ruby-lapack-1.7.2/0000755000175000017500000000000012655774405013606 5ustar uwabamiuwabamiruby-lapack-1.7.2/dev/0000755000175000017500000000000012655767602014365 5ustar uwabamiuwabamiruby-lapack-1.7.2/dev/defs/0000755000175000017500000000000012655767602015306 5ustar uwabamiuwabamiruby-lapack-1.7.2/dev/defs/zpstrf0000644000175000017500000000701512502223526016543 0ustar uwabamiuwabami--- :name: zpstrf :md5sum: f241adc9e5b2e3a5588055b546367490 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - piv: :type: integer :intent: output :dims: - n - rank: :type: integer :intent: output - tol: :type: doublereal :intent: input - work: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPSTRF computes the Cholesky factorization with complete\n\ * pivoting of a complex Hermitian positive semidefinite matrix A.\n\ *\n\ * The factorization has the form\n\ * P' * A * P = U' * U , if UPLO = 'U',\n\ * P' * A * P = L * L', if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is lower triangular, and\n\ * P is stored as vector PIV.\n\ *\n\ * This algorithm does not attempt to check that A is positive\n\ * semidefinite. This version of the algorithm calls level 3 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * n by n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n by n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the factor U or L from the Cholesky\n\ * factorization as above.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * PIV (output) INTEGER array, dimension (N)\n\ * PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n\ *\n\ * RANK (output) INTEGER\n\ * The rank of A given by the number of steps the algorithm\n\ * completed.\n\ *\n\ * TOL (input) DOUBLE PRECISION\n\ * User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) )\n\ * will be used. The algorithm terminates at the (K-1)st step\n\ * if the pivot <= TOL.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n\ * Work space.\n\ *\n\ * INFO (output) INTEGER\n\ * < 0: If INFO = -K, the K-th argument had an illegal value,\n\ * = 0: algorithm completed successfully, and\n\ * > 0: the matrix A is either rank deficient with computed rank\n\ * as returned in RANK, or is indefinite. See Section 7 of\n\ * LAPACK Working Note #161 for further information.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlarscl20000644000175000017500000000305112502223526016715 0ustar uwabamiuwabami--- :name: dlarscl2 :md5sum: ccf9a7110b886c2acac2362579620076 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - m - x: :type: doublereal :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE DLARSCL2 ( M, N, D, X, LDX )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLARSCL2 performs a reciprocal diagonal scaling on an vector:\n\ * x <-- inv(D) * x\n\ * where the diagonal matrix D is stored as a vector.\n\ *\n\ * Eventually to be replaced by BLAS_dge_diag_scale in the new BLAS\n\ * standard.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of D and X. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of D and X. N >= 0.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (M)\n\ * Diagonal matrix D, stored as a vector of length M.\n\ *\n\ * X (input/output) DOUBLE PRECISION array, dimension (LDX,N)\n\ * On entry, the vector X to be scaled by D.\n\ * On exit, the scaled vector.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the vector X. LDX >= 0.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/stpcon0000644000175000017500000000544712502223526016530 0ustar uwabamiuwabami--- :name: stpcon :md5sum: 67bae0432923c2a291efa3e2bea0d816 :category: :subroutine :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input :dims: - ldap - rcond: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE STPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STPCON estimates the reciprocal of the condition number of a packed\n\ * triangular matrix A, in either the 1-norm or the infinity-norm.\n\ *\n\ * The norm of A is computed and an estimate is obtained for\n\ * norm(inv(A)), then the reciprocal of the condition number is\n\ * computed as\n\ * RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies whether the 1-norm condition number or the\n\ * infinity-norm condition number is required:\n\ * = '1' or 'O': 1-norm;\n\ * = 'I': Infinity-norm.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input) REAL array, dimension (N*(N+1)/2)\n\ * The upper or lower triangular matrix A, packed columnwise in\n\ * a linear array. The j-th column of A is stored in the array\n\ * AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ * If DIAG = 'U', the diagonal elements of A are not referenced\n\ * and are assumed to be 1.\n\ *\n\ * RCOND (output) REAL\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(norm(A) * norm(inv(A))).\n\ *\n\ * WORK (workspace) REAL array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlapmr0000644000175000017500000000402512502223526016470 0ustar uwabamiuwabami--- :name: dlapmr :md5sum: b24c98083dc638c7e586e2e99b4a3ff4 :category: :subroutine :arguments: - forwrd: :type: logical :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input - k: :type: integer :intent: input/output :dims: - m :substitutions: {} :fortran_help: " SUBROUTINE DLAPMR( FORWRD, M, N, X, LDX, K )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAPMR rearranges the rows of the M by N matrix X as specified\n\ * by the permutation K(1),K(2),...,K(M) of the integers 1,...,M.\n\ * If FORWRD = .TRUE., forward permutation:\n\ *\n\ * X(K(I),*) is moved X(I,*) for I = 1,2,...,M.\n\ *\n\ * If FORWRD = .FALSE., backward permutation:\n\ *\n\ * X(I,*) is moved to X(K(I),*) for I = 1,2,...,M.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FORWRD (input) LOGICAL\n\ * = .TRUE., forward permutation\n\ * = .FALSE., backward permutation\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix X. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix X. N >= 0.\n\ *\n\ * X (input/output) DOUBLE PRECISION array, dimension (LDX,N)\n\ * On entry, the M by N matrix X.\n\ * On exit, X contains the permuted matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X, LDX >= MAX(1,M).\n\ *\n\ * K (input/output) INTEGER array, dimension (M)\n\ * On entry, K contains the permutation vector. K is used as\n\ * internal workspace, but reset to its original value on\n\ * output.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, IN, J, JJ\n DOUBLE PRECISION TEMP\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlarre0000644000175000017500000002231512502223526016464 0ustar uwabamiuwabami--- :name: dlarre :md5sum: 9747783e17f3023e920adbd7f058f053 :category: :subroutine :arguments: - range: :type: char :intent: input - n: :type: integer :intent: input - vl: :type: doublereal :intent: input/output - vu: :type: doublereal :intent: input/output - il: :type: integer :intent: input - iu: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n - e2: :type: doublereal :intent: input/output :dims: - n - rtol1: :type: doublereal :intent: input - rtol2: :type: doublereal :intent: input - spltol: :type: doublereal :intent: input - nsplit: :type: integer :intent: output - isplit: :type: integer :intent: output :dims: - n - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - werr: :type: doublereal :intent: output :dims: - n - wgap: :type: doublereal :intent: output :dims: - n - iblock: :type: integer :intent: output :dims: - n - indexw: :type: integer :intent: output :dims: - n - gers: :type: doublereal :intent: output :dims: - 2*n - pivmin: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 6*n - iwork: :type: integer :intent: workspace :dims: - 5*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLARRE( RANGE, N, VL, VU, IL, IU, D, E, E2, RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT, M, W, WERR, WGAP, IBLOCK, INDEXW, GERS, PIVMIN, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * To find the desired eigenvalues of a given real symmetric\n\ * tridiagonal matrix T, DLARRE sets any \"small\" off-diagonal\n\ * elements to zero, and for each unreduced block T_i, it finds\n\ * (a) a suitable shift at one end of the block's spectrum,\n\ * (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and\n\ * (c) eigenvalues of each L_i D_i L_i^T.\n\ * The representations and eigenvalues found are then used by\n\ * DSTEMR to compute the eigenvectors of T.\n\ * The accuracy varies depending on whether bisection is used to\n\ * find a few eigenvalues or the dqds algorithm (subroutine DLASQ2) to\n\ * conpute all and then discard any unwanted one.\n\ * As an added benefit, DLARRE also outputs the n\n\ * Gerschgorin intervals for the matrices L_i D_i L_i^T.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': (\"All\") all eigenvalues will be found.\n\ * = 'V': (\"Value\") all eigenvalues in the half-open interval\n\ * (VL, VU] will be found.\n\ * = 'I': (\"Index\") the IL-th through IU-th eigenvalues (of the\n\ * entire matrix) will be found.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N > 0.\n\ *\n\ * VL (input/output) DOUBLE PRECISION\n\ * VU (input/output) DOUBLE PRECISION\n\ * If RANGE='V', the lower and upper bounds for the eigenvalues.\n\ * Eigenvalues less than or equal to VL, or greater than VU,\n\ * will not be returned. VL < VU.\n\ * If RANGE='I' or ='A', DLARRE computes bounds on the desired\n\ * part of the spectrum.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the N diagonal elements of the tridiagonal\n\ * matrix T.\n\ * On exit, the N diagonal elements of the diagonal\n\ * matrices D_i.\n\ *\n\ * E (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the first (N-1) entries contain the subdiagonal\n\ * elements of the tridiagonal matrix T; E(N) need not be set.\n\ * On exit, E contains the subdiagonal elements of the unit\n\ * bidiagonal matrices L_i. The entries E( ISPLIT( I ) ),\n\ * 1 <= I <= NSPLIT, contain the base points sigma_i on output.\n\ *\n\ * E2 (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the first (N-1) entries contain the SQUARES of the\n\ * subdiagonal elements of the tridiagonal matrix T;\n\ * E2(N) need not be set.\n\ * On exit, the entries E2( ISPLIT( I ) ),\n\ * 1 <= I <= NSPLIT, have been set to zero\n\ *\n\ * RTOL1 (input) DOUBLE PRECISION\n\ * RTOL2 (input) DOUBLE PRECISION\n\ * Parameters for bisection.\n\ * An interval [LEFT,RIGHT] has converged if\n\ * RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n\ *\n\ * SPLTOL (input) DOUBLE PRECISION\n\ * The threshold for splitting.\n\ *\n\ * NSPLIT (output) INTEGER\n\ * The number of blocks T splits into. 1 <= NSPLIT <= N.\n\ *\n\ * ISPLIT (output) INTEGER array, dimension (N)\n\ * The splitting points, at which T breaks up into blocks.\n\ * The first block consists of rows/columns 1 to ISPLIT(1),\n\ * the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n\ * etc., and the NSPLIT-th consists of rows/columns\n\ * ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues (of all L_i D_i L_i^T)\n\ * found.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * The first M elements contain the eigenvalues. The\n\ * eigenvalues of each of the blocks, L_i D_i L_i^T, are\n\ * sorted in ascending order ( DLARRE may use the\n\ * remaining N-M elements as workspace).\n\ *\n\ * WERR (output) DOUBLE PRECISION array, dimension (N)\n\ * The error bound on the corresponding eigenvalue in W.\n\ *\n\ * WGAP (output) DOUBLE PRECISION array, dimension (N)\n\ * The separation from the right neighbor eigenvalue in W.\n\ * The gap is only with respect to the eigenvalues of the same block\n\ * as each block has its own representation tree.\n\ * Exception: at the right end of a block we store the left gap\n\ *\n\ * IBLOCK (output) INTEGER array, dimension (N)\n\ * The indices of the blocks (submatrices) associated with the\n\ * corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue\n\ * W(i) belongs to the first block from the top, =2 if W(i)\n\ * belongs to the second block, etc.\n\ *\n\ * INDEXW (output) INTEGER array, dimension (N)\n\ * The indices of the eigenvalues within each block (submatrix);\n\ * for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the\n\ * i-th eigenvalue W(i) is the 10-th eigenvalue in block 2\n\ *\n\ * GERS (output) DOUBLE PRECISION array, dimension (2*N)\n\ * The N Gerschgorin intervals (the i-th Gerschgorin interval\n\ * is (GERS(2*i-1), GERS(2*i)).\n\ *\n\ * PIVMIN (output) DOUBLE PRECISION\n\ * The minimum pivot in the Sturm sequence for T.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (6*N)\n\ * Workspace.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (5*N)\n\ * Workspace.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * > 0: A problem occured in DLARRE.\n\ * < 0: One of the called subroutines signaled an internal problem.\n\ * Needs inspection of the corresponding parameter IINFO\n\ * for further information.\n\ *\n\ * =-1: Problem in DLARRD.\n\ * = 2: No base representation could be found in MAXTRY iterations.\n\ * Increasing MAXTRY and recompilation might be a remedy.\n\ * =-3: Problem in DLARRB when computing the refined root\n\ * representation for DLASQ2.\n\ * =-4: Problem in DLARRB when preforming bisection on the\n\ * desired part of the spectrum.\n\ * =-5: Problem in DLASQ2.\n\ * =-6: Problem in DLASQ2.\n\ *\n\n\ * Further Details\n\ * The base representations are required to suffer very little\n\ * element growth and consequently define all their eigenvalues to\n\ * high relative accuracy.\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Beresford Parlett, University of California, Berkeley, USA\n\ * Jim Demmel, University of California, Berkeley, USA\n\ * Inderjit Dhillon, University of Texas, Austin, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, University of California, Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slapmt0000644000175000017500000000400612502223526016510 0ustar uwabamiuwabami--- :name: slapmt :md5sum: 26a344afe248a46fe200041a17590b53 :category: :subroutine :arguments: - forwrd: :type: logical :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input - k: :type: integer :intent: input/output :dims: - n :substitutions: {} :fortran_help: " SUBROUTINE SLAPMT( FORWRD, M, N, X, LDX, K )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAPMT rearranges the columns of the M by N matrix X as specified\n\ * by the permutation K(1),K(2),...,K(N) of the integers 1,...,N.\n\ * If FORWRD = .TRUE., forward permutation:\n\ *\n\ * X(*,K(J)) is moved X(*,J) for J = 1,2,...,N.\n\ *\n\ * If FORWRD = .FALSE., backward permutation:\n\ *\n\ * X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FORWRD (input) LOGICAL\n\ * = .TRUE., forward permutation\n\ * = .FALSE., backward permutation\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix X. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix X. N >= 0.\n\ *\n\ * X (input/output) REAL array, dimension (LDX,N)\n\ * On entry, the M by N matrix X.\n\ * On exit, X contains the permuted matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X, LDX >= MAX(1,M).\n\ *\n\ * K (input/output) INTEGER array, dimension (N)\n\ * On entry, K contains the permutation vector. K is used as\n\ * internal workspace, but reset to its original value on\n\ * output.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, II, J, IN\n REAL TEMP\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dpoequb0000644000175000017500000000507012502223526016651 0ustar uwabamiuwabami--- :name: dpoequb :md5sum: 8d069074f0a04dd639f60982c9143567 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - n - scond: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPOEQU computes row and column scalings intended to equilibrate a\n\ * symmetric positive definite matrix A and reduce its condition number\n\ * (with respect to the two-norm). S contains the scale factors,\n\ * S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n\ * elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n\ * choice of S puts the condition number of B within a factor N of the\n\ * smallest possible condition number over all possible diagonal\n\ * scalings.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The N-by-N symmetric positive definite matrix whose scaling\n\ * factors are to be computed. Only the diagonal elements of A\n\ * are referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * S (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, S contains the scale factors for A.\n\ *\n\ * SCOND (output) DOUBLE PRECISION\n\ * If INFO = 0, S contains the ratio of the smallest S(i) to\n\ * the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n\ * large nor too small, it is not worth scaling by S.\n\ *\n\ * AMAX (output) DOUBLE PRECISION\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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 is nonpositive.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ilaslr0000644000175000017500000000177712502223526016512 0ustar uwabamiuwabami--- :name: ilaslr :md5sum: 20012d009aecf6412a055e523aafddd2 :category: :function :type: integer :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " INTEGER FUNCTION ILASLR( M, N, A, LDA )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ILASLR scans A for its last non-zero row.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix A.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * 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\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slansp0000644000175000017500000000544612502223526016521 0ustar uwabamiuwabami--- :name: slansp :md5sum: 5f100ca86e29bd04042b892b3d73567a :category: :function :type: real :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input :dims: - n*(n+1)/2 - work: :type: real :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " REAL FUNCTION SLANSP( NORM, UPLO, N, AP, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLANSP returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * real symmetric matrix A, supplied in packed form.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * SLANSP returns the value\n\ *\n\ * SLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in SLANSP as described\n\ * above.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is supplied.\n\ * = 'U': Upper triangular part of A is supplied\n\ * = 'L': Lower triangular part of A is supplied\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, SLANSP is\n\ * set to zero.\n\ *\n\ * AP (input) REAL array, dimension (N*(N+1)/2)\n\ * The upper or lower triangle of the symmetric matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n\ * WORK is not referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chgeqz0000644000175000017500000002234112502223525016472 0ustar uwabamiuwabami--- :name: chgeqz :md5sum: 8994134138840bb33bb79c034bde7992 :category: :subroutine :arguments: - job: :type: char :intent: input - compq: :type: char :intent: input - compz: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: complex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - t: :type: complex :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - alpha: :type: complex :intent: output :dims: - n - beta: :type: complex :intent: output :dims: - n - q: :type: complex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - z: :type: complex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHGEQZ computes the eigenvalues of a complex matrix pair (H,T),\n\ * where H is an upper Hessenberg matrix and T is upper triangular,\n\ * using the single-shift QZ method.\n\ * Matrix pairs of this type are produced by the reduction to\n\ * generalized upper Hessenberg form of a complex matrix pair (A,B):\n\ * \n\ * A = Q1*H*Z1**H, B = Q1*T*Z1**H,\n\ * \n\ * as computed by CGGHRD.\n\ * \n\ * If JOB='S', then the Hessenberg-triangular pair (H,T) is\n\ * also reduced to generalized Schur form,\n\ * \n\ * H = Q*S*Z**H, T = Q*P*Z**H,\n\ * \n\ * where Q and Z are unitary matrices and S and P are upper triangular.\n\ * \n\ * Optionally, the unitary matrix Q from the generalized Schur\n\ * factorization may be postmultiplied into an input matrix Q1, and the\n\ * unitary matrix Z may be postmultiplied into an input matrix Z1.\n\ * If Q1 and Z1 are the unitary matrices from CGGHRD that reduced\n\ * the matrix pair (A,B) to generalized Hessenberg form, then the output\n\ * matrices Q1*Q and Z1*Z are the unitary factors from the generalized\n\ * Schur factorization of (A,B):\n\ * \n\ * A = (Q1*Q)*S*(Z1*Z)**H, B = (Q1*Q)*P*(Z1*Z)**H.\n\ * \n\ * To avoid overflow, eigenvalues of the matrix pair (H,T)\n\ * (equivalently, of (A,B)) are computed as a pair of complex values\n\ * (alpha,beta). If beta is nonzero, lambda = alpha / beta is an\n\ * eigenvalue of the generalized nonsymmetric eigenvalue problem (GNEP)\n\ * A*x = lambda*B*x\n\ * and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the\n\ * alternate form of the GNEP\n\ * mu*A*y = B*y.\n\ * The values of alpha and beta for the i-th eigenvalue can be read\n\ * directly from the generalized Schur form: alpha = S(i,i),\n\ * beta = P(i,i).\n\ *\n\ * Ref: C.B. Moler & G.W. Stewart, \"An Algorithm for Generalized Matrix\n\ * Eigenvalue Problems\", SIAM J. Numer. Anal., 10(1973),\n\ * pp. 241--256.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * = 'E': Compute eigenvalues only;\n\ * = 'S': Computer eigenvalues and the Schur form.\n\ *\n\ * COMPQ (input) CHARACTER*1\n\ * = 'N': Left Schur vectors (Q) are not computed;\n\ * = 'I': Q is initialized to the unit matrix and the matrix Q\n\ * of left Schur vectors of (H,T) is returned;\n\ * = 'V': Q must contain a unitary matrix Q1 on entry and\n\ * the product Q1*Q is returned.\n\ *\n\ * COMPZ (input) CHARACTER*1\n\ * = 'N': Right Schur vectors (Z) are not computed;\n\ * = 'I': Q is initialized to the unit matrix and the matrix Z\n\ * of right Schur vectors of (H,T) is returned;\n\ * = 'V': Z must contain a unitary matrix Z1 on entry and\n\ * the product Z1*Z is returned.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices H, T, Q, and Z. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * ILO and IHI mark the rows and columns of H which are in\n\ * Hessenberg form. It is assumed that A is already upper\n\ * triangular in rows and columns 1:ILO-1 and IHI+1:N.\n\ * If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.\n\ *\n\ * H (input/output) COMPLEX array, dimension (LDH, N)\n\ * On entry, the N-by-N upper Hessenberg matrix H.\n\ * On exit, if JOB = 'S', H contains the upper triangular\n\ * matrix S from the generalized Schur factorization.\n\ * If JOB = 'E', the diagonal of H matches that of S, but\n\ * the rest of H is unspecified.\n\ *\n\ * LDH (input) INTEGER\n\ * The leading dimension of the array H. LDH >= max( 1, N ).\n\ *\n\ * T (input/output) COMPLEX array, dimension (LDT, N)\n\ * On entry, the N-by-N upper triangular matrix T.\n\ * On exit, if JOB = 'S', T contains the upper triangular\n\ * matrix P from the generalized Schur factorization.\n\ * If JOB = 'E', the diagonal of T matches that of P, but\n\ * the rest of T is unspecified.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= max( 1, N ).\n\ *\n\ * ALPHA (output) COMPLEX array, dimension (N)\n\ * The complex scalars alpha that define the eigenvalues of\n\ * GNEP. ALPHA(i) = S(i,i) in the generalized Schur\n\ * factorization.\n\ *\n\ * BETA (output) COMPLEX array, dimension (N)\n\ * The real non-negative scalars beta that define the\n\ * eigenvalues of GNEP. BETA(i) = P(i,i) in the generalized\n\ * Schur factorization.\n\ *\n\ * Together, the quantities alpha = ALPHA(j) and beta = BETA(j)\n\ * represent the j-th eigenvalue of the matrix pair (A,B), in\n\ * one of the forms lambda = alpha/beta or mu = beta/alpha.\n\ * Since either lambda or mu may overflow, they should not,\n\ * in general, be computed.\n\ *\n\ * Q (input/output) COMPLEX array, dimension (LDQ, N)\n\ * On entry, if COMPZ = 'V', the unitary matrix Q1 used in the\n\ * reduction of (A,B) to generalized Hessenberg form.\n\ * On exit, if COMPZ = 'I', the unitary matrix of left Schur\n\ * vectors of (H,T), and if COMPZ = 'V', the unitary matrix of\n\ * left Schur vectors of (A,B).\n\ * Not referenced if COMPZ = 'N'.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= 1.\n\ * If COMPQ='V' or 'I', then LDQ >= N.\n\ *\n\ * Z (input/output) COMPLEX array, dimension (LDZ, N)\n\ * On entry, if COMPZ = 'V', the unitary matrix Z1 used in the\n\ * reduction of (A,B) to generalized Hessenberg form.\n\ * On exit, if COMPZ = 'I', the unitary matrix of right Schur\n\ * vectors of (H,T), and if COMPZ = 'V', the unitary matrix of\n\ * right Schur vectors of (A,B).\n\ * Not referenced if COMPZ = 'N'.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1.\n\ * If COMPZ='V' or 'I', then LDZ >= N.\n\ *\n\ * WORK (workspace/output) COMPLEX 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,N).\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\ * RWORK (workspace) REAL array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * = 1,...,N: the QZ iteration did not converge. (H,T) is not\n\ * in Schur form, but ALPHA(i) and BETA(i),\n\ * i=INFO+1,...,N should be correct.\n\ * = N+1,...,2*N: the shift calculation failed. (H,T) is not\n\ * in Schur form, but ALPHA(i) and BETA(i),\n\ * i=INFO-N+1,...,N should be correct.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * We assume that complex ABS works as long as its value is less than\n\ * overflow.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dtpttr0000644000175000017500000000446012502223526016535 0ustar uwabamiuwabami--- :name: dtpttr :md5sum: 2013b72664e417c2618b1d7b80ef088a :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - ldap - a: :type: doublereal :intent: output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: lda: MAX(1,n) n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE DTPTTR( UPLO, N, AP, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTPTTR copies a triangular matrix A from standard packed format (TP)\n\ * to standard full format (TR).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular.\n\ * = 'L': A is lower triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ),\n\ * On entry, the upper or lower triangular matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * A (output) DOUBLE PRECISION array, dimension ( LDA, N )\n\ * On exit, the triangular matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlartv0000644000175000017500000000423012502223526016503 0ustar uwabamiuwabami--- :name: dlartv :md5sum: 4f0bf90dcdf7a26f49b5a73714cdf127 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - y: :type: doublereal :intent: input/output :dims: - 1+(n-1)*incy - incy: :type: integer :intent: input - c: :type: doublereal :intent: input :dims: - 1+(n-1)*incc - s: :type: doublereal :intent: input :dims: - 1+(n-1)*incc - incc: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE DLARTV( N, X, INCX, Y, INCY, C, S, INCC )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLARTV applies a vector of real plane rotations to elements of the\n\ * real vectors x and y. For i = 1,2,...,n\n\ *\n\ * ( x(i) ) := ( c(i) s(i) ) ( x(i) )\n\ * ( y(i) ) ( -s(i) c(i) ) ( y(i) )\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of plane rotations to be applied.\n\ *\n\ * X (input/output) DOUBLE PRECISION array,\n\ * dimension (1+(N-1)*INCX)\n\ * The vector x.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between elements of X. INCX > 0.\n\ *\n\ * Y (input/output) DOUBLE PRECISION array,\n\ * dimension (1+(N-1)*INCY)\n\ * The vector y.\n\ *\n\ * INCY (input) INTEGER\n\ * The increment between elements of Y. INCY > 0.\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)\n\ * The cosines of the plane rotations.\n\ *\n\ * S (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)\n\ * The sines of the plane rotations.\n\ *\n\ * INCC (input) INTEGER\n\ * The increment between elements of C and S. INCC > 0.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, IC, IX, IY\n DOUBLE PRECISION XI, YI\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sgbequ0000644000175000017500000000737212502223526016507 0ustar uwabamiuwabami--- :name: sgbequ :md5sum: e05049ad6bde32cc4308286b8c0a3d8e :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - r: :type: real :intent: output :dims: - MAX(1,m) - c: :type: real :intent: output :dims: - n - rowcnd: :type: real :intent: output - colcnd: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGBEQU computes row and column scalings intended to equilibrate an\n\ * M-by-N band matrix A and reduce its condition number. R returns the\n\ * row scale factors and C the column scale factors, chosen to try to\n\ * make the largest element in each row and column of the matrix B with\n\ * elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n\ *\n\ * R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n\ * number and BIGNUM = largest safe number. Use of these scaling\n\ * factors is not guaranteed to reduce the condition number of A but\n\ * works well in practice.\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\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * AB (input) REAL array, dimension (LDAB,N)\n\ * The band matrix A, stored in rows 1 to KL+KU+1. The j-th\n\ * column of A is stored in the j-th column of the array AB as\n\ * follows:\n\ * AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * R (output) REAL array, dimension (M)\n\ * If INFO = 0, or INFO > M, R contains the row scale factors\n\ * for A.\n\ *\n\ * C (output) REAL array, dimension (N)\n\ * If INFO = 0, C contains the column scale factors for A.\n\ *\n\ * ROWCND (output) REAL\n\ * If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n\ * smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n\ * AMAX is neither too large nor too small, it is not worth\n\ * scaling by R.\n\ *\n\ * COLCND (output) REAL\n\ * If INFO = 0, COLCND contains the ratio of the smallest\n\ * C(i) to the largest C(i). If COLCND >= 0.1, it is not\n\ * worth scaling by C.\n\ *\n\ * AMAX (output) REAL\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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, and i is\n\ * <= M: the i-th row of A is exactly zero\n\ * > M: the (i-M)-th column of A is exactly zero\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgerfsx0000644000175000017500000004032412502223526016655 0ustar uwabamiuwabami--- :name: dgerfsx :md5sum: ebbb73fcc0262d3a5b61f65f235f8830 :category: :subroutine :arguments: - trans: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - r: :type: doublereal :intent: input :dims: - n - c: :type: doublereal :intent: input :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublereal :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " SUBROUTINE DGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGERFSX improves the computed solution to a system of linear\n\ * equations and provides error bounds and backward error estimates\n\ * for the solution. In addition to normwise error bound, the code\n\ * provides maximum componentwise error bound if possible. See\n\ * comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n\ * error bounds.\n\ *\n\ * The original system of linear equations may have been equilibrated\n\ * before calling this routine, as described by arguments EQUED, R\n\ * and C below. In this case, the solution and error bounds returned\n\ * are for the original unequilibrated system.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose = Transpose)\n\ *\n\ * EQUED (input) CHARACTER*1\n\ * Specifies the form of equilibration that was done to A\n\ * before calling this routine. This is needed to compute\n\ * the solution and error bounds correctly.\n\ * = 'N': No equilibration\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ * The right hand side B has been changed accordingly.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The original N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n\ * The factors L and U from the factorization A = P*L*U\n\ * as computed by DGETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from DGETRF; for 1<=i<=N, row i of the\n\ * matrix was interchanged with row IPIV(i).\n\ *\n\ * R (input) DOUBLE PRECISION array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'R' or 'B', A is\n\ * multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n\ * is not accessed. \n\ * If R is accessed, each element of R should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension (N)\n\ * The column scale factors for A. If EQUED = 'C' or 'B', A is\n\ * multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n\ * is not accessed. \n\ * If C is accessed, each element of C should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by DGETRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * Componentwise relative backward error. This is the\n\ * componentwise relative backward error of each solution vector X(j)\n\ * (i.e., the smallest relative change in any element of A or B that\n\ * makes X(j) an exact solution).\n\ *\n\ * N_ERR_BNDS (input) INTEGER\n\ * Number of error bounds to return for each right hand side\n\ * and each type (normwise or componentwise). See ERR_BNDS_NORM and\n\ * ERR_BNDS_COMP below.\n\ *\n\ * ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * dlamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * dlamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * dlamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * dlamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * dlamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * dlamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * NPARAMS (input) INTEGER\n\ * Specifies the number of parameters set in PARAMS. If .LE. 0, the\n\ * PARAMS array is never referenced and default values are used.\n\ *\n\ * PARAMS (input / output) DOUBLE PRECISION array, dimension (NPARAMS)\n\ * Specifies algorithm parameters. If an entry is .LT. 0.0, then\n\ * that entry will be filled with default value used for that\n\ * parameter. Only positions up to NPARAMS are accessed; defaults\n\ * are used for higher-numbered parameters.\n\ *\n\ * PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n\ * refinement or not.\n\ * Default: 1.0D+0\n\ * = 0.0 : No refinement is performed, and no error bounds are\n\ * computed.\n\ * = 1.0 : Use the double-precision refinement algorithm,\n\ * possibly with doubled-single computations if the\n\ * compilation environment does not support DOUBLE\n\ * PRECISION.\n\ * (other values are reserved for future use)\n\ *\n\ * PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n\ * computations allowed for refinement.\n\ * Default: 10\n\ * Aggressive: Set to 100 to permit convergence using approximate\n\ * factorizations or factorizations other than LU. If\n\ * the factorization uses a technique other than\n\ * Gaussian elimination, the guarantees in\n\ * err_bnds_norm and err_bnds_comp may no longer be\n\ * trustworthy.\n\ *\n\ * PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n\ * will attempt to find a solution with small componentwise\n\ * relative error in the double-precision algorithm. Positive\n\ * is true, 0.0 is false.\n\ * Default: 1.0 (attempt componentwise convergence)\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit. The solution to every right-hand side is\n\ * guaranteed.\n\ * < 0: If INFO = -i, the i-th argument had an illegal value\n\ * > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zstein0000644000175000017500000001211112502223526016520 0ustar uwabamiuwabami--- :name: zstein :md5sum: e31fefcd280e4ed544d4a3d6fa703ad2 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublereal :intent: input :dims: - n-1 - m: :type: integer :intent: input - w: :type: doublereal :intent: input :dims: - n - iblock: :type: integer :intent: input :dims: - n - isplit: :type: integer :intent: input :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - m - ldz: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 5*n - iwork: :type: integer :intent: workspace :dims: - n - ifail: :type: integer :intent: output :dims: - m - info: :type: integer :intent: output :substitutions: ldz: MAX(1,n) m: n :fortran_help: " SUBROUTINE ZSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSTEIN computes the eigenvectors of a real symmetric tridiagonal\n\ * matrix T corresponding to specified eigenvalues, using inverse\n\ * iteration.\n\ *\n\ * The maximum number of iterations allowed for each eigenvector is\n\ * specified by an internal parameter MAXITS (currently set to 5).\n\ *\n\ * Although the eigenvectors are real, they are stored in a complex\n\ * array, which may be passed to ZUNMTR or ZUPMTR for back\n\ * transformation to the eigenvectors of a complex Hermitian matrix\n\ * which was reduced to tridiagonal form.\n\ *\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The n diagonal elements of the tridiagonal matrix T.\n\ *\n\ * E (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) subdiagonal elements of the tridiagonal matrix\n\ * T, stored in elements 1 to N-1.\n\ *\n\ * M (input) INTEGER\n\ * The number of eigenvectors to be found. 0 <= M <= N.\n\ *\n\ * W (input) DOUBLE PRECISION array, dimension (N)\n\ * The first M elements of W contain the eigenvalues for\n\ * which eigenvectors are to be computed. The eigenvalues\n\ * should be grouped by split-off block and ordered from\n\ * smallest to largest within the block. ( The output array\n\ * W from DSTEBZ with ORDER = 'B' is expected here. )\n\ *\n\ * IBLOCK (input) INTEGER array, dimension (N)\n\ * The submatrix indices associated with the corresponding\n\ * eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to\n\ * the first submatrix from the top, =2 if W(i) belongs to\n\ * the second submatrix, etc. ( The output array IBLOCK\n\ * from DSTEBZ is expected here. )\n\ *\n\ * ISPLIT (input) INTEGER array, dimension (N)\n\ * The splitting points, at which T breaks up into submatrices.\n\ * The first submatrix consists of rows/columns 1 to\n\ * ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n\ * through ISPLIT( 2 ), etc.\n\ * ( The output array ISPLIT from DSTEBZ is expected here. )\n\ *\n\ * Z (output) COMPLEX*16 array, dimension (LDZ, M)\n\ * The computed eigenvectors. The eigenvector associated\n\ * with the eigenvalue W(i) is stored in the i-th column of\n\ * Z. Any vector which fails to converge is set to its current\n\ * iterate after MAXITS iterations.\n\ * The imaginary parts of the eigenvectors are set to zero.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (5*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * IFAIL (output) INTEGER array, dimension (M)\n\ * On normal exit, all elements of IFAIL are zero.\n\ * If one or more eigenvectors fail to converge after\n\ * MAXITS iterations, then their indices are stored in\n\ * array IFAIL.\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, then i eigenvectors failed to converge\n\ * in MAXITS iterations. Their indices are stored in\n\ * array IFAIL.\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * MAXITS INTEGER, default = 5\n\ * The maximum number of iterations performed.\n\ *\n\ * EXTRA INTEGER, default = 2\n\ * The number of iterations performed after norm growth\n\ * criterion is satisfied, should be at least 1.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhegst0000644000175000017500000000576112502223526016525 0ustar uwabamiuwabami--- :name: zhegst :md5sum: c20dbdb32438b9794fb86eb0c5c5348d :category: :subroutine :arguments: - itype: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHEGST reduces a complex Hermitian-definite generalized\n\ * eigenproblem to standard form.\n\ *\n\ * If ITYPE = 1, the problem is A*x = lambda*B*x,\n\ * and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)\n\ *\n\ * If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n\ * B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L.\n\ *\n\ * B must have been previously factorized as U**H*U or L*L**H by ZPOTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);\n\ * = 2 or 3: compute U*A*U**H or L**H*A*L.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored and B is factored as\n\ * U**H*U;\n\ * = 'L': Lower triangle of A is stored and B is factored as\n\ * L*L**H.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the transformed matrix, stored in the\n\ * same format as A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,N)\n\ * The triangular factor from the Cholesky factorization of B,\n\ * as returned by ZPOTRF.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgebal0000644000175000017500000001043212502223526016454 0ustar uwabamiuwabami--- :name: zgebal :md5sum: 29bd7a53ad4bc2dbc8daccd7f385fcb5 :category: :subroutine :arguments: - job: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - scale: :type: doublereal :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGEBAL balances a general complex matrix A. This involves, first,\n\ * permuting A by a similarity transformation to isolate eigenvalues\n\ * in the first 1 to ILO-1 and last IHI+1 to N elements on the\n\ * diagonal; and second, applying a diagonal similarity transformation\n\ * to rows and columns ILO to IHI to make the rows and columns as\n\ * close in norm as possible. Both steps are optional.\n\ *\n\ * Balancing may reduce the 1-norm of the matrix, and improve the\n\ * accuracy of the computed eigenvalues and/or eigenvectors.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * Specifies the operations to be performed on A:\n\ * = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0\n\ * for i = 1,...,N;\n\ * = 'P': permute only;\n\ * = 'S': scale only;\n\ * = 'B': both permute and scale.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the input matrix A.\n\ * On exit, A is overwritten by the balanced matrix.\n\ * If JOB = 'N', A is not referenced.\n\ * See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * ILO (output) INTEGER\n\ * IHI (output) INTEGER\n\ * ILO and IHI are set to integers such that on exit\n\ * A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.\n\ * If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n\ *\n\ * SCALE (output) DOUBLE PRECISION array, dimension (N)\n\ * Details of the permutations and scaling factors applied to\n\ * A. If P(j) is the index of the row and column interchanged\n\ * with row and column j and D(j) is the scaling factor\n\ * applied to row and column j, then\n\ * SCALE(j) = P(j) for j = 1,...,ILO-1\n\ * = D(j) for j = ILO,...,IHI\n\ * = P(j) for j = IHI+1,...,N.\n\ * The order in which the interchanges are made is N to IHI+1,\n\ * then 1 to ILO-1.\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 permutations consist of row and column interchanges which put\n\ * the matrix in the form\n\ *\n\ * ( T1 X Y )\n\ * P A P = ( 0 B Z )\n\ * ( 0 0 T2 )\n\ *\n\ * where T1 and T2 are upper triangular matrices whose eigenvalues lie\n\ * along the diagonal. The column indices ILO and IHI mark the starting\n\ * and ending columns of the submatrix B. Balancing consists of applying\n\ * a diagonal similarity transformation inv(D) * B * D to make the\n\ * 1-norms of each row of B and its corresponding column nearly equal.\n\ * The output matrix is\n\ *\n\ * ( T1 X*D Y )\n\ * ( 0 inv(D)*B*D inv(D)*Z ).\n\ * ( 0 0 T2 )\n\ *\n\ * Information about the permutations P and the diagonal matrix D is\n\ * returned in the vector SCALE.\n\ *\n\ * This subroutine is based on the EISPACK routine CBAL.\n\ *\n\ * Modified by Tzu-Yi Chen, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlarcm0000644000175000017500000000424212502223526016502 0ustar uwabamiuwabami--- :name: zlarcm :md5sum: 56086b8d732437efd20f5eb5f4efa2ea :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - m - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: doublecomplex :intent: output :dims: - ldc - n - ldc: :type: integer :intent: input - rwork: :type: doublereal :intent: workspace :dims: - 2*m*n :substitutions: ldc: MAX(1,m) :fortran_help: " SUBROUTINE ZLARCM( M, N, A, LDA, B, LDB, C, LDC, RWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLARCM performs a very simple matrix-matrix multiplication:\n\ * C := A * B,\n\ * where A is M by M and real; B is M by N and complex;\n\ * C is M by N and complex.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A and of the matrix C.\n\ * M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns and rows of the matrix B and\n\ * the number of columns of the matrix C.\n\ * N >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA, M)\n\ * A contains the M by M matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >=max(1,M).\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB, N)\n\ * B contains the M by N matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >=max(1,M).\n\ *\n\ * C (input) COMPLEX*16 array, dimension (LDC, N)\n\ * C contains the M by N matrix C.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >=max(1,M).\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (2*M*N)\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlansy0000644000175000017500000000615712502223526016513 0ustar uwabamiuwabami--- :name: dlansy :md5sum: 78d7f9a5930b4f926c5af132c0fb33be :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLANSY returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * real symmetric matrix A.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * DLANSY returns the value\n\ *\n\ * DLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in DLANSY as described\n\ * above.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is to be referenced.\n\ * = 'U': Upper triangular part of A is referenced\n\ * = 'L': Lower triangular part of A is referenced\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, DLANSY is\n\ * set to zero.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The symmetric matrix A. If UPLO = 'U', the leading n by n\n\ * upper triangular part of A contains the upper triangular part\n\ * of the matrix A, and the strictly lower triangular part of A\n\ * is not referenced. If UPLO = 'L', the leading n by n lower\n\ * triangular part of A contains the lower triangular part of\n\ * the matrix A, and the strictly upper triangular part of A is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(N,1).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n\ * WORK is not referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssbtrd0000644000175000017500000001001312502223526016504 0ustar uwabamiuwabami--- :name: ssbtrd :md5sum: 4d2b2c94a4720f12c22cbd1420997ff4 :category: :subroutine :arguments: - vect: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - d: :type: real :intent: output :dims: - n - e: :type: real :intent: output :dims: - n-1 - q: :type: real :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SSBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSBTRD reduces a real symmetric band matrix A to symmetric\n\ * tridiagonal form T by an orthogonal similarity transformation:\n\ * Q**T * A * Q = T.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * VECT (input) CHARACTER*1\n\ * = 'N': do not form Q;\n\ * = 'V': form Q;\n\ * = 'U': update a matrix X, by forming X*Q.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) REAL array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ * On exit, the diagonal elements of AB are overwritten by the\n\ * diagonal elements of the tridiagonal matrix T; if KD > 0, the\n\ * elements on the first superdiagonal (if UPLO = 'U') or the\n\ * first subdiagonal (if UPLO = 'L') are overwritten by the\n\ * off-diagonal elements of T; the rest of AB is overwritten by\n\ * values generated during the reduction.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * D (output) REAL array, dimension (N)\n\ * The diagonal elements of the tridiagonal matrix T.\n\ *\n\ * E (output) REAL array, dimension (N-1)\n\ * The off-diagonal elements of the tridiagonal matrix T:\n\ * E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.\n\ *\n\ * Q (input/output) REAL array, dimension (LDQ,N)\n\ * On entry, if VECT = 'U', then Q must contain an N-by-N\n\ * matrix X; if VECT = 'N' or 'V', then Q need not be set.\n\ *\n\ * On exit:\n\ * if VECT = 'V', Q contains the N-by-N orthogonal matrix Q;\n\ * if VECT = 'U', Q contains the product X*Q;\n\ * if VECT = 'N', the array Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q.\n\ * LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.\n\ *\n\ * WORK (workspace) REAL array, dimension (N)\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\ * Modified by Linda Kaufman, Bell Labs.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cpptrs0000644000175000017500000000517212502223525016527 0ustar uwabamiuwabami--- :name: cpptrs :md5sum: a5d4c77afe8b8f87c48b32cd50b42f9e :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPPTRS solves a system of linear equations A*X = B with a Hermitian\n\ * positive definite matrix A in packed storage using the Cholesky\n\ * factorization A = U**H*U or A = L*L**H computed by CPPTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AP (input) COMPLEX array, dimension (N*(N+1)/2)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**H*U or A = L*L**H, packed columnwise in a linear\n\ * array. The j-th column of U or L is stored in the array AP\n\ * as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL UPPER\n INTEGER I\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CTPSV, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/ssycon0000644000175000017500000000537712502223526016542 0ustar uwabamiuwabami--- :name: ssycon :md5sum: a6c3acc99557360e216bc35bcb78abd5 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 2*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSYCON estimates the reciprocal of the condition number (in the\n\ * 1-norm) of a real symmetric matrix A using the factorization\n\ * A = U*D*U**T or A = L*D*L**T computed by SSYTRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by SSYTRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by SSYTRF.\n\ *\n\ * ANORM (input) REAL\n\ * The 1-norm of the original matrix A.\n\ *\n\ * RCOND (output) REAL\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n\ * estimate of the 1-norm of inv(A) computed in this routine.\n\ *\n\ * WORK (workspace) REAL array, dimension (2*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zpocon0000644000175000017500000000475712502223526016535 0ustar uwabamiuwabami--- :name: zpocon :md5sum: 732372d3f7464a9247ca90003ad28437 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPOCON estimates the reciprocal of the condition number (in the\n\ * 1-norm) of a complex Hermitian positive definite matrix using the\n\ * Cholesky factorization A = U**H*U or A = L*L**H computed by ZPOTRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**H*U or A = L*L**H, as computed by ZPOTRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * ANORM (input) DOUBLE PRECISION\n\ * The 1-norm (or infinity-norm) of the Hermitian matrix A.\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n\ * estimate of the 1-norm of inv(A) computed in this routine.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlabrd0000644000175000017500000001471212502223526016473 0ustar uwabamiuwabami--- :name: zlabrd :md5sum: 162a9368de85a7bfb4b6ba8b9e25a27f :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - MAX(1,nb) - e: :type: doublereal :intent: output :dims: - MAX(1,nb) - tauq: :type: doublecomplex :intent: output :dims: - MAX(1,nb) - taup: :type: doublecomplex :intent: output :dims: - MAX(1,nb) - x: :type: doublecomplex :intent: output :dims: - ldx - MAX(1,nb) - ldx: :type: integer :intent: input - y: :type: doublecomplex :intent: output :dims: - ldy - MAX(1,nb) - ldy: :type: integer :intent: input :substitutions: ldx: MAX(1,m) ldy: MAX(1,n) :fortran_help: " SUBROUTINE ZLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, LDY )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLABRD reduces the first NB rows and columns of a complex general\n\ * m by n matrix A to upper or lower real bidiagonal form by a unitary\n\ * transformation Q' * A * P, and returns the matrices X and Y which\n\ * are needed to apply the transformation to the unreduced part of A.\n\ *\n\ * If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower\n\ * bidiagonal form.\n\ *\n\ * This is an auxiliary routine called by ZGEBRD\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows in the matrix A.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns in the matrix A.\n\ *\n\ * NB (input) INTEGER\n\ * The number of leading rows and columns of A to be reduced.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the m by n general matrix to be reduced.\n\ * On exit, the first NB rows and columns of the matrix are\n\ * overwritten; the rest of the array is unchanged.\n\ * If m >= n, elements on and below the diagonal in the first NB\n\ * columns, with the array TAUQ, represent the unitary\n\ * matrix Q as a product of elementary reflectors; and\n\ * elements above the diagonal in the first NB rows, with the\n\ * array TAUP, represent the unitary matrix P as a product\n\ * of elementary reflectors.\n\ * If m < n, elements below the diagonal in the first NB\n\ * columns, with the array TAUQ, represent the unitary\n\ * matrix Q as a product of elementary reflectors, and\n\ * elements on and above the diagonal in the first NB rows,\n\ * with the array TAUP, represent the unitary matrix P as\n\ * a product of elementary reflectors.\n\ * See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * D (output) DOUBLE PRECISION array, dimension (NB)\n\ * The diagonal elements of the first NB rows and columns of\n\ * the reduced matrix. D(i) = A(i,i).\n\ *\n\ * E (output) DOUBLE PRECISION array, dimension (NB)\n\ * The off-diagonal elements of the first NB rows and columns of\n\ * the reduced matrix.\n\ *\n\ * TAUQ (output) COMPLEX*16 array dimension (NB)\n\ * The scalar factors of the elementary reflectors which\n\ * represent the unitary matrix Q. See Further Details.\n\ *\n\ * TAUP (output) COMPLEX*16 array, dimension (NB)\n\ * The scalar factors of the elementary reflectors which\n\ * represent the unitary matrix P. See Further Details.\n\ *\n\ * X (output) COMPLEX*16 array, dimension (LDX,NB)\n\ * The m-by-nb matrix X required to update the unreduced part\n\ * of A.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,M).\n\ *\n\ * Y (output) COMPLEX*16 array, dimension (LDY,NB)\n\ * The n-by-nb matrix Y required to update the unreduced part\n\ * of A.\n\ *\n\ * LDY (input) INTEGER\n\ * The leading dimension of the array Y. LDY >= max(1,N).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The matrices Q and P are represented as products of elementary\n\ * reflectors:\n\ *\n\ * Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb)\n\ *\n\ * Each H(i) and G(i) has the form:\n\ *\n\ * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n\ *\n\ * where tauq and taup are complex scalars, and v and u are complex\n\ * vectors.\n\ *\n\ * If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in\n\ * A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in\n\ * A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n\ *\n\ * If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in\n\ * A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in\n\ * A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n\ *\n\ * The elements of the vectors v and u together form the m-by-nb matrix\n\ * V and the nb-by-n matrix U' which are needed, with X and Y, to apply\n\ * the transformation to the unreduced part of the matrix, using a block\n\ * update of the form: A := A - V*Y' - X*U'.\n\ *\n\ * The contents of A on exit are illustrated by the following examples\n\ * with nb = 2:\n\ *\n\ * m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n\ *\n\ * ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 )\n\ * ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 )\n\ * ( v1 v2 a a a ) ( v1 1 a a a a )\n\ * ( v1 v2 a a a ) ( v1 v2 a a a a )\n\ * ( v1 v2 a a a ) ( v1 v2 a a a a )\n\ * ( v1 v2 a a a )\n\ *\n\ * where a denotes an element of the original matrix which is unchanged,\n\ * vi denotes an element of the vector defining H(i), and ui an element\n\ * of the vector defining G(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/stgsen0000644000175000017500000004146012502223526016520 0ustar uwabamiuwabami--- :name: stgsen :md5sum: 679c7e17ebcfb834ce7dd42f2eb8a2b1 :category: :subroutine :arguments: - ijob: :type: integer :intent: input - wantq: :type: logical :intent: input - wantz: :type: logical :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alphar: :type: real :intent: output :dims: - n - alphai: :type: real :intent: output :dims: - n - beta: :type: real :intent: output :dims: - n - q: :type: real :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - z: :type: real :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - m: :type: integer :intent: output - pl: :type: real :intent: output - pr: :type: real :intent: output - dif: :type: real :intent: output :dims: - "2" - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(ijob==1||ijob==2||ijob==4) ? MAX(4*n+16,2*m*(n-m)) : (ijob==3||ijob==5) ? MAX(4*n+16,4*m*(n-m)) : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "(ijob==1||ijob==2||ijob==4) ? n+6 : (ijob==3||ijob==5) ? MAX(2*m*(n-m),n+6) : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE STGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STGSEN reorders the generalized real Schur decomposition of a real\n\ * matrix pair (A, B) (in terms of an orthonormal equivalence trans-\n\ * formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues\n\ * appears in the leading diagonal blocks of the upper quasi-triangular\n\ * matrix A and the upper triangular B. The leading columns of Q and\n\ * Z form orthonormal bases of the corresponding left and right eigen-\n\ * spaces (deflating subspaces). (A, B) must be in generalized real\n\ * Schur canonical form (as returned by SGGES), i.e. A is block upper\n\ * triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper\n\ * triangular.\n\ *\n\ * STGSEN also computes the generalized eigenvalues\n\ *\n\ * w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j)\n\ *\n\ * of the reordered matrix pair (A, B).\n\ *\n\ * Optionally, STGSEN computes the estimates of reciprocal condition\n\ * numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),\n\ * (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)\n\ * between the matrix pairs (A11, B11) and (A22,B22) that correspond to\n\ * the selected cluster and the eigenvalues outside the cluster, resp.,\n\ * and norms of \"projections\" onto left and right eigenspaces w.r.t.\n\ * the selected cluster in the (1,1)-block.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * IJOB (input) INTEGER\n\ * Specifies whether condition numbers are required for the\n\ * cluster of eigenvalues (PL and PR) or the deflating subspaces\n\ * (Difu and Difl):\n\ * =0: Only reorder w.r.t. SELECT. No extras.\n\ * =1: Reciprocal of norms of \"projections\" onto left and right\n\ * eigenspaces w.r.t. the selected cluster (PL and PR).\n\ * =2: Upper bounds on Difu and Difl. F-norm-based estimate\n\ * (DIF(1:2)).\n\ * =3: Estimate of Difu and Difl. 1-norm-based estimate\n\ * (DIF(1:2)).\n\ * About 5 times as expensive as IJOB = 2.\n\ * =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic\n\ * version to get it all.\n\ * =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)\n\ *\n\ * WANTQ (input) LOGICAL\n\ * .TRUE. : update the left transformation matrix Q;\n\ * .FALSE.: do not update Q.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * .TRUE. : update the right transformation matrix Z;\n\ * .FALSE.: do not update Z.\n\ *\n\ * SELECT (input) LOGICAL array, dimension (N)\n\ * SELECT specifies the eigenvalues in the selected cluster.\n\ * To select a real eigenvalue w(j), SELECT(j) must be set to\n\ * .TRUE.. To select a complex conjugate pair of eigenvalues\n\ * w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,\n\ * either SELECT(j) or SELECT(j+1) or both must be set to\n\ * .TRUE.; a complex conjugate pair of eigenvalues must be\n\ * either both included in the cluster or both excluded.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension(LDA,N)\n\ * On entry, the upper quasi-triangular matrix A, with (A, B) in\n\ * generalized real Schur canonical form.\n\ * On exit, A is overwritten by the reordered matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) REAL array, dimension(LDB,N)\n\ * On entry, the upper triangular matrix B, with (A, B) in\n\ * generalized real Schur canonical form.\n\ * On exit, B is overwritten by the reordered matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * ALPHAR (output) REAL array, dimension (N)\n\ * ALPHAI (output) REAL array, dimension (N)\n\ * BETA (output) REAL array, dimension (N)\n\ * On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n\ * be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i\n\ * and BETA(j),j=1,...,N are the diagonals of the complex Schur\n\ * form (S,T) that would result if the 2-by-2 diagonal blocks of\n\ * the real generalized Schur form of (A,B) were further reduced\n\ * to triangular form using complex unitary transformations.\n\ * If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n\ * positive, then the j-th and (j+1)-st eigenvalues are a\n\ * complex conjugate pair, with ALPHAI(j+1) negative.\n\ *\n\ * Q (input/output) REAL array, dimension (LDQ,N)\n\ * On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.\n\ * On exit, Q has been postmultiplied by the left orthogonal\n\ * transformation matrix which reorder (A, B); The leading M\n\ * columns of Q form orthonormal bases for the specified pair of\n\ * left eigenspaces (deflating subspaces).\n\ * If WANTQ = .FALSE., Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= 1;\n\ * and if WANTQ = .TRUE., LDQ >= N.\n\ *\n\ * Z (input/output) REAL array, dimension (LDZ,N)\n\ * On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.\n\ * On exit, Z has been postmultiplied by the left orthogonal\n\ * transformation matrix which reorder (A, B); The leading M\n\ * columns of Z form orthonormal bases for the specified pair of\n\ * left eigenspaces (deflating subspaces).\n\ * If WANTZ = .FALSE., Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1;\n\ * If WANTZ = .TRUE., LDZ >= N.\n\ *\n\ * M (output) INTEGER\n\ * The dimension of the specified pair of left and right eigen-\n\ * spaces (deflating subspaces). 0 <= M <= N.\n\ *\n\ * PL (output) REAL\n\ * PR (output) REAL\n\ * If IJOB = 1, 4 or 5, PL, PR are lower bounds on the\n\ * reciprocal of the norm of \"projections\" onto left and right\n\ * eigenspaces with respect to the selected cluster.\n\ * 0 < PL, PR <= 1.\n\ * If M = 0 or M = N, PL = PR = 1.\n\ * If IJOB = 0, 2 or 3, PL and PR are not referenced.\n\ *\n\ * DIF (output) REAL array, dimension (2).\n\ * If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.\n\ * If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on\n\ * Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based\n\ * estimates of Difu and Difl.\n\ * If M = 0 or N, DIF(1:2) = F-norm([A, B]).\n\ * If IJOB = 0 or 1, DIF is not referenced.\n\ *\n\ * WORK (workspace/output) REAL 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 >= 4*N+16.\n\ * If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)).\n\ * If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)).\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\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK. LIWORK >= 1.\n\ * If IJOB = 1, 2 or 4, LIWORK >= N+6.\n\ * If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6).\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal size of the IWORK array,\n\ * returns this value as the first entry of the IWORK array, and\n\ * no error message related to LIWORK 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\ * =1: Reordering of (A, B) failed because the transformed\n\ * matrix pair (A, B) would be too far from generalized\n\ * Schur form; the problem is very ill-conditioned.\n\ * (A, B) may have been partially reordered.\n\ * If requested, 0 is returned in DIF(*), PL and PR.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * STGSEN first collects the selected eigenvalues by computing\n\ * orthogonal U and W that move them to the top left corner of (A, B).\n\ * In other words, the selected eigenvalues are the eigenvalues of\n\ * (A11, B11) in:\n\ *\n\ * U'*(A, B)*W = (A11 A12) (B11 B12) n1\n\ * ( 0 A22),( 0 B22) n2\n\ * n1 n2 n1 n2\n\ *\n\ * where N = n1+n2 and U' means the transpose of U. The first n1 columns\n\ * of U and W span the specified pair of left and right eigenspaces\n\ * (deflating subspaces) of (A, B).\n\ *\n\ * If (A, B) has been obtained from the generalized real Schur\n\ * decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the\n\ * reordered generalized real Schur form of (C, D) is given by\n\ *\n\ * (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',\n\ *\n\ * and the first n1 columns of Q*U and Z*W span the corresponding\n\ * deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).\n\ *\n\ * Note that if the selected eigenvalue is sufficiently ill-conditioned,\n\ * then its value may differ significantly from its value before\n\ * reordering.\n\ *\n\ * The reciprocal condition numbers of the left and right eigenspaces\n\ * spanned by the first n1 columns of U and W (or Q*U and Z*W) may\n\ * be returned in DIF(1:2), corresponding to Difu and Difl, resp.\n\ *\n\ * The Difu and Difl are defined as:\n\ *\n\ * Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )\n\ * and\n\ * Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],\n\ *\n\ * where sigma-min(Zu) is the smallest singular value of the\n\ * (2*n1*n2)-by-(2*n1*n2) matrix\n\ *\n\ * Zu = [ kron(In2, A11) -kron(A22', In1) ]\n\ * [ kron(In2, B11) -kron(B22', In1) ].\n\ *\n\ * Here, Inx is the identity matrix of size nx and A22' is the\n\ * transpose of A22. kron(X, Y) is the Kronecker product between\n\ * the matrices X and Y.\n\ *\n\ * When DIF(2) is small, small changes in (A, B) can cause large changes\n\ * in the deflating subspace. An approximate (asymptotic) bound on the\n\ * maximum angular error in the computed deflating subspaces is\n\ *\n\ * EPS * norm((A, B)) / DIF(2),\n\ *\n\ * where EPS is the machine precision.\n\ *\n\ * The reciprocal norm of the projectors on the left and right\n\ * eigenspaces associated with (A11, B11) may be returned in PL and PR.\n\ * They are computed as follows. First we compute L and R so that\n\ * P*(A, B)*Q is block diagonal, where\n\ *\n\ * P = ( I -L ) n1 Q = ( I R ) n1\n\ * ( 0 I ) n2 and ( 0 I ) n2\n\ * n1 n2 n1 n2\n\ *\n\ * and (L, R) is the solution to the generalized Sylvester equation\n\ *\n\ * A11*R - L*A22 = -A12\n\ * B11*R - L*B22 = -B12\n\ *\n\ * Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).\n\ * An approximate (asymptotic) bound on the average absolute error of\n\ * the selected eigenvalues is\n\ *\n\ * EPS * norm((A, B)) / PL.\n\ *\n\ * There are also global error bounds which valid for perturbations up\n\ * to a certain restriction: A lower bound (x) on the smallest\n\ * F-norm(E,F) for which an eigenvalue of (A11, B11) may move and\n\ * coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),\n\ * (i.e. (A + E, B + F), is\n\ *\n\ * x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).\n\ *\n\ * An approximate bound on x can be computed from DIF(1:2), PL and PR.\n\ *\n\ * If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed\n\ * (L', R') and unperturbed (L, R) left and right deflating subspaces\n\ * associated with the selected cluster in the (1,1)-blocks can be\n\ * bounded as\n\ *\n\ * max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))\n\ * max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))\n\ *\n\ * See LAPACK User's Guide section 4.11 or the following references\n\ * for more information.\n\ *\n\ * Note that if the default method for computing the Frobenius-norm-\n\ * based estimate DIF is not wanted (see SLATDF), then the parameter\n\ * IDIFJB (see below) should be changed from 3 to 4 (routine SLATDF\n\ * (IJOB = 2 will be used)). See STGSYL for more details.\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * References\n\ * ==========\n\ *\n\ * [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n\ * Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n\ * M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n\ * Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n\ *\n\ * [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n\ * Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n\ * Estimation: Theory, Algorithms and Software,\n\ * Report UMINF - 94.04, Department of Computing Science, Umea\n\ * University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working\n\ * Note 87. To appear in Numerical Algorithms, 1996.\n\ *\n\ * [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n\ * for Solving the Generalized Sylvester Equation and Estimating the\n\ * Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n\ * Department of Computing Science, Umea University, S-901 87 Umea,\n\ * Sweden, December 1993, Revised April 1994, Also as LAPACK Working\n\ * Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,\n\ * 1996.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dpstrf0000644000175000017500000000701512502223526016515 0ustar uwabamiuwabami--- :name: dpstrf :md5sum: 4601a86524330e102c2ffe6bf56c1149 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - piv: :type: integer :intent: output :dims: - n - rank: :type: integer :intent: output - tol: :type: doublereal :intent: input - work: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPSTRF computes the Cholesky factorization with complete\n\ * pivoting of a real symmetric positive semidefinite matrix A.\n\ *\n\ * The factorization has the form\n\ * P' * A * P = U' * U , if UPLO = 'U',\n\ * P' * A * P = L * L', if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is lower triangular, and\n\ * P is stored as vector PIV.\n\ *\n\ * This algorithm does not attempt to check that A is positive\n\ * semidefinite. This version of the algorithm calls level 3 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * n by n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n by n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the factor U or L from the Cholesky\n\ * factorization as above.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * PIV (output) INTEGER array, dimension (N)\n\ * PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n\ *\n\ * RANK (output) INTEGER\n\ * The rank of A given by the number of steps the algorithm\n\ * completed.\n\ *\n\ * TOL (input) DOUBLE PRECISION\n\ * User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) )\n\ * will be used. The algorithm terminates at the (K-1)st step\n\ * if the pivot <= TOL.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n\ * Work space.\n\ *\n\ * INFO (output) INTEGER\n\ * < 0: If INFO = -K, the K-th argument had an illegal value,\n\ * = 0: algorithm completed successfully, and\n\ * > 0: the matrix A is either rank deficient with computed rank\n\ * as returned in RANK, or is indefinite. See Section 7 of\n\ * LAPACK Working Note #161 for further information.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zptsvx0000644000175000017500000001670212502223526016574 0ustar uwabamiuwabami--- :name: zptsvx :md5sum: f74ed0acaf4ad8aafce833be62fc059b :category: :subroutine :arguments: - fact: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublecomplex :intent: input :dims: - n-1 - df: :type: doublereal :intent: input/output :dims: - n - ef: :type: doublecomplex :intent: input/output :dims: - n-1 - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE ZPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPTSVX uses the factorization A = L*D*L**H to compute the solution\n\ * to a complex system of linear equations A*X = B, where A is an\n\ * N-by-N Hermitian positive definite tridiagonal matrix and X and B\n\ * are N-by-NRHS matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'N', the matrix A is factored as A = L*D*L**H, where L\n\ * is a unit lower bidiagonal matrix and D is diagonal. The\n\ * factorization can also be regarded as having the form\n\ * A = U**H*D*U.\n\ *\n\ * 2. If the leading i-by-i principal minor is not positive definite,\n\ * then the routine returns with INFO = i. Otherwise, the factored\n\ * form of A is used to estimate the condition number of the matrix\n\ * A. If the reciprocal of the condition number is less than machine\n\ * precision, INFO = N+1 is returned as a warning, but the routine\n\ * still goes on to solve for X and compute error bounds as\n\ * described below.\n\ *\n\ * 3. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 4. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix\n\ * A is supplied on entry.\n\ * = 'F': On entry, DF and EF contain the factored form of A.\n\ * D, E, DF, and EF will not be modified.\n\ * = 'N': The matrix A will be copied to DF and EF and\n\ * factored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The n diagonal elements of the tridiagonal matrix A.\n\ *\n\ * E (input) COMPLEX*16 array, dimension (N-1)\n\ * The (n-1) subdiagonal elements of the tridiagonal matrix A.\n\ *\n\ * DF (input or output) DOUBLE PRECISION array, dimension (N)\n\ * If FACT = 'F', then DF is an input argument and on entry\n\ * contains the n diagonal elements of the diagonal matrix D\n\ * from the L*D*L**H factorization of A.\n\ * If FACT = 'N', then DF is an output argument and on exit\n\ * contains the n diagonal elements of the diagonal matrix D\n\ * from the L*D*L**H factorization of A.\n\ *\n\ * EF (input or output) COMPLEX*16 array, dimension (N-1)\n\ * If FACT = 'F', then EF is an input argument and on entry\n\ * contains the (n-1) subdiagonal elements of the unit\n\ * bidiagonal factor L from the L*D*L**H factorization of A.\n\ * If FACT = 'N', then EF is an output argument and on exit\n\ * contains the (n-1) subdiagonal elements of the unit\n\ * bidiagonal factor L from the L*D*L**H factorization of A.\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The N-by-NRHS right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The reciprocal condition number of the matrix A. If RCOND\n\ * is less than the machine precision (in particular, if\n\ * RCOND = 0), the matrix is singular to working precision.\n\ * This condition is indicated by a return code of INFO > 0.\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j).\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in any\n\ * element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\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, and i is\n\ * <= N: the leading minor of order i of A is\n\ * not positive definite, so the factorization\n\ * could not be completed, and the solution has not\n\ * been computed. RCOND = 0 is returned.\n\ * = N+1: U is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsposv0000644000175000017500000001427112502223526016533 0ustar uwabamiuwabami--- :name: dsposv :md5sum: afe420b5c200deccb5aa7fc0f0c8cf39 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - n - nrhs - swork: :type: real :intent: workspace :dims: - n*(n+nrhs) - iter: :type: integer :intent: output - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE DSPOSV( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, WORK, SWORK, ITER, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSPOSV computes the solution to a real system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N symmetric positive definite matrix and X and B\n\ * are N-by-NRHS matrices.\n\ *\n\ * DSPOSV first attempts to factorize the matrix in SINGLE PRECISION\n\ * and use this factorization within an iterative refinement procedure\n\ * to produce a solution with DOUBLE PRECISION normwise backward error\n\ * quality (see below). If the approach fails the method switches to a\n\ * DOUBLE PRECISION factorization and solve.\n\ *\n\ * The iterative refinement is not going to be a winning strategy if\n\ * the ratio SINGLE PRECISION performance over DOUBLE PRECISION\n\ * performance is too small. A reasonable strategy should take the\n\ * number of right-hand sides and the size of the matrix into account.\n\ * This might be done with a call to ILAENV in the future. Up to now, we\n\ * always try iterative refinement.\n\ *\n\ * The iterative refinement process is stopped if\n\ * ITER > ITERMAX\n\ * or for all the RHS we have:\n\ * RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX\n\ * where\n\ * o ITER is the number of the current iteration in the iterative\n\ * refinement process\n\ * o RNRM is the infinity-norm of the residual\n\ * o XNRM is the infinity-norm of the solution\n\ * o ANRM is the infinity-operator-norm of the matrix A\n\ * o EPS is the machine epsilon returned by DLAMCH('Epsilon')\n\ * The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00\n\ * respectively.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array,\n\ * dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ * On exit, if iterative refinement has been successfully used\n\ * (INFO.EQ.0 and ITER.GE.0, see description below), then A is\n\ * unchanged, if double precision factorization has been used\n\ * (INFO.EQ.0 and ITER.LT.0, see description below), then the\n\ * array A contains the factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T.\n\ *\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * The N-by-NRHS right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * If INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (N,NRHS)\n\ * This array is used to hold the residual vectors.\n\ *\n\ * SWORK (workspace) REAL array, dimension (N*(N+NRHS))\n\ * This array is used to use the single precision matrix and the\n\ * right-hand sides or solutions in single precision.\n\ *\n\ * ITER (output) INTEGER\n\ * < 0: iterative refinement has failed, double precision\n\ * factorization has been performed\n\ * -1 : the routine fell back to full precision for\n\ * implementation- or machine-specific reasons\n\ * -2 : narrowing the precision induced an overflow,\n\ * the routine fell back to full precision\n\ * -3 : failure of SPOTRF\n\ * -31: stop the iterative refinement after the 30th\n\ * iterations\n\ * > 0: iterative refinement has been sucessfully used.\n\ * Returns the number of iterations\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 leading minor of order i of (DOUBLE\n\ * PRECISION) A is not positive definite, so the\n\ * factorization could not be completed, and the solution\n\ * has not been computed.\n\ *\n\ * =========\n\ *\n" ruby-lapack-1.7.2/dev/defs/ztrti20000644000175000017500000000455512502223526016457 0ustar uwabamiuwabami--- :name: ztrti2 :md5sum: 270e046b9b0d3f1c0bff663a3feeab5b :category: :subroutine :arguments: - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZTRTI2( UPLO, DIAG, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTRTI2 computes the inverse of a complex upper or lower triangular\n\ * matrix.\n\ *\n\ * This is the Level 2 BLAS version of the algorithm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the matrix A is upper or lower triangular.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * Specifies whether or not the matrix A is unit triangular.\n\ * = 'N': Non-unit triangular\n\ * = 'U': Unit triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the triangular matrix A. If UPLO = 'U', the\n\ * leading n by n upper triangular part of the array A contains\n\ * the upper triangular matrix, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n by n lower triangular part of the array A contains\n\ * the lower triangular matrix, and the strictly upper\n\ * triangular part of A is not referenced. If DIAG = 'U', the\n\ * diagonal elements of A are also not referenced and are\n\ * assumed to be 1.\n\ *\n\ * On exit, the (triangular) inverse of the original matrix, in\n\ * the same storage format.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgehrd0000644000175000017500000001134312502223526016475 0ustar uwabamiuwabami--- :name: zgehrd :md5sum: 151c13c15d5546777ff58abbdef05187 :category: :subroutine :arguments: - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - n-1 - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGEHRD reduces a complex general matrix A to upper Hessenberg form H by\n\ * an unitary similarity transformation: Q' * A * Q = H .\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * It is assumed that A is already upper triangular in rows\n\ * and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n\ * set by a previous call to ZGEBAL; otherwise they should be\n\ * set to 1 and N respectively. See Further Details.\n\ * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the N-by-N general matrix to be reduced.\n\ * On exit, the upper triangle and the first subdiagonal of A\n\ * are overwritten with the upper Hessenberg matrix H, and the\n\ * elements below the first subdiagonal, with the array TAU,\n\ * represent the unitary matrix Q as a product of elementary\n\ * reflectors. See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * TAU (output) COMPLEX*16 array, dimension (N-1)\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to\n\ * zero.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK)\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of the array WORK. LWORK >= max(1,N).\n\ * For optimum performance LWORK >= N*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 (ihi-ilo) elementary\n\ * reflectors\n\ *\n\ * Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar, and v is a complex vector with\n\ * v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n\ * exit in A(i+2:ihi,i), and tau in TAU(i).\n\ *\n\ * The contents of A are illustrated by the following example, with\n\ * n = 7, ilo = 2 and ihi = 6:\n\ *\n\ * on entry, on exit,\n\ *\n\ * ( a a a a a a a ) ( a a h h h h a )\n\ * ( a a a a a a ) ( a h h h h a )\n\ * ( a a a a a a ) ( h h h h h h )\n\ * ( a a a a a a ) ( v2 h h h h h )\n\ * ( a a a a a a ) ( v2 v3 h h h h )\n\ * ( a a a a a a ) ( v2 v3 v4 h h h )\n\ * ( a ) ( a )\n\ *\n\ * where a denotes an element of the original matrix A, h denotes a\n\ * modified element of the upper Hessenberg matrix H, and vi denotes an\n\ * element of the vector defining H(i).\n\ *\n\ * This file is a slight modification of LAPACK-3.0's DGEHRD\n\ * subroutine incorporating improvements proposed by Quintana-Orti and\n\ * Van de Geijn (2006). (See DLAHR2.)\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlaqsp0000644000175000017500000000542112502223526016476 0ustar uwabamiuwabami--- :name: dlaqsp :md5sum: d4a0f98e745846989812a681a1028e71 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - s: :type: doublereal :intent: input :dims: - n - scond: :type: doublereal :intent: input - amax: :type: doublereal :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAQSP equilibrates a symmetric matrix A using the scaling factors\n\ * in the vector S.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, the equilibrated matrix: diag(S) * A * diag(S), in\n\ * the same storage format as A.\n\ *\n\ * S (input) DOUBLE PRECISION array, dimension (N)\n\ * The scale factors for A.\n\ *\n\ * SCOND (input) DOUBLE PRECISION\n\ * Ratio of the smallest S(i) to the largest S(i).\n\ *\n\ * AMAX (input) DOUBLE PRECISION\n\ * Absolute value of largest matrix entry.\n\ *\n\ * EQUED (output) CHARACTER*1\n\ * Specifies whether or not equilibration was done.\n\ * = 'N': No equilibration.\n\ * = 'Y': Equilibration was done, i.e., A has been replaced by\n\ * diag(S) * A * diag(S).\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * THRESH is a threshold value used to decide if scaling should be done\n\ * based on the ratio of the scaling factors. If SCOND < THRESH,\n\ * scaling is done.\n\ *\n\ * LARGE and SMALL are threshold values used to decide if scaling should\n\ * be done based on the absolute size of the largest matrix element.\n\ * If AMAX > LARGE or AMAX < SMALL, scaling is done.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dtrcon0000644000175000017500000000614612502223526016510 0ustar uwabamiuwabami--- :name: dtrcon :md5sum: c9e8e550a9265f1dcf6aa23ea7ae653d :category: :subroutine :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTRCON estimates the reciprocal of the condition number of a\n\ * triangular matrix A, in either the 1-norm or the infinity-norm.\n\ *\n\ * The norm of A is computed and an estimate is obtained for\n\ * norm(inv(A)), then the reciprocal of the condition number is\n\ * computed as\n\ * RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies whether the 1-norm condition number or the\n\ * infinity-norm condition number is required:\n\ * = '1' or 'O': 1-norm;\n\ * = 'I': Infinity-norm.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The triangular matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of the array A contains the upper\n\ * triangular matrix, and the strictly lower triangular part of\n\ * A is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of the array A contains the lower triangular\n\ * matrix, and the strictly upper triangular part of A is not\n\ * referenced. If DIAG = 'U', the diagonal elements of A are\n\ * also not referenced and are assumed to be 1.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(norm(A) * norm(inv(A))).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgels0000644000175000017500000001330612502223526016337 0ustar uwabamiuwabami--- :name: zgels :md5sum: d543f789adef7ad831c7880fbac31097 :category: :subroutine :arguments: - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MIN(m,n) + MAX(MIN(m,n),nrhs) - info: :type: integer :intent: output :substitutions: m: lda ldb: MAX(m,n) :fortran_help: " SUBROUTINE ZGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGELS solves overdetermined or underdetermined complex linear systems\n\ * involving an M-by-N matrix A, or its conjugate-transpose, using a QR\n\ * or LQ 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 = 'C' and m >= n: find the minimum norm solution of\n\ * an undetermined system A**H * X = B.\n\ *\n\ * 4. If TRANS = 'C' and m < n: find the least squares solution of\n\ * an overdetermined system, i.e., solve the least squares problem\n\ * minimize || B - A**H * 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\ * = 'C': the linear system involves A**H.\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) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * if M >= N, A is overwritten by details of its QR\n\ * factorization as returned by ZGEQRF;\n\ * if M < N, A is overwritten by details of its LQ\n\ * factorization as returned by ZGELQF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input/output) COMPLEX*16 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 = 'C'.\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 the\n\ * modulus of 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 = 'C' and m >= n, rows 1 to M of B contain the\n\ * minimum norm solution vectors;\n\ * if TRANS = 'C' 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 the modulus 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) COMPLEX*16 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" ruby-lapack-1.7.2/dev/defs/dlanhs0000644000175000017500000000457212502223526016471 0ustar uwabamiuwabami--- :name: dlanhs :md5sum: 00f8dcb211edf59271e15369f14cb83b :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? n : 0" :fortran_help: " DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLANHS returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * Hessenberg matrix A.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * DLANHS returns the value\n\ *\n\ * DLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in DLANHS as described\n\ * above.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, DLANHS is\n\ * set to zero.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The n by n upper Hessenberg matrix A; the part of A below the\n\ * first sub-diagonal is not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(N,1).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n\ * referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlarfb0000644000175000017500000000767612502223526016462 0ustar uwabamiuwabami--- :name: dlarfb :md5sum: a20fc3a5ff2f6f880a322c5402f64de1 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - direct: :type: char :intent: input - storev: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - v: :type: doublereal :intent: input :dims: - ldv - k - ldv: :type: integer :intent: input - t: :type: doublereal :intent: input :dims: - ldt - k - ldt: :type: integer :intent: input - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - ldwork - k - ldwork: :type: integer :intent: input :substitutions: ldwork: "MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0" :fortran_help: " SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLARFB applies a real block reflector H or its transpose H' to a\n\ * real m by n matrix C, from either the left or the right.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply H or H' from the Left\n\ * = 'R': apply H or H' from the Right\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': apply H (No transpose)\n\ * = 'T': apply H' (Transpose)\n\ *\n\ * DIRECT (input) CHARACTER*1\n\ * Indicates how H is formed from a product of elementary\n\ * reflectors\n\ * = 'F': H = H(1) H(2) . . . H(k) (Forward)\n\ * = 'B': H = H(k) . . . H(2) H(1) (Backward)\n\ *\n\ * STOREV (input) CHARACTER*1\n\ * Indicates how the vectors which define the elementary\n\ * reflectors are stored:\n\ * = 'C': Columnwise\n\ * = 'R': Rowwise\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C.\n\ *\n\ * K (input) INTEGER\n\ * The order of the matrix T (= the number of elementary\n\ * reflectors whose product defines the block reflector).\n\ *\n\ * V (input) DOUBLE PRECISION array, dimension\n\ * (LDV,K) if STOREV = 'C'\n\ * (LDV,M) if STOREV = 'R' and SIDE = 'L'\n\ * (LDV,N) if STOREV = 'R' and SIDE = 'R'\n\ * The matrix V. See further details.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V.\n\ * If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);\n\ * if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);\n\ * if STOREV = 'R', LDV >= K.\n\ *\n\ * T (input) DOUBLE PRECISION array, dimension (LDT,K)\n\ * The triangular k by k matrix T in the representation of the\n\ * block reflector.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= K.\n\ *\n\ * C (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n\ * On entry, the m by n matrix C.\n\ * On exit, C is overwritten by H*C or H'*C or C*H or C*H'.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDA >= max(1,M).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K)\n\ *\n\ * LDWORK (input) INTEGER\n\ * The leading dimension of the array WORK.\n\ * If SIDE = 'L', LDWORK >= max(1,N);\n\ * if SIDE = 'R', LDWORK >= max(1,M).\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cpbtf20000644000175000017500000000712712502223525016376 0ustar uwabamiuwabami--- :name: cpbtf2 :md5sum: 9dc08eed5d77e0abfd14e60815cef7a6 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPBTF2( UPLO, N, KD, AB, LDAB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPBTF2 computes the Cholesky factorization of a complex Hermitian\n\ * positive definite band matrix A.\n\ *\n\ * The factorization has the form\n\ * A = U' * U , if UPLO = 'U', or\n\ * A = L * L', if UPLO = 'L',\n\ * where U is an upper triangular matrix, U' is the conjugate transpose\n\ * of U, and L is lower triangular.\n\ *\n\ * This is the unblocked version of the algorithm, calling Level 2 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * Hermitian matrix A is stored:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of super-diagonals of the matrix A if UPLO = 'U',\n\ * or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) COMPLEX array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * On exit, if INFO = 0, the triangular factor U or L from the\n\ * Cholesky factorization A = U'*U or A = L*L' of the band\n\ * matrix A, in the same storage format as A.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ * > 0: if INFO = k, the leading minor of order k is not\n\ * positive definite, and the factorization could not be\n\ * completed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * N = 6, KD = 2, and UPLO = 'U':\n\ *\n\ * On entry: On exit:\n\ *\n\ * * * a13 a24 a35 a46 * * u13 u24 u35 u46\n\ * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n\ * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n\ *\n\ * Similarly, if UPLO = 'L' the format of A is as follows:\n\ *\n\ * On entry: On exit:\n\ *\n\ * a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n\ * a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n\ * a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n\ *\n\ * Array elements marked * are not used by the routine.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgeqr2p0000644000175000017500000000477612502223526016572 0ustar uwabamiuwabami--- :name: dgeqr2p :md5sum: 59f93cf670a8bce6baf99ccbb702ece5 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - MIN(m,n) - work: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGEQR2P( M, N, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGEQR2 computes a QR factorization of a real m by n matrix A:\n\ * A = Q * R.\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 above the diagonal of the array\n\ * contain the min(m,n) by n upper trapezoidal matrix R (R is\n\ * upper triangular if m >= n); the elements below 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 (N)\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(1) H(2) . . . H(k), 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:m) is stored on exit in A(i+1:m,i),\n\ * and tau in TAU(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dtrsyl0000644000175000017500000001005612502223526016533 0ustar uwabamiuwabami--- :name: dtrsyl :md5sum: f236af47dea9bd90ec38f415953dc0a5 :category: :subroutine :arguments: - trana: :type: char :intent: input - tranb: :type: char :intent: input - isgn: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - m - lda: :type: integer :intent: input - b: :type: doublereal :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - scale: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, SCALE, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTRSYL solves the real Sylvester matrix equation:\n\ *\n\ * op(A)*X + X*op(B) = scale*C or\n\ * op(A)*X - X*op(B) = scale*C,\n\ *\n\ * where op(A) = A or A**T, and A and B are both upper quasi-\n\ * triangular. A is M-by-M and B is N-by-N; the right hand side C and\n\ * the solution X are M-by-N; and scale is an output scale factor, set\n\ * <= 1 to avoid overflow in X.\n\ *\n\ * A and B must be in Schur canonical form (as returned by DHSEQR), that\n\ * is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks;\n\ * each 2-by-2 diagonal block has its diagonal elements equal and its\n\ * off-diagonal elements of opposite sign.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANA (input) CHARACTER*1\n\ * Specifies the option op(A):\n\ * = 'N': op(A) = A (No transpose)\n\ * = 'T': op(A) = A**T (Transpose)\n\ * = 'C': op(A) = A**H (Conjugate transpose = Transpose)\n\ *\n\ * TRANB (input) CHARACTER*1\n\ * Specifies the option op(B):\n\ * = 'N': op(B) = B (No transpose)\n\ * = 'T': op(B) = B**T (Transpose)\n\ * = 'C': op(B) = B**H (Conjugate transpose = Transpose)\n\ *\n\ * ISGN (input) INTEGER\n\ * Specifies the sign in the equation:\n\ * = +1: solve op(A)*X + X*op(B) = scale*C\n\ * = -1: solve op(A)*X - X*op(B) = scale*C\n\ *\n\ * M (input) INTEGER\n\ * The order of the matrix A, and the number of rows in the\n\ * matrices X and C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix B, and the number of columns in the\n\ * matrices X and C. N >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,M)\n\ * The upper quasi-triangular matrix A, in Schur canonical form.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,N)\n\ * The upper quasi-triangular matrix B, in Schur canonical form.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * C (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n\ * On entry, the M-by-N right hand side matrix C.\n\ * On exit, C is overwritten by the solution matrix X.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M)\n\ *\n\ * SCALE (output) DOUBLE PRECISION\n\ * The scale factor, scale, set <= 1 to avoid overflow in X.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * = 1: A and B have common or very close eigenvalues; perturbed\n\ * values were used to solve the equation (but the matrices\n\ * A and B are unchanged).\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ztrexc0000644000175000017500000000622712502223526016536 0ustar uwabamiuwabami--- :name: ztrexc :md5sum: 22440e97c892aee6b265e87024968d43 :category: :subroutine :arguments: - compq: :type: char :intent: input - n: :type: integer :intent: input - t: :type: doublecomplex :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - q: :type: doublecomplex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - ifst: :type: integer :intent: input - ilst: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTREXC reorders the Schur factorization of a complex matrix\n\ * A = Q*T*Q**H, so that the diagonal element of T with row index IFST\n\ * is moved to row ILST.\n\ *\n\ * The Schur form T is reordered by a unitary similarity transformation\n\ * Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by\n\ * postmultplying it with Z.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * COMPQ (input) CHARACTER*1\n\ * = 'V': update the matrix Q of Schur vectors;\n\ * = 'N': do not update Q.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix T. N >= 0.\n\ *\n\ * T (input/output) COMPLEX*16 array, dimension (LDT,N)\n\ * On entry, the upper triangular matrix T.\n\ * On exit, the reordered upper triangular matrix.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= max(1,N).\n\ *\n\ * Q (input/output) COMPLEX*16 array, dimension (LDQ,N)\n\ * On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n\ * On exit, if COMPQ = 'V', Q has been postmultiplied by the\n\ * unitary transformation matrix Z which reorders T.\n\ * If COMPQ = 'N', Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N).\n\ *\n\ * IFST (input) INTEGER\n\ * ILST (input) INTEGER\n\ * Specify the reordering of the diagonal elements of T:\n\ * The element with row index IFST is moved to row ILST by a\n\ * sequence of transpositions between adjacent elements.\n\ * 1 <= IFST <= N; 1 <= ILST <= N.\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\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL WANTQ\n INTEGER K, M1, M2, M3\n DOUBLE PRECISION CS\n COMPLEX*16 SN, T11, T22, TEMP\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZLARTG, ZROT\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC DCONJG, MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dorghr0000644000175000017500000000566212502223526016506 0ustar uwabamiuwabami--- :name: dorghr :md5sum: 05dfa3e4bb3b03cb3e2846680ed1ae05 :category: :subroutine :arguments: - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - n-1 - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: ihi-ilo - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DORGHR generates a real orthogonal matrix Q which is defined as the\n\ * product of IHI-ILO elementary reflectors of order N, as returned by\n\ * DGEHRD:\n\ *\n\ * Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix Q. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * ILO and IHI must have the same values as in the previous call\n\ * of DGEHRD. Q is equal to the unit matrix except in the\n\ * submatrix Q(ilo+1:ihi,ilo+1:ihi).\n\ * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the vectors which define the elementary reflectors,\n\ * as returned by DGEHRD.\n\ * On exit, the N-by-N orthogonal matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * TAU (input) DOUBLE PRECISION array, dimension (N-1)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by DGEHRD.\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 >= IHI-ILO.\n\ * For optimum performance LWORK >= (IHI-ILO)*NB, where NB is\n\ * the 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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zla_porpvgrw0000644000175000017500000000522212502223526017745 0ustar uwabamiuwabami--- :name: zla_porpvgrw :md5sum: e917efebc5e4c9397b6b5953515fb481 :category: :function :type: doublereal :arguments: - uplo: :type: char :intent: input - ncols: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - work: :type: doublecomplex :intent: input :dims: - 2*n :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION ZLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, LDAF, WORK )\n\n\ * Purpose\n\ * =======\n\ * \n\ * ZLA_PORPVGRW computes the reciprocal pivot growth factor\n\ * norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n\ * much less than 1, the stability of the LU factorization of the\n\ * (equilibrated) matrix A could be poor. This also means that the\n\ * solution X, estimated condition numbers, and error bounds could be\n\ * unreliable.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * NCOLS (input) INTEGER\n\ * The number of columns of the matrix A. NCOLS >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX*16 array, dimension (LDAF,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T, as computed by ZPOTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * WORK (input) COMPLEX*16 array, dimension (2*N)\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n DOUBLE PRECISION AMAX, UMAX, RPVGRW\n LOGICAL UPPER\n COMPLEX*16 ZDUM\n\ * ..\n\ * .. External Functions ..\n EXTERNAL LSAME, ZLASET\n LOGICAL LSAME\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN, REAL, DIMAG\n\ * ..\n\ * .. Statement Functions ..\n DOUBLE PRECISION CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zupmtr0000644000175000017500000000717012502223526016556 0ustar uwabamiuwabami--- :name: zupmtr :md5sum: 2c774ae5c8f3bf8176eb3968138221b8 :category: :subroutine :arguments: - side: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - m*(m+1)/2 - tau: :type: doublecomplex :intent: input :dims: - m-1 - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZUPMTR overwrites the general complex M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'C': Q**H * C C * Q**H\n\ *\n\ * where Q is a complex unitary matrix of order nq, with nq = m if\n\ * SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of\n\ * nq-1 elementary reflectors, as returned by ZHPTRD using packed\n\ * storage:\n\ *\n\ * if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);\n\ *\n\ * if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**H from the Left;\n\ * = 'R': apply Q or Q**H from the Right.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangular packed storage used in previous\n\ * call to ZHPTRD;\n\ * = 'L': Lower triangular packed storage used in previous\n\ * call to ZHPTRD.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q;\n\ * = 'C': Conjugate transpose, apply Q**H.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * AP (input) COMPLEX*16 array, dimension\n\ * (M*(M+1)/2) if SIDE = 'L'\n\ * (N*(N+1)/2) if SIDE = 'R'\n\ * The vectors which define the elementary reflectors, as\n\ * returned by ZHPTRD. AP is modified by the routine but\n\ * restored on exit.\n\ *\n\ * TAU (input) COMPLEX*16 array, dimension (M-1) if SIDE = 'L'\n\ * or (N-1) if SIDE = 'R'\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by ZHPTRD.\n\ *\n\ * C (input/output) COMPLEX*16 array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension\n\ * (N) if SIDE = 'L'\n\ * (M) if SIDE = 'R'\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgeqp30000644000175000017500000000756312502223525016404 0ustar uwabamiuwabami--- :name: cgeqp3 :md5sum: ab6cee8b274b134af89a8741b7884457 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: complex :intent: output :dims: - MIN(m,n) - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n+1 - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGEQP3 computes a QR factorization with column pivoting of a\n\ * matrix A: A*P = Q*R using Level 3 BLAS.\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) COMPLEX array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, the upper triangle of the array contains the\n\ * min(M,N)-by-N upper trapezoidal matrix R; the elements below\n\ * the diagonal, together with the array TAU, represent the\n\ * unitary matrix Q as a product of min(M,N) elementary\n\ * reflectors.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * JPVT (input/output) INTEGER array, dimension (N)\n\ * On entry, if JPVT(J).ne.0, the J-th column of A is permuted\n\ * to the front of A*P (a leading column); if JPVT(J)=0,\n\ * the J-th column of A is a free column.\n\ * On exit, if JPVT(J)=K, then the J-th column of A*P was the\n\ * the K-th column of A.\n\ *\n\ * TAU (output) COMPLEX array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors.\n\ *\n\ * WORK (workspace/output) COMPLEX 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 >= N+1.\n\ * For optimal performance LWORK >= ( N+1 )*NB, where NB\n\ * is the 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\ * RWORK (workspace) REAL array, dimension (2*N)\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(1) H(2) . . . H(k), 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/complex scalar, and v is a real/complex vector\n\ * with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in\n\ * A(i+1:m,i), and tau in TAU(i).\n\ *\n\ * Based on contributions by\n\ * G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n\ * X. Sun, Computer Science Dept., Duke University, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clalsd0000644000175000017500000001253512502223525016457 0ustar uwabamiuwabami--- :name: clalsd :md5sum: 67e6050323bb3b9ddcb04cc9b8ea807c :category: :subroutine :arguments: - uplo: :type: char :intent: input - smlsiz: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - rcond: :type: real :intent: input - rank: :type: integer :intent: output - work: :type: complex :intent: workspace :dims: - n * nrhs - rwork: :type: real :intent: workspace :dims: - 9*n+2*n*smlsiz+8*n*nlvl+3*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1) - iwork: :type: integer :intent: workspace :dims: - 3*n*nlvl + 11*n - info: :type: integer :intent: output :substitutions: nlvl: ( (int)( log(((double)n)/(smlsiz+1))/log(2.0) ) ) + 1 :extras: nlvl: integer :fortran_help: " SUBROUTINE CLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, RANK, WORK, RWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLALSD uses the singular value decomposition of A to solve the least\n\ * squares problem of finding X to minimize the Euclidean norm of each\n\ * column of A*X-B, where A is N-by-N upper bidiagonal, and X and B\n\ * are N-by-NRHS. The solution X overwrites B.\n\ *\n\ * The singular values of A smaller than RCOND times the largest\n\ * singular value are treated as zero in solving the least squares\n\ * problem; in this case a minimum norm solution is returned.\n\ * The actual singular values are returned in D in ascending order.\n\ *\n\ * This code makes very mild assumptions about floating point\n\ * arithmetic. It will work on machines with a guard digit in\n\ * add/subtract, or on those binary machines without guard digits\n\ * which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.\n\ * It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': D and E define an upper bidiagonal matrix.\n\ * = 'L': D and E define a lower bidiagonal matrix.\n\ *\n\ * SMLSIZ (input) INTEGER\n\ * The maximum size of the subproblems at the bottom of the\n\ * computation tree.\n\ *\n\ * N (input) INTEGER\n\ * The dimension of the bidiagonal matrix. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of columns of B. NRHS must be at least 1.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry D contains the main diagonal of the bidiagonal\n\ * matrix. On exit, if INFO = 0, D contains its singular values.\n\ *\n\ * E (input/output) REAL array, dimension (N-1)\n\ * Contains the super-diagonal entries of the bidiagonal matrix.\n\ * On exit, E has been destroyed.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On input, B contains the right hand sides of the least\n\ * squares problem. On output, B contains the solution X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B in the calling subprogram.\n\ * LDB must be at least max(1,N).\n\ *\n\ * RCOND (input) REAL\n\ * The singular values of A less than or equal to RCOND times\n\ * the largest singular value are treated as zero in solving\n\ * the least squares problem. If RCOND is negative,\n\ * machine precision is used instead.\n\ * For example, if diag(S)*X=B were the least squares problem,\n\ * where diag(S) is a diagonal matrix of singular values, the\n\ * solution would be X(i) = B(i) / S(i) if S(i) is greater than\n\ * RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to\n\ * RCOND*max(S).\n\ *\n\ * RANK (output) INTEGER\n\ * The number of singular values of A greater than RCOND times\n\ * the largest singular value.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (N * NRHS).\n\ *\n\ * RWORK (workspace) REAL array, dimension at least\n\ * (9*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS +\n\ * MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS ),\n\ * where\n\ * NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (3*N*NLVL + 11*N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit.\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * > 0: The algorithm failed to compute a singular value while\n\ * working on the submatrix lying in rows and columns\n\ * INFO/(N+1) through MOD(INFO,N+1).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ming Gu and Ren-Cang Li, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhetrd0000644000175000017500000001317012502223526016512 0ustar uwabamiuwabami--- :name: zhetrd :md5sum: 8ff61910f96d3aa218cab2a83ffadca4 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - n - e: :type: doublereal :intent: output :dims: - n-1 - tau: :type: doublecomplex :intent: output :dims: - n-1 - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHETRD reduces a complex Hermitian matrix A to real symmetric\n\ * tridiagonal form T by a unitary similarity transformation:\n\ * Q**H * A * Q = T.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ * On exit, if UPLO = 'U', the diagonal and first superdiagonal\n\ * of A are overwritten by the corresponding elements of the\n\ * tridiagonal matrix T, and the elements above the first\n\ * superdiagonal, with the array TAU, represent the unitary\n\ * matrix Q as a product of elementary reflectors; if UPLO\n\ * = 'L', the diagonal and first subdiagonal of A are over-\n\ * written by the corresponding elements of the tridiagonal\n\ * matrix T, and the elements below the first subdiagonal, with\n\ * the array TAU, represent the unitary matrix Q as a product\n\ * of elementary reflectors. See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * D (output) DOUBLE PRECISION array, dimension (N)\n\ * The diagonal elements of the tridiagonal matrix T:\n\ * D(i) = A(i,i).\n\ *\n\ * E (output) DOUBLE PRECISION array, dimension (N-1)\n\ * The off-diagonal elements of the tridiagonal matrix T:\n\ * E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n\ *\n\ * TAU (output) COMPLEX*16 array, dimension (N-1)\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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 >= 1.\n\ * For optimum performance LWORK >= N*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\ * If UPLO = 'U', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(n-1) . . . H(2) H(1).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar, and v is a complex vector with\n\ * v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n\ * A(1:i-1,i+1), and tau in TAU(i).\n\ *\n\ * If UPLO = 'L', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(n-1).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar, and v is a complex vector with\n\ * v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n\ * and tau in TAU(i).\n\ *\n\ * The contents of A on exit are illustrated by the following examples\n\ * with n = 5:\n\ *\n\ * if UPLO = 'U': if UPLO = 'L':\n\ *\n\ * ( d e v2 v3 v4 ) ( d )\n\ * ( d e v3 v4 ) ( e d )\n\ * ( d e v4 ) ( v1 e d )\n\ * ( d e ) ( v1 v2 e d )\n\ * ( d ) ( v1 v2 v3 e d )\n\ *\n\ * where d and e denote diagonal and off-diagonal elements of T, and vi\n\ * denotes an element of the vector defining H(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zcgesv0000644000175000017500000001415312502223526016515 0ustar uwabamiuwabami--- :name: zcgesv :md5sum: bdec37d073bdd6753df626ef86ae37b2 :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - n*nrhs - swork: :type: complex :intent: workspace :dims: - n*(n+nrhs) - rwork: :type: doublereal :intent: workspace :dims: - n - iter: :type: integer :intent: output - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE ZCGESV( N, NRHS, A, LDA, IPIV, B, LDB, X, LDX, WORK, SWORK, RWORK, ITER, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZCGESV computes the solution to a complex system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n\ *\n\ * ZCGESV first attempts to factorize the matrix in COMPLEX and use this\n\ * factorization within an iterative refinement procedure to produce a\n\ * solution with COMPLEX*16 normwise backward error quality (see below).\n\ * If the approach fails the method switches to a COMPLEX*16\n\ * factorization and solve.\n\ *\n\ * The iterative refinement is not going to be a winning strategy if\n\ * the ratio COMPLEX performance over COMPLEX*16 performance is too\n\ * small. A reasonable strategy should take the number of right-hand\n\ * sides and the size of the matrix into account. This might be done\n\ * with a call to ILAENV in the future. Up to now, we always try\n\ * iterative refinement.\n\ *\n\ * The iterative refinement process is stopped if\n\ * ITER > ITERMAX\n\ * or for all the RHS we have:\n\ * RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX\n\ * where\n\ * o ITER is the number of the current iteration in the iterative\n\ * refinement process\n\ * o RNRM is the infinity-norm of the residual\n\ * o XNRM is the infinity-norm of the solution\n\ * o ANRM is the infinity-operator-norm of the matrix A\n\ * o EPS is the machine epsilon returned by DLAMCH('Epsilon')\n\ * The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00\n\ * respectively.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array,\n\ * dimension (LDA,N)\n\ * On entry, the N-by-N coefficient matrix A.\n\ * On exit, if iterative refinement has been successfully used\n\ * (INFO.EQ.0 and ITER.GE.0, see description below), then A is\n\ * unchanged, if double precision factorization has been used\n\ * (INFO.EQ.0 and ITER.LT.0, see description below), then the\n\ * array A contains the factors L and U from the factorization\n\ * A = P*L*U; the unit diagonal elements of L are not stored.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * The pivot indices that define the permutation matrix P;\n\ * row i of the matrix was interchanged with row IPIV(i).\n\ * Corresponds either to the single precision factorization\n\ * (if INFO.EQ.0 and ITER.GE.0) or the double precision\n\ * factorization (if INFO.EQ.0 and ITER.LT.0).\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The N-by-NRHS right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * If INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (N*NRHS)\n\ * This array is used to hold the residual vectors.\n\ *\n\ * SWORK (workspace) COMPLEX array, dimension (N*(N+NRHS))\n\ * This array is used to use the single precision matrix and the\n\ * right-hand sides or solutions in single precision.\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * ITER (output) INTEGER\n\ * < 0: iterative refinement has failed, COMPLEX*16\n\ * factorization has been performed\n\ * -1 : the routine fell back to full precision for\n\ * implementation- or machine-specific reasons\n\ * -2 : narrowing the precision induced an overflow,\n\ * the routine fell back to full precision\n\ * -3 : failure of CGETRF\n\ * -31: stop the iterative refinement after the 30th\n\ * iterations\n\ * > 0: iterative refinement has been sucessfully used.\n\ * Returns the number of iterations\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, U(i,i) computed in COMPLEX*16 is exactly\n\ * zero. The factorization has been completed, but the\n\ * factor U is exactly singular, so the solution\n\ * could not be computed.\n\ *\n\ * =========\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgerfs0000644000175000017500000001113612502223525016462 0ustar uwabamiuwabami--- :name: cgerfs :md5sum: 159d9fe35bc1f2e3a27de2ef0371b704 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGERFS improves the computed solution to a system of linear\n\ * equations and provides error bounds and backward error estimates for\n\ * the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The original N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX array, dimension (LDAF,N)\n\ * The factors L and U from the factorization A = P*L*U\n\ * as computed by CGETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from CGETRF; for 1<=i<=N, row i of the\n\ * matrix was interchanged with row IPIV(i).\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) COMPLEX array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by CGETRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlasv20000644000175000017500000000615712502223526016414 0ustar uwabamiuwabami--- :name: dlasv2 :md5sum: 9337b1a710d99f92d83bed784d02e670 :category: :subroutine :arguments: - f: :type: doublereal :intent: input - g: :type: doublereal :intent: input - h: :type: doublereal :intent: input - ssmin: :type: doublereal :intent: output - ssmax: :type: doublereal :intent: output - snr: :type: doublereal :intent: output - csr: :type: doublereal :intent: output - snl: :type: doublereal :intent: output - csl: :type: doublereal :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLASV2 computes the singular value decomposition of a 2-by-2\n\ * triangular matrix\n\ * [ F G ]\n\ * [ 0 H ].\n\ * On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the\n\ * smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and\n\ * right singular vectors for abs(SSMAX), giving the decomposition\n\ *\n\ * [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ]\n\ * [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ].\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * F (input) DOUBLE PRECISION\n\ * The (1,1) element of the 2-by-2 matrix.\n\ *\n\ * G (input) DOUBLE PRECISION\n\ * The (1,2) element of the 2-by-2 matrix.\n\ *\n\ * H (input) DOUBLE PRECISION\n\ * The (2,2) element of the 2-by-2 matrix.\n\ *\n\ * SSMIN (output) DOUBLE PRECISION\n\ * abs(SSMIN) is the smaller singular value.\n\ *\n\ * SSMAX (output) DOUBLE PRECISION\n\ * abs(SSMAX) is the larger singular value.\n\ *\n\ * SNL (output) DOUBLE PRECISION\n\ * CSL (output) DOUBLE PRECISION\n\ * The vector (CSL, SNL) is a unit left singular vector for the\n\ * singular value abs(SSMAX).\n\ *\n\ * SNR (output) DOUBLE PRECISION\n\ * CSR (output) DOUBLE PRECISION\n\ * The vector (CSR, SNR) is a unit right singular vector for the\n\ * singular value abs(SSMAX).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Any input parameter may be aliased with any output parameter.\n\ *\n\ * Barring over/underflow and assuming a guard digit in subtraction, all\n\ * output quantities are correct to within a few units in the last\n\ * place (ulps).\n\ *\n\ * In IEEE arithmetic, the code works correctly if one matrix element is\n\ * infinite.\n\ *\n\ * Overflow will not occur unless the largest singular value itself\n\ * overflows or is within a few ulps of overflow. (On machines with\n\ * partial overflow, like the Cray, overflow may occur if the largest\n\ * singular value is within a factor of 2 of overflow.)\n\ *\n\ * Underflow is harmless if underflow is gradual. Otherwise, results\n\ * may correspond to a matrix modified by perturbations of size near\n\ * the underflow threshold.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sopgtr0000644000175000017500000000441512502223526016532 0ustar uwabamiuwabami--- :name: sopgtr :md5sum: 1353a948b585706cee42dbaad028b132 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input :dims: - ldap - tau: :type: real :intent: input :dims: - ldtau - q: :type: real :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - n-1 - info: :type: integer :intent: output :substitutions: ldq: MAX(1,n) n: ldtau+1 :fortran_help: " SUBROUTINE SOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SOPGTR generates a real orthogonal matrix Q which is defined as the\n\ * product of n-1 elementary reflectors H(i) of order n, as returned by\n\ * SSPTRD using packed storage:\n\ *\n\ * if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),\n\ *\n\ * if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangular packed storage used in previous\n\ * call to SSPTRD;\n\ * = 'L': Lower triangular packed storage used in previous\n\ * call to SSPTRD.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix Q. N >= 0.\n\ *\n\ * AP (input) REAL array, dimension (N*(N+1)/2)\n\ * The vectors which define the elementary reflectors, as\n\ * returned by SSPTRD.\n\ *\n\ * TAU (input) REAL array, dimension (N-1)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by SSPTRD.\n\ *\n\ * Q (output) REAL array, dimension (LDQ,N)\n\ * The N-by-N orthogonal matrix Q.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N).\n\ *\n\ * WORK (workspace) REAL array, dimension (N-1)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlaic10000644000175000017500000000534212502223526016377 0ustar uwabamiuwabami--- :name: zlaic1 :md5sum: 63910da00daf76915c35466d47fea244 :category: :subroutine :arguments: - job: :type: integer :intent: input - j: :type: integer :intent: input - x: :type: doublecomplex :intent: input :dims: - j - sest: :type: doublereal :intent: input - w: :type: doublecomplex :intent: input :dims: - j - gamma: :type: doublecomplex :intent: input - sestpr: :type: doublereal :intent: output - s: :type: doublecomplex :intent: output - c: :type: doublecomplex :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAIC1 applies one step of incremental condition estimation in\n\ * its simplest version:\n\ *\n\ * Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j\n\ * lower triangular matrix L, such that\n\ * twonorm(L*x) = sest\n\ * Then ZLAIC1 computes sestpr, s, c such that\n\ * the vector\n\ * [ s*x ]\n\ * xhat = [ c ]\n\ * is an approximate singular vector of\n\ * [ L 0 ]\n\ * Lhat = [ w' gamma ]\n\ * in the sense that\n\ * twonorm(Lhat*xhat) = sestpr.\n\ *\n\ * Depending on JOB, an estimate for the largest or smallest singular\n\ * value is computed.\n\ *\n\ * Note that [s c]' and sestpr**2 is an eigenpair of the system\n\ *\n\ * diag(sest*sest, 0) + [alpha gamma] * [ conjg(alpha) ]\n\ * [ conjg(gamma) ]\n\ *\n\ * where alpha = conjg(x)'*w.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) INTEGER\n\ * = 1: an estimate for the largest singular value is computed.\n\ * = 2: an estimate for the smallest singular value is computed.\n\ *\n\ * J (input) INTEGER\n\ * Length of X and W\n\ *\n\ * X (input) COMPLEX*16 array, dimension (J)\n\ * The j-vector x.\n\ *\n\ * SEST (input) DOUBLE PRECISION\n\ * Estimated singular value of j by j matrix L\n\ *\n\ * W (input) COMPLEX*16 array, dimension (J)\n\ * The j-vector w.\n\ *\n\ * GAMMA (input) COMPLEX*16\n\ * The diagonal element gamma.\n\ *\n\ * SESTPR (output) DOUBLE PRECISION\n\ * Estimated singular value of (j+1) by (j+1) matrix Lhat.\n\ *\n\ * S (output) COMPLEX*16\n\ * Sine needed in forming xhat.\n\ *\n\ * C (output) COMPLEX*16\n\ * Cosine needed in forming xhat.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chfrk0000644000175000017500000001061412502223525016306 0ustar uwabamiuwabami--- :name: chfrk :md5sum: 08bd40053c967bb77e3ab340f3a09c2b :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - alpha: :type: real :intent: input - a: :type: complex :intent: input :dims: - lda - "lsame_(&trans,\"N\") ? k : n" - lda: :type: integer :intent: input - beta: :type: real :intent: input - c: :type: complex :intent: input/output :dims: - ldc :substitutions: lda: "lsame_(&trans,\"N\") ? MAX(1,n) : MAX(1,k)" n: ((int)sqrtf(ldc*8+1.0f)-1)/2 :extra: ldc: integer :fortran_help: " SUBROUTINE CHFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Level 3 BLAS like routine for C in RFP Format.\n\ *\n\ * CHFRK performs one of the Hermitian rank--k operations\n\ *\n\ * C := alpha*A*conjg( A' ) + beta*C,\n\ *\n\ * or\n\ *\n\ * C := alpha*conjg( A' )*A + beta*C,\n\ *\n\ * where alpha and beta are real scalars, C is an n--by--n Hermitian\n\ * matrix and A is an n--by--k matrix in the first case and a k--by--n\n\ * matrix in the second case.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': The Normal Form of RFP A is stored;\n\ * = 'C': The Conjugate-transpose Form of RFP A is stored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * On entry, UPLO specifies whether the upper or lower\n\ * triangular part of the array C is to be referenced as\n\ * follows:\n\ *\n\ * UPLO = 'U' or 'u' Only the upper triangular part of C\n\ * is to be referenced.\n\ *\n\ * UPLO = 'L' or 'l' Only the lower triangular part of C\n\ * is to be referenced.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * On entry, TRANS specifies the operation to be performed as\n\ * follows:\n\ *\n\ * TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C.\n\ *\n\ * TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the order of the matrix C. N must be\n\ * at least zero.\n\ * Unchanged on exit.\n\ *\n\ * K (input) INTEGER\n\ * On entry with TRANS = 'N' or 'n', K specifies the number\n\ * of columns of the matrix A, and on entry with\n\ * TRANS = 'C' or 'c', K specifies the number of rows of the\n\ * matrix A. K must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * ALPHA (input) REAL\n\ * On entry, ALPHA specifies the scalar alpha.\n\ * Unchanged on exit.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,ka)\n\ * where KA\n\ * is K when TRANS = 'N' or 'n', and is N otherwise. Before\n\ * entry with TRANS = 'N' or 'n', the leading N--by--K part of\n\ * the array A must contain the matrix A, otherwise the leading\n\ * K--by--N part of the array A must contain the matrix A.\n\ * Unchanged on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * On entry, LDA specifies the first dimension of A as declared\n\ * in the calling (sub) program. When TRANS = 'N' or 'n'\n\ * then LDA must be at least max( 1, n ), otherwise LDA must\n\ * be at least max( 1, k ).\n\ * Unchanged on exit.\n\ *\n\ * BETA (input) REAL\n\ * On entry, BETA specifies the scalar beta.\n\ * Unchanged on exit.\n\ *\n\ * C (input/output) COMPLEX array, dimension (N*(N+1)/2)\n\ * On entry, the matrix A in RFP Format. RFP Format is\n\ * described by TRANSR, UPLO and N. Note that the imaginary\n\ * parts of the diagonal elements need not be set, they are\n\ * assumed to be zero, and on exit they are set to zero.\n\ *\n\ * Arguments\n\ * ==========\n\ *\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlaed30000644000175000017500000001265612502223526016356 0ustar uwabamiuwabami--- :name: dlaed3 :md5sum: 43bf65fad7f2277e7f8939b3c02e35ac :category: :subroutine :arguments: - k: :type: integer :intent: input - n: :type: integer :intent: input - n1: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - n - q: :type: doublereal :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - rho: :type: doublereal :intent: input - dlamda: :type: doublereal :intent: input/output :dims: - k - q2: :type: doublereal :intent: input :dims: - n - n - indx: :type: integer :intent: input :dims: - n - ctot: :type: integer :intent: input :dims: - "4" - w: :type: doublereal :intent: input/output :dims: - k - s: :type: doublereal :intent: workspace :dims: - MAX(1,k) - (n1 + 1) - info: :type: integer :intent: output :substitutions: ldq: MAX(1,n) :fortran_help: " SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX, CTOT, W, S, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAED3 finds the roots of the secular equation, as defined by the\n\ * values in D, W, and RHO, between 1 and K. It makes the\n\ * appropriate calls to DLAED4 and then updates the eigenvectors by\n\ * multiplying the matrix of eigenvectors of the pair of eigensystems\n\ * being combined by the matrix of eigenvectors of the K-by-K system\n\ * which is solved here.\n\ *\n\ * This code makes very mild assumptions about floating point\n\ * arithmetic. It will work on machines with a guard digit in\n\ * add/subtract, or on those binary machines without guard digits\n\ * which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n\ * It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * K (input) INTEGER\n\ * The number of terms in the rational function to be solved by\n\ * DLAED4. K >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of rows and columns in the Q matrix.\n\ * N >= K (deflation may result in N>K).\n\ *\n\ * N1 (input) INTEGER\n\ * The location of the last eigenvalue in the leading submatrix.\n\ * min(1,N) <= N1 <= N/2.\n\ *\n\ * D (output) DOUBLE PRECISION array, dimension (N)\n\ * D(I) contains the updated eigenvalues for\n\ * 1 <= I <= K.\n\ *\n\ * Q (output) DOUBLE PRECISION array, dimension (LDQ,N)\n\ * Initially the first K columns are used as workspace.\n\ * On output the columns 1 to K contain\n\ * the updated eigenvectors.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N).\n\ *\n\ * RHO (input) DOUBLE PRECISION\n\ * The value of the parameter in the rank one update equation.\n\ * RHO >= 0 required.\n\ *\n\ * DLAMDA (input/output) DOUBLE PRECISION array, dimension (K)\n\ * The first K elements of this array contain the old roots\n\ * of the deflated updating problem. These are the poles\n\ * of the secular equation. May be changed on output by\n\ * having lowest order bit set to zero on Cray X-MP, Cray Y-MP,\n\ * Cray-2, or Cray C-90, as described above.\n\ *\n\ * Q2 (input) DOUBLE PRECISION array, dimension (LDQ2, N)\n\ * The first K columns of this matrix contain the non-deflated\n\ * eigenvectors for the split problem.\n\ *\n\ * INDX (input) INTEGER array, dimension (N)\n\ * The permutation used to arrange the columns of the deflated\n\ * Q matrix into three groups (see DLAED2).\n\ * The rows of the eigenvectors found by DLAED4 must be likewise\n\ * permuted before the matrix multiply can take place.\n\ *\n\ * CTOT (input) INTEGER array, dimension (4)\n\ * A count of the total number of the various types of columns\n\ * in Q, as described in INDX. The fourth column type is any\n\ * column which has been deflated.\n\ *\n\ * W (input/output) DOUBLE PRECISION array, dimension (K)\n\ * The first K elements of this array contain the components\n\ * of the deflation-adjusted updating vector. Destroyed on\n\ * output.\n\ *\n\ * S (workspace) DOUBLE PRECISION array, dimension (N1 + 1)*K\n\ * Will contain the eigenvectors of the repaired matrix which\n\ * will be multiplied by the previously accumulated eigenvectors\n\ * to update the system.\n\ *\n\ * LDS (input) INTEGER\n\ * The leading dimension of S. LDS >= max(1,K).\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 = 1, an eigenvalue did not converge\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Jeff Rutter, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ * Modified by Francoise Tisseur, University of Tennessee.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slarre0000644000175000017500000002215412502223526016504 0ustar uwabamiuwabami--- :name: slarre :md5sum: 98a7ef095c3e263ebe5088ca21b69c1a :category: :subroutine :arguments: - range: :type: char :intent: input - n: :type: integer :intent: input - vl: :type: real :intent: input/output - vu: :type: real :intent: input/output - il: :type: integer :intent: input - iu: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n - e2: :type: real :intent: input/output :dims: - n - rtol1: :type: real :intent: input - rtol2: :type: real :intent: input - spltol: :type: real :intent: input - nsplit: :type: integer :intent: output - isplit: :type: integer :intent: output :dims: - n - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - werr: :type: real :intent: output :dims: - n - wgap: :type: real :intent: output :dims: - n - iblock: :type: integer :intent: output :dims: - n - indexw: :type: integer :intent: output :dims: - n - gers: :type: real :intent: output :dims: - 2*n - pivmin: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 6*n - iwork: :type: integer :intent: workspace :dims: - 5*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLARRE( RANGE, N, VL, VU, IL, IU, D, E, E2, RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT, M, W, WERR, WGAP, IBLOCK, INDEXW, GERS, PIVMIN, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * To find the desired eigenvalues of a given real symmetric\n\ * tridiagonal matrix T, SLARRE sets any \"small\" off-diagonal\n\ * elements to zero, and for each unreduced block T_i, it finds\n\ * (a) a suitable shift at one end of the block's spectrum,\n\ * (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and\n\ * (c) eigenvalues of each L_i D_i L_i^T.\n\ * The representations and eigenvalues found are then used by\n\ * SSTEMR to compute the eigenvectors of T.\n\ * The accuracy varies depending on whether bisection is used to\n\ * find a few eigenvalues or the dqds algorithm (subroutine SLASQ2) to\n\ * conpute all and then discard any unwanted one.\n\ * As an added benefit, SLARRE also outputs the n\n\ * Gerschgorin intervals for the matrices L_i D_i L_i^T.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': (\"All\") all eigenvalues will be found.\n\ * = 'V': (\"Value\") all eigenvalues in the half-open interval\n\ * (VL, VU] will be found.\n\ * = 'I': (\"Index\") the IL-th through IU-th eigenvalues (of the\n\ * entire matrix) will be found.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N > 0.\n\ *\n\ * VL (input/output) REAL \n\ * VU (input/output) REAL \n\ * If RANGE='V', the lower and upper bounds for the eigenvalues.\n\ * Eigenvalues less than or equal to VL, or greater than VU,\n\ * will not be returned. VL < VU.\n\ * If RANGE='I' or ='A', SLARRE computes bounds on the desired\n\ * part of the spectrum.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the N diagonal elements of the tridiagonal\n\ * matrix T.\n\ * On exit, the N diagonal elements of the diagonal\n\ * matrices D_i.\n\ *\n\ * E (input/output) REAL array, dimension (N)\n\ * On entry, the first (N-1) entries contain the subdiagonal\n\ * elements of the tridiagonal matrix T; E(N) need not be set.\n\ * On exit, E contains the subdiagonal elements of the unit\n\ * bidiagonal matrices L_i. The entries E( ISPLIT( I ) ),\n\ * 1 <= I <= NSPLIT, contain the base points sigma_i on output.\n\ *\n\ * E2 (input/output) REAL array, dimension (N)\n\ * On entry, the first (N-1) entries contain the SQUARES of the\n\ * subdiagonal elements of the tridiagonal matrix T;\n\ * E2(N) need not be set.\n\ * On exit, the entries E2( ISPLIT( I ) ),\n\ * 1 <= I <= NSPLIT, have been set to zero\n\ *\n\ * RTOL1 (input) REAL \n\ * RTOL2 (input) REAL \n\ * Parameters for bisection.\n\ * An interval [LEFT,RIGHT] has converged if\n\ * RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n\ *\n\ * SPLTOL (input) REAL \n\ * The threshold for splitting.\n\ *\n\ * NSPLIT (output) INTEGER\n\ * The number of blocks T splits into. 1 <= NSPLIT <= N.\n\ *\n\ * ISPLIT (output) INTEGER array, dimension (N)\n\ * The splitting points, at which T breaks up into blocks.\n\ * The first block consists of rows/columns 1 to ISPLIT(1),\n\ * the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n\ * etc., and the NSPLIT-th consists of rows/columns\n\ * ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues (of all L_i D_i L_i^T)\n\ * found.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * The first M elements contain the eigenvalues. The\n\ * eigenvalues of each of the blocks, L_i D_i L_i^T, are\n\ * sorted in ascending order ( SLARRE may use the\n\ * remaining N-M elements as workspace).\n\ *\n\ * WERR (output) REAL array, dimension (N)\n\ * The error bound on the corresponding eigenvalue in W.\n\ *\n\ * WGAP (output) REAL array, dimension (N)\n\ * The separation from the right neighbor eigenvalue in W.\n\ * The gap is only with respect to the eigenvalues of the same block\n\ * as each block has its own representation tree.\n\ * Exception: at the right end of a block we store the left gap\n\ *\n\ * IBLOCK (output) INTEGER array, dimension (N)\n\ * The indices of the blocks (submatrices) associated with the\n\ * corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue\n\ * W(i) belongs to the first block from the top, =2 if W(i)\n\ * belongs to the second block, etc.\n\ *\n\ * INDEXW (output) INTEGER array, dimension (N)\n\ * The indices of the eigenvalues within each block (submatrix);\n\ * for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the\n\ * i-th eigenvalue W(i) is the 10-th eigenvalue in block 2\n\ *\n\ * GERS (output) REAL array, dimension (2*N)\n\ * The N Gerschgorin intervals (the i-th Gerschgorin interval\n\ * is (GERS(2*i-1), GERS(2*i)).\n\ *\n\ * PIVMIN (output) REAL\n\ * The minimum pivot in the Sturm sequence for T.\n\ *\n\ * WORK (workspace) REAL array, dimension (6*N)\n\ * Workspace.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (5*N)\n\ * Workspace.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * > 0: A problem occured in SLARRE.\n\ * < 0: One of the called subroutines signaled an internal problem.\n\ * Needs inspection of the corresponding parameter IINFO\n\ * for further information.\n\ *\n\ * =-1: Problem in SLARRD.\n\ * = 2: No base representation could be found in MAXTRY iterations.\n\ * Increasing MAXTRY and recompilation might be a remedy.\n\ * =-3: Problem in SLARRB when computing the refined root\n\ * representation for SLASQ2.\n\ * =-4: Problem in SLARRB when preforming bisection on the\n\ * desired part of the spectrum.\n\ * =-5: Problem in SLASQ2.\n\ * =-6: Problem in SLASQ2.\n\ *\n\n\ * Further Details\n\ * The base representations are required to suffer very little\n\ * element growth and consequently define all their eigenvalues to\n\ * high relative accuracy.\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Beresford Parlett, University of California, Berkeley, USA\n\ * Jim Demmel, University of California, Berkeley, USA\n\ * Inderjit Dhillon, University of Texas, Austin, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, University of California, Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cstein0000644000175000017500000001177012502223525016502 0ustar uwabamiuwabami--- :name: cstein :md5sum: 738c45b1cce1bfa88f60e473bd396273 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: real :intent: input :dims: - n-1 - m: :type: integer :intent: input - w: :type: real :intent: input :dims: - n - iblock: :type: integer :intent: input :dims: - n - isplit: :type: integer :intent: input :dims: - n - z: :type: complex :intent: output :dims: - ldz - m - ldz: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 5*n - iwork: :type: integer :intent: workspace :dims: - n - ifail: :type: integer :intent: output :dims: - m - info: :type: integer :intent: output :substitutions: ldz: MAX(1,n) m: n :fortran_help: " SUBROUTINE CSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSTEIN computes the eigenvectors of a real symmetric tridiagonal\n\ * matrix T corresponding to specified eigenvalues, using inverse\n\ * iteration.\n\ *\n\ * The maximum number of iterations allowed for each eigenvector is\n\ * specified by an internal parameter MAXITS (currently set to 5).\n\ *\n\ * Although the eigenvectors are real, they are stored in a complex\n\ * array, which may be passed to CUNMTR or CUPMTR for back\n\ * transformation to the eigenvectors of a complex Hermitian matrix\n\ * which was reduced to tridiagonal form.\n\ *\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The n diagonal elements of the tridiagonal matrix T.\n\ *\n\ * E (input) REAL array, dimension (N-1)\n\ * The (n-1) subdiagonal elements of the tridiagonal matrix\n\ * T, stored in elements 1 to N-1.\n\ *\n\ * M (input) INTEGER\n\ * The number of eigenvectors to be found. 0 <= M <= N.\n\ *\n\ * W (input) REAL array, dimension (N)\n\ * The first M elements of W contain the eigenvalues for\n\ * which eigenvectors are to be computed. The eigenvalues\n\ * should be grouped by split-off block and ordered from\n\ * smallest to largest within the block. ( The output array\n\ * W from SSTEBZ with ORDER = 'B' is expected here. )\n\ *\n\ * IBLOCK (input) INTEGER array, dimension (N)\n\ * The submatrix indices associated with the corresponding\n\ * eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to\n\ * the first submatrix from the top, =2 if W(i) belongs to\n\ * the second submatrix, etc. ( The output array IBLOCK\n\ * from SSTEBZ is expected here. )\n\ *\n\ * ISPLIT (input) INTEGER array, dimension (N)\n\ * The splitting points, at which T breaks up into submatrices.\n\ * The first submatrix consists of rows/columns 1 to\n\ * ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n\ * through ISPLIT( 2 ), etc.\n\ * ( The output array ISPLIT from SSTEBZ is expected here. )\n\ *\n\ * Z (output) COMPLEX array, dimension (LDZ, M)\n\ * The computed eigenvectors. The eigenvector associated\n\ * with the eigenvalue W(i) is stored in the i-th column of\n\ * Z. Any vector which fails to converge is set to its current\n\ * iterate after MAXITS iterations.\n\ * The imaginary parts of the eigenvectors are set to zero.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) REAL array, dimension (5*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * IFAIL (output) INTEGER array, dimension (M)\n\ * On normal exit, all elements of IFAIL are zero.\n\ * If one or more eigenvectors fail to converge after\n\ * MAXITS iterations, then their indices are stored in\n\ * array IFAIL.\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, then i eigenvectors failed to converge\n\ * in MAXITS iterations. Their indices are stored in\n\ * array IFAIL.\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * MAXITS INTEGER, default = 5\n\ * The maximum number of iterations performed.\n\ *\n\ * EXTRA INTEGER, default = 2\n\ * The number of iterations performed after norm growth\n\ * criterion is satisfied, should be at least 1.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgetrs0000644000175000017500000000474412502223526016511 0ustar uwabamiuwabami--- :name: dgetrs :md5sum: 065854a0ebb4465961ce7034ae87b2eb :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGETRS solves a system of linear equations\n\ * A * X = B or A' * X = B\n\ * with a general N-by-N matrix A using the LU factorization computed\n\ * by DGETRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A'* X = B (Transpose)\n\ * = 'C': A'* X = B (Conjugate transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The factors L and U from the factorization A = P*L*U\n\ * as computed by DGETRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from DGETRF; for 1<=i<=N, row i of the\n\ * matrix was interchanged with row IPIV(i).\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgbtrf0000644000175000017500000000740212502223526016502 0ustar uwabamiuwabami--- :name: sgbtrf :md5sum: 8af1a2a140a4794550498ad4693a88c2 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGBTRF computes an LU factorization of a real m-by-n band matrix A\n\ * using partial pivoting with row interchanges.\n\ *\n\ * This is the blocked version of the algorithm, calling Level 3 BLAS.\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\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * AB (input/output) REAL array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows KL+1 to\n\ * 2*KL+KU+1; rows 1 to KL of the array need not be set.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n\ *\n\ * On exit, details of the factorization: U is stored as an\n\ * upper triangular band matrix with KL+KU superdiagonals in\n\ * rows 1 to KL+KU+1, and the multipliers used during the\n\ * factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n\ * See below for further details.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n\ *\n\ * IPIV (output) INTEGER array, dimension (min(M,N))\n\ * The pivot indices; for 1 <= i <= min(M,N), row i of the\n\ * matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, and division by zero will occur if it is used\n\ * to solve a system of equations.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * M = N = 6, KL = 2, KU = 1:\n\ *\n\ * On entry: On exit:\n\ *\n\ * * * * + + + * * * u14 u25 u36\n\ * * * + + + + * * u13 u24 u35 u46\n\ * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n\ * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n\ * a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n\ * a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n\ *\n\ * Array elements marked * are not used by the routine; elements marked\n\ * + need not be set on entry, but are required by the routine to store\n\ * elements of U because of fill-in resulting from the row interchanges.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cunglq0000644000175000017500000000567312502223526016514 0ustar uwabamiuwabami--- :name: cunglq :md5sum: d4f3daf8bd53210a78b538ace0bd1b56 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CUNGLQ generates an M-by-N complex matrix Q with orthonormal rows,\n\ * which is defined as the first M rows of a product of K elementary\n\ * reflectors of order N\n\ *\n\ * Q = H(k)' . . . H(2)' H(1)'\n\ *\n\ * as returned by CGELQF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. N >= M.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. M >= K >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the i-th row must contain the vector which defines\n\ * the elementary reflector H(i), for i = 1,2,...,k, as returned\n\ * by CGELQF in the first k rows of its array argument A.\n\ * On exit, the M-by-N matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) COMPLEX array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by CGELQF.\n\ *\n\ * WORK (workspace/output) COMPLEX 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\n\ * the 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 has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zggev0000644000175000017500000001503012502223526016331 0ustar uwabamiuwabami--- :name: zggev :md5sum: e16117b677fb268d46e4067d8d0d98ff :category: :subroutine :arguments: - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alpha: :type: doublecomplex :intent: output :dims: - n - beta: :type: doublecomplex :intent: output :dims: - n - vl: :type: doublecomplex :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: doublecomplex :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(1,2*n) - rwork: :type: doublereal :intent: output :dims: - 8*n - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " SUBROUTINE ZGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGGEV computes for a pair of N-by-N complex nonsymmetric matrices\n\ * (A,B), the generalized eigenvalues, and optionally, the left and/or\n\ * right generalized eigenvectors.\n\ *\n\ * A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n\ * lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n\ * singular. It is usually represented as the pair (alpha,beta), as\n\ * there is a reasonable interpretation for beta=0, and even for both\n\ * being zero.\n\ *\n\ * The right generalized eigenvector v(j) corresponding to the\n\ * generalized eigenvalue lambda(j) of (A,B) satisfies\n\ *\n\ * A * v(j) = lambda(j) * B * v(j).\n\ *\n\ * The left generalized eigenvector u(j) corresponding to the\n\ * generalized eigenvalues lambda(j) of (A,B) satisfies\n\ *\n\ * u(j)**H * A = lambda(j) * u(j)**H * B\n\ *\n\ * where u(j)**H is the conjugate-transpose of u(j).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVL (input) CHARACTER*1\n\ * = 'N': do not compute the left generalized eigenvectors;\n\ * = 'V': compute the left generalized eigenvectors.\n\ *\n\ * JOBVR (input) CHARACTER*1\n\ * = 'N': do not compute the right generalized eigenvectors;\n\ * = 'V': compute the right generalized eigenvectors.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A, B, VL, and VR. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA, N)\n\ * On entry, the matrix A in the pair (A,B).\n\ * On exit, A has been overwritten.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB, N)\n\ * On entry, the matrix B in the pair (A,B).\n\ * On exit, B has been overwritten.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B. LDB >= max(1,N).\n\ *\n\ * ALPHA (output) COMPLEX*16 array, dimension (N)\n\ * BETA (output) COMPLEX*16 array, dimension (N)\n\ * On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the\n\ * generalized eigenvalues.\n\ *\n\ * Note: the quotients ALPHA(j)/BETA(j) may easily over- or\n\ * underflow, and BETA(j) may even be zero. Thus, the user\n\ * should avoid naively computing the ratio alpha/beta.\n\ * However, ALPHA will be always less than and usually\n\ * comparable with norm(A) in magnitude, and BETA always less\n\ * than and usually comparable with norm(B).\n\ *\n\ * VL (output) COMPLEX*16 array, dimension (LDVL,N)\n\ * If JOBVL = 'V', the left generalized eigenvectors u(j) are\n\ * stored one after another in the columns of VL, in the same\n\ * order as their eigenvalues.\n\ * Each eigenvector is scaled so the largest component has\n\ * abs(real part) + abs(imag. part) = 1.\n\ * Not referenced if JOBVL = 'N'.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the matrix VL. LDVL >= 1, and\n\ * if JOBVL = 'V', LDVL >= N.\n\ *\n\ * VR (output) COMPLEX*16 array, dimension (LDVR,N)\n\ * If JOBVR = 'V', the right generalized eigenvectors v(j) are\n\ * stored one after another in the columns of VR, in the same\n\ * order as their eigenvalues.\n\ * Each eigenvector is scaled so the largest component has\n\ * abs(real part) + abs(imag. part) = 1.\n\ * Not referenced if JOBVR = 'N'.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the matrix VR. LDVR >= 1, and\n\ * if JOBVR = 'V', LDVR >= N.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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,2*N).\n\ * For good performance, LWORK must generally be larger.\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\ * RWORK (workspace/output) DOUBLE PRECISION array, dimension (8*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * =1,...,N:\n\ * The QZ iteration failed. No eigenvectors have been\n\ * calculated, but ALPHA(j) and BETA(j) should be\n\ * correct for j=INFO+1,...,N.\n\ * > N: =N+1: other then QZ iteration failed in DHGEQZ,\n\ * =N+2: error return from DTGEVC.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cla_gercond_x0000644000175000017500000000675712502223525020015 0ustar uwabamiuwabami--- :name: cla_gercond_x :md5sum: 901839bd8115eba9bf98a6db1f4b7bb9 :category: :function :type: real :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - x: :type: complex :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: complex :intent: input :dims: - 2*n - rwork: :type: real :intent: input :dims: - n :substitutions: {} :fortran_help: " REAL FUNCTION CLA_GERCOND_X( TRANS, N, A, LDA, AF, LDAF, IPIV, X, INFO, WORK, RWORK )\n\n\ * Purpose\n\ * =======\n\ * \n\ * CLA_GERCOND_X computes the infinity norm condition number of\n\ * op(A) * diag(X) where X is a COMPLEX vector.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate Transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX array, dimension (LDAF,N)\n\ * The factors L and U from the factorization\n\ * A = P*L*U as computed by CGETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from the factorization A = P*L*U\n\ * as computed by CGETRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * X (input) COMPLEX array, dimension (N)\n\ * The vector X in the formula op(A) * diag(X).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * i > 0: The ith argument is invalid.\n\ *\n\ * WORK (input) COMPLEX array, dimension (2*N).\n\ * Workspace.\n\ *\n\ * RWORK (input) REAL array, dimension (N).\n\ * Workspace.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE\n REAL AINVNM, ANORM, TMP\n INTEGER I, J\n COMPLEX ZDUM\n\ * ..\n\ * .. Local Arrays ..\n INTEGER ISAVE( 3 )\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CLACN2, CGETRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, REAL, AIMAG\n\ * ..\n\ * .. Statement Functions ..\n REAL CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slasq10000644000175000017500000000466712502223526016431 0ustar uwabamiuwabami--- :name: slasq1 :md5sum: 37d790add72999bf796dea9d2b43e8e2 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n - work: :type: real :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLASQ1( N, D, E, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLASQ1 computes the singular values of a real N-by-N bidiagonal\n\ * matrix with diagonal D and off-diagonal E. The singular values\n\ * are computed to high relative accuracy, in the absence of\n\ * denormalization, underflow and overflow. The algorithm was first\n\ * presented in\n\ *\n\ * \"Accurate singular values and differential qd algorithms\" by K. V.\n\ * Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230,\n\ * 1994,\n\ *\n\ * and the present implementation is described in \"An implementation of\n\ * the dqds Algorithm (Positive Case)\", LAPACK Working Note.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of rows and columns in the matrix. N >= 0.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, D contains the diagonal elements of the\n\ * bidiagonal matrix whose SVD is desired. On normal exit,\n\ * D contains the singular values in decreasing order.\n\ *\n\ * E (input/output) REAL array, dimension (N)\n\ * On entry, elements E(1:N-1) contain the off-diagonal elements\n\ * of the bidiagonal matrix whose SVD is desired.\n\ * On exit, E is overwritten.\n\ *\n\ * WORK (workspace) REAL array, dimension (4*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: the algorithm failed\n\ * = 1, a split was marked by a positive value in E\n\ * = 2, current block of Z not diagonalized after 30*N\n\ * iterations (in inner while loop)\n\ * = 3, termination criterion of outer while loop not met \n\ * (program created more than N unreduced blocks)\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sormql0000644000175000017500000001043012502223526016523 0ustar uwabamiuwabami--- :name: sormql :md5sum: 82e0f91f76caa378359d0a433113338f :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SORMQL overwrites the general real M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'T': Q**T * C C * Q**T\n\ *\n\ * where Q is a real orthogonal matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(k) . . . H(2) H(1)\n\ *\n\ * as returned by SGEQLF. Q is of order M if SIDE = 'L' and of order N\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**T from the Left;\n\ * = 'R': apply Q or Q**T from the Right.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q;\n\ * = 'T': Transpose, apply Q**T.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,K)\n\ * The i-th column must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * SGEQLF in the last k columns of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ * If SIDE = 'L', LDA >= max(1,M);\n\ * if SIDE = 'R', LDA >= max(1,N).\n\ *\n\ * TAU (input) REAL array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by SGEQLF.\n\ *\n\ * C (input/output) REAL array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace/output) REAL 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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M).\n\ * For optimum performance LWORK >= N*NB if SIDE = 'L', and\n\ * LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n\ * 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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgttrs0000644000175000017500000000676712502223525016535 0ustar uwabamiuwabami--- :name: cgttrs :md5sum: 2ee48e0bb1e224a8e456011f2c24bf31 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: complex :intent: input :dims: - n-1 - d: :type: complex :intent: input :dims: - n - du: :type: complex :intent: input :dims: - n-1 - du2: :type: complex :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGTTRS solves one of the systems of equations\n\ * A * X = B, A**T * X = B, or A**H * X = B,\n\ * with a tridiagonal matrix A using the LU factorization computed\n\ * by CGTTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations.\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * DL (input) COMPLEX array, dimension (N-1)\n\ * The (n-1) multipliers that define the matrix L from the\n\ * LU factorization of A.\n\ *\n\ * D (input) COMPLEX array, dimension (N)\n\ * The n diagonal elements of the upper triangular matrix U from\n\ * the LU factorization of A.\n\ *\n\ * DU (input) COMPLEX array, dimension (N-1)\n\ * The (n-1) elements of the first super-diagonal of U.\n\ *\n\ * DU2 (input) COMPLEX array, dimension (N-2)\n\ * The (n-2) elements of the second super-diagonal of U.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices; for 1 <= i <= n, row i of the matrix was\n\ * interchanged with row IPIV(i). IPIV(i) will always be either\n\ * i or i+1; IPIV(i) = i indicates a row interchange was not\n\ * required.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the matrix of right hand side vectors B.\n\ * On exit, B is overwritten by the solution vectors X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL NOTRAN\n INTEGER ITRANS, J, JB, NB\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CGTTS2, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlarrv0000644000175000017500000002226512655767354016536 0ustar uwabamiuwabami--- :name: dlarrv :md5sum: 955488910714829a06c9ad0b196024a4 :category: :subroutine :arguments: - n: :type: integer :intent: input - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - d: :type: doublereal :intent: input/output :dims: - n - l: :type: doublereal :intent: input/output :dims: - n - pivmin: :type: doublereal :intent: input - isplit: :type: integer :intent: input :dims: - n - m: :type: integer :intent: input - dol: :type: integer :intent: input - dou: :type: integer :intent: input - minrgp: :type: doublereal :intent: input - rtol1: :type: doublereal :intent: input - rtol2: :type: doublereal :intent: input - w: :type: doublereal :intent: input/output :dims: - n - werr: :type: doublereal :intent: input/output :dims: - n - wgap: :type: doublereal :intent: input/output :dims: - n - iblock: :type: integer :intent: input :dims: - n - indexw: :type: integer :intent: input :dims: - n - gers: :type: doublereal :intent: input :dims: - 2*n - z: :type: doublereal :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - work: :type: doublereal :intent: workspace :dims: - 12*n - iwork: :type: integer :intent: workspace :dims: - 7*n - info: :type: integer :intent: output :substitutions: ldz: n :fortran_help: " SUBROUTINE DLARRV( N, VL, VU, D, L, PIVMIN, ISPLIT, M, DOL, DOU, MINRGP, RTOL1, RTOL2, W, WERR, WGAP, IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLARRV computes the eigenvectors of the tridiagonal matrix\n\ * T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T.\n\ * The input eigenvalues should have been computed by DLARRE.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * VL (input) DOUBLE PRECISION\n\ * VU (input) DOUBLE PRECISION\n\ * Lower and upper bounds of the interval that contains the desired\n\ * eigenvalues. VL < VU. Needed to compute gaps on the left or right\n\ * end of the extremal eigenvalues in the desired RANGE.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the N diagonal elements of the diagonal matrix D.\n\ * On exit, D may be overwritten.\n\ *\n\ * L (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the (N-1) subdiagonal elements of the unit\n\ * bidiagonal matrix L are in elements 1 to N-1 of L\n\ * (if the matrix is not split.) At the end of each block\n\ * is stored the corresponding shift as given by DLARRE.\n\ * On exit, L is overwritten.\n\ *\n\ * PIVMIN (input) DOUBLE PRECISION\n\ * The minimum pivot allowed in the Sturm sequence.\n\ *\n\ * ISPLIT (input) INTEGER array, dimension (N)\n\ * The splitting points, at which T breaks up into blocks.\n\ * The first block consists of rows/columns 1 to\n\ * ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n\ * through ISPLIT( 2 ), etc.\n\ *\n\ * M (input) INTEGER\n\ * The total number of input eigenvalues. 0 <= M <= N.\n\ *\n\ * DOL (input) INTEGER\n\ * DOU (input) INTEGER\n\ * If the user wants to compute only selected eigenvectors from all\n\ * the eigenvalues supplied, he can specify an index range DOL:DOU.\n\ * Or else the setting DOL=1, DOU=M should be applied.\n\ * Note that DOL and DOU refer to the order in which the eigenvalues\n\ * are stored in W.\n\ * If the user wants to compute only selected eigenpairs, then\n\ * the columns DOL-1 to DOU+1 of the eigenvector space Z contain the\n\ * computed eigenvectors. All other columns of Z are set to zero.\n\ *\n\ * MINRGP (input) DOUBLE PRECISION\n\ *\n\ * RTOL1 (input) DOUBLE PRECISION\n\ * RTOL2 (input) DOUBLE PRECISION\n\ * Parameters for bisection.\n\ * An interval [LEFT,RIGHT] has converged if\n\ * RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n\ *\n\ * W (input/output) DOUBLE PRECISION array, dimension (N)\n\ * The first M elements of W contain the APPROXIMATE eigenvalues for\n\ * which eigenvectors are to be computed. The eigenvalues\n\ * should be grouped by split-off block and ordered from\n\ * smallest to largest within the block ( The output array\n\ * W from DLARRE is expected here ). Furthermore, they are with\n\ * respect to the shift of the corresponding root representation\n\ * for their block. On exit, W holds the eigenvalues of the\n\ * UNshifted matrix.\n\ *\n\ * WERR (input/output) DOUBLE PRECISION array, dimension (N)\n\ * The first M elements contain the semiwidth of the uncertainty\n\ * interval of the corresponding eigenvalue in W\n\ *\n\ * WGAP (input/output) DOUBLE PRECISION array, dimension (N)\n\ * The separation from the right neighbor eigenvalue in W.\n\ *\n\ * IBLOCK (input) INTEGER array, dimension (N)\n\ * The indices of the blocks (submatrices) associated with the\n\ * corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue\n\ * W(i) belongs to the first block from the top, =2 if W(i)\n\ * belongs to the second block, etc.\n\ *\n\ * INDEXW (input) INTEGER array, dimension (N)\n\ * The indices of the eigenvalues within each block (submatrix);\n\ * for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the\n\ * i-th eigenvalue W(i) is the 10-th eigenvalue in the second block.\n\ *\n\ * GERS (input) DOUBLE PRECISION array, dimension (2*N)\n\ * The N Gerschgorin intervals (the i-th Gerschgorin interval\n\ * is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should\n\ * be computed from the original UNshifted matrix.\n\ *\n\ * Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )\n\ * If INFO = 0, the first M columns of Z contain the\n\ * orthonormal eigenvectors of the matrix T\n\ * corresponding to the input eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )\n\ * The support of the eigenvectors in Z, i.e., the indices\n\ * indicating the nonzero elements in Z. The I-th eigenvector\n\ * is nonzero only in elements ISUPPZ( 2*I-1 ) through\n\ * ISUPPZ( 2*I ).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (12*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (7*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ *\n\ * > 0: A problem occured in DLARRV.\n\ * < 0: One of the called subroutines signaled an internal problem.\n\ * Needs inspection of the corresponding parameter IINFO\n\ * for further information.\n\ *\n\ * =-1: Problem in DLARRB when refining a child's eigenvalues.\n\ * =-2: Problem in DLARRF when computing the RRR of a child.\n\ * When a child is inside a tight cluster, it can be difficult\n\ * to find an RRR. A partial remedy from the user's point of\n\ * view is to make the parameter MINRGP smaller and recompile.\n\ * However, as the orthogonality of the computed vectors is\n\ * proportional to 1/MINRGP, the user should be aware that\n\ * he might be trading in precision when he decreases MINRGP.\n\ * =-3: Problem in DLARRB when refining a single eigenvalue\n\ * after the Rayleigh correction was rejected.\n\ * = 5: The Rayleigh Quotient Iteration failed to converge to\n\ * full accuracy in MAXITR steps.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Beresford Parlett, University of California, Berkeley, USA\n\ * Jim Demmel, University of California, Berkeley, USA\n\ * Inderjit Dhillon, University of Texas, Austin, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, University of California, Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sopmtr0000644000175000017500000000705712502223526016545 0ustar uwabamiuwabami--- :name: sopmtr :md5sum: 4b67d05bda91d23c14cdd5edc2424ec8 :category: :subroutine :arguments: - side: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input :dims: - m*(m+1)/2 - tau: :type: real :intent: input :dims: - m-1 - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SOPMTR overwrites the general real M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'T': Q**T * C C * Q**T\n\ *\n\ * where Q is a real orthogonal matrix of order nq, with nq = m if\n\ * SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of\n\ * nq-1 elementary reflectors, as returned by SSPTRD using packed\n\ * storage:\n\ *\n\ * if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);\n\ *\n\ * if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**T from the Left;\n\ * = 'R': apply Q or Q**T from the Right.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangular packed storage used in previous\n\ * call to SSPTRD;\n\ * = 'L': Lower triangular packed storage used in previous\n\ * call to SSPTRD.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q;\n\ * = 'T': Transpose, apply Q**T.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * AP (input) REAL array, dimension\n\ * (M*(M+1)/2) if SIDE = 'L'\n\ * (N*(N+1)/2) if SIDE = 'R'\n\ * The vectors which define the elementary reflectors, as\n\ * returned by SSPTRD. AP is modified by the routine but\n\ * restored on exit.\n\ *\n\ * TAU (input) REAL array, dimension (M-1) if SIDE = 'L'\n\ * or (N-1) if SIDE = 'R'\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by SSPTRD.\n\ *\n\ * C (input/output) REAL array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) REAL array, dimension\n\ * (N) if SIDE = 'L'\n\ * (M) if SIDE = 'R'\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlaqr00000644000175000017500000001746312502223526016434 0ustar uwabamiuwabami--- :name: zlaqr0 :md5sum: b1ca48722dced304d23bdf7ff40fa5fd :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: doublecomplex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - w: :type: doublecomplex :intent: output :dims: - n - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: doublecomplex :intent: input/output :dims: - "wantz ? ldz : 0" - "wantz ? ihi : 0" - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAQR0 computes the eigenvalues of a Hessenberg matrix H\n\ * and, optionally, the matrices T and Z from the Schur decomposition\n\ * H = Z T Z**H, where T is an upper triangular matrix (the\n\ * Schur form), and Z is the unitary matrix of Schur vectors.\n\ *\n\ * Optionally Z may be postmultiplied into an input unitary\n\ * matrix Q so that this routine can give the Schur factorization\n\ * of a matrix A which has been reduced to the Hessenberg form H\n\ * by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * WANTT (input) LOGICAL\n\ * = .TRUE. : the full Schur form T is required;\n\ * = .FALSE.: only eigenvalues are required.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * = .TRUE. : the matrix of Schur vectors Z is required;\n\ * = .FALSE.: Schur vectors are not required.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H. N .GE. 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * It is assumed that H is already upper triangular in rows\n\ * and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n\ * H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n\ * previous call to ZGEBAL, and then passed to ZGEHRD when the\n\ * matrix output by ZGEBAL is reduced to Hessenberg form.\n\ * Otherwise, ILO and IHI should be set to 1 and N,\n\ * respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n\ * If N = 0, then ILO = 1 and IHI = 0.\n\ *\n\ * H (input/output) COMPLEX*16 array, dimension (LDH,N)\n\ * On entry, the upper Hessenberg matrix H.\n\ * On exit, if INFO = 0 and WANTT is .TRUE., then H\n\ * contains the upper triangular matrix T from the Schur\n\ * decomposition (the Schur form). If INFO = 0 and WANT is\n\ * .FALSE., then the contents of H are unspecified on exit.\n\ * (The output value of H when INFO.GT.0 is given under the\n\ * description of INFO below.)\n\ *\n\ * This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n\ * j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n\ *\n\ * LDH (input) INTEGER\n\ * The leading dimension of the array H. LDH .GE. max(1,N).\n\ *\n\ * W (output) COMPLEX*16 array, dimension (N)\n\ * The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored\n\ * in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are\n\ * stored in the same order as on the diagonal of the Schur\n\ * form returned in H, with W(i) = H(i,i).\n\ *\n\ * Z (input/output) COMPLEX*16 array, dimension (LDZ,IHI)\n\ * If WANTZ is .FALSE., then Z is not referenced.\n\ * If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n\ * replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n\ * orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n\ * (The output value of Z when INFO.GT.0 is given under\n\ * the description of INFO below.)\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. if WANTZ is .TRUE.\n\ * then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 array, dimension LWORK\n\ * On exit, if LWORK = -1, WORK(1) returns an estimate of\n\ * the optimal value for LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK .GE. max(1,N)\n\ * is sufficient, but LWORK typically as large as 6*N may\n\ * be required for optimal performance. A workspace query\n\ * to determine the optimal workspace size is recommended.\n\ *\n\ * If LWORK = -1, then ZLAQR0 does a workspace query.\n\ * In this case, ZLAQR0 checks the input parameters and\n\ * estimates the optimal workspace size for the given\n\ * values of N, ILO and IHI. The estimate is returned\n\ * in WORK(1). No error message related to LWORK is\n\ * issued by XERBLA. Neither H nor Z are accessed.\n\ *\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * .GT. 0: if INFO = i, ZLAQR0 failed to compute all of\n\ * the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n\ * and WI contain those eigenvalues which have been\n\ * successfully computed. (Failures are rare.)\n\ *\n\ * If INFO .GT. 0 and WANT is .FALSE., then on exit,\n\ * the remaining unconverged eigenvalues are the eigen-\n\ * values of the upper Hessenberg matrix rows and\n\ * columns ILO through INFO of the final, output\n\ * value of H.\n\ *\n\ * If INFO .GT. 0 and WANTT is .TRUE., then on exit\n\ *\n\ * (*) (initial value of H)*U = U*(final value of H)\n\ *\n\ * where U is a unitary matrix. The final\n\ * value of H is upper Hessenberg and triangular in\n\ * rows and columns INFO+1 through IHI.\n\ *\n\ * If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n\ *\n\ * (final value of Z(ILO:IHI,ILOZ:IHIZ)\n\ * = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n\ *\n\ * where U is the unitary matrix in (*) (regard-\n\ * less of the value of WANTT.)\n\ *\n\ * If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n\ * accessed.\n\ *\n\n\ * ================================================================\n\ * Based on contributions by\n\ * Karen Braman and Ralph Byers, Department of Mathematics,\n\ * University of Kansas, USA\n\ *\n\ * ================================================================\n\ * References:\n\ * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n\ * Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n\ * Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n\ * 929--947, 2002.\n\ *\n\ * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n\ * Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n\ * of Matrix Analysis, volume 23, pages 948--973, 2002.\n\ *\n\ * ================================================================\n" ruby-lapack-1.7.2/dev/defs/ssyevd0000644000175000017500000001356112502223526016533 0ustar uwabamiuwabami--- :name: ssyevd :md5sum: e10c9634d1a916940bd4f1bd51d00aed :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 2*n+1 : lsame_(&jobz,\"V\") ? 1+6*n+2*n*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSYEVD computes all eigenvalues and, optionally, eigenvectors of a\n\ * real symmetric matrix A. If eigenvectors are desired, it uses a\n\ * divide and conquer algorithm.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\ * Because of large use of BLAS of level 3, SSYEVD needs N**2 more\n\ * workspace than SSYEVX.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA, N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of A contains the\n\ * upper triangular part of the matrix A. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of A contains\n\ * the lower triangular part of the matrix A.\n\ * On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n\ * orthonormal eigenvectors of the matrix A.\n\ * If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n\ * or the upper triangle (if UPLO='U') of A, including the\n\ * diagonal, is destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * WORK (workspace/output) REAL array,\n\ * dimension (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\ * If N <= 1, LWORK must be at least 1.\n\ * If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1.\n\ * If JOBZ = 'V' and N > 1, LWORK must be at least \n\ * 1 + 6*N + 2*N**2.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the optimal sizes of the WORK and IWORK\n\ * arrays, returns these values as the first entries of the WORK\n\ * and IWORK arrays, and no error message related to LWORK or\n\ * LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK.\n\ * If N <= 1, LIWORK must be at least 1.\n\ * If JOBZ = 'N' and N > 1, LIWORK must be at least 1.\n\ * If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK and IWORK arrays, and no error message related to\n\ * LWORK or LIWORK 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 and JOBZ = 'N', then the algorithm failed\n\ * to converge; i off-diagonal elements of an intermediate\n\ * tridiagonal form did not converge to zero;\n\ * if INFO = i and JOBZ = 'V', then the algorithm failed\n\ * to compute an eigenvalue while working on the submatrix\n\ * lying in rows and columns INFO/(N+1) through\n\ * mod(INFO,N+1).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Jeff Rutter, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ * Modified by Francoise Tisseur, University of Tennessee.\n\ *\n\ * Modified description of INFO. Sven, 16 Feb 05.\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgeqp30000644000175000017500000000742512502223526016403 0ustar uwabamiuwabami--- :name: dgeqp3 :md5sum: bbaf1198c839c6a81f6e98424eecce52 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: doublereal :intent: output :dims: - MIN(m,n) - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 3*n+1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGEQP3 computes a QR factorization with column pivoting of a\n\ * matrix A: A*P = Q*R using Level 3 BLAS.\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 upper triangle of the array contains the\n\ * min(M,N)-by-N upper trapezoidal matrix R; the elements below\n\ * the diagonal, together with the array TAU, represent the\n\ * orthogonal matrix Q as a product of min(M,N) elementary\n\ * reflectors.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * JPVT (input/output) INTEGER array, dimension (N)\n\ * On entry, if JPVT(J).ne.0, the J-th column of A is permuted\n\ * to the front of A*P (a leading column); if JPVT(J)=0,\n\ * the J-th column of A is a free column.\n\ * On exit, if JPVT(J)=K, then the J-th column of A*P was the\n\ * the K-th column of A.\n\ *\n\ * TAU (output) DOUBLE PRECISION array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors.\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 >= 3*N+1.\n\ * For optimal performance LWORK >= 2*N+( N+1 )*NB, where NB\n\ * is the 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(1) H(2) . . . H(k), 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/complex scalar, and v is a real/complex vector\n\ * with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in\n\ * A(i+1:m,i), and tau in TAU(i).\n\ *\n\ * Based on contributions by\n\ * G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n\ * X. Sun, Computer Science Dept., Duke University, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slasq20000644000175000017500000000557512502223526016431 0ustar uwabamiuwabami--- :name: slasq2 :md5sum: 5a34b80f0830e1d378a257fe1013e49c :category: :subroutine :arguments: - n: :type: integer :intent: input - z: :type: real :intent: input/output :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLASQ2( N, Z, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLASQ2 computes all the eigenvalues of the symmetric positive \n\ * definite tridiagonal matrix associated with the qd array Z to high\n\ * relative accuracy are computed to high relative accuracy, in the\n\ * absence of denormalization, underflow and overflow.\n\ *\n\ * To see the relation of Z to the tridiagonal matrix, let L be a\n\ * unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and\n\ * let U be an upper bidiagonal matrix with 1's above and diagonal\n\ * Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the\n\ * symmetric tridiagonal to which it is similar.\n\ *\n\ * Note : SLASQ2 defines a logical variable, IEEE, which is true\n\ * on machines which follow ieee-754 floating-point standard in their\n\ * handling of infinities and NaNs, and false otherwise. This variable\n\ * is passed to SLASQ3.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of rows and columns in the matrix. N >= 0.\n\ *\n\ * Z (input/output) REAL array, dimension ( 4*N )\n\ * On entry Z holds the qd array. On exit, entries 1 to N hold\n\ * the eigenvalues in decreasing order, Z( 2*N+1 ) holds the\n\ * trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If\n\ * N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 )\n\ * holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of\n\ * shifts that failed.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if the i-th argument is a scalar and had an illegal\n\ * value, then INFO = -i, if the i-th argument is an\n\ * array and the j-entry had an illegal value, then\n\ * INFO = -(i*100+j)\n\ * > 0: the algorithm failed\n\ * = 1, a split was marked by a positive value in E\n\ * = 2, current block of Z not diagonalized after 30*N\n\ * iterations (in inner while loop)\n\ * = 3, termination criterion of outer while loop not met \n\ * (program created more than N unreduced blocks)\n\ *\n\n\ * Further Details\n\ * ===============\n\ * Local Variables: I0:N0 defines a current unreduced segment of Z.\n\ * The shifts are accumulated in SIGMA. Iteration count is in ITER.\n\ * Ping-pong is controlled by PP (alternates between 0 and 1).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cung2l0000644000175000017500000000443412502223526016407 0ustar uwabamiuwabami--- :name: cung2l :md5sum: 47a3cd3791dbf603dc72bd8465be2b51 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - work: :type: complex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CUNG2L( M, N, K, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CUNG2L generates an m by n complex matrix Q with orthonormal columns,\n\ * which is defined as the last n columns of a product of k elementary\n\ * reflectors of order m\n\ *\n\ * Q = H(k) . . . H(2) H(1)\n\ *\n\ * as returned by CGEQLF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. M >= N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. N >= K >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the (n-k+i)-th column must contain the vector which\n\ * defines the elementary reflector H(i), for i = 1,2,...,k, as\n\ * returned by CGEQLF in the last k columns of its array\n\ * argument A.\n\ * On exit, the m-by-n matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) COMPLEX array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by CGEQLF.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cla_gbrfsx_extended0000644000175000017500000003577612502223525021223 0ustar uwabamiuwabami--- :name: cla_gbrfsx_extended :md5sum: 14debaef2e540705026327e958a0fff4 :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - trans_type: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - lda - n - ldab: :type: integer :intent: input - afb: :type: complex :intent: input :dims: - ldaf - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - colequ: :type: logical :intent: input - c: :type: real :intent: input :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: complex :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: real :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - err_bnds_norm: :type: real :intent: input/output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: input/output :dims: - nrhs - n_err_bnds - res: :type: complex :intent: input :dims: - n - ayb: :type: real :intent: input :dims: - n - dy: :type: complex :intent: input :dims: - n - y_tail: :type: complex :intent: input :dims: - n - rcond: :type: real :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: real :intent: input - dz_ub: :type: real :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: ldafb: ldaf = MAX(1,n) ldab: lda = MAX(1,n) :fortran_help: " SUBROUTINE CLA_GBRFSX_EXTENDED ( PREC_TYPE, TRANS_TYPE, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLA_GBRFSX_EXTENDED improves the computed solution to a system of\n\ * linear equations by performing extra-precise iterative refinement\n\ * and provides error bounds and backward error estimates for the solution.\n\ * This subroutine is called by CGBRFSX to perform iterative refinement.\n\ * In addition to normwise error bound, the code provides maximum\n\ * componentwise error bound if possible. See comments for ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP for details of the error bounds. Note that this\n\ * subroutine is only resonsible for setting the second fields of\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * PREC_TYPE (input) INTEGER\n\ * Specifies the intermediate precision to be used in refinement.\n\ * The value is defined by ILAPREC(P) where P is a CHARACTER and\n\ * P = 'S': Single\n\ * = 'D': Double\n\ * = 'I': Indigenous\n\ * = 'X', 'E': Extra\n\ *\n\ * TRANS_TYPE (input) INTEGER\n\ * Specifies the transposition operation on A.\n\ * The value is defined by ILATRANS(T) where T is a CHARACTER and\n\ * T = 'N': No transpose\n\ * = 'T': Transpose\n\ * = 'C': Conjugate transpose\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right-hand-sides, i.e., the number of columns of the\n\ * matrix B.\n\ *\n\ * AB (input) COMPLEX array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AFB (input) COMPLEX array, dimension (LDAF,N)\n\ * The factors L and U from the factorization\n\ * A = P*L*U as computed by CGBTRF.\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from the factorization A = P*L*U\n\ * as computed by CGBTRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * COLEQU (input) LOGICAL\n\ * If .TRUE. then column equilibration was done to A before calling\n\ * this routine. This is needed to compute the solution and error\n\ * bounds correctly.\n\ *\n\ * C (input) REAL array, dimension (N)\n\ * The column scale factors for A. If COLEQU = .FALSE., C\n\ * is not accessed. If C is input, each element of C should be a power\n\ * of the radix to ensure a reliable solution and error estimates.\n\ * Scaling by powers of the radix does not cause rounding errors unless\n\ * the result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,NRHS)\n\ * The right-hand-side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * Y (input/output) COMPLEX array, dimension (LDY,NRHS)\n\ * On entry, the solution matrix X, as computed by CGBTRS.\n\ * On exit, the improved solution matrix Y.\n\ *\n\ * LDY (input) INTEGER\n\ * The leading dimension of the array Y. LDY >= max(1,N).\n\ *\n\ * BERR_OUT (output) REAL array, dimension (NRHS)\n\ * On exit, BERR_OUT(j) contains the componentwise relative backward\n\ * error for right-hand-side j from the formula\n\ * max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n\ * where abs(Z) is the componentwise absolute value of the matrix\n\ * or vector Z. This is computed by CLA_LIN_BERR.\n\ *\n\ * N_NORMS (input) INTEGER\n\ * Determines which error bounds to return (see ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP).\n\ * If N_NORMS >= 1 return normwise error bounds.\n\ * If N_NORMS >= 2 return componentwise error bounds.\n\ *\n\ * ERR_BNDS_NORM (input/output) REAL array, dimension\n\ * (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (input/output) REAL array, dimension\n\ * (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * RES (input) COMPLEX array, dimension (N)\n\ * Workspace to hold the intermediate residual.\n\ *\n\ * AYB (input) REAL array, dimension (N)\n\ * Workspace.\n\ *\n\ * DY (input) COMPLEX array, dimension (N)\n\ * Workspace to hold the intermediate solution.\n\ *\n\ * Y_TAIL (input) COMPLEX array, dimension (N)\n\ * Workspace to hold the trailing bits of the intermediate solution.\n\ *\n\ * RCOND (input) REAL\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * ITHRESH (input) INTEGER\n\ * The maximum number of residual computations allowed for\n\ * refinement. The default is 10. For 'aggressive' set to 100 to\n\ * permit convergence using approximate factorizations or\n\ * factorizations other than LU. If the factorization uses a\n\ * technique other than Gaussian elimination, the guarantees in\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n\ *\n\ * RTHRESH (input) REAL\n\ * Determines when to stop refinement if the error estimate stops\n\ * decreasing. Refinement will stop when the next solution no longer\n\ * satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n\ * the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n\ * default value is 0.5. For 'aggressive' set to 0.9 to permit\n\ * convergence on extremely ill-conditioned matrices. See LAWN 165\n\ * for more details.\n\ *\n\ * DZ_UB (input) REAL\n\ * Determines when to start considering componentwise convergence.\n\ * Componentwise convergence is only considered after each component\n\ * of the solution Y is stable, which we definte as the relative\n\ * change in each component being less than DZ_UB. The default value\n\ * is 0.25, requiring the first bit to be stable. See LAWN 165 for\n\ * more details.\n\ *\n\ * IGNORE_CWISE (input) LOGICAL\n\ * If .TRUE. then ignore componentwise convergence. Default value\n\ * is .FALSE..\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * < 0: if INFO = -i, the ith argument to CGBTRS had an illegal\n\ * value\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n CHARACTER TRANS\n INTEGER CNT, I, J, M, X_STATE, Z_STATE, Y_PREC_STATE\n REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n COMPLEX ZDUM\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zhprfs0000644000175000017500000001150512502223526016526 0ustar uwabamiuwabami--- :name: zhprfs :md5sum: 363a2f0473501f9de1cea18f56f0d6ba :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - afp: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZHPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHPRFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is Hermitian indefinite\n\ * and packed, and provides error bounds and backward error estimates\n\ * for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * The upper or lower triangle of the Hermitian matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * AFP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * The factored form of the matrix A. AFP contains the block\n\ * diagonal matrix D and the multipliers used to obtain the\n\ * factor U or L from the factorization A = U*D*U**H or\n\ * A = L*D*L**H as computed by ZHPTRF, stored as a packed\n\ * triangular matrix.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by ZHPTRF.\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by ZHPTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sggbal0000644000175000017500000001170112502223526016447 0ustar uwabamiuwabami--- :name: sggbal :md5sum: 90918ecfe5b5c156b054f0f9447942ae :category: :subroutine :arguments: - job: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - lscale: :type: real :intent: output :dims: - n - rscale: :type: real :intent: output :dims: - n - work: :type: real :intent: workspace :dims: - "(lsame_(&job,\"S\")||lsame_(&job,\"B\")) ? MAX(1,6*n) : (lsame_(&job,\"N\")||lsame_(&job,\"P\")) ? 1 : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGGBAL balances a pair of general real matrices (A,B). This\n\ * involves, first, permuting A and B by similarity transformations to\n\ * isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N\n\ * elements on the diagonal; and second, applying a diagonal similarity\n\ * transformation to rows and columns ILO to IHI to make the rows\n\ * and columns as close in norm as possible. Both steps are optional.\n\ *\n\ * Balancing may reduce the 1-norm of the matrices, and improve the\n\ * accuracy of the computed eigenvalues and/or eigenvectors in the\n\ * generalized eigenvalue problem A*x = lambda*B*x.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * Specifies the operations to be performed on A and B:\n\ * = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0\n\ * and RSCALE(I) = 1.0 for i = 1,...,N.\n\ * = 'P': permute only;\n\ * = 'S': scale only;\n\ * = 'B': both permute and scale.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the input matrix A.\n\ * On exit, A is overwritten by the balanced matrix.\n\ * If JOB = 'N', A is not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) REAL array, dimension (LDB,N)\n\ * On entry, the input matrix B.\n\ * On exit, B is overwritten by the balanced matrix.\n\ * If JOB = 'N', B is not referenced.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * ILO (output) INTEGER\n\ * IHI (output) INTEGER\n\ * ILO and IHI are set to integers such that on exit\n\ * A(i,j) = 0 and B(i,j) = 0 if i > j and\n\ * j = 1,...,ILO-1 or i = IHI+1,...,N.\n\ * If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n\ *\n\ * LSCALE (output) REAL array, dimension (N)\n\ * Details of the permutations and scaling factors applied\n\ * to the left side of A and B. If P(j) is the index of the\n\ * row interchanged with row j, and D(j)\n\ * is the scaling factor applied to row j, then\n\ * LSCALE(j) = P(j) for J = 1,...,ILO-1\n\ * = D(j) for J = ILO,...,IHI\n\ * = P(j) for J = IHI+1,...,N.\n\ * The order in which the interchanges are made is N to IHI+1,\n\ * then 1 to ILO-1.\n\ *\n\ * RSCALE (output) REAL array, dimension (N)\n\ * Details of the permutations and scaling factors applied\n\ * to the right side of A and B. If P(j) is the index of the\n\ * column interchanged with column j, and D(j)\n\ * is the scaling factor applied to column j, then\n\ * LSCALE(j) = P(j) for J = 1,...,ILO-1\n\ * = D(j) for J = ILO,...,IHI\n\ * = P(j) for J = IHI+1,...,N.\n\ * The order in which the interchanges are made is N to IHI+1,\n\ * then 1 to ILO-1.\n\ *\n\ * WORK (workspace) REAL array, dimension (lwork)\n\ * lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and\n\ * at least 1 when JOB = 'N' or 'P'.\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\ * See R.C. WARD, Balancing the generalized eigenvalue problem,\n\ * SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ilauplo0000644000175000017500000000164512502223526016663 0ustar uwabamiuwabami--- :name: ilauplo :md5sum: 5876dad692d4c40d99a08273d8c014f9 :category: :function :type: integer :arguments: - uplo: :type: char :intent: input :substitutions: {} :fortran_help: " INTEGER FUNCTION ILAUPLO( UPLO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This subroutine translated from a character string specifying a\n\ * upper- or lower-triangular matrix to the relevant BLAST-specified\n\ * integer constant.\n\ *\n\ * ILAUPLO returns an INTEGER. If ILAUPLO < 0, then the input is not\n\ * a character indicating an upper- or lower-triangular matrix.\n\ * Otherwise ILAUPLO returns the constant value corresponding to UPLO.\n\ *\n\n\ * Arguments\n\ * =========\n\ * UPLO (input) CHARACTER\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zporfsx0000644000175000017500000003707612502223526016740 0ustar uwabamiuwabami--- :name: zporfsx :md5sum: ba57da39ddef83ee555ab5e394b61c61 :category: :subroutine :arguments: - uplo: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " SUBROUTINE ZPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPORFSX improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is symmetric positive\n\ * definite, and provides error bounds and backward error estimates\n\ * for the solution. In addition to normwise error bound, the code\n\ * provides maximum componentwise error bound if possible. See\n\ * comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n\ * error bounds.\n\ *\n\ * The original system of linear equations may have been equilibrated\n\ * before calling this routine, as described by arguments EQUED and S\n\ * below. In this case, the solution and error bounds returned are\n\ * for the original unequilibrated system.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * EQUED (input) CHARACTER*1\n\ * Specifies the form of equilibration that was done to A\n\ * before calling this routine. This is needed to compute\n\ * the solution and error bounds correctly.\n\ * = 'N': No equilibration\n\ * = 'Y': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(S) * A * diag(S).\n\ * The right hand side B has been changed accordingly.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular part\n\ * of the matrix A, and the strictly lower triangular part of A\n\ * is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of A contains the lower triangular part of\n\ * the matrix A, and the strictly upper triangular part of A is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX*16 array, dimension (LDAF,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T, as computed by DPOTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * S (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'Y', A is multiplied on\n\ * the left and right by diag(S). S is an input argument if FACT =\n\ * 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n\ * = 'Y', each element of S must be positive. If S is output, each\n\ * element of S is a power of the radix. If S is input, each element\n\ * of S should be a power of the radix to ensure a reliable solution\n\ * and error estimates. Scaling by powers of the radix does not cause\n\ * rounding errors unless the result underflows or overflows.\n\ * Rounding errors during scaling lead to refining with a matrix that\n\ * is not equivalent to the input matrix, producing error estimates\n\ * that may not be reliable.\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by DGETRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * Componentwise relative backward error. This is the\n\ * componentwise relative backward error of each solution vector X(j)\n\ * (i.e., the smallest relative change in any element of A or B that\n\ * makes X(j) an exact solution).\n\ *\n\ * N_ERR_BNDS (input) INTEGER\n\ * Number of error bounds to return for each right hand side\n\ * and each type (normwise or componentwise). See ERR_BNDS_NORM and\n\ * ERR_BNDS_COMP below.\n\ *\n\ * ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * dlamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * dlamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * dlamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * dlamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * dlamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * dlamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * NPARAMS (input) INTEGER\n\ * Specifies the number of parameters set in PARAMS. If .LE. 0, the\n\ * PARAMS array is never referenced and default values are used.\n\ *\n\ * PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS\n\ * Specifies algorithm parameters. If an entry is .LT. 0.0, then\n\ * that entry will be filled with default value used for that\n\ * parameter. Only positions up to NPARAMS are accessed; defaults\n\ * are used for higher-numbered parameters.\n\ *\n\ * PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n\ * refinement or not.\n\ * Default: 1.0D+0\n\ * = 0.0 : No refinement is performed, and no error bounds are\n\ * computed.\n\ * = 1.0 : Use the double-precision refinement algorithm,\n\ * possibly with doubled-single computations if the\n\ * compilation environment does not support DOUBLE\n\ * PRECISION.\n\ * (other values are reserved for future use)\n\ *\n\ * PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n\ * computations allowed for refinement.\n\ * Default: 10\n\ * Aggressive: Set to 100 to permit convergence using approximate\n\ * factorizations or factorizations other than LU. If\n\ * the factorization uses a technique other than\n\ * Gaussian elimination, the guarantees in\n\ * err_bnds_norm and err_bnds_comp may no longer be\n\ * trustworthy.\n\ *\n\ * PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n\ * will attempt to find a solution with small componentwise\n\ * relative error in the double-precision algorithm. Positive\n\ * is true, 0.0 is false.\n\ * Default: 1.0 (attempt componentwise convergence)\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit. The solution to every right-hand side is\n\ * guaranteed.\n\ * < 0: If INFO = -i, the i-th argument had an illegal value\n\ * > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/spptri0000644000175000017500000000362412502223526016536 0ustar uwabamiuwabami--- :name: spptri :md5sum: 43cff036bbefeae28ea091a5a1aa282e :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPPTRI( UPLO, N, AP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPPTRI computes the inverse of a real symmetric positive definite\n\ * matrix A using the Cholesky factorization A = U**T*U or A = L*L**T\n\ * computed by SPPTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangular factor is stored in AP;\n\ * = 'L': Lower triangular factor is stored in AP.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) REAL array, dimension (N*(N+1)/2)\n\ * On entry, the triangular factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T, packed columnwise as\n\ * a linear array. The j-th column of U or L is stored in the\n\ * array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n\ *\n\ * On exit, the upper or lower triangle of the (symmetric)\n\ * inverse of A, overwriting the input factor U or L.\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,i) element of the factor U or L is\n\ * zero, and the inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgetrf0000644000175000017500000000452512502223526016510 0ustar uwabamiuwabami--- :name: sgetrf :md5sum: fd03c253a8862b16c1b50e2ad7d0db20 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGETRF( M, N, A, LDA, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGETRF computes an LU factorization of a general M-by-N matrix A\n\ * using partial pivoting with row interchanges.\n\ *\n\ * The factorization has the form\n\ * A = P * L * U\n\ * where P is a permutation matrix, L is lower triangular with unit\n\ * diagonal elements (lower trapezoidal if m > n), and U is upper\n\ * triangular (upper trapezoidal if m < n).\n\ *\n\ * This is the right-looking Level 3 BLAS version of the algorithm.\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) REAL array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix to be factored.\n\ * On exit, the factors L and U from the factorization\n\ * A = P*L*U; the unit diagonal elements of L are not stored.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * IPIV (output) INTEGER array, dimension (min(M,N))\n\ * The pivot indices; for 1 <= i <= min(M,N), row i of the\n\ * matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, and division by zero will occur if it is used\n\ * to solve a system of equations.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clacn20000644000175000017500000000555612502223525016364 0ustar uwabamiuwabami--- :name: clacn2 :md5sum: e82e391618650776158bd652bd776c82 :category: :subroutine :arguments: - n: :type: integer :intent: input - v: :type: complex :intent: workspace :dims: - n - x: :type: complex :intent: input/output :dims: - n - est: :type: real :intent: input/output - kase: :type: integer :intent: input/output - isave: :type: integer :intent: input/output :dims: - "3" :substitutions: {} :fortran_help: " SUBROUTINE CLACN2( N, V, X, EST, KASE, ISAVE )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLACN2 estimates the 1-norm of a square, complex matrix A.\n\ * Reverse communication is used for evaluating matrix-vector products.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 1.\n\ *\n\ * V (workspace) COMPLEX array, dimension (N)\n\ * On the final return, V = A*W, where EST = norm(V)/norm(W)\n\ * (W is not returned).\n\ *\n\ * X (input/output) COMPLEX array, dimension (N)\n\ * On an intermediate return, X should be overwritten by\n\ * A * X, if KASE=1,\n\ * A' * X, if KASE=2,\n\ * where A' is the conjugate transpose of A, and CLACN2 must be\n\ * re-called with all the other parameters unchanged.\n\ *\n\ * EST (input/output) REAL\n\ * On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be\n\ * unchanged from the previous call to CLACN2.\n\ * On exit, EST is an estimate (a lower bound) for norm(A). \n\ *\n\ * KASE (input/output) INTEGER\n\ * On the initial call to CLACN2, KASE should be 0.\n\ * On an intermediate return, KASE will be 1 or 2, indicating\n\ * whether X should be overwritten by A * X or A' * X.\n\ * On the final return from CLACN2, KASE will again be 0.\n\ *\n\ * ISAVE (input/output) INTEGER array, dimension (3)\n\ * ISAVE is used to save variables between calls to SLACN2\n\ *\n\n\ * Further Details\n\ * ======= =======\n\ *\n\ * Contributed by Nick Higham, University of Manchester.\n\ * Originally named CONEST, dated March 16, 1988.\n\ *\n\ * Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n\ * a real or complex matrix, with applications to condition estimation\",\n\ * ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n\ *\n\ * Last modified: April, 1999\n\ *\n\ * This is a thread safe version of CLACON, which uses the array ISAVE\n\ * in place of a SAVE statement, as follows:\n\ *\n\ * CLACON CLACN2\n\ * JUMP ISAVE(1)\n\ * J ISAVE(2)\n\ * ITER ISAVE(3)\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhptrd0000644000175000017500000000774512502223526016540 0ustar uwabamiuwabami--- :name: zhptrd :md5sum: 9d8dcc90a6a09c895332ed4d3bafa8f9 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - ldap - d: :type: doublereal :intent: output :dims: - n - e: :type: doublereal :intent: output :dims: - n-1 - tau: :type: doublecomplex :intent: output :dims: - n-1 - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE ZHPTRD( UPLO, N, AP, D, E, TAU, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHPTRD reduces a complex Hermitian matrix A stored in packed form to\n\ * real symmetric tridiagonal form T by a unitary similarity\n\ * transformation: Q**H * A * Q = T.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ * On exit, if UPLO = 'U', the diagonal and first superdiagonal\n\ * of A are overwritten by the corresponding elements of the\n\ * tridiagonal matrix T, and the elements above the first\n\ * superdiagonal, with the array TAU, represent the unitary\n\ * matrix Q as a product of elementary reflectors; if UPLO\n\ * = 'L', the diagonal and first subdiagonal of A are over-\n\ * written by the corresponding elements of the tridiagonal\n\ * matrix T, and the elements below the first subdiagonal, with\n\ * the array TAU, represent the unitary matrix Q as a product\n\ * of elementary reflectors. See Further Details.\n\ *\n\ * D (output) DOUBLE PRECISION array, dimension (N)\n\ * The diagonal elements of the tridiagonal matrix T:\n\ * D(i) = A(i,i).\n\ *\n\ * E (output) DOUBLE PRECISION array, dimension (N-1)\n\ * The off-diagonal elements of the tridiagonal matrix T:\n\ * E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n\ *\n\ * TAU (output) COMPLEX*16 array, dimension (N-1)\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\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\ * If UPLO = 'U', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(n-1) . . . H(2) H(1).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar, and v is a complex vector with\n\ * v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,\n\ * overwriting A(1:i-1,i+1), and tau is stored in TAU(i).\n\ *\n\ * If UPLO = 'L', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(n-1).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar, and v is a complex vector with\n\ * v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,\n\ * overwriting A(i+2:n,i), and tau is stored in TAU(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlatrs0000644000175000017500000001702212502223526016503 0ustar uwabamiuwabami--- :name: dlatrs :md5sum: 78957566bfa0909d05e8e96786331be9 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - normin: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - n - scale: :type: doublereal :intent: output - cnorm: :type: doublereal :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, CNORM, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLATRS solves one of the triangular systems\n\ *\n\ * A *x = s*b or A'*x = s*b\n\ *\n\ * with scaling to prevent overflow. Here A is an upper or lower\n\ * triangular matrix, A' denotes the transpose of A, x and b are\n\ * n-element vectors, and s is a scaling factor, usually less than\n\ * or equal to 1, chosen so that the components of x will be less than\n\ * the overflow threshold. If the unscaled problem will not cause\n\ * overflow, the Level 2 BLAS routine DTRSV is called. If the matrix A\n\ * is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n\ * non-trivial solution to A*x = 0 is returned.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the matrix A is upper or lower triangular.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the operation applied to A.\n\ * = 'N': Solve A * x = s*b (No transpose)\n\ * = 'T': Solve A'* x = s*b (Transpose)\n\ * = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * Specifies whether or not the matrix A is unit triangular.\n\ * = 'N': Non-unit triangular\n\ * = 'U': Unit triangular\n\ *\n\ * NORMIN (input) CHARACTER*1\n\ * Specifies whether CNORM has been set or not.\n\ * = 'Y': CNORM contains the column norms on entry\n\ * = 'N': CNORM is not set on entry. On exit, the norms will\n\ * be computed and stored in CNORM.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The triangular matrix A. If UPLO = 'U', the leading n by n\n\ * upper triangular part of the array A contains the upper\n\ * triangular matrix, and the strictly lower triangular part of\n\ * A is not referenced. If UPLO = 'L', the leading n by n lower\n\ * triangular part of the array A contains the lower triangular\n\ * matrix, and the strictly upper triangular part of A is not\n\ * referenced. If DIAG = 'U', the diagonal elements of A are\n\ * also not referenced and are assumed to be 1.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max (1,N).\n\ *\n\ * X (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the right hand side b of the triangular system.\n\ * On exit, X is overwritten by the solution vector x.\n\ *\n\ * SCALE (output) DOUBLE PRECISION\n\ * The scaling factor s for the triangular system\n\ * A * x = s*b or A'* x = s*b.\n\ * If SCALE = 0, the matrix A is singular or badly scaled, and\n\ * the vector x is an exact or approximate solution to A*x = 0.\n\ *\n\ * CNORM (input or output) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n\ * contains the norm of the off-diagonal part of the j-th column\n\ * of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n\ * to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n\ * must be greater than or equal to the 1-norm.\n\ *\n\ * If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n\ * returns the 1-norm of the offdiagonal part of the j-th column\n\ * of A.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ *\n\n\ * Further Details\n\ * ======= =======\n\ *\n\ * A rough bound on x is computed; if that is less than overflow, DTRSV\n\ * is called, otherwise, specific code is used which checks for possible\n\ * overflow or divide-by-zero at every operation.\n\ *\n\ * A columnwise scheme is used for solving A*x = b. The basic algorithm\n\ * if A is lower triangular is\n\ *\n\ * x[1:n] := b[1:n]\n\ * for j = 1, ..., n\n\ * x(j) := x(j) / A(j,j)\n\ * x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n\ * end\n\ *\n\ * Define bounds on the components of x after j iterations of the loop:\n\ * M(j) = bound on x[1:j]\n\ * G(j) = bound on x[j+1:n]\n\ * Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n\ *\n\ * Then for iteration j+1 we have\n\ * M(j+1) <= G(j) / | A(j+1,j+1) |\n\ * G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n\ * <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n\ *\n\ * where CNORM(j+1) is greater than or equal to the infinity-norm of\n\ * column j+1 of A, not counting the diagonal. Hence\n\ *\n\ * G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n\ * 1<=i<=j\n\ * and\n\ *\n\ * |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n\ * 1<=i< j\n\ *\n\ * Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTRSV if the\n\ * reciprocal of the largest M(j), j=1,..,n, is larger than\n\ * max(underflow, 1/overflow).\n\ *\n\ * The bound on x(j) is also used to determine when a step in the\n\ * columnwise method can be performed without fear of overflow. If\n\ * the computed bound is greater than a large constant, x is scaled to\n\ * prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n\ * 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n\ *\n\ * Similarly, a row-wise scheme is used to solve A'*x = b. The basic\n\ * algorithm for A upper triangular is\n\ *\n\ * for j = 1, ..., n\n\ * x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n\ * end\n\ *\n\ * We simultaneously compute two bounds\n\ * G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n\ * M(j) = bound on x(i), 1<=i<=j\n\ *\n\ * The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n\ * add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n\ * Then the bound on x(j) is\n\ *\n\ * M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n\ *\n\ * <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n\ * 1<=i<=j\n\ *\n\ * and we can safely call DTRSV if 1/M(n) and 1/G(n) are both greater\n\ * than max(underflow, 1/overflow).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dbbcsd0000644000175000017500000002247412502223526016442 0ustar uwabamiuwabami--- :name: dbbcsd :md5sum: 26a801cd779a10106a829b0e401c7a94 :category: :subroutine :arguments: - jobu1: :type: char :intent: input - jobu2: :type: char :intent: input - jobv1t: :type: char :intent: input - jobv2t: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - q: :type: integer :intent: input - theta: :type: doublereal :intent: input/output :dims: - q - phi: :type: doublereal :intent: input :dims: - q-1 - u1: :type: doublereal :intent: input/output :dims: - ldu1 - p - ldu1: :type: integer :intent: input - u2: :type: doublereal :intent: input/output :dims: - ldu2 - m-p - ldu2: :type: integer :intent: input - v1t: :type: doublereal :intent: input/output :dims: - ldv1t - q - ldv1t: :type: integer :intent: input - v2t: :type: doublereal :intent: input/output :dims: - ldv2t - m-q - ldv2t: :type: integer :intent: input - b11d: :type: doublereal :intent: output :dims: - q - b11e: :type: doublereal :intent: output :dims: - q-1 - b12d: :type: doublereal :intent: output :dims: - q - b12e: :type: doublereal :intent: output :dims: - q-1 - b21d: :type: doublereal :intent: output :dims: - q - b21e: :type: doublereal :intent: output :dims: - q-1 - b22d: :type: doublereal :intent: output :dims: - q - b22e: :type: doublereal :intent: output :dims: - q-1 - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 8*q - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, THETA, PHI, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, B22D, B22E, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DBBCSD computes the CS decomposition of an orthogonal matrix in\n\ * bidiagonal-block form,\n\ *\n\ *\n\ * [ B11 | B12 0 0 ]\n\ * [ 0 | 0 -I 0 ]\n\ * X = [----------------]\n\ * [ B21 | B22 0 0 ]\n\ * [ 0 | 0 0 I ]\n\ *\n\ * [ C | -S 0 0 ]\n\ * [ U1 | ] [ 0 | 0 -I 0 ] [ V1 | ]**T\n\ * = [---------] [---------------] [---------] .\n\ * [ | U2 ] [ S | C 0 0 ] [ | V2 ]\n\ * [ 0 | 0 0 I ]\n\ *\n\ * X is M-by-M, its top-left block is P-by-Q, and Q must be no larger\n\ * than P, M-P, or M-Q. (If Q is not the smallest index, then X must be\n\ * transposed and/or permuted. This can be done in constant time using\n\ * the TRANS and SIGNS options. See DORCSD for details.)\n\ *\n\ * The bidiagonal matrices B11, B12, B21, and B22 are represented\n\ * implicitly by angles THETA(1:Q) and PHI(1:Q-1).\n\ *\n\ * The orthogonal matrices U1, U2, V1T, and V2T are input/output.\n\ * The input matrices are pre- or post-multiplied by the appropriate\n\ * singular vector matrices.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBU1 (input) CHARACTER\n\ * = 'Y': U1 is updated;\n\ * otherwise: U1 is not updated.\n\ *\n\ * JOBU2 (input) CHARACTER\n\ * = 'Y': U2 is updated;\n\ * otherwise: U2 is not updated.\n\ *\n\ * JOBV1T (input) CHARACTER\n\ * = 'Y': V1T is updated;\n\ * otherwise: V1T is not updated.\n\ *\n\ * JOBV2T (input) CHARACTER\n\ * = 'Y': V2T is updated;\n\ * otherwise: V2T is not updated.\n\ *\n\ * TRANS (input) CHARACTER\n\ * = 'T': X, U1, U2, V1T, and V2T are stored in row-major\n\ * order;\n\ * otherwise: X, U1, U2, V1T, and V2T are stored in column-\n\ * major order.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows and columns in X, the orthogonal matrix in\n\ * bidiagonal-block form.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows in the top-left block of X. 0 <= P <= M.\n\ *\n\ * Q (input) INTEGER\n\ * The number of columns in the top-left block of X.\n\ * 0 <= Q <= MIN(P,M-P,M-Q).\n\ *\n\ * THETA (input/output) DOUBLE PRECISION array, dimension (Q)\n\ * On entry, the angles THETA(1),...,THETA(Q) that, along with\n\ * PHI(1), ...,PHI(Q-1), define the matrix in bidiagonal-block\n\ * form. On exit, the angles whose cosines and sines define the\n\ * diagonal blocks in the CS decomposition.\n\ *\n\ * PHI (input/workspace) DOUBLE PRECISION array, dimension (Q-1)\n\ * The angles PHI(1),...,PHI(Q-1) that, along with THETA(1),...,\n\ * THETA(Q), define the matrix in bidiagonal-block form.\n\ *\n\ * U1 (input/output) DOUBLE PRECISION array, dimension (LDU1,P)\n\ * On entry, an LDU1-by-P matrix. On exit, U1 is postmultiplied\n\ * by the left singular vector matrix common to [ B11 ; 0 ] and\n\ * [ B12 0 0 ; 0 -I 0 0 ].\n\ *\n\ * LDU1 (input) INTEGER\n\ * The leading dimension of the array U1.\n\ *\n\ * U2 (input/output) DOUBLE PRECISION array, dimension (LDU2,M-P)\n\ * On entry, an LDU2-by-(M-P) matrix. On exit, U2 is\n\ * postmultiplied by the left singular vector matrix common to\n\ * [ B21 ; 0 ] and [ B22 0 0 ; 0 0 I ].\n\ *\n\ * LDU2 (input) INTEGER\n\ * The leading dimension of the array U2.\n\ *\n\ * V1T (input/output) DOUBLE PRECISION array, dimension (LDV1T,Q)\n\ * On entry, a LDV1T-by-Q matrix. On exit, V1T is premultiplied\n\ * by the transpose of the right singular vector\n\ * matrix common to [ B11 ; 0 ] and [ B21 ; 0 ].\n\ *\n\ * LDV1T (input) INTEGER\n\ * The leading dimension of the array V1T.\n\ *\n\ * V2T (input/output) DOUBLE PRECISION array, dimenison (LDV2T,M-Q)\n\ * On entry, a LDV2T-by-(M-Q) matrix. On exit, V2T is\n\ * premultiplied by the transpose of the right\n\ * singular vector matrix common to [ B12 0 0 ; 0 -I 0 ] and\n\ * [ B22 0 0 ; 0 0 I ].\n\ *\n\ * LDV2T (input) INTEGER\n\ * The leading dimension of the array V2T.\n\ *\n\ * B11D (output) DOUBLE PRECISION array, dimension (Q)\n\ * When DBBCSD converges, B11D contains the cosines of THETA(1),\n\ * ..., THETA(Q). If DBBCSD fails to converge, then B11D\n\ * contains the diagonal of the partially reduced top-left\n\ * block.\n\ *\n\ * B11E (output) DOUBLE PRECISION array, dimension (Q-1)\n\ * When DBBCSD converges, B11E contains zeros. If DBBCSD fails\n\ * to converge, then B11E contains the superdiagonal of the\n\ * partially reduced top-left block.\n\ *\n\ * B12D (output) DOUBLE PRECISION array, dimension (Q)\n\ * When DBBCSD converges, B12D contains the negative sines of\n\ * THETA(1), ..., THETA(Q). If DBBCSD fails to converge, then\n\ * B12D contains the diagonal of the partially reduced top-right\n\ * block.\n\ *\n\ * B12E (output) DOUBLE PRECISION array, dimension (Q-1)\n\ * When DBBCSD converges, B12E contains zeros. If DBBCSD fails\n\ * to converge, then B12E contains the subdiagonal of the\n\ * partially reduced top-right block.\n\ *\n\ * WORK (workspace) 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,8*Q).\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal size of the WORK array,\n\ * returns this value as the first entry of the work array, and\n\ * no error 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 DBBCSD did not converge, INFO specifies the number\n\ * of nonzero entries in PHI, and B11D, B11E, etc.,\n\ * contain the partially reduced matrix.\n\ *\n\ * Reference\n\ * =========\n\ *\n\ * [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.\n\ * Algorithms, 50(1):33-65, 2009.\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * TOLMUL DOUBLE PRECISION, default = MAX(10,MIN(100,EPS**(-1/8)))\n\ * TOLMUL controls the convergence criterion of the QR loop.\n\ * Angles THETA(i), PHI(i) are rounded to 0 or PI/2 when they\n\ * are within TOLMUL*EPS of either bound.\n\ *\n\n\ * ===================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ztrttp0000644000175000017500000000440112502223526016556 0ustar uwabamiuwabami--- :name: ztrttp :md5sum: a44dba928c85704365bac0d60caba0c2 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ap: :type: doublecomplex :intent: output :dims: - ( n*(n+1)/2 ) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZTRTTP( UPLO, N, A, LDA, AP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTRTTP copies a triangular matrix A from full format (TR) to standard\n\ * packed format (TP).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices AP and A. N >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the triangular matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AP (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n\ * On exit, the upper or lower triangular matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsyswapr0000644000175000017500000000435412502223526017072 0ustar uwabamiuwabami--- :name: dsyswapr :md5sum: b4071132998e7f7d907b231f31a0e28b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - i1: :type: integer :intent: input - i2: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE DSYSWAPR( UPLO, N, A, I1, I2)\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSYSWAPR applies an elementary permutation on the rows and the columns of\n\ * a symmetric matrix.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the NB diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L as computed by DSYTRF.\n\ *\n\ * On exit, if INFO = 0, the (symmetric) inverse of the original\n\ * matrix. If UPLO = 'U', the upper triangular part of the\n\ * inverse is formed and the part of A below the diagonal is not\n\ * referenced; if UPLO = 'L' the lower triangular part of the\n\ * inverse is formed and the part of A above the diagonal is\n\ * not referenced.\n\ *\n\ * I1 (input) INTEGER\n\ * Index of the first row to swap\n\ *\n\ * I2 (input) INTEGER\n\ * Index of the second row to swap\n\ *\n\n\ * =====================================================================\n\ *\n\ * ..\n\ * .. Local Scalars ..\n LOGICAL UPPER\n INTEGER I\n DOUBLE PRECISION TMP\n\ *\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DSWAP\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sla_porcond0000644000175000017500000000675412502223526017527 0ustar uwabamiuwabami--- :name: sla_porcond :md5sum: f0d498acfd1d554092c078a19690e2e6 :category: :function :type: real :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - cmode: :type: integer :intent: input - c: :type: real :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: real :intent: input :dims: - 3*n - iwork: :type: integer :intent: input :dims: - n :substitutions: {} :fortran_help: " REAL FUNCTION SLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, CMODE, C, INFO, WORK, IWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLA_PORCOND Estimates the Skeel condition number of op(A) * op2(C)\n\ * where op2 is determined by CMODE as follows\n\ * CMODE = 1 op2(C) = C\n\ * CMODE = 0 op2(C) = I\n\ * CMODE = -1 op2(C) = inv(C)\n\ * The Skeel condition number cond(A) = norminf( |inv(A)||A| )\n\ * is computed by computing scaling factors R such that\n\ * diag(R)*A*op2(C) is row equilibrated and computing the standard\n\ * infinity-norm condition number.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) REAL array, dimension (LDAF,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T, as computed by SPOTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * CMODE (input) INTEGER\n\ * Determines op2(C) in the formula op(A) * op2(C) as follows:\n\ * CMODE = 1 op2(C) = C\n\ * CMODE = 0 op2(C) = I\n\ * CMODE = -1 op2(C) = inv(C)\n\ *\n\ * C (input) REAL array, dimension (N)\n\ * The vector C in the formula op(A) * op2(C).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * i > 0: The ith argument is invalid.\n\ *\n\ * WORK (input) REAL array, dimension (3*N).\n\ * Workspace.\n\ *\n\ * IWORK (input) INTEGER array, dimension (N).\n\ * Workspace.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER KASE, I, J\n REAL AINVNM, TMP\n LOGICAL UP\n\ * ..\n\ * .. Array Arguments ..\n INTEGER ISAVE( 3 )\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER ISAMAX\n EXTERNAL LSAME, ISAMAX\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SLACN2, SPOTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dla_porpvgrw0000644000175000017500000000463412502223526017725 0ustar uwabamiuwabami--- :name: dla_porpvgrw :md5sum: 808a3e0cfa3cafe090522d7d169ee362 :category: :function :type: doublereal :arguments: - uplo: :type: char :intent: input - ncols: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - work: :type: doublereal :intent: input :dims: - 2*n :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION DLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, LDAF, WORK )\n\n\ * Purpose\n\ * =======\n\ * \n\ * DLA_PORPVGRW computes the reciprocal pivot growth factor\n\ * norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n\ * much less than 1, the stability of the LU factorization of the\n\ * (equilibrated) matrix A could be poor. This also means that the\n\ * solution X, estimated condition numbers, and error bounds could be\n\ * unreliable.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * NCOLS (input) INTEGER\n\ * The number of columns of the matrix A. NCOLS >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T, as computed by DPOTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * WORK (input) DOUBLE PRECISION array, dimension (2*N)\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n DOUBLE PRECISION AMAX, UMAX, RPVGRW\n LOGICAL UPPER\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN\n\ * ..\n\ * .. External Functions ..\n EXTERNAL LSAME, DLASET\n LOGICAL LSAME\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zgerqf0000644000175000017500000000752312502223526016515 0ustar uwabamiuwabami--- :name: zgerqf :md5sum: 7f71fdab4185fb2a41d4eb15cb97fb06 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - MIN(m,n) - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGERQF computes an RQ factorization of a complex M-by-N matrix A:\n\ * A = R * 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) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit,\n\ * if m <= n, the upper triangle of the subarray\n\ * A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R;\n\ * if m >= n, the elements on and above the (m-n)-th subdiagonal\n\ * contain the M-by-N upper trapezoidal matrix R;\n\ * the remaining elements, with the array TAU, represent the\n\ * unitary matrix Q as a product of min(m,n) elementary\n\ * 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) COMPLEX*16 array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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\n\ * the 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(1)' H(2)' . . . H(k)', 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 complex scalar, and v is a complex vector with\n\ * v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on\n\ * exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i).\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n $ MU, NB, NBMIN, NU, NX\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZGERQ2, ZLARFB, ZLARFT\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sgsvj00000644000175000017500000001664412502223526016437 0ustar uwabamiuwabami--- :name: sgsvj0 :md5sum: 3d2a3ab6cc4e65db034ed891716f6493 :category: :subroutine :arguments: - jobv: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - sva: :type: real :intent: input/output :dims: - n - mv: :type: integer :intent: input - v: :type: real :intent: input/output :dims: - ldv - n - ldv: :type: integer :intent: input - eps: :type: integer :intent: input - sfmin: :type: integer :intent: input - tol: :type: real :intent: input - nsweep: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - lwork - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: lwork: m :fortran_help: " SUBROUTINE SGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGSVJ0 is called from SGESVJ as a pre-processor and that is its main\n\ * purpose. It applies Jacobi rotations in the same way as SGESVJ does, but\n\ * it does not check convergence (stopping criterion). Few tuning\n\ * parameters (marked by [TP]) are available for the implementer.\n\ *\n\ * Further Details\n\ * ~~~~~~~~~~~~~~~\n\ * SGSVJ0 is used just to enable SGESVJ to call a simplified version of\n\ * itself to work on a submatrix of the original matrix.\n\ *\n\ * Contributors\n\ * ~~~~~~~~~~~~\n\ * Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)\n\ *\n\ * Bugs, Examples and Comments\n\ * ~~~~~~~~~~~~~~~~~~~~~~~~~~~\n\ * Please report all bugs and send interesting test examples and comments to\n\ * drmac@math.hr. Thank you.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBV (input) CHARACTER*1\n\ * Specifies whether the output from this procedure is used\n\ * to compute the matrix V:\n\ * = 'V': the product of the Jacobi rotations is accumulated\n\ * by postmulyiplying the N-by-N array V.\n\ * (See the description of V.)\n\ * = 'A': the product of the Jacobi rotations is accumulated\n\ * by postmulyiplying the MV-by-N array V.\n\ * (See the descriptions of MV and V.)\n\ * = 'N': the Jacobi rotations are not accumulated.\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.\n\ * M >= N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, M-by-N matrix A, such that A*diag(D) represents\n\ * the input matrix.\n\ * On exit,\n\ * A_onexit * D_onexit represents the input matrix A*diag(D)\n\ * post-multiplied by a sequence of Jacobi rotations, where the\n\ * rotation threshold and the total number of sweeps are given in\n\ * TOL and NSWEEP, respectively.\n\ * (See the descriptions of D, TOL and NSWEEP.)\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * D (input/workspace/output) REAL array, dimension (N)\n\ * The array D accumulates the scaling factors from the fast scaled\n\ * Jacobi rotations.\n\ * On entry, A*diag(D) represents the input matrix.\n\ * On exit, A_onexit*diag(D_onexit) represents the input matrix\n\ * post-multiplied by a sequence of Jacobi rotations, where the\n\ * rotation threshold and the total number of sweeps are given in\n\ * TOL and NSWEEP, respectively.\n\ * (See the descriptions of A, TOL and NSWEEP.)\n\ *\n\ * SVA (input/workspace/output) REAL array, dimension (N)\n\ * On entry, SVA contains the Euclidean norms of the columns of\n\ * the matrix A*diag(D).\n\ * On exit, SVA contains the Euclidean norms of the columns of\n\ * the matrix onexit*diag(D_onexit).\n\ *\n\ * MV (input) INTEGER\n\ * If JOBV .EQ. 'A', then MV rows of V are post-multipled by a\n\ * sequence of Jacobi rotations.\n\ * If JOBV = 'N', then MV is not referenced.\n\ *\n\ * V (input/output) REAL array, dimension (LDV,N)\n\ * If JOBV .EQ. 'V' then N rows of V are post-multipled by a\n\ * sequence of Jacobi rotations.\n\ * If JOBV .EQ. 'A' then MV rows of V are post-multipled by a\n\ * sequence of Jacobi rotations.\n\ * If JOBV = 'N', then V is not referenced.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V, LDV >= 1.\n\ * If JOBV = 'V', LDV .GE. N.\n\ * If JOBV = 'A', LDV .GE. MV.\n\ *\n\ * EPS (input) INTEGER\n\ * EPS = SLAMCH('Epsilon')\n\ *\n\ * SFMIN (input) INTEGER\n\ * SFMIN = SLAMCH('Safe Minimum')\n\ *\n\ * TOL (input) REAL\n\ * TOL is the threshold for Jacobi rotations. For a pair\n\ * A(:,p), A(:,q) of pivot columns, the Jacobi rotation is\n\ * applied only if ABS(COS(angle(A(:,p),A(:,q)))) .GT. TOL.\n\ *\n\ * NSWEEP (input) INTEGER\n\ * NSWEEP is the number of sweeps of Jacobi rotations to be\n\ * performed.\n\ *\n\ * WORK (workspace) REAL array, dimension LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * LWORK is the dimension of WORK. LWORK .GE. M.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0 : successful exit.\n\ * < 0 : if INFO = -i, then the i-th argument had an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Parameters ..\n REAL ZERO, HALF, ONE, TWO\n PARAMETER ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0,\n + TWO = 2.0E0 )\n\ * ..\n\ * .. Local Scalars ..\n REAL AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,\n + BIGTHETA, CS, MXAAPQ, MXSINJ, ROOTBIG, ROOTEPS,\n + ROOTSFMIN, ROOTTOL, SMALL, SN, T, TEMP1, THETA,\n + THSIGN\n INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1,\n + ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, NBL,\n + NOTROT, p, PSKIPPED, q, ROWSKIP, SWBAND\n LOGICAL APPLV, ROTOK, RSVEC\n\ * ..\n\ * .. Local Arrays ..\n REAL FASTR( 5 )\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, AMAX1, AMIN1, FLOAT, MIN0, SIGN, SQRT\n\ * ..\n\ * .. External Functions ..\n REAL SDOT, SNRM2\n INTEGER ISAMAX\n LOGICAL LSAME\n EXTERNAL ISAMAX, LSAME, SDOT, SNRM2\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SAXPY, SCOPY, SLASCL, SLASSQ, SROTM, SSWAP\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dgerq20000644000175000017500000000517312502223526016402 0ustar uwabamiuwabami--- :name: dgerq2 :md5sum: ec6dcb765aef641986c3c35e04eff023 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - MIN(m,n) - work: :type: doublereal :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE DGERQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGERQ2 computes an RQ factorization of a real m by n matrix A:\n\ * A = R * 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, if m <= n, the upper triangle of the subarray\n\ * A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;\n\ * if m >= n, the elements on and above the (m-n)-th subdiagonal\n\ * contain the m by n upper trapezoidal matrix R; the remaining\n\ * elements, with the array TAU, represent the orthogonal matrix\n\ * Q as a product of elementary reflectors (see Further\n\ * 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(1) H(2) . . . H(k), 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(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n\ * A(m-k+i,1:n-k+i-1), and tau in TAU(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlagts0000644000175000017500000001145512502223526016474 0ustar uwabamiuwabami--- :name: dlagts :md5sum: 1e4c232f7c97f49ee5dc23580a208740 :category: :subroutine :arguments: - job: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - n - b: :type: doublereal :intent: input :dims: - n-1 - c: :type: doublereal :intent: input :dims: - n-1 - d: :type: doublereal :intent: input :dims: - n-2 - in: :type: integer :intent: input :dims: - n - y: :type: doublereal :intent: input/output :dims: - n - tol: :type: doublereal :intent: input/output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAGTS may be used to solve one of the systems of equations\n\ *\n\ * (T - lambda*I)*x = y or (T - lambda*I)'*x = y,\n\ *\n\ * where T is an n by n tridiagonal matrix, for x, following the\n\ * factorization of (T - lambda*I) as\n\ *\n\ * (T - lambda*I) = P*L*U ,\n\ *\n\ * by routine DLAGTF. The choice of equation to be solved is\n\ * controlled by the argument JOB, and in each case there is an option\n\ * to perturb zero or very small diagonal elements of U, this option\n\ * being intended for use in applications such as inverse iteration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) INTEGER\n\ * Specifies the job to be performed by DLAGTS as follows:\n\ * = 1: The equations (T - lambda*I)x = y are to be solved,\n\ * but diagonal elements of U are not to be perturbed.\n\ * = -1: The equations (T - lambda*I)x = y are to be solved\n\ * and, if overflow would otherwise occur, the diagonal\n\ * elements of U are to be perturbed. See argument TOL\n\ * below.\n\ * = 2: The equations (T - lambda*I)'x = y are to be solved,\n\ * but diagonal elements of U are not to be perturbed.\n\ * = -2: The equations (T - lambda*I)'x = y are to be solved\n\ * and, if overflow would otherwise occur, the diagonal\n\ * elements of U are to be perturbed. See argument TOL\n\ * below.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix T.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (N)\n\ * On entry, A must contain the diagonal elements of U as\n\ * returned from DLAGTF.\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (N-1)\n\ * On entry, B must contain the first super-diagonal elements of\n\ * U as returned from DLAGTF.\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension (N-1)\n\ * On entry, C must contain the sub-diagonal elements of L as\n\ * returned from DLAGTF.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N-2)\n\ * On entry, D must contain the second super-diagonal elements\n\ * of U as returned from DLAGTF.\n\ *\n\ * IN (input) INTEGER array, dimension (N)\n\ * On entry, IN must contain details of the matrix P as returned\n\ * from DLAGTF.\n\ *\n\ * Y (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the right hand side vector y.\n\ * On exit, Y is overwritten by the solution vector x.\n\ *\n\ * TOL (input/output) DOUBLE PRECISION\n\ * On entry, with JOB .lt. 0, TOL should be the minimum\n\ * perturbation to be made to very small diagonal elements of U.\n\ * TOL should normally be chosen as about eps*norm(U), where eps\n\ * is the relative machine precision, but if TOL is supplied as\n\ * non-positive, then it is reset to eps*max( abs( u(i,j) ) ).\n\ * If JOB .gt. 0 then TOL is not referenced.\n\ *\n\ * On exit, TOL is changed as described above, only if TOL is\n\ * non-positive on entry. Otherwise TOL is unchanged.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0 : successful exit\n\ * .lt. 0: if INFO = -i, the i-th argument had an illegal value\n\ * .gt. 0: overflow would occur when computing the INFO(th)\n\ * element of the solution vector x. This can only occur\n\ * when JOB is supplied as positive and either means\n\ * that a diagonal element of U is very small, or that\n\ * the elements of the right-hand side vector y are very\n\ * large.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsytrf0000644000175000017500000001451212502223526016526 0ustar uwabamiuwabami--- :name: dsytrf :md5sum: 6d21131ea8f86296671b9092b6e08f5b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSYTRF computes the factorization of a real symmetric matrix A using\n\ * the Bunch-Kaufman diagonal pivoting method. The form of the\n\ * factorization is\n\ *\n\ * A = U*D*U**T or A = L*D*L**T\n\ *\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, and D is symmetric and block diagonal with\n\ * 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\ * This is the blocked version of the algorithm, calling Level 3 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L (see below for further details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D.\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\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 length of WORK. LWORK >=1. For best performance\n\ * LWORK >= N*NB, where NB is the block size returned by ILAENV.\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, D(i,i) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular, and division by zero will occur if it\n\ * is used to solve a system of equations.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * If UPLO = 'U', then A = U*D*U', where\n\ * U = P(n)*U(n)* ... *P(k)U(k)* ...,\n\ * i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n\ * 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I v 0 ) k-s\n\ * U(k) = ( 0 I 0 ) s\n\ * ( 0 0 I ) n-k\n\ * k-s s n-k\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n\ * If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n\ * and A(k,k), and v overwrites A(1:k-2,k-1:k).\n\ *\n\ * If UPLO = 'L', then A = L*D*L', where\n\ * L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n\ * i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n\ * n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I 0 0 ) k-1\n\ * L(k) = ( 0 I 0 ) s\n\ * ( 0 v I ) n-k-s+1\n\ * k-1 s n-k-s+1\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n\ * If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n\ * and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LQUERY, UPPER\n INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DLASYF, DSYTF2, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cppsvx0000644000175000017500000002571612502223525016545 0ustar uwabamiuwabami--- :name: cppsvx :md5sum: 7c5c075a3757dacd30b5886053520e39 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - n*(n+1)/2 - afp: :type: complex :intent: input/output :dims: - n*(n+1)/2 - equed: :type: char :intent: input/output - s: :type: real :intent: input/output :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE CPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPPSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to\n\ * compute the solution to a complex system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N Hermitian positive definite matrix stored in\n\ * packed format and X and B are N-by-NRHS matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', real scaling factors are computed to equilibrate\n\ * the system:\n\ * diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n\ *\n\ * 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n\ * factor the matrix A (after equilibration if FACT = 'E') as\n\ * A = U'* U , if UPLO = 'U', or\n\ * A = L * L', if UPLO = 'L',\n\ * where U is an upper triangular matrix, L is a lower triangular\n\ * matrix, and ' indicates conjugate transpose.\n\ *\n\ * 3. If the leading i-by-i principal minor is not positive definite,\n\ * then the routine returns with INFO = i. Otherwise, the factored\n\ * form of A is used to estimate the condition number of the matrix\n\ * A. If the reciprocal of the condition number is less than machine\n\ * precision, INFO = N+1 is returned as a warning, but the routine\n\ * still goes on to solve for X and compute error bounds as\n\ * described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(S) so that it solves the original system before\n\ * equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AFP contains the factored form of A.\n\ * If EQUED = 'Y', the matrix A has been equilibrated\n\ * with scaling factors given by S. AP and AFP will not\n\ * be modified.\n\ * = 'N': The matrix A will be copied to AFP and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AFP and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * A, packed columnwise in a linear array, except if FACT = 'F'\n\ * and EQUED = 'Y', then A must contain the equilibrated matrix\n\ * diag(S)*A*diag(S). The j-th column of A is stored in the\n\ * array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ * See below for further details. A is not modified if\n\ * FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n\ *\n\ * On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n\ * diag(S)*A*diag(S).\n\ *\n\ * AFP (input or output) COMPLEX array, dimension (N*(N+1)/2)\n\ * If FACT = 'F', then AFP is an input argument and on entry\n\ * contains the triangular factor U or L from the Cholesky\n\ * factorization A = U**H*U or A = L*L**H, in the same storage\n\ * format as A. If EQUED .ne. 'N', then AFP is the factored\n\ * form of the equilibrated matrix A.\n\ *\n\ * If FACT = 'N', then AFP is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U**H*U or A = L*L**H of the original\n\ * matrix A.\n\ *\n\ * If FACT = 'E', then AFP is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U**H*U or A = L*L**H of the equilibrated\n\ * matrix A (see the description of AP for the form of the\n\ * equilibrated matrix).\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'Y': Equilibration was done, i.e., A has been replaced by\n\ * diag(S) * A * diag(S).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * S (input or output) REAL array, dimension (N)\n\ * The scale factors for A; not accessed if EQUED = 'N'. S is\n\ * an input argument if FACT = 'F'; otherwise, S is an output\n\ * argument. If FACT = 'F' and EQUED = 'Y', each element of S\n\ * must be positive.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n\ * B is overwritten by diag(S) * B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n\ * the original system of equations. Note that if EQUED = 'Y',\n\ * A and B are modified on exit, and the solution to the\n\ * equilibrated system is inv(diag(S))*X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A after equilibration (if done). If RCOND is less than the\n\ * machine precision (in particular, if RCOND = 0), the matrix\n\ * is singular to working precision. This condition is\n\ * indicated by a return code of INFO > 0.\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\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, and i is\n\ * <= N: the leading minor of order i of A is\n\ * not positive definite, so the factorization\n\ * could not be completed, and the solution has not\n\ * been computed. RCOND = 0 is returned.\n\ * = N+1: U is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The packed storage scheme is illustrated by the following example\n\ * when N = 4, UPLO = 'U':\n\ *\n\ * Two-dimensional storage of the Hermitian matrix A:\n\ *\n\ * a11 a12 a13 a14\n\ * a22 a23 a24\n\ * a33 a34 (aij = conjg(aji))\n\ * a44\n\ *\n\ * Packed storage of the upper triangle of A:\n\ *\n\ * AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cspsv0000644000175000017500000001153112502223525016346 0ustar uwabamiuwabami--- :name: cspsv :md5sum: 8afbd7ff5fb61d346b159c2fd129c50f :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: output :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: n: ldb :fortran_help: " SUBROUTINE CSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSPSV computes the solution to a complex system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N symmetric matrix stored in packed format and X\n\ * and B are N-by-NRHS matrices.\n\ *\n\ * The diagonal pivoting method is used to factor A as\n\ * A = U * D * U**T, if UPLO = 'U', or\n\ * A = L * D * L**T, if UPLO = 'L',\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, D is symmetric and block diagonal with 1-by-1\n\ * and 2-by-2 diagonal blocks. The factored form of A is then used to\n\ * solve the system of equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ * See below for further details.\n\ *\n\ * On exit, the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L from the factorization\n\ * A = U*D*U**T or A = L*D*L**T as computed by CSPTRF, stored as\n\ * a packed triangular matrix in the same storage format as A.\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D, as\n\ * determined by CSPTRF. If IPIV(k) > 0, then rows and columns\n\ * k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n\ * diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n\ * then rows and columns k-1 and -IPIV(k) were interchanged and\n\ * D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n\ * IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n\ * -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n\ * diagonal block.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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, D(i,i) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular, so the solution could not be\n\ * computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The packed storage scheme is illustrated by the following example\n\ * when N = 4, UPLO = 'U':\n\ *\n\ * Two-dimensional storage of the symmetric matrix A:\n\ *\n\ * a11 a12 a13 a14\n\ * a22 a23 a24\n\ * a33 a34 (aij = aji)\n\ * a44\n\ *\n\ * Packed storage of the upper triangle of A:\n\ *\n\ * AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n\ *\n\ * =====================================================================\n\ *\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CSPTRF, CSPTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slaed10000644000175000017500000001170212655767354016407 0ustar uwabamiuwabami--- :name: slaed1 :md5sum: d07835f50a422bece671635ac839355a :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - q: :type: real :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - indxq: :type: integer :intent: input/output :dims: - n - rho: :type: real :intent: input - cutpnt: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 4*n + pow(n,2) - iwork: :type: integer :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAED1 computes the updated eigensystem of a diagonal\n\ * matrix after modification by a rank-one symmetric matrix. This\n\ * routine is used only for the eigenproblem which requires all\n\ * eigenvalues and eigenvectors of a tridiagonal matrix. SLAED7 handles\n\ * the case in which eigenvalues only or eigenvalues and eigenvectors\n\ * of a full symmetric matrix (which was reduced to tridiagonal form)\n\ * are desired.\n\ *\n\ * T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)\n\ *\n\ * where Z = Q'u, u is a vector of length N with ones in the\n\ * CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.\n\ *\n\ * The eigenvectors of the original matrix are stored in Q, and the\n\ * eigenvalues are in D. The algorithm consists of three stages:\n\ *\n\ * The first stage consists of deflating the size of the problem\n\ * when there are multiple eigenvalues or if there is a zero in\n\ * the Z vector. For each such occurrence the dimension of the\n\ * secular equation problem is reduced by one. This stage is\n\ * performed by the routine SLAED2.\n\ *\n\ * The second stage consists of calculating the updated\n\ * eigenvalues. This is done by finding the roots of the secular\n\ * equation via the routine SLAED4 (as called by SLAED3).\n\ * This routine also calculates the eigenvectors of the current\n\ * problem.\n\ *\n\ * The final stage consists of computing the updated eigenvectors\n\ * directly using the updated eigenvalues. The eigenvectors for\n\ * the current problem are multiplied with the eigenvectors from\n\ * the overall problem.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The dimension of the symmetric tridiagonal matrix. N >= 0.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the eigenvalues of the rank-1-perturbed matrix.\n\ * On exit, the eigenvalues of the repaired matrix.\n\ *\n\ * Q (input/output) REAL array, dimension (LDQ,N)\n\ * On entry, the eigenvectors of the rank-1-perturbed matrix.\n\ * On exit, the eigenvectors of the repaired tridiagonal matrix.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N).\n\ *\n\ * INDXQ (input/output) INTEGER array, dimension (N)\n\ * On entry, the permutation which separately sorts the two\n\ * subproblems in D into ascending order.\n\ * On exit, the permutation which will reintegrate the\n\ * subproblems back into sorted order,\n\ * i.e. D( INDXQ( I = 1, N ) ) will be in ascending order.\n\ *\n\ * RHO (input) REAL\n\ * The subdiagonal entry used to create the rank-1 modification.\n\ *\n\ * CUTPNT (input) INTEGER\n\ * The location of the last eigenvalue in the leading sub-matrix.\n\ * min(1,N) <= CUTPNT <= N/2.\n\ *\n\ * WORK (workspace) REAL array, dimension (4*N + N**2)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (4*N)\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 = 1, an eigenvalue did not converge\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Jeff Rutter, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ * Modified by Francoise Tisseur, University of Tennessee.\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER COLTYP, CPP1, I, IDLMDA, INDX, INDXC, INDXP,\n $ IQ2, IS, IW, IZ, K, N1, N2\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SCOPY, SLAED2, SLAED3, SLAMRG, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sormrq0000644000175000017500000001046212502223526016536 0ustar uwabamiuwabami--- :name: sormrq :md5sum: c9ce5049cc64eea5a906b4441ebbcde8 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SORMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SORMRQ overwrites the general real M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'T': Q**T * C C * Q**T\n\ *\n\ * where Q is a real orthogonal matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by SGERQF. Q is of order M if SIDE = 'L' and of order N\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**T from the Left;\n\ * = 'R': apply Q or Q**T from the Right.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q;\n\ * = 'T': Transpose, apply Q**T.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) REAL array, dimension\n\ * (LDA,M) if SIDE = 'L',\n\ * (LDA,N) if SIDE = 'R'\n\ * The i-th row must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * SGERQF in the last k rows of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,K).\n\ *\n\ * TAU (input) REAL array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by SGERQF.\n\ *\n\ * C (input/output) REAL array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace/output) REAL 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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M).\n\ * For optimum performance LWORK >= N*NB if SIDE = 'L', and\n\ * LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n\ * 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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dorg2r0000644000175000017500000000447112502223526016415 0ustar uwabamiuwabami--- :name: dorg2r :md5sum: af8c6ad7cd7df62846868e6258c386e0 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - work: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DORG2R generates an m by n real matrix Q with orthonormal columns,\n\ * which is defined as the first n columns of a product of k elementary\n\ * reflectors of order m\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by DGEQRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. M >= N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. N >= K >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the i-th column must contain the vector which\n\ * defines the elementary reflector H(i), for i = 1,2,...,k, as\n\ * returned by DGEQRF in the first k columns of its array\n\ * argument A.\n\ * On exit, the m-by-n matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) DOUBLE PRECISION array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by DGEQRF.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgtsvx0000644000175000017500000002320712502223526016552 0ustar uwabamiuwabami--- :name: sgtsvx :md5sum: 424970766dd3d41a2404ab38f5143612 :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: real :intent: input :dims: - n-1 - d: :type: real :intent: input :dims: - n - du: :type: real :intent: input :dims: - n-1 - dlf: :type: real :intent: input/output :dims: - n-1 - df: :type: real :intent: input/output :dims: - n - duf: :type: real :intent: input/output :dims: - n-1 - du2: :type: real :intent: input/output :dims: - n-2 - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE SGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGTSVX uses the LU factorization to compute the solution to a real\n\ * system of linear equations A * X = B or A**T * X = B,\n\ * where A is a tridiagonal matrix of order N and X and B are N-by-NRHS\n\ * matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'N', the LU decomposition is used to factor the matrix A\n\ * as A = L * U, where L is a product of permutation and unit lower\n\ * bidiagonal matrices and U is upper triangular with nonzeros in\n\ * only the main diagonal and first two superdiagonals.\n\ *\n\ * 2. If some U(i,i)=0, so that U is exactly singular, then the routine\n\ * returns with INFO = i. Otherwise, the factored form of A is used\n\ * to estimate the condition number of the matrix A. If the\n\ * reciprocal of the condition number is less than machine precision,\n\ * INFO = N+1 is returned as a warning, but the routine still goes on\n\ * to solve for X and compute error bounds as described below.\n\ *\n\ * 3. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 4. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of A has been\n\ * supplied on entry.\n\ * = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored\n\ * form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV\n\ * will not be modified.\n\ * = 'N': The matrix will be copied to DLF, DF, and DUF\n\ * and factored.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * DL (input) REAL array, dimension (N-1)\n\ * The (n-1) subdiagonal elements of A.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The n diagonal elements of A.\n\ *\n\ * DU (input) REAL array, dimension (N-1)\n\ * The (n-1) superdiagonal elements of A.\n\ *\n\ * DLF (input or output) REAL array, dimension (N-1)\n\ * If FACT = 'F', then DLF is an input argument and on entry\n\ * contains the (n-1) multipliers that define the matrix L from\n\ * the LU factorization of A as computed by SGTTRF.\n\ *\n\ * If FACT = 'N', then DLF is an output argument and on exit\n\ * contains the (n-1) multipliers that define the matrix L from\n\ * the LU factorization of A.\n\ *\n\ * DF (input or output) REAL array, dimension (N)\n\ * If FACT = 'F', then DF is an input argument and on entry\n\ * contains the n diagonal elements of the upper triangular\n\ * matrix U from the LU factorization of A.\n\ *\n\ * If FACT = 'N', then DF is an output argument and on exit\n\ * contains the n diagonal elements of the upper triangular\n\ * matrix U from the LU factorization of A.\n\ *\n\ * DUF (input or output) REAL array, dimension (N-1)\n\ * If FACT = 'F', then DUF is an input argument and on entry\n\ * contains the (n-1) elements of the first superdiagonal of U.\n\ *\n\ * If FACT = 'N', then DUF is an output argument and on exit\n\ * contains the (n-1) elements of the first superdiagonal of U.\n\ *\n\ * DU2 (input or output) REAL array, dimension (N-2)\n\ * If FACT = 'F', then DU2 is an input argument and on entry\n\ * contains the (n-2) elements of the second superdiagonal of\n\ * U.\n\ *\n\ * If FACT = 'N', then DU2 is an output argument and on exit\n\ * contains the (n-2) elements of the second superdiagonal of\n\ * U.\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains the pivot indices from the LU factorization of A as\n\ * computed by SGTTRF.\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the LU factorization of A;\n\ * row i of the matrix was interchanged with row IPIV(i).\n\ * IPIV(i) will always be either i or i+1; IPIV(i) = i indicates\n\ * a row interchange was not required.\n\ *\n\ * B (input) REAL array, dimension (LDB,NRHS)\n\ * The N-by-NRHS right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) REAL array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A. If RCOND is less than the machine precision (in\n\ * particular, if RCOND = 0), the matrix is singular to working\n\ * precision. This condition is indicated by a return code of\n\ * INFO > 0.\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) REAL array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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, and i is\n\ * <= N: U(i,i) is exactly zero. The factorization\n\ * has not been completed unless i = N, but the\n\ * factor U is exactly singular, so the solution\n\ * and error bounds could not be computed.\n\ * RCOND = 0 is returned.\n\ * = N+1: U is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dorm2r0000644000175000017500000000732212502223526016421 0ustar uwabamiuwabami--- :name: dorm2r :md5sum: fab971af37bdf9192f838b2bc546173d :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DORM2R overwrites the general real m by n matrix C with\n\ *\n\ * Q * C if SIDE = 'L' and TRANS = 'N', or\n\ *\n\ * Q'* C if SIDE = 'L' and TRANS = 'T', or\n\ *\n\ * C * Q if SIDE = 'R' and TRANS = 'N', or\n\ *\n\ * C * Q' if SIDE = 'R' and TRANS = 'T',\n\ *\n\ * where Q is a real orthogonal matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q' from the Left\n\ * = 'R': apply Q or Q' from the Right\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': apply Q (No transpose)\n\ * = 'T': apply Q' (Transpose)\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,K)\n\ * The i-th column must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * DGEQRF in the first k columns of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ * If SIDE = 'L', LDA >= max(1,M);\n\ * if SIDE = 'R', LDA >= max(1,N).\n\ *\n\ * TAU (input) DOUBLE PRECISION array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by DGEQRF.\n\ *\n\ * C (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n\ * On entry, the m by n matrix C.\n\ * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension\n\ * (N) if SIDE = 'L',\n\ * (M) if SIDE = 'R'\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgesvd0000644000175000017500000001572612502223526016516 0ustar uwabamiuwabami--- :name: sgesvd :md5sum: d1b4d1842f793e4c465046572749c3b6 :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobvt: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n :outdims: - lda - MIN(m,n) - lda: :type: integer :intent: input - s: :type: real :intent: output :dims: - MIN(m,n) - u: :type: real :intent: output :dims: - ldu - "lsame_(&jobu,\"A\") ? m : lsame_(&jobu,\"S\") ? MIN(m,n) : 0" - ldu: :type: integer :intent: input - vt: :type: real :intent: output :dims: - ldvt - n - ldvt: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(MAX(1, 3*MIN(m,n)+MAX(m,n)), 5*MIN(m,n)) - info: :type: integer :intent: output :substitutions: m: lda ldvt: "lsame_(&jobvt,\"A\") ? n : lsame_(&jobvt,\"S\") ? MIN(m,n) : 1" ldu: "((lsame_(&jobu,\"S\")) || (lsame_(&jobu,\"A\"))) ? m : 1" :fortran_help: " SUBROUTINE SGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGESVD computes the singular value decomposition (SVD) of a real\n\ * M-by-N matrix A, optionally computing the left and/or right singular\n\ * vectors. The SVD is written\n\ *\n\ * A = U * SIGMA * transpose(V)\n\ *\n\ * where SIGMA is an M-by-N matrix which is zero except for its\n\ * min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and\n\ * V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA\n\ * are the singular values of A; they are real and non-negative, and\n\ * are returned in descending order. The first min(m,n) columns of\n\ * U and V are the left and right singular vectors of A.\n\ *\n\ * Note that the routine returns V**T, not V.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBU (input) CHARACTER*1\n\ * Specifies options for computing all or part of the matrix U:\n\ * = 'A': all M columns of U are returned in array U:\n\ * = 'S': the first min(m,n) columns of U (the left singular\n\ * vectors) are returned in the array U;\n\ * = 'O': the first min(m,n) columns of U (the left singular\n\ * vectors) are overwritten on the array A;\n\ * = 'N': no columns of U (no left singular vectors) are\n\ * computed.\n\ *\n\ * JOBVT (input) CHARACTER*1\n\ * Specifies options for computing all or part of the matrix\n\ * V**T:\n\ * = 'A': all N rows of V**T are returned in the array VT;\n\ * = 'S': the first min(m,n) rows of V**T (the right singular\n\ * vectors) are returned in the array VT;\n\ * = 'O': the first min(m,n) rows of V**T (the right singular\n\ * vectors) are overwritten on the array A;\n\ * = 'N': no rows of V**T (no right singular vectors) are\n\ * computed.\n\ *\n\ * JOBVT and JOBU cannot both be 'O'.\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. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit,\n\ * if JOBU = 'O', A is overwritten with the first min(m,n)\n\ * columns of U (the left singular vectors,\n\ * stored columnwise);\n\ * if JOBVT = 'O', A is overwritten with the first min(m,n)\n\ * rows of V**T (the right singular vectors,\n\ * stored rowwise);\n\ * if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A\n\ * are destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * S (output) REAL array, dimension (min(M,N))\n\ * The singular values of A, sorted so that S(i) >= S(i+1).\n\ *\n\ * U (output) REAL array, dimension (LDU,UCOL)\n\ * (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.\n\ * If JOBU = 'A', U contains the M-by-M orthogonal matrix U;\n\ * if JOBU = 'S', U contains the first min(m,n) columns of U\n\ * (the left singular vectors, stored columnwise);\n\ * if JOBU = 'N' or 'O', U is not referenced.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= 1; if\n\ * JOBU = 'S' or 'A', LDU >= M.\n\ *\n\ * VT (output) REAL array, dimension (LDVT,N)\n\ * If JOBVT = 'A', VT contains the N-by-N orthogonal matrix\n\ * V**T;\n\ * if JOBVT = 'S', VT contains the first min(m,n) rows of\n\ * V**T (the right singular vectors, stored rowwise);\n\ * if JOBVT = 'N' or 'O', VT is not referenced.\n\ *\n\ * LDVT (input) INTEGER\n\ * The leading dimension of the array VT. LDVT >= 1; if\n\ * JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).\n\ *\n\ * WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK;\n\ * if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged\n\ * superdiagonal elements of an upper bidiagonal matrix B\n\ * whose diagonal is in S (not necessarily sorted). B\n\ * satisfies A = U * B * VT, so it has the same singular values\n\ * as A, and singular vectors related by U and VT.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK.\n\ * LWORK >= MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)).\n\ * For good performance, LWORK should generally be larger.\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 SBDSQR did not converge, INFO specifies how many\n\ * superdiagonals of an intermediate bidiagonal form B\n\ * did not converge to zero. See the description of WORK\n\ * above for details.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clasr0000644000175000017500000001400712502223525016315 0ustar uwabamiuwabami--- :name: clasr :md5sum: 9edeb6dbb98dd9c3e28985b4bc103c42 :category: :subroutine :arguments: - side: :type: char :intent: input - pivot: :type: char :intent: input - direct: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - c: :type: real :intent: input :dims: - m-1 - s: :type: real :intent: input :dims: - m-1 - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE CLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLASR applies a sequence of real plane rotations to a complex matrix\n\ * A, from either the left or the right.\n\ *\n\ * When SIDE = 'L', the transformation takes the form\n\ *\n\ * A := P*A\n\ *\n\ * and when SIDE = 'R', the transformation takes the form\n\ *\n\ * A := A*P**T\n\ *\n\ * where P is an orthogonal matrix consisting of a sequence of z plane\n\ * rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',\n\ * and P**T is the transpose of P.\n\ * \n\ * When DIRECT = 'F' (Forward sequence), then\n\ * \n\ * P = P(z-1) * ... * P(2) * P(1)\n\ * \n\ * and when DIRECT = 'B' (Backward sequence), then\n\ * \n\ * P = P(1) * P(2) * ... * P(z-1)\n\ * \n\ * where P(k) is a plane rotation matrix defined by the 2-by-2 rotation\n\ * \n\ * R(k) = ( c(k) s(k) )\n\ * = ( -s(k) c(k) ).\n\ * \n\ * When PIVOT = 'V' (Variable pivot), the rotation is performed\n\ * for the plane (k,k+1), i.e., P(k) has the form\n\ * \n\ * P(k) = ( 1 )\n\ * ( ... )\n\ * ( 1 )\n\ * ( c(k) s(k) )\n\ * ( -s(k) c(k) )\n\ * ( 1 )\n\ * ( ... )\n\ * ( 1 )\n\ * \n\ * where R(k) appears as a rank-2 modification to the identity matrix in\n\ * rows and columns k and k+1.\n\ * \n\ * When PIVOT = 'T' (Top pivot), the rotation is performed for the\n\ * plane (1,k+1), so P(k) has the form\n\ * \n\ * P(k) = ( c(k) s(k) )\n\ * ( 1 )\n\ * ( ... )\n\ * ( 1 )\n\ * ( -s(k) c(k) )\n\ * ( 1 )\n\ * ( ... )\n\ * ( 1 )\n\ * \n\ * where R(k) appears in rows and columns 1 and k+1.\n\ * \n\ * Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is\n\ * performed for the plane (k,z), giving P(k) the form\n\ * \n\ * P(k) = ( 1 )\n\ * ( ... )\n\ * ( 1 )\n\ * ( c(k) s(k) )\n\ * ( 1 )\n\ * ( ... )\n\ * ( 1 )\n\ * ( -s(k) c(k) )\n\ * \n\ * where R(k) appears in rows and columns k and z. The rotations are\n\ * performed without ever forming P(k) explicitly.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * Specifies whether the plane rotation matrix P is applied to\n\ * A on the left or the right.\n\ * = 'L': Left, compute A := P*A\n\ * = 'R': Right, compute A:= A*P**T\n\ *\n\ * PIVOT (input) CHARACTER*1\n\ * Specifies the plane for which P(k) is a plane rotation\n\ * matrix.\n\ * = 'V': Variable pivot, the plane (k,k+1)\n\ * = 'T': Top pivot, the plane (1,k+1)\n\ * = 'B': Bottom pivot, the plane (k,z)\n\ *\n\ * DIRECT (input) CHARACTER*1\n\ * Specifies whether P is a forward or backward sequence of\n\ * plane rotations.\n\ * = 'F': Forward, P = P(z-1)*...*P(2)*P(1)\n\ * = 'B': Backward, P = P(1)*P(2)*...*P(z-1)\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A. If m <= 1, an immediate\n\ * return is effected.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix A. If n <= 1, an\n\ * immediate return is effected.\n\ *\n\ * C (input) REAL array, dimension\n\ * (M-1) if SIDE = 'L'\n\ * (N-1) if SIDE = 'R'\n\ * The cosines c(k) of the plane rotations.\n\ *\n\ * S (input) REAL array, dimension\n\ * (M-1) if SIDE = 'L'\n\ * (N-1) if SIDE = 'R'\n\ * The sines s(k) of the plane rotations. The 2-by-2 plane\n\ * rotation part of the matrix P(k), R(k), has the form\n\ * R(k) = ( c(k) s(k) )\n\ * ( -s(k) c(k) ).\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * The M-by-N matrix A. On exit, A is overwritten by P*A if\n\ * SIDE = 'R' or by A*P**T if SIDE = 'L'.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zcposv0000644000175000017500000001464412502223526016545 0ustar uwabamiuwabami--- :name: zcposv :md5sum: f63123d92c2b19650e7f886a8530407f :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - n*nrhs - swork: :type: complex :intent: workspace :dims: - n*(n+nrhs) - rwork: :type: doublereal :intent: workspace :dims: - n - iter: :type: integer :intent: output - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE ZCPOSV( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, WORK, SWORK, RWORK, ITER, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZCPOSV computes the solution to a complex system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N Hermitian positive definite matrix and X and B\n\ * are N-by-NRHS matrices.\n\ *\n\ * ZCPOSV first attempts to factorize the matrix in COMPLEX and use this\n\ * factorization within an iterative refinement procedure to produce a\n\ * solution with COMPLEX*16 normwise backward error quality (see below).\n\ * If the approach fails the method switches to a COMPLEX*16\n\ * factorization and solve.\n\ *\n\ * The iterative refinement is not going to be a winning strategy if\n\ * the ratio COMPLEX performance over COMPLEX*16 performance is too\n\ * small. A reasonable strategy should take the number of right-hand\n\ * sides and the size of the matrix into account. This might be done\n\ * with a call to ILAENV in the future. Up to now, we always try\n\ * iterative refinement.\n\ *\n\ * The iterative refinement process is stopped if\n\ * ITER > ITERMAX\n\ * or for all the RHS we have:\n\ * RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX\n\ * where\n\ * o ITER is the number of the current iteration in the iterative\n\ * refinement process\n\ * o RNRM is the infinity-norm of the residual\n\ * o XNRM is the infinity-norm of the solution\n\ * o ANRM is the infinity-operator-norm of the matrix A\n\ * o EPS is the machine epsilon returned by DLAMCH('Epsilon')\n\ * The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00\n\ * respectively.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array,\n\ * dimension (LDA,N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * Note that the imaginary parts of the diagonal\n\ * elements need not be set and are assumed to be zero.\n\ *\n\ * On exit, if iterative refinement has been successfully used\n\ * (INFO.EQ.0 and ITER.GE.0, see description below), then A is\n\ * unchanged, if double precision factorization has been used\n\ * (INFO.EQ.0 and ITER.LT.0, see description below), then the\n\ * array A contains the factor U or L from the Cholesky\n\ * factorization A = U**H*U or A = L*L**H.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The N-by-NRHS right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * If INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (N*NRHS)\n\ * This array is used to hold the residual vectors.\n\ *\n\ * SWORK (workspace) COMPLEX array, dimension (N*(N+NRHS))\n\ * This array is used to use the single precision matrix and the\n\ * right-hand sides or solutions in single precision.\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * ITER (output) INTEGER\n\ * < 0: iterative refinement has failed, COMPLEX*16\n\ * factorization has been performed\n\ * -1 : the routine fell back to full precision for\n\ * implementation- or machine-specific reasons\n\ * -2 : narrowing the precision induced an overflow,\n\ * the routine fell back to full precision\n\ * -3 : failure of CPOTRF\n\ * -31: stop the iterative refinement after the 30th\n\ * iterations\n\ * > 0: iterative refinement has been sucessfully used.\n\ * Returns the number of iterations\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 leading minor of order i of\n\ * (COMPLEX*16) A is not positive definite, so the\n\ * factorization could not be completed, and the solution\n\ * has not been computed.\n\ *\n\ * =========\n\ *\n" ruby-lapack-1.7.2/dev/defs/slasd10000644000175000017500000001402412655767354016425 0ustar uwabamiuwabami--- :name: slasd1 :md5sum: a7c621c6eb8da974889c7dd9078eeeb9 :category: :subroutine :arguments: - nl: :type: integer :intent: input - nr: :type: integer :intent: input - sqre: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - nl+nr+1 - alpha: :type: real :intent: input/output - beta: :type: real :intent: input/output - u: :type: real :intent: input/output :dims: - ldu - n - ldu: :type: integer :intent: input - vt: :type: real :intent: input/output :dims: - ldvt - m - ldvt: :type: integer :intent: input - idxq: :type: integer :intent: output :dims: - n - iwork: :type: integer :intent: workspace :dims: - 4*n - work: :type: real :intent: workspace :dims: - 3*pow(m,2)+2*m - info: :type: integer :intent: output :substitutions: m: n + sqre :fortran_help: " SUBROUTINE SLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT, IDXQ, IWORK, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B,\n\ * where N = NL + NR + 1 and M = N + SQRE. SLASD1 is called from SLASD0.\n\ *\n\ * A related subroutine SLASD7 handles the case in which the singular\n\ * values (and the singular vectors in factored form) are desired.\n\ *\n\ * SLASD1 computes the SVD as follows:\n\ *\n\ * ( D1(in) 0 0 0 )\n\ * B = U(in) * ( Z1' a Z2' b ) * VT(in)\n\ * ( 0 0 D2(in) 0 )\n\ *\n\ * = U(out) * ( D(out) 0) * VT(out)\n\ *\n\ * where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M\n\ * with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros\n\ * elsewhere; and the entry b is empty if SQRE = 0.\n\ *\n\ * The left singular vectors of the original matrix are stored in U, and\n\ * the transpose of the right singular vectors are stored in VT, and the\n\ * singular values are in D. The algorithm consists of three stages:\n\ *\n\ * The first stage consists of deflating the size of the problem\n\ * when there are multiple singular values or when there are zeros in\n\ * the Z vector. For each such occurrence the dimension of the\n\ * secular equation problem is reduced by one. This stage is\n\ * performed by the routine SLASD2.\n\ *\n\ * The second stage consists of calculating the updated\n\ * singular values. This is done by finding the square roots of the\n\ * roots of the secular equation via the routine SLASD4 (as called\n\ * by SLASD3). This routine also calculates the singular vectors of\n\ * the current problem.\n\ *\n\ * The final stage consists of computing the updated singular vectors\n\ * directly using the updated singular values. The singular vectors\n\ * for the current problem are multiplied with the singular vectors\n\ * from the overall problem.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NL (input) INTEGER\n\ * The row dimension of the upper block. NL >= 1.\n\ *\n\ * NR (input) INTEGER\n\ * The row dimension of the lower block. NR >= 1.\n\ *\n\ * SQRE (input) INTEGER\n\ * = 0: the lower block is an NR-by-NR square matrix.\n\ * = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n\ *\n\ * The bidiagonal matrix has row dimension N = NL + NR + 1,\n\ * and column dimension M = N + SQRE.\n\ *\n\ * D (input/output) REAL array, dimension (NL+NR+1).\n\ * N = NL+NR+1\n\ * On entry D(1:NL,1:NL) contains the singular values of the\n\ * upper block; and D(NL+2:N) contains the singular values of\n\ * the lower block. On exit D(1:N) contains the singular values\n\ * of the modified matrix.\n\ *\n\ * ALPHA (input/output) REAL\n\ * Contains the diagonal element associated with the added row.\n\ *\n\ * BETA (input/output) REAL\n\ * Contains the off-diagonal element associated with the added\n\ * row.\n\ *\n\ * U (input/output) REAL array, dimension (LDU,N)\n\ * On entry U(1:NL, 1:NL) contains the left singular vectors of\n\ * the upper block; U(NL+2:N, NL+2:N) contains the left singular\n\ * vectors of the lower block. On exit U contains the left\n\ * singular vectors of the bidiagonal matrix.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= max( 1, N ).\n\ *\n\ * VT (input/output) REAL array, dimension (LDVT,M)\n\ * where M = N + SQRE.\n\ * On entry VT(1:NL+1, 1:NL+1)' contains the right singular\n\ * vectors of the upper block; VT(NL+2:M, NL+2:M)' contains\n\ * the right singular vectors of the lower block. On exit\n\ * VT' contains the right singular vectors of the\n\ * bidiagonal matrix.\n\ *\n\ * LDVT (input) INTEGER\n\ * The leading dimension of the array VT. LDVT >= max( 1, M ).\n\ *\n\ * IDXQ (output) INTEGER array, dimension (N)\n\ * This contains the permutation which will reintegrate the\n\ * subproblem just solved back into sorted order, i.e.\n\ * D( IDXQ( I = 1, N ) ) will be in ascending order.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (4*N)\n\ *\n\ * WORK (workspace) REAL array, dimension (3*M**2+2*M)\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 = 1, a singular value did not converge\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ming Gu and Huan Ren, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slartv0000644000175000017500000000412012502223526016520 0ustar uwabamiuwabami--- :name: slartv :md5sum: ecffa2fbeb30d3e551363e5757a136fa :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - y: :type: real :intent: input/output :dims: - 1+(n-1)*incy - incy: :type: integer :intent: input - c: :type: real :intent: input :dims: - 1+(n-1)*incc - s: :type: real :intent: input :dims: - 1+(n-1)*incc - incc: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE SLARTV( N, X, INCX, Y, INCY, C, S, INCC )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLARTV applies a vector of real plane rotations to elements of the\n\ * real vectors x and y. For i = 1,2,...,n\n\ *\n\ * ( x(i) ) := ( c(i) s(i) ) ( x(i) )\n\ * ( y(i) ) ( -s(i) c(i) ) ( y(i) )\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of plane rotations to be applied.\n\ *\n\ * X (input/output) REAL array,\n\ * dimension (1+(N-1)*INCX)\n\ * The vector x.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between elements of X. INCX > 0.\n\ *\n\ * Y (input/output) REAL array,\n\ * dimension (1+(N-1)*INCY)\n\ * The vector y.\n\ *\n\ * INCY (input) INTEGER\n\ * The increment between elements of Y. INCY > 0.\n\ *\n\ * C (input) REAL array, dimension (1+(N-1)*INCC)\n\ * The cosines of the plane rotations.\n\ *\n\ * S (input) REAL array, dimension (1+(N-1)*INCC)\n\ * The sines of the plane rotations.\n\ *\n\ * INCC (input) INTEGER\n\ * The increment between elements of C and S. INCC > 0.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, IC, IX, IY\n REAL XI, YI\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlarrf0000644000175000017500000001165612655767354016520 0ustar uwabamiuwabami--- :name: dlarrf :md5sum: df72f10d35d5993e0a6caea1cd27a6a6 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - l: :type: doublereal :intent: input :dims: - n-1 - ld: :type: doublereal :intent: input :dims: - n-1 - clstrt: :type: integer :intent: input - clend: :type: integer :intent: input - w: :type: doublereal :intent: input :dims: - clend-clstrt+1 - wgap: :type: doublereal :intent: input/output :dims: - clend-clstrt+1 - werr: :type: doublereal :intent: input :dims: - clend-clstrt+1 - spdiam: :type: doublereal :intent: input - clgapl: :type: doublereal :intent: input - clgapr: :type: doublereal :intent: input - pivmin: :type: doublereal :intent: input - sigma: :type: doublereal :intent: output - dplus: :type: doublereal :intent: output :dims: - n - lplus: :type: doublereal :intent: output :dims: - n-1 - work: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLARRF( N, D, L, LD, CLSTRT, CLEND, W, WGAP, WERR, SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA, DPLUS, LPLUS, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Given the initial representation L D L^T and its cluster of close\n\ * eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ...\n\ * W( CLEND ), DLARRF finds a new relatively robust representation\n\ * L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the\n\ * eigenvalues of L(+) D(+) L(+)^T is relatively isolated.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix (subblock, if the matrix split).\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The N diagonal elements of the diagonal matrix D.\n\ *\n\ * L (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (N-1) subdiagonal elements of the unit bidiagonal\n\ * matrix L.\n\ *\n\ * LD (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (N-1) elements L(i)*D(i).\n\ *\n\ * CLSTRT (input) INTEGER\n\ * The index of the first eigenvalue in the cluster.\n\ *\n\ * CLEND (input) INTEGER\n\ * The index of the last eigenvalue in the cluster.\n\ *\n\ * W (input) DOUBLE PRECISION array, dimension\n\ * dimension is >= (CLEND-CLSTRT+1)\n\ * The eigenvalue APPROXIMATIONS of L D L^T in ascending order.\n\ * W( CLSTRT ) through W( CLEND ) form the cluster of relatively\n\ * close eigenalues.\n\ *\n\ * WGAP (input/output) DOUBLE PRECISION array, dimension\n\ * dimension is >= (CLEND-CLSTRT+1)\n\ * The separation from the right neighbor eigenvalue in W.\n\ *\n\ * WERR (input) DOUBLE PRECISION array, dimension\n\ * dimension is >= (CLEND-CLSTRT+1)\n\ * WERR contain the semiwidth of the uncertainty\n\ * interval of the corresponding eigenvalue APPROXIMATION in W\n\ *\n\ * SPDIAM (input) DOUBLE PRECISION\n\ * estimate of the spectral diameter obtained from the\n\ * Gerschgorin intervals\n\ *\n\ * CLGAPL (input) DOUBLE PRECISION\n\ *\n\ * CLGAPR (input) DOUBLE PRECISION\n\ * absolute gap on each end of the cluster.\n\ * Set by the calling routine to protect against shifts too close\n\ * to eigenvalues outside the cluster.\n\ *\n\ * PIVMIN (input) DOUBLE PRECISION\n\ * The minimum pivot allowed in the Sturm sequence.\n\ *\n\ * SIGMA (output) DOUBLE PRECISION\n\ * The shift used to form L(+) D(+) L(+)^T.\n\ *\n\ * DPLUS (output) DOUBLE PRECISION array, dimension (N)\n\ * The N diagonal elements of the diagonal matrix D(+).\n\ *\n\ * LPLUS (output) DOUBLE PRECISION array, dimension (N-1)\n\ * The first (N-1) elements of LPLUS contain the subdiagonal\n\ * elements of the unit bidiagonal matrix L(+).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n\ * Workspace.\n\ *\n\ * INFO (output) INTEGER\n\ * Signals processing OK (=0) or failure (=1)\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Beresford Parlett, University of California, Berkeley, USA\n\ * Jim Demmel, University of California, Berkeley, USA\n\ * Inderjit Dhillon, University of Texas, Austin, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, University of California, Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zunmhr0000644000175000017500000001226412502223526016540 0ustar uwabamiuwabami--- :name: zunmhr :md5sum: 453fec5987903314df5d90693637fa0f :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - m-1 - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZUNMHR overwrites the general complex M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'C': Q**H * C C * Q**H\n\ *\n\ * where Q is a complex unitary matrix of order nq, with nq = m if\n\ * SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of\n\ * IHI-ILO elementary reflectors, as returned by ZGEHRD:\n\ *\n\ * Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**H from the Left;\n\ * = 'R': apply Q or Q**H from the Right.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': apply Q (No transpose)\n\ * = 'C': apply Q**H (Conjugate transpose)\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * ILO and IHI must have the same values as in the previous call\n\ * of ZGEHRD. Q is equal to the unit matrix except in the\n\ * submatrix Q(ilo+1:ihi,ilo+1:ihi).\n\ * If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and\n\ * ILO = 1 and IHI = 0, if M = 0;\n\ * if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and\n\ * ILO = 1 and IHI = 0, if N = 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension\n\ * (LDA,M) if SIDE = 'L'\n\ * (LDA,N) if SIDE = 'R'\n\ * The vectors which define the elementary reflectors, as\n\ * returned by ZGEHRD.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ * LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n\ *\n\ * TAU (input) COMPLEX*16 array, dimension\n\ * (M-1) if SIDE = 'L'\n\ * (N-1) if SIDE = 'R'\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by ZGEHRD.\n\ *\n\ * C (input/output) COMPLEX*16 array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M).\n\ * For optimum performance LWORK >= N*NB if SIDE = 'L', and\n\ * LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n\ * 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\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LEFT, LQUERY\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZUNMQR\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cgelss0000644000175000017500000001170312502223525016471 0ustar uwabamiuwabami--- :name: cgelss :md5sum: 62422f6642a76bd0d56d9f0cc0a57940 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - s: :type: real :intent: output :dims: - MIN(m,n) - rcond: :type: real :intent: input - rank: :type: integer :intent: output - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 3*MIN(m,n) + MAX(MAX(2*MIN(m,n),MAX(m,n)),nrhs) - rwork: :type: real :intent: workspace :dims: - 5*MIN(m,n) - info: :type: integer :intent: output :substitutions: m: lda ldb: MAX(m, n) :fortran_help: " SUBROUTINE CGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGELSS computes the minimum norm solution to a complex linear\n\ * least squares problem:\n\ *\n\ * Minimize 2-norm(| b - A*x |).\n\ *\n\ * using the singular value decomposition (SVD) of A. A is an M-by-N\n\ * matrix which may be rank-deficient.\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 matrix\n\ * X.\n\ *\n\ * The effective rank of A is determined by treating as zero those\n\ * singular values which are less than RCOND times the largest singular\n\ * value.\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\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, the first min(m,n) rows of A are overwritten with\n\ * its right singular vectors, stored rowwise.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the M-by-NRHS right hand side matrix B.\n\ * On exit, B is overwritten by the N-by-NRHS solution matrix X.\n\ * If m >= n and RANK = n, the residual sum-of-squares for\n\ * the solution in the i-th column is given by the sum of\n\ * squares of the modulus of elements n+1:m in that column.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,M,N).\n\ *\n\ * S (output) REAL array, dimension (min(M,N))\n\ * The singular values of A in decreasing order.\n\ * The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n\ *\n\ * RCOND (input) REAL\n\ * RCOND is used to determine the effective rank of A.\n\ * Singular values S(i) <= RCOND*S(1) are treated as zero.\n\ * If RCOND < 0, machine precision is used instead.\n\ *\n\ * RANK (output) INTEGER\n\ * The effective rank of A, i.e., the number of singular values\n\ * which are greater than RCOND*S(1).\n\ *\n\ * WORK (workspace/output) COMPLEX 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 >= 1, and also:\n\ * LWORK >= 2*min(M,N) + max(M,N,NRHS)\n\ * For good performance, LWORK should generally be larger.\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\ * RWORK (workspace) REAL array, dimension (5*min(M,N))\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * > 0: the algorithm for computing the SVD failed to converge;\n\ * if INFO = i, i off-diagonal elements of an intermediate\n\ * bidiagonal form did not converge to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dorgqr0000644000175000017500000000577112502223526016520 0ustar uwabamiuwabami--- :name: dorgqr :md5sum: 10a83164d308f6d24d44e9831e4999ff :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DORGQR generates an M-by-N real matrix Q with orthonormal columns,\n\ * which is defined as the first N columns of a product of K elementary\n\ * reflectors of order M\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by DGEQRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. M >= N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. N >= K >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the i-th column must contain the vector which\n\ * defines the elementary reflector H(i), for i = 1,2,...,k, as\n\ * returned by DGEQRF in the first k columns of its array\n\ * argument A.\n\ * On exit, the M-by-N matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) DOUBLE PRECISION array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by DGEQRF.\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,N).\n\ * For optimum performance LWORK >= N*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 has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgbsv0000644000175000017500000001150612502223526016320 0ustar uwabamiuwabami--- :name: dgbsv :md5sum: 310da022bace27c3272e6f5cd692a164 :category: :subroutine :arguments: - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGBSV computes the solution to a real system of linear equations\n\ * A * X = B, where A is a band matrix of order N with KL subdiagonals\n\ * and KU superdiagonals, and X and B are N-by-NRHS matrices.\n\ *\n\ * The LU decomposition with partial pivoting and row interchanges is\n\ * used to factor A as A = L * U, where L is a product of permutation\n\ * and unit lower triangular matrices with KL subdiagonals, and U is\n\ * upper triangular with KL+KU superdiagonals. The factored form of A\n\ * is then used to solve the system of equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows KL+1 to\n\ * 2*KL+KU+1; rows 1 to KL of the array need not be set.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)\n\ * On exit, details of the factorization: U is stored as an\n\ * upper triangular band matrix with KL+KU superdiagonals in\n\ * rows 1 to KL+KU+1, and the multipliers used during the\n\ * factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n\ * See below for further details.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * The pivot indices that define the permutation matrix P;\n\ * row i of the matrix was interchanged with row IPIV(i).\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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, U(i,i) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, and the solution has not been computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * M = N = 6, KL = 2, KU = 1:\n\ *\n\ * On entry: On exit:\n\ *\n\ * * * * + + + * * * u14 u25 u36\n\ * * * + + + + * * u13 u24 u35 u46\n\ * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n\ * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n\ * a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n\ * a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n\ *\n\ * Array elements marked * are not used by the routine; elements marked\n\ * + need not be set on entry, but are required by the routine to store\n\ * elements of U because of fill-in resulting from the row interchanges.\n\ *\n\ * =====================================================================\n\ *\n\ * .. External Subroutines ..\n EXTERNAL DGBTRF, DGBTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zsyrfsx0000644000175000017500000003761412502223526016753 0ustar uwabamiuwabami--- :name: zsyrfsx :md5sum: 2a39f78dee92e9988bf64c5a25b2d5f2 :category: :subroutine :arguments: - uplo: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " SUBROUTINE ZSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSYRFSX improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is symmetric indefinite, and\n\ * provides error bounds and backward error estimates for the\n\ * solution. In addition to normwise error bound, the code provides\n\ * maximum componentwise error bound if possible. See comments for\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.\n\ *\n\ * The original system of linear equations may have been equilibrated\n\ * before calling this routine, as described by arguments EQUED and S\n\ * below. In this case, the solution and error bounds returned are\n\ * for the original unequilibrated system.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * EQUED (input) CHARACTER*1\n\ * Specifies the form of equilibration that was done to A\n\ * before calling this routine. This is needed to compute\n\ * the solution and error bounds correctly.\n\ * = 'N': No equilibration\n\ * = 'Y': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(S) * A * diag(S).\n\ * The right hand side B has been changed accordingly.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular\n\ * part of the matrix A, and the strictly lower triangular\n\ * part of A is not referenced. If UPLO = 'L', the leading\n\ * N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX*16 array, dimension (LDAF,N)\n\ * The factored form of the matrix A. AF contains the block\n\ * diagonal matrix D and the multipliers used to obtain the\n\ * factor U or L from the factorization A = U*D*U**T or A =\n\ * L*D*L**T as computed by DSYTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by DSYTRF.\n\ *\n\ * S (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The scale factors for A. If EQUED = 'Y', A is multiplied on\n\ * the left and right by diag(S). S is an input argument if FACT =\n\ * 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n\ * = 'Y', each element of S must be positive. If S is output, each\n\ * element of S is a power of the radix. If S is input, each element\n\ * of S should be a power of the radix to ensure a reliable solution\n\ * and error estimates. Scaling by powers of the radix does not cause\n\ * rounding errors unless the result underflows or overflows.\n\ * Rounding errors during scaling lead to refining with a matrix that\n\ * is not equivalent to the input matrix, producing error estimates\n\ * that may not be reliable.\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by DGETRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * Componentwise relative backward error. This is the\n\ * componentwise relative backward error of each solution vector X(j)\n\ * (i.e., the smallest relative change in any element of A or B that\n\ * makes X(j) an exact solution).\n\ *\n\ * N_ERR_BNDS (input) INTEGER\n\ * Number of error bounds to return for each right hand side\n\ * and each type (normwise or componentwise). See ERR_BNDS_NORM and\n\ * ERR_BNDS_COMP below.\n\ *\n\ * ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * dlamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * dlamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * dlamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * dlamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * dlamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * dlamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * NPARAMS (input) INTEGER\n\ * Specifies the number of parameters set in PARAMS. If .LE. 0, the\n\ * PARAMS array is never referenced and default values are used.\n\ *\n\ * PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS\n\ * Specifies algorithm parameters. If an entry is .LT. 0.0, then\n\ * that entry will be filled with default value used for that\n\ * parameter. Only positions up to NPARAMS are accessed; defaults\n\ * are used for higher-numbered parameters.\n\ *\n\ * PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n\ * refinement or not.\n\ * Default: 1.0D+0\n\ * = 0.0 : No refinement is performed, and no error bounds are\n\ * computed.\n\ * = 1.0 : Use the double-precision refinement algorithm,\n\ * possibly with doubled-single computations if the\n\ * compilation environment does not support DOUBLE\n\ * PRECISION.\n\ * (other values are reserved for future use)\n\ *\n\ * PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n\ * computations allowed for refinement.\n\ * Default: 10\n\ * Aggressive: Set to 100 to permit convergence using approximate\n\ * factorizations or factorizations other than LU. If\n\ * the factorization uses a technique other than\n\ * Gaussian elimination, the guarantees in\n\ * err_bnds_norm and err_bnds_comp may no longer be\n\ * trustworthy.\n\ *\n\ * PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n\ * will attempt to find a solution with small componentwise\n\ * relative error in the double-precision algorithm. Positive\n\ * is true, 0.0 is false.\n\ * Default: 1.0 (attempt componentwise convergence)\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit. The solution to every right-hand side is\n\ * guaranteed.\n\ * < 0: If INFO = -i, the i-th argument had an illegal value\n\ * > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sptcon0000644000175000017500000000467112502223526016526 0ustar uwabamiuwabami--- :name: sptcon :md5sum: 5a00e16f6815275367e352669482c2d2 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: real :intent: input :dims: - n-1 - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPTCON( N, D, E, ANORM, RCOND, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPTCON computes the reciprocal of the condition number (in the\n\ * 1-norm) of a real symmetric positive definite tridiagonal matrix\n\ * using the factorization A = L*D*L**T or A = U**T*D*U computed by\n\ * SPTTRF.\n\ *\n\ * Norm(inv(A)) is computed by a direct method, and the reciprocal of\n\ * the condition number is computed as\n\ * RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The n diagonal elements of the diagonal matrix D from the\n\ * factorization of A, as computed by SPTTRF.\n\ *\n\ * E (input) REAL array, dimension (N-1)\n\ * The (n-1) off-diagonal elements of the unit bidiagonal factor\n\ * U or L from the factorization of A, as computed by SPTTRF.\n\ *\n\ * ANORM (input) REAL\n\ * The 1-norm of the original matrix A.\n\ *\n\ * RCOND (output) REAL\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the\n\ * 1-norm of inv(A) computed in this routine.\n\ *\n\ * WORK (workspace) REAL array, dimension (N)\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 method used is described in Nicholas J. Higham, \"Efficient\n\ * Algorithms for Computing the Condition Number of a Tridiagonal\n\ * Matrix\", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgbsvx0000644000175000017500000003446012502223525016512 0ustar uwabamiuwabami--- :name: cgbsvx :md5sum: ec265f99c9de3a8c59cb298793c1ae74 :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: complex :intent: input/output :dims: - ldafb - n :option: true - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n :option: true - equed: :type: char :intent: input/output :option: true - r: :type: real :intent: input/output :dims: - n :option: true - c: :type: real :intent: input/output :dims: - n :option: true - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldx: n ldafb: 2*kl+ku+1 :fortran_help: " SUBROUTINE CGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGBSVX uses the LU factorization to compute the solution to a complex\n\ * system of linear equations A * X = B, A**T * X = B, or A**H * X = B,\n\ * where A is a band matrix of order N with KL subdiagonals and KU\n\ * superdiagonals, and X and B are N-by-NRHS matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed by this subroutine:\n\ *\n\ * 1. If FACT = 'E', real scaling factors are computed to equilibrate\n\ * the system:\n\ * TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n\ * TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n\ * TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n\ * or diag(C)*B (if TRANS = 'T' or 'C').\n\ *\n\ * 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n\ * matrix A (after equilibration if FACT = 'E') as\n\ * A = L * U,\n\ * where L is a product of permutation and unit lower triangular\n\ * matrices with KL subdiagonals, and U is upper triangular with\n\ * KL+KU superdiagonals.\n\ *\n\ * 3. If some U(i,i)=0, so that U is exactly singular, then the routine\n\ * returns with INFO = i. Otherwise, the factored form of A is used\n\ * to estimate the condition number of the matrix A. If the\n\ * reciprocal of the condition number is less than machine precision,\n\ * INFO = N+1 is returned as a warning, but the routine still goes on\n\ * to solve for X and compute error bounds as described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n\ * that it solves the original system before equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AFB and IPIV contain the factored form of\n\ * A. If EQUED is not 'N', the matrix A has been\n\ * equilibrated with scaling factors given by R and C.\n\ * AB, AFB, and IPIV are not modified.\n\ * = 'N': The matrix A will be copied to AFB and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AFB and factored.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations.\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose)\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AB (input/output) COMPLEX array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n\ *\n\ * If FACT = 'F' and EQUED is not 'N', then A must have been\n\ * equilibrated by the scaling factors in R and/or C. AB is not\n\ * modified if FACT = 'F' or 'N', or if FACT = 'E' and\n\ * EQUED = 'N' on exit.\n\ *\n\ * On exit, if EQUED .ne. 'N', A is scaled as follows:\n\ * EQUED = 'R': A := diag(R) * A\n\ * EQUED = 'C': A := A * diag(C)\n\ * EQUED = 'B': A := diag(R) * A * diag(C).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * AFB (input or output) COMPLEX array, dimension (LDAFB,N)\n\ * If FACT = 'F', then AFB is an input argument and on entry\n\ * contains details of the LU factorization of the band matrix\n\ * A, as computed by CGBTRF. U is stored as an upper triangular\n\ * band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n\ * and the multipliers used during the factorization are stored\n\ * in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is\n\ * the factored form of the equilibrated matrix A.\n\ *\n\ * If FACT = 'N', then AFB is an output argument and on exit\n\ * returns details of the LU factorization of A.\n\ *\n\ * If FACT = 'E', then AFB is an output argument and on exit\n\ * returns details of the LU factorization of the equilibrated\n\ * matrix A (see the description of AB for the form of the\n\ * equilibrated matrix).\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains the pivot indices from the factorization A = L*U\n\ * as computed by CGBTRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = L*U\n\ * of the original matrix A.\n\ *\n\ * If FACT = 'E', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = L*U\n\ * of the equilibrated matrix A.\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * R (input or output) REAL array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'R' or 'B', A is\n\ * multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n\ * is not accessed. R is an input argument if FACT = 'F';\n\ * otherwise, R is an output argument. If FACT = 'F' and\n\ * EQUED = 'R' or 'B', each element of R must be positive.\n\ *\n\ * C (input or output) REAL array, dimension (N)\n\ * The column scale factors for A. If EQUED = 'C' or 'B', A is\n\ * multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n\ * is not accessed. C is an input argument if FACT = 'F';\n\ * otherwise, C is an output argument. If FACT = 'F' and\n\ * EQUED = 'C' or 'B', each element of C must be positive.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit,\n\ * if EQUED = 'N', B is not modified;\n\ * if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n\ * diag(R)*B;\n\ * if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n\ * overwritten by diag(C)*B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n\ * to the original system of equations. Note that A and B are\n\ * modified on exit if EQUED .ne. 'N', and the solution to the\n\ * equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n\ * EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n\ * and EQUED = 'R' or 'B'.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A after equilibration (if done). If RCOND is less than the\n\ * machine precision (in particular, if RCOND = 0), the matrix\n\ * is singular to working precision. This condition is\n\ * indicated by a return code of INFO > 0.\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace/output) REAL array, dimension (N)\n\ * On exit, RWORK(1) contains the reciprocal pivot growth\n\ * factor norm(A)/norm(U). The \"max absolute element\" norm is\n\ * used. If RWORK(1) is much less than 1, then the stability\n\ * of the LU factorization of the (equilibrated) matrix A\n\ * could be poor. This also means that the solution X, condition\n\ * estimator RCOND, and forward error bound FERR could be\n\ * unreliable. If factorization fails with 0 0: if INFO = i, and i is\n\ * <= N: U(i,i) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, so the solution and error bounds\n\ * could not be computed. RCOND = 0 is returned.\n\ * = N+1: U is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * =====================================================================\n\ * Moved setting of INFO = N+1 so INFO does not subsequently get\n\ * overwritten. Sven, 17 Mar 05. \n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cla_gbrpvgrw0000644000175000017500000000601012502223525017663 0ustar uwabamiuwabami--- :name: cla_gbrpvgrw :md5sum: 6ebe3ad7622d703a0633348eddaf80d8 :category: :function :type: real :arguments: - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ncols: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: complex :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input :substitutions: {} :fortran_help: " REAL FUNCTION CLA_GBRPVGRW( N, KL, KU, NCOLS, AB, LDAB, AFB, LDAFB )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLA_GBRPVGRW computes the reciprocal pivot growth factor\n\ * norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n\ * much less than 1, the stability of the LU factorization of the\n\ * (equilibrated) matrix A could be poor. This also means that the\n\ * solution X, estimated condition numbers, and error bounds could be\n\ * unreliable.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * NCOLS (input) INTEGER\n\ * The number of columns of the matrix A. NCOLS >= 0.\n\ *\n\ * AB (input) COMPLEX array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * AFB (input) COMPLEX array, dimension (LDAFB,N)\n\ * Details of the LU factorization of the band matrix A, as\n\ * computed by CGBTRF. U is stored as an upper triangular\n\ * band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n\ * and the multipliers used during the factorization are stored\n\ * in rows KL+KU+2 to 2*KL+KU+1.\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J, KD\n REAL AMAX, UMAX, RPVGRW\n COMPLEX ZDUM\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN, REAL, AIMAG\n\ * ..\n\ * .. Statement Functions ..\n REAL CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zgeqp30000644000175000017500000000764012502223526016430 0ustar uwabamiuwabami--- :name: zgeqp3 :md5sum: 4e5e3c299fc7580a41a9e5a83aa4402d :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: doublecomplex :intent: output :dims: - MIN(m,n) - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n+1 - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGEQP3 computes a QR factorization with column pivoting of a\n\ * matrix A: A*P = Q*R using Level 3 BLAS.\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) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, the upper triangle of the array contains the\n\ * min(M,N)-by-N upper trapezoidal matrix R; the elements below\n\ * the diagonal, together with the array TAU, represent the\n\ * unitary matrix Q as a product of min(M,N) elementary\n\ * reflectors.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * JPVT (input/output) INTEGER array, dimension (N)\n\ * On entry, if JPVT(J).ne.0, the J-th column of A is permuted\n\ * to the front of A*P (a leading column); if JPVT(J)=0,\n\ * the J-th column of A is a free column.\n\ * On exit, if JPVT(J)=K, then the J-th column of A*P was the\n\ * the K-th column of A.\n\ *\n\ * TAU (output) COMPLEX*16 array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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 >= N+1.\n\ * For optimal performance LWORK >= ( N+1 )*NB, where NB\n\ * is the 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\ * RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\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(1) H(2) . . . H(k), 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/complex scalar, and v is a real/complex vector\n\ * with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in\n\ * A(i+1:m,i), and tau in TAU(i).\n\ *\n\ * Based on contributions by\n\ * G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n\ * X. Sun, Computer Science Dept., Duke University, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/claqr20000644000175000017500000001772312502223525016405 0ustar uwabamiuwabami--- :name: claqr2 :md5sum: 59b391f379b9ee57f3b536ba3712e7be :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ktop: :type: integer :intent: input - kbot: :type: integer :intent: input - nw: :type: integer :intent: input - h: :type: complex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: complex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - ns: :type: integer :intent: output - nd: :type: integer :intent: output - sh: :type: complex :intent: output :dims: - MAX(1,kbot) - v: :type: complex :intent: workspace :dims: - ldv - MAX(1,nw) - ldv: :type: integer :intent: input - nh: :type: integer :intent: input - t: :type: complex :intent: workspace :dims: - ldv - MAX(1,nw) - ldt: :type: integer :intent: input - nv: :type: integer :intent: input - wv: :type: complex :intent: workspace :dims: - ldv - MAX(1,nw) - ldwv: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*nw :substitutions: ldwv: nw ldt: nw ldv: nw :fortran_help: " SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n\ * This subroutine is identical to CLAQR3 except that it avoids\n\ * recursion by calling CLAHQR instead of CLAQR4.\n\ *\n\ *\n\ * ******************************************************************\n\ * Aggressive early deflation:\n\ *\n\ * This subroutine accepts as input an upper Hessenberg matrix\n\ * H and performs an unitary similarity transformation\n\ * designed to detect and deflate fully converged eigenvalues from\n\ * a trailing principal submatrix. On output H has been over-\n\ * written by a new Hessenberg matrix that is a perturbation of\n\ * an unitary similarity transformation of H. It is to be\n\ * hoped that the final version of H has many zero subdiagonal\n\ * entries.\n\ *\n\ * ******************************************************************\n\n\ * WANTT (input) LOGICAL\n\ * If .TRUE., then the Hessenberg matrix H is fully updated\n\ * so that the triangular Schur factor may be\n\ * computed (in cooperation with the calling subroutine).\n\ * If .FALSE., then only enough of H is updated to preserve\n\ * the eigenvalues.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * If .TRUE., then the unitary matrix Z is updated so\n\ * so that the unitary Schur factor may be computed\n\ * (in cooperation with the calling subroutine).\n\ * If .FALSE., then Z is not referenced.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H and (if WANTZ is .TRUE.) the\n\ * order of the unitary matrix Z.\n\ *\n\ * KTOP (input) INTEGER\n\ * It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n\ * KBOT and KTOP together determine an isolated block\n\ * along the diagonal of the Hessenberg matrix.\n\ *\n\ * KBOT (input) INTEGER\n\ * It is assumed without a check that either\n\ * KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together\n\ * determine an isolated block along the diagonal of the\n\ * Hessenberg matrix.\n\ *\n\ * NW (input) INTEGER\n\ * Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).\n\ *\n\ * H (input/output) COMPLEX array, dimension (LDH,N)\n\ * On input the initial N-by-N section of H stores the\n\ * Hessenberg matrix undergoing aggressive early deflation.\n\ * On output H has been transformed by a unitary\n\ * similarity transformation, perturbed, and the returned\n\ * to Hessenberg form that (it is to be hoped) has some\n\ * zero subdiagonal entries.\n\ *\n\ * LDH (input) integer\n\ * Leading dimension of H just as declared in the calling\n\ * subroutine. N .LE. LDH\n\ *\n\ * ILOZ (input) INTEGER\n\ * IHIZ (input) INTEGER\n\ * Specify the rows of Z to which transformations must be\n\ * applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n\ *\n\ * Z (input/output) COMPLEX array, dimension (LDZ,N)\n\ * IF WANTZ is .TRUE., then on output, the unitary\n\ * similarity transformation mentioned above has been\n\ * accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n\ * If WANTZ is .FALSE., then Z is unreferenced.\n\ *\n\ * LDZ (input) integer\n\ * The leading dimension of Z just as declared in the\n\ * calling subroutine. 1 .LE. LDZ.\n\ *\n\ * NS (output) integer\n\ * The number of unconverged (ie approximate) eigenvalues\n\ * returned in SR and SI that may be used as shifts by the\n\ * calling subroutine.\n\ *\n\ * ND (output) integer\n\ * The number of converged eigenvalues uncovered by this\n\ * subroutine.\n\ *\n\ * SH (output) COMPLEX array, dimension KBOT\n\ * On output, approximate eigenvalues that may\n\ * be used for shifts are stored in SH(KBOT-ND-NS+1)\n\ * through SR(KBOT-ND). Converged eigenvalues are\n\ * stored in SH(KBOT-ND+1) through SH(KBOT).\n\ *\n\ * V (workspace) COMPLEX array, dimension (LDV,NW)\n\ * An NW-by-NW work array.\n\ *\n\ * LDV (input) integer scalar\n\ * The leading dimension of V just as declared in the\n\ * calling subroutine. NW .LE. LDV\n\ *\n\ * NH (input) integer scalar\n\ * The number of columns of T. NH.GE.NW.\n\ *\n\ * T (workspace) COMPLEX array, dimension (LDT,NW)\n\ *\n\ * LDT (input) integer\n\ * The leading dimension of T just as declared in the\n\ * calling subroutine. NW .LE. LDT\n\ *\n\ * NV (input) integer\n\ * The number of rows of work array WV available for\n\ * workspace. NV.GE.NW.\n\ *\n\ * WV (workspace) COMPLEX array, dimension (LDWV,NW)\n\ *\n\ * LDWV (input) integer\n\ * The leading dimension of W just as declared in the\n\ * calling subroutine. NW .LE. LDV\n\ *\n\ * WORK (workspace) COMPLEX array, dimension LWORK.\n\ * On exit, WORK(1) is set to an estimate of the optimal value\n\ * of LWORK for the given values of N, NW, KTOP and KBOT.\n\ *\n\ * LWORK (input) integer\n\ * The dimension of the work array WORK. LWORK = 2*NW\n\ * suffices, but greater efficiency may result from larger\n\ * values of LWORK.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; CLAQR2\n\ * only estimates the optimal workspace size for the given\n\ * values of N, NW, KTOP and KBOT. The estimate is returned\n\ * in WORK(1). No error message related to LWORK is issued\n\ * by XERBLA. Neither H nor Z are accessed.\n\ *\n\n\ * ================================================================\n\ * Based on contributions by\n\ * Karen Braman and Ralph Byers, Department of Mathematics,\n\ * University of Kansas, USA\n\ *\n\ * ================================================================\n" ruby-lapack-1.7.2/dev/defs/cpotrs0000644000175000017500000000417512502223525016530 0ustar uwabamiuwabami--- :name: cpotrs :md5sum: 8d3cc3dae23907090d62f41e1d1f4629 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPOTRS solves a system of linear equations A*X = B with a Hermitian\n\ * positive definite matrix A using the Cholesky factorization \n\ * A = U**H*U or A = L*L**H computed by CPOTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**H*U or A = L*L**H, as computed by CPOTRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgees0000644000175000017500000001600712502223526016303 0ustar uwabamiuwabami--- :name: dgees :md5sum: 6e68756fb1b8fae3f71e2cb0f98b4115 :category: :subroutine :arguments: - jobvs: :type: char :intent: input - sort: :type: char :intent: input - select: :intent: external procedure :block_type: logical :block_arg_num: 2 :block_arg_type: doublereal - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - sdim: :type: integer :intent: output - wr: :type: doublereal :intent: output :dims: - n - wi: :type: doublereal :intent: output :dims: - n - vs: :type: doublereal :intent: output :dims: - ldvs - n - ldvs: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 3*n - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvs: "lsame_(&jobvs,\"V\") ? n : 1" :fortran_help: " SUBROUTINE DGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, VS, LDVS, WORK, LWORK, BWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGEES computes for an N-by-N real nonsymmetric matrix A, the\n\ * eigenvalues, the real Schur form T, and, optionally, the matrix of\n\ * Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).\n\ *\n\ * Optionally, it also orders the eigenvalues on the diagonal of the\n\ * real Schur form so that selected eigenvalues are at the top left.\n\ * The leading columns of Z then form an orthonormal basis for the\n\ * invariant subspace corresponding to the selected eigenvalues.\n\ *\n\ * A matrix is in real Schur form if it is upper quasi-triangular with\n\ * 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the\n\ * form\n\ * [ a b ]\n\ * [ c a ]\n\ *\n\ * where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVS (input) CHARACTER*1\n\ * = 'N': Schur vectors are not computed;\n\ * = 'V': Schur vectors are computed.\n\ *\n\ * SORT (input) CHARACTER*1\n\ * Specifies whether or not to order the eigenvalues on the\n\ * diagonal of the Schur form.\n\ * = 'N': Eigenvalues are not ordered;\n\ * = 'S': Eigenvalues are ordered (see SELECT).\n\ *\n\ * SELECT (external procedure) LOGICAL FUNCTION of two DOUBLE PRECISION arguments\n\ * SELECT must be declared EXTERNAL in the calling subroutine.\n\ * If SORT = 'S', SELECT is used to select eigenvalues to sort\n\ * to the top left of the Schur form.\n\ * If SORT = 'N', SELECT is not referenced.\n\ * An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if\n\ * SELECT(WR(j),WI(j)) is true; i.e., if either one of a complex\n\ * conjugate pair of eigenvalues is selected, then both complex\n\ * eigenvalues are selected.\n\ * Note that a selected complex eigenvalue may no longer\n\ * satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since\n\ * ordering may change the value of complex eigenvalues\n\ * (especially if the eigenvalue is ill-conditioned); in this\n\ * case INFO is set to N+2 (see INFO below).\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ * On exit, A has been overwritten by its real Schur form T.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * SDIM (output) INTEGER\n\ * If SORT = 'N', SDIM = 0.\n\ * If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n\ * for which SELECT is true. (Complex conjugate\n\ * pairs for which SELECT is true for either\n\ * eigenvalue count as 2.)\n\ *\n\ * WR (output) DOUBLE PRECISION array, dimension (N)\n\ * WI (output) DOUBLE PRECISION array, dimension (N)\n\ * WR and WI contain the real and imaginary parts,\n\ * respectively, of the computed eigenvalues in the same order\n\ * that they appear on the diagonal of the output Schur form T.\n\ * Complex conjugate pairs of eigenvalues will appear\n\ * consecutively with the eigenvalue having the positive\n\ * imaginary part first.\n\ *\n\ * VS (output) DOUBLE PRECISION array, dimension (LDVS,N)\n\ * If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur\n\ * vectors.\n\ * If JOBVS = 'N', VS is not referenced.\n\ *\n\ * LDVS (input) INTEGER\n\ * The leading dimension of the array VS. LDVS >= 1; if\n\ * JOBVS = 'V', LDVS >= N.\n\ *\n\ * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) contains the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK >= max(1,3*N).\n\ * For good performance, LWORK must generally be larger.\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\ * BWORK (workspace) LOGICAL array, dimension (N)\n\ * Not referenced if SORT = 'N'.\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, and i is\n\ * <= N: the QR algorithm failed to compute all the\n\ * eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI\n\ * contain those eigenvalues which have converged; if\n\ * JOBVS = 'V', VS contains the matrix which reduces A\n\ * to its partially converged Schur form.\n\ * = N+1: the eigenvalues could not be reordered because some\n\ * eigenvalues were too close to separate (the problem\n\ * is very ill-conditioned);\n\ * = N+2: after reordering, roundoff changed values of some\n\ * complex eigenvalues so that leading eigenvalues in\n\ * the Schur form no longer satisfy SELECT=.TRUE. This\n\ * could also be caused by underflow due to scaling.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssbgvx0000644000175000017500000002151112502223526016524 0ustar uwabamiuwabami--- :name: ssbgvx :md5sum: 6533cca6ce1f6994105411b520fc7ed2 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: real :intent: input/output :dims: - ldbb - n - ldbb: :type: integer :intent: input - q: :type: real :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: output :dims: - 7*n - iwork: :type: integer :intent: output :dims: - 5*n - ifail: :type: integer :intent: output :dims: - m - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" ldq: "1 ? jobz = 'n' : MAX(1,n) ? jobz = 'v' : 0" :fortran_help: " SUBROUTINE SSBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSBGVX computes selected eigenvalues, and optionally, eigenvectors\n\ * of a real generalized symmetric-definite banded eigenproblem, of\n\ * the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric\n\ * and banded, and B is also positive definite. Eigenvalues and\n\ * eigenvectors can be selected by specifying either all eigenvalues,\n\ * a range of values or a range of indices for the desired eigenvalues.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found.\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found.\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * KA (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n\ *\n\ * KB (input) INTEGER\n\ * The number of superdiagonals of the matrix B if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n\ *\n\ * AB (input/output) REAL array, dimension (LDAB, N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first ka+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n\ *\n\ * On exit, the contents of AB are destroyed.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KA+1.\n\ *\n\ * BB (input/output) REAL array, dimension (LDBB, N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix B, stored in the first kb+1 rows of the array. The\n\ * j-th column of B is stored in the j-th column of the array BB\n\ * as follows:\n\ * if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n\ * if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n\ *\n\ * On exit, the factor S from the split Cholesky factorization\n\ * B = S**T*S, as returned by SPBSTF.\n\ *\n\ * LDBB (input) INTEGER\n\ * The leading dimension of the array BB. LDBB >= KB+1.\n\ *\n\ * Q (output) REAL array, dimension (LDQ, N)\n\ * If JOBZ = 'V', the n-by-n matrix used in the reduction of\n\ * A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x,\n\ * and consequently C to tridiagonal form.\n\ * If JOBZ = 'N', the array Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. If JOBZ = 'N',\n\ * LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N).\n\ *\n\ * VL (input) REAL\n\ * VU (input) REAL\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) REAL\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less than\n\ * or equal to zero, then EPS*|T| will be used in its place,\n\ * where |T| is the 1-norm of the tridiagonal matrix obtained\n\ * by reducing A to tridiagonal form.\n\ *\n\ * Eigenvalues will be computed most accurately when ABSTOL is\n\ * set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n\ * If this routine returns with INFO>0, indicating that some\n\ * eigenvectors did not converge, try setting ABSTOL to\n\ * 2*SLAMCH('S').\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) REAL array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n\ * eigenvectors, with the i-th column of Z holding the\n\ * eigenvector associated with W(i). The eigenvectors are\n\ * normalized so Z**T*B*Z = I.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace/output) REAL array, dimension (7N)\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (5N)\n\ *\n\ * IFAIL (output) INTEGER array, dimension (M)\n\ * If JOBZ = 'V', then if INFO = 0, the first M elements of\n\ * IFAIL are zero. If INFO > 0, then IFAIL contains the\n\ * indices of the eigenvalues that failed to converge.\n\ * If JOBZ = 'N', then IFAIL is not referenced.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0 : successful exit\n\ * < 0 : if INFO = -i, the i-th argument had an illegal value\n\ * <= N: if INFO = i, then i eigenvectors failed to converge.\n\ * Their indices are stored in IFAIL.\n\ * > N : SPBSTF returned an error code; i.e.,\n\ * if INFO = N + i, for 1 <= i <= N, then the leading\n\ * minor of order i of B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chpsvx0000644000175000017500000002251412502223525016526 0ustar uwabamiuwabami--- :name: chpsvx :md5sum: 85de40ec51043497622de651889992fd :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - afp: :type: complex :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE CHPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHPSVX uses the diagonal pivoting factorization A = U*D*U**H or\n\ * A = L*D*L**H to compute the solution to a complex system of linear\n\ * equations A * X = B, where A is an N-by-N Hermitian matrix stored\n\ * in packed format and X and B are N-by-NRHS matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'N', the diagonal pivoting method is used to factor A as\n\ * A = U * D * U**H, if UPLO = 'U', or\n\ * A = L * D * L**H, if UPLO = 'L',\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices and D is Hermitian and block diagonal with\n\ * 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\ * 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n\ * returns with INFO = i. Otherwise, the factored form of A is used\n\ * to estimate the condition number of the matrix A. If the\n\ * reciprocal of the condition number is less than machine precision,\n\ * INFO = N+1 is returned as a warning, but the routine still goes on\n\ * to solve for X and compute error bounds as described below.\n\ *\n\ * 3. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 4. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of A has been\n\ * supplied on entry.\n\ * = 'F': On entry, AFP and IPIV contain the factored form of\n\ * A. AFP and IPIV will not be modified.\n\ * = 'N': The matrix A will be copied to AFP and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AP (input) COMPLEX array, dimension (N*(N+1)/2)\n\ * The upper or lower triangle of the Hermitian matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ * See below for further details.\n\ *\n\ * AFP (input or output) COMPLEX array, dimension (N*(N+1)/2)\n\ * If FACT = 'F', then AFP is an input argument and on entry\n\ * contains the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L from the factorization\n\ * A = U*D*U**H or A = L*D*L**H as computed by CHPTRF, stored as\n\ * a packed triangular matrix in the same storage format as A.\n\ *\n\ * If FACT = 'N', then AFP is an output argument and on exit\n\ * contains the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L from the factorization\n\ * A = U*D*U**H or A = L*D*L**H as computed by CHPTRF, stored as\n\ * a packed triangular matrix in the same storage format as A.\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains details of the interchanges and the block structure\n\ * of D, as determined by CHPTRF.\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains details of the interchanges and the block structure\n\ * of D, as determined by CHPTRF.\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,NRHS)\n\ * The N-by-NRHS right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A. If RCOND is less than the machine precision (in\n\ * particular, if RCOND = 0), the matrix is singular to working\n\ * precision. This condition is indicated by a return code of\n\ * INFO > 0.\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\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, and i is\n\ * <= N: D(i,i) is exactly zero. The factorization\n\ * has been completed but the factor D is exactly\n\ * singular, so the solution and error bounds could\n\ * not be computed. RCOND = 0 is returned.\n\ * = N+1: D is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The packed storage scheme is illustrated by the following example\n\ * when N = 4, UPLO = 'U':\n\ *\n\ * Two-dimensional storage of the Hermitian matrix A:\n\ *\n\ * a11 a12 a13 a14\n\ * a22 a23 a24\n\ * a33 a34 (aij = conjg(aji))\n\ * a44\n\ *\n\ * Packed storage of the upper triangle of A:\n\ *\n\ * AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/csyswapr0000644000175000017500000000434212502223525017065 0ustar uwabamiuwabami--- :name: csyswapr :md5sum: e53b159491b12c5dd923b2795134aff2 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - i1: :type: integer :intent: input - i2: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE CSYSWAPR( UPLO, N, A, I1, I2)\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSYSWAPR applies an elementary permutation on the rows and the columns of\n\ * a symmetric matrix.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the NB diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L as computed by CSYTRF.\n\ *\n\ * On exit, if INFO = 0, the (symmetric) inverse of the original\n\ * matrix. If UPLO = 'U', the upper triangular part of the\n\ * inverse is formed and the part of A below the diagonal is not\n\ * referenced; if UPLO = 'L' the lower triangular part of the\n\ * inverse is formed and the part of A above the diagonal is\n\ * not referenced.\n\ *\n\ * I1 (input) INTEGER\n\ * Index of the first row to swap\n\ *\n\ * I2 (input) INTEGER\n\ * Index of the second row to swap\n\ *\n\n\ * =====================================================================\n\ *\n\ * ..\n\ * .. Local Scalars ..\n LOGICAL UPPER\n INTEGER I\n COMPLEX TMP\n\ *\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CSWAP\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sisnan0000644000175000017500000000133312502223526016503 0ustar uwabamiuwabami--- :name: sisnan :md5sum: 59f568b95ecad80e459328f43736527e :category: :function :type: logical :arguments: - sin: :type: real :intent: input :substitutions: {} :fortran_help: " LOGICAL FUNCTION SISNAN( SIN )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SISNAN returns .TRUE. if its argument is NaN, and .FALSE.\n\ * otherwise. To be replaced by the Fortran 2003 intrinsic in the\n\ * future.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIN (input) REAL\n\ * Input to test for NaN.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. External Functions ..\n LOGICAL SLAISNAN\n EXTERNAL SLAISNAN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/chbgst0000644000175000017500000001004712502223525016463 0ustar uwabamiuwabami--- :name: chbgst :md5sum: 50629657aeecc3af421f07faa75dcb16 :category: :subroutine :arguments: - vect: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: complex :intent: input :dims: - ldbb - n - ldbb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - n - ldx: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: "lsame_(&vect,\"V\") ? MAX(1,n) : 1" :fortran_help: " SUBROUTINE CHBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, LDX, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHBGST reduces a complex Hermitian-definite banded generalized\n\ * eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y,\n\ * such that C has the same bandwidth as A.\n\ *\n\ * B must have been previously factorized as S**H*S by CPBSTF, using a\n\ * split Cholesky factorization. A is overwritten by C = X**H*A*X, where\n\ * X = S**(-1)*Q and Q is a unitary matrix chosen to preserve the\n\ * bandwidth of A.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * VECT (input) CHARACTER*1\n\ * = 'N': do not form the transformation matrix X;\n\ * = 'V': form X.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * KA (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n\ *\n\ * KB (input) INTEGER\n\ * The number of superdiagonals of the matrix B if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0.\n\ *\n\ * AB (input/output) COMPLEX array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix A, stored in the first ka+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n\ *\n\ * On exit, the transformed matrix X**H*A*X, stored in the same\n\ * format as A.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KA+1.\n\ *\n\ * BB (input) COMPLEX array, dimension (LDBB,N)\n\ * The banded factor S from the split Cholesky factorization of\n\ * B, as returned by CPBSTF, stored in the first kb+1 rows of\n\ * the array.\n\ *\n\ * LDBB (input) INTEGER\n\ * The leading dimension of the array BB. LDBB >= KB+1.\n\ *\n\ * X (output) COMPLEX array, dimension (LDX,N)\n\ * If VECT = 'V', the n-by-n matrix X.\n\ * If VECT = 'N', the array X is not referenced.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X.\n\ * LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sggrqf0000644000175000017500000001545312502223526016511 0ustar uwabamiuwabami--- :name: sggrqf :md5sum: c7c0fb9d6a37dbbeb48942c85c40711e :category: :subroutine :arguments: - m: :type: integer :intent: input - p: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - taua: :type: real :intent: output :dims: - MIN(m,n) - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - taub: :type: real :intent: output :dims: - MIN(p,n) - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(MAX(n,m),p) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGGRQF computes a generalized RQ factorization of an M-by-N matrix A\n\ * and a P-by-N matrix B:\n\ *\n\ * A = R*Q, B = Z*T*Q,\n\ *\n\ * where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal\n\ * matrix, and R and T assume one of the forms:\n\ *\n\ * if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N,\n\ * N-M M ( R21 ) N\n\ * N\n\ *\n\ * where R12 or R21 is upper triangular, and\n\ *\n\ * if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P,\n\ * ( 0 ) P-N P N-P\n\ * N\n\ *\n\ * where T11 is upper triangular.\n\ *\n\ * In particular, if B is square and nonsingular, the GRQ factorization\n\ * of A and B implicitly gives the RQ factorization of A*inv(B):\n\ *\n\ * A*inv(B) = (R*inv(T))*Z'\n\ *\n\ * where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n\ * transpose of the matrix Z.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A. M >= 0.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows of the matrix B. P >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, if M <= N, the upper triangle of the subarray\n\ * A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;\n\ * if M > N, the elements on and above the (M-N)-th subdiagonal\n\ * contain the M-by-N upper trapezoidal matrix R; the remaining\n\ * elements, with the array TAUA, represent the orthogonal\n\ * matrix Q as a product of elementary reflectors (see Further\n\ * Details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAUA (output) REAL array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the orthogonal matrix Q (see Further Details).\n\ *\n\ * B (input/output) REAL array, dimension (LDB,N)\n\ * On entry, the P-by-N matrix B.\n\ * On exit, the elements on and above the diagonal of the array\n\ * contain the min(P,N)-by-N upper trapezoidal matrix T (T is\n\ * upper triangular if P >= N); the elements below the diagonal,\n\ * with the array TAUB, represent the orthogonal matrix Z as a\n\ * product of elementary reflectors (see Further Details).\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,P).\n\ *\n\ * TAUB (output) REAL array, dimension (min(P,N))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the orthogonal matrix Z (see Further Details).\n\ *\n\ * WORK (workspace/output) REAL 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,N,M,P).\n\ * For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n\ * where NB1 is the optimal blocksize for the RQ factorization\n\ * of an M-by-N matrix, NB2 is the optimal blocksize for the\n\ * QR factorization of a P-by-N matrix, and NB3 is the optimal\n\ * blocksize for a call of SORMRQ.\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 INF0= -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(1) H(2) . . . H(k), where k = min(m,n).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - taua * v * v'\n\ *\n\ * where taua is a real scalar, and v is a real vector with\n\ * v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n\ * A(m-k+i,1:n-k+i-1), and taua in TAUA(i).\n\ * To form Q explicitly, use LAPACK subroutine SORGRQ.\n\ * To use Q to update another matrix, use LAPACK subroutine SORMRQ.\n\ *\n\ * The matrix Z is represented as a product of elementary reflectors\n\ *\n\ * Z = H(1) H(2) . . . H(k), where k = min(p,n).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - taub * v * v'\n\ *\n\ * where taub is a real scalar, and v is a real vector with\n\ * v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),\n\ * and taub in TAUB(i).\n\ * To form Z explicitly, use LAPACK subroutine SORGQR.\n\ * To use Z to update another matrix, use LAPACK subroutine SORMQR.\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SGEQRF, SGERQF, SORMRQ, XERBLA\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV \n EXTERNAL ILAENV \n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC INT, MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlangb0000644000175000017500000000555512502223526016451 0ustar uwabamiuwabami--- :name: dlangb :md5sum: 5a9301c71e52681db32faa73a8ccc40f :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? n : 0" :fortran_help: " DOUBLE PRECISION FUNCTION DLANGB( NORM, N, KL, KU, AB, LDAB, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLANGB returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of an\n\ * n by n band matrix A, with kl sub-diagonals and ku super-diagonals.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * DLANGB returns the value\n\ *\n\ * DLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in DLANGB as described\n\ * above.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, DLANGB is\n\ * set to zero.\n\ *\n\ * KL (input) INTEGER\n\ * The number of sub-diagonals of the matrix A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of super-diagonals of the matrix A. KU >= 0.\n\ *\n\ * AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * The band matrix A, stored in rows 1 to KL+KU+1. The j-th\n\ * column of A is stored in the j-th column of the array AB as\n\ * follows:\n\ * AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n\ * referenced.\n\ *\n\n\ * =====================================================================\n\ *\n\ *\n" ruby-lapack-1.7.2/dev/defs/cla_porpvgrw0000644000175000017500000000514412502223525017720 0ustar uwabamiuwabami--- :name: cla_porpvgrw :md5sum: b6254f02ecd607ce251062879936c907 :category: :function :type: real :arguments: - uplo: :type: char :intent: input - ncols: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - work: :type: complex :intent: input :dims: - 2*n :substitutions: {} :fortran_help: " REAL FUNCTION CLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, LDAF, WORK )\n\n\ * Purpose\n\ * =======\n\ * \n\ * CLA_PORPVGRW computes the reciprocal pivot growth factor\n\ * norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n\ * much less than 1, the stability of the LU factorization of the\n\ * (equilibrated) matrix A could be poor. This also means that the\n\ * solution X, estimated condition numbers, and error bounds could be\n\ * unreliable.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * NCOLS (input) INTEGER\n\ * The number of columns of the matrix A. NCOLS >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX array, dimension (LDAF,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T, as computed by CPOTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * WORK (input) COMPLEX array, dimension (2*N)\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n REAL AMAX, UMAX, RPVGRW\n LOGICAL UPPER\n COMPLEX ZDUM\n\ * ..\n\ * .. External Functions ..\n EXTERNAL LSAME, CLASET\n LOGICAL LSAME\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN, REAL, AIMAG\n\ * ..\n\ * .. Statement Functions ..\n REAL CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zheevd0000644000175000017500000001553712502223526016510 0ustar uwabamiuwabami--- :name: zheevd :md5sum: cfb4c97c52c4714d3a44874ba9810d89 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n+1 : lsame_(&jobz,\"V\") ? 2*n+n*n : 0" - rwork: :type: doublereal :intent: output :dims: - MAX(1,lrwork) - lrwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n+1 : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHEEVD computes all eigenvalues and, optionally, eigenvectors of a\n\ * complex Hermitian matrix A. If eigenvectors are desired, it uses a\n\ * divide and conquer algorithm.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA, N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of A contains the\n\ * upper triangular part of the matrix A. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of A contains\n\ * the lower triangular part of the matrix A.\n\ * On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n\ * orthonormal eigenvectors of the matrix A.\n\ * If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n\ * or the upper triangle (if UPLO='U') of A, including the\n\ * diagonal, is destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of the array WORK.\n\ * If N <= 1, LWORK must be at least 1.\n\ * If JOBZ = 'N' and N > 1, LWORK must be at least N + 1.\n\ * If JOBZ = 'V' and N > 1, LWORK must be at least 2*N + N**2.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the optimal sizes of the WORK, RWORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * RWORK (workspace/output) DOUBLE PRECISION array,\n\ * dimension (LRWORK)\n\ * On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n\ *\n\ * LRWORK (input) INTEGER\n\ * The dimension of the array RWORK.\n\ * If N <= 1, LRWORK must be at least 1.\n\ * If JOBZ = 'N' and N > 1, LRWORK must be at least N.\n\ * If JOBZ = 'V' and N > 1, LRWORK must be at least\n\ * 1 + 5*N + 2*N**2.\n\ *\n\ * If LRWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK.\n\ * If N <= 1, LIWORK must be at least 1.\n\ * If JOBZ = 'N' and N > 1, LIWORK must be at least 1.\n\ * If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK 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 and JOBZ = 'N', then the algorithm failed\n\ * to converge; i off-diagonal elements of an intermediate\n\ * tridiagonal form did not converge to zero;\n\ * if INFO = i and JOBZ = 'V', then the algorithm failed\n\ * to compute an eigenvalue while working on the submatrix\n\ * lying in rows and columns INFO/(N+1) through\n\ * mod(INFO,N+1).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Jeff Rutter, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ *\n\ * Modified description of INFO. Sven, 16 Feb 05.\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cunmr20000644000175000017500000000731312502223526016422 0ustar uwabamiuwabami--- :name: cunmr2 :md5sum: 9fa3edd4ed9752efc8febe2650619540 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CUNMR2 overwrites the general complex m-by-n matrix C with\n\ *\n\ * Q * C if SIDE = 'L' and TRANS = 'N', or\n\ *\n\ * Q'* C if SIDE = 'L' and TRANS = 'C', or\n\ *\n\ * C * Q if SIDE = 'R' and TRANS = 'N', or\n\ *\n\ * C * Q' if SIDE = 'R' and TRANS = 'C',\n\ *\n\ * where Q is a complex unitary matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(1)' H(2)' . . . H(k)'\n\ *\n\ * as returned by CGERQF. Q is of order m if SIDE = 'L' and of order n\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q' from the Left\n\ * = 'R': apply Q or Q' from the Right\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': apply Q (No transpose)\n\ * = 'C': apply Q' (Conjugate transpose)\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension\n\ * (LDA,M) if SIDE = 'L',\n\ * (LDA,N) if SIDE = 'R'\n\ * The i-th row must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * CGERQF in the last k rows of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,K).\n\ *\n\ * TAU (input) COMPLEX array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by CGERQF.\n\ *\n\ * C (input/output) COMPLEX array, dimension (LDC,N)\n\ * On entry, the m-by-n matrix C.\n\ * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension\n\ * (N) if SIDE = 'L',\n\ * (M) if SIDE = 'R'\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slasr0000644000175000017500000001400312502223526016332 0ustar uwabamiuwabami--- :name: slasr :md5sum: ff809128ca416b4d7f92c1ccd028ba23 :category: :subroutine :arguments: - side: :type: char :intent: input - pivot: :type: char :intent: input - direct: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - c: :type: real :intent: input :dims: - m-1 - s: :type: real :intent: input :dims: - m-1 - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE SLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLASR applies a sequence of plane rotations to a real matrix A,\n\ * from either the left or the right.\n\ * \n\ * When SIDE = 'L', the transformation takes the form\n\ * \n\ * A := P*A\n\ * \n\ * and when SIDE = 'R', the transformation takes the form\n\ * \n\ * A := A*P**T\n\ * \n\ * where P is an orthogonal matrix consisting of a sequence of z plane\n\ * rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',\n\ * and P**T is the transpose of P.\n\ * \n\ * When DIRECT = 'F' (Forward sequence), then\n\ * \n\ * P = P(z-1) * ... * P(2) * P(1)\n\ * \n\ * and when DIRECT = 'B' (Backward sequence), then\n\ * \n\ * P = P(1) * P(2) * ... * P(z-1)\n\ * \n\ * where P(k) is a plane rotation matrix defined by the 2-by-2 rotation\n\ * \n\ * R(k) = ( c(k) s(k) )\n\ * = ( -s(k) c(k) ).\n\ * \n\ * When PIVOT = 'V' (Variable pivot), the rotation is performed\n\ * for the plane (k,k+1), i.e., P(k) has the form\n\ * \n\ * P(k) = ( 1 )\n\ * ( ... )\n\ * ( 1 )\n\ * ( c(k) s(k) )\n\ * ( -s(k) c(k) )\n\ * ( 1 )\n\ * ( ... )\n\ * ( 1 )\n\ * \n\ * where R(k) appears as a rank-2 modification to the identity matrix in\n\ * rows and columns k and k+1.\n\ * \n\ * When PIVOT = 'T' (Top pivot), the rotation is performed for the\n\ * plane (1,k+1), so P(k) has the form\n\ * \n\ * P(k) = ( c(k) s(k) )\n\ * ( 1 )\n\ * ( ... )\n\ * ( 1 )\n\ * ( -s(k) c(k) )\n\ * ( 1 )\n\ * ( ... )\n\ * ( 1 )\n\ * \n\ * where R(k) appears in rows and columns 1 and k+1.\n\ * \n\ * Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is\n\ * performed for the plane (k,z), giving P(k) the form\n\ * \n\ * P(k) = ( 1 )\n\ * ( ... )\n\ * ( 1 )\n\ * ( c(k) s(k) )\n\ * ( 1 )\n\ * ( ... )\n\ * ( 1 )\n\ * ( -s(k) c(k) )\n\ * \n\ * where R(k) appears in rows and columns k and z. The rotations are\n\ * performed without ever forming P(k) explicitly.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * Specifies whether the plane rotation matrix P is applied to\n\ * A on the left or the right.\n\ * = 'L': Left, compute A := P*A\n\ * = 'R': Right, compute A:= A*P**T\n\ *\n\ * PIVOT (input) CHARACTER*1\n\ * Specifies the plane for which P(k) is a plane rotation\n\ * matrix.\n\ * = 'V': Variable pivot, the plane (k,k+1)\n\ * = 'T': Top pivot, the plane (1,k+1)\n\ * = 'B': Bottom pivot, the plane (k,z)\n\ *\n\ * DIRECT (input) CHARACTER*1\n\ * Specifies whether P is a forward or backward sequence of\n\ * plane rotations.\n\ * = 'F': Forward, P = P(z-1)*...*P(2)*P(1)\n\ * = 'B': Backward, P = P(1)*P(2)*...*P(z-1)\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A. If m <= 1, an immediate\n\ * return is effected.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix A. If n <= 1, an\n\ * immediate return is effected.\n\ *\n\ * C (input) REAL array, dimension\n\ * (M-1) if SIDE = 'L'\n\ * (N-1) if SIDE = 'R'\n\ * The cosines c(k) of the plane rotations.\n\ *\n\ * S (input) REAL array, dimension\n\ * (M-1) if SIDE = 'L'\n\ * (N-1) if SIDE = 'R'\n\ * The sines s(k) of the plane rotations. The 2-by-2 plane\n\ * rotation part of the matrix P(k), R(k), has the form\n\ * R(k) = ( c(k) s(k) )\n\ * ( -s(k) c(k) ).\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * The M-by-N matrix A. On exit, A is overwritten by P*A if\n\ * SIDE = 'R' or by A*P**T if SIDE = 'L'.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgtrfs0000644000175000017500000001315112502223526016502 0ustar uwabamiuwabami--- :name: dgtrfs :md5sum: 14bdb4c078a4d0b6cccf1b5a3d92eeaa :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: doublereal :intent: input :dims: - n-1 - d: :type: doublereal :intent: input :dims: - n - du: :type: doublereal :intent: input :dims: - n-1 - dlf: :type: doublereal :intent: input :dims: - n-1 - df: :type: doublereal :intent: input :dims: - n - duf: :type: doublereal :intent: input :dims: - n-1 - du2: :type: doublereal :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGTRFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is tridiagonal, and provides\n\ * error bounds and backward error estimates for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * DL (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) subdiagonal elements of A.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The diagonal elements of A.\n\ *\n\ * DU (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) superdiagonal elements of A.\n\ *\n\ * DLF (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) multipliers that define the matrix L from the\n\ * LU factorization of A as computed by DGTTRF.\n\ *\n\ * DF (input) DOUBLE PRECISION array, dimension (N)\n\ * The n diagonal elements of the upper triangular matrix U from\n\ * the LU factorization of A.\n\ *\n\ * DUF (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) elements of the first superdiagonal of U.\n\ *\n\ * DU2 (input) DOUBLE PRECISION array, dimension (N-2)\n\ * The (n-2) elements of the second superdiagonal of U.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices; for 1 <= i <= n, row i of the matrix was\n\ * interchanged with row IPIV(i). IPIV(i) will always be either\n\ * i or i+1; IPIV(i) = i indicates a row interchange was not\n\ * required.\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by DGTTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slags20000644000175000017500000000537612502223526016416 0ustar uwabamiuwabami--- :name: slags2 :md5sum: 33da975bfa8208d409d3b33a3fa68c1d :category: :subroutine :arguments: - upper: :type: logical :intent: input - a1: :type: real :intent: input - a2: :type: real :intent: input - a3: :type: real :intent: input - b1: :type: real :intent: input - b2: :type: real :intent: input - b3: :type: real :intent: input - csu: :type: real :intent: output - snu: :type: real :intent: output - csv: :type: real :intent: output - snv: :type: real :intent: output - csq: :type: real :intent: output - snq: :type: real :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, SNV, CSQ, SNQ )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such\n\ * that if ( UPPER ) then\n\ *\n\ * U'*A*Q = U'*( A1 A2 )*Q = ( x 0 )\n\ * ( 0 A3 ) ( x x )\n\ * and\n\ * V'*B*Q = V'*( B1 B2 )*Q = ( x 0 )\n\ * ( 0 B3 ) ( x x )\n\ *\n\ * or if ( .NOT.UPPER ) then\n\ *\n\ * U'*A*Q = U'*( A1 0 )*Q = ( x x )\n\ * ( A2 A3 ) ( 0 x )\n\ * and\n\ * V'*B*Q = V'*( B1 0 )*Q = ( x x )\n\ * ( B2 B3 ) ( 0 x )\n\ *\n\ * The rows of the transformed A and B are parallel, where\n\ *\n\ * U = ( CSU SNU ), V = ( CSV SNV ), Q = ( CSQ SNQ )\n\ * ( -SNU CSU ) ( -SNV CSV ) ( -SNQ CSQ )\n\ *\n\ * Z' denotes the transpose of Z.\n\ *\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPPER (input) LOGICAL\n\ * = .TRUE.: the input matrices A and B are upper triangular.\n\ * = .FALSE.: the input matrices A and B are lower triangular.\n\ *\n\ * A1 (input) REAL\n\ * A2 (input) REAL\n\ * A3 (input) REAL\n\ * On entry, A1, A2 and A3 are elements of the input 2-by-2\n\ * upper (lower) triangular matrix A.\n\ *\n\ * B1 (input) REAL\n\ * B2 (input) REAL\n\ * B3 (input) REAL\n\ * On entry, B1, B2 and B3 are elements of the input 2-by-2\n\ * upper (lower) triangular matrix B.\n\ *\n\ * CSU (output) REAL\n\ * SNU (output) REAL\n\ * The desired orthogonal matrix U.\n\ *\n\ * CSV (output) REAL\n\ * SNV (output) REAL\n\ * The desired orthogonal matrix V.\n\ *\n\ * CSQ (output) REAL\n\ * SNQ (output) REAL\n\ * The desired orthogonal matrix Q.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zpbsvx0000644000175000017500000002765412502223526016562 0ustar uwabamiuwabami--- :name: zpbsvx :md5sum: 10461d4ad60f29592cf9eca8262b0e6a :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublecomplex :intent: input/output :dims: - ldafb - n - ldafb: :type: integer :intent: input - equed: :type: char :intent: input/output - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE ZPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPBSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to\n\ * compute the solution to a complex system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N Hermitian positive definite band matrix and X\n\ * and B are N-by-NRHS matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', real scaling factors are computed to equilibrate\n\ * the system:\n\ * diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n\ *\n\ * 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n\ * factor the matrix A (after equilibration if FACT = 'E') as\n\ * A = U**H * U, if UPLO = 'U', or\n\ * A = L * L**H, if UPLO = 'L',\n\ * where U is an upper triangular band matrix, and L is a lower\n\ * triangular band matrix.\n\ *\n\ * 3. If the leading i-by-i principal minor is not positive definite,\n\ * then the routine returns with INFO = i. Otherwise, the factored\n\ * form of A is used to estimate the condition number of the matrix\n\ * A. If the reciprocal of the condition number is less than machine\n\ * precision, INFO = N+1 is returned as a warning, but the routine\n\ * still goes on to solve for X and compute error bounds as\n\ * described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(S) so that it solves the original system before\n\ * equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AFB contains the factored form of A.\n\ * If EQUED = 'Y', the matrix A has been equilibrated\n\ * with scaling factors given by S. AB and AFB will not\n\ * be modified.\n\ * = 'N': The matrix A will be copied to AFB and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AFB and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right-hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix A, stored in the first KD+1 rows of the array, except\n\ * if FACT = 'F' and EQUED = 'Y', then A must contain the\n\ * equilibrated matrix diag(S)*A*diag(S). The j-th column of A\n\ * is stored in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).\n\ * See below for further details.\n\ *\n\ * On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n\ * diag(S)*A*diag(S).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array A. LDAB >= KD+1.\n\ *\n\ * AFB (input or output) COMPLEX*16 array, dimension (LDAFB,N)\n\ * If FACT = 'F', then AFB is an input argument and on entry\n\ * contains the triangular factor U or L from the Cholesky\n\ * factorization A = U**H*U or A = L*L**H of the band matrix\n\ * A, in the same storage format as A (see AB). If EQUED = 'Y',\n\ * then AFB is the factored form of the equilibrated matrix A.\n\ *\n\ * If FACT = 'N', then AFB is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U**H*U or A = L*L**H.\n\ *\n\ * If FACT = 'E', then AFB is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U**H*U or A = L*L**H of the equilibrated\n\ * matrix A (see the description of A for the form of the\n\ * equilibrated matrix).\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= KD+1.\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'Y': Equilibration was done, i.e., A has been replaced by\n\ * diag(S) * A * diag(S).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * S (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The scale factors for A; not accessed if EQUED = 'N'. S is\n\ * an input argument if FACT = 'F'; otherwise, S is an output\n\ * argument. If FACT = 'F' and EQUED = 'Y', each element of S\n\ * must be positive.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n\ * B is overwritten by diag(S) * B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n\ * the original system of equations. Note that if EQUED = 'Y',\n\ * A and B are modified on exit, and the solution to the\n\ * equilibrated system is inv(diag(S))*X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A after equilibration (if done). If RCOND is less than the\n\ * machine precision (in particular, if RCOND = 0), the matrix\n\ * is singular to working precision. This condition is\n\ * indicated by a return code of INFO > 0.\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\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, and i is\n\ * <= N: the leading minor of order i of A is\n\ * not positive definite, so the factorization\n\ * could not be completed, and the solution has not\n\ * been computed. RCOND = 0 is returned.\n\ * = N+1: U is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * N = 6, KD = 2, and UPLO = 'U':\n\ *\n\ * Two-dimensional storage of the Hermitian matrix A:\n\ *\n\ * a11 a12 a13\n\ * a22 a23 a24\n\ * a33 a34 a35\n\ * a44 a45 a46\n\ * a55 a56\n\ * (aij=conjg(aji)) a66\n\ *\n\ * Band storage of the upper triangle of A:\n\ *\n\ * * * a13 a24 a35 a46\n\ * * a12 a23 a34 a45 a56\n\ * a11 a22 a33 a44 a55 a66\n\ *\n\ * Similarly, if UPLO = 'L' the format of A is as follows:\n\ *\n\ * a11 a22 a33 a44 a55 a66\n\ * a21 a32 a43 a54 a65 *\n\ * a31 a42 a53 a64 * *\n\ *\n\ * Array elements marked * are not used by the routine.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlae20000644000175000017500000000363012502223526016201 0ustar uwabamiuwabami--- :name: dlae2 :md5sum: 6634a79d68e158282cf44e0eded12a8d :category: :subroutine :arguments: - a: :type: doublereal :intent: input - b: :type: doublereal :intent: input - c: :type: doublereal :intent: input - rt1: :type: doublereal :intent: output - rt2: :type: doublereal :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLAE2( A, B, C, RT1, RT2 )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix\n\ * [ A B ]\n\ * [ B C ].\n\ * On return, RT1 is the eigenvalue of larger absolute value, and RT2\n\ * is the eigenvalue of smaller absolute value.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * A (input) DOUBLE PRECISION\n\ * The (1,1) element of the 2-by-2 matrix.\n\ *\n\ * B (input) DOUBLE PRECISION\n\ * The (1,2) and (2,1) elements of the 2-by-2 matrix.\n\ *\n\ * C (input) DOUBLE PRECISION\n\ * The (2,2) element of the 2-by-2 matrix.\n\ *\n\ * RT1 (output) DOUBLE PRECISION\n\ * The eigenvalue of larger absolute value.\n\ *\n\ * RT2 (output) DOUBLE PRECISION\n\ * The eigenvalue of smaller absolute value.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * RT1 is accurate to a few ulps barring over/underflow.\n\ *\n\ * RT2 may be inaccurate if there is massive cancellation in the\n\ * determinant A*C-B*B; higher precision or correctly rounded or\n\ * correctly truncated arithmetic would be needed to compute RT2\n\ * accurately in all cases.\n\ *\n\ * Overflow is possible only if RT1 is within a factor of 5 of overflow.\n\ * Underflow is harmless if the input data is 0 or exceeds\n\ * underflow_threshold / macheps.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slasq60000644000175000017500000000432712502223526016427 0ustar uwabamiuwabami--- :name: slasq6 :md5sum: 04d0e31a5d0435c67ed105bcbe82323f :category: :subroutine :arguments: - i0: :type: integer :intent: input - n0: :type: integer :intent: input - z: :type: real :intent: input :dims: - 4*n0 - pp: :type: integer :intent: input - dmin: :type: real :intent: output - dmin1: :type: real :intent: output - dmin2: :type: real :intent: output - dn: :type: real :intent: output - dnm1: :type: real :intent: output - dnm2: :type: real :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DNM1, DNM2 )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLASQ6 computes one dqd (shift equal to zero) transform in\n\ * ping-pong form, with protection against underflow and overflow.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * I0 (input) INTEGER\n\ * First index.\n\ *\n\ * N0 (input) INTEGER\n\ * Last index.\n\ *\n\ * Z (input) REAL array, dimension ( 4*N )\n\ * Z holds the qd array. EMIN is stored in Z(4*N0) to avoid\n\ * an extra argument.\n\ *\n\ * PP (input) INTEGER\n\ * PP=0 for ping, PP=1 for pong.\n\ *\n\ * DMIN (output) REAL\n\ * Minimum value of d.\n\ *\n\ * DMIN1 (output) REAL\n\ * Minimum value of d, excluding D( N0 ).\n\ *\n\ * DMIN2 (output) REAL\n\ * Minimum value of d, excluding D( N0 ) and D( N0-1 ).\n\ *\n\ * DN (output) REAL\n\ * d(N0), the last value of d.\n\ *\n\ * DNM1 (output) REAL\n\ * d(N0-1).\n\ *\n\ * DNM2 (output) REAL\n\ * d(N0-2).\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Parameter ..\n REAL ZERO\n PARAMETER ( ZERO = 0.0E0 )\n\ * ..\n\ * .. Local Scalars ..\n INTEGER J4, J4P2\n REAL D, EMIN, SAFMIN, TEMP\n\ * ..\n\ * .. External Function ..\n REAL SLAMCH\n EXTERNAL SLAMCH\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sgeqp30000644000175000017500000000733712502223526016424 0ustar uwabamiuwabami--- :name: sgeqp3 :md5sum: d403640a3535834978e177dfacbf62cd :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: real :intent: output :dims: - MIN(m,n) - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 3*n+1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGEQP3 computes a QR factorization with column pivoting of a\n\ * matrix A: A*P = Q*R using Level 3 BLAS.\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) REAL array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, the upper triangle of the array contains the\n\ * min(M,N)-by-N upper trapezoidal matrix R; the elements below\n\ * the diagonal, together with the array TAU, represent the\n\ * orthogonal matrix Q as a product of min(M,N) elementary\n\ * reflectors.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * JPVT (input/output) INTEGER array, dimension (N)\n\ * On entry, if JPVT(J).ne.0, the J-th column of A is permuted\n\ * to the front of A*P (a leading column); if JPVT(J)=0,\n\ * the J-th column of A is a free column.\n\ * On exit, if JPVT(J)=K, then the J-th column of A*P was the\n\ * the K-th column of A.\n\ *\n\ * TAU (output) REAL array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors.\n\ *\n\ * WORK (workspace/output) REAL 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 >= 3*N+1.\n\ * For optimal performance LWORK >= 2*N+( N+1 )*NB, where NB\n\ * is the 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(1) H(2) . . . H(k), 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/complex scalar, and v is a real/complex vector\n\ * with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in\n\ * A(i+1:m,i), and tau in TAU(i).\n\ *\n\ * Based on contributions by\n\ * G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n\ * X. Sun, Computer Science Dept., Duke University, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dla_syrcond0000644000175000017500000000761612502223526017523 0ustar uwabamiuwabami--- :name: dla_syrcond :md5sum: 8136e050755bb66761ca2f199b0b2e84 :category: :function :type: doublereal :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - cmode: :type: integer :intent: input - c: :type: doublereal :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: doublereal :intent: input :dims: - 3*n - iwork: :type: integer :intent: input :dims: - n :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION DLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, IPIV, CMODE, C, INFO, WORK, IWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLA_SYRCOND estimates the Skeel condition number of op(A) * op2(C)\n\ * where op2 is determined by CMODE as follows\n\ * CMODE = 1 op2(C) = C\n\ * CMODE = 0 op2(C) = I\n\ * CMODE = -1 op2(C) = inv(C)\n\ * The Skeel condition number cond(A) = norminf( |inv(A)||A| )\n\ * is computed by computing scaling factors R such that\n\ * diag(R)*A*op2(C) is row equilibrated and computing the standard\n\ * infinity-norm condition number.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by DSYTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by DSYTRF.\n\ *\n\ * CMODE (input) INTEGER\n\ * Determines op2(C) in the formula op(A) * op2(C) as follows:\n\ * CMODE = 1 op2(C) = C\n\ * CMODE = 0 op2(C) = I\n\ * CMODE = -1 op2(C) = inv(C)\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension (N)\n\ * The vector C in the formula op(A) * op2(C).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * i > 0: The ith argument is invalid.\n\ *\n\ * WORK (input) DOUBLE PRECISION array, dimension (3*N).\n\ * Workspace.\n\ *\n\ * IWORK (input) INTEGER array, dimension (N).\n\ * Workspace.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n CHARACTER NORMIN\n INTEGER KASE, I, J\n DOUBLE PRECISION AINVNM, SMLNUM, TMP\n LOGICAL UP\n\ * ..\n\ * .. Local Arrays ..\n INTEGER ISAVE( 3 )\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER IDAMAX\n DOUBLE PRECISION DLAMCH\n EXTERNAL LSAME, IDAMAX, DLAMCH\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DLACN2, DLATRS, DRSCL, XERBLA, DSYTRS\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sgesc20000644000175000017500000000446612502223526016410 0ustar uwabamiuwabami--- :name: sgesc2 :md5sum: a1d942fb0e32d88b83645ceab007aaaa :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - rhs: :type: real :intent: input/output :dims: - n - ipiv: :type: integer :intent: input :dims: - n - jpiv: :type: integer :intent: input :dims: - n - scale: :type: real :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGESC2 solves a system of linear equations\n\ *\n\ * A * X = scale* RHS\n\ *\n\ * with a general N-by-N matrix A using the LU factorization with\n\ * complete pivoting computed by SGETC2.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * On entry, the LU part of the factorization of the n-by-n\n\ * matrix A computed by SGETC2: A = P * L * U * Q\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1, N).\n\ *\n\ * RHS (input/output) REAL array, dimension (N).\n\ * On entry, the right hand side vector b.\n\ * On exit, the solution vector X.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N).\n\ * The pivot indices; for 1 <= i <= N, row i of the\n\ * matrix has been interchanged with row IPIV(i).\n\ *\n\ * JPIV (input) INTEGER array, dimension (N).\n\ * The pivot indices; for 1 <= j <= N, column j of the\n\ * matrix has been interchanged with column JPIV(j).\n\ *\n\ * SCALE (output) REAL\n\ * On exit, SCALE contains the scale factor. SCALE is chosen\n\ * 0 <= SCALE <= 1 to prevent owerflow in the solution.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgtcon0000644000175000017500000000654412502223526016516 0ustar uwabamiuwabami--- :name: sgtcon :md5sum: 1e88f60a1e7dead4af7e4f638ef858ac :category: :subroutine :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - dl: :type: real :intent: input :dims: - n-1 - d: :type: real :intent: input :dims: - n - du: :type: real :intent: input :dims: - n-1 - du2: :type: real :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 2*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGTCON estimates the reciprocal of the condition number of a real\n\ * tridiagonal matrix A using the LU factorization as computed by\n\ * SGTTRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies whether the 1-norm condition number or the\n\ * infinity-norm condition number is required:\n\ * = '1' or 'O': 1-norm;\n\ * = 'I': Infinity-norm.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * DL (input) REAL array, dimension (N-1)\n\ * The (n-1) multipliers that define the matrix L from the\n\ * LU factorization of A as computed by SGTTRF.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The n diagonal elements of the upper triangular matrix U from\n\ * the LU factorization of A.\n\ *\n\ * DU (input) REAL array, dimension (N-1)\n\ * The (n-1) elements of the first superdiagonal of U.\n\ *\n\ * DU2 (input) REAL array, dimension (N-2)\n\ * The (n-2) elements of the second superdiagonal of U.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices; for 1 <= i <= n, row i of the matrix was\n\ * interchanged with row IPIV(i). IPIV(i) will always be either\n\ * i or i+1; IPIV(i) = i indicates a row interchange was not\n\ * required.\n\ *\n\ * ANORM (input) REAL\n\ * If NORM = '1' or 'O', the 1-norm of the original matrix A.\n\ * If NORM = 'I', the infinity-norm of the original matrix A.\n\ *\n\ * RCOND (output) REAL\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n\ * estimate of the 1-norm of inv(A) computed in this routine.\n\ *\n\ * WORK (workspace) REAL array, dimension (2*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgghrd0000644000175000017500000001344312502223525016452 0ustar uwabamiuwabami--- :name: cgghrd :md5sum: 62029756327bc968ec07529087b0e19a :category: :subroutine :arguments: - compq: :type: char :intent: input - compz: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - q: :type: complex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - z: :type: complex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGGHRD reduces a pair of complex matrices (A,B) to generalized upper\n\ * Hessenberg form using unitary transformations, where A is a\n\ * general matrix and B is upper triangular. The form of the generalized\n\ * eigenvalue problem is\n\ * A*x = lambda*B*x,\n\ * and B is typically made upper triangular by computing its QR\n\ * factorization and moving the unitary matrix Q to the left side\n\ * of the equation.\n\ *\n\ * This subroutine simultaneously reduces A to a Hessenberg matrix H:\n\ * Q**H*A*Z = H\n\ * and transforms B to another upper triangular matrix T:\n\ * Q**H*B*Z = T\n\ * in order to reduce the problem to its standard form\n\ * H*y = lambda*T*y\n\ * where y = Z**H*x.\n\ *\n\ * The unitary matrices Q and Z are determined as products of Givens\n\ * rotations. They may either be formed explicitly, or they may be\n\ * postmultiplied into input matrices Q1 and Z1, so that\n\ * Q1 * A * Z1**H = (Q1*Q) * H * (Z1*Z)**H\n\ * Q1 * B * Z1**H = (Q1*Q) * T * (Z1*Z)**H\n\ * If Q1 is the unitary matrix from the QR factorization of B in the\n\ * original equation A*x = lambda*B*x, then CGGHRD reduces the original\n\ * problem to generalized Hessenberg form.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * COMPQ (input) CHARACTER*1\n\ * = 'N': do not compute Q;\n\ * = 'I': Q is initialized to the unit matrix, and the\n\ * unitary matrix Q is returned;\n\ * = 'V': Q must contain a unitary matrix Q1 on entry,\n\ * and the product Q1*Q is returned.\n\ *\n\ * COMPZ (input) CHARACTER*1\n\ * = 'N': do not compute Q;\n\ * = 'I': Q is initialized to the unit matrix, and the\n\ * unitary matrix Q is returned;\n\ * = 'V': Q must contain a unitary matrix Q1 on entry,\n\ * and the product Q1*Q is returned.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * ILO and IHI mark the rows and columns of A which are to be\n\ * reduced. It is assumed that A is already upper triangular\n\ * in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are\n\ * normally set by a previous call to CGGBAL; otherwise they\n\ * should be set to 1 and N respectively.\n\ * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA, N)\n\ * On entry, the N-by-N general matrix to be reduced.\n\ * On exit, the upper triangle and the first subdiagonal of A\n\ * are overwritten with the upper Hessenberg matrix H, and the\n\ * rest is set to zero.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB, N)\n\ * On entry, the N-by-N upper triangular matrix B.\n\ * On exit, the upper triangular matrix T = Q**H B Z. The\n\ * elements below the diagonal are set to zero.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * Q (input/output) COMPLEX array, dimension (LDQ, N)\n\ * On entry, if COMPQ = 'V', the unitary matrix Q1, typically\n\ * from the QR factorization of B.\n\ * On exit, if COMPQ='I', the unitary matrix Q, and if\n\ * COMPQ = 'V', the product Q1*Q.\n\ * Not referenced if COMPQ='N'.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q.\n\ * LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.\n\ *\n\ * Z (input/output) COMPLEX array, dimension (LDZ, N)\n\ * On entry, if COMPZ = 'V', the unitary matrix Z1.\n\ * On exit, if COMPZ='I', the unitary matrix Z, and if\n\ * COMPZ = 'V', the product Z1*Z.\n\ * Not referenced if COMPZ='N'.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z.\n\ * LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.\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\ * This routine reduces A to Hessenberg and B to triangular form by\n\ * an unblocked reduction, as described in _Matrix_Computations_,\n\ * by Golub and van Loan (Johns Hopkins Press).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlagtf0000644000175000017500000001074012502223526016453 0ustar uwabamiuwabami--- :name: dlagtf :md5sum: 3a0ef4d4c7ee1d1045339e13d37e6877 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - n - lambda: :type: doublereal :intent: input - b: :type: doublereal :intent: input/output :dims: - n-1 - c: :type: doublereal :intent: input/output :dims: - n-1 - tol: :type: doublereal :intent: input - d: :type: doublereal :intent: output :dims: - n-2 - in: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAGTF factorizes the matrix (T - lambda*I), where T is an n by n\n\ * tridiagonal matrix and lambda is a scalar, as\n\ *\n\ * T - lambda*I = PLU,\n\ *\n\ * where P is a permutation matrix, L is a unit lower tridiagonal matrix\n\ * with at most one non-zero sub-diagonal elements per column and U is\n\ * an upper triangular matrix with at most two non-zero super-diagonal\n\ * elements per column.\n\ *\n\ * The factorization is obtained by Gaussian elimination with partial\n\ * pivoting and implicit row scaling.\n\ *\n\ * The parameter LAMBDA is included in the routine so that DLAGTF may\n\ * be used, in conjunction with DLAGTS, to obtain eigenvectors of T by\n\ * inverse iteration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix T.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, A must contain the diagonal elements of T.\n\ *\n\ * On exit, A is overwritten by the n diagonal elements of the\n\ * upper triangular matrix U of the factorization of T.\n\ *\n\ * LAMBDA (input) DOUBLE PRECISION\n\ * On entry, the scalar lambda.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (N-1)\n\ * On entry, B must contain the (n-1) super-diagonal elements of\n\ * T.\n\ *\n\ * On exit, B is overwritten by the (n-1) super-diagonal\n\ * elements of the matrix U of the factorization of T.\n\ *\n\ * C (input/output) DOUBLE PRECISION array, dimension (N-1)\n\ * On entry, C must contain the (n-1) sub-diagonal elements of\n\ * T.\n\ *\n\ * On exit, C is overwritten by the (n-1) sub-diagonal elements\n\ * of the matrix L of the factorization of T.\n\ *\n\ * TOL (input) DOUBLE PRECISION\n\ * On entry, a relative tolerance used to indicate whether or\n\ * not the matrix (T - lambda*I) is nearly singular. TOL should\n\ * normally be chose as approximately the largest relative error\n\ * in the elements of T. For example, if the elements of T are\n\ * correct to about 4 significant figures, then TOL should be\n\ * set to about 5*10**(-4). If TOL is supplied as less than eps,\n\ * where eps is the relative machine precision, then the value\n\ * eps is used in place of TOL.\n\ *\n\ * D (output) DOUBLE PRECISION array, dimension (N-2)\n\ * On exit, D is overwritten by the (n-2) second super-diagonal\n\ * elements of the matrix U of the factorization of T.\n\ *\n\ * IN (output) INTEGER array, dimension (N)\n\ * On exit, IN contains details of the permutation matrix P. If\n\ * an interchange occurred at the kth step of the elimination,\n\ * then IN(k) = 1, otherwise IN(k) = 0. The element IN(n)\n\ * returns the smallest positive integer j such that\n\ *\n\ * abs( u(j,j) ).le. norm( (T - lambda*I)(j) )*TOL,\n\ *\n\ * where norm( A(j) ) denotes the sum of the absolute values of\n\ * the jth row of the matrix A. If no such j exists then IN(n)\n\ * is returned as zero. If IN(n) is returned as positive, then a\n\ * diagonal element of U is small, indicating that\n\ * (T - lambda*I) is singular or nearly singular,\n\ *\n\ * INFO (output) INTEGER\n\ * = 0 : successful exit\n\ * .lt. 0: if INFO = -k, the kth argument had an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsyrfs0000644000175000017500000001231612502223526016525 0ustar uwabamiuwabami--- :name: dsyrfs :md5sum: 85f1c6f5556ee003f037a35fc4ac4b07 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSYRFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is symmetric indefinite, and\n\ * provides error bounds and backward error estimates for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular part\n\ * of the matrix A, and the strictly lower triangular part of A\n\ * is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of A contains the lower triangular part of\n\ * the matrix A, and the strictly upper triangular part of A is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n\ * The factored form of the matrix A. AF contains the block\n\ * diagonal matrix D and the multipliers used to obtain the\n\ * factor U or L from the factorization A = U*D*U**T or\n\ * A = L*D*L**T as computed by DSYTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by DSYTRF.\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by DSYTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clapll0000644000175000017500000000355112502223525016462 0ustar uwabamiuwabami--- :name: clapll :md5sum: bc1696c79251fc14dc4c23739749cff4 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - y: :type: complex :intent: input/output :dims: - 1+(n-1)*incy - incy: :type: integer :intent: input - ssmin: :type: real :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CLAPLL( N, X, INCX, Y, INCY, SSMIN )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Given two column vectors X and Y, let\n\ *\n\ * A = ( X Y ).\n\ *\n\ * The subroutine first computes the QR factorization of A = Q*R,\n\ * and then computes the SVD of the 2-by-2 upper triangular matrix R.\n\ * The smaller singular value of R is returned in SSMIN, which is used\n\ * as the measurement of the linear dependency of the vectors X and Y.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The length of the vectors X and Y.\n\ *\n\ * X (input/output) COMPLEX array, dimension (1+(N-1)*INCX)\n\ * On entry, X contains the N-vector X.\n\ * On exit, X is overwritten.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between successive elements of X. INCX > 0.\n\ *\n\ * Y (input/output) COMPLEX array, dimension (1+(N-1)*INCY)\n\ * On entry, Y contains the N-vector Y.\n\ * On exit, Y is overwritten.\n\ *\n\ * INCY (input) INTEGER\n\ * The increment between successive elements of Y. INCY > 0.\n\ *\n\ * SSMIN (output) REAL\n\ * The smallest singular value of the N-by-2 matrix A = ( X Y ).\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlarzt0000644000175000017500000001231512502223526016512 0ustar uwabamiuwabami--- :name: dlarzt :md5sum: 794da30b757b5da1ded2c6c9124f7150 :category: :subroutine :arguments: - direct: :type: char :intent: input - storev: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - v: :type: doublereal :intent: input/output :dims: - ldv - "lsame_(&storev,\"C\") ? k : lsame_(&storev,\"R\") ? n : 0" - ldv: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - t: :type: doublereal :intent: output :dims: - ldt - k - ldt: :type: integer :intent: input :substitutions: ldt: k :fortran_help: " SUBROUTINE DLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLARZT forms the triangular factor T of a real block reflector\n\ * H of order > n, which is defined as a product of k elementary\n\ * reflectors.\n\ *\n\ * If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n\ *\n\ * If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n\ *\n\ * If STOREV = 'C', the vector which defines the elementary reflector\n\ * H(i) is stored in the i-th column of the array V, and\n\ *\n\ * H = I - V * T * V'\n\ *\n\ * If STOREV = 'R', the vector which defines the elementary reflector\n\ * H(i) is stored in the i-th row of the array V, and\n\ *\n\ * H = I - V' * T * V\n\ *\n\ * Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * DIRECT (input) CHARACTER*1\n\ * Specifies the order in which the elementary reflectors are\n\ * multiplied to form the block reflector:\n\ * = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n\ * = 'B': H = H(k) . . . H(2) H(1) (Backward)\n\ *\n\ * STOREV (input) CHARACTER*1\n\ * Specifies how the vectors which define the elementary\n\ * reflectors are stored (see also Further Details):\n\ * = 'C': columnwise (not supported yet)\n\ * = 'R': rowwise\n\ *\n\ * N (input) INTEGER\n\ * The order of the block reflector H. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The order of the triangular factor T (= the number of\n\ * elementary reflectors). K >= 1.\n\ *\n\ * V (input/output) DOUBLE PRECISION array, dimension\n\ * (LDV,K) if STOREV = 'C'\n\ * (LDV,N) if STOREV = 'R'\n\ * The matrix V. See further details.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V.\n\ * If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n\ *\n\ * TAU (input) DOUBLE PRECISION array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i).\n\ *\n\ * T (output) DOUBLE PRECISION array, dimension (LDT,K)\n\ * The k by k triangular factor T of the block reflector.\n\ * If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n\ * lower triangular. The rest of the array is not used.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= K.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * The shape of the matrix V and the storage of the vectors which define\n\ * the H(i) is best illustrated by the following example with n = 5 and\n\ * k = 3. The elements equal to 1 are not stored; the corresponding\n\ * array elements are modified but restored on exit. The rest of the\n\ * array is not used.\n\ *\n\ * DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':\n\ *\n\ * ______V_____\n\ * ( v1 v2 v3 ) / \\\n\ * ( v1 v2 v3 ) ( v1 v1 v1 v1 v1 . . . . 1 )\n\ * V = ( v1 v2 v3 ) ( v2 v2 v2 v2 v2 . . . 1 )\n\ * ( v1 v2 v3 ) ( v3 v3 v3 v3 v3 . . 1 )\n\ * ( v1 v2 v3 )\n\ * . . .\n\ * . . .\n\ * 1 . .\n\ * 1 .\n\ * 1\n\ *\n\ * DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':\n\ *\n\ * ______V_____\n\ * 1 / \\\n\ * . 1 ( 1 . . . . v1 v1 v1 v1 v1 )\n\ * . . 1 ( . 1 . . . v2 v2 v2 v2 v2 )\n\ * . . . ( . . 1 . . v3 v3 v3 v3 v3 )\n\ * . . .\n\ * ( v1 v2 v3 )\n\ * ( v1 v2 v3 )\n\ * V = ( v1 v2 v3 )\n\ * ( v1 v2 v3 )\n\ * ( v1 v2 v3 )\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/csysv0000644000175000017500000001274212502223525016364 0ustar uwabamiuwabami--- :name: csysv :md5sum: eb3a9b2a1e9a499c6394d402697b0f15 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSYSV computes the solution to a complex system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n\ * matrices.\n\ *\n\ * The diagonal pivoting method is used to factor A as\n\ * A = U * D * U**T, if UPLO = 'U', or\n\ * A = L * D * L**T, if UPLO = 'L',\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, and D is symmetric and block diagonal with \n\ * 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then\n\ * used to solve the system of equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the block diagonal matrix D and the\n\ * multipliers used to obtain the factor U or L from the\n\ * factorization A = U*D*U**T or A = L*D*L**T as computed by\n\ * CSYTRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D, as\n\ * determined by CSYTRF. If IPIV(k) > 0, then rows and columns\n\ * k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n\ * diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n\ * then rows and columns k-1 and -IPIV(k) were interchanged and\n\ * D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n\ * IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n\ * -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n\ * diagonal block.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of WORK. LWORK >= 1, and for best performance\n\ * LWORK >= max(1,N*NB), where NB is the optimal blocksize for\n\ * CSYTRF.\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, D(i,i) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular, so the solution could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LWKOPT, NB\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL ILAENV, LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CSYTRF, CSYTRS2, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sgbtrs0000644000175000017500000000576212502223526016526 0ustar uwabamiuwabami--- :name: sgbtrs :md5sum: 67897804c7f0b5c5cc0d53f7458b2608 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGBTRS solves a system of linear equations\n\ * A * X = B or A' * X = B\n\ * with a general band matrix A using the LU factorization computed\n\ * by SGBTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations.\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A'* X = B (Transpose)\n\ * = 'C': A'* X = B (Conjugate transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AB (input) REAL array, dimension (LDAB,N)\n\ * Details of the LU factorization of the band matrix A, as\n\ * computed by SGBTRF. U is stored as an upper triangular band\n\ * matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n\ * the multipliers used during the factorization are stored in\n\ * rows KL+KU+2 to 2*KL+KU+1.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices; for 1 <= i <= N, row i of the matrix was\n\ * interchanged with row IPIV(i).\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgesvxx0000644000175000017500000005476412502223525016716 0ustar uwabamiuwabami--- :name: cgesvxx :md5sum: f33bd5ec25f783a870ac91682bc5f189 :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - equed: :type: char :intent: input/output - r: :type: real :intent: input/output :dims: - n - c: :type: real :intent: input/output :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - rpvgrw: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldx: n n_err_bnds: "3" :fortran_help: " SUBROUTINE CGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGESVXX uses the LU factorization to compute the solution to a\n\ * complex system of linear equations A * X = B, where A is an\n\ * N-by-N matrix and X and B are N-by-NRHS matrices.\n\ *\n\ * If requested, both normwise and maximum componentwise error bounds\n\ * are returned. CGESVXX will return a solution with a tiny\n\ * guaranteed error (O(eps) where eps is the working machine\n\ * precision) unless the matrix is very ill-conditioned, in which\n\ * case a warning is returned. Relevant condition numbers also are\n\ * calculated and returned.\n\ *\n\ * CGESVXX accepts user-provided factorizations and equilibration\n\ * factors; see the definitions of the FACT and EQUED options.\n\ * Solving with refinement and using a factorization from a previous\n\ * CGESVXX call will also produce a solution with either O(eps)\n\ * errors or warnings, but we cannot make that claim for general\n\ * user-provided factorizations and equilibration factors if they\n\ * differ from what CGESVXX would itself produce.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', real scaling factors are computed to equilibrate\n\ * the system:\n\ *\n\ * TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n\ * TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n\ * TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n\ *\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n\ * or diag(C)*B (if TRANS = 'T' or 'C').\n\ *\n\ * 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n\ * the matrix A (after equilibration if FACT = 'E') as\n\ *\n\ * A = P * L * U,\n\ *\n\ * where P is a permutation matrix, L is a unit lower triangular\n\ * matrix, and U is upper triangular.\n\ *\n\ * 3. If some U(i,i)=0, so that U is exactly singular, then the\n\ * routine returns with INFO = i. Otherwise, the factored form of A\n\ * is used to estimate the condition number of the matrix A (see\n\ * argument RCOND). If the reciprocal of the condition number is less\n\ * than machine precision, the routine still goes on to solve for X\n\ * and compute error bounds as described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n\ * the routine will use iterative refinement to try to get a small\n\ * error and error bounds. Refinement calculates the residual to at\n\ * least twice the working precision.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n\ * that it solves the original system before equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AF and IPIV contain the factored form of A.\n\ * If EQUED is not 'N', the matrix A has been\n\ * equilibrated with scaling factors given by R and C.\n\ * A, AF, and IPIV are not modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AF and factored.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is\n\ * not 'N', then A must have been equilibrated by the scaling\n\ * factors in R and/or C. A is not modified if FACT = 'F' or\n\ * 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n\ *\n\ * On exit, if EQUED .ne. 'N', A is scaled as follows:\n\ * EQUED = 'R': A := diag(R) * A\n\ * EQUED = 'C': A := A * diag(C)\n\ * EQUED = 'B': A := diag(R) * A * diag(C).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input or output) COMPLEX array, dimension (LDAF,N)\n\ * If FACT = 'F', then AF is an input argument and on entry\n\ * contains the factors L and U from the factorization\n\ * A = P*L*U as computed by CGETRF. If EQUED .ne. 'N', then\n\ * AF is the factored form of the equilibrated matrix A.\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the factors L and U from the factorization A = P*L*U\n\ * of the original matrix A.\n\ *\n\ * If FACT = 'E', then AF is an output argument and on exit\n\ * returns the factors L and U from the factorization A = P*L*U\n\ * of the equilibrated matrix A (see the description of A for\n\ * the form of the equilibrated matrix).\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * as computed by CGETRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * of the original matrix A.\n\ *\n\ * If FACT = 'E', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * of the equilibrated matrix A.\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * R (input or output) REAL array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'R' or 'B', A is\n\ * multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n\ * is not accessed. R is an input argument if FACT = 'F';\n\ * otherwise, R is an output argument. If FACT = 'F' and\n\ * EQUED = 'R' or 'B', each element of R must be positive.\n\ * If R is output, each element of R is a power of the radix.\n\ * If R is input, each element of R should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * C (input or output) REAL array, dimension (N)\n\ * The column scale factors for A. If EQUED = 'C' or 'B', A is\n\ * multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n\ * is not accessed. C is an input argument if FACT = 'F';\n\ * otherwise, C is an output argument. If FACT = 'F' and\n\ * EQUED = 'C' or 'B', each element of C must be positive.\n\ * If C is output, each element of C is a power of the radix.\n\ * If C is input, each element of C should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit,\n\ * if EQUED = 'N', B is not modified;\n\ * if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n\ * diag(R)*B;\n\ * if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n\ * overwritten by diag(C)*B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX array, dimension (LDX,NRHS)\n\ * If INFO = 0, the N-by-NRHS solution matrix X to the original\n\ * system of equations. Note that A and B are modified on exit\n\ * if EQUED .ne. 'N', and the solution to the equilibrated system is\n\ * inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n\ * inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * RPVGRW (output) REAL\n\ * Reciprocal pivot growth. On exit, this contains the reciprocal\n\ * pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n\ * norm is used. If this is much less than 1, then the stability of\n\ * the LU factorization of the (equilibrated) matrix A could be poor.\n\ * This also means that the solution X, estimated condition numbers,\n\ * and error bounds could be unreliable. If factorization fails with\n\ * 0 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgttrf0000644000175000017500000000604012502223526016521 0ustar uwabamiuwabami--- :name: sgttrf :md5sum: 4e9324d553ecb9fda65af78de9d470e8 :category: :subroutine :arguments: - n: :type: integer :intent: input - dl: :type: real :intent: input/output :dims: - n-1 - d: :type: real :intent: input/output :dims: - n - du: :type: real :intent: input/output :dims: - n-1 - du2: :type: real :intent: output :dims: - n-2 - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGTTRF( N, DL, D, DU, DU2, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGTTRF computes an LU factorization of a real tridiagonal matrix A\n\ * using elimination with partial pivoting and row interchanges.\n\ *\n\ * The factorization has the form\n\ * A = L * U\n\ * where L is a product of permutation and unit lower bidiagonal\n\ * matrices and U is upper triangular with nonzeros in only the main\n\ * diagonal and first two superdiagonals.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A.\n\ *\n\ * DL (input/output) REAL array, dimension (N-1)\n\ * On entry, DL must contain the (n-1) sub-diagonal elements of\n\ * A.\n\ *\n\ * On exit, DL is overwritten by the (n-1) multipliers that\n\ * define the matrix L from the LU factorization of A.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, D must contain the diagonal elements of A.\n\ *\n\ * On exit, D is overwritten by the n diagonal elements of the\n\ * upper triangular matrix U from the LU factorization of A.\n\ *\n\ * DU (input/output) REAL array, dimension (N-1)\n\ * On entry, DU must contain the (n-1) super-diagonal elements\n\ * of A.\n\ *\n\ * On exit, DU is overwritten by the (n-1) elements of the first\n\ * super-diagonal of U.\n\ *\n\ * DU2 (output) REAL array, dimension (N-2)\n\ * On exit, DU2 is overwritten by the (n-2) elements of the\n\ * second super-diagonal of U.\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * The pivot indices; for 1 <= i <= n, row i of the matrix was\n\ * interchanged with row IPIV(i). IPIV(i) will always be either\n\ * i or i+1; IPIV(i) = i indicates a row interchange was not\n\ * required.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ * > 0: if INFO = k, U(k,k) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, and division by zero will occur if it is used\n\ * to solve a system of equations.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/classq0000644000175000017500000000415512502223525016502 0ustar uwabamiuwabami--- :name: classq :md5sum: 98b03e0f8741f340e1c75a898eb65b7e :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: complex :intent: input :dims: - n - incx: :type: integer :intent: input - scale: :type: real :intent: input/output - sumsq: :type: real :intent: input/output :substitutions: {} :fortran_help: " SUBROUTINE CLASSQ( N, X, INCX, SCALE, SUMSQ )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLASSQ returns the values scl and ssq such that\n\ *\n\ * ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,\n\ *\n\ * where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is\n\ * assumed to be at least unity and the value of ssq will then satisfy\n\ *\n\ * 1.0 .le. ssq .le. ( sumsq + 2*n ).\n\ *\n\ * scale is assumed to be non-negative and scl returns the value\n\ *\n\ * scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ),\n\ * i\n\ *\n\ * scale and sumsq must be supplied in SCALE and SUMSQ respectively.\n\ * SCALE and SUMSQ are overwritten by scl and ssq respectively.\n\ *\n\ * The routine makes only one pass through the vector X.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of elements to be used from the vector X.\n\ *\n\ * X (input) COMPLEX array, dimension (N)\n\ * The vector x as described above.\n\ * x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between successive values of the vector X.\n\ * INCX > 0.\n\ *\n\ * SCALE (input/output) REAL\n\ * On entry, the value scale in the equation above.\n\ * On exit, SCALE is overwritten with the value scl .\n\ *\n\ * SUMSQ (input/output) REAL\n\ * On entry, the value sumsq in the equation above.\n\ * On exit, SUMSQ is overwritten with the value ssq .\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgecon0000644000175000017500000000505212502223526016477 0ustar uwabamiuwabami--- :name: zgecon :md5sum: 57c09e654b5c310f1726f52961a7ca80 :category: :subroutine :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGECON estimates the reciprocal of the condition number of a general\n\ * complex matrix A, in either the 1-norm or the infinity-norm, using\n\ * the LU factorization computed by ZGETRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as\n\ * RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies whether the 1-norm condition number or the\n\ * infinity-norm condition number is required:\n\ * = '1' or 'O': 1-norm;\n\ * = 'I': Infinity-norm.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The factors L and U from the factorization A = P*L*U\n\ * as computed by ZGETRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * ANORM (input) DOUBLE PRECISION\n\ * If NORM = '1' or 'O', the 1-norm of the original matrix A.\n\ * If NORM = 'I', the infinity-norm of the original matrix A.\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(norm(A) * norm(inv(A))).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zporfs0000644000175000017500000001154412502223526016540 0ustar uwabamiuwabami--- :name: zporfs :md5sum: 4bc4a31a427ae54f3a7c9845be815a3d :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPORFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is Hermitian positive definite,\n\ * and provides error bounds and backward error estimates for the\n\ * solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The Hermitian matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular part\n\ * of the matrix A, and the strictly lower triangular part of A\n\ * is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of A contains the lower triangular part of\n\ * the matrix A, and the strictly upper triangular part of A is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX*16 array, dimension (LDAF,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**H*U or A = L*L**H, as computed by ZPOTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by ZPOTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * ====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhbev0000644000175000017500000000765512502223526016343 0ustar uwabamiuwabami--- :name: zhbev :md5sum: 4aa6337b1416770872716376ca785458 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - n - rwork: :type: doublereal :intent: workspace :dims: - MAX(1,3*n-2) - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" :fortran_help: " SUBROUTINE ZHBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHBEV computes all the eigenvalues and, optionally, eigenvectors of\n\ * a complex Hermitian band matrix A.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) COMPLEX*16 array, dimension (LDAB, N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * On exit, AB is overwritten by values generated during the\n\ * reduction to tridiagonal form. If UPLO = 'U', the first\n\ * superdiagonal and the diagonal of the tridiagonal matrix T\n\ * are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n\ * the diagonal and first subdiagonal of T are returned in the\n\ * first two rows of AB.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD + 1.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) COMPLEX*16 array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n\ * eigenvectors of the matrix A, with the i-th column of Z\n\ * holding the eigenvector associated with W(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (max(1,3*N-2))\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 algorithm failed to converge; i\n\ * off-diagonal elements of an intermediate tridiagonal\n\ * form did not converge to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dtgexc0000644000175000017500000001450312502223526016471 0ustar uwabamiuwabami--- :name: dtgexc :md5sum: c2b019b8915f3720467ce4261b0c9e0f :category: :subroutine :arguments: - wantq: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - q: :type: doublereal :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - z: :type: doublereal :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - ifst: :type: integer :intent: input/output - ilst: :type: integer :intent: input/output - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : 4*n+16" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, IFST, ILST, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTGEXC reorders the generalized real Schur decomposition of a real\n\ * matrix pair (A,B) using an orthogonal equivalence transformation\n\ *\n\ * (A, B) = Q * (A, B) * Z',\n\ *\n\ * so that the diagonal block of (A, B) with row index IFST is moved\n\ * to row ILST.\n\ *\n\ * (A, B) must be in generalized real Schur canonical form (as returned\n\ * by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2\n\ * diagonal blocks. B is upper triangular.\n\ *\n\ * Optionally, the matrices Q and Z of generalized Schur vectors are\n\ * updated.\n\ *\n\ * Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n\ * Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n\ *\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * WANTQ (input) LOGICAL\n\ * .TRUE. : update the left transformation matrix Q;\n\ * .FALSE.: do not update Q.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * .TRUE. : update the right transformation matrix Z;\n\ * .FALSE.: do not update Z.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the matrix A in generalized real Schur canonical\n\ * form.\n\ * On exit, the updated matrix A, again in generalized\n\ * real Schur canonical form.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,N)\n\ * On entry, the matrix B in generalized real Schur canonical\n\ * form (A,B).\n\ * On exit, the updated matrix B, again in generalized\n\ * real Schur canonical form (A,B).\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n\ * On entry, if WANTQ = .TRUE., the orthogonal matrix Q.\n\ * On exit, the updated matrix Q.\n\ * If WANTQ = .FALSE., Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= 1.\n\ * If WANTQ = .TRUE., LDQ >= N.\n\ *\n\ * Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n\ * On entry, if WANTZ = .TRUE., the orthogonal matrix Z.\n\ * On exit, the updated matrix Z.\n\ * If WANTZ = .FALSE., Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1.\n\ * If WANTZ = .TRUE., LDZ >= N.\n\ *\n\ * IFST (input/output) INTEGER\n\ * ILST (input/output) INTEGER\n\ * Specify the reordering of the diagonal blocks of (A, B).\n\ * The block with row index IFST is moved to row ILST, by a\n\ * sequence of swapping between adjacent blocks.\n\ * On exit, if IFST pointed on entry to the second row of\n\ * a 2-by-2 block, it is changed to point to the first row;\n\ * ILST always points to the first row of the block in its\n\ * final position (which may differ from its input value by\n\ * +1 or -1). 1 <= IFST, ILST <= 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 >= 1 when N <= 1, otherwise LWORK >= 4*N + 16.\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\ * =1: The transformed matrix pair (A, B) would be too far\n\ * from generalized Schur form; the problem is ill-\n\ * conditioned. (A, B) may have been partially reordered,\n\ * and ILST points to the first row of the current\n\ * position of the block being moved.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n\ * Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n\ * M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n\ * Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cstedc0000644000175000017500000001732212502223525016461 0ustar uwabamiuwabami--- :name: cstedc :md5sum: 0cb301e3ca0d09d7acb4ab12140db0e3 :category: :subroutine :arguments: - compz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - z: :type: complex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(lsame_(&compz,\"N\")||lsame_(&compz,\"I\")||n<=1) ? 1 : lsame_(&compz,\"V\") ? n*n : 0" - rwork: :type: real :intent: output :dims: - MAX(1,lrwork) - lrwork: :type: integer :intent: input :option: true :default: "(lsame_(&compz,\"N\")||n<=1) ? 1 : lsame_(&compz,\"V\") ? 1+3*n+2*n*LG(n)+3*n*n : lsame_(&compz,\"I\") ? 1+4*n+2*n*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "(lsame_(&compz,\"N\")||n<=1) ? 1 : lsame_(&compz,\"V\") ? 6+6*n+5*n*LG(n) : lsame_(&compz,\"I\") ? 3+5*n : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSTEDC computes all eigenvalues and, optionally, eigenvectors of a\n\ * symmetric tridiagonal matrix using the divide and conquer method.\n\ * The eigenvectors of a full or band complex Hermitian matrix can also\n\ * be found if CHETRD or CHPTRD or CHBTRD has been used to reduce this\n\ * matrix to tridiagonal form.\n\ *\n\ * This code makes very mild assumptions about floating point\n\ * arithmetic. It will work on machines with a guard digit in\n\ * add/subtract, or on those binary machines without guard digits\n\ * which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n\ * It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none. See SLAED3 for details.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * COMPZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only.\n\ * = 'I': Compute eigenvectors of tridiagonal matrix also.\n\ * = 'V': Compute eigenvectors of original Hermitian matrix\n\ * also. On entry, Z contains the unitary matrix used\n\ * to reduce the original matrix to tridiagonal form.\n\ *\n\ * N (input) INTEGER\n\ * The dimension of the symmetric tridiagonal matrix. N >= 0.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the diagonal elements of the tridiagonal matrix.\n\ * On exit, if INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * E (input/output) REAL array, dimension (N-1)\n\ * On entry, the subdiagonal elements of the tridiagonal matrix.\n\ * On exit, E has been destroyed.\n\ *\n\ * Z (input/output) COMPLEX array, dimension (LDZ,N)\n\ * On entry, if COMPZ = 'V', then Z contains the unitary\n\ * matrix used in the reduction to tridiagonal form.\n\ * On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n\ * orthonormal eigenvectors of the original Hermitian matrix,\n\ * and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n\ * of the symmetric tridiagonal matrix.\n\ * If COMPZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1.\n\ * If eigenvectors are desired, then LDZ >= max(1,N).\n\ *\n\ * WORK (workspace/output) COMPLEX 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\ * If COMPZ = 'N' or 'I', or N <= 1, LWORK must be at least 1.\n\ * If COMPZ = 'V' and N > 1, LWORK must be at least N*N.\n\ * Note that for COMPZ = 'V', then if N is less than or\n\ * equal to the minimum divide size, usually 25, then LWORK need\n\ * only be 1.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the optimal sizes of the WORK, RWORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK))\n\ * On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n\ *\n\ * LRWORK (input) INTEGER\n\ * The dimension of the array RWORK.\n\ * If COMPZ = 'N' or N <= 1, LRWORK must be at least 1.\n\ * If COMPZ = 'V' and N > 1, LRWORK must be at least\n\ * 1 + 3*N + 2*N*lg N + 3*N**2 ,\n\ * where lg( N ) = smallest integer k such\n\ * that 2**k >= N.\n\ * If COMPZ = 'I' and N > 1, LRWORK must be at least\n\ * 1 + 4*N + 2*N**2 .\n\ * Note that for COMPZ = 'I' or 'V', then if N is less than or\n\ * equal to the minimum divide size, usually 25, then LRWORK\n\ * need only be max(1,2*(N-1)).\n\ *\n\ * If LRWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK.\n\ * If COMPZ = 'N' or N <= 1, LIWORK must be at least 1.\n\ * If COMPZ = 'V' or N > 1, LIWORK must be at least\n\ * 6 + 6*N + 5*N*lg N.\n\ * If COMPZ = 'I' or N > 1, LIWORK must be at least\n\ * 3 + 5*N .\n\ * Note that for COMPZ = 'I' or 'V', then if N is less than or\n\ * equal to the minimum divide size, usually 25, then LIWORK\n\ * need only be 1.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK 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: The algorithm failed to compute an eigenvalue while\n\ * working on the submatrix lying in rows and columns\n\ * INFO/(N+1) through mod(INFO,N+1).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Jeff Rutter, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zung2l0000644000175000017500000000446712502223526016444 0ustar uwabamiuwabami--- :name: zung2l :md5sum: 4673fb5058f789d5a4b6628595472cbd :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - work: :type: doublecomplex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZUNG2L generates an m by n complex matrix Q with orthonormal columns,\n\ * which is defined as the last n columns of a product of k elementary\n\ * reflectors of order m\n\ *\n\ * Q = H(k) . . . H(2) H(1)\n\ *\n\ * as returned by ZGEQLF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. M >= N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. N >= K >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the (n-k+i)-th column must contain the vector which\n\ * defines the elementary reflector H(i), for i = 1,2,...,k, as\n\ * returned by ZGEQLF in the last k columns of its array\n\ * argument A.\n\ * On exit, the m-by-n matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) COMPLEX*16 array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by ZGEQLF.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dggglm0000644000175000017500000001236612502223526016461 0ustar uwabamiuwabami--- :name: dggglm :md5sum: b132b24d18eb3c974ddf79f3c310f812 :category: :subroutine :arguments: - n: :type: integer :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - m - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - p - ldb: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - x: :type: doublereal :intent: output :dims: - m - y: :type: doublereal :intent: output :dims: - p - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m+n+p - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGGGLM solves a general Gauss-Markov linear model (GLM) problem:\n\ *\n\ * minimize || y ||_2 subject to d = A*x + B*y\n\ * x\n\ *\n\ * where A is an N-by-M matrix, B is an N-by-P matrix, and d is a\n\ * given N-vector. It is assumed that M <= N <= M+P, and\n\ *\n\ * rank(A) = M and rank( A B ) = N.\n\ *\n\ * Under these assumptions, the constrained equation is always\n\ * consistent, and there is a unique solution x and a minimal 2-norm\n\ * solution y, which is obtained using a generalized QR factorization\n\ * of the matrices (A, B) given by\n\ *\n\ * A = Q*(R), B = Q*T*Z.\n\ * (0)\n\ *\n\ * In particular, if matrix B is square nonsingular, then the problem\n\ * GLM is equivalent to the following weighted linear least squares\n\ * problem\n\ *\n\ * minimize || inv(B)*(d-A*x) ||_2\n\ * x\n\ *\n\ * where inv(B) denotes the inverse of B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of rows of the matrices A and B. N >= 0.\n\ *\n\ * M (input) INTEGER\n\ * The number of columns of the matrix A. 0 <= M <= N.\n\ *\n\ * P (input) INTEGER\n\ * The number of columns of the matrix B. P >= N-M.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,M)\n\ * On entry, the N-by-M matrix A.\n\ * On exit, the upper triangular part of the array A contains\n\ * the M-by-M upper triangular matrix R.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,P)\n\ * On entry, the N-by-P matrix B.\n\ * On exit, if N <= P, the upper triangle of the subarray\n\ * B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n\ * if N > P, the elements on and above the (N-P)th subdiagonal\n\ * contain the N-by-P upper trapezoidal matrix T.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, D is the left hand side of the GLM equation.\n\ * On exit, D is destroyed.\n\ *\n\ * X (output) DOUBLE PRECISION array, dimension (M)\n\ * Y (output) DOUBLE PRECISION array, dimension (P)\n\ * On exit, X and Y are the solutions of the GLM problem.\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,N+M+P).\n\ * For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,\n\ * where NB is an upper bound for the optimal blocksizes for\n\ * DGEQRF, SGERQF, DORMQR and SORMRQ.\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\ * = 1: the upper triangular factor R associated with A in the\n\ * generalized QR factorization of the pair (A, B) is\n\ * singular, so that rank(A) < M; the least squares\n\ * solution could not be computed.\n\ * = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal\n\ * factor T associated with B in the generalized QR\n\ * factorization of the pair (A, B) is singular, so that\n\ * rank( A B ) < N; the least squares solution could not\n\ * be computed.\n\ *\n\n\ * ===================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dpotrf0000644000175000017500000000457512502223526016521 0ustar uwabamiuwabami--- :name: dpotrf :md5sum: d423e0b564d01b7b1609bb5561b93073 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPOTRF computes the Cholesky factorization of a real symmetric\n\ * positive definite matrix A.\n\ *\n\ * The factorization has the form\n\ * A = U**T * U, if UPLO = 'U', or\n\ * A = L * L**T, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is lower triangular.\n\ *\n\ * This is the block version of the algorithm, calling Level 3 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\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 leading minor of order i is not\n\ * positive definite, and the factorization could not be\n\ * completed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ztbcon0000644000175000017500000000633712502223526016520 0ustar uwabamiuwabami--- :name: ztbcon :md5sum: 44bfad5070510971c7f6dac7609ca25b :category: :subroutine :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTBCON estimates the reciprocal of the condition number of a\n\ * triangular band matrix A, in either the 1-norm or the infinity-norm.\n\ *\n\ * The norm of A is computed and an estimate is obtained for\n\ * norm(inv(A)), then the reciprocal of the condition number is\n\ * computed as\n\ * RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies whether the 1-norm condition number or the\n\ * infinity-norm condition number is required:\n\ * = '1' or 'O': 1-norm;\n\ * = 'I': Infinity-norm.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals or subdiagonals of the\n\ * triangular band matrix A. KD >= 0.\n\ *\n\ * AB (input) COMPLEX*16 array, dimension (LDAB,N)\n\ * The upper or lower triangular band matrix A, stored in the\n\ * first kd+1 rows of the array. The j-th column of A is stored\n\ * in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ * If DIAG = 'U', the diagonal elements of A are not referenced\n\ * and are assumed to be 1.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(norm(A) * norm(inv(A))).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsytrs20000644000175000017500000000525712502223526016633 0ustar uwabamiuwabami--- :name: dsytrs2 :md5sum: 4d56588bffecdffff2457883247d9b42 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSYTRS2 solves a system of linear equations A*X = B with a real\n\ * symmetric matrix A using the factorization A = U*D*U**T or\n\ * A = L*D*L**T computed by DSYTRF and converted by DSYCONV.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by DSYTRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by DSYTRF.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * WORK (workspace) REAL array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dspsv0000644000175000017500000001155612502223526016357 0ustar uwabamiuwabami--- :name: dspsv :md5sum: 0fac3d384951ed9358ca786e7d72fd2b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: output :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: n: ldb :fortran_help: " SUBROUTINE DSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSPSV computes the solution to a real system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N symmetric matrix stored in packed format and X\n\ * and B are N-by-NRHS matrices.\n\ *\n\ * The diagonal pivoting method is used to factor A as\n\ * A = U * D * U**T, if UPLO = 'U', or\n\ * A = L * D * L**T, if UPLO = 'L',\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, D is symmetric and block diagonal with 1-by-1\n\ * and 2-by-2 diagonal blocks. The factored form of A is then used to\n\ * solve the system of equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ * See below for further details.\n\ *\n\ * On exit, the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L from the factorization\n\ * A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as\n\ * a packed triangular matrix in the same storage format as A.\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D, as\n\ * determined by DSPTRF. If IPIV(k) > 0, then rows and columns\n\ * k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n\ * diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n\ * then rows and columns k-1 and -IPIV(k) were interchanged and\n\ * D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n\ * IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n\ * -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n\ * diagonal block.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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, D(i,i) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular, so the solution could not be\n\ * computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The packed storage scheme is illustrated by the following example\n\ * when N = 4, UPLO = 'U':\n\ *\n\ * Two-dimensional storage of the symmetric matrix A:\n\ *\n\ * a11 a12 a13 a14\n\ * a22 a23 a24\n\ * a33 a34 (aij = aji)\n\ * a44\n\ *\n\ * Packed storage of the upper triangle of A:\n\ *\n\ * AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n\ *\n\ * =====================================================================\n\ *\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DSPTRF, DSPTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/spftrf0000644000175000017500000001412012502223526016512 0ustar uwabamiuwabami--- :name: spftrf :md5sum: d1c6046e8099759e3e26aad67c90017d :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPFTRF( TRANSR, UPLO, N, A, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPFTRF computes the Cholesky factorization of a real symmetric\n\ * positive definite matrix A.\n\ *\n\ * The factorization has the form\n\ * A = U**T * U, if UPLO = 'U', or\n\ * A = L * L**T, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is lower triangular.\n\ *\n\ * This is the block version of the algorithm, calling Level 3 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': The Normal TRANSR of RFP A is stored;\n\ * = 'T': The Transpose TRANSR of RFP A is stored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of RFP A is stored;\n\ * = 'L': Lower triangle of RFP A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension ( N*(N+1)/2 );\n\ * On entry, the symmetric matrix A in RFP format. RFP format is\n\ * described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n\ * then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n\ * (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is\n\ * the transpose of RFP A as defined when\n\ * TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n\ * follows: If UPLO = 'U' the RFP A contains the NT elements of\n\ * upper packed A. If UPLO = 'L' the RFP A contains the elements\n\ * of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n\ * 'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n\ * is odd. See the Note below for more details.\n\ *\n\ * On exit, if INFO = 0, the factor U or L from the Cholesky\n\ * factorization RFP A = U**T*U or RFP A = L*L**T.\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 leading minor of order i is not\n\ * positive definite, and the factorization could not be\n\ * completed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * We first consider Rectangular Full Packed (RFP) Format when N is\n\ * even. We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * the transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * the transpose of the last three columns of AP lower.\n\ * This covers the case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 04 05 33 43 53\n\ * 13 14 15 00 44 54\n\ * 23 24 25 10 11 55\n\ * 33 34 35 20 21 22\n\ * 00 44 45 30 31 32\n\ * 01 11 55 40 41 42\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We then consider Rectangular Full Packed (RFP) Format when N is\n\ * odd. We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * the transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * the transpose of the last two columns of AP lower.\n\ * This covers the case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 03 04 00 33 43\n\ * 12 13 14 10 11 44\n\ * 22 23 24 20 21 22\n\ * 00 33 34 30 31 32\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlanst0000644000175000017500000000404112502223526016474 0ustar uwabamiuwabami--- :name: dlanst :md5sum: 615e091890476d886b6641697bfe7b25 :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublereal :intent: input :dims: - n-1 :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLANST returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * real symmetric tridiagonal matrix A.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * DLANST returns the value\n\ *\n\ * DLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in DLANST as described\n\ * above.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, DLANST is\n\ * set to zero.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The diagonal elements of A.\n\ *\n\ * E (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) sub-diagonal or super-diagonal elements of A.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ztrtri0000644000175000017500000000460012502223526016546 0ustar uwabamiuwabami--- :name: ztrtri :md5sum: 843b034565f063ef35a59608bd92e376 :category: :subroutine :arguments: - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZTRTRI( UPLO, DIAG, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTRTRI computes the inverse of a complex upper or lower triangular\n\ * matrix A.\n\ *\n\ * This is the Level 3 BLAS version of the algorithm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the triangular matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of the array A contains\n\ * the upper triangular matrix, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of the array A contains\n\ * the lower triangular matrix, and the strictly upper\n\ * triangular part of A is not referenced. If DIAG = 'U', the\n\ * diagonal elements of A are also not referenced and are\n\ * assumed to be 1.\n\ * On exit, the (triangular) inverse of the original matrix, in\n\ * the same storage format.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\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, A(i,i) is exactly zero. The triangular\n\ * matrix is singular and its inverse can not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlarrr0000644000175000017500000000362312502223526016502 0ustar uwabamiuwabami--- :name: dlarrr :md5sum: aaf8ba40b9ad39ee862cbb6d215c9186 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublereal :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLARRR( N, D, E, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Perform tests to decide whether the symmetric tridiagonal matrix T\n\ * warrants expensive computations which guarantee high relative accuracy\n\ * in the eigenvalues.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N > 0.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The N diagonal elements of the tridiagonal matrix T.\n\ *\n\ * E (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the first (N-1) entries contain the subdiagonal\n\ * elements of the tridiagonal matrix T; E(N) is set to ZERO.\n\ *\n\ * INFO (output) INTEGER\n\ * INFO = 0(default) : the matrix warrants computations preserving\n\ * relative accuracy.\n\ * INFO = 1 : the matrix warrants computations guaranteeing\n\ * only absolute accuracy.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Beresford Parlett, University of California, Berkeley, USA\n\ * Jim Demmel, University of California, Berkeley, USA\n\ * Inderjit Dhillon, University of Texas, Austin, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, University of California, Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slasyf0000644000175000017500000001054212502223526016513 0ustar uwabamiuwabami--- :name: slasyf :md5sum: b2e9ac7bd81537a479ed47e04a559ad2 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nb: :type: integer :intent: input - kb: :type: integer :intent: output - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - w: :type: real :intent: workspace :dims: - ldw - MAX(1,nb) - ldw: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: ldw: MAX(1,n) :fortran_help: " SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLASYF computes a partial factorization of a real symmetric matrix A\n\ * using the Bunch-Kaufman diagonal pivoting method. The partial\n\ * factorization has the form:\n\ *\n\ * A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:\n\ * ( 0 U22 ) ( 0 D ) ( U12' U22' )\n\ *\n\ * A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L'\n\ * ( L21 I ) ( 0 A22 ) ( 0 I )\n\ *\n\ * where the order of D is at most NB. The actual order is returned in\n\ * the argument KB, and is either NB or NB-1, or N if N <= NB.\n\ *\n\ * SLASYF is an auxiliary routine called by SSYTRF. It uses blocked code\n\ * (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or\n\ * A22 (if UPLO = 'L').\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NB (input) INTEGER\n\ * The maximum number of columns of the matrix A that should be\n\ * factored. NB should be at least 2 to allow for 2-by-2 pivot\n\ * blocks.\n\ *\n\ * KB (output) INTEGER\n\ * The number of columns of A that were actually factored.\n\ * KB is either NB-1 or NB, or N if N <= NB.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * n-by-n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n-by-n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ * On exit, A contains details of the partial factorization.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D.\n\ * If UPLO = 'U', only the last KB elements of IPIV are set;\n\ * if UPLO = 'L', only the first KB elements are set.\n\ *\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * W (workspace) REAL array, dimension (LDW,NB)\n\ *\n\ * LDW (input) INTEGER\n\ * The leading dimension of the array W. LDW >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/strti20000644000175000017500000000453312502223526016444 0ustar uwabamiuwabami--- :name: strti2 :md5sum: 1d4a26588f70037999cb08613ada275d :category: :subroutine :arguments: - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE STRTI2( UPLO, DIAG, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STRTI2 computes the inverse of a real upper or lower triangular\n\ * matrix.\n\ *\n\ * This is the Level 2 BLAS version of the algorithm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the matrix A is upper or lower triangular.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * Specifies whether or not the matrix A is unit triangular.\n\ * = 'N': Non-unit triangular\n\ * = 'U': Unit triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the triangular matrix A. If UPLO = 'U', the\n\ * leading n by n upper triangular part of the array A contains\n\ * the upper triangular matrix, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n by n lower triangular part of the array A contains\n\ * the lower triangular matrix, and the strictly upper\n\ * triangular part of A is not referenced. If DIAG = 'U', the\n\ * diagonal elements of A are also not referenced and are\n\ * assumed to be 1.\n\ *\n\ * On exit, the (triangular) inverse of the original matrix, in\n\ * the same storage format.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsbgst0000644000175000017500000000772312502223526016507 0ustar uwabamiuwabami--- :name: dsbgst :md5sum: d2437ea90e45fe4864720cf3787add9d :category: :subroutine :arguments: - vect: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: doublereal :intent: input :dims: - ldbb - n - ldbb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - n - ldx: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldx: "lsame_(&vect,\"V\") ? MAX(1,n) : 1" :fortran_help: " SUBROUTINE DSBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, LDX, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSBGST reduces a real symmetric-definite banded generalized\n\ * eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y,\n\ * such that C has the same bandwidth as A.\n\ *\n\ * B must have been previously factorized as S**T*S by DPBSTF, using a\n\ * split Cholesky factorization. A is overwritten by C = X**T*A*X, where\n\ * X = S**(-1)*Q and Q is an orthogonal matrix chosen to preserve the\n\ * bandwidth of A.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * VECT (input) CHARACTER*1\n\ * = 'N': do not form the transformation matrix X;\n\ * = 'V': form X.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * KA (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n\ *\n\ * KB (input) INTEGER\n\ * The number of superdiagonals of the matrix B if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0.\n\ *\n\ * AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first ka+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n\ *\n\ * On exit, the transformed matrix X**T*A*X, stored in the same\n\ * format as A.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KA+1.\n\ *\n\ * BB (input) DOUBLE PRECISION array, dimension (LDBB,N)\n\ * The banded factor S from the split Cholesky factorization of\n\ * B, as returned by DPBSTF, stored in the first KB+1 rows of\n\ * the array.\n\ *\n\ * LDBB (input) INTEGER\n\ * The leading dimension of the array BB. LDBB >= KB+1.\n\ *\n\ * X (output) DOUBLE PRECISION array, dimension (LDX,N)\n\ * If VECT = 'V', the n-by-n matrix X.\n\ * If VECT = 'N', the array X is not referenced.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X.\n\ * LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cpftrs0000644000175000017500000001467012502223525016520 0ustar uwabamiuwabami--- :name: cpftrs :md5sum: ccd62c87dcf766b816524a7c639bb28b :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - n*(n+1)/2 - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPFTRS solves a system of linear equations A*X = B with a Hermitian\n\ * positive definite matrix A using the Cholesky factorization\n\ * A = U**H*U or A = L*L**H computed by CPFTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': The Normal TRANSR of RFP A is stored;\n\ * = 'C': The Conjugate-transpose TRANSR of RFP A is stored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of RFP A is stored;\n\ * = 'L': Lower triangle of RFP A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension ( N*(N+1)/2 );\n\ * The triangular factor U or L from the Cholesky factorization\n\ * of RFP A = U**H*U or RFP A = L*L**H, as computed by CPFTRF.\n\ * See note below for more details about RFP A.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * We first consider Standard Packed Format when N is even.\n\ * We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * conjugate-transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * conjugate-transpose of the last three columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- --\n\ * 03 04 05 33 43 53\n\ * -- --\n\ * 13 14 15 00 44 54\n\ * --\n\ * 23 24 25 10 11 55\n\ *\n\ * 33 34 35 20 21 22\n\ * --\n\ * 00 44 45 30 31 32\n\ * -- --\n\ * 01 11 55 40 41 42\n\ * -- -- --\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We next consider Standard Packed Format when N is odd.\n\ * We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * conjugate-transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * conjugate-transpose of the last two columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- --\n\ * 02 03 04 00 33 43\n\ * --\n\ * 12 13 14 10 11 44\n\ *\n\ * 22 23 24 20 21 22\n\ * --\n\ * 00 33 34 30 31 32\n\ * -- --\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- --\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clacgv0000644000175000017500000000223412502223525016447 0ustar uwabamiuwabami--- :name: clacgv :md5sum: b798c93b96a1a5b91fa73ba3dcd76a1b :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - 1+(n-1)*abs(incx) - incx: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE CLACGV( N, X, INCX )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLACGV conjugates a complex vector of length N.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The length of the vector X. N >= 0.\n\ *\n\ * X (input/output) COMPLEX array, dimension\n\ * (1+(N-1)*abs(INCX))\n\ * On entry, the vector of length N to be conjugated.\n\ * On exit, X is overwritten with conjg(X).\n\ *\n\ * INCX (input) INTEGER\n\ * The spacing between successive elements of X.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, IOFF\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC CONJG\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dstemr0000644000175000017500000002754412502223526016522 0ustar uwabamiuwabami--- :name: dstemr :md5sum: 3d5dcbe36e1791efd5d5a833db168b23 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - nzc: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - tryrac: :type: logical :intent: input/output - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 18*n : lsame_(&jobz,\"N\") ? 12*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 10*n : lsame_(&jobz,\"N\") ? 8*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " SUBROUTINE DSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSTEMR computes selected eigenvalues and, optionally, eigenvectors\n\ * of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n\ * a well defined set of pairwise different real eigenvalues, the corresponding\n\ * real eigenvectors are pairwise orthogonal.\n\ *\n\ * The spectrum may be computed either completely or partially by specifying\n\ * either an interval (VL,VU] or a range of indices IL:IU for the desired\n\ * eigenvalues.\n\ *\n\ * Depending on the number of desired eigenvalues, these are computed either\n\ * by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are\n\ * computed by the use of various suitable L D L^T factorizations near clusters\n\ * of close eigenvalues (referred to as RRRs, Relatively Robust\n\ * Representations). An informal sketch of the algorithm follows.\n\ *\n\ * For each unreduced block (submatrix) of T,\n\ * (a) Compute T - sigma I = L D L^T, so that L and D\n\ * define all the wanted eigenvalues to high relative accuracy.\n\ * This means that small relative changes in the entries of D and L\n\ * cause only small relative changes in the eigenvalues and\n\ * eigenvectors. The standard (unfactored) representation of the\n\ * tridiagonal matrix T does not have this property in general.\n\ * (b) Compute the eigenvalues to suitable accuracy.\n\ * If the eigenvectors are desired, the algorithm attains full\n\ * accuracy of the computed eigenvalues only right before\n\ * the corresponding vectors have to be computed, see steps c) and d).\n\ * (c) For each cluster of close eigenvalues, select a new\n\ * shift close to the cluster, find a new factorization, and refine\n\ * the shifted eigenvalues to suitable accuracy.\n\ * (d) For each eigenvalue with a large enough relative separation compute\n\ * the corresponding eigenvector by forming a rank revealing twisted\n\ * factorization. Go back to (c) for any clusters that remain.\n\ *\n\ * For more details, see:\n\ * - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n\ * to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n\ * Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n\ * - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n\ * Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n\ * 2004. Also LAPACK Working Note 154.\n\ * - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n\ * tridiagonal eigenvalue/eigenvector problem\",\n\ * Computer Science Division Technical Report No. UCB/CSD-97-971,\n\ * UC Berkeley, May 1997.\n\ *\n\ * Further Details\n\ * 1.DSTEMR works only on machines which follow IEEE-754\n\ * floating-point standard in their handling of infinities and NaNs.\n\ * This permits the use of efficient inner loops avoiding a check for\n\ * zero divisors.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found.\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found.\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the N diagonal elements of the tridiagonal matrix\n\ * T. On exit, D is overwritten.\n\ *\n\ * E (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the (N-1) subdiagonal elements of the tridiagonal\n\ * matrix T in elements 1 to N-1 of E. E(N) need not be set on\n\ * input, but is used internally as workspace.\n\ * On exit, E is overwritten.\n\ *\n\ * VL (input) DOUBLE PRECISION\n\ * VU (input) DOUBLE PRECISION\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * The first M elements contain the selected eigenvalues in\n\ * ascending order.\n\ *\n\ * Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )\n\ * If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix T\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and can be computed with a workspace\n\ * query by setting NZC = -1, see below.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', then LDZ >= max(1,N).\n\ *\n\ * NZC (input) INTEGER\n\ * The number of eigenvectors to be held in the array Z.\n\ * If RANGE = 'A', then NZC >= max(1,N).\n\ * If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].\n\ * If RANGE = 'I', then NZC >= IU-IL+1.\n\ * If NZC = -1, then a workspace query is assumed; the\n\ * routine calculates the number of columns of the array Z that\n\ * are needed to hold the eigenvectors.\n\ * This value is returned as the first entry of the Z array, and\n\ * no error message related to NZC is issued by XERBLA.\n\ *\n\ * ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n\ * The support of the eigenvectors in Z, i.e., the indices\n\ * indicating the nonzero elements in Z. The i-th computed eigenvector\n\ * is nonzero only in elements ISUPPZ( 2*i-1 ) through\n\ * ISUPPZ( 2*i ). This is relevant in the case when the matrix\n\ * is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n\ *\n\ * TRYRAC (input/output) LOGICAL\n\ * If TRYRAC.EQ..TRUE., indicates that the code should check whether\n\ * the tridiagonal matrix defines its eigenvalues to high relative\n\ * accuracy. If so, the code uses relative-accuracy preserving\n\ * algorithms that might be (a bit) slower depending on the matrix.\n\ * If the matrix does not define its eigenvalues to high relative\n\ * accuracy, the code can uses possibly faster algorithms.\n\ * If TRYRAC.EQ..FALSE., the code is not required to guarantee\n\ * relatively accurate eigenvalues and can use the fastest possible\n\ * techniques.\n\ * On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix\n\ * does not define its eigenvalues to high relative accuracy.\n\ *\n\ * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)\n\ * On exit, if INFO = 0, WORK(1) returns the optimal\n\ * (and minimal) LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK >= max(1,18*N)\n\ * if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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\ * IWORK (workspace/output) INTEGER array, dimension (LIWORK)\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK. LIWORK >= max(1,10*N)\n\ * if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n\ * if only the eigenvalues are to be computed.\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal size of the IWORK array,\n\ * returns this value as the first entry of the IWORK array, and\n\ * no error message related to LIWORK is issued by XERBLA.\n\ *\n\ * INFO (output) INTEGER\n\ * On exit, INFO\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: if INFO = 1X, internal error in DLARRE,\n\ * if INFO = 2X, internal error in DLARRV.\n\ * Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n\ * the nonzero error code returned by DLARRE or\n\ * DLARRV, respectively.\n\ *\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Beresford Parlett, University of California, Berkeley, USA\n\ * Jim Demmel, University of California, Berkeley, USA\n\ * Inderjit Dhillon, University of Texas, Austin, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, University of California, Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slaqps0000644000175000017500000001006212502223526016512 0ustar uwabamiuwabami--- :name: slaqps :md5sum: de7dce7932e28c06c99614320e23e047 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - offset: :type: integer :intent: input - nb: :type: integer :intent: input - kb: :type: integer :intent: output - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: real :intent: output :dims: - kb - vn1: :type: real :intent: input/output :dims: - n - vn2: :type: real :intent: input/output :dims: - n - auxv: :type: real :intent: input/output :dims: - nb - f: :type: real :intent: input/output :dims: - ldf - nb - ldf: :type: integer :intent: input :substitutions: kb: nb :fortran_help: " SUBROUTINE SLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, VN2, AUXV, F, LDF )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAQPS computes a step of QR factorization with column pivoting\n\ * of a real M-by-N matrix A by using Blas-3. It tries to factorize\n\ * NB columns from A starting from the row OFFSET+1, and updates all\n\ * of the matrix with Blas-3 xGEMM.\n\ *\n\ * In some cases, due to catastrophic cancellations, it cannot\n\ * factorize NB columns. Hence, the actual number of factorized\n\ * columns is returned in KB.\n\ *\n\ * Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\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\ * OFFSET (input) INTEGER\n\ * The number of rows of A that have been factorized in\n\ * previous steps.\n\ *\n\ * NB (input) INTEGER\n\ * The number of columns to factorize.\n\ *\n\ * KB (output) INTEGER\n\ * The number of columns actually factorized.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, block A(OFFSET+1:M,1:KB) is the triangular\n\ * factor obtained and block A(1:OFFSET,1:N) has been\n\ * accordingly pivoted, but no factorized.\n\ * The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has\n\ * been updated.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * JPVT (input/output) INTEGER array, dimension (N)\n\ * JPVT(I) = K <==> Column K of the full matrix A has been\n\ * permuted into position I in AP.\n\ *\n\ * TAU (output) REAL array, dimension (KB)\n\ * The scalar factors of the elementary reflectors.\n\ *\n\ * VN1 (input/output) REAL array, dimension (N)\n\ * The vector with the partial column norms.\n\ *\n\ * VN2 (input/output) REAL array, dimension (N)\n\ * The vector with the exact column norms.\n\ *\n\ * AUXV (input/output) REAL array, dimension (NB)\n\ * Auxiliar vector.\n\ *\n\ * F (input/output) REAL array, dimension (LDF,NB)\n\ * Matrix F' = L*Y'*A.\n\ *\n\ * LDF (input) INTEGER\n\ * The leading dimension of the array F. LDF >= max(1,N).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n\ * X. Sun, Computer Science Dept., Duke University, USA\n\ *\n\ * Partial column norm updating strategy modified by\n\ * Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n\ * University of Zagreb, Croatia.\n\ * June 2010\n\ * For more details see LAPACK Working Note 176.\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sorglq0000644000175000017500000000564212502223526016526 0ustar uwabamiuwabami--- :name: sorglq :md5sum: c0025a6efef362bff327d6a884154b3c :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SORGLQ generates an M-by-N real matrix Q with orthonormal rows,\n\ * which is defined as the first M rows of a product of K elementary\n\ * reflectors of order N\n\ *\n\ * Q = H(k) . . . H(2) H(1)\n\ *\n\ * as returned by SGELQF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. N >= M.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. M >= K >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the i-th row must contain the vector which defines\n\ * the elementary reflector H(i), for i = 1,2,...,k, as returned\n\ * by SGELQF in the first k rows of its array argument A.\n\ * On exit, the M-by-N matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) REAL array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by SGELQF.\n\ *\n\ * WORK (workspace/output) REAL 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\n\ * the 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 has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgels0000644000175000017500000001327412502223526016315 0ustar uwabamiuwabami--- :name: dgels :md5sum: 9260fd1d04cb3579ce975a620c16558c :category: :subroutine :arguments: - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MIN(m,n) + MAX(MIN(m,n),nrhs) - info: :type: integer :intent: output :substitutions: m: lda ldb: MAX(m,n) :fortran_help: " 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" ruby-lapack-1.7.2/dev/defs/sgbbrd0000644000175000017500000001133612502223526016457 0ustar uwabamiuwabami--- :name: sgbbrd :md5sum: a63bfd9042ac59ad25fe20ca4dea72f6 :category: :subroutine :arguments: - vect: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - ncc: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - d: :type: real :intent: output :dims: - MIN(m,n) - e: :type: real :intent: output :dims: - MIN(m,n)-1 - q: :type: real :intent: output :dims: - ldq - m - ldq: :type: integer :intent: input - pt: :type: real :intent: output :dims: - ldpt - n - ldpt: :type: integer :intent: input - c: :type: real :intent: input/output :dims: - ldc - ncc - ldc: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 2*MAX(m,n) - info: :type: integer :intent: output :substitutions: m: ldab ldq: "((lsame_(&vect,\"Q\")) || (lsame_(&vect,\"B\"))) ? MAX(1,m) : 1" ldpt: "((lsame_(&vect,\"P\")) || (lsame_(&vect,\"B\"))) ? MAX(1,n) : 1" :fortran_help: " SUBROUTINE SGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, LDQ, PT, LDPT, C, LDC, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGBBRD reduces a real general m-by-n band matrix A to upper\n\ * bidiagonal form B by an orthogonal transformation: Q' * A * P = B.\n\ *\n\ * The routine computes B, and optionally forms Q or P', or computes\n\ * Q'*C for a given matrix C.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * VECT (input) CHARACTER*1\n\ * Specifies whether or not the matrices Q and P' are to be\n\ * formed.\n\ * = 'N': do not form Q or P';\n\ * = 'Q': form Q only;\n\ * = 'P': form P' only;\n\ * = 'B': form both.\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\ * NCC (input) INTEGER\n\ * The number of columns of the matrix C. NCC >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals of the matrix A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals of the matrix A. KU >= 0.\n\ *\n\ * AB (input/output) REAL array, dimension (LDAB,N)\n\ * On entry, the m-by-n band matrix A, stored in rows 1 to\n\ * KL+KU+1. The j-th column of A is stored in the j-th column of\n\ * the array AB as follows:\n\ * AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n\ * On exit, A is overwritten by values generated during the\n\ * reduction.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array A. LDAB >= KL+KU+1.\n\ *\n\ * D (output) REAL array, dimension (min(M,N))\n\ * The diagonal elements of the bidiagonal matrix B.\n\ *\n\ * E (output) REAL array, dimension (min(M,N)-1)\n\ * The superdiagonal elements of the bidiagonal matrix B.\n\ *\n\ * Q (output) REAL array, dimension (LDQ,M)\n\ * If VECT = 'Q' or 'B', the m-by-m orthogonal matrix Q.\n\ * If VECT = 'N' or 'P', the array Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q.\n\ * LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.\n\ *\n\ * PT (output) REAL array, dimension (LDPT,N)\n\ * If VECT = 'P' or 'B', the n-by-n orthogonal matrix P'.\n\ * If VECT = 'N' or 'Q', the array PT is not referenced.\n\ *\n\ * LDPT (input) INTEGER\n\ * The leading dimension of the array PT.\n\ * LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.\n\ *\n\ * C (input/output) REAL array, dimension (LDC,NCC)\n\ * On entry, an m-by-ncc matrix C.\n\ * On exit, C is overwritten by Q'*C.\n\ * C is not referenced if NCC = 0.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C.\n\ * LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.\n\ *\n\ * WORK (workspace) REAL array, dimension (2*max(M,N))\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cla_porfsx_extended0000644000175000017500000003434212502223525021235 0ustar uwabamiuwabami--- :name: cla_porfsx_extended :md5sum: 12869e888f1a7be8b7bedeec770f0481 :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - colequ: :type: logical :intent: input - c: :type: real :intent: input :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: complex :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: real :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - err_bnds_norm: :type: real :intent: input/output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: input/output :dims: - nrhs - n_err_bnds - res: :type: complex :intent: input :dims: - n - ayb: :type: real :intent: input :dims: - n - dy: :type: complex :intent: input :dims: - n - y_tail: :type: complex :intent: input :dims: - n - rcond: :type: real :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: real :intent: input - dz_ub: :type: real :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLA_PORFSX_EXTENDED improves the computed solution to a system of\n\ * linear equations by performing extra-precise iterative refinement\n\ * and provides error bounds and backward error estimates for the solution.\n\ * This subroutine is called by CPORFSX to perform iterative refinement.\n\ * In addition to normwise error bound, the code provides maximum\n\ * componentwise error bound if possible. See comments for ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP for details of the error bounds. Note that this\n\ * subroutine is only resonsible for setting the second fields of\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * PREC_TYPE (input) INTEGER\n\ * Specifies the intermediate precision to be used in refinement.\n\ * The value is defined by ILAPREC(P) where P is a CHARACTER and\n\ * P = 'S': Single\n\ * = 'D': Double\n\ * = 'I': Indigenous\n\ * = 'X', 'E': Extra\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right-hand-sides, i.e., the number of columns of the\n\ * matrix B.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX array, dimension (LDAF,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T, as computed by CPOTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * COLEQU (input) LOGICAL\n\ * If .TRUE. then column equilibration was done to A before calling\n\ * this routine. This is needed to compute the solution and error\n\ * bounds correctly.\n\ *\n\ * C (input) REAL array, dimension (N)\n\ * The column scale factors for A. If COLEQU = .FALSE., C\n\ * is not accessed. If C is input, each element of C should be a power\n\ * of the radix to ensure a reliable solution and error estimates.\n\ * Scaling by powers of the radix does not cause rounding errors unless\n\ * the result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,NRHS)\n\ * The right-hand-side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * Y (input/output) COMPLEX array, dimension\n\ * (LDY,NRHS)\n\ * On entry, the solution matrix X, as computed by CPOTRS.\n\ * On exit, the improved solution matrix Y.\n\ *\n\ * LDY (input) INTEGER\n\ * The leading dimension of the array Y. LDY >= max(1,N).\n\ *\n\ * BERR_OUT (output) REAL array, dimension (NRHS)\n\ * On exit, BERR_OUT(j) contains the componentwise relative backward\n\ * error for right-hand-side j from the formula\n\ * max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n\ * where abs(Z) is the componentwise absolute value of the matrix\n\ * or vector Z. This is computed by CLA_LIN_BERR.\n\ *\n\ * N_NORMS (input) INTEGER\n\ * Determines which error bounds to return (see ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP).\n\ * If N_NORMS >= 1 return normwise error bounds.\n\ * If N_NORMS >= 2 return componentwise error bounds.\n\ *\n\ * ERR_BNDS_NORM (input/output) REAL array, dimension\n\ * (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (input/output) REAL array, dimension\n\ * (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * RES (input) COMPLEX array, dimension (N)\n\ * Workspace to hold the intermediate residual.\n\ *\n\ * AYB (input) REAL array, dimension (N)\n\ * Workspace.\n\ *\n\ * DY (input) COMPLEX array, dimension (N)\n\ * Workspace to hold the intermediate solution.\n\ *\n\ * Y_TAIL (input) COMPLEX array, dimension (N)\n\ * Workspace to hold the trailing bits of the intermediate solution.\n\ *\n\ * RCOND (input) REAL\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * ITHRESH (input) INTEGER\n\ * The maximum number of residual computations allowed for\n\ * refinement. The default is 10. For 'aggressive' set to 100 to\n\ * permit convergence using approximate factorizations or\n\ * factorizations other than LU. If the factorization uses a\n\ * technique other than Gaussian elimination, the guarantees in\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n\ *\n\ * RTHRESH (input) REAL\n\ * Determines when to stop refinement if the error estimate stops\n\ * decreasing. Refinement will stop when the next solution no longer\n\ * satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n\ * the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n\ * default value is 0.5. For 'aggressive' set to 0.9 to permit\n\ * convergence on extremely ill-conditioned matrices. See LAWN 165\n\ * for more details.\n\ *\n\ * DZ_UB (input) REAL\n\ * Determines when to start considering componentwise convergence.\n\ * Componentwise convergence is only considered after each component\n\ * of the solution Y is stable, which we definte as the relative\n\ * change in each component being less than DZ_UB. The default value\n\ * is 0.25, requiring the first bit to be stable. See LAWN 165 for\n\ * more details.\n\ *\n\ * IGNORE_CWISE (input) LOGICAL\n\ * If .TRUE. then ignore componentwise convergence. Default value\n\ * is .FALSE..\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * < 0: if INFO = -i, the ith argument to CPOTRS had an illegal\n\ * value\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE,\n $ Y_PREC_STATE\n REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n COMPLEX ZDUM\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlaqr50000644000175000017500000001675512502223526016416 0ustar uwabamiuwabami--- :name: dlaqr5 :md5sum: 7e0db3e70152db066243f2fdafb92b99 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - kacc22: :type: integer :intent: input - n: :type: integer :intent: input - ktop: :type: integer :intent: input - kbot: :type: integer :intent: input - nshfts: :type: integer :intent: input - sr: :type: doublereal :intent: input/output :dims: - nshfts - si: :type: doublereal :intent: input/output :dims: - nshfts - h: :type: doublereal :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: doublereal :intent: input/output :dims: - "wantz ? ldz : 0" - "wantz ? ihiz : 0" - ldz: :type: integer :intent: input - v: :type: doublereal :intent: workspace :dims: - ldv - nshfts/2 - ldv: :type: integer :intent: input - u: :type: doublereal :intent: workspace :dims: - ldu - 3*nshfts-3 - ldu: :type: integer :intent: input - nv: :type: integer :intent: input - wv: :type: doublereal :intent: workspace :dims: - ldwv - 3*nshfts-3 - ldwv: :type: integer :intent: input - nh: :type: integer :intent: input - wh: :type: doublereal :intent: workspace :dims: - ldwh - MAX(1,nh) - ldwh: :type: integer :intent: input :substitutions: ldwh: 3*nshfts-3 ldz: n ldwv: nv ldu: 3*nshfts-3 ldv: "3" :fortran_help: " SUBROUTINE DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, SR, SI, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, WV, LDWV, NH, WH, LDWH )\n\n\ * This auxiliary subroutine called by DLAQR0 performs a\n\ * single small-bulge multi-shift QR sweep.\n\ *\n\n\ * WANTT (input) logical scalar\n\ * WANTT = .true. if the quasi-triangular Schur factor\n\ * is being computed. WANTT is set to .false. otherwise.\n\ *\n\ * WANTZ (input) logical scalar\n\ * WANTZ = .true. if the orthogonal Schur factor is being\n\ * computed. WANTZ is set to .false. otherwise.\n\ *\n\ * KACC22 (input) integer with value 0, 1, or 2.\n\ * Specifies the computation mode of far-from-diagonal\n\ * orthogonal updates.\n\ * = 0: DLAQR5 does not accumulate reflections and does not\n\ * use matrix-matrix multiply to update far-from-diagonal\n\ * matrix entries.\n\ * = 1: DLAQR5 accumulates reflections and uses matrix-matrix\n\ * multiply to update the far-from-diagonal matrix entries.\n\ * = 2: DLAQR5 accumulates reflections, uses matrix-matrix\n\ * multiply to update the far-from-diagonal matrix entries,\n\ * and takes advantage of 2-by-2 block structure during\n\ * matrix multiplies.\n\ *\n\ * N (input) integer scalar\n\ * N is the order of the Hessenberg matrix H upon which this\n\ * subroutine operates.\n\ *\n\ * KTOP (input) integer scalar\n\ * KBOT (input) integer scalar\n\ * These are the first and last rows and columns of an\n\ * isolated diagonal block upon which the QR sweep is to be\n\ * applied. It is assumed without a check that\n\ * either KTOP = 1 or H(KTOP,KTOP-1) = 0\n\ * and\n\ * either KBOT = N or H(KBOT+1,KBOT) = 0.\n\ *\n\ * NSHFTS (input) integer scalar\n\ * NSHFTS gives the number of simultaneous shifts. NSHFTS\n\ * must be positive and even.\n\ *\n\ * SR (input/output) DOUBLE PRECISION array of size (NSHFTS)\n\ * SI (input/output) DOUBLE PRECISION array of size (NSHFTS)\n\ * SR contains the real parts and SI contains the imaginary\n\ * parts of the NSHFTS shifts of origin that define the\n\ * multi-shift QR sweep. On output SR and SI may be\n\ * reordered.\n\ *\n\ * H (input/output) DOUBLE PRECISION array of size (LDH,N)\n\ * On input H contains a Hessenberg matrix. On output a\n\ * multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied\n\ * to the isolated diagonal block in rows and columns KTOP\n\ * through KBOT.\n\ *\n\ * LDH (input) integer scalar\n\ * LDH is the leading dimension of H just as declared in the\n\ * calling procedure. LDH.GE.MAX(1,N).\n\ *\n\ * ILOZ (input) INTEGER\n\ * IHIZ (input) INTEGER\n\ * Specify the rows of Z to which transformations must be\n\ * applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N\n\ *\n\ * Z (input/output) DOUBLE PRECISION array of size (LDZ,IHI)\n\ * If WANTZ = .TRUE., then the QR Sweep orthogonal\n\ * similarity transformation is accumulated into\n\ * Z(ILOZ:IHIZ,ILO:IHI) from the right.\n\ * If WANTZ = .FALSE., then Z is unreferenced.\n\ *\n\ * LDZ (input) integer scalar\n\ * LDA is the leading dimension of Z just as declared in\n\ * the calling procedure. LDZ.GE.N.\n\ *\n\ * V (workspace) DOUBLE PRECISION array of size (LDV,NSHFTS/2)\n\ *\n\ * LDV (input) integer scalar\n\ * LDV is the leading dimension of V as declared in the\n\ * calling procedure. LDV.GE.3.\n\ *\n\ * U (workspace) DOUBLE PRECISION array of size\n\ * (LDU,3*NSHFTS-3)\n\ *\n\ * LDU (input) integer scalar\n\ * LDU is the leading dimension of U just as declared in the\n\ * in the calling subroutine. LDU.GE.3*NSHFTS-3.\n\ *\n\ * NH (input) integer scalar\n\ * NH is the number of columns in array WH available for\n\ * workspace. NH.GE.1.\n\ *\n\ * WH (workspace) DOUBLE PRECISION array of size (LDWH,NH)\n\ *\n\ * LDWH (input) integer scalar\n\ * Leading dimension of WH just as declared in the\n\ * calling procedure. LDWH.GE.3*NSHFTS-3.\n\ *\n\ * NV (input) integer scalar\n\ * NV is the number of rows in WV agailable for workspace.\n\ * NV.GE.1.\n\ *\n\ * WV (workspace) DOUBLE PRECISION array of size\n\ * (LDWV,3*NSHFTS-3)\n\ *\n\ * LDWV (input) integer scalar\n\ * LDWV is the leading dimension of WV as declared in the\n\ * in the calling subroutine. LDWV.GE.NV.\n\ *\n\n\ * ================================================================\n\ * Based on contributions by\n\ * Karen Braman and Ralph Byers, Department of Mathematics,\n\ * University of Kansas, USA\n\ *\n\ * ================================================================\n\ * Reference:\n\ *\n\ * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n\ * Algorithm Part I: Maintaining Well Focused Shifts, and\n\ * Level 3 Performance, SIAM Journal of Matrix Analysis,\n\ * volume 23, pages 929--947, 2002.\n\ *\n\ * ================================================================\n" ruby-lapack-1.7.2/dev/defs/clansy0000644000175000017500000000612412502223525016503 0ustar uwabamiuwabami--- :name: clansy :md5sum: 9e26445e2edd83a8a270cac207025f26 :category: :function :type: real :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "MAX(1,(lsame_(&norm,\"I\")||lsame_(&norm,\"1\")||lsame_(&norm,\"o\")) ? n : 0)" :substitutions: {} :fortran_help: " REAL FUNCTION CLANSY( NORM, UPLO, N, A, LDA, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLANSY returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * complex symmetric matrix A.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * CLANSY returns the value\n\ *\n\ * CLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in CLANSY as described\n\ * above.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is to be referenced.\n\ * = 'U': Upper triangular part of A is referenced\n\ * = 'L': Lower triangular part of A is referenced\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, CLANSY is\n\ * set to zero.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The symmetric matrix A. If UPLO = 'U', the leading n by n\n\ * upper triangular part of A contains the upper triangular part\n\ * of the matrix A, and the strictly lower triangular part of A\n\ * is not referenced. If UPLO = 'L', the leading n by n lower\n\ * triangular part of A contains the lower triangular part of\n\ * the matrix A, and the strictly upper triangular part of A is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(N,1).\n\ *\n\ * WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n\ * WORK is not referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgetrf0000644000175000017500000000454712502223526016475 0ustar uwabamiuwabami--- :name: dgetrf :md5sum: a4dcbe6d74786df056780307768b0b99 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGETRF computes an LU factorization of a general M-by-N matrix A\n\ * using partial pivoting with row interchanges.\n\ *\n\ * The factorization has the form\n\ * A = P * L * U\n\ * where P is a permutation matrix, L is lower triangular with unit\n\ * diagonal elements (lower trapezoidal if m > n), and U is upper\n\ * triangular (upper trapezoidal if m < n).\n\ *\n\ * This is the right-looking Level 3 BLAS version of the algorithm.\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 to be factored.\n\ * On exit, the factors L and U from the factorization\n\ * A = P*L*U; the unit diagonal elements of L are not stored.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * IPIV (output) INTEGER array, dimension (min(M,N))\n\ * The pivot indices; for 1 <= i <= min(M,N), row i of the\n\ * matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, and division by zero will occur if it is used\n\ * to solve a system of equations.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slaruv0000644000175000017500000000344012502223526016525 0ustar uwabamiuwabami--- :name: slaruv :md5sum: 83238be5ea5cc1426c39500d003d2f59 :category: :subroutine :arguments: - iseed: :type: integer :intent: input/output :dims: - "4" - n: :type: integer :intent: input - x: :type: real :intent: output :dims: - MAX(1,n) :substitutions: {} :fortran_help: " SUBROUTINE SLARUV( ISEED, N, X )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLARUV returns a vector of n random real numbers from a uniform (0,1)\n\ * distribution (n <= 128).\n\ *\n\ * This is an auxiliary routine called by SLARNV and CLARNV.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ISEED (input/output) INTEGER array, dimension (4)\n\ * On entry, the seed of the random number generator; the array\n\ * elements must be between 0 and 4095, and ISEED(4) must be\n\ * odd.\n\ * On exit, the seed is updated.\n\ *\n\ * N (input) INTEGER\n\ * The number of random numbers to be generated. N <= 128.\n\ *\n\ * X (output) REAL array, dimension (N)\n\ * The generated random numbers.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * This routine uses a multiplicative congruential method with modulus\n\ * 2**48 and multiplier 33952834046453 (see G.S.Fishman,\n\ * 'Multiplicative congruential random number generators with modulus\n\ * 2**b: an exhaustive analysis for b = 32 and a partial analysis for\n\ * b = 48', Math. Comp. 189, pp 331-344, 1990).\n\ *\n\ * 48-bit integers are stored in 4 integer array elements with 12 bits\n\ * per element. Hence the routine is portable across machines with\n\ * integers of 32 bits or more.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clarfx0000644000175000017500000000457412502223525016500 0ustar uwabamiuwabami--- :name: clarfx :md5sum: 9e263a35974f11168c2a951af14c6ac1 :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - v: :type: complex :intent: input :dims: - m - tau: :type: complex :intent: input - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " SUBROUTINE CLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLARFX applies a complex elementary reflector H to a complex m by n\n\ * matrix C, from either the left or the right. H is represented in the\n\ * form\n\ *\n\ * H = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar and v is a complex vector.\n\ *\n\ * If tau = 0, then H is taken to be the unit matrix\n\ *\n\ * This version uses inline code if H has order < 11.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': form H * C\n\ * = 'R': form C * H\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C.\n\ *\n\ * V (input) COMPLEX array, dimension (M) if SIDE = 'L'\n\ * or (N) if SIDE = 'R'\n\ * The vector v in the representation of H.\n\ *\n\ * TAU (input) COMPLEX\n\ * The value tau in the representation of H.\n\ *\n\ * C (input/output) COMPLEX array, dimension (LDC,N)\n\ * On entry, the m by n matrix C.\n\ * On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n\ * or C * H if SIDE = 'R'.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDA >= max(1,M).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (N) if SIDE = 'L'\n\ * or (M) if SIDE = 'R'\n\ * WORK is not referenced if H has order < 11.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/claswp0000644000175000017500000000447612502223525016513 0ustar uwabamiuwabami--- :name: claswp :md5sum: 4612b48da9d86f8d302ad0a932b6e32d :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - k1: :type: integer :intent: input - k2: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - k2*abs(incx) - incx: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE CLASWP( N, A, LDA, K1, K2, IPIV, INCX )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLASWP performs a series of row interchanges on the matrix A.\n\ * One row interchange is initiated for each of rows K1 through K2 of A.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix A.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the matrix of column dimension N to which the row\n\ * interchanges will be applied.\n\ * On exit, the permuted matrix.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ *\n\ * K1 (input) INTEGER\n\ * The first element of IPIV for which a row interchange will\n\ * be done.\n\ *\n\ * K2 (input) INTEGER\n\ * The last element of IPIV for which a row interchange will\n\ * be done.\n\ *\n\ * IPIV (input) INTEGER array, dimension (K2*abs(INCX))\n\ * The vector of pivot indices. Only the elements in positions\n\ * K1 through K2 of IPIV are accessed.\n\ * IPIV(K) = L implies rows K and L are to be interchanged.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between successive values of IPIV. If IPIV\n\ * is negative, the pivots are applied in reverse order.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Modified by\n\ * R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32\n COMPLEX TEMP\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cherfs0000644000175000017500000001215012502223525016460 0ustar uwabamiuwabami--- :name: cherfs :md5sum: d7c39ab75eb88e3a1a1e8ea96480eedf :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CHERFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHERFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is Hermitian indefinite, and\n\ * provides error bounds and backward error estimates for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The Hermitian matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular part\n\ * of the matrix A, and the strictly lower triangular part of A\n\ * is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of A contains the lower triangular part of\n\ * the matrix A, and the strictly upper triangular part of A is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX array, dimension (LDAF,N)\n\ * The factored form of the matrix A. AF contains the block\n\ * diagonal matrix D and the multipliers used to obtain the\n\ * factor U or L from the factorization A = U*D*U**H or\n\ * A = L*D*L**H as computed by CHETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by CHETRF.\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) COMPLEX array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by CHETRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zsyswapr0000644000175000017500000000435712502223526017123 0ustar uwabamiuwabami--- :name: zsyswapr :md5sum: a06299b5ca7909daadcca4963ee3a42b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - i1: :type: integer :intent: input - i2: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE ZSYSWAPR( UPLO, N, A, I1, I2)\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSYSWAPR applies an elementary permutation on the rows and the columns of\n\ * a symmetric matrix.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE COMPLEX array, dimension (LDA,N)\n\ * On entry, the NB diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L as computed by ZSYTRF.\n\ *\n\ * On exit, if INFO = 0, the (symmetric) inverse of the original\n\ * matrix. If UPLO = 'U', the upper triangular part of the\n\ * inverse is formed and the part of A below the diagonal is not\n\ * referenced; if UPLO = 'L' the lower triangular part of the\n\ * inverse is formed and the part of A above the diagonal is\n\ * not referenced.\n\ *\n\ * I1 (input) INTEGER\n\ * Index of the first row to swap\n\ *\n\ * I2 (input) INTEGER\n\ * Index of the second row to swap\n\ *\n\n\ * =====================================================================\n\ *\n\ * ..\n\ * .. Local Scalars ..\n LOGICAL UPPER\n INTEGER I\n DOUBLE COMPLEX TMP\n\ *\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL ZSWAP\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/spbrfs0000644000175000017500000001171712502223526016516 0ustar uwabamiuwabami--- :name: spbrfs :md5sum: b02855b62236c3e7a01af09522487131 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: real :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPBRFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is symmetric positive definite\n\ * and banded, and provides error bounds and backward error estimates\n\ * for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AB (input) REAL array, dimension (LDAB,N)\n\ * The upper or lower triangle of the symmetric band matrix A,\n\ * stored in the first KD+1 rows of the array. The j-th column\n\ * of A is stored in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * AFB (input) REAL array, dimension (LDAFB,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T of the band matrix A as computed by\n\ * SPBTRF, in the same storage format as A (see AB).\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= KD+1.\n\ *\n\ * B (input) REAL array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) REAL array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by SPBTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) REAL array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dorml20000644000175000017500000000735412502223526016420 0ustar uwabamiuwabami--- :name: dorml2 :md5sum: bf58654a0eb1ae3bde80e6d4b318343f :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DORML2 overwrites the general real m by n matrix C with\n\ *\n\ * Q * C if SIDE = 'L' and TRANS = 'N', or\n\ *\n\ * Q'* C if SIDE = 'L' and TRANS = 'T', or\n\ *\n\ * C * Q if SIDE = 'R' and TRANS = 'N', or\n\ *\n\ * C * Q' if SIDE = 'R' and TRANS = 'T',\n\ *\n\ * where Q is a real orthogonal matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(k) . . . H(2) H(1)\n\ *\n\ * as returned by DGELQF. Q is of order m if SIDE = 'L' and of order n\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q' from the Left\n\ * = 'R': apply Q or Q' from the Right\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': apply Q (No transpose)\n\ * = 'T': apply Q' (Transpose)\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension\n\ * (LDA,M) if SIDE = 'L',\n\ * (LDA,N) if SIDE = 'R'\n\ * The i-th row must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * DGELQF in the first k rows of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,K).\n\ *\n\ * TAU (input) DOUBLE PRECISION array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by DGELQF.\n\ *\n\ * C (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n\ * On entry, the m by n matrix C.\n\ * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension\n\ * (N) if SIDE = 'L',\n\ * (M) if SIDE = 'R'\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlaed00000644000175000017500000001235612502223526016350 0ustar uwabamiuwabami--- :name: dlaed0 :md5sum: 337ae89b96bbbde72236a7ce62eb8536 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - qsiz: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input :dims: - n-1 - q: :type: doublereal :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - qstore: :type: doublereal :intent: workspace :dims: - ldqs - n - ldqs: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - "((icompq == 0) || (icompq == 1)) ? 1 + 3*n + 2*n*LG(n) + 2*pow(n,2) : icompq == 2 ? 4*n + pow(n,2) : 0" - iwork: :type: integer :intent: workspace :dims: - "((icompq == 0) || (icompq == 1)) ? 6 + 6*n + 5*n*LG(n) : icompq == 2 ? 3 + 5*n : 0" - info: :type: integer :intent: output :substitutions: ldqs: "icompq == 1 ? MAX(1,n) : 1" :fortran_help: " SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAED0 computes all eigenvalues and corresponding eigenvectors of a\n\ * symmetric tridiagonal matrix using the divide and conquer method.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ICOMPQ (input) INTEGER\n\ * = 0: Compute eigenvalues only.\n\ * = 1: Compute eigenvectors of original dense symmetric matrix\n\ * also. On entry, Q contains the orthogonal matrix used\n\ * to reduce the original matrix to tridiagonal form.\n\ * = 2: Compute eigenvalues and eigenvectors of tridiagonal\n\ * matrix.\n\ *\n\ * QSIZ (input) INTEGER\n\ * The dimension of the orthogonal matrix used to reduce\n\ * the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.\n\ *\n\ * N (input) INTEGER\n\ * The dimension of the symmetric tridiagonal matrix. N >= 0.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the main diagonal of the tridiagonal matrix.\n\ * On exit, its eigenvalues.\n\ *\n\ * E (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The off-diagonal elements of the tridiagonal matrix.\n\ * On exit, E has been destroyed.\n\ *\n\ * Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)\n\ * On entry, Q must contain an N-by-N orthogonal matrix.\n\ * If ICOMPQ = 0 Q is not referenced.\n\ * If ICOMPQ = 1 On entry, Q is a subset of the columns of the\n\ * orthogonal matrix used to reduce the full\n\ * matrix to tridiagonal form corresponding to\n\ * the subset of the full matrix which is being\n\ * decomposed at this time.\n\ * If ICOMPQ = 2 On entry, Q will be the identity matrix.\n\ * On exit, Q contains the eigenvectors of the\n\ * tridiagonal matrix.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. If eigenvectors are\n\ * desired, then LDQ >= max(1,N). In any case, LDQ >= 1.\n\ *\n\ * QSTORE (workspace) DOUBLE PRECISION array, dimension (LDQS, N)\n\ * Referenced only when ICOMPQ = 1. Used to store parts of\n\ * the eigenvector matrix when the updating matrix multiplies\n\ * take place.\n\ *\n\ * LDQS (input) INTEGER\n\ * The leading dimension of the array QSTORE. If ICOMPQ = 1,\n\ * then LDQS >= max(1,N). In any case, LDQS >= 1.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array,\n\ * If ICOMPQ = 0 or 1, the dimension of WORK must be at least\n\ * 1 + 3*N + 2*N*lg N + 2*N**2\n\ * ( lg( N ) = smallest integer k\n\ * such that 2^k >= N )\n\ * If ICOMPQ = 2, the dimension of WORK must be at least\n\ * 4*N + N**2.\n\ *\n\ * IWORK (workspace) INTEGER array,\n\ * If ICOMPQ = 0 or 1, the dimension of IWORK must be at least\n\ * 6 + 6*N + 5*N*lg N.\n\ * ( lg( N ) = smallest integer k\n\ * such that 2^k >= N )\n\ * If ICOMPQ = 2, the dimension of IWORK must be at least\n\ * 3 + 5*N.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit.\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * > 0: The algorithm failed to compute an eigenvalue while\n\ * working on the submatrix lying in rows and columns\n\ * INFO/(N+1) through mod(INFO,N+1).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Jeff Rutter, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zsytri20000644000175000017500000000742612502223526016647 0ustar uwabamiuwabami--- :name: zsytri2 :md5sum: 250ab7ce23ae359ab3d198b664d5bf4b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublecomplex :intent: workspace :dims: - lwork - lwork: :type: integer :intent: input :option: true :default: (n+nb+1)*(nb+3) - info: :type: integer :intent: output :substitutions: c__1: "1" c__m1: "-1" lwork: (n+nb+1)*(nb+3) nb: ilaenv_(&c__1, "ZSYTRF", &uplo, &n, &c__m1, &c__m1, &c__m1) :extras: c__1: integer c__m1: integer nb: integer :fortran_help: " SUBROUTINE ZSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSYTRI2 computes the inverse of a complex symmetric indefinite matrix\n\ * A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n\ * ZSYTRF. ZSYTRI2 sets the LEADING DIMENSION of the workspace\n\ * before calling ZSYTRI2X that actually computes the inverse.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE COMPLEX array, dimension (LDA,N)\n\ * On entry, the NB diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L as computed by ZSYTRF.\n\ *\n\ * On exit, if INFO = 0, the (symmetric) inverse of the original\n\ * matrix. If UPLO = 'U', the upper triangular part of the\n\ * inverse is formed and the part of A below the diagonal is not\n\ * referenced; if UPLO = 'L' the lower triangular part of the\n\ * inverse is formed and the part of A above the diagonal is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the NB structure of D\n\ * as determined by ZSYTRF.\n\ *\n\ * WORK (workspace) DOUBLE COMPLEX array, dimension (N+NB+1)*(NB+3)\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK.\n\ * WORK is size >= (N+NB+1)*(NB+3)\n\ * If LDWORK = -1, then a workspace query is assumed; the routine\n\ * calculates:\n\ * - the optimal size of the WORK array, returns\n\ * this value as the first entry of the WORK array,\n\ * - and no error message related to LDWORK 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, D(i,i) = 0; the matrix is singular and its\n\ * inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL UPPER, LQUERY\n INTEGER MINSIZE, NBMAX\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL ZSYTRI2X\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zlarfb0000644000175000017500000000770212502223526016476 0ustar uwabamiuwabami--- :name: zlarfb :md5sum: 627c934444abbc66d8956c26ce0a6217 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - direct: :type: char :intent: input - storev: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - v: :type: doublecomplex :intent: input :dims: - ldv - k - ldv: :type: integer :intent: input - t: :type: doublecomplex :intent: input :dims: - ldt - k - ldt: :type: integer :intent: input - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - ldwork - k - ldwork: :type: integer :intent: input :substitutions: ldwork: "MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0" :fortran_help: " SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLARFB applies a complex block reflector H or its transpose H' to a\n\ * complex M-by-N matrix C, from either the left or the right.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply H or H' from the Left\n\ * = 'R': apply H or H' from the Right\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': apply H (No transpose)\n\ * = 'C': apply H' (Conjugate transpose)\n\ *\n\ * DIRECT (input) CHARACTER*1\n\ * Indicates how H is formed from a product of elementary\n\ * reflectors\n\ * = 'F': H = H(1) H(2) . . . H(k) (Forward)\n\ * = 'B': H = H(k) . . . H(2) H(1) (Backward)\n\ *\n\ * STOREV (input) CHARACTER*1\n\ * Indicates how the vectors which define the elementary\n\ * reflectors are stored:\n\ * = 'C': Columnwise\n\ * = 'R': Rowwise\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C.\n\ *\n\ * K (input) INTEGER\n\ * The order of the matrix T (= the number of elementary\n\ * reflectors whose product defines the block reflector).\n\ *\n\ * V (input) COMPLEX*16 array, dimension\n\ * (LDV,K) if STOREV = 'C'\n\ * (LDV,M) if STOREV = 'R' and SIDE = 'L'\n\ * (LDV,N) if STOREV = 'R' and SIDE = 'R'\n\ * The matrix V. See further details.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V.\n\ * If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);\n\ * if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);\n\ * if STOREV = 'R', LDV >= K.\n\ *\n\ * T (input) COMPLEX*16 array, dimension (LDT,K)\n\ * The triangular K-by-K matrix T in the representation of the\n\ * block reflector.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= K.\n\ *\n\ * C (input/output) COMPLEX*16 array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by H*C or H'*C or C*H or C*H'.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (LDWORK,K)\n\ *\n\ * LDWORK (input) INTEGER\n\ * The leading dimension of the array WORK.\n\ * If SIDE = 'L', LDWORK >= max(1,N);\n\ * if SIDE = 'R', LDWORK >= max(1,M).\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssygvd0000644000175000017500000001715512502223526016540 0ustar uwabamiuwabami--- :name: ssygvd :md5sum: 89917a8e36f69459391a1b240a601bff :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 2*n+1 : lsame_(&jobz,\"V\") ? 1+6*n+2*n*n : 1" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSYGVD computes all the eigenvalues, and optionally, the eigenvectors\n\ * of a real generalized symmetric-definite eigenproblem, of the form\n\ * A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n\ * B are assumed to be symmetric and B is also positive definite.\n\ * If eigenvectors are desired, it uses a divide and conquer algorithm.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * Specifies the problem type to be solved:\n\ * = 1: A*x = (lambda)*B*x\n\ * = 2: A*B*x = (lambda)*x\n\ * = 3: B*A*x = (lambda)*x\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA, N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of A contains the\n\ * upper triangular part of the matrix A. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of A contains\n\ * the lower triangular part of the matrix A.\n\ *\n\ * On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n\ * matrix Z of eigenvectors. The eigenvectors are normalized\n\ * as follows:\n\ * if ITYPE = 1 or 2, Z**T*B*Z = I;\n\ * if ITYPE = 3, Z**T*inv(B)*Z = I.\n\ * If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n\ * or the lower triangle (if UPLO='L') of A, including the\n\ * diagonal, is destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) REAL array, dimension (LDB, N)\n\ * On entry, the symmetric matrix B. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of B contains the\n\ * upper triangular part of the matrix B. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of B contains\n\ * the lower triangular part of the matrix B.\n\ *\n\ * On exit, if INFO <= N, the part of B containing the matrix is\n\ * overwritten by the triangular factor U or L from the Cholesky\n\ * factorization B = U**T*U or B = L*L**T.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * WORK (workspace/output) REAL 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\ * If N <= 1, LWORK >= 1.\n\ * If JOBZ = 'N' and N > 1, LWORK >= 2*N+1.\n\ * If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the optimal sizes of the WORK and IWORK\n\ * arrays, returns these values as the first entries of the WORK\n\ * and IWORK arrays, and no error message related to LWORK or\n\ * LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK.\n\ * If N <= 1, LIWORK >= 1.\n\ * If JOBZ = 'N' and N > 1, LIWORK >= 1.\n\ * If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK and IWORK arrays, and no error message related to\n\ * LWORK or LIWORK 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: SPOTRF or SSYEVD returned an error code:\n\ * <= N: if INFO = i and JOBZ = 'N', then the algorithm\n\ * failed to converge; i off-diagonal elements of an\n\ * intermediate tridiagonal form did not converge to\n\ * zero;\n\ * if INFO = i and JOBZ = 'V', then the algorithm\n\ * failed to compute an eigenvalue while working on\n\ * the submatrix lying in rows and columns INFO/(N+1)\n\ * through mod(INFO,N+1);\n\ * > N: if INFO = N + i, for 1 <= i <= N, then the leading\n\ * minor of order i of B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n\ *\n\ * Modified so that no backsubstitution is performed if SSYEVD fails to\n\ * converge (NEIG in old code could be greater than N causing out of\n\ * bounds reference to A - reported by Ralf Meyer). Also corrected the\n\ * description of INFO and the test on ITYPE. Sven, 16 Feb 05.\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsprfs0000644000175000017500000001151012502223526016507 0ustar uwabamiuwabami--- :name: dsprfs :md5sum: f0af4a880340cc82d7c68a365633767b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - n*(n+1)/2 - afp: :type: doublereal :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSPRFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is symmetric indefinite\n\ * and packed, and provides error bounds and backward error estimates\n\ * for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * The upper or lower triangle of the symmetric matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * AFP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * The factored form of the matrix A. AFP contains the block\n\ * diagonal matrix D and the multipliers used to obtain the\n\ * factor U or L from the factorization A = U*D*U**T or\n\ * A = L*D*L**T as computed by DSPTRF, stored as a packed\n\ * triangular matrix.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by DSPTRF.\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by DSPTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlangb0000644000175000017500000000552712502223526016476 0ustar uwabamiuwabami--- :name: zlangb :md5sum: 4120e61255d0848a64b6de95b2ceac7d :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - "MAX(1,lsame_(&norm,\"I\") ? n : 0)" :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION ZLANGB( NORM, N, KL, KU, AB, LDAB, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLANGB returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of an\n\ * n by n band matrix A, with kl sub-diagonals and ku super-diagonals.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * ZLANGB returns the value\n\ *\n\ * ZLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in ZLANGB as described\n\ * above.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, ZLANGB is\n\ * set to zero.\n\ *\n\ * KL (input) INTEGER\n\ * The number of sub-diagonals of the matrix A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of super-diagonals of the matrix A. KU >= 0.\n\ *\n\ * AB (input) COMPLEX*16 array, dimension (LDAB,N)\n\ * The band matrix A, stored in rows 1 to KL+KU+1. The j-th\n\ * column of A is stored in the j-th column of the array AB as\n\ * follows:\n\ * AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n\ * referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clarzb0000644000175000017500000001032212502223525016462 0ustar uwabamiuwabami--- :name: clarzb :md5sum: b1a6ab49c9ee4c3c63094d8f6e6eb92a :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - direct: :type: char :intent: input - storev: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - v: :type: complex :intent: input :dims: - ldv - nv - ldv: :type: integer :intent: input - t: :type: complex :intent: input :dims: - ldt - k - ldt: :type: integer :intent: input - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - ldwork - k - ldwork: :type: integer :intent: input :substitutions: ldwork: "MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0" :fortran_help: " SUBROUTINE CLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLARZB applies a complex block reflector H or its transpose H**H\n\ * to a complex distributed M-by-N C from the left or the right.\n\ *\n\ * Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply H or H' from the Left\n\ * = 'R': apply H or H' from the Right\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': apply H (No transpose)\n\ * = 'C': apply H' (Conjugate transpose)\n\ *\n\ * DIRECT (input) CHARACTER*1\n\ * Indicates how H is formed from a product of elementary\n\ * reflectors\n\ * = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n\ * = 'B': H = H(k) . . . H(2) H(1) (Backward)\n\ *\n\ * STOREV (input) CHARACTER*1\n\ * Indicates how the vectors which define the elementary\n\ * reflectors are stored:\n\ * = 'C': Columnwise (not supported yet)\n\ * = 'R': Rowwise\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C.\n\ *\n\ * K (input) INTEGER\n\ * The order of the matrix T (= the number of elementary\n\ * reflectors whose product defines the block reflector).\n\ *\n\ * L (input) INTEGER\n\ * The number of columns of the matrix V containing the\n\ * meaningful part of the Householder reflectors.\n\ * If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n\ *\n\ * V (input) COMPLEX array, dimension (LDV,NV).\n\ * If STOREV = 'C', NV = K; if STOREV = 'R', NV = L.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V.\n\ * If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K.\n\ *\n\ * T (input) COMPLEX array, dimension (LDT,K)\n\ * The triangular K-by-K matrix T in the representation of the\n\ * block reflector.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= K.\n\ *\n\ * C (input/output) COMPLEX array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by H*C or H'*C or C*H or C*H'.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (LDWORK,K)\n\ *\n\ * LDWORK (input) INTEGER\n\ * The leading dimension of the array WORK.\n\ * If SIDE = 'L', LDWORK >= max(1,N);\n\ * if SIDE = 'R', LDWORK >= max(1,M).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sstevr0000644000175000017500000002475212502223526016550 0ustar uwabamiuwabami--- :name: sstevr :md5sum: e5ea156e311e0d701679c0e4fa1a3c85 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - MAX(1,n-1) - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 20*n - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: 10*n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"I\") ? iu-il+1 : n" :fortran_help: " SUBROUTINE SSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSTEVR computes selected eigenvalues and, optionally, eigenvectors\n\ * of a real symmetric tridiagonal matrix T. Eigenvalues and\n\ * eigenvectors can be selected by specifying either a range of values\n\ * or a range of indices for the desired eigenvalues.\n\ *\n\ * Whenever possible, SSTEVR calls SSTEMR to compute the\n\ * eigenspectrum using Relatively Robust Representations. SSTEMR\n\ * computes eigenvalues by the dqds algorithm, while orthogonal\n\ * eigenvectors are computed from various \"good\" L D L^T representations\n\ * (also known as Relatively Robust Representations). Gram-Schmidt\n\ * orthogonalization is avoided as far as possible. More specifically,\n\ * the various steps of the algorithm are as follows. For the i-th\n\ * unreduced block of T,\n\ * (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T\n\ * is a relatively robust representation,\n\ * (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high\n\ * relative accuracy by the dqds algorithm,\n\ * (c) If there is a cluster of close eigenvalues, \"choose\" sigma_i\n\ * close to the cluster, and go to step (a),\n\ * (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T,\n\ * compute the corresponding eigenvector by forming a\n\ * rank-revealing twisted factorization.\n\ * The desired accuracy of the output can be specified by the input\n\ * parameter ABSTOL.\n\ *\n\ * For more details, see \"A new O(n^2) algorithm for the symmetric\n\ * tridiagonal eigenvalue/eigenvector problem\", by Inderjit Dhillon,\n\ * Computer Science Division Technical Report No. UCB//CSD-97-971,\n\ * UC Berkeley, May 1997.\n\ *\n\ *\n\ * Note 1 : SSTEVR calls SSTEMR when the full spectrum is requested\n\ * on machines which conform to the ieee-754 floating point standard.\n\ * SSTEVR calls SSTEBZ and SSTEIN on non-ieee machines and\n\ * when partial spectrum requests are made.\n\ *\n\ * Normal execution of SSTEMR may create NaNs and infinities and\n\ * hence may abort due to a floating point exception in environments\n\ * which do not handle NaNs and infinities in the ieee standard default\n\ * manner.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found.\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found.\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ ********** For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and\n\ ********** SSTEIN are called\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the n diagonal elements of the tridiagonal matrix\n\ * A.\n\ * On exit, D may be multiplied by a constant factor chosen\n\ * to avoid over/underflow in computing the eigenvalues.\n\ *\n\ * E (input/output) REAL array, dimension (max(1,N-1))\n\ * On entry, the (n-1) subdiagonal elements of the tridiagonal\n\ * matrix A in elements 1 to N-1 of E.\n\ * On exit, E may be multiplied by a constant factor chosen\n\ * to avoid over/underflow in computing the eigenvalues.\n\ *\n\ * VL (input) REAL\n\ * VU (input) REAL\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) REAL\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less than\n\ * or equal to zero, then EPS*|T| will be used in its place,\n\ * where |T| is the 1-norm of the tridiagonal matrix obtained\n\ * by reducing A to tridiagonal form.\n\ *\n\ * See \"Computing Small Singular Values of Bidiagonal Matrices\n\ * with Guaranteed High Relative Accuracy,\" by Demmel and\n\ * Kahan, LAPACK Working Note #3.\n\ *\n\ * If high relative accuracy is important, set ABSTOL to\n\ * SLAMCH( 'Safe minimum' ). Doing so will guarantee that\n\ * eigenvalues are computed to high relative accuracy when\n\ * possible in future releases. The current code does not\n\ * make any guarantees about high relative accuracy, but\n\ * future releases will. See J. Barlow and J. Demmel,\n\ * \"Computing Accurate Eigensystems of Scaled Diagonally\n\ * Dominant Matrices\", LAPACK Working Note #7, for a discussion\n\ * of which matrices define their eigenvalues to high relative\n\ * accuracy.\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * The first M elements contain the selected eigenvalues in\n\ * ascending order.\n\ *\n\ * Z (output) REAL array, dimension (LDZ, max(1,M) )\n\ * If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix A\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )\n\ * The support of the eigenvectors in Z, i.e., the indices\n\ * indicating the nonzero elements in Z. The i-th eigenvector\n\ * is nonzero only in elements ISUPPZ( 2*i-1 ) through\n\ * ISUPPZ( 2*i ).\n\ ********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1\n\ *\n\ * WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal (and\n\ * minimal) LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK >= 20*N.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the optimal sizes of the WORK and IWORK\n\ * arrays, returns these values as the first entries of the WORK\n\ * and IWORK arrays, and no error message related to LWORK or\n\ * LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal (and\n\ * minimal) LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK. LIWORK >= 10*N.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK and IWORK arrays, and no error message related to\n\ * LWORK or LIWORK 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: Internal error\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Inderjit Dhillon, IBM Almaden, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Ken Stanley, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ * Jason Riedy, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgerq20000644000175000017500000000520212502223526016421 0ustar uwabamiuwabami--- :name: zgerq2 :md5sum: baea0cbe70a2bf4011f56458fb1c6ba4 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - MIN(m,n) - work: :type: doublecomplex :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE ZGERQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGERQ2 computes an RQ factorization of a complex m by n matrix A:\n\ * A = R * 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) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the m by n matrix A.\n\ * On exit, if m <= n, the upper triangle of the subarray\n\ * A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;\n\ * if m >= n, the elements on and above the (m-n)-th subdiagonal\n\ * contain the m by n upper trapezoidal matrix R; the remaining\n\ * elements, with the array TAU, represent the unitary matrix\n\ * Q as a product of elementary reflectors (see Further\n\ * Details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (output) COMPLEX*16 array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace) COMPLEX*16 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(1)' H(2)' . . . H(k)', 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 complex scalar, and v is a complex vector with\n\ * v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on\n\ * exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/strsen0000644000175000017500000002550212502223526016532 0ustar uwabamiuwabami--- :name: strsen :md5sum: dffc2bc2dac37c71e5e862aa4bf0cc53 :category: :subroutine :arguments: - job: :type: char :intent: input - compq: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - t: :type: real :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - q: :type: real :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - wr: :type: real :intent: output :dims: - n - wi: :type: real :intent: output :dims: - n - m: :type: integer :intent: output - s: :type: real :intent: output - sep: :type: real :intent: output - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&job,\"N\") ? n : lsame_(&job,\"E\") ? m*(n-m) : (lsame_(&job,\"V\")||lsame_(&job,\"B\")) ? 2*m*(n-m) : 0" - iwork: :type: integer :intent: workspace :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE STRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STRSEN reorders the real Schur factorization of a real matrix\n\ * A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in\n\ * the leading diagonal blocks of the upper quasi-triangular matrix T,\n\ * and the leading columns of Q form an orthonormal basis of the\n\ * corresponding right invariant subspace.\n\ *\n\ * Optionally the routine computes the reciprocal condition numbers of\n\ * the cluster of eigenvalues and/or the invariant subspace.\n\ *\n\ * T must be in Schur canonical form (as returned by SHSEQR), that is,\n\ * block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each\n\ * 2-by-2 diagonal block has its diagonal elemnts equal and its\n\ * off-diagonal elements of opposite sign.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * Specifies whether condition numbers are required for the\n\ * cluster of eigenvalues (S) or the invariant subspace (SEP):\n\ * = 'N': none;\n\ * = 'E': for eigenvalues only (S);\n\ * = 'V': for invariant subspace only (SEP);\n\ * = 'B': for both eigenvalues and invariant subspace (S and\n\ * SEP).\n\ *\n\ * COMPQ (input) CHARACTER*1\n\ * = 'V': update the matrix Q of Schur vectors;\n\ * = 'N': do not update Q.\n\ *\n\ * SELECT (input) LOGICAL array, dimension (N)\n\ * SELECT specifies the eigenvalues in the selected cluster. To\n\ * select a real eigenvalue w(j), SELECT(j) must be set to\n\ * .TRUE.. To select a complex conjugate pair of eigenvalues\n\ * w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,\n\ * either SELECT(j) or SELECT(j+1) or both must be set to\n\ * .TRUE.; a complex conjugate pair of eigenvalues must be\n\ * either both included in the cluster or both excluded.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix T. N >= 0.\n\ *\n\ * T (input/output) REAL array, dimension (LDT,N)\n\ * On entry, the upper quasi-triangular matrix T, in Schur\n\ * canonical form.\n\ * On exit, T is overwritten by the reordered matrix T, again in\n\ * Schur canonical form, with the selected eigenvalues in the\n\ * leading diagonal blocks.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= max(1,N).\n\ *\n\ * Q (input/output) REAL array, dimension (LDQ,N)\n\ * On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n\ * On exit, if COMPQ = 'V', Q has been postmultiplied by the\n\ * orthogonal transformation matrix which reorders T; the\n\ * leading M columns of Q form an orthonormal basis for the\n\ * specified invariant subspace.\n\ * If COMPQ = 'N', Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q.\n\ * LDQ >= 1; and if COMPQ = 'V', LDQ >= N.\n\ *\n\ * WR (output) REAL array, dimension (N)\n\ * WI (output) REAL array, dimension (N)\n\ * The real and imaginary parts, respectively, of the reordered\n\ * eigenvalues of T. The eigenvalues are stored in the same\n\ * order as on the diagonal of T, with WR(i) = T(i,i) and, if\n\ * T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and\n\ * WI(i+1) = -WI(i). Note that if a complex eigenvalue is\n\ * sufficiently ill-conditioned, then its value may differ\n\ * significantly from its value before reordering.\n\ *\n\ * M (output) INTEGER\n\ * The dimension of the specified invariant subspace.\n\ * 0 < = M <= N.\n\ *\n\ * S (output) REAL\n\ * If JOB = 'E' or 'B', S is a lower bound on the reciprocal\n\ * condition number for the selected cluster of eigenvalues.\n\ * S cannot underestimate the true reciprocal condition number\n\ * by more than a factor of sqrt(N). If M = 0 or N, S = 1.\n\ * If JOB = 'N' or 'V', S is not referenced.\n\ *\n\ * SEP (output) REAL\n\ * If JOB = 'V' or 'B', SEP is the estimated reciprocal\n\ * condition number of the specified invariant subspace. If\n\ * M = 0 or N, SEP = norm(T).\n\ * If JOB = 'N' or 'E', SEP is not referenced.\n\ *\n\ * WORK (workspace/output) REAL 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\ * If JOB = 'N', LWORK >= max(1,N);\n\ * if JOB = 'E', LWORK >= max(1,M*(N-M));\n\ * if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).\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\ * IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK.\n\ * If JOB = 'N' or 'E', LIWORK >= 1;\n\ * if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)).\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal size of the IWORK array,\n\ * returns this value as the first entry of the IWORK array, and\n\ * no error message related to LIWORK 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\ * = 1: reordering of T failed because some eigenvalues are too\n\ * close to separate (the problem is very ill-conditioned);\n\ * T may have been partially reordered, and WR and WI\n\ * contain the eigenvalues in the same order as in T; S and\n\ * SEP (if requested) are set to zero.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * STRSEN first collects the selected eigenvalues by computing an\n\ * orthogonal transformation Z to move them to the top left corner of T.\n\ * In other words, the selected eigenvalues are the eigenvalues of T11\n\ * in:\n\ *\n\ * Z'*T*Z = ( T11 T12 ) n1\n\ * ( 0 T22 ) n2\n\ * n1 n2\n\ *\n\ * where N = n1+n2 and Z' means the transpose of Z. The first n1 columns\n\ * of Z span the specified invariant subspace of T.\n\ *\n\ * If T has been obtained from the real Schur factorization of a matrix\n\ * A = Q*T*Q', then the reordered real Schur factorization of A is given\n\ * by A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span\n\ * the corresponding invariant subspace of A.\n\ *\n\ * The reciprocal condition number of the average of the eigenvalues of\n\ * T11 may be returned in S. S lies between 0 (very badly conditioned)\n\ * and 1 (very well conditioned). It is computed as follows. First we\n\ * compute R so that\n\ *\n\ * P = ( I R ) n1\n\ * ( 0 0 ) n2\n\ * n1 n2\n\ *\n\ * is the projector on the invariant subspace associated with T11.\n\ * R is the solution of the Sylvester equation:\n\ *\n\ * T11*R - R*T22 = T12.\n\ *\n\ * Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote\n\ * the two-norm of M. Then S is computed as the lower bound\n\ *\n\ * (1 + F-norm(R)**2)**(-1/2)\n\ *\n\ * on the reciprocal of 2-norm(P), the true reciprocal condition number.\n\ * S cannot underestimate 1 / 2-norm(P) by more than a factor of\n\ * sqrt(N).\n\ *\n\ * An approximate error bound for the computed average of the\n\ * eigenvalues of T11 is\n\ *\n\ * EPS * norm(T) / S\n\ *\n\ * where EPS is the machine precision.\n\ *\n\ * The reciprocal condition number of the right invariant subspace\n\ * spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.\n\ * SEP is defined as the separation of T11 and T22:\n\ *\n\ * sep( T11, T22 ) = sigma-min( C )\n\ *\n\ * where sigma-min(C) is the smallest singular value of the\n\ * n1*n2-by-n1*n2 matrix\n\ *\n\ * C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )\n\ *\n\ * I(m) is an m by m identity matrix, and kprod denotes the Kronecker\n\ * product. We estimate sigma-min(C) by the reciprocal of an estimate of\n\ * the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)\n\ * cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).\n\ *\n\ * When SEP is small, small changes in T can cause large changes in\n\ * the invariant subspace. An approximate bound on the maximum angular\n\ * error in the computed right invariant subspace is\n\ *\n\ * EPS * norm(T) / SEP\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlatrd0000644000175000017500000001407612502223526016520 0ustar uwabamiuwabami--- :name: zlatrd :md5sum: ae6def33901a9d780e3ccd3da388b4a5 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - e: :type: doublereal :intent: output :dims: - n-1 - tau: :type: doublecomplex :intent: output :dims: - n-1 - w: :type: doublecomplex :intent: output :dims: - ldw - MAX(n,nb) - ldw: :type: integer :intent: input :substitutions: ldw: MAX(1,n) :fortran_help: " SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLATRD reduces NB rows and columns of a complex Hermitian matrix A to\n\ * Hermitian tridiagonal form by a unitary similarity\n\ * transformation Q' * A * Q, and returns the matrices V and W which are\n\ * needed to apply the transformation to the unreduced part of A.\n\ *\n\ * If UPLO = 'U', ZLATRD reduces the last NB rows and columns of a\n\ * matrix, of which the upper triangle is supplied;\n\ * if UPLO = 'L', ZLATRD reduces the first NB rows and columns of a\n\ * matrix, of which the lower triangle is supplied.\n\ *\n\ * This is an auxiliary routine called by ZHETRD.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * Hermitian matrix A is stored:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A.\n\ *\n\ * NB (input) INTEGER\n\ * The number of rows and columns to be reduced.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the leading\n\ * n-by-n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n-by-n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ * On exit:\n\ * if UPLO = 'U', the last NB columns have been reduced to\n\ * tridiagonal form, with the diagonal elements overwriting\n\ * the diagonal elements of A; the elements above the diagonal\n\ * with the array TAU, represent the unitary matrix Q as a\n\ * product of elementary reflectors;\n\ * if UPLO = 'L', the first NB columns have been reduced to\n\ * tridiagonal form, with the diagonal elements overwriting\n\ * the diagonal elements of A; the elements below the diagonal\n\ * with the array TAU, represent the unitary matrix Q as a\n\ * product of elementary reflectors.\n\ * See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * E (output) DOUBLE PRECISION array, dimension (N-1)\n\ * If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal\n\ * elements of the last NB columns of the reduced matrix;\n\ * if UPLO = 'L', E(1:nb) contains the subdiagonal elements of\n\ * the first NB columns of the reduced matrix.\n\ *\n\ * TAU (output) COMPLEX*16 array, dimension (N-1)\n\ * The scalar factors of the elementary reflectors, stored in\n\ * TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.\n\ * See Further Details.\n\ *\n\ * W (output) COMPLEX*16 array, dimension (LDW,NB)\n\ * The n-by-nb matrix W required to update the unreduced part\n\ * of A.\n\ *\n\ * LDW (input) INTEGER\n\ * The leading dimension of the array W. LDW >= max(1,N).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * If UPLO = 'U', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(n) H(n-1) . . . H(n-nb+1).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar, and v is a complex vector with\n\ * v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),\n\ * and tau in TAU(i-1).\n\ *\n\ * If UPLO = 'L', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(nb).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar, and v is a complex vector with\n\ * v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),\n\ * and tau in TAU(i).\n\ *\n\ * The elements of the vectors v together form the n-by-nb matrix V\n\ * which is needed, with W, to apply the transformation to the unreduced\n\ * part of the matrix, using a Hermitian rank-2k update of the form:\n\ * A := A - V*W' - W*V'.\n\ *\n\ * The contents of A on exit are illustrated by the following examples\n\ * with n = 5 and nb = 2:\n\ *\n\ * if UPLO = 'U': if UPLO = 'L':\n\ *\n\ * ( a a a v4 v5 ) ( d )\n\ * ( a a v4 v5 ) ( 1 d )\n\ * ( a 1 v5 ) ( v1 1 a )\n\ * ( d 1 ) ( v1 v2 a a )\n\ * ( d ) ( v1 v2 a a a )\n\ *\n\ * where d denotes a diagonal element of the reduced matrix, a denotes\n\ * an element of the original matrix that is unchanged, and vi denotes\n\ * an element of the vector defining H(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chbevd0000644000175000017500000001635412502223525016453 0ustar uwabamiuwabami--- :name: chbevd :md5sum: ffa41f3f4c98922918cb3981415422ec :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 2*n*n : 0" - rwork: :type: real :intent: output :dims: - MAX(1,lrwork) - lrwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" :fortran_help: " SUBROUTINE CHBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHBEVD computes all the eigenvalues and, optionally, eigenvectors of\n\ * a complex Hermitian band matrix A. If eigenvectors are desired, it\n\ * uses a divide and conquer algorithm.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) COMPLEX array, dimension (LDAB, N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * On exit, AB is overwritten by values generated during the\n\ * reduction to tridiagonal form. If UPLO = 'U', the first\n\ * superdiagonal and the diagonal of the tridiagonal matrix T\n\ * are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n\ * the diagonal and first subdiagonal of T are returned in the\n\ * first two rows of AB.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD + 1.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) COMPLEX array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n\ * eigenvectors of the matrix A, with the i-th column of Z\n\ * holding the eigenvector associated with W(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace/output) COMPLEX 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\ * If N <= 1, LWORK must be at least 1.\n\ * If JOBZ = 'N' and N > 1, LWORK must be at least N.\n\ * If JOBZ = 'V' and N > 1, LWORK must be at least 2*N**2.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the optimal sizes of the WORK, RWORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * RWORK (workspace/output) REAL array,\n\ * dimension (LRWORK)\n\ * On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n\ *\n\ * LRWORK (input) INTEGER\n\ * The dimension of array RWORK.\n\ * If N <= 1, LRWORK must be at least 1.\n\ * If JOBZ = 'N' and N > 1, LRWORK must be at least N.\n\ * If JOBZ = 'V' and N > 1, LRWORK must be at least\n\ * 1 + 5*N + 2*N**2.\n\ *\n\ * If LRWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of array IWORK.\n\ * If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.\n\ * If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N .\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK 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 algorithm failed to converge; i\n\ * off-diagonal elements of an intermediate tridiagonal\n\ * form did not converge to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgbtrf0000644000175000017500000000741312502223525016463 0ustar uwabamiuwabami--- :name: cgbtrf :md5sum: cb767c902d74f024a5a58dad38d41372 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGBTRF computes an LU factorization of a complex m-by-n band matrix A\n\ * using partial pivoting with row interchanges.\n\ *\n\ * This is the blocked version of the algorithm, calling Level 3 BLAS.\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\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * AB (input/output) COMPLEX array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows KL+1 to\n\ * 2*KL+KU+1; rows 1 to KL of the array need not be set.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n\ *\n\ * On exit, details of the factorization: U is stored as an\n\ * upper triangular band matrix with KL+KU superdiagonals in\n\ * rows 1 to KL+KU+1, and the multipliers used during the\n\ * factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n\ * See below for further details.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n\ *\n\ * IPIV (output) INTEGER array, dimension (min(M,N))\n\ * The pivot indices; for 1 <= i <= min(M,N), row i of the\n\ * matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, and division by zero will occur if it is used\n\ * to solve a system of equations.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * M = N = 6, KL = 2, KU = 1:\n\ *\n\ * On entry: On exit:\n\ *\n\ * * * * + + + * * * u14 u25 u36\n\ * * * + + + + * * u13 u24 u35 u46\n\ * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n\ * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n\ * a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n\ * a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n\ *\n\ * Array elements marked * are not used by the routine; elements marked\n\ * + need not be set on entry, but are required by the routine to store\n\ * elements of U because of fill-in resulting from the row interchanges.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgeqr2p0000644000175000017500000000471112502223526016576 0ustar uwabamiuwabami--- :name: sgeqr2p :md5sum: 5248af5ed9acffff08cb0b94440311ff :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - MIN(m,n) - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGEQR2P( M, N, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGEQR2P computes a QR factorization of a real m by n matrix A:\n\ * A = Q * R.\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) REAL array, dimension (LDA,N)\n\ * On entry, the m by n matrix A.\n\ * On exit, the elements on and above the diagonal of the array\n\ * contain the min(m,n) by n upper trapezoidal matrix R (R is\n\ * upper triangular if m >= n); the elements below 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) REAL array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace) REAL array, dimension (N)\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(1) H(2) . . . H(k), 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:m) is stored on exit in A(i+1:m,i),\n\ * and tau in TAU(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgegv0000644000175000017500000002341212502223525016304 0ustar uwabamiuwabami--- :name: cgegv :md5sum: 4bb3b3ee105dc84e3a06b33c6db1feee :category: :subroutine :arguments: - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alpha: :type: complex :intent: output :dims: - n - beta: :type: complex :intent: output :dims: - n - vl: :type: complex :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: complex :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: real :intent: output :dims: - 8*n - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " SUBROUTINE CGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This routine is deprecated and has been replaced by routine CGGEV.\n\ *\n\ * CGEGV computes the eigenvalues and, optionally, the left and/or right\n\ * eigenvectors of a complex matrix pair (A,B).\n\ * Given two square matrices A and B,\n\ * the generalized nonsymmetric eigenvalue problem (GNEP) is to find the\n\ * eigenvalues lambda and corresponding (non-zero) eigenvectors x such\n\ * that\n\ * A*x = lambda*B*x.\n\ *\n\ * An alternate form is to find the eigenvalues mu and corresponding\n\ * eigenvectors y such that\n\ * mu*A*y = B*y.\n\ *\n\ * These two forms are equivalent with mu = 1/lambda and x = y if\n\ * neither lambda nor mu is zero. In order to deal with the case that\n\ * lambda or mu is zero or small, two values alpha and beta are returned\n\ * for each eigenvalue, such that lambda = alpha/beta and\n\ * mu = beta/alpha.\n\ * \n\ * The vectors x and y in the above equations are right eigenvectors of\n\ * the matrix pair (A,B). Vectors u and v satisfying\n\ * u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B\n\ * are left eigenvectors of (A,B).\n\ *\n\ * Note: this routine performs \"full balancing\" on A and B -- see\n\ * \"Further Details\", below.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVL (input) CHARACTER*1\n\ * = 'N': do not compute the left generalized eigenvectors;\n\ * = 'V': compute the left generalized eigenvectors (returned\n\ * in VL).\n\ *\n\ * JOBVR (input) CHARACTER*1\n\ * = 'N': do not compute the right generalized eigenvectors;\n\ * = 'V': compute the right generalized eigenvectors (returned\n\ * in VR).\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A, B, VL, and VR. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA, N)\n\ * On entry, the matrix A.\n\ * If JOBVL = 'V' or JOBVR = 'V', then on exit A\n\ * contains the Schur form of A from the generalized Schur\n\ * factorization of the pair (A,B) after balancing. If no\n\ * eigenvectors were computed, then only the diagonal elements\n\ * of the Schur form will be correct. See CGGHRD and CHGEQZ\n\ * for details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB, N)\n\ * On entry, the matrix B.\n\ * If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the\n\ * upper triangular matrix obtained from B in the generalized\n\ * Schur factorization of the pair (A,B) after balancing.\n\ * If no eigenvectors were computed, then only the diagonal\n\ * elements of B will be correct. See CGGHRD and CHGEQZ for\n\ * details.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B. LDB >= max(1,N).\n\ *\n\ * ALPHA (output) COMPLEX array, dimension (N)\n\ * The complex scalars alpha that define the eigenvalues of\n\ * GNEP.\n\ *\n\ * BETA (output) COMPLEX array, dimension (N)\n\ * The complex scalars beta that define the eigenvalues of GNEP.\n\ * \n\ * Together, the quantities alpha = ALPHA(j) and beta = BETA(j)\n\ * represent the j-th eigenvalue of the matrix pair (A,B), in\n\ * one of the forms lambda = alpha/beta or mu = beta/alpha.\n\ * Since either lambda or mu may overflow, they should not,\n\ * in general, be computed.\n\n\ *\n\ * VL (output) COMPLEX array, dimension (LDVL,N)\n\ * If JOBVL = 'V', the left eigenvectors u(j) are stored\n\ * in the columns of VL, in the same order as their eigenvalues.\n\ * Each eigenvector is scaled so that its largest component has\n\ * abs(real part) + abs(imag. part) = 1, except for eigenvectors\n\ * corresponding to an eigenvalue with alpha = beta = 0, which\n\ * are set to zero.\n\ * Not referenced if JOBVL = 'N'.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the matrix VL. LDVL >= 1, and\n\ * if JOBVL = 'V', LDVL >= N.\n\ *\n\ * VR (output) COMPLEX array, dimension (LDVR,N)\n\ * If JOBVR = 'V', the right eigenvectors x(j) are stored\n\ * in the columns of VR, in the same order as their eigenvalues.\n\ * Each eigenvector is scaled so that its largest component has\n\ * abs(real part) + abs(imag. part) = 1, except for eigenvectors\n\ * corresponding to an eigenvalue with alpha = beta = 0, which\n\ * are set to zero.\n\ * Not referenced if JOBVR = 'N'.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the matrix VR. LDVR >= 1, and\n\ * if JOBVR = 'V', LDVR >= N.\n\ *\n\ * WORK (workspace/output) COMPLEX 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,2*N).\n\ * For good performance, LWORK must generally be larger.\n\ * To compute the optimal value of LWORK, call ILAENV to get\n\ * blocksizes (for CGEQRF, CUNMQR, and CUNGQR.) Then compute:\n\ * NB -- MAX of the blocksizes for CGEQRF, CUNMQR, and CUNGQR;\n\ * The optimal LWORK is MAX( 2*N, N*(NB+1) ).\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\ * RWORK (workspace/output) REAL array, dimension (8*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * =1,...,N:\n\ * The QZ iteration failed. No eigenvectors have been\n\ * calculated, but ALPHA(j) and BETA(j) should be\n\ * correct for j=INFO+1,...,N.\n\ * > N: errors that usually indicate LAPACK problems:\n\ * =N+1: error return from CGGBAL\n\ * =N+2: error return from CGEQRF\n\ * =N+3: error return from CUNMQR\n\ * =N+4: error return from CUNGQR\n\ * =N+5: error return from CGGHRD\n\ * =N+6: error return from CHGEQZ (other than failed\n\ * iteration)\n\ * =N+7: error return from CTGEVC\n\ * =N+8: error return from CGGBAK (computing VL)\n\ * =N+9: error return from CGGBAK (computing VR)\n\ * =N+10: error return from CLASCL (various calls)\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Balancing\n\ * ---------\n\ *\n\ * This driver calls CGGBAL to both permute and scale rows and columns\n\ * of A and B. The permutations PL and PR are chosen so that PL*A*PR\n\ * and PL*B*R will be upper triangular except for the diagonal blocks\n\ * A(i:j,i:j) and B(i:j,i:j), with i and j as close together as\n\ * possible. The diagonal scaling matrices DL and DR are chosen so\n\ * that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to\n\ * one (except for the elements that start out zero.)\n\ *\n\ * After the eigenvalues and eigenvectors of the balanced matrices\n\ * have been computed, CGGBAK transforms the eigenvectors back to what\n\ * they would have been (in perfect arithmetic) if they had not been\n\ * balanced.\n\ *\n\ * Contents of A and B on Exit\n\ * -------- -- - --- - -- ----\n\ *\n\ * If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or\n\ * both), then on exit the arrays A and B will contain the complex Schur\n\ * form[*] of the \"balanced\" versions of A and B. If no eigenvectors\n\ * are computed, then only the diagonal blocks will be correct.\n\ *\n\ * [*] In other words, upper triangular form.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dggevx0000644000175000017500000003441012502223526016476 0ustar uwabamiuwabami--- :name: dggevx :md5sum: d820d02e84e8720e11cd584403d567e3 :category: :subroutine :arguments: - balanc: :type: char :intent: input - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alphar: :type: doublereal :intent: output :dims: - n - alphai: :type: doublereal :intent: output :dims: - n - beta: :type: doublereal :intent: output :dims: - n - vl: :type: doublereal :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: doublereal :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - lscale: :type: doublereal :intent: output :dims: - n - rscale: :type: doublereal :intent: output :dims: - n - abnrm: :type: doublereal :intent: output - bbnrm: :type: doublereal :intent: output - rconde: :type: doublereal :intent: output :dims: - n - rcondv: :type: doublereal :intent: output :dims: - n - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(lsame_(&balanc,\"S\")||lsame_(&balanc,\"B\")||lsame_(&jobvl,\"V\")||lsame_(&jobvr,\"V\")) ? 6*n : lsame_(&sense,\"E\") ? 10*n : (lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? 2*n*n+8*n+16 : 2*n" - iwork: :type: integer :intent: workspace :dims: - "lsame_(&sense,\"E\") ? 0 : n+6" - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sense,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " SUBROUTINE DGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, ILO, IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, WORK, LWORK, IWORK, BWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B)\n\ * the generalized eigenvalues, and optionally, the left and/or right\n\ * generalized eigenvectors.\n\ *\n\ * Optionally also, it computes a balancing transformation to improve\n\ * the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n\ * LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for\n\ * the eigenvalues (RCONDE), and reciprocal condition numbers for the\n\ * right eigenvectors (RCONDV).\n\ *\n\ * A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n\ * lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n\ * singular. It is usually represented as the pair (alpha,beta), as\n\ * there is a reasonable interpretation for beta=0, and even for both\n\ * being zero.\n\ *\n\ * The right eigenvector v(j) corresponding to the eigenvalue lambda(j)\n\ * of (A,B) satisfies\n\ *\n\ * A * v(j) = lambda(j) * B * v(j) .\n\ *\n\ * The left eigenvector u(j) corresponding to the eigenvalue lambda(j)\n\ * of (A,B) satisfies\n\ *\n\ * u(j)**H * A = lambda(j) * u(j)**H * B.\n\ *\n\ * where u(j)**H is the conjugate-transpose of u(j).\n\ *\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * BALANC (input) CHARACTER*1\n\ * Specifies the balance option to be performed.\n\ * = 'N': do not diagonally scale or permute;\n\ * = 'P': permute only;\n\ * = 'S': scale only;\n\ * = 'B': both permute and scale.\n\ * Computed reciprocal condition numbers will be for the\n\ * matrices after permuting and/or balancing. Permuting does\n\ * not change condition numbers (in exact arithmetic), but\n\ * balancing does.\n\ *\n\ * JOBVL (input) CHARACTER*1\n\ * = 'N': do not compute the left generalized eigenvectors;\n\ * = 'V': compute the left generalized eigenvectors.\n\ *\n\ * JOBVR (input) CHARACTER*1\n\ * = 'N': do not compute the right generalized eigenvectors;\n\ * = 'V': compute the right generalized eigenvectors.\n\ *\n\ * SENSE (input) CHARACTER*1\n\ * Determines which reciprocal condition numbers are computed.\n\ * = 'N': none are computed;\n\ * = 'E': computed for eigenvalues only;\n\ * = 'V': computed for eigenvectors only;\n\ * = 'B': computed for eigenvalues and eigenvectors.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A, B, VL, and VR. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n\ * On entry, the matrix A in the pair (A,B).\n\ * On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'\n\ * or both, then A contains the first part of the real Schur\n\ * form of the \"balanced\" versions of the input A and B.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of A. LDA >= max(1,N).\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n\ * On entry, the matrix B in the pair (A,B).\n\ * On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'\n\ * or both, then B contains the second part of the real Schur\n\ * form of the \"balanced\" versions of the input A and B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B. LDB >= max(1,N).\n\ *\n\ * ALPHAR (output) DOUBLE PRECISION array, dimension (N)\n\ * ALPHAI (output) DOUBLE PRECISION array, dimension (N)\n\ * BETA (output) DOUBLE PRECISION array, dimension (N)\n\ * On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n\ * be the generalized eigenvalues. If ALPHAI(j) is zero, then\n\ * the j-th eigenvalue is real; if positive, then the j-th and\n\ * (j+1)-st eigenvalues are a complex conjugate pair, with\n\ * ALPHAI(j+1) negative.\n\ *\n\ * Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n\ * may easily over- or underflow, and BETA(j) may even be zero.\n\ * Thus, the user should avoid naively computing the ratio\n\ * ALPHA/BETA. However, ALPHAR and ALPHAI will be always less\n\ * than and usually comparable with norm(A) in magnitude, and\n\ * BETA always less than and usually comparable with norm(B).\n\ *\n\ * VL (output) DOUBLE PRECISION array, dimension (LDVL,N)\n\ * If JOBVL = 'V', the left eigenvectors u(j) are stored one\n\ * after another in the columns of VL, in the same order as\n\ * their eigenvalues. If the j-th eigenvalue is real, then\n\ * u(j) = VL(:,j), the j-th column of VL. If the j-th and\n\ * (j+1)-th eigenvalues form a complex conjugate pair, then\n\ * u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).\n\ * Each eigenvector will be scaled so the largest component have\n\ * abs(real part) + abs(imag. part) = 1.\n\ * Not referenced if JOBVL = 'N'.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the matrix VL. LDVL >= 1, and\n\ * if JOBVL = 'V', LDVL >= N.\n\ *\n\ * VR (output) DOUBLE PRECISION array, dimension (LDVR,N)\n\ * If JOBVR = 'V', the right eigenvectors v(j) are stored one\n\ * after another in the columns of VR, in the same order as\n\ * their eigenvalues. If the j-th eigenvalue is real, then\n\ * v(j) = VR(:,j), the j-th column of VR. If the j-th and\n\ * (j+1)-th eigenvalues form a complex conjugate pair, then\n\ * v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).\n\ * Each eigenvector will be scaled so the largest component have\n\ * abs(real part) + abs(imag. part) = 1.\n\ * Not referenced if JOBVR = 'N'.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the matrix VR. LDVR >= 1, and\n\ * if JOBVR = 'V', LDVR >= N.\n\ *\n\ * ILO (output) INTEGER\n\ * IHI (output) INTEGER\n\ * ILO and IHI are integer values such that on exit\n\ * A(i,j) = 0 and B(i,j) = 0 if i > j and\n\ * j = 1,...,ILO-1 or i = IHI+1,...,N.\n\ * If BALANC = 'N' or 'S', ILO = 1 and IHI = N.\n\ *\n\ * LSCALE (output) DOUBLE PRECISION array, dimension (N)\n\ * Details of the permutations and scaling factors applied\n\ * to the left side of A and B. If PL(j) is the index of the\n\ * row interchanged with row j, and DL(j) is the scaling\n\ * factor applied to row j, then\n\ * LSCALE(j) = PL(j) for j = 1,...,ILO-1\n\ * = DL(j) for j = ILO,...,IHI\n\ * = PL(j) for j = IHI+1,...,N.\n\ * The order in which the interchanges are made is N to IHI+1,\n\ * then 1 to ILO-1.\n\ *\n\ * RSCALE (output) DOUBLE PRECISION array, dimension (N)\n\ * Details of the permutations and scaling factors applied\n\ * to the right side of A and B. If PR(j) is the index of the\n\ * column interchanged with column j, and DR(j) is the scaling\n\ * factor applied to column j, then\n\ * RSCALE(j) = PR(j) for j = 1,...,ILO-1\n\ * = DR(j) for j = ILO,...,IHI\n\ * = PR(j) for j = IHI+1,...,N\n\ * The order in which the interchanges are made is N to IHI+1,\n\ * then 1 to ILO-1.\n\ *\n\ * ABNRM (output) DOUBLE PRECISION\n\ * The one-norm of the balanced matrix A.\n\ *\n\ * BBNRM (output) DOUBLE PRECISION\n\ * The one-norm of the balanced matrix B.\n\ *\n\ * RCONDE (output) DOUBLE PRECISION array, dimension (N)\n\ * If SENSE = 'E' or 'B', the reciprocal condition numbers of\n\ * the eigenvalues, stored in consecutive elements of the array.\n\ * For a complex conjugate pair of eigenvalues two consecutive\n\ * elements of RCONDE are set to the same value. Thus RCONDE(j),\n\ * RCONDV(j), and the j-th columns of VL and VR all correspond\n\ * to the j-th eigenpair.\n\ * If SENSE = 'N or 'V', RCONDE is not referenced.\n\ *\n\ * RCONDV (output) DOUBLE PRECISION array, dimension (N)\n\ * If SENSE = 'V' or 'B', the estimated reciprocal condition\n\ * numbers of the eigenvectors, stored in consecutive elements\n\ * of the array. For a complex eigenvector two consecutive\n\ * elements of RCONDV are set to the same value. If the\n\ * eigenvalues cannot be reordered to compute RCONDV(j),\n\ * RCONDV(j) is set to 0; this can only occur when the true\n\ * value would be very small anyway.\n\ * If SENSE = 'N' or 'E', RCONDV is not referenced.\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,2*N).\n\ * If BALANC = 'S' or 'B', or JOBVL = 'V', or JOBVR = 'V',\n\ * LWORK >= max(1,6*N).\n\ * If SENSE = 'E' or 'B', LWORK >= max(1,10*N).\n\ * If SENSE = 'V' or 'B', LWORK >= 2*N*N+8*N+16.\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\ * IWORK (workspace) INTEGER array, dimension (N+6)\n\ * If SENSE = 'E', IWORK is not referenced.\n\ *\n\ * BWORK (workspace) LOGICAL array, dimension (N)\n\ * If SENSE = 'N', BWORK is not referenced.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * = 1,...,N:\n\ * The QZ iteration failed. No eigenvectors have been\n\ * calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)\n\ * should be correct for j=INFO+1,...,N.\n\ * > N: =N+1: other than QZ iteration failed in DHGEQZ.\n\ * =N+2: error return from DTGEVC.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Balancing a matrix pair (A,B) includes, first, permuting rows and\n\ * columns to isolate eigenvalues, second, applying diagonal similarity\n\ * transformation to the rows and columns to make the rows and columns\n\ * as close in norm as possible. The computed reciprocal condition\n\ * numbers correspond to the balanced matrix. Permuting rows and columns\n\ * will not change the condition numbers (in exact arithmetic) but\n\ * diagonal scaling will. For further explanation of balancing, see\n\ * section 4.11.1.2 of LAPACK Users' Guide.\n\ *\n\ * An approximate error bound on the chordal distance between the i-th\n\ * computed generalized eigenvalue w and the corresponding exact\n\ * eigenvalue lambda is\n\ *\n\ * chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)\n\ *\n\ * An approximate error bound for the angle between the i-th computed\n\ * eigenvector VL(i) or VR(i) is given by\n\ *\n\ * EPS * norm(ABNRM, BBNRM) / DIF(i).\n\ *\n\ * For further explanation of the reciprocal condition numbers RCONDE\n\ * and RCONDV, see section 4.11 of LAPACK User's Guide.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/stgexc0000644000175000017500000001435312502223526016513 0ustar uwabamiuwabami--- :name: stgexc :md5sum: 5d3e5cea4ba4800679b5eae4b7a67cc3 :category: :subroutine :arguments: - wantq: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - q: :type: real :intent: input/output :dims: - ldz - n - ldq: :type: integer :intent: input - z: :type: real :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - ifst: :type: integer :intent: input/output - ilst: :type: integer :intent: input/output - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : 4*n+16" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE STGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, IFST, ILST, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STGEXC reorders the generalized real Schur decomposition of a real\n\ * matrix pair (A,B) using an orthogonal equivalence transformation\n\ *\n\ * (A, B) = Q * (A, B) * Z',\n\ *\n\ * so that the diagonal block of (A, B) with row index IFST is moved\n\ * to row ILST.\n\ *\n\ * (A, B) must be in generalized real Schur canonical form (as returned\n\ * by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2\n\ * diagonal blocks. B is upper triangular.\n\ *\n\ * Optionally, the matrices Q and Z of generalized Schur vectors are\n\ * updated.\n\ *\n\ * Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n\ * Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n\ *\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * WANTQ (input) LOGICAL\n\ * .TRUE. : update the left transformation matrix Q;\n\ * .FALSE.: do not update Q.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * .TRUE. : update the right transformation matrix Z;\n\ * .FALSE.: do not update Z.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the matrix A in generalized real Schur canonical\n\ * form.\n\ * On exit, the updated matrix A, again in generalized\n\ * real Schur canonical form.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) REAL array, dimension (LDB,N)\n\ * On entry, the matrix B in generalized real Schur canonical\n\ * form (A,B).\n\ * On exit, the updated matrix B, again in generalized\n\ * real Schur canonical form (A,B).\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * Q (input/output) REAL array, dimension (LDZ,N)\n\ * On entry, if WANTQ = .TRUE., the orthogonal matrix Q.\n\ * On exit, the updated matrix Q.\n\ * If WANTQ = .FALSE., Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= 1.\n\ * If WANTQ = .TRUE., LDQ >= N.\n\ *\n\ * Z (input/output) REAL array, dimension (LDZ,N)\n\ * On entry, if WANTZ = .TRUE., the orthogonal matrix Z.\n\ * On exit, the updated matrix Z.\n\ * If WANTZ = .FALSE., Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1.\n\ * If WANTZ = .TRUE., LDZ >= N.\n\ *\n\ * IFST (input/output) INTEGER\n\ * ILST (input/output) INTEGER\n\ * Specify the reordering of the diagonal blocks of (A, B).\n\ * The block with row index IFST is moved to row ILST, by a\n\ * sequence of swapping between adjacent blocks.\n\ * On exit, if IFST pointed on entry to the second row of\n\ * a 2-by-2 block, it is changed to point to the first row;\n\ * ILST always points to the first row of the block in its\n\ * final position (which may differ from its input value by\n\ * +1 or -1). 1 <= IFST, ILST <= N.\n\ *\n\ * WORK (workspace/output) REAL 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 >= 1 when N <= 1, otherwise LWORK >= 4*N + 16.\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\ * =1: The transformed matrix pair (A, B) would be too far\n\ * from generalized Schur form; the problem is ill-\n\ * conditioned. (A, B) may have been partially reordered,\n\ * and ILST points to the first row of the current\n\ * position of the block being moved.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n\ * Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n\ * M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n\ * Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/spbstf0000644000175000017500000000763012502223526016517 0ustar uwabamiuwabami--- :name: spbstf :md5sum: 4015e93b6c7ebd85726713ac3fabd501 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPBSTF( UPLO, N, KD, AB, LDAB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPBSTF computes a split Cholesky factorization of a real\n\ * symmetric positive definite band matrix A.\n\ *\n\ * This routine is designed to be used in conjunction with SSBGST.\n\ *\n\ * The factorization has the form A = S**T*S where S is a band matrix\n\ * of the same bandwidth as A and the following structure:\n\ *\n\ * S = ( U )\n\ * ( M L )\n\ *\n\ * where U is upper triangular of order m = (n+kd)/2, and L is lower\n\ * triangular of order n-m.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) REAL array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first kd+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * On exit, if INFO = 0, the factor S from the split Cholesky\n\ * factorization A = S**T*S. See Further Details.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\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 factorization could not be completed,\n\ * because the updated element a(i,i) was negative; the\n\ * matrix A is not positive definite.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * N = 7, KD = 2:\n\ *\n\ * S = ( s11 s12 s13 )\n\ * ( s22 s23 s24 )\n\ * ( s33 s34 )\n\ * ( s44 )\n\ * ( s53 s54 s55 )\n\ * ( s64 s65 s66 )\n\ * ( s75 s76 s77 )\n\ *\n\ * If UPLO = 'U', the array AB holds:\n\ *\n\ * on entry: on exit:\n\ *\n\ * * * a13 a24 a35 a46 a57 * * s13 s24 s53 s64 s75\n\ * * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54 s65 s76\n\ * a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77\n\ *\n\ * If UPLO = 'L', the array AB holds:\n\ *\n\ * on entry: on exit:\n\ *\n\ * a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77\n\ * a21 a32 a43 a54 a65 a76 * s12 s23 s34 s54 s65 s76 *\n\ * a31 a42 a53 a64 a64 * * s13 s24 s53 s64 s75 * *\n\ *\n\ * Array elements marked * are not used by the routine.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slargv0000644000175000017500000000367112502223526016515 0ustar uwabamiuwabami--- :name: slargv :md5sum: f561479469994456d10e2e31f244ecbb :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - y: :type: real :intent: input/output :dims: - 1+(n-1)*incy - incy: :type: integer :intent: input - c: :type: real :intent: output :dims: - 1+(n-1)*incc - incc: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE SLARGV( N, X, INCX, Y, INCY, C, INCC )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLARGV generates a vector of real plane rotations, determined by\n\ * elements of the real vectors x and y. For i = 1,2,...,n\n\ *\n\ * ( c(i) s(i) ) ( x(i) ) = ( a(i) )\n\ * ( -s(i) c(i) ) ( y(i) ) = ( 0 )\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of plane rotations to be generated.\n\ *\n\ * X (input/output) REAL array,\n\ * dimension (1+(N-1)*INCX)\n\ * On entry, the vector x.\n\ * On exit, x(i) is overwritten by a(i), for i = 1,...,n.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between elements of X. INCX > 0.\n\ *\n\ * Y (input/output) REAL array,\n\ * dimension (1+(N-1)*INCY)\n\ * On entry, the vector y.\n\ * On exit, the sines of the plane rotations.\n\ *\n\ * INCY (input) INTEGER\n\ * The increment between elements of Y. INCY > 0.\n\ *\n\ * C (output) REAL array, dimension (1+(N-1)*INCC)\n\ * The cosines of the plane rotations.\n\ *\n\ * INCC (input) INTEGER\n\ * The increment between elements of C. INCC > 0.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlaed10000644000175000017500000001201212655767354016363 0ustar uwabamiuwabami--- :name: dlaed1 :md5sum: de28a4b248244bebc9ea6c8ab7809f3b :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - q: :type: doublereal :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - indxq: :type: integer :intent: input/output :dims: - n - rho: :type: doublereal :intent: input - cutpnt: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 4*n + pow(n,2) - iwork: :type: integer :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAED1 computes the updated eigensystem of a diagonal\n\ * matrix after modification by a rank-one symmetric matrix. This\n\ * routine is used only for the eigenproblem which requires all\n\ * eigenvalues and eigenvectors of a tridiagonal matrix. DLAED7 handles\n\ * the case in which eigenvalues only or eigenvalues and eigenvectors\n\ * of a full symmetric matrix (which was reduced to tridiagonal form)\n\ * are desired.\n\ *\n\ * T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)\n\ *\n\ * where Z = Q'u, u is a vector of length N with ones in the\n\ * CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.\n\ *\n\ * The eigenvectors of the original matrix are stored in Q, and the\n\ * eigenvalues are in D. The algorithm consists of three stages:\n\ *\n\ * The first stage consists of deflating the size of the problem\n\ * when there are multiple eigenvalues or if there is a zero in\n\ * the Z vector. For each such occurrence the dimension of the\n\ * secular equation problem is reduced by one. This stage is\n\ * performed by the routine DLAED2.\n\ *\n\ * The second stage consists of calculating the updated\n\ * eigenvalues. This is done by finding the roots of the secular\n\ * equation via the routine DLAED4 (as called by DLAED3).\n\ * This routine also calculates the eigenvectors of the current\n\ * problem.\n\ *\n\ * The final stage consists of computing the updated eigenvectors\n\ * directly using the updated eigenvalues. The eigenvectors for\n\ * the current problem are multiplied with the eigenvectors from\n\ * the overall problem.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The dimension of the symmetric tridiagonal matrix. N >= 0.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the eigenvalues of the rank-1-perturbed matrix.\n\ * On exit, the eigenvalues of the repaired matrix.\n\ *\n\ * Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n\ * On entry, the eigenvectors of the rank-1-perturbed matrix.\n\ * On exit, the eigenvectors of the repaired tridiagonal matrix.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N).\n\ *\n\ * INDXQ (input/output) INTEGER array, dimension (N)\n\ * On entry, the permutation which separately sorts the two\n\ * subproblems in D into ascending order.\n\ * On exit, the permutation which will reintegrate the\n\ * subproblems back into sorted order,\n\ * i.e. D( INDXQ( I = 1, N ) ) will be in ascending order.\n\ *\n\ * RHO (input) DOUBLE PRECISION\n\ * The subdiagonal entry used to create the rank-1 modification.\n\ *\n\ * CUTPNT (input) INTEGER\n\ * The location of the last eigenvalue in the leading sub-matrix.\n\ * min(1,N) <= CUTPNT <= N/2.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (4*N + N**2)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (4*N)\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 = 1, an eigenvalue did not converge\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Jeff Rutter, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ * Modified by Francoise Tisseur, University of Tennessee.\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER COLTYP, I, IDLMDA, INDX, INDXC, INDXP, IQ2, IS,\n $ IW, IZ, K, N1, N2, ZPP1\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DCOPY, DLAED2, DLAED3, DLAMRG, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlarrb0000644000175000017500000001246112502223526016462 0ustar uwabamiuwabami--- :name: dlarrb :md5sum: 94581ce130ae520a534c65b282147970 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - lld: :type: doublereal :intent: input :dims: - n-1 - ifirst: :type: integer :intent: input - ilast: :type: integer :intent: input - rtol1: :type: doublereal :intent: input - rtol2: :type: doublereal :intent: input - offset: :type: integer :intent: input - w: :type: doublereal :intent: input/output :dims: - n - wgap: :type: doublereal :intent: input/output :dims: - n-1 - werr: :type: doublereal :intent: input/output :dims: - n - work: :type: doublereal :intent: workspace :dims: - 2*n - iwork: :type: integer :intent: workspace :dims: - 2*n - pivmin: :type: doublereal :intent: input - spdiam: :type: doublereal :intent: input - twist: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLARRB( N, D, LLD, IFIRST, ILAST, RTOL1, RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK, PIVMIN, SPDIAM, TWIST, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Given the relatively robust representation(RRR) L D L^T, DLARRB\n\ * does \"limited\" bisection to refine the eigenvalues of L D L^T,\n\ * W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial\n\ * guesses for these eigenvalues are input in W, the corresponding estimate\n\ * of the error in these guesses and their gaps are input in WERR\n\ * and WGAP, respectively. During bisection, intervals\n\ * [left, right] are maintained by storing their mid-points and\n\ * semi-widths in the arrays W and WERR respectively.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The N diagonal elements of the diagonal matrix D.\n\ *\n\ * LLD (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (N-1) elements L(i)*L(i)*D(i).\n\ *\n\ * IFIRST (input) INTEGER\n\ * The index of the first eigenvalue to be computed.\n\ *\n\ * ILAST (input) INTEGER\n\ * The index of the last eigenvalue to be computed.\n\ *\n\ * RTOL1 (input) DOUBLE PRECISION\n\ * RTOL2 (input) DOUBLE PRECISION\n\ * Tolerance for the convergence of the bisection intervals.\n\ * An interval [LEFT,RIGHT] has converged if\n\ * RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n\ * where GAP is the (estimated) distance to the nearest\n\ * eigenvalue.\n\ *\n\ * OFFSET (input) INTEGER\n\ * Offset for the arrays W, WGAP and WERR, i.e., the IFIRST-OFFSET\n\ * through ILAST-OFFSET elements of these arrays are to be used.\n\ *\n\ * W (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are\n\ * estimates of the eigenvalues of L D L^T indexed IFIRST throug\n\ * ILAST.\n\ * On output, these estimates are refined.\n\ *\n\ * WGAP (input/output) DOUBLE PRECISION array, dimension (N-1)\n\ * On input, the (estimated) gaps between consecutive\n\ * eigenvalues of L D L^T, i.e., WGAP(I-OFFSET) is the gap between\n\ * eigenvalues I and I+1. Note that if IFIRST.EQ.ILAST\n\ * then WGAP(IFIRST-OFFSET) must be set to ZERO.\n\ * On output, these gaps are refined.\n\ *\n\ * WERR (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are\n\ * the errors in the estimates of the corresponding elements in W.\n\ * On output, these errors are refined.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n\ * Workspace.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (2*N)\n\ * Workspace.\n\ *\n\ * PIVMIN (input) DOUBLE PRECISION\n\ * The minimum pivot in the Sturm sequence.\n\ *\n\ * SPDIAM (input) DOUBLE PRECISION\n\ * The spectral diameter of the matrix.\n\ *\n\ * TWIST (input) INTEGER\n\ * The twist index for the twisted factorization that is used\n\ * for the negcount.\n\ * TWIST = N: Compute negcount from L D L^T - LAMBDA I = L+ D+ L+^T\n\ * TWIST = 1: Compute negcount from L D L^T - LAMBDA I = U- D- U-^T\n\ * TWIST = R: Compute negcount from L D L^T - LAMBDA I = N(r) D(r) N(r)\n\ *\n\ * INFO (output) INTEGER\n\ * Error flag.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Beresford Parlett, University of California, Berkeley, USA\n\ * Jim Demmel, University of California, Berkeley, USA\n\ * Inderjit Dhillon, University of Texas, Austin, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, University of California, Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctprfs0000644000175000017500000001103412502223525016507 0ustar uwabamiuwabami--- :name: ctprfs :md5sum: bd37980bab10e66ded4499fe3f0267e2 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ldb :fortran_help: " SUBROUTINE CTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTPRFS provides error bounds and backward error estimates for the\n\ * solution to a system of linear equations with a triangular packed\n\ * coefficient matrix.\n\ *\n\ * The solution matrix X must be computed by CTPTRS or some other\n\ * means before entering this routine. CTPRFS does not do iterative\n\ * refinement because doing so cannot improve the backward error.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AP (input) COMPLEX array, dimension (N*(N+1)/2)\n\ * The upper or lower triangular matrix A, packed columnwise in\n\ * a linear array. The j-th column of A is stored in the array\n\ * AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ * If DIAG = 'U', the diagonal elements of A are not referenced\n\ * and are assumed to be 1.\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,NRHS)\n\ * The right hand side matrix B. \n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input) COMPLEX array, dimension (LDX,NRHS)\n\ * The solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clarz0000644000175000017500000000605612502223525016331 0ustar uwabamiuwabami--- :name: clarz :md5sum: 0f5559fe28e5257781743a106558e54f :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - l: :type: integer :intent: input - v: :type: complex :intent: input :dims: - 1+(l-1)*abs(incv) - incv: :type: integer :intent: input - tau: :type: complex :intent: input - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " SUBROUTINE CLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLARZ applies a complex elementary reflector H to a complex\n\ * M-by-N matrix C, from either the left or the right. H is represented\n\ * in the form\n\ *\n\ * H = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar and v is a complex vector.\n\ *\n\ * If tau = 0, then H is taken to be the unit matrix.\n\ *\n\ * To apply H' (the conjugate transpose of H), supply conjg(tau) instead\n\ * tau.\n\ *\n\ * H is a product of k elementary reflectors as returned by CTZRZF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': form H * C\n\ * = 'R': form C * H\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C.\n\ *\n\ * L (input) INTEGER\n\ * The number of entries of the vector V containing\n\ * the meaningful part of the Householder vectors.\n\ * If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n\ *\n\ * V (input) COMPLEX array, dimension (1+(L-1)*abs(INCV))\n\ * The vector v in the representation of H as returned by\n\ * CTZRZF. V is not used if TAU = 0.\n\ *\n\ * INCV (input) INTEGER\n\ * The increment between elements of v. INCV <> 0.\n\ *\n\ * TAU (input) COMPLEX\n\ * The value tau in the representation of H.\n\ *\n\ * C (input/output) COMPLEX array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n\ * or C * H if SIDE = 'R'.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension\n\ * (N) if SIDE = 'L'\n\ * or (M) if SIDE = 'R'\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dpftrf0000644000175000017500000001414212502223526016477 0ustar uwabamiuwabami--- :name: dpftrf :md5sum: 3fc77e15efea7d6ef9bac22a903fe147 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPFTRF( TRANSR, UPLO, N, A, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPFTRF computes the Cholesky factorization of a real symmetric\n\ * positive definite matrix A.\n\ *\n\ * The factorization has the form\n\ * A = U**T * U, if UPLO = 'U', or\n\ * A = L * L**T, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is lower triangular.\n\ *\n\ * This is the block version of the algorithm, calling Level 3 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': The Normal TRANSR of RFP A is stored;\n\ * = 'T': The Transpose TRANSR of RFP A is stored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of RFP A is stored;\n\ * = 'L': Lower triangle of RFP A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 );\n\ * On entry, the symmetric matrix A in RFP format. RFP format is\n\ * described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n\ * then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n\ * (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is\n\ * the transpose of RFP A as defined when\n\ * TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n\ * follows: If UPLO = 'U' the RFP A contains the NT elements of\n\ * upper packed A. If UPLO = 'L' the RFP A contains the elements\n\ * of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n\ * 'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n\ * is odd. See the Note below for more details.\n\ *\n\ * On exit, if INFO = 0, the factor U or L from the Cholesky\n\ * factorization RFP A = U**T*U or RFP A = L*L**T.\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 leading minor of order i is not\n\ * positive definite, and the factorization could not be\n\ * completed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * We first consider Rectangular Full Packed (RFP) Format when N is\n\ * even. We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * the transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * the transpose of the last three columns of AP lower.\n\ * This covers the case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 04 05 33 43 53\n\ * 13 14 15 00 44 54\n\ * 23 24 25 10 11 55\n\ * 33 34 35 20 21 22\n\ * 00 44 45 30 31 32\n\ * 01 11 55 40 41 42\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We then consider Rectangular Full Packed (RFP) Format when N is\n\ * odd. We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * the transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * the transpose of the last two columns of AP lower.\n\ * This covers the case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 03 04 00 33 43\n\ * 12 13 14 10 11 44\n\ * 22 23 24 20 21 22\n\ * 00 33 34 30 31 32\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlascl20000644000175000017500000000302012502223526016527 0ustar uwabamiuwabami--- :name: dlascl2 :md5sum: 303b57afa464faf1740b95059b092c65 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - m - x: :type: doublereal :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE DLASCL2 ( M, N, D, X, LDX )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLASCL2 performs a diagonal scaling on a vector:\n\ * x <-- D * x\n\ * where the diagonal matrix D is stored as a vector.\n\ *\n\ * Eventually to be replaced by BLAS_dge_diag_scale in the new BLAS\n\ * standard.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of D and X. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of D and X. N >= 0.\n\ *\n\ * D (input) DOUBLE PRECISION array, length M\n\ * Diagonal matrix D, stored as a vector of length M.\n\ *\n\ * X (input/output) DOUBLE PRECISION array, dimension (LDX,N)\n\ * On entry, the vector X to be scaled by D.\n\ * On exit, the scaled vector.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the vector X. LDX >= 0.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zptrfs0000644000175000017500000001135712502223526016547 0ustar uwabamiuwabami--- :name: zptrfs :md5sum: b039702b9cb6d623dbf01d6a72aa8bd3 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublecomplex :intent: input :dims: - n-1 - df: :type: doublereal :intent: input :dims: - n - ef: :type: doublecomplex :intent: input :dims: - n-1 - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPTRFS( UPLO, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPTRFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is Hermitian positive definite\n\ * and tridiagonal, and provides error bounds and backward error\n\ * estimates for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the superdiagonal or the subdiagonal of the\n\ * tridiagonal matrix A is stored and the form of the\n\ * factorization:\n\ * = 'U': E is the superdiagonal of A, and A = U**H*D*U;\n\ * = 'L': E is the subdiagonal of A, and A = L*D*L**H.\n\ * (The two forms are equivalent if A is real.)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The n real diagonal elements of the tridiagonal matrix A.\n\ *\n\ * E (input) COMPLEX*16 array, dimension (N-1)\n\ * The (n-1) off-diagonal elements of the tridiagonal matrix A\n\ * (see UPLO).\n\ *\n\ * DF (input) DOUBLE PRECISION array, dimension (N)\n\ * The n diagonal elements of the diagonal matrix D from\n\ * the factorization computed by ZPTTRF.\n\ *\n\ * EF (input) COMPLEX*16 array, dimension (N-1)\n\ * The (n-1) off-diagonal elements of the unit bidiagonal\n\ * factor U or L from the factorization computed by ZPTTRF\n\ * (see UPLO).\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by ZPTTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j).\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dpbtrf0000644000175000017500000000676312502223526016505 0ustar uwabamiuwabami--- :name: dpbtrf :md5sum: 6355622b2a30fa00a4fe3d46a1c18912 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPBTRF( UPLO, N, KD, AB, LDAB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPBTRF computes the Cholesky factorization of a real symmetric\n\ * positive definite band matrix A.\n\ *\n\ * The factorization has the form\n\ * A = U**T * U, if UPLO = 'U', or\n\ * A = L * L**T, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is lower triangular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * On exit, if INFO = 0, the triangular factor U or L from the\n\ * Cholesky factorization A = U**T*U or A = L*L**T of the band\n\ * matrix A, in the same storage format as A.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\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 leading minor of order i is not\n\ * positive definite, and the factorization could not be\n\ * completed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * N = 6, KD = 2, and UPLO = 'U':\n\ *\n\ * On entry: On exit:\n\ *\n\ * * * a13 a24 a35 a46 * * u13 u24 u35 u46\n\ * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n\ * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n\ *\n\ * Similarly, if UPLO = 'L' the format of A is as follows:\n\ *\n\ * On entry: On exit:\n\ *\n\ * a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n\ * a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n\ * a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n\ *\n\ * Array elements marked * are not used by the routine.\n\ *\n\ * Contributed by\n\ * Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dormlq0000644000175000017500000001057312502223526016514 0ustar uwabamiuwabami--- :name: dormlq :md5sum: 8dfec4368a6a339237ffb44f3b838c49 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DORMLQ overwrites the general real M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'T': Q**T * C C * Q**T\n\ *\n\ * where Q is a real orthogonal matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(k) . . . H(2) H(1)\n\ *\n\ * as returned by DGELQF. Q is of order M if SIDE = 'L' and of order N\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**T from the Left;\n\ * = 'R': apply Q or Q**T from the Right.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q;\n\ * = 'T': Transpose, apply Q**T.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension\n\ * (LDA,M) if SIDE = 'L',\n\ * (LDA,N) if SIDE = 'R'\n\ * The i-th row must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * DGELQF in the first k rows of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,K).\n\ *\n\ * TAU (input) DOUBLE PRECISION array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by DGELQF.\n\ *\n\ * C (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M).\n\ * For optimum performance LWORK >= N*NB if SIDE = 'L', and\n\ * LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n\ * 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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dla_porcond0000644000175000017500000000710612502223526017500 0ustar uwabamiuwabami--- :name: dla_porcond :md5sum: ad89241edd2e8e4f14c40b59471af634 :category: :function :type: doublereal :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - cmode: :type: integer :intent: input - c: :type: doublereal :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: doublereal :intent: input :dims: - 3*n - iwork: :type: integer :intent: input :dims: - n :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION DLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, CMODE, C, INFO, WORK, IWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLA_PORCOND Estimates the Skeel condition number of op(A) * op2(C)\n\ * where op2 is determined by CMODE as follows\n\ * CMODE = 1 op2(C) = C\n\ * CMODE = 0 op2(C) = I\n\ * CMODE = -1 op2(C) = inv(C)\n\ * The Skeel condition number cond(A) = norminf( |inv(A)||A| )\n\ * is computed by computing scaling factors R such that\n\ * diag(R)*A*op2(C) is row equilibrated and computing the standard\n\ * infinity-norm condition number.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T, as computed by DPOTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * CMODE (input) INTEGER\n\ * Determines op2(C) in the formula op(A) * op2(C) as follows:\n\ * CMODE = 1 op2(C) = C\n\ * CMODE = 0 op2(C) = I\n\ * CMODE = -1 op2(C) = inv(C)\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension (N)\n\ * The vector C in the formula op(A) * op2(C).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * i > 0: The ith argument is invalid.\n\ *\n\ * WORK (input) DOUBLE PRECISION array, dimension (3*N).\n\ * Workspace.\n\ *\n\ * IWORK (input) INTEGER array, dimension (N).\n\ * Workspace.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER KASE, I, J\n DOUBLE PRECISION AINVNM, TMP\n LOGICAL UP\n\ * ..\n\ * .. Array Arguments ..\n INTEGER ISAVE( 3 )\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER IDAMAX\n EXTERNAL LSAME, IDAMAX\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DLACN2, DPOTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sorg2r0000644000175000017500000000440312502223526016427 0ustar uwabamiuwabami--- :name: sorg2r :md5sum: be97ee24af78e97a228a26d00443a498 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SORG2R( M, N, K, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SORG2R generates an m by n real matrix Q with orthonormal columns,\n\ * which is defined as the first n columns of a product of k elementary\n\ * reflectors of order m\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by SGEQRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. M >= N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. N >= K >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the i-th column must contain the vector which\n\ * defines the elementary reflector H(i), for i = 1,2,...,k, as\n\ * returned by SGEQRF in the first k columns of its array\n\ * argument A.\n\ * On exit, the m-by-n matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) REAL array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by SGEQRF.\n\ *\n\ * WORK (workspace) REAL array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgebd20000644000175000017500000001327312502223526016373 0ustar uwabamiuwabami--- :name: zgebd2 :md5sum: a34f063a4eed461697dd095a39a0e253 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - MIN(m,n) - e: :type: doublereal :intent: output :dims: - MIN(m,n)-1 - tauq: :type: doublecomplex :intent: output :dims: - MIN(m,n) - taup: :type: doublecomplex :intent: output :dims: - MIN(m,n) - work: :type: doublecomplex :intent: workspace :dims: - MAX(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGEBD2 reduces a complex general m by n matrix A to upper or lower\n\ * real bidiagonal form B by a unitary transformation: Q' * A * P = B.\n\ *\n\ * If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows in the matrix A. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns in the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the m by n general matrix to be reduced.\n\ * On exit,\n\ * if m >= n, the diagonal and the first superdiagonal are\n\ * overwritten with the upper bidiagonal matrix B; the\n\ * elements below the diagonal, with the array TAUQ, represent\n\ * the unitary matrix Q as a product of elementary\n\ * reflectors, and the elements above the first superdiagonal,\n\ * with the array TAUP, represent the unitary matrix P as\n\ * a product of elementary reflectors;\n\ * if m < n, the diagonal and the first subdiagonal are\n\ * overwritten with the lower bidiagonal matrix B; the\n\ * elements below the first subdiagonal, with the array TAUQ,\n\ * represent the unitary matrix Q as a product of\n\ * elementary reflectors, and the elements above the diagonal,\n\ * with the array TAUP, represent the unitary matrix P as\n\ * a product of elementary reflectors.\n\ * See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * D (output) DOUBLE PRECISION array, dimension (min(M,N))\n\ * The diagonal elements of the bidiagonal matrix B:\n\ * D(i) = A(i,i).\n\ *\n\ * E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)\n\ * The off-diagonal elements of the bidiagonal matrix B:\n\ * if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n\ * if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n\ *\n\ * TAUQ (output) COMPLEX*16 array dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the unitary matrix Q. See Further Details.\n\ *\n\ * TAUP (output) COMPLEX*16 array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the unitary matrix P. See Further Details.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (max(M,N))\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 matrices Q and P are represented as products of elementary\n\ * reflectors:\n\ *\n\ * If m >= n,\n\ *\n\ * Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)\n\ *\n\ * Each H(i) and G(i) has the form:\n\ *\n\ * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n\ *\n\ * where tauq and taup are complex scalars, and v and u are complex\n\ * vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in\n\ * A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in\n\ * A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n\ *\n\ * If m < n,\n\ *\n\ * Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)\n\ *\n\ * Each H(i) and G(i) has the form:\n\ *\n\ * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n\ *\n\ * where tauq and taup are complex scalars, v and u are complex vectors;\n\ * v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);\n\ * u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);\n\ * tauq is stored in TAUQ(i) and taup in TAUP(i).\n\ *\n\ * The contents of A on exit are illustrated by the following examples:\n\ *\n\ * m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n\ *\n\ * ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )\n\ * ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )\n\ * ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )\n\ * ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )\n\ * ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )\n\ * ( v1 v2 v3 v4 v5 )\n\ *\n\ * where d and e denote diagonal and off-diagonal elements of B, vi\n\ * denotes an element of the vector defining H(i), and ui an element of\n\ * the vector defining G(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dpotri0000644000175000017500000000413712502223526016516 0ustar uwabamiuwabami--- :name: dpotri :md5sum: 2c5bbee2b4cacacf2af6cf4a23801249 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPOTRI( UPLO, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPOTRI computes the inverse of a real symmetric positive definite\n\ * matrix A using the Cholesky factorization A = U**T*U or A = L*L**T\n\ * computed by DPOTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the triangular factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T, as computed by\n\ * DPOTRF.\n\ * On exit, the upper or lower triangle of the (symmetric)\n\ * inverse of A, overwriting the input factor U or L.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\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,i) element of the factor U or L is\n\ * zero, and the inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DLAUUM, DTRTRI, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slasd00000644000175000017500000000775512502223526016414 0ustar uwabamiuwabami--- :name: slasd0 :md5sum: ee7a88d8d84c0475b3d0063f24187d61 :category: :subroutine :arguments: - n: :type: integer :intent: input - sqre: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input :dims: - m-1 - u: :type: real :intent: output :dims: - ldu - n - ldu: :type: integer :intent: input - vt: :type: real :intent: output :dims: - ldvt - m - ldvt: :type: integer :intent: input - smlsiz: :type: integer :intent: input - iwork: :type: integer :intent: workspace :dims: - 8*n - work: :type: real :intent: workspace :dims: - 3*pow(m,2)+2*m - info: :type: integer :intent: output :substitutions: m: "sqre == 0 ? n : sqre == 1 ? n+1 : 0" ldvt: m ldu: n :fortran_help: " SUBROUTINE SLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Using a divide and conquer approach, SLASD0 computes the singular\n\ * value decomposition (SVD) of a real upper bidiagonal N-by-M\n\ * matrix B with diagonal D and offdiagonal E, where M = N + SQRE.\n\ * The algorithm computes orthogonal matrices U and VT such that\n\ * B = U * S * VT. The singular values S are overwritten on D.\n\ *\n\ * A related subroutine, SLASDA, computes only the singular values,\n\ * and optionally, the singular vectors in compact form.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * On entry, the row dimension of the upper bidiagonal matrix.\n\ * This is also the dimension of the main diagonal array D.\n\ *\n\ * SQRE (input) INTEGER\n\ * Specifies the column dimension of the bidiagonal matrix.\n\ * = 0: The bidiagonal matrix has column dimension M = N;\n\ * = 1: The bidiagonal matrix has column dimension M = N+1;\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry D contains the main diagonal of the bidiagonal\n\ * matrix.\n\ * On exit D, if INFO = 0, contains its singular values.\n\ *\n\ * E (input) REAL array, dimension (M-1)\n\ * Contains the subdiagonal entries of the bidiagonal matrix.\n\ * On exit, E has been destroyed.\n\ *\n\ * U (output) REAL array, dimension at least (LDQ, N)\n\ * On exit, U contains the left singular vectors.\n\ *\n\ * LDU (input) INTEGER\n\ * On entry, leading dimension of U.\n\ *\n\ * VT (output) REAL array, dimension at least (LDVT, M)\n\ * On exit, VT' contains the right singular vectors.\n\ *\n\ * LDVT (input) INTEGER\n\ * On entry, leading dimension of VT.\n\ *\n\ * SMLSIZ (input) INTEGER\n\ * On entry, maximum size of the subproblems at the\n\ * bottom of the computation tree.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (8*N)\n\ *\n\ * WORK (workspace) REAL array, dimension (3*M**2+2*M)\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 = 1, a singular value did not converge\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ming Gu and Huan Ren, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, I1, IC, IDXQ, IDXQC, IM1, INODE, ITEMP, IWK,\n $ J, LF, LL, LVL, M, NCC, ND, NDB1, NDIML, NDIMR,\n $ NL, NLF, NLP1, NLVL, NR, NRF, NRP1, SQREI\n REAL ALPHA, BETA\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SLASD1, SLASDQ, SLASDT, XERBLA\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/stpttr0000644000175000017500000000441412502223526016553 0ustar uwabamiuwabami--- :name: stpttr :md5sum: 9c07897dfa04ac8ad6c902bcba53ac0d :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input :dims: - ldap - a: :type: real :intent: output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: lda: MAX(1,n) n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE STPTTR( UPLO, N, AP, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STPTTR copies a triangular matrix A from standard packed format (TP)\n\ * to standard full format (TR).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular.\n\ * = 'L': A is lower triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input) REAL array, dimension ( N*(N+1)/2 ),\n\ * On entry, the upper or lower triangular matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * A (output) REAL array, dimension ( LDA, N )\n\ * On exit, the triangular matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dspgst0000644000175000017500000000513712502223526016522 0ustar uwabamiuwabami--- :name: dspgst :md5sum: 48403040935324240d0e4c768206ee8a :category: :subroutine :arguments: - itype: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - bp: :type: doublereal :intent: input :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DSPGST( ITYPE, UPLO, N, AP, BP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSPGST reduces a real symmetric-definite generalized eigenproblem\n\ * to standard form, using packed storage.\n\ *\n\ * If ITYPE = 1, the problem is A*x = lambda*B*x,\n\ * and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)\n\ *\n\ * If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n\ * B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.\n\ *\n\ * B must have been previously factorized as U**T*U or L*L**T by DPPTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);\n\ * = 2 or 3: compute U*A*U**T or L**T*A*L.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored and B is factored as\n\ * U**T*U;\n\ * = 'L': Lower triangle of A is stored and B is factored as\n\ * L*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, if INFO = 0, the transformed matrix, stored in the\n\ * same format as A.\n\ *\n\ * BP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * The triangular factor from the Cholesky factorization of B,\n\ * stored in the same format as A, as returned by DPPTRF.\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clahr20000644000175000017500000001155612502223525016372 0ustar uwabamiuwabami--- :name: clahr2 :md5sum: 830e928c511e3ec5d35e891b95ae225c :category: :subroutine :arguments: - n: :type: integer :intent: input - k: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n-k+1 - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - MAX(1,nb) - t: :type: complex :intent: output :dims: - ldt - MAX(1,nb) - ldt: :type: integer :intent: input - y: :type: complex :intent: output :dims: - ldy - MAX(1,nb) - ldy: :type: integer :intent: input :substitutions: ldy: n ldt: nb :fortran_help: " SUBROUTINE CLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1)\n\ * matrix A so that elements below the k-th subdiagonal are zero. The\n\ * reduction is performed by an unitary similarity transformation\n\ * Q' * A * Q. The routine returns the matrices V and T which determine\n\ * Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n\ *\n\ * This is an auxiliary routine called by CGEHRD.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A.\n\ *\n\ * K (input) INTEGER\n\ * The offset for the reduction. Elements below the k-th\n\ * subdiagonal in the first NB columns are reduced to zero.\n\ * K < N.\n\ *\n\ * NB (input) INTEGER\n\ * The number of columns to be reduced.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N-K+1)\n\ * On entry, the n-by-(n-k+1) general matrix A.\n\ * On exit, the elements on and above the k-th subdiagonal in\n\ * the first NB columns are overwritten with the corresponding\n\ * elements of the reduced matrix; the elements below the k-th\n\ * subdiagonal, with the array TAU, represent the matrix Q as a\n\ * product of elementary reflectors. The other columns of A are\n\ * unchanged. See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * TAU (output) COMPLEX array, dimension (NB)\n\ * The scalar factors of the elementary reflectors. See Further\n\ * Details.\n\ *\n\ * T (output) COMPLEX array, dimension (LDT,NB)\n\ * The upper triangular matrix T.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= NB.\n\ *\n\ * Y (output) COMPLEX array, dimension (LDY,NB)\n\ * The n-by-nb matrix Y.\n\ *\n\ * LDY (input) INTEGER\n\ * The leading dimension of the array Y. LDY >= N.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The matrix Q is represented as a product of nb elementary reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(nb).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar, and v is a complex vector with\n\ * v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n\ * A(i+k+1:n,i), and tau in TAU(i).\n\ *\n\ * The elements of the vectors v together form the (n-k+1)-by-nb matrix\n\ * V which is needed, with T and Y, to apply the transformation to the\n\ * unreduced part of the matrix, using an update of the form:\n\ * A := (I - V*T*V') * (A - Y*V').\n\ *\n\ * The contents of A on exit are illustrated by the following example\n\ * with n = 7, k = 3 and nb = 2:\n\ *\n\ * ( a a a a a )\n\ * ( a a a a a )\n\ * ( a a a a a )\n\ * ( h h a a a )\n\ * ( v1 h a a a )\n\ * ( v1 v2 a a a )\n\ * ( v1 v2 a a a )\n\ *\n\ * where a denotes an element of the original matrix A, h denotes a\n\ * modified element of the upper Hessenberg matrix H, and vi denotes an\n\ * element of the vector defining H(i).\n\ *\n\ * This subroutine is a slight modification of LAPACK-3.0's DLAHRD\n\ * incorporating improvements proposed by Quintana-Orti and Van de\n\ * Gejin. Note that the entries of A(1:K,2:NB) differ from those\n\ * returned by the original LAPACK-3.0's DLAHRD routine. (This\n\ * subroutine is not backward compatible with LAPACK-3.0's DLAHRD.)\n\ *\n\ * References\n\ * ==========\n\ *\n\ * Gregorio Quintana-Orti and Robert van de Geijn, \"Improving the\n\ * performance of reduction to Hessenberg form,\" ACM Transactions on\n\ * Mathematical Software, 32(2):180-194, June 2006.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlarzb0000644000175000017500000001036212502223526016470 0ustar uwabamiuwabami--- :name: dlarzb :md5sum: f96a6fc175b682aa86c9a5b8a426ef27 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - direct: :type: char :intent: input - storev: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - v: :type: doublereal :intent: input :dims: - ldv - nv - ldv: :type: integer :intent: input - t: :type: doublereal :intent: input :dims: - ldt - k - ldt: :type: integer :intent: input - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - ldwork - k - ldwork: :type: integer :intent: input :substitutions: ldwork: "MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0" :fortran_help: " SUBROUTINE DLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLARZB applies a real block reflector H or its transpose H**T to\n\ * a real distributed M-by-N C from the left or the right.\n\ *\n\ * Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply H or H' from the Left\n\ * = 'R': apply H or H' from the Right\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': apply H (No transpose)\n\ * = 'C': apply H' (Transpose)\n\ *\n\ * DIRECT (input) CHARACTER*1\n\ * Indicates how H is formed from a product of elementary\n\ * reflectors\n\ * = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n\ * = 'B': H = H(k) . . . H(2) H(1) (Backward)\n\ *\n\ * STOREV (input) CHARACTER*1\n\ * Indicates how the vectors which define the elementary\n\ * reflectors are stored:\n\ * = 'C': Columnwise (not supported yet)\n\ * = 'R': Rowwise\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C.\n\ *\n\ * K (input) INTEGER\n\ * The order of the matrix T (= the number of elementary\n\ * reflectors whose product defines the block reflector).\n\ *\n\ * L (input) INTEGER\n\ * The number of columns of the matrix V containing the\n\ * meaningful part of the Householder reflectors.\n\ * If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n\ *\n\ * V (input) DOUBLE PRECISION array, dimension (LDV,NV).\n\ * If STOREV = 'C', NV = K; if STOREV = 'R', NV = L.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V.\n\ * If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K.\n\ *\n\ * T (input) DOUBLE PRECISION array, dimension (LDT,K)\n\ * The triangular K-by-K matrix T in the representation of the\n\ * block reflector.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= K.\n\ *\n\ * C (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by H*C or H'*C or C*H or C*H'.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K)\n\ *\n\ * LDWORK (input) INTEGER\n\ * The leading dimension of the array WORK.\n\ * If SIDE = 'L', LDWORK >= max(1,N);\n\ * if SIDE = 'R', LDWORK >= max(1,M).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zggglm0000644000175000017500000001234412502223526016503 0ustar uwabamiuwabami--- :name: zggglm :md5sum: 4dfcb5e46048a0cc50cbd11d22ab8d4f :category: :subroutine :arguments: - n: :type: integer :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - m - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - p - ldb: :type: integer :intent: input - d: :type: doublecomplex :intent: input/output :dims: - n - x: :type: doublecomplex :intent: output :dims: - m - y: :type: doublecomplex :intent: output :dims: - p - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m+n+p - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGGGLM solves a general Gauss-Markov linear model (GLM) problem:\n\ *\n\ * minimize || y ||_2 subject to d = A*x + B*y\n\ * x\n\ *\n\ * where A is an N-by-M matrix, B is an N-by-P matrix, and d is a\n\ * given N-vector. It is assumed that M <= N <= M+P, and\n\ *\n\ * rank(A) = M and rank( A B ) = N.\n\ *\n\ * Under these assumptions, the constrained equation is always\n\ * consistent, and there is a unique solution x and a minimal 2-norm\n\ * solution y, which is obtained using a generalized QR factorization\n\ * of the matrices (A, B) given by\n\ *\n\ * A = Q*(R), B = Q*T*Z.\n\ * (0)\n\ *\n\ * In particular, if matrix B is square nonsingular, then the problem\n\ * GLM is equivalent to the following weighted linear least squares\n\ * problem\n\ *\n\ * minimize || inv(B)*(d-A*x) ||_2\n\ * x\n\ *\n\ * where inv(B) denotes the inverse of B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of rows of the matrices A and B. N >= 0.\n\ *\n\ * M (input) INTEGER\n\ * The number of columns of the matrix A. 0 <= M <= N.\n\ *\n\ * P (input) INTEGER\n\ * The number of columns of the matrix B. P >= N-M.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,M)\n\ * On entry, the N-by-M matrix A.\n\ * On exit, the upper triangular part of the array A contains\n\ * the M-by-M upper triangular matrix R.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,P)\n\ * On entry, the N-by-P matrix B.\n\ * On exit, if N <= P, the upper triangle of the subarray\n\ * B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n\ * if N > P, the elements on and above the (N-P)th subdiagonal\n\ * contain the N-by-P upper trapezoidal matrix T.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * D (input/output) COMPLEX*16 array, dimension (N)\n\ * On entry, D is the left hand side of the GLM equation.\n\ * On exit, D is destroyed.\n\ *\n\ * X (output) COMPLEX*16 array, dimension (M)\n\ * Y (output) COMPLEX*16 array, dimension (P)\n\ * On exit, X and Y are the solutions of the GLM problem.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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,N+M+P).\n\ * For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,\n\ * where NB is an upper bound for the optimal blocksizes for\n\ * ZGEQRF, ZGERQF, ZUNMQR and ZUNMRQ.\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\ * = 1: the upper triangular factor R associated with A in the\n\ * generalized QR factorization of the pair (A, B) is\n\ * singular, so that rank(A) < M; the least squares\n\ * solution could not be computed.\n\ * = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal\n\ * factor T associated with B in the generalized QR\n\ * factorization of the pair (A, B) is singular, so that\n\ * rank( A B ) < N; the least squares solution could not\n\ * be computed.\n\ *\n\n\ * ===================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsycon0000644000175000017500000000550612502223526016515 0ustar uwabamiuwabami--- :name: dsycon :md5sum: f24dbdb6547b437650c544720f6da760 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 2*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSYCON estimates the reciprocal of the condition number (in the\n\ * 1-norm) of a real symmetric matrix A using the factorization\n\ * A = U*D*U**T or A = L*D*L**T computed by DSYTRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by DSYTRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by DSYTRF.\n\ *\n\ * ANORM (input) DOUBLE PRECISION\n\ * The 1-norm of the original matrix A.\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n\ * estimate of the 1-norm of inv(A) computed in this routine.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlasq10000644000175000017500000000475512502223526016410 0ustar uwabamiuwabami--- :name: dlasq1 :md5sum: 64432270af33eae03a6a5fd907dae092 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n - work: :type: doublereal :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLASQ1( N, D, E, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLASQ1 computes the singular values of a real N-by-N bidiagonal\n\ * matrix with diagonal D and off-diagonal E. The singular values\n\ * are computed to high relative accuracy, in the absence of\n\ * denormalization, underflow and overflow. The algorithm was first\n\ * presented in\n\ *\n\ * \"Accurate singular values and differential qd algorithms\" by K. V.\n\ * Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230,\n\ * 1994,\n\ *\n\ * and the present implementation is described in \"An implementation of\n\ * the dqds Algorithm (Positive Case)\", LAPACK Working Note.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of rows and columns in the matrix. N >= 0.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, D contains the diagonal elements of the\n\ * bidiagonal matrix whose SVD is desired. On normal exit,\n\ * D contains the singular values in decreasing order.\n\ *\n\ * E (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, elements E(1:N-1) contain the off-diagonal elements\n\ * of the bidiagonal matrix whose SVD is desired.\n\ * On exit, E is overwritten.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: the algorithm failed\n\ * = 1, a split was marked by a positive value in E\n\ * = 2, current block of Z not diagonalized after 30*N\n\ * iterations (in inner while loop)\n\ * = 3, termination criterion of outer while loop not met \n\ * (program created more than N unreduced blocks)\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgetrs0000644000175000017500000000475512502223526016541 0ustar uwabamiuwabami--- :name: zgetrs :md5sum: e6b23e55b9e2004e66cec7e32ea11589 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGETRS solves a system of linear equations\n\ * A * X = B, A**T * X = B, or A**H * X = B\n\ * with a general N-by-N matrix A using the LU factorization computed\n\ * by ZGETRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The factors L and U from the factorization A = P*L*U\n\ * as computed by ZGETRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from ZGETRF; for 1<=i<=N, row i of the\n\ * matrix was interchanged with row IPIV(i).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slahqr0000644000175000017500000001452312502223526016507 0ustar uwabamiuwabami--- :name: slahqr :md5sum: 5cbfbd1abeed40e4a90c345cdab7c428 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: real :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - wr: :type: real :intent: output :dims: - n - wi: :type: real :intent: output :dims: - n - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: real :intent: input/output :dims: - "wantz ? ldz : 0" - "wantz ? n : 0" - ldz: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILOZ, IHIZ, Z, LDZ, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAHQR is an auxiliary routine called by SHSEQR to update the\n\ * eigenvalues and Schur decomposition already computed by SHSEQR, by\n\ * dealing with the Hessenberg submatrix in rows and columns ILO to\n\ * IHI.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * WANTT (input) LOGICAL\n\ * = .TRUE. : the full Schur form T is required;\n\ * = .FALSE.: only eigenvalues are required.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * = .TRUE. : the matrix of Schur vectors Z is required;\n\ * = .FALSE.: Schur vectors are not required.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * It is assumed that H is already upper quasi-triangular in\n\ * rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless\n\ * ILO = 1). SLAHQR works primarily with the Hessenberg\n\ * submatrix in rows and columns ILO to IHI, but applies\n\ * transformations to all of H if WANTT is .TRUE..\n\ * 1 <= ILO <= max(1,IHI); IHI <= N.\n\ *\n\ * H (input/output) REAL array, dimension (LDH,N)\n\ * On entry, the upper Hessenberg matrix H.\n\ * On exit, if INFO is zero and if WANTT is .TRUE., H is upper\n\ * quasi-triangular in rows and columns ILO:IHI, with any\n\ * 2-by-2 diagonal blocks in standard form. If INFO is zero\n\ * and WANTT is .FALSE., the contents of H are unspecified on\n\ * exit. The output state of H if INFO is nonzero is given\n\ * below under the description of INFO.\n\ *\n\ * LDH (input) INTEGER\n\ * The leading dimension of the array H. LDH >= max(1,N).\n\ *\n\ * WR (output) REAL array, dimension (N)\n\ * WI (output) REAL array, dimension (N)\n\ * The real and imaginary parts, respectively, of the computed\n\ * eigenvalues ILO to IHI are stored in the corresponding\n\ * elements of WR and WI. If two eigenvalues are computed as a\n\ * complex conjugate pair, they are stored in consecutive\n\ * elements of WR and WI, say the i-th and (i+1)th, with\n\ * WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the\n\ * eigenvalues are stored in the same order as on the diagonal\n\ * of the Schur form returned in H, with WR(i) = H(i,i), and, if\n\ * H(i:i+1,i:i+1) is a 2-by-2 diagonal block,\n\ * WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i).\n\ *\n\ * ILOZ (input) INTEGER\n\ * IHIZ (input) INTEGER\n\ * Specify the rows of Z to which transformations must be\n\ * applied if WANTZ is .TRUE..\n\ * 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.\n\ *\n\ * Z (input/output) REAL array, dimension (LDZ,N)\n\ * If WANTZ is .TRUE., on entry Z must contain the current\n\ * matrix Z of transformations accumulated by SHSEQR, and on\n\ * exit Z has been updated; transformations are applied only to\n\ * the submatrix Z(ILOZ:IHIZ,ILO:IHI).\n\ * If WANTZ is .FALSE., Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * .GT. 0: If INFO = i, SLAHQR failed to compute all the\n\ * eigenvalues ILO to IHI in a total of 30 iterations\n\ * per eigenvalue; elements i+1:ihi of WR and WI\n\ * contain those eigenvalues which have been\n\ * successfully computed.\n\ *\n\ * If INFO .GT. 0 and WANTT is .FALSE., then on exit,\n\ * the remaining unconverged eigenvalues are the\n\ * eigenvalues of the upper Hessenberg matrix rows\n\ * and columns ILO thorugh INFO of the final, output\n\ * value of H.\n\ *\n\ * If INFO .GT. 0 and WANTT is .TRUE., then on exit\n\ * (*) (initial value of H)*U = U*(final value of H)\n\ * where U is an orthognal matrix. The final\n\ * value of H is upper Hessenberg and triangular in\n\ * rows and columns INFO+1 through IHI.\n\ *\n\ * If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n\ * (final value of Z) = (initial value of Z)*U\n\ * where U is the orthogonal matrix in (*)\n\ * (regardless of the value of WANTT.)\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * 02-96 Based on modifications by\n\ * David Day, Sandia National Laboratory, USA\n\ *\n\ * 12-04 Further modifications by\n\ * Ralph Byers, University of Kansas, USA\n\ * This is a modified version of SLAHQR from LAPACK version 3.0.\n\ * It is (1) more robust against overflow and underflow and\n\ * (2) adopts the more conservative Ahues & Tisseur stopping\n\ * criterion (LAWN 122, 1997).\n\ *\n\ * =========================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlasyf0000644000175000017500000001066412502223526016527 0ustar uwabamiuwabami--- :name: zlasyf :md5sum: e54d78ff2740ce908fef577db94f64f0 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nb: :type: integer :intent: input - kb: :type: integer :intent: output - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - w: :type: doublecomplex :intent: workspace :dims: - ldw - MAX(1,nb) - ldw: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: ldw: MAX(1,n) :fortran_help: " SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLASYF computes a partial factorization of a complex symmetric matrix\n\ * A using the Bunch-Kaufman diagonal pivoting method. The partial\n\ * factorization has the form:\n\ *\n\ * A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:\n\ * ( 0 U22 ) ( 0 D ) ( U12' U22' )\n\ *\n\ * A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L'\n\ * ( L21 I ) ( 0 A22 ) ( 0 I )\n\ *\n\ * where the order of D is at most NB. The actual order is returned in\n\ * the argument KB, and is either NB or NB-1, or N if N <= NB.\n\ * Note that U' denotes the transpose of U.\n\ *\n\ * ZLASYF is an auxiliary routine called by ZSYTRF. It uses blocked code\n\ * (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or\n\ * A22 (if UPLO = 'L').\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NB (input) INTEGER\n\ * The maximum number of columns of the matrix A that should be\n\ * factored. NB should be at least 2 to allow for 2-by-2 pivot\n\ * blocks.\n\ *\n\ * KB (output) INTEGER\n\ * The number of columns of A that were actually factored.\n\ * KB is either NB-1 or NB, or N if N <= NB.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * n-by-n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n-by-n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ * On exit, A contains details of the partial factorization.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D.\n\ * If UPLO = 'U', only the last KB elements of IPIV are set;\n\ * if UPLO = 'L', only the first KB elements are set.\n\ *\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * W (workspace) COMPLEX*16 array, dimension (LDW,NB)\n\ *\n\ * LDW (input) INTEGER\n\ * The leading dimension of the array W. LDW >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slaqr50000644000175000017500000001653512502223526016431 0ustar uwabamiuwabami--- :name: slaqr5 :md5sum: 57ca99e1b1f617787f2fa2e386337500 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - kacc22: :type: integer :intent: input - n: :type: integer :intent: input - ktop: :type: integer :intent: input - kbot: :type: integer :intent: input - nshfts: :type: integer :intent: input - sr: :type: real :intent: input/output :dims: - nshfts - si: :type: real :intent: input/output :dims: - nshfts - h: :type: real :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: real :intent: input/output :dims: - "wantz ? ldz : 0" - "wantz ? ihiz : 0" - ldz: :type: integer :intent: input - v: :type: real :intent: workspace :dims: - ldv - nshfts/2 - ldv: :type: integer :intent: input - u: :type: real :intent: workspace :dims: - ldu - 3*nshfts-3 - ldu: :type: integer :intent: input - nv: :type: integer :intent: input - wv: :type: real :intent: workspace :dims: - ldwv - 3*nshfts-3 - ldwv: :type: integer :intent: input - nh: :type: integer :intent: input - wh: :type: real :intent: workspace :dims: - ldwh - MAX(1,nh) - ldwh: :type: integer :intent: input :substitutions: ldwh: 3*nshfts-3 ldz: n ldwv: nv ldu: 3*nshfts-3 ldv: "3" :fortran_help: " SUBROUTINE SLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, SR, SI, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, WV, LDWV, NH, WH, LDWH )\n\n\ * This auxiliary subroutine called by SLAQR0 performs a\n\ * single small-bulge multi-shift QR sweep.\n\ *\n\n\ * WANTT (input) logical scalar\n\ * WANTT = .true. if the quasi-triangular Schur factor\n\ * is being computed. WANTT is set to .false. otherwise.\n\ *\n\ * WANTZ (input) logical scalar\n\ * WANTZ = .true. if the orthogonal Schur factor is being\n\ * computed. WANTZ is set to .false. otherwise.\n\ *\n\ * KACC22 (input) integer with value 0, 1, or 2.\n\ * Specifies the computation mode of far-from-diagonal\n\ * orthogonal updates.\n\ * = 0: SLAQR5 does not accumulate reflections and does not\n\ * use matrix-matrix multiply to update far-from-diagonal\n\ * matrix entries.\n\ * = 1: SLAQR5 accumulates reflections and uses matrix-matrix\n\ * multiply to update the far-from-diagonal matrix entries.\n\ * = 2: SLAQR5 accumulates reflections, uses matrix-matrix\n\ * multiply to update the far-from-diagonal matrix entries,\n\ * and takes advantage of 2-by-2 block structure during\n\ * matrix multiplies.\n\ *\n\ * N (input) integer scalar\n\ * N is the order of the Hessenberg matrix H upon which this\n\ * subroutine operates.\n\ *\n\ * KTOP (input) integer scalar\n\ * KBOT (input) integer scalar\n\ * These are the first and last rows and columns of an\n\ * isolated diagonal block upon which the QR sweep is to be\n\ * applied. It is assumed without a check that\n\ * either KTOP = 1 or H(KTOP,KTOP-1) = 0\n\ * and\n\ * either KBOT = N or H(KBOT+1,KBOT) = 0.\n\ *\n\ * NSHFTS (input) integer scalar\n\ * NSHFTS gives the number of simultaneous shifts. NSHFTS\n\ * must be positive and even.\n\ *\n\ * SR (input/output) REAL array of size (NSHFTS)\n\ * SI (input/output) REAL array of size (NSHFTS)\n\ * SR contains the real parts and SI contains the imaginary\n\ * parts of the NSHFTS shifts of origin that define the\n\ * multi-shift QR sweep. On output SR and SI may be\n\ * reordered.\n\ *\n\ * H (input/output) REAL array of size (LDH,N)\n\ * On input H contains a Hessenberg matrix. On output a\n\ * multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied\n\ * to the isolated diagonal block in rows and columns KTOP\n\ * through KBOT.\n\ *\n\ * LDH (input) integer scalar\n\ * LDH is the leading dimension of H just as declared in the\n\ * calling procedure. LDH.GE.MAX(1,N).\n\ *\n\ * ILOZ (input) INTEGER\n\ * IHIZ (input) INTEGER\n\ * Specify the rows of Z to which transformations must be\n\ * applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N\n\ *\n\ * Z (input/output) REAL array of size (LDZ,IHI)\n\ * If WANTZ = .TRUE., then the QR Sweep orthogonal\n\ * similarity transformation is accumulated into\n\ * Z(ILOZ:IHIZ,ILO:IHI) from the right.\n\ * If WANTZ = .FALSE., then Z is unreferenced.\n\ *\n\ * LDZ (input) integer scalar\n\ * LDA is the leading dimension of Z just as declared in\n\ * the calling procedure. LDZ.GE.N.\n\ *\n\ * V (workspace) REAL array of size (LDV,NSHFTS/2)\n\ *\n\ * LDV (input) integer scalar\n\ * LDV is the leading dimension of V as declared in the\n\ * calling procedure. LDV.GE.3.\n\ *\n\ * U (workspace) REAL array of size\n\ * (LDU,3*NSHFTS-3)\n\ *\n\ * LDU (input) integer scalar\n\ * LDU is the leading dimension of U just as declared in the\n\ * in the calling subroutine. LDU.GE.3*NSHFTS-3.\n\ *\n\ * NH (input) integer scalar\n\ * NH is the number of columns in array WH available for\n\ * workspace. NH.GE.1.\n\ *\n\ * WH (workspace) REAL array of size (LDWH,NH)\n\ *\n\ * LDWH (input) integer scalar\n\ * Leading dimension of WH just as declared in the\n\ * calling procedure. LDWH.GE.3*NSHFTS-3.\n\ *\n\ * NV (input) integer scalar\n\ * NV is the number of rows in WV agailable for workspace.\n\ * NV.GE.1.\n\ *\n\ * WV (workspace) REAL array of size\n\ * (LDWV,3*NSHFTS-3)\n\ *\n\ * LDWV (input) integer scalar\n\ * LDWV is the leading dimension of WV as declared in the\n\ * in the calling subroutine. LDWV.GE.NV.\n\ *\n\n\ * ================================================================\n\ * Based on contributions by\n\ * Karen Braman and Ralph Byers, Department of Mathematics,\n\ * University of Kansas, USA\n\ *\n\ * ================================================================\n\ * Reference:\n\ *\n\ * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n\ * Algorithm Part I: Maintaining Well Focused Shifts, and\n\ * Level 3 Performance, SIAM Journal of Matrix Analysis,\n\ * volume 23, pages 929--947, 2002.\n\ *\n\ * ================================================================\n" ruby-lapack-1.7.2/dev/defs/dormhr0000644000175000017500000001226412502223526016510 0ustar uwabamiuwabami--- :name: dormhr :md5sum: 1aa88be0d6f9f382347ae47d367d3cfc :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - m-1 - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DORMHR overwrites the general real M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'T': Q**T * C C * Q**T\n\ *\n\ * where Q is a real orthogonal matrix of order nq, with nq = m if\n\ * SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of\n\ * IHI-ILO elementary reflectors, as returned by DGEHRD:\n\ *\n\ * Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**T from the Left;\n\ * = 'R': apply Q or Q**T from the Right.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q;\n\ * = 'T': Transpose, apply Q**T.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * ILO and IHI must have the same values as in the previous call\n\ * of DGEHRD. Q is equal to the unit matrix except in the\n\ * submatrix Q(ilo+1:ihi,ilo+1:ihi).\n\ * If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and\n\ * ILO = 1 and IHI = 0, if M = 0;\n\ * if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and\n\ * ILO = 1 and IHI = 0, if N = 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension\n\ * (LDA,M) if SIDE = 'L'\n\ * (LDA,N) if SIDE = 'R'\n\ * The vectors which define the elementary reflectors, as\n\ * returned by DGEHRD.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ * LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n\ *\n\ * TAU (input) DOUBLE PRECISION array, dimension\n\ * (M-1) if SIDE = 'L'\n\ * (N-1) if SIDE = 'R'\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by DGEHRD.\n\ *\n\ * C (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M).\n\ * For optimum performance LWORK >= N*NB if SIDE = 'L', and\n\ * LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n\ * 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\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LEFT, LQUERY\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DORMQR, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cggglm0000644000175000017500000001225612502223525016455 0ustar uwabamiuwabami--- :name: cggglm :md5sum: 52c910bf2bf7160e16593f1ec7fc216f :category: :subroutine :arguments: - n: :type: integer :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - m - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - p - ldb: :type: integer :intent: input - d: :type: complex :intent: input/output :dims: - n - x: :type: complex :intent: output :dims: - m - y: :type: complex :intent: output :dims: - p - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m+n+p - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGGGLM solves a general Gauss-Markov linear model (GLM) problem:\n\ *\n\ * minimize || y ||_2 subject to d = A*x + B*y\n\ * x\n\ *\n\ * where A is an N-by-M matrix, B is an N-by-P matrix, and d is a\n\ * given N-vector. It is assumed that M <= N <= M+P, and\n\ *\n\ * rank(A) = M and rank( A B ) = N.\n\ *\n\ * Under these assumptions, the constrained equation is always\n\ * consistent, and there is a unique solution x and a minimal 2-norm\n\ * solution y, which is obtained using a generalized QR factorization\n\ * of the matrices (A, B) given by\n\ *\n\ * A = Q*(R), B = Q*T*Z.\n\ * (0)\n\ *\n\ * In particular, if matrix B is square nonsingular, then the problem\n\ * GLM is equivalent to the following weighted linear least squares\n\ * problem\n\ *\n\ * minimize || inv(B)*(d-A*x) ||_2\n\ * x\n\ *\n\ * where inv(B) denotes the inverse of B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of rows of the matrices A and B. N >= 0.\n\ *\n\ * M (input) INTEGER\n\ * The number of columns of the matrix A. 0 <= M <= N.\n\ *\n\ * P (input) INTEGER\n\ * The number of columns of the matrix B. P >= N-M.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,M)\n\ * On entry, the N-by-M matrix A.\n\ * On exit, the upper triangular part of the array A contains\n\ * the M-by-M upper triangular matrix R.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,P)\n\ * On entry, the N-by-P matrix B.\n\ * On exit, if N <= P, the upper triangle of the subarray\n\ * B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n\ * if N > P, the elements on and above the (N-P)th subdiagonal\n\ * contain the N-by-P upper trapezoidal matrix T.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * D (input/output) COMPLEX array, dimension (N)\n\ * On entry, D is the left hand side of the GLM equation.\n\ * On exit, D is destroyed.\n\ *\n\ * X (output) COMPLEX array, dimension (M)\n\ * Y (output) COMPLEX array, dimension (P)\n\ * On exit, X and Y are the solutions of the GLM problem.\n\ *\n\ * WORK (workspace/output) COMPLEX 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,N+M+P).\n\ * For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,\n\ * where NB is an upper bound for the optimal blocksizes for\n\ * CGEQRF, CGERQF, CUNMQR and CUNMRQ.\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\ * = 1: the upper triangular factor R associated with A in the\n\ * generalized QR factorization of the pair (A, B) is\n\ * singular, so that rank(A) < M; the least squares\n\ * solution could not be computed.\n\ * = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal\n\ * factor T associated with B in the generalized QR\n\ * factorization of the pair (A, B) is singular, so that\n\ * rank( A B ) < N; the least squares solution could not\n\ * be computed.\n\ *\n\n\ * ===================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlange0000644000175000017500000000475012502223526016476 0ustar uwabamiuwabami--- :name: zlange :md5sum: 50408df6803944fddcccdb05db912293 :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? m : 0" :fortran_help: " DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLANGE returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * complex matrix A.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * ZLANGE returns the value\n\ *\n\ * ZLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in ZLANGE as described\n\ * above.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A. M >= 0. When M = 0,\n\ * ZLANGE is set to zero.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix A. N >= 0. When N = 0,\n\ * ZLANGE is set to zero.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The m by n matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(M,1).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n\ * referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zstedc0000644000175000017500000001747712502223526016524 0ustar uwabamiuwabami--- :name: zstedc :md5sum: 369d6e9078072178eaab9195160df8f7 :category: :subroutine :arguments: - compz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - z: :type: doublecomplex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(lsame_(&compz,\"N\")||lsame_(&compz,\"I\")||n<=1) ? 1 : lsame_(&compz,\"V\") ? n*n : 0" - rwork: :type: doublereal :intent: output :dims: - MAX(1,lrwork) - lrwork: :type: integer :intent: input :option: true :default: "(lsame_(&compz,\"N\")||n<=1) ? 1 : lsame_(&compz,\"V\") ? 1+3*n+2*n*LG(n)+3*n*n : lsame_(&compz,\"I\") ? 1+4*n+2*n*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "(lsame_(&compz,\"N\")||n<=1) ? 1 : lsame_(&compz,\"V\") ? 6+6*n+5*n*LG(n) : lsame_(&compz,\"I\") ? 3+5*n : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSTEDC computes all eigenvalues and, optionally, eigenvectors of a\n\ * symmetric tridiagonal matrix using the divide and conquer method.\n\ * The eigenvectors of a full or band complex Hermitian matrix can also\n\ * be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this\n\ * matrix to tridiagonal form.\n\ *\n\ * This code makes very mild assumptions about floating point\n\ * arithmetic. It will work on machines with a guard digit in\n\ * add/subtract, or on those binary machines without guard digits\n\ * which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n\ * It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none. See DLAED3 for details.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * COMPZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only.\n\ * = 'I': Compute eigenvectors of tridiagonal matrix also.\n\ * = 'V': Compute eigenvectors of original Hermitian matrix\n\ * also. On entry, Z contains the unitary matrix used\n\ * to reduce the original matrix to tridiagonal form.\n\ *\n\ * N (input) INTEGER\n\ * The dimension of the symmetric tridiagonal matrix. N >= 0.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the diagonal elements of the tridiagonal matrix.\n\ * On exit, if INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * E (input/output) DOUBLE PRECISION array, dimension (N-1)\n\ * On entry, the subdiagonal elements of the tridiagonal matrix.\n\ * On exit, E has been destroyed.\n\ *\n\ * Z (input/output) COMPLEX*16 array, dimension (LDZ,N)\n\ * On entry, if COMPZ = 'V', then Z contains the unitary\n\ * matrix used in the reduction to tridiagonal form.\n\ * On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n\ * orthonormal eigenvectors of the original Hermitian matrix,\n\ * and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n\ * of the symmetric tridiagonal matrix.\n\ * If COMPZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1.\n\ * If eigenvectors are desired, then LDZ >= max(1,N).\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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\ * If COMPZ = 'N' or 'I', or N <= 1, LWORK must be at least 1.\n\ * If COMPZ = 'V' and N > 1, LWORK must be at least N*N.\n\ * Note that for COMPZ = 'V', then if N is less than or\n\ * equal to the minimum divide size, usually 25, then LWORK need\n\ * only be 1.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the optimal sizes of the WORK, RWORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * RWORK (workspace/output) DOUBLE PRECISION array,\n\ * dimension (LRWORK)\n\ * On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n\ *\n\ * LRWORK (input) INTEGER\n\ * The dimension of the array RWORK.\n\ * If COMPZ = 'N' or N <= 1, LRWORK must be at least 1.\n\ * If COMPZ = 'V' and N > 1, LRWORK must be at least\n\ * 1 + 3*N + 2*N*lg N + 3*N**2 ,\n\ * where lg( N ) = smallest integer k such\n\ * that 2**k >= N.\n\ * If COMPZ = 'I' and N > 1, LRWORK must be at least\n\ * 1 + 4*N + 2*N**2 .\n\ * Note that for COMPZ = 'I' or 'V', then if N is less than or\n\ * equal to the minimum divide size, usually 25, then LRWORK\n\ * need only be max(1,2*(N-1)).\n\ *\n\ * If LRWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK.\n\ * If COMPZ = 'N' or N <= 1, LIWORK must be at least 1.\n\ * If COMPZ = 'V' or N > 1, LIWORK must be at least\n\ * 6 + 6*N + 5*N*lg N.\n\ * If COMPZ = 'I' or N > 1, LIWORK must be at least\n\ * 3 + 5*N .\n\ * Note that for COMPZ = 'I' or 'V', then if N is less than or\n\ * equal to the minimum divide size, usually 25, then LIWORK\n\ * need only be 1.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK 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: The algorithm failed to compute an eigenvalue while\n\ * working on the submatrix lying in rows and columns\n\ * INFO/(N+1) through mod(INFO,N+1).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Jeff Rutter, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/csyrfsx0000644000175000017500000003733612502223525016724 0ustar uwabamiuwabami--- :name: csyrfsx :md5sum: 5751d1c98e030d16ad5c84317087f0a3 :category: :subroutine :arguments: - uplo: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - s: :type: real :intent: input/output :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " SUBROUTINE CSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSYRFSX improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is symmetric indefinite, and\n\ * provides error bounds and backward error estimates for the\n\ * solution. In addition to normwise error bound, the code provides\n\ * maximum componentwise error bound if possible. See comments for\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.\n\ *\n\ * The original system of linear equations may have been equilibrated\n\ * before calling this routine, as described by arguments EQUED and S\n\ * below. In this case, the solution and error bounds returned are\n\ * for the original unequilibrated system.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * EQUED (input) CHARACTER*1\n\ * Specifies the form of equilibration that was done to A\n\ * before calling this routine. This is needed to compute\n\ * the solution and error bounds correctly.\n\ * = 'N': No equilibration\n\ * = 'Y': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(S) * A * diag(S).\n\ * The right hand side B has been changed accordingly.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular\n\ * part of the matrix A, and the strictly lower triangular\n\ * part of A is not referenced. If UPLO = 'L', the leading\n\ * N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX array, dimension (LDAF,N)\n\ * The factored form of the matrix A. AF contains the block\n\ * diagonal matrix D and the multipliers used to obtain the\n\ * factor U or L from the factorization A = U*D*U**T or A =\n\ * L*D*L**T as computed by SSYTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by SSYTRF.\n\ *\n\ * S (input or output) REAL array, dimension (N)\n\ * The scale factors for A. If EQUED = 'Y', A is multiplied on\n\ * the left and right by diag(S). S is an input argument if FACT =\n\ * 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n\ * = 'Y', each element of S must be positive. If S is output, each\n\ * element of S is a power of the radix. If S is input, each element\n\ * of S should be a power of the radix to ensure a reliable solution\n\ * and error estimates. Scaling by powers of the radix does not cause\n\ * rounding errors unless the result underflows or overflows.\n\ * Rounding errors during scaling lead to refining with a matrix that\n\ * is not equivalent to the input matrix, producing error estimates\n\ * that may not be reliable.\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) COMPLEX array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by SGETRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * Componentwise relative backward error. This is the\n\ * componentwise relative backward error of each solution vector X(j)\n\ * (i.e., the smallest relative change in any element of A or B that\n\ * makes X(j) an exact solution).\n\ *\n\ * N_ERR_BNDS (input) INTEGER\n\ * Number of error bounds to return for each right hand side\n\ * and each type (normwise or componentwise). See ERR_BNDS_NORM and\n\ * ERR_BNDS_COMP below.\n\ *\n\ * ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * NPARAMS (input) INTEGER\n\ * Specifies the number of parameters set in PARAMS. If .LE. 0, the\n\ * PARAMS array is never referenced and default values are used.\n\ *\n\ * PARAMS (input / output) REAL array, dimension NPARAMS\n\ * Specifies algorithm parameters. If an entry is .LT. 0.0, then\n\ * that entry will be filled with default value used for that\n\ * parameter. Only positions up to NPARAMS are accessed; defaults\n\ * are used for higher-numbered parameters.\n\ *\n\ * PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n\ * refinement or not.\n\ * Default: 1.0\n\ * = 0.0 : No refinement is performed, and no error bounds are\n\ * computed.\n\ * = 1.0 : Use the double-precision refinement algorithm,\n\ * possibly with doubled-single computations if the\n\ * compilation environment does not support DOUBLE\n\ * PRECISION.\n\ * (other values are reserved for future use)\n\ *\n\ * PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n\ * computations allowed for refinement.\n\ * Default: 10\n\ * Aggressive: Set to 100 to permit convergence using approximate\n\ * factorizations or factorizations other than LU. If\n\ * the factorization uses a technique other than\n\ * Gaussian elimination, the guarantees in\n\ * err_bnds_norm and err_bnds_comp may no longer be\n\ * trustworthy.\n\ *\n\ * PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n\ * will attempt to find a solution with small componentwise\n\ * relative error in the double-precision algorithm. Positive\n\ * is true, 0.0 is false.\n\ * Default: 1.0 (attempt componentwise convergence)\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (2*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit. The solution to every right-hand side is\n\ * guaranteed.\n\ * < 0: If INFO = -i, the i-th argument had an illegal value\n\ * > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgelq20000644000175000017500000000501212502223526016412 0ustar uwabamiuwabami--- :name: zgelq2 :md5sum: 84e06067201c6f460a120e74e1e81915 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - MIN(m,n) - work: :type: doublecomplex :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGELQ2 computes an LQ factorization of a complex 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) COMPLEX*16 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 unitary 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) COMPLEX*16 array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace) COMPLEX*16 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 complex scalar, and v is a complex vector with\n\ * v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in\n\ * A(i,i+1:n), and tau in TAU(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sposvx0000644000175000017500000002545212502223526016562 0ustar uwabamiuwabami--- :name: sposvx :md5sum: 378892e498244c50b29908f4f7980ff2 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - equed: :type: char :intent: input/output - s: :type: real :intent: input/output :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE SPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPOSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to\n\ * compute the solution to a real system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N symmetric positive definite matrix and X and B\n\ * are N-by-NRHS matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', real scaling factors are computed to equilibrate\n\ * the system:\n\ * diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n\ *\n\ * 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n\ * factor the matrix A (after equilibration if FACT = 'E') as\n\ * A = U**T* U, if UPLO = 'U', or\n\ * A = L * L**T, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is a lower triangular\n\ * matrix.\n\ *\n\ * 3. If the leading i-by-i principal minor is not positive definite,\n\ * then the routine returns with INFO = i. Otherwise, the factored\n\ * form of A is used to estimate the condition number of the matrix\n\ * A. If the reciprocal of the condition number is less than machine\n\ * precision, INFO = N+1 is returned as a warning, but the routine\n\ * still goes on to solve for X and compute error bounds as\n\ * described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(S) so that it solves the original system before\n\ * equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AF contains the factored form of A.\n\ * If EQUED = 'Y', the matrix A has been equilibrated\n\ * with scaling factors given by S. A and AF will not\n\ * be modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AF and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A, except if FACT = 'F' and\n\ * EQUED = 'Y', then A must contain the equilibrated matrix\n\ * diag(S)*A*diag(S). If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced. A is not modified if\n\ * FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n\ *\n\ * On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n\ * diag(S)*A*diag(S).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input or output) REAL array, dimension (LDAF,N)\n\ * If FACT = 'F', then AF is an input argument and on entry\n\ * contains the triangular factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T, in the same storage\n\ * format as A. If EQUED .ne. 'N', then AF is the factored form\n\ * of the equilibrated matrix diag(S)*A*diag(S).\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T of the original\n\ * matrix A.\n\ *\n\ * If FACT = 'E', then AF is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T of the equilibrated\n\ * matrix A (see the description of A for the form of the\n\ * equilibrated matrix).\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'Y': Equilibration was done, i.e., A has been replaced by\n\ * diag(S) * A * diag(S).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * S (input or output) REAL array, dimension (N)\n\ * The scale factors for A; not accessed if EQUED = 'N'. S is\n\ * an input argument if FACT = 'F'; otherwise, S is an output\n\ * argument. If FACT = 'F' and EQUED = 'Y', each element of S\n\ * must be positive.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n\ * B is overwritten by diag(S) * B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) REAL array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n\ * the original system of equations. Note that if EQUED = 'Y',\n\ * A and B are modified on exit, and the solution to the\n\ * equilibrated system is inv(diag(S))*X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A after equilibration (if done). If RCOND is less than the\n\ * machine precision (in particular, if RCOND = 0), the matrix\n\ * is singular to working precision. This condition is\n\ * indicated by a return code of INFO > 0.\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) REAL array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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, and i is\n\ * <= N: the leading minor of order i of A is\n\ * not positive definite, so the factorization\n\ * could not be completed, and the solution has not\n\ * been computed. RCOND = 0 is returned.\n\ * = N+1: U is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zsyequb0000644000175000017500000000654012502223526016717 0ustar uwabamiuwabami--- :name: zsyequb :md5sum: 7838e61ddaf85695089baeff8d3a0914 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - n - scond: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSYEQUB computes row and column scalings intended to equilibrate a\n\ * symmetric matrix A and reduce its condition number\n\ * (with respect to the two-norm). S contains the scale factors,\n\ * S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n\ * elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n\ * choice of S puts the condition number of B within a factor N of the\n\ * smallest possible condition number over all possible diagonal\n\ * scalings.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The N-by-N symmetric matrix whose scaling\n\ * factors are to be computed. Only the diagonal elements of A\n\ * are referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * S (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, S contains the scale factors for A.\n\ *\n\ * SCOND (output) DOUBLE PRECISION\n\ * If INFO = 0, S contains the ratio of the smallest S(i) to\n\ * the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n\ * large nor too small, it is not worth scaling by S.\n\ *\n\ * AMAX (output) DOUBLE PRECISION\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (3*N)\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 is nonpositive.\n\ *\n\n\ * Further Details\n\ * ======= =======\n\ *\n\ * Reference: Livne, O.E. and Golub, G.H., \"Scaling by Binormalization\",\n\ * Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004.\n\ * DOI 10.1023/B:NUMA.0000016606.32820.69\n\ * Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slagtf0000644000175000017500000001056412502223526016476 0ustar uwabamiuwabami--- :name: slagtf :md5sum: 122493f77edd75a8cd45086d994ac58d :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - n - lambda: :type: real :intent: input - b: :type: real :intent: input/output :dims: - n-1 - c: :type: real :intent: input/output :dims: - n-1 - tol: :type: real :intent: input - d: :type: real :intent: output :dims: - n-2 - in: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAGTF factorizes the matrix (T - lambda*I), where T is an n by n\n\ * tridiagonal matrix and lambda is a scalar, as\n\ *\n\ * T - lambda*I = PLU,\n\ *\n\ * where P is a permutation matrix, L is a unit lower tridiagonal matrix\n\ * with at most one non-zero sub-diagonal elements per column and U is\n\ * an upper triangular matrix with at most two non-zero super-diagonal\n\ * elements per column.\n\ *\n\ * The factorization is obtained by Gaussian elimination with partial\n\ * pivoting and implicit row scaling.\n\ *\n\ * The parameter LAMBDA is included in the routine so that SLAGTF may\n\ * be used, in conjunction with SLAGTS, to obtain eigenvectors of T by\n\ * inverse iteration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix T.\n\ *\n\ * A (input/output) REAL array, dimension (N)\n\ * On entry, A must contain the diagonal elements of T.\n\ *\n\ * On exit, A is overwritten by the n diagonal elements of the\n\ * upper triangular matrix U of the factorization of T.\n\ *\n\ * LAMBDA (input) REAL\n\ * On entry, the scalar lambda.\n\ *\n\ * B (input/output) REAL array, dimension (N-1)\n\ * On entry, B must contain the (n-1) super-diagonal elements of\n\ * T.\n\ *\n\ * On exit, B is overwritten by the (n-1) super-diagonal\n\ * elements of the matrix U of the factorization of T.\n\ *\n\ * C (input/output) REAL array, dimension (N-1)\n\ * On entry, C must contain the (n-1) sub-diagonal elements of\n\ * T.\n\ *\n\ * On exit, C is overwritten by the (n-1) sub-diagonal elements\n\ * of the matrix L of the factorization of T.\n\ *\n\ * TOL (input) REAL\n\ * On entry, a relative tolerance used to indicate whether or\n\ * not the matrix (T - lambda*I) is nearly singular. TOL should\n\ * normally be chose as approximately the largest relative error\n\ * in the elements of T. For example, if the elements of T are\n\ * correct to about 4 significant figures, then TOL should be\n\ * set to about 5*10**(-4). If TOL is supplied as less than eps,\n\ * where eps is the relative machine precision, then the value\n\ * eps is used in place of TOL.\n\ *\n\ * D (output) REAL array, dimension (N-2)\n\ * On exit, D is overwritten by the (n-2) second super-diagonal\n\ * elements of the matrix U of the factorization of T.\n\ *\n\ * IN (output) INTEGER array, dimension (N)\n\ * On exit, IN contains details of the permutation matrix P. If\n\ * an interchange occurred at the kth step of the elimination,\n\ * then IN(k) = 1, otherwise IN(k) = 0. The element IN(n)\n\ * returns the smallest positive integer j such that\n\ *\n\ * abs( u(j,j) ).le. norm( (T - lambda*I)(j) )*TOL,\n\ *\n\ * where norm( A(j) ) denotes the sum of the absolute values of\n\ * the jth row of the matrix A. If no such j exists then IN(n)\n\ * is returned as zero. If IN(n) is returned as positive, then a\n\ * diagonal element of U is small, indicating that\n\ * (T - lambda*I) is singular or nearly singular,\n\ *\n\ * INFO (output) INTEGER\n\ * = 0 : successful exit\n\ * .lt. 0: if INFO = -k, the kth argument had an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlaqr20000644000175000017500000002066612502223526016407 0ustar uwabamiuwabami--- :name: dlaqr2 :md5sum: e0c45302be6c32704dcfaf7b0ad95ca3 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ktop: :type: integer :intent: input - kbot: :type: integer :intent: input - nw: :type: integer :intent: input - h: :type: doublereal :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: doublereal :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - ns: :type: integer :intent: output - nd: :type: integer :intent: output - sr: :type: doublereal :intent: output :dims: - MAX(1,kbot) - si: :type: doublereal :intent: output :dims: - MAX(1,kbot) - v: :type: doublereal :intent: workspace :dims: - ldv - MAX(1,nw) - ldv: :type: integer :intent: input - nh: :type: integer :intent: input - t: :type: doublereal :intent: workspace :dims: - ldt - MAX(1,nw) - ldt: :type: integer :intent: input - nv: :type: integer :intent: input - wv: :type: doublereal :intent: workspace :dims: - ldwv - MAX(1,nw) - ldwv: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*nw :substitutions: ldwv: nw ldt: nw ldv: nw :fortran_help: " SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n\ * This subroutine is identical to DLAQR3 except that it avoids\n\ * recursion by calling DLAHQR instead of DLAQR4.\n\ *\n\ *\n\ * ******************************************************************\n\ * Aggressive early deflation:\n\ *\n\ * This subroutine accepts as input an upper Hessenberg matrix\n\ * H and performs an orthogonal similarity transformation\n\ * designed to detect and deflate fully converged eigenvalues from\n\ * a trailing principal submatrix. On output H has been over-\n\ * written by a new Hessenberg matrix that is a perturbation of\n\ * an orthogonal similarity transformation of H. It is to be\n\ * hoped that the final version of H has many zero subdiagonal\n\ * entries.\n\ *\n\ * ******************************************************************\n\n\ * WANTT (input) LOGICAL\n\ * If .TRUE., then the Hessenberg matrix H is fully updated\n\ * so that the quasi-triangular Schur factor may be\n\ * computed (in cooperation with the calling subroutine).\n\ * If .FALSE., then only enough of H is updated to preserve\n\ * the eigenvalues.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * If .TRUE., then the orthogonal matrix Z is updated so\n\ * so that the orthogonal Schur factor may be computed\n\ * (in cooperation with the calling subroutine).\n\ * If .FALSE., then Z is not referenced.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H and (if WANTZ is .TRUE.) the\n\ * order of the orthogonal matrix Z.\n\ *\n\ * KTOP (input) INTEGER\n\ * It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n\ * KBOT and KTOP together determine an isolated block\n\ * along the diagonal of the Hessenberg matrix.\n\ *\n\ * KBOT (input) INTEGER\n\ * It is assumed without a check that either\n\ * KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together\n\ * determine an isolated block along the diagonal of the\n\ * Hessenberg matrix.\n\ *\n\ * NW (input) INTEGER\n\ * Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).\n\ *\n\ * H (input/output) DOUBLE PRECISION array, dimension (LDH,N)\n\ * On input the initial N-by-N section of H stores the\n\ * Hessenberg matrix undergoing aggressive early deflation.\n\ * On output H has been transformed by an orthogonal\n\ * similarity transformation, perturbed, and the returned\n\ * to Hessenberg form that (it is to be hoped) has some\n\ * zero subdiagonal entries.\n\ *\n\ * LDH (input) integer\n\ * Leading dimension of H just as declared in the calling\n\ * subroutine. N .LE. LDH\n\ *\n\ * ILOZ (input) INTEGER\n\ * IHIZ (input) INTEGER\n\ * Specify the rows of Z to which transformations must be\n\ * applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n\ *\n\ * Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n\ * IF WANTZ is .TRUE., then on output, the orthogonal\n\ * similarity transformation mentioned above has been\n\ * accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n\ * If WANTZ is .FALSE., then Z is unreferenced.\n\ *\n\ * LDZ (input) integer\n\ * The leading dimension of Z just as declared in the\n\ * calling subroutine. 1 .LE. LDZ.\n\ *\n\ * NS (output) integer\n\ * The number of unconverged (ie approximate) eigenvalues\n\ * returned in SR and SI that may be used as shifts by the\n\ * calling subroutine.\n\ *\n\ * ND (output) integer\n\ * The number of converged eigenvalues uncovered by this\n\ * subroutine.\n\ *\n\ * SR (output) DOUBLE PRECISION array, dimension (KBOT)\n\ * SI (output) DOUBLE PRECISION array, dimension (KBOT)\n\ * On output, the real and imaginary parts of approximate\n\ * eigenvalues that may be used for shifts are stored in\n\ * SR(KBOT-ND-NS+1) through SR(KBOT-ND) and\n\ * SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.\n\ * The real and imaginary parts of converged eigenvalues\n\ * are stored in SR(KBOT-ND+1) through SR(KBOT) and\n\ * SI(KBOT-ND+1) through SI(KBOT), respectively.\n\ *\n\ * V (workspace) DOUBLE PRECISION array, dimension (LDV,NW)\n\ * An NW-by-NW work array.\n\ *\n\ * LDV (input) integer scalar\n\ * The leading dimension of V just as declared in the\n\ * calling subroutine. NW .LE. LDV\n\ *\n\ * NH (input) integer scalar\n\ * The number of columns of T. NH.GE.NW.\n\ *\n\ * T (workspace) DOUBLE PRECISION array, dimension (LDT,NW)\n\ *\n\ * LDT (input) integer\n\ * The leading dimension of T just as declared in the\n\ * calling subroutine. NW .LE. LDT\n\ *\n\ * NV (input) integer\n\ * The number of rows of work array WV available for\n\ * workspace. NV.GE.NW.\n\ *\n\ * WV (workspace) DOUBLE PRECISION array, dimension (LDWV,NW)\n\ *\n\ * LDWV (input) integer\n\ * The leading dimension of W just as declared in the\n\ * calling subroutine. NW .LE. LDV\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)\n\ * On exit, WORK(1) is set to an estimate of the optimal value\n\ * of LWORK for the given values of N, NW, KTOP and KBOT.\n\ *\n\ * LWORK (input) integer\n\ * The dimension of the work array WORK. LWORK = 2*NW\n\ * suffices, but greater efficiency may result from larger\n\ * values of LWORK.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; DLAQR2\n\ * only estimates the optimal workspace size for the given\n\ * values of N, NW, KTOP and KBOT. The estimate is returned\n\ * in WORK(1). No error message related to LWORK is issued\n\ * by XERBLA. Neither H nor Z are accessed.\n\ *\n\n\ * ================================================================\n\ * Based on contributions by\n\ * Karen Braman and Ralph Byers, Department of Mathematics,\n\ * University of Kansas, USA\n\ *\n\ * ================================================================\n" ruby-lapack-1.7.2/dev/defs/zla_gerfsx_extended0000644000175000017500000003545612502223526021251 0ustar uwabamiuwabami--- :name: zla_gerfsx_extended :md5sum: 85446eaf381da203f656d20ee1d661d6 :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - trans_type: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - colequ: :type: logical :intent: input - c: :type: doublereal :intent: input :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: doublecomplex :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: doublereal :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - errs_n: :type: doublereal :intent: input/output :dims: - nrhs - n_norms - errs_c: :type: doublereal :intent: input/output :dims: - nrhs - n_norms - res: :type: doublecomplex :intent: input :dims: - n - ayb: :type: doublereal :intent: input :dims: - n - dy: :type: doublecomplex :intent: input :dims: - n - y_tail: :type: doublecomplex :intent: input :dims: - n - rcond: :type: doublereal :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: doublereal :intent: input - dz_ub: :type: doublereal :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: n_norms: "3" :fortran_help: " SUBROUTINE ZLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERRS_N, ERRS_C, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLA_GERFSX_EXTENDED improves the computed solution to a system of\n\ * linear equations by performing extra-precise iterative refinement\n\ * and provides error bounds and backward error estimates for the solution.\n\ * This subroutine is called by ZGERFSX to perform iterative refinement.\n\ * In addition to normwise error bound, the code provides maximum\n\ * componentwise error bound if possible. See comments for ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP for details of the error bounds. Note that this\n\ * subroutine is only resonsible for setting the second fields of\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * PREC_TYPE (input) INTEGER\n\ * Specifies the intermediate precision to be used in refinement.\n\ * The value is defined by ILAPREC(P) where P is a CHARACTER and\n\ * P = 'S': Single\n\ * = 'D': Double\n\ * = 'I': Indigenous\n\ * = 'X', 'E': Extra\n\ *\n\ * TRANS_TYPE (input) INTEGER\n\ * Specifies the transposition operation on A.\n\ * The value is defined by ILATRANS(T) where T is a CHARACTER and\n\ * T = 'N': No transpose\n\ * = 'T': Transpose\n\ * = 'C': Conjugate transpose\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right-hand-sides, i.e., the number of columns of the\n\ * matrix B.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX*16 array, dimension (LDAF,N)\n\ * The factors L and U from the factorization\n\ * A = P*L*U as computed by ZGETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from the factorization A = P*L*U\n\ * as computed by ZGETRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * COLEQU (input) LOGICAL\n\ * If .TRUE. then column equilibration was done to A before calling\n\ * this routine. This is needed to compute the solution and error\n\ * bounds correctly.\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension (N)\n\ * The column scale factors for A. If COLEQU = .FALSE., C\n\ * is not accessed. If C is input, each element of C should be a power\n\ * of the radix to ensure a reliable solution and error estimates.\n\ * Scaling by powers of the radix does not cause rounding errors unless\n\ * the result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The right-hand-side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * Y (input/output) COMPLEX*16 array, dimension (LDY,NRHS)\n\ * On entry, the solution matrix X, as computed by ZGETRS.\n\ * On exit, the improved solution matrix Y.\n\ *\n\ * LDY (input) INTEGER\n\ * The leading dimension of the array Y. LDY >= max(1,N).\n\ *\n\ * BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * On exit, BERR_OUT(j) contains the componentwise relative backward\n\ * error for right-hand-side j from the formula\n\ * max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n\ * where abs(Z) is the componentwise absolute value of the matrix\n\ * or vector Z. This is computed by ZLA_LIN_BERR.\n\ *\n\ * N_NORMS (input) INTEGER\n\ * Determines which error bounds to return (see ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP).\n\ * If N_NORMS >= 1 return normwise error bounds.\n\ * If N_NORMS >= 2 return componentwise error bounds.\n\ *\n\ * ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension\n\ * (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension\n\ * (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * RES (input) COMPLEX*16 array, dimension (N)\n\ * Workspace to hold the intermediate residual.\n\ *\n\ * AYB (input) DOUBLE PRECISION array, dimension (N)\n\ * Workspace.\n\ *\n\ * DY (input) COMPLEX*16 array, dimension (N)\n\ * Workspace to hold the intermediate solution.\n\ *\n\ * Y_TAIL (input) COMPLEX*16 array, dimension (N)\n\ * Workspace to hold the trailing bits of the intermediate solution.\n\ *\n\ * RCOND (input) DOUBLE PRECISION\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * ITHRESH (input) INTEGER\n\ * The maximum number of residual computations allowed for\n\ * refinement. The default is 10. For 'aggressive' set to 100 to\n\ * permit convergence using approximate factorizations or\n\ * factorizations other than LU. If the factorization uses a\n\ * technique other than Gaussian elimination, the guarantees in\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n\ *\n\ * RTHRESH (input) DOUBLE PRECISION\n\ * Determines when to stop refinement if the error estimate stops\n\ * decreasing. Refinement will stop when the next solution no longer\n\ * satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n\ * the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n\ * default value is 0.5. For 'aggressive' set to 0.9 to permit\n\ * convergence on extremely ill-conditioned matrices. See LAWN 165\n\ * for more details.\n\ *\n\ * DZ_UB (input) DOUBLE PRECISION\n\ * Determines when to start considering componentwise convergence.\n\ * Componentwise convergence is only considered after each component\n\ * of the solution Y is stable, which we definte as the relative\n\ * change in each component being less than DZ_UB. The default value\n\ * is 0.25, requiring the first bit to be stable. See LAWN 165 for\n\ * more details.\n\ *\n\ * IGNORE_CWISE (input) LOGICAL\n\ * If .TRUE. then ignore componentwise convergence. Default value\n\ * is .FALSE..\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * < 0: if INFO = -i, the ith argument to ZGETRS had an illegal\n\ * value\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n CHARACTER TRANS\n INTEGER CNT, I, J, X_STATE, Z_STATE, Y_PREC_STATE\n DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n COMPLEX*16 ZDUM\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/clarrv0000644000175000017500000002214112655767354016526 0ustar uwabamiuwabami--- :name: clarrv :md5sum: 247eb83eb2fa79b6048985eb11384e6f :category: :subroutine :arguments: - n: :type: integer :intent: input - vl: :type: real :intent: input - vu: :type: real :intent: input - d: :type: real :intent: input/output :dims: - n - l: :type: real :intent: input/output :dims: - n - pivmin: :type: real :intent: input - isplit: :type: integer :intent: input :dims: - n - m: :type: integer :intent: input - dol: :type: integer :intent: input - dou: :type: integer :intent: input - minrgp: :type: real :intent: input - rtol1: :type: real :intent: input - rtol2: :type: real :intent: input - w: :type: real :intent: input/output :dims: - n - werr: :type: real :intent: input/output :dims: - n - wgap: :type: real :intent: input/output :dims: - n - iblock: :type: integer :intent: input :dims: - n - indexw: :type: integer :intent: input :dims: - n - gers: :type: real :intent: input :dims: - 2*n - z: :type: complex :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - work: :type: real :intent: workspace :dims: - 12*n - iwork: :type: integer :intent: workspace :dims: - 7*n - info: :type: integer :intent: output :substitutions: ldz: n :fortran_help: " SUBROUTINE CLARRV( N, VL, VU, D, L, PIVMIN, ISPLIT, M, DOL, DOU, MINRGP, RTOL1, RTOL2, W, WERR, WGAP, IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLARRV computes the eigenvectors of the tridiagonal matrix\n\ * T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T.\n\ * The input eigenvalues should have been computed by SLARRE.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * VL (input) REAL \n\ * VU (input) REAL \n\ * Lower and upper bounds of the interval that contains the desired\n\ * eigenvalues. VL < VU. Needed to compute gaps on the left or right\n\ * end of the extremal eigenvalues in the desired RANGE.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the N diagonal elements of the diagonal matrix D.\n\ * On exit, D may be overwritten.\n\ *\n\ * L (input/output) REAL array, dimension (N)\n\ * On entry, the (N-1) subdiagonal elements of the unit\n\ * bidiagonal matrix L are in elements 1 to N-1 of L\n\ * (if the matrix is not split.) At the end of each block\n\ * is stored the corresponding shift as given by SLARRE.\n\ * On exit, L is overwritten.\n\ *\n\ * PIVMIN (in) DOUBLE PRECISION\n\ * The minimum pivot allowed in the Sturm sequence.\n\ *\n\ * ISPLIT (input) INTEGER array, dimension (N)\n\ * The splitting points, at which T breaks up into blocks.\n\ * The first block consists of rows/columns 1 to\n\ * ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n\ * through ISPLIT( 2 ), etc.\n\ *\n\ * M (input) INTEGER\n\ * The total number of input eigenvalues. 0 <= M <= N.\n\ *\n\ * DOL (input) INTEGER\n\ * DOU (input) INTEGER\n\ * If the user wants to compute only selected eigenvectors from all\n\ * the eigenvalues supplied, he can specify an index range DOL:DOU.\n\ * Or else the setting DOL=1, DOU=M should be applied.\n\ * Note that DOL and DOU refer to the order in which the eigenvalues\n\ * are stored in W.\n\ * If the user wants to compute only selected eigenpairs, then\n\ * the columns DOL-1 to DOU+1 of the eigenvector space Z contain the\n\ * computed eigenvectors. All other columns of Z are set to zero.\n\ *\n\ * MINRGP (input) REAL \n\ *\n\ * RTOL1 (input) REAL \n\ * RTOL2 (input) REAL \n\ * Parameters for bisection.\n\ * An interval [LEFT,RIGHT] has converged if\n\ * RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n\ *\n\ * W (input/output) REAL array, dimension (N)\n\ * The first M elements of W contain the APPROXIMATE eigenvalues for\n\ * which eigenvectors are to be computed. The eigenvalues\n\ * should be grouped by split-off block and ordered from\n\ * smallest to largest within the block ( The output array\n\ * W from SLARRE is expected here ). Furthermore, they are with\n\ * respect to the shift of the corresponding root representation\n\ * for their block. On exit, W holds the eigenvalues of the\n\ * UNshifted matrix.\n\ *\n\ * WERR (input/output) REAL array, dimension (N)\n\ * The first M elements contain the semiwidth of the uncertainty\n\ * interval of the corresponding eigenvalue in W\n\ *\n\ * WGAP (input/output) REAL array, dimension (N)\n\ * The separation from the right neighbor eigenvalue in W.\n\ *\n\ * IBLOCK (input) INTEGER array, dimension (N)\n\ * The indices of the blocks (submatrices) associated with the\n\ * corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue\n\ * W(i) belongs to the first block from the top, =2 if W(i)\n\ * belongs to the second block, etc.\n\ *\n\ * INDEXW (input) INTEGER array, dimension (N)\n\ * The indices of the eigenvalues within each block (submatrix);\n\ * for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the\n\ * i-th eigenvalue W(i) is the 10-th eigenvalue in the second block.\n\ *\n\ * GERS (input) REAL array, dimension (2*N)\n\ * The N Gerschgorin intervals (the i-th Gerschgorin interval\n\ * is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should\n\ * be computed from the original UNshifted matrix.\n\ *\n\ * Z (output) COMPLEX array, dimension (LDZ, max(1,M) )\n\ * If INFO = 0, the first M columns of Z contain the\n\ * orthonormal eigenvectors of the matrix T\n\ * corresponding to the input eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )\n\ * The support of the eigenvectors in Z, i.e., the indices\n\ * indicating the nonzero elements in Z. The I-th eigenvector\n\ * is nonzero only in elements ISUPPZ( 2*I-1 ) through\n\ * ISUPPZ( 2*I ).\n\ *\n\ * WORK (workspace) REAL array, dimension (12*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (7*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ *\n\ * > 0: A problem occured in CLARRV.\n\ * < 0: One of the called subroutines signaled an internal problem.\n\ * Needs inspection of the corresponding parameter IINFO\n\ * for further information.\n\ *\n\ * =-1: Problem in SLARRB when refining a child's eigenvalues.\n\ * =-2: Problem in SLARRF when computing the RRR of a child.\n\ * When a child is inside a tight cluster, it can be difficult\n\ * to find an RRR. A partial remedy from the user's point of\n\ * view is to make the parameter MINRGP smaller and recompile.\n\ * However, as the orthogonality of the computed vectors is\n\ * proportional to 1/MINRGP, the user should be aware that\n\ * he might be trading in precision when he decreases MINRGP.\n\ * =-3: Problem in SLARRB when refining a single eigenvalue\n\ * after the Rayleigh correction was rejected.\n\ * = 5: The Rayleigh Quotient Iteration failed to converge to\n\ * full accuracy in MAXITR steps.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Beresford Parlett, University of California, Berkeley, USA\n\ * Jim Demmel, University of California, Berkeley, USA\n\ * Inderjit Dhillon, University of Texas, Austin, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, University of California, Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctgsy20000644000175000017500000001743012502223525016427 0ustar uwabamiuwabami--- :name: ctgsy2 :md5sum: fd16bf64f0e7ab12a71f285b2f8febc0 :category: :subroutine :arguments: - trans: :type: char :intent: input - ijob: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - b: :type: complex :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - d: :type: complex :intent: input :dims: - ldd - m - ldd: :type: integer :intent: input - e: :type: complex :intent: input :dims: - lde - n - lde: :type: integer :intent: input - f: :type: complex :intent: input/output :dims: - ldf - n - ldf: :type: integer :intent: input - scale: :type: real :intent: output - rdsum: :type: real :intent: input/output - rdscal: :type: real :intent: input/output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTGSY2 solves the generalized Sylvester equation\n\ *\n\ * A * R - L * B = scale * C (1)\n\ * D * R - L * E = scale * F\n\ *\n\ * using Level 1 and 2 BLAS, where R and L are unknown M-by-N matrices,\n\ * (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,\n\ * N-by-N and M-by-N, respectively. A, B, D and E are upper triangular\n\ * (i.e., (A,D) and (B,E) in generalized Schur form).\n\ *\n\ * The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output\n\ * scaling factor chosen to avoid overflow.\n\ *\n\ * In matrix notation solving equation (1) corresponds to solve\n\ * Zx = scale * b, where Z is defined as\n\ *\n\ * Z = [ kron(In, A) -kron(B', Im) ] (2)\n\ * [ kron(In, D) -kron(E', Im) ],\n\ *\n\ * Ik is the identity matrix of size k and X' is the transpose of X.\n\ * kron(X, Y) is the Kronecker product between the matrices X and Y.\n\ *\n\ * If TRANS = 'C', y in the conjugate transposed system Z'y = scale*b\n\ * is solved for, which is equivalent to solve for R and L in\n\ *\n\ * A' * R + D' * L = scale * C (3)\n\ * R * B' + L * E' = scale * -F\n\ *\n\ * This case is used to compute an estimate of Dif[(A, D), (B, E)] =\n\ * = sigma_min(Z) using reverse communicaton with CLACON.\n\ *\n\ * CTGSY2 also (IJOB >= 1) contributes to the computation in CTGSYL\n\ * of an upper bound on the separation between to matrix pairs. Then\n\ * the input (A, D), (B, E) are sub-pencils of two matrix pairs in\n\ * CTGSYL.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N', solve the generalized Sylvester equation (1).\n\ * = 'T': solve the 'transposed' system (3).\n\ *\n\ * IJOB (input) INTEGER\n\ * Specifies what kind of functionality to be performed.\n\ * =0: solve (1) only.\n\ * =1: A contribution from this subsystem to a Frobenius\n\ * norm-based estimate of the separation between two matrix\n\ * pairs is computed. (look ahead strategy is used).\n\ * =2: A contribution from this subsystem to a Frobenius\n\ * norm-based estimate of the separation between two matrix\n\ * pairs is computed. (SGECON on sub-systems is used.)\n\ * Not referenced if TRANS = 'T'.\n\ *\n\ * M (input) INTEGER\n\ * On entry, M specifies the order of A and D, and the row\n\ * dimension of C, F, R and L.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the order of B and E, and the column\n\ * dimension of C, F, R and L.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA, M)\n\ * On entry, A contains an upper triangular matrix.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the matrix A. LDA >= max(1, M).\n\ *\n\ * B (input) COMPLEX array, dimension (LDB, N)\n\ * On entry, B contains an upper triangular matrix.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the matrix B. LDB >= max(1, N).\n\ *\n\ * C (input/output) COMPLEX array, dimension (LDC, N)\n\ * On entry, C contains the right-hand-side of the first matrix\n\ * equation in (1).\n\ * On exit, if IJOB = 0, C has been overwritten by the solution\n\ * R.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the matrix C. LDC >= max(1, M).\n\ *\n\ * D (input) COMPLEX array, dimension (LDD, M)\n\ * On entry, D contains an upper triangular matrix.\n\ *\n\ * LDD (input) INTEGER\n\ * The leading dimension of the matrix D. LDD >= max(1, M).\n\ *\n\ * E (input) COMPLEX array, dimension (LDE, N)\n\ * On entry, E contains an upper triangular matrix.\n\ *\n\ * LDE (input) INTEGER\n\ * The leading dimension of the matrix E. LDE >= max(1, N).\n\ *\n\ * F (input/output) COMPLEX array, dimension (LDF, N)\n\ * On entry, F contains the right-hand-side of the second matrix\n\ * equation in (1).\n\ * On exit, if IJOB = 0, F has been overwritten by the solution\n\ * L.\n\ *\n\ * LDF (input) INTEGER\n\ * The leading dimension of the matrix F. LDF >= max(1, M).\n\ *\n\ * SCALE (output) REAL\n\ * On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions\n\ * R and L (C and F on entry) will hold the solutions to a\n\ * slightly perturbed system but the input matrices A, B, D and\n\ * E have not been changed. If SCALE = 0, R and L will hold the\n\ * solutions to the homogeneous system with C = F = 0.\n\ * Normally, SCALE = 1.\n\ *\n\ * RDSUM (input/output) REAL\n\ * On entry, the sum of squares of computed contributions to\n\ * the Dif-estimate under computation by CTGSYL, where the\n\ * scaling factor RDSCAL (see below) has been factored out.\n\ * On exit, the corresponding sum of squares updated with the\n\ * contributions from the current sub-system.\n\ * If TRANS = 'T' RDSUM is not touched.\n\ * NOTE: RDSUM only makes sense when CTGSY2 is called by\n\ * CTGSYL.\n\ *\n\ * RDSCAL (input/output) REAL\n\ * On entry, scaling factor used to prevent overflow in RDSUM.\n\ * On exit, RDSCAL is updated w.r.t. the current contributions\n\ * in RDSUM.\n\ * If TRANS = 'T', RDSCAL is not touched.\n\ * NOTE: RDSCAL only makes sense when CTGSY2 is called by\n\ * CTGSYL.\n\ *\n\ * INFO (output) INTEGER\n\ * On exit, if INFO is set to\n\ * =0: Successful exit\n\ * <0: If INFO = -i, input argument number i is illegal.\n\ * >0: The matrix pairs (A, D) and (B, E) have common or very\n\ * close eigenvalues.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/claqgb0000644000175000017500000000731712502223525016450 0ustar uwabamiuwabami--- :name: claqgb :md5sum: 3949a6ac3870026b07ce26c34aa20e54 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - r: :type: real :intent: input :dims: - m - c: :type: real :intent: input :dims: - n - rowcnd: :type: real :intent: input - colcnd: :type: real :intent: input - amax: :type: real :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAQGB equilibrates a general M by N band matrix A with KL\n\ * subdiagonals and KU superdiagonals using the row and scaling factors\n\ * in the vectors R and C.\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\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * AB (input/output) COMPLEX array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n\ *\n\ * On exit, the equilibrated matrix, in the same storage format\n\ * as A. See EQUED for the form of the equilibrated matrix.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDA >= KL+KU+1.\n\ *\n\ * R (input) REAL array, dimension (M)\n\ * The row scale factors for A.\n\ *\n\ * C (input) REAL array, dimension (N)\n\ * The column scale factors for A.\n\ *\n\ * ROWCND (input) REAL\n\ * Ratio of the smallest R(i) to the largest R(i).\n\ *\n\ * COLCND (input) REAL\n\ * Ratio of the smallest C(i) to the largest C(i).\n\ *\n\ * AMAX (input) REAL\n\ * Absolute value of largest matrix entry.\n\ *\n\ * EQUED (output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * THRESH is a threshold value used to decide if row or column scaling\n\ * should be done based on the ratio of the row or column scaling\n\ * factors. If ROWCND < THRESH, row scaling is done, and if\n\ * COLCND < THRESH, column scaling is done.\n\ *\n\ * LARGE and SMALL are threshold values used to decide if row scaling\n\ * should be done based on the absolute size of the largest matrix\n\ * element. If AMAX > LARGE or AMAX < SMALL, row scaling is done.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlapmt0000644000175000017500000000403012502223526016466 0ustar uwabamiuwabami--- :name: dlapmt :md5sum: 7e42e3f49a708615b1f14ee2a2897663 :category: :subroutine :arguments: - forwrd: :type: logical :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input - k: :type: integer :intent: input/output :dims: - n :substitutions: {} :fortran_help: " SUBROUTINE DLAPMT( FORWRD, M, N, X, LDX, K )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAPMT rearranges the columns of the M by N matrix X as specified\n\ * by the permutation K(1),K(2),...,K(N) of the integers 1,...,N.\n\ * If FORWRD = .TRUE., forward permutation:\n\ *\n\ * X(*,K(J)) is moved X(*,J) for J = 1,2,...,N.\n\ *\n\ * If FORWRD = .FALSE., backward permutation:\n\ *\n\ * X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FORWRD (input) LOGICAL\n\ * = .TRUE., forward permutation\n\ * = .FALSE., backward permutation\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix X. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix X. N >= 0.\n\ *\n\ * X (input/output) DOUBLE PRECISION array, dimension (LDX,N)\n\ * On entry, the M by N matrix X.\n\ * On exit, X contains the permuted matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X, LDX >= MAX(1,M).\n\ *\n\ * K (input/output) INTEGER array, dimension (N)\n\ * On entry, K contains the permutation vector. K is used as\n\ * internal workspace, but reset to its original value on\n\ * output.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, II, IN, J\n DOUBLE PRECISION TEMP\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slaeda0000644000175000017500000001040512502223526016441 0ustar uwabamiuwabami--- :name: slaeda :md5sum: 24a9751e7a3bb6e15256dfe9218457ca :category: :subroutine :arguments: - n: :type: integer :intent: input - tlvls: :type: integer :intent: input - curlvl: :type: integer :intent: input - curpbm: :type: integer :intent: input - prmptr: :type: integer :intent: input :dims: - n*LG(n) - perm: :type: integer :intent: input :dims: - n*LG(n) - givptr: :type: integer :intent: input :dims: - n*LG(n) - givcol: :type: integer :intent: input :dims: - "2" - n*LG(n) - givnum: :type: real :intent: input :dims: - "2" - n*LG(n) - q: :type: real :intent: input :dims: - pow(n,2) - qptr: :type: integer :intent: input :dims: - ldqptr - z: :type: real :intent: output :dims: - n - ztemp: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ldqptr-2 :fortran_help: " SUBROUTINE SLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAEDA computes the Z vector corresponding to the merge step in the\n\ * CURLVLth step of the merge process with TLVLS steps for the CURPBMth\n\ * problem.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The dimension of the symmetric tridiagonal matrix. N >= 0.\n\ *\n\ * TLVLS (input) INTEGER\n\ * The total number of merging levels in the overall divide and\n\ * conquer tree.\n\ *\n\ * CURLVL (input) INTEGER\n\ * The current level in the overall merge routine,\n\ * 0 <= curlvl <= tlvls.\n\ *\n\ * CURPBM (input) INTEGER\n\ * The current problem in the current level in the overall\n\ * merge routine (counting from upper left to lower right).\n\ *\n\ * PRMPTR (input) INTEGER array, dimension (N lg N)\n\ * Contains a list of pointers which indicate where in PERM a\n\ * level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)\n\ * indicates the size of the permutation and incidentally the\n\ * size of the full, non-deflated problem.\n\ *\n\ * PERM (input) INTEGER array, dimension (N lg N)\n\ * Contains the permutations (from deflation and sorting) to be\n\ * applied to each eigenblock.\n\ *\n\ * GIVPTR (input) INTEGER array, dimension (N lg N)\n\ * Contains a list of pointers which indicate where in GIVCOL a\n\ * level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)\n\ * indicates the number of Givens rotations.\n\ *\n\ * GIVCOL (input) INTEGER array, dimension (2, N lg N)\n\ * Each pair of numbers indicates a pair of columns to take place\n\ * in a Givens rotation.\n\ *\n\ * GIVNUM (input) REAL array, dimension (2, N lg N)\n\ * Each number indicates the S value to be used in the\n\ * corresponding Givens rotation.\n\ *\n\ * Q (input) REAL array, dimension (N**2)\n\ * Contains the square eigenblocks from previous levels, the\n\ * starting positions for blocks are given by QPTR.\n\ *\n\ * QPTR (input) INTEGER array, dimension (N+2)\n\ * Contains a list of pointers which indicate where in Q an\n\ * eigenblock is stored. SQRT( QPTR(i+1) - QPTR(i) ) indicates\n\ * the size of the block.\n\ *\n\ * Z (output) REAL array, dimension (N)\n\ * On output this vector contains the updating vector (the last\n\ * row of the first sub-eigenvector matrix and the first row of\n\ * the second sub-eigenvector matrix).\n\ *\n\ * ZTEMP (workspace) REAL array, dimension (N)\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\ * Based on contributions by\n\ * Jeff Rutter, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dggev0000644000175000017500000001636512502223526016317 0ustar uwabamiuwabami--- :name: dggev :md5sum: 27e8c7132a2cb715913cbcefadd0f718 :category: :subroutine :arguments: - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alphar: :type: doublereal :intent: output :dims: - n - alphai: :type: doublereal :intent: output :dims: - n - beta: :type: doublereal :intent: output :dims: - n - vl: :type: doublereal :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: doublereal :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(1,8*n) - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " SUBROUTINE DGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B)\n\ * the generalized eigenvalues, and optionally, the left and/or right\n\ * generalized eigenvectors.\n\ *\n\ * A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n\ * lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n\ * singular. It is usually represented as the pair (alpha,beta), as\n\ * there is a reasonable interpretation for beta=0, and even for both\n\ * being zero.\n\ *\n\ * The right eigenvector v(j) corresponding to the eigenvalue lambda(j)\n\ * of (A,B) satisfies\n\ *\n\ * A * v(j) = lambda(j) * B * v(j).\n\ *\n\ * The left eigenvector u(j) corresponding to the eigenvalue lambda(j)\n\ * of (A,B) satisfies\n\ *\n\ * u(j)**H * A = lambda(j) * u(j)**H * B .\n\ *\n\ * where u(j)**H is the conjugate-transpose of u(j).\n\ *\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVL (input) CHARACTER*1\n\ * = 'N': do not compute the left generalized eigenvectors;\n\ * = 'V': compute the left generalized eigenvectors.\n\ *\n\ * JOBVR (input) CHARACTER*1\n\ * = 'N': do not compute the right generalized eigenvectors;\n\ * = 'V': compute the right generalized eigenvectors.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A, B, VL, and VR. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n\ * On entry, the matrix A in the pair (A,B).\n\ * On exit, A has been overwritten.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of A. LDA >= max(1,N).\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n\ * On entry, the matrix B in the pair (A,B).\n\ * On exit, B has been overwritten.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B. LDB >= max(1,N).\n\ *\n\ * ALPHAR (output) DOUBLE PRECISION array, dimension (N)\n\ * ALPHAI (output) DOUBLE PRECISION array, dimension (N)\n\ * BETA (output) DOUBLE PRECISION array, dimension (N)\n\ * On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n\ * be the generalized eigenvalues. If ALPHAI(j) is zero, then\n\ * the j-th eigenvalue is real; if positive, then the j-th and\n\ * (j+1)-st eigenvalues are a complex conjugate pair, with\n\ * ALPHAI(j+1) negative.\n\ *\n\ * Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n\ * may easily over- or underflow, and BETA(j) may even be zero.\n\ * Thus, the user should avoid naively computing the ratio\n\ * alpha/beta. However, ALPHAR and ALPHAI will be always less\n\ * than and usually comparable with norm(A) in magnitude, and\n\ * BETA always less than and usually comparable with norm(B).\n\ *\n\ * VL (output) DOUBLE PRECISION array, dimension (LDVL,N)\n\ * If JOBVL = 'V', the left eigenvectors u(j) are stored one\n\ * after another in the columns of VL, in the same order as\n\ * their eigenvalues. If the j-th eigenvalue is real, then\n\ * u(j) = VL(:,j), the j-th column of VL. If the j-th and\n\ * (j+1)-th eigenvalues form a complex conjugate pair, then\n\ * u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).\n\ * Each eigenvector is scaled so the largest component has\n\ * abs(real part)+abs(imag. part)=1.\n\ * Not referenced if JOBVL = 'N'.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the matrix VL. LDVL >= 1, and\n\ * if JOBVL = 'V', LDVL >= N.\n\ *\n\ * VR (output) DOUBLE PRECISION array, dimension (LDVR,N)\n\ * If JOBVR = 'V', the right eigenvectors v(j) are stored one\n\ * after another in the columns of VR, in the same order as\n\ * their eigenvalues. If the j-th eigenvalue is real, then\n\ * v(j) = VR(:,j), the j-th column of VR. If the j-th and\n\ * (j+1)-th eigenvalues form a complex conjugate pair, then\n\ * v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).\n\ * Each eigenvector is scaled so the largest component has\n\ * abs(real part)+abs(imag. part)=1.\n\ * Not referenced if JOBVR = 'N'.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the matrix VR. LDVR >= 1, and\n\ * if JOBVR = 'V', LDVR >= 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. LWORK >= max(1,8*N).\n\ * For good performance, LWORK must generally be larger.\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\ * = 1,...,N:\n\ * The QZ iteration failed. No eigenvectors have been\n\ * calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)\n\ * should be correct for j=INFO+1,...,N.\n\ * > N: =N+1: other than QZ iteration failed in DHGEQZ.\n\ * =N+2: error return from DTGEVC.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgetc20000644000175000017500000000502712502223526016364 0ustar uwabamiuwabami--- :name: dgetc2 :md5sum: 8407e50951ea8e41f50aa9499510d542 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - jpiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGETC2( N, A, LDA, IPIV, JPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGETC2 computes an LU factorization with complete pivoting of the\n\ * n-by-n matrix A. The factorization has the form A = P * L * U * Q,\n\ * where P and Q are permutation matrices, L is lower triangular with\n\ * unit diagonal elements and U is upper triangular.\n\ *\n\ * This is the Level 2 BLAS algorithm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n\ * On entry, the n-by-n matrix A to be factored.\n\ * On exit, the factors L and U from the factorization\n\ * A = P*L*U*Q; the unit diagonal elements of L are not stored.\n\ * If U(k, k) appears to be less than SMIN, U(k, k) is given the\n\ * value of SMIN, i.e., giving a nonsingular perturbed system.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension(N).\n\ * The pivot indices; for 1 <= i <= N, row i of the\n\ * matrix has been interchanged with row IPIV(i).\n\ *\n\ * JPIV (output) INTEGER array, dimension(N).\n\ * The pivot indices; for 1 <= j <= N, column j of the\n\ * matrix has been interchanged with column JPIV(j).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * > 0: if INFO = k, U(k, k) is likely to produce owerflow if\n\ * we try to solve for x in Ax = b. So U is perturbed to\n\ * avoid the overflow.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctrsyl0000644000175000017500000000704212502223525016532 0ustar uwabamiuwabami--- :name: ctrsyl :md5sum: 197d88da50e387a8b9e1087a4832e33a :category: :subroutine :arguments: - trana: :type: char :intent: input - tranb: :type: char :intent: input - isgn: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - b: :type: complex :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - scale: :type: real :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, SCALE, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTRSYL solves the complex Sylvester matrix equation:\n\ *\n\ * op(A)*X + X*op(B) = scale*C or\n\ * op(A)*X - X*op(B) = scale*C,\n\ *\n\ * where op(A) = A or A**H, and A and B are both upper triangular. A is\n\ * M-by-M and B is N-by-N; the right hand side C and the solution X are\n\ * M-by-N; and scale is an output scale factor, set <= 1 to avoid\n\ * overflow in X.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANA (input) CHARACTER*1\n\ * Specifies the option op(A):\n\ * = 'N': op(A) = A (No transpose)\n\ * = 'C': op(A) = A**H (Conjugate transpose)\n\ *\n\ * TRANB (input) CHARACTER*1\n\ * Specifies the option op(B):\n\ * = 'N': op(B) = B (No transpose)\n\ * = 'C': op(B) = B**H (Conjugate transpose)\n\ *\n\ * ISGN (input) INTEGER\n\ * Specifies the sign in the equation:\n\ * = +1: solve op(A)*X + X*op(B) = scale*C\n\ * = -1: solve op(A)*X - X*op(B) = scale*C\n\ *\n\ * M (input) INTEGER\n\ * The order of the matrix A, and the number of rows in the\n\ * matrices X and C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix B, and the number of columns in the\n\ * matrices X and C. N >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,M)\n\ * The upper triangular matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,N)\n\ * The upper triangular matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * C (input/output) COMPLEX array, dimension (LDC,N)\n\ * On entry, the M-by-N right hand side matrix C.\n\ * On exit, C is overwritten by the solution matrix X.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M)\n\ *\n\ * SCALE (output) REAL\n\ * The scale factor, scale, set <= 1 to avoid overflow in X.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * = 1: A and B have common or very close eigenvalues; perturbed\n\ * values were used to solve the equation (but the matrices\n\ * A and B are unchanged).\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsytri0000644000175000017500000000510212502223526016524 0ustar uwabamiuwabami--- :name: dsytri :md5sum: 4da55048240e1b7185e9debffbf1a7e7 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSYTRI computes the inverse of a real symmetric indefinite matrix\n\ * A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n\ * DSYTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the block diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L as computed by DSYTRF.\n\ *\n\ * On exit, if INFO = 0, the (symmetric) inverse of the original\n\ * matrix. If UPLO = 'U', the upper triangular part of the\n\ * inverse is formed and the part of A below the diagonal is not\n\ * referenced; if UPLO = 'L' the lower triangular part of the\n\ * inverse is formed and the part of A above the diagonal is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by DSYTRF.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (N)\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, D(i,i) = 0; the matrix is singular and its\n\ * inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clantp0000644000175000017500000000613612502223525016476 0ustar uwabamiuwabami--- :name: clantp :md5sum: dbd82e1acf27b336626c0bbbfee9eec8 :category: :function :type: real :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - work: :type: real :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? n : 0" :fortran_help: " REAL FUNCTION CLANTP( NORM, UPLO, DIAG, N, AP, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLANTP returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * triangular matrix A, supplied in packed form.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * CLANTP returns the value\n\ *\n\ * CLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in CLANTP as described\n\ * above.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the matrix A is upper or lower triangular.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * Specifies whether or not the matrix A is unit triangular.\n\ * = 'N': Non-unit triangular\n\ * = 'U': Unit triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, CLANTP is\n\ * set to zero.\n\ *\n\ * AP (input) COMPLEX array, dimension (N*(N+1)/2)\n\ * The upper or lower triangular matrix A, packed columnwise in\n\ * a linear array. The j-th column of A is stored in the array\n\ * AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ * Note that when DIAG = 'U', the elements of the array AP\n\ * corresponding to the diagonal elements of the matrix A are\n\ * not referenced, but are assumed to be one.\n\ *\n\ * WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n\ * referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlacn20000644000175000017500000000562212502223526016406 0ustar uwabamiuwabami--- :name: zlacn2 :md5sum: d0aba13d98ac5036c2909c711b5db9b7 :category: :subroutine :arguments: - n: :type: integer :intent: input - v: :type: doublecomplex :intent: workspace :dims: - n - x: :type: doublecomplex :intent: input/output :dims: - n - est: :type: doublereal :intent: input/output - kase: :type: integer :intent: input/output - isave: :type: integer :intent: input/output :dims: - "3" :substitutions: {} :fortran_help: " SUBROUTINE ZLACN2( N, V, X, EST, KASE, ISAVE )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLACN2 estimates the 1-norm of a square, complex matrix A.\n\ * Reverse communication is used for evaluating matrix-vector products.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 1.\n\ *\n\ * V (workspace) COMPLEX*16 array, dimension (N)\n\ * On the final return, V = A*W, where EST = norm(V)/norm(W)\n\ * (W is not returned).\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension (N)\n\ * On an intermediate return, X should be overwritten by\n\ * A * X, if KASE=1,\n\ * A' * X, if KASE=2,\n\ * where A' is the conjugate transpose of A, and ZLACN2 must be\n\ * re-called with all the other parameters unchanged.\n\ *\n\ * EST (input/output) DOUBLE PRECISION\n\ * On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be\n\ * unchanged from the previous call to ZLACN2.\n\ * On exit, EST is an estimate (a lower bound) for norm(A). \n\ *\n\ * KASE (input/output) INTEGER\n\ * On the initial call to ZLACN2, KASE should be 0.\n\ * On an intermediate return, KASE will be 1 or 2, indicating\n\ * whether X should be overwritten by A * X or A' * X.\n\ * On the final return from ZLACN2, KASE will again be 0.\n\ *\n\ * ISAVE (input/output) INTEGER array, dimension (3)\n\ * ISAVE is used to save variables between calls to ZLACN2\n\ *\n\n\ * Further Details\n\ * ======= =======\n\ *\n\ * Contributed by Nick Higham, University of Manchester.\n\ * Originally named CONEST, dated March 16, 1988.\n\ *\n\ * Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n\ * a real or complex matrix, with applications to condition estimation\",\n\ * ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n\ *\n\ * Last modified: April, 1999\n\ *\n\ * This is a thread safe version of ZLACON, which uses the array ISAVE\n\ * in place of a SAVE statement, as follows:\n\ *\n\ * ZLACON ZLACN2\n\ * JUMP ISAVE(1)\n\ * J ISAVE(2)\n\ * ITER ISAVE(3)\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlaqr10000644000175000017500000000423512502223526016400 0ustar uwabamiuwabami--- :name: dlaqr1 :md5sum: ad34e252476d8fc18eea40e0f25e76ec :category: :subroutine :arguments: - n: :type: integer :intent: input - h: :type: doublereal :intent: input :dims: - ldh - n - ldh: :type: integer :intent: input - sr1: :type: doublereal :intent: input - si1: :type: doublereal :intent: input - sr2: :type: doublereal :intent: input - si2: :type: doublereal :intent: input - v: :type: doublereal :intent: output :dims: - n :substitutions: {} :fortran_help: " SUBROUTINE DLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V )\n\n\ * Given a 2-by-2 or 3-by-3 matrix H, DLAQR1 sets v to a\n\ * scalar multiple of the first column of the product\n\ *\n\ * (*) K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I)\n\ *\n\ * scaling to avoid overflows and most underflows. It\n\ * is assumed that either\n\ *\n\ * 1) sr1 = sr2 and si1 = -si2\n\ * or\n\ * 2) si1 = si2 = 0.\n\ *\n\ * This is useful for starting double implicit shift bulges\n\ * in the QR algorithm.\n\ *\n\ *\n\n\ * N (input) integer\n\ * Order of the matrix H. N must be either 2 or 3.\n\ *\n\ * H (input) DOUBLE PRECISION array of dimension (LDH,N)\n\ * The 2-by-2 or 3-by-3 matrix H in (*).\n\ *\n\ * LDH (input) integer\n\ * The leading dimension of H as declared in\n\ * the calling procedure. LDH.GE.N\n\ *\n\ * SR1 (input) DOUBLE PRECISION\n\ * SI1 The shifts in (*).\n\ * SR2\n\ * SI2\n\ *\n\ * V (output) DOUBLE PRECISION array of dimension N\n\ * A scalar multiple of the first column of the\n\ * matrix K in (*).\n\ *\n\n\ * ================================================================\n\ * Based on contributions by\n\ * Karen Braman and Ralph Byers, Department of Mathematics,\n\ * University of Kansas, USA\n\ *\n\ * ================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsytrs0000644000175000017500000000501312502223526016537 0ustar uwabamiuwabami--- :name: dsytrs :md5sum: ca8b35bd83b856d5e15745acb423ab11 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSYTRS solves a system of linear equations A*X = B with a real\n\ * symmetric matrix A using the factorization A = U*D*U**T or\n\ * A = L*D*L**T computed by DSYTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by DSYTRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by DSYTRF.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dtrexc0000644000175000017500000000747212502223526016513 0ustar uwabamiuwabami--- :name: dtrexc :md5sum: f570fee5c461d3f34b24fa3141a74cb3 :category: :subroutine :arguments: - compq: :type: char :intent: input - n: :type: integer :intent: input - t: :type: doublereal :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - q: :type: doublereal :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - ifst: :type: integer :intent: input/output - ilst: :type: integer :intent: input/output - work: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTREXC reorders the real Schur factorization of a real matrix\n\ * A = Q*T*Q**T, so that the diagonal block of T with row index IFST is\n\ * moved to row ILST.\n\ *\n\ * The real Schur form T is reordered by an orthogonal similarity\n\ * transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors\n\ * is updated by postmultiplying it with Z.\n\ *\n\ * T must be in Schur canonical form (as returned by DHSEQR), that is,\n\ * block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each\n\ * 2-by-2 diagonal block has its diagonal elements equal and its\n\ * off-diagonal elements of opposite sign.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * COMPQ (input) CHARACTER*1\n\ * = 'V': update the matrix Q of Schur vectors;\n\ * = 'N': do not update Q.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix T. N >= 0.\n\ *\n\ * T (input/output) DOUBLE PRECISION array, dimension (LDT,N)\n\ * On entry, the upper quasi-triangular matrix T, in Schur\n\ * Schur canonical form.\n\ * On exit, the reordered upper quasi-triangular matrix, again\n\ * in Schur canonical form.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= max(1,N).\n\ *\n\ * Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n\ * On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n\ * On exit, if COMPQ = 'V', Q has been postmultiplied by the\n\ * orthogonal transformation matrix Z which reorders T.\n\ * If COMPQ = 'N', Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N).\n\ *\n\ * IFST (input/output) INTEGER\n\ * ILST (input/output) INTEGER\n\ * Specify the reordering of the diagonal blocks of T.\n\ * The block with row index IFST is moved to row ILST, by a\n\ * sequence of transpositions between adjacent blocks.\n\ * On exit, if IFST pointed on entry to the second row of a\n\ * 2-by-2 block, it is changed to point to the first row; ILST\n\ * always points to the first row of the block in its final\n\ * position (which may differ from its input value by +1 or -1).\n\ * 1 <= IFST <= N; 1 <= ILST <= N.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * = 1: two adjacent blocks were too close to swap (the problem\n\ * is very ill-conditioned); T may have been partially\n\ * reordered, and ILST points to the first row of the\n\ * current position of the block being moved.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctfttp0000644000175000017500000001415512502223525016521 0ustar uwabamiuwabami--- :name: ctfttp :md5sum: 5f4fc9970b485e991ce8f01eb38da11d :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - arf: :type: complex :intent: input :dims: - ( n*(n+1)/2 ) - ap: :type: complex :intent: output :dims: - ( n*(n+1)/2 ) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CTFTTP( TRANSR, UPLO, N, ARF, AP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTFTTP copies a triangular matrix A from rectangular full packed\n\ * format (TF) to standard packed format (TP).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': ARF is in Normal format;\n\ * = 'C': ARF is in Conjugate-transpose format;\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * ARF (input) COMPLEX array, dimension ( N*(N+1)/2 ),\n\ * On entry, the upper or lower triangular matrix A stored in\n\ * RFP format. For a further discussion see Notes below.\n\ *\n\ * AP (output) COMPLEX array, dimension ( N*(N+1)/2 ),\n\ * On exit, the upper or lower triangular matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\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\ * We first consider Standard Packed Format when N is even.\n\ * We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * conjugate-transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * conjugate-transpose of the last three columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- --\n\ * 03 04 05 33 43 53\n\ * -- --\n\ * 13 14 15 00 44 54\n\ * --\n\ * 23 24 25 10 11 55\n\ *\n\ * 33 34 35 20 21 22\n\ * --\n\ * 00 44 45 30 31 32\n\ * -- --\n\ * 01 11 55 40 41 42\n\ * -- -- --\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We next consider Standard Packed Format when N is odd.\n\ * We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * conjugate-transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * conjugate-transpose of the last two columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- --\n\ * 02 03 04 00 33 43\n\ * --\n\ * 12 13 14 10 11 44\n\ *\n\ * 22 23 24 20 21 22\n\ * --\n\ * 00 33 34 30 31 32\n\ * -- --\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- --\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clarfb0000644000175000017500000000763612502223525016454 0ustar uwabamiuwabami--- :name: clarfb :md5sum: 297dbf123408181db136925cb1ae5c61 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - direct: :type: char :intent: input - storev: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - v: :type: complex :intent: input :dims: - ldv - k - ldv: :type: integer :intent: input - t: :type: complex :intent: input :dims: - ldt - k - ldt: :type: integer :intent: input - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - ldwork - k - ldwork: :type: integer :intent: input :substitutions: ldwork: "MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0" :fortran_help: " SUBROUTINE CLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLARFB applies a complex block reflector H or its transpose H' to a\n\ * complex M-by-N matrix C, from either the left or the right.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply H or H' from the Left\n\ * = 'R': apply H or H' from the Right\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': apply H (No transpose)\n\ * = 'C': apply H' (Conjugate transpose)\n\ *\n\ * DIRECT (input) CHARACTER*1\n\ * Indicates how H is formed from a product of elementary\n\ * reflectors\n\ * = 'F': H = H(1) H(2) . . . H(k) (Forward)\n\ * = 'B': H = H(k) . . . H(2) H(1) (Backward)\n\ *\n\ * STOREV (input) CHARACTER*1\n\ * Indicates how the vectors which define the elementary\n\ * reflectors are stored:\n\ * = 'C': Columnwise\n\ * = 'R': Rowwise\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C.\n\ *\n\ * K (input) INTEGER\n\ * The order of the matrix T (= the number of elementary\n\ * reflectors whose product defines the block reflector).\n\ *\n\ * V (input) COMPLEX array, dimension\n\ * (LDV,K) if STOREV = 'C'\n\ * (LDV,M) if STOREV = 'R' and SIDE = 'L'\n\ * (LDV,N) if STOREV = 'R' and SIDE = 'R'\n\ * The matrix V. See further details.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V.\n\ * If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);\n\ * if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);\n\ * if STOREV = 'R', LDV >= K.\n\ *\n\ * T (input) COMPLEX array, dimension (LDT,K)\n\ * The triangular K-by-K matrix T in the representation of the\n\ * block reflector.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= K.\n\ *\n\ * C (input/output) COMPLEX array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by H*C or H'*C or C*H or C*H'.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (LDWORK,K)\n\ *\n\ * LDWORK (input) INTEGER\n\ * The leading dimension of the array WORK.\n\ * If SIDE = 'L', LDWORK >= max(1,N);\n\ * if SIDE = 'R', LDWORK >= max(1,M).\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgbcon0000644000175000017500000000654712502223526016506 0ustar uwabamiuwabami--- :name: zgbcon :md5sum: 88891109a55972c3b9533da471187b59 :category: :subroutine :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGBCON estimates the reciprocal of the condition number of a complex\n\ * general band matrix A, in either the 1-norm or the infinity-norm,\n\ * using the LU factorization computed by ZGBTRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as\n\ * RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies whether the 1-norm condition number or the\n\ * infinity-norm condition number is required:\n\ * = '1' or 'O': 1-norm;\n\ * = 'I': Infinity-norm.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * AB (input) COMPLEX*16 array, dimension (LDAB,N)\n\ * Details of the LU factorization of the band matrix A, as\n\ * computed by ZGBTRF. U is stored as an upper triangular band\n\ * matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n\ * the multipliers used during the factorization are stored in\n\ * rows KL+KU+2 to 2*KL+KU+1.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices; for 1 <= i <= N, row i of the matrix was\n\ * interchanged with row IPIV(i).\n\ *\n\ * ANORM (input) DOUBLE PRECISION\n\ * If NORM = '1' or 'O', the 1-norm of the original matrix A.\n\ * If NORM = 'I', the infinity-norm of the original matrix A.\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(norm(A) * norm(inv(A))).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clauum0000644000175000017500000000413212502223525016475 0ustar uwabamiuwabami--- :name: clauum :md5sum: f581ea1c2a8bf3f26404843289f3189c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CLAUUM( UPLO, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAUUM computes the product U * U' or L' * L, where the triangular\n\ * factor U or L is stored in the upper or lower triangular part of\n\ * the array A.\n\ *\n\ * If UPLO = 'U' or 'u' then the upper triangle of the result is stored,\n\ * overwriting the factor U in A.\n\ * If UPLO = 'L' or 'l' then the lower triangle of the result is stored,\n\ * overwriting the factor L in A.\n\ *\n\ * This is the blocked form of the algorithm, calling Level 3 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the triangular factor stored in the array A\n\ * is upper or lower triangular:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the triangular factor U or L. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the triangular factor U or L.\n\ * On exit, if UPLO = 'U', the upper triangle of A is\n\ * overwritten with the upper triangle of the product U * U';\n\ * if UPLO = 'L', the lower triangle of A is overwritten with\n\ * the lower triangle of the product L' * L.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctrttf0000644000175000017500000001466412502223525016530 0ustar uwabamiuwabami--- :name: ctrttf :md5sum: 6a5c6f7d589892c220e1674bad5372e3 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - arf: :type: doublecomplex :intent: output :dims: - ( n*(n+1)/2 ) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CTRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTRTTF copies a triangular matrix A from standard full format (TR)\n\ * to rectangular full packed format (TF) .\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': ARF in Normal mode is wanted;\n\ * = 'C': ARF in Conjugate Transpose mode is wanted;\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension ( LDA, N ) \n\ * On entry, the triangular matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of the array A contains\n\ * the upper triangular matrix, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of the array A contains\n\ * the lower triangular matrix, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the matrix A. LDA >= max(1,N).\n\ *\n\ * ARF (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n\ * On exit, the upper or lower triangular matrix A stored in\n\ * RFP format. For a further discussion see Notes below.\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\ * We first consider Standard Packed Format when N is even.\n\ * We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = `N'. RFP holds AP as follows:\n\ * For UPLO = `U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * conjugate-transpose of the first three columns of AP upper.\n\ * For UPLO = `L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * conjugate-transpose of the last three columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N even and TRANSR = `N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- --\n\ * 03 04 05 33 43 53\n\ * -- --\n\ * 13 14 15 00 44 54\n\ * --\n\ * 23 24 25 10 11 55\n\ *\n\ * 33 34 35 20 21 22\n\ * --\n\ * 00 44 45 30 31 32\n\ * -- --\n\ * 01 11 55 40 41 42\n\ * -- -- --\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = `C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We next consider Standard Packed Format when N is odd.\n\ * We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = `N'. RFP holds AP as follows:\n\ * For UPLO = `U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * conjugate-transpose of the first two columns of AP upper.\n\ * For UPLO = `L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * conjugate-transpose of the last two columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N odd and TRANSR = `N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- --\n\ * 02 03 04 00 33 43\n\ * --\n\ * 12 13 14 10 11 44\n\ *\n\ * 22 23 24 20 21 22\n\ * --\n\ * 00 33 34 30 31 32\n\ * -- --\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = `C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- --\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlacrm0000644000175000017500000000423412502223526016503 0ustar uwabamiuwabami--- :name: zlacrm :md5sum: 9ae33084c6b14c9ddd1a66b99572017a :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: doublecomplex :intent: output :dims: - ldc - n - ldc: :type: integer :intent: input - rwork: :type: doublereal :intent: workspace :dims: - 2*m*n :substitutions: ldc: MAX(1,n) :fortran_help: " SUBROUTINE ZLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLACRM performs a very simple matrix-matrix multiplication:\n\ * C := A * B,\n\ * where A is M by N and complex; B is N by N and real;\n\ * C is M by N and complex.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A and of the matrix C.\n\ * M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns and rows of the matrix B and\n\ * the number of columns of the matrix C.\n\ * N >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA, N)\n\ * A contains 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\ * B (input) DOUBLE PRECISION array, dimension (LDB, N)\n\ * B contains the N by N matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >=max(1,N).\n\ *\n\ * C (input) COMPLEX*16 array, dimension (LDC, N)\n\ * C contains the M by N matrix C.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >=max(1,N).\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (2*M*N)\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgbcon0000644000175000017500000000643712502223525016454 0ustar uwabamiuwabami--- :name: cgbcon :md5sum: 8e6b7e041c6298e0552aa8c039013d30 :category: :subroutine :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGBCON estimates the reciprocal of the condition number of a complex\n\ * general band matrix A, in either the 1-norm or the infinity-norm,\n\ * using the LU factorization computed by CGBTRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as\n\ * RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies whether the 1-norm condition number or the\n\ * infinity-norm condition number is required:\n\ * = '1' or 'O': 1-norm;\n\ * = 'I': Infinity-norm.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * AB (input) COMPLEX array, dimension (LDAB,N)\n\ * Details of the LU factorization of the band matrix A, as\n\ * computed by CGBTRF. U is stored as an upper triangular band\n\ * matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n\ * the multipliers used during the factorization are stored in\n\ * rows KL+KU+2 to 2*KL+KU+1.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices; for 1 <= i <= N, row i of the matrix was\n\ * interchanged with row IPIV(i).\n\ *\n\ * ANORM (input) REAL\n\ * If NORM = '1' or 'O', the 1-norm of the original matrix A.\n\ * If NORM = 'I', the infinity-norm of the original matrix A.\n\ *\n\ * RCOND (output) REAL\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(norm(A) * norm(inv(A))).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zpbtf20000644000175000017500000000714012502223526016421 0ustar uwabamiuwabami--- :name: zpbtf2 :md5sum: bf0e4da7634cbb13842e62dcb88bc4af :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPBTF2( UPLO, N, KD, AB, LDAB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPBTF2 computes the Cholesky factorization of a complex Hermitian\n\ * positive definite band matrix A.\n\ *\n\ * The factorization has the form\n\ * A = U' * U , if UPLO = 'U', or\n\ * A = L * L', if UPLO = 'L',\n\ * where U is an upper triangular matrix, U' is the conjugate transpose\n\ * of U, and L is lower triangular.\n\ *\n\ * This is the unblocked version of the algorithm, calling Level 2 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * Hermitian matrix A is stored:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of super-diagonals of the matrix A if UPLO = 'U',\n\ * or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * On exit, if INFO = 0, the triangular factor U or L from the\n\ * Cholesky factorization A = U'*U or A = L*L' of the band\n\ * matrix A, in the same storage format as A.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ * > 0: if INFO = k, the leading minor of order k is not\n\ * positive definite, and the factorization could not be\n\ * completed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * N = 6, KD = 2, and UPLO = 'U':\n\ *\n\ * On entry: On exit:\n\ *\n\ * * * a13 a24 a35 a46 * * u13 u24 u35 u46\n\ * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n\ * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n\ *\n\ * Similarly, if UPLO = 'L' the format of A is as follows:\n\ *\n\ * On entry: On exit:\n\ *\n\ * a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n\ * a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n\ * a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n\ *\n\ * Array elements marked * are not used by the routine.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlaqr30000644000175000017500000002033012502223526016374 0ustar uwabamiuwabami--- :name: dlaqr3 :md5sum: 6e3a9343765ecb5f586856edd3fb6ba7 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ktop: :type: integer :intent: input - kbot: :type: integer :intent: input - nw: :type: integer :intent: input - h: :type: doublereal :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: doublereal :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - ns: :type: integer :intent: output - nd: :type: integer :intent: output - sr: :type: doublereal :intent: output :dims: - MAX(1,kbot) - si: :type: doublereal :intent: output :dims: - MAX(1,kbot) - v: :type: doublereal :intent: workspace :dims: - ldv - MAX(1,nw) - ldv: :type: integer :intent: input - nh: :type: integer :intent: input - t: :type: doublereal :intent: workspace :dims: - ldt - MAX(1,nw) - ldt: :type: integer :intent: input - nv: :type: integer :intent: input - wv: :type: doublereal :intent: workspace :dims: - ldwv - MAX(1,nw) - ldwv: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*nw :substitutions: ldwv: nw ldt: nw ldv: nw :fortran_help: " SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n\ * Aggressive early deflation:\n\ *\n\ * This subroutine accepts as input an upper Hessenberg matrix\n\ * H and performs an orthogonal similarity transformation\n\ * designed to detect and deflate fully converged eigenvalues from\n\ * a trailing principal submatrix. On output H has been over-\n\ * written by a new Hessenberg matrix that is a perturbation of\n\ * an orthogonal similarity transformation of H. It is to be\n\ * hoped that the final version of H has many zero subdiagonal\n\ * entries.\n\ *\n\ * ******************************************************************\n\n\ * WANTT (input) LOGICAL\n\ * If .TRUE., then the Hessenberg matrix H is fully updated\n\ * so that the quasi-triangular Schur factor may be\n\ * computed (in cooperation with the calling subroutine).\n\ * If .FALSE., then only enough of H is updated to preserve\n\ * the eigenvalues.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * If .TRUE., then the orthogonal matrix Z is updated so\n\ * so that the orthogonal Schur factor may be computed\n\ * (in cooperation with the calling subroutine).\n\ * If .FALSE., then Z is not referenced.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H and (if WANTZ is .TRUE.) the\n\ * order of the orthogonal matrix Z.\n\ *\n\ * KTOP (input) INTEGER\n\ * It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n\ * KBOT and KTOP together determine an isolated block\n\ * along the diagonal of the Hessenberg matrix.\n\ *\n\ * KBOT (input) INTEGER\n\ * It is assumed without a check that either\n\ * KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together\n\ * determine an isolated block along the diagonal of the\n\ * Hessenberg matrix.\n\ *\n\ * NW (input) INTEGER\n\ * Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).\n\ *\n\ * H (input/output) DOUBLE PRECISION array, dimension (LDH,N)\n\ * On input the initial N-by-N section of H stores the\n\ * Hessenberg matrix undergoing aggressive early deflation.\n\ * On output H has been transformed by an orthogonal\n\ * similarity transformation, perturbed, and the returned\n\ * to Hessenberg form that (it is to be hoped) has some\n\ * zero subdiagonal entries.\n\ *\n\ * LDH (input) integer\n\ * Leading dimension of H just as declared in the calling\n\ * subroutine. N .LE. LDH\n\ *\n\ * ILOZ (input) INTEGER\n\ * IHIZ (input) INTEGER\n\ * Specify the rows of Z to which transformations must be\n\ * applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n\ *\n\ * Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n\ * IF WANTZ is .TRUE., then on output, the orthogonal\n\ * similarity transformation mentioned above has been\n\ * accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n\ * If WANTZ is .FALSE., then Z is unreferenced.\n\ *\n\ * LDZ (input) integer\n\ * The leading dimension of Z just as declared in the\n\ * calling subroutine. 1 .LE. LDZ.\n\ *\n\ * NS (output) integer\n\ * The number of unconverged (ie approximate) eigenvalues\n\ * returned in SR and SI that may be used as shifts by the\n\ * calling subroutine.\n\ *\n\ * ND (output) integer\n\ * The number of converged eigenvalues uncovered by this\n\ * subroutine.\n\ *\n\ * SR (output) DOUBLE PRECISION array, dimension (KBOT)\n\ * SI (output) DOUBLE PRECISION array, dimension (KBOT)\n\ * On output, the real and imaginary parts of approximate\n\ * eigenvalues that may be used for shifts are stored in\n\ * SR(KBOT-ND-NS+1) through SR(KBOT-ND) and\n\ * SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.\n\ * The real and imaginary parts of converged eigenvalues\n\ * are stored in SR(KBOT-ND+1) through SR(KBOT) and\n\ * SI(KBOT-ND+1) through SI(KBOT), respectively.\n\ *\n\ * V (workspace) DOUBLE PRECISION array, dimension (LDV,NW)\n\ * An NW-by-NW work array.\n\ *\n\ * LDV (input) integer scalar\n\ * The leading dimension of V just as declared in the\n\ * calling subroutine. NW .LE. LDV\n\ *\n\ * NH (input) integer scalar\n\ * The number of columns of T. NH.GE.NW.\n\ *\n\ * T (workspace) DOUBLE PRECISION array, dimension (LDT,NW)\n\ *\n\ * LDT (input) integer\n\ * The leading dimension of T just as declared in the\n\ * calling subroutine. NW .LE. LDT\n\ *\n\ * NV (input) integer\n\ * The number of rows of work array WV available for\n\ * workspace. NV.GE.NW.\n\ *\n\ * WV (workspace) DOUBLE PRECISION array, dimension (LDWV,NW)\n\ *\n\ * LDWV (input) integer\n\ * The leading dimension of W just as declared in the\n\ * calling subroutine. NW .LE. LDV\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)\n\ * On exit, WORK(1) is set to an estimate of the optimal value\n\ * of LWORK for the given values of N, NW, KTOP and KBOT.\n\ *\n\ * LWORK (input) integer\n\ * The dimension of the work array WORK. LWORK = 2*NW\n\ * suffices, but greater efficiency may result from larger\n\ * values of LWORK.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; DLAQR3\n\ * only estimates the optimal workspace size for the given\n\ * values of N, NW, KTOP and KBOT. The estimate is returned\n\ * in WORK(1). No error message related to LWORK is issued\n\ * by XERBLA. Neither H nor Z are accessed.\n\ *\n\n\ * ================================================================\n\ * Based on contributions by\n\ * Karen Braman and Ralph Byers, Department of Mathematics,\n\ * University of Kansas, USA\n\ *\n\ * ================================================================\n" ruby-lapack-1.7.2/dev/defs/claqp20000644000175000017500000000665012502223525016400 0ustar uwabamiuwabami--- :name: claqp2 :md5sum: 44ab7cf5adb154df3f069f835f338c36 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - offset: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: complex :intent: output :dims: - MIN(m,n) - vn1: :type: real :intent: input/output :dims: - n - vn2: :type: real :intent: input/output :dims: - n - work: :type: complex :intent: workspace :dims: - n :substitutions: {} :fortran_help: " SUBROUTINE CLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAQP2 computes a QR factorization with column pivoting of\n\ * the block A(OFFSET+1:M,1:N).\n\ * The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\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\ * OFFSET (input) INTEGER\n\ * The number of rows of the matrix A that must be pivoted\n\ * but no factorized. OFFSET >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, the upper triangle of block A(OFFSET+1:M,1:N) is \n\ * the triangular factor obtained; the elements in block\n\ * A(OFFSET+1:M,1:N) below the diagonal, together with the\n\ * array TAU, represent the orthogonal matrix Q as a product of\n\ * elementary reflectors. Block A(1:OFFSET,1:N) has been\n\ * accordingly pivoted, but no factorized.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * JPVT (input/output) INTEGER array, dimension (N)\n\ * On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n\ * to the front of A*P (a leading column); if JPVT(i) = 0,\n\ * the i-th column of A is a free column.\n\ * On exit, if JPVT(i) = k, then the i-th column of A*P\n\ * was the k-th column of A.\n\ *\n\ * TAU (output) COMPLEX array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors.\n\ *\n\ * VN1 (input/output) REAL array, dimension (N)\n\ * The vector with the partial column norms.\n\ *\n\ * VN2 (input/output) REAL array, dimension (N)\n\ * The vector with the exact column norms.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (N)\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n\ * X. Sun, Computer Science Dept., Duke University, USA\n\ *\n\ * Partial column norm updating strategy modified by\n\ * Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n\ * University of Zagreb, Croatia.\n\ * June 2010\n\ * For more details see LAPACK Working Note 176.\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgtsvx0000644000175000017500000002356112502223526016536 0ustar uwabamiuwabami--- :name: dgtsvx :md5sum: 65257f06318d08af23974f8758a267a7 :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: doublereal :intent: input :dims: - n-1 - d: :type: doublereal :intent: input :dims: - n - du: :type: doublereal :intent: input :dims: - n-1 - dlf: :type: doublereal :intent: input/output :dims: - n-1 - df: :type: doublereal :intent: input/output :dims: - n - duf: :type: doublereal :intent: input/output :dims: - n-1 - du2: :type: doublereal :intent: input/output :dims: - n-2 - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE DGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGTSVX uses the LU factorization to compute the solution to a real\n\ * system of linear equations A * X = B or A**T * X = B,\n\ * where A is a tridiagonal matrix of order N and X and B are N-by-NRHS\n\ * matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'N', the LU decomposition is used to factor the matrix A\n\ * as A = L * U, where L is a product of permutation and unit lower\n\ * bidiagonal matrices and U is upper triangular with nonzeros in\n\ * only the main diagonal and first two superdiagonals.\n\ *\n\ * 2. If some U(i,i)=0, so that U is exactly singular, then the routine\n\ * returns with INFO = i. Otherwise, the factored form of A is used\n\ * to estimate the condition number of the matrix A. If the\n\ * reciprocal of the condition number is less than machine precision,\n\ * INFO = N+1 is returned as a warning, but the routine still goes on\n\ * to solve for X and compute error bounds as described below.\n\ *\n\ * 3. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 4. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of A has been\n\ * supplied on entry.\n\ * = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored\n\ * form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV\n\ * will not be modified.\n\ * = 'N': The matrix will be copied to DLF, DF, and DUF\n\ * and factored.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * DL (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) subdiagonal elements of A.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The n diagonal elements of A.\n\ *\n\ * DU (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) superdiagonal elements of A.\n\ *\n\ * DLF (input or output) DOUBLE PRECISION array, dimension (N-1)\n\ * If FACT = 'F', then DLF is an input argument and on entry\n\ * contains the (n-1) multipliers that define the matrix L from\n\ * the LU factorization of A as computed by DGTTRF.\n\ *\n\ * If FACT = 'N', then DLF is an output argument and on exit\n\ * contains the (n-1) multipliers that define the matrix L from\n\ * the LU factorization of A.\n\ *\n\ * DF (input or output) DOUBLE PRECISION array, dimension (N)\n\ * If FACT = 'F', then DF is an input argument and on entry\n\ * contains the n diagonal elements of the upper triangular\n\ * matrix U from the LU factorization of A.\n\ *\n\ * If FACT = 'N', then DF is an output argument and on exit\n\ * contains the n diagonal elements of the upper triangular\n\ * matrix U from the LU factorization of A.\n\ *\n\ * DUF (input or output) DOUBLE PRECISION array, dimension (N-1)\n\ * If FACT = 'F', then DUF is an input argument and on entry\n\ * contains the (n-1) elements of the first superdiagonal of U.\n\ *\n\ * If FACT = 'N', then DUF is an output argument and on exit\n\ * contains the (n-1) elements of the first superdiagonal of U.\n\ *\n\ * DU2 (input or output) DOUBLE PRECISION array, dimension (N-2)\n\ * If FACT = 'F', then DU2 is an input argument and on entry\n\ * contains the (n-2) elements of the second superdiagonal of\n\ * U.\n\ *\n\ * If FACT = 'N', then DU2 is an output argument and on exit\n\ * contains the (n-2) elements of the second superdiagonal of\n\ * U.\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains the pivot indices from the LU factorization of A as\n\ * computed by DGTTRF.\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the LU factorization of A;\n\ * row i of the matrix was interchanged with row IPIV(i).\n\ * IPIV(i) will always be either i or i+1; IPIV(i) = i indicates\n\ * a row interchange was not required.\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * The N-by-NRHS right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A. If RCOND is less than the machine precision (in\n\ * particular, if RCOND = 0), the matrix is singular to working\n\ * precision. This condition is indicated by a return code of\n\ * INFO > 0.\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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, and i is\n\ * <= N: U(i,i) is exactly zero. The factorization\n\ * has not been completed unless i = N, but the\n\ * factor U is exactly singular, so the solution\n\ * and error bounds could not be computed.\n\ * RCOND = 0 is returned.\n\ * = N+1: U is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slasd50000644000175000017500000000446412502223526016413 0ustar uwabamiuwabami--- :name: slasd5 :md5sum: a7b9ae7360e5f962ed9cb997a7a2fa1d :category: :subroutine :arguments: - i: :type: integer :intent: input - d: :type: real :intent: input :dims: - "2" - z: :type: real :intent: input :dims: - "2" - delta: :type: real :intent: output :dims: - "2" - rho: :type: real :intent: input - dsigma: :type: real :intent: output - work: :type: real :intent: workspace :dims: - "2" :substitutions: {} :fortran_help: " SUBROUTINE SLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This subroutine computes the square root of the I-th eigenvalue\n\ * of a positive symmetric rank-one modification of a 2-by-2 diagonal\n\ * matrix\n\ *\n\ * diag( D ) * diag( D ) + RHO * Z * transpose(Z) .\n\ *\n\ * The diagonal entries in the array D are assumed to satisfy\n\ *\n\ * 0 <= D(i) < D(j) for i < j .\n\ *\n\ * We also assume RHO > 0 and that the Euclidean norm of the vector\n\ * Z is one.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * I (input) INTEGER\n\ * The index of the eigenvalue to be computed. I = 1 or I = 2.\n\ *\n\ * D (input) REAL array, dimension (2)\n\ * The original eigenvalues. We assume 0 <= D(1) < D(2).\n\ *\n\ * Z (input) REAL array, dimension (2)\n\ * The components of the updating vector.\n\ *\n\ * DELTA (output) REAL array, dimension (2)\n\ * Contains (D(j) - sigma_I) in its j-th component.\n\ * The vector DELTA contains the information necessary\n\ * to construct the eigenvectors.\n\ *\n\ * RHO (input) REAL\n\ * The scalar in the symmetric updating formula.\n\ *\n\ * DSIGMA (output) REAL\n\ * The computed sigma_I, the I-th updated eigenvalue.\n\ *\n\ * WORK (workspace) REAL array, dimension (2)\n\ * WORK contains (D(j) + sigma_I) in its j-th component.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ren-Cang Li, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgttrf0000644000175000017500000000615012502223526016504 0ustar uwabamiuwabami--- :name: dgttrf :md5sum: 306eba329147375407f9d5681c1499cc :category: :subroutine :arguments: - n: :type: integer :intent: input - dl: :type: doublereal :intent: input/output :dims: - n-1 - d: :type: doublereal :intent: input/output :dims: - n - du: :type: doublereal :intent: input/output :dims: - n-1 - du2: :type: doublereal :intent: output :dims: - n-2 - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGTTRF( N, DL, D, DU, DU2, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGTTRF computes an LU factorization of a real tridiagonal matrix A\n\ * using elimination with partial pivoting and row interchanges.\n\ *\n\ * The factorization has the form\n\ * A = L * U\n\ * where L is a product of permutation and unit lower bidiagonal\n\ * matrices and U is upper triangular with nonzeros in only the main\n\ * diagonal and first two superdiagonals.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A.\n\ *\n\ * DL (input/output) DOUBLE PRECISION array, dimension (N-1)\n\ * On entry, DL must contain the (n-1) sub-diagonal elements of\n\ * A.\n\ *\n\ * On exit, DL is overwritten by the (n-1) multipliers that\n\ * define the matrix L from the LU factorization of A.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, D must contain the diagonal elements of A.\n\ *\n\ * On exit, D is overwritten by the n diagonal elements of the\n\ * upper triangular matrix U from the LU factorization of A.\n\ *\n\ * DU (input/output) DOUBLE PRECISION array, dimension (N-1)\n\ * On entry, DU must contain the (n-1) super-diagonal elements\n\ * of A.\n\ *\n\ * On exit, DU is overwritten by the (n-1) elements of the first\n\ * super-diagonal of U.\n\ *\n\ * DU2 (output) DOUBLE PRECISION array, dimension (N-2)\n\ * On exit, DU2 is overwritten by the (n-2) elements of the\n\ * second super-diagonal of U.\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * The pivot indices; for 1 <= i <= n, row i of the matrix was\n\ * interchanged with row IPIV(i). IPIV(i) will always be either\n\ * i or i+1; IPIV(i) = i indicates a row interchange was not\n\ * required.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ * > 0: if INFO = k, U(k,k) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, and division by zero will occur if it is used\n\ * to solve a system of equations.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clantb0000644000175000017500000000704612502223525016461 0ustar uwabamiuwabami--- :name: clantb :md5sum: b67405c765473479f482587ff2fd0f79 :category: :function :type: real :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "MAX(1,lsame_(&norm,\"I\") ? n : 0)" :substitutions: {} :fortran_help: " REAL FUNCTION CLANTB( NORM, UPLO, DIAG, N, K, AB, LDAB, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLANTB returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of an\n\ * n by n triangular band matrix A, with ( k + 1 ) diagonals.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * CLANTB returns the value\n\ *\n\ * CLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in CLANTB as described\n\ * above.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the matrix A is upper or lower triangular.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * Specifies whether or not the matrix A is unit triangular.\n\ * = 'N': Non-unit triangular\n\ * = 'U': Unit triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, CLANTB is\n\ * set to zero.\n\ *\n\ * K (input) INTEGER\n\ * The number of super-diagonals of the matrix A if UPLO = 'U',\n\ * or the number of sub-diagonals of the matrix A if UPLO = 'L'.\n\ * K >= 0.\n\ *\n\ * AB (input) COMPLEX array, dimension (LDAB,N)\n\ * The upper or lower triangular band matrix A, stored in the\n\ * first k+1 rows of AB. The j-th column of A is stored\n\ * in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).\n\ * Note that when DIAG = 'U', the elements of the array AB\n\ * corresponding to the diagonal elements of the matrix A are\n\ * not referenced, but are assumed to be one.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= K+1.\n\ *\n\ * WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n\ * referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cla_lin_berr0000644000175000017500000000523312502223525017625 0ustar uwabamiuwabami--- :name: cla_lin_berr :md5sum: 6b8eeecaaa46d0e73b99de53d6d4b511 :category: :subroutine :arguments: - n: :type: integer :intent: input - nz: :type: integer :intent: input - nrhs: :type: integer :intent: input - res: :type: doublereal :intent: input :dims: - n - nrhs - ayb: :type: doublereal :intent: input :dims: - n - nrhs - berr: :type: complex :intent: output :dims: - nrhs :substitutions: {} :fortran_help: " SUBROUTINE CLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLA_LIN_BERR computes componentwise relative backward error from\n\ * the formula\n\ * max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n\ * where abs(Z) is the componentwise absolute value of the matrix\n\ * or vector Z.\n\ *\n\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NZ (input) INTEGER\n\ * We add (NZ+1)*SLAMCH( 'Safe minimum' ) to R(i) in the numerator to\n\ * guard against spuriously zero residuals. Default value is N.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices AYB, RES, and BERR. NRHS >= 0.\n\ *\n\ * RES (input) DOUBLE PRECISION array, dimension (N,NRHS)\n\ * The residual matrix, i.e., the matrix R in the relative backward\n\ * error formula above.\n\ *\n\ * AYB (input) DOUBLE PRECISION array, dimension (N, NRHS)\n\ * The denominator in the relative backward error formula above, i.e.,\n\ * the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B\n\ * are from iterative refinement (see cla_gerfsx_extended.f).\n\ * \n\ * BERR (output) COMPLEX array, dimension (NRHS)\n\ * The componentwise relative backward error from the formula above.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n REAL TMP\n INTEGER I, J\n COMPLEX CDUM\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, REAL, AIMAG, MAX\n\ * ..\n\ * .. External Functions ..\n EXTERNAL SLAMCH\n REAL SLAMCH\n REAL SAFE1\n\ * ..\n\ * .. Statement Functions ..\n COMPLEX CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zgeqlf0000644000175000017500000000750112502223526016503 0ustar uwabamiuwabami--- :name: zgeqlf :md5sum: e875061982fc1c96c8778a2ffdf12cc1 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - MIN(m,n) - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGEQLF computes a QL factorization of a complex M-by-N matrix A:\n\ * A = Q * L.\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) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit,\n\ * if m >= n, the lower triangle of the subarray\n\ * A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L;\n\ * if m <= n, the elements on and below the (n-m)-th\n\ * superdiagonal contain the M-by-N lower trapezoidal matrix L;\n\ * the remaining elements, with the array TAU, represent the\n\ * unitary matrix Q as a product of elementary reflectors\n\ * (see Further Details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (output) COMPLEX*16 array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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,N).\n\ * For optimum performance LWORK >= N*NB, where NB is\n\ * the 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 complex scalar, and v is a complex vector with\n\ * v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n\ * A(1:m-k+i-1,n-k+i), and tau in TAU(i).\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n $ MU, NB, NBMIN, NU, NX\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZGEQL2, ZLARFB, ZLARFT\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zlantb0000644000175000017500000000712312502223526016505 0ustar uwabamiuwabami--- :name: zlantb :md5sum: b83aebd51718807ea87f8fe975fb3cb7 :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? n : 0" :fortran_help: " DOUBLE PRECISION FUNCTION ZLANTB( NORM, UPLO, DIAG, N, K, AB, LDAB, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLANTB returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of an\n\ * n by n triangular band matrix A, with ( k + 1 ) diagonals.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * ZLANTB returns the value\n\ *\n\ * ZLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in ZLANTB as described\n\ * above.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the matrix A is upper or lower triangular.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * Specifies whether or not the matrix A is unit triangular.\n\ * = 'N': Non-unit triangular\n\ * = 'U': Unit triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, ZLANTB is\n\ * set to zero.\n\ *\n\ * K (input) INTEGER\n\ * The number of super-diagonals of the matrix A if UPLO = 'U',\n\ * or the number of sub-diagonals of the matrix A if UPLO = 'L'.\n\ * K >= 0.\n\ *\n\ * AB (input) COMPLEX*16 array, dimension (LDAB,N)\n\ * The upper or lower triangular band matrix A, stored in the\n\ * first k+1 rows of AB. The j-th column of A is stored\n\ * in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).\n\ * Note that when DIAG = 'U', the elements of the array AB\n\ * corresponding to the diagonal elements of the matrix A are\n\ * not referenced, but are assumed to be one.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= K+1.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n\ * referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgerq20000644000175000017500000000510512502223526016414 0ustar uwabamiuwabami--- :name: sgerq2 :md5sum: 8307cc39ced248fef7772c32448921a0 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - MIN(m,n) - work: :type: real :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE SGERQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGERQ2 computes an RQ factorization of a real m by n matrix A:\n\ * A = R * 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) REAL array, dimension (LDA,N)\n\ * On entry, the m by n matrix A.\n\ * On exit, if m <= n, the upper triangle of the subarray\n\ * A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;\n\ * if m >= n, the elements on and above the (m-n)-th subdiagonal\n\ * contain the m by n upper trapezoidal matrix R; the remaining\n\ * elements, with the array TAU, represent the orthogonal matrix\n\ * Q as a product of elementary reflectors (see Further\n\ * Details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (output) REAL array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace) REAL 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(1) H(2) . . . H(k), 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(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n\ * A(m-k+i,1:n-k+i-1), and tau in TAU(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctrsna0000644000175000017500000001664112502223525016511 0ustar uwabamiuwabami--- :name: ctrsna :md5sum: e91cc890d0ea7dbba10a9adc422212aa :category: :subroutine :arguments: - job: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - t: :type: complex :intent: input :dims: - ldt - n - ldt: :type: integer :intent: input - vl: :type: complex :intent: input :dims: - ldvl - m - ldvl: :type: integer :intent: input - vr: :type: complex :intent: input :dims: - ldvr - m - ldvr: :type: integer :intent: input - s: :type: real :intent: output :dims: - mm - sep: :type: real :intent: output :dims: - mm - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: complex :intent: workspace :dims: - "lsame_(&job,\"E\") ? 0 : ldwork" - "lsame_(&job,\"E\") ? 0 : n+6" - ldwork: :type: integer :intent: input - rwork: :type: real :intent: workspace :dims: - "lsame_(&job,\"E\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldwork: "((lsame_(&job,\"V\")) || (lsame_(&job,\"B\"))) ? n : 1" mm: m :fortran_help: " SUBROUTINE CTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTRSNA estimates reciprocal condition numbers for specified\n\ * eigenvalues and/or right eigenvectors of a complex upper triangular\n\ * matrix T (or of any matrix Q*T*Q**H with Q unitary).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * Specifies whether condition numbers are required for\n\ * eigenvalues (S) or eigenvectors (SEP):\n\ * = 'E': for eigenvalues only (S);\n\ * = 'V': for eigenvectors only (SEP);\n\ * = 'B': for both eigenvalues and eigenvectors (S and SEP).\n\ *\n\ * HOWMNY (input) CHARACTER*1\n\ * = 'A': compute condition numbers for all eigenpairs;\n\ * = 'S': compute condition numbers for selected eigenpairs\n\ * specified by the array SELECT.\n\ *\n\ * SELECT (input) LOGICAL array, dimension (N)\n\ * If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n\ * condition numbers are required. To select condition numbers\n\ * for the j-th eigenpair, SELECT(j) must be set to .TRUE..\n\ * If HOWMNY = 'A', SELECT is not referenced.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix T. N >= 0.\n\ *\n\ * T (input) COMPLEX array, dimension (LDT,N)\n\ * The upper triangular matrix T.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= max(1,N).\n\ *\n\ * VL (input) COMPLEX array, dimension (LDVL,M)\n\ * If JOB = 'E' or 'B', VL must contain left eigenvectors of T\n\ * (or of any Q*T*Q**H with Q unitary), corresponding to the\n\ * eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n\ * must be stored in consecutive columns of VL, as returned by\n\ * CHSEIN or CTREVC.\n\ * If JOB = 'V', VL is not referenced.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the array VL.\n\ * LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.\n\ *\n\ * VR (input) COMPLEX array, dimension (LDVR,M)\n\ * If JOB = 'E' or 'B', VR must contain right eigenvectors of T\n\ * (or of any Q*T*Q**H with Q unitary), corresponding to the\n\ * eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n\ * must be stored in consecutive columns of VR, as returned by\n\ * CHSEIN or CTREVC.\n\ * If JOB = 'V', VR is not referenced.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the array VR.\n\ * LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.\n\ *\n\ * S (output) REAL array, dimension (MM)\n\ * If JOB = 'E' or 'B', the reciprocal condition numbers of the\n\ * selected eigenvalues, stored in consecutive elements of the\n\ * array. Thus S(j), SEP(j), and the j-th columns of VL and VR\n\ * all correspond to the same eigenpair (but not in general the\n\ * j-th eigenpair, unless all eigenpairs are selected).\n\ * If JOB = 'V', S is not referenced.\n\ *\n\ * SEP (output) REAL array, dimension (MM)\n\ * If JOB = 'V' or 'B', the estimated reciprocal condition\n\ * numbers of the selected eigenvectors, stored in consecutive\n\ * elements of the array.\n\ * If JOB = 'E', SEP is not referenced.\n\ *\n\ * MM (input) INTEGER\n\ * The number of elements in the arrays S (if JOB = 'E' or 'B')\n\ * and/or SEP (if JOB = 'V' or 'B'). MM >= M.\n\ *\n\ * M (output) INTEGER\n\ * The number of elements of the arrays S and/or SEP actually\n\ * used to store the estimated condition numbers.\n\ * If HOWMNY = 'A', M is set to N.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (LDWORK,N+6)\n\ * If JOB = 'E', WORK is not referenced.\n\ *\n\ * LDWORK (input) INTEGER\n\ * The leading dimension of the array WORK.\n\ * LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\n\ * If JOB = 'E', RWORK is not referenced.\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 reciprocal of the condition number of an eigenvalue lambda is\n\ * defined as\n\ *\n\ * S(lambda) = |v'*u| / (norm(u)*norm(v))\n\ *\n\ * where u and v are the right and left eigenvectors of T corresponding\n\ * to lambda; v' denotes the conjugate transpose of v, and norm(u)\n\ * denotes the Euclidean norm. These reciprocal condition numbers always\n\ * lie between zero (very badly conditioned) and one (very well\n\ * conditioned). If n = 1, S(lambda) is defined to be 1.\n\ *\n\ * An approximate error bound for a computed eigenvalue W(i) is given by\n\ *\n\ * EPS * norm(T) / S(i)\n\ *\n\ * where EPS is the machine precision.\n\ *\n\ * The reciprocal of the condition number of the right eigenvector u\n\ * corresponding to lambda is defined as follows. Suppose\n\ *\n\ * T = ( lambda c )\n\ * ( 0 T22 )\n\ *\n\ * Then the reciprocal condition number is\n\ *\n\ * SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )\n\ *\n\ * where sigma-min denotes the smallest singular value. We approximate\n\ * the smallest singular value by the reciprocal of an estimate of the\n\ * one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is\n\ * defined to be abs(T(1,1)).\n\ *\n\ * An approximate error bound for a computed right eigenvector VR(i)\n\ * is given by\n\ *\n\ * EPS * norm(T) / SEP(i)\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zla_syrcond_c0000644000175000017500000000710612502223526020045 0ustar uwabamiuwabami--- :name: zla_syrcond_c :md5sum: dc1bde7c84b5aa69b54885640a0c0150 :category: :function :type: doublereal :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - c: :type: doublereal :intent: input :dims: - n - capply: :type: logical :intent: input - info: :type: integer :intent: output - work: :type: doublecomplex :intent: input :dims: - 2*n - rwork: :type: doublereal :intent: input :dims: - n :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION ZLA_SYRCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLA_SYRCOND_C Computes the infinity norm condition number of\n\ * op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX*16 array, dimension (LDAF,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by ZSYTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by ZSYTRF.\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension (N)\n\ * The vector C in the formula op(A) * inv(diag(C)).\n\ *\n\ * CAPPLY (input) LOGICAL\n\ * If .TRUE. then access the vector C in the formula above.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * i > 0: The ith argument is invalid.\n\ *\n\ * WORK (input) COMPLEX*16 array, dimension (2*N).\n\ * Workspace.\n\ *\n\ * RWORK (input) DOUBLE PRECISION array, dimension (N).\n\ * Workspace.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER KASE\n DOUBLE PRECISION AINVNM, ANORM, TMP\n INTEGER I, J\n LOGICAL UP\n COMPLEX*16 ZDUM\n\ * ..\n\ * .. Local Arrays ..\n INTEGER ISAVE( 3 )\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL ZLACN2, ZSYTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n\ * ..\n\ * .. Statement Functions ..\n DOUBLE PRECISION CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dgeql20000644000175000017500000000516612502223526016376 0ustar uwabamiuwabami--- :name: dgeql2 :md5sum: a28ed88137c6b697773895e45d0d13a1 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - MIN(m,n) - work: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGEQL2( M, N, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGEQL2 computes a QL factorization of a real m by n matrix A:\n\ * A = Q * L.\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, if m >= n, the lower triangle of the subarray\n\ * A(m-n+1:m,1:n) contains the n by n lower triangular matrix L;\n\ * if m <= n, the elements on and below the (n-m)-th\n\ * superdiagonal contain the m by n lower trapezoidal matrix L;\n\ * the remaining elements, with the array TAU, represent the\n\ * orthogonal matrix Q as a product of elementary reflectors\n\ * (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 (N)\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(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n\ * A(1:m-k+i-1,n-k+i), and tau in TAU(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctrsen0000644000175000017500000002074712502223525016517 0ustar uwabamiuwabami--- :name: ctrsen :md5sum: d2b5291e456ad12fb0adea66a05d53de :category: :subroutine :arguments: - job: :type: char :intent: input - compq: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - t: :type: complex :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - q: :type: complex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - w: :type: complex :intent: output :dims: - n - m: :type: integer :intent: output - s: :type: real :intent: output - sep: :type: real :intent: output - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&job,\"N\") ? n : lsame_(&job,\"E\") ? m*(n-m) : (lsame_(&job,\"V\")||lsame_(&job,\"B\")) ? 2*m*(n-m) : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S, SEP, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTRSEN reorders the Schur factorization of a complex matrix\n\ * A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in\n\ * the leading positions on the diagonal of the upper triangular matrix\n\ * T, and the leading columns of Q form an orthonormal basis of the\n\ * corresponding right invariant subspace.\n\ *\n\ * Optionally the routine computes the reciprocal condition numbers of\n\ * the cluster of eigenvalues and/or the invariant subspace.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * Specifies whether condition numbers are required for the\n\ * cluster of eigenvalues (S) or the invariant subspace (SEP):\n\ * = 'N': none;\n\ * = 'E': for eigenvalues only (S);\n\ * = 'V': for invariant subspace only (SEP);\n\ * = 'B': for both eigenvalues and invariant subspace (S and\n\ * SEP).\n\ *\n\ * COMPQ (input) CHARACTER*1\n\ * = 'V': update the matrix Q of Schur vectors;\n\ * = 'N': do not update Q.\n\ *\n\ * SELECT (input) LOGICAL array, dimension (N)\n\ * SELECT specifies the eigenvalues in the selected cluster. To\n\ * select the j-th eigenvalue, SELECT(j) must be set to .TRUE..\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix T. N >= 0.\n\ *\n\ * T (input/output) COMPLEX array, dimension (LDT,N)\n\ * On entry, the upper triangular matrix T.\n\ * On exit, T is overwritten by the reordered matrix T, with the\n\ * selected eigenvalues as the leading diagonal elements.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= max(1,N).\n\ *\n\ * Q (input/output) COMPLEX array, dimension (LDQ,N)\n\ * On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n\ * On exit, if COMPQ = 'V', Q has been postmultiplied by the\n\ * unitary transformation matrix which reorders T; the leading M\n\ * columns of Q form an orthonormal basis for the specified\n\ * invariant subspace.\n\ * If COMPQ = 'N', Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q.\n\ * LDQ >= 1; and if COMPQ = 'V', LDQ >= N.\n\ *\n\ * W (output) COMPLEX array, dimension (N)\n\ * The reordered eigenvalues of T, in the same order as they\n\ * appear on the diagonal of T.\n\ *\n\ * M (output) INTEGER\n\ * The dimension of the specified invariant subspace.\n\ * 0 <= M <= N.\n\ *\n\ * S (output) REAL\n\ * If JOB = 'E' or 'B', S is a lower bound on the reciprocal\n\ * condition number for the selected cluster of eigenvalues.\n\ * S cannot underestimate the true reciprocal condition number\n\ * by more than a factor of sqrt(N). If M = 0 or N, S = 1.\n\ * If JOB = 'N' or 'V', S is not referenced.\n\ *\n\ * SEP (output) REAL\n\ * If JOB = 'V' or 'B', SEP is the estimated reciprocal\n\ * condition number of the specified invariant subspace. If\n\ * M = 0 or N, SEP = norm(T).\n\ * If JOB = 'N' or 'E', SEP is not referenced.\n\ *\n\ * WORK (workspace/output) COMPLEX 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\ * If JOB = 'N', LWORK >= 1;\n\ * if JOB = 'E', LWORK = max(1,M*(N-M));\n\ * if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).\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\ * CTRSEN first collects the selected eigenvalues by computing a unitary\n\ * transformation Z to move them to the top left corner of T. In other\n\ * words, the selected eigenvalues are the eigenvalues of T11 in:\n\ *\n\ * Z'*T*Z = ( T11 T12 ) n1\n\ * ( 0 T22 ) n2\n\ * n1 n2\n\ *\n\ * where N = n1+n2 and Z' means the conjugate transpose of Z. The first\n\ * n1 columns of Z span the specified invariant subspace of T.\n\ *\n\ * If T has been obtained from the Schur factorization of a matrix\n\ * A = Q*T*Q', then the reordered Schur factorization of A is given by\n\ * A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span the\n\ * corresponding invariant subspace of A.\n\ *\n\ * The reciprocal condition number of the average of the eigenvalues of\n\ * T11 may be returned in S. S lies between 0 (very badly conditioned)\n\ * and 1 (very well conditioned). It is computed as follows. First we\n\ * compute R so that\n\ *\n\ * P = ( I R ) n1\n\ * ( 0 0 ) n2\n\ * n1 n2\n\ *\n\ * is the projector on the invariant subspace associated with T11.\n\ * R is the solution of the Sylvester equation:\n\ *\n\ * T11*R - R*T22 = T12.\n\ *\n\ * Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote\n\ * the two-norm of M. Then S is computed as the lower bound\n\ *\n\ * (1 + F-norm(R)**2)**(-1/2)\n\ *\n\ * on the reciprocal of 2-norm(P), the true reciprocal condition number.\n\ * S cannot underestimate 1 / 2-norm(P) by more than a factor of\n\ * sqrt(N).\n\ *\n\ * An approximate error bound for the computed average of the\n\ * eigenvalues of T11 is\n\ *\n\ * EPS * norm(T) / S\n\ *\n\ * where EPS is the machine precision.\n\ *\n\ * The reciprocal condition number of the right invariant subspace\n\ * spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.\n\ * SEP is defined as the separation of T11 and T22:\n\ *\n\ * sep( T11, T22 ) = sigma-min( C )\n\ *\n\ * where sigma-min(C) is the smallest singular value of the\n\ * n1*n2-by-n1*n2 matrix\n\ *\n\ * C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )\n\ *\n\ * I(m) is an m by m identity matrix, and kprod denotes the Kronecker\n\ * product. We estimate sigma-min(C) by the reciprocal of an estimate of\n\ * the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)\n\ * cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).\n\ *\n\ * When SEP is small, small changes in T can cause large changes in\n\ * the invariant subspace. An approximate bound on the maximum angular\n\ * error in the computed right invariant subspace is\n\ *\n\ * EPS * norm(T) / SEP\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dormr20000644000175000017500000000735312502223526016425 0ustar uwabamiuwabami--- :name: dormr2 :md5sum: 08b4812e38d10b5056d4fbd87207a314 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DORMR2 overwrites the general real m by n matrix C with\n\ *\n\ * Q * C if SIDE = 'L' and TRANS = 'N', or\n\ *\n\ * Q'* C if SIDE = 'L' and TRANS = 'T', or\n\ *\n\ * C * Q if SIDE = 'R' and TRANS = 'N', or\n\ *\n\ * C * Q' if SIDE = 'R' and TRANS = 'T',\n\ *\n\ * where Q is a real orthogonal matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by DGERQF. Q is of order m if SIDE = 'L' and of order n\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q' from the Left\n\ * = 'R': apply Q or Q' from the Right\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': apply Q (No transpose)\n\ * = 'T': apply Q' (Transpose)\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension\n\ * (LDA,M) if SIDE = 'L',\n\ * (LDA,N) if SIDE = 'R'\n\ * The i-th row must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * DGERQF in the last k rows of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,K).\n\ *\n\ * TAU (input) DOUBLE PRECISION array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by DGERQF.\n\ *\n\ * C (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n\ * On entry, the m by n matrix C.\n\ * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension\n\ * (N) if SIDE = 'L',\n\ * (M) if SIDE = 'R'\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dpbrfs0000644000175000017500000001211512502223526016470 0ustar uwabamiuwabami--- :name: dpbrfs :md5sum: 8b7dd205a80433495815f47866c016f7 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublereal :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPBRFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is symmetric positive definite\n\ * and banded, and provides error bounds and backward error estimates\n\ * for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * The upper or lower triangle of the symmetric band matrix A,\n\ * stored in the first KD+1 rows of the array. The j-th column\n\ * of A is stored in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T of the band matrix A as computed by\n\ * DPBTRF, in the same storage format as A (see AB).\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= KD+1.\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by DPBTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clarzt0000644000175000017500000001225412502223525016512 0ustar uwabamiuwabami--- :name: clarzt :md5sum: 99197ece47e417c570eb4b4a4b1a2418 :category: :subroutine :arguments: - direct: :type: char :intent: input - storev: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - v: :type: complex :intent: input/output :dims: - ldv - "lsame_(&storev,\"C\") ? k : lsame_(&storev,\"R\") ? n : 0" - ldv: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - t: :type: complex :intent: output :dims: - ldt - k - ldt: :type: integer :intent: input :substitutions: ldt: k :fortran_help: " SUBROUTINE CLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLARZT forms the triangular factor T of a complex block reflector\n\ * H of order > n, which is defined as a product of k elementary\n\ * reflectors.\n\ *\n\ * If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n\ *\n\ * If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n\ *\n\ * If STOREV = 'C', the vector which defines the elementary reflector\n\ * H(i) is stored in the i-th column of the array V, and\n\ *\n\ * H = I - V * T * V'\n\ *\n\ * If STOREV = 'R', the vector which defines the elementary reflector\n\ * H(i) is stored in the i-th row of the array V, and\n\ *\n\ * H = I - V' * T * V\n\ *\n\ * Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * DIRECT (input) CHARACTER*1\n\ * Specifies the order in which the elementary reflectors are\n\ * multiplied to form the block reflector:\n\ * = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n\ * = 'B': H = H(k) . . . H(2) H(1) (Backward)\n\ *\n\ * STOREV (input) CHARACTER*1\n\ * Specifies how the vectors which define the elementary\n\ * reflectors are stored (see also Further Details):\n\ * = 'C': columnwise (not supported yet)\n\ * = 'R': rowwise\n\ *\n\ * N (input) INTEGER\n\ * The order of the block reflector H. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The order of the triangular factor T (= the number of\n\ * elementary reflectors). K >= 1.\n\ *\n\ * V (input/output) COMPLEX array, dimension\n\ * (LDV,K) if STOREV = 'C'\n\ * (LDV,N) if STOREV = 'R'\n\ * The matrix V. See further details.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V.\n\ * If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n\ *\n\ * TAU (input) COMPLEX array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i).\n\ *\n\ * T (output) COMPLEX array, dimension (LDT,K)\n\ * The k by k triangular factor T of the block reflector.\n\ * If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n\ * lower triangular. The rest of the array is not used.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= K.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * The shape of the matrix V and the storage of the vectors which define\n\ * the H(i) is best illustrated by the following example with n = 5 and\n\ * k = 3. The elements equal to 1 are not stored; the corresponding\n\ * array elements are modified but restored on exit. The rest of the\n\ * array is not used.\n\ *\n\ * DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':\n\ *\n\ * ______V_____\n\ * ( v1 v2 v3 ) / \\\n\ * ( v1 v2 v3 ) ( v1 v1 v1 v1 v1 . . . . 1 )\n\ * V = ( v1 v2 v3 ) ( v2 v2 v2 v2 v2 . . . 1 )\n\ * ( v1 v2 v3 ) ( v3 v3 v3 v3 v3 . . 1 )\n\ * ( v1 v2 v3 )\n\ * . . .\n\ * . . .\n\ * 1 . .\n\ * 1 .\n\ * 1\n\ *\n\ * DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':\n\ *\n\ * ______V_____\n\ * 1 / \\\n\ * . 1 ( 1 . . . . v1 v1 v1 v1 v1 )\n\ * . . 1 ( . 1 . . . v2 v2 v2 v2 v2 )\n\ * . . . ( . . 1 . . v3 v3 v3 v3 v3 )\n\ * . . .\n\ * ( v1 v2 v3 )\n\ * ( v1 v2 v3 )\n\ * V = ( v1 v2 v3 )\n\ * ( v1 v2 v3 )\n\ * ( v1 v2 v3 )\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgsvj10000644000175000017500000002110712502223526016407 0ustar uwabamiuwabami--- :name: dgsvj1 :md5sum: 5a0a9a6d9b6517aee627cb9db7764663 :category: :subroutine :arguments: - jobv: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - n1: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - sva: :type: doublereal :intent: input/output :dims: - n - mv: :type: integer :intent: input - v: :type: doublereal :intent: input/output :dims: - ldv - n - ldv: :type: integer :intent: input - eps: :type: doublereal :intent: input - sfmin: :type: doublereal :intent: input - tol: :type: doublereal :intent: input - nsweep: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - lwork - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: lwork: m :fortran_help: " SUBROUTINE DGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGSVJ1 is called from SGESVJ as a pre-processor and that is its main\n\ * purpose. It applies Jacobi rotations in the same way as SGESVJ does, but\n\ * it targets only particular pivots and it does not check convergence\n\ * (stopping criterion). Few tunning parameters (marked by [TP]) are\n\ * available for the implementer.\n\ *\n\ * Further Details\n\ * ~~~~~~~~~~~~~~~\n\ * DGSVJ1 applies few sweeps of Jacobi rotations in the column space of\n\ * the input M-by-N matrix A. The pivot pairs are taken from the (1,2)\n\ * off-diagonal block in the corresponding N-by-N Gram matrix A^T * A. The\n\ * block-entries (tiles) of the (1,2) off-diagonal block are marked by the\n\ * [x]'s in the following scheme:\n\ *\n\ * | * * * [x] [x] [x]|\n\ * | * * * [x] [x] [x]| Row-cycling in the nblr-by-nblc [x] blocks.\n\ * | * * * [x] [x] [x]| Row-cyclic pivoting inside each [x] block.\n\ * |[x] [x] [x] * * * |\n\ * |[x] [x] [x] * * * |\n\ * |[x] [x] [x] * * * |\n\ *\n\ * In terms of the columns of A, the first N1 columns are rotated 'against'\n\ * the remaining N-N1 columns, trying to increase the angle between the\n\ * corresponding subspaces. The off-diagonal block is N1-by(N-N1) and it is\n\ * tiled using quadratic tiles of side KBL. Here, KBL is a tunning parmeter.\n\ * The number of sweeps is given in NSWEEP and the orthogonality threshold\n\ * is given in TOL.\n\ *\n\ * Contributors\n\ * ~~~~~~~~~~~~\n\ * Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBV (input) CHARACTER*1\n\ * Specifies whether the output from this procedure is used\n\ * to compute the matrix V:\n\ * = 'V': the product of the Jacobi rotations is accumulated\n\ * by postmulyiplying the N-by-N array V.\n\ * (See the description of V.)\n\ * = 'A': the product of the Jacobi rotations is accumulated\n\ * by postmulyiplying the MV-by-N array V.\n\ * (See the descriptions of MV and V.)\n\ * = 'N': the Jacobi rotations are not accumulated.\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.\n\ * M >= N >= 0.\n\ *\n\ * N1 (input) INTEGER\n\ * N1 specifies the 2 x 2 block partition, the first N1 columns are\n\ * rotated 'against' the remaining N-N1 columns of A.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, M-by-N matrix A, such that A*diag(D) represents\n\ * the input matrix.\n\ * On exit,\n\ * A_onexit * D_onexit represents the input matrix A*diag(D)\n\ * post-multiplied by a sequence of Jacobi rotations, where the\n\ * rotation threshold and the total number of sweeps are given in\n\ * TOL and NSWEEP, respectively.\n\ * (See the descriptions of N1, D, TOL and NSWEEP.)\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * D (input/workspace/output) DOUBLE PRECISION array, dimension (N)\n\ * The array D accumulates the scaling factors from the fast scaled\n\ * Jacobi rotations.\n\ * On entry, A*diag(D) represents the input matrix.\n\ * On exit, A_onexit*diag(D_onexit) represents the input matrix\n\ * post-multiplied by a sequence of Jacobi rotations, where the\n\ * rotation threshold and the total number of sweeps are given in\n\ * TOL and NSWEEP, respectively.\n\ * (See the descriptions of N1, A, TOL and NSWEEP.)\n\ *\n\ * SVA (input/workspace/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, SVA contains the Euclidean norms of the columns of\n\ * the matrix A*diag(D).\n\ * On exit, SVA contains the Euclidean norms of the columns of\n\ * the matrix onexit*diag(D_onexit).\n\ *\n\ * MV (input) INTEGER\n\ * If JOBV .EQ. 'A', then MV rows of V are post-multipled by a\n\ * sequence of Jacobi rotations.\n\ * If JOBV = 'N', then MV is not referenced.\n\ *\n\ * V (input/output) DOUBLE PRECISION array, dimension (LDV,N)\n\ * If JOBV .EQ. 'V' then N rows of V are post-multipled by a\n\ * sequence of Jacobi rotations.\n\ * If JOBV .EQ. 'A' then MV rows of V are post-multipled by a\n\ * sequence of Jacobi rotations.\n\ * If JOBV = 'N', then V is not referenced.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V, LDV >= 1.\n\ * If JOBV = 'V', LDV .GE. N.\n\ * If JOBV = 'A', LDV .GE. MV.\n\ *\n\ * EPS (input) DOUBLE PRECISION\n\ * EPS = DLAMCH('Epsilon')\n\ *\n\ * SFMIN (input) DOUBLE PRECISION\n\ * SFMIN = DLAMCH('Safe Minimum')\n\ *\n\ * TOL (input) DOUBLE PRECISION\n\ * TOL is the threshold for Jacobi rotations. For a pair\n\ * A(:,p), A(:,q) of pivot columns, the Jacobi rotation is\n\ * applied only if DABS(COS(angle(A(:,p),A(:,q)))) .GT. TOL.\n\ *\n\ * NSWEEP (input) INTEGER\n\ * NSWEEP is the number of sweeps of Jacobi rotations to be\n\ * performed.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)\n\ *\n\ * LWORK (input) INTEGER\n\ * LWORK is the dimension of WORK. LWORK .GE. M.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0 : successful exit.\n\ * < 0 : if INFO = -i, then the i-th argument had an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Parameters ..\n DOUBLE PRECISION ZERO, HALF, ONE, TWO\n PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0,\n + TWO = 2.0D0 )\n\ * ..\n\ * .. Local Scalars ..\n DOUBLE PRECISION AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,\n + BIGTHETA, CS, LARGE, MXAAPQ, MXSINJ, ROOTBIG,\n + ROOTEPS, ROOTSFMIN, ROOTTOL, SMALL, SN, T,\n + TEMP1, THETA, THSIGN\n INTEGER BLSKIP, EMPTSW, i, ibr, igl, IERR, IJBLSK,\n + ISWROT, jbc, jgl, KBL, MVL, NOTROT, nblc, nblr,\n + p, PSKIPPED, q, ROWSKIP, SWBAND\n LOGICAL APPLV, ROTOK, RSVEC\n\ * ..\n\ * .. Local Arrays ..\n DOUBLE PRECISION FASTR( 5 )\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC DABS, DMAX1, DBLE, MIN0, DSIGN, DSQRT\n\ * ..\n\ * .. External Functions ..\n DOUBLE PRECISION DDOT, DNRM2\n INTEGER IDAMAX\n LOGICAL LSAME\n EXTERNAL IDAMAX, LSAME, DDOT, DNRM2\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DAXPY, DCOPY, DLASCL, DLASSQ, DROTM, DSWAP\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sgebrd0000644000175000017500000001444112502223526016462 0ustar uwabamiuwabami--- :name: sgebrd :md5sum: e97ad4e90b71b7f4c64185e3257c2608 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: real :intent: output :dims: - MIN(m,n) - e: :type: real :intent: output :dims: - MIN(m,n)-1 - tauq: :type: real :intent: output :dims: - MIN(m,n) - taup: :type: real :intent: output :dims: - MIN(m,n) - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGEBRD reduces a general real M-by-N matrix A to upper or lower\n\ * bidiagonal form B by an orthogonal transformation: Q**T * A * P = B.\n\ *\n\ * If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows in the matrix A. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns in the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the M-by-N general matrix to be reduced.\n\ * On exit,\n\ * if m >= n, the diagonal and the first superdiagonal are\n\ * overwritten with the upper bidiagonal matrix B; the\n\ * elements below the diagonal, with the array TAUQ, represent\n\ * the orthogonal matrix Q as a product of elementary\n\ * reflectors, and the elements above the first superdiagonal,\n\ * with the array TAUP, represent the orthogonal matrix P as\n\ * a product of elementary reflectors;\n\ * if m < n, the diagonal and the first subdiagonal are\n\ * overwritten with the lower bidiagonal matrix B; the\n\ * elements below the first subdiagonal, with the array TAUQ,\n\ * represent the orthogonal matrix Q as a product of\n\ * elementary reflectors, and the elements above the diagonal,\n\ * with the array TAUP, represent the orthogonal matrix P as\n\ * a product of elementary reflectors.\n\ * See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * D (output) REAL array, dimension (min(M,N))\n\ * The diagonal elements of the bidiagonal matrix B:\n\ * D(i) = A(i,i).\n\ *\n\ * E (output) REAL array, dimension (min(M,N)-1)\n\ * The off-diagonal elements of the bidiagonal matrix B:\n\ * if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n\ * if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n\ *\n\ * TAUQ (output) REAL array dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the orthogonal matrix Q. See Further Details.\n\ *\n\ * TAUP (output) REAL array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the orthogonal matrix P. See Further Details.\n\ *\n\ * WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of the array WORK. LWORK >= max(1,M,N).\n\ * For optimum performance LWORK >= (M+N)*NB, where NB\n\ * is the 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 matrices Q and P are represented as products of elementary\n\ * reflectors:\n\ *\n\ * If m >= n,\n\ *\n\ * Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)\n\ *\n\ * Each H(i) and G(i) has the form:\n\ *\n\ * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n\ *\n\ * where tauq and taup are real scalars, and v and u are real vectors;\n\ * v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);\n\ * u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);\n\ * tauq is stored in TAUQ(i) and taup in TAUP(i).\n\ *\n\ * If m < n,\n\ *\n\ * Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)\n\ *\n\ * Each H(i) and G(i) has the form:\n\ *\n\ * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n\ *\n\ * where tauq and taup are real scalars, and v and u are real vectors;\n\ * v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);\n\ * u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);\n\ * tauq is stored in TAUQ(i) and taup in TAUP(i).\n\ *\n\ * The contents of A on exit are illustrated by the following examples:\n\ *\n\ * m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n\ *\n\ * ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )\n\ * ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )\n\ * ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )\n\ * ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )\n\ * ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )\n\ * ( v1 v2 v3 v4 v5 )\n\ *\n\ * where d and e denote diagonal and off-diagonal elements of B, vi\n\ * denotes an element of the vector defining H(i), and ui an element of\n\ * the vector defining G(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ztgevc0000644000175000017500000001513712502223526016521 0ustar uwabamiuwabami--- :name: ztgevc :md5sum: bae3f0de8622f9b5da908703d038acb9 :category: :subroutine :arguments: - side: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - s: :type: doublecomplex :intent: input :dims: - lds - n - lds: :type: integer :intent: input - p: :type: doublecomplex :intent: input :dims: - ldp - n - ldp: :type: integer :intent: input - vl: :type: doublecomplex :intent: input/output :dims: - ldvl - mm - ldvl: :type: integer :intent: input - vr: :type: doublecomplex :intent: input/output :dims: - ldvr - mm - ldvr: :type: integer :intent: input - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTGEVC computes some or all of the right and/or left eigenvectors of\n\ * a pair of complex matrices (S,P), where S and P are upper triangular.\n\ * Matrix pairs of this type are produced by the generalized Schur\n\ * factorization of a complex matrix pair (A,B):\n\ * \n\ * A = Q*S*Z**H, B = Q*P*Z**H\n\ * \n\ * as computed by ZGGHRD + ZHGEQZ.\n\ * \n\ * The right eigenvector x and the left eigenvector y of (S,P)\n\ * corresponding to an eigenvalue w are defined by:\n\ * \n\ * S*x = w*P*x, (y**H)*S = w*(y**H)*P,\n\ * \n\ * where y**H denotes the conjugate tranpose of y.\n\ * The eigenvalues are not input to this routine, but are computed\n\ * directly from the diagonal elements of S and P.\n\ * \n\ * This routine returns the matrices X and/or Y of right and left\n\ * eigenvectors of (S,P), or the products Z*X and/or Q*Y,\n\ * where Z and Q are input matrices.\n\ * If Q and Z are the unitary factors from the generalized Schur\n\ * factorization of a matrix pair (A,B), then Z*X and Q*Y\n\ * are the matrices of right and left eigenvectors of (A,B).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'R': compute right eigenvectors only;\n\ * = 'L': compute left eigenvectors only;\n\ * = 'B': compute both right and left eigenvectors.\n\ *\n\ * HOWMNY (input) CHARACTER*1\n\ * = 'A': compute all right and/or left eigenvectors;\n\ * = 'B': compute all right and/or left eigenvectors,\n\ * backtransformed by the matrices in VR and/or VL;\n\ * = 'S': compute selected right and/or left eigenvectors,\n\ * specified by the logical array SELECT.\n\ *\n\ * SELECT (input) LOGICAL array, dimension (N)\n\ * If HOWMNY='S', SELECT specifies the eigenvectors to be\n\ * computed. The eigenvector corresponding to the j-th\n\ * eigenvalue is computed if SELECT(j) = .TRUE..\n\ * Not referenced if HOWMNY = 'A' or 'B'.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices S and P. N >= 0.\n\ *\n\ * S (input) COMPLEX*16 array, dimension (LDS,N)\n\ * The upper triangular matrix S from a generalized Schur\n\ * factorization, as computed by ZHGEQZ.\n\ *\n\ * LDS (input) INTEGER\n\ * The leading dimension of array S. LDS >= max(1,N).\n\ *\n\ * P (input) COMPLEX*16 array, dimension (LDP,N)\n\ * The upper triangular matrix P from a generalized Schur\n\ * factorization, as computed by ZHGEQZ. P must have real\n\ * diagonal elements.\n\ *\n\ * LDP (input) INTEGER\n\ * The leading dimension of array P. LDP >= max(1,N).\n\ *\n\ * VL (input/output) COMPLEX*16 array, dimension (LDVL,MM)\n\ * On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n\ * contain an N-by-N matrix Q (usually the unitary matrix Q\n\ * of left Schur vectors returned by ZHGEQZ).\n\ * On exit, if SIDE = 'L' or 'B', VL contains:\n\ * if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);\n\ * if HOWMNY = 'B', the matrix Q*Y;\n\ * if HOWMNY = 'S', the left eigenvectors of (S,P) specified by\n\ * SELECT, stored consecutively in the columns of\n\ * VL, in the same order as their eigenvalues.\n\ * Not referenced if SIDE = 'R'.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of array VL. LDVL >= 1, and if\n\ * SIDE = 'L' or 'l' or 'B' or 'b', LDVL >= N.\n\ *\n\ * VR (input/output) COMPLEX*16 array, dimension (LDVR,MM)\n\ * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n\ * contain an N-by-N matrix Q (usually the unitary matrix Z\n\ * of right Schur vectors returned by ZHGEQZ).\n\ * On exit, if SIDE = 'R' or 'B', VR contains:\n\ * if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);\n\ * if HOWMNY = 'B', the matrix Z*X;\n\ * if HOWMNY = 'S', the right eigenvectors of (S,P) specified by\n\ * SELECT, stored consecutively in the columns of\n\ * VR, in the same order as their eigenvalues.\n\ * Not referenced if SIDE = 'L'.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the array VR. LDVR >= 1, and if\n\ * SIDE = 'R' or 'B', LDVR >= N.\n\ *\n\ * MM (input) INTEGER\n\ * The number of columns in the arrays VL and/or VR. MM >= M.\n\ *\n\ * M (output) INTEGER\n\ * The number of columns in the arrays VL and/or VR actually\n\ * used to store the eigenvectors. If HOWMNY = 'A' or 'B', M\n\ * is set to N. Each selected eigenvector occupies one column.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgeql20000644000175000017500000000513012502223525016363 0ustar uwabamiuwabami--- :name: cgeql2 :md5sum: e094d31e3478cc3db98bef235a365dbd :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - MIN(m,n) - work: :type: complex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGEQL2( M, N, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGEQL2 computes a QL factorization of a complex m by n matrix A:\n\ * A = Q * L.\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) COMPLEX array, dimension (LDA,N)\n\ * On entry, the m by n matrix A.\n\ * On exit, if m >= n, the lower triangle of the subarray\n\ * A(m-n+1:m,1:n) contains the n by n lower triangular matrix L;\n\ * if m <= n, the elements on and below the (n-m)-th\n\ * superdiagonal contain the m by n lower trapezoidal matrix L;\n\ * the remaining elements, with the array TAU, represent the\n\ * unitary matrix Q as a product of elementary reflectors\n\ * (see Further Details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (output) COMPLEX array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (N)\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 complex scalar, and v is a complex vector with\n\ * v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n\ * A(1:m-k+i-1,n-k+i), and tau in TAU(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgehrd0000644000175000017500000001131012502223525016437 0ustar uwabamiuwabami--- :name: cgehrd :md5sum: fe31e41de8aa4f616eac2734fd86700f :category: :subroutine :arguments: - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - n-1 - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGEHRD reduces a complex general matrix A to upper Hessenberg form H by\n\ * an unitary similarity transformation: Q' * A * Q = H .\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * It is assumed that A is already upper triangular in rows\n\ * and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n\ * set by a previous call to CGEBAL; otherwise they should be\n\ * set to 1 and N respectively. See Further Details.\n\ * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the N-by-N general matrix to be reduced.\n\ * On exit, the upper triangle and the first subdiagonal of A\n\ * are overwritten with the upper Hessenberg matrix H, and the\n\ * elements below the first subdiagonal, with the array TAU,\n\ * represent the unitary matrix Q as a product of elementary\n\ * reflectors. See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * TAU (output) COMPLEX array, dimension (N-1)\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to\n\ * zero.\n\ *\n\ * WORK (workspace/output) COMPLEX array, dimension (LWORK)\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of the array WORK. LWORK >= max(1,N).\n\ * For optimum performance LWORK >= N*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 (ihi-ilo) elementary\n\ * reflectors\n\ *\n\ * Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar, and v is a complex vector with\n\ * v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n\ * exit in A(i+2:ihi,i), and tau in TAU(i).\n\ *\n\ * The contents of A are illustrated by the following example, with\n\ * n = 7, ilo = 2 and ihi = 6:\n\ *\n\ * on entry, on exit,\n\ *\n\ * ( a a a a a a a ) ( a a h h h h a )\n\ * ( a a a a a a ) ( a h h h h a )\n\ * ( a a a a a a ) ( h h h h h h )\n\ * ( a a a a a a ) ( v2 h h h h h )\n\ * ( a a a a a a ) ( v2 v3 h h h h )\n\ * ( a a a a a a ) ( v2 v3 v4 h h h )\n\ * ( a ) ( a )\n\ *\n\ * where a denotes an element of the original matrix A, h denotes a\n\ * modified element of the upper Hessenberg matrix H, and vi denotes an\n\ * element of the vector defining H(i).\n\ *\n\ * This file is a slight modification of LAPACK-3.0's DGEHRD\n\ * subroutine incorporating improvements proposed by Quintana-Orti and\n\ * Van de Geijn (2006). (See DLAHR2.)\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgetc20000644000175000017500000000504212502223526016407 0ustar uwabamiuwabami--- :name: zgetc2 :md5sum: 017780c8b3ef2a235613004b824db1dc :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - jpiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGETC2( N, A, LDA, IPIV, JPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGETC2 computes an LU factorization, using complete pivoting, of the\n\ * n-by-n matrix A. The factorization has the form A = P * L * U * Q,\n\ * where P and Q are permutation matrices, L is lower triangular with\n\ * unit diagonal elements and U is upper triangular.\n\ *\n\ * This is a level 1 BLAS version of the algorithm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA, N)\n\ * On entry, the n-by-n matrix to be factored.\n\ * On exit, the factors L and U from the factorization\n\ * A = P*L*U*Q; the unit diagonal elements of L are not stored.\n\ * If U(k, k) appears to be less than SMIN, U(k, k) is given the\n\ * value of SMIN, giving a nonsingular perturbed system.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1, N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N).\n\ * The pivot indices; for 1 <= i <= N, row i of the\n\ * matrix has been interchanged with row IPIV(i).\n\ *\n\ * JPIV (output) INTEGER array, dimension (N).\n\ * The pivot indices; for 1 <= j <= N, column j of the\n\ * matrix has been interchanged with column JPIV(j).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * > 0: if INFO = k, U(k, k) is likely to produce overflow if\n\ * one tries to solve for x in Ax = b. So U is perturbed\n\ * to avoid the overflow.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/spstf20000644000175000017500000000673112502223526016440 0ustar uwabamiuwabami--- :name: spstf2 :md5sum: 7c3f23878642ae0aa4302ae0bd2848c1 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - piv: :type: integer :intent: output :dims: - n - rank: :type: integer :intent: output - tol: :type: real :intent: input - work: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPSTF2 computes the Cholesky factorization with complete\n\ * pivoting of a real symmetric positive semidefinite matrix A.\n\ *\n\ * The factorization has the form\n\ * P' * A * P = U' * U , if UPLO = 'U',\n\ * P' * A * P = L * L', if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is lower triangular, and\n\ * P is stored as vector PIV.\n\ *\n\ * This algorithm does not attempt to check that A is positive\n\ * semidefinite. This version of the algorithm calls level 2 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * n by n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n by n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the factor U or L from the Cholesky\n\ * factorization as above.\n\ *\n\ * PIV (output) INTEGER array, dimension (N)\n\ * PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n\ *\n\ * RANK (output) INTEGER\n\ * The rank of A given by the number of steps the algorithm\n\ * completed.\n\ *\n\ * TOL (input) REAL\n\ * User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) )\n\ * will be used. The algorithm terminates at the (K-1)st step\n\ * if the pivot <= TOL.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * WORK (workspace) REAL array, dimension (2*N)\n\ * Work space.\n\ *\n\ * INFO (output) INTEGER\n\ * < 0: If INFO = -K, the K-th argument had an illegal value,\n\ * = 0: algorithm completed successfully, and\n\ * > 0: the matrix A is either rank deficient with computed rank\n\ * as returned in RANK, or is indefinite. See Section 7 of\n\ * LAPACK Working Note #161 for further information.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chptrs0000644000175000017500000000464512502223525016523 0ustar uwabamiuwabami--- :name: chptrs :md5sum: 7f2d33532d7caeda7fca44e1cfb4346c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CHPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHPTRS solves a system of linear equations A*X = B with a complex\n\ * Hermitian matrix A stored in packed format using the factorization\n\ * A = U*D*U**H or A = L*D*L**H computed by CHPTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**H;\n\ * = 'L': Lower triangular, form is A = L*D*L**H.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AP (input) COMPLEX array, dimension (N*(N+1)/2)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by CHPTRF, stored as a\n\ * packed triangular matrix.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by CHPTRF.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/csyrfs0000644000175000017500000001215012502223525016517 0ustar uwabamiuwabami--- :name: csyrfs :md5sum: 4970ead7255fb16d7d98d6b6286b9d12 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSYRFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is symmetric indefinite, and\n\ * provides error bounds and backward error estimates for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular part\n\ * of the matrix A, and the strictly lower triangular part of A\n\ * is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of A contains the lower triangular part of\n\ * the matrix A, and the strictly upper triangular part of A is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX array, dimension (LDAF,N)\n\ * The factored form of the matrix A. AF contains the block\n\ * diagonal matrix D and the multipliers used to obtain the\n\ * factor U or L from the factorization A = U*D*U**T or\n\ * A = L*D*L**T as computed by CSYTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by CSYTRF.\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) COMPLEX array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by CSYTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgesvx0000644000175000017500000003257712502223526016526 0ustar uwabamiuwabami--- :name: dgesvx :md5sum: cb38332edb915fb28cae04bc3431f6ab :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input/output :dims: - ldaf - n :option: true - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n :option: true - equed: :type: char :intent: input/output :option: true - r: :type: doublereal :intent: input/output :dims: - n :option: true - c: :type: doublereal :intent: input/output :dims: - n :option: true - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: output :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: n ldaf: n :fortran_help: " SUBROUTINE DGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGESVX uses the LU factorization to compute the solution to a real\n\ * system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', real scaling factors are computed to equilibrate\n\ * the system:\n\ * TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n\ * TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n\ * TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n\ * or diag(C)*B (if TRANS = 'T' or 'C').\n\ *\n\ * 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n\ * matrix A (after equilibration if FACT = 'E') as\n\ * A = P * L * U,\n\ * where P is a permutation matrix, L is a unit lower triangular\n\ * matrix, and U is upper triangular.\n\ *\n\ * 3. If some U(i,i)=0, so that U is exactly singular, then the routine\n\ * returns with INFO = i. Otherwise, the factored form of A is used\n\ * to estimate the condition number of the matrix A. If the\n\ * reciprocal of the condition number is less than machine precision,\n\ * INFO = N+1 is returned as a warning, but the routine still goes on\n\ * to solve for X and compute error bounds as described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n\ * that it solves the original system before equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AF and IPIV contain the factored form of A.\n\ * If EQUED is not 'N', the matrix A has been\n\ * equilibrated with scaling factors given by R and C.\n\ * A, AF, and IPIV are not modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AF and factored.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is\n\ * not 'N', then A must have been equilibrated by the scaling\n\ * factors in R and/or C. A is not modified if FACT = 'F' or\n\ * 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n\ *\n\ * On exit, if EQUED .ne. 'N', A is scaled as follows:\n\ * EQUED = 'R': A := diag(R) * A\n\ * EQUED = 'C': A := A * diag(C)\n\ * EQUED = 'B': A := diag(R) * A * diag(C).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N)\n\ * If FACT = 'F', then AF is an input argument and on entry\n\ * contains the factors L and U from the factorization\n\ * A = P*L*U as computed by DGETRF. If EQUED .ne. 'N', then\n\ * AF is the factored form of the equilibrated matrix A.\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the factors L and U from the factorization A = P*L*U\n\ * of the original matrix A.\n\ *\n\ * If FACT = 'E', then AF is an output argument and on exit\n\ * returns the factors L and U from the factorization A = P*L*U\n\ * of the equilibrated matrix A (see the description of A for\n\ * the form of the equilibrated matrix).\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * as computed by DGETRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * of the original matrix A.\n\ *\n\ * If FACT = 'E', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * of the equilibrated matrix A.\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * R (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'R' or 'B', A is\n\ * multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n\ * is not accessed. R is an input argument if FACT = 'F';\n\ * otherwise, R is an output argument. If FACT = 'F' and\n\ * EQUED = 'R' or 'B', each element of R must be positive.\n\ *\n\ * C (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The column scale factors for A. If EQUED = 'C' or 'B', A is\n\ * multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n\ * is not accessed. C is an input argument if FACT = 'F';\n\ * otherwise, C is an output argument. If FACT = 'F' and\n\ * EQUED = 'C' or 'B', each element of C must be positive.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit,\n\ * if EQUED = 'N', B is not modified;\n\ * if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n\ * diag(R)*B;\n\ * if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n\ * overwritten by diag(C)*B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n\ * to the original system of equations. Note that A and B are\n\ * modified on exit if EQUED .ne. 'N', and the solution to the\n\ * equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n\ * EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n\ * and EQUED = 'R' or 'B'.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A after equilibration (if done). If RCOND is less than the\n\ * machine precision (in particular, if RCOND = 0), the matrix\n\ * is singular to working precision. This condition is\n\ * indicated by a return code of INFO > 0.\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace/output) DOUBLE PRECISION array, dimension (4*N)\n\ * On exit, WORK(1) contains the reciprocal pivot growth\n\ * factor norm(A)/norm(U). The \"max absolute element\" norm is\n\ * used. If WORK(1) is much less than 1, then the stability\n\ * of the LU factorization of the (equilibrated) matrix A\n\ * could be poor. This also means that the solution X, condition\n\ * estimator RCOND, and forward error bound FERR could be\n\ * unreliable. If factorization fails with 0 0: if INFO = i, and i is\n\ * <= N: U(i,i) is exactly zero. The factorization has\n\ * been completed, but the factor U is exactly\n\ * singular, so the solution and error bounds\n\ * could not be computed. RCOND = 0 is returned.\n\ * = N+1: U is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chbtrd0000644000175000017500000001003612502223525016455 0ustar uwabamiuwabami--- :name: chbtrd :md5sum: 58603e69db2395aacc0af96c113a10e7 :category: :subroutine :arguments: - vect: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - d: :type: real :intent: output :dims: - n - e: :type: real :intent: output :dims: - n-1 - q: :type: complex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CHBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHBTRD reduces a complex Hermitian band matrix A to real symmetric\n\ * tridiagonal form T by a unitary similarity transformation:\n\ * Q**H * A * Q = T.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * VECT (input) CHARACTER*1\n\ * = 'N': do not form Q;\n\ * = 'V': form Q;\n\ * = 'U': update a matrix X, by forming X*Q.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) COMPLEX array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ * On exit, the diagonal elements of AB are overwritten by the\n\ * diagonal elements of the tridiagonal matrix T; if KD > 0, the\n\ * elements on the first superdiagonal (if UPLO = 'U') or the\n\ * first subdiagonal (if UPLO = 'L') are overwritten by the\n\ * off-diagonal elements of T; the rest of AB is overwritten by\n\ * values generated during the reduction.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * D (output) REAL array, dimension (N)\n\ * The diagonal elements of the tridiagonal matrix T.\n\ *\n\ * E (output) REAL array, dimension (N-1)\n\ * The off-diagonal elements of the tridiagonal matrix T:\n\ * E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.\n\ *\n\ * Q (input/output) COMPLEX array, dimension (LDQ,N)\n\ * On entry, if VECT = 'U', then Q must contain an N-by-N\n\ * matrix X; if VECT = 'N' or 'V', then Q need not be set.\n\ *\n\ * On exit:\n\ * if VECT = 'V', Q contains the N-by-N unitary matrix Q;\n\ * if VECT = 'U', Q contains the product X*Q;\n\ * if VECT = 'N', the array Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q.\n\ * LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (N)\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\ * Modified by Linda Kaufman, Bell Labs.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlaed80000644000175000017500000001643712502223526016364 0ustar uwabamiuwabami--- :name: dlaed8 :md5sum: d8ce12a706721da54812694fab3a1bbe :category: :subroutine :arguments: - icompq: :type: integer :intent: input - k: :type: integer :intent: output - n: :type: integer :intent: input - qsiz: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - q: :type: doublereal :intent: input/output :dims: - "icompq==0 ? 0 : ldq" - "icompq==0 ? 0 : n" - ldq: :type: integer :intent: input - indxq: :type: integer :intent: input :dims: - n - rho: :type: doublereal :intent: input/output - cutpnt: :type: integer :intent: input - z: :type: doublereal :intent: input :dims: - n - dlamda: :type: doublereal :intent: output :dims: - n - q2: :type: doublereal :intent: output :dims: - "icompq==0 ? 0 : ldq2" - "icompq==0 ? 0 : n" - ldq2: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - perm: :type: integer :intent: output :dims: - n - givptr: :type: integer :intent: output - givcol: :type: integer :intent: output :dims: - "2" - n - givnum: :type: doublereal :intent: output :dims: - "2" - n - indxp: :type: integer :intent: workspace :dims: - n - indx: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldq2: MAX(1,n) :fortran_help: " SUBROUTINE DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR, GIVCOL, GIVNUM, INDXP, INDX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAED8 merges the two sets of eigenvalues together into a single\n\ * sorted set. Then it tries to deflate the size of the problem.\n\ * There are two ways in which deflation can occur: when two or more\n\ * eigenvalues are close together or if there is a tiny element in the\n\ * Z vector. For each such occurrence the order of the related secular\n\ * equation problem is reduced by one.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ICOMPQ (input) INTEGER\n\ * = 0: Compute eigenvalues only.\n\ * = 1: Compute eigenvectors of original dense symmetric matrix\n\ * also. On entry, Q contains the orthogonal matrix used\n\ * to reduce the original matrix to tridiagonal form.\n\ *\n\ * K (output) INTEGER\n\ * The number of non-deflated eigenvalues, and the order of the\n\ * related secular equation.\n\ *\n\ * N (input) INTEGER\n\ * The dimension of the symmetric tridiagonal matrix. N >= 0.\n\ *\n\ * QSIZ (input) INTEGER\n\ * The dimension of the orthogonal matrix used to reduce\n\ * the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the eigenvalues of the two submatrices to be\n\ * combined. On exit, the trailing (N-K) updated eigenvalues\n\ * (those which were deflated) sorted into increasing order.\n\ *\n\ * Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n\ * If ICOMPQ = 0, Q is not referenced. Otherwise,\n\ * on entry, Q contains the eigenvectors of the partially solved\n\ * system which has been previously updated in matrix\n\ * multiplies with other partially solved eigensystems.\n\ * On exit, Q contains the trailing (N-K) updated eigenvectors\n\ * (those which were deflated) in its last N-K columns.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N).\n\ *\n\ * INDXQ (input) INTEGER array, dimension (N)\n\ * The permutation which separately sorts the two sub-problems\n\ * in D into ascending order. Note that elements in the second\n\ * half of this permutation must first have CUTPNT added to\n\ * their values in order to be accurate.\n\ *\n\ * RHO (input/output) DOUBLE PRECISION\n\ * On entry, the off-diagonal element associated with the rank-1\n\ * cut which originally split the two submatrices which are now\n\ * being recombined.\n\ * On exit, RHO has been modified to the value required by\n\ * DLAED3.\n\ *\n\ * CUTPNT (input) INTEGER\n\ * The location of the last eigenvalue in the leading\n\ * sub-matrix. min(1,N) <= CUTPNT <= N.\n\ *\n\ * Z (input) DOUBLE PRECISION array, dimension (N)\n\ * On entry, Z contains the updating vector (the last row of\n\ * the first sub-eigenvector matrix and the first row of the\n\ * second sub-eigenvector matrix).\n\ * On exit, the contents of Z are destroyed by the updating\n\ * process.\n\ *\n\ * DLAMDA (output) DOUBLE PRECISION array, dimension (N)\n\ * A copy of the first K eigenvalues which will be used by\n\ * DLAED3 to form the secular equation.\n\ *\n\ * Q2 (output) DOUBLE PRECISION array, dimension (LDQ2,N)\n\ * If ICOMPQ = 0, Q2 is not referenced. Otherwise,\n\ * a copy of the first K eigenvectors which will be used by\n\ * DLAED7 in a matrix multiply (DGEMM) to update the new\n\ * eigenvectors.\n\ *\n\ * LDQ2 (input) INTEGER\n\ * The leading dimension of the array Q2. LDQ2 >= max(1,N).\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * The first k values of the final deflation-altered z-vector and\n\ * will be passed to DLAED3.\n\ *\n\ * PERM (output) INTEGER array, dimension (N)\n\ * The permutations (from deflation and sorting) to be applied\n\ * to each eigenblock.\n\ *\n\ * GIVPTR (output) INTEGER\n\ * The number of Givens rotations which took place in this\n\ * subproblem.\n\ *\n\ * GIVCOL (output) INTEGER array, dimension (2, N)\n\ * Each pair of numbers indicates a pair of columns to take place\n\ * in a Givens rotation.\n\ *\n\ * GIVNUM (output) DOUBLE PRECISION array, dimension (2, N)\n\ * Each number indicates the S value to be used in the\n\ * corresponding Givens rotation.\n\ *\n\ * INDXP (workspace) INTEGER array, dimension (N)\n\ * The permutation used to place deflated values of D at the end\n\ * of the array. INDXP(1:K) points to the nondeflated D-values\n\ * and INDXP(K+1:N) points to the deflated eigenvalues.\n\ *\n\ * INDX (workspace) INTEGER array, dimension (N)\n\ * The permutation used to sort the contents of D into ascending\n\ * order.\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\ * Based on contributions by\n\ * Jeff Rutter, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/claic10000644000175000017500000000522112502223525016343 0ustar uwabamiuwabami--- :name: claic1 :md5sum: 22926ad0c8db95eafc17cf2632e11865 :category: :subroutine :arguments: - job: :type: integer :intent: input - j: :type: integer :intent: input - x: :type: complex :intent: input :dims: - j - sest: :type: real :intent: input - w: :type: complex :intent: input :dims: - j - gamma: :type: complex :intent: input - sestpr: :type: real :intent: output - s: :type: complex :intent: output - c: :type: complex :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAIC1 applies one step of incremental condition estimation in\n\ * its simplest version:\n\ *\n\ * Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j\n\ * lower triangular matrix L, such that\n\ * twonorm(L*x) = sest\n\ * Then CLAIC1 computes sestpr, s, c such that\n\ * the vector\n\ * [ s*x ]\n\ * xhat = [ c ]\n\ * is an approximate singular vector of\n\ * [ L 0 ]\n\ * Lhat = [ w' gamma ]\n\ * in the sense that\n\ * twonorm(Lhat*xhat) = sestpr.\n\ *\n\ * Depending on JOB, an estimate for the largest or smallest singular\n\ * value is computed.\n\ *\n\ * Note that [s c]' and sestpr**2 is an eigenpair of the system\n\ *\n\ * diag(sest*sest, 0) + [alpha gamma] * [ conjg(alpha) ]\n\ * [ conjg(gamma) ]\n\ *\n\ * where alpha = conjg(x)'*w.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) INTEGER\n\ * = 1: an estimate for the largest singular value is computed.\n\ * = 2: an estimate for the smallest singular value is computed.\n\ *\n\ * J (input) INTEGER\n\ * Length of X and W\n\ *\n\ * X (input) COMPLEX array, dimension (J)\n\ * The j-vector x.\n\ *\n\ * SEST (input) REAL\n\ * Estimated singular value of j by j matrix L\n\ *\n\ * W (input) COMPLEX array, dimension (J)\n\ * The j-vector w.\n\ *\n\ * GAMMA (input) COMPLEX\n\ * The diagonal element gamma.\n\ *\n\ * SESTPR (output) REAL\n\ * Estimated singular value of (j+1) by (j+1) matrix Lhat.\n\ *\n\ * S (output) COMPLEX\n\ * Sine needed in forming xhat.\n\ *\n\ * C (output) COMPLEX\n\ * Cosine needed in forming xhat.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhpevd0000644000175000017500000001560512502223526016517 0ustar uwabamiuwabami--- :name: zhpevd :md5sum: 6547972d4a8ed778f40a7ad0af3719f2 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - ldap - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 2*n : 0" - rwork: :type: doublereal :intent: output :dims: - MAX(1,lrwork) - lrwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "(lsame_(&jobz,\"N\")||n<=1) ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE ZHPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHPEVD computes all the eigenvalues and, optionally, eigenvectors of\n\ * a complex Hermitian matrix A in packed storage. If eigenvectors are\n\ * desired, it uses a divide and conquer algorithm.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, AP is overwritten by values generated during the\n\ * reduction to tridiagonal form. If UPLO = 'U', the diagonal\n\ * and first superdiagonal of the tridiagonal matrix T overwrite\n\ * the corresponding elements of A, and if UPLO = 'L', the\n\ * diagonal and first subdiagonal of T overwrite the\n\ * corresponding elements of A.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) COMPLEX*16 array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n\ * eigenvectors of the matrix A, with the i-th column of Z\n\ * holding the eigenvector associated with W(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the required LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of array WORK.\n\ * If N <= 1, LWORK must be at least 1.\n\ * If JOBZ = 'N' and N > 1, LWORK must be at least N.\n\ * If JOBZ = 'V' and N > 1, LWORK must be at least 2*N.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the required sizes of the WORK, RWORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * RWORK (workspace/output) DOUBLE PRECISION array,\n\ * dimension (LRWORK)\n\ * On exit, if INFO = 0, RWORK(1) returns the required LRWORK.\n\ *\n\ * LRWORK (input) INTEGER\n\ * The dimension of array RWORK.\n\ * If N <= 1, LRWORK must be at least 1.\n\ * If JOBZ = 'N' and N > 1, LRWORK must be at least N.\n\ * If JOBZ = 'V' and N > 1, LRWORK must be at least\n\ * 1 + 5*N + 2*N**2.\n\ *\n\ * If LRWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the required sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of array IWORK.\n\ * If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.\n\ * If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the required sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK 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 algorithm failed to converge; i\n\ * off-diagonal elements of an intermediate tridiagonal\n\ * form did not converge to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/stprfs0000644000175000017500000001102312502223526016526 0ustar uwabamiuwabami--- :name: stprfs :md5sum: f24b1ca96348a27a0f29020ea208cd14 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: real :intent: input :dims: - n*(n+1)/2 - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ldb :fortran_help: " SUBROUTINE STPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STPRFS provides error bounds and backward error estimates for the\n\ * solution to a system of linear equations with a triangular packed\n\ * coefficient matrix.\n\ *\n\ * The solution matrix X must be computed by STPTRS or some other\n\ * means before entering this routine. STPRFS does not do iterative\n\ * refinement because doing so cannot improve the backward error.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose = Transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AP (input) REAL array, dimension (N*(N+1)/2)\n\ * The upper or lower triangular matrix A, packed columnwise in\n\ * a linear array. The j-th column of A is stored in the array\n\ * AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ * If DIAG = 'U', the diagonal elements of A are not referenced\n\ * and are assumed to be 1.\n\ *\n\ * B (input) REAL array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input) REAL array, dimension (LDX,NRHS)\n\ * The solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) REAL array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlaqtr0000644000175000017500000001025312502223526016500 0ustar uwabamiuwabami--- :name: dlaqtr :md5sum: 3ddbfae11a027af905ef99908a20b4bc :category: :subroutine :arguments: - ltran: :type: logical :intent: input - lreal: :type: logical :intent: input - n: :type: integer :intent: input - t: :type: doublereal :intent: input :dims: - ldt - n - ldt: :type: integer :intent: input - b: :type: doublereal :intent: input :dims: - n - w: :type: doublereal :intent: input - scale: :type: doublereal :intent: output - x: :type: doublereal :intent: input/output :dims: - 2*n - work: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAQTR solves the real quasi-triangular system\n\ *\n\ * op(T)*p = scale*c, if LREAL = .TRUE.\n\ *\n\ * or the complex quasi-triangular systems\n\ *\n\ * op(T + iB)*(p+iq) = scale*(c+id), if LREAL = .FALSE.\n\ *\n\ * in real arithmetic, where T is upper quasi-triangular.\n\ * If LREAL = .FALSE., then the first diagonal block of T must be\n\ * 1 by 1, B is the specially structured matrix\n\ *\n\ * B = [ b(1) b(2) ... b(n) ]\n\ * [ w ]\n\ * [ w ]\n\ * [ . ]\n\ * [ w ]\n\ *\n\ * op(A) = A or A', A' denotes the conjugate transpose of\n\ * matrix A.\n\ *\n\ * On input, X = [ c ]. On output, X = [ p ].\n\ * [ d ] [ q ]\n\ *\n\ * This subroutine is designed for the condition number estimation\n\ * in routine DTRSNA.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * LTRAN (input) LOGICAL\n\ * On entry, LTRAN specifies the option of conjugate transpose:\n\ * = .FALSE., op(T+i*B) = T+i*B,\n\ * = .TRUE., op(T+i*B) = (T+i*B)'.\n\ *\n\ * LREAL (input) LOGICAL\n\ * On entry, LREAL specifies the input matrix structure:\n\ * = .FALSE., the input is complex\n\ * = .TRUE., the input is real\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the order of T+i*B. N >= 0.\n\ *\n\ * T (input) DOUBLE PRECISION array, dimension (LDT,N)\n\ * On entry, T contains a matrix in Schur canonical form.\n\ * If LREAL = .FALSE., then the first diagonal block of T mu\n\ * be 1 by 1.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the matrix T. LDT >= max(1,N).\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (N)\n\ * On entry, B contains the elements to form the matrix\n\ * B as described above.\n\ * If LREAL = .TRUE., B is not referenced.\n\ *\n\ * W (input) DOUBLE PRECISION\n\ * On entry, W is the diagonal element of the matrix B.\n\ * If LREAL = .TRUE., W is not referenced.\n\ *\n\ * SCALE (output) DOUBLE PRECISION\n\ * On exit, SCALE is the scale factor.\n\ *\n\ * X (input/output) DOUBLE PRECISION array, dimension (2*N)\n\ * On entry, X contains the right hand side of the system.\n\ * On exit, X is overwritten by the solution.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * On exit, INFO is set to\n\ * 0: successful exit.\n\ * 1: the some diagonal 1 by 1 block has been perturbed by\n\ * a small number SMIN to keep nonsingularity.\n\ * 2: the some diagonal 2 by 2 block has been perturbed by\n\ * a small number in DLALN2 to keep nonsingularity.\n\ * NOTE: In the interests of speed, this routine does not\n\ * check the inputs for errors.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlatrs0000644000175000017500000001716512502223526016541 0ustar uwabamiuwabami--- :name: zlatrs :md5sum: 7ee5a9584440f5928720414c337c052d :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - normin: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - n - scale: :type: doublereal :intent: output - cnorm: :type: doublereal :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, CNORM, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLATRS solves one of the triangular systems\n\ *\n\ * A * x = s*b, A**T * x = s*b, or A**H * x = s*b,\n\ *\n\ * with scaling to prevent overflow. Here A is an upper or lower\n\ * triangular matrix, A**T denotes the transpose of A, A**H denotes the\n\ * conjugate transpose of A, x and b are n-element vectors, and s is a\n\ * scaling factor, usually less than or equal to 1, chosen so that the\n\ * components of x will be less than the overflow threshold. If the\n\ * unscaled problem will not cause overflow, the Level 2 BLAS routine\n\ * ZTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j),\n\ * then s is set to 0 and a non-trivial solution to A*x = 0 is returned.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the matrix A is upper or lower triangular.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the operation applied to A.\n\ * = 'N': Solve A * x = s*b (No transpose)\n\ * = 'T': Solve A**T * x = s*b (Transpose)\n\ * = 'C': Solve A**H * x = s*b (Conjugate transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * Specifies whether or not the matrix A is unit triangular.\n\ * = 'N': Non-unit triangular\n\ * = 'U': Unit triangular\n\ *\n\ * NORMIN (input) CHARACTER*1\n\ * Specifies whether CNORM has been set or not.\n\ * = 'Y': CNORM contains the column norms on entry\n\ * = 'N': CNORM is not set on entry. On exit, the norms will\n\ * be computed and stored in CNORM.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The triangular matrix A. If UPLO = 'U', the leading n by n\n\ * upper triangular part of the array A contains the upper\n\ * triangular matrix, and the strictly lower triangular part of\n\ * A is not referenced. If UPLO = 'L', the leading n by n lower\n\ * triangular part of the array A contains the lower triangular\n\ * matrix, and the strictly upper triangular part of A is not\n\ * referenced. If DIAG = 'U', the diagonal elements of A are\n\ * also not referenced and are assumed to be 1.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max (1,N).\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension (N)\n\ * On entry, the right hand side b of the triangular system.\n\ * On exit, X is overwritten by the solution vector x.\n\ *\n\ * SCALE (output) DOUBLE PRECISION\n\ * The scaling factor s for the triangular system\n\ * A * x = s*b, A**T * x = s*b, or A**H * x = s*b.\n\ * If SCALE = 0, the matrix A is singular or badly scaled, and\n\ * the vector x is an exact or approximate solution to A*x = 0.\n\ *\n\ * CNORM (input or output) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n\ * contains the norm of the off-diagonal part of the j-th column\n\ * of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n\ * to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n\ * must be greater than or equal to the 1-norm.\n\ *\n\ * If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n\ * returns the 1-norm of the offdiagonal part of the j-th column\n\ * of A.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ *\n\n\ * Further Details\n\ * ======= =======\n\ *\n\ * A rough bound on x is computed; if that is less than overflow, ZTRSV\n\ * is called, otherwise, specific code is used which checks for possible\n\ * overflow or divide-by-zero at every operation.\n\ *\n\ * A columnwise scheme is used for solving A*x = b. The basic algorithm\n\ * if A is lower triangular is\n\ *\n\ * x[1:n] := b[1:n]\n\ * for j = 1, ..., n\n\ * x(j) := x(j) / A(j,j)\n\ * x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n\ * end\n\ *\n\ * Define bounds on the components of x after j iterations of the loop:\n\ * M(j) = bound on x[1:j]\n\ * G(j) = bound on x[j+1:n]\n\ * Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n\ *\n\ * Then for iteration j+1 we have\n\ * M(j+1) <= G(j) / | A(j+1,j+1) |\n\ * G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n\ * <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n\ *\n\ * where CNORM(j+1) is greater than or equal to the infinity-norm of\n\ * column j+1 of A, not counting the diagonal. Hence\n\ *\n\ * G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n\ * 1<=i<=j\n\ * and\n\ *\n\ * |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n\ * 1<=i< j\n\ *\n\ * Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTRSV if the\n\ * reciprocal of the largest M(j), j=1,..,n, is larger than\n\ * max(underflow, 1/overflow).\n\ *\n\ * The bound on x(j) is also used to determine when a step in the\n\ * columnwise method can be performed without fear of overflow. If\n\ * the computed bound is greater than a large constant, x is scaled to\n\ * prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n\ * 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n\ *\n\ * Similarly, a row-wise scheme is used to solve A**T *x = b or\n\ * A**H *x = b. The basic algorithm for A upper triangular is\n\ *\n\ * for j = 1, ..., n\n\ * x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n\ * end\n\ *\n\ * We simultaneously compute two bounds\n\ * G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n\ * M(j) = bound on x(i), 1<=i<=j\n\ *\n\ * The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n\ * add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n\ * Then the bound on x(j) is\n\ *\n\ * M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n\ *\n\ * <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n\ * 1<=i<=j\n\ *\n\ * and we can safely call ZTRSV if 1/M(n) and 1/G(n) are both greater\n\ * than max(underflow, 1/overflow).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgbsv0000644000175000017500000001146112502223525016316 0ustar uwabamiuwabami--- :name: cgbsv :md5sum: be2a69ee36b53e7064810d3a8ed3d66f :category: :subroutine :arguments: - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGBSV computes the solution to a complex system of linear equations\n\ * A * X = B, where A is a band matrix of order N with KL subdiagonals\n\ * and KU superdiagonals, and X and B are N-by-NRHS matrices.\n\ *\n\ * The LU decomposition with partial pivoting and row interchanges is\n\ * used to factor A as A = L * U, where L is a product of permutation\n\ * and unit lower triangular matrices with KL subdiagonals, and U is\n\ * upper triangular with KL+KU superdiagonals. The factored form of A\n\ * is then used to solve the system of equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AB (input/output) COMPLEX array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows KL+1 to\n\ * 2*KL+KU+1; rows 1 to KL of the array need not be set.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)\n\ * On exit, details of the factorization: U is stored as an\n\ * upper triangular band matrix with KL+KU superdiagonals in\n\ * rows 1 to KL+KU+1, and the multipliers used during the\n\ * factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n\ * See below for further details.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * The pivot indices that define the permutation matrix P;\n\ * row i of the matrix was interchanged with row IPIV(i).\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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, U(i,i) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, and the solution has not been computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * M = N = 6, KL = 2, KU = 1:\n\ *\n\ * On entry: On exit:\n\ *\n\ * * * * + + + * * * u14 u25 u36\n\ * * * + + + + * * u13 u24 u35 u46\n\ * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n\ * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n\ * a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n\ * a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n\ *\n\ * Array elements marked * are not used by the routine; elements marked\n\ * + need not be set on entry, but are required by the routine to store\n\ * elements of U because of fill-in resulting from the row interchanges.\n\ *\n\ * =====================================================================\n\ *\n\ * .. External Subroutines ..\n EXTERNAL CGBTRF, CGBTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cgeqlf0000644000175000017500000000744612502223525016463 0ustar uwabamiuwabami--- :name: cgeqlf :md5sum: aa37cd9c6d3b8da0b377cd981fb69997 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - MIN(m,n) - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGEQLF computes a QL factorization of a complex M-by-N matrix A:\n\ * A = Q * L.\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) COMPLEX array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit,\n\ * if m >= n, the lower triangle of the subarray\n\ * A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L;\n\ * if m <= n, the elements on and below the (n-m)-th\n\ * superdiagonal contain the M-by-N lower trapezoidal matrix L;\n\ * the remaining elements, with the array TAU, represent the\n\ * unitary matrix Q as a product of elementary reflectors\n\ * (see Further Details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (output) COMPLEX array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace/output) COMPLEX 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,N).\n\ * For optimum performance LWORK >= N*NB, where NB is\n\ * the 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 complex scalar, and v is a complex vector with\n\ * v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n\ * A(1:m-k+i-1,n-k+i), and tau in TAU(i).\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n $ MU, NB, NBMIN, NU, NX\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CGEQL2, CLARFB, CLARFT, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlaln20000644000175000017500000001452312502223526016371 0ustar uwabamiuwabami--- :name: dlaln2 :md5sum: 029cdd6fe89ae0077f078ad1c1d1da86 :category: :subroutine :arguments: - ltrans: :type: logical :intent: input - na: :type: integer :intent: input - nw: :type: integer :intent: input - smin: :type: doublereal :intent: input - ca: :type: doublereal :intent: input - a: :type: doublereal :intent: input :dims: - lda - na - lda: :type: integer :intent: input - d1: :type: doublereal :intent: input - d2: :type: doublereal :intent: input - b: :type: doublereal :intent: input :dims: - ldb - nw - ldb: :type: integer :intent: input - wr: :type: doublereal :intent: input - wi: :type: doublereal :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nw - ldx: :type: integer :intent: input - scale: :type: doublereal :intent: output - xnorm: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: ldx: na :fortran_help: " SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, LDB, WR, WI, X, LDX, SCALE, XNORM, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLALN2 solves a system of the form (ca A - w D ) X = s B\n\ * or (ca A' - w D) X = s B with possible scaling (\"s\") and\n\ * perturbation of A. (A' means A-transpose.)\n\ *\n\ * A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA\n\ * real diagonal matrix, w is a real or complex value, and X and B are\n\ * NA x 1 matrices -- real if w is real, complex if w is complex. NA\n\ * may be 1 or 2.\n\ *\n\ * If w is complex, X and B are represented as NA x 2 matrices,\n\ * the first column of each being the real part and the second\n\ * being the imaginary part.\n\ *\n\ * \"s\" is a scaling factor (.LE. 1), computed by DLALN2, which is\n\ * so chosen that X can be computed without overflow. X is further\n\ * scaled if necessary to assure that norm(ca A - w D)*norm(X) is less\n\ * than overflow.\n\ *\n\ * If both singular values of (ca A - w D) are less than SMIN,\n\ * SMIN*identity will be used instead of (ca A - w D). If only one\n\ * singular value is less than SMIN, one element of (ca A - w D) will be\n\ * perturbed enough to make the smallest singular value roughly SMIN.\n\ * If both singular values are at least SMIN, (ca A - w D) will not be\n\ * perturbed. In any case, the perturbation will be at most some small\n\ * multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values\n\ * are computed by infinity-norm approximations, and thus will only be\n\ * correct to a factor of 2 or so.\n\ *\n\ * Note: all input quantities are assumed to be smaller than overflow\n\ * by a reasonable factor. (See BIGNUM.)\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * LTRANS (input) LOGICAL\n\ * =.TRUE.: A-transpose will be used.\n\ * =.FALSE.: A will be used (not transposed.)\n\ *\n\ * NA (input) INTEGER\n\ * The size of the matrix A. It may (only) be 1 or 2.\n\ *\n\ * NW (input) INTEGER\n\ * 1 if \"w\" is real, 2 if \"w\" is complex. It may only be 1\n\ * or 2.\n\ *\n\ * SMIN (input) DOUBLE PRECISION\n\ * The desired lower bound on the singular values of A. This\n\ * should be a safe distance away from underflow or overflow,\n\ * say, between (underflow/machine precision) and (machine\n\ * precision * overflow ). (See BIGNUM and ULP.)\n\ *\n\ * CA (input) DOUBLE PRECISION\n\ * The coefficient c, which A is multiplied by.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,NA)\n\ * The NA x NA matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of A. It must be at least NA.\n\ *\n\ * D1 (input) DOUBLE PRECISION\n\ * The 1,1 element in the diagonal matrix D.\n\ *\n\ * D2 (input) DOUBLE PRECISION\n\ * The 2,2 element in the diagonal matrix D. Not used if NW=1.\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,NW)\n\ * The NA x NW matrix B (right-hand side). If NW=2 (\"w\" is\n\ * complex), column 1 contains the real part of B and column 2\n\ * contains the imaginary part.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B. It must be at least NA.\n\ *\n\ * WR (input) DOUBLE PRECISION\n\ * The real part of the scalar \"w\".\n\ *\n\ * WI (input) DOUBLE PRECISION\n\ * The imaginary part of the scalar \"w\". Not used if NW=1.\n\ *\n\ * X (output) DOUBLE PRECISION array, dimension (LDX,NW)\n\ * The NA x NW matrix X (unknowns), as computed by DLALN2.\n\ * If NW=2 (\"w\" is complex), on exit, column 1 will contain\n\ * the real part of X and column 2 will contain the imaginary\n\ * part.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of X. It must be at least NA.\n\ *\n\ * SCALE (output) DOUBLE PRECISION\n\ * The scale factor that B must be multiplied by to insure\n\ * that overflow does not occur when computing X. Thus,\n\ * (ca A - w D) X will be SCALE*B, not B (ignoring\n\ * perturbations of A.) It will be at most 1.\n\ *\n\ * XNORM (output) DOUBLE PRECISION\n\ * The infinity-norm of X, when X is regarded as an NA x NW\n\ * real matrix.\n\ *\n\ * INFO (output) INTEGER\n\ * An error flag. It will be set to zero if no error occurs,\n\ * a negative number if an argument is in error, or a positive\n\ * number if ca A - w D had to be perturbed.\n\ * The possible values are:\n\ * = 0: No error occurred, and (ca A - w D) did not have to be\n\ * perturbed.\n\ * = 1: (ca A - w D) had to be perturbed to make its smallest\n\ * (or only) singular value greater than SMIN.\n\ * NOTE: In the interests of speed, this routine does not\n\ * check the inputs for errors.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zunmqr0000644000175000017500000001054212502223526016546 0ustar uwabamiuwabami--- :name: zunmqr :md5sum: 03aa2db16b2f96e7e6935ea901f2b1aa :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZUNMQR overwrites the general complex M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'C': Q**H * C C * Q**H\n\ *\n\ * where Q is a complex unitary matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by ZGEQRF. Q is of order M if SIDE = 'L' and of order N\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**H from the Left;\n\ * = 'R': apply Q or Q**H from the Right.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q;\n\ * = 'C': Conjugate transpose, apply Q**H.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,K)\n\ * The i-th column must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * ZGEQRF in the first k columns of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ * If SIDE = 'L', LDA >= max(1,M);\n\ * if SIDE = 'R', LDA >= max(1,N).\n\ *\n\ * TAU (input) COMPLEX*16 array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by ZGEQRF.\n\ *\n\ * C (input/output) COMPLEX*16 array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M).\n\ * For optimum performance LWORK >= N*NB if SIDE = 'L', and\n\ * LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n\ * 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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clascl0000644000175000017500000000632612502223525016457 0ustar uwabamiuwabami--- :name: clascl :md5sum: fce65101e2bd6b47b1be23e27767bac2 :category: :subroutine :arguments: - type: :type: char :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - cfrom: :type: real :intent: input - cto: :type: real :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLASCL multiplies the M by N complex matrix A by the real scalar\n\ * CTO/CFROM. This is done without over/underflow as long as the final\n\ * result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that\n\ * A may be full, upper triangular, lower triangular, upper Hessenberg,\n\ * or banded.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TYPE (input) CHARACTER*1\n\ * TYPE indices the storage type of the input matrix.\n\ * = 'G': A is a full matrix.\n\ * = 'L': A is a lower triangular matrix.\n\ * = 'U': A is an upper triangular matrix.\n\ * = 'H': A is an upper Hessenberg matrix.\n\ * = 'B': A is a symmetric band matrix with lower bandwidth KL\n\ * and upper bandwidth KU and with the only the lower\n\ * half stored.\n\ * = 'Q': A is a symmetric band matrix with lower bandwidth KL\n\ * and upper bandwidth KU and with the only the upper\n\ * half stored.\n\ * = 'Z': A is a band matrix with lower bandwidth KL and upper\n\ * bandwidth KU. See CGBTRF for storage details.\n\ *\n\ * KL (input) INTEGER\n\ * The lower bandwidth of A. Referenced only if TYPE = 'B',\n\ * 'Q' or 'Z'.\n\ *\n\ * KU (input) INTEGER\n\ * The upper bandwidth of A. Referenced only if TYPE = 'B',\n\ * 'Q' or 'Z'.\n\ *\n\ * CFROM (input) REAL\n\ * CTO (input) REAL\n\ * The matrix A is multiplied by CTO/CFROM. A(I,J) is computed\n\ * without over/underflow if the final result CTO*A(I,J)/CFROM\n\ * can be represented without over/underflow. CFROM must be\n\ * nonzero.\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) COMPLEX array, dimension (LDA,N)\n\ * The matrix to be multiplied by CTO/CFROM. See TYPE for the\n\ * storage type.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/crot0000644000175000017500000000367312502223525016167 0ustar uwabamiuwabami--- :name: crot :md5sum: 5c7ea320d6a9412ddf95fc7a6f674517 :category: :subroutine :arguments: - n: :type: integer :intent: input - cx: :type: complex :intent: input/output :dims: - n - incx: :type: integer :intent: input - cy: :type: complex :intent: input/output :dims: - n - incy: :type: integer :intent: input - c: :type: real :intent: input - s: :type: complex :intent: input :substitutions: {} :fortran_help: " SUBROUTINE CROT( N, CX, INCX, CY, INCY, C, S )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CROT applies a plane rotation, where the cos (C) is real and the\n\ * sin (S) is complex, and the vectors CX and CY are complex.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of elements in the vectors CX and CY.\n\ *\n\ * CX (input/output) COMPLEX array, dimension (N)\n\ * On input, the vector X.\n\ * On output, CX is overwritten with C*X + S*Y.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between successive values of CY. INCX <> 0.\n\ *\n\ * CY (input/output) COMPLEX array, dimension (N)\n\ * On input, the vector Y.\n\ * On output, CY is overwritten with -CONJG(S)*X + C*Y.\n\ *\n\ * INCY (input) INTEGER\n\ * The increment between successive values of CY. INCX <> 0.\n\ *\n\ * C (input) REAL\n\ * S (input) COMPLEX\n\ * C and S define a rotation\n\ * [ C S ]\n\ * [ -conjg(S) C ]\n\ * where C*C + S*CONJG(S) = 1.0.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, IX, IY\n COMPLEX STEMP\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC CONJG\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cgtcon0000644000175000017500000000636612502223525016477 0ustar uwabamiuwabami--- :name: cgtcon :md5sum: e46b7760f66cc206300c78aed26370b3 :category: :subroutine :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - dl: :type: complex :intent: input :dims: - n-1 - d: :type: complex :intent: input :dims: - n - du: :type: complex :intent: input :dims: - n-1 - du2: :type: complex :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: complex :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGTCON estimates the reciprocal of the condition number of a complex\n\ * tridiagonal matrix A using the LU factorization as computed by\n\ * CGTTRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies whether the 1-norm condition number or the\n\ * infinity-norm condition number is required:\n\ * = '1' or 'O': 1-norm;\n\ * = 'I': Infinity-norm.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * DL (input) COMPLEX array, dimension (N-1)\n\ * The (n-1) multipliers that define the matrix L from the\n\ * LU factorization of A as computed by CGTTRF.\n\ *\n\ * D (input) COMPLEX array, dimension (N)\n\ * The n diagonal elements of the upper triangular matrix U from\n\ * the LU factorization of A.\n\ *\n\ * DU (input) COMPLEX array, dimension (N-1)\n\ * The (n-1) elements of the first superdiagonal of U.\n\ *\n\ * DU2 (input) COMPLEX array, dimension (N-2)\n\ * The (n-2) elements of the second superdiagonal of U.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices; for 1 <= i <= n, row i of the matrix was\n\ * interchanged with row IPIV(i). IPIV(i) will always be either\n\ * i or i+1; IPIV(i) = i indicates a row interchange was not\n\ * required.\n\ *\n\ * ANORM (input) REAL\n\ * If NORM = '1' or 'O', the 1-norm of the original matrix A.\n\ * If NORM = 'I', the infinity-norm of the original matrix A.\n\ *\n\ * RCOND (output) REAL\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n\ * estimate of the 1-norm of inv(A) computed in this routine.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clanht0000644000175000017500000000400012502223525016452 0ustar uwabamiuwabami--- :name: clanht :md5sum: c658a5158529cfe7a4c7c521584dcd71 :category: :function :type: real :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: complex :intent: input :dims: - n-1 :substitutions: {} :fortran_help: " REAL FUNCTION CLANHT( NORM, N, D, E )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLANHT returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * complex Hermitian tridiagonal matrix A.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * CLANHT returns the value\n\ *\n\ * CLANHT = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in CLANHT as described\n\ * above.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, CLANHT is\n\ * set to zero.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The diagonal elements of A.\n\ *\n\ * E (input) COMPLEX array, dimension (N-1)\n\ * The (n-1) sub-diagonal or super-diagonal elements of A.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/spbtf20000644000175000017500000000710412502223526016412 0ustar uwabamiuwabami--- :name: spbtf2 :md5sum: 60a9f976698f8a9e6d64eb1bc045f8d4 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPBTF2( UPLO, N, KD, AB, LDAB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPBTF2 computes the Cholesky factorization of a real symmetric\n\ * positive definite band matrix A.\n\ *\n\ * The factorization has the form\n\ * A = U' * U , if UPLO = 'U', or\n\ * A = L * L', if UPLO = 'L',\n\ * where U is an upper triangular matrix, U' is the transpose of U, and\n\ * L is lower triangular.\n\ *\n\ * This is the unblocked version of the algorithm, calling Level 2 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of super-diagonals of the matrix A if UPLO = 'U',\n\ * or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) REAL array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * On exit, if INFO = 0, the triangular factor U or L from the\n\ * Cholesky factorization A = U'*U or A = L*L' of the band\n\ * matrix A, in the same storage format as A.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ * > 0: if INFO = k, the leading minor of order k is not\n\ * positive definite, and the factorization could not be\n\ * completed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * N = 6, KD = 2, and UPLO = 'U':\n\ *\n\ * On entry: On exit:\n\ *\n\ * * * a13 a24 a35 a46 * * u13 u24 u35 u46\n\ * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n\ * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n\ *\n\ * Similarly, if UPLO = 'L' the format of A is as follows:\n\ *\n\ * On entry: On exit:\n\ *\n\ * a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n\ * a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n\ * a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n\ *\n\ * Array elements marked * are not used by the routine.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dla_gbrcond0000644000175000017500000001123712502223526017452 0ustar uwabamiuwabami--- :name: dla_gbrcond :md5sum: 166b58ae6ab01504cac311045c0152cb :category: :function :type: doublereal :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublereal :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - cmode: :type: integer :intent: input - c: :type: doublereal :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: doublereal :intent: input :dims: - 5*n - iwork: :type: integer :intent: input :dims: - n :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION DLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, AFB, LDAFB, IPIV, CMODE, C, INFO, WORK, IWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLA_GBRCOND Estimates the Skeel condition number of op(A) * op2(C)\n\ * where op2 is determined by CMODE as follows\n\ * CMODE = 1 op2(C) = C\n\ * CMODE = 0 op2(C) = I\n\ * CMODE = -1 op2(C) = inv(C)\n\ * The Skeel condition number cond(A) = norminf( |inv(A)||A| )\n\ * is computed by computing scaling factors R such that\n\ * diag(R)*A*op2(C) is row equilibrated and computing the standard\n\ * infinity-norm condition number.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate Transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n\ * Details of the LU factorization of the band matrix A, as\n\ * computed by DGBTRF. U is stored as an upper triangular\n\ * band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n\ * and the multipliers used during the factorization are stored\n\ * in rows KL+KU+2 to 2*KL+KU+1.\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from the factorization A = P*L*U\n\ * as computed by DGBTRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * CMODE (input) INTEGER\n\ * Determines op2(C) in the formula op(A) * op2(C) as follows:\n\ * CMODE = 1 op2(C) = C\n\ * CMODE = 0 op2(C) = I\n\ * CMODE = -1 op2(C) = inv(C)\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension (N)\n\ * The vector C in the formula op(A) * op2(C).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * i > 0: The ith argument is invalid.\n\ *\n\ * WORK (input) DOUBLE PRECISION array, dimension (5*N).\n\ * Workspace.\n\ *\n\ * IWORK (input) INTEGER array, dimension (N).\n\ * Workspace.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE, I, J, KD, KE\n DOUBLE PRECISION AINVNM, TMP\n\ * ..\n\ * .. Local Arrays ..\n INTEGER ISAVE( 3 )\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DLACN2, DGBTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dstegr0000644000175000017500000002076612502223526016513 0ustar uwabamiuwabami--- :name: dstegr :md5sum: 5393f044bbbc7b15c9c7280098a07f35 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 18*n : lsame_(&jobz,\"N\") ? 12*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 10*n : lsame_(&jobz,\"N\") ? 8*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " SUBROUTINE DSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSTEGR computes selected eigenvalues and, optionally, eigenvectors\n\ * of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n\ * a well defined set of pairwise different real eigenvalues, the corresponding\n\ * real eigenvectors are pairwise orthogonal.\n\ *\n\ * The spectrum may be computed either completely or partially by specifying\n\ * either an interval (VL,VU] or a range of indices IL:IU for the desired\n\ * eigenvalues.\n\ *\n\ * DSTEGR is a compatability wrapper around the improved DSTEMR routine.\n\ * See DSTEMR for further details.\n\ *\n\ * One important change is that the ABSTOL parameter no longer provides any\n\ * benefit and hence is no longer used.\n\ *\n\ * Note : DSTEGR and DSTEMR work only on machines which follow\n\ * IEEE-754 floating-point standard in their handling of infinities and\n\ * NaNs. Normal execution may create these exceptiona values and hence\n\ * may abort due to a floating point exception in environments which\n\ * do not conform to the IEEE-754 standard.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found.\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found.\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the N diagonal elements of the tridiagonal matrix\n\ * T. On exit, D is overwritten.\n\ *\n\ * E (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the (N-1) subdiagonal elements of the tridiagonal\n\ * matrix T in elements 1 to N-1 of E. E(N) need not be set on\n\ * input, but is used internally as workspace.\n\ * On exit, E is overwritten.\n\ *\n\ * VL (input) DOUBLE PRECISION\n\ * VU (input) DOUBLE PRECISION\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) DOUBLE PRECISION\n\ * Unused. Was the absolute error tolerance for the\n\ * eigenvalues/eigenvectors in previous versions.\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * The first M elements contain the selected eigenvalues in\n\ * ascending order.\n\ *\n\ * Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )\n\ * If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix T\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ * Supplying N columns is always safe.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', then LDZ >= max(1,N).\n\ *\n\ * ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n\ * The support of the eigenvectors in Z, i.e., the indices\n\ * indicating the nonzero elements in Z. The i-th computed eigenvector\n\ * is nonzero only in elements ISUPPZ( 2*i-1 ) through\n\ * ISUPPZ( 2*i ). This is relevant in the case when the matrix\n\ * is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n\ *\n\ * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)\n\ * On exit, if INFO = 0, WORK(1) returns the optimal\n\ * (and minimal) LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK >= max(1,18*N)\n\ * if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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\ * IWORK (workspace/output) INTEGER array, dimension (LIWORK)\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK. LIWORK >= max(1,10*N)\n\ * if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n\ * if only the eigenvalues are to be computed.\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal size of the IWORK array,\n\ * returns this value as the first entry of the IWORK array, and\n\ * no error message related to LIWORK is issued by XERBLA.\n\ *\n\ * INFO (output) INTEGER\n\ * On exit, INFO\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: if INFO = 1X, internal error in DLARRE,\n\ * if INFO = 2X, internal error in DLARRV.\n\ * Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n\ * the nonzero error code returned by DLARRE or\n\ * DLARRV, respectively.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Inderjit Dhillon, IBM Almaden, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, LBNL/NERSC, USA\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL TRYRAC\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DSTEMR\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dsytd20000644000175000017500000001163512502223526016427 0ustar uwabamiuwabami--- :name: dsytd2 :md5sum: a634adbb262ee2d31d6afea919b42fed :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - n - e: :type: doublereal :intent: output :dims: - n-1 - tau: :type: doublereal :intent: output :dims: - n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal\n\ * form T by an orthogonal similarity transformation: Q' * A * Q = T.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * n-by-n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n-by-n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ * On exit, if UPLO = 'U', the diagonal and first superdiagonal\n\ * of A are overwritten by the corresponding elements of the\n\ * tridiagonal matrix T, and the elements above the first\n\ * superdiagonal, with the array TAU, represent the orthogonal\n\ * matrix Q as a product of elementary reflectors; if UPLO\n\ * = 'L', the diagonal and first subdiagonal of A are over-\n\ * written by the corresponding elements of the tridiagonal\n\ * matrix T, and the elements below the first subdiagonal, with\n\ * the array TAU, represent the orthogonal matrix Q as a product\n\ * of elementary reflectors. See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * D (output) DOUBLE PRECISION array, dimension (N)\n\ * The diagonal elements of the tridiagonal matrix T:\n\ * D(i) = A(i,i).\n\ *\n\ * E (output) DOUBLE PRECISION array, dimension (N-1)\n\ * The off-diagonal elements of the tridiagonal matrix T:\n\ * E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n\ *\n\ * TAU (output) DOUBLE PRECISION array, dimension (N-1)\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\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\ * If UPLO = 'U', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(n-1) . . . H(2) H(1).\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(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n\ * A(1:i-1,i+1), and tau in TAU(i).\n\ *\n\ * If UPLO = 'L', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(n-1).\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) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n\ * and tau in TAU(i).\n\ *\n\ * The contents of A on exit are illustrated by the following examples\n\ * with n = 5:\n\ *\n\ * if UPLO = 'U': if UPLO = 'L':\n\ *\n\ * ( d e v2 v3 v4 ) ( d )\n\ * ( d e v3 v4 ) ( e d )\n\ * ( d e v4 ) ( v1 e d )\n\ * ( d e ) ( v1 v2 e d )\n\ * ( d ) ( v1 v2 v3 e d )\n\ *\n\ * where d and e denote diagonal and off-diagonal elements of T, and vi\n\ * denotes an element of the vector defining H(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssyswapr0000644000175000017500000000433412502223526017107 0ustar uwabamiuwabami--- :name: ssyswapr :md5sum: 8d75fd067b15a4894a7b7b15f0c13b2d :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - i1: :type: integer :intent: input - i2: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE SSYSWAPR( UPLO, N, A, I1, I2)\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSYSWAPR applies an elementary permutation on the rows and the columns of\n\ * a symmetric matrix.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the NB diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L as computed by SSYTRF.\n\ *\n\ * On exit, if INFO = 0, the (symmetric) inverse of the original\n\ * matrix. If UPLO = 'U', the upper triangular part of the\n\ * inverse is formed and the part of A below the diagonal is not\n\ * referenced; if UPLO = 'L' the lower triangular part of the\n\ * inverse is formed and the part of A above the diagonal is\n\ * not referenced.\n\ *\n\ * I1 (input) INTEGER\n\ * Index of the first row to swap\n\ *\n\ * I2 (input) INTEGER\n\ * Index of the second row to swap\n\ *\n\n\ * =====================================================================\n\ *\n\ * ..\n\ * .. Local Scalars ..\n LOGICAL UPPER\n INTEGER I\n REAL TMP\n\ *\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SSWAP\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zlauum0000644000175000017500000000414312502223526016527 0ustar uwabamiuwabami--- :name: zlauum :md5sum: 9baf610b7968d0f2dca16da19ee72436 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZLAUUM( UPLO, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAUUM computes the product U * U' or L' * L, where the triangular\n\ * factor U or L is stored in the upper or lower triangular part of\n\ * the array A.\n\ *\n\ * If UPLO = 'U' or 'u' then the upper triangle of the result is stored,\n\ * overwriting the factor U in A.\n\ * If UPLO = 'L' or 'l' then the lower triangle of the result is stored,\n\ * overwriting the factor L in A.\n\ *\n\ * This is the blocked form of the algorithm, calling Level 3 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the triangular factor stored in the array A\n\ * is upper or lower triangular:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the triangular factor U or L. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the triangular factor U or L.\n\ * On exit, if UPLO = 'U', the upper triangle of A is\n\ * overwritten with the upper triangle of the product U * U';\n\ * if UPLO = 'L', the lower triangle of A is overwritten with\n\ * the lower triangle of the product L' * L.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zla_syamv0000644000175000017500000001122212502223526017213 0ustar uwabamiuwabami--- :name: zla_syamv :md5sum: 041a90dddeca6e2506af8fce8e2257a1 :category: :subroutine :arguments: - uplo: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: doublereal :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: doublecomplex :intent: input :dims: - 1+(n-1)*abs(incx) - incx: :type: integer :intent: input - beta: :type: doublereal :intent: input - y: :type: doublereal :intent: input/output :dims: - 1 + ( n - 1 )*abs( incy ) - incy: :type: integer :intent: input :substitutions: lda: MAX(1, n) :fortran_help: " SUBROUTINE ZLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLA_SYAMV performs the matrix-vector operation\n\ *\n\ * y := alpha*abs(A)*abs(x) + beta*abs(y),\n\ *\n\ * where alpha and beta are scalars, x and y are vectors and A is an\n\ * n by n symmetric matrix.\n\ *\n\ * This function is primarily used in calculating error bounds.\n\ * To protect against underflow during evaluation, components in\n\ * the resulting vector are perturbed away from zero by (N+1)\n\ * times the underflow threshold. To prevent unnecessarily large\n\ * errors for block-structure embedded in general matrices,\n\ * \"symbolically\" zero components are not perturbed. A zero\n\ * entry is considered \"symbolic\" if all multiplications involved\n\ * in computing that entry have at least one zero multiplicand.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * UPLO (input) INTEGER\n\ * On entry, UPLO specifies whether the upper or lower\n\ * triangular part of the array A is to be referenced as\n\ * follows:\n\ *\n\ * UPLO = BLAS_UPPER Only the upper triangular part of A\n\ * is to be referenced.\n\ *\n\ * UPLO = BLAS_LOWER Only the lower triangular part of A\n\ * is to be referenced.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the number of columns of the matrix A.\n\ * N must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * ALPHA - DOUBLE PRECISION .\n\ * On entry, ALPHA specifies the scalar alpha.\n\ * Unchanged on exit.\n\ *\n\ * A - COMPLEX*16 array of DIMENSION ( LDA, n ).\n\ * Before entry, the leading m by n part of the array A must\n\ * contain the matrix of coefficients.\n\ * Unchanged on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * On entry, LDA specifies the first dimension of A as declared\n\ * in the calling (sub) program. LDA must be at least\n\ * max( 1, n ).\n\ * Unchanged on exit.\n\ *\n\ * X - COMPLEX*16 array of DIMENSION at least\n\ * ( 1 + ( n - 1 )*abs( INCX ) )\n\ * Before entry, the incremented array X must contain the\n\ * vector x.\n\ * Unchanged on exit.\n\ *\n\ * INCX (input) INTEGER\n\ * On entry, INCX specifies the increment for the elements of\n\ * X. INCX must not be zero.\n\ * Unchanged on exit.\n\ *\n\ * BETA - DOUBLE PRECISION .\n\ * On entry, BETA specifies the scalar beta. When BETA is\n\ * supplied as zero then Y need not be set on input.\n\ * Unchanged on exit.\n\ *\n\ * Y (input/output) DOUBLE PRECISION array, dimension\n\ * ( 1 + ( n - 1 )*abs( INCY ) )\n\ * Before entry with BETA non-zero, the incremented array Y\n\ * must contain the vector y. On exit, Y is overwritten by the\n\ * updated vector y.\n\ *\n\ * INCY (input) INTEGER\n\ * On entry, INCY specifies the increment for the elements of\n\ * Y. INCY must not be zero.\n\ * Unchanged on exit.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Level 2 Blas routine.\n\ *\n\ * -- Written on 22-October-1986.\n\ * Jack Dongarra, Argonne National Lab.\n\ * Jeremy Du Croz, Nag Central Office.\n\ * Sven Hammarling, Nag Central Office.\n\ * Richard Hanson, Sandia National Labs.\n\ * -- Modified for the absolute-value product, April 2006\n\ * Jason Riedy, UC Berkeley\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgtrfs0000644000175000017500000001311312502223526016526 0ustar uwabamiuwabami--- :name: zgtrfs :md5sum: 8d4d4d8d907eb8ca2c144546d27fcda8 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: doublecomplex :intent: input :dims: - n-1 - d: :type: doublecomplex :intent: input :dims: - n - du: :type: doublecomplex :intent: input :dims: - n-1 - dlf: :type: doublecomplex :intent: input :dims: - n-1 - df: :type: doublecomplex :intent: input :dims: - n - duf: :type: doublecomplex :intent: input :dims: - n-1 - du2: :type: doublecomplex :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGTRFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is tridiagonal, and provides\n\ * error bounds and backward error estimates for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * DL (input) COMPLEX*16 array, dimension (N-1)\n\ * The (n-1) subdiagonal elements of A.\n\ *\n\ * D (input) COMPLEX*16 array, dimension (N)\n\ * The diagonal elements of A.\n\ *\n\ * DU (input) COMPLEX*16 array, dimension (N-1)\n\ * The (n-1) superdiagonal elements of A.\n\ *\n\ * DLF (input) COMPLEX*16 array, dimension (N-1)\n\ * The (n-1) multipliers that define the matrix L from the\n\ * LU factorization of A as computed by ZGTTRF.\n\ *\n\ * DF (input) COMPLEX*16 array, dimension (N)\n\ * The n diagonal elements of the upper triangular matrix U from\n\ * the LU factorization of A.\n\ *\n\ * DUF (input) COMPLEX*16 array, dimension (N-1)\n\ * The (n-1) elements of the first superdiagonal of U.\n\ *\n\ * DU2 (input) COMPLEX*16 array, dimension (N-2)\n\ * The (n-2) elements of the second superdiagonal of U.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices; for 1 <= i <= n, row i of the matrix was\n\ * interchanged with row IPIV(i). IPIV(i) will always be either\n\ * i or i+1; IPIV(i) = i indicates a row interchange was not\n\ * required.\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by ZGTTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ztrtrs0000644000175000017500000000652212502223526016565 0ustar uwabamiuwabami--- :name: ztrtrs :md5sum: 8c053191eeb4d8f06ee6f6547433d23e :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTRTRS solves a triangular system of the form\n\ *\n\ * A * X = B, A**T * X = B, or A**H * X = B,\n\ *\n\ * where A is a triangular matrix of order N, and B is an N-by-NRHS\n\ * matrix. A check is made to verify that A is nonsingular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The triangular matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of the array A contains the upper\n\ * triangular matrix, and the strictly lower triangular part of\n\ * A is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of the array A contains the lower triangular\n\ * matrix, and the strictly upper triangular part of A is not\n\ * referenced. If DIAG = 'U', the diagonal elements of A are\n\ * also not referenced and are assumed to be 1.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, if INFO = 0, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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 A is zero,\n\ * indicating that the matrix is singular and the solutions\n\ * X have not been computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clar2v0000644000175000017500000000515412502223525016405 0ustar uwabamiuwabami--- :name: clar2v :md5sum: 7ed20259419e6c0e94185c5273a1f5b6 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - 1+(n-1)*incx - y: :type: complex :intent: input/output :dims: - 1+(n-1)*incx - z: :type: complex :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - c: :type: real :intent: input :dims: - 1+(n-1)*incc - s: :type: complex :intent: input :dims: - 1+(n-1)*incc - incc: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE CLAR2V( N, X, Y, Z, INCX, C, S, INCC )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAR2V applies a vector of complex plane rotations with real cosines\n\ * from both sides to a sequence of 2-by-2 complex Hermitian matrices,\n\ * defined by the elements of the vectors x, y and z. For i = 1,2,...,n\n\ *\n\ * ( x(i) z(i) ) :=\n\ * ( conjg(z(i)) y(i) )\n\ *\n\ * ( c(i) conjg(s(i)) ) ( x(i) z(i) ) ( c(i) -conjg(s(i)) )\n\ * ( -s(i) c(i) ) ( conjg(z(i)) y(i) ) ( s(i) c(i) )\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of plane rotations to be applied.\n\ *\n\ * X (input/output) COMPLEX array, dimension (1+(N-1)*INCX)\n\ * The vector x; the elements of x are assumed to be real.\n\ *\n\ * Y (input/output) COMPLEX array, dimension (1+(N-1)*INCX)\n\ * The vector y; the elements of y are assumed to be real.\n\ *\n\ * Z (input/output) COMPLEX array, dimension (1+(N-1)*INCX)\n\ * The vector z.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between elements of X, Y and Z. INCX > 0.\n\ *\n\ * C (input) REAL array, dimension (1+(N-1)*INCC)\n\ * The cosines of the plane rotations.\n\ *\n\ * S (input) COMPLEX array, dimension (1+(N-1)*INCC)\n\ * The sines of the plane rotations.\n\ *\n\ * INCC (input) INTEGER\n\ * The increment between elements of C and S. INCC > 0.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, IC, IX\n REAL CI, SII, SIR, T1I, T1R, T5, T6, XI, YI, ZII,\n $ ZIR\n COMPLEX SI, T2, T3, T4, ZI\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC AIMAG, CMPLX, CONJG, REAL\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlasq60000644000175000017500000000452512502223526016410 0ustar uwabamiuwabami--- :name: dlasq6 :md5sum: 51937f03f827ecc2ba8f5b8564d50417 :category: :subroutine :arguments: - i0: :type: integer :intent: input - n0: :type: integer :intent: input - z: :type: doublereal :intent: input :dims: - 4*n0 - pp: :type: integer :intent: input - dmin: :type: doublereal :intent: output - dmin1: :type: doublereal :intent: output - dmin2: :type: doublereal :intent: output - dn: :type: doublereal :intent: output - dnm1: :type: doublereal :intent: output - dnm2: :type: doublereal :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DNM1, DNM2 )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLASQ6 computes one dqd (shift equal to zero) transform in\n\ * ping-pong form, with protection against underflow and overflow.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * I0 (input) INTEGER\n\ * First index.\n\ *\n\ * N0 (input) INTEGER\n\ * Last index.\n\ *\n\ * Z (input) DOUBLE PRECISION array, dimension ( 4*N )\n\ * Z holds the qd array. EMIN is stored in Z(4*N0) to avoid\n\ * an extra argument.\n\ *\n\ * PP (input) INTEGER\n\ * PP=0 for ping, PP=1 for pong.\n\ *\n\ * DMIN (output) DOUBLE PRECISION\n\ * Minimum value of d.\n\ *\n\ * DMIN1 (output) DOUBLE PRECISION\n\ * Minimum value of d, excluding D( N0 ).\n\ *\n\ * DMIN2 (output) DOUBLE PRECISION\n\ * Minimum value of d, excluding D( N0 ) and D( N0-1 ).\n\ *\n\ * DN (output) DOUBLE PRECISION\n\ * d(N0), the last value of d.\n\ *\n\ * DNM1 (output) DOUBLE PRECISION\n\ * d(N0-1).\n\ *\n\ * DNM2 (output) DOUBLE PRECISION\n\ * d(N0-2).\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Parameter ..\n DOUBLE PRECISION ZERO\n PARAMETER ( ZERO = 0.0D0 )\n\ * ..\n\ * .. Local Scalars ..\n INTEGER J4, J4P2\n DOUBLE PRECISION D, EMIN, SAFMIN, TEMP\n\ * ..\n\ * .. External Function ..\n DOUBLE PRECISION DLAMCH\n EXTERNAL DLAMCH\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/clarnv0000644000175000017500000000371012502223525016475 0ustar uwabamiuwabami--- :name: clarnv :md5sum: d8a94840fe9945fe9d176d472042aa2b :category: :subroutine :arguments: - idist: :type: integer :intent: input - iseed: :type: integer :intent: input/output :dims: - "4" - n: :type: integer :intent: input - x: :type: complex :intent: output :dims: - MAX(1,n) :substitutions: {} :fortran_help: " SUBROUTINE CLARNV( IDIST, ISEED, N, X )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLARNV returns a vector of n random complex numbers from a uniform or\n\ * normal distribution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * IDIST (input) INTEGER\n\ * Specifies the distribution of the random numbers:\n\ * = 1: real and imaginary parts each uniform (0,1)\n\ * = 2: real and imaginary parts each uniform (-1,1)\n\ * = 3: real and imaginary parts each normal (0,1)\n\ * = 4: uniformly distributed on the disc abs(z) < 1\n\ * = 5: uniformly distributed on the circle abs(z) = 1\n\ *\n\ * ISEED (input/output) INTEGER array, dimension (4)\n\ * On entry, the seed of the random number generator; the array\n\ * elements must be between 0 and 4095, and ISEED(4) must be\n\ * odd.\n\ * On exit, the seed is updated.\n\ *\n\ * N (input) INTEGER\n\ * The number of random numbers to be generated.\n\ *\n\ * X (output) COMPLEX array, dimension (N)\n\ * The generated random numbers.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * This routine calls the auxiliary routine SLARUV to generate random\n\ * real numbers from a uniform (0,1) distribution, in batches of up to\n\ * 128 using vectorisable code. The Box-Muller method is used to\n\ * transform numbers from a uniform to a normal distribution.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgbrfs0000644000175000017500000001301512502223526016457 0ustar uwabamiuwabami--- :name: dgbrfs :md5sum: b56549a2e7880c6fef2c12fa919a14d7 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublereal :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGBRFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is banded, and provides\n\ * error bounds and backward error estimates for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * The original band matrix A, stored in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n\ * Details of the LU factorization of the band matrix A, as\n\ * computed by DGBTRF. U is stored as an upper triangular band\n\ * matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n\ * the multipliers used during the factorization are stored in\n\ * rows KL+KU+2 to 2*KL+KU+1.\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from DGBTRF; for 1<=i<=N, row i of the\n\ * matrix was interchanged with row IPIV(i).\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by DGBTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlartgp0000644000175000017500000000335612502223526016654 0ustar uwabamiuwabami--- :name: dlartgp :md5sum: bed8b61858c5189bd7a27d2f840c6ce8 :category: :subroutine :arguments: - f: :type: doublereal :intent: input - g: :type: doublereal :intent: input - cs: :type: doublereal :intent: output - sn: :type: doublereal :intent: output - r: :type: doublereal :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLARTGP( F, G, CS, SN, R )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLARTGP generates a plane rotation so that\n\ *\n\ * [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1.\n\ * [ -SN CS ] [ G ] [ 0 ]\n\ *\n\ * This is a slower, more accurate version of the Level 1 BLAS routine DROTG,\n\ * with the following other differences:\n\ * F and G are unchanged on return.\n\ * If G=0, then CS=(+/-)1 and SN=0.\n\ * If F=0 and (G .ne. 0), then CS=0 and SN=(+/-)1.\n\ *\n\ * The sign is chosen so that R >= 0.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * F (input) DOUBLE PRECISION\n\ * The first component of vector to be rotated.\n\ *\n\ * G (input) DOUBLE PRECISION\n\ * The second component of vector to be rotated.\n\ *\n\ * CS (output) DOUBLE PRECISION\n\ * The cosine of the rotation.\n\ *\n\ * SN (output) DOUBLE PRECISION\n\ * The sine of the rotation.\n\ *\n\ * R (output) DOUBLE PRECISION\n\ * The nonzero component of the rotated vector.\n\ *\n\ * This version has a few statements commented out for thread safety\n\ * (machine parameters are computed on each entry). 10 feb 03, SJH.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zherfs0000644000175000017500000001231312502223526016511 0ustar uwabamiuwabami--- :name: zherfs :md5sum: 5526aebb74609c66f4e00e60fd27abae :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZHERFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHERFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is Hermitian indefinite, and\n\ * provides error bounds and backward error estimates for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The Hermitian matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular part\n\ * of the matrix A, and the strictly lower triangular part of A\n\ * is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of A contains the lower triangular part of\n\ * the matrix A, and the strictly upper triangular part of A is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX*16 array, dimension (LDAF,N)\n\ * The factored form of the matrix A. AF contains the block\n\ * diagonal matrix D and the multipliers used to obtain the\n\ * factor U or L from the factorization A = U*D*U**H or\n\ * A = L*D*L**H as computed by ZHETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by ZHETRF.\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by ZHETRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slansb0000644000175000017500000000623612502223526016501 0ustar uwabamiuwabami--- :name: slansb :md5sum: 3bbedb2fca11c6eb099b3bac2c12c03f :category: :function :type: real :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " REAL FUNCTION SLANSB( NORM, UPLO, N, K, AB, LDAB, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLANSB returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of an\n\ * n by n symmetric band matrix A, with k super-diagonals.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * SLANSB returns the value\n\ *\n\ * SLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in SLANSB as described\n\ * above.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * band matrix A is supplied.\n\ * = 'U': Upper triangular part is supplied\n\ * = 'L': Lower triangular part is supplied\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, SLANSB is\n\ * set to zero.\n\ *\n\ * K (input) INTEGER\n\ * The number of super-diagonals or sub-diagonals of the\n\ * band matrix A. K >= 0.\n\ *\n\ * AB (input) REAL array, dimension (LDAB,N)\n\ * The upper or lower triangle of the symmetric band matrix A,\n\ * stored in the first K+1 rows of AB. The j-th column of A is\n\ * stored in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= K+1.\n\ *\n\ * WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n\ * WORK is not referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zsytrf0000644000175000017500000001451412502223526016556 0ustar uwabamiuwabami--- :name: zsytrf :md5sum: 9c93e85cbf5380c2c19fa9764c96cc12 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSYTRF computes the factorization of a complex symmetric matrix A\n\ * using the Bunch-Kaufman diagonal pivoting method. The form of the\n\ * factorization is\n\ *\n\ * A = U*D*U**T or A = L*D*L**T\n\ *\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, and D is symmetric and block diagonal with\n\ * with 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\ * This is the blocked version of the algorithm, calling Level 3 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L (see below for further details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D.\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of WORK. LWORK >=1. For best performance\n\ * LWORK >= N*NB, where NB is the block size returned by ILAENV.\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, D(i,i) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular, and division by zero will occur if it\n\ * is used to solve a system of equations.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * If UPLO = 'U', then A = U*D*U', where\n\ * U = P(n)*U(n)* ... *P(k)U(k)* ...,\n\ * i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n\ * 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I v 0 ) k-s\n\ * U(k) = ( 0 I 0 ) s\n\ * ( 0 0 I ) n-k\n\ * k-s s n-k\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n\ * If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n\ * and A(k,k), and v overwrites A(1:k-2,k-1:k).\n\ *\n\ * If UPLO = 'L', then A = L*D*L', where\n\ * L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n\ * i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n\ * n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I 0 0 ) k-1\n\ * L(k) = ( 0 I 0 ) s\n\ * ( 0 v I ) n-k-s+1\n\ * k-1 s n-k-s+1\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n\ * If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n\ * and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LQUERY, UPPER\n INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZLASYF, ZSYTF2\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/ssysvxx0000644000175000017500000005147112502223526016767 0ustar uwabamiuwabami--- :name: ssysvxx :md5sum: 8aeecdaa231d926cc3ca72197ec9883e :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - equed: :type: char :intent: input/output - s: :type: real :intent: input/output :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - rpvgrw: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: real :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " SUBROUTINE SSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSYSVXX uses the diagonal pivoting factorization to compute the\n\ * solution to a real system of linear equations A * X = B, where A\n\ * is an N-by-N symmetric matrix and X and B are N-by-NRHS matrices.\n\ *\n\ * If requested, both normwise and maximum componentwise error bounds\n\ * are returned. SSYSVXX will return a solution with a tiny\n\ * guaranteed error (O(eps) where eps is the working machine\n\ * precision) unless the matrix is very ill-conditioned, in which\n\ * case a warning is returned. Relevant condition numbers also are\n\ * calculated and returned.\n\ *\n\ * SSYSVXX accepts user-provided factorizations and equilibration\n\ * factors; see the definitions of the FACT and EQUED options.\n\ * Solving with refinement and using a factorization from a previous\n\ * SSYSVXX call will also produce a solution with either O(eps)\n\ * errors or warnings, but we cannot make that claim for general\n\ * user-provided factorizations and equilibration factors if they\n\ * differ from what SSYSVXX would itself produce.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', real scaling factors are computed to equilibrate\n\ * the system:\n\ *\n\ * diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B\n\ *\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n\ *\n\ * 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n\ * the matrix A (after equilibration if FACT = 'E') as\n\ *\n\ * A = U * D * U**T, if UPLO = 'U', or\n\ * A = L * D * L**T, if UPLO = 'L',\n\ *\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, and D is symmetric and block diagonal with\n\ * 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\ * 3. If some D(i,i)=0, so that D is exactly singular, then the\n\ * routine returns with INFO = i. Otherwise, the factored form of A\n\ * is used to estimate the condition number of the matrix A (see\n\ * argument RCOND). If the reciprocal of the condition number is\n\ * less than machine precision, the routine still goes on to solve\n\ * for X and compute error bounds as described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n\ * the routine will use iterative refinement to try to get a small\n\ * error and error bounds. Refinement calculates the residual to at\n\ * least twice the working precision.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(R) so that it solves the original system before\n\ * equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AF and IPIV contain the factored form of A.\n\ * If EQUED is not 'N', the matrix A has been\n\ * equilibrated with scaling factors given by S.\n\ * A, AF, and IPIV are not modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AF and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular\n\ * part of the matrix A, and the strictly lower triangular\n\ * part of A is not referenced. If UPLO = 'L', the leading\n\ * N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n\ * diag(S)*A*diag(S).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input or output) REAL array, dimension (LDAF,N)\n\ * If FACT = 'F', then AF is an input argument and on entry\n\ * contains the block diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L from the factorization A =\n\ * U*D*U**T or A = L*D*L**T as computed by SSYTRF.\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the block diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L from the factorization A =\n\ * U*D*U**T or A = L*D*L**T.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains details of the interchanges and the block\n\ * structure of D, as determined by SSYTRF. If IPIV(k) > 0,\n\ * then rows and columns k and IPIV(k) were interchanged and\n\ * D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and\n\ * IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and\n\ * -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2\n\ * diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0,\n\ * then rows and columns k+1 and -IPIV(k) were interchanged\n\ * and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains details of the interchanges and the block\n\ * structure of D, as determined by SSYTRF.\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'Y': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(S) * A * diag(S).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * S (input or output) REAL array, dimension (N)\n\ * The scale factors for A. If EQUED = 'Y', A is multiplied on\n\ * the left and right by diag(S). S is an input argument if FACT =\n\ * 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n\ * = 'Y', each element of S must be positive. If S is output, each\n\ * element of S is a power of the radix. If S is input, each element\n\ * of S should be a power of the radix to ensure a reliable solution\n\ * and error estimates. Scaling by powers of the radix does not cause\n\ * rounding errors unless the result underflows or overflows.\n\ * Rounding errors during scaling lead to refining with a matrix that\n\ * is not equivalent to the input matrix, producing error estimates\n\ * that may not be reliable.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit,\n\ * if EQUED = 'N', B is not modified;\n\ * if EQUED = 'Y', B is overwritten by diag(S)*B;\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) REAL array, dimension (LDX,NRHS)\n\ * If INFO = 0, the N-by-NRHS solution matrix X to the original\n\ * system of equations. Note that A and B are modified on exit if\n\ * EQUED .ne. 'N', and the solution to the equilibrated system is\n\ * inv(diag(S))*X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * RPVGRW (output) REAL\n\ * Reciprocal pivot growth. On exit, this contains the reciprocal\n\ * pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n\ * norm is used. If this is much less than 1, then the stability of\n\ * the LU factorization of the (equilibrated) matrix A could be poor.\n\ * This also means that the solution X, estimated condition numbers,\n\ * and error bounds could be unreliable. If factorization fails with\n\ * 0 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgetc20000644000175000017500000000500512502223526016377 0ustar uwabamiuwabami--- :name: sgetc2 :md5sum: 8ba0f6ea4d1dc51b6b0e3d59cbf825d9 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - jpiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGETC2( N, A, LDA, IPIV, JPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGETC2 computes an LU factorization with complete pivoting of the\n\ * n-by-n matrix A. The factorization has the form A = P * L * U * Q,\n\ * where P and Q are permutation matrices, L is lower triangular with\n\ * unit diagonal elements and U is upper triangular.\n\ *\n\ * This is the Level 2 BLAS algorithm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA, N)\n\ * On entry, the n-by-n matrix A to be factored.\n\ * On exit, the factors L and U from the factorization\n\ * A = P*L*U*Q; the unit diagonal elements of L are not stored.\n\ * If U(k, k) appears to be less than SMIN, U(k, k) is given the\n\ * value of SMIN, i.e., giving a nonsingular perturbed system.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension(N).\n\ * The pivot indices; for 1 <= i <= N, row i of the\n\ * matrix has been interchanged with row IPIV(i).\n\ *\n\ * JPIV (output) INTEGER array, dimension(N).\n\ * The pivot indices; for 1 <= j <= N, column j of the\n\ * matrix has been interchanged with column JPIV(j).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * > 0: if INFO = k, U(k, k) is likely to produce owerflow if\n\ * we try to solve for x in Ax = b. So U is perturbed to\n\ * avoid the overflow.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zungql0000644000175000017500000000576712502223526016547 0ustar uwabamiuwabami--- :name: zungql :md5sum: 953f5696164d9977e6b295e5ab72e66c :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZUNGQL generates an M-by-N complex matrix Q with orthonormal columns,\n\ * which is defined as the last N columns of a product of K elementary\n\ * reflectors of order M\n\ *\n\ * Q = H(k) . . . H(2) H(1)\n\ *\n\ * as returned by ZGEQLF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. M >= N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. N >= K >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the (n-k+i)-th column must contain the vector which\n\ * defines the elementary reflector H(i), for i = 1,2,...,k, as\n\ * returned by ZGEQLF in the last k columns of its array\n\ * argument A.\n\ * On exit, the M-by-N matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) COMPLEX*16 array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by ZGEQLF.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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,N).\n\ * For optimum performance LWORK >= N*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 has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sspev0000644000175000017500000000644212502223526016356 0ustar uwabamiuwabami--- :name: sspev :md5sum: 190815c126e8cc58da7d9d497f9d0050 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - ldap - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE SSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSPEV computes all the eigenvalues and, optionally, eigenvectors of a\n\ * real symmetric matrix A in packed storage.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) REAL array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, AP is overwritten by values generated during the\n\ * reduction to tridiagonal form. If UPLO = 'U', the diagonal\n\ * and first superdiagonal of the tridiagonal matrix T overwrite\n\ * the corresponding elements of A, and if UPLO = 'L', the\n\ * diagonal and first subdiagonal of T overwrite the\n\ * corresponding elements of A.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) REAL array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n\ * eigenvectors of the matrix A, with the i-th column of Z\n\ * holding the eigenvector associated with W(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) REAL array, dimension (3*N)\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 algorithm failed to converge; i\n\ * off-diagonal elements of an intermediate tridiagonal\n\ * form did not converge to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cunmlq0000644000175000017500000001053112502223526016507 0ustar uwabamiuwabami--- :name: cunmlq :md5sum: dc642a8768f6ae415361d81170fba6a4 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CUNMLQ overwrites the general complex M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'C': Q**H * C C * Q**H\n\ *\n\ * where Q is a complex unitary matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(k)' . . . H(2)' H(1)'\n\ *\n\ * as returned by CGELQF. Q is of order M if SIDE = 'L' and of order N\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**H from the Left;\n\ * = 'R': apply Q or Q**H from the Right.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q;\n\ * = 'C': Conjugate transpose, apply Q**H.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension\n\ * (LDA,M) if SIDE = 'L',\n\ * (LDA,N) if SIDE = 'R'\n\ * The i-th row must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * CGELQF in the first k rows of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,K).\n\ *\n\ * TAU (input) COMPLEX array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by CGELQF.\n\ *\n\ * C (input/output) COMPLEX array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace/output) COMPLEX 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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M).\n\ * For optimum performance LWORK >= N*NB if SIDE 'L', and\n\ * LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n\ * 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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zsytrs20000644000175000017500000000526112502223526016654 0ustar uwabamiuwabami--- :name: zsytrs2 :md5sum: e48a2eb0aa983b9ea713ab0769adbe87 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSYTRS2 solves a system of linear equations A*X = B with a real\n\ * symmetric matrix A using the factorization A = U*D*U**T or\n\ * A = L*D*L**T computed by ZSYTRF and converted by ZSYCONV.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input) DOUBLE COMPLEX array, dimension (LDA,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by ZSYTRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by ZSYTRF.\n\ *\n\ * B (input/output) DOUBLE COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * WORK (workspace) REAL array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slabad0000644000175000017500000000312512502223526016437 0ustar uwabamiuwabami--- :name: slabad :md5sum: 7aed9e15f2c5ce86f54581079167d813 :category: :subroutine :arguments: - small: :type: real :intent: input/output - large: :type: real :intent: input/output :substitutions: {} :fortran_help: " SUBROUTINE SLABAD( SMALL, LARGE )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLABAD takes as input the values computed by SLAMCH for underflow and\n\ * overflow, and returns the square root of each of these values if the\n\ * log of LARGE is sufficiently large. This subroutine is intended to\n\ * identify machines with a large exponent range, such as the Crays, and\n\ * redefine the underflow and overflow limits to be the square roots of\n\ * the values computed by SLAMCH. This subroutine is needed because\n\ * SLAMCH does not compensate for poor arithmetic in the upper half of\n\ * the exponent range, as is found on a Cray.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SMALL (input/output) REAL\n\ * On entry, the underflow threshold as computed by SLAMCH.\n\ * On exit, if LOG10(LARGE) is sufficiently large, the square\n\ * root of SMALL, otherwise unchanged.\n\ *\n\ * LARGE (input/output) REAL\n\ * On entry, the overflow threshold as computed by SLAMCH.\n\ * On exit, if LOG10(LARGE) is sufficiently large, the square\n\ * root of LARGE, otherwise unchanged.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Intrinsic Functions ..\n INTRINSIC LOG10, SQRT\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zhseqr0000644000175000017500000002634012502223526016531 0ustar uwabamiuwabami--- :name: zhseqr :md5sum: ef6b85e6bdbf0fa44c0c2503d7c14f6f :category: :subroutine :arguments: - job: :type: char :intent: input - compz: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: doublecomplex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - w: :type: doublecomplex :intent: output :dims: - n - z: :type: doublecomplex :intent: input/output :dims: - "lsame_(&compz,\"N\") ? 0 : ldz" - "lsame_(&compz,\"N\") ? 0 : n" - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHSEQR computes the eigenvalues of a Hessenberg matrix H\n\ * and, optionally, the matrices T and Z from the Schur decomposition\n\ * H = Z T Z**H, where T is an upper triangular matrix (the\n\ * Schur form), and Z is the unitary matrix of Schur vectors.\n\ *\n\ * Optionally Z may be postmultiplied into an input unitary\n\ * matrix Q so that this routine can give the Schur factorization\n\ * of a matrix A which has been reduced to the Hessenberg form H\n\ * by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * = 'E': compute eigenvalues only;\n\ * = 'S': compute eigenvalues and the Schur form T.\n\ *\n\ * COMPZ (input) CHARACTER*1\n\ * = 'N': no Schur vectors are computed;\n\ * = 'I': Z is initialized to the unit matrix and the matrix Z\n\ * of Schur vectors of H is returned;\n\ * = 'V': Z must contain an unitary matrix Q on entry, and\n\ * the product Q*Z is returned.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H. N .GE. 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * It is assumed that H is already upper triangular in rows\n\ * and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n\ * set by a previous call to ZGEBAL, and then passed to ZGEHRD\n\ * when the matrix output by ZGEBAL is reduced to Hessenberg\n\ * form. Otherwise ILO and IHI should be set to 1 and N\n\ * respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n\ * If N = 0, then ILO = 1 and IHI = 0.\n\ *\n\ * H (input/output) COMPLEX*16 array, dimension (LDH,N)\n\ * On entry, the upper Hessenberg matrix H.\n\ * On exit, if INFO = 0 and JOB = 'S', H contains the upper\n\ * triangular matrix T from the Schur decomposition (the\n\ * Schur form). If INFO = 0 and JOB = 'E', the contents of\n\ * H are unspecified on exit. (The output value of H when\n\ * INFO.GT.0 is given under the description of INFO below.)\n\ *\n\ * Unlike earlier versions of ZHSEQR, this subroutine may\n\ * explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1\n\ * or j = IHI+1, IHI+2, ... N.\n\ *\n\ * LDH (input) INTEGER\n\ * The leading dimension of the array H. LDH .GE. max(1,N).\n\ *\n\ * W (output) COMPLEX*16 array, dimension (N)\n\ * The computed eigenvalues. If JOB = 'S', the eigenvalues are\n\ * stored in the same order as on the diagonal of the Schur\n\ * form returned in H, with W(i) = H(i,i).\n\ *\n\ * Z (input/output) COMPLEX*16 array, dimension (LDZ,N)\n\ * If COMPZ = 'N', Z is not referenced.\n\ * If COMPZ = 'I', on entry Z need not be set and on exit,\n\ * if INFO = 0, Z contains the unitary matrix Z of the Schur\n\ * vectors of H. If COMPZ = 'V', on entry Z must contain an\n\ * N-by-N matrix Q, which is assumed to be equal to the unit\n\ * matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,\n\ * if INFO = 0, Z contains Q*Z.\n\ * Normally Q is the unitary matrix generated by ZUNGHR\n\ * after the call to ZGEHRD which formed the Hessenberg matrix\n\ * H. (The output value of Z when INFO.GT.0 is given under\n\ * the description of INFO below.)\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. if COMPZ = 'I' or\n\ * COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 array, dimension (LWORK)\n\ * On exit, if INFO = 0, WORK(1) returns an estimate of\n\ * the optimal value for LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK .GE. max(1,N)\n\ * is sufficient and delivers very good and sometimes\n\ * optimal performance. However, LWORK as large as 11*N\n\ * may be required for optimal performance. A workspace\n\ * query is recommended to determine the optimal workspace\n\ * size.\n\ *\n\ * If LWORK = -1, then ZHSEQR does a workspace query.\n\ * In this case, ZHSEQR checks the input parameters and\n\ * estimates the optimal workspace size for the given\n\ * values of N, ILO and IHI. The estimate is returned\n\ * in WORK(1). No error message related to LWORK is\n\ * issued by XERBLA. Neither H nor Z are accessed.\n\ *\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * .LT. 0: if INFO = -i, the i-th argument had an illegal\n\ * value\n\ * .GT. 0: if INFO = i, ZHSEQR failed to compute all of\n\ * the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n\ * and WI contain those eigenvalues which have been\n\ * successfully computed. (Failures are rare.)\n\ *\n\ * If INFO .GT. 0 and JOB = 'E', then on exit, the\n\ * remaining unconverged eigenvalues are the eigen-\n\ * values of the upper Hessenberg matrix rows and\n\ * columns ILO through INFO of the final, output\n\ * value of H.\n\ *\n\ * If INFO .GT. 0 and JOB = 'S', then on exit\n\ *\n\ * (*) (initial value of H)*U = U*(final value of H)\n\ *\n\ * where U is a unitary matrix. The final\n\ * value of H is upper Hessenberg and triangular in\n\ * rows and columns INFO+1 through IHI.\n\ *\n\ * If INFO .GT. 0 and COMPZ = 'V', then on exit\n\ *\n\ * (final value of Z) = (initial value of Z)*U\n\ *\n\ * where U is the unitary matrix in (*) (regard-\n\ * less of the value of JOB.)\n\ *\n\ * If INFO .GT. 0 and COMPZ = 'I', then on exit\n\ * (final value of Z) = U\n\ * where U is the unitary matrix in (*) (regard-\n\ * less of the value of JOB.)\n\ *\n\ * If INFO .GT. 0 and COMPZ = 'N', then Z is not\n\ * accessed.\n\ *\n\n\ * ================================================================\n\ * Default values supplied by\n\ * ILAENV(ISPEC,'ZHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).\n\ * It is suggested that these defaults be adjusted in order\n\ * to attain best performance in each particular\n\ * computational environment.\n\ *\n\ * ISPEC=12: The ZLAHQR vs ZLAQR0 crossover point.\n\ * Default: 75. (Must be at least 11.)\n\ *\n\ * ISPEC=13: Recommended deflation window size.\n\ * This depends on ILO, IHI and NS. NS is the\n\ * number of simultaneous shifts returned\n\ * by ILAENV(ISPEC=15). (See ISPEC=15 below.)\n\ * The default for (IHI-ILO+1).LE.500 is NS.\n\ * The default for (IHI-ILO+1).GT.500 is 3*NS/2.\n\ *\n\ * ISPEC=14: Nibble crossover point. (See IPARMQ for\n\ * details.) Default: 14% of deflation window\n\ * size.\n\ *\n\ * ISPEC=15: Number of simultaneous shifts in a multishift\n\ * QR iteration.\n\ *\n\ * If IHI-ILO+1 is ...\n\ *\n\ * greater than ...but less ... the\n\ * or equal to ... than default is\n\ *\n\ * 1 30 NS = 2(+)\n\ * 30 60 NS = 4(+)\n\ * 60 150 NS = 10(+)\n\ * 150 590 NS = **\n\ * 590 3000 NS = 64\n\ * 3000 6000 NS = 128\n\ * 6000 infinity NS = 256\n\ *\n\ * (+) By default some or all matrices of this order\n\ * are passed to the implicit double shift routine\n\ * ZLAHQR and this parameter is ignored. See\n\ * ISPEC=12 above and comments in IPARMQ for\n\ * details.\n\ *\n\ * (**) The asterisks (**) indicate an ad-hoc\n\ * function of N increasing from 10 to 64.\n\ *\n\ * ISPEC=16: Select structured matrix multiply.\n\ * If the number of simultaneous shifts (specified\n\ * by ISPEC=15) is less than 14, then the default\n\ * for ISPEC=16 is 0. Otherwise the default for\n\ * ISPEC=16 is 2.\n\ *\n\ * ================================================================\n\ * Based on contributions by\n\ * Karen Braman and Ralph Byers, Department of Mathematics,\n\ * University of Kansas, USA\n\ *\n\ * ================================================================\n\ * References:\n\ * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n\ * Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n\ * Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n\ * 929--947, 2002.\n\ *\n\ * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n\ * Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n\ * of Matrix Analysis, volume 23, pages 948--973, 2002.\n\ *\n\ * ================================================================\n" ruby-lapack-1.7.2/dev/defs/dorgl20000644000175000017500000000443612502223526016410 0ustar uwabamiuwabami--- :name: dorgl2 :md5sum: 6ba11f9817d8923212cda012b48b0806 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - work: :type: doublereal :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DORGL2 generates an m by n real matrix Q with orthonormal rows,\n\ * which is defined as the first m rows of a product of k elementary\n\ * reflectors of order n\n\ *\n\ * Q = H(k) . . . H(2) H(1)\n\ *\n\ * as returned by DGELQF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. N >= M.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. M >= K >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the i-th row must contain the vector which defines\n\ * the elementary reflector H(i), for i = 1,2,...,k, as returned\n\ * by DGELQF in the first k rows of its array argument A.\n\ * On exit, the m-by-n matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) DOUBLE PRECISION array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by DGELQF.\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 has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slasq40000644000175000017500000000440712502223526016424 0ustar uwabamiuwabami--- :name: slasq4 :md5sum: 384541c9aca1ccacc332afa3badf712b :category: :subroutine :arguments: - i0: :type: integer :intent: input - n0: :type: integer :intent: input - z: :type: real :intent: input :dims: - 4*n0 - pp: :type: integer :intent: input - n0in: :type: integer :intent: input - dmin: :type: real :intent: input - dmin1: :type: real :intent: input - dmin2: :type: real :intent: input - dn: :type: real :intent: input - dn1: :type: real :intent: input - dn2: :type: real :intent: input - tau: :type: real :intent: output - ttype: :type: integer :intent: output - g: :type: real :intent: input/output :substitutions: {} :fortran_help: " SUBROUTINE SLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1, DN2, TAU, TTYPE, G )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLASQ4 computes an approximation TAU to the smallest eigenvalue\n\ * using values of d from the previous transform.\n\ *\n\n\ * I0 (input) INTEGER\n\ * First index.\n\ *\n\ * N0 (input) INTEGER\n\ * Last index.\n\ *\n\ * Z (input) REAL array, dimension ( 4*N )\n\ * Z holds the qd array.\n\ *\n\ * PP (input) INTEGER\n\ * PP=0 for ping, PP=1 for pong.\n\ *\n\ * NOIN (input) INTEGER\n\ * The value of N0 at start of EIGTEST.\n\ *\n\ * DMIN (input) REAL\n\ * Minimum value of d.\n\ *\n\ * DMIN1 (input) REAL\n\ * Minimum value of d, excluding D( N0 ).\n\ *\n\ * DMIN2 (input) REAL\n\ * Minimum value of d, excluding D( N0 ) and D( N0-1 ).\n\ *\n\ * DN (input) REAL\n\ * d(N)\n\ *\n\ * DN1 (input) REAL\n\ * d(N-1)\n\ *\n\ * DN2 (input) REAL\n\ * d(N-2)\n\ *\n\ * TAU (output) REAL\n\ * This is the shift.\n\ *\n\ * TTYPE (output) INTEGER\n\ * Shift type.\n\ *\n\ * G (input/output) REAL\n\ * G is passed as an argument in order to save its value between\n\ * calls to SLASQ4.\n\ *\n\n\ * Further Details\n\ * ===============\n\ * CNST1 = 9/16\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgelq20000644000175000017500000000471512502223526016414 0ustar uwabamiuwabami--- :name: sgelq2 :md5sum: 1e79428ba3255ee6646e52547c2b32cf :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - MIN(m,n) - work: :type: real :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE SGELQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGELQ2 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) REAL 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) REAL array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace) REAL 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" ruby-lapack-1.7.2/dev/defs/clansb0000644000175000017500000000624412502223525016457 0ustar uwabamiuwabami--- :name: clansb :md5sum: e61754eafe3b5e1bdf794923a4ad9977 :category: :function :type: real :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " REAL FUNCTION CLANSB( NORM, UPLO, N, K, AB, LDAB, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLANSB returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of an\n\ * n by n symmetric band matrix A, with k super-diagonals.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * CLANSB returns the value\n\ *\n\ * CLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in CLANSB as described\n\ * above.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * band matrix A is supplied.\n\ * = 'U': Upper triangular part is supplied\n\ * = 'L': Lower triangular part is supplied\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, CLANSB is\n\ * set to zero.\n\ *\n\ * K (input) INTEGER\n\ * The number of super-diagonals or sub-diagonals of the\n\ * band matrix A. K >= 0.\n\ *\n\ * AB (input) COMPLEX array, dimension (LDAB,N)\n\ * The upper or lower triangle of the symmetric band matrix A,\n\ * stored in the first K+1 rows of AB. The j-th column of A is\n\ * stored in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= K+1.\n\ *\n\ * WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n\ * WORK is not referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgees0000644000175000017500000001363312502223526016333 0ustar uwabamiuwabami--- :name: zgees :md5sum: 9de99276d77e47de1eb795c27dafa7c3 :category: :subroutine :arguments: - jobvs: :type: char :intent: input - sort: :type: char :intent: input - select: :intent: external procedure :block_type: logical :block_arg_num: 1 :block_arg_type: doublecomplex - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - sdim: :type: integer :intent: output - w: :type: doublecomplex :intent: output :dims: - n - vs: :type: doublecomplex :intent: output :dims: - ldvs - n - ldvs: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvs: "lsame_(&jobvs,\"V\") ? n : 1" :fortran_help: " SUBROUTINE ZGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS, LDVS, WORK, LWORK, RWORK, BWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGEES computes for an N-by-N complex nonsymmetric matrix A, the\n\ * eigenvalues, the Schur form T, and, optionally, the matrix of Schur\n\ * vectors Z. This gives the Schur factorization A = Z*T*(Z**H).\n\ *\n\ * Optionally, it also orders the eigenvalues on the diagonal of the\n\ * Schur form so that selected eigenvalues are at the top left.\n\ * The leading columns of Z then form an orthonormal basis for the\n\ * invariant subspace corresponding to the selected eigenvalues.\n\ *\n\ * A complex matrix is in Schur form if it is upper triangular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVS (input) CHARACTER*1\n\ * = 'N': Schur vectors are not computed;\n\ * = 'V': Schur vectors are computed.\n\ *\n\ * SORT (input) CHARACTER*1\n\ * Specifies whether or not to order the eigenvalues on the\n\ * diagonal of the Schur form.\n\ * = 'N': Eigenvalues are not ordered:\n\ * = 'S': Eigenvalues are ordered (see SELECT).\n\ *\n\ * SELECT (external procedure) LOGICAL FUNCTION of one COMPLEX*16 argument\n\ * SELECT must be declared EXTERNAL in the calling subroutine.\n\ * If SORT = 'S', SELECT is used to select eigenvalues to order\n\ * to the top left of the Schur form.\n\ * IF SORT = 'N', SELECT is not referenced.\n\ * The eigenvalue W(j) is selected if SELECT(W(j)) is true.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ * On exit, A has been overwritten by its Schur form T.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * SDIM (output) INTEGER\n\ * If SORT = 'N', SDIM = 0.\n\ * If SORT = 'S', SDIM = number of eigenvalues for which\n\ * SELECT is true.\n\ *\n\ * W (output) COMPLEX*16 array, dimension (N)\n\ * W contains the computed eigenvalues, in the same order that\n\ * they appear on the diagonal of the output Schur form T.\n\ *\n\ * VS (output) COMPLEX*16 array, dimension (LDVS,N)\n\ * If JOBVS = 'V', VS contains the unitary matrix Z of Schur\n\ * vectors.\n\ * If JOBVS = 'N', VS is not referenced.\n\ *\n\ * LDVS (input) INTEGER\n\ * The leading dimension of the array VS. LDVS >= 1; if\n\ * JOBVS = 'V', LDVS >= N.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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,2*N).\n\ * For good performance, LWORK must generally be larger.\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\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * BWORK (workspace) LOGICAL array, dimension (N)\n\ * Not referenced if SORT = 'N'.\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, and i is\n\ * <= N: the QR algorithm failed to compute all the\n\ * eigenvalues; elements 1:ILO-1 and i+1:N of W\n\ * contain those eigenvalues which have converged;\n\ * if JOBVS = 'V', VS contains the matrix which\n\ * reduces A to its partially converged Schur form.\n\ * = N+1: the eigenvalues could not be reordered because\n\ * some eigenvalues were too close to separate (the\n\ * problem is very ill-conditioned);\n\ * = N+2: after reordering, roundoff changed values of\n\ * some complex eigenvalues so that leading\n\ * eigenvalues in the Schur form no longer satisfy\n\ * SELECT = .TRUE.. This could also be caused by\n\ * underflow due to scaling.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgecon0000644000175000017500000000472512502223526016476 0ustar uwabamiuwabami--- :name: sgecon :md5sum: 946a6d0eb733c9d751e18bcd9e264365 :category: :subroutine :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGECON estimates the reciprocal of the condition number of a general\n\ * real matrix A, in either the 1-norm or the infinity-norm, using\n\ * the LU factorization computed by SGETRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as\n\ * RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies whether the 1-norm condition number or the\n\ * infinity-norm condition number is required:\n\ * = '1' or 'O': 1-norm;\n\ * = 'I': Infinity-norm.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * The factors L and U from the factorization A = P*L*U\n\ * as computed by SGETRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * ANORM (input) REAL\n\ * If NORM = '1' or 'O', the 1-norm of the original matrix A.\n\ * If NORM = 'I', the infinity-norm of the original matrix A.\n\ *\n\ * RCOND (output) REAL\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(norm(A) * norm(inv(A))).\n\ *\n\ * WORK (workspace) REAL array, dimension (4*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zunmrz0000644000175000017500000001151212502223526016555 0ustar uwabamiuwabami--- :name: zunmrz :md5sum: 4852187a5574f9f5bf22da48e0265e54 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZUNMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZUNMRZ overwrites the general complex M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'C': Q**H * C C * Q**H\n\ *\n\ * where Q is a complex unitary matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by ZTZRZF. Q is of order M if SIDE = 'L' and of order N\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**H from the Left;\n\ * = 'R': apply Q or Q**H from the Right.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q;\n\ * = 'C': Conjugate transpose, apply Q**H.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * L (input) INTEGER\n\ * The number of columns of the matrix A containing\n\ * the meaningful part of the Householder reflectors.\n\ * If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension\n\ * (LDA,M) if SIDE = 'L',\n\ * (LDA,N) if SIDE = 'R'\n\ * The i-th row must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * ZTZRZF in the last k rows of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,K).\n\ *\n\ * TAU (input) COMPLEX*16 array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by ZTZRZF.\n\ *\n\ * C (input/output) COMPLEX*16 array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M).\n\ * For optimum performance LWORK >= N*NB if SIDE = 'L', and\n\ * LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n\ * 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\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dormqr0000644000175000017500000001054112502223526016515 0ustar uwabamiuwabami--- :name: dormqr :md5sum: 3680363f39cc4d2d574d217d1252ceeb :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DORMQR overwrites the general real M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'T': Q**T * C C * Q**T\n\ *\n\ * where Q is a real orthogonal matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**T from the Left;\n\ * = 'R': apply Q or Q**T from the Right.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q;\n\ * = 'T': Transpose, apply Q**T.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,K)\n\ * The i-th column must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * DGEQRF in the first k columns of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ * If SIDE = 'L', LDA >= max(1,M);\n\ * if SIDE = 'R', LDA >= max(1,N).\n\ *\n\ * TAU (input) DOUBLE PRECISION array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by DGEQRF.\n\ *\n\ * C (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M).\n\ * For optimum performance LWORK >= N*NB if SIDE = 'L', and\n\ * LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n\ * 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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zla_porfsx_extended0000644000175000017500000003467312502223526021274 0ustar uwabamiuwabami--- :name: zla_porfsx_extended :md5sum: b1329c654babe3970201a34d324770a2 :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - colequ: :type: logical :intent: input - c: :type: doublereal :intent: input :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: doublecomplex :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: doublereal :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: input/output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: input/output :dims: - nrhs - n_err_bnds - res: :type: doublecomplex :intent: input :dims: - n - ayb: :type: doublereal :intent: input :dims: - n - dy: :type: doublecomplex :intent: input :dims: - n - y_tail: :type: doublecomplex :intent: input :dims: - n - rcond: :type: doublereal :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: doublereal :intent: input - dz_ub: :type: doublereal :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLA_PORFSX_EXTENDED improves the computed solution to a system of\n\ * linear equations by performing extra-precise iterative refinement\n\ * and provides error bounds and backward error estimates for the solution.\n\ * This subroutine is called by ZPORFSX to perform iterative refinement.\n\ * In addition to normwise error bound, the code provides maximum\n\ * componentwise error bound if possible. See comments for ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP for details of the error bounds. Note that this\n\ * subroutine is only resonsible for setting the second fields of\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * PREC_TYPE (input) INTEGER\n\ * Specifies the intermediate precision to be used in refinement.\n\ * The value is defined by ILAPREC(P) where P is a CHARACTER and\n\ * P = 'S': Single\n\ * = 'D': Double\n\ * = 'I': Indigenous\n\ * = 'X', 'E': Extra\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right-hand-sides, i.e., the number of columns of the\n\ * matrix B.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX*16 array, dimension (LDAF,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T, as computed by ZPOTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * COLEQU (input) LOGICAL\n\ * If .TRUE. then column equilibration was done to A before calling\n\ * this routine. This is needed to compute the solution and error\n\ * bounds correctly.\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension (N)\n\ * The column scale factors for A. If COLEQU = .FALSE., C\n\ * is not accessed. If C is input, each element of C should be a power\n\ * of the radix to ensure a reliable solution and error estimates.\n\ * Scaling by powers of the radix does not cause rounding errors unless\n\ * the result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The right-hand-side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * Y (input/output) COMPLEX*16 array, dimension\n\ * (LDY,NRHS)\n\ * On entry, the solution matrix X, as computed by ZPOTRS.\n\ * On exit, the improved solution matrix Y.\n\ *\n\ * LDY (input) INTEGER\n\ * The leading dimension of the array Y. LDY >= max(1,N).\n\ *\n\ * BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * On exit, BERR_OUT(j) contains the componentwise relative backward\n\ * error for right-hand-side j from the formula\n\ * max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n\ * where abs(Z) is the componentwise absolute value of the matrix\n\ * or vector Z. This is computed by ZLA_LIN_BERR.\n\ *\n\ * N_NORMS (input) INTEGER\n\ * Determines which error bounds to return (see ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP).\n\ * If N_NORMS >= 1 return normwise error bounds.\n\ * If N_NORMS >= 2 return componentwise error bounds.\n\ *\n\ * ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension\n\ * (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension\n\ * (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * RES (input) COMPLEX*16 array, dimension (N)\n\ * Workspace to hold the intermediate residual.\n\ *\n\ * AYB (input) DOUBLE PRECISION array, dimension (N)\n\ * Workspace.\n\ *\n\ * DY (input) COMPLEX*16 PRECISION array, dimension (N)\n\ * Workspace to hold the intermediate solution.\n\ *\n\ * Y_TAIL (input) COMPLEX*16 array, dimension (N)\n\ * Workspace to hold the trailing bits of the intermediate solution.\n\ *\n\ * RCOND (input) DOUBLE PRECISION\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * ITHRESH (input) INTEGER\n\ * The maximum number of residual computations allowed for\n\ * refinement. The default is 10. For 'aggressive' set to 100 to\n\ * permit convergence using approximate factorizations or\n\ * factorizations other than LU. If the factorization uses a\n\ * technique other than Gaussian elimination, the guarantees in\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n\ *\n\ * RTHRESH (input) DOUBLE PRECISION\n\ * Determines when to stop refinement if the error estimate stops\n\ * decreasing. Refinement will stop when the next solution no longer\n\ * satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n\ * the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n\ * default value is 0.5. For 'aggressive' set to 0.9 to permit\n\ * convergence on extremely ill-conditioned matrices. See LAWN 165\n\ * for more details.\n\ *\n\ * DZ_UB (input) DOUBLE PRECISION\n\ * Determines when to start considering componentwise convergence.\n\ * Componentwise convergence is only considered after each component\n\ * of the solution Y is stable, which we definte as the relative\n\ * change in each component being less than DZ_UB. The default value\n\ * is 0.25, requiring the first bit to be stable. See LAWN 165 for\n\ * more details.\n\ *\n\ * IGNORE_CWISE (input) LOGICAL\n\ * If .TRUE. then ignore componentwise convergence. Default value\n\ * is .FALSE..\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * < 0: if INFO = -i, the ith argument to ZPOTRS had an illegal\n\ * value\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE,\n $ Y_PREC_STATE\n DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n COMPLEX*16 ZDUM\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slangt0000644000175000017500000000422412502223526016502 0ustar uwabamiuwabami--- :name: slangt :md5sum: b5fa6a1b7e062602baca818363a90bb4 :category: :function :type: real :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - dl: :type: real :intent: input :dims: - n-1 - d: :type: real :intent: input :dims: - n - du: :type: real :intent: input :dims: - n-1 :substitutions: {} :fortran_help: " REAL FUNCTION SLANGT( NORM, N, DL, D, DU )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLANGT returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * real tridiagonal matrix A.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * SLANGT returns the value\n\ *\n\ * SLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in SLANGT as described\n\ * above.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, SLANGT is\n\ * set to zero.\n\ *\n\ * DL (input) REAL array, dimension (N-1)\n\ * The (n-1) sub-diagonal elements of A.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The diagonal elements of A.\n\ *\n\ * DU (input) REAL array, dimension (N-1)\n\ * The (n-1) super-diagonal elements of A.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sormr30000644000175000017500000001104512502223526016436 0ustar uwabamiuwabami--- :name: sormr3 :md5sum: 7f39e6e76399d353e330f71975ab640d :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SORMR3 overwrites the general real m by n matrix C with\n\ *\n\ * Q * C if SIDE = 'L' and TRANS = 'N', or\n\ *\n\ * Q'* C if SIDE = 'L' and TRANS = 'T', or\n\ *\n\ * C * Q if SIDE = 'R' and TRANS = 'N', or\n\ *\n\ * C * Q' if SIDE = 'R' and TRANS = 'T',\n\ *\n\ * where Q is a real orthogonal matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by STZRZF. Q is of order m if SIDE = 'L' and of order n\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q' from the Left\n\ * = 'R': apply Q or Q' from the Right\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': apply Q (No transpose)\n\ * = 'T': apply Q' (Transpose)\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * L (input) INTEGER\n\ * The number of columns of the matrix A containing\n\ * the meaningful part of the Householder reflectors.\n\ * If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n\ *\n\ * A (input) REAL array, dimension\n\ * (LDA,M) if SIDE = 'L',\n\ * (LDA,N) if SIDE = 'R'\n\ * The i-th row must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * STZRZF in the last k rows of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,K).\n\ *\n\ * TAU (input) REAL array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by STZRZF.\n\ *\n\ * C (input/output) REAL array, dimension (LDC,N)\n\ * On entry, the m-by-n matrix C.\n\ * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) REAL array, dimension\n\ * (N) if SIDE = 'L',\n\ * (M) if SIDE = 'R'\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\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LEFT, NOTRAN\n INTEGER I, I1, I2, I3, IC, JA, JC, MI, NI, NQ\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SLARZ, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/spptrf0000644000175000017500000000514012502223526016526 0ustar uwabamiuwabami--- :name: spptrf :md5sum: 23562c90317eb8bef1a4a57d96a58691 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPPTRF( UPLO, N, AP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPPTRF computes the Cholesky factorization of a real symmetric\n\ * positive definite matrix A stored in packed format.\n\ *\n\ * The factorization has the form\n\ * A = U**T * U, if UPLO = 'U', or\n\ * A = L * L**T, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is lower triangular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) REAL array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ * See below for further details.\n\ *\n\ * On exit, if INFO = 0, the triangular factor U or L from the\n\ * Cholesky factorization A = U**T*U or A = L*L**T, in the same\n\ * storage format as A.\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 leading minor of order i is not\n\ * positive definite, and the factorization could not be\n\ * completed.\n\ *\n\n\ * Further Details\n\ * ======= =======\n\ *\n\ * The packed storage scheme is illustrated by the following example\n\ * when N = 4, UPLO = 'U':\n\ *\n\ * Two-dimensional storage of the symmetric matrix A:\n\ *\n\ * a11 a12 a13 a14\n\ * a22 a23 a24\n\ * a33 a34 (aij = aji)\n\ * a44\n\ *\n\ * Packed storage of the upper triangle of A:\n\ *\n\ * AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slarrr0000644000175000017500000000357312502223526016525 0ustar uwabamiuwabami--- :name: slarrr :md5sum: 2978dd436dee35812a8a2070f682419c :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: real :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLARRR( N, D, E, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Perform tests to decide whether the symmetric tridiagonal matrix T\n\ * warrants expensive computations which guarantee high relative accuracy\n\ * in the eigenvalues.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N > 0.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The N diagonal elements of the tridiagonal matrix T.\n\ *\n\ * E (input/output) REAL array, dimension (N)\n\ * On entry, the first (N-1) entries contain the subdiagonal\n\ * elements of the tridiagonal matrix T; E(N) is set to ZERO.\n\ *\n\ * INFO (output) INTEGER\n\ * INFO = 0(default) : the matrix warrants computations preserving\n\ * relative accuracy.\n\ * INFO = 1 : the matrix warrants computations guaranteeing\n\ * only absolute accuracy.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Beresford Parlett, University of California, Berkeley, USA\n\ * Jim Demmel, University of California, Berkeley, USA\n\ * Inderjit Dhillon, University of Texas, Austin, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, University of California, Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgges0000644000175000017500000002130712502223525016302 0ustar uwabamiuwabami--- :name: cgges :md5sum: 2194034394c6047cf7a6bae40d20e0c0 :category: :subroutine :arguments: - jobvsl: :type: char :intent: input - jobvsr: :type: char :intent: input - sort: :type: char :intent: input - selctg: :intent: external procedure :block_type: logical :block_arg_num: 2 :block_arg_type: complex - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - sdim: :type: integer :intent: output - alpha: :type: complex :intent: output :dims: - n - beta: :type: complex :intent: output :dims: - n - vsl: :type: complex :intent: output :dims: - ldvsl - n - ldvsl: :type: integer :intent: input - vsr: :type: complex :intent: output :dims: - ldvsr - n - ldvsr: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: real :intent: workspace :dims: - 8*n - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvsl: "lsame_(&jobvsl,\"V\") ? n : 1" ldvsr: "lsame_(&jobvsr,\"V\") ? n : 1" :fortran_help: " SUBROUTINE CGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, BWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGGES computes for a pair of N-by-N complex nonsymmetric matrices\n\ * (A,B), the generalized eigenvalues, the generalized complex Schur\n\ * form (S, T), and optionally left and/or right Schur vectors (VSL\n\ * and VSR). This gives the generalized Schur factorization\n\ *\n\ * (A,B) = ( (VSL)*S*(VSR)**H, (VSL)*T*(VSR)**H )\n\ *\n\ * where (VSR)**H is the conjugate-transpose of VSR.\n\ *\n\ * Optionally, it also orders the eigenvalues so that a selected cluster\n\ * of eigenvalues appears in the leading diagonal blocks of the upper\n\ * triangular matrix S and the upper triangular matrix T. The leading\n\ * columns of VSL and VSR then form an unitary basis for the\n\ * corresponding left and right eigenspaces (deflating subspaces).\n\ *\n\ * (If only the generalized eigenvalues are needed, use the driver\n\ * CGGEV instead, which is faster.)\n\ *\n\ * A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n\ * or a ratio alpha/beta = w, such that A - w*B is singular. It is\n\ * usually represented as the pair (alpha,beta), as there is a\n\ * reasonable interpretation for beta=0, and even for both being zero.\n\ *\n\ * A pair of matrices (S,T) is in generalized complex Schur form if S\n\ * and T are upper triangular and, in addition, the diagonal elements\n\ * of T are non-negative real numbers.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVSL (input) CHARACTER*1\n\ * = 'N': do not compute the left Schur vectors;\n\ * = 'V': compute the left Schur vectors.\n\ *\n\ * JOBVSR (input) CHARACTER*1\n\ * = 'N': do not compute the right Schur vectors;\n\ * = 'V': compute the right Schur vectors.\n\ *\n\ * SORT (input) CHARACTER*1\n\ * Specifies whether or not to order the eigenvalues on the\n\ * diagonal of the generalized Schur form.\n\ * = 'N': Eigenvalues are not ordered;\n\ * = 'S': Eigenvalues are ordered (see SELCTG).\n\ *\n\ * SELCTG (external procedure) LOGICAL FUNCTION of two COMPLEX arguments\n\ * SELCTG must be declared EXTERNAL in the calling subroutine.\n\ * If SORT = 'N', SELCTG is not referenced.\n\ * If SORT = 'S', SELCTG is used to select eigenvalues to sort\n\ * to the top left of the Schur form.\n\ * An eigenvalue ALPHA(j)/BETA(j) is selected if\n\ * SELCTG(ALPHA(j),BETA(j)) is true.\n\ *\n\ * Note that a selected complex eigenvalue may no longer satisfy\n\ * SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since\n\ * ordering may change the value of complex eigenvalues\n\ * (especially if the eigenvalue is ill-conditioned), in this\n\ * case INFO is set to N+2 (See INFO below).\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A, B, VSL, and VSR. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA, N)\n\ * On entry, the first of the pair of matrices.\n\ * On exit, A has been overwritten by its generalized Schur\n\ * form S.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB, N)\n\ * On entry, the second of the pair of matrices.\n\ * On exit, B has been overwritten by its generalized Schur\n\ * form T.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B. LDB >= max(1,N).\n\ *\n\ * SDIM (output) INTEGER\n\ * If SORT = 'N', SDIM = 0.\n\ * If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n\ * for which SELCTG is true.\n\ *\n\ * ALPHA (output) COMPLEX array, dimension (N)\n\ * BETA (output) COMPLEX array, dimension (N)\n\ * On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the\n\ * generalized eigenvalues. ALPHA(j), j=1,...,N and BETA(j),\n\ * j=1,...,N are the diagonals of the complex Schur form (A,B)\n\ * output by CGGES. The BETA(j) will be non-negative real.\n\ *\n\ * Note: the quotients ALPHA(j)/BETA(j) may easily over- or\n\ * underflow, and BETA(j) may even be zero. Thus, the user\n\ * should avoid naively computing the ratio alpha/beta.\n\ * However, ALPHA will be always less than and usually\n\ * comparable with norm(A) in magnitude, and BETA always less\n\ * than and usually comparable with norm(B).\n\ *\n\ * VSL (output) COMPLEX array, dimension (LDVSL,N)\n\ * If JOBVSL = 'V', VSL will contain the left Schur vectors.\n\ * Not referenced if JOBVSL = 'N'.\n\ *\n\ * LDVSL (input) INTEGER\n\ * The leading dimension of the matrix VSL. LDVSL >= 1, and\n\ * if JOBVSL = 'V', LDVSL >= N.\n\ *\n\ * VSR (output) COMPLEX array, dimension (LDVSR,N)\n\ * If JOBVSR = 'V', VSR will contain the right Schur vectors.\n\ * Not referenced if JOBVSR = 'N'.\n\ *\n\ * LDVSR (input) INTEGER\n\ * The leading dimension of the matrix VSR. LDVSR >= 1, and\n\ * if JOBVSR = 'V', LDVSR >= N.\n\ *\n\ * WORK (workspace/output) COMPLEX 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,2*N).\n\ * For good performance, LWORK must generally be larger.\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\ * RWORK (workspace) REAL array, dimension (8*N)\n\ *\n\ * BWORK (workspace) LOGICAL array, dimension (N)\n\ * Not referenced if SORT = 'N'.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * =1,...,N:\n\ * The QZ iteration failed. (A,B) are not in Schur\n\ * form, but ALPHA(j) and BETA(j) should be correct for\n\ * j=INFO+1,...,N.\n\ * > N: =N+1: other than QZ iteration failed in CHGEQZ\n\ * =N+2: after reordering, roundoff changed values of\n\ * some complex eigenvalues so that leading\n\ * eigenvalues in the Generalized Schur form no\n\ * longer satisfy SELCTG=.TRUE. This could also\n\ * be caused due to scaling.\n\ * =N+3: reordering falied in CTGSEN.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cungrq0000644000175000017500000000571612502223526016520 0ustar uwabamiuwabami--- :name: cungrq :md5sum: d746240bdc6859afd89dd9dca3203e48 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CUNGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CUNGRQ generates an M-by-N complex matrix Q with orthonormal rows,\n\ * which is defined as the last M rows of a product of K elementary\n\ * reflectors of order N\n\ *\n\ * Q = H(1)' H(2)' . . . H(k)'\n\ *\n\ * as returned by CGERQF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. N >= M.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. M >= K >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the (m-k+i)-th row must contain the vector which\n\ * defines the elementary reflector H(i), for i = 1,2,...,k, as\n\ * returned by CGERQF in the last k rows of its array argument\n\ * A.\n\ * On exit, the M-by-N matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) COMPLEX array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by CGERQF.\n\ *\n\ * WORK (workspace/output) COMPLEX 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 has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgerqf0000644000175000017500000000747012502223525016466 0ustar uwabamiuwabami--- :name: cgerqf :md5sum: 4f88b7a5d03b29c9016c5f0e7ecefe20 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - MIN(m,n) - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGERQF computes an RQ factorization of a complex M-by-N matrix A:\n\ * A = R * 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) COMPLEX array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit,\n\ * if m <= n, the upper triangle of the subarray\n\ * A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R;\n\ * if m >= n, the elements on and above the (m-n)-th subdiagonal\n\ * contain the M-by-N upper trapezoidal matrix R;\n\ * the remaining elements, with the array TAU, represent the\n\ * unitary matrix Q as a product of min(m,n) elementary\n\ * 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) COMPLEX array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace/output) COMPLEX 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\n\ * the 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(1)' H(2)' . . . H(k)', 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 complex scalar, and v is a complex vector with\n\ * v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on\n\ * exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i).\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n $ MU, NB, NBMIN, NU, NX\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CGERQ2, CLARFB, CLARFT, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dgbbrd0000644000175000017500000001153412502223526016440 0ustar uwabamiuwabami--- :name: dgbbrd :md5sum: b1d106c514038584d5188d2ac5af4fbe :category: :subroutine :arguments: - vect: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - ncc: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - MIN(m,n) - e: :type: doublereal :intent: output :dims: - MIN(m,n)-1 - q: :type: doublereal :intent: output :dims: - ldq - m - ldq: :type: integer :intent: input - pt: :type: doublereal :intent: output :dims: - ldpt - n - ldpt: :type: integer :intent: input - c: :type: doublereal :intent: input/output :dims: - ldc - ncc - ldc: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 2*MAX(m,n) - info: :type: integer :intent: output :substitutions: m: ldab ldq: "((lsame_(&vect,\"Q\")) || (lsame_(&vect,\"B\"))) ? MAX(1,m) : 1" ldpt: "((lsame_(&vect,\"P\")) || (lsame_(&vect,\"B\"))) ? MAX(1,n) : 1" :fortran_help: " SUBROUTINE DGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, LDQ, PT, LDPT, C, LDC, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGBBRD reduces a real general m-by-n band matrix A to upper\n\ * bidiagonal form B by an orthogonal transformation: Q' * A * P = B.\n\ *\n\ * The routine computes B, and optionally forms Q or P', or computes\n\ * Q'*C for a given matrix C.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * VECT (input) CHARACTER*1\n\ * Specifies whether or not the matrices Q and P' are to be\n\ * formed.\n\ * = 'N': do not form Q or P';\n\ * = 'Q': form Q only;\n\ * = 'P': form P' only;\n\ * = 'B': form both.\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\ * NCC (input) INTEGER\n\ * The number of columns of the matrix C. NCC >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals of the matrix A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals of the matrix A. KU >= 0.\n\ *\n\ * AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * On entry, the m-by-n band matrix A, stored in rows 1 to\n\ * KL+KU+1. The j-th column of A is stored in the j-th column of\n\ * the array AB as follows:\n\ * AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n\ * On exit, A is overwritten by values generated during the\n\ * reduction.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array A. LDAB >= KL+KU+1.\n\ *\n\ * D (output) DOUBLE PRECISION array, dimension (min(M,N))\n\ * The diagonal elements of the bidiagonal matrix B.\n\ *\n\ * E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)\n\ * The superdiagonal elements of the bidiagonal matrix B.\n\ *\n\ * Q (output) DOUBLE PRECISION array, dimension (LDQ,M)\n\ * If VECT = 'Q' or 'B', the m-by-m orthogonal matrix Q.\n\ * If VECT = 'N' or 'P', the array Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q.\n\ * LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.\n\ *\n\ * PT (output) DOUBLE PRECISION array, dimension (LDPT,N)\n\ * If VECT = 'P' or 'B', the n-by-n orthogonal matrix P'.\n\ * If VECT = 'N' or 'Q', the array PT is not referenced.\n\ *\n\ * LDPT (input) INTEGER\n\ * The leading dimension of the array PT.\n\ * LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.\n\ *\n\ * C (input/output) DOUBLE PRECISION array, dimension (LDC,NCC)\n\ * On entry, an m-by-ncc matrix C.\n\ * On exit, C is overwritten by Q'*C.\n\ * C is not referenced if NCC = 0.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C.\n\ * LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (2*max(M,N))\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlanhf0000644000175000017500000002007512502223526016476 0ustar uwabamiuwabami--- :name: zlanhf :md5sum: 70d3555cf9335d87bbaccab9490116b5 :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - work: :type: doublereal :intent: workspace :dims: - lwork :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " DOUBLE PRECISION FUNCTION ZLANHF( NORM, TRANSR, UPLO, N, A, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLANHF returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * complex Hermitian matrix A in RFP format.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * ZLANHF returns the value\n\ *\n\ * ZLANHF = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER\n\ * Specifies the value to be returned in ZLANHF as described\n\ * above.\n\ *\n\ * TRANSR (input) CHARACTER\n\ * Specifies whether the RFP format of A is normal or\n\ * conjugate-transposed format.\n\ * = 'N': RFP format is Normal\n\ * = 'C': RFP format is Conjugate-transposed\n\ *\n\ * UPLO (input) CHARACTER\n\ * On entry, UPLO specifies whether the RFP matrix A came from\n\ * an upper or lower triangular matrix as follows:\n\ *\n\ * UPLO = 'U' or 'u' RFP A came from an upper triangular\n\ * matrix\n\ *\n\ * UPLO = 'L' or 'l' RFP A came from a lower triangular\n\ * matrix\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, ZLANHF is\n\ * set to zero.\n\ *\n\ * A (input) COMPLEX*16 array, dimension ( N*(N+1)/2 );\n\ * On entry, the matrix A in RFP Format.\n\ * RFP Format is described by TRANSR, UPLO and N as follows:\n\ * If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;\n\ * K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If\n\ * TRANSR = 'C' then RFP is the Conjugate-transpose of RFP A\n\ * as defined when TRANSR = 'N'. The contents of RFP A are\n\ * defined by UPLO as follows: If UPLO = 'U' the RFP A\n\ * contains the ( N*(N+1)/2 ) elements of upper packed A\n\ * either in normal or conjugate-transpose Format. If\n\ * UPLO = 'L' the RFP A contains the ( N*(N+1) /2 ) elements\n\ * of lower packed A either in normal or conjugate-transpose\n\ * Format. The LDA of RFP A is (N+1)/2 when TRANSR = 'C'. When\n\ * TRANSR is 'N' the LDA is N+1 when N is even and is N when\n\ * is odd. See the Note below for more details.\n\ * Unchanged on exit.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK),\n\ * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n\ * WORK is not referenced.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * We first consider Standard Packed Format when N is even.\n\ * We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * conjugate-transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * conjugate-transpose of the last three columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- --\n\ * 03 04 05 33 43 53\n\ * -- --\n\ * 13 14 15 00 44 54\n\ * --\n\ * 23 24 25 10 11 55\n\ *\n\ * 33 34 35 20 21 22\n\ * --\n\ * 00 44 45 30 31 32\n\ * -- --\n\ * 01 11 55 40 41 42\n\ * -- -- --\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We next consider Standard Packed Format when N is odd.\n\ * We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * conjugate-transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * conjugate-transpose of the last two columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- --\n\ * 02 03 04 00 33 43\n\ * --\n\ * 12 13 14 10 11 44\n\ *\n\ * 22 23 24 20 21 22\n\ * --\n\ * 00 33 34 30 31 32\n\ * -- --\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- --\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sorgbr0000644000175000017500000001046012502223526016507 0ustar uwabamiuwabami--- :name: sorgbr :md5sum: 04941c7af799ded94e7405ffcf964cc8 :category: :subroutine :arguments: - vect: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - MIN(m,k) - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SORGBR generates one of the real orthogonal matrices Q or P**T\n\ * determined by SGEBRD when reducing a real matrix A to bidiagonal\n\ * form: A = Q * B * P**T. Q and P**T are defined as products of\n\ * elementary reflectors H(i) or G(i) respectively.\n\ *\n\ * If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q\n\ * is of order M:\n\ * if m >= k, Q = H(1) H(2) . . . H(k) and SORGBR returns the first n\n\ * columns of Q, where m >= n >= k;\n\ * if m < k, Q = H(1) H(2) . . . H(m-1) and SORGBR returns Q as an\n\ * M-by-M matrix.\n\ *\n\ * If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T\n\ * is of order N:\n\ * if k < n, P**T = G(k) . . . G(2) G(1) and SORGBR returns the first m\n\ * rows of P**T, where n >= m >= k;\n\ * if k >= n, P**T = G(n-1) . . . G(2) G(1) and SORGBR returns P**T as\n\ * an N-by-N matrix.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * VECT (input) CHARACTER*1\n\ * Specifies whether the matrix Q or the matrix P**T is\n\ * required, as defined in the transformation applied by SGEBRD:\n\ * = 'Q': generate Q;\n\ * = 'P': generate P**T.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q or P**T to be returned.\n\ * M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q or P**T to be returned.\n\ * N >= 0.\n\ * If VECT = 'Q', M >= N >= min(M,K);\n\ * if VECT = 'P', N >= M >= min(N,K).\n\ *\n\ * K (input) INTEGER\n\ * If VECT = 'Q', the number of columns in the original M-by-K\n\ * matrix reduced by SGEBRD.\n\ * If VECT = 'P', the number of rows in the original K-by-N\n\ * matrix reduced by SGEBRD.\n\ * K >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the vectors which define the elementary reflectors,\n\ * as returned by SGEBRD.\n\ * On exit, the M-by-N matrix Q or P**T.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) REAL array, dimension\n\ * (min(M,K)) if VECT = 'Q'\n\ * (min(N,K)) if VECT = 'P'\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i) or G(i), which determines Q or P**T, as\n\ * returned by SGEBRD in its array argument TAUQ or TAUP.\n\ *\n\ * WORK (workspace/output) REAL 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,min(M,N)).\n\ * For optimum performance LWORK >= min(M,N)*NB, where NB\n\ * is the 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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sla_gbrpvgrw0000644000175000017500000000537512502223526017721 0ustar uwabamiuwabami--- :name: sla_gbrpvgrw :md5sum: 03f8d3a9809ecee2db4307d6345927c2 :category: :function :type: real :arguments: - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ncols: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: real :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input :substitutions: {} :fortran_help: " REAL FUNCTION SLA_GBRPVGRW( N, KL, KU, NCOLS, AB, LDAB, AFB, LDAFB )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLA_GBRPVGRW computes the reciprocal pivot growth factor\n\ * norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n\ * much less than 1, the stability of the LU factorization of the\n\ * (equilibrated) matrix A could be poor. This also means that the\n\ * solution X, estimated condition numbers, and error bounds could be\n\ * unreliable.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * NCOLS (input) INTEGER\n\ * The number of columns of the matrix A. NCOLS >= 0.\n\ *\n\ * AB (input) REAL array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * AFB (input) REAL array, dimension (LDAFB,N)\n\ * Details of the LU factorization of the band matrix A, as\n\ * computed by SGBTRF. U is stored as an upper triangular\n\ * band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n\ * and the multipliers used during the factorization are stored\n\ * in rows KL+KU+2 to 2*KL+KU+1.\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J, KD\n REAL AMAX, UMAX, RPVGRW\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cheevd0000644000175000017500000001545112502223525016453 0ustar uwabamiuwabami--- :name: cheevd :md5sum: 155bc4bab8cfde8184298cbef514de86 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n+1 : lsame_(&jobz,\"V\") ? 2*n+n*n : 0" - rwork: :type: real :intent: output :dims: - MAX(1,lrwork) - lrwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n+1 : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHEEVD computes all eigenvalues and, optionally, eigenvectors of a\n\ * complex Hermitian matrix A. If eigenvectors are desired, it uses a\n\ * divide and conquer algorithm.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA, N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of A contains the\n\ * upper triangular part of the matrix A. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of A contains\n\ * the lower triangular part of the matrix A.\n\ * On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n\ * orthonormal eigenvectors of the matrix A.\n\ * If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n\ * or the upper triangle (if UPLO='U') of A, including the\n\ * diagonal, is destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of the array WORK.\n\ * If N <= 1, LWORK must be at least 1.\n\ * If JOBZ = 'N' and N > 1, LWORK must be at least N + 1.\n\ * If JOBZ = 'V' and N > 1, LWORK must be at least 2*N + N**2.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the optimal sizes of the WORK, RWORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * RWORK (workspace/output) REAL array,\n\ * dimension (LRWORK)\n\ * On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n\ *\n\ * LRWORK (input) INTEGER\n\ * The dimension of the array RWORK.\n\ * If N <= 1, LRWORK must be at least 1.\n\ * If JOBZ = 'N' and N > 1, LRWORK must be at least N.\n\ * If JOBZ = 'V' and N > 1, LRWORK must be at least\n\ * 1 + 5*N + 2*N**2.\n\ *\n\ * If LRWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK.\n\ * If N <= 1, LIWORK must be at least 1.\n\ * If JOBZ = 'N' and N > 1, LIWORK must be at least 1.\n\ * If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK 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 and JOBZ = 'N', then the algorithm failed\n\ * to converge; i off-diagonal elements of an intermediate\n\ * tridiagonal form did not converge to zero;\n\ * if INFO = i and JOBZ = 'V', then the algorithm failed\n\ * to compute an eigenvalue while working on the submatrix\n\ * lying in rows and columns INFO/(N+1) through\n\ * mod(INFO,N+1).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Jeff Rutter, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ *\n\ * Modified description of INFO. Sven, 16 Feb 05.\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhegvd0000644000175000017500000002140312502223526016477 0ustar uwabamiuwabami--- :name: zhegvd :md5sum: c08fb41eb03abb64ff3169f9ef5e7f3d :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n+1 : lsame_(&jobz,\"V\") ? 2*n+n*n : 0" - rwork: :type: doublereal :intent: output :dims: - MAX(1,lrwork) - lrwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZHEGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHEGVD computes all the eigenvalues, and optionally, the eigenvectors\n\ * of a complex generalized Hermitian-definite eigenproblem, of the form\n\ * A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n\ * B are assumed to be Hermitian and B is also positive definite.\n\ * If eigenvectors are desired, it uses a divide and conquer algorithm.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * Specifies the problem type to be solved:\n\ * = 1: A*x = (lambda)*B*x\n\ * = 2: A*B*x = (lambda)*x\n\ * = 3: B*A*x = (lambda)*x\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA, N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of A contains the\n\ * upper triangular part of the matrix A. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of A contains\n\ * the lower triangular part of the matrix A.\n\ *\n\ * On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n\ * matrix Z of eigenvectors. The eigenvectors are normalized\n\ * as follows:\n\ * if ITYPE = 1 or 2, Z**H*B*Z = I;\n\ * if ITYPE = 3, Z**H*inv(B)*Z = I.\n\ * If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n\ * or the lower triangle (if UPLO='L') of A, including the\n\ * diagonal, is destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB, N)\n\ * On entry, the Hermitian matrix B. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of B contains the\n\ * upper triangular part of the matrix B. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of B contains\n\ * the lower triangular part of the matrix B.\n\ *\n\ * On exit, if INFO <= N, the part of B containing the matrix is\n\ * overwritten by the triangular factor U or L from the Cholesky\n\ * factorization B = U**H*U or B = L*L**H.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of the array WORK.\n\ * If N <= 1, LWORK >= 1.\n\ * If JOBZ = 'N' and N > 1, LWORK >= N + 1.\n\ * If JOBZ = 'V' and N > 1, LWORK >= 2*N + N**2.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the optimal sizes of the WORK, RWORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * RWORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))\n\ * On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n\ *\n\ * LRWORK (input) INTEGER\n\ * The dimension of the array RWORK.\n\ * If N <= 1, LRWORK >= 1.\n\ * If JOBZ = 'N' and N > 1, LRWORK >= N.\n\ * If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.\n\ *\n\ * If LRWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK.\n\ * If N <= 1, LIWORK >= 1.\n\ * If JOBZ = 'N' and N > 1, LIWORK >= 1.\n\ * If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK 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: ZPOTRF or ZHEEVD returned an error code:\n\ * <= N: if INFO = i and JOBZ = 'N', then the algorithm\n\ * failed to converge; i off-diagonal elements of an\n\ * intermediate tridiagonal form did not converge to\n\ * zero;\n\ * if INFO = i and JOBZ = 'V', then the algorithm\n\ * failed to compute an eigenvalue while working on\n\ * the submatrix lying in rows and columns INFO/(N+1)\n\ * through mod(INFO,N+1);\n\ * > N: if INFO = N + i, for 1 <= i <= N, then the leading\n\ * minor of order i of B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n\ *\n\ * Modified so that no backsubstitution is performed if ZHEEVD fails to\n\ * converge (NEIG in old code could be greater than N causing out of\n\ * bounds reference to A - reported by Ralf Meyer). Also corrected the\n\ * description of INFO and the test on ITYPE. Sven, 16 Feb 05.\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dtpcon0000644000175000017500000000553512502223526016507 0ustar uwabamiuwabami--- :name: dtpcon :md5sum: 958d9db19db171876d7345b6cb787b8a :category: :subroutine :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - ldap - rcond: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE DTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTPCON estimates the reciprocal of the condition number of a packed\n\ * triangular matrix A, in either the 1-norm or the infinity-norm.\n\ *\n\ * The norm of A is computed and an estimate is obtained for\n\ * norm(inv(A)), then the reciprocal of the condition number is\n\ * computed as\n\ * RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies whether the 1-norm condition number or the\n\ * infinity-norm condition number is required:\n\ * = '1' or 'O': 1-norm;\n\ * = 'I': Infinity-norm.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * The upper or lower triangular matrix A, packed columnwise in\n\ * a linear array. The j-th column of A is stored in the array\n\ * AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ * If DIAG = 'U', the diagonal elements of A are not referenced\n\ * and are assumed to be 1.\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(norm(A) * norm(inv(A))).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zppsvx0000644000175000017500000002612512502223526016570 0ustar uwabamiuwabami--- :name: zppsvx :md5sum: 9992fe999469ef1a85a5d74b06ea05d7 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - afp: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - equed: :type: char :intent: input/output - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE ZPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPPSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to\n\ * compute the solution to a complex system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N Hermitian positive definite matrix stored in\n\ * packed format and X and B are N-by-NRHS matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', real scaling factors are computed to equilibrate\n\ * the system:\n\ * diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n\ *\n\ * 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n\ * factor the matrix A (after equilibration if FACT = 'E') as\n\ * A = U'* U , if UPLO = 'U', or\n\ * A = L * L', if UPLO = 'L',\n\ * where U is an upper triangular matrix, L is a lower triangular\n\ * matrix, and ' indicates conjugate transpose.\n\ *\n\ * 3. If the leading i-by-i principal minor is not positive definite,\n\ * then the routine returns with INFO = i. Otherwise, the factored\n\ * form of A is used to estimate the condition number of the matrix\n\ * A. If the reciprocal of the condition number is less than machine\n\ * precision, INFO = N+1 is returned as a warning, but the routine\n\ * still goes on to solve for X and compute error bounds as\n\ * described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(S) so that it solves the original system before\n\ * equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AFP contains the factored form of A.\n\ * If EQUED = 'Y', the matrix A has been equilibrated\n\ * with scaling factors given by S. AP and AFP will not\n\ * be modified.\n\ * = 'N': The matrix A will be copied to AFP and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AFP and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * A, packed columnwise in a linear array, except if FACT = 'F'\n\ * and EQUED = 'Y', then A must contain the equilibrated matrix\n\ * diag(S)*A*diag(S). The j-th column of A is stored in the\n\ * array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ * See below for further details. A is not modified if\n\ * FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n\ *\n\ * On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n\ * diag(S)*A*diag(S).\n\ *\n\ * AFP (input or output) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * If FACT = 'F', then AFP is an input argument and on entry\n\ * contains the triangular factor U or L from the Cholesky\n\ * factorization A = U**H*U or A = L*L**H, in the same storage\n\ * format as A. If EQUED .ne. 'N', then AFP is the factored\n\ * form of the equilibrated matrix A.\n\ *\n\ * If FACT = 'N', then AFP is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U**H*U or A = L*L**H of the original\n\ * matrix A.\n\ *\n\ * If FACT = 'E', then AFP is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U**H*U or A = L*L**H of the equilibrated\n\ * matrix A (see the description of AP for the form of the\n\ * equilibrated matrix).\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'Y': Equilibration was done, i.e., A has been replaced by\n\ * diag(S) * A * diag(S).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * S (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The scale factors for A; not accessed if EQUED = 'N'. S is\n\ * an input argument if FACT = 'F'; otherwise, S is an output\n\ * argument. If FACT = 'F' and EQUED = 'Y', each element of S\n\ * must be positive.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n\ * B is overwritten by diag(S) * B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n\ * the original system of equations. Note that if EQUED = 'Y',\n\ * A and B are modified on exit, and the solution to the\n\ * equilibrated system is inv(diag(S))*X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A after equilibration (if done). If RCOND is less than the\n\ * machine precision (in particular, if RCOND = 0), the matrix\n\ * is singular to working precision. This condition is\n\ * indicated by a return code of INFO > 0.\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\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, and i is\n\ * <= N: the leading minor of order i of A is\n\ * not positive definite, so the factorization\n\ * could not be completed, and the solution has not\n\ * been computed. RCOND = 0 is returned.\n\ * = N+1: U is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The packed storage scheme is illustrated by the following example\n\ * when N = 4, UPLO = 'U':\n\ *\n\ * Two-dimensional storage of the Hermitian matrix A:\n\ *\n\ * a11 a12 a13 a14\n\ * a22 a23 a24\n\ * a33 a34 (aij = conjg(aji))\n\ * a44\n\ *\n\ * Packed storage of the upper triangle of A:\n\ *\n\ * AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dggsvd0000644000175000017500000002443412502223526016475 0ustar uwabamiuwabami--- :name: dggsvd :md5sum: 478a765175c3dec9fe66f8749e4eba83 :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobv: :type: char :intent: input - jobq: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - p: :type: integer :intent: input - k: :type: integer :intent: output - l: :type: integer :intent: output - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alpha: :type: doublereal :intent: output :dims: - n - beta: :type: doublereal :intent: output :dims: - n - u: :type: doublereal :intent: output :dims: - ldu - m - ldu: :type: integer :intent: input - v: :type: doublereal :intent: output :dims: - ldv - p - ldv: :type: integer :intent: input - q: :type: doublereal :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(3*n,m - p)+n - iwork: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: m: lda p: ldb ldq: "lsame_(&jobq,\"Q\") ? MAX(1,n) : 1" ldu: "lsame_(&jobu,\"U\") ? MAX(1,m) : 1" ldv: "lsame_(&jobv,\"V\") ? MAX(1,p) : 1" :fortran_help: " SUBROUTINE DGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGGSVD computes the generalized singular value decomposition (GSVD)\n\ * of an M-by-N real matrix A and P-by-N real matrix B:\n\ *\n\ * U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R )\n\ *\n\ * where U, V and Q are orthogonal matrices, and Z' is the transpose\n\ * of Z. Let K+L = the effective numerical rank of the matrix (A',B')',\n\ * then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and\n\ * D2 are M-by-(K+L) and P-by-(K+L) \"diagonal\" matrices and of the\n\ * following structures, respectively:\n\ *\n\ * If M-K-L >= 0,\n\ *\n\ * K L\n\ * D1 = K ( I 0 )\n\ * L ( 0 C )\n\ * M-K-L ( 0 0 )\n\ *\n\ * K L\n\ * D2 = L ( 0 S )\n\ * P-L ( 0 0 )\n\ *\n\ * N-K-L K L\n\ * ( 0 R ) = K ( 0 R11 R12 )\n\ * L ( 0 0 R22 )\n\ *\n\ * where\n\ *\n\ * C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n\ * S = diag( BETA(K+1), ... , BETA(K+L) ),\n\ * C**2 + S**2 = I.\n\ *\n\ * R is stored in A(1:K+L,N-K-L+1:N) on exit.\n\ *\n\ * If M-K-L < 0,\n\ *\n\ * K M-K K+L-M\n\ * D1 = K ( I 0 0 )\n\ * M-K ( 0 C 0 )\n\ *\n\ * K M-K K+L-M\n\ * D2 = M-K ( 0 S 0 )\n\ * K+L-M ( 0 0 I )\n\ * P-L ( 0 0 0 )\n\ *\n\ * N-K-L K M-K K+L-M\n\ * ( 0 R ) = K ( 0 R11 R12 R13 )\n\ * M-K ( 0 0 R22 R23 )\n\ * K+L-M ( 0 0 0 R33 )\n\ *\n\ * where\n\ *\n\ * C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n\ * S = diag( BETA(K+1), ... , BETA(M) ),\n\ * C**2 + S**2 = I.\n\ *\n\ * (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored\n\ * ( 0 R22 R23 )\n\ * in B(M-K+1:L,N+M-K-L+1:N) on exit.\n\ *\n\ * The routine computes C, S, R, and optionally the orthogonal\n\ * transformation matrices U, V and Q.\n\ *\n\ * In particular, if B is an N-by-N nonsingular matrix, then the GSVD of\n\ * A and B implicitly gives the SVD of A*inv(B):\n\ * A*inv(B) = U*(D1*inv(D2))*V'.\n\ * If ( A',B')' has orthonormal columns, then the GSVD of A and B is\n\ * also equal to the CS decomposition of A and B. Furthermore, the GSVD\n\ * can be used to derive the solution of the eigenvalue problem:\n\ * A'*A x = lambda* B'*B x.\n\ * In some literature, the GSVD of A and B is presented in the form\n\ * U'*A*X = ( 0 D1 ), V'*B*X = ( 0 D2 )\n\ * where U and V are orthogonal and X is nonsingular, D1 and D2 are\n\ * ``diagonal''. The former GSVD form can be converted to the latter\n\ * form by taking the nonsingular matrix X as\n\ *\n\ * X = Q*( I 0 )\n\ * ( 0 inv(R) ).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBU (input) CHARACTER*1\n\ * = 'U': Orthogonal matrix U is computed;\n\ * = 'N': U is not computed.\n\ *\n\ * JOBV (input) CHARACTER*1\n\ * = 'V': Orthogonal matrix V is computed;\n\ * = 'N': V is not computed.\n\ *\n\ * JOBQ (input) CHARACTER*1\n\ * = 'Q': Orthogonal matrix Q is computed;\n\ * = 'N': Q is not computed.\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 matrices A and B. N >= 0.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows of the matrix B. P >= 0.\n\ *\n\ * K (output) INTEGER\n\ * L (output) INTEGER\n\ * On exit, K and L specify the dimension of the subblocks\n\ * described in the Purpose section.\n\ * K + L = effective numerical rank of (A',B')'.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, A contains the triangular matrix R, or part of R.\n\ * See Purpose for details.\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,N)\n\ * On entry, the P-by-N matrix B.\n\ * On exit, B contains the triangular matrix R if M-K-L < 0.\n\ * See Purpose for details.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,P).\n\ *\n\ * ALPHA (output) DOUBLE PRECISION array, dimension (N)\n\ * BETA (output) DOUBLE PRECISION array, dimension (N)\n\ * On exit, ALPHA and BETA contain the generalized singular\n\ * value pairs of A and B;\n\ * ALPHA(1:K) = 1,\n\ * BETA(1:K) = 0,\n\ * and if M-K-L >= 0,\n\ * ALPHA(K+1:K+L) = C,\n\ * BETA(K+1:K+L) = S,\n\ * or if M-K-L < 0,\n\ * ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0\n\ * BETA(K+1:M) =S, BETA(M+1:K+L) =1\n\ * and\n\ * ALPHA(K+L+1:N) = 0\n\ * BETA(K+L+1:N) = 0\n\ *\n\ * U (output) DOUBLE PRECISION array, dimension (LDU,M)\n\ * If JOBU = 'U', U contains the M-by-M orthogonal matrix U.\n\ * If JOBU = 'N', U is not referenced.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= max(1,M) if\n\ * JOBU = 'U'; LDU >= 1 otherwise.\n\ *\n\ * V (output) DOUBLE PRECISION array, dimension (LDV,P)\n\ * If JOBV = 'V', V contains the P-by-P orthogonal matrix V.\n\ * If JOBV = 'N', V is not referenced.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V. LDV >= max(1,P) if\n\ * JOBV = 'V'; LDV >= 1 otherwise.\n\ *\n\ * Q (output) DOUBLE PRECISION array, dimension (LDQ,N)\n\ * If JOBQ = 'Q', Q contains the N-by-N orthogonal matrix Q.\n\ * If JOBQ = 'N', Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N) if\n\ * JOBQ = 'Q'; LDQ >= 1 otherwise.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array,\n\ * dimension (max(3*N,M,P)+N)\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (N)\n\ * On exit, IWORK stores the sorting information. More\n\ * precisely, the following loop will sort ALPHA\n\ * for I = K+1, min(M,K+L)\n\ * swap ALPHA(I) and ALPHA(IWORK(I))\n\ * endfor\n\ * such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N).\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 = 1, the Jacobi-type procedure failed to\n\ * converge. For further details, see subroutine DTGSJA.\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * TOLA DOUBLE PRECISION\n\ * TOLB DOUBLE PRECISION\n\ * TOLA and TOLB are the thresholds to determine the effective\n\ * rank of (A',B')'. Generally, they are set to\n\ * TOLA = MAX(M,N)*norm(A)*MAZHEPS,\n\ * TOLB = MAX(P,N)*norm(B)*MAZHEPS.\n\ * The size of TOLA and TOLB may affect the size of backward\n\ * errors of the decomposition.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * 2-96 Based on modifications by\n\ * Ming Gu and Huan Ren, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL WANTQ, WANTU, WANTV\n INTEGER I, IBND, ISUB, J, NCYCLE\n DOUBLE PRECISION ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n DOUBLE PRECISION DLAMCH, DLANGE\n EXTERNAL LSAME, DLAMCH, DLANGE\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DCOPY, DGGSVP, DTGSJA, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sgbsv0000644000175000017500000001144212502223526016336 0ustar uwabamiuwabami--- :name: sgbsv :md5sum: 6196dc1254d6b974ab34de77816b9fe2 :category: :subroutine :arguments: - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGBSV computes the solution to a real system of linear equations\n\ * A * X = B, where A is a band matrix of order N with KL subdiagonals\n\ * and KU superdiagonals, and X and B are N-by-NRHS matrices.\n\ *\n\ * The LU decomposition with partial pivoting and row interchanges is\n\ * used to factor A as A = L * U, where L is a product of permutation\n\ * and unit lower triangular matrices with KL subdiagonals, and U is\n\ * upper triangular with KL+KU superdiagonals. The factored form of A\n\ * is then used to solve the system of equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AB (input/output) REAL array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows KL+1 to\n\ * 2*KL+KU+1; rows 1 to KL of the array need not be set.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)\n\ * On exit, details of the factorization: U is stored as an\n\ * upper triangular band matrix with KL+KU superdiagonals in\n\ * rows 1 to KL+KU+1, and the multipliers used during the\n\ * factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n\ * See below for further details.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * The pivot indices that define the permutation matrix P;\n\ * row i of the matrix was interchanged with row IPIV(i).\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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, U(i,i) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, and the solution has not been computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * M = N = 6, KL = 2, KU = 1:\n\ *\n\ * On entry: On exit:\n\ *\n\ * * * * + + + * * * u14 u25 u36\n\ * * * + + + + * * u13 u24 u35 u46\n\ * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n\ * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n\ * a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n\ * a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n\ *\n\ * Array elements marked * are not used by the routine; elements marked\n\ * + need not be set on entry, but are required by the routine to store\n\ * elements of U because of fill-in resulting from the row interchanges.\n\ *\n\ * =====================================================================\n\ *\n\ * .. External Subroutines ..\n EXTERNAL SGBTRF, SGBTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slabrd0000644000175000017500000001447712502223526016474 0ustar uwabamiuwabami--- :name: slabrd :md5sum: 2b3826069fc3770fe2db03223e112bbc :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: real :intent: output :dims: - MAX(1,nb) - e: :type: real :intent: output :dims: - MAX(1,nb) - tauq: :type: real :intent: output :dims: - MAX(1,nb) - taup: :type: real :intent: output :dims: - MAX(1,nb) - x: :type: real :intent: output :dims: - ldx - MAX(1,nb) - ldx: :type: integer :intent: input - y: :type: real :intent: output :dims: - ldy - MAX(1,nb) - ldy: :type: integer :intent: input :substitutions: ldx: m ldy: n :fortran_help: " SUBROUTINE SLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, LDY )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLABRD reduces the first NB rows and columns of a real general\n\ * m by n matrix A to upper or lower bidiagonal form by an orthogonal\n\ * transformation Q' * A * P, and returns the matrices X and Y which\n\ * are needed to apply the transformation to the unreduced part of A.\n\ *\n\ * If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower\n\ * bidiagonal form.\n\ *\n\ * This is an auxiliary routine called by SGEBRD\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows in the matrix A.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns in the matrix A.\n\ *\n\ * NB (input) INTEGER\n\ * The number of leading rows and columns of A to be reduced.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the m by n general matrix to be reduced.\n\ * On exit, the first NB rows and columns of the matrix are\n\ * overwritten; the rest of the array is unchanged.\n\ * If m >= n, elements on and below the diagonal in the first NB\n\ * columns, with the array TAUQ, represent the orthogonal\n\ * matrix Q as a product of elementary reflectors; and\n\ * elements above the diagonal in the first NB rows, with the\n\ * array TAUP, represent the orthogonal matrix P as a product\n\ * of elementary reflectors.\n\ * If m < n, elements below the diagonal in the first NB\n\ * columns, with the array TAUQ, represent the orthogonal\n\ * matrix Q as a product of elementary reflectors, and\n\ * elements on and above the diagonal in the first NB rows,\n\ * with the array TAUP, represent the orthogonal matrix P as\n\ * a product of elementary reflectors.\n\ * See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * D (output) REAL array, dimension (NB)\n\ * The diagonal elements of the first NB rows and columns of\n\ * the reduced matrix. D(i) = A(i,i).\n\ *\n\ * E (output) REAL array, dimension (NB)\n\ * The off-diagonal elements of the first NB rows and columns of\n\ * the reduced matrix.\n\ *\n\ * TAUQ (output) REAL array dimension (NB)\n\ * The scalar factors of the elementary reflectors which\n\ * represent the orthogonal matrix Q. See Further Details.\n\ *\n\ * TAUP (output) REAL array, dimension (NB)\n\ * The scalar factors of the elementary reflectors which\n\ * represent the orthogonal matrix P. See Further Details.\n\ *\n\ * X (output) REAL array, dimension (LDX,NB)\n\ * The m-by-nb matrix X required to update the unreduced part\n\ * of A.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= M.\n\ *\n\ * Y (output) REAL array, dimension (LDY,NB)\n\ * The n-by-nb matrix Y required to update the unreduced part\n\ * of A.\n\ *\n\ * LDY (input) INTEGER\n\ * The leading dimension of the array Y. LDY >= N.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The matrices Q and P are represented as products of elementary\n\ * reflectors:\n\ *\n\ * Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb)\n\ *\n\ * Each H(i) and G(i) has the form:\n\ *\n\ * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n\ *\n\ * where tauq and taup are real scalars, and v and u are real vectors.\n\ *\n\ * If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in\n\ * A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in\n\ * A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n\ *\n\ * If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in\n\ * A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in\n\ * A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n\ *\n\ * The elements of the vectors v and u together form the m-by-nb matrix\n\ * V and the nb-by-n matrix U' which are needed, with X and Y, to apply\n\ * the transformation to the unreduced part of the matrix, using a block\n\ * update of the form: A := A - V*Y' - X*U'.\n\ *\n\ * The contents of A on exit are illustrated by the following examples\n\ * with nb = 2:\n\ *\n\ * m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n\ *\n\ * ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 )\n\ * ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 )\n\ * ( v1 v2 a a a ) ( v1 1 a a a a )\n\ * ( v1 v2 a a a ) ( v1 v2 a a a a )\n\ * ( v1 v2 a a a ) ( v1 v2 a a a a )\n\ * ( v1 v2 a a a )\n\ *\n\ * where a denotes an element of the original matrix which is unchanged,\n\ * vi denotes an element of the vector defining H(i), and ui an element\n\ * of the vector defining G(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cungql0000644000175000017500000000573412502223526016512 0ustar uwabamiuwabami--- :name: cungql :md5sum: c47a9b1529f67e9caf6cd88a84aaaa64 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CUNGQL generates an M-by-N complex matrix Q with orthonormal columns,\n\ * which is defined as the last N columns of a product of K elementary\n\ * reflectors of order M\n\ *\n\ * Q = H(k) . . . H(2) H(1)\n\ *\n\ * as returned by CGEQLF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. M >= N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. N >= K >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the (n-k+i)-th column must contain the vector which\n\ * defines the elementary reflector H(i), for i = 1,2,...,k, as\n\ * returned by CGEQLF in the last k columns of its array\n\ * argument A.\n\ * On exit, the M-by-N matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) COMPLEX array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by CGEQLF.\n\ *\n\ * WORK (workspace/output) COMPLEX 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,N).\n\ * For optimum performance LWORK >= N*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 has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgelsd0000644000175000017500000001740512502223526016507 0ustar uwabamiuwabami--- :name: zgelsd :md5sum: 3cda6a4e059bdc95d6c1841204c3d144 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - MIN(m,n) - rcond: :type: doublereal :intent: input - rank: :type: integer :intent: output - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "m>=n ? 2*n+n*nrhs : 2*m+m*nrhs" - rwork: :type: doublereal :intent: workspace :dims: - MAX(1,lrwork) - iwork: :type: integer :intent: workspace :dims: - MAX(1,liwork) - info: :type: integer :intent: output :substitutions: m: lda ldb: MAX(m,n) c__9: "9" c__0: "0" liwork: MAX(1,3*(MIN(m,n))*nlvl+11*(MIN(m,n))) lrwork: "m>=n ? 10*n+2*n*smlsiz+8*n*nlvl+3*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1) : 10*m+2*m*smlsiz+8*m*nlvl+2*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1)" nlvl: MAX(0,(int)(log(1.0*MIN(m,n)/(smlsiz+1))/log(2.0))) smlsiz: ilaenv_(&c__9,"ZGELSD"," ",&c__0,&c__0,&c__0,&c__0) :fortran_help: " SUBROUTINE ZGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, RWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGELSD computes the minimum-norm solution to a real linear least\n\ * squares problem:\n\ * minimize 2-norm(| b - A*x |)\n\ * using the singular value decomposition (SVD) of A. A is an M-by-N\n\ * matrix which may be rank-deficient.\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\ * The problem is solved in three steps:\n\ * (1) Reduce the coefficient matrix A to bidiagonal form with\n\ * Householder tranformations, reducing the original problem\n\ * into a \"bidiagonal least squares problem\" (BLS)\n\ * (2) Solve the BLS using a divide and conquer approach.\n\ * (3) Apply back all the Householder tranformations to solve\n\ * the original least squares problem.\n\ *\n\ * The effective rank of A is determined by treating as zero those\n\ * singular values which are less than RCOND times the largest singular\n\ * value.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\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\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, A has been destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the M-by-NRHS right hand side matrix B.\n\ * On exit, B is overwritten by the N-by-NRHS solution matrix X.\n\ * If m >= n and RANK = n, the residual sum-of-squares for\n\ * the solution in the i-th column is given by the sum of\n\ * squares of the modulus of elements n+1:m in that column.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,M,N).\n\ *\n\ * S (output) DOUBLE PRECISION array, dimension (min(M,N))\n\ * The singular values of A in decreasing order.\n\ * The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n\ *\n\ * RCOND (input) DOUBLE PRECISION\n\ * RCOND is used to determine the effective rank of A.\n\ * Singular values S(i) <= RCOND*S(1) are treated as zero.\n\ * If RCOND < 0, machine precision is used instead.\n\ *\n\ * RANK (output) INTEGER\n\ * The effective rank of A, i.e., the number of singular values\n\ * which are greater than RCOND*S(1).\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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 must be at least 1.\n\ * The exact minimum amount of workspace needed depends on M,\n\ * N and NRHS. As long as LWORK is at least\n\ * 2*N + N*NRHS\n\ * if M is greater than or equal to N or\n\ * 2*M + M*NRHS\n\ * if M is less than N, the code will execute correctly.\n\ * For good performance, LWORK should generally be larger.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the optimal size of the array WORK and the\n\ * minimum sizes of the arrays RWORK and IWORK, and returns\n\ * these values as the first entries of the WORK, RWORK and\n\ * IWORK arrays, and no error message related to LWORK is issued\n\ * by XERBLA.\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))\n\ * LRWORK >=\n\ * 10*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS +\n\ * MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS )\n\ * if M is greater than or equal to N or\n\ * 10*M + 2*M*SMLSIZ + 8*M*NLVL + 3*SMLSIZ*NRHS +\n\ * MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS )\n\ * if M is less than N, the code will execute correctly.\n\ * SMLSIZ is returned by ILAENV and is equal to the maximum\n\ * size of the subproblems at the bottom of the computation\n\ * tree (usually about 25), and\n\ * NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )\n\ * On exit, if INFO = 0, RWORK(1) returns the minimum LRWORK.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))\n\ * LIWORK >= max(1, 3*MINMN*NLVL + 11*MINMN),\n\ * where MINMN = MIN( M,N ).\n\ * On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * > 0: the algorithm for computing the SVD failed to converge;\n\ * if INFO = i, i off-diagonal elements of an intermediate\n\ * bidiagonal form did not converge to zero.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ming Gu and Ren-Cang Li, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/spbequ0000644000175000017500000000617412502223526016517 0ustar uwabamiuwabami--- :name: spbequ :md5sum: fcd294fd62071c4dcdc44bab541045fc :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - s: :type: real :intent: output :dims: - n - scond: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPBEQU computes row and column scalings intended to equilibrate a\n\ * symmetric positive definite band matrix A and reduce its condition\n\ * number (with respect to the two-norm). S contains the scale factors,\n\ * S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n\ * elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n\ * choice of S puts the condition number of B within a factor N of the\n\ * smallest possible condition number over all possible diagonal\n\ * scalings.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangular of A is stored;\n\ * = 'L': Lower triangular of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input) REAL array, dimension (LDAB,N)\n\ * The upper or lower triangle of the symmetric band matrix A,\n\ * stored in the first KD+1 rows of the array. The j-th column\n\ * of A is stored in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array A. LDAB >= KD+1.\n\ *\n\ * S (output) REAL array, dimension (N)\n\ * If INFO = 0, S contains the scale factors for A.\n\ *\n\ * SCOND (output) REAL\n\ * If INFO = 0, S contains the ratio of the smallest S(i) to\n\ * the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n\ * large nor too small, it is not worth scaling by S.\n\ *\n\ * AMAX (output) REAL\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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 is nonpositive.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clals00000644000175000017500000001667312502223525016402 0ustar uwabamiuwabami--- :name: clals0 :md5sum: ad7ab4b461d9859a4b3030cba44206c0 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - nl: :type: integer :intent: input - nr: :type: integer :intent: input - sqre: :type: integer :intent: input - nrhs: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - bx: :type: complex :intent: workspace :dims: - ldbx - nrhs - ldbx: :type: integer :intent: input - perm: :type: integer :intent: input :dims: - n - givptr: :type: integer :intent: input - givcol: :type: integer :intent: input :dims: - ldgcol - "2" - ldgcol: :type: integer :intent: input - givnum: :type: real :intent: input :dims: - ldgnum - "2" - ldgnum: :type: integer :intent: input - poles: :type: real :intent: input :dims: - ldgnum - "2" - difl: :type: real :intent: input :dims: - k - difr: :type: real :intent: input :dims: - ldgnum - "2" - z: :type: real :intent: input :dims: - k - k: :type: integer :intent: input - c: :type: real :intent: input - s: :type: real :intent: input - rwork: :type: real :intent: workspace :dims: - k*(1+nrhs) + 2*nrhs - info: :type: integer :intent: output :substitutions: ldbx: n :fortran_help: " SUBROUTINE CLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLALS0 applies back the multiplying factors of either the left or the\n\ * right singular vector matrix of a diagonal matrix appended by a row\n\ * to the right hand side matrix B in solving the least squares problem\n\ * using the divide-and-conquer SVD approach.\n\ *\n\ * For the left singular vector matrix, three types of orthogonal\n\ * matrices are involved:\n\ *\n\ * (1L) Givens rotations: the number of such rotations is GIVPTR; the\n\ * pairs of columns/rows they were applied to are stored in GIVCOL;\n\ * and the C- and S-values of these rotations are stored in GIVNUM.\n\ *\n\ * (2L) Permutation. The (NL+1)-st row of B is to be moved to the first\n\ * row, and for J=2:N, PERM(J)-th row of B is to be moved to the\n\ * J-th row.\n\ *\n\ * (3L) The left singular vector matrix of the remaining matrix.\n\ *\n\ * For the right singular vector matrix, four types of orthogonal\n\ * matrices are involved:\n\ *\n\ * (1R) The right singular vector matrix of the remaining matrix.\n\ *\n\ * (2R) If SQRE = 1, one extra Givens rotation to generate the right\n\ * null space.\n\ *\n\ * (3R) The inverse transformation of (2L).\n\ *\n\ * (4R) The inverse transformation of (1L).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ICOMPQ (input) INTEGER\n\ * Specifies whether singular vectors are to be computed in\n\ * factored form:\n\ * = 0: Left singular vector matrix.\n\ * = 1: Right singular vector matrix.\n\ *\n\ * NL (input) INTEGER\n\ * The row dimension of the upper block. NL >= 1.\n\ *\n\ * NR (input) INTEGER\n\ * The row dimension of the lower block. NR >= 1.\n\ *\n\ * SQRE (input) INTEGER\n\ * = 0: the lower block is an NR-by-NR square matrix.\n\ * = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n\ *\n\ * The bidiagonal matrix has row dimension N = NL + NR + 1,\n\ * and column dimension M = N + SQRE.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of columns of B and BX. NRHS must be at least 1.\n\ *\n\ * B (input/output) COMPLEX array, dimension ( LDB, NRHS )\n\ * On input, B contains the right hand sides of the least\n\ * squares problem in rows 1 through M. On output, B contains\n\ * the solution X in rows 1 through N.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B. LDB must be at least\n\ * max(1,MAX( M, N ) ).\n\ *\n\ * BX (workspace) COMPLEX array, dimension ( LDBX, NRHS )\n\ *\n\ * LDBX (input) INTEGER\n\ * The leading dimension of BX.\n\ *\n\ * PERM (input) INTEGER array, dimension ( N )\n\ * The permutations (from deflation and sorting) applied\n\ * to the two blocks.\n\ *\n\ * GIVPTR (input) INTEGER\n\ * The number of Givens rotations which took place in this\n\ * subproblem.\n\ *\n\ * GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )\n\ * Each pair of numbers indicates a pair of rows/columns\n\ * involved in a Givens rotation.\n\ *\n\ * LDGCOL (input) INTEGER\n\ * The leading dimension of GIVCOL, must be at least N.\n\ *\n\ * GIVNUM (input) REAL array, dimension ( LDGNUM, 2 )\n\ * Each number indicates the C or S value used in the\n\ * corresponding Givens rotation.\n\ *\n\ * LDGNUM (input) INTEGER\n\ * The leading dimension of arrays DIFR, POLES and\n\ * GIVNUM, must be at least K.\n\ *\n\ * POLES (input) REAL array, dimension ( LDGNUM, 2 )\n\ * On entry, POLES(1:K, 1) contains the new singular\n\ * values obtained from solving the secular equation, and\n\ * POLES(1:K, 2) is an array containing the poles in the secular\n\ * equation.\n\ *\n\ * DIFL (input) REAL array, dimension ( K ).\n\ * On entry, DIFL(I) is the distance between I-th updated\n\ * (undeflated) singular value and the I-th (undeflated) old\n\ * singular value.\n\ *\n\ * DIFR (input) REAL array, dimension ( LDGNUM, 2 ).\n\ * On entry, DIFR(I, 1) contains the distances between I-th\n\ * updated (undeflated) singular value and the I+1-th\n\ * (undeflated) old singular value. And DIFR(I, 2) is the\n\ * normalizing factor for the I-th right singular vector.\n\ *\n\ * Z (input) REAL array, dimension ( K )\n\ * Contain the components of the deflation-adjusted updating row\n\ * vector.\n\ *\n\ * K (input) INTEGER\n\ * Contains the dimension of the non-deflated matrix,\n\ * This is the order of the related secular equation. 1 <= K <=N.\n\ *\n\ * C (input) REAL\n\ * C contains garbage if SQRE =0 and the C-value of a Givens\n\ * rotation related to the right null space if SQRE = 1.\n\ *\n\ * S (input) REAL\n\ * S contains garbage if SQRE =0 and the S-value of a Givens\n\ * rotation related to the right null space if SQRE = 1.\n\ *\n\ * RWORK (workspace) REAL array, dimension\n\ * ( K*(1+NRHS) + 2*NRHS )\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\ * Based on contributions by\n\ * Ming Gu and Ren-Cang Li, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slarrd0000644000175000017500000002560512502223526016507 0ustar uwabamiuwabami--- :name: slarrd :md5sum: 1d17cb93ea8bc4bff6584301e13e6ec7 :category: :subroutine :arguments: - range: :type: char :intent: input - order: :type: char :intent: input - n: :type: integer :intent: input - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - gers: :type: real :intent: input :dims: - 2*n - reltol: :type: real :intent: input - d: :type: real :intent: input :dims: - n - e: :type: real :intent: input :dims: - n-1 - e2: :type: real :intent: input :dims: - n-1 - pivmin: :type: real :intent: input - nsplit: :type: integer :intent: input - isplit: :type: integer :intent: input :dims: - n - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - werr: :type: real :intent: output :dims: - n - wl: :type: real :intent: output - wu: :type: real :intent: output - iblock: :type: integer :intent: output :dims: - n - indexw: :type: integer :intent: output :dims: - n - work: :type: real :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLARRD( RANGE, ORDER, N, VL, VU, IL, IU, GERS, RELTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT, M, W, WERR, WL, WU, IBLOCK, INDEXW, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLARRD computes the eigenvalues of a symmetric tridiagonal\n\ * matrix T to suitable accuracy. This is an auxiliary code to be\n\ * called from SSTEMR.\n\ * The user may ask for all eigenvalues, all eigenvalues\n\ * in the half-open interval (VL, VU], or the IL-th through IU-th\n\ * eigenvalues.\n\ *\n\ * To avoid overflow, the matrix must be scaled so that its\n\ * largest element is no greater than overflow**(1/2) *\n\ * underflow**(1/4) in absolute value, and for greatest\n\ * accuracy, it should not be much smaller than that.\n\ *\n\ * See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n\ * Matrix\", Report CS41, Computer Science Dept., Stanford\n\ * University, July 21, 1966.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': (\"All\") all eigenvalues will be found.\n\ * = 'V': (\"Value\") all eigenvalues in the half-open interval\n\ * (VL, VU] will be found.\n\ * = 'I': (\"Index\") the IL-th through IU-th eigenvalues (of the\n\ * entire matrix) will be found.\n\ *\n\ * ORDER (input) CHARACTER*1\n\ * = 'B': (\"By Block\") the eigenvalues will be grouped by\n\ * split-off block (see IBLOCK, ISPLIT) and\n\ * ordered from smallest to largest within\n\ * the block.\n\ * = 'E': (\"Entire matrix\")\n\ * the eigenvalues for the entire matrix\n\ * will be ordered from smallest to\n\ * largest.\n\ *\n\ * N (input) INTEGER\n\ * The order of the tridiagonal matrix T. N >= 0.\n\ *\n\ * VL (input) REAL \n\ * VU (input) REAL \n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. Eigenvalues less than or equal\n\ * to VL, or greater than VU, will not be returned. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * GERS (input) REAL array, dimension (2*N)\n\ * The N Gerschgorin intervals (the i-th Gerschgorin interval\n\ * is (GERS(2*i-1), GERS(2*i)).\n\ *\n\ * RELTOL (input) REAL \n\ * The minimum relative width of an interval. When an interval\n\ * is narrower than RELTOL times the larger (in\n\ * magnitude) endpoint, then it is considered to be\n\ * sufficiently small, i.e., converged. Note: this should\n\ * always be at least radix*machine epsilon.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The n diagonal elements of the tridiagonal matrix T.\n\ *\n\ * E (input) REAL array, dimension (N-1)\n\ * The (n-1) off-diagonal elements of the tridiagonal matrix T.\n\ *\n\ * E2 (input) REAL array, dimension (N-1)\n\ * The (n-1) squared off-diagonal elements of the tridiagonal matrix T.\n\ *\n\ * PIVMIN (input) REAL \n\ * The minimum pivot allowed in the Sturm sequence for T.\n\ *\n\ * NSPLIT (input) INTEGER\n\ * The number of diagonal blocks in the matrix T.\n\ * 1 <= NSPLIT <= N.\n\ *\n\ * ISPLIT (input) INTEGER array, dimension (N)\n\ * The splitting points, at which T breaks up into submatrices.\n\ * The first submatrix consists of rows/columns 1 to ISPLIT(1),\n\ * the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n\ * etc., and the NSPLIT-th consists of rows/columns\n\ * ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n\ * (Only the first NSPLIT elements will actually be used, but\n\ * since the user cannot know a priori what value NSPLIT will\n\ * have, N words must be reserved for ISPLIT.)\n\ *\n\ * M (output) INTEGER\n\ * The actual number of eigenvalues found. 0 <= M <= N.\n\ * (See also the description of INFO=2,3.)\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * On exit, the first M elements of W will contain the\n\ * eigenvalue approximations. SLARRD computes an interval\n\ * I_j = (a_j, b_j] that includes eigenvalue j. The eigenvalue\n\ * approximation is given as the interval midpoint\n\ * W(j)= ( a_j + b_j)/2. The corresponding error is bounded by\n\ * WERR(j) = abs( a_j - b_j)/2\n\ *\n\ * WERR (output) REAL array, dimension (N)\n\ * The error bound on the corresponding eigenvalue approximation\n\ * in W.\n\ *\n\ * WL (output) REAL \n\ * WU (output) REAL \n\ * The interval (WL, WU] contains all the wanted eigenvalues.\n\ * If RANGE='V', then WL=VL and WU=VU.\n\ * If RANGE='A', then WL and WU are the global Gerschgorin bounds\n\ * on the spectrum.\n\ * If RANGE='I', then WL and WU are computed by SLAEBZ from the\n\ * index range specified.\n\ *\n\ * IBLOCK (output) INTEGER array, dimension (N)\n\ * At each row/column j where E(j) is zero or small, the\n\ * matrix T is considered to split into a block diagonal\n\ * matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which\n\ * block (from 1 to the number of blocks) the eigenvalue W(i)\n\ * belongs. (SLARRD may use the remaining N-M elements as\n\ * workspace.)\n\ *\n\ * INDEXW (output) INTEGER array, dimension (N)\n\ * The indices of the eigenvalues within each block (submatrix);\n\ * for example, INDEXW(i)= j and IBLOCK(i)=k imply that the\n\ * i-th eigenvalue W(i) is the j-th eigenvalue in block k.\n\ *\n\ * WORK (workspace) REAL array, dimension (4*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (3*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: some or all of the eigenvalues failed to converge or\n\ * were not computed:\n\ * =1 or 3: Bisection failed to converge for some\n\ * eigenvalues; these eigenvalues are flagged by a\n\ * negative block number. The effect is that the\n\ * eigenvalues may not be as accurate as the\n\ * absolute and relative tolerances. This is\n\ * generally caused by unexpectedly inaccurate\n\ * arithmetic.\n\ * =2 or 3: RANGE='I' only: Not all of the eigenvalues\n\ * IL:IU were found.\n\ * Effect: M < IU+1-IL\n\ * Cause: non-monotonic arithmetic, causing the\n\ * Sturm sequence to be non-monotonic.\n\ * Cure: recalculate, using RANGE='A', and pick\n\ * out eigenvalues IL:IU. In some cases,\n\ * increasing the PARAMETER \"FUDGE\" may\n\ * make things work.\n\ * = 4: RANGE='I', and the Gershgorin interval\n\ * initially used was too small. No eigenvalues\n\ * were computed.\n\ * Probable cause: your machine has sloppy\n\ * floating-point arithmetic.\n\ * Cure: Increase the PARAMETER \"FUDGE\",\n\ * recompile, and try again.\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * FUDGE REAL , default = 2\n\ * A \"fudge factor\" to widen the Gershgorin intervals. Ideally,\n\ * a value of 1 should work, but on machines with sloppy\n\ * arithmetic, this needs to be larger. The default for\n\ * publicly released versions should be large enough to handle\n\ * the worst machine around. Note that this has no effect\n\ * on accuracy of the solution.\n\ *\n\ * Based on contributions by\n\ * W. Kahan, University of California, Berkeley, USA\n\ * Beresford Parlett, University of California, Berkeley, USA\n\ * Jim Demmel, University of California, Berkeley, USA\n\ * Inderjit Dhillon, University of Texas, Austin, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, University of California, Berkeley, USA\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slacn20000644000175000017500000000562612502223526016403 0ustar uwabamiuwabami--- :name: slacn2 :md5sum: 9887439066195ba0232deeddaf0c56dd :category: :subroutine :arguments: - n: :type: integer :intent: input - v: :type: real :intent: workspace :dims: - n - x: :type: real :intent: input/output :dims: - n - isgn: :type: integer :intent: workspace :dims: - n - est: :type: real :intent: input/output - kase: :type: integer :intent: input/output - isave: :type: integer :intent: input/output :dims: - "3" :substitutions: {} :fortran_help: " SUBROUTINE SLACN2( N, V, X, ISGN, EST, KASE, ISAVE )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLACN2 estimates the 1-norm of a square, real matrix A.\n\ * Reverse communication is used for evaluating matrix-vector products.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 1.\n\ *\n\ * V (workspace) REAL array, dimension (N)\n\ * On the final return, V = A*W, where EST = norm(V)/norm(W)\n\ * (W is not returned).\n\ *\n\ * X (input/output) REAL array, dimension (N)\n\ * On an intermediate return, X should be overwritten by\n\ * A * X, if KASE=1,\n\ * A' * X, if KASE=2,\n\ * and SLACN2 must be re-called with all the other parameters\n\ * unchanged.\n\ *\n\ * ISGN (workspace) INTEGER array, dimension (N)\n\ *\n\ * EST (input/output) REAL\n\ * On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be\n\ * unchanged from the previous call to SLACN2.\n\ * On exit, EST is an estimate (a lower bound) for norm(A). \n\ *\n\ * KASE (input/output) INTEGER\n\ * On the initial call to SLACN2, KASE should be 0.\n\ * On an intermediate return, KASE will be 1 or 2, indicating\n\ * whether X should be overwritten by A * X or A' * X.\n\ * On the final return from SLACN2, KASE will again be 0.\n\ *\n\ * ISAVE (input/output) INTEGER array, dimension (3)\n\ * ISAVE is used to save variables between calls to SLACN2\n\ *\n\n\ * Further Details\n\ * ======= =======\n\ *\n\ * Contributed by Nick Higham, University of Manchester.\n\ * Originally named SONEST, dated March 16, 1988.\n\ *\n\ * Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n\ * a real or complex matrix, with applications to condition estimation\",\n\ * ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n\ *\n\ * This is a thread safe version of SLACON, which uses the array ISAVE\n\ * in place of a SAVE statement, as follows:\n\ *\n\ * SLACON SLACN2\n\ * JUMP ISAVE(1)\n\ * J ISAVE(2)\n\ * ITER ISAVE(3)\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chetrs20000644000175000017500000000524012502223525016562 0ustar uwabamiuwabami--- :name: chetrs2 :md5sum: cd636966a24cd1a9a753a4dcf2c8b77c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHETRS2 solves a system of linear equations A*X = B with a COMPLEX\n\ * Hermitian matrix A using the factorization A = U*D*U**T or\n\ * A = L*D*L**T computed by CSYTRF and converted by CSYCONV.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**H;\n\ * = 'L': Lower triangular, form is A = L*D*L**H.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by CHETRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by CHETRF.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlarrv0000644000175000017500000002226512655767354016564 0ustar uwabamiuwabami--- :name: zlarrv :md5sum: ae9ce24a0dd6a243053bd6396969a553 :category: :subroutine :arguments: - n: :type: integer :intent: input - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - d: :type: doublereal :intent: input/output :dims: - n - l: :type: doublereal :intent: input/output :dims: - n - pivmin: :type: doublereal :intent: input - isplit: :type: integer :intent: input :dims: - n - m: :type: integer :intent: input - dol: :type: integer :intent: input - dou: :type: integer :intent: input - minrgp: :type: doublereal :intent: input - rtol1: :type: doublereal :intent: input - rtol2: :type: doublereal :intent: input - w: :type: doublereal :intent: input/output :dims: - n - werr: :type: doublereal :intent: input/output :dims: - n - wgap: :type: doublereal :intent: input/output :dims: - n - iblock: :type: integer :intent: input :dims: - n - indexw: :type: integer :intent: input :dims: - n - gers: :type: doublereal :intent: input :dims: - 2*n - z: :type: doublecomplex :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - work: :type: doublereal :intent: workspace :dims: - 12*n - iwork: :type: integer :intent: workspace :dims: - 7*n - info: :type: integer :intent: output :substitutions: ldz: n :fortran_help: " SUBROUTINE ZLARRV( N, VL, VU, D, L, PIVMIN, ISPLIT, M, DOL, DOU, MINRGP, RTOL1, RTOL2, W, WERR, WGAP, IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLARRV computes the eigenvectors of the tridiagonal matrix\n\ * T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T.\n\ * The input eigenvalues should have been computed by DLARRE.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * VL (input) DOUBLE PRECISION\n\ * VU (input) DOUBLE PRECISION\n\ * Lower and upper bounds of the interval that contains the desired\n\ * eigenvalues. VL < VU. Needed to compute gaps on the left or right\n\ * end of the extremal eigenvalues in the desired RANGE.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the N diagonal elements of the diagonal matrix D.\n\ * On exit, D may be overwritten.\n\ *\n\ * L (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the (N-1) subdiagonal elements of the unit\n\ * bidiagonal matrix L are in elements 1 to N-1 of L\n\ * (if the matrix is not split.) At the end of each block\n\ * is stored the corresponding shift as given by DLARRE.\n\ * On exit, L is overwritten.\n\ *\n\ * PIVMIN (in) DOUBLE PRECISION\n\ * The minimum pivot allowed in the Sturm sequence.\n\ *\n\ * ISPLIT (input) INTEGER array, dimension (N)\n\ * The splitting points, at which T breaks up into blocks.\n\ * The first block consists of rows/columns 1 to\n\ * ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n\ * through ISPLIT( 2 ), etc.\n\ *\n\ * M (input) INTEGER\n\ * The total number of input eigenvalues. 0 <= M <= N.\n\ *\n\ * DOL (input) INTEGER\n\ * DOU (input) INTEGER\n\ * If the user wants to compute only selected eigenvectors from all\n\ * the eigenvalues supplied, he can specify an index range DOL:DOU.\n\ * Or else the setting DOL=1, DOU=M should be applied.\n\ * Note that DOL and DOU refer to the order in which the eigenvalues\n\ * are stored in W.\n\ * If the user wants to compute only selected eigenpairs, then\n\ * the columns DOL-1 to DOU+1 of the eigenvector space Z contain the\n\ * computed eigenvectors. All other columns of Z are set to zero.\n\ *\n\ * MINRGP (input) DOUBLE PRECISION\n\ *\n\ * RTOL1 (input) DOUBLE PRECISION\n\ * RTOL2 (input) DOUBLE PRECISION\n\ * Parameters for bisection.\n\ * An interval [LEFT,RIGHT] has converged if\n\ * RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n\ *\n\ * W (input/output) DOUBLE PRECISION array, dimension (N)\n\ * The first M elements of W contain the APPROXIMATE eigenvalues for\n\ * which eigenvectors are to be computed. The eigenvalues\n\ * should be grouped by split-off block and ordered from\n\ * smallest to largest within the block ( The output array\n\ * W from DLARRE is expected here ). Furthermore, they are with\n\ * respect to the shift of the corresponding root representation\n\ * for their block. On exit, W holds the eigenvalues of the\n\ * UNshifted matrix.\n\ *\n\ * WERR (input/output) DOUBLE PRECISION array, dimension (N)\n\ * The first M elements contain the semiwidth of the uncertainty\n\ * interval of the corresponding eigenvalue in W\n\ *\n\ * WGAP (input/output) DOUBLE PRECISION array, dimension (N)\n\ * The separation from the right neighbor eigenvalue in W.\n\ *\n\ * IBLOCK (input) INTEGER array, dimension (N)\n\ * The indices of the blocks (submatrices) associated with the\n\ * corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue\n\ * W(i) belongs to the first block from the top, =2 if W(i)\n\ * belongs to the second block, etc.\n\ *\n\ * INDEXW (input) INTEGER array, dimension (N)\n\ * The indices of the eigenvalues within each block (submatrix);\n\ * for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the\n\ * i-th eigenvalue W(i) is the 10-th eigenvalue in the second block.\n\ *\n\ * GERS (input) DOUBLE PRECISION array, dimension (2*N)\n\ * The N Gerschgorin intervals (the i-th Gerschgorin interval\n\ * is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should\n\ * be computed from the original UNshifted matrix.\n\ *\n\ * Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M) )\n\ * If INFO = 0, the first M columns of Z contain the\n\ * orthonormal eigenvectors of the matrix T\n\ * corresponding to the input eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )\n\ * The support of the eigenvectors in Z, i.e., the indices\n\ * indicating the nonzero elements in Z. The I-th eigenvector\n\ * is nonzero only in elements ISUPPZ( 2*I-1 ) through\n\ * ISUPPZ( 2*I ).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (12*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (7*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ *\n\ * > 0: A problem occured in ZLARRV.\n\ * < 0: One of the called subroutines signaled an internal problem.\n\ * Needs inspection of the corresponding parameter IINFO\n\ * for further information.\n\ *\n\ * =-1: Problem in DLARRB when refining a child's eigenvalues.\n\ * =-2: Problem in DLARRF when computing the RRR of a child.\n\ * When a child is inside a tight cluster, it can be difficult\n\ * to find an RRR. A partial remedy from the user's point of\n\ * view is to make the parameter MINRGP smaller and recompile.\n\ * However, as the orthogonality of the computed vectors is\n\ * proportional to 1/MINRGP, the user should be aware that\n\ * he might be trading in precision when he decreases MINRGP.\n\ * =-3: Problem in DLARRB when refining a single eigenvalue\n\ * after the Rayleigh correction was rejected.\n\ * = 5: The Rayleigh Quotient Iteration failed to converge to\n\ * full accuracy in MAXITR steps.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Beresford Parlett, University of California, Berkeley, USA\n\ * Jim Demmel, University of California, Berkeley, USA\n\ * Inderjit Dhillon, University of Texas, Austin, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, University of California, Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slaqr10000644000175000017500000000412512502223526016415 0ustar uwabamiuwabami--- :name: slaqr1 :md5sum: 9268bfacaf3cde6691ba9220ca02f6e0 :category: :subroutine :arguments: - n: :type: integer :intent: input - h: :type: real :intent: input :dims: - ldh - n - ldh: :type: integer :intent: input - sr1: :type: real :intent: input - si1: :type: real :intent: input - sr2: :type: real :intent: input - si2: :type: real :intent: input - v: :type: real :intent: output :dims: - n :substitutions: {} :fortran_help: " SUBROUTINE SLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V )\n\n\ * Given a 2-by-2 or 3-by-3 matrix H, SLAQR1 sets v to a\n\ * scalar multiple of the first column of the product\n\ *\n\ * (*) K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I)\n\ *\n\ * scaling to avoid overflows and most underflows. It\n\ * is assumed that either\n\ *\n\ * 1) sr1 = sr2 and si1 = -si2\n\ * or\n\ * 2) si1 = si2 = 0.\n\ *\n\ * This is useful for starting double implicit shift bulges\n\ * in the QR algorithm.\n\ *\n\ *\n\n\ * N (input) integer\n\ * Order of the matrix H. N must be either 2 or 3.\n\ *\n\ * H (input) REAL array of dimension (LDH,N)\n\ * The 2-by-2 or 3-by-3 matrix H in (*).\n\ *\n\ * LDH (input) integer\n\ * The leading dimension of H as declared in\n\ * the calling procedure. LDH.GE.N\n\ *\n\ * SR1 (input) REAL\n\ * SI1 The shifts in (*).\n\ * SR2\n\ * SI2\n\ *\n\ * V (output) REAL array of dimension N\n\ * A scalar multiple of the first column of the\n\ * matrix K in (*).\n\ *\n\n\ * ================================================================\n\ * Based on contributions by\n\ * Karen Braman and Ralph Byers, Department of Mathematics,\n\ * University of Kansas, USA\n\ *\n\ * ================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dormql0000644000175000017500000001054012502223526016506 0ustar uwabamiuwabami--- :name: dormql :md5sum: 91204df0ad361c3d664f21c97a977882 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DORMQL overwrites the general real M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'T': Q**T * C C * Q**T\n\ *\n\ * where Q is a real orthogonal matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(k) . . . H(2) H(1)\n\ *\n\ * as returned by DGEQLF. Q is of order M if SIDE = 'L' and of order N\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**T from the Left;\n\ * = 'R': apply Q or Q**T from the Right.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q;\n\ * = 'T': Transpose, apply Q**T.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,K)\n\ * The i-th column must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * DGEQLF in the last k columns of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ * If SIDE = 'L', LDA >= max(1,M);\n\ * if SIDE = 'R', LDA >= max(1,N).\n\ *\n\ * TAU (input) DOUBLE PRECISION array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by DGEQLF.\n\ *\n\ * C (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M).\n\ * For optimum performance LWORK >= N*NB if SIDE = 'L', and\n\ * LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n\ * 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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slarft0000644000175000017500000001067712502223526016516 0ustar uwabamiuwabami--- :name: slarft :md5sum: b12d563ef62c069ed8eb5acdf578968b :category: :subroutine :arguments: - direct: :type: char :intent: input - storev: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - v: :type: real :intent: input/output :dims: - ldv - "lsame_(&storev,\"C\") ? k : lsame_(&storev,\"R\") ? n : 0" - ldv: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - t: :type: real :intent: output :dims: - ldt - k - ldt: :type: integer :intent: input :substitutions: ldt: k :fortran_help: " SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLARFT forms the triangular factor T of a real block reflector H\n\ * of order n, which is defined as a product of k elementary reflectors.\n\ *\n\ * If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n\ *\n\ * If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n\ *\n\ * If STOREV = 'C', the vector which defines the elementary reflector\n\ * H(i) is stored in the i-th column of the array V, and\n\ *\n\ * H = I - V * T * V'\n\ *\n\ * If STOREV = 'R', the vector which defines the elementary reflector\n\ * H(i) is stored in the i-th row of the array V, and\n\ *\n\ * H = I - V' * T * V\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * DIRECT (input) CHARACTER*1\n\ * Specifies the order in which the elementary reflectors are\n\ * multiplied to form the block reflector:\n\ * = 'F': H = H(1) H(2) . . . H(k) (Forward)\n\ * = 'B': H = H(k) . . . H(2) H(1) (Backward)\n\ *\n\ * STOREV (input) CHARACTER*1\n\ * Specifies how the vectors which define the elementary\n\ * reflectors are stored (see also Further Details):\n\ * = 'C': columnwise\n\ * = 'R': rowwise\n\ *\n\ * N (input) INTEGER\n\ * The order of the block reflector H. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The order of the triangular factor T (= the number of\n\ * elementary reflectors). K >= 1.\n\ *\n\ * V (input/output) REAL array, dimension\n\ * (LDV,K) if STOREV = 'C'\n\ * (LDV,N) if STOREV = 'R'\n\ * The matrix V. See further details.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V.\n\ * If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n\ *\n\ * TAU (input) REAL array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i).\n\ *\n\ * T (output) REAL array, dimension (LDT,K)\n\ * The k by k triangular factor T of the block reflector.\n\ * If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n\ * lower triangular. The rest of the array is not used.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= K.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The shape of the matrix V and the storage of the vectors which define\n\ * the H(i) is best illustrated by the following example with n = 5 and\n\ * k = 3. The elements equal to 1 are not stored; the corresponding\n\ * array elements are modified but restored on exit. The rest of the\n\ * array is not used.\n\ *\n\ * DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':\n\ *\n\ * V = ( 1 ) V = ( 1 v1 v1 v1 v1 )\n\ * ( v1 1 ) ( 1 v2 v2 v2 )\n\ * ( v1 v2 1 ) ( 1 v3 v3 )\n\ * ( v1 v2 v3 )\n\ * ( v1 v2 v3 )\n\ *\n\ * DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':\n\ *\n\ * V = ( v1 v2 v3 ) V = ( v1 v1 1 )\n\ * ( v1 v2 v3 ) ( v2 v2 v2 1 )\n\ * ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )\n\ * ( 1 v3 )\n\ * ( 1 )\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dtzrqf0000644000175000017500000000644212502223526016530 0ustar uwabamiuwabami--- :name: dtzrqf :md5sum: 0f69e484f62485cb2f20960d94d2dd64 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE DTZRQF( M, N, A, LDA, TAU, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This routine is deprecated and has been replaced by routine DTZRZF.\n\ *\n\ * DTZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A\n\ * to upper triangular form by means of orthogonal transformations.\n\ *\n\ * The upper trapezoidal matrix A is factored as\n\ *\n\ * A = ( R 0 ) * Z,\n\ *\n\ * where Z is an N-by-N orthogonal matrix and R is an M-by-M upper\n\ * triangular matrix.\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 >= M.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the leading M-by-N upper trapezoidal part of the\n\ * array A must contain the matrix to be factorized.\n\ * On exit, the leading M-by-M upper triangular part of A\n\ * contains the upper triangular matrix R, and elements M+1 to\n\ * N of the first M rows of A, with the array TAU, represent the\n\ * orthogonal matrix Z as a product of M elementary reflectors.\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 (M)\n\ * The scalar factors of the elementary reflectors.\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 factorization is obtained by Householder's method. The kth\n\ * transformation matrix, Z( k ), which is used to introduce zeros into\n\ * the ( m - k + 1 )th row of A, is given in the form\n\ *\n\ * Z( k ) = ( I 0 ),\n\ * ( 0 T( k ) )\n\ *\n\ * where\n\ *\n\ * T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n\ * ( 0 )\n\ * ( z( k ) )\n\ *\n\ * tau is a scalar and z( k ) is an ( n - m ) element vector.\n\ * tau and z( k ) are chosen to annihilate the elements of the kth row\n\ * of X.\n\ *\n\ * The scalar tau is returned in the kth element of TAU and the vector\n\ * u( k ) in the kth row of A, such that the elements of z( k ) are\n\ * in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n\ * the upper triangular part of A.\n\ *\n\ * Z is given by\n\ *\n\ * Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dtrttf0000644000175000017500000001405712502223526016526 0ustar uwabamiuwabami--- :name: dtrttf :md5sum: 02cd214c0c27547c9ac214b4519cadba :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - arf: :type: doublereal :intent: output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DTRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTRTTF copies a triangular matrix A from standard full format (TR)\n\ * to rectangular full packed format (TF) .\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': ARF in Normal form is wanted;\n\ * = 'T': ARF in Transpose form is wanted.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N).\n\ * On entry, the triangular matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of the array A contains\n\ * the upper triangular matrix, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of the array A contains\n\ * the lower triangular matrix, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the matrix A. LDA >= max(1,N).\n\ *\n\ * ARF (output) DOUBLE PRECISION array, dimension (NT).\n\ * NT=N*(N+1)/2. On exit, the triangular matrix A in RFP format.\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\ * We first consider Rectangular Full Packed (RFP) Format when N is\n\ * even. We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * the transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * the transpose of the last three columns of AP lower.\n\ * This covers the case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 04 05 33 43 53\n\ * 13 14 15 00 44 54\n\ * 23 24 25 10 11 55\n\ * 33 34 35 20 21 22\n\ * 00 44 45 30 31 32\n\ * 01 11 55 40 41 42\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We then consider Rectangular Full Packed (RFP) Format when N is\n\ * odd. We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * the transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * the transpose of the last two columns of AP lower.\n\ * This covers the case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 03 04 00 33 43\n\ * 12 13 14 10 11 44\n\ * 22 23 24 20 21 22\n\ * 00 33 34 30 31 32\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * Reference\n\ * =========\n\ *\n\ * =====================================================================\n\ *\n\ * ..\n\ * .. Local Scalars ..\n LOGICAL LOWER, NISODD, NORMALTRANSR\n INTEGER I, IJ, J, K, L, N1, N2, NT, NX2, NP1X2\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MOD\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/clabrd0000644000175000017500000001457112502223525016446 0ustar uwabamiuwabami--- :name: clabrd :md5sum: 6ef5300c03ff0c0ef1c02f7f2da050d5 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: real :intent: output :dims: - MAX(1,nb) - e: :type: real :intent: output :dims: - MAX(1,nb) - tauq: :type: complex :intent: output :dims: - MAX(1,nb) - taup: :type: complex :intent: output :dims: - MAX(1,nb) - x: :type: complex :intent: output :dims: - ldx - MAX(1,nb) - ldx: :type: integer :intent: input - y: :type: complex :intent: output :dims: - ldy - MAX(1,nb) - ldy: :type: integer :intent: input :substitutions: ldx: MAX(1,m) ldy: MAX(1,n) :fortran_help: " SUBROUTINE CLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, LDY )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLABRD reduces the first NB rows and columns of a complex general\n\ * m by n matrix A to upper or lower real bidiagonal form by a unitary\n\ * transformation Q' * A * P, and returns the matrices X and Y which\n\ * are needed to apply the transformation to the unreduced part of A.\n\ *\n\ * If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower\n\ * bidiagonal form.\n\ *\n\ * This is an auxiliary routine called by CGEBRD\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows in the matrix A.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns in the matrix A.\n\ *\n\ * NB (input) INTEGER\n\ * The number of leading rows and columns of A to be reduced.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the m by n general matrix to be reduced.\n\ * On exit, the first NB rows and columns of the matrix are\n\ * overwritten; the rest of the array is unchanged.\n\ * If m >= n, elements on and below the diagonal in the first NB\n\ * columns, with the array TAUQ, represent the unitary\n\ * matrix Q as a product of elementary reflectors; and\n\ * elements above the diagonal in the first NB rows, with the\n\ * array TAUP, represent the unitary matrix P as a product\n\ * of elementary reflectors.\n\ * If m < n, elements below the diagonal in the first NB\n\ * columns, with the array TAUQ, represent the unitary\n\ * matrix Q as a product of elementary reflectors, and\n\ * elements on and above the diagonal in the first NB rows,\n\ * with the array TAUP, represent the unitary matrix P as\n\ * a product of elementary reflectors.\n\ * See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * D (output) REAL array, dimension (NB)\n\ * The diagonal elements of the first NB rows and columns of\n\ * the reduced matrix. D(i) = A(i,i).\n\ *\n\ * E (output) REAL array, dimension (NB)\n\ * The off-diagonal elements of the first NB rows and columns of\n\ * the reduced matrix.\n\ *\n\ * TAUQ (output) COMPLEX array dimension (NB)\n\ * The scalar factors of the elementary reflectors which\n\ * represent the unitary matrix Q. See Further Details.\n\ *\n\ * TAUP (output) COMPLEX array, dimension (NB)\n\ * The scalar factors of the elementary reflectors which\n\ * represent the unitary matrix P. See Further Details.\n\ *\n\ * X (output) COMPLEX array, dimension (LDX,NB)\n\ * The m-by-nb matrix X required to update the unreduced part\n\ * of A.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,M).\n\ *\n\ * Y (output) COMPLEX array, dimension (LDY,NB)\n\ * The n-by-nb matrix Y required to update the unreduced part\n\ * of A.\n\ *\n\ * LDY (input) INTEGER\n\ * The leading dimension of the array Y. LDY >= max(1,N).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The matrices Q and P are represented as products of elementary\n\ * reflectors:\n\ *\n\ * Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb)\n\ *\n\ * Each H(i) and G(i) has the form:\n\ *\n\ * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n\ *\n\ * where tauq and taup are complex scalars, and v and u are complex\n\ * vectors.\n\ *\n\ * If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in\n\ * A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in\n\ * A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n\ *\n\ * If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in\n\ * A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in\n\ * A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n\ *\n\ * The elements of the vectors v and u together form the m-by-nb matrix\n\ * V and the nb-by-n matrix U' which are needed, with X and Y, to apply\n\ * the transformation to the unreduced part of the matrix, using a block\n\ * update of the form: A := A - V*Y' - X*U'.\n\ *\n\ * The contents of A on exit are illustrated by the following examples\n\ * with nb = 2:\n\ *\n\ * m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n\ *\n\ * ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 )\n\ * ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 )\n\ * ( v1 v2 a a a ) ( v1 1 a a a a )\n\ * ( v1 v2 a a a ) ( v1 v2 a a a a )\n\ * ( v1 v2 a a a ) ( v1 v2 a a a a )\n\ * ( v1 v2 a a a )\n\ *\n\ * where a denotes an element of the original matrix which is unchanged,\n\ * vi denotes an element of the vector defining H(i), and ui an element\n\ * of the vector defining G(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgeqr20000644000175000017500000000470612502223526016422 0ustar uwabamiuwabami--- :name: sgeqr2 :md5sum: 06513c36c991798679679c5ae0ee68ee :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - MIN(m,n) - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGEQR2( M, N, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGEQR2 computes a QR factorization of a real m by n matrix A:\n\ * A = Q * R.\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) REAL array, dimension (LDA,N)\n\ * On entry, the m by n matrix A.\n\ * On exit, the elements on and above the diagonal of the array\n\ * contain the min(m,n) by n upper trapezoidal matrix R (R is\n\ * upper triangular if m >= n); the elements below 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) REAL array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace) REAL array, dimension (N)\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(1) H(2) . . . H(k), 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:m) is stored on exit in A(i+1:m,i),\n\ * and tau in TAU(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgbrfsx0000644000175000017500000004241512502223526016674 0ustar uwabamiuwabami--- :name: sgbrfsx :md5sum: 6b886aa6b32d084299e4e5d743981a5b :category: :subroutine :arguments: - trans: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublereal :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - r: :type: real :intent: input/output :dims: - n - c: :type: real :intent: input/output :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: real :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " SUBROUTINE SGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGBRFSX improves the computed solution to a system of linear\n\ * equations and provides error bounds and backward error estimates\n\ * for the solution. In addition to normwise error bound, the code\n\ * provides maximum componentwise error bound if possible. See\n\ * comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n\ * error bounds.\n\ *\n\ * The original system of linear equations may have been equilibrated\n\ * before calling this routine, as described by arguments EQUED, R\n\ * and C below. In this case, the solution and error bounds returned\n\ * are for the original unequilibrated system.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose = Transpose)\n\ *\n\ * EQUED (input) CHARACTER*1\n\ * Specifies the form of equilibration that was done to A\n\ * before calling this routine. This is needed to compute\n\ * the solution and error bounds correctly.\n\ * = 'N': No equilibration\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ * The right hand side B has been changed accordingly.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * The original band matrix A, stored in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n\ * Details of the LU factorization of the band matrix A, as\n\ * computed by DGBTRF. U is stored as an upper triangular band\n\ * matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n\ * the multipliers used during the factorization are stored in\n\ * rows KL+KU+2 to 2*KL+KU+1.\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from SGETRF; for 1<=i<=N, row i of the\n\ * matrix was interchanged with row IPIV(i).\n\ *\n\ * R (input or output) REAL array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'R' or 'B', A is\n\ * multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n\ * is not accessed. R is an input argument if FACT = 'F';\n\ * otherwise, R is an output argument. If FACT = 'F' and\n\ * EQUED = 'R' or 'B', each element of R must be positive.\n\ * If R is output, each element of R is a power of the radix.\n\ * If R is input, each element of R should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * C (input or output) REAL array, dimension (N)\n\ * The column scale factors for A. If EQUED = 'C' or 'B', A is\n\ * multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n\ * is not accessed. C is an input argument if FACT = 'F';\n\ * otherwise, C is an output argument. If FACT = 'F' and\n\ * EQUED = 'C' or 'B', each element of C must be positive.\n\ * If C is output, each element of C is a power of the radix.\n\ * If C is input, each element of C should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input) REAL array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) REAL array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by SGETRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * Componentwise relative backward error. This is the\n\ * componentwise relative backward error of each solution vector X(j)\n\ * (i.e., the smallest relative change in any element of A or B that\n\ * makes X(j) an exact solution).\n\ *\n\ * N_ERR_BNDS (input) INTEGER\n\ * Number of error bounds to return for each right hand side\n\ * and each type (normwise or componentwise). See ERR_BNDS_NORM and\n\ * ERR_BNDS_COMP below.\n\ *\n\ * ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * NPARAMS (input) INTEGER\n\ * Specifies the number of parameters set in PARAMS. If .LE. 0, the\n\ * PARAMS array is never referenced and default values are used.\n\ *\n\ * PARAMS (input / output) REAL array, dimension NPARAMS\n\ * Specifies algorithm parameters. If an entry is .LT. 0.0, then\n\ * that entry will be filled with default value used for that\n\ * parameter. Only positions up to NPARAMS are accessed; defaults\n\ * are used for higher-numbered parameters.\n\ *\n\ * PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n\ * refinement or not.\n\ * Default: 1.0\n\ * = 0.0 : No refinement is performed, and no error bounds are\n\ * computed.\n\ * = 1.0 : Use the double-precision refinement algorithm,\n\ * possibly with doubled-single computations if the\n\ * compilation environment does not support DOUBLE\n\ * PRECISION.\n\ * (other values are reserved for future use)\n\ *\n\ * PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n\ * computations allowed for refinement.\n\ * Default: 10\n\ * Aggressive: Set to 100 to permit convergence using approximate\n\ * factorizations or factorizations other than LU. If\n\ * the factorization uses a technique other than\n\ * Gaussian elimination, the guarantees in\n\ * err_bnds_norm and err_bnds_comp may no longer be\n\ * trustworthy.\n\ *\n\ * PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n\ * will attempt to find a solution with small componentwise\n\ * relative error in the double-precision algorithm. Positive\n\ * is true, 0.0 is false.\n\ * Default: 1.0 (attempt componentwise convergence)\n\ *\n\ * WORK (workspace) REAL array, dimension (4*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit. The solution to every right-hand side is\n\ * guaranteed.\n\ * < 0: If INFO = -i, the i-th argument had an illegal value\n\ * > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgerfs0000644000175000017500000001132012502223526016457 0ustar uwabamiuwabami--- :name: dgerfs :md5sum: 446e892116e20158a8eebd9ecff5461f :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGERFS improves the computed solution to a system of linear\n\ * equations and provides error bounds and backward error estimates for\n\ * the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The original N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n\ * The factors L and U from the factorization A = P*L*U\n\ * as computed by DGETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from DGETRF; for 1<=i<=N, row i of the\n\ * matrix was interchanged with row IPIV(i).\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by DGETRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctfsm0000644000175000017500000002250312502223525016325 0ustar uwabamiuwabami--- :name: ctfsm :md5sum: d21aad1c42cd0f99fe857823611311a5 :category: :subroutine :arguments: - transr: :type: char :intent: input - side: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: complex :intent: input - a: :type: complex :intent: input :dims: - n*(n+1)/2 - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE CTFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, B, LDB )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Level 3 BLAS like routine for A in RFP Format.\n\ *\n\ * CTFSM solves the matrix equation\n\ *\n\ * op( A )*X = alpha*B or X*op( A ) = alpha*B\n\ *\n\ * where alpha is a scalar, X and B are m by n matrices, A is a unit, or\n\ * non-unit, upper or lower triangular matrix and op( A ) is one of\n\ *\n\ * op( A ) = A or op( A ) = conjg( A' ).\n\ *\n\ * A is in Rectangular Full Packed (RFP) Format.\n\ *\n\ * The matrix X is overwritten on B.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': The Normal Form of RFP A is stored;\n\ * = 'C': The Conjugate-transpose Form of RFP A is stored.\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * On entry, SIDE specifies whether op( A ) appears on the left\n\ * or right of X as follows:\n\ *\n\ * SIDE = 'L' or 'l' op( A )*X = alpha*B.\n\ *\n\ * SIDE = 'R' or 'r' X*op( A ) = alpha*B.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * On entry, UPLO specifies whether the RFP matrix A came from\n\ * an upper or lower triangular matrix as follows:\n\ * UPLO = 'U' or 'u' RFP A came from an upper triangular matrix\n\ * UPLO = 'L' or 'l' RFP A came from a lower triangular matrix\n\ *\n\ * Unchanged on exit.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * On entry, TRANS specifies the form of op( A ) to be used\n\ * in the matrix multiplication as follows:\n\ *\n\ * TRANS = 'N' or 'n' op( A ) = A.\n\ *\n\ * TRANS = 'C' or 'c' op( A ) = conjg( A' ).\n\ *\n\ * Unchanged on exit.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * On entry, DIAG specifies whether or not RFP A is unit\n\ * triangular as follows:\n\ *\n\ * DIAG = 'U' or 'u' A is assumed to be unit triangular.\n\ *\n\ * DIAG = 'N' or 'n' A is not assumed to be unit\n\ * triangular.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * M (input) INTEGER\n\ * On entry, M specifies the number of rows of B. M must be at\n\ * least zero.\n\ * Unchanged on exit.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the number of columns of B. N must be\n\ * at least zero.\n\ * Unchanged on exit.\n\ *\n\ * ALPHA (input) COMPLEX\n\ * On entry, ALPHA specifies the scalar alpha. When alpha is\n\ * zero then A is not referenced and B need not be set before\n\ * entry.\n\ * Unchanged on exit.\n\ *\n\ * A (input) COMPLEX array, dimension (N*(N+1)/2)\n\ * NT = N*(N+1)/2. On entry, the matrix A in RFP Format.\n\ * RFP Format is described by TRANSR, UPLO and N as follows:\n\ * If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;\n\ * K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If\n\ * TRANSR = 'C' then RFP is the Conjugate-transpose of RFP A as\n\ * defined when TRANSR = 'N'. The contents of RFP A are defined\n\ * by UPLO as follows: If UPLO = 'U' the RFP A contains the NT\n\ * elements of upper packed A either in normal or\n\ * conjugate-transpose Format. If UPLO = 'L' the RFP A contains\n\ * the NT elements of lower packed A either in normal or\n\ * conjugate-transpose Format. The LDA of RFP A is (N+1)/2 when\n\ * TRANSR = 'C'. When TRANSR is 'N' the LDA is N+1 when N is\n\ * even and is N when is odd.\n\ * See the Note below for more details. Unchanged on exit.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,N)\n\ * Before entry, the leading m by n part of the array B must\n\ * contain the right-hand side matrix B, and on exit is\n\ * overwritten by the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * On entry, LDB specifies the first dimension of B as declared\n\ * in the calling (sub) program. LDB must be at least\n\ * max( 1, m ).\n\ * Unchanged on exit.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * We first consider Standard Packed Format when N is even.\n\ * We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * conjugate-transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * conjugate-transpose of the last three columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- --\n\ * 03 04 05 33 43 53\n\ * -- --\n\ * 13 14 15 00 44 54\n\ * --\n\ * 23 24 25 10 11 55\n\ *\n\ * 33 34 35 20 21 22\n\ * --\n\ * 00 44 45 30 31 32\n\ * -- --\n\ * 01 11 55 40 41 42\n\ * -- -- --\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We next consider Standard Packed Format when N is odd.\n\ * We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * conjugate-transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * conjugate-transpose of the last two columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- --\n\ * 02 03 04 00 33 43\n\ * --\n\ * 12 13 14 10 11 44\n\ *\n\ * 22 23 24 20 21 22\n\ * --\n\ * 00 33 34 30 31 32\n\ * -- --\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- --\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/claed80000644000175000017500000001523312502223525016353 0ustar uwabamiuwabami--- :name: claed8 :md5sum: 09090f0f6ee43e9175bf724857ff705a :category: :subroutine :arguments: - k: :type: integer :intent: output - n: :type: integer :intent: input - qsiz: :type: integer :intent: input - q: :type: complex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - rho: :type: real :intent: input/output - cutpnt: :type: integer :intent: input - z: :type: real :intent: input :dims: - n - dlamda: :type: real :intent: output :dims: - n - q2: :type: complex :intent: output :dims: - ldq2 - n - ldq2: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - indxp: :type: integer :intent: workspace :dims: - n - indx: :type: integer :intent: workspace :dims: - n - indxq: :type: integer :intent: input :dims: - n - perm: :type: integer :intent: output :dims: - n - givptr: :type: integer :intent: output - givcol: :type: integer :intent: output :dims: - "2" - n - givnum: :type: real :intent: output :dims: - "2" - n - info: :type: integer :intent: output :substitutions: ldq2: MAX( 1, n ) :fortran_help: " SUBROUTINE CLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA, Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR, GIVCOL, GIVNUM, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAED8 merges the two sets of eigenvalues together into a single\n\ * sorted set. Then it tries to deflate the size of the problem.\n\ * There are two ways in which deflation can occur: when two or more\n\ * eigenvalues are close together or if there is a tiny element in the\n\ * Z vector. For each such occurrence the order of the related secular\n\ * equation problem is reduced by one.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * K (output) INTEGER\n\ * Contains the number of non-deflated eigenvalues.\n\ * This is the order of the related secular equation.\n\ *\n\ * N (input) INTEGER\n\ * The dimension of the symmetric tridiagonal matrix. N >= 0.\n\ *\n\ * QSIZ (input) INTEGER\n\ * The dimension of the unitary matrix used to reduce\n\ * the dense or band matrix to tridiagonal form.\n\ * QSIZ >= N if ICOMPQ = 1.\n\ *\n\ * Q (input/output) COMPLEX array, dimension (LDQ,N)\n\ * On entry, Q contains the eigenvectors of the partially solved\n\ * system which has been previously updated in matrix\n\ * multiplies with other partially solved eigensystems.\n\ * On exit, Q contains the trailing (N-K) updated eigenvectors\n\ * (those which were deflated) in its last N-K columns.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max( 1, N ).\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, D contains the eigenvalues of the two submatrices to\n\ * be combined. On exit, D contains the trailing (N-K) updated\n\ * eigenvalues (those which were deflated) sorted into increasing\n\ * order.\n\ *\n\ * RHO (input/output) REAL\n\ * Contains the off diagonal element associated with the rank-1\n\ * cut which originally split the two submatrices which are now\n\ * being recombined. RHO is modified during the computation to\n\ * the value required by SLAED3.\n\ *\n\ * CUTPNT (input) INTEGER\n\ * Contains the location of the last eigenvalue in the leading\n\ * sub-matrix. MIN(1,N) <= CUTPNT <= N.\n\ *\n\ * Z (input) REAL array, dimension (N)\n\ * On input this vector contains the updating vector (the last\n\ * row of the first sub-eigenvector matrix and the first row of\n\ * the second sub-eigenvector matrix). The contents of Z are\n\ * destroyed during the updating process.\n\ *\n\ * DLAMDA (output) REAL array, dimension (N)\n\ * Contains a copy of the first K eigenvalues which will be used\n\ * by SLAED3 to form the secular equation.\n\ *\n\ * Q2 (output) COMPLEX array, dimension (LDQ2,N)\n\ * If ICOMPQ = 0, Q2 is not referenced. Otherwise,\n\ * Contains a copy of the first K eigenvectors which will be used\n\ * by SLAED7 in a matrix multiply (SGEMM) to update the new\n\ * eigenvectors.\n\ *\n\ * LDQ2 (input) INTEGER\n\ * The leading dimension of the array Q2. LDQ2 >= max( 1, N ).\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * This will hold the first k values of the final\n\ * deflation-altered z-vector and will be passed to SLAED3.\n\ *\n\ * INDXP (workspace) INTEGER array, dimension (N)\n\ * This will contain the permutation used to place deflated\n\ * values of D at the end of the array. On output INDXP(1:K)\n\ * points to the nondeflated D-values and INDXP(K+1:N)\n\ * points to the deflated eigenvalues.\n\ *\n\ * INDX (workspace) INTEGER array, dimension (N)\n\ * This will contain the permutation used to sort the contents of\n\ * D into ascending order.\n\ *\n\ * INDXQ (input) INTEGER array, dimension (N)\n\ * This contains the permutation which separately sorts the two\n\ * sub-problems in D into ascending order. Note that elements in\n\ * the second half of this permutation must first have CUTPNT\n\ * added to their values in order to be accurate.\n\ *\n\ * PERM (output) INTEGER array, dimension (N)\n\ * Contains the permutations (from deflation and sorting) to be\n\ * applied to each eigenblock.\n\ *\n\ * GIVPTR (output) INTEGER\n\ * Contains the number of Givens rotations which took place in\n\ * this subproblem.\n\ *\n\ * GIVCOL (output) INTEGER array, dimension (2, N)\n\ * Each pair of numbers indicates a pair of columns to take place\n\ * in a Givens rotation.\n\ *\n\ * GIVNUM (output) REAL array, dimension (2, N)\n\ * Each number indicates the S value to be used in the\n\ * corresponding Givens rotation.\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dtptri0000644000175000017500000000521712502223526016523 0ustar uwabamiuwabami--- :name: dtptri :md5sum: 9fb8837fb48bdcfef3a54e4bdbd604f7 :category: :subroutine :arguments: - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DTPTRI( UPLO, DIAG, N, AP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTPTRI computes the inverse of a real upper or lower triangular\n\ * matrix A stored in packed format.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangular matrix A, stored\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n.\n\ * See below for further details.\n\ * On exit, the (triangular) inverse of the original matrix, in\n\ * the same packed storage format.\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, A(i,i) is exactly zero. The triangular\n\ * matrix is singular and its inverse can not be computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * A triangular matrix A can be transferred to packed storage using one\n\ * of the following program segments:\n\ *\n\ * UPLO = 'U': UPLO = 'L':\n\ *\n\ * JC = 1 JC = 1\n\ * DO 2 J = 1, N DO 2 J = 1, N\n\ * DO 1 I = 1, J DO 1 I = J, N\n\ * AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J)\n\ * 1 CONTINUE 1 CONTINUE\n\ * JC = JC + J JC = JC + N - J + 1\n\ * 2 CONTINUE 2 CONTINUE\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cunm2r0000644000175000017500000000725712502223526016431 0ustar uwabamiuwabami--- :name: cunm2r :md5sum: d6529aa837a2fa06b92428b617c42361 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CUNM2R overwrites the general complex m-by-n matrix C with\n\ *\n\ * Q * C if SIDE = 'L' and TRANS = 'N', or\n\ *\n\ * Q'* C if SIDE = 'L' and TRANS = 'C', or\n\ *\n\ * C * Q if SIDE = 'R' and TRANS = 'N', or\n\ *\n\ * C * Q' if SIDE = 'R' and TRANS = 'C',\n\ *\n\ * where Q is a complex unitary matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by CGEQRF. Q is of order m if SIDE = 'L' and of order n\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q' from the Left\n\ * = 'R': apply Q or Q' from the Right\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': apply Q (No transpose)\n\ * = 'C': apply Q' (Conjugate transpose)\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,K)\n\ * The i-th column must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * CGEQRF in the first k columns of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ * If SIDE = 'L', LDA >= max(1,M);\n\ * if SIDE = 'R', LDA >= max(1,N).\n\ *\n\ * TAU (input) COMPLEX array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by CGEQRF.\n\ *\n\ * C (input/output) COMPLEX array, dimension (LDC,N)\n\ * On entry, the m-by-n matrix C.\n\ * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension\n\ * (N) if SIDE = 'L',\n\ * (M) if SIDE = 'R'\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlabad0000644000175000017500000000317112502223526016421 0ustar uwabamiuwabami--- :name: dlabad :md5sum: 22dcceea234b4e85f0bf77e6bb51ee52 :category: :subroutine :arguments: - small: :type: doublereal :intent: input/output - large: :type: doublereal :intent: input/output :substitutions: {} :fortran_help: " SUBROUTINE DLABAD( SMALL, LARGE )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLABAD takes as input the values computed by DLAMCH for underflow and\n\ * overflow, and returns the square root of each of these values if the\n\ * log of LARGE is sufficiently large. This subroutine is intended to\n\ * identify machines with a large exponent range, such as the Crays, and\n\ * redefine the underflow and overflow limits to be the square roots of\n\ * the values computed by DLAMCH. This subroutine is needed because\n\ * DLAMCH does not compensate for poor arithmetic in the upper half of\n\ * the exponent range, as is found on a Cray.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SMALL (input/output) DOUBLE PRECISION\n\ * On entry, the underflow threshold as computed by DLAMCH.\n\ * On exit, if LOG10(LARGE) is sufficiently large, the square\n\ * root of SMALL, otherwise unchanged.\n\ *\n\ * LARGE (input/output) DOUBLE PRECISION\n\ * On entry, the overflow threshold as computed by DLAMCH.\n\ * On exit, if LOG10(LARGE) is sufficiently large, the square\n\ * root of LARGE, otherwise unchanged.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Intrinsic Functions ..\n INTRINSIC LOG10, SQRT\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dppequ0000644000175000017500000000545512502223526016517 0ustar uwabamiuwabami--- :name: dppequ :md5sum: 62f6b4c55adfca98e81cfdd929796b64 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - ldap - s: :type: doublereal :intent: output :dims: - n - scond: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE DPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPPEQU computes row and column scalings intended to equilibrate a\n\ * symmetric positive definite matrix A in packed storage and reduce\n\ * its condition number (with respect to the two-norm). S contains the\n\ * scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix\n\ * B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.\n\ * This choice of S puts the condition number of B within a factor N of\n\ * the smallest possible condition number over all possible diagonal\n\ * scalings.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * The upper or lower triangle of the symmetric matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * S (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, S contains the scale factors for A.\n\ *\n\ * SCOND (output) DOUBLE PRECISION\n\ * If INFO = 0, S contains the ratio of the smallest S(i) to\n\ * the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n\ * large nor too small, it is not worth scaling by S.\n\ *\n\ * AMAX (output) DOUBLE PRECISION\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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 is nonpositive.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsygvx0000644000175000017500000002330312502223526016535 0ustar uwabamiuwabami--- :name: dsygvx :md5sum: d1049907494bb459407d81971dc3b773 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - "lsame_(&jobz,\"N\") ? 0 : ldz" - "lsame_(&jobz,\"N\") ? 0 : MAX(1,m)" - ldz: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 8*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " SUBROUTINE DSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSYGVX computes selected eigenvalues, and optionally, eigenvectors\n\ * of a real generalized symmetric-definite eigenproblem, of the form\n\ * A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A\n\ * and B are assumed to be symmetric and B is also positive definite.\n\ * Eigenvalues and eigenvectors can be selected by specifying either a\n\ * range of values or a range of indices for the desired eigenvalues.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * Specifies the problem type to be solved:\n\ * = 1: A*x = (lambda)*B*x\n\ * = 2: A*B*x = (lambda)*x\n\ * = 3: B*A*x = (lambda)*x\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found.\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found.\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A and B are stored;\n\ * = 'L': Lower triangle of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix pencil (A,B). N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of A contains the\n\ * upper triangular part of the matrix A. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of A contains\n\ * the lower triangular part of the matrix A.\n\ *\n\ * On exit, the lower triangle (if UPLO='L') or the upper\n\ * triangle (if UPLO='U') of A, including the diagonal, is\n\ * destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n\ * On entry, the symmetric matrix B. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of B contains the\n\ * upper triangular part of the matrix B. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of B contains\n\ * the lower triangular part of the matrix B.\n\ *\n\ * On exit, if INFO <= N, the part of B containing the matrix is\n\ * overwritten by the triangular factor U or L from the Cholesky\n\ * factorization B = U**T*U or B = L*L**T.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * VL (input) DOUBLE PRECISION\n\ * VU (input) DOUBLE PRECISION\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) DOUBLE PRECISION\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less than\n\ * or equal to zero, then EPS*|T| will be used in its place,\n\ * where |T| is the 1-norm of the tridiagonal matrix obtained\n\ * by reducing A to tridiagonal form.\n\ *\n\ * Eigenvalues will be computed most accurately when ABSTOL is\n\ * set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n\ * If this routine returns with INFO>0, indicating that some\n\ * eigenvectors did not converge, try setting ABSTOL to\n\ * 2*DLAMCH('S').\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * On normal exit, the first M elements contain the selected\n\ * eigenvalues in ascending order.\n\ *\n\ * Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix A\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * The eigenvectors are normalized as follows:\n\ * if ITYPE = 1 or 2, Z**T*B*Z = I;\n\ * if ITYPE = 3, Z**T*inv(B)*Z = I.\n\ *\n\ * If an eigenvector fails to converge, then that column of Z\n\ * contains the latest approximation to the eigenvector, and the\n\ * index of the eigenvector is returned in IFAIL.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,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 length of the array WORK. LWORK >= max(1,8*N).\n\ * For optimal efficiency, LWORK >= (NB+3)*N,\n\ * where NB is the blocksize for DSYTRD returned by ILAENV.\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\ * IWORK (workspace) INTEGER array, dimension (5*N)\n\ *\n\ * IFAIL (output) INTEGER array, dimension (N)\n\ * If JOBZ = 'V', then if INFO = 0, the first M elements of\n\ * IFAIL are zero. If INFO > 0, then IFAIL contains the\n\ * indices of the eigenvectors that failed to converge.\n\ * If JOBZ = 'N', then IFAIL is not referenced.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: DPOTRF or DSYEVX returned an error code:\n\ * <= N: if INFO = i, DSYEVX failed to converge;\n\ * i eigenvectors failed to converge. Their indices\n\ * are stored in array IFAIL.\n\ * > N: if INFO = N + i, for 1 <= i <= N, then the leading\n\ * minor of order i of B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sspevd0000644000175000017500000001331712502223526016521 0ustar uwabamiuwabami--- :name: sspevd :md5sum: 83441e80c70bbab2f5bee13cf131faa6 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - ldap - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 2*n : lsame_(&jobz,\"V\") ? 1+6*n+n*n : 2" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "(lsame_(&jobz,\"N\")||n<=1) ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE SSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSPEVD computes all the eigenvalues and, optionally, eigenvectors\n\ * of a real symmetric matrix A in packed storage. If eigenvectors are\n\ * desired, it uses a divide and conquer algorithm.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) REAL array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, AP is overwritten by values generated during the\n\ * reduction to tridiagonal form. If UPLO = 'U', the diagonal\n\ * and first superdiagonal of the tridiagonal matrix T overwrite\n\ * the corresponding elements of A, and if UPLO = 'L', the\n\ * diagonal and first subdiagonal of T overwrite the\n\ * corresponding elements of A.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) REAL array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n\ * eigenvectors of the matrix A, with the i-th column of Z\n\ * holding the eigenvector associated with W(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the required LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK.\n\ * If N <= 1, LWORK must be at least 1.\n\ * If JOBZ = 'N' and N > 1, LWORK must be at least 2*N.\n\ * If JOBZ = 'V' and N > 1, LWORK must be at least\n\ * 1 + 6*N + N**2.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the required sizes of the WORK and IWORK\n\ * arrays, returns these values as the first entries of the WORK\n\ * and IWORK arrays, and no error message related to LWORK or\n\ * LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK.\n\ * If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.\n\ * If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the required sizes of the WORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK and IWORK arrays, and no error message related to\n\ * LWORK or LIWORK 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 algorithm failed to converge; i\n\ * off-diagonal elements of an intermediate tridiagonal\n\ * form did not converge to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgeev0000644000175000017500000001322612502223526016306 0ustar uwabamiuwabami--- :name: dgeev :md5sum: aabe3b38aa4ecc1eaef182e801f27ca4 :category: :subroutine :arguments: - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - wr: :type: doublereal :intent: output :dims: - n - wi: :type: doublereal :intent: output :dims: - n - vl: :type: doublereal :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: doublereal :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(lsame_(&jobvl,\"V\")||lsame_(&jobvr,\"V\")) ? 4*n : 3*n" - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGEEV computes for an N-by-N real nonsymmetric matrix A, the\n\ * eigenvalues and, optionally, the left and/or right eigenvectors.\n\ *\n\ * The right eigenvector v(j) of A satisfies\n\ * A * v(j) = lambda(j) * v(j)\n\ * where lambda(j) is its eigenvalue.\n\ * The left eigenvector u(j) of A satisfies\n\ * u(j)**H * A = lambda(j) * u(j)**H\n\ * where u(j)**H denotes the conjugate transpose of u(j).\n\ *\n\ * The computed eigenvectors are normalized to have Euclidean norm\n\ * equal to 1 and largest component real.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVL (input) CHARACTER*1\n\ * = 'N': left eigenvectors of A are not computed;\n\ * = 'V': left eigenvectors of A are computed.\n\ *\n\ * JOBVR (input) CHARACTER*1\n\ * = 'N': right eigenvectors of A are not computed;\n\ * = 'V': right eigenvectors of A are computed.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ * On exit, A has been overwritten.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * WR (output) DOUBLE PRECISION array, dimension (N)\n\ * WI (output) DOUBLE PRECISION array, dimension (N)\n\ * WR and WI contain the real and imaginary parts,\n\ * respectively, of the computed eigenvalues. Complex\n\ * conjugate pairs of eigenvalues appear consecutively\n\ * with the eigenvalue having the positive imaginary part\n\ * first.\n\ *\n\ * VL (output) DOUBLE PRECISION array, dimension (LDVL,N)\n\ * If JOBVL = 'V', the left eigenvectors u(j) are stored one\n\ * after another in the columns of VL, in the same order\n\ * as their eigenvalues.\n\ * If JOBVL = 'N', VL is not referenced.\n\ * If the j-th eigenvalue is real, then u(j) = VL(:,j),\n\ * the j-th column of VL.\n\ * If the j-th and (j+1)-st eigenvalues form a complex\n\ * conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and\n\ * u(j+1) = VL(:,j) - i*VL(:,j+1).\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the array VL. LDVL >= 1; if\n\ * JOBVL = 'V', LDVL >= N.\n\ *\n\ * VR (output) DOUBLE PRECISION array, dimension (LDVR,N)\n\ * If JOBVR = 'V', the right eigenvectors v(j) are stored one\n\ * after another in the columns of VR, in the same order\n\ * as their eigenvalues.\n\ * If JOBVR = 'N', VR is not referenced.\n\ * If the j-th eigenvalue is real, then v(j) = VR(:,j),\n\ * the j-th column of VR.\n\ * If the j-th and (j+1)-st eigenvalues form a complex\n\ * conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and\n\ * v(j+1) = VR(:,j) - i*VR(:,j+1).\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the array VR. LDVR >= 1; if\n\ * JOBVR = 'V', LDVR >= 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. LWORK >= max(1,3*N), and\n\ * if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good\n\ * performance, LWORK must generally be larger.\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 QR algorithm failed to compute all the\n\ * eigenvalues, and no eigenvectors have been computed;\n\ * elements i+1:N of WR and WI contain eigenvalues which\n\ * have converged.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgetrs0000644000175000017500000000470012502223526016520 0ustar uwabamiuwabami--- :name: sgetrs :md5sum: 6bb0828613c13abf696da0b96b456275 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGETRS solves a system of linear equations\n\ * A * X = B or A' * X = B\n\ * with a general N-by-N matrix A using the LU factorization computed\n\ * by SGETRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A'* X = B (Transpose)\n\ * = 'C': A'* X = B (Conjugate transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * The factors L and U from the factorization A = P*L*U\n\ * as computed by SGETRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from SGETRF; for 1<=i<=N, row i of the\n\ * matrix was interchanged with row IPIV(i).\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlals00000644000175000017500000001713512502223526016424 0ustar uwabamiuwabami--- :name: zlals0 :md5sum: 6c3f08f2e87225b43e82d00fc4312c59 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - nl: :type: integer :intent: input - nr: :type: integer :intent: input - sqre: :type: integer :intent: input - nrhs: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - bx: :type: doublecomplex :intent: workspace :dims: - ldbx - nrhs - ldbx: :type: integer :intent: input - perm: :type: integer :intent: input :dims: - n - givptr: :type: integer :intent: input - givcol: :type: integer :intent: input :dims: - ldgcol - "2" - ldgcol: :type: integer :intent: input - givnum: :type: doublereal :intent: input :dims: - ldgnum - "2" - ldgnum: :type: integer :intent: input - poles: :type: doublereal :intent: input :dims: - ldgnum - "2" - difl: :type: doublereal :intent: input :dims: - k - difr: :type: doublereal :intent: input :dims: - ldgnum - "2" - z: :type: doublereal :intent: input :dims: - k - k: :type: integer :intent: input - c: :type: doublereal :intent: input - s: :type: doublereal :intent: input - rwork: :type: doublereal :intent: workspace :dims: - k*(1+nrhs) + 2*nrhs - info: :type: integer :intent: output :substitutions: ldbx: n :fortran_help: " SUBROUTINE ZLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLALS0 applies back the multiplying factors of either the left or the\n\ * right singular vector matrix of a diagonal matrix appended by a row\n\ * to the right hand side matrix B in solving the least squares problem\n\ * using the divide-and-conquer SVD approach.\n\ *\n\ * For the left singular vector matrix, three types of orthogonal\n\ * matrices are involved:\n\ *\n\ * (1L) Givens rotations: the number of such rotations is GIVPTR; the\n\ * pairs of columns/rows they were applied to are stored in GIVCOL;\n\ * and the C- and S-values of these rotations are stored in GIVNUM.\n\ *\n\ * (2L) Permutation. The (NL+1)-st row of B is to be moved to the first\n\ * row, and for J=2:N, PERM(J)-th row of B is to be moved to the\n\ * J-th row.\n\ *\n\ * (3L) The left singular vector matrix of the remaining matrix.\n\ *\n\ * For the right singular vector matrix, four types of orthogonal\n\ * matrices are involved:\n\ *\n\ * (1R) The right singular vector matrix of the remaining matrix.\n\ *\n\ * (2R) If SQRE = 1, one extra Givens rotation to generate the right\n\ * null space.\n\ *\n\ * (3R) The inverse transformation of (2L).\n\ *\n\ * (4R) The inverse transformation of (1L).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ICOMPQ (input) INTEGER\n\ * Specifies whether singular vectors are to be computed in\n\ * factored form:\n\ * = 0: Left singular vector matrix.\n\ * = 1: Right singular vector matrix.\n\ *\n\ * NL (input) INTEGER\n\ * The row dimension of the upper block. NL >= 1.\n\ *\n\ * NR (input) INTEGER\n\ * The row dimension of the lower block. NR >= 1.\n\ *\n\ * SQRE (input) INTEGER\n\ * = 0: the lower block is an NR-by-NR square matrix.\n\ * = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n\ *\n\ * The bidiagonal matrix has row dimension N = NL + NR + 1,\n\ * and column dimension M = N + SQRE.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of columns of B and BX. NRHS must be at least 1.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension ( LDB, NRHS )\n\ * On input, B contains the right hand sides of the least\n\ * squares problem in rows 1 through M. On output, B contains\n\ * the solution X in rows 1 through N.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B. LDB must be at least\n\ * max(1,MAX( M, N ) ).\n\ *\n\ * BX (workspace) COMPLEX*16 array, dimension ( LDBX, NRHS )\n\ *\n\ * LDBX (input) INTEGER\n\ * The leading dimension of BX.\n\ *\n\ * PERM (input) INTEGER array, dimension ( N )\n\ * The permutations (from deflation and sorting) applied\n\ * to the two blocks.\n\ *\n\ * GIVPTR (input) INTEGER\n\ * The number of Givens rotations which took place in this\n\ * subproblem.\n\ *\n\ * GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )\n\ * Each pair of numbers indicates a pair of rows/columns\n\ * involved in a Givens rotation.\n\ *\n\ * LDGCOL (input) INTEGER\n\ * The leading dimension of GIVCOL, must be at least N.\n\ *\n\ * GIVNUM (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )\n\ * Each number indicates the C or S value used in the\n\ * corresponding Givens rotation.\n\ *\n\ * LDGNUM (input) INTEGER\n\ * The leading dimension of arrays DIFR, POLES and\n\ * GIVNUM, must be at least K.\n\ *\n\ * POLES (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )\n\ * On entry, POLES(1:K, 1) contains the new singular\n\ * values obtained from solving the secular equation, and\n\ * POLES(1:K, 2) is an array containing the poles in the secular\n\ * equation.\n\ *\n\ * DIFL (input) DOUBLE PRECISION array, dimension ( K ).\n\ * On entry, DIFL(I) is the distance between I-th updated\n\ * (undeflated) singular value and the I-th (undeflated) old\n\ * singular value.\n\ *\n\ * DIFR (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ).\n\ * On entry, DIFR(I, 1) contains the distances between I-th\n\ * updated (undeflated) singular value and the I+1-th\n\ * (undeflated) old singular value. And DIFR(I, 2) is the\n\ * normalizing factor for the I-th right singular vector.\n\ *\n\ * Z (input) DOUBLE PRECISION array, dimension ( K )\n\ * Contain the components of the deflation-adjusted updating row\n\ * vector.\n\ *\n\ * K (input) INTEGER\n\ * Contains the dimension of the non-deflated matrix,\n\ * This is the order of the related secular equation. 1 <= K <=N.\n\ *\n\ * C (input) DOUBLE PRECISION\n\ * C contains garbage if SQRE =0 and the C-value of a Givens\n\ * rotation related to the right null space if SQRE = 1.\n\ *\n\ * S (input) DOUBLE PRECISION\n\ * S contains garbage if SQRE =0 and the S-value of a Givens\n\ * rotation related to the right null space if SQRE = 1.\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension\n\ * ( K*(1+NRHS) + 2*NRHS )\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\ * Based on contributions by\n\ * Ming Gu and Ren-Cang Li, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sstein0000644000175000017500000001122512502223526016516 0ustar uwabamiuwabami--- :name: sstein :md5sum: bbffab0892513273e4f820370b48ca83 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: real :intent: input :dims: - n-1 - m: :type: integer :intent: input - w: :type: real :intent: input :dims: - n - iblock: :type: integer :intent: input :dims: - n - isplit: :type: integer :intent: input :dims: - n - z: :type: real :intent: output :dims: - ldz - m - ldz: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 5*n - iwork: :type: integer :intent: workspace :dims: - n - ifail: :type: integer :intent: output :dims: - m - info: :type: integer :intent: output :substitutions: ldz: MAX(1,n) m: n :fortran_help: " SUBROUTINE SSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSTEIN computes the eigenvectors of a real symmetric tridiagonal\n\ * matrix T corresponding to specified eigenvalues, using inverse\n\ * iteration.\n\ *\n\ * The maximum number of iterations allowed for each eigenvector is\n\ * specified by an internal parameter MAXITS (currently set to 5).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The n diagonal elements of the tridiagonal matrix T.\n\ *\n\ * E (input) REAL array, dimension (N-1)\n\ * The (n-1) subdiagonal elements of the tridiagonal matrix\n\ * T, in elements 1 to N-1.\n\ *\n\ * M (input) INTEGER\n\ * The number of eigenvectors to be found. 0 <= M <= N.\n\ *\n\ * W (input) REAL array, dimension (N)\n\ * The first M elements of W contain the eigenvalues for\n\ * which eigenvectors are to be computed. The eigenvalues\n\ * should be grouped by split-off block and ordered from\n\ * smallest to largest within the block. ( The output array\n\ * W from SSTEBZ with ORDER = 'B' is expected here. )\n\ *\n\ * IBLOCK (input) INTEGER array, dimension (N)\n\ * The submatrix indices associated with the corresponding\n\ * eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to\n\ * the first submatrix from the top, =2 if W(i) belongs to\n\ * the second submatrix, etc. ( The output array IBLOCK\n\ * from SSTEBZ is expected here. )\n\ *\n\ * ISPLIT (input) INTEGER array, dimension (N)\n\ * The splitting points, at which T breaks up into submatrices.\n\ * The first submatrix consists of rows/columns 1 to\n\ * ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n\ * through ISPLIT( 2 ), etc.\n\ * ( The output array ISPLIT from SSTEBZ is expected here. )\n\ *\n\ * Z (output) REAL array, dimension (LDZ, M)\n\ * The computed eigenvectors. The eigenvector associated\n\ * with the eigenvalue W(i) is stored in the i-th column of\n\ * Z. Any vector which fails to converge is set to its current\n\ * iterate after MAXITS iterations.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) REAL array, dimension (5*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * IFAIL (output) INTEGER array, dimension (M)\n\ * On normal exit, all elements of IFAIL are zero.\n\ * If one or more eigenvectors fail to converge after\n\ * MAXITS iterations, then their indices are stored in\n\ * array IFAIL.\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, then i eigenvectors failed to converge\n\ * in MAXITS iterations. Their indices are stored in\n\ * array IFAIL.\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * MAXITS INTEGER, default = 5\n\ * The maximum number of iterations performed.\n\ *\n\ * EXTRA INTEGER, default = 2\n\ * The number of iterations performed after norm growth\n\ * criterion is satisfied, should be at least 1.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/spotrs0000644000175000017500000000416012502223526016543 0ustar uwabamiuwabami--- :name: spotrs :md5sum: 682fff75d60d2fbfbef656486b39b556 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPOTRS solves a system of linear equations A*X = B with a symmetric\n\ * positive definite matrix A using the Cholesky factorization\n\ * A = U**T*U or A = L*L**T computed by SPOTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T, as computed by SPOTRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dtpttf0000644000175000017500000001252412502223526016521 0ustar uwabamiuwabami--- :name: dtpttf :md5sum: 2f271fd495fd7e413550d296b4710f6e :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - ( n*(n+1)/2 ) - arf: :type: doublereal :intent: output :dims: - ( n*(n+1)/2 ) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DTPTTF( TRANSR, UPLO, N, AP, ARF, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTPTTF copies a triangular matrix A from standard packed format (TP)\n\ * to rectangular full packed format (TF).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': ARF in Normal format is wanted;\n\ * = 'T': ARF in Conjugate-transpose format is wanted.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ),\n\ * On entry, the upper or lower triangular matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * ARF (output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ),\n\ * On exit, the upper or lower triangular matrix A stored in\n\ * RFP format. For a further discussion see Notes below.\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\ * We first consider Rectangular Full Packed (RFP) Format when N is\n\ * even. We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * the transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * the transpose of the last three columns of AP lower.\n\ * This covers the case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 04 05 33 43 53\n\ * 13 14 15 00 44 54\n\ * 23 24 25 10 11 55\n\ * 33 34 35 20 21 22\n\ * 00 44 45 30 31 32\n\ * 01 11 55 40 41 42\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We then consider Rectangular Full Packed (RFP) Format when N is\n\ * odd. We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * the transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * the transpose of the last two columns of AP lower.\n\ * This covers the case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 03 04 00 33 43\n\ * 12 13 14 10 11 44\n\ * 22 23 24 20 21 22\n\ * 00 33 34 30 31 32\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlahr20000644000175000017500000001162212502223526016414 0ustar uwabamiuwabami--- :name: zlahr2 :md5sum: 9ac30357bebcece7da5d61625afa8bb7 :category: :subroutine :arguments: - n: :type: integer :intent: input - k: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n-k+1 - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - MAX(1,nb) - t: :type: doublecomplex :intent: output :dims: - ldt - MAX(1,nb) - ldt: :type: integer :intent: input - y: :type: doublecomplex :intent: output :dims: - ldy - MAX(1,nb) - ldy: :type: integer :intent: input :substitutions: ldy: n ldt: nb :fortran_help: " SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1)\n\ * matrix A so that elements below the k-th subdiagonal are zero. The\n\ * reduction is performed by an unitary similarity transformation\n\ * Q' * A * Q. The routine returns the matrices V and T which determine\n\ * Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n\ *\n\ * This is an auxiliary routine called by ZGEHRD.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A.\n\ *\n\ * K (input) INTEGER\n\ * The offset for the reduction. Elements below the k-th\n\ * subdiagonal in the first NB columns are reduced to zero.\n\ * K < N.\n\ *\n\ * NB (input) INTEGER\n\ * The number of columns to be reduced.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N-K+1)\n\ * On entry, the n-by-(n-k+1) general matrix A.\n\ * On exit, the elements on and above the k-th subdiagonal in\n\ * the first NB columns are overwritten with the corresponding\n\ * elements of the reduced matrix; the elements below the k-th\n\ * subdiagonal, with the array TAU, represent the matrix Q as a\n\ * product of elementary reflectors. The other columns of A are\n\ * unchanged. See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * TAU (output) COMPLEX*16 array, dimension (NB)\n\ * The scalar factors of the elementary reflectors. See Further\n\ * Details.\n\ *\n\ * T (output) COMPLEX*16 array, dimension (LDT,NB)\n\ * The upper triangular matrix T.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= NB.\n\ *\n\ * Y (output) COMPLEX*16 array, dimension (LDY,NB)\n\ * The n-by-nb matrix Y.\n\ *\n\ * LDY (input) INTEGER\n\ * The leading dimension of the array Y. LDY >= N.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The matrix Q is represented as a product of nb elementary reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(nb).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar, and v is a complex vector with\n\ * v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n\ * A(i+k+1:n,i), and tau in TAU(i).\n\ *\n\ * The elements of the vectors v together form the (n-k+1)-by-nb matrix\n\ * V which is needed, with T and Y, to apply the transformation to the\n\ * unreduced part of the matrix, using an update of the form:\n\ * A := (I - V*T*V') * (A - Y*V').\n\ *\n\ * The contents of A on exit are illustrated by the following example\n\ * with n = 7, k = 3 and nb = 2:\n\ *\n\ * ( a a a a a )\n\ * ( a a a a a )\n\ * ( a a a a a )\n\ * ( h h a a a )\n\ * ( v1 h a a a )\n\ * ( v1 v2 a a a )\n\ * ( v1 v2 a a a )\n\ *\n\ * where a denotes an element of the original matrix A, h denotes a\n\ * modified element of the upper Hessenberg matrix H, and vi denotes an\n\ * element of the vector defining H(i).\n\ *\n\ * This subroutine is a slight modification of LAPACK-3.0's DLAHRD\n\ * incorporating improvements proposed by Quintana-Orti and Van de\n\ * Gejin. Note that the entries of A(1:K,2:NB) differ from those\n\ * returned by the original LAPACK-3.0's DLAHRD routine. (This\n\ * subroutine is not backward compatible with LAPACK-3.0's DLAHRD.)\n\ *\n\ * References\n\ * ==========\n\ *\n\ * Gregorio Quintana-Orti and Robert van de Geijn, \"Improving the\n\ * performance of reduction to Hessenberg form,\" ACM Transactions on\n\ * Mathematical Software, 32(2):180-194, June 2006.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlacon0000644000175000017500000000475012502223526016456 0ustar uwabamiuwabami--- :name: dlacon :md5sum: 7ed7cddcc0aa7b3a8a541f6acef383f1 :category: :subroutine :arguments: - n: :type: integer :intent: input - v: :type: doublereal :intent: workspace :dims: - n - x: :type: doublereal :intent: input/output :dims: - n - isgn: :type: integer :intent: workspace :dims: - n - est: :type: doublereal :intent: input/output - kase: :type: integer :intent: input/output :substitutions: {} :fortran_help: " SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLACON estimates the 1-norm of a square, real matrix A.\n\ * Reverse communication is used for evaluating matrix-vector products.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 1.\n\ *\n\ * V (workspace) DOUBLE PRECISION array, dimension (N)\n\ * On the final return, V = A*W, where EST = norm(V)/norm(W)\n\ * (W is not returned).\n\ *\n\ * X (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On an intermediate return, X should be overwritten by\n\ * A * X, if KASE=1,\n\ * A' * X, if KASE=2,\n\ * and DLACON must be re-called with all the other parameters\n\ * unchanged.\n\ *\n\ * ISGN (workspace) INTEGER array, dimension (N)\n\ *\n\ * EST (input/output) DOUBLE PRECISION\n\ * On entry with KASE = 1 or 2 and JUMP = 3, EST should be\n\ * unchanged from the previous call to DLACON.\n\ * On exit, EST is an estimate (a lower bound) for norm(A). \n\ *\n\ * KASE (input/output) INTEGER\n\ * On the initial call to DLACON, KASE should be 0.\n\ * On an intermediate return, KASE will be 1 or 2, indicating\n\ * whether X should be overwritten by A * X or A' * X.\n\ * On the final return from DLACON, KASE will again be 0.\n\ *\n\n\ * Further Details\n\ * ======= =======\n\ *\n\ * Contributed by Nick Higham, University of Manchester.\n\ * Originally named SONEST, dated March 16, 1988.\n\ *\n\ * Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n\ * a real or complex matrix, with applications to condition estimation\",\n\ * ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slapll0000644000175000017500000000363312502223526016504 0ustar uwabamiuwabami--- :name: slapll :md5sum: fe9c0f015b103d941386cd6fd4c0cadd :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - y: :type: real :intent: input/output :dims: - 1+(n-1)*incy - incy: :type: integer :intent: input - ssmin: :type: real :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLAPLL( N, X, INCX, Y, INCY, SSMIN )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Given two column vectors X and Y, let\n\ *\n\ * A = ( X Y ).\n\ *\n\ * The subroutine first computes the QR factorization of A = Q*R,\n\ * and then computes the SVD of the 2-by-2 upper triangular matrix R.\n\ * The smaller singular value of R is returned in SSMIN, which is used\n\ * as the measurement of the linear dependency of the vectors X and Y.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The length of the vectors X and Y.\n\ *\n\ * X (input/output) REAL array,\n\ * dimension (1+(N-1)*INCX)\n\ * On entry, X contains the N-vector X.\n\ * On exit, X is overwritten.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between successive elements of X. INCX > 0.\n\ *\n\ * Y (input/output) REAL array,\n\ * dimension (1+(N-1)*INCY)\n\ * On entry, Y contains the N-vector Y.\n\ * On exit, Y is overwritten.\n\ *\n\ * INCY (input) INTEGER\n\ * The increment between successive elements of Y. INCY > 0.\n\ *\n\ * SSMIN (output) REAL\n\ * The smallest singular value of the N-by-2 matrix A = ( X Y ).\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zpftrs0000644000175000017500000001471212502223526016545 0ustar uwabamiuwabami--- :name: zpftrs :md5sum: 6c99990622f6c51eba397f04e0c5e92f :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPFTRS solves a system of linear equations A*X = B with a Hermitian\n\ * positive definite matrix A using the Cholesky factorization\n\ * A = U**H*U or A = L*L**H computed by ZPFTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': The Normal TRANSR of RFP A is stored;\n\ * = 'C': The Conjugate-transpose TRANSR of RFP A is stored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of RFP A is stored;\n\ * = 'L': Lower triangle of RFP A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension ( N*(N+1)/2 );\n\ * The triangular factor U or L from the Cholesky factorization\n\ * of RFP A = U**H*U or RFP A = L*L**H, as computed by ZPFTRF.\n\ * See note below for more details about RFP A.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * We first consider Standard Packed Format when N is even.\n\ * We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * conjugate-transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * conjugate-transpose of the last three columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- --\n\ * 03 04 05 33 43 53\n\ * -- --\n\ * 13 14 15 00 44 54\n\ * --\n\ * 23 24 25 10 11 55\n\ *\n\ * 33 34 35 20 21 22\n\ * --\n\ * 00 44 45 30 31 32\n\ * -- --\n\ * 01 11 55 40 41 42\n\ * -- -- --\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We next consider Standard Packed Format when N is odd.\n\ * We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * conjugate-transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * conjugate-transpose of the last two columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- --\n\ * 02 03 04 00 33 43\n\ * --\n\ * 12 13 14 10 11 44\n\ *\n\ * 22 23 24 20 21 22\n\ * --\n\ * 00 33 34 30 31 32\n\ * -- --\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- --\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlansf0000644000175000017500000001462112502223526016463 0ustar uwabamiuwabami--- :name: dlansf :md5sum: acc95b8236c6becc6541bc4ec77e258b :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - n*(n+1)/2 - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " DOUBLE PRECISION FUNCTION DLANSF( NORM, TRANSR, UPLO, N, A, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLANSF returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * real symmetric matrix A in RFP format.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * DLANSF returns the value\n\ *\n\ * DLANSF = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in DLANSF as described\n\ * above.\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * Specifies whether the RFP format of A is normal or\n\ * transposed format.\n\ * = 'N': RFP format is Normal;\n\ * = 'T': RFP format is Transpose.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * On entry, UPLO specifies whether the RFP matrix A came from\n\ * an upper or lower triangular matrix as follows:\n\ * = 'U': RFP A came from an upper triangular matrix;\n\ * = 'L': RFP A came from a lower triangular matrix.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, DLANSF is\n\ * set to zero.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 );\n\ * On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')\n\ * part of the symmetric matrix A stored in RFP format. See the\n\ * \"Notes\" below for more details.\n\ * Unchanged on exit.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n\ * WORK is not referenced.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * We first consider Rectangular Full Packed (RFP) Format when N is\n\ * even. We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * the transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * the transpose of the last three columns of AP lower.\n\ * This covers the case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 04 05 33 43 53\n\ * 13 14 15 00 44 54\n\ * 23 24 25 10 11 55\n\ * 33 34 35 20 21 22\n\ * 00 44 45 30 31 32\n\ * 01 11 55 40 41 42\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We then consider Rectangular Full Packed (RFP) Format when N is\n\ * odd. We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * the transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * the transpose of the last two columns of AP lower.\n\ * This covers the case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 03 04 00 33 43\n\ * 12 13 14 10 11 44\n\ * 22 23 24 20 21 22\n\ * 00 33 34 30 31 32\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * Reference\n\ * =========\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slanv20000644000175000017500000000454512502223526016425 0ustar uwabamiuwabami--- :name: slanv2 :md5sum: 8fbb15250e591974a48a0ab06ae552d1 :category: :subroutine :arguments: - a: :type: real :intent: input/output - b: :type: real :intent: input/output - c: :type: real :intent: input/output - d: :type: real :intent: input/output - rt1r: :type: real :intent: output - rt1i: :type: real :intent: output - rt2r: :type: real :intent: output - rt2i: :type: real :intent: output - cs: :type: real :intent: output - sn: :type: real :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric\n\ * matrix in standard form:\n\ *\n\ * [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ]\n\ * [ C D ] [ SN CS ] [ CC DD ] [-SN CS ]\n\ *\n\ * where either\n\ * 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or\n\ * 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex\n\ * conjugate eigenvalues.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * A (input/output) REAL \n\ * B (input/output) REAL \n\ * C (input/output) REAL \n\ * D (input/output) REAL \n\ * On entry, the elements of the input matrix.\n\ * On exit, they are overwritten by the elements of the\n\ * standardised Schur form.\n\ *\n\ * RT1R (output) REAL \n\ * RT1I (output) REAL \n\ * RT2R (output) REAL \n\ * RT2I (output) REAL \n\ * The real and imaginary parts of the eigenvalues. If the\n\ * eigenvalues are a complex conjugate pair, RT1I > 0.\n\ *\n\ * CS (output) REAL \n\ * SN (output) REAL \n\ * Parameters of the rotation matrix.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Modified by V. Sima, Research Institute for Informatics, Bucharest,\n\ * Romania, to reduce the risk of cancellation errors,\n\ * when computing real eigenvalues, and to ensure, if possible, that\n\ * abs(RT1R) >= abs(RT2R).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cheevr0000644000175000017500000003200012502223525016456 0ustar uwabamiuwabami--- :name: cheevr :md5sum: 9d3a30fde6d44c5d3a22bf2f8b026b5b :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: real :intent: output :dims: - MAX(1,lrwork) - lrwork: :type: integer :intent: input :option: true :default: 24*n - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: 10*n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " SUBROUTINE CHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHEEVR computes selected eigenvalues and, optionally, eigenvectors\n\ * of a complex Hermitian matrix A. Eigenvalues and eigenvectors can\n\ * be selected by specifying either a range of values or a range of\n\ * indices for the desired eigenvalues.\n\ *\n\ * CHEEVR first reduces the matrix A to tridiagonal form T with a call\n\ * to CHETRD. Then, whenever possible, CHEEVR calls CSTEMR to compute\n\ * the eigenspectrum using Relatively Robust Representations. CSTEMR\n\ * computes eigenvalues by the dqds algorithm, while orthogonal\n\ * eigenvectors are computed from various \"good\" L D L^T representations\n\ * (also known as Relatively Robust Representations). Gram-Schmidt\n\ * orthogonalization is avoided as far as possible. More specifically,\n\ * the various steps of the algorithm are as follows.\n\ *\n\ * For each unreduced block (submatrix) of T,\n\ * (a) Compute T - sigma I = L D L^T, so that L and D\n\ * define all the wanted eigenvalues to high relative accuracy.\n\ * This means that small relative changes in the entries of D and L\n\ * cause only small relative changes in the eigenvalues and\n\ * eigenvectors. The standard (unfactored) representation of the\n\ * tridiagonal matrix T does not have this property in general.\n\ * (b) Compute the eigenvalues to suitable accuracy.\n\ * If the eigenvectors are desired, the algorithm attains full\n\ * accuracy of the computed eigenvalues only right before\n\ * the corresponding vectors have to be computed, see steps c) and d).\n\ * (c) For each cluster of close eigenvalues, select a new\n\ * shift close to the cluster, find a new factorization, and refine\n\ * the shifted eigenvalues to suitable accuracy.\n\ * (d) For each eigenvalue with a large enough relative separation compute\n\ * the corresponding eigenvector by forming a rank revealing twisted\n\ * factorization. Go back to (c) for any clusters that remain.\n\ *\n\ * The desired accuracy of the output can be specified by the input\n\ * parameter ABSTOL.\n\ *\n\ * For more details, see DSTEMR's documentation and:\n\ * - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n\ * to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n\ * Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n\ * - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n\ * Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n\ * 2004. Also LAPACK Working Note 154.\n\ * - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n\ * tridiagonal eigenvalue/eigenvector problem\",\n\ * Computer Science Division Technical Report No. UCB/CSD-97-971,\n\ * UC Berkeley, May 1997.\n\ *\n\ *\n\ * Note 1 : CHEEVR calls CSTEMR when the full spectrum is requested\n\ * on machines which conform to the ieee-754 floating point standard.\n\ * CHEEVR calls SSTEBZ and CSTEIN on non-ieee machines and\n\ * when partial spectrum requests are made.\n\ *\n\ * Normal execution of CSTEMR may create NaNs and infinities and\n\ * hence may abort due to a floating point exception in environments\n\ * which do not handle NaNs and infinities in the ieee standard default\n\ * manner.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found.\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found.\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ ********** For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and\n\ ********** CSTEIN are called\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA, N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of A contains the\n\ * upper triangular part of the matrix A. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of A contains\n\ * the lower triangular part of the matrix A.\n\ * On exit, the lower triangle (if UPLO='L') or the upper\n\ * triangle (if UPLO='U') of A, including the diagonal, is\n\ * destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * VL (input) REAL\n\ * VU (input) REAL\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) REAL\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less than\n\ * or equal to zero, then EPS*|T| will be used in its place,\n\ * where |T| is the 1-norm of the tridiagonal matrix obtained\n\ * by reducing A to tridiagonal form.\n\ *\n\ * See \"Computing Small Singular Values of Bidiagonal Matrices\n\ * with Guaranteed High Relative Accuracy,\" by Demmel and\n\ * Kahan, LAPACK Working Note #3.\n\ *\n\ * If high relative accuracy is important, set ABSTOL to\n\ * SLAMCH( 'Safe minimum' ). Doing so will guarantee that\n\ * eigenvalues are computed to high relative accuracy when\n\ * possible in future releases. The current code does not\n\ * make any guarantees about high relative accuracy, but\n\ * furutre releases will. See J. Barlow and J. Demmel,\n\ * \"Computing Accurate Eigensystems of Scaled Diagonally\n\ * Dominant Matrices\", LAPACK Working Note #7, for a discussion\n\ * of which matrices define their eigenvalues to high relative\n\ * accuracy.\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * The first M elements contain the selected eigenvalues in\n\ * ascending order.\n\ *\n\ * Z (output) COMPLEX array, dimension (LDZ, max(1,M))\n\ * If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix A\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )\n\ * The support of the eigenvectors in Z, i.e., the indices\n\ * indicating the nonzero elements in Z. The i-th eigenvector\n\ * is nonzero only in elements ISUPPZ( 2*i-1 ) through\n\ * ISUPPZ( 2*i ).\n\ ********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1\n\ *\n\ * WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of the array WORK. LWORK >= max(1,2*N).\n\ * For optimal efficiency, LWORK >= (NB+1)*N,\n\ * where NB is the max of the blocksize for CHETRD and for\n\ * CUNMTR as returned by ILAENV.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the optimal sizes of the WORK, RWORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK))\n\ * On exit, if INFO = 0, RWORK(1) returns the optimal\n\ * (and minimal) LRWORK.\n\ *\n\ * LRWORK (input) INTEGER\n\ * The length of the array RWORK. LRWORK >= max(1,24*N).\n\ *\n\ * If LRWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal\n\ * (and minimal) LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK. LIWORK >= max(1,10*N).\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK 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: Internal error\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Inderjit Dhillon, IBM Almaden, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Ken Stanley, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ * Jason Riedy, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sorgrq0000644000175000017500000000566612502223526016542 0ustar uwabamiuwabami--- :name: sorgrq :md5sum: 6a4e113034625a1fc6d7f18a8ca85de7 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SORGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SORGRQ generates an M-by-N real matrix Q with orthonormal rows,\n\ * which is defined as the last M rows of a product of K elementary\n\ * reflectors of order N\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by SGERQF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. N >= M.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. M >= K >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the (m-k+i)-th row must contain the vector which\n\ * defines the elementary reflector H(i), for i = 1,2,...,k, as\n\ * returned by SGERQF in the last k rows of its array argument\n\ * A.\n\ * On exit, the M-by-N matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) REAL array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by SGERQF.\n\ *\n\ * WORK (workspace/output) REAL 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 has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clacrm0000644000175000017500000000414612502223525016455 0ustar uwabamiuwabami--- :name: clacrm :md5sum: 1bf6ccc7ff0a4a97890dd67394c3dfe6 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: complex :intent: output :dims: - ldc - n - ldc: :type: integer :intent: input - rwork: :type: real :intent: workspace :dims: - 2*m*n :substitutions: ldc: MAX(1,n) :fortran_help: " SUBROUTINE CLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLACRM performs a very simple matrix-matrix multiplication:\n\ * C := A * B,\n\ * where A is M by N and complex; B is N by N and real;\n\ * C is M by N and complex.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A and of the matrix C.\n\ * M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns and rows of the matrix B and\n\ * the number of columns of the matrix C.\n\ * N >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA, N)\n\ * A contains 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\ * B (input) REAL array, dimension (LDB, N)\n\ * B contains the N by N matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >=max(1,N).\n\ *\n\ * C (input) COMPLEX array, dimension (LDC, N)\n\ * C contains the M by N matrix C.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >=max(1,N).\n\ *\n\ * RWORK (workspace) REAL array, dimension (2*M*N)\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slaqr40000644000175000017500000002145012502223526016420 0ustar uwabamiuwabami--- :name: slaqr4 :md5sum: 9408e2dd3693791efc87fae05ebec6b6 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: real :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - wr: :type: real :intent: output :dims: - ihi - wi: :type: real :intent: output :dims: - ihi - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: real :intent: input/output :dims: - ldz - ihi - ldz: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAQR4 computes the eigenvalues of a Hessenberg matrix H\n\ * and, optionally, the matrices T and Z from the Schur decomposition\n\ * H = Z T Z**T, where T is an upper quasi-triangular matrix (the\n\ * Schur form), and Z is the orthogonal matrix of Schur vectors.\n\ *\n\ * Optionally Z may be postmultiplied into an input orthogonal\n\ * matrix Q so that this routine can give the Schur factorization\n\ * of a matrix A which has been reduced to the Hessenberg form H\n\ * by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * WANTT (input) LOGICAL\n\ * = .TRUE. : the full Schur form T is required;\n\ * = .FALSE.: only eigenvalues are required.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * = .TRUE. : the matrix of Schur vectors Z is required;\n\ * = .FALSE.: Schur vectors are not required.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H. N .GE. 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * It is assumed that H is already upper triangular in rows\n\ * and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n\ * H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n\ * previous call to SGEBAL, and then passed to SGEHRD when the\n\ * matrix output by SGEBAL is reduced to Hessenberg form.\n\ * Otherwise, ILO and IHI should be set to 1 and N,\n\ * respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n\ * If N = 0, then ILO = 1 and IHI = 0.\n\ *\n\ * H (input/output) REAL array, dimension (LDH,N)\n\ * On entry, the upper Hessenberg matrix H.\n\ * On exit, if INFO = 0 and WANTT is .TRUE., then H contains\n\ * the upper quasi-triangular matrix T from the Schur\n\ * decomposition (the Schur form); 2-by-2 diagonal blocks\n\ * (corresponding to complex conjugate pairs of eigenvalues)\n\ * are returned in standard form, with H(i,i) = H(i+1,i+1)\n\ * and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is\n\ * .FALSE., then the contents of H are unspecified on exit.\n\ * (The output value of H when INFO.GT.0 is given under the\n\ * description of INFO below.)\n\ *\n\ * This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n\ * j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n\ *\n\ * LDH (input) INTEGER\n\ * The leading dimension of the array H. LDH .GE. max(1,N).\n\ *\n\ * WR (output) REAL array, dimension (IHI)\n\ * WI (output) REAL array, dimension (IHI)\n\ * The real and imaginary parts, respectively, of the computed\n\ * eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI)\n\ * and WI(ILO:IHI). If two eigenvalues are computed as a\n\ * complex conjugate pair, they are stored in consecutive\n\ * elements of WR and WI, say the i-th and (i+1)th, with\n\ * WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then\n\ * the eigenvalues are stored in the same order as on the\n\ * diagonal of the Schur form returned in H, with\n\ * WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal\n\ * block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and\n\ * WI(i+1) = -WI(i).\n\ *\n\ * ILOZ (input) INTEGER\n\ * IHIZ (input) INTEGER\n\ * Specify the rows of Z to which transformations must be\n\ * applied if WANTZ is .TRUE..\n\ * 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.\n\ *\n\ * Z (input/output) REAL array, dimension (LDZ,IHI)\n\ * If WANTZ is .FALSE., then Z is not referenced.\n\ * If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n\ * replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n\ * orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n\ * (The output value of Z when INFO.GT.0 is given under\n\ * the description of INFO below.)\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. if WANTZ is .TRUE.\n\ * then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.\n\ *\n\ * WORK (workspace/output) REAL array, dimension LWORK\n\ * On exit, if LWORK = -1, WORK(1) returns an estimate of\n\ * the optimal value for LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK .GE. max(1,N)\n\ * is sufficient, but LWORK typically as large as 6*N may\n\ * be required for optimal performance. A workspace query\n\ * to determine the optimal workspace size is recommended.\n\ *\n\ * If LWORK = -1, then SLAQR4 does a workspace query.\n\ * In this case, SLAQR4 checks the input parameters and\n\ * estimates the optimal workspace size for the given\n\ * values of N, ILO and IHI. The estimate is returned\n\ * in WORK(1). No error message related to LWORK is\n\ * issued by XERBLA. Neither H nor Z are accessed.\n\ *\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * .GT. 0: if INFO = i, SLAQR4 failed to compute all of\n\ * the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n\ * and WI contain those eigenvalues which have been\n\ * successfully computed. (Failures are rare.)\n\ *\n\ * If INFO .GT. 0 and WANT is .FALSE., then on exit,\n\ * the remaining unconverged eigenvalues are the eigen-\n\ * values of the upper Hessenberg matrix rows and\n\ * columns ILO through INFO of the final, output\n\ * value of H.\n\ *\n\ * If INFO .GT. 0 and WANTT is .TRUE., then on exit\n\ *\n\ * (*) (initial value of H)*U = U*(final value of H)\n\ *\n\ * where U is an orthogonal matrix. The final\n\ * value of H is upper Hessenberg and quasi-triangular\n\ * in rows and columns INFO+1 through IHI.\n\ *\n\ * If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n\ *\n\ * (final value of Z(ILO:IHI,ILOZ:IHIZ)\n\ * = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n\ *\n\ * where U is the orthogonal matrix in (*) (regard-\n\ * less of the value of WANTT.)\n\ *\n\ * If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n\ * accessed.\n\ *\n\n\ * ================================================================\n\ * Based on contributions by\n\ * Karen Braman and Ralph Byers, Department of Mathematics,\n\ * University of Kansas, USA\n\ *\n\ * ================================================================\n\ * References:\n\ * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n\ * Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n\ * Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n\ * 929--947, 2002.\n\ *\n\ * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n\ * Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n\ * of Matrix Analysis, volume 23, pages 948--973, 2002.\n\ *\n\ * ================================================================\n" ruby-lapack-1.7.2/dev/defs/sgeevx0000644000175000017500000002500112502223526016507 0ustar uwabamiuwabami--- :name: sgeevx :md5sum: def8c51083d6025e43422c29fe495dfd :category: :subroutine :arguments: - balanc: :type: char :intent: input - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - wr: :type: real :intent: output :dims: - n - wi: :type: real :intent: output :dims: - n - vl: :type: real :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: real :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - scale: :type: real :intent: output :dims: - n - abnrm: :type: real :intent: output - rconde: :type: real :intent: output :dims: - n - rcondv: :type: real :intent: output :dims: - n - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(lsame_(&sense,\"N\")||lsame_(&sense,\"E\")) ? 2*n : (lsame_(&jobvl,\"V\")||lsame_(&jobvr,\"V\")) ? 3*n : (lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? n*(n+6) : 0" - iwork: :type: integer :intent: workspace :dims: - "(lsame_(&sense,\"N\")||lsame_(&sense,\"E\")) ? 0 : 2*n-2" - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " SUBROUTINE SGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, WORK, LWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGEEVX computes for an N-by-N real nonsymmetric matrix A, the\n\ * eigenvalues and, optionally, the left and/or right eigenvectors.\n\ *\n\ * Optionally also, it computes a balancing transformation to improve\n\ * the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n\ * SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues\n\ * (RCONDE), and reciprocal condition numbers for the right\n\ * eigenvectors (RCONDV).\n\ *\n\ * The right eigenvector v(j) of A satisfies\n\ * A * v(j) = lambda(j) * v(j)\n\ * where lambda(j) is its eigenvalue.\n\ * The left eigenvector u(j) of A satisfies\n\ * u(j)**H * A = lambda(j) * u(j)**H\n\ * where u(j)**H denotes the conjugate transpose of u(j).\n\ *\n\ * The computed eigenvectors are normalized to have Euclidean norm\n\ * equal to 1 and largest component real.\n\ *\n\ * Balancing a matrix means permuting the rows and columns to make it\n\ * more nearly upper triangular, and applying a diagonal similarity\n\ * transformation D * A * D**(-1), where D is a diagonal matrix, to\n\ * make its rows and columns closer in norm and the condition numbers\n\ * of its eigenvalues and eigenvectors smaller. The computed\n\ * reciprocal condition numbers correspond to the balanced matrix.\n\ * Permuting rows and columns will not change the condition numbers\n\ * (in exact arithmetic) but diagonal scaling will. For further\n\ * explanation of balancing, see section 4.10.2 of the LAPACK\n\ * Users' Guide.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * BALANC (input) CHARACTER*1\n\ * Indicates how the input matrix should be diagonally scaled\n\ * and/or permuted to improve the conditioning of its\n\ * eigenvalues.\n\ * = 'N': Do not diagonally scale or permute;\n\ * = 'P': Perform permutations to make the matrix more nearly\n\ * upper triangular. Do not diagonally scale;\n\ * = 'S': Diagonally scale the matrix, i.e. replace A by\n\ * D*A*D**(-1), where D is a diagonal matrix chosen\n\ * to make the rows and columns of A more equal in\n\ * norm. Do not permute;\n\ * = 'B': Both diagonally scale and permute A.\n\ *\n\ * Computed reciprocal condition numbers will be for the matrix\n\ * after balancing and/or permuting. Permuting does not change\n\ * condition numbers (in exact arithmetic), but balancing does.\n\ *\n\ * JOBVL (input) CHARACTER*1\n\ * = 'N': left eigenvectors of A are not computed;\n\ * = 'V': left eigenvectors of A are computed.\n\ * If SENSE = 'E' or 'B', JOBVL must = 'V'.\n\ *\n\ * JOBVR (input) CHARACTER*1\n\ * = 'N': right eigenvectors of A are not computed;\n\ * = 'V': right eigenvectors of A are computed.\n\ * If SENSE = 'E' or 'B', JOBVR must = 'V'.\n\ *\n\ * SENSE (input) CHARACTER*1\n\ * Determines which reciprocal condition numbers are computed.\n\ * = 'N': None are computed;\n\ * = 'E': Computed for eigenvalues only;\n\ * = 'V': Computed for right eigenvectors only;\n\ * = 'B': Computed for eigenvalues and right eigenvectors.\n\ *\n\ * If SENSE = 'E' or 'B', both left and right eigenvectors\n\ * must also be computed (JOBVL = 'V' and JOBVR = 'V').\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ * On exit, A has been overwritten. If JOBVL = 'V' or\n\ * JOBVR = 'V', A contains the real Schur form of the balanced\n\ * version of the input matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * WR (output) REAL array, dimension (N)\n\ * WI (output) REAL array, dimension (N)\n\ * WR and WI contain the real and imaginary parts,\n\ * respectively, of the computed eigenvalues. Complex\n\ * conjugate pairs of eigenvalues will appear consecutively\n\ * with the eigenvalue having the positive imaginary part\n\ * first.\n\ *\n\ * VL (output) REAL array, dimension (LDVL,N)\n\ * If JOBVL = 'V', the left eigenvectors u(j) are stored one\n\ * after another in the columns of VL, in the same order\n\ * as their eigenvalues.\n\ * If JOBVL = 'N', VL is not referenced.\n\ * If the j-th eigenvalue is real, then u(j) = VL(:,j),\n\ * the j-th column of VL.\n\ * If the j-th and (j+1)-st eigenvalues form a complex\n\ * conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and\n\ * u(j+1) = VL(:,j) - i*VL(:,j+1).\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the array VL. LDVL >= 1; if\n\ * JOBVL = 'V', LDVL >= N.\n\ *\n\ * VR (output) REAL array, dimension (LDVR,N)\n\ * If JOBVR = 'V', the right eigenvectors v(j) are stored one\n\ * after another in the columns of VR, in the same order\n\ * as their eigenvalues.\n\ * If JOBVR = 'N', VR is not referenced.\n\ * If the j-th eigenvalue is real, then v(j) = VR(:,j),\n\ * the j-th column of VR.\n\ * If the j-th and (j+1)-st eigenvalues form a complex\n\ * conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and\n\ * v(j+1) = VR(:,j) - i*VR(:,j+1).\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the array VR. LDVR >= 1, and if\n\ * JOBVR = 'V', LDVR >= N.\n\ *\n\ * ILO (output) INTEGER\n\ * IHI (output) INTEGER\n\ * ILO and IHI are integer values determined when A was\n\ * balanced. The balanced A(i,j) = 0 if I > J and \n\ * J = 1,...,ILO-1 or I = IHI+1,...,N.\n\ *\n\ * SCALE (output) REAL array, dimension (N)\n\ * Details of the permutations and scaling factors applied\n\ * when balancing A. If P(j) is the index of the row and column\n\ * interchanged with row and column j, and D(j) is the scaling\n\ * factor applied to row and column j, then\n\ * SCALE(J) = P(J), for J = 1,...,ILO-1\n\ * = D(J), for J = ILO,...,IHI\n\ * = P(J) for J = IHI+1,...,N.\n\ * The order in which the interchanges are made is N to IHI+1,\n\ * then 1 to ILO-1.\n\ *\n\ * ABNRM (output) REAL\n\ * The one-norm of the balanced matrix (the maximum\n\ * of the sum of absolute values of elements of any column).\n\ *\n\ * RCONDE (output) REAL array, dimension (N)\n\ * RCONDE(j) is the reciprocal condition number of the j-th\n\ * eigenvalue.\n\ *\n\ * RCONDV (output) REAL array, dimension (N)\n\ * RCONDV(j) is the reciprocal condition number of the j-th\n\ * right eigenvector.\n\ *\n\ * WORK (workspace/output) REAL 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. If SENSE = 'N' or 'E',\n\ * LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V',\n\ * LWORK >= 3*N. If SENSE = 'V' or 'B', LWORK >= N*(N+6).\n\ * For good performance, LWORK must generally be larger.\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\ * IWORK (workspace) INTEGER array, dimension (2*N-2)\n\ * If SENSE = 'N' or 'E', not referenced.\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 QR algorithm failed to compute all the\n\ * eigenvalues, and no eigenvectors or condition numbers\n\ * have been computed; elements 1:ILO-1 and i+1:N of WR\n\ * and WI contain eigenvalues which have converged.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dpteqr0000644000175000017500000001051712502223526016513 0ustar uwabamiuwabami--- :name: dpteqr :md5sum: 82a196d2a9d89768456560591eed50c9 :category: :subroutine :arguments: - compz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - z: :type: doublereal :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPTEQR computes all eigenvalues and, optionally, eigenvectors of a\n\ * symmetric positive definite tridiagonal matrix by first factoring the\n\ * matrix using DPTTRF, and then calling DBDSQR to compute the singular\n\ * values of the bidiagonal factor.\n\ *\n\ * This routine computes the eigenvalues of the positive definite\n\ * tridiagonal matrix to high relative accuracy. This means that if the\n\ * eigenvalues range over many orders of magnitude in size, then the\n\ * small eigenvalues and corresponding eigenvectors will be computed\n\ * more accurately than, for example, with the standard QR method.\n\ *\n\ * The eigenvectors of a full or band symmetric positive definite matrix\n\ * can also be found if DSYTRD, DSPTRD, or DSBTRD has been used to\n\ * reduce this matrix to tridiagonal form. (The reduction to tridiagonal\n\ * form, however, may preclude the possibility of obtaining high\n\ * relative accuracy in the small eigenvalues of the original matrix, if\n\ * these eigenvalues range over many orders of magnitude.)\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * COMPZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only.\n\ * = 'V': Compute eigenvectors of original symmetric\n\ * matrix also. Array Z contains the orthogonal\n\ * matrix used to reduce the original matrix to\n\ * tridiagonal form.\n\ * = 'I': Compute eigenvectors of tridiagonal matrix also.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the n diagonal elements of the tridiagonal\n\ * matrix.\n\ * On normal exit, D contains the eigenvalues, in descending\n\ * order.\n\ *\n\ * E (input/output) DOUBLE PRECISION array, dimension (N-1)\n\ * On entry, the (n-1) subdiagonal elements of the tridiagonal\n\ * matrix.\n\ * On exit, E has been destroyed.\n\ *\n\ * Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)\n\ * On entry, if COMPZ = 'V', the orthogonal matrix used in the\n\ * reduction to tridiagonal form.\n\ * On exit, if COMPZ = 'V', the orthonormal eigenvectors of the\n\ * original symmetric matrix;\n\ * if COMPZ = 'I', the orthonormal eigenvectors of the\n\ * tridiagonal matrix.\n\ * If INFO > 0 on exit, Z contains the eigenvectors associated\n\ * with only the stored eigenvalues.\n\ * If COMPZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * COMPZ = 'V' or 'I', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\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, and i is:\n\ * <= N the Cholesky factorization of the matrix could\n\ * not be performed because the i-th principal minor\n\ * was not positive definite.\n\ * > N the SVD algorithm failed to converge;\n\ * if INFO = N+i, i off-diagonal elements of the\n\ * bidiagonal factor did not converge to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slaic10000644000175000017500000000513612502223526016371 0ustar uwabamiuwabami--- :name: slaic1 :md5sum: 5a7ca2ea3cbe409b461402c0b08dd9ba :category: :subroutine :arguments: - job: :type: integer :intent: input - j: :type: integer :intent: input - x: :type: real :intent: input :dims: - j - sest: :type: real :intent: input - w: :type: real :intent: input :dims: - j - gamma: :type: real :intent: input - sestpr: :type: real :intent: output - s: :type: real :intent: output - c: :type: real :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAIC1 applies one step of incremental condition estimation in\n\ * its simplest version:\n\ *\n\ * Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j\n\ * lower triangular matrix L, such that\n\ * twonorm(L*x) = sest\n\ * Then SLAIC1 computes sestpr, s, c such that\n\ * the vector\n\ * [ s*x ]\n\ * xhat = [ c ]\n\ * is an approximate singular vector of\n\ * [ L 0 ]\n\ * Lhat = [ w' gamma ]\n\ * in the sense that\n\ * twonorm(Lhat*xhat) = sestpr.\n\ *\n\ * Depending on JOB, an estimate for the largest or smallest singular\n\ * value is computed.\n\ *\n\ * Note that [s c]' and sestpr**2 is an eigenpair of the system\n\ *\n\ * diag(sest*sest, 0) + [alpha gamma] * [ alpha ]\n\ * [ gamma ]\n\ *\n\ * where alpha = x'*w.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) INTEGER\n\ * = 1: an estimate for the largest singular value is computed.\n\ * = 2: an estimate for the smallest singular value is computed.\n\ *\n\ * J (input) INTEGER\n\ * Length of X and W\n\ *\n\ * X (input) REAL array, dimension (J)\n\ * The j-vector x.\n\ *\n\ * SEST (input) REAL\n\ * Estimated singular value of j by j matrix L\n\ *\n\ * W (input) REAL array, dimension (J)\n\ * The j-vector w.\n\ *\n\ * GAMMA (input) REAL\n\ * The diagonal element gamma.\n\ *\n\ * SESTPR (output) REAL\n\ * Estimated singular value of (j+1) by (j+1) matrix Lhat.\n\ *\n\ * S (output) REAL\n\ * Sine needed in forming xhat.\n\ *\n\ * C (output) REAL\n\ * Cosine needed in forming xhat.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgbtrs0000644000175000017500000000602612502223526016501 0ustar uwabamiuwabami--- :name: dgbtrs :md5sum: a4125cfc65d3f9c498b42c6cbaaedb91 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGBTRS solves a system of linear equations\n\ * A * X = B or A' * X = B\n\ * with a general band matrix A using the LU factorization computed\n\ * by DGBTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations.\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A'* X = B (Transpose)\n\ * = 'C': A'* X = B (Conjugate transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * Details of the LU factorization of the band matrix A, as\n\ * computed by DGBTRF. U is stored as an upper triangular band\n\ * matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n\ * the multipliers used during the factorization are stored in\n\ * rows KL+KU+2 to 2*KL+KU+1.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices; for 1 <= i <= N, row i of the matrix was\n\ * interchanged with row IPIV(i).\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/spotri0000644000175000017500000000411512502223526016531 0ustar uwabamiuwabami--- :name: spotri :md5sum: 25b6d8f49368c27482c933dfa5623c9b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPOTRI( UPLO, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPOTRI computes the inverse of a real symmetric positive definite\n\ * matrix A using the Cholesky factorization A = U**T*U or A = L*L**T\n\ * computed by SPOTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the triangular factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T, as computed by\n\ * SPOTRF.\n\ * On exit, the upper or lower triangle of the (symmetric)\n\ * inverse of A, overwriting the input factor U or L.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\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,i) element of the factor U or L is\n\ * zero, and the inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SLAUUM, STRTRI, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slaset0000644000175000017500000000472412502223526016512 0ustar uwabamiuwabami--- :name: slaset :md5sum: 28d3123066d541479be9ab6a5b21ab74 :category: :subroutine :arguments: - uplo: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: real :intent: input - beta: :type: real :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE SLASET( UPLO, M, N, ALPHA, BETA, A, LDA )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLASET initializes an m-by-n matrix A to BETA on the diagonal and\n\ * ALPHA on the offdiagonals.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies the part of the matrix A to be set.\n\ * = 'U': Upper triangular part is set; the strictly lower\n\ * triangular part of A is not changed.\n\ * = 'L': Lower triangular part is set; the strictly upper\n\ * triangular part of A is not changed.\n\ * Otherwise: All of the matrix A is set.\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\ * ALPHA (input) REAL\n\ * The constant to which the offdiagonal elements are to be set.\n\ *\n\ * BETA (input) REAL\n\ * The constant to which the diagonal elements are to be set.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On exit, the leading m-by-n submatrix of A is set as follows:\n\ *\n\ * if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n,\n\ * if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n,\n\ * otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j,\n\ *\n\ * and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cgeqr2p0000644000175000017500000000474112502223525016560 0ustar uwabamiuwabami--- :name: cgeqr2p :md5sum: fd03ae20ad3f07feeda91959e82ee8fb :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - MIN(m,n) - work: :type: complex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGEQR2P( M, N, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGEQR2P computes a QR factorization of a complex m by n matrix A:\n\ * A = Q * R.\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) COMPLEX array, dimension (LDA,N)\n\ * On entry, the m by n matrix A.\n\ * On exit, the elements on and above the diagonal of the array\n\ * contain the min(m,n) by n upper trapezoidal matrix R (R is\n\ * upper triangular if m >= n); the elements below the diagonal,\n\ * with the array TAU, represent the unitary 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) COMPLEX array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (N)\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(1) H(2) . . . H(k), 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 complex scalar, and v is a complex vector with\n\ * v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n\ * and tau in TAU(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zggesx0000644000175000017500000002666312502223526016534 0ustar uwabamiuwabami--- :name: zggesx :md5sum: d871f51cd6ca4808303ae8fcba8e7fbf :category: :subroutine :arguments: - jobvsl: :type: char :intent: input - jobvsr: :type: char :intent: input - sort: :type: char :intent: input - selctg: :intent: external procedure :block_type: logical :block_arg_num: 2 :block_arg_type: doublecomplex - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - sdim: :type: integer :intent: output - alpha: :type: doublecomplex :intent: output :dims: - n - beta: :type: doublecomplex :intent: output :dims: - n - vsl: :type: doublecomplex :intent: output :dims: - ldvsl - n - ldvsl: :type: integer :intent: input - vsr: :type: doublecomplex :intent: output :dims: - ldvsr - n - ldvsr: :type: integer :intent: input - rconde: :type: doublereal :intent: output :dims: - "2" - rcondv: :type: doublereal :intent: output :dims: - "2" - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n==0 ? 1 : (lsame_(&sense,\"E\")||lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? MAX(2*n,n*n/2) : 2*n" - rwork: :type: doublereal :intent: workspace :dims: - 8*n - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "(lsame_(&sense,\"N\")||n==0) ? 1 : n+2" - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvsl: "lsame_(&jobvsl,\"V\") ? n : 1" ldvsr: "lsame_(&jobvsr,\"V\") ? n : 1" :fortran_help: " SUBROUTINE ZGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, B, LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, RWORK, IWORK, LIWORK, BWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGGESX computes for a pair of N-by-N complex nonsymmetric matrices\n\ * (A,B), the generalized eigenvalues, the complex Schur form (S,T),\n\ * and, optionally, the left and/or right matrices of Schur vectors (VSL\n\ * and VSR). This gives the generalized Schur factorization\n\ *\n\ * (A,B) = ( (VSL) S (VSR)**H, (VSL) T (VSR)**H )\n\ *\n\ * where (VSR)**H is the conjugate-transpose of VSR.\n\ *\n\ * Optionally, it also orders the eigenvalues so that a selected cluster\n\ * of eigenvalues appears in the leading diagonal blocks of the upper\n\ * triangular matrix S and the upper triangular matrix T; computes\n\ * a reciprocal condition number for the average of the selected\n\ * eigenvalues (RCONDE); and computes a reciprocal condition number for\n\ * the right and left deflating subspaces corresponding to the selected\n\ * eigenvalues (RCONDV). The leading columns of VSL and VSR then form\n\ * an orthonormal basis for the corresponding left and right eigenspaces\n\ * (deflating subspaces).\n\ *\n\ * A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n\ * or a ratio alpha/beta = w, such that A - w*B is singular. It is\n\ * usually represented as the pair (alpha,beta), as there is a\n\ * reasonable interpretation for beta=0 or for both being zero.\n\ *\n\ * A pair of matrices (S,T) is in generalized complex Schur form if T is\n\ * upper triangular with non-negative diagonal and S is upper\n\ * triangular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVSL (input) CHARACTER*1\n\ * = 'N': do not compute the left Schur vectors;\n\ * = 'V': compute the left Schur vectors.\n\ *\n\ * JOBVSR (input) CHARACTER*1\n\ * = 'N': do not compute the right Schur vectors;\n\ * = 'V': compute the right Schur vectors.\n\ *\n\ * SORT (input) CHARACTER*1\n\ * Specifies whether or not to order the eigenvalues on the\n\ * diagonal of the generalized Schur form.\n\ * = 'N': Eigenvalues are not ordered;\n\ * = 'S': Eigenvalues are ordered (see SELCTG).\n\ *\n\ * SELCTG (external procedure) LOGICAL FUNCTION of two COMPLEX*16 arguments\n\ * SELCTG must be declared EXTERNAL in the calling subroutine.\n\ * If SORT = 'N', SELCTG is not referenced.\n\ * If SORT = 'S', SELCTG is used to select eigenvalues to sort\n\ * to the top left of the Schur form.\n\ * Note that a selected complex eigenvalue may no longer satisfy\n\ * SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since\n\ * ordering may change the value of complex eigenvalues\n\ * (especially if the eigenvalue is ill-conditioned), in this\n\ * case INFO is set to N+3 see INFO below).\n\ *\n\ * SENSE (input) CHARACTER*1\n\ * Determines which reciprocal condition numbers are computed.\n\ * = 'N' : None are computed;\n\ * = 'E' : Computed for average of selected eigenvalues only;\n\ * = 'V' : Computed for selected deflating subspaces only;\n\ * = 'B' : Computed for both.\n\ * If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A, B, VSL, and VSR. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA, N)\n\ * On entry, the first of the pair of matrices.\n\ * On exit, A has been overwritten by its generalized Schur\n\ * form S.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB, N)\n\ * On entry, the second of the pair of matrices.\n\ * On exit, B has been overwritten by its generalized Schur\n\ * form T.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B. LDB >= max(1,N).\n\ *\n\ * SDIM (output) INTEGER\n\ * If SORT = 'N', SDIM = 0.\n\ * If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n\ * for which SELCTG is true.\n\ *\n\ * ALPHA (output) COMPLEX*16 array, dimension (N)\n\ * BETA (output) COMPLEX*16 array, dimension (N)\n\ * On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the\n\ * generalized eigenvalues. ALPHA(j) and BETA(j),j=1,...,N are\n\ * the diagonals of the complex Schur form (S,T). BETA(j) will\n\ * be non-negative real.\n\ *\n\ * Note: the quotients ALPHA(j)/BETA(j) may easily over- or\n\ * underflow, and BETA(j) may even be zero. Thus, the user\n\ * should avoid naively computing the ratio alpha/beta.\n\ * However, ALPHA will be always less than and usually\n\ * comparable with norm(A) in magnitude, and BETA always less\n\ * than and usually comparable with norm(B).\n\ *\n\ * VSL (output) COMPLEX*16 array, dimension (LDVSL,N)\n\ * If JOBVSL = 'V', VSL will contain the left Schur vectors.\n\ * Not referenced if JOBVSL = 'N'.\n\ *\n\ * LDVSL (input) INTEGER\n\ * The leading dimension of the matrix VSL. LDVSL >=1, and\n\ * if JOBVSL = 'V', LDVSL >= N.\n\ *\n\ * VSR (output) COMPLEX*16 array, dimension (LDVSR,N)\n\ * If JOBVSR = 'V', VSR will contain the right Schur vectors.\n\ * Not referenced if JOBVSR = 'N'.\n\ *\n\ * LDVSR (input) INTEGER\n\ * The leading dimension of the matrix VSR. LDVSR >= 1, and\n\ * if JOBVSR = 'V', LDVSR >= N.\n\ *\n\ * RCONDE (output) DOUBLE PRECISION array, dimension ( 2 )\n\ * If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the\n\ * reciprocal condition numbers for the average of the selected\n\ * eigenvalues.\n\ * Not referenced if SENSE = 'N' or 'V'.\n\ *\n\ * RCONDV (output) DOUBLE PRECISION array, dimension ( 2 )\n\ * If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the\n\ * reciprocal condition number for the selected deflating\n\ * subspaces.\n\ * Not referenced if SENSE = 'N' or 'E'.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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\ * If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B',\n\ * LWORK >= MAX(1,2*N,2*SDIM*(N-SDIM)), else\n\ * LWORK >= MAX(1,2*N). Note that 2*SDIM*(N-SDIM) <= N*N/2.\n\ * Note also that an error is only returned if\n\ * LWORK < MAX(1,2*N), but if SENSE = 'E' or 'V' or 'B' this may\n\ * not be large enough.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the bound on the optimal size of the WORK\n\ * array and the minimum size of the IWORK array, returns these\n\ * values as the first entries of the WORK and IWORK arrays, and\n\ * no error message related to LWORK or LIWORK is issued by\n\ * XERBLA.\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension ( 8*N )\n\ * Real workspace.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK.\n\ * If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise\n\ * LIWORK >= N+2.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the bound on the optimal size of the\n\ * WORK array and the minimum size of the IWORK array, returns\n\ * these values as the first entries of the WORK and IWORK\n\ * arrays, and no error message related to LWORK or LIWORK is\n\ * issued by XERBLA.\n\ *\n\ * BWORK (workspace) LOGICAL array, dimension (N)\n\ * Not referenced if SORT = 'N'.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * = 1,...,N:\n\ * The QZ iteration failed. (A,B) are not in Schur\n\ * form, but ALPHA(j) and BETA(j) should be correct for\n\ * j=INFO+1,...,N.\n\ * > N: =N+1: other than QZ iteration failed in ZHGEQZ\n\ * =N+2: after reordering, roundoff changed values of\n\ * some complex eigenvalues so that leading\n\ * eigenvalues in the Generalized Schur form no\n\ * longer satisfy SELCTG=.TRUE. This could also\n\ * be caused due to scaling.\n\ * =N+3: reordering failed in ZTGSEN.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlasq20000644000175000017500000000561712502223526016407 0ustar uwabamiuwabami--- :name: dlasq2 :md5sum: dc76333ff510f8712b38bba549479bf4 :category: :subroutine :arguments: - n: :type: integer :intent: input - z: :type: doublereal :intent: input/output :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLASQ2( N, Z, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLASQ2 computes all the eigenvalues of the symmetric positive \n\ * definite tridiagonal matrix associated with the qd array Z to high\n\ * relative accuracy are computed to high relative accuracy, in the\n\ * absence of denormalization, underflow and overflow.\n\ *\n\ * To see the relation of Z to the tridiagonal matrix, let L be a\n\ * unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and\n\ * let U be an upper bidiagonal matrix with 1's above and diagonal\n\ * Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the\n\ * symmetric tridiagonal to which it is similar.\n\ *\n\ * Note : DLASQ2 defines a logical variable, IEEE, which is true\n\ * on machines which follow ieee-754 floating-point standard in their\n\ * handling of infinities and NaNs, and false otherwise. This variable\n\ * is passed to DLASQ3.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of rows and columns in the matrix. N >= 0.\n\ *\n\ * Z (input/output) DOUBLE PRECISION array, dimension ( 4*N )\n\ * On entry Z holds the qd array. On exit, entries 1 to N hold\n\ * the eigenvalues in decreasing order, Z( 2*N+1 ) holds the\n\ * trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If\n\ * N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 )\n\ * holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of\n\ * shifts that failed.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if the i-th argument is a scalar and had an illegal\n\ * value, then INFO = -i, if the i-th argument is an\n\ * array and the j-entry had an illegal value, then\n\ * INFO = -(i*100+j)\n\ * > 0: the algorithm failed\n\ * = 1, a split was marked by a positive value in E\n\ * = 2, current block of Z not diagonalized after 30*N\n\ * iterations (in inner while loop)\n\ * = 3, termination criterion of outer while loop not met \n\ * (program created more than N unreduced blocks)\n\ *\n\n\ * Further Details\n\ * ===============\n\ * Local Variables: I0:N0 defines a current unreduced segment of Z.\n\ * The shifts are accumulated in SIGMA. Iteration count is in ITER.\n\ * Ping-pong is controlled by PP (alternates between 0 and 1).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgebrd0000644000175000017500000001461412502223526016445 0ustar uwabamiuwabami--- :name: dgebrd :md5sum: 406bda8120eb4cf0266486d3331f12ce :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - MIN(m,n) - e: :type: doublereal :intent: output :dims: - MIN(m,n)-1 - tauq: :type: doublereal :intent: output :dims: - MIN(m,n) - taup: :type: doublereal :intent: output :dims: - MIN(m,n) - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGEBRD reduces a general real M-by-N matrix A to upper or lower\n\ * bidiagonal form B by an orthogonal transformation: Q**T * A * P = B.\n\ *\n\ * If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows in the matrix A. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns in the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the M-by-N general matrix to be reduced.\n\ * On exit,\n\ * if m >= n, the diagonal and the first superdiagonal are\n\ * overwritten with the upper bidiagonal matrix B; the\n\ * elements below the diagonal, with the array TAUQ, represent\n\ * the orthogonal matrix Q as a product of elementary\n\ * reflectors, and the elements above the first superdiagonal,\n\ * with the array TAUP, represent the orthogonal matrix P as\n\ * a product of elementary reflectors;\n\ * if m < n, the diagonal and the first subdiagonal are\n\ * overwritten with the lower bidiagonal matrix B; the\n\ * elements below the first subdiagonal, with the array TAUQ,\n\ * represent the orthogonal matrix Q as a product of\n\ * elementary reflectors, and the elements above the diagonal,\n\ * with the array TAUP, represent the orthogonal matrix P as\n\ * a product of elementary reflectors.\n\ * See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * D (output) DOUBLE PRECISION array, dimension (min(M,N))\n\ * The diagonal elements of the bidiagonal matrix B:\n\ * D(i) = A(i,i).\n\ *\n\ * E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)\n\ * The off-diagonal elements of the bidiagonal matrix B:\n\ * if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n\ * if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n\ *\n\ * TAUQ (output) DOUBLE PRECISION array dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the orthogonal matrix Q. See Further Details.\n\ *\n\ * TAUP (output) DOUBLE PRECISION array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the orthogonal matrix P. See Further 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 length of the array WORK. LWORK >= max(1,M,N).\n\ * For optimum performance LWORK >= (M+N)*NB, where NB\n\ * is the 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 matrices Q and P are represented as products of elementary\n\ * reflectors:\n\ *\n\ * If m >= n,\n\ *\n\ * Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)\n\ *\n\ * Each H(i) and G(i) has the form:\n\ *\n\ * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n\ *\n\ * where tauq and taup are real scalars, and v and u are real vectors;\n\ * v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);\n\ * u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);\n\ * tauq is stored in TAUQ(i) and taup in TAUP(i).\n\ *\n\ * If m < n,\n\ *\n\ * Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)\n\ *\n\ * Each H(i) and G(i) has the form:\n\ *\n\ * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n\ *\n\ * where tauq and taup are real scalars, and v and u are real vectors;\n\ * v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);\n\ * u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);\n\ * tauq is stored in TAUQ(i) and taup in TAUP(i).\n\ *\n\ * The contents of A on exit are illustrated by the following examples:\n\ *\n\ * m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n\ *\n\ * ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )\n\ * ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )\n\ * ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )\n\ * ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )\n\ * ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )\n\ * ( v1 v2 v3 v4 v5 )\n\ *\n\ * where d and e denote diagonal and off-diagonal elements of B, vi\n\ * denotes an element of the vector defining H(i), and ui an element of\n\ * the vector defining G(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sggevx0000644000175000017500000003400612502223526016516 0ustar uwabamiuwabami--- :name: sggevx :md5sum: 7044c66a49c1acd580038604dab023c1 :category: :subroutine :arguments: - balanc: :type: char :intent: input - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alphar: :type: real :intent: output :dims: - n - alphai: :type: real :intent: output :dims: - n - beta: :type: real :intent: output :dims: - n - vl: :type: real :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: real :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - lscale: :type: real :intent: output :dims: - n - rscale: :type: real :intent: output :dims: - n - abnrm: :type: real :intent: output - bbnrm: :type: real :intent: output - rconde: :type: real :intent: output :dims: - n - rcondv: :type: real :intent: output :dims: - n - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(lsame_(&balanc,\"S\")||lsame_(&balanc,\"B\")||lsame_(&jobvl,\"V\")||lsame_(&jobvr,\"V\")) ? 6*n : lsame_(&sense,\"E\") ? 10*n : (lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? 2*n*n+8*n+16 : 2*n" - iwork: :type: integer :intent: workspace :dims: - "lsame_(&sense,\"E\") ? 0 : n+6" - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sense,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " SUBROUTINE SGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, ILO, IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, WORK, LWORK, IWORK, BWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B)\n\ * the generalized eigenvalues, and optionally, the left and/or right\n\ * generalized eigenvectors.\n\ *\n\ * Optionally also, it computes a balancing transformation to improve\n\ * the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n\ * LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for\n\ * the eigenvalues (RCONDE), and reciprocal condition numbers for the\n\ * right eigenvectors (RCONDV).\n\ *\n\ * A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n\ * lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n\ * singular. It is usually represented as the pair (alpha,beta), as\n\ * there is a reasonable interpretation for beta=0, and even for both\n\ * being zero.\n\ *\n\ * The right eigenvector v(j) corresponding to the eigenvalue lambda(j)\n\ * of (A,B) satisfies\n\ *\n\ * A * v(j) = lambda(j) * B * v(j) .\n\ *\n\ * The left eigenvector u(j) corresponding to the eigenvalue lambda(j)\n\ * of (A,B) satisfies\n\ *\n\ * u(j)**H * A = lambda(j) * u(j)**H * B.\n\ *\n\ * where u(j)**H is the conjugate-transpose of u(j).\n\ *\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * BALANC (input) CHARACTER*1\n\ * Specifies the balance option to be performed.\n\ * = 'N': do not diagonally scale or permute;\n\ * = 'P': permute only;\n\ * = 'S': scale only;\n\ * = 'B': both permute and scale.\n\ * Computed reciprocal condition numbers will be for the\n\ * matrices after permuting and/or balancing. Permuting does\n\ * not change condition numbers (in exact arithmetic), but\n\ * balancing does.\n\ *\n\ * JOBVL (input) CHARACTER*1\n\ * = 'N': do not compute the left generalized eigenvectors;\n\ * = 'V': compute the left generalized eigenvectors.\n\ *\n\ * JOBVR (input) CHARACTER*1\n\ * = 'N': do not compute the right generalized eigenvectors;\n\ * = 'V': compute the right generalized eigenvectors.\n\ *\n\ * SENSE (input) CHARACTER*1\n\ * Determines which reciprocal condition numbers are computed.\n\ * = 'N': none are computed;\n\ * = 'E': computed for eigenvalues only;\n\ * = 'V': computed for eigenvectors only;\n\ * = 'B': computed for eigenvalues and eigenvectors.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A, B, VL, and VR. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA, N)\n\ * On entry, the matrix A in the pair (A,B).\n\ * On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'\n\ * or both, then A contains the first part of the real Schur\n\ * form of the \"balanced\" versions of the input A and B.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of A. LDA >= max(1,N).\n\ *\n\ * B (input/output) REAL array, dimension (LDB, N)\n\ * On entry, the matrix B in the pair (A,B).\n\ * On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'\n\ * or both, then B contains the second part of the real Schur\n\ * form of the \"balanced\" versions of the input A and B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B. LDB >= max(1,N).\n\ *\n\ * ALPHAR (output) REAL array, dimension (N)\n\ * ALPHAI (output) REAL array, dimension (N)\n\ * BETA (output) REAL array, dimension (N)\n\ * On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n\ * be the generalized eigenvalues. If ALPHAI(j) is zero, then\n\ * the j-th eigenvalue is real; if positive, then the j-th and\n\ * (j+1)-st eigenvalues are a complex conjugate pair, with\n\ * ALPHAI(j+1) negative.\n\ *\n\ * Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n\ * may easily over- or underflow, and BETA(j) may even be zero.\n\ * Thus, the user should avoid naively computing the ratio\n\ * ALPHA/BETA. However, ALPHAR and ALPHAI will be always less\n\ * than and usually comparable with norm(A) in magnitude, and\n\ * BETA always less than and usually comparable with norm(B).\n\ *\n\ * VL (output) REAL array, dimension (LDVL,N)\n\ * If JOBVL = 'V', the left eigenvectors u(j) are stored one\n\ * after another in the columns of VL, in the same order as\n\ * their eigenvalues. If the j-th eigenvalue is real, then\n\ * u(j) = VL(:,j), the j-th column of VL. If the j-th and\n\ * (j+1)-th eigenvalues form a complex conjugate pair, then\n\ * u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).\n\ * Each eigenvector will be scaled so the largest component have\n\ * abs(real part) + abs(imag. part) = 1.\n\ * Not referenced if JOBVL = 'N'.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the matrix VL. LDVL >= 1, and\n\ * if JOBVL = 'V', LDVL >= N.\n\ *\n\ * VR (output) REAL array, dimension (LDVR,N)\n\ * If JOBVR = 'V', the right eigenvectors v(j) are stored one\n\ * after another in the columns of VR, in the same order as\n\ * their eigenvalues. If the j-th eigenvalue is real, then\n\ * v(j) = VR(:,j), the j-th column of VR. If the j-th and\n\ * (j+1)-th eigenvalues form a complex conjugate pair, then\n\ * v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).\n\ * Each eigenvector will be scaled so the largest component have\n\ * abs(real part) + abs(imag. part) = 1.\n\ * Not referenced if JOBVR = 'N'.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the matrix VR. LDVR >= 1, and\n\ * if JOBVR = 'V', LDVR >= N.\n\ *\n\ * ILO (output) INTEGER\n\ * IHI (output) INTEGER\n\ * ILO and IHI are integer values such that on exit\n\ * A(i,j) = 0 and B(i,j) = 0 if i > j and\n\ * j = 1,...,ILO-1 or i = IHI+1,...,N.\n\ * If BALANC = 'N' or 'S', ILO = 1 and IHI = N.\n\ *\n\ * LSCALE (output) REAL array, dimension (N)\n\ * Details of the permutations and scaling factors applied\n\ * to the left side of A and B. If PL(j) is the index of the\n\ * row interchanged with row j, and DL(j) is the scaling\n\ * factor applied to row j, then\n\ * LSCALE(j) = PL(j) for j = 1,...,ILO-1\n\ * = DL(j) for j = ILO,...,IHI\n\ * = PL(j) for j = IHI+1,...,N.\n\ * The order in which the interchanges are made is N to IHI+1,\n\ * then 1 to ILO-1.\n\ *\n\ * RSCALE (output) REAL array, dimension (N)\n\ * Details of the permutations and scaling factors applied\n\ * to the right side of A and B. If PR(j) is the index of the\n\ * column interchanged with column j, and DR(j) is the scaling\n\ * factor applied to column j, then\n\ * RSCALE(j) = PR(j) for j = 1,...,ILO-1\n\ * = DR(j) for j = ILO,...,IHI\n\ * = PR(j) for j = IHI+1,...,N\n\ * The order in which the interchanges are made is N to IHI+1,\n\ * then 1 to ILO-1.\n\ *\n\ * ABNRM (output) REAL\n\ * The one-norm of the balanced matrix A.\n\ *\n\ * BBNRM (output) REAL\n\ * The one-norm of the balanced matrix B.\n\ *\n\ * RCONDE (output) REAL array, dimension (N)\n\ * If SENSE = 'E' or 'B', the reciprocal condition numbers of\n\ * the eigenvalues, stored in consecutive elements of the array.\n\ * For a complex conjugate pair of eigenvalues two consecutive\n\ * elements of RCONDE are set to the same value. Thus RCONDE(j),\n\ * RCONDV(j), and the j-th columns of VL and VR all correspond\n\ * to the j-th eigenpair.\n\ * If SENSE = 'N' or 'V', RCONDE is not referenced.\n\ *\n\ * RCONDV (output) REAL array, dimension (N)\n\ * If SENSE = 'V' or 'B', the estimated reciprocal condition\n\ * numbers of the eigenvectors, stored in consecutive elements\n\ * of the array. For a complex eigenvector two consecutive\n\ * elements of RCONDV are set to the same value. If the\n\ * eigenvalues cannot be reordered to compute RCONDV(j),\n\ * RCONDV(j) is set to 0; this can only occur when the true\n\ * value would be very small anyway.\n\ * If SENSE = 'N' or 'E', RCONDV is not referenced.\n\ *\n\ * WORK (workspace/output) REAL 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,2*N).\n\ * If BALANC = 'S' or 'B', or JOBVL = 'V', or JOBVR = 'V',\n\ * LWORK >= max(1,6*N).\n\ * If SENSE = 'E', LWORK >= max(1,10*N).\n\ * If SENSE = 'V' or 'B', LWORK >= 2*N*N+8*N+16.\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\ * IWORK (workspace) INTEGER array, dimension (N+6)\n\ * If SENSE = 'E', IWORK is not referenced.\n\ *\n\ * BWORK (workspace) LOGICAL array, dimension (N)\n\ * If SENSE = 'N', BWORK is not referenced.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * = 1,...,N:\n\ * The QZ iteration failed. No eigenvectors have been\n\ * calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)\n\ * should be correct for j=INFO+1,...,N.\n\ * > N: =N+1: other than QZ iteration failed in SHGEQZ.\n\ * =N+2: error return from STGEVC.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Balancing a matrix pair (A,B) includes, first, permuting rows and\n\ * columns to isolate eigenvalues, second, applying diagonal similarity\n\ * transformation to the rows and columns to make the rows and columns\n\ * as close in norm as possible. The computed reciprocal condition\n\ * numbers correspond to the balanced matrix. Permuting rows and columns\n\ * will not change the condition numbers (in exact arithmetic) but\n\ * diagonal scaling will. For further explanation of balancing, see\n\ * section 4.11.1.2 of LAPACK Users' Guide.\n\ *\n\ * An approximate error bound on the chordal distance between the i-th\n\ * computed generalized eigenvalue w and the corresponding exact\n\ * eigenvalue lambda is\n\ *\n\ * chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)\n\ *\n\ * An approximate error bound for the angle between the i-th computed\n\ * eigenvector VL(i) or VR(i) is given by\n\ *\n\ * EPS * norm(ABNRM, BBNRM) / DIF(i).\n\ *\n\ * For further explanation of the reciprocal condition numbers RCONDE\n\ * and RCONDV, see section 4.11 of LAPACK User's Guide.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgghrd0000644000175000017500000001350312502223526016470 0ustar uwabamiuwabami--- :name: sgghrd :md5sum: d0503df67d201eb3464bb900dd79f061 :category: :subroutine :arguments: - compq: :type: char :intent: input - compz: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - q: :type: real :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - z: :type: real :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGGHRD reduces a pair of real matrices (A,B) to generalized upper\n\ * Hessenberg form using orthogonal transformations, where A is a\n\ * general matrix and B is upper triangular. The form of the\n\ * generalized eigenvalue problem is\n\ * A*x = lambda*B*x,\n\ * and B is typically made upper triangular by computing its QR\n\ * factorization and moving the orthogonal matrix Q to the left side\n\ * of the equation.\n\ *\n\ * This subroutine simultaneously reduces A to a Hessenberg matrix H:\n\ * Q**T*A*Z = H\n\ * and transforms B to another upper triangular matrix T:\n\ * Q**T*B*Z = T\n\ * in order to reduce the problem to its standard form\n\ * H*y = lambda*T*y\n\ * where y = Z**T*x.\n\ *\n\ * The orthogonal matrices Q and Z are determined as products of Givens\n\ * rotations. They may either be formed explicitly, or they may be\n\ * postmultiplied into input matrices Q1 and Z1, so that\n\ *\n\ * Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T\n\ *\n\ * Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T\n\ *\n\ * If Q1 is the orthogonal matrix from the QR factorization of B in the\n\ * original equation A*x = lambda*B*x, then SGGHRD reduces the original\n\ * problem to generalized Hessenberg form.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * COMPQ (input) CHARACTER*1\n\ * = 'N': do not compute Q;\n\ * = 'I': Q is initialized to the unit matrix, and the\n\ * orthogonal matrix Q is returned;\n\ * = 'V': Q must contain an orthogonal matrix Q1 on entry,\n\ * and the product Q1*Q is returned.\n\ *\n\ * COMPZ (input) CHARACTER*1\n\ * = 'N': do not compute Z;\n\ * = 'I': Z is initialized to the unit matrix, and the\n\ * orthogonal matrix Z is returned;\n\ * = 'V': Z must contain an orthogonal matrix Z1 on entry,\n\ * and the product Z1*Z is returned.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * ILO and IHI mark the rows and columns of A which are to be\n\ * reduced. It is assumed that A is already upper triangular\n\ * in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are\n\ * normally set by a previous call to SGGBAL; otherwise they\n\ * should be set to 1 and N respectively.\n\ * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA, N)\n\ * On entry, the N-by-N general matrix to be reduced.\n\ * On exit, the upper triangle and the first subdiagonal of A\n\ * are overwritten with the upper Hessenberg matrix H, and the\n\ * rest is set to zero.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) REAL array, dimension (LDB, N)\n\ * On entry, the N-by-N upper triangular matrix B.\n\ * On exit, the upper triangular matrix T = Q**T B Z. The\n\ * elements below the diagonal are set to zero.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * Q (input/output) REAL array, dimension (LDQ, N)\n\ * On entry, if COMPQ = 'V', the orthogonal matrix Q1,\n\ * typically from the QR factorization of B.\n\ * On exit, if COMPQ='I', the orthogonal matrix Q, and if\n\ * COMPQ = 'V', the product Q1*Q.\n\ * Not referenced if COMPQ='N'.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q.\n\ * LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.\n\ *\n\ * Z (input/output) REAL array, dimension (LDZ, N)\n\ * On entry, if COMPZ = 'V', the orthogonal matrix Z1.\n\ * On exit, if COMPZ='I', the orthogonal matrix Z, and if\n\ * COMPZ = 'V', the product Z1*Z.\n\ * Not referenced if COMPZ='N'.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z.\n\ * LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.\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\ * This routine reduces A to Hessenberg and B to triangular form by\n\ * an unblocked reduction, as described in _Matrix_Computations_,\n\ * by Golub and Van Loan (Johns Hopkins Press.)\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slarfb0000644000175000017500000000756612502223526016477 0ustar uwabamiuwabami--- :name: slarfb :md5sum: a289ad616cdb1dfb94da0a9070a5b91e :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - direct: :type: char :intent: input - storev: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - v: :type: real :intent: input :dims: - ldv - k - ldv: :type: integer :intent: input - t: :type: real :intent: input :dims: - ldt - k - ldt: :type: integer :intent: input - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - ldwork - k - ldwork: :type: integer :intent: input :substitutions: ldwork: "MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0" :fortran_help: " SUBROUTINE SLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLARFB applies a real block reflector H or its transpose H' to a\n\ * real m by n matrix C, from either the left or the right.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply H or H' from the Left\n\ * = 'R': apply H or H' from the Right\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': apply H (No transpose)\n\ * = 'T': apply H' (Transpose)\n\ *\n\ * DIRECT (input) CHARACTER*1\n\ * Indicates how H is formed from a product of elementary\n\ * reflectors\n\ * = 'F': H = H(1) H(2) . . . H(k) (Forward)\n\ * = 'B': H = H(k) . . . H(2) H(1) (Backward)\n\ *\n\ * STOREV (input) CHARACTER*1\n\ * Indicates how the vectors which define the elementary\n\ * reflectors are stored:\n\ * = 'C': Columnwise\n\ * = 'R': Rowwise\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C.\n\ *\n\ * K (input) INTEGER\n\ * The order of the matrix T (= the number of elementary\n\ * reflectors whose product defines the block reflector).\n\ *\n\ * V (input) REAL array, dimension\n\ * (LDV,K) if STOREV = 'C'\n\ * (LDV,M) if STOREV = 'R' and SIDE = 'L'\n\ * (LDV,N) if STOREV = 'R' and SIDE = 'R'\n\ * The matrix V. See further details.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V.\n\ * If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);\n\ * if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);\n\ * if STOREV = 'R', LDV >= K.\n\ *\n\ * T (input) REAL array, dimension (LDT,K)\n\ * The triangular k by k matrix T in the representation of the\n\ * block reflector.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= K.\n\ *\n\ * C (input/output) REAL array, dimension (LDC,N)\n\ * On entry, the m by n matrix C.\n\ * On exit, C is overwritten by H*C or H'*C or C*H or C*H'.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDA >= max(1,M).\n\ *\n\ * WORK (workspace) REAL array, dimension (LDWORK,K)\n\ *\n\ * LDWORK (input) INTEGER\n\ * The leading dimension of the array WORK.\n\ * If SIDE = 'L', LDWORK >= max(1,N);\n\ * if SIDE = 'R', LDWORK >= max(1,M).\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slahr20000644000175000017500000001152012502223526016402 0ustar uwabamiuwabami--- :name: slahr2 :md5sum: 036e30e7208a92f8c4dea174520af37e :category: :subroutine :arguments: - n: :type: integer :intent: input - k: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n-k+1 - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - MAX(1,nb) - t: :type: real :intent: output :dims: - ldt - MAX(1,nb) - ldt: :type: integer :intent: input - y: :type: real :intent: output :dims: - ldy - MAX(1,nb) - ldy: :type: integer :intent: input :substitutions: ldy: n ldt: nb :fortran_help: " SUBROUTINE SLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1)\n\ * matrix A so that elements below the k-th subdiagonal are zero. The\n\ * reduction is performed by an orthogonal similarity transformation\n\ * Q' * A * Q. The routine returns the matrices V and T which determine\n\ * Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n\ *\n\ * This is an auxiliary routine called by SGEHRD.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A.\n\ *\n\ * K (input) INTEGER\n\ * The offset for the reduction. Elements below the k-th\n\ * subdiagonal in the first NB columns are reduced to zero.\n\ * K < N.\n\ *\n\ * NB (input) INTEGER\n\ * The number of columns to be reduced.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N-K+1)\n\ * On entry, the n-by-(n-k+1) general matrix A.\n\ * On exit, the elements on and above the k-th subdiagonal in\n\ * the first NB columns are overwritten with the corresponding\n\ * elements of the reduced matrix; the elements below the k-th\n\ * subdiagonal, with the array TAU, represent the matrix Q as a\n\ * product of elementary reflectors. The other columns of A are\n\ * unchanged. See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * TAU (output) REAL array, dimension (NB)\n\ * The scalar factors of the elementary reflectors. See Further\n\ * Details.\n\ *\n\ * T (output) REAL array, dimension (LDT,NB)\n\ * The upper triangular matrix T.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= NB.\n\ *\n\ * Y (output) REAL array, dimension (LDY,NB)\n\ * The n-by-nb matrix Y.\n\ *\n\ * LDY (input) INTEGER\n\ * The leading dimension of the array Y. LDY >= N.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The matrix Q is represented as a product of nb elementary reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(nb).\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+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n\ * A(i+k+1:n,i), and tau in TAU(i).\n\ *\n\ * The elements of the vectors v together form the (n-k+1)-by-nb matrix\n\ * V which is needed, with T and Y, to apply the transformation to the\n\ * unreduced part of the matrix, using an update of the form:\n\ * A := (I - V*T*V') * (A - Y*V').\n\ *\n\ * The contents of A on exit are illustrated by the following example\n\ * with n = 7, k = 3 and nb = 2:\n\ *\n\ * ( a a a a a )\n\ * ( a a a a a )\n\ * ( a a a a a )\n\ * ( h h a a a )\n\ * ( v1 h a a a )\n\ * ( v1 v2 a a a )\n\ * ( v1 v2 a a a )\n\ *\n\ * where a denotes an element of the original matrix A, h denotes a\n\ * modified element of the upper Hessenberg matrix H, and vi denotes an\n\ * element of the vector defining H(i).\n\ *\n\ * This subroutine is a slight modification of LAPACK-3.0's DLAHRD\n\ * incorporating improvements proposed by Quintana-Orti and Van de\n\ * Gejin. Note that the entries of A(1:K,2:NB) differ from those\n\ * returned by the original LAPACK-3.0's DLAHRD routine. (This\n\ * subroutine is not backward compatible with LAPACK-3.0's DLAHRD.)\n\ *\n\ * References\n\ * ==========\n\ *\n\ * Gregorio Quintana-Orti and Robert van de Geijn, \"Improving the\n\ * performance of reduction to Hessenberg form,\" ACM Transactions on\n\ * Mathematical Software, 32(2):180-194, June 2006.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sorgtr0000644000175000017500000000546012502223526016535 0ustar uwabamiuwabami--- :name: sorgtr :md5sum: c7c50b630620062c901712667ebb5d59 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - n-1 - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SORGTR generates a real orthogonal matrix Q which is defined as the\n\ * product of n-1 elementary reflectors of order N, as returned by\n\ * SSYTRD:\n\ *\n\ * if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),\n\ *\n\ * if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A contains elementary reflectors\n\ * from SSYTRD;\n\ * = 'L': Lower triangle of A contains elementary reflectors\n\ * from SSYTRD.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix Q. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the vectors which define the elementary reflectors,\n\ * as returned by SSYTRD.\n\ * On exit, the N-by-N orthogonal matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * TAU (input) REAL array, dimension (N-1)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by SSYTRD.\n\ *\n\ * WORK (workspace/output) REAL 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,N-1).\n\ * For optimum performance LWORK >= (N-1)*NB, where NB is\n\ * the 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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cla_heamv0000644000175000017500000001114112502223525017124 0ustar uwabamiuwabami--- :name: cla_heamv :md5sum: a9e12928b232d452b69031ceb12d1748 :category: :subroutine :arguments: - uplo: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: real :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: complex :intent: input :dims: - 1 + ( n - 1 )*abs( incx ) - incx: :type: integer :intent: input - beta: :type: real :intent: input - y: :type: real :intent: input/output :dims: - 1 + ( n - 1 )*abs( incy ) - incy: :type: integer :intent: input :substitutions: lda: n :fortran_help: " SUBROUTINE CLA_HEAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLA_SYAMV performs the matrix-vector operation\n\ *\n\ * y := alpha*abs(A)*abs(x) + beta*abs(y),\n\ *\n\ * where alpha and beta are scalars, x and y are vectors and A is an\n\ * n by n symmetric matrix.\n\ *\n\ * This function is primarily used in calculating error bounds.\n\ * To protect against underflow during evaluation, components in\n\ * the resulting vector are perturbed away from zero by (N+1)\n\ * times the underflow threshold. To prevent unnecessarily large\n\ * errors for block-structure embedded in general matrices,\n\ * \"symbolically\" zero components are not perturbed. A zero\n\ * entry is considered \"symbolic\" if all multiplications involved\n\ * in computing that entry have at least one zero multiplicand.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * UPLO (input) INTEGER\n\ * On entry, UPLO specifies whether the upper or lower\n\ * triangular part of the array A is to be referenced as\n\ * follows:\n\ *\n\ * UPLO = BLAS_UPPER Only the upper triangular part of A\n\ * is to be referenced.\n\ *\n\ * UPLO = BLAS_LOWER Only the lower triangular part of A\n\ * is to be referenced.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the number of columns of the matrix A.\n\ * N must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * ALPHA (input) REAL .\n\ * On entry, ALPHA specifies the scalar alpha.\n\ * Unchanged on exit.\n\ *\n\ * A - COMPLEX array of DIMENSION ( LDA, n ).\n\ * Before entry, the leading m by n part of the array A must\n\ * contain the matrix of coefficients.\n\ * Unchanged on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * On entry, LDA specifies the first dimension of A as declared\n\ * in the calling (sub) program. LDA must be at least\n\ * max( 1, n ).\n\ * Unchanged on exit.\n\ *\n\ * X (input) COMPLEX array, dimension\n\ * ( 1 + ( n - 1 )*abs( INCX ) )\n\ * Before entry, the incremented array X must contain the\n\ * vector x.\n\ * Unchanged on exit.\n\ *\n\ * INCX (input) INTEGER\n\ * On entry, INCX specifies the increment for the elements of\n\ * X. INCX must not be zero.\n\ * Unchanged on exit.\n\ *\n\ * BETA (input) REAL .\n\ * On entry, BETA specifies the scalar beta. When BETA is\n\ * supplied as zero then Y need not be set on input.\n\ * Unchanged on exit.\n\ *\n\ * Y (input/output) REAL array, dimension\n\ * ( 1 + ( n - 1 )*abs( INCY ) )\n\ * Before entry with BETA non-zero, the incremented array Y\n\ * must contain the vector y. On exit, Y is overwritten by the\n\ * updated vector y.\n\ *\n\ * INCY (input) INTEGER\n\ * On entry, INCY specifies the increment for the elements of\n\ * Y. INCY must not be zero.\n\ * Unchanged on exit.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Level 2 Blas routine.\n\ *\n\ * -- Written on 22-October-1986.\n\ * Jack Dongarra, Argonne National Lab.\n\ * Jeremy Du Croz, Nag Central Office.\n\ * Sven Hammarling, Nag Central Office.\n\ * Richard Hanson, Sandia National Labs.\n\ * -- Modified for the absolute-value product, April 2006\n\ * Jason Riedy, UC Berkeley\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgebal0000644000175000017500000001037012502223526016446 0ustar uwabamiuwabami--- :name: sgebal :md5sum: f24299883b8992810cf76ee8abf27538 :category: :subroutine :arguments: - job: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - scale: :type: real :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGEBAL balances a general real matrix A. This involves, first,\n\ * permuting A by a similarity transformation to isolate eigenvalues\n\ * in the first 1 to ILO-1 and last IHI+1 to N elements on the\n\ * diagonal; and second, applying a diagonal similarity transformation\n\ * to rows and columns ILO to IHI to make the rows and columns as\n\ * close in norm as possible. Both steps are optional.\n\ *\n\ * Balancing may reduce the 1-norm of the matrix, and improve the\n\ * accuracy of the computed eigenvalues and/or eigenvectors.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * Specifies the operations to be performed on A:\n\ * = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0\n\ * for i = 1,...,N;\n\ * = 'P': permute only;\n\ * = 'S': scale only;\n\ * = 'B': both permute and scale.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the input matrix A.\n\ * On exit, A is overwritten by the balanced matrix.\n\ * If JOB = 'N', A is not referenced.\n\ * See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * ILO (output) INTEGER\n\ * IHI (output) INTEGER\n\ * ILO and IHI are set to integers such that on exit\n\ * A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.\n\ * If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n\ *\n\ * SCALE (output) REAL array, dimension (N)\n\ * Details of the permutations and scaling factors applied to\n\ * A. If P(j) is the index of the row and column interchanged\n\ * with row and column j and D(j) is the scaling factor\n\ * applied to row and column j, then\n\ * SCALE(j) = P(j) for j = 1,...,ILO-1\n\ * = D(j) for j = ILO,...,IHI\n\ * = P(j) for j = IHI+1,...,N.\n\ * The order in which the interchanges are made is N to IHI+1,\n\ * then 1 to ILO-1.\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 permutations consist of row and column interchanges which put\n\ * the matrix in the form\n\ *\n\ * ( T1 X Y )\n\ * P A P = ( 0 B Z )\n\ * ( 0 0 T2 )\n\ *\n\ * where T1 and T2 are upper triangular matrices whose eigenvalues lie\n\ * along the diagonal. The column indices ILO and IHI mark the starting\n\ * and ending columns of the submatrix B. Balancing consists of applying\n\ * a diagonal similarity transformation inv(D) * B * D to make the\n\ * 1-norms of each row of B and its corresponding column nearly equal.\n\ * The output matrix is\n\ *\n\ * ( T1 X*D Y )\n\ * ( 0 inv(D)*B*D inv(D)*Z ).\n\ * ( 0 0 T2 )\n\ *\n\ * Information about the permutations P and the diagonal matrix D is\n\ * returned in the vector SCALE.\n\ *\n\ * This subroutine is based on the EISPACK routine BALANC.\n\ *\n\ * Modified by Tzu-Yi Chen, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlantp0000644000175000017500000000620212502223526016472 0ustar uwabamiuwabami--- :name: dlantp :md5sum: 89c0a27d7546449efda1386a0b958f8b :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - n*(n+1)/2 - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? n : 0" :fortran_help: " DOUBLE PRECISION FUNCTION DLANTP( NORM, UPLO, DIAG, N, AP, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLANTP returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * triangular matrix A, supplied in packed form.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * DLANTP returns the value\n\ *\n\ * DLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in DLANTP as described\n\ * above.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the matrix A is upper or lower triangular.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * Specifies whether or not the matrix A is unit triangular.\n\ * = 'N': Non-unit triangular\n\ * = 'U': Unit triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, DLANTP is\n\ * set to zero.\n\ *\n\ * AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * The upper or lower triangular matrix A, packed columnwise in\n\ * a linear array. The j-th column of A is stored in the array\n\ * AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ * Note that when DIAG = 'U', the elements of the array AP\n\ * corresponding to the diagonal elements of the matrix A are\n\ * not referenced, but are assumed to be one.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n\ * referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/stptri0000644000175000017500000000517512502223526016545 0ustar uwabamiuwabami--- :name: stptri :md5sum: 1651295dca8d52ec141a000d61e66fe5 :category: :subroutine :arguments: - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE STPTRI( UPLO, DIAG, N, AP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STPTRI computes the inverse of a real upper or lower triangular\n\ * matrix A stored in packed format.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) REAL array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangular matrix A, stored\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n.\n\ * See below for further details.\n\ * On exit, the (triangular) inverse of the original matrix, in\n\ * the same packed storage format.\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, A(i,i) is exactly zero. The triangular\n\ * matrix is singular and its inverse can not be computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * A triangular matrix A can be transferred to packed storage using one\n\ * of the following program segments:\n\ *\n\ * UPLO = 'U': UPLO = 'L':\n\ *\n\ * JC = 1 JC = 1\n\ * DO 2 J = 1, N DO 2 J = 1, N\n\ * DO 1 I = 1, J DO 1 I = J, N\n\ * AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J)\n\ * 1 CONTINUE 1 CONTINUE\n\ * JC = JC + J JC = JC + N - J + 1\n\ * 2 CONTINUE 2 CONTINUE\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlaqsb0000644000175000017500000000645612502223526016517 0ustar uwabamiuwabami--- :name: zlaqsb :md5sum: 29dea065db6a95e6e3f4254e406dc67e :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - s: :type: doublereal :intent: input :dims: - n - scond: :type: doublereal :intent: input - amax: :type: doublereal :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAQSB equilibrates a symmetric band matrix A using the scaling\n\ * factors in the vector S.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of super-diagonals of the matrix A if UPLO = 'U',\n\ * or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * On exit, if INFO = 0, the triangular factor U or L from the\n\ * Cholesky factorization A = U'*U or A = L*L' of the band\n\ * matrix A, in the same storage format as A.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * S (input) DOUBLE PRECISION array, dimension (N)\n\ * The scale factors for A.\n\ *\n\ * SCOND (input) DOUBLE PRECISION\n\ * Ratio of the smallest S(i) to the largest S(i).\n\ *\n\ * AMAX (input) DOUBLE PRECISION\n\ * Absolute value of largest matrix entry.\n\ *\n\ * EQUED (output) CHARACTER*1\n\ * Specifies whether or not equilibration was done.\n\ * = 'N': No equilibration.\n\ * = 'Y': Equilibration was done, i.e., A has been replaced by\n\ * diag(S) * A * diag(S).\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * THRESH is a threshold value used to decide if scaling should be done\n\ * based on the ratio of the scaling factors. If SCOND < THRESH,\n\ * scaling is done.\n\ *\n\ * LARGE and SMALL are threshold values used to decide if scaling should\n\ * be done based on the absolute size of the largest matrix element.\n\ * If AMAX > LARGE or AMAX < SMALL, scaling is done.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cptrfs0000644000175000017500000001115012502223525016506 0ustar uwabamiuwabami--- :name: cptrfs :md5sum: 9b5bef723bf83861b13e566ffe866e75 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: complex :intent: input :dims: - n-1 - df: :type: real :intent: input :dims: - n - ef: :type: complex :intent: input :dims: - n-1 - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPTRFS( UPLO, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPTRFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is Hermitian positive definite\n\ * and tridiagonal, and provides error bounds and backward error\n\ * estimates for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the superdiagonal or the subdiagonal of the\n\ * tridiagonal matrix A is stored and the form of the\n\ * factorization:\n\ * = 'U': E is the superdiagonal of A, and A = U**H*D*U;\n\ * = 'L': E is the subdiagonal of A, and A = L*D*L**H.\n\ * (The two forms are equivalent if A is real.)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The n real diagonal elements of the tridiagonal matrix A.\n\ *\n\ * E (input) COMPLEX array, dimension (N-1)\n\ * The (n-1) off-diagonal elements of the tridiagonal matrix A\n\ * (see UPLO).\n\ *\n\ * DF (input) REAL array, dimension (N)\n\ * The n diagonal elements of the diagonal matrix D from\n\ * the factorization computed by CPTTRF.\n\ *\n\ * EF (input) COMPLEX array, dimension (N-1)\n\ * The (n-1) off-diagonal elements of the unit bidiagonal\n\ * factor U or L from the factorization computed by CPTTRF\n\ * (see UPLO).\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) COMPLEX array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by CPTTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j).\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dzsum10000644000175000017500000000252412502223526016436 0ustar uwabamiuwabami--- :name: dzsum1 :md5sum: 4c611d4aef843b07b606ed1beec14057 :category: :function :type: doublereal :arguments: - n: :type: integer :intent: input - cx: :type: doublecomplex :intent: input :dims: - n - incx: :type: integer :intent: input :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION DZSUM1( N, CX, INCX )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DZSUM1 takes the sum of the absolute values of a complex\n\ * vector and returns a double precision result.\n\ *\n\ * Based on DZASUM from the Level 1 BLAS.\n\ * The change is to use the 'genuine' absolute value.\n\ *\n\ * Contributed by Nick Higham for use with ZLACON.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of elements in the vector CX.\n\ *\n\ * CX (input) COMPLEX*16 array, dimension (N)\n\ * The vector whose elements will be summed.\n\ *\n\ * INCX (input) INTEGER\n\ * The spacing between successive values of CX. INCX > 0.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, NINCX\n DOUBLE PRECISION STEMP\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/ztptri0000644000175000017500000000521712502223526016551 0ustar uwabamiuwabami--- :name: ztptri :md5sum: 604c2ba8d0abc266318f80f050d207c6 :category: :subroutine :arguments: - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZTPTRI( UPLO, DIAG, N, AP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTPTRI computes the inverse of a complex upper or lower triangular\n\ * matrix A stored in packed format.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangular matrix A, stored\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n.\n\ * See below for further details.\n\ * On exit, the (triangular) inverse of the original matrix, in\n\ * the same packed storage format.\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, A(i,i) is exactly zero. The triangular\n\ * matrix is singular and its inverse can not be computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * A triangular matrix A can be transferred to packed storage using one\n\ * of the following program segments:\n\ *\n\ * UPLO = 'U': UPLO = 'L':\n\ *\n\ * JC = 1 JC = 1\n\ * DO 2 J = 1, N DO 2 J = 1, N\n\ * DO 1 I = 1, J DO 1 I = J, N\n\ * AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J)\n\ * 1 CONTINUE 1 CONTINUE\n\ * JC = JC + J JC = JC + N - J + 1\n\ * 2 CONTINUE 2 CONTINUE\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clatrd0000644000175000017500000001402112502223525016456 0ustar uwabamiuwabami--- :name: clatrd :md5sum: ad2e74bcec91b1bccbee75fb9f8dcbe7 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - e: :type: real :intent: output :dims: - n-1 - tau: :type: complex :intent: output :dims: - n-1 - w: :type: complex :intent: output :dims: - ldw - MAX(n,nb) - ldw: :type: integer :intent: input :substitutions: ldw: MAX(1,n) :fortran_help: " SUBROUTINE CLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLATRD reduces NB rows and columns of a complex Hermitian matrix A to\n\ * Hermitian tridiagonal form by a unitary similarity\n\ * transformation Q' * A * Q, and returns the matrices V and W which are\n\ * needed to apply the transformation to the unreduced part of A.\n\ *\n\ * If UPLO = 'U', CLATRD reduces the last NB rows and columns of a\n\ * matrix, of which the upper triangle is supplied;\n\ * if UPLO = 'L', CLATRD reduces the first NB rows and columns of a\n\ * matrix, of which the lower triangle is supplied.\n\ *\n\ * This is an auxiliary routine called by CHETRD.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * Hermitian matrix A is stored:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A.\n\ *\n\ * NB (input) INTEGER\n\ * The number of rows and columns to be reduced.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the leading\n\ * n-by-n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n-by-n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ * On exit:\n\ * if UPLO = 'U', the last NB columns have been reduced to\n\ * tridiagonal form, with the diagonal elements overwriting\n\ * the diagonal elements of A; the elements above the diagonal\n\ * with the array TAU, represent the unitary matrix Q as a\n\ * product of elementary reflectors;\n\ * if UPLO = 'L', the first NB columns have been reduced to\n\ * tridiagonal form, with the diagonal elements overwriting\n\ * the diagonal elements of A; the elements below the diagonal\n\ * with the array TAU, represent the unitary matrix Q as a\n\ * product of elementary reflectors.\n\ * See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * E (output) REAL array, dimension (N-1)\n\ * If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal\n\ * elements of the last NB columns of the reduced matrix;\n\ * if UPLO = 'L', E(1:nb) contains the subdiagonal elements of\n\ * the first NB columns of the reduced matrix.\n\ *\n\ * TAU (output) COMPLEX array, dimension (N-1)\n\ * The scalar factors of the elementary reflectors, stored in\n\ * TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.\n\ * See Further Details.\n\ *\n\ * W (output) COMPLEX array, dimension (LDW,NB)\n\ * The n-by-nb matrix W required to update the unreduced part\n\ * of A.\n\ *\n\ * LDW (input) INTEGER\n\ * The leading dimension of the array W. LDW >= max(1,N).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * If UPLO = 'U', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(n) H(n-1) . . . H(n-nb+1).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar, and v is a complex vector with\n\ * v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),\n\ * and tau in TAU(i-1).\n\ *\n\ * If UPLO = 'L', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(nb).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar, and v is a complex vector with\n\ * v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),\n\ * and tau in TAU(i).\n\ *\n\ * The elements of the vectors v together form the n-by-nb matrix V\n\ * which is needed, with W, to apply the transformation to the unreduced\n\ * part of the matrix, using a Hermitian rank-2k update of the form:\n\ * A := A - V*W' - W*V'.\n\ *\n\ * The contents of A on exit are illustrated by the following examples\n\ * with n = 5 and nb = 2:\n\ *\n\ * if UPLO = 'U': if UPLO = 'L':\n\ *\n\ * ( a a a v4 v5 ) ( d )\n\ * ( a a v4 v5 ) ( 1 d )\n\ * ( a 1 v5 ) ( v1 1 a )\n\ * ( d 1 ) ( v1 v2 a a )\n\ * ( d ) ( v1 v2 a a a )\n\ *\n\ * where d denotes a diagonal element of the reduced matrix, a denotes\n\ * an element of the original matrix that is unchanged, and vi denotes\n\ * an element of the vector defining H(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slaswp0000644000175000017500000000447012502223526016526 0ustar uwabamiuwabami--- :name: slaswp :md5sum: a146d16e2844160e4ad408d072ac1b88 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - k1: :type: integer :intent: input - k2: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - k2*abs(incx) - incx: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE SLASWP( N, A, LDA, K1, K2, IPIV, INCX )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLASWP performs a series of row interchanges on the matrix A.\n\ * One row interchange is initiated for each of rows K1 through K2 of A.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix A.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the matrix of column dimension N to which the row\n\ * interchanges will be applied.\n\ * On exit, the permuted matrix.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ *\n\ * K1 (input) INTEGER\n\ * The first element of IPIV for which a row interchange will\n\ * be done.\n\ *\n\ * K2 (input) INTEGER\n\ * The last element of IPIV for which a row interchange will\n\ * be done.\n\ *\n\ * IPIV (input) INTEGER array, dimension (K2*abs(INCX))\n\ * The vector of pivot indices. Only the elements in positions\n\ * K1 through K2 of IPIV are accessed.\n\ * IPIV(K) = L implies rows K and L are to be interchanged.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between successive values of IPIV. If IPIV\n\ * is negative, the pivots are applied in reverse order.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Modified by\n\ * R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32\n REAL TEMP\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/clacon0000644000175000017500000000461212502223525016451 0ustar uwabamiuwabami--- :name: clacon :md5sum: a83f242544259a16370667c7f930d723 :category: :subroutine :arguments: - n: :type: integer :intent: input - v: :type: complex :intent: workspace :dims: - n - x: :type: complex :intent: input/output :dims: - n - est: :type: real :intent: input/output - kase: :type: integer :intent: input/output :substitutions: {} :fortran_help: " SUBROUTINE CLACON( N, V, X, EST, KASE )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLACON estimates the 1-norm of a square, complex matrix A.\n\ * Reverse communication is used for evaluating matrix-vector products.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 1.\n\ *\n\ * V (workspace) COMPLEX array, dimension (N)\n\ * On the final return, V = A*W, where EST = norm(V)/norm(W)\n\ * (W is not returned).\n\ *\n\ * X (input/output) COMPLEX array, dimension (N)\n\ * On an intermediate return, X should be overwritten by\n\ * A * X, if KASE=1,\n\ * A' * X, if KASE=2,\n\ * where A' is the conjugate transpose of A, and CLACON must be\n\ * re-called with all the other parameters unchanged.\n\ *\n\ * EST (input/output) REAL\n\ * On entry with KASE = 1 or 2 and JUMP = 3, EST should be\n\ * unchanged from the previous call to CLACON.\n\ * On exit, EST is an estimate (a lower bound) for norm(A). \n\ *\n\ * KASE (input/output) INTEGER\n\ * On the initial call to CLACON, KASE should be 0.\n\ * On an intermediate return, KASE will be 1 or 2, indicating\n\ * whether X should be overwritten by A * X or A' * X.\n\ * On the final return from CLACON, KASE will again be 0.\n\ *\n\n\ * Further Details\n\ * ======= =======\n\ *\n\ * Contributed by Nick Higham, University of Manchester.\n\ * Originally named CONEST, dated March 16, 1988.\n\ *\n\ * Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n\ * a real or complex matrix, with applications to condition estimation\",\n\ * ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n\ *\n\ * Last modified: April, 1999\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zsteqr0000644000175000017500000000724612502223526016551 0ustar uwabamiuwabami--- :name: zsteqr :md5sum: 9473dd32ba01e32fce8c973a305d064a :category: :subroutine :arguments: - compz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - z: :type: doublecomplex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - "lsame_(&compz,\"N\") ? 0 : MAX(1,2*n-2)" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSTEQR computes all eigenvalues and, optionally, eigenvectors of a\n\ * symmetric tridiagonal matrix using the implicit QL or QR method.\n\ * The eigenvectors of a full or band complex Hermitian matrix can also\n\ * be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this\n\ * matrix to tridiagonal form.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * COMPZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only.\n\ * = 'V': Compute eigenvalues and eigenvectors of the original\n\ * Hermitian matrix. On entry, Z must contain the\n\ * unitary matrix used to reduce the original matrix\n\ * to tridiagonal form.\n\ * = 'I': Compute eigenvalues and eigenvectors of the\n\ * tridiagonal matrix. Z is initialized to the identity\n\ * matrix.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the diagonal elements of the tridiagonal matrix.\n\ * On exit, if INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * E (input/output) DOUBLE PRECISION array, dimension (N-1)\n\ * On entry, the (n-1) subdiagonal elements of the tridiagonal\n\ * matrix.\n\ * On exit, E has been destroyed.\n\ *\n\ * Z (input/output) COMPLEX*16 array, dimension (LDZ, N)\n\ * On entry, if COMPZ = 'V', then Z contains the unitary\n\ * matrix used in the reduction to tridiagonal form.\n\ * On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n\ * orthonormal eigenvectors of the original Hermitian matrix,\n\ * and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n\ * of the symmetric tridiagonal matrix.\n\ * If COMPZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * eigenvectors are desired, then LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))\n\ * If COMPZ = 'N', then WORK is not referenced.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: the algorithm has failed to find all the eigenvalues in\n\ * a total of 30*N iterations; if INFO = i, then i\n\ * elements of E have not converged to zero; on exit, D\n\ * and E contain the elements of a symmetric tridiagonal\n\ * matrix which is unitarily similar to the original\n\ * matrix.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlarfx0000644000175000017500000000464012502223526016474 0ustar uwabamiuwabami--- :name: dlarfx :md5sum: 108ce4a0efb7326ffa867e146ae4ee94 :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - v: :type: doublereal :intent: input :dims: - m - tau: :type: doublereal :intent: input - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLARFX applies a real elementary reflector H to a real m by n\n\ * matrix C, from either the left or the right. H is represented in the\n\ * form\n\ *\n\ * H = I - tau * v * v'\n\ *\n\ * where tau is a real scalar and v is a real vector.\n\ *\n\ * If tau = 0, then H is taken to be the unit matrix\n\ *\n\ * This version uses inline code if H has order < 11.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': form H * C\n\ * = 'R': form C * H\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C.\n\ *\n\ * V (input) DOUBLE PRECISION array, dimension (M) if SIDE = 'L'\n\ * or (N) if SIDE = 'R'\n\ * The vector v in the representation of H.\n\ *\n\ * TAU (input) DOUBLE PRECISION\n\ * The value tau in the representation of H.\n\ *\n\ * C (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n\ * On entry, the m by n matrix C.\n\ * On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n\ * or C * H if SIDE = 'R'.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDA >= (1,M).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension\n\ * (N) if SIDE = 'L'\n\ * or (M) if SIDE = 'R'\n\ * WORK is not referenced if H has order < 11.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chetrf0000644000175000017500000001401112502223525016457 0ustar uwabamiuwabami--- :name: chetrf :md5sum: f5e1a64640b9b7eecf825c98401cf6ac :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CHETRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHETRF computes the factorization of a complex Hermitian matrix A\n\ * using the Bunch-Kaufman diagonal pivoting method. The form of the\n\ * factorization is\n\ *\n\ * A = U*D*U**H or A = L*D*L**H\n\ *\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, and D is Hermitian and block diagonal with \n\ * 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\ * This is the blocked version of the algorithm, calling Level 3 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L (see below for further details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D.\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of WORK. LWORK >=1. For best performance\n\ * LWORK >= N*NB, where NB is the block size returned by ILAENV.\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, D(i,i) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular, and division by zero will occur if it\n\ * is used to solve a system of equations.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * If UPLO = 'U', then A = U*D*U', where\n\ * U = P(n)*U(n)* ... *P(k)U(k)* ...,\n\ * i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n\ * 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I v 0 ) k-s\n\ * U(k) = ( 0 I 0 ) s\n\ * ( 0 0 I ) n-k\n\ * k-s s n-k\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n\ * If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n\ * and A(k,k), and v overwrites A(1:k-2,k-1:k).\n\ *\n\ * If UPLO = 'L', then A = L*D*L', where\n\ * L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n\ * i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n\ * n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I 0 0 ) k-1\n\ * L(k) = ( 0 I 0 ) s\n\ * ( 0 v I ) n-k-s+1\n\ * k-1 s n-k-s+1\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n\ * If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n\ * and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LQUERY, UPPER\n INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CHETF2, CLAHEF, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zunmrq0000644000175000017500000001056412502223526016552 0ustar uwabamiuwabami--- :name: zunmrq :md5sum: 2f8b6c1c9742562afec7489e83cac105 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZUNMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZUNMRQ overwrites the general complex M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'C': Q**H * C C * Q**H\n\ *\n\ * where Q is a complex unitary matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(1)' H(2)' . . . H(k)'\n\ *\n\ * as returned by ZGERQF. Q is of order M if SIDE = 'L' and of order N\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**H from the Left;\n\ * = 'R': apply Q or Q**H from the Right.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q;\n\ * = 'C': Transpose, apply Q**H.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension\n\ * (LDA,M) if SIDE = 'L',\n\ * (LDA,N) if SIDE = 'R'\n\ * The i-th row must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * ZGERQF in the last k rows of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,K).\n\ *\n\ * TAU (input) COMPLEX*16 array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by ZGERQF.\n\ *\n\ * C (input/output) COMPLEX*16 array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M).\n\ * For optimum performance LWORK >= N*NB if SIDE = 'L', and\n\ * LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n\ * 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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhpev0000644000175000017500000000705112502223526016347 0ustar uwabamiuwabami--- :name: zhpev :md5sum: 29948d79784f28856fc93f9c14691050 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - ldap - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - MAX(1, 2*n-1) - rwork: :type: doublereal :intent: workspace :dims: - MAX(1, 3*n-2) - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE ZHPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHPEV computes all the eigenvalues and, optionally, eigenvectors of a\n\ * complex Hermitian matrix in packed storage.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, AP is overwritten by values generated during the\n\ * reduction to tridiagonal form. If UPLO = 'U', the diagonal\n\ * and first superdiagonal of the tridiagonal matrix T overwrite\n\ * the corresponding elements of A, and if UPLO = 'L', the\n\ * diagonal and first subdiagonal of T overwrite the\n\ * corresponding elements of A.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) COMPLEX*16 array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n\ * eigenvectors of the matrix A, with the i-th column of Z\n\ * holding the eigenvector associated with W(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (max(1, 2*N-1))\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2))\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 algorithm failed to converge; i\n\ * off-diagonal elements of an intermediate tridiagonal\n\ * form did not converge to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgeequb0000644000175000017500000000742112502223526016656 0ustar uwabamiuwabami--- :name: zgeequb :md5sum: 309542637b4b7d181a093e782883b162 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - r: :type: doublereal :intent: output :dims: - m - c: :type: doublereal :intent: output :dims: - n - rowcnd: :type: doublereal :intent: output - colcnd: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE ZGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGEEQUB computes row and column scalings intended to equilibrate an\n\ * M-by-N matrix A and reduce its condition number. R returns the row\n\ * scale factors and C the column scale factors, chosen to try to make\n\ * the largest element in each row and column of the matrix B with\n\ * elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n\ * the radix.\n\ *\n\ * R(i) and C(j) are restricted to be a power of the radix between\n\ * SMLNUM = smallest safe number and BIGNUM = largest safe number. Use\n\ * of these scaling factors is not guaranteed to reduce the condition\n\ * number of A but works well in practice.\n\ *\n\ * This routine differs from ZGEEQU by restricting the scaling factors\n\ * to a power of the radix. Baring over- and underflow, scaling by\n\ * these factors introduces no additional rounding errors. However, the\n\ * scaled entries' magnitured are no longer approximately 1 but lie\n\ * between sqrt(radix) and 1/sqrt(radix).\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) COMPLEX*16 array, dimension (LDA,N)\n\ * The M-by-N matrix whose equilibration factors are\n\ * to be computed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * R (output) DOUBLE PRECISION array, dimension (M)\n\ * If INFO = 0 or INFO > M, R contains the row scale factors\n\ * for A.\n\ *\n\ * C (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, C contains the column scale factors for A.\n\ *\n\ * ROWCND (output) DOUBLE PRECISION\n\ * If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n\ * smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n\ * AMAX is neither too large nor too small, it is not worth\n\ * scaling by R.\n\ *\n\ * COLCND (output) DOUBLE PRECISION\n\ * If INFO = 0, COLCND contains the ratio of the smallest\n\ * C(i) to the largest C(i). If COLCND >= 0.1, it is not\n\ * worth scaling by C.\n\ *\n\ * AMAX (output) DOUBLE PRECISION\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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, and i is\n\ * <= M: the i-th row of A is exactly zero\n\ * > M: the (i-M)-th column of A is exactly zero\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/csysvx0000644000175000017500000002340112502223525016546 0ustar uwabamiuwabami--- :name: csysvx :md5sum: 77314dc5b8cd439895289aa101e91eb2 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 3*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE CSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSYSVX uses the diagonal pivoting factorization to compute the\n\ * solution to a complex system of linear equations A * X = B,\n\ * where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n\ * matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'N', the diagonal pivoting method is used to factor A.\n\ * The form of the factorization is\n\ * A = U * D * U**T, if UPLO = 'U', or\n\ * A = L * D * L**T, if UPLO = 'L',\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, and D is symmetric and block diagonal with\n\ * 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\ * 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n\ * returns with INFO = i. Otherwise, the factored form of A is used\n\ * to estimate the condition number of the matrix A. If the\n\ * reciprocal of the condition number is less than machine precision,\n\ * INFO = N+1 is returned as a warning, but the routine still goes on\n\ * to solve for X and compute error bounds as described below.\n\ *\n\ * 3. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 4. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of A has been\n\ * supplied on entry.\n\ * = 'F': On entry, AF and IPIV contain the factored form\n\ * of A. A, AF and IPIV will not be modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular part\n\ * of the matrix A, and the strictly lower triangular part of A\n\ * is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of A contains the lower triangular part of\n\ * the matrix A, and the strictly upper triangular part of A is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input or output) COMPLEX array, dimension (LDAF,N)\n\ * If FACT = 'F', then AF is an input argument and on entry\n\ * contains the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L from the factorization\n\ * A = U*D*U**T or A = L*D*L**T as computed by CSYTRF.\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L from the factorization\n\ * A = U*D*U**T or A = L*D*L**T.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains details of the interchanges and the block structure\n\ * of D, as determined by CSYTRF.\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains details of the interchanges and the block structure\n\ * of D, as determined by CSYTRF.\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,NRHS)\n\ * The N-by-NRHS right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A. If RCOND is less than the machine precision (in\n\ * particular, if RCOND = 0), the matrix is singular to working\n\ * precision. This condition is indicated by a return code of\n\ * INFO > 0.\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of WORK. LWORK >= max(1,2*N), and for best\n\ * performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where\n\ * NB is the optimal blocksize for CSYTRF.\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\ * RWORK (workspace) REAL array, dimension (N)\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, and i is\n\ * <= N: D(i,i) is exactly zero. The factorization\n\ * has been completed but the factor D is exactly\n\ * singular, so the solution and error bounds could\n\ * not be computed. RCOND = 0 is returned.\n\ * = N+1: D is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clahqr0000644000175000017500000001336312502223525016467 0ustar uwabamiuwabami--- :name: clahqr :md5sum: d125b723dbd235592af2682105ae6ba2 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: complex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - w: :type: complex :intent: output :dims: - n - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: complex :intent: input/output :dims: - "wantz ? ldz : 0" - "wantz ? n : 0" - ldz: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, IHIZ, Z, LDZ, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAHQR is an auxiliary routine called by CHSEQR to update the\n\ * eigenvalues and Schur decomposition already computed by CHSEQR, by\n\ * dealing with the Hessenberg submatrix in rows and columns ILO to\n\ * IHI.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * WANTT (input) LOGICAL\n\ * = .TRUE. : the full Schur form T is required;\n\ * = .FALSE.: only eigenvalues are required.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * = .TRUE. : the matrix of Schur vectors Z is required;\n\ * = .FALSE.: Schur vectors are not required.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * It is assumed that H is already upper triangular in rows and\n\ * columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1).\n\ * CLAHQR works primarily with the Hessenberg submatrix in rows\n\ * and columns ILO to IHI, but applies transformations to all of\n\ * H if WANTT is .TRUE..\n\ * 1 <= ILO <= max(1,IHI); IHI <= N.\n\ *\n\ * H (input/output) COMPLEX array, dimension (LDH,N)\n\ * On entry, the upper Hessenberg matrix H.\n\ * On exit, if INFO is zero and if WANTT is .TRUE., then H\n\ * is upper triangular in rows and columns ILO:IHI. If INFO\n\ * is zero and if WANTT is .FALSE., then the contents of H\n\ * are unspecified on exit. The output state of H in case\n\ * INF is positive is below under the description of INFO.\n\ *\n\ * LDH (input) INTEGER\n\ * The leading dimension of the array H. LDH >= max(1,N).\n\ *\n\ * W (output) COMPLEX array, dimension (N)\n\ * The computed eigenvalues ILO to IHI are stored in the\n\ * corresponding elements of W. If WANTT is .TRUE., the\n\ * eigenvalues are stored in the same order as on the diagonal\n\ * of the Schur form returned in H, with W(i) = H(i,i).\n\ *\n\ * ILOZ (input) INTEGER\n\ * IHIZ (input) INTEGER\n\ * Specify the rows of Z to which transformations must be\n\ * applied if WANTZ is .TRUE..\n\ * 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.\n\ *\n\ * Z (input/output) COMPLEX array, dimension (LDZ,N)\n\ * If WANTZ is .TRUE., on entry Z must contain the current\n\ * matrix Z of transformations accumulated by CHSEQR, and on\n\ * exit Z has been updated; transformations are applied only to\n\ * the submatrix Z(ILOZ:IHIZ,ILO:IHI).\n\ * If WANTZ is .FALSE., Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * .GT. 0: if INFO = i, CLAHQR failed to compute all the\n\ * eigenvalues ILO to IHI in a total of 30 iterations\n\ * per eigenvalue; elements i+1:ihi of W contain\n\ * those eigenvalues which have been successfully\n\ * computed.\n\ *\n\ * If INFO .GT. 0 and WANTT is .FALSE., then on exit,\n\ * the remaining unconverged eigenvalues are the\n\ * eigenvalues of the upper Hessenberg matrix\n\ * rows and columns ILO thorugh INFO of the final,\n\ * output value of H.\n\ *\n\ * If INFO .GT. 0 and WANTT is .TRUE., then on exit\n\ * (*) (initial value of H)*U = U*(final value of H)\n\ * where U is an orthognal matrix. The final\n\ * value of H is upper Hessenberg and triangular in\n\ * rows and columns INFO+1 through IHI.\n\ *\n\ * If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n\ * (final value of Z) = (initial value of Z)*U\n\ * where U is the orthogonal matrix in (*)\n\ * (regardless of the value of WANTT.)\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * 02-96 Based on modifications by\n\ * David Day, Sandia National Laboratory, USA\n\ *\n\ * 12-04 Further modifications by\n\ * Ralph Byers, University of Kansas, USA\n\ * This is a modified version of CLAHQR from LAPACK version 3.0.\n\ * It is (1) more robust against overflow and underflow and\n\ * (2) adopts the more conservative Ahues & Tisseur stopping\n\ * criterion (LAWN 122, 1997).\n\ *\n\ * =========================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cppsv0000644000175000017500000000755312502223525016354 0ustar uwabamiuwabami--- :name: cppsv :md5sum: 263bad3d932191350716a728abd9f879 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - n*(n+1)/2 - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPPSV( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPPSV computes the solution to a complex system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N Hermitian positive definite matrix stored in\n\ * packed format and X and B are N-by-NRHS matrices.\n\ *\n\ * The Cholesky decomposition is used to factor A as\n\ * A = U**H* U, if UPLO = 'U', or\n\ * A = L * L**H, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is a lower triangular\n\ * matrix. The factored form of A is then used to solve the system of\n\ * equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ * See below for further details. \n\ *\n\ * On exit, if INFO = 0, the factor U or L from the Cholesky\n\ * factorization A = U**H*U or A = L*L**H, in the same storage\n\ * format as A.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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 leading minor of order i of A is not\n\ * positive definite, so the factorization could not be\n\ * completed, and the solution has not been computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The packed storage scheme is illustrated by the following example\n\ * when N = 4, UPLO = 'U':\n\ *\n\ * Two-dimensional storage of the Hermitian matrix A:\n\ *\n\ * a11 a12 a13 a14\n\ * a22 a23 a24\n\ * a33 a34 (aij = conjg(aji))\n\ * a44\n\ *\n\ * Packed storage of the upper triangle of A:\n\ *\n\ * AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n\ *\n\ * =====================================================================\n\ *\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CPPTRF, CPPTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sgelss0000644000175000017500000001143412502223526016513 0ustar uwabamiuwabami--- :name: sgelss :md5sum: 6214c742930da2ac2e5dea89d942672f :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - s: :type: real :intent: output :dims: - MIN(m,n) - rcond: :type: real :intent: input - rank: :type: integer :intent: output - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 3*MIN(m,n) + MAX(MAX(2*MIN(m,n),MAX(m,n)),nrhs) - info: :type: integer :intent: output :substitutions: m: lda ldb: MAX(m,n) :fortran_help: " SUBROUTINE SGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGELSS computes the minimum norm solution to a real linear least\n\ * squares problem:\n\ *\n\ * Minimize 2-norm(| b - A*x |).\n\ *\n\ * using the singular value decomposition (SVD) of A. A is an M-by-N\n\ * matrix which may be rank-deficient.\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 matrix\n\ * X.\n\ *\n\ * The effective rank of A is determined by treating as zero those\n\ * singular values which are less than RCOND times the largest singular\n\ * value.\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\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, the first min(m,n) rows of A are overwritten with\n\ * its right singular vectors, stored rowwise.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the M-by-NRHS right hand side matrix B.\n\ * On exit, B is overwritten by the N-by-NRHS solution\n\ * matrix X. If m >= n and RANK = n, the residual\n\ * sum-of-squares for the solution in the i-th column is given\n\ * by the sum of squares of elements n+1:m in that column.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,max(M,N)).\n\ *\n\ * S (output) REAL array, dimension (min(M,N))\n\ * The singular values of A in decreasing order.\n\ * The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n\ *\n\ * RCOND (input) REAL\n\ * RCOND is used to determine the effective rank of A.\n\ * Singular values S(i) <= RCOND*S(1) are treated as zero.\n\ * If RCOND < 0, machine precision is used instead.\n\ *\n\ * RANK (output) INTEGER\n\ * The effective rank of A, i.e., the number of singular values\n\ * which are greater than RCOND*S(1).\n\ *\n\ * WORK (workspace/output) REAL 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 >= 1, and also:\n\ * LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS )\n\ * For good performance, LWORK should generally be larger.\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: the algorithm for computing the SVD failed to converge;\n\ * if INFO = i, i off-diagonal elements of an intermediate\n\ * bidiagonal form did not converge to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cggev0000644000175000017500000001470712502223525016313 0ustar uwabamiuwabami--- :name: cggev :md5sum: 31b6e9522945246c5ec67cadb581319d :category: :subroutine :arguments: - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alpha: :type: complex :intent: output :dims: - n - beta: :type: complex :intent: output :dims: - n - vl: :type: complex :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: complex :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(1,2*n) - rwork: :type: real :intent: output :dims: - 8*n - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " SUBROUTINE CGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGGEV computes for a pair of N-by-N complex nonsymmetric matrices\n\ * (A,B), the generalized eigenvalues, and optionally, the left and/or\n\ * right generalized eigenvectors.\n\ *\n\ * A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n\ * lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n\ * singular. It is usually represented as the pair (alpha,beta), as\n\ * there is a reasonable interpretation for beta=0, and even for both\n\ * being zero.\n\ *\n\ * The right generalized eigenvector v(j) corresponding to the\n\ * generalized eigenvalue lambda(j) of (A,B) satisfies\n\ *\n\ * A * v(j) = lambda(j) * B * v(j).\n\ *\n\ * The left generalized eigenvector u(j) corresponding to the\n\ * generalized eigenvalues lambda(j) of (A,B) satisfies\n\ *\n\ * u(j)**H * A = lambda(j) * u(j)**H * B\n\ *\n\ * where u(j)**H is the conjugate-transpose of u(j).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVL (input) CHARACTER*1\n\ * = 'N': do not compute the left generalized eigenvectors;\n\ * = 'V': compute the left generalized eigenvectors.\n\ *\n\ * JOBVR (input) CHARACTER*1\n\ * = 'N': do not compute the right generalized eigenvectors;\n\ * = 'V': compute the right generalized eigenvectors.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A, B, VL, and VR. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA, N)\n\ * On entry, the matrix A in the pair (A,B).\n\ * On exit, A has been overwritten.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB, N)\n\ * On entry, the matrix B in the pair (A,B).\n\ * On exit, B has been overwritten.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B. LDB >= max(1,N).\n\ *\n\ * ALPHA (output) COMPLEX array, dimension (N)\n\ * BETA (output) COMPLEX array, dimension (N)\n\ * On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the\n\ * generalized eigenvalues.\n\ *\n\ * Note: the quotients ALPHA(j)/BETA(j) may easily over- or\n\ * underflow, and BETA(j) may even be zero. Thus, the user\n\ * should avoid naively computing the ratio alpha/beta.\n\ * However, ALPHA will be always less than and usually\n\ * comparable with norm(A) in magnitude, and BETA always less\n\ * than and usually comparable with norm(B).\n\ *\n\ * VL (output) COMPLEX array, dimension (LDVL,N)\n\ * If JOBVL = 'V', the left generalized eigenvectors u(j) are\n\ * stored one after another in the columns of VL, in the same\n\ * order as their eigenvalues.\n\ * Each eigenvector is scaled so the largest component has\n\ * abs(real part) + abs(imag. part) = 1.\n\ * Not referenced if JOBVL = 'N'.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the matrix VL. LDVL >= 1, and\n\ * if JOBVL = 'V', LDVL >= N.\n\ *\n\ * VR (output) COMPLEX array, dimension (LDVR,N)\n\ * If JOBVR = 'V', the right generalized eigenvectors v(j) are\n\ * stored one after another in the columns of VR, in the same\n\ * order as their eigenvalues.\n\ * Each eigenvector is scaled so the largest component has\n\ * abs(real part) + abs(imag. part) = 1.\n\ * Not referenced if JOBVR = 'N'.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the matrix VR. LDVR >= 1, and\n\ * if JOBVR = 'V', LDVR >= N.\n\ *\n\ * WORK (workspace/output) COMPLEX 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,2*N).\n\ * For good performance, LWORK must generally be larger.\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\ * RWORK (workspace/output) REAL array, dimension (8*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * =1,...,N:\n\ * The QZ iteration failed. No eigenvectors have been\n\ * calculated, but ALPHA(j) and BETA(j) should be\n\ * correct for j=INFO+1,...,N.\n\ * > N: =N+1: other then QZ iteration failed in SHGEQZ,\n\ * =N+2: error return from STGEVC.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgelq20000644000175000017500000000500312502223526016364 0ustar uwabamiuwabami--- :name: dgelq2 :md5sum: efc77ee160fccc12e8137440aba81433 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - MIN(m,n) - work: :type: doublereal :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " 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" ruby-lapack-1.7.2/dev/defs/ctrcon0000644000175000017500000000606612502223525016507 0ustar uwabamiuwabami--- :name: ctrcon :md5sum: f981f46545d070fd6eaeba4cc354de5f :category: :subroutine :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - rcond: :type: real :intent: output - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTRCON estimates the reciprocal of the condition number of a\n\ * triangular matrix A, in either the 1-norm or the infinity-norm.\n\ *\n\ * The norm of A is computed and an estimate is obtained for\n\ * norm(inv(A)), then the reciprocal of the condition number is\n\ * computed as\n\ * RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies whether the 1-norm condition number or the\n\ * infinity-norm condition number is required:\n\ * = '1' or 'O': 1-norm;\n\ * = 'I': Infinity-norm.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The triangular matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of the array A contains the upper\n\ * triangular matrix, and the strictly lower triangular part of\n\ * A is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of the array A contains the lower triangular\n\ * matrix, and the strictly upper triangular part of A is not\n\ * referenced. If DIAG = 'U', the diagonal elements of A are\n\ * also not referenced and are assumed to be 1.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(norm(A) * norm(inv(A))).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctrevc0000644000175000017500000001466112502223525016505 0ustar uwabamiuwabami--- :name: ctrevc :md5sum: d514272127683844e93020ff209cd3db :category: :subroutine :arguments: - side: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - t: :type: complex :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - vl: :type: complex :intent: input/output :dims: - ldvl - mm - ldvl: :type: integer :intent: input - vr: :type: complex :intent: input/output :dims: - ldvr - mm - ldvr: :type: integer :intent: input - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTREVC computes some or all of the right and/or left eigenvectors of\n\ * a complex upper triangular matrix T.\n\ * Matrices of this type are produced by the Schur factorization of\n\ * a complex general matrix: A = Q*T*Q**H, as computed by CHSEQR.\n\ * \n\ * The right eigenvector x and the left eigenvector y of T corresponding\n\ * to an eigenvalue w are defined by:\n\ * \n\ * T*x = w*x, (y**H)*T = w*(y**H)\n\ * \n\ * where y**H denotes the conjugate transpose of the vector y.\n\ * The eigenvalues are not input to this routine, but are read directly\n\ * from the diagonal of T.\n\ * \n\ * This routine returns the matrices X and/or Y of right and left\n\ * eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an\n\ * input matrix. If Q is the unitary factor that reduces a matrix A to\n\ * Schur form T, then Q*X and Q*Y are the matrices of right and left\n\ * eigenvectors of A.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'R': compute right eigenvectors only;\n\ * = 'L': compute left eigenvectors only;\n\ * = 'B': compute both right and left eigenvectors.\n\ *\n\ * HOWMNY (input) CHARACTER*1\n\ * = 'A': compute all right and/or left eigenvectors;\n\ * = 'B': compute all right and/or left eigenvectors,\n\ * backtransformed using the matrices supplied in\n\ * VR and/or VL;\n\ * = 'S': compute selected right and/or left eigenvectors,\n\ * as indicated by the logical array SELECT.\n\ *\n\ * SELECT (input) LOGICAL array, dimension (N)\n\ * If HOWMNY = 'S', SELECT specifies the eigenvectors to be\n\ * computed.\n\ * The eigenvector corresponding to the j-th eigenvalue is\n\ * computed if SELECT(j) = .TRUE..\n\ * Not referenced if HOWMNY = 'A' or 'B'.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix T. N >= 0.\n\ *\n\ * T (input/output) COMPLEX array, dimension (LDT,N)\n\ * The upper triangular matrix T. T is modified, but restored\n\ * on exit.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= max(1,N).\n\ *\n\ * VL (input/output) COMPLEX array, dimension (LDVL,MM)\n\ * On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n\ * contain an N-by-N matrix Q (usually the unitary matrix Q of\n\ * Schur vectors returned by CHSEQR).\n\ * On exit, if SIDE = 'L' or 'B', VL contains:\n\ * if HOWMNY = 'A', the matrix Y of left eigenvectors of T;\n\ * if HOWMNY = 'B', the matrix Q*Y;\n\ * if HOWMNY = 'S', the left eigenvectors of T specified by\n\ * SELECT, stored consecutively in the columns\n\ * of VL, in the same order as their\n\ * eigenvalues.\n\ * Not referenced if SIDE = 'R'.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the array VL. LDVL >= 1, and if\n\ * SIDE = 'L' or 'B', LDVL >= N.\n\ *\n\ * VR (input/output) COMPLEX array, dimension (LDVR,MM)\n\ * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n\ * contain an N-by-N matrix Q (usually the unitary matrix Q of\n\ * Schur vectors returned by CHSEQR).\n\ * On exit, if SIDE = 'R' or 'B', VR contains:\n\ * if HOWMNY = 'A', the matrix X of right eigenvectors of T;\n\ * if HOWMNY = 'B', the matrix Q*X;\n\ * if HOWMNY = 'S', the right eigenvectors of T specified by\n\ * SELECT, stored consecutively in the columns\n\ * of VR, in the same order as their\n\ * eigenvalues.\n\ * Not referenced if SIDE = 'L'.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the array VR. LDVR >= 1, and if\n\ * SIDE = 'R' or 'B'; LDVR >= N.\n\ *\n\ * MM (input) INTEGER\n\ * The number of columns in the arrays VL and/or VR. MM >= M.\n\ *\n\ * M (output) INTEGER\n\ * The number of columns in the arrays VL and/or VR actually\n\ * used to store the eigenvectors. If HOWMNY = 'A' or 'B', M\n\ * is set to N. Each selected eigenvector occupies one\n\ * column.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\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 algorithm used in this program is basically backward (forward)\n\ * substitution, with scaling to make the the code robust against\n\ * possible overflow.\n\ *\n\ * Each eigenvector is normalized so that the element of largest\n\ * magnitude has magnitude 1; here the magnitude of a complex number\n\ * (x,y) is taken to be |x| + |y|.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sppsvx0000644000175000017500000002563212502223526016563 0ustar uwabamiuwabami--- :name: sppsvx :md5sum: f166a0980453efbc2cb1d3eed8b18771 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - n*(n+1)/2 - afp: :type: real :intent: input/output :dims: - n*(n+1)/2 - equed: :type: char :intent: input/output - s: :type: real :intent: input/output :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE SPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPPSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to\n\ * compute the solution to a real system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N symmetric positive definite matrix stored in\n\ * packed format and X and B are N-by-NRHS matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', real scaling factors are computed to equilibrate\n\ * the system:\n\ * diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n\ *\n\ * 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n\ * factor the matrix A (after equilibration if FACT = 'E') as\n\ * A = U**T* U, if UPLO = 'U', or\n\ * A = L * L**T, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is a lower triangular\n\ * matrix.\n\ *\n\ * 3. If the leading i-by-i principal minor is not positive definite,\n\ * then the routine returns with INFO = i. Otherwise, the factored\n\ * form of A is used to estimate the condition number of the matrix\n\ * A. If the reciprocal of the condition number is less than machine\n\ * precision, INFO = N+1 is returned as a warning, but the routine\n\ * still goes on to solve for X and compute error bounds as\n\ * described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(S) so that it solves the original system before\n\ * equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AFP contains the factored form of A.\n\ * If EQUED = 'Y', the matrix A has been equilibrated\n\ * with scaling factors given by S. AP and AFP will not\n\ * be modified.\n\ * = 'N': The matrix A will be copied to AFP and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AFP and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AP (input/output) REAL array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array, except if FACT = 'F'\n\ * and EQUED = 'Y', then A must contain the equilibrated matrix\n\ * diag(S)*A*diag(S). The j-th column of A is stored in the\n\ * array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ * See below for further details. A is not modified if\n\ * FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n\ *\n\ * On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n\ * diag(S)*A*diag(S).\n\ *\n\ * AFP (input or output) REAL array, dimension\n\ * (N*(N+1)/2)\n\ * If FACT = 'F', then AFP is an input argument and on entry\n\ * contains the triangular factor U or L from the Cholesky\n\ * factorization A = U'*U or A = L*L', in the same storage\n\ * format as A. If EQUED .ne. 'N', then AFP is the factored\n\ * form of the equilibrated matrix A.\n\ *\n\ * If FACT = 'N', then AFP is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U'*U or A = L*L' of the original matrix A.\n\ *\n\ * If FACT = 'E', then AFP is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U'*U or A = L*L' of the equilibrated\n\ * matrix A (see the description of AP for the form of the\n\ * equilibrated matrix).\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'Y': Equilibration was done, i.e., A has been replaced by\n\ * diag(S) * A * diag(S).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * S (input or output) REAL array, dimension (N)\n\ * The scale factors for A; not accessed if EQUED = 'N'. S is\n\ * an input argument if FACT = 'F'; otherwise, S is an output\n\ * argument. If FACT = 'F' and EQUED = 'Y', each element of S\n\ * must be positive.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n\ * B is overwritten by diag(S) * B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) REAL array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n\ * the original system of equations. Note that if EQUED = 'Y',\n\ * A and B are modified on exit, and the solution to the\n\ * equilibrated system is inv(diag(S))*X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A after equilibration (if done). If RCOND is less than the\n\ * machine precision (in particular, if RCOND = 0), the matrix\n\ * is singular to working precision. This condition is\n\ * indicated by a return code of INFO > 0.\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) REAL array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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, and i is\n\ * <= N: the leading minor of order i of A is\n\ * not positive definite, so the factorization\n\ * could not be completed, and the solution has not\n\ * been computed. RCOND = 0 is returned.\n\ * = N+1: U is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The packed storage scheme is illustrated by the following example\n\ * when N = 4, UPLO = 'U':\n\ *\n\ * Two-dimensional storage of the symmetric matrix A:\n\ *\n\ * a11 a12 a13 a14\n\ * a22 a23 a24\n\ * a33 a34 (aij = conjg(aji))\n\ * a44\n\ *\n\ * Packed storage of the upper triangle of A:\n\ *\n\ * AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgbbrd0000644000175000017500000001161512502223525016436 0ustar uwabamiuwabami--- :name: cgbbrd :md5sum: b3d52b28be53961bb824695caf6d2471 :category: :subroutine :arguments: - vect: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - ncc: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - d: :type: real :intent: output :dims: - MIN(m,n) - e: :type: real :intent: output :dims: - MIN(m,n)-1 - q: :type: complex :intent: output :dims: - ldq - m - ldq: :type: integer :intent: input - pt: :type: complex :intent: output :dims: - ldpt - n - ldpt: :type: integer :intent: input - c: :type: complex :intent: input/output :dims: - ldc - ncc - ldc: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - MAX(m,n) - rwork: :type: real :intent: workspace :dims: - MAX(m,n) - info: :type: integer :intent: output :substitutions: m: ldab ldq: "((lsame_(&vect,\"Q\")) || (lsame_(&vect,\"B\"))) ? MAX(1,m) : 1" ldpt: "((lsame_(&vect,\"P\")) || (lsame_(&vect,\"B\"))) ? MAX(1,n) : 1" :fortran_help: " SUBROUTINE CGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, LDQ, PT, LDPT, C, LDC, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGBBRD reduces a complex general m-by-n band matrix A to real upper\n\ * bidiagonal form B by a unitary transformation: Q' * A * P = B.\n\ *\n\ * The routine computes B, and optionally forms Q or P', or computes\n\ * Q'*C for a given matrix C.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * VECT (input) CHARACTER*1\n\ * Specifies whether or not the matrices Q and P' are to be\n\ * formed.\n\ * = 'N': do not form Q or P';\n\ * = 'Q': form Q only;\n\ * = 'P': form P' only;\n\ * = 'B': form both.\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\ * NCC (input) INTEGER\n\ * The number of columns of the matrix C. NCC >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals of the matrix A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals of the matrix A. KU >= 0.\n\ *\n\ * AB (input/output) COMPLEX array, dimension (LDAB,N)\n\ * On entry, the m-by-n band matrix A, stored in rows 1 to\n\ * KL+KU+1. The j-th column of A is stored in the j-th column of\n\ * the array AB as follows:\n\ * AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n\ * On exit, A is overwritten by values generated during the\n\ * reduction.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array A. LDAB >= KL+KU+1.\n\ *\n\ * D (output) REAL array, dimension (min(M,N))\n\ * The diagonal elements of the bidiagonal matrix B.\n\ *\n\ * E (output) REAL array, dimension (min(M,N)-1)\n\ * The superdiagonal elements of the bidiagonal matrix B.\n\ *\n\ * Q (output) COMPLEX array, dimension (LDQ,M)\n\ * If VECT = 'Q' or 'B', the m-by-m unitary matrix Q.\n\ * If VECT = 'N' or 'P', the array Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q.\n\ * LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.\n\ *\n\ * PT (output) COMPLEX array, dimension (LDPT,N)\n\ * If VECT = 'P' or 'B', the n-by-n unitary matrix P'.\n\ * If VECT = 'N' or 'Q', the array PT is not referenced.\n\ *\n\ * LDPT (input) INTEGER\n\ * The leading dimension of the array PT.\n\ * LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.\n\ *\n\ * C (input/output) COMPLEX array, dimension (LDC,NCC)\n\ * On entry, an m-by-ncc matrix C.\n\ * On exit, C is overwritten by Q'*C.\n\ * C is not referenced if NCC = 0.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C.\n\ * LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (max(M,N))\n\ *\n\ * RWORK (workspace) REAL array, dimension (max(M,N))\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cptts20000644000175000017500000000552312502223525016433 0ustar uwabamiuwabami--- :name: cptts2 :md5sum: 681017bf4848ba56ba74ad522dbff08c :category: :subroutine :arguments: - iuplo: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: complex :intent: input :dims: - n-1 - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE CPTTS2( IUPLO, N, NRHS, D, E, B, LDB )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPTTS2 solves a tridiagonal system of the form\n\ * A * X = B\n\ * using the factorization A = U'*D*U or A = L*D*L' computed by CPTTRF.\n\ * D is a diagonal matrix specified in the vector D, U (or L) is a unit\n\ * bidiagonal matrix whose superdiagonal (subdiagonal) is specified in\n\ * the vector E, and X and B are N by NRHS matrices.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * IUPLO (input) INTEGER\n\ * Specifies the form of the factorization and whether the\n\ * vector E is the superdiagonal of the upper bidiagonal factor\n\ * U or the subdiagonal of the lower bidiagonal factor L.\n\ * = 1: A = U'*D*U, E is the superdiagonal of U\n\ * = 0: A = L*D*L', E is the subdiagonal of L\n\ *\n\ * N (input) INTEGER\n\ * The order of the tridiagonal matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The n diagonal elements of the diagonal matrix D from the\n\ * factorization A = U'*D*U or A = L*D*L'.\n\ *\n\ * E (input) COMPLEX array, dimension (N-1)\n\ * If IUPLO = 1, the (n-1) superdiagonal elements of the unit\n\ * bidiagonal factor U from the factorization A = U'*D*U.\n\ * If IUPLO = 0, the (n-1) subdiagonal elements of the unit\n\ * bidiagonal factor L from the factorization A = L*D*L'.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the right hand side vectors B for the system of\n\ * linear equations.\n\ * On exit, the solution vectors, X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CSSCAL\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC CONJG\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/shseqr0000644000175000017500000002774712502223526016536 0ustar uwabamiuwabami--- :name: shseqr :md5sum: 717af2c10d7849612c9648d71a873ad5 :category: :subroutine :arguments: - job: :type: char :intent: input - compz: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: real :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - wr: :type: real :intent: output :dims: - n - wi: :type: real :intent: output :dims: - n - z: :type: real :intent: input/output :dims: - "lsame_(&compz,\"N\") ? 0 : ldz" - "lsame_(&compz,\"N\") ? 0 : n" - ldz: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, LDZ, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SHSEQR computes the eigenvalues of a Hessenberg matrix H\n\ * and, optionally, the matrices T and Z from the Schur decomposition\n\ * H = Z T Z**T, where T is an upper quasi-triangular matrix (the\n\ * Schur form), and Z is the orthogonal matrix of Schur vectors.\n\ *\n\ * Optionally Z may be postmultiplied into an input orthogonal\n\ * matrix Q so that this routine can give the Schur factorization\n\ * of a matrix A which has been reduced to the Hessenberg form H\n\ * by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * = 'E': compute eigenvalues only;\n\ * = 'S': compute eigenvalues and the Schur form T.\n\ *\n\ * COMPZ (input) CHARACTER*1\n\ * = 'N': no Schur vectors are computed;\n\ * = 'I': Z is initialized to the unit matrix and the matrix Z\n\ * of Schur vectors of H is returned;\n\ * = 'V': Z must contain an orthogonal matrix Q on entry, and\n\ * the product Q*Z is returned.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H. N .GE. 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * It is assumed that H is already upper triangular in rows\n\ * and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n\ * set by a previous call to SGEBAL, and then passed to SGEHRD\n\ * when the matrix output by SGEBAL is reduced to Hessenberg\n\ * form. Otherwise ILO and IHI should be set to 1 and N\n\ * respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n\ * If N = 0, then ILO = 1 and IHI = 0.\n\ *\n\ * H (input/output) REAL array, dimension (LDH,N)\n\ * On entry, the upper Hessenberg matrix H.\n\ * On exit, if INFO = 0 and JOB = 'S', then H contains the\n\ * upper quasi-triangular matrix T from the Schur decomposition\n\ * (the Schur form); 2-by-2 diagonal blocks (corresponding to\n\ * complex conjugate pairs of eigenvalues) are returned in\n\ * standard form, with H(i,i) = H(i+1,i+1) and\n\ * H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and JOB = 'E', the\n\ * contents of H are unspecified on exit. (The output value of\n\ * H when INFO.GT.0 is given under the description of INFO\n\ * below.)\n\ *\n\ * Unlike earlier versions of SHSEQR, this subroutine may\n\ * explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1\n\ * or j = IHI+1, IHI+2, ... N.\n\ *\n\ * LDH (input) INTEGER\n\ * The leading dimension of the array H. LDH .GE. max(1,N).\n\ *\n\ * WR (output) REAL array, dimension (N)\n\ * WI (output) REAL array, dimension (N)\n\ * The real and imaginary parts, respectively, of the computed\n\ * eigenvalues. If two eigenvalues are computed as a complex\n\ * conjugate pair, they are stored in consecutive elements of\n\ * WR and WI, say the i-th and (i+1)th, with WI(i) .GT. 0 and\n\ * WI(i+1) .LT. 0. If JOB = 'S', the eigenvalues are stored in\n\ * the same order as on the diagonal of the Schur form returned\n\ * in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2\n\ * diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and\n\ * WI(i+1) = -WI(i).\n\ *\n\ * Z (input/output) REAL array, dimension (LDZ,N)\n\ * If COMPZ = 'N', Z is not referenced.\n\ * If COMPZ = 'I', on entry Z need not be set and on exit,\n\ * if INFO = 0, Z contains the orthogonal matrix Z of the Schur\n\ * vectors of H. If COMPZ = 'V', on entry Z must contain an\n\ * N-by-N matrix Q, which is assumed to be equal to the unit\n\ * matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,\n\ * if INFO = 0, Z contains Q*Z.\n\ * Normally Q is the orthogonal matrix generated by SORGHR\n\ * after the call to SGEHRD which formed the Hessenberg matrix\n\ * H. (The output value of Z when INFO.GT.0 is given under\n\ * the description of INFO below.)\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. if COMPZ = 'I' or\n\ * COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1.\n\ *\n\ * WORK (workspace/output) REAL array, dimension (LWORK)\n\ * On exit, if INFO = 0, WORK(1) returns an estimate of\n\ * the optimal value for LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK .GE. max(1,N)\n\ * is sufficient and delivers very good and sometimes\n\ * optimal performance. However, LWORK as large as 11*N\n\ * may be required for optimal performance. A workspace\n\ * query is recommended to determine the optimal workspace\n\ * size.\n\ *\n\ * If LWORK = -1, then SHSEQR does a workspace query.\n\ * In this case, SHSEQR checks the input parameters and\n\ * estimates the optimal workspace size for the given\n\ * values of N, ILO and IHI. The estimate is returned\n\ * in WORK(1). No error message related to LWORK is\n\ * issued by XERBLA. Neither H nor Z are accessed.\n\ *\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * .LT. 0: if INFO = -i, the i-th argument had an illegal\n\ * value\n\ * .GT. 0: if INFO = i, SHSEQR failed to compute all of\n\ * the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n\ * and WI contain those eigenvalues which have been\n\ * successfully computed. (Failures are rare.)\n\ *\n\ * If INFO .GT. 0 and JOB = 'E', then on exit, the\n\ * remaining unconverged eigenvalues are the eigen-\n\ * values of the upper Hessenberg matrix rows and\n\ * columns ILO through INFO of the final, output\n\ * value of H.\n\ *\n\ * If INFO .GT. 0 and JOB = 'S', then on exit\n\ *\n\ * (*) (initial value of H)*U = U*(final value of H)\n\ *\n\ * where U is an orthogonal matrix. The final\n\ * value of H is upper Hessenberg and quasi-triangular\n\ * in rows and columns INFO+1 through IHI.\n\ *\n\ * If INFO .GT. 0 and COMPZ = 'V', then on exit\n\ *\n\ * (final value of Z) = (initial value of Z)*U\n\ *\n\ * where U is the orthogonal matrix in (*) (regard-\n\ * less of the value of JOB.)\n\ *\n\ * If INFO .GT. 0 and COMPZ = 'I', then on exit\n\ * (final value of Z) = U\n\ * where U is the orthogonal matrix in (*) (regard-\n\ * less of the value of JOB.)\n\ *\n\ * If INFO .GT. 0 and COMPZ = 'N', then Z is not\n\ * accessed.\n\ *\n\n\ * ================================================================\n\ * Default values supplied by\n\ * ILAENV(ISPEC,'SHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).\n\ * It is suggested that these defaults be adjusted in order\n\ * to attain best performance in each particular\n\ * computational environment.\n\ *\n\ * ISPEC=12: The SLAHQR vs SLAQR0 crossover point.\n\ * Default: 75. (Must be at least 11.)\n\ *\n\ * ISPEC=13: Recommended deflation window size.\n\ * This depends on ILO, IHI and NS. NS is the\n\ * number of simultaneous shifts returned\n\ * by ILAENV(ISPEC=15). (See ISPEC=15 below.)\n\ * The default for (IHI-ILO+1).LE.500 is NS.\n\ * The default for (IHI-ILO+1).GT.500 is 3*NS/2.\n\ *\n\ * ISPEC=14: Nibble crossover point. (See IPARMQ for\n\ * details.) Default: 14% of deflation window\n\ * size.\n\ *\n\ * ISPEC=15: Number of simultaneous shifts in a multishift\n\ * QR iteration.\n\ *\n\ * If IHI-ILO+1 is ...\n\ *\n\ * greater than ...but less ... the\n\ * or equal to ... than default is\n\ *\n\ * 1 30 NS = 2(+)\n\ * 30 60 NS = 4(+)\n\ * 60 150 NS = 10(+)\n\ * 150 590 NS = **\n\ * 590 3000 NS = 64\n\ * 3000 6000 NS = 128\n\ * 6000 infinity NS = 256\n\ *\n\ * (+) By default some or all matrices of this order\n\ * are passed to the implicit double shift routine\n\ * SLAHQR and this parameter is ignored. See\n\ * ISPEC=12 above and comments in IPARMQ for\n\ * details.\n\ *\n\ * (**) The asterisks (**) indicate an ad-hoc\n\ * function of N increasing from 10 to 64.\n\ *\n\ * ISPEC=16: Select structured matrix multiply.\n\ * If the number of simultaneous shifts (specified\n\ * by ISPEC=15) is less than 14, then the default\n\ * for ISPEC=16 is 0. Otherwise the default for\n\ * ISPEC=16 is 2.\n\ *\n\ * ================================================================\n\ * Based on contributions by\n\ * Karen Braman and Ralph Byers, Department of Mathematics,\n\ * University of Kansas, USA\n\ *\n\ * ================================================================\n\ * References:\n\ * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n\ * Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n\ * Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n\ * 929--947, 2002.\n\ *\n\ * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n\ * Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n\ * of Matrix Analysis, volume 23, pages 948--973, 2002.\n\ *\n\ * ================================================================\n" ruby-lapack-1.7.2/dev/defs/slascl0000644000175000017500000000631512502223526016476 0ustar uwabamiuwabami--- :name: slascl :md5sum: 1a4b40e8a10707c3896d8c7d4a610aac :category: :subroutine :arguments: - type: :type: char :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - cfrom: :type: real :intent: input - cto: :type: real :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLASCL multiplies the M by N real matrix A by the real scalar\n\ * CTO/CFROM. This is done without over/underflow as long as the final\n\ * result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that\n\ * A may be full, upper triangular, lower triangular, upper Hessenberg,\n\ * or banded.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TYPE (input) CHARACTER*1\n\ * TYPE indices the storage type of the input matrix.\n\ * = 'G': A is a full matrix.\n\ * = 'L': A is a lower triangular matrix.\n\ * = 'U': A is an upper triangular matrix.\n\ * = 'H': A is an upper Hessenberg matrix.\n\ * = 'B': A is a symmetric band matrix with lower bandwidth KL\n\ * and upper bandwidth KU and with the only the lower\n\ * half stored.\n\ * = 'Q': A is a symmetric band matrix with lower bandwidth KL\n\ * and upper bandwidth KU and with the only the upper\n\ * half stored.\n\ * = 'Z': A is a band matrix with lower bandwidth KL and upper\n\ * bandwidth KU. See SGBTRF for storage details.\n\ *\n\ * KL (input) INTEGER\n\ * The lower bandwidth of A. Referenced only if TYPE = 'B',\n\ * 'Q' or 'Z'.\n\ *\n\ * KU (input) INTEGER\n\ * The upper bandwidth of A. Referenced only if TYPE = 'B',\n\ * 'Q' or 'Z'.\n\ *\n\ * CFROM (input) REAL\n\ * CTO (input) REAL\n\ * The matrix A is multiplied by CTO/CFROM. A(I,J) is computed\n\ * without over/underflow if the final result CTO*A(I,J)/CFROM\n\ * can be represented without over/underflow. CFROM must be\n\ * nonzero.\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) REAL array, dimension (LDA,N)\n\ * The matrix to be multiplied by CTO/CFROM. See TYPE for the\n\ * storage type.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgelqf0000644000175000017500000000725312502223526016461 0ustar uwabamiuwabami--- :name: dgelqf :md5sum: b4d5555b345b2643eab5d4e5c10862ee :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - MIN(m,n) - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " 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" ruby-lapack-1.7.2/dev/defs/dgttrs0000644000175000017500000000704012502223526016520 0ustar uwabamiuwabami--- :name: dgttrs :md5sum: b93484e4a60657d1a7d75fd2575b68f7 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: doublereal :intent: input :dims: - n-1 - d: :type: doublereal :intent: input :dims: - n - du: :type: doublereal :intent: input :dims: - n-1 - du2: :type: doublereal :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGTTRS solves one of the systems of equations\n\ * A*X = B or A'*X = B,\n\ * with a tridiagonal matrix A using the LU factorization computed\n\ * by DGTTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations.\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A'* X = B (Transpose)\n\ * = 'C': A'* X = B (Conjugate transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * DL (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) multipliers that define the matrix L from the\n\ * LU factorization of A.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The n diagonal elements of the upper triangular matrix U from\n\ * the LU factorization of A.\n\ *\n\ * DU (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) elements of the first super-diagonal of U.\n\ *\n\ * DU2 (input) DOUBLE PRECISION array, dimension (N-2)\n\ * The (n-2) elements of the second super-diagonal of U.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices; for 1 <= i <= n, row i of the matrix was\n\ * interchanged with row IPIV(i). IPIV(i) will always be either\n\ * i or i+1; IPIV(i) = i indicates a row interchange was not\n\ * required.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the matrix of right hand side vectors B.\n\ * On exit, B is overwritten by the solution vectors X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL NOTRAN\n INTEGER ITRANS, J, JB, NB\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DGTTS2, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/strttp0000644000175000017500000000433212502223526016552 0ustar uwabamiuwabami--- :name: strttp :md5sum: 952a2e28ec06b1b31c0e79c0f031dff9 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ap: :type: real :intent: output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE STRTTP( UPLO, N, A, LDA, AP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STRTTP copies a triangular matrix A from full format (TR) to standard\n\ * packed format (TP).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular.\n\ * = 'L': A is lower triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices AP and A. N >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * On exit, the triangular matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AP (output) REAL array, dimension (N*(N+1)/2\n\ * On exit, the upper or lower triangular matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zggbak0000644000175000017500000000744012502223526016462 0ustar uwabamiuwabami--- :name: zggbak :md5sum: 6989e9096344ffe7d282754d45eeda01 :category: :subroutine :arguments: - job: :type: char :intent: input - side: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - lscale: :type: doublereal :intent: input :dims: - n - rscale: :type: doublereal :intent: input :dims: - n - m: :type: integer :intent: input - v: :type: doublecomplex :intent: input/output :dims: - ldv - m - ldv: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGGBAK forms the right or left eigenvectors of a complex generalized\n\ * eigenvalue problem A*x = lambda*B*x, by backward transformation on\n\ * the computed eigenvectors of the balanced pair of matrices output by\n\ * ZGGBAL.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * Specifies the type of backward transformation required:\n\ * = 'N': do nothing, return immediately;\n\ * = 'P': do backward transformation for permutation only;\n\ * = 'S': do backward transformation for scaling only;\n\ * = 'B': do backward transformations for both permutation and\n\ * scaling.\n\ * JOB must be the same as the argument JOB supplied to ZGGBAL.\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'R': V contains right eigenvectors;\n\ * = 'L': V contains left eigenvectors.\n\ *\n\ * N (input) INTEGER\n\ * The number of rows of the matrix V. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * The integers ILO and IHI determined by ZGGBAL.\n\ * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n\ *\n\ * LSCALE (input) DOUBLE PRECISION array, dimension (N)\n\ * Details of the permutations and/or scaling factors applied\n\ * to the left side of A and B, as returned by ZGGBAL.\n\ *\n\ * RSCALE (input) DOUBLE PRECISION array, dimension (N)\n\ * Details of the permutations and/or scaling factors applied\n\ * to the right side of A and B, as returned by ZGGBAL.\n\ *\n\ * M (input) INTEGER\n\ * The number of columns of the matrix V. M >= 0.\n\ *\n\ * V (input/output) COMPLEX*16 array, dimension (LDV,M)\n\ * On entry, the matrix of right or left eigenvectors to be\n\ * transformed, as returned by ZTGEVC.\n\ * On exit, V is overwritten by the transformed eigenvectors.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the matrix V. LDV >= max(1,N).\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\ * See R.C. Ward, Balancing the generalized eigenvalue problem,\n\ * SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LEFTV, RIGHTV\n INTEGER I, K\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZDSCAL, ZSWAP\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slaneg0000644000175000017500000000535412502223526016470 0ustar uwabamiuwabami--- :name: slaneg :md5sum: b592b6c8f13d7dc0edca587a18aebd9f :category: :function :type: integer :arguments: - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - lld: :type: real :intent: input :dims: - n-1 - sigma: :type: real :intent: input - pivmin: :type: real :intent: input - r: :type: integer :intent: input :substitutions: {} :fortran_help: " INTEGER FUNCTION SLANEG( N, D, LLD, SIGMA, PIVMIN, R )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLANEG computes the Sturm count, the number of negative pivots\n\ * encountered while factoring tridiagonal T - sigma I = L D L^T.\n\ * This implementation works directly on the factors without forming\n\ * the tridiagonal matrix T. The Sturm count is also the number of\n\ * eigenvalues of T less than sigma.\n\ *\n\ * This routine is called from SLARRB.\n\ *\n\ * The current routine does not use the PIVMIN parameter but rather\n\ * requires IEEE-754 propagation of Infinities and NaNs. This\n\ * routine also has no input range restrictions but does require\n\ * default exception handling such that x/0 produces Inf when x is\n\ * non-zero, and Inf/Inf produces NaN. For more information, see:\n\ *\n\ * Marques, Riedy, and Voemel, \"Benefits of IEEE-754 Features in\n\ * Modern Symmetric Tridiagonal Eigensolvers,\" SIAM Journal on\n\ * Scientific Computing, v28, n5, 2006. DOI 10.1137/050641624\n\ * (Tech report version in LAWN 172 with the same title.)\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The N diagonal elements of the diagonal matrix D.\n\ *\n\ * LLD (input) REAL array, dimension (N-1)\n\ * The (N-1) elements L(i)*L(i)*D(i).\n\ *\n\ * SIGMA (input) REAL \n\ * Shift amount in T - sigma I = L D L^T.\n\ *\n\ * PIVMIN (input) REAL \n\ * The minimum pivot in the Sturm sequence. May be used\n\ * when zero pivots are encountered on non-IEEE-754\n\ * architectures.\n\ *\n\ * R (input) INTEGER\n\ * The twist index for the twisted factorization that is used\n\ * for the negcount.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, University of California, Berkeley, USA\n\ * Jason Riedy, University of California, Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlarrk0000644000175000017500000000624512502223526016476 0ustar uwabamiuwabami--- :name: dlarrk :md5sum: 4e0b3e510031faaddb890af5e08e89a2 :category: :subroutine :arguments: - n: :type: integer :intent: input - iw: :type: integer :intent: input - gl: :type: doublereal :intent: input - gu: :type: doublereal :intent: input - d: :type: doublereal :intent: input :dims: - n - e2: :type: doublereal :intent: input :dims: - n-1 - pivmin: :type: doublereal :intent: input - reltol: :type: doublereal :intent: input - w: :type: doublereal :intent: output - werr: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLARRK( N, IW, GL, GU, D, E2, PIVMIN, RELTOL, W, WERR, INFO)\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLARRK computes one eigenvalue of a symmetric tridiagonal\n\ * matrix T to suitable accuracy. This is an auxiliary code to be\n\ * called from DSTEMR.\n\ *\n\ * To avoid overflow, the matrix must be scaled so that its\n\ * largest element is no greater than overflow**(1/2) *\n\ * underflow**(1/4) in absolute value, and for greatest\n\ * accuracy, it should not be much smaller than that.\n\ *\n\ * See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n\ * Matrix\", Report CS41, Computer Science Dept., Stanford\n\ * University, July 21, 1966.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the tridiagonal matrix T. N >= 0.\n\ *\n\ * IW (input) INTEGER\n\ * The index of the eigenvalues to be returned.\n\ *\n\ * GL (input) DOUBLE PRECISION\n\ * GU (input) DOUBLE PRECISION\n\ * An upper and a lower bound on the eigenvalue.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The n diagonal elements of the tridiagonal matrix T.\n\ *\n\ * E2 (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) squared off-diagonal elements of the tridiagonal matrix T.\n\ *\n\ * PIVMIN (input) DOUBLE PRECISION\n\ * The minimum pivot allowed in the Sturm sequence for T.\n\ *\n\ * RELTOL (input) DOUBLE PRECISION\n\ * The minimum relative width of an interval. When an interval\n\ * is narrower than RELTOL times the larger (in\n\ * magnitude) endpoint, then it is considered to be\n\ * sufficiently small, i.e., converged. Note: this should\n\ * always be at least radix*machine epsilon.\n\ *\n\ * W (output) DOUBLE PRECISION\n\ *\n\ * WERR (output) DOUBLE PRECISION\n\ * The error bound on the corresponding eigenvalue approximation\n\ * in W.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Eigenvalue converged\n\ * = -1: Eigenvalue did NOT converge\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * FUDGE DOUBLE PRECISION, default = 2\n\ * A \"fudge factor\" to widen the Gershgorin intervals.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctpttf0000644000175000017500000001417412502223525016522 0ustar uwabamiuwabami--- :name: ctpttf :md5sum: a3138578f1484902c662e2e58b35bf01 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - ( n*(n+1)/2 ) - arf: :type: complex :intent: output :dims: - ( n*(n+1)/2 ) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CTPTTF( TRANSR, UPLO, N, AP, ARF, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTPTTF copies a triangular matrix A from standard packed format (TP)\n\ * to rectangular full packed format (TF).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': ARF in Normal format is wanted;\n\ * = 'C': ARF in Conjugate-transpose format is wanted.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input) COMPLEX array, dimension ( N*(N+1)/2 ),\n\ * On entry, the upper or lower triangular matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * ARF (output) COMPLEX array, dimension ( N*(N+1)/2 ),\n\ * On exit, the upper or lower triangular matrix A stored in\n\ * RFP format. For a further discussion see Notes below.\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\ * We first consider Standard Packed Format when N is even.\n\ * We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * conjugate-transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * conjugate-transpose of the last three columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- --\n\ * 03 04 05 33 43 53\n\ * -- --\n\ * 13 14 15 00 44 54\n\ * --\n\ * 23 24 25 10 11 55\n\ *\n\ * 33 34 35 20 21 22\n\ * --\n\ * 00 44 45 30 31 32\n\ * -- --\n\ * 01 11 55 40 41 42\n\ * -- -- --\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We next consider Standard Packed Format when N is odd.\n\ * We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * conjugate-transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * conjugate-transpose of the last two columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- --\n\ * 02 03 04 00 33 43\n\ * --\n\ * 12 13 14 10 11 44\n\ *\n\ * 22 23 24 20 21 22\n\ * --\n\ * 00 33 34 30 31 32\n\ * -- --\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- --\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/csysvxx0000644000175000017500000005154312502223525016746 0ustar uwabamiuwabami--- :name: csysvxx :md5sum: cc892e69a3d21b7e853bcf241519ec7c :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - equed: :type: char :intent: input/output - s: :type: real :intent: input/output :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - rpvgrw: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " SUBROUTINE CSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSYSVXX uses the diagonal pivoting factorization to compute the\n\ * solution to a complex system of linear equations A * X = B, where\n\ * A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n\ * matrices.\n\ *\n\ * If requested, both normwise and maximum componentwise error bounds\n\ * are returned. CSYSVXX will return a solution with a tiny\n\ * guaranteed error (O(eps) where eps is the working machine\n\ * precision) unless the matrix is very ill-conditioned, in which\n\ * case a warning is returned. Relevant condition numbers also are\n\ * calculated and returned.\n\ *\n\ * CSYSVXX accepts user-provided factorizations and equilibration\n\ * factors; see the definitions of the FACT and EQUED options.\n\ * Solving with refinement and using a factorization from a previous\n\ * CSYSVXX call will also produce a solution with either O(eps)\n\ * errors or warnings, but we cannot make that claim for general\n\ * user-provided factorizations and equilibration factors if they\n\ * differ from what CSYSVXX would itself produce.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', real scaling factors are computed to equilibrate\n\ * the system:\n\ *\n\ * diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B\n\ *\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n\ *\n\ * 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n\ * the matrix A (after equilibration if FACT = 'E') as\n\ *\n\ * A = U * D * U**T, if UPLO = 'U', or\n\ * A = L * D * L**T, if UPLO = 'L',\n\ *\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, and D is symmetric and block diagonal with\n\ * 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\ * 3. If some D(i,i)=0, so that D is exactly singular, then the\n\ * routine returns with INFO = i. Otherwise, the factored form of A\n\ * is used to estimate the condition number of the matrix A (see\n\ * argument RCOND). If the reciprocal of the condition number is\n\ * less than machine precision, the routine still goes on to solve\n\ * for X and compute error bounds as described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n\ * the routine will use iterative refinement to try to get a small\n\ * error and error bounds. Refinement calculates the residual to at\n\ * least twice the working precision.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(R) so that it solves the original system before\n\ * equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AF and IPIV contain the factored form of A.\n\ * If EQUED is not 'N', the matrix A has been\n\ * equilibrated with scaling factors given by S.\n\ * A, AF, and IPIV are not modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AF and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular\n\ * part of the matrix A, and the strictly lower triangular\n\ * part of A is not referenced. If UPLO = 'L', the leading\n\ * N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n\ * diag(S)*A*diag(S).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input or output) COMPLEX array, dimension (LDAF,N)\n\ * If FACT = 'F', then AF is an input argument and on entry\n\ * contains the block diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L from the factorization A =\n\ * U*D*U**T or A = L*D*L**T as computed by SSYTRF.\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the block diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L from the factorization A =\n\ * U*D*U**T or A = L*D*L**T.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains details of the interchanges and the block\n\ * structure of D, as determined by SSYTRF. If IPIV(k) > 0,\n\ * then rows and columns k and IPIV(k) were interchanged and\n\ * D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and\n\ * IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and\n\ * -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2\n\ * diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0,\n\ * then rows and columns k+1 and -IPIV(k) were interchanged\n\ * and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains details of the interchanges and the block\n\ * structure of D, as determined by SSYTRF.\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'Y': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(S) * A * diag(S).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * S (input or output) REAL array, dimension (N)\n\ * The scale factors for A. If EQUED = 'Y', A is multiplied on\n\ * the left and right by diag(S). S is an input argument if FACT =\n\ * 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n\ * = 'Y', each element of S must be positive. If S is output, each\n\ * element of S is a power of the radix. If S is input, each element\n\ * of S should be a power of the radix to ensure a reliable solution\n\ * and error estimates. Scaling by powers of the radix does not cause\n\ * rounding errors unless the result underflows or overflows.\n\ * Rounding errors during scaling lead to refining with a matrix that\n\ * is not equivalent to the input matrix, producing error estimates\n\ * that may not be reliable.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit,\n\ * if EQUED = 'N', B is not modified;\n\ * if EQUED = 'Y', B is overwritten by diag(S)*B;\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX array, dimension (LDX,NRHS)\n\ * If INFO = 0, the N-by-NRHS solution matrix X to the original\n\ * system of equations. Note that A and B are modified on exit if\n\ * EQUED .ne. 'N', and the solution to the equilibrated system is\n\ * inv(diag(S))*X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * RPVGRW (output) REAL\n\ * Reciprocal pivot growth. On exit, this contains the reciprocal\n\ * pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n\ * norm is used. If this is much less than 1, then the stability of\n\ * the LU factorization of the (equilibrated) matrix A could be poor.\n\ * This also means that the solution X, estimated condition numbers,\n\ * and error bounds could be unreliable. If factorization fails with\n\ * 0 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/strcon0000644000175000017500000000606012502223526016522 0ustar uwabamiuwabami--- :name: strcon :md5sum: 1e27ff979acf125159e35c01ddb03755 :category: :subroutine :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - rcond: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE STRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STRCON estimates the reciprocal of the condition number of a\n\ * triangular matrix A, in either the 1-norm or the infinity-norm.\n\ *\n\ * The norm of A is computed and an estimate is obtained for\n\ * norm(inv(A)), then the reciprocal of the condition number is\n\ * computed as\n\ * RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies whether the 1-norm condition number or the\n\ * infinity-norm condition number is required:\n\ * = '1' or 'O': 1-norm;\n\ * = 'I': Infinity-norm.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * The triangular matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of the array A contains the upper\n\ * triangular matrix, and the strictly lower triangular part of\n\ * A is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of the array A contains the lower triangular\n\ * matrix, and the strictly upper triangular part of A is not\n\ * referenced. If DIAG = 'U', the diagonal elements of A are\n\ * also not referenced and are assumed to be 1.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(norm(A) * norm(inv(A))).\n\ *\n\ * WORK (workspace) REAL array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cposvx0000644000175000017500000002550412502223525016537 0ustar uwabamiuwabami--- :name: cposvx :md5sum: 5047940aaa72c0b2ca58d57ec4923985 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - equed: :type: char :intent: input/output - s: :type: real :intent: input/output :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE CPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPOSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to\n\ * compute the solution to a complex system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N Hermitian positive definite matrix and X and B\n\ * are N-by-NRHS matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', real scaling factors are computed to equilibrate\n\ * the system:\n\ * diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n\ *\n\ * 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n\ * factor the matrix A (after equilibration if FACT = 'E') as\n\ * A = U**H* U, if UPLO = 'U', or\n\ * A = L * L**H, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is a lower triangular\n\ * matrix.\n\ *\n\ * 3. If the leading i-by-i principal minor is not positive definite,\n\ * then the routine returns with INFO = i. Otherwise, the factored\n\ * form of A is used to estimate the condition number of the matrix\n\ * A. If the reciprocal of the condition number is less than machine\n\ * precision, INFO = N+1 is returned as a warning, but the routine\n\ * still goes on to solve for X and compute error bounds as\n\ * described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(S) so that it solves the original system before\n\ * equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AF contains the factored form of A.\n\ * If EQUED = 'Y', the matrix A has been equilibrated\n\ * with scaling factors given by S. A and AF will not\n\ * be modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AF and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the Hermitian matrix A, except if FACT = 'F' and\n\ * EQUED = 'Y', then A must contain the equilibrated matrix\n\ * diag(S)*A*diag(S). If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced. A is not modified if\n\ * FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n\ *\n\ * On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n\ * diag(S)*A*diag(S).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input or output) COMPLEX array, dimension (LDAF,N)\n\ * If FACT = 'F', then AF is an input argument and on entry\n\ * contains the triangular factor U or L from the Cholesky\n\ * factorization A = U**H*U or A = L*L**H, in the same storage\n\ * format as A. If EQUED .ne. 'N', then AF is the factored form\n\ * of the equilibrated matrix diag(S)*A*diag(S).\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U**H*U or A = L*L**H of the original\n\ * matrix A.\n\ *\n\ * If FACT = 'E', then AF is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U**H*U or A = L*L**H of the equilibrated\n\ * matrix A (see the description of A for the form of the\n\ * equilibrated matrix).\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'Y': Equilibration was done, i.e., A has been replaced by\n\ * diag(S) * A * diag(S).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * S (input or output) REAL array, dimension (N)\n\ * The scale factors for A; not accessed if EQUED = 'N'. S is\n\ * an input argument if FACT = 'F'; otherwise, S is an output\n\ * argument. If FACT = 'F' and EQUED = 'Y', each element of S\n\ * must be positive.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS righthand side matrix B.\n\ * On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n\ * B is overwritten by diag(S) * B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n\ * the original system of equations. Note that if EQUED = 'Y',\n\ * A and B are modified on exit, and the solution to the\n\ * equilibrated system is inv(diag(S))*X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A after equilibration (if done). If RCOND is less than the\n\ * machine precision (in particular, if RCOND = 0), the matrix\n\ * is singular to working precision. This condition is\n\ * indicated by a return code of INFO > 0.\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\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, and i is\n\ * <= N: the leading minor of order i of A is\n\ * not positive definite, so the factorization\n\ * could not be completed, and the solution has not\n\ * been computed. RCOND = 0 is returned.\n\ * = N+1: U is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zposv0000644000175000017500000000707212502223526016377 0ustar uwabamiuwabami--- :name: zposv :md5sum: e38d6624ec2ed6919290514116fa9a0d :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPOSV computes the solution to a complex system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N Hermitian positive definite matrix and X and B\n\ * are N-by-NRHS matrices.\n\ *\n\ * The Cholesky decomposition is used to factor A as\n\ * A = U**H* U, if UPLO = 'U', or\n\ * A = L * L**H, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is a lower triangular\n\ * matrix. The factored form of A is then used to solve the system of\n\ * equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the factor U or L from the Cholesky\n\ * factorization A = U**H*U or A = L*L**H.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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 leading minor of order i of A is not\n\ * positive definite, so the factorization could not be\n\ * completed, and the solution has not been computed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZPOTRF, ZPOTRS\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slaed60000644000175000017500000000604012502223526016366 0ustar uwabamiuwabami--- :name: slaed6 :md5sum: 13a1e6df9b21c8b69ce9525581404001 :category: :subroutine :arguments: - kniter: :type: integer :intent: input - orgati: :type: logical :intent: input - rho: :type: real :intent: input - d: :type: real :intent: input :dims: - "3" - z: :type: real :intent: input :dims: - "3" - finit: :type: real :intent: input - tau: :type: real :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAED6 computes the positive or negative root (closest to the origin)\n\ * of\n\ * z(1) z(2) z(3)\n\ * f(x) = rho + --------- + ---------- + ---------\n\ * d(1)-x d(2)-x d(3)-x\n\ *\n\ * It is assumed that\n\ *\n\ * if ORGATI = .true. the root is between d(2) and d(3);\n\ * otherwise it is between d(1) and d(2)\n\ *\n\ * This routine will be called by SLAED4 when necessary. In most cases,\n\ * the root sought is the smallest in magnitude, though it might not be\n\ * in some extremely rare situations.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * KNITER (input) INTEGER\n\ * Refer to SLAED4 for its significance.\n\ *\n\ * ORGATI (input) LOGICAL\n\ * If ORGATI is true, the needed root is between d(2) and\n\ * d(3); otherwise it is between d(1) and d(2). See\n\ * SLAED4 for further details.\n\ *\n\ * RHO (input) REAL \n\ * Refer to the equation f(x) above.\n\ *\n\ * D (input) REAL array, dimension (3)\n\ * D satisfies d(1) < d(2) < d(3).\n\ *\n\ * Z (input) REAL array, dimension (3)\n\ * Each of the elements in z must be positive.\n\ *\n\ * FINIT (input) REAL \n\ * The value of f at 0. It is more accurate than the one\n\ * evaluated inside this routine (if someone wants to do\n\ * so).\n\ *\n\ * TAU (output) REAL \n\ * The root of the equation f(x).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * > 0: if INFO = 1, failure to converge\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * 30/06/99: Based on contributions by\n\ * Ren-Cang Li, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ *\n\ * 10/02/03: This version has a few statements commented out for thread safety\n\ * (machine parameters are computed on each entry). SJH.\n\ *\n\ * 05/10/06: Modified from a new version of Ren-Cang Li, use\n\ * Gragg-Thornton-Warner cubic convergent scheme for better stability.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsyev0000644000175000017500000000663412502223526016353 0ustar uwabamiuwabami--- :name: dsyev :md5sum: b35bf3f73e7855142219b77369a0d2cf :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 3*n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSYEV computes all eigenvalues and, optionally, eigenvectors of a\n\ * real symmetric matrix A.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of A contains the\n\ * upper triangular part of the matrix A. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of A contains\n\ * the lower triangular part of the matrix A.\n\ * On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n\ * orthonormal eigenvectors of the matrix A.\n\ * If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n\ * or the upper triangle (if UPLO='U') of A, including the\n\ * diagonal, is destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\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 length of the array WORK. LWORK >= max(1,3*N-1).\n\ * For optimal efficiency, LWORK >= (NB+2)*N,\n\ * where NB is the blocksize for DSYTRD returned by ILAENV.\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 algorithm failed to converge; i\n\ * off-diagonal elements of an intermediate tridiagonal\n\ * form did not converge to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgelsx0000644000175000017500000001230212502223526016522 0ustar uwabamiuwabami--- :name: zgelsx :md5sum: e5aa06fa11b4cff251513549dfaa24c8 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - rcond: :type: doublereal :intent: input - rank: :type: integer :intent: output - work: :type: doublecomplex :intent: workspace :dims: - MIN(m,n) + MAX(n,2*(MIN(m,n))+nrhs) - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This routine is deprecated and has been replaced by routine ZGELSY.\n\ *\n\ * ZGELSX computes the minimum-norm solution to a complex linear least\n\ * squares problem:\n\ * minimize || A * X - B ||\n\ * using a complete orthogonal factorization of A. A is an M-by-N\n\ * matrix which may be rank-deficient.\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\ * The routine first computes a QR factorization with column pivoting:\n\ * A * P = Q * [ R11 R12 ]\n\ * [ 0 R22 ]\n\ * with R11 defined as the largest leading submatrix whose estimated\n\ * condition number is less than 1/RCOND. The order of R11, RANK,\n\ * is the effective rank of A.\n\ *\n\ * Then, R22 is considered to be negligible, and R12 is annihilated\n\ * by unitary transformations from the right, arriving at the\n\ * complete orthogonal factorization:\n\ * A * P = Q * [ T11 0 ] * Z\n\ * [ 0 0 ]\n\ * The minimum-norm solution is then\n\ * X = P * Z' [ inv(T11)*Q1'*B ]\n\ * [ 0 ]\n\ * where Q1 consists of the first RANK columns of 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\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of\n\ * columns of matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, A has been overwritten by details of its\n\ * complete orthogonal factorization.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the M-by-NRHS right hand side matrix B.\n\ * On exit, the N-by-NRHS solution matrix X.\n\ * If m >= n and RANK = n, the residual sum-of-squares for\n\ * the solution in the i-th column is given by the sum of\n\ * squares of elements N+1:M in that column.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,M,N).\n\ *\n\ * JPVT (input/output) INTEGER array, dimension (N)\n\ * On entry, if JPVT(i) .ne. 0, the i-th column of A is an\n\ * initial column, otherwise it is a free column. Before\n\ * the QR factorization of A, all initial columns are\n\ * permuted to the leading positions; only the remaining\n\ * free columns are moved as a result of column pivoting\n\ * during the factorization.\n\ * On exit, if JPVT(i) = k, then the i-th column of A*P\n\ * was the k-th column of A.\n\ *\n\ * RCOND (input) DOUBLE PRECISION\n\ * RCOND is used to determine the effective rank of A, which\n\ * is defined as the order of the largest leading triangular\n\ * submatrix R11 in the QR factorization with pivoting of A,\n\ * whose estimated condition number < 1/RCOND.\n\ *\n\ * RANK (output) INTEGER\n\ * The effective rank of A, i.e., the order of the submatrix\n\ * R11. This is the same as the order of the submatrix T11\n\ * in the complete orthogonal factorization of A.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension\n\ * (min(M,N) + max( N, 2*min(M,N)+NRHS )),\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clartv0000644000175000017500000000423512502223525016506 0ustar uwabamiuwabami--- :name: clartv :md5sum: 66385b4b24372bfb5f9f2668f63301e3 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - y: :type: complex :intent: input/output :dims: - 1+(n-1)*incy - incy: :type: integer :intent: input - c: :type: real :intent: input :dims: - 1+(n-1)*incc - s: :type: complex :intent: input :dims: - 1+(n-1)*incc - incc: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE CLARTV( N, X, INCX, Y, INCY, C, S, INCC )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLARTV applies a vector of complex plane rotations with real cosines\n\ * to elements of the complex vectors x and y. For i = 1,2,...,n\n\ *\n\ * ( x(i) ) := ( c(i) s(i) ) ( x(i) )\n\ * ( y(i) ) ( -conjg(s(i)) c(i) ) ( y(i) )\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of plane rotations to be applied.\n\ *\n\ * X (input/output) COMPLEX array, dimension (1+(N-1)*INCX)\n\ * The vector x.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between elements of X. INCX > 0.\n\ *\n\ * Y (input/output) COMPLEX array, dimension (1+(N-1)*INCY)\n\ * The vector y.\n\ *\n\ * INCY (input) INTEGER\n\ * The increment between elements of Y. INCY > 0.\n\ *\n\ * C (input) REAL array, dimension (1+(N-1)*INCC)\n\ * The cosines of the plane rotations.\n\ *\n\ * S (input) COMPLEX array, dimension (1+(N-1)*INCC)\n\ * The sines of the plane rotations.\n\ *\n\ * INCC (input) INTEGER\n\ * The increment between elements of C and S. INCC > 0.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, IC, IX, IY\n COMPLEX XI, YI\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC CONJG\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zlaed70000644000175000017500000001761512655767354016435 0ustar uwabamiuwabami--- :name: zlaed7 :md5sum: d4f753104c3d1ea76346b6c9c300455a :category: :subroutine :arguments: - n: :type: integer :intent: input - cutpnt: :type: integer :intent: input - qsiz: :type: integer :intent: input - tlvls: :type: integer :intent: input - curlvl: :type: integer :intent: input - curpbm: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - q: :type: doublecomplex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - rho: :type: doublereal :intent: input - indxq: :type: integer :intent: output :dims: - n - qstore: :type: doublereal :intent: input/output :dims: - pow(n,2)+1 - qptr: :type: integer :intent: input/output :dims: - n+2 - prmptr: :type: integer :intent: input :dims: - n*LG(n) - perm: :type: integer :intent: input :dims: - n*LG(n) - givptr: :type: integer :intent: input :dims: - n*LG(n) - givcol: :type: integer :intent: input :dims: - "2" - n*LG(n) - givnum: :type: doublereal :intent: input :dims: - "2" - n*LG(n) - work: :type: doublecomplex :intent: workspace :dims: - qsiz*n - rwork: :type: doublereal :intent: workspace :dims: - 3*n+2*qsiz*n - iwork: :type: integer :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZLAED7( N, CUTPNT, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, LDQ, RHO, INDXQ, QSTORE, QPTR, PRMPTR, PERM, GIVPTR, GIVCOL, GIVNUM, WORK, RWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAED7 computes the updated eigensystem of a diagonal\n\ * matrix after modification by a rank-one symmetric matrix. This\n\ * routine is used only for the eigenproblem which requires all\n\ * eigenvalues and optionally eigenvectors of a dense or banded\n\ * Hermitian matrix that has been reduced to tridiagonal form.\n\ *\n\ * T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)\n\ *\n\ * where Z = Q'u, u is a vector of length N with ones in the\n\ * CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.\n\ *\n\ * The eigenvectors of the original matrix are stored in Q, and the\n\ * eigenvalues are in D. The algorithm consists of three stages:\n\ *\n\ * The first stage consists of deflating the size of the problem\n\ * when there are multiple eigenvalues or if there is a zero in\n\ * the Z vector. For each such occurrence the dimension of the\n\ * secular equation problem is reduced by one. This stage is\n\ * performed by the routine DLAED2.\n\ *\n\ * The second stage consists of calculating the updated\n\ * eigenvalues. This is done by finding the roots of the secular\n\ * equation via the routine DLAED4 (as called by SLAED3).\n\ * This routine also calculates the eigenvectors of the current\n\ * problem.\n\ *\n\ * The final stage consists of computing the updated eigenvectors\n\ * directly using the updated eigenvalues. The eigenvectors for\n\ * the current problem are multiplied with the eigenvectors from\n\ * the overall problem.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The dimension of the symmetric tridiagonal matrix. N >= 0.\n\ *\n\ * CUTPNT (input) INTEGER\n\ * Contains the location of the last eigenvalue in the leading\n\ * sub-matrix. min(1,N) <= CUTPNT <= N.\n\ *\n\ * QSIZ (input) INTEGER\n\ * The dimension of the unitary matrix used to reduce\n\ * the full matrix to tridiagonal form. QSIZ >= N.\n\ *\n\ * TLVLS (input) INTEGER\n\ * The total number of merging levels in the overall divide and\n\ * conquer tree.\n\ *\n\ * CURLVL (input) INTEGER\n\ * The current level in the overall merge routine,\n\ * 0 <= curlvl <= tlvls.\n\ *\n\ * CURPBM (input) INTEGER\n\ * The current problem in the current level in the overall\n\ * merge routine (counting from upper left to lower right).\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the eigenvalues of the rank-1-perturbed matrix.\n\ * On exit, the eigenvalues of the repaired matrix.\n\ *\n\ * Q (input/output) COMPLEX*16 array, dimension (LDQ,N)\n\ * On entry, the eigenvectors of the rank-1-perturbed matrix.\n\ * On exit, the eigenvectors of the repaired tridiagonal matrix.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N).\n\ *\n\ * RHO (input) DOUBLE PRECISION\n\ * Contains the subdiagonal element used to create the rank-1\n\ * modification.\n\ *\n\ * INDXQ (output) INTEGER array, dimension (N)\n\ * This contains the permutation which will reintegrate the\n\ * subproblem just solved back into sorted order,\n\ * ie. D( INDXQ( I = 1, N ) ) will be in ascending order.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (4*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array,\n\ * dimension (3*N+2*QSIZ*N)\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (QSIZ*N)\n\ *\n\ * QSTORE (input/output) DOUBLE PRECISION array, dimension (N**2+1)\n\ * Stores eigenvectors of submatrices encountered during\n\ * divide and conquer, packed together. QPTR points to\n\ * beginning of the submatrices.\n\ *\n\ * QPTR (input/output) INTEGER array, dimension (N+2)\n\ * List of indices pointing to beginning of submatrices stored\n\ * in QSTORE. The submatrices are numbered starting at the\n\ * bottom left of the divide and conquer tree, from left to\n\ * right and bottom to top.\n\ *\n\ * PRMPTR (input) INTEGER array, dimension (N lg N)\n\ * Contains a list of pointers which indicate where in PERM a\n\ * level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)\n\ * indicates the size of the permutation and also the size of\n\ * the full, non-deflated problem.\n\ *\n\ * PERM (input) INTEGER array, dimension (N lg N)\n\ * Contains the permutations (from deflation and sorting) to be\n\ * applied to each eigenblock.\n\ *\n\ * GIVPTR (input) INTEGER array, dimension (N lg N)\n\ * Contains a list of pointers which indicate where in GIVCOL a\n\ * level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)\n\ * indicates the number of Givens rotations.\n\ *\n\ * GIVCOL (input) INTEGER array, dimension (2, N lg N)\n\ * Each pair of numbers indicates a pair of columns to take place\n\ * in a Givens rotation.\n\ *\n\ * GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N)\n\ * Each number indicates the S value to be used in the\n\ * corresponding Givens rotation.\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 = 1, an eigenvalue did not converge\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER COLTYP, CURR, I, IDLMDA, INDX,\n $ INDXC, INDXP, IQ, IW, IZ, K, N1, N2, PTR\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DLAED9, DLAEDA, DLAMRG, XERBLA, ZLACRM, ZLAED8\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slarscl20000644000175000017500000000300012502223526016726 0ustar uwabamiuwabami--- :name: slarscl2 :md5sum: fa79e33c68ca79f44f598209626415d8 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - m - x: :type: real :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE SLARSCL2 ( M, N, D, X, LDX )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLARSCL2 performs a reciprocal diagonal scaling on an vector:\n\ * x <-- inv(D) * x\n\ * where the diagonal matrix D is stored as a vector.\n\ *\n\ * Eventually to be replaced by BLAS_sge_diag_scale in the new BLAS\n\ * standard.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of D and X. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of D and X. N >= 0.\n\ *\n\ * D (input) REAL array, length M\n\ * Diagonal matrix D, stored as a vector of length M.\n\ *\n\ * X (input/output) REAL array, dimension (LDX,N)\n\ * On entry, the vector X to be scaled by D.\n\ * On exit, the scaled vector.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the vector X. LDX >= 0.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zlangt0000644000175000017500000000431212502223526016507 0ustar uwabamiuwabami--- :name: zlangt :md5sum: 9e28b2c5225e24d990e7ee9a95247313 :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - dl: :type: doublecomplex :intent: input :dims: - n-1 - d: :type: doublecomplex :intent: input :dims: - n - du: :type: doublecomplex :intent: input :dims: - n-1 :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION ZLANGT( NORM, N, DL, D, DU )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLANGT returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * complex tridiagonal matrix A.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * ZLANGT returns the value\n\ *\n\ * ZLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in ZLANGT as described\n\ * above.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, ZLANGT is\n\ * set to zero.\n\ *\n\ * DL (input) COMPLEX*16 array, dimension (N-1)\n\ * The (n-1) sub-diagonal elements of A.\n\ *\n\ * D (input) COMPLEX*16 array, dimension (N)\n\ * The diagonal elements of A.\n\ *\n\ * DU (input) COMPLEX*16 array, dimension (N-1)\n\ * The (n-1) super-diagonal elements of A.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgejsv0000644000175000017500000022005712502223526016517 0ustar uwabamiuwabami--- :name: sgejsv :md5sum: 014d15d64a56599ae987928ca94d6d5e :category: :subroutine :arguments: - joba: :type: char :intent: input - jobu: :type: char :intent: input - jobv: :type: char :intent: input - jobr: :type: char :intent: input - jobt: :type: char :intent: input - jobp: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - sva: :type: real :intent: output :dims: - n - u: :type: real :intent: output :dims: - ldu - n - ldu: :type: integer :intent: input - v: :type: real :intent: output :dims: - ldv - n - ldv: :type: integer :intent: input - work: :type: real :intent: input/output :dims: - lwork - lwork: :type: integer :intent: input :option: true :default: "(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)" - iwork: :type: integer :intent: output :dims: - m+3*n - info: :type: integer :intent: output :substitutions: ldu: "(lsame_(&jobu,\"U\")||lsame_(&jobu,\"F\")||lsame_(&jobu,\"W\")) ? m : 1" ldv: "(lsame_(&jobu,\"U\")||lsame_(&jobu,\"F\")||lsame_(&jobu,\"W\")) ? n : 1" :fortran_help: " SUBROUTINE SGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, M, N, A, LDA, SVA, U, LDU, V, LDV, WORK, LWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ * SGEJSV 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 SQRT(BIG), BIG=SLAMCH('O'), then JOBR issues\n\ * the licence to kill columns of A whose norm in c*A is less than\n\ * SQRT(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 SGESVJ.\n\ * = 'R': RESTRICTED range for sigma(c*A) is [SQRT(SFMIN), SQRT(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 SGESVJ.\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) REAL 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) REAL 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) REAL 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) REAL 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) REAL 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 SQRT(||(R^t * R)^(-1)||_1).\n\ * It is computed using SPOCON. 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 : SGEJSV 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\ * SGEJSV 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 SGEJSV 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 (SGEJSV) 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 (SGESVJ) 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 SGEJSV 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 SGEJSV 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 REAL ZERO, ONE\n PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )\n\ * ..\n\ * .. Local Scalars ..\n REAL 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 ABS, ALOG, AMAX1, AMIN1, FLOAT,\n & MAX0, MIN0, NINT, SIGN, SQRT\n\ * ..\n\ * .. External Functions ..\n REAL SLAMCH, SNRM2\n INTEGER ISAMAX\n LOGICAL LSAME\n EXTERNAL ISAMAX, LSAME, SLAMCH, SNRM2\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SCOPY, SGELQF, SGEQP3, SGEQRF, SLACPY, SLASCL,\n & SLASET, SLASSQ, SLASWP, SORGQR, SORMLQ,\n & SORMQR, SPOCON, SSCAL, SSWAP, STRSM, XERBLA\n\ *\n EXTERNAL SGESVJ\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( 'SGEJSV', - 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 SLAMCH() does not fail on the target architecture.\n\ *\n EPSLN = SLAMCH('Epsilon')\n SFMIN = SLAMCH('SafeMinimum')\n SMALL = SFMIN / EPSLN\n BIG = SLAMCH('O')\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 / SQRT(FLOAT(M)*FLOAT(N))\n NOSCAL = .TRUE.\n GOSCAL = .TRUE.\n DO 1874 p = 1, N\n AAPP = ZERO\n AAQQ = ONE\n CALL SLASSQ( M, A(1,p), 1, AAPP, AAQQ )\n IF ( AAPP .GT. BIG ) THEN\n INFO = - 9\n CALL XERBLA( 'SGEJSV', -INFO )\n RETURN\n END IF\n AAQQ = SQRT(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 SSCAL( 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 = AMAX1( AAPP, SVA(p) )\n IF ( SVA(p) .NE. ZERO ) AAQQ = AMIN1( 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 SLASET( 'G', M, N1, ZERO, ONE, U, LDU )\n IF ( RSVEC ) CALL SLASET( '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 SLASCL( 'G',0,0,SVA(1),SCALEM, M,1,A(1,1),LDA,IERR )\n CALL SLACPY( '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 SGEQRF( M, N, U,LDU, WORK, WORK(N+1),LWORK-N,IERR )\n CALL SORGQR( M,N1,1, U,LDU,WORK,WORK(N+1),LWORK-N,IERR )\n CALL SCOPY( 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 SLASSQ( N, A(p,1), LDA, XSC, TEMP1 )\n\ * SLASSQ 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*SQRT(TEMP1))\n AATMAX = AMAX1( AATMAX, WORK(N+p) )\n IF (WORK(N+p) .NE. ZERO) AATMIN = AMIN1(AATMIN,WORK(N+p))\n 1950 CONTINUE\n ELSE\n DO 1904 p = 1, M\n WORK(M+N+p) = SCALEM*ABS( A(p,ISAMAX(N,A(p,1),LDA)) )\n AATMAX = AMAX1( AATMAX, WORK(M+N+p) )\n AATMIN = AMIN1( 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 SLASSQ( 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 * ALOG(BIG1)\n 1113 CONTINUE\n ENTRA = - ENTRA / ALOG(FLOAT(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 * ALOG(BIG1)\n 1114 CONTINUE\n ENTRAT = - ENTRAT / ALOG(FLOAT(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 SQRT(BIG) -- the matrix is scaled so that its maximal column\n\ * has Euclidean norm equal to SQRT(BIG/N). The only reason to keep\n\ * SQRT(BIG) instead of BIG is the fact that SGEJSV 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 SGESVJ will compute them. So, in that case,\n\ * one should use SGESVJ instead of SGEJSV.\n\ *\n BIG1 = SQRT( BIG )\n TEMP1 = SQRT( BIG / FLOAT(N) )\n\ *\n CALL SLASCL( '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 SLASCL( '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. SQRT(BIG)/SQRT(SFMIN).\n XSC = SQRT( 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. SQRT(BIG/N) * EPSLN / SFMIN,\n\ * as a precaution measure, the full SVD is computed using SGESVJ\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.SQRT(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 SLASET( '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 = ISAMAX( 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 SLASWP( 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 SGEQP3 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 SGEQP3 improves overal performance of SGEJSV.\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 SGEQP3( 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 SGEJSV 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 = SQRT(FLOAT(N))*EPSLN\n DO 3001 p = 2, N\n IF ( ABS(A(p,p)) .GE. (TEMP1*ABS(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 = SQRT(SFMIN)\n DO 3401 p = 2, N\n IF ( ( ABS(A(p,p)) .LT. (EPSLN*ABS(A(p-1,p-1))) ) .OR.\n & ( ABS(A(p,p)) .LT. SMALL ) .OR.\n & ( L2KILL .AND. (ABS(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 = SQRT(SFMIN)\n DO 3301 p = 2, N\n IF ( ( ABS(A(p,p)) .LT. SMALL ) .OR.\n & ( L2KILL .AND. (ABS(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 = ABS(A(p,p)) / SVA(IWORK(p))\n MAXPRJ = AMIN1( MAXPRJ, TEMP1 )\n 3051 CONTINUE\n IF ( MAXPRJ**2 .GE. ONE - FLOAT(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 SLACPY( 'U', N, N, A, LDA, V, LDV )\n DO 3053 p = 1, N\n TEMP1 = SVA(IWORK(p))\n CALL SSCAL( p, ONE/TEMP1, V(1,p), 1 )\n 3053 CONTINUE\n CALL SPOCON( '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 SLACPY( 'U', N, N, A, LDA, U, LDU )\n DO 3054 p = 1, N\n TEMP1 = SVA(IWORK(p))\n CALL SSCAL( p, ONE/TEMP1, U(1,p), 1 )\n 3054 CONTINUE\n CALL SPOCON( 'U', N, U, LDU, ONE, TEMP1,\n & WORK(N+1), IWORK(2*N+M+1), IERR )\n ELSE\n CALL SLACPY( 'U', N, N, A, LDA, WORK(N+1), N )\n DO 3052 p = 1, N\n TEMP1 = SVA(IWORK(p))\n CALL SSCAL( 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 SPOCON( '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 / SQRT(TEMP1)\n\ * SCONDA is an estimate of SQRT(||(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. ( ABS( A(1,1)/A(NR,NR) ) .GT. SQRT(BIG1) )\n\ * If there is no violent scaling, artificial perturbation is not needed.\n\ *\n\ * Phase 3:\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 SCOPY( 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 = SQRT(SMALL)\n XSC = EPSLN / FLOAT(N)\n DO 4947 q = 1, NR\n TEMP1 = XSC*ABS(A(q,q))\n DO 4949 p = 1, N\n IF ( ( (p.GT.q) .AND. (ABS(A(p,q)).LE.TEMP1) )\n & .OR. ( p .LT. q ) )\n & A(p,q) = SIGN( TEMP1, A(p,q) )\n 4949 CONTINUE\n 4947 CONTINUE\n ELSE\n CALL SLASET( '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 SGEQRF( 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 SCOPY( 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 = SQRT(SMALL)\n XSC = EPSLN / FLOAT(N)\n DO 1947 q = 1, NR\n TEMP1 = XSC*ABS(A(q,q))\n DO 1949 p = 1, NR\n IF ( ( (p.GT.q) .AND. (ABS(A(p,q)).LE.TEMP1) )\n & .OR. ( p .LT. q ) )\n & A(p,q) = SIGN( TEMP1, A(p,q) )\n 1949 CONTINUE\n 1947 CONTINUE\n ELSE\n CALL SLASET( '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 SGESVJ( 'L', 'NoU', 'NoV', NR, NR, A, LDA, SVA,\n & N, V, LDV, WORK, LWORK, INFO )\n\ *\n SCALEM = WORK(1)\n NUMRANK = NINT(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 SCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 )\n 1998 CONTINUE\n CALL SLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n\ *\n CALL SGESVJ( 'L','U','N', N, NR, V,LDV, SVA, NR, A,LDA,\n & WORK, LWORK, INFO )\n SCALEM = WORK(1)\n NUMRANK = NINT(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 SLASET( 'Lower', NR-1, NR-1, ZERO, ZERO, A(2,1), LDA )\n CALL SGELQF( NR, N, A, LDA, WORK, WORK(N+1), LWORK-N, IERR)\n CALL SLACPY( 'Lower', NR, NR, A, LDA, V, LDV )\n CALL SLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n CALL SGEQRF( NR, NR, V, LDV, WORK(N+1), WORK(2*N+1),\n & LWORK-2*N, IERR )\n DO 8998 p = 1, NR\n CALL SCOPY( NR-p+1, V(p,p), LDV, V(p,p), 1 )\n 8998 CONTINUE\n CALL SLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n\ *\n CALL SGESVJ( 'Lower', 'U','N', NR, NR, V,LDV, SVA, NR, U,\n & LDU, WORK(N+1), LWORK, INFO )\n SCALEM = WORK(N+1)\n NUMRANK = NINT(WORK(N+2))\n IF ( NR .LT. N ) THEN\n CALL SLASET( 'A',N-NR, NR, ZERO,ZERO, V(NR+1,1), LDV )\n CALL SLASET( 'A',NR, N-NR, ZERO,ZERO, V(1,NR+1), LDV )\n CALL SLASET( 'A',N-NR,N-NR,ZERO,ONE, V(NR+1,NR+1), LDV )\n END IF\n\ *\n CALL SORMLQ( '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 SCOPY( N, V(p,1), LDV, A(IWORK(p),1), LDA )\n 8991 CONTINUE\n CALL SLACPY( 'All', N, N, A, LDA, V, LDV )\n\ *\n IF ( TRANSP ) THEN\n CALL SLACPY( '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 SCOPY( N-p+1, A(p,p), LDA, U(p,p), 1 )\n 1965 CONTINUE\n CALL SLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU )\n\ *\n CALL SGEQRF( 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 SCOPY( NR-p, U(p,p+1), LDU, U(p+1,p), 1 )\n 1967 CONTINUE\n CALL SLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU )\n\ *\n CALL SGESVJ( '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 = NINT(WORK(N+2))\n\ *\n IF ( NR .LT. M ) THEN\n CALL SLASET( 'A', M-NR, NR,ZERO, ZERO, U(NR+1,1), LDU )\n IF ( NR .LT. N1 ) THEN\n CALL SLASET( 'A',NR, N1-NR, ZERO, ZERO, U(1,NR+1), LDU )\n CALL SLASET( 'A',M-NR,N1-NR,ZERO,ONE,U(NR+1,NR+1), LDU )\n END IF\n END IF\n\ *\n CALL SORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U,\n & LDU, WORK(N+1), LWORK-N, IERR )\n\ *\n IF ( ROWPIV )\n & CALL SLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 )\n\ *\n DO 1974 p = 1, N1\n XSC = ONE / SNRM2( M, U(1,p), 1 )\n CALL SSCAL( M, XSC, U(1,p), 1 )\n 1974 CONTINUE\n\ *\n IF ( TRANSP ) THEN\n CALL SLACPY( '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 SGEJSV.\n\ *\n DO 1968 p = 1, NR\n CALL SCOPY( 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 = SQRT(SMALL)\n DO 2969 q = 1, NR\n TEMP1 = XSC*ABS( V(q,q) )\n DO 2968 p = 1, N\n IF ( ( p .GT. q ) .AND. ( ABS(V(p,q)) .LE. TEMP1 )\n & .OR. ( p .LT. q ) )\n & V(p,q) = SIGN( 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 SLASET( '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 SLACPY( 'L', NR, NR, V, LDV, WORK(2*N+1), NR )\n DO 3950 p = 1, NR\n TEMP1 = SNRM2(NR-p+1,WORK(2*N+(p-1)*NR+p),1)\n CALL SSCAL(NR-p+1,ONE/TEMP1,WORK(2*N+(p-1)*NR+p),1)\n 3950 CONTINUE\n CALL SPOCON('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 / SQRT(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. FLOAT(N)\n\ * more conservative <=> CONDR1 .LT. SQRT(FLOAT(N))\n\ *\n COND_OK = SQRT(FLOAT(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 SGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1),\n & LWORK-2*N, IERR )\n\ *\n IF ( L2PERT ) THEN\n XSC = SQRT(SMALL)/EPSLN\n DO 3959 p = 2, NR\n DO 3958 q = 1, p - 1\n TEMP1 = XSC * AMIN1(ABS(V(p,p)),ABS(V(q,q)))\n IF ( ABS(V(q,p)) .LE. TEMP1 )\n & V(q,p) = SIGN( TEMP1, V(q,p) )\n 3958 CONTINUE\n 3959 CONTINUE\n END IF\n\ *\n IF ( NR .NE. N )\n\ * .. save ...\n & CALL SLACPY( '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 SCOPY( 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 SGEQP3\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 SGEQP3( N, NR, V, LDV, IWORK(N+1), WORK(N+1),\n & WORK(2*N+1), LWORK-2*N, IERR )\n\ ** CALL SGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1),\n\ ** & LWORK-2*N, IERR )\n IF ( L2PERT ) THEN\n XSC = SQRT(SMALL)\n DO 3969 p = 2, NR\n DO 3968 q = 1, p - 1\n TEMP1 = XSC * AMIN1(ABS(V(p,p)),ABS(V(q,q)))\n IF ( ABS(V(q,p)) .LE. TEMP1 )\n & V(q,p) = SIGN( TEMP1, V(q,p) )\n 3968 CONTINUE\n 3969 CONTINUE\n END IF\n\ *\n CALL SLACPY( 'A', N, NR, V, LDV, WORK(2*N+1), N )\n\ *\n IF ( L2PERT ) THEN\n XSC = SQRT(SMALL)\n DO 8970 p = 2, NR\n DO 8971 q = 1, p - 1\n TEMP1 = XSC * AMIN1(ABS(V(p,p)),ABS(V(q,q)))\n V(p,q) = - SIGN( TEMP1, V(q,p) )\n 8971 CONTINUE\n 8970 CONTINUE\n ELSE\n CALL SLASET( '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 SGELQF( 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 SLACPY( 'L',NR,NR,V,LDV,WORK(2*N+N*NR+NR+1),NR )\n DO 4950 p = 1, NR\n TEMP1 = SNRM2( p, WORK(2*N+N*NR+NR+p), NR )\n CALL SSCAL( p, ONE/TEMP1, WORK(2*N+N*NR+NR+p), NR )\n 4950 CONTINUE\n CALL SPOCON( '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 / SQRT(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 SLACPY( '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 = SQRT(SMALL)\n DO 4968 q = 2, NR\n TEMP1 = XSC * V(q,q)\n DO 4969 p = 1, q - 1\n\ * V(p,q) = - SIGN( TEMP1, V(q,p) )\n V(p,q) = - SIGN( TEMP1, V(p,q) )\n 4969 CONTINUE\n 4968 CONTINUE\n ELSE\n CALL SLASET( '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 SGESVJ( '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 = NINT(WORK(2*N+N*NR+NR+2))\n DO 3970 p = 1, NR\n CALL SCOPY( NR, V(1,p), 1, U(1,p), 1 )\n CALL SSCAL( 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 SGESVJ, premultiplied with the orthogonal matrix\n\ * from the second QR factorization.\n CALL STRSM( '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 SGESVJ. The Q-factor from the second QR\n\ * factorization is then built in explicitly.\n CALL STRSM('L','U','T','N',NR,NR,ONE,WORK(2*N+1),\n & N,V,LDV)\n IF ( NR .LT. N ) THEN\n CALL SLASET('A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV)\n CALL SLASET('A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV)\n CALL SLASET('A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV)\n END IF\n CALL SORMQR('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 SGESVJ( '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 = NINT(WORK(2*N+N*NR+NR+2))\n DO 3870 p = 1, NR\n CALL SCOPY( NR, V(1,p), 1, U(1,p), 1 )\n CALL SSCAL( NR, SVA(p), U(1,p), 1 )\n 3870 CONTINUE\n CALL STRSM('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 SLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV )\n CALL SLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV )\n CALL SLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV )\n END IF\n CALL SORMQR( '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 SGEJSV completes the task.\n\ * Compute the full SVD of L3 using SGESVJ with explicit\n\ * accumulation of Jacobi rotations.\n CALL SGESVJ( '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 = NINT(WORK(2*N+N*NR+NR+2))\n IF ( NR .LT. N ) THEN\n CALL SLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV )\n CALL SLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV )\n CALL SLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV )\n END IF\n CALL SORMQR( '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 SORMLQ( '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 = SQRT(FLOAT(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 / SNRM2( N, V(1,q), 1 )\n IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n & CALL SSCAL( 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 SLASET( 'A', M-NR, NR, ZERO, ZERO, U(NR+1,1), LDU )\n IF ( NR .LT. N1 ) THEN\n CALL SLASET('A',NR,N1-NR,ZERO,ZERO,U(1,NR+1),LDU)\n CALL SLASET('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 SORMQR( '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 = SQRT(FLOAT(M)) * EPSLN\n DO 1973 p = 1, NR\n XSC = ONE / SNRM2( M, U(1,p), 1 )\n IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n & CALL SSCAL( 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 SLASWP( 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 SLACPY( 'Upper', N, N, A, LDA, WORK(N+1), N )\n IF ( L2PERT ) THEN\n XSC = SQRT(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)=-SIGN(TEMP1,WORK(N+(p-1)*N+q))\n 5971 CONTINUE\n 5970 CONTINUE\n ELSE\n CALL SLASET( 'Lower',N-1,N-1,ZERO,ZERO,WORK(N+2),N )\n END IF\n\ *\n CALL SGESVJ( '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 = NINT(WORK(N+N*N+2))\n DO 6970 p = 1, N\n CALL SCOPY( N, WORK(N+(p-1)*N+1), 1, U(1,p), 1 )\n CALL SSCAL( N, SVA(p), WORK(N+(p-1)*N+1), 1 )\n 6970 CONTINUE\n\ *\n CALL STRSM( 'Left', 'Upper', 'NoTrans', 'No UD', N, N,\n & ONE, A, LDA, WORK(N+1), N )\n DO 6972 p = 1, N\n CALL SCOPY( N, WORK(N+p), N, V(IWORK(p),1), LDV )\n 6972 CONTINUE\n TEMP1 = SQRT(FLOAT(N))*EPSLN\n DO 6971 p = 1, N\n XSC = ONE / SNRM2( N, V(1,p), 1 )\n IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n & CALL SSCAL( 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 SLASET( 'A', M-N, N, ZERO, ZERO, U(N+1,1), LDU )\n IF ( N .LT. N1 ) THEN\n CALL SLASET( 'A',N, N1-N, ZERO, ZERO, U(1,N+1),LDU )\n CALL SLASET( 'A',M-N,N1-N, ZERO, ONE,U(N+1,N+1),LDU )\n END IF\n END IF\n CALL SORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U,\n & LDU, WORK(N+1), LWORK-N, IERR )\n TEMP1 = SQRT(FLOAT(M))*EPSLN\n DO 6973 p = 1, N1\n XSC = ONE / SNRM2( M, U(1,p), 1 )\n IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n & CALL SSCAL( M, XSC, U(1,p), 1 )\n 6973 CONTINUE\n\ *\n IF ( ROWPIV )\n & CALL SLASWP( 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 SCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 )\n 7968 CONTINUE\n\ *\n IF ( L2PERT ) THEN\n XSC = SQRT(SMALL/EPSLN)\n DO 5969 q = 1, NR\n TEMP1 = XSC*ABS( V(q,q) )\n DO 5968 p = 1, N\n IF ( ( p .GT. q ) .AND. ( ABS(V(p,q)) .LE. TEMP1 )\n & .OR. ( p .LT. q ) )\n & V(p,q) = SIGN( 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 SLASET( 'U', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n END IF\n\n CALL SGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1),\n & LWORK-2*N, IERR )\n CALL SLACPY( 'L', N, NR, V, LDV, WORK(2*N+1), N )\n\ *\n DO 7969 p = 1, NR\n CALL SCOPY( NR-p+1, V(p,p), LDV, U(p,p), 1 )\n 7969 CONTINUE\n\n IF ( L2PERT ) THEN\n XSC = SQRT(SMALL/EPSLN)\n DO 9970 q = 2, NR\n DO 9971 p = 1, q - 1\n TEMP1 = XSC * AMIN1(ABS(U(p,p)),ABS(U(q,q)))\n U(p,q) = - SIGN( TEMP1, U(q,p) )\n 9971 CONTINUE\n 9970 CONTINUE\n ELSE\n CALL SLASET('U', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU )\n END IF\n\n CALL SGESVJ( 'L', '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 = NINT(WORK(2*N+N*NR+2))\n\n IF ( NR .LT. N ) THEN\n CALL SLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV )\n CALL SLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV )\n CALL SLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV )\n END IF\n\n CALL SORMQR( '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 = SQRT(FLOAT(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 / SNRM2( N, V(1,q), 1 )\n IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n & CALL SSCAL( 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 SLASET( 'A', M-NR, NR, ZERO, ZERO, U(NR+1,1), LDU )\n IF ( NR .LT. N1 ) THEN\n CALL SLASET( 'A',NR, N1-NR, ZERO, ZERO, U(1,NR+1),LDU )\n CALL SLASET( 'A',M-NR,N1-NR, ZERO, ONE,U(NR+1,NR+1),LDU )\n END IF\n END IF\n\ *\n CALL SORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U,\n & LDU, WORK(N+1), LWORK-N, IERR )\n\ *\n IF ( ROWPIV )\n & CALL SLASWP( 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 SSWAP( 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 SLASCL( '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 SGEJSV\n\ * ..\n END\n\ *\n" ruby-lapack-1.7.2/dev/defs/spftri0000644000175000017500000001346612502223526016531 0ustar uwabamiuwabami--- :name: spftri :md5sum: 7350ee23c49766041a290bde8cbe7e2e :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPFTRI( TRANSR, UPLO, N, A, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPFTRI computes the inverse of a real (symmetric) positive definite\n\ * matrix A using the Cholesky factorization A = U**T*U or A = L*L**T\n\ * computed by SPFTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': The Normal TRANSR of RFP A is stored;\n\ * = 'T': The Transpose TRANSR of RFP A is stored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension ( N*(N+1)/2 )\n\ * On entry, the symmetric matrix A in RFP format. RFP format is\n\ * described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n\ * then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n\ * (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is\n\ * the transpose of RFP A as defined when\n\ * TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n\ * follows: If UPLO = 'U' the RFP A contains the nt elements of\n\ * upper packed A. If UPLO = 'L' the RFP A contains the elements\n\ * of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n\ * 'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n\ * is odd. See the Note below for more details.\n\ *\n\ * On exit, the symmetric inverse of the original matrix, in the\n\ * same storage format.\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,i) element of the factor U or L is\n\ * zero, and the inverse could not be computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * We first consider Rectangular Full Packed (RFP) Format when N is\n\ * even. We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * the transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * the transpose of the last three columns of AP lower.\n\ * This covers the case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 04 05 33 43 53\n\ * 13 14 15 00 44 54\n\ * 23 24 25 10 11 55\n\ * 33 34 35 20 21 22\n\ * 00 44 45 30 31 32\n\ * 01 11 55 40 41 42\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We then consider Rectangular Full Packed (RFP) Format when N is\n\ * odd. We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * the transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * the transpose of the last two columns of AP lower.\n\ * This covers the case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 03 04 00 33 43\n\ * 12 13 14 10 11 44\n\ * 22 23 24 20 21 22\n\ * 00 33 34 30 31 32\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlantr0000644000175000017500000000732412502223526016502 0ustar uwabamiuwabami--- :name: dlantr :md5sum: f11d9df4022a1ca2d33a5591fbe76955 :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? m : 0" :fortran_help: " DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, LDA, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLANTR returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * trapezoidal or triangular matrix A.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * DLANTR returns the value\n\ *\n\ * DLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in DLANTR as described\n\ * above.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the matrix A is upper or lower trapezoidal.\n\ * = 'U': Upper trapezoidal\n\ * = 'L': Lower trapezoidal\n\ * Note that A is triangular instead of trapezoidal if M = N.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * Specifies whether or not the matrix A has unit diagonal.\n\ * = 'N': Non-unit diagonal\n\ * = 'U': Unit diagonal\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A. M >= 0, and if\n\ * UPLO = 'U', M <= N. When M = 0, DLANTR is set to zero.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix A. N >= 0, and if\n\ * UPLO = 'L', N <= M. When N = 0, DLANTR is set to zero.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The trapezoidal matrix A (A is triangular if M = N).\n\ * If UPLO = 'U', the leading m by n upper trapezoidal part of\n\ * the array A contains the upper trapezoidal matrix, and the\n\ * strictly lower triangular part of A is not referenced.\n\ * If UPLO = 'L', the leading m by n lower trapezoidal part of\n\ * the array A contains the lower trapezoidal matrix, and the\n\ * strictly upper triangular part of A is not referenced. Note\n\ * that when DIAG = 'U', the diagonal elements of A are not\n\ * referenced and are assumed to be one.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(M,1).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n\ * referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssyev0000644000175000017500000000654612502223526016374 0ustar uwabamiuwabami--- :name: ssyev :md5sum: b3e09603e880a722d95069c7c92b63df :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 3*n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSYEV computes all eigenvalues and, optionally, eigenvectors of a\n\ * real symmetric matrix A.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA, N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of A contains the\n\ * upper triangular part of the matrix A. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of A contains\n\ * the lower triangular part of the matrix A.\n\ * On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n\ * orthonormal eigenvectors of the matrix A.\n\ * If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n\ * or the upper triangle (if UPLO='U') of A, including the\n\ * diagonal, is destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of the array WORK. LWORK >= max(1,3*N-1).\n\ * For optimal efficiency, LWORK >= (NB+2)*N,\n\ * where NB is the blocksize for SSYTRD returned by ILAENV.\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 algorithm failed to converge; i\n\ * off-diagonal elements of an intermediate tridiagonal\n\ * form did not converge to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slaed20000644000175000017500000001445512502223526016373 0ustar uwabamiuwabami--- :name: slaed2 :md5sum: e070f3045768b0a9fca4dcd7e04b36cc :category: :subroutine :arguments: - k: :type: integer :intent: output - n: :type: integer :intent: input - n1: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - q: :type: real :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - indxq: :type: integer :intent: input/output :dims: - n - rho: :type: real :intent: input/output - z: :type: real :intent: input :dims: - n - dlamda: :type: real :intent: output :dims: - n - w: :type: real :intent: output :dims: - n - q2: :type: real :intent: output :dims: - pow(n1,2)+pow(n-n1,2) - indx: :type: integer :intent: workspace :dims: - n - indxc: :type: integer :intent: output :dims: - n - indxp: :type: integer :intent: workspace :dims: - n - coltyp: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, Q2, INDX, INDXC, INDXP, COLTYP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAED2 merges the two sets of eigenvalues together into a single\n\ * sorted set. Then it tries to deflate the size of the problem.\n\ * There are two ways in which deflation can occur: when two or more\n\ * eigenvalues are close together or if there is a tiny entry in the\n\ * Z vector. For each such occurrence the order of the related secular\n\ * equation problem is reduced by one.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * K (output) INTEGER\n\ * The number of non-deflated eigenvalues, and the order of the\n\ * related secular equation. 0 <= K <=N.\n\ *\n\ * N (input) INTEGER\n\ * The dimension of the symmetric tridiagonal matrix. N >= 0.\n\ *\n\ * N1 (input) INTEGER\n\ * The location of the last eigenvalue in the leading sub-matrix.\n\ * min(1,N) <= N1 <= N/2.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, D contains the eigenvalues of the two submatrices to\n\ * be combined.\n\ * On exit, D contains the trailing (N-K) updated eigenvalues\n\ * (those which were deflated) sorted into increasing order.\n\ *\n\ * Q (input/output) REAL array, dimension (LDQ, N)\n\ * On entry, Q contains the eigenvectors of two submatrices in\n\ * the two square blocks with corners at (1,1), (N1,N1)\n\ * and (N1+1, N1+1), (N,N).\n\ * On exit, Q contains the trailing (N-K) updated eigenvectors\n\ * (those which were deflated) in its last N-K columns.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N).\n\ *\n\ * INDXQ (input/output) INTEGER array, dimension (N)\n\ * The permutation which separately sorts the two sub-problems\n\ * in D into ascending order. Note that elements in the second\n\ * half of this permutation must first have N1 added to their\n\ * values. Destroyed on exit.\n\ *\n\ * RHO (input/output) REAL\n\ * On entry, the off-diagonal element associated with the rank-1\n\ * cut which originally split the two submatrices which are now\n\ * being recombined.\n\ * On exit, RHO has been modified to the value required by\n\ * SLAED3.\n\ *\n\ * Z (input) REAL array, dimension (N)\n\ * On entry, Z contains the updating vector (the last\n\ * row of the first sub-eigenvector matrix and the first row of\n\ * the second sub-eigenvector matrix).\n\ * On exit, the contents of Z have been destroyed by the updating\n\ * process.\n\ *\n\ * DLAMDA (output) REAL array, dimension (N)\n\ * A copy of the first K eigenvalues which will be used by\n\ * SLAED3 to form the secular equation.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * The first k values of the final deflation-altered z-vector\n\ * which will be passed to SLAED3.\n\ *\n\ * Q2 (output) REAL array, dimension (N1**2+(N-N1)**2)\n\ * A copy of the first K eigenvectors which will be used by\n\ * SLAED3 in a matrix multiply (SGEMM) to solve for the new\n\ * eigenvectors.\n\ *\n\ * INDX (workspace) INTEGER array, dimension (N)\n\ * The permutation used to sort the contents of DLAMDA into\n\ * ascending order.\n\ *\n\ * INDXC (output) INTEGER array, dimension (N)\n\ * The permutation used to arrange the columns of the deflated\n\ * Q matrix into three groups: the first group contains non-zero\n\ * elements only at and above N1, the second contains\n\ * non-zero elements only below N1, and the third is dense.\n\ *\n\ * INDXP (workspace) INTEGER array, dimension (N)\n\ * The permutation used to place deflated values of D at the end\n\ * of the array. INDXP(1:K) points to the nondeflated D-values\n\ * and INDXP(K+1:N) points to the deflated eigenvalues.\n\ *\n\ * COLTYP (workspace/output) INTEGER array, dimension (N)\n\ * During execution, a label which will indicate which of the\n\ * following types a column in the Q2 matrix is:\n\ * 1 : non-zero in the upper half only;\n\ * 2 : dense;\n\ * 3 : non-zero in the lower half only;\n\ * 4 : deflated.\n\ * On exit, COLTYP(i) is the number of columns of type i,\n\ * for i=1 to 4 only.\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\ * Based on contributions by\n\ * Jeff Rutter, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ * Modified by Francoise Tisseur, University of Tennessee.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlaqsp0000644000175000017500000000541612502223526016530 0ustar uwabamiuwabami--- :name: zlaqsp :md5sum: 515183f69fcd0fff72e408ac43741f2e :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - s: :type: doublereal :intent: input :dims: - n - scond: :type: doublereal :intent: input - amax: :type: doublereal :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAQSP equilibrates a symmetric matrix A using the scaling factors\n\ * in the vector S.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, the equilibrated matrix: diag(S) * A * diag(S), in\n\ * the same storage format as A.\n\ *\n\ * S (input) DOUBLE PRECISION array, dimension (N)\n\ * The scale factors for A.\n\ *\n\ * SCOND (input) DOUBLE PRECISION\n\ * Ratio of the smallest S(i) to the largest S(i).\n\ *\n\ * AMAX (input) DOUBLE PRECISION\n\ * Absolute value of largest matrix entry.\n\ *\n\ * EQUED (output) CHARACTER*1\n\ * Specifies whether or not equilibration was done.\n\ * = 'N': No equilibration.\n\ * = 'Y': Equilibration was done, i.e., A has been replaced by\n\ * diag(S) * A * diag(S).\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * THRESH is a threshold value used to decide if scaling should be done\n\ * based on the ratio of the scaling factors. If SCOND < THRESH,\n\ * scaling is done.\n\ *\n\ * LARGE and SMALL are threshold values used to decide if scaling should\n\ * be done based on the absolute size of the largest matrix element.\n\ * If AMAX > LARGE or AMAX < SMALL, scaling is done.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/csytrs0000644000175000017500000000476612502223525016553 0ustar uwabamiuwabami--- :name: csytrs :md5sum: 784ed608d5930bb4507bf2cf968d77e7 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSYTRS solves a system of linear equations A*X = B with a complex\n\ * symmetric matrix A using the factorization A = U*D*U**T or\n\ * A = L*D*L**T computed by CSYTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by CSYTRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by CSYTRF.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slanst0000644000175000017500000000376712502223526016531 0ustar uwabamiuwabami--- :name: slanst :md5sum: cabf2b8182a1ceb35b27b12871092df3 :category: :function :type: real :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: real :intent: input :dims: - n-1 :substitutions: {} :fortran_help: " REAL FUNCTION SLANST( NORM, N, D, E )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLANST returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * real symmetric tridiagonal matrix A.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * SLANST returns the value\n\ *\n\ * SLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in SLANST as described\n\ * above.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, SLANST is\n\ * set to zero.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The diagonal elements of A.\n\ *\n\ * E (input) REAL array, dimension (N-1)\n\ * The (n-1) sub-diagonal or super-diagonal elements of A.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgerq20000644000175000017500000000514712502223525016401 0ustar uwabamiuwabami--- :name: cgerq2 :md5sum: 5c2737c86fa799ea149918e61f3f15a4 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - MIN(m,n) - work: :type: complex :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE CGERQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGERQ2 computes an RQ factorization of a complex m by n matrix A:\n\ * A = R * 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) COMPLEX array, dimension (LDA,N)\n\ * On entry, the m by n matrix A.\n\ * On exit, if m <= n, the upper triangle of the subarray\n\ * A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;\n\ * if m >= n, the elements on and above the (m-n)-th subdiagonal\n\ * contain the m by n upper trapezoidal matrix R; the remaining\n\ * elements, with the array TAU, represent the unitary matrix\n\ * Q as a product of elementary reflectors (see Further\n\ * Details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (output) COMPLEX array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace) COMPLEX 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(1)' H(2)' . . . H(k)', 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 complex scalar, and v is a complex vector with\n\ * v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on\n\ * exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlasq50000644000175000017500000000474512502223526016413 0ustar uwabamiuwabami--- :name: dlasq5 :md5sum: 3d03f3e888c881f172d8092734679c9d :category: :subroutine :arguments: - i0: :type: integer :intent: input - n0: :type: integer :intent: input - z: :type: doublereal :intent: input :dims: - 4*n0 - pp: :type: integer :intent: input - tau: :type: doublereal :intent: input - dmin: :type: doublereal :intent: output - dmin1: :type: doublereal :intent: output - dmin2: :type: doublereal :intent: output - dn: :type: doublereal :intent: output - dnm1: :type: doublereal :intent: output - dnm2: :type: doublereal :intent: output - ieee: :type: logical :intent: input :substitutions: {} :fortran_help: " SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, IEEE )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLASQ5 computes one dqds transform in ping-pong form, one\n\ * version for IEEE machines another for non IEEE machines.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * I0 (input) INTEGER\n\ * First index.\n\ *\n\ * N0 (input) INTEGER\n\ * Last index.\n\ *\n\ * Z (input) DOUBLE PRECISION array, dimension ( 4*N )\n\ * Z holds the qd array. EMIN is stored in Z(4*N0) to avoid\n\ * an extra argument.\n\ *\n\ * PP (input) INTEGER\n\ * PP=0 for ping, PP=1 for pong.\n\ *\n\ * TAU (input) DOUBLE PRECISION\n\ * This is the shift.\n\ *\n\ * DMIN (output) DOUBLE PRECISION\n\ * Minimum value of d.\n\ *\n\ * DMIN1 (output) DOUBLE PRECISION\n\ * Minimum value of d, excluding D( N0 ).\n\ *\n\ * DMIN2 (output) DOUBLE PRECISION\n\ * Minimum value of d, excluding D( N0 ) and D( N0-1 ).\n\ *\n\ * DN (output) DOUBLE PRECISION\n\ * d(N0), the last value of d.\n\ *\n\ * DNM1 (output) DOUBLE PRECISION\n\ * d(N0-1).\n\ *\n\ * DNM2 (output) DOUBLE PRECISION\n\ * d(N0-2).\n\ *\n\ * IEEE (input) LOGICAL\n\ * Flag for IEEE or non IEEE arithmetic.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Parameter ..\n DOUBLE PRECISION ZERO\n PARAMETER ( ZERO = 0.0D0 )\n\ * ..\n\ * .. Local Scalars ..\n INTEGER J4, J4P2\n DOUBLE PRECISION D, EMIN, TEMP\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zlaqps0000644000175000017500000000765412502223526016536 0ustar uwabamiuwabami--- :name: zlaqps :md5sum: a668f9d3c711ffd359dd258d703585bb :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - offset: :type: integer :intent: input - nb: :type: integer :intent: input - kb: :type: integer :intent: output - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: doublecomplex :intent: output :dims: - kb - vn1: :type: doublereal :intent: input/output :dims: - n - vn2: :type: doublereal :intent: input/output :dims: - n - auxv: :type: doublecomplex :intent: input/output :dims: - nb - f: :type: doublecomplex :intent: input/output :dims: - ldf - nb - ldf: :type: integer :intent: input :substitutions: kb: nb :fortran_help: " SUBROUTINE ZLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, VN2, AUXV, F, LDF )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAQPS computes a step of QR factorization with column pivoting\n\ * of a complex M-by-N matrix A by using Blas-3. It tries to factorize\n\ * NB columns from A starting from the row OFFSET+1, and updates all\n\ * of the matrix with Blas-3 xGEMM.\n\ *\n\ * In some cases, due to catastrophic cancellations, it cannot\n\ * factorize NB columns. Hence, the actual number of factorized\n\ * columns is returned in KB.\n\ *\n\ * Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\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\ * OFFSET (input) INTEGER\n\ * The number of rows of A that have been factorized in\n\ * previous steps.\n\ *\n\ * NB (input) INTEGER\n\ * The number of columns to factorize.\n\ *\n\ * KB (output) INTEGER\n\ * The number of columns actually factorized.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, block A(OFFSET+1:M,1:KB) is the triangular\n\ * factor obtained and block A(1:OFFSET,1:N) has been\n\ * accordingly pivoted, but no factorized.\n\ * The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has\n\ * been updated.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * JPVT (input/output) INTEGER array, dimension (N)\n\ * JPVT(I) = K <==> Column K of the full matrix A has been\n\ * permuted into position I in AP.\n\ *\n\ * TAU (output) COMPLEX*16 array, dimension (KB)\n\ * The scalar factors of the elementary reflectors.\n\ *\n\ * VN1 (input/output) DOUBLE PRECISION array, dimension (N)\n\ * The vector with the partial column norms.\n\ *\n\ * VN2 (input/output) DOUBLE PRECISION array, dimension (N)\n\ * The vector with the exact column norms.\n\ *\n\ * AUXV (input/output) COMPLEX*16 array, dimension (NB)\n\ * Auxiliar vector.\n\ *\n\ * F (input/output) COMPLEX*16 array, dimension (LDF,NB)\n\ * Matrix F' = L*Y'*A.\n\ *\n\ * LDF (input) INTEGER\n\ * The leading dimension of the array F. LDF >= max(1,N).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n\ * X. Sun, Computer Science Dept., Duke University, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zrot0000644000175000017500000000375112502223526016214 0ustar uwabamiuwabami--- :name: zrot :md5sum: 78d0f66ef5b739cafe490eed4531ebec :category: :subroutine :arguments: - n: :type: integer :intent: input - cx: :type: doublecomplex :intent: input/output :dims: - n - incx: :type: integer :intent: input - cy: :type: doublecomplex :intent: input/output :dims: - n - incy: :type: integer :intent: input - c: :type: doublereal :intent: input - s: :type: doublecomplex :intent: input :substitutions: {} :fortran_help: " SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZROT applies a plane rotation, where the cos (C) is real and the\n\ * sin (S) is complex, and the vectors CX and CY are complex.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of elements in the vectors CX and CY.\n\ *\n\ * CX (input/output) COMPLEX*16 array, dimension (N)\n\ * On input, the vector X.\n\ * On output, CX is overwritten with C*X + S*Y.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between successive values of CY. INCX <> 0.\n\ *\n\ * CY (input/output) COMPLEX*16 array, dimension (N)\n\ * On input, the vector Y.\n\ * On output, CY is overwritten with -CONJG(S)*X + C*Y.\n\ *\n\ * INCY (input) INTEGER\n\ * The increment between successive values of CY. INCX <> 0.\n\ *\n\ * C (input) DOUBLE PRECISION\n\ * S (input) COMPLEX*16\n\ * C and S define a rotation\n\ * [ C S ]\n\ * [ -conjg(S) C ]\n\ * where C*C + S*CONJG(S) = 1.0.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, IX, IY\n COMPLEX*16 STEMP\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC DCONJG\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zgeql20000644000175000017500000000516312502223526016421 0ustar uwabamiuwabami--- :name: zgeql2 :md5sum: 31856639f92558821325ce108c7eed98 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - MIN(m,n) - work: :type: doublecomplex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGEQL2( M, N, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGEQL2 computes a QL factorization of a complex m by n matrix A:\n\ * A = Q * L.\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) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the m by n matrix A.\n\ * On exit, if m >= n, the lower triangle of the subarray\n\ * A(m-n+1:m,1:n) contains the n by n lower triangular matrix L;\n\ * if m <= n, the elements on and below the (n-m)-th\n\ * superdiagonal contain the m by n lower trapezoidal matrix L;\n\ * the remaining elements, with the array TAU, represent the\n\ * unitary matrix Q as a product of elementary reflectors\n\ * (see Further Details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (output) COMPLEX*16 array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (N)\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 complex scalar, and v is a complex vector with\n\ * v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n\ * A(1:m-k+i-1,n-k+i), and tau in TAU(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctrtrs0000644000175000017500000000650012502223525016531 0ustar uwabamiuwabami--- :name: ctrtrs :md5sum: f4b2c572df1427345c348b89b7533172 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTRTRS solves a triangular system of the form\n\ *\n\ * A * X = B, A**T * X = B, or A**H * X = B,\n\ *\n\ * where A is a triangular matrix of order N, and B is an N-by-NRHS\n\ * matrix. A check is made to verify that A is nonsingular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The triangular matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of the array A contains the upper\n\ * triangular matrix, and the strictly lower triangular part of\n\ * A is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of the array A contains the lower triangular\n\ * matrix, and the strictly upper triangular part of A is not\n\ * referenced. If DIAG = 'U', the diagonal elements of A are\n\ * also not referenced and are assumed to be 1.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, if INFO = 0, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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 A is zero,\n\ * indicating that the matrix is singular and the solutions\n\ * X have not been computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zungl20000644000175000017500000000443312502223526016435 0ustar uwabamiuwabami--- :name: zungl2 :md5sum: 83082cb495e710244929a7f2d99d4246 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - work: :type: doublecomplex :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZUNGL2 generates an m-by-n complex matrix Q with orthonormal rows,\n\ * which is defined as the first m rows of a product of k elementary\n\ * reflectors of order n\n\ *\n\ * Q = H(k)' . . . H(2)' H(1)'\n\ *\n\ * as returned by ZGELQF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. N >= M.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. M >= K >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the i-th row must contain the vector which defines\n\ * the elementary reflector H(i), for i = 1,2,...,k, as returned\n\ * by ZGELQF in the first k rows of its array argument A.\n\ * On exit, the m by n matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) COMPLEX*16 array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by ZGELQF.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (M)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlanhe0000644000175000017500000000634212502223526016476 0ustar uwabamiuwabami--- :name: zlanhe :md5sum: 1b2b837bfeae7c4b9e9012d4e8676435 :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLANHE returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * complex hermitian matrix A.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * ZLANHE returns the value\n\ *\n\ * ZLANHE = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in ZLANHE as described\n\ * above.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * hermitian matrix A is to be referenced.\n\ * = 'U': Upper triangular part of A is referenced\n\ * = 'L': Lower triangular part of A is referenced\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, ZLANHE is\n\ * set to zero.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The hermitian matrix A. If UPLO = 'U', the leading n by n\n\ * upper triangular part of A contains the upper triangular part\n\ * of the matrix A, and the strictly lower triangular part of A\n\ * is not referenced. If UPLO = 'L', the leading n by n lower\n\ * triangular part of A contains the lower triangular part of\n\ * the matrix A, and the strictly upper triangular part of A is\n\ * not referenced. Note that the imaginary parts of the diagonal\n\ * elements need not be set and are assumed to be zero.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(N,1).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n\ * WORK is not referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cpbrfs0000644000175000017500000001174712502223525016500 0ustar uwabamiuwabami--- :name: cpbrfs :md5sum: 48c158d45998746437808d4354b35cc6 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: complex :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPBRFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is Hermitian positive definite\n\ * and banded, and provides error bounds and backward error estimates\n\ * for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AB (input) COMPLEX array, dimension (LDAB,N)\n\ * The upper or lower triangle of the Hermitian band matrix A,\n\ * stored in the first KD+1 rows of the array. The j-th column\n\ * of A is stored in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * AFB (input) COMPLEX array, dimension (LDAFB,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**H*U or A = L*L**H of the band matrix A as computed by\n\ * CPBTRF, in the same storage format as A (see AB).\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= KD+1.\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) COMPLEX array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by CPBTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgtsvx0000644000175000017500000002354512502223526016566 0ustar uwabamiuwabami--- :name: zgtsvx :md5sum: 898a2cdb954f54175f3ed1880fdf619e :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: doublecomplex :intent: input :dims: - n-1 - d: :type: doublecomplex :intent: input :dims: - n - du: :type: doublecomplex :intent: input :dims: - n-1 - dlf: :type: doublecomplex :intent: input/output :dims: - n-1 - df: :type: doublecomplex :intent: input/output :dims: - n - duf: :type: doublecomplex :intent: input/output :dims: - n-1 - du2: :type: doublecomplex :intent: input/output :dims: - n-2 - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE ZGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGTSVX uses the LU factorization to compute the solution to a complex\n\ * system of linear equations A * X = B, A**T * X = B, or A**H * X = B,\n\ * where A is a tridiagonal matrix of order N and X and B are N-by-NRHS\n\ * matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'N', the LU decomposition is used to factor the matrix A\n\ * as A = L * U, where L is a product of permutation and unit lower\n\ * bidiagonal matrices and U is upper triangular with nonzeros in\n\ * only the main diagonal and first two superdiagonals.\n\ *\n\ * 2. If some U(i,i)=0, so that U is exactly singular, then the routine\n\ * returns with INFO = i. Otherwise, the factored form of A is used\n\ * to estimate the condition number of the matrix A. If the\n\ * reciprocal of the condition number is less than machine precision,\n\ * INFO = N+1 is returned as a warning, but the routine still goes on\n\ * to solve for X and compute error bounds as described below.\n\ *\n\ * 3. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 4. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of A has been\n\ * supplied on entry.\n\ * = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored form\n\ * of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV will not\n\ * be modified.\n\ * = 'N': The matrix will be copied to DLF, DF, and DUF\n\ * and factored.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * DL (input) COMPLEX*16 array, dimension (N-1)\n\ * The (n-1) subdiagonal elements of A.\n\ *\n\ * D (input) COMPLEX*16 array, dimension (N)\n\ * The n diagonal elements of A.\n\ *\n\ * DU (input) COMPLEX*16 array, dimension (N-1)\n\ * The (n-1) superdiagonal elements of A.\n\ *\n\ * DLF (input or output) COMPLEX*16 array, dimension (N-1)\n\ * If FACT = 'F', then DLF is an input argument and on entry\n\ * contains the (n-1) multipliers that define the matrix L from\n\ * the LU factorization of A as computed by ZGTTRF.\n\ *\n\ * If FACT = 'N', then DLF is an output argument and on exit\n\ * contains the (n-1) multipliers that define the matrix L from\n\ * the LU factorization of A.\n\ *\n\ * DF (input or output) COMPLEX*16 array, dimension (N)\n\ * If FACT = 'F', then DF is an input argument and on entry\n\ * contains the n diagonal elements of the upper triangular\n\ * matrix U from the LU factorization of A.\n\ *\n\ * If FACT = 'N', then DF is an output argument and on exit\n\ * contains the n diagonal elements of the upper triangular\n\ * matrix U from the LU factorization of A.\n\ *\n\ * DUF (input or output) COMPLEX*16 array, dimension (N-1)\n\ * If FACT = 'F', then DUF is an input argument and on entry\n\ * contains the (n-1) elements of the first superdiagonal of U.\n\ *\n\ * If FACT = 'N', then DUF is an output argument and on exit\n\ * contains the (n-1) elements of the first superdiagonal of U.\n\ *\n\ * DU2 (input or output) COMPLEX*16 array, dimension (N-2)\n\ * If FACT = 'F', then DU2 is an input argument and on entry\n\ * contains the (n-2) elements of the second superdiagonal of\n\ * U.\n\ *\n\ * If FACT = 'N', then DU2 is an output argument and on exit\n\ * contains the (n-2) elements of the second superdiagonal of\n\ * U.\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains the pivot indices from the LU factorization of A as\n\ * computed by ZGTTRF.\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the LU factorization of A;\n\ * row i of the matrix was interchanged with row IPIV(i).\n\ * IPIV(i) will always be either i or i+1; IPIV(i) = i indicates\n\ * a row interchange was not required.\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The N-by-NRHS right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A. If RCOND is less than the machine precision (in\n\ * particular, if RCOND = 0), the matrix is singular to working\n\ * precision. This condition is indicated by a return code of\n\ * INFO > 0.\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\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, and i is\n\ * <= N: U(i,i) is exactly zero. The factorization\n\ * has not been completed unless i = N, but the\n\ * factor U is exactly singular, so the solution\n\ * and error bounds could not be computed.\n\ * RCOND = 0 is returned.\n\ * = N+1: U is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clangb0000644000175000017500000000546612502223525016450 0ustar uwabamiuwabami--- :name: clangb :md5sum: 4671133f3e16efb8ebc9afc55c1fae56 :category: :function :type: real :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "MAX(1,lsame_(&norm,\"I\") ? n : 0)" :substitutions: {} :fortran_help: " REAL FUNCTION CLANGB( NORM, N, KL, KU, AB, LDAB, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLANGB returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of an\n\ * n by n band matrix A, with kl sub-diagonals and ku super-diagonals.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * CLANGB returns the value\n\ *\n\ * CLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in CLANGB as described\n\ * above.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, CLANGB is\n\ * set to zero.\n\ *\n\ * KL (input) INTEGER\n\ * The number of sub-diagonals of the matrix A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of super-diagonals of the matrix A. KU >= 0.\n\ *\n\ * AB (input) COMPLEX array, dimension (LDAB,N)\n\ * The band matrix A, stored in rows 1 to KL+KU+1. The j-th\n\ * column of A is stored in the j-th column of the array AB as\n\ * follows:\n\ * AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n\ * referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlaqgb0000644000175000017500000000746512502223526016456 0ustar uwabamiuwabami--- :name: dlaqgb :md5sum: 3e680371f6b032c8b947d3a6023a369f :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - r: :type: doublereal :intent: input :dims: - m - c: :type: doublereal :intent: input :dims: - n - rowcnd: :type: doublereal :intent: input - colcnd: :type: doublereal :intent: input - amax: :type: doublereal :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAQGB equilibrates a general M by N band matrix A with KL\n\ * subdiagonals and KU superdiagonals using the row and scaling factors\n\ * in the vectors R and C.\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\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n\ *\n\ * On exit, the equilibrated matrix, in the same storage format\n\ * as A. See EQUED for the form of the equilibrated matrix.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDA >= KL+KU+1.\n\ *\n\ * R (input) DOUBLE PRECISION array, dimension (M)\n\ * The row scale factors for A.\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension (N)\n\ * The column scale factors for A.\n\ *\n\ * ROWCND (input) DOUBLE PRECISION\n\ * Ratio of the smallest R(i) to the largest R(i).\n\ *\n\ * COLCND (input) DOUBLE PRECISION\n\ * Ratio of the smallest C(i) to the largest C(i).\n\ *\n\ * AMAX (input) DOUBLE PRECISION\n\ * Absolute value of largest matrix entry.\n\ *\n\ * EQUED (output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * THRESH is a threshold value used to decide if row or column scaling\n\ * should be done based on the ratio of the row or column scaling\n\ * factors. If ROWCND < THRESH, row scaling is done, and if\n\ * COLCND < THRESH, column scaling is done.\n\ *\n\ * LARGE and SMALL are threshold values used to decide if row scaling\n\ * should be done based on the absolute size of the largest matrix\n\ * element. If AMAX > LARGE or AMAX < SMALL, row scaling is done.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dpoequ0000644000175000017500000000506612502223526016514 0ustar uwabamiuwabami--- :name: dpoequ :md5sum: 858ca9e43e3ae192a06d9709d4c8242f :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - n - scond: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPOEQU computes row and column scalings intended to equilibrate a\n\ * symmetric positive definite matrix A and reduce its condition number\n\ * (with respect to the two-norm). S contains the scale factors,\n\ * S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n\ * elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n\ * choice of S puts the condition number of B within a factor N of the\n\ * smallest possible condition number over all possible diagonal\n\ * scalings.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The N-by-N symmetric positive definite matrix whose scaling\n\ * factors are to be computed. Only the diagonal elements of A\n\ * are referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * S (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, S contains the scale factors for A.\n\ *\n\ * SCOND (output) DOUBLE PRECISION\n\ * If INFO = 0, S contains the ratio of the smallest S(i) to\n\ * the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n\ * large nor too small, it is not worth scaling by S.\n\ *\n\ * AMAX (output) DOUBLE PRECISION\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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 is nonpositive.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cpteqr0000644000175000017500000001036612502223525016513 0ustar uwabamiuwabami--- :name: cpteqr :md5sum: d6ff24d6a8c210f3d0d24cbe9a55d908 :category: :subroutine :arguments: - compz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - z: :type: complex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPTEQR computes all eigenvalues and, optionally, eigenvectors of a\n\ * symmetric positive definite tridiagonal matrix by first factoring the\n\ * matrix using SPTTRF and then calling CBDSQR to compute the singular\n\ * values of the bidiagonal factor.\n\ *\n\ * This routine computes the eigenvalues of the positive definite\n\ * tridiagonal matrix to high relative accuracy. This means that if the\n\ * eigenvalues range over many orders of magnitude in size, then the\n\ * small eigenvalues and corresponding eigenvectors will be computed\n\ * more accurately than, for example, with the standard QR method.\n\ *\n\ * The eigenvectors of a full or band positive definite Hermitian matrix\n\ * can also be found if CHETRD, CHPTRD, or CHBTRD has been used to\n\ * reduce this matrix to tridiagonal form. (The reduction to\n\ * tridiagonal form, however, may preclude the possibility of obtaining\n\ * high relative accuracy in the small eigenvalues of the original\n\ * matrix, if these eigenvalues range over many orders of magnitude.)\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * COMPZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only.\n\ * = 'V': Compute eigenvectors of original Hermitian\n\ * matrix also. Array Z contains the unitary matrix\n\ * used to reduce the original matrix to tridiagonal\n\ * form.\n\ * = 'I': Compute eigenvectors of tridiagonal matrix also.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the n diagonal elements of the tridiagonal matrix.\n\ * On normal exit, D contains the eigenvalues, in descending\n\ * order.\n\ *\n\ * E (input/output) REAL array, dimension (N-1)\n\ * On entry, the (n-1) subdiagonal elements of the tridiagonal\n\ * matrix.\n\ * On exit, E has been destroyed.\n\ *\n\ * Z (input/output) COMPLEX array, dimension (LDZ, N)\n\ * On entry, if COMPZ = 'V', the unitary matrix used in the\n\ * reduction to tridiagonal form.\n\ * On exit, if COMPZ = 'V', the orthonormal eigenvectors of the\n\ * original Hermitian matrix;\n\ * if COMPZ = 'I', the orthonormal eigenvectors of the\n\ * tridiagonal matrix.\n\ * If INFO > 0 on exit, Z contains the eigenvectors associated\n\ * with only the stored eigenvalues.\n\ * If COMPZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * COMPZ = 'V' or 'I', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) REAL array, dimension (4*N)\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, and i is:\n\ * <= N the Cholesky factorization of the matrix could\n\ * not be performed because the i-th principal minor\n\ * was not positive definite.\n\ * > N the SVD algorithm failed to converge;\n\ * if INFO = N+i, i off-diagonal elements of the\n\ * bidiagonal factor did not converge to zero.\n\ *\n\n\ * ====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsytrd0000644000175000017500000001317412502223526016527 0ustar uwabamiuwabami--- :name: dsytrd :md5sum: 0d42d32d704b2719a5b5bbbe89b1d402 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - n - e: :type: doublereal :intent: output :dims: - n-1 - tau: :type: doublereal :intent: output :dims: - n-1 - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSYTRD reduces a real symmetric matrix A to real symmetric\n\ * tridiagonal form T by an orthogonal similarity transformation:\n\ * Q**T * A * Q = T.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ * On exit, if UPLO = 'U', the diagonal and first superdiagonal\n\ * of A are overwritten by the corresponding elements of the\n\ * tridiagonal matrix T, and the elements above the first\n\ * superdiagonal, with the array TAU, represent the orthogonal\n\ * matrix Q as a product of elementary reflectors; if UPLO\n\ * = 'L', the diagonal and first subdiagonal of A are over-\n\ * written by the corresponding elements of the tridiagonal\n\ * matrix T, and the elements below the first subdiagonal, with\n\ * the array TAU, represent the orthogonal matrix Q as a product\n\ * of elementary reflectors. See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * D (output) DOUBLE PRECISION array, dimension (N)\n\ * The diagonal elements of the tridiagonal matrix T:\n\ * D(i) = A(i,i).\n\ *\n\ * E (output) DOUBLE PRECISION array, dimension (N-1)\n\ * The off-diagonal elements of the tridiagonal matrix T:\n\ * E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n\ *\n\ * TAU (output) DOUBLE PRECISION array, dimension (N-1)\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 >= 1.\n\ * For optimum performance LWORK >= N*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\ * If UPLO = 'U', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(n-1) . . . H(2) H(1).\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(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n\ * A(1:i-1,i+1), and tau in TAU(i).\n\ *\n\ * If UPLO = 'L', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(n-1).\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) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n\ * and tau in TAU(i).\n\ *\n\ * The contents of A on exit are illustrated by the following examples\n\ * with n = 5:\n\ *\n\ * if UPLO = 'U': if UPLO = 'L':\n\ *\n\ * ( d e v2 v3 v4 ) ( d )\n\ * ( d e v3 v4 ) ( e d )\n\ * ( d e v4 ) ( v1 e d )\n\ * ( d e ) ( v1 v2 e d )\n\ * ( d ) ( v1 v2 v3 e d )\n\ *\n\ * where d and e denote diagonal and off-diagonal elements of T, and vi\n\ * denotes an element of the vector defining H(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlauu20000644000175000017500000000414512502223526016436 0ustar uwabamiuwabami--- :name: zlauu2 :md5sum: 46fcd96cf0ef4dc6978b64ca0ec2df0c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZLAUU2( UPLO, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAUU2 computes the product U * U' or L' * L, where the triangular\n\ * factor U or L is stored in the upper or lower triangular part of\n\ * the array A.\n\ *\n\ * If UPLO = 'U' or 'u' then the upper triangle of the result is stored,\n\ * overwriting the factor U in A.\n\ * If UPLO = 'L' or 'l' then the lower triangle of the result is stored,\n\ * overwriting the factor L in A.\n\ *\n\ * This is the unblocked form of the algorithm, calling Level 2 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the triangular factor stored in the array A\n\ * is upper or lower triangular:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the triangular factor U or L. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the triangular factor U or L.\n\ * On exit, if UPLO = 'U', the upper triangle of A is\n\ * overwritten with the upper triangle of the product U * U';\n\ * if UPLO = 'L', the lower triangle of A is overwritten with\n\ * the lower triangle of the product L' * L.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zpotri0000644000175000017500000000413712502223526016544 0ustar uwabamiuwabami--- :name: zpotri :md5sum: d9cbd3d8000d34f9dbd5b622fb106900 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPOTRI( UPLO, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPOTRI computes the inverse of a complex Hermitian positive definite\n\ * matrix A using the Cholesky factorization A = U**H*U or A = L*L**H\n\ * computed by ZPOTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the triangular factor U or L from the Cholesky\n\ * factorization A = U**H*U or A = L*L**H, as computed by\n\ * ZPOTRF.\n\ * On exit, the upper or lower triangle of the (Hermitian)\n\ * inverse of A, overwriting the input factor U or L.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\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,i) element of the factor U or L is\n\ * zero, and the inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZLAUUM, ZTRTRI\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/ssygv0000644000175000017500000001232512502223526016366 0ustar uwabamiuwabami--- :name: ssygv :md5sum: 1003382acfdb1e9d9c4540ae84151723 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 3*n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSYGV computes all the eigenvalues, and optionally, the eigenvectors\n\ * of a real generalized symmetric-definite eigenproblem, of the form\n\ * A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.\n\ * Here A and B are assumed to be symmetric and B is also\n\ * positive definite.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * Specifies the problem type to be solved:\n\ * = 1: A*x = (lambda)*B*x\n\ * = 2: A*B*x = (lambda)*x\n\ * = 3: B*A*x = (lambda)*x\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA, N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of A contains the\n\ * upper triangular part of the matrix A. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of A contains\n\ * the lower triangular part of the matrix A.\n\ *\n\ * On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n\ * matrix Z of eigenvectors. The eigenvectors are normalized\n\ * as follows:\n\ * if ITYPE = 1 or 2, Z**T*B*Z = I;\n\ * if ITYPE = 3, Z**T*inv(B)*Z = I.\n\ * If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n\ * or the lower triangle (if UPLO='L') of A, including the\n\ * diagonal, is destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) REAL array, dimension (LDB, N)\n\ * On entry, the symmetric positive definite matrix B.\n\ * If UPLO = 'U', the leading N-by-N upper triangular part of B\n\ * contains the upper triangular part of the matrix B.\n\ * If UPLO = 'L', the leading N-by-N lower triangular part of B\n\ * contains the lower triangular part of the matrix B.\n\ *\n\ * On exit, if INFO <= N, the part of B containing the matrix is\n\ * overwritten by the triangular factor U or L from the Cholesky\n\ * factorization B = U**T*U or B = L*L**T.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of the array WORK. LWORK >= max(1,3*N-1).\n\ * For optimal efficiency, LWORK >= (NB+2)*N,\n\ * where NB is the blocksize for SSYTRD returned by ILAENV.\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: SPOTRF or SSYEV returned an error code:\n\ * <= N: if INFO = i, SSYEV failed to converge;\n\ * i off-diagonal elements of an intermediate\n\ * tridiagonal form did not converge to zero;\n\ * > N: if INFO = N + i, for 1 <= i <= N, then the leading\n\ * minor of order i of B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slamrg0000644000175000017500000000373112502223526016501 0ustar uwabamiuwabami--- :name: slamrg :md5sum: 0a48b06c5453d8e1f06057cc7369f5f8 :category: :subroutine :arguments: - n1: :type: integer :intent: input - n2: :type: integer :intent: input - a: :type: real :intent: input :dims: - n1+n2 - strd1: :type: integer :intent: input - strd2: :type: integer :intent: input - index: :type: integer :intent: output :dims: - n1+n2 :substitutions: {} :fortran_help: " SUBROUTINE SLAMRG( N1, N2, A, STRD1, STRD2, INDEX )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAMRG will create a permutation list which will merge the elements\n\ * of A (which is composed of two independently sorted sets) into a\n\ * single set which is sorted in ascending order.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N1 (input) INTEGER\n\ * N2 (input) INTEGER\n\ * These arguements contain the respective lengths of the two\n\ * sorted lists to be merged.\n\ *\n\ * A (input) REAL array, dimension (N1+N2)\n\ * The first N1 elements of A contain a list of numbers which\n\ * are sorted in either ascending or descending order. Likewise\n\ * for the final N2 elements.\n\ *\n\ * STRD1 (input) INTEGER\n\ * STRD2 (input) INTEGER\n\ * These are the strides to be taken through the array A.\n\ * Allowable strides are 1 and -1. They indicate whether a\n\ * subset of A is sorted in ascending (STRDx = 1) or descending\n\ * (STRDx = -1) order.\n\ *\n\ * INDEX (output) INTEGER array, dimension (N1+N2)\n\ * On exit this array will contain a permutation such that\n\ * if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be\n\ * sorted in ascending order.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, IND1, IND2, N1SV, N2SV\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cgetrs0000644000175000017500000000473312502223525016505 0ustar uwabamiuwabami--- :name: cgetrs :md5sum: 3baee94e1ac511afdeae03d88c6f52a6 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGETRS solves a system of linear equations\n\ * A * X = B, A**T * X = B, or A**H * X = B\n\ * with a general N-by-N matrix A using the LU factorization computed\n\ * by CGETRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The factors L and U from the factorization A = P*L*U\n\ * as computed by CGETRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from CGETRF; for 1<=i<=N, row i of the\n\ * matrix was interchanged with row IPIV(i).\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgeqrfp0000644000175000017500000000725112502223525016643 0ustar uwabamiuwabami--- :name: cgeqrfp :md5sum: cd46368a177f80fac9067f36e868f8d9 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - MIN(m,n) - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGEQRFP computes a QR factorization of a complex M-by-N matrix A:\n\ * A = Q * R.\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) COMPLEX array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, the elements on and above the diagonal of the array\n\ * contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n\ * upper triangular if m >= n); the elements below the diagonal,\n\ * with the array TAU, represent the unitary matrix Q as a\n\ * product of min(m,n) elementary reflectors (see Further\n\ * Details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (output) COMPLEX array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace/output) COMPLEX 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,N).\n\ * For optimum performance LWORK >= N*NB, where NB is\n\ * the 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(1) H(2) . . . H(k), 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 complex scalar, and v is a complex vector with\n\ * v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\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 CGEQR2P, CLARFB, CLARFT, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sgesvxx0000644000175000017500000005475012502223526016732 0ustar uwabamiuwabami--- :name: sgesvxx :md5sum: f1d72a70abcead56ab0ad3c271a07a62 :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - equed: :type: char :intent: input/output - r: :type: real :intent: input/output :dims: - n - c: :type: real :intent: input/output :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - rpvgrw: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: real :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " SUBROUTINE SGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGESVXX uses the LU factorization to compute the solution to a\n\ * real system of linear equations A * X = B, where A is an\n\ * N-by-N matrix and X and B are N-by-NRHS matrices.\n\ *\n\ * If requested, both normwise and maximum componentwise error bounds\n\ * are returned. SGESVXX will return a solution with a tiny\n\ * guaranteed error (O(eps) where eps is the working machine\n\ * precision) unless the matrix is very ill-conditioned, in which\n\ * case a warning is returned. Relevant condition numbers also are\n\ * calculated and returned.\n\ *\n\ * SGESVXX accepts user-provided factorizations and equilibration\n\ * factors; see the definitions of the FACT and EQUED options.\n\ * Solving with refinement and using a factorization from a previous\n\ * SGESVXX call will also produce a solution with either O(eps)\n\ * errors or warnings, but we cannot make that claim for general\n\ * user-provided factorizations and equilibration factors if they\n\ * differ from what SGESVXX would itself produce.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', real scaling factors are computed to equilibrate\n\ * the system:\n\ *\n\ * TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n\ * TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n\ * TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n\ *\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n\ * or diag(C)*B (if TRANS = 'T' or 'C').\n\ *\n\ * 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n\ * the matrix A (after equilibration if FACT = 'E') as\n\ *\n\ * A = P * L * U,\n\ *\n\ * where P is a permutation matrix, L is a unit lower triangular\n\ * matrix, and U is upper triangular.\n\ *\n\ * 3. If some U(i,i)=0, so that U is exactly singular, then the\n\ * routine returns with INFO = i. Otherwise, the factored form of A\n\ * is used to estimate the condition number of the matrix A (see\n\ * argument RCOND). If the reciprocal of the condition number is less\n\ * than machine precision, the routine still goes on to solve for X\n\ * and compute error bounds as described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n\ * the routine will use iterative refinement to try to get a small\n\ * error and error bounds. Refinement calculates the residual to at\n\ * least twice the working precision.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n\ * that it solves the original system before equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AF and IPIV contain the factored form of A.\n\ * If EQUED is not 'N', the matrix A has been\n\ * equilibrated with scaling factors given by R and C.\n\ * A, AF, and IPIV are not modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AF and factored.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate Transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is\n\ * not 'N', then A must have been equilibrated by the scaling\n\ * factors in R and/or C. A is not modified if FACT = 'F' or\n\ * 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n\ *\n\ * On exit, if EQUED .ne. 'N', A is scaled as follows:\n\ * EQUED = 'R': A := diag(R) * A\n\ * EQUED = 'C': A := A * diag(C)\n\ * EQUED = 'B': A := diag(R) * A * diag(C).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input or output) REAL array, dimension (LDAF,N)\n\ * If FACT = 'F', then AF is an input argument and on entry\n\ * contains the factors L and U from the factorization\n\ * A = P*L*U as computed by SGETRF. If EQUED .ne. 'N', then\n\ * AF is the factored form of the equilibrated matrix A.\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the factors L and U from the factorization A = P*L*U\n\ * of the original matrix A.\n\ *\n\ * If FACT = 'E', then AF is an output argument and on exit\n\ * returns the factors L and U from the factorization A = P*L*U\n\ * of the equilibrated matrix A (see the description of A for\n\ * the form of the equilibrated matrix).\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * as computed by SGETRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * of the original matrix A.\n\ *\n\ * If FACT = 'E', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * of the equilibrated matrix A.\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * R (input or output) REAL array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'R' or 'B', A is\n\ * multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n\ * is not accessed. R is an input argument if FACT = 'F';\n\ * otherwise, R is an output argument. If FACT = 'F' and\n\ * EQUED = 'R' or 'B', each element of R must be positive.\n\ * If R is output, each element of R is a power of the radix.\n\ * If R is input, each element of R should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * C (input or output) REAL array, dimension (N)\n\ * The column scale factors for A. If EQUED = 'C' or 'B', A is\n\ * multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n\ * is not accessed. C is an input argument if FACT = 'F';\n\ * otherwise, C is an output argument. If FACT = 'F' and\n\ * EQUED = 'C' or 'B', each element of C must be positive.\n\ * If C is output, each element of C is a power of the radix.\n\ * If C is input, each element of C should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit,\n\ * if EQUED = 'N', B is not modified;\n\ * if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n\ * diag(R)*B;\n\ * if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n\ * overwritten by diag(C)*B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) REAL array, dimension (LDX,NRHS)\n\ * If INFO = 0, the N-by-NRHS solution matrix X to the original\n\ * system of equations. Note that A and B are modified on exit\n\ * if EQUED .ne. 'N', and the solution to the equilibrated system is\n\ * inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n\ * inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * RPVGRW (output) REAL\n\ * Reciprocal pivot growth. On exit, this contains the reciprocal\n\ * pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n\ * norm is used. If this is much less than 1, then the stability of\n\ * the LU factorization of the (equilibrated) matrix A could be poor.\n\ * This also means that the solution X, estimated condition numbers,\n\ * and error bounds could be unreliable. If factorization fails with\n\ * 0 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dtrsna0000644000175000017500000002100412502223526016500 0ustar uwabamiuwabami--- :name: dtrsna :md5sum: 71c51825fc44a5eab65748b5f7d3cd1f :category: :subroutine :arguments: - job: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - t: :type: doublereal :intent: input :dims: - ldt - n - ldt: :type: integer :intent: input - vl: :type: doublereal :intent: input :dims: - ldvl - m - ldvl: :type: integer :intent: input - vr: :type: doublereal :intent: input :dims: - ldvr - m - ldvr: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - mm - sep: :type: doublereal :intent: output :dims: - mm - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: doublereal :intent: workspace :dims: - "lsame_(&job,\"E\") ? 0 : ldwork" - "lsame_(&job,\"E\") ? 0 : n+6" - ldwork: :type: integer :intent: input - iwork: :type: integer :intent: workspace :dims: - "lsame_(&job,\"E\") ? 0 : 2*(n-1)" - info: :type: integer :intent: output :substitutions: ldwork: "((lsame_(&job,\"V\")) || (lsame_(&job,\"B\"))) ? n : 1" mm: m :fortran_help: " SUBROUTINE DTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTRSNA estimates reciprocal condition numbers for specified\n\ * eigenvalues and/or right eigenvectors of a real upper\n\ * quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q\n\ * orthogonal).\n\ *\n\ * T must be in Schur canonical form (as returned by DHSEQR), that is,\n\ * block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each\n\ * 2-by-2 diagonal block has its diagonal elements equal and its\n\ * off-diagonal elements of opposite sign.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * Specifies whether condition numbers are required for\n\ * eigenvalues (S) or eigenvectors (SEP):\n\ * = 'E': for eigenvalues only (S);\n\ * = 'V': for eigenvectors only (SEP);\n\ * = 'B': for both eigenvalues and eigenvectors (S and SEP).\n\ *\n\ * HOWMNY (input) CHARACTER*1\n\ * = 'A': compute condition numbers for all eigenpairs;\n\ * = 'S': compute condition numbers for selected eigenpairs\n\ * specified by the array SELECT.\n\ *\n\ * SELECT (input) LOGICAL array, dimension (N)\n\ * If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n\ * condition numbers are required. To select condition numbers\n\ * for the eigenpair corresponding to a real eigenvalue w(j),\n\ * SELECT(j) must be set to .TRUE.. To select condition numbers\n\ * corresponding to a complex conjugate pair of eigenvalues w(j)\n\ * and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be\n\ * set to .TRUE..\n\ * If HOWMNY = 'A', SELECT is not referenced.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix T. N >= 0.\n\ *\n\ * T (input) DOUBLE PRECISION array, dimension (LDT,N)\n\ * The upper quasi-triangular matrix T, in Schur canonical form.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= max(1,N).\n\ *\n\ * VL (input) DOUBLE PRECISION array, dimension (LDVL,M)\n\ * If JOB = 'E' or 'B', VL must contain left eigenvectors of T\n\ * (or of any Q*T*Q**T with Q orthogonal), corresponding to the\n\ * eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n\ * must be stored in consecutive columns of VL, as returned by\n\ * DHSEIN or DTREVC.\n\ * If JOB = 'V', VL is not referenced.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the array VL.\n\ * LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.\n\ *\n\ * VR (input) DOUBLE PRECISION array, dimension (LDVR,M)\n\ * If JOB = 'E' or 'B', VR must contain right eigenvectors of T\n\ * (or of any Q*T*Q**T with Q orthogonal), corresponding to the\n\ * eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n\ * must be stored in consecutive columns of VR, as returned by\n\ * DHSEIN or DTREVC.\n\ * If JOB = 'V', VR is not referenced.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the array VR.\n\ * LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.\n\ *\n\ * S (output) DOUBLE PRECISION array, dimension (MM)\n\ * If JOB = 'E' or 'B', the reciprocal condition numbers of the\n\ * selected eigenvalues, stored in consecutive elements of the\n\ * array. For a complex conjugate pair of eigenvalues two\n\ * consecutive elements of S are set to the same value. Thus\n\ * S(j), SEP(j), and the j-th columns of VL and VR all\n\ * correspond to the same eigenpair (but not in general the\n\ * j-th eigenpair, unless all eigenpairs are selected).\n\ * If JOB = 'V', S is not referenced.\n\ *\n\ * SEP (output) DOUBLE PRECISION array, dimension (MM)\n\ * If JOB = 'V' or 'B', the estimated reciprocal condition\n\ * numbers of the selected eigenvectors, stored in consecutive\n\ * elements of the array. For a complex eigenvector two\n\ * consecutive elements of SEP are set to the same value. If\n\ * the eigenvalues cannot be reordered to compute SEP(j), SEP(j)\n\ * is set to 0; this can only occur when the true value would be\n\ * very small anyway.\n\ * If JOB = 'E', SEP is not referenced.\n\ *\n\ * MM (input) INTEGER\n\ * The number of elements in the arrays S (if JOB = 'E' or 'B')\n\ * and/or SEP (if JOB = 'V' or 'B'). MM >= M.\n\ *\n\ * M (output) INTEGER\n\ * The number of elements of the arrays S and/or SEP actually\n\ * used to store the estimated condition numbers.\n\ * If HOWMNY = 'A', M is set to N.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,N+6)\n\ * If JOB = 'E', WORK is not referenced.\n\ *\n\ * LDWORK (input) INTEGER\n\ * The leading dimension of the array WORK.\n\ * LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (2*(N-1))\n\ * If JOB = 'E', IWORK is not referenced.\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 reciprocal of the condition number of an eigenvalue lambda is\n\ * defined as\n\ *\n\ * S(lambda) = |v'*u| / (norm(u)*norm(v))\n\ *\n\ * where u and v are the right and left eigenvectors of T corresponding\n\ * to lambda; v' denotes the conjugate-transpose of v, and norm(u)\n\ * denotes the Euclidean norm. These reciprocal condition numbers always\n\ * lie between zero (very badly conditioned) and one (very well\n\ * conditioned). If n = 1, S(lambda) is defined to be 1.\n\ *\n\ * An approximate error bound for a computed eigenvalue W(i) is given by\n\ *\n\ * EPS * norm(T) / S(i)\n\ *\n\ * where EPS is the machine precision.\n\ *\n\ * The reciprocal of the condition number of the right eigenvector u\n\ * corresponding to lambda is defined as follows. Suppose\n\ *\n\ * T = ( lambda c )\n\ * ( 0 T22 )\n\ *\n\ * Then the reciprocal condition number is\n\ *\n\ * SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )\n\ *\n\ * where sigma-min denotes the smallest singular value. We approximate\n\ * the smallest singular value by the reciprocal of an estimate of the\n\ * one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is\n\ * defined to be abs(T(1,1)).\n\ *\n\ * An approximate error bound for a computed right eigenvector VR(i)\n\ * is given by\n\ *\n\ * EPS * norm(T) / SEP(i)\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/strevc0000644000175000017500000001603412502223526016522 0ustar uwabamiuwabami--- :name: strevc :md5sum: 0d2d5d1a609c10f4ee3c5f0b43c8a755 :category: :subroutine :arguments: - side: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input/output :dims: - n - n: :type: integer :intent: input - t: :type: real :intent: input :dims: - ldt - n - ldt: :type: integer :intent: input - vl: :type: real :intent: input/output :dims: - ldvl - mm - ldvl: :type: integer :intent: input - vr: :type: real :intent: input/output :dims: - ldvr - mm - ldvr: :type: integer :intent: input - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: real :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE STREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STREVC computes some or all of the right and/or left eigenvectors of\n\ * a real upper quasi-triangular matrix T.\n\ * Matrices of this type are produced by the Schur factorization of\n\ * a real general matrix: A = Q*T*Q**T, as computed by SHSEQR.\n\ * \n\ * The right eigenvector x and the left eigenvector y of T corresponding\n\ * to an eigenvalue w are defined by:\n\ * \n\ * T*x = w*x, (y**H)*T = w*(y**H)\n\ * \n\ * where y**H denotes the conjugate transpose of y.\n\ * The eigenvalues are not input to this routine, but are read directly\n\ * from the diagonal blocks of T.\n\ * \n\ * This routine returns the matrices X and/or Y of right and left\n\ * eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an\n\ * input matrix. If Q is the orthogonal factor that reduces a matrix\n\ * A to Schur form T, then Q*X and Q*Y are the matrices of right and\n\ * left eigenvectors of A.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'R': compute right eigenvectors only;\n\ * = 'L': compute left eigenvectors only;\n\ * = 'B': compute both right and left eigenvectors.\n\ *\n\ * HOWMNY (input) CHARACTER*1\n\ * = 'A': compute all right and/or left eigenvectors;\n\ * = 'B': compute all right and/or left eigenvectors,\n\ * backtransformed by the matrices in VR and/or VL;\n\ * = 'S': compute selected right and/or left eigenvectors,\n\ * as indicated by the logical array SELECT.\n\ *\n\ * SELECT (input/output) LOGICAL array, dimension (N)\n\ * If HOWMNY = 'S', SELECT specifies the eigenvectors to be\n\ * computed.\n\ * If w(j) is a real eigenvalue, the corresponding real\n\ * eigenvector is computed if SELECT(j) is .TRUE..\n\ * If w(j) and w(j+1) are the real and imaginary parts of a\n\ * complex eigenvalue, the corresponding complex eigenvector is\n\ * computed if either SELECT(j) or SELECT(j+1) is .TRUE., and\n\ * on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to\n\ * .FALSE..\n\ * Not referenced if HOWMNY = 'A' or 'B'.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix T. N >= 0.\n\ *\n\ * T (input) REAL array, dimension (LDT,N)\n\ * The upper quasi-triangular matrix T in Schur canonical form.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= max(1,N).\n\ *\n\ * VL (input/output) REAL array, dimension (LDVL,MM)\n\ * On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n\ * contain an N-by-N matrix Q (usually the orthogonal matrix Q\n\ * of Schur vectors returned by SHSEQR).\n\ * On exit, if SIDE = 'L' or 'B', VL contains:\n\ * if HOWMNY = 'A', the matrix Y of left eigenvectors of T;\n\ * if HOWMNY = 'B', the matrix Q*Y;\n\ * if HOWMNY = 'S', the left eigenvectors of T specified by\n\ * SELECT, stored consecutively in the columns\n\ * of VL, in the same order as their\n\ * eigenvalues.\n\ * A complex eigenvector corresponding to a complex eigenvalue\n\ * is stored in two consecutive columns, the first holding the\n\ * real part, and the second the imaginary part.\n\ * Not referenced if SIDE = 'R'.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the array VL. LDVL >= 1, and if\n\ * SIDE = 'L' or 'B', LDVL >= N.\n\ *\n\ * VR (input/output) REAL array, dimension (LDVR,MM)\n\ * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n\ * contain an N-by-N matrix Q (usually the orthogonal matrix Q\n\ * of Schur vectors returned by SHSEQR).\n\ * On exit, if SIDE = 'R' or 'B', VR contains:\n\ * if HOWMNY = 'A', the matrix X of right eigenvectors of T;\n\ * if HOWMNY = 'B', the matrix Q*X;\n\ * if HOWMNY = 'S', the right eigenvectors of T specified by\n\ * SELECT, stored consecutively in the columns\n\ * of VR, in the same order as their\n\ * eigenvalues.\n\ * A complex eigenvector corresponding to a complex eigenvalue\n\ * is stored in two consecutive columns, the first holding the\n\ * real part and the second the imaginary part.\n\ * Not referenced if SIDE = 'L'.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the array VR. LDVR >= 1, and if\n\ * SIDE = 'R' or 'B', LDVR >= N.\n\ *\n\ * MM (input) INTEGER\n\ * The number of columns in the arrays VL and/or VR. MM >= M.\n\ *\n\ * M (output) INTEGER\n\ * The number of columns in the arrays VL and/or VR actually\n\ * used to store the eigenvectors.\n\ * If HOWMNY = 'A' or 'B', M is set to N.\n\ * Each selected real eigenvector occupies one column and each\n\ * selected complex eigenvector occupies two columns.\n\ *\n\ * WORK (workspace) REAL array, dimension (3*N)\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 algorithm used in this program is basically backward (forward)\n\ * substitution, with scaling to make the the code robust against\n\ * possible overflow.\n\ *\n\ * Each eigenvector is normalized so that the element of largest\n\ * magnitude has magnitude 1; here the magnitude of a complex number\n\ * (x,y) is taken to be |x| + |y|.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgetri0000644000175000017500000000521012502223525016462 0ustar uwabamiuwabami--- :name: cgetri :md5sum: 9ecd491ae64a30ddedf4b8b8b8b65820 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGETRI computes the inverse of a matrix using the LU factorization\n\ * computed by CGETRF.\n\ *\n\ * This method inverts U and then computes inv(A) by solving the system\n\ * inv(A)*L = inv(U) for inv(A).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the factors L and U from the factorization\n\ * A = P*L*U as computed by CGETRF.\n\ * On exit, if INFO = 0, the inverse of the original matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from CGETRF; for 1<=i<=N, row i of the\n\ * matrix was interchanged with row IPIV(i).\n\ *\n\ * WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO=0, then WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK >= max(1,N).\n\ * For optimal performance LWORK >= N*NB, where NB is\n\ * the optimal blocksize returned by ILAENV.\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, U(i,i) is exactly zero; the matrix is\n\ * singular and its inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsbevx0000644000175000017500000002024412502223526016505 0ustar uwabamiuwabami--- :name: dsbevx :md5sum: c54c0d69a5f4df0fc356205a4641b5ae :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - q: :type: doublereal :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 7*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" ldq: "lsame_(&jobz,\"V\") ? MAX(1,n) : 0" :fortran_help: " SUBROUTINE DSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSBEVX computes selected eigenvalues and, optionally, eigenvectors\n\ * of a real symmetric band matrix A. Eigenvalues and eigenvectors can\n\ * be selected by specifying either a range of values or a range of\n\ * indices for the desired eigenvalues.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found;\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found;\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * On exit, AB is overwritten by values generated during the\n\ * reduction to tridiagonal form. If UPLO = 'U', the first\n\ * superdiagonal and the diagonal of the tridiagonal matrix T\n\ * are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n\ * the diagonal and first subdiagonal of T are returned in the\n\ * first two rows of AB.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD + 1.\n\ *\n\ * Q (output) DOUBLE PRECISION array, dimension (LDQ, N)\n\ * If JOBZ = 'V', the N-by-N orthogonal matrix used in the\n\ * reduction to tridiagonal form.\n\ * If JOBZ = 'N', the array Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. If JOBZ = 'V', then\n\ * LDQ >= max(1,N).\n\ *\n\ * VL (input) DOUBLE PRECISION\n\ * VU (input) DOUBLE PRECISION\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) DOUBLE PRECISION\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less than\n\ * or equal to zero, then EPS*|T| will be used in its place,\n\ * where |T| is the 1-norm of the tridiagonal matrix obtained\n\ * by reducing AB to tridiagonal form.\n\ *\n\ * Eigenvalues will be computed most accurately when ABSTOL is\n\ * set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n\ * If this routine returns with INFO>0, indicating that some\n\ * eigenvectors did not converge, try setting ABSTOL to\n\ * 2*DLAMCH('S').\n\ *\n\ * See \"Computing Small Singular Values of Bidiagonal Matrices\n\ * with Guaranteed High Relative Accuracy,\" by Demmel and\n\ * Kahan, LAPACK Working Note #3.\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * The first M elements contain the selected eigenvalues in\n\ * ascending order.\n\ *\n\ * Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))\n\ * If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix A\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * If an eigenvector fails to converge, then that column of Z\n\ * contains the latest approximation to the eigenvector, and the\n\ * index of the eigenvector is returned in IFAIL.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (7*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (5*N)\n\ *\n\ * IFAIL (output) INTEGER array, dimension (N)\n\ * If JOBZ = 'V', then if INFO = 0, the first M elements of\n\ * IFAIL are zero. If INFO > 0, then IFAIL contains the\n\ * indices of the eigenvectors that failed to converge.\n\ * If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n\ * Their indices are stored in array IFAIL.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cungr20000644000175000017500000000442412502223526016414 0ustar uwabamiuwabami--- :name: cungr2 :md5sum: f7132b5708349bba4dac10d58a1884cb :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - work: :type: complex :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE CUNGR2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CUNGR2 generates an m by n complex matrix Q with orthonormal rows,\n\ * which is defined as the last m rows of a product of k elementary\n\ * reflectors of order n\n\ *\n\ * Q = H(1)' H(2)' . . . H(k)'\n\ *\n\ * as returned by CGERQF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. N >= M.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. M >= K >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the (m-k+i)-th row must contain the vector which\n\ * defines the elementary reflector H(i), for i = 1,2,...,k, as\n\ * returned by CGERQF in the last k rows of its array argument\n\ * A.\n\ * On exit, the m-by-n matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) COMPLEX array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by CGERQF.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (M)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sspsvx0000644000175000017500000002252012502223526016557 0ustar uwabamiuwabami--- :name: sspsvx :md5sum: f706bfdee518e2325df5f40d8aa62f3c :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: real :intent: input :dims: - n*(n+1)/2 - afp: :type: real :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE SSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSPSVX uses the diagonal pivoting factorization A = U*D*U**T or\n\ * A = L*D*L**T to compute the solution to a real system of linear\n\ * equations A * X = B, where A is an N-by-N symmetric matrix stored\n\ * in packed format and X and B are N-by-NRHS matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'N', the diagonal pivoting method is used to factor A as\n\ * A = U * D * U**T, if UPLO = 'U', or\n\ * A = L * D * L**T, if UPLO = 'L',\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices and D is symmetric and block diagonal with\n\ * 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\ * 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n\ * returns with INFO = i. Otherwise, the factored form of A is used\n\ * to estimate the condition number of the matrix A. If the\n\ * reciprocal of the condition number is less than machine precision,\n\ * INFO = N+1 is returned as a warning, but the routine still goes on\n\ * to solve for X and compute error bounds as described below.\n\ *\n\ * 3. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 4. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of A has been\n\ * supplied on entry.\n\ * = 'F': On entry, AFP and IPIV contain the factored form of\n\ * A. AP, AFP and IPIV will not be modified.\n\ * = 'N': The matrix A will be copied to AFP and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AP (input) REAL array, dimension (N*(N+1)/2)\n\ * The upper or lower triangle of the symmetric matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ * See below for further details.\n\ *\n\ * AFP (input or output) REAL array, dimension\n\ * (N*(N+1)/2)\n\ * If FACT = 'F', then AFP is an input argument and on entry\n\ * contains the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L from the factorization\n\ * A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as\n\ * a packed triangular matrix in the same storage format as A.\n\ *\n\ * If FACT = 'N', then AFP is an output argument and on exit\n\ * contains the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L from the factorization\n\ * A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as\n\ * a packed triangular matrix in the same storage format as A.\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains details of the interchanges and the block structure\n\ * of D, as determined by SSPTRF.\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains details of the interchanges and the block structure\n\ * of D, as determined by SSPTRF.\n\ *\n\ * B (input) REAL array, dimension (LDB,NRHS)\n\ * The N-by-NRHS right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) REAL array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A. If RCOND is less than the machine precision (in\n\ * particular, if RCOND = 0), the matrix is singular to working\n\ * precision. This condition is indicated by a return code of\n\ * INFO > 0.\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) REAL array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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, and i is\n\ * <= N: D(i,i) is exactly zero. The factorization\n\ * has been completed but the factor D is exactly\n\ * singular, so the solution and error bounds could\n\ * not be computed. RCOND = 0 is returned.\n\ * = N+1: D is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The packed storage scheme is illustrated by the following example\n\ * when N = 4, UPLO = 'U':\n\ *\n\ * Two-dimensional storage of the symmetric matrix A:\n\ *\n\ * a11 a12 a13 a14\n\ * a22 a23 a24\n\ * a33 a34 (aij = aji)\n\ * a44\n\ *\n\ * Packed storage of the upper triangle of A:\n\ *\n\ * AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slaed90000644000175000017500000001006112502223526016367 0ustar uwabamiuwabami--- :name: slaed9 :md5sum: 19d8d043e908de337edab6e6515b3c83 :category: :subroutine :arguments: - k: :type: integer :intent: input - kstart: :type: integer :intent: input - kstop: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: real :intent: output :dims: - MAX(1,n) - q: :type: real :intent: workspace :dims: - ldq - MAX(1,n) - ldq: :type: integer :intent: input - rho: :type: real :intent: input - dlamda: :type: real :intent: input :dims: - k - w: :type: real :intent: input :dims: - k - s: :type: real :intent: output :dims: - lds - k - lds: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: ldq: MAX( 1, n ) lds: MAX( 1, k ) :fortran_help: " SUBROUTINE SLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W, S, LDS, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAED9 finds the roots of the secular equation, as defined by the\n\ * values in D, Z, and RHO, between KSTART and KSTOP. It makes the\n\ * appropriate calls to SLAED4 and then stores the new matrix of\n\ * eigenvectors for use in calculating the next level of Z vectors.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * K (input) INTEGER\n\ * The number of terms in the rational function to be solved by\n\ * SLAED4. K >= 0.\n\ *\n\ * KSTART (input) INTEGER\n\ * KSTOP (input) INTEGER\n\ * The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP\n\ * are to be computed. 1 <= KSTART <= KSTOP <= K.\n\ *\n\ * N (input) INTEGER\n\ * The number of rows and columns in the Q matrix.\n\ * N >= K (delation may result in N > K).\n\ *\n\ * D (output) REAL array, dimension (N)\n\ * D(I) contains the updated eigenvalues\n\ * for KSTART <= I <= KSTOP.\n\ *\n\ * Q (workspace) REAL array, dimension (LDQ,N)\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max( 1, N ).\n\ *\n\ * RHO (input) REAL\n\ * The value of the parameter in the rank one update equation.\n\ * RHO >= 0 required.\n\ *\n\ * DLAMDA (input) REAL array, dimension (K)\n\ * The first K elements of this array contain the old roots\n\ * of the deflated updating problem. These are the poles\n\ * of the secular equation.\n\ *\n\ * W (input) REAL array, dimension (K)\n\ * The first K elements of this array contain the components\n\ * of the deflation-adjusted updating vector.\n\ *\n\ * S (output) REAL array, dimension (LDS, K)\n\ * Will contain the eigenvectors of the repaired matrix which\n\ * will be stored for subsequent Z vector calculation and\n\ * multiplied by the previously accumulated eigenvectors\n\ * to update the system.\n\ *\n\ * LDS (input) INTEGER\n\ * The leading dimension of S. LDS >= max( 1, K ).\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 = 1, an eigenvalue did not converge\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Jeff Rutter, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n REAL TEMP\n\ * ..\n\ * .. External Functions ..\n REAL SLAMC3, SNRM2\n EXTERNAL SLAMC3, SNRM2\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SCOPY, SLAED4, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, SIGN, SQRT\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dtfttr0000644000175000017500000001434412502223526016525 0ustar uwabamiuwabami--- :name: dtfttr :md5sum: ef350058598d512b67124e7c2dde9291 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - arf: :type: doublereal :intent: input :dims: - ldarf - a: :type: doublereal :intent: output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(8*ldarf+1.0f)-1)/2 lda: MAX(1,n) :extras: ldarf: integer :fortran_help: " SUBROUTINE DTFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTFTTR copies a triangular matrix A from rectangular full packed\n\ * format (TF) to standard full format (TR).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': ARF is in Normal format;\n\ * = 'T': ARF is in Transpose format.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices ARF and A. N >= 0.\n\ *\n\ * ARF (input) DOUBLE PRECISION array, dimension (N*(N+1)/2).\n\ * On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')\n\ * matrix A in RFP format. See the \"Notes\" below for more\n\ * details.\n\ *\n\ * A (output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On exit, the triangular matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of the array A contains\n\ * the upper triangular matrix, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of the array A contains\n\ * the lower triangular matrix, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\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\ * We first consider Rectangular Full Packed (RFP) Format when N is\n\ * even. We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * the transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * the transpose of the last three columns of AP lower.\n\ * This covers the case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 04 05 33 43 53\n\ * 13 14 15 00 44 54\n\ * 23 24 25 10 11 55\n\ * 33 34 35 20 21 22\n\ * 00 44 45 30 31 32\n\ * 01 11 55 40 41 42\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We then consider Rectangular Full Packed (RFP) Format when N is\n\ * odd. We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * the transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * the transpose of the last two columns of AP lower.\n\ * This covers the case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 03 04 00 33 43\n\ * 12 13 14 10 11 44\n\ * 22 23 24 20 21 22\n\ * 00 33 34 30 31 32\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * Reference\n\ * =========\n\ *\n\ * =====================================================================\n\ *\n\ * ..\n\ * .. Local Scalars ..\n LOGICAL LOWER, NISODD, NORMALTRANSR\n INTEGER N1, N2, K, NT, NX2, NP1X2\n INTEGER I, J, L, IJ\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MOD\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zlanhb0000644000175000017500000000644612502223526016500 0ustar uwabamiuwabami--- :name: zlanhb :md5sum: 5c87108609a1d4de7b166f8a854c225e :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " DOUBLE PRECISION FUNCTION ZLANHB( NORM, UPLO, N, K, AB, LDAB, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLANHB returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of an\n\ * n by n hermitian band matrix A, with k super-diagonals.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * ZLANHB returns the value\n\ *\n\ * ZLANHB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in ZLANHB as described\n\ * above.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * band matrix A is supplied.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, ZLANHB is\n\ * set to zero.\n\ *\n\ * K (input) INTEGER\n\ * The number of super-diagonals or sub-diagonals of the\n\ * band matrix A. K >= 0.\n\ *\n\ * AB (input) COMPLEX*16 array, dimension (LDAB,N)\n\ * The upper or lower triangle of the hermitian band matrix A,\n\ * stored in the first K+1 rows of AB. The j-th column of A is\n\ * stored in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).\n\ * Note that the imaginary parts of the diagonal elements need\n\ * not be set and are assumed to be zero.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= K+1.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n\ * WORK is not referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ilaclr0000644000175000017500000000201612502223526016455 0ustar uwabamiuwabami--- :name: ilaclr :md5sum: 33fda7f2ac92c6aa5768747a408df60f :category: :function :type: integer :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " INTEGER FUNCTION ILACLR( M, N, A, LDA )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ILACLR scans A for its last non-zero row.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix A.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * 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\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgesvd0000644000175000017500000001617412502223525016473 0ustar uwabamiuwabami--- :name: cgesvd :md5sum: 31811375e47d4ef59153bb7b2e7b0db7 :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobvt: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n :outdims: - lda - MIN(m,n) - lda: :type: integer :intent: input - s: :type: real :intent: output :dims: - MIN(m,n) - u: :type: complex :intent: output :dims: - ldu - "lsame_(&jobu,\"A\") ? m : lsame_(&jobu,\"S\") ? MIN(m,n) : 0" - ldu: :type: integer :intent: input - vt: :type: complex :intent: output :dims: - ldvt - n - ldvt: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(1, 2*MIN(m,n)+MAX(m,n)) - rwork: :type: real :intent: workspace :dims: - 5*MIN(m,n) - info: :type: integer :intent: output :substitutions: m: lda ldvt: "lsame_(&jobvt,\"A\") ? n : lsame_(&jobvt,\"S\") ? MIN(m,n) : 1" ldu: "((lsame_(&jobu,\"S\")) || (lsame_(&jobu,\"A\"))) ? m : 1" :fortran_help: " SUBROUTINE CGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGESVD computes the singular value decomposition (SVD) of a complex\n\ * M-by-N matrix A, optionally computing the left and/or right singular\n\ * vectors. The SVD is written\n\ *\n\ * A = U * SIGMA * conjugate-transpose(V)\n\ *\n\ * where SIGMA is an M-by-N matrix which is zero except for its\n\ * min(m,n) diagonal elements, U is an M-by-M unitary matrix, and\n\ * V is an N-by-N unitary matrix. The diagonal elements of SIGMA\n\ * are the singular values of A; they are real and non-negative, and\n\ * are returned in descending order. The first min(m,n) columns of\n\ * U and V are the left and right singular vectors of A.\n\ *\n\ * Note that the routine returns V**H, not V.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBU (input) CHARACTER*1\n\ * Specifies options for computing all or part of the matrix U:\n\ * = 'A': all M columns of U are returned in array U:\n\ * = 'S': the first min(m,n) columns of U (the left singular\n\ * vectors) are returned in the array U;\n\ * = 'O': the first min(m,n) columns of U (the left singular\n\ * vectors) are overwritten on the array A;\n\ * = 'N': no columns of U (no left singular vectors) are\n\ * computed.\n\ *\n\ * JOBVT (input) CHARACTER*1\n\ * Specifies options for computing all or part of the matrix\n\ * V**H:\n\ * = 'A': all N rows of V**H are returned in the array VT;\n\ * = 'S': the first min(m,n) rows of V**H (the right singular\n\ * vectors) are returned in the array VT;\n\ * = 'O': the first min(m,n) rows of V**H (the right singular\n\ * vectors) are overwritten on the array A;\n\ * = 'N': no rows of V**H (no right singular vectors) are\n\ * computed.\n\ *\n\ * JOBVT and JOBU cannot both be 'O'.\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. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit,\n\ * if JOBU = 'O', A is overwritten with the first min(m,n)\n\ * columns of U (the left singular vectors,\n\ * stored columnwise);\n\ * if JOBVT = 'O', A is overwritten with the first min(m,n)\n\ * rows of V**H (the right singular vectors,\n\ * stored rowwise);\n\ * if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A\n\ * are destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * S (output) REAL array, dimension (min(M,N))\n\ * The singular values of A, sorted so that S(i) >= S(i+1).\n\ *\n\ * U (output) COMPLEX array, dimension (LDU,UCOL)\n\ * (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.\n\ * If JOBU = 'A', U contains the M-by-M unitary matrix U;\n\ * if JOBU = 'S', U contains the first min(m,n) columns of U\n\ * (the left singular vectors, stored columnwise);\n\ * if JOBU = 'N' or 'O', U is not referenced.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= 1; if\n\ * JOBU = 'S' or 'A', LDU >= M.\n\ *\n\ * VT (output) COMPLEX array, dimension (LDVT,N)\n\ * If JOBVT = 'A', VT contains the N-by-N unitary matrix\n\ * V**H;\n\ * if JOBVT = 'S', VT contains the first min(m,n) rows of\n\ * V**H (the right singular vectors, stored rowwise);\n\ * if JOBVT = 'N' or 'O', VT is not referenced.\n\ *\n\ * LDVT (input) INTEGER\n\ * The leading dimension of the array VT. LDVT >= 1; if\n\ * JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).\n\ *\n\ * WORK (workspace/output) COMPLEX 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,2*MIN(M,N)+MAX(M,N)).\n\ * For good performance, LWORK should generally be larger.\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\ * RWORK (workspace) REAL array, dimension (5*min(M,N))\n\ * On exit, if INFO > 0, RWORK(1:MIN(M,N)-1) contains the\n\ * unconverged superdiagonal elements of an upper bidiagonal\n\ * matrix B whose diagonal is in S (not necessarily sorted).\n\ * B satisfies A = U * B * VT, so it has the same singular\n\ * values as A, and singular vectors related by U and VT.\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 CBDSQR did not converge, INFO specifies how many\n\ * superdiagonals of an intermediate bidiagonal form B\n\ * did not converge to zero. See the description of RWORK\n\ * above for details.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlasr0000644000175000017500000001406412502223526016350 0ustar uwabamiuwabami--- :name: zlasr :md5sum: 2c139334c18fea83b86ce843062afbb9 :category: :subroutine :arguments: - side: :type: char :intent: input - pivot: :type: char :intent: input - direct: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - c: :type: doublereal :intent: input :dims: - m-1 - s: :type: doublereal :intent: input :dims: - m-1 - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLASR applies a sequence of real plane rotations to a complex matrix\n\ * A, from either the left or the right.\n\ *\n\ * When SIDE = 'L', the transformation takes the form\n\ *\n\ * A := P*A\n\ *\n\ * and when SIDE = 'R', the transformation takes the form\n\ *\n\ * A := A*P**T\n\ *\n\ * where P is an orthogonal matrix consisting of a sequence of z plane\n\ * rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',\n\ * and P**T is the transpose of P.\n\ * \n\ * When DIRECT = 'F' (Forward sequence), then\n\ * \n\ * P = P(z-1) * ... * P(2) * P(1)\n\ * \n\ * and when DIRECT = 'B' (Backward sequence), then\n\ * \n\ * P = P(1) * P(2) * ... * P(z-1)\n\ * \n\ * where P(k) is a plane rotation matrix defined by the 2-by-2 rotation\n\ * \n\ * R(k) = ( c(k) s(k) )\n\ * = ( -s(k) c(k) ).\n\ * \n\ * When PIVOT = 'V' (Variable pivot), the rotation is performed\n\ * for the plane (k,k+1), i.e., P(k) has the form\n\ * \n\ * P(k) = ( 1 )\n\ * ( ... )\n\ * ( 1 )\n\ * ( c(k) s(k) )\n\ * ( -s(k) c(k) )\n\ * ( 1 )\n\ * ( ... )\n\ * ( 1 )\n\ * \n\ * where R(k) appears as a rank-2 modification to the identity matrix in\n\ * rows and columns k and k+1.\n\ * \n\ * When PIVOT = 'T' (Top pivot), the rotation is performed for the\n\ * plane (1,k+1), so P(k) has the form\n\ * \n\ * P(k) = ( c(k) s(k) )\n\ * ( 1 )\n\ * ( ... )\n\ * ( 1 )\n\ * ( -s(k) c(k) )\n\ * ( 1 )\n\ * ( ... )\n\ * ( 1 )\n\ * \n\ * where R(k) appears in rows and columns 1 and k+1.\n\ * \n\ * Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is\n\ * performed for the plane (k,z), giving P(k) the form\n\ * \n\ * P(k) = ( 1 )\n\ * ( ... )\n\ * ( 1 )\n\ * ( c(k) s(k) )\n\ * ( 1 )\n\ * ( ... )\n\ * ( 1 )\n\ * ( -s(k) c(k) )\n\ * \n\ * where R(k) appears in rows and columns k and z. The rotations are\n\ * performed without ever forming P(k) explicitly.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * Specifies whether the plane rotation matrix P is applied to\n\ * A on the left or the right.\n\ * = 'L': Left, compute A := P*A\n\ * = 'R': Right, compute A:= A*P**T\n\ *\n\ * PIVOT (input) CHARACTER*1\n\ * Specifies the plane for which P(k) is a plane rotation\n\ * matrix.\n\ * = 'V': Variable pivot, the plane (k,k+1)\n\ * = 'T': Top pivot, the plane (1,k+1)\n\ * = 'B': Bottom pivot, the plane (k,z)\n\ *\n\ * DIRECT (input) CHARACTER*1\n\ * Specifies whether P is a forward or backward sequence of\n\ * plane rotations.\n\ * = 'F': Forward, P = P(z-1)*...*P(2)*P(1)\n\ * = 'B': Backward, P = P(1)*P(2)*...*P(z-1)\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A. If m <= 1, an immediate\n\ * return is effected.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix A. If n <= 1, an\n\ * immediate return is effected.\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension\n\ * (M-1) if SIDE = 'L'\n\ * (N-1) if SIDE = 'R'\n\ * The cosines c(k) of the plane rotations.\n\ *\n\ * S (input) DOUBLE PRECISION array, dimension\n\ * (M-1) if SIDE = 'L'\n\ * (N-1) if SIDE = 'R'\n\ * The sines s(k) of the plane rotations. The 2-by-2 plane\n\ * rotation part of the matrix P(k), R(k), has the form\n\ * R(k) = ( c(k) s(k) )\n\ * ( -s(k) c(k) ).\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * The M-by-N matrix A. On exit, A is overwritten by P*A if\n\ * SIDE = 'R' or by A*P**T if SIDE = 'L'.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctgexc0000644000175000017500000001371712502223525016475 0ustar uwabamiuwabami--- :name: ctgexc :md5sum: 28615b111bd89941edff51027b6ac193 :category: :subroutine :arguments: - wantq: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - q: :type: complex :intent: input/output :dims: - ldz - n - ldq: :type: integer :intent: input - z: :type: complex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - ifst: :type: integer :intent: input - ilst: :type: integer :intent: input/output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, IFST, ILST, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTGEXC reorders the generalized Schur decomposition of a complex\n\ * matrix pair (A,B), using an unitary equivalence transformation\n\ * (A, B) := Q * (A, B) * Z', so that the diagonal block of (A, B) with\n\ * row index IFST is moved to row ILST.\n\ *\n\ * (A, B) must be in generalized Schur canonical form, that is, A and\n\ * B are both upper triangular.\n\ *\n\ * Optionally, the matrices Q and Z of generalized Schur vectors are\n\ * updated.\n\ *\n\ * Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n\ * Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * WANTQ (input) LOGICAL\n\ * .TRUE. : update the left transformation matrix Q;\n\ * .FALSE.: do not update Q.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * .TRUE. : update the right transformation matrix Z;\n\ * .FALSE.: do not update Z.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the upper triangular matrix A in the pair (A, B).\n\ * On exit, the updated matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,N)\n\ * On entry, the upper triangular matrix B in the pair (A, B).\n\ * On exit, the updated matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * Q (input/output) COMPLEX array, dimension (LDZ,N)\n\ * On entry, if WANTQ = .TRUE., the unitary matrix Q.\n\ * On exit, the updated matrix Q.\n\ * If WANTQ = .FALSE., Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= 1;\n\ * If WANTQ = .TRUE., LDQ >= N.\n\ *\n\ * Z (input/output) COMPLEX array, dimension (LDZ,N)\n\ * On entry, if WANTZ = .TRUE., the unitary matrix Z.\n\ * On exit, the updated matrix Z.\n\ * If WANTZ = .FALSE., Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1;\n\ * If WANTZ = .TRUE., LDZ >= N.\n\ *\n\ * IFST (input) INTEGER\n\ * ILST (input/output) INTEGER\n\ * Specify the reordering of the diagonal blocks of (A, B).\n\ * The block with row index IFST is moved to row ILST, by a\n\ * sequence of swapping between adjacent blocks.\n\ *\n\ * INFO (output) INTEGER\n\ * =0: Successful exit.\n\ * <0: if INFO = -i, the i-th argument had an illegal value.\n\ * =1: The transformed matrix pair (A, B) would be too far\n\ * from generalized Schur form; the problem is ill-\n\ * conditioned. (A, B) may have been partially reordered,\n\ * and ILST points to the first row of the current\n\ * position of the block being moved.\n\ *\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n\ * Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n\ * M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n\ * Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n\ *\n\ * [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n\ * Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n\ * Estimation: Theory, Algorithms and Software, Report\n\ * UMINF - 94.04, Department of Computing Science, Umea University,\n\ * S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.\n\ * To appear in Numerical Algorithms, 1996.\n\ *\n\ * [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n\ * for Solving the Generalized Sylvester Equation and Estimating the\n\ * Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n\ * Department of Computing Science, Umea University, S-901 87 Umea,\n\ * Sweden, December 1993, Revised April 1994, Also as LAPACK working\n\ * Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,\n\ * 1996.\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER HERE\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CTGEX2, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cla_gbrcond_x0000644000175000017500000001027712502223525020002 0ustar uwabamiuwabami--- :name: cla_gbrcond_x :md5sum: 752539b13b6724667a3fba3025ec4a6b :category: :function :type: real :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: complex :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - x: :type: complex :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: complex :intent: input :dims: - 2*n - rwork: :type: real :intent: input :dims: - n :substitutions: {} :fortran_help: " REAL FUNCTION CLA_GBRCOND_X( TRANS, N, KL, KU, AB, LDAB, AFB, LDAFB, IPIV, X, INFO, WORK, RWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLA_GBRCOND_X Computes the infinity norm condition number of\n\ * op(A) * diag(X) where X is a COMPLEX vector.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate Transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * AB (input) COMPLEX array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * AFB (input) COMPLEX array, dimension (LDAFB,N)\n\ * Details of the LU factorization of the band matrix A, as\n\ * computed by CGBTRF. U is stored as an upper triangular\n\ * band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n\ * and the multipliers used during the factorization are stored\n\ * in rows KL+KU+2 to 2*KL+KU+1.\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from the factorization A = P*L*U\n\ * as computed by CGBTRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * X (input) COMPLEX array, dimension (N)\n\ * The vector X in the formula op(A) * diag(X).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * i > 0: The ith argument is invalid.\n\ *\n\ * WORK (input) COMPLEX array, dimension (2*N).\n\ * Workspace.\n\ *\n\ * RWORK (input) REAL array, dimension (N).\n\ * Workspace.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE, I, J\n REAL AINVNM, ANORM, TMP\n COMPLEX ZDUM\n\ * ..\n\ * .. Local Arrays ..\n INTEGER ISAVE( 3 )\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CLACN2, CGBTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n\ * ..\n\ * .. Statement Functions ..\n REAL CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zhbgst0000644000175000017500000001013512502223526016511 0ustar uwabamiuwabami--- :name: zhbgst :md5sum: b25f0a732a0eebdab26f937666828130 :category: :subroutine :arguments: - vect: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: doublecomplex :intent: input :dims: - ldbb - n - ldbb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - n - ldx: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: "lsame_(&vect,\"V\") ? MAX(1,n) : 1" :fortran_help: " SUBROUTINE ZHBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, LDX, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHBGST reduces a complex Hermitian-definite banded generalized\n\ * eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y,\n\ * such that C has the same bandwidth as A.\n\ *\n\ * B must have been previously factorized as S**H*S by ZPBSTF, using a\n\ * split Cholesky factorization. A is overwritten by C = X**H*A*X, where\n\ * X = S**(-1)*Q and Q is a unitary matrix chosen to preserve the\n\ * bandwidth of A.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * VECT (input) CHARACTER*1\n\ * = 'N': do not form the transformation matrix X;\n\ * = 'V': form X.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * KA (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n\ *\n\ * KB (input) INTEGER\n\ * The number of superdiagonals of the matrix B if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0.\n\ *\n\ * AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix A, stored in the first ka+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n\ *\n\ * On exit, the transformed matrix X**H*A*X, stored in the same\n\ * format as A.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KA+1.\n\ *\n\ * BB (input) COMPLEX*16 array, dimension (LDBB,N)\n\ * The banded factor S from the split Cholesky factorization of\n\ * B, as returned by ZPBSTF, stored in the first kb+1 rows of\n\ * the array.\n\ *\n\ * LDBB (input) INTEGER\n\ * The leading dimension of the array BB. LDBB >= KB+1.\n\ *\n\ * X (output) COMPLEX*16 array, dimension (LDX,N)\n\ * If VECT = 'V', the n-by-n matrix X.\n\ * If VECT = 'N', the array X is not referenced.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X.\n\ * LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlansb0000644000175000017500000000630512502223526016505 0ustar uwabamiuwabami--- :name: zlansb :md5sum: 2cf3136063091d0832acc52777370cbe :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " DOUBLE PRECISION FUNCTION ZLANSB( NORM, UPLO, N, K, AB, LDAB, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLANSB returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of an\n\ * n by n symmetric band matrix A, with k super-diagonals.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * ZLANSB returns the value\n\ *\n\ * ZLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in ZLANSB as described\n\ * above.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * band matrix A is supplied.\n\ * = 'U': Upper triangular part is supplied\n\ * = 'L': Lower triangular part is supplied\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, ZLANSB is\n\ * set to zero.\n\ *\n\ * K (input) INTEGER\n\ * The number of super-diagonals or sub-diagonals of the\n\ * band matrix A. K >= 0.\n\ *\n\ * AB (input) COMPLEX*16 array, dimension (LDAB,N)\n\ * The upper or lower triangle of the symmetric band matrix A,\n\ * stored in the first K+1 rows of AB. The j-th column of A is\n\ * stored in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= K+1.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n\ * WORK is not referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zbdsqr0000644000175000017500000001607112502223526016522 0ustar uwabamiuwabami--- :name: zbdsqr :md5sum: f9942566ea058ea5036793480cdaa22c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ncvt: :type: integer :intent: input - nru: :type: integer :intent: input - ncc: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - vt: :type: doublecomplex :intent: input/output :dims: - ldvt - ncvt - ldvt: :type: integer :intent: input - u: :type: doublecomplex :intent: input/output :dims: - ldu - n - ldu: :type: integer :intent: input - c: :type: doublecomplex :intent: input/output :dims: - ldc - ncc - ldc: :type: integer :intent: input - rwork: :type: doublereal :intent: workspace :dims: - "(ncvt==nru)&&(nru==ncc)&&(ncc==0) ? 2*n : MAX(1, 4*n-4)" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZBDSQR computes the singular values and, optionally, the right and/or\n\ * left singular vectors from the singular value decomposition (SVD) of\n\ * a real N-by-N (upper or lower) bidiagonal matrix B using the implicit\n\ * zero-shift QR algorithm. The SVD of B has the form\n\ * \n\ * B = Q * S * P**H\n\ * \n\ * where S is the diagonal matrix of singular values, Q is an orthogonal\n\ * matrix of left singular vectors, and P is an orthogonal matrix of\n\ * right singular vectors. If left singular vectors are requested, this\n\ * subroutine actually returns U*Q instead of Q, and, if right singular\n\ * vectors are requested, this subroutine returns P**H*VT instead of\n\ * P**H, for given complex input matrices U and VT. When U and VT are\n\ * the unitary matrices that reduce a general matrix A to bidiagonal\n\ * form: A = U*B*VT, as computed by ZGEBRD, then\n\ * \n\ * A = (U*Q) * S * (P**H*VT)\n\ * \n\ * is the SVD of A. Optionally, the subroutine may also compute Q**H*C\n\ * for a given complex input matrix C.\n\ *\n\ * See \"Computing Small Singular Values of Bidiagonal Matrices With\n\ * Guaranteed High Relative Accuracy,\" by J. Demmel and W. Kahan,\n\ * LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,\n\ * no. 5, pp. 873-912, Sept 1990) and\n\ * \"Accurate singular values and differential qd algorithms,\" by\n\ * B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics\n\ * Department, University of California at Berkeley, July 1992\n\ * for a detailed description of the algorithm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': B is upper bidiagonal;\n\ * = 'L': B is lower bidiagonal.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix B. N >= 0.\n\ *\n\ * NCVT (input) INTEGER\n\ * The number of columns of the matrix VT. NCVT >= 0.\n\ *\n\ * NRU (input) INTEGER\n\ * The number of rows of the matrix U. NRU >= 0.\n\ *\n\ * NCC (input) INTEGER\n\ * The number of columns of the matrix C. NCC >= 0.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the n diagonal elements of the bidiagonal matrix B.\n\ * On exit, if INFO=0, the singular values of B in decreasing\n\ * order.\n\ *\n\ * E (input/output) DOUBLE PRECISION array, dimension (N-1)\n\ * On entry, the N-1 offdiagonal elements of the bidiagonal\n\ * matrix B.\n\ * On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E\n\ * will contain the diagonal and superdiagonal elements of a\n\ * bidiagonal matrix orthogonally equivalent to the one given\n\ * as input.\n\ *\n\ * VT (input/output) COMPLEX*16 array, dimension (LDVT, NCVT)\n\ * On entry, an N-by-NCVT matrix VT.\n\ * On exit, VT is overwritten by P**H * VT.\n\ * Not referenced if NCVT = 0.\n\ *\n\ * LDVT (input) INTEGER\n\ * The leading dimension of the array VT.\n\ * LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.\n\ *\n\ * U (input/output) COMPLEX*16 array, dimension (LDU, N)\n\ * On entry, an NRU-by-N matrix U.\n\ * On exit, U is overwritten by U * Q.\n\ * Not referenced if NRU = 0.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= max(1,NRU).\n\ *\n\ * C (input/output) COMPLEX*16 array, dimension (LDC, NCC)\n\ * On entry, an N-by-NCC matrix C.\n\ * On exit, C is overwritten by Q**H * C.\n\ * Not referenced if NCC = 0.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C.\n\ * LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n\ * if NCVT = NRU = NCC = 0, (max(1, 4*N-4)) otherwise\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: If INFO = -i, the i-th argument had an illegal value\n\ * > 0: the algorithm did not converge; D and E contain the\n\ * elements of a bidiagonal matrix which is orthogonally\n\ * similar to the input matrix B; if INFO = i, i\n\ * elements of E have not converged to zero.\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8)))\n\ * TOLMUL controls the convergence criterion of the QR loop.\n\ * If it is positive, TOLMUL*EPS is the desired relative\n\ * precision in the computed singular values.\n\ * If it is negative, abs(TOLMUL*EPS*sigma_max) is the\n\ * desired absolute accuracy in the computed singular\n\ * values (corresponds to relative accuracy\n\ * abs(TOLMUL*EPS) in the largest singular value.\n\ * abs(TOLMUL) should be between 1 and 1/EPS, and preferably\n\ * between 10 (for fast convergence) and .1/EPS\n\ * (for there to be some accuracy in the results).\n\ * Default is to lose at either one eighth or 2 of the\n\ * available decimal digits in each computed singular value\n\ * (whichever is smaller).\n\ *\n\ * MAXITR INTEGER, default = 6\n\ * MAXITR controls the maximum number of passes of the\n\ * algorithm through its inner loop. The algorithms stops\n\ * (and so fails to converge) if the number of passes\n\ * through the inner loop exceeds MAXITR*N**2.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sla_syrcond0000644000175000017500000000746312502223526017542 0ustar uwabamiuwabami--- :name: sla_syrcond :md5sum: 5eaaae108449bbac6d01191c8809734f :category: :function :type: real :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - cmode: :type: integer :intent: input - c: :type: real :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: real :intent: input :dims: - 3*n - iwork: :type: integer :intent: input :dims: - n :substitutions: {} :fortran_help: " REAL FUNCTION SLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, IPIV, CMODE, C, INFO, WORK, IWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLA_SYRCOND estimates the Skeel condition number of op(A) * op2(C)\n\ * where op2 is determined by CMODE as follows\n\ * CMODE = 1 op2(C) = C\n\ * CMODE = 0 op2(C) = I\n\ * CMODE = -1 op2(C) = inv(C)\n\ * The Skeel condition number cond(A) = norminf( |inv(A)||A| )\n\ * is computed by computing scaling factors R such that\n\ * diag(R)*A*op2(C) is row equilibrated and computing the standard\n\ * infinity-norm condition number.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) REAL array, dimension (LDAF,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by SSYTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by SSYTRF.\n\ *\n\ * CMODE (input) INTEGER\n\ * Determines op2(C) in the formula op(A) * op2(C) as follows:\n\ * CMODE = 1 op2(C) = C\n\ * CMODE = 0 op2(C) = I\n\ * CMODE = -1 op2(C) = inv(C)\n\ *\n\ * C (input) REAL array, dimension (N)\n\ * The vector C in the formula op(A) * op2(C).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * i > 0: The ith argument is invalid.\n\ *\n\ * WORK (input) REAL array, dimension (3*N).\n\ * Workspace.\n\ *\n\ * IWORK (input) INTEGER array, dimension (N).\n\ * Workspace.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n CHARACTER NORMIN\n INTEGER KASE, I, J\n REAL AINVNM, SMLNUM, TMP\n LOGICAL UP\n\ * ..\n\ * .. Local Arrays ..\n INTEGER ISAVE( 3 )\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER ISAMAX\n REAL SLAMCH\n EXTERNAL LSAME, ISAMAX, SLAMCH\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SLACN2, SLATRS, SRSCL, XERBLA, SSYTRS\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zlapll0000644000175000017500000000361512502223526016513 0ustar uwabamiuwabami--- :name: zlapll :md5sum: f38274c6caef49904c71c30719914830 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - y: :type: doublecomplex :intent: input/output :dims: - 1+(n-1)*incy - incy: :type: integer :intent: input - ssmin: :type: doublereal :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZLAPLL( N, X, INCX, Y, INCY, SSMIN )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Given two column vectors X and Y, let\n\ *\n\ * A = ( X Y ).\n\ *\n\ * The subroutine first computes the QR factorization of A = Q*R,\n\ * and then computes the SVD of the 2-by-2 upper triangular matrix R.\n\ * The smaller singular value of R is returned in SSMIN, which is used\n\ * as the measurement of the linear dependency of the vectors X and Y.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The length of the vectors X and Y.\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX)\n\ * On entry, X contains the N-vector X.\n\ * On exit, X is overwritten.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between successive elements of X. INCX > 0.\n\ *\n\ * Y (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCY)\n\ * On entry, Y contains the N-vector Y.\n\ * On exit, Y is overwritten.\n\ *\n\ * INCY (input) INTEGER\n\ * The increment between successive elements of Y. INCY > 0.\n\ *\n\ * SSMIN (output) DOUBLE PRECISION\n\ * The smallest singular value of the N-by-2 matrix A = ( X Y ).\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssytrf0000644000175000017500000001444712502223526016554 0ustar uwabamiuwabami--- :name: ssytrf :md5sum: 838bea0e137071d39a87657d7a1c49ee :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSYTRF computes the factorization of a real symmetric matrix A using\n\ * the Bunch-Kaufman diagonal pivoting method. The form of the\n\ * factorization is\n\ *\n\ * A = U*D*U**T or A = L*D*L**T\n\ *\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, and D is symmetric and block diagonal with \n\ * 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\ * This is the blocked version of the algorithm, calling Level 3 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L (see below for further details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D.\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of WORK. LWORK >=1. For best performance\n\ * LWORK >= N*NB, where NB is the block size returned by ILAENV.\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, D(i,i) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular, and division by zero will occur if it\n\ * is used to solve a system of equations.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * If UPLO = 'U', then A = U*D*U', where\n\ * U = P(n)*U(n)* ... *P(k)U(k)* ...,\n\ * i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n\ * 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I v 0 ) k-s\n\ * U(k) = ( 0 I 0 ) s\n\ * ( 0 0 I ) n-k\n\ * k-s s n-k\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n\ * If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n\ * and A(k,k), and v overwrites A(1:k-2,k-1:k).\n\ *\n\ * If UPLO = 'L', then A = L*D*L', where\n\ * L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n\ * i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n\ * n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I 0 0 ) k-1\n\ * L(k) = ( 0 I 0 ) s\n\ * ( 0 v I ) n-k-s+1\n\ * k-1 s n-k-s+1\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n\ * If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n\ * and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LQUERY, UPPER\n INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SLASYF, SSYTF2, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zsprfs0000644000175000017500000001150512502223526016541 0ustar uwabamiuwabami--- :name: zsprfs :md5sum: 7caa9964208d29c528d9fd5d91110b07 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - afp: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSPRFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is symmetric indefinite\n\ * and packed, and provides error bounds and backward error estimates\n\ * for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * The upper or lower triangle of the symmetric matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * AFP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * The factored form of the matrix A. AFP contains the block\n\ * diagonal matrix D and the multipliers used to obtain the\n\ * factor U or L from the factorization A = U*D*U**T or\n\ * A = L*D*L**T as computed by ZSPTRF, stored as a packed\n\ * triangular matrix.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by ZSPTRF.\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by ZSPTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ztpttr0000644000175000017500000000445212502223526016564 0ustar uwabamiuwabami--- :name: ztpttr :md5sum: 5ed67b9d6cd4f4d7c52337ecbb99e07f :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - ldap - a: :type: doublecomplex :intent: output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: lda: MAX(1,n) n: ((int)sqrtf(ldap*8-1.0f)-1)/2 :fortran_help: " SUBROUTINE ZTPTTR( UPLO, N, AP, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTPTTR copies a triangular matrix A from standard packed format (TP)\n\ * to standard full format (TR).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular.\n\ * = 'L': A is lower triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n\ * On entry, the upper or lower triangular matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * A (output) COMPLEX*16 array, dimension ( LDA, N )\n\ * On exit, the triangular matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgetf20000644000175000017500000000452512502223525016367 0ustar uwabamiuwabami--- :name: cgetf2 :md5sum: 132de400e395cb5fa9f26913324c405d :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGETF2( M, N, A, LDA, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGETF2 computes an LU factorization of a general m-by-n matrix A\n\ * using partial pivoting with row interchanges.\n\ *\n\ * The factorization has the form\n\ * A = P * L * U\n\ * where P is a permutation matrix, L is lower triangular with unit\n\ * diagonal elements (lower trapezoidal if m > n), and U is upper\n\ * triangular (upper trapezoidal if m < n).\n\ *\n\ * This is the right-looking Level 2 BLAS version of the algorithm.\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) COMPLEX array, dimension (LDA,N)\n\ * On entry, the m by n matrix to be factored.\n\ * On exit, the factors L and U from the factorization\n\ * A = P*L*U; the unit diagonal elements of L are not stored.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * IPIV (output) INTEGER array, dimension (min(M,N))\n\ * The pivot indices; for 1 <= i <= min(M,N), row i of the\n\ * matrix was interchanged with row IPIV(i).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ * > 0: if INFO = k, U(k,k) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, and division by zero will occur if it is used\n\ * to solve a system of equations.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhsein0000644000175000017500000001673212502223526016521 0ustar uwabamiuwabami--- :name: zhsein :md5sum: e2281999ac422c1eb5a43a6ce31f629e :category: :subroutine :arguments: - side: :type: char :intent: input - eigsrc: :type: char :intent: input - initv: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - h: :type: doublecomplex :intent: input :dims: - ldh - n - ldh: :type: integer :intent: input - w: :type: doublecomplex :intent: input/output :dims: - n - vl: :type: doublecomplex :intent: input/output :dims: - ldvl - mm - ldvl: :type: integer :intent: input - vr: :type: doublecomplex :intent: input/output :dims: - ldvr - mm - ldvr: :type: integer :intent: input - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: doublecomplex :intent: workspace :dims: - n*n - rwork: :type: doublereal :intent: workspace :dims: - n - ifaill: :type: integer :intent: output :dims: - mm - ifailr: :type: integer :intent: output :dims: - mm - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, W, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, IFAILL, IFAILR, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHSEIN uses inverse iteration to find specified right and/or left\n\ * eigenvectors of a complex upper Hessenberg matrix H.\n\ *\n\ * The right eigenvector x and the left eigenvector y of the matrix H\n\ * corresponding to an eigenvalue w are defined by:\n\ *\n\ * H * x = w * x, y**h * H = w * y**h\n\ *\n\ * where y**h denotes the conjugate transpose of the vector y.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'R': compute right eigenvectors only;\n\ * = 'L': compute left eigenvectors only;\n\ * = 'B': compute both right and left eigenvectors.\n\ *\n\ * EIGSRC (input) CHARACTER*1\n\ * Specifies the source of eigenvalues supplied in W:\n\ * = 'Q': the eigenvalues were found using ZHSEQR; thus, if\n\ * H has zero subdiagonal elements, and so is\n\ * block-triangular, then the j-th eigenvalue can be\n\ * assumed to be an eigenvalue of the block containing\n\ * the j-th row/column. This property allows ZHSEIN to\n\ * perform inverse iteration on just one diagonal block.\n\ * = 'N': no assumptions are made on the correspondence\n\ * between eigenvalues and diagonal blocks. In this\n\ * case, ZHSEIN must always perform inverse iteration\n\ * using the whole matrix H.\n\ *\n\ * INITV (input) CHARACTER*1\n\ * = 'N': no initial vectors are supplied;\n\ * = 'U': user-supplied initial vectors are stored in the arrays\n\ * VL and/or VR.\n\ *\n\ * SELECT (input) LOGICAL array, dimension (N)\n\ * Specifies the eigenvectors to be computed. To select the\n\ * eigenvector corresponding to the eigenvalue W(j),\n\ * SELECT(j) must be set to .TRUE..\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H. N >= 0.\n\ *\n\ * H (input) COMPLEX*16 array, dimension (LDH,N)\n\ * The upper Hessenberg matrix H.\n\ *\n\ * LDH (input) INTEGER\n\ * The leading dimension of the array H. LDH >= max(1,N).\n\ *\n\ * W (input/output) COMPLEX*16 array, dimension (N)\n\ * On entry, the eigenvalues of H.\n\ * On exit, the real parts of W may have been altered since\n\ * close eigenvalues are perturbed slightly in searching for\n\ * independent eigenvectors.\n\ *\n\ * VL (input/output) COMPLEX*16 array, dimension (LDVL,MM)\n\ * On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must\n\ * contain starting vectors for the inverse iteration for the\n\ * left eigenvectors; the starting vector for each eigenvector\n\ * must be in the same column in which the eigenvector will be\n\ * stored.\n\ * On exit, if SIDE = 'L' or 'B', the left eigenvectors\n\ * specified by SELECT will be stored consecutively in the\n\ * columns of VL, in the same order as their eigenvalues.\n\ * If SIDE = 'R', VL is not referenced.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the array VL.\n\ * LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.\n\ *\n\ * VR (input/output) COMPLEX*16 array, dimension (LDVR,MM)\n\ * On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must\n\ * contain starting vectors for the inverse iteration for the\n\ * right eigenvectors; the starting vector for each eigenvector\n\ * must be in the same column in which the eigenvector will be\n\ * stored.\n\ * On exit, if SIDE = 'R' or 'B', the right eigenvectors\n\ * specified by SELECT will be stored consecutively in the\n\ * columns of VR, in the same order as their eigenvalues.\n\ * If SIDE = 'L', VR is not referenced.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the array VR.\n\ * LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.\n\ *\n\ * MM (input) INTEGER\n\ * The number of columns in the arrays VL and/or VR. MM >= M.\n\ *\n\ * M (output) INTEGER\n\ * The number of columns in the arrays VL and/or VR required to\n\ * store the eigenvectors (= the number of .TRUE. elements in\n\ * SELECT).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (N*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * IFAILL (output) INTEGER array, dimension (MM)\n\ * If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left\n\ * eigenvector in the i-th column of VL (corresponding to the\n\ * eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the\n\ * eigenvector converged satisfactorily.\n\ * If SIDE = 'R', IFAILL is not referenced.\n\ *\n\ * IFAILR (output) INTEGER array, dimension (MM)\n\ * If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right\n\ * eigenvector in the i-th column of VR (corresponding to the\n\ * eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the\n\ * eigenvector converged satisfactorily.\n\ * If SIDE = 'L', IFAILR is not referenced.\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, i is the number of eigenvectors which\n\ * failed to converge; see IFAILL and IFAILR for further\n\ * details.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Each eigenvector is normalized so that the element of largest\n\ * magnitude has magnitude 1; here the magnitude of a complex number\n\ * (x,y) is taken to be |x|+|y|.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cpprfs0000644000175000017500000001065612502223525016514 0ustar uwabamiuwabami--- :name: cpprfs :md5sum: 8a43d4e4a0ca70bf33d98b675e1af06b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - afp: :type: complex :intent: input :dims: - n*(n+1)/2 - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ldb :fortran_help: " SUBROUTINE CPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPPRFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is Hermitian positive definite\n\ * and packed, and provides error bounds and backward error estimates\n\ * for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AP (input) COMPLEX array, dimension (N*(N+1)/2)\n\ * The upper or lower triangle of the Hermitian matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * AFP (input) COMPLEX array, dimension (N*(N+1)/2)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**H*U or A = L*L**H, as computed by SPPTRF/CPPTRF,\n\ * packed columnwise in a linear array in the same format as A\n\ * (see AP).\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) COMPLEX array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by CPPTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * ====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsytri20000644000175000017500000000737012502223526016617 0ustar uwabamiuwabami--- :name: dsytri2 :md5sum: 55abdf3e0f382d7920cd2955e9f19249 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublereal :intent: workspace :dims: - lwork - lwork: :type: integer :intent: input :option: true :default: (n+nb+1)*(nb+3) - info: :type: integer :intent: output :substitutions: c__1: "1" c__m1: "-1" nb: ilaenv_(&c__1, "DSYTRF", &uplo, &n, &c__m1, &c__m1, &c__m1) :extras: c__1: integer c__m1: integer nb: integer :fortran_help: " SUBROUTINE DSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSYTRI2 computes the inverse of a real symmetric indefinite matrix\n\ * A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n\ * DSYTRF. DSYTRI2 sets the LEADING DIMENSION of the workspace\n\ * before calling DSYTRI2X that actually computes the inverse.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the NB diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L as computed by DSYTRF.\n\ *\n\ * On exit, if INFO = 0, the (symmetric) inverse of the original\n\ * matrix. If UPLO = 'U', the upper triangular part of the\n\ * inverse is formed and the part of A below the diagonal is not\n\ * referenced; if UPLO = 'L' the lower triangular part of the\n\ * inverse is formed and the part of A above the diagonal is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the NB structure of D\n\ * as determined by DSYTRF.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (N+NB+1)*(NB+3)\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK.\n\ * WORK is size >= (N+NB+1)*(NB+3)\n\ * If LDWORK = -1, then a workspace query is assumed; the routine\n\ * calculates:\n\ * - the optimal size of the WORK array, returns\n\ * this value as the first entry of the WORK array,\n\ * - and no error message related to LDWORK 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, D(i,i) = 0; the matrix is singular and its\n\ * inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL UPPER, LQUERY\n INTEGER MINSIZE, NBMAX\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DSYTRI2X\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dgelsx0000644000175000017500000001205612502223526016502 0ustar uwabamiuwabami--- :name: dgelsx :md5sum: 8510818f8072eca24262ab83fcc2c9b9 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - rcond: :type: doublereal :intent: input - rank: :type: integer :intent: output - work: :type: doublereal :intent: workspace :dims: - MAX((MIN(m,n))+3*n,2*(MIN(m,n))*nrhs) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This routine is deprecated and has been replaced by routine DGELSY.\n\ *\n\ * DGELSX computes the minimum-norm solution to a real linear least\n\ * squares problem:\n\ * minimize || A * X - B ||\n\ * using a complete orthogonal factorization of A. A is an M-by-N\n\ * matrix which may be rank-deficient.\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\ * The routine first computes a QR factorization with column pivoting:\n\ * A * P = Q * [ R11 R12 ]\n\ * [ 0 R22 ]\n\ * with R11 defined as the largest leading submatrix whose estimated\n\ * condition number is less than 1/RCOND. The order of R11, RANK,\n\ * is the effective rank of A.\n\ *\n\ * Then, R22 is considered to be negligible, and R12 is annihilated\n\ * by orthogonal transformations from the right, arriving at the\n\ * complete orthogonal factorization:\n\ * A * P = Q * [ T11 0 ] * Z\n\ * [ 0 0 ]\n\ * The minimum-norm solution is then\n\ * X = P * Z' [ inv(T11)*Q1'*B ]\n\ * [ 0 ]\n\ * where Q1 consists of the first RANK columns of 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\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of\n\ * columns of 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, A has been overwritten by details of its\n\ * complete orthogonal factorization.\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 M-by-NRHS right hand side matrix B.\n\ * On exit, the N-by-NRHS solution matrix X.\n\ * If m >= n and RANK = n, the residual sum-of-squares for\n\ * the solution in the i-th column is given by the sum of\n\ * squares of elements N+1:M in that column.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,M,N).\n\ *\n\ * JPVT (input/output) INTEGER array, dimension (N)\n\ * On entry, if JPVT(i) .ne. 0, the i-th column of A is an\n\ * initial column, otherwise it is a free column. Before\n\ * the QR factorization of A, all initial columns are\n\ * permuted to the leading positions; only the remaining\n\ * free columns are moved as a result of column pivoting\n\ * during the factorization.\n\ * On exit, if JPVT(i) = k, then the i-th column of A*P\n\ * was the k-th column of A.\n\ *\n\ * RCOND (input) DOUBLE PRECISION\n\ * RCOND is used to determine the effective rank of A, which\n\ * is defined as the order of the largest leading triangular\n\ * submatrix R11 in the QR factorization with pivoting of A,\n\ * whose estimated condition number < 1/RCOND.\n\ *\n\ * RANK (output) INTEGER\n\ * The effective rank of A, i.e., the order of the submatrix\n\ * R11. This is the same as the order of the submatrix T11\n\ * in the complete orthogonal factorization of A.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension\n\ * (max( min(M,N)+3*N, 2*min(M,N)+NRHS )),\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zherfsx0000644000175000017500000003761412502223526016714 0ustar uwabamiuwabami--- :name: zherfsx :md5sum: c5087f3ef812132fa16bb2e388fa2bc3 :category: :subroutine :arguments: - uplo: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " SUBROUTINE ZHERFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHERFSX improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is Hermitian indefinite, and\n\ * provides error bounds and backward error estimates for the\n\ * solution. In addition to normwise error bound, the code provides\n\ * maximum componentwise error bound if possible. See comments for\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.\n\ *\n\ * The original system of linear equations may have been equilibrated\n\ * before calling this routine, as described by arguments EQUED and S\n\ * below. In this case, the solution and error bounds returned are\n\ * for the original unequilibrated system.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * EQUED (input) CHARACTER*1\n\ * Specifies the form of equilibration that was done to A\n\ * before calling this routine. This is needed to compute\n\ * the solution and error bounds correctly.\n\ * = 'N': No equilibration\n\ * = 'Y': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(S) * A * diag(S).\n\ * The right hand side B has been changed accordingly.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular\n\ * part of the matrix A, and the strictly lower triangular\n\ * part of A is not referenced. If UPLO = 'L', the leading\n\ * N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX*16 array, dimension (LDAF,N)\n\ * The factored form of the matrix A. AF contains the block\n\ * diagonal matrix D and the multipliers used to obtain the\n\ * factor U or L from the factorization A = U*D*U**T or A =\n\ * L*D*L**T as computed by DSYTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by DSYTRF.\n\ *\n\ * S (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The scale factors for A. If EQUED = 'Y', A is multiplied on\n\ * the left and right by diag(S). S is an input argument if FACT =\n\ * 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n\ * = 'Y', each element of S must be positive. If S is output, each\n\ * element of S is a power of the radix. If S is input, each element\n\ * of S should be a power of the radix to ensure a reliable solution\n\ * and error estimates. Scaling by powers of the radix does not cause\n\ * rounding errors unless the result underflows or overflows.\n\ * Rounding errors during scaling lead to refining with a matrix that\n\ * is not equivalent to the input matrix, producing error estimates\n\ * that may not be reliable.\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by DGETRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * Componentwise relative backward error. This is the\n\ * componentwise relative backward error of each solution vector X(j)\n\ * (i.e., the smallest relative change in any element of A or B that\n\ * makes X(j) an exact solution).\n\ *\n\ * N_ERR_BNDS (input) INTEGER\n\ * Number of error bounds to return for each right hand side\n\ * and each type (normwise or componentwise). See ERR_BNDS_NORM and\n\ * ERR_BNDS_COMP below.\n\ *\n\ * ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * dlamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * dlamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * dlamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * dlamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * dlamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * dlamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * NPARAMS (input) INTEGER\n\ * Specifies the number of parameters set in PARAMS. If .LE. 0, the\n\ * PARAMS array is never referenced and default values are used.\n\ *\n\ * PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS\n\ * Specifies algorithm parameters. If an entry is .LT. 0.0, then\n\ * that entry will be filled with default value used for that\n\ * parameter. Only positions up to NPARAMS are accessed; defaults\n\ * are used for higher-numbered parameters.\n\ *\n\ * PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n\ * refinement or not.\n\ * Default: 1.0D+0\n\ * = 0.0 : No refinement is performed, and no error bounds are\n\ * computed.\n\ * = 1.0 : Use the double-precision refinement algorithm,\n\ * possibly with doubled-single computations if the\n\ * compilation environment does not support DOUBLE\n\ * PRECISION.\n\ * (other values are reserved for future use)\n\ *\n\ * PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n\ * computations allowed for refinement.\n\ * Default: 10\n\ * Aggressive: Set to 100 to permit convergence using approximate\n\ * factorizations or factorizations other than LU. If\n\ * the factorization uses a technique other than\n\ * Gaussian elimination, the guarantees in\n\ * err_bnds_norm and err_bnds_comp may no longer be\n\ * trustworthy.\n\ *\n\ * PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n\ * will attempt to find a solution with small componentwise\n\ * relative error in the double-precision algorithm. Positive\n\ * is true, 0.0 is false.\n\ * Default: 1.0 (attempt componentwise convergence)\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit. The solution to every right-hand side is\n\ * guaranteed.\n\ * < 0: If INFO = -i, the i-th argument had an illegal value\n\ * > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlarfgp0000644000175000017500000000362312502223526016633 0ustar uwabamiuwabami--- :name: dlarfgp :md5sum: 89a34e78357d879182ce8b4d6c766cdb :category: :subroutine :arguments: - n: :type: integer :intent: input - alpha: :type: doublereal :intent: input/output - x: :type: doublereal :intent: input/output :dims: - 1+(n-2)*abs(incx) - incx: :type: integer :intent: input - tau: :type: doublereal :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLARFGP( N, ALPHA, X, INCX, TAU )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLARFGP generates a real elementary reflector H of order n, such\n\ * that\n\ *\n\ * H * ( alpha ) = ( beta ), H' * H = I.\n\ * ( x ) ( 0 )\n\ *\n\ * where alpha and beta are scalars, beta is non-negative, and x is\n\ * an (n-1)-element real vector. H is represented in the form\n\ *\n\ * H = I - tau * ( 1 ) * ( 1 v' ) ,\n\ * ( v )\n\ *\n\ * where tau is a real scalar and v is a real (n-1)-element\n\ * vector.\n\ *\n\ * If the elements of x are all zero, then tau = 0 and H is taken to be\n\ * the unit matrix.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the elementary reflector.\n\ *\n\ * ALPHA (input/output) DOUBLE PRECISION\n\ * On entry, the value alpha.\n\ * On exit, it is overwritten with the value beta.\n\ *\n\ * X (input/output) DOUBLE PRECISION array, dimension\n\ * (1+(N-2)*abs(INCX))\n\ * On entry, the vector x.\n\ * On exit, it is overwritten with the vector v.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between elements of X. INCX > 0.\n\ *\n\ * TAU (output) DOUBLE PRECISION\n\ * The value tau.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ilaver0000644000175000017500000000223412502223526016473 0ustar uwabamiuwabami--- :name: ilaver :md5sum: ae154117d9ef11e8dc514356ed2ec2ad :category: :subroutine :arguments: - vers_major: :type: integer :intent: output - vers_minor: :type: integer :intent: output - vers_patch: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This subroutine return the Lapack version.\n\ *\n\n\ * Arguments\n\ * =========\n\ * VERS_MAJOR (output) INTEGER\n\ * return the lapack major version\n\ * VERS_MINOR (output) INTEGER\n\ * return the lapack minor version from the major version\n\ * VERS_PATCH (output) INTEGER\n\ * return the lapack patch version from the minor version\n\n\ * =====================================================================\n\ *\n INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH\n\ * =====================================================================\n VERS_MAJOR = 3\n VERS_MINOR = 3\n VERS_PATCH = 0\n\ * =====================================================================\n\ *\n RETURN\n END\n" ruby-lapack-1.7.2/dev/defs/dhseqr0000644000175000017500000003010112502223526016471 0ustar uwabamiuwabami--- :name: dhseqr :md5sum: b1117e715390f2b96127cf6b714d4ccf :category: :subroutine :arguments: - job: :type: char :intent: input - compz: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: doublereal :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - wr: :type: doublereal :intent: output :dims: - n - wi: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: input/output :dims: - "lsame_(&compz,\"N\") ? 0 : ldz" - "lsame_(&compz,\"N\") ? 0 : n" - ldz: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, LDZ, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DHSEQR computes the eigenvalues of a Hessenberg matrix H\n\ * and, optionally, the matrices T and Z from the Schur decomposition\n\ * H = Z T Z**T, where T is an upper quasi-triangular matrix (the\n\ * Schur form), and Z is the orthogonal matrix of Schur vectors.\n\ *\n\ * Optionally Z may be postmultiplied into an input orthogonal\n\ * matrix Q so that this routine can give the Schur factorization\n\ * of a matrix A which has been reduced to the Hessenberg form H\n\ * by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * = 'E': compute eigenvalues only;\n\ * = 'S': compute eigenvalues and the Schur form T.\n\ *\n\ * COMPZ (input) CHARACTER*1\n\ * = 'N': no Schur vectors are computed;\n\ * = 'I': Z is initialized to the unit matrix and the matrix Z\n\ * of Schur vectors of H is returned;\n\ * = 'V': Z must contain an orthogonal matrix Q on entry, and\n\ * the product Q*Z is returned.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H. N .GE. 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * It is assumed that H is already upper triangular in rows\n\ * and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n\ * set by a previous call to DGEBAL, and then passed to DGEHRD\n\ * when the matrix output by DGEBAL is reduced to Hessenberg\n\ * form. Otherwise ILO and IHI should be set to 1 and N\n\ * respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n\ * If N = 0, then ILO = 1 and IHI = 0.\n\ *\n\ * H (input/output) DOUBLE PRECISION array, dimension (LDH,N)\n\ * On entry, the upper Hessenberg matrix H.\n\ * On exit, if INFO = 0 and JOB = 'S', then H contains the\n\ * upper quasi-triangular matrix T from the Schur decomposition\n\ * (the Schur form); 2-by-2 diagonal blocks (corresponding to\n\ * complex conjugate pairs of eigenvalues) are returned in\n\ * standard form, with H(i,i) = H(i+1,i+1) and\n\ * H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and JOB = 'E', the\n\ * contents of H are unspecified on exit. (The output value of\n\ * H when INFO.GT.0 is given under the description of INFO\n\ * below.)\n\ *\n\ * Unlike earlier versions of DHSEQR, this subroutine may\n\ * explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1\n\ * or j = IHI+1, IHI+2, ... N.\n\ *\n\ * LDH (input) INTEGER\n\ * The leading dimension of the array H. LDH .GE. max(1,N).\n\ *\n\ * WR (output) DOUBLE PRECISION array, dimension (N)\n\ * WI (output) DOUBLE PRECISION array, dimension (N)\n\ * The real and imaginary parts, respectively, of the computed\n\ * eigenvalues. If two eigenvalues are computed as a complex\n\ * conjugate pair, they are stored in consecutive elements of\n\ * WR and WI, say the i-th and (i+1)th, with WI(i) .GT. 0 and\n\ * WI(i+1) .LT. 0. If JOB = 'S', the eigenvalues are stored in\n\ * the same order as on the diagonal of the Schur form returned\n\ * in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2\n\ * diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and\n\ * WI(i+1) = -WI(i).\n\ *\n\ * Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n\ * If COMPZ = 'N', Z is not referenced.\n\ * If COMPZ = 'I', on entry Z need not be set and on exit,\n\ * if INFO = 0, Z contains the orthogonal matrix Z of the Schur\n\ * vectors of H. If COMPZ = 'V', on entry Z must contain an\n\ * N-by-N matrix Q, which is assumed to be equal to the unit\n\ * matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,\n\ * if INFO = 0, Z contains Q*Z.\n\ * Normally Q is the orthogonal matrix generated by DORGHR\n\ * after the call to DGEHRD which formed the Hessenberg matrix\n\ * H. (The output value of Z when INFO.GT.0 is given under\n\ * the description of INFO below.)\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. if COMPZ = 'I' or\n\ * COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1.\n\ *\n\ * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)\n\ * On exit, if INFO = 0, WORK(1) returns an estimate of\n\ * the optimal value for LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK .GE. max(1,N)\n\ * is sufficient and delivers very good and sometimes\n\ * optimal performance. However, LWORK as large as 11*N\n\ * may be required for optimal performance. A workspace\n\ * query is recommended to determine the optimal workspace\n\ * size.\n\ *\n\ * If LWORK = -1, then DHSEQR does a workspace query.\n\ * In this case, DHSEQR checks the input parameters and\n\ * estimates the optimal workspace size for the given\n\ * values of N, ILO and IHI. The estimate is returned\n\ * in WORK(1). No error message related to LWORK is\n\ * issued by XERBLA. Neither H nor Z are accessed.\n\ *\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * .LT. 0: if INFO = -i, the i-th argument had an illegal\n\ * value\n\ * .GT. 0: if INFO = i, DHSEQR failed to compute all of\n\ * the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n\ * and WI contain those eigenvalues which have been\n\ * successfully computed. (Failures are rare.)\n\ *\n\ * If INFO .GT. 0 and JOB = 'E', then on exit, the\n\ * remaining unconverged eigenvalues are the eigen-\n\ * values of the upper Hessenberg matrix rows and\n\ * columns ILO through INFO of the final, output\n\ * value of H.\n\ *\n\ * If INFO .GT. 0 and JOB = 'S', then on exit\n\ *\n\ * (*) (initial value of H)*U = U*(final value of H)\n\ *\n\ * where U is an orthogonal matrix. The final\n\ * value of H is upper Hessenberg and quasi-triangular\n\ * in rows and columns INFO+1 through IHI.\n\ *\n\ * If INFO .GT. 0 and COMPZ = 'V', then on exit\n\ *\n\ * (final value of Z) = (initial value of Z)*U\n\ *\n\ * where U is the orthogonal matrix in (*) (regard-\n\ * less of the value of JOB.)\n\ *\n\ * If INFO .GT. 0 and COMPZ = 'I', then on exit\n\ * (final value of Z) = U\n\ * where U is the orthogonal matrix in (*) (regard-\n\ * less of the value of JOB.)\n\ *\n\ * If INFO .GT. 0 and COMPZ = 'N', then Z is not\n\ * accessed.\n\ *\n\n\ * ================================================================\n\ * Default values supplied by\n\ * ILAENV(ISPEC,'DHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).\n\ * It is suggested that these defaults be adjusted in order\n\ * to attain best performance in each particular\n\ * computational environment.\n\ *\n\ * ISPEC=12: The DLAHQR vs DLAQR0 crossover point.\n\ * Default: 75. (Must be at least 11.)\n\ *\n\ * ISPEC=13: Recommended deflation window size.\n\ * This depends on ILO, IHI and NS. NS is the\n\ * number of simultaneous shifts returned\n\ * by ILAENV(ISPEC=15). (See ISPEC=15 below.)\n\ * The default for (IHI-ILO+1).LE.500 is NS.\n\ * The default for (IHI-ILO+1).GT.500 is 3*NS/2.\n\ *\n\ * ISPEC=14: Nibble crossover point. (See IPARMQ for\n\ * details.) Default: 14% of deflation window\n\ * size.\n\ *\n\ * ISPEC=15: Number of simultaneous shifts in a multishift\n\ * QR iteration.\n\ *\n\ * If IHI-ILO+1 is ...\n\ *\n\ * greater than ...but less ... the\n\ * or equal to ... than default is\n\ *\n\ * 1 30 NS = 2(+)\n\ * 30 60 NS = 4(+)\n\ * 60 150 NS = 10(+)\n\ * 150 590 NS = **\n\ * 590 3000 NS = 64\n\ * 3000 6000 NS = 128\n\ * 6000 infinity NS = 256\n\ *\n\ * (+) By default some or all matrices of this order\n\ * are passed to the implicit double shift routine\n\ * DLAHQR and this parameter is ignored. See\n\ * ISPEC=12 above and comments in IPARMQ for\n\ * details.\n\ *\n\ * (**) The asterisks (**) indicate an ad-hoc\n\ * function of N increasing from 10 to 64.\n\ *\n\ * ISPEC=16: Select structured matrix multiply.\n\ * If the number of simultaneous shifts (specified\n\ * by ISPEC=15) is less than 14, then the default\n\ * for ISPEC=16 is 0. Otherwise the default for\n\ * ISPEC=16 is 2.\n\ *\n\ * ================================================================\n\ * Based on contributions by\n\ * Karen Braman and Ralph Byers, Department of Mathematics,\n\ * University of Kansas, USA\n\ *\n\ * ================================================================\n\ * References:\n\ * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n\ * Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n\ * Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n\ * 929--947, 2002.\n\ *\n\ * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n\ * Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n\ * of Matrix Analysis, volume 23, pages 948--973, 2002.\n\ *\n\ * ================================================================\n" ruby-lapack-1.7.2/dev/defs/chptrd0000644000175000017500000000765712502223525016512 0ustar uwabamiuwabami--- :name: chptrd :md5sum: a3029585e3226a50f649c5b9511928e4 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - ldap - d: :type: real :intent: output :dims: - n - e: :type: real :intent: output :dims: - n-1 - tau: :type: complex :intent: output :dims: - n-1 - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE CHPTRD( UPLO, N, AP, D, E, TAU, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHPTRD reduces a complex Hermitian matrix A stored in packed form to\n\ * real symmetric tridiagonal form T by a unitary similarity\n\ * transformation: Q**H * A * Q = T.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ * On exit, if UPLO = 'U', the diagonal and first superdiagonal\n\ * of A are overwritten by the corresponding elements of the\n\ * tridiagonal matrix T, and the elements above the first\n\ * superdiagonal, with the array TAU, represent the unitary\n\ * matrix Q as a product of elementary reflectors; if UPLO\n\ * = 'L', the diagonal and first subdiagonal of A are over-\n\ * written by the corresponding elements of the tridiagonal\n\ * matrix T, and the elements below the first subdiagonal, with\n\ * the array TAU, represent the unitary matrix Q as a product\n\ * of elementary reflectors. See Further Details.\n\ *\n\ * D (output) REAL array, dimension (N)\n\ * The diagonal elements of the tridiagonal matrix T:\n\ * D(i) = A(i,i).\n\ *\n\ * E (output) REAL array, dimension (N-1)\n\ * The off-diagonal elements of the tridiagonal matrix T:\n\ * E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n\ *\n\ * TAU (output) COMPLEX array, dimension (N-1)\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\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\ * If UPLO = 'U', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(n-1) . . . H(2) H(1).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar, and v is a complex vector with\n\ * v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,\n\ * overwriting A(1:i-1,i+1), and tau is stored in TAU(i).\n\ *\n\ * If UPLO = 'L', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(n-1).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar, and v is a complex vector with\n\ * v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,\n\ * overwriting A(i+2:n,i), and tau is stored in TAU(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlaqr50000644000175000017500000001627012502223526016434 0ustar uwabamiuwabami--- :name: zlaqr5 :md5sum: de74b49e2130ffd48980da890514c237 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - kacc22: :type: integer :intent: input - n: :type: integer :intent: input - ktop: :type: integer :intent: input - kbot: :type: integer :intent: input - nshfts: :type: integer :intent: input - s: :type: doublecomplex :intent: input/output :dims: - nshfts - h: :type: doublecomplex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: doublecomplex :intent: input/output :dims: - "wantz ? ldz : 0" - "wantz ? ihiz : 0" - ldz: :type: integer :intent: input - v: :type: doublecomplex :intent: workspace :dims: - ldv - nshfts/2 - ldv: :type: integer :intent: input - u: :type: doublecomplex :intent: workspace :dims: - ldu - 3*nshfts-3 - ldu: :type: integer :intent: input - nv: :type: integer :intent: input - wv: :type: doublecomplex :intent: workspace :dims: - ldwv - 3*nshfts-3 - ldwv: :type: integer :intent: input - nh: :type: integer :intent: input - wh: :type: doublecomplex :intent: workspace :dims: - ldwh - MAX(1,nh) - ldwh: :type: integer :intent: input :substitutions: ldwh: 3*nshfts-3 ldwv: nv ldu: 3*nshfts-3 ldv: "3" :fortran_help: " SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, WV, LDWV, NH, WH, LDWH )\n\n\ * This auxiliary subroutine called by ZLAQR0 performs a\n\ * single small-bulge multi-shift QR sweep.\n\ *\n\n\ * WANTT (input) logical scalar\n\ * WANTT = .true. if the triangular Schur factor\n\ * is being computed. WANTT is set to .false. otherwise.\n\ *\n\ * WANTZ (input) logical scalar\n\ * WANTZ = .true. if the unitary Schur factor is being\n\ * computed. WANTZ is set to .false. otherwise.\n\ *\n\ * KACC22 (input) integer with value 0, 1, or 2.\n\ * Specifies the computation mode of far-from-diagonal\n\ * orthogonal updates.\n\ * = 0: ZLAQR5 does not accumulate reflections and does not\n\ * use matrix-matrix multiply to update far-from-diagonal\n\ * matrix entries.\n\ * = 1: ZLAQR5 accumulates reflections and uses matrix-matrix\n\ * multiply to update the far-from-diagonal matrix entries.\n\ * = 2: ZLAQR5 accumulates reflections, uses matrix-matrix\n\ * multiply to update the far-from-diagonal matrix entries,\n\ * and takes advantage of 2-by-2 block structure during\n\ * matrix multiplies.\n\ *\n\ * N (input) integer scalar\n\ * N is the order of the Hessenberg matrix H upon which this\n\ * subroutine operates.\n\ *\n\ * KTOP (input) integer scalar\n\ * KBOT (input) integer scalar\n\ * These are the first and last rows and columns of an\n\ * isolated diagonal block upon which the QR sweep is to be\n\ * applied. It is assumed without a check that\n\ * either KTOP = 1 or H(KTOP,KTOP-1) = 0\n\ * and\n\ * either KBOT = N or H(KBOT+1,KBOT) = 0.\n\ *\n\ * NSHFTS (input) integer scalar\n\ * NSHFTS gives the number of simultaneous shifts. NSHFTS\n\ * must be positive and even.\n\ *\n\ * S (input/output) COMPLEX*16 array of size (NSHFTS)\n\ * S contains the shifts of origin that define the multi-\n\ * shift QR sweep. On output S may be reordered.\n\ *\n\ * H (input/output) COMPLEX*16 array of size (LDH,N)\n\ * On input H contains a Hessenberg matrix. On output a\n\ * multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied\n\ * to the isolated diagonal block in rows and columns KTOP\n\ * through KBOT.\n\ *\n\ * LDH (input) integer scalar\n\ * LDH is the leading dimension of H just as declared in the\n\ * calling procedure. LDH.GE.MAX(1,N).\n\ *\n\ * ILOZ (input) INTEGER\n\ * IHIZ (input) INTEGER\n\ * Specify the rows of Z to which transformations must be\n\ * applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N\n\ *\n\ * Z (input/output) COMPLEX*16 array of size (LDZ,IHI)\n\ * If WANTZ = .TRUE., then the QR Sweep unitary\n\ * similarity transformation is accumulated into\n\ * Z(ILOZ:IHIZ,ILO:IHI) from the right.\n\ * If WANTZ = .FALSE., then Z is unreferenced.\n\ *\n\ * LDZ (input) integer scalar\n\ * LDA is the leading dimension of Z just as declared in\n\ * the calling procedure. LDZ.GE.N.\n\ *\n\ * V (workspace) COMPLEX*16 array of size (LDV,NSHFTS/2)\n\ *\n\ * LDV (input) integer scalar\n\ * LDV is the leading dimension of V as declared in the\n\ * calling procedure. LDV.GE.3.\n\ *\n\ * U (workspace) COMPLEX*16 array of size\n\ * (LDU,3*NSHFTS-3)\n\ *\n\ * LDU (input) integer scalar\n\ * LDU is the leading dimension of U just as declared in the\n\ * in the calling subroutine. LDU.GE.3*NSHFTS-3.\n\ *\n\ * NH (input) integer scalar\n\ * NH is the number of columns in array WH available for\n\ * workspace. NH.GE.1.\n\ *\n\ * WH (workspace) COMPLEX*16 array of size (LDWH,NH)\n\ *\n\ * LDWH (input) integer scalar\n\ * Leading dimension of WH just as declared in the\n\ * calling procedure. LDWH.GE.3*NSHFTS-3.\n\ *\n\ * NV (input) integer scalar\n\ * NV is the number of rows in WV agailable for workspace.\n\ * NV.GE.1.\n\ *\n\ * WV (workspace) COMPLEX*16 array of size\n\ * (LDWV,3*NSHFTS-3)\n\ *\n\ * LDWV (input) integer scalar\n\ * LDWV is the leading dimension of WV as declared in the\n\ * in the calling subroutine. LDWV.GE.NV.\n\ *\n\n\ * ================================================================\n\ * Based on contributions by\n\ * Karen Braman and Ralph Byers, Department of Mathematics,\n\ * University of Kansas, USA\n\ *\n\ * ================================================================\n\ * Reference:\n\ *\n\ * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n\ * Algorithm Part I: Maintaining Well Focused Shifts, and\n\ * Level 3 Performance, SIAM Journal of Matrix Analysis,\n\ * volume 23, pages 929--947, 2002.\n\ *\n\ * ================================================================\n" ruby-lapack-1.7.2/dev/defs/ctgsen0000644000175000017500000003736312502223525016506 0ustar uwabamiuwabami--- :name: ctgsen :md5sum: 611f676b24131fa01861ff97339e1db5 :category: :subroutine :arguments: - ijob: :type: integer :intent: input - wantq: :type: logical :intent: input - wantz: :type: logical :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alpha: :type: complex :intent: output :dims: - n - beta: :type: complex :intent: output :dims: - n - q: :type: complex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - z: :type: complex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - m: :type: integer :intent: output - pl: :type: real :intent: output - pr: :type: real :intent: output - dif: :type: real :intent: output :dims: - "2" - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(ijob==1||ijob==2||ijob==4) ? 2*m*(n-m) : (ijob==3||ijob==5) ? 4*m*(n-m) : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "(ijob==1||ijob==2||ijob==4) ? n+2 : (ijob==3||ijob==5) ? 2*m*(n-m) : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTGSEN reorders the generalized Schur decomposition of a complex\n\ * matrix pair (A, B) (in terms of an unitary equivalence trans-\n\ * formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues\n\ * appears in the leading diagonal blocks of the pair (A,B). The leading\n\ * columns of Q and Z form unitary bases of the corresponding left and\n\ * right eigenspaces (deflating subspaces). (A, B) must be in\n\ * generalized Schur canonical form, that is, A and B are both upper\n\ * triangular.\n\ *\n\ * CTGSEN also computes the generalized eigenvalues\n\ *\n\ * w(j)= ALPHA(j) / BETA(j)\n\ *\n\ * of the reordered matrix pair (A, B).\n\ *\n\ * Optionally, the routine computes estimates of reciprocal condition\n\ * numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),\n\ * (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)\n\ * between the matrix pairs (A11, B11) and (A22,B22) that correspond to\n\ * the selected cluster and the eigenvalues outside the cluster, resp.,\n\ * and norms of \"projections\" onto left and right eigenspaces w.r.t.\n\ * the selected cluster in the (1,1)-block.\n\ *\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * IJOB (input) integer\n\ * Specifies whether condition numbers are required for the\n\ * cluster of eigenvalues (PL and PR) or the deflating subspaces\n\ * (Difu and Difl):\n\ * =0: Only reorder w.r.t. SELECT. No extras.\n\ * =1: Reciprocal of norms of \"projections\" onto left and right\n\ * eigenspaces w.r.t. the selected cluster (PL and PR).\n\ * =2: Upper bounds on Difu and Difl. F-norm-based estimate\n\ * (DIF(1:2)).\n\ * =3: Estimate of Difu and Difl. 1-norm-based estimate\n\ * (DIF(1:2)).\n\ * About 5 times as expensive as IJOB = 2.\n\ * =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic\n\ * version to get it all.\n\ * =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)\n\ *\n\ * WANTQ (input) LOGICAL\n\ * .TRUE. : update the left transformation matrix Q;\n\ * .FALSE.: do not update Q.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * .TRUE. : update the right transformation matrix Z;\n\ * .FALSE.: do not update Z.\n\ *\n\ * SELECT (input) LOGICAL array, dimension (N)\n\ * SELECT specifies the eigenvalues in the selected cluster. To\n\ * select an eigenvalue w(j), SELECT(j) must be set to\n\ * .TRUE..\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension(LDA,N)\n\ * On entry, the upper triangular matrix A, in generalized\n\ * Schur canonical form.\n\ * On exit, A is overwritten by the reordered matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX array, dimension(LDB,N)\n\ * On entry, the upper triangular matrix B, in generalized\n\ * Schur canonical form.\n\ * On exit, B is overwritten by the reordered matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * ALPHA (output) COMPLEX array, dimension (N)\n\ * BETA (output) COMPLEX array, dimension (N)\n\ * The diagonal elements of A and B, respectively,\n\ * when the pair (A,B) has been reduced to generalized Schur\n\ * form. ALPHA(i)/BETA(i) i=1,...,N are the generalized\n\ * eigenvalues.\n\ *\n\ * Q (input/output) COMPLEX array, dimension (LDQ,N)\n\ * On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.\n\ * On exit, Q has been postmultiplied by the left unitary\n\ * transformation matrix which reorder (A, B); The leading M\n\ * columns of Q form orthonormal bases for the specified pair of\n\ * left eigenspaces (deflating subspaces).\n\ * If WANTQ = .FALSE., Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= 1.\n\ * If WANTQ = .TRUE., LDQ >= N.\n\ *\n\ * Z (input/output) COMPLEX array, dimension (LDZ,N)\n\ * On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.\n\ * On exit, Z has been postmultiplied by the left unitary\n\ * transformation matrix which reorder (A, B); The leading M\n\ * columns of Z form orthonormal bases for the specified pair of\n\ * left eigenspaces (deflating subspaces).\n\ * If WANTZ = .FALSE., Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1.\n\ * If WANTZ = .TRUE., LDZ >= N.\n\ *\n\ * M (output) INTEGER\n\ * The dimension of the specified pair of left and right\n\ * eigenspaces, (deflating subspaces) 0 <= M <= N.\n\ *\n\ * PL\t (output) REAL\n\ * PR\t (output) REAL\n\ * If IJOB = 1, 4 or 5, PL, PR are lower bounds on the\n\ * reciprocal of the norm of \"projections\" onto left and right\n\ * eigenspace with respect to the selected cluster.\n\ * 0 < PL, PR <= 1.\n\ * If M = 0 or M = N, PL = PR = 1.\n\ * If IJOB = 0, 2 or 3 PL, PR are not referenced.\n\ *\n\ * DIF (output) REAL array, dimension (2).\n\ * If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.\n\ * If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on\n\ * Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based\n\ * estimates of Difu and Difl, computed using reversed\n\ * communication with CLACN2.\n\ * If M = 0 or N, DIF(1:2) = F-norm([A, B]).\n\ * If IJOB = 0 or 1, DIF is not referenced.\n\ *\n\ * WORK (workspace/output) COMPLEX 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 >= 1\n\ * If IJOB = 1, 2 or 4, LWORK >= 2*M*(N-M)\n\ * If IJOB = 3 or 5, LWORK >= 4*M*(N-M)\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\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK. LIWORK >= 1.\n\ * If IJOB = 1, 2 or 4, LIWORK >= N+2;\n\ * If IJOB = 3 or 5, LIWORK >= MAX(N+2, 2*M*(N-M));\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal size of the IWORK array,\n\ * returns this value as the first entry of the IWORK array, and\n\ * no error message related to LIWORK 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\ * =1: Reordering of (A, B) failed because the transformed\n\ * matrix pair (A, B) would be too far from generalized\n\ * Schur form; the problem is very ill-conditioned.\n\ * (A, B) may have been partially reordered.\n\ * If requested, 0 is returned in DIF(*), PL and PR.\n\ *\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * CTGSEN first collects the selected eigenvalues by computing unitary\n\ * U and W that move them to the top left corner of (A, B). In other\n\ * words, the selected eigenvalues are the eigenvalues of (A11, B11) in\n\ *\n\ * U'*(A, B)*W = (A11 A12) (B11 B12) n1\n\ * ( 0 A22),( 0 B22) n2\n\ * n1 n2 n1 n2\n\ *\n\ * where N = n1+n2 and U' means the conjugate transpose of U. The first\n\ * n1 columns of U and W span the specified pair of left and right\n\ * eigenspaces (deflating subspaces) of (A, B).\n\ *\n\ * If (A, B) has been obtained from the generalized real Schur\n\ * decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the\n\ * reordered generalized Schur form of (C, D) is given by\n\ *\n\ * (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',\n\ *\n\ * and the first n1 columns of Q*U and Z*W span the corresponding\n\ * deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).\n\ *\n\ * Note that if the selected eigenvalue is sufficiently ill-conditioned,\n\ * then its value may differ significantly from its value before\n\ * reordering.\n\ *\n\ * The reciprocal condition numbers of the left and right eigenspaces\n\ * spanned by the first n1 columns of U and W (or Q*U and Z*W) may\n\ * be returned in DIF(1:2), corresponding to Difu and Difl, resp.\n\ *\n\ * The Difu and Difl are defined as:\n\ *\n\ * Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )\n\ * and\n\ * Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],\n\ *\n\ * where sigma-min(Zu) is the smallest singular value of the\n\ * (2*n1*n2)-by-(2*n1*n2) matrix\n\ *\n\ * Zu = [ kron(In2, A11) -kron(A22', In1) ]\n\ * [ kron(In2, B11) -kron(B22', In1) ].\n\ *\n\ * Here, Inx is the identity matrix of size nx and A22' is the\n\ * transpose of A22. kron(X, Y) is the Kronecker product between\n\ * the matrices X and Y.\n\ *\n\ * When DIF(2) is small, small changes in (A, B) can cause large changes\n\ * in the deflating subspace. An approximate (asymptotic) bound on the\n\ * maximum angular error in the computed deflating subspaces is\n\ *\n\ * EPS * norm((A, B)) / DIF(2),\n\ *\n\ * where EPS is the machine precision.\n\ *\n\ * The reciprocal norm of the projectors on the left and right\n\ * eigenspaces associated with (A11, B11) may be returned in PL and PR.\n\ * They are computed as follows. First we compute L and R so that\n\ * P*(A, B)*Q is block diagonal, where\n\ *\n\ * P = ( I -L ) n1 Q = ( I R ) n1\n\ * ( 0 I ) n2 and ( 0 I ) n2\n\ * n1 n2 n1 n2\n\ *\n\ * and (L, R) is the solution to the generalized Sylvester equation\n\ *\n\ * A11*R - L*A22 = -A12\n\ * B11*R - L*B22 = -B12\n\ *\n\ * Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).\n\ * An approximate (asymptotic) bound on the average absolute error of\n\ * the selected eigenvalues is\n\ *\n\ * EPS * norm((A, B)) / PL.\n\ *\n\ * There are also global error bounds which valid for perturbations up\n\ * to a certain restriction: A lower bound (x) on the smallest\n\ * F-norm(E,F) for which an eigenvalue of (A11, B11) may move and\n\ * coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),\n\ * (i.e. (A + E, B + F), is\n\ *\n\ * x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).\n\ *\n\ * An approximate bound on x can be computed from DIF(1:2), PL and PR.\n\ *\n\ * If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed\n\ * (L', R') and unperturbed (L, R) left and right deflating subspaces\n\ * associated with the selected cluster in the (1,1)-blocks can be\n\ * bounded as\n\ *\n\ * max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))\n\ * max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))\n\ *\n\ * See LAPACK User's Guide section 4.11 or the following references\n\ * for more information.\n\ *\n\ * Note that if the default method for computing the Frobenius-norm-\n\ * based estimate DIF is not wanted (see CLATDF), then the parameter\n\ * IDIFJB (see below) should be changed from 3 to 4 (routine CLATDF\n\ * (IJOB = 2 will be used)). See CTGSYL for more details.\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * References\n\ * ==========\n\ *\n\ * [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n\ * Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n\ * M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n\ * Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n\ *\n\ * [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n\ * Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n\ * Estimation: Theory, Algorithms and Software, Report\n\ * UMINF - 94.04, Department of Computing Science, Umea University,\n\ * S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.\n\ * To appear in Numerical Algorithms, 1996.\n\ *\n\ * [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n\ * for Solving the Generalized Sylvester Equation and Estimating the\n\ * Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n\ * Department of Computing Science, Umea University, S-901 87 Umea,\n\ * Sweden, December 1993, Revised April 1994, Also as LAPACK working\n\ * Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,\n\ * 1996.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgelsx0000644000175000017500000001220312502223525016472 0ustar uwabamiuwabami--- :name: cgelsx :md5sum: aa91b952fb4647943c51d9489763bd18 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - rcond: :type: real :intent: input - rank: :type: integer :intent: output - work: :type: complex :intent: workspace :dims: - MIN(m,n) + MAX(n,2*(MIN(m,n))+nrhs) - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This routine is deprecated and has been replaced by routine CGELSY.\n\ *\n\ * CGELSX computes the minimum-norm solution to a complex linear least\n\ * squares problem:\n\ * minimize || A * X - B ||\n\ * using a complete orthogonal factorization of A. A is an M-by-N\n\ * matrix which may be rank-deficient.\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\ * The routine first computes a QR factorization with column pivoting:\n\ * A * P = Q * [ R11 R12 ]\n\ * [ 0 R22 ]\n\ * with R11 defined as the largest leading submatrix whose estimated\n\ * condition number is less than 1/RCOND. The order of R11, RANK,\n\ * is the effective rank of A.\n\ *\n\ * Then, R22 is considered to be negligible, and R12 is annihilated\n\ * by unitary transformations from the right, arriving at the\n\ * complete orthogonal factorization:\n\ * A * P = Q * [ T11 0 ] * Z\n\ * [ 0 0 ]\n\ * The minimum-norm solution is then\n\ * X = P * Z' [ inv(T11)*Q1'*B ]\n\ * [ 0 ]\n\ * where Q1 consists of the first RANK columns of 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\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of\n\ * columns of matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, A has been overwritten by details of its\n\ * complete orthogonal factorization.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the M-by-NRHS right hand side matrix B.\n\ * On exit, the N-by-NRHS solution matrix X.\n\ * If m >= n and RANK = n, the residual sum-of-squares for\n\ * the solution in the i-th column is given by the sum of\n\ * squares of elements N+1:M in that column.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,M,N).\n\ *\n\ * JPVT (input/output) INTEGER array, dimension (N)\n\ * On entry, if JPVT(i) .ne. 0, the i-th column of A is an\n\ * initial column, otherwise it is a free column. Before\n\ * the QR factorization of A, all initial columns are\n\ * permuted to the leading positions; only the remaining\n\ * free columns are moved as a result of column pivoting\n\ * during the factorization.\n\ * On exit, if JPVT(i) = k, then the i-th column of A*P\n\ * was the k-th column of A.\n\ *\n\ * RCOND (input) REAL\n\ * RCOND is used to determine the effective rank of A, which\n\ * is defined as the order of the largest leading triangular\n\ * submatrix R11 in the QR factorization with pivoting of A,\n\ * whose estimated condition number < 1/RCOND.\n\ *\n\ * RANK (output) INTEGER\n\ * The effective rank of A, i.e., the order of the submatrix\n\ * R11. This is the same as the order of the submatrix T11\n\ * in the complete orthogonal factorization of A.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension\n\ * (min(M,N) + max( N, 2*min(M,N)+NRHS )),\n\ *\n\ * RWORK (workspace) REAL array, dimension (2*N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgbtrs0000644000175000017500000000601612502223525016476 0ustar uwabamiuwabami--- :name: cgbtrs :md5sum: e6189618958ef743907bab8b81357369 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGBTRS solves a system of linear equations\n\ * A * X = B, A**T * X = B, or A**H * X = B\n\ * with a general band matrix A using the LU factorization computed\n\ * by CGBTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations.\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AB (input) COMPLEX array, dimension (LDAB,N)\n\ * Details of the LU factorization of the band matrix A, as\n\ * computed by CGBTRF. U is stored as an upper triangular band\n\ * matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n\ * the multipliers used during the factorization are stored in\n\ * rows KL+KU+2 to 2*KL+KU+1.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices; for 1 <= i <= N, row i of the matrix was\n\ * interchanged with row IPIV(i).\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chetd20000644000175000017500000001156312502223525016366 0ustar uwabamiuwabami--- :name: chetd2 :md5sum: 71b4642e8124d75edc818a52bbfcacc7 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: real :intent: output :dims: - n - e: :type: real :intent: output :dims: - n-1 - tau: :type: complex :intent: output :dims: - n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CHETD2( UPLO, N, A, LDA, D, E, TAU, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHETD2 reduces a complex Hermitian matrix A to real symmetric\n\ * tridiagonal form T by a unitary similarity transformation:\n\ * Q' * A * Q = T.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * Hermitian matrix A is stored:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the leading\n\ * n-by-n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n-by-n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ * On exit, if UPLO = 'U', the diagonal and first superdiagonal\n\ * of A are overwritten by the corresponding elements of the\n\ * tridiagonal matrix T, and the elements above the first\n\ * superdiagonal, with the array TAU, represent the unitary\n\ * matrix Q as a product of elementary reflectors; if UPLO\n\ * = 'L', the diagonal and first subdiagonal of A are over-\n\ * written by the corresponding elements of the tridiagonal\n\ * matrix T, and the elements below the first subdiagonal, with\n\ * the array TAU, represent the unitary matrix Q as a product\n\ * of elementary reflectors. See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * D (output) REAL array, dimension (N)\n\ * The diagonal elements of the tridiagonal matrix T:\n\ * D(i) = A(i,i).\n\ *\n\ * E (output) REAL array, dimension (N-1)\n\ * The off-diagonal elements of the tridiagonal matrix T:\n\ * E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n\ *\n\ * TAU (output) COMPLEX array, dimension (N-1)\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\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\ * If UPLO = 'U', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(n-1) . . . H(2) H(1).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar, and v is a complex vector with\n\ * v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n\ * A(1:i-1,i+1), and tau in TAU(i).\n\ *\n\ * If UPLO = 'L', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(n-1).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar, and v is a complex vector with\n\ * v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n\ * and tau in TAU(i).\n\ *\n\ * The contents of A on exit are illustrated by the following examples\n\ * with n = 5:\n\ *\n\ * if UPLO = 'U': if UPLO = 'L':\n\ *\n\ * ( d e v2 v3 v4 ) ( d )\n\ * ( d e v3 v4 ) ( e d )\n\ * ( d e v4 ) ( v1 e d )\n\ * ( d e ) ( v1 v2 e d )\n\ * ( d ) ( v1 v2 v3 e d )\n\ *\n\ * where d and e denote diagonal and off-diagonal elements of T, and vi\n\ * denotes an element of the vector defining H(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlassq0000644000175000017500000000423212502223526016526 0ustar uwabamiuwabami--- :name: zlassq :md5sum: e346894954ce60bf7035bd1e4a6f75c3 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: doublecomplex :intent: input :dims: - n - incx: :type: integer :intent: input - scale: :type: doublereal :intent: input/output - sumsq: :type: doublereal :intent: input/output :substitutions: {} :fortran_help: " SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLASSQ returns the values scl and ssq such that\n\ *\n\ * ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,\n\ *\n\ * where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is\n\ * assumed to be at least unity and the value of ssq will then satisfy\n\ *\n\ * 1.0 .le. ssq .le. ( sumsq + 2*n ).\n\ *\n\ * scale is assumed to be non-negative and scl returns the value\n\ *\n\ * scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ),\n\ * i\n\ *\n\ * scale and sumsq must be supplied in SCALE and SUMSQ respectively.\n\ * SCALE and SUMSQ are overwritten by scl and ssq respectively.\n\ *\n\ * The routine makes only one pass through the vector X.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of elements to be used from the vector X.\n\ *\n\ * X (input) COMPLEX*16 array, dimension (N)\n\ * The vector x as described above.\n\ * x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between successive values of the vector X.\n\ * INCX > 0.\n\ *\n\ * SCALE (input/output) DOUBLE PRECISION\n\ * On entry, the value scale in the equation above.\n\ * On exit, SCALE is overwritten with the value scl .\n\ *\n\ * SUMSQ (input/output) DOUBLE PRECISION\n\ * On entry, the value sumsq in the equation above.\n\ * On exit, SUMSQ is overwritten with the value ssq .\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgbrfs0000644000175000017500000001277612502223526016522 0ustar uwabamiuwabami--- :name: zgbrfs :md5sum: ff6b0a35d16530b0e7721261123bb43e :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublecomplex :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGBRFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is banded, and provides\n\ * error bounds and backward error estimates for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AB (input) COMPLEX*16 array, dimension (LDAB,N)\n\ * The original band matrix A, stored in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * AFB (input) COMPLEX*16 array, dimension (LDAFB,N)\n\ * Details of the LU factorization of the band matrix A, as\n\ * computed by ZGBTRF. U is stored as an upper triangular band\n\ * matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n\ * the multipliers used during the factorization are stored in\n\ * rows KL+KU+2 to 2*KL+KU+1.\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from ZGBTRF; for 1<=i<=N, row i of the\n\ * matrix was interchanged with row IPIV(i).\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by ZGBTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cpotf20000644000175000017500000000471312502223525016411 0ustar uwabamiuwabami--- :name: cpotf2 :md5sum: a7c491fac2d61e6bc2983fde569beb7d :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPOTF2( UPLO, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPOTF2 computes the Cholesky factorization of a complex Hermitian\n\ * positive definite matrix A.\n\ *\n\ * The factorization has the form\n\ * A = U' * U , if UPLO = 'U', or\n\ * A = L * L', if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is lower triangular.\n\ *\n\ * This is the unblocked version of the algorithm, calling Level 2 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * Hermitian matrix A is stored.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the leading\n\ * n by n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n by n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the factor U or L from the Cholesky\n\ * factorization A = U'*U or A = L*L'.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ * > 0: if INFO = k, the leading minor of order k is not\n\ * positive definite, and the factorization could not be\n\ * completed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhpcon0000644000175000017500000000510312502223526016510 0ustar uwabamiuwabami--- :name: zhpcon :md5sum: f06328a28b5679c1819985fa02dc711a :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZHPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHPCON estimates the reciprocal of the condition number of a complex\n\ * Hermitian packed matrix A using the factorization A = U*D*U**H or\n\ * A = L*D*L**H computed by ZHPTRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**H;\n\ * = 'L': Lower triangular, form is A = L*D*L**H.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by ZHPTRF, stored as a\n\ * packed triangular matrix.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by ZHPTRF.\n\ *\n\ * ANORM (input) DOUBLE PRECISION\n\ * The 1-norm of the original matrix A.\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n\ * estimate of the 1-norm of inv(A) computed in this routine.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zupgtr0000644000175000017500000000450612502223526016550 0ustar uwabamiuwabami--- :name: zupgtr :md5sum: 924fd32a52613919c09c91f16d7e0fa6 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - ldap - tau: :type: doublecomplex :intent: input :dims: - ldtau - q: :type: doublecomplex :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - n-1 - info: :type: integer :intent: output :substitutions: ldq: MAX(1,n) n: ldtau+1 :fortran_help: " SUBROUTINE ZUPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZUPGTR generates a complex unitary matrix Q which is defined as the\n\ * product of n-1 elementary reflectors H(i) of order n, as returned by\n\ * ZHPTRD using packed storage:\n\ *\n\ * if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),\n\ *\n\ * if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangular packed storage used in previous\n\ * call to ZHPTRD;\n\ * = 'L': Lower triangular packed storage used in previous\n\ * call to ZHPTRD.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix Q. N >= 0.\n\ *\n\ * AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * The vectors which define the elementary reflectors, as\n\ * returned by ZHPTRD.\n\ *\n\ * TAU (input) COMPLEX*16 array, dimension (N-1)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by ZHPTRD.\n\ *\n\ * Q (output) COMPLEX*16 array, dimension (LDQ,N)\n\ * The N-by-N unitary matrix Q.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (N-1)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlaed40000644000175000017500000000655312502223526016356 0ustar uwabamiuwabami--- :name: dlaed4 :md5sum: 2bf936115b6fbea109694f74fb7b08e3 :category: :subroutine :arguments: - n: :type: integer :intent: input - i: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - z: :type: doublereal :intent: input :dims: - n - delta: :type: doublereal :intent: output :dims: - n - rho: :type: doublereal :intent: input - dlam: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This subroutine computes the I-th updated eigenvalue of a symmetric\n\ * rank-one modification to a diagonal matrix whose elements are\n\ * given in the array d, and that\n\ *\n\ * D(i) < D(j) for i < j\n\ *\n\ * and that RHO > 0. This is arranged by the calling routine, and is\n\ * no loss in generality. The rank-one modified system is thus\n\ *\n\ * diag( D ) + RHO * Z * Z_transpose.\n\ *\n\ * where we assume the Euclidean norm of Z is 1.\n\ *\n\ * The method consists of approximating the rational functions in the\n\ * secular equation by simpler interpolating rational functions.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The length of all arrays.\n\ *\n\ * I (input) INTEGER\n\ * The index of the eigenvalue to be computed. 1 <= I <= N.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The original eigenvalues. It is assumed that they are in\n\ * order, D(I) < D(J) for I < J.\n\ *\n\ * Z (input) DOUBLE PRECISION array, dimension (N)\n\ * The components of the updating vector.\n\ *\n\ * DELTA (output) DOUBLE PRECISION array, dimension (N)\n\ * If N .GT. 2, DELTA contains (D(j) - lambda_I) in its j-th\n\ * component. If N = 1, then DELTA(1) = 1. If N = 2, see DLAED5\n\ * for detail. The vector DELTA contains the information necessary\n\ * to construct the eigenvectors by DLAED3 and DLAED9.\n\ *\n\ * RHO (input) DOUBLE PRECISION\n\ * The scalar in the symmetric updating formula.\n\ *\n\ * DLAM (output) DOUBLE PRECISION\n\ * The computed lambda_I, the I-th updated eigenvalue.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * > 0: if INFO = 1, the updating process failed.\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * Logical variable ORGATI (origin-at-i?) is used for distinguishing\n\ * whether D(i) or D(i+1) is treated as the origin.\n\ *\n\ * ORGATI = .true. origin at i\n\ * ORGATI = .false. origin at i+1\n\ *\n\ * Logical variable SWTCH3 (switch-for-3-poles?) is for noting\n\ * if we are working with THREE poles!\n\ *\n\ * MAXIT is the maximum number of iterations allowed for each\n\ * eigenvalue.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ren-Cang Li, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlacpy0000644000175000017500000000426212502223526016470 0ustar uwabamiuwabami--- :name: dlacpy :md5sum: 10366fbf2a10d962bba69e321b7c3c7b :category: :subroutine :arguments: - uplo: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: output :dims: - ldb - n - ldb: :type: integer :intent: input :substitutions: ldb: MAX(1,m) :fortran_help: " SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLACPY copies all or part of a two-dimensional matrix A to another\n\ * matrix B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies the part of the matrix A to be copied to B.\n\ * = 'U': Upper triangular part\n\ * = 'L': Lower triangular part\n\ * Otherwise: All of the matrix A\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) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The m by n matrix A. If UPLO = 'U', only the upper triangle\n\ * or trapezoid is accessed; if UPLO = 'L', only the lower\n\ * triangle or trapezoid is accessed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (output) DOUBLE PRECISION array, dimension (LDB,N)\n\ * On exit, B = A in the locations specified by UPLO.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,M).\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slapy20000644000175000017500000000123312502223526016421 0ustar uwabamiuwabami--- :name: slapy2 :md5sum: 4f1338cbdbf1dbb2f5736504748d4bf3 :category: :function :type: real :arguments: - x: :type: real :intent: input - y: :type: real :intent: input :substitutions: {} :fortran_help: " REAL FUNCTION SLAPY2( X, Y )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary\n\ * overflow.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * X (input) REAL\n\ * Y (input) REAL\n\ * X and Y specify the values x and y.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlahef0000644000175000017500000001067612502223526016473 0ustar uwabamiuwabami--- :name: zlahef :md5sum: 43bf4f4327aedf5ca806b99215ebff6b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nb: :type: integer :intent: input - kb: :type: integer :intent: output - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - w: :type: doublecomplex :intent: workspace :dims: - ldw - MAX(n,nb) - ldw: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: ldw: MAX(1,n) :fortran_help: " SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAHEF computes a partial factorization of a complex Hermitian\n\ * matrix A using the Bunch-Kaufman diagonal pivoting method. The\n\ * partial factorization has the form:\n\ *\n\ * A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:\n\ * ( 0 U22 ) ( 0 D ) ( U12' U22' )\n\ *\n\ * A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L'\n\ * ( L21 I ) ( 0 A22 ) ( 0 I )\n\ *\n\ * where the order of D is at most NB. The actual order is returned in\n\ * the argument KB, and is either NB or NB-1, or N if N <= NB.\n\ * Note that U' denotes the conjugate transpose of U.\n\ *\n\ * ZLAHEF is an auxiliary routine called by ZHETRF. It uses blocked code\n\ * (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or\n\ * A22 (if UPLO = 'L').\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * Hermitian matrix A is stored:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NB (input) INTEGER\n\ * The maximum number of columns of the matrix A that should be\n\ * factored. NB should be at least 2 to allow for 2-by-2 pivot\n\ * blocks.\n\ *\n\ * KB (output) INTEGER\n\ * The number of columns of A that were actually factored.\n\ * KB is either NB-1 or NB, or N if N <= NB.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the leading\n\ * n-by-n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n-by-n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ * On exit, A contains details of the partial factorization.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D.\n\ * If UPLO = 'U', only the last KB elements of IPIV are set;\n\ * if UPLO = 'L', only the first KB elements are set.\n\ *\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * W (workspace) COMPLEX*16 array, dimension (LDW,NB)\n\ *\n\ * LDW (input) INTEGER\n\ * The leading dimension of the array W. LDW >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slarra0000644000175000017500000000643312502223526016502 0ustar uwabamiuwabami--- :name: slarra :md5sum: 8c265e4b5b823f839c614ef3bc019488 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: real :intent: input/output :dims: - n - e2: :type: real :intent: input/output :dims: - n - spltol: :type: real :intent: input - tnrm: :type: real :intent: input - nsplit: :type: integer :intent: output - isplit: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLARRA( N, D, E, E2, SPLTOL, TNRM, NSPLIT, ISPLIT, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Compute the splitting points with threshold SPLTOL.\n\ * SLARRA sets any \"small\" off-diagonal elements to zero.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N > 0.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * On entry, the N diagonal elements of the tridiagonal\n\ * matrix T.\n\ *\n\ * E (input/output) REAL array, dimension (N)\n\ * On entry, the first (N-1) entries contain the subdiagonal\n\ * elements of the tridiagonal matrix T; E(N) need not be set.\n\ * On exit, the entries E( ISPLIT( I ) ), 1 <= I <= NSPLIT,\n\ * are set to zero, the other entries of E are untouched.\n\ *\n\ * E2 (input/output) REAL array, dimension (N)\n\ * On entry, the first (N-1) entries contain the SQUARES of the\n\ * subdiagonal elements of the tridiagonal matrix T;\n\ * E2(N) need not be set.\n\ * On exit, the entries E2( ISPLIT( I ) ),\n\ * 1 <= I <= NSPLIT, have been set to zero\n\ *\n\ * SPLTOL (input) REAL \n\ * The threshold for splitting. Two criteria can be used:\n\ * SPLTOL<0 : criterion based on absolute off-diagonal value\n\ * SPLTOL>0 : criterion that preserves relative accuracy\n\ *\n\ * TNRM (input) REAL \n\ * The norm of the matrix.\n\ *\n\ * NSPLIT (output) INTEGER\n\ * The number of blocks T splits into. 1 <= NSPLIT <= N.\n\ *\n\ * ISPLIT (output) INTEGER array, dimension (N)\n\ * The splitting points, at which T breaks up into blocks.\n\ * The first block consists of rows/columns 1 to ISPLIT(1),\n\ * the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n\ * etc., and the NSPLIT-th consists of rows/columns\n\ * ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n\ *\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Beresford Parlett, University of California, Berkeley, USA\n\ * Jim Demmel, University of California, Berkeley, USA\n\ * Inderjit Dhillon, University of Texas, Austin, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, University of California, Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sorgql0000644000175000017500000000570712502223526016530 0ustar uwabamiuwabami--- :name: sorgql :md5sum: f5008c1f6620c914e619887d4ba524d2 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SORGQL generates an M-by-N real matrix Q with orthonormal columns,\n\ * which is defined as the last N columns of a product of K elementary\n\ * reflectors of order M\n\ *\n\ * Q = H(k) . . . H(2) H(1)\n\ *\n\ * as returned by SGEQLF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. M >= N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. N >= K >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the (n-k+i)-th column must contain the vector which\n\ * defines the elementary reflector H(i), for i = 1,2,...,k, as\n\ * returned by SGEQLF in the last k columns of its array\n\ * argument A.\n\ * On exit, the M-by-N matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) REAL array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by SGEQLF.\n\ *\n\ * WORK (workspace/output) REAL 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,N).\n\ * For optimum performance LWORK >= N*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 has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgbcon0000644000175000017500000000653612502223526016456 0ustar uwabamiuwabami--- :name: dgbcon :md5sum: 3a7c574975c857211d37ef3e3a3e933d :category: :subroutine :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGBCON estimates the reciprocal of the condition number of a real\n\ * general band matrix A, in either the 1-norm or the infinity-norm,\n\ * using the LU factorization computed by DGBTRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as\n\ * RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies whether the 1-norm condition number or the\n\ * infinity-norm condition number is required:\n\ * = '1' or 'O': 1-norm;\n\ * = 'I': Infinity-norm.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * Details of the LU factorization of the band matrix A, as\n\ * computed by DGBTRF. U is stored as an upper triangular band\n\ * matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n\ * the multipliers used during the factorization are stored in\n\ * rows KL+KU+2 to 2*KL+KU+1.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices; for 1 <= i <= N, row i of the matrix was\n\ * interchanged with row IPIV(i).\n\ *\n\ * ANORM (input) DOUBLE PRECISION\n\ * If NORM = '1' or 'O', the 1-norm of the original matrix A.\n\ * If NORM = 'I', the infinity-norm of the original matrix A.\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(norm(A) * norm(inv(A))).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgehd20000644000175000017500000000736112502223525016352 0ustar uwabamiuwabami--- :name: cgehd2 :md5sum: 8450267c1a4d71c520945ff6f0d8610b :category: :subroutine :arguments: - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - n-1 - work: :type: complex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGEHD2 reduces a complex general matrix A to upper Hessenberg form H\n\ * by a unitary similarity transformation: Q' * A * Q = H .\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * It is assumed that A is already upper triangular in rows\n\ * and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n\ * set by a previous call to CGEBAL; otherwise they should be\n\ * set to 1 and N respectively. See Further Details.\n\ * 1 <= ILO <= IHI <= max(1,N).\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the n by n general matrix to be reduced.\n\ * On exit, the upper triangle and the first subdiagonal of A\n\ * are overwritten with the upper Hessenberg matrix H, and the\n\ * elements below the first subdiagonal, with the array TAU,\n\ * represent the unitary matrix Q as a product of elementary\n\ * reflectors. See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * TAU (output) COMPLEX array, dimension (N-1)\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (N)\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 (ihi-ilo) elementary\n\ * reflectors\n\ *\n\ * Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar, and v is a complex vector with\n\ * v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n\ * exit in A(i+2:ihi,i), and tau in TAU(i).\n\ *\n\ * The contents of A are illustrated by the following example, with\n\ * n = 7, ilo = 2 and ihi = 6:\n\ *\n\ * on entry, on exit,\n\ *\n\ * ( a a a a a a a ) ( a a h h h h a )\n\ * ( a a a a a a ) ( a h h h h a )\n\ * ( a a a a a a ) ( h h h h h h )\n\ * ( a a a a a a ) ( v2 h h h h h )\n\ * ( a a a a a a ) ( v2 v3 h h h h )\n\ * ( a a a a a a ) ( v2 v3 v4 h h h )\n\ * ( a ) ( a )\n\ *\n\ * where a denotes an element of the original matrix A, h denotes a\n\ * modified element of the upper Hessenberg matrix H, and vi denotes an\n\ * element of the vector defining H(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgeqpf0000644000175000017500000000670612502223526016515 0ustar uwabamiuwabami--- :name: zgeqpf :md5sum: 51fcf5d185ef9463c8789ce9d0d92782 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: doublecomplex :intent: output :dims: - MIN(m,n) - work: :type: doublecomplex :intent: workspace :dims: - n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This routine is deprecated and has been replaced by routine ZGEQP3.\n\ *\n\ * ZGEQPF computes a QR factorization with column pivoting of a\n\ * complex M-by-N matrix A: A*P = Q*R.\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) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, the upper triangle of the array contains the\n\ * min(M,N)-by-N upper triangular matrix R; the elements\n\ * below the diagonal, together with the array TAU,\n\ * represent the unitary matrix Q as a product of\n\ * min(m,n) elementary reflectors.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * JPVT (input/output) INTEGER array, dimension (N)\n\ * On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n\ * to the front of A*P (a leading column); if JPVT(i) = 0,\n\ * the i-th column of A is a free column.\n\ * On exit, if JPVT(i) = k, then the i-th column of A*P\n\ * was the k-th column of A.\n\ *\n\ * TAU (output) COMPLEX*16 array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\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(1) H(2) . . . H(n)\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar, and v is a complex vector with\n\ * v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).\n\ *\n\ * The matrix P is represented in jpvt as follows: If\n\ * jpvt(j) = i\n\ * then the jth column of P is the ith canonical unit vector.\n\ *\n\ * Partial column norm updating strategy modified by\n\ * Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n\ * University of Zagreb, Croatia.\n\ * June 2010\n\ * For more details see LAPACK Working Note 176.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zggbal0000644000175000017500000001201012502223526016450 0ustar uwabamiuwabami--- :name: zggbal :md5sum: 2eb576199bbfbe923f6f6bab24ed50f2 :category: :subroutine :arguments: - job: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - lscale: :type: doublereal :intent: output :dims: - n - rscale: :type: doublereal :intent: output :dims: - n - work: :type: doublereal :intent: workspace :dims: - "(lsame_(&job,\"S\")||lsame_(&job,\"B\")) ? MAX(1,6*n) : (lsame_(&job,\"N\")||lsame_(&job,\"P\")) ? 1 : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGGBAL balances a pair of general complex matrices (A,B). This\n\ * involves, first, permuting A and B by similarity transformations to\n\ * isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N\n\ * elements on the diagonal; and second, applying a diagonal similarity\n\ * transformation to rows and columns ILO to IHI to make the rows\n\ * and columns as close in norm as possible. Both steps are optional.\n\ *\n\ * Balancing may reduce the 1-norm of the matrices, and improve the\n\ * accuracy of the computed eigenvalues and/or eigenvectors in the\n\ * generalized eigenvalue problem A*x = lambda*B*x.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * Specifies the operations to be performed on A and B:\n\ * = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0\n\ * and RSCALE(I) = 1.0 for i=1,...,N;\n\ * = 'P': permute only;\n\ * = 'S': scale only;\n\ * = 'B': both permute and scale.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the input matrix A.\n\ * On exit, A is overwritten by the balanced matrix.\n\ * If JOB = 'N', A is not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,N)\n\ * On entry, the input matrix B.\n\ * On exit, B is overwritten by the balanced matrix.\n\ * If JOB = 'N', B is not referenced.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * ILO (output) INTEGER\n\ * IHI (output) INTEGER\n\ * ILO and IHI are set to integers such that on exit\n\ * A(i,j) = 0 and B(i,j) = 0 if i > j and\n\ * j = 1,...,ILO-1 or i = IHI+1,...,N.\n\ * If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n\ *\n\ * LSCALE (output) DOUBLE PRECISION array, dimension (N)\n\ * Details of the permutations and scaling factors applied\n\ * to the left side of A and B. If P(j) is the index of the\n\ * row interchanged with row j, and D(j) is the scaling factor\n\ * applied to row j, then\n\ * LSCALE(j) = P(j) for J = 1,...,ILO-1\n\ * = D(j) for J = ILO,...,IHI\n\ * = P(j) for J = IHI+1,...,N.\n\ * The order in which the interchanges are made is N to IHI+1,\n\ * then 1 to ILO-1.\n\ *\n\ * RSCALE (output) DOUBLE PRECISION array, dimension (N)\n\ * Details of the permutations and scaling factors applied\n\ * to the right side of A and B. If P(j) is the index of the\n\ * column interchanged with column j, and D(j) is the scaling\n\ * factor applied to column j, then\n\ * RSCALE(j) = P(j) for J = 1,...,ILO-1\n\ * = D(j) for J = ILO,...,IHI\n\ * = P(j) for J = IHI+1,...,N.\n\ * The order in which the interchanges are made is N to IHI+1,\n\ * then 1 to ILO-1.\n\ *\n\ * WORK (workspace) REAL array, dimension (lwork)\n\ * lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and\n\ * at least 1 when JOB = 'N' or 'P'.\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\ * See R.C. WARD, Balancing the generalized eigenvalue problem,\n\ * SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/iladlr0000644000175000017500000000202112502223526016452 0ustar uwabamiuwabami--- :name: iladlr :md5sum: 4168f3d5a975c714ef6b4c66396a9f94 :category: :function :type: integer :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " INTEGER FUNCTION ILADLR( M, N, A, LDA )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ILADLR scans A for its last non-zero row.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix A.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * 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\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgegs0000644000175000017500000001626212502223526016327 0ustar uwabamiuwabami--- :name: sgegs :md5sum: c623dc99f7ba59741a8e3ad0a7221b09 :category: :subroutine :arguments: - jobvsl: :type: char :intent: input - jobvsr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alphar: :type: real :intent: output :dims: - n - alphai: :type: real :intent: output :dims: - n - beta: :type: real :intent: output :dims: - n - vsl: :type: real :intent: output :dims: - ldvsl - n - ldvsl: :type: integer :intent: input - vsr: :type: real :intent: output :dims: - ldvsr - n - ldvsr: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 4*n - info: :type: integer :intent: output :substitutions: ldvsl: "lsame_(&jobvsl,\"V\") ? n : 1" ldvsr: "lsame_(&jobvsr,\"V\") ? n : 1" :fortran_help: " SUBROUTINE SGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This routine is deprecated and has been replaced by routine SGGES.\n\ *\n\ * SGEGS computes the eigenvalues, real Schur form, and, optionally,\n\ * left and or/right Schur vectors of a real matrix pair (A,B).\n\ * Given two square matrices A and B, the generalized real Schur\n\ * factorization has the form\n\ * \n\ * A = Q*S*Z**T, B = Q*T*Z**T\n\ *\n\ * where Q and Z are orthogonal matrices, T is upper triangular, and S\n\ * is an upper quasi-triangular matrix with 1-by-1 and 2-by-2 diagonal\n\ * blocks, the 2-by-2 blocks corresponding to complex conjugate pairs\n\ * of eigenvalues of (A,B). The columns of Q are the left Schur vectors\n\ * and the columns of Z are the right Schur vectors.\n\ * \n\ * If only the eigenvalues of (A,B) are needed, the driver routine\n\ * SGEGV should be used instead. See SGEGV for a description of the\n\ * eigenvalues of the generalized nonsymmetric eigenvalue problem\n\ * (GNEP).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVSL (input) CHARACTER*1\n\ * = 'N': do not compute the left Schur vectors;\n\ * = 'V': compute the left Schur vectors (returned in VSL).\n\ *\n\ * JOBVSR (input) CHARACTER*1\n\ * = 'N': do not compute the right Schur vectors;\n\ * = 'V': compute the right Schur vectors (returned in VSR).\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A, B, VSL, and VSR. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA, N)\n\ * On entry, the matrix A.\n\ * On exit, the upper quasi-triangular matrix S from the\n\ * generalized real Schur factorization.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of A. LDA >= max(1,N).\n\ *\n\ * B (input/output) REAL array, dimension (LDB, N)\n\ * On entry, the matrix B.\n\ * On exit, the upper triangular matrix T from the generalized\n\ * real Schur factorization.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B. LDB >= max(1,N).\n\ *\n\ * ALPHAR (output) REAL array, dimension (N)\n\ * The real parts of each scalar alpha defining an eigenvalue\n\ * of GNEP.\n\ *\n\ * ALPHAI (output) REAL array, dimension (N)\n\ * The imaginary parts of each scalar alpha defining an\n\ * eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th\n\ * eigenvalue is real; if positive, then the j-th and (j+1)-st\n\ * eigenvalues are a complex conjugate pair, with\n\ * ALPHAI(j+1) = -ALPHAI(j).\n\ *\n\ * BETA (output) REAL array, dimension (N)\n\ * The scalars beta that define the eigenvalues of GNEP.\n\ * Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and\n\ * beta = BETA(j) represent the j-th eigenvalue of the matrix\n\ * pair (A,B), in one of the forms lambda = alpha/beta or\n\ * mu = beta/alpha. Since either lambda or mu may overflow,\n\ * they should not, in general, be computed.\n\ *\n\ * VSL (output) REAL array, dimension (LDVSL,N)\n\ * If JOBVSL = 'V', the matrix of left Schur vectors Q.\n\ * Not referenced if JOBVSL = 'N'.\n\ *\n\ * LDVSL (input) INTEGER\n\ * The leading dimension of the matrix VSL. LDVSL >=1, and\n\ * if JOBVSL = 'V', LDVSL >= N.\n\ *\n\ * VSR (output) REAL array, dimension (LDVSR,N)\n\ * If JOBVSR = 'V', the matrix of right Schur vectors Z.\n\ * Not referenced if JOBVSR = 'N'.\n\ *\n\ * LDVSR (input) INTEGER\n\ * The leading dimension of the matrix VSR. LDVSR >= 1, and\n\ * if JOBVSR = 'V', LDVSR >= N.\n\ *\n\ * WORK (workspace/output) REAL 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,4*N).\n\ * For good performance, LWORK must generally be larger.\n\ * To compute the optimal value of LWORK, call ILAENV to get\n\ * blocksizes (for SGEQRF, SORMQR, and SORGQR.) Then compute:\n\ * NB -- MAX of the blocksizes for SGEQRF, SORMQR, and SORGQR\n\ * The optimal LWORK is 2*N + N*(NB+1).\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\ * = 1,...,N:\n\ * The QZ iteration failed. (A,B) are not in Schur\n\ * form, but ALPHAR(j), ALPHAI(j), and BETA(j) should\n\ * be correct for j=INFO+1,...,N.\n\ * > N: errors that usually indicate LAPACK problems:\n\ * =N+1: error return from SGGBAL\n\ * =N+2: error return from SGEQRF\n\ * =N+3: error return from SORMQR\n\ * =N+4: error return from SORGQR\n\ * =N+5: error return from SGGHRD\n\ * =N+6: error return from SHGEQZ (other than failed\n\ * iteration)\n\ * =N+7: error return from SGGBAK (computing VSL)\n\ * =N+8: error return from SGGBAK (computing VSR)\n\ * =N+9: error return from SLASCL (various places)\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlasd80000644000175000017500000001131612502223526016371 0ustar uwabamiuwabami--- :name: dlasd8 :md5sum: da4e64c91be87e67d70f49ec5f695f5e :category: :subroutine :arguments: - icompq: :type: integer :intent: input - k: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - k - z: :type: doublereal :intent: input/output :dims: - k - vf: :type: doublereal :intent: input/output :dims: - k - vl: :type: doublereal :intent: input/output :dims: - k - difl: :type: doublereal :intent: output :dims: - k - difr: :type: doublereal :intent: output :dims: - "icompq == 1 ? lddifr : icompq == 0 ? k : 0" - "icompq == 1 ? 2 : 0" - lddifr: :type: integer :intent: input - dsigma: :type: doublereal :intent: input/output :dims: - k - work: :type: doublereal :intent: workspace :dims: - 3 * k - info: :type: integer :intent: output :substitutions: lddifr: k :fortran_help: " SUBROUTINE DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, DSIGMA, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLASD8 finds the square roots of the roots of the secular equation,\n\ * as defined by the values in DSIGMA and Z. It makes the appropriate\n\ * calls to DLASD4, and stores, for each element in D, the distance\n\ * to its two nearest poles (elements in DSIGMA). It also updates\n\ * the arrays VF and VL, the first and last components of all the\n\ * right singular vectors of the original bidiagonal matrix.\n\ *\n\ * DLASD8 is called from DLASD6.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ICOMPQ (input) INTEGER\n\ * Specifies whether singular vectors are to be computed in\n\ * factored form in the calling routine:\n\ * = 0: Compute singular values only.\n\ * = 1: Compute singular vectors in factored form as well.\n\ *\n\ * K (input) INTEGER\n\ * The number of terms in the rational function to be solved\n\ * by DLASD4. K >= 1.\n\ *\n\ * D (output) DOUBLE PRECISION array, dimension ( K )\n\ * On output, D contains the updated singular values.\n\ *\n\ * Z (input/output) DOUBLE PRECISION array, dimension ( K )\n\ * On entry, the first K elements of this array contain the\n\ * components of the deflation-adjusted updating row vector.\n\ * On exit, Z is updated.\n\ *\n\ * VF (input/output) DOUBLE PRECISION array, dimension ( K )\n\ * On entry, VF contains information passed through DBEDE8.\n\ * On exit, VF contains the first K components of the first\n\ * components of all right singular vectors of the bidiagonal\n\ * matrix.\n\ *\n\ * VL (input/output) DOUBLE PRECISION array, dimension ( K )\n\ * On entry, VL contains information passed through DBEDE8.\n\ * On exit, VL contains the first K components of the last\n\ * components of all right singular vectors of the bidiagonal\n\ * matrix.\n\ *\n\ * DIFL (output) DOUBLE PRECISION array, dimension ( K )\n\ * On exit, DIFL(I) = D(I) - DSIGMA(I).\n\ *\n\ * DIFR (output) DOUBLE PRECISION array,\n\ * dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and\n\ * dimension ( K ) if ICOMPQ = 0.\n\ * On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not\n\ * defined and will not be referenced.\n\ *\n\ * If ICOMPQ = 1, DIFR(1:K,2) is an array containing the\n\ * normalizing factors for the right singular vector matrix.\n\ *\n\ * LDDIFR (input) INTEGER\n\ * The leading dimension of DIFR, must be at least K.\n\ *\n\ * DSIGMA (input/output) DOUBLE PRECISION array, dimension ( K )\n\ * On entry, the first K elements of this array contain the old\n\ * roots of the deflated updating problem. These are the poles\n\ * of the secular equation.\n\ * On exit, the elements of DSIGMA may be very slightly altered\n\ * in value.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension at least 3 * K\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 = 1, a singular value did not converge\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ming Gu and Huan Ren, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slaqr30000644000175000017500000002010312502223526016411 0ustar uwabamiuwabami--- :name: slaqr3 :md5sum: 488261ef65216cdb19827c02638e462d :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ktop: :type: integer :intent: input - kbot: :type: integer :intent: input - nw: :type: integer :intent: input - h: :type: real :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: real :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - ns: :type: integer :intent: output - nd: :type: integer :intent: output - sr: :type: real :intent: output :dims: - MAX(1,kbot) - si: :type: real :intent: output :dims: - MAX(1,kbot) - v: :type: real :intent: workspace :dims: - ldv - MAX(1,nw) - ldv: :type: integer :intent: input - nh: :type: integer :intent: input - t: :type: real :intent: workspace :dims: - ldt - MAX(1,nw) - ldt: :type: integer :intent: input - nv: :type: integer :intent: input - wv: :type: real :intent: workspace :dims: - ldwv - MAX(1,nw) - ldwv: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*nw :substitutions: ldwv: nw ldt: nw ldv: nw :fortran_help: " SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n\ * Aggressive early deflation:\n\ *\n\ * This subroutine accepts as input an upper Hessenberg matrix\n\ * H and performs an orthogonal similarity transformation\n\ * designed to detect and deflate fully converged eigenvalues from\n\ * a trailing principal submatrix. On output H has been over-\n\ * written by a new Hessenberg matrix that is a perturbation of\n\ * an orthogonal similarity transformation of H. It is to be\n\ * hoped that the final version of H has many zero subdiagonal\n\ * entries.\n\ *\n\ * ******************************************************************\n\n\ * WANTT (input) LOGICAL\n\ * If .TRUE., then the Hessenberg matrix H is fully updated\n\ * so that the quasi-triangular Schur factor may be\n\ * computed (in cooperation with the calling subroutine).\n\ * If .FALSE., then only enough of H is updated to preserve\n\ * the eigenvalues.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * If .TRUE., then the orthogonal matrix Z is updated so\n\ * so that the orthogonal Schur factor may be computed\n\ * (in cooperation with the calling subroutine).\n\ * If .FALSE., then Z is not referenced.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H and (if WANTZ is .TRUE.) the\n\ * order of the orthogonal matrix Z.\n\ *\n\ * KTOP (input) INTEGER\n\ * It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n\ * KBOT and KTOP together determine an isolated block\n\ * along the diagonal of the Hessenberg matrix.\n\ *\n\ * KBOT (input) INTEGER\n\ * It is assumed without a check that either\n\ * KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together\n\ * determine an isolated block along the diagonal of the\n\ * Hessenberg matrix.\n\ *\n\ * NW (input) INTEGER\n\ * Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).\n\ *\n\ * H (input/output) REAL array, dimension (LDH,N)\n\ * On input the initial N-by-N section of H stores the\n\ * Hessenberg matrix undergoing aggressive early deflation.\n\ * On output H has been transformed by an orthogonal\n\ * similarity transformation, perturbed, and the returned\n\ * to Hessenberg form that (it is to be hoped) has some\n\ * zero subdiagonal entries.\n\ *\n\ * LDH (input) integer\n\ * Leading dimension of H just as declared in the calling\n\ * subroutine. N .LE. LDH\n\ *\n\ * ILOZ (input) INTEGER\n\ * IHIZ (input) INTEGER\n\ * Specify the rows of Z to which transformations must be\n\ * applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n\ *\n\ * Z (input/output) REAL array, dimension (LDZ,N)\n\ * IF WANTZ is .TRUE., then on output, the orthogonal\n\ * similarity transformation mentioned above has been\n\ * accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n\ * If WANTZ is .FALSE., then Z is unreferenced.\n\ *\n\ * LDZ (input) integer\n\ * The leading dimension of Z just as declared in the\n\ * calling subroutine. 1 .LE. LDZ.\n\ *\n\ * NS (output) integer\n\ * The number of unconverged (ie approximate) eigenvalues\n\ * returned in SR and SI that may be used as shifts by the\n\ * calling subroutine.\n\ *\n\ * ND (output) integer\n\ * The number of converged eigenvalues uncovered by this\n\ * subroutine.\n\ *\n\ * SR (output) REAL array, dimension KBOT\n\ * SI (output) REAL array, dimension KBOT\n\ * On output, the real and imaginary parts of approximate\n\ * eigenvalues that may be used for shifts are stored in\n\ * SR(KBOT-ND-NS+1) through SR(KBOT-ND) and\n\ * SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.\n\ * The real and imaginary parts of converged eigenvalues\n\ * are stored in SR(KBOT-ND+1) through SR(KBOT) and\n\ * SI(KBOT-ND+1) through SI(KBOT), respectively.\n\ *\n\ * V (workspace) REAL array, dimension (LDV,NW)\n\ * An NW-by-NW work array.\n\ *\n\ * LDV (input) integer scalar\n\ * The leading dimension of V just as declared in the\n\ * calling subroutine. NW .LE. LDV\n\ *\n\ * NH (input) integer scalar\n\ * The number of columns of T. NH.GE.NW.\n\ *\n\ * T (workspace) REAL array, dimension (LDT,NW)\n\ *\n\ * LDT (input) integer\n\ * The leading dimension of T just as declared in the\n\ * calling subroutine. NW .LE. LDT\n\ *\n\ * NV (input) integer\n\ * The number of rows of work array WV available for\n\ * workspace. NV.GE.NW.\n\ *\n\ * WV (workspace) REAL array, dimension (LDWV,NW)\n\ *\n\ * LDWV (input) integer\n\ * The leading dimension of W just as declared in the\n\ * calling subroutine. NW .LE. LDV\n\ *\n\ * WORK (workspace) REAL array, dimension LWORK.\n\ * On exit, WORK(1) is set to an estimate of the optimal value\n\ * of LWORK for the given values of N, NW, KTOP and KBOT.\n\ *\n\ * LWORK (input) integer\n\ * The dimension of the work array WORK. LWORK = 2*NW\n\ * suffices, but greater efficiency may result from larger\n\ * values of LWORK.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; SLAQR3\n\ * only estimates the optimal workspace size for the given\n\ * values of N, NW, KTOP and KBOT. The estimate is returned\n\ * in WORK(1). No error message related to LWORK is issued\n\ * by XERBLA. Neither H nor Z are accessed.\n\ *\n\n\ * ================================================================\n\ * Based on contributions by\n\ * Karen Braman and Ralph Byers, Department of Mathematics,\n\ * University of Kansas, USA\n\ *\n\ * ================================================================\n" ruby-lapack-1.7.2/dev/defs/zpbsv0000644000175000017500000001142712502223526016361 0ustar uwabamiuwabami--- :name: zpbsv :md5sum: 623d43399d1b4bef8bd502dca8eb4707 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPBSV computes the solution to a complex system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N Hermitian positive definite band matrix and X\n\ * and B are N-by-NRHS matrices.\n\ *\n\ * The Cholesky decomposition is used to factor A as\n\ * A = U**H * U, if UPLO = 'U', or\n\ * A = L * L**H, if UPLO = 'L',\n\ * where U is an upper triangular band matrix, and L is a lower\n\ * triangular band matrix, with the same number of superdiagonals or\n\ * subdiagonals as A. The factored form of A is then used to solve the\n\ * system of equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).\n\ * See below for further details.\n\ *\n\ * On exit, if INFO = 0, the triangular factor U or L from the\n\ * Cholesky factorization A = U**H*U or A = L*L**H of the band\n\ * matrix A, in the same storage format as A.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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 leading minor of order i of A is not\n\ * positive definite, so the factorization could not be\n\ * completed, and the solution has not been computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * N = 6, KD = 2, and UPLO = 'U':\n\ *\n\ * On entry: On exit:\n\ *\n\ * * * a13 a24 a35 a46 * * u13 u24 u35 u46\n\ * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n\ * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n\ *\n\ * Similarly, if UPLO = 'L' the format of A is as follows:\n\ *\n\ * On entry: On exit:\n\ *\n\ * a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n\ * a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n\ * a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n\ *\n\ * Array elements marked * are not used by the routine.\n\ *\n\ * =====================================================================\n\ *\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZPBTRF, ZPBTRS\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/csptrf0000644000175000017500000001155712502223525016521 0ustar uwabamiuwabami--- :name: csptrf :md5sum: 4c99db07d0e28d8dca31885d59d58116 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - ldap - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE CSPTRF( UPLO, N, AP, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSPTRF computes the factorization of a complex symmetric matrix A\n\ * stored in packed format using the Bunch-Kaufman diagonal pivoting\n\ * method:\n\ *\n\ * A = U*D*U**T or A = L*D*L**T\n\ *\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, and D is symmetric and block diagonal with\n\ * 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L, stored as a packed triangular\n\ * matrix overwriting A (see below for further details).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D.\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\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, D(i,i) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular, and division by zero will occur if it\n\ * is used to solve a system of equations.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * 5-96 - Based on modifications by J. Lewis, Boeing Computer Services\n\ * Company\n\ *\n\ * If UPLO = 'U', then A = U*D*U', where\n\ * U = P(n)*U(n)* ... *P(k)U(k)* ...,\n\ * i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n\ * 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I v 0 ) k-s\n\ * U(k) = ( 0 I 0 ) s\n\ * ( 0 0 I ) n-k\n\ * k-s s n-k\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n\ * If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n\ * and A(k,k), and v overwrites A(1:k-2,k-1:k).\n\ *\n\ * If UPLO = 'L', then A = L*D*L', where\n\ * L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n\ * i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n\ * n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I 0 0 ) k-1\n\ * L(k) = ( 0 I 0 ) s\n\ * ( 0 v I ) n-k-s+1\n\ * k-1 s n-k-s+1\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n\ * If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n\ * and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cunmql0000644000175000017500000001046312502223526016513 0ustar uwabamiuwabami--- :name: cunmql :md5sum: e075186612aa4b25773c8e1ad534f676 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CUNMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CUNMQL overwrites the general complex M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'C': Q**H * C C * Q**H\n\ *\n\ * where Q is a complex unitary matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(k) . . . H(2) H(1)\n\ *\n\ * as returned by CGEQLF. Q is of order M if SIDE = 'L' and of order N\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**H from the Left;\n\ * = 'R': apply Q or Q**H from the Right.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q;\n\ * = 'C': Transpose, apply Q**H.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,K)\n\ * The i-th column must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * CGEQLF in the last k columns of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ * If SIDE = 'L', LDA >= max(1,M);\n\ * if SIDE = 'R', LDA >= max(1,N).\n\ *\n\ * TAU (input) COMPLEX array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by CGEQLF.\n\ *\n\ * C (input/output) COMPLEX array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace/output) COMPLEX 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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M).\n\ * For optimum performance LWORK >= N*NB if SIDE = 'L', and\n\ * LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n\ * 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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssptrs0000644000175000017500000000462612502223526016556 0ustar uwabamiuwabami--- :name: ssptrs :md5sum: 0f123f21a75d567b16fa17a541053358 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: real :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSPTRS solves a system of linear equations A*X = B with a real\n\ * symmetric matrix A stored in packed format using the factorization\n\ * A = U*D*U**T or A = L*D*L**T computed by SSPTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AP (input) REAL array, dimension (N*(N+1)/2)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by SSPTRF, stored as a\n\ * packed triangular matrix.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by SSPTRF.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgebal0000644000175000017500000001043412502223526016430 0ustar uwabamiuwabami--- :name: dgebal :md5sum: 45f9fb3e24750e422000cd2ba1545396 :category: :subroutine :arguments: - job: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - scale: :type: doublereal :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGEBAL balances a general real matrix A. This involves, first,\n\ * permuting A by a similarity transformation to isolate eigenvalues\n\ * in the first 1 to ILO-1 and last IHI+1 to N elements on the\n\ * diagonal; and second, applying a diagonal similarity transformation\n\ * to rows and columns ILO to IHI to make the rows and columns as\n\ * close in norm as possible. Both steps are optional.\n\ *\n\ * Balancing may reduce the 1-norm of the matrix, and improve the\n\ * accuracy of the computed eigenvalues and/or eigenvectors.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * Specifies the operations to be performed on A:\n\ * = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0\n\ * for i = 1,...,N;\n\ * = 'P': permute only;\n\ * = 'S': scale only;\n\ * = 'B': both permute and scale.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the input matrix A.\n\ * On exit, A is overwritten by the balanced matrix.\n\ * If JOB = 'N', A is not referenced.\n\ * See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * ILO (output) INTEGER\n\ * IHI (output) INTEGER\n\ * ILO and IHI are set to integers such that on exit\n\ * A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.\n\ * If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n\ *\n\ * SCALE (output) DOUBLE PRECISION array, dimension (N)\n\ * Details of the permutations and scaling factors applied to\n\ * A. If P(j) is the index of the row and column interchanged\n\ * with row and column j and D(j) is the scaling factor\n\ * applied to row and column j, then\n\ * SCALE(j) = P(j) for j = 1,...,ILO-1\n\ * = D(j) for j = ILO,...,IHI\n\ * = P(j) for j = IHI+1,...,N.\n\ * The order in which the interchanges are made is N to IHI+1,\n\ * then 1 to ILO-1.\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 permutations consist of row and column interchanges which put\n\ * the matrix in the form\n\ *\n\ * ( T1 X Y )\n\ * P A P = ( 0 B Z )\n\ * ( 0 0 T2 )\n\ *\n\ * where T1 and T2 are upper triangular matrices whose eigenvalues lie\n\ * along the diagonal. The column indices ILO and IHI mark the starting\n\ * and ending columns of the submatrix B. Balancing consists of applying\n\ * a diagonal similarity transformation inv(D) * B * D to make the\n\ * 1-norms of each row of B and its corresponding column nearly equal.\n\ * The output matrix is\n\ *\n\ * ( T1 X*D Y )\n\ * ( 0 inv(D)*B*D inv(D)*Z ).\n\ * ( 0 0 T2 )\n\ *\n\ * Information about the permutations P and the diagonal matrix D is\n\ * returned in the vector SCALE.\n\ *\n\ * This subroutine is based on the EISPACK routine BALANC.\n\ *\n\ * Modified by Tzu-Yi Chen, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cpstrf0000644000175000017500000000674012502223525016517 0ustar uwabamiuwabami--- :name: cpstrf :md5sum: 6db062af9f26bd93641c108b59166894 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - piv: :type: integer :intent: output :dims: - n - rank: :type: integer :intent: output - tol: :type: real :intent: input - work: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPSTRF computes the Cholesky factorization with complete\n\ * pivoting of a complex Hermitian positive semidefinite matrix A.\n\ *\n\ * The factorization has the form\n\ * P' * A * P = U' * U , if UPLO = 'U',\n\ * P' * A * P = L * L', if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is lower triangular, and\n\ * P is stored as vector PIV.\n\ *\n\ * This algorithm does not attempt to check that A is positive\n\ * semidefinite. This version of the algorithm calls level 3 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * n by n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n by n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the factor U or L from the Cholesky\n\ * factorization as above.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * PIV (output) INTEGER array, dimension (N)\n\ * PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n\ *\n\ * RANK (output) INTEGER\n\ * The rank of A given by the number of steps the algorithm\n\ * completed.\n\ *\n\ * TOL (input) REAL\n\ * User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) )\n\ * will be used. The algorithm terminates at the (K-1)st step\n\ * if the pivot <= TOL.\n\ *\n\ * WORK (workspace) REAL array, dimension (2*N)\n\ * Work space.\n\ *\n\ * INFO (output) INTEGER\n\ * < 0: If INFO = -K, the K-th argument had an illegal value,\n\ * = 0: algorithm completed successfully, and\n\ * > 0: the matrix A is either rank deficient with computed rank\n\ * as returned in RANK, or is indefinite. See Section 7 of\n\ * LAPACK Working Note #161 for further information.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cla_hercond_c0000644000175000017500000000672212502223525017761 0ustar uwabamiuwabami--- :name: cla_hercond_c :md5sum: a663416c99cd3cb30e966cfb58383a71 :category: :function :type: real :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - c: :type: real :intent: input :dims: - n - capply: :type: logical :intent: input - info: :type: integer :intent: output - work: :type: complex :intent: input :dims: - 2*n - rwork: :type: real :intent: input :dims: - n :substitutions: {} :fortran_help: " REAL FUNCTION CLA_HERCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLA_HERCOND_C computes the infinity norm condition number of\n\ * op(A) * inv(diag(C)) where C is a REAL vector.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX array, dimension (LDAF,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by CHETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by CHETRF.\n\ *\n\ * C (input) REAL array, dimension (N)\n\ * The vector C in the formula op(A) * inv(diag(C)).\n\ *\n\ * CAPPLY (input) LOGICAL\n\ * If .TRUE. then access the vector C in the formula above.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * i > 0: The ith argument is invalid.\n\ *\n\ * WORK (input) COMPLEX array, dimension (2*N).\n\ * Workspace.\n\ *\n\ * RWORK (input) REAL array, dimension (N).\n\ * Workspace.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER KASE, I, J\n REAL AINVNM, ANORM, TMP\n LOGICAL UP\n COMPLEX ZDUM\n\ * ..\n\ * .. Local Arrays ..\n INTEGER ISAVE( 3 )\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CLACN2, CHETRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n\ * ..\n\ * .. Statement Functions ..\n REAL CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slalsa0000644000175000017500000001741612502223526016500 0ustar uwabamiuwabami--- :name: slalsa :md5sum: 3817ef103afe5374c5f2833dfd84f267 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - smlsiz: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - bx: :type: real :intent: output :dims: - ldbx - nrhs - ldbx: :type: integer :intent: input - u: :type: real :intent: input :dims: - ldu - smlsiz - ldu: :type: integer :intent: input - vt: :type: real :intent: input :dims: - ldu - smlsiz+1 - k: :type: integer :intent: input :dims: - n - difl: :type: real :intent: input :dims: - ldu - nlvl - difr: :type: real :intent: input :dims: - ldu - 2 * nlvl - z: :type: real :intent: input :dims: - ldu - nlvl - poles: :type: real :intent: input :dims: - ldu - 2 * nlvl - givptr: :type: integer :intent: input :dims: - n - givcol: :type: integer :intent: input :dims: - ldgcol - 2 * nlvl - ldgcol: :type: integer :intent: input - perm: :type: integer :intent: input :dims: - ldgcol - nlvl - givnum: :type: real :intent: input :dims: - ldu - 2 * nlvl - c: :type: real :intent: input :dims: - n - s: :type: real :intent: input :dims: - n - work: :type: real :intent: workspace :dims: - n - iwork: :type: integer :intent: workspace :dims: - 3 * n - info: :type: integer :intent: output :substitutions: ldbx: n nlvl: (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1 :fortran_help: " SUBROUTINE SLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLALSA is an itermediate step in solving the least squares problem\n\ * by computing the SVD of the coefficient matrix in compact form (The\n\ * singular vectors are computed as products of simple orthorgonal\n\ * matrices.).\n\ *\n\ * If ICOMPQ = 0, SLALSA applies the inverse of the left singular vector\n\ * matrix of an upper bidiagonal matrix to the right hand side; and if\n\ * ICOMPQ = 1, SLALSA applies the right singular vector matrix to the\n\ * right hand side. The singular vector matrices were generated in\n\ * compact form by SLALSA.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ *\n\ * ICOMPQ (input) INTEGER\n\ * Specifies whether the left or the right singular vector\n\ * matrix is involved.\n\ * = 0: Left singular vector matrix\n\ * = 1: Right singular vector matrix\n\ *\n\ * SMLSIZ (input) INTEGER\n\ * The maximum size of the subproblems at the bottom of the\n\ * computation tree.\n\ *\n\ * N (input) INTEGER\n\ * The row and column dimensions of the upper bidiagonal matrix.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of columns of B and BX. NRHS must be at least 1.\n\ *\n\ * B (input/output) REAL array, dimension ( LDB, NRHS )\n\ * On input, B contains the right hand sides of the least\n\ * squares problem in rows 1 through M.\n\ * On output, B contains the solution X in rows 1 through N.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B in the calling subprogram.\n\ * LDB must be at least max(1,MAX( M, N ) ).\n\ *\n\ * BX (output) REAL array, dimension ( LDBX, NRHS )\n\ * On exit, the result of applying the left or right singular\n\ * vector matrix to B.\n\ *\n\ * LDBX (input) INTEGER\n\ * The leading dimension of BX.\n\ *\n\ * U (input) REAL array, dimension ( LDU, SMLSIZ ).\n\ * On entry, U contains the left singular vector matrices of all\n\ * subproblems at the bottom level.\n\ *\n\ * LDU (input) INTEGER, LDU = > N.\n\ * The leading dimension of arrays U, VT, DIFL, DIFR,\n\ * POLES, GIVNUM, and Z.\n\ *\n\ * VT (input) REAL array, dimension ( LDU, SMLSIZ+1 ).\n\ * On entry, VT' contains the right singular vector matrices of\n\ * all subproblems at the bottom level.\n\ *\n\ * K (input) INTEGER array, dimension ( N ).\n\ *\n\ * DIFL (input) REAL array, dimension ( LDU, NLVL ).\n\ * where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.\n\ *\n\ * DIFR (input) REAL array, dimension ( LDU, 2 * NLVL ).\n\ * On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record\n\ * distances between singular values on the I-th level and\n\ * singular values on the (I -1)-th level, and DIFR(*, 2 * I)\n\ * record the normalizing factors of the right singular vectors\n\ * matrices of subproblems on I-th level.\n\ *\n\ * Z (input) REAL array, dimension ( LDU, NLVL ).\n\ * On entry, Z(1, I) contains the components of the deflation-\n\ * adjusted updating row vector for subproblems on the I-th\n\ * level.\n\ *\n\ * POLES (input) REAL array, dimension ( LDU, 2 * NLVL ).\n\ * On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old\n\ * singular values involved in the secular equations on the I-th\n\ * level.\n\ *\n\ * GIVPTR (input) INTEGER array, dimension ( N ).\n\ * On entry, GIVPTR( I ) records the number of Givens\n\ * rotations performed on the I-th problem on the computation\n\ * tree.\n\ *\n\ * GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ).\n\ * On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the\n\ * locations of Givens rotations performed on the I-th level on\n\ * the computation tree.\n\ *\n\ * LDGCOL (input) INTEGER, LDGCOL = > N.\n\ * The leading dimension of arrays GIVCOL and PERM.\n\ *\n\ * PERM (input) INTEGER array, dimension ( LDGCOL, NLVL ).\n\ * On entry, PERM(*, I) records permutations done on the I-th\n\ * level of the computation tree.\n\ *\n\ * GIVNUM (input) REAL array, dimension ( LDU, 2 * NLVL ).\n\ * On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-\n\ * values of Givens rotations performed on the I-th level on the\n\ * computation tree.\n\ *\n\ * C (input) REAL array, dimension ( N ).\n\ * On entry, if the I-th subproblem is not square,\n\ * C( I ) contains the C-value of a Givens rotation related to\n\ * the right null space of the I-th subproblem.\n\ *\n\ * S (input) REAL array, dimension ( N ).\n\ * On entry, if the I-th subproblem is not square,\n\ * S( I ) contains the S-value of a Givens rotation related to\n\ * the right null space of the I-th subproblem.\n\ *\n\ * WORK (workspace) REAL array.\n\ * The dimension must be at least N.\n\ *\n\ * IWORK (workspace) INTEGER array.\n\ * The dimension must be at least 3 * N\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\ * Based on contributions by\n\ * Ming Gu and Ren-Cang Li, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgeesx0000644000175000017500000002376712502223526016506 0ustar uwabamiuwabami--- :name: dgeesx :md5sum: 86306dfb6f982e18929b60f86f2c7b1f :category: :subroutine :arguments: - jobvs: :type: char :intent: input - sort: :type: char :intent: input - select: :intent: external procedure :block_type: logical :block_arg_num: 2 :block_arg_type: doublereal - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - sdim: :type: integer :intent: output - wr: :type: doublereal :intent: output :dims: - n - wi: :type: doublereal :intent: output :dims: - n - vs: :type: doublereal :intent: output :dims: - ldvs - n - ldvs: :type: integer :intent: input - rconde: :type: doublereal :intent: output - rcondv: :type: doublereal :intent: output - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(lsame_(&sense,\"E\")||lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? n+n*n/2 : 3*n" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvs: "lsame_(&jobvs,\"V\") ? n : 1" :fortran_help: " SUBROUTINE DGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, IWORK, LIWORK, BWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGEESX computes for an N-by-N real nonsymmetric matrix A, the\n\ * eigenvalues, the real Schur form T, and, optionally, the matrix of\n\ * Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).\n\ *\n\ * Optionally, it also orders the eigenvalues on the diagonal of the\n\ * real Schur form so that selected eigenvalues are at the top left;\n\ * computes a reciprocal condition number for the average of the\n\ * selected eigenvalues (RCONDE); and computes a reciprocal condition\n\ * number for the right invariant subspace corresponding to the\n\ * selected eigenvalues (RCONDV). The leading columns of Z form an\n\ * orthonormal basis for this invariant subspace.\n\ *\n\ * For further explanation of the reciprocal condition numbers RCONDE\n\ * and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where\n\ * these quantities are called s and sep respectively).\n\ *\n\ * A real matrix is in real Schur form if it is upper quasi-triangular\n\ * with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in\n\ * the form\n\ * [ a b ]\n\ * [ c a ]\n\ *\n\ * where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVS (input) CHARACTER*1\n\ * = 'N': Schur vectors are not computed;\n\ * = 'V': Schur vectors are computed.\n\ *\n\ * SORT (input) CHARACTER*1\n\ * Specifies whether or not to order the eigenvalues on the\n\ * diagonal of the Schur form.\n\ * = 'N': Eigenvalues are not ordered;\n\ * = 'S': Eigenvalues are ordered (see SELECT).\n\ *\n\ * SELECT (external procedure) LOGICAL FUNCTION of two DOUBLE PRECISION arguments\n\ * SELECT must be declared EXTERNAL in the calling subroutine.\n\ * If SORT = 'S', SELECT is used to select eigenvalues to sort\n\ * to the top left of the Schur form.\n\ * If SORT = 'N', SELECT is not referenced.\n\ * An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if\n\ * SELECT(WR(j),WI(j)) is true; i.e., if either one of a\n\ * complex conjugate pair of eigenvalues is selected, then both\n\ * are. Note that a selected complex eigenvalue may no longer\n\ * satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since\n\ * ordering may change the value of complex eigenvalues\n\ * (especially if the eigenvalue is ill-conditioned); in this\n\ * case INFO may be set to N+3 (see INFO below).\n\ *\n\ * SENSE (input) CHARACTER*1\n\ * Determines which reciprocal condition numbers are computed.\n\ * = 'N': None are computed;\n\ * = 'E': Computed for average of selected eigenvalues only;\n\ * = 'V': Computed for selected right invariant subspace only;\n\ * = 'B': Computed for both.\n\ * If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n\ * On entry, the N-by-N matrix A.\n\ * On exit, A is overwritten by its real Schur form T.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * SDIM (output) INTEGER\n\ * If SORT = 'N', SDIM = 0.\n\ * If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n\ * for which SELECT is true. (Complex conjugate\n\ * pairs for which SELECT is true for either\n\ * eigenvalue count as 2.)\n\ *\n\ * WR (output) DOUBLE PRECISION array, dimension (N)\n\ * WI (output) DOUBLE PRECISION array, dimension (N)\n\ * WR and WI contain the real and imaginary parts, respectively,\n\ * of the computed eigenvalues, in the same order that they\n\ * appear on the diagonal of the output Schur form T. Complex\n\ * conjugate pairs of eigenvalues appear consecutively with the\n\ * eigenvalue having the positive imaginary part first.\n\ *\n\ * VS (output) DOUBLE PRECISION array, dimension (LDVS,N)\n\ * If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur\n\ * vectors.\n\ * If JOBVS = 'N', VS is not referenced.\n\ *\n\ * LDVS (input) INTEGER\n\ * The leading dimension of the array VS. LDVS >= 1, and if\n\ * JOBVS = 'V', LDVS >= N.\n\ *\n\ * RCONDE (output) DOUBLE PRECISION\n\ * If SENSE = 'E' or 'B', RCONDE contains the reciprocal\n\ * condition number for the average of the selected eigenvalues.\n\ * Not referenced if SENSE = 'N' or 'V'.\n\ *\n\ * RCONDV (output) DOUBLE PRECISION\n\ * If SENSE = 'V' or 'B', RCONDV contains the reciprocal\n\ * condition number for the selected right invariant subspace.\n\ * Not referenced if SENSE = 'N' or 'E'.\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,3*N).\n\ * Also, if SENSE = 'E' or 'V' or 'B',\n\ * LWORK >= N+2*SDIM*(N-SDIM), where SDIM is the number of\n\ * selected eigenvalues computed by this routine. Note that\n\ * N+2*SDIM*(N-SDIM) <= N+N*N/2. Note also that an error is only\n\ * returned if LWORK < max(1,3*N), but if SENSE = 'E' or 'V' or\n\ * 'B' this may not be large enough.\n\ * For good performance, LWORK must generally be larger.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates upper bounds on the optimal sizes of the\n\ * arrays WORK and IWORK, returns these values as the first\n\ * entries of the WORK and IWORK arrays, and no error messages\n\ * related to LWORK or LIWORK are issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK.\n\ * LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM).\n\ * Note that SDIM*(N-SDIM) <= N*N/4. Note also that an error is\n\ * only returned if LIWORK < 1, but if SENSE = 'V' or 'B' this\n\ * may not be large enough.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates upper bounds on the optimal sizes of\n\ * the arrays WORK and IWORK, returns these values as the first\n\ * entries of the WORK and IWORK arrays, and no error messages\n\ * related to LWORK or LIWORK are issued by XERBLA.\n\ *\n\ * BWORK (workspace) LOGICAL array, dimension (N)\n\ * Not referenced if SORT = 'N'.\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, and i is\n\ * <= N: the QR algorithm failed to compute all the\n\ * eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI\n\ * contain those eigenvalues which have converged; if\n\ * JOBVS = 'V', VS contains the transformation which\n\ * reduces A to its partially converged Schur form.\n\ * = N+1: the eigenvalues could not be reordered because some\n\ * eigenvalues were too close to separate (the problem\n\ * is very ill-conditioned);\n\ * = N+2: after reordering, roundoff changed values of some\n\ * complex eigenvalues so that leading eigenvalues in\n\ * the Schur form no longer satisfy SELECT=.TRUE. This\n\ * could also be caused by underflow due to scaling.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssbevd0000644000175000017500000001420212502223526016475 0ustar uwabamiuwabami--- :name: ssbevd :md5sum: 71100f8057bbfe6a4838357d0d1b2105 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=0 ? 1 : lsame_(&jobz,\"N\") ? 2*n : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "(lsame_(&jobz,\"N\")||n<=0) ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" :fortran_help: " SUBROUTINE SSBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSBEVD computes all the eigenvalues and, optionally, eigenvectors of\n\ * a real symmetric band matrix A. If eigenvectors are desired, it uses\n\ * a divide and conquer algorithm.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) REAL array, dimension (LDAB, N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * On exit, AB is overwritten by values generated during the\n\ * reduction to tridiagonal form. If UPLO = 'U', the first\n\ * superdiagonal and the diagonal of the tridiagonal matrix T\n\ * are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n\ * the diagonal and first subdiagonal of T are returned in the\n\ * first two rows of AB.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD + 1.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) REAL array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n\ * eigenvectors of the matrix A, with the i-th column of Z\n\ * holding the eigenvector associated with W(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace/output) REAL array,\n\ * dimension (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\ * IF N <= 1, LWORK must be at least 1.\n\ * If JOBZ = 'N' and N > 2, LWORK must be at least 2*N.\n\ * If JOBZ = 'V' and N > 2, LWORK must be at least\n\ * ( 1 + 5*N + 2*N**2 ).\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the optimal sizes of the WORK and IWORK\n\ * arrays, returns these values as the first entries of the WORK\n\ * and IWORK arrays, and no error message related to LWORK or\n\ * LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array LIWORK.\n\ * If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.\n\ * If JOBZ = 'V' and N > 2, LIWORK must be at least 3 + 5*N.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK and IWORK arrays, and no error message related to\n\ * LWORK or LIWORK 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 algorithm failed to converge; i\n\ * off-diagonal elements of an intermediate tridiagonal\n\ * form did not converge to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsygv0000644000175000017500000001243512502223526016351 0ustar uwabamiuwabami--- :name: dsygv :md5sum: 1004f5151de1d6f47d819bbd8507eeaa :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 3*n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSYGV computes all the eigenvalues, and optionally, the eigenvectors\n\ * of a real generalized symmetric-definite eigenproblem, of the form\n\ * A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.\n\ * Here A and B are assumed to be symmetric and B is also\n\ * positive definite.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * Specifies the problem type to be solved:\n\ * = 1: A*x = (lambda)*B*x\n\ * = 2: A*B*x = (lambda)*x\n\ * = 3: B*A*x = (lambda)*x\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of A contains the\n\ * upper triangular part of the matrix A. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of A contains\n\ * the lower triangular part of the matrix A.\n\ *\n\ * On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n\ * matrix Z of eigenvectors. The eigenvectors are normalized\n\ * as follows:\n\ * if ITYPE = 1 or 2, Z**T*B*Z = I;\n\ * if ITYPE = 3, Z**T*inv(B)*Z = I.\n\ * If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n\ * or the lower triangle (if UPLO='L') of A, including the\n\ * diagonal, is destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n\ * On entry, the symmetric positive definite matrix B.\n\ * If UPLO = 'U', the leading N-by-N upper triangular part of B\n\ * contains the upper triangular part of the matrix B.\n\ * If UPLO = 'L', the leading N-by-N lower triangular part of B\n\ * contains the lower triangular part of the matrix B.\n\ *\n\ * On exit, if INFO <= N, the part of B containing the matrix is\n\ * overwritten by the triangular factor U or L from the Cholesky\n\ * factorization B = U**T*U or B = L*L**T.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\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 length of the array WORK. LWORK >= max(1,3*N-1).\n\ * For optimal efficiency, LWORK >= (NB+2)*N,\n\ * where NB is the blocksize for DSYTRD returned by ILAENV.\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: DPOTRF or DSYEV returned an error code:\n\ * <= N: if INFO = i, DSYEV failed to converge;\n\ * i off-diagonal elements of an intermediate\n\ * tridiagonal form did not converge to zero;\n\ * > N: if INFO = N + i, for 1 <= i <= N, then the leading\n\ * minor of order i of B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clarft0000644000175000017500000001072412502223525016466 0ustar uwabamiuwabami--- :name: clarft :md5sum: 74b95dc223df4ad5e87ce0c8b73b032b :category: :subroutine :arguments: - direct: :type: char :intent: input - storev: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - v: :type: complex :intent: input/output :dims: - ldv - "lsame_(&storev,\"C\") ? k : lsame_(&storev,\"R\") ? n : 0" - ldv: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - t: :type: complex :intent: output :dims: - ldt - k - ldt: :type: integer :intent: input :substitutions: ldt: k :fortran_help: " SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLARFT forms the triangular factor T of a complex block reflector H\n\ * of order n, which is defined as a product of k elementary reflectors.\n\ *\n\ * If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n\ *\n\ * If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n\ *\n\ * If STOREV = 'C', the vector which defines the elementary reflector\n\ * H(i) is stored in the i-th column of the array V, and\n\ *\n\ * H = I - V * T * V'\n\ *\n\ * If STOREV = 'R', the vector which defines the elementary reflector\n\ * H(i) is stored in the i-th row of the array V, and\n\ *\n\ * H = I - V' * T * V\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * DIRECT (input) CHARACTER*1\n\ * Specifies the order in which the elementary reflectors are\n\ * multiplied to form the block reflector:\n\ * = 'F': H = H(1) H(2) . . . H(k) (Forward)\n\ * = 'B': H = H(k) . . . H(2) H(1) (Backward)\n\ *\n\ * STOREV (input) CHARACTER*1\n\ * Specifies how the vectors which define the elementary\n\ * reflectors are stored (see also Further Details):\n\ * = 'C': columnwise\n\ * = 'R': rowwise\n\ *\n\ * N (input) INTEGER\n\ * The order of the block reflector H. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The order of the triangular factor T (= the number of\n\ * elementary reflectors). K >= 1.\n\ *\n\ * V (input/output) COMPLEX array, dimension\n\ * (LDV,K) if STOREV = 'C'\n\ * (LDV,N) if STOREV = 'R'\n\ * The matrix V. See further details.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V.\n\ * If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n\ *\n\ * TAU (input) COMPLEX array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i).\n\ *\n\ * T (output) COMPLEX array, dimension (LDT,K)\n\ * The k by k triangular factor T of the block reflector.\n\ * If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n\ * lower triangular. The rest of the array is not used.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= K.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The shape of the matrix V and the storage of the vectors which define\n\ * the H(i) is best illustrated by the following example with n = 5 and\n\ * k = 3. The elements equal to 1 are not stored; the corresponding\n\ * array elements are modified but restored on exit. The rest of the\n\ * array is not used.\n\ *\n\ * DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':\n\ *\n\ * V = ( 1 ) V = ( 1 v1 v1 v1 v1 )\n\ * ( v1 1 ) ( 1 v2 v2 v2 )\n\ * ( v1 v2 1 ) ( 1 v3 v3 )\n\ * ( v1 v2 v3 )\n\ * ( v1 v2 v3 )\n\ *\n\ * DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':\n\ *\n\ * V = ( v1 v2 v3 ) V = ( v1 v1 1 )\n\ * ( v1 v2 v3 ) ( v2 v2 v2 1 )\n\ * ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )\n\ * ( 1 v3 )\n\ * ( 1 )\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zsycon0000644000175000017500000000526412502223526016544 0ustar uwabamiuwabami--- :name: zsycon :md5sum: 3caa5f8f193ae08f62f6bc017fca8b5a :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSYCON estimates the reciprocal of the condition number (in the\n\ * 1-norm) of a complex symmetric matrix A using the factorization\n\ * A = U*D*U**T or A = L*D*L**T computed by ZSYTRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by ZSYTRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by ZSYTRF.\n\ *\n\ * ANORM (input) DOUBLE PRECISION\n\ * The 1-norm of the original matrix A.\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n\ * estimate of the 1-norm of inv(A) computed in this routine.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgesv0000644000175000017500000000604012502223526016337 0ustar uwabamiuwabami--- :name: sgesv :md5sum: 2f2e91d8b360280d7c090a0bdf896bf9 :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGESV computes the solution to a real system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n\ *\n\ * The LU decomposition with partial pivoting and row interchanges is\n\ * used to factor A as\n\ * A = P * L * U,\n\ * where P is a permutation matrix, L is unit lower triangular, and U is\n\ * upper triangular. The factored form of A is then used to solve the\n\ * system of equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the N-by-N coefficient matrix A.\n\ * On exit, the factors L and U from the factorization\n\ * A = P*L*U; the unit diagonal elements of L are not stored.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * The pivot indices that define the permutation matrix P;\n\ * row i of the matrix was interchanged with row IPIV(i).\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS matrix of right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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, U(i,i) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, so the solution could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. External Subroutines ..\n EXTERNAL SGETRF, SGETRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zgbtrf0000644000175000017500000000742412502223526016515 0ustar uwabamiuwabami--- :name: zgbtrf :md5sum: 6b9ba6577c2423774dbf912b5a5a3595 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGBTRF computes an LU factorization of a complex m-by-n band matrix A\n\ * using partial pivoting with row interchanges.\n\ *\n\ * This is the blocked version of the algorithm, calling Level 3 BLAS.\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\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows KL+1 to\n\ * 2*KL+KU+1; rows 1 to KL of the array need not be set.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n\ *\n\ * On exit, details of the factorization: U is stored as an\n\ * upper triangular band matrix with KL+KU superdiagonals in\n\ * rows 1 to KL+KU+1, and the multipliers used during the\n\ * factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n\ * See below for further details.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n\ *\n\ * IPIV (output) INTEGER array, dimension (min(M,N))\n\ * The pivot indices; for 1 <= i <= min(M,N), row i of the\n\ * matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, and division by zero will occur if it is used\n\ * to solve a system of equations.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * M = N = 6, KL = 2, KU = 1:\n\ *\n\ * On entry: On exit:\n\ *\n\ * * * * + + + * * * u14 u25 u36\n\ * * * + + + + * * u13 u24 u35 u46\n\ * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n\ * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n\ * a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n\ * a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n\ *\n\ * Array elements marked * are not used by the routine; elements marked\n\ * + need not be set on entry, but are required by the routine to store\n\ * elements of U because of fill-in resulting from the row interchanges.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sormqr0000644000175000017500000001043112502223526016532 0ustar uwabamiuwabami--- :name: sormqr :md5sum: 67964f86905e74bb1a25c5c33745dd83 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SORMQR overwrites the general real M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'T': Q**T * C C * Q**T\n\ *\n\ * where Q is a real orthogonal matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by SGEQRF. Q is of order M if SIDE = 'L' and of order N\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**T from the Left;\n\ * = 'R': apply Q or Q**T from the Right.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q;\n\ * = 'T': Transpose, apply Q**T.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,K)\n\ * The i-th column must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * SGEQRF in the first k columns of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ * If SIDE = 'L', LDA >= max(1,M);\n\ * if SIDE = 'R', LDA >= max(1,N).\n\ *\n\ * TAU (input) REAL array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by SGEQRF.\n\ *\n\ * C (input/output) REAL array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace/output) REAL 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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M).\n\ * For optimum performance LWORK >= N*NB if SIDE = 'L', and\n\ * LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n\ * 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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ztrrfs0000644000175000017500000001162312502223526016545 0ustar uwabamiuwabami--- :name: ztrrfs :md5sum: 794fda595394da3ba558276fc668ed14 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTRRFS provides error bounds and backward error estimates for the\n\ * solution to a system of linear equations with a triangular\n\ * coefficient matrix.\n\ *\n\ * The solution matrix X must be computed by ZTRTRS or some other\n\ * means before entering this routine. ZTRRFS does not do iterative\n\ * refinement because doing so cannot improve the backward error.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The triangular matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of the array A contains the upper\n\ * triangular matrix, and the strictly lower triangular part of\n\ * A is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of the array A contains the lower triangular\n\ * matrix, and the strictly upper triangular part of A is not\n\ * referenced. If DIAG = 'U', the diagonal elements of A are\n\ * also not referenced and are assumed to be 1.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * The solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slantr0000644000175000017500000000725212502223526016521 0ustar uwabamiuwabami--- :name: slantr :md5sum: f3ff0071196a89e069537cf5a2e623f8 :category: :function :type: real :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? m : 0" :fortran_help: " REAL FUNCTION SLANTR( NORM, UPLO, DIAG, M, N, A, LDA, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLANTR returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * trapezoidal or triangular matrix A.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * SLANTR returns the value\n\ *\n\ * SLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in SLANTR as described\n\ * above.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the matrix A is upper or lower trapezoidal.\n\ * = 'U': Upper trapezoidal\n\ * = 'L': Lower trapezoidal\n\ * Note that A is triangular instead of trapezoidal if M = N.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * Specifies whether or not the matrix A has unit diagonal.\n\ * = 'N': Non-unit diagonal\n\ * = 'U': Unit diagonal\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A. M >= 0, and if\n\ * UPLO = 'U', M <= N. When M = 0, SLANTR is set to zero.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix A. N >= 0, and if\n\ * UPLO = 'L', N <= M. When N = 0, SLANTR is set to zero.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * The trapezoidal matrix A (A is triangular if M = N).\n\ * If UPLO = 'U', the leading m by n upper trapezoidal part of\n\ * the array A contains the upper trapezoidal matrix, and the\n\ * strictly lower triangular part of A is not referenced.\n\ * If UPLO = 'L', the leading m by n lower trapezoidal part of\n\ * the array A contains the lower trapezoidal matrix, and the\n\ * strictly upper triangular part of A is not referenced. Note\n\ * that when DIAG = 'U', the diagonal elements of A are not\n\ * referenced and are assumed to be one.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(M,1).\n\ *\n\ * WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n\ * referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cunml20000644000175000017500000000731412502223526016415 0ustar uwabamiuwabami--- :name: cunml2 :md5sum: 978c51e7604473ec5f48cacdc20d9c44 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CUNML2 overwrites the general complex m-by-n matrix C with\n\ *\n\ * Q * C if SIDE = 'L' and TRANS = 'N', or\n\ *\n\ * Q'* C if SIDE = 'L' and TRANS = 'C', or\n\ *\n\ * C * Q if SIDE = 'R' and TRANS = 'N', or\n\ *\n\ * C * Q' if SIDE = 'R' and TRANS = 'C',\n\ *\n\ * where Q is a complex unitary matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(k)' . . . H(2)' H(1)'\n\ *\n\ * as returned by CGELQF. Q is of order m if SIDE = 'L' and of order n\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q' from the Left\n\ * = 'R': apply Q or Q' from the Right\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': apply Q (No transpose)\n\ * = 'C': apply Q' (Conjugate transpose)\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension\n\ * (LDA,M) if SIDE = 'L',\n\ * (LDA,N) if SIDE = 'R'\n\ * The i-th row must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * CGELQF in the first k rows of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,K).\n\ *\n\ * TAU (input) COMPLEX array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by CGELQF.\n\ *\n\ * C (input/output) COMPLEX array, dimension (LDC,N)\n\ * On entry, the m-by-n matrix C.\n\ * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension\n\ * (N) if SIDE = 'L',\n\ * (M) if SIDE = 'R'\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlaebz0000644000175000017500000003003612502223526016453 0ustar uwabamiuwabami--- :name: dlaebz :md5sum: 667b9d1d21f6f805330766d1f74f173b :category: :subroutine :arguments: - ijob: :type: integer :intent: input - nitmax: :type: integer :intent: input - n: :type: integer :intent: input - mmax: :type: integer :intent: input - minp: :type: integer :intent: input - nbmin: :type: integer :intent: input - abstol: :type: doublereal :intent: input - reltol: :type: doublereal :intent: input - pivmin: :type: doublereal :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublereal :intent: input :dims: - n - e2: :type: doublereal :intent: input :dims: - n - nval: :type: integer :intent: input/output :dims: - "(ijob==1||ijob==2) ? 0 : ijob==3 ? minp : 0" - ab: :type: doublereal :intent: input/output :dims: - mmax - "2" - c: :type: doublereal :intent: input/output :dims: - "ijob==1 ? 0 : (ijob==2||ijob==3) ? mmax : 0" - mout: :type: integer :intent: output - nab: :type: integer :intent: input/output :dims: - mmax - "2" - work: :type: doublereal :intent: workspace :dims: - mmax - iwork: :type: integer :intent: workspace :dims: - mmax - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL, RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT, NAB, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAEBZ contains the iteration loops which compute and use the\n\ * function N(w), which is the count of eigenvalues of a symmetric\n\ * tridiagonal matrix T less than or equal to its argument w. It\n\ * performs a choice of two types of loops:\n\ *\n\ * IJOB=1, followed by\n\ * IJOB=2: It takes as input a list of intervals and returns a list of\n\ * sufficiently small intervals whose union contains the same\n\ * eigenvalues as the union of the original intervals.\n\ * The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP.\n\ * The output interval (AB(j,1),AB(j,2)] will contain\n\ * eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT.\n\ *\n\ * IJOB=3: It performs a binary search in each input interval\n\ * (AB(j,1),AB(j,2)] for a point w(j) such that\n\ * N(w(j))=NVAL(j), and uses C(j) as the starting point of\n\ * the search. If such a w(j) is found, then on output\n\ * AB(j,1)=AB(j,2)=w. If no such w(j) is found, then on output\n\ * (AB(j,1),AB(j,2)] will be a small interval containing the\n\ * point where N(w) jumps through NVAL(j), unless that point\n\ * lies outside the initial interval.\n\ *\n\ * Note that the intervals are in all cases half-open intervals,\n\ * i.e., of the form (a,b] , which includes b but not a .\n\ *\n\ * To avoid underflow, the matrix should be scaled so that its largest\n\ * element is no greater than overflow**(1/2) * underflow**(1/4)\n\ * in absolute value. To assure the most accurate computation\n\ * of small eigenvalues, the matrix should be scaled to be\n\ * not much smaller than that, either.\n\ *\n\ * See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n\ * Matrix\", Report CS41, Computer Science Dept., Stanford\n\ * University, July 21, 1966\n\ *\n\ * Note: the arguments are, in general, *not* checked for unreasonable\n\ * values.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * IJOB (input) INTEGER\n\ * Specifies what is to be done:\n\ * = 1: Compute NAB for the initial intervals.\n\ * = 2: Perform bisection iteration to find eigenvalues of T.\n\ * = 3: Perform bisection iteration to invert N(w), i.e.,\n\ * to find a point which has a specified number of\n\ * eigenvalues of T to its left.\n\ * Other values will cause DLAEBZ to return with INFO=-1.\n\ *\n\ * NITMAX (input) INTEGER\n\ * The maximum number of \"levels\" of bisection to be\n\ * performed, i.e., an interval of width W will not be made\n\ * smaller than 2^(-NITMAX) * W. If not all intervals\n\ * have converged after NITMAX iterations, then INFO is set\n\ * to the number of non-converged intervals.\n\ *\n\ * N (input) INTEGER\n\ * The dimension n of the tridiagonal matrix T. It must be at\n\ * least 1.\n\ *\n\ * MMAX (input) INTEGER\n\ * The maximum number of intervals. If more than MMAX intervals\n\ * are generated, then DLAEBZ will quit with INFO=MMAX+1.\n\ *\n\ * MINP (input) INTEGER\n\ * The initial number of intervals. It may not be greater than\n\ * MMAX.\n\ *\n\ * NBMIN (input) INTEGER\n\ * The smallest number of intervals that should be processed\n\ * using a vector loop. If zero, then only the scalar loop\n\ * will be used.\n\ *\n\ * ABSTOL (input) DOUBLE PRECISION\n\ * The minimum (absolute) width of an interval. When an\n\ * interval is narrower than ABSTOL, or than RELTOL times the\n\ * larger (in magnitude) endpoint, then it is considered to be\n\ * sufficiently small, i.e., converged. This must be at least\n\ * zero.\n\ *\n\ * RELTOL (input) DOUBLE PRECISION\n\ * The minimum relative width of an interval. When an interval\n\ * is narrower than ABSTOL, or than RELTOL times the larger (in\n\ * magnitude) endpoint, then it is considered to be\n\ * sufficiently small, i.e., converged. Note: this should\n\ * always be at least radix*machine epsilon.\n\ *\n\ * PIVMIN (input) DOUBLE PRECISION\n\ * The minimum absolute value of a \"pivot\" in the Sturm\n\ * sequence loop. This *must* be at least max |e(j)**2| *\n\ * safe_min and at least safe_min, where safe_min is at least\n\ * the smallest number that can divide one without overflow.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The diagonal elements of the tridiagonal matrix T.\n\ *\n\ * E (input) DOUBLE PRECISION array, dimension (N)\n\ * The offdiagonal elements of the tridiagonal matrix T in\n\ * positions 1 through N-1. E(N) is arbitrary.\n\ *\n\ * E2 (input) DOUBLE PRECISION array, dimension (N)\n\ * The squares of the offdiagonal elements of the tridiagonal\n\ * matrix T. E2(N) is ignored.\n\ *\n\ * NVAL (input/output) INTEGER array, dimension (MINP)\n\ * If IJOB=1 or 2, not referenced.\n\ * If IJOB=3, the desired values of N(w). The elements of NVAL\n\ * will be reordered to correspond with the intervals in AB.\n\ * Thus, NVAL(j) on output will not, in general be the same as\n\ * NVAL(j) on input, but it will correspond with the interval\n\ * (AB(j,1),AB(j,2)] on output.\n\ *\n\ * AB (input/output) DOUBLE PRECISION array, dimension (MMAX,2)\n\ * The endpoints of the intervals. AB(j,1) is a(j), the left\n\ * endpoint of the j-th interval, and AB(j,2) is b(j), the\n\ * right endpoint of the j-th interval. The input intervals\n\ * will, in general, be modified, split, and reordered by the\n\ * calculation.\n\ *\n\ * C (input/output) DOUBLE PRECISION array, dimension (MMAX)\n\ * If IJOB=1, ignored.\n\ * If IJOB=2, workspace.\n\ * If IJOB=3, then on input C(j) should be initialized to the\n\ * first search point in the binary search.\n\ *\n\ * MOUT (output) INTEGER\n\ * If IJOB=1, the number of eigenvalues in the intervals.\n\ * If IJOB=2 or 3, the number of intervals output.\n\ * If IJOB=3, MOUT will equal MINP.\n\ *\n\ * NAB (input/output) INTEGER array, dimension (MMAX,2)\n\ * If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)).\n\ * If IJOB=2, then on input, NAB(i,j) should be set. It must\n\ * satisfy the condition:\n\ * N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)),\n\ * which means that in interval i only eigenvalues\n\ * NAB(i,1)+1,...,NAB(i,2) will be considered. Usually,\n\ * NAB(i,j)=N(AB(i,j)), from a previous call to DLAEBZ with\n\ * IJOB=1.\n\ * On output, NAB(i,j) will contain\n\ * max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of\n\ * the input interval that the output interval\n\ * (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the\n\ * the input values of NAB(k,1) and NAB(k,2).\n\ * If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)),\n\ * unless N(w) > NVAL(i) for all search points w , in which\n\ * case NAB(i,1) will not be modified, i.e., the output\n\ * value will be the same as the input value (modulo\n\ * reorderings -- see NVAL and AB), or unless N(w) < NVAL(i)\n\ * for all search points w , in which case NAB(i,2) will\n\ * not be modified. Normally, NAB should be set to some\n\ * distinctive value(s) before DLAEBZ is called.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (MMAX)\n\ * Workspace.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (MMAX)\n\ * Workspace.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: All intervals converged.\n\ * = 1--MMAX: The last INFO intervals did not converge.\n\ * = MMAX+1: More than MMAX intervals were generated.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * This routine is intended to be called only by other LAPACK\n\ * routines, thus the interface is less user-friendly. It is intended\n\ * for two purposes:\n\ *\n\ * (a) finding eigenvalues. In this case, DLAEBZ should have one or\n\ * more initial intervals set up in AB, and DLAEBZ should be called\n\ * with IJOB=1. This sets up NAB, and also counts the eigenvalues.\n\ * Intervals with no eigenvalues would usually be thrown out at\n\ * this point. Also, if not all the eigenvalues in an interval i\n\ * are desired, NAB(i,1) can be increased or NAB(i,2) decreased.\n\ * For example, set NAB(i,1)=NAB(i,2)-1 to get the largest\n\ * eigenvalue. DLAEBZ is then called with IJOB=2 and MMAX\n\ * no smaller than the value of MOUT returned by the call with\n\ * IJOB=1. After this (IJOB=2) call, eigenvalues NAB(i,1)+1\n\ * through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the\n\ * tolerance specified by ABSTOL and RELTOL.\n\ *\n\ * (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l).\n\ * In this case, start with a Gershgorin interval (a,b). Set up\n\ * AB to contain 2 search intervals, both initially (a,b). One\n\ * NVAL element should contain f-1 and the other should contain l\n\ * , while C should contain a and b, resp. NAB(i,1) should be -1\n\ * and NAB(i,2) should be N+1, to flag an error if the desired\n\ * interval does not lie in (a,b). DLAEBZ is then called with\n\ * IJOB=3. On exit, if w(f-1) < w(f), then one of the intervals --\n\ * j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while\n\ * if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r\n\ * >= 0, then the interval will have N(AB(j,1))=NAB(j,1)=f-k and\n\ * N(AB(j,2))=NAB(j,2)=f+r. The cases w(l) < w(l+1) and\n\ * w(l-r)=...=w(l+k) are handled similarly.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chpev0000644000175000017500000000675212502223525016326 0ustar uwabamiuwabami--- :name: chpev :md5sum: 526bd4ade00201871894a1f1c53fa307 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - ldap - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - MAX(1, 2*n-1) - rwork: :type: real :intent: workspace :dims: - MAX(1, 3*n-2) - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE CHPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHPEV computes all the eigenvalues and, optionally, eigenvectors of a\n\ * complex Hermitian matrix in packed storage.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, AP is overwritten by values generated during the\n\ * reduction to tridiagonal form. If UPLO = 'U', the diagonal\n\ * and first superdiagonal of the tridiagonal matrix T overwrite\n\ * the corresponding elements of A, and if UPLO = 'L', the\n\ * diagonal and first subdiagonal of T overwrite the\n\ * corresponding elements of A.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) COMPLEX array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n\ * eigenvectors of the matrix A, with the i-th column of Z\n\ * holding the eigenvector associated with W(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (max(1, 2*N-1))\n\ *\n\ * RWORK (workspace) REAL array, dimension (max(1, 3*N-2))\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 algorithm failed to converge; i\n\ * off-diagonal elements of an intermediate tridiagonal\n\ * form did not converge to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsygs20000644000175000017500000000576712502223526016442 0ustar uwabamiuwabami--- :name: dsygs2 :md5sum: 756f9e1ce51d4b84e9ec4983cfd676a3 :category: :subroutine :arguments: - itype: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSYGS2 reduces a real symmetric-definite generalized eigenproblem\n\ * to standard form.\n\ *\n\ * If ITYPE = 1, the problem is A*x = lambda*B*x,\n\ * and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')\n\ *\n\ * If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n\ * B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.\n\ *\n\ * B must have been previously factorized as U'*U or L*L' by DPOTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');\n\ * = 2 or 3: compute U*A*U' or L'*A*L.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored, and how B has been factorized.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * n by n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n by n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the transformed matrix, stored in the\n\ * same format as A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,N)\n\ * The triangular factor from the Cholesky factorization of B,\n\ * as returned by DPOTRF.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slaqr20000644000175000017500000002044112502223526016415 0ustar uwabamiuwabami--- :name: slaqr2 :md5sum: 541e85f74014b7b55bb36811cffb45db :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ktop: :type: integer :intent: input - kbot: :type: integer :intent: input - nw: :type: integer :intent: input - h: :type: real :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: real :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - ns: :type: integer :intent: output - nd: :type: integer :intent: output - sr: :type: real :intent: output :dims: - MAX(1,kbot) - si: :type: real :intent: output :dims: - MAX(1,kbot) - v: :type: real :intent: workspace :dims: - ldv - MAX(1,nw) - ldv: :type: integer :intent: input - nh: :type: integer :intent: input - t: :type: real :intent: workspace :dims: - ldt - MAX(1,nw) - ldt: :type: integer :intent: input - nv: :type: integer :intent: input - wv: :type: real :intent: workspace :dims: - ldwv - MAX(1,nw) - ldwv: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*nw :substitutions: ldwv: nw ldt: nw ldv: nw :fortran_help: " SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n\ * This subroutine is identical to SLAQR3 except that it avoids\n\ * recursion by calling SLAHQR instead of SLAQR4.\n\ *\n\ *\n\ * ******************************************************************\n\ * Aggressive early deflation:\n\ *\n\ * This subroutine accepts as input an upper Hessenberg matrix\n\ * H and performs an orthogonal similarity transformation\n\ * designed to detect and deflate fully converged eigenvalues from\n\ * a trailing principal submatrix. On output H has been over-\n\ * written by a new Hessenberg matrix that is a perturbation of\n\ * an orthogonal similarity transformation of H. It is to be\n\ * hoped that the final version of H has many zero subdiagonal\n\ * entries.\n\ *\n\ * ******************************************************************\n\n\ * WANTT (input) LOGICAL\n\ * If .TRUE., then the Hessenberg matrix H is fully updated\n\ * so that the quasi-triangular Schur factor may be\n\ * computed (in cooperation with the calling subroutine).\n\ * If .FALSE., then only enough of H is updated to preserve\n\ * the eigenvalues.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * If .TRUE., then the orthogonal matrix Z is updated so\n\ * so that the orthogonal Schur factor may be computed\n\ * (in cooperation with the calling subroutine).\n\ * If .FALSE., then Z is not referenced.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H and (if WANTZ is .TRUE.) the\n\ * order of the orthogonal matrix Z.\n\ *\n\ * KTOP (input) INTEGER\n\ * It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n\ * KBOT and KTOP together determine an isolated block\n\ * along the diagonal of the Hessenberg matrix.\n\ *\n\ * KBOT (input) INTEGER\n\ * It is assumed without a check that either\n\ * KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together\n\ * determine an isolated block along the diagonal of the\n\ * Hessenberg matrix.\n\ *\n\ * NW (input) INTEGER\n\ * Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).\n\ *\n\ * H (input/output) REAL array, dimension (LDH,N)\n\ * On input the initial N-by-N section of H stores the\n\ * Hessenberg matrix undergoing aggressive early deflation.\n\ * On output H has been transformed by an orthogonal\n\ * similarity transformation, perturbed, and the returned\n\ * to Hessenberg form that (it is to be hoped) has some\n\ * zero subdiagonal entries.\n\ *\n\ * LDH (input) integer\n\ * Leading dimension of H just as declared in the calling\n\ * subroutine. N .LE. LDH\n\ *\n\ * ILOZ (input) INTEGER\n\ * IHIZ (input) INTEGER\n\ * Specify the rows of Z to which transformations must be\n\ * applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n\ *\n\ * Z (input/output) REAL array, dimension (LDZ,N)\n\ * IF WANTZ is .TRUE., then on output, the orthogonal\n\ * similarity transformation mentioned above has been\n\ * accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n\ * If WANTZ is .FALSE., then Z is unreferenced.\n\ *\n\ * LDZ (input) integer\n\ * The leading dimension of Z just as declared in the\n\ * calling subroutine. 1 .LE. LDZ.\n\ *\n\ * NS (output) integer\n\ * The number of unconverged (ie approximate) eigenvalues\n\ * returned in SR and SI that may be used as shifts by the\n\ * calling subroutine.\n\ *\n\ * ND (output) integer\n\ * The number of converged eigenvalues uncovered by this\n\ * subroutine.\n\ *\n\ * SR (output) REAL array, dimension KBOT\n\ * SI (output) REAL array, dimension KBOT\n\ * On output, the real and imaginary parts of approximate\n\ * eigenvalues that may be used for shifts are stored in\n\ * SR(KBOT-ND-NS+1) through SR(KBOT-ND) and\n\ * SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.\n\ * The real and imaginary parts of converged eigenvalues\n\ * are stored in SR(KBOT-ND+1) through SR(KBOT) and\n\ * SI(KBOT-ND+1) through SI(KBOT), respectively.\n\ *\n\ * V (workspace) REAL array, dimension (LDV,NW)\n\ * An NW-by-NW work array.\n\ *\n\ * LDV (input) integer scalar\n\ * The leading dimension of V just as declared in the\n\ * calling subroutine. NW .LE. LDV\n\ *\n\ * NH (input) integer scalar\n\ * The number of columns of T. NH.GE.NW.\n\ *\n\ * T (workspace) REAL array, dimension (LDT,NW)\n\ *\n\ * LDT (input) integer\n\ * The leading dimension of T just as declared in the\n\ * calling subroutine. NW .LE. LDT\n\ *\n\ * NV (input) integer\n\ * The number of rows of work array WV available for\n\ * workspace. NV.GE.NW.\n\ *\n\ * WV (workspace) REAL array, dimension (LDWV,NW)\n\ *\n\ * LDWV (input) integer\n\ * The leading dimension of W just as declared in the\n\ * calling subroutine. NW .LE. LDV\n\ *\n\ * WORK (workspace) REAL array, dimension LWORK.\n\ * On exit, WORK(1) is set to an estimate of the optimal value\n\ * of LWORK for the given values of N, NW, KTOP and KBOT.\n\ *\n\ * LWORK (input) integer\n\ * The dimension of the work array WORK. LWORK = 2*NW\n\ * suffices, but greater efficiency may result from larger\n\ * values of LWORK.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; SLAQR2\n\ * only estimates the optimal workspace size for the given\n\ * values of N, NW, KTOP and KBOT. The estimate is returned\n\ * in WORK(1). No error message related to LWORK is issued\n\ * by XERBLA. Neither H nor Z are accessed.\n\ *\n\n\ * ================================================================\n\ * Based on contributions by\n\ * Karen Braman and Ralph Byers, Department of Mathematics,\n\ * University of Kansas, USA\n\ *\n\ * ================================================================\n" ruby-lapack-1.7.2/dev/defs/cungqr0000644000175000017500000000573012502223526016514 0ustar uwabamiuwabami--- :name: cungqr :md5sum: 2b4cd874b9af0ac7808c9a204c885182 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CUNGQR generates an M-by-N complex matrix Q with orthonormal columns,\n\ * which is defined as the first N columns of a product of K elementary\n\ * reflectors of order M\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by CGEQRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. M >= N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. N >= K >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the i-th column must contain the vector which\n\ * defines the elementary reflector H(i), for i = 1,2,...,k, as\n\ * returned by CGEQRF in the first k columns of its array\n\ * argument A.\n\ * On exit, the M-by-N matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) COMPLEX array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by CGEQRF.\n\ *\n\ * WORK (workspace/output) COMPLEX 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,N).\n\ * For optimum performance LWORK >= N*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 has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlargv0000644000175000017500000000505412502223526016521 0ustar uwabamiuwabami--- :name: zlargv :md5sum: bc7733bbe1d5c4b2c02183f807aadd34 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - y: :type: doublecomplex :intent: input/output :dims: - 1+(n-1)*incy - incy: :type: integer :intent: input - c: :type: doublereal :intent: output :dims: - 1+(n-1)*incc - incc: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE ZLARGV( N, X, INCX, Y, INCY, C, INCC )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLARGV generates a vector of complex plane rotations with real\n\ * cosines, determined by elements of the complex vectors x and y.\n\ * For i = 1,2,...,n\n\ *\n\ * ( c(i) s(i) ) ( x(i) ) = ( r(i) )\n\ * ( -conjg(s(i)) c(i) ) ( y(i) ) = ( 0 )\n\ *\n\ * where c(i)**2 + ABS(s(i))**2 = 1\n\ *\n\ * The following conventions are used (these are the same as in ZLARTG,\n\ * but differ from the BLAS1 routine ZROTG):\n\ * If y(i)=0, then c(i)=1 and s(i)=0.\n\ * If x(i)=0, then c(i)=0 and s(i) is chosen so that r(i) is real.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of plane rotations to be generated.\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX)\n\ * On entry, the vector x.\n\ * On exit, x(i) is overwritten by r(i), for i = 1,...,n.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between elements of X. INCX > 0.\n\ *\n\ * Y (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCY)\n\ * On entry, the vector y.\n\ * On exit, the sines of the plane rotations.\n\ *\n\ * INCY (input) INTEGER\n\ * The increment between elements of Y. INCY > 0.\n\ *\n\ * C (output) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)\n\ * The cosines of the plane rotations.\n\ *\n\ * INCC (input) INTEGER\n\ * The increment between elements of C. INCC > 0.\n\ *\n\n\ * Further Details\n\ * ======= =======\n\ *\n\ * 6-6-96 - Modified with a new algorithm by W. Kahan and J. Demmel\n\ *\n\ * This version has a few statements commented out for thread safety\n\ * (machine parameters are computed on each entry). 10 feb 03, SJH.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cunmqr0000644000175000017500000001047612502223526016525 0ustar uwabamiuwabami--- :name: cunmqr :md5sum: 5596f3f65a6800dec1c8bfdab7678536 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CUNMQR overwrites the general complex M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'C': Q**H * C C * Q**H\n\ *\n\ * where Q is a complex unitary matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by CGEQRF. Q is of order M if SIDE = 'L' and of order N\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**H from the Left;\n\ * = 'R': apply Q or Q**H from the Right.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q;\n\ * = 'C': Conjugate transpose, apply Q**H.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,K)\n\ * The i-th column must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * CGEQRF in the first k columns of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ * If SIDE = 'L', LDA >= max(1,M);\n\ * if SIDE = 'R', LDA >= max(1,N).\n\ *\n\ * TAU (input) COMPLEX array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by CGEQRF.\n\ *\n\ * C (input/output) COMPLEX array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace/output) COMPLEX 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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M).\n\ * For optimum performance LWORK >= N*NB if SIDE = 'L', and\n\ * LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n\ * 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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sposv0000644000175000017500000000703012502223526016362 0ustar uwabamiuwabami--- :name: sposv :md5sum: 68e02f39eeec630778ac5a25a9500f3c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPOSV computes the solution to a real system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N symmetric positive definite matrix and X and B\n\ * are N-by-NRHS matrices.\n\ *\n\ * The Cholesky decomposition is used to factor A as\n\ * A = U**T* U, if UPLO = 'U', or\n\ * A = L * L**T, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is a lower triangular\n\ * matrix. The factored form of A is then used to solve the system of\n\ * equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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 leading minor of order i of A is not\n\ * positive definite, so the factorization could not be\n\ * completed, and the solution has not been computed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SPOTRF, SPOTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slacpy0000644000175000017500000000421612502223526016506 0ustar uwabamiuwabami--- :name: slacpy :md5sum: fb3c0582ff1682fc252e5d6ad1a2f089 :category: :subroutine :arguments: - uplo: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: output :dims: - ldb - n - ldb: :type: integer :intent: input :substitutions: ldb: MAX(1,m) :fortran_help: " SUBROUTINE SLACPY( UPLO, M, N, A, LDA, B, LDB )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLACPY copies all or part of a two-dimensional matrix A to another\n\ * matrix B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies the part of the matrix A to be copied to B.\n\ * = 'U': Upper triangular part\n\ * = 'L': Lower triangular part\n\ * Otherwise: All of the matrix A\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) REAL array, dimension (LDA,N)\n\ * The m by n matrix A. If UPLO = 'U', only the upper triangle\n\ * or trapezoid is accessed; if UPLO = 'L', only the lower\n\ * triangle or trapezoid is accessed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (output) REAL array, dimension (LDB,N)\n\ * On exit, B = A in the locations specified by UPLO.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,M).\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sgsvj10000644000175000017500000002067712502223526016441 0ustar uwabamiuwabami--- :name: sgsvj1 :md5sum: cbe49ab014331204cca976ff4c40a398 :category: :subroutine :arguments: - jobv: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - n1: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - sva: :type: real :intent: input/output :dims: - n - mv: :type: integer :intent: input - v: :type: real :intent: input/output :dims: - ldv - n - ldv: :type: integer :intent: input - eps: :type: integer :intent: input - sfmin: :type: integer :intent: input - tol: :type: real :intent: input - nsweep: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - lwork - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: lwork: m :fortran_help: " SUBROUTINE SGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGSVJ1 is called from SGESVJ as a pre-processor and that is its main\n\ * purpose. It applies Jacobi rotations in the same way as SGESVJ does, but\n\ * it targets only particular pivots and it does not check convergence\n\ * (stopping criterion). Few tunning parameters (marked by [TP]) are\n\ * available for the implementer.\n\ *\n\ * Further Details\n\ * ~~~~~~~~~~~~~~~\n\ * SGSVJ1 applies few sweeps of Jacobi rotations in the column space of\n\ * the input M-by-N matrix A. The pivot pairs are taken from the (1,2)\n\ * off-diagonal block in the corresponding N-by-N Gram matrix A^T * A. The\n\ * block-entries (tiles) of the (1,2) off-diagonal block are marked by the\n\ * [x]'s in the following scheme:\n\ *\n\ * | * * * [x] [x] [x]|\n\ * | * * * [x] [x] [x]| Row-cycling in the nblr-by-nblc [x] blocks.\n\ * | * * * [x] [x] [x]| Row-cyclic pivoting inside each [x] block.\n\ * |[x] [x] [x] * * * |\n\ * |[x] [x] [x] * * * |\n\ * |[x] [x] [x] * * * |\n\ *\n\ * In terms of the columns of A, the first N1 columns are rotated 'against'\n\ * the remaining N-N1 columns, trying to increase the angle between the\n\ * corresponding subspaces. The off-diagonal block is N1-by(N-N1) and it is\n\ * tiled using quadratic tiles of side KBL. Here, KBL is a tunning parmeter.\n\ * The number of sweeps is given in NSWEEP and the orthogonality threshold\n\ * is given in TOL.\n\ *\n\ * Contributors\n\ * ~~~~~~~~~~~~\n\ * Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBV (input) CHARACTER*1\n\ * Specifies whether the output from this procedure is used\n\ * to compute the matrix V:\n\ * = 'V': the product of the Jacobi rotations is accumulated\n\ * by postmulyiplying the N-by-N array V.\n\ * (See the description of V.)\n\ * = 'A': the product of the Jacobi rotations is accumulated\n\ * by postmulyiplying the MV-by-N array V.\n\ * (See the descriptions of MV and V.)\n\ * = 'N': the Jacobi rotations are not accumulated.\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.\n\ * M >= N >= 0.\n\ *\n\ * N1 (input) INTEGER\n\ * N1 specifies the 2 x 2 block partition, the first N1 columns are\n\ * rotated 'against' the remaining N-N1 columns of A.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, M-by-N matrix A, such that A*diag(D) represents\n\ * the input matrix.\n\ * On exit,\n\ * A_onexit * D_onexit represents the input matrix A*diag(D)\n\ * post-multiplied by a sequence of Jacobi rotations, where the\n\ * rotation threshold and the total number of sweeps are given in\n\ * TOL and NSWEEP, respectively.\n\ * (See the descriptions of N1, D, TOL and NSWEEP.)\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * D (input/workspace/output) REAL array, dimension (N)\n\ * The array D accumulates the scaling factors from the fast scaled\n\ * Jacobi rotations.\n\ * On entry, A*diag(D) represents the input matrix.\n\ * On exit, A_onexit*diag(D_onexit) represents the input matrix\n\ * post-multiplied by a sequence of Jacobi rotations, where the\n\ * rotation threshold and the total number of sweeps are given in\n\ * TOL and NSWEEP, respectively.\n\ * (See the descriptions of N1, A, TOL and NSWEEP.)\n\ *\n\ * SVA (input/workspace/output) REAL array, dimension (N)\n\ * On entry, SVA contains the Euclidean norms of the columns of\n\ * the matrix A*diag(D).\n\ * On exit, SVA contains the Euclidean norms of the columns of\n\ * the matrix onexit*diag(D_onexit).\n\ *\n\ * MV (input) INTEGER\n\ * If JOBV .EQ. 'A', then MV rows of V are post-multipled by a\n\ * sequence of Jacobi rotations.\n\ * If JOBV = 'N', then MV is not referenced.\n\ *\n\ * V (input/output) REAL array, dimension (LDV,N)\n\ * If JOBV .EQ. 'V' then N rows of V are post-multipled by a\n\ * sequence of Jacobi rotations.\n\ * If JOBV .EQ. 'A' then MV rows of V are post-multipled by a\n\ * sequence of Jacobi rotations.\n\ * If JOBV = 'N', then V is not referenced.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V, LDV >= 1.\n\ * If JOBV = 'V', LDV .GE. N.\n\ * If JOBV = 'A', LDV .GE. MV.\n\ *\n\ * EPS (input) INTEGER\n\ * EPS = SLAMCH('Epsilon')\n\ *\n\ * SFMIN (input) INTEGER\n\ * SFMIN = SLAMCH('Safe Minimum')\n\ *\n\ * TOL (input) REAL\n\ * TOL is the threshold for Jacobi rotations. For a pair\n\ * A(:,p), A(:,q) of pivot columns, the Jacobi rotation is\n\ * applied only if ABS(COS(angle(A(:,p),A(:,q)))) .GT. TOL.\n\ *\n\ * NSWEEP (input) INTEGER\n\ * NSWEEP is the number of sweeps of Jacobi rotations to be\n\ * performed.\n\ *\n\ * WORK (workspace) REAL array, dimension LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * LWORK is the dimension of WORK. LWORK .GE. M.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0 : successful exit.\n\ * < 0 : if INFO = -i, then the i-th argument had an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Parameters ..\n REAL ZERO, HALF, ONE, TWO\n PARAMETER ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0,\n + TWO = 2.0E0 )\n\ * ..\n\ * .. Local Scalars ..\n REAL AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,\n + BIGTHETA, CS, LARGE, MXAAPQ, MXSINJ, ROOTBIG,\n + ROOTEPS, ROOTSFMIN, ROOTTOL, SMALL, SN, T,\n + TEMP1, THETA, THSIGN\n INTEGER BLSKIP, EMPTSW, i, ibr, igl, IERR, IJBLSK,\n + ISWROT, jbc, jgl, KBL, MVL, NOTROT, nblc, nblr,\n + p, PSKIPPED, q, ROWSKIP, SWBAND\n LOGICAL APPLV, ROTOK, RSVEC\n\ * ..\n\ * .. Local Arrays ..\n REAL FASTR( 5 )\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, AMAX1, FLOAT, MIN0, SIGN, SQRT\n\ * ..\n\ * .. External Functions ..\n REAL SDOT, SNRM2\n INTEGER ISAMAX\n LOGICAL LSAME\n EXTERNAL ISAMAX, LSAME, SDOT, SNRM2\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SAXPY, SCOPY, SLASCL, SLASSQ, SROTM, SSWAP\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sgeqrfp0000644000175000017500000000722212502223526016662 0ustar uwabamiuwabami--- :name: sgeqrfp :md5sum: cca781b3e9a0170ae3da210612086ca7 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - MIN(m,n) - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGEQRFP computes a QR factorization of a real M-by-N matrix A:\n\ * A = Q * R.\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) REAL array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, the elements on and above the diagonal of the array\n\ * contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n\ * upper triangular if m >= n); the elements below the diagonal,\n\ * with the array TAU, represent the orthogonal matrix Q as a\n\ * product of min(m,n) elementary reflectors (see Further\n\ * Details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (output) REAL array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace/output) REAL 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,N).\n\ * For optimum performance LWORK >= N*NB, where NB is \n\ * the 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(1) H(2) . . . H(k), 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:m) is stored on exit in A(i+1:m,i),\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 SGEQR2P, SLARFB, SLARFT, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dorgtr0000644000175000017500000000554612502223526016523 0ustar uwabamiuwabami--- :name: dorgtr :md5sum: fcaca39eb500671fa5d4d41d70cf3fb2 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - n-1 - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DORGTR generates a real orthogonal matrix Q which is defined as the\n\ * product of n-1 elementary reflectors of order N, as returned by\n\ * DSYTRD:\n\ *\n\ * if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),\n\ *\n\ * if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A contains elementary reflectors\n\ * from DSYTRD;\n\ * = 'L': Lower triangle of A contains elementary reflectors\n\ * from DSYTRD.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix Q. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the vectors which define the elementary reflectors,\n\ * as returned by DSYTRD.\n\ * On exit, the N-by-N orthogonal matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * TAU (input) DOUBLE PRECISION array, dimension (N-1)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by DSYTRD.\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,N-1).\n\ * For optimum performance LWORK >= (N-1)*NB, where NB is\n\ * the 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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sggglm0000644000175000017500000001221212502223526016466 0ustar uwabamiuwabami--- :name: sggglm :md5sum: aba2d257bbf8b9411b9165fa82316214 :category: :subroutine :arguments: - n: :type: integer :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - m - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - p - ldb: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - x: :type: real :intent: output :dims: - m - y: :type: real :intent: output :dims: - p - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m+n+p - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGGGLM solves a general Gauss-Markov linear model (GLM) problem:\n\ *\n\ * minimize || y ||_2 subject to d = A*x + B*y\n\ * x\n\ *\n\ * where A is an N-by-M matrix, B is an N-by-P matrix, and d is a\n\ * given N-vector. It is assumed that M <= N <= M+P, and\n\ *\n\ * rank(A) = M and rank( A B ) = N.\n\ *\n\ * Under these assumptions, the constrained equation is always\n\ * consistent, and there is a unique solution x and a minimal 2-norm\n\ * solution y, which is obtained using a generalized QR factorization\n\ * of the matrices (A, B) given by\n\ *\n\ * A = Q*(R), B = Q*T*Z.\n\ * (0)\n\ *\n\ * In particular, if matrix B is square nonsingular, then the problem\n\ * GLM is equivalent to the following weighted linear least squares\n\ * problem\n\ *\n\ * minimize || inv(B)*(d-A*x) ||_2\n\ * x\n\ *\n\ * where inv(B) denotes the inverse of B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of rows of the matrices A and B. N >= 0.\n\ *\n\ * M (input) INTEGER\n\ * The number of columns of the matrix A. 0 <= M <= N.\n\ *\n\ * P (input) INTEGER\n\ * The number of columns of the matrix B. P >= N-M.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,M)\n\ * On entry, the N-by-M matrix A.\n\ * On exit, the upper triangular part of the array A contains\n\ * the M-by-M upper triangular matrix R.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) REAL array, dimension (LDB,P)\n\ * On entry, the N-by-P matrix B.\n\ * On exit, if N <= P, the upper triangle of the subarray\n\ * B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n\ * if N > P, the elements on and above the (N-P)th subdiagonal\n\ * contain the N-by-P upper trapezoidal matrix T.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, D is the left hand side of the GLM equation.\n\ * On exit, D is destroyed.\n\ *\n\ * X (output) REAL array, dimension (M)\n\ * Y (output) REAL array, dimension (P)\n\ * On exit, X and Y are the solutions of the GLM problem.\n\ *\n\ * WORK (workspace/output) REAL 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,N+M+P).\n\ * For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,\n\ * where NB is an upper bound for the optimal blocksizes for\n\ * SGEQRF, SGERQF, SORMQR and SORMRQ.\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\ * = 1: the upper triangular factor R associated with A in the\n\ * generalized QR factorization of the pair (A, B) is\n\ * singular, so that rank(A) < M; the least squares\n\ * solution could not be computed.\n\ * = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal\n\ * factor T associated with B in the generalized QR\n\ * factorization of the pair (A, B) is singular, so that\n\ * rank( A B ) < N; the least squares solution could not\n\ * be computed.\n\ *\n\n\ * ===================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slahrd0000644000175000017500000001050412502223526016465 0ustar uwabamiuwabami--- :name: slahrd :md5sum: 310f3d05f9a370f74c5c3899e0327653 :category: :subroutine :arguments: - n: :type: integer :intent: input - k: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n-k+1 - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - MAX(1,nb) - t: :type: real :intent: output :dims: - ldt - MAX(1,nb) - ldt: :type: integer :intent: input - y: :type: real :intent: output :dims: - ldy - MAX(1,nb) - ldy: :type: integer :intent: input :substitutions: lda: n ldy: n ldt: nb :fortran_help: " SUBROUTINE SLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAHRD reduces the first NB columns of a real general n-by-(n-k+1)\n\ * matrix A so that elements below the k-th subdiagonal are zero. The\n\ * reduction is performed by an orthogonal similarity transformation\n\ * Q' * A * Q. The routine returns the matrices V and T which determine\n\ * Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n\ *\n\ * This is an OBSOLETE auxiliary routine. \n\ * This routine will be 'deprecated' in a future release.\n\ * Please use the new routine SLAHR2 instead.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A.\n\ *\n\ * K (input) INTEGER\n\ * The offset for the reduction. Elements below the k-th\n\ * subdiagonal in the first NB columns are reduced to zero.\n\ *\n\ * NB (input) INTEGER\n\ * The number of columns to be reduced.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N-K+1)\n\ * On entry, the n-by-(n-k+1) general matrix A.\n\ * On exit, the elements on and above the k-th subdiagonal in\n\ * the first NB columns are overwritten with the corresponding\n\ * elements of the reduced matrix; the elements below the k-th\n\ * subdiagonal, with the array TAU, represent the matrix Q as a\n\ * product of elementary reflectors. The other columns of A are\n\ * unchanged. See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * TAU (output) REAL array, dimension (NB)\n\ * The scalar factors of the elementary reflectors. See Further\n\ * Details.\n\ *\n\ * T (output) REAL array, dimension (LDT,NB)\n\ * The upper triangular matrix T.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= NB.\n\ *\n\ * Y (output) REAL array, dimension (LDY,NB)\n\ * The n-by-nb matrix Y.\n\ *\n\ * LDY (input) INTEGER\n\ * The leading dimension of the array Y. LDY >= N.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The matrix Q is represented as a product of nb elementary reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(nb).\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+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n\ * A(i+k+1:n,i), and tau in TAU(i).\n\ *\n\ * The elements of the vectors v together form the (n-k+1)-by-nb matrix\n\ * V which is needed, with T and Y, to apply the transformation to the\n\ * unreduced part of the matrix, using an update of the form:\n\ * A := (I - V*T*V') * (A - Y*V').\n\ *\n\ * The contents of A on exit are illustrated by the following example\n\ * with n = 7, k = 3 and nb = 2:\n\ *\n\ * ( a h a a a )\n\ * ( a h a a a )\n\ * ( a h a a a )\n\ * ( h h a a a )\n\ * ( v1 h a a a )\n\ * ( v1 v2 a a a )\n\ * ( v1 v2 a a a )\n\ *\n\ * where a denotes an element of the original matrix A, h denotes a\n\ * modified element of the upper Hessenberg matrix H, and vi denotes an\n\ * element of the vector defining H(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/csyconv0000644000175000017500000000510512502223525016674 0ustar uwabamiuwabami--- :name: csyconv :md5sum: e73f59e4a1733ca5d74167eeee971dba :category: :subroutine :arguments: - uplo: :type: char :intent: input - way: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: complex :intent: workspace :dims: - MAX(1,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CSYCONV( UPLO, WAY, N, A, LDA, IPIV, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSYCONV convert A given by TRF into L and D and vice-versa.\n\ * Get Non-diag elements of D (returned in workspace) and \n\ * apply or reverse permutation done in TRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ * \n\ * WAY (input) CHARACTER*1\n\ * = 'C': Convert \n\ * = 'R': Revert\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by CSYTRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by CSYTRF.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (N)\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of WORK. LWORK >=1. \n\ * LWORK = N\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zsptri0000644000175000017500000000473312502223526016552 0ustar uwabamiuwabami--- :name: zsptri :md5sum: 67e0485ac6f1e73b1946a7a103fd21e5 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublecomplex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZSPTRI( UPLO, N, AP, IPIV, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSPTRI computes the inverse of a complex symmetric indefinite matrix\n\ * A in packed storage using the factorization A = U*D*U**T or\n\ * A = L*D*L**T computed by ZSPTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * On entry, the block diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L as computed by ZSPTRF,\n\ * stored as a packed triangular matrix.\n\ *\n\ * On exit, if INFO = 0, the (symmetric) inverse of the original\n\ * matrix, stored as a packed triangular matrix. The j-th column\n\ * of inv(A) is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;\n\ * if UPLO = 'L',\n\ * AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by ZSPTRF.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (N)\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, D(i,i) = 0; the matrix is singular and its\n\ * inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssyrfs0000644000175000017500000001212012502223526016535 0ustar uwabamiuwabami--- :name: ssyrfs :md5sum: 3c7cbc979f08d480fd7cfb5e0839f8ff :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSYRFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is symmetric indefinite, and\n\ * provides error bounds and backward error estimates for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular part\n\ * of the matrix A, and the strictly lower triangular part of A\n\ * is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of A contains the lower triangular part of\n\ * the matrix A, and the strictly upper triangular part of A is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) REAL array, dimension (LDAF,N)\n\ * The factored form of the matrix A. AF contains the block\n\ * diagonal matrix D and the multipliers used to obtain the\n\ * factor U or L from the factorization A = U*D*U**T or\n\ * A = L*D*L**T as computed by SSYTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by SSYTRF.\n\ *\n\ * B (input) REAL array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) REAL array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by SSYTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) REAL array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlaed50000644000175000017500000000410412502223526016345 0ustar uwabamiuwabami--- :name: dlaed5 :md5sum: 97c4dbce5d8f0302e9cdfe76525ae209 :category: :subroutine :arguments: - i: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - "2" - z: :type: doublereal :intent: input :dims: - "2" - delta: :type: doublereal :intent: output :dims: - "2" - rho: :type: doublereal :intent: input - dlam: :type: doublereal :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This subroutine computes the I-th eigenvalue of a symmetric rank-one\n\ * modification of a 2-by-2 diagonal matrix\n\ *\n\ * diag( D ) + RHO * Z * transpose(Z) .\n\ *\n\ * The diagonal elements in the array D are assumed to satisfy\n\ *\n\ * D(i) < D(j) for i < j .\n\ *\n\ * We also assume RHO > 0 and that the Euclidean norm of the vector\n\ * Z is one.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * I (input) INTEGER\n\ * The index of the eigenvalue to be computed. I = 1 or I = 2.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (2)\n\ * The original eigenvalues. We assume D(1) < D(2).\n\ *\n\ * Z (input) DOUBLE PRECISION array, dimension (2)\n\ * The components of the updating vector.\n\ *\n\ * DELTA (output) DOUBLE PRECISION array, dimension (2)\n\ * The vector DELTA contains the information necessary\n\ * to construct the eigenvectors.\n\ *\n\ * RHO (input) DOUBLE PRECISION\n\ * The scalar in the symmetric updating formula.\n\ *\n\ * DLAM (output) DOUBLE PRECISION\n\ * The computed lambda_I, the I-th updated eigenvalue.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ren-Cang Li, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cggsvd0000644000175000017500000002441312502223525016470 0ustar uwabamiuwabami--- :name: cggsvd :md5sum: c979f406eb76f93acff2a1803459b120 :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobv: :type: char :intent: input - jobq: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - p: :type: integer :intent: input - k: :type: integer :intent: output - l: :type: integer :intent: output - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alpha: :type: real :intent: output :dims: - n - beta: :type: real :intent: output :dims: - n - u: :type: complex :intent: output :dims: - ldu - m - ldu: :type: integer :intent: input - v: :type: complex :intent: output :dims: - ldv - p - ldv: :type: integer :intent: input - q: :type: complex :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - MAX(3*n,m - p)+n - rwork: :type: real :intent: workspace :dims: - 2*n - iwork: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: m: lda p: ldb ldq: "lsame_(&jobq,\"Q\") ? MAX(1,n) : 1" ldu: "lsame_(&jobu,\"U\") ? MAX(1,m) : 1" ldv: "lsame_(&jobv,\"V\") ? MAX(1,p) : 1" :fortran_help: " SUBROUTINE CGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, RWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGGSVD computes the generalized singular value decomposition (GSVD)\n\ * of an M-by-N complex matrix A and P-by-N complex matrix B:\n\ *\n\ * U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R )\n\ *\n\ * where U, V and Q are unitary matrices, and Z' means the conjugate\n\ * transpose of Z. Let K+L = the effective numerical rank of the\n\ * matrix (A',B')', then R is a (K+L)-by-(K+L) nonsingular upper\n\ * triangular matrix, D1 and D2 are M-by-(K+L) and P-by-(K+L) \"diagonal\"\n\ * matrices and of the following structures, respectively:\n\ *\n\ * If M-K-L >= 0,\n\ *\n\ * K L\n\ * D1 = K ( I 0 )\n\ * L ( 0 C )\n\ * M-K-L ( 0 0 )\n\ *\n\ * K L\n\ * D2 = L ( 0 S )\n\ * P-L ( 0 0 )\n\ *\n\ * N-K-L K L\n\ * ( 0 R ) = K ( 0 R11 R12 )\n\ * L ( 0 0 R22 )\n\ * where\n\ *\n\ * C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n\ * S = diag( BETA(K+1), ... , BETA(K+L) ),\n\ * C**2 + S**2 = I.\n\ *\n\ * R is stored in A(1:K+L,N-K-L+1:N) on exit.\n\ *\n\ * If M-K-L < 0,\n\ *\n\ * K M-K K+L-M\n\ * D1 = K ( I 0 0 )\n\ * M-K ( 0 C 0 )\n\ *\n\ * K M-K K+L-M\n\ * D2 = M-K ( 0 S 0 )\n\ * K+L-M ( 0 0 I )\n\ * P-L ( 0 0 0 )\n\ *\n\ * N-K-L K M-K K+L-M\n\ * ( 0 R ) = K ( 0 R11 R12 R13 )\n\ * M-K ( 0 0 R22 R23 )\n\ * K+L-M ( 0 0 0 R33 )\n\ *\n\ * where\n\ *\n\ * C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n\ * S = diag( BETA(K+1), ... , BETA(M) ),\n\ * C**2 + S**2 = I.\n\ *\n\ * (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored\n\ * ( 0 R22 R23 )\n\ * in B(M-K+1:L,N+M-K-L+1:N) on exit.\n\ *\n\ * The routine computes C, S, R, and optionally the unitary\n\ * transformation matrices U, V and Q.\n\ *\n\ * In particular, if B is an N-by-N nonsingular matrix, then the GSVD of\n\ * A and B implicitly gives the SVD of A*inv(B):\n\ * A*inv(B) = U*(D1*inv(D2))*V'.\n\ * If ( A',B')' has orthnormal columns, then the GSVD of A and B is also\n\ * equal to the CS decomposition of A and B. Furthermore, the GSVD can\n\ * be used to derive the solution of the eigenvalue problem:\n\ * A'*A x = lambda* B'*B x.\n\ * In some literature, the GSVD of A and B is presented in the form\n\ * U'*A*X = ( 0 D1 ), V'*B*X = ( 0 D2 )\n\ * where U and V are orthogonal and X is nonsingular, and D1 and D2 are\n\ * ``diagonal''. The former GSVD form can be converted to the latter\n\ * form by taking the nonsingular matrix X as\n\ *\n\ * X = Q*( I 0 )\n\ * ( 0 inv(R) )\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBU (input) CHARACTER*1\n\ * = 'U': Unitary matrix U is computed;\n\ * = 'N': U is not computed.\n\ *\n\ * JOBV (input) CHARACTER*1\n\ * = 'V': Unitary matrix V is computed;\n\ * = 'N': V is not computed.\n\ *\n\ * JOBQ (input) CHARACTER*1\n\ * = 'Q': Unitary matrix Q is computed;\n\ * = 'N': Q is not computed.\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 matrices A and B. N >= 0.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows of the matrix B. P >= 0.\n\ *\n\ * K (output) INTEGER\n\ * L (output) INTEGER\n\ * On exit, K and L specify the dimension of the subblocks\n\ * described in Purpose.\n\ * K + L = effective numerical rank of (A',B')'.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, A contains the triangular matrix R, or part of R.\n\ * See Purpose for details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,N)\n\ * On entry, the P-by-N matrix B.\n\ * On exit, B contains part of the triangular matrix R if\n\ * M-K-L < 0. See Purpose for details.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,P).\n\ *\n\ * ALPHA (output) REAL array, dimension (N)\n\ * BETA (output) REAL array, dimension (N)\n\ * On exit, ALPHA and BETA contain the generalized singular\n\ * value pairs of A and B;\n\ * ALPHA(1:K) = 1,\n\ * BETA(1:K) = 0,\n\ * and if M-K-L >= 0,\n\ * ALPHA(K+1:K+L) = C,\n\ * BETA(K+1:K+L) = S,\n\ * or if M-K-L < 0,\n\ * ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0\n\ * BETA(K+1:M) = S, BETA(M+1:K+L) = 1\n\ * and\n\ * ALPHA(K+L+1:N) = 0\n\ * BETA(K+L+1:N) = 0\n\ *\n\ * U (output) COMPLEX array, dimension (LDU,M)\n\ * If JOBU = 'U', U contains the M-by-M unitary matrix U.\n\ * If JOBU = 'N', U is not referenced.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= max(1,M) if\n\ * JOBU = 'U'; LDU >= 1 otherwise.\n\ *\n\ * V (output) COMPLEX array, dimension (LDV,P)\n\ * If JOBV = 'V', V contains the P-by-P unitary matrix V.\n\ * If JOBV = 'N', V is not referenced.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V. LDV >= max(1,P) if\n\ * JOBV = 'V'; LDV >= 1 otherwise.\n\ *\n\ * Q (output) COMPLEX array, dimension (LDQ,N)\n\ * If JOBQ = 'Q', Q contains the N-by-N unitary matrix Q.\n\ * If JOBQ = 'N', Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N) if\n\ * JOBQ = 'Q'; LDQ >= 1 otherwise.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (max(3*N,M,P)+N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (2*N)\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (N)\n\ * On exit, IWORK stores the sorting information. More\n\ * precisely, the following loop will sort ALPHA\n\ * for I = K+1, min(M,K+L)\n\ * swap ALPHA(I) and ALPHA(IWORK(I))\n\ * endfor\n\ * such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N).\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 = 1, the Jacobi-type procedure failed to\n\ * converge. For further details, see subroutine CTGSJA.\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * TOLA REAL\n\ * TOLB REAL\n\ * TOLA and TOLB are the thresholds to determine the effective\n\ * rank of (A',B')'. Generally, they are set to\n\ * TOLA = MAX(M,N)*norm(A)*MACHEPS,\n\ * TOLB = MAX(P,N)*norm(B)*MACHEPS.\n\ * The size of TOLA and TOLB may affect the size of backward\n\ * errors of the decomposition.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * 2-96 Based on modifications by\n\ * Ming Gu and Huan Ren, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL WANTQ, WANTU, WANTV\n INTEGER I, IBND, ISUB, J, NCYCLE\n REAL ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n REAL CLANGE, SLAMCH\n EXTERNAL LSAME, CLANGE, SLAMCH\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CGGSVP, CTGSJA, SCOPY, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/ztbrfs0000644000175000017500000001200612502223526016521 0ustar uwabamiuwabami--- :name: ztbrfs :md5sum: 0d120f06aea8ac5f348b168e747d158f :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTBRFS provides error bounds and backward error estimates for the\n\ * solution to a system of linear equations with a triangular band\n\ * coefficient matrix.\n\ *\n\ * The solution matrix X must be computed by ZTBTRS or some other\n\ * means before entering this routine. ZTBRFS does not do iterative\n\ * refinement because doing so cannot improve the backward error.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals or subdiagonals of the\n\ * triangular band matrix A. KD >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AB (input) COMPLEX*16 array, dimension (LDAB,N)\n\ * The upper or lower triangular band matrix A, stored in the\n\ * first kd+1 rows of the array. The j-th column of A is stored\n\ * in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ * If DIAG = 'U', the diagonal elements of A are not referenced\n\ * and are assumed to be 1.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * The solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlarfg0000644000175000017500000000400412502223526016473 0ustar uwabamiuwabami--- :name: zlarfg :md5sum: ce36054c7cc3734a13a0cfaf1fa30a13 :category: :subroutine :arguments: - n: :type: integer :intent: input - alpha: :type: doublecomplex :intent: input/output - x: :type: doublecomplex :intent: input/output :dims: - 1+(n-2)*abs(incx) - incx: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLARFG generates a complex elementary reflector H of order n, such\n\ * that\n\ *\n\ * H' * ( alpha ) = ( beta ), H' * H = I.\n\ * ( x ) ( 0 )\n\ *\n\ * where alpha and beta are scalars, with beta real, and x is an\n\ * (n-1)-element complex vector. H is represented in the form\n\ *\n\ * H = I - tau * ( 1 ) * ( 1 v' ) ,\n\ * ( v )\n\ *\n\ * where tau is a complex scalar and v is a complex (n-1)-element\n\ * vector. Note that H is not hermitian.\n\ *\n\ * If the elements of x are all zero and alpha is real, then tau = 0\n\ * and H is taken to be the unit matrix.\n\ *\n\ * Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 .\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the elementary reflector.\n\ *\n\ * ALPHA (input/output) COMPLEX*16\n\ * On entry, the value alpha.\n\ * On exit, it is overwritten with the value beta.\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension\n\ * (1+(N-2)*abs(INCX))\n\ * On entry, the vector x.\n\ * On exit, it is overwritten with the vector v.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between elements of X. INCX > 0.\n\ *\n\ * TAU (output) COMPLEX*16\n\ * The value tau.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slaed30000644000175000017500000001245612502223526016373 0ustar uwabamiuwabami--- :name: slaed3 :md5sum: 6f3222590ab64b2fd11ec8b308ea8611 :category: :subroutine :arguments: - k: :type: integer :intent: input - n: :type: integer :intent: input - n1: :type: integer :intent: input - d: :type: real :intent: output :dims: - n - q: :type: real :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - rho: :type: real :intent: input - dlamda: :type: real :intent: input/output :dims: - k - q2: :type: real :intent: input :dims: - n - n - indx: :type: integer :intent: input :dims: - n - ctot: :type: integer :intent: input :dims: - "4" - w: :type: real :intent: input/output :dims: - k - s: :type: real :intent: workspace :dims: - MAX(1,k) - n1 + 1 - info: :type: integer :intent: output :substitutions: ldq: MAX(1,n) :fortran_help: " SUBROUTINE SLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX, CTOT, W, S, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAED3 finds the roots of the secular equation, as defined by the\n\ * values in D, W, and RHO, between 1 and K. It makes the\n\ * appropriate calls to SLAED4 and then updates the eigenvectors by\n\ * multiplying the matrix of eigenvectors of the pair of eigensystems\n\ * being combined by the matrix of eigenvectors of the K-by-K system\n\ * which is solved here.\n\ *\n\ * This code makes very mild assumptions about floating point\n\ * arithmetic. It will work on machines with a guard digit in\n\ * add/subtract, or on those binary machines without guard digits\n\ * which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n\ * It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * K (input) INTEGER\n\ * The number of terms in the rational function to be solved by\n\ * SLAED4. K >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of rows and columns in the Q matrix.\n\ * N >= K (deflation may result in N>K).\n\ *\n\ * N1 (input) INTEGER\n\ * The location of the last eigenvalue in the leading submatrix.\n\ * min(1,N) <= N1 <= N/2.\n\ *\n\ * D (output) REAL array, dimension (N)\n\ * D(I) contains the updated eigenvalues for\n\ * 1 <= I <= K.\n\ *\n\ * Q (output) REAL array, dimension (LDQ,N)\n\ * Initially the first K columns are used as workspace.\n\ * On output the columns 1 to K contain\n\ * the updated eigenvectors.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N).\n\ *\n\ * RHO (input) REAL\n\ * The value of the parameter in the rank one update equation.\n\ * RHO >= 0 required.\n\ *\n\ * DLAMDA (input/output) REAL array, dimension (K)\n\ * The first K elements of this array contain the old roots\n\ * of the deflated updating problem. These are the poles\n\ * of the secular equation. May be changed on output by\n\ * having lowest order bit set to zero on Cray X-MP, Cray Y-MP,\n\ * Cray-2, or Cray C-90, as described above.\n\ *\n\ * Q2 (input) REAL array, dimension (LDQ2, N)\n\ * The first K columns of this matrix contain the non-deflated\n\ * eigenvectors for the split problem.\n\ *\n\ * INDX (input) INTEGER array, dimension (N)\n\ * The permutation used to arrange the columns of the deflated\n\ * Q matrix into three groups (see SLAED2).\n\ * The rows of the eigenvectors found by SLAED4 must be likewise\n\ * permuted before the matrix multiply can take place.\n\ *\n\ * CTOT (input) INTEGER array, dimension (4)\n\ * A count of the total number of the various types of columns\n\ * in Q, as described in INDX. The fourth column type is any\n\ * column which has been deflated.\n\ *\n\ * W (input/output) REAL array, dimension (K)\n\ * The first K elements of this array contain the components\n\ * of the deflation-adjusted updating vector. Destroyed on\n\ * output.\n\ *\n\ * S (workspace) REAL array, dimension (N1 + 1)*K\n\ * Will contain the eigenvectors of the repaired matrix which\n\ * will be multiplied by the previously accumulated eigenvectors\n\ * to update the system.\n\ *\n\ * LDS (input) INTEGER\n\ * The leading dimension of S. LDS >= max(1,K).\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 = 1, an eigenvalue did not converge\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Jeff Rutter, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ * Modified by Francoise Tisseur, University of Tennessee.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slaqp20000644000175000017500000000663012502223526016417 0ustar uwabamiuwabami--- :name: slaqp2 :md5sum: 082858bc789a3c8a0443b0df5a0a377a :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - offset: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: real :intent: output :dims: - MIN(m,n) - vn1: :type: real :intent: input/output :dims: - n - vn2: :type: real :intent: input/output :dims: - n - work: :type: real :intent: workspace :dims: - n :substitutions: {} :fortran_help: " SUBROUTINE SLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAQP2 computes a QR factorization with column pivoting of\n\ * the block A(OFFSET+1:M,1:N).\n\ * The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\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\ * OFFSET (input) INTEGER\n\ * The number of rows of the matrix A that must be pivoted\n\ * but no factorized. OFFSET >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, the upper triangle of block A(OFFSET+1:M,1:N) is \n\ * the triangular factor obtained; the elements in block \n\ * A(OFFSET+1:M,1:N) below the diagonal, together with the \n\ * array TAU, represent the orthogonal matrix Q as a product of\n\ * elementary reflectors. Block A(1:OFFSET,1:N) has been\n\ * accordingly pivoted, but no factorized.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * JPVT (input/output) INTEGER array, dimension (N)\n\ * On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n\ * to the front of A*P (a leading column); if JPVT(i) = 0,\n\ * the i-th column of A is a free column.\n\ * On exit, if JPVT(i) = k, then the i-th column of A*P\n\ * was the k-th column of A.\n\ *\n\ * TAU (output) REAL array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors.\n\ *\n\ * VN1 (input/output) REAL array, dimension (N)\n\ * The vector with the partial column norms.\n\ *\n\ * VN2 (input/output) REAL array, dimension (N)\n\ * The vector with the exact column norms.\n\ *\n\ * WORK (workspace) REAL array, dimension (N)\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n\ * X. Sun, Computer Science Dept., Duke University, USA\n\ *\n\ * Partial column norm updating strategy modified by\n\ * Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n\ * University of Zagreb, Croatia.\n\ * June 2010\n\ * For more details see LAPACK Working Note 176.\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ztrttf0000644000175000017500000001467512502223526016562 0ustar uwabamiuwabami--- :name: ztrttf :md5sum: 41673e3e78a3bb5093e17504697ba277 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - arf: :type: doublecomplex :intent: output :dims: - ( n*(n+1)/2 ) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZTRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTRTTF copies a triangular matrix A from standard full format (TR)\n\ * to rectangular full packed format (TF) .\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': ARF in Normal mode is wanted;\n\ * = 'C': ARF in Conjugate Transpose mode is wanted;\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension ( LDA, N ) \n\ * On entry, the triangular matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of the array A contains\n\ * the upper triangular matrix, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of the array A contains\n\ * the lower triangular matrix, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the matrix A. LDA >= max(1,N).\n\ *\n\ * ARF (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n\ * On exit, the upper or lower triangular matrix A stored in\n\ * RFP format. For a further discussion see Notes below.\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\ * We first consider Standard Packed Format when N is even.\n\ * We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = `N'. RFP holds AP as follows:\n\ * For UPLO = `U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * conjugate-transpose of the first three columns of AP upper.\n\ * For UPLO = `L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * conjugate-transpose of the last three columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N even and TRANSR = `N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- --\n\ * 03 04 05 33 43 53\n\ * -- --\n\ * 13 14 15 00 44 54\n\ * --\n\ * 23 24 25 10 11 55\n\ *\n\ * 33 34 35 20 21 22\n\ * --\n\ * 00 44 45 30 31 32\n\ * -- --\n\ * 01 11 55 40 41 42\n\ * -- -- --\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = `C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We next consider Standard Packed Format when N is odd.\n\ * We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = `N'. RFP holds AP as follows:\n\ * For UPLO = `U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * conjugate-transpose of the first two columns of AP upper.\n\ * For UPLO = `L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * conjugate-transpose of the last two columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N odd and TRANSR = `N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- --\n\ * 02 03 04 00 33 43\n\ * --\n\ * 12 13 14 10 11 44\n\ *\n\ * 22 23 24 20 21 22\n\ * --\n\ * 00 33 34 30 31 32\n\ * -- --\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = `C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- --\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlansp0000644000175000017500000000552012502223526016473 0ustar uwabamiuwabami--- :name: dlansp :md5sum: eff9ff5dad54ccade39fa653933603f3 :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - n*(n+1)/2 - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLANSP returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * real symmetric matrix A, supplied in packed form.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * DLANSP returns the value\n\ *\n\ * DLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in DLANSP as described\n\ * above.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is supplied.\n\ * = 'U': Upper triangular part of A is supplied\n\ * = 'L': Lower triangular part of A is supplied\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, DLANSP is\n\ * set to zero.\n\ *\n\ * AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * The upper or lower triangle of the symmetric matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n\ * WORK is not referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chpgvx0000644000175000017500000002205212502223525016507 0ustar uwabamiuwabami--- :name: chpgvx :md5sum: 04980cf924a1957e030573a32bc6b72c :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - ldap - bp: :type: complex :intent: input/output :dims: - n*(n+1)/2 - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - "lsame_(&jobz,\"N\") ? 0 : ldz" - "lsame_(&jobz,\"N\") ? 0 : n" - ldz: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - 7*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE CHPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHPGVX computes selected eigenvalues and, optionally, eigenvectors\n\ * of a complex generalized Hermitian-definite eigenproblem, of the form\n\ * A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n\ * B are assumed to be Hermitian, stored in packed format, and B is also\n\ * positive definite. Eigenvalues and eigenvectors can be selected by\n\ * specifying either a range of values or a range of indices for the\n\ * desired eigenvalues.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * Specifies the problem type to be solved:\n\ * = 1: A*x = (lambda)*B*x\n\ * = 2: A*B*x = (lambda)*x\n\ * = 3: B*A*x = (lambda)*x\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found;\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found;\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, the contents of AP are destroyed.\n\ *\n\ * BP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * B, packed columnwise in a linear array. The j-th column of B\n\ * is stored in the array BP as follows:\n\ * if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n\ *\n\ * On exit, the triangular factor U or L from the Cholesky\n\ * factorization B = U**H*U or B = L*L**H, in the same storage\n\ * format as B.\n\ *\n\ * VL (input) REAL\n\ * VU (input) REAL\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) REAL\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less than\n\ * or equal to zero, then EPS*|T| will be used in its place,\n\ * where |T| is the 1-norm of the tridiagonal matrix obtained\n\ * by reducing AP to tridiagonal form.\n\ *\n\ * Eigenvalues will be computed most accurately when ABSTOL is\n\ * set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n\ * If this routine returns with INFO>0, indicating that some\n\ * eigenvectors did not converge, try setting ABSTOL to\n\ * 2*SLAMCH('S').\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * On normal exit, the first M elements contain the selected\n\ * eigenvalues in ascending order.\n\ *\n\ * Z (output) COMPLEX array, dimension (LDZ, N)\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix A\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * The eigenvectors are normalized as follows:\n\ * if ITYPE = 1 or 2, Z**H*B*Z = I;\n\ * if ITYPE = 3, Z**H*inv(B)*Z = I.\n\ *\n\ * If an eigenvector fails to converge, then that column of Z\n\ * contains the latest approximation to the eigenvector, and the\n\ * index of the eigenvector is returned in IFAIL.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (7*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (5*N)\n\ *\n\ * IFAIL (output) INTEGER array, dimension (N)\n\ * If JOBZ = 'V', then if INFO = 0, the first M elements of\n\ * IFAIL are zero. If INFO > 0, then IFAIL contains the\n\ * indices of the eigenvectors that failed to converge.\n\ * If JOBZ = 'N', then IFAIL is not referenced.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: CPPTRF or CHPEVX returned an error code:\n\ * <= N: if INFO = i, CHPEVX failed to converge;\n\ * i eigenvectors failed to converge. Their indices\n\ * are stored in array IFAIL.\n\ * > N: if INFO = N + i, for 1 <= i <= n, then the leading\n\ * minor of order i of B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL ALLEIG, INDEIG, UPPER, VALEIG, WANTZ\n CHARACTER TRANS\n INTEGER J\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CHPEVX, CHPGST, CPPTRF, CTPMV, CTPSV, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slacon0000644000175000017500000000466212502223526016477 0ustar uwabamiuwabami--- :name: slacon :md5sum: d96882f0cf8bca75abc96f74556cd278 :category: :subroutine :arguments: - n: :type: integer :intent: input - v: :type: real :intent: workspace :dims: - n - x: :type: real :intent: input/output :dims: - n - isgn: :type: integer :intent: workspace :dims: - n - est: :type: real :intent: input/output - kase: :type: integer :intent: input/output :substitutions: {} :fortran_help: " SUBROUTINE SLACON( N, V, X, ISGN, EST, KASE )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLACON estimates the 1-norm of a square, real matrix A.\n\ * Reverse communication is used for evaluating matrix-vector products.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 1.\n\ *\n\ * V (workspace) REAL array, dimension (N)\n\ * On the final return, V = A*W, where EST = norm(V)/norm(W)\n\ * (W is not returned).\n\ *\n\ * X (input/output) REAL array, dimension (N)\n\ * On an intermediate return, X should be overwritten by\n\ * A * X, if KASE=1,\n\ * A' * X, if KASE=2,\n\ * and SLACON must be re-called with all the other parameters\n\ * unchanged.\n\ *\n\ * ISGN (workspace) INTEGER array, dimension (N)\n\ *\n\ * EST (input/output) REAL\n\ * On entry with KASE = 1 or 2 and JUMP = 3, EST should be\n\ * unchanged from the previous call to SLACON.\n\ * On exit, EST is an estimate (a lower bound) for norm(A). \n\ *\n\ * KASE (input/output) INTEGER\n\ * On the initial call to SLACON, KASE should be 0.\n\ * On an intermediate return, KASE will be 1 or 2, indicating\n\ * whether X should be overwritten by A * X or A' * X.\n\ * On the final return from SLACON, KASE will again be 0.\n\ *\n\n\ * Further Details\n\ * ======= =======\n\ *\n\ * Contributed by Nick Higham, University of Manchester.\n\ * Originally named SONEST, dated March 16, 1988.\n\ *\n\ * Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n\ * a real or complex matrix, with applications to condition estimation\",\n\ * ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/shsein0000644000175000017500000002124012502223526016500 0ustar uwabamiuwabami--- :name: shsein :md5sum: 41d65c46fe2e60e8a05df236c5bd8cfb :category: :subroutine :arguments: - side: :type: char :intent: input - eigsrc: :type: char :intent: input - initv: :type: char :intent: input - select: :type: logical :intent: input/output :dims: - n - n: :type: integer :intent: input - h: :type: real :intent: input :dims: - ldh - n - ldh: :type: integer :intent: input - wr: :type: real :intent: input/output :dims: - n - wi: :type: real :intent: input :dims: - n - vl: :type: real :intent: input/output :dims: - ldvl - mm - ldvl: :type: integer :intent: input - vr: :type: real :intent: input/output :dims: - ldvr - mm - ldvr: :type: integer :intent: input - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: real :intent: workspace :dims: - (n+2)*n - ifaill: :type: integer :intent: output :dims: - mm - ifailr: :type: integer :intent: output :dims: - mm - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI, VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL, IFAILR, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SHSEIN uses inverse iteration to find specified right and/or left\n\ * eigenvectors of a real upper Hessenberg matrix H.\n\ *\n\ * The right eigenvector x and the left eigenvector y of the matrix H\n\ * corresponding to an eigenvalue w are defined by:\n\ *\n\ * H * x = w * x, y**h * H = w * y**h\n\ *\n\ * where y**h denotes the conjugate transpose of the vector y.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'R': compute right eigenvectors only;\n\ * = 'L': compute left eigenvectors only;\n\ * = 'B': compute both right and left eigenvectors.\n\ *\n\ * EIGSRC (input) CHARACTER*1\n\ * Specifies the source of eigenvalues supplied in (WR,WI):\n\ * = 'Q': the eigenvalues were found using SHSEQR; thus, if\n\ * H has zero subdiagonal elements, and so is\n\ * block-triangular, then the j-th eigenvalue can be\n\ * assumed to be an eigenvalue of the block containing\n\ * the j-th row/column. This property allows SHSEIN to\n\ * perform inverse iteration on just one diagonal block.\n\ * = 'N': no assumptions are made on the correspondence\n\ * between eigenvalues and diagonal blocks. In this\n\ * case, SHSEIN must always perform inverse iteration\n\ * using the whole matrix H.\n\ *\n\ * INITV (input) CHARACTER*1\n\ * = 'N': no initial vectors are supplied;\n\ * = 'U': user-supplied initial vectors are stored in the arrays\n\ * VL and/or VR.\n\ *\n\ * SELECT (input/output) LOGICAL array, dimension (N)\n\ * Specifies the eigenvectors to be computed. To select the\n\ * real eigenvector corresponding to a real eigenvalue WR(j),\n\ * SELECT(j) must be set to .TRUE.. To select the complex\n\ * eigenvector corresponding to a complex eigenvalue\n\ * (WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)),\n\ * either SELECT(j) or SELECT(j+1) or both must be set to\n\ * .TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is\n\ * .FALSE..\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H. N >= 0.\n\ *\n\ * H (input) REAL array, dimension (LDH,N)\n\ * The upper Hessenberg matrix H.\n\ *\n\ * LDH (input) INTEGER\n\ * The leading dimension of the array H. LDH >= max(1,N).\n\ *\n\ * WR (input/output) REAL array, dimension (N)\n\ * WI (input) REAL array, dimension (N)\n\ * On entry, the real and imaginary parts of the eigenvalues of\n\ * H; a complex conjugate pair of eigenvalues must be stored in\n\ * consecutive elements of WR and WI.\n\ * On exit, WR may have been altered since close eigenvalues\n\ * are perturbed slightly in searching for independent\n\ * eigenvectors.\n\ *\n\ * VL (input/output) REAL array, dimension (LDVL,MM)\n\ * On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must\n\ * contain starting vectors for the inverse iteration for the\n\ * left eigenvectors; the starting vector for each eigenvector\n\ * must be in the same column(s) in which the eigenvector will\n\ * be stored.\n\ * On exit, if SIDE = 'L' or 'B', the left eigenvectors\n\ * specified by SELECT will be stored consecutively in the\n\ * columns of VL, in the same order as their eigenvalues. A\n\ * complex eigenvector corresponding to a complex eigenvalue is\n\ * stored in two consecutive columns, the first holding the real\n\ * part and the second the imaginary part.\n\ * If SIDE = 'R', VL is not referenced.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the array VL.\n\ * LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.\n\ *\n\ * VR (input/output) REAL array, dimension (LDVR,MM)\n\ * On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must\n\ * contain starting vectors for the inverse iteration for the\n\ * right eigenvectors; the starting vector for each eigenvector\n\ * must be in the same column(s) in which the eigenvector will\n\ * be stored.\n\ * On exit, if SIDE = 'R' or 'B', the right eigenvectors\n\ * specified by SELECT will be stored consecutively in the\n\ * columns of VR, in the same order as their eigenvalues. A\n\ * complex eigenvector corresponding to a complex eigenvalue is\n\ * stored in two consecutive columns, the first holding the real\n\ * part and the second the imaginary part.\n\ * If SIDE = 'L', VR is not referenced.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the array VR.\n\ * LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.\n\ *\n\ * MM (input) INTEGER\n\ * The number of columns in the arrays VL and/or VR. MM >= M.\n\ *\n\ * M (output) INTEGER\n\ * The number of columns in the arrays VL and/or VR required to\n\ * store the eigenvectors; each selected real eigenvector\n\ * occupies one column and each selected complex eigenvector\n\ * occupies two columns.\n\ *\n\ * WORK (workspace) REAL array, dimension ((N+2)*N)\n\ *\n\ * IFAILL (output) INTEGER array, dimension (MM)\n\ * If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left\n\ * eigenvector in the i-th column of VL (corresponding to the\n\ * eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the\n\ * eigenvector converged satisfactorily. If the i-th and (i+1)th\n\ * columns of VL hold a complex eigenvector, then IFAILL(i) and\n\ * IFAILL(i+1) are set to the same value.\n\ * If SIDE = 'R', IFAILL is not referenced.\n\ *\n\ * IFAILR (output) INTEGER array, dimension (MM)\n\ * If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right\n\ * eigenvector in the i-th column of VR (corresponding to the\n\ * eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the\n\ * eigenvector converged satisfactorily. If the i-th and (i+1)th\n\ * columns of VR hold a complex eigenvector, then IFAILR(i) and\n\ * IFAILR(i+1) are set to the same value.\n\ * If SIDE = 'L', IFAILR is not referenced.\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, i is the number of eigenvectors which\n\ * failed to converge; see IFAILL and IFAILR for further\n\ * details.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Each eigenvector is normalized so that the element of largest\n\ * magnitude has magnitude 1; here the magnitude of a complex number\n\ * (x,y) is taken to be |x|+|y|.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsptri0000644000175000017500000000473612502223526016527 0ustar uwabamiuwabami--- :name: dsptri :md5sum: 4b77efb779c649e38dd9815265e50086 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DSPTRI( UPLO, N, AP, IPIV, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSPTRI computes the inverse of a real symmetric indefinite matrix\n\ * A in packed storage using the factorization A = U*D*U**T or\n\ * A = L*D*L**T computed by DSPTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * On entry, the block diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L as computed by DSPTRF,\n\ * stored as a packed triangular matrix.\n\ *\n\ * On exit, if INFO = 0, the (symmetric) inverse of the original\n\ * matrix, stored as a packed triangular matrix. The j-th column\n\ * of inv(A) is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;\n\ * if UPLO = 'L',\n\ * AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by DSPTRF.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (N)\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, D(i,i) = 0; the matrix is singular and its\n\ * inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/claqsb0000644000175000017500000000635712502223525016467 0ustar uwabamiuwabami--- :name: claqsb :md5sum: f2a38c2dabc747d75a627865a1f6678f :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - s: :type: real :intent: input :dims: - n - scond: :type: real :intent: input - amax: :type: real :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAQSB equilibrates a symmetric band matrix A using the scaling\n\ * factors in the vector S.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of super-diagonals of the matrix A if UPLO = 'U',\n\ * or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) COMPLEX array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * On exit, if INFO = 0, the triangular factor U or L from the\n\ * Cholesky factorization A = U'*U or A = L*L' of the band\n\ * matrix A, in the same storage format as A.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * S (input) REAL array, dimension (N)\n\ * The scale factors for A.\n\ *\n\ * SCOND (input) REAL\n\ * Ratio of the smallest S(i) to the largest S(i).\n\ *\n\ * AMAX (input) REAL\n\ * Absolute value of largest matrix entry.\n\ *\n\ * EQUED (output) CHARACTER*1\n\ * Specifies whether or not equilibration was done.\n\ * = 'N': No equilibration.\n\ * = 'Y': Equilibration was done, i.e., A has been replaced by\n\ * diag(S) * A * diag(S).\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * THRESH is a threshold value used to decide if scaling should be done\n\ * based on the ratio of the scaling factors. If SCOND < THRESH,\n\ * scaling is done.\n\ *\n\ * LARGE and SMALL are threshold values used to decide if scaling should\n\ * be done based on the absolute size of the largest matrix element.\n\ * If AMAX > LARGE or AMAX < SMALL, scaling is done.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cunmr30000644000175000017500000001116012502223526016416 0ustar uwabamiuwabami--- :name: cunmr3 :md5sum: 67cac9132bae1f638b544e1094b357af :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CUNMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CUNMR3 overwrites the general complex m by n matrix C with\n\ *\n\ * Q * C if SIDE = 'L' and TRANS = 'N', or\n\ *\n\ * Q'* C if SIDE = 'L' and TRANS = 'C', or\n\ *\n\ * C * Q if SIDE = 'R' and TRANS = 'N', or\n\ *\n\ * C * Q' if SIDE = 'R' and TRANS = 'C',\n\ *\n\ * where Q is a complex unitary matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by CTZRZF. Q is of order m if SIDE = 'L' and of order n\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q' from the Left\n\ * = 'R': apply Q or Q' from the Right\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': apply Q (No transpose)\n\ * = 'C': apply Q' (Conjugate transpose)\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * L (input) INTEGER\n\ * The number of columns of the matrix A containing\n\ * the meaningful part of the Householder reflectors.\n\ * If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension\n\ * (LDA,M) if SIDE = 'L',\n\ * (LDA,N) if SIDE = 'R'\n\ * The i-th row must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * CTZRZF in the last k rows of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,K).\n\ *\n\ * TAU (input) COMPLEX array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by CTZRZF.\n\ *\n\ * C (input/output) COMPLEX array, dimension (LDC,N)\n\ * On entry, the m-by-n matrix C.\n\ * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension\n\ * (N) if SIDE = 'L',\n\ * (M) if SIDE = 'R'\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\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LEFT, NOTRAN\n INTEGER I, I1, I2, I3, IC, JA, JC, MI, NI, NQ\n COMPLEX TAUI\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CLARZ, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC CONJG, MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlasyf0000644000175000017500000001060612502223526016475 0ustar uwabamiuwabami--- :name: dlasyf :md5sum: a8454c0cdaacfc25f0e790f47e4824f1 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nb: :type: integer :intent: input - kb: :type: integer :intent: output - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - w: :type: doublereal :intent: workspace :dims: - ldw - MAX(1,nb) - ldw: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: ldw: MAX(1,n) :fortran_help: " SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLASYF computes a partial factorization of a real symmetric matrix A\n\ * using the Bunch-Kaufman diagonal pivoting method. The partial\n\ * factorization has the form:\n\ *\n\ * A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:\n\ * ( 0 U22 ) ( 0 D ) ( U12' U22' )\n\ *\n\ * A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L'\n\ * ( L21 I ) ( 0 A22 ) ( 0 I )\n\ *\n\ * where the order of D is at most NB. The actual order is returned in\n\ * the argument KB, and is either NB or NB-1, or N if N <= NB.\n\ *\n\ * DLASYF is an auxiliary routine called by DSYTRF. It uses blocked code\n\ * (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or\n\ * A22 (if UPLO = 'L').\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NB (input) INTEGER\n\ * The maximum number of columns of the matrix A that should be\n\ * factored. NB should be at least 2 to allow for 2-by-2 pivot\n\ * blocks.\n\ *\n\ * KB (output) INTEGER\n\ * The number of columns of A that were actually factored.\n\ * KB is either NB-1 or NB, or N if N <= NB.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * n-by-n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n-by-n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ * On exit, A contains details of the partial factorization.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D.\n\ * If UPLO = 'U', only the last KB elements of IPIV are set;\n\ * if UPLO = 'L', only the first KB elements are set.\n\ *\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * W (workspace) DOUBLE PRECISION array, dimension (LDW,NB)\n\ *\n\ * LDW (input) INTEGER\n\ * The leading dimension of the array W. LDW >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssygs20000644000175000017500000000572312502223526016451 0ustar uwabamiuwabami--- :name: ssygs2 :md5sum: 42826111a4afb91aa5b98c358b60a0b2 :category: :subroutine :arguments: - itype: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSYGS2 reduces a real symmetric-definite generalized eigenproblem\n\ * to standard form.\n\ *\n\ * If ITYPE = 1, the problem is A*x = lambda*B*x,\n\ * and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')\n\ *\n\ * If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n\ * B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.\n\ *\n\ * B must have been previously factorized as U'*U or L*L' by SPOTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');\n\ * = 2 or 3: compute U*A*U' or L'*A*L.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored, and how B has been factorized.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * n by n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n by n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the transformed matrix, stored in the\n\ * same format as A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input) REAL array, dimension (LDB,N)\n\ * The triangular factor from the Cholesky factorization of B,\n\ * as returned by SPOTRF.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cggevx0000644000175000017500000003161012502223525016473 0ustar uwabamiuwabami--- :name: cggevx :md5sum: 6749d93a340b1974b08908ef409f99e7 :category: :subroutine :arguments: - balanc: :type: char :intent: input - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alpha: :type: complex :intent: output :dims: - n - beta: :type: complex :intent: output :dims: - n - vl: :type: complex :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: complex :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - lscale: :type: real :intent: output :dims: - n - rscale: :type: real :intent: output :dims: - n - abnrm: :type: real :intent: output - bbnrm: :type: real :intent: output - rconde: :type: real :intent: output :dims: - n - rcondv: :type: real :intent: output :dims: - n - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&sense,\"E\") ? 4*n : (lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? 2*n*n+2*n : 2*n" - rwork: :type: real :intent: workspace :dims: - lrwork - iwork: :type: integer :intent: workspace :dims: - "lsame_(&sense,\"E\") ? 0 : n+2" - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sense,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" lrwork: "((lsame_(&balanc,\"S\")) || (lsame_(&balanc,\"B\"))) ? MAX(1,6*n) : MAX(1,2*n)" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " SUBROUTINE CGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, ILO, IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, WORK, LWORK, RWORK, IWORK, BWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGGEVX computes for a pair of N-by-N complex nonsymmetric matrices\n\ * (A,B) the generalized eigenvalues, and optionally, the left and/or\n\ * right generalized eigenvectors.\n\ *\n\ * Optionally, it also computes a balancing transformation to improve\n\ * the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n\ * LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for\n\ * the eigenvalues (RCONDE), and reciprocal condition numbers for the\n\ * right eigenvectors (RCONDV).\n\ *\n\ * A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n\ * lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n\ * singular. It is usually represented as the pair (alpha,beta), as\n\ * there is a reasonable interpretation for beta=0, and even for both\n\ * being zero.\n\ *\n\ * The right eigenvector v(j) corresponding to the eigenvalue lambda(j)\n\ * of (A,B) satisfies\n\ * A * v(j) = lambda(j) * B * v(j) .\n\ * The left eigenvector u(j) corresponding to the eigenvalue lambda(j)\n\ * of (A,B) satisfies\n\ * u(j)**H * A = lambda(j) * u(j)**H * B.\n\ * where u(j)**H is the conjugate-transpose of u(j).\n\ *\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * BALANC (input) CHARACTER*1\n\ * Specifies the balance option to be performed:\n\ * = 'N': do not diagonally scale or permute;\n\ * = 'P': permute only;\n\ * = 'S': scale only;\n\ * = 'B': both permute and scale.\n\ * Computed reciprocal condition numbers will be for the\n\ * matrices after permuting and/or balancing. Permuting does\n\ * not change condition numbers (in exact arithmetic), but\n\ * balancing does.\n\ *\n\ * JOBVL (input) CHARACTER*1\n\ * = 'N': do not compute the left generalized eigenvectors;\n\ * = 'V': compute the left generalized eigenvectors.\n\ *\n\ * JOBVR (input) CHARACTER*1\n\ * = 'N': do not compute the right generalized eigenvectors;\n\ * = 'V': compute the right generalized eigenvectors.\n\ *\n\ * SENSE (input) CHARACTER*1\n\ * Determines which reciprocal condition numbers are computed.\n\ * = 'N': none are computed;\n\ * = 'E': computed for eigenvalues only;\n\ * = 'V': computed for eigenvectors only;\n\ * = 'B': computed for eigenvalues and eigenvectors.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A, B, VL, and VR. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA, N)\n\ * On entry, the matrix A in the pair (A,B).\n\ * On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'\n\ * or both, then A contains the first part of the complex Schur\n\ * form of the \"balanced\" versions of the input A and B.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB, N)\n\ * On entry, the matrix B in the pair (A,B).\n\ * On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'\n\ * or both, then B contains the second part of the complex\n\ * Schur form of the \"balanced\" versions of the input A and B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B. LDB >= max(1,N).\n\ *\n\ * ALPHA (output) COMPLEX array, dimension (N)\n\ * BETA (output) COMPLEX array, dimension (N)\n\ * On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the generalized\n\ * eigenvalues.\n\ *\n\ * Note: the quotient ALPHA(j)/BETA(j) ) may easily over- or\n\ * underflow, and BETA(j) may even be zero. Thus, the user\n\ * should avoid naively computing the ratio ALPHA/BETA.\n\ * However, ALPHA will be always less than and usually\n\ * comparable with norm(A) in magnitude, and BETA always less\n\ * than and usually comparable with norm(B).\n\ *\n\ * VL (output) COMPLEX array, dimension (LDVL,N)\n\ * If JOBVL = 'V', the left generalized eigenvectors u(j) are\n\ * stored one after another in the columns of VL, in the same\n\ * order as their eigenvalues.\n\ * Each eigenvector will be scaled so the largest component\n\ * will have abs(real part) + abs(imag. part) = 1.\n\ * Not referenced if JOBVL = 'N'.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the matrix VL. LDVL >= 1, and\n\ * if JOBVL = 'V', LDVL >= N.\n\ *\n\ * VR (output) COMPLEX array, dimension (LDVR,N)\n\ * If JOBVR = 'V', the right generalized eigenvectors v(j) are\n\ * stored one after another in the columns of VR, in the same\n\ * order as their eigenvalues.\n\ * Each eigenvector will be scaled so the largest component\n\ * will have abs(real part) + abs(imag. part) = 1.\n\ * Not referenced if JOBVR = 'N'.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the matrix VR. LDVR >= 1, and\n\ * if JOBVR = 'V', LDVR >= N.\n\ *\n\ * ILO (output) INTEGER\n\ * IHI (output) INTEGER\n\ * ILO and IHI are integer values such that on exit\n\ * A(i,j) = 0 and B(i,j) = 0 if i > j and\n\ * j = 1,...,ILO-1 or i = IHI+1,...,N.\n\ * If BALANC = 'N' or 'S', ILO = 1 and IHI = N.\n\ *\n\ * LSCALE (output) REAL array, dimension (N)\n\ * Details of the permutations and scaling factors applied\n\ * to the left side of A and B. If PL(j) is the index of the\n\ * row interchanged with row j, and DL(j) is the scaling\n\ * factor applied to row j, then\n\ * LSCALE(j) = PL(j) for j = 1,...,ILO-1\n\ * = DL(j) for j = ILO,...,IHI\n\ * = PL(j) for j = IHI+1,...,N.\n\ * The order in which the interchanges are made is N to IHI+1,\n\ * then 1 to ILO-1.\n\ *\n\ * RSCALE (output) REAL array, dimension (N)\n\ * Details of the permutations and scaling factors applied\n\ * to the right side of A and B. If PR(j) is the index of the\n\ * column interchanged with column j, and DR(j) is the scaling\n\ * factor applied to column j, then\n\ * RSCALE(j) = PR(j) for j = 1,...,ILO-1\n\ * = DR(j) for j = ILO,...,IHI\n\ * = PR(j) for j = IHI+1,...,N\n\ * The order in which the interchanges are made is N to IHI+1,\n\ * then 1 to ILO-1.\n\ *\n\ * ABNRM (output) REAL\n\ * The one-norm of the balanced matrix A.\n\ *\n\ * BBNRM (output) REAL\n\ * The one-norm of the balanced matrix B.\n\ *\n\ * RCONDE (output) REAL array, dimension (N)\n\ * If SENSE = 'E' or 'B', the reciprocal condition numbers of\n\ * the eigenvalues, stored in consecutive elements of the array.\n\ * If SENSE = 'N' or 'V', RCONDE is not referenced.\n\ *\n\ * RCONDV (output) REAL array, dimension (N)\n\ * If SENSE = 'V' or 'B', the estimated reciprocal condition\n\ * numbers of the eigenvectors, stored in consecutive elements\n\ * of the array. If the eigenvalues cannot be reordered to\n\ * compute RCONDV(j), RCONDV(j) is set to 0; this can only occur\n\ * when the true value would be very small anyway. \n\ * If SENSE = 'N' or 'E', RCONDV is not referenced.\n\ *\n\ * WORK (workspace/output) COMPLEX 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,2*N).\n\ * If SENSE = 'E', LWORK >= max(1,4*N).\n\ * If SENSE = 'V' or 'B', LWORK >= max(1,2*N*N+2*N).\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\ * RWORK (workspace) REAL array, dimension (lrwork)\n\ * lrwork must be at least max(1,6*N) if BALANC = 'S' or 'B',\n\ * and at least max(1,2*N) otherwise.\n\ * Real workspace.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N+2)\n\ * If SENSE = 'E', IWORK is not referenced.\n\ *\n\ * BWORK (workspace) LOGICAL array, dimension (N)\n\ * If SENSE = 'N', BWORK is not referenced.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * = 1,...,N:\n\ * The QZ iteration failed. No eigenvectors have been\n\ * calculated, but ALPHA(j) and BETA(j) should be correct\n\ * for j=INFO+1,...,N.\n\ * > N: =N+1: other than QZ iteration failed in CHGEQZ.\n\ * =N+2: error return from CTGEVC.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Balancing a matrix pair (A,B) includes, first, permuting rows and\n\ * columns to isolate eigenvalues, second, applying diagonal similarity\n\ * transformation to the rows and columns to make the rows and columns\n\ * as close in norm as possible. The computed reciprocal condition\n\ * numbers correspond to the balanced matrix. Permuting rows and columns\n\ * will not change the condition numbers (in exact arithmetic) but\n\ * diagonal scaling will. For further explanation of balancing, see\n\ * section 4.11.1.2 of LAPACK Users' Guide.\n\ *\n\ * An approximate error bound on the chordal distance between the i-th\n\ * computed generalized eigenvalue w and the corresponding exact\n\ * eigenvalue lambda is\n\ *\n\ * chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)\n\ *\n\ * An approximate error bound for the angle between the i-th computed\n\ * eigenvector VL(i) or VR(i) is given by\n\ *\n\ * EPS * norm(ABNRM, BBNRM) / DIF(i).\n\ *\n\ * For further explanation of the reciprocal condition numbers RCONDE\n\ * and RCONDV, see section 4.11 of LAPACK User's Guide.\n\ *\n" ruby-lapack-1.7.2/dev/defs/stfttp0000644000175000017500000001243012502223526016534 0ustar uwabamiuwabami--- :name: stfttp :md5sum: 8b5cd27ac481472cc0220e19615f2a63 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - arf: :type: real :intent: input :dims: - ( n*(n+1)/2 ) - ap: :type: real :intent: output :dims: - ( n*(n+1)/2 ) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE STFTTP( TRANSR, UPLO, N, ARF, AP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STFTTP copies a triangular matrix A from rectangular full packed\n\ * format (TF) to standard packed format (TP).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': ARF is in Normal format;\n\ * = 'T': ARF is in Transpose format;\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * ARF (input) REAL array, dimension ( N*(N+1)/2 ),\n\ * On entry, the upper or lower triangular matrix A stored in\n\ * RFP format. For a further discussion see Notes below.\n\ *\n\ * AP (output) REAL array, dimension ( N*(N+1)/2 ),\n\ * On exit, the upper or lower triangular matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\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\ * We first consider Rectangular Full Packed (RFP) Format when N is\n\ * even. We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * the transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * the transpose of the last three columns of AP lower.\n\ * This covers the case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 04 05 33 43 53\n\ * 13 14 15 00 44 54\n\ * 23 24 25 10 11 55\n\ * 33 34 35 20 21 22\n\ * 00 44 45 30 31 32\n\ * 01 11 55 40 41 42\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We then consider Rectangular Full Packed (RFP) Format when N is\n\ * odd. We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * the transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * the transpose of the last two columns of AP lower.\n\ * This covers the case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 03 04 00 33 43\n\ * 12 13 14 10 11 44\n\ * 22 23 24 20 21 22\n\ * 00 33 34 30 31 32\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhegv0000644000175000017500000001271212502223526016336 0ustar uwabamiuwabami--- :name: zhegv :md5sum: 07c9d92c53a06b1456cf9411ad416814 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n-1 - rwork: :type: doublereal :intent: workspace :dims: - MAX(1, 3*n-2) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZHEGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHEGV computes all the eigenvalues, and optionally, the eigenvectors\n\ * of a complex generalized Hermitian-definite eigenproblem, of the form\n\ * A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.\n\ * Here A and B are assumed to be Hermitian and B is also\n\ * positive definite.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * Specifies the problem type to be solved:\n\ * = 1: A*x = (lambda)*B*x\n\ * = 2: A*B*x = (lambda)*x\n\ * = 3: B*A*x = (lambda)*x\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA, N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of A contains the\n\ * upper triangular part of the matrix A. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of A contains\n\ * the lower triangular part of the matrix A.\n\ *\n\ * On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n\ * matrix Z of eigenvectors. The eigenvectors are normalized\n\ * as follows:\n\ * if ITYPE = 1 or 2, Z**H*B*Z = I;\n\ * if ITYPE = 3, Z**H*inv(B)*Z = I.\n\ * If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n\ * or the lower triangle (if UPLO='L') of A, including the\n\ * diagonal, is destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB, N)\n\ * On entry, the Hermitian positive definite matrix B.\n\ * If UPLO = 'U', the leading N-by-N upper triangular part of B\n\ * contains the upper triangular part of the matrix B.\n\ * If UPLO = 'L', the leading N-by-N lower triangular part of B\n\ * contains the lower triangular part of the matrix B.\n\ *\n\ * On exit, if INFO <= N, the part of B containing the matrix is\n\ * overwritten by the triangular factor U or L from the Cholesky\n\ * factorization B = U**H*U or B = L*L**H.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of the array WORK. LWORK >= max(1,2*N-1).\n\ * For optimal efficiency, LWORK >= (NB+1)*N,\n\ * where NB is the blocksize for ZHETRD returned by ILAENV.\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\ * RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2))\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: ZPOTRF or ZHEEV returned an error code:\n\ * <= N: if INFO = i, ZHEEV failed to converge;\n\ * i off-diagonal elements of an intermediate\n\ * tridiagonal form did not converge to zero;\n\ * > N: if INFO = N + i, for 1 <= i <= N, then the leading\n\ * minor of order i of B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ztbtrs0000644000175000017500000000670312502223526016546 0ustar uwabamiuwabami--- :name: ztbtrs :md5sum: f5db47eaff35ac41a9679726933de724 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTBTRS solves a triangular system of the form\n\ *\n\ * A * X = B, A**T * X = B, or A**H * X = B,\n\ *\n\ * where A is a triangular band matrix of order N, and B is an\n\ * N-by-NRHS matrix. A check is made to verify that A is nonsingular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals or subdiagonals of the\n\ * triangular band matrix A. KD >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AB (input) COMPLEX*16 array, dimension (LDAB,N)\n\ * The upper or lower triangular band matrix A, stored in the\n\ * first kd+1 rows of AB. The j-th column of A is stored\n\ * in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ * If DIAG = 'U', the diagonal elements of A are not referenced\n\ * and are assumed to be 1.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, if INFO = 0, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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 A is zero,\n\ * indicating that the matrix is singular and the\n\ * solutions X have not been computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgbequ0000644000175000017500000000754612502223526016473 0ustar uwabamiuwabami--- :name: dgbequ :md5sum: 1fed30e38d10a573adca3196ba837d4b :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - r: :type: doublereal :intent: output :dims: - MAX(1,m) - c: :type: doublereal :intent: output :dims: - n - rowcnd: :type: doublereal :intent: output - colcnd: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGBEQU computes row and column scalings intended to equilibrate an\n\ * M-by-N band matrix A and reduce its condition number. R returns the\n\ * row scale factors and C the column scale factors, chosen to try to\n\ * make the largest element in each row and column of the matrix B with\n\ * elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n\ *\n\ * R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n\ * number and BIGNUM = largest safe number. Use of these scaling\n\ * factors is not guaranteed to reduce the condition number of A but\n\ * works well in practice.\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\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * The band matrix A, stored in rows 1 to KL+KU+1. The j-th\n\ * column of A is stored in the j-th column of the array AB as\n\ * follows:\n\ * AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * R (output) DOUBLE PRECISION array, dimension (M)\n\ * If INFO = 0, or INFO > M, R contains the row scale factors\n\ * for A.\n\ *\n\ * C (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, C contains the column scale factors for A.\n\ *\n\ * ROWCND (output) DOUBLE PRECISION\n\ * If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n\ * smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n\ * AMAX is neither too large nor too small, it is not worth\n\ * scaling by R.\n\ *\n\ * COLCND (output) DOUBLE PRECISION\n\ * If INFO = 0, COLCND contains the ratio of the smallest\n\ * C(i) to the largest C(i). If COLCND >= 0.1, it is not\n\ * worth scaling by C.\n\ *\n\ * AMAX (output) DOUBLE PRECISION\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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, and i is\n\ * <= M: the i-th row of A is exactly zero\n\ * > M: the (i-M)-th column of A is exactly zero\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgeevx0000644000175000017500000002315212502223526016523 0ustar uwabamiuwabami--- :name: zgeevx :md5sum: c5b0634690cc9242af9ab759a937a099 :category: :subroutine :arguments: - balanc: :type: char :intent: input - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - w: :type: doublecomplex :intent: output :dims: - n - vl: :type: doublecomplex :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: doublecomplex :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - scale: :type: doublereal :intent: output :dims: - n - abnrm: :type: doublereal :intent: output - rconde: :type: doublereal :intent: output :dims: - n - rcondv: :type: doublereal :intent: output :dims: - n - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(lsame_(&sense,\"N\")||lsame_(&sense,\"E\")) ? 2*n : (lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? n*n+2*n : 0" - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " SUBROUTINE ZGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, WORK, LWORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGEEVX computes for an N-by-N complex nonsymmetric matrix A, the\n\ * eigenvalues and, optionally, the left and/or right eigenvectors.\n\ *\n\ * Optionally also, it computes a balancing transformation to improve\n\ * the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n\ * SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues\n\ * (RCONDE), and reciprocal condition numbers for the right\n\ * eigenvectors (RCONDV).\n\ *\n\ * The right eigenvector v(j) of A satisfies\n\ * A * v(j) = lambda(j) * v(j)\n\ * where lambda(j) is its eigenvalue.\n\ * The left eigenvector u(j) of A satisfies\n\ * u(j)**H * A = lambda(j) * u(j)**H\n\ * where u(j)**H denotes the conjugate transpose of u(j).\n\ *\n\ * The computed eigenvectors are normalized to have Euclidean norm\n\ * equal to 1 and largest component real.\n\ *\n\ * Balancing a matrix means permuting the rows and columns to make it\n\ * more nearly upper triangular, and applying a diagonal similarity\n\ * transformation D * A * D**(-1), where D is a diagonal matrix, to\n\ * make its rows and columns closer in norm and the condition numbers\n\ * of its eigenvalues and eigenvectors smaller. The computed\n\ * reciprocal condition numbers correspond to the balanced matrix.\n\ * Permuting rows and columns will not change the condition numbers\n\ * (in exact arithmetic) but diagonal scaling will. For further\n\ * explanation of balancing, see section 4.10.2 of the LAPACK\n\ * Users' Guide.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * BALANC (input) CHARACTER*1\n\ * Indicates how the input matrix should be diagonally scaled\n\ * and/or permuted to improve the conditioning of its\n\ * eigenvalues.\n\ * = 'N': Do not diagonally scale or permute;\n\ * = 'P': Perform permutations to make the matrix more nearly\n\ * upper triangular. Do not diagonally scale;\n\ * = 'S': Diagonally scale the matrix, ie. replace A by\n\ * D*A*D**(-1), where D is a diagonal matrix chosen\n\ * to make the rows and columns of A more equal in\n\ * norm. Do not permute;\n\ * = 'B': Both diagonally scale and permute A.\n\ *\n\ * Computed reciprocal condition numbers will be for the matrix\n\ * after balancing and/or permuting. Permuting does not change\n\ * condition numbers (in exact arithmetic), but balancing does.\n\ *\n\ * JOBVL (input) CHARACTER*1\n\ * = 'N': left eigenvectors of A are not computed;\n\ * = 'V': left eigenvectors of A are computed.\n\ * If SENSE = 'E' or 'B', JOBVL must = 'V'.\n\ *\n\ * JOBVR (input) CHARACTER*1\n\ * = 'N': right eigenvectors of A are not computed;\n\ * = 'V': right eigenvectors of A are computed.\n\ * If SENSE = 'E' or 'B', JOBVR must = 'V'.\n\ *\n\ * SENSE (input) CHARACTER*1\n\ * Determines which reciprocal condition numbers are computed.\n\ * = 'N': None are computed;\n\ * = 'E': Computed for eigenvalues only;\n\ * = 'V': Computed for right eigenvectors only;\n\ * = 'B': Computed for eigenvalues and right eigenvectors.\n\ *\n\ * If SENSE = 'E' or 'B', both left and right eigenvectors\n\ * must also be computed (JOBVL = 'V' and JOBVR = 'V').\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ * On exit, A has been overwritten. If JOBVL = 'V' or\n\ * JOBVR = 'V', A contains the Schur form of the balanced\n\ * version of the matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * W (output) COMPLEX*16 array, dimension (N)\n\ * W contains the computed eigenvalues.\n\ *\n\ * VL (output) COMPLEX*16 array, dimension (LDVL,N)\n\ * If JOBVL = 'V', the left eigenvectors u(j) are stored one\n\ * after another in the columns of VL, in the same order\n\ * as their eigenvalues.\n\ * If JOBVL = 'N', VL is not referenced.\n\ * u(j) = VL(:,j), the j-th column of VL.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the array VL. LDVL >= 1; if\n\ * JOBVL = 'V', LDVL >= N.\n\ *\n\ * VR (output) COMPLEX*16 array, dimension (LDVR,N)\n\ * If JOBVR = 'V', the right eigenvectors v(j) are stored one\n\ * after another in the columns of VR, in the same order\n\ * as their eigenvalues.\n\ * If JOBVR = 'N', VR is not referenced.\n\ * v(j) = VR(:,j), the j-th column of VR.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the array VR. LDVR >= 1; if\n\ * JOBVR = 'V', LDVR >= N.\n\ *\n\ * ILO (output) INTEGER\n\ * IHI (output) INTEGER\n\ * ILO and IHI are integer values determined when A was\n\ * balanced. The balanced A(i,j) = 0 if I > J and\n\ * J = 1,...,ILO-1 or I = IHI+1,...,N.\n\ *\n\ * SCALE (output) DOUBLE PRECISION array, dimension (N)\n\ * Details of the permutations and scaling factors applied\n\ * when balancing A. If P(j) is the index of the row and column\n\ * interchanged with row and column j, and D(j) is the scaling\n\ * factor applied to row and column j, then\n\ * SCALE(J) = P(J), for J = 1,...,ILO-1\n\ * = D(J), for J = ILO,...,IHI\n\ * = P(J) for J = IHI+1,...,N.\n\ * The order in which the interchanges are made is N to IHI+1,\n\ * then 1 to ILO-1.\n\ *\n\ * ABNRM (output) DOUBLE PRECISION\n\ * The one-norm of the balanced matrix (the maximum\n\ * of the sum of absolute values of elements of any column).\n\ *\n\ * RCONDE (output) DOUBLE PRECISION array, dimension (N)\n\ * RCONDE(j) is the reciprocal condition number of the j-th\n\ * eigenvalue.\n\ *\n\ * RCONDV (output) DOUBLE PRECISION array, dimension (N)\n\ * RCONDV(j) is the reciprocal condition number of the j-th\n\ * right eigenvector.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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. If SENSE = 'N' or 'E',\n\ * LWORK >= max(1,2*N), and if SENSE = 'V' or 'B',\n\ * LWORK >= N*N+2*N.\n\ * For good performance, LWORK must generally be larger.\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\ * RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\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 QR algorithm failed to compute all the\n\ * eigenvalues, and no eigenvectors or condition numbers\n\ * have been computed; elements 1:ILO-1 and i+1:N of W\n\ * contain eigenvalues which have converged.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlat2c0000644000175000017500000000515512502223526016415 0ustar uwabamiuwabami--- :name: zlat2c :md5sum: dcca8cca30b42aa080136a071f79dc3c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - sa: :type: complex :intent: output :dims: - ldsa - n - ldsa: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: ldsa: MAX(1,n) :fortran_help: " SUBROUTINE ZLAT2C( UPLO, N, A, LDA, SA, LDSA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAT2C converts a COMPLEX*16 triangular matrix, SA, to a COMPLEX\n\ * triangular matrix, A.\n\ *\n\ * RMAX is the overflow for the SINGLE PRECISION arithmetic\n\ * ZLAT2C checks that all the entries of A are between -RMAX and\n\ * RMAX. If not the convertion is aborted and a flag is raised.\n\ *\n\ * This is an auxiliary routine so there is no argument checking.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * N (input) INTEGER\n\ * The number of rows and columns of the matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the N-by-N triangular coefficient matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * SA (output) COMPLEX array, dimension (LDSA,N)\n\ * Only the UPLO part of SA is referenced. On exit, if INFO=0,\n\ * the N-by-N coefficient matrix SA; if INFO>0, the content of\n\ * the UPLO part of SA is unspecified.\n\ *\n\ * LDSA (input) INTEGER\n\ * The leading dimension of the array SA. LDSA >= max(1,M).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit.\n\ * = 1: an entry of the matrix A is greater than the SINGLE\n\ * PRECISION overflow threshold, in this case, the content\n\ * of the UPLO part of SA in exit is unspecified.\n\ *\n\ * =========\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n DOUBLE PRECISION RMAX\n LOGICAL UPPER\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC DBLE, DIMAG\n\ * ..\n\ * .. External Functions ..\n REAL SLAMCH\n LOGICAL LSAME\n EXTERNAL SLAMCH, LSAME\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dpbcon0000644000175000017500000000604512502223526016462 0ustar uwabamiuwabami--- :name: dpbcon :md5sum: 20d0a20dbd1b200d211eeeb871142b23 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPBCON estimates the reciprocal of the condition number (in the\n\ * 1-norm) of a real symmetric positive definite band matrix using the\n\ * Cholesky factorization A = U**T*U or A = L*L**T computed by DPBTRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangular factor stored in AB;\n\ * = 'L': Lower triangular factor stored in AB.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T of the band matrix A, stored in the\n\ * first KD+1 rows of the array. The j-th column of U or L is\n\ * stored in the j-th column of the array AB as follows:\n\ * if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * ANORM (input) DOUBLE PRECISION\n\ * The 1-norm (or infinity-norm) of the symmetric band matrix A.\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n\ * estimate of the 1-norm of inv(A) computed in this routine.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sptsvx0000644000175000017500000001617612502223526016572 0ustar uwabamiuwabami--- :name: sptsvx :md5sum: 25937351c61902c902d4672751abaf55 :category: :subroutine :arguments: - fact: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: real :intent: input :dims: - n-1 - df: :type: real :intent: input/output :dims: - n - ef: :type: real :intent: input/output :dims: - n-1 - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE SPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPTSVX uses the factorization A = L*D*L**T to compute the solution\n\ * to a real system of linear equations A*X = B, where A is an N-by-N\n\ * symmetric positive definite tridiagonal matrix and X and B are\n\ * N-by-NRHS matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'N', the matrix A is factored as A = L*D*L**T, where L\n\ * is a unit lower bidiagonal matrix and D is diagonal. The\n\ * factorization can also be regarded as having the form\n\ * A = U**T*D*U.\n\ *\n\ * 2. If the leading i-by-i principal minor is not positive definite,\n\ * then the routine returns with INFO = i. Otherwise, the factored\n\ * form of A is used to estimate the condition number of the matrix\n\ * A. If the reciprocal of the condition number is less than machine\n\ * precision, INFO = N+1 is returned as a warning, but the routine\n\ * still goes on to solve for X and compute error bounds as\n\ * described below.\n\ *\n\ * 3. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 4. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of A has been\n\ * supplied on entry.\n\ * = 'F': On entry, DF and EF contain the factored form of A.\n\ * D, E, DF, and EF will not be modified.\n\ * = 'N': The matrix A will be copied to DF and EF and\n\ * factored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The n diagonal elements of the tridiagonal matrix A.\n\ *\n\ * E (input) REAL array, dimension (N-1)\n\ * The (n-1) subdiagonal elements of the tridiagonal matrix A.\n\ *\n\ * DF (input or output) REAL array, dimension (N)\n\ * If FACT = 'F', then DF is an input argument and on entry\n\ * contains the n diagonal elements of the diagonal matrix D\n\ * from the L*D*L**T factorization of A.\n\ * If FACT = 'N', then DF is an output argument and on exit\n\ * contains the n diagonal elements of the diagonal matrix D\n\ * from the L*D*L**T factorization of A.\n\ *\n\ * EF (input or output) REAL array, dimension (N-1)\n\ * If FACT = 'F', then EF is an input argument and on entry\n\ * contains the (n-1) subdiagonal elements of the unit\n\ * bidiagonal factor L from the L*D*L**T factorization of A.\n\ * If FACT = 'N', then EF is an output argument and on exit\n\ * contains the (n-1) subdiagonal elements of the unit\n\ * bidiagonal factor L from the L*D*L**T factorization of A.\n\ *\n\ * B (input) REAL array, dimension (LDB,NRHS)\n\ * The N-by-NRHS right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) REAL array, dimension (LDX,NRHS)\n\ * If INFO = 0 of INFO = N+1, the N-by-NRHS solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * The reciprocal condition number of the matrix A. If RCOND\n\ * is less than the machine precision (in particular, if\n\ * RCOND = 0), the matrix is singular to working precision.\n\ * This condition is indicated by a return code of INFO > 0.\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j).\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in any\n\ * element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) REAL array, dimension (2*N)\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, and i is\n\ * <= N: the leading minor of order i of A is\n\ * not positive definite, so the factorization\n\ * could not be completed, and the solution has not\n\ * been computed. RCOND = 0 is returned.\n\ * = N+1: U is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlaruv0000644000175000017500000000346212502223526016512 0ustar uwabamiuwabami--- :name: dlaruv :md5sum: 5f925de019c10838c63b3fb8bb460f32 :category: :subroutine :arguments: - iseed: :type: integer :intent: input/output :dims: - "4" - n: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - MAX(1,n) :substitutions: {} :fortran_help: " SUBROUTINE DLARUV( ISEED, N, X )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLARUV returns a vector of n random real numbers from a uniform (0,1)\n\ * distribution (n <= 128).\n\ *\n\ * This is an auxiliary routine called by DLARNV and ZLARNV.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ISEED (input/output) INTEGER array, dimension (4)\n\ * On entry, the seed of the random number generator; the array\n\ * elements must be between 0 and 4095, and ISEED(4) must be\n\ * odd.\n\ * On exit, the seed is updated.\n\ *\n\ * N (input) INTEGER\n\ * The number of random numbers to be generated. N <= 128.\n\ *\n\ * X (output) DOUBLE PRECISION array, dimension (N)\n\ * The generated random numbers.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * This routine uses a multiplicative congruential method with modulus\n\ * 2**48 and multiplier 33952834046453 (see G.S.Fishman,\n\ * 'Multiplicative congruential random number generators with modulus\n\ * 2**b: an exhaustive analysis for b = 32 and a partial analysis for\n\ * b = 48', Math. Comp. 189, pp 331-344, 1990).\n\ *\n\ * 48-bit integers are stored in 4 integer array elements with 12 bits\n\ * per element. Hence the routine is portable across machines with\n\ * integers of 32 bits or more.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slascl20000644000175000017500000000275412502223526016563 0ustar uwabamiuwabami--- :name: slascl2 :md5sum: 6db1e378bf1025bf179649e638ef1f6e :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - m - x: :type: real :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE SLASCL2 ( M, N, D, X, LDX )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLASCL2 performs a diagonal scaling on a vector:\n\ * x <-- D * x\n\ * where the diagonal matrix D is stored as a vector.\n\ *\n\ * Eventually to be replaced by BLAS_sge_diag_scale in the new BLAS\n\ * standard.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of D and X. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of D and X. N >= 0.\n\ *\n\ * D (input) REAL array, length M\n\ * Diagonal matrix D, stored as a vector of length M.\n\ *\n\ * X (input/output) REAL array, dimension (LDX,N)\n\ * On entry, the vector X to be scaled by D.\n\ * On exit, the scaled vector.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the vector X. LDX >= 0.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cggrqf0000644000175000017500000001551312502223525016465 0ustar uwabamiuwabami--- :name: cggrqf :md5sum: f971670b151a75a72622c3d66873201a :category: :subroutine :arguments: - m: :type: integer :intent: input - p: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - taua: :type: complex :intent: output :dims: - MIN(m,n) - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - taub: :type: complex :intent: output :dims: - MIN(p,n) - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(MAX(n,m),p) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGGRQF computes a generalized RQ factorization of an M-by-N matrix A\n\ * and a P-by-N matrix B:\n\ *\n\ * A = R*Q, B = Z*T*Q,\n\ *\n\ * where Q is an N-by-N unitary matrix, Z is a P-by-P unitary\n\ * matrix, and R and T assume one of the forms:\n\ *\n\ * if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N,\n\ * N-M M ( R21 ) N\n\ * N\n\ *\n\ * where R12 or R21 is upper triangular, and\n\ *\n\ * if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P,\n\ * ( 0 ) P-N P N-P\n\ * N\n\ *\n\ * where T11 is upper triangular.\n\ *\n\ * In particular, if B is square and nonsingular, the GRQ factorization\n\ * of A and B implicitly gives the RQ factorization of A*inv(B):\n\ *\n\ * A*inv(B) = (R*inv(T))*Z'\n\ *\n\ * where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n\ * conjugate transpose of the matrix Z.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A. M >= 0.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows of the matrix B. P >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, if M <= N, the upper triangle of the subarray\n\ * A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;\n\ * if M > N, the elements on and above the (M-N)-th subdiagonal\n\ * contain the M-by-N upper trapezoidal matrix R; the remaining\n\ * elements, with the array TAUA, represent the unitary\n\ * matrix Q as a product of elementary reflectors (see Further\n\ * Details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAUA (output) COMPLEX array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the unitary matrix Q (see Further Details).\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,N)\n\ * On entry, the P-by-N matrix B.\n\ * On exit, the elements on and above the diagonal of the array\n\ * contain the min(P,N)-by-N upper trapezoidal matrix T (T is\n\ * upper triangular if P >= N); the elements below the diagonal,\n\ * with the array TAUB, represent the unitary matrix Z as a\n\ * product of elementary reflectors (see Further Details).\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,P).\n\ *\n\ * TAUB (output) COMPLEX array, dimension (min(P,N))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the unitary matrix Z (see Further Details).\n\ *\n\ * WORK (workspace/output) COMPLEX 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,N,M,P).\n\ * For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n\ * where NB1 is the optimal blocksize for the RQ factorization\n\ * of an M-by-N matrix, NB2 is the optimal blocksize for the\n\ * QR factorization of a P-by-N matrix, and NB3 is the optimal\n\ * blocksize for a call of CUNMRQ.\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(1) H(2) . . . H(k), where k = min(m,n).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - taua * v * v'\n\ *\n\ * where taua is a complex scalar, and v is a complex vector with\n\ * v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n\ * A(m-k+i,1:n-k+i-1), and taua in TAUA(i).\n\ * To form Q explicitly, use LAPACK subroutine CUNGRQ.\n\ * To use Q to update another matrix, use LAPACK subroutine CUNMRQ.\n\ *\n\ * The matrix Z is represented as a product of elementary reflectors\n\ *\n\ * Z = H(1) H(2) . . . H(k), where k = min(p,n).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - taub * v * v'\n\ *\n\ * where taub is a complex scalar, and v is a complex vector with\n\ * v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),\n\ * and taub in TAUB(i).\n\ * To form Z explicitly, use LAPACK subroutine CUNGQR.\n\ * To use Z to update another matrix, use LAPACK subroutine CUNMQR.\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CGEQRF, CGERQF, CUNMRQ, XERBLA\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV \n EXTERNAL ILAENV\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC INT, MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/clarfg0000644000175000017500000000375112502223525016453 0ustar uwabamiuwabami--- :name: clarfg :md5sum: b7684e6877d9b4630730f6ad023dcaf1 :category: :subroutine :arguments: - n: :type: integer :intent: input - alpha: :type: complex :intent: input/output - x: :type: complex :intent: input/output :dims: - 1+(n-2)*abs(incx) - incx: :type: integer :intent: input - tau: :type: complex :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CLARFG( N, ALPHA, X, INCX, TAU )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLARFG generates a complex elementary reflector H of order n, such\n\ * that\n\ *\n\ * H' * ( alpha ) = ( beta ), H' * H = I.\n\ * ( x ) ( 0 )\n\ *\n\ * where alpha and beta are scalars, with beta real, and x is an\n\ * (n-1)-element complex vector. H is represented in the form\n\ *\n\ * H = I - tau * ( 1 ) * ( 1 v' ) ,\n\ * ( v )\n\ *\n\ * where tau is a complex scalar and v is a complex (n-1)-element\n\ * vector. Note that H is not hermitian.\n\ *\n\ * If the elements of x are all zero and alpha is real, then tau = 0\n\ * and H is taken to be the unit matrix.\n\ *\n\ * Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 .\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the elementary reflector.\n\ *\n\ * ALPHA (input/output) COMPLEX\n\ * On entry, the value alpha.\n\ * On exit, it is overwritten with the value beta.\n\ *\n\ * X (input/output) COMPLEX array, dimension\n\ * (1+(N-2)*abs(INCX))\n\ * On entry, the vector x.\n\ * On exit, it is overwritten with the vector v.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between elements of X. INCX > 0.\n\ *\n\ * TAU (output) COMPLEX\n\ * The value tau.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dtbrfs0000644000175000017500000001201712502223526016475 0ustar uwabamiuwabami--- :name: dtbrfs :md5sum: 2d7dad49f21789544cccf53137cb26b4 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTBRFS provides error bounds and backward error estimates for the\n\ * solution to a system of linear equations with a triangular band\n\ * coefficient matrix.\n\ *\n\ * The solution matrix X must be computed by DTBTRS or some other\n\ * means before entering this routine. DTBRFS does not do iterative\n\ * refinement because doing so cannot improve the backward error.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose = Transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals or subdiagonals of the\n\ * triangular band matrix A. KD >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * The upper or lower triangular band matrix A, stored in the\n\ * first kd+1 rows of the array. The j-th column of A is stored\n\ * in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ * If DIAG = 'U', the diagonal elements of A are not referenced\n\ * and are assumed to be 1.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * The solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slartgp0000644000175000017500000000322412502223526016665 0ustar uwabamiuwabami--- :name: slartgp :md5sum: 88a79da91a90b35ec8e235764f012f69 :category: :subroutine :arguments: - f: :type: real :intent: input - g: :type: real :intent: input - cs: :type: real :intent: output - sn: :type: real :intent: output - r: :type: real :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLARTGP( F, G, CS, SN, R )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLARTGP generates a plane rotation so that\n\ *\n\ * [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1.\n\ * [ -SN CS ] [ G ] [ 0 ]\n\ *\n\ * This is a slower, more accurate version of the Level 1 BLAS routine SROTG,\n\ * with the following other differences:\n\ * F and G are unchanged on return.\n\ * If G=0, then CS=(+/-)1 and SN=0.\n\ * If F=0 and (G .ne. 0), then CS=0 and SN=(+/-)1.\n\ *\n\ * The sign is chosen so that R >= 0.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * F (input) REAL\n\ * The first component of vector to be rotated.\n\ *\n\ * G (input) REAL\n\ * The second component of vector to be rotated.\n\ *\n\ * CS (output) REAL\n\ * The cosine of the rotation.\n\ *\n\ * SN (output) REAL\n\ * The sine of the rotation.\n\ *\n\ * R (output) REAL\n\ * The nonzero component of the rotated vector.\n\ *\n\ * This version has a few statements commented out for thread safety\n\ * (machine parameters are computed on each entry). 10 feb 03, SJH.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slagts0000644000175000017500000001130112502223526016501 0ustar uwabamiuwabami--- :name: slagts :md5sum: 6a4561511123cd1f15a6d9c4867535a3 :category: :subroutine :arguments: - job: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - n - b: :type: real :intent: input :dims: - n-1 - c: :type: real :intent: input :dims: - n-1 - d: :type: real :intent: input :dims: - n-2 - in: :type: integer :intent: input :dims: - n - y: :type: real :intent: input/output :dims: - n - tol: :type: real :intent: input/output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAGTS may be used to solve one of the systems of equations\n\ *\n\ * (T - lambda*I)*x = y or (T - lambda*I)'*x = y,\n\ *\n\ * where T is an n by n tridiagonal matrix, for x, following the\n\ * factorization of (T - lambda*I) as\n\ *\n\ * (T - lambda*I) = P*L*U ,\n\ *\n\ * by routine SLAGTF. The choice of equation to be solved is\n\ * controlled by the argument JOB, and in each case there is an option\n\ * to perturb zero or very small diagonal elements of U, this option\n\ * being intended for use in applications such as inverse iteration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) INTEGER\n\ * Specifies the job to be performed by SLAGTS as follows:\n\ * = 1: The equations (T - lambda*I)x = y are to be solved,\n\ * but diagonal elements of U are not to be perturbed.\n\ * = -1: The equations (T - lambda*I)x = y are to be solved\n\ * and, if overflow would otherwise occur, the diagonal\n\ * elements of U are to be perturbed. See argument TOL\n\ * below.\n\ * = 2: The equations (T - lambda*I)'x = y are to be solved,\n\ * but diagonal elements of U are not to be perturbed.\n\ * = -2: The equations (T - lambda*I)'x = y are to be solved\n\ * and, if overflow would otherwise occur, the diagonal\n\ * elements of U are to be perturbed. See argument TOL\n\ * below.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix T.\n\ *\n\ * A (input) REAL array, dimension (N)\n\ * On entry, A must contain the diagonal elements of U as\n\ * returned from SLAGTF.\n\ *\n\ * B (input) REAL array, dimension (N-1)\n\ * On entry, B must contain the first super-diagonal elements of\n\ * U as returned from SLAGTF.\n\ *\n\ * C (input) REAL array, dimension (N-1)\n\ * On entry, C must contain the sub-diagonal elements of L as\n\ * returned from SLAGTF.\n\ *\n\ * D (input) REAL array, dimension (N-2)\n\ * On entry, D must contain the second super-diagonal elements\n\ * of U as returned from SLAGTF.\n\ *\n\ * IN (input) INTEGER array, dimension (N)\n\ * On entry, IN must contain details of the matrix P as returned\n\ * from SLAGTF.\n\ *\n\ * Y (input/output) REAL array, dimension (N)\n\ * On entry, the right hand side vector y.\n\ * On exit, Y is overwritten by the solution vector x.\n\ *\n\ * TOL (input/output) REAL\n\ * On entry, with JOB .lt. 0, TOL should be the minimum\n\ * perturbation to be made to very small diagonal elements of U.\n\ * TOL should normally be chosen as about eps*norm(U), where eps\n\ * is the relative machine precision, but if TOL is supplied as\n\ * non-positive, then it is reset to eps*max( abs( u(i,j) ) ).\n\ * If JOB .gt. 0 then TOL is not referenced.\n\ *\n\ * On exit, TOL is changed as described above, only if TOL is\n\ * non-positive on entry. Otherwise TOL is unchanged.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0 : successful exit\n\ * .lt. 0: if INFO = -i, the i-th argument had an illegal value\n\ * .gt. 0: overflow would occur when computing the INFO(th)\n\ * element of the solution vector x. This can only occur\n\ * when JOB is supplied as positive and either means\n\ * that a diagonal element of U is very small, or that\n\ * the elements of the right-hand side vector y are very\n\ * large.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlahr20000644000175000017500000001163012502223526016365 0ustar uwabamiuwabami--- :name: dlahr2 :md5sum: ae8b6735a5e45955e75ccfa5fab032b6 :category: :subroutine :arguments: - n: :type: integer :intent: input - k: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n-k+1 - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - MAX(1,nb) - t: :type: doublereal :intent: output :dims: - ldt - MAX(1,nb) - ldt: :type: integer :intent: input - y: :type: doublereal :intent: output :dims: - ldy - MAX(1,nb) - ldy: :type: integer :intent: input :substitutions: ldy: n ldt: nb :fortran_help: " SUBROUTINE DLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1)\n\ * matrix A so that elements below the k-th subdiagonal are zero. The\n\ * reduction is performed by an orthogonal similarity transformation\n\ * Q' * A * Q. The routine returns the matrices V and T which determine\n\ * Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n\ *\n\ * This is an auxiliary routine called by DGEHRD.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A.\n\ *\n\ * K (input) INTEGER\n\ * The offset for the reduction. Elements below the k-th\n\ * subdiagonal in the first NB columns are reduced to zero.\n\ * K < N.\n\ *\n\ * NB (input) INTEGER\n\ * The number of columns to be reduced.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N-K+1)\n\ * On entry, the n-by-(n-k+1) general matrix A.\n\ * On exit, the elements on and above the k-th subdiagonal in\n\ * the first NB columns are overwritten with the corresponding\n\ * elements of the reduced matrix; the elements below the k-th\n\ * subdiagonal, with the array TAU, represent the matrix Q as a\n\ * product of elementary reflectors. The other columns of A are\n\ * unchanged. See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * TAU (output) DOUBLE PRECISION array, dimension (NB)\n\ * The scalar factors of the elementary reflectors. See Further\n\ * Details.\n\ *\n\ * T (output) DOUBLE PRECISION array, dimension (LDT,NB)\n\ * The upper triangular matrix T.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= NB.\n\ *\n\ * Y (output) DOUBLE PRECISION array, dimension (LDY,NB)\n\ * The n-by-nb matrix Y.\n\ *\n\ * LDY (input) INTEGER\n\ * The leading dimension of the array Y. LDY >= N.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The matrix Q is represented as a product of nb elementary reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(nb).\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+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n\ * A(i+k+1:n,i), and tau in TAU(i).\n\ *\n\ * The elements of the vectors v together form the (n-k+1)-by-nb matrix\n\ * V which is needed, with T and Y, to apply the transformation to the\n\ * unreduced part of the matrix, using an update of the form:\n\ * A := (I - V*T*V') * (A - Y*V').\n\ *\n\ * The contents of A on exit are illustrated by the following example\n\ * with n = 7, k = 3 and nb = 2:\n\ *\n\ * ( a a a a a )\n\ * ( a a a a a )\n\ * ( a a a a a )\n\ * ( h h a a a )\n\ * ( v1 h a a a )\n\ * ( v1 v2 a a a )\n\ * ( v1 v2 a a a )\n\ *\n\ * where a denotes an element of the original matrix A, h denotes a\n\ * modified element of the upper Hessenberg matrix H, and vi denotes an\n\ * element of the vector defining H(i).\n\ *\n\ * This subroutine is a slight modification of LAPACK-3.0's DLAHRD\n\ * incorporating improvements proposed by Quintana-Orti and Van de\n\ * Gejin. Note that the entries of A(1:K,2:NB) differ from those\n\ * returned by the original LAPACK-3.0's DLAHRD routine. (This\n\ * subroutine is not backward compatible with LAPACK-3.0's DLAHRD.)\n\ *\n\ * References\n\ * ==========\n\ *\n\ * Gregorio Quintana-Orti and Robert van de Geijn, \"Improving the\n\ * performance of reduction to Hessenberg form,\" ACM Transactions on\n\ * Mathematical Software, 32(2):180-194, June 2006.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlarrd0000644000175000017500000002572312502223526016471 0ustar uwabamiuwabami--- :name: dlarrd :md5sum: 1c6e49f591c6b2ec7416a44a5da7f9c7 :category: :subroutine :arguments: - range: :type: char :intent: input - order: :type: char :intent: input - n: :type: integer :intent: input - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - gers: :type: doublereal :intent: input :dims: - 2*n - reltol: :type: doublereal :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublereal :intent: input :dims: - n-1 - e2: :type: doublereal :intent: input :dims: - n-1 - pivmin: :type: doublereal :intent: input - nsplit: :type: integer :intent: input - isplit: :type: integer :intent: input :dims: - n - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - werr: :type: doublereal :intent: output :dims: - n - wl: :type: doublereal :intent: output - wu: :type: doublereal :intent: output - iblock: :type: integer :intent: output :dims: - n - indexw: :type: integer :intent: output :dims: - n - work: :type: doublereal :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLARRD( RANGE, ORDER, N, VL, VU, IL, IU, GERS, RELTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT, M, W, WERR, WL, WU, IBLOCK, INDEXW, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLARRD computes the eigenvalues of a symmetric tridiagonal\n\ * matrix T to suitable accuracy. This is an auxiliary code to be\n\ * called from DSTEMR.\n\ * The user may ask for all eigenvalues, all eigenvalues\n\ * in the half-open interval (VL, VU], or the IL-th through IU-th\n\ * eigenvalues.\n\ *\n\ * To avoid overflow, the matrix must be scaled so that its\n\ * largest element is no greater than overflow**(1/2) *\n\ * underflow**(1/4) in absolute value, and for greatest\n\ * accuracy, it should not be much smaller than that.\n\ *\n\ * See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n\ * Matrix\", Report CS41, Computer Science Dept., Stanford\n\ * University, July 21, 1966.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': (\"All\") all eigenvalues will be found.\n\ * = 'V': (\"Value\") all eigenvalues in the half-open interval\n\ * (VL, VU] will be found.\n\ * = 'I': (\"Index\") the IL-th through IU-th eigenvalues (of the\n\ * entire matrix) will be found.\n\ *\n\ * ORDER (input) CHARACTER*1\n\ * = 'B': (\"By Block\") the eigenvalues will be grouped by\n\ * split-off block (see IBLOCK, ISPLIT) and\n\ * ordered from smallest to largest within\n\ * the block.\n\ * = 'E': (\"Entire matrix\")\n\ * the eigenvalues for the entire matrix\n\ * will be ordered from smallest to\n\ * largest.\n\ *\n\ * N (input) INTEGER\n\ * The order of the tridiagonal matrix T. N >= 0.\n\ *\n\ * VL (input) DOUBLE PRECISION\n\ * VU (input) DOUBLE PRECISION\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. Eigenvalues less than or equal\n\ * to VL, or greater than VU, will not be returned. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * GERS (input) DOUBLE PRECISION array, dimension (2*N)\n\ * The N Gerschgorin intervals (the i-th Gerschgorin interval\n\ * is (GERS(2*i-1), GERS(2*i)).\n\ *\n\ * RELTOL (input) DOUBLE PRECISION\n\ * The minimum relative width of an interval. When an interval\n\ * is narrower than RELTOL times the larger (in\n\ * magnitude) endpoint, then it is considered to be\n\ * sufficiently small, i.e., converged. Note: this should\n\ * always be at least radix*machine epsilon.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The n diagonal elements of the tridiagonal matrix T.\n\ *\n\ * E (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) off-diagonal elements of the tridiagonal matrix T.\n\ *\n\ * E2 (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) squared off-diagonal elements of the tridiagonal matrix T.\n\ *\n\ * PIVMIN (input) DOUBLE PRECISION\n\ * The minimum pivot allowed in the Sturm sequence for T.\n\ *\n\ * NSPLIT (input) INTEGER\n\ * The number of diagonal blocks in the matrix T.\n\ * 1 <= NSPLIT <= N.\n\ *\n\ * ISPLIT (input) INTEGER array, dimension (N)\n\ * The splitting points, at which T breaks up into submatrices.\n\ * The first submatrix consists of rows/columns 1 to ISPLIT(1),\n\ * the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n\ * etc., and the NSPLIT-th consists of rows/columns\n\ * ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n\ * (Only the first NSPLIT elements will actually be used, but\n\ * since the user cannot know a priori what value NSPLIT will\n\ * have, N words must be reserved for ISPLIT.)\n\ *\n\ * M (output) INTEGER\n\ * The actual number of eigenvalues found. 0 <= M <= N.\n\ * (See also the description of INFO=2,3.)\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * On exit, the first M elements of W will contain the\n\ * eigenvalue approximations. DLARRD computes an interval\n\ * I_j = (a_j, b_j] that includes eigenvalue j. The eigenvalue\n\ * approximation is given as the interval midpoint\n\ * W(j)= ( a_j + b_j)/2. The corresponding error is bounded by\n\ * WERR(j) = abs( a_j - b_j)/2\n\ *\n\ * WERR (output) DOUBLE PRECISION array, dimension (N)\n\ * The error bound on the corresponding eigenvalue approximation\n\ * in W.\n\ *\n\ * WL (output) DOUBLE PRECISION\n\ * WU (output) DOUBLE PRECISION\n\ * The interval (WL, WU] contains all the wanted eigenvalues.\n\ * If RANGE='V', then WL=VL and WU=VU.\n\ * If RANGE='A', then WL and WU are the global Gerschgorin bounds\n\ * on the spectrum.\n\ * If RANGE='I', then WL and WU are computed by DLAEBZ from the\n\ * index range specified.\n\ *\n\ * IBLOCK (output) INTEGER array, dimension (N)\n\ * At each row/column j where E(j) is zero or small, the\n\ * matrix T is considered to split into a block diagonal\n\ * matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which\n\ * block (from 1 to the number of blocks) the eigenvalue W(i)\n\ * belongs. (DLARRD may use the remaining N-M elements as\n\ * workspace.)\n\ *\n\ * INDEXW (output) INTEGER array, dimension (N)\n\ * The indices of the eigenvalues within each block (submatrix);\n\ * for example, INDEXW(i)= j and IBLOCK(i)=k imply that the\n\ * i-th eigenvalue W(i) is the j-th eigenvalue in block k.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (3*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: some or all of the eigenvalues failed to converge or\n\ * were not computed:\n\ * =1 or 3: Bisection failed to converge for some\n\ * eigenvalues; these eigenvalues are flagged by a\n\ * negative block number. The effect is that the\n\ * eigenvalues may not be as accurate as the\n\ * absolute and relative tolerances. This is\n\ * generally caused by unexpectedly inaccurate\n\ * arithmetic.\n\ * =2 or 3: RANGE='I' only: Not all of the eigenvalues\n\ * IL:IU were found.\n\ * Effect: M < IU+1-IL\n\ * Cause: non-monotonic arithmetic, causing the\n\ * Sturm sequence to be non-monotonic.\n\ * Cure: recalculate, using RANGE='A', and pick\n\ * out eigenvalues IL:IU. In some cases,\n\ * increasing the PARAMETER \"FUDGE\" may\n\ * make things work.\n\ * = 4: RANGE='I', and the Gershgorin interval\n\ * initially used was too small. No eigenvalues\n\ * were computed.\n\ * Probable cause: your machine has sloppy\n\ * floating-point arithmetic.\n\ * Cure: Increase the PARAMETER \"FUDGE\",\n\ * recompile, and try again.\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * FUDGE DOUBLE PRECISION, default = 2\n\ * A \"fudge factor\" to widen the Gershgorin intervals. Ideally,\n\ * a value of 1 should work, but on machines with sloppy\n\ * arithmetic, this needs to be larger. The default for\n\ * publicly released versions should be large enough to handle\n\ * the worst machine around. Note that this has no effect\n\ * on accuracy of the solution.\n\ *\n\ * Based on contributions by\n\ * W. Kahan, University of California, Berkeley, USA\n\ * Beresford Parlett, University of California, Berkeley, USA\n\ * Jim Demmel, University of California, Berkeley, USA\n\ * Inderjit Dhillon, University of Texas, Austin, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, University of California, Berkeley, USA\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clag2z0000644000175000017500000000351612502223525016376 0ustar uwabamiuwabami--- :name: clag2z :md5sum: 46933ce5b4f1eadd7bc7106884919faf :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - sa: :type: complex :intent: input :dims: - ldsa - n - ldsa: :type: integer :intent: input - a: :type: doublecomplex :intent: output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: lda: MAX(1,m) :fortran_help: " SUBROUTINE CLAG2Z( M, N, SA, LDSA, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAG2Z converts a COMPLEX matrix, SA, to a COMPLEX*16 matrix, A.\n\ *\n\ * Note that while it is possible to overflow while converting\n\ * from double to single, it is not possible to overflow when\n\ * converting from single to double.\n\ *\n\ * This is an auxiliary routine so there is no argument checking.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of lines of the matrix A. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix A. N >= 0.\n\ *\n\ * SA (input) COMPLEX array, dimension (LDSA,N)\n\ * On entry, the M-by-N coefficient matrix SA.\n\ *\n\ * LDSA (input) INTEGER\n\ * The leading dimension of the array SA. LDSA >= max(1,M).\n\ *\n\ * A (output) COMPLEX*16 array, dimension (LDA,N)\n\ * On exit, the M-by-N coefficient matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * =========\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlatzm0000644000175000017500000000724612502223526016514 0ustar uwabamiuwabami--- :name: dlatzm :md5sum: 93a8893a5409108190967bd55dcd6d6d :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - v: :type: doublereal :intent: input :dims: - 1 + (m-1)*abs(incv) - incv: :type: integer :intent: input - tau: :type: doublereal :intent: input - c1: :type: doublereal :intent: input/output :dims: - "lsame_(&side,\"L\") ? ldc : lsame_(&side,\"R\") ? m : 0" - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? 1 : 0" - c2: :type: doublereal :intent: input/output :dims: - ldc - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? n-1 : 0" - ldc: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " SUBROUTINE DLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This routine is deprecated and has been replaced by routine DORMRZ.\n\ *\n\ * DLATZM applies a Householder matrix generated by DTZRQF to a matrix.\n\ *\n\ * Let P = I - tau*u*u', u = ( 1 ),\n\ * ( v )\n\ * where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if\n\ * SIDE = 'R'.\n\ *\n\ * If SIDE equals 'L', let\n\ * C = [ C1 ] 1\n\ * [ C2 ] m-1\n\ * n\n\ * Then C is overwritten by P*C.\n\ *\n\ * If SIDE equals 'R', let\n\ * C = [ C1, C2 ] m\n\ * 1 n-1\n\ * Then C is overwritten by C*P.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': form P * C\n\ * = 'R': form C * P\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C.\n\ *\n\ * V (input) DOUBLE PRECISION array, dimension\n\ * (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n\ * (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n\ * The vector v in the representation of P. V is not used\n\ * if TAU = 0.\n\ *\n\ * INCV (input) INTEGER\n\ * The increment between elements of v. INCV <> 0\n\ *\n\ * TAU (input) DOUBLE PRECISION\n\ * The value tau in the representation of P.\n\ *\n\ * C1 (input/output) DOUBLE PRECISION array, dimension\n\ * (LDC,N) if SIDE = 'L'\n\ * (M,1) if SIDE = 'R'\n\ * On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1\n\ * if SIDE = 'R'.\n\ *\n\ * On exit, the first row of P*C if SIDE = 'L', or the first\n\ * column of C*P if SIDE = 'R'.\n\ *\n\ * C2 (input/output) DOUBLE PRECISION array, dimension\n\ * (LDC, N) if SIDE = 'L'\n\ * (LDC, N-1) if SIDE = 'R'\n\ * On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the\n\ * m x (n - 1) matrix C2 if SIDE = 'R'.\n\ *\n\ * On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P\n\ * if SIDE = 'R'.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the arrays C1 and C2. LDC >= (1,M).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension\n\ * (N) if SIDE = 'L'\n\ * (M) if SIDE = 'R'\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/spbtrs0000644000175000017500000000606212502223526016531 0ustar uwabamiuwabami--- :name: spbtrs :md5sum: 5c0eafb2b3376474927b22c92ecdf413 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPBTRS solves a system of linear equations A*X = B with a symmetric\n\ * positive definite band matrix A using the Cholesky factorization\n\ * A = U**T*U or A = L*L**T computed by SPBTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangular factor stored in AB;\n\ * = 'L': Lower triangular factor stored in AB.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AB (input) REAL array, dimension (LDAB,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T of the band matrix A, stored in the\n\ * first KD+1 rows of the array. The j-th column of U or L is\n\ * stored in the j-th column of the array AB as follows:\n\ * if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL UPPER\n INTEGER J\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL STBSV, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dsysvx0000644000175000017500000002356312502223526016561 0ustar uwabamiuwabami--- :name: dsysvx :md5sum: 6486f4357d9e46f47f6b6fad0f47fd94 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE DSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSYSVX uses the diagonal pivoting factorization to compute the\n\ * solution to a real system of linear equations A * X = B,\n\ * where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n\ * matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'N', the diagonal pivoting method is used to factor A.\n\ * The form of the factorization is\n\ * A = U * D * U**T, if UPLO = 'U', or\n\ * A = L * D * L**T, if UPLO = 'L',\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, and D is symmetric and block diagonal with\n\ * 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\ * 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n\ * returns with INFO = i. Otherwise, the factored form of A is used\n\ * to estimate the condition number of the matrix A. If the\n\ * reciprocal of the condition number is less than machine precision,\n\ * INFO = N+1 is returned as a warning, but the routine still goes on\n\ * to solve for X and compute error bounds as described below.\n\ *\n\ * 3. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 4. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of A has been\n\ * supplied on entry.\n\ * = 'F': On entry, AF and IPIV contain the factored form of\n\ * A. AF and IPIV will not be modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular part\n\ * of the matrix A, and the strictly lower triangular part of A\n\ * is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of A contains the lower triangular part of\n\ * the matrix A, and the strictly upper triangular part of A is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N)\n\ * If FACT = 'F', then AF is an input argument and on entry\n\ * contains the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L from the factorization\n\ * A = U*D*U**T or A = L*D*L**T as computed by DSYTRF.\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L from the factorization\n\ * A = U*D*U**T or A = L*D*L**T.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains details of the interchanges and the block structure\n\ * of D, as determined by DSYTRF.\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains details of the interchanges and the block structure\n\ * of D, as determined by DSYTRF.\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * The N-by-NRHS right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A. If RCOND is less than the machine precision (in\n\ * particular, if RCOND = 0), the matrix is singular to working\n\ * precision. This condition is indicated by a return code of\n\ * INFO > 0.\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\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 length of WORK. LWORK >= max(1,3*N), and for best\n\ * performance, when FACT = 'N', LWORK >= max(1,3*N,N*NB), where\n\ * NB is the optimal blocksize for DSYTRF.\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\ * IWORK (workspace) INTEGER array, dimension (N)\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, and i is\n\ * <= N: D(i,i) is exactly zero. The factorization\n\ * has been completed but the factor D is exactly\n\ * singular, so the solution and error bounds could\n\ * not be computed. RCOND = 0 is returned.\n\ * = N+1: D is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clar1v0000644000175000017500000001450612502223525016405 0ustar uwabamiuwabami--- :name: clar1v :md5sum: 476c7fc59e63411f4a380b0ca17e4c25 :category: :subroutine :arguments: - n: :type: integer :intent: input - b1: :type: integer :intent: input - bn: :type: integer :intent: input - lambda: :type: real :intent: input - d: :type: real :intent: input :dims: - n - l: :type: real :intent: input :dims: - n-1 - ld: :type: real :intent: input :dims: - n-1 - lld: :type: real :intent: input :dims: - n-1 - pivmin: :type: real :intent: input - gaptol: :type: real :intent: input - z: :type: complex :intent: input/output :dims: - n - wantnc: :type: logical :intent: input - negcnt: :type: integer :intent: output - ztz: :type: real :intent: output - mingma: :type: real :intent: output - r: :type: integer :intent: input/output - isuppz: :type: integer :intent: output :dims: - "2" - nrminv: :type: real :intent: output - resid: :type: real :intent: output - rqcorr: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 4*n :substitutions: {} :fortran_help: " SUBROUTINE CLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD, PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, R, ISUPPZ, NRMINV, RESID, RQCORR, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAR1V computes the (scaled) r-th column of the inverse of\n\ * the sumbmatrix in rows B1 through BN of the tridiagonal matrix\n\ * L D L^T - sigma I. When sigma is close to an eigenvalue, the\n\ * computed vector is an accurate eigenvector. Usually, r corresponds\n\ * to the index where the eigenvector is largest in magnitude.\n\ * The following steps accomplish this computation :\n\ * (a) Stationary qd transform, L D L^T - sigma I = L(+) D(+) L(+)^T,\n\ * (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T,\n\ * (c) Computation of the diagonal elements of the inverse of\n\ * L D L^T - sigma I by combining the above transforms, and choosing\n\ * r as the index where the diagonal of the inverse is (one of the)\n\ * largest in magnitude.\n\ * (d) Computation of the (scaled) r-th column of the inverse using the\n\ * twisted factorization obtained by combining the top part of the\n\ * the stationary and the bottom part of the progressive transform.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix L D L^T.\n\ *\n\ * B1 (input) INTEGER\n\ * First index of the submatrix of L D L^T.\n\ *\n\ * BN (input) INTEGER\n\ * Last index of the submatrix of L D L^T.\n\ *\n\ * LAMBDA (input) REAL \n\ * The shift. In order to compute an accurate eigenvector,\n\ * LAMBDA should be a good approximation to an eigenvalue\n\ * of L D L^T.\n\ *\n\ * L (input) REAL array, dimension (N-1)\n\ * The (n-1) subdiagonal elements of the unit bidiagonal matrix\n\ * L, in elements 1 to N-1.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The n diagonal elements of the diagonal matrix D.\n\ *\n\ * LD (input) REAL array, dimension (N-1)\n\ * The n-1 elements L(i)*D(i).\n\ *\n\ * LLD (input) REAL array, dimension (N-1)\n\ * The n-1 elements L(i)*L(i)*D(i).\n\ *\n\ * PIVMIN (input) REAL \n\ * The minimum pivot in the Sturm sequence.\n\ *\n\ * GAPTOL (input) REAL \n\ * Tolerance that indicates when eigenvector entries are negligible\n\ * w.r.t. their contribution to the residual.\n\ *\n\ * Z (input/output) COMPLEX array, dimension (N)\n\ * On input, all entries of Z must be set to 0.\n\ * On output, Z contains the (scaled) r-th column of the\n\ * inverse. The scaling is such that Z(R) equals 1.\n\ *\n\ * WANTNC (input) LOGICAL\n\ * Specifies whether NEGCNT has to be computed.\n\ *\n\ * NEGCNT (output) INTEGER\n\ * If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin\n\ * in the matrix factorization L D L^T, and NEGCNT = -1 otherwise.\n\ *\n\ * ZTZ (output) REAL \n\ * The square of the 2-norm of Z.\n\ *\n\ * MINGMA (output) REAL \n\ * The reciprocal of the largest (in magnitude) diagonal\n\ * element of the inverse of L D L^T - sigma I.\n\ *\n\ * R (input/output) INTEGER\n\ * The twist index for the twisted factorization used to\n\ * compute Z.\n\ * On input, 0 <= R <= N. If R is input as 0, R is set to\n\ * the index where (L D L^T - sigma I)^{-1} is largest\n\ * in magnitude. If 1 <= R <= N, R is unchanged.\n\ * On output, R contains the twist index used to compute Z.\n\ * Ideally, R designates the position of the maximum entry in the\n\ * eigenvector.\n\ *\n\ * ISUPPZ (output) INTEGER array, dimension (2)\n\ * The support of the vector in Z, i.e., the vector Z is\n\ * nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ).\n\ *\n\ * NRMINV (output) REAL \n\ * NRMINV = 1/SQRT( ZTZ )\n\ *\n\ * RESID (output) REAL \n\ * The residual of the FP vector.\n\ * RESID = ABS( MINGMA )/SQRT( ZTZ )\n\ *\n\ * RQCORR (output) REAL \n\ * The Rayleigh Quotient correction to LAMBDA.\n\ * RQCORR = MINGMA*TMP\n\ *\n\ * WORK (workspace) REAL array, dimension (4*N)\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Beresford Parlett, University of California, Berkeley, USA\n\ * Jim Demmel, University of California, Berkeley, USA\n\ * Inderjit Dhillon, University of Texas, Austin, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, University of California, Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgghrd0000644000175000017500000001350712502223526016503 0ustar uwabamiuwabami--- :name: zgghrd :md5sum: c4bd0bbb646c8b02ff96b0a6977d8d8c :category: :subroutine :arguments: - compq: :type: char :intent: input - compz: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - q: :type: doublecomplex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - z: :type: doublecomplex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGGHRD reduces a pair of complex matrices (A,B) to generalized upper\n\ * Hessenberg form using unitary transformations, where A is a\n\ * general matrix and B is upper triangular. The form of the\n\ * generalized eigenvalue problem is\n\ * A*x = lambda*B*x,\n\ * and B is typically made upper triangular by computing its QR\n\ * factorization and moving the unitary matrix Q to the left side\n\ * of the equation.\n\ *\n\ * This subroutine simultaneously reduces A to a Hessenberg matrix H:\n\ * Q**H*A*Z = H\n\ * and transforms B to another upper triangular matrix T:\n\ * Q**H*B*Z = T\n\ * in order to reduce the problem to its standard form\n\ * H*y = lambda*T*y\n\ * where y = Z**H*x.\n\ *\n\ * The unitary matrices Q and Z are determined as products of Givens\n\ * rotations. They may either be formed explicitly, or they may be\n\ * postmultiplied into input matrices Q1 and Z1, so that\n\ * Q1 * A * Z1**H = (Q1*Q) * H * (Z1*Z)**H\n\ * Q1 * B * Z1**H = (Q1*Q) * T * (Z1*Z)**H\n\ * If Q1 is the unitary matrix from the QR factorization of B in the\n\ * original equation A*x = lambda*B*x, then ZGGHRD reduces the original\n\ * problem to generalized Hessenberg form.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * COMPQ (input) CHARACTER*1\n\ * = 'N': do not compute Q;\n\ * = 'I': Q is initialized to the unit matrix, and the\n\ * unitary matrix Q is returned;\n\ * = 'V': Q must contain a unitary matrix Q1 on entry,\n\ * and the product Q1*Q is returned.\n\ *\n\ * COMPZ (input) CHARACTER*1\n\ * = 'N': do not compute Q;\n\ * = 'I': Q is initialized to the unit matrix, and the\n\ * unitary matrix Q is returned;\n\ * = 'V': Q must contain a unitary matrix Q1 on entry,\n\ * and the product Q1*Q is returned.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * ILO and IHI mark the rows and columns of A which are to be\n\ * reduced. It is assumed that A is already upper triangular\n\ * in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are\n\ * normally set by a previous call to ZGGBAL; otherwise they\n\ * should be set to 1 and N respectively.\n\ * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA, N)\n\ * On entry, the N-by-N general matrix to be reduced.\n\ * On exit, the upper triangle and the first subdiagonal of A\n\ * are overwritten with the upper Hessenberg matrix H, and the\n\ * rest is set to zero.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB, N)\n\ * On entry, the N-by-N upper triangular matrix B.\n\ * On exit, the upper triangular matrix T = Q**H B Z. The\n\ * elements below the diagonal are set to zero.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * Q (input/output) COMPLEX*16 array, dimension (LDQ, N)\n\ * On entry, if COMPQ = 'V', the unitary matrix Q1, typically\n\ * from the QR factorization of B.\n\ * On exit, if COMPQ='I', the unitary matrix Q, and if\n\ * COMPQ = 'V', the product Q1*Q.\n\ * Not referenced if COMPQ='N'.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q.\n\ * LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.\n\ *\n\ * Z (input/output) COMPLEX*16 array, dimension (LDZ, N)\n\ * On entry, if COMPZ = 'V', the unitary matrix Z1.\n\ * On exit, if COMPZ='I', the unitary matrix Z, and if\n\ * COMPZ = 'V', the product Z1*Z.\n\ * Not referenced if COMPZ='N'.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z.\n\ * LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.\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\ * This routine reduces A to Hessenberg and B to triangular form by\n\ * an unblocked reduction, as described in _Matrix_Computations_,\n\ * by Golub and van Loan (Johns Hopkins Press).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgeequ0000644000175000017500000000642612502223525016470 0ustar uwabamiuwabami--- :name: cgeequ :md5sum: b5e1f650b307e4997d54c66b11f94248 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - r: :type: real :intent: output :dims: - m - c: :type: real :intent: output :dims: - n - rowcnd: :type: real :intent: output - colcnd: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE CGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGEEQU computes row and column scalings intended to equilibrate an\n\ * M-by-N matrix A and reduce its condition number. R returns the row\n\ * scale factors and C the column scale factors, chosen to try to make\n\ * the largest element in each row and column of the matrix B with\n\ * elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n\ *\n\ * R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n\ * number and BIGNUM = largest safe number. Use of these scaling\n\ * factors is not guaranteed to reduce the condition number of A but\n\ * works well in practice.\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) COMPLEX array, dimension (LDA,N)\n\ * The M-by-N matrix whose equilibration factors are\n\ * to be computed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * R (output) REAL array, dimension (M)\n\ * If INFO = 0 or INFO > M, R contains the row scale factors\n\ * for A.\n\ *\n\ * C (output) REAL array, dimension (N)\n\ * If INFO = 0, C contains the column scale factors for A.\n\ *\n\ * ROWCND (output) REAL\n\ * If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n\ * smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n\ * AMAX is neither too large nor too small, it is not worth\n\ * scaling by R.\n\ *\n\ * COLCND (output) REAL\n\ * If INFO = 0, COLCND contains the ratio of the smallest\n\ * C(i) to the largest C(i). If COLCND >= 0.1, it is not\n\ * worth scaling by C.\n\ *\n\ * AMAX (output) REAL\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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, and i is\n\ * <= M: the i-th row of A is exactly zero\n\ * > M: the (i-M)-th column of A is exactly zero\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgbtrf0000644000175000017500000000742412502223526016467 0ustar uwabamiuwabami--- :name: dgbtrf :md5sum: 748601a9d6892d3d72a222a317ff462a :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGBTRF computes an LU factorization of a real m-by-n band matrix A\n\ * using partial pivoting with row interchanges.\n\ *\n\ * This is the blocked version of the algorithm, calling Level 3 BLAS.\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\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows KL+1 to\n\ * 2*KL+KU+1; rows 1 to KL of the array need not be set.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n\ *\n\ * On exit, details of the factorization: U is stored as an\n\ * upper triangular band matrix with KL+KU superdiagonals in\n\ * rows 1 to KL+KU+1, and the multipliers used during the\n\ * factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n\ * See below for further details.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n\ *\n\ * IPIV (output) INTEGER array, dimension (min(M,N))\n\ * The pivot indices; for 1 <= i <= min(M,N), row i of the\n\ * matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, and division by zero will occur if it is used\n\ * to solve a system of equations.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * M = N = 6, KL = 2, KU = 1:\n\ *\n\ * On entry: On exit:\n\ *\n\ * * * * + + + * * * u14 u25 u36\n\ * * * + + + + * * u13 u24 u35 u46\n\ * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n\ * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n\ * a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n\ * a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n\ *\n\ * Array elements marked * are not used by the routine; elements marked\n\ * + need not be set on entry, but are required by the routine to store\n\ * elements of U because of fill-in resulting from the row interchanges.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlatrd0000644000175000017500000001407712502223526016473 0ustar uwabamiuwabami--- :name: dlatrd :md5sum: b6751dfd08ecd201d434b7f4b939e5b4 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - e: :type: doublereal :intent: output :dims: - n-1 - tau: :type: doublereal :intent: output :dims: - n-1 - w: :type: doublereal :intent: output :dims: - ldw - MAX(n,nb) - ldw: :type: integer :intent: input :substitutions: ldw: MAX(1,n) :fortran_help: " SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLATRD reduces NB rows and columns of a real symmetric matrix A to\n\ * symmetric tridiagonal form by an orthogonal similarity\n\ * transformation Q' * A * Q, and returns the matrices V and W which are\n\ * needed to apply the transformation to the unreduced part of A.\n\ *\n\ * If UPLO = 'U', DLATRD reduces the last NB rows and columns of a\n\ * matrix, of which the upper triangle is supplied;\n\ * if UPLO = 'L', DLATRD reduces the first NB rows and columns of a\n\ * matrix, of which the lower triangle is supplied.\n\ *\n\ * This is an auxiliary routine called by DSYTRD.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A.\n\ *\n\ * NB (input) INTEGER\n\ * The number of rows and columns to be reduced.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * n-by-n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n-by-n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ * On exit:\n\ * if UPLO = 'U', the last NB columns have been reduced to\n\ * tridiagonal form, with the diagonal elements overwriting\n\ * the diagonal elements of A; the elements above the diagonal\n\ * with the array TAU, represent the orthogonal matrix Q as a\n\ * product of elementary reflectors;\n\ * if UPLO = 'L', the first NB columns have been reduced to\n\ * tridiagonal form, with the diagonal elements overwriting\n\ * the diagonal elements of A; the elements below the diagonal\n\ * with the array TAU, represent the orthogonal matrix Q as a\n\ * product of elementary reflectors.\n\ * See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= (1,N).\n\ *\n\ * E (output) DOUBLE PRECISION array, dimension (N-1)\n\ * If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal\n\ * elements of the last NB columns of the reduced matrix;\n\ * if UPLO = 'L', E(1:nb) contains the subdiagonal elements of\n\ * the first NB columns of the reduced matrix.\n\ *\n\ * TAU (output) DOUBLE PRECISION array, dimension (N-1)\n\ * The scalar factors of the elementary reflectors, stored in\n\ * TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.\n\ * See Further Details.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (LDW,NB)\n\ * The n-by-nb matrix W required to update the unreduced part\n\ * of A.\n\ *\n\ * LDW (input) INTEGER\n\ * The leading dimension of the array W. LDW >= max(1,N).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * If UPLO = 'U', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(n) H(n-1) . . . H(n-nb+1).\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(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),\n\ * and tau in TAU(i-1).\n\ *\n\ * If UPLO = 'L', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(nb).\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) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),\n\ * and tau in TAU(i).\n\ *\n\ * The elements of the vectors v together form the n-by-nb matrix V\n\ * which is needed, with W, to apply the transformation to the unreduced\n\ * part of the matrix, using a symmetric rank-2k update of the form:\n\ * A := A - V*W' - W*V'.\n\ *\n\ * The contents of A on exit are illustrated by the following examples\n\ * with n = 5 and nb = 2:\n\ *\n\ * if UPLO = 'U': if UPLO = 'L':\n\ *\n\ * ( a a a v4 v5 ) ( d )\n\ * ( a a v4 v5 ) ( 1 d )\n\ * ( a 1 v5 ) ( v1 1 a )\n\ * ( d 1 ) ( v1 v2 a a )\n\ * ( d ) ( v1 v2 a a a )\n\ *\n\ * where d denotes a diagonal element of the reduced matrix, a denotes\n\ * an element of the original matrix that is unchanged, and vi denotes\n\ * an element of the vector defining H(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/claqsp0000644000175000017500000000531712502223525016500 0ustar uwabamiuwabami--- :name: claqsp :md5sum: 8848a8c7da22b13fd5e2a4b1707cf25c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - n*(n+1)/2 - s: :type: real :intent: input :dims: - n - scond: :type: real :intent: input - amax: :type: real :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAQSP equilibrates a symmetric matrix A using the scaling factors\n\ * in the vector S.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, the equilibrated matrix: diag(S) * A * diag(S), in\n\ * the same storage format as A.\n\ *\n\ * S (input) REAL array, dimension (N)\n\ * The scale factors for A.\n\ *\n\ * SCOND (input) REAL\n\ * Ratio of the smallest S(i) to the largest S(i).\n\ *\n\ * AMAX (input) REAL\n\ * Absolute value of largest matrix entry.\n\ *\n\ * EQUED (output) CHARACTER*1\n\ * Specifies whether or not equilibration was done.\n\ * = 'N': No equilibration.\n\ * = 'Y': Equilibration was done, i.e., A has been replaced by\n\ * diag(S) * A * diag(S).\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * THRESH is a threshold value used to decide if scaling should be done\n\ * based on the ratio of the scaling factors. If SCOND < THRESH,\n\ * scaling is done.\n\ *\n\ * LARGE and SMALL are threshold values used to decide if scaling should\n\ * be done based on the absolute size of the largest matrix element.\n\ * If AMAX > LARGE or AMAX < SMALL, scaling is done.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlar1v0000644000175000017500000001462712502223526016413 0ustar uwabamiuwabami--- :name: dlar1v :md5sum: 6322bae9cfb9228c90b6dd34a2408183 :category: :subroutine :arguments: - n: :type: integer :intent: input - b1: :type: integer :intent: input - bn: :type: integer :intent: input - lambda: :type: doublereal :intent: input - d: :type: doublereal :intent: input :dims: - n - l: :type: doublereal :intent: input :dims: - n-1 - ld: :type: doublereal :intent: input :dims: - n-1 - lld: :type: doublereal :intent: input :dims: - n-1 - pivmin: :type: doublereal :intent: input - gaptol: :type: doublereal :intent: input - z: :type: doublereal :intent: input/output :dims: - n - wantnc: :type: logical :intent: input - negcnt: :type: integer :intent: output - ztz: :type: doublereal :intent: output - mingma: :type: doublereal :intent: output - r: :type: integer :intent: input/output - isuppz: :type: integer :intent: output :dims: - "2" - nrminv: :type: doublereal :intent: output - resid: :type: doublereal :intent: output - rqcorr: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 4*n :substitutions: {} :fortran_help: " SUBROUTINE DLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD, PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, R, ISUPPZ, NRMINV, RESID, RQCORR, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAR1V computes the (scaled) r-th column of the inverse of\n\ * the sumbmatrix in rows B1 through BN of the tridiagonal matrix\n\ * L D L^T - sigma I. When sigma is close to an eigenvalue, the\n\ * computed vector is an accurate eigenvector. Usually, r corresponds\n\ * to the index where the eigenvector is largest in magnitude.\n\ * The following steps accomplish this computation :\n\ * (a) Stationary qd transform, L D L^T - sigma I = L(+) D(+) L(+)^T,\n\ * (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T,\n\ * (c) Computation of the diagonal elements of the inverse of\n\ * L D L^T - sigma I by combining the above transforms, and choosing\n\ * r as the index where the diagonal of the inverse is (one of the)\n\ * largest in magnitude.\n\ * (d) Computation of the (scaled) r-th column of the inverse using the\n\ * twisted factorization obtained by combining the top part of the\n\ * the stationary and the bottom part of the progressive transform.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix L D L^T.\n\ *\n\ * B1 (input) INTEGER\n\ * First index of the submatrix of L D L^T.\n\ *\n\ * BN (input) INTEGER\n\ * Last index of the submatrix of L D L^T.\n\ *\n\ * LAMBDA (input) DOUBLE PRECISION\n\ * The shift. In order to compute an accurate eigenvector,\n\ * LAMBDA should be a good approximation to an eigenvalue\n\ * of L D L^T.\n\ *\n\ * L (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) subdiagonal elements of the unit bidiagonal matrix\n\ * L, in elements 1 to N-1.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The n diagonal elements of the diagonal matrix D.\n\ *\n\ * LD (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The n-1 elements L(i)*D(i).\n\ *\n\ * LLD (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The n-1 elements L(i)*L(i)*D(i).\n\ *\n\ * PIVMIN (input) DOUBLE PRECISION\n\ * The minimum pivot in the Sturm sequence.\n\ *\n\ * GAPTOL (input) DOUBLE PRECISION\n\ * Tolerance that indicates when eigenvector entries are negligible\n\ * w.r.t. their contribution to the residual.\n\ *\n\ * Z (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On input, all entries of Z must be set to 0.\n\ * On output, Z contains the (scaled) r-th column of the\n\ * inverse. The scaling is such that Z(R) equals 1.\n\ *\n\ * WANTNC (input) LOGICAL\n\ * Specifies whether NEGCNT has to be computed.\n\ *\n\ * NEGCNT (output) INTEGER\n\ * If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin\n\ * in the matrix factorization L D L^T, and NEGCNT = -1 otherwise.\n\ *\n\ * ZTZ (output) DOUBLE PRECISION\n\ * The square of the 2-norm of Z.\n\ *\n\ * MINGMA (output) DOUBLE PRECISION\n\ * The reciprocal of the largest (in magnitude) diagonal\n\ * element of the inverse of L D L^T - sigma I.\n\ *\n\ * R (input/output) INTEGER\n\ * The twist index for the twisted factorization used to\n\ * compute Z.\n\ * On input, 0 <= R <= N. If R is input as 0, R is set to\n\ * the index where (L D L^T - sigma I)^{-1} is largest\n\ * in magnitude. If 1 <= R <= N, R is unchanged.\n\ * On output, R contains the twist index used to compute Z.\n\ * Ideally, R designates the position of the maximum entry in the\n\ * eigenvector.\n\ *\n\ * ISUPPZ (output) INTEGER array, dimension (2)\n\ * The support of the vector in Z, i.e., the vector Z is\n\ * nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ).\n\ *\n\ * NRMINV (output) DOUBLE PRECISION\n\ * NRMINV = 1/SQRT( ZTZ )\n\ *\n\ * RESID (output) DOUBLE PRECISION\n\ * The residual of the FP vector.\n\ * RESID = ABS( MINGMA )/SQRT( ZTZ )\n\ *\n\ * RQCORR (output) DOUBLE PRECISION\n\ * The Rayleigh Quotient correction to LAMBDA.\n\ * RQCORR = MINGMA*TMP\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Beresford Parlett, University of California, Berkeley, USA\n\ * Jim Demmel, University of California, Berkeley, USA\n\ * Inderjit Dhillon, University of Texas, Austin, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, University of California, Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgebak0000644000175000017500000000547712502223526016442 0ustar uwabamiuwabami--- :name: dgebak :md5sum: 1422ed99bdfebc076a90d3f7631e2619 :category: :subroutine :arguments: - job: :type: char :intent: input - side: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - scale: :type: doublereal :intent: input :dims: - n - m: :type: integer :intent: input - v: :type: doublereal :intent: input/output :dims: - ldv - m - ldv: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGEBAK forms the right or left eigenvectors of a real general matrix\n\ * by backward transformation on the computed eigenvectors of the\n\ * balanced matrix output by DGEBAL.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * Specifies the type of backward transformation required:\n\ * = 'N', do nothing, return immediately;\n\ * = 'P', do backward transformation for permutation only;\n\ * = 'S', do backward transformation for scaling only;\n\ * = 'B', do backward transformations for both permutation and\n\ * scaling.\n\ * JOB must be the same as the argument JOB supplied to DGEBAL.\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'R': V contains right eigenvectors;\n\ * = 'L': V contains left eigenvectors.\n\ *\n\ * N (input) INTEGER\n\ * The number of rows of the matrix V. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * The integers ILO and IHI determined by DGEBAL.\n\ * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n\ *\n\ * SCALE (input) DOUBLE PRECISION array, dimension (N)\n\ * Details of the permutation and scaling factors, as returned\n\ * by DGEBAL.\n\ *\n\ * M (input) INTEGER\n\ * The number of columns of the matrix V. M >= 0.\n\ *\n\ * V (input/output) DOUBLE PRECISION array, dimension (LDV,M)\n\ * On entry, the matrix of right or left eigenvectors to be\n\ * transformed, as returned by DHSEIN or DTREVC.\n\ * On exit, V is overwritten by the transformed eigenvectors.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V. LDV >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ztftri0000644000175000017500000001547212502223526016543 0ustar uwabamiuwabami--- :name: ztftri :md5sum: 3bd41cf0bc65085617b31fb5b3448085 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZTFTRI( TRANSR, UPLO, DIAG, N, A, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTFTRI computes the inverse of a triangular matrix A stored in RFP\n\ * format.\n\ *\n\ * This is a Level 3 BLAS version of the algorithm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': The Normal TRANSR of RFP A is stored;\n\ * = 'C': The Conjugate-transpose TRANSR of RFP A is stored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension ( N*(N+1)/2 );\n\ * On entry, the triangular matrix A in RFP format. RFP format\n\ * is described by TRANSR, UPLO, and N as follows: If TRANSR =\n\ * 'N' then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n\ * (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is\n\ * the Conjugate-transpose of RFP A as defined when\n\ * TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n\ * follows: If UPLO = 'U' the RFP A contains the nt elements of\n\ * upper packed A; If UPLO = 'L' the RFP A contains the nt\n\ * elements of lower packed A. The LDA of RFP A is (N+1)/2 when\n\ * TRANSR = 'C'. When TRANSR is 'N' the LDA is N+1 when N is\n\ * even and N is odd. See the Note below for more details.\n\ *\n\ * On exit, the (triangular) inverse of the original matrix, in\n\ * the same storage format.\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, A(i,i) is exactly zero. The triangular\n\ * matrix is singular and its inverse can not be computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * We first consider Standard Packed Format when N is even.\n\ * We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * conjugate-transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * conjugate-transpose of the last three columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- --\n\ * 03 04 05 33 43 53\n\ * -- --\n\ * 13 14 15 00 44 54\n\ * --\n\ * 23 24 25 10 11 55\n\ *\n\ * 33 34 35 20 21 22\n\ * --\n\ * 00 44 45 30 31 32\n\ * -- --\n\ * 01 11 55 40 41 42\n\ * -- -- --\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We next consider Standard Packed Format when N is odd.\n\ * We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * conjugate-transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * conjugate-transpose of the last two columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- --\n\ * 02 03 04 00 33 43\n\ * --\n\ * 12 13 14 10 11 44\n\ *\n\ * 22 23 24 20 21 22\n\ * --\n\ * 00 33 34 30 31 32\n\ * -- --\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- --\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chegst0000644000175000017500000000573712502223525016500 0ustar uwabamiuwabami--- :name: chegst :md5sum: 79db73907714c6262f9a3ff4c9fb3ec7 :category: :subroutine :arguments: - itype: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHEGST reduces a complex Hermitian-definite generalized\n\ * eigenproblem to standard form.\n\ *\n\ * If ITYPE = 1, the problem is A*x = lambda*B*x,\n\ * and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)\n\ *\n\ * If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n\ * B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L.\n\ *\n\ * B must have been previously factorized as U**H*U or L*L**H by CPOTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);\n\ * = 2 or 3: compute U*A*U**H or L**H*A*L.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored and B is factored as\n\ * U**H*U;\n\ * = 'L': Lower triangle of A is stored and B is factored as\n\ * L*L**H.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the transformed matrix, stored in the\n\ * same format as A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,N)\n\ * The triangular factor from the Cholesky factorization of B,\n\ * as returned by CPOTRF.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlarscl20000644000175000017500000000306212502223526016745 0ustar uwabamiuwabami--- :name: zlarscl2 :md5sum: 080c93b0555c1909ea0298bd0d4ec2f9 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - m - x: :type: doublecomplex :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE ZLARSCL2 ( M, N, D, X, LDX )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLARSCL2 performs a reciprocal diagonal scaling on an vector:\n\ * x <-- inv(D) * x\n\ * where the DOUBLE PRECISION diagonal matrix D is stored as a vector.\n\ *\n\ * Eventually to be replaced by BLAS_zge_diag_scale in the new BLAS\n\ * standard.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of D and X. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of D and X. N >= 0.\n\ *\n\ * D (input) DOUBLE PRECISION array, length M\n\ * Diagonal matrix D, stored as a vector of length M.\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension (LDX,N)\n\ * On entry, the vector X to be scaled by D.\n\ * On exit, the scaled vector.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the vector X. LDX >= 0.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slaln20000644000175000017500000001421512502223526016406 0ustar uwabamiuwabami--- :name: slaln2 :md5sum: 1daa4014ddd7a0cc7ee7dcf6e2b38829 :category: :subroutine :arguments: - ltrans: :type: logical :intent: input - na: :type: integer :intent: input - nw: :type: integer :intent: input - smin: :type: real :intent: input - ca: :type: real :intent: input - a: :type: real :intent: input :dims: - lda - na - lda: :type: integer :intent: input - d1: :type: real :intent: input - d2: :type: real :intent: input - b: :type: real :intent: input :dims: - ldb - nw - ldb: :type: integer :intent: input - wr: :type: real :intent: input - wi: :type: real :intent: input - x: :type: real :intent: output :dims: - ldx - nw - ldx: :type: integer :intent: input - scale: :type: real :intent: output - xnorm: :type: real :intent: output - info: :type: integer :intent: output :substitutions: ldx: na :fortran_help: " SUBROUTINE SLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, LDB, WR, WI, X, LDX, SCALE, XNORM, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLALN2 solves a system of the form (ca A - w D ) X = s B\n\ * or (ca A' - w D) X = s B with possible scaling (\"s\") and\n\ * perturbation of A. (A' means A-transpose.)\n\ *\n\ * A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA\n\ * real diagonal matrix, w is a real or complex value, and X and B are\n\ * NA x 1 matrices -- real if w is real, complex if w is complex. NA\n\ * may be 1 or 2.\n\ *\n\ * If w is complex, X and B are represented as NA x 2 matrices,\n\ * the first column of each being the real part and the second\n\ * being the imaginary part.\n\ *\n\ * \"s\" is a scaling factor (.LE. 1), computed by SLALN2, which is\n\ * so chosen that X can be computed without overflow. X is further\n\ * scaled if necessary to assure that norm(ca A - w D)*norm(X) is less\n\ * than overflow.\n\ *\n\ * If both singular values of (ca A - w D) are less than SMIN,\n\ * SMIN*identity will be used instead of (ca A - w D). If only one\n\ * singular value is less than SMIN, one element of (ca A - w D) will be\n\ * perturbed enough to make the smallest singular value roughly SMIN.\n\ * If both singular values are at least SMIN, (ca A - w D) will not be\n\ * perturbed. In any case, the perturbation will be at most some small\n\ * multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values\n\ * are computed by infinity-norm approximations, and thus will only be\n\ * correct to a factor of 2 or so.\n\ *\n\ * Note: all input quantities are assumed to be smaller than overflow\n\ * by a reasonable factor. (See BIGNUM.)\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * LTRANS (input) LOGICAL\n\ * =.TRUE.: A-transpose will be used.\n\ * =.FALSE.: A will be used (not transposed.)\n\ *\n\ * NA (input) INTEGER\n\ * The size of the matrix A. It may (only) be 1 or 2.\n\ *\n\ * NW (input) INTEGER\n\ * 1 if \"w\" is real, 2 if \"w\" is complex. It may only be 1\n\ * or 2.\n\ *\n\ * SMIN (input) REAL\n\ * The desired lower bound on the singular values of A. This\n\ * should be a safe distance away from underflow or overflow,\n\ * say, between (underflow/machine precision) and (machine\n\ * precision * overflow ). (See BIGNUM and ULP.)\n\ *\n\ * CA (input) REAL\n\ * The coefficient c, which A is multiplied by.\n\ *\n\ * A (input) REAL array, dimension (LDA,NA)\n\ * The NA x NA matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of A. It must be at least NA.\n\ *\n\ * D1 (input) REAL\n\ * The 1,1 element in the diagonal matrix D.\n\ *\n\ * D2 (input) REAL\n\ * The 2,2 element in the diagonal matrix D. Not used if NW=1.\n\ *\n\ * B (input) REAL array, dimension (LDB,NW)\n\ * The NA x NW matrix B (right-hand side). If NW=2 (\"w\" is\n\ * complex), column 1 contains the real part of B and column 2\n\ * contains the imaginary part.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B. It must be at least NA.\n\ *\n\ * WR (input) REAL\n\ * The real part of the scalar \"w\".\n\ *\n\ * WI (input) REAL\n\ * The imaginary part of the scalar \"w\". Not used if NW=1.\n\ *\n\ * X (output) REAL array, dimension (LDX,NW)\n\ * The NA x NW matrix X (unknowns), as computed by SLALN2.\n\ * If NW=2 (\"w\" is complex), on exit, column 1 will contain\n\ * the real part of X and column 2 will contain the imaginary\n\ * part.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of X. It must be at least NA.\n\ *\n\ * SCALE (output) REAL\n\ * The scale factor that B must be multiplied by to insure\n\ * that overflow does not occur when computing X. Thus,\n\ * (ca A - w D) X will be SCALE*B, not B (ignoring\n\ * perturbations of A.) It will be at most 1.\n\ *\n\ * XNORM (output) REAL\n\ * The infinity-norm of X, when X is regarded as an NA x NW\n\ * real matrix.\n\ *\n\ * INFO (output) INTEGER\n\ * An error flag. It will be set to zero if no error occurs,\n\ * a negative number if an argument is in error, or a positive\n\ * number if ca A - w D had to be perturbed.\n\ * The possible values are:\n\ * = 0: No error occurred, and (ca A - w D) did not have to be\n\ * perturbed.\n\ * = 1: (ca A - w D) had to be perturbed to make its smallest\n\ * (or only) singular value greater than SMIN.\n\ * NOTE: In the interests of speed, this routine does not\n\ * check the inputs for errors.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zla_syrfsx_extended0000644000175000017500000003524212502223526021302 0ustar uwabamiuwabami--- :name: zla_syrfsx_extended :md5sum: 1bbc80dff104ad9433d7b76fc0d7da02 :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - colequ: :type: logical :intent: input - c: :type: doublereal :intent: input :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: doublecomplex :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: doublereal :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: input/output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: input/output :dims: - nrhs - n_err_bnds - res: :type: doublecomplex :intent: input :dims: - n - ayb: :type: doublereal :intent: input :dims: - n - dy: :type: doublecomplex :intent: input :dims: - n - y_tail: :type: doublecomplex :intent: input :dims: - n - rcond: :type: doublereal :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: doublereal :intent: input - dz_ub: :type: doublereal :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLA_SYRFSX_EXTENDED improves the computed solution to a system of\n\ * linear equations by performing extra-precise iterative refinement\n\ * and provides error bounds and backward error estimates for the solution.\n\ * This subroutine is called by ZSYRFSX to perform iterative refinement.\n\ * In addition to normwise error bound, the code provides maximum\n\ * componentwise error bound if possible. See comments for ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP for details of the error bounds. Note that this\n\ * subroutine is only resonsible for setting the second fields of\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * PREC_TYPE (input) INTEGER\n\ * Specifies the intermediate precision to be used in refinement.\n\ * The value is defined by ILAPREC(P) where P is a CHARACTER and\n\ * P = 'S': Single\n\ * = 'D': Double\n\ * = 'I': Indigenous\n\ * = 'X', 'E': Extra\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right-hand-sides, i.e., the number of columns of the\n\ * matrix B.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX*16 array, dimension (LDAF,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by ZSYTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by ZSYTRF.\n\ *\n\ * COLEQU (input) LOGICAL\n\ * If .TRUE. then column equilibration was done to A before calling\n\ * this routine. This is needed to compute the solution and error\n\ * bounds correctly.\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension (N)\n\ * The column scale factors for A. If COLEQU = .FALSE., C\n\ * is not accessed. If C is input, each element of C should be a power\n\ * of the radix to ensure a reliable solution and error estimates.\n\ * Scaling by powers of the radix does not cause rounding errors unless\n\ * the result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The right-hand-side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * Y (input/output) COMPLEX*16 array, dimension\n\ * (LDY,NRHS)\n\ * On entry, the solution matrix X, as computed by ZSYTRS.\n\ * On exit, the improved solution matrix Y.\n\ *\n\ * LDY (input) INTEGER\n\ * The leading dimension of the array Y. LDY >= max(1,N).\n\ *\n\ * BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * On exit, BERR_OUT(j) contains the componentwise relative backward\n\ * error for right-hand-side j from the formula\n\ * max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n\ * where abs(Z) is the componentwise absolute value of the matrix\n\ * or vector Z. This is computed by ZLA_LIN_BERR.\n\ *\n\ * N_NORMS (input) INTEGER\n\ * Determines which error bounds to return (see ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP).\n\ * If N_NORMS >= 1 return normwise error bounds.\n\ * If N_NORMS >= 2 return componentwise error bounds.\n\ *\n\ * ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension\n\ * (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension\n\ * (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * RES (input) COMPLEX*16 array, dimension (N)\n\ * Workspace to hold the intermediate residual.\n\ *\n\ * AYB (input) DOUBLE PRECISION array, dimension (N)\n\ * Workspace.\n\ *\n\ * DY (input) COMPLEX*16 array, dimension (N)\n\ * Workspace to hold the intermediate solution.\n\ *\n\ * Y_TAIL (input) COMPLEX*16 array, dimension (N)\n\ * Workspace to hold the trailing bits of the intermediate solution.\n\ *\n\ * RCOND (input) DOUBLE PRECISION\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * ITHRESH (input) INTEGER\n\ * The maximum number of residual computations allowed for\n\ * refinement. The default is 10. For 'aggressive' set to 100 to\n\ * permit convergence using approximate factorizations or\n\ * factorizations other than LU. If the factorization uses a\n\ * technique other than Gaussian elimination, the guarantees in\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n\ *\n\ * RTHRESH (input) DOUBLE PRECISION\n\ * Determines when to stop refinement if the error estimate stops\n\ * decreasing. Refinement will stop when the next solution no longer\n\ * satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n\ * the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n\ * default value is 0.5. For 'aggressive' set to 0.9 to permit\n\ * convergence on extremely ill-conditioned matrices. See LAWN 165\n\ * for more details.\n\ *\n\ * DZ_UB (input) DOUBLE PRECISION\n\ * Determines when to start considering componentwise convergence.\n\ * Componentwise convergence is only considered after each component\n\ * of the solution Y is stable, which we definte as the relative\n\ * change in each component being less than DZ_UB. The default value\n\ * is 0.25, requiring the first bit to be stable. See LAWN 165 for\n\ * more details.\n\ *\n\ * IGNORE_CWISE (input) LOGICAL\n\ * If .TRUE. then ignore componentwise convergence. Default value\n\ * is .FALSE..\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * < 0: if INFO = -i, the ith argument to ZSYTRS had an illegal\n\ * value\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE,\n $ Y_PREC_STATE\n DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n COMPLEX*16 ZDUM\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlaswp0000644000175000017500000000451212502223526016504 0ustar uwabamiuwabami--- :name: dlaswp :md5sum: 836b13a675719254b74dc6b844e95cd1 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - k1: :type: integer :intent: input - k2: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - k2*abs(incx) - incx: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLASWP performs a series of row interchanges on the matrix A.\n\ * One row interchange is initiated for each of rows K1 through K2 of A.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix A.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the matrix of column dimension N to which the row\n\ * interchanges will be applied.\n\ * On exit, the permuted matrix.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ *\n\ * K1 (input) INTEGER\n\ * The first element of IPIV for which a row interchange will\n\ * be done.\n\ *\n\ * K2 (input) INTEGER\n\ * The last element of IPIV for which a row interchange will\n\ * be done.\n\ *\n\ * IPIV (input) INTEGER array, dimension (K2*abs(INCX))\n\ * The vector of pivot indices. Only the elements in positions\n\ * K1 through K2 of IPIV are accessed.\n\ * IPIV(K) = L implies rows K and L are to be interchanged.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between successive values of IPIV. If IPIV\n\ * is negative, the pivots are applied in reverse order.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Modified by\n\ * R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32\n DOUBLE PRECISION TEMP\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sptrfs0000644000175000017500000000765512502223526016546 0ustar uwabamiuwabami--- :name: sptrfs :md5sum: 4ecbb01d7ec0c479ca08bee758afed59 :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: real :intent: input :dims: - n-1 - df: :type: real :intent: input :dims: - n - ef: :type: real :intent: input :dims: - n-1 - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPTRFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is symmetric positive definite\n\ * and tridiagonal, and provides error bounds and backward error\n\ * estimates for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The n diagonal elements of the tridiagonal matrix A.\n\ *\n\ * E (input) REAL array, dimension (N-1)\n\ * The (n-1) subdiagonal elements of the tridiagonal matrix A.\n\ *\n\ * DF (input) REAL array, dimension (N)\n\ * The n diagonal elements of the diagonal matrix D from the\n\ * factorization computed by SPTTRF.\n\ *\n\ * EF (input) REAL array, dimension (N-1)\n\ * The (n-1) subdiagonal elements of the unit bidiagonal factor\n\ * L from the factorization computed by SPTTRF.\n\ *\n\ * B (input) REAL array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) REAL array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by SPTTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j).\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) REAL array, dimension (2*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dorgr20000644000175000017500000000446212502223526016415 0ustar uwabamiuwabami--- :name: dorgr2 :md5sum: 9ffcc258297972edf31797ab19274e52 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - work: :type: doublereal :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE DORGR2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DORGR2 generates an m by n real matrix Q with orthonormal rows,\n\ * which is defined as the last m rows of a product of k elementary\n\ * reflectors of order n\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by DGERQF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. N >= M.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. M >= K >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the (m-k+i)-th row must contain the vector which\n\ * defines the elementary reflector H(i), for i = 1,2,...,k, as\n\ * returned by DGERQF in the last k rows of its array argument\n\ * A.\n\ * On exit, the m by n matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) DOUBLE PRECISION array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by DGERQF.\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 has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dtrsen0000644000175000017500000002570012502223526016513 0ustar uwabamiuwabami--- :name: dtrsen :md5sum: b5686e8b4c84da226a5a36225bfe7ba6 :category: :subroutine :arguments: - job: :type: char :intent: input - compq: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - t: :type: doublereal :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - q: :type: doublereal :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - wr: :type: doublereal :intent: output :dims: - n - wi: :type: doublereal :intent: output :dims: - n - m: :type: integer :intent: output - s: :type: doublereal :intent: output - sep: :type: doublereal :intent: output - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&job,\"N\") ? n : lsame_(&job,\"E\") ? m*(n-m) : (lsame_(&job,\"V\")||lsame_(&job,\"B\")) ? 2*m*(n-m) : 0" - iwork: :type: integer :intent: workspace :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTRSEN reorders the real Schur factorization of a real matrix\n\ * A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in\n\ * the leading diagonal blocks of the upper quasi-triangular matrix T,\n\ * and the leading columns of Q form an orthonormal basis of the\n\ * corresponding right invariant subspace.\n\ *\n\ * Optionally the routine computes the reciprocal condition numbers of\n\ * the cluster of eigenvalues and/or the invariant subspace.\n\ *\n\ * T must be in Schur canonical form (as returned by DHSEQR), that is,\n\ * block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each\n\ * 2-by-2 diagonal block has its diagonal elemnts equal and its\n\ * off-diagonal elements of opposite sign.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * Specifies whether condition numbers are required for the\n\ * cluster of eigenvalues (S) or the invariant subspace (SEP):\n\ * = 'N': none;\n\ * = 'E': for eigenvalues only (S);\n\ * = 'V': for invariant subspace only (SEP);\n\ * = 'B': for both eigenvalues and invariant subspace (S and\n\ * SEP).\n\ *\n\ * COMPQ (input) CHARACTER*1\n\ * = 'V': update the matrix Q of Schur vectors;\n\ * = 'N': do not update Q.\n\ *\n\ * SELECT (input) LOGICAL array, dimension (N)\n\ * SELECT specifies the eigenvalues in the selected cluster. To\n\ * select a real eigenvalue w(j), SELECT(j) must be set to\n\ * .TRUE.. To select a complex conjugate pair of eigenvalues\n\ * w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,\n\ * either SELECT(j) or SELECT(j+1) or both must be set to\n\ * .TRUE.; a complex conjugate pair of eigenvalues must be\n\ * either both included in the cluster or both excluded.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix T. N >= 0.\n\ *\n\ * T (input/output) DOUBLE PRECISION array, dimension (LDT,N)\n\ * On entry, the upper quasi-triangular matrix T, in Schur\n\ * canonical form.\n\ * On exit, T is overwritten by the reordered matrix T, again in\n\ * Schur canonical form, with the selected eigenvalues in the\n\ * leading diagonal blocks.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= max(1,N).\n\ *\n\ * Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n\ * On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n\ * On exit, if COMPQ = 'V', Q has been postmultiplied by the\n\ * orthogonal transformation matrix which reorders T; the\n\ * leading M columns of Q form an orthonormal basis for the\n\ * specified invariant subspace.\n\ * If COMPQ = 'N', Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q.\n\ * LDQ >= 1; and if COMPQ = 'V', LDQ >= N.\n\ *\n\ * WR (output) DOUBLE PRECISION array, dimension (N)\n\ * WI (output) DOUBLE PRECISION array, dimension (N)\n\ * The real and imaginary parts, respectively, of the reordered\n\ * eigenvalues of T. The eigenvalues are stored in the same\n\ * order as on the diagonal of T, with WR(i) = T(i,i) and, if\n\ * T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and\n\ * WI(i+1) = -WI(i). Note that if a complex eigenvalue is\n\ * sufficiently ill-conditioned, then its value may differ\n\ * significantly from its value before reordering.\n\ *\n\ * M (output) INTEGER\n\ * The dimension of the specified invariant subspace.\n\ * 0 < = M <= N.\n\ *\n\ * S (output) DOUBLE PRECISION\n\ * If JOB = 'E' or 'B', S is a lower bound on the reciprocal\n\ * condition number for the selected cluster of eigenvalues.\n\ * S cannot underestimate the true reciprocal condition number\n\ * by more than a factor of sqrt(N). If M = 0 or N, S = 1.\n\ * If JOB = 'N' or 'V', S is not referenced.\n\ *\n\ * SEP (output) DOUBLE PRECISION\n\ * If JOB = 'V' or 'B', SEP is the estimated reciprocal\n\ * condition number of the specified invariant subspace. If\n\ * M = 0 or N, SEP = norm(T).\n\ * If JOB = 'N' or 'E', SEP is not referenced.\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\ * If JOB = 'N', LWORK >= max(1,N);\n\ * if JOB = 'E', LWORK >= max(1,M*(N-M));\n\ * if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).\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\ * IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK.\n\ * If JOB = 'N' or 'E', LIWORK >= 1;\n\ * if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)).\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal size of the IWORK array,\n\ * returns this value as the first entry of the IWORK array, and\n\ * no error message related to LIWORK 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\ * = 1: reordering of T failed because some eigenvalues are too\n\ * close to separate (the problem is very ill-conditioned);\n\ * T may have been partially reordered, and WR and WI\n\ * contain the eigenvalues in the same order as in T; S and\n\ * SEP (if requested) are set to zero.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * DTRSEN first collects the selected eigenvalues by computing an\n\ * orthogonal transformation Z to move them to the top left corner of T.\n\ * In other words, the selected eigenvalues are the eigenvalues of T11\n\ * in:\n\ *\n\ * Z'*T*Z = ( T11 T12 ) n1\n\ * ( 0 T22 ) n2\n\ * n1 n2\n\ *\n\ * where N = n1+n2 and Z' means the transpose of Z. The first n1 columns\n\ * of Z span the specified invariant subspace of T.\n\ *\n\ * If T has been obtained from the real Schur factorization of a matrix\n\ * A = Q*T*Q', then the reordered real Schur factorization of A is given\n\ * by A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span\n\ * the corresponding invariant subspace of A.\n\ *\n\ * The reciprocal condition number of the average of the eigenvalues of\n\ * T11 may be returned in S. S lies between 0 (very badly conditioned)\n\ * and 1 (very well conditioned). It is computed as follows. First we\n\ * compute R so that\n\ *\n\ * P = ( I R ) n1\n\ * ( 0 0 ) n2\n\ * n1 n2\n\ *\n\ * is the projector on the invariant subspace associated with T11.\n\ * R is the solution of the Sylvester equation:\n\ *\n\ * T11*R - R*T22 = T12.\n\ *\n\ * Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote\n\ * the two-norm of M. Then S is computed as the lower bound\n\ *\n\ * (1 + F-norm(R)**2)**(-1/2)\n\ *\n\ * on the reciprocal of 2-norm(P), the true reciprocal condition number.\n\ * S cannot underestimate 1 / 2-norm(P) by more than a factor of\n\ * sqrt(N).\n\ *\n\ * An approximate error bound for the computed average of the\n\ * eigenvalues of T11 is\n\ *\n\ * EPS * norm(T) / S\n\ *\n\ * where EPS is the machine precision.\n\ *\n\ * The reciprocal condition number of the right invariant subspace\n\ * spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.\n\ * SEP is defined as the separation of T11 and T22:\n\ *\n\ * sep( T11, T22 ) = sigma-min( C )\n\ *\n\ * where sigma-min(C) is the smallest singular value of the\n\ * n1*n2-by-n1*n2 matrix\n\ *\n\ * C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )\n\ *\n\ * I(m) is an m by m identity matrix, and kprod denotes the Kronecker\n\ * product. We estimate sigma-min(C) by the reciprocal of an estimate of\n\ * the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)\n\ * cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).\n\ *\n\ * When SEP is small, small changes in T can cause large changes in\n\ * the invariant subspace. An approximate bound on the maximum angular\n\ * error in the computed right invariant subspace is\n\ *\n\ * EPS * norm(T) / SEP\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsbgv0000644000175000017500000001270012502223526016315 0ustar uwabamiuwabami--- :name: dsbgv :md5sum: 17fbadac3c6da4dce3f66fd5af4d631a :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: doublereal :intent: input/output :dims: - ldbb - n - ldbb: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? n : 1" :fortran_help: " SUBROUTINE DSBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSBGV computes all the eigenvalues, and optionally, the eigenvectors\n\ * of a real generalized symmetric-definite banded eigenproblem, of\n\ * the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric\n\ * and banded, and B is also positive definite.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * KA (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n\ *\n\ * KB (input) INTEGER\n\ * The number of superdiagonals of the matrix B if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n\ *\n\ * AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first ka+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n\ *\n\ * On exit, the contents of AB are destroyed.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KA+1.\n\ *\n\ * BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix B, stored in the first kb+1 rows of the array. The\n\ * j-th column of B is stored in the j-th column of the array BB\n\ * as follows:\n\ * if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n\ * if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n\ *\n\ * On exit, the factor S from the split Cholesky factorization\n\ * B = S**T*S, as returned by DPBSTF.\n\ *\n\ * LDBB (input) INTEGER\n\ * The leading dimension of the array BB. LDBB >= KB+1.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n\ * eigenvectors, with the i-th column of Z holding the\n\ * eigenvector associated with W(i). The eigenvectors are\n\ * normalized so that Z**T*B*Z = I.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= N.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\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, and i is:\n\ * <= N: the algorithm failed to converge:\n\ * i off-diagonal elements of an intermediate\n\ * tridiagonal form did not converge to zero;\n\ * > N: if INFO = N + i, for 1 <= i <= N, then DPBSTF\n\ * returned INFO = i: B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL UPPER, WANTZ\n CHARACTER VECT\n INTEGER IINFO, INDE, INDWRK\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DPBSTF, DSBGST, DSBTRD, DSTEQR, DSTERF, XERBLA\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cgees0000644000175000017500000001352712502223525016305 0ustar uwabamiuwabami--- :name: cgees :md5sum: ada518051342c4def9d30ad41b0a7f31 :category: :subroutine :arguments: - jobvs: :type: char :intent: input - sort: :type: char :intent: input - select: :intent: external procedure :block_type: logical :block_arg_num: 1 :block_arg_type: complex - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - sdim: :type: integer :intent: output - w: :type: complex :intent: output :dims: - n - vs: :type: complex :intent: output :dims: - ldvs - n - ldvs: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: real :intent: workspace :dims: - n - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvs: "lsame_(&jobvs,\"V\") ? n : 1" :fortran_help: " SUBROUTINE CGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS, LDVS, WORK, LWORK, RWORK, BWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGEES computes for an N-by-N complex nonsymmetric matrix A, the\n\ * eigenvalues, the Schur form T, and, optionally, the matrix of Schur\n\ * vectors Z. This gives the Schur factorization A = Z*T*(Z**H).\n\ *\n\ * Optionally, it also orders the eigenvalues on the diagonal of the\n\ * Schur form so that selected eigenvalues are at the top left.\n\ * The leading columns of Z then form an orthonormal basis for the\n\ * invariant subspace corresponding to the selected eigenvalues.\n\n\ * A complex matrix is in Schur form if it is upper triangular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVS (input) CHARACTER*1\n\ * = 'N': Schur vectors are not computed;\n\ * = 'V': Schur vectors are computed.\n\ *\n\ * SORT (input) CHARACTER*1\n\ * Specifies whether or not to order the eigenvalues on the\n\ * diagonal of the Schur form.\n\ * = 'N': Eigenvalues are not ordered:\n\ * = 'S': Eigenvalues are ordered (see SELECT).\n\ *\n\ * SELECT (external procedure) LOGICAL FUNCTION of one COMPLEX argument\n\ * SELECT must be declared EXTERNAL in the calling subroutine.\n\ * If SORT = 'S', SELECT is used to select eigenvalues to order\n\ * to the top left of the Schur form.\n\ * IF SORT = 'N', SELECT is not referenced.\n\ * The eigenvalue W(j) is selected if SELECT(W(j)) is true.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ * On exit, A has been overwritten by its Schur form T.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * SDIM (output) INTEGER\n\ * If SORT = 'N', SDIM = 0.\n\ * If SORT = 'S', SDIM = number of eigenvalues for which\n\ * SELECT is true.\n\ *\n\ * W (output) COMPLEX array, dimension (N)\n\ * W contains the computed eigenvalues, in the same order that\n\ * they appear on the diagonal of the output Schur form T.\n\ *\n\ * VS (output) COMPLEX array, dimension (LDVS,N)\n\ * If JOBVS = 'V', VS contains the unitary matrix Z of Schur\n\ * vectors.\n\ * If JOBVS = 'N', VS is not referenced.\n\ *\n\ * LDVS (input) INTEGER\n\ * The leading dimension of the array VS. LDVS >= 1; if\n\ * JOBVS = 'V', LDVS >= N.\n\ *\n\ * WORK (workspace/output) COMPLEX 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,2*N).\n\ * For good performance, LWORK must generally be larger.\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\ * RWORK (workspace) REAL array, dimension (N)\n\ *\n\ * BWORK (workspace) LOGICAL array, dimension (N)\n\ * Not referenced if SORT = 'N'.\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, and i is\n\ * <= N: the QR algorithm failed to compute all the\n\ * eigenvalues; elements 1:ILO-1 and i+1:N of W\n\ * contain those eigenvalues which have converged;\n\ * if JOBVS = 'V', VS contains the matrix which\n\ * reduces A to its partially converged Schur form.\n\ * = N+1: the eigenvalues could not be reordered because\n\ * some eigenvalues were too close to separate (the\n\ * problem is very ill-conditioned);\n\ * = N+2: after reordering, roundoff changed values of\n\ * some complex eigenvalues so that leading\n\ * eigenvalues in the Schur form no longer satisfy\n\ * SELECT = .TRUE.. This could also be caused by\n\ * underflow due to scaling.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlalsa0000644000175000017500000001774612502223526016467 0ustar uwabamiuwabami--- :name: dlalsa :md5sum: 96a29d1579174e468115a64a75f6f345 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - smlsiz: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - bx: :type: doublereal :intent: output :dims: - ldbx - nrhs - ldbx: :type: integer :intent: input - u: :type: doublereal :intent: input :dims: - ldu - smlsiz - ldu: :type: integer :intent: input - vt: :type: doublereal :intent: input :dims: - ldu - smlsiz+1 - k: :type: integer :intent: input :dims: - n - difl: :type: doublereal :intent: input :dims: - ldu - nlvl - difr: :type: doublereal :intent: input :dims: - ldu - 2 * nlvl - z: :type: doublereal :intent: input :dims: - ldu - nlvl - poles: :type: doublereal :intent: input :dims: - ldu - 2 * nlvl - givptr: :type: integer :intent: input :dims: - n - givcol: :type: integer :intent: input :dims: - ldgcol - 2 * nlvl - ldgcol: :type: integer :intent: input - perm: :type: integer :intent: input :dims: - ldgcol - nlvl - givnum: :type: doublereal :intent: input :dims: - ldu - 2 * nlvl - c: :type: doublereal :intent: input :dims: - n - s: :type: doublereal :intent: input :dims: - n - work: :type: doublereal :intent: workspace :dims: - n - iwork: :type: integer :intent: workspace :dims: - 3 * n - info: :type: integer :intent: output :substitutions: ldbx: n nlvl: (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1 :fortran_help: " SUBROUTINE DLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLALSA is an itermediate step in solving the least squares problem\n\ * by computing the SVD of the coefficient matrix in compact form (The\n\ * singular vectors are computed as products of simple orthorgonal\n\ * matrices.).\n\ *\n\ * If ICOMPQ = 0, DLALSA applies the inverse of the left singular vector\n\ * matrix of an upper bidiagonal matrix to the right hand side; and if\n\ * ICOMPQ = 1, DLALSA applies the right singular vector matrix to the\n\ * right hand side. The singular vector matrices were generated in\n\ * compact form by DLALSA.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ *\n\ * ICOMPQ (input) INTEGER\n\ * Specifies whether the left or the right singular vector\n\ * matrix is involved.\n\ * = 0: Left singular vector matrix\n\ * = 1: Right singular vector matrix\n\ *\n\ * SMLSIZ (input) INTEGER\n\ * The maximum size of the subproblems at the bottom of the\n\ * computation tree.\n\ *\n\ * N (input) INTEGER\n\ * The row and column dimensions of the upper bidiagonal matrix.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of columns of B and BX. NRHS must be at least 1.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension ( LDB, NRHS )\n\ * On input, B contains the right hand sides of the least\n\ * squares problem in rows 1 through M.\n\ * On output, B contains the solution X in rows 1 through N.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B in the calling subprogram.\n\ * LDB must be at least max(1,MAX( M, N ) ).\n\ *\n\ * BX (output) DOUBLE PRECISION array, dimension ( LDBX, NRHS )\n\ * On exit, the result of applying the left or right singular\n\ * vector matrix to B.\n\ *\n\ * LDBX (input) INTEGER\n\ * The leading dimension of BX.\n\ *\n\ * U (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ).\n\ * On entry, U contains the left singular vector matrices of all\n\ * subproblems at the bottom level.\n\ *\n\ * LDU (input) INTEGER, LDU = > N.\n\ * The leading dimension of arrays U, VT, DIFL, DIFR,\n\ * POLES, GIVNUM, and Z.\n\ *\n\ * VT (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ).\n\ * On entry, VT' contains the right singular vector matrices of\n\ * all subproblems at the bottom level.\n\ *\n\ * K (input) INTEGER array, dimension ( N ).\n\ *\n\ * DIFL (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).\n\ * where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.\n\ *\n\ * DIFR (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).\n\ * On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record\n\ * distances between singular values on the I-th level and\n\ * singular values on the (I -1)-th level, and DIFR(*, 2 * I)\n\ * record the normalizing factors of the right singular vectors\n\ * matrices of subproblems on I-th level.\n\ *\n\ * Z (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).\n\ * On entry, Z(1, I) contains the components of the deflation-\n\ * adjusted updating row vector for subproblems on the I-th\n\ * level.\n\ *\n\ * POLES (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).\n\ * On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old\n\ * singular values involved in the secular equations on the I-th\n\ * level.\n\ *\n\ * GIVPTR (input) INTEGER array, dimension ( N ).\n\ * On entry, GIVPTR( I ) records the number of Givens\n\ * rotations performed on the I-th problem on the computation\n\ * tree.\n\ *\n\ * GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ).\n\ * On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the\n\ * locations of Givens rotations performed on the I-th level on\n\ * the computation tree.\n\ *\n\ * LDGCOL (input) INTEGER, LDGCOL = > N.\n\ * The leading dimension of arrays GIVCOL and PERM.\n\ *\n\ * PERM (input) INTEGER array, dimension ( LDGCOL, NLVL ).\n\ * On entry, PERM(*, I) records permutations done on the I-th\n\ * level of the computation tree.\n\ *\n\ * GIVNUM (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).\n\ * On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-\n\ * values of Givens rotations performed on the I-th level on the\n\ * computation tree.\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension ( N ).\n\ * On entry, if the I-th subproblem is not square,\n\ * C( I ) contains the C-value of a Givens rotation related to\n\ * the right null space of the I-th subproblem.\n\ *\n\ * S (input) DOUBLE PRECISION array, dimension ( N ).\n\ * On entry, if the I-th subproblem is not square,\n\ * S( I ) contains the S-value of a Givens rotation related to\n\ * the right null space of the I-th subproblem.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array.\n\ * The dimension must be at least N.\n\ *\n\ * IWORK (workspace) INTEGER array.\n\ * The dimension must be at least 3 * N\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\ * Based on contributions by\n\ * Ming Gu and Ren-Cang Li, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssytf20000644000175000017500000001321612502223526016445 0ustar uwabamiuwabami--- :name: ssytf2 :md5sum: b890ad730f432e7fd43aafe12b906d1b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SSYTF2( UPLO, N, A, LDA, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSYTF2 computes the factorization of a real symmetric matrix A using\n\ * the Bunch-Kaufman diagonal pivoting method:\n\ *\n\ * A = U*D*U' or A = L*D*L'\n\ *\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, U' is the transpose of U, and D is symmetric and\n\ * block diagonal with 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\ * This is the unblocked version of the algorithm, calling Level 2 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * n-by-n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n-by-n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L (see below for further details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D.\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ * > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular, and division by zero will occur if it\n\ * is used to solve a system of equations.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * 09-29-06 - patch from\n\ * Bobby Cheng, MathWorks\n\ *\n\ * Replace l.204 and l.372\n\ * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN\n\ * by\n\ * IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN\n\ *\n\ * 01-01-96 - Based on modifications by\n\ * J. Lewis, Boeing Computer Services Company\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ * 1-96 - Based on modifications by J. Lewis, Boeing Computer Services\n\ * Company\n\ *\n\ * If UPLO = 'U', then A = U*D*U', where\n\ * U = P(n)*U(n)* ... *P(k)U(k)* ...,\n\ * i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n\ * 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I v 0 ) k-s\n\ * U(k) = ( 0 I 0 ) s\n\ * ( 0 0 I ) n-k\n\ * k-s s n-k\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n\ * If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n\ * and A(k,k), and v overwrites A(1:k-2,k-1:k).\n\ *\n\ * If UPLO = 'L', then A = L*D*L', where\n\ * L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n\ * i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n\ * n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I 0 0 ) k-1\n\ * L(k) = ( 0 I 0 ) s\n\ * ( 0 v I ) n-k-s+1\n\ * k-1 s n-k-s+1\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n\ * If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n\ * and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clanhf0000644000175000017500000002003112502223525016436 0ustar uwabamiuwabami--- :name: clanhf :md5sum: 88dd9937813f707862d82f94478d3e58 :category: :function :type: real :arguments: - norm: :type: char :intent: input - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - work: :type: real :intent: workspace :dims: - lwork :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " REAL FUNCTION CLANHF( NORM, TRANSR, UPLO, N, A, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLANHF returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * complex Hermitian matrix A in RFP format.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * CLANHF returns the value\n\ *\n\ * CLANHF = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER\n\ * Specifies the value to be returned in CLANHF as described\n\ * above.\n\ *\n\ * TRANSR (input) CHARACTER\n\ * Specifies whether the RFP format of A is normal or\n\ * conjugate-transposed format.\n\ * = 'N': RFP format is Normal\n\ * = 'C': RFP format is Conjugate-transposed\n\ *\n\ * UPLO (input) CHARACTER\n\ * On entry, UPLO specifies whether the RFP matrix A came from\n\ * an upper or lower triangular matrix as follows:\n\ *\n\ * UPLO = 'U' or 'u' RFP A came from an upper triangular\n\ * matrix\n\ *\n\ * UPLO = 'L' or 'l' RFP A came from a lower triangular\n\ * matrix\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, CLANHF is\n\ * set to zero.\n\ *\n\ * A (input) COMPLEX*16 array, dimension ( N*(N+1)/2 );\n\ * On entry, the matrix A in RFP Format.\n\ * RFP Format is described by TRANSR, UPLO and N as follows:\n\ * If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;\n\ * K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If\n\ * TRANSR = 'C' then RFP is the Conjugate-transpose of RFP A\n\ * as defined when TRANSR = 'N'. The contents of RFP A are\n\ * defined by UPLO as follows: If UPLO = 'U' the RFP A\n\ * contains the ( N*(N+1)/2 ) elements of upper packed A\n\ * either in normal or conjugate-transpose Format. If\n\ * UPLO = 'L' the RFP A contains the ( N*(N+1) /2 ) elements\n\ * of lower packed A either in normal or conjugate-transpose\n\ * Format. The LDA of RFP A is (N+1)/2 when TRANSR = 'C'. When\n\ * TRANSR is 'N' the LDA is N+1 when N is even and is N when\n\ * is odd. See the Note below for more details.\n\ * Unchanged on exit.\n\ *\n\ * WORK (workspace) REAL array, dimension (LWORK),\n\ * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n\ * WORK is not referenced.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * We first consider Standard Packed Format when N is even.\n\ * We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * conjugate-transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * conjugate-transpose of the last three columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- --\n\ * 03 04 05 33 43 53\n\ * -- --\n\ * 13 14 15 00 44 54\n\ * --\n\ * 23 24 25 10 11 55\n\ *\n\ * 33 34 35 20 21 22\n\ * --\n\ * 00 44 45 30 31 32\n\ * -- --\n\ * 01 11 55 40 41 42\n\ * -- -- --\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We next consider Standard Packed Format when N is odd.\n\ * We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * conjugate-transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * conjugate-transpose of the last two columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- --\n\ * 02 03 04 00 33 43\n\ * --\n\ * 12 13 14 10 11 44\n\ *\n\ * 22 23 24 20 21 22\n\ * --\n\ * 00 33 34 30 31 32\n\ * -- --\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- --\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sppsv0000644000175000017500000000753412502223526016374 0ustar uwabamiuwabami--- :name: sppsv :md5sum: 87516007e377bd390aec2344e7fd7157 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - n*(n+1)/2 - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPPSV( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPPSV computes the solution to a real system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N symmetric positive definite matrix stored in\n\ * packed format and X and B are N-by-NRHS matrices.\n\ *\n\ * The Cholesky decomposition is used to factor A as\n\ * A = U**T* U, if UPLO = 'U', or\n\ * A = L * L**T, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is a lower triangular\n\ * matrix. The factored form of A is then used to solve the system of\n\ * equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AP (input/output) REAL array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ * See below for further details. \n\ *\n\ * On exit, if INFO = 0, the factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T, in the same storage\n\ * format as A.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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 leading minor of order i of A is not\n\ * positive definite, so the factorization could not be\n\ * completed, and the solution has not been computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The packed storage scheme is illustrated by the following example\n\ * when N = 4, UPLO = 'U':\n\ *\n\ * Two-dimensional storage of the symmetric matrix A:\n\ *\n\ * a11 a12 a13 a14\n\ * a22 a23 a24\n\ * a33 a34 (aij = conjg(aji))\n\ * a44\n\ *\n\ * Packed storage of the upper triangle of A:\n\ *\n\ * AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n\ *\n\ * =====================================================================\n\ *\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SPPTRF, SPPTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cladiv0000644000175000017500000000174412502223525016457 0ustar uwabamiuwabami--- :name: cladiv :md5sum: 3c908b32d86634d06c097310466421b6 :category: :function :type: complex :arguments: - x: :type: complex :intent: input - y: :type: complex :intent: input :substitutions: {} :fortran_help: " COMPLEX FUNCTION CLADIV( X, Y )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLADIV := X / Y, where X and Y are complex. The computation of X / Y\n\ * will not overflow on an intermediary step unless the results\n\ * overflows.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * X (input) COMPLEX\n\ * Y (input) COMPLEX\n\ * The complex scalars X and Y.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n REAL ZI, ZR\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SLADIV\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC AIMAG, CMPLX, REAL\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlatrz0000644000175000017500000000665012502223526016517 0ustar uwabamiuwabami--- :name: dlatrz :md5sum: 29240b38847f5fec70a609188c5ec3c5 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - m - work: :type: doublereal :intent: workspace :dims: - m :substitutions: m: lda :fortran_help: " SUBROUTINE DLATRZ( M, N, L, A, LDA, TAU, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLATRZ factors the M-by-(M+L) real upper trapezoidal matrix\n\ * [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z, by means\n\ * of orthogonal transformations. Z is an (M+L)-by-(M+L) orthogonal\n\ * matrix and, R and A1 are M-by-M upper triangular matrices.\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\ * L (input) INTEGER\n\ * The number of columns of the matrix A containing the\n\ * meaningful part of the Householder vectors. N-M >= L >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the leading M-by-N upper trapezoidal part of the\n\ * array A must contain the matrix to be factorized.\n\ * On exit, the leading M-by-M upper triangular part of A\n\ * contains the upper triangular matrix R, and elements N-L+1 to\n\ * N of the first M rows of A, with the array TAU, represent the\n\ * orthogonal matrix Z as a product of M elementary reflectors.\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 (M)\n\ * The scalar factors of the elementary reflectors.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (M)\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * The factorization is obtained by Householder's method. The kth\n\ * transformation matrix, Z( k ), which is used to introduce zeros into\n\ * the ( m - k + 1 )th row of A, is given in the form\n\ *\n\ * Z( k ) = ( I 0 ),\n\ * ( 0 T( k ) )\n\ *\n\ * where\n\ *\n\ * T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n\ * ( 0 )\n\ * ( z( k ) )\n\ *\n\ * tau is a scalar and z( k ) is an l element vector. tau and z( k )\n\ * are chosen to annihilate the elements of the kth row of A2.\n\ *\n\ * The scalar tau is returned in the kth element of TAU and the vector\n\ * u( k ) in the kth row of A2, such that the elements of z( k ) are\n\ * in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in\n\ * the upper triangular part of A1.\n\ *\n\ * Z is given by\n\ *\n\ * Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clantr0000644000175000017500000000726012502223525016477 0ustar uwabamiuwabami--- :name: clantr :md5sum: 2952a019c52f6bc7681a557329258545 :category: :function :type: real :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? m : 0" :fortran_help: " REAL FUNCTION CLANTR( NORM, UPLO, DIAG, M, N, A, LDA, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLANTR returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * trapezoidal or triangular matrix A.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * CLANTR returns the value\n\ *\n\ * CLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in CLANTR as described\n\ * above.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the matrix A is upper or lower trapezoidal.\n\ * = 'U': Upper trapezoidal\n\ * = 'L': Lower trapezoidal\n\ * Note that A is triangular instead of trapezoidal if M = N.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * Specifies whether or not the matrix A has unit diagonal.\n\ * = 'N': Non-unit diagonal\n\ * = 'U': Unit diagonal\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A. M >= 0, and if\n\ * UPLO = 'U', M <= N. When M = 0, CLANTR is set to zero.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix A. N >= 0, and if\n\ * UPLO = 'L', N <= M. When N = 0, CLANTR is set to zero.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The trapezoidal matrix A (A is triangular if M = N).\n\ * If UPLO = 'U', the leading m by n upper trapezoidal part of\n\ * the array A contains the upper trapezoidal matrix, and the\n\ * strictly lower triangular part of A is not referenced.\n\ * If UPLO = 'L', the leading m by n lower trapezoidal part of\n\ * the array A contains the lower trapezoidal matrix, and the\n\ * strictly upper triangular part of A is not referenced. Note\n\ * that when DIAG = 'U', the diagonal elements of A are not\n\ * referenced and are assumed to be one.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(M,1).\n\ *\n\ * WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n\ * referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/disnan0000644000175000017500000000135512502223526016470 0ustar uwabamiuwabami--- :name: disnan :md5sum: 6226d5dde19479c96fbf22f35fdf0c6c :category: :function :type: logical :arguments: - din: :type: doublereal :intent: input :substitutions: {} :fortran_help: " LOGICAL FUNCTION DISNAN( DIN )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DISNAN returns .TRUE. if its argument is NaN, and .FALSE.\n\ * otherwise. To be replaced by the Fortran 2003 intrinsic in the\n\ * future.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * DIN (input) DOUBLE PRECISION\n\ * Input to test for NaN.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. External Functions ..\n LOGICAL DLAISNAN\n EXTERNAL DLAISNAN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dla_porfsx_extended0000644000175000017500000003466112502223526021243 0ustar uwabamiuwabami--- :name: dla_porfsx_extended :md5sum: ee3648f5d40164c388f6fca867c879bb :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - colequ: :type: logical :intent: input - c: :type: doublereal :intent: input :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: doublereal :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: doublereal :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: input/output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: input/output :dims: - nrhs - n_err_bnds - res: :type: doublereal :intent: input :dims: - n - ayb: :type: doublereal :intent: input :dims: - n - dy: :type: doublereal :intent: input :dims: - n - y_tail: :type: doublereal :intent: input :dims: - n - rcond: :type: doublereal :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: doublereal :intent: input - dz_ub: :type: doublereal :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLA_PORFSX_EXTENDED improves the computed solution to a system of\n\ * linear equations by performing extra-precise iterative refinement\n\ * and provides error bounds and backward error estimates for the solution.\n\ * This subroutine is called by DPORFSX to perform iterative refinement.\n\ * In addition to normwise error bound, the code provides maximum\n\ * componentwise error bound if possible. See comments for ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP for details of the error bounds. Note that this\n\ * subroutine is only resonsible for setting the second fields of\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * PREC_TYPE (input) INTEGER\n\ * Specifies the intermediate precision to be used in refinement.\n\ * The value is defined by ILAPREC(P) where P is a CHARACTER and\n\ * P = 'S': Single\n\ * = 'D': Double\n\ * = 'I': Indigenous\n\ * = 'X', 'E': Extra\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right-hand-sides, i.e., the number of columns of the\n\ * matrix B.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T, as computed by DPOTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * COLEQU (input) LOGICAL\n\ * If .TRUE. then column equilibration was done to A before calling\n\ * this routine. This is needed to compute the solution and error\n\ * bounds correctly.\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension (N)\n\ * The column scale factors for A. If COLEQU = .FALSE., C\n\ * is not accessed. If C is input, each element of C should be a power\n\ * of the radix to ensure a reliable solution and error estimates.\n\ * Scaling by powers of the radix does not cause rounding errors unless\n\ * the result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * The right-hand-side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * Y (input/output) DOUBLE PRECISION array, dimension\n\ * (LDY,NRHS)\n\ * On entry, the solution matrix X, as computed by DPOTRS.\n\ * On exit, the improved solution matrix Y.\n\ *\n\ * LDY (input) INTEGER\n\ * The leading dimension of the array Y. LDY >= max(1,N).\n\ *\n\ * BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * On exit, BERR_OUT(j) contains the componentwise relative backward\n\ * error for right-hand-side j from the formula\n\ * max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n\ * where abs(Z) is the componentwise absolute value of the matrix\n\ * or vector Z. This is computed by DLA_LIN_BERR.\n\ *\n\ * N_NORMS (input) INTEGER\n\ * Determines which error bounds to return (see ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP).\n\ * If N_NORMS >= 1 return normwise error bounds.\n\ * If N_NORMS >= 2 return componentwise error bounds.\n\ *\n\ * ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension\n\ * (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension\n\ * (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * RES (input) DOUBLE PRECISION array, dimension (N)\n\ * Workspace to hold the intermediate residual.\n\ *\n\ * AYB (input) DOUBLE PRECISION array, dimension (N)\n\ * Workspace. This can be the same workspace passed for Y_TAIL.\n\ *\n\ * DY (input) DOUBLE PRECISION array, dimension (N)\n\ * Workspace to hold the intermediate solution.\n\ *\n\ * Y_TAIL (input) DOUBLE PRECISION array, dimension (N)\n\ * Workspace to hold the trailing bits of the intermediate solution.\n\ *\n\ * RCOND (input) DOUBLE PRECISION\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * ITHRESH (input) INTEGER\n\ * The maximum number of residual computations allowed for\n\ * refinement. The default is 10. For 'aggressive' set to 100 to\n\ * permit convergence using approximate factorizations or\n\ * factorizations other than LU. If the factorization uses a\n\ * technique other than Gaussian elimination, the guarantees in\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n\ *\n\ * RTHRESH (input) DOUBLE PRECISION\n\ * Determines when to stop refinement if the error estimate stops\n\ * decreasing. Refinement will stop when the next solution no longer\n\ * satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n\ * the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n\ * default value is 0.5. For 'aggressive' set to 0.9 to permit\n\ * convergence on extremely ill-conditioned matrices. See LAWN 165\n\ * for more details.\n\ *\n\ * DZ_UB (input) DOUBLE PRECISION\n\ * Determines when to start considering componentwise convergence.\n\ * Componentwise convergence is only considered after each component\n\ * of the solution Y is stable, which we definte as the relative\n\ * change in each component being less than DZ_UB. The default value\n\ * is 0.25, requiring the first bit to be stable. See LAWN 165 for\n\ * more details.\n\ *\n\ * IGNORE_CWISE (input) LOGICAL\n\ * If .TRUE. then ignore componentwise convergence. Default value\n\ * is .FALSE..\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * < 0: if INFO = -i, the ith argument to DPOTRS had an illegal\n\ * value\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE\n DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/spteqr0000644000175000017500000001040712502223526016530 0ustar uwabamiuwabami--- :name: spteqr :md5sum: 602a7d1d94751729b99e8b4b6eb7a9b3 :category: :subroutine :arguments: - compz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - z: :type: real :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPTEQR computes all eigenvalues and, optionally, eigenvectors of a\n\ * symmetric positive definite tridiagonal matrix by first factoring the\n\ * matrix using SPTTRF, and then calling SBDSQR to compute the singular\n\ * values of the bidiagonal factor.\n\ *\n\ * This routine computes the eigenvalues of the positive definite\n\ * tridiagonal matrix to high relative accuracy. This means that if the\n\ * eigenvalues range over many orders of magnitude in size, then the\n\ * small eigenvalues and corresponding eigenvectors will be computed\n\ * more accurately than, for example, with the standard QR method.\n\ *\n\ * The eigenvectors of a full or band symmetric positive definite matrix\n\ * can also be found if SSYTRD, SSPTRD, or SSBTRD has been used to\n\ * reduce this matrix to tridiagonal form. (The reduction to tridiagonal\n\ * form, however, may preclude the possibility of obtaining high\n\ * relative accuracy in the small eigenvalues of the original matrix, if\n\ * these eigenvalues range over many orders of magnitude.)\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * COMPZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only.\n\ * = 'V': Compute eigenvectors of original symmetric\n\ * matrix also. Array Z contains the orthogonal\n\ * matrix used to reduce the original matrix to\n\ * tridiagonal form.\n\ * = 'I': Compute eigenvectors of tridiagonal matrix also.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the n diagonal elements of the tridiagonal\n\ * matrix.\n\ * On normal exit, D contains the eigenvalues, in descending\n\ * order.\n\ *\n\ * E (input/output) REAL array, dimension (N-1)\n\ * On entry, the (n-1) subdiagonal elements of the tridiagonal\n\ * matrix.\n\ * On exit, E has been destroyed.\n\ *\n\ * Z (input/output) REAL array, dimension (LDZ, N)\n\ * On entry, if COMPZ = 'V', the orthogonal matrix used in the\n\ * reduction to tridiagonal form.\n\ * On exit, if COMPZ = 'V', the orthonormal eigenvectors of the\n\ * original symmetric matrix;\n\ * if COMPZ = 'I', the orthonormal eigenvectors of the\n\ * tridiagonal matrix.\n\ * If INFO > 0 on exit, Z contains the eigenvectors associated\n\ * with only the stored eigenvalues.\n\ * If COMPZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * COMPZ = 'V' or 'I', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) REAL array, dimension (4*N)\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, and i is:\n\ * <= N the Cholesky factorization of the matrix could\n\ * not be performed because the i-th principal minor\n\ * was not positive definite.\n\ * > N the SVD algorithm failed to converge;\n\ * if INFO = N+i, i off-diagonal elements of the\n\ * bidiagonal factor did not converge to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ztrevc0000644000175000017500000001474712502223526016542 0ustar uwabamiuwabami--- :name: ztrevc :md5sum: ec49fff50379686734c9e1b3cd5bcaad :category: :subroutine :arguments: - side: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - t: :type: doublecomplex :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - vl: :type: doublecomplex :intent: input/output :dims: - ldvl - mm - ldvl: :type: integer :intent: input - vr: :type: doublecomplex :intent: input/output :dims: - ldvr - mm - ldvr: :type: integer :intent: input - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTREVC computes some or all of the right and/or left eigenvectors of\n\ * a complex upper triangular matrix T.\n\ * Matrices of this type are produced by the Schur factorization of\n\ * a complex general matrix: A = Q*T*Q**H, as computed by ZHSEQR.\n\ * \n\ * The right eigenvector x and the left eigenvector y of T corresponding\n\ * to an eigenvalue w are defined by:\n\ * \n\ * T*x = w*x, (y**H)*T = w*(y**H)\n\ * \n\ * where y**H denotes the conjugate transpose of the vector y.\n\ * The eigenvalues are not input to this routine, but are read directly\n\ * from the diagonal of T.\n\ * \n\ * This routine returns the matrices X and/or Y of right and left\n\ * eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an\n\ * input matrix. If Q is the unitary factor that reduces a matrix A to\n\ * Schur form T, then Q*X and Q*Y are the matrices of right and left\n\ * eigenvectors of A.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'R': compute right eigenvectors only;\n\ * = 'L': compute left eigenvectors only;\n\ * = 'B': compute both right and left eigenvectors.\n\ *\n\ * HOWMNY (input) CHARACTER*1\n\ * = 'A': compute all right and/or left eigenvectors;\n\ * = 'B': compute all right and/or left eigenvectors,\n\ * backtransformed using the matrices supplied in\n\ * VR and/or VL;\n\ * = 'S': compute selected right and/or left eigenvectors,\n\ * as indicated by the logical array SELECT.\n\ *\n\ * SELECT (input) LOGICAL array, dimension (N)\n\ * If HOWMNY = 'S', SELECT specifies the eigenvectors to be\n\ * computed.\n\ * The eigenvector corresponding to the j-th eigenvalue is\n\ * computed if SELECT(j) = .TRUE..\n\ * Not referenced if HOWMNY = 'A' or 'B'.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix T. N >= 0.\n\ *\n\ * T (input/output) COMPLEX*16 array, dimension (LDT,N)\n\ * The upper triangular matrix T. T is modified, but restored\n\ * on exit.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= max(1,N).\n\ *\n\ * VL (input/output) COMPLEX*16 array, dimension (LDVL,MM)\n\ * On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n\ * contain an N-by-N matrix Q (usually the unitary matrix Q of\n\ * Schur vectors returned by ZHSEQR).\n\ * On exit, if SIDE = 'L' or 'B', VL contains:\n\ * if HOWMNY = 'A', the matrix Y of left eigenvectors of T;\n\ * if HOWMNY = 'B', the matrix Q*Y;\n\ * if HOWMNY = 'S', the left eigenvectors of T specified by\n\ * SELECT, stored consecutively in the columns\n\ * of VL, in the same order as their\n\ * eigenvalues.\n\ * Not referenced if SIDE = 'R'.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the array VL. LDVL >= 1, and if\n\ * SIDE = 'L' or 'B', LDVL >= N.\n\ *\n\ * VR (input/output) COMPLEX*16 array, dimension (LDVR,MM)\n\ * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n\ * contain an N-by-N matrix Q (usually the unitary matrix Q of\n\ * Schur vectors returned by ZHSEQR).\n\ * On exit, if SIDE = 'R' or 'B', VR contains:\n\ * if HOWMNY = 'A', the matrix X of right eigenvectors of T;\n\ * if HOWMNY = 'B', the matrix Q*X;\n\ * if HOWMNY = 'S', the right eigenvectors of T specified by\n\ * SELECT, stored consecutively in the columns\n\ * of VR, in the same order as their\n\ * eigenvalues.\n\ * Not referenced if SIDE = 'L'.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the array VR. LDVR >= 1, and if\n\ * SIDE = 'R' or 'B'; LDVR >= N.\n\ *\n\ * MM (input) INTEGER\n\ * The number of columns in the arrays VL and/or VR. MM >= M.\n\ *\n\ * M (output) INTEGER\n\ * The number of columns in the arrays VL and/or VR actually\n\ * used to store the eigenvectors. If HOWMNY = 'A' or 'B', M\n\ * is set to N. Each selected eigenvector occupies one\n\ * column.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\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 algorithm used in this program is basically backward (forward)\n\ * substitution, with scaling to make the the code robust against\n\ * possible overflow.\n\ *\n\ * Each eigenvector is normalized so that the element of largest\n\ * magnitude has magnitude 1; here the magnitude of a complex number\n\ * (x,y) is taken to be |x| + |y|.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlaqr40000644000175000017500000001746512502223526016442 0ustar uwabamiuwabami--- :name: zlaqr4 :md5sum: a1ca2c176247952b0c88578286a3070f :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: doublecomplex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - w: :type: doublecomplex :intent: output :dims: - n - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: doublecomplex :intent: input/output :dims: - ldz - ihi - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: ldz: "wantz ? MAX(1,ihiz) : 1" :fortran_help: " SUBROUTINE ZLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAQR4 computes the eigenvalues of a Hessenberg matrix H\n\ * and, optionally, the matrices T and Z from the Schur decomposition\n\ * H = Z T Z**H, where T is an upper triangular matrix (the\n\ * Schur form), and Z is the unitary matrix of Schur vectors.\n\ *\n\ * Optionally Z may be postmultiplied into an input unitary\n\ * matrix Q so that this routine can give the Schur factorization\n\ * of a matrix A which has been reduced to the Hessenberg form H\n\ * by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * WANTT (input) LOGICAL\n\ * = .TRUE. : the full Schur form T is required;\n\ * = .FALSE.: only eigenvalues are required.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * = .TRUE. : the matrix of Schur vectors Z is required;\n\ * = .FALSE.: Schur vectors are not required.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H. N .GE. 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * It is assumed that H is already upper triangular in rows\n\ * and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n\ * H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n\ * previous call to ZGEBAL, and then passed to ZGEHRD when the\n\ * matrix output by ZGEBAL is reduced to Hessenberg form.\n\ * Otherwise, ILO and IHI should be set to 1 and N,\n\ * respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n\ * If N = 0, then ILO = 1 and IHI = 0.\n\ *\n\ * H (input/output) COMPLEX*16 array, dimension (LDH,N)\n\ * On entry, the upper Hessenberg matrix H.\n\ * On exit, if INFO = 0 and WANTT is .TRUE., then H\n\ * contains the upper triangular matrix T from the Schur\n\ * decomposition (the Schur form). If INFO = 0 and WANT is\n\ * .FALSE., then the contents of H are unspecified on exit.\n\ * (The output value of H when INFO.GT.0 is given under the\n\ * description of INFO below.)\n\ *\n\ * This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n\ * j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n\ *\n\ * LDH (input) INTEGER\n\ * The leading dimension of the array H. LDH .GE. max(1,N).\n\ *\n\ * W (output) COMPLEX*16 array, dimension (N)\n\ * The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored\n\ * in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are\n\ * stored in the same order as on the diagonal of the Schur\n\ * form returned in H, with W(i) = H(i,i).\n\ *\n\ * Z (input/output) COMPLEX*16 array, dimension (LDZ,IHI)\n\ * If WANTZ is .FALSE., then Z is not referenced.\n\ * If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n\ * replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n\ * orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n\ * (The output value of Z when INFO.GT.0 is given under\n\ * the description of INFO below.)\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. if WANTZ is .TRUE.\n\ * then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 array, dimension LWORK\n\ * On exit, if LWORK = -1, WORK(1) returns an estimate of\n\ * the optimal value for LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK .GE. max(1,N)\n\ * is sufficient, but LWORK typically as large as 6*N may\n\ * be required for optimal performance. A workspace query\n\ * to determine the optimal workspace size is recommended.\n\ *\n\ * If LWORK = -1, then ZLAQR4 does a workspace query.\n\ * In this case, ZLAQR4 checks the input parameters and\n\ * estimates the optimal workspace size for the given\n\ * values of N, ILO and IHI. The estimate is returned\n\ * in WORK(1). No error message related to LWORK is\n\ * issued by XERBLA. Neither H nor Z are accessed.\n\ *\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * .GT. 0: if INFO = i, ZLAQR4 failed to compute all of\n\ * the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n\ * and WI contain those eigenvalues which have been\n\ * successfully computed. (Failures are rare.)\n\ *\n\ * If INFO .GT. 0 and WANT is .FALSE., then on exit,\n\ * the remaining unconverged eigenvalues are the eigen-\n\ * values of the upper Hessenberg matrix rows and\n\ * columns ILO through INFO of the final, output\n\ * value of H.\n\ *\n\ * If INFO .GT. 0 and WANTT is .TRUE., then on exit\n\ *\n\ * (*) (initial value of H)*U = U*(final value of H)\n\ *\n\ * where U is a unitary matrix. The final\n\ * value of H is upper Hessenberg and triangular in\n\ * rows and columns INFO+1 through IHI.\n\ *\n\ * If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n\ *\n\ * (final value of Z(ILO:IHI,ILOZ:IHIZ)\n\ * = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n\ *\n\ * where U is the unitary matrix in (*) (regard-\n\ * less of the value of WANTT.)\n\ *\n\ * If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n\ * accessed.\n\ *\n\n\ * ================================================================\n\ * Based on contributions by\n\ * Karen Braman and Ralph Byers, Department of Mathematics,\n\ * University of Kansas, USA\n\ *\n\ * ================================================================\n\ * References:\n\ * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n\ * Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n\ * Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n\ * 929--947, 2002.\n\ *\n\ * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n\ * Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n\ * of Matrix Analysis, volume 23, pages 948--973, 2002.\n\ *\n\ * ================================================================\n" ruby-lapack-1.7.2/dev/defs/ssbgvd0000644000175000017500000001670012502223526016504 0ustar uwabamiuwabami--- :name: ssbgvd :md5sum: 5bfbda491946682057cb1045bd9f84a5 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: real :intent: input/output :dims: - ldbb - n - ldbb: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 3*n : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "(lsame_(&jobz,\"N\")||n<=0) ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" :fortran_help: " SUBROUTINE SSBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSBGVD computes all the eigenvalues, and optionally, the eigenvectors\n\ * of a real generalized symmetric-definite banded eigenproblem, of the\n\ * form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric and\n\ * banded, and B is also positive definite. If eigenvectors are\n\ * desired, it uses a divide and conquer algorithm.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * KA (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n\ *\n\ * KB (input) INTEGER\n\ * The number of superdiagonals of the matrix B if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n\ *\n\ * AB (input/output) REAL array, dimension (LDAB, N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first ka+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n\ *\n\ * On exit, the contents of AB are destroyed.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KA+1.\n\ *\n\ * BB (input/output) REAL array, dimension (LDBB, N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix B, stored in the first kb+1 rows of the array. The\n\ * j-th column of B is stored in the j-th column of the array BB\n\ * as follows:\n\ * if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n\ * if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n\ *\n\ * On exit, the factor S from the split Cholesky factorization\n\ * B = S**T*S, as returned by SPBSTF.\n\ *\n\ * LDBB (input) INTEGER\n\ * The leading dimension of the array BB. LDBB >= KB+1.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) REAL array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n\ * eigenvectors, with the i-th column of Z holding the\n\ * eigenvector associated with W(i). The eigenvectors are\n\ * normalized so Z**T*B*Z = I.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace/output) REAL 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\ * If N <= 1, LWORK >= 1.\n\ * If JOBZ = 'N' and N > 1, LWORK >= 3*N.\n\ * If JOBZ = 'V' and N > 1, LWORK >= 1 + 5*N + 2*N**2.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the optimal sizes of the WORK and IWORK\n\ * arrays, returns these values as the first entries of the WORK\n\ * and IWORK arrays, and no error message related to LWORK or\n\ * LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK.\n\ * If JOBZ = 'N' or N <= 1, LIWORK >= 1.\n\ * If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK and IWORK arrays, and no error message related to\n\ * LWORK or LIWORK 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, and i is:\n\ * <= N: the algorithm failed to converge:\n\ * i off-diagonal elements of an intermediate\n\ * tridiagonal form did not converge to zero;\n\ * > N: if INFO = N + i, for 1 <= i <= N, then SPBSTF\n\ * returned INFO = i: B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssygst0000644000175000017500000000572012502223526016550 0ustar uwabamiuwabami--- :name: ssygst :md5sum: 710385c5ac37be3867975f6350fe08d6 :category: :subroutine :arguments: - itype: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSYGST reduces a real symmetric-definite generalized eigenproblem\n\ * to standard form.\n\ *\n\ * If ITYPE = 1, the problem is A*x = lambda*B*x,\n\ * and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)\n\ *\n\ * If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n\ * B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.\n\ *\n\ * B must have been previously factorized as U**T*U or L*L**T by SPOTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);\n\ * = 2 or 3: compute U*A*U**T or L**T*A*L.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored and B is factored as\n\ * U**T*U;\n\ * = 'L': Lower triangle of A is stored and B is factored as\n\ * L*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the transformed matrix, stored in the\n\ * same format as A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input) REAL array, dimension (LDB,N)\n\ * The triangular factor from the Cholesky factorization of B,\n\ * as returned by SPOTRF.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zla_gbrfsx_extended0000644000175000017500000003627212502223526021243 0ustar uwabamiuwabami--- :name: zla_gbrfsx_extended :md5sum: 583c722c3f706254fb3dd1f1bdb61bf9 :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - trans_type: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublecomplex :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - colequ: :type: logical :intent: input - c: :type: doublereal :intent: input :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: doublecomplex :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: doublereal :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: input/output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: input/output :dims: - nrhs - n_err_bnds - res: :type: doublecomplex :intent: input :dims: - n - ayb: :type: doublereal :intent: input :dims: - n - dy: :type: doublecomplex :intent: input :dims: - n - y_tail: :type: doublecomplex :intent: input :dims: - n - rcond: :type: doublereal :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: doublereal :intent: input - dz_ub: :type: doublereal :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: n: ldab ldafb: MAX(1,n) :fortran_help: " SUBROUTINE ZLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLA_GBRFSX_EXTENDED improves the computed solution to a system of\n\ * linear equations by performing extra-precise iterative refinement\n\ * and provides error bounds and backward error estimates for the solution.\n\ * This subroutine is called by ZGBRFSX to perform iterative refinement.\n\ * In addition to normwise error bound, the code provides maximum\n\ * componentwise error bound if possible. See comments for ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP for details of the error bounds. Note that this\n\ * subroutine is only resonsible for setting the second fields of\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * PREC_TYPE (input) INTEGER\n\ * Specifies the intermediate precision to be used in refinement.\n\ * The value is defined by ILAPREC(P) where P is a CHARACTER and\n\ * P = 'S': Single\n\ * = 'D': Double\n\ * = 'I': Indigenous\n\ * = 'X', 'E': Extra\n\ *\n\ * TRANS_TYPE (input) INTEGER\n\ * Specifies the transposition operation on A.\n\ * The value is defined by ILATRANS(T) where T is a CHARACTER and\n\ * T = 'N': No transpose\n\ * = 'T': Transpose\n\ * = 'C': Conjugate transpose\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right-hand-sides, i.e., the number of columns of the\n\ * matrix B.\n\ *\n\ * AB (input) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AFB (input) COMPLEX*16 array, dimension (LDAF,N)\n\ * The factors L and U from the factorization\n\ * A = P*L*U as computed by ZGBTRF.\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from the factorization A = P*L*U\n\ * as computed by ZGBTRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * COLEQU (input) LOGICAL\n\ * If .TRUE. then column equilibration was done to A before calling\n\ * this routine. This is needed to compute the solution and error\n\ * bounds correctly.\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension (N)\n\ * The column scale factors for A. If COLEQU = .FALSE., C\n\ * is not accessed. If C is input, each element of C should be a power\n\ * of the radix to ensure a reliable solution and error estimates.\n\ * Scaling by powers of the radix does not cause rounding errors unless\n\ * the result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The right-hand-side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * Y (input/output) COMPLEX*16 array, dimension (LDY,NRHS)\n\ * On entry, the solution matrix X, as computed by ZGBTRS.\n\ * On exit, the improved solution matrix Y.\n\ *\n\ * LDY (input) INTEGER\n\ * The leading dimension of the array Y. LDY >= max(1,N).\n\ *\n\ * BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * On exit, BERR_OUT(j) contains the componentwise relative backward\n\ * error for right-hand-side j from the formula\n\ * max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n\ * where abs(Z) is the componentwise absolute value of the matrix\n\ * or vector Z. This is computed by ZLA_LIN_BERR.\n\ *\n\ * N_NORMS (input) INTEGER\n\ * Determines which error bounds to return (see ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP).\n\ * If N_NORMS >= 1 return normwise error bounds.\n\ * If N_NORMS >= 2 return componentwise error bounds.\n\ *\n\ * ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension\n\ * (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension\n\ * (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * RES (input) COMPLEX*16 array, dimension (N)\n\ * Workspace to hold the intermediate residual.\n\ *\n\ * AYB (input) DOUBLE PRECISION array, dimension (N)\n\ * Workspace.\n\ *\n\ * DY (input) COMPLEX*16 array, dimension (N)\n\ * Workspace to hold the intermediate solution.\n\ *\n\ * Y_TAIL (input) COMPLEX*16 array, dimension (N)\n\ * Workspace to hold the trailing bits of the intermediate solution.\n\ *\n\ * RCOND (input) DOUBLE PRECISION\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * ITHRESH (input) INTEGER\n\ * The maximum number of residual computations allowed for\n\ * refinement. The default is 10. For 'aggressive' set to 100 to\n\ * permit convergence using approximate factorizations or\n\ * factorizations other than LU. If the factorization uses a\n\ * technique other than Gaussian elimination, the guarantees in\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n\ *\n\ * RTHRESH (input) DOUBLE PRECISION\n\ * Determines when to stop refinement if the error estimate stops\n\ * decreasing. Refinement will stop when the next solution no longer\n\ * satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n\ * the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n\ * default value is 0.5. For 'aggressive' set to 0.9 to permit\n\ * convergence on extremely ill-conditioned matrices. See LAWN 165\n\ * for more details.\n\ *\n\ * DZ_UB (input) DOUBLE PRECISION\n\ * Determines when to start considering componentwise convergence.\n\ * Componentwise convergence is only considered after each component\n\ * of the solution Y is stable, which we definte as the relative\n\ * change in each component being less than DZ_UB. The default value\n\ * is 0.25, requiring the first bit to be stable. See LAWN 165 for\n\ * more details.\n\ *\n\ * IGNORE_CWISE (input) LOGICAL\n\ * If .TRUE. then ignore componentwise convergence. Default value\n\ * is .FALSE..\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * < 0: if INFO = -i, the ith argument to ZGBTRS had an illegal\n\ * value\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n CHARACTER TRANS\n INTEGER CNT, I, J, M, X_STATE, Z_STATE, Y_PREC_STATE\n DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n COMPLEX*16 ZDUM\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zunm2r0000644000175000017500000000732312502223526016452 0ustar uwabamiuwabami--- :name: zunm2r :md5sum: f0c7b1706a9a0b57a6e942c453151964 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZUNM2R overwrites the general complex m-by-n matrix C with\n\ *\n\ * Q * C if SIDE = 'L' and TRANS = 'N', or\n\ *\n\ * Q'* C if SIDE = 'L' and TRANS = 'C', or\n\ *\n\ * C * Q if SIDE = 'R' and TRANS = 'N', or\n\ *\n\ * C * Q' if SIDE = 'R' and TRANS = 'C',\n\ *\n\ * where Q is a complex unitary matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by ZGEQRF. Q is of order m if SIDE = 'L' and of order n\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q' from the Left\n\ * = 'R': apply Q or Q' from the Right\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': apply Q (No transpose)\n\ * = 'C': apply Q' (Conjugate transpose)\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,K)\n\ * The i-th column must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * ZGEQRF in the first k columns of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ * If SIDE = 'L', LDA >= max(1,M);\n\ * if SIDE = 'R', LDA >= max(1,N).\n\ *\n\ * TAU (input) COMPLEX*16 array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by ZGEQRF.\n\ *\n\ * C (input/output) COMPLEX*16 array, dimension (LDC,N)\n\ * On entry, the m-by-n matrix C.\n\ * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension\n\ * (N) if SIDE = 'L',\n\ * (M) if SIDE = 'R'\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgttrs0000644000175000017500000000704412502223526016552 0ustar uwabamiuwabami--- :name: zgttrs :md5sum: 0ca17e08872927fc933bf9e16738ea54 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: doublecomplex :intent: input :dims: - n-1 - d: :type: doublecomplex :intent: input :dims: - n - du: :type: doublecomplex :intent: input :dims: - n-1 - du2: :type: doublecomplex :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGTTRS solves one of the systems of equations\n\ * A * X = B, A**T * X = B, or A**H * X = B,\n\ * with a tridiagonal matrix A using the LU factorization computed\n\ * by ZGTTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations.\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * DL (input) COMPLEX*16 array, dimension (N-1)\n\ * The (n-1) multipliers that define the matrix L from the\n\ * LU factorization of A.\n\ *\n\ * D (input) COMPLEX*16 array, dimension (N)\n\ * The n diagonal elements of the upper triangular matrix U from\n\ * the LU factorization of A.\n\ *\n\ * DU (input) COMPLEX*16 array, dimension (N-1)\n\ * The (n-1) elements of the first super-diagonal of U.\n\ *\n\ * DU2 (input) COMPLEX*16 array, dimension (N-2)\n\ * The (n-2) elements of the second super-diagonal of U.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices; for 1 <= i <= n, row i of the matrix was\n\ * interchanged with row IPIV(i). IPIV(i) will always be either\n\ * i or i+1; IPIV(i) = i indicates a row interchange was not\n\ * required.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the matrix of right hand side vectors B.\n\ * On exit, B is overwritten by the solution vectors X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL NOTRAN\n INTEGER ITRANS, J, JB, NB\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZGTTS2\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slarzb0000644000175000017500000001025212502223526016505 0ustar uwabamiuwabami--- :name: slarzb :md5sum: 902d5ca8735017153470221c8083e9c9 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - direct: :type: char :intent: input - storev: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - v: :type: real :intent: input :dims: - ldv - nv - ldv: :type: integer :intent: input - t: :type: real :intent: input :dims: - ldt - k - ldt: :type: integer :intent: input - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - ldwork - k - ldwork: :type: integer :intent: input :substitutions: ldwork: "MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0" :fortran_help: " SUBROUTINE SLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLARZB applies a real block reflector H or its transpose H**T to\n\ * a real distributed M-by-N C from the left or the right.\n\ *\n\ * Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply H or H' from the Left\n\ * = 'R': apply H or H' from the Right\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': apply H (No transpose)\n\ * = 'C': apply H' (Transpose)\n\ *\n\ * DIRECT (input) CHARACTER*1\n\ * Indicates how H is formed from a product of elementary\n\ * reflectors\n\ * = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n\ * = 'B': H = H(k) . . . H(2) H(1) (Backward)\n\ *\n\ * STOREV (input) CHARACTER*1\n\ * Indicates how the vectors which define the elementary\n\ * reflectors are stored:\n\ * = 'C': Columnwise (not supported yet)\n\ * = 'R': Rowwise\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C.\n\ *\n\ * K (input) INTEGER\n\ * The order of the matrix T (= the number of elementary\n\ * reflectors whose product defines the block reflector).\n\ *\n\ * L (input) INTEGER\n\ * The number of columns of the matrix V containing the\n\ * meaningful part of the Householder reflectors.\n\ * If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n\ *\n\ * V (input) REAL array, dimension (LDV,NV).\n\ * If STOREV = 'C', NV = K; if STOREV = 'R', NV = L.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V.\n\ * If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K.\n\ *\n\ * T (input) REAL array, dimension (LDT,K)\n\ * The triangular K-by-K matrix T in the representation of the\n\ * block reflector.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= K.\n\ *\n\ * C (input/output) REAL array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by H*C or H'*C or C*H or C*H'.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) REAL array, dimension (LDWORK,K)\n\ *\n\ * LDWORK (input) INTEGER\n\ * The leading dimension of the array WORK.\n\ * If SIDE = 'L', LDWORK >= max(1,N);\n\ * if SIDE = 'R', LDWORK >= max(1,M).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsyevr0000644000175000017500000003016412502223526016530 0ustar uwabamiuwabami--- :name: dsyevr :md5sum: 545806622e844f3721dd5f6c9dbaf0e1 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 26*n - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: 10*n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"I\") ? iu-il+1 : n" :fortran_help: " SUBROUTINE DSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSYEVR computes selected eigenvalues and, optionally, eigenvectors\n\ * of a real symmetric matrix A. Eigenvalues and eigenvectors can be\n\ * selected by specifying either a range of values or a range of\n\ * indices for the desired eigenvalues.\n\ *\n\ * DSYEVR first reduces the matrix A to tridiagonal form T with a call\n\ * to DSYTRD. Then, whenever possible, DSYEVR calls DSTEMR to compute\n\ * the eigenspectrum using Relatively Robust Representations. DSTEMR\n\ * computes eigenvalues by the dqds algorithm, while orthogonal\n\ * eigenvectors are computed from various \"good\" L D L^T representations\n\ * (also known as Relatively Robust Representations). Gram-Schmidt\n\ * orthogonalization is avoided as far as possible. More specifically,\n\ * the various steps of the algorithm are as follows.\n\ *\n\ * For each unreduced block (submatrix) of T,\n\ * (a) Compute T - sigma I = L D L^T, so that L and D\n\ * define all the wanted eigenvalues to high relative accuracy.\n\ * This means that small relative changes in the entries of D and L\n\ * cause only small relative changes in the eigenvalues and\n\ * eigenvectors. The standard (unfactored) representation of the\n\ * tridiagonal matrix T does not have this property in general.\n\ * (b) Compute the eigenvalues to suitable accuracy.\n\ * If the eigenvectors are desired, the algorithm attains full\n\ * accuracy of the computed eigenvalues only right before\n\ * the corresponding vectors have to be computed, see steps c) and d).\n\ * (c) For each cluster of close eigenvalues, select a new\n\ * shift close to the cluster, find a new factorization, and refine\n\ * the shifted eigenvalues to suitable accuracy.\n\ * (d) For each eigenvalue with a large enough relative separation compute\n\ * the corresponding eigenvector by forming a rank revealing twisted\n\ * factorization. Go back to (c) for any clusters that remain.\n\ *\n\ * The desired accuracy of the output can be specified by the input\n\ * parameter ABSTOL.\n\ *\n\ * For more details, see DSTEMR's documentation and:\n\ * - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n\ * to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n\ * Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n\ * - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n\ * Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n\ * 2004. Also LAPACK Working Note 154.\n\ * - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n\ * tridiagonal eigenvalue/eigenvector problem\",\n\ * Computer Science Division Technical Report No. UCB/CSD-97-971,\n\ * UC Berkeley, May 1997.\n\ *\n\ *\n\ * Note 1 : DSYEVR calls DSTEMR when the full spectrum is requested\n\ * on machines which conform to the ieee-754 floating point standard.\n\ * DSYEVR calls DSTEBZ and SSTEIN on non-ieee machines and\n\ * when partial spectrum requests are made.\n\ *\n\ * Normal execution of DSTEMR may create NaNs and infinities and\n\ * hence may abort due to a floating point exception in environments\n\ * which do not handle NaNs and infinities in the ieee standard default\n\ * manner.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found.\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found.\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ ********** For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and\n\ ********** DSTEIN are called\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of A contains the\n\ * upper triangular part of the matrix A. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of A contains\n\ * the lower triangular part of the matrix A.\n\ * On exit, the lower triangle (if UPLO='L') or the upper\n\ * triangle (if UPLO='U') of A, including the diagonal, is\n\ * destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * VL (input) DOUBLE PRECISION\n\ * VU (input) DOUBLE PRECISION\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) DOUBLE PRECISION\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less than\n\ * or equal to zero, then EPS*|T| will be used in its place,\n\ * where |T| is the 1-norm of the tridiagonal matrix obtained\n\ * by reducing A to tridiagonal form.\n\ *\n\ * See \"Computing Small Singular Values of Bidiagonal Matrices\n\ * with Guaranteed High Relative Accuracy,\" by Demmel and\n\ * Kahan, LAPACK Working Note #3.\n\ *\n\ * If high relative accuracy is important, set ABSTOL to\n\ * DLAMCH( 'Safe minimum' ). Doing so will guarantee that\n\ * eigenvalues are computed to high relative accuracy when\n\ * possible in future releases. The current code does not\n\ * make any guarantees about high relative accuracy, but\n\ * future releases will. See J. Barlow and J. Demmel,\n\ * \"Computing Accurate Eigensystems of Scaled Diagonally\n\ * Dominant Matrices\", LAPACK Working Note #7, for a discussion\n\ * of which matrices define their eigenvalues to high relative\n\ * accuracy.\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * The first M elements contain the selected eigenvalues in\n\ * ascending order.\n\ *\n\ * Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))\n\ * If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix A\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ * Supplying N columns is always safe.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )\n\ * The support of the eigenvectors in Z, i.e., the indices\n\ * indicating the nonzero elements in Z. The i-th eigenvector\n\ * is nonzero only in elements ISUPPZ( 2*i-1 ) through\n\ * ISUPPZ( 2*i ).\n\ ********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1\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,26*N).\n\ * For optimal efficiency, LWORK >= (NB+6)*N,\n\ * where NB is the max of the blocksize for DSYTRD and DORMTR\n\ * returned by ILAENV.\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\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK. LIWORK >= max(1,10*N).\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal size of the IWORK array,\n\ * returns this value as the first entry of the IWORK array, and\n\ * no error message related to LIWORK 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: Internal error\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Inderjit Dhillon, IBM Almaden, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Ken Stanley, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ * Jason Riedy, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zuncsd0000644000175000017500000002053312502223526016521 0ustar uwabamiuwabami--- :name: zuncsd :md5sum: f820000ebe86f9c39a15b07a7082cf5d :category: :subroutine :arguments: - jobu1: :type: char :intent: input - jobu2: :type: char :intent: input - jobv1t: :type: char :intent: input - jobv2t: :type: char :intent: input - trans: :type: char :intent: input - signs: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - q: :type: integer :intent: input - x11: :type: doublecomplex :intent: input :dims: - p - q - ldx11: :type: integer :intent: input - x12: :type: doublecomplex :intent: input :dims: - p - m-q - ldx12: :type: integer :intent: input - x21: :type: doublecomplex :intent: input :dims: - p - q - ldx21: :type: integer :intent: input - x22: :type: doublecomplex :intent: input :dims: - p - m-q - ldx22: :type: integer :intent: input - theta: :type: doublereal :intent: output :dims: - MIN(MIN(MIN(p,m-p),q),m-q) - u1: :type: doublecomplex :intent: output :dims: - p - ldu1: :type: integer :intent: input - u2: :type: doublecomplex :intent: output :dims: - m-p - ldu2: :type: integer :intent: input - v1t: :type: doublecomplex :intent: output :dims: - q - ldv1t: :type: integer :intent: input - v2t: :type: doublecomplex :intent: output :dims: - m-q - ldv2t: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - rwork: :type: doublereal :intent: workspace :dims: - MAX(1,lrwork) - lrwork: :type: integer :intent: input - iwork: :type: integer :intent: workspace :dims: - m-q - info: :type: integer :intent: output :substitutions: ldv2t: "lsame_(&jobv2t,\"Y\") ? MAX(1,m-q) : 0" ldv1t: "lsame_(&jobv1t,\"Y\") ? MAX(1,q) : 0" ldu1: "lsame_(&jobu1,\"Y\") ? MAX(1,p) : 0" ldu2: "lsame_(&jobu2,\"Y\") ? MAX(1,m-p) : 0" ldx11: p ldx12: p ldx21: p ldx22: p :fortran_help: " RECURSIVE SUBROUTINE ZUNCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, WORK, LWORK, RWORK, LRWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZUNCSD computes the CS decomposition of an M-by-M partitioned\n\ * unitary matrix X:\n\ *\n\ * [ I 0 0 | 0 0 0 ]\n\ * [ 0 C 0 | 0 -S 0 ]\n\ * [ X11 | X12 ] [ U1 | ] [ 0 0 0 | 0 0 -I ] [ V1 | ]**H\n\ * X = [-----------] = [---------] [---------------------] [---------] .\n\ * [ X21 | X22 ] [ | U2 ] [ 0 0 0 | I 0 0 ] [ | V2 ]\n\ * [ 0 S 0 | 0 C 0 ]\n\ * [ 0 0 I | 0 0 0 ]\n\ *\n\ * X11 is P-by-Q. The unitary matrices U1, U2, V1, and V2 are P-by-P,\n\ * (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are\n\ * R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in\n\ * which R = MIN(P,M-P,Q,M-Q).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBU1 (input) CHARACTER\n\ * = 'Y': U1 is computed;\n\ * otherwise: U1 is not computed.\n\ *\n\ * JOBU2 (input) CHARACTER\n\ * = 'Y': U2 is computed;\n\ * otherwise: U2 is not computed.\n\ *\n\ * JOBV1T (input) CHARACTER\n\ * = 'Y': V1T is computed;\n\ * otherwise: V1T is not computed.\n\ *\n\ * JOBV2T (input) CHARACTER\n\ * = 'Y': V2T is computed;\n\ * otherwise: V2T is not computed.\n\ *\n\ * TRANS (input) CHARACTER\n\ * = 'T': X, U1, U2, V1T, and V2T are stored in row-major\n\ * order;\n\ * otherwise: X, U1, U2, V1T, and V2T are stored in column-\n\ * major order.\n\ *\n\ * SIGNS (input) CHARACTER\n\ * = 'O': The lower-left block is made nonpositive (the\n\ * \"other\" convention);\n\ * otherwise: The upper-right block is made nonpositive (the\n\ * \"default\" convention).\n\ *\n\ * M (input) INTEGER\n\ * The number of rows and columns in X.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows in X11 and X12. 0 <= P <= M.\n\ *\n\ * Q (input) INTEGER\n\ * The number of columns in X11 and X21. 0 <= Q <= M.\n\ *\n\ * X (input/workspace) COMPLEX*16 array, dimension (LDX,M)\n\ * On entry, the unitary matrix whose CSD is desired.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of X. LDX >= MAX(1,M).\n\ *\n\ * THETA (output) DOUBLE PRECISION array, dimension (R), in which R =\n\ * MIN(P,M-P,Q,M-Q).\n\ * C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and\n\ * S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).\n\ *\n\ * U1 (output) COMPLEX*16 array, dimension (P)\n\ * If JOBU1 = 'Y', U1 contains the P-by-P unitary matrix U1.\n\ *\n\ * LDU1 (input) INTEGER\n\ * The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=\n\ * MAX(1,P).\n\ *\n\ * U2 (output) COMPLEX*16 array, dimension (M-P)\n\ * If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) unitary\n\ * matrix U2.\n\ *\n\ * LDU2 (input) INTEGER\n\ * The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=\n\ * MAX(1,M-P).\n\ *\n\ * V1T (output) COMPLEX*16 array, dimension (Q)\n\ * If JOBV1T = 'Y', V1T contains the Q-by-Q matrix unitary\n\ * matrix V1**H.\n\ *\n\ * LDV1T (input) INTEGER\n\ * The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=\n\ * MAX(1,Q).\n\ *\n\ * V2T (output) COMPLEX*16 array, dimension (M-Q)\n\ * If JOBV2T = 'Y', V2T contains the (M-Q)-by-(M-Q) unitary\n\ * matrix V2**H.\n\ *\n\ * LDV2T (input) INTEGER\n\ * The leading dimension of V2T. If JOBV2T = 'Y', LDV2T >=\n\ * MAX(1,M-Q).\n\ *\n\ * WORK (workspace) COMPLEX*16 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\ *\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\ * RWORK (workspace) DOUBLE PRECISION array, dimension MAX(1,LRWORK)\n\ * On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n\ * If INFO > 0 on exit, RWORK(2:R) contains the values PHI(1),\n\ * ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),\n\ * define the matrix in intermediate bidiagonal-block form\n\ * remaining after nonconvergence. INFO specifies the number\n\ * of nonzero PHI's.\n\ *\n\ * LRWORK (input) INTEGER\n\ * The dimension of the array RWORK.\n\ *\n\ * If LRWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the optimal size of the RWORK array, returns\n\ * this value as the first entry of the work array, and no error\n\ * message related to LRWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (M-Q)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit.\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * > 0: ZBBCSD did not converge. See the description of RWORK\n\ * above for details.\n\ *\n\ * Reference\n\ * =========\n\ *\n\ * [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.\n\ * Algorithms, 50(1):33-65, 2009.\n\ *\n\n\ * ===================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slansf0000644000175000017500000001455712502223526016512 0ustar uwabamiuwabami--- :name: slansf :md5sum: 014dd5ab8c3ce978110881e5d5f9d13b :category: :function :type: real :arguments: - norm: :type: char :intent: input - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - n*(n+1)/2 - work: :type: real :intent: workspace :dims: - "MAX(1,(lsame_(&norm,\"I\")||lsame_(&norm,\"1\")||lsame_(&norm,\"o\")) ? n : 0)" :substitutions: {} :fortran_help: " REAL FUNCTION SLANSF( NORM, TRANSR, UPLO, N, A, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLANSF returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * real symmetric matrix A in RFP format.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * SLANSF returns the value\n\ *\n\ * SLANSF = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in SLANSF as described\n\ * above.\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * Specifies whether the RFP format of A is normal or\n\ * transposed format.\n\ * = 'N': RFP format is Normal;\n\ * = 'T': RFP format is Transpose.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * On entry, UPLO specifies whether the RFP matrix A came from\n\ * an upper or lower triangular matrix as follows:\n\ * = 'U': RFP A came from an upper triangular matrix;\n\ * = 'L': RFP A came from a lower triangular matrix.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, SLANSF is\n\ * set to zero.\n\ *\n\ * A (input) REAL array, dimension ( N*(N+1)/2 );\n\ * On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')\n\ * part of the symmetric matrix A stored in RFP format. See the\n\ * \"Notes\" below for more details.\n\ * Unchanged on exit.\n\ *\n\ * WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n\ * WORK is not referenced.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * We first consider Rectangular Full Packed (RFP) Format when N is\n\ * even. We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * the transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * the transpose of the last three columns of AP lower.\n\ * This covers the case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 04 05 33 43 53\n\ * 13 14 15 00 44 54\n\ * 23 24 25 10 11 55\n\ * 33 34 35 20 21 22\n\ * 00 44 45 30 31 32\n\ * 01 11 55 40 41 42\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We then consider Rectangular Full Packed (RFP) Format when N is\n\ * odd. We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * the transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * the transpose of the last two columns of AP lower.\n\ * This covers the case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 03 04 00 33 43\n\ * 12 13 14 10 11 44\n\ * 22 23 24 20 21 22\n\ * 00 33 34 30 31 32\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * Reference\n\ * =========\n\ *\n\ * =====================================================================\n\ *\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zunmtr0000644000175000017500000001172112502223526016551 0ustar uwabamiuwabami--- :name: zunmtr :md5sum: d9162f3d836aaf44831702b03f6edbaa :category: :subroutine :arguments: - side: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - m-1 - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZUNMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZUNMTR overwrites the general complex M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'C': Q**H * C C * Q**H\n\ *\n\ * where Q is a complex unitary matrix of order nq, with nq = m if\n\ * SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of\n\ * nq-1 elementary reflectors, as returned by ZHETRD:\n\ *\n\ * if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);\n\ *\n\ * if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**H from the Left;\n\ * = 'R': apply Q or Q**H from the Right.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A contains elementary reflectors\n\ * from ZHETRD;\n\ * = 'L': Lower triangle of A contains elementary reflectors\n\ * from ZHETRD.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q;\n\ * = 'C': Conjugate transpose, apply Q**H.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension\n\ * (LDA,M) if SIDE = 'L'\n\ * (LDA,N) if SIDE = 'R'\n\ * The vectors which define the elementary reflectors, as\n\ * returned by ZHETRD.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ * LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n\ *\n\ * TAU (input) COMPLEX*16 array, dimension\n\ * (M-1) if SIDE = 'L'\n\ * (N-1) if SIDE = 'R'\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by ZHETRD.\n\ *\n\ * C (input/output) COMPLEX*16 array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M).\n\ * For optimum performance LWORK >= N*NB if SIDE = 'L', and\n\ * LWORK >=M*NB if SIDE = 'R', where NB is the optimal\n\ * 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\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LEFT, LQUERY, UPPER\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZUNMQL, ZUNMQR\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/claqps0000644000175000017500000001011512502223525016470 0ustar uwabamiuwabami--- :name: claqps :md5sum: d435df2cf720a3491ba886138dbbe026 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - offset: :type: integer :intent: input - nb: :type: integer :intent: input - kb: :type: integer :intent: output - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: complex :intent: output :dims: - kb - vn1: :type: real :intent: input/output :dims: - n - vn2: :type: real :intent: input/output :dims: - n - auxv: :type: complex :intent: input/output :dims: - nb - f: :type: complex :intent: input/output :dims: - ldf - nb - ldf: :type: integer :intent: input :substitutions: kb: nb :fortran_help: " SUBROUTINE CLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, VN2, AUXV, F, LDF )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAQPS computes a step of QR factorization with column pivoting\n\ * of a complex M-by-N matrix A by using Blas-3. It tries to factorize\n\ * NB columns from A starting from the row OFFSET+1, and updates all\n\ * of the matrix with Blas-3 xGEMM.\n\ *\n\ * In some cases, due to catastrophic cancellations, it cannot\n\ * factorize NB columns. Hence, the actual number of factorized\n\ * columns is returned in KB.\n\ *\n\ * Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\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\ * OFFSET (input) INTEGER\n\ * The number of rows of A that have been factorized in\n\ * previous steps.\n\ *\n\ * NB (input) INTEGER\n\ * The number of columns to factorize.\n\ *\n\ * KB (output) INTEGER\n\ * The number of columns actually factorized.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, block A(OFFSET+1:M,1:KB) is the triangular\n\ * factor obtained and block A(1:OFFSET,1:N) has been\n\ * accordingly pivoted, but no factorized.\n\ * The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has\n\ * been updated.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * JPVT (input/output) INTEGER array, dimension (N)\n\ * JPVT(I) = K <==> Column K of the full matrix A has been\n\ * permuted into position I in AP.\n\ *\n\ * TAU (output) COMPLEX array, dimension (KB)\n\ * The scalar factors of the elementary reflectors.\n\ *\n\ * VN1 (input/output) REAL array, dimension (N)\n\ * The vector with the partial column norms.\n\ *\n\ * VN2 (input/output) REAL array, dimension (N)\n\ * The vector with the exact column norms.\n\ *\n\ * AUXV (input/output) COMPLEX array, dimension (NB)\n\ * Auxiliar vector.\n\ *\n\ * F (input/output) COMPLEX array, dimension (LDF,NB)\n\ * Matrix F' = L*Y'*A.\n\ *\n\ * LDF (input) INTEGER\n\ * The leading dimension of the array F. LDF >= max(1,N).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n\ * X. Sun, Computer Science Dept., Duke University, USA\n\ *\n\ * Partial column norm updating strategy modified by\n\ * Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n\ * University of Zagreb, Croatia.\n\ * June 2010\n\ * For more details see LAPACK Working Note 176.\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sstegr0000644000175000017500000002054612502223526016526 0ustar uwabamiuwabami--- :name: sstegr :md5sum: 992b1604b86ed979e0de63b7c057e36b :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 18*n : lsame_(&jobz,\"N\") ? 12*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 10*n : lsame_(&jobz,\"N\") ? 8*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " SUBROUTINE SSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSTEGR computes selected eigenvalues and, optionally, eigenvectors\n\ * of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n\ * a well defined set of pairwise different real eigenvalues, the corresponding\n\ * real eigenvectors are pairwise orthogonal.\n\ *\n\ * The spectrum may be computed either completely or partially by specifying\n\ * either an interval (VL,VU] or a range of indices IL:IU for the desired\n\ * eigenvalues.\n\ *\n\ * SSTEGR is a compatability wrapper around the improved SSTEMR routine.\n\ * See SSTEMR for further details.\n\ *\n\ * One important change is that the ABSTOL parameter no longer provides any\n\ * benefit and hence is no longer used.\n\ *\n\ * Note : SSTEGR and SSTEMR work only on machines which follow\n\ * IEEE-754 floating-point standard in their handling of infinities and\n\ * NaNs. Normal execution may create these exceptiona values and hence\n\ * may abort due to a floating point exception in environments which\n\ * do not conform to the IEEE-754 standard.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found.\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found.\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the N diagonal elements of the tridiagonal matrix\n\ * T. On exit, D is overwritten.\n\ *\n\ * E (input/output) REAL array, dimension (N)\n\ * On entry, the (N-1) subdiagonal elements of the tridiagonal\n\ * matrix T in elements 1 to N-1 of E. E(N) need not be set on\n\ * input, but is used internally as workspace.\n\ * On exit, E is overwritten.\n\ *\n\ * VL (input) REAL\n\ * VU (input) REAL\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) REAL\n\ * Unused. Was the absolute error tolerance for the\n\ * eigenvalues/eigenvectors in previous versions.\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * The first M elements contain the selected eigenvalues in\n\ * ascending order.\n\ *\n\ * Z (output) REAL array, dimension (LDZ, max(1,M) )\n\ * If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix T\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ * Supplying N columns is always safe.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', then LDZ >= max(1,N).\n\ *\n\ * ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n\ * The support of the eigenvectors in Z, i.e., the indices\n\ * indicating the nonzero elements in Z. The i-th computed eigenvector\n\ * is nonzero only in elements ISUPPZ( 2*i-1 ) through\n\ * ISUPPZ( 2*i ). This is relevant in the case when the matrix\n\ * is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n\ *\n\ * WORK (workspace/output) REAL array, dimension (LWORK)\n\ * On exit, if INFO = 0, WORK(1) returns the optimal\n\ * (and minimal) LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK >= max(1,18*N)\n\ * if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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\ * IWORK (workspace/output) INTEGER array, dimension (LIWORK)\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK. LIWORK >= max(1,10*N)\n\ * if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n\ * if only the eigenvalues are to be computed.\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal size of the IWORK array,\n\ * returns this value as the first entry of the IWORK array, and\n\ * no error message related to LIWORK is issued by XERBLA.\n\ *\n\ * INFO (output) INTEGER\n\ * On exit, INFO\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: if INFO = 1X, internal error in SLARRE,\n\ * if INFO = 2X, internal error in SLARRV.\n\ * Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n\ * the nonzero error code returned by SLARRE or\n\ * SLARRV, respectively.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Inderjit Dhillon, IBM Almaden, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, LBNL/NERSC, USA\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL TRYRAC\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SSTEMR\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/shgeqz0000644000175000017500000002507212502223526016517 0ustar uwabamiuwabami--- :name: shgeqz :md5sum: 50f3e0f180cee44115f687d20453be96 :category: :subroutine :arguments: - job: :type: char :intent: input - compq: :type: char :intent: input - compz: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: real :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - t: :type: real :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - alphar: :type: real :intent: output :dims: - n - alphai: :type: real :intent: output :dims: - n - beta: :type: real :intent: output :dims: - n - q: :type: real :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - z: :type: real :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SHGEQZ computes the eigenvalues of a real matrix pair (H,T),\n\ * where H is an upper Hessenberg matrix and T is upper triangular,\n\ * using the double-shift QZ method.\n\ * Matrix pairs of this type are produced by the reduction to\n\ * generalized upper Hessenberg form of a real matrix pair (A,B):\n\ *\n\ * A = Q1*H*Z1**T, B = Q1*T*Z1**T,\n\ *\n\ * as computed by SGGHRD.\n\ *\n\ * If JOB='S', then the Hessenberg-triangular pair (H,T) is\n\ * also reduced to generalized Schur form,\n\ * \n\ * H = Q*S*Z**T, T = Q*P*Z**T,\n\ * \n\ * where Q and Z are orthogonal matrices, P is an upper triangular\n\ * matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2\n\ * diagonal blocks.\n\ *\n\ * The 1-by-1 blocks correspond to real eigenvalues of the matrix pair\n\ * (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of\n\ * eigenvalues.\n\ *\n\ * Additionally, the 2-by-2 upper triangular diagonal blocks of P\n\ * corresponding to 2-by-2 blocks of S are reduced to positive diagonal\n\ * form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0,\n\ * P(j,j) > 0, and P(j+1,j+1) > 0.\n\ *\n\ * Optionally, the orthogonal matrix Q from the generalized Schur\n\ * factorization may be postmultiplied into an input matrix Q1, and the\n\ * orthogonal matrix Z may be postmultiplied into an input matrix Z1.\n\ * If Q1 and Z1 are the orthogonal matrices from SGGHRD that reduced\n\ * the matrix pair (A,B) to generalized upper Hessenberg form, then the\n\ * output matrices Q1*Q and Z1*Z are the orthogonal factors from the\n\ * generalized Schur factorization of (A,B):\n\ *\n\ * A = (Q1*Q)*S*(Z1*Z)**T, B = (Q1*Q)*P*(Z1*Z)**T.\n\ * \n\ * To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently,\n\ * of (A,B)) are computed as a pair of values (alpha,beta), where alpha is\n\ * complex and beta real.\n\ * If beta is nonzero, lambda = alpha / beta is an eigenvalue of the\n\ * generalized nonsymmetric eigenvalue problem (GNEP)\n\ * A*x = lambda*B*x\n\ * and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the\n\ * alternate form of the GNEP\n\ * mu*A*y = B*y.\n\ * Real eigenvalues can be read directly from the generalized Schur\n\ * form: \n\ * alpha = S(i,i), beta = P(i,i).\n\ *\n\ * Ref: C.B. Moler & G.W. Stewart, \"An Algorithm for Generalized Matrix\n\ * Eigenvalue Problems\", SIAM J. Numer. Anal., 10(1973),\n\ * pp. 241--256.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * = 'E': Compute eigenvalues only;\n\ * = 'S': Compute eigenvalues and the Schur form. \n\ *\n\ * COMPQ (input) CHARACTER*1\n\ * = 'N': Left Schur vectors (Q) are not computed;\n\ * = 'I': Q is initialized to the unit matrix and the matrix Q\n\ * of left Schur vectors of (H,T) is returned;\n\ * = 'V': Q must contain an orthogonal matrix Q1 on entry and\n\ * the product Q1*Q is returned.\n\ *\n\ * COMPZ (input) CHARACTER*1\n\ * = 'N': Right Schur vectors (Z) are not computed;\n\ * = 'I': Z is initialized to the unit matrix and the matrix Z\n\ * of right Schur vectors of (H,T) is returned;\n\ * = 'V': Z must contain an orthogonal matrix Z1 on entry and\n\ * the product Z1*Z is returned.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices H, T, Q, and Z. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * ILO and IHI mark the rows and columns of H which are in\n\ * Hessenberg form. It is assumed that A is already upper\n\ * triangular in rows and columns 1:ILO-1 and IHI+1:N.\n\ * If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.\n\ *\n\ * H (input/output) REAL array, dimension (LDH, N)\n\ * On entry, the N-by-N upper Hessenberg matrix H.\n\ * On exit, if JOB = 'S', H contains the upper quasi-triangular\n\ * matrix S from the generalized Schur factorization;\n\ * 2-by-2 diagonal blocks (corresponding to complex conjugate\n\ * pairs of eigenvalues) are returned in standard form, with\n\ * H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0.\n\ * If JOB = 'E', the diagonal blocks of H match those of S, but\n\ * the rest of H is unspecified.\n\ *\n\ * LDH (input) INTEGER\n\ * The leading dimension of the array H. LDH >= max( 1, N ).\n\ *\n\ * T (input/output) REAL array, dimension (LDT, N)\n\ * On entry, the N-by-N upper triangular matrix T.\n\ * On exit, if JOB = 'S', T contains the upper triangular\n\ * matrix P from the generalized Schur factorization;\n\ * 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S\n\ * are reduced to positive diagonal form, i.e., if H(j+1,j) is\n\ * non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and\n\ * T(j+1,j+1) > 0.\n\ * If JOB = 'E', the diagonal blocks of T match those of P, but\n\ * the rest of T is unspecified.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= max( 1, N ).\n\ *\n\ * ALPHAR (output) REAL array, dimension (N)\n\ * The real parts of each scalar alpha defining an eigenvalue\n\ * of GNEP.\n\ *\n\ * ALPHAI (output) REAL array, dimension (N)\n\ * The imaginary parts of each scalar alpha defining an\n\ * eigenvalue of GNEP.\n\ * If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n\ * positive, then the j-th and (j+1)-st eigenvalues are a\n\ * complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j).\n\ *\n\ * BETA (output) REAL array, dimension (N)\n\ * The scalars beta that define the eigenvalues of GNEP.\n\ * Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and\n\ * beta = BETA(j) represent the j-th eigenvalue of the matrix\n\ * pair (A,B), in one of the forms lambda = alpha/beta or\n\ * mu = beta/alpha. Since either lambda or mu may overflow,\n\ * they should not, in general, be computed.\n\ *\n\ * Q (input/output) REAL array, dimension (LDQ, N)\n\ * On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in\n\ * the reduction of (A,B) to generalized Hessenberg form.\n\ * On exit, if COMPZ = 'I', the orthogonal matrix of left Schur\n\ * vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix\n\ * of left Schur vectors of (A,B).\n\ * Not referenced if COMPZ = 'N'.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= 1.\n\ * If COMPQ='V' or 'I', then LDQ >= N.\n\ *\n\ * Z (input/output) REAL array, dimension (LDZ, N)\n\ * On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in\n\ * the reduction of (A,B) to generalized Hessenberg form.\n\ * On exit, if COMPZ = 'I', the orthogonal matrix of\n\ * right Schur vectors of (H,T), and if COMPZ = 'V', the\n\ * orthogonal matrix of right Schur vectors of (A,B).\n\ * Not referenced if COMPZ = 'N'.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1.\n\ * If COMPZ='V' or 'I', then LDZ >= N.\n\ *\n\ * WORK (workspace/output) REAL 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,N).\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\ * = 1,...,N: the QZ iteration did not converge. (H,T) is not\n\ * in Schur form, but ALPHAR(i), ALPHAI(i), and\n\ * BETA(i), i=INFO+1,...,N should be correct.\n\ * = N+1,...,2*N: the shift calculation failed. (H,T) is not\n\ * in Schur form, but ALPHAR(i), ALPHAI(i), and\n\ * BETA(i), i=INFO-N+1,...,N should be correct.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Iteration counters:\n\ *\n\ * JITER -- counts iterations.\n\ * IITER -- counts iterations run since ILAST was last\n\ * changed. This is therefore reset only when a 1-by-1 or\n\ * 2-by-2 block deflates off the bottom.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlamrg0000644000175000017500000000375312502223526016466 0ustar uwabamiuwabami--- :name: dlamrg :md5sum: 482180fad6debeccfe564bd4a552d6d5 :category: :subroutine :arguments: - n1: :type: integer :intent: input - n2: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - n1+n2 - dtrd1: :type: integer :intent: input - dtrd2: :type: integer :intent: input - index: :type: integer :intent: output :dims: - n1+n2 :substitutions: {} :fortran_help: " SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAMRG will create a permutation list which will merge the elements\n\ * of A (which is composed of two independently sorted sets) into a\n\ * single set which is sorted in ascending order.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N1 (input) INTEGER\n\ * N2 (input) INTEGER\n\ * These arguements contain the respective lengths of the two\n\ * sorted lists to be merged.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (N1+N2)\n\ * The first N1 elements of A contain a list of numbers which\n\ * are sorted in either ascending or descending order. Likewise\n\ * for the final N2 elements.\n\ *\n\ * DTRD1 (input) INTEGER\n\ * DTRD2 (input) INTEGER\n\ * These are the strides to be taken through the array A.\n\ * Allowable strides are 1 and -1. They indicate whether a\n\ * subset of A is sorted in ascending (DTRDx = 1) or descending\n\ * (DTRDx = -1) order.\n\ *\n\ * INDEX (output) INTEGER array, dimension (N1+N2)\n\ * On exit this array will contain a permutation such that\n\ * if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be\n\ * sorted in ascending order.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, IND1, IND2, N1SV, N2SV\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dptsvx0000644000175000017500000001646212502223526016551 0ustar uwabamiuwabami--- :name: dptsvx :md5sum: f1a2d0ffc60d33704538dbaf610529e1 :category: :subroutine :arguments: - fact: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublereal :intent: input :dims: - n-1 - df: :type: doublereal :intent: input/output :dims: - n - ef: :type: doublereal :intent: input/output :dims: - n-1 - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE DPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPTSVX uses the factorization A = L*D*L**T to compute the solution\n\ * to a real system of linear equations A*X = B, where A is an N-by-N\n\ * symmetric positive definite tridiagonal matrix and X and B are\n\ * N-by-NRHS matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'N', the matrix A is factored as A = L*D*L**T, where L\n\ * is a unit lower bidiagonal matrix and D is diagonal. The\n\ * factorization can also be regarded as having the form\n\ * A = U**T*D*U.\n\ *\n\ * 2. If the leading i-by-i principal minor is not positive definite,\n\ * then the routine returns with INFO = i. Otherwise, the factored\n\ * form of A is used to estimate the condition number of the matrix\n\ * A. If the reciprocal of the condition number is less than machine\n\ * precision, INFO = N+1 is returned as a warning, but the routine\n\ * still goes on to solve for X and compute error bounds as\n\ * described below.\n\ *\n\ * 3. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 4. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of A has been\n\ * supplied on entry.\n\ * = 'F': On entry, DF and EF contain the factored form of A.\n\ * D, E, DF, and EF will not be modified.\n\ * = 'N': The matrix A will be copied to DF and EF and\n\ * factored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The n diagonal elements of the tridiagonal matrix A.\n\ *\n\ * E (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) subdiagonal elements of the tridiagonal matrix A.\n\ *\n\ * DF (input or output) DOUBLE PRECISION array, dimension (N)\n\ * If FACT = 'F', then DF is an input argument and on entry\n\ * contains the n diagonal elements of the diagonal matrix D\n\ * from the L*D*L**T factorization of A.\n\ * If FACT = 'N', then DF is an output argument and on exit\n\ * contains the n diagonal elements of the diagonal matrix D\n\ * from the L*D*L**T factorization of A.\n\ *\n\ * EF (input or output) DOUBLE PRECISION array, dimension (N-1)\n\ * If FACT = 'F', then EF is an input argument and on entry\n\ * contains the (n-1) subdiagonal elements of the unit\n\ * bidiagonal factor L from the L*D*L**T factorization of A.\n\ * If FACT = 'N', then EF is an output argument and on exit\n\ * contains the (n-1) subdiagonal elements of the unit\n\ * bidiagonal factor L from the L*D*L**T factorization of A.\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * The N-by-NRHS right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * If INFO = 0 of INFO = N+1, the N-by-NRHS solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The reciprocal condition number of the matrix A. If RCOND\n\ * is less than the machine precision (in particular, if\n\ * RCOND = 0), the matrix is singular to working precision.\n\ * This condition is indicated by a return code of INFO > 0.\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j).\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in any\n\ * element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\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, and i is\n\ * <= N: the leading minor of order i of A is\n\ * not positive definite, so the factorization\n\ * could not be completed, and the solution has not\n\ * been computed. RCOND = 0 is returned.\n\ * = N+1: U is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ztgsy20000644000175000017500000001760412502223526016462 0ustar uwabamiuwabami--- :name: ztgsy2 :md5sum: 4250a5a6ef42ca889363cd7d0210dab7 :category: :subroutine :arguments: - trans: :type: char :intent: input - ijob: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - d: :type: doublecomplex :intent: input :dims: - ldd - m - ldd: :type: integer :intent: input - e: :type: doublecomplex :intent: input :dims: - lde - n - lde: :type: integer :intent: input - f: :type: doublecomplex :intent: input/output :dims: - ldf - n - ldf: :type: integer :intent: input - scale: :type: doublereal :intent: output - rdsum: :type: doublereal :intent: input/output - rdscal: :type: doublereal :intent: input/output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTGSY2 solves the generalized Sylvester equation\n\ *\n\ * A * R - L * B = scale * C (1)\n\ * D * R - L * E = scale * F\n\ *\n\ * using Level 1 and 2 BLAS, where R and L are unknown M-by-N matrices,\n\ * (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,\n\ * N-by-N and M-by-N, respectively. A, B, D and E are upper triangular\n\ * (i.e., (A,D) and (B,E) in generalized Schur form).\n\ *\n\ * The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output\n\ * scaling factor chosen to avoid overflow.\n\ *\n\ * In matrix notation solving equation (1) corresponds to solve\n\ * Zx = scale * b, where Z is defined as\n\ *\n\ * Z = [ kron(In, A) -kron(B', Im) ] (2)\n\ * [ kron(In, D) -kron(E', Im) ],\n\ *\n\ * Ik is the identity matrix of size k and X' is the transpose of X.\n\ * kron(X, Y) is the Kronecker product between the matrices X and Y.\n\ *\n\ * If TRANS = 'C', y in the conjugate transposed system Z'y = scale*b\n\ * is solved for, which is equivalent to solve for R and L in\n\ *\n\ * A' * R + D' * L = scale * C (3)\n\ * R * B' + L * E' = scale * -F\n\ *\n\ * This case is used to compute an estimate of Dif[(A, D), (B, E)] =\n\ * = sigma_min(Z) using reverse communicaton with ZLACON.\n\ *\n\ * ZTGSY2 also (IJOB >= 1) contributes to the computation in ZTGSYL\n\ * of an upper bound on the separation between to matrix pairs. Then\n\ * the input (A, D), (B, E) are sub-pencils of two matrix pairs in\n\ * ZTGSYL.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N', solve the generalized Sylvester equation (1).\n\ * = 'T': solve the 'transposed' system (3).\n\ *\n\ * IJOB (input) INTEGER\n\ * Specifies what kind of functionality to be performed.\n\ * =0: solve (1) only.\n\ * =1: A contribution from this subsystem to a Frobenius\n\ * norm-based estimate of the separation between two matrix\n\ * pairs is computed. (look ahead strategy is used).\n\ * =2: A contribution from this subsystem to a Frobenius\n\ * norm-based estimate of the separation between two matrix\n\ * pairs is computed. (DGECON on sub-systems is used.)\n\ * Not referenced if TRANS = 'T'.\n\ *\n\ * M (input) INTEGER\n\ * On entry, M specifies the order of A and D, and the row\n\ * dimension of C, F, R and L.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the order of B and E, and the column\n\ * dimension of C, F, R and L.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA, M)\n\ * On entry, A contains an upper triangular matrix.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the matrix A. LDA >= max(1, M).\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB, N)\n\ * On entry, B contains an upper triangular matrix.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the matrix B. LDB >= max(1, N).\n\ *\n\ * C (input/output) COMPLEX*16 array, dimension (LDC, N)\n\ * On entry, C contains the right-hand-side of the first matrix\n\ * equation in (1).\n\ * On exit, if IJOB = 0, C has been overwritten by the solution\n\ * R.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the matrix C. LDC >= max(1, M).\n\ *\n\ * D (input) COMPLEX*16 array, dimension (LDD, M)\n\ * On entry, D contains an upper triangular matrix.\n\ *\n\ * LDD (input) INTEGER\n\ * The leading dimension of the matrix D. LDD >= max(1, M).\n\ *\n\ * E (input) COMPLEX*16 array, dimension (LDE, N)\n\ * On entry, E contains an upper triangular matrix.\n\ *\n\ * LDE (input) INTEGER\n\ * The leading dimension of the matrix E. LDE >= max(1, N).\n\ *\n\ * F (input/output) COMPLEX*16 array, dimension (LDF, N)\n\ * On entry, F contains the right-hand-side of the second matrix\n\ * equation in (1).\n\ * On exit, if IJOB = 0, F has been overwritten by the solution\n\ * L.\n\ *\n\ * LDF (input) INTEGER\n\ * The leading dimension of the matrix F. LDF >= max(1, M).\n\ *\n\ * SCALE (output) DOUBLE PRECISION\n\ * On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions\n\ * R and L (C and F on entry) will hold the solutions to a\n\ * slightly perturbed system but the input matrices A, B, D and\n\ * E have not been changed. If SCALE = 0, R and L will hold the\n\ * solutions to the homogeneous system with C = F = 0.\n\ * Normally, SCALE = 1.\n\ *\n\ * RDSUM (input/output) DOUBLE PRECISION\n\ * On entry, the sum of squares of computed contributions to\n\ * the Dif-estimate under computation by ZTGSYL, where the\n\ * scaling factor RDSCAL (see below) has been factored out.\n\ * On exit, the corresponding sum of squares updated with the\n\ * contributions from the current sub-system.\n\ * If TRANS = 'T' RDSUM is not touched.\n\ * NOTE: RDSUM only makes sense when ZTGSY2 is called by\n\ * ZTGSYL.\n\ *\n\ * RDSCAL (input/output) DOUBLE PRECISION\n\ * On entry, scaling factor used to prevent overflow in RDSUM.\n\ * On exit, RDSCAL is updated w.r.t. the current contributions\n\ * in RDSUM.\n\ * If TRANS = 'T', RDSCAL is not touched.\n\ * NOTE: RDSCAL only makes sense when ZTGSY2 is called by\n\ * ZTGSYL.\n\ *\n\ * INFO (output) INTEGER\n\ * On exit, if INFO is set to\n\ * =0: Successful exit\n\ * <0: If INFO = -i, input argument number i is illegal.\n\ * >0: The matrix pairs (A, D) and (B, E) have common or very\n\ * close eigenvalues.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ztgexc0000644000175000017500000001376312502223526016526 0ustar uwabamiuwabami--- :name: ztgexc :md5sum: 1802c26e89d51c5c4d73a4bd2b40e40b :category: :subroutine :arguments: - wantq: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - q: :type: doublecomplex :intent: input/output :dims: - ldz - n - ldq: :type: integer :intent: input - z: :type: doublecomplex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - ifst: :type: integer :intent: input - ilst: :type: integer :intent: input/output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, IFST, ILST, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTGEXC reorders the generalized Schur decomposition of a complex\n\ * matrix pair (A,B), using an unitary equivalence transformation\n\ * (A, B) := Q * (A, B) * Z', so that the diagonal block of (A, B) with\n\ * row index IFST is moved to row ILST.\n\ *\n\ * (A, B) must be in generalized Schur canonical form, that is, A and\n\ * B are both upper triangular.\n\ *\n\ * Optionally, the matrices Q and Z of generalized Schur vectors are\n\ * updated.\n\ *\n\ * Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n\ * Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * WANTQ (input) LOGICAL\n\ * .TRUE. : update the left transformation matrix Q;\n\ * .FALSE.: do not update Q.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * .TRUE. : update the right transformation matrix Z;\n\ * .FALSE.: do not update Z.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the upper triangular matrix A in the pair (A, B).\n\ * On exit, the updated matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,N)\n\ * On entry, the upper triangular matrix B in the pair (A, B).\n\ * On exit, the updated matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * Q (input/output) COMPLEX*16 array, dimension (LDZ,N)\n\ * On entry, if WANTQ = .TRUE., the unitary matrix Q.\n\ * On exit, the updated matrix Q.\n\ * If WANTQ = .FALSE., Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= 1;\n\ * If WANTQ = .TRUE., LDQ >= N.\n\ *\n\ * Z (input/output) COMPLEX*16 array, dimension (LDZ,N)\n\ * On entry, if WANTZ = .TRUE., the unitary matrix Z.\n\ * On exit, the updated matrix Z.\n\ * If WANTZ = .FALSE., Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1;\n\ * If WANTZ = .TRUE., LDZ >= N.\n\ *\n\ * IFST (input) INTEGER\n\ * ILST (input/output) INTEGER\n\ * Specify the reordering of the diagonal blocks of (A, B).\n\ * The block with row index IFST is moved to row ILST, by a\n\ * sequence of swapping between adjacent blocks.\n\ *\n\ * INFO (output) INTEGER\n\ * =0: Successful exit.\n\ * <0: if INFO = -i, the i-th argument had an illegal value.\n\ * =1: The transformed matrix pair (A, B) would be too far\n\ * from generalized Schur form; the problem is ill-\n\ * conditioned. (A, B) may have been partially reordered,\n\ * and ILST points to the first row of the current\n\ * position of the block being moved.\n\ *\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n\ * Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n\ * M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n\ * Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n\ *\n\ * [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n\ * Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n\ * Estimation: Theory, Algorithms and Software, Report\n\ * UMINF - 94.04, Department of Computing Science, Umea University,\n\ * S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.\n\ * To appear in Numerical Algorithms, 1996.\n\ *\n\ * [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n\ * for Solving the Generalized Sylvester Equation and Estimating the\n\ * Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n\ * Department of Computing Science, Umea University, S-901 87 Umea,\n\ * Sweden, December 1993, Revised April 1994, Also as LAPACK working\n\ * Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,\n\ * 1996.\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER HERE\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZTGEX2\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slanhs0000644000175000017500000000452012502223526016501 0ustar uwabamiuwabami--- :name: slanhs :md5sum: e3c43e2100e6bef410d4ba5dc67db587 :category: :function :type: real :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? n : 0" :fortran_help: " REAL FUNCTION SLANHS( NORM, N, A, LDA, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLANHS returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * Hessenberg matrix A.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * SLANHS returns the value\n\ *\n\ * SLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in SLANHS as described\n\ * above.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, SLANHS is\n\ * set to zero.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * The n by n upper Hessenberg matrix A; the part of A below the\n\ * first sub-diagonal is not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(N,1).\n\ *\n\ * WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n\ * referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cpbtrs0000644000175000017500000000607612502223525016515 0ustar uwabamiuwabami--- :name: cpbtrs :md5sum: a372d285f8e1289f9739e11ea3d0058e :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPBTRS solves a system of linear equations A*X = B with a Hermitian\n\ * positive definite band matrix A using the Cholesky factorization\n\ * A = U**H*U or A = L*L**H computed by CPBTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangular factor stored in AB;\n\ * = 'L': Lower triangular factor stored in AB.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AB (input) COMPLEX array, dimension (LDAB,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**H*U or A = L*L**H of the band matrix A, stored in the\n\ * first KD+1 rows of the array. The j-th column of U or L is\n\ * stored in the j-th column of the array AB as follows:\n\ * if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL UPPER\n INTEGER J\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CTBSV, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dormrz0000644000175000017500000001151112502223526016524 0ustar uwabamiuwabami--- :name: dormrz :md5sum: b7420b7de5854d706c94fac76154c6d5 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DORMRZ overwrites the general real M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'T': Q**T * C C * Q**T\n\ *\n\ * where Q is a real orthogonal matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by DTZRZF. Q is of order M if SIDE = 'L' and of order N\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**T from the Left;\n\ * = 'R': apply Q or Q**T from the Right.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q;\n\ * = 'T': Transpose, apply Q**T.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * L (input) INTEGER\n\ * The number of columns of the matrix A containing\n\ * the meaningful part of the Householder reflectors.\n\ * If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension\n\ * (LDA,M) if SIDE = 'L',\n\ * (LDA,N) if SIDE = 'R'\n\ * The i-th row must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * DTZRZF in the last k rows of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,K).\n\ *\n\ * TAU (input) DOUBLE PRECISION array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by DTZRZF.\n\ *\n\ * C (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M).\n\ * For optimum performance LWORK >= N*NB if SIDE = 'L', and\n\ * LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n\ * 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\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlarf0000644000175000017500000000521412502223526016330 0ustar uwabamiuwabami--- :name: zlarf :md5sum: f12ff196863e7cc551d26a0f1f27dd12 :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - v: :type: doublecomplex :intent: input :dims: - 1 + (m-1)*abs(incv) - incv: :type: integer :intent: input - tau: :type: doublecomplex :intent: input - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLARF applies a complex elementary reflector H to a complex M-by-N\n\ * matrix C, from either the left or the right. H is represented in the\n\ * form\n\ *\n\ * H = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar and v is a complex vector.\n\ *\n\ * If tau = 0, then H is taken to be the unit matrix.\n\ *\n\ * To apply H' (the conjugate transpose of H), supply conjg(tau) instead\n\ * tau.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': form H * C\n\ * = 'R': form C * H\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C.\n\ *\n\ * V (input) COMPLEX*16 array, dimension\n\ * (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n\ * or (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n\ * The vector v in the representation of H. V is not used if\n\ * TAU = 0.\n\ *\n\ * INCV (input) INTEGER\n\ * The increment between elements of v. INCV <> 0.\n\ *\n\ * TAU (input) COMPLEX*16\n\ * The value tau in the representation of H.\n\ *\n\ * C (input/output) COMPLEX*16 array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n\ * or C * H if SIDE = 'R'.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension\n\ * (N) if SIDE = 'L'\n\ * or (M) if SIDE = 'R'\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/spftrs0000644000175000017500000001314212502223526016532 0ustar uwabamiuwabami--- :name: spftrs :md5sum: 59ce631df9d7e1b4bd116b5447fce8c2 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - n*(n+1)/2 - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPFTRS solves a system of linear equations A*X = B with a symmetric\n\ * positive definite matrix A using the Cholesky factorization\n\ * A = U**T*U or A = L*L**T computed by SPFTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': The Normal TRANSR of RFP A is stored;\n\ * = 'T': The Transpose TRANSR of RFP A is stored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of RFP A is stored;\n\ * = 'L': Lower triangle of RFP A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input) REAL array, dimension ( N*(N+1)/2 )\n\ * The triangular factor U or L from the Cholesky factorization\n\ * of RFP A = U**H*U or RFP A = L*L**T, as computed by SPFTRF.\n\ * See note below for more details about RFP A.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * We first consider Rectangular Full Packed (RFP) Format when N is\n\ * even. We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * the transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * the transpose of the last three columns of AP lower.\n\ * This covers the case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 04 05 33 43 53\n\ * 13 14 15 00 44 54\n\ * 23 24 25 10 11 55\n\ * 33 34 35 20 21 22\n\ * 00 44 45 30 31 32\n\ * 01 11 55 40 41 42\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We then consider Rectangular Full Packed (RFP) Format when N is\n\ * odd. We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * the transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * the transpose of the last two columns of AP lower.\n\ * This covers the case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 03 04 00 33 43\n\ * 12 13 14 10 11 44\n\ * 22 23 24 20 21 22\n\ * 00 33 34 30 31 32\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dspgv0000644000175000017500000001200012502223526016324 0ustar uwabamiuwabami--- :name: dspgv :md5sum: fa90c149e39cfb6acbcec1aec1f9ef15 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - ldap - bp: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE DSPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSPGV computes all the eigenvalues and, optionally, the eigenvectors\n\ * of a real generalized symmetric-definite eigenproblem, of the form\n\ * A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.\n\ * Here A and B are assumed to be symmetric, stored in packed format,\n\ * and B is also positive definite.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * Specifies the problem type to be solved:\n\ * = 1: A*x = (lambda)*B*x\n\ * = 2: A*B*x = (lambda)*x\n\ * = 3: B*A*x = (lambda)*x\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * AP (input/output) DOUBLE PRECISION array, dimension\n\ * (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, the contents of AP are destroyed.\n\ *\n\ * BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * B, packed columnwise in a linear array. The j-th column of B\n\ * is stored in the array BP as follows:\n\ * if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n\ *\n\ * On exit, the triangular factor U or L from the Cholesky\n\ * factorization B = U**T*U or B = L*L**T, in the same storage\n\ * format as B.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n\ * eigenvectors. The eigenvectors are normalized as follows:\n\ * if ITYPE = 1 or 2, Z**T*B*Z = I;\n\ * if ITYPE = 3, Z**T*inv(B)*Z = I.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: DPPTRF or DSPEV returned an error code:\n\ * <= N: if INFO = i, DSPEV failed to converge;\n\ * i off-diagonal elements of an intermediate\n\ * tridiagonal form did not converge to zero.\n\ * > N: if INFO = n + i, for 1 <= i <= n, then the leading\n\ * minor of order i of B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL UPPER, WANTZ\n CHARACTER TRANS\n INTEGER J, NEIG\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DPPTRF, DSPEV, DSPGST, DTPMV, DTPSV, XERBLA\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cgesvx0000644000175000017500000003236712502223525016521 0ustar uwabamiuwabami--- :name: cgesvx :md5sum: 63167ffcd212fc9e1f2cb1f47cca7e74 :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input/output :dims: - ldaf - n :option: true - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n :option: true - equed: :type: char :intent: input/output :option: true - r: :type: real :intent: input/output :dims: - n :option: true - c: :type: real :intent: input/output :dims: - n :option: true - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: output :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldx: n ldaf: n :fortran_help: " SUBROUTINE CGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGESVX uses the LU factorization to compute the solution to a complex\n\ * system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', real scaling factors are computed to equilibrate\n\ * the system:\n\ * TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n\ * TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n\ * TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n\ * or diag(C)*B (if TRANS = 'T' or 'C').\n\ *\n\ * 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n\ * matrix A (after equilibration if FACT = 'E') as\n\ * A = P * L * U,\n\ * where P is a permutation matrix, L is a unit lower triangular\n\ * matrix, and U is upper triangular.\n\ *\n\ * 3. If some U(i,i)=0, so that U is exactly singular, then the routine\n\ * returns with INFO = i. Otherwise, the factored form of A is used\n\ * to estimate the condition number of the matrix A. If the\n\ * reciprocal of the condition number is less than machine precision,\n\ * INFO = N+1 is returned as a warning, but the routine still goes on\n\ * to solve for X and compute error bounds as described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n\ * that it solves the original system before equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AF and IPIV contain the factored form of A.\n\ * If EQUED is not 'N', the matrix A has been\n\ * equilibrated with scaling factors given by R and C.\n\ * A, AF, and IPIV are not modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AF and factored.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose)\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is\n\ * not 'N', then A must have been equilibrated by the scaling\n\ * factors in R and/or C. A is not modified if FACT = 'F' or\n\ * 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n\ *\n\ * On exit, if EQUED .ne. 'N', A is scaled as follows:\n\ * EQUED = 'R': A := diag(R) * A\n\ * EQUED = 'C': A := A * diag(C)\n\ * EQUED = 'B': A := diag(R) * A * diag(C).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input or output) COMPLEX array, dimension (LDAF,N)\n\ * If FACT = 'F', then AF is an input argument and on entry\n\ * contains the factors L and U from the factorization\n\ * A = P*L*U as computed by CGETRF. If EQUED .ne. 'N', then\n\ * AF is the factored form of the equilibrated matrix A.\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the factors L and U from the factorization A = P*L*U\n\ * of the original matrix A.\n\ *\n\ * If FACT = 'E', then AF is an output argument and on exit\n\ * returns the factors L and U from the factorization A = P*L*U\n\ * of the equilibrated matrix A (see the description of A for\n\ * the form of the equilibrated matrix).\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * as computed by CGETRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * of the original matrix A.\n\ *\n\ * If FACT = 'E', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * of the equilibrated matrix A.\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * R (input or output) REAL array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'R' or 'B', A is\n\ * multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n\ * is not accessed. R is an input argument if FACT = 'F';\n\ * otherwise, R is an output argument. If FACT = 'F' and\n\ * EQUED = 'R' or 'B', each element of R must be positive.\n\ *\n\ * C (input or output) REAL array, dimension (N)\n\ * The column scale factors for A. If EQUED = 'C' or 'B', A is\n\ * multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n\ * is not accessed. C is an input argument if FACT = 'F';\n\ * otherwise, C is an output argument. If FACT = 'F' and\n\ * EQUED = 'C' or 'B', each element of C must be positive.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit,\n\ * if EQUED = 'N', B is not modified;\n\ * if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n\ * diag(R)*B;\n\ * if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n\ * overwritten by diag(C)*B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n\ * to the original system of equations. Note that A and B are\n\ * modified on exit if EQUED .ne. 'N', and the solution to the\n\ * equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n\ * EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n\ * and EQUED = 'R' or 'B'.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A after equilibration (if done). If RCOND is less than the\n\ * machine precision (in particular, if RCOND = 0), the matrix\n\ * is singular to working precision. This condition is\n\ * indicated by a return code of INFO > 0.\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace/output) REAL array, dimension (2*N)\n\ * On exit, RWORK(1) contains the reciprocal pivot growth\n\ * factor norm(A)/norm(U). The \"max absolute element\" norm is\n\ * used. If RWORK(1) is much less than 1, then the stability\n\ * of the LU factorization of the (equilibrated) matrix A\n\ * could be poor. This also means that the solution X, condition\n\ * estimator RCOND, and forward error bound FERR could be\n\ * unreliable. If factorization fails with 0 0: if INFO = i, and i is\n\ * <= N: U(i,i) is exactly zero. The factorization has\n\ * been completed, but the factor U is exactly\n\ * singular, so the solution and error bounds\n\ * could not be computed. RCOND = 0 is returned.\n\ * = N+1: U is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zpbrfs0000644000175000017500000001212012502223526016512 0ustar uwabamiuwabami--- :name: zpbrfs :md5sum: 772ad90aaaf5530161b964fe7ede2bfb :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublecomplex :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPBRFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is Hermitian positive definite\n\ * and banded, and provides error bounds and backward error estimates\n\ * for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * The upper or lower triangle of the Hermitian band matrix A,\n\ * stored in the first KD+1 rows of the array. The j-th column\n\ * of A is stored in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * AFB (input) COMPLEX*16 array, dimension (LDAFB,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**H*U or A = L*L**H of the band matrix A as computed by\n\ * ZPBTRF, in the same storage format as A (see AB).\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= KD+1.\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by ZPBTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zsptrs0000644000175000017500000000466712502223526016572 0ustar uwabamiuwabami--- :name: zsptrs :md5sum: d02dfce2a8e5b00442505e8d2142b19d :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSPTRS solves a system of linear equations A*X = B with a complex\n\ * symmetric matrix A stored in packed format using the factorization\n\ * A = U*D*U**T or A = L*D*L**T computed by ZSPTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by ZSPTRF, stored as a\n\ * packed triangular matrix.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by ZSPTRF.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cla_syrfsx_extended0000644000175000017500000003472312502223525021255 0ustar uwabamiuwabami--- :name: cla_syrfsx_extended :md5sum: 72b90b5cfd7630e9b07d0fa1740b3534 :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - colequ: :type: logical :intent: input - c: :type: real :intent: input :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: complex :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: real :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - err_bnds_norm: :type: real :intent: input/output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: input/output :dims: - nrhs - n_err_bnds - res: :type: complex :intent: input :dims: - n - ayb: :type: real :intent: input :dims: - n - dy: :type: complex :intent: input :dims: - n - y_tail: :type: complex :intent: input :dims: - n - rcond: :type: real :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: real :intent: input - dz_ub: :type: real :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLA_SYRFSX_EXTENDED improves the computed solution to a system of\n\ * linear equations by performing extra-precise iterative refinement\n\ * and provides error bounds and backward error estimates for the solution.\n\ * This subroutine is called by CSYRFSX to perform iterative refinement.\n\ * In addition to normwise error bound, the code provides maximum\n\ * componentwise error bound if possible. See comments for ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP for details of the error bounds. Note that this\n\ * subroutine is only resonsible for setting the second fields of\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * PREC_TYPE (input) INTEGER\n\ * Specifies the intermediate precision to be used in refinement.\n\ * The value is defined by ILAPREC(P) where P is a CHARACTER and\n\ * P = 'S': Single\n\ * = 'D': Double\n\ * = 'I': Indigenous\n\ * = 'X', 'E': Extra\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right-hand-sides, i.e., the number of columns of the\n\ * matrix B.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX array, dimension (LDAF,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by CSYTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by CSYTRF.\n\ *\n\ * COLEQU (input) LOGICAL\n\ * If .TRUE. then column equilibration was done to A before calling\n\ * this routine. This is needed to compute the solution and error\n\ * bounds correctly.\n\ *\n\ * C (input) REAL array, dimension (N)\n\ * The column scale factors for A. If COLEQU = .FALSE., C\n\ * is not accessed. If C is input, each element of C should be a power\n\ * of the radix to ensure a reliable solution and error estimates.\n\ * Scaling by powers of the radix does not cause rounding errors unless\n\ * the result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,NRHS)\n\ * The right-hand-side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * Y (input/output) COMPLEX array, dimension\n\ * (LDY,NRHS)\n\ * On entry, the solution matrix X, as computed by CSYTRS.\n\ * On exit, the improved solution matrix Y.\n\ *\n\ * LDY (input) INTEGER\n\ * The leading dimension of the array Y. LDY >= max(1,N).\n\ *\n\ * BERR_OUT (output) REAL array, dimension (NRHS)\n\ * On exit, BERR_OUT(j) contains the componentwise relative backward\n\ * error for right-hand-side j from the formula\n\ * max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n\ * where abs(Z) is the componentwise absolute value of the matrix\n\ * or vector Z. This is computed by CLA_LIN_BERR.\n\ *\n\ * N_NORMS (input) INTEGER\n\ * Determines which error bounds to return (see ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP).\n\ * If N_NORMS >= 1 return normwise error bounds.\n\ * If N_NORMS >= 2 return componentwise error bounds.\n\ *\n\ * ERR_BNDS_NORM (input/output) REAL array, dimension\n\ * (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (input/output) REAL array, dimension\n\ * (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * RES (input) COMPLEX array, dimension (N)\n\ * Workspace to hold the intermediate residual.\n\ *\n\ * AYB (input) REAL array, dimension (N)\n\ * Workspace.\n\ *\n\ * DY (input) COMPLEX array, dimension (N)\n\ * Workspace to hold the intermediate solution.\n\ *\n\ * Y_TAIL (input) COMPLEX array, dimension (N)\n\ * Workspace to hold the trailing bits of the intermediate solution.\n\ *\n\ * RCOND (input) REAL\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * ITHRESH (input) INTEGER\n\ * The maximum number of residual computations allowed for\n\ * refinement. The default is 10. For 'aggressive' set to 100 to\n\ * permit convergence using approximate factorizations or\n\ * factorizations other than LU. If the factorization uses a\n\ * technique other than Gaussian elimination, the guarantees in\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n\ *\n\ * RTHRESH (input) REAL\n\ * Determines when to stop refinement if the error estimate stops\n\ * decreasing. Refinement will stop when the next solution no longer\n\ * satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n\ * the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n\ * default value is 0.5. For 'aggressive' set to 0.9 to permit\n\ * convergence on extremely ill-conditioned matrices. See LAWN 165\n\ * for more details.\n\ *\n\ * DZ_UB (input) REAL\n\ * Determines when to start considering componentwise convergence.\n\ * Componentwise convergence is only considered after each component\n\ * of the solution Y is stable, which we definte as the relative\n\ * change in each component being less than DZ_UB. The default value\n\ * is 0.25, requiring the first bit to be stable. See LAWN 165 for\n\ * more details.\n\ *\n\ * IGNORE_CWISE (input) LOGICAL\n\ * If .TRUE. then ignore componentwise convergence. Default value\n\ * is .FALSE..\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * < 0: if INFO = -i, the ith argument to CSYTRS had an illegal\n\ * value\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE,\n $ Y_PREC_STATE\n REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n COMPLEX ZDUM\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cporfs0000644000175000017500000001140112502223525016500 0ustar uwabamiuwabami--- :name: cporfs :md5sum: f9b7b261f3c53ee94e6f500ba8bf61b7 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPORFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is Hermitian positive definite,\n\ * and provides error bounds and backward error estimates for the\n\ * solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The Hermitian matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular part\n\ * of the matrix A, and the strictly lower triangular part of A\n\ * is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of A contains the lower triangular part of\n\ * the matrix A, and the strictly upper triangular part of A is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX array, dimension (LDAF,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**H*U or A = L*L**H, as computed by CPOTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) COMPLEX array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by CPOTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * ====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dpttrs0000644000175000017500000000533612502223526016537 0ustar uwabamiuwabami--- :name: dpttrs :md5sum: 4df62154d25e780b1accac29911e5aef :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublereal :intent: input :dims: - n-1 - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPTTRS( N, NRHS, D, E, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPTTRS solves a tridiagonal system of the form\n\ * A * X = B\n\ * using the L*D*L' factorization of A computed by DPTTRF. D is a\n\ * diagonal matrix specified in the vector D, L is a unit bidiagonal\n\ * matrix whose subdiagonal is specified in the vector E, and X and B\n\ * are N by NRHS matrices.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the tridiagonal matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The n diagonal elements of the diagonal matrix D from the\n\ * L*D*L' factorization of A.\n\ *\n\ * E (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) subdiagonal elements of the unit bidiagonal factor\n\ * L from the L*D*L' factorization of A. E can also be regarded\n\ * as the superdiagonal of the unit bidiagonal factor U from the\n\ * factorization A = U'*D*U.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the right hand side vectors B for the system of\n\ * linear equations.\n\ * On exit, the solution vectors, X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER J, JB, NB\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DPTTS2, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zla_rpvgrw0000644000175000017500000000446112502223526017412 0ustar uwabamiuwabami--- :name: zla_rpvgrw :md5sum: 973297576068c8104e05e11efcbf080f :category: :function :type: doublereal :arguments: - n: :type: integer :intent: input - ncols: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION ZLA_RPVGRW( N, NCOLS, A, LDA, AF, LDAF )\n\n\ * Purpose\n\ * =======\n\ * \n\ * ZLA_RPVGRW computes the reciprocal pivot growth factor\n\ * norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n\ * much less than 1, the stability of the LU factorization of the\n\ * (equilibrated) matrix A could be poor. This also means that the\n\ * solution X, estimated condition numbers, and error bounds could be\n\ * unreliable.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NCOLS (input) INTEGER\n\ * The number of columns of the matrix A. NCOLS >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n\ * The factors L and U from the factorization\n\ * A = P*L*U as computed by ZGETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n DOUBLE PRECISION AMAX, UMAX, RPVGRW\n COMPLEX*16 ZDUM\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN, ABS, REAL, DIMAG\n\ * ..\n\ * .. Statement Functions ..\n DOUBLE PRECISION CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zhptrf0000644000175000017500000001153712502223526016534 0ustar uwabamiuwabami--- :name: zhptrf :md5sum: a5f6c770830276234c0c42f2e5e0d35f :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - ldap - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE ZHPTRF( UPLO, N, AP, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHPTRF computes the factorization of a complex Hermitian packed\n\ * matrix A using the Bunch-Kaufman diagonal pivoting method:\n\ *\n\ * A = U*D*U**H or A = L*D*L**H\n\ *\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, and D is Hermitian and block diagonal with\n\ * 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L, stored as a packed triangular\n\ * matrix overwriting A (see below for further details).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D.\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\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, D(i,i) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular, and division by zero will occur if it\n\ * is used to solve a system of equations.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * 5-96 - Based on modifications by J. Lewis, Boeing Computer Services\n\ * Company\n\ *\n\ * If UPLO = 'U', then A = U*D*U', where\n\ * U = P(n)*U(n)* ... *P(k)U(k)* ...,\n\ * i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n\ * 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I v 0 ) k-s\n\ * U(k) = ( 0 I 0 ) s\n\ * ( 0 0 I ) n-k\n\ * k-s s n-k\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n\ * If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n\ * and A(k,k), and v overwrites A(1:k-2,k-1:k).\n\ *\n\ * If UPLO = 'L', then A = L*D*L', where\n\ * L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n\ * i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n\ * n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I 0 0 ) k-1\n\ * L(k) = ( 0 I 0 ) s\n\ * ( 0 v I ) n-k-s+1\n\ * k-1 s n-k-s+1\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n\ * If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n\ * and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sla_porfsx_extended0000644000175000017500000003412512502223526021255 0ustar uwabamiuwabami--- :name: sla_porfsx_extended :md5sum: 48316f84c94865849f375c5fbf379958 :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - colequ: :type: logical :intent: input - c: :type: real :intent: input :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: real :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: real :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - err_bnds_norm: :type: real :intent: input/output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: input/output :dims: - nrhs - n_err_bnds - res: :type: real :intent: input :dims: - n - ayb: :type: real :intent: input :dims: - n - dy: :type: real :intent: input :dims: - n - y_tail: :type: real :intent: input :dims: - n - rcond: :type: real :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: real :intent: input - dz_ub: :type: real :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLA_PORFSX_EXTENDED improves the computed solution to a system of\n\ * linear equations by performing extra-precise iterative refinement\n\ * and provides error bounds and backward error estimates for the solution.\n\ * This subroutine is called by SPORFSX to perform iterative refinement.\n\ * In addition to normwise error bound, the code provides maximum\n\ * componentwise error bound if possible. See comments for ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP for details of the error bounds. Note that this\n\ * subroutine is only resonsible for setting the second fields of\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * PREC_TYPE (input) INTEGER\n\ * Specifies the intermediate precision to be used in refinement.\n\ * The value is defined by ILAPREC(P) where P is a CHARACTER and\n\ * P = 'S': Single\n\ * = 'D': Double\n\ * = 'I': Indigenous\n\ * = 'X', 'E': Extra\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right-hand-sides, i.e., the number of columns of the\n\ * matrix B.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) REAL array, dimension (LDAF,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T, as computed by SPOTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * COLEQU (input) LOGICAL\n\ * If .TRUE. then column equilibration was done to A before calling\n\ * this routine. This is needed to compute the solution and error\n\ * bounds correctly.\n\ *\n\ * C (input) REAL array, dimension (N)\n\ * The column scale factors for A. If COLEQU = .FALSE., C\n\ * is not accessed. If C is input, each element of C should be a power\n\ * of the radix to ensure a reliable solution and error estimates.\n\ * Scaling by powers of the radix does not cause rounding errors unless\n\ * the result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input) REAL array, dimension (LDB,NRHS)\n\ * The right-hand-side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * Y (input/output) REAL array, dimension (LDY,NRHS)\n\ * On entry, the solution matrix X, as computed by SPOTRS.\n\ * On exit, the improved solution matrix Y.\n\ *\n\ * LDY (input) INTEGER\n\ * The leading dimension of the array Y. LDY >= max(1,N).\n\ *\n\ * BERR_OUT (output) REAL array, dimension (NRHS)\n\ * On exit, BERR_OUT(j) contains the componentwise relative backward\n\ * error for right-hand-side j from the formula\n\ * max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n\ * where abs(Z) is the componentwise absolute value of the matrix\n\ * or vector Z. This is computed by SLA_LIN_BERR.\n\ *\n\ * N_NORMS (input) INTEGER\n\ * Determines which error bounds to return (see ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP).\n\ * If N_NORMS >= 1 return normwise error bounds.\n\ * If N_NORMS >= 2 return componentwise error bounds.\n\ *\n\ * ERR_BNDS_NORM (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * RES (input) REAL array, dimension (N)\n\ * Workspace to hold the intermediate residual.\n\ *\n\ * AYB (input) REAL array, dimension (N)\n\ * Workspace. This can be the same workspace passed for Y_TAIL.\n\ *\n\ * DY (input) REAL array, dimension (N)\n\ * Workspace to hold the intermediate solution.\n\ *\n\ * Y_TAIL (input) REAL array, dimension (N)\n\ * Workspace to hold the trailing bits of the intermediate solution.\n\ *\n\ * RCOND (input) REAL\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * ITHRESH (input) INTEGER\n\ * The maximum number of residual computations allowed for\n\ * refinement. The default is 10. For 'aggressive' set to 100 to\n\ * permit convergence using approximate factorizations or\n\ * factorizations other than LU. If the factorization uses a\n\ * technique other than Gaussian elimination, the guarantees in\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n\ *\n\ * RTHRESH (input) REAL\n\ * Determines when to stop refinement if the error estimate stops\n\ * decreasing. Refinement will stop when the next solution no longer\n\ * satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n\ * the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n\ * default value is 0.5. For 'aggressive' set to 0.9 to permit\n\ * convergence on extremely ill-conditioned matrices. See LAWN 165\n\ * for more details.\n\ *\n\ * DZ_UB (input) REAL\n\ * Determines when to start considering componentwise convergence.\n\ * Componentwise convergence is only considered after each component\n\ * of the solution Y is stable, which we definte as the relative\n\ * change in each component being less than DZ_UB. The default value\n\ * is 0.25, requiring the first bit to be stable. See LAWN 165 for\n\ * more details.\n\ *\n\ * IGNORE_CWISE (input) LOGICAL\n\ * If .TRUE. then ignore componentwise convergence. Default value\n\ * is .FALSE..\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * < 0: if INFO = -i, the ith argument to SPOTRS had an illegal\n\ * value\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE\n REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/ztgsyl0000644000175000017500000002256312502223526016554 0ustar uwabamiuwabami--- :name: ztgsyl :md5sum: 5c0a55052a20a73bcdac4d22cbfd8012 :category: :subroutine :arguments: - trans: :type: char :intent: input - ijob: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - d: :type: doublecomplex :intent: input :dims: - ldd - m - ldd: :type: integer :intent: input - e: :type: doublecomplex :intent: input :dims: - lde - n - lde: :type: integer :intent: input - f: :type: doublecomplex :intent: input/output :dims: - ldf - n - ldf: :type: integer :intent: input - scale: :type: doublereal :intent: output - dif: :type: doublereal :intent: output - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "((ijob==1||ijob==2)&&lsame_(&trans,\"N\")) ? 2*m*n : 1" - iwork: :type: integer :intent: workspace :dims: - m+n+2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTGSYL solves the generalized Sylvester equation:\n\ *\n\ * A * R - L * B = scale * C (1)\n\ * D * R - L * E = scale * F\n\ *\n\ * where R and L are unknown m-by-n matrices, (A, D), (B, E) and\n\ * (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n,\n\ * respectively, with complex entries. A, B, D and E are upper\n\ * triangular (i.e., (A,D) and (B,E) in generalized Schur form).\n\ *\n\ * The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1\n\ * is an output scaling factor chosen to avoid overflow.\n\ *\n\ * In matrix notation (1) is equivalent to solve Zx = scale*b, where Z\n\ * is defined as\n\ *\n\ * Z = [ kron(In, A) -kron(B', Im) ] (2)\n\ * [ kron(In, D) -kron(E', Im) ],\n\ *\n\ * Here Ix is the identity matrix of size x and X' is the conjugate\n\ * transpose of X. Kron(X, Y) is the Kronecker product between the\n\ * matrices X and Y.\n\ *\n\ * If TRANS = 'C', y in the conjugate transposed system Z'*y = scale*b\n\ * is solved for, which is equivalent to solve for R and L in\n\ *\n\ * A' * R + D' * L = scale * C (3)\n\ * R * B' + L * E' = scale * -F\n\ *\n\ * This case (TRANS = 'C') is used to compute an one-norm-based estimate\n\ * of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D)\n\ * and (B,E), using ZLACON.\n\ *\n\ * If IJOB >= 1, ZTGSYL computes a Frobenius norm-based estimate of\n\ * Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the\n\ * reciprocal of the smallest singular value of Z.\n\ *\n\ * This is a level-3 BLAS algorithm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': solve the generalized sylvester equation (1).\n\ * = 'C': solve the \"conjugate transposed\" system (3).\n\ *\n\ * IJOB (input) INTEGER\n\ * Specifies what kind of functionality to be performed.\n\ * =0: solve (1) only.\n\ * =1: The functionality of 0 and 3.\n\ * =2: The functionality of 0 and 4.\n\ * =3: Only an estimate of Dif[(A,D), (B,E)] is computed.\n\ * (look ahead strategy is used).\n\ * =4: Only an estimate of Dif[(A,D), (B,E)] is computed.\n\ * (ZGECON on sub-systems is used).\n\ * Not referenced if TRANS = 'C'.\n\ *\n\ * M (input) INTEGER\n\ * The order of the matrices A and D, and the row dimension of\n\ * the matrices C, F, R and L.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices B and E, and the column dimension\n\ * of the matrices C, F, R and L.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA, M)\n\ * The upper triangular matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1, M).\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB, N)\n\ * The upper triangular matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1, N).\n\ *\n\ * C (input/output) COMPLEX*16 array, dimension (LDC, N)\n\ * On entry, C contains the right-hand-side of the first matrix\n\ * equation in (1) or (3).\n\ * On exit, if IJOB = 0, 1 or 2, C has been overwritten by\n\ * the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R,\n\ * the solution achieved during the computation of the\n\ * Dif-estimate.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1, M).\n\ *\n\ * D (input) COMPLEX*16 array, dimension (LDD, M)\n\ * The upper triangular matrix D.\n\ *\n\ * LDD (input) INTEGER\n\ * The leading dimension of the array D. LDD >= max(1, M).\n\ *\n\ * E (input) COMPLEX*16 array, dimension (LDE, N)\n\ * The upper triangular matrix E.\n\ *\n\ * LDE (input) INTEGER\n\ * The leading dimension of the array E. LDE >= max(1, N).\n\ *\n\ * F (input/output) COMPLEX*16 array, dimension (LDF, N)\n\ * On entry, F contains the right-hand-side of the second matrix\n\ * equation in (1) or (3).\n\ * On exit, if IJOB = 0, 1 or 2, F has been overwritten by\n\ * the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L,\n\ * the solution achieved during the computation of the\n\ * Dif-estimate.\n\ *\n\ * LDF (input) INTEGER\n\ * The leading dimension of the array F. LDF >= max(1, M).\n\ *\n\ * DIF (output) DOUBLE PRECISION\n\ * On exit DIF is the reciprocal of a lower bound of the\n\ * reciprocal of the Dif-function, i.e. DIF is an upper bound of\n\ * Dif[(A,D), (B,E)] = sigma-min(Z), where Z as in (2).\n\ * IF IJOB = 0 or TRANS = 'C', DIF is not referenced.\n\ *\n\ * SCALE (output) DOUBLE PRECISION\n\ * On exit SCALE is the scaling factor in (1) or (3).\n\ * If 0 < SCALE < 1, C and F hold the solutions R and L, resp.,\n\ * to a slightly perturbed system but the input matrices A, B,\n\ * D and E have not been changed. If SCALE = 0, R and L will\n\ * hold the solutions to the homogenious system with C = F = 0.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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 > = 1.\n\ * If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N).\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\ * IWORK (workspace) INTEGER array, dimension (M+N+2)\n\ *\n\ * INFO (output) INTEGER\n\ * =0: successful exit\n\ * <0: If INFO = -i, the i-th argument had an illegal value.\n\ * >0: (A, D) and (B, E) have common or very close\n\ * eigenvalues.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n\ * for Solving the Generalized Sylvester Equation and Estimating the\n\ * Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n\ * Department of Computing Science, Umea University, S-901 87 Umea,\n\ * Sweden, December 1993, Revised April 1994, Also as LAPACK Working\n\ * Note 75. To appear in ACM Trans. on Math. Software, Vol 22,\n\ * No 1, 1996.\n\ *\n\ * [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester\n\ * Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal.\n\ * Appl., 15(4):1045-1060, 1994.\n\ *\n\ * [3] B. Kagstrom and L. Westin, Generalized Schur Methods with\n\ * Condition Estimators for Solving the Generalized Sylvester\n\ * Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7,\n\ * July 1989, pp 745-751.\n\ *\n\ * =====================================================================\n\ * Replaced various illegal calls to CCOPY by calls to CLASET.\n\ * Sven Hammarling, 1/5/02.\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgebak0000644000175000017500000000544412502223525016432 0ustar uwabamiuwabami--- :name: cgebak :md5sum: ec4f808992cd580a6d84750daf885382 :category: :subroutine :arguments: - job: :type: char :intent: input - side: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - scale: :type: real :intent: input :dims: - n - m: :type: integer :intent: input - v: :type: complex :intent: input/output :dims: - ldv - m - ldv: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGEBAK forms the right or left eigenvectors of a complex general\n\ * matrix by backward transformation on the computed eigenvectors of the\n\ * balanced matrix output by CGEBAL.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * Specifies the type of backward transformation required:\n\ * = 'N', do nothing, return immediately;\n\ * = 'P', do backward transformation for permutation only;\n\ * = 'S', do backward transformation for scaling only;\n\ * = 'B', do backward transformations for both permutation and\n\ * scaling.\n\ * JOB must be the same as the argument JOB supplied to CGEBAL.\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'R': V contains right eigenvectors;\n\ * = 'L': V contains left eigenvectors.\n\ *\n\ * N (input) INTEGER\n\ * The number of rows of the matrix V. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * The integers ILO and IHI determined by CGEBAL.\n\ * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n\ *\n\ * SCALE (input) REAL array, dimension (N)\n\ * Details of the permutation and scaling factors, as returned\n\ * by CGEBAL.\n\ *\n\ * M (input) INTEGER\n\ * The number of columns of the matrix V. M >= 0.\n\ *\n\ * V (input/output) COMPLEX array, dimension (LDV,M)\n\ * On entry, the matrix of right or left eigenvectors to be\n\ * transformed, as returned by CHSEIN or CTREVC.\n\ * On exit, V is overwritten by the transformed eigenvectors.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V. LDV >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/claset0000644000175000017500000000435612502223525016472 0ustar uwabamiuwabami--- :name: claset :md5sum: 064dfdfbe3ff9686c339a8059099f40d :category: :subroutine :arguments: - uplo: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: complex :intent: input - beta: :type: complex :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE CLASET( UPLO, M, N, ALPHA, BETA, A, LDA )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLASET initializes a 2-D array A to BETA on the diagonal and\n\ * ALPHA on the offdiagonals.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies the part of the matrix A to be set.\n\ * = 'U': Upper triangular part is set. The lower triangle\n\ * is unchanged.\n\ * = 'L': Lower triangular part is set. The upper triangle\n\ * is unchanged.\n\ * Otherwise: All of the matrix A is set.\n\ *\n\ * M (input) INTEGER\n\ * On entry, M specifies the number of rows of A.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the number of columns of A.\n\ *\n\ * ALPHA (input) COMPLEX\n\ * All the offdiagonal array elements are set to ALPHA.\n\ *\n\ * BETA (input) COMPLEX\n\ * All the diagonal array elements are set to BETA.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the m by n matrix A.\n\ * On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j;\n\ * A(i,i) = BETA , 1 <= i <= min(m,n)\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cunghr0000644000175000017500000000561312502223526016503 0ustar uwabamiuwabami--- :name: cunghr :md5sum: acce247a28646ccc2aef73082933dd45 :category: :subroutine :arguments: - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - n-1 - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: ihi-ilo - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CUNGHR generates a complex unitary matrix Q which is defined as the\n\ * product of IHI-ILO elementary reflectors of order N, as returned by\n\ * CGEHRD:\n\ *\n\ * Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix Q. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * ILO and IHI must have the same values as in the previous call\n\ * of CGEHRD. Q is equal to the unit matrix except in the\n\ * submatrix Q(ilo+1:ihi,ilo+1:ihi).\n\ * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the vectors which define the elementary reflectors,\n\ * as returned by CGEHRD.\n\ * On exit, the N-by-N unitary matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * TAU (input) COMPLEX array, dimension (N-1)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by CGEHRD.\n\ *\n\ * WORK (workspace/output) COMPLEX 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 >= IHI-ILO.\n\ * For optimum performance LWORK >= (IHI-ILO)*NB, where NB is\n\ * the 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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zheev0000644000175000017500000000711412502223526016334 0ustar uwabamiuwabami--- :name: zheev :md5sum: d20b733ac955437780c0f0f4ad96dad9 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n-1 - rwork: :type: doublereal :intent: workspace :dims: - MAX(1, 3*n-2) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHEEV computes all eigenvalues and, optionally, eigenvectors of a\n\ * complex Hermitian matrix A.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA, N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of A contains the\n\ * upper triangular part of the matrix A. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of A contains\n\ * the lower triangular part of the matrix A.\n\ * On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n\ * orthonormal eigenvectors of the matrix A.\n\ * If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n\ * or the upper triangle (if UPLO='U') of A, including the\n\ * diagonal, is destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of the array WORK. LWORK >= max(1,2*N-1).\n\ * For optimal efficiency, LWORK >= (NB+1)*N,\n\ * where NB is the blocksize for ZHETRD returned by ILAENV.\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\ * RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2))\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 algorithm failed to converge; i\n\ * off-diagonal elements of an intermediate tridiagonal\n\ * form did not converge to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clacp20000644000175000017500000000420312502223525016352 0ustar uwabamiuwabami--- :name: clacp2 :md5sum: 27b6c099766e4740d217c85767ea2a11 :category: :subroutine :arguments: - uplo: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: output :dims: - ldb - n - ldb: :type: integer :intent: input :substitutions: ldb: MAX(1,m) :fortran_help: " SUBROUTINE CLACP2( UPLO, M, N, A, LDA, B, LDB )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLACP2 copies all or part of a real two-dimensional matrix A to a\n\ * complex matrix B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies the part of the matrix A to be copied to B.\n\ * = 'U': Upper triangular part\n\ * = 'L': Lower triangular part\n\ * Otherwise: All of the matrix A\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) REAL array, dimension (LDA,N)\n\ * The m by n matrix A. If UPLO = 'U', only the upper trapezium\n\ * is accessed; if UPLO = 'L', only the lower trapezium is\n\ * accessed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (output) COMPLEX array, dimension (LDB,N)\n\ * On exit, B = A in the locations specified by UPLO.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,M).\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dsgesv0000644000175000017500000001401112502223526016500 0ustar uwabamiuwabami--- :name: dsgesv :md5sum: 37507bbdfd1407291f8640470f411a6e :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - n - nrhs - swork: :type: real :intent: workspace :dims: - n*(n+nrhs) - iter: :type: integer :intent: output - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE DSGESV( N, NRHS, A, LDA, IPIV, B, LDB, X, LDX, WORK, SWORK, ITER, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSGESV computes the solution to a real system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n\ *\n\ * DSGESV first attempts to factorize the matrix in SINGLE PRECISION\n\ * and use this factorization within an iterative refinement procedure\n\ * to produce a solution with DOUBLE PRECISION normwise backward error\n\ * quality (see below). If the approach fails the method switches to a\n\ * DOUBLE PRECISION factorization and solve.\n\ *\n\ * The iterative refinement is not going to be a winning strategy if\n\ * the ratio SINGLE PRECISION performance over DOUBLE PRECISION\n\ * performance is too small. A reasonable strategy should take the\n\ * number of right-hand sides and the size of the matrix into account.\n\ * This might be done with a call to ILAENV in the future. Up to now, we\n\ * always try iterative refinement.\n\ *\n\ * The iterative refinement process is stopped if\n\ * ITER > ITERMAX\n\ * or for all the RHS we have:\n\ * RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX\n\ * where\n\ * o ITER is the number of the current iteration in the iterative\n\ * refinement process\n\ * o RNRM is the infinity-norm of the residual\n\ * o XNRM is the infinity-norm of the solution\n\ * o ANRM is the infinity-operator-norm of the matrix A\n\ * o EPS is the machine epsilon returned by DLAMCH('Epsilon')\n\ * The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00\n\ * respectively.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array,\n\ * dimension (LDA,N)\n\ * On entry, the N-by-N coefficient matrix A.\n\ * On exit, if iterative refinement has been successfully used\n\ * (INFO.EQ.0 and ITER.GE.0, see description below), then A is\n\ * unchanged, if double precision factorization has been used\n\ * (INFO.EQ.0 and ITER.LT.0, see description below), then the\n\ * array A contains the factors L and U from the factorization\n\ * A = P*L*U; the unit diagonal elements of L are not stored.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * The pivot indices that define the permutation matrix P;\n\ * row i of the matrix was interchanged with row IPIV(i).\n\ * Corresponds either to the single precision factorization\n\ * (if INFO.EQ.0 and ITER.GE.0) or the double precision\n\ * factorization (if INFO.EQ.0 and ITER.LT.0).\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * The N-by-NRHS right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * If INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (N,NRHS)\n\ * This array is used to hold the residual vectors.\n\ *\n\ * SWORK (workspace) REAL array, dimension (N*(N+NRHS))\n\ * This array is used to use the single precision matrix and the\n\ * right-hand sides or solutions in single precision.\n\ *\n\ * ITER (output) INTEGER\n\ * < 0: iterative refinement has failed, double precision\n\ * factorization has been performed\n\ * -1 : the routine fell back to full precision for\n\ * implementation- or machine-specific reasons\n\ * -2 : narrowing the precision induced an overflow,\n\ * the routine fell back to full precision\n\ * -3 : failure of SGETRF\n\ * -31: stop the iterative refinement after the 30th\n\ * iterations\n\ * > 0: iterative refinement has been sucessfully used.\n\ * Returns the number of iterations\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, U(i,i) computed in DOUBLE PRECISION is\n\ * exactly zero. The factorization has been completed,\n\ * but the factor U is exactly singular, so the solution\n\ * could not be computed.\n\ *\n\ * =========\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssbev0000644000175000017500000000731612502223526016341 0ustar uwabamiuwabami--- :name: ssbev :md5sum: c21bb96306e38603fdb5434c2dc4066f :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,3*n-2) - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" :fortran_help: " SUBROUTINE SSBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSBEV computes all the eigenvalues and, optionally, eigenvectors of\n\ * a real symmetric band matrix A.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) REAL array, dimension (LDAB, N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * On exit, AB is overwritten by values generated during the\n\ * reduction to tridiagonal form. If UPLO = 'U', the first\n\ * superdiagonal and the diagonal of the tridiagonal matrix T\n\ * are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n\ * the diagonal and first subdiagonal of T are returned in the\n\ * first two rows of AB.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD + 1.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) REAL array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n\ * eigenvectors of the matrix A, with the i-th column of Z\n\ * holding the eigenvector associated with W(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) REAL array, dimension (max(1,3*N-2))\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 algorithm failed to converge; i\n\ * off-diagonal elements of an intermediate tridiagonal\n\ * form did not converge to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zsyr0000644000175000017500000000671712502223526016232 0ustar uwabamiuwabami--- :name: zsyr :md5sum: 33a5282ed2c27e74161752edaa7271f7 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - alpha: :type: doublecomplex :intent: input - x: :type: doublecomplex :intent: input :dims: - 1 + ( n - 1 )*abs( incx ) - incx: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE ZSYR( UPLO, N, ALPHA, X, INCX, A, LDA )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSYR performs the symmetric rank 1 operation\n\ *\n\ * A := alpha*x*( x' ) + A,\n\ *\n\ * where alpha is a complex scalar, x is an n element vector and A is an\n\ * n by n symmetric matrix.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * On entry, UPLO specifies whether the upper or lower\n\ * triangular part of the array A is to be referenced as\n\ * follows:\n\ *\n\ * UPLO = 'U' or 'u' Only the upper triangular part of A\n\ * is to be referenced.\n\ *\n\ * UPLO = 'L' or 'l' Only the lower triangular part of A\n\ * is to be referenced.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the order of the matrix A.\n\ * N must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * ALPHA (input) COMPLEX*16\n\ * On entry, ALPHA specifies the scalar alpha.\n\ * Unchanged on exit.\n\ *\n\ * X (input) COMPLEX*16 array, dimension at least\n\ * ( 1 + ( N - 1 )*abs( INCX ) ).\n\ * Before entry, the incremented array X must contain the N-\n\ * element vector x.\n\ * Unchanged on exit.\n\ *\n\ * INCX (input) INTEGER\n\ * On entry, INCX specifies the increment for the elements of\n\ * X. INCX must not be zero.\n\ * Unchanged on exit.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension ( LDA, N )\n\ * Before entry, with UPLO = 'U' or 'u', the leading n by n\n\ * upper triangular part of the array A must contain the upper\n\ * triangular part of the symmetric matrix and the strictly\n\ * lower triangular part of A is not referenced. On exit, the\n\ * upper triangular part of the array A is overwritten by the\n\ * upper triangular part of the updated matrix.\n\ * Before entry, with UPLO = 'L' or 'l', the leading n by n\n\ * lower triangular part of the array A must contain the lower\n\ * triangular part of the symmetric matrix and the strictly\n\ * upper triangular part of A is not referenced. On exit, the\n\ * lower triangular part of the array A is overwritten by the\n\ * lower triangular part of the updated matrix.\n\ *\n\ * LDA (input) INTEGER\n\ * On entry, LDA specifies the first dimension of A as declared\n\ * in the calling (sub) program. LDA must be at least\n\ * max( 1, N ).\n\ * Unchanged on exit.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlartv0000644000175000017500000000431312502223526016533 0ustar uwabamiuwabami--- :name: zlartv :md5sum: e5ca2c7119fc89e868f72f604550a7d4 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - y: :type: doublecomplex :intent: input/output :dims: - 1+(n-1)*incy - incy: :type: integer :intent: input - c: :type: doublereal :intent: input :dims: - 1+(n-1)*incc - s: :type: doublecomplex :intent: input :dims: - 1+(n-1)*incc - incc: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE ZLARTV( N, X, INCX, Y, INCY, C, S, INCC )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLARTV applies a vector of complex plane rotations with real cosines\n\ * to elements of the complex vectors x and y. For i = 1,2,...,n\n\ *\n\ * ( x(i) ) := ( c(i) s(i) ) ( x(i) )\n\ * ( y(i) ) ( -conjg(s(i)) c(i) ) ( y(i) )\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of plane rotations to be applied.\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX)\n\ * The vector x.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between elements of X. INCX > 0.\n\ *\n\ * Y (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCY)\n\ * The vector y.\n\ *\n\ * INCY (input) INTEGER\n\ * The increment between elements of Y. INCY > 0.\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)\n\ * The cosines of the plane rotations.\n\ *\n\ * S (input) COMPLEX*16 array, dimension (1+(N-1)*INCC)\n\ * The sines of the plane rotations.\n\ *\n\ * INCC (input) INTEGER\n\ * The increment between elements of C and S. INCC > 0.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, IC, IX, IY\n COMPLEX*16 XI, YI\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC DCONJG\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cunm2l0000644000175000017500000000725612502223526016422 0ustar uwabamiuwabami--- :name: cunm2l :md5sum: c3593596199bc8c9370014ab907efab6 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CUNM2L overwrites the general complex m-by-n matrix C with\n\ *\n\ * Q * C if SIDE = 'L' and TRANS = 'N', or\n\ *\n\ * Q'* C if SIDE = 'L' and TRANS = 'C', or\n\ *\n\ * C * Q if SIDE = 'R' and TRANS = 'N', or\n\ *\n\ * C * Q' if SIDE = 'R' and TRANS = 'C',\n\ *\n\ * where Q is a complex unitary matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(k) . . . H(2) H(1)\n\ *\n\ * as returned by CGEQLF. Q is of order m if SIDE = 'L' and of order n\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q' from the Left\n\ * = 'R': apply Q or Q' from the Right\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': apply Q (No transpose)\n\ * = 'C': apply Q' (Conjugate transpose)\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,K)\n\ * The i-th column must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * CGEQLF in the last k columns of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ * If SIDE = 'L', LDA >= max(1,M);\n\ * if SIDE = 'R', LDA >= max(1,N).\n\ *\n\ * TAU (input) COMPLEX array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by CGEQLF.\n\ *\n\ * C (input/output) COMPLEX array, dimension (LDC,N)\n\ * On entry, the m-by-n matrix C.\n\ * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension\n\ * (N) if SIDE = 'L',\n\ * (M) if SIDE = 'R'\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/csytri20000644000175000017500000000734312502223525016615 0ustar uwabamiuwabami--- :name: csytri2 :md5sum: b6d9a32ccfff551e13aeac00195defaa :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: complex :intent: workspace :dims: - lwork - lwork: :type: integer :intent: input :option: true :default: (n+nb+1)*(nb+3) - info: :type: integer :intent: output :substitutions: c__1: "1" c__m1: "-1" nb: ilaenv_(&c__1, "CSYTRF", &uplo, &n, &c__m1, &c__m1, &c__m1) :extras: c__1: integer c__m1: integer nb: integer :fortran_help: " SUBROUTINE CSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSYTRI2 computes the inverse of a complex symmetric indefinite matrix\n\ * A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n\ * CSYTRF. CSYTRI2 sets the LEADING DIMENSION of the workspace\n\ * before calling CSYTRI2X that actually computes the inverse.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the NB diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L as computed by CSYTRF.\n\ *\n\ * On exit, if INFO = 0, the (symmetric) inverse of the original\n\ * matrix. If UPLO = 'U', the upper triangular part of the\n\ * inverse is formed and the part of A below the diagonal is not\n\ * referenced; if UPLO = 'L' the lower triangular part of the\n\ * inverse is formed and the part of A above the diagonal is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the NB structure of D\n\ * as determined by CSYTRF.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (N+NB+1)*(NB+3)\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK.\n\ * WORK is size >= (N+NB+1)*(NB+3)\n\ * If LDWORK = -1, then a workspace query is assumed; the routine\n\ * calculates:\n\ * - the optimal size of the WORK array, returns\n\ * this value as the first entry of the WORK array,\n\ * - and no error message related to LDWORK 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, D(i,i) = 0; the matrix is singular and its\n\ * inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL UPPER, LQUERY\n INTEGER MINSIZE, NBMAX\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CSYTRI2X\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/csteqr0000644000175000017500000000714712502223525016521 0ustar uwabamiuwabami--- :name: csteqr :md5sum: 278eb31a7052cf9df5ea2f545eedabca :category: :subroutine :arguments: - compz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - z: :type: complex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "lsame_(&compz,\"N\") ? 0 : MAX(1,2*n-2)" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSTEQR computes all eigenvalues and, optionally, eigenvectors of a\n\ * symmetric tridiagonal matrix using the implicit QL or QR method.\n\ * The eigenvectors of a full or band complex Hermitian matrix can also\n\ * be found if CHETRD or CHPTRD or CHBTRD has been used to reduce this\n\ * matrix to tridiagonal form.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * COMPZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only.\n\ * = 'V': Compute eigenvalues and eigenvectors of the original\n\ * Hermitian matrix. On entry, Z must contain the\n\ * unitary matrix used to reduce the original matrix\n\ * to tridiagonal form.\n\ * = 'I': Compute eigenvalues and eigenvectors of the\n\ * tridiagonal matrix. Z is initialized to the identity\n\ * matrix.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the diagonal elements of the tridiagonal matrix.\n\ * On exit, if INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * E (input/output) REAL array, dimension (N-1)\n\ * On entry, the (n-1) subdiagonal elements of the tridiagonal\n\ * matrix.\n\ * On exit, E has been destroyed.\n\ *\n\ * Z (input/output) COMPLEX array, dimension (LDZ, N)\n\ * On entry, if COMPZ = 'V', then Z contains the unitary\n\ * matrix used in the reduction to tridiagonal form.\n\ * On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n\ * orthonormal eigenvectors of the original Hermitian matrix,\n\ * and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n\ * of the symmetric tridiagonal matrix.\n\ * If COMPZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * eigenvectors are desired, then LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) REAL array, dimension (max(1,2*N-2))\n\ * If COMPZ = 'N', then WORK is not referenced.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: the algorithm has failed to find all the eigenvalues in\n\ * a total of 30*N iterations; if INFO = i, then i\n\ * elements of E have not converged to zero; on exit, D\n\ * and E contain the elements of a symmetric tridiagonal\n\ * matrix which is unitarily similar to the original\n\ * matrix.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sggsvp0000644000175000017500000001512512502223526016525 0ustar uwabamiuwabami--- :name: sggsvp :md5sum: 8f9fa51bd57835c14e5543a88bb2b821 :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobv: :type: char :intent: input - jobq: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - tola: :type: real :intent: input - tolb: :type: real :intent: input - k: :type: integer :intent: output - l: :type: integer :intent: output - u: :type: real :intent: output :dims: - ldu - m - ldu: :type: integer :intent: input - v: :type: real :intent: output :dims: - ldv - p - ldv: :type: integer :intent: input - q: :type: real :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - iwork: :type: integer :intent: workspace :dims: - n - tau: :type: real :intent: workspace :dims: - n - work: :type: real :intent: workspace :dims: - MAX(MAX(3*n,m),p) - info: :type: integer :intent: output :substitutions: m: lda p: ldb ldq: "lsame_(&jobq,\"Q\") ? MAX(1,n) : 1" ldu: "lsame_(&jobu,\"U\") ? MAX(1,m) : 1" ldv: "lsame_(&jobv,\"V\") ? MAX(1,p) : 1" :fortran_help: " SUBROUTINE SGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGGSVP computes orthogonal matrices U, V and Q such that\n\ *\n\ * N-K-L K L\n\ * U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0;\n\ * L ( 0 0 A23 )\n\ * M-K-L ( 0 0 0 )\n\ *\n\ * N-K-L K L\n\ * = K ( 0 A12 A13 ) if M-K-L < 0;\n\ * M-K ( 0 0 A23 )\n\ *\n\ * N-K-L K L\n\ * V'*B*Q = L ( 0 0 B13 )\n\ * P-L ( 0 0 0 )\n\ *\n\ * where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n\ * upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n\ * otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective\n\ * numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the\n\ * transpose of Z.\n\ *\n\ * This decomposition is the preprocessing step for computing the\n\ * Generalized Singular Value Decomposition (GSVD), see subroutine\n\ * SGGSVD.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBU (input) CHARACTER*1\n\ * = 'U': Orthogonal matrix U is computed;\n\ * = 'N': U is not computed.\n\ *\n\ * JOBV (input) CHARACTER*1\n\ * = 'V': Orthogonal matrix V is computed;\n\ * = 'N': V is not computed.\n\ *\n\ * JOBQ (input) CHARACTER*1\n\ * = 'Q': Orthogonal matrix Q is computed;\n\ * = 'N': Q is not computed.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A. M >= 0.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows of the matrix B. P >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, A contains the triangular (or trapezoidal) matrix\n\ * described in the Purpose section.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input/output) REAL array, dimension (LDB,N)\n\ * On entry, the P-by-N matrix B.\n\ * On exit, B contains the triangular matrix described in\n\ * the Purpose section.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,P).\n\ *\n\ * TOLA (input) REAL\n\ * TOLB (input) REAL\n\ * TOLA and TOLB are the thresholds to determine the effective\n\ * numerical rank of matrix B and a subblock of A. Generally,\n\ * they are set to\n\ * TOLA = MAX(M,N)*norm(A)*MACHEPS,\n\ * TOLB = MAX(P,N)*norm(B)*MACHEPS.\n\ * The size of TOLA and TOLB may affect the size of backward\n\ * errors of the decomposition.\n\ *\n\ * K (output) INTEGER\n\ * L (output) INTEGER\n\ * On exit, K and L specify the dimension of the subblocks\n\ * described in Purpose.\n\ * K + L = effective numerical rank of (A',B')'.\n\ *\n\ * U (output) REAL array, dimension (LDU,M)\n\ * If JOBU = 'U', U contains the orthogonal matrix U.\n\ * If JOBU = 'N', U is not referenced.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= max(1,M) if\n\ * JOBU = 'U'; LDU >= 1 otherwise.\n\ *\n\ * V (output) REAL array, dimension (LDV,P)\n\ * If JOBV = 'V', V contains the orthogonal matrix V.\n\ * If JOBV = 'N', V is not referenced.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V. LDV >= max(1,P) if\n\ * JOBV = 'V'; LDV >= 1 otherwise.\n\ *\n\ * Q (output) REAL array, dimension (LDQ,N)\n\ * If JOBQ = 'Q', Q contains the orthogonal matrix Q.\n\ * If JOBQ = 'N', Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N) if\n\ * JOBQ = 'Q'; LDQ >= 1 otherwise.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * TAU (workspace) REAL array, dimension (N)\n\ *\n\ * WORK (workspace) REAL array, dimension (max(3*N,M,P))\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\n\ * Further Details\n\ * ===============\n\ *\n\ * The subroutine uses LAPACK subroutine SGEQPF for the QR factorization\n\ * with column pivoting to detect the effective numerical rank of the\n\ * a matrix. It may be replaced by a better rank determination strategy.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlarfgp0000644000175000017500000000372112502223526016660 0ustar uwabamiuwabami--- :name: zlarfgp :md5sum: 8380298bf6ea2a06c5eba285dbcf2805 :category: :subroutine :arguments: - n: :type: integer :intent: input - alpha: :type: doublecomplex :intent: input/output - x: :type: doublecomplex :intent: input/output :dims: - 1+(n-2)*abs(incx) - incx: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZLARFGP( N, ALPHA, X, INCX, TAU )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLARFGP generates a complex elementary reflector H of order n, such\n\ * that\n\ *\n\ * H' * ( alpha ) = ( beta ), H' * H = I.\n\ * ( x ) ( 0 )\n\ *\n\ * where alpha and beta are scalars, beta is real and non-negative, and\n\ * x is an (n-1)-element complex vector. H is represented in the form\n\ *\n\ * H = I - tau * ( 1 ) * ( 1 v' ) ,\n\ * ( v )\n\ *\n\ * where tau is a complex scalar and v is a complex (n-1)-element\n\ * vector. Note that H is not hermitian.\n\ *\n\ * If the elements of x are all zero and alpha is real, then tau = 0\n\ * and H is taken to be the unit matrix.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the elementary reflector.\n\ *\n\ * ALPHA (input/output) COMPLEX*16\n\ * On entry, the value alpha.\n\ * On exit, it is overwritten with the value beta.\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension\n\ * (1+(N-2)*abs(INCX))\n\ * On entry, the vector x.\n\ * On exit, it is overwritten with the vector v.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between elements of X. INCX > 0.\n\ *\n\ * TAU (output) COMPLEX*16\n\ * The value tau.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/csyr0000644000175000017500000000666412502223525016203 0ustar uwabamiuwabami--- :name: csyr :md5sum: 0d882c1ac101190a904cd313b2ad84cd :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - alpha: :type: complex :intent: input - x: :type: complex :intent: input :dims: - 1 + ( n - 1 )*abs( incx ) - incx: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE CSYR( UPLO, N, ALPHA, X, INCX, A, LDA )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSYR performs the symmetric rank 1 operation\n\ *\n\ * A := alpha*x*( x' ) + A,\n\ *\n\ * where alpha is a complex scalar, x is an n element vector and A is an\n\ * n by n symmetric matrix.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * On entry, UPLO specifies whether the upper or lower\n\ * triangular part of the array A is to be referenced as\n\ * follows:\n\ *\n\ * UPLO = 'U' or 'u' Only the upper triangular part of A\n\ * is to be referenced.\n\ *\n\ * UPLO = 'L' or 'l' Only the lower triangular part of A\n\ * is to be referenced.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the order of the matrix A.\n\ * N must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * ALPHA (input) COMPLEX\n\ * On entry, ALPHA specifies the scalar alpha.\n\ * Unchanged on exit.\n\ *\n\ * X (input) COMPLEX array, dimension at least\n\ * ( 1 + ( N - 1 )*abs( INCX ) ).\n\ * Before entry, the incremented array X must contain the N-\n\ * element vector x.\n\ * Unchanged on exit.\n\ *\n\ * INCX (input) INTEGER\n\ * On entry, INCX specifies the increment for the elements of\n\ * X. INCX must not be zero.\n\ * Unchanged on exit.\n\ *\n\ * A (input/output) COMPLEX array, dimension ( LDA, N )\n\ * Before entry, with UPLO = 'U' or 'u', the leading n by n\n\ * upper triangular part of the array A must contain the upper\n\ * triangular part of the symmetric matrix and the strictly\n\ * lower triangular part of A is not referenced. On exit, the\n\ * upper triangular part of the array A is overwritten by the\n\ * upper triangular part of the updated matrix.\n\ * Before entry, with UPLO = 'L' or 'l', the leading n by n\n\ * lower triangular part of the array A must contain the lower\n\ * triangular part of the symmetric matrix and the strictly\n\ * upper triangular part of A is not referenced. On exit, the\n\ * lower triangular part of the array A is overwritten by the\n\ * lower triangular part of the updated matrix.\n\ *\n\ * LDA (input) INTEGER\n\ * On entry, LDA specifies the first dimension of A as declared\n\ * in the calling (sub) program. LDA must be at least\n\ * max( 1, N ).\n\ * Unchanged on exit.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zspr0000644000175000017500000000675712502223526016225 0ustar uwabamiuwabami--- :name: zspr :md5sum: 1b45f732167d7f16a56853c51464aade :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - alpha: :type: doublecomplex :intent: input - x: :type: doublecomplex :intent: input :dims: - 1 + ( n - 1 )*abs( incx ) - incx: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - ( n*( n + 1 ) )/2 :substitutions: {} :fortran_help: " SUBROUTINE ZSPR( UPLO, N, ALPHA, X, INCX, AP )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSPR performs the symmetric rank 1 operation\n\ *\n\ * A := alpha*x*conjg( x' ) + A,\n\ *\n\ * where alpha is a complex scalar, x is an n element vector and A is an\n\ * n by n symmetric matrix, supplied in packed form.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * On entry, UPLO specifies whether the upper or lower\n\ * triangular part of the matrix A is supplied in the packed\n\ * array AP as follows:\n\ *\n\ * UPLO = 'U' or 'u' The upper triangular part of A is\n\ * supplied in AP.\n\ *\n\ * UPLO = 'L' or 'l' The lower triangular part of A is\n\ * supplied in AP.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the order of the matrix A.\n\ * N must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * ALPHA (input) COMPLEX*16\n\ * On entry, ALPHA specifies the scalar alpha.\n\ * Unchanged on exit.\n\ *\n\ * X (input) COMPLEX*16 array, dimension at least\n\ * ( 1 + ( N - 1 )*abs( INCX ) ).\n\ * Before entry, the incremented array X must contain the N-\n\ * element vector x.\n\ * Unchanged on exit.\n\ *\n\ * INCX (input) INTEGER\n\ * On entry, INCX specifies the increment for the elements of\n\ * X. INCX must not be zero.\n\ * Unchanged on exit.\n\ *\n\ * AP (input/output) COMPLEX*16 array, dimension at least\n\ * ( ( N*( N + 1 ) )/2 ).\n\ * Before entry, with UPLO = 'U' or 'u', the array AP must\n\ * contain the upper triangular part of the symmetric matrix\n\ * packed sequentially, column by column, so that AP( 1 )\n\ * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )\n\ * and a( 2, 2 ) respectively, and so on. On exit, the array\n\ * AP is overwritten by the upper triangular part of the\n\ * updated matrix.\n\ * Before entry, with UPLO = 'L' or 'l', the array AP must\n\ * contain the lower triangular part of the symmetric matrix\n\ * packed sequentially, column by column, so that AP( 1 )\n\ * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )\n\ * and a( 3, 1 ) respectively, and so on. On exit, the array\n\ * AP is overwritten by the lower triangular part of the\n\ * updated matrix.\n\ * Note that the imaginary parts of the diagonal elements need\n\ * not be set, they are assumed to be zero, and on exit they\n\ * are set to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dpocon0000644000175000017500000000474612502223526016505 0ustar uwabamiuwabami--- :name: dpocon :md5sum: 19c40cce9c2a922eb3d8ee1ae6cd2d5a :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPOCON estimates the reciprocal of the condition number (in the\n\ * 1-norm) of a real symmetric positive definite matrix using the\n\ * Cholesky factorization A = U**T*U or A = L*L**T computed by DPOTRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T, as computed by DPOTRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * ANORM (input) DOUBLE PRECISION\n\ * The 1-norm (or infinity-norm) of the symmetric matrix A.\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n\ * estimate of the 1-norm of inv(A) computed in this routine.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chpevd0000644000175000017500000001543612502223525016471 0ustar uwabamiuwabami--- :name: chpevd :md5sum: 27230956d597f9d089a7156bcfa7b173 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - ldap - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 2*n : 0" - rwork: :type: real :intent: output :dims: - MAX(1,lrwork) - lrwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "(lsame_(&jobz,\"N\")||n<=1) ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE CHPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHPEVD computes all the eigenvalues and, optionally, eigenvectors of\n\ * a complex Hermitian matrix A in packed storage. If eigenvectors are\n\ * desired, it uses a divide and conquer algorithm.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, AP is overwritten by values generated during the\n\ * reduction to tridiagonal form. If UPLO = 'U', the diagonal\n\ * and first superdiagonal of the tridiagonal matrix T overwrite\n\ * the corresponding elements of A, and if UPLO = 'L', the\n\ * diagonal and first subdiagonal of T overwrite the\n\ * corresponding elements of A.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) COMPLEX array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n\ * eigenvectors of the matrix A, with the i-th column of Z\n\ * holding the eigenvector associated with W(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the required LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of array WORK.\n\ * If N <= 1, LWORK must be at least 1.\n\ * If JOBZ = 'N' and N > 1, LWORK must be at least N.\n\ * If JOBZ = 'V' and N > 1, LWORK must be at least 2*N.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the required sizes of the WORK, RWORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK))\n\ * On exit, if INFO = 0, RWORK(1) returns the required LRWORK.\n\ *\n\ * LRWORK (input) INTEGER\n\ * The dimension of array RWORK.\n\ * If N <= 1, LRWORK must be at least 1.\n\ * If JOBZ = 'N' and N > 1, LRWORK must be at least N.\n\ * If JOBZ = 'V' and N > 1, LRWORK must be at least\n\ * 1 + 5*N + 2*N**2.\n\ *\n\ * If LRWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the required sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of array IWORK.\n\ * If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.\n\ * If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the required sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK 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 algorithm failed to converge; i\n\ * off-diagonal elements of an intermediate tridiagonal\n\ * form did not converge to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgelss0000644000175000017500000001202412502223526016516 0ustar uwabamiuwabami--- :name: zgelss :md5sum: 3ff0752f7cd079a1daa03043392ba6a3 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - MIN(m,n) - rcond: :type: doublereal :intent: input - rank: :type: integer :intent: output - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 3*MIN(m,n) + MAX(MAX(2*MIN(m,n),MAX(m,n)),nrhs) - rwork: :type: doublereal :intent: workspace :dims: - 5*MIN(m,n) - info: :type: integer :intent: output :substitutions: m: lda ldb: MAX(m, n) :fortran_help: " SUBROUTINE ZGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGELSS computes the minimum norm solution to a complex linear\n\ * least squares problem:\n\ *\n\ * Minimize 2-norm(| b - A*x |).\n\ *\n\ * using the singular value decomposition (SVD) of A. A is an M-by-N\n\ * matrix which may be rank-deficient.\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 matrix\n\ * X.\n\ *\n\ * The effective rank of A is determined by treating as zero those\n\ * singular values which are less than RCOND times the largest singular\n\ * value.\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\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, the first min(m,n) rows of A are overwritten with\n\ * its right singular vectors, stored rowwise.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the M-by-NRHS right hand side matrix B.\n\ * On exit, B is overwritten by the N-by-NRHS solution matrix X.\n\ * If m >= n and RANK = n, the residual sum-of-squares for\n\ * the solution in the i-th column is given by the sum of\n\ * squares of the modulus of elements n+1:m in that column.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,M,N).\n\ *\n\ * S (output) DOUBLE PRECISION array, dimension (min(M,N))\n\ * The singular values of A in decreasing order.\n\ * The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n\ *\n\ * RCOND (input) DOUBLE PRECISION\n\ * RCOND is used to determine the effective rank of A.\n\ * Singular values S(i) <= RCOND*S(1) are treated as zero.\n\ * If RCOND < 0, machine precision is used instead.\n\ *\n\ * RANK (output) INTEGER\n\ * The effective rank of A, i.e., the number of singular values\n\ * which are greater than RCOND*S(1).\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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 >= 1, and also:\n\ * LWORK >= 2*min(M,N) + max(M,N,NRHS)\n\ * For good performance, LWORK should generally be larger.\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\ * RWORK (workspace) DOUBLE PRECISION array, dimension (5*min(M,N))\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * > 0: the algorithm for computing the SVD failed to converge;\n\ * if INFO = i, i off-diagonal elements of an intermediate\n\ * bidiagonal form did not converge to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cggesx0000644000175000017500000002646412502223525016503 0ustar uwabamiuwabami--- :name: cggesx :md5sum: 2f0b8d24265696a975f64dcdb1eefeec :category: :subroutine :arguments: - jobvsl: :type: char :intent: input - jobvsr: :type: char :intent: input - sort: :type: char :intent: input - selctg: :intent: external procedure :block_type: logical :block_arg_num: 2 :block_arg_type: complex - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - sdim: :type: integer :intent: output - alpha: :type: complex :intent: output :dims: - n - beta: :type: complex :intent: output :dims: - n - vsl: :type: complex :intent: output :dims: - ldvsl - n - ldvsl: :type: integer :intent: input - vsr: :type: complex :intent: output :dims: - ldvsr - n - ldvsr: :type: integer :intent: input - rconde: :type: real :intent: output :dims: - "2" - rcondv: :type: real :intent: output :dims: - "2" - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n==0 ? 1 : (lsame_(&sense,\"E\")||lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? MAX(2*n,n*n/2) : 2*n" - rwork: :type: real :intent: workspace :dims: - 8*n - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "(lsame_(&sense,\"N\")||n==0) ? 1 : n+2" - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvsl: "lsame_(&jobvsl,\"V\") ? n : 1" ldvsr: "lsame_(&jobvsr,\"V\") ? n : 1" :fortran_help: " SUBROUTINE CGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, B, LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, RWORK, IWORK, LIWORK, BWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGGESX computes for a pair of N-by-N complex nonsymmetric matrices\n\ * (A,B), the generalized eigenvalues, the complex Schur form (S,T),\n\ * and, optionally, the left and/or right matrices of Schur vectors (VSL\n\ * and VSR). This gives the generalized Schur factorization\n\ *\n\ * (A,B) = ( (VSL) S (VSR)**H, (VSL) T (VSR)**H )\n\ *\n\ * where (VSR)**H is the conjugate-transpose of VSR.\n\ *\n\ * Optionally, it also orders the eigenvalues so that a selected cluster\n\ * of eigenvalues appears in the leading diagonal blocks of the upper\n\ * triangular matrix S and the upper triangular matrix T; computes\n\ * a reciprocal condition number for the average of the selected\n\ * eigenvalues (RCONDE); and computes a reciprocal condition number for\n\ * the right and left deflating subspaces corresponding to the selected\n\ * eigenvalues (RCONDV). The leading columns of VSL and VSR then form\n\ * an orthonormal basis for the corresponding left and right eigenspaces\n\ * (deflating subspaces).\n\ *\n\ * A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n\ * or a ratio alpha/beta = w, such that A - w*B is singular. It is\n\ * usually represented as the pair (alpha,beta), as there is a\n\ * reasonable interpretation for beta=0 or for both being zero.\n\ *\n\ * A pair of matrices (S,T) is in generalized complex Schur form if T is\n\ * upper triangular with non-negative diagonal and S is upper\n\ * triangular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVSL (input) CHARACTER*1\n\ * = 'N': do not compute the left Schur vectors;\n\ * = 'V': compute the left Schur vectors.\n\ *\n\ * JOBVSR (input) CHARACTER*1\n\ * = 'N': do not compute the right Schur vectors;\n\ * = 'V': compute the right Schur vectors.\n\ *\n\ * SORT (input) CHARACTER*1\n\ * Specifies whether or not to order the eigenvalues on the\n\ * diagonal of the generalized Schur form.\n\ * = 'N': Eigenvalues are not ordered;\n\ * = 'S': Eigenvalues are ordered (see SELCTG).\n\ *\n\ * SELCTG (external procedure) LOGICAL FUNCTION of two COMPLEX arguments\n\ * SELCTG must be declared EXTERNAL in the calling subroutine.\n\ * If SORT = 'N', SELCTG is not referenced.\n\ * If SORT = 'S', SELCTG is used to select eigenvalues to sort\n\ * to the top left of the Schur form.\n\ * Note that a selected complex eigenvalue may no longer satisfy\n\ * SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since\n\ * ordering may change the value of complex eigenvalues\n\ * (especially if the eigenvalue is ill-conditioned), in this\n\ * case INFO is set to N+3 see INFO below).\n\ *\n\ * SENSE (input) CHARACTER*1\n\ * Determines which reciprocal condition numbers are computed.\n\ * = 'N' : None are computed;\n\ * = 'E' : Computed for average of selected eigenvalues only;\n\ * = 'V' : Computed for selected deflating subspaces only;\n\ * = 'B' : Computed for both.\n\ * If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A, B, VSL, and VSR. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA, N)\n\ * On entry, the first of the pair of matrices.\n\ * On exit, A has been overwritten by its generalized Schur\n\ * form S.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB, N)\n\ * On entry, the second of the pair of matrices.\n\ * On exit, B has been overwritten by its generalized Schur\n\ * form T.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B. LDB >= max(1,N).\n\ *\n\ * SDIM (output) INTEGER\n\ * If SORT = 'N', SDIM = 0.\n\ * If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n\ * for which SELCTG is true.\n\ *\n\ * ALPHA (output) COMPLEX array, dimension (N)\n\ * BETA (output) COMPLEX array, dimension (N)\n\ * On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the\n\ * generalized eigenvalues. ALPHA(j) and BETA(j),j=1,...,N are\n\ * the diagonals of the complex Schur form (S,T). BETA(j) will\n\ * be non-negative real.\n\ *\n\ * Note: the quotients ALPHA(j)/BETA(j) may easily over- or\n\ * underflow, and BETA(j) may even be zero. Thus, the user\n\ * should avoid naively computing the ratio alpha/beta.\n\ * However, ALPHA will be always less than and usually\n\ * comparable with norm(A) in magnitude, and BETA always less\n\ * than and usually comparable with norm(B).\n\ *\n\ * VSL (output) COMPLEX array, dimension (LDVSL,N)\n\ * If JOBVSL = 'V', VSL will contain the left Schur vectors.\n\ * Not referenced if JOBVSL = 'N'.\n\ *\n\ * LDVSL (input) INTEGER\n\ * The leading dimension of the matrix VSL. LDVSL >=1, and\n\ * if JOBVSL = 'V', LDVSL >= N.\n\ *\n\ * VSR (output) COMPLEX array, dimension (LDVSR,N)\n\ * If JOBVSR = 'V', VSR will contain the right Schur vectors.\n\ * Not referenced if JOBVSR = 'N'.\n\ *\n\ * LDVSR (input) INTEGER\n\ * The leading dimension of the matrix VSR. LDVSR >= 1, and\n\ * if JOBVSR = 'V', LDVSR >= N.\n\ *\n\ * RCONDE (output) REAL array, dimension ( 2 )\n\ * If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the\n\ * reciprocal condition numbers for the average of the selected\n\ * eigenvalues.\n\ * Not referenced if SENSE = 'N' or 'V'.\n\ *\n\ * RCONDV (output) REAL array, dimension ( 2 )\n\ * If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the\n\ * reciprocal condition number for the selected deflating\n\ * subspaces.\n\ * Not referenced if SENSE = 'N' or 'E'.\n\ *\n\ * WORK (workspace/output) COMPLEX 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\ * If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B',\n\ * LWORK >= MAX(1,2*N,2*SDIM*(N-SDIM)), else\n\ * LWORK >= MAX(1,2*N). Note that 2*SDIM*(N-SDIM) <= N*N/2.\n\ * Note also that an error is only returned if\n\ * LWORK < MAX(1,2*N), but if SENSE = 'E' or 'V' or 'B' this may\n\ * not be large enough.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the bound on the optimal size of the WORK\n\ * array and the minimum size of the IWORK array, returns these\n\ * values as the first entries of the WORK and IWORK arrays, and\n\ * no error message related to LWORK or LIWORK is issued by\n\ * XERBLA.\n\ *\n\ * RWORK (workspace) REAL array, dimension ( 8*N )\n\ * Real workspace.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array WORK.\n\ * If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise\n\ * LIWORK >= N+2.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the bound on the optimal size of the\n\ * WORK array and the minimum size of the IWORK array, returns\n\ * these values as the first entries of the WORK and IWORK\n\ * arrays, and no error message related to LWORK or LIWORK is\n\ * issued by XERBLA.\n\ *\n\ * BWORK (workspace) LOGICAL array, dimension (N)\n\ * Not referenced if SORT = 'N'.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * = 1,...,N:\n\ * The QZ iteration failed. (A,B) are not in Schur\n\ * form, but ALPHA(j) and BETA(j) should be correct for\n\ * j=INFO+1,...,N.\n\ * > N: =N+1: other than QZ iteration failed in CHGEQZ\n\ * =N+2: after reordering, roundoff changed values of\n\ * some complex eigenvalues so that leading\n\ * eigenvalues in the Generalized Schur form no\n\ * longer satisfy SELCTG=.TRUE. This could also\n\ * be caused due to scaling.\n\ * =N+3: reordering failed in CTGSEN.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/stftri0000644000175000017500000001402512502223526016525 0ustar uwabamiuwabami--- :name: stftri :md5sum: 8257ba2b58870bddeb55353c065e8aa5 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE STFTRI( TRANSR, UPLO, DIAG, N, A, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STFTRI computes the inverse of a triangular matrix A stored in RFP\n\ * format.\n\ *\n\ * This is a Level 3 BLAS version of the algorithm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': The Normal TRANSR of RFP A is stored;\n\ * = 'T': The Transpose TRANSR of RFP A is stored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (NT);\n\ * NT=N*(N+1)/2. On entry, the triangular factor of a Hermitian\n\ * Positive Definite matrix A in RFP format. RFP format is\n\ * described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n\ * then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n\ * (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is\n\ * the transpose of RFP A as defined when\n\ * TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n\ * follows: If UPLO = 'U' the RFP A contains the nt elements of\n\ * upper packed A; If UPLO = 'L' the RFP A contains the nt\n\ * elements of lower packed A. The LDA of RFP A is (N+1)/2 when\n\ * TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is\n\ * even and N is odd. See the Note below for more details.\n\ *\n\ * On exit, the (triangular) inverse of the original matrix, in\n\ * the same storage format.\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, A(i,i) is exactly zero. The triangular\n\ * matrix is singular and its inverse can not be computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * We first consider Rectangular Full Packed (RFP) Format when N is\n\ * even. We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * the transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * the transpose of the last three columns of AP lower.\n\ * This covers the case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 04 05 33 43 53\n\ * 13 14 15 00 44 54\n\ * 23 24 25 10 11 55\n\ * 33 34 35 20 21 22\n\ * 00 44 45 30 31 32\n\ * 01 11 55 40 41 42\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We then consider Rectangular Full Packed (RFP) Format when N is\n\ * odd. We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * the transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * the transpose of the last two columns of AP lower.\n\ * This covers the case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 03 04 00 33 43\n\ * 12 13 14 10 11 44\n\ * 22 23 24 20 21 22\n\ * 00 33 34 30 31 32\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sggqrf0000644000175000017500000001551112502223526016504 0ustar uwabamiuwabami--- :name: sggqrf :md5sum: f1e600b5a35285017faea41a9d40ae77 :category: :subroutine :arguments: - n: :type: integer :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - m - lda: :type: integer :intent: input - taua: :type: real :intent: output :dims: - MIN(n,m) - b: :type: real :intent: input/output :dims: - ldb - p - ldb: :type: integer :intent: input - taub: :type: real :intent: output :dims: - MIN(n,p) - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(MAX(n,m),p) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGGQRF computes a generalized QR factorization of an N-by-M matrix A\n\ * and an N-by-P matrix B:\n\ *\n\ * A = Q*R, B = Q*T*Z,\n\ *\n\ * where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal\n\ * matrix, and R and T assume one of the forms:\n\ *\n\ * if N >= M, R = ( R11 ) M , or if N < M, R = ( R11 R12 ) N,\n\ * ( 0 ) N-M N M-N\n\ * M\n\ *\n\ * where R11 is upper triangular, and\n\ *\n\ * if N <= P, T = ( 0 T12 ) N, or if N > P, T = ( T11 ) N-P,\n\ * P-N N ( T21 ) P\n\ * P\n\ *\n\ * where T12 or T21 is upper triangular.\n\ *\n\ * In particular, if B is square and nonsingular, the GQR factorization\n\ * of A and B implicitly gives the QR factorization of inv(B)*A:\n\ *\n\ * inv(B)*A = Z'*(inv(T)*R)\n\ *\n\ * where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n\ * transpose of the matrix Z.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of rows of the matrices A and B. N >= 0.\n\ *\n\ * M (input) INTEGER\n\ * The number of columns of the matrix A. M >= 0.\n\ *\n\ * P (input) INTEGER\n\ * The number of columns of the matrix B. P >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,M)\n\ * On entry, the N-by-M matrix A.\n\ * On exit, the elements on and above the diagonal of the array\n\ * contain the min(N,M)-by-M upper trapezoidal matrix R (R is\n\ * upper triangular if N >= M); the elements below the diagonal,\n\ * with the array TAUA, represent the orthogonal matrix Q as a\n\ * product of min(N,M) elementary reflectors (see Further\n\ * Details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * TAUA (output) REAL array, dimension (min(N,M))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the orthogonal matrix Q (see Further Details).\n\ *\n\ * B (input/output) REAL array, dimension (LDB,P)\n\ * On entry, the N-by-P matrix B.\n\ * On exit, if N <= P, the upper triangle of the subarray\n\ * B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n\ * if N > P, the elements on and above the (N-P)-th subdiagonal\n\ * contain the N-by-P upper trapezoidal matrix T; the remaining\n\ * elements, with the array TAUB, represent the orthogonal\n\ * matrix Z as a product of elementary reflectors (see Further\n\ * Details).\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * TAUB (output) REAL array, dimension (min(N,P))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the orthogonal matrix Z (see Further Details).\n\ *\n\ * WORK (workspace/output) REAL 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,N,M,P).\n\ * For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n\ * where NB1 is the optimal blocksize for the QR factorization\n\ * of an N-by-M matrix, NB2 is the optimal blocksize for the\n\ * RQ factorization of an N-by-P matrix, and NB3 is the optimal\n\ * blocksize for a call of SORMQR.\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(1) H(2) . . . H(k), where k = min(n,m).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - taua * v * v'\n\ *\n\ * where taua 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+1:n,i),\n\ * and taua in TAUA(i).\n\ * To form Q explicitly, use LAPACK subroutine SORGQR.\n\ * To use Q to update another matrix, use LAPACK subroutine SORMQR.\n\ *\n\ * The matrix Z is represented as a product of elementary reflectors\n\ *\n\ * Z = H(1) H(2) . . . H(k), where k = min(n,p).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - taub * v * v'\n\ *\n\ * where taub is a real scalar, and v is a real vector with\n\ * v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in\n\ * B(n-k+i,1:p-k+i-1), and taub in TAUB(i).\n\ * To form Z explicitly, use LAPACK subroutine SORGRQ.\n\ * To use Z to update another matrix, use LAPACK subroutine SORMRQ.\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SGEQRF, SGERQF, SORMQR, XERBLA\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV \n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC INT, MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dorgrq0000644000175000017500000000575412502223526016521 0ustar uwabamiuwabami--- :name: dorgrq :md5sum: e982525c706ceef56e0ecde091ae0481 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DORGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DORGRQ generates an M-by-N real matrix Q with orthonormal rows,\n\ * which is defined as the last M rows of a product of K elementary\n\ * reflectors of order N\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by DGERQF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. N >= M.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. M >= K >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the (m-k+i)-th row must contain the vector which\n\ * defines the elementary reflector H(i), for i = 1,2,...,k, as\n\ * returned by DGERQF in the last k rows of its array argument\n\ * A.\n\ * On exit, the M-by-N matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) DOUBLE PRECISION array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by DGERQF.\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 has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsptrf0000644000175000017500000001156012502223526016515 0ustar uwabamiuwabami--- :name: dsptrf :md5sum: 6ecf609969698a72de25e3e961f876f8 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - ldap - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE DSPTRF( UPLO, N, AP, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSPTRF computes the factorization of a real symmetric matrix A stored\n\ * in packed format using the Bunch-Kaufman diagonal pivoting method:\n\ *\n\ * A = U*D*U**T or A = L*D*L**T\n\ *\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, and D is symmetric and block diagonal with\n\ * 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L, stored as a packed triangular\n\ * matrix overwriting A (see below for further details).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D.\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\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, D(i,i) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular, and division by zero will occur if it\n\ * is used to solve a system of equations.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * 5-96 - Based on modifications by J. Lewis, Boeing Computer Services\n\ * Company\n\ *\n\ * If UPLO = 'U', then A = U*D*U', where\n\ * U = P(n)*U(n)* ... *P(k)U(k)* ...,\n\ * i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n\ * 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I v 0 ) k-s\n\ * U(k) = ( 0 I 0 ) s\n\ * ( 0 0 I ) n-k\n\ * k-s s n-k\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n\ * If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n\ * and A(k,k), and v overwrites A(1:k-2,k-1:k).\n\ *\n\ * If UPLO = 'L', then A = L*D*L', where\n\ * L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n\ * i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n\ * n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I 0 0 ) k-1\n\ * L(k) = ( 0 I 0 ) s\n\ * ( 0 v I ) n-k-s+1\n\ * k-1 s n-k-s+1\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n\ * If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n\ * and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chpgst0000644000175000017500000000511212502223525016476 0ustar uwabamiuwabami--- :name: chpgst :md5sum: 1a890303b2501ebc28a37ce6b73eedd1 :category: :subroutine :arguments: - itype: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - n*(n+1)/2 - bp: :type: complex :intent: input :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CHPGST( ITYPE, UPLO, N, AP, BP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHPGST reduces a complex Hermitian-definite generalized\n\ * eigenproblem to standard form, using packed storage.\n\ *\n\ * If ITYPE = 1, the problem is A*x = lambda*B*x,\n\ * and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)\n\ *\n\ * If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n\ * B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L.\n\ *\n\ * B must have been previously factorized as U**H*U or L*L**H by CPPTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);\n\ * = 2 or 3: compute U*A*U**H or L**H*A*L.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored and B is factored as\n\ * U**H*U;\n\ * = 'L': Lower triangle of A is stored and B is factored as\n\ * L*L**H.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, if INFO = 0, the transformed matrix, stored in the\n\ * same format as A.\n\ *\n\ * BP (input) COMPLEX array, dimension (N*(N+1)/2)\n\ * The triangular factor from the Cholesky factorization of B,\n\ * stored in the same format as A, as returned by CPPTRF.\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgelsy0000644000175000017500000001473612502223526016540 0ustar uwabamiuwabami--- :name: zgelsy :md5sum: 0975498361fcf6232bb0bdd055804a74 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - rcond: :type: doublereal :intent: input - rank: :type: integer :intent: output - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(MIN(m,n)+3*n+1, 2*MIN(m,n)+nrhs) - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: m: lda ldb: MAX(m,n) :fortran_help: " SUBROUTINE ZGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGELSY computes the minimum-norm solution to a complex linear least\n\ * squares problem:\n\ * minimize || A * X - B ||\n\ * using a complete orthogonal factorization of A. A is an M-by-N\n\ * matrix which may be rank-deficient.\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\ * The routine first computes a QR factorization with column pivoting:\n\ * A * P = Q * [ R11 R12 ]\n\ * [ 0 R22 ]\n\ * with R11 defined as the largest leading submatrix whose estimated\n\ * condition number is less than 1/RCOND. The order of R11, RANK,\n\ * is the effective rank of A.\n\ *\n\ * Then, R22 is considered to be negligible, and R12 is annihilated\n\ * by unitary transformations from the right, arriving at the\n\ * complete orthogonal factorization:\n\ * A * P = Q * [ T11 0 ] * Z\n\ * [ 0 0 ]\n\ * The minimum-norm solution is then\n\ * X = P * Z' [ inv(T11)*Q1'*B ]\n\ * [ 0 ]\n\ * where Q1 consists of the first RANK columns of Q.\n\ *\n\ * This routine is basically identical to the original xGELSX except\n\ * three differences:\n\ * o The permutation of matrix B (the right hand side) is faster and\n\ * more simple.\n\ * o The call to the subroutine xGEQPF has been substituted by the\n\ * the call to the subroutine xGEQP3. This subroutine is a Blas-3\n\ * version of the QR factorization with column pivoting.\n\ * o Matrix B (the right hand side) is updated with Blas-3.\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\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of\n\ * columns of matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, A has been overwritten by details of its\n\ * complete orthogonal factorization.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the M-by-NRHS right hand side matrix B.\n\ * On exit, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,M,N).\n\ *\n\ * JPVT (input/output) INTEGER array, dimension (N)\n\ * On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n\ * to the front of AP, otherwise column i is a free column.\n\ * On exit, if JPVT(i) = k, then the i-th column of A*P\n\ * was the k-th column of A.\n\ *\n\ * RCOND (input) DOUBLE PRECISION\n\ * RCOND is used to determine the effective rank of A, which\n\ * is defined as the order of the largest leading triangular\n\ * submatrix R11 in the QR factorization with pivoting of A,\n\ * whose estimated condition number < 1/RCOND.\n\ *\n\ * RANK (output) INTEGER\n\ * The effective rank of A, i.e., the order of the submatrix\n\ * R11. This is the same as the order of the submatrix T11\n\ * in the complete orthogonal factorization of A.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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\ * The unblocked strategy requires that:\n\ * LWORK >= MN + MAX( 2*MN, N+1, MN+NRHS )\n\ * where MN = min(M,N).\n\ * The block algorithm requires that:\n\ * LWORK >= MN + MAX( 2*MN, NB*(N+1), MN+MN*NB, MN+NB*NRHS )\n\ * where NB is an upper bound on the blocksize returned\n\ * by ILAENV for the routines ZGEQP3, ZTZRZF, CTZRQF, ZUNMQR,\n\ * and ZUNMRZ.\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\ * RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\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\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ * E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n\ * G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlas20000644000175000017500000000415212502223526016217 0ustar uwabamiuwabami--- :name: dlas2 :md5sum: 6ae427644021d52d561acf40d2ec605c :category: :subroutine :arguments: - f: :type: doublereal :intent: input - g: :type: doublereal :intent: input - h: :type: doublereal :intent: input - ssmin: :type: doublereal :intent: output - ssmax: :type: doublereal :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAS2 computes the singular values of the 2-by-2 matrix\n\ * [ F G ]\n\ * [ 0 H ].\n\ * On return, SSMIN is the smaller singular value and SSMAX is the\n\ * larger singular value.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * F (input) DOUBLE PRECISION\n\ * The (1,1) element of the 2-by-2 matrix.\n\ *\n\ * G (input) DOUBLE PRECISION\n\ * The (1,2) element of the 2-by-2 matrix.\n\ *\n\ * H (input) DOUBLE PRECISION\n\ * The (2,2) element of the 2-by-2 matrix.\n\ *\n\ * SSMIN (output) DOUBLE PRECISION\n\ * The smaller singular value.\n\ *\n\ * SSMAX (output) DOUBLE PRECISION\n\ * The larger singular value.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Barring over/underflow, all output quantities are correct to within\n\ * a few units in the last place (ulps), even in the absence of a guard\n\ * digit in addition/subtraction.\n\ *\n\ * In IEEE arithmetic, the code works correctly if one matrix element is\n\ * infinite.\n\ *\n\ * Overflow will not occur unless the largest singular value itself\n\ * overflows, or is within a few ulps of overflow. (On machines with\n\ * partial overflow, like the Cray, overflow may occur if the largest\n\ * singular value is within a factor of 2 of overflow.)\n\ *\n\ * Underflow is harmless if underflow is gradual. Otherwise, results\n\ * may correspond to a matrix modified by perturbations of size near\n\ * the underflow threshold.\n\ *\n\ * ====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zsytrs0000644000175000017500000000501012502223526016562 0ustar uwabamiuwabami--- :name: zsytrs :md5sum: 0ac949a3605c07adf342125aa507bb44 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSYTRS solves a system of linear equations A*X = B with a complex\n\ * symmetric matrix A using the factorization A = U*D*U**T or\n\ * A = L*D*L**T computed by ZSYTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by ZSYTRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by ZSYTRF.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dla_gbrpvgrw0000644000175000017500000000546312502223526017700 0ustar uwabamiuwabami--- :name: dla_gbrpvgrw :md5sum: 8b95eb4dff88659ee9254d8e892a9501 :category: :function :type: doublereal :arguments: - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ncols: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublereal :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION DLA_GBRPVGRW( N, KL, KU, NCOLS, AB, LDAB, AFB, LDAFB )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLA_GBRPVGRW computes the reciprocal pivot growth factor\n\ * norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n\ * much less than 1, the stability of the LU factorization of the\n\ * (equilibrated) matrix A could be poor. This also means that the\n\ * solution X, estimated condition numbers, and error bounds could be\n\ * unreliable.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * NCOLS (input) INTEGER\n\ * The number of columns of the matrix A. NCOLS >= 0.\n\ *\n\ * AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n\ * Details of the LU factorization of the band matrix A, as\n\ * computed by DGBTRF. U is stored as an upper triangular\n\ * band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n\ * and the multipliers used during the factorization are stored\n\ * in rows KL+KU+2 to 2*KL+KU+1.\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J, KD\n DOUBLE PRECISION AMAX, UMAX, RPVGRW\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zsysvxx0000644000175000017500000005156512502223526017002 0ustar uwabamiuwabami--- :name: zsysvxx :md5sum: 3f3062455b8eddc6564c8ef135aac476 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - equed: :type: char :intent: input/output - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - rpvgrw: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " SUBROUTINE ZSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSYSVXX uses the diagonal pivoting factorization to compute the\n\ * solution to a complex*16 system of linear equations A * X = B, where\n\ * A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n\ * matrices.\n\ *\n\ * If requested, both normwise and maximum componentwise error bounds\n\ * are returned. ZSYSVXX will return a solution with a tiny\n\ * guaranteed error (O(eps) where eps is the working machine\n\ * precision) unless the matrix is very ill-conditioned, in which\n\ * case a warning is returned. Relevant condition numbers also are\n\ * calculated and returned.\n\ *\n\ * ZSYSVXX accepts user-provided factorizations and equilibration\n\ * factors; see the definitions of the FACT and EQUED options.\n\ * Solving with refinement and using a factorization from a previous\n\ * ZSYSVXX call will also produce a solution with either O(eps)\n\ * errors or warnings, but we cannot make that claim for general\n\ * user-provided factorizations and equilibration factors if they\n\ * differ from what ZSYSVXX would itself produce.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n\ * the system:\n\ *\n\ * diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B\n\ *\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n\ *\n\ * 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n\ * the matrix A (after equilibration if FACT = 'E') as\n\ *\n\ * A = U * D * U**T, if UPLO = 'U', or\n\ * A = L * D * L**T, if UPLO = 'L',\n\ *\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, and D is symmetric and block diagonal with\n\ * 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\ * 3. If some D(i,i)=0, so that D is exactly singular, then the\n\ * routine returns with INFO = i. Otherwise, the factored form of A\n\ * is used to estimate the condition number of the matrix A (see\n\ * argument RCOND). If the reciprocal of the condition number is\n\ * less than machine precision, the routine still goes on to solve\n\ * for X and compute error bounds as described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n\ * the routine will use iterative refinement to try to get a small\n\ * error and error bounds. Refinement calculates the residual to at\n\ * least twice the working precision.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(R) so that it solves the original system before\n\ * equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AF and IPIV contain the factored form of A.\n\ * If EQUED is not 'N', the matrix A has been\n\ * equilibrated with scaling factors given by S.\n\ * A, AF, and IPIV are not modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AF and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular\n\ * part of the matrix A, and the strictly lower triangular\n\ * part of A is not referenced. If UPLO = 'L', the leading\n\ * N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n\ * diag(S)*A*diag(S).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input or output) COMPLEX*16 array, dimension (LDAF,N)\n\ * If FACT = 'F', then AF is an input argument and on entry\n\ * contains the block diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L from the factorization A =\n\ * U*D*U**T or A = L*D*L**T as computed by DSYTRF.\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the block diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L from the factorization A =\n\ * U*D*U**T or A = L*D*L**T.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains details of the interchanges and the block\n\ * structure of D, as determined by DSYTRF. If IPIV(k) > 0,\n\ * then rows and columns k and IPIV(k) were interchanged and\n\ * D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and\n\ * IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and\n\ * -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2\n\ * diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0,\n\ * then rows and columns k+1 and -IPIV(k) were interchanged\n\ * and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains details of the interchanges and the block\n\ * structure of D, as determined by DSYTRF.\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'Y': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(S) * A * diag(S).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * S (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The scale factors for A. If EQUED = 'Y', A is multiplied on\n\ * the left and right by diag(S). S is an input argument if FACT =\n\ * 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n\ * = 'Y', each element of S must be positive. If S is output, each\n\ * element of S is a power of the radix. If S is input, each element\n\ * of S should be a power of the radix to ensure a reliable solution\n\ * and error estimates. Scaling by powers of the radix does not cause\n\ * rounding errors unless the result underflows or overflows.\n\ * Rounding errors during scaling lead to refining with a matrix that\n\ * is not equivalent to the input matrix, producing error estimates\n\ * that may not be reliable.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit,\n\ * if EQUED = 'N', B is not modified;\n\ * if EQUED = 'Y', B is overwritten by diag(S)*B;\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * If INFO = 0, the N-by-NRHS solution matrix X to the original\n\ * system of equations. Note that A and B are modified on exit if\n\ * EQUED .ne. 'N', and the solution to the equilibrated system is\n\ * inv(diag(S))*X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * RPVGRW (output) DOUBLE PRECISION\n\ * Reciprocal pivot growth. On exit, this contains the reciprocal\n\ * pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n\ * norm is used. If this is much less than 1, then the stability of\n\ * the LU factorization of the (equilibrated) matrix A could be poor.\n\ * This also means that the solution X, estimated condition numbers,\n\ * and error bounds could be unreliable. If factorization fails with\n\ * 0 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zpftri0000644000175000017500000001523212502223526016531 0ustar uwabamiuwabami--- :name: zpftri :md5sum: 43c1c7ce98a803f789417702484a41a1 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPFTRI( TRANSR, UPLO, N, A, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPFTRI computes the inverse of a complex Hermitian positive definite\n\ * matrix A using the Cholesky factorization A = U**H*U or A = L*L**H\n\ * computed by ZPFTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': The Normal TRANSR of RFP A is stored;\n\ * = 'C': The Conjugate-transpose TRANSR of RFP A is stored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension ( N*(N+1)/2 );\n\ * On entry, the Hermitian matrix A in RFP format. RFP format is\n\ * described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n\ * then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n\ * (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is\n\ * the Conjugate-transpose of RFP A as defined when\n\ * TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n\ * follows: If UPLO = 'U' the RFP A contains the nt elements of\n\ * upper packed A. If UPLO = 'L' the RFP A contains the elements\n\ * of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n\ * 'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n\ * is odd. See the Note below for more details.\n\ *\n\ * On exit, the Hermitian inverse of the original matrix, in the\n\ * same storage format.\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,i) element of the factor U or L is\n\ * zero, and the inverse could not be computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * We first consider Standard Packed Format when N is even.\n\ * We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * conjugate-transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * conjugate-transpose of the last three columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- --\n\ * 03 04 05 33 43 53\n\ * -- --\n\ * 13 14 15 00 44 54\n\ * --\n\ * 23 24 25 10 11 55\n\ *\n\ * 33 34 35 20 21 22\n\ * --\n\ * 00 44 45 30 31 32\n\ * -- --\n\ * 01 11 55 40 41 42\n\ * -- -- --\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We next consider Standard Packed Format when N is odd.\n\ * We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * conjugate-transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * conjugate-transpose of the last two columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- --\n\ * 02 03 04 00 33 43\n\ * --\n\ * 12 13 14 10 11 44\n\ *\n\ * 22 23 24 20 21 22\n\ * --\n\ * 00 33 34 30 31 32\n\ * -- --\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- --\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/stpttf0000644000175000017500000001246112502223526016540 0ustar uwabamiuwabami--- :name: stpttf :md5sum: bee582ac0fc39454a04971af8851b644 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input :dims: - ( n*(n+1)/2 ) - arf: :type: real :intent: output :dims: - ( n*(n+1)/2 ) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE STPTTF( TRANSR, UPLO, N, AP, ARF, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STPTTF copies a triangular matrix A from standard packed format (TP)\n\ * to rectangular full packed format (TF).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': ARF in Normal format is wanted;\n\ * = 'T': ARF in Conjugate-transpose format is wanted.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input) REAL array, dimension ( N*(N+1)/2 ),\n\ * On entry, the upper or lower triangular matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * ARF (output) REAL array, dimension ( N*(N+1)/2 ),\n\ * On exit, the upper or lower triangular matrix A stored in\n\ * RFP format. For a further discussion see Notes below.\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\ * We first consider Rectangular Full Packed (RFP) Format when N is\n\ * even. We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * the transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * the transpose of the last three columns of AP lower.\n\ * This covers the case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 04 05 33 43 53\n\ * 13 14 15 00 44 54\n\ * 23 24 25 10 11 55\n\ * 33 34 35 20 21 22\n\ * 00 44 45 30 31 32\n\ * 01 11 55 40 41 42\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We then consider Rectangular Full Packed (RFP) Format when N is\n\ * odd. We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * the transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * the transpose of the last two columns of AP lower.\n\ * This covers the case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 03 04 00 33 43\n\ * 12 13 14 10 11 44\n\ * 22 23 24 20 21 22\n\ * 00 33 34 30 31 32\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgttrs0000644000175000017500000000670612502223526016547 0ustar uwabamiuwabami--- :name: sgttrs :md5sum: 8a9f866de5c6cec7691ae47b40d6cc6c :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: real :intent: input :dims: - n-1 - d: :type: real :intent: input :dims: - n - du: :type: real :intent: input :dims: - n-1 - du2: :type: real :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGTTRS solves one of the systems of equations\n\ * A*X = B or A'*X = B,\n\ * with a tridiagonal matrix A using the LU factorization computed\n\ * by SGTTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations.\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A'* X = B (Transpose)\n\ * = 'C': A'* X = B (Conjugate transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * DL (input) REAL array, dimension (N-1)\n\ * The (n-1) multipliers that define the matrix L from the\n\ * LU factorization of A.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The n diagonal elements of the upper triangular matrix U from\n\ * the LU factorization of A.\n\ *\n\ * DU (input) REAL array, dimension (N-1)\n\ * The (n-1) elements of the first super-diagonal of U.\n\ *\n\ * DU2 (input) REAL array, dimension (N-2)\n\ * The (n-2) elements of the second super-diagonal of U.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices; for 1 <= i <= n, row i of the matrix was\n\ * interchanged with row IPIV(i). IPIV(i) will always be either\n\ * i or i+1; IPIV(i) = i indicates a row interchange was not\n\ * required.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the matrix of right hand side vectors B.\n\ * On exit, B is overwritten by the solution vectors X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL NOTRAN\n INTEGER ITRANS, J, JB, NB\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SGTTS2, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zunmbr0000644000175000017500000001426512502223526016535 0ustar uwabamiuwabami--- :name: zunmbr :md5sum: 39e1a87077ff3d4f0239a32149d77cc5 :category: :subroutine :arguments: - vect: :type: char :intent: input - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - MIN(nq,k) - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - MIN(nq,k) - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: nq: "lsame_(&side,\"L\") ? m : lsame_(&side,\"R\") ? n : 0" :fortran_help: " SUBROUTINE ZUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * If VECT = 'Q', ZUNMBR overwrites the general complex M-by-N matrix C\n\ * with\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'C': Q**H * C C * Q**H\n\ *\n\ * If VECT = 'P', ZUNMBR overwrites the general complex M-by-N matrix C\n\ * with\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': P * C C * P\n\ * TRANS = 'C': P**H * C C * P**H\n\ *\n\ * Here Q and P**H are the unitary matrices determined by ZGEBRD when\n\ * reducing a complex matrix A to bidiagonal form: A = Q * B * P**H. Q\n\ * and P**H are defined as products of elementary reflectors H(i) and\n\ * G(i) respectively.\n\ *\n\ * Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the\n\ * order of the unitary matrix Q or P**H that is applied.\n\ *\n\ * If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:\n\ * if nq >= k, Q = H(1) H(2) . . . H(k);\n\ * if nq < k, Q = H(1) H(2) . . . H(nq-1).\n\ *\n\ * If VECT = 'P', A is assumed to have been a K-by-NQ matrix:\n\ * if k < nq, P = G(1) G(2) . . . G(k);\n\ * if k >= nq, P = G(1) G(2) . . . G(nq-1).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * VECT (input) CHARACTER*1\n\ * = 'Q': apply Q or Q**H;\n\ * = 'P': apply P or P**H.\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q, Q**H, P or P**H from the Left;\n\ * = 'R': apply Q, Q**H, P or P**H from the Right.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q or P;\n\ * = 'C': Conjugate transpose, apply Q**H or P**H.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * If VECT = 'Q', the number of columns in the original\n\ * matrix reduced by ZGEBRD.\n\ * If VECT = 'P', the number of rows in the original\n\ * matrix reduced by ZGEBRD.\n\ * K >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension\n\ * (LDA,min(nq,K)) if VECT = 'Q'\n\ * (LDA,nq) if VECT = 'P'\n\ * The vectors which define the elementary reflectors H(i) and\n\ * G(i), whose products determine the matrices Q and P, as\n\ * returned by ZGEBRD.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ * If VECT = 'Q', LDA >= max(1,nq);\n\ * if VECT = 'P', LDA >= max(1,min(nq,K)).\n\ *\n\ * TAU (input) COMPLEX*16 array, dimension (min(nq,K))\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i) or G(i) which determines Q or P, as returned\n\ * by ZGEBRD in the array argument TAUQ or TAUP.\n\ *\n\ * C (input/output) COMPLEX*16 array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q\n\ * or P*C or P**H*C or C*P or C*P**H.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M);\n\ * if N = 0 or M = 0, LWORK >= 1.\n\ * For optimum performance LWORK >= max(1,N*NB) if SIDE = 'L',\n\ * and LWORK >= max(1,M*NB) if SIDE = 'R', where NB is the\n\ * optimal blocksize. (NB = 0 if M = 0 or N = 0.)\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\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN\n CHARACTER TRANST\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZUNMLQ, ZUNMQR\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/lsamen0000644000175000017500000000270112502223526016467 0ustar uwabamiuwabami--- :name: lsamen :md5sum: 436b27be921ef85dfbabbd827f65a5f1 :category: :function :type: logical :arguments: - n: :type: integer :intent: input - ca: :type: char :intent: input :dims: - "*" - cb: :type: char :intent: input :dims: - "*" :substitutions: {} :fortran_help: " LOGICAL FUNCTION LSAMEN( N, CA, CB )\n\n\ * Purpose\n\ * =======\n\ *\n\ * LSAMEN tests if the first N letters of CA are the same as the\n\ * first N letters of CB, regardless of case.\n\ * LSAMEN returns .TRUE. if CA and CB are equivalent except for case\n\ * and .FALSE. otherwise. LSAMEN also returns .FALSE. if LEN( CA )\n\ * or LEN( CB ) is less than N.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of characters in CA and CB to be compared.\n\ *\n\ * CA (input) CHARACTER*(*)\n\ * CB (input) CHARACTER*(*)\n\ * CA and CB specify two character strings of length at least N.\n\ * Only the first N characters of each string will be accessed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC LEN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cheevx0000644000175000017500000001760112502223525016476 0ustar uwabamiuwabami--- :name: cheevx :md5sum: 16e52f5a970fe326d98bf7b6bca8e538 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : 2*n" - rwork: :type: real :intent: workspace :dims: - 7*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " SUBROUTINE CHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHEEVX computes selected eigenvalues and, optionally, eigenvectors\n\ * of a complex Hermitian matrix A. Eigenvalues and eigenvectors can\n\ * be selected by specifying either a range of values or a range of\n\ * indices for the desired eigenvalues.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found.\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found.\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA, N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of A contains the\n\ * upper triangular part of the matrix A. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of A contains\n\ * the lower triangular part of the matrix A.\n\ * On exit, the lower triangle (if UPLO='L') or the upper\n\ * triangle (if UPLO='U') of A, including the diagonal, is\n\ * destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * VL (input) REAL\n\ * VU (input) REAL\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) REAL\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less than\n\ * or equal to zero, then EPS*|T| will be used in its place,\n\ * where |T| is the 1-norm of the tridiagonal matrix obtained\n\ * by reducing A to tridiagonal form.\n\ *\n\ * Eigenvalues will be computed most accurately when ABSTOL is\n\ * set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n\ * If this routine returns with INFO>0, indicating that some\n\ * eigenvectors did not converge, try setting ABSTOL to\n\ * 2*SLAMCH('S').\n\ *\n\ * See \"Computing Small Singular Values of Bidiagonal Matrices\n\ * with Guaranteed High Relative Accuracy,\" by Demmel and\n\ * Kahan, LAPACK Working Note #3.\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * On normal exit, the first M elements contain the selected\n\ * eigenvalues in ascending order.\n\ *\n\ * Z (output) COMPLEX array, dimension (LDZ, max(1,M))\n\ * If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix A\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * If an eigenvector fails to converge, then that column of Z\n\ * contains the latest approximation to the eigenvector, and the\n\ * index of the eigenvector is returned in IFAIL.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of the array WORK. LWORK >= 1, when N <= 1;\n\ * otherwise 2*N.\n\ * For optimal efficiency, LWORK >= (NB+1)*N,\n\ * where NB is the max of the blocksize for CHETRD and for\n\ * CUNMTR as returned by ILAENV.\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\ * RWORK (workspace) REAL array, dimension (7*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (5*N)\n\ *\n\ * IFAIL (output) INTEGER array, dimension (N)\n\ * If JOBZ = 'V', then if INFO = 0, the first M elements of\n\ * IFAIL are zero. If INFO > 0, then IFAIL contains the\n\ * indices of the eigenvectors that failed to converge.\n\ * If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n\ * Their indices are stored in array IFAIL.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cggqrf0000644000175000017500000001555112502223525016467 0ustar uwabamiuwabami--- :name: cggqrf :md5sum: a13fa854c2926b10d6ea7e667ca8049f :category: :subroutine :arguments: - n: :type: integer :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - m - lda: :type: integer :intent: input - taua: :type: complex :intent: output :dims: - MIN(n,m) - b: :type: complex :intent: input/output :dims: - ldb - p - ldb: :type: integer :intent: input - taub: :type: complex :intent: output :dims: - MIN(n,p) - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(MAX(n,m),p) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGGQRF computes a generalized QR factorization of an N-by-M matrix A\n\ * and an N-by-P matrix B:\n\ *\n\ * A = Q*R, B = Q*T*Z,\n\ *\n\ * where Q is an N-by-N unitary matrix, Z is a P-by-P unitary matrix,\n\ * and R and T assume one of the forms:\n\ *\n\ * if N >= M, R = ( R11 ) M , or if N < M, R = ( R11 R12 ) N,\n\ * ( 0 ) N-M N M-N\n\ * M\n\ *\n\ * where R11 is upper triangular, and\n\ *\n\ * if N <= P, T = ( 0 T12 ) N, or if N > P, T = ( T11 ) N-P,\n\ * P-N N ( T21 ) P\n\ * P\n\ *\n\ * where T12 or T21 is upper triangular.\n\ *\n\ * In particular, if B is square and nonsingular, the GQR factorization\n\ * of A and B implicitly gives the QR factorization of inv(B)*A:\n\ *\n\ * inv(B)*A = Z'*(inv(T)*R)\n\ *\n\ * where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n\ * conjugate transpose of matrix Z.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of rows of the matrices A and B. N >= 0.\n\ *\n\ * M (input) INTEGER\n\ * The number of columns of the matrix A. M >= 0.\n\ *\n\ * P (input) INTEGER\n\ * The number of columns of the matrix B. P >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,M)\n\ * On entry, the N-by-M matrix A.\n\ * On exit, the elements on and above the diagonal of the array\n\ * contain the min(N,M)-by-M upper trapezoidal matrix R (R is\n\ * upper triangular if N >= M); the elements below the diagonal,\n\ * with the array TAUA, represent the unitary matrix Q as a\n\ * product of min(N,M) elementary reflectors (see Further\n\ * Details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * TAUA (output) COMPLEX array, dimension (min(N,M))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the unitary matrix Q (see Further Details).\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,P)\n\ * On entry, the N-by-P matrix B.\n\ * On exit, if N <= P, the upper triangle of the subarray\n\ * B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n\ * if N > P, the elements on and above the (N-P)-th subdiagonal\n\ * contain the N-by-P upper trapezoidal matrix T; the remaining\n\ * elements, with the array TAUB, represent the unitary\n\ * matrix Z as a product of elementary reflectors (see Further\n\ * Details).\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * TAUB (output) COMPLEX array, dimension (min(N,P))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the unitary matrix Z (see Further Details).\n\ *\n\ * WORK (workspace/output) COMPLEX 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,N,M,P).\n\ * For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n\ * where NB1 is the optimal blocksize for the QR factorization\n\ * of an N-by-M matrix, NB2 is the optimal blocksize for the\n\ * RQ factorization of an N-by-P matrix, and NB3 is the optimal\n\ * blocksize for a call of CUNMQR.\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(1) H(2) . . . H(k), where k = min(n,m).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - taua * v * v'\n\ *\n\ * where taua is a complex scalar, and v is a complex vector with\n\ * v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),\n\ * and taua in TAUA(i).\n\ * To form Q explicitly, use LAPACK subroutine CUNGQR.\n\ * To use Q to update another matrix, use LAPACK subroutine CUNMQR.\n\ *\n\ * The matrix Z is represented as a product of elementary reflectors\n\ *\n\ * Z = H(1) H(2) . . . H(k), where k = min(n,p).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - taub * v * v'\n\ *\n\ * where taub is a complex scalar, and v is a complex vector with\n\ * v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in\n\ * B(n-k+i,1:p-k+i-1), and taub in TAUB(i).\n\ * To form Z explicitly, use LAPACK subroutine CUNGRQ.\n\ * To use Z to update another matrix, use LAPACK subroutine CUNMRQ.\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CGEQRF, CGERQF, CUNMQR, XERBLA\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV \n EXTERNAL ILAENV\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC INT, MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/clascl20000644000175000017500000000276712502223525016546 0ustar uwabamiuwabami--- :name: clascl2 :md5sum: 9b6d7c19706b050d8089911e3fd99ddc :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - m - x: :type: complex :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE CLASCL2 ( M, N, D, X, LDX )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLASCL2 performs a diagonal scaling on a vector:\n\ * x <-- D * x\n\ * where the diagonal REAL matrix D is stored as a vector.\n\ *\n\ * Eventually to be replaced by BLAS_cge_diag_scale in the new BLAS\n\ * standard.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of D and X. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of D and X. N >= 0.\n\ *\n\ * D (input) REAL array, length M\n\ * Diagonal matrix D, stored as a vector of length M.\n\ *\n\ * X (input/output) COMPLEX array, dimension (LDX,N)\n\ * On entry, the vector X to be scaled by D.\n\ * On exit, the scaled vector.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the vector X. LDX >= 0.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slagtm0000644000175000017500000000577212502223526016512 0ustar uwabamiuwabami--- :name: slagtm :md5sum: 38a005a5d2de8569634e40e7455b437a :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - alpha: :type: real :intent: input - dl: :type: real :intent: input :dims: - n-1 - d: :type: real :intent: input :dims: - n - du: :type: real :intent: input :dims: - n-1 - x: :type: real :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - beta: :type: real :intent: input - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE SLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, B, LDB )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAGTM performs a matrix-vector product of the form\n\ *\n\ * B := alpha * A * X + beta * B\n\ *\n\ * where A is a tridiagonal matrix of order N, B and X are N by NRHS\n\ * matrices, and alpha and beta are real scalars, each of which may be\n\ * 0., 1., or -1.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the operation applied to A.\n\ * = 'N': No transpose, B := alpha * A * X + beta * B\n\ * = 'T': Transpose, B := alpha * A'* X + beta * B\n\ * = 'C': Conjugate transpose = Transpose\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices X and B.\n\ *\n\ * ALPHA (input) REAL\n\ * The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise,\n\ * it is assumed to be 0.\n\ *\n\ * DL (input) REAL array, dimension (N-1)\n\ * The (n-1) sub-diagonal elements of T.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The diagonal elements of T.\n\ *\n\ * DU (input) REAL array, dimension (N-1)\n\ * The (n-1) super-diagonal elements of T.\n\ *\n\ * X (input) REAL array, dimension (LDX,NRHS)\n\ * The N by NRHS matrix X.\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(N,1).\n\ *\n\ * BETA (input) REAL\n\ * The scalar beta. BETA must be 0., 1., or -1.; otherwise,\n\ * it is assumed to be 1.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the N by NRHS matrix B.\n\ * On exit, B is overwritten by the matrix expression\n\ * B := alpha * A * X + beta * B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(N,1).\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgecon0000644000175000017500000000474212502223525016454 0ustar uwabamiuwabami--- :name: cgecon :md5sum: f5f1bbadb10b69b8f3ee9c60dc75b75c :category: :subroutine :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGECON estimates the reciprocal of the condition number of a general\n\ * complex matrix A, in either the 1-norm or the infinity-norm, using\n\ * the LU factorization computed by CGETRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as\n\ * RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies whether the 1-norm condition number or the\n\ * infinity-norm condition number is required:\n\ * = '1' or 'O': 1-norm;\n\ * = 'I': Infinity-norm.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The factors L and U from the factorization A = P*L*U\n\ * as computed by CGETRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * ANORM (input) REAL\n\ * If NORM = '1' or 'O', the 1-norm of the original matrix A.\n\ * If NORM = 'I', the infinity-norm of the original matrix A.\n\ *\n\ * RCOND (output) REAL\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(norm(A) * norm(inv(A))).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (2*N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctpcon0000644000175000017500000000545512502223525016506 0ustar uwabamiuwabami--- :name: ctpcon :md5sum: 23dc10d29cb244e7abee807ca79e6757 :category: :subroutine :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - ldap - rcond: :type: real :intent: output - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE CTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTPCON estimates the reciprocal of the condition number of a packed\n\ * triangular matrix A, in either the 1-norm or the infinity-norm.\n\ *\n\ * The norm of A is computed and an estimate is obtained for\n\ * norm(inv(A)), then the reciprocal of the condition number is\n\ * computed as\n\ * RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies whether the 1-norm condition number or the\n\ * infinity-norm condition number is required:\n\ * = '1' or 'O': 1-norm;\n\ * = 'I': Infinity-norm.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input) COMPLEX array, dimension (N*(N+1)/2)\n\ * The upper or lower triangular matrix A, packed columnwise in\n\ * a linear array. The j-th column of A is stored in the array\n\ * AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ * If DIAG = 'U', the diagonal elements of A are not referenced\n\ * and are assumed to be 1.\n\ *\n\ * RCOND (output) REAL\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(norm(A) * norm(inv(A))).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlarzt0000644000175000017500000001230712502223526016541 0ustar uwabamiuwabami--- :name: zlarzt :md5sum: 10bdb46591b0abb303255f8db76e37b7 :category: :subroutine :arguments: - direct: :type: char :intent: input - storev: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - v: :type: doublecomplex :intent: input/output :dims: - ldv - "lsame_(&storev,\"C\") ? k : lsame_(&storev,\"R\") ? n : 0" - ldv: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - t: :type: doublecomplex :intent: output :dims: - ldt - k - ldt: :type: integer :intent: input :substitutions: ldt: k :fortran_help: " SUBROUTINE ZLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLARZT forms the triangular factor T of a complex block reflector\n\ * H of order > n, which is defined as a product of k elementary\n\ * reflectors.\n\ *\n\ * If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n\ *\n\ * If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n\ *\n\ * If STOREV = 'C', the vector which defines the elementary reflector\n\ * H(i) is stored in the i-th column of the array V, and\n\ *\n\ * H = I - V * T * V'\n\ *\n\ * If STOREV = 'R', the vector which defines the elementary reflector\n\ * H(i) is stored in the i-th row of the array V, and\n\ *\n\ * H = I - V' * T * V\n\ *\n\ * Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * DIRECT (input) CHARACTER*1\n\ * Specifies the order in which the elementary reflectors are\n\ * multiplied to form the block reflector:\n\ * = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n\ * = 'B': H = H(k) . . . H(2) H(1) (Backward)\n\ *\n\ * STOREV (input) CHARACTER*1\n\ * Specifies how the vectors which define the elementary\n\ * reflectors are stored (see also Further Details):\n\ * = 'C': columnwise (not supported yet)\n\ * = 'R': rowwise\n\ *\n\ * N (input) INTEGER\n\ * The order of the block reflector H. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The order of the triangular factor T (= the number of\n\ * elementary reflectors). K >= 1.\n\ *\n\ * V (input/output) COMPLEX*16 array, dimension\n\ * (LDV,K) if STOREV = 'C'\n\ * (LDV,N) if STOREV = 'R'\n\ * The matrix V. See further details.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V.\n\ * If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n\ *\n\ * TAU (input) COMPLEX*16 array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i).\n\ *\n\ * T (output) COMPLEX*16 array, dimension (LDT,K)\n\ * The k by k triangular factor T of the block reflector.\n\ * If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n\ * lower triangular. The rest of the array is not used.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= K.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * The shape of the matrix V and the storage of the vectors which define\n\ * the H(i) is best illustrated by the following example with n = 5 and\n\ * k = 3. The elements equal to 1 are not stored; the corresponding\n\ * array elements are modified but restored on exit. The rest of the\n\ * array is not used.\n\ *\n\ * DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':\n\ *\n\ * ______V_____\n\ * ( v1 v2 v3 ) / \\\n\ * ( v1 v2 v3 ) ( v1 v1 v1 v1 v1 . . . . 1 )\n\ * V = ( v1 v2 v3 ) ( v2 v2 v2 v2 v2 . . . 1 )\n\ * ( v1 v2 v3 ) ( v3 v3 v3 v3 v3 . . 1 )\n\ * ( v1 v2 v3 )\n\ * . . .\n\ * . . .\n\ * 1 . .\n\ * 1 .\n\ * 1\n\ *\n\ * DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':\n\ *\n\ * ______V_____\n\ * 1 / \\\n\ * . 1 ( 1 . . . . v1 v1 v1 v1 v1 )\n\ * . . 1 ( . 1 . . . v2 v2 v2 v2 v2 )\n\ * . . . ( . . 1 . . v3 v3 v3 v3 v3 )\n\ * . . .\n\ * ( v1 v2 v3 )\n\ * ( v1 v2 v3 )\n\ * V = ( v1 v2 v3 )\n\ * ( v1 v2 v3 )\n\ * ( v1 v2 v3 )\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zpotrs0000644000175000017500000000421612502223526016554 0ustar uwabamiuwabami--- :name: zpotrs :md5sum: 86f72d1107e046da306dfe0cef88d7fd :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPOTRS solves a system of linear equations A*X = B with a Hermitian\n\ * positive definite matrix A using the Cholesky factorization\n\ * A = U**H*U or A = L*L**H computed by ZPOTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**H*U or A = L*L**H, as computed by ZPOTRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlaed00000644000175000017500000000745512502223526016402 0ustar uwabamiuwabami--- :name: zlaed0 :md5sum: 0fc362ce3bc169eeb9caad18edabb44d :category: :subroutine :arguments: - qsiz: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - q: :type: doublecomplex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - qstore: :type: doublecomplex :intent: workspace :dims: - ldqs - n - ldqs: :type: integer :intent: input - rwork: :type: doublereal :intent: workspace :dims: - 1 + 3*n + 2*n*LG(n) + 3*pow(n,2) - iwork: :type: integer :intent: workspace :dims: - 6 + 6*n + 5*n*LG(n) - info: :type: integer :intent: output :substitutions: ldqs: MAX(1,n) :fortran_help: " SUBROUTINE ZLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Using the divide and conquer method, ZLAED0 computes all eigenvalues\n\ * of a symmetric tridiagonal matrix which is one diagonal block of\n\ * those from reducing a dense or band Hermitian matrix and\n\ * corresponding eigenvectors of the dense or band matrix.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * QSIZ (input) INTEGER\n\ * The dimension of the unitary matrix used to reduce\n\ * the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.\n\ *\n\ * N (input) INTEGER\n\ * The dimension of the symmetric tridiagonal matrix. N >= 0.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the diagonal elements of the tridiagonal matrix.\n\ * On exit, the eigenvalues in ascending order.\n\ *\n\ * E (input/output) DOUBLE PRECISION array, dimension (N-1)\n\ * On entry, the off-diagonal elements of the tridiagonal matrix.\n\ * On exit, E has been destroyed.\n\ *\n\ * Q (input/output) COMPLEX*16 array, dimension (LDQ,N)\n\ * On entry, Q must contain an QSIZ x N matrix whose columns\n\ * unitarily orthonormal. It is a part of the unitary matrix\n\ * that reduces the full dense Hermitian matrix to a\n\ * (reducible) symmetric tridiagonal matrix.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N).\n\ *\n\ * IWORK (workspace) INTEGER array,\n\ * the dimension of IWORK must be at least\n\ * 6 + 6*N + 5*N*lg N\n\ * ( lg( N ) = smallest integer k\n\ * such that 2^k >= N )\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array,\n\ * dimension (1 + 3*N + 2*N*lg N + 3*N**2)\n\ * ( lg( N ) = smallest integer k\n\ * such that 2^k >= N )\n\ *\n\ * QSTORE (workspace) COMPLEX*16 array, dimension (LDQS, N)\n\ * Used to store parts of\n\ * the eigenvector matrix when the updating matrix multiplies\n\ * take place.\n\ *\n\ * LDQS (input) INTEGER\n\ * The leading dimension of the array QSTORE.\n\ * LDQS >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit.\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * > 0: The algorithm failed to compute an eigenvalue while\n\ * working on the submatrix lying in rows and columns\n\ * INFO/(N+1) through mod(INFO,N+1).\n\ *\n\n\ * =====================================================================\n\ *\n\ * Warning: N could be as big as QSIZ!\n\ *\n" ruby-lapack-1.7.2/dev/defs/sla_syrpvgrw0000644000175000017500000000563512502223526017763 0ustar uwabamiuwabami--- :name: sla_syrpvgrw :md5sum: 2520bed9e6244f2db3d5b849f49a59d2 :category: :function :type: real :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - info: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: real :intent: input :dims: - 2*n :substitutions: {} :fortran_help: " REAL FUNCTION SLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, WORK )\n\n\ * Purpose\n\ * =======\n\ * \n\ * SLA_SYRPVGRW computes the reciprocal pivot growth factor\n\ * norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n\ * much less than 1, the stability of the LU factorization of the\n\ * (equilibrated) matrix A could be poor. This also means that the\n\ * solution X, estimated condition numbers, and error bounds could be\n\ * unreliable.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * INFO (input) INTEGER\n\ * The value of INFO returned from SSYTRF, .i.e., the pivot in\n\ * column INFO is exactly 0.\n\ *\n\ * NCOLS (input) INTEGER\n\ * The number of columns of the matrix A. NCOLS >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) REAL array, dimension (LDAF,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by SSYTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by SSYTRF.\n\ *\n\ * WORK (input) REAL array, dimension (2*N)\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER NCOLS, I, J, K, KP\n REAL AMAX, UMAX, RPVGRW, TMP\n LOGICAL UPPER\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN\n\ * ..\n\ * .. External Functions ..\n EXTERNAL LSAME, SLASET\n LOGICAL LSAME\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zlantp0000644000175000017500000000617712502223526016533 0ustar uwabamiuwabami--- :name: zlantp :md5sum: 5643fadc8657c6b20518835ef43210f4 :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? n : 0" :fortran_help: " DOUBLE PRECISION FUNCTION ZLANTP( NORM, UPLO, DIAG, N, AP, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLANTP returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * triangular matrix A, supplied in packed form.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * ZLANTP returns the value\n\ *\n\ * ZLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in ZLANTP as described\n\ * above.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the matrix A is upper or lower triangular.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * Specifies whether or not the matrix A is unit triangular.\n\ * = 'N': Non-unit triangular\n\ * = 'U': Unit triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, ZLANTP is\n\ * set to zero.\n\ *\n\ * AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * The upper or lower triangular matrix A, packed columnwise in\n\ * a linear array. The j-th column of A is stored in the array\n\ * AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ * Note that when DIAG = 'U', the elements of the array AP\n\ * corresponding to the diagonal elements of the matrix A are\n\ * not referenced, but are assumed to be one.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n\ * referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slaed40000644000175000017500000000642112502223526016367 0ustar uwabamiuwabami--- :name: slaed4 :md5sum: d6ca8d8edb3a5f41edc126568787c862 :category: :subroutine :arguments: - n: :type: integer :intent: input - i: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - z: :type: real :intent: input :dims: - n - delta: :type: real :intent: output :dims: - n - rho: :type: real :intent: input - dlam: :type: real :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This subroutine computes the I-th updated eigenvalue of a symmetric\n\ * rank-one modification to a diagonal matrix whose elements are\n\ * given in the array d, and that\n\ *\n\ * D(i) < D(j) for i < j\n\ *\n\ * and that RHO > 0. This is arranged by the calling routine, and is\n\ * no loss in generality. The rank-one modified system is thus\n\ *\n\ * diag( D ) + RHO * Z * Z_transpose.\n\ *\n\ * where we assume the Euclidean norm of Z is 1.\n\ *\n\ * The method consists of approximating the rational functions in the\n\ * secular equation by simpler interpolating rational functions.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The length of all arrays.\n\ *\n\ * I (input) INTEGER\n\ * The index of the eigenvalue to be computed. 1 <= I <= N.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The original eigenvalues. It is assumed that they are in\n\ * order, D(I) < D(J) for I < J.\n\ *\n\ * Z (input) REAL array, dimension (N)\n\ * The components of the updating vector.\n\ *\n\ * DELTA (output) REAL array, dimension (N)\n\ * If N .GT. 2, DELTA contains (D(j) - lambda_I) in its j-th\n\ * component. If N = 1, then DELTA(1) = 1. If N = 2, see SLAED5\n\ * for detail. The vector DELTA contains the information necessary\n\ * to construct the eigenvectors by SLAED3 and SLAED9.\n\ *\n\ * RHO (input) REAL\n\ * The scalar in the symmetric updating formula.\n\ *\n\ * DLAM (output) REAL\n\ * The computed lambda_I, the I-th updated eigenvalue.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * > 0: if INFO = 1, the updating process failed.\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * Logical variable ORGATI (origin-at-i?) is used for distinguishing\n\ * whether D(i) or D(i+1) is treated as the origin.\n\ *\n\ * ORGATI = .true. origin at i\n\ * ORGATI = .false. origin at i+1\n\ *\n\ * Logical variable SWTCH3 (switch-for-3-poles?) is for noting\n\ * if we are working with THREE poles!\n\ *\n\ * MAXIT is the maximum number of iterations allowed for each\n\ * eigenvalue.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ren-Cang Li, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgetri0000644000175000017500000000524012502223526016467 0ustar uwabamiuwabami--- :name: dgetri :md5sum: c484cb60864677da7365b61f53b577c7 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGETRI computes the inverse of a matrix using the LU factorization\n\ * computed by DGETRF.\n\ *\n\ * This method inverts U and then computes inv(A) by solving the system\n\ * inv(A)*L = inv(U) for inv(A).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the factors L and U from the factorization\n\ * A = P*L*U as computed by DGETRF.\n\ * On exit, if INFO = 0, the inverse of the original matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from DGETRF; for 1<=i<=N, row i of the\n\ * matrix was interchanged with row IPIV(i).\n\ *\n\ * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO=0, then WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK >= max(1,N).\n\ * For optimal performance LWORK >= N*NB, where NB is\n\ * the optimal blocksize returned by ILAENV.\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, U(i,i) is exactly zero; the matrix is\n\ * singular and its inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/scsum10000644000175000017500000000250512502223526016425 0ustar uwabamiuwabami--- :name: scsum1 :md5sum: 9056190314a2a56645696ef9574ef9d4 :category: :function :type: real :arguments: - n: :type: integer :intent: input - cx: :type: complex :intent: input :dims: - n - incx: :type: integer :intent: input :substitutions: {} :fortran_help: " REAL FUNCTION SCSUM1( N, CX, INCX )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SCSUM1 takes the sum of the absolute values of a complex\n\ * vector and returns a single precision result.\n\ *\n\ * Based on SCASUM from the Level 1 BLAS.\n\ * The change is to use the 'genuine' absolute value.\n\ *\n\ * Contributed by Nick Higham for use with CLACON.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of elements in the vector CX.\n\ *\n\ * CX (input) COMPLEX array, dimension (N)\n\ * The vector whose elements will be summed.\n\ *\n\ * INCX (input) INTEGER\n\ * The spacing between successive values of CX. INCX > 0.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, NINCX\n REAL STEMP\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cunmtr0000644000175000017500000001165512502223526016530 0ustar uwabamiuwabami--- :name: cunmtr :md5sum: 11d3fb40772ec5f0829d5a084bbba746 :category: :subroutine :arguments: - side: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - m-1 - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CUNMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CUNMTR overwrites the general complex M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'C': Q**H * C C * Q**H\n\ *\n\ * where Q is a complex unitary matrix of order nq, with nq = m if\n\ * SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of\n\ * nq-1 elementary reflectors, as returned by CHETRD:\n\ *\n\ * if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);\n\ *\n\ * if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**H from the Left;\n\ * = 'R': apply Q or Q**H from the Right.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A contains elementary reflectors\n\ * from CHETRD;\n\ * = 'L': Lower triangle of A contains elementary reflectors\n\ * from CHETRD.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q;\n\ * = 'C': Conjugate transpose, apply Q**H.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension\n\ * (LDA,M) if SIDE = 'L'\n\ * (LDA,N) if SIDE = 'R'\n\ * The vectors which define the elementary reflectors, as\n\ * returned by CHETRD.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ * LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n\ *\n\ * TAU (input) COMPLEX array, dimension\n\ * (M-1) if SIDE = 'L'\n\ * (N-1) if SIDE = 'R'\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by CHETRD.\n\ *\n\ * C (input/output) COMPLEX array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace/output) COMPLEX 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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M).\n\ * For optimum performance LWORK >= N*NB if SIDE = 'L', and\n\ * LWORK >=M*NB if SIDE = 'R', where NB is the optimal\n\ * 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\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LEFT, LQUERY, UPPER\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL ILAENV, LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CUNMQL, CUNMQR, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dla_gerfsx_extended0000644000175000017500000003556112502223526021220 0ustar uwabamiuwabami--- :name: dla_gerfsx_extended :md5sum: 3d7ad12043072b489bb0902dafc971c6 :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - trans_type: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - colequ: :type: logical :intent: input - c: :type: doublereal :intent: input :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: doublereal :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: doublereal :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - errs_n: :type: doublereal :intent: input/output :dims: - nrhs - n_norms - errs_c: :type: doublereal :intent: input/output :dims: - nrhs - n_norms - res: :type: doublereal :intent: input :dims: - n - ayb: :type: doublereal :intent: input :dims: - n - dy: :type: doublereal :intent: input :dims: - n - y_tail: :type: doublereal :intent: input :dims: - n - rcond: :type: doublereal :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: doublereal :intent: input - dz_ub: :type: doublereal :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: n_norms: "3" :fortran_help: " SUBROUTINE DLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERRS_N, ERRS_C, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n\ * Purpose\n\ * =======\n\ * \n\ * DLA_GERFSX_EXTENDED improves the computed solution to a system of\n\ * linear equations by performing extra-precise iterative refinement\n\ * and provides error bounds and backward error estimates for the solution.\n\ * This subroutine is called by DGERFSX to perform iterative refinement.\n\ * In addition to normwise error bound, the code provides maximum\n\ * componentwise error bound if possible. See comments for ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP for details of the error bounds. Note that this\n\ * subroutine is only resonsible for setting the second fields of\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * PREC_TYPE (input) INTEGER\n\ * Specifies the intermediate precision to be used in refinement.\n\ * The value is defined by ILAPREC(P) where P is a CHARACTER and\n\ * P = 'S': Single\n\ * = 'D': Double\n\ * = 'I': Indigenous\n\ * = 'X', 'E': Extra\n\ *\n\ * TRANS_TYPE (input) INTEGER\n\ * Specifies the transposition operation on A.\n\ * The value is defined by ILATRANS(T) where T is a CHARACTER and\n\ * T = 'N': No transpose\n\ * = 'T': Transpose\n\ * = 'C': Conjugate transpose\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right-hand-sides, i.e., the number of columns of the\n\ * matrix B.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n\ * The factors L and U from the factorization\n\ * A = P*L*U as computed by DGETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from the factorization A = P*L*U\n\ * as computed by DGETRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * COLEQU (input) LOGICAL\n\ * If .TRUE. then column equilibration was done to A before calling\n\ * this routine. This is needed to compute the solution and error\n\ * bounds correctly.\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension (N)\n\ * The column scale factors for A. If COLEQU = .FALSE., C\n\ * is not accessed. If C is input, each element of C should be a power\n\ * of the radix to ensure a reliable solution and error estimates.\n\ * Scaling by powers of the radix does not cause rounding errors unless\n\ * the result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * The right-hand-side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * Y (input/output) DOUBLE PRECISION array, dimension\n\ * (LDY,NRHS)\n\ * On entry, the solution matrix X, as computed by DGETRS.\n\ * On exit, the improved solution matrix Y.\n\ *\n\ * LDY (input) INTEGER\n\ * The leading dimension of the array Y. LDY >= max(1,N).\n\ *\n\ * BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * On exit, BERR_OUT(j) contains the componentwise relative backward\n\ * error for right-hand-side j from the formula\n\ * max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n\ * where abs(Z) is the componentwise absolute value of the matrix\n\ * or vector Z. This is computed by DLA_LIN_BERR.\n\ *\n\ * N_NORMS (input) INTEGER\n\ * Determines which error bounds to return (see ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP).\n\ * If N_NORMS >= 1 return normwise error bounds.\n\ * If N_NORMS >= 2 return componentwise error bounds.\n\ *\n\ * ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension\n\ * (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension\n\ * (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * RES (input) DOUBLE PRECISION array, dimension (N)\n\ * Workspace to hold the intermediate residual.\n\ *\n\ * AYB (input) DOUBLE PRECISION array, dimension (N)\n\ * Workspace. This can be the same workspace passed for Y_TAIL.\n\ *\n\ * DY (input) DOUBLE PRECISION array, dimension (N)\n\ * Workspace to hold the intermediate solution.\n\ *\n\ * Y_TAIL (input) DOUBLE PRECISION array, dimension (N)\n\ * Workspace to hold the trailing bits of the intermediate solution.\n\ *\n\ * RCOND (input) DOUBLE PRECISION\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * ITHRESH (input) INTEGER\n\ * The maximum number of residual computations allowed for\n\ * refinement. The default is 10. For 'aggressive' set to 100 to\n\ * permit convergence using approximate factorizations or\n\ * factorizations other than LU. If the factorization uses a\n\ * technique other than Gaussian elimination, the guarantees in\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n\ *\n\ * RTHRESH (input) DOUBLE PRECISION\n\ * Determines when to stop refinement if the error estimate stops\n\ * decreasing. Refinement will stop when the next solution no longer\n\ * satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n\ * the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n\ * default value is 0.5. For 'aggressive' set to 0.9 to permit\n\ * convergence on extremely ill-conditioned matrices. See LAWN 165\n\ * for more details.\n\ *\n\ * DZ_UB (input) DOUBLE PRECISION\n\ * Determines when to start considering componentwise convergence.\n\ * Componentwise convergence is only considered after each component\n\ * of the solution Y is stable, which we definte as the relative\n\ * change in each component being less than DZ_UB. The default value\n\ * is 0.25, requiring the first bit to be stable. See LAWN 165 for\n\ * more details.\n\ *\n\ * IGNORE_CWISE (input) LOGICAL\n\ * If .TRUE. then ignore componentwise convergence. Default value\n\ * is .FALSE..\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * < 0: if INFO = -i, the ith argument to DGETRS had an illegal\n\ * value\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n CHARACTER TRANS\n INTEGER CNT, I, J, X_STATE, Z_STATE, Y_PREC_STATE\n DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zheequb0000644000175000017500000000522112502223526016653 0ustar uwabamiuwabami--- :name: zheequb :md5sum: 7b6794b81f1747a915e16b94b240d5e3 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - n - scond: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZHEEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSYEQUB computes row and column scalings intended to equilibrate a\n\ * symmetric matrix A and reduce its condition number\n\ * (with respect to the two-norm). S contains the scale factors,\n\ * S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n\ * elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n\ * choice of S puts the condition number of B within a factor N of the\n\ * smallest possible condition number over all possible diagonal\n\ * scalings.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The N-by-N symmetric matrix whose scaling\n\ * factors are to be computed. Only the diagonal elements of A\n\ * are referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * S (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, S contains the scale factors for A.\n\ *\n\ * SCOND (output) DOUBLE PRECISION\n\ * If INFO = 0, S contains the ratio of the smallest S(i) to\n\ * the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n\ * large nor too small, it is not worth scaling by S.\n\ *\n\ * AMAX (output) DOUBLE PRECISION\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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 is nonpositive.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zpprfs0000644000175000017500000001102112502223526016527 0ustar uwabamiuwabami--- :name: zpprfs :md5sum: addabb06f1320fc4046bab06d84f0935 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - afp: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ldb :fortran_help: " SUBROUTINE ZPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPPRFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is Hermitian positive definite\n\ * and packed, and provides error bounds and backward error estimates\n\ * for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * The upper or lower triangle of the Hermitian matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * AFP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**H*U or A = L*L**H, as computed by DPPTRF/ZPPTRF,\n\ * packed columnwise in a linear array in the same format as A\n\ * (see AP).\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by ZPPTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * ====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/izmax10000644000175000017500000000307512502223526016426 0ustar uwabamiuwabami--- :name: izmax1 :md5sum: 9594df1850d6464cd15f4e4b7161a5fa :category: :function :type: integer :arguments: - n: :type: integer :intent: input - cx: :type: doublecomplex :intent: input :dims: - n - incx: :type: integer :intent: input :substitutions: {} :fortran_help: " INTEGER FUNCTION IZMAX1( N, CX, INCX )\n\n\ * Purpose\n\ * =======\n\ *\n\ * IZMAX1 finds the index of the element whose real part has maximum\n\ * absolute value.\n\ *\n\ * Based on IZAMAX from Level 1 BLAS.\n\ * The change is to use the 'genuine' absolute value.\n\ *\n\ * Contributed by Nick Higham for use with ZLACON.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of elements in the vector CX.\n\ *\n\ * CX (input) COMPLEX*16 array, dimension (N)\n\ * The vector whose elements will be summed.\n\ *\n\ * INCX (input) INTEGER\n\ * The spacing between successive values of CX. INCX >= 1.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, IX\n DOUBLE PRECISION SMAX\n COMPLEX*16 ZDUM\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS\n\ * ..\n\ * .. Statement Functions ..\n DOUBLE PRECISION CABS1\n\ * ..\n\ * .. Statement Function definitions ..\n\ *\n\ * NEXT LINE IS THE ONLY MODIFICATION.\n CABS1( ZDUM ) = ABS( ZDUM )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dpbtrs0000644000175000017500000000612612502223526016513 0ustar uwabamiuwabami--- :name: dpbtrs :md5sum: a666157203f207f22114152a99a262ce :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPBTRS solves a system of linear equations A*X = B with a symmetric\n\ * positive definite band matrix A using the Cholesky factorization\n\ * A = U**T*U or A = L*L**T computed by DPBTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangular factor stored in AB;\n\ * = 'L': Lower triangular factor stored in AB.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T of the band matrix A, stored in the\n\ * first KD+1 rows of the array. The j-th column of U or L is\n\ * stored in the j-th column of the array AB as follows:\n\ * if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL UPPER\n INTEGER J\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DTBSV, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlasr0000644000175000017500000001407112502223526016320 0ustar uwabamiuwabami--- :name: dlasr :md5sum: b4a6611d98b6eae9b7f7b00cae25a5e9 :category: :subroutine :arguments: - side: :type: char :intent: input - pivot: :type: char :intent: input - direct: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - c: :type: doublereal :intent: input :dims: - m-1 - s: :type: doublereal :intent: input :dims: - m-1 - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLASR applies a sequence of plane rotations to a real matrix A,\n\ * from either the left or the right.\n\ * \n\ * When SIDE = 'L', the transformation takes the form\n\ * \n\ * A := P*A\n\ * \n\ * and when SIDE = 'R', the transformation takes the form\n\ * \n\ * A := A*P**T\n\ * \n\ * where P is an orthogonal matrix consisting of a sequence of z plane\n\ * rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',\n\ * and P**T is the transpose of P.\n\ * \n\ * When DIRECT = 'F' (Forward sequence), then\n\ * \n\ * P = P(z-1) * ... * P(2) * P(1)\n\ * \n\ * and when DIRECT = 'B' (Backward sequence), then\n\ * \n\ * P = P(1) * P(2) * ... * P(z-1)\n\ * \n\ * where P(k) is a plane rotation matrix defined by the 2-by-2 rotation\n\ * \n\ * R(k) = ( c(k) s(k) )\n\ * = ( -s(k) c(k) ).\n\ * \n\ * When PIVOT = 'V' (Variable pivot), the rotation is performed\n\ * for the plane (k,k+1), i.e., P(k) has the form\n\ * \n\ * P(k) = ( 1 )\n\ * ( ... )\n\ * ( 1 )\n\ * ( c(k) s(k) )\n\ * ( -s(k) c(k) )\n\ * ( 1 )\n\ * ( ... )\n\ * ( 1 )\n\ * \n\ * where R(k) appears as a rank-2 modification to the identity matrix in\n\ * rows and columns k and k+1.\n\ * \n\ * When PIVOT = 'T' (Top pivot), the rotation is performed for the\n\ * plane (1,k+1), so P(k) has the form\n\ * \n\ * P(k) = ( c(k) s(k) )\n\ * ( 1 )\n\ * ( ... )\n\ * ( 1 )\n\ * ( -s(k) c(k) )\n\ * ( 1 )\n\ * ( ... )\n\ * ( 1 )\n\ * \n\ * where R(k) appears in rows and columns 1 and k+1.\n\ * \n\ * Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is\n\ * performed for the plane (k,z), giving P(k) the form\n\ * \n\ * P(k) = ( 1 )\n\ * ( ... )\n\ * ( 1 )\n\ * ( c(k) s(k) )\n\ * ( 1 )\n\ * ( ... )\n\ * ( 1 )\n\ * ( -s(k) c(k) )\n\ * \n\ * where R(k) appears in rows and columns k and z. The rotations are\n\ * performed without ever forming P(k) explicitly.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * Specifies whether the plane rotation matrix P is applied to\n\ * A on the left or the right.\n\ * = 'L': Left, compute A := P*A\n\ * = 'R': Right, compute A:= A*P**T\n\ *\n\ * PIVOT (input) CHARACTER*1\n\ * Specifies the plane for which P(k) is a plane rotation\n\ * matrix.\n\ * = 'V': Variable pivot, the plane (k,k+1)\n\ * = 'T': Top pivot, the plane (1,k+1)\n\ * = 'B': Bottom pivot, the plane (k,z)\n\ *\n\ * DIRECT (input) CHARACTER*1\n\ * Specifies whether P is a forward or backward sequence of\n\ * plane rotations.\n\ * = 'F': Forward, P = P(z-1)*...*P(2)*P(1)\n\ * = 'B': Backward, P = P(1)*P(2)*...*P(z-1)\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A. If m <= 1, an immediate\n\ * return is effected.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix A. If n <= 1, an\n\ * immediate return is effected.\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension\n\ * (M-1) if SIDE = 'L'\n\ * (N-1) if SIDE = 'R'\n\ * The cosines c(k) of the plane rotations.\n\ *\n\ * S (input) DOUBLE PRECISION array, dimension\n\ * (M-1) if SIDE = 'L'\n\ * (N-1) if SIDE = 'R'\n\ * The sines s(k) of the plane rotations. The 2-by-2 plane\n\ * rotation part of the matrix P(k), R(k), has the form\n\ * R(k) = ( c(k) s(k) )\n\ * ( -s(k) c(k) ).\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The M-by-N matrix A. On exit, A is overwritten by P*A if\n\ * SIDE = 'R' or by A*P**T if SIDE = 'L'.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ztfttr0000644000175000017500000001473212502223526016554 0ustar uwabamiuwabami--- :name: ztfttr :md5sum: 19f4fd1962dcfce8cdbea1c9e2eff0ab :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - arf: :type: doublecomplex :intent: input :dims: - ldarf - a: :type: doublecomplex :intent: output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: lda: MAX(1,n) n: ((int)sqrtf(8*ldarf+1.0f)-1)/2 :fortran_help: " SUBROUTINE ZTFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTFTTR copies a triangular matrix A from rectangular full packed\n\ * format (TF) to standard full format (TR).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': ARF is in Normal format;\n\ * = 'C': ARF is in Conjugate-transpose format;\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * ARF (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n\ * On entry, the upper or lower triangular matrix A stored in\n\ * RFP format. For a further discussion see Notes below.\n\ *\n\ * A (output) COMPLEX*16 array, dimension ( LDA, N ) \n\ * On exit, the triangular matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of the array A contains\n\ * the upper triangular matrix, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of the array A contains\n\ * the lower triangular matrix, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\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\ * We first consider Standard Packed Format when N is even.\n\ * We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * conjugate-transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * conjugate-transpose of the last three columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- --\n\ * 03 04 05 33 43 53\n\ * -- --\n\ * 13 14 15 00 44 54\n\ * --\n\ * 23 24 25 10 11 55\n\ *\n\ * 33 34 35 20 21 22\n\ * --\n\ * 00 44 45 30 31 32\n\ * -- --\n\ * 01 11 55 40 41 42\n\ * -- -- --\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We next consider Standard Packed Format when N is odd.\n\ * We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * conjugate-transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * conjugate-transpose of the last two columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- --\n\ * 02 03 04 00 33 43\n\ * --\n\ * 12 13 14 10 11 44\n\ *\n\ * 22 23 24 20 21 22\n\ * --\n\ * 00 33 34 30 31 32\n\ * -- --\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- --\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlarrj0000644000175000017500000001011712502223526016466 0ustar uwabamiuwabami--- :name: dlarrj :md5sum: 2a08a838ca5660f3b1cf1b9237f3741e :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e2: :type: doublereal :intent: input :dims: - n-1 - ifirst: :type: integer :intent: input - ilast: :type: integer :intent: input - rtol: :type: doublereal :intent: input - offset: :type: integer :intent: input - w: :type: doublereal :intent: input/output :dims: - n - werr: :type: doublereal :intent: input/output :dims: - n - work: :type: doublereal :intent: workspace :dims: - 2*n - iwork: :type: integer :intent: workspace :dims: - 2*n - pivmin: :type: doublereal :intent: input - spdiam: :type: doublereal :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLARRJ( N, D, E2, IFIRST, ILAST, RTOL, OFFSET, W, WERR, WORK, IWORK, PIVMIN, SPDIAM, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Given the initial eigenvalue approximations of T, DLARRJ\n\ * does bisection to refine the eigenvalues of T,\n\ * W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial\n\ * guesses for these eigenvalues are input in W, the corresponding estimate\n\ * of the error in these guesses in WERR. During bisection, intervals\n\ * [left, right] are maintained by storing their mid-points and\n\ * semi-widths in the arrays W and WERR respectively.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The N diagonal elements of T.\n\ *\n\ * E2 (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The Squares of the (N-1) subdiagonal elements of T.\n\ *\n\ * IFIRST (input) INTEGER\n\ * The index of the first eigenvalue to be computed.\n\ *\n\ * ILAST (input) INTEGER\n\ * The index of the last eigenvalue to be computed.\n\ *\n\ * RTOL (input) DOUBLE PRECISION\n\ * Tolerance for the convergence of the bisection intervals.\n\ * An interval [LEFT,RIGHT] has converged if\n\ * RIGHT-LEFT.LT.RTOL*MAX(|LEFT|,|RIGHT|).\n\ *\n\ * OFFSET (input) INTEGER\n\ * Offset for the arrays W and WERR, i.e., the IFIRST-OFFSET\n\ * through ILAST-OFFSET elements of these arrays are to be used.\n\ *\n\ * W (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are\n\ * estimates of the eigenvalues of L D L^T indexed IFIRST through\n\ * ILAST.\n\ * On output, these estimates are refined.\n\ *\n\ * WERR (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are\n\ * the errors in the estimates of the corresponding elements in W.\n\ * On output, these errors are refined.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n\ * Workspace.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (2*N)\n\ * Workspace.\n\ *\n\ * PIVMIN (input) DOUBLE PRECISION\n\ * The minimum pivot in the Sturm sequence for T.\n\ *\n\ * SPDIAM (input) DOUBLE PRECISION\n\ * The spectral diameter of T.\n\ *\n\ * INFO (output) INTEGER\n\ * Error flag.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Beresford Parlett, University of California, Berkeley, USA\n\ * Jim Demmel, University of California, Berkeley, USA\n\ * Inderjit Dhillon, University of Texas, Austin, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, University of California, Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/drscl0000644000175000017500000000262512502223526016324 0ustar uwabamiuwabami--- :name: drscl :md5sum: f5c221f426610c222a5048da51a491d9 :category: :subroutine :arguments: - n: :type: integer :intent: input - sa: :type: doublereal :intent: input - sx: :type: doublereal :intent: input/output :dims: - 1+(n-1)*abs(incx) - incx: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE DRSCL( N, SA, SX, INCX )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DRSCL multiplies an n-element real vector x by the real scalar 1/a.\n\ * This is done without overflow or underflow as long as\n\ * the final result x/a does not overflow or underflow.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of components of the vector x.\n\ *\n\ * SA (input) DOUBLE PRECISION\n\ * The scalar a which is used to divide each component of x.\n\ * SA must be >= 0, or the subroutine will divide by zero.\n\ *\n\ * SX (input/output) DOUBLE PRECISION array, dimension\n\ * (1+(N-1)*abs(INCX))\n\ * The n-element vector x.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between successive values of the vector SX.\n\ * > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgges0000644000175000017500000002314612502223526016326 0ustar uwabamiuwabami--- :name: sgges :md5sum: c82764a1dfe0f3e66ab308ca3336562a :category: :subroutine :arguments: - jobvsl: :type: char :intent: input - jobvsr: :type: char :intent: input - sort: :type: char :intent: input - selctg: :intent: external procedure :block_type: logical :block_arg_num: 3 :block_arg_type: real - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - sdim: :type: integer :intent: output - alphar: :type: real :intent: output :dims: - n - alphai: :type: real :intent: output :dims: - n - beta: :type: real :intent: output :dims: - n - vsl: :type: real :intent: output :dims: - ldvsl - n - ldvsl: :type: integer :intent: input - vsr: :type: real :intent: output :dims: - ldvsr - n - ldvsr: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(8*n,6*n+16) - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvsl: "lsame_(&jobvsl,\"V\") ? n : 1" ldvsr: "lsame_(&jobvsr,\"V\") ? n : 1" :fortran_help: " SUBROUTINE SGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, BWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGGES computes for a pair of N-by-N real nonsymmetric matrices (A,B),\n\ * the generalized eigenvalues, the generalized real Schur form (S,T),\n\ * optionally, the left and/or right matrices of Schur vectors (VSL and\n\ * VSR). This gives the generalized Schur factorization\n\ *\n\ * (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T )\n\ *\n\ * Optionally, it also orders the eigenvalues so that a selected cluster\n\ * of eigenvalues appears in the leading diagonal blocks of the upper\n\ * quasi-triangular matrix S and the upper triangular matrix T.The\n\ * leading columns of VSL and VSR then form an orthonormal basis for the\n\ * corresponding left and right eigenspaces (deflating subspaces).\n\ *\n\ * (If only the generalized eigenvalues are needed, use the driver\n\ * SGGEV instead, which is faster.)\n\ *\n\ * A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n\ * or a ratio alpha/beta = w, such that A - w*B is singular. It is\n\ * usually represented as the pair (alpha,beta), as there is a\n\ * reasonable interpretation for beta=0 or both being zero.\n\ *\n\ * A pair of matrices (S,T) is in generalized real Schur form if T is\n\ * upper triangular with non-negative diagonal and S is block upper\n\ * triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond\n\ * to real generalized eigenvalues, while 2-by-2 blocks of S will be\n\ * \"standardized\" by making the corresponding elements of T have the\n\ * form:\n\ * [ a 0 ]\n\ * [ 0 b ]\n\ *\n\ * and the pair of corresponding 2-by-2 blocks in S and T will have a\n\ * complex conjugate pair of generalized eigenvalues.\n\ *\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVSL (input) CHARACTER*1\n\ * = 'N': do not compute the left Schur vectors;\n\ * = 'V': compute the left Schur vectors.\n\ *\n\ * JOBVSR (input) CHARACTER*1\n\ * = 'N': do not compute the right Schur vectors;\n\ * = 'V': compute the right Schur vectors.\n\ *\n\ * SORT (input) CHARACTER*1\n\ * Specifies whether or not to order the eigenvalues on the\n\ * diagonal of the generalized Schur form.\n\ * = 'N': Eigenvalues are not ordered;\n\ * = 'S': Eigenvalues are ordered (see SELCTG);\n\ *\n\ * SELCTG (external procedure) LOGICAL FUNCTION of three REAL arguments\n\ * SELCTG must be declared EXTERNAL in the calling subroutine.\n\ * If SORT = 'N', SELCTG is not referenced.\n\ * If SORT = 'S', SELCTG is used to select eigenvalues to sort\n\ * to the top left of the Schur form.\n\ * An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if\n\ * SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either\n\ * one of a complex conjugate pair of eigenvalues is selected,\n\ * then both complex eigenvalues are selected.\n\ *\n\ * Note that in the ill-conditioned case, a selected complex\n\ * eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j),\n\ * BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2\n\ * in this case.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A, B, VSL, and VSR. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA, N)\n\ * On entry, the first of the pair of matrices.\n\ * On exit, A has been overwritten by its generalized Schur\n\ * form S.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of A. LDA >= max(1,N).\n\ *\n\ * B (input/output) REAL array, dimension (LDB, N)\n\ * On entry, the second of the pair of matrices.\n\ * On exit, B has been overwritten by its generalized Schur\n\ * form T.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B. LDB >= max(1,N).\n\ *\n\ * SDIM (output) INTEGER\n\ * If SORT = 'N', SDIM = 0.\n\ * If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n\ * for which SELCTG is true. (Complex conjugate pairs for which\n\ * SELCTG is true for either eigenvalue count as 2.)\n\ *\n\ * ALPHAR (output) REAL array, dimension (N)\n\ * ALPHAI (output) REAL array, dimension (N)\n\ * BETA (output) REAL array, dimension (N)\n\ * On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n\ * be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i,\n\ * and BETA(j),j=1,...,N are the diagonals of the complex Schur\n\ * form (S,T) that would result if the 2-by-2 diagonal blocks of\n\ * the real Schur form of (A,B) were further reduced to\n\ * triangular form using 2-by-2 complex unitary transformations.\n\ * If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n\ * positive, then the j-th and (j+1)-st eigenvalues are a\n\ * complex conjugate pair, with ALPHAI(j+1) negative.\n\ *\n\ * Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n\ * may easily over- or underflow, and BETA(j) may even be zero.\n\ * Thus, the user should avoid naively computing the ratio.\n\ * However, ALPHAR and ALPHAI will be always less than and\n\ * usually comparable with norm(A) in magnitude, and BETA always\n\ * less than and usually comparable with norm(B).\n\ *\n\ * VSL (output) REAL array, dimension (LDVSL,N)\n\ * If JOBVSL = 'V', VSL will contain the left Schur vectors.\n\ * Not referenced if JOBVSL = 'N'.\n\ *\n\ * LDVSL (input) INTEGER\n\ * The leading dimension of the matrix VSL. LDVSL >=1, and\n\ * if JOBVSL = 'V', LDVSL >= N.\n\ *\n\ * VSR (output) REAL array, dimension (LDVSR,N)\n\ * If JOBVSR = 'V', VSR will contain the right Schur vectors.\n\ * Not referenced if JOBVSR = 'N'.\n\ *\n\ * LDVSR (input) INTEGER\n\ * The leading dimension of the matrix VSR. LDVSR >= 1, and\n\ * if JOBVSR = 'V', LDVSR >= N.\n\ *\n\ * WORK (workspace/output) REAL 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\ * If N = 0, LWORK >= 1, else LWORK >= max(8*N,6*N+16).\n\ * For good performance , LWORK must generally be larger.\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\ * BWORK (workspace) LOGICAL array, dimension (N)\n\ * Not referenced if SORT = 'N'.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * = 1,...,N:\n\ * The QZ iteration failed. (A,B) are not in Schur\n\ * form, but ALPHAR(j), ALPHAI(j), and BETA(j) should\n\ * be correct for j=INFO+1,...,N.\n\ * > N: =N+1: other than QZ iteration failed in SHGEQZ.\n\ * =N+2: after reordering, roundoff changed values of\n\ * some complex eigenvalues so that leading\n\ * eigenvalues in the Generalized Schur form no\n\ * longer satisfy SELCTG=.TRUE. This could also\n\ * be caused due to scaling.\n\ * =N+3: reordering failed in STGSEN.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zla_gercond_x0000644000175000017500000000707112502223526020033 0ustar uwabamiuwabami--- :name: zla_gercond_x :md5sum: 1e10515b8db3cc06a4a3a28106b51f3f :category: :function :type: doublereal :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - x: :type: doublecomplex :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: doublecomplex :intent: input :dims: - 2*n - rwork: :type: doublereal :intent: input :dims: - n :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION ZLA_GERCOND_X( TRANS, N, A, LDA, AF, LDAF, IPIV, X, INFO, WORK, RWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLA_GERCOND_X computes the infinity norm condition number of\n\ * op(A) * diag(X) where X is a COMPLEX*16 vector.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate Transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX*16 array, dimension (LDAF,N)\n\ * The factors L and U from the factorization\n\ * A = P*L*U as computed by ZGETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from the factorization A = P*L*U\n\ * as computed by ZGETRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * X (input) COMPLEX*16 array, dimension (N)\n\ * The vector X in the formula op(A) * diag(X).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * i > 0: The ith argument is invalid.\n\ *\n\ * WORK (input) COMPLEX*16 array, dimension (2*N).\n\ * Workspace.\n\ *\n\ * RWORK (input) DOUBLE PRECISION array, dimension (N).\n\ * Workspace.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE\n DOUBLE PRECISION AINVNM, ANORM, TMP\n INTEGER I, J\n COMPLEX*16 ZDUM\n\ * ..\n\ * .. Local Arrays ..\n INTEGER ISAVE( 3 )\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL ZLACN2, ZGETRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, REAL, DIMAG\n\ * ..\n\ * .. Statement Functions ..\n DOUBLE PRECISION CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/spptrs0000644000175000017500000000515612502223526016552 0ustar uwabamiuwabami--- :name: spptrs :md5sum: 87799d8280769b5abe7f899985cf3927 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: real :intent: input :dims: - n*(n+1)/2 - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPPTRS solves a system of linear equations A*X = B with a symmetric\n\ * positive definite matrix A in packed storage using the Cholesky\n\ * factorization A = U**T*U or A = L*L**T computed by SPPTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AP (input) REAL array, dimension (N*(N+1)/2)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T, packed columnwise in a linear\n\ * array. The j-th column of U or L is stored in the array AP\n\ * as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL UPPER\n INTEGER I\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL STPSV, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/chbev0000644000175000017500000000755612502223525016313 0ustar uwabamiuwabami--- :name: chbev :md5sum: 1cdc22adcd288b6f426c659c21190424 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - n - rwork: :type: real :intent: workspace :dims: - MAX(1,3*n-2) - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" :fortran_help: " SUBROUTINE CHBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHBEV computes all the eigenvalues and, optionally, eigenvectors of\n\ * a complex Hermitian band matrix A.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) COMPLEX array, dimension (LDAB, N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * On exit, AB is overwritten by values generated during the\n\ * reduction to tridiagonal form. If UPLO = 'U', the first\n\ * superdiagonal and the diagonal of the tridiagonal matrix T\n\ * are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n\ * the diagonal and first subdiagonal of T are returned in the\n\ * first two rows of AB.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD + 1.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) COMPLEX array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n\ * eigenvectors of the matrix A, with the i-th column of Z\n\ * holding the eigenvector associated with W(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (max(1,3*N-2))\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 algorithm failed to converge; i\n\ * off-diagonal elements of an intermediate tridiagonal\n\ * form did not converge to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cspmv0000644000175000017500000000775512502223525016355 0ustar uwabamiuwabami--- :name: cspmv :md5sum: 247e190a3b417303369ffe78ead9f23c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - alpha: :type: complex :intent: input - ap: :type: complex :intent: input :dims: - ldap - x: :type: complex :intent: input :dims: - 1 + (n-1)*abs(incx) - incx: :type: integer :intent: input - beta: :type: complex :intent: input - y: :type: complex :intent: input/output :dims: - 1 + (n-1)*abs(incy) - incy: :type: integer :intent: input :substitutions: n: ((integer)sqrtf(8*ldap+1.0f)-1)/2 :extras: ldap: integer :fortran_help: " SUBROUTINE CSPMV( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSPMV performs the matrix-vector operation\n\ *\n\ * y := alpha*A*x + beta*y,\n\ *\n\ * where alpha and beta are scalars, x and y are n element vectors and\n\ * A is an n by n symmetric matrix, supplied in packed form.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * On entry, UPLO specifies whether the upper or lower\n\ * triangular part of the matrix A is supplied in the packed\n\ * array AP as follows:\n\ *\n\ * UPLO = 'U' or 'u' The upper triangular part of A is\n\ * supplied in AP.\n\ *\n\ * UPLO = 'L' or 'l' The lower triangular part of A is\n\ * supplied in AP.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the order of the matrix A.\n\ * N must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * ALPHA (input) COMPLEX\n\ * On entry, ALPHA specifies the scalar alpha.\n\ * Unchanged on exit.\n\ *\n\ * AP (input) COMPLEX array, dimension at least\n\ * ( ( N*( N + 1 ) )/2 ).\n\ * Before entry, with UPLO = 'U' or 'u', the array AP must\n\ * contain the upper triangular part of the symmetric matrix\n\ * packed sequentially, column by column, so that AP( 1 )\n\ * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )\n\ * and a( 2, 2 ) respectively, and so on.\n\ * Before entry, with UPLO = 'L' or 'l', the array AP must\n\ * contain the lower triangular part of the symmetric matrix\n\ * packed sequentially, column by column, so that AP( 1 )\n\ * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )\n\ * and a( 3, 1 ) respectively, and so on.\n\ * Unchanged on exit.\n\ *\n\ * X (input) COMPLEX array, dimension at least\n\ * ( 1 + ( N - 1 )*abs( INCX ) ).\n\ * Before entry, the incremented array X must contain the N-\n\ * element vector x.\n\ * Unchanged on exit.\n\ *\n\ * INCX (input) INTEGER\n\ * On entry, INCX specifies the increment for the elements of\n\ * X. INCX must not be zero.\n\ * Unchanged on exit.\n\ *\n\ * BETA (input) COMPLEX\n\ * On entry, BETA specifies the scalar beta. When BETA is\n\ * supplied as zero then Y need not be set on input.\n\ * Unchanged on exit.\n\ *\n\ * Y (input/output) COMPLEX array, dimension at least \n\ * ( 1 + ( N - 1 )*abs( INCY ) ).\n\ * Before entry, the incremented array Y must contain the n\n\ * element vector y. On exit, Y is overwritten by the updated\n\ * vector y.\n\ *\n\ * INCY (input) INTEGER\n\ * On entry, INCY specifies the increment for the elements of\n\ * Y. INCY must not be zero.\n\ * Unchanged on exit.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dstein0000644000175000017500000001135712502223526016505 0ustar uwabamiuwabami--- :name: dstein :md5sum: 632e25e87ef78ec30feecb369f890ec1 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublereal :intent: input :dims: - n-1 - m: :type: integer :intent: input - w: :type: doublereal :intent: input :dims: - n - iblock: :type: integer :intent: input :dims: - n - isplit: :type: integer :intent: input :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - m - ldz: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 5*n - iwork: :type: integer :intent: workspace :dims: - n - ifail: :type: integer :intent: output :dims: - m - info: :type: integer :intent: output :substitutions: ldz: MAX(1,n) m: n :fortran_help: " SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSTEIN computes the eigenvectors of a real symmetric tridiagonal\n\ * matrix T corresponding to specified eigenvalues, using inverse\n\ * iteration.\n\ *\n\ * The maximum number of iterations allowed for each eigenvector is\n\ * specified by an internal parameter MAXITS (currently set to 5).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The n diagonal elements of the tridiagonal matrix T.\n\ *\n\ * E (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) subdiagonal elements of the tridiagonal matrix\n\ * T, in elements 1 to N-1.\n\ *\n\ * M (input) INTEGER\n\ * The number of eigenvectors to be found. 0 <= M <= N.\n\ *\n\ * W (input) DOUBLE PRECISION array, dimension (N)\n\ * The first M elements of W contain the eigenvalues for\n\ * which eigenvectors are to be computed. The eigenvalues\n\ * should be grouped by split-off block and ordered from\n\ * smallest to largest within the block. ( The output array\n\ * W from DSTEBZ with ORDER = 'B' is expected here. )\n\ *\n\ * IBLOCK (input) INTEGER array, dimension (N)\n\ * The submatrix indices associated with the corresponding\n\ * eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to\n\ * the first submatrix from the top, =2 if W(i) belongs to\n\ * the second submatrix, etc. ( The output array IBLOCK\n\ * from DSTEBZ is expected here. )\n\ *\n\ * ISPLIT (input) INTEGER array, dimension (N)\n\ * The splitting points, at which T breaks up into submatrices.\n\ * The first submatrix consists of rows/columns 1 to\n\ * ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n\ * through ISPLIT( 2 ), etc.\n\ * ( The output array ISPLIT from DSTEBZ is expected here. )\n\ *\n\ * Z (output) DOUBLE PRECISION array, dimension (LDZ, M)\n\ * The computed eigenvectors. The eigenvector associated\n\ * with the eigenvalue W(i) is stored in the i-th column of\n\ * Z. Any vector which fails to converge is set to its current\n\ * iterate after MAXITS iterations.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (5*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * IFAIL (output) INTEGER array, dimension (M)\n\ * On normal exit, all elements of IFAIL are zero.\n\ * If one or more eigenvectors fail to converge after\n\ * MAXITS iterations, then their indices are stored in\n\ * array IFAIL.\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, then i eigenvectors failed to converge\n\ * in MAXITS iterations. Their indices are stored in\n\ * array IFAIL.\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * MAXITS INTEGER, default = 5\n\ * The maximum number of iterations performed.\n\ *\n\ * EXTRA INTEGER, default = 2\n\ * The number of iterations performed after norm growth\n\ * criterion is satisfied, should be at least 1.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zsyconv0000644000175000017500000000514512502223526016730 0ustar uwabamiuwabami--- :name: zsyconv :md5sum: 2f9890567fa95c147b575de68e48b3da :category: :subroutine :arguments: - uplo: :type: char :intent: input - way: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublecomplex :intent: workspace :dims: - MAX(1,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZSYCONV( UPLO, WAY, N, A, LDA, IPIV, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSYCONV converts A given by ZHETRF into L and D or vice-versa.\n\ * Get nondiagonal elements of D (returned in workspace) and \n\ * apply or reverse permutation done in TRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ * \n\ * WAY (input) CHARACTER*1\n\ * = 'C': Convert \n\ * = 'R': Revert\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) DOUBLE COMPLEX array, dimension (LDA,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by ZSYTRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by ZSYTRF.\n\ *\n\ * WORK (workspace) DOUBLE COMPLEX array, dimension (N)\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of WORK. LWORK >=1. \n\ * LWORK = N\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clange0000644000175000017500000000470712502223525016450 0ustar uwabamiuwabami--- :name: clange :md5sum: 6793322d76fa36f62a8b759167322ea6 :category: :function :type: real :arguments: - norm: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? m : 0" :fortran_help: " REAL FUNCTION CLANGE( NORM, M, N, A, LDA, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLANGE returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * complex matrix A.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * CLANGE returns the value\n\ *\n\ * CLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in CLANGE as described\n\ * above.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A. M >= 0. When M = 0,\n\ * CLANGE is set to zero.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix A. N >= 0. When N = 0,\n\ * CLANGE is set to zero.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The m by n matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(M,1).\n\ *\n\ * WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n\ * referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clatrs0000644000175000017500000001707712502223525016513 0ustar uwabamiuwabami--- :name: clatrs :md5sum: 7acf429b0c580f6619388ac433e3add1 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - normin: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - n - scale: :type: real :intent: output - cnorm: :type: real :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, CNORM, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLATRS solves one of the triangular systems\n\ *\n\ * A * x = s*b, A**T * x = s*b, or A**H * x = s*b,\n\ *\n\ * with scaling to prevent overflow. Here A is an upper or lower\n\ * triangular matrix, A**T denotes the transpose of A, A**H denotes the\n\ * conjugate transpose of A, x and b are n-element vectors, and s is a\n\ * scaling factor, usually less than or equal to 1, chosen so that the\n\ * components of x will be less than the overflow threshold. If the\n\ * unscaled problem will not cause overflow, the Level 2 BLAS routine\n\ * CTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j),\n\ * then s is set to 0 and a non-trivial solution to A*x = 0 is returned.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the matrix A is upper or lower triangular.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the operation applied to A.\n\ * = 'N': Solve A * x = s*b (No transpose)\n\ * = 'T': Solve A**T * x = s*b (Transpose)\n\ * = 'C': Solve A**H * x = s*b (Conjugate transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * Specifies whether or not the matrix A is unit triangular.\n\ * = 'N': Non-unit triangular\n\ * = 'U': Unit triangular\n\ *\n\ * NORMIN (input) CHARACTER*1\n\ * Specifies whether CNORM has been set or not.\n\ * = 'Y': CNORM contains the column norms on entry\n\ * = 'N': CNORM is not set on entry. On exit, the norms will\n\ * be computed and stored in CNORM.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The triangular matrix A. If UPLO = 'U', the leading n by n\n\ * upper triangular part of the array A contains the upper\n\ * triangular matrix, and the strictly lower triangular part of\n\ * A is not referenced. If UPLO = 'L', the leading n by n lower\n\ * triangular part of the array A contains the lower triangular\n\ * matrix, and the strictly upper triangular part of A is not\n\ * referenced. If DIAG = 'U', the diagonal elements of A are\n\ * also not referenced and are assumed to be 1.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max (1,N).\n\ *\n\ * X (input/output) COMPLEX array, dimension (N)\n\ * On entry, the right hand side b of the triangular system.\n\ * On exit, X is overwritten by the solution vector x.\n\ *\n\ * SCALE (output) REAL\n\ * The scaling factor s for the triangular system\n\ * A * x = s*b, A**T * x = s*b, or A**H * x = s*b.\n\ * If SCALE = 0, the matrix A is singular or badly scaled, and\n\ * the vector x is an exact or approximate solution to A*x = 0.\n\ *\n\ * CNORM (input or output) REAL array, dimension (N)\n\ *\n\ * If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n\ * contains the norm of the off-diagonal part of the j-th column\n\ * of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n\ * to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n\ * must be greater than or equal to the 1-norm.\n\ *\n\ * If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n\ * returns the 1-norm of the offdiagonal part of the j-th column\n\ * of A.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ *\n\n\ * Further Details\n\ * ======= =======\n\ *\n\ * A rough bound on x is computed; if that is less than overflow, CTRSV\n\ * is called, otherwise, specific code is used which checks for possible\n\ * overflow or divide-by-zero at every operation.\n\ *\n\ * A columnwise scheme is used for solving A*x = b. The basic algorithm\n\ * if A is lower triangular is\n\ *\n\ * x[1:n] := b[1:n]\n\ * for j = 1, ..., n\n\ * x(j) := x(j) / A(j,j)\n\ * x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n\ * end\n\ *\n\ * Define bounds on the components of x after j iterations of the loop:\n\ * M(j) = bound on x[1:j]\n\ * G(j) = bound on x[j+1:n]\n\ * Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n\ *\n\ * Then for iteration j+1 we have\n\ * M(j+1) <= G(j) / | A(j+1,j+1) |\n\ * G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n\ * <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n\ *\n\ * where CNORM(j+1) is greater than or equal to the infinity-norm of\n\ * column j+1 of A, not counting the diagonal. Hence\n\ *\n\ * G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n\ * 1<=i<=j\n\ * and\n\ *\n\ * |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n\ * 1<=i< j\n\ *\n\ * Since |x(j)| <= M(j), we use the Level 2 BLAS routine CTRSV if the\n\ * reciprocal of the largest M(j), j=1,..,n, is larger than\n\ * max(underflow, 1/overflow).\n\ *\n\ * The bound on x(j) is also used to determine when a step in the\n\ * columnwise method can be performed without fear of overflow. If\n\ * the computed bound is greater than a large constant, x is scaled to\n\ * prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n\ * 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n\ *\n\ * Similarly, a row-wise scheme is used to solve A**T *x = b or\n\ * A**H *x = b. The basic algorithm for A upper triangular is\n\ *\n\ * for j = 1, ..., n\n\ * x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n\ * end\n\ *\n\ * We simultaneously compute two bounds\n\ * G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n\ * M(j) = bound on x(i), 1<=i<=j\n\ *\n\ * The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n\ * add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n\ * Then the bound on x(j) is\n\ *\n\ * M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n\ *\n\ * <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n\ * 1<=i<=j\n\ *\n\ * and we can safely call CTRSV if 1/M(n) and 1/G(n) are both greater\n\ * than max(underflow, 1/overflow).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsterf0000644000175000017500000000316012502223526016477 0ustar uwabamiuwabami--- :name: dsterf :md5sum: 5dc7d5e9f4d5a3a72037d3b60fce2589 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DSTERF( N, D, E, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSTERF computes all eigenvalues of a symmetric tridiagonal matrix\n\ * using the Pal-Walker-Kahan variant of the QL or QR algorithm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the n diagonal elements of the tridiagonal matrix.\n\ * On exit, if INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * E (input/output) DOUBLE PRECISION array, dimension (N-1)\n\ * On entry, the (n-1) subdiagonal elements of the tridiagonal\n\ * matrix.\n\ * On exit, E has been destroyed.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: the algorithm failed to find all of the eigenvalues in\n\ * a total of 30*N iterations; if INFO = i, then i\n\ * elements of E have not converged to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zungqr0000644000175000017500000000576312502223526016551 0ustar uwabamiuwabami--- :name: zungqr :md5sum: 7b643868b80fc48ab43e7a76954d6b60 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZUNGQR generates an M-by-N complex matrix Q with orthonormal columns,\n\ * which is defined as the first N columns of a product of K elementary\n\ * reflectors of order M\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by ZGEQRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. M >= N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. N >= K >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the i-th column must contain the vector which\n\ * defines the elementary reflector H(i), for i = 1,2,...,k, as\n\ * returned by ZGEQRF in the first k columns of its array\n\ * argument A.\n\ * On exit, the M-by-N matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) COMPLEX*16 array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by ZGEQRF.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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,N).\n\ * For optimum performance LWORK >= N*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 has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zptcon0000644000175000017500000000503012502223526016523 0ustar uwabamiuwabami--- :name: zptcon :md5sum: 55726a854f4ea93e20da6057c21868f0 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublecomplex :intent: input :dims: - n-1 - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPTCON( N, D, E, ANORM, RCOND, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPTCON computes the reciprocal of the condition number (in the\n\ * 1-norm) of a complex Hermitian positive definite tridiagonal matrix\n\ * using the factorization A = L*D*L**H or A = U**H*D*U computed by\n\ * ZPTTRF.\n\ *\n\ * Norm(inv(A)) is computed by a direct method, and the reciprocal of\n\ * the condition number is computed as\n\ * RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The n diagonal elements of the diagonal matrix D from the\n\ * factorization of A, as computed by ZPTTRF.\n\ *\n\ * E (input) COMPLEX*16 array, dimension (N-1)\n\ * The (n-1) off-diagonal elements of the unit bidiagonal factor\n\ * U or L from the factorization of A, as computed by ZPTTRF.\n\ *\n\ * ANORM (input) DOUBLE PRECISION\n\ * The 1-norm of the original matrix A.\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the\n\ * 1-norm of inv(A) computed in this routine.\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\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 method used is described in Nicholas J. Higham, \"Efficient\n\ * Algorithms for Computing the Condition Number of a Tridiagonal\n\ * Matrix\", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlanhs0000644000175000017500000000456712502223526016523 0ustar uwabamiuwabami--- :name: zlanhs :md5sum: 0d7a937484d67bc8e510f66da14bec2f :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? n : 0" :fortran_help: " DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLANHS returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * Hessenberg matrix A.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * ZLANHS returns the value\n\ *\n\ * ZLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in ZLANHS as described\n\ * above.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, ZLANHS is\n\ * set to zero.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The n by n upper Hessenberg matrix A; the part of A below the\n\ * first sub-diagonal is not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(N,1).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n\ * referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgbtf20000644000175000017500000000742612502223525016367 0ustar uwabamiuwabami--- :name: cgbtf2 :md5sum: 874bb87107feab33bcca8057b0073bac :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGBTF2 computes an LU factorization of a complex m-by-n band matrix\n\ * A using partial pivoting with row interchanges.\n\ *\n\ * This is the unblocked version of the algorithm, calling Level 2 BLAS.\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\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * AB (input/output) COMPLEX array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows KL+1 to\n\ * 2*KL+KU+1; rows 1 to KL of the array need not be set.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n\ *\n\ * On exit, details of the factorization: U is stored as an\n\ * upper triangular band matrix with KL+KU superdiagonals in\n\ * rows 1 to KL+KU+1, and the multipliers used during the\n\ * factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n\ * See below for further details.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n\ *\n\ * IPIV (output) INTEGER array, dimension (min(M,N))\n\ * The pivot indices; for 1 <= i <= min(M,N), row i of the\n\ * matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, and division by zero will occur if it is used\n\ * to solve a system of equations.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * M = N = 6, KL = 2, KU = 1:\n\ *\n\ * On entry: On exit:\n\ *\n\ * * * * + + + * * * u14 u25 u36\n\ * * * + + + + * * u13 u24 u35 u46\n\ * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n\ * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n\ * a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n\ * a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n\ *\n\ * Array elements marked * are not used by the routine; elements marked\n\ * + need not be set on entry, but are required by the routine to store\n\ * elements of U, because of fill-in resulting from the row\n\ * interchanges.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/claqhp0000644000175000017500000000531712502223525016465 0ustar uwabamiuwabami--- :name: claqhp :md5sum: a481d769a64275943f73dbe515a1ebf0 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - n*(n+1)/2 - s: :type: real :intent: input :dims: - n - scond: :type: real :intent: input - amax: :type: real :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CLAQHP( UPLO, N, AP, S, SCOND, AMAX, EQUED )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAQHP equilibrates a Hermitian matrix A using the scaling factors\n\ * in the vector S.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * Hermitian matrix A is stored.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, the equilibrated matrix: diag(S) * A * diag(S), in\n\ * the same storage format as A.\n\ *\n\ * S (input) REAL array, dimension (N)\n\ * The scale factors for A.\n\ *\n\ * SCOND (input) REAL\n\ * Ratio of the smallest S(i) to the largest S(i).\n\ *\n\ * AMAX (input) REAL\n\ * Absolute value of largest matrix entry.\n\ *\n\ * EQUED (output) CHARACTER*1\n\ * Specifies whether or not equilibration was done.\n\ * = 'N': No equilibration.\n\ * = 'Y': Equilibration was done, i.e., A has been replaced by\n\ * diag(S) * A * diag(S).\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * THRESH is a threshold value used to decide if scaling should be done\n\ * based on the ratio of the scaling factors. If SCOND < THRESH,\n\ * scaling is done.\n\ *\n\ * LARGE and SMALL are threshold values used to decide if scaling should\n\ * be done based on the absolute size of the largest matrix element.\n\ * If AMAX > LARGE or AMAX < SMALL, scaling is done.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgetc20000644000175000017500000000503112502223525016355 0ustar uwabamiuwabami--- :name: cgetc2 :md5sum: 0e098d8f352fe876de5f103e8d0d40d5 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - jpiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGETC2( N, A, LDA, IPIV, JPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGETC2 computes an LU factorization, using complete pivoting, of the\n\ * n-by-n matrix A. The factorization has the form A = P * L * U * Q,\n\ * where P and Q are permutation matrices, L is lower triangular with\n\ * unit diagonal elements and U is upper triangular.\n\ *\n\ * This is a level 1 BLAS version of the algorithm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA, N)\n\ * On entry, the n-by-n matrix to be factored.\n\ * On exit, the factors L and U from the factorization\n\ * A = P*L*U*Q; the unit diagonal elements of L are not stored.\n\ * If U(k, k) appears to be less than SMIN, U(k, k) is given the\n\ * value of SMIN, giving a nonsingular perturbed system.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1, N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N).\n\ * The pivot indices; for 1 <= i <= N, row i of the\n\ * matrix has been interchanged with row IPIV(i).\n\ *\n\ * JPIV (output) INTEGER array, dimension (N).\n\ * The pivot indices; for 1 <= j <= N, column j of the\n\ * matrix has been interchanged with column JPIV(j).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * > 0: if INFO = k, U(k, k) is likely to produce overflow if\n\ * one tries to solve for x in Ax = b. So U is perturbed\n\ * to avoid the overflow.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgeev0000644000175000017500000001305212502223526016322 0ustar uwabamiuwabami--- :name: sgeev :md5sum: 65ee2e476fb8f76d13c30265f57d9bc0 :category: :subroutine :arguments: - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - wr: :type: real :intent: output :dims: - n - wi: :type: real :intent: output :dims: - n - vl: :type: real :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: real :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(lsame_(&jobvl,\"V\")||lsame_(&jobvr,\"V\")) ? 4*n : 3*n" - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " SUBROUTINE SGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGEEV computes for an N-by-N real nonsymmetric matrix A, the\n\ * eigenvalues and, optionally, the left and/or right eigenvectors.\n\ *\n\ * The right eigenvector v(j) of A satisfies\n\ * A * v(j) = lambda(j) * v(j)\n\ * where lambda(j) is its eigenvalue.\n\ * The left eigenvector u(j) of A satisfies\n\ * u(j)**H * A = lambda(j) * u(j)**H\n\ * where u(j)**H denotes the conjugate transpose of u(j).\n\ *\n\ * The computed eigenvectors are normalized to have Euclidean norm\n\ * equal to 1 and largest component real.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVL (input) CHARACTER*1\n\ * = 'N': left eigenvectors of A are not computed;\n\ * = 'V': left eigenvectors of A are computed.\n\ *\n\ * JOBVR (input) CHARACTER*1\n\ * = 'N': right eigenvectors of A are not computed;\n\ * = 'V': right eigenvectors of A are computed.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ * On exit, A has been overwritten.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * WR (output) REAL array, dimension (N)\n\ * WI (output) REAL array, dimension (N)\n\ * WR and WI contain the real and imaginary parts,\n\ * respectively, of the computed eigenvalues. Complex\n\ * conjugate pairs of eigenvalues appear consecutively\n\ * with the eigenvalue having the positive imaginary part\n\ * first.\n\ *\n\ * VL (output) REAL array, dimension (LDVL,N)\n\ * If JOBVL = 'V', the left eigenvectors u(j) are stored one\n\ * after another in the columns of VL, in the same order\n\ * as their eigenvalues.\n\ * If JOBVL = 'N', VL is not referenced.\n\ * If the j-th eigenvalue is real, then u(j) = VL(:,j),\n\ * the j-th column of VL.\n\ * If the j-th and (j+1)-st eigenvalues form a complex\n\ * conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and\n\ * u(j+1) = VL(:,j) - i*VL(:,j+1).\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the array VL. LDVL >= 1; if\n\ * JOBVL = 'V', LDVL >= N.\n\ *\n\ * VR (output) REAL array, dimension (LDVR,N)\n\ * If JOBVR = 'V', the right eigenvectors v(j) are stored one\n\ * after another in the columns of VR, in the same order\n\ * as their eigenvalues.\n\ * If JOBVR = 'N', VR is not referenced.\n\ * If the j-th eigenvalue is real, then v(j) = VR(:,j),\n\ * the j-th column of VR.\n\ * If the j-th and (j+1)-st eigenvalues form a complex\n\ * conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and\n\ * v(j+1) = VR(:,j) - i*VR(:,j+1).\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the array VR. LDVR >= 1; if\n\ * JOBVR = 'V', LDVR >= N.\n\ *\n\ * WORK (workspace/output) REAL 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,3*N), and\n\ * if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good\n\ * performance, LWORK must generally be larger.\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 QR algorithm failed to compute all the\n\ * eigenvalues, and no eigenvectors have been computed;\n\ * elements i+1:N of WR and WI contain eigenvalues which\n\ * have converged.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cla_gbamv0000644000175000017500000001203212502223525017120 0ustar uwabamiuwabami--- :name: cla_gbamv :md5sum: 6fdc0ec1e9d677c211aaed9e1e36bb0c :category: :subroutine :arguments: - trans: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - alpha: :type: real :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - x: :type: real :intent: input :dims: - "trans == ilatrans_(\"N\") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )" - incx: :type: integer :intent: input - beta: :type: real :intent: input - y: :type: real :intent: input/output :dims: - "trans == ilatrans_(\"N\") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )" - incy: :type: integer :intent: input :substitutions: ldab: MAX(1,m) :fortran_help: " SUBROUTINE CLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, INCX, BETA, Y, INCY )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLA_GBAMV performs one of the matrix-vector operations\n\ *\n\ * y := alpha*abs(A)*abs(x) + beta*abs(y),\n\ * or y := alpha*abs(A)'*abs(x) + beta*abs(y),\n\ *\n\ * where alpha and beta are scalars, x and y are vectors and A is an\n\ * m by n matrix.\n\ *\n\ * This function is primarily used in calculating error bounds.\n\ * To protect against underflow during evaluation, components in\n\ * the resulting vector are perturbed away from zero by (N+1)\n\ * times the underflow threshold. To prevent unnecessarily large\n\ * errors for block-structure embedded in general matrices,\n\ * \"symbolically\" zero components are not perturbed. A zero\n\ * entry is considered \"symbolic\" if all multiplications involved\n\ * in computing that entry have at least one zero multiplicand.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * TRANS (input) INTEGER\n\ * On entry, TRANS specifies the operation to be performed as\n\ * follows:\n\ *\n\ * BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y)\n\ * BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n\ * BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n\ *\n\ * Unchanged on exit.\n\ *\n\ * M (input) INTEGER\n\ * On entry, M specifies the number of rows of the matrix A.\n\ * M must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the number of columns of the matrix A.\n\ * N must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * ALPHA (input) REAL\n\ * On entry, ALPHA specifies the scalar alpha.\n\ * Unchanged on exit.\n\ *\n\ * A (input) REAL array, dimension (LDA,n)\n\ * Before entry, the leading m by n part of the array A must\n\ * contain the matrix of coefficients.\n\ * Unchanged on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * On entry, LDA specifies the first dimension of A as declared\n\ * in the calling (sub) program. LDA must be at least\n\ * max( 1, m ).\n\ * Unchanged on exit.\n\ *\n\ * X (input) REAL array, dimension at least\n\ * ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n\ * and at least\n\ * ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n\ * Before entry, the incremented array X must contain the\n\ * vector x.\n\ * Unchanged on exit.\n\ *\n\ * INCX (input) INTEGER\n\ * On entry, INCX specifies the increment for the elements of\n\ * X. INCX must not be zero.\n\ * Unchanged on exit.\n\ *\n\ * BETA (input) REAL\n\ * On entry, BETA specifies the scalar beta. When BETA is\n\ * supplied as zero then Y need not be set on input.\n\ * Unchanged on exit.\n\ *\n\ * Y (input/output) REAL array, dimension at least\n\ * ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n\ * and at least\n\ * ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n\ * Before entry with BETA non-zero, the incremented array Y\n\ * must contain the vector y. On exit, Y is overwritten by the\n\ * updated vector y.\n\ *\n\ * INCY (input) INTEGER\n\ * On entry, INCY specifies the increment for the elements of\n\ * Y. INCY must not be zero.\n\ * Unchanged on exit.\n\ *\n\ *\n\ * Level 2 Blas routine.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgesvj0000644000175000017500000003657012502223526016524 0ustar uwabamiuwabami--- :name: sgesvj :md5sum: 6fcf21eb9eda45c9d276fe7d46e1a972 :category: :subroutine :arguments: - joba: :type: char :intent: input - jobu: :type: char :intent: input - jobv: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - sva: :type: real :intent: output :dims: - n - mv: :type: integer :intent: input - v: :type: real :intent: input/output :dims: - ldv - n - ldv: :type: integer :intent: input - work: :type: real :intent: input/output :dims: - lwork - lwork: :type: integer :intent: input :option: true :default: MAX(6,m+n) - info: :type: integer :intent: output :substitutions: lwork: MAX(6,m+n) :fortran_help: " SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, LDV, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGESVJ computes the singular value decomposition (SVD) of a real\n\ * M-by-N matrix A, where M >= N. The SVD of A is written as\n\ * [++] [xx] [x0] [xx]\n\ * A = U * SIGMA * V^t, [++] = [xx] * [ox] * [xx]\n\ * [++] [xx]\n\ * where SIGMA is an N-by-N diagonal matrix, U is an M-by-N orthonormal\n\ * matrix, and V is an N-by-N orthogonal matrix. The diagonal elements\n\ * of SIGMA are the singular values of A. The columns of U and V are the\n\ * left and the right singular vectors of A, respectively.\n\ *\n\ * Further Details\n\ * ~~~~~~~~~~~~~~~\n\ * The orthogonal N-by-N matrix V is obtained as a product of Jacobi plane\n\ * rotations. The rotations are implemented as fast scaled rotations of\n\ * Anda and Park [1]. In the case of underflow of the Jacobi angle, a\n\ * modified Jacobi transformation of Drmac [4] is used. Pivot strategy uses\n\ * column interchanges of de Rijk [2]. The relative accuracy of the computed\n\ * singular values and the accuracy of the computed singular vectors (in\n\ * angle metric) is as guaranteed by the theory of Demmel and Veselic [3].\n\ * The condition number that determines the accuracy in the full rank case\n\ * is essentially min_{D=diag} kappa(A*D), where kappa(.) is the\n\ * spectral condition number. The best performance of this Jacobi SVD\n\ * procedure is achieved if used in an accelerated version of Drmac and\n\ * Veselic [5,6], and it is the kernel routine in the SIGMA library [7].\n\ * Some tunning parameters (marked with [TP]) are available for the\n\ * implementer.\n\ * The computational range for the nonzero singular values is the machine\n\ * number interval ( UNDERFLOW , OVERFLOW ). In extreme cases, even\n\ * denormalized singular values can be computed with the corresponding\n\ * gradual loss of accurate digits.\n\ *\n\ * Contributors\n\ * ~~~~~~~~~~~~\n\ * Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)\n\ *\n\ * References\n\ * ~~~~~~~~~~\n\ * [1] A. A. Anda and H. Park: Fast plane rotations with dynamic scaling.\n\ * SIAM J. matrix Anal. Appl., Vol. 15 (1994), pp. 162-174.\n\ * [2] P. P. M. De Rijk: A one-sided Jacobi algorithm for computing the\n\ * singular value decomposition on a vector computer.\n\ * SIAM J. Sci. Stat. Comp., Vol. 10 (1998), pp. 359-371.\n\ * [3] J. Demmel and K. Veselic: Jacobi method is more accurate than QR.\n\ * [4] Z. Drmac: Implementation of Jacobi rotations for accurate singular\n\ * value computation in floating point arithmetic.\n\ * SIAM J. Sci. Comp., Vol. 18 (1997), pp. 1200-1222.\n\ * [5] 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\ * [6] 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\ * [7] 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 test examples and comments to\n\ * drmac@math.hr. Thank you.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBA (input) CHARACTER* 1\n\ * Specifies the structure of A.\n\ * = 'L': The input matrix A is lower triangular;\n\ * = 'U': The input matrix A is upper triangular;\n\ * = 'G': The input matrix A is general M-by-N matrix, M >= N.\n\ *\n\ * JOBU (input) CHARACTER*1\n\ * Specifies whether to compute the left singular vectors\n\ * (columns of U):\n\ * = 'U': The left singular vectors corresponding to the nonzero\n\ * singular values are computed and returned in the leading\n\ * columns of A. See more details in the description of A.\n\ * The default numerical orthogonality threshold is set to\n\ * approximately TOL=CTOL*EPS, CTOL=SQRT(M), EPS=SLAMCH('E').\n\ * = 'C': Analogous to JOBU='U', except that user can control the\n\ * level of numerical orthogonality of the computed left\n\ * singular vectors. TOL can be set to TOL = CTOL*EPS, where\n\ * CTOL is given on input in the array WORK.\n\ * No CTOL smaller than ONE is allowed. CTOL greater\n\ * than 1 / EPS is meaningless. The option 'C'\n\ * can be used if M*EPS is satisfactory orthogonality\n\ * of the computed left singular vectors, so CTOL=M could\n\ * save few sweeps of Jacobi rotations.\n\ * See the descriptions of A and WORK(1).\n\ * = 'N': The matrix U is not computed. However, see the\n\ * description of A.\n\ *\n\ * JOBV (input) CHARACTER*1\n\ * Specifies whether to compute the right singular vectors, that\n\ * is, the matrix V:\n\ * = 'V' : the matrix V is computed and returned in the array V\n\ * = 'A' : the Jacobi rotations are applied to the MV-by-N\n\ * array V. In other words, the right singular vector\n\ * matrix V is not computed explicitly; instead it is\n\ * applied to an MV-by-N matrix initially stored in the\n\ * first MV rows of V.\n\ * = 'N' : the matrix V is not computed and the array V is not\n\ * referenced\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.\n\ * M >= N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit,\n\ * If JOBU .EQ. 'U' .OR. JOBU .EQ. 'C':\n\ * If INFO .EQ. 0 :\n\ * RANKA orthonormal columns of U are returned in the\n\ * leading RANKA columns of the array A. Here RANKA <= N\n\ * is the number of computed singular values of A that are\n\ * above the underflow threshold SLAMCH('S'). The singular\n\ * vectors corresponding to underflowed or zero singular\n\ * values are not computed. The value of RANKA is returned\n\ * in the array WORK as RANKA=NINT(WORK(2)). Also see the\n\ * descriptions of SVA and WORK. The computed columns of U\n\ * are mutually numerically orthogonal up to approximately\n\ * TOL=SQRT(M)*EPS (default); or TOL=CTOL*EPS (JOBU.EQ.'C'),\n\ * see the description of JOBU.\n\ * If INFO .GT. 0,\n\ * the procedure SGESVJ did not converge in the given number\n\ * of iterations (sweeps). In that case, the computed\n\ * columns of U may not be orthogonal up to TOL. The output\n\ * U (stored in A), SIGMA (given by the computed singular\n\ * values in SVA(1:N)) and V is still a decomposition of the\n\ * input matrix A in the sense that the residual\n\ * ||A-SCALE*U*SIGMA*V^T||_2 / ||A||_2 is small.\n\ * If JOBU .EQ. 'N':\n\ * If INFO .EQ. 0 :\n\ * Note that the left singular vectors are 'for free' in the\n\ * one-sided Jacobi SVD algorithm. However, if only the\n\ * singular values are needed, the level of numerical\n\ * orthogonality of U is not an issue and iterations are\n\ * stopped when the columns of the iterated matrix are\n\ * numerically orthogonal up to approximately M*EPS. Thus,\n\ * on exit, A contains the columns of U scaled with the\n\ * corresponding singular values.\n\ * If INFO .GT. 0 :\n\ * the procedure SGESVJ did not converge in the given number\n\ * of iterations (sweeps).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * SVA (workspace/output) REAL array, dimension (N)\n\ * On exit,\n\ * If INFO .EQ. 0 :\n\ * depending on the value SCALE = WORK(1), we have:\n\ * If SCALE .EQ. ONE:\n\ * SVA(1:N) contains the computed singular values of A.\n\ * During the computation SVA contains the Euclidean column\n\ * norms of the iterated matrices in the array A.\n\ * If SCALE .NE. ONE:\n\ * The singular values of A are SCALE*SVA(1:N), and this\n\ * factored representation is due to the fact that some of the\n\ * singular values of A might underflow or overflow.\n\ *\n\ * If INFO .GT. 0 :\n\ * the procedure SGESVJ did not converge in the given number of\n\ * iterations (sweeps) and SCALE*SVA(1:N) may not be accurate.\n\ *\n\ * MV (input) INTEGER\n\ * If JOBV .EQ. 'A', then the product of Jacobi rotations in SGESVJ\n\ * is applied to the first MV rows of V. See the description of JOBV.\n\ *\n\ * V (input/output) REAL array, dimension (LDV,N)\n\ * If JOBV = 'V', then V contains on exit the N-by-N matrix of\n\ * the right singular vectors;\n\ * If JOBV = 'A', then V contains the product of the computed right\n\ * singular vector matrix and the initial matrix in\n\ * the array V.\n\ * If JOBV = 'N', then V is not referenced.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V, LDV .GE. 1.\n\ * If JOBV .EQ. 'V', then LDV .GE. max(1,N).\n\ * If JOBV .EQ. 'A', then LDV .GE. max(1,MV) .\n\ *\n\ * WORK (input/workspace/output) REAL array, dimension max(4,M+N).\n\ * On entry,\n\ * If JOBU .EQ. 'C' :\n\ * WORK(1) = CTOL, where CTOL defines the threshold for convergence.\n\ * The process stops if all columns of A are mutually\n\ * orthogonal up to CTOL*EPS, EPS=SLAMCH('E').\n\ * It is required that CTOL >= ONE, i.e. it is not\n\ * allowed to force the routine to obtain orthogonality\n\ * below EPSILON.\n\ * On exit,\n\ * WORK(1) = SCALE is the scaling factor such that SCALE*SVA(1:N)\n\ * are the computed singular vcalues of A.\n\ * (See description of SVA().)\n\ * WORK(2) = NINT(WORK(2)) is the number of the computed nonzero\n\ * singular values.\n\ * WORK(3) = NINT(WORK(3)) is the number of the computed singular\n\ * values that are larger than the underflow threshold.\n\ * WORK(4) = NINT(WORK(4)) is the number of sweeps of Jacobi\n\ * rotations needed for numerical convergence.\n\ * WORK(5) = max_{i.NE.j} |COS(A(:,i),A(:,j))| in the last sweep.\n\ * This is useful information in cases when SGESVJ did\n\ * not converge, as it can be used to estimate whether\n\ * the output is stil useful and for post festum analysis.\n\ * WORK(6) = the largest absolute value over all sines of the\n\ * Jacobi rotation angles in the last sweep. It can be\n\ * useful for a post festum analysis.\n\ *\n\ * LWORK length of WORK, WORK >= MAX(6,M+N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0 : successful exit.\n\ * < 0 : if INFO = -i, then the i-th argument had an illegal value\n\ * > 0 : SGESVJ did not converge in the maximal allowed number (30)\n\ * of sweeps. The output may still be useful. See the\n\ * description of WORK.\n\n\ * =====================================================================\n\ *\n\ * .. Local Parameters ..\n REAL ZERO, HALF, ONE, TWO\n PARAMETER ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0,\n + TWO = 2.0E0 )\n INTEGER NSWEEP\n PARAMETER ( NSWEEP = 30 )\n\ * ..\n\ * .. Local Scalars ..\n REAL AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,\n + BIGTHETA, CS, CTOL, EPSLN, LARGE, MXAAPQ,\n + MXSINJ, ROOTBIG, ROOTEPS, ROOTSFMIN, ROOTTOL,\n + SKL, SFMIN, SMALL, SN, T, TEMP1, THETA,\n + THSIGN, TOL\n INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1,\n + ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, N2, N34,\n + N4, NBL, NOTROT, p, PSKIPPED, q, ROWSKIP,\n + SWBAND\n LOGICAL APPLV, GOSCALE, LOWER, LSVEC, NOSCALE, ROTOK,\n + RSVEC, UCTOL, UPPER\n\ * ..\n\ * .. Local Arrays ..\n REAL FASTR( 5 )\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, AMAX1, AMIN1, FLOAT, MIN0, SIGN, SQRT\n\ * ..\n\ * .. External Functions ..\n\ * from BLAS\n REAL SDOT, SNRM2\n EXTERNAL SDOT, SNRM2\n INTEGER ISAMAX\n EXTERNAL ISAMAX\n\ * from LAPACK\n REAL SLAMCH\n EXTERNAL SLAMCH\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n\ * from BLAS\n EXTERNAL SAXPY, SCOPY, SROTM, SSCAL, SSWAP\n\ * from LAPACK\n EXTERNAL SLASCL, SLASET, SLASSQ, XERBLA\n\ *\n EXTERNAL SGSVJ0, SGSVJ1\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zgeqr2p0000644000175000017500000000477412502223526016616 0ustar uwabamiuwabami--- :name: zgeqr2p :md5sum: 91c52296b9bdb3e1d438c64cbffd2d84 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - MIN(m,n) - work: :type: doublecomplex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGEQR2P( M, N, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGEQR2P computes a QR factorization of a complex m by n matrix A:\n\ * A = Q * R.\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) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the m by n matrix A.\n\ * On exit, the elements on and above the diagonal of the array\n\ * contain the min(m,n) by n upper trapezoidal matrix R (R is\n\ * upper triangular if m >= n); the elements below the diagonal,\n\ * with the array TAU, represent the unitary 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) COMPLEX*16 array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (N)\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(1) H(2) . . . H(k), 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 complex scalar, and v is a complex vector with\n\ * v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n\ * and tau in TAU(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/stbrfs0000644000175000017500000001164312502223526016520 0ustar uwabamiuwabami--- :name: stbrfs :md5sum: 2e9b692379fa03625583395df789da2f :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE STBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STBRFS provides error bounds and backward error estimates for the\n\ * solution to a system of linear equations with a triangular band\n\ * coefficient matrix.\n\ *\n\ * The solution matrix X must be computed by STBTRS or some other\n\ * means before entering this routine. STBRFS does not do iterative\n\ * refinement because doing so cannot improve the backward error.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose = Transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals or subdiagonals of the\n\ * triangular band matrix A. KD >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AB (input) REAL array, dimension (LDAB,N)\n\ * The upper or lower triangular band matrix A, stored in the\n\ * first kd+1 rows of the array. The j-th column of A is stored\n\ * in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ * If DIAG = 'U', the diagonal elements of A are not referenced\n\ * and are assumed to be 1.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * B (input) REAL array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input) REAL array, dimension (LDX,NRHS)\n\ * The solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) REAL array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dspevd0000644000175000017500000001347712502223526016511 0ustar uwabamiuwabami--- :name: dspevd :md5sum: 3bed418654a505888490fb1f28577d00 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - ldap - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 2*n : lsame_(&jobz,\"V\") ? 1+6*n+n*n : 2" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "(lsame_(&jobz,\"N\")||n<=1) ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE DSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSPEVD computes all the eigenvalues and, optionally, eigenvectors\n\ * of a real symmetric matrix A in packed storage. If eigenvectors are\n\ * desired, it uses a divide and conquer algorithm.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, AP is overwritten by values generated during the\n\ * reduction to tridiagonal form. If UPLO = 'U', the diagonal\n\ * and first superdiagonal of the tridiagonal matrix T overwrite\n\ * the corresponding elements of A, and if UPLO = 'L', the\n\ * diagonal and first subdiagonal of T overwrite the\n\ * corresponding elements of A.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n\ * eigenvectors of the matrix A, with the i-th column of Z\n\ * holding the eigenvector associated with W(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace/output) DOUBLE PRECISION array,\n\ * dimension (LWORK)\n\ * On exit, if INFO = 0, WORK(1) returns the required LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK.\n\ * If N <= 1, LWORK must be at least 1.\n\ * If JOBZ = 'N' and N > 1, LWORK must be at least 2*N.\n\ * If JOBZ = 'V' and N > 1, LWORK must be at least\n\ * 1 + 6*N + N**2.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the required sizes of the WORK and IWORK\n\ * arrays, returns these values as the first entries of the WORK\n\ * and IWORK arrays, and no error message related to LWORK or\n\ * LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK.\n\ * If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.\n\ * If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the required sizes of the WORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK and IWORK arrays, and no error message related to\n\ * LWORK or LIWORK 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 algorithm failed to converge; i\n\ * off-diagonal elements of an intermediate tridiagonal\n\ * form did not converge to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dspsvx0000644000175000017500000002274012502223526016544 0ustar uwabamiuwabami--- :name: dspsvx :md5sum: 54ccdee08d1f02db7007bc1865c36951 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - n*(n+1)/2 - afp: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE DSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSPSVX uses the diagonal pivoting factorization A = U*D*U**T or\n\ * A = L*D*L**T to compute the solution to a real system of linear\n\ * equations A * X = B, where A is an N-by-N symmetric matrix stored\n\ * in packed format and X and B are N-by-NRHS matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'N', the diagonal pivoting method is used to factor A as\n\ * A = U * D * U**T, if UPLO = 'U', or\n\ * A = L * D * L**T, if UPLO = 'L',\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices and D is symmetric and block diagonal with\n\ * 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\ * 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n\ * returns with INFO = i. Otherwise, the factored form of A is used\n\ * to estimate the condition number of the matrix A. If the\n\ * reciprocal of the condition number is less than machine precision,\n\ * INFO = N+1 is returned as a warning, but the routine still goes on\n\ * to solve for X and compute error bounds as described below.\n\ *\n\ * 3. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 4. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of A has been\n\ * supplied on entry.\n\ * = 'F': On entry, AFP and IPIV contain the factored form of\n\ * A. AP, AFP and IPIV will not be modified.\n\ * = 'N': The matrix A will be copied to AFP and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * The upper or lower triangle of the symmetric matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ * See below for further details.\n\ *\n\ * AFP (input or output) DOUBLE PRECISION array, dimension\n\ * (N*(N+1)/2)\n\ * If FACT = 'F', then AFP is an input argument and on entry\n\ * contains the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L from the factorization\n\ * A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as\n\ * a packed triangular matrix in the same storage format as A.\n\ *\n\ * If FACT = 'N', then AFP is an output argument and on exit\n\ * contains the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L from the factorization\n\ * A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as\n\ * a packed triangular matrix in the same storage format as A.\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains details of the interchanges and the block structure\n\ * of D, as determined by DSPTRF.\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains details of the interchanges and the block structure\n\ * of D, as determined by DSPTRF.\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * The N-by-NRHS right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A. If RCOND is less than the machine precision (in\n\ * particular, if RCOND = 0), the matrix is singular to working\n\ * precision. This condition is indicated by a return code of\n\ * INFO > 0.\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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, and i is\n\ * <= N: D(i,i) is exactly zero. The factorization\n\ * has been completed but the factor D is exactly\n\ * singular, so the solution and error bounds could\n\ * not be computed. RCOND = 0 is returned.\n\ * = N+1: D is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The packed storage scheme is illustrated by the following example\n\ * when N = 4, UPLO = 'U':\n\ *\n\ * Two-dimensional storage of the symmetric matrix A:\n\ *\n\ * a11 a12 a13 a14\n\ * a22 a23 a24\n\ * a33 a34 (aij = aji)\n\ * a44\n\ *\n\ * Packed storage of the upper triangle of A:\n\ *\n\ * AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhptri0000644000175000017500000000473312502223526016537 0ustar uwabamiuwabami--- :name: zhptri :md5sum: 9a9ff958ef312371ebb95295f2bf585d :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublecomplex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZHPTRI( UPLO, N, AP, IPIV, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHPTRI computes the inverse of a complex Hermitian indefinite matrix\n\ * A in packed storage using the factorization A = U*D*U**H or\n\ * A = L*D*L**H computed by ZHPTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**H;\n\ * = 'L': Lower triangular, form is A = L*D*L**H.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * On entry, the block diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L as computed by ZHPTRF,\n\ * stored as a packed triangular matrix.\n\ *\n\ * On exit, if INFO = 0, the (Hermitian) inverse of the original\n\ * matrix, stored as a packed triangular matrix. The j-th column\n\ * of inv(A) is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;\n\ * if UPLO = 'L',\n\ * AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by ZHPTRF.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (N)\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, D(i,i) = 0; the matrix is singular and its\n\ * inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlatrz0000644000175000017500000000663612502223526016551 0ustar uwabamiuwabami--- :name: zlatrz :md5sum: 0af09c4ea0283533c27d147138430ba3 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - m - work: :type: doublecomplex :intent: workspace :dims: - m :substitutions: m: lda :fortran_help: " SUBROUTINE ZLATRZ( M, N, L, A, LDA, TAU, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLATRZ factors the M-by-(M+L) complex upper trapezoidal matrix\n\ * [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z by means\n\ * of unitary transformations, where Z is an (M+L)-by-(M+L) unitary\n\ * matrix and, R and A1 are M-by-M upper triangular matrices.\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\ * L (input) INTEGER\n\ * The number of columns of the matrix A containing the\n\ * meaningful part of the Householder vectors. N-M >= L >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the leading M-by-N upper trapezoidal part of the\n\ * array A must contain the matrix to be factorized.\n\ * On exit, the leading M-by-M upper triangular part of A\n\ * contains the upper triangular matrix R, and elements N-L+1 to\n\ * N of the first M rows of A, with the array TAU, represent the\n\ * unitary matrix Z as a product of M elementary reflectors.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (output) COMPLEX*16 array, dimension (M)\n\ * The scalar factors of the elementary reflectors.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (M)\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * The factorization is obtained by Householder's method. The kth\n\ * transformation matrix, Z( k ), which is used to introduce zeros into\n\ * the ( m - k + 1 )th row of A, is given in the form\n\ *\n\ * Z( k ) = ( I 0 ),\n\ * ( 0 T( k ) )\n\ *\n\ * where\n\ *\n\ * T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n\ * ( 0 )\n\ * ( z( k ) )\n\ *\n\ * tau is a scalar and z( k ) is an l element vector. tau and z( k )\n\ * are chosen to annihilate the elements of the kth row of A2.\n\ *\n\ * The scalar tau is returned in the kth element of TAU and the vector\n\ * u( k ) in the kth row of A2, such that the elements of z( k ) are\n\ * in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in\n\ * the upper triangular part of A1.\n\ *\n\ * Z is given by\n\ *\n\ * Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctfttr0000644000175000017500000001471012502223525016520 0ustar uwabamiuwabami--- :name: ctfttr :md5sum: 66395551e389cab666a024291681e258 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - arf: :type: complex :intent: input :dims: - ldarf - a: :type: complex :intent: output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: lda: MAX(1,n) n: ((int)sqrtf(ldarf*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE CTFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTFTTR copies a triangular matrix A from rectangular full packed\n\ * format (TF) to standard full format (TR).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': ARF is in Normal format;\n\ * = 'C': ARF is in Conjugate-transpose format;\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * ARF (input) COMPLEX array, dimension ( N*(N+1)/2 ),\n\ * On entry, the upper or lower triangular matrix A stored in\n\ * RFP format. For a further discussion see Notes below.\n\ *\n\ * A (output) COMPLEX array, dimension ( LDA, N ) \n\ * On exit, the triangular matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of the array A contains\n\ * the upper triangular matrix, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of the array A contains\n\ * the lower triangular matrix, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\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\ * We first consider Standard Packed Format when N is even.\n\ * We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * conjugate-transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * conjugate-transpose of the last three columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- --\n\ * 03 04 05 33 43 53\n\ * -- --\n\ * 13 14 15 00 44 54\n\ * --\n\ * 23 24 25 10 11 55\n\ *\n\ * 33 34 35 20 21 22\n\ * --\n\ * 00 44 45 30 31 32\n\ * -- --\n\ * 01 11 55 40 41 42\n\ * -- -- --\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We next consider Standard Packed Format when N is odd.\n\ * We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * conjugate-transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * conjugate-transpose of the last two columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- --\n\ * 02 03 04 00 33 43\n\ * --\n\ * 12 13 14 10 11 44\n\ *\n\ * 22 23 24 20 21 22\n\ * --\n\ * 00 33 34 30 31 32\n\ * -- --\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- --\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlaic10000644000175000017500000000533412502223526016352 0ustar uwabamiuwabami--- :name: dlaic1 :md5sum: c5939e302aa2582a21e74047f303bb4a :category: :subroutine :arguments: - job: :type: integer :intent: input - j: :type: integer :intent: input - x: :type: doublereal :intent: input :dims: - j - sest: :type: doublereal :intent: input - w: :type: doublereal :intent: input :dims: - j - gamma: :type: doublereal :intent: input - sestpr: :type: doublereal :intent: output - s: :type: doublereal :intent: output - c: :type: doublereal :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAIC1 applies one step of incremental condition estimation in\n\ * its simplest version:\n\ *\n\ * Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j\n\ * lower triangular matrix L, such that\n\ * twonorm(L*x) = sest\n\ * Then DLAIC1 computes sestpr, s, c such that\n\ * the vector\n\ * [ s*x ]\n\ * xhat = [ c ]\n\ * is an approximate singular vector of\n\ * [ L 0 ]\n\ * Lhat = [ w' gamma ]\n\ * in the sense that\n\ * twonorm(Lhat*xhat) = sestpr.\n\ *\n\ * Depending on JOB, an estimate for the largest or smallest singular\n\ * value is computed.\n\ *\n\ * Note that [s c]' and sestpr**2 is an eigenpair of the system\n\ *\n\ * diag(sest*sest, 0) + [alpha gamma] * [ alpha ]\n\ * [ gamma ]\n\ *\n\ * where alpha = x'*w.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) INTEGER\n\ * = 1: an estimate for the largest singular value is computed.\n\ * = 2: an estimate for the smallest singular value is computed.\n\ *\n\ * J (input) INTEGER\n\ * Length of X and W\n\ *\n\ * X (input) DOUBLE PRECISION array, dimension (J)\n\ * The j-vector x.\n\ *\n\ * SEST (input) DOUBLE PRECISION\n\ * Estimated singular value of j by j matrix L\n\ *\n\ * W (input) DOUBLE PRECISION array, dimension (J)\n\ * The j-vector w.\n\ *\n\ * GAMMA (input) DOUBLE PRECISION\n\ * The diagonal element gamma.\n\ *\n\ * SESTPR (output) DOUBLE PRECISION\n\ * Estimated singular value of (j+1) by (j+1) matrix Lhat.\n\ *\n\ * S (output) DOUBLE PRECISION\n\ * Sine needed in forming xhat.\n\ *\n\ * C (output) DOUBLE PRECISION\n\ * Cosine needed in forming xhat.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlasd10000644000175000017500000001422512655767354016411 0ustar uwabamiuwabami--- :name: dlasd1 :md5sum: 4f6a6e622373feee99a1d18bb5f55bec :category: :subroutine :arguments: - nl: :type: integer :intent: input - nr: :type: integer :intent: input - sqre: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - alpha: :type: doublereal :intent: input/output - beta: :type: doublereal :intent: input/output - u: :type: doublereal :intent: input/output :dims: - ldu - n - ldu: :type: integer :intent: input - vt: :type: doublereal :intent: input/output :dims: - ldvt - m - ldvt: :type: integer :intent: input - idxq: :type: integer :intent: output :dims: - n - iwork: :type: integer :intent: workspace :dims: - 4 * n - work: :type: doublereal :intent: workspace :dims: - 3*pow(m,2) + 2*m - info: :type: integer :intent: output :substitutions: m: n + sqre n: nl+nr+1 :fortran_help: " SUBROUTINE DLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT, IDXQ, IWORK, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B,\n\ * where N = NL + NR + 1 and M = N + SQRE. DLASD1 is called from DLASD0.\n\ *\n\ * A related subroutine DLASD7 handles the case in which the singular\n\ * values (and the singular vectors in factored form) are desired.\n\ *\n\ * DLASD1 computes the SVD as follows:\n\ *\n\ * ( D1(in) 0 0 0 )\n\ * B = U(in) * ( Z1' a Z2' b ) * VT(in)\n\ * ( 0 0 D2(in) 0 )\n\ *\n\ * = U(out) * ( D(out) 0) * VT(out)\n\ *\n\ * where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M\n\ * with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros\n\ * elsewhere; and the entry b is empty if SQRE = 0.\n\ *\n\ * The left singular vectors of the original matrix are stored in U, and\n\ * the transpose of the right singular vectors are stored in VT, and the\n\ * singular values are in D. The algorithm consists of three stages:\n\ *\n\ * The first stage consists of deflating the size of the problem\n\ * when there are multiple singular values or when there are zeros in\n\ * the Z vector. For each such occurrence the dimension of the\n\ * secular equation problem is reduced by one. This stage is\n\ * performed by the routine DLASD2.\n\ *\n\ * The second stage consists of calculating the updated\n\ * singular values. This is done by finding the square roots of the\n\ * roots of the secular equation via the routine DLASD4 (as called\n\ * by DLASD3). This routine also calculates the singular vectors of\n\ * the current problem.\n\ *\n\ * The final stage consists of computing the updated singular vectors\n\ * directly using the updated singular values. The singular vectors\n\ * for the current problem are multiplied with the singular vectors\n\ * from the overall problem.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NL (input) INTEGER\n\ * The row dimension of the upper block. NL >= 1.\n\ *\n\ * NR (input) INTEGER\n\ * The row dimension of the lower block. NR >= 1.\n\ *\n\ * SQRE (input) INTEGER\n\ * = 0: the lower block is an NR-by-NR square matrix.\n\ * = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n\ *\n\ * The bidiagonal matrix has row dimension N = NL + NR + 1,\n\ * and column dimension M = N + SQRE.\n\ *\n\ * D (input/output) DOUBLE PRECISION array,\n\ * dimension (N = NL+NR+1).\n\ * On entry D(1:NL,1:NL) contains the singular values of the\n\ * upper block; and D(NL+2:N) contains the singular values of\n\ * the lower block. On exit D(1:N) contains the singular values\n\ * of the modified matrix.\n\ *\n\ * ALPHA (input/output) DOUBLE PRECISION\n\ * Contains the diagonal element associated with the added row.\n\ *\n\ * BETA (input/output) DOUBLE PRECISION\n\ * Contains the off-diagonal element associated with the added\n\ * row.\n\ *\n\ * U (input/output) DOUBLE PRECISION array, dimension(LDU,N)\n\ * On entry U(1:NL, 1:NL) contains the left singular vectors of\n\ * the upper block; U(NL+2:N, NL+2:N) contains the left singular\n\ * vectors of the lower block. On exit U contains the left\n\ * singular vectors of the bidiagonal matrix.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= max( 1, N ).\n\ *\n\ * VT (input/output) DOUBLE PRECISION array, dimension(LDVT,M)\n\ * where M = N + SQRE.\n\ * On entry VT(1:NL+1, 1:NL+1)' contains the right singular\n\ * vectors of the upper block; VT(NL+2:M, NL+2:M)' contains\n\ * the right singular vectors of the lower block. On exit\n\ * VT' contains the right singular vectors of the\n\ * bidiagonal matrix.\n\ *\n\ * LDVT (input) INTEGER\n\ * The leading dimension of the array VT. LDVT >= max( 1, M ).\n\ *\n\ * IDXQ (output) INTEGER array, dimension(N)\n\ * This contains the permutation which will reintegrate the\n\ * subproblem just solved back into sorted order, i.e.\n\ * D( IDXQ( I = 1, N ) ) will be in ascending order.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension( 4 * N )\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension( 3*M**2 + 2*M )\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 = 1, a singular value did not converge\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ming Gu and Huan Ren, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctbcon0000644000175000017500000000625112502223525016463 0ustar uwabamiuwabami--- :name: ctbcon :md5sum: 5d8bdcb99cde893c680cec51fda218c8 :category: :subroutine :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - rcond: :type: real :intent: output - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTBCON estimates the reciprocal of the condition number of a\n\ * triangular band matrix A, in either the 1-norm or the infinity-norm.\n\ *\n\ * The norm of A is computed and an estimate is obtained for\n\ * norm(inv(A)), then the reciprocal of the condition number is\n\ * computed as\n\ * RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies whether the 1-norm condition number or the\n\ * infinity-norm condition number is required:\n\ * = '1' or 'O': 1-norm;\n\ * = 'I': Infinity-norm.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals or subdiagonals of the\n\ * triangular band matrix A. KD >= 0.\n\ *\n\ * AB (input) COMPLEX array, dimension (LDAB,N)\n\ * The upper or lower triangular band matrix A, stored in the\n\ * first kd+1 rows of the array. The j-th column of A is stored\n\ * in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ * If DIAG = 'U', the diagonal elements of A are not referenced\n\ * and are assumed to be 1.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * RCOND (output) REAL\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(norm(A) * norm(inv(A))).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zla_herfsx_extended0000644000175000017500000003524212502223526021243 0ustar uwabamiuwabami--- :name: zla_herfsx_extended :md5sum: 99391e842a46fddd9ee369da7d076db8 :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - colequ: :type: logical :intent: input - c: :type: doublereal :intent: input :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: doublecomplex :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: doublereal :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: input/output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: input/output :dims: - nrhs - n_err_bnds - res: :type: doublecomplex :intent: input :dims: - n - ayb: :type: doublereal :intent: input :dims: - n - dy: :type: doublecomplex :intent: input :dims: - n - y_tail: :type: doublecomplex :intent: input :dims: - n - rcond: :type: doublereal :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: doublereal :intent: input - dz_ub: :type: doublereal :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZLA_HERFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLA_HERFSX_EXTENDED improves the computed solution to a system of\n\ * linear equations by performing extra-precise iterative refinement\n\ * and provides error bounds and backward error estimates for the solution.\n\ * This subroutine is called by ZHERFSX to perform iterative refinement.\n\ * In addition to normwise error bound, the code provides maximum\n\ * componentwise error bound if possible. See comments for ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP for details of the error bounds. Note that this\n\ * subroutine is only resonsible for setting the second fields of\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * PREC_TYPE (input) INTEGER\n\ * Specifies the intermediate precision to be used in refinement.\n\ * The value is defined by ILAPREC(P) where P is a CHARACTER and\n\ * P = 'S': Single\n\ * = 'D': Double\n\ * = 'I': Indigenous\n\ * = 'X', 'E': Extra\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right-hand-sides, i.e., the number of columns of the\n\ * matrix B.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX*16 array, dimension (LDAF,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by ZHETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by ZHETRF.\n\ *\n\ * COLEQU (input) LOGICAL\n\ * If .TRUE. then column equilibration was done to A before calling\n\ * this routine. This is needed to compute the solution and error\n\ * bounds correctly.\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension (N)\n\ * The column scale factors for A. If COLEQU = .FALSE., C\n\ * is not accessed. If C is input, each element of C should be a power\n\ * of the radix to ensure a reliable solution and error estimates.\n\ * Scaling by powers of the radix does not cause rounding errors unless\n\ * the result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The right-hand-side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * Y (input/output) COMPLEX*16 array, dimension\n\ * (LDY,NRHS)\n\ * On entry, the solution matrix X, as computed by ZHETRS.\n\ * On exit, the improved solution matrix Y.\n\ *\n\ * LDY (input) INTEGER\n\ * The leading dimension of the array Y. LDY >= max(1,N).\n\ *\n\ * BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * On exit, BERR_OUT(j) contains the componentwise relative backward\n\ * error for right-hand-side j from the formula\n\ * max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n\ * where abs(Z) is the componentwise absolute value of the matrix\n\ * or vector Z. This is computed by ZLA_LIN_BERR.\n\ *\n\ * N_NORMS (input) INTEGER\n\ * Determines which error bounds to return (see ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP).\n\ * If N_NORMS >= 1 return normwise error bounds.\n\ * If N_NORMS >= 2 return componentwise error bounds.\n\ *\n\ * ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension\n\ * (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension\n\ * (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * RES (input) COMPLEX*16 array, dimension (N)\n\ * Workspace to hold the intermediate residual.\n\ *\n\ * AYB (input) DOUBLE PRECISION array, dimension (N)\n\ * Workspace.\n\ *\n\ * DY (input) COMPLEX*16 array, dimension (N)\n\ * Workspace to hold the intermediate solution.\n\ *\n\ * Y_TAIL (input) COMPLEX*16 array, dimension (N)\n\ * Workspace to hold the trailing bits of the intermediate solution.\n\ *\n\ * RCOND (input) DOUBLE PRECISION\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * ITHRESH (input) INTEGER\n\ * The maximum number of residual computations allowed for\n\ * refinement. The default is 10. For 'aggressive' set to 100 to\n\ * permit convergence using approximate factorizations or\n\ * factorizations other than LU. If the factorization uses a\n\ * technique other than Gaussian elimination, the guarantees in\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n\ *\n\ * RTHRESH (input) DOUBLE PRECISION\n\ * Determines when to stop refinement if the error estimate stops\n\ * decreasing. Refinement will stop when the next solution no longer\n\ * satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n\ * the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n\ * default value is 0.5. For 'aggressive' set to 0.9 to permit\n\ * convergence on extremely ill-conditioned matrices. See LAWN 165\n\ * for more details.\n\ *\n\ * DZ_UB (input) DOUBLE PRECISION\n\ * Determines when to start considering componentwise convergence.\n\ * Componentwise convergence is only considered after each component\n\ * of the solution Y is stable, which we definte as the relative\n\ * change in each component being less than DZ_UB. The default value\n\ * is 0.25, requiring the first bit to be stable. See LAWN 165 for\n\ * more details.\n\ *\n\ * IGNORE_CWISE (input) LOGICAL\n\ * If .TRUE. then ignore componentwise convergence. Default value\n\ * is .FALSE..\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * < 0: if INFO = -i, the ith argument to ZHETRS had an illegal\n\ * value\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE,\n $ Y_PREC_STATE\n DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n COMPLEX*16 ZDUM\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cung2r0000644000175000017500000000443012502223526016411 0ustar uwabamiuwabami--- :name: cung2r :md5sum: fb8fb5bf1556d2bed7db5cf3c96185c5 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - work: :type: complex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CUNG2R generates an m by n complex matrix Q with orthonormal columns,\n\ * which is defined as the first n columns of a product of k elementary\n\ * reflectors of order m\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by CGEQRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. M >= N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. N >= K >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the i-th column must contain the vector which\n\ * defines the elementary reflector H(i), for i = 1,2,...,k, as\n\ * returned by CGEQRF in the first k columns of its array\n\ * argument A.\n\ * On exit, the m by n matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) COMPLEX array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by CGEQRF.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlacrt0000644000175000017500000000361312502223526016512 0ustar uwabamiuwabami--- :name: zlacrt :md5sum: 604f79f577cce40b1cf8d8abaa65ee99 :category: :subroutine :arguments: - n: :type: integer :intent: input - cx: :type: doublecomplex :intent: input/output :dims: - n - incx: :type: integer :intent: input - cy: :type: doublecomplex :intent: input/output :dims: - n - incy: :type: integer :intent: input - c: :type: doublecomplex :intent: input - s: :type: doublecomplex :intent: input :substitutions: {} :fortran_help: " SUBROUTINE ZLACRT( N, CX, INCX, CY, INCY, C, S )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLACRT performs the operation\n\ *\n\ * ( c s )( x ) ==> ( x )\n\ * ( -s c )( y ) ( y )\n\ *\n\ * where c and s are complex and the vectors x and y are complex.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of elements in the vectors CX and CY.\n\ *\n\ * CX (input/output) COMPLEX*16 array, dimension (N)\n\ * On input, the vector x.\n\ * On output, CX is overwritten with c*x + s*y.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between successive values of CX. INCX <> 0.\n\ *\n\ * CY (input/output) COMPLEX*16 array, dimension (N)\n\ * On input, the vector y.\n\ * On output, CY is overwritten with -s*x + c*y.\n\ *\n\ * INCY (input) INTEGER\n\ * The increment between successive values of CY. INCY <> 0.\n\ *\n\ * C (input) COMPLEX*16\n\ * S (input) COMPLEX*16\n\ * C and S define the matrix\n\ * [ C S ].\n\ * [ -S C ]\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, IX, IY\n COMPLEX*16 CTEMP\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zunml20000644000175000017500000000736012502223526016445 0ustar uwabamiuwabami--- :name: zunml2 :md5sum: e27ef006d74c26f3884a48ee719ffdda :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZUNML2 overwrites the general complex m-by-n matrix C with\n\ *\n\ * Q * C if SIDE = 'L' and TRANS = 'N', or\n\ *\n\ * Q'* C if SIDE = 'L' and TRANS = 'C', or\n\ *\n\ * C * Q if SIDE = 'R' and TRANS = 'N', or\n\ *\n\ * C * Q' if SIDE = 'R' and TRANS = 'C',\n\ *\n\ * where Q is a complex unitary matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(k)' . . . H(2)' H(1)'\n\ *\n\ * as returned by ZGELQF. Q is of order m if SIDE = 'L' and of order n\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q' from the Left\n\ * = 'R': apply Q or Q' from the Right\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': apply Q (No transpose)\n\ * = 'C': apply Q' (Conjugate transpose)\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension\n\ * (LDA,M) if SIDE = 'L',\n\ * (LDA,N) if SIDE = 'R'\n\ * The i-th row must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * ZGELQF in the first k rows of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,K).\n\ *\n\ * TAU (input) COMPLEX*16 array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by ZGELQF.\n\ *\n\ * C (input/output) COMPLEX*16 array, dimension (LDC,N)\n\ * On entry, the m-by-n matrix C.\n\ * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension\n\ * (N) if SIDE = 'L',\n\ * (M) if SIDE = 'R'\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlag20000644000175000017500000001122212655767354016224 0ustar uwabamiuwabami--- :name: dlag2 :md5sum: cb3cffe0121d3cdef959429272b11c8d :category: :subroutine :arguments: - a: :type: doublereal :intent: input :dims: - lda - "2" - lda: :type: integer :intent: input - b: :type: doublereal :intent: input :dims: - ldb - "2" - ldb: :type: integer :intent: input - safmin: :type: doublereal :intent: input - scale1: :type: doublereal :intent: output - scale2: :type: doublereal :intent: output - wr1: :type: doublereal :intent: output - wr2: :type: doublereal :intent: output - wi: :type: doublereal :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, WR2, WI )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue\n\ * problem A - w B, with scaling as necessary to avoid over-/underflow.\n\ *\n\ * The scaling factor \"s\" results in a modified eigenvalue equation\n\ *\n\ * s A - w B\n\ *\n\ * where s is a non-negative scaling factor chosen so that w, w B,\n\ * and s A do not overflow and, if possible, do not underflow, either.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA, 2)\n\ * On entry, the 2 x 2 matrix A. It is assumed that its 1-norm\n\ * is less than 1/SAFMIN. Entries less than\n\ * sqrt(SAFMIN)*norm(A) are subject to being treated as zero.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= 2.\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB, 2)\n\ * On entry, the 2 x 2 upper triangular matrix B. It is\n\ * assumed that the one-norm of B is less than 1/SAFMIN. The\n\ * diagonals should be at least sqrt(SAFMIN) times the largest\n\ * element of B (in absolute value); if a diagonal is smaller\n\ * than that, then +/- sqrt(SAFMIN) will be used instead of\n\ * that diagonal.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= 2.\n\ *\n\ * SAFMIN (input) DOUBLE PRECISION\n\ * The smallest positive number s.t. 1/SAFMIN does not\n\ * overflow. (This should always be DLAMCH('S') -- it is an\n\ * argument in order to avoid having to call DLAMCH frequently.)\n\ *\n\ * SCALE1 (output) DOUBLE PRECISION\n\ * A scaling factor used to avoid over-/underflow in the\n\ * eigenvalue equation which defines the first eigenvalue. If\n\ * the eigenvalues are complex, then the eigenvalues are\n\ * ( WR1 +/- WI i ) / SCALE1 (which may lie outside the\n\ * exponent range of the machine), SCALE1=SCALE2, and SCALE1\n\ * will always be positive. If the eigenvalues are real, then\n\ * the first (real) eigenvalue is WR1 / SCALE1 , but this may\n\ * overflow or underflow, and in fact, SCALE1 may be zero or\n\ * less than the underflow threshold if the exact eigenvalue\n\ * is sufficiently large.\n\ *\n\ * SCALE2 (output) DOUBLE PRECISION\n\ * A scaling factor used to avoid over-/underflow in the\n\ * eigenvalue equation which defines the second eigenvalue. If\n\ * the eigenvalues are complex, then SCALE2=SCALE1. If the\n\ * eigenvalues are real, then the second (real) eigenvalue is\n\ * WR2 / SCALE2 , but this may overflow or underflow, and in\n\ * fact, SCALE2 may be zero or less than the underflow\n\ * threshold if the exact eigenvalue is sufficiently large.\n\ *\n\ * WR1 (output) DOUBLE PRECISION\n\ * If the eigenvalue is real, then WR1 is SCALE1 times the\n\ * eigenvalue closest to the (2,2) element of A B**(-1). If the\n\ * eigenvalue is complex, then WR1=WR2 is SCALE1 times the real\n\ * part of the eigenvalues.\n\ *\n\ * WR2 (output) DOUBLE PRECISION\n\ * If the eigenvalue is real, then WR2 is SCALE2 times the\n\ * other eigenvalue. If the eigenvalue is complex, then\n\ * WR1=WR2 is SCALE1 times the real part of the eigenvalues.\n\ *\n\ * WI (output) DOUBLE PRECISION\n\ * If the eigenvalue is real, then WI is zero. If the\n\ * eigenvalue is complex, then WI is SCALE1 times the imaginary\n\ * part of the eigenvalues. WI will always be non-negative.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slarfgp0000644000175000017500000000353512502223526016654 0ustar uwabamiuwabami--- :name: slarfgp :md5sum: b62217a99e255413ad1162ce4db07fd0 :category: :subroutine :arguments: - n: :type: integer :intent: input - alpha: :type: real :intent: input/output - x: :type: real :intent: input/output :dims: - 1+(n-2)*abs(incx) - incx: :type: integer :intent: input - tau: :type: real :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLARFGP( N, ALPHA, X, INCX, TAU )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLARFGP generates a real elementary reflector H of order n, such\n\ * that\n\ *\n\ * H * ( alpha ) = ( beta ), H' * H = I.\n\ * ( x ) ( 0 )\n\ *\n\ * where alpha and beta are scalars, beta is non-negative, and x is\n\ * an (n-1)-element real vector. H is represented in the form\n\ *\n\ * H = I - tau * ( 1 ) * ( 1 v' ) ,\n\ * ( v )\n\ *\n\ * where tau is a real scalar and v is a real (n-1)-element\n\ * vector.\n\ *\n\ * If the elements of x are all zero, then tau = 0 and H is taken to be\n\ * the unit matrix.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the elementary reflector.\n\ *\n\ * ALPHA (input/output) REAL\n\ * On entry, the value alpha.\n\ * On exit, it is overwritten with the value beta.\n\ *\n\ * X (input/output) REAL array, dimension\n\ * (1+(N-2)*abs(INCX))\n\ * On entry, the vector x.\n\ * On exit, it is overwritten with the vector v.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between elements of X. INCX > 0.\n\ *\n\ * TAU (output) REAL\n\ * The value tau.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgtts20000644000175000017500000000570012502223526016440 0ustar uwabamiuwabami--- :name: sgtts2 :md5sum: cea36b0cbb0bba04fe5ed67e019b34c7 :category: :subroutine :arguments: - itrans: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: real :intent: input :dims: - n-1 - d: :type: real :intent: input :dims: - n - du: :type: real :intent: input :dims: - n-1 - du2: :type: real :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE SGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGTTS2 solves one of the systems of equations\n\ * A*X = B or A'*X = B,\n\ * with a tridiagonal matrix A using the LU factorization computed\n\ * by SGTTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITRANS (input) INTEGER\n\ * Specifies the form of the system of equations.\n\ * = 0: A * X = B (No transpose)\n\ * = 1: A'* X = B (Transpose)\n\ * = 2: A'* X = B (Conjugate transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * DL (input) REAL array, dimension (N-1)\n\ * The (n-1) multipliers that define the matrix L from the\n\ * LU factorization of A.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The n diagonal elements of the upper triangular matrix U from\n\ * the LU factorization of A.\n\ *\n\ * DU (input) REAL array, dimension (N-1)\n\ * The (n-1) elements of the first super-diagonal of U.\n\ *\n\ * DU2 (input) REAL array, dimension (N-2)\n\ * The (n-2) elements of the second super-diagonal of U.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices; for 1 <= i <= n, row i of the matrix was\n\ * interchanged with row IPIV(i). IPIV(i) will always be either\n\ * i or i+1; IPIV(i) = i indicates a row interchange was not\n\ * required.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the matrix of right hand side vectors B.\n\ * On exit, B is overwritten by the solution vectors X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, IP, J\n REAL TEMP\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cptsvx0000644000175000017500000001645112502223525016545 0ustar uwabamiuwabami--- :name: cptsvx :md5sum: a5c06f21616bb02edc1995a65814fd71 :category: :subroutine :arguments: - fact: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: complex :intent: input :dims: - n-1 - df: :type: real :intent: input/output :dims: - n - ef: :type: complex :intent: input/output :dims: - n-1 - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE CPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPTSVX uses the factorization A = L*D*L**H to compute the solution\n\ * to a complex system of linear equations A*X = B, where A is an\n\ * N-by-N Hermitian positive definite tridiagonal matrix and X and B\n\ * are N-by-NRHS matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'N', the matrix A is factored as A = L*D*L**H, where L\n\ * is a unit lower bidiagonal matrix and D is diagonal. The\n\ * factorization can also be regarded as having the form\n\ * A = U**H*D*U.\n\ *\n\ * 2. If the leading i-by-i principal minor is not positive definite,\n\ * then the routine returns with INFO = i. Otherwise, the factored\n\ * form of A is used to estimate the condition number of the matrix\n\ * A. If the reciprocal of the condition number is less than machine\n\ * precision, INFO = N+1 is returned as a warning, but the routine\n\ * still goes on to solve for X and compute error bounds as\n\ * described below.\n\ *\n\ * 3. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 4. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix\n\ * A is supplied on entry.\n\ * = 'F': On entry, DF and EF contain the factored form of A.\n\ * D, E, DF, and EF will not be modified.\n\ * = 'N': The matrix A will be copied to DF and EF and\n\ * factored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The n diagonal elements of the tridiagonal matrix A.\n\ *\n\ * E (input) COMPLEX array, dimension (N-1)\n\ * The (n-1) subdiagonal elements of the tridiagonal matrix A.\n\ *\n\ * DF (input or output) REAL array, dimension (N)\n\ * If FACT = 'F', then DF is an input argument and on entry\n\ * contains the n diagonal elements of the diagonal matrix D\n\ * from the L*D*L**H factorization of A.\n\ * If FACT = 'N', then DF is an output argument and on exit\n\ * contains the n diagonal elements of the diagonal matrix D\n\ * from the L*D*L**H factorization of A.\n\ *\n\ * EF (input or output) COMPLEX array, dimension (N-1)\n\ * If FACT = 'F', then EF is an input argument and on entry\n\ * contains the (n-1) subdiagonal elements of the unit\n\ * bidiagonal factor L from the L*D*L**H factorization of A.\n\ * If FACT = 'N', then EF is an output argument and on exit\n\ * contains the (n-1) subdiagonal elements of the unit\n\ * bidiagonal factor L from the L*D*L**H factorization of A.\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,NRHS)\n\ * The N-by-NRHS right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * The reciprocal condition number of the matrix A. If RCOND\n\ * is less than the machine precision (in particular, if\n\ * RCOND = 0), the matrix is singular to working precision.\n\ * This condition is indicated by a return code of INFO > 0.\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j).\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in any\n\ * element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\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, and i is\n\ * <= N: the leading minor of order i of A is\n\ * not positive definite, so the factorization\n\ * could not be completed, and the solution has not\n\ * been computed. RCOND = 0 is returned.\n\ * = N+1: U is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgeesx0000644000175000017500000002354712502223526016521 0ustar uwabamiuwabami--- :name: sgeesx :md5sum: 64fcd2b5803aefdf7af907e57f81fd53 :category: :subroutine :arguments: - jobvs: :type: char :intent: input - sort: :type: char :intent: input - select: :intent: external procedure :block_type: logical :block_arg_num: 2 :block_arg_type: real - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - sdim: :type: integer :intent: output - wr: :type: real :intent: output :dims: - n - wi: :type: real :intent: output :dims: - n - vs: :type: real :intent: output :dims: - ldvs - n - ldvs: :type: integer :intent: input - rconde: :type: real :intent: output - rcondv: :type: real :intent: output - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(lsame_(&sense,\"E\")||lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? n+n*n/2 : 3*n" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvs: "lsame_(&jobvs,\"V\") ? n : 1" :fortran_help: " SUBROUTINE SGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, IWORK, LIWORK, BWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGEESX computes for an N-by-N real nonsymmetric matrix A, the\n\ * eigenvalues, the real Schur form T, and, optionally, the matrix of\n\ * Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).\n\ *\n\ * Optionally, it also orders the eigenvalues on the diagonal of the\n\ * real Schur form so that selected eigenvalues are at the top left;\n\ * computes a reciprocal condition number for the average of the\n\ * selected eigenvalues (RCONDE); and computes a reciprocal condition\n\ * number for the right invariant subspace corresponding to the\n\ * selected eigenvalues (RCONDV). The leading columns of Z form an\n\ * orthonormal basis for this invariant subspace.\n\ *\n\ * For further explanation of the reciprocal condition numbers RCONDE\n\ * and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where\n\ * these quantities are called s and sep respectively).\n\ *\n\ * A real matrix is in real Schur form if it is upper quasi-triangular\n\ * with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in\n\ * the form\n\ * [ a b ]\n\ * [ c a ]\n\ *\n\ * where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVS (input) CHARACTER*1\n\ * = 'N': Schur vectors are not computed;\n\ * = 'V': Schur vectors are computed.\n\ *\n\ * SORT (input) CHARACTER*1\n\ * Specifies whether or not to order the eigenvalues on the\n\ * diagonal of the Schur form.\n\ * = 'N': Eigenvalues are not ordered;\n\ * = 'S': Eigenvalues are ordered (see SELECT).\n\ *\n\ * SELECT (external procedure) LOGICAL FUNCTION of two REAL arguments\n\ * SELECT must be declared EXTERNAL in the calling subroutine.\n\ * If SORT = 'S', SELECT is used to select eigenvalues to sort\n\ * to the top left of the Schur form.\n\ * If SORT = 'N', SELECT is not referenced.\n\ * An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if\n\ * SELECT(WR(j),WI(j)) is true; i.e., if either one of a\n\ * complex conjugate pair of eigenvalues is selected, then both\n\ * are. Note that a selected complex eigenvalue may no longer\n\ * satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since\n\ * ordering may change the value of complex eigenvalues\n\ * (especially if the eigenvalue is ill-conditioned); in this\n\ * case INFO may be set to N+3 (see INFO below).\n\ *\n\ * SENSE (input) CHARACTER*1\n\ * Determines which reciprocal condition numbers are computed.\n\ * = 'N': None are computed;\n\ * = 'E': Computed for average of selected eigenvalues only;\n\ * = 'V': Computed for selected right invariant subspace only;\n\ * = 'B': Computed for both.\n\ * If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA, N)\n\ * On entry, the N-by-N matrix A.\n\ * On exit, A is overwritten by its real Schur form T.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * SDIM (output) INTEGER\n\ * If SORT = 'N', SDIM = 0.\n\ * If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n\ * for which SELECT is true. (Complex conjugate\n\ * pairs for which SELECT is true for either\n\ * eigenvalue count as 2.)\n\ *\n\ * WR (output) REAL array, dimension (N)\n\ * WI (output) REAL array, dimension (N)\n\ * WR and WI contain the real and imaginary parts, respectively,\n\ * of the computed eigenvalues, in the same order that they\n\ * appear on the diagonal of the output Schur form T. Complex\n\ * conjugate pairs of eigenvalues appear consecutively with the\n\ * eigenvalue having the positive imaginary part first.\n\ *\n\ * VS (output) REAL array, dimension (LDVS,N)\n\ * If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur\n\ * vectors.\n\ * If JOBVS = 'N', VS is not referenced.\n\ *\n\ * LDVS (input) INTEGER\n\ * The leading dimension of the array VS. LDVS >= 1, and if\n\ * JOBVS = 'V', LDVS >= N.\n\ *\n\ * RCONDE (output) REAL\n\ * If SENSE = 'E' or 'B', RCONDE contains the reciprocal\n\ * condition number for the average of the selected eigenvalues.\n\ * Not referenced if SENSE = 'N' or 'V'.\n\ *\n\ * RCONDV (output) REAL\n\ * If SENSE = 'V' or 'B', RCONDV contains the reciprocal\n\ * condition number for the selected right invariant subspace.\n\ * Not referenced if SENSE = 'N' or 'E'.\n\ *\n\ * WORK (workspace/output) REAL 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,3*N).\n\ * Also, if SENSE = 'E' or 'V' or 'B',\n\ * LWORK >= N+2*SDIM*(N-SDIM), where SDIM is the number of\n\ * selected eigenvalues computed by this routine. Note that\n\ * N+2*SDIM*(N-SDIM) <= N+N*N/2. Note also that an error is only\n\ * returned if LWORK < max(1,3*N), but if SENSE = 'E' or 'V' or\n\ * 'B' this may not be large enough.\n\ * For good performance, LWORK must generally be larger.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates upper bounds on the optimal sizes of the\n\ * arrays WORK and IWORK, returns these values as the first\n\ * entries of the WORK and IWORK arrays, and no error messages\n\ * related to LWORK or LIWORK are issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK.\n\ * LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM).\n\ * Note that SDIM*(N-SDIM) <= N*N/4. Note also that an error is\n\ * only returned if LIWORK < 1, but if SENSE = 'V' or 'B' this\n\ * may not be large enough.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates upper bounds on the optimal sizes of\n\ * the arrays WORK and IWORK, returns these values as the first\n\ * entries of the WORK and IWORK arrays, and no error messages\n\ * related to LWORK or LIWORK are issued by XERBLA.\n\ *\n\ * BWORK (workspace) LOGICAL array, dimension (N)\n\ * Not referenced if SORT = 'N'.\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, and i is\n\ * <= N: the QR algorithm failed to compute all the\n\ * eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI\n\ * contain those eigenvalues which have converged; if\n\ * JOBVS = 'V', VS contains the transformation which\n\ * reduces A to its partially converged Schur form.\n\ * = N+1: the eigenvalues could not be reordered because some\n\ * eigenvalues were too close to separate (the problem\n\ * is very ill-conditioned);\n\ * = N+2: after reordering, roundoff changed values of some\n\ * complex eigenvalues so that leading eigenvalues in\n\ * the Schur form no longer satisfy SELECT=.TRUE. This\n\ * could also be caused by underflow due to scaling.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zpftrf0000644000175000017500000001570512502223526016533 0ustar uwabamiuwabami--- :name: zpftrf :md5sum: 61ddc3c3f976621b0f6d627166ae8a57 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPFTRF( TRANSR, UPLO, N, A, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPFTRF computes the Cholesky factorization of a complex Hermitian\n\ * positive definite matrix A.\n\ *\n\ * The factorization has the form\n\ * A = U**H * U, if UPLO = 'U', or\n\ * A = L * L**H, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is lower triangular.\n\ *\n\ * This is the block version of the algorithm, calling Level 3 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': The Normal TRANSR of RFP A is stored;\n\ * = 'C': The Conjugate-transpose TRANSR of RFP A is stored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of RFP A is stored;\n\ * = 'L': Lower triangle of RFP A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension ( N*(N+1)/2 );\n\ * On entry, the Hermitian matrix A in RFP format. RFP format is\n\ * described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n\ * then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n\ * (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is\n\ * the Conjugate-transpose of RFP A as defined when\n\ * TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n\ * follows: If UPLO = 'U' the RFP A contains the nt elements of\n\ * upper packed A. If UPLO = 'L' the RFP A contains the elements\n\ * of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n\ * 'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n\ * is odd. See the Note below for more details.\n\ *\n\ * On exit, if INFO = 0, the factor U or L from the Cholesky\n\ * factorization RFP A = U**H*U or RFP A = L*L**H.\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 leading minor of order i is not\n\ * positive definite, and the factorization could not be\n\ * completed.\n\ *\n\ * Further Notes on RFP Format:\n\ * ============================\n\ *\n\ * We first consider Standard Packed Format when N is even.\n\ * We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * conjugate-transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * conjugate-transpose of the last three columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- --\n\ * 03 04 05 33 43 53\n\ * -- --\n\ * 13 14 15 00 44 54\n\ * --\n\ * 23 24 25 10 11 55\n\ *\n\ * 33 34 35 20 21 22\n\ * --\n\ * 00 44 45 30 31 32\n\ * -- --\n\ * 01 11 55 40 41 42\n\ * -- -- --\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We next consider Standard Packed Format when N is odd.\n\ * We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * conjugate-transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * conjugate-transpose of the last two columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- --\n\ * 02 03 04 00 33 43\n\ * --\n\ * 12 13 14 10 11 44\n\ *\n\ * 22 23 24 20 21 22\n\ * --\n\ * 00 33 34 30 31 32\n\ * -- --\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- --\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/spbtrf0000644000175000017500000000674112502223526016520 0ustar uwabamiuwabami--- :name: spbtrf :md5sum: d8a847b41ef3b56bb1ee6cfc241034bd :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPBTRF( UPLO, N, KD, AB, LDAB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPBTRF computes the Cholesky factorization of a real symmetric\n\ * positive definite band matrix A.\n\ *\n\ * The factorization has the form\n\ * A = U**T * U, if UPLO = 'U', or\n\ * A = L * L**T, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is lower triangular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) REAL array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * On exit, if INFO = 0, the triangular factor U or L from the\n\ * Cholesky factorization A = U**T*U or A = L*L**T of the band\n\ * matrix A, in the same storage format as A.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\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 leading minor of order i is not\n\ * positive definite, and the factorization could not be\n\ * completed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * N = 6, KD = 2, and UPLO = 'U':\n\ *\n\ * On entry: On exit:\n\ *\n\ * * * a13 a24 a35 a46 * * u13 u24 u35 u46\n\ * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n\ * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n\ *\n\ * Similarly, if UPLO = 'L' the format of A is as follows:\n\ *\n\ * On entry: On exit:\n\ *\n\ * a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n\ * a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n\ * a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n\ *\n\ * Array elements marked * are not used by the routine.\n\ *\n\ * Contributed by\n\ * Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clanhs0000644000175000017500000000452612502223525016466 0ustar uwabamiuwabami--- :name: clanhs :md5sum: 7cf1a1d1a95e15c62f33d712a3f376be :category: :function :type: real :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? n : 0" :fortran_help: " REAL FUNCTION CLANHS( NORM, N, A, LDA, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLANHS returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * Hessenberg matrix A.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * CLANHS returns the value\n\ *\n\ * CLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in CLANHS as described\n\ * above.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, CLANHS is\n\ * set to zero.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The n by n upper Hessenberg matrix A; the part of A below the\n\ * first sub-diagonal is not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(N,1).\n\ *\n\ * WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n\ * referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgbsv0000644000175000017500000001150312502223526016343 0ustar uwabamiuwabami--- :name: zgbsv :md5sum: ae5d9df6f8b2826acd8be07569b5c355 :category: :subroutine :arguments: - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGBSV computes the solution to a complex system of linear equations\n\ * A * X = B, where A is a band matrix of order N with KL subdiagonals\n\ * and KU superdiagonals, and X and B are N-by-NRHS matrices.\n\ *\n\ * The LU decomposition with partial pivoting and row interchanges is\n\ * used to factor A as A = L * U, where L is a product of permutation\n\ * and unit lower triangular matrices with KL subdiagonals, and U is\n\ * upper triangular with KL+KU superdiagonals. The factored form of A\n\ * is then used to solve the system of equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows KL+1 to\n\ * 2*KL+KU+1; rows 1 to KL of the array need not be set.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)\n\ * On exit, details of the factorization: U is stored as an\n\ * upper triangular band matrix with KL+KU superdiagonals in\n\ * rows 1 to KL+KU+1, and the multipliers used during the\n\ * factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n\ * See below for further details.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * The pivot indices that define the permutation matrix P;\n\ * row i of the matrix was interchanged with row IPIV(i).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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, U(i,i) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, and the solution has not been computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * M = N = 6, KL = 2, KU = 1:\n\ *\n\ * On entry: On exit:\n\ *\n\ * * * * + + + * * * u14 u25 u36\n\ * * * + + + + * * u13 u24 u35 u46\n\ * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n\ * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n\ * a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n\ * a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n\ *\n\ * Array elements marked * are not used by the routine; elements marked\n\ * + need not be set on entry, but are required by the routine to store\n\ * elements of U because of fill-in resulting from the row interchanges.\n\ *\n\ * =====================================================================\n\ *\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZGBTRF, ZGBTRS\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlanv20000644000175000017500000000465412502223526016407 0ustar uwabamiuwabami--- :name: dlanv2 :md5sum: c7c0b03a8957e1ba328eea9560c78752 :category: :subroutine :arguments: - a: :type: doublereal :intent: input/output - b: :type: doublereal :intent: input/output - c: :type: doublereal :intent: input/output - d: :type: doublereal :intent: input/output - rt1r: :type: doublereal :intent: output - rt1i: :type: doublereal :intent: output - rt2r: :type: doublereal :intent: output - rt2i: :type: doublereal :intent: output - cs: :type: doublereal :intent: output - sn: :type: doublereal :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric\n\ * matrix in standard form:\n\ *\n\ * [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ]\n\ * [ C D ] [ SN CS ] [ CC DD ] [-SN CS ]\n\ *\n\ * where either\n\ * 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or\n\ * 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex\n\ * conjugate eigenvalues.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * A (input/output) DOUBLE PRECISION\n\ * B (input/output) DOUBLE PRECISION\n\ * C (input/output) DOUBLE PRECISION\n\ * D (input/output) DOUBLE PRECISION\n\ * On entry, the elements of the input matrix.\n\ * On exit, they are overwritten by the elements of the\n\ * standardised Schur form.\n\ *\n\ * RT1R (output) DOUBLE PRECISION\n\ * RT1I (output) DOUBLE PRECISION\n\ * RT2R (output) DOUBLE PRECISION\n\ * RT2I (output) DOUBLE PRECISION\n\ * The real and imaginary parts of the eigenvalues. If the\n\ * eigenvalues are a complex conjugate pair, RT1I > 0.\n\ *\n\ * CS (output) DOUBLE PRECISION\n\ * SN (output) DOUBLE PRECISION\n\ * Parameters of the rotation matrix.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Modified by V. Sima, Research Institute for Informatics, Bucharest,\n\ * Romania, to reduce the risk of cancellation errors,\n\ * when computing real eigenvalues, and to ensure, if possible, that\n\ * abs(RT1R) >= abs(RT2R).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cunmrz0000644000175000017500000001144612502223526016534 0ustar uwabamiuwabami--- :name: cunmrz :md5sum: 78c9a267970adfd685ebe4eeafc6e1ec :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CUNMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CUNMRZ overwrites the general complex M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'C': Q**H * C C * Q**H\n\ *\n\ * where Q is a complex unitary matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by CTZRZF. Q is of order M if SIDE = 'L' and of order N\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**H from the Left;\n\ * = 'R': apply Q or Q**H from the Right.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q;\n\ * = 'C': Conjugate transpose, apply Q**H.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * L (input) INTEGER\n\ * The number of columns of the matrix A containing\n\ * the meaningful part of the Householder reflectors.\n\ * If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension\n\ * (LDA,M) if SIDE = 'L',\n\ * (LDA,N) if SIDE = 'R'\n\ * The i-th row must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * CTZRZF in the last k rows of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,K).\n\ *\n\ * TAU (input) COMPLEX array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by CTZRZF.\n\ *\n\ * C (input/output) COMPLEX array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace/output) COMPLEX 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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M).\n\ * For optimum performance LWORK >= N*NB if SIDE = 'L', and\n\ * LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n\ * 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\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgtcon0000644000175000017500000000674212502223526016477 0ustar uwabamiuwabami--- :name: dgtcon :md5sum: 33c789ced03959494b2d8ea9a37671e7 :category: :subroutine :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - dl: :type: doublereal :intent: input :dims: - n-1 - d: :type: doublereal :intent: input :dims: - n - du: :type: doublereal :intent: input :dims: - n-1 - du2: :type: doublereal :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 2*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGTCON estimates the reciprocal of the condition number of a real\n\ * tridiagonal matrix A using the LU factorization as computed by\n\ * DGTTRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies whether the 1-norm condition number or the\n\ * infinity-norm condition number is required:\n\ * = '1' or 'O': 1-norm;\n\ * = 'I': Infinity-norm.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * DL (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) multipliers that define the matrix L from the\n\ * LU factorization of A as computed by DGTTRF.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The n diagonal elements of the upper triangular matrix U from\n\ * the LU factorization of A.\n\ *\n\ * DU (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) elements of the first superdiagonal of U.\n\ *\n\ * DU2 (input) DOUBLE PRECISION array, dimension (N-2)\n\ * The (n-2) elements of the second superdiagonal of U.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices; for 1 <= i <= n, row i of the matrix was\n\ * interchanged with row IPIV(i). IPIV(i) will always be either\n\ * i or i+1; IPIV(i) = i indicates a row interchange was not\n\ * required.\n\ *\n\ * ANORM (input) DOUBLE PRECISION\n\ * If NORM = '1' or 'O', the 1-norm of the original matrix A.\n\ * If NORM = 'I', the infinity-norm of the original matrix A.\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n\ * estimate of the 1-norm of inv(A) computed in this routine.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/csytri2x0000644000175000017500000000527312502223525017005 0ustar uwabamiuwabami--- :name: csytri2x :md5sum: a3d45c60190155762686eac6e370ef80 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: complex :intent: workspace :dims: - n+nb+1 - nb+3 - nb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSYTRI2X computes the inverse of a real symmetric indefinite matrix\n\ * A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n\ * CSYTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the NNB diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L as computed by CSYTRF.\n\ *\n\ * On exit, if INFO = 0, the (symmetric) inverse of the original\n\ * matrix. If UPLO = 'U', the upper triangular part of the\n\ * inverse is formed and the part of A below the diagonal is not\n\ * referenced; if UPLO = 'L' the lower triangular part of the\n\ * inverse is formed and the part of A above the diagonal is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the NNB structure of D\n\ * as determined by CSYTRF.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (N+NNB+1,NNB+3)\n\ *\n\ * NB (input) INTEGER\n\ * Block size\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, D(i,i) = 0; the matrix is singular and its\n\ * inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgebak0000644000175000017500000000547712502223526016470 0ustar uwabamiuwabami--- :name: zgebak :md5sum: 91449be85cde6d98723559584ca26ef6 :category: :subroutine :arguments: - job: :type: char :intent: input - side: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - scale: :type: doublereal :intent: input :dims: - n - m: :type: integer :intent: input - v: :type: doublecomplex :intent: input/output :dims: - ldv - m - ldv: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGEBAK forms the right or left eigenvectors of a complex general\n\ * matrix by backward transformation on the computed eigenvectors of the\n\ * balanced matrix output by ZGEBAL.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * Specifies the type of backward transformation required:\n\ * = 'N', do nothing, return immediately;\n\ * = 'P', do backward transformation for permutation only;\n\ * = 'S', do backward transformation for scaling only;\n\ * = 'B', do backward transformations for both permutation and\n\ * scaling.\n\ * JOB must be the same as the argument JOB supplied to ZGEBAL.\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'R': V contains right eigenvectors;\n\ * = 'L': V contains left eigenvectors.\n\ *\n\ * N (input) INTEGER\n\ * The number of rows of the matrix V. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * The integers ILO and IHI determined by ZGEBAL.\n\ * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n\ *\n\ * SCALE (input) DOUBLE PRECISION array, dimension (N)\n\ * Details of the permutation and scaling factors, as returned\n\ * by ZGEBAL.\n\ *\n\ * M (input) INTEGER\n\ * The number of columns of the matrix V. M >= 0.\n\ *\n\ * V (input/output) COMPLEX*16 array, dimension (LDV,M)\n\ * On entry, the matrix of right or left eigenvectors to be\n\ * transformed, as returned by ZHSEIN or ZTREVC.\n\ * On exit, V is overwritten by the transformed eigenvectors.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V. LDV >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhetri0000644000175000017500000000507712502223526016526 0ustar uwabamiuwabami--- :name: zhetri :md5sum: e2b7ed70acb2f49352be473cb1de436e :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublecomplex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZHETRI( UPLO, N, A, LDA, IPIV, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHETRI computes the inverse of a complex Hermitian indefinite matrix\n\ * A using the factorization A = U*D*U**H or A = L*D*L**H computed by\n\ * ZHETRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**H;\n\ * = 'L': Lower triangular, form is A = L*D*L**H.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the block diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L as computed by ZHETRF.\n\ *\n\ * On exit, if INFO = 0, the (Hermitian) inverse of the original\n\ * matrix. If UPLO = 'U', the upper triangular part of the\n\ * inverse is formed and the part of A below the diagonal is not\n\ * referenced; if UPLO = 'L' the lower triangular part of the\n\ * inverse is formed and the part of A above the diagonal is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by ZHETRF.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (N)\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, D(i,i) = 0; the matrix is singular and its\n\ * inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ztfttp0000644000175000017500000001417612502223526016554 0ustar uwabamiuwabami--- :name: ztfttp :md5sum: 2f906623dea66c0b3bed7217e28c6507 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - arf: :type: doublecomplex :intent: input :dims: - ( n*(n+1)/2 ) - ap: :type: doublecomplex :intent: output :dims: - ( n*(n+1)/2 ) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZTFTTP( TRANSR, UPLO, N, ARF, AP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTFTTP copies a triangular matrix A from rectangular full packed\n\ * format (TF) to standard packed format (TP).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': ARF is in Normal format;\n\ * = 'C': ARF is in Conjugate-transpose format;\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * ARF (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n\ * On entry, the upper or lower triangular matrix A stored in\n\ * RFP format. For a further discussion see Notes below.\n\ *\n\ * AP (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n\ * On exit, the upper or lower triangular matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\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\ * We first consider Standard Packed Format when N is even.\n\ * We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * conjugate-transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * conjugate-transpose of the last three columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- --\n\ * 03 04 05 33 43 53\n\ * -- --\n\ * 13 14 15 00 44 54\n\ * --\n\ * 23 24 25 10 11 55\n\ *\n\ * 33 34 35 20 21 22\n\ * --\n\ * 00 44 45 30 31 32\n\ * -- --\n\ * 01 11 55 40 41 42\n\ * -- -- --\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We next consider Standard Packed Format when N is odd.\n\ * We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * conjugate-transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * conjugate-transpose of the last two columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- --\n\ * 02 03 04 00 33 43\n\ * --\n\ * 12 13 14 10 11 44\n\ *\n\ * 22 23 24 20 21 22\n\ * --\n\ * 00 33 34 30 31 32\n\ * -- --\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- --\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgelsd0000644000175000017500000001730312502223525016454 0ustar uwabamiuwabami--- :name: cgelsd :md5sum: 5a0063a066f735f77a3b1eb3f1e27edc :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - s: :type: real :intent: output :dims: - MIN(m,n) - rcond: :type: real :intent: input - rank: :type: integer :intent: output - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "m>=n ? 2*n+n*nrhs : 2*m+m*nrhs" - rwork: :type: real :intent: workspace :dims: - MAX(1,lrwork) - iwork: :type: integer :intent: workspace :dims: - MAX(1,liwork) - info: :type: integer :intent: output :substitutions: m: lda ldb: MAX(m,n) c__9: "9" c__0: "0" liwork: MAX(1,3*(MIN(m,n))*nlvl+11*(MIN(m,n))) lrwork: "m>=n ? 10*n+2*n*smlsiz+8*n*nlvl+3*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1) : 10*m+2*m*smlsiz+8*m*nlvl+2*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1)" nlvl: MAX(0,(int)(log(1.0*MIN(m,n)/(smlsiz+1))/log(2.0))) smlsiz: ilaenv_(&c__9,"CGELSD"," ",&c__0,&c__0,&c__0,&c__0) :fortran_help: " SUBROUTINE CGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, RWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGELSD computes the minimum-norm solution to a real linear least\n\ * squares problem:\n\ * minimize 2-norm(| b - A*x |)\n\ * using the singular value decomposition (SVD) of A. A is an M-by-N\n\ * matrix which may be rank-deficient.\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\ * The problem is solved in three steps:\n\ * (1) Reduce the coefficient matrix A to bidiagonal form with\n\ * Householder tranformations, reducing the original problem\n\ * into a \"bidiagonal least squares problem\" (BLS)\n\ * (2) Solve the BLS using a divide and conquer approach.\n\ * (3) Apply back all the Householder tranformations to solve\n\ * the original least squares problem.\n\ *\n\ * The effective rank of A is determined by treating as zero those\n\ * singular values which are less than RCOND times the largest singular\n\ * value.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\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\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, A has been destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the M-by-NRHS right hand side matrix B.\n\ * On exit, B is overwritten by the N-by-NRHS solution matrix X.\n\ * If m >= n and RANK = n, the residual sum-of-squares for\n\ * the solution in the i-th column is given by the sum of\n\ * squares of the modulus of elements n+1:m in that column.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,M,N).\n\ *\n\ * S (output) REAL array, dimension (min(M,N))\n\ * The singular values of A in decreasing order.\n\ * The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n\ *\n\ * RCOND (input) REAL\n\ * RCOND is used to determine the effective rank of A.\n\ * Singular values S(i) <= RCOND*S(1) are treated as zero.\n\ * If RCOND < 0, machine precision is used instead.\n\ *\n\ * RANK (output) INTEGER\n\ * The effective rank of A, i.e., the number of singular values\n\ * which are greater than RCOND*S(1).\n\ *\n\ * WORK (workspace/output) COMPLEX 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 must be at least 1.\n\ * The exact minimum amount of workspace needed depends on M,\n\ * N and NRHS. As long as LWORK is at least\n\ * 2 * N + N * NRHS\n\ * if M is greater than or equal to N or\n\ * 2 * M + M * NRHS\n\ * if M is less than N, the code will execute correctly.\n\ * For good performance, LWORK should generally be larger.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the optimal size of the array WORK and the\n\ * minimum sizes of the arrays RWORK and IWORK, and returns\n\ * these values as the first entries of the WORK, RWORK and\n\ * IWORK arrays, and no error message related to LWORK is issued\n\ * by XERBLA.\n\ *\n\ * RWORK (workspace) REAL array, dimension (MAX(1,LRWORK))\n\ * LRWORK >=\n\ * 10*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS +\n\ * MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS )\n\ * if M is greater than or equal to N or\n\ * 10*M + 2*M*SMLSIZ + 8*M*NLVL + 3*SMLSIZ*NRHS +\n\ * MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS )\n\ * if M is less than N, the code will execute correctly.\n\ * SMLSIZ is returned by ILAENV and is equal to the maximum\n\ * size of the subproblems at the bottom of the computation\n\ * tree (usually about 25), and\n\ * NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )\n\ * On exit, if INFO = 0, RWORK(1) returns the minimum LRWORK.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))\n\ * LIWORK >= max(1, 3*MINMN*NLVL + 11*MINMN),\n\ * where MINMN = MIN( M,N ).\n\ * On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * > 0: the algorithm for computing the SVD failed to converge;\n\ * if INFO = i, i off-diagonal elements of an intermediate\n\ * bidiagonal form did not converge to zero.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ming Gu and Ren-Cang Li, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlasq40000644000175000017500000000462712502223526016411 0ustar uwabamiuwabami--- :name: dlasq4 :md5sum: 6d8b1df65fc2a9a01be27c77f4c07567 :category: :subroutine :arguments: - i0: :type: integer :intent: input - n0: :type: integer :intent: input - z: :type: doublereal :intent: input :dims: - 4*n0 - pp: :type: integer :intent: input - n0in: :type: integer :intent: input - dmin: :type: doublereal :intent: input - dmin1: :type: doublereal :intent: input - dmin2: :type: doublereal :intent: input - dn: :type: doublereal :intent: input - dn1: :type: doublereal :intent: input - dn2: :type: doublereal :intent: input - tau: :type: doublereal :intent: output - ttype: :type: integer :intent: output - g: :type: real :intent: input/output :substitutions: {} :fortran_help: " SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1, DN2, TAU, TTYPE, G )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLASQ4 computes an approximation TAU to the smallest eigenvalue\n\ * using values of d from the previous transform.\n\ *\n\n\ * I0 (input) INTEGER\n\ * First index.\n\ *\n\ * N0 (input) INTEGER\n\ * Last index.\n\ *\n\ * Z (input) DOUBLE PRECISION array, dimension ( 4*N )\n\ * Z holds the qd array.\n\ *\n\ * PP (input) INTEGER\n\ * PP=0 for ping, PP=1 for pong.\n\ *\n\ * NOIN (input) INTEGER\n\ * The value of N0 at start of EIGTEST.\n\ *\n\ * DMIN (input) DOUBLE PRECISION\n\ * Minimum value of d.\n\ *\n\ * DMIN1 (input) DOUBLE PRECISION\n\ * Minimum value of d, excluding D( N0 ).\n\ *\n\ * DMIN2 (input) DOUBLE PRECISION\n\ * Minimum value of d, excluding D( N0 ) and D( N0-1 ).\n\ *\n\ * DN (input) DOUBLE PRECISION\n\ * d(N)\n\ *\n\ * DN1 (input) DOUBLE PRECISION\n\ * d(N-1)\n\ *\n\ * DN2 (input) DOUBLE PRECISION\n\ * d(N-2)\n\ *\n\ * TAU (output) DOUBLE PRECISION\n\ * This is the shift.\n\ *\n\ * TTYPE (output) INTEGER\n\ * Shift type.\n\ *\n\ * G (input/output) REAL\n\ * G is passed as an argument in order to save its value between\n\ * calls to DLASQ4.\n\ *\n\n\ * Further Details\n\ * ===============\n\ * CNST1 = 9/16\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zptts20000644000175000017500000000560112502223526016460 0ustar uwabamiuwabami--- :name: zptts2 :md5sum: 3913b63799343492f4ef48be21c0b157 :category: :subroutine :arguments: - iuplo: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublecomplex :intent: input :dims: - n-1 - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE ZPTTS2( IUPLO, N, NRHS, D, E, B, LDB )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPTTS2 solves a tridiagonal system of the form\n\ * A * X = B\n\ * using the factorization A = U'*D*U or A = L*D*L' computed by ZPTTRF.\n\ * D is a diagonal matrix specified in the vector D, U (or L) is a unit\n\ * bidiagonal matrix whose superdiagonal (subdiagonal) is specified in\n\ * the vector E, and X and B are N by NRHS matrices.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * IUPLO (input) INTEGER\n\ * Specifies the form of the factorization and whether the\n\ * vector E is the superdiagonal of the upper bidiagonal factor\n\ * U or the subdiagonal of the lower bidiagonal factor L.\n\ * = 1: A = U'*D*U, E is the superdiagonal of U\n\ * = 0: A = L*D*L', E is the subdiagonal of L\n\ *\n\ * N (input) INTEGER\n\ * The order of the tridiagonal matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The n diagonal elements of the diagonal matrix D from the\n\ * factorization A = U'*D*U or A = L*D*L'.\n\ *\n\ * E (input) COMPLEX*16 array, dimension (N-1)\n\ * If IUPLO = 1, the (n-1) superdiagonal elements of the unit\n\ * bidiagonal factor U from the factorization A = U'*D*U.\n\ * If IUPLO = 0, the (n-1) subdiagonal elements of the unit\n\ * bidiagonal factor L from the factorization A = L*D*L'.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the right hand side vectors B for the system of\n\ * linear equations.\n\ * On exit, the solution vectors, X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL ZDSCAL\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC DCONJG\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zlag2c0000644000175000017500000000454612655767354016430 0ustar uwabamiuwabami--- :name: zlag2c :md5sum: 74fe0ffefcc616f52a172abaa7fccf0d :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - sa: :type: complex :intent: output :dims: - ldsa - n - ldsa: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: ldsa: MAX(1,m) :fortran_help: " SUBROUTINE ZLAG2C( M, N, A, LDA, SA, LDSA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAG2C converts a COMPLEX*16 matrix, SA, to a COMPLEX matrix, A.\n\ *\n\ * RMAX is the overflow for the SINGLE PRECISION arithmetic\n\ * ZLAG2C checks that all the entries of A are between -RMAX and\n\ * RMAX. If not the conversion is aborted and a flag is raised.\n\ *\n\ * This is an auxiliary routine so there is no argument checking.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of lines 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) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the M-by-N coefficient matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * SA (output) COMPLEX array, dimension (LDSA,N)\n\ * On exit, if INFO=0, the M-by-N coefficient matrix SA; if\n\ * INFO>0, the content of SA is unspecified.\n\ *\n\ * LDSA (input) INTEGER\n\ * The leading dimension of the array SA. LDSA >= max(1,M).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit.\n\ * = 1: an entry of the matrix A is greater than the SINGLE\n\ * PRECISION overflow threshold, in this case, the content\n\ * of SA in exit is unspecified.\n\ *\n\ * =========\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n DOUBLE PRECISION RMAX\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC DBLE, DIMAG\n\ * ..\n\ * .. External Functions ..\n REAL SLAMCH\n EXTERNAL SLAMCH\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slaed50000644000175000017500000000375212502223526016374 0ustar uwabamiuwabami--- :name: slaed5 :md5sum: 1e0d84a3982b12261a34f11249234b49 :category: :subroutine :arguments: - i: :type: integer :intent: input - d: :type: real :intent: input :dims: - "2" - z: :type: real :intent: input :dims: - "2" - delta: :type: real :intent: output :dims: - "2" - rho: :type: real :intent: input - dlam: :type: real :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLAED5( I, D, Z, DELTA, RHO, DLAM )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This subroutine computes the I-th eigenvalue of a symmetric rank-one\n\ * modification of a 2-by-2 diagonal matrix\n\ *\n\ * diag( D ) + RHO * Z * transpose(Z) .\n\ *\n\ * The diagonal elements in the array D are assumed to satisfy\n\ *\n\ * D(i) < D(j) for i < j .\n\ *\n\ * We also assume RHO > 0 and that the Euclidean norm of the vector\n\ * Z is one.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * I (input) INTEGER\n\ * The index of the eigenvalue to be computed. I = 1 or I = 2.\n\ *\n\ * D (input) REAL array, dimension (2)\n\ * The original eigenvalues. We assume D(1) < D(2).\n\ *\n\ * Z (input) REAL array, dimension (2)\n\ * The components of the updating vector.\n\ *\n\ * DELTA (output) REAL array, dimension (2)\n\ * The vector DELTA contains the information necessary\n\ * to construct the eigenvectors.\n\ *\n\ * RHO (input) REAL\n\ * The scalar in the symmetric updating formula.\n\ *\n\ * DLAM (output) REAL\n\ * The computed lambda_I, the I-th updated eigenvalue.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ren-Cang Li, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sptts20000644000175000017500000000440312502223526016450 0ustar uwabamiuwabami--- :name: sptts2 :md5sum: 2e63425e2f920d91557419030f1e2e1b :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: real :intent: input :dims: - n-1 - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE SPTTS2( N, NRHS, D, E, B, LDB )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPTTS2 solves a tridiagonal system of the form\n\ * A * X = B\n\ * using the L*D*L' factorization of A computed by SPTTRF. D is a\n\ * diagonal matrix specified in the vector D, L is a unit bidiagonal\n\ * matrix whose subdiagonal is specified in the vector E, and X and B\n\ * are N by NRHS matrices.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the tridiagonal matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The n diagonal elements of the diagonal matrix D from the\n\ * L*D*L' factorization of A.\n\ *\n\ * E (input) REAL array, dimension (N-1)\n\ * The (n-1) subdiagonal elements of the unit bidiagonal factor\n\ * L from the L*D*L' factorization of A. E can also be regarded\n\ * as the superdiagonal of the unit bidiagonal factor U from the\n\ * factorization A = U'*D*U.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the right hand side vectors B for the system of\n\ * linear equations.\n\ * On exit, the solution vectors, X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SSCAL\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zhbgv0000644000175000017500000001312212502223526016327 0ustar uwabamiuwabami--- :name: zhbgv :md5sum: 53ed0c8a2fa947bd3a711b8a8c2025f0 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: doublecomplex :intent: input/output :dims: - ldbb - n - ldbb: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - n - rwork: :type: doublereal :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? n : 1" :fortran_help: " SUBROUTINE ZHBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHBGV computes all the eigenvalues, and optionally, the eigenvectors\n\ * of a complex generalized Hermitian-definite banded eigenproblem, of\n\ * the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian\n\ * and banded, and B is also positive definite.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * KA (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n\ *\n\ * KB (input) INTEGER\n\ * The number of superdiagonals of the matrix B if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n\ *\n\ * AB (input/output) COMPLEX*16 array, dimension (LDAB, N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix A, stored in the first ka+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n\ *\n\ * On exit, the contents of AB are destroyed.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KA+1.\n\ *\n\ * BB (input/output) COMPLEX*16 array, dimension (LDBB, N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix B, stored in the first kb+1 rows of the array. The\n\ * j-th column of B is stored in the j-th column of the array BB\n\ * as follows:\n\ * if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n\ * if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n\ *\n\ * On exit, the factor S from the split Cholesky factorization\n\ * B = S**H*S, as returned by ZPBSTF.\n\ *\n\ * LDBB (input) INTEGER\n\ * The leading dimension of the array BB. LDBB >= KB+1.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) COMPLEX*16 array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n\ * eigenvectors, with the i-th column of Z holding the\n\ * eigenvector associated with W(i). The eigenvectors are\n\ * normalized so that Z**H*B*Z = I.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= N.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (3*N)\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, and i is:\n\ * <= N: the algorithm failed to converge:\n\ * i off-diagonal elements of an intermediate\n\ * tridiagonal form did not converge to zero;\n\ * > N: if INFO = N + i, for 1 <= i <= N, then ZPBSTF\n\ * returned INFO = i: B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL UPPER, WANTZ\n CHARACTER VECT\n INTEGER IINFO, INDE, INDWRK\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DSTERF, XERBLA, ZHBGST, ZHBTRD, ZPBSTF, ZSTEQR\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zla_syrpvgrw0000644000175000017500000000633712502223526017772 0ustar uwabamiuwabami--- :name: zla_syrpvgrw :md5sum: 317835fcbf8ec3e2105e90ebf3c36c72 :category: :function :type: doublereal :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - info: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublecomplex :intent: input :dims: - 2*n :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION ZLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, WORK )\n\n\ * Purpose\n\ * =======\n\ * \n\ * ZLA_SYRPVGRW computes the reciprocal pivot growth factor\n\ * norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n\ * much less than 1, the stability of the LU factorization of the\n\ * (equilibrated) matrix A could be poor. This also means that the\n\ * solution X, estimated condition numbers, and error bounds could be\n\ * unreliable.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * INFO (input) INTEGER\n\ * The value of INFO returned from ZSYTRF, .i.e., the pivot in\n\ * column INFO is exactly 0.\n\ *\n\ * NCOLS (input) INTEGER\n\ * The number of columns of the matrix A. NCOLS >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX*16 array, dimension (LDAF,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by ZSYTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by ZSYTRF.\n\ *\n\ * WORK (input) COMPLEX*16 array, dimension (2*N)\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER NCOLS, I, J, K, KP\n DOUBLE PRECISION AMAX, UMAX, RPVGRW, TMP\n LOGICAL UPPER\n COMPLEX*16 ZDUM\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, REAL, DIMAG, MAX, MIN\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL LSAME, ZLASET\n LOGICAL LSAME\n\ * ..\n\ * .. Statement Functions ..\n DOUBLE PRECISION CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE ( ZDUM ) ) + ABS( DIMAG ( ZDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zhpevx0000644000175000017500000001644312502223526016544 0ustar uwabamiuwabami--- :name: zhpevx :md5sum: 6bf75070a769cbabc0a9a3b578487f43 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - ldap - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - 7*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE ZHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHPEVX computes selected eigenvalues and, optionally, eigenvectors\n\ * of a complex Hermitian matrix A in packed storage.\n\ * Eigenvalues/vectors can be selected by specifying either a range of\n\ * values or a range of indices for the desired eigenvalues.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found;\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found;\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, AP is overwritten by values generated during the\n\ * reduction to tridiagonal form. If UPLO = 'U', the diagonal\n\ * and first superdiagonal of the tridiagonal matrix T overwrite\n\ * the corresponding elements of A, and if UPLO = 'L', the\n\ * diagonal and first subdiagonal of T overwrite the\n\ * corresponding elements of A.\n\ *\n\ * VL (input) DOUBLE PRECISION\n\ * VU (input) DOUBLE PRECISION\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) DOUBLE PRECISION\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less than\n\ * or equal to zero, then EPS*|T| will be used in its place,\n\ * where |T| is the 1-norm of the tridiagonal matrix obtained\n\ * by reducing AP to tridiagonal form.\n\ *\n\ * Eigenvalues will be computed most accurately when ABSTOL is\n\ * set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n\ * If this routine returns with INFO>0, indicating that some\n\ * eigenvectors did not converge, try setting ABSTOL to\n\ * 2*DLAMCH('S').\n\ *\n\ * See \"Computing Small Singular Values of Bidiagonal Matrices\n\ * with Guaranteed High Relative Accuracy,\" by Demmel and\n\ * Kahan, LAPACK Working Note #3.\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, the selected eigenvalues in ascending order.\n\ *\n\ * Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M))\n\ * If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix A\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * If an eigenvector fails to converge, then that column of Z\n\ * contains the latest approximation to the eigenvector, and\n\ * the index of the eigenvector is returned in IFAIL.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (7*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (5*N)\n\ *\n\ * IFAIL (output) INTEGER array, dimension (N)\n\ * If JOBZ = 'V', then if INFO = 0, the first M elements of\n\ * IFAIL are zero. If INFO > 0, then IFAIL contains the\n\ * indices of the eigenvectors that failed to converge.\n\ * If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n\ * Their indices are stored in array IFAIL.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/spbsv0000644000175000017500000001136612502223526016354 0ustar uwabamiuwabami--- :name: spbsv :md5sum: 4407c9056bcf43a0932a2e1a7a03fb8a :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPBSV computes the solution to a real system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N symmetric positive definite band matrix and X\n\ * and B are N-by-NRHS matrices.\n\ *\n\ * The Cholesky decomposition is used to factor A as\n\ * A = U**T * U, if UPLO = 'U', or\n\ * A = L * L**T, if UPLO = 'L',\n\ * where U is an upper triangular band matrix, and L is a lower\n\ * triangular band matrix, with the same number of superdiagonals or\n\ * subdiagonals as A. The factored form of A is then used to solve the\n\ * system of equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AB (input/output) REAL array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).\n\ * See below for further details.\n\ *\n\ * On exit, if INFO = 0, the triangular factor U or L from the\n\ * Cholesky factorization A = U**T*U or A = L*L**T of the band\n\ * matrix A, in the same storage format as A.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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 leading minor of order i of A is not\n\ * positive definite, so the factorization could not be\n\ * completed, and the solution has not been computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * N = 6, KD = 2, and UPLO = 'U':\n\ *\n\ * On entry: On exit:\n\ *\n\ * * * a13 a24 a35 a46 * * u13 u24 u35 u46\n\ * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n\ * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n\ *\n\ * Similarly, if UPLO = 'L' the format of A is as follows:\n\ *\n\ * On entry: On exit:\n\ *\n\ * a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n\ * a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n\ * a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n\ *\n\ * Array elements marked * are not used by the routine.\n\ *\n\ * =====================================================================\n\ *\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SPBTRF, SPBTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zlalsa0000644000175000017500000002002112502223526016471 0ustar uwabamiuwabami--- :name: zlalsa :md5sum: dd9ab43ee14de96210fce94d8fd0fbe9 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - smlsiz: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - bx: :type: doublecomplex :intent: output :dims: - ldbx - nrhs - ldbx: :type: integer :intent: input - u: :type: doublereal :intent: input :dims: - ldu - smlsiz - ldu: :type: integer :intent: input - vt: :type: doublereal :intent: input :dims: - ldu - smlsiz+1 - k: :type: integer :intent: input :dims: - n - difl: :type: doublereal :intent: input :dims: - ldu - nlvl - difr: :type: doublereal :intent: input :dims: - ldu - 2 * nlvl - z: :type: doublereal :intent: input :dims: - ldu - nlvl - poles: :type: doublereal :intent: input :dims: - ldu - 2 * nlvl - givptr: :type: integer :intent: input :dims: - n - givcol: :type: integer :intent: input :dims: - ldgcol - 2 * nlvl - ldgcol: :type: integer :intent: input - perm: :type: integer :intent: input :dims: - ldgcol - nlvl - givnum: :type: doublereal :intent: input :dims: - ldu - 2 * nlvl - c: :type: doublereal :intent: input :dims: - n - s: :type: doublereal :intent: input :dims: - n - rwork: :type: doublereal :intent: workspace :dims: - MAX(n,(smlsiz+1)*nrhs*3) - iwork: :type: integer :intent: workspace :dims: - 3 * n - info: :type: integer :intent: output :substitutions: ldbx: n nlvl: (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1 :fortran_help: " SUBROUTINE ZLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, PERM, GIVNUM, C, S, RWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLALSA is an itermediate step in solving the least squares problem\n\ * by computing the SVD of the coefficient matrix in compact form (The\n\ * singular vectors are computed as products of simple orthorgonal\n\ * matrices.).\n\ *\n\ * If ICOMPQ = 0, ZLALSA applies the inverse of the left singular vector\n\ * matrix of an upper bidiagonal matrix to the right hand side; and if\n\ * ICOMPQ = 1, ZLALSA applies the right singular vector matrix to the\n\ * right hand side. The singular vector matrices were generated in\n\ * compact form by ZLALSA.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ICOMPQ (input) INTEGER\n\ * Specifies whether the left or the right singular vector\n\ * matrix is involved.\n\ * = 0: Left singular vector matrix\n\ * = 1: Right singular vector matrix\n\ *\n\ * SMLSIZ (input) INTEGER\n\ * The maximum size of the subproblems at the bottom of the\n\ * computation tree.\n\ *\n\ * N (input) INTEGER\n\ * The row and column dimensions of the upper bidiagonal matrix.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of columns of B and BX. NRHS must be at least 1.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension ( LDB, NRHS )\n\ * On input, B contains the right hand sides of the least\n\ * squares problem in rows 1 through M.\n\ * On output, B contains the solution X in rows 1 through N.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B in the calling subprogram.\n\ * LDB must be at least max(1,MAX( M, N ) ).\n\ *\n\ * BX (output) COMPLEX*16 array, dimension ( LDBX, NRHS )\n\ * On exit, the result of applying the left or right singular\n\ * vector matrix to B.\n\ *\n\ * LDBX (input) INTEGER\n\ * The leading dimension of BX.\n\ *\n\ * U (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ).\n\ * On entry, U contains the left singular vector matrices of all\n\ * subproblems at the bottom level.\n\ *\n\ * LDU (input) INTEGER, LDU = > N.\n\ * The leading dimension of arrays U, VT, DIFL, DIFR,\n\ * POLES, GIVNUM, and Z.\n\ *\n\ * VT (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ).\n\ * On entry, VT' contains the right singular vector matrices of\n\ * all subproblems at the bottom level.\n\ *\n\ * K (input) INTEGER array, dimension ( N ).\n\ *\n\ * DIFL (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).\n\ * where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.\n\ *\n\ * DIFR (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).\n\ * On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record\n\ * distances between singular values on the I-th level and\n\ * singular values on the (I -1)-th level, and DIFR(*, 2 * I)\n\ * record the normalizing factors of the right singular vectors\n\ * matrices of subproblems on I-th level.\n\ *\n\ * Z (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).\n\ * On entry, Z(1, I) contains the components of the deflation-\n\ * adjusted updating row vector for subproblems on the I-th\n\ * level.\n\ *\n\ * POLES (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).\n\ * On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old\n\ * singular values involved in the secular equations on the I-th\n\ * level.\n\ *\n\ * GIVPTR (input) INTEGER array, dimension ( N ).\n\ * On entry, GIVPTR( I ) records the number of Givens\n\ * rotations performed on the I-th problem on the computation\n\ * tree.\n\ *\n\ * GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ).\n\ * On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the\n\ * locations of Givens rotations performed on the I-th level on\n\ * the computation tree.\n\ *\n\ * LDGCOL (input) INTEGER, LDGCOL = > N.\n\ * The leading dimension of arrays GIVCOL and PERM.\n\ *\n\ * PERM (input) INTEGER array, dimension ( LDGCOL, NLVL ).\n\ * On entry, PERM(*, I) records permutations done on the I-th\n\ * level of the computation tree.\n\ *\n\ * GIVNUM (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).\n\ * On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-\n\ * values of Givens rotations performed on the I-th level on the\n\ * computation tree.\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension ( N ).\n\ * On entry, if the I-th subproblem is not square,\n\ * C( I ) contains the C-value of a Givens rotation related to\n\ * the right null space of the I-th subproblem.\n\ *\n\ * S (input) DOUBLE PRECISION array, dimension ( N ).\n\ * On entry, if the I-th subproblem is not square,\n\ * S( I ) contains the S-value of a Givens rotation related to\n\ * the right null space of the I-th subproblem.\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension at least\n\ * MAX( (SMLSZ+1)*NRHS*3, N*(1+NRHS) + 2*NRHS ).\n\ *\n\ * IWORK (workspace) INTEGER array.\n\ * The dimension must be at least 3 * N\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\ * Based on contributions by\n\ * Ming Gu and Ren-Cang Li, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlasd60000644000175000017500000002452712655767354016424 0ustar uwabamiuwabami--- :name: dlasd6 :md5sum: d01a531ca94d767a226f40498502e8dd :category: :subroutine :arguments: - icompq: :type: integer :intent: input - nl: :type: integer :intent: input - nr: :type: integer :intent: input - sqre: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - nl+nr+1 - vf: :type: doublereal :intent: input/output :dims: - m - vl: :type: doublereal :intent: input/output :dims: - m - alpha: :type: doublereal :intent: input/output - beta: :type: doublereal :intent: input/output - idxq: :type: integer :intent: output :dims: - n - perm: :type: integer :intent: output :dims: - n - givptr: :type: integer :intent: output - givcol: :type: integer :intent: output :dims: - ldgcol - "2" - ldgcol: :type: integer :intent: input - givnum: :type: doublereal :intent: output :dims: - ldgnum - "2" - ldgnum: :type: integer :intent: input - poles: :type: doublereal :intent: output :dims: - ldgnum - "2" - difl: :type: doublereal :intent: output :dims: - n - difr: :type: doublereal :intent: output :dims: - "icompq == 1 ? ldgnum : icompq == 0 ? n : 0" - "icompq == 1 ? 2 : 0" - z: :type: doublereal :intent: output :dims: - m - k: :type: integer :intent: output - c: :type: doublereal :intent: output - s: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 4 * m - iwork: :type: integer :intent: workspace :dims: - 3 * n - info: :type: integer :intent: output :substitutions: m: n + sqre n: nl + nr + 1 ldgnum: n ldgcol: n :fortran_help: " SUBROUTINE DLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA, IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLASD6 computes the SVD of an updated upper bidiagonal matrix B\n\ * obtained by merging two smaller ones by appending a row. This\n\ * routine is used only for the problem which requires all singular\n\ * values and optionally singular vector matrices in factored form.\n\ * B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE.\n\ * A related subroutine, DLASD1, handles the case in which all singular\n\ * values and singular vectors of the bidiagonal matrix are desired.\n\ *\n\ * DLASD6 computes the SVD as follows:\n\ *\n\ * ( D1(in) 0 0 0 )\n\ * B = U(in) * ( Z1' a Z2' b ) * VT(in)\n\ * ( 0 0 D2(in) 0 )\n\ *\n\ * = U(out) * ( D(out) 0) * VT(out)\n\ *\n\ * where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M\n\ * with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros\n\ * elsewhere; and the entry b is empty if SQRE = 0.\n\ *\n\ * The singular values of B can be computed using D1, D2, the first\n\ * components of all the right singular vectors of the lower block, and\n\ * the last components of all the right singular vectors of the upper\n\ * block. These components are stored and updated in VF and VL,\n\ * respectively, in DLASD6. Hence U and VT are not explicitly\n\ * referenced.\n\ *\n\ * The singular values are stored in D. The algorithm consists of two\n\ * stages:\n\ *\n\ * The first stage consists of deflating the size of the problem\n\ * when there are multiple singular values or if there is a zero\n\ * in the Z vector. For each such occurrence the dimension of the\n\ * secular equation problem is reduced by one. This stage is\n\ * performed by the routine DLASD7.\n\ *\n\ * The second stage consists of calculating the updated\n\ * singular values. This is done by finding the roots of the\n\ * secular equation via the routine DLASD4 (as called by DLASD8).\n\ * This routine also updates VF and VL and computes the distances\n\ * between the updated singular values and the old singular\n\ * values.\n\ *\n\ * DLASD6 is called from DLASDA.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ICOMPQ (input) INTEGER\n\ * Specifies whether singular vectors are to be computed in\n\ * factored form:\n\ * = 0: Compute singular values only.\n\ * = 1: Compute singular vectors in factored form as well.\n\ *\n\ * NL (input) INTEGER\n\ * The row dimension of the upper block. NL >= 1.\n\ *\n\ * NR (input) INTEGER\n\ * The row dimension of the lower block. NR >= 1.\n\ *\n\ * SQRE (input) INTEGER\n\ * = 0: the lower block is an NR-by-NR square matrix.\n\ * = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n\ *\n\ * The bidiagonal matrix has row dimension N = NL + NR + 1,\n\ * and column dimension M = N + SQRE.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension ( NL+NR+1 ).\n\ * On entry D(1:NL,1:NL) contains the singular values of the\n\ * upper block, and D(NL+2:N) contains the singular values\n\ * of the lower block. On exit D(1:N) contains the singular\n\ * values of the modified matrix.\n\ *\n\ * VF (input/output) DOUBLE PRECISION array, dimension ( M )\n\ * On entry, VF(1:NL+1) contains the first components of all\n\ * right singular vectors of the upper block; and VF(NL+2:M)\n\ * contains the first components of all right singular vectors\n\ * of the lower block. On exit, VF contains the first components\n\ * of all right singular vectors of the bidiagonal matrix.\n\ *\n\ * VL (input/output) DOUBLE PRECISION array, dimension ( M )\n\ * On entry, VL(1:NL+1) contains the last components of all\n\ * right singular vectors of the upper block; and VL(NL+2:M)\n\ * contains the last components of all right singular vectors of\n\ * the lower block. On exit, VL contains the last components of\n\ * all right singular vectors of the bidiagonal matrix.\n\ *\n\ * ALPHA (input/output) DOUBLE PRECISION\n\ * Contains the diagonal element associated with the added row.\n\ *\n\ * BETA (input/output) DOUBLE PRECISION\n\ * Contains the off-diagonal element associated with the added\n\ * row.\n\ *\n\ * IDXQ (output) INTEGER array, dimension ( N )\n\ * This contains the permutation which will reintegrate the\n\ * subproblem just solved back into sorted order, i.e.\n\ * D( IDXQ( I = 1, N ) ) will be in ascending order.\n\ *\n\ * PERM (output) INTEGER array, dimension ( N )\n\ * The permutations (from deflation and sorting) to be applied\n\ * to each block. Not referenced if ICOMPQ = 0.\n\ *\n\ * GIVPTR (output) INTEGER\n\ * The number of Givens rotations which took place in this\n\ * subproblem. Not referenced if ICOMPQ = 0.\n\ *\n\ * GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )\n\ * Each pair of numbers indicates a pair of columns to take place\n\ * in a Givens rotation. Not referenced if ICOMPQ = 0.\n\ *\n\ * LDGCOL (input) INTEGER\n\ * leading dimension of GIVCOL, must be at least N.\n\ *\n\ * GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )\n\ * Each number indicates the C or S value to be used in the\n\ * corresponding Givens rotation. Not referenced if ICOMPQ = 0.\n\ *\n\ * LDGNUM (input) INTEGER\n\ * The leading dimension of GIVNUM and POLES, must be at least N.\n\ *\n\ * POLES (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )\n\ * On exit, POLES(1,*) is an array containing the new singular\n\ * values obtained from solving the secular equation, and\n\ * POLES(2,*) is an array containing the poles in the secular\n\ * equation. Not referenced if ICOMPQ = 0.\n\ *\n\ * DIFL (output) DOUBLE PRECISION array, dimension ( N )\n\ * On exit, DIFL(I) is the distance between I-th updated\n\ * (undeflated) singular value and the I-th (undeflated) old\n\ * singular value.\n\ *\n\ * DIFR (output) DOUBLE PRECISION array,\n\ * dimension ( LDGNUM, 2 ) if ICOMPQ = 1 and\n\ * dimension ( N ) if ICOMPQ = 0.\n\ * On exit, DIFR(I, 1) is the distance between I-th updated\n\ * (undeflated) singular value and the I+1-th (undeflated) old\n\ * singular value.\n\ *\n\ * If ICOMPQ = 1, DIFR(1:K,2) is an array containing the\n\ * normalizing factors for the right singular vector matrix.\n\ *\n\ * See DLASD8 for details on DIFL and DIFR.\n\ *\n\ * Z (output) DOUBLE PRECISION array, dimension ( M )\n\ * The first elements of this array contain the components\n\ * of the deflation-adjusted updating row vector.\n\ *\n\ * K (output) INTEGER\n\ * Contains the dimension of the non-deflated matrix,\n\ * This is the order of the related secular equation. 1 <= K <=N.\n\ *\n\ * C (output) DOUBLE PRECISION\n\ * C contains garbage if SQRE =0 and the C-value of a Givens\n\ * rotation related to the right null space if SQRE = 1.\n\ *\n\ * S (output) DOUBLE PRECISION\n\ * S contains garbage if SQRE =0 and the S-value of a Givens\n\ * rotation related to the right null space if SQRE = 1.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension ( 4 * M )\n\ *\n\ * IWORK (workspace) INTEGER array, dimension ( 3 * N )\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 = 1, a singular value did not converge\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ming Gu and Huan Ren, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ieeeck0000644000175000017500000000302412502223526016434 0ustar uwabamiuwabami--- :name: ieeeck :md5sum: 912297d3164c5b304dfe88d1002d97b1 :category: :function :type: integer :arguments: - ispec: :type: integer :intent: input - zero: :type: real :intent: input - one: :type: real :intent: input :substitutions: {} :fortran_help: " INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE )\n\n\ * Purpose\n\ * =======\n\ *\n\ * IEEECK is called from the ILAENV to verify that Infinity and\n\ * possibly NaN arithmetic is safe (i.e. will not trap).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ISPEC (input) INTEGER\n\ * Specifies whether to test just for inifinity arithmetic\n\ * or whether to test for infinity and NaN arithmetic.\n\ * = 0: Verify infinity arithmetic only.\n\ * = 1: Verify infinity and NaN arithmetic.\n\ *\n\ * ZERO (input) REAL\n\ * Must contain the value 0.0\n\ * This is passed to prevent the compiler from optimizing\n\ * away this code.\n\ *\n\ * ONE (input) REAL\n\ * Must contain the value 1.0\n\ * This is passed to prevent the compiler from optimizing\n\ * away this code.\n\ *\n\ * RETURN VALUE: INTEGER\n\ * = 0: Arithmetic failed to produce the correct answers\n\ * = 1: Arithmetic produced the correct answers\n\ *\n\ * .. Local Scalars ..\n REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF,\n $ NEGZRO, NEWZRO, POSINF\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zhetf20000644000175000017500000001310712502223526016414 0ustar uwabamiuwabami--- :name: zhetf2 :md5sum: 725e5436827d63711e21fdeffc5c30d6 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZHETF2( UPLO, N, A, LDA, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHETF2 computes the factorization of a complex Hermitian matrix A\n\ * using the Bunch-Kaufman diagonal pivoting method:\n\ *\n\ * A = U*D*U' or A = L*D*L'\n\ *\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, U' is the conjugate transpose of U, and D is\n\ * Hermitian and block diagonal with 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\ * This is the unblocked version of the algorithm, calling Level 2 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * Hermitian matrix A is stored:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the leading\n\ * n-by-n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n-by-n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L (see below for further details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D.\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ * > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular, and division by zero will occur if it\n\ * is used to solve a system of equations.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * 09-29-06 - patch from\n\ * Bobby Cheng, MathWorks\n\ *\n\ * Replace l.210 and l.393\n\ * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN\n\ * by\n\ * IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN\n\ *\n\ * 01-01-96 - Based on modifications by\n\ * J. Lewis, Boeing Computer Services Company\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * If UPLO = 'U', then A = U*D*U', where\n\ * U = P(n)*U(n)* ... *P(k)U(k)* ...,\n\ * i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n\ * 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I v 0 ) k-s\n\ * U(k) = ( 0 I 0 ) s\n\ * ( 0 0 I ) n-k\n\ * k-s s n-k\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n\ * If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n\ * and A(k,k), and v overwrites A(1:k-2,k-1:k).\n\ *\n\ * If UPLO = 'L', then A = L*D*L', where\n\ * L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n\ * i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n\ * n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I 0 0 ) k-1\n\ * L(k) = ( 0 I 0 ) s\n\ * ( 0 v I ) n-k-s+1\n\ * k-1 s n-k-s+1\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n\ * If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n\ * and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cpftri0000644000175000017500000001522112502223525016477 0ustar uwabamiuwabami--- :name: cpftri :md5sum: 628346e3f91d7dfc0bb02666b752fd84 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPFTRI( TRANSR, UPLO, N, A, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPFTRI computes the inverse of a complex Hermitian positive definite\n\ * matrix A using the Cholesky factorization A = U**H*U or A = L*L**H\n\ * computed by CPFTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': The Normal TRANSR of RFP A is stored;\n\ * = 'C': The Conjugate-transpose TRANSR of RFP A is stored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension ( N*(N+1)/2 );\n\ * On entry, the Hermitian matrix A in RFP format. RFP format is\n\ * described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n\ * then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n\ * (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is\n\ * the Conjugate-transpose of RFP A as defined when\n\ * TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n\ * follows: If UPLO = 'U' the RFP A contains the nt elements of\n\ * upper packed A. If UPLO = 'L' the RFP A contains the elements\n\ * of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n\ * 'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n\ * is odd. See the Note below for more details.\n\ *\n\ * On exit, the Hermitian inverse of the original matrix, in the\n\ * same storage format.\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,i) element of the factor U or L is\n\ * zero, and the inverse could not be computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * We first consider Standard Packed Format when N is even.\n\ * We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * conjugate-transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * conjugate-transpose of the last three columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- --\n\ * 03 04 05 33 43 53\n\ * -- --\n\ * 13 14 15 00 44 54\n\ * --\n\ * 23 24 25 10 11 55\n\ *\n\ * 33 34 35 20 21 22\n\ * --\n\ * 00 44 45 30 31 32\n\ * -- --\n\ * 01 11 55 40 41 42\n\ * -- -- --\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We next consider Standard Packed Format when N is odd.\n\ * We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * conjugate-transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * conjugate-transpose of the last two columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- --\n\ * 02 03 04 00 33 43\n\ * --\n\ * 12 13 14 10 11 44\n\ *\n\ * 22 23 24 20 21 22\n\ * --\n\ * 00 33 34 30 31 32\n\ * -- --\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- --\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dspgvx0000644000175000017500000002214512502223526016527 0ustar uwabamiuwabami--- :name: dspgvx :md5sum: f64e08142ffc3da2c4a946629754e8ad :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - ldap - bp: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - "lsame_(&jobz,\"N\") ? 0 : ldz" - "lsame_(&jobz,\"N\") ? 0 : MAX(1,m)" - ldz: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 8*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE DSPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSPGVX computes selected eigenvalues, and optionally, eigenvectors\n\ * of a real generalized symmetric-definite eigenproblem, of the form\n\ * A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A\n\ * and B are assumed to be symmetric, stored in packed storage, and B\n\ * is also positive definite. Eigenvalues and eigenvectors can be\n\ * selected by specifying either a range of values or a range of indices\n\ * for the desired eigenvalues.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * Specifies the problem type to be solved:\n\ * = 1: A*x = (lambda)*B*x\n\ * = 2: A*B*x = (lambda)*x\n\ * = 3: B*A*x = (lambda)*x\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found.\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found.\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A and B are stored;\n\ * = 'L': Lower triangle of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix pencil (A,B). N >= 0.\n\ *\n\ * AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, the contents of AP are destroyed.\n\ *\n\ * BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * B, packed columnwise in a linear array. The j-th column of B\n\ * is stored in the array BP as follows:\n\ * if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n\ *\n\ * On exit, the triangular factor U or L from the Cholesky\n\ * factorization B = U**T*U or B = L*L**T, in the same storage\n\ * format as B.\n\ *\n\ * VL (input) DOUBLE PRECISION\n\ * VU (input) DOUBLE PRECISION\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) DOUBLE PRECISION\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less than\n\ * or equal to zero, then EPS*|T| will be used in its place,\n\ * where |T| is the 1-norm of the tridiagonal matrix obtained\n\ * by reducing A to tridiagonal form.\n\ *\n\ * Eigenvalues will be computed most accurately when ABSTOL is\n\ * set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n\ * If this routine returns with INFO>0, indicating that some\n\ * eigenvectors did not converge, try setting ABSTOL to\n\ * 2*DLAMCH('S').\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * On normal exit, the first M elements contain the selected\n\ * eigenvalues in ascending order.\n\ *\n\ * Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix A\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * The eigenvectors are normalized as follows:\n\ * if ITYPE = 1 or 2, Z**T*B*Z = I;\n\ * if ITYPE = 3, Z**T*inv(B)*Z = I.\n\ *\n\ * If an eigenvector fails to converge, then that column of Z\n\ * contains the latest approximation to the eigenvector, and the\n\ * index of the eigenvector is returned in IFAIL.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (8*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (5*N)\n\ *\n\ * IFAIL (output) INTEGER array, dimension (N)\n\ * If JOBZ = 'V', then if INFO = 0, the first M elements of\n\ * IFAIL are zero. If INFO > 0, then IFAIL contains the\n\ * indices of the eigenvectors that failed to converge.\n\ * If JOBZ = 'N', then IFAIL is not referenced.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: DPPTRF or DSPEVX returned an error code:\n\ * <= N: if INFO = i, DSPEVX failed to converge;\n\ * i eigenvectors failed to converge. Their indices\n\ * are stored in array IFAIL.\n\ * > N: if INFO = N + i, for 1 <= i <= N, then the leading\n\ * minor of order i of B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL ALLEIG, INDEIG, UPPER, VALEIG, WANTZ\n CHARACTER TRANS\n INTEGER J\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DPPTRF, DSPEVX, DSPGST, DTPMV, DTPSV, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlasd50000644000175000017500000000465012502223526016371 0ustar uwabamiuwabami--- :name: dlasd5 :md5sum: a3ba28af47ea722e3d88224bb102319d :category: :subroutine :arguments: - i: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - "2" - z: :type: doublereal :intent: input :dims: - "2" - delta: :type: doublereal :intent: output :dims: - "2" - rho: :type: doublereal :intent: input - dsigma: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - "2" :substitutions: {} :fortran_help: " SUBROUTINE DLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This subroutine computes the square root of the I-th eigenvalue\n\ * of a positive symmetric rank-one modification of a 2-by-2 diagonal\n\ * matrix\n\ *\n\ * diag( D ) * diag( D ) + RHO * Z * transpose(Z) .\n\ *\n\ * The diagonal entries in the array D are assumed to satisfy\n\ *\n\ * 0 <= D(i) < D(j) for i < j .\n\ *\n\ * We also assume RHO > 0 and that the Euclidean norm of the vector\n\ * Z is one.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * I (input) INTEGER\n\ * The index of the eigenvalue to be computed. I = 1 or I = 2.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension ( 2 )\n\ * The original eigenvalues. We assume 0 <= D(1) < D(2).\n\ *\n\ * Z (input) DOUBLE PRECISION array, dimension ( 2 )\n\ * The components of the updating vector.\n\ *\n\ * DELTA (output) DOUBLE PRECISION array, dimension ( 2 )\n\ * Contains (D(j) - sigma_I) in its j-th component.\n\ * The vector DELTA contains the information necessary\n\ * to construct the eigenvectors.\n\ *\n\ * RHO (input) DOUBLE PRECISION\n\ * The scalar in the symmetric updating formula.\n\ *\n\ * DSIGMA (output) DOUBLE PRECISION\n\ * The computed sigma_I, the I-th updated eigenvalue.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension ( 2 )\n\ * WORK contains (D(j) + sigma_I) in its j-th component.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ren-Cang Li, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlatdf0000644000175000017500000001154412502223526016453 0ustar uwabamiuwabami--- :name: dlatdf :md5sum: 69cfce3953f1837f451afd56bf000e43 :category: :subroutine :arguments: - ijob: :type: integer :intent: input - n: :type: integer :intent: input - z: :type: doublereal :intent: input :dims: - ldz - n - ldz: :type: integer :intent: input - rhs: :type: doublereal :intent: input/output :dims: - n - rdsum: :type: doublereal :intent: input/output - rdscal: :type: doublereal :intent: input/output - ipiv: :type: integer :intent: input :dims: - n - jpiv: :type: integer :intent: input :dims: - n :substitutions: {} :fortran_help: " SUBROUTINE DLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, JPIV )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLATDF uses the LU factorization of the n-by-n matrix Z computed by\n\ * DGETC2 and computes a contribution to the reciprocal Dif-estimate\n\ * by solving Z * x = b for x, and choosing the r.h.s. b such that\n\ * the norm of x is as large as possible. On entry RHS = b holds the\n\ * contribution from earlier solved sub-systems, and on return RHS = x.\n\ *\n\ * The factorization of Z returned by DGETC2 has the form Z = P*L*U*Q,\n\ * where P and Q are permutation matrices. L is lower triangular with\n\ * unit diagonal elements and U is upper triangular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * IJOB (input) INTEGER\n\ * IJOB = 2: First compute an approximative null-vector e\n\ * of Z using DGECON, e is normalized and solve for\n\ * Zx = +-e - f with the sign giving the greater value\n\ * of 2-norm(x). About 5 times as expensive as Default.\n\ * IJOB .ne. 2: Local look ahead strategy where all entries of\n\ * the r.h.s. b is choosen as either +1 or -1 (Default).\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Z.\n\ *\n\ * Z (input) DOUBLE PRECISION array, dimension (LDZ, N)\n\ * On entry, the LU part of the factorization of the n-by-n\n\ * matrix Z computed by DGETC2: Z = P * L * U * Q\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDA >= max(1, N).\n\ *\n\ * RHS (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, RHS contains contributions from other subsystems.\n\ * On exit, RHS contains the solution of the subsystem with\n\ * entries acoording to the value of IJOB (see above).\n\ *\n\ * RDSUM (input/output) DOUBLE PRECISION\n\ * On entry, the sum of squares of computed contributions to\n\ * the Dif-estimate under computation by DTGSYL, where the\n\ * scaling factor RDSCAL (see below) has been factored out.\n\ * On exit, the corresponding sum of squares updated with the\n\ * contributions from the current sub-system.\n\ * If TRANS = 'T' RDSUM is not touched.\n\ * NOTE: RDSUM only makes sense when DTGSY2 is called by STGSYL.\n\ *\n\ * RDSCAL (input/output) DOUBLE PRECISION\n\ * On entry, scaling factor used to prevent overflow in RDSUM.\n\ * On exit, RDSCAL is updated w.r.t. the current contributions\n\ * in RDSUM.\n\ * If TRANS = 'T', RDSCAL is not touched.\n\ * NOTE: RDSCAL only makes sense when DTGSY2 is called by\n\ * DTGSYL.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N).\n\ * The pivot indices; for 1 <= i <= N, row i of the\n\ * matrix has been interchanged with row IPIV(i).\n\ *\n\ * JPIV (input) INTEGER array, dimension (N).\n\ * The pivot indices; for 1 <= j <= N, column j of the\n\ * matrix has been interchanged with column JPIV(j).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * This routine is a further developed implementation of algorithm\n\ * BSOLVE in [1] using complete pivoting in the LU factorization.\n\ *\n\ * [1] Bo Kagstrom and Lars Westin,\n\ * Generalized Schur Methods with Condition Estimators for\n\ * Solving the Generalized Sylvester Equation, IEEE Transactions\n\ * on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.\n\ *\n\ * [2] Peter Poromaa,\n\ * On Efficient and Robust Estimators for the Separation\n\ * between two Regular Matrix Pairs with Applications in\n\ * Condition Estimation. Report IMINF-95.05, Departement of\n\ * Computing Science, Umea University, S-901 87 Umea, Sweden, 1995.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dtftri0000644000175000017500000001405212502223526016506 0ustar uwabamiuwabami--- :name: dtftri :md5sum: 0a233694c5876684d380213ab04de7a1 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DTFTRI( TRANSR, UPLO, DIAG, N, A, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTFTRI computes the inverse of a triangular matrix A stored in RFP\n\ * format.\n\ *\n\ * This is a Level 3 BLAS version of the algorithm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': The Normal TRANSR of RFP A is stored;\n\ * = 'T': The Transpose TRANSR of RFP A is stored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (0:nt-1);\n\ * nt=N*(N+1)/2. On entry, the triangular factor of a Hermitian\n\ * Positive Definite matrix A in RFP format. RFP format is\n\ * described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n\ * then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n\ * (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is\n\ * the transpose of RFP A as defined when\n\ * TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n\ * follows: If UPLO = 'U' the RFP A contains the nt elements of\n\ * upper packed A; If UPLO = 'L' the RFP A contains the nt\n\ * elements of lower packed A. The LDA of RFP A is (N+1)/2 when\n\ * TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is\n\ * even and N is odd. See the Note below for more details.\n\ *\n\ * On exit, the (triangular) inverse of the original matrix, in\n\ * the same storage format.\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, A(i,i) is exactly zero. The triangular\n\ * matrix is singular and its inverse can not be computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * We first consider Rectangular Full Packed (RFP) Format when N is\n\ * even. We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * the transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * the transpose of the last three columns of AP lower.\n\ * This covers the case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 04 05 33 43 53\n\ * 13 14 15 00 44 54\n\ * 23 24 25 10 11 55\n\ * 33 34 35 20 21 22\n\ * 00 44 45 30 31 32\n\ * 01 11 55 40 41 42\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We then consider Rectangular Full Packed (RFP) Format when N is\n\ * odd. We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * the transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * the transpose of the last two columns of AP lower.\n\ * This covers the case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 03 04 00 33 43\n\ * 12 13 14 10 11 44\n\ * 22 23 24 20 21 22\n\ * 00 33 34 30 31 32\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zsytri2x0000644000175000017500000000533012502223526017027 0ustar uwabamiuwabami--- :name: zsytri2x :md5sum: df62985a9e25f0e54a4d290a33c25c5b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublecomplex :intent: workspace :dims: - n+nb+1 - nb+3 - nb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSYTRI2X computes the inverse of a complex symmetric indefinite matrix\n\ * A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n\ * ZSYTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE COMPLEX array, dimension (LDA,N)\n\ * On entry, the NNB diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L as computed by ZSYTRF.\n\ *\n\ * On exit, if INFO = 0, the (symmetric) inverse of the original\n\ * matrix. If UPLO = 'U', the upper triangular part of the\n\ * inverse is formed and the part of A below the diagonal is not\n\ * referenced; if UPLO = 'L' the lower triangular part of the\n\ * inverse is formed and the part of A above the diagonal is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the NNB structure of D\n\ * as determined by ZSYTRF.\n\ *\n\ * WORK (workspace) DOUBLE COMPLEX array, dimension (N+NNB+1,NNB+3)\n\ *\n\ * NB (input) INTEGER\n\ * Block size\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, D(i,i) = 0; the matrix is singular and its\n\ * inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dorgbr0000644000175000017500000001054612502223526016475 0ustar uwabamiuwabami--- :name: dorgbr :md5sum: 77e112eb51464cf117c5be590352f159 :category: :subroutine :arguments: - vect: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - MIN(m,k) - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DORGBR generates one of the real orthogonal matrices Q or P**T\n\ * determined by DGEBRD when reducing a real matrix A to bidiagonal\n\ * form: A = Q * B * P**T. Q and P**T are defined as products of\n\ * elementary reflectors H(i) or G(i) respectively.\n\ *\n\ * If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q\n\ * is of order M:\n\ * if m >= k, Q = H(1) H(2) . . . H(k) and DORGBR returns the first n\n\ * columns of Q, where m >= n >= k;\n\ * if m < k, Q = H(1) H(2) . . . H(m-1) and DORGBR returns Q as an\n\ * M-by-M matrix.\n\ *\n\ * If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T\n\ * is of order N:\n\ * if k < n, P**T = G(k) . . . G(2) G(1) and DORGBR returns the first m\n\ * rows of P**T, where n >= m >= k;\n\ * if k >= n, P**T = G(n-1) . . . G(2) G(1) and DORGBR returns P**T as\n\ * an N-by-N matrix.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * VECT (input) CHARACTER*1\n\ * Specifies whether the matrix Q or the matrix P**T is\n\ * required, as defined in the transformation applied by DGEBRD:\n\ * = 'Q': generate Q;\n\ * = 'P': generate P**T.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q or P**T to be returned.\n\ * M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q or P**T to be returned.\n\ * N >= 0.\n\ * If VECT = 'Q', M >= N >= min(M,K);\n\ * if VECT = 'P', N >= M >= min(N,K).\n\ *\n\ * K (input) INTEGER\n\ * If VECT = 'Q', the number of columns in the original M-by-K\n\ * matrix reduced by DGEBRD.\n\ * If VECT = 'P', the number of rows in the original K-by-N\n\ * matrix reduced by DGEBRD.\n\ * K >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the vectors which define the elementary reflectors,\n\ * as returned by DGEBRD.\n\ * On exit, the M-by-N matrix Q or P**T.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) DOUBLE PRECISION array, dimension\n\ * (min(M,K)) if VECT = 'Q'\n\ * (min(N,K)) if VECT = 'P'\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i) or G(i), which determines Q or P**T, as\n\ * returned by DGEBRD in its array argument TAUQ or TAUP.\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,min(M,N)).\n\ * For optimum performance LWORK >= min(M,N)*NB, where NB\n\ * is the 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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dtrttp0000644000175000017500000000437612502223526016543 0ustar uwabamiuwabami--- :name: dtrttp :md5sum: e1a6dcbcddf23f887480015b02d38eb7 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ap: :type: doublereal :intent: output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DTRTTP( UPLO, N, A, LDA, AP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTRTTP copies a triangular matrix A from full format (TR) to standard\n\ * packed format (TP).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular.\n\ * = 'L': A is lower triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices AP and A. N >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On exit, the triangular matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AP (output) DOUBLE PRECISION array, dimension (N*(N+1)/2\n\ * On exit, the upper or lower triangular matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zdrscl0000644000175000017500000000263112502223526016513 0ustar uwabamiuwabami--- :name: zdrscl :md5sum: e7cb13451d543134640cbced3e3cc991 :category: :subroutine :arguments: - n: :type: integer :intent: input - sa: :type: doublereal :intent: input - sx: :type: doublecomplex :intent: input/output :dims: - 1+(n-1)*abs(incx) - incx: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE ZDRSCL( N, SA, SX, INCX )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZDRSCL multiplies an n-element complex vector x by the real scalar\n\ * 1/a. This is done without overflow or underflow as long as\n\ * the final result x/a does not overflow or underflow.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of components of the vector x.\n\ *\n\ * SA (input) DOUBLE PRECISION\n\ * The scalar a which is used to divide each component of x.\n\ * SA must be >= 0, or the subroutine will divide by zero.\n\ *\n\ * SX (input/output) COMPLEX*16 array, dimension\n\ * (1+(N-1)*abs(INCX))\n\ * The n-element vector x.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between successive values of the vector SX.\n\ * > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chpevx0000644000175000017500000001625612502223525016516 0ustar uwabamiuwabami--- :name: chpevx :md5sum: 5df9981285d3b1ae5440a199960342f7 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - ldap - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - 7*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE CHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHPEVX computes selected eigenvalues and, optionally, eigenvectors\n\ * of a complex Hermitian matrix A in packed storage.\n\ * Eigenvalues/vectors can be selected by specifying either a range of\n\ * values or a range of indices for the desired eigenvalues.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found;\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found;\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, AP is overwritten by values generated during the\n\ * reduction to tridiagonal form. If UPLO = 'U', the diagonal\n\ * and first superdiagonal of the tridiagonal matrix T overwrite\n\ * the corresponding elements of A, and if UPLO = 'L', the\n\ * diagonal and first subdiagonal of T overwrite the\n\ * corresponding elements of A.\n\ *\n\ * VL (input) REAL\n\ * VU (input) REAL\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) REAL\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less than\n\ * or equal to zero, then EPS*|T| will be used in its place,\n\ * where |T| is the 1-norm of the tridiagonal matrix obtained\n\ * by reducing AP to tridiagonal form.\n\ *\n\ * Eigenvalues will be computed most accurately when ABSTOL is\n\ * set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n\ * If this routine returns with INFO>0, indicating that some\n\ * eigenvectors did not converge, try setting ABSTOL to\n\ * 2*SLAMCH('S').\n\ *\n\ * See \"Computing Small Singular Values of Bidiagonal Matrices\n\ * with Guaranteed High Relative Accuracy,\" by Demmel and\n\ * Kahan, LAPACK Working Note #3.\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * If INFO = 0, the selected eigenvalues in ascending order.\n\ *\n\ * Z (output) COMPLEX array, dimension (LDZ, max(1,M))\n\ * If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix A\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * If an eigenvector fails to converge, then that column of Z\n\ * contains the latest approximation to the eigenvector, and\n\ * the index of the eigenvector is returned in IFAIL.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (7*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (5*N)\n\ *\n\ * IFAIL (output) INTEGER array, dimension (N)\n\ * If JOBZ = 'V', then if INFO = 0, the first M elements of\n\ * IFAIL are zero. If INFO > 0, then IFAIL contains the\n\ * indices of the eigenvectors that failed to converge.\n\ * If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n\ * Their indices are stored in array IFAIL.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chbevx0000644000175000017500000001762212502223525016476 0ustar uwabamiuwabami--- :name: chbevx :md5sum: e914f49f4d5aed935f95c281139db9ec :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - q: :type: complex :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - n - rwork: :type: real :intent: workspace :dims: - 7*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" ldq: "lsame_(&jobz,\"V\") ? MAX(1,n) : 0" :fortran_help: " SUBROUTINE CHBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHBEVX computes selected eigenvalues and, optionally, eigenvectors\n\ * of a complex Hermitian band matrix A. Eigenvalues and eigenvectors\n\ * can be selected by specifying either a range of values or a range of\n\ * indices for the desired eigenvalues.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found;\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found;\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) COMPLEX array, dimension (LDAB, N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * On exit, AB is overwritten by values generated during the\n\ * reduction to tridiagonal form.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD + 1.\n\ *\n\ * Q (output) COMPLEX array, dimension (LDQ, N)\n\ * If JOBZ = 'V', the N-by-N unitary matrix used in the\n\ * reduction to tridiagonal form.\n\ * If JOBZ = 'N', the array Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. If JOBZ = 'V', then\n\ * LDQ >= max(1,N).\n\ *\n\ * VL (input) REAL\n\ * VU (input) REAL\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) REAL\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less than\n\ * or equal to zero, then EPS*|T| will be used in its place,\n\ * where |T| is the 1-norm of the tridiagonal matrix obtained\n\ * by reducing AB to tridiagonal form.\n\ *\n\ * Eigenvalues will be computed most accurately when ABSTOL is\n\ * set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n\ * If this routine returns with INFO>0, indicating that some\n\ * eigenvectors did not converge, try setting ABSTOL to\n\ * 2*SLAMCH('S').\n\ *\n\ * See \"Computing Small Singular Values of Bidiagonal Matrices\n\ * with Guaranteed High Relative Accuracy,\" by Demmel and\n\ * Kahan, LAPACK Working Note #3.\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * The first M elements contain the selected eigenvalues in\n\ * ascending order.\n\ *\n\ * Z (output) COMPLEX array, dimension (LDZ, max(1,M))\n\ * If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix A\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * If an eigenvector fails to converge, then that column of Z\n\ * contains the latest approximation to the eigenvector, and the\n\ * index of the eigenvector is returned in IFAIL.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (7*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (5*N)\n\ *\n\ * IFAIL (output) INTEGER array, dimension (N)\n\ * If JOBZ = 'V', then if INFO = 0, the first M elements of\n\ * IFAIL are zero. If INFO > 0, then IFAIL contains the\n\ * indices of the eigenvectors that failed to converge.\n\ * If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n\ * Their indices are stored in array IFAIL.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgesc20000644000175000017500000000452412502223525016362 0ustar uwabamiuwabami--- :name: cgesc2 :md5sum: 0ec1cb4fcf962fa0ec5a158eaccd46cf :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - rhs: :type: complex :intent: input/output :dims: - n - ipiv: :type: integer :intent: input :dims: - n - jpiv: :type: integer :intent: input :dims: - n - scale: :type: real :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGESC2 solves a system of linear equations\n\ *\n\ * A * X = scale* RHS\n\ *\n\ * with a general N-by-N matrix A using the LU factorization with\n\ * complete pivoting computed by CGETC2.\n\ *\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix A.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA, N)\n\ * On entry, the LU part of the factorization of the n-by-n\n\ * matrix A computed by CGETC2: A = P * L * U * Q\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1, N).\n\ *\n\ * RHS (input/output) COMPLEX array, dimension N.\n\ * On entry, the right hand side vector b.\n\ * On exit, the solution vector X.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N).\n\ * The pivot indices; for 1 <= i <= N, row i of the\n\ * matrix has been interchanged with row IPIV(i).\n\ *\n\ * JPIV (input) INTEGER array, dimension (N).\n\ * The pivot indices; for 1 <= j <= N, column j of the\n\ * matrix has been interchanged with column JPIV(j).\n\ *\n\ * SCALE (output) REAL\n\ * On exit, SCALE contains the scale factor. SCALE is chosen\n\ * 0 <= SCALE <= 1 to prevent owerflow in the solution.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cpbsvx0000644000175000017500000002744512502223525016530 0ustar uwabamiuwabami--- :name: cpbsvx :md5sum: dd6dc051e36b6752af3418cbf8133450 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: complex :intent: input/output :dims: - ldafb - n - ldafb: :type: integer :intent: input - equed: :type: char :intent: input/output - s: :type: real :intent: input/output :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE CPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPBSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to\n\ * compute the solution to a complex system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N Hermitian positive definite band matrix and X\n\ * and B are N-by-NRHS matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', real scaling factors are computed to equilibrate\n\ * the system:\n\ * diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n\ *\n\ * 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n\ * factor the matrix A (after equilibration if FACT = 'E') as\n\ * A = U**H * U, if UPLO = 'U', or\n\ * A = L * L**H, if UPLO = 'L',\n\ * where U is an upper triangular band matrix, and L is a lower\n\ * triangular band matrix.\n\ *\n\ * 3. If the leading i-by-i principal minor is not positive definite,\n\ * then the routine returns with INFO = i. Otherwise, the factored\n\ * form of A is used to estimate the condition number of the matrix\n\ * A. If the reciprocal of the condition number is less than machine\n\ * precision, INFO = N+1 is returned as a warning, but the routine\n\ * still goes on to solve for X and compute error bounds as\n\ * described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(S) so that it solves the original system before\n\ * equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AFB contains the factored form of A.\n\ * If EQUED = 'Y', the matrix A has been equilibrated\n\ * with scaling factors given by S. AB and AFB will not\n\ * be modified.\n\ * = 'N': The matrix A will be copied to AFB and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AFB and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right-hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AB (input/output) COMPLEX array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix A, stored in the first KD+1 rows of the array, except\n\ * if FACT = 'F' and EQUED = 'Y', then A must contain the\n\ * equilibrated matrix diag(S)*A*diag(S). The j-th column of A\n\ * is stored in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).\n\ * See below for further details.\n\ *\n\ * On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n\ * diag(S)*A*diag(S).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array A. LDAB >= KD+1.\n\ *\n\ * AFB (input or output) COMPLEX array, dimension (LDAFB,N)\n\ * If FACT = 'F', then AFB is an input argument and on entry\n\ * contains the triangular factor U or L from the Cholesky\n\ * factorization A = U**H*U or A = L*L**H of the band matrix\n\ * A, in the same storage format as A (see AB). If EQUED = 'Y',\n\ * then AFB is the factored form of the equilibrated matrix A.\n\ *\n\ * If FACT = 'N', then AFB is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U**H*U or A = L*L**H.\n\ *\n\ * If FACT = 'E', then AFB is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U**H*U or A = L*L**H of the equilibrated\n\ * matrix A (see the description of A for the form of the\n\ * equilibrated matrix).\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= KD+1.\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'Y': Equilibration was done, i.e., A has been replaced by\n\ * diag(S) * A * diag(S).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * S (input or output) REAL array, dimension (N)\n\ * The scale factors for A; not accessed if EQUED = 'N'. S is\n\ * an input argument if FACT = 'F'; otherwise, S is an output\n\ * argument. If FACT = 'F' and EQUED = 'Y', each element of S\n\ * must be positive.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n\ * B is overwritten by diag(S) * B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n\ * the original system of equations. Note that if EQUED = 'Y',\n\ * A and B are modified on exit, and the solution to the\n\ * equilibrated system is inv(diag(S))*X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A after equilibration (if done). If RCOND is less than the\n\ * machine precision (in particular, if RCOND = 0), the matrix\n\ * is singular to working precision. This condition is\n\ * indicated by a return code of INFO > 0.\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\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, and i is\n\ * <= N: the leading minor of order i of A is\n\ * not positive definite, so the factorization\n\ * could not be completed, and the solution has not\n\ * been computed. RCOND = 0 is returned.\n\ * = N+1: U is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * N = 6, KD = 2, and UPLO = 'U':\n\ *\n\ * Two-dimensional storage of the Hermitian matrix A:\n\ *\n\ * a11 a12 a13\n\ * a22 a23 a24\n\ * a33 a34 a35\n\ * a44 a45 a46\n\ * a55 a56\n\ * (aij=conjg(aji)) a66\n\ *\n\ * Band storage of the upper triangle of A:\n\ *\n\ * * * a13 a24 a35 a46\n\ * * a12 a23 a34 a45 a56\n\ * a11 a22 a33 a44 a55 a66\n\ *\n\ * Similarly, if UPLO = 'L' the format of A is as follows:\n\ *\n\ * a11 a22 a33 a44 a55 a66\n\ * a21 a32 a43 a54 a65 *\n\ * a31 a42 a53 a64 * *\n\ *\n\ * Array elements marked * are not used by the routine.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dladiv0000644000175000017500000000275212502223526016461 0ustar uwabamiuwabami--- :name: dladiv :md5sum: 41da7dda9474acb9983598430ee07a80 :category: :subroutine :arguments: - a: :type: doublereal :intent: input - b: :type: doublereal :intent: input - c: :type: doublereal :intent: input - d: :type: doublereal :intent: input - p: :type: doublereal :intent: output - q: :type: doublereal :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLADIV( A, B, C, D, P, Q )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLADIV performs complex division in real arithmetic\n\ *\n\ * a + i*b\n\ * p + i*q = ---------\n\ * c + i*d\n\ *\n\ * The algorithm is due to Robert L. Smith and can be found\n\ * in D. Knuth, The art of Computer Programming, Vol.2, p.195\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * A (input) DOUBLE PRECISION\n\ * B (input) DOUBLE PRECISION\n\ * C (input) DOUBLE PRECISION\n\ * D (input) DOUBLE PRECISION\n\ * The scalars a, b, c, and d in the above expression.\n\ *\n\ * P (output) DOUBLE PRECISION\n\ * Q (output) DOUBLE PRECISION\n\ * The scalars p and q in the above expression.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n DOUBLE PRECISION E, F\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dspev0000644000175000017500000000655212502223526016341 0ustar uwabamiuwabami--- :name: dspev :md5sum: abbf7fb1bb1c2e05e3a416106fd62a7b :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - ldap - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSPEV computes all the eigenvalues and, optionally, eigenvectors of a\n\ * real symmetric matrix A in packed storage.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, AP is overwritten by values generated during the\n\ * reduction to tridiagonal form. If UPLO = 'U', the diagonal\n\ * and first superdiagonal of the tridiagonal matrix T overwrite\n\ * the corresponding elements of A, and if UPLO = 'L', the\n\ * diagonal and first subdiagonal of T overwrite the\n\ * corresponding elements of A.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n\ * eigenvectors of the matrix A, with the i-th column of Z\n\ * holding the eigenvector associated with W(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\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 algorithm failed to converge; i\n\ * off-diagonal elements of an intermediate tridiagonal\n\ * form did not converge to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cla_gercond_c0000644000175000017500000000717512502223525017763 0ustar uwabamiuwabami--- :name: cla_gercond_c :md5sum: 973bbc06a0c6b2901d91af027d777425 :category: :function :type: real :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - c: :type: real :intent: input :dims: - n - capply: :type: logical :intent: input - info: :type: integer :intent: output - work: :type: complex :intent: input :dims: - 2*n - rwork: :type: real :intent: input :dims: - n :substitutions: {} :fortran_help: " REAL FUNCTION CLA_GERCOND_C( TRANS, N, A, LDA, AF, LDAF, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n\ * Purpose\n\ * =======\n\ * \n\ * CLA_GERCOND_C computes the infinity norm condition number of\n\ * op(A) * inv(diag(C)) where C is a REAL vector.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate Transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX array, dimension (LDAF,N)\n\ * The factors L and U from the factorization\n\ * A = P*L*U as computed by CGETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from the factorization A = P*L*U\n\ * as computed by CGETRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * C (input) REAL array, dimension (N)\n\ * The vector C in the formula op(A) * inv(diag(C)).\n\ *\n\ * CAPPLY (input) LOGICAL\n\ * If .TRUE. then access the vector C in the formula above.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * i > 0: The ith argument is invalid.\n\ *\n\ * WORK (input) COMPLEX array, dimension (2*N).\n\ * Workspace.\n\ *\n\ * RWORK (input) REAL array, dimension (N).\n\ * Workspace.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE, I, J\n REAL AINVNM, ANORM, TMP\n COMPLEX ZDUM\n\ * ..\n\ * .. Local Arrays ..\n INTEGER ISAVE( 3 )\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CLACN2, CGETRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, REAL, AIMAG\n\ * ..\n\ * .. Statement Functions ..\n REAL CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dsyconv0000644000175000017500000000513512502223526016701 0ustar uwabamiuwabami--- :name: dsyconv :md5sum: 7d1a9b6de72c915da71b7d057f380fea :category: :subroutine :arguments: - uplo: :type: char :intent: input - way: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublereal :intent: workspace :dims: - MAX(1,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DSYCONV( UPLO, WAY, N, A, LDA, IPIV, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSYCONV convert A given by TRF into L and D and vice-versa.\n\ * Get Non-diag elements of D (returned in workspace) and \n\ * apply or reverse permutation done in TRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ * \n\ * WAY (input) CHARACTER*1\n\ * = 'C': Convert \n\ * = 'R': Revert\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by DSYTRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by DSYTRF.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of WORK. LWORK >=1. \n\ * LWORK = N\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sorm2l0000644000175000017500000000721112502223526016427 0ustar uwabamiuwabami--- :name: sorm2l :md5sum: 7a7499c55913697ee8e4843bc6dd133c :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SORM2L overwrites the general real m by n matrix C with\n\ *\n\ * Q * C if SIDE = 'L' and TRANS = 'N', or\n\ *\n\ * Q'* C if SIDE = 'L' and TRANS = 'T', or\n\ *\n\ * C * Q if SIDE = 'R' and TRANS = 'N', or\n\ *\n\ * C * Q' if SIDE = 'R' and TRANS = 'T',\n\ *\n\ * where Q is a real orthogonal matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(k) . . . H(2) H(1)\n\ *\n\ * as returned by SGEQLF. Q is of order m if SIDE = 'L' and of order n\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q' from the Left\n\ * = 'R': apply Q or Q' from the Right\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': apply Q (No transpose)\n\ * = 'T': apply Q' (Transpose)\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,K)\n\ * The i-th column must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * SGEQLF in the last k columns of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ * If SIDE = 'L', LDA >= max(1,M);\n\ * if SIDE = 'R', LDA >= max(1,N).\n\ *\n\ * TAU (input) REAL array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by SGEQLF.\n\ *\n\ * C (input/output) REAL array, dimension (LDC,N)\n\ * On entry, the m by n matrix C.\n\ * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) REAL array, dimension\n\ * (N) if SIDE = 'L',\n\ * (M) if SIDE = 'R'\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slae20000644000175000017500000000347612502223526016230 0ustar uwabamiuwabami--- :name: slae2 :md5sum: 18f4efd60fb42dab6017abab77961a75 :category: :subroutine :arguments: - a: :type: real :intent: input - b: :type: real :intent: input - c: :type: real :intent: input - rt1: :type: real :intent: output - rt2: :type: real :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLAE2( A, B, C, RT1, RT2 )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix\n\ * [ A B ]\n\ * [ B C ].\n\ * On return, RT1 is the eigenvalue of larger absolute value, and RT2\n\ * is the eigenvalue of smaller absolute value.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * A (input) REAL\n\ * The (1,1) element of the 2-by-2 matrix.\n\ *\n\ * B (input) REAL\n\ * The (1,2) and (2,1) elements of the 2-by-2 matrix.\n\ *\n\ * C (input) REAL\n\ * The (2,2) element of the 2-by-2 matrix.\n\ *\n\ * RT1 (output) REAL\n\ * The eigenvalue of larger absolute value.\n\ *\n\ * RT2 (output) REAL\n\ * The eigenvalue of smaller absolute value.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * RT1 is accurate to a few ulps barring over/underflow.\n\ *\n\ * RT2 may be inaccurate if there is massive cancellation in the\n\ * determinant A*C-B*B; higher precision or correctly rounded or\n\ * correctly truncated arithmetic would be needed to compute RT2\n\ * accurately in all cases.\n\ *\n\ * Overflow is possible only if RT1 is within a factor of 5 of overflow.\n\ * Underflow is harmless if the input data is 0 or exceeds\n\ * underflow_threshold / macheps.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slaein0000644000175000017500000001020412502223526016460 0ustar uwabamiuwabami--- :name: slaein :md5sum: db0ea0cba06ef1453f7435398c35d394 :category: :subroutine :arguments: - rightv: :type: logical :intent: input - noinit: :type: logical :intent: input - n: :type: integer :intent: input - h: :type: real :intent: input :dims: - ldh - n - ldh: :type: integer :intent: input - wr: :type: real :intent: input - wi: :type: real :intent: input - vr: :type: real :intent: input/output :dims: - n - vi: :type: real :intent: input/output :dims: - n - b: :type: real :intent: workspace :dims: - ldb - n - ldb: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - n - eps3: :type: real :intent: input - smlnum: :type: real :intent: input - bignum: :type: real :intent: input - info: :type: integer :intent: output :substitutions: ldb: n+1 :fortran_help: " SUBROUTINE SLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B, LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAEIN uses inverse iteration to find a right or left eigenvector\n\ * corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg\n\ * matrix H.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * RIGHTV (input) LOGICAL\n\ * = .TRUE. : compute right eigenvector;\n\ * = .FALSE.: compute left eigenvector.\n\ *\n\ * NOINIT (input) LOGICAL\n\ * = .TRUE. : no initial vector supplied in (VR,VI).\n\ * = .FALSE.: initial vector supplied in (VR,VI).\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H. N >= 0.\n\ *\n\ * H (input) REAL array, dimension (LDH,N)\n\ * The upper Hessenberg matrix H.\n\ *\n\ * LDH (input) INTEGER\n\ * The leading dimension of the array H. LDH >= max(1,N).\n\ *\n\ * WR (input) REAL\n\ * WI (input) REAL\n\ * The real and imaginary parts of the eigenvalue of H whose\n\ * corresponding right or left eigenvector is to be computed.\n\ *\n\ * VR (input/output) REAL array, dimension (N)\n\ * VI (input/output) REAL array, dimension (N)\n\ * On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain\n\ * a real starting vector for inverse iteration using the real\n\ * eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI\n\ * must contain the real and imaginary parts of a complex\n\ * starting vector for inverse iteration using the complex\n\ * eigenvalue (WR,WI); otherwise VR and VI need not be set.\n\ * On exit, if WI = 0.0 (real eigenvalue), VR contains the\n\ * computed real eigenvector; if WI.ne.0.0 (complex eigenvalue),\n\ * VR and VI contain the real and imaginary parts of the\n\ * computed complex eigenvector. The eigenvector is normalized\n\ * so that the component of largest magnitude has magnitude 1;\n\ * here the magnitude of a complex number (x,y) is taken to be\n\ * |x| + |y|.\n\ * VI is not referenced if WI = 0.0.\n\ *\n\ * B (workspace) REAL array, dimension (LDB,N)\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= N+1.\n\ *\n\ * WORK (workspace) REAL array, dimension (N)\n\ *\n\ * EPS3 (input) REAL\n\ * A small machine-dependent value which is used to perturb\n\ * close eigenvalues, and to replace zero pivots.\n\ *\n\ * SMLNUM (input) REAL\n\ * A machine-dependent value close to the underflow threshold.\n\ *\n\ * BIGNUM (input) REAL\n\ * A machine-dependent value close to the overflow threshold.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * = 1: inverse iteration did not converge; VR is set to the\n\ * last iterate, and so is VI if WI.ne.0.0.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgesvxx0000644000175000017500000005506212502223526016710 0ustar uwabamiuwabami--- :name: dgesvxx :md5sum: 66e137ddd86d76cfb4ae5f95a9fce4a7 :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - equed: :type: char :intent: input/output - r: :type: doublereal :intent: input/output :dims: - n - c: :type: doublereal :intent: input/output :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - rpvgrw: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublereal :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " SUBROUTINE DGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGESVXX uses the LU factorization to compute the solution to a\n\ * double precision system of linear equations A * X = B, where A is an\n\ * N-by-N matrix and X and B are N-by-NRHS matrices.\n\ *\n\ * If requested, both normwise and maximum componentwise error bounds\n\ * are returned. DGESVXX will return a solution with a tiny\n\ * guaranteed error (O(eps) where eps is the working machine\n\ * precision) unless the matrix is very ill-conditioned, in which\n\ * case a warning is returned. Relevant condition numbers also are\n\ * calculated and returned.\n\ *\n\ * DGESVXX accepts user-provided factorizations and equilibration\n\ * factors; see the definitions of the FACT and EQUED options.\n\ * Solving with refinement and using a factorization from a previous\n\ * DGESVXX call will also produce a solution with either O(eps)\n\ * errors or warnings, but we cannot make that claim for general\n\ * user-provided factorizations and equilibration factors if they\n\ * differ from what DGESVXX would itself produce.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n\ * the system:\n\ *\n\ * TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n\ * TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n\ * TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n\ *\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n\ * or diag(C)*B (if TRANS = 'T' or 'C').\n\ *\n\ * 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n\ * the matrix A (after equilibration if FACT = 'E') as\n\ *\n\ * A = P * L * U,\n\ *\n\ * where P is a permutation matrix, L is a unit lower triangular\n\ * matrix, and U is upper triangular.\n\ *\n\ * 3. If some U(i,i)=0, so that U is exactly singular, then the\n\ * routine returns with INFO = i. Otherwise, the factored form of A\n\ * is used to estimate the condition number of the matrix A (see\n\ * argument RCOND). If the reciprocal of the condition number is less\n\ * than machine precision, the routine still goes on to solve for X\n\ * and compute error bounds as described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n\ * the routine will use iterative refinement to try to get a small\n\ * error and error bounds. Refinement calculates the residual to at\n\ * least twice the working precision.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n\ * that it solves the original system before equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AF and IPIV contain the factored form of A.\n\ * If EQUED is not 'N', the matrix A has been\n\ * equilibrated with scaling factors given by R and C.\n\ * A, AF, and IPIV are not modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AF and factored.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate Transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is\n\ * not 'N', then A must have been equilibrated by the scaling\n\ * factors in R and/or C. A is not modified if FACT = 'F' or\n\ * 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n\ *\n\ * On exit, if EQUED .ne. 'N', A is scaled as follows:\n\ * EQUED = 'R': A := diag(R) * A\n\ * EQUED = 'C': A := A * diag(C)\n\ * EQUED = 'B': A := diag(R) * A * diag(C).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N)\n\ * If FACT = 'F', then AF is an input argument and on entry\n\ * contains the factors L and U from the factorization\n\ * A = P*L*U as computed by DGETRF. If EQUED .ne. 'N', then\n\ * AF is the factored form of the equilibrated matrix A.\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the factors L and U from the factorization A = P*L*U\n\ * of the original matrix A.\n\ *\n\ * If FACT = 'E', then AF is an output argument and on exit\n\ * returns the factors L and U from the factorization A = P*L*U\n\ * of the equilibrated matrix A (see the description of A for\n\ * the form of the equilibrated matrix).\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * as computed by DGETRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * of the original matrix A.\n\ *\n\ * If FACT = 'E', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * of the equilibrated matrix A.\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * R (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'R' or 'B', A is\n\ * multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n\ * is not accessed. R is an input argument if FACT = 'F';\n\ * otherwise, R is an output argument. If FACT = 'F' and\n\ * EQUED = 'R' or 'B', each element of R must be positive.\n\ * If R is output, each element of R is a power of the radix.\n\ * If R is input, each element of R should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * C (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The column scale factors for A. If EQUED = 'C' or 'B', A is\n\ * multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n\ * is not accessed. C is an input argument if FACT = 'F';\n\ * otherwise, C is an output argument. If FACT = 'F' and\n\ * EQUED = 'C' or 'B', each element of C must be positive.\n\ * If C is output, each element of C is a power of the radix.\n\ * If C is input, each element of C should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit,\n\ * if EQUED = 'N', B is not modified;\n\ * if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n\ * diag(R)*B;\n\ * if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n\ * overwritten by diag(C)*B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * If INFO = 0, the N-by-NRHS solution matrix X to the original\n\ * system of equations. Note that A and B are modified on exit\n\ * if EQUED .ne. 'N', and the solution to the equilibrated system is\n\ * inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n\ * inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * RPVGRW (output) DOUBLE PRECISION\n\ * Reciprocal pivot growth. On exit, this contains the reciprocal\n\ * pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n\ * norm is used. If this is much less than 1, then the stability of\n\ * the LU factorization of the (equilibrated) matrix A could be poor.\n\ * This also means that the solution X, estimated condition numbers,\n\ * and error bounds could be unreliable. If factorization fails with\n\ * 0 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssyrfsx0000644000175000017500000003730212502223526016736 0ustar uwabamiuwabami--- :name: ssyrfsx :md5sum: dfa0d302a32611400da950bcd1072380 :category: :subroutine :arguments: - uplo: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - s: :type: real :intent: input/output :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: real :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " SUBROUTINE SSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSYRFSX improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is symmetric indefinite, and\n\ * provides error bounds and backward error estimates for the\n\ * solution. In addition to normwise error bound, the code provides\n\ * maximum componentwise error bound if possible. See comments for\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.\n\ *\n\ * The original system of linear equations may have been equilibrated\n\ * before calling this routine, as described by arguments EQUED and S\n\ * below. In this case, the solution and error bounds returned are\n\ * for the original unequilibrated system.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * EQUED (input) CHARACTER*1\n\ * Specifies the form of equilibration that was done to A\n\ * before calling this routine. This is needed to compute\n\ * the solution and error bounds correctly.\n\ * = 'N': No equilibration\n\ * = 'Y': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(S) * A * diag(S).\n\ * The right hand side B has been changed accordingly.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular\n\ * part of the matrix A, and the strictly lower triangular\n\ * part of A is not referenced. If UPLO = 'L', the leading\n\ * N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) REAL array, dimension (LDAF,N)\n\ * The factored form of the matrix A. AF contains the block\n\ * diagonal matrix D and the multipliers used to obtain the\n\ * factor U or L from the factorization A = U*D*U**T or A =\n\ * L*D*L**T as computed by SSYTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by SSYTRF.\n\ *\n\ * S (input or output) REAL array, dimension (N)\n\ * The scale factors for A. If EQUED = 'Y', A is multiplied on\n\ * the left and right by diag(S). S is an input argument if FACT =\n\ * 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n\ * = 'Y', each element of S must be positive. If S is output, each\n\ * element of S is a power of the radix. If S is input, each element\n\ * of S should be a power of the radix to ensure a reliable solution\n\ * and error estimates. Scaling by powers of the radix does not cause\n\ * rounding errors unless the result underflows or overflows.\n\ * Rounding errors during scaling lead to refining with a matrix that\n\ * is not equivalent to the input matrix, producing error estimates\n\ * that may not be reliable.\n\ *\n\ * B (input) REAL array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) REAL array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by SGETRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * Componentwise relative backward error. This is the\n\ * componentwise relative backward error of each solution vector X(j)\n\ * (i.e., the smallest relative change in any element of A or B that\n\ * makes X(j) an exact solution).\n\ *\n\ * N_ERR_BNDS (input) INTEGER\n\ * Number of error bounds to return for each right hand side\n\ * and each type (normwise or componentwise). See ERR_BNDS_NORM and\n\ * ERR_BNDS_COMP below.\n\ *\n\ * ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * NPARAMS (input) INTEGER\n\ * Specifies the number of parameters set in PARAMS. If .LE. 0, the\n\ * PARAMS array is never referenced and default values are used.\n\ *\n\ * PARAMS (input / output) REAL array, dimension NPARAMS\n\ * Specifies algorithm parameters. If an entry is .LT. 0.0, then\n\ * that entry will be filled with default value used for that\n\ * parameter. Only positions up to NPARAMS are accessed; defaults\n\ * are used for higher-numbered parameters.\n\ *\n\ * PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n\ * refinement or not.\n\ * Default: 1.0\n\ * = 0.0 : No refinement is performed, and no error bounds are\n\ * computed.\n\ * = 1.0 : Use the double-precision refinement algorithm,\n\ * possibly with doubled-single computations if the\n\ * compilation environment does not support DOUBLE\n\ * PRECISION.\n\ * (other values are reserved for future use)\n\ *\n\ * PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n\ * computations allowed for refinement.\n\ * Default: 10\n\ * Aggressive: Set to 100 to permit convergence using approximate\n\ * factorizations or factorizations other than LU. If\n\ * the factorization uses a technique other than\n\ * Gaussian elimination, the guarantees in\n\ * err_bnds_norm and err_bnds_comp may no longer be\n\ * trustworthy.\n\ *\n\ * PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n\ * will attempt to find a solution with small componentwise\n\ * relative error in the double-precision algorithm. Positive\n\ * is true, 0.0 is false.\n\ * Default: 1.0 (attempt componentwise convergence)\n\ *\n\ * WORK (workspace) REAL array, dimension (4*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit. The solution to every right-hand side is\n\ * guaranteed.\n\ * < 0: If INFO = -i, the i-th argument had an illegal value\n\ * > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zpoequ0000644000175000017500000000506312502223526016537 0ustar uwabamiuwabami--- :name: zpoequ :md5sum: 1019992820d3deca34591f65cbb2c774 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - n - scond: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPOEQU computes row and column scalings intended to equilibrate a\n\ * Hermitian positive definite matrix A and reduce its condition number\n\ * (with respect to the two-norm). S contains the scale factors,\n\ * S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n\ * elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n\ * choice of S puts the condition number of B within a factor N of the\n\ * smallest possible condition number over all possible diagonal\n\ * scalings.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The N-by-N Hermitian positive definite matrix whose scaling\n\ * factors are to be computed. Only the diagonal elements of A\n\ * are referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * S (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, S contains the scale factors for A.\n\ *\n\ * SCOND (output) DOUBLE PRECISION\n\ * If INFO = 0, S contains the ratio of the smallest S(i) to\n\ * the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n\ * large nor too small, it is not worth scaling by S.\n\ *\n\ * AMAX (output) DOUBLE PRECISION\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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 is nonpositive.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clacpy0000644000175000017500000000420212502223525016460 0ustar uwabamiuwabami--- :name: clacpy :md5sum: b6d3093093de2f43162dc18940b3cfcf :category: :subroutine :arguments: - uplo: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: output :dims: - ldb - n - ldb: :type: integer :intent: input :substitutions: ldb: MAX(1,m) :fortran_help: " SUBROUTINE CLACPY( UPLO, M, N, A, LDA, B, LDB )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLACPY copies all or part of a two-dimensional matrix A to another\n\ * matrix B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies the part of the matrix A to be copied to B.\n\ * = 'U': Upper triangular part\n\ * = 'L': Lower triangular part\n\ * Otherwise: All of the matrix A\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) COMPLEX array, dimension (LDA,N)\n\ * The m by n matrix A. If UPLO = 'U', only the upper trapezium\n\ * is accessed; if UPLO = 'L', only the lower trapezium is\n\ * accessed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (output) COMPLEX array, dimension (LDB,N)\n\ * On exit, B = A in the locations specified by UPLO.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,M).\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/ssprfs0000644000175000017500000001131212502223526016526 0ustar uwabamiuwabami--- :name: ssprfs :md5sum: 4b6b3373fef866ff285dcb698532f7bd :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: real :intent: input :dims: - n*(n+1)/2 - afp: :type: real :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSPRFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is symmetric indefinite\n\ * and packed, and provides error bounds and backward error estimates\n\ * for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AP (input) REAL array, dimension (N*(N+1)/2)\n\ * The upper or lower triangle of the symmetric matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * AFP (input) REAL array, dimension (N*(N+1)/2)\n\ * The factored form of the matrix A. AFP contains the block\n\ * diagonal matrix D and the multipliers used to obtain the\n\ * factor U or L from the factorization A = U*D*U**T or\n\ * A = L*D*L**T as computed by SSPTRF, stored as a packed\n\ * triangular matrix.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by SSPTRF.\n\ *\n\ * B (input) REAL array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) REAL array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by SSPTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) REAL array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/spoequb0000644000175000017500000000476012502223526016675 0ustar uwabamiuwabami--- :name: spoequb :md5sum: 4aa28db9fad2c9d00f35b7d240b9c359 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - s: :type: real :intent: output :dims: - n - scond: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPOEQU computes row and column scalings intended to equilibrate a\n\ * symmetric positive definite matrix A and reduce its condition number\n\ * (with respect to the two-norm). S contains the scale factors,\n\ * S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n\ * elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n\ * choice of S puts the condition number of B within a factor N of the\n\ * smallest possible condition number over all possible diagonal\n\ * scalings.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * The N-by-N symmetric positive definite matrix whose scaling\n\ * factors are to be computed. Only the diagonal elements of A\n\ * are referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * S (output) REAL array, dimension (N)\n\ * If INFO = 0, S contains the scale factors for A.\n\ *\n\ * SCOND (output) REAL\n\ * If INFO = 0, S contains the ratio of the smallest S(i) to\n\ * the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n\ * large nor too small, it is not worth scaling by S.\n\ *\n\ * AMAX (output) REAL\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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 is nonpositive.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chetrd0000644000175000017500000001307112502223525016462 0ustar uwabamiuwabami--- :name: chetrd :md5sum: 90032415c41efdbcc206a1786bcc8b9e :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: real :intent: output :dims: - n - e: :type: real :intent: output :dims: - n-1 - tau: :type: complex :intent: output :dims: - n-1 - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHETRD reduces a complex Hermitian matrix A to real symmetric\n\ * tridiagonal form T by a unitary similarity transformation:\n\ * Q**H * A * Q = T.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ * On exit, if UPLO = 'U', the diagonal and first superdiagonal\n\ * of A are overwritten by the corresponding elements of the\n\ * tridiagonal matrix T, and the elements above the first\n\ * superdiagonal, with the array TAU, represent the unitary\n\ * matrix Q as a product of elementary reflectors; if UPLO\n\ * = 'L', the diagonal and first subdiagonal of A are over-\n\ * written by the corresponding elements of the tridiagonal\n\ * matrix T, and the elements below the first subdiagonal, with\n\ * the array TAU, represent the unitary matrix Q as a product\n\ * of elementary reflectors. See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * D (output) REAL array, dimension (N)\n\ * The diagonal elements of the tridiagonal matrix T:\n\ * D(i) = A(i,i).\n\ *\n\ * E (output) REAL array, dimension (N-1)\n\ * The off-diagonal elements of the tridiagonal matrix T:\n\ * E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n\ *\n\ * TAU (output) COMPLEX array, dimension (N-1)\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace/output) COMPLEX 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 >= 1.\n\ * For optimum performance LWORK >= N*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\ * If UPLO = 'U', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(n-1) . . . H(2) H(1).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar, and v is a complex vector with\n\ * v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n\ * A(1:i-1,i+1), and tau in TAU(i).\n\ *\n\ * If UPLO = 'L', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(n-1).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar, and v is a complex vector with\n\ * v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n\ * and tau in TAU(i).\n\ *\n\ * The contents of A on exit are illustrated by the following examples\n\ * with n = 5:\n\ *\n\ * if UPLO = 'U': if UPLO = 'L':\n\ *\n\ * ( d e v2 v3 v4 ) ( d )\n\ * ( d e v3 v4 ) ( e d )\n\ * ( d e v4 ) ( v1 e d )\n\ * ( d e ) ( v1 v2 e d )\n\ * ( d ) ( v1 v2 v3 e d )\n\ *\n\ * where d and e denote diagonal and off-diagonal elements of T, and vi\n\ * denotes an element of the vector defining H(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chptrf0000644000175000017500000001152612502223525016502 0ustar uwabamiuwabami--- :name: chptrf :md5sum: 227b4ab1f5a1280f310d5961364b711c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - ldap - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE CHPTRF( UPLO, N, AP, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHPTRF computes the factorization of a complex Hermitian packed\n\ * matrix A using the Bunch-Kaufman diagonal pivoting method:\n\ *\n\ * A = U*D*U**H or A = L*D*L**H\n\ *\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, and D is Hermitian and block diagonal with\n\ * 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L, stored as a packed triangular\n\ * matrix overwriting A (see below for further details).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D.\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\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, D(i,i) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular, and division by zero will occur if it\n\ * is used to solve a system of equations.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * 5-96 - Based on modifications by J. Lewis, Boeing Computer Services\n\ * Company\n\ *\n\ * If UPLO = 'U', then A = U*D*U', where\n\ * U = P(n)*U(n)* ... *P(k)U(k)* ...,\n\ * i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n\ * 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I v 0 ) k-s\n\ * U(k) = ( 0 I 0 ) s\n\ * ( 0 0 I ) n-k\n\ * k-s s n-k\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n\ * If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n\ * and A(k,k), and v overwrites A(1:k-2,k-1:k).\n\ *\n\ * If UPLO = 'L', then A = L*D*L', where\n\ * L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n\ * i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n\ * n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I 0 0 ) k-1\n\ * L(k) = ( 0 I 0 ) s\n\ * ( 0 v I ) n-k-s+1\n\ * k-1 s n-k-s+1\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n\ * If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n\ * and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zpotf20000644000175000017500000000472412502223526016443 0ustar uwabamiuwabami--- :name: zpotf2 :md5sum: 1f423a28af00c579ba564960eb3c801f :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPOTF2( UPLO, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPOTF2 computes the Cholesky factorization of a complex Hermitian\n\ * positive definite matrix A.\n\ *\n\ * The factorization has the form\n\ * A = U' * U , if UPLO = 'U', or\n\ * A = L * L', if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is lower triangular.\n\ *\n\ * This is the unblocked version of the algorithm, calling Level 2 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * Hermitian matrix A is stored.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the leading\n\ * n by n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n by n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the factor U or L from the Cholesky\n\ * factorization A = U'*U or A = L*L'.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ * > 0: if INFO = k, the leading minor of order k is not\n\ * positive definite, and the factorization could not be\n\ * completed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dspcon0000644000175000017500000000534512502223526016505 0ustar uwabamiuwabami--- :name: dspcon :md5sum: e621cc4d4a938054c58e6e583bb7bb66 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 2*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSPCON estimates the reciprocal of the condition number (in the\n\ * 1-norm) of a real symmetric packed matrix A using the factorization\n\ * A = U*D*U**T or A = L*D*L**T computed by DSPTRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by DSPTRF, stored as a\n\ * packed triangular matrix.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by DSPTRF.\n\ *\n\ * ANORM (input) DOUBLE PRECISION\n\ * The 1-norm of the original matrix A.\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n\ * estimate of the 1-norm of inv(A) computed in this routine.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slaexc0000644000175000017500000000601412502223526016470 0ustar uwabamiuwabami--- :name: slaexc :md5sum: 7b147a6610de47105a915414572b084a :category: :subroutine :arguments: - wantq: :type: logical :intent: input - n: :type: integer :intent: input - t: :type: real :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - q: :type: real :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - j1: :type: integer :intent: input - n1: :type: integer :intent: input - n2: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in\n\ * an upper quasi-triangular matrix T by an orthogonal similarity\n\ * transformation.\n\ *\n\ * T must be in Schur canonical form, that is, block upper triangular\n\ * with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block\n\ * has its diagonal elemnts equal and its off-diagonal elements of\n\ * opposite sign.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * WANTQ (input) LOGICAL\n\ * = .TRUE. : accumulate the transformation in the matrix Q;\n\ * = .FALSE.: do not accumulate the transformation.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix T. N >= 0.\n\ *\n\ * T (input/output) REAL array, dimension (LDT,N)\n\ * On entry, the upper quasi-triangular matrix T, in Schur\n\ * canonical form.\n\ * On exit, the updated matrix T, again in Schur canonical form.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= max(1,N).\n\ *\n\ * Q (input/output) REAL array, dimension (LDQ,N)\n\ * On entry, if WANTQ is .TRUE., the orthogonal matrix Q.\n\ * On exit, if WANTQ is .TRUE., the updated matrix Q.\n\ * If WANTQ is .FALSE., Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q.\n\ * LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N.\n\ *\n\ * J1 (input) INTEGER\n\ * The index of the first row of the first block T11.\n\ *\n\ * N1 (input) INTEGER\n\ * The order of the first block T11. N1 = 0, 1 or 2.\n\ *\n\ * N2 (input) INTEGER\n\ * The order of the second block T22. N2 = 0, 1 or 2.\n\ *\n\ * WORK (workspace) REAL array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * = 1: the transformed matrix T would be too far from Schur\n\ * form; the blocks are not swapped and T and Q are\n\ * unchanged.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlacon0000644000175000017500000000465612502223526016511 0ustar uwabamiuwabami--- :name: zlacon :md5sum: da79628afbd39cf73c8240528208f1d5 :category: :subroutine :arguments: - n: :type: integer :intent: input - v: :type: doublecomplex :intent: workspace :dims: - n - x: :type: doublecomplex :intent: input/output :dims: - n - est: :type: doublereal :intent: input/output - kase: :type: integer :intent: input/output :substitutions: {} :fortran_help: " SUBROUTINE ZLACON( N, V, X, EST, KASE )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLACON estimates the 1-norm of a square, complex matrix A.\n\ * Reverse communication is used for evaluating matrix-vector products.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 1.\n\ *\n\ * V (workspace) COMPLEX*16 array, dimension (N)\n\ * On the final return, V = A*W, where EST = norm(V)/norm(W)\n\ * (W is not returned).\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension (N)\n\ * On an intermediate return, X should be overwritten by\n\ * A * X, if KASE=1,\n\ * A' * X, if KASE=2,\n\ * where A' is the conjugate transpose of A, and ZLACON must be\n\ * re-called with all the other parameters unchanged.\n\ *\n\ * EST (input/output) DOUBLE PRECISION\n\ * On entry with KASE = 1 or 2 and JUMP = 3, EST should be\n\ * unchanged from the previous call to ZLACON.\n\ * On exit, EST is an estimate (a lower bound) for norm(A). \n\ *\n\ * KASE (input/output) INTEGER\n\ * On the initial call to ZLACON, KASE should be 0.\n\ * On an intermediate return, KASE will be 1 or 2, indicating\n\ * whether X should be overwritten by A * X or A' * X.\n\ * On the final return from ZLACON, KASE will again be 0.\n\ *\n\n\ * Further Details\n\ * ======= =======\n\ *\n\ * Contributed by Nick Higham, University of Manchester.\n\ * Originally named CONEST, dated March 16, 1988.\n\ *\n\ * Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n\ * a real or complex matrix, with applications to condition estimation\",\n\ * ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n\ *\n\ * Last modified: April, 1999\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ztzrzf0000644000175000017500000001021612502223526016561 0ustar uwabamiuwabami--- :name: ztzrzf :md5sum: 71b51f416a0713c90c0b4492f3d3457b :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - m - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE ZTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTZRZF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A\n\ * to upper triangular form by means of unitary transformations.\n\ *\n\ * The upper trapezoidal matrix A is factored as\n\ *\n\ * A = ( R 0 ) * Z,\n\ *\n\ * where Z is an N-by-N unitary matrix and R is an M-by-M upper\n\ * triangular matrix.\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 >= M.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the leading M-by-N upper trapezoidal part of the\n\ * array A must contain the matrix to be factorized.\n\ * On exit, the leading M-by-M upper triangular part of A\n\ * contains the upper triangular matrix R, and elements M+1 to\n\ * N of the first M rows of A, with the array TAU, represent the\n\ * unitary matrix Z as a product of M elementary reflectors.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (output) COMPLEX*16 array, dimension (M)\n\ * The scalar factors of the elementary reflectors.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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\n\ * the 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\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * The factorization is obtained by Householder's method. The kth\n\ * transformation matrix, Z( k ), which is used to introduce zeros into\n\ * the ( m - k + 1 )th row of A, is given in the form\n\ *\n\ * Z( k ) = ( I 0 ),\n\ * ( 0 T( k ) )\n\ *\n\ * where\n\ *\n\ * T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n\ * ( 0 )\n\ * ( z( k ) )\n\ *\n\ * tau is a scalar and z( k ) is an ( n - m ) element vector.\n\ * tau and z( k ) are chosen to annihilate the elements of the kth row\n\ * of X.\n\ *\n\ * The scalar tau is returned in the kth element of TAU and the vector\n\ * u( k ) in the kth row of A, such that the elements of z( k ) are\n\ * in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n\ * the upper triangular part of A.\n\ *\n\ * Z is given by\n\ *\n\ * Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cposvxx0000644000175000017500000005055012502223525016726 0ustar uwabamiuwabami--- :name: cposvxx :md5sum: 882ffc7988c6739b23858fcef7731bed :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - equed: :type: char :intent: input/output - s: :type: real :intent: input/output :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - rpvgrw: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " SUBROUTINE CPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T\n\ * to compute the solution to a complex system of linear equations\n\ * A * X = B, where A is an N-by-N symmetric positive definite matrix\n\ * and X and B are N-by-NRHS matrices.\n\ *\n\ * If requested, both normwise and maximum componentwise error bounds\n\ * are returned. CPOSVXX will return a solution with a tiny\n\ * guaranteed error (O(eps) where eps is the working machine\n\ * precision) unless the matrix is very ill-conditioned, in which\n\ * case a warning is returned. Relevant condition numbers also are\n\ * calculated and returned.\n\ *\n\ * CPOSVXX accepts user-provided factorizations and equilibration\n\ * factors; see the definitions of the FACT and EQUED options.\n\ * Solving with refinement and using a factorization from a previous\n\ * CPOSVXX call will also produce a solution with either O(eps)\n\ * errors or warnings, but we cannot make that claim for general\n\ * user-provided factorizations and equilibration factors if they\n\ * differ from what CPOSVXX would itself produce.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', real scaling factors are computed to equilibrate\n\ * the system:\n\ *\n\ * diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B\n\ *\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n\ *\n\ * 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n\ * factor the matrix A (after equilibration if FACT = 'E') as\n\ * A = U**T* U, if UPLO = 'U', or\n\ * A = L * L**T, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is a lower triangular\n\ * matrix.\n\ *\n\ * 3. If the leading i-by-i principal minor is not positive definite,\n\ * then the routine returns with INFO = i. Otherwise, the factored\n\ * form of A is used to estimate the condition number of the matrix\n\ * A (see argument RCOND). If the reciprocal of the condition number\n\ * is less than machine precision, the routine still goes on to solve\n\ * for X and compute error bounds as described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n\ * the routine will use iterative refinement to try to get a small\n\ * error and error bounds. Refinement calculates the residual to at\n\ * least twice the working precision.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(S) so that it solves the original system before\n\ * equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AF contains the factored form of A.\n\ * If EQUED is not 'N', the matrix A has been\n\ * equilibrated with scaling factors given by S.\n\ * A and AF are not modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AF and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A, except if FACT = 'F' and EQUED =\n\ * 'Y', then A must contain the equilibrated matrix\n\ * diag(S)*A*diag(S). If UPLO = 'U', the leading N-by-N upper\n\ * triangular part of A contains the upper triangular part of the\n\ * matrix A, and the strictly lower triangular part of A is not\n\ * referenced. If UPLO = 'L', the leading N-by-N lower triangular\n\ * part of A contains the lower triangular part of the matrix A, and\n\ * the strictly upper triangular part of A is not referenced. A is\n\ * not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED =\n\ * 'N' on exit.\n\ *\n\ * On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n\ * diag(S)*A*diag(S).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input or output) COMPLEX array, dimension (LDAF,N)\n\ * If FACT = 'F', then AF is an input argument and on entry\n\ * contains the triangular factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T, in the same storage\n\ * format as A. If EQUED .ne. 'N', then AF is the factored\n\ * form of the equilibrated matrix diag(S)*A*diag(S).\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T of the original\n\ * matrix A.\n\ *\n\ * If FACT = 'E', then AF is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T of the equilibrated\n\ * matrix A (see the description of A for the form of the\n\ * equilibrated matrix).\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'Y': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(S) * A * diag(S).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * S (input or output) REAL array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'Y', A is multiplied on\n\ * the left and right by diag(S). S is an input argument if FACT =\n\ * 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n\ * = 'Y', each element of S must be positive. If S is output, each\n\ * element of S is a power of the radix. If S is input, each element\n\ * of S should be a power of the radix to ensure a reliable solution\n\ * and error estimates. Scaling by powers of the radix does not cause\n\ * rounding errors unless the result underflows or overflows.\n\ * Rounding errors during scaling lead to refining with a matrix that\n\ * is not equivalent to the input matrix, producing error estimates\n\ * that may not be reliable.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit,\n\ * if EQUED = 'N', B is not modified;\n\ * if EQUED = 'Y', B is overwritten by diag(S)*B;\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX array, dimension (LDX,NRHS)\n\ * If INFO = 0, the N-by-NRHS solution matrix X to the original\n\ * system of equations. Note that A and B are modified on exit if\n\ * EQUED .ne. 'N', and the solution to the equilibrated system is\n\ * inv(diag(S))*X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * RPVGRW (output) REAL\n\ * Reciprocal pivot growth. On exit, this contains the reciprocal\n\ * pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n\ * norm is used. If this is much less than 1, then the stability of\n\ * the LU factorization of the (equilibrated) matrix A could be poor.\n\ * This also means that the solution X, estimated condition numbers,\n\ * and error bounds could be unreliable. If factorization fails with\n\ * 0 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clanhp0000644000175000017500000000567112502223525016465 0ustar uwabamiuwabami--- :name: clanhp :md5sum: 9dca827973764d6308604a8dd70a8e52 :category: :function :type: real :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - work: :type: real :intent: workspace :dims: - "MAX(1,(lsame_(&norm,\"I\")||lsame_(&norm,\"1\")||lsame_(&norm,\"O\")) ? n : 0)" :substitutions: {} :fortran_help: " REAL FUNCTION CLANHP( NORM, UPLO, N, AP, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLANHP returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * complex hermitian matrix A, supplied in packed form.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * CLANHP returns the value\n\ *\n\ * CLANHP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in CLANHP as described\n\ * above.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * hermitian matrix A is supplied.\n\ * = 'U': Upper triangular part of A is supplied\n\ * = 'L': Lower triangular part of A is supplied\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, CLANHP is\n\ * set to zero.\n\ *\n\ * AP (input) COMPLEX array, dimension (N*(N+1)/2)\n\ * The upper or lower triangle of the hermitian matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ * Note that the imaginary parts of the diagonal elements need\n\ * not be set and are assumed to be zero.\n\ *\n\ * WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n\ * WORK is not referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgeesx0000644000175000017500000001746012502223526016525 0ustar uwabamiuwabami--- :name: zgeesx :md5sum: c664e00d89738fc39bde317d2585291e :category: :subroutine :arguments: - jobvs: :type: char :intent: input - sort: :type: char :intent: input - select: :intent: external procedure :block_type: logical :block_arg_num: 1 :block_arg_type: doublecomplex - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - sdim: :type: integer :intent: output - w: :type: doublecomplex :intent: output :dims: - n - vs: :type: doublecomplex :intent: output :dims: - ldvs - n - ldvs: :type: integer :intent: input - rconde: :type: doublereal :intent: output - rcondv: :type: doublereal :intent: output - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(lsame_(&sense,\"E\")||lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? n*n/2 : 2*n" - rwork: :type: doublereal :intent: workspace :dims: - n - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvs: "lsame_(&jobvs,\"V\") ? n : 1" :fortran_help: " SUBROUTINE ZGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, W, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, RWORK, BWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGEESX computes for an N-by-N complex nonsymmetric matrix A, the\n\ * eigenvalues, the Schur form T, and, optionally, the matrix of Schur\n\ * vectors Z. This gives the Schur factorization A = Z*T*(Z**H).\n\ *\n\ * Optionally, it also orders the eigenvalues on the diagonal of the\n\ * Schur form so that selected eigenvalues are at the top left;\n\ * computes a reciprocal condition number for the average of the\n\ * selected eigenvalues (RCONDE); and computes a reciprocal condition\n\ * number for the right invariant subspace corresponding to the\n\ * selected eigenvalues (RCONDV). The leading columns of Z form an\n\ * orthonormal basis for this invariant subspace.\n\ *\n\ * For further explanation of the reciprocal condition numbers RCONDE\n\ * and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where\n\ * these quantities are called s and sep respectively).\n\ *\n\ * A complex matrix is in Schur form if it is upper triangular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVS (input) CHARACTER*1\n\ * = 'N': Schur vectors are not computed;\n\ * = 'V': Schur vectors are computed.\n\ *\n\ * SORT (input) CHARACTER*1\n\ * Specifies whether or not to order the eigenvalues on the\n\ * diagonal of the Schur form.\n\ * = 'N': Eigenvalues are not ordered;\n\ * = 'S': Eigenvalues are ordered (see SELECT).\n\ *\n\ * SELECT (external procedure) LOGICAL FUNCTION of one COMPLEX*16 argument\n\ * SELECT must be declared EXTERNAL in the calling subroutine.\n\ * If SORT = 'S', SELECT is used to select eigenvalues to order\n\ * to the top left of the Schur form.\n\ * If SORT = 'N', SELECT is not referenced.\n\ * An eigenvalue W(j) is selected if SELECT(W(j)) is true.\n\ *\n\ * SENSE (input) CHARACTER*1\n\ * Determines which reciprocal condition numbers are computed.\n\ * = 'N': None are computed;\n\ * = 'E': Computed for average of selected eigenvalues only;\n\ * = 'V': Computed for selected right invariant subspace only;\n\ * = 'B': Computed for both.\n\ * If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA, N)\n\ * On entry, the N-by-N matrix A.\n\ * On exit, A is overwritten by its Schur form T.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * SDIM (output) INTEGER\n\ * If SORT = 'N', SDIM = 0.\n\ * If SORT = 'S', SDIM = number of eigenvalues for which\n\ * SELECT is true.\n\ *\n\ * W (output) COMPLEX*16 array, dimension (N)\n\ * W contains the computed eigenvalues, in the same order\n\ * that they appear on the diagonal of the output Schur form T.\n\ *\n\ * VS (output) COMPLEX*16 array, dimension (LDVS,N)\n\ * If JOBVS = 'V', VS contains the unitary matrix Z of Schur\n\ * vectors.\n\ * If JOBVS = 'N', VS is not referenced.\n\ *\n\ * LDVS (input) INTEGER\n\ * The leading dimension of the array VS. LDVS >= 1, and if\n\ * JOBVS = 'V', LDVS >= N.\n\ *\n\ * RCONDE (output) DOUBLE PRECISION\n\ * If SENSE = 'E' or 'B', RCONDE contains the reciprocal\n\ * condition number for the average of the selected eigenvalues.\n\ * Not referenced if SENSE = 'N' or 'V'.\n\ *\n\ * RCONDV (output) DOUBLE PRECISION\n\ * If SENSE = 'V' or 'B', RCONDV contains the reciprocal\n\ * condition number for the selected right invariant subspace.\n\ * Not referenced if SENSE = 'N' or 'E'.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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,2*N).\n\ * Also, if SENSE = 'E' or 'V' or 'B', LWORK >= 2*SDIM*(N-SDIM),\n\ * where SDIM is the number of selected eigenvalues computed by\n\ * this routine. Note that 2*SDIM*(N-SDIM) <= N*N/2. Note also\n\ * that an error is only returned if LWORK < max(1,2*N), but if\n\ * SENSE = 'E' or 'V' or 'B' this may not be large enough.\n\ * For good performance, LWORK must generally be larger.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates upper bound on the optimal size of the\n\ * array WORK, returns this value as the first entry of the WORK\n\ * array, and no error message related to LWORK is issued by\n\ * XERBLA.\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * BWORK (workspace) LOGICAL array, dimension (N)\n\ * Not referenced if SORT = 'N'.\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, and i is\n\ * <= N: the QR algorithm failed to compute all the\n\ * eigenvalues; elements 1:ILO-1 and i+1:N of W\n\ * contain those eigenvalues which have converged; if\n\ * JOBVS = 'V', VS contains the transformation which\n\ * reduces A to its partially converged Schur form.\n\ * = N+1: the eigenvalues could not be reordered because some\n\ * eigenvalues were too close to separate (the problem\n\ * is very ill-conditioned);\n\ * = N+2: after reordering, roundoff changed values of some\n\ * complex eigenvalues so that leading eigenvalues in\n\ * the Schur form no longer satisfy SELECT=.TRUE. This\n\ * could also be caused by underflow due to scaling.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clatps0000644000175000017500000001630112502223525016476 0ustar uwabamiuwabami--- :name: clatps :md5sum: d713535a97fe8819f48baf9545b24b97 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - normin: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - x: :type: complex :intent: input/output :dims: - n - scale: :type: real :intent: output - cnorm: :type: real :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, CNORM, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLATPS solves one of the triangular systems\n\ *\n\ * A * x = s*b, A**T * x = s*b, or A**H * x = s*b,\n\ *\n\ * with scaling to prevent overflow, where A is an upper or lower\n\ * triangular matrix stored in packed form. Here A**T denotes the\n\ * transpose of A, A**H denotes the conjugate transpose of A, x and b\n\ * are n-element vectors, and s is a scaling factor, usually less than\n\ * or equal to 1, chosen so that the components of x will be less than\n\ * the overflow threshold. If the unscaled problem will not cause\n\ * overflow, the Level 2 BLAS routine CTPSV is called. If the matrix A\n\ * is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n\ * non-trivial solution to A*x = 0 is returned.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the matrix A is upper or lower triangular.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the operation applied to A.\n\ * = 'N': Solve A * x = s*b (No transpose)\n\ * = 'T': Solve A**T * x = s*b (Transpose)\n\ * = 'C': Solve A**H * x = s*b (Conjugate transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * Specifies whether or not the matrix A is unit triangular.\n\ * = 'N': Non-unit triangular\n\ * = 'U': Unit triangular\n\ *\n\ * NORMIN (input) CHARACTER*1\n\ * Specifies whether CNORM has been set or not.\n\ * = 'Y': CNORM contains the column norms on entry\n\ * = 'N': CNORM is not set on entry. On exit, the norms will\n\ * be computed and stored in CNORM.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input) COMPLEX array, dimension (N*(N+1)/2)\n\ * The upper or lower triangular matrix A, packed columnwise in\n\ * a linear array. The j-th column of A is stored in the array\n\ * AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * X (input/output) COMPLEX array, dimension (N)\n\ * On entry, the right hand side b of the triangular system.\n\ * On exit, X is overwritten by the solution vector x.\n\ *\n\ * SCALE (output) REAL\n\ * The scaling factor s for the triangular system\n\ * A * x = s*b, A**T * x = s*b, or A**H * x = s*b.\n\ * If SCALE = 0, the matrix A is singular or badly scaled, and\n\ * the vector x is an exact or approximate solution to A*x = 0.\n\ *\n\ * CNORM (input or output) REAL array, dimension (N)\n\ *\n\ * If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n\ * contains the norm of the off-diagonal part of the j-th column\n\ * of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n\ * to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n\ * must be greater than or equal to the 1-norm.\n\ *\n\ * If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n\ * returns the 1-norm of the offdiagonal part of the j-th column\n\ * of A.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ *\n\n\ * Further Details\n\ * ======= =======\n\ *\n\ * A rough bound on x is computed; if that is less than overflow, CTPSV\n\ * is called, otherwise, specific code is used which checks for possible\n\ * overflow or divide-by-zero at every operation.\n\ *\n\ * A columnwise scheme is used for solving A*x = b. The basic algorithm\n\ * if A is lower triangular is\n\ *\n\ * x[1:n] := b[1:n]\n\ * for j = 1, ..., n\n\ * x(j) := x(j) / A(j,j)\n\ * x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n\ * end\n\ *\n\ * Define bounds on the components of x after j iterations of the loop:\n\ * M(j) = bound on x[1:j]\n\ * G(j) = bound on x[j+1:n]\n\ * Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n\ *\n\ * Then for iteration j+1 we have\n\ * M(j+1) <= G(j) / | A(j+1,j+1) |\n\ * G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n\ * <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n\ *\n\ * where CNORM(j+1) is greater than or equal to the infinity-norm of\n\ * column j+1 of A, not counting the diagonal. Hence\n\ *\n\ * G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n\ * 1<=i<=j\n\ * and\n\ *\n\ * |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n\ * 1<=i< j\n\ *\n\ * Since |x(j)| <= M(j), we use the Level 2 BLAS routine CTPSV if the\n\ * reciprocal of the largest M(j), j=1,..,n, is larger than\n\ * max(underflow, 1/overflow).\n\ *\n\ * The bound on x(j) is also used to determine when a step in the\n\ * columnwise method can be performed without fear of overflow. If\n\ * the computed bound is greater than a large constant, x is scaled to\n\ * prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n\ * 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n\ *\n\ * Similarly, a row-wise scheme is used to solve A**T *x = b or\n\ * A**H *x = b. The basic algorithm for A upper triangular is\n\ *\n\ * for j = 1, ..., n\n\ * x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n\ * end\n\ *\n\ * We simultaneously compute two bounds\n\ * G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n\ * M(j) = bound on x(i), 1<=i<=j\n\ *\n\ * The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n\ * add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n\ * Then the bound on x(j) is\n\ *\n\ * M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n\ *\n\ * <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n\ * 1<=i<=j\n\ *\n\ * and we can safely call CTPSV if 1/M(n) and 1/G(n) are both greater\n\ * than max(underflow, 1/overflow).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlaqge0000644000175000017500000000627112502223526016453 0ustar uwabamiuwabami--- :name: dlaqge :md5sum: b14c9cc959d1e11f7142942dbe096cdd :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - r: :type: doublereal :intent: input :dims: - m - c: :type: doublereal :intent: input :dims: - n - rowcnd: :type: doublereal :intent: input - colcnd: :type: doublereal :intent: input - amax: :type: doublereal :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAQGE equilibrates a general M by N matrix A using the row and\n\ * column scaling factors in the vectors R and C.\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 equilibrated matrix. See EQUED for the form of\n\ * the equilibrated matrix.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(M,1).\n\ *\n\ * R (input) DOUBLE PRECISION array, dimension (M)\n\ * The row scale factors for A.\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension (N)\n\ * The column scale factors for A.\n\ *\n\ * ROWCND (input) DOUBLE PRECISION\n\ * Ratio of the smallest R(i) to the largest R(i).\n\ *\n\ * COLCND (input) DOUBLE PRECISION\n\ * Ratio of the smallest C(i) to the largest C(i).\n\ *\n\ * AMAX (input) DOUBLE PRECISION\n\ * Absolute value of largest matrix entry.\n\ *\n\ * EQUED (output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * THRESH is a threshold value used to decide if row or column scaling\n\ * should be done based on the ratio of the row or column scaling\n\ * factors. If ROWCND < THRESH, row scaling is done, and if\n\ * COLCND < THRESH, column scaling is done.\n\ *\n\ * LARGE and SMALL are threshold values used to decide if row scaling\n\ * should be done based on the absolute size of the largest matrix\n\ * element. If AMAX > LARGE or AMAX < SMALL, row scaling is done.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgebd20000644000175000017500000001314212502223526016357 0ustar uwabamiuwabami--- :name: sgebd2 :md5sum: e4e4458e28f45673d7327d16a19ea99c :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: real :intent: output :dims: - MIN(m,n) - e: :type: real :intent: output :dims: - MIN(m,n)-1 - tauq: :type: real :intent: output :dims: - MIN(m,n) - taup: :type: real :intent: output :dims: - MIN(m,n) - work: :type: real :intent: workspace :dims: - MAX(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGEBD2 reduces a real general m by n matrix A to upper or lower\n\ * bidiagonal form B by an orthogonal transformation: Q' * A * P = B.\n\ *\n\ * If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows in the matrix A. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns in the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the m by n general matrix to be reduced.\n\ * On exit,\n\ * if m >= n, the diagonal and the first superdiagonal are\n\ * overwritten with the upper bidiagonal matrix B; the\n\ * elements below the diagonal, with the array TAUQ, represent\n\ * the orthogonal matrix Q as a product of elementary\n\ * reflectors, and the elements above the first superdiagonal,\n\ * with the array TAUP, represent the orthogonal matrix P as\n\ * a product of elementary reflectors;\n\ * if m < n, the diagonal and the first subdiagonal are\n\ * overwritten with the lower bidiagonal matrix B; the\n\ * elements below the first subdiagonal, with the array TAUQ,\n\ * represent the orthogonal matrix Q as a product of\n\ * elementary reflectors, and the elements above the diagonal,\n\ * with the array TAUP, represent the orthogonal matrix P as\n\ * a product of elementary reflectors.\n\ * See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * D (output) REAL array, dimension (min(M,N))\n\ * The diagonal elements of the bidiagonal matrix B:\n\ * D(i) = A(i,i).\n\ *\n\ * E (output) REAL array, dimension (min(M,N)-1)\n\ * The off-diagonal elements of the bidiagonal matrix B:\n\ * if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n\ * if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n\ *\n\ * TAUQ (output) REAL array dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the orthogonal matrix Q. See Further Details.\n\ *\n\ * TAUP (output) REAL array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the orthogonal matrix P. See Further Details.\n\ *\n\ * WORK (workspace) REAL array, dimension (max(M,N))\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 matrices Q and P are represented as products of elementary\n\ * reflectors:\n\ *\n\ * If m >= n,\n\ *\n\ * Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)\n\ *\n\ * Each H(i) and G(i) has the form:\n\ *\n\ * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n\ *\n\ * where tauq and taup are real scalars, and v and u are real vectors;\n\ * v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);\n\ * u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);\n\ * tauq is stored in TAUQ(i) and taup in TAUP(i).\n\ *\n\ * If m < n,\n\ *\n\ * Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)\n\ *\n\ * Each H(i) and G(i) has the form:\n\ *\n\ * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n\ *\n\ * where tauq and taup are real scalars, and v and u are real vectors;\n\ * v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);\n\ * u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);\n\ * tauq is stored in TAUQ(i) and taup in TAUP(i).\n\ *\n\ * The contents of A on exit are illustrated by the following examples:\n\ *\n\ * m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n\ *\n\ * ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )\n\ * ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )\n\ * ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )\n\ * ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )\n\ * ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )\n\ * ( v1 v2 v3 v4 v5 )\n\ *\n\ * where d and e denote diagonal and off-diagonal elements of B, vi\n\ * denotes an element of the vector defining H(i), and ui an element of\n\ * the vector defining G(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sspevx0000644000175000017500000001601512502223526016543 0ustar uwabamiuwabami--- :name: sspevx :md5sum: b52fee75951227849a69f57900d7636b :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - ldap - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 8*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE SSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSPEVX computes selected eigenvalues and, optionally, eigenvectors\n\ * of a real symmetric matrix A in packed storage. Eigenvalues/vectors\n\ * can be selected by specifying either a range of values or a range of\n\ * indices for the desired eigenvalues.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found;\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found;\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) REAL array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, AP is overwritten by values generated during the\n\ * reduction to tridiagonal form. If UPLO = 'U', the diagonal\n\ * and first superdiagonal of the tridiagonal matrix T overwrite\n\ * the corresponding elements of A, and if UPLO = 'L', the\n\ * diagonal and first subdiagonal of T overwrite the\n\ * corresponding elements of A.\n\ *\n\ * VL (input) REAL\n\ * VU (input) REAL\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) REAL\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less than\n\ * or equal to zero, then EPS*|T| will be used in its place,\n\ * where |T| is the 1-norm of the tridiagonal matrix obtained\n\ * by reducing AP to tridiagonal form.\n\ *\n\ * Eigenvalues will be computed most accurately when ABSTOL is\n\ * set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n\ * If this routine returns with INFO>0, indicating that some\n\ * eigenvectors did not converge, try setting ABSTOL to\n\ * 2*SLAMCH('S').\n\ *\n\ * See \"Computing Small Singular Values of Bidiagonal Matrices\n\ * with Guaranteed High Relative Accuracy,\" by Demmel and\n\ * Kahan, LAPACK Working Note #3.\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * If INFO = 0, the selected eigenvalues in ascending order.\n\ *\n\ * Z (output) REAL array, dimension (LDZ, max(1,M))\n\ * If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix A\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * If an eigenvector fails to converge, then that column of Z\n\ * contains the latest approximation to the eigenvector, and the\n\ * index of the eigenvector is returned in IFAIL.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) REAL array, dimension (8*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (5*N)\n\ *\n\ * IFAIL (output) INTEGER array, dimension (N)\n\ * If JOBZ = 'V', then if INFO = 0, the first M elements of\n\ * IFAIL are zero. If INFO > 0, then IFAIL contains the\n\ * indices of the eigenvectors that failed to converge.\n\ * If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n\ * Their indices are stored in array IFAIL.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slauu20000644000175000017500000000412612502223526016426 0ustar uwabamiuwabami--- :name: slauu2 :md5sum: 5e2e54c06151826f884384f29c08e854 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLAUU2( UPLO, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAUU2 computes the product U * U' or L' * L, where the triangular\n\ * factor U or L is stored in the upper or lower triangular part of\n\ * the array A.\n\ *\n\ * If UPLO = 'U' or 'u' then the upper triangle of the result is stored,\n\ * overwriting the factor U in A.\n\ * If UPLO = 'L' or 'l' then the lower triangle of the result is stored,\n\ * overwriting the factor L in A.\n\ *\n\ * This is the unblocked form of the algorithm, calling Level 2 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the triangular factor stored in the array A\n\ * is upper or lower triangular:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the triangular factor U or L. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the triangular factor U or L.\n\ * On exit, if UPLO = 'U', the upper triangle of A is\n\ * overwritten with the upper triangle of the product U * U';\n\ * if UPLO = 'L', the lower triangle of A is overwritten with\n\ * the lower triangle of the product L' * L.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/claed00000644000175000017500000000734512502223525016350 0ustar uwabamiuwabami--- :name: claed0 :md5sum: 83b18987c9b3313733de29e1dea9bdad :category: :subroutine :arguments: - qsiz: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - q: :type: complex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - qstore: :type: complex :intent: workspace :dims: - ldqs - n - ldqs: :type: integer :intent: input - rwork: :type: real :intent: workspace :dims: - 1 + 3*n + 2*n*LG(n) + 3*pow(n,2) - iwork: :type: integer :intent: workspace :dims: - 6 + 6*n + 5*n*LG(n) - info: :type: integer :intent: output :substitutions: ldqs: MAX(1,n) :fortran_help: " SUBROUTINE CLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Using the divide and conquer method, CLAED0 computes all eigenvalues\n\ * of a symmetric tridiagonal matrix which is one diagonal block of\n\ * those from reducing a dense or band Hermitian matrix and\n\ * corresponding eigenvectors of the dense or band matrix.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * QSIZ (input) INTEGER\n\ * The dimension of the unitary matrix used to reduce\n\ * the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.\n\ *\n\ * N (input) INTEGER\n\ * The dimension of the symmetric tridiagonal matrix. N >= 0.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the diagonal elements of the tridiagonal matrix.\n\ * On exit, the eigenvalues in ascending order.\n\ *\n\ * E (input/output) REAL array, dimension (N-1)\n\ * On entry, the off-diagonal elements of the tridiagonal matrix.\n\ * On exit, E has been destroyed.\n\ *\n\ * Q (input/output) COMPLEX array, dimension (LDQ,N)\n\ * On entry, Q must contain an QSIZ x N matrix whose columns\n\ * unitarily orthonormal. It is a part of the unitary matrix\n\ * that reduces the full dense Hermitian matrix to a\n\ * (reducible) symmetric tridiagonal matrix.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N).\n\ *\n\ * IWORK (workspace) INTEGER array,\n\ * the dimension of IWORK must be at least\n\ * 6 + 6*N + 5*N*lg N\n\ * ( lg( N ) = smallest integer k\n\ * such that 2^k >= N )\n\ *\n\ * RWORK (workspace) REAL array,\n\ * dimension (1 + 3*N + 2*N*lg N + 3*N**2)\n\ * ( lg( N ) = smallest integer k\n\ * such that 2^k >= N )\n\ *\n\ * QSTORE (workspace) COMPLEX array, dimension (LDQS, N)\n\ * Used to store parts of\n\ * the eigenvector matrix when the updating matrix multiplies\n\ * take place.\n\ *\n\ * LDQS (input) INTEGER\n\ * The leading dimension of the array QSTORE.\n\ * LDQS >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit.\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * > 0: The algorithm failed to compute an eigenvalue while\n\ * working on the submatrix lying in rows and columns\n\ * INFO/(N+1) through mod(INFO,N+1).\n\ *\n\n\ * =====================================================================\n\ *\n\ * Warning: N could be as big as QSIZ!\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgbsvx0000644000175000017500000003440012502223526016506 0ustar uwabamiuwabami--- :name: dgbsvx :md5sum: 0129a67da42e6c8b84a014e106b7f3e1 :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublereal :intent: input/output :dims: - ldafb - n :option: true - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n :option: true - equed: :type: char :intent: input/output :option: true - r: :type: doublereal :intent: input/output :dims: - n :option: true - c: :type: doublereal :intent: input/output :dims: - n :option: true - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: output :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: n ldafb: 2*kl+ku+1 :fortran_help: " SUBROUTINE DGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGBSVX uses the LU factorization to compute the solution to a real\n\ * system of linear equations A * X = B, A**T * X = B, or A**H * X = B,\n\ * where A is a band matrix of order N with KL subdiagonals and KU\n\ * superdiagonals, and X and B are N-by-NRHS matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed by this subroutine:\n\ *\n\ * 1. If FACT = 'E', real scaling factors are computed to equilibrate\n\ * the system:\n\ * TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n\ * TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n\ * TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n\ * or diag(C)*B (if TRANS = 'T' or 'C').\n\ *\n\ * 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n\ * matrix A (after equilibration if FACT = 'E') as\n\ * A = L * U,\n\ * where L is a product of permutation and unit lower triangular\n\ * matrices with KL subdiagonals, and U is upper triangular with\n\ * KL+KU superdiagonals.\n\ *\n\ * 3. If some U(i,i)=0, so that U is exactly singular, then the routine\n\ * returns with INFO = i. Otherwise, the factored form of A is used\n\ * to estimate the condition number of the matrix A. If the\n\ * reciprocal of the condition number is less than machine precision,\n\ * INFO = N+1 is returned as a warning, but the routine still goes on\n\ * to solve for X and compute error bounds as described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n\ * that it solves the original system before equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AFB and IPIV contain the factored form of\n\ * A. If EQUED is not 'N', the matrix A has been\n\ * equilibrated with scaling factors given by R and C.\n\ * AB, AFB, and IPIV are not modified.\n\ * = 'N': The matrix A will be copied to AFB and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AFB and factored.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations.\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n\ *\n\ * If FACT = 'F' and EQUED is not 'N', then A must have been\n\ * equilibrated by the scaling factors in R and/or C. AB is not\n\ * modified if FACT = 'F' or 'N', or if FACT = 'E' and\n\ * EQUED = 'N' on exit.\n\ *\n\ * On exit, if EQUED .ne. 'N', A is scaled as follows:\n\ * EQUED = 'R': A := diag(R) * A\n\ * EQUED = 'C': A := A * diag(C)\n\ * EQUED = 'B': A := diag(R) * A * diag(C).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * AFB (input or output) DOUBLE PRECISION array, dimension (LDAFB,N)\n\ * If FACT = 'F', then AFB is an input argument and on entry\n\ * contains details of the LU factorization of the band matrix\n\ * A, as computed by DGBTRF. U is stored as an upper triangular\n\ * band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n\ * and the multipliers used during the factorization are stored\n\ * in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is\n\ * the factored form of the equilibrated matrix A.\n\ *\n\ * If FACT = 'N', then AFB is an output argument and on exit\n\ * returns details of the LU factorization of A.\n\ *\n\ * If FACT = 'E', then AFB is an output argument and on exit\n\ * returns details of the LU factorization of the equilibrated\n\ * matrix A (see the description of AB for the form of the\n\ * equilibrated matrix).\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains the pivot indices from the factorization A = L*U\n\ * as computed by DGBTRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = L*U\n\ * of the original matrix A.\n\ *\n\ * If FACT = 'E', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = L*U\n\ * of the equilibrated matrix A.\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * R (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'R' or 'B', A is\n\ * multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n\ * is not accessed. R is an input argument if FACT = 'F';\n\ * otherwise, R is an output argument. If FACT = 'F' and\n\ * EQUED = 'R' or 'B', each element of R must be positive.\n\ *\n\ * C (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The column scale factors for A. If EQUED = 'C' or 'B', A is\n\ * multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n\ * is not accessed. C is an input argument if FACT = 'F';\n\ * otherwise, C is an output argument. If FACT = 'F' and\n\ * EQUED = 'C' or 'B', each element of C must be positive.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit,\n\ * if EQUED = 'N', B is not modified;\n\ * if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n\ * diag(R)*B;\n\ * if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n\ * overwritten by diag(C)*B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n\ * to the original system of equations. Note that A and B are\n\ * modified on exit if EQUED .ne. 'N', and the solution to the\n\ * equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n\ * EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n\ * and EQUED = 'R' or 'B'.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A after equilibration (if done). If RCOND is less than the\n\ * machine precision (in particular, if RCOND = 0), the matrix\n\ * is singular to working precision. This condition is\n\ * indicated by a return code of INFO > 0.\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace/output) DOUBLE PRECISION array, dimension (3*N)\n\ * On exit, WORK(1) contains the reciprocal pivot growth\n\ * factor norm(A)/norm(U). The \"max absolute element\" norm is\n\ * used. If WORK(1) is much less than 1, then the stability\n\ * of the LU factorization of the (equilibrated) matrix A\n\ * could be poor. This also means that the solution X, condition\n\ * estimator RCOND, and forward error bound FERR could be\n\ * unreliable. If factorization fails with 0 0: if INFO = i, and i is\n\ * <= N: U(i,i) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, so the solution and error bounds\n\ * could not be computed. RCOND = 0 is returned.\n\ * = N+1: U is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhetrs20000644000175000017500000000526112502223526016615 0ustar uwabamiuwabami--- :name: zhetrs2 :md5sum: ccc24e2bde3f20ad75f420ff6ebeee26 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHETRS2 solves a system of linear equations A*X = B with a real\n\ * Hermitian matrix A using the factorization A = U*D*U**T or\n\ * A = L*D*L**T computed by ZSYTRF and converted by ZSYCONV.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**H;\n\ * = 'L': Lower triangular, form is A = L*D*L**H.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input) DOUBLE COMPLEX array, dimension (LDA,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by ZHETRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by ZHETRF.\n\ *\n\ * B (input/output) DOUBLE COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * WORK (workspace) REAL array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zpotrf0000644000175000017500000000457512502223526016547 0ustar uwabamiuwabami--- :name: zpotrf :md5sum: cbd658bc78bbb93bab7a06a58884ba99 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPOTRF( UPLO, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPOTRF computes the Cholesky factorization of a complex Hermitian\n\ * positive definite matrix A.\n\ *\n\ * The factorization has the form\n\ * A = U**H * U, if UPLO = 'U', or\n\ * A = L * L**H, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is lower triangular.\n\ *\n\ * This is the block version of the algorithm, calling Level 3 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the factor U or L from the Cholesky\n\ * factorization A = U**H*U or A = L*L**H.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\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 leading minor of order i is not\n\ * positive definite, and the factorization could not be\n\ * completed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sormrz0000644000175000017500000001140112502223526016541 0ustar uwabamiuwabami--- :name: sormrz :md5sum: 86e71e8e355df05ea115b509d2d2733c :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SORMRZ overwrites the general real M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'T': Q**T * C C * Q**T\n\ *\n\ * where Q is a real orthogonal matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by STZRZF. Q is of order M if SIDE = 'L' and of order N\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**T from the Left;\n\ * = 'R': apply Q or Q**T from the Right.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q;\n\ * = 'T': Transpose, apply Q**T.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * L (input) INTEGER\n\ * The number of columns of the matrix A containing\n\ * the meaningful part of the Householder reflectors.\n\ * If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n\ *\n\ * A (input) REAL array, dimension\n\ * (LDA,M) if SIDE = 'L',\n\ * (LDA,N) if SIDE = 'R'\n\ * The i-th row must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * STZRZF in the last k rows of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,K).\n\ *\n\ * TAU (input) REAL array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by STZRZF.\n\ *\n\ * C (input/output) REAL array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace/output) REAL 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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M).\n\ * For optimum performance LWORK >= N*NB if SIDE = 'L', and\n\ * LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n\ * 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\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlaein0000644000175000017500000000641012502223526016473 0ustar uwabamiuwabami--- :name: zlaein :md5sum: 845486ba7c6cdc14509c94e425271687 :category: :subroutine :arguments: - rightv: :type: logical :intent: input - noinit: :type: logical :intent: input - n: :type: integer :intent: input - h: :type: doublecomplex :intent: input :dims: - ldh - n - ldh: :type: integer :intent: input - w: :type: doublecomplex :intent: input - v: :type: doublecomplex :intent: input/output :dims: - n - b: :type: doublecomplex :intent: workspace :dims: - ldb - n - ldb: :type: integer :intent: input - rwork: :type: doublereal :intent: workspace :dims: - n - eps3: :type: doublereal :intent: input - smlnum: :type: doublereal :intent: input - info: :type: integer :intent: output :substitutions: ldb: MAX(1,n) :fortran_help: " SUBROUTINE ZLAEIN( RIGHTV, NOINIT, N, H, LDH, W, V, B, LDB, RWORK, EPS3, SMLNUM, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAEIN uses inverse iteration to find a right or left eigenvector\n\ * corresponding to the eigenvalue W of a complex upper Hessenberg\n\ * matrix H.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * RIGHTV (input) LOGICAL\n\ * = .TRUE. : compute right eigenvector;\n\ * = .FALSE.: compute left eigenvector.\n\ *\n\ * NOINIT (input) LOGICAL\n\ * = .TRUE. : no initial vector supplied in V\n\ * = .FALSE.: initial vector supplied in V.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H. N >= 0.\n\ *\n\ * H (input) COMPLEX*16 array, dimension (LDH,N)\n\ * The upper Hessenberg matrix H.\n\ *\n\ * LDH (input) INTEGER\n\ * The leading dimension of the array H. LDH >= max(1,N).\n\ *\n\ * W (input) COMPLEX*16\n\ * The eigenvalue of H whose corresponding right or left\n\ * eigenvector is to be computed.\n\ *\n\ * V (input/output) COMPLEX*16 array, dimension (N)\n\ * On entry, if NOINIT = .FALSE., V must contain a starting\n\ * vector for inverse iteration; otherwise V need not be set.\n\ * On exit, V contains the computed eigenvector, normalized so\n\ * that the component of largest magnitude has magnitude 1; here\n\ * the magnitude of a complex number (x,y) is taken to be\n\ * |x| + |y|.\n\ *\n\ * B (workspace) COMPLEX*16 array, dimension (LDB,N)\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * EPS3 (input) DOUBLE PRECISION\n\ * A small machine-dependent value which is used to perturb\n\ * close eigenvalues, and to replace zero pivots.\n\ *\n\ * SMLNUM (input) DOUBLE PRECISION\n\ * A machine-dependent value close to the underflow threshold.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * = 1: inverse iteration did not converge; V is set to the\n\ * last iterate.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlansp0000644000175000017500000000552012502223526016521 0ustar uwabamiuwabami--- :name: zlansp :md5sum: b3032545d19330061f35960b61a3e82e :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " DOUBLE PRECISION FUNCTION ZLANSP( NORM, UPLO, N, AP, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLANSP returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * complex symmetric matrix A, supplied in packed form.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * ZLANSP returns the value\n\ *\n\ * ZLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in ZLANSP as described\n\ * above.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is supplied.\n\ * = 'U': Upper triangular part of A is supplied\n\ * = 'L': Lower triangular part of A is supplied\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, ZLANSP is\n\ * set to zero.\n\ *\n\ * AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * The upper or lower triangle of the symmetric matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n\ * WORK is not referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slag20000644000175000017500000001100212655767354016237 0ustar uwabamiuwabami--- :name: slag2 :md5sum: 4299c5465453583eb5c3f7ba95c8c2df :category: :subroutine :arguments: - a: :type: real :intent: input :dims: - lda - "2" - lda: :type: integer :intent: input - b: :type: real :intent: input :dims: - ldb - "2" - ldb: :type: integer :intent: input - safmin: :type: real :intent: input - scale1: :type: real :intent: output - scale2: :type: real :intent: output - wr1: :type: real :intent: output - wr2: :type: real :intent: output - wi: :type: real :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, WR2, WI )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue\n\ * problem A - w B, with scaling as necessary to avoid over-/underflow.\n\ *\n\ * The scaling factor \"s\" results in a modified eigenvalue equation\n\ *\n\ * s A - w B\n\ *\n\ * where s is a non-negative scaling factor chosen so that w, w B,\n\ * and s A do not overflow and, if possible, do not underflow, either.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * A (input) REAL array, dimension (LDA, 2)\n\ * On entry, the 2 x 2 matrix A. It is assumed that its 1-norm\n\ * is less than 1/SAFMIN. Entries less than\n\ * sqrt(SAFMIN)*norm(A) are subject to being treated as zero.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= 2.\n\ *\n\ * B (input) REAL array, dimension (LDB, 2)\n\ * On entry, the 2 x 2 upper triangular matrix B. It is\n\ * assumed that the one-norm of B is less than 1/SAFMIN. The\n\ * diagonals should be at least sqrt(SAFMIN) times the largest\n\ * element of B (in absolute value); if a diagonal is smaller\n\ * than that, then +/- sqrt(SAFMIN) will be used instead of\n\ * that diagonal.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= 2.\n\ *\n\ * SAFMIN (input) REAL\n\ * The smallest positive number s.t. 1/SAFMIN does not\n\ * overflow. (This should always be SLAMCH('S') -- it is an\n\ * argument in order to avoid having to call SLAMCH frequently.)\n\ *\n\ * SCALE1 (output) REAL\n\ * A scaling factor used to avoid over-/underflow in the\n\ * eigenvalue equation which defines the first eigenvalue. If\n\ * the eigenvalues are complex, then the eigenvalues are\n\ * ( WR1 +/- WI i ) / SCALE1 (which may lie outside the\n\ * exponent range of the machine), SCALE1=SCALE2, and SCALE1\n\ * will always be positive. If the eigenvalues are real, then\n\ * the first (real) eigenvalue is WR1 / SCALE1 , but this may\n\ * overflow or underflow, and in fact, SCALE1 may be zero or\n\ * less than the underflow threshold if the exact eigenvalue\n\ * is sufficiently large.\n\ *\n\ * SCALE2 (output) REAL\n\ * A scaling factor used to avoid over-/underflow in the\n\ * eigenvalue equation which defines the second eigenvalue. If\n\ * the eigenvalues are complex, then SCALE2=SCALE1. If the\n\ * eigenvalues are real, then the second (real) eigenvalue is\n\ * WR2 / SCALE2 , but this may overflow or underflow, and in\n\ * fact, SCALE2 may be zero or less than the underflow\n\ * threshold if the exact eigenvalue is sufficiently large.\n\ *\n\ * WR1 (output) REAL\n\ * If the eigenvalue is real, then WR1 is SCALE1 times the\n\ * eigenvalue closest to the (2,2) element of A B**(-1). If the\n\ * eigenvalue is complex, then WR1=WR2 is SCALE1 times the real\n\ * part of the eigenvalues.\n\ *\n\ * WR2 (output) REAL\n\ * If the eigenvalue is real, then WR2 is SCALE2 times the\n\ * other eigenvalue. If the eigenvalue is complex, then\n\ * WR1=WR2 is SCALE1 times the real part of the eigenvalues.\n\ *\n\ * WI (output) REAL\n\ * If the eigenvalue is real, then WI is zero. If the\n\ * eigenvalue is complex, then WI is SCALE1 times the imaginary\n\ * part of the eigenvalues. WI will always be non-negative.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlassq0000644000175000017500000000414612502223526016504 0ustar uwabamiuwabami--- :name: dlassq :md5sum: 3c1c556bdf9d5d6e44e32c35fd990d30 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: doublereal :intent: input :dims: - n - incx: :type: integer :intent: input - scale: :type: doublereal :intent: input/output - sumsq: :type: doublereal :intent: input/output :substitutions: {} :fortran_help: " SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLASSQ returns the values scl and smsq such that\n\ *\n\ * ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,\n\ *\n\ * where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is\n\ * assumed to be non-negative and scl returns the value\n\ *\n\ * scl = max( scale, abs( x( i ) ) ).\n\ *\n\ * scale and sumsq must be supplied in SCALE and SUMSQ and\n\ * scl and smsq are overwritten on SCALE and SUMSQ respectively.\n\ *\n\ * The routine makes only one pass through the vector x.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of elements to be used from the vector X.\n\ *\n\ * X (input) DOUBLE PRECISION array, dimension (N)\n\ * The vector for which a scaled sum of squares is computed.\n\ * x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between successive values of the vector X.\n\ * INCX > 0.\n\ *\n\ * SCALE (input/output) DOUBLE PRECISION\n\ * On entry, the value scale in the equation above.\n\ * On exit, SCALE is overwritten with scl , the scaling factor\n\ * for the sum of squares.\n\ *\n\ * SUMSQ (input/output) DOUBLE PRECISION\n\ * On entry, the value sumsq in the equation above.\n\ * On exit, SUMSQ is overwritten with smsq , the basic sum of\n\ * squares from which scl has been factored out.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chseqr0000644000175000017500000002627412502223525016507 0ustar uwabamiuwabami--- :name: chseqr :md5sum: b7398af14f809c4ce963b655e29f282d :category: :subroutine :arguments: - job: :type: char :intent: input - compz: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: complex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - w: :type: complex :intent: output :dims: - n - z: :type: complex :intent: input/output :dims: - "lsame_(&compz,\"N\") ? 0 : ldz" - "lsame_(&compz,\"N\") ? 0 : n" - ldz: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHSEQR computes the eigenvalues of a Hessenberg matrix H\n\ * and, optionally, the matrices T and Z from the Schur decomposition\n\ * H = Z T Z**H, where T is an upper triangular matrix (the\n\ * Schur form), and Z is the unitary matrix of Schur vectors.\n\ *\n\ * Optionally Z may be postmultiplied into an input unitary\n\ * matrix Q so that this routine can give the Schur factorization\n\ * of a matrix A which has been reduced to the Hessenberg form H\n\ * by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * = 'E': compute eigenvalues only;\n\ * = 'S': compute eigenvalues and the Schur form T.\n\ *\n\ * COMPZ (input) CHARACTER*1\n\ * = 'N': no Schur vectors are computed;\n\ * = 'I': Z is initialized to the unit matrix and the matrix Z\n\ * of Schur vectors of H is returned;\n\ * = 'V': Z must contain an unitary matrix Q on entry, and\n\ * the product Q*Z is returned.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H. N .GE. 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * It is assumed that H is already upper triangular in rows\n\ * and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n\ * set by a previous call to CGEBAL, and then passed to CGEHRD\n\ * when the matrix output by CGEBAL is reduced to Hessenberg\n\ * form. Otherwise ILO and IHI should be set to 1 and N\n\ * respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n\ * If N = 0, then ILO = 1 and IHI = 0.\n\ *\n\ * H (input/output) COMPLEX array, dimension (LDH,N)\n\ * On entry, the upper Hessenberg matrix H.\n\ * On exit, if INFO = 0 and JOB = 'S', H contains the upper\n\ * triangular matrix T from the Schur decomposition (the\n\ * Schur form). If INFO = 0 and JOB = 'E', the contents of\n\ * H are unspecified on exit. (The output value of H when\n\ * INFO.GT.0 is given under the description of INFO below.)\n\ *\n\ * Unlike earlier versions of CHSEQR, this subroutine may\n\ * explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1\n\ * or j = IHI+1, IHI+2, ... N.\n\ *\n\ * LDH (input) INTEGER\n\ * The leading dimension of the array H. LDH .GE. max(1,N).\n\ *\n\ * W (output) COMPLEX array, dimension (N)\n\ * The computed eigenvalues. If JOB = 'S', the eigenvalues are\n\ * stored in the same order as on the diagonal of the Schur\n\ * form returned in H, with W(i) = H(i,i).\n\ *\n\ * Z (input/output) COMPLEX array, dimension (LDZ,N)\n\ * If COMPZ = 'N', Z is not referenced.\n\ * If COMPZ = 'I', on entry Z need not be set and on exit,\n\ * if INFO = 0, Z contains the unitary matrix Z of the Schur\n\ * vectors of H. If COMPZ = 'V', on entry Z must contain an\n\ * N-by-N matrix Q, which is assumed to be equal to the unit\n\ * matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,\n\ * if INFO = 0, Z contains Q*Z.\n\ * Normally Q is the unitary matrix generated by CUNGHR\n\ * after the call to CGEHRD which formed the Hessenberg matrix\n\ * H. (The output value of Z when INFO.GT.0 is given under\n\ * the description of INFO below.)\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. if COMPZ = 'I' or\n\ * COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1.\n\ *\n\ * WORK (workspace/output) COMPLEX array, dimension (LWORK)\n\ * On exit, if INFO = 0, WORK(1) returns an estimate of\n\ * the optimal value for LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK .GE. max(1,N)\n\ * is sufficient and delivers very good and sometimes\n\ * optimal performance. However, LWORK as large as 11*N\n\ * may be required for optimal performance. A workspace\n\ * query is recommended to determine the optimal workspace\n\ * size.\n\ *\n\ * If LWORK = -1, then CHSEQR does a workspace query.\n\ * In this case, CHSEQR checks the input parameters and\n\ * estimates the optimal workspace size for the given\n\ * values of N, ILO and IHI. The estimate is returned\n\ * in WORK(1). No error message related to LWORK is\n\ * issued by XERBLA. Neither H nor Z are accessed.\n\ *\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * .LT. 0: if INFO = -i, the i-th argument had an illegal\n\ * value\n\ * .GT. 0: if INFO = i, CHSEQR failed to compute all of\n\ * the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n\ * and WI contain those eigenvalues which have been\n\ * successfully computed. (Failures are rare.)\n\ *\n\ * If INFO .GT. 0 and JOB = 'E', then on exit, the\n\ * remaining unconverged eigenvalues are the eigen-\n\ * values of the upper Hessenberg matrix rows and\n\ * columns ILO through INFO of the final, output\n\ * value of H.\n\ *\n\ * If INFO .GT. 0 and JOB = 'S', then on exit\n\ *\n\ * (*) (initial value of H)*U = U*(final value of H)\n\ *\n\ * where U is a unitary matrix. The final\n\ * value of H is upper Hessenberg and triangular in\n\ * rows and columns INFO+1 through IHI.\n\ *\n\ * If INFO .GT. 0 and COMPZ = 'V', then on exit\n\ *\n\ * (final value of Z) = (initial value of Z)*U\n\ *\n\ * where U is the unitary matrix in (*) (regard-\n\ * less of the value of JOB.)\n\ *\n\ * If INFO .GT. 0 and COMPZ = 'I', then on exit\n\ * (final value of Z) = U\n\ * where U is the unitary matrix in (*) (regard-\n\ * less of the value of JOB.)\n\ *\n\ * If INFO .GT. 0 and COMPZ = 'N', then Z is not\n\ * accessed.\n\ *\n\n\ * ================================================================\n\ * Default values supplied by\n\ * ILAENV(ISPEC,'CHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).\n\ * It is suggested that these defaults be adjusted in order\n\ * to attain best performance in each particular\n\ * computational environment.\n\ *\n\ * ISPEC=12: The CLAHQR vs CLAQR0 crossover point.\n\ * Default: 75. (Must be at least 11.)\n\ *\n\ * ISPEC=13: Recommended deflation window size.\n\ * This depends on ILO, IHI and NS. NS is the\n\ * number of simultaneous shifts returned\n\ * by ILAENV(ISPEC=15). (See ISPEC=15 below.)\n\ * The default for (IHI-ILO+1).LE.500 is NS.\n\ * The default for (IHI-ILO+1).GT.500 is 3*NS/2.\n\ *\n\ * ISPEC=14: Nibble crossover point. (See IPARMQ for\n\ * details.) Default: 14% of deflation window\n\ * size.\n\ *\n\ * ISPEC=15: Number of simultaneous shifts in a multishift\n\ * QR iteration.\n\ *\n\ * If IHI-ILO+1 is ...\n\ *\n\ * greater than ...but less ... the\n\ * or equal to ... than default is\n\ *\n\ * 1 30 NS = 2(+)\n\ * 30 60 NS = 4(+)\n\ * 60 150 NS = 10(+)\n\ * 150 590 NS = **\n\ * 590 3000 NS = 64\n\ * 3000 6000 NS = 128\n\ * 6000 infinity NS = 256\n\ *\n\ * (+) By default some or all matrices of this order\n\ * are passed to the implicit double shift routine\n\ * CLAHQR and this parameter is ignored. See\n\ * ISPEC=12 above and comments in IPARMQ for\n\ * details.\n\ *\n\ * (**) The asterisks (**) indicate an ad-hoc\n\ * function of N increasing from 10 to 64.\n\ *\n\ * ISPEC=16: Select structured matrix multiply.\n\ * If the number of simultaneous shifts (specified\n\ * by ISPEC=15) is less than 14, then the default\n\ * for ISPEC=16 is 0. Otherwise the default for\n\ * ISPEC=16 is 2.\n\ *\n\ * ================================================================\n\ * Based on contributions by\n\ * Karen Braman and Ralph Byers, Department of Mathematics,\n\ * University of Kansas, USA\n\ *\n\ * ================================================================\n\ * References:\n\ * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n\ * Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n\ * Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n\ * 929--947, 2002.\n\ *\n\ * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n\ * Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n\ * of Matrix Analysis, volume 23, pages 948--973, 2002.\n\ *\n\ * ================================================================\n" ruby-lapack-1.7.2/dev/defs/zgbtrs0000644000175000017500000000604012502223526016523 0ustar uwabamiuwabami--- :name: zgbtrs :md5sum: d0b1e4f8ef8e3c1fad70475d295eab0d :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGBTRS solves a system of linear equations\n\ * A * X = B, A**T * X = B, or A**H * X = B\n\ * with a general band matrix A using the LU factorization computed\n\ * by ZGBTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations.\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AB (input) COMPLEX*16 array, dimension (LDAB,N)\n\ * Details of the LU factorization of the band matrix A, as\n\ * computed by ZGBTRF. U is stored as an upper triangular band\n\ * matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n\ * the multipliers used during the factorization are stored in\n\ * rows KL+KU+2 to 2*KL+KU+1.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices; for 1 <= i <= N, row i of the matrix was\n\ * interchanged with row IPIV(i).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlasda0000644000175000017500000002242612502223526016446 0ustar uwabamiuwabami--- :name: dlasda :md5sum: a77fa77241c8f31a76eaef00f664e15a :category: :subroutine :arguments: - icompq: :type: integer :intent: input - smlsiz: :type: integer :intent: input - n: :type: integer :intent: input - sqre: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input :dims: - m-1 - u: :type: doublereal :intent: output :dims: - ldu - MAX(1,smlsiz) - ldu: :type: integer :intent: input - vt: :type: doublereal :intent: output :dims: - ldu - smlsiz+1 - k: :type: integer :intent: output :dims: - "icompq == 1 ? n : icompq == 0 ? 1 : 0" - difl: :type: doublereal :intent: output :dims: - ldu - nlvl - difr: :type: doublereal :intent: output :dims: - "icompq == 1 ? ldu : icompq == 0 ? n : 0" - "icompq == 1 ? 2 * nlvl : 0" - z: :type: doublereal :intent: output :dims: - "icompq == 1 ? ldu : icompq == 0 ? n : 0" - "icompq == 1 ? nlvl : 0" - poles: :type: doublereal :intent: output :dims: - ldu - 2 * nlvl - givptr: :type: integer :intent: output :dims: - n - givcol: :type: integer :intent: output :dims: - ldgcol - 2 * nlvl - ldgcol: :type: integer :intent: input - perm: :type: integer :intent: output :dims: - ldgcol - nlvl - givnum: :type: doublereal :intent: output :dims: - ldu - 2 * nlvl - c: :type: doublereal :intent: output :dims: - "icompq == 1 ? n : icompq == 0 ? 1 : 0" - s: :type: doublereal :intent: output :dims: - "icompq==1 ? n : icompq==0 ? 1 : 0" - work: :type: doublereal :intent: workspace :dims: - 6 * n + (smlsiz + 1)*(smlsiz + 1) - iwork: :type: integer :intent: workspace :dims: - (7 * n) - info: :type: integer :intent: output :substitutions: m: "sqre == 0 ? n : sqre == 1 ? n+1 : 0" ldu: n nlvl: floor(1.0/log(2.0)*log((double)n/smlsiz)) ldgcol: n :fortran_help: " SUBROUTINE DLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Using a divide and conquer approach, DLASDA computes the singular\n\ * value decomposition (SVD) of a real upper bidiagonal N-by-M matrix\n\ * B with diagonal D and offdiagonal E, where M = N + SQRE. The\n\ * algorithm computes the singular values in the SVD B = U * S * VT.\n\ * The orthogonal matrices U and VT are optionally computed in\n\ * compact form.\n\ *\n\ * A related subroutine, DLASD0, computes the singular values and\n\ * the singular vectors in explicit form.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ICOMPQ (input) INTEGER\n\ * Specifies whether singular vectors are to be computed\n\ * in compact form, as follows\n\ * = 0: Compute singular values only.\n\ * = 1: Compute singular vectors of upper bidiagonal\n\ * matrix in compact form.\n\ *\n\ * SMLSIZ (input) INTEGER\n\ * The maximum size of the subproblems at the bottom of the\n\ * computation tree.\n\ *\n\ * N (input) INTEGER\n\ * The row dimension of the upper bidiagonal matrix. This is\n\ * also the dimension of the main diagonal array D.\n\ *\n\ * SQRE (input) INTEGER\n\ * Specifies the column dimension of the bidiagonal matrix.\n\ * = 0: The bidiagonal matrix has column dimension M = N;\n\ * = 1: The bidiagonal matrix has column dimension M = N + 1.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension ( N )\n\ * On entry D contains the main diagonal of the bidiagonal\n\ * matrix. On exit D, if INFO = 0, contains its singular values.\n\ *\n\ * E (input) DOUBLE PRECISION array, dimension ( M-1 )\n\ * Contains the subdiagonal entries of the bidiagonal matrix.\n\ * On exit, E has been destroyed.\n\ *\n\ * U (output) DOUBLE PRECISION array,\n\ * dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced\n\ * if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left\n\ * singular vector matrices of all subproblems at the bottom\n\ * level.\n\ *\n\ * LDU (input) INTEGER, LDU = > N.\n\ * The leading dimension of arrays U, VT, DIFL, DIFR, POLES,\n\ * GIVNUM, and Z.\n\ *\n\ * VT (output) DOUBLE PRECISION array,\n\ * dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced\n\ * if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT' contains the right\n\ * singular vector matrices of all subproblems at the bottom\n\ * level.\n\ *\n\ * K (output) INTEGER array,\n\ * dimension ( N ) if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0.\n\ * If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th\n\ * secular equation on the computation tree.\n\ *\n\ * DIFL (output) DOUBLE PRECISION array, dimension ( LDU, NLVL ),\n\ * where NLVL = floor(log_2 (N/SMLSIZ))).\n\ *\n\ * DIFR (output) DOUBLE PRECISION array,\n\ * dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and\n\ * dimension ( N ) if ICOMPQ = 0.\n\ * If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1)\n\ * record distances between singular values on the I-th\n\ * level and singular values on the (I -1)-th level, and\n\ * DIFR(1:N, 2 * I ) contains the normalizing factors for\n\ * the right singular vector matrix. See DLASD8 for details.\n\ *\n\ * Z (output) DOUBLE PRECISION array,\n\ * dimension ( LDU, NLVL ) if ICOMPQ = 1 and\n\ * dimension ( N ) if ICOMPQ = 0.\n\ * The first K elements of Z(1, I) contain the components of\n\ * the deflation-adjusted updating row vector for subproblems\n\ * on the I-th level.\n\ *\n\ * POLES (output) DOUBLE PRECISION array,\n\ * dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced\n\ * if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and\n\ * POLES(1, 2*I) contain the new and old singular values\n\ * involved in the secular equations on the I-th level.\n\ *\n\ * GIVPTR (output) INTEGER array,\n\ * dimension ( N ) if ICOMPQ = 1, and not referenced if\n\ * ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records\n\ * the number of Givens rotations performed on the I-th\n\ * problem on the computation tree.\n\ *\n\ * GIVCOL (output) INTEGER array,\n\ * dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not\n\ * referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,\n\ * GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations\n\ * of Givens rotations performed on the I-th level on the\n\ * computation tree.\n\ *\n\ * LDGCOL (input) INTEGER, LDGCOL = > N.\n\ * The leading dimension of arrays GIVCOL and PERM.\n\ *\n\ * PERM (output) INTEGER array,\n\ * dimension ( LDGCOL, NLVL ) if ICOMPQ = 1, and not referenced\n\ * if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records\n\ * permutations done on the I-th level of the computation tree.\n\ *\n\ * GIVNUM (output) DOUBLE PRECISION array,\n\ * dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not\n\ * referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,\n\ * GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S-\n\ * values of Givens rotations performed on the I-th level on\n\ * the computation tree.\n\ *\n\ * C (output) DOUBLE PRECISION array,\n\ * dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0.\n\ * If ICOMPQ = 1 and the I-th subproblem is not square, on exit,\n\ * C( I ) contains the C-value of a Givens rotation related to\n\ * the right null space of the I-th subproblem.\n\ *\n\ * S (output) DOUBLE PRECISION array, dimension ( N ) if\n\ * ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1\n\ * and the I-th subproblem is not square, on exit, S( I )\n\ * contains the S-value of a Givens rotation related to\n\ * the right null space of the I-th subproblem.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension\n\ * (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)).\n\ *\n\ * IWORK (workspace) INTEGER array.\n\ * Dimension must be at least (7 * N).\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 = 1, a singular value did not converge\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ming Gu and Huan Ren, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ztgex20000644000175000017500000001171112502223526016434 0ustar uwabamiuwabami--- :name: ztgex2 :md5sum: 846b12fba6b25d431f2510d76148309e :category: :subroutine :arguments: - wantq: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - q: :type: doublecomplex :intent: input/output :dims: - "wantq ? ldq : 0" - "wantq ? n : 0" - ldq: :type: integer :intent: input - z: :type: doublecomplex :intent: input/output :dims: - "wantq ? ldz : 0" - "wantq ? n : 0" - ldz: :type: integer :intent: input - j1: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, J1, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTGEX2 swaps adjacent diagonal 1 by 1 blocks (A11,B11) and (A22,B22)\n\ * in an upper triangular matrix pair (A, B) by an unitary equivalence\n\ * transformation.\n\ *\n\ * (A, B) must be in generalized Schur canonical form, that is, A and\n\ * B are both upper triangular.\n\ *\n\ * Optionally, the matrices Q and Z of generalized Schur vectors are\n\ * updated.\n\ *\n\ * Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n\ * Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n\ *\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * WANTQ (input) LOGICAL\n\ * .TRUE. : update the left transformation matrix Q;\n\ * .FALSE.: do not update Q.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * .TRUE. : update the right transformation matrix Z;\n\ * .FALSE.: do not update Z.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 arrays, dimensions (LDA,N)\n\ * On entry, the matrix A in the pair (A, B).\n\ * On exit, the updated matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX*16 arrays, dimensions (LDB,N)\n\ * On entry, the matrix B in the pair (A, B).\n\ * On exit, the updated matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * Q (input/output) COMPLEX*16 array, dimension (LDZ,N)\n\ * If WANTQ = .TRUE, on entry, the unitary matrix Q. On exit,\n\ * the updated matrix Q.\n\ * Not referenced if WANTQ = .FALSE..\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= 1;\n\ * If WANTQ = .TRUE., LDQ >= N.\n\ *\n\ * Z (input/output) COMPLEX*16 array, dimension (LDZ,N)\n\ * If WANTZ = .TRUE, on entry, the unitary matrix Z. On exit,\n\ * the updated matrix Z.\n\ * Not referenced if WANTZ = .FALSE..\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1;\n\ * If WANTZ = .TRUE., LDZ >= N.\n\ *\n\ * J1 (input) INTEGER\n\ * The index to the first block (A11, B11).\n\ *\n\ * INFO (output) INTEGER\n\ * =0: Successful exit.\n\ * =1: The transformed matrix pair (A, B) would be too far\n\ * from generalized Schur form; the problem is ill-\n\ * conditioned. \n\ *\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * In the current code both weak and strong stability tests are\n\ * performed. The user can omit the strong stability test by changing\n\ * the internal logical parameter WANDS to .FALSE.. See ref. [2] for\n\ * details.\n\ *\n\ * [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n\ * Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n\ * M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n\ * Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n\ *\n\ * [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n\ * Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n\ * Estimation: Theory, Algorithms and Software, Report UMINF-94.04,\n\ * Department of Computing Science, Umea University, S-901 87 Umea,\n\ * Sweden, 1994. Also as LAPACK Working Note 87. To appear in\n\ * Numerical Algorithms, 1996.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgbcon0000644000175000017500000000642612502223526016473 0ustar uwabamiuwabami--- :name: sgbcon :md5sum: eaa07e1508e7cce0f3ead5f9b4aec35a :category: :subroutine :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGBCON estimates the reciprocal of the condition number of a real\n\ * general band matrix A, in either the 1-norm or the infinity-norm,\n\ * using the LU factorization computed by SGBTRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as\n\ * RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies whether the 1-norm condition number or the\n\ * infinity-norm condition number is required:\n\ * = '1' or 'O': 1-norm;\n\ * = 'I': Infinity-norm.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * AB (input) REAL array, dimension (LDAB,N)\n\ * Details of the LU factorization of the band matrix A, as\n\ * computed by SGBTRF. U is stored as an upper triangular band\n\ * matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n\ * the multipliers used during the factorization are stored in\n\ * rows KL+KU+2 to 2*KL+KU+1.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices; for 1 <= i <= N, row i of the matrix was\n\ * interchanged with row IPIV(i).\n\ *\n\ * ANORM (input) REAL\n\ * If NORM = '1' or 'O', the 1-norm of the original matrix A.\n\ * If NORM = 'I', the infinity-norm of the original matrix A.\n\ *\n\ * RCOND (output) REAL\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(norm(A) * norm(inv(A))).\n\ *\n\ * WORK (workspace) REAL array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slasq30000644000175000017500000000630512502223526016422 0ustar uwabamiuwabami--- :name: slasq3 :md5sum: 2f410ac97a48fb4a07e823012fc4b2d8 :category: :subroutine :arguments: - i0: :type: integer :intent: input - n0: :type: integer :intent: input/output - z: :type: real :intent: input :dims: - 4*n0 - pp: :type: integer :intent: input/output - dmin: :type: real :intent: output - sigma: :type: real :intent: output - desig: :type: real :intent: input/output - qmax: :type: real :intent: input - nfail: :type: integer :intent: output - iter: :type: integer :intent: output - ndiv: :type: integer :intent: output - ieee: :type: logical :intent: input - ttype: :type: integer :intent: input/output - dmin1: :type: real :intent: input/output - dmin2: :type: real :intent: input/output - dn: :type: real :intent: input/output - dn1: :type: real :intent: input/output - dn2: :type: real :intent: input/output - g: :type: real :intent: input/output - tau: :type: real :intent: input/output :substitutions: {} :fortran_help: " SUBROUTINE SLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, DN2, G, TAU )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLASQ3 checks for deflation, computes a shift (TAU) and calls dqds.\n\ * In case of failure it changes shifts, and tries again until output\n\ * is positive.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * I0 (input) INTEGER\n\ * First index.\n\ *\n\ * N0 (input/output) INTEGER\n\ * Last index.\n\ *\n\ * Z (input) REAL array, dimension ( 4*N )\n\ * Z holds the qd array.\n\ *\n\ * PP (input/output) INTEGER\n\ * PP=0 for ping, PP=1 for pong.\n\ * PP=2 indicates that flipping was applied to the Z array \n\ * and that the initial tests for deflation should not be \n\ * performed.\n\ *\n\ * DMIN (output) REAL\n\ * Minimum value of d.\n\ *\n\ * SIGMA (output) REAL\n\ * Sum of shifts used in current segment.\n\ *\n\ * DESIG (input/output) REAL\n\ * Lower order part of SIGMA\n\ *\n\ * QMAX (input) REAL\n\ * Maximum value of q.\n\ *\n\ * NFAIL (output) INTEGER\n\ * Number of times shift was too big.\n\ *\n\ * ITER (output) INTEGER\n\ * Number of iterations.\n\ *\n\ * NDIV (output) INTEGER\n\ * Number of divisions.\n\ *\n\ * IEEE (input) LOGICAL\n\ * Flag for IEEE or non IEEE arithmetic (passed to SLASQ5).\n\ *\n\ * TTYPE (input/output) INTEGER\n\ * Shift type.\n\ *\n\ * DMIN1 (input/output) REAL\n\ *\n\ * DMIN2 (input/output) REAL\n\ *\n\ * DN (input/output) REAL\n\ *\n\ * DN1 (input/output) REAL\n\ *\n\ * DN2 (input/output) REAL\n\ *\n\ * G (input/output) REAL\n\ *\n\ * TAU (input/output) REAL\n\ *\n\ * These are passed as arguments in order to save their values\n\ * between calls to SLASQ3.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dhgeqz0000644000175000017500000002531212502223526016475 0ustar uwabamiuwabami--- :name: dhgeqz :md5sum: bce30abcdf7b59c766869e0ee9849a6a :category: :subroutine :arguments: - job: :type: char :intent: input - compq: :type: char :intent: input - compz: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: doublereal :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - t: :type: doublereal :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - alphar: :type: doublereal :intent: output :dims: - n - alphai: :type: doublereal :intent: output :dims: - n - beta: :type: doublereal :intent: output :dims: - n - q: :type: doublereal :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - z: :type: doublereal :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DHGEQZ computes the eigenvalues of a real matrix pair (H,T),\n\ * where H is an upper Hessenberg matrix and T is upper triangular,\n\ * using the double-shift QZ method.\n\ * Matrix pairs of this type are produced by the reduction to\n\ * generalized upper Hessenberg form of a real matrix pair (A,B):\n\ *\n\ * A = Q1*H*Z1**T, B = Q1*T*Z1**T,\n\ *\n\ * as computed by DGGHRD.\n\ *\n\ * If JOB='S', then the Hessenberg-triangular pair (H,T) is\n\ * also reduced to generalized Schur form,\n\ * \n\ * H = Q*S*Z**T, T = Q*P*Z**T,\n\ * \n\ * where Q and Z are orthogonal matrices, P is an upper triangular\n\ * matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2\n\ * diagonal blocks.\n\ *\n\ * The 1-by-1 blocks correspond to real eigenvalues of the matrix pair\n\ * (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of\n\ * eigenvalues.\n\ *\n\ * Additionally, the 2-by-2 upper triangular diagonal blocks of P\n\ * corresponding to 2-by-2 blocks of S are reduced to positive diagonal\n\ * form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0,\n\ * P(j,j) > 0, and P(j+1,j+1) > 0.\n\ *\n\ * Optionally, the orthogonal matrix Q from the generalized Schur\n\ * factorization may be postmultiplied into an input matrix Q1, and the\n\ * orthogonal matrix Z may be postmultiplied into an input matrix Z1.\n\ * If Q1 and Z1 are the orthogonal matrices from DGGHRD that reduced\n\ * the matrix pair (A,B) to generalized upper Hessenberg form, then the\n\ * output matrices Q1*Q and Z1*Z are the orthogonal factors from the\n\ * generalized Schur factorization of (A,B):\n\ *\n\ * A = (Q1*Q)*S*(Z1*Z)**T, B = (Q1*Q)*P*(Z1*Z)**T.\n\ * \n\ * To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently,\n\ * of (A,B)) are computed as a pair of values (alpha,beta), where alpha is\n\ * complex and beta real.\n\ * If beta is nonzero, lambda = alpha / beta is an eigenvalue of the\n\ * generalized nonsymmetric eigenvalue problem (GNEP)\n\ * A*x = lambda*B*x\n\ * and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the\n\ * alternate form of the GNEP\n\ * mu*A*y = B*y.\n\ * Real eigenvalues can be read directly from the generalized Schur\n\ * form: \n\ * alpha = S(i,i), beta = P(i,i).\n\ *\n\ * Ref: C.B. Moler & G.W. Stewart, \"An Algorithm for Generalized Matrix\n\ * Eigenvalue Problems\", SIAM J. Numer. Anal., 10(1973),\n\ * pp. 241--256.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * = 'E': Compute eigenvalues only;\n\ * = 'S': Compute eigenvalues and the Schur form. \n\ *\n\ * COMPQ (input) CHARACTER*1\n\ * = 'N': Left Schur vectors (Q) are not computed;\n\ * = 'I': Q is initialized to the unit matrix and the matrix Q\n\ * of left Schur vectors of (H,T) is returned;\n\ * = 'V': Q must contain an orthogonal matrix Q1 on entry and\n\ * the product Q1*Q is returned.\n\ *\n\ * COMPZ (input) CHARACTER*1\n\ * = 'N': Right Schur vectors (Z) are not computed;\n\ * = 'I': Z is initialized to the unit matrix and the matrix Z\n\ * of right Schur vectors of (H,T) is returned;\n\ * = 'V': Z must contain an orthogonal matrix Z1 on entry and\n\ * the product Z1*Z is returned.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices H, T, Q, and Z. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * ILO and IHI mark the rows and columns of H which are in\n\ * Hessenberg form. It is assumed that A is already upper\n\ * triangular in rows and columns 1:ILO-1 and IHI+1:N.\n\ * If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.\n\ *\n\ * H (input/output) DOUBLE PRECISION array, dimension (LDH, N)\n\ * On entry, the N-by-N upper Hessenberg matrix H.\n\ * On exit, if JOB = 'S', H contains the upper quasi-triangular\n\ * matrix S from the generalized Schur factorization;\n\ * 2-by-2 diagonal blocks (corresponding to complex conjugate\n\ * pairs of eigenvalues) are returned in standard form, with\n\ * H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0.\n\ * If JOB = 'E', the diagonal blocks of H match those of S, but\n\ * the rest of H is unspecified.\n\ *\n\ * LDH (input) INTEGER\n\ * The leading dimension of the array H. LDH >= max( 1, N ).\n\ *\n\ * T (input/output) DOUBLE PRECISION array, dimension (LDT, N)\n\ * On entry, the N-by-N upper triangular matrix T.\n\ * On exit, if JOB = 'S', T contains the upper triangular\n\ * matrix P from the generalized Schur factorization;\n\ * 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S\n\ * are reduced to positive diagonal form, i.e., if H(j+1,j) is\n\ * non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and\n\ * T(j+1,j+1) > 0.\n\ * If JOB = 'E', the diagonal blocks of T match those of P, but\n\ * the rest of T is unspecified.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= max( 1, N ).\n\ *\n\ * ALPHAR (output) DOUBLE PRECISION array, dimension (N)\n\ * The real parts of each scalar alpha defining an eigenvalue\n\ * of GNEP.\n\ *\n\ * ALPHAI (output) DOUBLE PRECISION array, dimension (N)\n\ * The imaginary parts of each scalar alpha defining an\n\ * eigenvalue of GNEP.\n\ * If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n\ * positive, then the j-th and (j+1)-st eigenvalues are a\n\ * complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j).\n\ *\n\ * BETA (output) DOUBLE PRECISION array, dimension (N)\n\ * The scalars beta that define the eigenvalues of GNEP.\n\ * Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and\n\ * beta = BETA(j) represent the j-th eigenvalue of the matrix\n\ * pair (A,B), in one of the forms lambda = alpha/beta or\n\ * mu = beta/alpha. Since either lambda or mu may overflow,\n\ * they should not, in general, be computed.\n\ *\n\ * Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)\n\ * On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in\n\ * the reduction of (A,B) to generalized Hessenberg form.\n\ * On exit, if COMPZ = 'I', the orthogonal matrix of left Schur\n\ * vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix\n\ * of left Schur vectors of (A,B).\n\ * Not referenced if COMPZ = 'N'.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= 1.\n\ * If COMPQ='V' or 'I', then LDQ >= N.\n\ *\n\ * Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)\n\ * On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in\n\ * the reduction of (A,B) to generalized Hessenberg form.\n\ * On exit, if COMPZ = 'I', the orthogonal matrix of\n\ * right Schur vectors of (H,T), and if COMPZ = 'V', the\n\ * orthogonal matrix of right Schur vectors of (A,B).\n\ * Not referenced if COMPZ = 'N'.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1.\n\ * If COMPZ='V' or 'I', then LDZ >= 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. LWORK >= max(1,N).\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\ * = 1,...,N: the QZ iteration did not converge. (H,T) is not\n\ * in Schur form, but ALPHAR(i), ALPHAI(i), and\n\ * BETA(i), i=INFO+1,...,N should be correct.\n\ * = N+1,...,2*N: the shift calculation failed. (H,T) is not\n\ * in Schur form, but ALPHAR(i), ALPHAI(i), and\n\ * BETA(i), i=INFO-N+1,...,N should be correct.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Iteration counters:\n\ *\n\ * JITER -- counts iterations.\n\ * IITER -- counts iterations run since ILAST was last\n\ * changed. This is therefore reset only when a 1-by-1 or\n\ * 2-by-2 block deflates off the bottom.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/iladlc0000644000175000017500000000202412502223526016436 0ustar uwabamiuwabami--- :name: iladlc :md5sum: 519b6e504e227d778f36d69c1080c7ed :category: :function :type: integer :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " INTEGER FUNCTION ILADLC( M, N, A, LDA )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ILADLC scans A for its last non-zero column.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix A.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * 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\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zla_gercond_c0000644000175000017500000000733212502223526020006 0ustar uwabamiuwabami--- :name: zla_gercond_c :md5sum: 2e3c096c2d951fe9fae9aeba664dc25f :category: :function :type: doublereal :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - c: :type: doublereal :intent: input :dims: - n - capply: :type: logical :intent: input - info: :type: integer :intent: output - work: :type: doublecomplex :intent: input :dims: - 2*n - rwork: :type: doublereal :intent: input :dims: - n :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION ZLA_GERCOND_C( TRANS, N, A, LDA, AF, LDAF, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLA_GERCOND_C computes the infinity norm condition number of\n\ * op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate Transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX*16 array, dimension (LDAF,N)\n\ * The factors L and U from the factorization\n\ * A = P*L*U as computed by ZGETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from the factorization A = P*L*U\n\ * as computed by ZGETRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension (N)\n\ * The vector C in the formula op(A) * inv(diag(C)).\n\ *\n\ * CAPPLY (input) LOGICAL\n\ * If .TRUE. then access the vector C in the formula above.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * i > 0: The ith argument is invalid.\n\ *\n\ * WORK (input) COMPLEX*16 array, dimension (2*N).\n\ * Workspace.\n\ *\n\ * RWORK (input) DOUBLE PRECISION array, dimension (N).\n\ * Workspace.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE, I, J\n DOUBLE PRECISION AINVNM, ANORM, TMP\n COMPLEX*16 ZDUM\n\ * ..\n\ * .. Local Arrays ..\n INTEGER ISAVE( 3 )\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL ZLACN2, ZGETRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, REAL, DIMAG\n\ * ..\n\ * .. Statement Functions ..\n DOUBLE PRECISION CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sgglse0000644000175000017500000001204412502223526016475 0ustar uwabamiuwabami--- :name: sgglse :md5sum: f499922c0d1a1977b7b6beb425364495 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - p: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: real :intent: input/output :dims: - m - d: :type: real :intent: input/output :dims: - p - x: :type: real :intent: output :dims: - n - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m+n+p - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGGLSE solves the linear equality-constrained least squares (LSE)\n\ * problem:\n\ *\n\ * minimize || c - A*x ||_2 subject to B*x = d\n\ *\n\ * where A is an M-by-N matrix, B is a P-by-N matrix, c is a given\n\ * M-vector, and d is a given P-vector. It is assumed that\n\ * P <= N <= M+P, and\n\ *\n\ * rank(B) = P and rank( (A) ) = N.\n\ * ( (B) )\n\ *\n\ * These conditions ensure that the LSE problem has a unique solution,\n\ * which is obtained using a generalized RQ factorization of the\n\ * matrices (B, A) given by\n\ *\n\ * B = (0 R)*Q, A = Z*T*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 matrices A and B. N >= 0.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows of the matrix B. 0 <= P <= N <= M+P.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, the elements on and above the diagonal of the array\n\ * contain the min(M,N)-by-N upper trapezoidal matrix T.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input/output) REAL array, dimension (LDB,N)\n\ * On entry, the P-by-N matrix B.\n\ * On exit, the upper triangle of the subarray B(1:P,N-P+1:N)\n\ * contains the P-by-P upper triangular matrix R.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,P).\n\ *\n\ * C (input/output) REAL array, dimension (M)\n\ * On entry, C contains the right hand side vector for the\n\ * least squares part of the LSE problem.\n\ * On exit, the residual sum of squares for the solution\n\ * is given by the sum of squares of elements N-P+1 to M of\n\ * vector C.\n\ *\n\ * D (input/output) REAL array, dimension (P)\n\ * On entry, D contains the right hand side vector for the\n\ * constrained equation.\n\ * On exit, D is destroyed.\n\ *\n\ * X (output) REAL array, dimension (N)\n\ * On exit, X is the solution of the LSE problem.\n\ *\n\ * WORK (workspace/output) REAL 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+P).\n\ * For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,\n\ * where NB is an upper bound for the optimal blocksizes for\n\ * SGEQRF, SGERQF, SORMQR and SORMRQ.\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\ * = 1: the upper triangular factor R associated with B in the\n\ * generalized RQ factorization of the pair (B, A) is\n\ * singular, so that rank(B) < P; the least squares\n\ * solution could not be computed.\n\ * = 2: the (N-P) by (N-P) part of the upper trapezoidal factor\n\ * T associated with A in the generalized RQ factorization\n\ * of the pair (B, A) is singular, so that\n\ * rank( (A) ) < N; the least squares solution could not\n\ * ( (B) )\n\ * be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssbevx0000644000175000017500000002002412502223526016520 0ustar uwabamiuwabami--- :name: ssbevx :md5sum: 5bc1377ca79aec6da21ebd73878121f8 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - q: :type: real :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 7*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" ldq: "lsame_(&jobz,\"V\") ? MAX(1,n) : 0" :fortran_help: " SUBROUTINE SSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSBEVX computes selected eigenvalues and, optionally, eigenvectors\n\ * of a real symmetric band matrix A. Eigenvalues and eigenvectors can\n\ * be selected by specifying either a range of values or a range of\n\ * indices for the desired eigenvalues.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found;\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found;\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) REAL array, dimension (LDAB, N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * On exit, AB is overwritten by values generated during the\n\ * reduction to tridiagonal form. If UPLO = 'U', the first\n\ * superdiagonal and the diagonal of the tridiagonal matrix T\n\ * are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n\ * the diagonal and first subdiagonal of T are returned in the\n\ * first two rows of AB.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD + 1.\n\ *\n\ * Q (output) REAL array, dimension (LDQ, N)\n\ * If JOBZ = 'V', the N-by-N orthogonal matrix used in the\n\ * reduction to tridiagonal form.\n\ * If JOBZ = 'N', the array Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. If JOBZ = 'V', then\n\ * LDQ >= max(1,N).\n\ *\n\ * VL (input) REAL\n\ * VU (input) REAL\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) REAL\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less than\n\ * or equal to zero, then EPS*|T| will be used in its place,\n\ * where |T| is the 1-norm of the tridiagonal matrix obtained\n\ * by reducing AB to tridiagonal form.\n\ *\n\ * Eigenvalues will be computed most accurately when ABSTOL is\n\ * set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n\ * If this routine returns with INFO>0, indicating that some\n\ * eigenvectors did not converge, try setting ABSTOL to\n\ * 2*SLAMCH('S').\n\ *\n\ * See \"Computing Small Singular Values of Bidiagonal Matrices\n\ * with Guaranteed High Relative Accuracy,\" by Demmel and\n\ * Kahan, LAPACK Working Note #3.\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * The first M elements contain the selected eigenvalues in\n\ * ascending order.\n\ *\n\ * Z (output) REAL array, dimension (LDZ, max(1,M))\n\ * If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix A\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * If an eigenvector fails to converge, then that column of Z\n\ * contains the latest approximation to the eigenvector, and the\n\ * index of the eigenvector is returned in IFAIL.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) REAL array, dimension (7*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (5*N)\n\ *\n\ * IFAIL (output) INTEGER array, dimension (N)\n\ * If JOBZ = 'V', then if INFO = 0, the first M elements of\n\ * IFAIL are zero. If INFO > 0, then IFAIL contains the\n\ * indices of the eigenvectors that failed to converge.\n\ * If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n\ * Their indices are stored in array IFAIL.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsfrk0000644000175000017500000001016312502223526016322 0ustar uwabamiuwabami--- :name: dsfrk :md5sum: 0c83f186d2d8e20fbde488e693408f71 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - alpha: :type: doublereal :intent: input - a: :type: doublereal :intent: input :dims: - lda - "lsame_(&trans,\"N\") ? k : n" - lda: :type: integer :intent: input - beta: :type: doublereal :intent: input - c: :type: doublereal :intent: input/output :dims: - nt :substitutions: {} :fortran_help: " SUBROUTINE DSFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Level 3 BLAS like routine for C in RFP Format.\n\ *\n\ * DSFRK performs one of the symmetric rank--k operations\n\ *\n\ * C := alpha*A*A' + beta*C,\n\ *\n\ * or\n\ *\n\ * C := alpha*A'*A + beta*C,\n\ *\n\ * where alpha and beta are real scalars, C is an n--by--n symmetric\n\ * matrix and A is an n--by--k matrix in the first case and a k--by--n\n\ * matrix in the second case.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': The Normal Form of RFP A is stored;\n\ * = 'T': The Transpose Form of RFP A is stored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * On entry, UPLO specifies whether the upper or lower\n\ * triangular part of the array C is to be referenced as\n\ * follows:\n\ *\n\ * UPLO = 'U' or 'u' Only the upper triangular part of C\n\ * is to be referenced.\n\ *\n\ * UPLO = 'L' or 'l' Only the lower triangular part of C\n\ * is to be referenced.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * On entry, TRANS specifies the operation to be performed as\n\ * follows:\n\ *\n\ * TRANS = 'N' or 'n' C := alpha*A*A' + beta*C.\n\ *\n\ * TRANS = 'T' or 't' C := alpha*A'*A + beta*C.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the order of the matrix C. N must be\n\ * at least zero.\n\ * Unchanged on exit.\n\ *\n\ * K (input) INTEGER\n\ * On entry with TRANS = 'N' or 'n', K specifies the number\n\ * of columns of the matrix A, and on entry with TRANS = 'T'\n\ * or 't', K specifies the number of rows of the matrix A. K\n\ * must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * ALPHA (input) DOUBLE PRECISION\n\ * On entry, ALPHA specifies the scalar alpha.\n\ * Unchanged on exit.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,ka)\n\ * where KA\n\ * is K when TRANS = 'N' or 'n', and is N otherwise. Before\n\ * entry with TRANS = 'N' or 'n', the leading N--by--K part of\n\ * the array A must contain the matrix A, otherwise the leading\n\ * K--by--N part of the array A must contain the matrix A.\n\ * Unchanged on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * On entry, LDA specifies the first dimension of A as declared\n\ * in the calling (sub) program. When TRANS = 'N' or 'n'\n\ * then LDA must be at least max( 1, n ), otherwise LDA must\n\ * be at least max( 1, k ).\n\ * Unchanged on exit.\n\ *\n\ * BETA (input) DOUBLE PRECISION\n\ * On entry, BETA specifies the scalar beta.\n\ * Unchanged on exit.\n\ *\n\ *\n\ * C (input/output) DOUBLE PRECISION array, dimension (NT)\n\ * NT = N*(N+1)/2. On entry, the symmetric matrix C in RFP\n\ * Format. RFP Format is described by TRANSR, UPLO and N.\n\ *\n\ * Arguments\n\ * ==========\n\ *\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zhbgvx0000644000175000017500000002204312502223526016521 0ustar uwabamiuwabami--- :name: zhbgvx :md5sum: 76d1dc537517a9baeb413baa3e8601b5 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: doublecomplex :intent: input/output :dims: - ldbb - n - ldbb: :type: integer :intent: input - q: :type: doublecomplex :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - n - rwork: :type: doublereal :intent: workspace :dims: - 7*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? n : 1" ldq: "1 ? jobz = 'n' : MAX(1,n) ? jobz = 'v' : 0" :fortran_help: " SUBROUTINE ZHBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHBGVX computes all the eigenvalues, and optionally, the eigenvectors\n\ * of a complex generalized Hermitian-definite banded eigenproblem, of\n\ * the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian\n\ * and banded, and B is also positive definite. Eigenvalues and\n\ * eigenvectors can be selected by specifying either all eigenvalues,\n\ * a range of values or a range of indices for the desired eigenvalues.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found;\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found;\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * KA (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n\ *\n\ * KB (input) INTEGER\n\ * The number of superdiagonals of the matrix B if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n\ *\n\ * AB (input/output) COMPLEX*16 array, dimension (LDAB, N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix A, stored in the first ka+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n\ *\n\ * On exit, the contents of AB are destroyed.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KA+1.\n\ *\n\ * BB (input/output) COMPLEX*16 array, dimension (LDBB, N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix B, stored in the first kb+1 rows of the array. The\n\ * j-th column of B is stored in the j-th column of the array BB\n\ * as follows:\n\ * if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n\ * if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n\ *\n\ * On exit, the factor S from the split Cholesky factorization\n\ * B = S**H*S, as returned by ZPBSTF.\n\ *\n\ * LDBB (input) INTEGER\n\ * The leading dimension of the array BB. LDBB >= KB+1.\n\ *\n\ * Q (output) COMPLEX*16 array, dimension (LDQ, N)\n\ * If JOBZ = 'V', the n-by-n matrix used in the reduction of\n\ * A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x,\n\ * and consequently C to tridiagonal form.\n\ * If JOBZ = 'N', the array Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. If JOBZ = 'N',\n\ * LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N).\n\ *\n\ * VL (input) DOUBLE PRECISION\n\ * VU (input) DOUBLE PRECISION\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) DOUBLE PRECISION\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less than\n\ * or equal to zero, then EPS*|T| will be used in its place,\n\ * where |T| is the 1-norm of the tridiagonal matrix obtained\n\ * by reducing AP to tridiagonal form.\n\ *\n\ * Eigenvalues will be computed most accurately when ABSTOL is\n\ * set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n\ * If this routine returns with INFO>0, indicating that some\n\ * eigenvectors did not converge, try setting ABSTOL to\n\ * 2*DLAMCH('S').\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) COMPLEX*16 array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n\ * eigenvectors, with the i-th column of Z holding the\n\ * eigenvector associated with W(i). The eigenvectors are\n\ * normalized so that Z**H*B*Z = I.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= N.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (7*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (5*N)\n\ *\n\ * IFAIL (output) INTEGER array, dimension (N)\n\ * If JOBZ = 'V', then if INFO = 0, the first M elements of\n\ * IFAIL are zero. If INFO > 0, then IFAIL contains the\n\ * indices of the eigenvectors that failed to converge.\n\ * If JOBZ = 'N', then IFAIL is not referenced.\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, and i is:\n\ * <= N: then i eigenvectors failed to converge. Their\n\ * indices are stored in array IFAIL.\n\ * > N: if INFO = N + i, for 1 <= i <= N, then ZPBSTF\n\ * returned INFO = i: B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dormtr0000644000175000017500000001172112502223526016521 0ustar uwabamiuwabami--- :name: dormtr :md5sum: 977d8beedb08b5451d60dad11f963659 :category: :subroutine :arguments: - side: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - m-1 - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DORMTR overwrites the general real M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'T': Q**T * C C * Q**T\n\ *\n\ * where Q is a real orthogonal matrix of order nq, with nq = m if\n\ * SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of\n\ * nq-1 elementary reflectors, as returned by DSYTRD:\n\ *\n\ * if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);\n\ *\n\ * if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**T from the Left;\n\ * = 'R': apply Q or Q**T from the Right.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A contains elementary reflectors\n\ * from DSYTRD;\n\ * = 'L': Lower triangle of A contains elementary reflectors\n\ * from DSYTRD.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q;\n\ * = 'T': Transpose, apply Q**T.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension\n\ * (LDA,M) if SIDE = 'L'\n\ * (LDA,N) if SIDE = 'R'\n\ * The vectors which define the elementary reflectors, as\n\ * returned by DSYTRD.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ * LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n\ *\n\ * TAU (input) DOUBLE PRECISION array, dimension\n\ * (M-1) if SIDE = 'L'\n\ * (N-1) if SIDE = 'R'\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by DSYTRD.\n\ *\n\ * C (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M).\n\ * For optimum performance LWORK >= N*NB if SIDE = 'L', and\n\ * LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n\ * 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\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LEFT, LQUERY, UPPER\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DORMQL, DORMQR, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/clasyf0000644000175000017500000001064212502223525016473 0ustar uwabamiuwabami--- :name: clasyf :md5sum: 4b7a69b4acd8a223ada4d2f51b1e12a2 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nb: :type: integer :intent: input - kb: :type: integer :intent: output - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - w: :type: complex :intent: workspace :dims: - ldw - MAX(1,nb) - ldw: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: ldw: MAX(1,n) :fortran_help: " SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLASYF computes a partial factorization of a complex symmetric matrix\n\ * A using the Bunch-Kaufman diagonal pivoting method. The partial\n\ * factorization has the form:\n\ *\n\ * A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:\n\ * ( 0 U22 ) ( 0 D ) ( U12' U22' )\n\ *\n\ * A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L'\n\ * ( L21 I ) ( 0 A22 ) ( 0 I )\n\ *\n\ * where the order of D is at most NB. The actual order is returned in\n\ * the argument KB, and is either NB or NB-1, or N if N <= NB.\n\ * Note that U' denotes the transpose of U.\n\ *\n\ * CLASYF is an auxiliary routine called by CSYTRF. It uses blocked code\n\ * (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or\n\ * A22 (if UPLO = 'L').\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NB (input) INTEGER\n\ * The maximum number of columns of the matrix A that should be\n\ * factored. NB should be at least 2 to allow for 2-by-2 pivot\n\ * blocks.\n\ *\n\ * KB (output) INTEGER\n\ * The number of columns of A that were actually factored.\n\ * KB is either NB-1 or NB, or N if N <= NB.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * n-by-n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n-by-n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ * On exit, A contains details of the partial factorization.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D.\n\ * If UPLO = 'U', only the last KB elements of IPIV are set;\n\ * if UPLO = 'L', only the first KB elements are set.\n\ *\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * W (workspace) COMPLEX array, dimension (LDW,NB)\n\ *\n\ * LDW (input) INTEGER\n\ * The leading dimension of the array W. LDW >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sstebz0000644000175000017500000002145712502223526016533 0ustar uwabamiuwabami--- :name: sstebz :md5sum: b5160a4860997c0b386672e043c097b0 :category: :subroutine :arguments: - range: :type: char :intent: input - order: :type: char :intent: input - n: :type: integer :intent: input - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - d: :type: real :intent: input :dims: - n - e: :type: real :intent: input :dims: - n-1 - m: :type: integer :intent: output - nsplit: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - iblock: :type: integer :intent: output :dims: - n - isplit: :type: integer :intent: output :dims: - n - work: :type: real :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSTEBZ computes the eigenvalues of a symmetric tridiagonal\n\ * matrix T. The user may ask for all eigenvalues, all eigenvalues\n\ * in the half-open interval (VL, VU], or the IL-th through IU-th\n\ * eigenvalues.\n\ *\n\ * To avoid overflow, the matrix must be scaled so that its\n\ * largest element is no greater than overflow**(1/2) *\n\ * underflow**(1/4) in absolute value, and for greatest\n\ * accuracy, it should not be much smaller than that.\n\ *\n\ * See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n\ * Matrix\", Report CS41, Computer Science Dept., Stanford\n\ * University, July 21, 1966.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': (\"All\") all eigenvalues will be found.\n\ * = 'V': (\"Value\") all eigenvalues in the half-open interval\n\ * (VL, VU] will be found.\n\ * = 'I': (\"Index\") the IL-th through IU-th eigenvalues (of the\n\ * entire matrix) will be found.\n\ *\n\ * ORDER (input) CHARACTER*1\n\ * = 'B': (\"By Block\") the eigenvalues will be grouped by\n\ * split-off block (see IBLOCK, ISPLIT) and\n\ * ordered from smallest to largest within\n\ * the block.\n\ * = 'E': (\"Entire matrix\")\n\ * the eigenvalues for the entire matrix\n\ * will be ordered from smallest to\n\ * largest.\n\ *\n\ * N (input) INTEGER\n\ * The order of the tridiagonal matrix T. N >= 0.\n\ *\n\ * VL (input) REAL\n\ * VU (input) REAL\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. Eigenvalues less than or equal\n\ * to VL, or greater than VU, will not be returned. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) REAL\n\ * The absolute tolerance for the eigenvalues. An eigenvalue\n\ * (or cluster) is considered to be located if it has been\n\ * determined to lie in an interval whose width is ABSTOL or\n\ * less. If ABSTOL is less than or equal to zero, then ULP*|T|\n\ * will be used, where |T| means the 1-norm of T.\n\ *\n\ * Eigenvalues will be computed most accurately when ABSTOL is\n\ * set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The n diagonal elements of the tridiagonal matrix T.\n\ *\n\ * E (input) REAL array, dimension (N-1)\n\ * The (n-1) off-diagonal elements of the tridiagonal matrix T.\n\ *\n\ * M (output) INTEGER\n\ * The actual number of eigenvalues found. 0 <= M <= N.\n\ * (See also the description of INFO=2,3.)\n\ *\n\ * NSPLIT (output) INTEGER\n\ * The number of diagonal blocks in the matrix T.\n\ * 1 <= NSPLIT <= N.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * On exit, the first M elements of W will contain the\n\ * eigenvalues. (SSTEBZ may use the remaining N-M elements as\n\ * workspace.)\n\ *\n\ * IBLOCK (output) INTEGER array, dimension (N)\n\ * At each row/column j where E(j) is zero or small, the\n\ * matrix T is considered to split into a block diagonal\n\ * matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which\n\ * block (from 1 to the number of blocks) the eigenvalue W(i)\n\ * belongs. (SSTEBZ may use the remaining N-M elements as\n\ * workspace.)\n\ *\n\ * ISPLIT (output) INTEGER array, dimension (N)\n\ * The splitting points, at which T breaks up into submatrices.\n\ * The first submatrix consists of rows/columns 1 to ISPLIT(1),\n\ * the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n\ * etc., and the NSPLIT-th consists of rows/columns\n\ * ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n\ * (Only the first NSPLIT elements will actually be used, but\n\ * since the user cannot know a priori what value NSPLIT will\n\ * have, N words must be reserved for ISPLIT.)\n\ *\n\ * WORK (workspace) REAL array, dimension (4*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (3*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: some or all of the eigenvalues failed to converge or\n\ * were not computed:\n\ * =1 or 3: Bisection failed to converge for some\n\ * eigenvalues; these eigenvalues are flagged by a\n\ * negative block number. The effect is that the\n\ * eigenvalues may not be as accurate as the\n\ * absolute and relative tolerances. This is\n\ * generally caused by unexpectedly inaccurate\n\ * arithmetic.\n\ * =2 or 3: RANGE='I' only: Not all of the eigenvalues\n\ * IL:IU were found.\n\ * Effect: M < IU+1-IL\n\ * Cause: non-monotonic arithmetic, causing the\n\ * Sturm sequence to be non-monotonic.\n\ * Cure: recalculate, using RANGE='A', and pick\n\ * out eigenvalues IL:IU. In some cases,\n\ * increasing the PARAMETER \"FUDGE\" may\n\ * make things work.\n\ * = 4: RANGE='I', and the Gershgorin interval\n\ * initially used was too small. No eigenvalues\n\ * were computed.\n\ * Probable cause: your machine has sloppy\n\ * floating-point arithmetic.\n\ * Cure: Increase the PARAMETER \"FUDGE\",\n\ * recompile, and try again.\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * RELFAC REAL, default = 2.0e0\n\ * The relative tolerance. An interval (a,b] lies within\n\ * \"relative tolerance\" if b-a < RELFAC*ulp*max(|a|,|b|),\n\ * where \"ulp\" is the machine precision (distance from 1 to\n\ * the next larger floating point number.)\n\ *\n\ * FUDGE REAL, default = 2\n\ * A \"fudge factor\" to widen the Gershgorin intervals. Ideally,\n\ * a value of 1 should work, but on machines with sloppy\n\ * arithmetic, this needs to be larger. The default for\n\ * publicly released versions should be large enough to handle\n\ * the worst machine around. Note that this has no effect\n\ * on accuracy of the solution.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgbtf20000644000175000017500000000741512502223526016406 0ustar uwabamiuwabami--- :name: sgbtf2 :md5sum: 994c6c0f6c9f543f6e7b3330c848aeb8 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGBTF2 computes an LU factorization of a real m-by-n band matrix A\n\ * using partial pivoting with row interchanges.\n\ *\n\ * This is the unblocked version of the algorithm, calling Level 2 BLAS.\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\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * AB (input/output) REAL array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows KL+1 to\n\ * 2*KL+KU+1; rows 1 to KL of the array need not be set.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n\ *\n\ * On exit, details of the factorization: U is stored as an\n\ * upper triangular band matrix with KL+KU superdiagonals in\n\ * rows 1 to KL+KU+1, and the multipliers used during the\n\ * factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n\ * See below for further details.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n\ *\n\ * IPIV (output) INTEGER array, dimension (min(M,N))\n\ * The pivot indices; for 1 <= i <= min(M,N), row i of the\n\ * matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, and division by zero will occur if it is used\n\ * to solve a system of equations.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * M = N = 6, KL = 2, KU = 1:\n\ *\n\ * On entry: On exit:\n\ *\n\ * * * * + + + * * * u14 u25 u36\n\ * * * + + + + * * u13 u24 u35 u46\n\ * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n\ * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n\ * a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n\ * a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n\ *\n\ * Array elements marked * are not used by the routine; elements marked\n\ * + need not be set on entry, but are required by the routine to store\n\ * elements of U, because of fill-in resulting from the row\n\ * interchanges.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sppequ0000644000175000017500000000534512502223526016534 0ustar uwabamiuwabami--- :name: sppequ :md5sum: dd4a1d4820fa068a3609978bd96479a3 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input :dims: - ldap - s: :type: real :intent: output :dims: - n - scond: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE SPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPPEQU computes row and column scalings intended to equilibrate a\n\ * symmetric positive definite matrix A in packed storage and reduce\n\ * its condition number (with respect to the two-norm). S contains the\n\ * scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix\n\ * B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.\n\ * This choice of S puts the condition number of B within a factor N of\n\ * the smallest possible condition number over all possible diagonal\n\ * scalings.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input) REAL array, dimension (N*(N+1)/2)\n\ * The upper or lower triangle of the symmetric matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * S (output) REAL array, dimension (N)\n\ * If INFO = 0, S contains the scale factors for A.\n\ *\n\ * SCOND (output) REAL\n\ * If INFO = 0, S contains the ratio of the smallest S(i) to\n\ * the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n\ * large nor too small, it is not worth scaling by S.\n\ *\n\ * AMAX (output) REAL\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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 is nonpositive.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cggbal0000644000175000017500000001171412502223525016432 0ustar uwabamiuwabami--- :name: cggbal :md5sum: c943f265fd54c6aa73b300bdb1dec322 :category: :subroutine :arguments: - job: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - lscale: :type: real :intent: output :dims: - n - rscale: :type: real :intent: output :dims: - n - work: :type: real :intent: workspace :dims: - "(lsame_(&job,\"S\")||lsame_(&job,\"B\")) ? MAX(1,6*n) : (lsame_(&job,\"N\")||lsame_(&job,\"P\")) ? 1 : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGGBAL balances a pair of general complex matrices (A,B). This\n\ * involves, first, permuting A and B by similarity transformations to\n\ * isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N\n\ * elements on the diagonal; and second, applying a diagonal similarity\n\ * transformation to rows and columns ILO to IHI to make the rows\n\ * and columns as close in norm as possible. Both steps are optional.\n\ *\n\ * Balancing may reduce the 1-norm of the matrices, and improve the\n\ * accuracy of the computed eigenvalues and/or eigenvectors in the\n\ * generalized eigenvalue problem A*x = lambda*B*x.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * Specifies the operations to be performed on A and B:\n\ * = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0\n\ * and RSCALE(I) = 1.0 for i=1,...,N;\n\ * = 'P': permute only;\n\ * = 'S': scale only;\n\ * = 'B': both permute and scale.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the input matrix A.\n\ * On exit, A is overwritten by the balanced matrix.\n\ * If JOB = 'N', A is not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,N)\n\ * On entry, the input matrix B.\n\ * On exit, B is overwritten by the balanced matrix.\n\ * If JOB = 'N', B is not referenced.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * ILO (output) INTEGER\n\ * IHI (output) INTEGER\n\ * ILO and IHI are set to integers such that on exit\n\ * A(i,j) = 0 and B(i,j) = 0 if i > j and\n\ * j = 1,...,ILO-1 or i = IHI+1,...,N.\n\ * If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n\ *\n\ * LSCALE (output) REAL array, dimension (N)\n\ * Details of the permutations and scaling factors applied\n\ * to the left side of A and B. If P(j) is the index of the\n\ * row interchanged with row j, and D(j) is the scaling factor\n\ * applied to row j, then\n\ * LSCALE(j) = P(j) for J = 1,...,ILO-1\n\ * = D(j) for J = ILO,...,IHI\n\ * = P(j) for J = IHI+1,...,N.\n\ * The order in which the interchanges are made is N to IHI+1,\n\ * then 1 to ILO-1.\n\ *\n\ * RSCALE (output) REAL array, dimension (N)\n\ * Details of the permutations and scaling factors applied\n\ * to the right side of A and B. If P(j) is the index of the\n\ * column interchanged with column j, and D(j) is the scaling\n\ * factor applied to column j, then\n\ * RSCALE(j) = P(j) for J = 1,...,ILO-1\n\ * = D(j) for J = ILO,...,IHI\n\ * = P(j) for J = IHI+1,...,N.\n\ * The order in which the interchanges are made is N to IHI+1,\n\ * then 1 to ILO-1.\n\ *\n\ * WORK (workspace) REAL array, dimension (lwork)\n\ * lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and\n\ * at least 1 when JOB = 'N' or 'P'.\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\ * See R.C. WARD, Balancing the generalized eigenvalue problem,\n\ * SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slaev20000644000175000017500000000461512502223526016412 0ustar uwabamiuwabami--- :name: slaev2 :md5sum: b2933ce4bc39bd2862647978c0b49408 :category: :subroutine :arguments: - a: :type: real :intent: input - b: :type: real :intent: input - c: :type: real :intent: input - rt1: :type: real :intent: output - rt2: :type: real :intent: output - cs1: :type: real :intent: output - sn1: :type: real :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLAEV2( A, B, C, RT1, RT2, CS1, SN1 )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix\n\ * [ A B ]\n\ * [ B C ].\n\ * On return, RT1 is the eigenvalue of larger absolute value, RT2 is the\n\ * eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right\n\ * eigenvector for RT1, giving the decomposition\n\ *\n\ * [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ]\n\ * [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ].\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * A (input) REAL\n\ * The (1,1) element of the 2-by-2 matrix.\n\ *\n\ * B (input) REAL\n\ * The (1,2) element and the conjugate of the (2,1) element of\n\ * the 2-by-2 matrix.\n\ *\n\ * C (input) REAL\n\ * The (2,2) element of the 2-by-2 matrix.\n\ *\n\ * RT1 (output) REAL\n\ * The eigenvalue of larger absolute value.\n\ *\n\ * RT2 (output) REAL\n\ * The eigenvalue of smaller absolute value.\n\ *\n\ * CS1 (output) REAL\n\ * SN1 (output) REAL\n\ * The vector (CS1, SN1) is a unit right eigenvector for RT1.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * RT1 is accurate to a few ulps barring over/underflow.\n\ *\n\ * RT2 may be inaccurate if there is massive cancellation in the\n\ * determinant A*C-B*B; higher precision or correctly rounded or\n\ * correctly truncated arithmetic would be needed to compute RT2\n\ * accurately in all cases.\n\ *\n\ * CS1 and SN1 are accurate to a few ulps barring over/underflow.\n\ *\n\ * Overflow is possible only if RT1 is within a factor of 5 of overflow.\n\ * Underflow is harmless if the input data is 0 or exceeds\n\ * underflow_threshold / macheps.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlasd40000644000175000017500000000730212502223526016365 0ustar uwabamiuwabami--- :name: dlasd4 :md5sum: f02b36b4a85646e4e01e1dd6445ec7fe :category: :subroutine :arguments: - n: :type: integer :intent: input - i: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - z: :type: doublereal :intent: input :dims: - n - delta: :type: doublereal :intent: output :dims: - n - rho: :type: doublereal :intent: input - sigma: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This subroutine computes the square root of the I-th updated\n\ * eigenvalue of a positive symmetric rank-one modification to\n\ * a positive diagonal matrix whose entries are given as the squares\n\ * of the corresponding entries in the array d, and that\n\ *\n\ * 0 <= D(i) < D(j) for i < j\n\ *\n\ * and that RHO > 0. This is arranged by the calling routine, and is\n\ * no loss in generality. The rank-one modified system is thus\n\ *\n\ * diag( D ) * diag( D ) + RHO * Z * Z_transpose.\n\ *\n\ * where we assume the Euclidean norm of Z is 1.\n\ *\n\ * The method consists of approximating the rational functions in the\n\ * secular equation by simpler interpolating rational functions.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The length of all arrays.\n\ *\n\ * I (input) INTEGER\n\ * The index of the eigenvalue to be computed. 1 <= I <= N.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension ( N )\n\ * The original eigenvalues. It is assumed that they are in\n\ * order, 0 <= D(I) < D(J) for I < J.\n\ *\n\ * Z (input) DOUBLE PRECISION array, dimension ( N )\n\ * The components of the updating vector.\n\ *\n\ * DELTA (output) DOUBLE PRECISION array, dimension ( N )\n\ * If N .ne. 1, DELTA contains (D(j) - sigma_I) in its j-th\n\ * component. If N = 1, then DELTA(1) = 1. The vector DELTA\n\ * contains the information necessary to construct the\n\ * (singular) eigenvectors.\n\ *\n\ * RHO (input) DOUBLE PRECISION\n\ * The scalar in the symmetric updating formula.\n\ *\n\ * SIGMA (output) DOUBLE PRECISION\n\ * The computed sigma_I, the I-th updated eigenvalue.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension ( N )\n\ * If N .ne. 1, WORK contains (D(j) + sigma_I) in its j-th\n\ * component. If N = 1, then WORK( 1 ) = 1.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * > 0: if INFO = 1, the updating process failed.\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * Logical variable ORGATI (origin-at-i?) is used for distinguishing\n\ * whether D(i) or D(i+1) is treated as the origin.\n\ *\n\ * ORGATI = .true. origin at i\n\ * ORGATI = .false. origin at i+1\n\ *\n\ * Logical variable SWTCH3 (switch-for-3-poles?) is for noting\n\ * if we are working with THREE poles!\n\ *\n\ * MAXIT is the maximum number of iterations allowed for each\n\ * eigenvalue.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ren-Cang Li, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/spoequ0000644000175000017500000000475612502223526016540 0ustar uwabamiuwabami--- :name: spoequ :md5sum: 126e431bf7b286f0e96b4a6356abcc11 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - s: :type: real :intent: output :dims: - n - scond: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPOEQU computes row and column scalings intended to equilibrate a\n\ * symmetric positive definite matrix A and reduce its condition number\n\ * (with respect to the two-norm). S contains the scale factors,\n\ * S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n\ * elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n\ * choice of S puts the condition number of B within a factor N of the\n\ * smallest possible condition number over all possible diagonal\n\ * scalings.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * The N-by-N symmetric positive definite matrix whose scaling\n\ * factors are to be computed. Only the diagonal elements of A\n\ * are referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * S (output) REAL array, dimension (N)\n\ * If INFO = 0, S contains the scale factors for A.\n\ *\n\ * SCOND (output) REAL\n\ * If INFO = 0, S contains the ratio of the smallest S(i) to\n\ * the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n\ * large nor too small, it is not worth scaling by S.\n\ *\n\ * AMAX (output) REAL\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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 is nonpositive.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chegs20000644000175000017500000000574212502223525016372 0ustar uwabamiuwabami--- :name: chegs2 :md5sum: a0d46b53c7c5c0b238a824e94376e3ae :category: :subroutine :arguments: - itype: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHEGS2 reduces a complex Hermitian-definite generalized\n\ * eigenproblem to standard form.\n\ *\n\ * If ITYPE = 1, the problem is A*x = lambda*B*x,\n\ * and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')\n\ *\n\ * If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n\ * B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.\n\ *\n\ * B must have been previously factorized as U'*U or L*L' by CPOTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');\n\ * = 2 or 3: compute U*A*U' or L'*A*L.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * Hermitian matrix A is stored, and how B has been factorized.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the leading\n\ * n by n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n by n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the transformed matrix, stored in the\n\ * same format as A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,N)\n\ * The triangular factor from the Cholesky factorization of B,\n\ * as returned by CPOTRF.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dtgsyl0000644000175000017500000002301312502223526016515 0ustar uwabamiuwabami--- :name: dtgsyl :md5sum: 331c0eca19ec1c602ac38fd718147715 :category: :subroutine :arguments: - trans: :type: char :intent: input - ijob: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - m - lda: :type: integer :intent: input - b: :type: doublereal :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - ldd - m - ldd: :type: integer :intent: input - e: :type: doublereal :intent: input :dims: - lde - n - lde: :type: integer :intent: input - f: :type: doublereal :intent: input/output :dims: - ldf - n - ldf: :type: integer :intent: input - scale: :type: doublereal :intent: output - dif: :type: doublereal :intent: output - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "((ijob==1||ijob==2)&&lsame_(&trans,\"N\")) ? 2*m*n : 1" - iwork: :type: integer :intent: workspace :dims: - m+n+6 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTGSYL solves the generalized Sylvester equation:\n\ *\n\ * A * R - L * B = scale * C (1)\n\ * D * R - L * E = scale * F\n\ *\n\ * where R and L are unknown m-by-n matrices, (A, D), (B, E) and\n\ * (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n,\n\ * respectively, with real entries. (A, D) and (B, E) must be in\n\ * generalized (real) Schur canonical form, i.e. A, B are upper quasi\n\ * triangular and D, E are upper triangular.\n\ *\n\ * The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output\n\ * scaling factor chosen to avoid overflow.\n\ *\n\ * In matrix notation (1) is equivalent to solve Zx = scale b, where\n\ * Z is defined as\n\ *\n\ * Z = [ kron(In, A) -kron(B', Im) ] (2)\n\ * [ kron(In, D) -kron(E', Im) ].\n\ *\n\ * Here Ik is the identity matrix of size k and X' is the transpose of\n\ * X. kron(X, Y) is the Kronecker product between the matrices X and Y.\n\ *\n\ * If TRANS = 'T', DTGSYL solves the transposed system Z'*y = scale*b,\n\ * which is equivalent to solve for R and L in\n\ *\n\ * A' * R + D' * L = scale * C (3)\n\ * R * B' + L * E' = scale * (-F)\n\ *\n\ * This case (TRANS = 'T') is used to compute an one-norm-based estimate\n\ * of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D)\n\ * and (B,E), using DLACON.\n\ *\n\ * If IJOB >= 1, DTGSYL computes a Frobenius norm-based estimate\n\ * of Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the\n\ * reciprocal of the smallest singular value of Z. See [1-2] for more\n\ * information.\n\ *\n\ * This is a level 3 BLAS algorithm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N', solve the generalized Sylvester equation (1).\n\ * = 'T', solve the 'transposed' system (3).\n\ *\n\ * IJOB (input) INTEGER\n\ * Specifies what kind of functionality to be performed.\n\ * =0: solve (1) only.\n\ * =1: The functionality of 0 and 3.\n\ * =2: The functionality of 0 and 4.\n\ * =3: Only an estimate of Dif[(A,D), (B,E)] is computed.\n\ * (look ahead strategy IJOB = 1 is used).\n\ * =4: Only an estimate of Dif[(A,D), (B,E)] is computed.\n\ * ( DGECON on sub-systems is used ).\n\ * Not referenced if TRANS = 'T'.\n\ *\n\ * M (input) INTEGER\n\ * The order of the matrices A and D, and the row dimension of\n\ * the matrices C, F, R and L.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices B and E, and the column dimension\n\ * of the matrices C, F, R and L.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA, M)\n\ * The upper quasi triangular matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1, M).\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB, N)\n\ * The upper quasi triangular matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1, N).\n\ *\n\ * C (input/output) DOUBLE PRECISION array, dimension (LDC, N)\n\ * On entry, C contains the right-hand-side of the first matrix\n\ * equation in (1) or (3).\n\ * On exit, if IJOB = 0, 1 or 2, C has been overwritten by\n\ * the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R,\n\ * the solution achieved during the computation of the\n\ * Dif-estimate.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1, M).\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (LDD, M)\n\ * The upper triangular matrix D.\n\ *\n\ * LDD (input) INTEGER\n\ * The leading dimension of the array D. LDD >= max(1, M).\n\ *\n\ * E (input) DOUBLE PRECISION array, dimension (LDE, N)\n\ * The upper triangular matrix E.\n\ *\n\ * LDE (input) INTEGER\n\ * The leading dimension of the array E. LDE >= max(1, N).\n\ *\n\ * F (input/output) DOUBLE PRECISION array, dimension (LDF, N)\n\ * On entry, F contains the right-hand-side of the second matrix\n\ * equation in (1) or (3).\n\ * On exit, if IJOB = 0, 1 or 2, F has been overwritten by\n\ * the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L,\n\ * the solution achieved during the computation of the\n\ * Dif-estimate.\n\ *\n\ * LDF (input) INTEGER\n\ * The leading dimension of the array F. LDF >= max(1, M).\n\ *\n\ * DIF (output) DOUBLE PRECISION\n\ * On exit DIF is the reciprocal of a lower bound of the\n\ * reciprocal of the Dif-function, i.e. DIF is an upper bound of\n\ * Dif[(A,D), (B,E)] = sigma_min(Z), where Z as in (2).\n\ * IF IJOB = 0 or TRANS = 'T', DIF is not touched.\n\ *\n\ * SCALE (output) DOUBLE PRECISION\n\ * On exit SCALE is the scaling factor in (1) or (3).\n\ * If 0 < SCALE < 1, C and F hold the solutions R and L, resp.,\n\ * to a slightly perturbed system but the input matrices A, B, D\n\ * and E have not been changed. If SCALE = 0, C and F hold the\n\ * solutions R and L, respectively, to the homogeneous system\n\ * with C = F = 0. Normally, SCALE = 1.\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 > = 1.\n\ * If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N).\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\ * IWORK (workspace) INTEGER array, dimension (M+N+6)\n\ *\n\ * INFO (output) INTEGER\n\ * =0: successful exit\n\ * <0: If INFO = -i, the i-th argument had an illegal value.\n\ * >0: (A, D) and (B, E) have common or close eigenvalues.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n\ * for Solving the Generalized Sylvester Equation and Estimating the\n\ * Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n\ * Department of Computing Science, Umea University, S-901 87 Umea,\n\ * Sweden, December 1993, Revised April 1994, Also as LAPACK Working\n\ * Note 75. To appear in ACM Trans. on Math. Software, Vol 22,\n\ * No 1, 1996.\n\ *\n\ * [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester\n\ * Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal.\n\ * Appl., 15(4):1045-1060, 1994\n\ *\n\ * [3] B. Kagstrom and L. Westin, Generalized Schur Methods with\n\ * Condition Estimators for Solving the Generalized Sylvester\n\ * Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7,\n\ * July 1989, pp 745-751.\n\ *\n\ * =====================================================================\n\ * Replaced various illegal calls to DCOPY by calls to DLASET.\n\ * Sven Hammarling, 1/5/02.\n\ *\n" ruby-lapack-1.7.2/dev/defs/strsna0000644000175000017500000002063012502223526016523 0ustar uwabamiuwabami--- :name: strsna :md5sum: 1e372d5e18a7cb4bcbdd88ae0cc3766b :category: :subroutine :arguments: - job: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - t: :type: real :intent: input :dims: - ldt - n - ldt: :type: integer :intent: input - vl: :type: real :intent: input :dims: - ldvl - m - ldvl: :type: integer :intent: input - vr: :type: real :intent: input :dims: - ldvr - m - ldvr: :type: integer :intent: input - s: :type: real :intent: output :dims: - mm - sep: :type: real :intent: output :dims: - mm - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: real :intent: workspace :dims: - "lsame_(&job,\"E\") ? 0 : ldwork" - "lsame_(&job,\"E\") ? 0 : n+6" - ldwork: :type: integer :intent: input - iwork: :type: integer :intent: workspace :dims: - "lsame_(&job,\"E\") ? 0 : 2*(n-1)" - info: :type: integer :intent: output :substitutions: ldwork: "((lsame_(&job,\"V\")) || (lsame_(&job,\"B\"))) ? n : 1" mm: m :fortran_help: " SUBROUTINE STRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STRSNA estimates reciprocal condition numbers for specified\n\ * eigenvalues and/or right eigenvectors of a real upper\n\ * quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q\n\ * orthogonal).\n\ *\n\ * T must be in Schur canonical form (as returned by SHSEQR), that is,\n\ * block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each\n\ * 2-by-2 diagonal block has its diagonal elements equal and its\n\ * off-diagonal elements of opposite sign.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * Specifies whether condition numbers are required for\n\ * eigenvalues (S) or eigenvectors (SEP):\n\ * = 'E': for eigenvalues only (S);\n\ * = 'V': for eigenvectors only (SEP);\n\ * = 'B': for both eigenvalues and eigenvectors (S and SEP).\n\ *\n\ * HOWMNY (input) CHARACTER*1\n\ * = 'A': compute condition numbers for all eigenpairs;\n\ * = 'S': compute condition numbers for selected eigenpairs\n\ * specified by the array SELECT.\n\ *\n\ * SELECT (input) LOGICAL array, dimension (N)\n\ * If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n\ * condition numbers are required. To select condition numbers\n\ * for the eigenpair corresponding to a real eigenvalue w(j),\n\ * SELECT(j) must be set to .TRUE.. To select condition numbers\n\ * corresponding to a complex conjugate pair of eigenvalues w(j)\n\ * and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be\n\ * set to .TRUE..\n\ * If HOWMNY = 'A', SELECT is not referenced.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix T. N >= 0.\n\ *\n\ * T (input) REAL array, dimension (LDT,N)\n\ * The upper quasi-triangular matrix T, in Schur canonical form.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= max(1,N).\n\ *\n\ * VL (input) REAL array, dimension (LDVL,M)\n\ * If JOB = 'E' or 'B', VL must contain left eigenvectors of T\n\ * (or of any Q*T*Q**T with Q orthogonal), corresponding to the\n\ * eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n\ * must be stored in consecutive columns of VL, as returned by\n\ * SHSEIN or STREVC.\n\ * If JOB = 'V', VL is not referenced.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the array VL.\n\ * LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.\n\ *\n\ * VR (input) REAL array, dimension (LDVR,M)\n\ * If JOB = 'E' or 'B', VR must contain right eigenvectors of T\n\ * (or of any Q*T*Q**T with Q orthogonal), corresponding to the\n\ * eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n\ * must be stored in consecutive columns of VR, as returned by\n\ * SHSEIN or STREVC.\n\ * If JOB = 'V', VR is not referenced.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the array VR.\n\ * LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.\n\ *\n\ * S (output) REAL array, dimension (MM)\n\ * If JOB = 'E' or 'B', the reciprocal condition numbers of the\n\ * selected eigenvalues, stored in consecutive elements of the\n\ * array. For a complex conjugate pair of eigenvalues two\n\ * consecutive elements of S are set to the same value. Thus\n\ * S(j), SEP(j), and the j-th columns of VL and VR all\n\ * correspond to the same eigenpair (but not in general the\n\ * j-th eigenpair, unless all eigenpairs are selected).\n\ * If JOB = 'V', S is not referenced.\n\ *\n\ * SEP (output) REAL array, dimension (MM)\n\ * If JOB = 'V' or 'B', the estimated reciprocal condition\n\ * numbers of the selected eigenvectors, stored in consecutive\n\ * elements of the array. For a complex eigenvector two\n\ * consecutive elements of SEP are set to the same value. If\n\ * the eigenvalues cannot be reordered to compute SEP(j), SEP(j)\n\ * is set to 0; this can only occur when the true value would be\n\ * very small anyway.\n\ * If JOB = 'E', SEP is not referenced.\n\ *\n\ * MM (input) INTEGER\n\ * The number of elements in the arrays S (if JOB = 'E' or 'B')\n\ * and/or SEP (if JOB = 'V' or 'B'). MM >= M.\n\ *\n\ * M (output) INTEGER\n\ * The number of elements of the arrays S and/or SEP actually\n\ * used to store the estimated condition numbers.\n\ * If HOWMNY = 'A', M is set to N.\n\ *\n\ * WORK (workspace) REAL array, dimension (LDWORK,N+6)\n\ * If JOB = 'E', WORK is not referenced.\n\ *\n\ * LDWORK (input) INTEGER\n\ * The leading dimension of the array WORK.\n\ * LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (2*(N-1))\n\ * If JOB = 'E', IWORK is not referenced.\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 reciprocal of the condition number of an eigenvalue lambda is\n\ * defined as\n\ *\n\ * S(lambda) = |v'*u| / (norm(u)*norm(v))\n\ *\n\ * where u and v are the right and left eigenvectors of T corresponding\n\ * to lambda; v' denotes the conjugate-transpose of v, and norm(u)\n\ * denotes the Euclidean norm. These reciprocal condition numbers always\n\ * lie between zero (very badly conditioned) and one (very well\n\ * conditioned). If n = 1, S(lambda) is defined to be 1.\n\ *\n\ * An approximate error bound for a computed eigenvalue W(i) is given by\n\ *\n\ * EPS * norm(T) / S(i)\n\ *\n\ * where EPS is the machine precision.\n\ *\n\ * The reciprocal of the condition number of the right eigenvector u\n\ * corresponding to lambda is defined as follows. Suppose\n\ *\n\ * T = ( lambda c )\n\ * ( 0 T22 )\n\ *\n\ * Then the reciprocal condition number is\n\ *\n\ * SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )\n\ *\n\ * where sigma-min denotes the smallest singular value. We approximate\n\ * the smallest singular value by the reciprocal of an estimate of the\n\ * one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is\n\ * defined to be abs(T(1,1)).\n\ *\n\ * An approximate error bound for a computed right eigenvector VR(i)\n\ * is given by\n\ *\n\ * EPS * norm(T) / SEP(i)\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chbgvx0000644000175000017500000002163412502223525016476 0ustar uwabamiuwabami--- :name: chbgvx :md5sum: 994b0281e65266e3f6c89ad887294c10 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: complex :intent: input/output :dims: - ldbb - n - ldbb: :type: integer :intent: input - q: :type: complex :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - n - rwork: :type: real :intent: workspace :dims: - 7*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? n : 1" ldq: "1 ? jobz = 'n' : MAX(1,n) ? jobz = 'v' : 0" :fortran_help: " SUBROUTINE CHBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHBGVX computes all the eigenvalues, and optionally, the eigenvectors\n\ * of a complex generalized Hermitian-definite banded eigenproblem, of\n\ * the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian\n\ * and banded, and B is also positive definite. Eigenvalues and\n\ * eigenvectors can be selected by specifying either all eigenvalues,\n\ * a range of values or a range of indices for the desired eigenvalues.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found;\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found;\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * KA (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n\ *\n\ * KB (input) INTEGER\n\ * The number of superdiagonals of the matrix B if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n\ *\n\ * AB (input/output) COMPLEX array, dimension (LDAB, N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix A, stored in the first ka+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n\ *\n\ * On exit, the contents of AB are destroyed.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KA+1.\n\ *\n\ * BB (input/output) COMPLEX array, dimension (LDBB, N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix B, stored in the first kb+1 rows of the array. The\n\ * j-th column of B is stored in the j-th column of the array BB\n\ * as follows:\n\ * if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n\ * if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n\ *\n\ * On exit, the factor S from the split Cholesky factorization\n\ * B = S**H*S, as returned by CPBSTF.\n\ *\n\ * LDBB (input) INTEGER\n\ * The leading dimension of the array BB. LDBB >= KB+1.\n\ *\n\ * Q (output) COMPLEX array, dimension (LDQ, N)\n\ * If JOBZ = 'V', the n-by-n matrix used in the reduction of\n\ * A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x,\n\ * and consequently C to tridiagonal form.\n\ * If JOBZ = 'N', the array Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. If JOBZ = 'N',\n\ * LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N).\n\ *\n\ * VL (input) REAL\n\ * VU (input) REAL\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) REAL\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less than\n\ * or equal to zero, then EPS*|T| will be used in its place,\n\ * where |T| is the 1-norm of the tridiagonal matrix obtained\n\ * by reducing AP to tridiagonal form.\n\ *\n\ * Eigenvalues will be computed most accurately when ABSTOL is\n\ * set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n\ * If this routine returns with INFO>0, indicating that some\n\ * eigenvectors did not converge, try setting ABSTOL to\n\ * 2*SLAMCH('S').\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) COMPLEX array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n\ * eigenvectors, with the i-th column of Z holding the\n\ * eigenvector associated with W(i). The eigenvectors are\n\ * normalized so that Z**H*B*Z = I.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= N.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (7*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (5*N)\n\ *\n\ * IFAIL (output) INTEGER array, dimension (N)\n\ * If JOBZ = 'V', then if INFO = 0, the first M elements of\n\ * IFAIL are zero. If INFO > 0, then IFAIL contains the\n\ * indices of the eigenvectors that failed to converge.\n\ * If JOBZ = 'N', then IFAIL is not referenced.\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, and i is:\n\ * <= N: then i eigenvectors failed to converge. Their\n\ * indices are stored in array IFAIL.\n\ * > N: if INFO = N + i, for 1 <= i <= N, then CPBSTF\n\ * returned INFO = i: B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zla_syrcond_x0000644000175000017500000000661712502223526020100 0ustar uwabamiuwabami--- :name: zla_syrcond_x :md5sum: 2ee84b2298e93cd97cc2b1f8137a5f05 :category: :function :type: doublereal :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - x: :type: doublecomplex :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: doublecomplex :intent: input :dims: - 2*n - rwork: :type: doublereal :intent: input :dims: - n :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION ZLA_SYRCOND_X( UPLO, N, A, LDA, AF, LDAF, IPIV, X, INFO, WORK, RWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLA_SYRCOND_X Computes the infinity norm condition number of\n\ * op(A) * diag(X) where X is a COMPLEX*16 vector.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX*16 array, dimension (LDAF,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by ZSYTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by ZSYTRF.\n\ *\n\ * X (input) COMPLEX*16 array, dimension (N)\n\ * The vector X in the formula op(A) * diag(X).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * i > 0: The ith argument is invalid.\n\ *\n\ * WORK (input) COMPLEX*16 array, dimension (2*N).\n\ * Workspace.\n\ *\n\ * RWORK (input) DOUBLE PRECISION array, dimension (N).\n\ * Workspace.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER KASE\n DOUBLE PRECISION AINVNM, ANORM, TMP\n INTEGER I, J\n LOGICAL UP\n COMPLEX*16 ZDUM\n\ * ..\n\ * .. Local Arrays ..\n INTEGER ISAVE( 3 )\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL ZLACN2, ZSYTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n\ * ..\n\ * .. Statement Functions ..\n DOUBLE PRECISION CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zppequ0000644000175000017500000000545212502223526016542 0ustar uwabamiuwabami--- :name: zppequ :md5sum: a76caef1a7119edfff5a313f2a6c2966 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - ldap - s: :type: doublereal :intent: output :dims: - n - scond: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE ZPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPPEQU computes row and column scalings intended to equilibrate a\n\ * Hermitian positive definite matrix A in packed storage and reduce\n\ * its condition number (with respect to the two-norm). S contains the\n\ * scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix\n\ * B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.\n\ * This choice of S puts the condition number of B within a factor N of\n\ * the smallest possible condition number over all possible diagonal\n\ * scalings.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * The upper or lower triangle of the Hermitian matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * S (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, S contains the scale factors for A.\n\ *\n\ * SCOND (output) DOUBLE PRECISION\n\ * If INFO = 0, S contains the ratio of the smallest S(i) to\n\ * the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n\ * large nor too small, it is not worth scaling by S.\n\ *\n\ * AMAX (output) DOUBLE PRECISION\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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 is nonpositive.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgbrfs0000644000175000017500000001263312502223525016462 0ustar uwabamiuwabami--- :name: cgbrfs :md5sum: b26da869b9502286688e2b2960b3e223 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: complex :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGBRFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is banded, and provides\n\ * error bounds and backward error estimates for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AB (input) COMPLEX array, dimension (LDAB,N)\n\ * The original band matrix A, stored in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * AFB (input) COMPLEX array, dimension (LDAFB,N)\n\ * Details of the LU factorization of the band matrix A, as\n\ * computed by CGBTRF. U is stored as an upper triangular band\n\ * matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n\ * the multipliers used during the factorization are stored in\n\ * rows KL+KU+2 to 2*KL+KU+1.\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from CGBTRF; for 1<=i<=N, row i of the\n\ * matrix was interchanged with row IPIV(i).\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) COMPLEX array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by CGBTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgesvd0000644000175000017500000001606012502223526016467 0ustar uwabamiuwabami--- :name: dgesvd :md5sum: 979b942ecd658c595d1c5fd2d32bac36 :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobvt: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n :outdims: - lda - MIN(m,n) - lda: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - MIN(m,n) - u: :type: doublereal :intent: output :dims: - ldu - "lsame_(&jobu,\"A\") ? m : lsame_(&jobu,\"S\") ? MIN(m,n) : 0" - ldu: :type: integer :intent: input - vt: :type: doublereal :intent: output :dims: - ldvt - n - ldvt: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(MAX(1, 3*MIN(m,n)+MAX(m,n)), 5*MIN(m,n)) - info: :type: integer :intent: output :substitutions: m: lda ldvt: "lsame_(&jobvt,\"A\") ? n : lsame_(&jobvt,\"S\") ? MIN(m,n) : 1" ldu: "((lsame_(&jobu,\"S\")) || (lsame_(&jobu,\"A\"))) ? m : 1" :fortran_help: " SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGESVD computes the singular value decomposition (SVD) of a real\n\ * M-by-N matrix A, optionally computing the left and/or right singular\n\ * vectors. The SVD is written\n\ *\n\ * A = U * SIGMA * transpose(V)\n\ *\n\ * where SIGMA is an M-by-N matrix which is zero except for its\n\ * min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and\n\ * V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA\n\ * are the singular values of A; they are real and non-negative, and\n\ * are returned in descending order. The first min(m,n) columns of\n\ * U and V are the left and right singular vectors of A.\n\ *\n\ * Note that the routine returns V**T, not V.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBU (input) CHARACTER*1\n\ * Specifies options for computing all or part of the matrix U:\n\ * = 'A': all M columns of U are returned in array U:\n\ * = 'S': the first min(m,n) columns of U (the left singular\n\ * vectors) are returned in the array U;\n\ * = 'O': the first min(m,n) columns of U (the left singular\n\ * vectors) are overwritten on the array A;\n\ * = 'N': no columns of U (no left singular vectors) are\n\ * computed.\n\ *\n\ * JOBVT (input) CHARACTER*1\n\ * Specifies options for computing all or part of the matrix\n\ * V**T:\n\ * = 'A': all N rows of V**T are returned in the array VT;\n\ * = 'S': the first min(m,n) rows of V**T (the right singular\n\ * vectors) are returned in the array VT;\n\ * = 'O': the first min(m,n) rows of V**T (the right singular\n\ * vectors) are overwritten on the array A;\n\ * = 'N': no rows of V**T (no right singular vectors) are\n\ * computed.\n\ *\n\ * JOBVT and JOBU cannot both be 'O'.\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. 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,\n\ * if JOBU = 'O', A is overwritten with the first min(m,n)\n\ * columns of U (the left singular vectors,\n\ * stored columnwise);\n\ * if JOBVT = 'O', A is overwritten with the first min(m,n)\n\ * rows of V**T (the right singular vectors,\n\ * stored rowwise);\n\ * if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A\n\ * are destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * S (output) DOUBLE PRECISION array, dimension (min(M,N))\n\ * The singular values of A, sorted so that S(i) >= S(i+1).\n\ *\n\ * U (output) DOUBLE PRECISION array, dimension (LDU,UCOL)\n\ * (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.\n\ * If JOBU = 'A', U contains the M-by-M orthogonal matrix U;\n\ * if JOBU = 'S', U contains the first min(m,n) columns of U\n\ * (the left singular vectors, stored columnwise);\n\ * if JOBU = 'N' or 'O', U is not referenced.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= 1; if\n\ * JOBU = 'S' or 'A', LDU >= M.\n\ *\n\ * VT (output) DOUBLE PRECISION array, dimension (LDVT,N)\n\ * If JOBVT = 'A', VT contains the N-by-N orthogonal matrix\n\ * V**T;\n\ * if JOBVT = 'S', VT contains the first min(m,n) rows of\n\ * V**T (the right singular vectors, stored rowwise);\n\ * if JOBVT = 'N' or 'O', VT is not referenced.\n\ *\n\ * LDVT (input) INTEGER\n\ * The leading dimension of the array VT. LDVT >= 1; if\n\ * JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(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\ * if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged\n\ * superdiagonal elements of an upper bidiagonal matrix B\n\ * whose diagonal is in S (not necessarily sorted). B\n\ * satisfies A = U * B * VT, so it has the same singular values\n\ * as A, and singular vectors related by U and VT.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK.\n\ * LWORK >= MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)).\n\ * For good performance, LWORK should generally be larger.\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 DBDSQR did not converge, INFO specifies how many\n\ * superdiagonals of an intermediate bidiagonal form B\n\ * did not converge to zero. See the description of WORK\n\ * above for details.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgejsv0000644000175000017500000022031112502223526016471 0ustar uwabamiuwabami--- :name: dgejsv :md5sum: 48e427f846d8774d81a35aecade0f887 :category: :subroutine :arguments: - joba: :type: char :intent: input - jobu: :type: char :intent: input - jobv: :type: char :intent: input - jobr: :type: char :intent: input - jobt: :type: char :intent: input - jobp: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - sva: :type: doublereal :intent: output :dims: - n - u: :type: doublereal :intent: output :dims: - ldu - n - ldu: :type: integer :intent: input - v: :type: doublereal :intent: output :dims: - ldv - n - ldv: :type: integer :intent: input - work: :type: doublereal :intent: input/output :dims: - lwork - lwork: :type: integer :intent: input :option: true :default: "(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)" - iwork: :type: integer :intent: output :dims: - m+3*n - info: :type: integer :intent: output :substitutions: ldu: "(lsame_(&jobu,\"U\")||lsame_(&jobu,\"F\")||lsame_(&jobu,\"W\")) ? m : 1" ldv: "(lsame_(&jobu,\"U\")||lsame_(&jobu,\"F\")||lsame_(&jobu,\"W\")) ? n : 1" :fortran_help: " 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" ruby-lapack-1.7.2/dev/defs/slasv20000644000175000017500000000571512502223526016432 0ustar uwabamiuwabami--- :name: slasv2 :md5sum: b294da011aae849d462bb6da2189b9d9 :category: :subroutine :arguments: - f: :type: real :intent: input - g: :type: real :intent: input - h: :type: real :intent: input - ssmin: :type: real :intent: output - ssmax: :type: real :intent: output - snr: :type: real :intent: output - csr: :type: real :intent: output - snl: :type: real :intent: output - csl: :type: real :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLASV2 computes the singular value decomposition of a 2-by-2\n\ * triangular matrix\n\ * [ F G ]\n\ * [ 0 H ].\n\ * On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the\n\ * smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and\n\ * right singular vectors for abs(SSMAX), giving the decomposition\n\ *\n\ * [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ]\n\ * [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ].\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * F (input) REAL\n\ * The (1,1) element of the 2-by-2 matrix.\n\ *\n\ * G (input) REAL\n\ * The (1,2) element of the 2-by-2 matrix.\n\ *\n\ * H (input) REAL\n\ * The (2,2) element of the 2-by-2 matrix.\n\ *\n\ * SSMIN (output) REAL\n\ * abs(SSMIN) is the smaller singular value.\n\ *\n\ * SSMAX (output) REAL\n\ * abs(SSMAX) is the larger singular value.\n\ *\n\ * SNL (output) REAL\n\ * CSL (output) REAL\n\ * The vector (CSL, SNL) is a unit left singular vector for the\n\ * singular value abs(SSMAX).\n\ *\n\ * SNR (output) REAL\n\ * CSR (output) REAL\n\ * The vector (CSR, SNR) is a unit right singular vector for the\n\ * singular value abs(SSMAX).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Any input parameter may be aliased with any output parameter.\n\ *\n\ * Barring over/underflow and assuming a guard digit in subtraction, all\n\ * output quantities are correct to within a few units in the last\n\ * place (ulps).\n\ *\n\ * In IEEE arithmetic, the code works correctly if one matrix element is\n\ * infinite.\n\ *\n\ * Overflow will not occur unless the largest singular value itself\n\ * overflows or is within a few ulps of overflow. (On machines with\n\ * partial overflow, like the Cray, overflow may occur if the largest\n\ * singular value is within a factor of 2 of overflow.)\n\ *\n\ * Underflow is harmless if underflow is gradual. Otherwise, results\n\ * may correspond to a matrix modified by perturbations of size near\n\ * the underflow threshold.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctrexc0000644000175000017500000000620412502223525016501 0ustar uwabamiuwabami--- :name: ctrexc :md5sum: 98fce909e94f4aeceac927f4fb0dce87 :category: :subroutine :arguments: - compq: :type: char :intent: input - n: :type: integer :intent: input - t: :type: complex :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - q: :type: complex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - ifst: :type: integer :intent: input - ilst: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTREXC reorders the Schur factorization of a complex matrix\n\ * A = Q*T*Q**H, so that the diagonal element of T with row index IFST\n\ * is moved to row ILST.\n\ *\n\ * The Schur form T is reordered by a unitary similarity transformation\n\ * Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by\n\ * postmultplying it with Z.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * COMPQ (input) CHARACTER*1\n\ * = 'V': update the matrix Q of Schur vectors;\n\ * = 'N': do not update Q.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix T. N >= 0.\n\ *\n\ * T (input/output) COMPLEX array, dimension (LDT,N)\n\ * On entry, the upper triangular matrix T.\n\ * On exit, the reordered upper triangular matrix.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= max(1,N).\n\ *\n\ * Q (input/output) COMPLEX array, dimension (LDQ,N)\n\ * On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n\ * On exit, if COMPQ = 'V', Q has been postmultiplied by the\n\ * unitary transformation matrix Z which reorders T.\n\ * If COMPQ = 'N', Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N).\n\ *\n\ * IFST (input) INTEGER\n\ * ILST (input) INTEGER\n\ * Specify the reordering of the diagonal elements of T:\n\ * The element with row index IFST is moved to row ILST by a\n\ * sequence of transpositions between adjacent elements.\n\ * 1 <= IFST <= N; 1 <= ILST <= N.\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\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL WANTQ\n INTEGER K, M1, M2, M3\n REAL CS\n COMPLEX SN, T11, T22, TEMP\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CLARTG, CROT, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC CONJG, MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cbbcsd0000644000175000017500000002222012502223525016425 0ustar uwabamiuwabami--- :name: cbbcsd :md5sum: 7e10136e0faadfd9b81e31ecfe50ed65 :category: :subroutine :arguments: - jobu1: :type: char :intent: input - jobu2: :type: char :intent: input - jobv1t: :type: char :intent: input - jobv2t: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - q: :type: integer :intent: input - theta: :type: real :intent: input/output :dims: - q - phi: :type: real :intent: input :dims: - q-1 - u1: :type: complex :intent: input/output :dims: - ldu1 - p - ldu1: :type: integer :intent: input - u2: :type: complex :intent: input/output :dims: - ldu2 - m-p - ldu2: :type: integer :intent: input - v1t: :type: complex :intent: input/output :dims: - ldv1t - q - ldv1t: :type: integer :intent: input - v2t: :type: complex :intent: input/output :dims: - ldv2t - m-q - ldv2t: :type: integer :intent: input - b11d: :type: real :intent: output :dims: - q - b11e: :type: real :intent: output :dims: - q-1 - b12d: :type: real :intent: output :dims: - q - b12e: :type: real :intent: output :dims: - q-1 - b21d: :type: real :intent: output :dims: - q - b21e: :type: real :intent: output :dims: - q-1 - b22d: :type: real :intent: output :dims: - q - b22e: :type: real :intent: output :dims: - q-1 - rwork: :type: real :intent: workspace :dims: - MAX(1,lrwork) - lrwork: :type: integer :intent: input :option: true :default: 8*q - info: :type: integer :intent: output :substitutions: lrwork: MAX(1,8*q) :fortran_help: " SUBROUTINE CBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, THETA, PHI, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, B22D, B22E, RWORK, LRWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CBBCSD computes the CS decomposition of a unitary matrix in\n\ * bidiagonal-block form,\n\ *\n\ *\n\ * [ B11 | B12 0 0 ]\n\ * [ 0 | 0 -I 0 ]\n\ * X = [----------------]\n\ * [ B21 | B22 0 0 ]\n\ * [ 0 | 0 0 I ]\n\ *\n\ * [ C | -S 0 0 ]\n\ * [ U1 | ] [ 0 | 0 -I 0 ] [ V1 | ]**H\n\ * = [---------] [---------------] [---------] .\n\ * [ | U2 ] [ S | C 0 0 ] [ | V2 ]\n\ * [ 0 | 0 0 I ]\n\ *\n\ * X is M-by-M, its top-left block is P-by-Q, and Q must be no larger\n\ * than P, M-P, or M-Q. (If Q is not the smallest index, then X must be\n\ * transposed and/or permuted. This can be done in constant time using\n\ * the TRANS and SIGNS options. See CUNCSD for details.)\n\ *\n\ * The bidiagonal matrices B11, B12, B21, and B22 are represented\n\ * implicitly by angles THETA(1:Q) and PHI(1:Q-1).\n\ *\n\ * The unitary matrices U1, U2, V1T, and V2T are input/output.\n\ * The input matrices are pre- or post-multiplied by the appropriate\n\ * singular vector matrices.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBU1 (input) CHARACTER\n\ * = 'Y': U1 is updated;\n\ * otherwise: U1 is not updated.\n\ *\n\ * JOBU2 (input) CHARACTER\n\ * = 'Y': U2 is updated;\n\ * otherwise: U2 is not updated.\n\ *\n\ * JOBV1T (input) CHARACTER\n\ * = 'Y': V1T is updated;\n\ * otherwise: V1T is not updated.\n\ *\n\ * JOBV2T (input) CHARACTER\n\ * = 'Y': V2T is updated;\n\ * otherwise: V2T is not updated.\n\ *\n\ * TRANS (input) CHARACTER\n\ * = 'T': X, U1, U2, V1T, and V2T are stored in row-major\n\ * order;\n\ * otherwise: X, U1, U2, V1T, and V2T are stored in column-\n\ * major order.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows and columns in X, the unitary matrix in\n\ * bidiagonal-block form.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows in the top-left block of X. 0 <= P <= M.\n\ *\n\ * Q (input) INTEGER\n\ * The number of columns in the top-left block of X.\n\ * 0 <= Q <= MIN(P,M-P,M-Q).\n\ *\n\ * THETA (input/output) REAL array, dimension (Q)\n\ * On entry, the angles THETA(1),...,THETA(Q) that, along with\n\ * PHI(1), ...,PHI(Q-1), define the matrix in bidiagonal-block\n\ * form. On exit, the angles whose cosines and sines define the\n\ * diagonal blocks in the CS decomposition.\n\ *\n\ * PHI (input/workspace) REAL array, dimension (Q-1)\n\ * The angles PHI(1),...,PHI(Q-1) that, along with THETA(1),...,\n\ * THETA(Q), define the matrix in bidiagonal-block form.\n\ *\n\ * U1 (input/output) COMPLEX array, dimension (LDU1,P)\n\ * On entry, an LDU1-by-P matrix. On exit, U1 is postmultiplied\n\ * by the left singular vector matrix common to [ B11 ; 0 ] and\n\ * [ B12 0 0 ; 0 -I 0 0 ].\n\ *\n\ * LDU1 (input) INTEGER\n\ * The leading dimension of the array U1.\n\ *\n\ * U2 (input/output) COMPLEX array, dimension (LDU2,M-P)\n\ * On entry, an LDU2-by-(M-P) matrix. On exit, U2 is\n\ * postmultiplied by the left singular vector matrix common to\n\ * [ B21 ; 0 ] and [ B22 0 0 ; 0 0 I ].\n\ *\n\ * LDU2 (input) INTEGER\n\ * The leading dimension of the array U2.\n\ *\n\ * V1T (input/output) COMPLEX array, dimension (LDV1T,Q)\n\ * On entry, a LDV1T-by-Q matrix. On exit, V1T is premultiplied\n\ * by the conjugate transpose of the right singular vector\n\ * matrix common to [ B11 ; 0 ] and [ B21 ; 0 ].\n\ *\n\ * LDV1T (input) INTEGER\n\ * The leading dimension of the array V1T.\n\ *\n\ * V2T (input/output) COMPLEX array, dimenison (LDV2T,M-Q)\n\ * On entry, a LDV2T-by-(M-Q) matrix. On exit, V2T is\n\ * premultiplied by the conjugate transpose of the right\n\ * singular vector matrix common to [ B12 0 0 ; 0 -I 0 ] and\n\ * [ B22 0 0 ; 0 0 I ].\n\ *\n\ * LDV2T (input) INTEGER\n\ * The leading dimension of the array V2T.\n\ *\n\ * B11D (output) REAL array, dimension (Q)\n\ * When CBBCSD converges, B11D contains the cosines of THETA(1),\n\ * ..., THETA(Q). If CBBCSD fails to converge, then B11D\n\ * contains the diagonal of the partially reduced top-left\n\ * block.\n\ *\n\ * B11E (output) REAL array, dimension (Q-1)\n\ * When CBBCSD converges, B11E contains zeros. If CBBCSD fails\n\ * to converge, then B11E contains the superdiagonal of the\n\ * partially reduced top-left block.\n\ *\n\ * B12D (output) REAL array, dimension (Q)\n\ * When CBBCSD converges, B12D contains the negative sines of\n\ * THETA(1), ..., THETA(Q). If CBBCSD fails to converge, then\n\ * B12D contains the diagonal of the partially reduced top-right\n\ * block.\n\ *\n\ * B12E (output) REAL array, dimension (Q-1)\n\ * When CBBCSD converges, B12E contains zeros. If CBBCSD fails\n\ * to converge, then B12E contains the subdiagonal of the\n\ * partially reduced top-right block.\n\ *\n\ * RWORK (workspace) REAL array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LRWORK (input) INTEGER\n\ * The dimension of the array RWORK. LRWORK >= MAX(1,8*Q).\n\ *\n\ * If LRWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal size of the RWORK array,\n\ * returns this value as the first entry of the work array, and\n\ * no error message related to LRWORK 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 CBBCSD did not converge, INFO specifies the number\n\ * of nonzero entries in PHI, and B11D, B11E, etc.,\n\ * contain the partially reduced matrix.\n\ *\n\ * Reference\n\ * =========\n\ *\n\ * [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.\n\ * Algorithms, 50(1):33-65, 2009.\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * TOLMUL REAL, default = MAX(10,MIN(100,EPS**(-1/8)))\n\ * TOLMUL controls the convergence criterion of the QR loop.\n\ * Angles THETA(i), PHI(i) are rounded to 0 or PI/2 when they\n\ * are within TOLMUL*EPS of either bound.\n\ *\n\n\ * ===================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlaqr10000644000175000017500000000356412502223526016432 0ustar uwabamiuwabami--- :name: zlaqr1 :md5sum: dc7298366a69e9aa5a46ad5c668db6b1 :category: :subroutine :arguments: - n: :type: integer :intent: input - h: :type: doublecomplex :intent: input :dims: - ldh - n - ldh: :type: integer :intent: input - s1: :type: doublecomplex :intent: input - s2: :type: doublecomplex :intent: input - v: :type: doublecomplex :intent: output :dims: - n :substitutions: {} :fortran_help: " SUBROUTINE ZLAQR1( N, H, LDH, S1, S2, V )\n\n\ * Given a 2-by-2 or 3-by-3 matrix H, ZLAQR1 sets v to a\n\ * scalar multiple of the first column of the product\n\ *\n\ * (*) K = (H - s1*I)*(H - s2*I)\n\ *\n\ * scaling to avoid overflows and most underflows.\n\ *\n\ * This is useful for starting double implicit shift bulges\n\ * in the QR algorithm.\n\ *\n\ *\n\n\ * N (input) integer\n\ * Order of the matrix H. N must be either 2 or 3.\n\ *\n\ * H (input) COMPLEX*16 array of dimension (LDH,N)\n\ * The 2-by-2 or 3-by-3 matrix H in (*).\n\ *\n\ * LDH (input) integer\n\ * The leading dimension of H as declared in\n\ * the calling procedure. LDH.GE.N\n\ *\n\ * S1 (input) COMPLEX*16\n\ * S2 S1 and S2 are the shifts defining K in (*) above.\n\ *\n\ * V (output) COMPLEX*16 array of dimension N\n\ * A scalar multiple of the first column of the\n\ * matrix K in (*).\n\ *\n\n\ * ================================================================\n\ * Based on contributions by\n\ * Karen Braman and Ralph Byers, Department of Mathematics,\n\ * University of Kansas, USA\n\ *\n\ * ================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cspsvx0000644000175000017500000002251112502223525016536 0ustar uwabamiuwabami--- :name: cspsvx :md5sum: 301c107c780567b960fdeac5c4653ffd :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - afp: :type: complex :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE CSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSPSVX uses the diagonal pivoting factorization A = U*D*U**T or\n\ * A = L*D*L**T to compute the solution to a complex system of linear\n\ * equations A * X = B, where A is an N-by-N symmetric matrix stored\n\ * in packed format and X and B are N-by-NRHS matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'N', the diagonal pivoting method is used to factor A as\n\ * A = U * D * U**T, if UPLO = 'U', or\n\ * A = L * D * L**T, if UPLO = 'L',\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices and D is symmetric and block diagonal with\n\ * 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\ * 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n\ * returns with INFO = i. Otherwise, the factored form of A is used\n\ * to estimate the condition number of the matrix A. If the\n\ * reciprocal of the condition number is less than machine precision,\n\ * INFO = N+1 is returned as a warning, but the routine still goes on\n\ * to solve for X and compute error bounds as described below.\n\ *\n\ * 3. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 4. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of A has been\n\ * supplied on entry.\n\ * = 'F': On entry, AFP and IPIV contain the factored form\n\ * of A. AP, AFP and IPIV will not be modified.\n\ * = 'N': The matrix A will be copied to AFP and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AP (input) COMPLEX array, dimension (N*(N+1)/2)\n\ * The upper or lower triangle of the symmetric matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ * See below for further details.\n\ *\n\ * AFP (input or output) COMPLEX array, dimension (N*(N+1)/2)\n\ * If FACT = 'F', then AFP is an input argument and on entry\n\ * contains the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L from the factorization\n\ * A = U*D*U**T or A = L*D*L**T as computed by CSPTRF, stored as\n\ * a packed triangular matrix in the same storage format as A.\n\ *\n\ * If FACT = 'N', then AFP is an output argument and on exit\n\ * contains the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L from the factorization\n\ * A = U*D*U**T or A = L*D*L**T as computed by CSPTRF, stored as\n\ * a packed triangular matrix in the same storage format as A.\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains details of the interchanges and the block structure\n\ * of D, as determined by CSPTRF.\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains details of the interchanges and the block structure\n\ * of D, as determined by CSPTRF.\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,NRHS)\n\ * The N-by-NRHS right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A. If RCOND is less than the machine precision (in\n\ * particular, if RCOND = 0), the matrix is singular to working\n\ * precision. This condition is indicated by a return code of\n\ * INFO > 0.\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\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, and i is\n\ * <= N: D(i,i) is exactly zero. The factorization\n\ * has been completed but the factor D is exactly\n\ * singular, so the solution and error bounds could\n\ * not be computed. RCOND = 0 is returned.\n\ * = N+1: D is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The packed storage scheme is illustrated by the following example\n\ * when N = 4, UPLO = 'U':\n\ *\n\ * Two-dimensional storage of the symmetric matrix A:\n\ *\n\ * a11 a12 a13 a14\n\ * a22 a23 a24\n\ * a33 a34 (aij = aji)\n\ * a44\n\ *\n\ * Packed storage of the upper triangle of A:\n\ *\n\ * AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sspgv0000644000175000017500000001164612502223526016362 0ustar uwabamiuwabami--- :name: sspgv :md5sum: b3c519ead837e7b587434eb8d06cec29 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - ldap - bp: :type: real :intent: input/output :dims: - n*(n+1)/2 - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE SSPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSPGV computes all the eigenvalues and, optionally, the eigenvectors\n\ * of a real generalized symmetric-definite eigenproblem, of the form\n\ * A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.\n\ * Here A and B are assumed to be symmetric, stored in packed format,\n\ * and B is also positive definite.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * Specifies the problem type to be solved:\n\ * = 1: A*x = (lambda)*B*x\n\ * = 2: A*B*x = (lambda)*x\n\ * = 3: B*A*x = (lambda)*x\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * AP (input/output) REAL array, dimension\n\ * (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, the contents of AP are destroyed.\n\ *\n\ * BP (input/output) REAL array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * B, packed columnwise in a linear array. The j-th column of B\n\ * is stored in the array BP as follows:\n\ * if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n\ *\n\ * On exit, the triangular factor U or L from the Cholesky\n\ * factorization B = U**T*U or B = L*L**T, in the same storage\n\ * format as B.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) REAL array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n\ * eigenvectors. The eigenvectors are normalized as follows:\n\ * if ITYPE = 1 or 2, Z**T*B*Z = I;\n\ * if ITYPE = 3, Z**T*inv(B)*Z = I.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) REAL array, dimension (3*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: SPPTRF or SSPEV returned an error code:\n\ * <= N: if INFO = i, SSPEV failed to converge;\n\ * i off-diagonal elements of an intermediate\n\ * tridiagonal form did not converge to zero.\n\ * > N: if INFO = n + i, for 1 <= i <= n, then the leading\n\ * minor of order i of B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL UPPER, WANTZ\n CHARACTER TRANS\n INTEGER J, NEIG\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SPPTRF, SSPEV, SSPGST, STPMV, STPSV, XERBLA\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/ztpcon0000644000175000017500000000554312502223526016534 0ustar uwabamiuwabami--- :name: ztpcon :md5sum: 900599a9d663838136fafdce8c072da9 :category: :subroutine :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - ldap - rcond: :type: doublereal :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE ZTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTPCON estimates the reciprocal of the condition number of a packed\n\ * triangular matrix A, in either the 1-norm or the infinity-norm.\n\ *\n\ * The norm of A is computed and an estimate is obtained for\n\ * norm(inv(A)), then the reciprocal of the condition number is\n\ * computed as\n\ * RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies whether the 1-norm condition number or the\n\ * infinity-norm condition number is required:\n\ * = '1' or 'O': 1-norm;\n\ * = 'I': Infinity-norm.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * The upper or lower triangular matrix A, packed columnwise in\n\ * a linear array. The j-th column of A is stored in the array\n\ * AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ * If DIAG = 'U', the diagonal elements of A are not referenced\n\ * and are assumed to be 1.\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(norm(A) * norm(inv(A))).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/spttrs0000644000175000017500000000525012502223526016551 0ustar uwabamiuwabami--- :name: spttrs :md5sum: f2c3d76783e9838492aa35a5bd7101fa :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: real :intent: input :dims: - n-1 - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPTTRS( N, NRHS, D, E, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPTTRS solves a tridiagonal system of the form\n\ * A * X = B\n\ * using the L*D*L' factorization of A computed by SPTTRF. D is a\n\ * diagonal matrix specified in the vector D, L is a unit bidiagonal\n\ * matrix whose subdiagonal is specified in the vector E, and X and B\n\ * are N by NRHS matrices.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the tridiagonal matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The n diagonal elements of the diagonal matrix D from the\n\ * L*D*L' factorization of A.\n\ *\n\ * E (input) REAL array, dimension (N-1)\n\ * The (n-1) subdiagonal elements of the unit bidiagonal factor\n\ * L from the L*D*L' factorization of A. E can also be regarded\n\ * as the superdiagonal of the unit bidiagonal factor U from the\n\ * factorization A = U'*D*U.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the right hand side vectors B for the system of\n\ * linear equations.\n\ * On exit, the solution vectors, X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER J, JB, NB\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SPTTS2, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlasd20000644000175000017500000002110112502223526016354 0ustar uwabamiuwabami--- :name: dlasd2 :md5sum: 2f07ad46ba203eded0d5d52c02cc3361 :category: :subroutine :arguments: - nl: :type: integer :intent: input - nr: :type: integer :intent: input - sqre: :type: integer :intent: input - k: :type: integer :intent: output - d: :type: doublereal :intent: input/output :dims: - n - z: :type: doublereal :intent: output :dims: - n - alpha: :type: doublereal :intent: input - beta: :type: doublereal :intent: input - u: :type: doublereal :intent: input/output :dims: - ldu - n - ldu: :type: integer :intent: input - vt: :type: doublereal :intent: input/output :dims: - ldvt - m - ldvt: :type: integer :intent: input - dsigma: :type: doublereal :intent: output :dims: - n - u2: :type: doublereal :intent: output :dims: - ldu2 - n - ldu2: :type: integer :intent: input - vt2: :type: doublereal :intent: output :dims: - ldvt2 - n - ldvt2: :type: integer :intent: input - idxp: :type: integer :intent: workspace :dims: - n - idx: :type: integer :intent: workspace :dims: - n - idxc: :type: integer :intent: output :dims: - n - idxq: :type: integer :intent: input/output :dims: - n - coltyp: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldu2: n ldvt2: m :fortran_help: " SUBROUTINE DLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX, IDXC, IDXQ, COLTYP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLASD2 merges the two sets of singular values together into a single\n\ * sorted set. Then it tries to deflate the size of the problem.\n\ * There are two ways in which deflation can occur: when two or more\n\ * singular values are close together or if there is a tiny entry in the\n\ * Z vector. For each such occurrence the order of the related secular\n\ * equation problem is reduced by one.\n\ *\n\ * DLASD2 is called from DLASD1.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NL (input) INTEGER\n\ * The row dimension of the upper block. NL >= 1.\n\ *\n\ * NR (input) INTEGER\n\ * The row dimension of the lower block. NR >= 1.\n\ *\n\ * SQRE (input) INTEGER\n\ * = 0: the lower block is an NR-by-NR square matrix.\n\ * = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n\ *\n\ * The bidiagonal matrix has N = NL + NR + 1 rows and\n\ * M = N + SQRE >= N columns.\n\ *\n\ * K (output) INTEGER\n\ * Contains the dimension of the non-deflated matrix,\n\ * This is the order of the related secular equation. 1 <= K <=N.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension(N)\n\ * On entry D contains the singular values of the two submatrices\n\ * to be combined. On exit D contains the trailing (N-K) updated\n\ * singular values (those which were deflated) sorted into\n\ * increasing order.\n\ *\n\ * Z (output) DOUBLE PRECISION array, dimension(N)\n\ * On exit Z contains the updating row vector in the secular\n\ * equation.\n\ *\n\ * ALPHA (input) DOUBLE PRECISION\n\ * Contains the diagonal element associated with the added row.\n\ *\n\ * BETA (input) DOUBLE PRECISION\n\ * Contains the off-diagonal element associated with the added\n\ * row.\n\ *\n\ * U (input/output) DOUBLE PRECISION array, dimension(LDU,N)\n\ * On entry U contains the left singular vectors of two\n\ * submatrices in the two square blocks with corners at (1,1),\n\ * (NL, NL), and (NL+2, NL+2), (N,N).\n\ * On exit U contains the trailing (N-K) updated left singular\n\ * vectors (those which were deflated) in its last N-K columns.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= N.\n\ *\n\ * VT (input/output) DOUBLE PRECISION array, dimension(LDVT,M)\n\ * On entry VT' contains the right singular vectors of two\n\ * submatrices in the two square blocks with corners at (1,1),\n\ * (NL+1, NL+1), and (NL+2, NL+2), (M,M).\n\ * On exit VT' contains the trailing (N-K) updated right singular\n\ * vectors (those which were deflated) in its last N-K columns.\n\ * In case SQRE =1, the last row of VT spans the right null\n\ * space.\n\ *\n\ * LDVT (input) INTEGER\n\ * The leading dimension of the array VT. LDVT >= M.\n\ *\n\ * DSIGMA (output) DOUBLE PRECISION array, dimension (N)\n\ * Contains a copy of the diagonal elements (K-1 singular values\n\ * and one zero) in the secular equation.\n\ *\n\ * U2 (output) DOUBLE PRECISION array, dimension(LDU2,N)\n\ * Contains a copy of the first K-1 left singular vectors which\n\ * will be used by DLASD3 in a matrix multiply (DGEMM) to solve\n\ * for the new left singular vectors. U2 is arranged into four\n\ * blocks. The first block contains a column with 1 at NL+1 and\n\ * zero everywhere else; the second block contains non-zero\n\ * entries only at and above NL; the third contains non-zero\n\ * entries only below NL+1; and the fourth is dense.\n\ *\n\ * LDU2 (input) INTEGER\n\ * The leading dimension of the array U2. LDU2 >= N.\n\ *\n\ * VT2 (output) DOUBLE PRECISION array, dimension(LDVT2,N)\n\ * VT2' contains a copy of the first K right singular vectors\n\ * which will be used by DLASD3 in a matrix multiply (DGEMM) to\n\ * solve for the new right singular vectors. VT2 is arranged into\n\ * three blocks. The first block contains a row that corresponds\n\ * to the special 0 diagonal element in SIGMA; the second block\n\ * contains non-zeros only at and before NL +1; the third block\n\ * contains non-zeros only at and after NL +2.\n\ *\n\ * LDVT2 (input) INTEGER\n\ * The leading dimension of the array VT2. LDVT2 >= M.\n\ *\n\ * IDXP (workspace) INTEGER array dimension(N)\n\ * This will contain the permutation used to place deflated\n\ * values of D at the end of the array. On output IDXP(2:K)\n\ * points to the nondeflated D-values and IDXP(K+1:N)\n\ * points to the deflated singular values.\n\ *\n\ * IDX (workspace) INTEGER array dimension(N)\n\ * This will contain the permutation used to sort the contents of\n\ * D into ascending order.\n\ *\n\ * IDXC (output) INTEGER array dimension(N)\n\ * This will contain the permutation used to arrange the columns\n\ * of the deflated U matrix into three groups: the first group\n\ * contains non-zero entries only at and above NL, the second\n\ * contains non-zero entries only below NL+2, and the third is\n\ * dense.\n\ *\n\ * IDXQ (input/output) INTEGER array dimension(N)\n\ * This contains the permutation which separately sorts the two\n\ * sub-problems in D into ascending order. Note that entries in\n\ * the first hlaf of this permutation must first be moved one\n\ * position backward; and entries in the second half\n\ * must first have NL+1 added to their values.\n\ *\n\ * COLTYP (workspace/output) INTEGER array dimension(N)\n\ * As workspace, this will contain a label which will indicate\n\ * which of the following types a column in the U2 matrix or a\n\ * row in the VT2 matrix is:\n\ * 1 : non-zero in the upper half only\n\ * 2 : non-zero in the lower half only\n\ * 3 : dense\n\ * 4 : deflated\n\ *\n\ * On exit, it is an array of dimension 4, with COLTYP(I) being\n\ * the dimension of the I-th type columns.\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\ * Based on contributions by\n\ * Ming Gu and Huan Ren, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/claqsy0000644000175000017500000000575212502223525016514 0ustar uwabamiuwabami--- :name: claqsy :md5sum: cda09f78eb86852e56f73b7cca3221cf :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - s: :type: real :intent: input :dims: - n - scond: :type: real :intent: input - amax: :type: real :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAQSY equilibrates a symmetric matrix A using the scaling factors\n\ * in the vector S.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * n by n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n by n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if EQUED = 'Y', the equilibrated matrix:\n\ * diag(S) * A * diag(S).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(N,1).\n\ *\n\ * S (input) REAL array, dimension (N)\n\ * The scale factors for A.\n\ *\n\ * SCOND (input) REAL\n\ * Ratio of the smallest S(i) to the largest S(i).\n\ *\n\ * AMAX (input) REAL\n\ * Absolute value of largest matrix entry.\n\ *\n\ * EQUED (output) CHARACTER*1\n\ * Specifies whether or not equilibration was done.\n\ * = 'N': No equilibration.\n\ * = 'Y': Equilibration was done, i.e., A has been replaced by\n\ * diag(S) * A * diag(S).\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * THRESH is a threshold value used to decide if scaling should be done\n\ * based on the ratio of the scaling factors. If SCOND < THRESH,\n\ * scaling is done.\n\ *\n\ * LARGE and SMALL are threshold values used to decide if scaling should\n\ * be done based on the absolute size of the largest matrix element.\n\ * If AMAX > LARGE or AMAX < SMALL, scaling is done.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlangt0000644000175000017500000000432012502223526016460 0ustar uwabamiuwabami--- :name: dlangt :md5sum: a56e7eb61491985defd273c24dd9d896 :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - dl: :type: doublereal :intent: input :dims: - n-1 - d: :type: doublereal :intent: input :dims: - n - du: :type: doublereal :intent: input :dims: - n-1 :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION DLANGT( NORM, N, DL, D, DU )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLANGT returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * real tridiagonal matrix A.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * DLANGT returns the value\n\ *\n\ * DLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in DLANGT as described\n\ * above.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, DLANGT is\n\ * set to zero.\n\ *\n\ * DL (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) sub-diagonal elements of A.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The diagonal elements of A.\n\ *\n\ * DU (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) super-diagonal elements of A.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sla_gbamv0000644000175000017500000001202112502223526017137 0ustar uwabamiuwabami--- :name: sla_gbamv :md5sum: cbd7ec5ee7b6f3a1cb37f6d024c2d320 :category: :subroutine :arguments: - trans: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - alpha: :type: real :intent: input - ab: :type: real :intent: input :dims: - ldab - ldab: :type: integer :intent: input - x: :type: real :intent: input :dims: - "trans == ilatrans_(\"N\") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )" - incx: :type: integer :intent: input - beta: :type: real :intent: input - y: :type: real :intent: input/output :dims: - "trans == ilatrans_(\"N\") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )" - incy: :type: integer :intent: input :substitutions: lda: MAX(1,m) :fortran_help: " SUBROUTINE SLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, INCX, BETA, Y, INCY )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLA_GBAMV performs one of the matrix-vector operations\n\ *\n\ * y := alpha*abs(A)*abs(x) + beta*abs(y),\n\ * or y := alpha*abs(A)'*abs(x) + beta*abs(y),\n\ *\n\ * where alpha and beta are scalars, x and y are vectors and A is an\n\ * m by n matrix.\n\ *\n\ * This function is primarily used in calculating error bounds.\n\ * To protect against underflow during evaluation, components in\n\ * the resulting vector are perturbed away from zero by (N+1)\n\ * times the underflow threshold. To prevent unnecessarily large\n\ * errors for block-structure embedded in general matrices,\n\ * \"symbolically\" zero components are not perturbed. A zero\n\ * entry is considered \"symbolic\" if all multiplications involved\n\ * in computing that entry have at least one zero multiplicand.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * TRANS (input) INTEGER\n\ * On entry, TRANS specifies the operation to be performed as\n\ * follows:\n\ *\n\ * BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y)\n\ * BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n\ * BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n\ *\n\ * Unchanged on exit.\n\ *\n\ * M (input) INTEGER\n\ * On entry, M specifies the number of rows of the matrix A.\n\ * M must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the number of columns of the matrix A.\n\ * N must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * ALPHA (input) REAL\n\ * On entry, ALPHA specifies the scalar alpha.\n\ * Unchanged on exit.\n\ *\n\ * A - REAL array of DIMENSION ( LDA, n )\n\ * Before entry, the leading m by n part of the array A must\n\ * contain the matrix of coefficients.\n\ * Unchanged on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * On entry, LDA specifies the first dimension of A as declared\n\ * in the calling (sub) program. LDA must be at least\n\ * max( 1, m ).\n\ * Unchanged on exit.\n\ *\n\ * X (input) REAL array, dimension\n\ * ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n\ * and at least\n\ * ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n\ * Before entry, the incremented array X must contain the\n\ * vector x.\n\ * Unchanged on exit.\n\ *\n\ * INCX (input) INTEGER\n\ * On entry, INCX specifies the increment for the elements of\n\ * X. INCX must not be zero.\n\ * Unchanged on exit.\n\ *\n\ * BETA (input) REAL\n\ * On entry, BETA specifies the scalar beta. When BETA is\n\ * supplied as zero then Y need not be set on input.\n\ * Unchanged on exit.\n\ *\n\ * Y (input/output) REAL array, dimension\n\ * ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n\ * and at least\n\ * ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n\ * Before entry with BETA non-zero, the incremented array Y\n\ * must contain the vector y. On exit, Y is overwritten by the\n\ * updated vector y.\n\ *\n\ * INCY (input) INTEGER\n\ * On entry, INCY specifies the increment for the elements of\n\ * Y. INCY must not be zero.\n\ * Unchanged on exit.\n\ *\n\ *\n\ * Level 2 Blas routine.\n\ *\n\n\ * =====================================================================\n\n" ruby-lapack-1.7.2/dev/defs/stgevc0000644000175000017500000002355512502223526016515 0ustar uwabamiuwabami--- :name: stgevc :md5sum: 0a4f8003fe9e7bdf3a2db60d8dcd9b6f :category: :subroutine :arguments: - side: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - s: :type: real :intent: input :dims: - lds - n - lds: :type: integer :intent: input - p: :type: real :intent: input :dims: - ldp - n - ldp: :type: integer :intent: input - vl: :type: real :intent: input/output :dims: - ldvl - mm - ldvl: :type: integer :intent: input - vr: :type: real :intent: input/output :dims: - ldvr - mm - ldvr: :type: integer :intent: input - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: real :intent: workspace :dims: - 6*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE STGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STGEVC computes some or all of the right and/or left eigenvectors of\n\ * a pair of real matrices (S,P), where S is a quasi-triangular matrix\n\ * and P is upper triangular. Matrix pairs of this type are produced by\n\ * the generalized Schur factorization of a matrix pair (A,B):\n\ *\n\ * A = Q*S*Z**T, B = Q*P*Z**T\n\ *\n\ * as computed by SGGHRD + SHGEQZ.\n\ *\n\ * The right eigenvector x and the left eigenvector y of (S,P)\n\ * corresponding to an eigenvalue w are defined by:\n\ * \n\ * S*x = w*P*x, (y**H)*S = w*(y**H)*P,\n\ * \n\ * where y**H denotes the conjugate tranpose of y.\n\ * The eigenvalues are not input to this routine, but are computed\n\ * directly from the diagonal blocks of S and P.\n\ * \n\ * This routine returns the matrices X and/or Y of right and left\n\ * eigenvectors of (S,P), or the products Z*X and/or Q*Y,\n\ * where Z and Q are input matrices.\n\ * If Q and Z are the orthogonal factors from the generalized Schur\n\ * factorization of a matrix pair (A,B), then Z*X and Q*Y\n\ * are the matrices of right and left eigenvectors of (A,B).\n\ * \n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'R': compute right eigenvectors only;\n\ * = 'L': compute left eigenvectors only;\n\ * = 'B': compute both right and left eigenvectors.\n\ *\n\ * HOWMNY (input) CHARACTER*1\n\ * = 'A': compute all right and/or left eigenvectors;\n\ * = 'B': compute all right and/or left eigenvectors,\n\ * backtransformed by the matrices in VR and/or VL;\n\ * = 'S': compute selected right and/or left eigenvectors,\n\ * specified by the logical array SELECT.\n\ *\n\ * SELECT (input) LOGICAL array, dimension (N)\n\ * If HOWMNY='S', SELECT specifies the eigenvectors to be\n\ * computed. If w(j) is a real eigenvalue, the corresponding\n\ * real eigenvector is computed if SELECT(j) is .TRUE..\n\ * If w(j) and w(j+1) are the real and imaginary parts of a\n\ * complex eigenvalue, the corresponding complex eigenvector\n\ * is computed if either SELECT(j) or SELECT(j+1) is .TRUE.,\n\ * and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is\n\ * set to .FALSE..\n\ * Not referenced if HOWMNY = 'A' or 'B'.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices S and P. N >= 0.\n\ *\n\ * S (input) REAL array, dimension (LDS,N)\n\ * The upper quasi-triangular matrix S from a generalized Schur\n\ * factorization, as computed by SHGEQZ.\n\ *\n\ * LDS (input) INTEGER\n\ * The leading dimension of array S. LDS >= max(1,N).\n\ *\n\ * P (input) REAL array, dimension (LDP,N)\n\ * The upper triangular matrix P from a generalized Schur\n\ * factorization, as computed by SHGEQZ.\n\ * 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks\n\ * of S must be in positive diagonal form.\n\ *\n\ * LDP (input) INTEGER\n\ * The leading dimension of array P. LDP >= max(1,N).\n\ *\n\ * VL (input/output) REAL array, dimension (LDVL,MM)\n\ * On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n\ * contain an N-by-N matrix Q (usually the orthogonal matrix Q\n\ * of left Schur vectors returned by SHGEQZ).\n\ * On exit, if SIDE = 'L' or 'B', VL contains:\n\ * if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);\n\ * if HOWMNY = 'B', the matrix Q*Y;\n\ * if HOWMNY = 'S', the left eigenvectors of (S,P) specified by\n\ * SELECT, stored consecutively in the columns of\n\ * VL, in the same order as their eigenvalues.\n\ *\n\ * A complex eigenvector corresponding to a complex eigenvalue\n\ * is stored in two consecutive columns, the first holding the\n\ * real part, and the second the imaginary part.\n\ *\n\ * Not referenced if SIDE = 'R'.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of array VL. LDVL >= 1, and if\n\ * SIDE = 'L' or 'B', LDVL >= N.\n\ *\n\ * VR (input/output) REAL array, dimension (LDVR,MM)\n\ * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n\ * contain an N-by-N matrix Z (usually the orthogonal matrix Z\n\ * of right Schur vectors returned by SHGEQZ).\n\ *\n\ * On exit, if SIDE = 'R' or 'B', VR contains:\n\ * if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);\n\ * if HOWMNY = 'B' or 'b', the matrix Z*X;\n\ * if HOWMNY = 'S' or 's', the right eigenvectors of (S,P)\n\ * specified by SELECT, stored consecutively in the\n\ * columns of VR, in the same order as their\n\ * eigenvalues.\n\ *\n\ * A complex eigenvector corresponding to a complex eigenvalue\n\ * is stored in two consecutive columns, the first holding the\n\ * real part and the second the imaginary part.\n\ * \n\ * Not referenced if SIDE = 'L'.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the array VR. LDVR >= 1, and if\n\ * SIDE = 'R' or 'B', LDVR >= N.\n\ *\n\ * MM (input) INTEGER\n\ * The number of columns in the arrays VL and/or VR. MM >= M.\n\ *\n\ * M (output) INTEGER\n\ * The number of columns in the arrays VL and/or VR actually\n\ * used to store the eigenvectors. If HOWMNY = 'A' or 'B', M\n\ * is set to N. Each selected real eigenvector occupies one\n\ * column and each selected complex eigenvector occupies two\n\ * columns.\n\ *\n\ * WORK (workspace) REAL array, dimension (6*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit.\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * > 0: the 2-by-2 block (INFO:INFO+1) does not have a complex\n\ * eigenvalue.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Allocation of workspace:\n\ * ---------- -- ---------\n\ *\n\ * WORK( j ) = 1-norm of j-th column of A, above the diagonal\n\ * WORK( N+j ) = 1-norm of j-th column of B, above the diagonal\n\ * WORK( 2*N+1:3*N ) = real part of eigenvector\n\ * WORK( 3*N+1:4*N ) = imaginary part of eigenvector\n\ * WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector\n\ * WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector\n\ *\n\ * Rowwise vs. columnwise solution methods:\n\ * ------- -- ---------- -------- -------\n\ *\n\ * Finding a generalized eigenvector consists basically of solving the\n\ * singular triangular system\n\ *\n\ * (A - w B) x = 0 (for right) or: (A - w B)**H y = 0 (for left)\n\ *\n\ * Consider finding the i-th right eigenvector (assume all eigenvalues\n\ * are real). The equation to be solved is:\n\ * n i\n\ * 0 = sum C(j,k) v(k) = sum C(j,k) v(k) for j = i,. . .,1\n\ * k=j k=j\n\ *\n\ * where C = (A - w B) (The components v(i+1:n) are 0.)\n\ *\n\ * The \"rowwise\" method is:\n\ *\n\ * (1) v(i) := 1\n\ * for j = i-1,. . .,1:\n\ * i\n\ * (2) compute s = - sum C(j,k) v(k) and\n\ * k=j+1\n\ *\n\ * (3) v(j) := s / C(j,j)\n\ *\n\ * Step 2 is sometimes called the \"dot product\" step, since it is an\n\ * inner product between the j-th row and the portion of the eigenvector\n\ * that has been computed so far.\n\ *\n\ * The \"columnwise\" method consists basically in doing the sums\n\ * for all the rows in parallel. As each v(j) is computed, the\n\ * contribution of v(j) times the j-th column of C is added to the\n\ * partial sums. Since FORTRAN arrays are stored columnwise, this has\n\ * the advantage that at each step, the elements of C that are accessed\n\ * are adjacent to one another, whereas with the rowwise method, the\n\ * elements accessed at a step are spaced LDS (and LDP) words apart.\n\ *\n\ * When finding left eigenvectors, the matrix in question is the\n\ * transpose of the one in storage, so the rowwise method then\n\ * actually accesses columns of A and B at each step, and so is the\n\ * preferred method.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgeqr20000644000175000017500000000473612502223525016404 0ustar uwabamiuwabami--- :name: cgeqr2 :md5sum: 114a90186ffc7d77d59e5b0de91cafc3 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - MIN(m,n) - work: :type: complex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGEQR2( M, N, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGEQR2 computes a QR factorization of a complex m by n matrix A:\n\ * A = Q * R.\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) COMPLEX array, dimension (LDA,N)\n\ * On entry, the m by n matrix A.\n\ * On exit, the elements on and above the diagonal of the array\n\ * contain the min(m,n) by n upper trapezoidal matrix R (R is\n\ * upper triangular if m >= n); the elements below the diagonal,\n\ * with the array TAU, represent the unitary 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) COMPLEX array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (N)\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(1) H(2) . . . H(k), 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 complex scalar, and v is a complex vector with\n\ * v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n\ * and tau in TAU(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zpbstf0000644000175000017500000000776212502223526016534 0ustar uwabamiuwabami--- :name: zpbstf :md5sum: cfe511b95e98a455f985fa82d1816452 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPBSTF( UPLO, N, KD, AB, LDAB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPBSTF computes a split Cholesky factorization of a complex\n\ * Hermitian positive definite band matrix A.\n\ *\n\ * This routine is designed to be used in conjunction with ZHBGST.\n\ *\n\ * The factorization has the form A = S**H*S where S is a band matrix\n\ * of the same bandwidth as A and the following structure:\n\ *\n\ * S = ( U )\n\ * ( M L )\n\ *\n\ * where U is upper triangular of order m = (n+kd)/2, and L is lower\n\ * triangular of order n-m.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix A, stored in the first kd+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * On exit, if INFO = 0, the factor S from the split Cholesky\n\ * factorization A = S**H*S. See Further Details.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\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 factorization could not be completed,\n\ * because the updated element a(i,i) was negative; the\n\ * matrix A is not positive definite.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * N = 7, KD = 2:\n\ *\n\ * S = ( s11 s12 s13 )\n\ * ( s22 s23 s24 )\n\ * ( s33 s34 )\n\ * ( s44 )\n\ * ( s53 s54 s55 )\n\ * ( s64 s65 s66 )\n\ * ( s75 s76 s77 )\n\ *\n\ * If UPLO = 'U', the array AB holds:\n\ *\n\ * on entry: on exit:\n\ *\n\ * * * a13 a24 a35 a46 a57 * * s13 s24 s53' s64' s75'\n\ * * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54' s65' s76'\n\ * a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77\n\ *\n\ * If UPLO = 'L', the array AB holds:\n\ *\n\ * on entry: on exit:\n\ *\n\ * a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77\n\ * a21 a32 a43 a54 a65 a76 * s12' s23' s34' s54 s65 s76 *\n\ * a31 a42 a53 a64 a64 * * s13' s24' s53 s64 s75 * *\n\ *\n\ * Array elements marked * are not used by the routine; s12' denotes\n\ * conjg(s12); the diagonal elements of S are real.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cla_gerfsx_extended0000644000175000017500000003505412502223525021213 0ustar uwabamiuwabami--- :name: cla_gerfsx_extended :md5sum: 12ca37550f11461056c380e1b73caeff :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - trans_type: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - colequ: :type: logical :intent: input - c: :type: real :intent: input :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: complex :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: real :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - errs_n: :type: real :intent: input/output :dims: - nrhs - n_norms - errs_c: :type: real :intent: input/output :dims: - nrhs - n_norms - res: :type: complex :intent: input :dims: - n - ayb: :type: real :intent: input :dims: - n - dy: :type: complex :intent: input :dims: - n - y_tail: :type: complex :intent: input :dims: - n - rcond: :type: real :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: real :intent: input - dz_ub: :type: real :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: n_norsm: "3" :fortran_help: " SUBROUTINE CLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERRS_N, ERRS_C, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n\ * Purpose\n\ * =======\n\ * \n\ * CLA_GERFSX_EXTENDED improves the computed solution to a system of\n\ * linear equations by performing extra-precise iterative refinement\n\ * and provides error bounds and backward error estimates for the solution.\n\ * This subroutine is called by CGERFSX to perform iterative refinement.\n\ * In addition to normwise error bound, the code provides maximum\n\ * componentwise error bound if possible. See comments for ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP for details of the error bounds. Note that this\n\ * subroutine is only resonsible for setting the second fields of\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * PREC_TYPE (input) INTEGER\n\ * Specifies the intermediate precision to be used in refinement.\n\ * The value is defined by ILAPREC(P) where P is a CHARACTER and\n\ * P = 'S': Single\n\ * = 'D': Double\n\ * = 'I': Indigenous\n\ * = 'X', 'E': Extra\n\ *\n\ * TRANS_TYPE (input) INTEGER\n\ * Specifies the transposition operation on A.\n\ * The value is defined by ILATRANS(T) where T is a CHARACTER and\n\ * T = 'N': No transpose\n\ * = 'T': Transpose\n\ * = 'C': Conjugate transpose\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right-hand-sides, i.e., the number of columns of the\n\ * matrix B.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX array, dimension (LDAF,N)\n\ * The factors L and U from the factorization\n\ * A = P*L*U as computed by CGETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from the factorization A = P*L*U\n\ * as computed by CGETRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * COLEQU (input) LOGICAL\n\ * If .TRUE. then column equilibration was done to A before calling\n\ * this routine. This is needed to compute the solution and error\n\ * bounds correctly.\n\ *\n\ * C (input) REAL array, dimension (N)\n\ * The column scale factors for A. If COLEQU = .FALSE., C\n\ * is not accessed. If C is input, each element of C should be a power\n\ * of the radix to ensure a reliable solution and error estimates.\n\ * Scaling by powers of the radix does not cause rounding errors unless\n\ * the result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,NRHS)\n\ * The right-hand-side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * Y (input/output) COMPLEX array, dimension (LDY,NRHS)\n\ * On entry, the solution matrix X, as computed by CGETRS.\n\ * On exit, the improved solution matrix Y.\n\ *\n\ * LDY (input) INTEGER\n\ * The leading dimension of the array Y. LDY >= max(1,N).\n\ *\n\ * BERR_OUT (output) REAL array, dimension (NRHS)\n\ * On exit, BERR_OUT(j) contains the componentwise relative backward\n\ * error for right-hand-side j from the formula\n\ * max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n\ * where abs(Z) is the componentwise absolute value of the matrix\n\ * or vector Z. This is computed by CLA_LIN_BERR.\n\ *\n\ * N_NORMS (input) INTEGER\n\ * Determines which error bounds to return (see ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP).\n\ * If N_NORMS >= 1 return normwise error bounds.\n\ * If N_NORMS >= 2 return componentwise error bounds.\n\ *\n\ * ERR_BNDS_NORM (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * RES (input) COMPLEX array, dimension (N)\n\ * Workspace to hold the intermediate residual.\n\ *\n\ * AYB (input) REAL array, dimension (N)\n\ * Workspace.\n\ *\n\ * DY (input) COMPLEX array, dimension (N)\n\ * Workspace to hold the intermediate solution.\n\ *\n\ * Y_TAIL (input) COMPLEX array, dimension (N)\n\ * Workspace to hold the trailing bits of the intermediate solution.\n\ *\n\ * RCOND (input) REAL\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * ITHRESH (input) INTEGER\n\ * The maximum number of residual computations allowed for\n\ * refinement. The default is 10. For 'aggressive' set to 100 to\n\ * permit convergence using approximate factorizations or\n\ * factorizations other than LU. If the factorization uses a\n\ * technique other than Gaussian elimination, the guarantees in\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n\ *\n\ * RTHRESH (input) REAL\n\ * Determines when to stop refinement if the error estimate stops\n\ * decreasing. Refinement will stop when the next solution no longer\n\ * satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n\ * the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n\ * default value is 0.5. For 'aggressive' set to 0.9 to permit\n\ * convergence on extremely ill-conditioned matrices. See LAWN 165\n\ * for more details.\n\ *\n\ * DZ_UB (input) REAL\n\ * Determines when to start considering componentwise convergence.\n\ * Componentwise convergence is only considered after each component\n\ * of the solution Y is stable, which we definte as the relative\n\ * change in each component being less than DZ_UB. The default value\n\ * is 0.25, requiring the first bit to be stable. See LAWN 165 for\n\ * more details.\n\ *\n\ * IGNORE_CWISE (input) LOGICAL\n\ * If .TRUE. then ignore componentwise convergence. Default value\n\ * is .FALSE..\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * < 0: if INFO = -i, the ith argument to CGETRS had an illegal\n\ * value\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n CHARACTER TRANS\n INTEGER CNT, I, J, X_STATE, Z_STATE, Y_PREC_STATE\n REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n COMPLEX ZDUM\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sla_geamv0000644000175000017500000001126512502223526017153 0ustar uwabamiuwabami--- :name: sla_geamv :md5sum: 2e179391d15f035cb8c5119e60dcdd05 :category: :subroutine :arguments: - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: real :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: real :intent: input :dims: - "trans == ilatrans_(\"N\") ? 1+(n-1)*abs(incx) : 1+(m-1)*abs(incx)" - incx: :type: integer :intent: input - beta: :type: real :intent: input - y: :type: real :intent: input/output :dims: - "trans == ilatrans_(\"N\") ? 1+(m-1)*abs(incy) : 1+(n-1)*abs(incy)" - incy: :type: integer :intent: input :substitutions: lda: MAX(1, m) :fortran_help: " SUBROUTINE SLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLA_GEAMV performs one of the matrix-vector operations\n\ *\n\ * y := alpha*abs(A)*abs(x) + beta*abs(y),\n\ * or y := alpha*abs(A)'*abs(x) + beta*abs(y),\n\ *\n\ * where alpha and beta are scalars, x and y are vectors and A is an\n\ * m by n matrix.\n\ *\n\ * This function is primarily used in calculating error bounds.\n\ * To protect against underflow during evaluation, components in\n\ * the resulting vector are perturbed away from zero by (N+1)\n\ * times the underflow threshold. To prevent unnecessarily large\n\ * errors for block-structure embedded in general matrices,\n\ * \"symbolically\" zero components are not perturbed. A zero\n\ * entry is considered \"symbolic\" if all multiplications involved\n\ * in computing that entry have at least one zero multiplicand.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * TRANS (input) INTEGER\n\ * On entry, TRANS specifies the operation to be performed as\n\ * follows:\n\ *\n\ * BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y)\n\ * BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n\ * BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n\ *\n\ * Unchanged on exit.\n\ *\n\ * M (input) INTEGER\n\ * On entry, M specifies the number of rows of the matrix A.\n\ * M must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the number of columns of the matrix A.\n\ * N must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * ALPHA (input) REAL\n\ * On entry, ALPHA specifies the scalar alpha.\n\ * Unchanged on exit.\n\ *\n\ * A - REAL array of DIMENSION ( LDA, n )\n\ * Before entry, the leading m by n part of the array A must\n\ * contain the matrix of coefficients.\n\ * Unchanged on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * On entry, LDA specifies the first dimension of A as declared\n\ * in the calling (sub) program. LDA must be at least\n\ * max( 1, m ).\n\ * Unchanged on exit.\n\ *\n\ * X (input) REAL array, dimension\n\ * ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n\ * and at least\n\ * ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n\ * Before entry, the incremented array X must contain the\n\ * vector x.\n\ * Unchanged on exit.\n\ *\n\ * INCX (input) INTEGER\n\ * On entry, INCX specifies the increment for the elements of\n\ * X. INCX must not be zero.\n\ * Unchanged on exit.\n\ *\n\ * BETA (input) REAL\n\ * On entry, BETA specifies the scalar beta. When BETA is\n\ * supplied as zero then Y need not be set on input.\n\ * Unchanged on exit.\n\ *\n\ * Y - REAL\n\ * Array of DIMENSION at least\n\ * ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n\ * and at least\n\ * ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n\ * Before entry with BETA non-zero, the incremented array Y\n\ * must contain the vector y. On exit, Y is overwritten by the\n\ * updated vector y.\n\ *\n\ * INCY (input) INTEGER\n\ * On entry, INCY specifies the increment for the elements of\n\ * Y. INCY must not be zero.\n\ * Unchanged on exit.\n\ *\n\ * Level 2 Blas routine.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/strttf0000644000175000017500000001401412502223526016536 0ustar uwabamiuwabami--- :name: strttf :md5sum: 22b37df5c63942034431b6f79e1e3a0d :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - arf: :type: real :intent: output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE STRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STRTTF copies a triangular matrix A from standard full format (TR)\n\ * to rectangular full packed format (TF) .\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': ARF in Normal form is wanted;\n\ * = 'T': ARF in Transpose form is wanted.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N).\n\ * On entry, the triangular matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of the array A contains\n\ * the upper triangular matrix, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of the array A contains\n\ * the lower triangular matrix, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the matrix A. LDA >= max(1,N).\n\ *\n\ * ARF (output) REAL array, dimension (NT).\n\ * NT=N*(N+1)/2. On exit, the triangular matrix A in RFP format.\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\ * We first consider Rectangular Full Packed (RFP) Format when N is\n\ * even. We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * the transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * the transpose of the last three columns of AP lower.\n\ * This covers the case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 04 05 33 43 53\n\ * 13 14 15 00 44 54\n\ * 23 24 25 10 11 55\n\ * 33 34 35 20 21 22\n\ * 00 44 45 30 31 32\n\ * 01 11 55 40 41 42\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We then consider Rectangular Full Packed (RFP) Format when N is\n\ * odd. We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * the transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * the transpose of the last two columns of AP lower.\n\ * This covers the case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 03 04 00 33 43\n\ * 12 13 14 10 11 44\n\ * 22 23 24 20 21 22\n\ * 00 33 34 30 31 32\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * Reference\n\ * =========\n\ *\n\ * =====================================================================\n\ *\n\ * ..\n\ * .. Local Scalars ..\n LOGICAL LOWER, NISODD, NORMALTRANSR\n INTEGER I, IJ, J, K, L, N1, N2, NT, NX2, NP1X2\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MOD\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sggsvd0000644000175000017500000002416412502223526016514 0ustar uwabamiuwabami--- :name: sggsvd :md5sum: d33cddf77cac04b083208610d7b84d71 :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobv: :type: char :intent: input - jobq: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - p: :type: integer :intent: input - k: :type: integer :intent: output - l: :type: integer :intent: output - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alpha: :type: real :intent: output :dims: - n - beta: :type: real :intent: output :dims: - n - u: :type: real :intent: output :dims: - ldu - m - ldu: :type: integer :intent: input - v: :type: real :intent: output :dims: - ldv - p - ldv: :type: integer :intent: input - q: :type: real :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(3*n,m - p)+n - iwork: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: m: lda p: ldb ldq: "lsame_(&jobq,\"Q\") ? MAX(1,n) : 1" ldu: "lsame_(&jobu,\"U\") ? MAX(1,m) : 1" ldv: "lsame_(&jobv,\"V\") ? MAX(1,p) : 1" :fortran_help: " SUBROUTINE SGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGGSVD computes the generalized singular value decomposition (GSVD)\n\ * of an M-by-N real matrix A and P-by-N real matrix B:\n\ *\n\ * U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R )\n\ *\n\ * where U, V and Q are orthogonal matrices, and Z' is the transpose\n\ * of Z. Let K+L = the effective numerical rank of the matrix (A',B')',\n\ * then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and\n\ * D2 are M-by-(K+L) and P-by-(K+L) \"diagonal\" matrices and of the\n\ * following structures, respectively:\n\ *\n\ * If M-K-L >= 0,\n\ *\n\ * K L\n\ * D1 = K ( I 0 )\n\ * L ( 0 C )\n\ * M-K-L ( 0 0 )\n\ *\n\ * K L\n\ * D2 = L ( 0 S )\n\ * P-L ( 0 0 )\n\ *\n\ * N-K-L K L\n\ * ( 0 R ) = K ( 0 R11 R12 )\n\ * L ( 0 0 R22 )\n\ *\n\ * where\n\ *\n\ * C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n\ * S = diag( BETA(K+1), ... , BETA(K+L) ),\n\ * C**2 + S**2 = I.\n\ *\n\ * R is stored in A(1:K+L,N-K-L+1:N) on exit.\n\ *\n\ * If M-K-L < 0,\n\ *\n\ * K M-K K+L-M\n\ * D1 = K ( I 0 0 )\n\ * M-K ( 0 C 0 )\n\ *\n\ * K M-K K+L-M\n\ * D2 = M-K ( 0 S 0 )\n\ * K+L-M ( 0 0 I )\n\ * P-L ( 0 0 0 )\n\ *\n\ * N-K-L K M-K K+L-M\n\ * ( 0 R ) = K ( 0 R11 R12 R13 )\n\ * M-K ( 0 0 R22 R23 )\n\ * K+L-M ( 0 0 0 R33 )\n\ *\n\ * where\n\ *\n\ * C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n\ * S = diag( BETA(K+1), ... , BETA(M) ),\n\ * C**2 + S**2 = I.\n\ *\n\ * (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored\n\ * ( 0 R22 R23 )\n\ * in B(M-K+1:L,N+M-K-L+1:N) on exit.\n\ *\n\ * The routine computes C, S, R, and optionally the orthogonal\n\ * transformation matrices U, V and Q.\n\ *\n\ * In particular, if B is an N-by-N nonsingular matrix, then the GSVD of\n\ * A and B implicitly gives the SVD of A*inv(B):\n\ * A*inv(B) = U*(D1*inv(D2))*V'.\n\ * If ( A',B')' has orthonormal columns, then the GSVD of A and B is\n\ * also equal to the CS decomposition of A and B. Furthermore, the GSVD\n\ * can be used to derive the solution of the eigenvalue problem:\n\ * A'*A x = lambda* B'*B x.\n\ * In some literature, the GSVD of A and B is presented in the form\n\ * U'*A*X = ( 0 D1 ), V'*B*X = ( 0 D2 )\n\ * where U and V are orthogonal and X is nonsingular, D1 and D2 are\n\ * ``diagonal''. The former GSVD form can be converted to the latter\n\ * form by taking the nonsingular matrix X as\n\ *\n\ * X = Q*( I 0 )\n\ * ( 0 inv(R) ).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBU (input) CHARACTER*1\n\ * = 'U': Orthogonal matrix U is computed;\n\ * = 'N': U is not computed.\n\ *\n\ * JOBV (input) CHARACTER*1\n\ * = 'V': Orthogonal matrix V is computed;\n\ * = 'N': V is not computed.\n\ *\n\ * JOBQ (input) CHARACTER*1\n\ * = 'Q': Orthogonal matrix Q is computed;\n\ * = 'N': Q is not computed.\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 matrices A and B. N >= 0.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows of the matrix B. P >= 0.\n\ *\n\ * K (output) INTEGER\n\ * L (output) INTEGER\n\ * On exit, K and L specify the dimension of the subblocks\n\ * described in the Purpose section.\n\ * K + L = effective numerical rank of (A',B')'.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, A contains the triangular matrix R, or part of R.\n\ * See Purpose for details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input/output) REAL array, dimension (LDB,N)\n\ * On entry, the P-by-N matrix B.\n\ * On exit, B contains the triangular matrix R if M-K-L < 0.\n\ * See Purpose for details.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,P).\n\ *\n\ * ALPHA (output) REAL array, dimension (N)\n\ * BETA (output) REAL array, dimension (N)\n\ * On exit, ALPHA and BETA contain the generalized singular\n\ * value pairs of A and B;\n\ * ALPHA(1:K) = 1,\n\ * BETA(1:K) = 0,\n\ * and if M-K-L >= 0,\n\ * ALPHA(K+1:K+L) = C,\n\ * BETA(K+1:K+L) = S,\n\ * or if M-K-L < 0,\n\ * ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0\n\ * BETA(K+1:M) =S, BETA(M+1:K+L) =1\n\ * and\n\ * ALPHA(K+L+1:N) = 0\n\ * BETA(K+L+1:N) = 0\n\ *\n\ * U (output) REAL array, dimension (LDU,M)\n\ * If JOBU = 'U', U contains the M-by-M orthogonal matrix U.\n\ * If JOBU = 'N', U is not referenced.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= max(1,M) if\n\ * JOBU = 'U'; LDU >= 1 otherwise.\n\ *\n\ * V (output) REAL array, dimension (LDV,P)\n\ * If JOBV = 'V', V contains the P-by-P orthogonal matrix V.\n\ * If JOBV = 'N', V is not referenced.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V. LDV >= max(1,P) if\n\ * JOBV = 'V'; LDV >= 1 otherwise.\n\ *\n\ * Q (output) REAL array, dimension (LDQ,N)\n\ * If JOBQ = 'Q', Q contains the N-by-N orthogonal matrix Q.\n\ * If JOBQ = 'N', Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N) if\n\ * JOBQ = 'Q'; LDQ >= 1 otherwise.\n\ *\n\ * WORK (workspace) REAL array,\n\ * dimension (max(3*N,M,P)+N)\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (N)\n\ * On exit, IWORK stores the sorting information. More\n\ * precisely, the following loop will sort ALPHA\n\ * for I = K+1, min(M,K+L)\n\ * swap ALPHA(I) and ALPHA(IWORK(I))\n\ * endfor\n\ * such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N).\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 = 1, the Jacobi-type procedure failed to\n\ * converge. For further details, see subroutine STGSJA.\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * TOLA REAL\n\ * TOLB REAL\n\ * TOLA and TOLB are the thresholds to determine the effective\n\ * rank of (A',B')'. Generally, they are set to\n\ * TOLA = MAX(M,N)*norm(A)*MACHEPS,\n\ * TOLB = MAX(P,N)*norm(B)*MACHEPS.\n\ * The size of TOLA and TOLB may affect the size of backward\n\ * errors of the decomposition.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * 2-96 Based on modifications by\n\ * Ming Gu and Huan Ren, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL WANTQ, WANTU, WANTV\n INTEGER I, IBND, ISUB, J, NCYCLE\n REAL ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n REAL SLAMCH, SLANGE\n EXTERNAL LSAME, SLAMCH, SLANGE\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SCOPY, SGGSVP, STGSJA, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zgerfsx0000644000175000017500000004032212502223526016701 0ustar uwabamiuwabami--- :name: zgerfsx :md5sum: 20fccfe77933bc17f97c52905fa7faff :category: :subroutine :arguments: - trans: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - r: :type: doublereal :intent: input :dims: - n - c: :type: doublereal :intent: input :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " SUBROUTINE ZGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGERFSX improves the computed solution to a system of linear\n\ * equations and provides error bounds and backward error estimates\n\ * for the solution. In addition to normwise error bound, the code\n\ * provides maximum componentwise error bound if possible. See\n\ * comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n\ * error bounds.\n\ *\n\ * The original system of linear equations may have been equilibrated\n\ * before calling this routine, as described by arguments EQUED, R\n\ * and C below. In this case, the solution and error bounds returned\n\ * are for the original unequilibrated system.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose = Transpose)\n\ *\n\ * EQUED (input) CHARACTER*1\n\ * Specifies the form of equilibration that was done to A\n\ * before calling this routine. This is needed to compute\n\ * the solution and error bounds correctly.\n\ * = 'N': No equilibration\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ * The right hand side B has been changed accordingly.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The original N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX*16 array, dimension (LDAF,N)\n\ * The factors L and U from the factorization A = P*L*U\n\ * as computed by ZGETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from ZGETRF; for 1<=i<=N, row i of the\n\ * matrix was interchanged with row IPIV(i).\n\ *\n\ * R (input) DOUBLE PRECISION array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'R' or 'B', A is\n\ * multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n\ * is not accessed. \n\ * If R is accessed, each element of R should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension (N)\n\ * The column scale factors for A. If EQUED = 'C' or 'B', A is\n\ * multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n\ * is not accessed.\n\ * If C is accessed, each element of C should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by ZGETRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * Componentwise relative backward error. This is the\n\ * componentwise relative backward error of each solution vector X(j)\n\ * (i.e., the smallest relative change in any element of A or B that\n\ * makes X(j) an exact solution).\n\ *\n\ * N_ERR_BNDS (input) INTEGER\n\ * Number of error bounds to return for each right hand side\n\ * and each type (normwise or componentwise). See ERR_BNDS_NORM and\n\ * ERR_BNDS_COMP below.\n\ *\n\ * ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * dlamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * dlamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * dlamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * dlamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * dlamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * dlamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * NPARAMS (input) INTEGER\n\ * Specifies the number of parameters set in PARAMS. If .LE. 0, the\n\ * PARAMS array is never referenced and default values are used.\n\ *\n\ * PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS\n\ * Specifies algorithm parameters. If an entry is .LT. 0.0, then\n\ * that entry will be filled with default value used for that\n\ * parameter. Only positions up to NPARAMS are accessed; defaults\n\ * are used for higher-numbered parameters.\n\ *\n\ * PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n\ * refinement or not.\n\ * Default: 1.0D+0\n\ * = 0.0 : No refinement is performed, and no error bounds are\n\ * computed.\n\ * = 1.0 : Use the double-precision refinement algorithm,\n\ * possibly with doubled-single computations if the\n\ * compilation environment does not support DOUBLE\n\ * PRECISION.\n\ * (other values are reserved for future use)\n\ *\n\ * PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n\ * computations allowed for refinement.\n\ * Default: 10\n\ * Aggressive: Set to 100 to permit convergence using approximate\n\ * factorizations or factorizations other than LU. If\n\ * the factorization uses a technique other than\n\ * Gaussian elimination, the guarantees in\n\ * err_bnds_norm and err_bnds_comp may no longer be\n\ * trustworthy.\n\ *\n\ * PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n\ * will attempt to find a solution with small componentwise\n\ * relative error in the double-precision algorithm. Positive\n\ * is true, 0.0 is false.\n\ * Default: 1.0 (attempt componentwise convergence)\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit. The solution to every right-hand side is\n\ * guaranteed.\n\ * < 0: If INFO = -i, the i-th argument had an illegal value\n\ * > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgeequ0000644000175000017500000000657412502223526016476 0ustar uwabamiuwabami--- :name: dgeequ :md5sum: 24654d259d19a245582b147d74ff0ecb :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - r: :type: doublereal :intent: output :dims: - m - c: :type: doublereal :intent: output :dims: - n - rowcnd: :type: doublereal :intent: output - colcnd: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE DGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGEEQU computes row and column scalings intended to equilibrate an\n\ * M-by-N matrix A and reduce its condition number. R returns the row\n\ * scale factors and C the column scale factors, chosen to try to make\n\ * the largest element in each row and column of the matrix B with\n\ * elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n\ *\n\ * R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n\ * number and BIGNUM = largest safe number. Use of these scaling\n\ * factors is not guaranteed to reduce the condition number of A but\n\ * works well in practice.\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) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The M-by-N matrix whose equilibration factors are\n\ * to be computed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * R (output) DOUBLE PRECISION array, dimension (M)\n\ * If INFO = 0 or INFO > M, R contains the row scale factors\n\ * for A.\n\ *\n\ * C (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, C contains the column scale factors for A.\n\ *\n\ * ROWCND (output) DOUBLE PRECISION\n\ * If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n\ * smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n\ * AMAX is neither too large nor too small, it is not worth\n\ * scaling by R.\n\ *\n\ * COLCND (output) DOUBLE PRECISION\n\ * If INFO = 0, COLCND contains the ratio of the smallest\n\ * C(i) to the largest C(i). If COLCND >= 0.1, it is not\n\ * worth scaling by C.\n\ *\n\ * AMAX (output) DOUBLE PRECISION\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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, and i is\n\ * <= M: the i-th row of A is exactly zero\n\ * > M: the (i-M)-th column of A is exactly zero\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgegs0000644000175000017500000001574012502223526016336 0ustar uwabamiuwabami--- :name: zgegs :md5sum: 988d32aa0ef24205bd7a6eaa25b40715 :category: :subroutine :arguments: - jobvsl: :type: char :intent: input - jobvsr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alpha: :type: doublecomplex :intent: output :dims: - n - beta: :type: doublecomplex :intent: output :dims: - n - vsl: :type: doublecomplex :intent: output :dims: - ldvsl - n - ldvsl: :type: integer :intent: input - vsr: :type: doublecomplex :intent: output :dims: - ldvsr - n - ldvsr: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: doublereal :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: ldvsl: "lsame_(&jobvsl,\"V\") ? n : 1" ldvsr: "lsame_(&jobvsr,\"V\") ? n : 1" :fortran_help: " SUBROUTINE ZGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This routine is deprecated and has been replaced by routine ZGGES.\n\ *\n\ * ZGEGS computes the eigenvalues, Schur form, and, optionally, the\n\ * left and or/right Schur vectors of a complex matrix pair (A,B).\n\ * Given two square matrices A and B, the generalized Schur\n\ * factorization has the form\n\ * \n\ * A = Q*S*Z**H, B = Q*T*Z**H\n\ * \n\ * where Q and Z are unitary matrices and S and T are upper triangular.\n\ * The columns of Q are the left Schur vectors\n\ * and the columns of Z are the right Schur vectors.\n\ * \n\ * If only the eigenvalues of (A,B) are needed, the driver routine\n\ * ZGEGV should be used instead. See ZGEGV for a description of the\n\ * eigenvalues of the generalized nonsymmetric eigenvalue problem\n\ * (GNEP).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVSL (input) CHARACTER*1\n\ * = 'N': do not compute the left Schur vectors;\n\ * = 'V': compute the left Schur vectors (returned in VSL).\n\ *\n\ * JOBVSR (input) CHARACTER*1\n\ * = 'N': do not compute the right Schur vectors;\n\ * = 'V': compute the right Schur vectors (returned in VSR).\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A, B, VSL, and VSR. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA, N)\n\ * On entry, the matrix A.\n\ * On exit, the upper triangular matrix S from the generalized\n\ * Schur factorization.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB, N)\n\ * On entry, the matrix B.\n\ * On exit, the upper triangular matrix T from the generalized\n\ * Schur factorization.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B. LDB >= max(1,N).\n\ *\n\ * ALPHA (output) COMPLEX*16 array, dimension (N)\n\ * The complex scalars alpha that define the eigenvalues of\n\ * GNEP. ALPHA(j) = S(j,j), the diagonal element of the Schur\n\ * form of A.\n\ *\n\ * BETA (output) COMPLEX*16 array, dimension (N)\n\ * The non-negative real scalars beta that define the\n\ * eigenvalues of GNEP. BETA(j) = T(j,j), the diagonal element\n\ * of the triangular factor T.\n\ *\n\ * Together, the quantities alpha = ALPHA(j) and beta = BETA(j)\n\ * represent the j-th eigenvalue of the matrix pair (A,B), in\n\ * one of the forms lambda = alpha/beta or mu = beta/alpha.\n\ * Since either lambda or mu may overflow, they should not,\n\ * in general, be computed.\n\ *\n\ *\n\ * VSL (output) COMPLEX*16 array, dimension (LDVSL,N)\n\ * If JOBVSL = 'V', the matrix of left Schur vectors Q.\n\ * Not referenced if JOBVSL = 'N'.\n\ *\n\ * LDVSL (input) INTEGER\n\ * The leading dimension of the matrix VSL. LDVSL >= 1, and\n\ * if JOBVSL = 'V', LDVSL >= N.\n\ *\n\ * VSR (output) COMPLEX*16 array, dimension (LDVSR,N)\n\ * If JOBVSR = 'V', the matrix of right Schur vectors Z.\n\ * Not referenced if JOBVSR = 'N'.\n\ *\n\ * LDVSR (input) INTEGER\n\ * The leading dimension of the matrix VSR. LDVSR >= 1, and\n\ * if JOBVSR = 'V', LDVSR >= N.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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,2*N).\n\ * For good performance, LWORK must generally be larger.\n\ * To compute the optimal value of LWORK, call ILAENV to get\n\ * blocksizes (for ZGEQRF, ZUNMQR, and CUNGQR.) Then compute:\n\ * NB -- MAX of the blocksizes for ZGEQRF, ZUNMQR, and CUNGQR;\n\ * the optimal LWORK is N*(NB+1).\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\ * RWORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * =1,...,N:\n\ * The QZ iteration failed. (A,B) are not in Schur\n\ * form, but ALPHA(j) and BETA(j) should be correct for\n\ * j=INFO+1,...,N.\n\ * > N: errors that usually indicate LAPACK problems:\n\ * =N+1: error return from ZGGBAL\n\ * =N+2: error return from ZGEQRF\n\ * =N+3: error return from ZUNMQR\n\ * =N+4: error return from ZUNGQR\n\ * =N+5: error return from ZGGHRD\n\ * =N+6: error return from ZHGEQZ (other than failed\n\ * iteration)\n\ * =N+7: error return from ZGGBAK (computing VSL)\n\ * =N+8: error return from ZGGBAK (computing VSR)\n\ * =N+9: error return from ZLASCL (various places)\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zungtr0000644000175000017500000000551412502223526016546 0ustar uwabamiuwabami--- :name: zungtr :md5sum: d19f85a6bbd5f0ff4e71639186927cd5 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - n-1 - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZUNGTR generates a complex unitary matrix Q which is defined as the\n\ * product of n-1 elementary reflectors of order N, as returned by\n\ * ZHETRD:\n\ *\n\ * if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),\n\ *\n\ * if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A contains elementary reflectors\n\ * from ZHETRD;\n\ * = 'L': Lower triangle of A contains elementary reflectors\n\ * from ZHETRD.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix Q. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the vectors which define the elementary reflectors,\n\ * as returned by ZHETRD.\n\ * On exit, the N-by-N unitary matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= N.\n\ *\n\ * TAU (input) COMPLEX*16 array, dimension (N-1)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by ZHETRD.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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 >= N-1.\n\ * For optimum performance LWORK >= (N-1)*NB, where NB is\n\ * the 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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlar2v0000644000175000017500000000524412502223526016435 0ustar uwabamiuwabami--- :name: zlar2v :md5sum: e546278eb7b619c19afba3766521f824 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - 1+(n-1)*incx - y: :type: doublecomplex :intent: input/output :dims: - 1+(n-1)*incx - z: :type: doublecomplex :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - c: :type: doublereal :intent: input :dims: - 1+(n-1)*incc - s: :type: doublecomplex :intent: input :dims: - 1+(n-1)*incc - incc: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE ZLAR2V( N, X, Y, Z, INCX, C, S, INCC )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAR2V applies a vector of complex plane rotations with real cosines\n\ * from both sides to a sequence of 2-by-2 complex Hermitian matrices,\n\ * defined by the elements of the vectors x, y and z. For i = 1,2,...,n\n\ *\n\ * ( x(i) z(i) ) :=\n\ * ( conjg(z(i)) y(i) )\n\ *\n\ * ( c(i) conjg(s(i)) ) ( x(i) z(i) ) ( c(i) -conjg(s(i)) )\n\ * ( -s(i) c(i) ) ( conjg(z(i)) y(i) ) ( s(i) c(i) )\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of plane rotations to be applied.\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX)\n\ * The vector x; the elements of x are assumed to be real.\n\ *\n\ * Y (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX)\n\ * The vector y; the elements of y are assumed to be real.\n\ *\n\ * Z (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX)\n\ * The vector z.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between elements of X, Y and Z. INCX > 0.\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)\n\ * The cosines of the plane rotations.\n\ *\n\ * S (input) COMPLEX*16 array, dimension (1+(N-1)*INCC)\n\ * The sines of the plane rotations.\n\ *\n\ * INCC (input) INTEGER\n\ * The increment between elements of C and S. INCC > 0.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, IC, IX\n DOUBLE PRECISION CI, SII, SIR, T1I, T1R, T5, T6, XI, YI, ZII,\n $ ZIR\n COMPLEX*16 SI, T2, T3, T4, ZI\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC DBLE, DCMPLX, DCONJG, DIMAG\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dsyrfsx0000644000175000017500000003761512502223526016726 0ustar uwabamiuwabami--- :name: dsyrfsx :md5sum: 8aa531ba3e04ed4610af5a9318014bae :category: :subroutine :arguments: - uplo: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublereal :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " SUBROUTINE DSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSYRFSX improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is symmetric indefinite, and\n\ * provides error bounds and backward error estimates for the\n\ * solution. In addition to normwise error bound, the code provides\n\ * maximum componentwise error bound if possible. See comments for\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.\n\ *\n\ * The original system of linear equations may have been equilibrated\n\ * before calling this routine, as described by arguments EQUED and S\n\ * below. In this case, the solution and error bounds returned are\n\ * for the original unequilibrated system.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * EQUED (input) CHARACTER*1\n\ * Specifies the form of equilibration that was done to A\n\ * before calling this routine. This is needed to compute\n\ * the solution and error bounds correctly.\n\ * = 'N': No equilibration\n\ * = 'Y': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(S) * A * diag(S).\n\ * The right hand side B has been changed accordingly.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular\n\ * part of the matrix A, and the strictly lower triangular\n\ * part of A is not referenced. If UPLO = 'L', the leading\n\ * N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n\ * The factored form of the matrix A. AF contains the block\n\ * diagonal matrix D and the multipliers used to obtain the\n\ * factor U or L from the factorization A = U*D*U**T or A =\n\ * L*D*L**T as computed by DSYTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by DSYTRF.\n\ *\n\ * S (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The scale factors for A. If EQUED = 'Y', A is multiplied on\n\ * the left and right by diag(S). S is an input argument if FACT =\n\ * 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n\ * = 'Y', each element of S must be positive. If S is output, each\n\ * element of S is a power of the radix. If S is input, each element\n\ * of S should be a power of the radix to ensure a reliable solution\n\ * and error estimates. Scaling by powers of the radix does not cause\n\ * rounding errors unless the result underflows or overflows.\n\ * Rounding errors during scaling lead to refining with a matrix that\n\ * is not equivalent to the input matrix, producing error estimates\n\ * that may not be reliable.\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by DGETRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * Componentwise relative backward error. This is the\n\ * componentwise relative backward error of each solution vector X(j)\n\ * (i.e., the smallest relative change in any element of A or B that\n\ * makes X(j) an exact solution).\n\ *\n\ * N_ERR_BNDS (input) INTEGER\n\ * Number of error bounds to return for each right hand side\n\ * and each type (normwise or componentwise). See ERR_BNDS_NORM and\n\ * ERR_BNDS_COMP below.\n\ *\n\ * ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * dlamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * dlamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * dlamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * dlamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * dlamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * dlamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * NPARAMS (input) INTEGER\n\ * Specifies the number of parameters set in PARAMS. If .LE. 0, the\n\ * PARAMS array is never referenced and default values are used.\n\ *\n\ * PARAMS (input / output) DOUBLE PRECISION array, dimension (NPARAMS)\n\ * Specifies algorithm parameters. If an entry is .LT. 0.0, then\n\ * that entry will be filled with default value used for that\n\ * parameter. Only positions up to NPARAMS are accessed; defaults\n\ * are used for higher-numbered parameters.\n\ *\n\ * PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n\ * refinement or not.\n\ * Default: 1.0D+0\n\ * = 0.0 : No refinement is performed, and no error bounds are\n\ * computed.\n\ * = 1.0 : Use the double-precision refinement algorithm,\n\ * possibly with doubled-single computations if the\n\ * compilation environment does not support DOUBLE\n\ * PRECISION.\n\ * (other values are reserved for future use)\n\ *\n\ * PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n\ * computations allowed for refinement.\n\ * Default: 10\n\ * Aggressive: Set to 100 to permit convergence using approximate\n\ * factorizations or factorizations other than LU. If\n\ * the factorization uses a technique other than\n\ * Gaussian elimination, the guarantees in\n\ * err_bnds_norm and err_bnds_comp may no longer be\n\ * trustworthy.\n\ *\n\ * PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n\ * will attempt to find a solution with small componentwise\n\ * relative error in the double-precision algorithm. Positive\n\ * is true, 0.0 is false.\n\ * Default: 1.0 (attempt componentwise convergence)\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit. The solution to every right-hand side is\n\ * guaranteed.\n\ * < 0: If INFO = -i, the i-th argument had an illegal value\n\ * > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slarrv0000644000175000017500000002200112655767354016541 0ustar uwabamiuwabami--- :name: slarrv :md5sum: c11cfd693c654d5325e306c9460e5b65 :category: :subroutine :arguments: - n: :type: integer :intent: input - vl: :type: real :intent: input - vu: :type: real :intent: input - d: :type: real :intent: input/output :dims: - n - l: :type: real :intent: input/output :dims: - n - pivmin: :type: real :intent: input - isplit: :type: integer :intent: input :dims: - n - m: :type: integer :intent: input - dol: :type: integer :intent: input - dou: :type: integer :intent: input - minrgp: :type: real :intent: input - rtol1: :type: real :intent: input - rtol2: :type: real :intent: input - w: :type: real :intent: input/output :dims: - n - werr: :type: real :intent: input/output :dims: - n - wgap: :type: real :intent: input/output :dims: - n - iblock: :type: integer :intent: input :dims: - n - indexw: :type: integer :intent: input :dims: - n - gers: :type: real :intent: input :dims: - 2*n - z: :type: real :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - work: :type: real :intent: workspace :dims: - 12*n - iwork: :type: integer :intent: workspace :dims: - 7*n - info: :type: integer :intent: output :substitutions: ldz: n :fortran_help: " SUBROUTINE SLARRV( N, VL, VU, D, L, PIVMIN, ISPLIT, M, DOL, DOU, MINRGP, RTOL1, RTOL2, W, WERR, WGAP, IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLARRV computes the eigenvectors of the tridiagonal matrix\n\ * T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T.\n\ * The input eigenvalues should have been computed by SLARRE.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * VL (input) REAL \n\ * VU (input) REAL \n\ * Lower and upper bounds of the interval that contains the desired\n\ * eigenvalues. VL < VU. Needed to compute gaps on the left or right\n\ * end of the extremal eigenvalues in the desired RANGE.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the N diagonal elements of the diagonal matrix D.\n\ * On exit, D may be overwritten.\n\ *\n\ * L (input/output) REAL array, dimension (N)\n\ * On entry, the (N-1) subdiagonal elements of the unit\n\ * bidiagonal matrix L are in elements 1 to N-1 of L\n\ * (if the matrix is not split.) At the end of each block\n\ * is stored the corresponding shift as given by SLARRE.\n\ * On exit, L is overwritten.\n\ *\n\ * PIVMIN (input) REAL\n\ * The minimum pivot allowed in the Sturm sequence.\n\ *\n\ * ISPLIT (input) INTEGER array, dimension (N)\n\ * The splitting points, at which T breaks up into blocks.\n\ * The first block consists of rows/columns 1 to\n\ * ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n\ * through ISPLIT( 2 ), etc.\n\ *\n\ * M (input) INTEGER\n\ * The total number of input eigenvalues. 0 <= M <= N.\n\ *\n\ * DOL (input) INTEGER\n\ * DOU (input) INTEGER\n\ * If the user wants to compute only selected eigenvectors from all\n\ * the eigenvalues supplied, he can specify an index range DOL:DOU.\n\ * Or else the setting DOL=1, DOU=M should be applied.\n\ * Note that DOL and DOU refer to the order in which the eigenvalues\n\ * are stored in W.\n\ * If the user wants to compute only selected eigenpairs, then\n\ * the columns DOL-1 to DOU+1 of the eigenvector space Z contain the\n\ * computed eigenvectors. All other columns of Z are set to zero.\n\ *\n\ * MINRGP (input) REAL \n\ *\n\ * RTOL1 (input) REAL \n\ * RTOL2 (input) REAL \n\ * Parameters for bisection.\n\ * An interval [LEFT,RIGHT] has converged if\n\ * RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n\ *\n\ * W (input/output) REAL array, dimension (N)\n\ * The first M elements of W contain the APPROXIMATE eigenvalues for\n\ * which eigenvectors are to be computed. The eigenvalues\n\ * should be grouped by split-off block and ordered from\n\ * smallest to largest within the block ( The output array\n\ * W from SLARRE is expected here ). Furthermore, they are with\n\ * respect to the shift of the corresponding root representation\n\ * for their block. On exit, W holds the eigenvalues of the\n\ * UNshifted matrix.\n\ *\n\ * WERR (input/output) REAL array, dimension (N)\n\ * The first M elements contain the semiwidth of the uncertainty\n\ * interval of the corresponding eigenvalue in W\n\ *\n\ * WGAP (input/output) REAL array, dimension (N)\n\ * The separation from the right neighbor eigenvalue in W.\n\ *\n\ * IBLOCK (input) INTEGER array, dimension (N)\n\ * The indices of the blocks (submatrices) associated with the\n\ * corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue\n\ * W(i) belongs to the first block from the top, =2 if W(i)\n\ * belongs to the second block, etc.\n\ *\n\ * INDEXW (input) INTEGER array, dimension (N)\n\ * The indices of the eigenvalues within each block (submatrix);\n\ * for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the\n\ * i-th eigenvalue W(i) is the 10-th eigenvalue in the second block.\n\ *\n\ * GERS (input) REAL array, dimension (2*N)\n\ * The N Gerschgorin intervals (the i-th Gerschgorin interval\n\ * is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should\n\ * be computed from the original UNshifted matrix.\n\ *\n\ * Z (output) REAL array, dimension (LDZ, max(1,M) )\n\ * If INFO = 0, the first M columns of Z contain the\n\ * orthonormal eigenvectors of the matrix T\n\ * corresponding to the input eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )\n\ * The support of the eigenvectors in Z, i.e., the indices\n\ * indicating the nonzero elements in Z. The I-th eigenvector\n\ * is nonzero only in elements ISUPPZ( 2*I-1 ) through\n\ * ISUPPZ( 2*I ).\n\ *\n\ * WORK (workspace) REAL array, dimension (12*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (7*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ *\n\ * > 0: A problem occured in SLARRV.\n\ * < 0: One of the called subroutines signaled an internal problem.\n\ * Needs inspection of the corresponding parameter IINFO\n\ * for further information.\n\ *\n\ * =-1: Problem in SLARRB when refining a child's eigenvalues.\n\ * =-2: Problem in SLARRF when computing the RRR of a child.\n\ * When a child is inside a tight cluster, it can be difficult\n\ * to find an RRR. A partial remedy from the user's point of\n\ * view is to make the parameter MINRGP smaller and recompile.\n\ * However, as the orthogonality of the computed vectors is\n\ * proportional to 1/MINRGP, the user should be aware that\n\ * he might be trading in precision when he decreases MINRGP.\n\ * =-3: Problem in SLARRB when refining a single eigenvalue\n\ * after the Rayleigh correction was rejected.\n\ * = 5: The Rayleigh Quotient Iteration failed to converge to\n\ * full accuracy in MAXITR steps.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Beresford Parlett, University of California, Berkeley, USA\n\ * Jim Demmel, University of California, Berkeley, USA\n\ * Inderjit Dhillon, University of Texas, Austin, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, University of California, Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cspr0000644000175000017500000000672412502223525016167 0ustar uwabamiuwabami--- :name: cspr :md5sum: d07736c23393e9ea356860b4e3d8a14b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - alpha: :type: complex :intent: input - x: :type: complex :intent: input :dims: - 1 + ( n - 1 )*abs( incx ) - incx: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - ( n*( n + 1 ) )/2 :substitutions: {} :fortran_help: " SUBROUTINE CSPR( UPLO, N, ALPHA, X, INCX, AP )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSPR performs the symmetric rank 1 operation\n\ *\n\ * A := alpha*x*conjg( x' ) + A,\n\ *\n\ * where alpha is a complex scalar, x is an n element vector and A is an\n\ * n by n symmetric matrix, supplied in packed form.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * On entry, UPLO specifies whether the upper or lower\n\ * triangular part of the matrix A is supplied in the packed\n\ * array AP as follows:\n\ *\n\ * UPLO = 'U' or 'u' The upper triangular part of A is\n\ * supplied in AP.\n\ *\n\ * UPLO = 'L' or 'l' The lower triangular part of A is\n\ * supplied in AP.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the order of the matrix A.\n\ * N must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * ALPHA (input) COMPLEX\n\ * On entry, ALPHA specifies the scalar alpha.\n\ * Unchanged on exit.\n\ *\n\ * X (input) COMPLEX array, dimension at least\n\ * ( 1 + ( N - 1 )*abs( INCX ) ).\n\ * Before entry, the incremented array X must contain the N-\n\ * element vector x.\n\ * Unchanged on exit.\n\ *\n\ * INCX (input) INTEGER\n\ * On entry, INCX specifies the increment for the elements of\n\ * X. INCX must not be zero.\n\ * Unchanged on exit.\n\ *\n\ * AP (input/output) COMPLEX array, dimension at least\n\ * ( ( N*( N + 1 ) )/2 ).\n\ * Before entry, with UPLO = 'U' or 'u', the array AP must\n\ * contain the upper triangular part of the symmetric matrix\n\ * packed sequentially, column by column, so that AP( 1 )\n\ * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )\n\ * and a( 2, 2 ) respectively, and so on. On exit, the array\n\ * AP is overwritten by the upper triangular part of the\n\ * updated matrix.\n\ * Before entry, with UPLO = 'L' or 'l', the array AP must\n\ * contain the lower triangular part of the symmetric matrix\n\ * packed sequentially, column by column, so that AP( 1 )\n\ * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )\n\ * and a( 3, 1 ) respectively, and so on. On exit, the array\n\ * AP is overwritten by the lower triangular part of the\n\ * updated matrix.\n\ * Note that the imaginary parts of the diagonal elements need\n\ * not be set, they are assumed to be zero, and on exit they\n\ * are set to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chesvx0000644000175000017500000002340112502223525016507 0ustar uwabamiuwabami--- :name: chesvx :md5sum: 4374c03c50dbc833b7b3725c7ed3611d :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE CHESVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHESVX uses the diagonal pivoting factorization to compute the\n\ * solution to a complex system of linear equations A * X = B,\n\ * where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS\n\ * matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'N', the diagonal pivoting method is used to factor A.\n\ * The form of the factorization is\n\ * A = U * D * U**H, if UPLO = 'U', or\n\ * A = L * D * L**H, if UPLO = 'L',\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, and D is Hermitian and block diagonal with\n\ * 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\ * 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n\ * returns with INFO = i. Otherwise, the factored form of A is used\n\ * to estimate the condition number of the matrix A. If the\n\ * reciprocal of the condition number is less than machine precision,\n\ * INFO = N+1 is returned as a warning, but the routine still goes on\n\ * to solve for X and compute error bounds as described below.\n\ *\n\ * 3. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 4. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of A has been\n\ * supplied on entry.\n\ * = 'F': On entry, AF and IPIV contain the factored form\n\ * of A. A, AF and IPIV will not be modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The Hermitian matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular part\n\ * of the matrix A, and the strictly lower triangular part of A\n\ * is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of A contains the lower triangular part of\n\ * the matrix A, and the strictly upper triangular part of A is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input or output) COMPLEX array, dimension (LDAF,N)\n\ * If FACT = 'F', then AF is an input argument and on entry\n\ * contains the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L from the factorization\n\ * A = U*D*U**H or A = L*D*L**H as computed by CHETRF.\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L from the factorization\n\ * A = U*D*U**H or A = L*D*L**H.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains details of the interchanges and the block structure\n\ * of D, as determined by CHETRF.\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains details of the interchanges and the block structure\n\ * of D, as determined by CHETRF.\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,NRHS)\n\ * The N-by-NRHS right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A. If RCOND is less than the machine precision (in\n\ * particular, if RCOND = 0), the matrix is singular to working\n\ * precision. This condition is indicated by a return code of\n\ * INFO > 0.\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of WORK. LWORK >= max(1,2*N), and for best\n\ * performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where\n\ * NB is the optimal blocksize for CHETRF.\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\ * RWORK (workspace) REAL array, dimension (N)\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, and i is\n\ * <= N: D(i,i) is exactly zero. The factorization\n\ * has been completed but the factor D is exactly\n\ * singular, so the solution and error bounds could\n\ * not be computed. RCOND = 0 is returned.\n\ * = N+1: D is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sporfsx0000644000175000017500000003656412502223526016732 0ustar uwabamiuwabami--- :name: sporfsx :md5sum: aa5a8957ca3223e6fa42b338a9f77adb :category: :subroutine :arguments: - uplo: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - s: :type: real :intent: input/output :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: real :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " SUBROUTINE SPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPORFSX improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is symmetric positive\n\ * definite, and provides error bounds and backward error estimates\n\ * for the solution. In addition to normwise error bound, the code\n\ * provides maximum componentwise error bound if possible. See\n\ * comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n\ * error bounds.\n\ *\n\ * The original system of linear equations may have been equilibrated\n\ * before calling this routine, as described by arguments EQUED and S\n\ * below. In this case, the solution and error bounds returned are\n\ * for the original unequilibrated system.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * EQUED (input) CHARACTER*1\n\ * Specifies the form of equilibration that was done to A\n\ * before calling this routine. This is needed to compute\n\ * the solution and error bounds correctly.\n\ * = 'N': No equilibration\n\ * = 'Y': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(S) * A * diag(S).\n\ * The right hand side B has been changed accordingly.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular part\n\ * of the matrix A, and the strictly lower triangular part of A\n\ * is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of A contains the lower triangular part of\n\ * the matrix A, and the strictly upper triangular part of A is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) REAL array, dimension (LDAF,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T, as computed by SPOTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * S (input or output) REAL array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'Y', A is multiplied on\n\ * the left and right by diag(S). S is an input argument if FACT =\n\ * 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n\ * = 'Y', each element of S must be positive. If S is output, each\n\ * element of S is a power of the radix. If S is input, each element\n\ * of S should be a power of the radix to ensure a reliable solution\n\ * and error estimates. Scaling by powers of the radix does not cause\n\ * rounding errors unless the result underflows or overflows.\n\ * Rounding errors during scaling lead to refining with a matrix that\n\ * is not equivalent to the input matrix, producing error estimates\n\ * that may not be reliable.\n\ *\n\ * B (input) REAL array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) REAL array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by SGETRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * Componentwise relative backward error. This is the\n\ * componentwise relative backward error of each solution vector X(j)\n\ * (i.e., the smallest relative change in any element of A or B that\n\ * makes X(j) an exact solution).\n\ *\n\ * N_ERR_BNDS (input) INTEGER\n\ * Number of error bounds to return for each right hand side\n\ * and each type (normwise or componentwise). See ERR_BNDS_NORM and\n\ * ERR_BNDS_COMP below.\n\ *\n\ * ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * NPARAMS (input) INTEGER\n\ * Specifies the number of parameters set in PARAMS. If .LE. 0, the\n\ * PARAMS array is never referenced and default values are used.\n\ *\n\ * PARAMS (input / output) REAL array, dimension NPARAMS\n\ * Specifies algorithm parameters. If an entry is .LT. 0.0, then\n\ * that entry will be filled with default value used for that\n\ * parameter. Only positions up to NPARAMS are accessed; defaults\n\ * are used for higher-numbered parameters.\n\ *\n\ * PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n\ * refinement or not.\n\ * Default: 1.0\n\ * = 0.0 : No refinement is performed, and no error bounds are\n\ * computed.\n\ * = 1.0 : Use the double-precision refinement algorithm,\n\ * possibly with doubled-single computations if the\n\ * compilation environment does not support DOUBLE\n\ * PRECISION.\n\ * (other values are reserved for future use)\n\ *\n\ * PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n\ * computations allowed for refinement.\n\ * Default: 10\n\ * Aggressive: Set to 100 to permit convergence using approximate\n\ * factorizations or factorizations other than LU. If\n\ * the factorization uses a technique other than\n\ * Gaussian elimination, the guarantees in\n\ * err_bnds_norm and err_bnds_comp may no longer be\n\ * trustworthy.\n\ *\n\ * PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n\ * will attempt to find a solution with small componentwise\n\ * relative error in the double-precision algorithm. Positive\n\ * is true, 0.0 is false.\n\ * Default: 1.0 (attempt componentwise convergence)\n\ *\n\ * WORK (workspace) REAL array, dimension (4*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit. The solution to every right-hand side is\n\ * guaranteed.\n\ * < 0: If INFO = -i, the i-th argument had an illegal value\n\ * > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlaqhp0000644000175000017500000000541612502223526016515 0ustar uwabamiuwabami--- :name: zlaqhp :md5sum: 4b5255af747ad03a9813eafa66d1d2da :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - s: :type: doublereal :intent: input :dims: - n - scond: :type: doublereal :intent: input - amax: :type: doublereal :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZLAQHP( UPLO, N, AP, S, SCOND, AMAX, EQUED )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAQHP equilibrates a Hermitian matrix A using the scaling factors\n\ * in the vector S.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * Hermitian matrix A is stored.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, the equilibrated matrix: diag(S) * A * diag(S), in\n\ * the same storage format as A.\n\ *\n\ * S (input) DOUBLE PRECISION array, dimension (N)\n\ * The scale factors for A.\n\ *\n\ * SCOND (input) DOUBLE PRECISION\n\ * Ratio of the smallest S(i) to the largest S(i).\n\ *\n\ * AMAX (input) DOUBLE PRECISION\n\ * Absolute value of largest matrix entry.\n\ *\n\ * EQUED (output) CHARACTER*1\n\ * Specifies whether or not equilibration was done.\n\ * = 'N': No equilibration.\n\ * = 'Y': Equilibration was done, i.e., A has been replaced by\n\ * diag(S) * A * diag(S).\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * THRESH is a threshold value used to decide if scaling should be done\n\ * based on the ratio of the scaling factors. If SCOND < THRESH,\n\ * scaling is done.\n\ *\n\ * LARGE and SMALL are threshold values used to decide if scaling should\n\ * be done based on the absolute size of the largest matrix element.\n\ * If AMAX > LARGE or AMAX < SMALL, scaling is done.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ztzrqf0000644000175000017500000000644612502223526016562 0ustar uwabamiuwabami--- :name: ztzrqf :md5sum: 00c8f4cc856a90b144228b80089890df :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE ZTZRQF( M, N, A, LDA, TAU, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This routine is deprecated and has been replaced by routine ZTZRZF.\n\ *\n\ * ZTZRQF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A\n\ * to upper triangular form by means of unitary transformations.\n\ *\n\ * The upper trapezoidal matrix A is factored as\n\ *\n\ * A = ( R 0 ) * Z,\n\ *\n\ * where Z is an N-by-N unitary matrix and R is an M-by-M upper\n\ * triangular matrix.\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 >= M.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the leading M-by-N upper trapezoidal part of the\n\ * array A must contain the matrix to be factorized.\n\ * On exit, the leading M-by-M upper triangular part of A\n\ * contains the upper triangular matrix R, and elements M+1 to\n\ * N of the first M rows of A, with the array TAU, represent the\n\ * unitary matrix Z as a product of M elementary reflectors.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (output) COMPLEX*16 array, dimension (M)\n\ * The scalar factors of the elementary reflectors.\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 factorization is obtained by Householder's method. The kth\n\ * transformation matrix, Z( k ), whose conjugate transpose is used to\n\ * introduce zeros into the (m - k + 1)th row of A, is given in the form\n\ *\n\ * Z( k ) = ( I 0 ),\n\ * ( 0 T( k ) )\n\ *\n\ * where\n\ *\n\ * T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n\ * ( 0 )\n\ * ( z( k ) )\n\ *\n\ * tau is a scalar and z( k ) is an ( n - m ) element vector.\n\ * tau and z( k ) are chosen to annihilate the elements of the kth row\n\ * of X.\n\ *\n\ * The scalar tau is returned in the kth element of TAU and the vector\n\ * u( k ) in the kth row of A, such that the elements of z( k ) are\n\ * in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n\ * the upper triangular part of A.\n\ *\n\ * Z is given by\n\ *\n\ * Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zsytri0000644000175000017500000000510312502223526016553 0ustar uwabamiuwabami--- :name: zsytri :md5sum: 0b41f14d19118a107c85c7fede211213 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublecomplex :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSYTRI computes the inverse of a complex symmetric indefinite matrix\n\ * A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n\ * ZSYTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the block diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L as computed by ZSYTRF.\n\ *\n\ * On exit, if INFO = 0, the (symmetric) inverse of the original\n\ * matrix. If UPLO = 'U', the upper triangular part of the\n\ * inverse is formed and the part of A below the diagonal is not\n\ * referenced; if UPLO = 'L' the lower triangular part of the\n\ * inverse is formed and the part of A above the diagonal is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by ZSYTRF.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\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, D(i,i) = 0; the matrix is singular and its\n\ * inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zstegr0000644000175000017500000002076312502223526016536 0ustar uwabamiuwabami--- :name: zstegr :md5sum: 49832177055455b53b056123ac827dbc :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 18*n : lsame_(&jobz,\"N\") ? 12*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 10*n : lsame_(&jobz,\"N\") ? 8*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " SUBROUTINE ZSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSTEGR computes selected eigenvalues and, optionally, eigenvectors\n\ * of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n\ * a well defined set of pairwise different real eigenvalues, the corresponding\n\ * real eigenvectors are pairwise orthogonal.\n\ *\n\ * The spectrum may be computed either completely or partially by specifying\n\ * either an interval (VL,VU] or a range of indices IL:IU for the desired\n\ * eigenvalues.\n\ *\n\ * ZSTEGR is a compatability wrapper around the improved ZSTEMR routine.\n\ * See DSTEMR for further details.\n\ *\n\ * One important change is that the ABSTOL parameter no longer provides any\n\ * benefit and hence is no longer used.\n\ *\n\ * Note : ZSTEGR and ZSTEMR work only on machines which follow\n\ * IEEE-754 floating-point standard in their handling of infinities and\n\ * NaNs. Normal execution may create these exceptiona values and hence\n\ * may abort due to a floating point exception in environments which\n\ * do not conform to the IEEE-754 standard.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found.\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found.\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the N diagonal elements of the tridiagonal matrix\n\ * T. On exit, D is overwritten.\n\ *\n\ * E (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the (N-1) subdiagonal elements of the tridiagonal\n\ * matrix T in elements 1 to N-1 of E. E(N) need not be set on\n\ * input, but is used internally as workspace.\n\ * On exit, E is overwritten.\n\ *\n\ * VL (input) DOUBLE PRECISION\n\ * VU (input) DOUBLE PRECISION\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) DOUBLE PRECISION\n\ * Unused. Was the absolute error tolerance for the\n\ * eigenvalues/eigenvectors in previous versions.\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * The first M elements contain the selected eigenvalues in\n\ * ascending order.\n\ *\n\ * Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M) )\n\ * If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix T\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ * Supplying N columns is always safe.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', then LDZ >= max(1,N).\n\ *\n\ * ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n\ * The support of the eigenvectors in Z, i.e., the indices\n\ * indicating the nonzero elements in Z. The i-th computed eigenvector\n\ * is nonzero only in elements ISUPPZ( 2*i-1 ) through\n\ * ISUPPZ( 2*i ). This is relevant in the case when the matrix\n\ * is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n\ *\n\ * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)\n\ * On exit, if INFO = 0, WORK(1) returns the optimal\n\ * (and minimal) LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK >= max(1,18*N)\n\ * if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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\ * IWORK (workspace/output) INTEGER array, dimension (LIWORK)\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK. LIWORK >= max(1,10*N)\n\ * if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n\ * if only the eigenvalues are to be computed.\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal size of the IWORK array,\n\ * returns this value as the first entry of the IWORK array, and\n\ * no error message related to LIWORK is issued by XERBLA.\n\ *\n\ * INFO (output) INTEGER\n\ * On exit, INFO\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: if INFO = 1X, internal error in DLARRE,\n\ * if INFO = 2X, internal error in ZLARRV.\n\ * Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n\ * the nonzero error code returned by DLARRE or\n\ * ZLARRV, respectively.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Inderjit Dhillon, IBM Almaden, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, LBNL/NERSC, USA\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL TRYRAC\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL ZSTEMR\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dggrqf0000644000175000017500000001560312502223526016467 0ustar uwabamiuwabami--- :name: dggrqf :md5sum: 17620fbd0172e2c1610c61d9628e64cf :category: :subroutine :arguments: - m: :type: integer :intent: input - p: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - taua: :type: doublereal :intent: output :dims: - MIN(m,n) - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - taub: :type: doublereal :intent: output :dims: - MIN(p,n) - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(MAX(n,m),p) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGGRQF computes a generalized RQ factorization of an M-by-N matrix A\n\ * and a P-by-N matrix B:\n\ *\n\ * A = R*Q, B = Z*T*Q,\n\ *\n\ * where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal\n\ * matrix, and R and T assume one of the forms:\n\ *\n\ * if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N,\n\ * N-M M ( R21 ) N\n\ * N\n\ *\n\ * where R12 or R21 is upper triangular, and\n\ *\n\ * if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P,\n\ * ( 0 ) P-N P N-P\n\ * N\n\ *\n\ * where T11 is upper triangular.\n\ *\n\ * In particular, if B is square and nonsingular, the GRQ factorization\n\ * of A and B implicitly gives the RQ factorization of A*inv(B):\n\ *\n\ * A*inv(B) = (R*inv(T))*Z'\n\ *\n\ * where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n\ * transpose of the matrix Z.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A. M >= 0.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows of the matrix B. P >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrices A and B. 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, if M <= N, the upper triangle of the subarray\n\ * A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;\n\ * if M > N, the elements on and above the (M-N)-th subdiagonal\n\ * contain the M-by-N upper trapezoidal matrix R; the remaining\n\ * elements, with the array TAUA, represent the orthogonal\n\ * matrix Q as a product of elementary reflectors (see Further\n\ * Details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAUA (output) DOUBLE PRECISION array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the orthogonal matrix Q (see Further Details).\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,N)\n\ * On entry, the P-by-N matrix B.\n\ * On exit, the elements on and above the diagonal of the array\n\ * contain the min(P,N)-by-N upper trapezoidal matrix T (T is\n\ * upper triangular if P >= N); the elements below the diagonal,\n\ * with the array TAUB, represent the orthogonal matrix Z as a\n\ * product of elementary reflectors (see Further Details).\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,P).\n\ *\n\ * TAUB (output) DOUBLE PRECISION array, dimension (min(P,N))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the orthogonal matrix Z (see Further 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,N,M,P).\n\ * For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n\ * where NB1 is the optimal blocksize for the RQ factorization\n\ * of an M-by-N matrix, NB2 is the optimal blocksize for the\n\ * QR factorization of a P-by-N matrix, and NB3 is the optimal\n\ * blocksize for a call of DORMRQ.\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 INF0= -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(1) H(2) . . . H(k), where k = min(m,n).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - taua * v * v'\n\ *\n\ * where taua is a real scalar, and v is a real vector with\n\ * v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n\ * A(m-k+i,1:n-k+i-1), and taua in TAUA(i).\n\ * To form Q explicitly, use LAPACK subroutine DORGRQ.\n\ * To use Q to update another matrix, use LAPACK subroutine DORMRQ.\n\ *\n\ * The matrix Z is represented as a product of elementary reflectors\n\ *\n\ * Z = H(1) H(2) . . . H(k), where k = min(p,n).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - taub * v * v'\n\ *\n\ * where taub is a real scalar, and v is a real vector with\n\ * v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),\n\ * and taub in TAUB(i).\n\ * To form Z explicitly, use LAPACK subroutine DORGQR.\n\ * To use Z to update another matrix, use LAPACK subroutine DORMQR.\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DGEQRF, DGERQF, DORMRQ, XERBLA\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC INT, MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sorml20000644000175000017500000000724412502223526016435 0ustar uwabamiuwabami--- :name: sorml2 :md5sum: 30a3da420120b18fe0d66742e041a3c1 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SORML2 overwrites the general real m by n matrix C with\n\ *\n\ * Q * C if SIDE = 'L' and TRANS = 'N', or\n\ *\n\ * Q'* C if SIDE = 'L' and TRANS = 'T', or\n\ *\n\ * C * Q if SIDE = 'R' and TRANS = 'N', or\n\ *\n\ * C * Q' if SIDE = 'R' and TRANS = 'T',\n\ *\n\ * where Q is a real orthogonal matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(k) . . . H(2) H(1)\n\ *\n\ * as returned by SGELQF. Q is of order m if SIDE = 'L' and of order n\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q' from the Left\n\ * = 'R': apply Q or Q' from the Right\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': apply Q (No transpose)\n\ * = 'T': apply Q' (Transpose)\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) REAL array, dimension\n\ * (LDA,M) if SIDE = 'L',\n\ * (LDA,N) if SIDE = 'R'\n\ * The i-th row must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * SGELQF in the first k rows of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,K).\n\ *\n\ * TAU (input) REAL array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by SGELQF.\n\ *\n\ * C (input/output) REAL array, dimension (LDC,N)\n\ * On entry, the m by n matrix C.\n\ * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) REAL array, dimension\n\ * (N) if SIDE = 'L',\n\ * (M) if SIDE = 'R'\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssytri20000644000175000017500000000732712502223526016640 0ustar uwabamiuwabami--- :name: ssytri2 :md5sum: f7557065622ea4dc05dffeeac6fa1e18 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: real :intent: input/output :dims: - lwork - lwork: :type: integer :intent: input :option: true :default: (n+nb+1)*(nb+3) - info: :type: integer :intent: output :substitutions: c__1: "1" c__m1: "-1" nb: ilaenv_(&c__1, "SSYTRF", &uplo, &n, &c__m1, &c__m1, &c__m1) :extras: c__1: integer c__m1: integer nb: integer :fortran_help: " SUBROUTINE SSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSYTRI2 computes the inverse of a real symmetric indefinite matrix\n\ * A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n\ * SSYTRF. SSYTRI2 sets the LEADING DIMENSION of the workspace\n\ * before calling SSYTRI2X that actually computes the inverse.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the NB diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L as computed by SSYTRF.\n\ *\n\ * On exit, if INFO = 0, the (symmetric) inverse of the original\n\ * matrix. If UPLO = 'U', the upper triangular part of the\n\ * inverse is formed and the part of A below the diagonal is not\n\ * referenced; if UPLO = 'L' the lower triangular part of the\n\ * inverse is formed and the part of A above the diagonal is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the NB structure of D\n\ * as determined by SSYTRF.\n\ *\n\ * WORK (workspace) REAL array, dimension (N+NB+1)*(NB+3)\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK.\n\ * WORK is size >= (N+NB+1)*(NB+3)\n\ * If LDWORK = -1, then a workspace query is assumed; the routine\n\ * calculates:\n\ * - the optimal size of the WORK array, returns\n\ * this value as the first entry of the WORK array,\n\ * - and no error message related to LDWORK 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, D(i,i) = 0; the matrix is singular and its\n\ * inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL UPPER, LQUERY\n INTEGER MINSIZE, NBMAX\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SSYTRI2X\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slarrf0000644000175000017500000001116212655767354016527 0ustar uwabamiuwabami--- :name: slarrf :md5sum: 04503ebe32bcc573b80d9d85b4382ab2 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - l: :type: real :intent: input :dims: - n-1 - ld: :type: real :intent: input :dims: - n-1 - clstrt: :type: integer :intent: input - clend: :type: integer :intent: input - w: :type: real :intent: input :dims: - clend-clstrt+1 - wgap: :type: real :intent: input/output :dims: - clend-clstrt+1 - werr: :type: real :intent: input :dims: - clend-clstrt+1 - spdiam: :type: real :intent: input - clgapl: :type: real :intent: input - clgapr: :type: real :intent: input - pivmin: :type: real :intent: input - sigma: :type: real :intent: output - dplus: :type: real :intent: output :dims: - n - lplus: :type: real :intent: output :dims: - n-1 - work: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLARRF( N, D, L, LD, CLSTRT, CLEND, W, WGAP, WERR, SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA, DPLUS, LPLUS, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Given the initial representation L D L^T and its cluster of close\n\ * eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ...\n\ * W( CLEND ), SLARRF finds a new relatively robust representation\n\ * L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the\n\ * eigenvalues of L(+) D(+) L(+)^T is relatively isolated.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix (subblock, if the matrix split).\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The N diagonal elements of the diagonal matrix D.\n\ *\n\ * L (input) REAL array, dimension (N-1)\n\ * The (N-1) subdiagonal elements of the unit bidiagonal\n\ * matrix L.\n\ *\n\ * LD (input) REAL array, dimension (N-1)\n\ * The (N-1) elements L(i)*D(i).\n\ *\n\ * CLSTRT (input) INTEGER\n\ * The index of the first eigenvalue in the cluster.\n\ *\n\ * CLEND (input) INTEGER\n\ * The index of the last eigenvalue in the cluster.\n\ *\n\ * W (input) REAL array, dimension\n\ * dimension is >= (CLEND-CLSTRT+1)\n\ * The eigenvalue APPROXIMATIONS of L D L^T in ascending order.\n\ * W( CLSTRT ) through W( CLEND ) form the cluster of relatively\n\ * close eigenalues.\n\ *\n\ * WGAP (input/output) REAL array, dimension\n\ * dimension is >= (CLEND-CLSTRT+1)\n\ * The separation from the right neighbor eigenvalue in W.\n\ *\n\ * WERR (input) REAL array, dimension\n\ * dimension is >= (CLEND-CLSTRT+1)\n\ * WERR contain the semiwidth of the uncertainty\n\ * interval of the corresponding eigenvalue APPROXIMATION in W\n\ *\n\ * SPDIAM (input) REAL\n\ * estimate of the spectral diameter obtained from the\n\ * Gerschgorin intervals\n\ *\n\ * CLGAPL (input) REAL\n\ *\n\ * CLGAPR (input) REAL\n\ * absolute gap on each end of the cluster.\n\ * Set by the calling routine to protect against shifts too close\n\ * to eigenvalues outside the cluster.\n\ *\n\ * PIVMIN (input) REAL\n\ * The minimum pivot allowed in the Sturm sequence.\n\ *\n\ * SIGMA (output) REAL \n\ * The shift used to form L(+) D(+) L(+)^T.\n\ *\n\ * DPLUS (output) REAL array, dimension (N)\n\ * The N diagonal elements of the diagonal matrix D(+).\n\ *\n\ * LPLUS (output) REAL array, dimension (N-1)\n\ * The first (N-1) elements of LPLUS contain the subdiagonal\n\ * elements of the unit bidiagonal matrix L(+).\n\ *\n\ * WORK (workspace) REAL array, dimension (2*N)\n\ * Workspace.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Beresford Parlett, University of California, Berkeley, USA\n\ * Jim Demmel, University of California, Berkeley, USA\n\ * Inderjit Dhillon, University of Texas, Austin, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, University of California, Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlacp20000644000175000017500000000423612502223526016410 0ustar uwabamiuwabami--- :name: zlacp2 :md5sum: 4c1a1c73163c0973ae7dd46cbc5aaa20 :category: :subroutine :arguments: - uplo: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: output :dims: - ldb - n - ldb: :type: integer :intent: input :substitutions: ldb: MAX(1,m) :fortran_help: " SUBROUTINE ZLACP2( UPLO, M, N, A, LDA, B, LDB )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLACP2 copies all or part of a real two-dimensional matrix A to a\n\ * complex matrix B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies the part of the matrix A to be copied to B.\n\ * = 'U': Upper triangular part\n\ * = 'L': Lower triangular part\n\ * Otherwise: All of the matrix A\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) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The m by n matrix A. If UPLO = 'U', only the upper trapezium\n\ * is accessed; if UPLO = 'L', only the lower trapezium is\n\ * accessed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (output) COMPLEX*16 array, dimension (LDB,N)\n\ * On exit, B = A in the locations specified by UPLO.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,M).\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sgelsd0000644000175000017500000001602312502223526016473 0ustar uwabamiuwabami--- :name: sgelsd :md5sum: d79751f910a02ca7f84d323a4de8dfe0 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - s: :type: real :intent: output :dims: - MIN(m,n) - rcond: :type: real :intent: input - rank: :type: integer :intent: output - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "m>=n ? 12*n + 2*n*smlsiz + 8*n*nlvl + n*nrhs + (smlsiz+1)*(smlsiz+1) : 12*m + 2*m*smlsiz + 8*m*nlvl + m*nrhs + (smlsiz+1)*(smlsiz+1)" - iwork: :type: integer :intent: workspace :dims: - MAX(1,liwork) - info: :type: integer :intent: output :substitutions: m: lda ldb: MAX(m,n) c__9: "9" c__0: "0" liwork: 3*(MIN(m,n))*nlvl+11*(MIN(m,n)) nlvl: MAX(0,((int)(log(((double)(MIN(m,n)))/(smlsiz+1))/log(2.0))+1)) smlsiz: ilaenv_(&c__9,"SGELSD"," ",&c__0,&c__0,&c__0,&c__0) :fortran_help: " SUBROUTINE SGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGELSD computes the minimum-norm solution to a real linear least\n\ * squares problem:\n\ * minimize 2-norm(| b - A*x |)\n\ * using the singular value decomposition (SVD) of A. A is an M-by-N\n\ * matrix which may be rank-deficient.\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\ * The problem is solved in three steps:\n\ * (1) Reduce the coefficient matrix A to bidiagonal form with\n\ * Householder transformations, reducing the original problem\n\ * into a \"bidiagonal least squares problem\" (BLS)\n\ * (2) Solve the BLS using a divide and conquer approach.\n\ * (3) Apply back all the Householder tranformations to solve\n\ * the original least squares problem.\n\ *\n\ * The effective rank of A is determined by treating as zero those\n\ * singular values which are less than RCOND times the largest singular\n\ * value.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of A. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, A has been destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the M-by-NRHS right hand side matrix B.\n\ * On exit, B is overwritten by the N-by-NRHS solution\n\ * matrix X. If m >= n and RANK = n, the residual\n\ * sum-of-squares for the solution in the i-th column is given\n\ * by the sum of squares of elements n+1:m in that column.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,max(M,N)).\n\ *\n\ * S (output) REAL array, dimension (min(M,N))\n\ * The singular values of A in decreasing order.\n\ * The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n\ *\n\ * RCOND (input) REAL\n\ * RCOND is used to determine the effective rank of A.\n\ * Singular values S(i) <= RCOND*S(1) are treated as zero.\n\ * If RCOND < 0, machine precision is used instead.\n\ *\n\ * RANK (output) INTEGER\n\ * The effective rank of A, i.e., the number of singular values\n\ * which are greater than RCOND*S(1).\n\ *\n\ * WORK (workspace/output) REAL 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 must be at least 1.\n\ * The exact minimum amount of workspace needed depends on M,\n\ * N and NRHS. As long as LWORK is at least\n\ * 12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2,\n\ * if M is greater than or equal to N or\n\ * 12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2,\n\ * if M is less than N, the code will execute correctly.\n\ * SMLSIZ is returned by ILAENV and is equal to the maximum\n\ * size of the subproblems at the bottom of the computation\n\ * tree (usually about 25), and\n\ * NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )\n\ * For good performance, LWORK should generally be larger.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the optimal size of the array WORK and the\n\ * minimum size of the array IWORK, and returns these values as\n\ * the first entries of the WORK and IWORK arrays, and no error\n\ * message related to LWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))\n\ * LIWORK >= max(1, 3*MINMN*NLVL + 11*MINMN),\n\ * where MINMN = MIN( M,N ).\n\ * On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * > 0: the algorithm for computing the SVD failed to converge;\n\ * if INFO = i, i off-diagonal elements of an intermediate\n\ * bidiagonal form did not converge to zero.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ming Gu and Ren-Cang Li, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlags20000644000175000017500000000652412502223526016421 0ustar uwabamiuwabami--- :name: zlags2 :md5sum: 3e5b9ee0cacaa512ab8a822358e62805 :category: :subroutine :arguments: - upper: :type: logical :intent: input - a1: :type: doublereal :intent: input - a2: :type: doublecomplex :intent: input - a3: :type: doublereal :intent: input - b1: :type: doublereal :intent: input - b2: :type: doublecomplex :intent: input - b3: :type: doublereal :intent: input - csu: :type: doublereal :intent: output - snu: :type: doublecomplex :intent: output - csv: :type: doublereal :intent: output - snv: :type: doublecomplex :intent: output - csq: :type: doublereal :intent: output - snq: :type: doublecomplex :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, SNV, CSQ, SNQ )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAGS2 computes 2-by-2 unitary matrices U, V and Q, such\n\ * that if ( UPPER ) then\n\ *\n\ * U'*A*Q = U'*( A1 A2 )*Q = ( x 0 )\n\ * ( 0 A3 ) ( x x )\n\ * and\n\ * V'*B*Q = V'*( B1 B2 )*Q = ( x 0 )\n\ * ( 0 B3 ) ( x x )\n\ *\n\ * or if ( .NOT.UPPER ) then\n\ *\n\ * U'*A*Q = U'*( A1 0 )*Q = ( x x )\n\ * ( A2 A3 ) ( 0 x )\n\ * and\n\ * V'*B*Q = V'*( B1 0 )*Q = ( x x )\n\ * ( B2 B3 ) ( 0 x )\n\ * where\n\ *\n\ * U = ( CSU SNU ), V = ( CSV SNV ),\n\ * ( -CONJG(SNU) CSU ) ( -CONJG(SNV) CSV )\n\ *\n\ * Q = ( CSQ SNQ )\n\ * ( -CONJG(SNQ) CSQ )\n\ *\n\ * Z' denotes the conjugate transpose of Z.\n\ *\n\ * The rows of the transformed A and B are parallel. Moreover, if the\n\ * input 2-by-2 matrix A is not zero, then the transformed (1,1) entry\n\ * of A is not zero. If the input matrices A and B are both not zero,\n\ * then the transformed (2,2) element of B is not zero, except when the\n\ * first rows of input A and B are parallel and the second rows are\n\ * zero.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPPER (input) LOGICAL\n\ * = .TRUE.: the input matrices A and B are upper triangular.\n\ * = .FALSE.: the input matrices A and B are lower triangular.\n\ *\n\ * A1 (input) DOUBLE PRECISION\n\ * A2 (input) COMPLEX*16\n\ * A3 (input) DOUBLE PRECISION\n\ * On entry, A1, A2 and A3 are elements of the input 2-by-2\n\ * upper (lower) triangular matrix A.\n\ *\n\ * B1 (input) DOUBLE PRECISION\n\ * B2 (input) COMPLEX*16\n\ * B3 (input) DOUBLE PRECISION\n\ * On entry, B1, B2 and B3 are elements of the input 2-by-2\n\ * upper (lower) triangular matrix B.\n\ *\n\ * CSU (output) DOUBLE PRECISION\n\ * SNU (output) COMPLEX*16\n\ * The desired unitary matrix U.\n\ *\n\ * CSV (output) DOUBLE PRECISION\n\ * SNV (output) COMPLEX*16\n\ * The desired unitary matrix V.\n\ *\n\ * CSQ (output) DOUBLE PRECISION\n\ * SNQ (output) COMPLEX*16\n\ * The desired unitary matrix Q.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgegs0000644000175000017500000001647612502223526016317 0ustar uwabamiuwabami--- :name: dgegs :md5sum: c49c4cd3c8469332e43b4d911700e384 :category: :subroutine :arguments: - jobvsl: :type: char :intent: input - jobvsr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alphar: :type: doublereal :intent: output :dims: - n - alphai: :type: doublereal :intent: output :dims: - n - beta: :type: doublereal :intent: output :dims: - n - vsl: :type: doublereal :intent: output :dims: - ldvsl - n - ldvsl: :type: integer :intent: input - vsr: :type: doublereal :intent: output :dims: - ldvsr - n - ldvsr: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 4*n - info: :type: integer :intent: output :substitutions: ldvsl: "lsame_(&jobvsl,\"V\") ? n : 1" ldvsr: "lsame_(&jobvsr,\"V\") ? n : 1" :fortran_help: " SUBROUTINE DGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This routine is deprecated and has been replaced by routine DGGES.\n\ *\n\ * DGEGS computes the eigenvalues, real Schur form, and, optionally,\n\ * left and or/right Schur vectors of a real matrix pair (A,B).\n\ * Given two square matrices A and B, the generalized real Schur\n\ * factorization has the form\n\ *\n\ * A = Q*S*Z**T, B = Q*T*Z**T\n\ *\n\ * where Q and Z are orthogonal matrices, T is upper triangular, and S\n\ * is an upper quasi-triangular matrix with 1-by-1 and 2-by-2 diagonal\n\ * blocks, the 2-by-2 blocks corresponding to complex conjugate pairs\n\ * of eigenvalues of (A,B). The columns of Q are the left Schur vectors\n\ * and the columns of Z are the right Schur vectors.\n\ *\n\ * If only the eigenvalues of (A,B) are needed, the driver routine\n\ * DGEGV should be used instead. See DGEGV for a description of the\n\ * eigenvalues of the generalized nonsymmetric eigenvalue problem\n\ * (GNEP).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVSL (input) CHARACTER*1\n\ * = 'N': do not compute the left Schur vectors;\n\ * = 'V': compute the left Schur vectors (returned in VSL).\n\ *\n\ * JOBVSR (input) CHARACTER*1\n\ * = 'N': do not compute the right Schur vectors;\n\ * = 'V': compute the right Schur vectors (returned in VSR).\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A, B, VSL, and VSR. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n\ * On entry, the matrix A.\n\ * On exit, the upper quasi-triangular matrix S from the\n\ * generalized real Schur factorization.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of A. LDA >= max(1,N).\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n\ * On entry, the matrix B.\n\ * On exit, the upper triangular matrix T from the generalized\n\ * real Schur factorization.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B. LDB >= max(1,N).\n\ *\n\ * ALPHAR (output) DOUBLE PRECISION array, dimension (N)\n\ * The real parts of each scalar alpha defining an eigenvalue\n\ * of GNEP.\n\ *\n\ * ALPHAI (output) DOUBLE PRECISION array, dimension (N)\n\ * The imaginary parts of each scalar alpha defining an\n\ * eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th\n\ * eigenvalue is real; if positive, then the j-th and (j+1)-st\n\ * eigenvalues are a complex conjugate pair, with\n\ * ALPHAI(j+1) = -ALPHAI(j).\n\ *\n\ * BETA (output) DOUBLE PRECISION array, dimension (N)\n\ * The scalars beta that define the eigenvalues of GNEP.\n\ * Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and\n\ * beta = BETA(j) represent the j-th eigenvalue of the matrix\n\ * pair (A,B), in one of the forms lambda = alpha/beta or\n\ * mu = beta/alpha. Since either lambda or mu may overflow,\n\ * they should not, in general, be computed.\n\ *\n\ * VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N)\n\ * If JOBVSL = 'V', the matrix of left Schur vectors Q.\n\ * Not referenced if JOBVSL = 'N'.\n\ *\n\ * LDVSL (input) INTEGER\n\ * The leading dimension of the matrix VSL. LDVSL >=1, and\n\ * if JOBVSL = 'V', LDVSL >= N.\n\ *\n\ * VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N)\n\ * If JOBVSR = 'V', the matrix of right Schur vectors Z.\n\ * Not referenced if JOBVSR = 'N'.\n\ *\n\ * LDVSR (input) INTEGER\n\ * The leading dimension of the matrix VSR. LDVSR >= 1, and\n\ * if JOBVSR = 'V', LDVSR >= 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. LWORK >= max(1,4*N).\n\ * For good performance, LWORK must generally be larger.\n\ * To compute the optimal value of LWORK, call ILAENV to get\n\ * blocksizes (for DGEQRF, DORMQR, and DORGQR.) Then compute:\n\ * NB -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR\n\ * The optimal LWORK is 2*N + N*(NB+1).\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\ * = 1,...,N:\n\ * The QZ iteration failed. (A,B) are not in Schur\n\ * form, but ALPHAR(j), ALPHAI(j), and BETA(j) should\n\ * be correct for j=INFO+1,...,N.\n\ * > N: errors that usually indicate LAPACK problems:\n\ * =N+1: error return from DGGBAL\n\ * =N+2: error return from DGEQRF\n\ * =N+3: error return from DORMQR\n\ * =N+4: error return from DORGQR\n\ * =N+5: error return from DGGHRD\n\ * =N+6: error return from DHGEQZ (other than failed\n\ * iteration)\n\ * =N+7: error return from DGGBAK (computing VSL)\n\ * =N+8: error return from DGGBAK (computing VSR)\n\ * =N+9: error return from DLASCL (various places)\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sla_gbrcond0000644000175000017500000001110612502223526017464 0ustar uwabamiuwabami--- :name: sla_gbrcond :md5sum: ff5d11e89ee27a58b83e3bf9843a8a8c :category: :function :type: real :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: real :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - cmode: :type: integer :intent: input - c: :type: real :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: real :intent: input :dims: - 5*n - iwork: :type: integer :intent: input :dims: - n :substitutions: {} :fortran_help: " REAL FUNCTION SLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, AFB, LDAFB, IPIV, CMODE, C, INFO, WORK, IWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLA_GBRCOND Estimates the Skeel condition number of op(A) * op2(C)\n\ * where op2 is determined by CMODE as follows\n\ * CMODE = 1 op2(C) = C\n\ * CMODE = 0 op2(C) = I\n\ * CMODE = -1 op2(C) = inv(C)\n\ * The Skeel condition number cond(A) = norminf( |inv(A)||A| )\n\ * is computed by computing scaling factors R such that\n\ * diag(R)*A*op2(C) is row equilibrated and computing the standard\n\ * infinity-norm condition number.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate Transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * AB (input) REAL array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * AFB (input) REAL array, dimension (LDAFB,N)\n\ * Details of the LU factorization of the band matrix A, as\n\ * computed by SGBTRF. U is stored as an upper triangular\n\ * band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n\ * and the multipliers used during the factorization are stored\n\ * in rows KL+KU+2 to 2*KL+KU+1.\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from the factorization A = P*L*U\n\ * as computed by SGBTRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * CMODE (input) INTEGER\n\ * Determines op2(C) in the formula op(A) * op2(C) as follows:\n\ * CMODE = 1 op2(C) = C\n\ * CMODE = 0 op2(C) = I\n\ * CMODE = -1 op2(C) = inv(C)\n\ *\n\ * C (input) REAL array, dimension (N)\n\ * The vector C in the formula op(A) * op2(C).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * i > 0: The ith argument is invalid.\n\ *\n\ * WORK (input) REAL array, dimension (5*N).\n\ * Workspace.\n\ *\n\ * IWORK (input) INTEGER array, dimension (N).\n\ * Workspace.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE, I, J, KD, KE\n REAL AINVNM, TMP\n\ * ..\n\ * .. Local Arrays ..\n INTEGER ISAVE( 3 )\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SLACN2, SGBTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlasdt0000644000175000017500000000364112502223526016467 0ustar uwabamiuwabami--- :name: dlasdt :md5sum: c087d4c2a38cb314111522d50756d606 :category: :subroutine :arguments: - n: :type: integer :intent: input - lvl: :type: integer :intent: output - nd: :type: integer :intent: output - inode: :type: integer :intent: output :dims: - MAX(1,n) - ndiml: :type: integer :intent: output :dims: - MAX(1,n) - ndimr: :type: integer :intent: output :dims: - MAX(1,n) - msub: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE DLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLASDT creates a tree of subproblems for bidiagonal divide and\n\ * conquer.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * On entry, the number of diagonal elements of the\n\ * bidiagonal matrix.\n\ *\n\ * LVL (output) INTEGER\n\ * On exit, the number of levels on the computation tree.\n\ *\n\ * ND (output) INTEGER\n\ * On exit, the number of nodes on the tree.\n\ *\n\ * INODE (output) INTEGER array, dimension ( N )\n\ * On exit, centers of subproblems.\n\ *\n\ * NDIML (output) INTEGER array, dimension ( N )\n\ * On exit, row dimensions of left children.\n\ *\n\ * NDIMR (output) INTEGER array, dimension ( N )\n\ * On exit, row dimensions of right children.\n\ *\n\ * MSUB (input) INTEGER\n\ * On entry, the maximum row dimension each subproblem at the\n\ * bottom of the tree can be of.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ming Gu and Huan Ren, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/iparmq0000644000175000017500000001760412502223526016511 0ustar uwabamiuwabami--- :name: iparmq :md5sum: 73ec37559601ded71e0b8df251efd10e :category: :function :type: integer :arguments: - ispec: :type: integer :intent: input - name: :type: char :intent: input - opts: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - lwork: :type: integer :intent: input :substitutions: {} :fortran_help: " INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This program sets problem and machine dependent parameters\n\ * useful for xHSEQR and its subroutines. It is called whenever \n\ * ILAENV is called with 12 <= ISPEC <= 16\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ISPEC (input) integer scalar\n\ * ISPEC specifies which tunable parameter IPARMQ should\n\ * return.\n\ *\n\ * ISPEC=12: (INMIN) Matrices of order nmin or less\n\ * are sent directly to xLAHQR, the implicit\n\ * double shift QR algorithm. NMIN must be\n\ * at least 11.\n\ *\n\ * ISPEC=13: (INWIN) Size of the deflation window.\n\ * This is best set greater than or equal to\n\ * the number of simultaneous shifts NS.\n\ * Larger matrices benefit from larger deflation\n\ * windows.\n\ *\n\ * ISPEC=14: (INIBL) Determines when to stop nibbling and\n\ * invest in an (expensive) multi-shift QR sweep.\n\ * If the aggressive early deflation subroutine\n\ * finds LD converged eigenvalues from an order\n\ * NW deflation window and LD.GT.(NW*NIBBLE)/100,\n\ * then the next QR sweep is skipped and early\n\ * deflation is applied immediately to the\n\ * remaining active diagonal block. Setting\n\ * IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a\n\ * multi-shift QR sweep whenever early deflation\n\ * finds a converged eigenvalue. Setting\n\ * IPARMQ(ISPEC=14) greater than or equal to 100\n\ * prevents TTQRE from skipping a multi-shift\n\ * QR sweep.\n\ *\n\ * ISPEC=15: (NSHFTS) The number of simultaneous shifts in\n\ * a multi-shift QR iteration.\n\ *\n\ * ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the\n\ * following meanings.\n\ * 0: During the multi-shift QR sweep,\n\ * xLAQR5 does not accumulate reflections and\n\ * does not use matrix-matrix multiply to\n\ * update the far-from-diagonal matrix\n\ * entries.\n\ * 1: During the multi-shift QR sweep,\n\ * xLAQR5 and/or xLAQRaccumulates reflections and uses\n\ * matrix-matrix multiply to update the\n\ * far-from-diagonal matrix entries.\n\ * 2: During the multi-shift QR sweep.\n\ * xLAQR5 accumulates reflections and takes\n\ * advantage of 2-by-2 block structure during\n\ * matrix-matrix multiplies.\n\ * (If xTRMM is slower than xGEMM, then\n\ * IPARMQ(ISPEC=16)=1 may be more efficient than\n\ * IPARMQ(ISPEC=16)=2 despite the greater level of\n\ * arithmetic work implied by the latter choice.)\n\ *\n\ * NAME (input) character string\n\ * Name of the calling subroutine\n\ *\n\ * OPTS (input) character string\n\ * This is a concatenation of the string arguments to\n\ * TTQRE.\n\ *\n\ * N (input) integer scalar\n\ * N is the order of the Hessenberg matrix H.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * It is assumed that H is already upper triangular\n\ * in rows and columns 1:ILO-1 and IHI+1:N.\n\ *\n\ * LWORK (input) integer scalar\n\ * The amount of workspace available.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Little is known about how best to choose these parameters.\n\ * It is possible to use different values of the parameters\n\ * for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR.\n\ *\n\ * It is probably best to choose different parameters for\n\ * different matrices and different parameters at different\n\ * times during the iteration, but this has not been\n\ * implemented --- yet.\n\ *\n\ *\n\ * The best choices of most of the parameters depend\n\ * in an ill-understood way on the relative execution\n\ * rate of xLAQR3 and xLAQR5 and on the nature of each\n\ * particular eigenvalue problem. Experiment may be the\n\ * only practical way to determine which choices are most\n\ * effective.\n\ *\n\ * Following is a list of default values supplied by IPARMQ.\n\ * These defaults may be adjusted in order to attain better\n\ * performance in any particular computational environment.\n\ *\n\ * IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point.\n\ * Default: 75. (Must be at least 11.)\n\ *\n\ * IPARMQ(ISPEC=13) Recommended deflation window size.\n\ * This depends on ILO, IHI and NS, the\n\ * number of simultaneous shifts returned\n\ * by IPARMQ(ISPEC=15). The default for\n\ * (IHI-ILO+1).LE.500 is NS. The default\n\ * for (IHI-ILO+1).GT.500 is 3*NS/2.\n\ *\n\ * IPARMQ(ISPEC=14) Nibble crossover point. Default: 14.\n\ *\n\ * IPARMQ(ISPEC=15) Number of simultaneous shifts, NS.\n\ * a multi-shift QR iteration.\n\ *\n\ * If IHI-ILO+1 is ...\n\ *\n\ * greater than ...but less ... the\n\ * or equal to ... than default is\n\ *\n\ * 0 30 NS = 2+\n\ * 30 60 NS = 4+\n\ * 60 150 NS = 10\n\ * 150 590 NS = **\n\ * 590 3000 NS = 64\n\ * 3000 6000 NS = 128\n\ * 6000 infinity NS = 256\n\ *\n\ * (+) By default matrices of this order are\n\ * passed to the implicit double shift routine\n\ * xLAHQR. See IPARMQ(ISPEC=12) above. These\n\ * values of NS are used only in case of a rare\n\ * xLAHQR failure.\n\ *\n\ * (**) The asterisks (**) indicate an ad-hoc\n\ * function increasing from 10 to 64.\n\ *\n\ * IPARMQ(ISPEC=16) Select structured matrix multiply.\n\ * (See ISPEC=16 above for details.)\n\ * Default: 3.\n\ *\n\ * ================================================================\n" ruby-lapack-1.7.2/dev/defs/dlaed20000644000175000017500000001465312502223526016354 0ustar uwabamiuwabami--- :name: dlaed2 :md5sum: d8f308f281405229efe4f87a4a67b923 :category: :subroutine :arguments: - k: :type: integer :intent: output - n: :type: integer :intent: input - n1: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - q: :type: doublereal :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - indxq: :type: integer :intent: input/output :dims: - n - rho: :type: doublereal :intent: input/output - z: :type: doublereal :intent: input :dims: - n - dlamda: :type: doublereal :intent: output :dims: - n - w: :type: doublereal :intent: output :dims: - n - q2: :type: doublereal :intent: output :dims: - pow(n1,2)+pow(n-n1,2) - indx: :type: integer :intent: workspace :dims: - n - indxc: :type: integer :intent: output :dims: - n - indxp: :type: integer :intent: workspace :dims: - n - coltyp: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, Q2, INDX, INDXC, INDXP, COLTYP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAED2 merges the two sets of eigenvalues together into a single\n\ * sorted set. Then it tries to deflate the size of the problem.\n\ * There are two ways in which deflation can occur: when two or more\n\ * eigenvalues are close together or if there is a tiny entry in the\n\ * Z vector. For each such occurrence the order of the related secular\n\ * equation problem is reduced by one.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * K (output) INTEGER\n\ * The number of non-deflated eigenvalues, and the order of the\n\ * related secular equation. 0 <= K <=N.\n\ *\n\ * N (input) INTEGER\n\ * The dimension of the symmetric tridiagonal matrix. N >= 0.\n\ *\n\ * N1 (input) INTEGER\n\ * The location of the last eigenvalue in the leading sub-matrix.\n\ * min(1,N) <= N1 <= N/2.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, D contains the eigenvalues of the two submatrices to\n\ * be combined.\n\ * On exit, D contains the trailing (N-K) updated eigenvalues\n\ * (those which were deflated) sorted into increasing order.\n\ *\n\ * Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)\n\ * On entry, Q contains the eigenvectors of two submatrices in\n\ * the two square blocks with corners at (1,1), (N1,N1)\n\ * and (N1+1, N1+1), (N,N).\n\ * On exit, Q contains the trailing (N-K) updated eigenvectors\n\ * (those which were deflated) in its last N-K columns.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N).\n\ *\n\ * INDXQ (input/output) INTEGER array, dimension (N)\n\ * The permutation which separately sorts the two sub-problems\n\ * in D into ascending order. Note that elements in the second\n\ * half of this permutation must first have N1 added to their\n\ * values. Destroyed on exit.\n\ *\n\ * RHO (input/output) DOUBLE PRECISION\n\ * On entry, the off-diagonal element associated with the rank-1\n\ * cut which originally split the two submatrices which are now\n\ * being recombined.\n\ * On exit, RHO has been modified to the value required by\n\ * DLAED3.\n\ *\n\ * Z (input) DOUBLE PRECISION array, dimension (N)\n\ * On entry, Z contains the updating vector (the last\n\ * row of the first sub-eigenvector matrix and the first row of\n\ * the second sub-eigenvector matrix).\n\ * On exit, the contents of Z have been destroyed by the updating\n\ * process.\n\ *\n\ * DLAMDA (output) DOUBLE PRECISION array, dimension (N)\n\ * A copy of the first K eigenvalues which will be used by\n\ * DLAED3 to form the secular equation.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * The first k values of the final deflation-altered z-vector\n\ * which will be passed to DLAED3.\n\ *\n\ * Q2 (output) DOUBLE PRECISION array, dimension (N1**2+(N-N1)**2)\n\ * A copy of the first K eigenvectors which will be used by\n\ * DLAED3 in a matrix multiply (DGEMM) to solve for the new\n\ * eigenvectors.\n\ *\n\ * INDX (workspace) INTEGER array, dimension (N)\n\ * The permutation used to sort the contents of DLAMDA into\n\ * ascending order.\n\ *\n\ * INDXC (output) INTEGER array, dimension (N)\n\ * The permutation used to arrange the columns of the deflated\n\ * Q matrix into three groups: the first group contains non-zero\n\ * elements only at and above N1, the second contains\n\ * non-zero elements only below N1, and the third is dense.\n\ *\n\ * INDXP (workspace) INTEGER array, dimension (N)\n\ * The permutation used to place deflated values of D at the end\n\ * of the array. INDXP(1:K) points to the nondeflated D-values\n\ * and INDXP(K+1:N) points to the deflated eigenvalues.\n\ *\n\ * COLTYP (workspace/output) INTEGER array, dimension (N)\n\ * During execution, a label which will indicate which of the\n\ * following types a column in the Q2 matrix is:\n\ * 1 : non-zero in the upper half only;\n\ * 2 : dense;\n\ * 3 : non-zero in the lower half only;\n\ * 4 : deflated.\n\ * On exit, COLTYP(i) is the number of columns of type i,\n\ * for i=1 to 4 only.\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\ * Based on contributions by\n\ * Jeff Rutter, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ * Modified by Francoise Tisseur, University of Tennessee.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgebrd0000644000175000017500000001457212502223526016476 0ustar uwabamiuwabami--- :name: zgebrd :md5sum: faeeaf701bfb70e79e0723c0b655fa1a :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - MIN(m,n) - e: :type: doublereal :intent: output :dims: - MIN(m,n)-1 - tauq: :type: doublecomplex :intent: output :dims: - MIN(m,n) - taup: :type: doublecomplex :intent: output :dims: - MIN(m,n) - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGEBRD reduces a general complex M-by-N matrix A to upper or lower\n\ * bidiagonal form B by a unitary transformation: Q**H * A * P = B.\n\ *\n\ * If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows in the matrix A. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns in the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the M-by-N general matrix to be reduced.\n\ * On exit,\n\ * if m >= n, the diagonal and the first superdiagonal are\n\ * overwritten with the upper bidiagonal matrix B; the\n\ * elements below the diagonal, with the array TAUQ, represent\n\ * the unitary matrix Q as a product of elementary\n\ * reflectors, and the elements above the first superdiagonal,\n\ * with the array TAUP, represent the unitary matrix P as\n\ * a product of elementary reflectors;\n\ * if m < n, the diagonal and the first subdiagonal are\n\ * overwritten with the lower bidiagonal matrix B; the\n\ * elements below the first subdiagonal, with the array TAUQ,\n\ * represent the unitary matrix Q as a product of\n\ * elementary reflectors, and the elements above the diagonal,\n\ * with the array TAUP, represent the unitary matrix P as\n\ * a product of elementary reflectors.\n\ * See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * D (output) DOUBLE PRECISION array, dimension (min(M,N))\n\ * The diagonal elements of the bidiagonal matrix B:\n\ * D(i) = A(i,i).\n\ *\n\ * E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)\n\ * The off-diagonal elements of the bidiagonal matrix B:\n\ * if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n\ * if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n\ *\n\ * TAUQ (output) COMPLEX*16 array dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the unitary matrix Q. See Further Details.\n\ *\n\ * TAUP (output) COMPLEX*16 array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the unitary matrix P. See Further Details.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of the array WORK. LWORK >= max(1,M,N).\n\ * For optimum performance LWORK >= (M+N)*NB, where NB\n\ * is the 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 matrices Q and P are represented as products of elementary\n\ * reflectors:\n\ *\n\ * If m >= n,\n\ *\n\ * Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)\n\ *\n\ * Each H(i) and G(i) has the form:\n\ *\n\ * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n\ *\n\ * where tauq and taup are complex scalars, and v and u are complex\n\ * vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in\n\ * A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in\n\ * A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n\ *\n\ * If m < n,\n\ *\n\ * Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)\n\ *\n\ * Each H(i) and G(i) has the form:\n\ *\n\ * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n\ *\n\ * where tauq and taup are complex scalars, and v and u are complex\n\ * vectors; v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in\n\ * A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in\n\ * A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n\ *\n\ * The contents of A on exit are illustrated by the following examples:\n\ *\n\ * m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n\ *\n\ * ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )\n\ * ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )\n\ * ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )\n\ * ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )\n\ * ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )\n\ * ( v1 v2 v3 v4 v5 )\n\ *\n\ * where d and e denote diagonal and off-diagonal elements of B, vi\n\ * denotes an element of the vector defining H(i), and ui an element of\n\ * the vector defining G(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/csptrs0000644000175000017500000000464512502223525016536 0ustar uwabamiuwabami--- :name: csptrs :md5sum: f8b60d66389c0af1a3e55795b48dcc6f :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSPTRS solves a system of linear equations A*X = B with a complex\n\ * symmetric matrix A stored in packed format using the factorization\n\ * A = U*D*U**T or A = L*D*L**T computed by CSPTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AP (input) COMPLEX array, dimension (N*(N+1)/2)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by CSPTRF, stored as a\n\ * packed triangular matrix.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by CSPTRF.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cggbak0000644000175000017500000000736312502223525016436 0ustar uwabamiuwabami--- :name: cggbak :md5sum: 28692fd5b96d1bf97c9bbba05c793325 :category: :subroutine :arguments: - job: :type: char :intent: input - side: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - lscale: :type: real :intent: input :dims: - n - rscale: :type: real :intent: input :dims: - n - m: :type: integer :intent: input - v: :type: complex :intent: input/output :dims: - ldv - m - ldv: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGGBAK forms the right or left eigenvectors of a complex generalized\n\ * eigenvalue problem A*x = lambda*B*x, by backward transformation on\n\ * the computed eigenvectors of the balanced pair of matrices output by\n\ * CGGBAL.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * Specifies the type of backward transformation required:\n\ * = 'N': do nothing, return immediately;\n\ * = 'P': do backward transformation for permutation only;\n\ * = 'S': do backward transformation for scaling only;\n\ * = 'B': do backward transformations for both permutation and\n\ * scaling.\n\ * JOB must be the same as the argument JOB supplied to CGGBAL.\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'R': V contains right eigenvectors;\n\ * = 'L': V contains left eigenvectors.\n\ *\n\ * N (input) INTEGER\n\ * The number of rows of the matrix V. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * The integers ILO and IHI determined by CGGBAL.\n\ * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n\ *\n\ * LSCALE (input) REAL array, dimension (N)\n\ * Details of the permutations and/or scaling factors applied\n\ * to the left side of A and B, as returned by CGGBAL.\n\ *\n\ * RSCALE (input) REAL array, dimension (N)\n\ * Details of the permutations and/or scaling factors applied\n\ * to the right side of A and B, as returned by CGGBAL.\n\ *\n\ * M (input) INTEGER\n\ * The number of columns of the matrix V. M >= 0.\n\ *\n\ * V (input/output) COMPLEX array, dimension (LDV,M)\n\ * On entry, the matrix of right or left eigenvectors to be\n\ * transformed, as returned by CTGEVC.\n\ * On exit, V is overwritten by the transformed eigenvectors.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the matrix V. LDV >= max(1,N).\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\ * See R.C. Ward, Balancing the generalized eigenvalue problem,\n\ * SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LEFTV, RIGHTV\n INTEGER I, K\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CSSCAL, CSWAP, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/stzrzf0000644000175000017500000001014712502223526016555 0ustar uwabamiuwabami--- :name: stzrzf :md5sum: 23ccaffcdd27808e21475d8e506f3e5d :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - m - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE STZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STZRZF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A\n\ * to upper triangular form by means of orthogonal transformations.\n\ *\n\ * The upper trapezoidal matrix A is factored as\n\ *\n\ * A = ( R 0 ) * Z,\n\ *\n\ * where Z is an N-by-N orthogonal matrix and R is an M-by-M upper\n\ * triangular matrix.\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 >= M.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the leading M-by-N upper trapezoidal part of the\n\ * array A must contain the matrix to be factorized.\n\ * On exit, the leading M-by-M upper triangular part of A\n\ * contains the upper triangular matrix R, and elements M+1 to\n\ * N of the first M rows of A, with the array TAU, represent the\n\ * orthogonal matrix Z as a product of M elementary reflectors.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (output) REAL array, dimension (M)\n\ * The scalar factors of the elementary reflectors.\n\ *\n\ * WORK (workspace/output) REAL 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\n\ * the 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\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * The factorization is obtained by Householder's method. The kth\n\ * transformation matrix, Z( k ), which is used to introduce zeros into\n\ * the ( m - k + 1 )th row of A, is given in the form\n\ *\n\ * Z( k ) = ( I 0 ),\n\ * ( 0 T( k ) )\n\ *\n\ * where\n\ *\n\ * T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n\ * ( 0 )\n\ * ( z( k ) )\n\ *\n\ * tau is a scalar and z( k ) is an ( n - m ) element vector.\n\ * tau and z( k ) are chosen to annihilate the elements of the kth row\n\ * of X.\n\ *\n\ * The scalar tau is returned in the kth element of TAU and the vector\n\ * u( k ) in the kth row of A, such that the elements of z( k ) are\n\ * in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n\ * the upper triangular part of A.\n\ *\n\ * Z is given by\n\ *\n\ * Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgeqpf0000644000175000017500000000663112502223525016462 0ustar uwabamiuwabami--- :name: cgeqpf :md5sum: 79525820621b8a0f82b1e8ed75e0eceb :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: complex :intent: output :dims: - MIN(m,n) - work: :type: complex :intent: workspace :dims: - n - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This routine is deprecated and has been replaced by routine CGEQP3.\n\ *\n\ * CGEQPF computes a QR factorization with column pivoting of a\n\ * complex M-by-N matrix A: A*P = Q*R.\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) COMPLEX array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, the upper triangle of the array contains the\n\ * min(M,N)-by-N upper triangular matrix R; the elements\n\ * below the diagonal, together with the array TAU,\n\ * represent the unitary matrix Q as a product of\n\ * min(m,n) elementary reflectors.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * JPVT (input/output) INTEGER array, dimension (N)\n\ * On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n\ * to the front of A*P (a leading column); if JPVT(i) = 0,\n\ * the i-th column of A is a free column.\n\ * On exit, if JPVT(i) = k, then the i-th column of A*P\n\ * was the k-th column of A.\n\ *\n\ * TAU (output) COMPLEX array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (2*N)\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(1) H(2) . . . H(n)\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar, and v is a complex vector with\n\ * v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).\n\ *\n\ * The matrix P is represented in jpvt as follows: If\n\ * jpvt(j) = i\n\ * then the jth column of P is the ith canonical unit vector.\n\ *\n\ * Partial column norm updating strategy modified by\n\ * Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n\ * University of Zagreb, Croatia.\n\ * June 2010\n\ * For more details see LAPACK Working Note 176.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cupgtr0000644000175000017500000000444212502223526016520 0ustar uwabamiuwabami--- :name: cupgtr :md5sum: 987966702842f36fc0ef177987253956 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - ldap - tau: :type: complex :intent: input :dims: - ldtau - q: :type: complex :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - n-1 - info: :type: integer :intent: output :substitutions: ldq: MAX(1,n) n: ldtau+1 :fortran_help: " SUBROUTINE CUPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CUPGTR generates a complex unitary matrix Q which is defined as the\n\ * product of n-1 elementary reflectors H(i) of order n, as returned by\n\ * CHPTRD using packed storage:\n\ *\n\ * if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),\n\ *\n\ * if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangular packed storage used in previous\n\ * call to CHPTRD;\n\ * = 'L': Lower triangular packed storage used in previous\n\ * call to CHPTRD.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix Q. N >= 0.\n\ *\n\ * AP (input) COMPLEX array, dimension (N*(N+1)/2)\n\ * The vectors which define the elementary reflectors, as\n\ * returned by CHPTRD.\n\ *\n\ * TAU (input) COMPLEX array, dimension (N-1)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by CHPTRD.\n\ *\n\ * Q (output) COMPLEX array, dimension (LDQ,N)\n\ * The N-by-N unitary matrix Q.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (N-1)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ilaslc0000644000175000017500000000200212502223526016451 0ustar uwabamiuwabami--- :name: ilaslc :md5sum: 98329b8613d7cf648a79d80e5f7526ba :category: :function :type: integer :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " INTEGER FUNCTION ILASLC( M, N, A, LDA )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ILASLC scans A for its last non-zero column.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix A.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * 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\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssptrd0000644000175000017500000000763112502223526016536 0ustar uwabamiuwabami--- :name: ssptrd :md5sum: 055e7259054806f91d37ece62e2b52e5 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - ldap - d: :type: real :intent: output :dims: - n - e: :type: real :intent: output :dims: - n-1 - tau: :type: real :intent: output :dims: - n-1 - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE SSPTRD( UPLO, N, AP, D, E, TAU, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSPTRD reduces a real symmetric matrix A stored in packed form to\n\ * symmetric tridiagonal form T by an orthogonal similarity\n\ * transformation: Q**T * A * Q = T.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) REAL array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ * On exit, if UPLO = 'U', the diagonal and first superdiagonal\n\ * of A are overwritten by the corresponding elements of the\n\ * tridiagonal matrix T, and the elements above the first\n\ * superdiagonal, with the array TAU, represent the orthogonal\n\ * matrix Q as a product of elementary reflectors; if UPLO\n\ * = 'L', the diagonal and first subdiagonal of A are over-\n\ * written by the corresponding elements of the tridiagonal\n\ * matrix T, and the elements below the first subdiagonal, with\n\ * the array TAU, represent the orthogonal matrix Q as a product\n\ * of elementary reflectors. See Further Details.\n\ *\n\ * D (output) REAL array, dimension (N)\n\ * The diagonal elements of the tridiagonal matrix T:\n\ * D(i) = A(i,i).\n\ *\n\ * E (output) REAL array, dimension (N-1)\n\ * The off-diagonal elements of the tridiagonal matrix T:\n\ * E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n\ *\n\ * TAU (output) REAL array, dimension (N-1)\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\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\ * If UPLO = 'U', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(n-1) . . . H(2) H(1).\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(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,\n\ * overwriting A(1:i-1,i+1), and tau is stored in TAU(i).\n\ *\n\ * If UPLO = 'L', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(n-1).\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) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,\n\ * overwriting A(i+2:n,i), and tau is stored in TAU(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dppcon0000644000175000017500000000516412502223526016501 0ustar uwabamiuwabami--- :name: dppcon :md5sum: 3736fd97dc2539bc118db306bfb573fb :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - ldap - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE DPPCON( UPLO, N, AP, ANORM, RCOND, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPPCON estimates the reciprocal of the condition number (in the\n\ * 1-norm) of a real symmetric positive definite packed matrix using\n\ * the Cholesky factorization A = U**T*U or A = L*L**T computed by\n\ * DPPTRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T, packed columnwise in a linear\n\ * array. The j-th column of U or L is stored in the array AP\n\ * as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n\ *\n\ * ANORM (input) DOUBLE PRECISION\n\ * The 1-norm (or infinity-norm) of the symmetric matrix A.\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n\ * estimate of the 1-norm of inv(A) computed in this routine.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chetrs0000644000175000017500000000476612502223525016514 0ustar uwabamiuwabami--- :name: chetrs :md5sum: b88885fcd9819045364766485aed2ea1 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CHETRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHETRS solves a system of linear equations A*X = B with a complex\n\ * Hermitian matrix A using the factorization A = U*D*U**H or\n\ * A = L*D*L**H computed by CHETRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**H;\n\ * = 'L': Lower triangular, form is A = L*D*L**H.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by CHETRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by CHETRF.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sorm2r0000644000175000017500000000721212502223526016436 0ustar uwabamiuwabami--- :name: sorm2r :md5sum: c2847c0b1bf75f9216b6b3f5610d07de :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SORM2R overwrites the general real m by n matrix C with\n\ *\n\ * Q * C if SIDE = 'L' and TRANS = 'N', or\n\ *\n\ * Q'* C if SIDE = 'L' and TRANS = 'T', or\n\ *\n\ * C * Q if SIDE = 'R' and TRANS = 'N', or\n\ *\n\ * C * Q' if SIDE = 'R' and TRANS = 'T',\n\ *\n\ * where Q is a real orthogonal matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by SGEQRF. Q is of order m if SIDE = 'L' and of order n\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q' from the Left\n\ * = 'R': apply Q or Q' from the Right\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': apply Q (No transpose)\n\ * = 'T': apply Q' (Transpose)\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,K)\n\ * The i-th column must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * SGEQRF in the first k columns of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ * If SIDE = 'L', LDA >= max(1,M);\n\ * if SIDE = 'R', LDA >= max(1,N).\n\ *\n\ * TAU (input) REAL array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by SGEQRF.\n\ *\n\ * C (input/output) REAL array, dimension (LDC,N)\n\ * On entry, the m by n matrix C.\n\ * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) REAL array, dimension\n\ * (N) if SIDE = 'L',\n\ * (M) if SIDE = 'R'\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctrti20000644000175000017500000000454412502223525016425 0ustar uwabamiuwabami--- :name: ctrti2 :md5sum: 540ce02ac93c8ae2c4c1845d53530736 :category: :subroutine :arguments: - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CTRTI2( UPLO, DIAG, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTRTI2 computes the inverse of a complex upper or lower triangular\n\ * matrix.\n\ *\n\ * This is the Level 2 BLAS version of the algorithm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the matrix A is upper or lower triangular.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * Specifies whether or not the matrix A is unit triangular.\n\ * = 'N': Non-unit triangular\n\ * = 'U': Unit triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the triangular matrix A. If UPLO = 'U', the\n\ * leading n by n upper triangular part of the array A contains\n\ * the upper triangular matrix, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n by n lower triangular part of the array A contains\n\ * the lower triangular matrix, and the strictly upper\n\ * triangular part of A is not referenced. If DIAG = 'U', the\n\ * diagonal elements of A are also not referenced and are\n\ * assumed to be 1.\n\ *\n\ * On exit, the (triangular) inverse of the original matrix, in\n\ * the same storage format.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgesv0000644000175000017500000000610412502223526016321 0ustar uwabamiuwabami--- :name: dgesv :md5sum: 8ab66d02ed18d053ba3faf7a6a1d1ad2 :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGESV computes the solution to a real system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n\ *\n\ * The LU decomposition with partial pivoting and row interchanges is\n\ * used to factor A as\n\ * A = P * L * U,\n\ * where P is a permutation matrix, L is unit lower triangular, and U is\n\ * upper triangular. The factored form of A is then used to solve the\n\ * system of equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the N-by-N coefficient matrix A.\n\ * On exit, the factors L and U from the factorization\n\ * A = P*L*U; the unit diagonal elements of L are not stored.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * The pivot indices that define the permutation matrix P;\n\ * row i of the matrix was interchanged with row IPIV(i).\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS matrix of right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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, U(i,i) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, so the solution could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. External Subroutines ..\n EXTERNAL DGETRF, DGETRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dgeequb0000644000175000017500000000742412502223526016633 0ustar uwabamiuwabami--- :name: dgeequb :md5sum: c63a97ad851901733ab2b896a9ad93a8 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - r: :type: doublereal :intent: output :dims: - m - c: :type: doublereal :intent: output :dims: - n - rowcnd: :type: doublereal :intent: output - colcnd: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE DGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGEEQUB computes row and column scalings intended to equilibrate an\n\ * M-by-N matrix A and reduce its condition number. R returns the row\n\ * scale factors and C the column scale factors, chosen to try to make\n\ * the largest element in each row and column of the matrix B with\n\ * elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n\ * the radix.\n\ *\n\ * R(i) and C(j) are restricted to be a power of the radix between\n\ * SMLNUM = smallest safe number and BIGNUM = largest safe number. Use\n\ * of these scaling factors is not guaranteed to reduce the condition\n\ * number of A but works well in practice.\n\ *\n\ * This routine differs from DGEEQU by restricting the scaling factors\n\ * to a power of the radix. Baring over- and underflow, scaling by\n\ * these factors introduces no additional rounding errors. However, the\n\ * scaled entries' magnitured are no longer approximately 1 but lie\n\ * between sqrt(radix) and 1/sqrt(radix).\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) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The M-by-N matrix whose equilibration factors are\n\ * to be computed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * R (output) DOUBLE PRECISION array, dimension (M)\n\ * If INFO = 0 or INFO > M, R contains the row scale factors\n\ * for A.\n\ *\n\ * C (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, C contains the column scale factors for A.\n\ *\n\ * ROWCND (output) DOUBLE PRECISION\n\ * If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n\ * smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n\ * AMAX is neither too large nor too small, it is not worth\n\ * scaling by R.\n\ *\n\ * COLCND (output) DOUBLE PRECISION\n\ * If INFO = 0, COLCND contains the ratio of the smallest\n\ * C(i) to the largest C(i). If COLCND >= 0.1, it is not\n\ * worth scaling by C.\n\ *\n\ * AMAX (output) DOUBLE PRECISION\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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, and i is\n\ * <= M: the i-th row of A is exactly zero\n\ * > M: the (i-M)-th column of A is exactly zero\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgetf20000644000175000017500000000454112502223526016367 0ustar uwabamiuwabami--- :name: dgetf2 :md5sum: 4a9f270f6962bef69979fdff93c30a0c :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGETF2 computes an LU factorization of a general m-by-n matrix A\n\ * using partial pivoting with row interchanges.\n\ *\n\ * The factorization has the form\n\ * A = P * L * U\n\ * where P is a permutation matrix, L is lower triangular with unit\n\ * diagonal elements (lower trapezoidal if m > n), and U is upper\n\ * triangular (upper trapezoidal if m < n).\n\ *\n\ * This is the right-looking Level 2 BLAS version of the algorithm.\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 to be factored.\n\ * On exit, the factors L and U from the factorization\n\ * A = P*L*U; the unit diagonal elements of L are not stored.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * IPIV (output) INTEGER array, dimension (min(M,N))\n\ * The pivot indices; for 1 <= i <= min(M,N), row i of the\n\ * matrix was interchanged with row IPIV(i).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ * > 0: if INFO = k, U(k,k) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, and division by zero will occur if it is used\n\ * to solve a system of equations.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dpbsvx0000644000175000017500000002765712502223526016537 0ustar uwabamiuwabami--- :name: dpbsvx :md5sum: 8391174b1809b05ffa196bf9a0d4a47a :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublereal :intent: input/output :dims: - ldafb - n - ldafb: :type: integer :intent: input - equed: :type: char :intent: input/output - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE DPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPBSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to\n\ * compute the solution to a real system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N symmetric positive definite band matrix and X\n\ * and B are N-by-NRHS matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', real scaling factors are computed to equilibrate\n\ * the system:\n\ * diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n\ *\n\ * 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n\ * factor the matrix A (after equilibration if FACT = 'E') as\n\ * A = U**T * U, if UPLO = 'U', or\n\ * A = L * L**T, if UPLO = 'L',\n\ * where U is an upper triangular band matrix, and L is a lower\n\ * triangular band matrix.\n\ *\n\ * 3. If the leading i-by-i principal minor is not positive definite,\n\ * then the routine returns with INFO = i. Otherwise, the factored\n\ * form of A is used to estimate the condition number of the matrix\n\ * A. If the reciprocal of the condition number is less than machine\n\ * precision, INFO = N+1 is returned as a warning, but the routine\n\ * still goes on to solve for X and compute error bounds as\n\ * described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(S) so that it solves the original system before\n\ * equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AFB contains the factored form of A.\n\ * If EQUED = 'Y', the matrix A has been equilibrated\n\ * with scaling factors given by S. AB and AFB will not\n\ * be modified.\n\ * = 'N': The matrix A will be copied to AFB and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AFB and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right-hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first KD+1 rows of the array, except\n\ * if FACT = 'F' and EQUED = 'Y', then A must contain the\n\ * equilibrated matrix diag(S)*A*diag(S). The j-th column of A\n\ * is stored in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).\n\ * See below for further details.\n\ *\n\ * On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n\ * diag(S)*A*diag(S).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array A. LDAB >= KD+1.\n\ *\n\ * AFB (input or output) DOUBLE PRECISION array, dimension (LDAFB,N)\n\ * If FACT = 'F', then AFB is an input argument and on entry\n\ * contains the triangular factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T of the band matrix\n\ * A, in the same storage format as A (see AB). If EQUED = 'Y',\n\ * then AFB is the factored form of the equilibrated matrix A.\n\ *\n\ * If FACT = 'N', then AFB is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T.\n\ *\n\ * If FACT = 'E', then AFB is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T of the equilibrated\n\ * matrix A (see the description of A for the form of the\n\ * equilibrated matrix).\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= KD+1.\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'Y': Equilibration was done, i.e., A has been replaced by\n\ * diag(S) * A * diag(S).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * S (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The scale factors for A; not accessed if EQUED = 'N'. S is\n\ * an input argument if FACT = 'F'; otherwise, S is an output\n\ * argument. If FACT = 'F' and EQUED = 'Y', each element of S\n\ * must be positive.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n\ * B is overwritten by diag(S) * B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n\ * the original system of equations. Note that if EQUED = 'Y',\n\ * A and B are modified on exit, and the solution to the\n\ * equilibrated system is inv(diag(S))*X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A after equilibration (if done). If RCOND is less than the\n\ * machine precision (in particular, if RCOND = 0), the matrix\n\ * is singular to working precision. This condition is\n\ * indicated by a return code of INFO > 0.\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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, and i is\n\ * <= N: the leading minor of order i of A is\n\ * not positive definite, so the factorization\n\ * could not be completed, and the solution has not\n\ * been computed. RCOND = 0 is returned.\n\ * = N+1: U is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * N = 6, KD = 2, and UPLO = 'U':\n\ *\n\ * Two-dimensional storage of the symmetric matrix A:\n\ *\n\ * a11 a12 a13\n\ * a22 a23 a24\n\ * a33 a34 a35\n\ * a44 a45 a46\n\ * a55 a56\n\ * (aij=conjg(aji)) a66\n\ *\n\ * Band storage of the upper triangle of A:\n\ *\n\ * * * a13 a24 a35 a46\n\ * * a12 a23 a34 a45 a56\n\ * a11 a22 a33 a44 a55 a66\n\ *\n\ * Similarly, if UPLO = 'L' the format of A is as follows:\n\ *\n\ * a11 a22 a33 a44 a55 a66\n\ * a21 a32 a43 a54 a65 *\n\ * a31 a42 a53 a64 * *\n\ *\n\ * Array elements marked * are not used by the routine.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgelsy0000644000175000017500000001436712502223526016531 0ustar uwabamiuwabami--- :name: sgelsy :md5sum: ef95fb1aa71e1dc5559fe35dd26c6aac :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - rcond: :type: real :intent: input - rank: :type: integer :intent: output - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(MIN(m,n)+3*n+1, 2*MIN(m,n)+nrhs) - info: :type: integer :intent: output :substitutions: m: lda ldb: MAX(m,n) :fortran_help: " SUBROUTINE SGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGELSY computes the minimum-norm solution to a real linear least\n\ * squares problem:\n\ * minimize || A * X - B ||\n\ * using a complete orthogonal factorization of A. A is an M-by-N\n\ * matrix which may be rank-deficient.\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\ * The routine first computes a QR factorization with column pivoting:\n\ * A * P = Q * [ R11 R12 ]\n\ * [ 0 R22 ]\n\ * with R11 defined as the largest leading submatrix whose estimated\n\ * condition number is less than 1/RCOND. The order of R11, RANK,\n\ * is the effective rank of A.\n\ *\n\ * Then, R22 is considered to be negligible, and R12 is annihilated\n\ * by orthogonal transformations from the right, arriving at the\n\ * complete orthogonal factorization:\n\ * A * P = Q * [ T11 0 ] * Z\n\ * [ 0 0 ]\n\ * The minimum-norm solution is then\n\ * X = P * Z' [ inv(T11)*Q1'*B ]\n\ * [ 0 ]\n\ * where Q1 consists of the first RANK columns of Q.\n\ *\n\ * This routine is basically identical to the original xGELSX except\n\ * three differences:\n\ * o The call to the subroutine xGEQPF has been substituted by the\n\ * the call to the subroutine xGEQP3. This subroutine is a Blas-3\n\ * version of the QR factorization with column pivoting.\n\ * o Matrix B (the right hand side) is updated with Blas-3.\n\ * o The permutation of matrix B (the right hand side) is faster and\n\ * more simple.\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\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of\n\ * columns of matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, A has been overwritten by details of its\n\ * complete orthogonal factorization.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the M-by-NRHS right hand side matrix B.\n\ * On exit, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,M,N).\n\ *\n\ * JPVT (input/output) INTEGER array, dimension (N)\n\ * On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n\ * to the front of AP, otherwise column i is a free column.\n\ * On exit, if JPVT(i) = k, then the i-th column of AP\n\ * was the k-th column of A.\n\ *\n\ * RCOND (input) REAL\n\ * RCOND is used to determine the effective rank of A, which\n\ * is defined as the order of the largest leading triangular\n\ * submatrix R11 in the QR factorization with pivoting of A,\n\ * whose estimated condition number < 1/RCOND.\n\ *\n\ * RANK (output) INTEGER\n\ * The effective rank of A, i.e., the order of the submatrix\n\ * R11. This is the same as the order of the submatrix T11\n\ * in the complete orthogonal factorization of A.\n\ *\n\ * WORK (workspace/output) REAL 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\ * The unblocked strategy requires that:\n\ * LWORK >= MAX( MN+3*N+1, 2*MN+NRHS ),\n\ * where MN = min( M, N ).\n\ * The block algorithm requires that:\n\ * LWORK >= MAX( MN+2*N+NB*(N+1), 2*MN+NB*NRHS ),\n\ * where NB is an upper bound on the blocksize returned\n\ * by ILAENV for the routines SGEQP3, STZRZF, STZRQF, SORMQR,\n\ * and SORMRZ.\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\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ * E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n\ * G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsyevx0000644000175000017500000001747212502223526016545 0ustar uwabamiuwabami--- :name: dsyevx :md5sum: 4b8e4075425f065e1c4088fde2b251f8 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : 8*n" - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"I\") ? iu-il+1 : n" :fortran_help: " SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSYEVX computes selected eigenvalues and, optionally, eigenvectors\n\ * of a real symmetric matrix A. Eigenvalues and eigenvectors can be\n\ * selected by specifying either a range of values or a range of indices\n\ * for the desired eigenvalues.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found.\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found.\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of A contains the\n\ * upper triangular part of the matrix A. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of A contains\n\ * the lower triangular part of the matrix A.\n\ * On exit, the lower triangle (if UPLO='L') or the upper\n\ * triangle (if UPLO='U') of A, including the diagonal, is\n\ * destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * VL (input) DOUBLE PRECISION\n\ * VU (input) DOUBLE PRECISION\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) DOUBLE PRECISION\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less than\n\ * or equal to zero, then EPS*|T| will be used in its place,\n\ * where |T| is the 1-norm of the tridiagonal matrix obtained\n\ * by reducing A to tridiagonal form.\n\ *\n\ * Eigenvalues will be computed most accurately when ABSTOL is\n\ * set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n\ * If this routine returns with INFO>0, indicating that some\n\ * eigenvectors did not converge, try setting ABSTOL to\n\ * 2*DLAMCH('S').\n\ *\n\ * See \"Computing Small Singular Values of Bidiagonal Matrices\n\ * with Guaranteed High Relative Accuracy,\" by Demmel and\n\ * Kahan, LAPACK Working Note #3.\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * On normal exit, the first M elements contain the selected\n\ * eigenvalues in ascending order.\n\ *\n\ * Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))\n\ * If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix A\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * If an eigenvector fails to converge, then that column of Z\n\ * contains the latest approximation to the eigenvector, and the\n\ * index of the eigenvector is returned in IFAIL.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,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 length of the array WORK. LWORK >= 1, when N <= 1;\n\ * otherwise 8*N.\n\ * For optimal efficiency, LWORK >= (NB+3)*N,\n\ * where NB is the max of the blocksize for DSYTRD and DORMTR\n\ * returned by ILAENV.\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\ * IWORK (workspace) INTEGER array, dimension (5*N)\n\ *\n\ * IFAIL (output) INTEGER array, dimension (N)\n\ * If JOBZ = 'V', then if INFO = 0, the first M elements of\n\ * IFAIL are zero. If INFO > 0, then IFAIL contains the\n\ * indices of the eigenvectors that failed to converge.\n\ * If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n\ * Their indices are stored in array IFAIL.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cpstf20000644000175000017500000000674212502223525016421 0ustar uwabamiuwabami--- :name: cpstf2 :md5sum: a8e79b54d21b622910982637f54f9b0c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - piv: :type: integer :intent: output :dims: - n - rank: :type: integer :intent: output - tol: :type: real :intent: input - work: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPSTF2 computes the Cholesky factorization with complete\n\ * pivoting of a complex Hermitian positive semidefinite matrix A.\n\ *\n\ * The factorization has the form\n\ * P' * A * P = U' * U , if UPLO = 'U',\n\ * P' * A * P = L * L', if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is lower triangular, and\n\ * P is stored as vector PIV.\n\ *\n\ * This algorithm does not attempt to check that A is positive\n\ * semidefinite. This version of the algorithm calls level 2 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * n by n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n by n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the factor U or L from the Cholesky\n\ * factorization as above.\n\ *\n\ * PIV (output) INTEGER array, dimension (N)\n\ * PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n\ *\n\ * RANK (output) INTEGER\n\ * The rank of A given by the number of steps the algorithm\n\ * completed.\n\ *\n\ * TOL (input) REAL\n\ * User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) )\n\ * will be used. The algorithm terminates at the (K-1)st step\n\ * if the pivot <= TOL.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * WORK (workspace) REAL array, dimension (2*N)\n\ * Work space.\n\ *\n\ * INFO (output) INTEGER\n\ * < 0: If INFO = -K, the K-th argument had an illegal value,\n\ * = 0: algorithm completed successfully, and\n\ * > 0: the matrix A is either rank deficient with computed rank\n\ * as returned in RANK, or is indefinite. See Section 7 of\n\ * LAPACK Working Note #161 for further information.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgelqf0000644000175000017500000000722712502223525016460 0ustar uwabamiuwabami--- :name: cgelqf :md5sum: b75f05b1c6941e97fc9d81c962662fb8 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - MIN(m,n) - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGELQF computes an LQ factorization of a complex 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) COMPLEX 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 unitary 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) COMPLEX array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace/output) COMPLEX 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 complex scalar, and v is a complex vector with\n\ * v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in\n\ * A(i,i+1: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 CGELQ2, CLARFB, CLARFT, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dla_syrfsx_extended0000644000175000017500000003524312502223526021255 0ustar uwabamiuwabami--- :name: dla_syrfsx_extended :md5sum: 5b2a7698bbce8c0dc9f743b47f9a53f0 :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - colequ: :type: logical :intent: input - c: :type: doublereal :intent: input :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: doublereal :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: doublereal :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: input/output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: input/output :dims: - nrhs - n_err_bnds - res: :type: doublereal :intent: input :dims: - n - ayb: :type: doublereal :intent: input :dims: - n - dy: :type: doublereal :intent: input :dims: - n - y_tail: :type: doublereal :intent: input :dims: - n - rcond: :type: doublereal :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: doublereal :intent: input - dz_ub: :type: doublereal :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n\ * Purpose\n\ * =======\n\ * \n\ * DLA_SYRFSX_EXTENDED improves the computed solution to a system of\n\ * linear equations by performing extra-precise iterative refinement\n\ * and provides error bounds and backward error estimates for the solution.\n\ * This subroutine is called by DSYRFSX to perform iterative refinement.\n\ * In addition to normwise error bound, the code provides maximum\n\ * componentwise error bound if possible. See comments for ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP for details of the error bounds. Note that this\n\ * subroutine is only resonsible for setting the second fields of\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * PREC_TYPE (input) INTEGER\n\ * Specifies the intermediate precision to be used in refinement.\n\ * The value is defined by ILAPREC(P) where P is a CHARACTER and\n\ * P = 'S': Single\n\ * = 'D': Double\n\ * = 'I': Indigenous\n\ * = 'X', 'E': Extra\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right-hand-sides, i.e., the number of columns of the\n\ * matrix B.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by DSYTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by DSYTRF.\n\ *\n\ * COLEQU (input) LOGICAL\n\ * If .TRUE. then column equilibration was done to A before calling\n\ * this routine. This is needed to compute the solution and error\n\ * bounds correctly.\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension (N)\n\ * The column scale factors for A. If COLEQU = .FALSE., C\n\ * is not accessed. If C is input, each element of C should be a power\n\ * of the radix to ensure a reliable solution and error estimates.\n\ * Scaling by powers of the radix does not cause rounding errors unless\n\ * the result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * The right-hand-side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * Y (input/output) DOUBLE PRECISION array, dimension\n\ * (LDY,NRHS)\n\ * On entry, the solution matrix X, as computed by DSYTRS.\n\ * On exit, the improved solution matrix Y.\n\ *\n\ * LDY (input) INTEGER\n\ * The leading dimension of the array Y. LDY >= max(1,N).\n\ *\n\ * BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * On exit, BERR_OUT(j) contains the componentwise relative backward\n\ * error for right-hand-side j from the formula\n\ * max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n\ * where abs(Z) is the componentwise absolute value of the matrix\n\ * or vector Z. This is computed by DLA_LIN_BERR.\n\ *\n\ * N_NORMS (input) INTEGER\n\ * Determines which error bounds to return (see ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP).\n\ * If N_NORMS >= 1 return normwise error bounds.\n\ * If N_NORMS >= 2 return componentwise error bounds.\n\ *\n\ * ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension\n\ * (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension\n\ * (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * RES (input) DOUBLE PRECISION array, dimension (N)\n\ * Workspace to hold the intermediate residual.\n\ *\n\ * AYB (input) DOUBLE PRECISION array, dimension (N)\n\ * Workspace. This can be the same workspace passed for Y_TAIL.\n\ *\n\ * DY (input) DOUBLE PRECISION array, dimension (N)\n\ * Workspace to hold the intermediate solution.\n\ *\n\ * Y_TAIL (input) DOUBLE PRECISION array, dimension (N)\n\ * Workspace to hold the trailing bits of the intermediate solution.\n\ *\n\ * RCOND (input) DOUBLE PRECISION\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * ITHRESH (input) INTEGER\n\ * The maximum number of residual computations allowed for\n\ * refinement. The default is 10. For 'aggressive' set to 100 to\n\ * permit convergence using approximate factorizations or\n\ * factorizations other than LU. If the factorization uses a\n\ * technique other than Gaussian elimination, the guarantees in\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n\ *\n\ * RTHRESH (input) DOUBLE PRECISION\n\ * Determines when to stop refinement if the error estimate stops\n\ * decreasing. Refinement will stop when the next solution no longer\n\ * satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n\ * the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n\ * default value is 0.5. For 'aggressive' set to 0.9 to permit\n\ * convergence on extremely ill-conditioned matrices. See LAWN 165\n\ * for more details.\n\ *\n\ * DZ_UB (input) DOUBLE PRECISION\n\ * Determines when to start considering componentwise convergence.\n\ * Componentwise convergence is only considered after each component\n\ * of the solution Y is stable, which we definte as the relative\n\ * change in each component being less than DZ_UB. The default value\n\ * is 0.25, requiring the first bit to be stable. See LAWN 165 for\n\ * more details.\n\ *\n\ * IGNORE_CWISE (input) LOGICAL\n\ * If .TRUE. then ignore componentwise convergence. Default value\n\ * is .FALSE..\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * < 0: if INFO = -i, the ith argument to DSYTRS had an illegal\n\ * value\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE\n DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/clahef0000644000175000017500000001065412502223525016437 0ustar uwabamiuwabami--- :name: clahef :md5sum: 495b64a6cbdc181f0b2a8122b9805ff0 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nb: :type: integer :intent: input - kb: :type: integer :intent: output - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - w: :type: complex :intent: workspace :dims: - ldw - MAX(n,nb) - ldw: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: ldw: MAX(1,n) :fortran_help: " SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAHEF computes a partial factorization of a complex Hermitian\n\ * matrix A using the Bunch-Kaufman diagonal pivoting method. The\n\ * partial factorization has the form:\n\ *\n\ * A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:\n\ * ( 0 U22 ) ( 0 D ) ( U12' U22' )\n\ *\n\ * A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L'\n\ * ( L21 I ) ( 0 A22 ) ( 0 I )\n\ *\n\ * where the order of D is at most NB. The actual order is returned in\n\ * the argument KB, and is either NB or NB-1, or N if N <= NB.\n\ * Note that U' denotes the conjugate transpose of U.\n\ *\n\ * CLAHEF is an auxiliary routine called by CHETRF. It uses blocked code\n\ * (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or\n\ * A22 (if UPLO = 'L').\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * Hermitian matrix A is stored:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NB (input) INTEGER\n\ * The maximum number of columns of the matrix A that should be\n\ * factored. NB should be at least 2 to allow for 2-by-2 pivot\n\ * blocks.\n\ *\n\ * KB (output) INTEGER\n\ * The number of columns of A that were actually factored.\n\ * KB is either NB-1 or NB, or N if N <= NB.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the leading\n\ * n-by-n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n-by-n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ * On exit, A contains details of the partial factorization.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D.\n\ * If UPLO = 'U', only the last KB elements of IPIV are set;\n\ * if UPLO = 'L', only the first KB elements are set.\n\ *\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * W (workspace) COMPLEX array, dimension (LDW,NB)\n\ *\n\ * LDW (input) INTEGER\n\ * The leading dimension of the array W. LDW >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlahrd0000644000175000017500000001060312502223526016446 0ustar uwabamiuwabami--- :name: dlahrd :md5sum: 3992e32cc63ed67be6e1a947a6fe2335 :category: :subroutine :arguments: - n: :type: integer :intent: input - k: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n-k+1 - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - MAX(1,nb) - t: :type: doublereal :intent: output :dims: - ldt - MAX(1,nb) - ldt: :type: integer :intent: input - y: :type: doublereal :intent: output :dims: - ldy - MAX(1,nb) - ldy: :type: integer :intent: input :substitutions: ldy: n ldt: nb :fortran_help: " SUBROUTINE DLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAHRD reduces the first NB columns of a real general n-by-(n-k+1)\n\ * matrix A so that elements below the k-th subdiagonal are zero. The\n\ * reduction is performed by an orthogonal similarity transformation\n\ * Q' * A * Q. The routine returns the matrices V and T which determine\n\ * Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n\ *\n\ * This is an OBSOLETE auxiliary routine. \n\ * This routine will be 'deprecated' in a future release.\n\ * Please use the new routine DLAHR2 instead.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A.\n\ *\n\ * K (input) INTEGER\n\ * The offset for the reduction. Elements below the k-th\n\ * subdiagonal in the first NB columns are reduced to zero.\n\ *\n\ * NB (input) INTEGER\n\ * The number of columns to be reduced.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N-K+1)\n\ * On entry, the n-by-(n-k+1) general matrix A.\n\ * On exit, the elements on and above the k-th subdiagonal in\n\ * the first NB columns are overwritten with the corresponding\n\ * elements of the reduced matrix; the elements below the k-th\n\ * subdiagonal, with the array TAU, represent the matrix Q as a\n\ * product of elementary reflectors. The other columns of A are\n\ * unchanged. See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * TAU (output) DOUBLE PRECISION array, dimension (NB)\n\ * The scalar factors of the elementary reflectors. See Further\n\ * Details.\n\ *\n\ * T (output) DOUBLE PRECISION array, dimension (LDT,NB)\n\ * The upper triangular matrix T.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= NB.\n\ *\n\ * Y (output) DOUBLE PRECISION array, dimension (LDY,NB)\n\ * The n-by-nb matrix Y.\n\ *\n\ * LDY (input) INTEGER\n\ * The leading dimension of the array Y. LDY >= N.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The matrix Q is represented as a product of nb elementary reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(nb).\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+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n\ * A(i+k+1:n,i), and tau in TAU(i).\n\ *\n\ * The elements of the vectors v together form the (n-k+1)-by-nb matrix\n\ * V which is needed, with T and Y, to apply the transformation to the\n\ * unreduced part of the matrix, using an update of the form:\n\ * A := (I - V*T*V') * (A - Y*V').\n\ *\n\ * The contents of A on exit are illustrated by the following example\n\ * with n = 7, k = 3 and nb = 2:\n\ *\n\ * ( a h a a a )\n\ * ( a h a a a )\n\ * ( a h a a a )\n\ * ( h h a a a )\n\ * ( v1 h a a a )\n\ * ( v1 v2 a a a )\n\ * ( v1 v2 a a a )\n\ *\n\ * where a denotes an element of the original matrix A, h denotes a\n\ * modified element of the upper Hessenberg matrix H, and vi denotes an\n\ * element of the vector defining H(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slasd20000644000175000017500000002065712502223526016412 0ustar uwabamiuwabami--- :name: slasd2 :md5sum: e139bb4b0237d0c44116e11595e1c166 :category: :subroutine :arguments: - nl: :type: integer :intent: input - nr: :type: integer :intent: input - sqre: :type: integer :intent: input - k: :type: integer :intent: output - d: :type: real :intent: input/output :dims: - n - z: :type: real :intent: output :dims: - n - alpha: :type: real :intent: input - beta: :type: real :intent: input - u: :type: real :intent: input/output :dims: - ldu - n - ldu: :type: integer :intent: input - vt: :type: real :intent: input/output :dims: - ldvt - m - ldvt: :type: integer :intent: input - dsigma: :type: real :intent: output :dims: - n - u2: :type: real :intent: output :dims: - ldu2 - n - ldu2: :type: integer :intent: input - vt2: :type: real :intent: output :dims: - ldvt2 - n - ldvt2: :type: integer :intent: input - idxp: :type: integer :intent: workspace :dims: - n - idx: :type: integer :intent: workspace :dims: - n - idxc: :type: integer :intent: output :dims: - n - idxq: :type: integer :intent: input/output :dims: - n - coltyp: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldu2: n ldvt2: m :fortran_help: " SUBROUTINE SLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX, IDXC, IDXQ, COLTYP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLASD2 merges the two sets of singular values together into a single\n\ * sorted set. Then it tries to deflate the size of the problem.\n\ * There are two ways in which deflation can occur: when two or more\n\ * singular values are close together or if there is a tiny entry in the\n\ * Z vector. For each such occurrence the order of the related secular\n\ * equation problem is reduced by one.\n\ *\n\ * SLASD2 is called from SLASD1.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NL (input) INTEGER\n\ * The row dimension of the upper block. NL >= 1.\n\ *\n\ * NR (input) INTEGER\n\ * The row dimension of the lower block. NR >= 1.\n\ *\n\ * SQRE (input) INTEGER\n\ * = 0: the lower block is an NR-by-NR square matrix.\n\ * = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n\ *\n\ * The bidiagonal matrix has N = NL + NR + 1 rows and\n\ * M = N + SQRE >= N columns.\n\ *\n\ * K (output) INTEGER\n\ * Contains the dimension of the non-deflated matrix,\n\ * This is the order of the related secular equation. 1 <= K <=N.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry D contains the singular values of the two submatrices\n\ * to be combined. On exit D contains the trailing (N-K) updated\n\ * singular values (those which were deflated) sorted into\n\ * increasing order.\n\ *\n\ * Z (output) REAL array, dimension (N)\n\ * On exit Z contains the updating row vector in the secular\n\ * equation.\n\ *\n\ * ALPHA (input) REAL\n\ * Contains the diagonal element associated with the added row.\n\ *\n\ * BETA (input) REAL\n\ * Contains the off-diagonal element associated with the added\n\ * row.\n\ *\n\ * U (input/output) REAL array, dimension (LDU,N)\n\ * On entry U contains the left singular vectors of two\n\ * submatrices in the two square blocks with corners at (1,1),\n\ * (NL, NL), and (NL+2, NL+2), (N,N).\n\ * On exit U contains the trailing (N-K) updated left singular\n\ * vectors (those which were deflated) in its last N-K columns.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= N.\n\ *\n\ * VT (input/output) REAL array, dimension (LDVT,M)\n\ * On entry VT' contains the right singular vectors of two\n\ * submatrices in the two square blocks with corners at (1,1),\n\ * (NL+1, NL+1), and (NL+2, NL+2), (M,M).\n\ * On exit VT' contains the trailing (N-K) updated right singular\n\ * vectors (those which were deflated) in its last N-K columns.\n\ * In case SQRE =1, the last row of VT spans the right null\n\ * space.\n\ *\n\ * LDVT (input) INTEGER\n\ * The leading dimension of the array VT. LDVT >= M.\n\ *\n\ * DSIGMA (output) REAL array, dimension (N)\n\ * Contains a copy of the diagonal elements (K-1 singular values\n\ * and one zero) in the secular equation.\n\ *\n\ * U2 (output) REAL array, dimension (LDU2,N)\n\ * Contains a copy of the first K-1 left singular vectors which\n\ * will be used by SLASD3 in a matrix multiply (SGEMM) to solve\n\ * for the new left singular vectors. U2 is arranged into four\n\ * blocks. The first block contains a column with 1 at NL+1 and\n\ * zero everywhere else; the second block contains non-zero\n\ * entries only at and above NL; the third contains non-zero\n\ * entries only below NL+1; and the fourth is dense.\n\ *\n\ * LDU2 (input) INTEGER\n\ * The leading dimension of the array U2. LDU2 >= N.\n\ *\n\ * VT2 (output) REAL array, dimension (LDVT2,N)\n\ * VT2' contains a copy of the first K right singular vectors\n\ * which will be used by SLASD3 in a matrix multiply (SGEMM) to\n\ * solve for the new right singular vectors. VT2 is arranged into\n\ * three blocks. The first block contains a row that corresponds\n\ * to the special 0 diagonal element in SIGMA; the second block\n\ * contains non-zeros only at and before NL +1; the third block\n\ * contains non-zeros only at and after NL +2.\n\ *\n\ * LDVT2 (input) INTEGER\n\ * The leading dimension of the array VT2. LDVT2 >= M.\n\ *\n\ * IDXP (workspace) INTEGER array, dimension (N)\n\ * This will contain the permutation used to place deflated\n\ * values of D at the end of the array. On output IDXP(2:K)\n\ * points to the nondeflated D-values and IDXP(K+1:N)\n\ * points to the deflated singular values.\n\ *\n\ * IDX (workspace) INTEGER array, dimension (N)\n\ * This will contain the permutation used to sort the contents of\n\ * D into ascending order.\n\ *\n\ * IDXC (output) INTEGER array, dimension (N)\n\ * This will contain the permutation used to arrange the columns\n\ * of the deflated U matrix into three groups: the first group\n\ * contains non-zero entries only at and above NL, the second\n\ * contains non-zero entries only below NL+2, and the third is\n\ * dense.\n\ *\n\ * IDXQ (input/output) INTEGER array, dimension (N)\n\ * This contains the permutation which separately sorts the two\n\ * sub-problems in D into ascending order. Note that entries in\n\ * the first hlaf of this permutation must first be moved one\n\ * position backward; and entries in the second half\n\ * must first have NL+1 added to their values.\n\ *\n\ * COLTYP (workspace/output) INTEGER array, dimension (N)\n\ * As workspace, this will contain a label which will indicate\n\ * which of the following types a column in the U2 matrix or a\n\ * row in the VT2 matrix is:\n\ * 1 : non-zero in the upper half only\n\ * 2 : non-zero in the lower half only\n\ * 3 : dense\n\ * 4 : deflated\n\ *\n\ * On exit, it is an array of dimension 4, with COLTYP(I) being\n\ * the dimension of the I-th type columns.\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\ * Based on contributions by\n\ * Ming Gu and Huan Ren, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgesdd0000644000175000017500000001760412502223526016500 0ustar uwabamiuwabami--- :name: zgesdd :md5sum: 0d191901adb7622e92d1f0b2dc6c8138 :category: :subroutine :arguments: - jobz: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - MIN(m,n) - u: :type: doublecomplex :intent: output :dims: - ldu - ucol - ldu: :type: integer :intent: input - vt: :type: doublecomplex :intent: output :dims: - ldvt - n - ldvt: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"N\") ? 2*MIN(m,n)+MAX(m,n) : lsame_(&jobz,\"O\") ? 2*MIN(m,n)*MIN(m,n)+2*MIN(m,n)+MAX(m,n) : (lsame_(&jobz,\"S\")||lsame_(&jobz,\"A\")) ? MIN(m,n)*MIN(m,n)+2*MIN(m,n)+MAX(m,n) : 0" - rwork: :type: doublereal :intent: workspace :dims: - "MAX(1, (lsame_(&jobz,\"N\") ? 5*MIN(m,n) : MIN(m,n)*MAX(5*MIN(m,n)+7,2*MAX(m,n)+2*MIN(m,n)+1)))" - iwork: :type: integer :intent: workspace :dims: - 8*MIN(m,n) - info: :type: integer :intent: output :substitutions: m: lda ucol: "((lsame_(&jobz,\"A\")) || (((lsame_(&jobz,\"O\")) && (m < n)))) ? m : lsame_(&jobz,\"S\") ? MIN(m,n) : 0" ldvt: "((lsame_(&jobz,\"A\")) || (((lsame_(&jobz,\"O\")) && (m >= n)))) ? n : lsame_(&jobz,\"S\") ? MIN(m,n) : 1" ldu: "(lsame_(&jobz,\"S\") || lsame_(&jobz,\"A\") || (lsame_(&jobz,\"O\") && m < n)) ? m : 1" :fortran_help: " SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGESDD computes the singular value decomposition (SVD) of a complex\n\ * M-by-N matrix A, optionally computing the left and/or right singular\n\ * vectors, by using divide-and-conquer method. The SVD is written\n\ *\n\ * A = U * SIGMA * conjugate-transpose(V)\n\ *\n\ * where SIGMA is an M-by-N matrix which is zero except for its\n\ * min(m,n) diagonal elements, U is an M-by-M unitary matrix, and\n\ * V is an N-by-N unitary matrix. The diagonal elements of SIGMA\n\ * are the singular values of A; they are real and non-negative, and\n\ * are returned in descending order. The first min(m,n) columns of\n\ * U and V are the left and right singular vectors of A.\n\ *\n\ * Note that the routine returns VT = V**H, not V.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * Specifies options for computing all or part of the matrix U:\n\ * = 'A': all M columns of U and all N rows of V**H are\n\ * returned in the arrays U and VT;\n\ * = 'S': the first min(M,N) columns of U and the first\n\ * min(M,N) rows of V**H are returned in the arrays U\n\ * and VT;\n\ * = 'O': If M >= N, the first N columns of U are overwritten\n\ * in the array A and all rows of V**H are returned in\n\ * the array VT;\n\ * otherwise, all columns of U are returned in the\n\ * array U and the first M rows of V**H are overwritten\n\ * in the array A;\n\ * = 'N': no columns of U or rows of V**H are computed.\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. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit,\n\ * if JOBZ = 'O', A is overwritten with the first N columns\n\ * of U (the left singular vectors, stored\n\ * columnwise) if M >= N;\n\ * A is overwritten with the first M rows\n\ * of V**H (the right singular vectors, stored\n\ * rowwise) otherwise.\n\ * if JOBZ .ne. 'O', the contents of A are destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * S (output) DOUBLE PRECISION array, dimension (min(M,N))\n\ * The singular values of A, sorted so that S(i) >= S(i+1).\n\ *\n\ * U (output) COMPLEX*16 array, dimension (LDU,UCOL)\n\ * UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;\n\ * UCOL = min(M,N) if JOBZ = 'S'.\n\ * If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M\n\ * unitary matrix U;\n\ * if JOBZ = 'S', U contains the first min(M,N) columns of U\n\ * (the left singular vectors, stored columnwise);\n\ * if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= 1; if\n\ * JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.\n\ *\n\ * VT (output) COMPLEX*16 array, dimension (LDVT,N)\n\ * If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the\n\ * N-by-N unitary matrix V**H;\n\ * if JOBZ = 'S', VT contains the first min(M,N) rows of\n\ * V**H (the right singular vectors, stored rowwise);\n\ * if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.\n\ *\n\ * LDVT (input) INTEGER\n\ * The leading dimension of the array VT. LDVT >= 1; if\n\ * JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;\n\ * if JOBZ = 'S', LDVT >= min(M,N).\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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 >= 1.\n\ * if JOBZ = 'N', LWORK >= 2*min(M,N)+max(M,N).\n\ * if JOBZ = 'O',\n\ * LWORK >= 2*min(M,N)*min(M,N)+2*min(M,N)+max(M,N).\n\ * if JOBZ = 'S' or 'A',\n\ * LWORK >= min(M,N)*min(M,N)+2*min(M,N)+max(M,N).\n\ * For good performance, LWORK should generally be larger.\n\ *\n\ * If LWORK = -1, a workspace query is assumed. The optimal\n\ * size for the WORK array is calculated and stored in WORK(1),\n\ * and no other work except argument checking is performed.\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))\n\ * If JOBZ = 'N', LRWORK >= 5*min(M,N).\n\ * Otherwise,\n\ * LRWORK >= min(M,N)*max(5*min(M,N)+7,2*max(M,N)+2*min(M,N)+1)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (8*min(M,N))\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit.\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * > 0: The updating process of DBDSDC did not converge.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ming Gu and Huan Ren, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlaed80000644000175000017500000001543112502223526016403 0ustar uwabamiuwabami--- :name: zlaed8 :md5sum: da94804bd8bee4c6a24adacd2c1c9816 :category: :subroutine :arguments: - k: :type: integer :intent: output - n: :type: integer :intent: input - qsiz: :type: integer :intent: input - q: :type: doublecomplex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - rho: :type: doublereal :intent: input/output - cutpnt: :type: integer :intent: input - z: :type: doublereal :intent: input :dims: - n - dlamda: :type: doublereal :intent: output :dims: - n - q2: :type: doublecomplex :intent: output :dims: - ldq2 - n - ldq2: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - indxp: :type: integer :intent: workspace :dims: - n - indx: :type: integer :intent: workspace :dims: - n - indxq: :type: integer :intent: input :dims: - n - perm: :type: integer :intent: output :dims: - n - givptr: :type: integer :intent: output - givcol: :type: integer :intent: output :dims: - "2" - n - givnum: :type: doublereal :intent: output :dims: - "2" - n - info: :type: integer :intent: output :substitutions: ldq2: MAX( 1, n ) :fortran_help: " SUBROUTINE ZLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA, Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR, GIVCOL, GIVNUM, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAED8 merges the two sets of eigenvalues together into a single\n\ * sorted set. Then it tries to deflate the size of the problem.\n\ * There are two ways in which deflation can occur: when two or more\n\ * eigenvalues are close together or if there is a tiny element in the\n\ * Z vector. For each such occurrence the order of the related secular\n\ * equation problem is reduced by one.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * K (output) INTEGER\n\ * Contains the number of non-deflated eigenvalues.\n\ * This is the order of the related secular equation.\n\ *\n\ * N (input) INTEGER\n\ * The dimension of the symmetric tridiagonal matrix. N >= 0.\n\ *\n\ * QSIZ (input) INTEGER\n\ * The dimension of the unitary matrix used to reduce\n\ * the dense or band matrix to tridiagonal form.\n\ * QSIZ >= N if ICOMPQ = 1.\n\ *\n\ * Q (input/output) COMPLEX*16 array, dimension (LDQ,N)\n\ * On entry, Q contains the eigenvectors of the partially solved\n\ * system which has been previously updated in matrix\n\ * multiplies with other partially solved eigensystems.\n\ * On exit, Q contains the trailing (N-K) updated eigenvectors\n\ * (those which were deflated) in its last N-K columns.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max( 1, N ).\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, D contains the eigenvalues of the two submatrices to\n\ * be combined. On exit, D contains the trailing (N-K) updated\n\ * eigenvalues (those which were deflated) sorted into increasing\n\ * order.\n\ *\n\ * RHO (input/output) DOUBLE PRECISION\n\ * Contains the off diagonal element associated with the rank-1\n\ * cut which originally split the two submatrices which are now\n\ * being recombined. RHO is modified during the computation to\n\ * the value required by DLAED3.\n\ *\n\ * CUTPNT (input) INTEGER\n\ * Contains the location of the last eigenvalue in the leading\n\ * sub-matrix. MIN(1,N) <= CUTPNT <= N.\n\ *\n\ * Z (input) DOUBLE PRECISION array, dimension (N)\n\ * On input this vector contains the updating vector (the last\n\ * row of the first sub-eigenvector matrix and the first row of\n\ * the second sub-eigenvector matrix). The contents of Z are\n\ * destroyed during the updating process.\n\ *\n\ * DLAMDA (output) DOUBLE PRECISION array, dimension (N)\n\ * Contains a copy of the first K eigenvalues which will be used\n\ * by DLAED3 to form the secular equation.\n\ *\n\ * Q2 (output) COMPLEX*16 array, dimension (LDQ2,N)\n\ * If ICOMPQ = 0, Q2 is not referenced. Otherwise,\n\ * Contains a copy of the first K eigenvectors which will be used\n\ * by DLAED7 in a matrix multiply (DGEMM) to update the new\n\ * eigenvectors.\n\ *\n\ * LDQ2 (input) INTEGER\n\ * The leading dimension of the array Q2. LDQ2 >= max( 1, N ).\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * This will hold the first k values of the final\n\ * deflation-altered z-vector and will be passed to DLAED3.\n\ *\n\ * INDXP (workspace) INTEGER array, dimension (N)\n\ * This will contain the permutation used to place deflated\n\ * values of D at the end of the array. On output INDXP(1:K)\n\ * points to the nondeflated D-values and INDXP(K+1:N)\n\ * points to the deflated eigenvalues.\n\ *\n\ * INDX (workspace) INTEGER array, dimension (N)\n\ * This will contain the permutation used to sort the contents of\n\ * D into ascending order.\n\ *\n\ * INDXQ (input) INTEGER array, dimension (N)\n\ * This contains the permutation which separately sorts the two\n\ * sub-problems in D into ascending order. Note that elements in\n\ * the second half of this permutation must first have CUTPNT\n\ * added to their values in order to be accurate.\n\ *\n\ * PERM (output) INTEGER array, dimension (N)\n\ * Contains the permutations (from deflation and sorting) to be\n\ * applied to each eigenblock.\n\ *\n\ * GIVPTR (output) INTEGER\n\ * Contains the number of Givens rotations which took place in\n\ * this subproblem.\n\ *\n\ * GIVCOL (output) INTEGER array, dimension (2, N)\n\ * Each pair of numbers indicates a pair of columns to take place\n\ * in a Givens rotation.\n\ *\n\ * GIVNUM (output) DOUBLE PRECISION array, dimension (2, N)\n\ * Each number indicates the S value to be used in the\n\ * corresponding Givens rotation.\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhpgv0000644000175000017500000001223312502223526016347 0ustar uwabamiuwabami--- :name: zhpgv :md5sum: e5c6764a97b39058ee96f9390c29cdc2 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - ldap - bp: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - MAX(1, 2*n-1) - rwork: :type: doublereal :intent: workspace :dims: - MAX(1, 3*n-2) - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE ZHPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHPGV computes all the eigenvalues and, optionally, the eigenvectors\n\ * of a complex generalized Hermitian-definite eigenproblem, of the form\n\ * A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.\n\ * Here A and B are assumed to be Hermitian, stored in packed format,\n\ * and B is also positive definite.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * Specifies the problem type to be solved:\n\ * = 1: A*x = (lambda)*B*x\n\ * = 2: A*B*x = (lambda)*x\n\ * = 3: B*A*x = (lambda)*x\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, the contents of AP are destroyed.\n\ *\n\ * BP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * B, packed columnwise in a linear array. The j-th column of B\n\ * is stored in the array BP as follows:\n\ * if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n\ *\n\ * On exit, the triangular factor U or L from the Cholesky\n\ * factorization B = U**H*U or B = L*L**H, in the same storage\n\ * format as B.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) COMPLEX*16 array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n\ * eigenvectors. The eigenvectors are normalized as follows:\n\ * if ITYPE = 1 or 2, Z**H*B*Z = I;\n\ * if ITYPE = 3, Z**H*inv(B)*Z = I.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (max(1, 2*N-1))\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2))\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: ZPPTRF or ZHPEV returned an error code:\n\ * <= N: if INFO = i, ZHPEV failed to converge;\n\ * i off-diagonal elements of an intermediate\n\ * tridiagonal form did not convergeto zero;\n\ * > N: if INFO = N + i, for 1 <= i <= n, then the leading\n\ * minor of order i of B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL UPPER, WANTZ\n CHARACTER TRANS\n INTEGER J, NEIG\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZHPEV, ZHPGST, ZPPTRF, ZTPMV, ZTPSV\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/xerbla0000644000175000017500000000220312502223526016462 0ustar uwabamiuwabami--- :name: xerbla :md5sum: 8669c67841523ada1fea62672f940583 :category: :subroutine :arguments: - srname: :type: char :intent: input :dims: - "*" - info: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE XERBLA( SRNAME, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * XERBLA is an error handler for the LAPACK routines.\n\ * It is called by an LAPACK routine if an input parameter has an\n\ * invalid value. A message is printed and execution stops.\n\ *\n\ * Installers may consider modifying the STOP statement in order to\n\ * call system-specific exception-handling facilities.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SRNAME (input) CHARACTER*(*)\n\ * The name of the routine which called XERBLA.\n\ *\n\ * INFO (input) INTEGER\n\ * The position of the invalid parameter in the parameter list\n\ * of the calling routine.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Intrinsic Functions ..\n INTRINSIC LEN_TRIM\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zgeqrfp0000644000175000017500000000730412502223526016672 0ustar uwabamiuwabami--- :name: zgeqrfp :md5sum: 1402e1cace636a626f301ee2f0fbbb65 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - MIN(m,n) - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGEQRFP computes a QR factorization of a complex M-by-N matrix A:\n\ * A = Q * R.\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) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, the elements on and above the diagonal of the array\n\ * contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n\ * upper triangular if m >= n); the elements below the diagonal,\n\ * with the array TAU, represent the unitary matrix Q as a\n\ * product of min(m,n) elementary reflectors (see Further\n\ * Details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (output) COMPLEX*16 array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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,N).\n\ * For optimum performance LWORK >= N*NB, where NB is\n\ * the 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(1) H(2) . . . H(k), 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 complex scalar, and v is a complex vector with\n\ * v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\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 XERBLA, ZGEQR2P, ZLARFB, ZLARFT\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sla_gercond0000644000175000017500000000750712502223526017501 0ustar uwabamiuwabami--- :name: sla_gercond :md5sum: e387f0de4f947d692671de72b3925269 :category: :function :type: real :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - cmode: :type: integer :intent: input - c: :type: real :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: real :intent: input :dims: - 3*n - iwork: :type: integer :intent: input :dims: - n :substitutions: {} :fortran_help: " REAL FUNCTION SLA_GERCOND ( TRANS, N, A, LDA, AF, LDAF, IPIV, CMODE, C, INFO, WORK, IWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLA_GERCOND estimates the Skeel condition number of op(A) * op2(C)\n\ * where op2 is determined by CMODE as follows\n\ * CMODE = 1 op2(C) = C\n\ * CMODE = 0 op2(C) = I\n\ * CMODE = -1 op2(C) = inv(C)\n\ * The Skeel condition number cond(A) = norminf( |inv(A)||A| )\n\ * is computed by computing scaling factors R such that\n\ * diag(R)*A*op2(C) is row equilibrated and computing the standard\n\ * infinity-norm condition number.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate Transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) REAL array, dimension (LDAF,N)\n\ * The factors L and U from the factorization\n\ * A = P*L*U as computed by SGETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from the factorization A = P*L*U\n\ * as computed by SGETRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * CMODE (input) INTEGER\n\ * Determines op2(C) in the formula op(A) * op2(C) as follows:\n\ * CMODE = 1 op2(C) = C\n\ * CMODE = 0 op2(C) = I\n\ * CMODE = -1 op2(C) = inv(C)\n\ *\n\ * C (input) REAL array, dimension (N)\n\ * The vector C in the formula op(A) * op2(C).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * i > 0: The ith argument is invalid.\n\ *\n\ * WORK (input) REAL array, dimension (3*N).\n\ * Workspace.\n\ *\n\ * IWORK (input) INTEGER array, dimension (N).\n\ * Workspace.2\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE, I, J\n REAL AINVNM, TMP\n\ * ..\n\ * .. Local Arrays ..\n INTEGER ISAVE( 3 )\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SLACN2, SGETRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cpbcon0000644000175000017500000000575712502223525016471 0ustar uwabamiuwabami--- :name: cpbcon :md5sum: f2a838373a459acebb9c8d2885c52046 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPBCON estimates the reciprocal of the condition number (in the\n\ * 1-norm) of a complex Hermitian positive definite band matrix using\n\ * the Cholesky factorization A = U**H*U or A = L*L**H computed by\n\ * CPBTRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangular factor stored in AB;\n\ * = 'L': Lower triangular factor stored in AB.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input) COMPLEX array, dimension (LDAB,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**H*U or A = L*L**H of the band matrix A, stored in the\n\ * first KD+1 rows of the array. The j-th column of U or L is\n\ * stored in the j-th column of the array AB as follows:\n\ * if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * ANORM (input) REAL\n\ * The 1-norm (or infinity-norm) of the Hermitian band matrix A.\n\ *\n\ * RCOND (output) REAL\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n\ * estimate of the 1-norm of inv(A) computed in this routine.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zunghr0000644000175000017500000000564612502223526016540 0ustar uwabamiuwabami--- :name: zunghr :md5sum: c69252dcf588a9af5c57d21ca126f764 :category: :subroutine :arguments: - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - n-1 - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: ihi-ilo - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZUNGHR generates a complex unitary matrix Q which is defined as the\n\ * product of IHI-ILO elementary reflectors of order N, as returned by\n\ * ZGEHRD:\n\ *\n\ * Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix Q. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * ILO and IHI must have the same values as in the previous call\n\ * of ZGEHRD. Q is equal to the unit matrix except in the\n\ * submatrix Q(ilo+1:ihi,ilo+1:ihi).\n\ * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the vectors which define the elementary reflectors,\n\ * as returned by ZGEHRD.\n\ * On exit, the N-by-N unitary matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * TAU (input) COMPLEX*16 array, dimension (N-1)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by ZGEHRD.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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 >= IHI-ILO.\n\ * For optimum performance LWORK >= (IHI-ILO)*NB, where NB is\n\ * the 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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zpbequ0000644000175000017500000000630112502223526016516 0ustar uwabamiuwabami--- :name: zpbequ :md5sum: 2a11d91c2d32ad2d3816f333fb440f5b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - n - scond: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPBEQU computes row and column scalings intended to equilibrate a\n\ * Hermitian positive definite band matrix A and reduce its condition\n\ * number (with respect to the two-norm). S contains the scale factors,\n\ * S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n\ * elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n\ * choice of S puts the condition number of B within a factor N of the\n\ * smallest possible condition number over all possible diagonal\n\ * scalings.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangular of A is stored;\n\ * = 'L': Lower triangular of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input) COMPLEX*16 array, dimension (LDAB,N)\n\ * The upper or lower triangle of the Hermitian band matrix A,\n\ * stored in the first KD+1 rows of the array. The j-th column\n\ * of A is stored in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array A. LDAB >= KD+1.\n\ *\n\ * S (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, S contains the scale factors for A.\n\ *\n\ * SCOND (output) DOUBLE PRECISION\n\ * If INFO = 0, S contains the ratio of the smallest S(i) to\n\ * the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n\ * large nor too small, it is not worth scaling by S.\n\ *\n\ * AMAX (output) DOUBLE PRECISION\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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 is nonpositive.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlarft0000644000175000017500000001075712502223526016524 0ustar uwabamiuwabami--- :name: zlarft :md5sum: e49ec2f4472e3bae691c01b3a570c0e5 :category: :subroutine :arguments: - direct: :type: char :intent: input - storev: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - v: :type: doublecomplex :intent: input/output :dims: - ldv - "lsame_(&storev,\"C\") ? k : lsame_(&storev,\"R\") ? n : 0" - ldv: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - t: :type: doublecomplex :intent: output :dims: - ldt - k - ldt: :type: integer :intent: input :substitutions: ldt: k :fortran_help: " SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLARFT forms the triangular factor T of a complex block reflector H\n\ * of order n, which is defined as a product of k elementary reflectors.\n\ *\n\ * If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n\ *\n\ * If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n\ *\n\ * If STOREV = 'C', the vector which defines the elementary reflector\n\ * H(i) is stored in the i-th column of the array V, and\n\ *\n\ * H = I - V * T * V'\n\ *\n\ * If STOREV = 'R', the vector which defines the elementary reflector\n\ * H(i) is stored in the i-th row of the array V, and\n\ *\n\ * H = I - V' * T * V\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * DIRECT (input) CHARACTER*1\n\ * Specifies the order in which the elementary reflectors are\n\ * multiplied to form the block reflector:\n\ * = 'F': H = H(1) H(2) . . . H(k) (Forward)\n\ * = 'B': H = H(k) . . . H(2) H(1) (Backward)\n\ *\n\ * STOREV (input) CHARACTER*1\n\ * Specifies how the vectors which define the elementary\n\ * reflectors are stored (see also Further Details):\n\ * = 'C': columnwise\n\ * = 'R': rowwise\n\ *\n\ * N (input) INTEGER\n\ * The order of the block reflector H. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The order of the triangular factor T (= the number of\n\ * elementary reflectors). K >= 1.\n\ *\n\ * V (input/output) COMPLEX*16 array, dimension\n\ * (LDV,K) if STOREV = 'C'\n\ * (LDV,N) if STOREV = 'R'\n\ * The matrix V. See further details.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V.\n\ * If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n\ *\n\ * TAU (input) COMPLEX*16 array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i).\n\ *\n\ * T (output) COMPLEX*16 array, dimension (LDT,K)\n\ * The k by k triangular factor T of the block reflector.\n\ * If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n\ * lower triangular. The rest of the array is not used.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= K.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The shape of the matrix V and the storage of the vectors which define\n\ * the H(i) is best illustrated by the following example with n = 5 and\n\ * k = 3. The elements equal to 1 are not stored; the corresponding\n\ * array elements are modified but restored on exit. The rest of the\n\ * array is not used.\n\ *\n\ * DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':\n\ *\n\ * V = ( 1 ) V = ( 1 v1 v1 v1 v1 )\n\ * ( v1 1 ) ( 1 v2 v2 v2 )\n\ * ( v1 v2 1 ) ( 1 v3 v3 )\n\ * ( v1 v2 v3 )\n\ * ( v1 v2 v3 )\n\ *\n\ * DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':\n\ *\n\ * V = ( v1 v2 v3 ) V = ( v1 v1 1 )\n\ * ( v1 v2 v3 ) ( v2 v2 v2 1 )\n\ * ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )\n\ * ( 1 v3 )\n\ * ( 1 )\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsygst0000644000175000017500000000576412502223526016541 0ustar uwabamiuwabami--- :name: dsygst :md5sum: b617f42ffff403e3bb78dce99c6de8cf :category: :subroutine :arguments: - itype: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSYGST reduces a real symmetric-definite generalized eigenproblem\n\ * to standard form.\n\ *\n\ * If ITYPE = 1, the problem is A*x = lambda*B*x,\n\ * and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)\n\ *\n\ * If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n\ * B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.\n\ *\n\ * B must have been previously factorized as U**T*U or L*L**T by DPOTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);\n\ * = 2 or 3: compute U*A*U**T or L**T*A*L.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored and B is factored as\n\ * U**T*U;\n\ * = 'L': Lower triangle of A is stored and B is factored as\n\ * L*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the transformed matrix, stored in the\n\ * same format as A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,N)\n\ * The triangular factor from the Cholesky factorization of B,\n\ * as returned by DPOTRF.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dpstf20000644000175000017500000000701712502223526016417 0ustar uwabamiuwabami--- :name: dpstf2 :md5sum: a3c2b199ffdc016a07d33dd0e50b9821 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - piv: :type: integer :intent: output :dims: - n - rank: :type: integer :intent: output - tol: :type: doublereal :intent: input - work: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPSTF2 computes the Cholesky factorization with complete\n\ * pivoting of a real symmetric positive semidefinite matrix A.\n\ *\n\ * The factorization has the form\n\ * P' * A * P = U' * U , if UPLO = 'U',\n\ * P' * A * P = L * L', if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is lower triangular, and\n\ * P is stored as vector PIV.\n\ *\n\ * This algorithm does not attempt to check that A is positive\n\ * semidefinite. This version of the algorithm calls level 2 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * n by n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n by n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the factor U or L from the Cholesky\n\ * factorization as above.\n\ *\n\ * PIV (output) INTEGER array, dimension (N)\n\ * PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n\ *\n\ * RANK (output) INTEGER\n\ * The rank of A given by the number of steps the algorithm\n\ * completed.\n\ *\n\ * TOL (input) DOUBLE PRECISION\n\ * User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) )\n\ * will be used. The algorithm terminates at the (K-1)st step\n\ * if the pivot <= TOL.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n\ * Work space.\n\ *\n\ * INFO (output) INTEGER\n\ * < 0: If INFO = -K, the K-th argument had an illegal value,\n\ * = 0: algorithm completed successfully, and\n\ * > 0: the matrix A is either rank deficient with computed rank\n\ * as returned in RANK, or is indefinite. See Section 7 of\n\ * LAPACK Working Note #161 for further information.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chegvx0000644000175000017500000002331512502223525016477 0ustar uwabamiuwabami--- :name: chegvx :md5sum: b4362162a760701dc3d2cf4c491046f0 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - "lsame_(&jobz,\"N\") ? 0 : ldz" - "lsame_(&jobz,\"N\") ? 0 : MAX(1,m)" - ldz: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: real :intent: workspace :dims: - 7*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " SUBROUTINE CHEGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHEGVX computes selected eigenvalues, and optionally, eigenvectors\n\ * of a complex generalized Hermitian-definite eigenproblem, of the form\n\ * A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n\ * B are assumed to be Hermitian and B is also positive definite.\n\ * Eigenvalues and eigenvectors can be selected by specifying either a\n\ * range of values or a range of indices for the desired eigenvalues.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * Specifies the problem type to be solved:\n\ * = 1: A*x = (lambda)*B*x\n\ * = 2: A*B*x = (lambda)*x\n\ * = 3: B*A*x = (lambda)*x\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found.\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found.\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ **\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA, N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of A contains the\n\ * upper triangular part of the matrix A. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of A contains\n\ * the lower triangular part of the matrix A.\n\ *\n\ * On exit, the lower triangle (if UPLO='L') or the upper\n\ * triangle (if UPLO='U') of A, including the diagonal, is\n\ * destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB, N)\n\ * On entry, the Hermitian matrix B. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of B contains the\n\ * upper triangular part of the matrix B. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of B contains\n\ * the lower triangular part of the matrix B.\n\ *\n\ * On exit, if INFO <= N, the part of B containing the matrix is\n\ * overwritten by the triangular factor U or L from the Cholesky\n\ * factorization B = U**H*U or B = L*L**H.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * VL (input) REAL\n\ * VU (input) REAL\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) REAL\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less than\n\ * or equal to zero, then EPS*|T| will be used in its place,\n\ * where |T| is the 1-norm of the tridiagonal matrix obtained\n\ * by reducing A to tridiagonal form.\n\ *\n\ * Eigenvalues will be computed most accurately when ABSTOL is\n\ * set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n\ * If this routine returns with INFO>0, indicating that some\n\ * eigenvectors did not converge, try setting ABSTOL to\n\ * 2*SLAMCH('S').\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * The first M elements contain the selected\n\ * eigenvalues in ascending order.\n\ *\n\ * Z (output) COMPLEX array, dimension (LDZ, max(1,M))\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix A\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * The eigenvectors are normalized as follows:\n\ * if ITYPE = 1 or 2, Z**T*B*Z = I;\n\ * if ITYPE = 3, Z**T*inv(B)*Z = I.\n\ *\n\ * If an eigenvector fails to converge, then that column of Z\n\ * contains the latest approximation to the eigenvector, and the\n\ * index of the eigenvector is returned in IFAIL.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of the array WORK. LWORK >= max(1,2*N).\n\ * For optimal efficiency, LWORK >= (NB+1)*N,\n\ * where NB is the blocksize for CHETRD returned by ILAENV.\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\ * RWORK (workspace) REAL array, dimension (7*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (5*N)\n\ *\n\ * IFAIL (output) INTEGER array, dimension (N)\n\ * If JOBZ = 'V', then if INFO = 0, the first M elements of\n\ * IFAIL are zero. If INFO > 0, then IFAIL contains the\n\ * indices of the eigenvectors that failed to converge.\n\ * If JOBZ = 'N', then IFAIL is not referenced.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: CPOTRF or CHEEVX returned an error code:\n\ * <= N: if INFO = i, CHEEVX failed to converge;\n\ * i eigenvectors failed to converge. Their indices\n\ * are stored in array IFAIL.\n\ * > N: if INFO = N + i, for 1 <= i <= N, then the leading\n\ * minor of order i of B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlags20000644000175000017500000000572612502223526016376 0ustar uwabamiuwabami--- :name: dlags2 :md5sum: 2770fd9e10b95116026d93397ade969b :category: :subroutine :arguments: - upper: :type: logical :intent: input - a1: :type: doublereal :intent: input - a2: :type: doublereal :intent: input - a3: :type: doublereal :intent: input - b1: :type: doublereal :intent: input - b2: :type: doublereal :intent: input - b3: :type: doublereal :intent: input - csu: :type: doublereal :intent: output - snu: :type: doublereal :intent: output - csv: :type: doublereal :intent: output - snv: :type: doublereal :intent: output - csq: :type: doublereal :intent: output - snq: :type: doublereal :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, SNV, CSQ, SNQ )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such\n\ * that if ( UPPER ) then\n\ *\n\ * U'*A*Q = U'*( A1 A2 )*Q = ( x 0 )\n\ * ( 0 A3 ) ( x x )\n\ * and\n\ * V'*B*Q = V'*( B1 B2 )*Q = ( x 0 )\n\ * ( 0 B3 ) ( x x )\n\ *\n\ * or if ( .NOT.UPPER ) then\n\ *\n\ * U'*A*Q = U'*( A1 0 )*Q = ( x x )\n\ * ( A2 A3 ) ( 0 x )\n\ * and\n\ * V'*B*Q = V'*( B1 0 )*Q = ( x x )\n\ * ( B2 B3 ) ( 0 x )\n\ *\n\ * The rows of the transformed A and B are parallel, where\n\ *\n\ * U = ( CSU SNU ), V = ( CSV SNV ), Q = ( CSQ SNQ )\n\ * ( -SNU CSU ) ( -SNV CSV ) ( -SNQ CSQ )\n\ *\n\ * Z' denotes the transpose of Z.\n\ *\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPPER (input) LOGICAL\n\ * = .TRUE.: the input matrices A and B are upper triangular.\n\ * = .FALSE.: the input matrices A and B are lower triangular.\n\ *\n\ * A1 (input) DOUBLE PRECISION\n\ * A2 (input) DOUBLE PRECISION\n\ * A3 (input) DOUBLE PRECISION\n\ * On entry, A1, A2 and A3 are elements of the input 2-by-2\n\ * upper (lower) triangular matrix A.\n\ *\n\ * B1 (input) DOUBLE PRECISION\n\ * B2 (input) DOUBLE PRECISION\n\ * B3 (input) DOUBLE PRECISION\n\ * On entry, B1, B2 and B3 are elements of the input 2-by-2\n\ * upper (lower) triangular matrix B.\n\ *\n\ * CSU (output) DOUBLE PRECISION\n\ * SNU (output) DOUBLE PRECISION\n\ * The desired orthogonal matrix U.\n\ *\n\ * CSV (output) DOUBLE PRECISION\n\ * SNV (output) DOUBLE PRECISION\n\ * The desired orthogonal matrix V.\n\ *\n\ * CSQ (output) DOUBLE PRECISION\n\ * SNQ (output) DOUBLE PRECISION\n\ * The desired orthogonal matrix Q.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zla_lin_berr0000644000175000017500000000524412502223526017657 0ustar uwabamiuwabami--- :name: zla_lin_berr :md5sum: 47f37ceeda0e82d8850d983f22cb3407 :category: :subroutine :arguments: - n: :type: integer :intent: input - nz: :type: integer :intent: input - nrhs: :type: integer :intent: input - res: :type: doublereal :intent: input :dims: - n - nrhs - ayb: :type: doublereal :intent: input :dims: - n - nrhs - berr: :type: doublecomplex :intent: output :dims: - nrhs :substitutions: {} :fortran_help: " SUBROUTINE ZLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLA_LIN_BERR computes componentwise relative backward error from\n\ * the formula\n\ * max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n\ * where abs(Z) is the componentwise absolute value of the matrix\n\ * or vector Z.\n\ *\n\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NZ (input) INTEGER\n\ * We add (NZ+1)*SLAMCH( 'Safe minimum' ) to R(i) in the numerator to\n\ * guard against spuriously zero residuals. Default value is N.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices AYB, RES, and BERR. NRHS >= 0.\n\ *\n\ * RES (input) DOUBLE PRECISION array, dimension (N,NRHS)\n\ * The residual matrix, i.e., the matrix R in the relative backward\n\ * error formula above.\n\ *\n\ * AYB (input) DOUBLE PRECISION array, dimension (N, NRHS)\n\ * The denominator in the relative backward error formula above, i.e.,\n\ * the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B\n\ * are from iterative refinement (see zla_gerfsx_extended.f).\n\ * \n\ * BERR (output) COMPLEX*16 array, dimension (NRHS)\n\ * The componentwise relative backward error from the formula above.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n DOUBLE PRECISION TMP\n INTEGER I, J\n COMPLEX*16 CDUM\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, REAL, DIMAG, MAX\n\ * ..\n\ * .. External Functions ..\n EXTERNAL DLAMCH\n DOUBLE PRECISION DLAMCH\n DOUBLE PRECISION SAFE1\n\ * ..\n\ * .. Statement Functions ..\n COMPLEX*16 CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slaqsy0000644000175000017500000000574412502223526016536 0ustar uwabamiuwabami--- :name: slaqsy :md5sum: a3447ffd7f39e12333b7d19bff28a03a :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - s: :type: real :intent: input :dims: - n - scond: :type: real :intent: input - amax: :type: real :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAQSY equilibrates a symmetric matrix A using the scaling factors\n\ * in the vector S.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * n by n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n by n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if EQUED = 'Y', the equilibrated matrix:\n\ * diag(S) * A * diag(S).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(N,1).\n\ *\n\ * S (input) REAL array, dimension (N)\n\ * The scale factors for A.\n\ *\n\ * SCOND (input) REAL\n\ * Ratio of the smallest S(i) to the largest S(i).\n\ *\n\ * AMAX (input) REAL\n\ * Absolute value of largest matrix entry.\n\ *\n\ * EQUED (output) CHARACTER*1\n\ * Specifies whether or not equilibration was done.\n\ * = 'N': No equilibration.\n\ * = 'Y': Equilibration was done, i.e., A has been replaced by\n\ * diag(S) * A * diag(S).\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * THRESH is a threshold value used to decide if scaling should be done\n\ * based on the ratio of the scaling factors. If SCOND < THRESH,\n\ * scaling is done.\n\ *\n\ * LARGE and SMALL are threshold values used to decide if scaling should\n\ * be done based on the absolute size of the largest matrix element.\n\ * If AMAX > LARGE or AMAX < SMALL, scaling is done.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgeql20000644000175000017500000000510012502223526016401 0ustar uwabamiuwabami--- :name: sgeql2 :md5sum: d3fdd8a2b8cb93ae73236c79e8143f4e :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - MIN(m,n) - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGEQL2( M, N, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGEQL2 computes a QL factorization of a real m by n matrix A:\n\ * A = Q * L.\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) REAL array, dimension (LDA,N)\n\ * On entry, the m by n matrix A.\n\ * On exit, if m >= n, the lower triangle of the subarray\n\ * A(m-n+1:m,1:n) contains the n by n lower triangular matrix L;\n\ * if m <= n, the elements on and below the (n-m)-th\n\ * superdiagonal contain the m by n lower trapezoidal matrix L;\n\ * the remaining elements, with the array TAU, represent the\n\ * orthogonal matrix Q as a product of elementary reflectors\n\ * (see Further Details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (output) REAL array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace) REAL array, dimension (N)\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(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n\ * A(1:m-k+i-1,n-k+i), and tau in TAU(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cla_syrcond_x0000644000175000017500000000650412502223525020043 0ustar uwabamiuwabami--- :name: cla_syrcond_x :md5sum: 3ac4221b1dcc11fa685d99f3692f1e54 :category: :function :type: real :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - x: :type: complex :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: complex :intent: input :dims: - 2*n - rwork: :type: real :intent: input :dims: - n :substitutions: {} :fortran_help: " REAL FUNCTION CLA_SYRCOND_X( UPLO, N, A, LDA, AF, LDAF, IPIV, X, INFO, WORK, RWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLA_SYRCOND_X Computes the infinity norm condition number of\n\ * op(A) * diag(X) where X is a COMPLEX vector.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX array, dimension (LDAF,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by CSYTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by CSYTRF.\n\ *\n\ * X (input) COMPLEX array, dimension (N)\n\ * The vector X in the formula op(A) * diag(X).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * i > 0: The ith argument is invalid.\n\ *\n\ * WORK (input) COMPLEX array, dimension (2*N).\n\ * Workspace.\n\ *\n\ * RWORK (input) REAL array, dimension (N).\n\ * Workspace.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER KASE\n REAL AINVNM, ANORM, TMP\n INTEGER I, J\n LOGICAL UP\n COMPLEX ZDUM\n\ * ..\n\ * .. Local Arrays ..\n INTEGER ISAVE( 3 )\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CLACN2, CSYTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n\ * ..\n\ * .. Statement Functions ..\n REAL CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slatbs0000644000175000017500000001670712502223526016513 0ustar uwabamiuwabami--- :name: slatbs :md5sum: 69ca3033afbf9a346aae44ab6b621fc0 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - normin: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - n - scale: :type: real :intent: output - cnorm: :type: real :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, SCALE, CNORM, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLATBS solves one of the triangular systems\n\ *\n\ * A *x = s*b or A'*x = s*b\n\ *\n\ * with scaling to prevent overflow, where A is an upper or lower\n\ * triangular band matrix. Here A' denotes the transpose of A, x and b\n\ * are n-element vectors, and s is a scaling factor, usually less than\n\ * or equal to 1, chosen so that the components of x will be less than\n\ * the overflow threshold. If the unscaled problem will not cause\n\ * overflow, the Level 2 BLAS routine STBSV is called. If the matrix A\n\ * is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n\ * non-trivial solution to A*x = 0 is returned.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the matrix A is upper or lower triangular.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the operation applied to A.\n\ * = 'N': Solve A * x = s*b (No transpose)\n\ * = 'T': Solve A'* x = s*b (Transpose)\n\ * = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * Specifies whether or not the matrix A is unit triangular.\n\ * = 'N': Non-unit triangular\n\ * = 'U': Unit triangular\n\ *\n\ * NORMIN (input) CHARACTER*1\n\ * Specifies whether CNORM has been set or not.\n\ * = 'Y': CNORM contains the column norms on entry\n\ * = 'N': CNORM is not set on entry. On exit, the norms will\n\ * be computed and stored in CNORM.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of subdiagonals or superdiagonals in the\n\ * triangular matrix A. KD >= 0.\n\ *\n\ * AB (input) REAL array, dimension (LDAB,N)\n\ * The upper or lower triangular band matrix A, stored in the\n\ * first KD+1 rows of the array. The j-th column of A is stored\n\ * in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * X (input/output) REAL array, dimension (N)\n\ * On entry, the right hand side b of the triangular system.\n\ * On exit, X is overwritten by the solution vector x.\n\ *\n\ * SCALE (output) REAL\n\ * The scaling factor s for the triangular system\n\ * A * x = s*b or A'* x = s*b.\n\ * If SCALE = 0, the matrix A is singular or badly scaled, and\n\ * the vector x is an exact or approximate solution to A*x = 0.\n\ *\n\ * CNORM (input or output) REAL array, dimension (N)\n\ *\n\ * If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n\ * contains the norm of the off-diagonal part of the j-th column\n\ * of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n\ * to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n\ * must be greater than or equal to the 1-norm.\n\ *\n\ * If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n\ * returns the 1-norm of the offdiagonal part of the j-th column\n\ * of A.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ *\n\n\ * Further Details\n\ * ======= =======\n\ *\n\ * A rough bound on x is computed; if that is less than overflow, STBSV\n\ * is called, otherwise, specific code is used which checks for possible\n\ * overflow or divide-by-zero at every operation.\n\ *\n\ * A columnwise scheme is used for solving A*x = b. The basic algorithm\n\ * if A is lower triangular is\n\ *\n\ * x[1:n] := b[1:n]\n\ * for j = 1, ..., n\n\ * x(j) := x(j) / A(j,j)\n\ * x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n\ * end\n\ *\n\ * Define bounds on the components of x after j iterations of the loop:\n\ * M(j) = bound on x[1:j]\n\ * G(j) = bound on x[j+1:n]\n\ * Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n\ *\n\ * Then for iteration j+1 we have\n\ * M(j+1) <= G(j) / | A(j+1,j+1) |\n\ * G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n\ * <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n\ *\n\ * where CNORM(j+1) is greater than or equal to the infinity-norm of\n\ * column j+1 of A, not counting the diagonal. Hence\n\ *\n\ * G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n\ * 1<=i<=j\n\ * and\n\ *\n\ * |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n\ * 1<=i< j\n\ *\n\ * Since |x(j)| <= M(j), we use the Level 2 BLAS routine STBSV if the\n\ * reciprocal of the largest M(j), j=1,..,n, is larger than\n\ * max(underflow, 1/overflow).\n\ *\n\ * The bound on x(j) is also used to determine when a step in the\n\ * columnwise method can be performed without fear of overflow. If\n\ * the computed bound is greater than a large constant, x is scaled to\n\ * prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n\ * 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n\ *\n\ * Similarly, a row-wise scheme is used to solve A'*x = b. The basic\n\ * algorithm for A upper triangular is\n\ *\n\ * for j = 1, ..., n\n\ * x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n\ * end\n\ *\n\ * We simultaneously compute two bounds\n\ * G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n\ * M(j) = bound on x(i), 1<=i<=j\n\ *\n\ * The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n\ * add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n\ * Then the bound on x(j) is\n\ *\n\ * M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n\ *\n\ * <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n\ * 1<=i<=j\n\ *\n\ * and we can safely call STBSV if 1/M(n) and 1/G(n) are both greater\n\ * than max(underflow, 1/overflow).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zla_herpvgrw0000644000175000017500000000630412502223526017725 0ustar uwabamiuwabami--- :name: zla_herpvgrw :md5sum: c7a4c2c50b491711138d57d30bf2f509 :category: :function :type: doublereal :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - info: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublecomplex :intent: input :dims: - 2*n :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION ZLA_HERPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, WORK )\n\n\ * Purpose\n\ * =======\n\ * \n\ * ZLA_HERPVGRW computes the reciprocal pivot growth factor\n\ * norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n\ * much less than 1, the stability of the LU factorization of the\n\ * (equilibrated) matrix A could be poor. This also means that the\n\ * solution X, estimated condition numbers, and error bounds could be\n\ * unreliable.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * INFO (input) INTEGER\n\ * The value of INFO returned from ZHETRF, .i.e., the pivot in\n\ * column INFO is exactly 0.\n\ *\n\ * NCOLS (input) INTEGER\n\ * The number of columns of the matrix A. NCOLS >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX*16 array, dimension (LDAF,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by ZHETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by ZHETRF.\n\ *\n\ * WORK (input) COMPLEX*16 array, dimension (2*N)\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER NCOLS, I, J, K, KP\n DOUBLE PRECISION AMAX, UMAX, RPVGRW, TMP\n LOGICAL UPPER, LSAME\n COMPLEX*16 ZDUM\n\ * ..\n\ * .. External Functions ..\n EXTERNAL LSAME, ZLASET\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, REAL, DIMAG, MAX, MIN\n\ * ..\n\ * .. Statement Functions ..\n DOUBLE PRECISION CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE ( ZDUM ) ) + ABS( DIMAG ( ZDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlaed90000644000175000017500000001023512502223526016353 0ustar uwabamiuwabami--- :name: dlaed9 :md5sum: e45625c97ed5b50036009a7a23bf1afd :category: :subroutine :arguments: - k: :type: integer :intent: input - kstart: :type: integer :intent: input - kstop: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - MAX(1,n) - q: :type: doublereal :intent: workspace :dims: - ldq - MAX(1,n) - ldq: :type: integer :intent: input - rho: :type: doublereal :intent: input - dlamda: :type: doublereal :intent: input :dims: - k - w: :type: doublereal :intent: input :dims: - k - s: :type: doublereal :intent: output :dims: - lds - k - lds: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: ldq: MAX( 1, n ) lds: MAX( 1, k ) :fortran_help: " SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W, S, LDS, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAED9 finds the roots of the secular equation, as defined by the\n\ * values in D, Z, and RHO, between KSTART and KSTOP. It makes the\n\ * appropriate calls to DLAED4 and then stores the new matrix of\n\ * eigenvectors for use in calculating the next level of Z vectors.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * K (input) INTEGER\n\ * The number of terms in the rational function to be solved by\n\ * DLAED4. K >= 0.\n\ *\n\ * KSTART (input) INTEGER\n\ * KSTOP (input) INTEGER\n\ * The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP\n\ * are to be computed. 1 <= KSTART <= KSTOP <= K.\n\ *\n\ * N (input) INTEGER\n\ * The number of rows and columns in the Q matrix.\n\ * N >= K (delation may result in N > K).\n\ *\n\ * D (output) DOUBLE PRECISION array, dimension (N)\n\ * D(I) contains the updated eigenvalues\n\ * for KSTART <= I <= KSTOP.\n\ *\n\ * Q (workspace) DOUBLE PRECISION array, dimension (LDQ,N)\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max( 1, N ).\n\ *\n\ * RHO (input) DOUBLE PRECISION\n\ * The value of the parameter in the rank one update equation.\n\ * RHO >= 0 required.\n\ *\n\ * DLAMDA (input) DOUBLE PRECISION array, dimension (K)\n\ * The first K elements of this array contain the old roots\n\ * of the deflated updating problem. These are the poles\n\ * of the secular equation.\n\ *\n\ * W (input) DOUBLE PRECISION array, dimension (K)\n\ * The first K elements of this array contain the components\n\ * of the deflation-adjusted updating vector.\n\ *\n\ * S (output) DOUBLE PRECISION array, dimension (LDS, K)\n\ * Will contain the eigenvectors of the repaired matrix which\n\ * will be stored for subsequent Z vector calculation and\n\ * multiplied by the previously accumulated eigenvectors\n\ * to update the system.\n\ *\n\ * LDS (input) INTEGER\n\ * The leading dimension of S. LDS >= max( 1, K ).\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 = 1, an eigenvalue did not converge\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Jeff Rutter, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n DOUBLE PRECISION TEMP\n\ * ..\n\ * .. External Functions ..\n DOUBLE PRECISION DLAMC3, DNRM2\n EXTERNAL DLAMC3, DNRM2\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DCOPY, DLAED4, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, SIGN, SQRT\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/stbcon0000644000175000017500000000624312502223526016505 0ustar uwabamiuwabami--- :name: stbcon :md5sum: a27a8931aed80bb492d80c96ccc10853 :category: :subroutine :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - rcond: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE STBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STBCON estimates the reciprocal of the condition number of a\n\ * triangular band matrix A, in either the 1-norm or the infinity-norm.\n\ *\n\ * The norm of A is computed and an estimate is obtained for\n\ * norm(inv(A)), then the reciprocal of the condition number is\n\ * computed as\n\ * RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies whether the 1-norm condition number or the\n\ * infinity-norm condition number is required:\n\ * = '1' or 'O': 1-norm;\n\ * = 'I': Infinity-norm.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals or subdiagonals of the\n\ * triangular band matrix A. KD >= 0.\n\ *\n\ * AB (input) REAL array, dimension (LDAB,N)\n\ * The upper or lower triangular band matrix A, stored in the\n\ * first kd+1 rows of the array. The j-th column of A is stored\n\ * in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ * If DIAG = 'U', the diagonal elements of A are not referenced\n\ * and are assumed to be 1.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * RCOND (output) REAL\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(norm(A) * norm(inv(A))).\n\ *\n\ * WORK (workspace) REAL array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sla_syamv0000644000175000017500000001114012502223526017203 0ustar uwabamiuwabami--- :name: sla_syamv :md5sum: 3fe7d0b46433be548d70a984dd25ac3e :category: :subroutine :arguments: - uplo: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: real :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: real :intent: input :dims: - 1 + ( n - 1 )*abs( incx ) - incx: :type: integer :intent: input - beta: :type: real :intent: input - y: :type: real :intent: input/output :dims: - 1 + ( n - 1 )*abs( incy ) - incy: :type: integer :intent: input :substitutions: lda: MAX(1, n) :fortran_help: " SUBROUTINE SLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLA_SYAMV performs the matrix-vector operation\n\ *\n\ * y := alpha*abs(A)*abs(x) + beta*abs(y),\n\ *\n\ * where alpha and beta are scalars, x and y are vectors and A is an\n\ * n by n symmetric matrix.\n\ *\n\ * This function is primarily used in calculating error bounds.\n\ * To protect against underflow during evaluation, components in\n\ * the resulting vector are perturbed away from zero by (N+1)\n\ * times the underflow threshold. To prevent unnecessarily large\n\ * errors for block-structure embedded in general matrices,\n\ * \"symbolically\" zero components are not perturbed. A zero\n\ * entry is considered \"symbolic\" if all multiplications involved\n\ * in computing that entry have at least one zero multiplicand.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * UPLO (input) INTEGER\n\ * On entry, UPLO specifies whether the upper or lower\n\ * triangular part of the array A is to be referenced as\n\ * follows:\n\ *\n\ * UPLO = BLAS_UPPER Only the upper triangular part of A\n\ * is to be referenced.\n\ *\n\ * UPLO = BLAS_LOWER Only the lower triangular part of A\n\ * is to be referenced.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the number of columns of the matrix A.\n\ * N must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * ALPHA (input) REAL .\n\ * On entry, ALPHA specifies the scalar alpha.\n\ * Unchanged on exit.\n\ *\n\ * A - REAL array of DIMENSION ( LDA, n ).\n\ * Before entry, the leading m by n part of the array A must\n\ * contain the matrix of coefficients.\n\ * Unchanged on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * On entry, LDA specifies the first dimension of A as declared\n\ * in the calling (sub) program. LDA must be at least\n\ * max( 1, n ).\n\ * Unchanged on exit.\n\ *\n\ * X (input) REAL array, dimension\n\ * ( 1 + ( n - 1 )*abs( INCX ) )\n\ * Before entry, the incremented array X must contain the\n\ * vector x.\n\ * Unchanged on exit.\n\ *\n\ * INCX (input) INTEGER\n\ * On entry, INCX specifies the increment for the elements of\n\ * X. INCX must not be zero.\n\ * Unchanged on exit.\n\ *\n\ * BETA (input) REAL .\n\ * On entry, BETA specifies the scalar beta. When BETA is\n\ * supplied as zero then Y need not be set on input.\n\ * Unchanged on exit.\n\ *\n\ * Y (input/output) REAL array, dimension\n\ * ( 1 + ( n - 1 )*abs( INCY ) )\n\ * Before entry with BETA non-zero, the incremented array Y\n\ * must contain the vector y. On exit, Y is overwritten by the\n\ * updated vector y.\n\ *\n\ * INCY (input) INTEGER\n\ * On entry, INCY specifies the increment for the elements of\n\ * Y. INCY must not be zero.\n\ * Unchanged on exit.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Level 2 Blas routine.\n\ *\n\ * -- Written on 22-October-1986.\n\ * Jack Dongarra, Argonne National Lab.\n\ * Jeremy Du Croz, Nag Central Office.\n\ * Sven Hammarling, Nag Central Office.\n\ * Richard Hanson, Sandia National Labs.\n\ * -- Modified for the absolute-value product, April 2006\n\ * Jason Riedy, UC Berkeley\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssptrf0000644000175000017500000001153612502223526016537 0ustar uwabamiuwabami--- :name: ssptrf :md5sum: d4d9ba30e2725b29813df249be3729ce :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - ldap - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE SSPTRF( UPLO, N, AP, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSPTRF computes the factorization of a real symmetric matrix A stored\n\ * in packed format using the Bunch-Kaufman diagonal pivoting method:\n\ *\n\ * A = U*D*U**T or A = L*D*L**T\n\ *\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, and D is symmetric and block diagonal with\n\ * 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) REAL array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L, stored as a packed triangular\n\ * matrix overwriting A (see below for further details).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D.\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\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, D(i,i) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular, and division by zero will occur if it\n\ * is used to solve a system of equations.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * 5-96 - Based on modifications by J. Lewis, Boeing Computer Services\n\ * Company\n\ *\n\ * If UPLO = 'U', then A = U*D*U', where\n\ * U = P(n)*U(n)* ... *P(k)U(k)* ...,\n\ * i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n\ * 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I v 0 ) k-s\n\ * U(k) = ( 0 I 0 ) s\n\ * ( 0 0 I ) n-k\n\ * k-s s n-k\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n\ * If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n\ * and A(k,k), and v overwrites A(1:k-2,k-1:k).\n\ *\n\ * If UPLO = 'L', then A = L*D*L', where\n\ * L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n\ * i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n\ * n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I 0 0 ) k-1\n\ * L(k) = ( 0 I 0 ) s\n\ * ( 0 v I ) n-k-s+1\n\ * k-1 s n-k-s+1\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n\ * If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n\ * and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhegs20000644000175000017500000000576412502223526016426 0ustar uwabamiuwabami--- :name: zhegs2 :md5sum: 807744acbc0fa9344d5087a32c297268 :category: :subroutine :arguments: - itype: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHEGS2 reduces a complex Hermitian-definite generalized\n\ * eigenproblem to standard form.\n\ *\n\ * If ITYPE = 1, the problem is A*x = lambda*B*x,\n\ * and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')\n\ *\n\ * If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n\ * B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.\n\ *\n\ * B must have been previously factorized as U'*U or L*L' by ZPOTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');\n\ * = 2 or 3: compute U*A*U' or L'*A*L.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * Hermitian matrix A is stored, and how B has been factorized.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the leading\n\ * n by n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n by n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the transformed matrix, stored in the\n\ * same format as A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,N)\n\ * The triangular factor from the Cholesky factorization of B,\n\ * as returned by ZPOTRF.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgesc20000644000175000017500000000455112502223526016364 0ustar uwabamiuwabami--- :name: dgesc2 :md5sum: 2545d85fa9c437128db2590785846062 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - rhs: :type: doublereal :intent: input/output :dims: - n - ipiv: :type: integer :intent: input :dims: - n - jpiv: :type: integer :intent: input :dims: - n - scale: :type: doublereal :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGESC2 solves a system of linear equations\n\ *\n\ * A * X = scale* RHS\n\ *\n\ * with a general N-by-N matrix A using the LU factorization with\n\ * complete pivoting computed by DGETC2.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the LU part of the factorization of the n-by-n\n\ * matrix A computed by DGETC2: A = P * L * U * Q\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1, N).\n\ *\n\ * RHS (input/output) DOUBLE PRECISION array, dimension (N).\n\ * On entry, the right hand side vector b.\n\ * On exit, the solution vector X.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N).\n\ * The pivot indices; for 1 <= i <= N, row i of the\n\ * matrix has been interchanged with row IPIV(i).\n\ *\n\ * JPIV (input) INTEGER array, dimension (N).\n\ * The pivot indices; for 1 <= j <= N, column j of the\n\ * matrix has been interchanged with column JPIV(j).\n\ *\n\ * SCALE (output) DOUBLE PRECISION\n\ * On exit, SCALE contains the scale factor. SCALE is chosen\n\ * 0 <= SCALE <= 1 to prevent owerflow in the solution.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sggbak0000644000175000017500000000735112502223526016454 0ustar uwabamiuwabami--- :name: sggbak :md5sum: 578f59f90aa7528cd8b5d765afa93309 :category: :subroutine :arguments: - job: :type: char :intent: input - side: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - lscale: :type: real :intent: input :dims: - n - rscale: :type: real :intent: input :dims: - n - m: :type: integer :intent: input - v: :type: real :intent: input/output :dims: - ldv - m - ldv: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGGBAK forms the right or left eigenvectors of a real generalized\n\ * eigenvalue problem A*x = lambda*B*x, by backward transformation on\n\ * the computed eigenvectors of the balanced pair of matrices output by\n\ * SGGBAL.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * Specifies the type of backward transformation required:\n\ * = 'N': do nothing, return immediately;\n\ * = 'P': do backward transformation for permutation only;\n\ * = 'S': do backward transformation for scaling only;\n\ * = 'B': do backward transformations for both permutation and\n\ * scaling.\n\ * JOB must be the same as the argument JOB supplied to SGGBAL.\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'R': V contains right eigenvectors;\n\ * = 'L': V contains left eigenvectors.\n\ *\n\ * N (input) INTEGER\n\ * The number of rows of the matrix V. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * The integers ILO and IHI determined by SGGBAL.\n\ * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n\ *\n\ * LSCALE (input) REAL array, dimension (N)\n\ * Details of the permutations and/or scaling factors applied\n\ * to the left side of A and B, as returned by SGGBAL.\n\ *\n\ * RSCALE (input) REAL array, dimension (N)\n\ * Details of the permutations and/or scaling factors applied\n\ * to the right side of A and B, as returned by SGGBAL.\n\ *\n\ * M (input) INTEGER\n\ * The number of columns of the matrix V. M >= 0.\n\ *\n\ * V (input/output) REAL array, dimension (LDV,M)\n\ * On entry, the matrix of right or left eigenvectors to be\n\ * transformed, as returned by STGEVC.\n\ * On exit, V is overwritten by the transformed eigenvectors.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the matrix V. LDV >= max(1,N).\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\ * See R.C. Ward, Balancing the generalized eigenvalue problem,\n\ * SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LEFTV, RIGHTV\n INTEGER I, K\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SSCAL, SSWAP, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/ssytrs0000644000175000017500000000474712502223526016573 0ustar uwabamiuwabami--- :name: ssytrs :md5sum: 20324ae4a550ed249f9ba27d627ce9cd :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSYTRS solves a system of linear equations A*X = B with a real\n\ * symmetric matrix A using the factorization A = U*D*U**T or\n\ * A = L*D*L**T computed by SSYTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by SSYTRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by SSYTRF.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlargv0000644000175000017500000000375712502223526016503 0ustar uwabamiuwabami--- :name: dlargv :md5sum: af0943ce2244e6b1a773daa080bf4a76 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - y: :type: doublereal :intent: input/output :dims: - 1+(n-1)*incy - incy: :type: integer :intent: input - c: :type: doublereal :intent: output :dims: - 1+(n-1)*incc - incc: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE DLARGV( N, X, INCX, Y, INCY, C, INCC )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLARGV generates a vector of real plane rotations, determined by\n\ * elements of the real vectors x and y. For i = 1,2,...,n\n\ *\n\ * ( c(i) s(i) ) ( x(i) ) = ( a(i) )\n\ * ( -s(i) c(i) ) ( y(i) ) = ( 0 )\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of plane rotations to be generated.\n\ *\n\ * X (input/output) DOUBLE PRECISION array,\n\ * dimension (1+(N-1)*INCX)\n\ * On entry, the vector x.\n\ * On exit, x(i) is overwritten by a(i), for i = 1,...,n.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between elements of X. INCX > 0.\n\ *\n\ * Y (input/output) DOUBLE PRECISION array,\n\ * dimension (1+(N-1)*INCY)\n\ * On entry, the vector y.\n\ * On exit, the sines of the plane rotations.\n\ *\n\ * INCY (input) INTEGER\n\ * The increment between elements of Y. INCY > 0.\n\ *\n\ * C (output) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)\n\ * The cosines of the plane rotations.\n\ *\n\ * INCC (input) INTEGER\n\ * The increment between elements of C. INCC > 0.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dpbtf20000644000175000017500000000712612502223526016377 0ustar uwabamiuwabami--- :name: dpbtf2 :md5sum: a0c868c2ec6bdfb965b1e3b3e37bf6f3 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPBTF2( UPLO, N, KD, AB, LDAB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPBTF2 computes the Cholesky factorization of a real symmetric\n\ * positive definite band matrix A.\n\ *\n\ * The factorization has the form\n\ * A = U' * U , if UPLO = 'U', or\n\ * A = L * L', if UPLO = 'L',\n\ * where U is an upper triangular matrix, U' is the transpose of U, and\n\ * L is lower triangular.\n\ *\n\ * This is the unblocked version of the algorithm, calling Level 2 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of super-diagonals of the matrix A if UPLO = 'U',\n\ * or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * On exit, if INFO = 0, the triangular factor U or L from the\n\ * Cholesky factorization A = U'*U or A = L*L' of the band\n\ * matrix A, in the same storage format as A.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ * > 0: if INFO = k, the leading minor of order k is not\n\ * positive definite, and the factorization could not be\n\ * completed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * N = 6, KD = 2, and UPLO = 'U':\n\ *\n\ * On entry: On exit:\n\ *\n\ * * * a13 a24 a35 a46 * * u13 u24 u35 u46\n\ * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n\ * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n\ *\n\ * Similarly, if UPLO = 'L' the format of A is as follows:\n\ *\n\ * On entry: On exit:\n\ *\n\ * a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n\ * a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n\ * a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n\ *\n\ * Array elements marked * are not used by the routine.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhpsv0000644000175000017500000001156212502223526016367 0ustar uwabamiuwabami--- :name: zhpsv :md5sum: 0713716e5e44cdc4522b3e60e4cd557d :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: output :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: n: ldb :fortran_help: " SUBROUTINE ZHPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHPSV computes the solution to a complex system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N Hermitian matrix stored in packed format and X\n\ * and B are N-by-NRHS matrices.\n\ *\n\ * The diagonal pivoting method is used to factor A as\n\ * A = U * D * U**H, if UPLO = 'U', or\n\ * A = L * D * L**H, if UPLO = 'L',\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, D is Hermitian and block diagonal with 1-by-1\n\ * and 2-by-2 diagonal blocks. The factored form of A is then used to\n\ * solve the system of equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ * See below for further details.\n\ *\n\ * On exit, the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L from the factorization\n\ * A = U*D*U**H or A = L*D*L**H as computed by ZHPTRF, stored as\n\ * a packed triangular matrix in the same storage format as A.\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D, as\n\ * determined by ZHPTRF. If IPIV(k) > 0, then rows and columns\n\ * k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n\ * diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n\ * then rows and columns k-1 and -IPIV(k) were interchanged and\n\ * D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n\ * IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n\ * -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n\ * diagonal block.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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, D(i,i) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular, so the solution could not be\n\ * computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The packed storage scheme is illustrated by the following example\n\ * when N = 4, UPLO = 'U':\n\ *\n\ * Two-dimensional storage of the Hermitian matrix A:\n\ *\n\ * a11 a12 a13 a14\n\ * a22 a23 a24\n\ * a33 a34 (aij = conjg(aji))\n\ * a44\n\ *\n\ * Packed storage of the upper triangle of A:\n\ *\n\ * AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n\ *\n\ * =====================================================================\n\ *\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZHPTRF, ZHPTRS\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dtfttp0000644000175000017500000001247312502223526016524 0ustar uwabamiuwabami--- :name: dtfttp :md5sum: 5a4746cb4cd86d64545e91aae7dfdcc8 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - arf: :type: doublereal :intent: input :dims: - ( n*(n+1)/2 ) - ap: :type: doublereal :intent: output :dims: - ( n*(n+1)/2 ) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DTFTTP( TRANSR, UPLO, N, ARF, AP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTFTTP copies a triangular matrix A from rectangular full packed\n\ * format (TF) to standard packed format (TP).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': ARF is in Normal format;\n\ * = 'T': ARF is in Transpose format;\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * ARF (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ),\n\ * On entry, the upper or lower triangular matrix A stored in\n\ * RFP format. For a further discussion see Notes below.\n\ *\n\ * AP (output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ),\n\ * On exit, the upper or lower triangular matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\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\ * We first consider Rectangular Full Packed (RFP) Format when N is\n\ * even. We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * the transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * the transpose of the last three columns of AP lower.\n\ * This covers the case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 04 05 33 43 53\n\ * 13 14 15 00 44 54\n\ * 23 24 25 10 11 55\n\ * 33 34 35 20 21 22\n\ * 00 44 45 30 31 32\n\ * 01 11 55 40 41 42\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We then consider Rectangular Full Packed (RFP) Format when N is\n\ * odd. We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * the transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * the transpose of the last two columns of AP lower.\n\ * This covers the case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 03 04 00 33 43\n\ * 12 13 14 10 11 44\n\ * 22 23 24 20 21 22\n\ * 00 33 34 30 31 32\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cbdsqr0000644000175000017500000001574112502223525016475 0ustar uwabamiuwabami--- :name: cbdsqr :md5sum: 2ab59917ff5e0610f9099f32c4b9bca8 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ncvt: :type: integer :intent: input - nru: :type: integer :intent: input - ncc: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - vt: :type: complex :intent: input/output :dims: - ldvt - ncvt - ldvt: :type: integer :intent: input - u: :type: complex :intent: input/output :dims: - ldu - n - ldu: :type: integer :intent: input - c: :type: complex :intent: input/output :dims: - ldc - ncc - ldc: :type: integer :intent: input - rwork: :type: real :intent: workspace :dims: - "(ncvt==nru)&&(nru==ncc)&&(ncc==0) ? 2*n : MAX(1, 4*n-4)" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CBDSQR computes the singular values and, optionally, the right and/or\n\ * left singular vectors from the singular value decomposition (SVD) of\n\ * a real N-by-N (upper or lower) bidiagonal matrix B using the implicit\n\ * zero-shift QR algorithm. The SVD of B has the form\n\ * \n\ * B = Q * S * P**H\n\ * \n\ * where S is the diagonal matrix of singular values, Q is an orthogonal\n\ * matrix of left singular vectors, and P is an orthogonal matrix of\n\ * right singular vectors. If left singular vectors are requested, this\n\ * subroutine actually returns U*Q instead of Q, and, if right singular\n\ * vectors are requested, this subroutine returns P**H*VT instead of\n\ * P**H, for given complex input matrices U and VT. When U and VT are\n\ * the unitary matrices that reduce a general matrix A to bidiagonal\n\ * form: A = U*B*VT, as computed by CGEBRD, then\n\ * \n\ * A = (U*Q) * S * (P**H*VT)\n\ * \n\ * is the SVD of A. Optionally, the subroutine may also compute Q**H*C\n\ * for a given complex input matrix C.\n\ *\n\ * See \"Computing Small Singular Values of Bidiagonal Matrices With\n\ * Guaranteed High Relative Accuracy,\" by J. Demmel and W. Kahan,\n\ * LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,\n\ * no. 5, pp. 873-912, Sept 1990) and\n\ * \"Accurate singular values and differential qd algorithms,\" by\n\ * B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics\n\ * Department, University of California at Berkeley, July 1992\n\ * for a detailed description of the algorithm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': B is upper bidiagonal;\n\ * = 'L': B is lower bidiagonal.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix B. N >= 0.\n\ *\n\ * NCVT (input) INTEGER\n\ * The number of columns of the matrix VT. NCVT >= 0.\n\ *\n\ * NRU (input) INTEGER\n\ * The number of rows of the matrix U. NRU >= 0.\n\ *\n\ * NCC (input) INTEGER\n\ * The number of columns of the matrix C. NCC >= 0.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the n diagonal elements of the bidiagonal matrix B.\n\ * On exit, if INFO=0, the singular values of B in decreasing\n\ * order.\n\ *\n\ * E (input/output) REAL array, dimension (N-1)\n\ * On entry, the N-1 offdiagonal elements of the bidiagonal\n\ * matrix B.\n\ * On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E\n\ * will contain the diagonal and superdiagonal elements of a\n\ * bidiagonal matrix orthogonally equivalent to the one given\n\ * as input.\n\ *\n\ * VT (input/output) COMPLEX array, dimension (LDVT, NCVT)\n\ * On entry, an N-by-NCVT matrix VT.\n\ * On exit, VT is overwritten by P**H * VT.\n\ * Not referenced if NCVT = 0.\n\ *\n\ * LDVT (input) INTEGER\n\ * The leading dimension of the array VT.\n\ * LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.\n\ *\n\ * U (input/output) COMPLEX array, dimension (LDU, N)\n\ * On entry, an NRU-by-N matrix U.\n\ * On exit, U is overwritten by U * Q.\n\ * Not referenced if NRU = 0.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= max(1,NRU).\n\ *\n\ * C (input/output) COMPLEX array, dimension (LDC, NCC)\n\ * On entry, an N-by-NCC matrix C.\n\ * On exit, C is overwritten by Q**H * C.\n\ * Not referenced if NCC = 0.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C.\n\ * LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.\n\ *\n\ * RWORK (workspace) REAL array, dimension (2*N) \n\ * if NCVT = NRU = NCC = 0, (max(1, 4*N-4)) otherwise\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: If INFO = -i, the i-th argument had an illegal value\n\ * > 0: the algorithm did not converge; D and E contain the\n\ * elements of a bidiagonal matrix which is orthogonally\n\ * similar to the input matrix B; if INFO = i, i\n\ * elements of E have not converged to zero.\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * TOLMUL REAL, default = max(10,min(100,EPS**(-1/8)))\n\ * TOLMUL controls the convergence criterion of the QR loop.\n\ * If it is positive, TOLMUL*EPS is the desired relative\n\ * precision in the computed singular values.\n\ * If it is negative, abs(TOLMUL*EPS*sigma_max) is the\n\ * desired absolute accuracy in the computed singular\n\ * values (corresponds to relative accuracy\n\ * abs(TOLMUL*EPS) in the largest singular value.\n\ * abs(TOLMUL) should be between 1 and 1/EPS, and preferably\n\ * between 10 (for fast convergence) and .1/EPS\n\ * (for there to be some accuracy in the results).\n\ * Default is to lose at either one eighth or 2 of the\n\ * available decimal digits in each computed singular value\n\ * (whichever is smaller).\n\ *\n\ * MAXITR INTEGER, default = 6\n\ * MAXITR controls the maximum number of passes of the\n\ * algorithm through its inner loop. The algorithms stops\n\ * (and so fails to converge) if the number of passes\n\ * through the inner loop exceeds MAXITR*N**2.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgtsv0000644000175000017500000000561312502223525016342 0ustar uwabamiuwabami--- :name: cgtsv :md5sum: 70ece7626a7de0599058891e16ed41ae :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: complex :intent: input/output :dims: - n-1 - d: :type: complex :intent: input/output :dims: - n - du: :type: complex :intent: input/output :dims: - n-1 - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGTSV solves the equation\n\ *\n\ * A*X = B,\n\ *\n\ * where A is an N-by-N tridiagonal matrix, by Gaussian elimination with\n\ * partial pivoting.\n\ *\n\ * Note that the equation A'*X = B may be solved by interchanging the\n\ * order of the arguments DU and DL.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * DL (input/output) COMPLEX array, dimension (N-1)\n\ * On entry, DL must contain the (n-1) subdiagonal elements of\n\ * A.\n\ * On exit, DL is overwritten by the (n-2) elements of the\n\ * second superdiagonal of the upper triangular matrix U from\n\ * the LU factorization of A, in DL(1), ..., DL(n-2).\n\ *\n\ * D (input/output) COMPLEX array, dimension (N)\n\ * On entry, D must contain the diagonal elements of A.\n\ * On exit, D is overwritten by the n diagonal elements of U.\n\ *\n\ * DU (input/output) COMPLEX array, dimension (N-1)\n\ * On entry, DU must contain the (n-1) superdiagonal elements\n\ * of A.\n\ * On exit, DU is overwritten by the (n-1) elements of the first\n\ * superdiagonal of U.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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, U(i,i) is exactly zero, and the solution\n\ * has not been computed. The factorization has not been\n\ * completed unless i = N.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cla_hercond_x0000644000175000017500000000643512502223525020007 0ustar uwabamiuwabami--- :name: cla_hercond_x :md5sum: 92fff2de9005dc3e2f76fc1542552543 :category: :function :type: real :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - x: :type: complex :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: complex :intent: input :dims: - 2*n - rwork: :type: real :intent: input :dims: - n :substitutions: {} :fortran_help: " REAL FUNCTION CLA_HERCOND_X( UPLO, N, A, LDA, AF, LDAF, IPIV, X, INFO, WORK, RWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLA_HERCOND_X computes the infinity norm condition number of\n\ * op(A) * diag(X) where X is a COMPLEX vector.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX array, dimension (LDAF,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by CHETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by CHETRF.\n\ *\n\ * X (input) COMPLEX array, dimension (N)\n\ * The vector X in the formula op(A) * diag(X).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * i > 0: The ith argument is invalid.\n\ *\n\ * WORK (input) COMPLEX array, dimension (2*N).\n\ * Workspace.\n\ *\n\ * RWORK (input) REAL array, dimension (N).\n\ * Workspace.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER KASE, I, J\n REAL AINVNM, ANORM, TMP\n LOGICAL UP\n COMPLEX ZDUM\n\ * ..\n\ * .. Local Arrays ..\n INTEGER ISAVE( 3 )\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CLACN2, CHETRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n\ * ..\n\ * .. Statement Functions ..\n REAL CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slarfg0000644000175000017500000000355412502223526016475 0ustar uwabamiuwabami--- :name: slarfg :md5sum: 98062fabc987bc9e49a64e0408fef3cc :category: :subroutine :arguments: - n: :type: integer :intent: input - alpha: :type: real :intent: input/output - x: :type: real :intent: input/output :dims: - 1+(n-2)*abs(incx) - incx: :type: integer :intent: input - tau: :type: real :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLARFG( N, ALPHA, X, INCX, TAU )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLARFG generates a real elementary reflector H of order n, such\n\ * that\n\ *\n\ * H * ( alpha ) = ( beta ), H' * H = I.\n\ * ( x ) ( 0 )\n\ *\n\ * where alpha and beta are scalars, and x is an (n-1)-element real\n\ * vector. H is represented in the form\n\ *\n\ * H = I - tau * ( 1 ) * ( 1 v' ) ,\n\ * ( v )\n\ *\n\ * where tau is a real scalar and v is a real (n-1)-element\n\ * vector.\n\ *\n\ * If the elements of x are all zero, then tau = 0 and H is taken to be\n\ * the unit matrix.\n\ *\n\ * Otherwise 1 <= tau <= 2.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the elementary reflector.\n\ *\n\ * ALPHA (input/output) REAL\n\ * On entry, the value alpha.\n\ * On exit, it is overwritten with the value beta.\n\ *\n\ * X (input/output) REAL array, dimension\n\ * (1+(N-2)*abs(INCX))\n\ * On entry, the vector x.\n\ * On exit, it is overwritten with the vector v.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between elements of X. INCX > 0.\n\ *\n\ * TAU (output) REAL\n\ * The value tau.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cppequ0000644000175000017500000000535312502223525016512 0ustar uwabamiuwabami--- :name: cppequ :md5sum: 1f019efc434c1da34e8b0c380a3dbce8 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - ldap - s: :type: real :intent: output :dims: - n - scond: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE CPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPPEQU computes row and column scalings intended to equilibrate a\n\ * Hermitian positive definite matrix A in packed storage and reduce\n\ * its condition number (with respect to the two-norm). S contains the\n\ * scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix\n\ * B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.\n\ * This choice of S puts the condition number of B within a factor N of\n\ * the smallest possible condition number over all possible diagonal\n\ * scalings.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input) COMPLEX array, dimension (N*(N+1)/2)\n\ * The upper or lower triangle of the Hermitian matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * S (output) REAL array, dimension (N)\n\ * If INFO = 0, S contains the scale factors for A.\n\ *\n\ * SCOND (output) REAL\n\ * If INFO = 0, S contains the ratio of the smallest S(i) to\n\ * the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n\ * large nor too small, it is not worth scaling by S.\n\ *\n\ * AMAX (output) REAL\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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 is nonpositive.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhbevd0000644000175000017500000001645312502223526016503 0ustar uwabamiuwabami--- :name: zhbevd :md5sum: 106aa15cb26a281f9d3f65ba8715cae8 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 2*n*n : 0" - rwork: :type: doublereal :intent: output :dims: - MAX(1,lrwork) - lrwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" :fortran_help: " SUBROUTINE ZHBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHBEVD computes all the eigenvalues and, optionally, eigenvectors of\n\ * a complex Hermitian band matrix A. If eigenvectors are desired, it\n\ * uses a divide and conquer algorithm.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) COMPLEX*16 array, dimension (LDAB, N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * On exit, AB is overwritten by values generated during the\n\ * reduction to tridiagonal form. If UPLO = 'U', the first\n\ * superdiagonal and the diagonal of the tridiagonal matrix T\n\ * are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n\ * the diagonal and first subdiagonal of T are returned in the\n\ * first two rows of AB.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD + 1.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) COMPLEX*16 array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n\ * eigenvectors of the matrix A, with the i-th column of Z\n\ * holding the eigenvector associated with W(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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\ * If N <= 1, LWORK must be at least 1.\n\ * If JOBZ = 'N' and N > 1, LWORK must be at least N.\n\ * If JOBZ = 'V' and N > 1, LWORK must be at least 2*N**2.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the optimal sizes of the WORK, RWORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * RWORK (workspace/output) DOUBLE PRECISION array,\n\ * dimension (LRWORK)\n\ * On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n\ *\n\ * LRWORK (input) INTEGER\n\ * The dimension of array RWORK.\n\ * If N <= 1, LRWORK must be at least 1.\n\ * If JOBZ = 'N' and N > 1, LRWORK must be at least N.\n\ * If JOBZ = 'V' and N > 1, LRWORK must be at least\n\ * 1 + 5*N + 2*N**2.\n\ *\n\ * If LRWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of array IWORK.\n\ * If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.\n\ * If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N .\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK 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 algorithm failed to converge; i\n\ * off-diagonal elements of an intermediate tridiagonal\n\ * form did not converge to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlartgs0000644000175000017500000000307612502223526016656 0ustar uwabamiuwabami--- :name: dlartgs :md5sum: bf0292e885c671bdbb8046966e02a27e :category: :subroutine :arguments: - x: :type: doublereal :intent: input - y: :type: doublereal :intent: input - sigma: :type: doublereal :intent: input - cs: :type: doublereal :intent: output - sn: :type: doublereal :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLARTGS( X, Y, SIGMA, CS, SN )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLARTGS generates a plane rotation designed to introduce a bulge in\n\ * Golub-Reinsch-style implicit QR iteration for the bidiagonal SVD\n\ * problem. X and Y are the top-row entries, and SIGMA is the shift.\n\ * The computed CS and SN define a plane rotation satisfying\n\ *\n\ * [ CS SN ] . [ X^2 - SIGMA ] = [ R ],\n\ * [ -SN CS ] [ X * Y ] [ 0 ]\n\ *\n\ * with R nonnegative. If X^2 - SIGMA and X * Y are 0, then the\n\ * rotation is by PI/2.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * X (input) DOUBLE PRECISION\n\ * The (1,1) entry of an upper bidiagonal matrix.\n\ *\n\ * Y (input) DOUBLE PRECISION\n\ * The (1,2) entry of an upper bidiagonal matrix.\n\ *\n\ * SIGMA (input) DOUBLE PRECISION\n\ * The shift.\n\ *\n\ * CS (output) DOUBLE PRECISION\n\ * The cosine of the rotation.\n\ *\n\ * SN (output) DOUBLE PRECISION\n\ * The sine of the rotation.\n\ *\n\n\ * ===================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zla_gbrcond_c0000644000175000017500000001070512502223526020001 0ustar uwabamiuwabami--- :name: zla_gbrcond_c :md5sum: 1dcbea81eec20033235e6bc8b3fbb4c5 :category: :function :type: doublereal :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublecomplex :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - c: :type: doublereal :intent: input :dims: - n - capply: :type: logical :intent: input - info: :type: integer :intent: output - work: :type: doublecomplex :intent: input :dims: - 2*n - rwork: :type: doublereal :intent: input :dims: - n :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION ZLA_GBRCOND_C( TRANS, N, KL, KU, AB, LDAB, AFB, LDAFB, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLA_GBRCOND_C Computes the infinity norm condition number of\n\ * op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate Transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * AB (input) COMPLEX*16 array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * AFB (input) COMPLEX*16 array, dimension (LDAFB,N)\n\ * Details of the LU factorization of the band matrix A, as\n\ * computed by ZGBTRF. U is stored as an upper triangular\n\ * band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n\ * and the multipliers used during the factorization are stored\n\ * in rows KL+KU+2 to 2*KL+KU+1.\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from the factorization A = P*L*U\n\ * as computed by ZGBTRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension (N)\n\ * The vector C in the formula op(A) * inv(diag(C)).\n\ *\n\ * CAPPLY (input) LOGICAL\n\ * If .TRUE. then access the vector C in the formula above.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * i > 0: The ith argument is invalid.\n\ *\n\ * WORK (input) COMPLEX*16 array, dimension (2*N).\n\ * Workspace.\n\ *\n\ * RWORK (input) DOUBLE PRECISION array, dimension (N).\n\ * Workspace.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE, I, J\n DOUBLE PRECISION AINVNM, ANORM, TMP\n COMPLEX*16 ZDUM\n\ * ..\n\ * .. Local Arrays ..\n INTEGER ISAVE( 3 )\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL ZLACN2, ZGBTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n\ * ..\n\ * .. Statement Functions ..\n DOUBLE PRECISION CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/xerbla_array0000644000175000017500000000427212502223526017670 0ustar uwabamiuwabami--- :name: xerbla_array :md5sum: 320702fa47907817bf73aecb5577c631 :category: :subroutine :arguments: - srname_array: :type: char :intent: input :dims: - srname_len - srname_len: :type: integer :intent: input - info: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE XERBLA_ARRAY( SRNAME_ARRAY, SRNAME_LEN, INFO)\n\n\ * Purpose\n\ * =======\n\ *\n\ * XERBLA_ARRAY assists other languages in calling XERBLA, the LAPACK\n\ * and BLAS error handler. Rather than taking a Fortran string argument\n\ * as the function's name, XERBLA_ARRAY takes an array of single\n\ * characters along with the array's length. XERBLA_ARRAY then copies\n\ * up to 32 characters of that array into a Fortran string and passes\n\ * that to XERBLA. If called with a non-positive SRNAME_LEN,\n\ * XERBLA_ARRAY will call XERBLA with a string of all blank characters.\n\ *\n\ * Say some macro or other device makes XERBLA_ARRAY available to C99\n\ * by a name lapack_xerbla and with a common Fortran calling convention.\n\ * Then a C99 program could invoke XERBLA via:\n\ * {\n\ * int flen = strlen(__func__);\n\ * lapack_xerbla(__func__, &flen, &info);\n\ * }\n\ *\n\ * Providing XERBLA_ARRAY is not necessary for intercepting LAPACK\n\ * errors. XERBLA_ARRAY calls XERBLA.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SRNAME_ARRAY (input) CHARACTER(1) array, dimension (SRNAME_LEN)\n\ * The name of the routine which called XERBLA_ARRAY.\n\ *\n\ * SRNAME_LEN (input) INTEGER\n\ * The length of the name in SRNAME_ARRAY.\n\ *\n\ * INFO (input) INTEGER\n\ * The position of the invalid parameter in the parameter list\n\ * of the calling routine.\n\ *\n\n\ * =====================================================================\n\ *\n\ * ..\n\ * .. Local Scalars ..\n INTEGER I\n\ * ..\n\ * .. Local Arrays ..\n CHARACTER*32 SRNAME\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MIN, LEN\n\ * ..\n\ * .. External Functions ..\n EXTERNAL XERBLA\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dpptri0000644000175000017500000000364612502223526016523 0ustar uwabamiuwabami--- :name: dpptri :md5sum: aa52068aa972b2b1a3d2d96115563353 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPPTRI( UPLO, N, AP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPPTRI computes the inverse of a real symmetric positive definite\n\ * matrix A using the Cholesky factorization A = U**T*U or A = L*L**T\n\ * computed by DPPTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangular factor is stored in AP;\n\ * = 'L': Lower triangular factor is stored in AP.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * On entry, the triangular factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T, packed columnwise as\n\ * a linear array. The j-th column of U or L is stored in the\n\ * array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n\ *\n\ * On exit, the upper or lower triangle of the (symmetric)\n\ * inverse of A, overwriting the input factor U or L.\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,i) element of the factor U or L is\n\ * zero, and the inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zpteqr0000644000175000017500000001046512502223526016543 0ustar uwabamiuwabami--- :name: zpteqr :md5sum: 1e06269af9687b8590d9765151765c50 :category: :subroutine :arguments: - compz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - z: :type: doublecomplex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPTEQR computes all eigenvalues and, optionally, eigenvectors of a\n\ * symmetric positive definite tridiagonal matrix by first factoring the\n\ * matrix using DPTTRF and then calling ZBDSQR to compute the singular\n\ * values of the bidiagonal factor.\n\ *\n\ * This routine computes the eigenvalues of the positive definite\n\ * tridiagonal matrix to high relative accuracy. This means that if the\n\ * eigenvalues range over many orders of magnitude in size, then the\n\ * small eigenvalues and corresponding eigenvectors will be computed\n\ * more accurately than, for example, with the standard QR method.\n\ *\n\ * The eigenvectors of a full or band positive definite Hermitian matrix\n\ * can also be found if ZHETRD, ZHPTRD, or ZHBTRD has been used to\n\ * reduce this matrix to tridiagonal form. (The reduction to\n\ * tridiagonal form, however, may preclude the possibility of obtaining\n\ * high relative accuracy in the small eigenvalues of the original\n\ * matrix, if these eigenvalues range over many orders of magnitude.)\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * COMPZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only.\n\ * = 'V': Compute eigenvectors of original Hermitian\n\ * matrix also. Array Z contains the unitary matrix\n\ * used to reduce the original matrix to tridiagonal\n\ * form.\n\ * = 'I': Compute eigenvectors of tridiagonal matrix also.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the n diagonal elements of the tridiagonal matrix.\n\ * On normal exit, D contains the eigenvalues, in descending\n\ * order.\n\ *\n\ * E (input/output) DOUBLE PRECISION array, dimension (N-1)\n\ * On entry, the (n-1) subdiagonal elements of the tridiagonal\n\ * matrix.\n\ * On exit, E has been destroyed.\n\ *\n\ * Z (input/output) COMPLEX*16 array, dimension (LDZ, N)\n\ * On entry, if COMPZ = 'V', the unitary matrix used in the\n\ * reduction to tridiagonal form.\n\ * On exit, if COMPZ = 'V', the orthonormal eigenvectors of the\n\ * original Hermitian matrix;\n\ * if COMPZ = 'I', the orthonormal eigenvectors of the\n\ * tridiagonal matrix.\n\ * If INFO > 0 on exit, Z contains the eigenvectors associated\n\ * with only the stored eigenvalues.\n\ * If COMPZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * COMPZ = 'V' or 'I', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\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, and i is:\n\ * <= N the Cholesky factorization of the matrix could\n\ * not be performed because the i-th principal minor\n\ * was not positive definite.\n\ * > N the SVD algorithm failed to converge;\n\ * if INFO = N+i, i off-diagonal elements of the\n\ * bidiagonal factor did not converge to zero.\n\ *\n\n\ * ====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dpbstf0000644000175000017500000000765212502223526016504 0ustar uwabamiuwabami--- :name: dpbstf :md5sum: 5a40047148b7bdd37c15d29462a47190 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPBSTF( UPLO, N, KD, AB, LDAB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPBSTF computes a split Cholesky factorization of a real\n\ * symmetric positive definite band matrix A.\n\ *\n\ * This routine is designed to be used in conjunction with DSBGST.\n\ *\n\ * The factorization has the form A = S**T*S where S is a band matrix\n\ * of the same bandwidth as A and the following structure:\n\ *\n\ * S = ( U )\n\ * ( M L )\n\ *\n\ * where U is upper triangular of order m = (n+kd)/2, and L is lower\n\ * triangular of order n-m.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first kd+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * On exit, if INFO = 0, the factor S from the split Cholesky\n\ * factorization A = S**T*S. See Further Details.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\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 factorization could not be completed,\n\ * because the updated element a(i,i) was negative; the\n\ * matrix A is not positive definite.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * N = 7, KD = 2:\n\ *\n\ * S = ( s11 s12 s13 )\n\ * ( s22 s23 s24 )\n\ * ( s33 s34 )\n\ * ( s44 )\n\ * ( s53 s54 s55 )\n\ * ( s64 s65 s66 )\n\ * ( s75 s76 s77 )\n\ *\n\ * If UPLO = 'U', the array AB holds:\n\ *\n\ * on entry: on exit:\n\ *\n\ * * * a13 a24 a35 a46 a57 * * s13 s24 s53 s64 s75\n\ * * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54 s65 s76\n\ * a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77\n\ *\n\ * If UPLO = 'L', the array AB holds:\n\ *\n\ * on entry: on exit:\n\ *\n\ * a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77\n\ * a21 a32 a43 a54 a65 a76 * s12 s23 s34 s54 s65 s76 *\n\ * a31 a42 a53 a64 a64 * * s13 s24 s53 s64 s75 * *\n\ *\n\ * Array elements marked * are not used by the routine.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgeqrf0000644000175000017500000000730312502223526016463 0ustar uwabamiuwabami--- :name: dgeqrf :md5sum: eff1033d66c3942bfe1fce5ed78f7b1d :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - MIN(m,n) - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGEQRF computes a QR factorization of a real M-by-N matrix A:\n\ * A = Q * R.\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 above the diagonal of the array\n\ * contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n\ * upper triangular if m >= n); the elements below the diagonal,\n\ * with the array TAU, represent the orthogonal matrix Q as a\n\ * product of min(m,n) elementary reflectors (see Further\n\ * 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,N).\n\ * For optimum performance LWORK >= N*NB, where NB is\n\ * the 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(1) H(2) . . . H(k), 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:m) is stored on exit in A(i+1:m,i),\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 DGEQR2, DLARFB, DLARFT, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/clangt0000644000175000017500000000425112502223525016461 0ustar uwabamiuwabami--- :name: clangt :md5sum: 652ea6ab81e8f71ce9bebc5bc9493bb5 :category: :function :type: real :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - dl: :type: complex :intent: input :dims: - n-1 - d: :type: complex :intent: input :dims: - n - du: :type: complex :intent: input :dims: - n-1 :substitutions: {} :fortran_help: " REAL FUNCTION CLANGT( NORM, N, DL, D, DU )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLANGT returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * complex tridiagonal matrix A.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * CLANGT returns the value\n\ *\n\ * CLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in CLANGT as described\n\ * above.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, CLANGT is\n\ * set to zero.\n\ *\n\ * DL (input) COMPLEX array, dimension (N-1)\n\ * The (n-1) sub-diagonal elements of A.\n\ *\n\ * D (input) COMPLEX array, dimension (N)\n\ * The diagonal elements of A.\n\ *\n\ * DU (input) COMPLEX array, dimension (N-1)\n\ * The (n-1) super-diagonal elements of A.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlapmt0000644000175000017500000000402512502223526016520 0ustar uwabamiuwabami--- :name: zlapmt :md5sum: 591f8631e725fd98463952019c2571aa :category: :subroutine :arguments: - forwrd: :type: logical :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input - k: :type: integer :intent: input/output :dims: - n :substitutions: {} :fortran_help: " SUBROUTINE ZLAPMT( FORWRD, M, N, X, LDX, K )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAPMT rearranges the columns of the M by N matrix X as specified\n\ * by the permutation K(1),K(2),...,K(N) of the integers 1,...,N.\n\ * If FORWRD = .TRUE., forward permutation:\n\ *\n\ * X(*,K(J)) is moved X(*,J) for J = 1,2,...,N.\n\ *\n\ * If FORWRD = .FALSE., backward permutation:\n\ *\n\ * X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FORWRD (input) LOGICAL\n\ * = .TRUE., forward permutation\n\ * = .FALSE., backward permutation\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix X. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix X. N >= 0.\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension (LDX,N)\n\ * On entry, the M by N matrix X.\n\ * On exit, X contains the permuted matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X, LDX >= MAX(1,M).\n\ *\n\ * K (input/output) INTEGER array, dimension (N)\n\ * On entry, K contains the permutation vector. K is used as\n\ * internal workspace, but reset to its original value on\n\ * output.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, II, IN, J\n COMPLEX*16 TEMP\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dggbal0000644000175000017500000001203312502223526016427 0ustar uwabamiuwabami--- :name: dggbal :md5sum: 24ff4f10c5e8790d8d13027b9337a32b :category: :subroutine :arguments: - job: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - lscale: :type: doublereal :intent: output :dims: - n - rscale: :type: doublereal :intent: output :dims: - n - work: :type: doublereal :intent: workspace :dims: - "(lsame_(&job,\"S\")||lsame_(&job,\"B\")) ? MAX(1,6*n) : (lsame_(&job,\"N\")||lsame_(&job,\"P\")) ? 1 : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGGBAL balances a pair of general real matrices (A,B). This\n\ * involves, first, permuting A and B by similarity transformations to\n\ * isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N\n\ * elements on the diagonal; and second, applying a diagonal similarity\n\ * transformation to rows and columns ILO to IHI to make the rows\n\ * and columns as close in norm as possible. Both steps are optional.\n\ *\n\ * Balancing may reduce the 1-norm of the matrices, and improve the\n\ * accuracy of the computed eigenvalues and/or eigenvectors in the\n\ * generalized eigenvalue problem A*x = lambda*B*x.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * Specifies the operations to be performed on A and B:\n\ * = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0\n\ * and RSCALE(I) = 1.0 for i = 1,...,N.\n\ * = 'P': permute only;\n\ * = 'S': scale only;\n\ * = 'B': both permute and scale.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the input matrix A.\n\ * On exit, A is overwritten by the balanced matrix.\n\ * If JOB = 'N', A is not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,N)\n\ * On entry, the input matrix B.\n\ * On exit, B is overwritten by the balanced matrix.\n\ * If JOB = 'N', B is not referenced.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * ILO (output) INTEGER\n\ * IHI (output) INTEGER\n\ * ILO and IHI are set to integers such that on exit\n\ * A(i,j) = 0 and B(i,j) = 0 if i > j and\n\ * j = 1,...,ILO-1 or i = IHI+1,...,N.\n\ * If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n\ *\n\ * LSCALE (output) DOUBLE PRECISION array, dimension (N)\n\ * Details of the permutations and scaling factors applied\n\ * to the left side of A and B. If P(j) is the index of the\n\ * row interchanged with row j, and D(j)\n\ * is the scaling factor applied to row j, then\n\ * LSCALE(j) = P(j) for J = 1,...,ILO-1\n\ * = D(j) for J = ILO,...,IHI\n\ * = P(j) for J = IHI+1,...,N.\n\ * The order in which the interchanges are made is N to IHI+1,\n\ * then 1 to ILO-1.\n\ *\n\ * RSCALE (output) DOUBLE PRECISION array, dimension (N)\n\ * Details of the permutations and scaling factors applied\n\ * to the right side of A and B. If P(j) is the index of the\n\ * column interchanged with column j, and D(j)\n\ * is the scaling factor applied to column j, then\n\ * LSCALE(j) = P(j) for J = 1,...,ILO-1\n\ * = D(j) for J = ILO,...,IHI\n\ * = P(j) for J = IHI+1,...,N.\n\ * The order in which the interchanges are made is N to IHI+1,\n\ * then 1 to ILO-1.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (lwork)\n\ * lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and\n\ * at least 1 when JOB = 'N' or 'P'.\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\ * See R.C. WARD, Balancing the generalized eigenvalue problem,\n\ * SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cspcon0000644000175000017500000000503512502223525016477 0ustar uwabamiuwabami--- :name: cspcon :md5sum: 2693ebd7b761444b3518da41dddce980 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: complex :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSPCON estimates the reciprocal of the condition number (in the\n\ * 1-norm) of a complex symmetric packed matrix A using the\n\ * factorization A = U*D*U**T or A = L*D*L**T computed by CSPTRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input) COMPLEX array, dimension (N*(N+1)/2)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by CSPTRF, stored as a\n\ * packed triangular matrix.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by CSPTRF.\n\ *\n\ * ANORM (input) REAL\n\ * The 1-norm of the original matrix A.\n\ *\n\ * RCOND (output) REAL\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n\ * estimate of the 1-norm of inv(A) computed in this routine.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/stgsy20000644000175000017500000002061612502223526016450 0ustar uwabamiuwabami--- :name: stgsy2 :md5sum: 649807c96dfdbfb124fdd5574fd71dd9 :category: :subroutine :arguments: - trans: :type: char :intent: input - ijob: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - m - lda: :type: integer :intent: input - b: :type: real :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - d: :type: real :intent: input :dims: - ldd - m - ldd: :type: integer :intent: input - e: :type: real :intent: input :dims: - lde - n - lde: :type: integer :intent: input - f: :type: real :intent: input/output :dims: - ldf - n - ldf: :type: integer :intent: input - scale: :type: real :intent: output - rdsum: :type: real :intent: input/output - rdscal: :type: real :intent: input/output - iwork: :type: integer :intent: workspace :dims: - m+n+2 - pq: :type: integer :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE STGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, IWORK, PQ, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STGSY2 solves the generalized Sylvester equation:\n\ *\n\ * A * R - L * B = scale * C (1)\n\ * D * R - L * E = scale * F,\n\ *\n\ * using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices,\n\ * (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,\n\ * N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E)\n\ * must be in generalized Schur canonical form, i.e. A, B are upper\n\ * quasi triangular and D, E are upper triangular. The solution (R, L)\n\ * overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor\n\ * chosen to avoid overflow.\n\ *\n\ * In matrix notation solving equation (1) corresponds to solve\n\ * Z*x = scale*b, where Z is defined as\n\ *\n\ * Z = [ kron(In, A) -kron(B', Im) ] (2)\n\ * [ kron(In, D) -kron(E', Im) ],\n\ *\n\ * Ik is the identity matrix of size k and X' is the transpose of X.\n\ * kron(X, Y) is the Kronecker product between the matrices X and Y.\n\ * In the process of solving (1), we solve a number of such systems\n\ * where Dim(In), Dim(In) = 1 or 2.\n\ *\n\ * If TRANS = 'T', solve the transposed system Z'*y = scale*b for y,\n\ * which is equivalent to solve for R and L in\n\ *\n\ * A' * R + D' * L = scale * C (3)\n\ * R * B' + L * E' = scale * -F\n\ *\n\ * This case is used to compute an estimate of Dif[(A, D), (B, E)] =\n\ * sigma_min(Z) using reverse communicaton with SLACON.\n\ *\n\ * STGSY2 also (IJOB >= 1) contributes to the computation in STGSYL\n\ * of an upper bound on the separation between to matrix pairs. Then\n\ * the input (A, D), (B, E) are sub-pencils of the matrix pair in\n\ * STGSYL. See STGSYL for details.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N', solve the generalized Sylvester equation (1).\n\ * = 'T': solve the 'transposed' system (3).\n\ *\n\ * IJOB (input) INTEGER\n\ * Specifies what kind of functionality to be performed.\n\ * = 0: solve (1) only.\n\ * = 1: A contribution from this subsystem to a Frobenius\n\ * norm-based estimate of the separation between two matrix\n\ * pairs is computed. (look ahead strategy is used).\n\ * = 2: A contribution from this subsystem to a Frobenius\n\ * norm-based estimate of the separation between two matrix\n\ * pairs is computed. (SGECON on sub-systems is used.)\n\ * Not referenced if TRANS = 'T'.\n\ *\n\ * M (input) INTEGER\n\ * On entry, M specifies the order of A and D, and the row\n\ * dimension of C, F, R and L.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the order of B and E, and the column\n\ * dimension of C, F, R and L.\n\ *\n\ * A (input) REAL array, dimension (LDA, M)\n\ * On entry, A contains an upper quasi triangular matrix.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the matrix A. LDA >= max(1, M).\n\ *\n\ * B (input) REAL array, dimension (LDB, N)\n\ * On entry, B contains an upper quasi triangular matrix.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the matrix B. LDB >= max(1, N).\n\ *\n\ * C (input/output) REAL array, dimension (LDC, N)\n\ * On entry, C contains the right-hand-side of the first matrix\n\ * equation in (1).\n\ * On exit, if IJOB = 0, C has been overwritten by the\n\ * solution R.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the matrix C. LDC >= max(1, M).\n\ *\n\ * D (input) REAL array, dimension (LDD, M)\n\ * On entry, D contains an upper triangular matrix.\n\ *\n\ * LDD (input) INTEGER\n\ * The leading dimension of the matrix D. LDD >= max(1, M).\n\ *\n\ * E (input) REAL array, dimension (LDE, N)\n\ * On entry, E contains an upper triangular matrix.\n\ *\n\ * LDE (input) INTEGER\n\ * The leading dimension of the matrix E. LDE >= max(1, N).\n\ *\n\ * F (input/output) REAL array, dimension (LDF, N)\n\ * On entry, F contains the right-hand-side of the second matrix\n\ * equation in (1).\n\ * On exit, if IJOB = 0, F has been overwritten by the\n\ * solution L.\n\ *\n\ * LDF (input) INTEGER\n\ * The leading dimension of the matrix F. LDF >= max(1, M).\n\ *\n\ * SCALE (output) REAL\n\ * On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions\n\ * R and L (C and F on entry) will hold the solutions to a\n\ * slightly perturbed system but the input matrices A, B, D and\n\ * E have not been changed. If SCALE = 0, R and L will hold the\n\ * solutions to the homogeneous system with C = F = 0. Normally,\n\ * SCALE = 1.\n\ *\n\ * RDSUM (input/output) REAL\n\ * On entry, the sum of squares of computed contributions to\n\ * the Dif-estimate under computation by STGSYL, where the\n\ * scaling factor RDSCAL (see below) has been factored out.\n\ * On exit, the corresponding sum of squares updated with the\n\ * contributions from the current sub-system.\n\ * If TRANS = 'T' RDSUM is not touched.\n\ * NOTE: RDSUM only makes sense when STGSY2 is called by STGSYL.\n\ *\n\ * RDSCAL (input/output) REAL\n\ * On entry, scaling factor used to prevent overflow in RDSUM.\n\ * On exit, RDSCAL is updated w.r.t. the current contributions\n\ * in RDSUM.\n\ * If TRANS = 'T', RDSCAL is not touched.\n\ * NOTE: RDSCAL only makes sense when STGSY2 is called by\n\ * STGSYL.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (M+N+2)\n\ *\n\ * PQ (output) INTEGER\n\ * On exit, the number of subsystems (of size 2-by-2, 4-by-4 and\n\ * 8-by-8) solved by this routine.\n\ *\n\ * INFO (output) INTEGER\n\ * On exit, if INFO is set to\n\ * =0: Successful exit\n\ * <0: If INFO = -i, the i-th argument had an illegal value.\n\ * >0: The matrix pairs (A, D) and (B, E) have common or very\n\ * close eigenvalues.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * =====================================================================\n\ * Replaced various illegal calls to SCOPY by calls to SLASET.\n\ * Sven Hammarling, 27/5/02.\n\ *\n" ruby-lapack-1.7.2/dev/defs/cheequb0000644000175000017500000000511412502223525016624 0ustar uwabamiuwabami--- :name: cheequb :md5sum: 9a7a2379d8ae799e5f48006ed943636f :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - s: :type: real :intent: output :dims: - n - scond: :type: real :intent: output - amax: :type: real :intent: output - work: :type: complex :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CHEEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSYEQUB computes row and column scalings intended to equilibrate a\n\ * symmetric matrix A and reduce its condition number\n\ * (with respect to the two-norm). S contains the scale factors,\n\ * S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n\ * elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n\ * choice of S puts the condition number of B within a factor N of the\n\ * smallest possible condition number over all possible diagonal\n\ * scalings.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The N-by-N symmetric matrix whose scaling\n\ * factors are to be computed. Only the diagonal elements of A\n\ * are referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * S (output) REAL array, dimension (N)\n\ * If INFO = 0, S contains the scale factors for A.\n\ *\n\ * SCOND (output) REAL\n\ * If INFO = 0, S contains the ratio of the smallest S(i) to\n\ * the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n\ * large nor too small, it is not worth scaling by S.\n\ *\n\ * AMAX (output) REAL\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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 is nonpositive.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dbdsqr0000644000175000017500000001664412502223526016502 0ustar uwabamiuwabami--- :name: dbdsqr :md5sum: 43c08e3c38f901cfbaf8d922647ff3dd :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ncvt: :type: integer :intent: input - nru: :type: integer :intent: input - ncc: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - vt: :type: doublereal :intent: input/output :dims: - ldvt - ncvt - ldvt: :type: integer :intent: input - u: :type: doublereal :intent: input/output :dims: - ldu - n - ldu: :type: integer :intent: input - c: :type: doublereal :intent: input/output :dims: - ldc - ncc - ldc: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DBDSQR computes the singular values and, optionally, the right and/or\n\ * left singular vectors from the singular value decomposition (SVD) of\n\ * a real N-by-N (upper or lower) bidiagonal matrix B using the implicit\n\ * zero-shift QR algorithm. The SVD of B has the form\n\ * \n\ * B = Q * S * P**T\n\ * \n\ * where S is the diagonal matrix of singular values, Q is an orthogonal\n\ * matrix of left singular vectors, and P is an orthogonal matrix of\n\ * right singular vectors. If left singular vectors are requested, this\n\ * subroutine actually returns U*Q instead of Q, and, if right singular\n\ * vectors are requested, this subroutine returns P**T*VT instead of\n\ * P**T, for given real input matrices U and VT. When U and VT are the\n\ * orthogonal matrices that reduce a general matrix A to bidiagonal\n\ * form: A = U*B*VT, as computed by DGEBRD, then\n\ *\n\ * A = (U*Q) * S * (P**T*VT)\n\ *\n\ * is the SVD of A. Optionally, the subroutine may also compute Q**T*C\n\ * for a given real input matrix C.\n\ *\n\ * See \"Computing Small Singular Values of Bidiagonal Matrices With\n\ * Guaranteed High Relative Accuracy,\" by J. Demmel and W. Kahan,\n\ * LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,\n\ * no. 5, pp. 873-912, Sept 1990) and\n\ * \"Accurate singular values and differential qd algorithms,\" by\n\ * B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics\n\ * Department, University of California at Berkeley, July 1992\n\ * for a detailed description of the algorithm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': B is upper bidiagonal;\n\ * = 'L': B is lower bidiagonal.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix B. N >= 0.\n\ *\n\ * NCVT (input) INTEGER\n\ * The number of columns of the matrix VT. NCVT >= 0.\n\ *\n\ * NRU (input) INTEGER\n\ * The number of rows of the matrix U. NRU >= 0.\n\ *\n\ * NCC (input) INTEGER\n\ * The number of columns of the matrix C. NCC >= 0.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the n diagonal elements of the bidiagonal matrix B.\n\ * On exit, if INFO=0, the singular values of B in decreasing\n\ * order.\n\ *\n\ * E (input/output) DOUBLE PRECISION array, dimension (N-1)\n\ * On entry, the N-1 offdiagonal elements of the bidiagonal\n\ * matrix B. \n\ * On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E\n\ * will contain the diagonal and superdiagonal elements of a\n\ * bidiagonal matrix orthogonally equivalent to the one given\n\ * as input.\n\ *\n\ * VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT)\n\ * On entry, an N-by-NCVT matrix VT.\n\ * On exit, VT is overwritten by P**T * VT.\n\ * Not referenced if NCVT = 0.\n\ *\n\ * LDVT (input) INTEGER\n\ * The leading dimension of the array VT.\n\ * LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.\n\ *\n\ * U (input/output) DOUBLE PRECISION array, dimension (LDU, N)\n\ * On entry, an NRU-by-N matrix U.\n\ * On exit, U is overwritten by U * Q.\n\ * Not referenced if NRU = 0.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= max(1,NRU).\n\ *\n\ * C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC)\n\ * On entry, an N-by-NCC matrix C.\n\ * On exit, C is overwritten by Q**T * C.\n\ * Not referenced if NCC = 0.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C.\n\ * LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: If INFO = -i, the i-th argument had an illegal value\n\ * > 0:\n\ * if NCVT = NRU = NCC = 0,\n\ * = 1, a split was marked by a positive value in E\n\ * = 2, current block of Z not diagonalized after 30*N\n\ * iterations (in inner while loop)\n\ * = 3, termination criterion of outer while loop not met \n\ * (program created more than N unreduced blocks)\n\ * else NCVT = NRU = NCC = 0,\n\ * the algorithm did not converge; D and E contain the\n\ * elements of a bidiagonal matrix which is orthogonally\n\ * similar to the input matrix B; if INFO = i, i\n\ * elements of E have not converged to zero.\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8)))\n\ * TOLMUL controls the convergence criterion of the QR loop.\n\ * If it is positive, TOLMUL*EPS is the desired relative\n\ * precision in the computed singular values.\n\ * If it is negative, abs(TOLMUL*EPS*sigma_max) is the\n\ * desired absolute accuracy in the computed singular\n\ * values (corresponds to relative accuracy\n\ * abs(TOLMUL*EPS) in the largest singular value.\n\ * abs(TOLMUL) should be between 1 and 1/EPS, and preferably\n\ * between 10 (for fast convergence) and .1/EPS\n\ * (for there to be some accuracy in the results).\n\ * Default is to lose at either one eighth or 2 of the\n\ * available decimal digits in each computed singular value\n\ * (whichever is smaller).\n\ *\n\ * MAXITR INTEGER, default = 6\n\ * MAXITR controls the maximum number of passes of the\n\ * algorithm through its inner loop. The algorithms stops\n\ * (and so fails to converge) if the number of passes\n\ * through the inner loop exceeds MAXITR*N**2.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlanhp0000644000175000017500000000572412502223526016514 0ustar uwabamiuwabami--- :name: zlanhp :md5sum: 5e520aeb2ec37a3f0f87b0a8b7b4df17 :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " DOUBLE PRECISION FUNCTION ZLANHP( NORM, UPLO, N, AP, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLANHP returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * complex hermitian matrix A, supplied in packed form.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * ZLANHP returns the value\n\ *\n\ * ZLANHP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in ZLANHP as described\n\ * above.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * hermitian matrix A is supplied.\n\ * = 'U': Upper triangular part of A is supplied\n\ * = 'L': Lower triangular part of A is supplied\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, ZLANHP is\n\ * set to zero.\n\ *\n\ * AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * The upper or lower triangle of the hermitian matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ * Note that the imaginary parts of the diagonal elements need\n\ * not be set and are assumed to be zero.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n\ * WORK is not referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgtts20000644000175000017500000000615612502223526016455 0ustar uwabamiuwabami--- :name: zgtts2 :md5sum: 162d28e29ce7ddeac4dd6a28f9dfc718 :category: :subroutine :arguments: - itrans: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: doublecomplex :intent: input :dims: - n-1 - d: :type: doublecomplex :intent: input :dims: - n - du: :type: doublecomplex :intent: input :dims: - n-1 - du2: :type: doublecomplex :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE ZGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGTTS2 solves one of the systems of equations\n\ * A * X = B, A**T * X = B, or A**H * X = B,\n\ * with a tridiagonal matrix A using the LU factorization computed\n\ * by ZGTTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITRANS (input) INTEGER\n\ * Specifies the form of the system of equations.\n\ * = 0: A * X = B (No transpose)\n\ * = 1: A**T * X = B (Transpose)\n\ * = 2: A**H * X = B (Conjugate transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * DL (input) COMPLEX*16 array, dimension (N-1)\n\ * The (n-1) multipliers that define the matrix L from the\n\ * LU factorization of A.\n\ *\n\ * D (input) COMPLEX*16 array, dimension (N)\n\ * The n diagonal elements of the upper triangular matrix U from\n\ * the LU factorization of A.\n\ *\n\ * DU (input) COMPLEX*16 array, dimension (N-1)\n\ * The (n-1) elements of the first super-diagonal of U.\n\ *\n\ * DU2 (input) COMPLEX*16 array, dimension (N-2)\n\ * The (n-2) elements of the second super-diagonal of U.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices; for 1 <= i <= n, row i of the matrix was\n\ * interchanged with row IPIV(i). IPIV(i) will always be either\n\ * i or i+1; IPIV(i) = i indicates a row interchange was not\n\ * required.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the matrix of right hand side vectors B.\n\ * On exit, B is overwritten by the solution vectors X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n COMPLEX*16 TEMP\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC DCONJG\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zhetd20000644000175000017500000001165112502223526016414 0ustar uwabamiuwabami--- :name: zhetd2 :md5sum: 5d6c063c7692d78bc773c0606e59e8a0 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - n - e: :type: doublereal :intent: output :dims: - n-1 - tau: :type: doublecomplex :intent: output :dims: - n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHETD2 reduces a complex Hermitian matrix A to real symmetric\n\ * tridiagonal form T by a unitary similarity transformation:\n\ * Q' * A * Q = T.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * Hermitian matrix A is stored:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the leading\n\ * n-by-n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n-by-n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ * On exit, if UPLO = 'U', the diagonal and first superdiagonal\n\ * of A are overwritten by the corresponding elements of the\n\ * tridiagonal matrix T, and the elements above the first\n\ * superdiagonal, with the array TAU, represent the unitary\n\ * matrix Q as a product of elementary reflectors; if UPLO\n\ * = 'L', the diagonal and first subdiagonal of A are over-\n\ * written by the corresponding elements of the tridiagonal\n\ * matrix T, and the elements below the first subdiagonal, with\n\ * the array TAU, represent the unitary matrix Q as a product\n\ * of elementary reflectors. See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * D (output) DOUBLE PRECISION array, dimension (N)\n\ * The diagonal elements of the tridiagonal matrix T:\n\ * D(i) = A(i,i).\n\ *\n\ * E (output) DOUBLE PRECISION array, dimension (N-1)\n\ * The off-diagonal elements of the tridiagonal matrix T:\n\ * E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n\ *\n\ * TAU (output) COMPLEX*16 array, dimension (N-1)\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\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\ * If UPLO = 'U', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(n-1) . . . H(2) H(1).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar, and v is a complex vector with\n\ * v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n\ * A(1:i-1,i+1), and tau in TAU(i).\n\ *\n\ * If UPLO = 'L', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(n-1).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar, and v is a complex vector with\n\ * v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n\ * and tau in TAU(i).\n\ *\n\ * The contents of A on exit are illustrated by the following examples\n\ * with n = 5:\n\ *\n\ * if UPLO = 'U': if UPLO = 'L':\n\ *\n\ * ( d e v2 v3 v4 ) ( d )\n\ * ( d e v3 v4 ) ( e d )\n\ * ( d e v4 ) ( v1 e d )\n\ * ( d e ) ( v1 v2 e d )\n\ * ( d ) ( v1 v2 v3 e d )\n\ *\n\ * where d and e denote diagonal and off-diagonal elements of T, and vi\n\ * denotes an element of the vector defining H(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlaqr40000644000175000017500000002160212502223526016400 0ustar uwabamiuwabami--- :name: dlaqr4 :md5sum: d8ba6b6e3c95815f0a98bf31c88ffd41 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: doublereal :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - wr: :type: doublereal :intent: output :dims: - ihi - wi: :type: doublereal :intent: output :dims: - ihi - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: doublereal :intent: input/output :dims: - ldz - ihi - ldz: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAQR4 computes the eigenvalues of a Hessenberg matrix H\n\ * and, optionally, the matrices T and Z from the Schur decomposition\n\ * H = Z T Z**T, where T is an upper quasi-triangular matrix (the\n\ * Schur form), and Z is the orthogonal matrix of Schur vectors.\n\ *\n\ * Optionally Z may be postmultiplied into an input orthogonal\n\ * matrix Q so that this routine can give the Schur factorization\n\ * of a matrix A which has been reduced to the Hessenberg form H\n\ * by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * WANTT (input) LOGICAL\n\ * = .TRUE. : the full Schur form T is required;\n\ * = .FALSE.: only eigenvalues are required.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * = .TRUE. : the matrix of Schur vectors Z is required;\n\ * = .FALSE.: Schur vectors are not required.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H. N .GE. 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * It is assumed that H is already upper triangular in rows\n\ * and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n\ * H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n\ * previous call to DGEBAL, and then passed to DGEHRD when the\n\ * matrix output by DGEBAL is reduced to Hessenberg form.\n\ * Otherwise, ILO and IHI should be set to 1 and N,\n\ * respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n\ * If N = 0, then ILO = 1 and IHI = 0.\n\ *\n\ * H (input/output) DOUBLE PRECISION array, dimension (LDH,N)\n\ * On entry, the upper Hessenberg matrix H.\n\ * On exit, if INFO = 0 and WANTT is .TRUE., then H contains\n\ * the upper quasi-triangular matrix T from the Schur\n\ * decomposition (the Schur form); 2-by-2 diagonal blocks\n\ * (corresponding to complex conjugate pairs of eigenvalues)\n\ * are returned in standard form, with H(i,i) = H(i+1,i+1)\n\ * and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is\n\ * .FALSE., then the contents of H are unspecified on exit.\n\ * (The output value of H when INFO.GT.0 is given under the\n\ * description of INFO below.)\n\ *\n\ * This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n\ * j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n\ *\n\ * LDH (input) INTEGER\n\ * The leading dimension of the array H. LDH .GE. max(1,N).\n\ *\n\ * WR (output) DOUBLE PRECISION array, dimension (IHI)\n\ * WI (output) DOUBLE PRECISION array, dimension (IHI)\n\ * The real and imaginary parts, respectively, of the computed\n\ * eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI)\n\ * and WI(ILO:IHI). If two eigenvalues are computed as a\n\ * complex conjugate pair, they are stored in consecutive\n\ * elements of WR and WI, say the i-th and (i+1)th, with\n\ * WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then\n\ * the eigenvalues are stored in the same order as on the\n\ * diagonal of the Schur form returned in H, with\n\ * WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal\n\ * block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and\n\ * WI(i+1) = -WI(i).\n\ *\n\ * ILOZ (input) INTEGER\n\ * IHIZ (input) INTEGER\n\ * Specify the rows of Z to which transformations must be\n\ * applied if WANTZ is .TRUE..\n\ * 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.\n\ *\n\ * Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI)\n\ * If WANTZ is .FALSE., then Z is not referenced.\n\ * If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n\ * replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n\ * orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n\ * (The output value of Z when INFO.GT.0 is given under\n\ * the description of INFO below.)\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. if WANTZ is .TRUE.\n\ * then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.\n\ *\n\ * WORK (workspace/output) DOUBLE PRECISION array, dimension LWORK\n\ * On exit, if LWORK = -1, WORK(1) returns an estimate of\n\ * the optimal value for LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK .GE. max(1,N)\n\ * is sufficient, but LWORK typically as large as 6*N may\n\ * be required for optimal performance. A workspace query\n\ * to determine the optimal workspace size is recommended.\n\ *\n\ * If LWORK = -1, then DLAQR4 does a workspace query.\n\ * In this case, DLAQR4 checks the input parameters and\n\ * estimates the optimal workspace size for the given\n\ * values of N, ILO and IHI. The estimate is returned\n\ * in WORK(1). No error message related to LWORK is\n\ * issued by XERBLA. Neither H nor Z are accessed.\n\ *\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * .GT. 0: if INFO = i, DLAQR4 failed to compute all of\n\ * the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n\ * and WI contain those eigenvalues which have been\n\ * successfully computed. (Failures are rare.)\n\ *\n\ * If INFO .GT. 0 and WANT is .FALSE., then on exit,\n\ * the remaining unconverged eigenvalues are the eigen-\n\ * values of the upper Hessenberg matrix rows and\n\ * columns ILO through INFO of the final, output\n\ * value of H.\n\ *\n\ * If INFO .GT. 0 and WANTT is .TRUE., then on exit\n\ *\n\ * (*) (initial value of H)*U = U*(final value of H)\n\ *\n\ * where U is an orthogonal matrix. The final\n\ * value of H is upper Hessenberg and quasi-triangular\n\ * in rows and columns INFO+1 through IHI.\n\ *\n\ * If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n\ *\n\ * (final value of Z(ILO:IHI,ILOZ:IHIZ)\n\ * = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n\ *\n\ * where U is the orthogonal matrix in (*) (regard-\n\ * less of the value of WANTT.)\n\ *\n\ * If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n\ * accessed.\n\ *\n\n\ * ================================================================\n\ * Based on contributions by\n\ * Karen Braman and Ralph Byers, Department of Mathematics,\n\ * University of Kansas, USA\n\ *\n\ * ================================================================\n\ * References:\n\ * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n\ * Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n\ * Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n\ * 929--947, 2002.\n\ *\n\ * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n\ * Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n\ * of Matrix Analysis, volume 23, pages 948--973, 2002.\n\ *\n\ * ================================================================\n" ruby-lapack-1.7.2/dev/defs/zla_gbrpvgrw0000644000175000017500000000605412502223526017723 0ustar uwabamiuwabami--- :name: zla_gbrpvgrw :md5sum: 93b4b0e0e44371aacf2dcc4f944acec7 :category: :function :type: doublereal :arguments: - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ncols: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublecomplex :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION ZLA_GBRPVGRW( N, KL, KU, NCOLS, AB, LDAB, AFB, LDAFB )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLA_GBRPVGRW computes the reciprocal pivot growth factor\n\ * norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n\ * much less than 1, the stability of the LU factorization of the\n\ * (equilibrated) matrix A could be poor. This also means that the\n\ * solution X, estimated condition numbers, and error bounds could be\n\ * unreliable.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * NCOLS (input) INTEGER\n\ * The number of columns of the matrix A. NCOLS >= 0.\n\ *\n\ * AB (input) COMPLEX*16 array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * AFB (input) COMPLEX*16 array, dimension (LDAFB,N)\n\ * Details of the LU factorization of the band matrix A, as\n\ * computed by ZGBTRF. U is stored as an upper triangular\n\ * band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n\ * and the multipliers used during the factorization are stored\n\ * in rows KL+KU+2 to 2*KL+KU+1.\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J, KD\n DOUBLE PRECISION AMAX, UMAX, RPVGRW\n COMPLEX*16 ZDUM\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN, REAL, DIMAG\n\ * ..\n\ * .. Statement Functions ..\n DOUBLE PRECISION CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sla_gerfsx_extended0000644000175000017500000003505112502223526021231 0ustar uwabamiuwabami--- :name: sla_gerfsx_extended :md5sum: e1c13e3630acd1f6b602bcd6c9654aca :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - trans_type: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - colequ: :type: logical :intent: input - c: :type: real :intent: input :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: real :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: real :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - err_bnds_norm: :type: real :intent: input/output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: input/output :dims: - nrhs - n_err_bnds - res: :type: real :intent: input :dims: - n - ayb: :type: real :intent: input :dims: - n - dy: :type: real :intent: input :dims: - n - y_tail: :type: real :intent: input :dims: - n - rcond: :type: real :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: real :intent: input - dz_ub: :type: real :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLA_GERFSX_EXTENDED improves the computed solution to a system of\n\ * linear equations by performing extra-precise iterative refinement\n\ * and provides error bounds and backward error estimates for the solution.\n\ * This subroutine is called by SGERFSX to perform iterative refinement.\n\ * In addition to normwise error bound, the code provides maximum\n\ * componentwise error bound if possible. See comments for ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP for details of the error bounds. Note that this\n\ * subroutine is only resonsible for setting the second fields of\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * PREC_TYPE (input) INTEGER\n\ * Specifies the intermediate precision to be used in refinement.\n\ * The value is defined by ILAPREC(P) where P is a CHARACTER and\n\ * P = 'S': Single\n\ * = 'D': Double\n\ * = 'I': Indigenous\n\ * = 'X', 'E': Extra\n\ *\n\ * TRANS_TYPE (input) INTEGER\n\ * Specifies the transposition operation on A.\n\ * The value is defined by ILATRANS(T) where T is a CHARACTER and\n\ * T = 'N': No transpose\n\ * = 'T': Transpose\n\ * = 'C': Conjugate transpose\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right-hand-sides, i.e., the number of columns of the\n\ * matrix B.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) REAL array, dimension (LDAF,N)\n\ * The factors L and U from the factorization\n\ * A = P*L*U as computed by SGETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from the factorization A = P*L*U\n\ * as computed by SGETRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * COLEQU (input) LOGICAL\n\ * If .TRUE. then column equilibration was done to A before calling\n\ * this routine. This is needed to compute the solution and error\n\ * bounds correctly.\n\ *\n\ * C (input) REAL array, dimension (N)\n\ * The column scale factors for A. If COLEQU = .FALSE., C\n\ * is not accessed. If C is input, each element of C should be a power\n\ * of the radix to ensure a reliable solution and error estimates.\n\ * Scaling by powers of the radix does not cause rounding errors unless\n\ * the result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input) REAL array, dimension (LDB,NRHS)\n\ * The right-hand-side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * Y (input/output) REAL array, dimension (LDY,NRHS)\n\ * On entry, the solution matrix X, as computed by SGETRS.\n\ * On exit, the improved solution matrix Y.\n\ *\n\ * LDY (input) INTEGER\n\ * The leading dimension of the array Y. LDY >= max(1,N).\n\ *\n\ * BERR_OUT (output) REAL array, dimension (NRHS)\n\ * On exit, BERR_OUT(j) contains the componentwise relative backward\n\ * error for right-hand-side j from the formula\n\ * max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n\ * where abs(Z) is the componentwise absolute value of the matrix\n\ * or vector Z. This is computed by SLA_LIN_BERR.\n\ *\n\ * N_NORMS (input) INTEGER\n\ * Determines which error bounds to return (see ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP).\n\ * If N_NORMS >= 1 return normwise error bounds.\n\ * If N_NORMS >= 2 return componentwise error bounds.\n\ *\n\ * ERR_BNDS_NORM (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * RES (input) REAL array, dimension (N)\n\ * Workspace to hold the intermediate residual.\n\ *\n\ * AYB (input) REAL array, dimension (N)\n\ * Workspace. This can be the same workspace passed for Y_TAIL.\n\ *\n\ * DY (input) REAL array, dimension (N)\n\ * Workspace to hold the intermediate solution.\n\ *\n\ * Y_TAIL (input) REAL array, dimension (N)\n\ * Workspace to hold the trailing bits of the intermediate solution.\n\ *\n\ * RCOND (input) REAL\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * ITHRESH (input) INTEGER\n\ * The maximum number of residual computations allowed for\n\ * refinement. The default is 10. For 'aggressive' set to 100 to\n\ * permit convergence using approximate factorizations or\n\ * factorizations other than LU. If the factorization uses a\n\ * technique other than Gaussian elimination, the guarantees in\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n\ *\n\ * RTHRESH (input) REAL\n\ * Determines when to stop refinement if the error estimate stops\n\ * decreasing. Refinement will stop when the next solution no longer\n\ * satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n\ * the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n\ * default value is 0.5. For 'aggressive' set to 0.9 to permit\n\ * convergence on extremely ill-conditioned matrices. See LAWN 165\n\ * for more details.\n\ *\n\ * DZ_UB (input) REAL\n\ * Determines when to start considering componentwise convergence.\n\ * Componentwise convergence is only considered after each component\n\ * of the solution Y is stable, which we definte as the relative\n\ * change in each component being less than DZ_UB. The default value\n\ * is 0.25, requiring the first bit to be stable. See LAWN 165 for\n\ * more details.\n\ *\n\ * IGNORE_CWISE (input) LOGICAL\n\ * If .TRUE. then ignore componentwise convergence. Default value\n\ * is .FALSE..\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * < 0: if INFO = -i, the ith argument to SGETRS had an illegal\n\ * value\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n CHARACTER TRANS\n INTEGER CNT, I, J, X_STATE, Z_STATE, Y_PREC_STATE\n REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zpptri0000644000175000017500000000364612502223526016551 0ustar uwabamiuwabami--- :name: zpptri :md5sum: 8ed87fedb50a3809ea9372f275d042e6 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPPTRI( UPLO, N, AP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPPTRI computes the inverse of a complex Hermitian positive definite\n\ * matrix A using the Cholesky factorization A = U**H*U or A = L*L**H\n\ * computed by ZPPTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangular factor is stored in AP;\n\ * = 'L': Lower triangular factor is stored in AP.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * On entry, the triangular factor U or L from the Cholesky\n\ * factorization A = U**H*U or A = L*L**H, packed columnwise as\n\ * a linear array. The j-th column of U or L is stored in the\n\ * array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n\ *\n\ * On exit, the upper or lower triangle of the (Hermitian)\n\ * inverse of A, overwriting the input factor U or L.\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,i) element of the factor U or L is\n\ * zero, and the inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgerfs0000644000175000017500000001130112502223526016504 0ustar uwabamiuwabami--- :name: zgerfs :md5sum: f648a842e8231bfdf23d4c1045e0c32d :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGERFS improves the computed solution to a system of linear\n\ * equations and provides error bounds and backward error estimates for\n\ * the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The original N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX*16 array, dimension (LDAF,N)\n\ * The factors L and U from the factorization A = P*L*U\n\ * as computed by ZGETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from ZGETRF; for 1<=i<=N, row i of the\n\ * matrix was interchanged with row IPIV(i).\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by ZGETRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sstevd0000644000175000017500000001163012502223526016521 0ustar uwabamiuwabami--- :name: sstevd :md5sum: 10d00bce80e4d19bfdeff93402e6c8f0 :category: :subroutine :arguments: - jobz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - z: :type: real :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(lsame_(&jobz,\"N\")||n<=1) ? 1 : lsame_(&jobz,\"V\") ? 1+4*n+n*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "(lsame_(&jobz,\"N\")||n<=1) ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" :fortran_help: " SUBROUTINE SSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSTEVD computes all eigenvalues and, optionally, eigenvectors of a\n\ * real symmetric tridiagonal matrix. If eigenvectors are desired, it\n\ * uses a divide and conquer algorithm.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the n diagonal elements of the tridiagonal matrix\n\ * A.\n\ * On exit, if INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * E (input/output) REAL array, dimension (N-1)\n\ * On entry, the (n-1) subdiagonal elements of the tridiagonal\n\ * matrix A, stored in elements 1 to N-1 of E.\n\ * On exit, the contents of E are destroyed.\n\ *\n\ * Z (output) REAL array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n\ * eigenvectors of the matrix A, with the i-th column of Z\n\ * holding the eigenvector associated with D(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace/output) REAL array,\n\ * dimension (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\ * If JOBZ = 'N' or N <= 1 then LWORK must be at least 1.\n\ * If JOBZ = 'V' and N > 1 then LWORK must be at least\n\ * ( 1 + 4*N + N**2 ).\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the optimal sizes of the WORK and IWORK\n\ * arrays, returns these values as the first entries of the WORK\n\ * and IWORK arrays, and no error message related to LWORK or\n\ * LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK.\n\ * If JOBZ = 'N' or N <= 1 then LIWORK must be at least 1.\n\ * If JOBZ = 'V' and N > 1 then LIWORK must be at least 3+5*N.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK and IWORK arrays, and no error message related to\n\ * LWORK or LIWORK 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 algorithm failed to converge; i\n\ * off-diagonal elements of E did not converge to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slalsd0000644000175000017500000001215212502223526016473 0ustar uwabamiuwabami--- :name: slalsd :md5sum: 44fe2b5988c1444181a79736bc714030 :category: :subroutine :arguments: - uplo: :type: char :intent: input - smlsiz: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - rcond: :type: real :intent: input - rank: :type: integer :intent: output - work: :type: real :intent: workspace :dims: - 9*n + 2*n*smlsiz + 8*n*nlvl + n*nrhs + pow(smlsiz+1,2) - iwork: :type: integer :intent: workspace :dims: - 3*n*nlvl + 11*n - info: :type: integer :intent: output :substitutions: nlvl: MAX(0, (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1) :fortran_help: " SUBROUTINE SLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, RANK, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLALSD uses the singular value decomposition of A to solve the least\n\ * squares problem of finding X to minimize the Euclidean norm of each\n\ * column of A*X-B, where A is N-by-N upper bidiagonal, and X and B\n\ * are N-by-NRHS. The solution X overwrites B.\n\ *\n\ * The singular values of A smaller than RCOND times the largest\n\ * singular value are treated as zero in solving the least squares\n\ * problem; in this case a minimum norm solution is returned.\n\ * The actual singular values are returned in D in ascending order.\n\ *\n\ * This code makes very mild assumptions about floating point\n\ * arithmetic. It will work on machines with a guard digit in\n\ * add/subtract, or on those binary machines without guard digits\n\ * which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.\n\ * It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': D and E define an upper bidiagonal matrix.\n\ * = 'L': D and E define a lower bidiagonal matrix.\n\ *\n\ * SMLSIZ (input) INTEGER\n\ * The maximum size of the subproblems at the bottom of the\n\ * computation tree.\n\ *\n\ * N (input) INTEGER\n\ * The dimension of the bidiagonal matrix. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of columns of B. NRHS must be at least 1.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry D contains the main diagonal of the bidiagonal\n\ * matrix. On exit, if INFO = 0, D contains its singular values.\n\ *\n\ * E (input/output) REAL array, dimension (N-1)\n\ * Contains the super-diagonal entries of the bidiagonal matrix.\n\ * On exit, E has been destroyed.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On input, B contains the right hand sides of the least\n\ * squares problem. On output, B contains the solution X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B in the calling subprogram.\n\ * LDB must be at least max(1,N).\n\ *\n\ * RCOND (input) REAL\n\ * The singular values of A less than or equal to RCOND times\n\ * the largest singular value are treated as zero in solving\n\ * the least squares problem. If RCOND is negative,\n\ * machine precision is used instead.\n\ * For example, if diag(S)*X=B were the least squares problem,\n\ * where diag(S) is a diagonal matrix of singular values, the\n\ * solution would be X(i) = B(i) / S(i) if S(i) is greater than\n\ * RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to\n\ * RCOND*max(S).\n\ *\n\ * RANK (output) INTEGER\n\ * The number of singular values of A greater than RCOND times\n\ * the largest singular value.\n\ *\n\ * WORK (workspace) REAL array, dimension at least\n\ * (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2),\n\ * where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1).\n\ *\n\ * IWORK (workspace) INTEGER array, dimension at least\n\ * (3*N*NLVL + 11*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit.\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * > 0: The algorithm failed to compute a singular value while\n\ * working on the submatrix lying in rows and columns\n\ * INFO/(N+1) through MOD(INFO,N+1).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ming Gu and Ren-Cang Li, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgeevx0000644000175000017500000002526412502223526016503 0ustar uwabamiuwabami--- :name: dgeevx :md5sum: 609542a2421694e34131836059fd6901 :category: :subroutine :arguments: - balanc: :type: char :intent: input - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - wr: :type: doublereal :intent: output :dims: - n - wi: :type: doublereal :intent: output :dims: - n - vl: :type: doublereal :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: doublereal :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - scale: :type: doublereal :intent: output :dims: - n - abnrm: :type: doublereal :intent: output - rconde: :type: doublereal :intent: output :dims: - n - rcondv: :type: doublereal :intent: output :dims: - n - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(lsame_(&sense,\"N\")||lsame_(&sense,\"E\")) ? 2*n : (lsame_(&jobvl,\"V\")||lsame_(&jobvr,\"V\")) ? 3*n : (lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? n*(n+6) : 0" - iwork: :type: integer :intent: workspace :dims: - "(lsame_(&sense,\"N\")||lsame_(&sense,\"E\")) ? 0 : 2*n-2" - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " SUBROUTINE DGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, WORK, LWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGEEVX computes for an N-by-N real nonsymmetric matrix A, the\n\ * eigenvalues and, optionally, the left and/or right eigenvectors.\n\ *\n\ * Optionally also, it computes a balancing transformation to improve\n\ * the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n\ * SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues\n\ * (RCONDE), and reciprocal condition numbers for the right\n\ * eigenvectors (RCONDV).\n\ *\n\ * The right eigenvector v(j) of A satisfies\n\ * A * v(j) = lambda(j) * v(j)\n\ * where lambda(j) is its eigenvalue.\n\ * The left eigenvector u(j) of A satisfies\n\ * u(j)**H * A = lambda(j) * u(j)**H\n\ * where u(j)**H denotes the conjugate transpose of u(j).\n\ *\n\ * The computed eigenvectors are normalized to have Euclidean norm\n\ * equal to 1 and largest component real.\n\ *\n\ * Balancing a matrix means permuting the rows and columns to make it\n\ * more nearly upper triangular, and applying a diagonal similarity\n\ * transformation D * A * D**(-1), where D is a diagonal matrix, to\n\ * make its rows and columns closer in norm and the condition numbers\n\ * of its eigenvalues and eigenvectors smaller. The computed\n\ * reciprocal condition numbers correspond to the balanced matrix.\n\ * Permuting rows and columns will not change the condition numbers\n\ * (in exact arithmetic) but diagonal scaling will. For further\n\ * explanation of balancing, see section 4.10.2 of the LAPACK\n\ * Users' Guide.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * BALANC (input) CHARACTER*1\n\ * Indicates how the input matrix should be diagonally scaled\n\ * and/or permuted to improve the conditioning of its\n\ * eigenvalues.\n\ * = 'N': Do not diagonally scale or permute;\n\ * = 'P': Perform permutations to make the matrix more nearly\n\ * upper triangular. Do not diagonally scale;\n\ * = 'S': Diagonally scale the matrix, i.e. replace A by\n\ * D*A*D**(-1), where D is a diagonal matrix chosen\n\ * to make the rows and columns of A more equal in\n\ * norm. Do not permute;\n\ * = 'B': Both diagonally scale and permute A.\n\ *\n\ * Computed reciprocal condition numbers will be for the matrix\n\ * after balancing and/or permuting. Permuting does not change\n\ * condition numbers (in exact arithmetic), but balancing does.\n\ *\n\ * JOBVL (input) CHARACTER*1\n\ * = 'N': left eigenvectors of A are not computed;\n\ * = 'V': left eigenvectors of A are computed.\n\ * If SENSE = 'E' or 'B', JOBVL must = 'V'.\n\ *\n\ * JOBVR (input) CHARACTER*1\n\ * = 'N': right eigenvectors of A are not computed;\n\ * = 'V': right eigenvectors of A are computed.\n\ * If SENSE = 'E' or 'B', JOBVR must = 'V'.\n\ *\n\ * SENSE (input) CHARACTER*1\n\ * Determines which reciprocal condition numbers are computed.\n\ * = 'N': None are computed;\n\ * = 'E': Computed for eigenvalues only;\n\ * = 'V': Computed for right eigenvectors only;\n\ * = 'B': Computed for eigenvalues and right eigenvectors.\n\ *\n\ * If SENSE = 'E' or 'B', both left and right eigenvectors\n\ * must also be computed (JOBVL = 'V' and JOBVR = 'V').\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ * On exit, A has been overwritten. If JOBVL = 'V' or\n\ * JOBVR = 'V', A contains the real Schur form of the balanced\n\ * version of the input matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * WR (output) DOUBLE PRECISION array, dimension (N)\n\ * WI (output) DOUBLE PRECISION array, dimension (N)\n\ * WR and WI contain the real and imaginary parts,\n\ * respectively, of the computed eigenvalues. Complex\n\ * conjugate pairs of eigenvalues will appear consecutively\n\ * with the eigenvalue having the positive imaginary part\n\ * first.\n\ *\n\ * VL (output) DOUBLE PRECISION array, dimension (LDVL,N)\n\ * If JOBVL = 'V', the left eigenvectors u(j) are stored one\n\ * after another in the columns of VL, in the same order\n\ * as their eigenvalues.\n\ * If JOBVL = 'N', VL is not referenced.\n\ * If the j-th eigenvalue is real, then u(j) = VL(:,j),\n\ * the j-th column of VL.\n\ * If the j-th and (j+1)-st eigenvalues form a complex\n\ * conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and\n\ * u(j+1) = VL(:,j) - i*VL(:,j+1).\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the array VL. LDVL >= 1; if\n\ * JOBVL = 'V', LDVL >= N.\n\ *\n\ * VR (output) DOUBLE PRECISION array, dimension (LDVR,N)\n\ * If JOBVR = 'V', the right eigenvectors v(j) are stored one\n\ * after another in the columns of VR, in the same order\n\ * as their eigenvalues.\n\ * If JOBVR = 'N', VR is not referenced.\n\ * If the j-th eigenvalue is real, then v(j) = VR(:,j),\n\ * the j-th column of VR.\n\ * If the j-th and (j+1)-st eigenvalues form a complex\n\ * conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and\n\ * v(j+1) = VR(:,j) - i*VR(:,j+1).\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the array VR. LDVR >= 1, and if\n\ * JOBVR = 'V', LDVR >= N.\n\ *\n\ * ILO (output) INTEGER\n\ * IHI (output) INTEGER\n\ * ILO and IHI are integer values determined when A was\n\ * balanced. The balanced A(i,j) = 0 if I > J and\n\ * J = 1,...,ILO-1 or I = IHI+1,...,N.\n\ *\n\ * SCALE (output) DOUBLE PRECISION array, dimension (N)\n\ * Details of the permutations and scaling factors applied\n\ * when balancing A. If P(j) is the index of the row and column\n\ * interchanged with row and column j, and D(j) is the scaling\n\ * factor applied to row and column j, then\n\ * SCALE(J) = P(J), for J = 1,...,ILO-1\n\ * = D(J), for J = ILO,...,IHI\n\ * = P(J) for J = IHI+1,...,N.\n\ * The order in which the interchanges are made is N to IHI+1,\n\ * then 1 to ILO-1.\n\ *\n\ * ABNRM (output) DOUBLE PRECISION\n\ * The one-norm of the balanced matrix (the maximum\n\ * of the sum of absolute values of elements of any column).\n\ *\n\ * RCONDE (output) DOUBLE PRECISION array, dimension (N)\n\ * RCONDE(j) is the reciprocal condition number of the j-th\n\ * eigenvalue.\n\ *\n\ * RCONDV (output) DOUBLE PRECISION array, dimension (N)\n\ * RCONDV(j) is the reciprocal condition number of the j-th\n\ * right eigenvector.\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. If SENSE = 'N' or 'E',\n\ * LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V',\n\ * LWORK >= 3*N. If SENSE = 'V' or 'B', LWORK >= N*(N+6).\n\ * For good performance, LWORK must generally be larger.\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\ * IWORK (workspace) INTEGER array, dimension (2*N-2)\n\ * If SENSE = 'N' or 'E', not referenced.\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 QR algorithm failed to compute all the\n\ * eigenvalues, and no eigenvectors or condition numbers\n\ * have been computed; elements 1:ILO-1 and i+1:N of WR\n\ * and WI contain eigenvalues which have converged.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slauum0000644000175000017500000000412412502223526016517 0ustar uwabamiuwabami--- :name: slauum :md5sum: ae3e332f4b2b2cd6e5a165d0d36c13a5 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLAUUM( UPLO, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAUUM computes the product U * U' or L' * L, where the triangular\n\ * factor U or L is stored in the upper or lower triangular part of\n\ * the array A.\n\ *\n\ * If UPLO = 'U' or 'u' then the upper triangle of the result is stored,\n\ * overwriting the factor U in A.\n\ * If UPLO = 'L' or 'l' then the lower triangle of the result is stored,\n\ * overwriting the factor L in A.\n\ *\n\ * This is the blocked form of the algorithm, calling Level 3 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the triangular factor stored in the array A\n\ * is upper or lower triangular:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the triangular factor U or L. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the triangular factor U or L.\n\ * On exit, if UPLO = 'U', the upper triangle of A is\n\ * overwritten with the upper triangle of the product U * U';\n\ * if UPLO = 'L', the lower triangle of A is overwritten with\n\ * the lower triangle of the product L' * L.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slantp0000644000175000017500000000613012502223526016511 0ustar uwabamiuwabami--- :name: slantp :md5sum: 7411f7e2611b351ddaa4eb97b833fb4f :category: :function :type: real :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input :dims: - n*(n+1)/2 - work: :type: real :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? n : 0" :fortran_help: " REAL FUNCTION SLANTP( NORM, UPLO, DIAG, N, AP, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLANTP returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * triangular matrix A, supplied in packed form.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * SLANTP returns the value\n\ *\n\ * SLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in SLANTP as described\n\ * above.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the matrix A is upper or lower triangular.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * Specifies whether or not the matrix A is unit triangular.\n\ * = 'N': Non-unit triangular\n\ * = 'U': Unit triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, SLANTP is\n\ * set to zero.\n\ *\n\ * AP (input) REAL array, dimension (N*(N+1)/2)\n\ * The upper or lower triangular matrix A, packed columnwise in\n\ * a linear array. The j-th column of A is stored in the array\n\ * AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ * Note that when DIAG = 'U', the elements of the array AP\n\ * corresponding to the diagonal elements of the matrix A are\n\ * not referenced, but are assumed to be one.\n\ *\n\ * WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n\ * referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgeqlf0000644000175000017500000000750412502223526016460 0ustar uwabamiuwabami--- :name: dgeqlf :md5sum: fa29ffe456888362b95f7fa8db470284 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - MIN(m,n) - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGEQLF computes a QL factorization of a real M-by-N matrix A:\n\ * A = Q * L.\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,\n\ * if m >= n, the lower triangle of the subarray\n\ * A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L;\n\ * if m <= n, the elements on and below the (n-m)-th\n\ * superdiagonal contain the M-by-N lower trapezoidal matrix L;\n\ * the remaining elements, with the array TAU, represent the\n\ * orthogonal matrix Q as a product of elementary reflectors\n\ * (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,N).\n\ * For optimum performance LWORK >= N*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(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n\ * A(1:m-k+i-1,n-k+i), and tau in TAU(i).\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n $ MU, NB, NBMIN, NU, NX\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DGEQL2, DLARFB, DLARFT, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zlahqr0000644000175000017500000001341612502223526016516 0ustar uwabamiuwabami--- :name: zlahqr :md5sum: 94def9c763c6ce11a5fa6e92f7c284a6 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: doublecomplex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - w: :type: doublecomplex :intent: output :dims: - n - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: doublecomplex :intent: input/output :dims: - "wantz ? ldz : 0" - "wantz ? n : 0" - ldz: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, IHIZ, Z, LDZ, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAHQR is an auxiliary routine called by CHSEQR to update the\n\ * eigenvalues and Schur decomposition already computed by CHSEQR, by\n\ * dealing with the Hessenberg submatrix in rows and columns ILO to\n\ * IHI.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * WANTT (input) LOGICAL\n\ * = .TRUE. : the full Schur form T is required;\n\ * = .FALSE.: only eigenvalues are required.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * = .TRUE. : the matrix of Schur vectors Z is required;\n\ * = .FALSE.: Schur vectors are not required.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * It is assumed that H is already upper triangular in rows and\n\ * columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1).\n\ * ZLAHQR works primarily with the Hessenberg submatrix in rows\n\ * and columns ILO to IHI, but applies transformations to all of\n\ * H if WANTT is .TRUE..\n\ * 1 <= ILO <= max(1,IHI); IHI <= N.\n\ *\n\ * H (input/output) COMPLEX*16 array, dimension (LDH,N)\n\ * On entry, the upper Hessenberg matrix H.\n\ * On exit, if INFO is zero and if WANTT is .TRUE., then H\n\ * is upper triangular in rows and columns ILO:IHI. If INFO\n\ * is zero and if WANTT is .FALSE., then the contents of H\n\ * are unspecified on exit. The output state of H in case\n\ * INF is positive is below under the description of INFO.\n\ *\n\ * LDH (input) INTEGER\n\ * The leading dimension of the array H. LDH >= max(1,N).\n\ *\n\ * W (output) COMPLEX*16 array, dimension (N)\n\ * The computed eigenvalues ILO to IHI are stored in the\n\ * corresponding elements of W. If WANTT is .TRUE., the\n\ * eigenvalues are stored in the same order as on the diagonal\n\ * of the Schur form returned in H, with W(i) = H(i,i).\n\ *\n\ * ILOZ (input) INTEGER\n\ * IHIZ (input) INTEGER\n\ * Specify the rows of Z to which transformations must be\n\ * applied if WANTZ is .TRUE..\n\ * 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.\n\ *\n\ * Z (input/output) COMPLEX*16 array, dimension (LDZ,N)\n\ * If WANTZ is .TRUE., on entry Z must contain the current\n\ * matrix Z of transformations accumulated by CHSEQR, and on\n\ * exit Z has been updated; transformations are applied only to\n\ * the submatrix Z(ILOZ:IHIZ,ILO:IHI).\n\ * If WANTZ is .FALSE., Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * .GT. 0: if INFO = i, ZLAHQR failed to compute all the\n\ * eigenvalues ILO to IHI in a total of 30 iterations\n\ * per eigenvalue; elements i+1:ihi of W contain\n\ * those eigenvalues which have been successfully\n\ * computed.\n\ *\n\ * If INFO .GT. 0 and WANTT is .FALSE., then on exit,\n\ * the remaining unconverged eigenvalues are the\n\ * eigenvalues of the upper Hessenberg matrix\n\ * rows and columns ILO thorugh INFO of the final,\n\ * output value of H.\n\ *\n\ * If INFO .GT. 0 and WANTT is .TRUE., then on exit\n\ * (*) (initial value of H)*U = U*(final value of H)\n\ * where U is an orthognal matrix. The final\n\ * value of H is upper Hessenberg and triangular in\n\ * rows and columns INFO+1 through IHI.\n\ *\n\ * If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n\ * (final value of Z) = (initial value of Z)*U\n\ * where U is the orthogonal matrix in (*)\n\ * (regardless of the value of WANTT.)\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * 02-96 Based on modifications by\n\ * David Day, Sandia National Laboratory, USA\n\ *\n\ * 12-04 Further modifications by\n\ * Ralph Byers, University of Kansas, USA\n\ * This is a modified version of ZLAHQR from LAPACK version 3.0.\n\ * It is (1) more robust against overflow and underflow and\n\ * (2) adopts the more conservative Ahues & Tisseur stopping\n\ * criterion (LAWN 122, 1997).\n\ *\n\ * =========================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlatdf0000644000175000017500000001164412502223526016502 0ustar uwabamiuwabami--- :name: zlatdf :md5sum: a3e258a309f756a498efa03aacc75a5a :category: :subroutine :arguments: - ijob: :type: integer :intent: input - n: :type: integer :intent: input - z: :type: doublecomplex :intent: input :dims: - ldz - n - ldz: :type: integer :intent: input - rhs: :type: doublecomplex :intent: input/output :dims: - n - rdsum: :type: doublereal :intent: input/output - rdscal: :type: doublereal :intent: input/output - ipiv: :type: integer :intent: input :dims: - n - jpiv: :type: integer :intent: input :dims: - n :substitutions: {} :fortran_help: " SUBROUTINE ZLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, JPIV )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLATDF computes the contribution to the reciprocal Dif-estimate\n\ * by solving for x in Z * x = b, where b is chosen such that the norm\n\ * of x is as large as possible. It is assumed that LU decomposition\n\ * of Z has been computed by ZGETC2. On entry RHS = f holds the\n\ * contribution from earlier solved sub-systems, and on return RHS = x.\n\ *\n\ * The factorization of Z returned by ZGETC2 has the form\n\ * Z = P * L * U * Q, where P and Q are permutation matrices. L is lower\n\ * triangular with unit diagonal elements and U is upper triangular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * IJOB (input) INTEGER\n\ * IJOB = 2: First compute an approximative null-vector e\n\ * of Z using ZGECON, e is normalized and solve for\n\ * Zx = +-e - f with the sign giving the greater value of\n\ * 2-norm(x). About 5 times as expensive as Default.\n\ * IJOB .ne. 2: Local look ahead strategy where\n\ * all entries of the r.h.s. b is choosen as either +1 or\n\ * -1. Default.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Z.\n\ *\n\ * Z (input) DOUBLE PRECISION array, dimension (LDZ, N)\n\ * On entry, the LU part of the factorization of the n-by-n\n\ * matrix Z computed by ZGETC2: Z = P * L * U * Q\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDA >= max(1, N).\n\ *\n\ * RHS (input/output) DOUBLE PRECISION array, dimension (N).\n\ * On entry, RHS contains contributions from other subsystems.\n\ * On exit, RHS contains the solution of the subsystem with\n\ * entries according to the value of IJOB (see above).\n\ *\n\ * RDSUM (input/output) DOUBLE PRECISION\n\ * On entry, the sum of squares of computed contributions to\n\ * the Dif-estimate under computation by ZTGSYL, where the\n\ * scaling factor RDSCAL (see below) has been factored out.\n\ * On exit, the corresponding sum of squares updated with the\n\ * contributions from the current sub-system.\n\ * If TRANS = 'T' RDSUM is not touched.\n\ * NOTE: RDSUM only makes sense when ZTGSY2 is called by CTGSYL.\n\ *\n\ * RDSCAL (input/output) DOUBLE PRECISION\n\ * On entry, scaling factor used to prevent overflow in RDSUM.\n\ * On exit, RDSCAL is updated w.r.t. the current contributions\n\ * in RDSUM.\n\ * If TRANS = 'T', RDSCAL is not touched.\n\ * NOTE: RDSCAL only makes sense when ZTGSY2 is called by\n\ * ZTGSYL.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N).\n\ * The pivot indices; for 1 <= i <= N, row i of the\n\ * matrix has been interchanged with row IPIV(i).\n\ *\n\ * JPIV (input) INTEGER array, dimension (N).\n\ * The pivot indices; for 1 <= j <= N, column j of the\n\ * matrix has been interchanged with column JPIV(j).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * This routine is a further developed implementation of algorithm\n\ * BSOLVE in [1] using complete pivoting in the LU factorization.\n\ *\n\ * [1] Bo Kagstrom and Lars Westin,\n\ * Generalized Schur Methods with Condition Estimators for\n\ * Solving the Generalized Sylvester Equation, IEEE Transactions\n\ * on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.\n\ *\n\ * [2] Peter Poromaa,\n\ * On Efficient and Robust Estimators for the Separation\n\ * between two Regular Matrix Pairs with Applications in\n\ * Condition Estimation. Report UMINF-95.05, Department of\n\ * Computing Science, Umea University, S-901 87 Umea, Sweden,\n\ * 1995.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlascl20000644000175000017500000000303612502223526016564 0ustar uwabamiuwabami--- :name: zlascl2 :md5sum: 429cf4142645802480d42330910b72d1 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - m - x: :type: doublecomplex :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE ZLASCL2 ( M, N, D, X, LDX )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLASCL2 performs a diagonal scaling on a vector:\n\ * x <-- D * x\n\ * where the DOUBLE PRECISION diagonal matrix D is stored as a vector.\n\ *\n\ * Eventually to be replaced by BLAS_zge_diag_scale in the new BLAS\n\ * standard.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of D and X. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of D and X. N >= 0.\n\ *\n\ * D (input) DOUBLE PRECISION array, length M\n\ * Diagonal matrix D, stored as a vector of length M.\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension (LDX,N)\n\ * On entry, the vector X to be scaled by D.\n\ * On exit, the scaled vector.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the vector X. LDX >= 0.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slaed70000644000175000017500000001761712655767354016430 0ustar uwabamiuwabami--- :name: slaed7 :md5sum: b12e352cfd0208ab191e0ebd1f68ecd6 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - n: :type: integer :intent: input - qsiz: :type: integer :intent: input - tlvls: :type: integer :intent: input - curlvl: :type: integer :intent: input - curpbm: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - q: :type: real :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - indxq: :type: integer :intent: output :dims: - n - rho: :type: real :intent: input - cutpnt: :type: integer :intent: input - qstore: :type: real :intent: input/output :dims: - pow(n,2)+1 - qptr: :type: integer :intent: input/output :dims: - n+2 - prmptr: :type: integer :intent: input :dims: - n*LG(n) - perm: :type: integer :intent: input :dims: - n*LG(n) - givptr: :type: integer :intent: input :dims: - n*LG(n) - givcol: :type: integer :intent: input :dims: - "2" - n*LG(n) - givnum: :type: real :intent: input :dims: - "2" - n*LG(n) - work: :type: real :intent: workspace :dims: - 3*n+qsiz*n - iwork: :type: integer :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR, PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAED7 computes the updated eigensystem of a diagonal\n\ * matrix after modification by a rank-one symmetric matrix. This\n\ * routine is used only for the eigenproblem which requires all\n\ * eigenvalues and optionally eigenvectors of a dense symmetric matrix\n\ * that has been reduced to tridiagonal form. SLAED1 handles\n\ * the case in which all eigenvalues and eigenvectors of a symmetric\n\ * tridiagonal matrix are desired.\n\ *\n\ * T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)\n\ *\n\ * where Z = Q'u, u is a vector of length N with ones in the\n\ * CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.\n\ *\n\ * The eigenvectors of the original matrix are stored in Q, and the\n\ * eigenvalues are in D. The algorithm consists of three stages:\n\ *\n\ * The first stage consists of deflating the size of the problem\n\ * when there are multiple eigenvalues or if there is a zero in\n\ * the Z vector. For each such occurrence the dimension of the\n\ * secular equation problem is reduced by one. This stage is\n\ * performed by the routine SLAED8.\n\ *\n\ * The second stage consists of calculating the updated\n\ * eigenvalues. This is done by finding the roots of the secular\n\ * equation via the routine SLAED4 (as called by SLAED9).\n\ * This routine also calculates the eigenvectors of the current\n\ * problem.\n\ *\n\ * The final stage consists of computing the updated eigenvectors\n\ * directly using the updated eigenvalues. The eigenvectors for\n\ * the current problem are multiplied with the eigenvectors from\n\ * the overall problem.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ICOMPQ (input) INTEGER\n\ * = 0: Compute eigenvalues only.\n\ * = 1: Compute eigenvectors of original dense symmetric matrix\n\ * also. On entry, Q contains the orthogonal matrix used\n\ * to reduce the original matrix to tridiagonal form.\n\ *\n\ * N (input) INTEGER\n\ * The dimension of the symmetric tridiagonal matrix. N >= 0.\n\ *\n\ * QSIZ (input) INTEGER\n\ * The dimension of the orthogonal matrix used to reduce\n\ * the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.\n\ *\n\ * TLVLS (input) INTEGER\n\ * The total number of merging levels in the overall divide and\n\ * conquer tree.\n\ *\n\ * CURLVL (input) INTEGER\n\ * The current level in the overall merge routine,\n\ * 0 <= CURLVL <= TLVLS.\n\ *\n\ * CURPBM (input) INTEGER\n\ * The current problem in the current level in the overall\n\ * merge routine (counting from upper left to lower right).\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the eigenvalues of the rank-1-perturbed matrix.\n\ * On exit, the eigenvalues of the repaired matrix.\n\ *\n\ * Q (input/output) REAL array, dimension (LDQ, N)\n\ * On entry, the eigenvectors of the rank-1-perturbed matrix.\n\ * On exit, the eigenvectors of the repaired tridiagonal matrix.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N).\n\ *\n\ * INDXQ (output) INTEGER array, dimension (N)\n\ * The permutation which will reintegrate the subproblem just\n\ * solved back into sorted order, i.e., D( INDXQ( I = 1, N ) )\n\ * will be in ascending order.\n\ *\n\ * RHO (input) REAL\n\ * The subdiagonal element used to create the rank-1\n\ * modification.\n\ *\n\ * CUTPNT (input) INTEGER\n\ * Contains the location of the last eigenvalue in the leading\n\ * sub-matrix. min(1,N) <= CUTPNT <= N.\n\ *\n\ * QSTORE (input/output) REAL array, dimension (N**2+1)\n\ * Stores eigenvectors of submatrices encountered during\n\ * divide and conquer, packed together. QPTR points to\n\ * beginning of the submatrices.\n\ *\n\ * QPTR (input/output) INTEGER array, dimension (N+2)\n\ * List of indices pointing to beginning of submatrices stored\n\ * in QSTORE. The submatrices are numbered starting at the\n\ * bottom left of the divide and conquer tree, from left to\n\ * right and bottom to top.\n\ *\n\ * PRMPTR (input) INTEGER array, dimension (N lg N)\n\ * Contains a list of pointers which indicate where in PERM a\n\ * level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)\n\ * indicates the size of the permutation and also the size of\n\ * the full, non-deflated problem.\n\ *\n\ * PERM (input) INTEGER array, dimension (N lg N)\n\ * Contains the permutations (from deflation and sorting) to be\n\ * applied to each eigenblock.\n\ *\n\ * GIVPTR (input) INTEGER array, dimension (N lg N)\n\ * Contains a list of pointers which indicate where in GIVCOL a\n\ * level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)\n\ * indicates the number of Givens rotations.\n\ *\n\ * GIVCOL (input) INTEGER array, dimension (2, N lg N)\n\ * Each pair of numbers indicates a pair of columns to take place\n\ * in a Givens rotation.\n\ *\n\ * GIVNUM (input) REAL array, dimension (2, N lg N)\n\ * Each number indicates the S value to be used in the\n\ * corresponding Givens rotation.\n\ *\n\ * WORK (workspace) REAL array, dimension (3*N+QSIZ*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (4*N)\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 = 1, an eigenvalue did not converge\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Jeff Rutter, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhecon0000644000175000017500000000524412502223526016503 0ustar uwabamiuwabami--- :name: zhecon :md5sum: a7a7115b4ebb274e00fbe09d609df27c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZHECON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHECON estimates the reciprocal of the condition number of a complex\n\ * Hermitian matrix A using the factorization A = U*D*U**H or\n\ * A = L*D*L**H computed by ZHETRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**H;\n\ * = 'L': Lower triangular, form is A = L*D*L**H.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by ZHETRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by ZHETRF.\n\ *\n\ * ANORM (input) DOUBLE PRECISION\n\ * The 1-norm of the original matrix A.\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n\ * estimate of the 1-norm of inv(A) computed in this routine.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dpbequ0000644000175000017500000000630312502223526016472 0ustar uwabamiuwabami--- :name: dpbequ :md5sum: 0bbb9cf6bd18888eaa8a1e40f750a9a9 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - n - scond: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPBEQU computes row and column scalings intended to equilibrate a\n\ * symmetric positive definite band matrix A and reduce its condition\n\ * number (with respect to the two-norm). S contains the scale factors,\n\ * S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n\ * elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n\ * choice of S puts the condition number of B within a factor N of the\n\ * smallest possible condition number over all possible diagonal\n\ * scalings.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangular of A is stored;\n\ * = 'L': Lower triangular of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * The upper or lower triangle of the symmetric band matrix A,\n\ * stored in the first KD+1 rows of the array. The j-th column\n\ * of A is stored in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array A. LDAB >= KD+1.\n\ *\n\ * S (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, S contains the scale factors for A.\n\ *\n\ * SCOND (output) DOUBLE PRECISION\n\ * If INFO = 0, S contains the ratio of the smallest S(i) to\n\ * the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n\ * large nor too small, it is not worth scaling by S.\n\ *\n\ * AMAX (output) DOUBLE PRECISION\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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 is nonpositive.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zpptrs0000644000175000017500000000521412502223526016554 0ustar uwabamiuwabami--- :name: zpptrs :md5sum: d37e45414eb53199139da50e79aa0dc5 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPPTRS solves a system of linear equations A*X = B with a Hermitian\n\ * positive definite matrix A in packed storage using the Cholesky\n\ * factorization A = U**H*U or A = L*L**H computed by ZPPTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**H*U or A = L*L**H, packed columnwise in a linear\n\ * array. The j-th column of U or L is stored in the array AP\n\ * as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL UPPER\n INTEGER I\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZTPSV\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dla_syamv0000644000175000017500000001120312502223526017164 0ustar uwabamiuwabami--- :name: dla_syamv :md5sum: ead79408a2a6f903222a56b448313185 :category: :subroutine :arguments: - uplo: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: doublereal :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: doublereal :intent: input :dims: - 1 + ( n - 1 )*abs( incx ) - incx: :type: integer :intent: input - beta: :type: doublereal :intent: input - y: :type: doublereal :intent: input/output :dims: - 1 + ( n - 1 )*abs( incy ) - incy: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE DLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLA_SYAMV performs the matrix-vector operation\n\ *\n\ * y := alpha*abs(A)*abs(x) + beta*abs(y),\n\ *\n\ * where alpha and beta are scalars, x and y are vectors and A is an\n\ * n by n symmetric matrix.\n\ *\n\ * This function is primarily used in calculating error bounds.\n\ * To protect against underflow during evaluation, components in\n\ * the resulting vector are perturbed away from zero by (N+1)\n\ * times the underflow threshold. To prevent unnecessarily large\n\ * errors for block-structure embedded in general matrices,\n\ * \"symbolically\" zero components are not perturbed. A zero\n\ * entry is considered \"symbolic\" if all multiplications involved\n\ * in computing that entry have at least one zero multiplicand.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * UPLO (input) INTEGER\n\ * On entry, UPLO specifies whether the upper or lower\n\ * triangular part of the array A is to be referenced as\n\ * follows:\n\ *\n\ * UPLO = BLAS_UPPER Only the upper triangular part of A\n\ * is to be referenced.\n\ *\n\ * UPLO = BLAS_LOWER Only the lower triangular part of A\n\ * is to be referenced.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the number of columns of the matrix A.\n\ * N must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * ALPHA - DOUBLE PRECISION .\n\ * On entry, ALPHA specifies the scalar alpha.\n\ * Unchanged on exit.\n\ *\n\ * A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).\n\ * Before entry, the leading m by n part of the array A must\n\ * contain the matrix of coefficients.\n\ * Unchanged on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * On entry, LDA specifies the first dimension of A as declared\n\ * in the calling (sub) program. LDA must be at least\n\ * max( 1, n ).\n\ * Unchanged on exit.\n\ *\n\ * X (input) DOUBLE PRECISION array, dimension\n\ * ( 1 + ( n - 1 )*abs( INCX ) )\n\ * Before entry, the incremented array X must contain the\n\ * vector x.\n\ * Unchanged on exit.\n\ *\n\ * INCX (input) INTEGER\n\ * On entry, INCX specifies the increment for the elements of\n\ * X. INCX must not be zero.\n\ * Unchanged on exit.\n\ *\n\ * BETA - DOUBLE PRECISION .\n\ * On entry, BETA specifies the scalar beta. When BETA is\n\ * supplied as zero then Y need not be set on input.\n\ * Unchanged on exit.\n\ *\n\ * Y (input/output) DOUBLE PRECISION array, dimension\n\ * ( 1 + ( n - 1 )*abs( INCY ) )\n\ * Before entry with BETA non-zero, the incremented array Y\n\ * must contain the vector y. On exit, Y is overwritten by the\n\ * updated vector y.\n\ *\n\ * INCY (input) INTEGER\n\ * On entry, INCY specifies the increment for the elements of\n\ * Y. INCY must not be zero.\n\ * Unchanged on exit.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Level 2 Blas routine.\n\ *\n\ * -- Written on 22-October-1986.\n\ * Jack Dongarra, Argonne National Lab.\n\ * Jeremy Du Croz, Nag Central Office.\n\ * Sven Hammarling, Nag Central Office.\n\ * Richard Hanson, Sandia National Labs.\n\ * -- Modified for the absolute-value product, April 2006\n\ * Jason Riedy, UC Berkeley\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgbrfsx0000644000175000017500000004270512502223526016657 0ustar uwabamiuwabami--- :name: dgbrfsx :md5sum: 1b319e91516e78be13a336d591bba7fe :category: :subroutine :arguments: - trans: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublereal :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - r: :type: doublereal :intent: input/output :dims: - n - c: :type: doublereal :intent: input/output :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublereal :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " SUBROUTINE DGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGBRFSX improves the computed solution to a system of linear\n\ * equations and provides error bounds and backward error estimates\n\ * for the solution. In addition to normwise error bound, the code\n\ * provides maximum componentwise error bound if possible. See\n\ * comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n\ * error bounds.\n\ *\n\ * The original system of linear equations may have been equilibrated\n\ * before calling this routine, as described by arguments EQUED, R\n\ * and C below. In this case, the solution and error bounds returned\n\ * are for the original unequilibrated system.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose = Transpose)\n\ *\n\ * EQUED (input) CHARACTER*1\n\ * Specifies the form of equilibration that was done to A\n\ * before calling this routine. This is needed to compute\n\ * the solution and error bounds correctly.\n\ * = 'N': No equilibration\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ * The right hand side B has been changed accordingly.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * The original band matrix A, stored in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n\ * Details of the LU factorization of the band matrix A, as\n\ * computed by DGBTRF. U is stored as an upper triangular band\n\ * matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n\ * the multipliers used during the factorization are stored in\n\ * rows KL+KU+2 to 2*KL+KU+1.\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from DGETRF; for 1<=i<=N, row i of the\n\ * matrix was interchanged with row IPIV(i).\n\ *\n\ * R (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'R' or 'B', A is\n\ * multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n\ * is not accessed. R is an input argument if FACT = 'F';\n\ * otherwise, R is an output argument. If FACT = 'F' and\n\ * EQUED = 'R' or 'B', each element of R must be positive.\n\ * If R is output, each element of R is a power of the radix.\n\ * If R is input, each element of R should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * C (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The column scale factors for A. If EQUED = 'C' or 'B', A is\n\ * multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n\ * is not accessed. C is an input argument if FACT = 'F';\n\ * otherwise, C is an output argument. If FACT = 'F' and\n\ * EQUED = 'C' or 'B', each element of C must be positive.\n\ * If C is output, each element of C is a power of the radix.\n\ * If C is input, each element of C should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by DGETRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * Componentwise relative backward error. This is the\n\ * componentwise relative backward error of each solution vector X(j)\n\ * (i.e., the smallest relative change in any element of A or B that\n\ * makes X(j) an exact solution).\n\ *\n\ * N_ERR_BNDS (input) INTEGER\n\ * Number of error bounds to return for each right hand side\n\ * and each type (normwise or componentwise). See ERR_BNDS_NORM and\n\ * ERR_BNDS_COMP below.\n\ *\n\ * ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * dlamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * dlamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * dlamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * dlamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * dlamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * dlamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * NPARAMS (input) INTEGER\n\ * Specifies the number of parameters set in PARAMS. If .LE. 0, the\n\ * PARAMS array is never referenced and default values are used.\n\ *\n\ * PARAMS (input / output) DOUBLE PRECISION array, dimension (NPARAMS)\n\ * Specifies algorithm parameters. If an entry is .LT. 0.0, then\n\ * that entry will be filled with default value used for that\n\ * parameter. Only positions up to NPARAMS are accessed; defaults\n\ * are used for higher-numbered parameters.\n\ *\n\ * PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n\ * refinement or not.\n\ * Default: 1.0D+0\n\ * = 0.0 : No refinement is performed, and no error bounds are\n\ * computed.\n\ * = 1.0 : Use the double-precision refinement algorithm,\n\ * possibly with doubled-single computations if the\n\ * compilation environment does not support DOUBLE\n\ * PRECISION.\n\ * (other values are reserved for future use)\n\ *\n\ * PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n\ * computations allowed for refinement.\n\ * Default: 10\n\ * Aggressive: Set to 100 to permit convergence using approximate\n\ * factorizations or factorizations other than LU. If\n\ * the factorization uses a technique other than\n\ * Gaussian elimination, the guarantees in\n\ * err_bnds_norm and err_bnds_comp may no longer be\n\ * trustworthy.\n\ *\n\ * PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n\ * will attempt to find a solution with small componentwise\n\ * relative error in the double-precision algorithm. Positive\n\ * is true, 0.0 is false.\n\ * Default: 1.0 (attempt componentwise convergence)\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit. The solution to every right-hand side is\n\ * guaranteed.\n\ * < 0: If INFO = -i, the i-th argument had an illegal value\n\ * > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slals00000644000175000017500000001657212502223526016421 0ustar uwabamiuwabami--- :name: slals0 :md5sum: 14617d38dd37bd0a84a9ec2cb4910f09 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - nl: :type: integer :intent: input - nr: :type: integer :intent: input - sqre: :type: integer :intent: input - nrhs: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - bx: :type: real :intent: workspace :dims: - ldbx - nrhs - ldbx: :type: integer :intent: input - perm: :type: integer :intent: input :dims: - n - givptr: :type: integer :intent: input - givcol: :type: integer :intent: input :dims: - ldgcol - "2" - ldgcol: :type: integer :intent: input - givnum: :type: real :intent: input :dims: - ldgnum - "2" - ldgnum: :type: integer :intent: input - poles: :type: real :intent: input :dims: - ldgnum - "2" - difl: :type: real :intent: input :dims: - k - difr: :type: real :intent: input :dims: - ldgnum - "2" - z: :type: real :intent: input :dims: - k - k: :type: integer :intent: input - c: :type: real :intent: input - s: :type: real :intent: input - work: :type: real :intent: workspace :dims: - k - info: :type: integer :intent: output :substitutions: ldbx: n :fortran_help: " SUBROUTINE SLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLALS0 applies back the multiplying factors of either the left or the\n\ * right singular vector matrix of a diagonal matrix appended by a row\n\ * to the right hand side matrix B in solving the least squares problem\n\ * using the divide-and-conquer SVD approach.\n\ *\n\ * For the left singular vector matrix, three types of orthogonal\n\ * matrices are involved:\n\ *\n\ * (1L) Givens rotations: the number of such rotations is GIVPTR; the\n\ * pairs of columns/rows they were applied to are stored in GIVCOL;\n\ * and the C- and S-values of these rotations are stored in GIVNUM.\n\ *\n\ * (2L) Permutation. The (NL+1)-st row of B is to be moved to the first\n\ * row, and for J=2:N, PERM(J)-th row of B is to be moved to the\n\ * J-th row.\n\ *\n\ * (3L) The left singular vector matrix of the remaining matrix.\n\ *\n\ * For the right singular vector matrix, four types of orthogonal\n\ * matrices are involved:\n\ *\n\ * (1R) The right singular vector matrix of the remaining matrix.\n\ *\n\ * (2R) If SQRE = 1, one extra Givens rotation to generate the right\n\ * null space.\n\ *\n\ * (3R) The inverse transformation of (2L).\n\ *\n\ * (4R) The inverse transformation of (1L).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ICOMPQ (input) INTEGER\n\ * Specifies whether singular vectors are to be computed in\n\ * factored form:\n\ * = 0: Left singular vector matrix.\n\ * = 1: Right singular vector matrix.\n\ *\n\ * NL (input) INTEGER\n\ * The row dimension of the upper block. NL >= 1.\n\ *\n\ * NR (input) INTEGER\n\ * The row dimension of the lower block. NR >= 1.\n\ *\n\ * SQRE (input) INTEGER\n\ * = 0: the lower block is an NR-by-NR square matrix.\n\ * = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n\ *\n\ * The bidiagonal matrix has row dimension N = NL + NR + 1,\n\ * and column dimension M = N + SQRE.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of columns of B and BX. NRHS must be at least 1.\n\ *\n\ * B (input/output) REAL array, dimension ( LDB, NRHS )\n\ * On input, B contains the right hand sides of the least\n\ * squares problem in rows 1 through M. On output, B contains\n\ * the solution X in rows 1 through N.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B. LDB must be at least\n\ * max(1,MAX( M, N ) ).\n\ *\n\ * BX (workspace) REAL array, dimension ( LDBX, NRHS )\n\ *\n\ * LDBX (input) INTEGER\n\ * The leading dimension of BX.\n\ *\n\ * PERM (input) INTEGER array, dimension ( N )\n\ * The permutations (from deflation and sorting) applied\n\ * to the two blocks.\n\ *\n\ * GIVPTR (input) INTEGER\n\ * The number of Givens rotations which took place in this\n\ * subproblem.\n\ *\n\ * GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )\n\ * Each pair of numbers indicates a pair of rows/columns\n\ * involved in a Givens rotation.\n\ *\n\ * LDGCOL (input) INTEGER\n\ * The leading dimension of GIVCOL, must be at least N.\n\ *\n\ * GIVNUM (input) REAL array, dimension ( LDGNUM, 2 )\n\ * Each number indicates the C or S value used in the\n\ * corresponding Givens rotation.\n\ *\n\ * LDGNUM (input) INTEGER\n\ * The leading dimension of arrays DIFR, POLES and\n\ * GIVNUM, must be at least K.\n\ *\n\ * POLES (input) REAL array, dimension ( LDGNUM, 2 )\n\ * On entry, POLES(1:K, 1) contains the new singular\n\ * values obtained from solving the secular equation, and\n\ * POLES(1:K, 2) is an array containing the poles in the secular\n\ * equation.\n\ *\n\ * DIFL (input) REAL array, dimension ( K ).\n\ * On entry, DIFL(I) is the distance between I-th updated\n\ * (undeflated) singular value and the I-th (undeflated) old\n\ * singular value.\n\ *\n\ * DIFR (input) REAL array, dimension ( LDGNUM, 2 ).\n\ * On entry, DIFR(I, 1) contains the distances between I-th\n\ * updated (undeflated) singular value and the I+1-th\n\ * (undeflated) old singular value. And DIFR(I, 2) is the\n\ * normalizing factor for the I-th right singular vector.\n\ *\n\ * Z (input) REAL array, dimension ( K )\n\ * Contain the components of the deflation-adjusted updating row\n\ * vector.\n\ *\n\ * K (input) INTEGER\n\ * Contains the dimension of the non-deflated matrix,\n\ * This is the order of the related secular equation. 1 <= K <=N.\n\ *\n\ * C (input) REAL\n\ * C contains garbage if SQRE =0 and the C-value of a Givens\n\ * rotation related to the right null space if SQRE = 1.\n\ *\n\ * S (input) REAL\n\ * S contains garbage if SQRE =0 and the S-value of a Givens\n\ * rotation related to the right null space if SQRE = 1.\n\ *\n\ * WORK (workspace) REAL array, dimension ( K )\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\ * Based on contributions by\n\ * Ming Gu and Ren-Cang Li, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctgsja0000644000175000017500000002564612502223525016477 0ustar uwabamiuwabami--- :name: ctgsja :md5sum: 694244b545f1c3526c7c564611a2e147 :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobv: :type: char :intent: input - jobq: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - tola: :type: real :intent: input - tolb: :type: real :intent: input - alpha: :type: real :intent: output :dims: - n - beta: :type: real :intent: output :dims: - n - u: :type: complex :intent: input/output :dims: - ldu - m - ldu: :type: integer :intent: input - v: :type: complex :intent: input/output :dims: - ldv - p - ldv: :type: integer :intent: input - q: :type: complex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - 2*n - ncycle: :type: integer :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, NCYCLE, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTGSJA computes the generalized singular value decomposition (GSVD)\n\ * of two complex upper triangular (or trapezoidal) matrices A and B.\n\ *\n\ * On entry, it is assumed that matrices A and B have the following\n\ * forms, which may be obtained by the preprocessing subroutine CGGSVP\n\ * from a general M-by-N matrix A and P-by-N matrix B:\n\ *\n\ * N-K-L K L\n\ * A = K ( 0 A12 A13 ) if M-K-L >= 0;\n\ * L ( 0 0 A23 )\n\ * M-K-L ( 0 0 0 )\n\ *\n\ * N-K-L K L\n\ * A = K ( 0 A12 A13 ) if M-K-L < 0;\n\ * M-K ( 0 0 A23 )\n\ *\n\ * N-K-L K L\n\ * B = L ( 0 0 B13 )\n\ * P-L ( 0 0 0 )\n\ *\n\ * where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n\ * upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n\ * otherwise A23 is (M-K)-by-L upper trapezoidal.\n\ *\n\ * On exit,\n\ *\n\ * U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ),\n\ *\n\ * where U, V and Q are unitary matrices, Z' denotes the conjugate\n\ * transpose of Z, R is a nonsingular upper triangular matrix, and D1\n\ * and D2 are ``diagonal'' matrices, which are of the following\n\ * structures:\n\ *\n\ * If M-K-L >= 0,\n\ *\n\ * K L\n\ * D1 = K ( I 0 )\n\ * L ( 0 C )\n\ * M-K-L ( 0 0 )\n\ *\n\ * K L\n\ * D2 = L ( 0 S )\n\ * P-L ( 0 0 )\n\ *\n\ * N-K-L K L\n\ * ( 0 R ) = K ( 0 R11 R12 ) K\n\ * L ( 0 0 R22 ) L\n\ *\n\ * where\n\ *\n\ * C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n\ * S = diag( BETA(K+1), ... , BETA(K+L) ),\n\ * C**2 + S**2 = I.\n\ *\n\ * R is stored in A(1:K+L,N-K-L+1:N) on exit.\n\ *\n\ * If M-K-L < 0,\n\ *\n\ * K M-K K+L-M\n\ * D1 = K ( I 0 0 )\n\ * M-K ( 0 C 0 )\n\ *\n\ * K M-K K+L-M\n\ * D2 = M-K ( 0 S 0 )\n\ * K+L-M ( 0 0 I )\n\ * P-L ( 0 0 0 )\n\ *\n\ * N-K-L K M-K K+L-M\n\ * ( 0 R ) = K ( 0 R11 R12 R13 )\n\ * M-K ( 0 0 R22 R23 )\n\ * K+L-M ( 0 0 0 R33 )\n\ *\n\ * where\n\ * C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n\ * S = diag( BETA(K+1), ... , BETA(M) ),\n\ * C**2 + S**2 = I.\n\ *\n\ * R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored\n\ * ( 0 R22 R23 )\n\ * in B(M-K+1:L,N+M-K-L+1:N) on exit.\n\ *\n\ * The computation of the unitary transformation matrices U, V or Q\n\ * is optional. These matrices may either be formed explicitly, or they\n\ * may be postmultiplied into input matrices U1, V1, or Q1.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBU (input) CHARACTER*1\n\ * = 'U': U must contain a unitary matrix U1 on entry, and\n\ * the product U1*U is returned;\n\ * = 'I': U is initialized to the unit matrix, and the\n\ * unitary matrix U is returned;\n\ * = 'N': U is not computed.\n\ *\n\ * JOBV (input) CHARACTER*1\n\ * = 'V': V must contain a unitary matrix V1 on entry, and\n\ * the product V1*V is returned;\n\ * = 'I': V is initialized to the unit matrix, and the\n\ * unitary matrix V is returned;\n\ * = 'N': V is not computed.\n\ *\n\ * JOBQ (input) CHARACTER*1\n\ * = 'Q': Q must contain a unitary matrix Q1 on entry, and\n\ * the product Q1*Q is returned;\n\ * = 'I': Q is initialized to the unit matrix, and the\n\ * unitary matrix Q is returned;\n\ * = 'N': Q is not computed.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A. M >= 0.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows of the matrix B. P >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrices A and B. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * L (input) INTEGER\n\ * K and L specify the subblocks in the input matrices A and B:\n\ * A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,,N-L+1:N)\n\ * of A and B, whose GSVD is going to be computed by CTGSJA.\n\ * See Further Details.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular\n\ * matrix R or part of R. See Purpose for details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,N)\n\ * On entry, the P-by-N matrix B.\n\ * On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains\n\ * a part of R. See Purpose for details.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,P).\n\ *\n\ * TOLA (input) REAL\n\ * TOLB (input) REAL\n\ * TOLA and TOLB are the convergence criteria for the Jacobi-\n\ * Kogbetliantz iteration procedure. Generally, they are the\n\ * same as used in the preprocessing step, say\n\ * TOLA = MAX(M,N)*norm(A)*MACHEPS,\n\ * TOLB = MAX(P,N)*norm(B)*MACHEPS.\n\ *\n\ * ALPHA (output) REAL array, dimension (N)\n\ * BETA (output) REAL array, dimension (N)\n\ * On exit, ALPHA and BETA contain the generalized singular\n\ * value pairs of A and B;\n\ * ALPHA(1:K) = 1,\n\ * BETA(1:K) = 0,\n\ * and if M-K-L >= 0,\n\ * ALPHA(K+1:K+L) = diag(C),\n\ * BETA(K+1:K+L) = diag(S),\n\ * or if M-K-L < 0,\n\ * ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0\n\ * BETA(K+1:M) = S, BETA(M+1:K+L) = 1.\n\ * Furthermore, if K+L < N,\n\ * ALPHA(K+L+1:N) = 0\n\ * BETA(K+L+1:N) = 0.\n\ *\n\ * U (input/output) COMPLEX array, dimension (LDU,M)\n\ * On entry, if JOBU = 'U', U must contain a matrix U1 (usually\n\ * the unitary matrix returned by CGGSVP).\n\ * On exit,\n\ * if JOBU = 'I', U contains the unitary matrix U;\n\ * if JOBU = 'U', U contains the product U1*U.\n\ * If JOBU = 'N', U is not referenced.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= max(1,M) if\n\ * JOBU = 'U'; LDU >= 1 otherwise.\n\ *\n\ * V (input/output) COMPLEX array, dimension (LDV,P)\n\ * On entry, if JOBV = 'V', V must contain a matrix V1 (usually\n\ * the unitary matrix returned by CGGSVP).\n\ * On exit,\n\ * if JOBV = 'I', V contains the unitary matrix V;\n\ * if JOBV = 'V', V contains the product V1*V.\n\ * If JOBV = 'N', V is not referenced.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V. LDV >= max(1,P) if\n\ * JOBV = 'V'; LDV >= 1 otherwise.\n\ *\n\ * Q (input/output) COMPLEX array, dimension (LDQ,N)\n\ * On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually\n\ * the unitary matrix returned by CGGSVP).\n\ * On exit,\n\ * if JOBQ = 'I', Q contains the unitary matrix Q;\n\ * if JOBQ = 'Q', Q contains the product Q1*Q.\n\ * If JOBQ = 'N', Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N) if\n\ * JOBQ = 'Q'; LDQ >= 1 otherwise.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * NCYCLE (output) INTEGER\n\ * The number of cycles required for convergence.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * = 1: the procedure does not converge after MAXIT cycles.\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * MAXIT INTEGER\n\ * MAXIT specifies the total loops that the iterative procedure\n\ * may take. If after MAXIT cycles, the routine fails to\n\ * converge, we return INFO = 1.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * CTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce\n\ * min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L\n\ * matrix B13 to the form:\n\ *\n\ * U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1,\n\ *\n\ * where U1, V1 and Q1 are unitary matrix, and Z' is the conjugate\n\ * transpose of Z. C1 and S1 are diagonal matrices satisfying\n\ *\n\ * C1**2 + S1**2 = I,\n\ *\n\ * and R1 is an L-by-L nonsingular upper triangular matrix.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cunmbr0000644000175000017500000001425012502223526016500 0ustar uwabamiuwabami--- :name: cunmbr :md5sum: a13ce3f061a13acebd53efeb52145740 :category: :subroutine :arguments: - vect: :type: char :intent: input - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - MIN(nq,k) - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - MIN(nq,k) - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: nq: "lsame_(&side,\"L\") ? m : lsame_(&side,\"R\") ? n : 0" :extras: nq: integer :fortran_help: " SUBROUTINE CUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * If VECT = 'Q', CUNMBR overwrites the general complex M-by-N matrix C\n\ * with\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'C': Q**H * C C * Q**H\n\ *\n\ * If VECT = 'P', CUNMBR overwrites the general complex M-by-N matrix C\n\ * with\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': P * C C * P\n\ * TRANS = 'C': P**H * C C * P**H\n\ *\n\ * Here Q and P**H are the unitary matrices determined by CGEBRD when\n\ * reducing a complex matrix A to bidiagonal form: A = Q * B * P**H. Q\n\ * and P**H are defined as products of elementary reflectors H(i) and\n\ * G(i) respectively.\n\ *\n\ * Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the\n\ * order of the unitary matrix Q or P**H that is applied.\n\ *\n\ * If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:\n\ * if nq >= k, Q = H(1) H(2) . . . H(k);\n\ * if nq < k, Q = H(1) H(2) . . . H(nq-1).\n\ *\n\ * If VECT = 'P', A is assumed to have been a K-by-NQ matrix:\n\ * if k < nq, P = G(1) G(2) . . . G(k);\n\ * if k >= nq, P = G(1) G(2) . . . G(nq-1).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * VECT (input) CHARACTER*1\n\ * = 'Q': apply Q or Q**H;\n\ * = 'P': apply P or P**H.\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q, Q**H, P or P**H from the Left;\n\ * = 'R': apply Q, Q**H, P or P**H from the Right.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q or P;\n\ * = 'C': Conjugate transpose, apply Q**H or P**H.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * If VECT = 'Q', the number of columns in the original\n\ * matrix reduced by CGEBRD.\n\ * If VECT = 'P', the number of rows in the original\n\ * matrix reduced by CGEBRD.\n\ * K >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension\n\ * (LDA,min(nq,K)) if VECT = 'Q'\n\ * (LDA,nq) if VECT = 'P'\n\ * The vectors which define the elementary reflectors H(i) and\n\ * G(i), whose products determine the matrices Q and P, as\n\ * returned by CGEBRD.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ * If VECT = 'Q', LDA >= max(1,nq);\n\ * if VECT = 'P', LDA >= max(1,min(nq,K)).\n\ *\n\ * TAU (input) COMPLEX array, dimension (min(nq,K))\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i) or G(i) which determines Q or P, as returned\n\ * by CGEBRD in the array argument TAUQ or TAUP.\n\ *\n\ * C (input/output) COMPLEX array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q\n\ * or P*C or P**H*C or C*P or C*P**H.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace/output) COMPLEX 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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M);\n\ * if N = 0 or M = 0, LWORK >= 1.\n\ * For optimum performance LWORK >= max(1,N*NB) if SIDE = 'L',\n\ * and LWORK >= max(1,M*NB) if SIDE = 'R', where NB is the\n\ * optimal blocksize. (NB = 0 if M = 0 or N = 0.)\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\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN\n CHARACTER TRANST\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL ILAENV, LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CUNMLQ, CUNMQR, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlasy20000644000175000017500000001007412502223526016410 0ustar uwabamiuwabami--- :name: dlasy2 :md5sum: 88846cd9774931667a402f668ac7bcbe :category: :subroutine :arguments: - ltranl: :type: logical :intent: input - ltranr: :type: logical :intent: input - isgn: :type: integer :intent: input - n1: :type: integer :intent: input - n2: :type: integer :intent: input - tl: :type: doublereal :intent: input :dims: - ldtl - "2" - ldtl: :type: integer :intent: input - tr: :type: doublereal :intent: input :dims: - ldtr - "2" - ldtr: :type: integer :intent: input - b: :type: doublereal :intent: input :dims: - ldb - "2" - ldb: :type: integer :intent: input - scale: :type: doublereal :intent: output - x: :type: doublereal :intent: output :dims: - ldx - "2" - ldx: :type: integer :intent: input - xnorm: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n1) :fortran_help: " SUBROUTINE DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in\n\ *\n\ * op(TL)*X + ISGN*X*op(TR) = SCALE*B,\n\ *\n\ * where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or\n\ * -1. op(T) = T or T', where T' denotes the transpose of T.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * LTRANL (input) LOGICAL\n\ * On entry, LTRANL specifies the op(TL):\n\ * = .FALSE., op(TL) = TL,\n\ * = .TRUE., op(TL) = TL'.\n\ *\n\ * LTRANR (input) LOGICAL\n\ * On entry, LTRANR specifies the op(TR):\n\ * = .FALSE., op(TR) = TR,\n\ * = .TRUE., op(TR) = TR'.\n\ *\n\ * ISGN (input) INTEGER\n\ * On entry, ISGN specifies the sign of the equation\n\ * as described before. ISGN may only be 1 or -1.\n\ *\n\ * N1 (input) INTEGER\n\ * On entry, N1 specifies the order of matrix TL.\n\ * N1 may only be 0, 1 or 2.\n\ *\n\ * N2 (input) INTEGER\n\ * On entry, N2 specifies the order of matrix TR.\n\ * N2 may only be 0, 1 or 2.\n\ *\n\ * TL (input) DOUBLE PRECISION array, dimension (LDTL,2)\n\ * On entry, TL contains an N1 by N1 matrix.\n\ *\n\ * LDTL (input) INTEGER\n\ * The leading dimension of the matrix TL. LDTL >= max(1,N1).\n\ *\n\ * TR (input) DOUBLE PRECISION array, dimension (LDTR,2)\n\ * On entry, TR contains an N2 by N2 matrix.\n\ *\n\ * LDTR (input) INTEGER\n\ * The leading dimension of the matrix TR. LDTR >= max(1,N2).\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,2)\n\ * On entry, the N1 by N2 matrix B contains the right-hand\n\ * side of the equation.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the matrix B. LDB >= max(1,N1).\n\ *\n\ * SCALE (output) DOUBLE PRECISION\n\ * On exit, SCALE contains the scale factor. SCALE is chosen\n\ * less than or equal to 1 to prevent the solution overflowing.\n\ *\n\ * X (output) DOUBLE PRECISION array, dimension (LDX,2)\n\ * On exit, X contains the N1 by N2 solution.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the matrix X. LDX >= max(1,N1).\n\ *\n\ * XNORM (output) DOUBLE PRECISION\n\ * On exit, XNORM is the infinity-norm of the solution.\n\ *\n\ * INFO (output) INTEGER\n\ * On exit, INFO is set to\n\ * 0: successful exit.\n\ * 1: TL and TR have too close eigenvalues, so TL or\n\ * TR is perturbed to get a nonsingular equation.\n\ * NOTE: In the interests of speed, this routine does not\n\ * check the inputs for errors.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgbrfsx0000644000175000017500000004272012502223526016702 0ustar uwabamiuwabami--- :name: zgbrfsx :md5sum: c8d8f3dcda58c3e51f64c2c62e669a25 :category: :subroutine :arguments: - trans: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublereal :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - r: :type: doublereal :intent: input/output :dims: - n - c: :type: doublereal :intent: input/output :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " SUBROUTINE ZGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGBRFSX improves the computed solution to a system of linear\n\ * equations and provides error bounds and backward error estimates\n\ * for the solution. In addition to normwise error bound, the code\n\ * provides maximum componentwise error bound if possible. See\n\ * comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n\ * error bounds.\n\ *\n\ * The original system of linear equations may have been equilibrated\n\ * before calling this routine, as described by arguments EQUED, R\n\ * and C below. In this case, the solution and error bounds returned\n\ * are for the original unequilibrated system.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose = Transpose)\n\ *\n\ * EQUED (input) CHARACTER*1\n\ * Specifies the form of equilibration that was done to A\n\ * before calling this routine. This is needed to compute\n\ * the solution and error bounds correctly.\n\ * = 'N': No equilibration\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ * The right hand side B has been changed accordingly.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * The original band matrix A, stored in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n\ * Details of the LU factorization of the band matrix A, as\n\ * computed by DGBTRF. U is stored as an upper triangular band\n\ * matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n\ * the multipliers used during the factorization are stored in\n\ * rows KL+KU+2 to 2*KL+KU+1.\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from DGETRF; for 1<=i<=N, row i of the\n\ * matrix was interchanged with row IPIV(i).\n\ *\n\ * R (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'R' or 'B', A is\n\ * multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n\ * is not accessed. R is an input argument if FACT = 'F';\n\ * otherwise, R is an output argument. If FACT = 'F' and\n\ * EQUED = 'R' or 'B', each element of R must be positive.\n\ * If R is output, each element of R is a power of the radix.\n\ * If R is input, each element of R should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * C (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The column scale factors for A. If EQUED = 'C' or 'B', A is\n\ * multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n\ * is not accessed. C is an input argument if FACT = 'F';\n\ * otherwise, C is an output argument. If FACT = 'F' and\n\ * EQUED = 'C' or 'B', each element of C must be positive.\n\ * If C is output, each element of C is a power of the radix.\n\ * If C is input, each element of C should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by DGETRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * Componentwise relative backward error. This is the\n\ * componentwise relative backward error of each solution vector X(j)\n\ * (i.e., the smallest relative change in any element of A or B that\n\ * makes X(j) an exact solution).\n\ *\n\ * N_ERR_BNDS (input) INTEGER\n\ * Number of error bounds to return for each right hand side\n\ * and each type (normwise or componentwise). See ERR_BNDS_NORM and\n\ * ERR_BNDS_COMP below.\n\ *\n\ * ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * dlamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * dlamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * dlamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * dlamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * dlamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * dlamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * NPARAMS (input) INTEGER\n\ * Specifies the number of parameters set in PARAMS. If .LE. 0, the\n\ * PARAMS array is never referenced and default values are used.\n\ *\n\ * PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS\n\ * Specifies algorithm parameters. If an entry is .LT. 0.0, then\n\ * that entry will be filled with default value used for that\n\ * parameter. Only positions up to NPARAMS are accessed; defaults\n\ * are used for higher-numbered parameters.\n\ *\n\ * PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n\ * refinement or not.\n\ * Default: 1.0D+0\n\ * = 0.0 : No refinement is performed, and no error bounds are\n\ * computed.\n\ * = 1.0 : Use the double-precision refinement algorithm,\n\ * possibly with doubled-single computations if the\n\ * compilation environment does not support DOUBLE\n\ * PRECISION.\n\ * (other values are reserved for future use)\n\ *\n\ * PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n\ * computations allowed for refinement.\n\ * Default: 10\n\ * Aggressive: Set to 100 to permit convergence using approximate\n\ * factorizations or factorizations other than LU. If\n\ * the factorization uses a technique other than\n\ * Gaussian elimination, the guarantees in\n\ * err_bnds_norm and err_bnds_comp may no longer be\n\ * trustworthy.\n\ *\n\ * PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n\ * will attempt to find a solution with small componentwise\n\ * relative error in the double-precision algorithm. Positive\n\ * is true, 0.0 is false.\n\ * Default: 1.0 (attempt componentwise convergence)\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit. The solution to every right-hand side is\n\ * guaranteed.\n\ * < 0: If INFO = -i, the i-th argument had an illegal value\n\ * > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlaev20000644000175000017500000000501312502223526016364 0ustar uwabamiuwabami--- :name: dlaev2 :md5sum: cb9b88b5e51e149c658216cec1ab2953 :category: :subroutine :arguments: - a: :type: doublereal :intent: input - b: :type: doublereal :intent: input - c: :type: doublereal :intent: input - rt1: :type: doublereal :intent: output - rt2: :type: doublereal :intent: output - cs1: :type: doublereal :intent: output - sn1: :type: doublereal :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix\n\ * [ A B ]\n\ * [ B C ].\n\ * On return, RT1 is the eigenvalue of larger absolute value, RT2 is the\n\ * eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right\n\ * eigenvector for RT1, giving the decomposition\n\ *\n\ * [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ]\n\ * [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ].\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * A (input) DOUBLE PRECISION\n\ * The (1,1) element of the 2-by-2 matrix.\n\ *\n\ * B (input) DOUBLE PRECISION\n\ * The (1,2) element and the conjugate of the (2,1) element of\n\ * the 2-by-2 matrix.\n\ *\n\ * C (input) DOUBLE PRECISION\n\ * The (2,2) element of the 2-by-2 matrix.\n\ *\n\ * RT1 (output) DOUBLE PRECISION\n\ * The eigenvalue of larger absolute value.\n\ *\n\ * RT2 (output) DOUBLE PRECISION\n\ * The eigenvalue of smaller absolute value.\n\ *\n\ * CS1 (output) DOUBLE PRECISION\n\ * SN1 (output) DOUBLE PRECISION\n\ * The vector (CS1, SN1) is a unit right eigenvector for RT1.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * RT1 is accurate to a few ulps barring over/underflow.\n\ *\n\ * RT2 may be inaccurate if there is massive cancellation in the\n\ * determinant A*C-B*B; higher precision or correctly rounded or\n\ * correctly truncated arithmetic would be needed to compute RT2\n\ * accurately in all cases.\n\ *\n\ * CS1 and SN1 are accurate to a few ulps barring over/underflow.\n\ *\n\ * Overflow is possible only if RT1 is within a factor of 5 of overflow.\n\ * Underflow is harmless if the input data is 0 or exceeds\n\ * underflow_threshold / macheps.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/stgsyl0000644000175000017500000002255112502223526016542 0ustar uwabamiuwabami--- :name: stgsyl :md5sum: 590e8de996b4d8d7c05f6e8b21245a75 :category: :subroutine :arguments: - trans: :type: char :intent: input - ijob: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - m - lda: :type: integer :intent: input - b: :type: real :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - d: :type: real :intent: input :dims: - ldd - m - ldd: :type: integer :intent: input - e: :type: real :intent: input :dims: - lde - n - lde: :type: integer :intent: input - f: :type: real :intent: input/output :dims: - ldf - n - ldf: :type: integer :intent: input - scale: :type: real :intent: output - dif: :type: real :intent: output - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "((ijob==1||ijob==2)&&lsame_(&trans,\"N\")) ? 2*m*n : 1" - iwork: :type: integer :intent: workspace :dims: - m+n+6 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE STGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STGSYL solves the generalized Sylvester equation:\n\ *\n\ * A * R - L * B = scale * C (1)\n\ * D * R - L * E = scale * F\n\ *\n\ * where R and L are unknown m-by-n matrices, (A, D), (B, E) and\n\ * (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n,\n\ * respectively, with real entries. (A, D) and (B, E) must be in\n\ * generalized (real) Schur canonical form, i.e. A, B are upper quasi\n\ * triangular and D, E are upper triangular.\n\ *\n\ * The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output\n\ * scaling factor chosen to avoid overflow.\n\ *\n\ * In matrix notation (1) is equivalent to solve Zx = scale b, where\n\ * Z is defined as\n\ *\n\ * Z = [ kron(In, A) -kron(B', Im) ] (2)\n\ * [ kron(In, D) -kron(E', Im) ].\n\ *\n\ * Here Ik is the identity matrix of size k and X' is the transpose of\n\ * X. kron(X, Y) is the Kronecker product between the matrices X and Y.\n\ *\n\ * If TRANS = 'T', STGSYL solves the transposed system Z'*y = scale*b,\n\ * which is equivalent to solve for R and L in\n\ *\n\ * A' * R + D' * L = scale * C (3)\n\ * R * B' + L * E' = scale * (-F)\n\ *\n\ * This case (TRANS = 'T') is used to compute an one-norm-based estimate\n\ * of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D)\n\ * and (B,E), using SLACON.\n\ *\n\ * If IJOB >= 1, STGSYL computes a Frobenius norm-based estimate\n\ * of Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the\n\ * reciprocal of the smallest singular value of Z. See [1-2] for more\n\ * information.\n\ *\n\ * This is a level 3 BLAS algorithm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N', solve the generalized Sylvester equation (1).\n\ * = 'T', solve the 'transposed' system (3).\n\ *\n\ * IJOB (input) INTEGER\n\ * Specifies what kind of functionality to be performed.\n\ * =0: solve (1) only.\n\ * =1: The functionality of 0 and 3.\n\ * =2: The functionality of 0 and 4.\n\ * =3: Only an estimate of Dif[(A,D), (B,E)] is computed.\n\ * (look ahead strategy IJOB = 1 is used).\n\ * =4: Only an estimate of Dif[(A,D), (B,E)] is computed.\n\ * ( SGECON on sub-systems is used ).\n\ * Not referenced if TRANS = 'T'.\n\ *\n\ * M (input) INTEGER\n\ * The order of the matrices A and D, and the row dimension of\n\ * the matrices C, F, R and L.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices B and E, and the column dimension\n\ * of the matrices C, F, R and L.\n\ *\n\ * A (input) REAL array, dimension (LDA, M)\n\ * The upper quasi triangular matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1, M).\n\ *\n\ * B (input) REAL array, dimension (LDB, N)\n\ * The upper quasi triangular matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1, N).\n\ *\n\ * C (input/output) REAL array, dimension (LDC, N)\n\ * On entry, C contains the right-hand-side of the first matrix\n\ * equation in (1) or (3).\n\ * On exit, if IJOB = 0, 1 or 2, C has been overwritten by\n\ * the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R,\n\ * the solution achieved during the computation of the\n\ * Dif-estimate.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1, M).\n\ *\n\ * D (input) REAL array, dimension (LDD, M)\n\ * The upper triangular matrix D.\n\ *\n\ * LDD (input) INTEGER\n\ * The leading dimension of the array D. LDD >= max(1, M).\n\ *\n\ * E (input) REAL array, dimension (LDE, N)\n\ * The upper triangular matrix E.\n\ *\n\ * LDE (input) INTEGER\n\ * The leading dimension of the array E. LDE >= max(1, N).\n\ *\n\ * F (input/output) REAL array, dimension (LDF, N)\n\ * On entry, F contains the right-hand-side of the second matrix\n\ * equation in (1) or (3).\n\ * On exit, if IJOB = 0, 1 or 2, F has been overwritten by\n\ * the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L,\n\ * the solution achieved during the computation of the\n\ * Dif-estimate.\n\ *\n\ * LDF (input) INTEGER\n\ * The leading dimension of the array F. LDF >= max(1, M).\n\ *\n\ * DIF (output) REAL\n\ * On exit DIF is the reciprocal of a lower bound of the\n\ * reciprocal of the Dif-function, i.e. DIF is an upper bound of\n\ * Dif[(A,D), (B,E)] = sigma_min(Z), where Z as in (2).\n\ * IF IJOB = 0 or TRANS = 'T', DIF is not touched.\n\ *\n\ * SCALE (output) REAL\n\ * On exit SCALE is the scaling factor in (1) or (3).\n\ * If 0 < SCALE < 1, C and F hold the solutions R and L, resp.,\n\ * to a slightly perturbed system but the input matrices A, B, D\n\ * and E have not been changed. If SCALE = 0, C and F hold the\n\ * solutions R and L, respectively, to the homogeneous system\n\ * with C = F = 0. Normally, SCALE = 1.\n\ *\n\ * WORK (workspace/output) REAL 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 > = 1.\n\ * If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N).\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\ * IWORK (workspace) INTEGER array, dimension (M+N+6)\n\ *\n\ * INFO (output) INTEGER\n\ * =0: successful exit\n\ * <0: If INFO = -i, the i-th argument had an illegal value.\n\ * >0: (A, D) and (B, E) have common or close eigenvalues.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n\ * for Solving the Generalized Sylvester Equation and Estimating the\n\ * Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n\ * Department of Computing Science, Umea University, S-901 87 Umea,\n\ * Sweden, December 1993, Revised April 1994, Also as LAPACK Working\n\ * Note 75. To appear in ACM Trans. on Math. Software, Vol 22,\n\ * No 1, 1996.\n\ *\n\ * [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester\n\ * Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal.\n\ * Appl., 15(4):1045-1060, 1994\n\ *\n\ * [3] B. Kagstrom and L. Westin, Generalized Schur Methods with\n\ * Condition Estimators for Solving the Generalized Sylvester\n\ * Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7,\n\ * July 1989, pp 745-751.\n\ *\n\ * =====================================================================\n\ * Replaced various illegal calls to SCOPY by calls to SLASET.\n\ * Sven Hammarling, 1/5/02.\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlansy0000644000175000017500000000615712502223526016541 0ustar uwabamiuwabami--- :name: zlansy :md5sum: 53d4b9c917535a23b36d076e4b5e3c08 :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " DOUBLE PRECISION FUNCTION ZLANSY( NORM, UPLO, N, A, LDA, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLANSY returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * complex symmetric matrix A.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * ZLANSY returns the value\n\ *\n\ * ZLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in ZLANSY as described\n\ * above.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is to be referenced.\n\ * = 'U': Upper triangular part of A is referenced\n\ * = 'L': Lower triangular part of A is referenced\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, ZLANSY is\n\ * set to zero.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The symmetric matrix A. If UPLO = 'U', the leading n by n\n\ * upper triangular part of A contains the upper triangular part\n\ * of the matrix A, and the strictly lower triangular part of A\n\ * is not referenced. If UPLO = 'L', the leading n by n lower\n\ * triangular part of A contains the lower triangular part of\n\ * the matrix A, and the strictly upper triangular part of A is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(N,1).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n\ * WORK is not referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlaesy0000644000175000017500000000504412502223526016522 0ustar uwabamiuwabami--- :name: zlaesy :md5sum: 642ca3d28da008080be23ca24f63fa2c :category: :subroutine :arguments: - a: :type: doublecomplex :intent: input - b: :type: doublecomplex :intent: input - c: :type: doublecomplex :intent: input - rt1: :type: doublecomplex :intent: output - rt2: :type: doublecomplex :intent: output - evscal: :type: doublecomplex :intent: output - cs1: :type: doublecomplex :intent: output - sn1: :type: doublecomplex :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZLAESY( A, B, C, RT1, RT2, EVSCAL, CS1, SN1 )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAESY computes the eigendecomposition of a 2-by-2 symmetric matrix\n\ * ( ( A, B );( B, C ) )\n\ * provided the norm of the matrix of eigenvectors is larger than\n\ * some threshold value.\n\ *\n\ * RT1 is the eigenvalue of larger absolute value, and RT2 of\n\ * smaller absolute value. If the eigenvectors are computed, then\n\ * on return ( CS1, SN1 ) is the unit eigenvector for RT1, hence\n\ *\n\ * [ CS1 SN1 ] . [ A B ] . [ CS1 -SN1 ] = [ RT1 0 ]\n\ * [ -SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * A (input) COMPLEX*16\n\ * The ( 1, 1 ) element of input matrix.\n\ *\n\ * B (input) COMPLEX*16\n\ * The ( 1, 2 ) element of input matrix. The ( 2, 1 ) element\n\ * is also given by B, since the 2-by-2 matrix is symmetric.\n\ *\n\ * C (input) COMPLEX*16\n\ * The ( 2, 2 ) element of input matrix.\n\ *\n\ * RT1 (output) COMPLEX*16\n\ * The eigenvalue of larger modulus.\n\ *\n\ * RT2 (output) COMPLEX*16\n\ * The eigenvalue of smaller modulus.\n\ *\n\ * EVSCAL (output) COMPLEX*16\n\ * The complex value by which the eigenvector matrix was scaled\n\ * to make it orthonormal. If EVSCAL is zero, the eigenvectors\n\ * were not computed. This means one of two things: the 2-by-2\n\ * matrix could not be diagonalized, or the norm of the matrix\n\ * of eigenvectors before scaling was larger than the threshold\n\ * value THRESH (set below).\n\ *\n\ * CS1 (output) COMPLEX*16\n\ * SN1 (output) COMPLEX*16\n\ * If EVSCAL .NE. 0, ( CS1, SN1 ) is the unit right eigenvector\n\ * for RT1.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ilaenv0000644000175000017500000001317712502223526016477 0ustar uwabamiuwabami--- :name: ilaenv :md5sum: a17ab3474e363bc9e09f7a174f8d4758 :category: :function :type: integer :arguments: - ispec: :type: integer :intent: input - name: :type: char :intent: input :dims: - "*" - opts: :type: char :intent: input :dims: - "*" - n1: :type: integer :intent: input - n2: :type: integer :intent: input - n3: :type: integer :intent: input - n4: :type: integer :intent: input :substitutions: {} :fortran_help: " INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ILAENV is called from the LAPACK routines to choose problem-dependent\n\ * parameters for the local environment. See ISPEC for a description of\n\ * the parameters.\n\ *\n\ * ILAENV returns an INTEGER\n\ * if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC\n\ * if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value.\n\ *\n\ * This version provides a set of parameters which should give good,\n\ * but not optimal, performance on many of the currently available\n\ * computers. Users are encouraged to modify this subroutine to set\n\ * the tuning parameters for their particular machine using the option\n\ * and problem size information in the arguments.\n\ *\n\ * This routine will not function correctly if it is converted to all\n\ * lower case. Converting it to all upper case is allowed.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ISPEC (input) INTEGER\n\ * Specifies the parameter to be returned as the value of\n\ * ILAENV.\n\ * = 1: the optimal blocksize; if this value is 1, an unblocked\n\ * algorithm will give the best performance.\n\ * = 2: the minimum block size for which the block routine\n\ * should be used; if the usable block size is less than\n\ * this value, an unblocked routine should be used.\n\ * = 3: the crossover point (in a block routine, for N less\n\ * than this value, an unblocked routine should be used)\n\ * = 4: the number of shifts, used in the nonsymmetric\n\ * eigenvalue routines (DEPRECATED)\n\ * = 5: the minimum column dimension for blocking to be used;\n\ * rectangular blocks must have dimension at least k by m,\n\ * where k is given by ILAENV(2,...) and m by ILAENV(5,...)\n\ * = 6: the crossover point for the SVD (when reducing an m by n\n\ * matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds\n\ * this value, a QR factorization is used first to reduce\n\ * the matrix to a triangular form.)\n\ * = 7: the number of processors\n\ * = 8: the crossover point for the multishift QR method\n\ * for nonsymmetric eigenvalue problems (DEPRECATED)\n\ * = 9: maximum size of the subproblems at the bottom of the\n\ * computation tree in the divide-and-conquer algorithm\n\ * (used by xGELSD and xGESDD)\n\ * =10: ieee NaN arithmetic can be trusted not to trap\n\ * =11: infinity arithmetic can be trusted not to trap\n\ * 12 <= ISPEC <= 16:\n\ * xHSEQR or one of its subroutines,\n\ * see IPARMQ for detailed explanation\n\ *\n\ * NAME (input) CHARACTER*(*)\n\ * The name of the calling subroutine, in either upper case or\n\ * lower case.\n\ *\n\ * OPTS (input) CHARACTER*(*)\n\ * The character options to the subroutine NAME, concatenated\n\ * into a single character string. For example, UPLO = 'U',\n\ * TRANS = 'T', and DIAG = 'N' for a triangular routine would\n\ * be specified as OPTS = 'UTN'.\n\ *\n\ * N1 (input) INTEGER\n\ * N2 (input) INTEGER\n\ * N3 (input) INTEGER\n\ * N4 (input) INTEGER\n\ * Problem dimensions for the subroutine NAME; these may not all\n\ * be required.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The following conventions have been used when calling ILAENV from the\n\ * LAPACK routines:\n\ * 1) OPTS is a concatenation of all of the character options to\n\ * subroutine NAME, in the same order that they appear in the\n\ * argument list for NAME, even if they are not used in determining\n\ * the value of the parameter specified by ISPEC.\n\ * 2) The problem dimensions N1, N2, N3, N4 are specified in the order\n\ * that they appear in the argument list for NAME. N1 is used\n\ * first, N2 second, and so on, and unused problem dimensions are\n\ * passed a value of -1.\n\ * 3) The parameter value returned by ILAENV is checked for validity in\n\ * the calling subroutine. For example, ILAENV is used to retrieve\n\ * the optimal blocksize for STRTRI as follows:\n\ *\n\ * NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )\n\ * IF( NB.LE.1 ) NB = MAX( 1, N )\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, IC, IZ, NB, NBMIN, NX\n LOGICAL CNAME, SNAME\n CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*6\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC CHAR, ICHAR, INT, MIN, REAL\n\ * ..\n\ * .. External Functions ..\n INTEGER IEEECK, IPARMQ\n EXTERNAL IEEECK, IPARMQ\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/strrfs0000644000175000017500000001146012502223526016535 0ustar uwabamiuwabami--- :name: strrfs :md5sum: 77120e9b758c0a89a337b22b4a383886 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE STRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STRRFS provides error bounds and backward error estimates for the\n\ * solution to a system of linear equations with a triangular\n\ * coefficient matrix.\n\ *\n\ * The solution matrix X must be computed by STRTRS or some other\n\ * means before entering this routine. STRRFS does not do iterative\n\ * refinement because doing so cannot improve the backward error.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose = Transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * The triangular matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of the array A contains the upper\n\ * triangular matrix, and the strictly lower triangular part of\n\ * A is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of the array A contains the lower triangular\n\ * matrix, and the strictly upper triangular part of A is not\n\ * referenced. If DIAG = 'U', the diagonal elements of A are\n\ * also not referenced and are assumed to be 1.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input) REAL array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input) REAL array, dimension (LDX,NRHS)\n\ * The solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) REAL array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgtsv0000644000175000017500000000562112502223526016362 0ustar uwabamiuwabami--- :name: sgtsv :md5sum: d0c8275ef5b870545d926bfab7aac31d :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: real :intent: input/output :dims: - n-1 - d: :type: real :intent: input/output :dims: - n - du: :type: real :intent: input/output :dims: - n-1 - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGTSV solves the equation\n\ *\n\ * A*X = B,\n\ *\n\ * where A is an n by n tridiagonal matrix, by Gaussian elimination with\n\ * partial pivoting.\n\ *\n\ * Note that the equation A'*X = B may be solved by interchanging the\n\ * order of the arguments DU and DL.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * DL (input/output) REAL array, dimension (N-1)\n\ * On entry, DL must contain the (n-1) sub-diagonal elements of\n\ * A.\n\ *\n\ * On exit, DL is overwritten by the (n-2) elements of the\n\ * second super-diagonal of the upper triangular matrix U from\n\ * the LU factorization of A, in DL(1), ..., DL(n-2).\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, D must contain the diagonal elements of A.\n\ *\n\ * On exit, D is overwritten by the n diagonal elements of U.\n\ *\n\ * DU (input/output) REAL array, dimension (N-1)\n\ * On entry, DU must contain the (n-1) super-diagonal elements\n\ * of A.\n\ *\n\ * On exit, DU is overwritten by the (n-1) elements of the first\n\ * super-diagonal of U.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the N by NRHS matrix of right hand side matrix B.\n\ * On exit, if INFO = 0, the N by NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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, U(i,i) is exactly zero, and the solution\n\ * has not been computed. The factorization has not been\n\ * completed unless i = N.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dtgex20000644000175000017500000001426112502223526016411 0ustar uwabamiuwabami--- :name: dtgex2 :md5sum: 3c9cc9551cb92a0e096ca7810e33e06d :category: :subroutine :arguments: - wantq: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - q: :type: doublereal :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - z: :type: doublereal :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - j1: :type: integer :intent: input - n1: :type: integer :intent: input - n2: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - lwork - lwork: :type: integer :intent: input :option: true :default: MAX(n*(n2+n1), (n2+n1)*(n2+n1)*2) - info: :type: integer :intent: output :substitutions: lwork: MAX(1,(MAX(n*(n2+n1),(n2+n1)*(n2+n1)*2))) :fortran_help: " SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, J1, N1, N2, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22)\n\ * of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair\n\ * (A, B) by an orthogonal equivalence transformation.\n\ *\n\ * (A, B) must be in generalized real Schur canonical form (as returned\n\ * by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2\n\ * diagonal blocks. B is upper triangular.\n\ *\n\ * Optionally, the matrices Q and Z of generalized Schur vectors are\n\ * updated.\n\ *\n\ * Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n\ * Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n\ *\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * WANTQ (input) LOGICAL\n\ * .TRUE. : update the left transformation matrix Q;\n\ * .FALSE.: do not update Q.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * .TRUE. : update the right transformation matrix Z;\n\ * .FALSE.: do not update Z.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimensions (LDA,N)\n\ * On entry, the matrix A in the pair (A, B).\n\ * On exit, the updated matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimensions (LDB,N)\n\ * On entry, the matrix B in the pair (A, B).\n\ * On exit, the updated matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n\ * On entry, if WANTQ = .TRUE., the orthogonal matrix Q.\n\ * On exit, the updated matrix Q.\n\ * Not referenced if WANTQ = .FALSE..\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= 1.\n\ * If WANTQ = .TRUE., LDQ >= N.\n\ *\n\ * Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n\ * On entry, if WANTZ =.TRUE., the orthogonal matrix Z.\n\ * On exit, the updated matrix Z.\n\ * Not referenced if WANTZ = .FALSE..\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1.\n\ * If WANTZ = .TRUE., LDZ >= N.\n\ *\n\ * J1 (input) INTEGER\n\ * The index to the first block (A11, B11). 1 <= J1 <= N.\n\ *\n\ * N1 (input) INTEGER\n\ * The order of the first block (A11, B11). N1 = 0, 1 or 2.\n\ *\n\ * N2 (input) INTEGER\n\ * The order of the second block (A22, B22). N2 = 0, 1 or 2.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)).\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK.\n\ * LWORK >= MAX( 1, N*(N2+N1), (N2+N1)*(N2+N1)*2 )\n\ *\n\ * INFO (output) INTEGER\n\ * =0: Successful exit\n\ * >0: If INFO = 1, the transformed matrix (A, B) would be\n\ * too far from generalized Schur form; the blocks are\n\ * not swapped and (A, B) and (Q, Z) are unchanged.\n\ * The problem of swapping is too ill-conditioned.\n\ * <0: If INFO = -16: LWORK is too small. Appropriate value\n\ * for LWORK is returned in WORK(1).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * In the current code both weak and strong stability tests are\n\ * performed. The user can omit the strong stability test by changing\n\ * the internal logical parameter WANDS to .FALSE.. See ref. [2] for\n\ * details.\n\ *\n\ * [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n\ * Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n\ * M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n\ * Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n\ *\n\ * [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n\ * Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n\ * Estimation: Theory, Algorithms and Software,\n\ * Report UMINF - 94.04, Department of Computing Science, Umea\n\ * University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working\n\ * Note 87. To appear in Numerical Algorithms, 1996.\n\ *\n\ * =====================================================================\n\ * Replaced various illegal calls to DCOPY by calls to DLASET, or by DO\n\ * loops. Sven Hammarling, 1/5/02.\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgegv0000644000175000017500000002572512502223526016317 0ustar uwabamiuwabami--- :name: dgegv :md5sum: 155f15d8861adb20fd687c0f414a941d :category: :subroutine :arguments: - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alphar: :type: doublereal :intent: output :dims: - n - alphai: :type: doublereal :intent: output :dims: - n - beta: :type: doublereal :intent: output :dims: - n - vl: :type: doublereal :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: doublereal :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 8*n - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " SUBROUTINE DGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This routine is deprecated and has been replaced by routine DGGEV.\n\ *\n\ * DGEGV computes the eigenvalues and, optionally, the left and/or right\n\ * eigenvectors of a real matrix pair (A,B).\n\ * Given two square matrices A and B,\n\ * the generalized nonsymmetric eigenvalue problem (GNEP) is to find the\n\ * eigenvalues lambda and corresponding (non-zero) eigenvectors x such\n\ * that\n\ *\n\ * A*x = lambda*B*x.\n\ *\n\ * An alternate form is to find the eigenvalues mu and corresponding\n\ * eigenvectors y such that\n\ *\n\ * mu*A*y = B*y.\n\ *\n\ * These two forms are equivalent with mu = 1/lambda and x = y if\n\ * neither lambda nor mu is zero. In order to deal with the case that\n\ * lambda or mu is zero or small, two values alpha and beta are returned\n\ * for each eigenvalue, such that lambda = alpha/beta and\n\ * mu = beta/alpha.\n\ *\n\ * The vectors x and y in the above equations are right eigenvectors of\n\ * the matrix pair (A,B). Vectors u and v satisfying\n\ *\n\ * u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B\n\ *\n\ * are left eigenvectors of (A,B).\n\ *\n\ * Note: this routine performs \"full balancing\" on A and B -- see\n\ * \"Further Details\", below.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVL (input) CHARACTER*1\n\ * = 'N': do not compute the left generalized eigenvectors;\n\ * = 'V': compute the left generalized eigenvectors (returned\n\ * in VL).\n\ *\n\ * JOBVR (input) CHARACTER*1\n\ * = 'N': do not compute the right generalized eigenvectors;\n\ * = 'V': compute the right generalized eigenvectors (returned\n\ * in VR).\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A, B, VL, and VR. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n\ * On entry, the matrix A.\n\ * If JOBVL = 'V' or JOBVR = 'V', then on exit A\n\ * contains the real Schur form of A from the generalized Schur\n\ * factorization of the pair (A,B) after balancing.\n\ * If no eigenvectors were computed, then only the diagonal\n\ * blocks from the Schur form will be correct. See DGGHRD and\n\ * DHGEQZ for details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of A. LDA >= max(1,N).\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n\ * On entry, the matrix B.\n\ * If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the\n\ * upper triangular matrix obtained from B in the generalized\n\ * Schur factorization of the pair (A,B) after balancing.\n\ * If no eigenvectors were computed, then only those elements of\n\ * B corresponding to the diagonal blocks from the Schur form of\n\ * A will be correct. See DGGHRD and DHGEQZ for details.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B. LDB >= max(1,N).\n\ *\n\ * ALPHAR (output) DOUBLE PRECISION array, dimension (N)\n\ * The real parts of each scalar alpha defining an eigenvalue of\n\ * GNEP.\n\ *\n\ * ALPHAI (output) DOUBLE PRECISION array, dimension (N)\n\ * The imaginary parts of each scalar alpha defining an\n\ * eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th\n\ * eigenvalue is real; if positive, then the j-th and\n\ * (j+1)-st eigenvalues are a complex conjugate pair, with\n\ * ALPHAI(j+1) = -ALPHAI(j).\n\ *\n\ * BETA (output) DOUBLE PRECISION array, dimension (N)\n\ * The scalars beta that define the eigenvalues of GNEP.\n\ * \n\ * Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and\n\ * beta = BETA(j) represent the j-th eigenvalue of the matrix\n\ * pair (A,B), in one of the forms lambda = alpha/beta or\n\ * mu = beta/alpha. Since either lambda or mu may overflow,\n\ * they should not, in general, be computed.\n\ *\n\ * VL (output) DOUBLE PRECISION array, dimension (LDVL,N)\n\ * If JOBVL = 'V', the left eigenvectors u(j) are stored\n\ * in the columns of VL, in the same order as their eigenvalues.\n\ * If the j-th eigenvalue is real, then u(j) = VL(:,j).\n\ * If the j-th and (j+1)-st eigenvalues form a complex conjugate\n\ * pair, then\n\ * u(j) = VL(:,j) + i*VL(:,j+1)\n\ * and\n\ * u(j+1) = VL(:,j) - i*VL(:,j+1).\n\ *\n\ * Each eigenvector is scaled so that its largest component has\n\ * abs(real part) + abs(imag. part) = 1, except for eigenvectors\n\ * corresponding to an eigenvalue with alpha = beta = 0, which\n\ * are set to zero.\n\ * Not referenced if JOBVL = 'N'.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the matrix VL. LDVL >= 1, and\n\ * if JOBVL = 'V', LDVL >= N.\n\ *\n\ * VR (output) DOUBLE PRECISION array, dimension (LDVR,N)\n\ * If JOBVR = 'V', the right eigenvectors x(j) are stored\n\ * in the columns of VR, in the same order as their eigenvalues.\n\ * If the j-th eigenvalue is real, then x(j) = VR(:,j).\n\ * If the j-th and (j+1)-st eigenvalues form a complex conjugate\n\ * pair, then\n\ * x(j) = VR(:,j) + i*VR(:,j+1)\n\ * and\n\ * x(j+1) = VR(:,j) - i*VR(:,j+1).\n\ *\n\ * Each eigenvector is scaled so that its largest component has\n\ * abs(real part) + abs(imag. part) = 1, except for eigenvalues\n\ * corresponding to an eigenvalue with alpha = beta = 0, which\n\ * are set to zero.\n\ * Not referenced if JOBVR = 'N'.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the matrix VR. LDVR >= 1, and\n\ * if JOBVR = 'V', LDVR >= 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. LWORK >= max(1,8*N).\n\ * For good performance, LWORK must generally be larger.\n\ * To compute the optimal value of LWORK, call ILAENV to get\n\ * blocksizes (for DGEQRF, DORMQR, and DORGQR.) Then compute:\n\ * NB -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR;\n\ * The optimal LWORK is:\n\ * 2*N + MAX( 6*N, N*(NB+1) ).\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\ * = 1,...,N:\n\ * The QZ iteration failed. No eigenvectors have been\n\ * calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)\n\ * should be correct for j=INFO+1,...,N.\n\ * > N: errors that usually indicate LAPACK problems:\n\ * =N+1: error return from DGGBAL\n\ * =N+2: error return from DGEQRF\n\ * =N+3: error return from DORMQR\n\ * =N+4: error return from DORGQR\n\ * =N+5: error return from DGGHRD\n\ * =N+6: error return from DHGEQZ (other than failed\n\ * iteration)\n\ * =N+7: error return from DTGEVC\n\ * =N+8: error return from DGGBAK (computing VL)\n\ * =N+9: error return from DGGBAK (computing VR)\n\ * =N+10: error return from DLASCL (various calls)\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Balancing\n\ * ---------\n\ *\n\ * This driver calls DGGBAL to both permute and scale rows and columns\n\ * of A and B. The permutations PL and PR are chosen so that PL*A*PR\n\ * and PL*B*R will be upper triangular except for the diagonal blocks\n\ * A(i:j,i:j) and B(i:j,i:j), with i and j as close together as\n\ * possible. The diagonal scaling matrices DL and DR are chosen so\n\ * that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to\n\ * one (except for the elements that start out zero.)\n\ *\n\ * After the eigenvalues and eigenvectors of the balanced matrices\n\ * have been computed, DGGBAK transforms the eigenvectors back to what\n\ * they would have been (in perfect arithmetic) if they had not been\n\ * balanced.\n\ *\n\ * Contents of A and B on Exit\n\ * -------- -- - --- - -- ----\n\ *\n\ * If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or\n\ * both), then on exit the arrays A and B will contain the real Schur\n\ * form[*] of the \"balanced\" versions of A and B. If no eigenvectors\n\ * are computed, then only the diagonal blocks will be correct.\n\ *\n\ * [*] See DHGEQZ, DGEGS, or read the book \"Matrix Computations\",\n\ * by Golub & van Loan, pub. by Johns Hopkins U. Press.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sggesx0000644000175000017500000003162712502223526016521 0ustar uwabamiuwabami--- :name: sggesx :md5sum: 3515fd1426593154ec1fad4573f2ba9c :category: :subroutine :arguments: - jobvsl: :type: char :intent: input - jobvsr: :type: char :intent: input - sort: :type: char :intent: input - selctg: :intent: external procedure :block_type: logical :block_arg_num: 3 :block_arg_type: real - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - sdim: :type: integer :intent: output - alphar: :type: real :intent: output :dims: - n - alphai: :type: real :intent: output :dims: - n - beta: :type: real :intent: output :dims: - n - vsl: :type: real :intent: output :dims: - ldvsl - n - ldvsl: :type: integer :intent: input - vsr: :type: real :intent: output :dims: - ldvsr - n - ldvsr: :type: integer :intent: input - rconde: :type: real :intent: output :dims: - "2" - rcondv: :type: real :intent: output :dims: - "2" - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n==0 ? 1 : (lsame_(&sense,\"E\")||lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? MAX(MAX(8*n,6*n+16),n*n/2) : MAX(8*n,6*n+16)" - iwork: :type: integer :intent: workspace :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "(lsame_(&sense,\"N\")||n==0) ? 1 : n+6" - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvsl: "lsame_(&jobvsl,\"V\") ? n : 1" ldvsr: "lsame_(&jobvsr,\"V\") ? n : 1" :fortran_help: " SUBROUTINE SGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, IWORK, LIWORK, BWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGGESX computes for a pair of N-by-N real nonsymmetric matrices\n\ * (A,B), the generalized eigenvalues, the real Schur form (S,T), and,\n\ * optionally, the left and/or right matrices of Schur vectors (VSL and\n\ * VSR). This gives the generalized Schur factorization\n\ *\n\ * (A,B) = ( (VSL) S (VSR)**T, (VSL) T (VSR)**T )\n\ *\n\ * Optionally, it also orders the eigenvalues so that a selected cluster\n\ * of eigenvalues appears in the leading diagonal blocks of the upper\n\ * quasi-triangular matrix S and the upper triangular matrix T; computes\n\ * a reciprocal condition number for the average of the selected\n\ * eigenvalues (RCONDE); and computes a reciprocal condition number for\n\ * the right and left deflating subspaces corresponding to the selected\n\ * eigenvalues (RCONDV). The leading columns of VSL and VSR then form\n\ * an orthonormal basis for the corresponding left and right eigenspaces\n\ * (deflating subspaces).\n\ *\n\ * A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n\ * or a ratio alpha/beta = w, such that A - w*B is singular. It is\n\ * usually represented as the pair (alpha,beta), as there is a\n\ * reasonable interpretation for beta=0 or for both being zero.\n\ *\n\ * A pair of matrices (S,T) is in generalized real Schur form if T is\n\ * upper triangular with non-negative diagonal and S is block upper\n\ * triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond\n\ * to real generalized eigenvalues, while 2-by-2 blocks of S will be\n\ * \"standardized\" by making the corresponding elements of T have the\n\ * form:\n\ * [ a 0 ]\n\ * [ 0 b ]\n\ *\n\ * and the pair of corresponding 2-by-2 blocks in S and T will have a\n\ * complex conjugate pair of generalized eigenvalues.\n\ *\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVSL (input) CHARACTER*1\n\ * = 'N': do not compute the left Schur vectors;\n\ * = 'V': compute the left Schur vectors.\n\ *\n\ * JOBVSR (input) CHARACTER*1\n\ * = 'N': do not compute the right Schur vectors;\n\ * = 'V': compute the right Schur vectors.\n\ *\n\ * SORT (input) CHARACTER*1\n\ * Specifies whether or not to order the eigenvalues on the\n\ * diagonal of the generalized Schur form.\n\ * = 'N': Eigenvalues are not ordered;\n\ * = 'S': Eigenvalues are ordered (see SELCTG).\n\ *\n\ * SELCTG (external procedure) LOGICAL FUNCTION of three REAL arguments\n\ * SELCTG must be declared EXTERNAL in the calling subroutine.\n\ * If SORT = 'N', SELCTG is not referenced.\n\ * If SORT = 'S', SELCTG is used to select eigenvalues to sort\n\ * to the top left of the Schur form.\n\ * An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if\n\ * SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either\n\ * one of a complex conjugate pair of eigenvalues is selected,\n\ * then both complex eigenvalues are selected.\n\ * Note that a selected complex eigenvalue may no longer satisfy\n\ * SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) = .TRUE. after ordering,\n\ * since ordering may change the value of complex eigenvalues\n\ * (especially if the eigenvalue is ill-conditioned), in this\n\ * case INFO is set to N+3.\n\ *\n\ * SENSE (input) CHARACTER*1\n\ * Determines which reciprocal condition numbers are computed.\n\ * = 'N' : None are computed;\n\ * = 'E' : Computed for average of selected eigenvalues only;\n\ * = 'V' : Computed for selected deflating subspaces only;\n\ * = 'B' : Computed for both.\n\ * If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A, B, VSL, and VSR. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA, N)\n\ * On entry, the first of the pair of matrices.\n\ * On exit, A has been overwritten by its generalized Schur\n\ * form S.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of A. LDA >= max(1,N).\n\ *\n\ * B (input/output) REAL array, dimension (LDB, N)\n\ * On entry, the second of the pair of matrices.\n\ * On exit, B has been overwritten by its generalized Schur\n\ * form T.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B. LDB >= max(1,N).\n\ *\n\ * SDIM (output) INTEGER\n\ * If SORT = 'N', SDIM = 0.\n\ * If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n\ * for which SELCTG is true. (Complex conjugate pairs for which\n\ * SELCTG is true for either eigenvalue count as 2.)\n\ *\n\ * ALPHAR (output) REAL array, dimension (N)\n\ * ALPHAI (output) REAL array, dimension (N)\n\ * BETA (output) REAL array, dimension (N)\n\ * On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n\ * be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i\n\ * and BETA(j),j=1,...,N are the diagonals of the complex Schur\n\ * form (S,T) that would result if the 2-by-2 diagonal blocks of\n\ * the real Schur form of (A,B) were further reduced to\n\ * triangular form using 2-by-2 complex unitary transformations.\n\ * If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n\ * positive, then the j-th and (j+1)-st eigenvalues are a\n\ * complex conjugate pair, with ALPHAI(j+1) negative.\n\ *\n\ * Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n\ * may easily over- or underflow, and BETA(j) may even be zero.\n\ * Thus, the user should avoid naively computing the ratio.\n\ * However, ALPHAR and ALPHAI will be always less than and\n\ * usually comparable with norm(A) in magnitude, and BETA always\n\ * less than and usually comparable with norm(B).\n\ *\n\ * VSL (output) REAL array, dimension (LDVSL,N)\n\ * If JOBVSL = 'V', VSL will contain the left Schur vectors.\n\ * Not referenced if JOBVSL = 'N'.\n\ *\n\ * LDVSL (input) INTEGER\n\ * The leading dimension of the matrix VSL. LDVSL >=1, and\n\ * if JOBVSL = 'V', LDVSL >= N.\n\ *\n\ * VSR (output) REAL array, dimension (LDVSR,N)\n\ * If JOBVSR = 'V', VSR will contain the right Schur vectors.\n\ * Not referenced if JOBVSR = 'N'.\n\ *\n\ * LDVSR (input) INTEGER\n\ * The leading dimension of the matrix VSR. LDVSR >= 1, and\n\ * if JOBVSR = 'V', LDVSR >= N.\n\ *\n\ * RCONDE (output) REAL array, dimension ( 2 )\n\ * If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the\n\ * reciprocal condition numbers for the average of the selected\n\ * eigenvalues.\n\ * Not referenced if SENSE = 'N' or 'V'.\n\ *\n\ * RCONDV (output) REAL array, dimension ( 2 )\n\ * If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the\n\ * reciprocal condition numbers for the selected deflating\n\ * subspaces.\n\ * Not referenced if SENSE = 'N' or 'E'.\n\ *\n\ * WORK (workspace/output) REAL 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\ * If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B',\n\ * LWORK >= max( 8*N, 6*N+16, 2*SDIM*(N-SDIM) ), else\n\ * LWORK >= max( 8*N, 6*N+16 ).\n\ * Note that 2*SDIM*(N-SDIM) <= N*N/2.\n\ * Note also that an error is only returned if\n\ * LWORK < max( 8*N, 6*N+16), but if SENSE = 'E' or 'V' or 'B'\n\ * this may not be large enough.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the bound on the optimal size of the WORK\n\ * array and the minimum size of the IWORK array, returns these\n\ * values as the first entries of the WORK and IWORK arrays, and\n\ * no error message related to LWORK or LIWORK is issued by\n\ * XERBLA.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK.\n\ * If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise\n\ * LIWORK >= N+6.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the bound on the optimal size of the\n\ * WORK array and the minimum size of the IWORK array, returns\n\ * these values as the first entries of the WORK and IWORK\n\ * arrays, and no error message related to LWORK or LIWORK is\n\ * issued by XERBLA.\n\ *\n\ * BWORK (workspace) LOGICAL array, dimension (N)\n\ * Not referenced if SORT = 'N'.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * = 1,...,N:\n\ * The QZ iteration failed. (A,B) are not in Schur\n\ * form, but ALPHAR(j), ALPHAI(j), and BETA(j) should\n\ * be correct for j=INFO+1,...,N.\n\ * > N: =N+1: other than QZ iteration failed in SHGEQZ\n\ * =N+2: after reordering, roundoff changed values of\n\ * some complex eigenvalues so that leading\n\ * eigenvalues in the Generalized Schur form no\n\ * longer satisfy SELCTG=.TRUE. This could also\n\ * be caused due to scaling.\n\ * =N+3: reordering failed in STGSEN.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * An approximate (asymptotic) bound on the average absolute error of\n\ * the selected eigenvalues is\n\ *\n\ * EPS * norm((A, B)) / RCONDE( 1 ).\n\ *\n\ * An approximate (asymptotic) bound on the maximum angular error in\n\ * the computed deflating subspaces is\n\ *\n\ * EPS * norm((A, B)) / RCONDV( 2 ).\n\ *\n\ * See LAPACK User's Guide, section 4.11 for more information.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cpttrs0000644000175000017500000000632012502223525016527 0ustar uwabamiuwabami--- :name: cpttrs :md5sum: 13a14e1496854b5687986f2a43e1fdbe :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: complex :intent: input :dims: - n-1 - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPTTRS( UPLO, N, NRHS, D, E, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPTTRS solves a tridiagonal system of the form\n\ * A * X = B\n\ * using the factorization A = U'*D*U or A = L*D*L' computed by CPTTRF.\n\ * D is a diagonal matrix specified in the vector D, U (or L) is a unit\n\ * bidiagonal matrix whose superdiagonal (subdiagonal) is specified in\n\ * the vector E, and X and B are N by NRHS matrices.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies the form of the factorization and whether the\n\ * vector E is the superdiagonal of the upper bidiagonal factor\n\ * U or the subdiagonal of the lower bidiagonal factor L.\n\ * = 'U': A = U'*D*U, E is the superdiagonal of U\n\ * = 'L': A = L*D*L', E is the subdiagonal of L\n\ *\n\ * N (input) INTEGER\n\ * The order of the tridiagonal matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The n diagonal elements of the diagonal matrix D from the\n\ * factorization A = U'*D*U or A = L*D*L'.\n\ *\n\ * E (input) COMPLEX array, dimension (N-1)\n\ * If UPLO = 'U', the (n-1) superdiagonal elements of the unit\n\ * bidiagonal factor U from the factorization A = U'*D*U.\n\ * If UPLO = 'L', the (n-1) subdiagonal elements of the unit\n\ * bidiagonal factor L from the factorization A = L*D*L'.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the right hand side vectors B for the system of\n\ * linear equations.\n\ * On exit, the solution vectors, X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL UPPER\n INTEGER IUPLO, J, JB, NB\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CPTTS2, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlabrd0000644000175000017500000001467512502223526016455 0ustar uwabamiuwabami--- :name: dlabrd :md5sum: cb76485d4ef4288d000a950edfd4b95f :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - MAX(1,nb) - e: :type: doublereal :intent: output :dims: - MAX(1,nb) - tauq: :type: doublereal :intent: output :dims: - MAX(1,nb) - taup: :type: doublereal :intent: output :dims: - MAX(1,nb) - x: :type: doublereal :intent: output :dims: - ldx - MAX(1,nb) - ldx: :type: integer :intent: input - y: :type: doublereal :intent: output :dims: - ldy - MAX(1,nb) - ldy: :type: integer :intent: input :substitutions: ldx: m ldy: n :fortran_help: " SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, LDY )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLABRD reduces the first NB rows and columns of a real general\n\ * m by n matrix A to upper or lower bidiagonal form by an orthogonal\n\ * transformation Q' * A * P, and returns the matrices X and Y which\n\ * are needed to apply the transformation to the unreduced part of A.\n\ *\n\ * If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower\n\ * bidiagonal form.\n\ *\n\ * This is an auxiliary routine called by DGEBRD\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows in the matrix A.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns in the matrix A.\n\ *\n\ * NB (input) INTEGER\n\ * The number of leading rows and columns of A to be reduced.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the m by n general matrix to be reduced.\n\ * On exit, the first NB rows and columns of the matrix are\n\ * overwritten; the rest of the array is unchanged.\n\ * If m >= n, elements on and below the diagonal in the first NB\n\ * columns, with the array TAUQ, represent the orthogonal\n\ * matrix Q as a product of elementary reflectors; and\n\ * elements above the diagonal in the first NB rows, with the\n\ * array TAUP, represent the orthogonal matrix P as a product\n\ * of elementary reflectors.\n\ * If m < n, elements below the diagonal in the first NB\n\ * columns, with the array TAUQ, represent the orthogonal\n\ * matrix Q as a product of elementary reflectors, and\n\ * elements on and above the diagonal in the first NB rows,\n\ * with the array TAUP, represent the orthogonal matrix P as\n\ * a product of elementary reflectors.\n\ * See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * D (output) DOUBLE PRECISION array, dimension (NB)\n\ * The diagonal elements of the first NB rows and columns of\n\ * the reduced matrix. D(i) = A(i,i).\n\ *\n\ * E (output) DOUBLE PRECISION array, dimension (NB)\n\ * The off-diagonal elements of the first NB rows and columns of\n\ * the reduced matrix.\n\ *\n\ * TAUQ (output) DOUBLE PRECISION array dimension (NB)\n\ * The scalar factors of the elementary reflectors which\n\ * represent the orthogonal matrix Q. See Further Details.\n\ *\n\ * TAUP (output) DOUBLE PRECISION array, dimension (NB)\n\ * The scalar factors of the elementary reflectors which\n\ * represent the orthogonal matrix P. See Further Details.\n\ *\n\ * X (output) DOUBLE PRECISION array, dimension (LDX,NB)\n\ * The m-by-nb matrix X required to update the unreduced part\n\ * of A.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= M.\n\ *\n\ * Y (output) DOUBLE PRECISION array, dimension (LDY,NB)\n\ * The n-by-nb matrix Y required to update the unreduced part\n\ * of A.\n\ *\n\ * LDY (input) INTEGER\n\ * The leading dimension of the array Y. LDY >= N.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The matrices Q and P are represented as products of elementary\n\ * reflectors:\n\ *\n\ * Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb)\n\ *\n\ * Each H(i) and G(i) has the form:\n\ *\n\ * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n\ *\n\ * where tauq and taup are real scalars, and v and u are real vectors.\n\ *\n\ * If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in\n\ * A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in\n\ * A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n\ *\n\ * If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in\n\ * A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in\n\ * A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n\ *\n\ * The elements of the vectors v and u together form the m-by-nb matrix\n\ * V and the nb-by-n matrix U' which are needed, with X and Y, to apply\n\ * the transformation to the unreduced part of the matrix, using a block\n\ * update of the form: A := A - V*Y' - X*U'.\n\ *\n\ * The contents of A on exit are illustrated by the following examples\n\ * with nb = 2:\n\ *\n\ * m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n\ *\n\ * ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 )\n\ * ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 )\n\ * ( v1 v2 a a a ) ( v1 1 a a a a )\n\ * ( v1 v2 a a a ) ( v1 v2 a a a a )\n\ * ( v1 v2 a a a ) ( v1 v2 a a a a )\n\ * ( v1 v2 a a a )\n\ *\n\ * where a denotes an element of the original matrix which is unchanged,\n\ * vi denotes an element of the vector defining H(i), and ui an element\n\ * of the vector defining G(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctgex20000644000175000017500000001164412502223525016411 0ustar uwabamiuwabami--- :name: ctgex2 :md5sum: 291e324cd2dab391083a4d6d15ee8c8d :category: :subroutine :arguments: - wantq: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - q: :type: complex :intent: input/output :dims: - "wantq ? ldq : 0" - "wantq ? n : 0" - ldq: :type: integer :intent: input - z: :type: complex :intent: input/output :dims: - "wantq ? ldz : 0" - "wantq ? n : 0" - ldz: :type: integer :intent: input - j1: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, J1, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTGEX2 swaps adjacent diagonal 1 by 1 blocks (A11,B11) and (A22,B22)\n\ * in an upper triangular matrix pair (A, B) by an unitary equivalence\n\ * transformation.\n\ *\n\ * (A, B) must be in generalized Schur canonical form, that is, A and\n\ * B are both upper triangular.\n\ *\n\ * Optionally, the matrices Q and Z of generalized Schur vectors are\n\ * updated.\n\ *\n\ * Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n\ * Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n\ *\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * WANTQ (input) LOGICAL\n\ * .TRUE. : update the left transformation matrix Q;\n\ * .FALSE.: do not update Q.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * .TRUE. : update the right transformation matrix Z;\n\ * .FALSE.: do not update Z.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) COMPLEX arrays, dimensions (LDA,N)\n\ * On entry, the matrix A in the pair (A, B).\n\ * On exit, the updated matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX arrays, dimensions (LDB,N)\n\ * On entry, the matrix B in the pair (A, B).\n\ * On exit, the updated matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * Q (input/output) COMPLEX array, dimension (LDZ,N)\n\ * If WANTQ = .TRUE, on entry, the unitary matrix Q. On exit,\n\ * the updated matrix Q.\n\ * Not referenced if WANTQ = .FALSE..\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= 1;\n\ * If WANTQ = .TRUE., LDQ >= N.\n\ *\n\ * Z (input/output) COMPLEX array, dimension (LDZ,N)\n\ * If WANTZ = .TRUE, on entry, the unitary matrix Z. On exit,\n\ * the updated matrix Z.\n\ * Not referenced if WANTZ = .FALSE..\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1;\n\ * If WANTZ = .TRUE., LDZ >= N.\n\ *\n\ * J1 (input) INTEGER\n\ * The index to the first block (A11, B11).\n\ *\n\ * INFO (output) INTEGER\n\ * =0: Successful exit.\n\ * =1: The transformed matrix pair (A, B) would be too far\n\ * from generalized Schur form; the problem is ill-\n\ * conditioned.\n\ *\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * In the current code both weak and strong stability tests are\n\ * performed. The user can omit the strong stability test by changing\n\ * the internal logical parameter WANDS to .FALSE.. See ref. [2] for\n\ * details.\n\ *\n\ * [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n\ * Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n\ * M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n\ * Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n\ *\n\ * [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n\ * Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n\ * Estimation: Theory, Algorithms and Software, Report UMINF-94.04,\n\ * Department of Computing Science, Umea University, S-901 87 Umea,\n\ * Sweden, 1994. Also as LAPACK Working Note 87. To appear in\n\ * Numerical Algorithms, 1996.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlansb0000644000175000017500000000631012502223526016453 0ustar uwabamiuwabami--- :name: dlansb :md5sum: 7d865bf099b44083eb35658d545bd4cf :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " DOUBLE PRECISION FUNCTION DLANSB( NORM, UPLO, N, K, AB, LDAB, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLANSB returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of an\n\ * n by n symmetric band matrix A, with k super-diagonals.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * DLANSB returns the value\n\ *\n\ * DLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in DLANSB as described\n\ * above.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * band matrix A is supplied.\n\ * = 'U': Upper triangular part is supplied\n\ * = 'L': Lower triangular part is supplied\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, DLANSB is\n\ * set to zero.\n\ *\n\ * K (input) INTEGER\n\ * The number of super-diagonals or sub-diagonals of the\n\ * band matrix A. K >= 0.\n\ *\n\ * AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * The upper or lower triangle of the symmetric band matrix A,\n\ * stored in the first K+1 rows of AB. The j-th column of A is\n\ * stored in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= K+1.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n\ * WORK is not referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlatbs0000644000175000017500000001701712502223526016467 0ustar uwabamiuwabami--- :name: dlatbs :md5sum: 9350a6e18496c8737cb00c53bba4cc08 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - normin: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - n - scale: :type: doublereal :intent: output - cnorm: :type: doublereal :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, SCALE, CNORM, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLATBS solves one of the triangular systems\n\ *\n\ * A *x = s*b or A'*x = s*b\n\ *\n\ * with scaling to prevent overflow, where A is an upper or lower\n\ * triangular band matrix. Here A' denotes the transpose of A, x and b\n\ * are n-element vectors, and s is a scaling factor, usually less than\n\ * or equal to 1, chosen so that the components of x will be less than\n\ * the overflow threshold. If the unscaled problem will not cause\n\ * overflow, the Level 2 BLAS routine DTBSV is called. If the matrix A\n\ * is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n\ * non-trivial solution to A*x = 0 is returned.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the matrix A is upper or lower triangular.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the operation applied to A.\n\ * = 'N': Solve A * x = s*b (No transpose)\n\ * = 'T': Solve A'* x = s*b (Transpose)\n\ * = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * Specifies whether or not the matrix A is unit triangular.\n\ * = 'N': Non-unit triangular\n\ * = 'U': Unit triangular\n\ *\n\ * NORMIN (input) CHARACTER*1\n\ * Specifies whether CNORM has been set or not.\n\ * = 'Y': CNORM contains the column norms on entry\n\ * = 'N': CNORM is not set on entry. On exit, the norms will\n\ * be computed and stored in CNORM.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of subdiagonals or superdiagonals in the\n\ * triangular matrix A. KD >= 0.\n\ *\n\ * AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * The upper or lower triangular band matrix A, stored in the\n\ * first KD+1 rows of the array. The j-th column of A is stored\n\ * in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * X (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the right hand side b of the triangular system.\n\ * On exit, X is overwritten by the solution vector x.\n\ *\n\ * SCALE (output) DOUBLE PRECISION\n\ * The scaling factor s for the triangular system\n\ * A * x = s*b or A'* x = s*b.\n\ * If SCALE = 0, the matrix A is singular or badly scaled, and\n\ * the vector x is an exact or approximate solution to A*x = 0.\n\ *\n\ * CNORM (input or output) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n\ * contains the norm of the off-diagonal part of the j-th column\n\ * of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n\ * to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n\ * must be greater than or equal to the 1-norm.\n\ *\n\ * If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n\ * returns the 1-norm of the offdiagonal part of the j-th column\n\ * of A.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ *\n\n\ * Further Details\n\ * ======= =======\n\ *\n\ * A rough bound on x is computed; if that is less than overflow, DTBSV\n\ * is called, otherwise, specific code is used which checks for possible\n\ * overflow or divide-by-zero at every operation.\n\ *\n\ * A columnwise scheme is used for solving A*x = b. The basic algorithm\n\ * if A is lower triangular is\n\ *\n\ * x[1:n] := b[1:n]\n\ * for j = 1, ..., n\n\ * x(j) := x(j) / A(j,j)\n\ * x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n\ * end\n\ *\n\ * Define bounds on the components of x after j iterations of the loop:\n\ * M(j) = bound on x[1:j]\n\ * G(j) = bound on x[j+1:n]\n\ * Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n\ *\n\ * Then for iteration j+1 we have\n\ * M(j+1) <= G(j) / | A(j+1,j+1) |\n\ * G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n\ * <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n\ *\n\ * where CNORM(j+1) is greater than or equal to the infinity-norm of\n\ * column j+1 of A, not counting the diagonal. Hence\n\ *\n\ * G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n\ * 1<=i<=j\n\ * and\n\ *\n\ * |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n\ * 1<=i< j\n\ *\n\ * Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTBSV if the\n\ * reciprocal of the largest M(j), j=1,..,n, is larger than\n\ * max(underflow, 1/overflow).\n\ *\n\ * The bound on x(j) is also used to determine when a step in the\n\ * columnwise method can be performed without fear of overflow. If\n\ * the computed bound is greater than a large constant, x is scaled to\n\ * prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n\ * 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n\ *\n\ * Similarly, a row-wise scheme is used to solve A'*x = b. The basic\n\ * algorithm for A upper triangular is\n\ *\n\ * for j = 1, ..., n\n\ * x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n\ * end\n\ *\n\ * We simultaneously compute two bounds\n\ * G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n\ * M(j) = bound on x(i), 1<=i<=j\n\ *\n\ * The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n\ * add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n\ * Then the bound on x(j) is\n\ *\n\ * M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n\ *\n\ * <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n\ * 1<=i<=j\n\ *\n\ * and we can safely call DTBSV if 1/M(n) and 1/G(n) are both greater\n\ * than max(underflow, 1/overflow).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgerfsx0000644000175000017500000004002212502223525016646 0ustar uwabamiuwabami--- :name: cgerfsx :md5sum: cec9f6b6b9086e460046d7894e0616dd :category: :subroutine :arguments: - trans: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - r: :type: real :intent: input :dims: - n - c: :type: real :intent: input :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " SUBROUTINE CGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGERFSX improves the computed solution to a system of linear\n\ * equations and provides error bounds and backward error estimates\n\ * for the solution. In addition to normwise error bound, the code\n\ * provides maximum componentwise error bound if possible. See\n\ * comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n\ * error bounds.\n\ *\n\ * The original system of linear equations may have been equilibrated\n\ * before calling this routine, as described by arguments EQUED, R\n\ * and C below. In this case, the solution and error bounds returned\n\ * are for the original unequilibrated system.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose = Transpose)\n\ *\n\ * EQUED (input) CHARACTER*1\n\ * Specifies the form of equilibration that was done to A\n\ * before calling this routine. This is needed to compute\n\ * the solution and error bounds correctly.\n\ * = 'N': No equilibration\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ * The right hand side B has been changed accordingly.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The original N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX array, dimension (LDAF,N)\n\ * The factors L and U from the factorization A = P*L*U\n\ * as computed by CGETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from CGETRF; for 1<=i<=N, row i of the\n\ * matrix was interchanged with row IPIV(i).\n\ *\n\ * R (input) REAL array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'R' or 'B', A is\n\ * multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n\ * is not accessed. \n\ * If R is accessed, each element of R should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * C (input) REAL array, dimension (N)\n\ * The column scale factors for A. If EQUED = 'C' or 'B', A is\n\ * multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n\ * is not accessed. \n\ * If C is accessed, each element of C should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) COMPLEX array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by CGETRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * Componentwise relative backward error. This is the\n\ * componentwise relative backward error of each solution vector X(j)\n\ * (i.e., the smallest relative change in any element of A or B that\n\ * makes X(j) an exact solution).\n\ *\n\ * N_ERR_BNDS (input) INTEGER\n\ * Number of error bounds to return for each right hand side\n\ * and each type (normwise or componentwise). See ERR_BNDS_NORM and\n\ * ERR_BNDS_COMP below.\n\ *\n\ * ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * NPARAMS (input) INTEGER\n\ * Specifies the number of parameters set in PARAMS. If .LE. 0, the\n\ * PARAMS array is never referenced and default values are used.\n\ *\n\ * PARAMS (input / output) REAL array, dimension NPARAMS\n\ * Specifies algorithm parameters. If an entry is .LT. 0.0, then\n\ * that entry will be filled with default value used for that\n\ * parameter. Only positions up to NPARAMS are accessed; defaults\n\ * are used for higher-numbered parameters.\n\ *\n\ * PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n\ * refinement or not.\n\ * Default: 1.0\n\ * = 0.0 : No refinement is performed, and no error bounds are\n\ * computed.\n\ * = 1.0 : Use the double-precision refinement algorithm,\n\ * possibly with doubled-single computations if the\n\ * compilation environment does not support DOUBLE\n\ * PRECISION.\n\ * (other values are reserved for future use)\n\ *\n\ * PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n\ * computations allowed for refinement.\n\ * Default: 10\n\ * Aggressive: Set to 100 to permit convergence using approximate\n\ * factorizations or factorizations other than LU. If\n\ * the factorization uses a technique other than\n\ * Gaussian elimination, the guarantees in\n\ * err_bnds_norm and err_bnds_comp may no longer be\n\ * trustworthy.\n\ *\n\ * PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n\ * will attempt to find a solution with small componentwise\n\ * relative error in the double-precision algorithm. Positive\n\ * is true, 0.0 is false.\n\ * Default: 1.0 (attempt componentwise convergence)\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (2*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit. The solution to every right-hand side is\n\ * guaranteed.\n\ * < 0: If INFO = -i, the i-th argument had an illegal value\n\ * > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgtcon0000644000175000017500000000650712502223526016524 0ustar uwabamiuwabami--- :name: zgtcon :md5sum: 27adfc903351ec100318405f24932950 :category: :subroutine :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - dl: :type: doublecomplex :intent: input :dims: - n-1 - d: :type: doublecomplex :intent: input :dims: - n - du: :type: doublecomplex :intent: input :dims: - n-1 - du2: :type: doublecomplex :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGTCON estimates the reciprocal of the condition number of a complex\n\ * tridiagonal matrix A using the LU factorization as computed by\n\ * ZGTTRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies whether the 1-norm condition number or the\n\ * infinity-norm condition number is required:\n\ * = '1' or 'O': 1-norm;\n\ * = 'I': Infinity-norm.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * DL (input) COMPLEX*16 array, dimension (N-1)\n\ * The (n-1) multipliers that define the matrix L from the\n\ * LU factorization of A as computed by ZGTTRF.\n\ *\n\ * D (input) COMPLEX*16 array, dimension (N)\n\ * The n diagonal elements of the upper triangular matrix U from\n\ * the LU factorization of A.\n\ *\n\ * DU (input) COMPLEX*16 array, dimension (N-1)\n\ * The (n-1) elements of the first superdiagonal of U.\n\ *\n\ * DU2 (input) COMPLEX*16 array, dimension (N-2)\n\ * The (n-2) elements of the second superdiagonal of U.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices; for 1 <= i <= n, row i of the matrix was\n\ * interchanged with row IPIV(i). IPIV(i) will always be either\n\ * i or i+1; IPIV(i) = i indicates a row interchange was not\n\ * required.\n\ *\n\ * ANORM (input) DOUBLE PRECISION\n\ * If NORM = '1' or 'O', the 1-norm of the original matrix A.\n\ * If NORM = 'I', the infinity-norm of the original matrix A.\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n\ * estimate of the 1-norm of inv(A) computed in this routine.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cla_syrpvgrw0000644000175000017500000000626212502223525017737 0ustar uwabamiuwabami--- :name: cla_syrpvgrw :md5sum: e96ba2f50c224c0fa1b51d9376552070 :category: :function :type: real :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - info: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: complex :intent: input :dims: - 2*n :substitutions: {} :fortran_help: " REAL FUNCTION CLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, WORK )\n\n\ * Purpose\n\ * =======\n\ * \n\ * CLA_SYRPVGRW computes the reciprocal pivot growth factor\n\ * norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n\ * much less than 1, the stability of the LU factorization of the\n\ * (equilibrated) matrix A could be poor. This also means that the\n\ * solution X, estimated condition numbers, and error bounds could be\n\ * unreliable.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * INFO (input) INTEGER\n\ * The value of INFO returned from CSYTRF, .i.e., the pivot in\n\ * column INFO is exactly 0.\n\ *\n\ * NCOLS (input) INTEGER\n\ * The number of columns of the matrix A. NCOLS >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX array, dimension (LDAF,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by CSYTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by CSYTRF.\n\ *\n\ * WORK (input) COMPLEX array, dimension (2*N)\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER NCOLS, I, J, K, KP\n REAL AMAX, UMAX, RPVGRW, TMP\n LOGICAL UPPER\n COMPLEX ZDUM\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, REAL, AIMAG, MAX, MIN\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL LSAME, CLASET\n LOGICAL LSAME\n\ * ..\n\ * .. Statement Functions ..\n REAL CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL ( ZDUM ) ) + ABS( AIMAG ( ZDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zsysvx0000644000175000017500000002356612502223526016612 0ustar uwabamiuwabami--- :name: zsysvx :md5sum: 656a5f89da3c81bca3d7d209e7e5939a :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 3*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE ZSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSYSVX uses the diagonal pivoting factorization to compute the\n\ * solution to a complex system of linear equations A * X = B,\n\ * where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n\ * matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'N', the diagonal pivoting method is used to factor A.\n\ * The form of the factorization is\n\ * A = U * D * U**T, if UPLO = 'U', or\n\ * A = L * D * L**T, if UPLO = 'L',\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, and D is symmetric and block diagonal with\n\ * 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\ * 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n\ * returns with INFO = i. Otherwise, the factored form of A is used\n\ * to estimate the condition number of the matrix A. If the\n\ * reciprocal of the condition number is less than machine precision,\n\ * INFO = N+1 is returned as a warning, but the routine still goes on\n\ * to solve for X and compute error bounds as described below.\n\ *\n\ * 3. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 4. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of A has been\n\ * supplied on entry.\n\ * = 'F': On entry, AF and IPIV contain the factored form\n\ * of A. A, AF and IPIV will not be modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular part\n\ * of the matrix A, and the strictly lower triangular part of A\n\ * is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of A contains the lower triangular part of\n\ * the matrix A, and the strictly upper triangular part of A is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input or output) COMPLEX*16 array, dimension (LDAF,N)\n\ * If FACT = 'F', then AF is an input argument and on entry\n\ * contains the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L from the factorization\n\ * A = U*D*U**T or A = L*D*L**T as computed by ZSYTRF.\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L from the factorization\n\ * A = U*D*U**T or A = L*D*L**T.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains details of the interchanges and the block structure\n\ * of D, as determined by ZSYTRF.\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains details of the interchanges and the block structure\n\ * of D, as determined by ZSYTRF.\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The N-by-NRHS right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A. If RCOND is less than the machine precision (in\n\ * particular, if RCOND = 0), the matrix is singular to working\n\ * precision. This condition is indicated by a return code of\n\ * INFO > 0.\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of WORK. LWORK >= max(1,2*N), and for best\n\ * performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where\n\ * NB is the optimal blocksize for ZSYTRF.\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\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\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, and i is\n\ * <= N: D(i,i) is exactly zero. The factorization\n\ * has been completed but the factor D is exactly\n\ * singular, so the solution and error bounds could\n\ * not be computed. RCOND = 0 is returned.\n\ * = N+1: D is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zsptrf0000644000175000017500000001157012502223526016544 0ustar uwabamiuwabami--- :name: zsptrf :md5sum: ccd21e8c310e6967f17c079115edb9d9 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - ldap - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE ZSPTRF( UPLO, N, AP, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSPTRF computes the factorization of a complex symmetric matrix A\n\ * stored in packed format using the Bunch-Kaufman diagonal pivoting\n\ * method:\n\ *\n\ * A = U*D*U**T or A = L*D*L**T\n\ *\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, and D is symmetric and block diagonal with\n\ * 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L, stored as a packed triangular\n\ * matrix overwriting A (see below for further details).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D.\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\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, D(i,i) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular, and division by zero will occur if it\n\ * is used to solve a system of equations.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * 5-96 - Based on modifications by J. Lewis, Boeing Computer Services\n\ * Company\n\ *\n\ * If UPLO = 'U', then A = U*D*U', where\n\ * U = P(n)*U(n)* ... *P(k)U(k)* ...,\n\ * i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n\ * 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I v 0 ) k-s\n\ * U(k) = ( 0 I 0 ) s\n\ * ( 0 0 I ) n-k\n\ * k-s s n-k\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n\ * If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n\ * and A(k,k), and v overwrites A(1:k-2,k-1:k).\n\ *\n\ * If UPLO = 'L', then A = L*D*L', where\n\ * L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n\ * i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n\ * n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I 0 0 ) k-1\n\ * L(k) = ( 0 I 0 ) s\n\ * ( 0 v I ) n-k-s+1\n\ * k-1 s n-k-s+1\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n\ * If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n\ * and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgeqrf0000644000175000017500000000724512502223525016466 0ustar uwabamiuwabami--- :name: cgeqrf :md5sum: 636ef6ebfc4f9933d33fe673fb47e58d :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - MIN(m,n) - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGEQRF computes a QR factorization of a complex M-by-N matrix A:\n\ * A = Q * R.\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) COMPLEX array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, the elements on and above the diagonal of the array\n\ * contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n\ * upper triangular if m >= n); the elements below the diagonal,\n\ * with the array TAU, represent the unitary matrix Q as a\n\ * product of min(m,n) elementary reflectors (see Further\n\ * Details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (output) COMPLEX array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace/output) COMPLEX 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,N).\n\ * For optimum performance LWORK >= N*NB, where NB is\n\ * the 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(1) H(2) . . . H(k), 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 complex scalar, and v is a complex vector with\n\ * v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\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 CGEQR2, CLARFB, CLARFT, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dstebz0000644000175000017500000002170512502223526016510 0ustar uwabamiuwabami--- :name: dstebz :md5sum: 6043998408856bffa9d3ac796deb214d :category: :subroutine :arguments: - range: :type: char :intent: input - order: :type: char :intent: input - n: :type: integer :intent: input - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublereal :intent: input :dims: - n-1 - m: :type: integer :intent: output - nsplit: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - iblock: :type: integer :intent: output :dims: - n - isplit: :type: integer :intent: output :dims: - n - work: :type: doublereal :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSTEBZ computes the eigenvalues of a symmetric tridiagonal\n\ * matrix T. The user may ask for all eigenvalues, all eigenvalues\n\ * in the half-open interval (VL, VU], or the IL-th through IU-th\n\ * eigenvalues.\n\ *\n\ * To avoid overflow, the matrix must be scaled so that its\n\ * largest element is no greater than overflow**(1/2) *\n\ * underflow**(1/4) in absolute value, and for greatest\n\ * accuracy, it should not be much smaller than that.\n\ *\n\ * See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n\ * Matrix\", Report CS41, Computer Science Dept., Stanford\n\ * University, July 21, 1966.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': (\"All\") all eigenvalues will be found.\n\ * = 'V': (\"Value\") all eigenvalues in the half-open interval\n\ * (VL, VU] will be found.\n\ * = 'I': (\"Index\") the IL-th through IU-th eigenvalues (of the\n\ * entire matrix) will be found.\n\ *\n\ * ORDER (input) CHARACTER*1\n\ * = 'B': (\"By Block\") the eigenvalues will be grouped by\n\ * split-off block (see IBLOCK, ISPLIT) and\n\ * ordered from smallest to largest within\n\ * the block.\n\ * = 'E': (\"Entire matrix\")\n\ * the eigenvalues for the entire matrix\n\ * will be ordered from smallest to\n\ * largest.\n\ *\n\ * N (input) INTEGER\n\ * The order of the tridiagonal matrix T. N >= 0.\n\ *\n\ * VL (input) DOUBLE PRECISION\n\ * VU (input) DOUBLE PRECISION\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. Eigenvalues less than or equal\n\ * to VL, or greater than VU, will not be returned. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) DOUBLE PRECISION\n\ * The absolute tolerance for the eigenvalues. An eigenvalue\n\ * (or cluster) is considered to be located if it has been\n\ * determined to lie in an interval whose width is ABSTOL or\n\ * less. If ABSTOL is less than or equal to zero, then ULP*|T|\n\ * will be used, where |T| means the 1-norm of T.\n\ *\n\ * Eigenvalues will be computed most accurately when ABSTOL is\n\ * set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The n diagonal elements of the tridiagonal matrix T.\n\ *\n\ * E (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) off-diagonal elements of the tridiagonal matrix T.\n\ *\n\ * M (output) INTEGER\n\ * The actual number of eigenvalues found. 0 <= M <= N.\n\ * (See also the description of INFO=2,3.)\n\ *\n\ * NSPLIT (output) INTEGER\n\ * The number of diagonal blocks in the matrix T.\n\ * 1 <= NSPLIT <= N.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * On exit, the first M elements of W will contain the\n\ * eigenvalues. (DSTEBZ may use the remaining N-M elements as\n\ * workspace.)\n\ *\n\ * IBLOCK (output) INTEGER array, dimension (N)\n\ * At each row/column j where E(j) is zero or small, the\n\ * matrix T is considered to split into a block diagonal\n\ * matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which\n\ * block (from 1 to the number of blocks) the eigenvalue W(i)\n\ * belongs. (DSTEBZ may use the remaining N-M elements as\n\ * workspace.)\n\ *\n\ * ISPLIT (output) INTEGER array, dimension (N)\n\ * The splitting points, at which T breaks up into submatrices.\n\ * The first submatrix consists of rows/columns 1 to ISPLIT(1),\n\ * the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n\ * etc., and the NSPLIT-th consists of rows/columns\n\ * ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n\ * (Only the first NSPLIT elements will actually be used, but\n\ * since the user cannot know a priori what value NSPLIT will\n\ * have, N words must be reserved for ISPLIT.)\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (3*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: some or all of the eigenvalues failed to converge or\n\ * were not computed:\n\ * =1 or 3: Bisection failed to converge for some\n\ * eigenvalues; these eigenvalues are flagged by a\n\ * negative block number. The effect is that the\n\ * eigenvalues may not be as accurate as the\n\ * absolute and relative tolerances. This is\n\ * generally caused by unexpectedly inaccurate\n\ * arithmetic.\n\ * =2 or 3: RANGE='I' only: Not all of the eigenvalues\n\ * IL:IU were found.\n\ * Effect: M < IU+1-IL\n\ * Cause: non-monotonic arithmetic, causing the\n\ * Sturm sequence to be non-monotonic.\n\ * Cure: recalculate, using RANGE='A', and pick\n\ * out eigenvalues IL:IU. In some cases,\n\ * increasing the PARAMETER \"FUDGE\" may\n\ * make things work.\n\ * = 4: RANGE='I', and the Gershgorin interval\n\ * initially used was too small. No eigenvalues\n\ * were computed.\n\ * Probable cause: your machine has sloppy\n\ * floating-point arithmetic.\n\ * Cure: Increase the PARAMETER \"FUDGE\",\n\ * recompile, and try again.\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * RELFAC DOUBLE PRECISION, default = 2.0e0\n\ * The relative tolerance. An interval (a,b] lies within\n\ * \"relative tolerance\" if b-a < RELFAC*ulp*max(|a|,|b|),\n\ * where \"ulp\" is the machine precision (distance from 1 to\n\ * the next larger floating point number.)\n\ *\n\ * FUDGE DOUBLE PRECISION, default = 2\n\ * A \"fudge factor\" to widen the Gershgorin intervals. Ideally,\n\ * a value of 1 should work, but on machines with sloppy\n\ * arithmetic, this needs to be larger. The default for\n\ * publicly released versions should be large enough to handle\n\ * the worst machine around. Note that this has no effect\n\ * on accuracy of the solution.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clalsa0000644000175000017500000001751312502223525016455 0ustar uwabamiuwabami--- :name: clalsa :md5sum: 363cb6c58961bef07799e856899db4f6 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - smlsiz: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - bx: :type: complex :intent: output :dims: - ldbx - nrhs - ldbx: :type: integer :intent: input - u: :type: real :intent: input :dims: - ldu - smlsiz - ldu: :type: integer :intent: input - vt: :type: real :intent: input :dims: - ldu - smlsiz+1 - k: :type: integer :intent: input :dims: - n - difl: :type: real :intent: input :dims: - ldu - nlvl - difr: :type: real :intent: input :dims: - ldu - 2 * nlvl - z: :type: real :intent: input :dims: - ldu - nlvl - poles: :type: real :intent: input :dims: - ldu - 2 * nlvl - givptr: :type: integer :intent: input :dims: - n - givcol: :type: integer :intent: input :dims: - ldgcol - 2 * nlvl - ldgcol: :type: integer :intent: input - perm: :type: integer :intent: input :dims: - ldgcol - nlvl - givnum: :type: real :intent: input :dims: - ldu - 2 * nlvl - c: :type: real :intent: input :dims: - n - s: :type: real :intent: input :dims: - n - rwork: :type: real :intent: workspace :dims: - MAX(n,(smlsiz+1)*nrhs*3) - iwork: :type: integer :intent: workspace :dims: - 3 * n - info: :type: integer :intent: output :substitutions: ldbx: n nlvl: (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1 :fortran_help: " SUBROUTINE CLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, PERM, GIVNUM, C, S, RWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLALSA is an itermediate step in solving the least squares problem\n\ * by computing the SVD of the coefficient matrix in compact form (The\n\ * singular vectors are computed as products of simple orthorgonal\n\ * matrices.).\n\ *\n\ * If ICOMPQ = 0, CLALSA applies the inverse of the left singular vector\n\ * matrix of an upper bidiagonal matrix to the right hand side; and if\n\ * ICOMPQ = 1, CLALSA applies the right singular vector matrix to the\n\ * right hand side. The singular vector matrices were generated in\n\ * compact form by CLALSA.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ICOMPQ (input) INTEGER\n\ * Specifies whether the left or the right singular vector\n\ * matrix is involved.\n\ * = 0: Left singular vector matrix\n\ * = 1: Right singular vector matrix\n\ *\n\ * SMLSIZ (input) INTEGER\n\ * The maximum size of the subproblems at the bottom of the\n\ * computation tree.\n\ *\n\ * N (input) INTEGER\n\ * The row and column dimensions of the upper bidiagonal matrix.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of columns of B and BX. NRHS must be at least 1.\n\ *\n\ * B (input/output) COMPLEX array, dimension ( LDB, NRHS )\n\ * On input, B contains the right hand sides of the least\n\ * squares problem in rows 1 through M.\n\ * On output, B contains the solution X in rows 1 through N.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B in the calling subprogram.\n\ * LDB must be at least max(1,MAX( M, N ) ).\n\ *\n\ * BX (output) COMPLEX array, dimension ( LDBX, NRHS )\n\ * On exit, the result of applying the left or right singular\n\ * vector matrix to B.\n\ *\n\ * LDBX (input) INTEGER\n\ * The leading dimension of BX.\n\ *\n\ * U (input) REAL array, dimension ( LDU, SMLSIZ ).\n\ * On entry, U contains the left singular vector matrices of all\n\ * subproblems at the bottom level.\n\ *\n\ * LDU (input) INTEGER, LDU = > N.\n\ * The leading dimension of arrays U, VT, DIFL, DIFR,\n\ * POLES, GIVNUM, and Z.\n\ *\n\ * VT (input) REAL array, dimension ( LDU, SMLSIZ+1 ).\n\ * On entry, VT' contains the right singular vector matrices of\n\ * all subproblems at the bottom level.\n\ *\n\ * K (input) INTEGER array, dimension ( N ).\n\ *\n\ * DIFL (input) REAL array, dimension ( LDU, NLVL ).\n\ * where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.\n\ *\n\ * DIFR (input) REAL array, dimension ( LDU, 2 * NLVL ).\n\ * On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record\n\ * distances between singular values on the I-th level and\n\ * singular values on the (I -1)-th level, and DIFR(*, 2 * I)\n\ * record the normalizing factors of the right singular vectors\n\ * matrices of subproblems on I-th level.\n\ *\n\ * Z (input) REAL array, dimension ( LDU, NLVL ).\n\ * On entry, Z(1, I) contains the components of the deflation-\n\ * adjusted updating row vector for subproblems on the I-th\n\ * level.\n\ *\n\ * POLES (input) REAL array, dimension ( LDU, 2 * NLVL ).\n\ * On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old\n\ * singular values involved in the secular equations on the I-th\n\ * level.\n\ *\n\ * GIVPTR (input) INTEGER array, dimension ( N ).\n\ * On entry, GIVPTR( I ) records the number of Givens\n\ * rotations performed on the I-th problem on the computation\n\ * tree.\n\ *\n\ * GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ).\n\ * On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the\n\ * locations of Givens rotations performed on the I-th level on\n\ * the computation tree.\n\ *\n\ * LDGCOL (input) INTEGER, LDGCOL = > N.\n\ * The leading dimension of arrays GIVCOL and PERM.\n\ *\n\ * PERM (input) INTEGER array, dimension ( LDGCOL, NLVL ).\n\ * On entry, PERM(*, I) records permutations done on the I-th\n\ * level of the computation tree.\n\ *\n\ * GIVNUM (input) REAL array, dimension ( LDU, 2 * NLVL ).\n\ * On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-\n\ * values of Givens rotations performed on the I-th level on the\n\ * computation tree.\n\ *\n\ * C (input) REAL array, dimension ( N ).\n\ * On entry, if the I-th subproblem is not square,\n\ * C( I ) contains the C-value of a Givens rotation related to\n\ * the right null space of the I-th subproblem.\n\ *\n\ * S (input) REAL array, dimension ( N ).\n\ * On entry, if the I-th subproblem is not square,\n\ * S( I ) contains the S-value of a Givens rotation related to\n\ * the right null space of the I-th subproblem.\n\ *\n\ * RWORK (workspace) REAL array, dimension at least\n\ * MAX( (SMLSZ+1)*NRHS*3, N*(1+NRHS) + 2*NRHS ).\n\ *\n\ * IWORK (workspace) INTEGER array.\n\ * The dimension must be at least 3 * N\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\ * Based on contributions by\n\ * Ming Gu and Ren-Cang Li, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clanhb0000644000175000017500000000640512502223525016443 0ustar uwabamiuwabami--- :name: clanhb :md5sum: f47750f12cb222d8f12ee2c177479928 :category: :function :type: real :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " REAL FUNCTION CLANHB( NORM, UPLO, N, K, AB, LDAB, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLANHB returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of an\n\ * n by n hermitian band matrix A, with k super-diagonals.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * CLANHB returns the value\n\ *\n\ * CLANHB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in CLANHB as described\n\ * above.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * band matrix A is supplied.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, CLANHB is\n\ * set to zero.\n\ *\n\ * K (input) INTEGER\n\ * The number of super-diagonals or sub-diagonals of the\n\ * band matrix A. K >= 0.\n\ *\n\ * AB (input) COMPLEX array, dimension (LDAB,N)\n\ * The upper or lower triangle of the hermitian band matrix A,\n\ * stored in the first K+1 rows of AB. The j-th column of A is\n\ * stored in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).\n\ * Note that the imaginary parts of the diagonal elements need\n\ * not be set and are assumed to be zero.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= K+1.\n\ *\n\ * WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n\ * WORK is not referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dtgevc0000644000175000017500000002370712502223526016475 0ustar uwabamiuwabami--- :name: dtgevc :md5sum: 05c0ef877f01207c516547bdc1379d50 :category: :subroutine :arguments: - side: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - s: :type: doublereal :intent: input :dims: - lds - n - lds: :type: integer :intent: input - p: :type: doublereal :intent: input :dims: - ldp - n - ldp: :type: integer :intent: input - vl: :type: doublereal :intent: input/output :dims: - ldvl - mm - ldvl: :type: integer :intent: input - vr: :type: doublereal :intent: input/output :dims: - ldvr - mm - ldvr: :type: integer :intent: input - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: doublereal :intent: workspace :dims: - 6*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTGEVC computes some or all of the right and/or left eigenvectors of\n\ * a pair of real matrices (S,P), where S is a quasi-triangular matrix\n\ * and P is upper triangular. Matrix pairs of this type are produced by\n\ * the generalized Schur factorization of a matrix pair (A,B):\n\ *\n\ * A = Q*S*Z**T, B = Q*P*Z**T\n\ *\n\ * as computed by DGGHRD + DHGEQZ.\n\ *\n\ * The right eigenvector x and the left eigenvector y of (S,P)\n\ * corresponding to an eigenvalue w are defined by:\n\ * \n\ * S*x = w*P*x, (y**H)*S = w*(y**H)*P,\n\ * \n\ * where y**H denotes the conjugate tranpose of y.\n\ * The eigenvalues are not input to this routine, but are computed\n\ * directly from the diagonal blocks of S and P.\n\ * \n\ * This routine returns the matrices X and/or Y of right and left\n\ * eigenvectors of (S,P), or the products Z*X and/or Q*Y,\n\ * where Z and Q are input matrices.\n\ * If Q and Z are the orthogonal factors from the generalized Schur\n\ * factorization of a matrix pair (A,B), then Z*X and Q*Y\n\ * are the matrices of right and left eigenvectors of (A,B).\n\ * \n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'R': compute right eigenvectors only;\n\ * = 'L': compute left eigenvectors only;\n\ * = 'B': compute both right and left eigenvectors.\n\ *\n\ * HOWMNY (input) CHARACTER*1\n\ * = 'A': compute all right and/or left eigenvectors;\n\ * = 'B': compute all right and/or left eigenvectors,\n\ * backtransformed by the matrices in VR and/or VL;\n\ * = 'S': compute selected right and/or left eigenvectors,\n\ * specified by the logical array SELECT.\n\ *\n\ * SELECT (input) LOGICAL array, dimension (N)\n\ * If HOWMNY='S', SELECT specifies the eigenvectors to be\n\ * computed. If w(j) is a real eigenvalue, the corresponding\n\ * real eigenvector is computed if SELECT(j) is .TRUE..\n\ * If w(j) and w(j+1) are the real and imaginary parts of a\n\ * complex eigenvalue, the corresponding complex eigenvector\n\ * is computed if either SELECT(j) or SELECT(j+1) is .TRUE.,\n\ * and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is\n\ * set to .FALSE..\n\ * Not referenced if HOWMNY = 'A' or 'B'.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices S and P. N >= 0.\n\ *\n\ * S (input) DOUBLE PRECISION array, dimension (LDS,N)\n\ * The upper quasi-triangular matrix S from a generalized Schur\n\ * factorization, as computed by DHGEQZ.\n\ *\n\ * LDS (input) INTEGER\n\ * The leading dimension of array S. LDS >= max(1,N).\n\ *\n\ * P (input) DOUBLE PRECISION array, dimension (LDP,N)\n\ * The upper triangular matrix P from a generalized Schur\n\ * factorization, as computed by DHGEQZ.\n\ * 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks\n\ * of S must be in positive diagonal form.\n\ *\n\ * LDP (input) INTEGER\n\ * The leading dimension of array P. LDP >= max(1,N).\n\ *\n\ * VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)\n\ * On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n\ * contain an N-by-N matrix Q (usually the orthogonal matrix Q\n\ * of left Schur vectors returned by DHGEQZ).\n\ * On exit, if SIDE = 'L' or 'B', VL contains:\n\ * if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);\n\ * if HOWMNY = 'B', the matrix Q*Y;\n\ * if HOWMNY = 'S', the left eigenvectors of (S,P) specified by\n\ * SELECT, stored consecutively in the columns of\n\ * VL, in the same order as their eigenvalues.\n\ *\n\ * A complex eigenvector corresponding to a complex eigenvalue\n\ * is stored in two consecutive columns, the first holding the\n\ * real part, and the second the imaginary part.\n\ *\n\ * Not referenced if SIDE = 'R'.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of array VL. LDVL >= 1, and if\n\ * SIDE = 'L' or 'B', LDVL >= N.\n\ *\n\ * VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)\n\ * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n\ * contain an N-by-N matrix Z (usually the orthogonal matrix Z\n\ * of right Schur vectors returned by DHGEQZ).\n\ *\n\ * On exit, if SIDE = 'R' or 'B', VR contains:\n\ * if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);\n\ * if HOWMNY = 'B' or 'b', the matrix Z*X;\n\ * if HOWMNY = 'S' or 's', the right eigenvectors of (S,P)\n\ * specified by SELECT, stored consecutively in the\n\ * columns of VR, in the same order as their\n\ * eigenvalues.\n\ *\n\ * A complex eigenvector corresponding to a complex eigenvalue\n\ * is stored in two consecutive columns, the first holding the\n\ * real part and the second the imaginary part.\n\ * \n\ * Not referenced if SIDE = 'L'.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the array VR. LDVR >= 1, and if\n\ * SIDE = 'R' or 'B', LDVR >= N.\n\ *\n\ * MM (input) INTEGER\n\ * The number of columns in the arrays VL and/or VR. MM >= M.\n\ *\n\ * M (output) INTEGER\n\ * The number of columns in the arrays VL and/or VR actually\n\ * used to store the eigenvectors. If HOWMNY = 'A' or 'B', M\n\ * is set to N. Each selected real eigenvector occupies one\n\ * column and each selected complex eigenvector occupies two\n\ * columns.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (6*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit.\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * > 0: the 2-by-2 block (INFO:INFO+1) does not have a complex\n\ * eigenvalue.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Allocation of workspace:\n\ * ---------- -- ---------\n\ *\n\ * WORK( j ) = 1-norm of j-th column of A, above the diagonal\n\ * WORK( N+j ) = 1-norm of j-th column of B, above the diagonal\n\ * WORK( 2*N+1:3*N ) = real part of eigenvector\n\ * WORK( 3*N+1:4*N ) = imaginary part of eigenvector\n\ * WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector\n\ * WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector\n\ *\n\ * Rowwise vs. columnwise solution methods:\n\ * ------- -- ---------- -------- -------\n\ *\n\ * Finding a generalized eigenvector consists basically of solving the\n\ * singular triangular system\n\ *\n\ * (A - w B) x = 0 (for right) or: (A - w B)**H y = 0 (for left)\n\ *\n\ * Consider finding the i-th right eigenvector (assume all eigenvalues\n\ * are real). The equation to be solved is:\n\ * n i\n\ * 0 = sum C(j,k) v(k) = sum C(j,k) v(k) for j = i,. . .,1\n\ * k=j k=j\n\ *\n\ * where C = (A - w B) (The components v(i+1:n) are 0.)\n\ *\n\ * The \"rowwise\" method is:\n\ *\n\ * (1) v(i) := 1\n\ * for j = i-1,. . .,1:\n\ * i\n\ * (2) compute s = - sum C(j,k) v(k) and\n\ * k=j+1\n\ *\n\ * (3) v(j) := s / C(j,j)\n\ *\n\ * Step 2 is sometimes called the \"dot product\" step, since it is an\n\ * inner product between the j-th row and the portion of the eigenvector\n\ * that has been computed so far.\n\ *\n\ * The \"columnwise\" method consists basically in doing the sums\n\ * for all the rows in parallel. As each v(j) is computed, the\n\ * contribution of v(j) times the j-th column of C is added to the\n\ * partial sums. Since FORTRAN arrays are stored columnwise, this has\n\ * the advantage that at each step, the elements of C that are accessed\n\ * are adjacent to one another, whereas with the rowwise method, the\n\ * elements accessed at a step are spaced LDS (and LDP) words apart.\n\ *\n\ * When finding left eigenvectors, the matrix in question is the\n\ * transpose of the one in storage, so the rowwise method then\n\ * actually accesses columns of A and B at each step, and so is the\n\ * preferred method.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgtrfs0000644000175000017500000001267312502223525016510 0ustar uwabamiuwabami--- :name: cgtrfs :md5sum: 40687df2803e8c7314702e4c54e11070 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: complex :intent: input :dims: - n-1 - d: :type: complex :intent: input :dims: - n - du: :type: complex :intent: input :dims: - n-1 - dlf: :type: complex :intent: input :dims: - n-1 - df: :type: complex :intent: input :dims: - n - duf: :type: complex :intent: input :dims: - n-1 - du2: :type: complex :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGTRFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is tridiagonal, and provides\n\ * error bounds and backward error estimates for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * DL (input) COMPLEX array, dimension (N-1)\n\ * The (n-1) subdiagonal elements of A.\n\ *\n\ * D (input) COMPLEX array, dimension (N)\n\ * The diagonal elements of A.\n\ *\n\ * DU (input) COMPLEX array, dimension (N-1)\n\ * The (n-1) superdiagonal elements of A.\n\ *\n\ * DLF (input) COMPLEX array, dimension (N-1)\n\ * The (n-1) multipliers that define the matrix L from the\n\ * LU factorization of A as computed by CGTTRF.\n\ *\n\ * DF (input) COMPLEX array, dimension (N)\n\ * The n diagonal elements of the upper triangular matrix U from\n\ * the LU factorization of A.\n\ *\n\ * DUF (input) COMPLEX array, dimension (N-1)\n\ * The (n-1) elements of the first superdiagonal of U.\n\ *\n\ * DU2 (input) COMPLEX array, dimension (N-2)\n\ * The (n-2) elements of the second superdiagonal of U.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices; for 1 <= i <= n, row i of the matrix was\n\ * interchanged with row IPIV(i). IPIV(i) will always be either\n\ * i or i+1; IPIV(i) = i indicates a row interchange was not\n\ * required.\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) COMPLEX array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by CGTTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlapll0000644000175000017500000000372112502223526016463 0ustar uwabamiuwabami--- :name: dlapll :md5sum: 08eb4ce7bfd3ce4c24db7b847d4d9b50 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - y: :type: doublereal :intent: input/output :dims: - 1+(n-1)*incy - incy: :type: integer :intent: input - ssmin: :type: doublereal :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLAPLL( N, X, INCX, Y, INCY, SSMIN )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Given two column vectors X and Y, let\n\ *\n\ * A = ( X Y ).\n\ *\n\ * The subroutine first computes the QR factorization of A = Q*R,\n\ * and then computes the SVD of the 2-by-2 upper triangular matrix R.\n\ * The smaller singular value of R is returned in SSMIN, which is used\n\ * as the measurement of the linear dependency of the vectors X and Y.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The length of the vectors X and Y.\n\ *\n\ * X (input/output) DOUBLE PRECISION array,\n\ * dimension (1+(N-1)*INCX)\n\ * On entry, X contains the N-vector X.\n\ * On exit, X is overwritten.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between successive elements of X. INCX > 0.\n\ *\n\ * Y (input/output) DOUBLE PRECISION array,\n\ * dimension (1+(N-1)*INCY)\n\ * On entry, Y contains the N-vector Y.\n\ * On exit, Y is overwritten.\n\ *\n\ * INCY (input) INTEGER\n\ * The increment between successive elements of Y. INCY > 0.\n\ *\n\ * SSMIN (output) DOUBLE PRECISION\n\ * The smallest singular value of the N-by-2 matrix A = ( X Y ).\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssysv0000644000175000017500000001271512502223526016405 0ustar uwabamiuwabami--- :name: ssysv :md5sum: 3e9925aac8d350c2ab75099826bbc8f9 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSYSV computes the solution to a real system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n\ * matrices.\n\ *\n\ * The diagonal pivoting method is used to factor A as\n\ * A = U * D * U**T, if UPLO = 'U', or\n\ * A = L * D * L**T, if UPLO = 'L',\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, and D is symmetric and block diagonal with \n\ * 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then\n\ * used to solve the system of equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the block diagonal matrix D and the\n\ * multipliers used to obtain the factor U or L from the\n\ * factorization A = U*D*U**T or A = L*D*L**T as computed by\n\ * SSYTRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D, as\n\ * determined by SSYTRF. If IPIV(k) > 0, then rows and columns\n\ * k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n\ * diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n\ * then rows and columns k-1 and -IPIV(k) were interchanged and\n\ * D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n\ * IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n\ * -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n\ * diagonal block.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of WORK. LWORK >= 1, and for best performance\n\ * LWORK >= max(1,N*NB), where NB is the optimal blocksize for\n\ * SSYTRF.\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, D(i,i) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular, so the solution could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LWKOPT, NB\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL ILAENV, LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SSYTRF, SSYTRS2, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cppcon0000644000175000017500000000506612502223525016500 0ustar uwabamiuwabami--- :name: cppcon :md5sum: c3caf11aabcf2b12028393d086f0a544 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - ldap - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE CPPCON( UPLO, N, AP, ANORM, RCOND, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPPCON estimates the reciprocal of the condition number (in the \n\ * 1-norm) of a complex Hermitian positive definite packed matrix using\n\ * the Cholesky factorization A = U**H*U or A = L*L**H computed by\n\ * CPPTRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input) COMPLEX array, dimension (N*(N+1)/2)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**H*U or A = L*L**H, packed columnwise in a linear\n\ * array. The j-th column of U or L is stored in the array AP\n\ * as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n\ *\n\ * ANORM (input) REAL\n\ * The 1-norm (or infinity-norm) of the Hermitian matrix A.\n\ *\n\ * RCOND (output) REAL\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n\ * estimate of the 1-norm of inv(A) computed in this routine.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctzrzf0000644000175000017500000001016312502223525016532 0ustar uwabamiuwabami--- :name: ctzrzf :md5sum: 0236521a4c727d201e0d3d1786f9f82b :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - m - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE CTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTZRZF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A\n\ * to upper triangular form by means of unitary transformations.\n\ *\n\ * The upper trapezoidal matrix A is factored as\n\ *\n\ * A = ( R 0 ) * Z,\n\ *\n\ * where Z is an N-by-N unitary matrix and R is an M-by-M upper\n\ * triangular matrix.\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 >= M.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the leading M-by-N upper trapezoidal part of the\n\ * array A must contain the matrix to be factorized.\n\ * On exit, the leading M-by-M upper triangular part of A\n\ * contains the upper triangular matrix R, and elements M+1 to\n\ * N of the first M rows of A, with the array TAU, represent the\n\ * unitary matrix Z as a product of M elementary reflectors.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (output) COMPLEX array, dimension (M)\n\ * The scalar factors of the elementary reflectors.\n\ *\n\ * WORK (workspace/output) COMPLEX 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\n\ * the 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\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * The factorization is obtained by Householder's method. The kth\n\ * transformation matrix, Z( k ), which is used to introduce zeros into\n\ * the ( m - k + 1 )th row of A, is given in the form\n\ *\n\ * Z( k ) = ( I 0 ),\n\ * ( 0 T( k ) )\n\ *\n\ * where\n\ *\n\ * T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n\ * ( 0 )\n\ * ( z( k ) )\n\ *\n\ * tau is a scalar and z( k ) is an ( n - m ) element vector.\n\ * tau and z( k ) are chosen to annihilate the elements of the kth row\n\ * of X.\n\ *\n\ * The scalar tau is returned in the kth element of TAU and the vector\n\ * u( k ) in the kth row of A, such that the elements of z( k ) are\n\ * in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n\ * the upper triangular part of A.\n\ *\n\ * Z is given by\n\ *\n\ * Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgebrd0000644000175000017500000001446212502223525016444 0ustar uwabamiuwabami--- :name: cgebrd :md5sum: 95dd155a09e64e05937c7a60f152d9f3 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: real :intent: output :dims: - MIN(m,n) - e: :type: real :intent: output :dims: - MIN(m,n)-1 - tauq: :type: complex :intent: output :dims: - MIN(m,n) - taup: :type: complex :intent: output :dims: - MIN(m,n) - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGEBRD reduces a general complex M-by-N matrix A to upper or lower\n\ * bidiagonal form B by a unitary transformation: Q**H * A * P = B.\n\ *\n\ * If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows in the matrix A. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns in the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the M-by-N general matrix to be reduced.\n\ * On exit,\n\ * if m >= n, the diagonal and the first superdiagonal are\n\ * overwritten with the upper bidiagonal matrix B; the\n\ * elements below the diagonal, with the array TAUQ, represent\n\ * the unitary matrix Q as a product of elementary\n\ * reflectors, and the elements above the first superdiagonal,\n\ * with the array TAUP, represent the unitary matrix P as\n\ * a product of elementary reflectors;\n\ * if m < n, the diagonal and the first subdiagonal are\n\ * overwritten with the lower bidiagonal matrix B; the\n\ * elements below the first subdiagonal, with the array TAUQ,\n\ * represent the unitary matrix Q as a product of\n\ * elementary reflectors, and the elements above the diagonal,\n\ * with the array TAUP, represent the unitary matrix P as\n\ * a product of elementary reflectors.\n\ * See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * D (output) REAL array, dimension (min(M,N))\n\ * The diagonal elements of the bidiagonal matrix B:\n\ * D(i) = A(i,i).\n\ *\n\ * E (output) REAL array, dimension (min(M,N)-1)\n\ * The off-diagonal elements of the bidiagonal matrix B:\n\ * if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n\ * if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n\ *\n\ * TAUQ (output) COMPLEX array dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the unitary matrix Q. See Further Details.\n\ *\n\ * TAUP (output) COMPLEX array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the unitary matrix P. See Further Details.\n\ *\n\ * WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of the array WORK. LWORK >= max(1,M,N).\n\ * For optimum performance LWORK >= (M+N)*NB, where NB\n\ * is the 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 matrices Q and P are represented as products of elementary\n\ * reflectors:\n\ *\n\ * If m >= n,\n\ *\n\ * Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)\n\ *\n\ * Each H(i) and G(i) has the form:\n\ *\n\ * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n\ *\n\ * where tauq and taup are complex scalars, and v and u are complex\n\ * vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in\n\ * A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in\n\ * A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n\ *\n\ * If m < n,\n\ *\n\ * Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)\n\ *\n\ * Each H(i) and G(i) has the form:\n\ *\n\ * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n\ *\n\ * where tauq and taup are complex scalars, and v and u are complex\n\ * vectors; v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in\n\ * A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in\n\ * A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n\ *\n\ * The contents of A on exit are illustrated by the following examples:\n\ *\n\ * m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n\ *\n\ * ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )\n\ * ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )\n\ * ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )\n\ * ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )\n\ * ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )\n\ * ( v1 v2 v3 v4 v5 )\n\ *\n\ * where d and e denote diagonal and off-diagonal elements of B, vi\n\ * denotes an element of the vector defining H(i), and ui an element of\n\ * the vector defining G(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cla_rpvgrw0000644000175000017500000000440712502223525017362 0ustar uwabamiuwabami--- :name: cla_rpvgrw :md5sum: 6ea05cda1b7eeeb5b354576bf4a33b68 :category: :function :type: real :arguments: - n: :type: integer :intent: input - ncols: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input :substitutions: {} :fortran_help: " REAL FUNCTION CLA_RPVGRW( N, NCOLS, A, LDA, AF, LDAF )\n\n\ * Purpose\n\ * =======\n\ * \n\ * CLA_RPVGRW computes the reciprocal pivot growth factor\n\ * norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n\ * much less than 1, the stability of the LU factorization of the\n\ * (equilibrated) matrix A could be poor. This also means that the\n\ * solution X, estimated condition numbers, and error bounds could be\n\ * unreliable.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NCOLS (input) INTEGER\n\ * The number of columns of the matrix A. NCOLS >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX array, dimension (LDAF,N)\n\ * The factors L and U from the factorization\n\ * A = P*L*U as computed by CGETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n REAL AMAX, UMAX, RPVGRW\n COMPLEX ZDUM\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN, ABS, REAL, AIMAG\n\ * ..\n\ * .. Statement Functions ..\n REAL CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dtfsm0000644000175000017500000002114112502223526016324 0ustar uwabamiuwabami--- :name: dtfsm :md5sum: c05922958954dd29b8a6792ef3790102 :category: :subroutine :arguments: - transr: :type: char :intent: input - side: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: doublereal :intent: input - a: :type: doublereal :intent: input :dims: - nt - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE DTFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, B, LDB )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Level 3 BLAS like routine for A in RFP Format.\n\ *\n\ * DTFSM solves the matrix equation\n\ *\n\ * op( A )*X = alpha*B or X*op( A ) = alpha*B\n\ *\n\ * where alpha is a scalar, X and B are m by n matrices, A is a unit, or\n\ * non-unit, upper or lower triangular matrix and op( A ) is one of\n\ *\n\ * op( A ) = A or op( A ) = A'.\n\ *\n\ * A is in Rectangular Full Packed (RFP) Format.\n\ *\n\ * The matrix X is overwritten on B.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': The Normal Form of RFP A is stored;\n\ * = 'T': The Transpose Form of RFP A is stored.\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * On entry, SIDE specifies whether op( A ) appears on the left\n\ * or right of X as follows:\n\ *\n\ * SIDE = 'L' or 'l' op( A )*X = alpha*B.\n\ *\n\ * SIDE = 'R' or 'r' X*op( A ) = alpha*B.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * On entry, UPLO specifies whether the RFP matrix A came from\n\ * an upper or lower triangular matrix as follows:\n\ * UPLO = 'U' or 'u' RFP A came from an upper triangular matrix\n\ * UPLO = 'L' or 'l' RFP A came from a lower triangular matrix\n\ *\n\ * Unchanged on exit.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * On entry, TRANS specifies the form of op( A ) to be used\n\ * in the matrix multiplication as follows:\n\ *\n\ * TRANS = 'N' or 'n' op( A ) = A.\n\ *\n\ * TRANS = 'T' or 't' op( A ) = A'.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * On entry, DIAG specifies whether or not RFP A is unit\n\ * triangular as follows:\n\ *\n\ * DIAG = 'U' or 'u' A is assumed to be unit triangular.\n\ *\n\ * DIAG = 'N' or 'n' A is not assumed to be unit\n\ * triangular.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * M (input) INTEGER\n\ * On entry, M specifies the number of rows of B. M must be at\n\ * least zero.\n\ * Unchanged on exit.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the number of columns of B. N must be\n\ * at least zero.\n\ * Unchanged on exit.\n\ *\n\ * ALPHA (input) DOUBLE PRECISION\n\ * On entry, ALPHA specifies the scalar alpha. When alpha is\n\ * zero then A is not referenced and B need not be set before\n\ * entry.\n\ * Unchanged on exit.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (NT)\n\ * NT = N*(N+1)/2. On entry, the matrix A in RFP Format.\n\ * RFP Format is described by TRANSR, UPLO and N as follows:\n\ * If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;\n\ * K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If\n\ * TRANSR = 'T' then RFP is the transpose of RFP A as\n\ * defined when TRANSR = 'N'. The contents of RFP A are defined\n\ * by UPLO as follows: If UPLO = 'U' the RFP A contains the NT\n\ * elements of upper packed A either in normal or\n\ * transpose Format. If UPLO = 'L' the RFP A contains\n\ * the NT elements of lower packed A either in normal or\n\ * transpose Format. The LDA of RFP A is (N+1)/2 when\n\ * TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is\n\ * even and is N when is odd.\n\ * See the Note below for more details. Unchanged on exit.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,N)\n\ * Before entry, the leading m by n part of the array B must\n\ * contain the right-hand side matrix B, and on exit is\n\ * overwritten by the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * On entry, LDB specifies the first dimension of B as declared\n\ * in the calling (sub) program. LDB must be at least\n\ * max( 1, m ).\n\ * Unchanged on exit.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * We first consider Rectangular Full Packed (RFP) Format when N is\n\ * even. We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * the transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * the transpose of the last three columns of AP lower.\n\ * This covers the case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 04 05 33 43 53\n\ * 13 14 15 00 44 54\n\ * 23 24 25 10 11 55\n\ * 33 34 35 20 21 22\n\ * 00 44 45 30 31 32\n\ * 01 11 55 40 41 42\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We then consider Rectangular Full Packed (RFP) Format when N is\n\ * odd. We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * the transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * the transpose of the last two columns of AP lower.\n\ * This covers the case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 03 04 00 33 43\n\ * 12 13 14 10 11 44\n\ * 22 23 24 20 21 22\n\ * 00 33 34 30 31 32\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * Reference\n\ * =========\n\ *\n\ * =====================================================================\n\ *\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/ssyequb0000644000175000017500000000641412502223526016710 0ustar uwabamiuwabami--- :name: ssyequb :md5sum: f38f288f9e8b71ede27c0a88d4d0021f :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - s: :type: real :intent: output :dims: - n - scond: :type: real :intent: output - amax: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSYEQUB computes row and column scalings intended to equilibrate a\n\ * symmetric matrix A and reduce its condition number\n\ * (with respect to the two-norm). S contains the scale factors,\n\ * S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n\ * elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n\ * choice of S puts the condition number of B within a factor N of the\n\ * smallest possible condition number over all possible diagonal\n\ * scalings.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * The N-by-N symmetric matrix whose scaling\n\ * factors are to be computed. Only the diagonal elements of A\n\ * are referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * S (output) REAL array, dimension (N)\n\ * If INFO = 0, S contains the scale factors for A.\n\ *\n\ * SCOND (output) REAL\n\ * If INFO = 0, S contains the ratio of the smallest S(i) to\n\ * the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n\ * large nor too small, it is not worth scaling by S.\n\ *\n\ * AMAX (output) REAL\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\n\ *\n\ * WORK (workspace) REAL array, dimension (3*N)\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 is nonpositive.\n\ *\n\n\ * Further Details\n\ * ======= =======\n\ *\n\ * Reference: Livne, O.E. and Golub, G.H., \"Scaling by Binormalization\",\n\ * Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004.\n\ * DOI 10.1023/B:NUMA.0000016606.32820.69\n\ * Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clatdf0000644000175000017500000001153412502223525016450 0ustar uwabamiuwabami--- :name: clatdf :md5sum: 5c926a59b991b5455a3094fe676dfba8 :category: :subroutine :arguments: - ijob: :type: integer :intent: input - n: :type: integer :intent: input - z: :type: complex :intent: input :dims: - ldz - n - ldz: :type: integer :intent: input - rhs: :type: complex :intent: input/output :dims: - n - rdsum: :type: real :intent: input/output - rdscal: :type: real :intent: input/output - ipiv: :type: integer :intent: input :dims: - n - jpiv: :type: integer :intent: input :dims: - n :substitutions: {} :fortran_help: " SUBROUTINE CLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, JPIV )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLATDF computes the contribution to the reciprocal Dif-estimate\n\ * by solving for x in Z * x = b, where b is chosen such that the norm\n\ * of x is as large as possible. It is assumed that LU decomposition\n\ * of Z has been computed by CGETC2. On entry RHS = f holds the\n\ * contribution from earlier solved sub-systems, and on return RHS = x.\n\ *\n\ * The factorization of Z returned by CGETC2 has the form\n\ * Z = P * L * U * Q, where P and Q are permutation matrices. L is lower\n\ * triangular with unit diagonal elements and U is upper triangular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * IJOB (input) INTEGER\n\ * IJOB = 2: First compute an approximative null-vector e\n\ * of Z using CGECON, e is normalized and solve for\n\ * Zx = +-e - f with the sign giving the greater value of\n\ * 2-norm(x). About 5 times as expensive as Default.\n\ * IJOB .ne. 2: Local look ahead strategy where\n\ * all entries of the r.h.s. b is choosen as either +1 or\n\ * -1. Default.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Z.\n\ *\n\ * Z (input) REAL array, dimension (LDZ, N)\n\ * On entry, the LU part of the factorization of the n-by-n\n\ * matrix Z computed by CGETC2: Z = P * L * U * Q\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDA >= max(1, N).\n\ *\n\ * RHS (input/output) REAL array, dimension (N).\n\ * On entry, RHS contains contributions from other subsystems.\n\ * On exit, RHS contains the solution of the subsystem with\n\ * entries according to the value of IJOB (see above).\n\ *\n\ * RDSUM (input/output) REAL\n\ * On entry, the sum of squares of computed contributions to\n\ * the Dif-estimate under computation by CTGSYL, where the\n\ * scaling factor RDSCAL (see below) has been factored out.\n\ * On exit, the corresponding sum of squares updated with the\n\ * contributions from the current sub-system.\n\ * If TRANS = 'T' RDSUM is not touched.\n\ * NOTE: RDSUM only makes sense when CTGSY2 is called by CTGSYL.\n\ *\n\ * RDSCAL (input/output) REAL\n\ * On entry, scaling factor used to prevent overflow in RDSUM.\n\ * On exit, RDSCAL is updated w.r.t. the current contributions\n\ * in RDSUM.\n\ * If TRANS = 'T', RDSCAL is not touched.\n\ * NOTE: RDSCAL only makes sense when CTGSY2 is called by\n\ * CTGSYL.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N).\n\ * The pivot indices; for 1 <= i <= N, row i of the\n\ * matrix has been interchanged with row IPIV(i).\n\ *\n\ * JPIV (input) INTEGER array, dimension (N).\n\ * The pivot indices; for 1 <= j <= N, column j of the\n\ * matrix has been interchanged with column JPIV(j).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * This routine is a further developed implementation of algorithm\n\ * BSOLVE in [1] using complete pivoting in the LU factorization.\n\ *\n\ * [1] Bo Kagstrom and Lars Westin,\n\ * Generalized Schur Methods with Condition Estimators for\n\ * Solving the Generalized Sylvester Equation, IEEE Transactions\n\ * on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.\n\ *\n\ * [2] Peter Poromaa,\n\ * On Efficient and Robust Estimators for the Separation\n\ * between two Regular Matrix Pairs with Applications in\n\ * Condition Estimation. Report UMINF-95.05, Department of\n\ * Computing Science, Umea University, S-901 87 Umea, Sweden,\n\ * 1995.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dpftrs0000644000175000017500000001320512502223526016513 0ustar uwabamiuwabami--- :name: dpftrs :md5sum: 7346bc2529481adfa1f5429620050f99 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - n*(n+1)/2 - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPFTRS solves a system of linear equations A*X = B with a symmetric\n\ * positive definite matrix A using the Cholesky factorization\n\ * A = U**T*U or A = L*L**T computed by DPFTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': The Normal TRANSR of RFP A is stored;\n\ * = 'T': The Transpose TRANSR of RFP A is stored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of RFP A is stored;\n\ * = 'L': Lower triangle of RFP A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ).\n\ * The triangular factor U or L from the Cholesky factorization\n\ * of RFP A = U**T*U or RFP A = L*L**T, as computed by DPFTRF.\n\ * See note below for more details about RFP A.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * We first consider Rectangular Full Packed (RFP) Format when N is\n\ * even. We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * the transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * the transpose of the last three columns of AP lower.\n\ * This covers the case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 04 05 33 43 53\n\ * 13 14 15 00 44 54\n\ * 23 24 25 10 11 55\n\ * 33 34 35 20 21 22\n\ * 00 44 45 30 31 32\n\ * 01 11 55 40 41 42\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We then consider Rectangular Full Packed (RFP) Format when N is\n\ * odd. We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * the transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * the transpose of the last two columns of AP lower.\n\ * This covers the case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 03 04 00 33 43\n\ * 12 13 14 10 11 44\n\ * 22 23 24 20 21 22\n\ * 00 33 34 30 31 32\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clagtm0000644000175000017500000000606112502223525016461 0ustar uwabamiuwabami--- :name: clagtm :md5sum: 76bb9071a03ce8f5aeaa641ddf9532e8 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - alpha: :type: real :intent: input - dl: :type: complex :intent: input :dims: - n-1 - d: :type: complex :intent: input :dims: - n - du: :type: complex :intent: input :dims: - n-1 - x: :type: complex :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - beta: :type: real :intent: input - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE CLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, B, LDB )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAGTM performs a matrix-vector product of the form\n\ *\n\ * B := alpha * A * X + beta * B\n\ *\n\ * where A is a tridiagonal matrix of order N, B and X are N by NRHS\n\ * matrices, and alpha and beta are real scalars, each of which may be\n\ * 0., 1., or -1.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the operation applied to A.\n\ * = 'N': No transpose, B := alpha * A * X + beta * B\n\ * = 'T': Transpose, B := alpha * A**T * X + beta * B\n\ * = 'C': Conjugate transpose, B := alpha * A**H * X + beta * B\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices X and B.\n\ *\n\ * ALPHA (input) REAL\n\ * The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise,\n\ * it is assumed to be 0.\n\ *\n\ * DL (input) COMPLEX array, dimension (N-1)\n\ * The (n-1) sub-diagonal elements of T.\n\ *\n\ * D (input) COMPLEX array, dimension (N)\n\ * The diagonal elements of T.\n\ *\n\ * DU (input) COMPLEX array, dimension (N-1)\n\ * The (n-1) super-diagonal elements of T.\n\ *\n\ * X (input) COMPLEX array, dimension (LDX,NRHS)\n\ * The N by NRHS matrix X.\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(N,1).\n\ *\n\ * BETA (input) REAL\n\ * The scalar beta. BETA must be 0., 1., or -1.; otherwise,\n\ * it is assumed to be 1.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the N by NRHS matrix B.\n\ * On exit, B is overwritten by the matrix expression\n\ * B := alpha * A * X + beta * B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(N,1).\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlaqps0000644000175000017500000001023612502223526016476 0ustar uwabamiuwabami--- :name: dlaqps :md5sum: cd53ffb1ef39ff1b9a7f507f393e88d5 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - offset: :type: integer :intent: input - nb: :type: integer :intent: input - kb: :type: integer :intent: output - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: doublereal :intent: output :dims: - kb - vn1: :type: doublereal :intent: input/output :dims: - n - vn2: :type: doublereal :intent: input/output :dims: - n - auxv: :type: doublereal :intent: input/output :dims: - nb - f: :type: doublereal :intent: input/output :dims: - ldf - nb - ldf: :type: integer :intent: input :substitutions: kb: nb :fortran_help: " SUBROUTINE DLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, VN2, AUXV, F, LDF )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAQPS computes a step of QR factorization with column pivoting\n\ * of a real M-by-N matrix A by using Blas-3. It tries to factorize\n\ * NB columns from A starting from the row OFFSET+1, and updates all\n\ * of the matrix with Blas-3 xGEMM.\n\ *\n\ * In some cases, due to catastrophic cancellations, it cannot\n\ * factorize NB columns. Hence, the actual number of factorized\n\ * columns is returned in KB.\n\ *\n\ * Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\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\ * OFFSET (input) INTEGER\n\ * The number of rows of A that have been factorized in\n\ * previous steps.\n\ *\n\ * NB (input) INTEGER\n\ * The number of columns to factorize.\n\ *\n\ * KB (output) INTEGER\n\ * The number of columns actually factorized.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, block A(OFFSET+1:M,1:KB) is the triangular\n\ * factor obtained and block A(1:OFFSET,1:N) has been\n\ * accordingly pivoted, but no factorized.\n\ * The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has\n\ * been updated.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * JPVT (input/output) INTEGER array, dimension (N)\n\ * JPVT(I) = K <==> Column K of the full matrix A has been\n\ * permuted into position I in AP.\n\ *\n\ * TAU (output) DOUBLE PRECISION array, dimension (KB)\n\ * The scalar factors of the elementary reflectors.\n\ *\n\ * VN1 (input/output) DOUBLE PRECISION array, dimension (N)\n\ * The vector with the partial column norms.\n\ *\n\ * VN2 (input/output) DOUBLE PRECISION array, dimension (N)\n\ * The vector with the exact column norms.\n\ *\n\ * AUXV (input/output) DOUBLE PRECISION array, dimension (NB)\n\ * Auxiliar vector.\n\ *\n\ * F (input/output) DOUBLE PRECISION array, dimension (LDF,NB)\n\ * Matrix F' = L*Y'*A.\n\ *\n\ * LDF (input) INTEGER\n\ * The leading dimension of the array F. LDF >= max(1,N).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n\ * X. Sun, Computer Science Dept., Duke University, USA\n\ *\n\ * Partial column norm updating strategy modified by\n\ * Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n\ * University of Zagreb, Croatia.\n\ * June 2010\n\ * For more details see LAPACK Working Note 176.\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgbsvxx0000644000175000017500000005647612502223526016717 0ustar uwabamiuwabami--- :name: dgbsvxx :md5sum: ed3b7b61f317423e291101840cbbe4a8 :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublereal :intent: input/output :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - equed: :type: char :intent: input/output - r: :type: doublereal :intent: input/output :dims: - n - c: :type: doublereal :intent: input/output :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - rpvgrw: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublereal :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " SUBROUTINE DGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGBSVXX uses the LU factorization to compute the solution to a\n\ * double precision system of linear equations A * X = B, where A is an\n\ * N-by-N matrix and X and B are N-by-NRHS matrices.\n\ *\n\ * If requested, both normwise and maximum componentwise error bounds\n\ * are returned. DGBSVXX will return a solution with a tiny\n\ * guaranteed error (O(eps) where eps is the working machine\n\ * precision) unless the matrix is very ill-conditioned, in which\n\ * case a warning is returned. Relevant condition numbers also are\n\ * calculated and returned.\n\ *\n\ * DGBSVXX accepts user-provided factorizations and equilibration\n\ * factors; see the definitions of the FACT and EQUED options.\n\ * Solving with refinement and using a factorization from a previous\n\ * DGBSVXX call will also produce a solution with either O(eps)\n\ * errors or warnings, but we cannot make that claim for general\n\ * user-provided factorizations and equilibration factors if they\n\ * differ from what DGBSVXX would itself produce.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n\ * the system:\n\ *\n\ * TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n\ * TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n\ * TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n\ *\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n\ * or diag(C)*B (if TRANS = 'T' or 'C').\n\ *\n\ * 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n\ * the matrix A (after equilibration if FACT = 'E') as\n\ *\n\ * A = P * L * U,\n\ *\n\ * where P is a permutation matrix, L is a unit lower triangular\n\ * matrix, and U is upper triangular.\n\ *\n\ * 3. If some U(i,i)=0, so that U is exactly singular, then the\n\ * routine returns with INFO = i. Otherwise, the factored form of A\n\ * is used to estimate the condition number of the matrix A (see\n\ * argument RCOND). If the reciprocal of the condition number is less\n\ * than machine precision, the routine still goes on to solve for X\n\ * and compute error bounds as described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n\ * the routine will use iterative refinement to try to get a small\n\ * error and error bounds. Refinement calculates the residual to at\n\ * least twice the working precision.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n\ * that it solves the original system before equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AF and IPIV contain the factored form of A.\n\ * If EQUED is not 'N', the matrix A has been\n\ * equilibrated with scaling factors given by R and C.\n\ * A, AF, and IPIV are not modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AF and factored.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate Transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n\ *\n\ * If FACT = 'F' and EQUED is not 'N', then AB must have been\n\ * equilibrated by the scaling factors in R and/or C. AB is not\n\ * modified if FACT = 'F' or 'N', or if FACT = 'E' and\n\ * EQUED = 'N' on exit.\n\ *\n\ * On exit, if EQUED .ne. 'N', A is scaled as follows:\n\ * EQUED = 'R': A := diag(R) * A\n\ * EQUED = 'C': A := A * diag(C)\n\ * EQUED = 'B': A := diag(R) * A * diag(C).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * AFB (input or output) DOUBLE PRECISION array, dimension (LDAFB,N)\n\ * If FACT = 'F', then AFB is an input argument and on entry\n\ * contains details of the LU factorization of the band matrix\n\ * A, as computed by DGBTRF. U is stored as an upper triangular\n\ * band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n\ * and the multipliers used during the factorization are stored\n\ * in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is\n\ * the factored form of the equilibrated matrix A.\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the factors L and U from the factorization A = P*L*U\n\ * of the original matrix A.\n\ *\n\ * If FACT = 'E', then AF is an output argument and on exit\n\ * returns the factors L and U from the factorization A = P*L*U\n\ * of the equilibrated matrix A (see the description of A for\n\ * the form of the equilibrated matrix).\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * as computed by DGETRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * of the original matrix A.\n\ *\n\ * If FACT = 'E', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * of the equilibrated matrix A.\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * R (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'R' or 'B', A is\n\ * multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n\ * is not accessed. R is an input argument if FACT = 'F';\n\ * otherwise, R is an output argument. If FACT = 'F' and\n\ * EQUED = 'R' or 'B', each element of R must be positive.\n\ * If R is output, each element of R is a power of the radix.\n\ * If R is input, each element of R should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * C (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The column scale factors for A. If EQUED = 'C' or 'B', A is\n\ * multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n\ * is not accessed. C is an input argument if FACT = 'F';\n\ * otherwise, C is an output argument. If FACT = 'F' and\n\ * EQUED = 'C' or 'B', each element of C must be positive.\n\ * If C is output, each element of C is a power of the radix.\n\ * If C is input, each element of C should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit,\n\ * if EQUED = 'N', B is not modified;\n\ * if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n\ * diag(R)*B;\n\ * if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n\ * overwritten by diag(C)*B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * If INFO = 0, the N-by-NRHS solution matrix X to the original\n\ * system of equations. Note that A and B are modified on exit\n\ * if EQUED .ne. 'N', and the solution to the equilibrated system is\n\ * inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n\ * inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * RPVGRW (output) DOUBLE PRECISION\n\ * Reciprocal pivot growth. On exit, this contains the reciprocal\n\ * pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n\ * norm is used. If this is much less than 1, then the stability of\n\ * the LU factorization of the (equilibrated) matrix A could be poor.\n\ * This also means that the solution X, estimated condition numbers,\n\ * and error bounds could be unreliable. If factorization fails with\n\ * 0 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dposv0000644000175000017500000000707412502223526016353 0ustar uwabamiuwabami--- :name: dposv :md5sum: 3bed0f9f43c482181fa639e2e8ece7ae :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPOSV computes the solution to a real system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N symmetric positive definite matrix and X and B\n\ * are N-by-NRHS matrices.\n\ *\n\ * The Cholesky decomposition is used to factor A as\n\ * A = U**T* U, if UPLO = 'U', or\n\ * A = L * L**T, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is a lower triangular\n\ * matrix. The factored form of A is then used to solve the system of\n\ * equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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 leading minor of order i of A is not\n\ * positive definite, so the factorization could not be\n\ * completed, and the solution has not been computed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DPOTRF, DPOTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dorg2l0000644000175000017500000000447512502223526016413 0ustar uwabamiuwabami--- :name: dorg2l :md5sum: 3e5cd2233ef21406983948746d5b6aaf :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - work: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DORG2L generates an m by n real matrix Q with orthonormal columns,\n\ * which is defined as the last n columns of a product of k elementary\n\ * reflectors of order m\n\ *\n\ * Q = H(k) . . . H(2) H(1)\n\ *\n\ * as returned by DGEQLF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. M >= N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. N >= K >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the (n-k+i)-th column must contain the vector which\n\ * defines the elementary reflector H(i), for i = 1,2,...,k, as\n\ * returned by DGEQLF in the last k columns of its array\n\ * argument A.\n\ * On exit, the m by n matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) DOUBLE PRECISION array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by DGEQLF.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/stzrqf0000644000175000017500000000637612502223526016555 0ustar uwabamiuwabami--- :name: stzrqf :md5sum: 3c659a74cdb37ba1b3d0655fa6394118 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE STZRQF( M, N, A, LDA, TAU, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This routine is deprecated and has been replaced by routine STZRZF.\n\ *\n\ * STZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A\n\ * to upper triangular form by means of orthogonal transformations.\n\ *\n\ * The upper trapezoidal matrix A is factored as\n\ *\n\ * A = ( R 0 ) * Z,\n\ *\n\ * where Z is an N-by-N orthogonal matrix and R is an M-by-M upper\n\ * triangular matrix.\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 >= M.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the leading M-by-N upper trapezoidal part of the\n\ * array A must contain the matrix to be factorized.\n\ * On exit, the leading M-by-M upper triangular part of A\n\ * contains the upper triangular matrix R, and elements M+1 to\n\ * N of the first M rows of A, with the array TAU, represent the\n\ * orthogonal matrix Z as a product of M elementary reflectors.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (output) REAL array, dimension (M)\n\ * The scalar factors of the elementary reflectors.\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 factorization is obtained by Householder's method. The kth\n\ * transformation matrix, Z( k ), which is used to introduce zeros into\n\ * the ( m - k + 1 )th row of A, is given in the form\n\ *\n\ * Z( k ) = ( I 0 ),\n\ * ( 0 T( k ) )\n\ *\n\ * where\n\ *\n\ * T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n\ * ( 0 )\n\ * ( z( k ) )\n\ *\n\ * tau is a scalar and z( k ) is an ( n - m ) element vector.\n\ * tau and z( k ) are chosen to annihilate the elements of the kth row\n\ * of X.\n\ *\n\ * The scalar tau is returned in the kth element of TAU and the vector\n\ * u( k ) in the kth row of A, such that the elements of z( k ) are\n\ * in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n\ * the upper triangular part of A.\n\ *\n\ * Z is given by\n\ *\n\ * Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chptri0000644000175000017500000000471112502223525016503 0ustar uwabamiuwabami--- :name: chptri :md5sum: bfa738a7c12419c2627e1a41ebd75c72 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - work: :type: complex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CHPTRI( UPLO, N, AP, IPIV, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHPTRI computes the inverse of a complex Hermitian indefinite matrix\n\ * A in packed storage using the factorization A = U*D*U**H or\n\ * A = L*D*L**H computed by CHPTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**H;\n\ * = 'L': Lower triangular, form is A = L*D*L**H.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n\ * On entry, the block diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L as computed by CHPTRF,\n\ * stored as a packed triangular matrix.\n\ *\n\ * On exit, if INFO = 0, the (Hermitian) inverse of the original\n\ * matrix, stored as a packed triangular matrix. The j-th column\n\ * of inv(A) is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;\n\ * if UPLO = 'L',\n\ * AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by CHPTRF.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (N)\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, D(i,i) = 0; the matrix is singular and its\n\ * inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/claqhb0000644000175000017500000000636212502223525016450 0ustar uwabamiuwabami--- :name: claqhb :md5sum: 3c63a8f4036750b8735047ff5e8b0f0a :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - s: :type: real :intent: output :dims: - n - scond: :type: real :intent: input - amax: :type: real :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CLAQHB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAQHB equilibrates an Hermitian band matrix A using the scaling\n\ * factors in the vector S.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of super-diagonals of the matrix A if UPLO = 'U',\n\ * or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) COMPLEX array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * On exit, if INFO = 0, the triangular factor U or L from the\n\ * Cholesky factorization A = U'*U or A = L*L' of the band\n\ * matrix A, in the same storage format as A.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * S (output) REAL array, dimension (N)\n\ * The scale factors for A.\n\ *\n\ * SCOND (input) REAL\n\ * Ratio of the smallest S(i) to the largest S(i).\n\ *\n\ * AMAX (input) REAL\n\ * Absolute value of largest matrix entry.\n\ *\n\ * EQUED (output) CHARACTER*1\n\ * Specifies whether or not equilibration was done.\n\ * = 'N': No equilibration.\n\ * = 'Y': Equilibration was done, i.e., A has been replaced by\n\ * diag(S) * A * diag(S).\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * THRESH is a threshold value used to decide if scaling should be done\n\ * based on the ratio of the scaling factors. If SCOND < THRESH,\n\ * scaling is done.\n\ *\n\ * LARGE and SMALL are threshold values used to decide if scaling should\n\ * be done based on the absolute size of the largest matrix element.\n\ * If AMAX > LARGE or AMAX < SMALL, scaling is done.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slarzt0000644000175000017500000001222712502223526016533 0ustar uwabamiuwabami--- :name: slarzt :md5sum: 81e19968d00efa646ad24673daeec8db :category: :subroutine :arguments: - direct: :type: char :intent: input - storev: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - v: :type: real :intent: input/output :dims: - ldv - "lsame_(&storev,\"C\") ? k : lsame_(&storev,\"R\") ? n : 0" - ldv: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - t: :type: real :intent: output :dims: - ldt - k - ldt: :type: integer :intent: input :substitutions: ldt: k :fortran_help: " SUBROUTINE SLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLARZT forms the triangular factor T of a real block reflector\n\ * H of order > n, which is defined as a product of k elementary\n\ * reflectors.\n\ *\n\ * If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n\ *\n\ * If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n\ *\n\ * If STOREV = 'C', the vector which defines the elementary reflector\n\ * H(i) is stored in the i-th column of the array V, and\n\ *\n\ * H = I - V * T * V'\n\ *\n\ * If STOREV = 'R', the vector which defines the elementary reflector\n\ * H(i) is stored in the i-th row of the array V, and\n\ *\n\ * H = I - V' * T * V\n\ *\n\ * Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * DIRECT (input) CHARACTER*1\n\ * Specifies the order in which the elementary reflectors are\n\ * multiplied to form the block reflector:\n\ * = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n\ * = 'B': H = H(k) . . . H(2) H(1) (Backward)\n\ *\n\ * STOREV (input) CHARACTER*1\n\ * Specifies how the vectors which define the elementary\n\ * reflectors are stored (see also Further Details):\n\ * = 'C': columnwise (not supported yet)\n\ * = 'R': rowwise\n\ *\n\ * N (input) INTEGER\n\ * The order of the block reflector H. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The order of the triangular factor T (= the number of\n\ * elementary reflectors). K >= 1.\n\ *\n\ * V (input/output) REAL array, dimension\n\ * (LDV,K) if STOREV = 'C'\n\ * (LDV,N) if STOREV = 'R'\n\ * The matrix V. See further details.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V.\n\ * If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n\ *\n\ * TAU (input) REAL array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i).\n\ *\n\ * T (output) REAL array, dimension (LDT,K)\n\ * The k by k triangular factor T of the block reflector.\n\ * If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n\ * lower triangular. The rest of the array is not used.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= K.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * The shape of the matrix V and the storage of the vectors which define\n\ * the H(i) is best illustrated by the following example with n = 5 and\n\ * k = 3. The elements equal to 1 are not stored; the corresponding\n\ * array elements are modified but restored on exit. The rest of the\n\ * array is not used.\n\ *\n\ * DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':\n\ *\n\ * ______V_____\n\ * ( v1 v2 v3 ) / \\\n\ * ( v1 v2 v3 ) ( v1 v1 v1 v1 v1 . . . . 1 )\n\ * V = ( v1 v2 v3 ) ( v2 v2 v2 v2 v2 . . . 1 )\n\ * ( v1 v2 v3 ) ( v3 v3 v3 v3 v3 . . 1 )\n\ * ( v1 v2 v3 )\n\ * . . .\n\ * . . .\n\ * 1 . .\n\ * 1 .\n\ * 1\n\ *\n\ * DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':\n\ *\n\ * ______V_____\n\ * 1 / \\\n\ * . 1 ( 1 . . . . v1 v1 v1 v1 v1 )\n\ * . . 1 ( . 1 . . . v2 v2 v2 v2 v2 )\n\ * . . . ( . . 1 . . v3 v3 v3 v3 v3 )\n\ * . . .\n\ * ( v1 v2 v3 )\n\ * ( v1 v2 v3 )\n\ * V = ( v1 v2 v3 )\n\ * ( v1 v2 v3 )\n\ * ( v1 v2 v3 )\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chetri0000644000175000017500000000505512502223525016472 0ustar uwabamiuwabami--- :name: chetri :md5sum: 4e4e236c2f9985d6b90601dcc470436a :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: complex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CHETRI( UPLO, N, A, LDA, IPIV, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHETRI computes the inverse of a complex Hermitian indefinite matrix\n\ * A using the factorization A = U*D*U**H or A = L*D*L**H computed by\n\ * CHETRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**H;\n\ * = 'L': Lower triangular, form is A = L*D*L**H.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the block diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L as computed by CHETRF.\n\ *\n\ * On exit, if INFO = 0, the (Hermitian) inverse of the original\n\ * matrix. If UPLO = 'U', the upper triangular part of the\n\ * inverse is formed and the part of A below the diagonal is not\n\ * referenced; if UPLO = 'L' the lower triangular part of the\n\ * inverse is formed and the part of A above the diagonal is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by CHETRF.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (N)\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, D(i,i) = 0; the matrix is singular and its\n\ * inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgetrf0000644000175000017500000000453312502223525016466 0ustar uwabamiuwabami--- :name: cgetrf :md5sum: ca5ce5932bcc96bfb579e9e88aabe52b :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGETRF( M, N, A, LDA, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGETRF computes an LU factorization of a general M-by-N matrix A\n\ * using partial pivoting with row interchanges.\n\ *\n\ * The factorization has the form\n\ * A = P * L * U\n\ * where P is a permutation matrix, L is lower triangular with unit\n\ * diagonal elements (lower trapezoidal if m > n), and U is upper\n\ * triangular (upper trapezoidal if m < n).\n\ *\n\ * This is the right-looking Level 3 BLAS version of the algorithm.\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) COMPLEX array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix to be factored.\n\ * On exit, the factors L and U from the factorization\n\ * A = P*L*U; the unit diagonal elements of L are not stored.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * IPIV (output) INTEGER array, dimension (min(M,N))\n\ * The pivot indices; for 1 <= i <= min(M,N), row i of the\n\ * matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, and division by zero will occur if it is used\n\ * to solve a system of equations.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlaqr00000644000175000017500000002160212502223526016374 0ustar uwabamiuwabami--- :name: dlaqr0 :md5sum: be8e4fe92e20cfc56b54b4a1ae53db3d :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: doublereal :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - wr: :type: doublereal :intent: output :dims: - ihi - wi: :type: doublereal :intent: output :dims: - ihi - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: doublereal :intent: input/output :dims: - ldz - ihi - ldz: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAQR0 computes the eigenvalues of a Hessenberg matrix H\n\ * and, optionally, the matrices T and Z from the Schur decomposition\n\ * H = Z T Z**T, where T is an upper quasi-triangular matrix (the\n\ * Schur form), and Z is the orthogonal matrix of Schur vectors.\n\ *\n\ * Optionally Z may be postmultiplied into an input orthogonal\n\ * matrix Q so that this routine can give the Schur factorization\n\ * of a matrix A which has been reduced to the Hessenberg form H\n\ * by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * WANTT (input) LOGICAL\n\ * = .TRUE. : the full Schur form T is required;\n\ * = .FALSE.: only eigenvalues are required.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * = .TRUE. : the matrix of Schur vectors Z is required;\n\ * = .FALSE.: Schur vectors are not required.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H. N .GE. 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * It is assumed that H is already upper triangular in rows\n\ * and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n\ * H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n\ * previous call to DGEBAL, and then passed to DGEHRD when the\n\ * matrix output by DGEBAL is reduced to Hessenberg form.\n\ * Otherwise, ILO and IHI should be set to 1 and N,\n\ * respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n\ * If N = 0, then ILO = 1 and IHI = 0.\n\ *\n\ * H (input/output) DOUBLE PRECISION array, dimension (LDH,N)\n\ * On entry, the upper Hessenberg matrix H.\n\ * On exit, if INFO = 0 and WANTT is .TRUE., then H contains\n\ * the upper quasi-triangular matrix T from the Schur\n\ * decomposition (the Schur form); 2-by-2 diagonal blocks\n\ * (corresponding to complex conjugate pairs of eigenvalues)\n\ * are returned in standard form, with H(i,i) = H(i+1,i+1)\n\ * and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is\n\ * .FALSE., then the contents of H are unspecified on exit.\n\ * (The output value of H when INFO.GT.0 is given under the\n\ * description of INFO below.)\n\ *\n\ * This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n\ * j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n\ *\n\ * LDH (input) INTEGER\n\ * The leading dimension of the array H. LDH .GE. max(1,N).\n\ *\n\ * WR (output) DOUBLE PRECISION array, dimension (IHI)\n\ * WI (output) DOUBLE PRECISION array, dimension (IHI)\n\ * The real and imaginary parts, respectively, of the computed\n\ * eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI)\n\ * and WI(ILO:IHI). If two eigenvalues are computed as a\n\ * complex conjugate pair, they are stored in consecutive\n\ * elements of WR and WI, say the i-th and (i+1)th, with\n\ * WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then\n\ * the eigenvalues are stored in the same order as on the\n\ * diagonal of the Schur form returned in H, with\n\ * WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal\n\ * block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and\n\ * WI(i+1) = -WI(i).\n\ *\n\ * ILOZ (input) INTEGER\n\ * IHIZ (input) INTEGER\n\ * Specify the rows of Z to which transformations must be\n\ * applied if WANTZ is .TRUE..\n\ * 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.\n\ *\n\ * Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI)\n\ * If WANTZ is .FALSE., then Z is not referenced.\n\ * If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n\ * replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n\ * orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n\ * (The output value of Z when INFO.GT.0 is given under\n\ * the description of INFO below.)\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. if WANTZ is .TRUE.\n\ * then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.\n\ *\n\ * WORK (workspace/output) DOUBLE PRECISION array, dimension LWORK\n\ * On exit, if LWORK = -1, WORK(1) returns an estimate of\n\ * the optimal value for LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK .GE. max(1,N)\n\ * is sufficient, but LWORK typically as large as 6*N may\n\ * be required for optimal performance. A workspace query\n\ * to determine the optimal workspace size is recommended.\n\ *\n\ * If LWORK = -1, then DLAQR0 does a workspace query.\n\ * In this case, DLAQR0 checks the input parameters and\n\ * estimates the optimal workspace size for the given\n\ * values of N, ILO and IHI. The estimate is returned\n\ * in WORK(1). No error message related to LWORK is\n\ * issued by XERBLA. Neither H nor Z are accessed.\n\ *\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * .GT. 0: if INFO = i, DLAQR0 failed to compute all of\n\ * the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n\ * and WI contain those eigenvalues which have been\n\ * successfully computed. (Failures are rare.)\n\ *\n\ * If INFO .GT. 0 and WANT is .FALSE., then on exit,\n\ * the remaining unconverged eigenvalues are the eigen-\n\ * values of the upper Hessenberg matrix rows and\n\ * columns ILO through INFO of the final, output\n\ * value of H.\n\ *\n\ * If INFO .GT. 0 and WANTT is .TRUE., then on exit\n\ *\n\ * (*) (initial value of H)*U = U*(final value of H)\n\ *\n\ * where U is an orthogonal matrix. The final\n\ * value of H is upper Hessenberg and quasi-triangular\n\ * in rows and columns INFO+1 through IHI.\n\ *\n\ * If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n\ *\n\ * (final value of Z(ILO:IHI,ILOZ:IHIZ)\n\ * = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n\ *\n\ * where U is the orthogonal matrix in (*) (regard-\n\ * less of the value of WANTT.)\n\ *\n\ * If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n\ * accessed.\n\ *\n\n\ * ================================================================\n\ * Based on contributions by\n\ * Karen Braman and Ralph Byers, Department of Mathematics,\n\ * University of Kansas, USA\n\ *\n\ * ================================================================\n\ * References:\n\ * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n\ * Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n\ * Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n\ * 929--947, 2002.\n\ *\n\ * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n\ * Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n\ * of Matrix Analysis, volume 23, pages 948--973, 2002.\n\ *\n\ * ================================================================\n" ruby-lapack-1.7.2/dev/defs/spbcon0000644000175000017500000000573512502223526016506 0ustar uwabamiuwabami--- :name: spbcon :md5sum: d503557674f04f3c66bdda5c815f8d48 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPBCON estimates the reciprocal of the condition number (in the\n\ * 1-norm) of a real symmetric positive definite band matrix using the\n\ * Cholesky factorization A = U**T*U or A = L*L**T computed by SPBTRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangular factor stored in AB;\n\ * = 'L': Lower triangular factor stored in AB.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input) REAL array, dimension (LDAB,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T of the band matrix A, stored in the\n\ * first KD+1 rows of the array. The j-th column of U or L is\n\ * stored in the j-th column of the array AB as follows:\n\ * if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * ANORM (input) REAL\n\ * The 1-norm (or infinity-norm) of the symmetric band matrix A.\n\ *\n\ * RCOND (output) REAL\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n\ * estimate of the 1-norm of inv(A) computed in this routine.\n\ *\n\ * WORK (workspace) REAL array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctrttp0000644000175000017500000000435712502223525016540 0ustar uwabamiuwabami--- :name: ctrttp :md5sum: ceec2a9ae63238ae23ddc810916fa9fb :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ap: :type: complex :intent: output :dims: - ( n*(n+1)/2 ) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CTRTTP( UPLO, N, A, LDA, AP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTRTTP copies a triangular matrix A from full format (TR) to standard\n\ * packed format (TP).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices AP and A. N >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * On entry, the triangular matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AP (output) COMPLEX array, dimension ( N*(N+1)/2 ),\n\ * On exit, the upper or lower triangular matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slapy30000644000175000017500000000135712502223526016431 0ustar uwabamiuwabami--- :name: slapy3 :md5sum: d5b21d912addf1cf62c52c3a9cc2e387 :category: :function :type: real :arguments: - x: :type: real :intent: input - y: :type: real :intent: input - z: :type: real :intent: input :substitutions: {} :fortran_help: " REAL FUNCTION SLAPY3( X, Y, Z )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause\n\ * unnecessary overflow.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * X (input) REAL\n\ * Y (input) REAL\n\ * Z (input) REAL\n\ * X, Y and Z specify the values x, y and z.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sorgl20000644000175000017500000000435012502223526016422 0ustar uwabamiuwabami--- :name: sorgl2 :md5sum: 5ca4164384b4e139924805aac6960789 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - work: :type: real :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE SORGL2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SORGL2 generates an m by n real matrix Q with orthonormal rows,\n\ * which is defined as the first m rows of a product of k elementary\n\ * reflectors of order n\n\ *\n\ * Q = H(k) . . . H(2) H(1)\n\ *\n\ * as returned by SGELQF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. N >= M.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. M >= K >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the i-th row must contain the vector which defines\n\ * the elementary reflector H(i), for i = 1,2,...,k, as returned\n\ * by SGELQF in the first k rows of its array argument A.\n\ * On exit, the m-by-n matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) REAL array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by SGELQF.\n\ *\n\ * WORK (workspace) REAL array, dimension (M)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zspmv0000644000175000017500000000776512502223526016406 0ustar uwabamiuwabami--- :name: zspmv :md5sum: 99c666f5d7f41498747544b9d29ffc22 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - alpha: :type: doublecomplex :intent: input - ap: :type: doublecomplex :intent: input :dims: - ( n*( n + 1 ) )/2 - x: :type: doublecomplex :intent: input :dims: - 1 + ( n - 1 )*abs( incx ) - incx: :type: integer :intent: input - beta: :type: doublecomplex :intent: input - y: :type: doublecomplex :intent: input/output :dims: - 1 + ( n - 1 )*abs( incy ) - incy: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE ZSPMV( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSPMV performs the matrix-vector operation\n\ *\n\ * y := alpha*A*x + beta*y,\n\ *\n\ * where alpha and beta are scalars, x and y are n element vectors and\n\ * A is an n by n symmetric matrix, supplied in packed form.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * On entry, UPLO specifies whether the upper or lower\n\ * triangular part of the matrix A is supplied in the packed\n\ * array AP as follows:\n\ *\n\ * UPLO = 'U' or 'u' The upper triangular part of A is\n\ * supplied in AP.\n\ *\n\ * UPLO = 'L' or 'l' The lower triangular part of A is\n\ * supplied in AP.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the order of the matrix A.\n\ * N must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * ALPHA (input) COMPLEX*16\n\ * On entry, ALPHA specifies the scalar alpha.\n\ * Unchanged on exit.\n\ *\n\ * AP (input) COMPLEX*16 array, dimension at least\n\ * ( ( N*( N + 1 ) )/2 ).\n\ * Before entry, with UPLO = 'U' or 'u', the array AP must\n\ * contain the upper triangular part of the symmetric matrix\n\ * packed sequentially, column by column, so that AP( 1 )\n\ * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )\n\ * and a( 2, 2 ) respectively, and so on.\n\ * Before entry, with UPLO = 'L' or 'l', the array AP must\n\ * contain the lower triangular part of the symmetric matrix\n\ * packed sequentially, column by column, so that AP( 1 )\n\ * contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )\n\ * and a( 3, 1 ) respectively, and so on.\n\ * Unchanged on exit.\n\ *\n\ * X (input) COMPLEX*16 array, dimension at least\n\ * ( 1 + ( N - 1 )*abs( INCX ) ).\n\ * Before entry, the incremented array X must contain the N-\n\ * element vector x.\n\ * Unchanged on exit.\n\ *\n\ * INCX (input) INTEGER\n\ * On entry, INCX specifies the increment for the elements of\n\ * X. INCX must not be zero.\n\ * Unchanged on exit.\n\ *\n\ * BETA (input) COMPLEX*16\n\ * On entry, BETA specifies the scalar beta. When BETA is\n\ * supplied as zero then Y need not be set on input.\n\ * Unchanged on exit.\n\ *\n\ * Y (input/output) COMPLEX*16 array, dimension at least\n\ * ( 1 + ( N - 1 )*abs( INCY ) ).\n\ * Before entry, the incremented array Y must contain the n\n\ * element vector y. On exit, Y is overwritten by the updated\n\ * vector y.\n\ *\n\ * INCY (input) INTEGER\n\ * On entry, INCY specifies the increment for the elements of\n\ * Y. INCY must not be zero.\n\ * Unchanged on exit.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sorcsd0000644000175000017500000001707112502223526016513 0ustar uwabamiuwabami--- :name: sorcsd :md5sum: 461218dc9a0e1a649087e4b8c78709c7 :category: :subroutine :arguments: - jobu1: :type: char :intent: input - jobu2: :type: char :intent: input - jobv1t: :type: char :intent: input - jobv2t: :type: char :intent: input - trans: :type: char :intent: input - signs: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - q: :type: integer :intent: input - x11: :type: real :intent: input :dims: - ldx11 - q - ldx11: :type: integer :intent: input - x12: :type: real :intent: input :dims: - ldx12 - m-q - ldx12: :type: integer :intent: input - x21: :type: real :intent: input :dims: - ldx21 - q - ldx21: :type: integer :intent: input - x22: :type: real :intent: input :dims: - ldx22 - m-q - ldx22: :type: integer :intent: input - theta: :type: real :intent: output :dims: - MIN(MIN(MIN(p,m-p),q),m-q) - u1: :type: real :intent: output :dims: - p - ldu1: :type: integer :intent: input - u2: :type: real :intent: output :dims: - m-p - ldu2: :type: integer :intent: input - v1t: :type: real :intent: output :dims: - q - ldv1t: :type: integer :intent: input - v2t: :type: real :intent: output :dims: - m-q - ldv2t: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - iwork: :type: integer :intent: workspace :dims: - m-q - info: :type: integer :intent: output :substitutions: ldv2t: "lsame_(&jobv2t,\"Y\") ? MAX(1,m-q) : 0" ldv1t: "lsame_(&jobv1t,\"Y\") ? MAX(1,q) : 0" ldu1: "lsame_(&jobu1,\"Y\") ? MAX(1,p) : 0" ldu2: "lsame_(&jobu2,\"Y\") ? MAX(1,m-p) : 0" p: ldx11 ldx12: p ldx21: p ldx22: p :fortran_help: " RECURSIVE SUBROUTINE SORCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, WORK, LWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SORCSD computes the CS decomposition of an M-by-M partitioned\n\ * orthogonal matrix X:\n\ *\n\ * [ I 0 0 | 0 0 0 ]\n\ * [ 0 C 0 | 0 -S 0 ]\n\ * [ X11 | X12 ] [ U1 | ] [ 0 0 0 | 0 0 -I ] [ V1 | ]**T\n\ * X = [-----------] = [---------] [---------------------] [---------] .\n\ * [ X21 | X22 ] [ | U2 ] [ 0 0 0 | I 0 0 ] [ | V2 ]\n\ * [ 0 S 0 | 0 C 0 ]\n\ * [ 0 0 I | 0 0 0 ]\n\ *\n\ * X11 is P-by-Q. The orthogonal matrices U1, U2, V1, and V2 are P-by-P,\n\ * (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are\n\ * R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in\n\ * which R = MIN(P,M-P,Q,M-Q).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBU1 (input) CHARACTER\n\ * = 'Y': U1 is computed;\n\ * otherwise: U1 is not computed.\n\ *\n\ * JOBU2 (input) CHARACTER\n\ * = 'Y': U2 is computed;\n\ * otherwise: U2 is not computed.\n\ *\n\ * JOBV1T (input) CHARACTER\n\ * = 'Y': V1T is computed;\n\ * otherwise: V1T is not computed.\n\ *\n\ * JOBV2T (input) CHARACTER\n\ * = 'Y': V2T is computed;\n\ * otherwise: V2T is not computed.\n\ *\n\ * TRANS (input) CHARACTER\n\ * = 'T': X, U1, U2, V1T, and V2T are stored in row-major\n\ * order;\n\ * otherwise: X, U1, U2, V1T, and V2T are stored in column-\n\ * major order.\n\ *\n\ * SIGNS (input) CHARACTER\n\ * = 'O': The lower-left block is made nonpositive (the\n\ * \"other\" convention);\n\ * otherwise: The upper-right block is made nonpositive (the\n\ * \"default\" convention).\n\ *\n\ * M (input) INTEGER\n\ * The number of rows and columns in X.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows in X11 and X12. 0 <= P <= M.\n\ *\n\ * Q (input) INTEGER\n\ * The number of columns in X11 and X21. 0 <= Q <= M.\n\ *\n\ * X (input/workspace) REAL array, dimension (LDX,M)\n\ * On entry, the orthogonal matrix whose CSD is desired.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of X. LDX >= MAX(1,M).\n\ *\n\ * THETA (output) REAL array, dimension (R), in which R =\n\ * MIN(P,M-P,Q,M-Q).\n\ * C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and\n\ * S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).\n\ *\n\ * U1 (output) REAL array, dimension (P)\n\ * If JOBU1 = 'Y', U1 contains the P-by-P orthogonal matrix U1.\n\ *\n\ * LDU1 (input) INTEGER\n\ * The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=\n\ * MAX(1,P).\n\ *\n\ * U2 (output) REAL array, dimension (M-P)\n\ * If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) orthogonal\n\ * matrix U2.\n\ *\n\ * LDU2 (input) INTEGER\n\ * The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=\n\ * MAX(1,M-P).\n\ *\n\ * V1T (output) REAL array, dimension (Q)\n\ * If JOBV1T = 'Y', V1T contains the Q-by-Q matrix orthogonal\n\ * matrix V1**T.\n\ *\n\ * LDV1T (input) INTEGER\n\ * The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=\n\ * MAX(1,Q).\n\ *\n\ * V2T (output) REAL array, dimension (M-Q)\n\ * If JOBV2T = 'Y', V2T contains the (M-Q)-by-(M-Q) orthogonal\n\ * matrix V2**T.\n\ *\n\ * LDV2T (input) INTEGER\n\ * The leading dimension of V2T. If JOBV2T = 'Y', LDV2T >=\n\ * MAX(1,M-Q).\n\ *\n\ * WORK (workspace) REAL array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ * If INFO > 0 on exit, WORK(2:R) contains the values PHI(1),\n\ * ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),\n\ * define the matrix in intermediate bidiagonal-block form\n\ * remaining after nonconvergence. INFO specifies the number\n\ * of nonzero PHI's.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK.\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\ * IWORK (workspace) INTEGER array, dimension (M-Q)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit.\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * > 0: SBBCSD did not converge. See the description of WORK\n\ * above for details.\n\ *\n\ * Reference\n\ * =========\n\ *\n\ * [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.\n\ * Algorithms, 50(1):33-65, 2009.\n\ *\n\n\ * ===================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zungrq0000644000175000017500000000575112502223526016546 0ustar uwabamiuwabami--- :name: zungrq :md5sum: 508241447b80f0014a07bd49196f1875 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZUNGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZUNGRQ generates an M-by-N complex matrix Q with orthonormal rows,\n\ * which is defined as the last M rows of a product of K elementary\n\ * reflectors of order N\n\ *\n\ * Q = H(1)' H(2)' . . . H(k)'\n\ *\n\ * as returned by ZGERQF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. N >= M.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. M >= K >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the (m-k+i)-th row must contain the vector which\n\ * defines the elementary reflector H(i), for i = 1,2,...,k, as\n\ * returned by ZGERQF in the last k rows of its array argument\n\ * A.\n\ * On exit, the M-by-N matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) COMPLEX*16 array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by ZGERQF.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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 has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cla_geamv0000644000175000017500000001130512502223525017125 0ustar uwabamiuwabami--- :name: cla_geamv :md5sum: 03b3c0c36a18cc3eacd0b6c465971c1e :category: :subroutine :arguments: - trans: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: real :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: complex :intent: input :dims: - "trans == ilatrans_(\"N\") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )" - incx: :type: integer :intent: input - beta: :type: real :intent: input - y: :type: real :intent: input/output :dims: - "trans == ilatrans_(\"N\") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )" - incy: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE CLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLA_GEAMV performs one of the matrix-vector operations\n\ *\n\ * y := alpha*abs(A)*abs(x) + beta*abs(y),\n\ * or y := alpha*abs(A)'*abs(x) + beta*abs(y),\n\ *\n\ * where alpha and beta are scalars, x and y are vectors and A is an\n\ * m by n matrix.\n\ *\n\ * This function is primarily used in calculating error bounds.\n\ * To protect against underflow during evaluation, components in\n\ * the resulting vector are perturbed away from zero by (N+1)\n\ * times the underflow threshold. To prevent unnecessarily large\n\ * errors for block-structure embedded in general matrices,\n\ * \"symbolically\" zero components are not perturbed. A zero\n\ * entry is considered \"symbolic\" if all multiplications involved\n\ * in computing that entry have at least one zero multiplicand.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * TRANS (input) INTEGER\n\ * On entry, TRANS specifies the operation to be performed as\n\ * follows:\n\ *\n\ * BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y)\n\ * BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n\ * BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n\ *\n\ * Unchanged on exit.\n\ *\n\ * M (input) INTEGER\n\ * On entry, M specifies the number of rows of the matrix A.\n\ * M must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the number of columns of the matrix A.\n\ * N must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * ALPHA (input) REAL\n\ * On entry, ALPHA specifies the scalar alpha.\n\ * Unchanged on exit.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,n)\n\ * Before entry, the leading m by n part of the array A must\n\ * contain the matrix of coefficients.\n\ * Unchanged on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * On entry, LDA specifies the first dimension of A as declared\n\ * in the calling (sub) program. LDA must be at least\n\ * max( 1, m ).\n\ * Unchanged on exit.\n\ *\n\ * X (input) COMPLEX array, dimension\n\ * ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n\ * and at least\n\ * ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n\ * Before entry, the incremented array X must contain the\n\ * vector x.\n\ * Unchanged on exit.\n\ *\n\ * INCX (input) INTEGER\n\ * On entry, INCX specifies the increment for the elements of\n\ * X. INCX must not be zero.\n\ * Unchanged on exit.\n\ *\n\ * BETA (input) REAL\n\ * On entry, BETA specifies the scalar beta. When BETA is\n\ * supplied as zero then Y need not be set on input.\n\ * Unchanged on exit.\n\ *\n\ * Y (input/output) REAL array, dimension\n\ * ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n\ * and at least\n\ * ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n\ * Before entry with BETA non-zero, the incremented array Y\n\ * must contain the vector y. On exit, Y is overwritten by the\n\ * updated vector y.\n\ *\n\ * INCY (input) INTEGER\n\ * On entry, INCY specifies the increment for the elements of\n\ * Y. INCY must not be zero.\n\ * Unchanged on exit.\n\ *\n\ *\n\ * Level 2 Blas routine.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zla_hercond_x0000644000175000017500000000656412502223526020042 0ustar uwabamiuwabami--- :name: zla_hercond_x :md5sum: ccd25c75038fb2a611096e4c99c03ee3 :category: :function :type: doublereal :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - x: :type: doublecomplex :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: doublecomplex :intent: input :dims: - 2*n - rwork: :type: doublereal :intent: input :dims: - n :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION ZLA_HERCOND_X( UPLO, N, A, LDA, AF, LDAF, IPIV, X, INFO, WORK, RWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLA_HERCOND_X computes the infinity norm condition number of\n\ * op(A) * diag(X) where X is a COMPLEX*16 vector.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX*16 array, dimension (LDAF,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by ZHETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by CHETRF.\n\ *\n\ * X (input) COMPLEX*16 array, dimension (N)\n\ * The vector X in the formula op(A) * diag(X).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * i > 0: The ith argument is invalid.\n\ *\n\ * WORK (input) COMPLEX*16 array, dimension (2*N).\n\ * Workspace.\n\ *\n\ * RWORK (input) DOUBLE PRECISION array, dimension (N).\n\ * Workspace.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER KASE, I, J\n DOUBLE PRECISION AINVNM, ANORM, TMP\n LOGICAL UP\n COMPLEX*16 ZDUM\n\ * ..\n\ * .. Local Arrays ..\n INTEGER ISAVE( 3 )\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL ZLACN2, ZHETRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n\ * ..\n\ * .. Statement Functions ..\n DOUBLE PRECISION CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dorgql0000644000175000017500000000577512502223526016516 0ustar uwabamiuwabami--- :name: dorgql :md5sum: 94580030c4ac4cba48c074ae5fc70b8d :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DORGQL generates an M-by-N real matrix Q with orthonormal columns,\n\ * which is defined as the last N columns of a product of K elementary\n\ * reflectors of order M\n\ *\n\ * Q = H(k) . . . H(2) H(1)\n\ *\n\ * as returned by DGEQLF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. M >= N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. N >= K >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the (n-k+i)-th column must contain the vector which\n\ * defines the elementary reflector H(i), for i = 1,2,...,k, as\n\ * returned by DGEQLF in the last k columns of its array\n\ * argument A.\n\ * On exit, the M-by-N matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) DOUBLE PRECISION array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by DGEQLF.\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,N).\n\ * For optimum performance LWORK >= N*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 has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssfrk0000644000175000017500000001011212502223526016333 0ustar uwabamiuwabami--- :name: ssfrk :md5sum: 5b5f4cafc518b82b9b7304e9cd5c0721 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - alpha: :type: real :intent: input - a: :type: real :intent: input :dims: - lda - "(lsame_(&trans,\"N\") || lsame_(&trans,\"n\")) ? k : n" - lda: :type: integer :intent: input - beta: :type: real :intent: input - c: :type: real :intent: input/output :dims: - nt :substitutions: {} :fortran_help: " SUBROUTINE SSFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Level 3 BLAS like routine for C in RFP Format.\n\ *\n\ * SSFRK performs one of the symmetric rank--k operations\n\ *\n\ * C := alpha*A*A' + beta*C,\n\ *\n\ * or\n\ *\n\ * C := alpha*A'*A + beta*C,\n\ *\n\ * where alpha and beta are real scalars, C is an n--by--n symmetric\n\ * matrix and A is an n--by--k matrix in the first case and a k--by--n\n\ * matrix in the second case.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': The Normal Form of RFP A is stored;\n\ * = 'T': The Transpose Form of RFP A is stored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * On entry, UPLO specifies whether the upper or lower\n\ * triangular part of the array C is to be referenced as\n\ * follows:\n\ *\n\ * UPLO = 'U' or 'u' Only the upper triangular part of C\n\ * is to be referenced.\n\ *\n\ * UPLO = 'L' or 'l' Only the lower triangular part of C\n\ * is to be referenced.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * On entry, TRANS specifies the operation to be performed as\n\ * follows:\n\ *\n\ * TRANS = 'N' or 'n' C := alpha*A*A' + beta*C.\n\ *\n\ * TRANS = 'T' or 't' C := alpha*A'*A + beta*C.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the order of the matrix C. N must be\n\ * at least zero.\n\ * Unchanged on exit.\n\ *\n\ * K (input) INTEGER\n\ * On entry with TRANS = 'N' or 'n', K specifies the number\n\ * of columns of the matrix A, and on entry with TRANS = 'T'\n\ * or 't', K specifies the number of rows of the matrix A. K\n\ * must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * ALPHA (input) REAL\n\ * On entry, ALPHA specifies the scalar alpha.\n\ * Unchanged on exit.\n\ *\n\ * A (input) REAL array of DIMENSION (LDA,ka)\n\ * where KA\n\ * is K when TRANS = 'N' or 'n', and is N otherwise. Before\n\ * entry with TRANS = 'N' or 'n', the leading N--by--K part of\n\ * the array A must contain the matrix A, otherwise the leading\n\ * K--by--N part of the array A must contain the matrix A.\n\ * Unchanged on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * On entry, LDA specifies the first dimension of A as declared\n\ * in the calling (sub) program. When TRANS = 'N' or 'n'\n\ * then LDA must be at least max( 1, n ), otherwise LDA must\n\ * be at least max( 1, k ).\n\ * Unchanged on exit.\n\ *\n\ * BETA (input) REAL\n\ * On entry, BETA specifies the scalar beta.\n\ * Unchanged on exit.\n\ *\n\ *\n\ * C (input/output) REAL array, dimension (NT)\n\ * NT = N*(N+1)/2. On entry, the symmetric matrix C in RFP\n\ * Format. RFP Format is described by TRANSR, UPLO and N.\n\ *\n\ * Arguments\n\ * ==========\n\ *\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cstegr0000644000175000017500000002055412502223525016504 0ustar uwabamiuwabami--- :name: cstegr :md5sum: d6dab7dc05d3eff31201f84ab530e5d5 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 18*n : lsame_(&jobz,\"N\") ? 12*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 10*n : lsame_(&jobz,\"N\") ? 8*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " SUBROUTINE CSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSTEGR computes selected eigenvalues and, optionally, eigenvectors\n\ * of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n\ * a well defined set of pairwise different real eigenvalues, the corresponding\n\ * real eigenvectors are pairwise orthogonal.\n\ *\n\ * The spectrum may be computed either completely or partially by specifying\n\ * either an interval (VL,VU] or a range of indices IL:IU for the desired\n\ * eigenvalues.\n\ *\n\ * CSTEGR is a compatability wrapper around the improved CSTEMR routine.\n\ * See SSTEMR for further details.\n\ *\n\ * One important change is that the ABSTOL parameter no longer provides any\n\ * benefit and hence is no longer used.\n\ *\n\ * Note : CSTEGR and CSTEMR work only on machines which follow\n\ * IEEE-754 floating-point standard in their handling of infinities and\n\ * NaNs. Normal execution may create these exceptiona values and hence\n\ * may abort due to a floating point exception in environments which\n\ * do not conform to the IEEE-754 standard.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found.\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found.\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the N diagonal elements of the tridiagonal matrix\n\ * T. On exit, D is overwritten.\n\ *\n\ * E (input/output) REAL array, dimension (N)\n\ * On entry, the (N-1) subdiagonal elements of the tridiagonal\n\ * matrix T in elements 1 to N-1 of E. E(N) need not be set on\n\ * input, but is used internally as workspace.\n\ * On exit, E is overwritten.\n\ *\n\ * VL (input) REAL\n\ * VU (input) REAL\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) REAL\n\ * Unused. Was the absolute error tolerance for the\n\ * eigenvalues/eigenvectors in previous versions.\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * The first M elements contain the selected eigenvalues in\n\ * ascending order.\n\ *\n\ * Z (output) COMPLEX array, dimension (LDZ, max(1,M) )\n\ * If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix T\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ * Supplying N columns is always safe.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', then LDZ >= max(1,N).\n\ *\n\ * ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n\ * The support of the eigenvectors in Z, i.e., the indices\n\ * indicating the nonzero elements in Z. The i-th computed eigenvector\n\ * is nonzero only in elements ISUPPZ( 2*i-1 ) through\n\ * ISUPPZ( 2*i ). This is relevant in the case when the matrix\n\ * is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n\ *\n\ * WORK (workspace/output) REAL array, dimension (LWORK)\n\ * On exit, if INFO = 0, WORK(1) returns the optimal\n\ * (and minimal) LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK >= max(1,18*N)\n\ * if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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\ * IWORK (workspace/output) INTEGER array, dimension (LIWORK)\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK. LIWORK >= max(1,10*N)\n\ * if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n\ * if only the eigenvalues are to be computed.\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal size of the IWORK array,\n\ * returns this value as the first entry of the IWORK array, and\n\ * no error message related to LIWORK is issued by XERBLA.\n\ *\n\ * INFO (output) INTEGER\n\ * On exit, INFO\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: if INFO = 1X, internal error in SLARRE,\n\ * if INFO = 2X, internal error in CLARRV.\n\ * Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n\ * the nonzero error code returned by SLARRE or\n\ * CLARRV, respectively.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Inderjit Dhillon, IBM Almaden, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, LBNL/NERSC, USA\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL TRYRAC\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CSTEMR\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/clapmr0000644000175000017500000000401112502223525016461 0ustar uwabamiuwabami--- :name: clapmr :md5sum: 4d207b45c2fb96e99248c500f5cadba8 :category: :subroutine :arguments: - forwrd: :type: logical :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input - k: :type: integer :intent: input/output :dims: - m :substitutions: {} :fortran_help: " SUBROUTINE CLAPMR( FORWRD, M, N, X, LDX, K )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAPMR rearranges the rows of the M by N matrix X as specified\n\ * by the permutation K(1),K(2),...,K(M) of the integers 1,...,M.\n\ * If FORWRD = .TRUE., forward permutation:\n\ *\n\ * X(K(I),*) is moved X(I,*) for I = 1,2,...,M.\n\ *\n\ * If FORWRD = .FALSE., backward permutation:\n\ *\n\ * X(I,*) is moved to X(K(I),*) for I = 1,2,...,M.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FORWRD (input) LOGICAL\n\ * = .TRUE., forward permutation\n\ * = .FALSE., backward permutation\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix X. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix X. N >= 0.\n\ *\n\ * X (input/output) COMPLEX array, dimension (LDX,N)\n\ * On entry, the M by N matrix X.\n\ * On exit, X contains the permuted matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X, LDX >= MAX(1,M).\n\ *\n\ * K (input/output) INTEGER array, dimension (M)\n\ * On entry, K contains the permutation vector. K is used as\n\ * internal workspace, but reset to its original value on\n\ * output.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, IN, J, JJ\n COMPLEX TEMP\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slasda0000644000175000017500000002203212502223526016456 0ustar uwabamiuwabami--- :name: slasda :md5sum: 7c5ff4bd16f613b9c5debfba98900d97 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - smlsiz: :type: integer :intent: input - n: :type: integer :intent: input - sqre: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input :dims: - m-1 - u: :type: real :intent: output :dims: - ldu - MAX(1,smlsiz) - ldu: :type: integer :intent: input - vt: :type: real :intent: output :dims: - ldu - smlsiz+1 - k: :type: integer :intent: output :dims: - "icompq == 1 ? n : icompq == 0 ? 1 : 0" - difl: :type: real :intent: output :dims: - ldu - nlvl - difr: :type: real :intent: output :dims: - "icompq == 1 ? ldu : icompq == 0 ? n : 0" - "icompq == 1 ? 2 * nlvl : 0" - z: :type: real :intent: output :dims: - "icompq == 1 ? ldu : icompq == 0 ? n : 0" - "icompq == 1 ? nlvl : 0" - poles: :type: real :intent: output :dims: - ldu - 2 * nlvl - givptr: :type: integer :intent: output :dims: - n - givcol: :type: integer :intent: output :dims: - ldgcol - 2 * nlvl - ldgcol: :type: integer :intent: input - perm: :type: integer :intent: output :dims: - ldgcol - nlvl - givnum: :type: real :intent: output :dims: - ldu - 2 * nlvl - c: :type: real :intent: output :dims: - "icompq == 1 ? n : icompq == 0 ? 1 : 0" - s: :type: real :intent: output :dims: - "icompq==1 ? n : icompq==0 ? 1 : 0" - work: :type: real :intent: workspace :dims: - 6 * n + (smlsiz + 1)*(smlsiz + 1) - iwork: :type: integer :intent: workspace :dims: - 7*n - info: :type: integer :intent: output :substitutions: m: "sqre == 0 ? n : sqre == 1 ? n+1 : 0" ldu: n nlvl: floor(1.0/log(2.0)*log((double)n/smlsiz)) ldgcol: n :fortran_help: " SUBROUTINE SLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Using a divide and conquer approach, SLASDA computes the singular\n\ * value decomposition (SVD) of a real upper bidiagonal N-by-M matrix\n\ * B with diagonal D and offdiagonal E, where M = N + SQRE. The\n\ * algorithm computes the singular values in the SVD B = U * S * VT.\n\ * The orthogonal matrices U and VT are optionally computed in\n\ * compact form.\n\ *\n\ * A related subroutine, SLASD0, computes the singular values and\n\ * the singular vectors in explicit form.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ICOMPQ (input) INTEGER\n\ * Specifies whether singular vectors are to be computed\n\ * in compact form, as follows\n\ * = 0: Compute singular values only.\n\ * = 1: Compute singular vectors of upper bidiagonal\n\ * matrix in compact form.\n\ *\n\ * SMLSIZ (input) INTEGER\n\ * The maximum size of the subproblems at the bottom of the\n\ * computation tree.\n\ *\n\ * N (input) INTEGER\n\ * The row dimension of the upper bidiagonal matrix. This is\n\ * also the dimension of the main diagonal array D.\n\ *\n\ * SQRE (input) INTEGER\n\ * Specifies the column dimension of the bidiagonal matrix.\n\ * = 0: The bidiagonal matrix has column dimension M = N;\n\ * = 1: The bidiagonal matrix has column dimension M = N + 1.\n\ *\n\ * D (input/output) REAL array, dimension ( N )\n\ * On entry D contains the main diagonal of the bidiagonal\n\ * matrix. On exit D, if INFO = 0, contains its singular values.\n\ *\n\ * E (input) REAL array, dimension ( M-1 )\n\ * Contains the subdiagonal entries of the bidiagonal matrix.\n\ * On exit, E has been destroyed.\n\ *\n\ * U (output) REAL array,\n\ * dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced\n\ * if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left\n\ * singular vector matrices of all subproblems at the bottom\n\ * level.\n\ *\n\ * LDU (input) INTEGER, LDU = > N.\n\ * The leading dimension of arrays U, VT, DIFL, DIFR, POLES,\n\ * GIVNUM, and Z.\n\ *\n\ * VT (output) REAL array,\n\ * dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced\n\ * if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT' contains the right\n\ * singular vector matrices of all subproblems at the bottom\n\ * level.\n\ *\n\ * K (output) INTEGER array, dimension ( N ) \n\ * if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0.\n\ * If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th\n\ * secular equation on the computation tree.\n\ *\n\ * DIFL (output) REAL array, dimension ( LDU, NLVL ),\n\ * where NLVL = floor(log_2 (N/SMLSIZ))).\n\ *\n\ * DIFR (output) REAL array,\n\ * dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and\n\ * dimension ( N ) if ICOMPQ = 0.\n\ * If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1)\n\ * record distances between singular values on the I-th\n\ * level and singular values on the (I -1)-th level, and\n\ * DIFR(1:N, 2 * I ) contains the normalizing factors for\n\ * the right singular vector matrix. See SLASD8 for details.\n\ *\n\ * Z (output) REAL array,\n\ * dimension ( LDU, NLVL ) if ICOMPQ = 1 and\n\ * dimension ( N ) if ICOMPQ = 0.\n\ * The first K elements of Z(1, I) contain the components of\n\ * the deflation-adjusted updating row vector for subproblems\n\ * on the I-th level.\n\ *\n\ * POLES (output) REAL array,\n\ * dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced\n\ * if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and\n\ * POLES(1, 2*I) contain the new and old singular values\n\ * involved in the secular equations on the I-th level.\n\ *\n\ * GIVPTR (output) INTEGER array,\n\ * dimension ( N ) if ICOMPQ = 1, and not referenced if\n\ * ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records\n\ * the number of Givens rotations performed on the I-th\n\ * problem on the computation tree.\n\ *\n\ * GIVCOL (output) INTEGER array,\n\ * dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not\n\ * referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,\n\ * GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations\n\ * of Givens rotations performed on the I-th level on the\n\ * computation tree.\n\ *\n\ * LDGCOL (input) INTEGER, LDGCOL = > N.\n\ * The leading dimension of arrays GIVCOL and PERM.\n\ *\n\ * PERM (output) INTEGER array, dimension ( LDGCOL, NLVL ) \n\ * if ICOMPQ = 1, and not referenced\n\ * if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records\n\ * permutations done on the I-th level of the computation tree.\n\ *\n\ * GIVNUM (output) REAL array,\n\ * dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not\n\ * referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,\n\ * GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S-\n\ * values of Givens rotations performed on the I-th level on\n\ * the computation tree.\n\ *\n\ * C (output) REAL array,\n\ * dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0.\n\ * If ICOMPQ = 1 and the I-th subproblem is not square, on exit,\n\ * C( I ) contains the C-value of a Givens rotation related to\n\ * the right null space of the I-th subproblem.\n\ *\n\ * S (output) REAL array, dimension ( N ) if\n\ * ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1\n\ * and the I-th subproblem is not square, on exit, S( I )\n\ * contains the S-value of a Givens rotation related to\n\ * the right null space of the I-th subproblem.\n\ *\n\ * WORK (workspace) REAL array, dimension\n\ * (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)).\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (7*N).\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 = 1, a singular value did not converge\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ming Gu and Huan Ren, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlaqp20000644000175000017500000000676012502223526016404 0ustar uwabamiuwabami--- :name: dlaqp2 :md5sum: 164cf40c4a8b2b2a7c734e7cadfbff68 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - offset: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: doublereal :intent: output :dims: - MIN(m,n) - vn1: :type: doublereal :intent: input/output :dims: - n - vn2: :type: doublereal :intent: input/output :dims: - n - work: :type: doublereal :intent: workspace :dims: - n :substitutions: {} :fortran_help: " SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAQP2 computes a QR factorization with column pivoting of\n\ * the block A(OFFSET+1:M,1:N).\n\ * The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\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\ * OFFSET (input) INTEGER\n\ * The number of rows of the matrix A that must be pivoted\n\ * but no factorized. OFFSET >= 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 upper triangle of block A(OFFSET+1:M,1:N) is \n\ * the triangular factor obtained; the elements in block\n\ * A(OFFSET+1:M,1:N) below the diagonal, together with the\n\ * array TAU, represent the orthogonal matrix Q as a product of\n\ * elementary reflectors. Block A(1:OFFSET,1:N) has been\n\ * accordingly pivoted, but no factorized.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * JPVT (input/output) INTEGER array, dimension (N)\n\ * On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n\ * to the front of A*P (a leading column); if JPVT(i) = 0,\n\ * the i-th column of A is a free column.\n\ * On exit, if JPVT(i) = k, then the i-th column of A*P\n\ * was the k-th column of A.\n\ *\n\ * TAU (output) DOUBLE PRECISION array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors.\n\ *\n\ * VN1 (input/output) DOUBLE PRECISION array, dimension (N)\n\ * The vector with the partial column norms.\n\ *\n\ * VN2 (input/output) DOUBLE PRECISION array, dimension (N)\n\ * The vector with the exact column norms.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (N)\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n\ * X. Sun, Computer Science Dept., Duke University, USA\n\ *\n\ * Partial column norm updating strategy modified by\n\ * Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n\ * University of Zagreb, Croatia.\n\ * June 2010\n\ * For more details see LAPACK Working Note 176.\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cpptrf0000644000175000017500000000516012502223525016507 0ustar uwabamiuwabami--- :name: cpptrf :md5sum: 0535cb122052f3009f316946a454aecc :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPPTRF( UPLO, N, AP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPPTRF computes the Cholesky factorization of a complex Hermitian\n\ * positive definite matrix A stored in packed format.\n\ *\n\ * The factorization has the form\n\ * A = U**H * U, if UPLO = 'U', or\n\ * A = L * L**H, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is lower triangular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ * See below for further details.\n\ *\n\ * On exit, if INFO = 0, the triangular factor U or L from the\n\ * Cholesky factorization A = U**H*U or A = L*L**H, in the same\n\ * storage format as A.\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 leading minor of order i is not\n\ * positive definite, and the factorization could not be\n\ * completed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The packed storage scheme is illustrated by the following example\n\ * when N = 4, UPLO = 'U':\n\ *\n\ * Two-dimensional storage of the Hermitian matrix A:\n\ *\n\ * a11 a12 a13 a14\n\ * a22 a23 a24\n\ * a33 a34 (aij = conjg(aji))\n\ * a44\n\ *\n\ * Packed storage of the upper triangle of A:\n\ *\n\ * AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cpbtrf0000644000175000017500000000675212502223525016501 0ustar uwabamiuwabami--- :name: cpbtrf :md5sum: 366ae9ae1c36282a8bfb40561c1d99cf :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPBTRF( UPLO, N, KD, AB, LDAB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPBTRF computes the Cholesky factorization of a complex Hermitian\n\ * positive definite band matrix A.\n\ *\n\ * The factorization has the form\n\ * A = U**H * U, if UPLO = 'U', or\n\ * A = L * L**H, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is lower triangular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) COMPLEX array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * On exit, if INFO = 0, the triangular factor U or L from the\n\ * Cholesky factorization A = U**H*U or A = L*L**H of the band\n\ * matrix A, in the same storage format as A.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\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 leading minor of order i is not\n\ * positive definite, and the factorization could not be\n\ * completed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * N = 6, KD = 2, and UPLO = 'U':\n\ *\n\ * On entry: On exit:\n\ *\n\ * * * a13 a24 a35 a46 * * u13 u24 u35 u46\n\ * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n\ * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n\ *\n\ * Similarly, if UPLO = 'L' the format of A is as follows:\n\ *\n\ * On entry: On exit:\n\ *\n\ * a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n\ * a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n\ * a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n\ *\n\ * Array elements marked * are not used by the routine.\n\ *\n\ * Contributed by\n\ * Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsysvxx0000644000175000017500000005156112502223526016750 0ustar uwabamiuwabami--- :name: dsysvxx :md5sum: 273b48af0574d8f9d7fb1975f97dcdc9 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - equed: :type: char :intent: input/output - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - rpvgrw: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublereal :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " SUBROUTINE DSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSYSVXX uses the diagonal pivoting factorization to compute the\n\ * solution to a double precision system of linear equations A * X = B, where A\n\ * is an N-by-N symmetric matrix and X and B are N-by-NRHS matrices.\n\ *\n\ * If requested, both normwise and maximum componentwise error bounds\n\ * are returned. DSYSVXX will return a solution with a tiny\n\ * guaranteed error (O(eps) where eps is the working machine\n\ * precision) unless the matrix is very ill-conditioned, in which\n\ * case a warning is returned. Relevant condition numbers also are\n\ * calculated and returned.\n\ *\n\ * DSYSVXX accepts user-provided factorizations and equilibration\n\ * factors; see the definitions of the FACT and EQUED options.\n\ * Solving with refinement and using a factorization from a previous\n\ * DSYSVXX call will also produce a solution with either O(eps)\n\ * errors or warnings, but we cannot make that claim for general\n\ * user-provided factorizations and equilibration factors if they\n\ * differ from what DSYSVXX would itself produce.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n\ * the system:\n\ *\n\ * diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B\n\ *\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n\ *\n\ * 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n\ * the matrix A (after equilibration if FACT = 'E') as\n\ *\n\ * A = U * D * U**T, if UPLO = 'U', or\n\ * A = L * D * L**T, if UPLO = 'L',\n\ *\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, and D is symmetric and block diagonal with\n\ * 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\ * 3. If some D(i,i)=0, so that D is exactly singular, then the\n\ * routine returns with INFO = i. Otherwise, the factored form of A\n\ * is used to estimate the condition number of the matrix A (see\n\ * argument RCOND). If the reciprocal of the condition number is\n\ * less than machine precision, the routine still goes on to solve\n\ * for X and compute error bounds as described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n\ * the routine will use iterative refinement to try to get a small\n\ * error and error bounds. Refinement calculates the residual to at\n\ * least twice the working precision.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(R) so that it solves the original system before\n\ * equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AF and IPIV contain the factored form of A.\n\ * If EQUED is not 'N', the matrix A has been\n\ * equilibrated with scaling factors given by S.\n\ * A, AF, and IPIV are not modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AF and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular\n\ * part of the matrix A, and the strictly lower triangular\n\ * part of A is not referenced. If UPLO = 'L', the leading\n\ * N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n\ * diag(S)*A*diag(S).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N)\n\ * If FACT = 'F', then AF is an input argument and on entry\n\ * contains the block diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L from the factorization A =\n\ * U*D*U**T or A = L*D*L**T as computed by DSYTRF.\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the block diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L from the factorization A =\n\ * U*D*U**T or A = L*D*L**T.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains details of the interchanges and the block\n\ * structure of D, as determined by DSYTRF. If IPIV(k) > 0,\n\ * then rows and columns k and IPIV(k) were interchanged and\n\ * D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and\n\ * IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and\n\ * -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2\n\ * diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0,\n\ * then rows and columns k+1 and -IPIV(k) were interchanged\n\ * and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains details of the interchanges and the block\n\ * structure of D, as determined by DSYTRF.\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'Y': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(S) * A * diag(S).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * S (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The scale factors for A. If EQUED = 'Y', A is multiplied on\n\ * the left and right by diag(S). S is an input argument if FACT =\n\ * 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n\ * = 'Y', each element of S must be positive. If S is output, each\n\ * element of S is a power of the radix. If S is input, each element\n\ * of S should be a power of the radix to ensure a reliable solution\n\ * and error estimates. Scaling by powers of the radix does not cause\n\ * rounding errors unless the result underflows or overflows.\n\ * Rounding errors during scaling lead to refining with a matrix that\n\ * is not equivalent to the input matrix, producing error estimates\n\ * that may not be reliable.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit,\n\ * if EQUED = 'N', B is not modified;\n\ * if EQUED = 'Y', B is overwritten by diag(S)*B;\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * If INFO = 0, the N-by-NRHS solution matrix X to the original\n\ * system of equations. Note that A and B are modified on exit if\n\ * EQUED .ne. 'N', and the solution to the equilibrated system is\n\ * inv(diag(S))*X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * RPVGRW (output) DOUBLE PRECISION\n\ * Reciprocal pivot growth. On exit, this contains the reciprocal\n\ * pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n\ * norm is used. If this is much less than 1, then the stability of\n\ * the LU factorization of the (equilibrated) matrix A could be poor.\n\ * This also means that the solution X, estimated condition numbers,\n\ * and error bounds could be unreliable. If factorization fails with\n\ * 0 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/claesy0000644000175000017500000000473412502223525016477 0ustar uwabamiuwabami--- :name: claesy :md5sum: cda88734cca22f111cf3994c8552cfb4 :category: :subroutine :arguments: - a: :type: complex :intent: input - b: :type: complex :intent: input - c: :type: complex :intent: input - rt1: :type: complex :intent: output - rt2: :type: complex :intent: output - evscal: :type: complex :intent: output - cs1: :type: complex :intent: output - sn1: :type: complex :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CLAESY( A, B, C, RT1, RT2, EVSCAL, CS1, SN1 )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAESY computes the eigendecomposition of a 2-by-2 symmetric matrix\n\ * ( ( A, B );( B, C ) )\n\ * provided the norm of the matrix of eigenvectors is larger than\n\ * some threshold value.\n\ *\n\ * RT1 is the eigenvalue of larger absolute value, and RT2 of\n\ * smaller absolute value. If the eigenvectors are computed, then\n\ * on return ( CS1, SN1 ) is the unit eigenvector for RT1, hence\n\ *\n\ * [ CS1 SN1 ] . [ A B ] . [ CS1 -SN1 ] = [ RT1 0 ]\n\ * [ -SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * A (input) COMPLEX\n\ * The ( 1, 1 ) element of input matrix.\n\ *\n\ * B (input) COMPLEX\n\ * The ( 1, 2 ) element of input matrix. The ( 2, 1 ) element\n\ * is also given by B, since the 2-by-2 matrix is symmetric.\n\ *\n\ * C (input) COMPLEX\n\ * The ( 2, 2 ) element of input matrix.\n\ *\n\ * RT1 (output) COMPLEX\n\ * The eigenvalue of larger modulus.\n\ *\n\ * RT2 (output) COMPLEX\n\ * The eigenvalue of smaller modulus.\n\ *\n\ * EVSCAL (output) COMPLEX\n\ * The complex value by which the eigenvector matrix was scaled\n\ * to make it orthonormal. If EVSCAL is zero, the eigenvectors\n\ * were not computed. This means one of two things: the 2-by-2\n\ * matrix could not be diagonalized, or the norm of the matrix\n\ * of eigenvectors before scaling was larger than the threshold\n\ * value THRESH (set below).\n\ *\n\ * CS1 (output) COMPLEX\n\ * SN1 (output) COMPLEX\n\ * If EVSCAL .NE. 0, ( CS1, SN1 ) is the unit right eigenvector\n\ * for RT1.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgglse0000644000175000017500000001222012502223526016452 0ustar uwabamiuwabami--- :name: dgglse :md5sum: f8e4bc124d9d19025708402676a2883b :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - p: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: doublereal :intent: input/output :dims: - m - d: :type: doublereal :intent: input/output :dims: - p - x: :type: doublereal :intent: output :dims: - n - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m+n+p - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGGLSE solves the linear equality-constrained least squares (LSE)\n\ * problem:\n\ *\n\ * minimize || c - A*x ||_2 subject to B*x = d\n\ *\n\ * where A is an M-by-N matrix, B is a P-by-N matrix, c is a given\n\ * M-vector, and d is a given P-vector. It is assumed that\n\ * P <= N <= M+P, and\n\ *\n\ * rank(B) = P and rank( (A) ) = N.\n\ * ( (B) )\n\ *\n\ * These conditions ensure that the LSE problem has a unique solution,\n\ * which is obtained using a generalized RQ factorization of the\n\ * matrices (B, A) given by\n\ *\n\ * B = (0 R)*Q, A = Z*T*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 matrices A and B. N >= 0.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows of the matrix B. 0 <= P <= N <= M+P.\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 above the diagonal of the array\n\ * contain the min(M,N)-by-N upper trapezoidal matrix T.\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,N)\n\ * On entry, the P-by-N matrix B.\n\ * On exit, the upper triangle of the subarray B(1:P,N-P+1:N)\n\ * contains the P-by-P upper triangular matrix R.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,P).\n\ *\n\ * C (input/output) DOUBLE PRECISION array, dimension (M)\n\ * On entry, C contains the right hand side vector for the\n\ * least squares part of the LSE problem.\n\ * On exit, the residual sum of squares for the solution\n\ * is given by the sum of squares of elements N-P+1 to M of\n\ * vector C.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (P)\n\ * On entry, D contains the right hand side vector for the\n\ * constrained equation.\n\ * On exit, D is destroyed.\n\ *\n\ * X (output) DOUBLE PRECISION array, dimension (N)\n\ * On exit, X is the solution of the LSE problem.\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+P).\n\ * For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,\n\ * where NB is an upper bound for the optimal blocksizes for\n\ * DGEQRF, SGERQF, DORMQR and SORMRQ.\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\ * = 1: the upper triangular factor R associated with B in the\n\ * generalized RQ factorization of the pair (B, A) is\n\ * singular, so that rank(B) < P; the least squares\n\ * solution could not be computed.\n\ * = 2: the (N-P) by (N-P) part of the upper trapezoidal factor\n\ * T associated with A in the generalized RQ factorization\n\ * of the pair (B, A) is singular, so that\n\ * rank( (A) ) < N; the least squares solution could not\n\ * ( (B) )\n\ * be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dtgsna0000644000175000017500000003301712502223526016474 0ustar uwabamiuwabami--- :name: dtgsna :md5sum: 75f02e486f5cd5b703e5e189eb4780e2 :category: :subroutine :arguments: - job: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - vl: :type: doublereal :intent: input :dims: - ldvl - m - ldvl: :type: integer :intent: input - vr: :type: doublereal :intent: input :dims: - ldvr - m - ldvr: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - mm - dif: :type: doublereal :intent: output :dims: - mm - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(lsame_(&job,\"V\")||lsame_(&job,\"B\")) ? 2*n*n : n" - iwork: :type: integer :intent: workspace :dims: - "lsame_(&job,\"E\") ? 0 : n + 6" - info: :type: integer :intent: output :substitutions: mm: m :fortran_help: " SUBROUTINE DTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTGSNA estimates reciprocal condition numbers for specified\n\ * eigenvalues and/or eigenvectors of a matrix pair (A, B) in\n\ * generalized real Schur canonical form (or of any matrix pair\n\ * (Q*A*Z', Q*B*Z') with orthogonal matrices Q and Z, where\n\ * Z' denotes the transpose of Z.\n\ *\n\ * (A, B) must be in generalized real Schur form (as returned by DGGES),\n\ * i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal\n\ * blocks. B is upper triangular.\n\ *\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * Specifies whether condition numbers are required for\n\ * eigenvalues (S) or eigenvectors (DIF):\n\ * = 'E': for eigenvalues only (S);\n\ * = 'V': for eigenvectors only (DIF);\n\ * = 'B': for both eigenvalues and eigenvectors (S and DIF).\n\ *\n\ * HOWMNY (input) CHARACTER*1\n\ * = 'A': compute condition numbers for all eigenpairs;\n\ * = 'S': compute condition numbers for selected eigenpairs\n\ * specified by the array SELECT.\n\ *\n\ * SELECT (input) LOGICAL array, dimension (N)\n\ * If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n\ * condition numbers are required. To select condition numbers\n\ * for the eigenpair corresponding to a real eigenvalue w(j),\n\ * SELECT(j) must be set to .TRUE.. To select condition numbers\n\ * corresponding to a complex conjugate pair of eigenvalues w(j)\n\ * and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be\n\ * set to .TRUE..\n\ * If HOWMNY = 'A', SELECT is not referenced.\n\ *\n\ * N (input) INTEGER\n\ * The order of the square matrix pair (A, B). N >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The upper quasi-triangular matrix A in the pair (A,B).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,N)\n\ * The upper triangular matrix B in the pair (A,B).\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * VL (input) DOUBLE PRECISION array, dimension (LDVL,M)\n\ * If JOB = 'E' or 'B', VL must contain left eigenvectors of\n\ * (A, B), corresponding to the eigenpairs specified by HOWMNY\n\ * and SELECT. The eigenvectors must be stored in consecutive\n\ * columns of VL, as returned by DTGEVC.\n\ * If JOB = 'V', VL is not referenced.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the array VL. LDVL >= 1.\n\ * If JOB = 'E' or 'B', LDVL >= N.\n\ *\n\ * VR (input) DOUBLE PRECISION array, dimension (LDVR,M)\n\ * If JOB = 'E' or 'B', VR must contain right eigenvectors of\n\ * (A, B), corresponding to the eigenpairs specified by HOWMNY\n\ * and SELECT. The eigenvectors must be stored in consecutive\n\ * columns ov VR, as returned by DTGEVC.\n\ * If JOB = 'V', VR is not referenced.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the array VR. LDVR >= 1.\n\ * If JOB = 'E' or 'B', LDVR >= N.\n\ *\n\ * S (output) DOUBLE PRECISION array, dimension (MM)\n\ * If JOB = 'E' or 'B', the reciprocal condition numbers of the\n\ * selected eigenvalues, stored in consecutive elements of the\n\ * array. For a complex conjugate pair of eigenvalues two\n\ * consecutive elements of S are set to the same value. Thus\n\ * S(j), DIF(j), and the j-th columns of VL and VR all\n\ * correspond to the same eigenpair (but not in general the\n\ * j-th eigenpair, unless all eigenpairs are selected).\n\ * If JOB = 'V', S is not referenced.\n\ *\n\ * DIF (output) DOUBLE PRECISION array, dimension (MM)\n\ * If JOB = 'V' or 'B', the estimated reciprocal condition\n\ * numbers of the selected eigenvectors, stored in consecutive\n\ * elements of the array. For a complex eigenvector two\n\ * consecutive elements of DIF are set to the same value. If\n\ * the eigenvalues cannot be reordered to compute DIF(j), DIF(j)\n\ * is set to 0; this can only occur when the true value would be\n\ * very small anyway.\n\ * If JOB = 'E', DIF is not referenced.\n\ *\n\ * MM (input) INTEGER\n\ * The number of elements in the arrays S and DIF. MM >= M.\n\ *\n\ * M (output) INTEGER\n\ * The number of elements of the arrays S and DIF used to store\n\ * the specified condition numbers; for each selected real\n\ * eigenvalue one element is used, and for each selected complex\n\ * conjugate pair of eigenvalues, two elements are used.\n\ * If HOWMNY = 'A', M is set to 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. LWORK >= max(1,N).\n\ * If JOB = 'V' or 'B' LWORK >= 2*N*(N+2)+16.\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\ * IWORK (workspace) INTEGER array, dimension (N + 6)\n\ * If JOB = 'E', IWORK is not referenced.\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\n\ * Further Details\n\ * ===============\n\ *\n\ * The reciprocal of the condition number of a generalized eigenvalue\n\ * w = (a, b) is defined as\n\ *\n\ * S(w) = (|u'Av|**2 + |u'Bv|**2)**(1/2) / (norm(u)*norm(v))\n\ *\n\ * where u and v are the left and right eigenvectors of (A, B)\n\ * corresponding to w; |z| denotes the absolute value of the complex\n\ * number, and norm(u) denotes the 2-norm of the vector u.\n\ * The pair (a, b) corresponds to an eigenvalue w = a/b (= u'Av/u'Bv)\n\ * of the matrix pair (A, B). If both a and b equal zero, then (A B) is\n\ * singular and S(I) = -1 is returned.\n\ *\n\ * An approximate error bound on the chordal distance between the i-th\n\ * computed generalized eigenvalue w and the corresponding exact\n\ * eigenvalue lambda is\n\ *\n\ * chord(w, lambda) <= EPS * norm(A, B) / S(I)\n\ *\n\ * where EPS is the machine precision.\n\ *\n\ * The reciprocal of the condition number DIF(i) of right eigenvector u\n\ * and left eigenvector v corresponding to the generalized eigenvalue w\n\ * is defined as follows:\n\ *\n\ * a) If the i-th eigenvalue w = (a,b) is real\n\ *\n\ * Suppose U and V are orthogonal transformations such that\n\ *\n\ * U'*(A, B)*V = (S, T) = ( a * ) ( b * ) 1\n\ * ( 0 S22 ),( 0 T22 ) n-1\n\ * 1 n-1 1 n-1\n\ *\n\ * Then the reciprocal condition number DIF(i) is\n\ *\n\ * Difl((a, b), (S22, T22)) = sigma-min( Zl ),\n\ *\n\ * where sigma-min(Zl) denotes the smallest singular value of the\n\ * 2(n-1)-by-2(n-1) matrix\n\ *\n\ * Zl = [ kron(a, In-1) -kron(1, S22) ]\n\ * [ kron(b, In-1) -kron(1, T22) ] .\n\ *\n\ * Here In-1 is the identity matrix of size n-1. kron(X, Y) is the\n\ * Kronecker product between the matrices X and Y.\n\ *\n\ * Note that if the default method for computing DIF(i) is wanted\n\ * (see DLATDF), then the parameter DIFDRI (see below) should be\n\ * changed from 3 to 4 (routine DLATDF(IJOB = 2 will be used)).\n\ * See DTGSYL for more details.\n\ *\n\ * b) If the i-th and (i+1)-th eigenvalues are complex conjugate pair,\n\ *\n\ * Suppose U and V are orthogonal transformations such that\n\ *\n\ * U'*(A, B)*V = (S, T) = ( S11 * ) ( T11 * ) 2\n\ * ( 0 S22 ),( 0 T22) n-2\n\ * 2 n-2 2 n-2\n\ *\n\ * and (S11, T11) corresponds to the complex conjugate eigenvalue\n\ * pair (w, conjg(w)). There exist unitary matrices U1 and V1 such\n\ * that\n\ *\n\ * U1'*S11*V1 = ( s11 s12 ) and U1'*T11*V1 = ( t11 t12 )\n\ * ( 0 s22 ) ( 0 t22 )\n\ *\n\ * where the generalized eigenvalues w = s11/t11 and\n\ * conjg(w) = s22/t22.\n\ *\n\ * Then the reciprocal condition number DIF(i) is bounded by\n\ *\n\ * min( d1, max( 1, |real(s11)/real(s22)| )*d2 )\n\ *\n\ * where, d1 = Difl((s11, t11), (s22, t22)) = sigma-min(Z1), where\n\ * Z1 is the complex 2-by-2 matrix\n\ *\n\ * Z1 = [ s11 -s22 ]\n\ * [ t11 -t22 ],\n\ *\n\ * This is done by computing (using real arithmetic) the\n\ * roots of the characteristical polynomial det(Z1' * Z1 - lambda I),\n\ * where Z1' denotes the conjugate transpose of Z1 and det(X) denotes\n\ * the determinant of X.\n\ *\n\ * and d2 is an upper bound on Difl((S11, T11), (S22, T22)), i.e. an\n\ * upper bound on sigma-min(Z2), where Z2 is (2n-2)-by-(2n-2)\n\ *\n\ * Z2 = [ kron(S11', In-2) -kron(I2, S22) ]\n\ * [ kron(T11', In-2) -kron(I2, T22) ]\n\ *\n\ * Note that if the default method for computing DIF is wanted (see\n\ * DLATDF), then the parameter DIFDRI (see below) should be changed\n\ * from 3 to 4 (routine DLATDF(IJOB = 2 will be used)). See DTGSYL\n\ * for more details.\n\ *\n\ * For each eigenvalue/vector specified by SELECT, DIF stores a\n\ * Frobenius norm-based estimate of Difl.\n\ *\n\ * An approximate error bound for the i-th computed eigenvector VL(i) or\n\ * VR(i) is given by\n\ *\n\ * EPS * norm(A, B) / DIF(i).\n\ *\n\ * See ref. [2-3] for more details and further references.\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * References\n\ * ==========\n\ *\n\ * [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n\ * Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n\ * M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n\ * Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n\ *\n\ * [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n\ * Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n\ * Estimation: Theory, Algorithms and Software,\n\ * Report UMINF - 94.04, Department of Computing Science, Umea\n\ * University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working\n\ * Note 87. To appear in Numerical Algorithms, 1996.\n\ *\n\ * [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n\ * for Solving the Generalized Sylvester Equation and Estimating the\n\ * Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n\ * Department of Computing Science, Umea University, S-901 87 Umea,\n\ * Sweden, December 1993, Revised April 1994, Also as LAPACK Working\n\ * Note 75. To appear in ACM Trans. on Math. Software, Vol 22,\n\ * No 1, 1996.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/claqr00000644000175000017500000001736312502223525016403 0ustar uwabamiuwabami--- :name: claqr0 :md5sum: 17110405cb2df6f5f3833a30a4a05ba5 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: complex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - w: :type: complex :intent: output :dims: - n - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: complex :intent: input/output :dims: - ldz - ihi - ldz: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAQR0 computes the eigenvalues of a Hessenberg matrix H\n\ * and, optionally, the matrices T and Z from the Schur decomposition\n\ * H = Z T Z**H, where T is an upper triangular matrix (the\n\ * Schur form), and Z is the unitary matrix of Schur vectors.\n\ *\n\ * Optionally Z may be postmultiplied into an input unitary\n\ * matrix Q so that this routine can give the Schur factorization\n\ * of a matrix A which has been reduced to the Hessenberg form H\n\ * by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * WANTT (input) LOGICAL\n\ * = .TRUE. : the full Schur form T is required;\n\ * = .FALSE.: only eigenvalues are required.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * = .TRUE. : the matrix of Schur vectors Z is required;\n\ * = .FALSE.: Schur vectors are not required.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H. N .GE. 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * It is assumed that H is already upper triangular in rows\n\ * and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n\ * H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n\ * previous call to CGEBAL, and then passed to CGEHRD when the\n\ * matrix output by CGEBAL is reduced to Hessenberg form.\n\ * Otherwise, ILO and IHI should be set to 1 and N,\n\ * respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n\ * If N = 0, then ILO = 1 and IHI = 0.\n\ *\n\ * H (input/output) COMPLEX array, dimension (LDH,N)\n\ * On entry, the upper Hessenberg matrix H.\n\ * On exit, if INFO = 0 and WANTT is .TRUE., then H\n\ * contains the upper triangular matrix T from the Schur\n\ * decomposition (the Schur form). If INFO = 0 and WANT is\n\ * .FALSE., then the contents of H are unspecified on exit.\n\ * (The output value of H when INFO.GT.0 is given under the\n\ * description of INFO below.)\n\ *\n\ * This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n\ * j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n\ *\n\ * LDH (input) INTEGER\n\ * The leading dimension of the array H. LDH .GE. max(1,N).\n\ *\n\ * W (output) COMPLEX array, dimension (N)\n\ * The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored\n\ * in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are\n\ * stored in the same order as on the diagonal of the Schur\n\ * form returned in H, with W(i) = H(i,i).\n\ *\n\ * Z (input/output) COMPLEX array, dimension (LDZ,IHI)\n\ * If WANTZ is .FALSE., then Z is not referenced.\n\ * If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n\ * replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n\ * orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n\ * (The output value of Z when INFO.GT.0 is given under\n\ * the description of INFO below.)\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. if WANTZ is .TRUE.\n\ * then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.\n\ *\n\ * WORK (workspace/output) COMPLEX array, dimension LWORK\n\ * On exit, if LWORK = -1, WORK(1) returns an estimate of\n\ * the optimal value for LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK .GE. max(1,N)\n\ * is sufficient, but LWORK typically as large as 6*N may\n\ * be required for optimal performance. A workspace query\n\ * to determine the optimal workspace size is recommended.\n\ *\n\ * If LWORK = -1, then CLAQR0 does a workspace query.\n\ * In this case, CLAQR0 checks the input parameters and\n\ * estimates the optimal workspace size for the given\n\ * values of N, ILO and IHI. The estimate is returned\n\ * in WORK(1). No error message related to LWORK is\n\ * issued by XERBLA. Neither H nor Z are accessed.\n\ *\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * .GT. 0: if INFO = i, CLAQR0 failed to compute all of\n\ * the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n\ * and WI contain those eigenvalues which have been\n\ * successfully computed. (Failures are rare.)\n\ *\n\ * If INFO .GT. 0 and WANT is .FALSE., then on exit,\n\ * the remaining unconverged eigenvalues are the eigen-\n\ * values of the upper Hessenberg matrix rows and\n\ * columns ILO through INFO of the final, output\n\ * value of H.\n\ *\n\ * If INFO .GT. 0 and WANTT is .TRUE., then on exit\n\ *\n\ * (*) (initial value of H)*U = U*(final value of H)\n\ *\n\ * where U is a unitary matrix. The final\n\ * value of H is upper Hessenberg and triangular in\n\ * rows and columns INFO+1 through IHI.\n\ *\n\ * If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n\ *\n\ * (final value of Z(ILO:IHI,ILOZ:IHIZ)\n\ * = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n\ *\n\ * where U is the unitary matrix in (*) (regard-\n\ * less of the value of WANTT.)\n\ *\n\ * If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n\ * accessed.\n\ *\n\n\ * ================================================================\n\ * Based on contributions by\n\ * Karen Braman and Ralph Byers, Department of Mathematics,\n\ * University of Kansas, USA\n\ *\n\ * ================================================================\n\ * References:\n\ * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n\ * Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n\ * Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n\ * 929--947, 2002.\n\ *\n\ * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n\ * Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n\ * of Matrix Analysis, volume 23, pages 948--973, 2002.\n\ *\n\ * ================================================================\n" ruby-lapack-1.7.2/dev/defs/zlaqhe0000644000175000017500000000605112502223526016476 0ustar uwabamiuwabami--- :name: zlaqhe :md5sum: 77e6b178f95bcb2b254421aa82d4d8cd :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - s: :type: doublereal :intent: input :dims: - n - scond: :type: doublereal :intent: input - amax: :type: doublereal :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAQHE equilibrates a Hermitian matrix A using the scaling factors\n\ * in the vector S.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * Hermitian matrix A is stored.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the leading\n\ * n by n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n by n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if EQUED = 'Y', the equilibrated matrix:\n\ * diag(S) * A * diag(S).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(N,1).\n\ *\n\ * S (input) DOUBLE PRECISION array, dimension (N)\n\ * The scale factors for A.\n\ *\n\ * SCOND (input) DOUBLE PRECISION\n\ * Ratio of the smallest S(i) to the largest S(i).\n\ *\n\ * AMAX (input) DOUBLE PRECISION\n\ * Absolute value of largest matrix entry.\n\ *\n\ * EQUED (output) CHARACTER*1\n\ * Specifies whether or not equilibration was done.\n\ * = 'N': No equilibration.\n\ * = 'Y': Equilibration was done, i.e., A has been replaced by\n\ * diag(S) * A * diag(S).\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * THRESH is a threshold value used to decide if scaling should be done\n\ * based on the ratio of the scaling factors. If SCOND < THRESH,\n\ * scaling is done.\n\ *\n\ * LARGE and SMALL are threshold values used to decide if scaling should\n\ * be done based on the absolute size of the largest matrix element.\n\ * If AMAX > LARGE or AMAX < SMALL, scaling is done.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgbbrd0000644000175000017500000001176012502223526016467 0ustar uwabamiuwabami--- :name: zgbbrd :md5sum: 8e300267613885efce454baefeee7dd6 :category: :subroutine :arguments: - vect: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - ncc: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - MIN(m,n) - e: :type: doublereal :intent: output :dims: - MIN(m,n)-1 - q: :type: doublecomplex :intent: output :dims: - ldq - m - ldq: :type: integer :intent: input - pt: :type: doublecomplex :intent: output :dims: - ldpt - n - ldpt: :type: integer :intent: input - c: :type: doublecomplex :intent: input/output :dims: - ldc - ncc - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - MAX(m,n) - rwork: :type: doublereal :intent: workspace :dims: - MAX(m,n) - info: :type: integer :intent: output :substitutions: m: ldab ldq: "((lsame_(&vect,\"Q\")) || (lsame_(&vect,\"B\"))) ? MAX(1,m) : 1" ldpt: "((lsame_(&vect,\"P\")) || (lsame_(&vect,\"B\"))) ? MAX(1,n) : 1" :fortran_help: " SUBROUTINE ZGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, LDQ, PT, LDPT, C, LDC, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGBBRD reduces a complex general m-by-n band matrix A to real upper\n\ * bidiagonal form B by a unitary transformation: Q' * A * P = B.\n\ *\n\ * The routine computes B, and optionally forms Q or P', or computes\n\ * Q'*C for a given matrix C.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * VECT (input) CHARACTER*1\n\ * Specifies whether or not the matrices Q and P' are to be\n\ * formed.\n\ * = 'N': do not form Q or P';\n\ * = 'Q': form Q only;\n\ * = 'P': form P' only;\n\ * = 'B': form both.\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\ * NCC (input) INTEGER\n\ * The number of columns of the matrix C. NCC >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals of the matrix A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals of the matrix A. KU >= 0.\n\ *\n\ * AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n\ * On entry, the m-by-n band matrix A, stored in rows 1 to\n\ * KL+KU+1. The j-th column of A is stored in the j-th column of\n\ * the array AB as follows:\n\ * AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n\ * On exit, A is overwritten by values generated during the\n\ * reduction.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array A. LDAB >= KL+KU+1.\n\ *\n\ * D (output) DOUBLE PRECISION array, dimension (min(M,N))\n\ * The diagonal elements of the bidiagonal matrix B.\n\ *\n\ * E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)\n\ * The superdiagonal elements of the bidiagonal matrix B.\n\ *\n\ * Q (output) COMPLEX*16 array, dimension (LDQ,M)\n\ * If VECT = 'Q' or 'B', the m-by-m unitary matrix Q.\n\ * If VECT = 'N' or 'P', the array Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q.\n\ * LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.\n\ *\n\ * PT (output) COMPLEX*16 array, dimension (LDPT,N)\n\ * If VECT = 'P' or 'B', the n-by-n unitary matrix P'.\n\ * If VECT = 'N' or 'Q', the array PT is not referenced.\n\ *\n\ * LDPT (input) INTEGER\n\ * The leading dimension of the array PT.\n\ * LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.\n\ *\n\ * C (input/output) COMPLEX*16 array, dimension (LDC,NCC)\n\ * On entry, an m-by-ncc matrix C.\n\ * On exit, C is overwritten by Q'*C.\n\ * C is not referenced if NCC = 0.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C.\n\ * LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (max(M,N))\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (max(M,N))\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cpbsv0000644000175000017500000001140512502223525016325 0ustar uwabamiuwabami--- :name: cpbsv :md5sum: 509caf333be99485328c142a494723c9 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPBSV computes the solution to a complex system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N Hermitian positive definite band matrix and X\n\ * and B are N-by-NRHS matrices.\n\ *\n\ * The Cholesky decomposition is used to factor A as\n\ * A = U**H * U, if UPLO = 'U', or\n\ * A = L * L**H, if UPLO = 'L',\n\ * where U is an upper triangular band matrix, and L is a lower\n\ * triangular band matrix, with the same number of superdiagonals or\n\ * subdiagonals as A. The factored form of A is then used to solve the\n\ * system of equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AB (input/output) COMPLEX array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).\n\ * See below for further details.\n\ *\n\ * On exit, if INFO = 0, the triangular factor U or L from the\n\ * Cholesky factorization A = U**H*U or A = L*L**H of the band\n\ * matrix A, in the same storage format as A.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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 leading minor of order i of A is not\n\ * positive definite, so the factorization could not be\n\ * completed, and the solution has not been computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * N = 6, KD = 2, and UPLO = 'U':\n\ *\n\ * On entry: On exit:\n\ *\n\ * * * a13 a24 a35 a46 * * u13 u24 u35 u46\n\ * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n\ * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n\ *\n\ * Similarly, if UPLO = 'L' the format of A is as follows:\n\ *\n\ * On entry: On exit:\n\ *\n\ * a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n\ * a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n\ * a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n\ *\n\ * Array elements marked * are not used by the routine.\n\ *\n\ * =====================================================================\n\ *\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CPBTRF, CPBTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dgebd20000644000175000017500000001331612502223526016343 0ustar uwabamiuwabami--- :name: dgebd2 :md5sum: d6a391ab865d33b54860820be4bb9eff :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - MIN(m,n) - e: :type: doublereal :intent: output :dims: - MIN(m,n)-1 - tauq: :type: doublereal :intent: output :dims: - MIN(m,n) - taup: :type: doublereal :intent: output :dims: - MIN(m,n) - work: :type: doublereal :intent: workspace :dims: - MAX(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGEBD2 reduces a real general m by n matrix A to upper or lower\n\ * bidiagonal form B by an orthogonal transformation: Q' * A * P = B.\n\ *\n\ * If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows in the matrix A. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns in the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the m by n general matrix to be reduced.\n\ * On exit,\n\ * if m >= n, the diagonal and the first superdiagonal are\n\ * overwritten with the upper bidiagonal matrix B; the\n\ * elements below the diagonal, with the array TAUQ, represent\n\ * the orthogonal matrix Q as a product of elementary\n\ * reflectors, and the elements above the first superdiagonal,\n\ * with the array TAUP, represent the orthogonal matrix P as\n\ * a product of elementary reflectors;\n\ * if m < n, the diagonal and the first subdiagonal are\n\ * overwritten with the lower bidiagonal matrix B; the\n\ * elements below the first subdiagonal, with the array TAUQ,\n\ * represent the orthogonal matrix Q as a product of\n\ * elementary reflectors, and the elements above the diagonal,\n\ * with the array TAUP, represent the orthogonal matrix P as\n\ * a product of elementary reflectors.\n\ * See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * D (output) DOUBLE PRECISION array, dimension (min(M,N))\n\ * The diagonal elements of the bidiagonal matrix B:\n\ * D(i) = A(i,i).\n\ *\n\ * E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)\n\ * The off-diagonal elements of the bidiagonal matrix B:\n\ * if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n\ * if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n\ *\n\ * TAUQ (output) DOUBLE PRECISION array dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the orthogonal matrix Q. See Further Details.\n\ *\n\ * TAUP (output) DOUBLE PRECISION array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the orthogonal matrix P. See Further Details.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (max(M,N))\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 matrices Q and P are represented as products of elementary\n\ * reflectors:\n\ *\n\ * If m >= n,\n\ *\n\ * Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)\n\ *\n\ * Each H(i) and G(i) has the form:\n\ *\n\ * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n\ *\n\ * where tauq and taup are real scalars, and v and u are real vectors;\n\ * v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);\n\ * u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);\n\ * tauq is stored in TAUQ(i) and taup in TAUP(i).\n\ *\n\ * If m < n,\n\ *\n\ * Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)\n\ *\n\ * Each H(i) and G(i) has the form:\n\ *\n\ * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n\ *\n\ * where tauq and taup are real scalars, and v and u are real vectors;\n\ * v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);\n\ * u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);\n\ * tauq is stored in TAUQ(i) and taup in TAUP(i).\n\ *\n\ * The contents of A on exit are illustrated by the following examples:\n\ *\n\ * m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n\ *\n\ * ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )\n\ * ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )\n\ * ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )\n\ * ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )\n\ * ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )\n\ * ( v1 v2 v3 v4 v5 )\n\ *\n\ * where d and e denote diagonal and off-diagonal elements of B, vi\n\ * denotes an element of the vector defining H(i), and ui an element of\n\ * the vector defining G(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slasd80000644000175000017500000001107612502223526016413 0ustar uwabamiuwabami--- :name: slasd8 :md5sum: 0427daa3f0dc3190e3b4094e1d06ca65 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - k: :type: integer :intent: input - d: :type: real :intent: output :dims: - k - z: :type: real :intent: input/output :dims: - k - vf: :type: real :intent: input/output :dims: - k - vl: :type: real :intent: input/output :dims: - k - difl: :type: real :intent: output :dims: - k - difr: :type: real :intent: output :dims: - "icompq == 1 ? lddifr : icompq == 0 ? k : 0" - "icompq == 1 ? 2 : 0" - lddifr: :type: integer :intent: input - dsigma: :type: real :intent: input/output :dims: - k - work: :type: real :intent: workspace :dims: - 3 * k - info: :type: integer :intent: output :substitutions: lddifr: k :fortran_help: " SUBROUTINE SLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, DSIGMA, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLASD8 finds the square roots of the roots of the secular equation,\n\ * as defined by the values in DSIGMA and Z. It makes the appropriate\n\ * calls to SLASD4, and stores, for each element in D, the distance\n\ * to its two nearest poles (elements in DSIGMA). It also updates\n\ * the arrays VF and VL, the first and last components of all the\n\ * right singular vectors of the original bidiagonal matrix.\n\ *\n\ * SLASD8 is called from SLASD6.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ICOMPQ (input) INTEGER\n\ * Specifies whether singular vectors are to be computed in\n\ * factored form in the calling routine:\n\ * = 0: Compute singular values only.\n\ * = 1: Compute singular vectors in factored form as well.\n\ *\n\ * K (input) INTEGER\n\ * The number of terms in the rational function to be solved\n\ * by SLASD4. K >= 1.\n\ *\n\ * D (output) REAL array, dimension ( K )\n\ * On output, D contains the updated singular values.\n\ *\n\ * Z (input/output) REAL array, dimension ( K )\n\ * On entry, the first K elements of this array contain the\n\ * components of the deflation-adjusted updating row vector.\n\ * On exit, Z is updated.\n\ *\n\ * VF (input/output) REAL array, dimension ( K )\n\ * On entry, VF contains information passed through DBEDE8.\n\ * On exit, VF contains the first K components of the first\n\ * components of all right singular vectors of the bidiagonal\n\ * matrix.\n\ *\n\ * VL (input/output) REAL array, dimension ( K )\n\ * On entry, VL contains information passed through DBEDE8.\n\ * On exit, VL contains the first K components of the last\n\ * components of all right singular vectors of the bidiagonal\n\ * matrix.\n\ *\n\ * DIFL (output) REAL array, dimension ( K )\n\ * On exit, DIFL(I) = D(I) - DSIGMA(I).\n\ *\n\ * DIFR (output) REAL array,\n\ * dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and\n\ * dimension ( K ) if ICOMPQ = 0.\n\ * On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not\n\ * defined and will not be referenced.\n\ *\n\ * If ICOMPQ = 1, DIFR(1:K,2) is an array containing the\n\ * normalizing factors for the right singular vector matrix.\n\ *\n\ * LDDIFR (input) INTEGER\n\ * The leading dimension of DIFR, must be at least K.\n\ *\n\ * DSIGMA (input/output) REAL array, dimension ( K )\n\ * On entry, the first K elements of this array contain the old\n\ * roots of the deflated updating problem. These are the poles\n\ * of the secular equation.\n\ * On exit, the elements of DSIGMA may be very slightly altered\n\ * in value.\n\ *\n\ * WORK (workspace) REAL array, dimension at least 3 * K\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 = 1, a singular value did not converge\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ming Gu and Huan Ren, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ilaclc0000644000175000017500000000201012502223526016430 0ustar uwabamiuwabami--- :name: ilaclc :md5sum: 40eb72bf94adf85b58d07bf4f02e8461 :category: :function :type: integer :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " INTEGER FUNCTION ILACLC( M, N, A, LDA )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ILACLC scans A for its last non-zero column.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix A.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * 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\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dopmtr0000644000175000017500000000716712502223526016530 0ustar uwabamiuwabami--- :name: dopmtr :md5sum: 663f65160cdb7949b61c331713b3a943 :category: :subroutine :arguments: - side: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - m*(m+1)/2 - tau: :type: doublereal :intent: input :dims: - m-1 - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DOPMTR overwrites the general real M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'T': Q**T * C C * Q**T\n\ *\n\ * where Q is a real orthogonal matrix of order nq, with nq = m if\n\ * SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of\n\ * nq-1 elementary reflectors, as returned by DSPTRD using packed\n\ * storage:\n\ *\n\ * if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);\n\ *\n\ * if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**T from the Left;\n\ * = 'R': apply Q or Q**T from the Right.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangular packed storage used in previous\n\ * call to DSPTRD;\n\ * = 'L': Lower triangular packed storage used in previous\n\ * call to DSPTRD.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q;\n\ * = 'T': Transpose, apply Q**T.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * AP (input) DOUBLE PRECISION array, dimension\n\ * (M*(M+1)/2) if SIDE = 'L'\n\ * (N*(N+1)/2) if SIDE = 'R'\n\ * The vectors which define the elementary reflectors, as\n\ * returned by DSPTRD. AP is modified by the routine but\n\ * restored on exit.\n\ *\n\ * TAU (input) DOUBLE PRECISION array, dimension (M-1) if SIDE = 'L'\n\ * or (N-1) if SIDE = 'R'\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by DSPTRD.\n\ *\n\ * C (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension\n\ * (N) if SIDE = 'L'\n\ * (M) if SIDE = 'R'\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsbev0000644000175000017500000000742612502223526016324 0ustar uwabamiuwabami--- :name: dsbev :md5sum: 0ca5c28ae2889fbdbe1f84fad527d165 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,3*n-2) - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" :fortran_help: " SUBROUTINE DSBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSBEV computes all the eigenvalues and, optionally, eigenvectors of\n\ * a real symmetric band matrix A.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * On exit, AB is overwritten by values generated during the\n\ * reduction to tridiagonal form. If UPLO = 'U', the first\n\ * superdiagonal and the diagonal of the tridiagonal matrix T\n\ * are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n\ * the diagonal and first subdiagonal of T are returned in the\n\ * first two rows of AB.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD + 1.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n\ * eigenvectors of the matrix A, with the i-th column of Z\n\ * holding the eigenvector associated with W(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (max(1,3*N-2))\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 algorithm failed to converge; i\n\ * off-diagonal elements of an intermediate tridiagonal\n\ * form did not converge to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slatdf0000644000175000017500000001143312502223526016467 0ustar uwabamiuwabami--- :name: slatdf :md5sum: f15dc290a2df350b5b3f847a55798283 :category: :subroutine :arguments: - ijob: :type: integer :intent: input - n: :type: integer :intent: input - z: :type: real :intent: input :dims: - ldz - n - ldz: :type: integer :intent: input - rhs: :type: real :intent: input/output :dims: - n - rdsum: :type: real :intent: input/output - rdscal: :type: real :intent: input/output - ipiv: :type: integer :intent: input :dims: - n - jpiv: :type: integer :intent: input :dims: - n :substitutions: {} :fortran_help: " SUBROUTINE SLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, JPIV )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLATDF uses the LU factorization of the n-by-n matrix Z computed by\n\ * SGETC2 and computes a contribution to the reciprocal Dif-estimate\n\ * by solving Z * x = b for x, and choosing the r.h.s. b such that\n\ * the norm of x is as large as possible. On entry RHS = b holds the\n\ * contribution from earlier solved sub-systems, and on return RHS = x.\n\ *\n\ * The factorization of Z returned by SGETC2 has the form Z = P*L*U*Q,\n\ * where P and Q are permutation matrices. L is lower triangular with\n\ * unit diagonal elements and U is upper triangular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * IJOB (input) INTEGER\n\ * IJOB = 2: First compute an approximative null-vector e\n\ * of Z using SGECON, e is normalized and solve for\n\ * Zx = +-e - f with the sign giving the greater value\n\ * of 2-norm(x). About 5 times as expensive as Default.\n\ * IJOB .ne. 2: Local look ahead strategy where all entries of\n\ * the r.h.s. b is choosen as either +1 or -1 (Default).\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Z.\n\ *\n\ * Z (input) REAL array, dimension (LDZ, N)\n\ * On entry, the LU part of the factorization of the n-by-n\n\ * matrix Z computed by SGETC2: Z = P * L * U * Q\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDA >= max(1, N).\n\ *\n\ * RHS (input/output) REAL array, dimension N.\n\ * On entry, RHS contains contributions from other subsystems.\n\ * On exit, RHS contains the solution of the subsystem with\n\ * entries acoording to the value of IJOB (see above).\n\ *\n\ * RDSUM (input/output) REAL\n\ * On entry, the sum of squares of computed contributions to\n\ * the Dif-estimate under computation by STGSYL, where the\n\ * scaling factor RDSCAL (see below) has been factored out.\n\ * On exit, the corresponding sum of squares updated with the\n\ * contributions from the current sub-system.\n\ * If TRANS = 'T' RDSUM is not touched.\n\ * NOTE: RDSUM only makes sense when STGSY2 is called by STGSYL.\n\ *\n\ * RDSCAL (input/output) REAL\n\ * On entry, scaling factor used to prevent overflow in RDSUM.\n\ * On exit, RDSCAL is updated w.r.t. the current contributions\n\ * in RDSUM.\n\ * If TRANS = 'T', RDSCAL is not touched.\n\ * NOTE: RDSCAL only makes sense when STGSY2 is called by\n\ * STGSYL.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N).\n\ * The pivot indices; for 1 <= i <= N, row i of the\n\ * matrix has been interchanged with row IPIV(i).\n\ *\n\ * JPIV (input) INTEGER array, dimension (N).\n\ * The pivot indices; for 1 <= j <= N, column j of the\n\ * matrix has been interchanged with column JPIV(j).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * This routine is a further developed implementation of algorithm\n\ * BSOLVE in [1] using complete pivoting in the LU factorization.\n\ *\n\ * [1] Bo Kagstrom and Lars Westin,\n\ * Generalized Schur Methods with Condition Estimators for\n\ * Solving the Generalized Sylvester Equation, IEEE Transactions\n\ * on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.\n\ *\n\ * [2] Peter Poromaa,\n\ * On Efficient and Robust Estimators for the Separation\n\ * between two Regular Matrix Pairs with Applications in\n\ * Condition Estimation. Report IMINF-95.05, Departement of\n\ * Computing Science, Umea University, S-901 87 Umea, Sweden, 1995.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/csytrs20000644000175000017500000000524012502223525016621 0ustar uwabamiuwabami--- :name: csytrs2 :md5sum: ede0b063319e696fdadf1357131d6a98 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSYTRS2 solves a system of linear equations A*X = B with a COMPLEX\n\ * symmetric matrix A using the factorization A = U*D*U**T or\n\ * A = L*D*L**T computed by CSYTRF and converted by CSYCONV.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by CSYTRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by CSYTRF.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssytri0000644000175000017500000000503612502223526016551 0ustar uwabamiuwabami--- :name: ssytri :md5sum: c1b48ee1c822859d4ff01e02baede991 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSYTRI computes the inverse of a real symmetric indefinite matrix\n\ * A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n\ * SSYTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the block diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L as computed by SSYTRF.\n\ *\n\ * On exit, if INFO = 0, the (symmetric) inverse of the original\n\ * matrix. If UPLO = 'U', the upper triangular part of the\n\ * inverse is formed and the part of A below the diagonal is not\n\ * referenced; if UPLO = 'L' the lower triangular part of the\n\ * inverse is formed and the part of A above the diagonal is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by SSYTRF.\n\ *\n\ * WORK (workspace) REAL array, dimension (N)\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, D(i,i) = 0; the matrix is singular and its\n\ * inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cupmtr0000644000175000017500000000712412502223526016526 0ustar uwabamiuwabami--- :name: cupmtr :md5sum: 89521ca27f55bfeeba2a81b50aae3789 :category: :subroutine :arguments: - side: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - m*(m+1)/2 - tau: :type: complex :intent: input :dims: - m-1 - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CUPMTR overwrites the general complex M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'C': Q**H * C C * Q**H\n\ *\n\ * where Q is a complex unitary matrix of order nq, with nq = m if\n\ * SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of\n\ * nq-1 elementary reflectors, as returned by CHPTRD using packed\n\ * storage:\n\ *\n\ * if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);\n\ *\n\ * if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**H from the Left;\n\ * = 'R': apply Q or Q**H from the Right.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangular packed storage used in previous\n\ * call to CHPTRD;\n\ * = 'L': Lower triangular packed storage used in previous\n\ * call to CHPTRD.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q;\n\ * = 'C': Conjugate transpose, apply Q**H.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * AP (input) COMPLEX array, dimension\n\ * (M*(M+1)/2) if SIDE = 'L'\n\ * (N*(N+1)/2) if SIDE = 'R'\n\ * The vectors which define the elementary reflectors, as\n\ * returned by CHPTRD. AP is modified by the routine but\n\ * restored on exit.\n\ *\n\ * TAU (input) COMPLEX array, dimension (M-1) if SIDE = 'L'\n\ * or (N-1) if SIDE = 'R'\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by CHPTRD.\n\ *\n\ * C (input/output) COMPLEX array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension\n\ * (N) if SIDE = 'L'\n\ * (M) if SIDE = 'R'\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctptri0000644000175000017500000000520612502223525016517 0ustar uwabamiuwabami--- :name: ctptri :md5sum: 237746a719623b18e0c7de528f689bca :category: :subroutine :arguments: - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CTPTRI( UPLO, DIAG, N, AP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTPTRI computes the inverse of a complex upper or lower triangular\n\ * matrix A stored in packed format.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangular matrix A, stored\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n.\n\ * See below for further details.\n\ * On exit, the (triangular) inverse of the original matrix, in\n\ * the same packed storage format.\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, A(i,i) is exactly zero. The triangular\n\ * matrix is singular and its inverse can not be computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * A triangular matrix A can be transferred to packed storage using one\n\ * of the following program segments:\n\ *\n\ * UPLO = 'U': UPLO = 'L':\n\ *\n\ * JC = 1 JC = 1\n\ * DO 2 J = 1, N DO 2 J = 1, N\n\ * DO 1 I = 1, J DO 1 I = J, N\n\ * AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J)\n\ * 1 CONTINUE 1 CONTINUE\n\ * JC = JC + J JC = JC + N - J + 1\n\ * 2 CONTINUE 2 CONTINUE\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgeqpf0000644000175000017500000000645612502223526016471 0ustar uwabamiuwabami--- :name: dgeqpf :md5sum: 357c7be8c28d16facf6f9fa20d73b074 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: doublereal :intent: output :dims: - MIN(m,n) - work: :type: doublereal :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This routine is deprecated and has been replaced by routine DGEQP3.\n\ *\n\ * DGEQPF computes a QR factorization with column pivoting of a\n\ * real M-by-N matrix A: A*P = Q*R.\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 upper triangle of the array contains the\n\ * min(M,N)-by-N upper triangular matrix R; the elements\n\ * below the diagonal, together with the array TAU,\n\ * represent the orthogonal matrix Q as a product of\n\ * min(m,n) elementary reflectors.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * JPVT (input/output) INTEGER array, dimension (N)\n\ * On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n\ * to the front of A*P (a leading column); if JPVT(i) = 0,\n\ * the i-th column of A is a free column.\n\ * On exit, if JPVT(i) = k, then the i-th column of A*P\n\ * was the k-th column of A.\n\ *\n\ * TAU (output) DOUBLE PRECISION array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\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(1) H(2) . . . H(n)\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H = 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:m) is stored on exit in A(i+1:m,i).\n\ *\n\ * The matrix P is represented in jpvt as follows: If\n\ * jpvt(j) = i\n\ * then the jth column of P is the ith canonical unit vector.\n\ *\n\ * Partial column norm updating strategy modified by\n\ * Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n\ * University of Zagreb, Croatia.\n\ * June 2010\n\ * For more details see LAPACK Working Note 176.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slasd70000644000175000017500000002013112502223526016402 0ustar uwabamiuwabami--- :name: slasd7 :md5sum: 1ef52169218289276f4f7b635e2435f4 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - nl: :type: integer :intent: input - nr: :type: integer :intent: input - sqre: :type: integer :intent: input - k: :type: integer :intent: output - d: :type: real :intent: input/output :dims: - n - z: :type: real :intent: output :dims: - m - zw: :type: real :intent: workspace :dims: - m - vf: :type: real :intent: input/output :dims: - m - vfw: :type: real :intent: workspace :dims: - m - vl: :type: real :intent: input/output :dims: - m - vlw: :type: real :intent: workspace :dims: - m - alpha: :type: real :intent: input - beta: :type: real :intent: input - dsigma: :type: real :intent: output :dims: - n - idx: :type: integer :intent: workspace :dims: - n - idxp: :type: integer :intent: workspace :dims: - n - idxq: :type: integer :intent: input :dims: - n - perm: :type: integer :intent: output :dims: - n - givptr: :type: integer :intent: output - givcol: :type: integer :intent: output :dims: - ldgcol - "2" - ldgcol: :type: integer :intent: input - givnum: :type: real :intent: output :dims: - ldgnum - "2" - ldgnum: :type: integer :intent: input - c: :type: real :intent: output - s: :type: real :intent: output - info: :type: integer :intent: output :substitutions: ldgnum: n ldgcol: n :fortran_help: " SUBROUTINE SLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL, VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, C, S, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLASD7 merges the two sets of singular values together into a single\n\ * sorted set. Then it tries to deflate the size of the problem. There\n\ * are two ways in which deflation can occur: when two or more singular\n\ * values are close together or if there is a tiny entry in the Z\n\ * vector. For each such occurrence the order of the related\n\ * secular equation problem is reduced by one.\n\ *\n\ * SLASD7 is called from SLASD6.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ICOMPQ (input) INTEGER\n\ * Specifies whether singular vectors are to be computed\n\ * in compact form, as follows:\n\ * = 0: Compute singular values only.\n\ * = 1: Compute singular vectors of upper\n\ * bidiagonal matrix in compact form.\n\ *\n\ * NL (input) INTEGER\n\ * The row dimension of the upper block. NL >= 1.\n\ *\n\ * NR (input) INTEGER\n\ * The row dimension of the lower block. NR >= 1.\n\ *\n\ * SQRE (input) INTEGER\n\ * = 0: the lower block is an NR-by-NR square matrix.\n\ * = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n\ *\n\ * The bidiagonal matrix has\n\ * N = NL + NR + 1 rows and\n\ * M = N + SQRE >= N columns.\n\ *\n\ * K (output) INTEGER\n\ * Contains the dimension of the non-deflated matrix, this is\n\ * the order of the related secular equation. 1 <= K <=N.\n\ *\n\ * D (input/output) REAL array, dimension ( N )\n\ * On entry D contains the singular values of the two submatrices\n\ * to be combined. On exit D contains the trailing (N-K) updated\n\ * singular values (those which were deflated) sorted into\n\ * increasing order.\n\ *\n\ * Z (output) REAL array, dimension ( M )\n\ * On exit Z contains the updating row vector in the secular\n\ * equation.\n\ *\n\ * ZW (workspace) REAL array, dimension ( M )\n\ * Workspace for Z.\n\ *\n\ * VF (input/output) REAL array, dimension ( M )\n\ * On entry, VF(1:NL+1) contains the first components of all\n\ * right singular vectors of the upper block; and VF(NL+2:M)\n\ * contains the first components of all right singular vectors\n\ * of the lower block. On exit, VF contains the first components\n\ * of all right singular vectors of the bidiagonal matrix.\n\ *\n\ * VFW (workspace) REAL array, dimension ( M )\n\ * Workspace for VF.\n\ *\n\ * VL (input/output) REAL array, dimension ( M )\n\ * On entry, VL(1:NL+1) contains the last components of all\n\ * right singular vectors of the upper block; and VL(NL+2:M)\n\ * contains the last components of all right singular vectors\n\ * of the lower block. On exit, VL contains the last components\n\ * of all right singular vectors of the bidiagonal matrix.\n\ *\n\ * VLW (workspace) REAL array, dimension ( M )\n\ * Workspace for VL.\n\ *\n\ * ALPHA (input) REAL\n\ * Contains the diagonal element associated with the added row.\n\ *\n\ * BETA (input) REAL\n\ * Contains the off-diagonal element associated with the added\n\ * row.\n\ *\n\ * DSIGMA (output) REAL array, dimension ( N )\n\ * Contains a copy of the diagonal elements (K-1 singular values\n\ * and one zero) in the secular equation.\n\ *\n\ * IDX (workspace) INTEGER array, dimension ( N )\n\ * This will contain the permutation used to sort the contents of\n\ * D into ascending order.\n\ *\n\ * IDXP (workspace) INTEGER array, dimension ( N )\n\ * This will contain the permutation used to place deflated\n\ * values of D at the end of the array. On output IDXP(2:K)\n\ * points to the nondeflated D-values and IDXP(K+1:N)\n\ * points to the deflated singular values.\n\ *\n\ * IDXQ (input) INTEGER array, dimension ( N )\n\ * This contains the permutation which separately sorts the two\n\ * sub-problems in D into ascending order. Note that entries in\n\ * the first half of this permutation must first be moved one\n\ * position backward; and entries in the second half\n\ * must first have NL+1 added to their values.\n\ *\n\ * PERM (output) INTEGER array, dimension ( N )\n\ * The permutations (from deflation and sorting) to be applied\n\ * to each singular block. Not referenced if ICOMPQ = 0.\n\ *\n\ * GIVPTR (output) INTEGER\n\ * The number of Givens rotations which took place in this\n\ * subproblem. Not referenced if ICOMPQ = 0.\n\ *\n\ * GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )\n\ * Each pair of numbers indicates a pair of columns to take place\n\ * in a Givens rotation. Not referenced if ICOMPQ = 0.\n\ *\n\ * LDGCOL (input) INTEGER\n\ * The leading dimension of GIVCOL, must be at least N.\n\ *\n\ * GIVNUM (output) REAL array, dimension ( LDGNUM, 2 )\n\ * Each number indicates the C or S value to be used in the\n\ * corresponding Givens rotation. Not referenced if ICOMPQ = 0.\n\ *\n\ * LDGNUM (input) INTEGER\n\ * The leading dimension of GIVNUM, must be at least N.\n\ *\n\ * C (output) REAL\n\ * C contains garbage if SQRE =0 and the C-value of a Givens\n\ * rotation related to the right null space if SQRE = 1.\n\ *\n\ * S (output) REAL\n\ * S contains garbage if SQRE =0 and the S-value of a Givens\n\ * rotation related to the right null space if SQRE = 1.\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\ * Based on contributions by\n\ * Ming Gu and Huan Ren, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgttrf0000644000175000017500000000607312502223525016506 0ustar uwabamiuwabami--- :name: cgttrf :md5sum: 113d7a17d7e56d36b76493ceda5cfa3e :category: :subroutine :arguments: - n: :type: integer :intent: input - dl: :type: complex :intent: input/output :dims: - n-1 - d: :type: complex :intent: input/output :dims: - n - du: :type: complex :intent: input/output :dims: - n-1 - du2: :type: complex :intent: output :dims: - n-2 - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGTTRF( N, DL, D, DU, DU2, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGTTRF computes an LU factorization of a complex tridiagonal matrix A\n\ * using elimination with partial pivoting and row interchanges.\n\ *\n\ * The factorization has the form\n\ * A = L * U\n\ * where L is a product of permutation and unit lower bidiagonal\n\ * matrices and U is upper triangular with nonzeros in only the main\n\ * diagonal and first two superdiagonals.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A.\n\ *\n\ * DL (input/output) COMPLEX array, dimension (N-1)\n\ * On entry, DL must contain the (n-1) sub-diagonal elements of\n\ * A.\n\ *\n\ * On exit, DL is overwritten by the (n-1) multipliers that\n\ * define the matrix L from the LU factorization of A.\n\ *\n\ * D (input/output) COMPLEX array, dimension (N)\n\ * On entry, D must contain the diagonal elements of A.\n\ *\n\ * On exit, D is overwritten by the n diagonal elements of the\n\ * upper triangular matrix U from the LU factorization of A.\n\ *\n\ * DU (input/output) COMPLEX array, dimension (N-1)\n\ * On entry, DU must contain the (n-1) super-diagonal elements\n\ * of A.\n\ *\n\ * On exit, DU is overwritten by the (n-1) elements of the first\n\ * super-diagonal of U.\n\ *\n\ * DU2 (output) COMPLEX array, dimension (N-2)\n\ * On exit, DU2 is overwritten by the (n-2) elements of the\n\ * second super-diagonal of U.\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * The pivot indices; for 1 <= i <= n, row i of the matrix was\n\ * interchanged with row IPIV(i). IPIV(i) will always be either\n\ * i or i+1; IPIV(i) = i indicates a row interchange was not\n\ * required.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ * > 0: if INFO = k, U(k,k) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, and division by zero will occur if it is used\n\ * to solve a system of equations.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zggsvp0000644000175000017500000001557012502223526016540 0ustar uwabamiuwabami--- :name: zggsvp :md5sum: fac9d59192d94c42c95f56a73f97a717 :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobv: :type: char :intent: input - jobq: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - tola: :type: doublereal :intent: input - tolb: :type: doublereal :intent: input - k: :type: integer :intent: output - l: :type: integer :intent: output - u: :type: doublecomplex :intent: output :dims: - ldu - m - ldu: :type: integer :intent: input - v: :type: doublecomplex :intent: output :dims: - ldv - p - ldv: :type: integer :intent: input - q: :type: doublecomplex :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - iwork: :type: integer :intent: workspace :dims: - n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - tau: :type: doublecomplex :intent: workspace :dims: - n - work: :type: doublecomplex :intent: workspace :dims: - MAX(3*n,m - p) - info: :type: integer :intent: output :substitutions: m: lda p: ldb ldq: "lsame_(&jobq,\"Q\") ? MAX(1,n) : 1" ldu: "lsame_(&jobu,\"U\") ? MAX(1,m) : 1" ldv: "lsame_(&jobv,\"V\") ? MAX(1,p) : 1" :fortran_help: " SUBROUTINE ZGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, RWORK, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGGSVP computes unitary matrices U, V and Q such that\n\ *\n\ * N-K-L K L\n\ * U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0;\n\ * L ( 0 0 A23 )\n\ * M-K-L ( 0 0 0 )\n\ *\n\ * N-K-L K L\n\ * = K ( 0 A12 A13 ) if M-K-L < 0;\n\ * M-K ( 0 0 A23 )\n\ *\n\ * N-K-L K L\n\ * V'*B*Q = L ( 0 0 B13 )\n\ * P-L ( 0 0 0 )\n\ *\n\ * where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n\ * upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n\ * otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective\n\ * numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the\n\ * conjugate transpose of Z.\n\ *\n\ * This decomposition is the preprocessing step for computing the\n\ * Generalized Singular Value Decomposition (GSVD), see subroutine\n\ * ZGGSVD.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBU (input) CHARACTER*1\n\ * = 'U': Unitary matrix U is computed;\n\ * = 'N': U is not computed.\n\ *\n\ * JOBV (input) CHARACTER*1\n\ * = 'V': Unitary matrix V is computed;\n\ * = 'N': V is not computed.\n\ *\n\ * JOBQ (input) CHARACTER*1\n\ * = 'Q': Unitary matrix Q is computed;\n\ * = 'N': Q is not computed.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A. M >= 0.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows of the matrix B. P >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, A contains the triangular (or trapezoidal) matrix\n\ * described in the Purpose section.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,N)\n\ * On entry, the P-by-N matrix B.\n\ * On exit, B contains the triangular matrix described in\n\ * the Purpose section.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,P).\n\ *\n\ * TOLA (input) DOUBLE PRECISION\n\ * TOLB (input) DOUBLE PRECISION\n\ * TOLA and TOLB are the thresholds to determine the effective\n\ * numerical rank of matrix B and a subblock of A. Generally,\n\ * they are set to\n\ * TOLA = MAX(M,N)*norm(A)*MAZHEPS,\n\ * TOLB = MAX(P,N)*norm(B)*MAZHEPS.\n\ * The size of TOLA and TOLB may affect the size of backward\n\ * errors of the decomposition.\n\ *\n\ * K (output) INTEGER\n\ * L (output) INTEGER\n\ * On exit, K and L specify the dimension of the subblocks\n\ * described in Purpose section.\n\ * K + L = effective numerical rank of (A',B')'.\n\ *\n\ * U (output) COMPLEX*16 array, dimension (LDU,M)\n\ * If JOBU = 'U', U contains the unitary matrix U.\n\ * If JOBU = 'N', U is not referenced.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= max(1,M) if\n\ * JOBU = 'U'; LDU >= 1 otherwise.\n\ *\n\ * V (output) COMPLEX*16 array, dimension (LDV,P)\n\ * If JOBV = 'V', V contains the unitary matrix V.\n\ * If JOBV = 'N', V is not referenced.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V. LDV >= max(1,P) if\n\ * JOBV = 'V'; LDV >= 1 otherwise.\n\ *\n\ * Q (output) COMPLEX*16 array, dimension (LDQ,N)\n\ * If JOBQ = 'Q', Q contains the unitary matrix Q.\n\ * If JOBQ = 'N', Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N) if\n\ * JOBQ = 'Q'; LDQ >= 1 otherwise.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n\ *\n\ * TAU (workspace) COMPLEX*16 array, dimension (N)\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (max(3*N,M,P))\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 subroutine uses LAPACK subroutine ZGEQPF for the QR factorization\n\ * with column pivoting to detect the effective numerical rank of the\n\ * a matrix. It may be replaced by a better rank determination strategy.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slaed80000644000175000017500000001621712502223526016377 0ustar uwabamiuwabami--- :name: slaed8 :md5sum: 695bf39ffc8e6dd4d22f1ba3685aeddc :category: :subroutine :arguments: - icompq: :type: integer :intent: input - k: :type: integer :intent: output - n: :type: integer :intent: input - qsiz: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - q: :type: real :intent: input/output :dims: - "icompq==0 ? 0 : ldq" - "icompq==0 ? 0 : n" - ldq: :type: integer :intent: input - indxq: :type: integer :intent: input :dims: - n - rho: :type: real :intent: input/output - cutpnt: :type: integer :intent: input - z: :type: real :intent: input :dims: - n - dlamda: :type: real :intent: output :dims: - n - q2: :type: real :intent: output :dims: - "icompq==0 ? 0 : ldq2" - "icompq==0 ? 0 : n" - ldq2: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - perm: :type: integer :intent: output :dims: - n - givptr: :type: integer :intent: output - givcol: :type: integer :intent: output :dims: - "2" - n - givnum: :type: real :intent: output :dims: - "2" - n - indxp: :type: integer :intent: workspace :dims: - n - indx: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldq2: MAX(1,n) :fortran_help: " SUBROUTINE SLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR, GIVCOL, GIVNUM, INDXP, INDX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAED8 merges the two sets of eigenvalues together into a single\n\ * sorted set. Then it tries to deflate the size of the problem.\n\ * There are two ways in which deflation can occur: when two or more\n\ * eigenvalues are close together or if there is a tiny element in the\n\ * Z vector. For each such occurrence the order of the related secular\n\ * equation problem is reduced by one.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ICOMPQ (input) INTEGER\n\ * = 0: Compute eigenvalues only.\n\ * = 1: Compute eigenvectors of original dense symmetric matrix\n\ * also. On entry, Q contains the orthogonal matrix used\n\ * to reduce the original matrix to tridiagonal form.\n\ *\n\ * K (output) INTEGER\n\ * The number of non-deflated eigenvalues, and the order of the\n\ * related secular equation.\n\ *\n\ * N (input) INTEGER\n\ * The dimension of the symmetric tridiagonal matrix. N >= 0.\n\ *\n\ * QSIZ (input) INTEGER\n\ * The dimension of the orthogonal matrix used to reduce\n\ * the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the eigenvalues of the two submatrices to be\n\ * combined. On exit, the trailing (N-K) updated eigenvalues\n\ * (those which were deflated) sorted into increasing order.\n\ *\n\ * Q (input/output) REAL array, dimension (LDQ,N)\n\ * If ICOMPQ = 0, Q is not referenced. Otherwise,\n\ * on entry, Q contains the eigenvectors of the partially solved\n\ * system which has been previously updated in matrix\n\ * multiplies with other partially solved eigensystems.\n\ * On exit, Q contains the trailing (N-K) updated eigenvectors\n\ * (those which were deflated) in its last N-K columns.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N).\n\ *\n\ * INDXQ (input) INTEGER array, dimension (N)\n\ * The permutation which separately sorts the two sub-problems\n\ * in D into ascending order. Note that elements in the second\n\ * half of this permutation must first have CUTPNT added to\n\ * their values in order to be accurate.\n\ *\n\ * RHO (input/output) REAL\n\ * On entry, the off-diagonal element associated with the rank-1\n\ * cut which originally split the two submatrices which are now\n\ * being recombined.\n\ * On exit, RHO has been modified to the value required by\n\ * SLAED3.\n\ *\n\ * CUTPNT (input) INTEGER\n\ * The location of the last eigenvalue in the leading\n\ * sub-matrix. min(1,N) <= CUTPNT <= N.\n\ *\n\ * Z (input) REAL array, dimension (N)\n\ * On entry, Z contains the updating vector (the last row of\n\ * the first sub-eigenvector matrix and the first row of the\n\ * second sub-eigenvector matrix).\n\ * On exit, the contents of Z are destroyed by the updating\n\ * process.\n\ *\n\ * DLAMDA (output) REAL array, dimension (N)\n\ * A copy of the first K eigenvalues which will be used by\n\ * SLAED3 to form the secular equation.\n\ *\n\ * Q2 (output) REAL array, dimension (LDQ2,N)\n\ * If ICOMPQ = 0, Q2 is not referenced. Otherwise,\n\ * a copy of the first K eigenvectors which will be used by\n\ * SLAED7 in a matrix multiply (SGEMM) to update the new\n\ * eigenvectors.\n\ *\n\ * LDQ2 (input) INTEGER\n\ * The leading dimension of the array Q2. LDQ2 >= max(1,N).\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * The first k values of the final deflation-altered z-vector and\n\ * will be passed to SLAED3.\n\ *\n\ * PERM (output) INTEGER array, dimension (N)\n\ * The permutations (from deflation and sorting) to be applied\n\ * to each eigenblock.\n\ *\n\ * GIVPTR (output) INTEGER\n\ * The number of Givens rotations which took place in this\n\ * subproblem.\n\ *\n\ * GIVCOL (output) INTEGER array, dimension (2, N)\n\ * Each pair of numbers indicates a pair of columns to take place\n\ * in a Givens rotation.\n\ *\n\ * GIVNUM (output) REAL array, dimension (2, N)\n\ * Each number indicates the S value to be used in the\n\ * corresponding Givens rotation.\n\ *\n\ * INDXP (workspace) INTEGER array, dimension (N)\n\ * The permutation used to place deflated values of D at the end\n\ * of the array. INDXP(1:K) points to the nondeflated D-values\n\ * and INDXP(K+1:N) points to the deflated eigenvalues.\n\ *\n\ * INDX (workspace) INTEGER array, dimension (N)\n\ * The permutation used to sort the contents of D into ascending\n\ * order.\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\ * Based on contributions by\n\ * Jeff Rutter, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/spbsvx0000644000175000017500000002741512502223526016546 0ustar uwabamiuwabami--- :name: spbsvx :md5sum: 3f219c9aaa3650653085d61fe2a5f6c7 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: real :intent: input/output :dims: - ldafb - n - ldafb: :type: integer :intent: input - equed: :type: char :intent: input/output - s: :type: real :intent: input/output :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE SPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPBSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to\n\ * compute the solution to a real system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N symmetric positive definite band matrix and X\n\ * and B are N-by-NRHS matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', real scaling factors are computed to equilibrate\n\ * the system:\n\ * diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n\ *\n\ * 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n\ * factor the matrix A (after equilibration if FACT = 'E') as\n\ * A = U**T * U, if UPLO = 'U', or\n\ * A = L * L**T, if UPLO = 'L',\n\ * where U is an upper triangular band matrix, and L is a lower\n\ * triangular band matrix.\n\ *\n\ * 3. If the leading i-by-i principal minor is not positive definite,\n\ * then the routine returns with INFO = i. Otherwise, the factored\n\ * form of A is used to estimate the condition number of the matrix\n\ * A. If the reciprocal of the condition number is less than machine\n\ * precision, INFO = N+1 is returned as a warning, but the routine\n\ * still goes on to solve for X and compute error bounds as\n\ * described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(S) so that it solves the original system before\n\ * equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AFB contains the factored form of A.\n\ * If EQUED = 'Y', the matrix A has been equilibrated\n\ * with scaling factors given by S. AB and AFB will not\n\ * be modified.\n\ * = 'N': The matrix A will be copied to AFB and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AFB and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right-hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AB (input/output) REAL array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first KD+1 rows of the array, except\n\ * if FACT = 'F' and EQUED = 'Y', then A must contain the\n\ * equilibrated matrix diag(S)*A*diag(S). The j-th column of A\n\ * is stored in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).\n\ * See below for further details.\n\ *\n\ * On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n\ * diag(S)*A*diag(S).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array A. LDAB >= KD+1.\n\ *\n\ * AFB (input or output) REAL array, dimension (LDAFB,N)\n\ * If FACT = 'F', then AFB is an input argument and on entry\n\ * contains the triangular factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T of the band matrix\n\ * A, in the same storage format as A (see AB). If EQUED = 'Y',\n\ * then AFB is the factored form of the equilibrated matrix A.\n\ *\n\ * If FACT = 'N', then AFB is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T.\n\ *\n\ * If FACT = 'E', then AFB is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T of the equilibrated\n\ * matrix A (see the description of A for the form of the\n\ * equilibrated matrix).\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= KD+1.\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'Y': Equilibration was done, i.e., A has been replaced by\n\ * diag(S) * A * diag(S).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * S (input or output) REAL array, dimension (N)\n\ * The scale factors for A; not accessed if EQUED = 'N'. S is\n\ * an input argument if FACT = 'F'; otherwise, S is an output\n\ * argument. If FACT = 'F' and EQUED = 'Y', each element of S\n\ * must be positive.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n\ * B is overwritten by diag(S) * B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) REAL array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n\ * the original system of equations. Note that if EQUED = 'Y',\n\ * A and B are modified on exit, and the solution to the\n\ * equilibrated system is inv(diag(S))*X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A after equilibration (if done). If RCOND is less than the\n\ * machine precision (in particular, if RCOND = 0), the matrix\n\ * is singular to working precision. This condition is\n\ * indicated by a return code of INFO > 0.\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) REAL array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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, and i is\n\ * <= N: the leading minor of order i of A is\n\ * not positive definite, so the factorization\n\ * could not be completed, and the solution has not\n\ * been computed. RCOND = 0 is returned.\n\ * = N+1: U is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * N = 6, KD = 2, and UPLO = 'U':\n\ *\n\ * Two-dimensional storage of the symmetric matrix A:\n\ *\n\ * a11 a12 a13\n\ * a22 a23 a24\n\ * a33 a34 a35\n\ * a44 a45 a46\n\ * a55 a56\n\ * (aij=conjg(aji)) a66\n\ *\n\ * Band storage of the upper triangle of A:\n\ *\n\ * * * a13 a24 a35 a46\n\ * * a12 a23 a34 a45 a56\n\ * a11 a22 a33 a44 a55 a66\n\ *\n\ * Similarly, if UPLO = 'L' the format of A is as follows:\n\ *\n\ * a11 a22 a33 a44 a55 a66\n\ * a21 a32 a43 a54 a65 *\n\ * a31 a42 a53 a64 * *\n\ *\n\ * Array elements marked * are not used by the routine.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dspgvd0000644000175000017500000001607512502223526016510 0ustar uwabamiuwabami--- :name: dspgvd :md5sum: d8feb9f109926c26daeabbe88286ca5a :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - ldap - bp: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 2*n : lsame_(&jobz,\"V\") ? 1+6*n+2*n*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "(lsame_(&jobz,\"N\")||n<=1) ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE DSPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSPGVD computes all the eigenvalues, and optionally, the eigenvectors\n\ * of a real generalized symmetric-definite eigenproblem, of the form\n\ * A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n\ * B are assumed to be symmetric, stored in packed format, and B is also\n\ * positive definite.\n\ * If eigenvectors are desired, it uses a divide and conquer algorithm.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * Specifies the problem type to be solved:\n\ * = 1: A*x = (lambda)*B*x\n\ * = 2: A*B*x = (lambda)*x\n\ * = 3: B*A*x = (lambda)*x\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, the contents of AP are destroyed.\n\ *\n\ * BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * B, packed columnwise in a linear array. The j-th column of B\n\ * is stored in the array BP as follows:\n\ * if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n\ *\n\ * On exit, the triangular factor U or L from the Cholesky\n\ * factorization B = U**T*U or B = L*L**T, in the same storage\n\ * format as B.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n\ * eigenvectors. The eigenvectors are normalized as follows:\n\ * if ITYPE = 1 or 2, Z**T*B*Z = I;\n\ * if ITYPE = 3, Z**T*inv(B)*Z = I.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the required LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK.\n\ * If N <= 1, LWORK >= 1.\n\ * If JOBZ = 'N' and N > 1, LWORK >= 2*N.\n\ * If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the required sizes of the WORK and IWORK\n\ * arrays, returns these values as the first entries of the WORK\n\ * and IWORK arrays, and no error message related to LWORK or\n\ * LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK.\n\ * If JOBZ = 'N' or N <= 1, LIWORK >= 1.\n\ * If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the required sizes of the WORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK and IWORK arrays, and no error message related to\n\ * LWORK or LIWORK 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: DPPTRF or DSPEVD returned an error code:\n\ * <= N: if INFO = i, DSPEVD failed to converge;\n\ * i off-diagonal elements of an intermediate\n\ * tridiagonal form did not converge to zero;\n\ * > N: if INFO = N + i, for 1 <= i <= N, then the leading\n\ * minor of order i of B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cheev0000644000175000017500000000702612502223525016306 0ustar uwabamiuwabami--- :name: cheev :md5sum: 149dbe00ca97a680aa0d60555b346c6d :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n-1 - rwork: :type: real :intent: workspace :dims: - MAX(1, 3*n-2) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHEEV computes all eigenvalues and, optionally, eigenvectors of a\n\ * complex Hermitian matrix A.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA, N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of A contains the\n\ * upper triangular part of the matrix A. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of A contains\n\ * the lower triangular part of the matrix A.\n\ * On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n\ * orthonormal eigenvectors of the matrix A.\n\ * If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n\ * or the upper triangle (if UPLO='U') of A, including the\n\ * diagonal, is destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of the array WORK. LWORK >= max(1,2*N-1).\n\ * For optimal efficiency, LWORK >= (NB+1)*N,\n\ * where NB is the blocksize for CHETRD returned by ILAENV.\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\ * RWORK (workspace) REAL array, dimension (max(1, 3*N-2))\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 algorithm failed to converge; i\n\ * off-diagonal elements of an intermediate tridiagonal\n\ * form did not converge to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zspsv0000644000175000017500000001155312502223526016402 0ustar uwabamiuwabami--- :name: zspsv :md5sum: 26289b85325f5450899fbb59ff11eb24 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: output :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: n: ldb :fortran_help: " SUBROUTINE ZSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSPSV computes the solution to a complex system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N symmetric matrix stored in packed format and X\n\ * and B are N-by-NRHS matrices.\n\ *\n\ * The diagonal pivoting method is used to factor A as\n\ * A = U * D * U**T, if UPLO = 'U', or\n\ * A = L * D * L**T, if UPLO = 'L',\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, D is symmetric and block diagonal with 1-by-1\n\ * and 2-by-2 diagonal blocks. The factored form of A is then used to\n\ * solve the system of equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ * See below for further details.\n\ *\n\ * On exit, the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L from the factorization\n\ * A = U*D*U**T or A = L*D*L**T as computed by ZSPTRF, stored as\n\ * a packed triangular matrix in the same storage format as A.\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D, as\n\ * determined by ZSPTRF. If IPIV(k) > 0, then rows and columns\n\ * k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n\ * diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n\ * then rows and columns k-1 and -IPIV(k) were interchanged and\n\ * D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n\ * IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n\ * -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n\ * diagonal block.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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, D(i,i) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular, so the solution could not be\n\ * computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The packed storage scheme is illustrated by the following example\n\ * when N = 4, UPLO = 'U':\n\ *\n\ * Two-dimensional storage of the symmetric matrix A:\n\ *\n\ * a11 a12 a13 a14\n\ * a22 a23 a24\n\ * a33 a34 (aij = aji)\n\ * a44\n\ *\n\ * Packed storage of the upper triangle of A:\n\ *\n\ * AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n\ *\n\ * =====================================================================\n\ *\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZSPTRF, ZSPTRS\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dhsein0000644000175000017500000002141412502223526016464 0ustar uwabamiuwabami--- :name: dhsein :md5sum: f1f28c22000db86e9f2f6f69e7dba216 :category: :subroutine :arguments: - side: :type: char :intent: input - eigsrc: :type: char :intent: input - initv: :type: char :intent: input - select: :type: logical :intent: input/output :dims: - n - n: :type: integer :intent: input - h: :type: doublereal :intent: input :dims: - ldh - n - ldh: :type: integer :intent: input - wr: :type: doublereal :intent: input/output :dims: - n - wi: :type: doublereal :intent: input :dims: - n - vl: :type: doublereal :intent: input/output :dims: - ldvl - mm - ldvl: :type: integer :intent: input - vr: :type: doublereal :intent: input/output :dims: - ldvr - mm - ldvr: :type: integer :intent: input - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: doublereal :intent: workspace :dims: - (n+2)*n - ifaill: :type: integer :intent: output :dims: - mm - ifailr: :type: integer :intent: output :dims: - mm - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI, VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL, IFAILR, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DHSEIN uses inverse iteration to find specified right and/or left\n\ * eigenvectors of a real upper Hessenberg matrix H.\n\ *\n\ * The right eigenvector x and the left eigenvector y of the matrix H\n\ * corresponding to an eigenvalue w are defined by:\n\ *\n\ * H * x = w * x, y**h * H = w * y**h\n\ *\n\ * where y**h denotes the conjugate transpose of the vector y.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'R': compute right eigenvectors only;\n\ * = 'L': compute left eigenvectors only;\n\ * = 'B': compute both right and left eigenvectors.\n\ *\n\ * EIGSRC (input) CHARACTER*1\n\ * Specifies the source of eigenvalues supplied in (WR,WI):\n\ * = 'Q': the eigenvalues were found using DHSEQR; thus, if\n\ * H has zero subdiagonal elements, and so is\n\ * block-triangular, then the j-th eigenvalue can be\n\ * assumed to be an eigenvalue of the block containing\n\ * the j-th row/column. This property allows DHSEIN to\n\ * perform inverse iteration on just one diagonal block.\n\ * = 'N': no assumptions are made on the correspondence\n\ * between eigenvalues and diagonal blocks. In this\n\ * case, DHSEIN must always perform inverse iteration\n\ * using the whole matrix H.\n\ *\n\ * INITV (input) CHARACTER*1\n\ * = 'N': no initial vectors are supplied;\n\ * = 'U': user-supplied initial vectors are stored in the arrays\n\ * VL and/or VR.\n\ *\n\ * SELECT (input/output) LOGICAL array, dimension (N)\n\ * Specifies the eigenvectors to be computed. To select the\n\ * real eigenvector corresponding to a real eigenvalue WR(j),\n\ * SELECT(j) must be set to .TRUE.. To select the complex\n\ * eigenvector corresponding to a complex eigenvalue\n\ * (WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)),\n\ * either SELECT(j) or SELECT(j+1) or both must be set to\n\ * .TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is\n\ * .FALSE..\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H. N >= 0.\n\ *\n\ * H (input) DOUBLE PRECISION array, dimension (LDH,N)\n\ * The upper Hessenberg matrix H.\n\ *\n\ * LDH (input) INTEGER\n\ * The leading dimension of the array H. LDH >= max(1,N).\n\ *\n\ * WR (input/output) DOUBLE PRECISION array, dimension (N)\n\ * WI (input) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the real and imaginary parts of the eigenvalues of\n\ * H; a complex conjugate pair of eigenvalues must be stored in\n\ * consecutive elements of WR and WI.\n\ * On exit, WR may have been altered since close eigenvalues\n\ * are perturbed slightly in searching for independent\n\ * eigenvectors.\n\ *\n\ * VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)\n\ * On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must\n\ * contain starting vectors for the inverse iteration for the\n\ * left eigenvectors; the starting vector for each eigenvector\n\ * must be in the same column(s) in which the eigenvector will\n\ * be stored.\n\ * On exit, if SIDE = 'L' or 'B', the left eigenvectors\n\ * specified by SELECT will be stored consecutively in the\n\ * columns of VL, in the same order as their eigenvalues. A\n\ * complex eigenvector corresponding to a complex eigenvalue is\n\ * stored in two consecutive columns, the first holding the real\n\ * part and the second the imaginary part.\n\ * If SIDE = 'R', VL is not referenced.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the array VL.\n\ * LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.\n\ *\n\ * VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)\n\ * On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must\n\ * contain starting vectors for the inverse iteration for the\n\ * right eigenvectors; the starting vector for each eigenvector\n\ * must be in the same column(s) in which the eigenvector will\n\ * be stored.\n\ * On exit, if SIDE = 'R' or 'B', the right eigenvectors\n\ * specified by SELECT will be stored consecutively in the\n\ * columns of VR, in the same order as their eigenvalues. A\n\ * complex eigenvector corresponding to a complex eigenvalue is\n\ * stored in two consecutive columns, the first holding the real\n\ * part and the second the imaginary part.\n\ * If SIDE = 'L', VR is not referenced.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the array VR.\n\ * LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.\n\ *\n\ * MM (input) INTEGER\n\ * The number of columns in the arrays VL and/or VR. MM >= M.\n\ *\n\ * M (output) INTEGER\n\ * The number of columns in the arrays VL and/or VR required to\n\ * store the eigenvectors; each selected real eigenvector\n\ * occupies one column and each selected complex eigenvector\n\ * occupies two columns.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension ((N+2)*N)\n\ *\n\ * IFAILL (output) INTEGER array, dimension (MM)\n\ * If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left\n\ * eigenvector in the i-th column of VL (corresponding to the\n\ * eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the\n\ * eigenvector converged satisfactorily. If the i-th and (i+1)th\n\ * columns of VL hold a complex eigenvector, then IFAILL(i) and\n\ * IFAILL(i+1) are set to the same value.\n\ * If SIDE = 'R', IFAILL is not referenced.\n\ *\n\ * IFAILR (output) INTEGER array, dimension (MM)\n\ * If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right\n\ * eigenvector in the i-th column of VR (corresponding to the\n\ * eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the\n\ * eigenvector converged satisfactorily. If the i-th and (i+1)th\n\ * columns of VR hold a complex eigenvector, then IFAILR(i) and\n\ * IFAILR(i+1) are set to the same value.\n\ * If SIDE = 'L', IFAILR is not referenced.\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, i is the number of eigenvectors which\n\ * failed to converge; see IFAILL and IFAILR for further\n\ * details.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Each eigenvector is normalized so that the element of largest\n\ * magnitude has magnitude 1; here the magnitude of a complex number\n\ * (x,y) is taken to be |x|+|y|.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/strsyl0000644000175000017500000000774612502223526016566 0ustar uwabamiuwabami--- :name: strsyl :md5sum: 650bfc17167d0bb5e57a982981f61818 :category: :subroutine :arguments: - trana: :type: char :intent: input - tranb: :type: char :intent: input - isgn: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - m - lda: :type: integer :intent: input - b: :type: real :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - scale: :type: real :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE STRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, SCALE, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STRSYL solves the real Sylvester matrix equation:\n\ *\n\ * op(A)*X + X*op(B) = scale*C or\n\ * op(A)*X - X*op(B) = scale*C,\n\ *\n\ * where op(A) = A or A**T, and A and B are both upper quasi-\n\ * triangular. A is M-by-M and B is N-by-N; the right hand side C and\n\ * the solution X are M-by-N; and scale is an output scale factor, set\n\ * <= 1 to avoid overflow in X.\n\ *\n\ * A and B must be in Schur canonical form (as returned by SHSEQR), that\n\ * is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks;\n\ * each 2-by-2 diagonal block has its diagonal elements equal and its\n\ * off-diagonal elements of opposite sign.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANA (input) CHARACTER*1\n\ * Specifies the option op(A):\n\ * = 'N': op(A) = A (No transpose)\n\ * = 'T': op(A) = A**T (Transpose)\n\ * = 'C': op(A) = A**H (Conjugate transpose = Transpose)\n\ *\n\ * TRANB (input) CHARACTER*1\n\ * Specifies the option op(B):\n\ * = 'N': op(B) = B (No transpose)\n\ * = 'T': op(B) = B**T (Transpose)\n\ * = 'C': op(B) = B**H (Conjugate transpose = Transpose)\n\ *\n\ * ISGN (input) INTEGER\n\ * Specifies the sign in the equation:\n\ * = +1: solve op(A)*X + X*op(B) = scale*C\n\ * = -1: solve op(A)*X - X*op(B) = scale*C\n\ *\n\ * M (input) INTEGER\n\ * The order of the matrix A, and the number of rows in the\n\ * matrices X and C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix B, and the number of columns in the\n\ * matrices X and C. N >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,M)\n\ * The upper quasi-triangular matrix A, in Schur canonical form.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input) REAL array, dimension (LDB,N)\n\ * The upper quasi-triangular matrix B, in Schur canonical form.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * C (input/output) REAL array, dimension (LDC,N)\n\ * On entry, the M-by-N right hand side matrix C.\n\ * On exit, C is overwritten by the solution matrix X.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M)\n\ *\n\ * SCALE (output) REAL\n\ * The scale factor, scale, set <= 1 to avoid overflow in X.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * = 1: A and B have common or very close eigenvalues; perturbed\n\ * values were used to solve the equation (but the matrices\n\ * A and B are unchanged).\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cherfsx0000644000175000017500000003733612502223525016665 0ustar uwabamiuwabami--- :name: cherfsx :md5sum: 8e75c5c0cefc0676f16ef4c51513f6e6 :category: :subroutine :arguments: - uplo: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - s: :type: real :intent: input/output :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " SUBROUTINE CHERFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHERFSX improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is Hermitian indefinite, and\n\ * provides error bounds and backward error estimates for the\n\ * solution. In addition to normwise error bound, the code provides\n\ * maximum componentwise error bound if possible. See comments for\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.\n\ *\n\ * The original system of linear equations may have been equilibrated\n\ * before calling this routine, as described by arguments EQUED and S\n\ * below. In this case, the solution and error bounds returned are\n\ * for the original unequilibrated system.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * EQUED (input) CHARACTER*1\n\ * Specifies the form of equilibration that was done to A\n\ * before calling this routine. This is needed to compute\n\ * the solution and error bounds correctly.\n\ * = 'N': No equilibration\n\ * = 'Y': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(S) * A * diag(S).\n\ * The right hand side B has been changed accordingly.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular\n\ * part of the matrix A, and the strictly lower triangular\n\ * part of A is not referenced. If UPLO = 'L', the leading\n\ * N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX array, dimension (LDAF,N)\n\ * The factored form of the matrix A. AF contains the block\n\ * diagonal matrix D and the multipliers used to obtain the\n\ * factor U or L from the factorization A = U*D*U**T or A =\n\ * L*D*L**T as computed by SSYTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by SSYTRF.\n\ *\n\ * S (input or output) REAL array, dimension (N)\n\ * The scale factors for A. If EQUED = 'Y', A is multiplied on\n\ * the left and right by diag(S). S is an input argument if FACT =\n\ * 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n\ * = 'Y', each element of S must be positive. If S is output, each\n\ * element of S is a power of the radix. If S is input, each element\n\ * of S should be a power of the radix to ensure a reliable solution\n\ * and error estimates. Scaling by powers of the radix does not cause\n\ * rounding errors unless the result underflows or overflows.\n\ * Rounding errors during scaling lead to refining with a matrix that\n\ * is not equivalent to the input matrix, producing error estimates\n\ * that may not be reliable.\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) COMPLEX array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by SGETRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * Componentwise relative backward error. This is the\n\ * componentwise relative backward error of each solution vector X(j)\n\ * (i.e., the smallest relative change in any element of A or B that\n\ * makes X(j) an exact solution).\n\ *\n\ * N_ERR_BNDS (input) INTEGER\n\ * Number of error bounds to return for each right hand side\n\ * and each type (normwise or componentwise). See ERR_BNDS_NORM and\n\ * ERR_BNDS_COMP below.\n\ *\n\ * ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * NPARAMS (input) INTEGER\n\ * Specifies the number of parameters set in PARAMS. If .LE. 0, the\n\ * PARAMS array is never referenced and default values are used.\n\ *\n\ * PARAMS (input / output) REAL array, dimension NPARAMS\n\ * Specifies algorithm parameters. If an entry is .LT. 0.0, then\n\ * that entry will be filled with default value used for that\n\ * parameter. Only positions up to NPARAMS are accessed; defaults\n\ * are used for higher-numbered parameters.\n\ *\n\ * PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n\ * refinement or not.\n\ * Default: 1.0\n\ * = 0.0 : No refinement is performed, and no error bounds are\n\ * computed.\n\ * = 1.0 : Use the double-precision refinement algorithm,\n\ * possibly with doubled-single computations if the\n\ * compilation environment does not support DOUBLE\n\ * PRECISION.\n\ * (other values are reserved for future use)\n\ *\n\ * PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n\ * computations allowed for refinement.\n\ * Default: 10\n\ * Aggressive: Set to 100 to permit convergence using approximate\n\ * factorizations or factorizations other than LU. If\n\ * the factorization uses a technique other than\n\ * Gaussian elimination, the guarantees in\n\ * err_bnds_norm and err_bnds_comp may no longer be\n\ * trustworthy.\n\ *\n\ * PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n\ * will attempt to find a solution with small componentwise\n\ * relative error in the double-precision algorithm. Positive\n\ * is true, 0.0 is false.\n\ * Default: 1.0 (attempt componentwise convergence)\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (2*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit. The solution to every right-hand side is\n\ * guaranteed.\n\ * < 0: If INFO = -i, the i-th argument had an illegal value\n\ * > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/claein0000644000175000017500000000625612502223525016453 0ustar uwabamiuwabami--- :name: claein :md5sum: 10958c9e44d2ecd0dada6eee846d037a :category: :subroutine :arguments: - rightv: :type: logical :intent: input - noinit: :type: logical :intent: input - n: :type: integer :intent: input - h: :type: complex :intent: input :dims: - ldh - n - ldh: :type: integer :intent: input - w: :type: complex :intent: input - v: :type: complex :intent: input/output :dims: - n - b: :type: complex :intent: workspace :dims: - ldb - n - ldb: :type: integer :intent: input - rwork: :type: real :intent: workspace :dims: - n - eps3: :type: real :intent: input - smlnum: :type: real :intent: input - info: :type: integer :intent: output :substitutions: ldb: MAX(1,n) :fortran_help: " SUBROUTINE CLAEIN( RIGHTV, NOINIT, N, H, LDH, W, V, B, LDB, RWORK, EPS3, SMLNUM, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAEIN uses inverse iteration to find a right or left eigenvector\n\ * corresponding to the eigenvalue W of a complex upper Hessenberg\n\ * matrix H.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * RIGHTV (input) LOGICAL\n\ * = .TRUE. : compute right eigenvector;\n\ * = .FALSE.: compute left eigenvector.\n\ *\n\ * NOINIT (input) LOGICAL\n\ * = .TRUE. : no initial vector supplied in V\n\ * = .FALSE.: initial vector supplied in V.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H. N >= 0.\n\ *\n\ * H (input) COMPLEX array, dimension (LDH,N)\n\ * The upper Hessenberg matrix H.\n\ *\n\ * LDH (input) INTEGER\n\ * The leading dimension of the array H. LDH >= max(1,N).\n\ *\n\ * W (input) COMPLEX\n\ * The eigenvalue of H whose corresponding right or left\n\ * eigenvector is to be computed.\n\ *\n\ * V (input/output) COMPLEX array, dimension (N)\n\ * On entry, if NOINIT = .FALSE., V must contain a starting\n\ * vector for inverse iteration; otherwise V need not be set.\n\ * On exit, V contains the computed eigenvector, normalized so\n\ * that the component of largest magnitude has magnitude 1; here\n\ * the magnitude of a complex number (x,y) is taken to be\n\ * |x| + |y|.\n\ *\n\ * B (workspace) COMPLEX array, dimension (LDB,N)\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\n\ *\n\ * EPS3 (input) REAL\n\ * A small machine-dependent value which is used to perturb\n\ * close eigenvalues, and to replace zero pivots.\n\ *\n\ * SMLNUM (input) REAL\n\ * A machine-dependent value close to the underflow threshold.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * = 1: inverse iteration did not converge; V is set to the\n\ * last iterate.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgeqr20000644000175000017500000000477412502223526016410 0ustar uwabamiuwabami--- :name: dgeqr2 :md5sum: fb9ab1f2a4dd3ec44720edcbe890256c :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - MIN(m,n) - work: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGEQR2 computes a QR factorization of a real m by n matrix A:\n\ * A = Q * R.\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 above the diagonal of the array\n\ * contain the min(m,n) by n upper trapezoidal matrix R (R is\n\ * upper triangular if m >= n); the elements below 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 (N)\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(1) H(2) . . . H(k), 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:m) is stored on exit in A(i+1:m,i),\n\ * and tau in TAU(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dppsvx0000644000175000017500000002607412502223526016545 0ustar uwabamiuwabami--- :name: dppsvx :md5sum: 2398de467fb49a54f33f13d43fb8e145 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - afp: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - equed: :type: char :intent: input/output - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE DPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPPSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to\n\ * compute the solution to a real system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N symmetric positive definite matrix stored in\n\ * packed format and X and B are N-by-NRHS matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', real scaling factors are computed to equilibrate\n\ * the system:\n\ * diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n\ *\n\ * 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n\ * factor the matrix A (after equilibration if FACT = 'E') as\n\ * A = U**T* U, if UPLO = 'U', or\n\ * A = L * L**T, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is a lower triangular\n\ * matrix.\n\ *\n\ * 3. If the leading i-by-i principal minor is not positive definite,\n\ * then the routine returns with INFO = i. Otherwise, the factored\n\ * form of A is used to estimate the condition number of the matrix\n\ * A. If the reciprocal of the condition number is less than machine\n\ * precision, INFO = N+1 is returned as a warning, but the routine\n\ * still goes on to solve for X and compute error bounds as\n\ * described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(S) so that it solves the original system before\n\ * equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AFP contains the factored form of A.\n\ * If EQUED = 'Y', the matrix A has been equilibrated\n\ * with scaling factors given by S. AP and AFP will not\n\ * be modified.\n\ * = 'N': The matrix A will be copied to AFP and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AFP and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array, except if FACT = 'F'\n\ * and EQUED = 'Y', then A must contain the equilibrated matrix\n\ * diag(S)*A*diag(S). The j-th column of A is stored in the\n\ * array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ * See below for further details. A is not modified if\n\ * FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n\ *\n\ * On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n\ * diag(S)*A*diag(S).\n\ *\n\ * AFP (input or output) DOUBLE PRECISION array, dimension\n\ * (N*(N+1)/2)\n\ * If FACT = 'F', then AFP is an input argument and on entry\n\ * contains the triangular factor U or L from the Cholesky\n\ * factorization A = U'*U or A = L*L', in the same storage\n\ * format as A. If EQUED .ne. 'N', then AFP is the factored\n\ * form of the equilibrated matrix A.\n\ *\n\ * If FACT = 'N', then AFP is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U'*U or A = L*L' of the original matrix A.\n\ *\n\ * If FACT = 'E', then AFP is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U'*U or A = L*L' of the equilibrated\n\ * matrix A (see the description of AP for the form of the\n\ * equilibrated matrix).\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'Y': Equilibration was done, i.e., A has been replaced by\n\ * diag(S) * A * diag(S).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * S (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The scale factors for A; not accessed if EQUED = 'N'. S is\n\ * an input argument if FACT = 'F'; otherwise, S is an output\n\ * argument. If FACT = 'F' and EQUED = 'Y', each element of S\n\ * must be positive.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n\ * B is overwritten by diag(S) * B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n\ * the original system of equations. Note that if EQUED = 'Y',\n\ * A and B are modified on exit, and the solution to the\n\ * equilibrated system is inv(diag(S))*X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A after equilibration (if done). If RCOND is less than the\n\ * machine precision (in particular, if RCOND = 0), the matrix\n\ * is singular to working precision. This condition is\n\ * indicated by a return code of INFO > 0.\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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, and i is\n\ * <= N: the leading minor of order i of A is\n\ * not positive definite, so the factorization\n\ * could not be completed, and the solution has not\n\ * been computed. RCOND = 0 is returned.\n\ * = N+1: U is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The packed storage scheme is illustrated by the following example\n\ * when N = 4, UPLO = 'U':\n\ *\n\ * Two-dimensional storage of the symmetric matrix A:\n\ *\n\ * a11 a12 a13 a14\n\ * a22 a23 a24\n\ * a33 a34 (aij = conjg(aji))\n\ * a44\n\ *\n\ * Packed storage of the upper triangle of A:\n\ *\n\ * AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgelqf0000644000175000017500000000716512502223526016502 0ustar uwabamiuwabami--- :name: sgelqf :md5sum: 167e1d10b4e9f338482f58398f79a993 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - MIN(m,n) - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGELQF 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) REAL 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) REAL array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace/output) REAL 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 SGELQ2, SLARFB, SLARFT, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlaed60000644000175000017500000000612312502223526016351 0ustar uwabamiuwabami--- :name: dlaed6 :md5sum: e039fc917dcc0ea6e9bd27545f59234c :category: :subroutine :arguments: - kniter: :type: integer :intent: input - orgati: :type: logical :intent: input - rho: :type: doublereal :intent: input - d: :type: doublereal :intent: input :dims: - "3" - z: :type: doublereal :intent: input :dims: - "3" - finit: :type: doublereal :intent: input - tau: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAED6 computes the positive or negative root (closest to the origin)\n\ * of\n\ * z(1) z(2) z(3)\n\ * f(x) = rho + --------- + ---------- + ---------\n\ * d(1)-x d(2)-x d(3)-x\n\ *\n\ * It is assumed that\n\ *\n\ * if ORGATI = .true. the root is between d(2) and d(3);\n\ * otherwise it is between d(1) and d(2)\n\ *\n\ * This routine will be called by DLAED4 when necessary. In most cases,\n\ * the root sought is the smallest in magnitude, though it might not be\n\ * in some extremely rare situations.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * KNITER (input) INTEGER\n\ * Refer to DLAED4 for its significance.\n\ *\n\ * ORGATI (input) LOGICAL\n\ * If ORGATI is true, the needed root is between d(2) and\n\ * d(3); otherwise it is between d(1) and d(2). See\n\ * DLAED4 for further details.\n\ *\n\ * RHO (input) DOUBLE PRECISION\n\ * Refer to the equation f(x) above.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (3)\n\ * D satisfies d(1) < d(2) < d(3).\n\ *\n\ * Z (input) DOUBLE PRECISION array, dimension (3)\n\ * Each of the elements in z must be positive.\n\ *\n\ * FINIT (input) DOUBLE PRECISION\n\ * The value of f at 0. It is more accurate than the one\n\ * evaluated inside this routine (if someone wants to do\n\ * so).\n\ *\n\ * TAU (output) DOUBLE PRECISION\n\ * The root of the equation f(x).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * > 0: if INFO = 1, failure to converge\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * 30/06/99: Based on contributions by\n\ * Ren-Cang Li, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ *\n\ * 10/02/03: This version has a few statements commented out for thread\n\ * safety (machine parameters are computed on each entry). SJH.\n\ *\n\ * 05/10/06: Modified from a new version of Ren-Cang Li, use\n\ * Gragg-Thornton-Warner cubic convergent scheme for better stability.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zsytf20000644000175000017500000001276112502223526016460 0ustar uwabamiuwabami--- :name: zsytf2 :md5sum: 1d96936fe2732003778e4d2042675625 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZSYTF2( UPLO, N, A, LDA, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSYTF2 computes the factorization of a complex symmetric matrix A\n\ * using the Bunch-Kaufman diagonal pivoting method:\n\ *\n\ * A = U*D*U' or A = L*D*L'\n\ *\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, U' is the transpose of U, and D is symmetric and\n\ * block diagonal with 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\ * This is the unblocked version of the algorithm, calling Level 2 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * n-by-n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n-by-n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L (see below for further details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D.\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ * > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular, and division by zero will occur if it\n\ * is used to solve a system of equations.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * 09-29-06 - patch from\n\ * Bobby Cheng, MathWorks\n\ *\n\ * Replace l.209 and l.377\n\ * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN\n\ * by\n\ * IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN\n\ *\n\ * 1-96 - Based on modifications by J. Lewis, Boeing Computer Services\n\ * Company\n\ *\n\ * If UPLO = 'U', then A = U*D*U', where\n\ * U = P(n)*U(n)* ... *P(k)U(k)* ...,\n\ * i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n\ * 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I v 0 ) k-s\n\ * U(k) = ( 0 I 0 ) s\n\ * ( 0 0 I ) n-k\n\ * k-s s n-k\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n\ * If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n\ * and A(k,k), and v overwrites A(1:k-2,k-1:k).\n\ *\n\ * If UPLO = 'L', then A = L*D*L', where\n\ * L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n\ * i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n\ * n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I 0 0 ) k-1\n\ * L(k) = ( 0 I 0 ) s\n\ * ( 0 v I ) n-k-s+1\n\ * k-1 s n-k-s+1\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n\ * If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n\ * and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlaqsy0000644000175000017500000000605112502223526016535 0ustar uwabamiuwabami--- :name: zlaqsy :md5sum: 33fa22407b763579d1adde067c2b0d27 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - s: :type: doublereal :intent: input :dims: - n - scond: :type: doublereal :intent: input - amax: :type: doublereal :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAQSY equilibrates a symmetric matrix A using the scaling factors\n\ * in the vector S.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * n by n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n by n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if EQUED = 'Y', the equilibrated matrix:\n\ * diag(S) * A * diag(S).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(N,1).\n\ *\n\ * S (input) DOUBLE PRECISION array, dimension (N)\n\ * The scale factors for A.\n\ *\n\ * SCOND (input) DOUBLE PRECISION\n\ * Ratio of the smallest S(i) to the largest S(i).\n\ *\n\ * AMAX (input) DOUBLE PRECISION\n\ * Absolute value of largest matrix entry.\n\ *\n\ * EQUED (output) CHARACTER*1\n\ * Specifies whether or not equilibration was done.\n\ * = 'N': No equilibration.\n\ * = 'Y': Equilibration was done, i.e., A has been replaced by\n\ * diag(S) * A * diag(S).\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * THRESH is a threshold value used to decide if scaling should be done\n\ * based on the ratio of the scaling factors. If SCOND < THRESH,\n\ * scaling is done.\n\ *\n\ * LARGE and SMALL are threshold values used to decide if scaling should\n\ * be done based on the absolute size of the largest matrix element.\n\ * If AMAX > LARGE or AMAX < SMALL, scaling is done.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlacn20000644000175000017500000000571412502223526016362 0ustar uwabamiuwabami--- :name: dlacn2 :md5sum: cc8a61551ef83735cc8fbda43e5751a3 :category: :subroutine :arguments: - n: :type: integer :intent: input - v: :type: doublereal :intent: workspace :dims: - n - x: :type: doublereal :intent: input/output :dims: - n - isgn: :type: integer :intent: workspace :dims: - n - est: :type: doublereal :intent: input/output - kase: :type: integer :intent: input/output - isave: :type: integer :intent: input/output :dims: - "3" :substitutions: {} :fortran_help: " SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLACN2 estimates the 1-norm of a square, real matrix A.\n\ * Reverse communication is used for evaluating matrix-vector products.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 1.\n\ *\n\ * V (workspace) DOUBLE PRECISION array, dimension (N)\n\ * On the final return, V = A*W, where EST = norm(V)/norm(W)\n\ * (W is not returned).\n\ *\n\ * X (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On an intermediate return, X should be overwritten by\n\ * A * X, if KASE=1,\n\ * A' * X, if KASE=2,\n\ * and DLACN2 must be re-called with all the other parameters\n\ * unchanged.\n\ *\n\ * ISGN (workspace) INTEGER array, dimension (N)\n\ *\n\ * EST (input/output) DOUBLE PRECISION\n\ * On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be\n\ * unchanged from the previous call to DLACN2.\n\ * On exit, EST is an estimate (a lower bound) for norm(A). \n\ *\n\ * KASE (input/output) INTEGER\n\ * On the initial call to DLACN2, KASE should be 0.\n\ * On an intermediate return, KASE will be 1 or 2, indicating\n\ * whether X should be overwritten by A * X or A' * X.\n\ * On the final return from DLACN2, KASE will again be 0.\n\ *\n\ * ISAVE (input/output) INTEGER array, dimension (3)\n\ * ISAVE is used to save variables between calls to DLACN2\n\ *\n\n\ * Further Details\n\ * ======= =======\n\ *\n\ * Contributed by Nick Higham, University of Manchester.\n\ * Originally named SONEST, dated March 16, 1988.\n\ *\n\ * Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n\ * a real or complex matrix, with applications to condition estimation\",\n\ * ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n\ *\n\ * This is a thread safe version of DLACON, which uses the array ISAVE\n\ * in place of a SAVE statement, as follows:\n\ *\n\ * DLACON DLACN2\n\ * JUMP ISAVE(1)\n\ * J ISAVE(2)\n\ * ITER ISAVE(3)\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlascl0000644000175000017500000000640312502223526016455 0ustar uwabamiuwabami--- :name: dlascl :md5sum: c116ad39650764c8b0fe2bbf035ba7a3 :category: :subroutine :arguments: - type: :type: char :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - cfrom: :type: doublereal :intent: input - cto: :type: doublereal :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLASCL multiplies the M by N real matrix A by the real scalar\n\ * CTO/CFROM. This is done without over/underflow as long as the final\n\ * result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that\n\ * A may be full, upper triangular, lower triangular, upper Hessenberg,\n\ * or banded.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TYPE (input) CHARACTER*1\n\ * TYPE indices the storage type of the input matrix.\n\ * = 'G': A is a full matrix.\n\ * = 'L': A is a lower triangular matrix.\n\ * = 'U': A is an upper triangular matrix.\n\ * = 'H': A is an upper Hessenberg matrix.\n\ * = 'B': A is a symmetric band matrix with lower bandwidth KL\n\ * and upper bandwidth KU and with the only the lower\n\ * half stored.\n\ * = 'Q': A is a symmetric band matrix with lower bandwidth KL\n\ * and upper bandwidth KU and with the only the upper\n\ * half stored.\n\ * = 'Z': A is a band matrix with lower bandwidth KL and upper\n\ * bandwidth KU. See DGBTRF for storage details.\n\ *\n\ * KL (input) INTEGER\n\ * The lower bandwidth of A. Referenced only if TYPE = 'B',\n\ * 'Q' or 'Z'.\n\ *\n\ * KU (input) INTEGER\n\ * The upper bandwidth of A. Referenced only if TYPE = 'B',\n\ * 'Q' or 'Z'.\n\ *\n\ * CFROM (input) DOUBLE PRECISION\n\ * CTO (input) DOUBLE PRECISION\n\ * The matrix A is multiplied by CTO/CFROM. A(I,J) is computed\n\ * without over/underflow if the final result CTO*A(I,J)/CFROM\n\ * can be represented without over/underflow. CFROM must be\n\ * nonzero.\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\ * The matrix to be multiplied by CTO/CFROM. See TYPE for the\n\ * storage type.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dppsv0000644000175000017500000000757612502223526016363 0ustar uwabamiuwabami--- :name: dppsv :md5sum: 05812066fff4498bbd8b9748ba91010d :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPPSV( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPPSV computes the solution to a real system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N symmetric positive definite matrix stored in\n\ * packed format and X and B are N-by-NRHS matrices.\n\ *\n\ * The Cholesky decomposition is used to factor A as\n\ * A = U**T* U, if UPLO = 'U', or\n\ * A = L * L**T, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is a lower triangular\n\ * matrix. The factored form of A is then used to solve the system of\n\ * equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ * See below for further details.\n\ *\n\ * On exit, if INFO = 0, the factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T, in the same storage\n\ * format as A.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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 leading minor of order i of A is not\n\ * positive definite, so the factorization could not be\n\ * completed, and the solution has not been computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The packed storage scheme is illustrated by the following example\n\ * when N = 4, UPLO = 'U':\n\ *\n\ * Two-dimensional storage of the symmetric matrix A:\n\ *\n\ * a11 a12 a13 a14\n\ * a22 a23 a24\n\ * a33 a34 (aij = conjg(aji))\n\ * a44\n\ *\n\ * Packed storage of the upper triangle of A:\n\ *\n\ * AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n\ *\n\ * =====================================================================\n\ *\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DPPTRF, DPPTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zbbcsd0000644000175000017500000002252612502223526016466 0ustar uwabamiuwabami--- :name: zbbcsd :md5sum: 9a65726a037b363eb2c0b9c63517765d :category: :subroutine :arguments: - jobu1: :type: char :intent: input - jobu2: :type: char :intent: input - jobv1t: :type: char :intent: input - jobv2t: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - q: :type: integer :intent: input - theta: :type: doublereal :intent: input/output :dims: - q - phi: :type: doublereal :intent: input :dims: - q-1 - u1: :type: doublecomplex :intent: input/output :dims: - ldu1 - p - ldu1: :type: integer :intent: input - u2: :type: doublecomplex :intent: input/output :dims: - ldu2 - m-p - ldu2: :type: integer :intent: input - v1t: :type: doublecomplex :intent: input/output :dims: - ldv1t - q - ldv1t: :type: integer :intent: input - v2t: :type: doublecomplex :intent: input/output :dims: - ldv2t - m-q - ldv2t: :type: integer :intent: input - b11d: :type: doublereal :intent: output :dims: - q - b11e: :type: doublereal :intent: output :dims: - q-1 - b12d: :type: doublereal :intent: output :dims: - q - b12e: :type: doublereal :intent: output :dims: - q-1 - b21d: :type: doublereal :intent: output :dims: - q - b21e: :type: doublereal :intent: output :dims: - q-1 - b22d: :type: doublereal :intent: output :dims: - q - b22e: :type: doublereal :intent: output :dims: - q-1 - rwork: :type: doublereal :intent: workspace :dims: - MAX(1,lrwork) - lrwork: :type: integer :intent: input :option: true :default: 8*q - info: :type: integer :intent: output :substitutions: lrwork: MAX(1,8*q) :fortran_help: " SUBROUTINE ZBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, THETA, PHI, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, B22D, B22E, RWORK, LRWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZBBCSD computes the CS decomposition of a unitary matrix in\n\ * bidiagonal-block form,\n\ *\n\ *\n\ * [ B11 | B12 0 0 ]\n\ * [ 0 | 0 -I 0 ]\n\ * X = [----------------]\n\ * [ B21 | B22 0 0 ]\n\ * [ 0 | 0 0 I ]\n\ *\n\ * [ C | -S 0 0 ]\n\ * [ U1 | ] [ 0 | 0 -I 0 ] [ V1 | ]**H\n\ * = [---------] [---------------] [---------] .\n\ * [ | U2 ] [ S | C 0 0 ] [ | V2 ]\n\ * [ 0 | 0 0 I ]\n\ *\n\ * X is M-by-M, its top-left block is P-by-Q, and Q must be no larger\n\ * than P, M-P, or M-Q. (If Q is not the smallest index, then X must be\n\ * transposed and/or permuted. This can be done in constant time using\n\ * the TRANS and SIGNS options. See ZUNCSD for details.)\n\ *\n\ * The bidiagonal matrices B11, B12, B21, and B22 are represented\n\ * implicitly by angles THETA(1:Q) and PHI(1:Q-1).\n\ *\n\ * The unitary matrices U1, U2, V1T, and V2T are input/output.\n\ * The input matrices are pre- or post-multiplied by the appropriate\n\ * singular vector matrices.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBU1 (input) CHARACTER\n\ * = 'Y': U1 is updated;\n\ * otherwise: U1 is not updated.\n\ *\n\ * JOBU2 (input) CHARACTER\n\ * = 'Y': U2 is updated;\n\ * otherwise: U2 is not updated.\n\ *\n\ * JOBV1T (input) CHARACTER\n\ * = 'Y': V1T is updated;\n\ * otherwise: V1T is not updated.\n\ *\n\ * JOBV2T (input) CHARACTER\n\ * = 'Y': V2T is updated;\n\ * otherwise: V2T is not updated.\n\ *\n\ * TRANS (input) CHARACTER\n\ * = 'T': X, U1, U2, V1T, and V2T are stored in row-major\n\ * order;\n\ * otherwise: X, U1, U2, V1T, and V2T are stored in column-\n\ * major order.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows and columns in X, the unitary matrix in\n\ * bidiagonal-block form.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows in the top-left block of X. 0 <= P <= M.\n\ *\n\ * Q (input) INTEGER\n\ * The number of columns in the top-left block of X.\n\ * 0 <= Q <= MIN(P,M-P,M-Q).\n\ *\n\ * THETA (input/output) DOUBLE PRECISION array, dimension (Q)\n\ * On entry, the angles THETA(1),...,THETA(Q) that, along with\n\ * PHI(1), ...,PHI(Q-1), define the matrix in bidiagonal-block\n\ * form. On exit, the angles whose cosines and sines define the\n\ * diagonal blocks in the CS decomposition.\n\ *\n\ * PHI (input/workspace) DOUBLE PRECISION array, dimension (Q-1)\n\ * The angles PHI(1),...,PHI(Q-1) that, along with THETA(1),...,\n\ * THETA(Q), define the matrix in bidiagonal-block form.\n\ *\n\ * U1 (input/output) COMPLEX*16 array, dimension (LDU1,P)\n\ * On entry, an LDU1-by-P matrix. On exit, U1 is postmultiplied\n\ * by the left singular vector matrix common to [ B11 ; 0 ] and\n\ * [ B12 0 0 ; 0 -I 0 0 ].\n\ *\n\ * LDU1 (input) INTEGER\n\ * The leading dimension of the array U1.\n\ *\n\ * U2 (input/output) COMPLEX*16 array, dimension (LDU2,M-P)\n\ * On entry, an LDU2-by-(M-P) matrix. On exit, U2 is\n\ * postmultiplied by the left singular vector matrix common to\n\ * [ B21 ; 0 ] and [ B22 0 0 ; 0 0 I ].\n\ *\n\ * LDU2 (input) INTEGER\n\ * The leading dimension of the array U2.\n\ *\n\ * V1T (input/output) COMPLEX*16 array, dimension (LDV1T,Q)\n\ * On entry, a LDV1T-by-Q matrix. On exit, V1T is premultiplied\n\ * by the conjugate transpose of the right singular vector\n\ * matrix common to [ B11 ; 0 ] and [ B21 ; 0 ].\n\ *\n\ * LDV1T (input) INTEGER\n\ * The leading dimension of the array V1T.\n\ *\n\ * V2T (input/output) COMPLEX*16 array, dimenison (LDV2T,M-Q)\n\ * On entry, a LDV2T-by-(M-Q) matrix. On exit, V2T is\n\ * premultiplied by the conjugate transpose of the right\n\ * singular vector matrix common to [ B12 0 0 ; 0 -I 0 ] and\n\ * [ B22 0 0 ; 0 0 I ].\n\ *\n\ * LDV2T (input) INTEGER\n\ * The leading dimension of the array V2T.\n\ *\n\ * B11D (output) DOUBLE PRECISION array, dimension (Q)\n\ * When ZBBCSD converges, B11D contains the cosines of THETA(1),\n\ * ..., THETA(Q). If ZBBCSD fails to converge, then B11D\n\ * contains the diagonal of the partially reduced top-left\n\ * block.\n\ *\n\ * B11E (output) DOUBLE PRECISION array, dimension (Q-1)\n\ * When ZBBCSD converges, B11E contains zeros. If ZBBCSD fails\n\ * to converge, then B11E contains the superdiagonal of the\n\ * partially reduced top-left block.\n\ *\n\ * B12D (output) DOUBLE PRECISION array, dimension (Q)\n\ * When ZBBCSD converges, B12D contains the negative sines of\n\ * THETA(1), ..., THETA(Q). If ZBBCSD fails to converge, then\n\ * B12D contains the diagonal of the partially reduced top-right\n\ * block.\n\ *\n\ * B12E (output) DOUBLE PRECISION array, dimension (Q-1)\n\ * When ZBBCSD converges, B12E contains zeros. If ZBBCSD fails\n\ * to converge, then B12E contains the subdiagonal of the\n\ * partially reduced top-right block.\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LRWORK (input) INTEGER\n\ * The dimension of the array RWORK. LRWORK >= MAX(1,8*Q).\n\ *\n\ * If LRWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal size of the RWORK array,\n\ * returns this value as the first entry of the work array, and\n\ * no error message related to LRWORK 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 ZBBCSD did not converge, INFO specifies the number\n\ * of nonzero entries in PHI, and B11D, B11E, etc.,\n\ * contain the partially reduced matrix.\n\ *\n\ * Reference\n\ * =========\n\ *\n\ * [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.\n\ * Algorithms, 50(1):33-65, 2009.\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * TOLMUL DOUBLE PRECISION, default = MAX(10,MIN(100,EPS**(-1/8)))\n\ * TOLMUL controls the convergence criterion of the QR loop.\n\ * Angles THETA(i), PHI(i) are rounded to 0 or PI/2 when they\n\ * are within TOLMUL*EPS of either bound.\n\ *\n\n\ * ===================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgeequ0000644000175000017500000000657112502223526016521 0ustar uwabamiuwabami--- :name: zgeequ :md5sum: 2b6b705fc741bc84747d85d5d1fa7b5d :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - r: :type: doublereal :intent: output :dims: - m - c: :type: doublereal :intent: output :dims: - n - rowcnd: :type: doublereal :intent: output - colcnd: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE ZGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGEEQU computes row and column scalings intended to equilibrate an\n\ * M-by-N matrix A and reduce its condition number. R returns the row\n\ * scale factors and C the column scale factors, chosen to try to make\n\ * the largest element in each row and column of the matrix B with\n\ * elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n\ *\n\ * R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n\ * number and BIGNUM = largest safe number. Use of these scaling\n\ * factors is not guaranteed to reduce the condition number of A but\n\ * works well in practice.\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) COMPLEX*16 array, dimension (LDA,N)\n\ * The M-by-N matrix whose equilibration factors are\n\ * to be computed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * R (output) DOUBLE PRECISION array, dimension (M)\n\ * If INFO = 0 or INFO > M, R contains the row scale factors\n\ * for A.\n\ *\n\ * C (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, C contains the column scale factors for A.\n\ *\n\ * ROWCND (output) DOUBLE PRECISION\n\ * If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n\ * smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n\ * AMAX is neither too large nor too small, it is not worth\n\ * scaling by R.\n\ *\n\ * COLCND (output) DOUBLE PRECISION\n\ * If INFO = 0, COLCND contains the ratio of the smallest\n\ * C(i) to the largest C(i). If COLCND >= 0.1, it is not\n\ * worth scaling by C.\n\ *\n\ * AMAX (output) DOUBLE PRECISION\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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, and i is\n\ * <= M: the i-th row of A is exactly zero\n\ * > M: the (i-M)-th column of A is exactly zero\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/stfttr0000644000175000017500000001424712502223526016546 0ustar uwabamiuwabami--- :name: stfttr :md5sum: df86973ab0132ff43480f353386b9f62 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - arf: :type: real :intent: input :dims: - ldarf - a: :type: real :intent: output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: lda: MAX(1,n) n: ((int)sqrtf(ldarf*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE STFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STFTTR copies a triangular matrix A from rectangular full packed\n\ * format (TF) to standard full format (TR).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': ARF is in Normal format;\n\ * = 'T': ARF is in Transpose format.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices ARF and A. N >= 0.\n\ *\n\ * ARF (input) REAL array, dimension (N*(N+1)/2).\n\ * On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')\n\ * matrix A in RFP format. See the \"Notes\" below for more\n\ * details.\n\ *\n\ * A (output) REAL array, dimension (LDA,N)\n\ * On exit, the triangular matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of the array A contains\n\ * the upper triangular matrix, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of the array A contains\n\ * the lower triangular matrix, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\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\ * We first consider Rectangular Full Packed (RFP) Format when N is\n\ * even. We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * the transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * the transpose of the last three columns of AP lower.\n\ * This covers the case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 04 05 33 43 53\n\ * 13 14 15 00 44 54\n\ * 23 24 25 10 11 55\n\ * 33 34 35 20 21 22\n\ * 00 44 45 30 31 32\n\ * 01 11 55 40 41 42\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We then consider Rectangular Full Packed (RFP) Format when N is\n\ * odd. We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * the transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * the transpose of the last two columns of AP lower.\n\ * This covers the case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 03 04 00 33 43\n\ * 12 13 14 10 11 44\n\ * 22 23 24 20 21 22\n\ * 00 33 34 30 31 32\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * Reference\n\ * =========\n\ *\n\ * =====================================================================\n\ *\n\ * ..\n\ * .. Local Scalars ..\n LOGICAL LOWER, NISODD, NORMALTRANSR\n INTEGER N1, N2, K, NT, NX2, NP1X2\n INTEGER I, J, L, IJ\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MOD\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dgesvj0000644000175000017500000003701212502223526016475 0ustar uwabamiuwabami--- :name: dgesvj :md5sum: df9133f8cb1fdc3793fc40b5c576608e :category: :subroutine :arguments: - joba: :type: char :intent: input - jobu: :type: char :intent: input - jobv: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - sva: :type: doublereal :intent: output :dims: - n - mv: :type: integer :intent: input - v: :type: doublereal :intent: input/output :dims: - ldv - n - ldv: :type: integer :intent: input - work: :type: doublereal :intent: input/output :dims: - lwork - lwork: :type: integer :intent: input :option: true :default: MAX(6,m+n) - info: :type: integer :intent: output :substitutions: lwork: MAX(4,m+n) :fortran_help: " SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, LDV, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGESVJ computes the singular value decomposition (SVD) of a real\n\ * M-by-N matrix A, where M >= N. The SVD of A is written as\n\ * [++] [xx] [x0] [xx]\n\ * A = U * SIGMA * V^t, [++] = [xx] * [ox] * [xx]\n\ * [++] [xx]\n\ * where SIGMA is an N-by-N diagonal matrix, U is an M-by-N orthonormal\n\ * matrix, and V is an N-by-N orthogonal matrix. The diagonal elements\n\ * of SIGMA are the singular values of A. The columns of U and V are the\n\ * left and the right singular vectors of A, respectively.\n\ *\n\ * Further Details\n\ * ~~~~~~~~~~~~~~~\n\ * The orthogonal N-by-N matrix V is obtained as a product of Jacobi plane\n\ * rotations. The rotations are implemented as fast scaled rotations of\n\ * Anda and Park [1]. In the case of underflow of the Jacobi angle, a\n\ * modified Jacobi transformation of Drmac [4] is used. Pivot strategy uses\n\ * column interchanges of de Rijk [2]. The relative accuracy of the computed\n\ * singular values and the accuracy of the computed singular vectors (in\n\ * angle metric) is as guaranteed by the theory of Demmel and Veselic [3].\n\ * The condition number that determines the accuracy in the full rank case\n\ * is essentially min_{D=diag} kappa(A*D), where kappa(.) is the\n\ * spectral condition number. The best performance of this Jacobi SVD\n\ * procedure is achieved if used in an accelerated version of Drmac and\n\ * Veselic [5,6], and it is the kernel routine in the SIGMA library [7].\n\ * Some tunning parameters (marked with [TP]) are available for the\n\ * implementer.\n\ * The computational range for the nonzero singular values is the machine\n\ * number interval ( UNDERFLOW , OVERFLOW ). In extreme cases, even\n\ * denormalized singular values can be computed with the corresponding\n\ * gradual loss of accurate digits.\n\ *\n\ * Contributors\n\ * ~~~~~~~~~~~~\n\ * Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)\n\ *\n\ * References\n\ * ~~~~~~~~~~\n\ * [1] A. A. Anda and H. Park: Fast plane rotations with dynamic scaling.\n\ * SIAM J. matrix Anal. Appl., Vol. 15 (1994), pp. 162-174.\n\ * [2] P. P. M. De Rijk: A one-sided Jacobi algorithm for computing the\n\ * singular value decomposition on a vector computer.\n\ * SIAM J. Sci. Stat. Comp., Vol. 10 (1998), pp. 359-371.\n\ * [3] J. Demmel and K. Veselic: Jacobi method is more accurate than QR.\n\ * [4] Z. Drmac: Implementation of Jacobi rotations for accurate singular\n\ * value computation in floating point arithmetic.\n\ * SIAM J. Sci. Comp., Vol. 18 (1997), pp. 1200-1222.\n\ * [5] 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\ * [6] 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\ * [7] 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 test examples and comments to\n\ * drmac@math.hr. Thank you.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBA (input) CHARACTER* 1\n\ * Specifies the structure of A.\n\ * = 'L': The input matrix A is lower triangular;\n\ * = 'U': The input matrix A is upper triangular;\n\ * = 'G': The input matrix A is general M-by-N matrix, M >= N.\n\ *\n\ * JOBU (input) CHARACTER*1\n\ * Specifies whether to compute the left singular vectors\n\ * (columns of U):\n\ * = 'U': The left singular vectors corresponding to the nonzero\n\ * singular values are computed and returned in the leading\n\ * columns of A. See more details in the description of A.\n\ * The default numerical orthogonality threshold is set to\n\ * approximately TOL=CTOL*EPS, CTOL=DSQRT(M), EPS=DLAMCH('E').\n\ * = 'C': Analogous to JOBU='U', except that user can control the\n\ * level of numerical orthogonality of the computed left\n\ * singular vectors. TOL can be set to TOL = CTOL*EPS, where\n\ * CTOL is given on input in the array WORK.\n\ * No CTOL smaller than ONE is allowed. CTOL greater\n\ * than 1 / EPS is meaningless. The option 'C'\n\ * can be used if M*EPS is satisfactory orthogonality\n\ * of the computed left singular vectors, so CTOL=M could\n\ * save few sweeps of Jacobi rotations.\n\ * See the descriptions of A and WORK(1).\n\ * = 'N': The matrix U is not computed. However, see the\n\ * description of A.\n\ *\n\ * JOBV (input) CHARACTER*1\n\ * Specifies whether to compute the right singular vectors, that\n\ * is, the matrix V:\n\ * = 'V' : the matrix V is computed and returned in the array V\n\ * = 'A' : the Jacobi rotations are applied to the MV-by-N\n\ * array V. In other words, the right singular vector\n\ * matrix V is not computed explicitly, instead it is\n\ * applied to an MV-by-N matrix initially stored in the\n\ * first MV rows of V.\n\ * = 'N' : the matrix V is not computed and the array V is not\n\ * referenced\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.\n\ * M >= 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 :\n\ * If JOBU .EQ. 'U' .OR. JOBU .EQ. 'C' :\n\ * If INFO .EQ. 0 :\n\ * RANKA orthonormal columns of U are returned in the\n\ * leading RANKA columns of the array A. Here RANKA <= N\n\ * is the number of computed singular values of A that are\n\ * above the underflow threshold DLAMCH('S'). The singular\n\ * vectors corresponding to underflowed or zero singular\n\ * values are not computed. The value of RANKA is returned\n\ * in the array WORK as RANKA=NINT(WORK(2)). Also see the\n\ * descriptions of SVA and WORK. The computed columns of U\n\ * are mutually numerically orthogonal up to approximately\n\ * TOL=DSQRT(M)*EPS (default); or TOL=CTOL*EPS (JOBU.EQ.'C'),\n\ * see the description of JOBU.\n\ * If INFO .GT. 0 :\n\ * the procedure DGESVJ did not converge in the given number\n\ * of iterations (sweeps). In that case, the computed\n\ * columns of U may not be orthogonal up to TOL. The output\n\ * U (stored in A), SIGMA (given by the computed singular\n\ * values in SVA(1:N)) and V is still a decomposition of the\n\ * input matrix A in the sense that the residual\n\ * ||A-SCALE*U*SIGMA*V^T||_2 / ||A||_2 is small.\n\ *\n\ * If JOBU .EQ. 'N' :\n\ * If INFO .EQ. 0 :\n\ * Note that the left singular vectors are 'for free' in the\n\ * one-sided Jacobi SVD algorithm. However, if only the\n\ * singular values are needed, the level of numerical\n\ * orthogonality of U is not an issue and iterations are\n\ * stopped when the columns of the iterated matrix are\n\ * numerically orthogonal up to approximately M*EPS. Thus,\n\ * on exit, A contains the columns of U scaled with the\n\ * corresponding singular values.\n\ * If INFO .GT. 0 :\n\ * the procedure DGESVJ did not converge in the given number\n\ * of iterations (sweeps).\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\ * If INFO .EQ. 0 :\n\ * depending on the value SCALE = WORK(1), we have:\n\ * If SCALE .EQ. ONE :\n\ * SVA(1:N) contains the computed singular values of A.\n\ * During the computation SVA contains the Euclidean column\n\ * norms of the iterated matrices in the array A.\n\ * If SCALE .NE. ONE :\n\ * The singular values of A are SCALE*SVA(1:N), and this\n\ * factored representation is due to the fact that some of the\n\ * singular values of A might underflow or overflow.\n\ * If INFO .GT. 0 :\n\ * the procedure DGESVJ did not converge in the given number of\n\ * iterations (sweeps) and SCALE*SVA(1:N) may not be accurate.\n\ *\n\ * MV (input) INTEGER\n\ * If JOBV .EQ. 'A', then the product of Jacobi rotations in DGESVJ\n\ * is applied to the first MV rows of V. See the description of JOBV.\n\ *\n\ * V (input/output) DOUBLE PRECISION array, dimension (LDV,N)\n\ * If JOBV = 'V', then V contains on exit the N-by-N matrix of\n\ * the right singular vectors;\n\ * If JOBV = 'A', then V contains the product of the computed right\n\ * singular vector matrix and the initial matrix in\n\ * the array V.\n\ * If JOBV = 'N', then V is not referenced.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V, LDV .GE. 1.\n\ * If JOBV .EQ. 'V', then LDV .GE. max(1,N).\n\ * If JOBV .EQ. 'A', then LDV .GE. max(1,MV) .\n\ *\n\ * WORK (input/workspace/output) DOUBLE PRECISION array, dimension max(4,M+N).\n\ * On entry :\n\ * If JOBU .EQ. 'C' :\n\ * WORK(1) = CTOL, where CTOL defines the threshold for convergence.\n\ * The process stops if all columns of A are mutually\n\ * orthogonal up to CTOL*EPS, EPS=DLAMCH('E').\n\ * It is required that CTOL >= ONE, i.e. it is not\n\ * allowed to force the routine to obtain orthogonality\n\ * below EPS.\n\ * On exit :\n\ * WORK(1) = SCALE is the scaling factor such that SCALE*SVA(1:N)\n\ * are the computed singular values of A.\n\ * (See description of SVA().)\n\ * WORK(2) = NINT(WORK(2)) is the number of the computed nonzero\n\ * singular values.\n\ * WORK(3) = NINT(WORK(3)) is the number of the computed singular\n\ * values that are larger than the underflow threshold.\n\ * WORK(4) = NINT(WORK(4)) is the number of sweeps of Jacobi\n\ * rotations needed for numerical convergence.\n\ * WORK(5) = max_{i.NE.j} |COS(A(:,i),A(:,j))| in the last sweep.\n\ * This is useful information in cases when DGESVJ did\n\ * not converge, as it can be used to estimate whether\n\ * the output is stil useful and for post festum analysis.\n\ * WORK(6) = the largest absolute value over all sines of the\n\ * Jacobi rotation angles in the last sweep. It can be\n\ * useful for a post festum analysis.\n\ *\n\ * LWORK (input) INTEGER\n\ * length of WORK, WORK >= MAX(6,M+N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0 : successful exit.\n\ * < 0 : if INFO = -i, then the i-th argument had an illegal value\n\ * > 0 : DGESVJ did not converge in the maximal allowed number (30)\n\ * of sweeps. The output may still be useful. See the\n\ * description of WORK.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Parameters ..\n DOUBLE PRECISION ZERO, HALF, ONE, TWO\n PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0,\n + TWO = 2.0D0 )\n INTEGER NSWEEP\n PARAMETER ( NSWEEP = 30 )\n\ * ..\n\ * .. Local Scalars ..\n DOUBLE PRECISION AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,\n + BIGTHETA, CS, CTOL, EPSLN, LARGE, MXAAPQ,\n + MXSINJ, ROOTBIG, ROOTEPS, ROOTSFMIN, ROOTTOL,\n + SKL, SFMIN, SMALL, SN, T, TEMP1, THETA,\n + THSIGN, TOL\n INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1,\n + ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, N2, N34,\n + N4, NBL, NOTROT, p, PSKIPPED, q, ROWSKIP,\n + SWBAND\n LOGICAL APPLV, GOSCALE, LOWER, LSVEC, NOSCALE, ROTOK,\n + RSVEC, UCTOL, UPPER\n\ * ..\n\ * .. Local Arrays ..\n DOUBLE PRECISION FASTR( 5 )\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC DABS, DMAX1, DMIN1, DBLE, MIN0, DSIGN, DSQRT\n\ * ..\n\ * .. External Functions ..\n\ * ..\n\ * from BLAS\n DOUBLE PRECISION DDOT, DNRM2\n EXTERNAL DDOT, DNRM2\n INTEGER IDAMAX\n EXTERNAL IDAMAX\n\ * from LAPACK\n DOUBLE PRECISION DLAMCH\n EXTERNAL DLAMCH\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n\ * ..\n\ * from BLAS\n EXTERNAL DAXPY, DCOPY, DROTM, DSCAL, DSWAP\n\ * from LAPACK\n EXTERNAL DLASCL, DLASET, DLASSQ, XERBLA\n\ *\n EXTERNAL DGSVJ0, DGSVJ1\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slasd60000644000175000017500000002414512655767354016437 0ustar uwabamiuwabami--- :name: slasd6 :md5sum: 42e32de8791f7036090b24785a2bdb17 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - nl: :type: integer :intent: input - nr: :type: integer :intent: input - sqre: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - nl+nr+1 - vf: :type: real :intent: input/output :dims: - m - vl: :type: real :intent: input/output :dims: - m - alpha: :type: real :intent: input/output - beta: :type: real :intent: input/output - idxq: :type: integer :intent: output :dims: - n - perm: :type: integer :intent: output :dims: - n - givptr: :type: integer :intent: output - givcol: :type: integer :intent: output :dims: - ldgcol - "2" - ldgcol: :type: integer :intent: input - givnum: :type: real :intent: output :dims: - ldgnum - "2" - ldgnum: :type: integer :intent: input - poles: :type: real :intent: output :dims: - ldgnum - "2" - difl: :type: real :intent: output :dims: - n - difr: :type: real :intent: output :dims: - "icompq == 1 ? ldgnum : icompq == 0 ? n : 0" - "icompq == 1 ? 2 : 0" - z: :type: real :intent: output :dims: - m - k: :type: integer :intent: output - c: :type: real :intent: output - s: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 4 * m - iwork: :type: integer :intent: workspace :dims: - 3 * n - info: :type: integer :intent: output :substitutions: m: n + sqre n: nl + nr + 1 ldgnum: n ldgcol: n :fortran_help: " SUBROUTINE SLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA, IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLASD6 computes the SVD of an updated upper bidiagonal matrix B\n\ * obtained by merging two smaller ones by appending a row. This\n\ * routine is used only for the problem which requires all singular\n\ * values and optionally singular vector matrices in factored form.\n\ * B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE.\n\ * A related subroutine, SLASD1, handles the case in which all singular\n\ * values and singular vectors of the bidiagonal matrix are desired.\n\ *\n\ * SLASD6 computes the SVD as follows:\n\ *\n\ * ( D1(in) 0 0 0 )\n\ * B = U(in) * ( Z1' a Z2' b ) * VT(in)\n\ * ( 0 0 D2(in) 0 )\n\ *\n\ * = U(out) * ( D(out) 0) * VT(out)\n\ *\n\ * where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M\n\ * with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros\n\ * elsewhere; and the entry b is empty if SQRE = 0.\n\ *\n\ * The singular values of B can be computed using D1, D2, the first\n\ * components of all the right singular vectors of the lower block, and\n\ * the last components of all the right singular vectors of the upper\n\ * block. These components are stored and updated in VF and VL,\n\ * respectively, in SLASD6. Hence U and VT are not explicitly\n\ * referenced.\n\ *\n\ * The singular values are stored in D. The algorithm consists of two\n\ * stages:\n\ *\n\ * The first stage consists of deflating the size of the problem\n\ * when there are multiple singular values or if there is a zero\n\ * in the Z vector. For each such occurrence the dimension of the\n\ * secular equation problem is reduced by one. This stage is\n\ * performed by the routine SLASD7.\n\ *\n\ * The second stage consists of calculating the updated\n\ * singular values. This is done by finding the roots of the\n\ * secular equation via the routine SLASD4 (as called by SLASD8).\n\ * This routine also updates VF and VL and computes the distances\n\ * between the updated singular values and the old singular\n\ * values.\n\ *\n\ * SLASD6 is called from SLASDA.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ICOMPQ (input) INTEGER\n\ * Specifies whether singular vectors are to be computed in\n\ * factored form:\n\ * = 0: Compute singular values only.\n\ * = 1: Compute singular vectors in factored form as well.\n\ *\n\ * NL (input) INTEGER\n\ * The row dimension of the upper block. NL >= 1.\n\ *\n\ * NR (input) INTEGER\n\ * The row dimension of the lower block. NR >= 1.\n\ *\n\ * SQRE (input) INTEGER\n\ * = 0: the lower block is an NR-by-NR square matrix.\n\ * = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n\ *\n\ * The bidiagonal matrix has row dimension N = NL + NR + 1,\n\ * and column dimension M = N + SQRE.\n\ *\n\ * D (input/output) REAL array, dimension (NL+NR+1).\n\ * On entry D(1:NL,1:NL) contains the singular values of the\n\ * upper block, and D(NL+2:N) contains the singular values\n\ * of the lower block. On exit D(1:N) contains the singular\n\ * values of the modified matrix.\n\ *\n\ * VF (input/output) REAL array, dimension (M)\n\ * On entry, VF(1:NL+1) contains the first components of all\n\ * right singular vectors of the upper block; and VF(NL+2:M)\n\ * contains the first components of all right singular vectors\n\ * of the lower block. On exit, VF contains the first components\n\ * of all right singular vectors of the bidiagonal matrix.\n\ *\n\ * VL (input/output) REAL array, dimension (M)\n\ * On entry, VL(1:NL+1) contains the last components of all\n\ * right singular vectors of the upper block; and VL(NL+2:M)\n\ * contains the last components of all right singular vectors of\n\ * the lower block. On exit, VL contains the last components of\n\ * all right singular vectors of the bidiagonal matrix.\n\ *\n\ * ALPHA (input/output) REAL\n\ * Contains the diagonal element associated with the added row.\n\ *\n\ * BETA (input/output) REAL\n\ * Contains the off-diagonal element associated with the added\n\ * row.\n\ *\n\ * IDXQ (output) INTEGER array, dimension (N)\n\ * This contains the permutation which will reintegrate the\n\ * subproblem just solved back into sorted order, i.e.\n\ * D( IDXQ( I = 1, N ) ) will be in ascending order.\n\ *\n\ * PERM (output) INTEGER array, dimension ( N )\n\ * The permutations (from deflation and sorting) to be applied\n\ * to each block. Not referenced if ICOMPQ = 0.\n\ *\n\ * GIVPTR (output) INTEGER\n\ * The number of Givens rotations which took place in this\n\ * subproblem. Not referenced if ICOMPQ = 0.\n\ *\n\ * GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )\n\ * Each pair of numbers indicates a pair of columns to take place\n\ * in a Givens rotation. Not referenced if ICOMPQ = 0.\n\ *\n\ * LDGCOL (input) INTEGER\n\ * leading dimension of GIVCOL, must be at least N.\n\ *\n\ * GIVNUM (output) REAL array, dimension ( LDGNUM, 2 )\n\ * Each number indicates the C or S value to be used in the\n\ * corresponding Givens rotation. Not referenced if ICOMPQ = 0.\n\ *\n\ * LDGNUM (input) INTEGER\n\ * The leading dimension of GIVNUM and POLES, must be at least N.\n\ *\n\ * POLES (output) REAL array, dimension ( LDGNUM, 2 )\n\ * On exit, POLES(1,*) is an array containing the new singular\n\ * values obtained from solving the secular equation, and\n\ * POLES(2,*) is an array containing the poles in the secular\n\ * equation. Not referenced if ICOMPQ = 0.\n\ *\n\ * DIFL (output) REAL array, dimension ( N )\n\ * On exit, DIFL(I) is the distance between I-th updated\n\ * (undeflated) singular value and the I-th (undeflated) old\n\ * singular value.\n\ *\n\ * DIFR (output) REAL array,\n\ * dimension ( LDGNUM, 2 ) if ICOMPQ = 1 and\n\ * dimension ( N ) if ICOMPQ = 0.\n\ * On exit, DIFR(I, 1) is the distance between I-th updated\n\ * (undeflated) singular value and the I+1-th (undeflated) old\n\ * singular value.\n\ *\n\ * If ICOMPQ = 1, DIFR(1:K,2) is an array containing the\n\ * normalizing factors for the right singular vector matrix.\n\ *\n\ * See SLASD8 for details on DIFL and DIFR.\n\ *\n\ * Z (output) REAL array, dimension ( M )\n\ * The first elements of this array contain the components\n\ * of the deflation-adjusted updating row vector.\n\ *\n\ * K (output) INTEGER\n\ * Contains the dimension of the non-deflated matrix,\n\ * This is the order of the related secular equation. 1 <= K <=N.\n\ *\n\ * C (output) REAL\n\ * C contains garbage if SQRE =0 and the C-value of a Givens\n\ * rotation related to the right null space if SQRE = 1.\n\ *\n\ * S (output) REAL\n\ * S contains garbage if SQRE =0 and the S-value of a Givens\n\ * rotation related to the right null space if SQRE = 1.\n\ *\n\ * WORK (workspace) REAL array, dimension ( 4 * M )\n\ *\n\ * IWORK (workspace) INTEGER array, dimension ( 3 * N )\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 = 1, a singular value did not converge\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ming Gu and Huan Ren, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dla_geamv0000644000175000017500000001141212502223526017126 0ustar uwabamiuwabami--- :name: dla_geamv :md5sum: ab3758acf8bfa5ffbbcdc48d5024599a :category: :subroutine :arguments: - trans: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: doublereal :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: doublereal :intent: input :dims: - "trans == ilatrans_(\"N\") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )" - incx: :type: integer :intent: input - beta: :type: doublereal :intent: input - y: :type: doublereal :intent: input/output :dims: - "trans == ilatrans_(\"N\") ? 1+(m-1)*abs(incy) : 1+(n-1)*abs(incy)" - incy: :type: integer :intent: input :substitutions: lda: MAX(1, m) :fortran_help: " SUBROUTINE DLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLA_GEAMV performs one of the matrix-vector operations\n\ *\n\ * y := alpha*abs(A)*abs(x) + beta*abs(y),\n\ * or y := alpha*abs(A)'*abs(x) + beta*abs(y),\n\ *\n\ * where alpha and beta are scalars, x and y are vectors and A is an\n\ * m by n matrix.\n\ *\n\ * This function is primarily used in calculating error bounds.\n\ * To protect against underflow during evaluation, components in\n\ * the resulting vector are perturbed away from zero by (N+1)\n\ * times the underflow threshold. To prevent unnecessarily large\n\ * errors for block-structure embedded in general matrices,\n\ * \"symbolically\" zero components are not perturbed. A zero\n\ * entry is considered \"symbolic\" if all multiplications involved\n\ * in computing that entry have at least one zero multiplicand.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * TRANS (input) INTEGER\n\ * On entry, TRANS specifies the operation to be performed as\n\ * follows:\n\ *\n\ * BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y)\n\ * BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n\ * BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n\ *\n\ * Unchanged on exit.\n\ *\n\ * M (input) INTEGER\n\ * On entry, M specifies the number of rows of the matrix A.\n\ * M must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the number of columns of the matrix A.\n\ * N must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * ALPHA - DOUBLE PRECISION\n\ * On entry, ALPHA specifies the scalar alpha.\n\ * Unchanged on exit.\n\ *\n\ * A - DOUBLE PRECISION array of DIMENSION ( LDA, n )\n\ * Before entry, the leading m by n part of the array A must\n\ * contain the matrix of coefficients.\n\ * Unchanged on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * On entry, LDA specifies the first dimension of A as declared\n\ * in the calling (sub) program. LDA must be at least\n\ * max( 1, m ).\n\ * Unchanged on exit.\n\ *\n\ * X (input) DOUBLE PRECISION array, dimension\n\ * ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n\ * and at least\n\ * ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n\ * Before entry, the incremented array X must contain the\n\ * vector x.\n\ * Unchanged on exit.\n\ *\n\ * INCX (input) INTEGER\n\ * On entry, INCX specifies the increment for the elements of\n\ * X. INCX must not be zero.\n\ * Unchanged on exit.\n\ *\n\ * BETA - DOUBLE PRECISION\n\ * On entry, BETA specifies the scalar beta. When BETA is\n\ * supplied as zero then Y need not be set on input.\n\ * Unchanged on exit.\n\ *\n\ * Y - DOUBLE PRECISION\n\ * Array of DIMENSION at least\n\ * ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n\ * and at least\n\ * ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n\ * Before entry with BETA non-zero, the incremented array Y\n\ * must contain the vector y. On exit, Y is overwritten by the\n\ * updated vector y.\n\ *\n\ * INCY (input) INTEGER\n\ * On entry, INCY specifies the increment for the elements of\n\ * Y. INCY must not be zero.\n\ * Unchanged on exit.\n\ *\n\ * Level 2 Blas routine.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgesdd0000644000175000017500000001747512502223525016456 0ustar uwabamiuwabami--- :name: cgesdd :md5sum: 22c0a1340de32a426796a6de2e6183b9 :category: :subroutine :arguments: - jobz: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - s: :type: real :intent: output :dims: - MIN(m,n) - u: :type: complex :intent: output :dims: - ldu - ucol - ldu: :type: integer :intent: input - vt: :type: complex :intent: output :dims: - ldvt - n - ldvt: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"N\") ? 2*MIN(m,n)+MAX(m,n) : lsame_(&jobz,\"O\") ? 2*MIN(m,n)*MIN(m,n)+2*MIN(m,n)+MAX(m,n) : (lsame_(&jobz,\"S\")||lsame_(&jobz,\"A\")) ? MIN(m,n)*MIN(m,n)+2*MIN(m,n)+MAX(m,n) : 0" - rwork: :type: real :intent: workspace :dims: - "MAX(1, (lsame_(&jobz,\"N\") ? 5*MIN(m,n) : MIN(m,n)*MAX(5*MIN(m,n)+7,2*MAX(m,n)+2*MIN(m,n)+1)))" - iwork: :type: integer :intent: workspace :dims: - 8*MIN(m,n) - info: :type: integer :intent: output :substitutions: m: lda ucol: "((lsame_(&jobz,\"A\")) || (((lsame_(&jobz,\"O\")) && (m < n)))) ? m : lsame_(&jobz,\"S\") ? MIN(m,n) : 0" ldvt: "((lsame_(&jobz,\"A\")) || (((lsame_(&jobz,\"O\")) && (m >= n)))) ? n : lsame_(&jobz,\"S\") ? MIN(m,n) : 1" ldu: "(lsame_(&jobz,\"S\") || lsame_(&jobz,\"A\") || (lsame_(&jobz,\"O\") && m < n)) ? m : 1" :fortran_help: " SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGESDD computes the singular value decomposition (SVD) of a complex\n\ * M-by-N matrix A, optionally computing the left and/or right singular\n\ * vectors, by using divide-and-conquer method. The SVD is written\n\ *\n\ * A = U * SIGMA * conjugate-transpose(V)\n\ *\n\ * where SIGMA is an M-by-N matrix which is zero except for its\n\ * min(m,n) diagonal elements, U is an M-by-M unitary matrix, and\n\ * V is an N-by-N unitary matrix. The diagonal elements of SIGMA\n\ * are the singular values of A; they are real and non-negative, and\n\ * are returned in descending order. The first min(m,n) columns of\n\ * U and V are the left and right singular vectors of A.\n\ *\n\ * Note that the routine returns VT = V**H, not V.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * Specifies options for computing all or part of the matrix U:\n\ * = 'A': all M columns of U and all N rows of V**H are\n\ * returned in the arrays U and VT;\n\ * = 'S': the first min(M,N) columns of U and the first\n\ * min(M,N) rows of V**H are returned in the arrays U\n\ * and VT;\n\ * = 'O': If M >= N, the first N columns of U are overwritten\n\ * in the array A and all rows of V**H are returned in\n\ * the array VT;\n\ * otherwise, all columns of U are returned in the\n\ * array U and the first M rows of V**H are overwritten\n\ * in the array A;\n\ * = 'N': no columns of U or rows of V**H are computed.\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. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit,\n\ * if JOBZ = 'O', A is overwritten with the first N columns\n\ * of U (the left singular vectors, stored\n\ * columnwise) if M >= N;\n\ * A is overwritten with the first M rows\n\ * of V**H (the right singular vectors, stored\n\ * rowwise) otherwise.\n\ * if JOBZ .ne. 'O', the contents of A are destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * S (output) REAL array, dimension (min(M,N))\n\ * The singular values of A, sorted so that S(i) >= S(i+1).\n\ *\n\ * U (output) COMPLEX array, dimension (LDU,UCOL)\n\ * UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;\n\ * UCOL = min(M,N) if JOBZ = 'S'.\n\ * If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M\n\ * unitary matrix U;\n\ * if JOBZ = 'S', U contains the first min(M,N) columns of U\n\ * (the left singular vectors, stored columnwise);\n\ * if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= 1; if\n\ * JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.\n\ *\n\ * VT (output) COMPLEX array, dimension (LDVT,N)\n\ * If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the\n\ * N-by-N unitary matrix V**H;\n\ * if JOBZ = 'S', VT contains the first min(M,N) rows of\n\ * V**H (the right singular vectors, stored rowwise);\n\ * if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.\n\ *\n\ * LDVT (input) INTEGER\n\ * The leading dimension of the array VT. LDVT >= 1; if\n\ * JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;\n\ * if JOBZ = 'S', LDVT >= min(M,N).\n\ *\n\ * WORK (workspace/output) COMPLEX 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 >= 1.\n\ * if JOBZ = 'N', LWORK >= 2*min(M,N)+max(M,N).\n\ * if JOBZ = 'O',\n\ * LWORK >= 2*min(M,N)*min(M,N)+2*min(M,N)+max(M,N).\n\ * if JOBZ = 'S' or 'A',\n\ * LWORK >= min(M,N)*min(M,N)+2*min(M,N)+max(M,N).\n\ * For good performance, LWORK should generally be larger.\n\ *\n\ * If LWORK = -1, a workspace query is assumed. The optimal\n\ * size for the WORK array is calculated and stored in WORK(1),\n\ * and no other work except argument checking is performed.\n\ *\n\ * RWORK (workspace) REAL array, dimension (MAX(1,LRWORK))\n\ * If JOBZ = 'N', LRWORK >= 5*min(M,N).\n\ * Otherwise, \n\ * LRWORK >= min(M,N)*max(5*min(M,N)+7,2*max(M,N)+2*min(M,N)+1)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (8*min(M,N))\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit.\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * > 0: The updating process of SBDSDC did not converge.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ming Gu and Huan Ren, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlaev20000644000175000017500000000502512502223526016415 0ustar uwabamiuwabami--- :name: zlaev2 :md5sum: 49df9aa5c2dd69b5dc367d52878c9391 :category: :subroutine :arguments: - a: :type: doublecomplex :intent: input - b: :type: doublecomplex :intent: input - c: :type: doublecomplex :intent: input - rt1: :type: doublereal :intent: output - rt2: :type: doublereal :intent: output - cs1: :type: doublereal :intent: output - sn1: :type: doublecomplex :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZLAEV2( A, B, C, RT1, RT2, CS1, SN1 )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAEV2 computes the eigendecomposition of a 2-by-2 Hermitian matrix\n\ * [ A B ]\n\ * [ CONJG(B) C ].\n\ * On return, RT1 is the eigenvalue of larger absolute value, RT2 is the\n\ * eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right\n\ * eigenvector for RT1, giving the decomposition\n\ *\n\ * [ CS1 CONJG(SN1) ] [ A B ] [ CS1 -CONJG(SN1) ] = [ RT1 0 ]\n\ * [-SN1 CS1 ] [ CONJG(B) C ] [ SN1 CS1 ] [ 0 RT2 ].\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * A (input) COMPLEX*16\n\ * The (1,1) element of the 2-by-2 matrix.\n\ *\n\ * B (input) COMPLEX*16\n\ * The (1,2) element and the conjugate of the (2,1) element of\n\ * the 2-by-2 matrix.\n\ *\n\ * C (input) COMPLEX*16\n\ * The (2,2) element of the 2-by-2 matrix.\n\ *\n\ * RT1 (output) DOUBLE PRECISION\n\ * The eigenvalue of larger absolute value.\n\ *\n\ * RT2 (output) DOUBLE PRECISION\n\ * The eigenvalue of smaller absolute value.\n\ *\n\ * CS1 (output) DOUBLE PRECISION\n\ * SN1 (output) COMPLEX*16\n\ * The vector (CS1, SN1) is a unit right eigenvector for RT1.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * RT1 is accurate to a few ulps barring over/underflow.\n\ *\n\ * RT2 may be inaccurate if there is massive cancellation in the\n\ * determinant A*C-B*B; higher precision or correctly rounded or\n\ * correctly truncated arithmetic would be needed to compute RT2\n\ * accurately in all cases.\n\ *\n\ * CS1 and SN1 are accurate to a few ulps barring over/underflow.\n\ *\n\ * Overflow is possible only if RT1 is within a factor of 5 of overflow.\n\ * Underflow is harmless if the input data is 0 or exceeds\n\ * underflow_threshold / macheps.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cungl20000644000175000017500000000440012502223526016400 0ustar uwabamiuwabami--- :name: cungl2 :md5sum: 930c4f7265868e01524d9b4e01ef32e5 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - work: :type: complex :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE CUNGL2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CUNGL2 generates an m-by-n complex matrix Q with orthonormal rows,\n\ * which is defined as the first m rows of a product of k elementary\n\ * reflectors of order n\n\ *\n\ * Q = H(k)' . . . H(2)' H(1)'\n\ *\n\ * as returned by CGELQF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. N >= M.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. M >= K >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the i-th row must contain the vector which defines\n\ * the elementary reflector H(i), for i = 1,2,...,k, as returned\n\ * by CGELQF in the first k rows of its array argument A.\n\ * On exit, the m by n matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) COMPLEX array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by CGELQF.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (M)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zpoequb0000644000175000017500000000506612502223526016704 0ustar uwabamiuwabami--- :name: zpoequb :md5sum: fcbf97ac05d2134d5a013144e6a8d278 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - n - scond: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPOEQUB computes row and column scalings intended to equilibrate a\n\ * symmetric positive definite matrix A and reduce its condition number\n\ * (with respect to the two-norm). S contains the scale factors,\n\ * S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n\ * elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n\ * choice of S puts the condition number of B within a factor N of the\n\ * smallest possible condition number over all possible diagonal\n\ * scalings.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The N-by-N symmetric positive definite matrix whose scaling\n\ * factors are to be computed. Only the diagonal elements of A\n\ * are referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * S (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, S contains the scale factors for A.\n\ *\n\ * SCOND (output) DOUBLE PRECISION\n\ * If INFO = 0, S contains the ratio of the smallest S(i) to\n\ * the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n\ * large nor too small, it is not worth scaling by S.\n\ *\n\ * AMAX (output) DOUBLE PRECISION\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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 is nonpositive.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chpsv0000644000175000017500000001154012502223525016333 0ustar uwabamiuwabami--- :name: chpsv :md5sum: 1791c2ef87d8451f3b148e7bd5f756d0 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: output :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: n: ldb :fortran_help: " SUBROUTINE CHPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHPSV computes the solution to a complex system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N Hermitian matrix stored in packed format and X\n\ * and B are N-by-NRHS matrices.\n\ *\n\ * The diagonal pivoting method is used to factor A as\n\ * A = U * D * U**H, if UPLO = 'U', or\n\ * A = L * D * L**H, if UPLO = 'L',\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, D is Hermitian and block diagonal with 1-by-1\n\ * and 2-by-2 diagonal blocks. The factored form of A is then used to\n\ * solve the system of equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ * See below for further details.\n\ *\n\ * On exit, the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L from the factorization\n\ * A = U*D*U**H or A = L*D*L**H as computed by CHPTRF, stored as\n\ * a packed triangular matrix in the same storage format as A.\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D, as\n\ * determined by CHPTRF. If IPIV(k) > 0, then rows and columns\n\ * k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n\ * diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n\ * then rows and columns k-1 and -IPIV(k) were interchanged and\n\ * D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n\ * IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n\ * -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n\ * diagonal block.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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, D(i,i) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular, so the solution could not be\n\ * computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The packed storage scheme is illustrated by the following example\n\ * when N = 4, UPLO = 'U':\n\ *\n\ * Two-dimensional storage of the Hermitian matrix A:\n\ *\n\ * a11 a12 a13 a14\n\ * a22 a23 a24\n\ * a33 a34 (aij = conjg(aji))\n\ * a44\n\ *\n\ * Packed storage of the upper triangle of A:\n\ *\n\ * AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n\ *\n\ * =====================================================================\n\ *\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CHPTRF, CHPTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dgehd20000644000175000017500000000742412502223526016354 0ustar uwabamiuwabami--- :name: dgehd2 :md5sum: 4829ae3085abb612140e17e11185438d :category: :subroutine :arguments: - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - n-1 - work: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGEHD2 reduces a real general matrix A to upper Hessenberg form H by\n\ * an orthogonal similarity transformation: Q' * A * Q = H .\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * It is assumed that A is already upper triangular in rows\n\ * and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n\ * set by a previous call to DGEBAL; otherwise they should be\n\ * set to 1 and N respectively. See Further Details.\n\ * 1 <= ILO <= IHI <= max(1,N).\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the n by n general matrix to be reduced.\n\ * On exit, the upper triangle and the first subdiagonal of A\n\ * are overwritten with the upper Hessenberg matrix H, and the\n\ * elements below the first subdiagonal, with the array TAU,\n\ * represent the orthogonal matrix Q as a product of elementary\n\ * reflectors. See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * TAU (output) DOUBLE PRECISION array, dimension (N-1)\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (N)\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 (ihi-ilo) elementary\n\ * reflectors\n\ *\n\ * Q = H(ilo) H(ilo+1) . . . H(ihi-1).\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) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n\ * exit in A(i+2:ihi,i), and tau in TAU(i).\n\ *\n\ * The contents of A are illustrated by the following example, with\n\ * n = 7, ilo = 2 and ihi = 6:\n\ *\n\ * on entry, on exit,\n\ *\n\ * ( a a a a a a a ) ( a a h h h h a )\n\ * ( a a a a a a ) ( a h h h h a )\n\ * ( a a a a a a ) ( h h h h h h )\n\ * ( a a a a a a ) ( v2 h h h h h )\n\ * ( a a a a a a ) ( v2 v3 h h h h )\n\ * ( a a a a a a ) ( v2 v3 v4 h h h )\n\ * ( a ) ( a )\n\ *\n\ * where a denotes an element of the original matrix A, h denotes a\n\ * modified element of the upper Hessenberg matrix H, and vi denotes an\n\ * element of the vector defining H(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlasdq0000644000175000017500000001465012502223526016466 0ustar uwabamiuwabami--- :name: dlasdq :md5sum: c377895c7b312038c22d75f7469b1c8c :category: :subroutine :arguments: - uplo: :type: char :intent: input - sqre: :type: integer :intent: input - n: :type: integer :intent: input - ncvt: :type: integer :intent: input - nru: :type: integer :intent: input - ncc: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - "sqre==0 ? n-1 : sqre==1 ? n : 0" - vt: :type: doublereal :intent: input/output :dims: - ldvt - ncvt - ldvt: :type: integer :intent: input - u: :type: doublereal :intent: input/output :dims: - ldu - n - ldu: :type: integer :intent: input - c: :type: doublereal :intent: input/output :dims: - ldc - ncc - ldc: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLASDQ computes the singular value decomposition (SVD) of a real\n\ * (upper or lower) bidiagonal matrix with diagonal D and offdiagonal\n\ * E, accumulating the transformations if desired. Letting B denote\n\ * the input bidiagonal matrix, the algorithm computes orthogonal\n\ * matrices Q and P such that B = Q * S * P' (P' denotes the transpose\n\ * of P). The singular values S are overwritten on D.\n\ *\n\ * The input matrix U is changed to U * Q if desired.\n\ * The input matrix VT is changed to P' * VT if desired.\n\ * The input matrix C is changed to Q' * C if desired.\n\ *\n\ * See \"Computing Small Singular Values of Bidiagonal Matrices With\n\ * Guaranteed High Relative Accuracy,\" by J. Demmel and W. Kahan,\n\ * LAPACK Working Note #3, for a detailed description of the algorithm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * On entry, UPLO specifies whether the input bidiagonal matrix\n\ * is upper or lower bidiagonal, and wether it is square are\n\ * not.\n\ * UPLO = 'U' or 'u' B is upper bidiagonal.\n\ * UPLO = 'L' or 'l' B is lower bidiagonal.\n\ *\n\ * SQRE (input) INTEGER\n\ * = 0: then the input matrix is N-by-N.\n\ * = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and\n\ * (N+1)-by-N if UPLU = 'L'.\n\ *\n\ * The bidiagonal matrix has\n\ * N = NL + NR + 1 rows and\n\ * M = N + SQRE >= N columns.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the number of rows and columns\n\ * in the matrix. N must be at least 0.\n\ *\n\ * NCVT (input) INTEGER\n\ * On entry, NCVT specifies the number of columns of\n\ * the matrix VT. NCVT must be at least 0.\n\ *\n\ * NRU (input) INTEGER\n\ * On entry, NRU specifies the number of rows of\n\ * the matrix U. NRU must be at least 0.\n\ *\n\ * NCC (input) INTEGER\n\ * On entry, NCC specifies the number of columns of\n\ * the matrix C. NCC must be at least 0.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, D contains the diagonal entries of the\n\ * bidiagonal matrix whose SVD is desired. On normal exit,\n\ * D contains the singular values in ascending order.\n\ *\n\ * E (input/output) DOUBLE PRECISION array.\n\ * dimension is (N-1) if SQRE = 0 and N if SQRE = 1.\n\ * On entry, the entries of E contain the offdiagonal entries\n\ * of the bidiagonal matrix whose SVD is desired. On normal\n\ * exit, E will contain 0. If the algorithm does not converge,\n\ * D and E will contain the diagonal and superdiagonal entries\n\ * of a bidiagonal matrix orthogonally equivalent to the one\n\ * given as input.\n\ *\n\ * VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT)\n\ * On entry, contains a matrix which on exit has been\n\ * premultiplied by P', dimension N-by-NCVT if SQRE = 0\n\ * and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0).\n\ *\n\ * LDVT (input) INTEGER\n\ * On entry, LDVT specifies the leading dimension of VT as\n\ * declared in the calling (sub) program. LDVT must be at\n\ * least 1. If NCVT is nonzero LDVT must also be at least N.\n\ *\n\ * U (input/output) DOUBLE PRECISION array, dimension (LDU, N)\n\ * On entry, contains a matrix which on exit has been\n\ * postmultiplied by Q, dimension NRU-by-N if SQRE = 0\n\ * and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0).\n\ *\n\ * LDU (input) INTEGER\n\ * On entry, LDU specifies the leading dimension of U as\n\ * declared in the calling (sub) program. LDU must be at\n\ * least max( 1, NRU ) .\n\ *\n\ * C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC)\n\ * On entry, contains an N-by-NCC matrix which on exit\n\ * has been premultiplied by Q' dimension N-by-NCC if SQRE = 0\n\ * and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0).\n\ *\n\ * LDC (input) INTEGER\n\ * On entry, LDC specifies the leading dimension of C as\n\ * declared in the calling (sub) program. LDC must be at\n\ * least 1. If NCC is nonzero, LDC must also be at least N.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n\ * Workspace. Only referenced if one of NCVT, NRU, or NCC is\n\ * nonzero, and if N is at least 2.\n\ *\n\ * INFO (output) INTEGER\n\ * On exit, a value of 0 indicates a successful exit.\n\ * If INFO < 0, argument number -INFO is illegal.\n\ * If INFO > 0, the algorithm did not converge, and INFO\n\ * specifies how many superdiagonals did not converge.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ming Gu and Huan Ren, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssbgst0000644000175000017500000000761312502223526016524 0ustar uwabamiuwabami--- :name: ssbgst :md5sum: 14370d921ebcc0d145ab5ead41aee089 :category: :subroutine :arguments: - vect: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: real :intent: input :dims: - ldbb - n - ldbb: :type: integer :intent: input - x: :type: real :intent: output :dims: - ldx - n - ldx: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldx: "lsame_(&vect,\"V\") ? MAX(1,n) : 1" :fortran_help: " SUBROUTINE SSBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, LDX, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSBGST reduces a real symmetric-definite banded generalized\n\ * eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y,\n\ * such that C has the same bandwidth as A.\n\ *\n\ * B must have been previously factorized as S**T*S by SPBSTF, using a\n\ * split Cholesky factorization. A is overwritten by C = X**T*A*X, where\n\ * X = S**(-1)*Q and Q is an orthogonal matrix chosen to preserve the\n\ * bandwidth of A.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * VECT (input) CHARACTER*1\n\ * = 'N': do not form the transformation matrix X;\n\ * = 'V': form X.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * KA (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n\ *\n\ * KB (input) INTEGER\n\ * The number of superdiagonals of the matrix B if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0.\n\ *\n\ * AB (input/output) REAL array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first ka+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n\ *\n\ * On exit, the transformed matrix X**T*A*X, stored in the same\n\ * format as A.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KA+1.\n\ *\n\ * BB (input) REAL array, dimension (LDBB,N)\n\ * The banded factor S from the split Cholesky factorization of\n\ * B, as returned by SPBSTF, stored in the first KB+1 rows of\n\ * the array.\n\ *\n\ * LDBB (input) INTEGER\n\ * The leading dimension of the array BB. LDBB >= KB+1.\n\ *\n\ * X (output) REAL array, dimension (LDX,N)\n\ * If VECT = 'V', the n-by-n matrix X.\n\ * If VECT = 'N', the array X is not referenced.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X.\n\ * LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.\n\ *\n\ * WORK (workspace) REAL array, dimension (2*N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/claqr30000644000175000017500000001736512502223525016410 0ustar uwabamiuwabami--- :name: claqr3 :md5sum: f6a7a83a5d8a4a26881150044fdfd443 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ktop: :type: integer :intent: input - kbot: :type: integer :intent: input - nw: :type: integer :intent: input - h: :type: complex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: complex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - ns: :type: integer :intent: output - nd: :type: integer :intent: output - sh: :type: complex :intent: output :dims: - MAX(1,kbot) - v: :type: complex :intent: workspace :dims: - ldv - MAX(1,nw) - ldv: :type: integer :intent: input - nh: :type: integer :intent: input - t: :type: complex :intent: workspace :dims: - ldv - MAX(1,nw) - ldt: :type: integer :intent: input - nv: :type: integer :intent: input - wv: :type: complex :intent: workspace :dims: - ldv - MAX(1,nw) - ldwv: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*nw :substitutions: ldwv: nw ldt: nw ldv: nw :fortran_help: " SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n\ * Aggressive early deflation:\n\ *\n\ * This subroutine accepts as input an upper Hessenberg matrix\n\ * H and performs an unitary similarity transformation\n\ * designed to detect and deflate fully converged eigenvalues from\n\ * a trailing principal submatrix. On output H has been over-\n\ * written by a new Hessenberg matrix that is a perturbation of\n\ * an unitary similarity transformation of H. It is to be\n\ * hoped that the final version of H has many zero subdiagonal\n\ * entries.\n\ *\n\ * ******************************************************************\n\n\ * WANTT (input) LOGICAL\n\ * If .TRUE., then the Hessenberg matrix H is fully updated\n\ * so that the triangular Schur factor may be\n\ * computed (in cooperation with the calling subroutine).\n\ * If .FALSE., then only enough of H is updated to preserve\n\ * the eigenvalues.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * If .TRUE., then the unitary matrix Z is updated so\n\ * so that the unitary Schur factor may be computed\n\ * (in cooperation with the calling subroutine).\n\ * If .FALSE., then Z is not referenced.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H and (if WANTZ is .TRUE.) the\n\ * order of the unitary matrix Z.\n\ *\n\ * KTOP (input) INTEGER\n\ * It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n\ * KBOT and KTOP together determine an isolated block\n\ * along the diagonal of the Hessenberg matrix.\n\ *\n\ * KBOT (input) INTEGER\n\ * It is assumed without a check that either\n\ * KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together\n\ * determine an isolated block along the diagonal of the\n\ * Hessenberg matrix.\n\ *\n\ * NW (input) INTEGER\n\ * Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).\n\ *\n\ * H (input/output) COMPLEX array, dimension (LDH,N)\n\ * On input the initial N-by-N section of H stores the\n\ * Hessenberg matrix undergoing aggressive early deflation.\n\ * On output H has been transformed by a unitary\n\ * similarity transformation, perturbed, and the returned\n\ * to Hessenberg form that (it is to be hoped) has some\n\ * zero subdiagonal entries.\n\ *\n\ * LDH (input) integer\n\ * Leading dimension of H just as declared in the calling\n\ * subroutine. N .LE. LDH\n\ *\n\ * ILOZ (input) INTEGER\n\ * IHIZ (input) INTEGER\n\ * Specify the rows of Z to which transformations must be\n\ * applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n\ *\n\ * Z (input/output) COMPLEX array, dimension (LDZ,N)\n\ * IF WANTZ is .TRUE., then on output, the unitary\n\ * similarity transformation mentioned above has been\n\ * accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n\ * If WANTZ is .FALSE., then Z is unreferenced.\n\ *\n\ * LDZ (input) integer\n\ * The leading dimension of Z just as declared in the\n\ * calling subroutine. 1 .LE. LDZ.\n\ *\n\ * NS (output) integer\n\ * The number of unconverged (ie approximate) eigenvalues\n\ * returned in SR and SI that may be used as shifts by the\n\ * calling subroutine.\n\ *\n\ * ND (output) integer\n\ * The number of converged eigenvalues uncovered by this\n\ * subroutine.\n\ *\n\ * SH (output) COMPLEX array, dimension KBOT\n\ * On output, approximate eigenvalues that may\n\ * be used for shifts are stored in SH(KBOT-ND-NS+1)\n\ * through SR(KBOT-ND). Converged eigenvalues are\n\ * stored in SH(KBOT-ND+1) through SH(KBOT).\n\ *\n\ * V (workspace) COMPLEX array, dimension (LDV,NW)\n\ * An NW-by-NW work array.\n\ *\n\ * LDV (input) integer scalar\n\ * The leading dimension of V just as declared in the\n\ * calling subroutine. NW .LE. LDV\n\ *\n\ * NH (input) integer scalar\n\ * The number of columns of T. NH.GE.NW.\n\ *\n\ * T (workspace) COMPLEX array, dimension (LDT,NW)\n\ *\n\ * LDT (input) integer\n\ * The leading dimension of T just as declared in the\n\ * calling subroutine. NW .LE. LDT\n\ *\n\ * NV (input) integer\n\ * The number of rows of work array WV available for\n\ * workspace. NV.GE.NW.\n\ *\n\ * WV (workspace) COMPLEX array, dimension (LDWV,NW)\n\ *\n\ * LDWV (input) integer\n\ * The leading dimension of W just as declared in the\n\ * calling subroutine. NW .LE. LDV\n\ *\n\ * WORK (workspace) COMPLEX array, dimension LWORK.\n\ * On exit, WORK(1) is set to an estimate of the optimal value\n\ * of LWORK for the given values of N, NW, KTOP and KBOT.\n\ *\n\ * LWORK (input) integer\n\ * The dimension of the work array WORK. LWORK = 2*NW\n\ * suffices, but greater efficiency may result from larger\n\ * values of LWORK.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; CLAQR3\n\ * only estimates the optimal workspace size for the given\n\ * values of N, NW, KTOP and KBOT. The estimate is returned\n\ * in WORK(1). No error message related to LWORK is issued\n\ * by XERBLA. Neither H nor Z are accessed.\n\ *\n\n\ * ================================================================\n\ * Based on contributions by\n\ * Karen Braman and Ralph Byers, Department of Mathematics,\n\ * University of Kansas, USA\n\ *\n\ * ================================================================\n" ruby-lapack-1.7.2/dev/defs/dgtts20000644000175000017500000000603212502223526016420 0ustar uwabamiuwabami--- :name: dgtts2 :md5sum: 709bd757314a13f631c15ff3b78523f5 :category: :subroutine :arguments: - itrans: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: doublereal :intent: input :dims: - n-1 - d: :type: doublereal :intent: input :dims: - n - du: :type: doublereal :intent: input :dims: - n-1 - du2: :type: doublereal :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGTTS2 solves one of the systems of equations\n\ * A*X = B or A'*X = B,\n\ * with a tridiagonal matrix A using the LU factorization computed\n\ * by DGTTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITRANS (input) INTEGER\n\ * Specifies the form of the system of equations.\n\ * = 0: A * X = B (No transpose)\n\ * = 1: A'* X = B (Transpose)\n\ * = 2: A'* X = B (Conjugate transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * DL (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) multipliers that define the matrix L from the\n\ * LU factorization of A.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The n diagonal elements of the upper triangular matrix U from\n\ * the LU factorization of A.\n\ *\n\ * DU (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) elements of the first super-diagonal of U.\n\ *\n\ * DU2 (input) DOUBLE PRECISION array, dimension (N-2)\n\ * The (n-2) elements of the second super-diagonal of U.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices; for 1 <= i <= n, row i of the matrix was\n\ * interchanged with row IPIV(i). IPIV(i) will always be either\n\ * i or i+1; IPIV(i) = i indicates a row interchange was not\n\ * required.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the matrix of right hand side vectors B.\n\ * On exit, B is overwritten by the solution vectors X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, IP, J\n DOUBLE PRECISION TEMP\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dormr30000644000175000017500000001115512502223526016421 0ustar uwabamiuwabami--- :name: dormr3 :md5sum: 5ee7280aa9deca5f92422e6d0bdeb1f2 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DORMR3 overwrites the general real m by n matrix C with\n\ *\n\ * Q * C if SIDE = 'L' and TRANS = 'N', or\n\ *\n\ * Q'* C if SIDE = 'L' and TRANS = 'T', or\n\ *\n\ * C * Q if SIDE = 'R' and TRANS = 'N', or\n\ *\n\ * C * Q' if SIDE = 'R' and TRANS = 'T',\n\ *\n\ * where Q is a real orthogonal matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by DTZRZF. Q is of order m if SIDE = 'L' and of order n\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q' from the Left\n\ * = 'R': apply Q or Q' from the Right\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': apply Q (No transpose)\n\ * = 'T': apply Q' (Transpose)\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * L (input) INTEGER\n\ * The number of columns of the matrix A containing\n\ * the meaningful part of the Householder reflectors.\n\ * If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension\n\ * (LDA,M) if SIDE = 'L',\n\ * (LDA,N) if SIDE = 'R'\n\ * The i-th row must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * DTZRZF in the last k rows of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,K).\n\ *\n\ * TAU (input) DOUBLE PRECISION array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by DTZRZF.\n\ *\n\ * C (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n\ * On entry, the m-by-n matrix C.\n\ * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension\n\ * (N) if SIDE = 'L',\n\ * (M) if SIDE = 'R'\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\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LEFT, NOTRAN\n INTEGER I, I1, I2, I3, IC, JA, JC, MI, NI, NQ\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DLARZ, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sspcon0000644000175000017500000000523612502223526016523 0ustar uwabamiuwabami--- :name: sspcon :md5sum: be9e7176a45065d4328b9ed8b007eba9 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 2*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSPCON estimates the reciprocal of the condition number (in the\n\ * 1-norm) of a real symmetric packed matrix A using the factorization\n\ * A = U*D*U**T or A = L*D*L**T computed by SSPTRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input) REAL array, dimension (N*(N+1)/2)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by SSPTRF, stored as a\n\ * packed triangular matrix.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by SSPTRF.\n\ *\n\ * ANORM (input) REAL\n\ * The 1-norm of the original matrix A.\n\ *\n\ * RCOND (output) REAL\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n\ * estimate of the 1-norm of inv(A) computed in this routine.\n\ *\n\ * WORK (workspace) REAL array, dimension (2*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgbequb0000644000175000017500000001025412502223526016642 0ustar uwabamiuwabami--- :name: sgbequb :md5sum: eebb96e018d76111b5c0fb465d6e56d3 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - r: :type: real :intent: output :dims: - m - c: :type: real :intent: output :dims: - n - rowcnd: :type: real :intent: output - colcnd: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: m: ldab :fortran_help: " SUBROUTINE SGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGBEQUB computes row and column scalings intended to equilibrate an\n\ * M-by-N matrix A and reduce its condition number. R returns the row\n\ * scale factors and C the column scale factors, chosen to try to make\n\ * the largest element in each row and column of the matrix B with\n\ * elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n\ * the radix.\n\ *\n\ * R(i) and C(j) are restricted to be a power of the radix between\n\ * SMLNUM = smallest safe number and BIGNUM = largest safe number. Use\n\ * of these scaling factors is not guaranteed to reduce the condition\n\ * number of A but works well in practice.\n\ *\n\ * This routine differs from SGEEQU by restricting the scaling factors\n\ * to a power of the radix. Baring over- and underflow, scaling by\n\ * these factors introduces no additional rounding errors. However, the\n\ * scaled entries' magnitured are no longer approximately 1 but lie\n\ * between sqrt(radix) and 1/sqrt(radix).\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\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array A. LDAB >= max(1,M).\n\ *\n\ * R (output) REAL array, dimension (M)\n\ * If INFO = 0 or INFO > M, R contains the row scale factors\n\ * for A.\n\ *\n\ * C (output) REAL array, dimension (N)\n\ * If INFO = 0, C contains the column scale factors for A.\n\ *\n\ * ROWCND (output) REAL\n\ * If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n\ * smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n\ * AMAX is neither too large nor too small, it is not worth\n\ * scaling by R.\n\ *\n\ * COLCND (output) REAL\n\ * If INFO = 0, COLCND contains the ratio of the smallest\n\ * C(i) to the largest C(i). If COLCND >= 0.1, it is not\n\ * worth scaling by C.\n\ *\n\ * AMAX (output) REAL\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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, and i is\n\ * <= M: the i-th row of A is exactly zero\n\ * > M: the (i-M)-th column of A is exactly zero\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgttrf0000644000175000017500000000613712502223526016537 0ustar uwabamiuwabami--- :name: zgttrf :md5sum: 66195e75eb1a5199cd58d87b31de3919 :category: :subroutine :arguments: - n: :type: integer :intent: input - dl: :type: doublecomplex :intent: input/output :dims: - n-1 - d: :type: doublecomplex :intent: input/output :dims: - n - du: :type: doublecomplex :intent: input/output :dims: - n-1 - du2: :type: doublecomplex :intent: output :dims: - n-2 - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGTTRF( N, DL, D, DU, DU2, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGTTRF computes an LU factorization of a complex tridiagonal matrix A\n\ * using elimination with partial pivoting and row interchanges.\n\ *\n\ * The factorization has the form\n\ * A = L * U\n\ * where L is a product of permutation and unit lower bidiagonal\n\ * matrices and U is upper triangular with nonzeros in only the main\n\ * diagonal and first two superdiagonals.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A.\n\ *\n\ * DL (input/output) COMPLEX*16 array, dimension (N-1)\n\ * On entry, DL must contain the (n-1) sub-diagonal elements of\n\ * A.\n\ *\n\ * On exit, DL is overwritten by the (n-1) multipliers that\n\ * define the matrix L from the LU factorization of A.\n\ *\n\ * D (input/output) COMPLEX*16 array, dimension (N)\n\ * On entry, D must contain the diagonal elements of A.\n\ *\n\ * On exit, D is overwritten by the n diagonal elements of the\n\ * upper triangular matrix U from the LU factorization of A.\n\ *\n\ * DU (input/output) COMPLEX*16 array, dimension (N-1)\n\ * On entry, DU must contain the (n-1) super-diagonal elements\n\ * of A.\n\ *\n\ * On exit, DU is overwritten by the (n-1) elements of the first\n\ * super-diagonal of U.\n\ *\n\ * DU2 (output) COMPLEX*16 array, dimension (N-2)\n\ * On exit, DU2 is overwritten by the (n-2) elements of the\n\ * second super-diagonal of U.\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * The pivot indices; for 1 <= i <= n, row i of the matrix was\n\ * interchanged with row IPIV(i). IPIV(i) will always be either\n\ * i or i+1; IPIV(i) = i indicates a row interchange was not\n\ * required.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ * > 0: if INFO = k, U(k,k) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, and division by zero will occur if it is used\n\ * to solve a system of equations.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cla_syamv0000644000175000017500000001114112502223525017163 0ustar uwabamiuwabami--- :name: cla_syamv :md5sum: 191e7c227fca4a3845d40fa60b7eaa53 :category: :subroutine :arguments: - uplo: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: real :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: complex :intent: input :dims: - 1 + ( n - 1 )*abs( incx ) - incx: :type: integer :intent: input - beta: :type: real :intent: input - y: :type: real :intent: input/output :dims: - 1 + ( n - 1 )*abs( incy ) - incy: :type: integer :intent: input :substitutions: n: lda :fortran_help: " SUBROUTINE CLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLA_SYAMV performs the matrix-vector operation\n\ *\n\ * y := alpha*abs(A)*abs(x) + beta*abs(y),\n\ *\n\ * where alpha and beta are scalars, x and y are vectors and A is an\n\ * n by n symmetric matrix.\n\ *\n\ * This function is primarily used in calculating error bounds.\n\ * To protect against underflow during evaluation, components in\n\ * the resulting vector are perturbed away from zero by (N+1)\n\ * times the underflow threshold. To prevent unnecessarily large\n\ * errors for block-structure embedded in general matrices,\n\ * \"symbolically\" zero components are not perturbed. A zero\n\ * entry is considered \"symbolic\" if all multiplications involved\n\ * in computing that entry have at least one zero multiplicand.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * UPLO (input) INTEGER\n\ * On entry, UPLO specifies whether the upper or lower\n\ * triangular part of the array A is to be referenced as\n\ * follows:\n\ *\n\ * UPLO = BLAS_UPPER Only the upper triangular part of A\n\ * is to be referenced.\n\ *\n\ * UPLO = BLAS_LOWER Only the lower triangular part of A\n\ * is to be referenced.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the number of columns of the matrix A.\n\ * N must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * ALPHA (input) REAL .\n\ * On entry, ALPHA specifies the scalar alpha.\n\ * Unchanged on exit.\n\ *\n\ * A - COMPLEX array of DIMENSION ( LDA, n ).\n\ * Before entry, the leading m by n part of the array A must\n\ * contain the matrix of coefficients.\n\ * Unchanged on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * On entry, LDA specifies the first dimension of A as declared\n\ * in the calling (sub) program. LDA must be at least\n\ * max( 1, n ).\n\ * Unchanged on exit.\n\ *\n\ * X (input) COMPLEX array, dimension\n\ * ( 1 + ( n - 1 )*abs( INCX ) )\n\ * Before entry, the incremented array X must contain the\n\ * vector x.\n\ * Unchanged on exit.\n\ *\n\ * INCX (input) INTEGER\n\ * On entry, INCX specifies the increment for the elements of\n\ * X. INCX must not be zero.\n\ * Unchanged on exit.\n\ *\n\ * BETA (input) REAL .\n\ * On entry, BETA specifies the scalar beta. When BETA is\n\ * supplied as zero then Y need not be set on input.\n\ * Unchanged on exit.\n\ *\n\ * Y (input/output) REAL array, dimension\n\ * ( 1 + ( n - 1 )*abs( INCY ) )\n\ * Before entry with BETA non-zero, the incremented array Y\n\ * must contain the vector y. On exit, Y is overwritten by the\n\ * updated vector y.\n\ *\n\ * INCY (input) INTEGER\n\ * On entry, INCY specifies the increment for the elements of\n\ * Y. INCY must not be zero.\n\ * Unchanged on exit.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Level 2 Blas routine.\n\ *\n\ * -- Written on 22-October-1986.\n\ * Jack Dongarra, Argonne National Lab.\n\ * Jeremy Du Croz, Nag Central Office.\n\ * Sven Hammarling, Nag Central Office.\n\ * Richard Hanson, Sandia National Labs.\n\ * -- Modified for the absolute-value product, April 2006\n\ * Jason Riedy, UC Berkeley\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zptsv0000644000175000017500000000571312502223526016404 0ustar uwabamiuwabami--- :name: zptsv :md5sum: 616f9ce474fe61d89341347d5adc59a9 :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublecomplex :intent: input/output :dims: - n-1 - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPTSV( N, NRHS, D, E, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPTSV computes the solution to a complex system of linear equations\n\ * A*X = B, where A is an N-by-N Hermitian positive definite tridiagonal\n\ * matrix, and X and B are N-by-NRHS matrices.\n\ *\n\ * A is factored as A = L*D*L**H, and the factored form of A is then\n\ * used to solve the system of equations.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the n diagonal elements of the tridiagonal matrix\n\ * A. On exit, the n diagonal elements of the diagonal matrix\n\ * D from the factorization A = L*D*L**H.\n\ *\n\ * E (input/output) COMPLEX*16 array, dimension (N-1)\n\ * On entry, the (n-1) subdiagonal elements of the tridiagonal\n\ * matrix A. On exit, the (n-1) subdiagonal elements of the\n\ * unit bidiagonal factor L from the L*D*L**H factorization of\n\ * A. E can also be regarded as the superdiagonal of the unit\n\ * bidiagonal factor U from the U**H*D*U factorization of A.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,N)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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 leading minor of order i is not\n\ * positive definite, and the solution has not been\n\ * computed. The factorization has not been completed\n\ * unless i = N.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZPTTRF, ZPTTRS\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zlarzb0000644000175000017500000001036612502223526016522 0ustar uwabamiuwabami--- :name: zlarzb :md5sum: c84f4faa09b773e85cce145ad0d50edf :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - direct: :type: char :intent: input - storev: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - v: :type: doublecomplex :intent: input :dims: - ldv - nv - ldv: :type: integer :intent: input - t: :type: doublecomplex :intent: input :dims: - ldt - k - ldt: :type: integer :intent: input - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - ldwork - k - ldwork: :type: integer :intent: input :substitutions: ldwork: "MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0" :fortran_help: " SUBROUTINE ZLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLARZB applies a complex block reflector H or its transpose H**H\n\ * to a complex distributed M-by-N C from the left or the right.\n\ *\n\ * Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply H or H' from the Left\n\ * = 'R': apply H or H' from the Right\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': apply H (No transpose)\n\ * = 'C': apply H' (Conjugate transpose)\n\ *\n\ * DIRECT (input) CHARACTER*1\n\ * Indicates how H is formed from a product of elementary\n\ * reflectors\n\ * = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n\ * = 'B': H = H(k) . . . H(2) H(1) (Backward)\n\ *\n\ * STOREV (input) CHARACTER*1\n\ * Indicates how the vectors which define the elementary\n\ * reflectors are stored:\n\ * = 'C': Columnwise (not supported yet)\n\ * = 'R': Rowwise\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C.\n\ *\n\ * K (input) INTEGER\n\ * The order of the matrix T (= the number of elementary\n\ * reflectors whose product defines the block reflector).\n\ *\n\ * L (input) INTEGER\n\ * The number of columns of the matrix V containing the\n\ * meaningful part of the Householder reflectors.\n\ * If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n\ *\n\ * V (input) COMPLEX*16 array, dimension (LDV,NV).\n\ * If STOREV = 'C', NV = K; if STOREV = 'R', NV = L.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V.\n\ * If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K.\n\ *\n\ * T (input) COMPLEX*16 array, dimension (LDT,K)\n\ * The triangular K-by-K matrix T in the representation of the\n\ * block reflector.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= K.\n\ *\n\ * C (input/output) COMPLEX*16 array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by H*C or H'*C or C*H or C*H'.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (LDWORK,K)\n\ *\n\ * LDWORK (input) INTEGER\n\ * The leading dimension of the array WORK.\n\ * If SIDE = 'L', LDWORK >= max(1,N);\n\ * if SIDE = 'R', LDWORK >= max(1,M).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgeqrf0000644000175000017500000000730012502223526016506 0ustar uwabamiuwabami--- :name: zgeqrf :md5sum: fdd67225f3e47265b559a2ec6bf67a18 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - MIN(m,n) - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGEQRF computes a QR factorization of a complex M-by-N matrix A:\n\ * A = Q * R.\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) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, the elements on and above the diagonal of the array\n\ * contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n\ * upper triangular if m >= n); the elements below the diagonal,\n\ * with the array TAU, represent the unitary matrix Q as a\n\ * product of min(m,n) elementary reflectors (see Further\n\ * Details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (output) COMPLEX*16 array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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,N).\n\ * For optimum performance LWORK >= N*NB, where NB is\n\ * the 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(1) H(2) . . . H(k), 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 complex scalar, and v is a complex vector with\n\ * v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\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 XERBLA, ZGEQR2, ZLARFB, ZLARFT\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cgglse0000644000175000017500000001211012502223525016446 0ustar uwabamiuwabami--- :name: cgglse :md5sum: 76651864baa26d2d1471eeda133757a5 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - p: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: complex :intent: input/output :dims: - m - d: :type: complex :intent: input/output :dims: - p - x: :type: complex :intent: output :dims: - n - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m+n+p - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGGLSE solves the linear equality-constrained least squares (LSE)\n\ * problem:\n\ *\n\ * minimize || c - A*x ||_2 subject to B*x = d\n\ *\n\ * where A is an M-by-N matrix, B is a P-by-N matrix, c is a given\n\ * M-vector, and d is a given P-vector. It is assumed that\n\ * P <= N <= M+P, and\n\ *\n\ * rank(B) = P and rank( (A) ) = N.\n\ * ( (B) )\n\ *\n\ * These conditions ensure that the LSE problem has a unique solution,\n\ * which is obtained using a generalized RQ factorization of the\n\ * matrices (B, A) given by\n\ *\n\ * B = (0 R)*Q, A = Z*T*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 matrices A and B. N >= 0.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows of the matrix B. 0 <= P <= N <= M+P.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, the elements on and above the diagonal of the array\n\ * contain the min(M,N)-by-N upper trapezoidal matrix T.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,N)\n\ * On entry, the P-by-N matrix B.\n\ * On exit, the upper triangle of the subarray B(1:P,N-P+1:N)\n\ * contains the P-by-P upper triangular matrix R.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,P).\n\ *\n\ * C (input/output) COMPLEX array, dimension (M)\n\ * On entry, C contains the right hand side vector for the\n\ * least squares part of the LSE problem.\n\ * On exit, the residual sum of squares for the solution\n\ * is given by the sum of squares of elements N-P+1 to M of\n\ * vector C.\n\ *\n\ * D (input/output) COMPLEX array, dimension (P)\n\ * On entry, D contains the right hand side vector for the\n\ * constrained equation.\n\ * On exit, D is destroyed.\n\ *\n\ * X (output) COMPLEX array, dimension (N)\n\ * On exit, X is the solution of the LSE problem.\n\ *\n\ * WORK (workspace/output) COMPLEX 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+P).\n\ * For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,\n\ * where NB is an upper bound for the optimal blocksizes for\n\ * CGEQRF, CGERQF, CUNMQR and CUNMRQ.\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\ * = 1: the upper triangular factor R associated with B in the\n\ * generalized RQ factorization of the pair (B, A) is\n\ * singular, so that rank(B) < P; the least squares\n\ * solution could not be computed.\n\ * = 2: the (N-P) by (N-P) part of the upper trapezoidal factor\n\ * T associated with A in the generalized RQ factorization\n\ * of the pair (B, A) is singular, so that\n\ * rank( (A) ) < N; the least squares solution could not\n\ * ( (B) )\n\ * be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slasdt0000644000175000017500000000364112502223526016506 0ustar uwabamiuwabami--- :name: slasdt :md5sum: 5376f79e53fc9785b46d6951f8772790 :category: :subroutine :arguments: - n: :type: integer :intent: input - lvl: :type: integer :intent: output - nd: :type: integer :intent: output - inode: :type: integer :intent: output :dims: - MAX(1,n) - ndiml: :type: integer :intent: output :dims: - MAX(1,n) - ndimr: :type: integer :intent: output :dims: - MAX(1,n) - msub: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE SLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLASDT creates a tree of subproblems for bidiagonal divide and\n\ * conquer.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * On entry, the number of diagonal elements of the\n\ * bidiagonal matrix.\n\ *\n\ * LVL (output) INTEGER\n\ * On exit, the number of levels on the computation tree.\n\ *\n\ * ND (output) INTEGER\n\ * On exit, the number of nodes on the tree.\n\ *\n\ * INODE (output) INTEGER array, dimension ( N )\n\ * On exit, centers of subproblems.\n\ *\n\ * NDIML (output) INTEGER array, dimension ( N )\n\ * On exit, row dimensions of left children.\n\ *\n\ * NDIMR (output) INTEGER array, dimension ( N )\n\ * On exit, row dimensions of right children.\n\ *\n\ * MSUB (input) INTEGER\n\ * On entry, the maximum row dimension each subproblem at the\n\ * bottom of the tree can be of.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ming Gu and Huan Ren, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssytrd0000644000175000017500000001304212502223526016540 0ustar uwabamiuwabami--- :name: ssytrd :md5sum: b138e11daf348714582c26e44231dbd9 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: real :intent: output :dims: - n - e: :type: real :intent: output :dims: - n-1 - tau: :type: real :intent: output :dims: - n-1 - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSYTRD reduces a real symmetric matrix A to real symmetric\n\ * tridiagonal form T by an orthogonal similarity transformation:\n\ * Q**T * A * Q = T.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ * On exit, if UPLO = 'U', the diagonal and first superdiagonal\n\ * of A are overwritten by the corresponding elements of the\n\ * tridiagonal matrix T, and the elements above the first\n\ * superdiagonal, with the array TAU, represent the orthogonal\n\ * matrix Q as a product of elementary reflectors; if UPLO\n\ * = 'L', the diagonal and first subdiagonal of A are over-\n\ * written by the corresponding elements of the tridiagonal\n\ * matrix T, and the elements below the first subdiagonal, with\n\ * the array TAU, represent the orthogonal matrix Q as a product\n\ * of elementary reflectors. See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * D (output) REAL array, dimension (N)\n\ * The diagonal elements of the tridiagonal matrix T:\n\ * D(i) = A(i,i).\n\ *\n\ * E (output) REAL array, dimension (N-1)\n\ * The off-diagonal elements of the tridiagonal matrix T:\n\ * E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n\ *\n\ * TAU (output) REAL array, dimension (N-1)\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace/output) REAL 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 >= 1.\n\ * For optimum performance LWORK >= N*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\ * If UPLO = 'U', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(n-1) . . . H(2) H(1).\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(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n\ * A(1:i-1,i+1), and tau in TAU(i).\n\ *\n\ * If UPLO = 'L', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(n-1).\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) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n\ * and tau in TAU(i).\n\ *\n\ * The contents of A on exit are illustrated by the following examples\n\ * with n = 5:\n\ *\n\ * if UPLO = 'U': if UPLO = 'L':\n\ *\n\ * ( d e v2 v3 v4 ) ( d )\n\ * ( d e v3 v4 ) ( e d )\n\ * ( d e v4 ) ( v1 e d )\n\ * ( d e ) ( v1 v2 e d )\n\ * ( d ) ( v1 v2 v3 e d )\n\ *\n\ * where d and e denote diagonal and off-diagonal elements of T, and vi\n\ * denotes an element of the vector defining H(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slaqsp0000644000175000017500000000531112502223526016513 0ustar uwabamiuwabami--- :name: slaqsp :md5sum: 3614f64211713ef89af82dc2852fc696 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - n*(n+1)/2 - s: :type: real :intent: input :dims: - n - scond: :type: real :intent: input - amax: :type: real :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAQSP equilibrates a symmetric matrix A using the scaling factors\n\ * in the vector S.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) REAL array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, the equilibrated matrix: diag(S) * A * diag(S), in\n\ * the same storage format as A.\n\ *\n\ * S (input) REAL array, dimension (N)\n\ * The scale factors for A.\n\ *\n\ * SCOND (input) REAL\n\ * Ratio of the smallest S(i) to the largest S(i).\n\ *\n\ * AMAX (input) REAL\n\ * Absolute value of largest matrix entry.\n\ *\n\ * EQUED (output) CHARACTER*1\n\ * Specifies whether or not equilibration was done.\n\ * = 'N': No equilibration.\n\ * = 'Y': Equilibration was done, i.e., A has been replaced by\n\ * diag(S) * A * diag(S).\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * THRESH is a threshold value used to decide if scaling should be done\n\ * based on the ratio of the scaling factors. If SCOND < THRESH,\n\ * scaling is done.\n\ *\n\ * LARGE and SMALL are threshold values used to decide if scaling should\n\ * be done based on the absolute size of the largest matrix element.\n\ * If AMAX > LARGE or AMAX < SMALL, scaling is done.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sposvxx0000644000175000017500000005051112502223526016744 0ustar uwabamiuwabami--- :name: sposvxx :md5sum: 39688c3da1b5c667774c67ca0d177f17 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - equed: :type: char :intent: input/output - s: :type: real :intent: input/output :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - rpvgrw: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: real :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " SUBROUTINE SPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T\n\ * to compute the solution to a real system of linear equations\n\ * A * X = B, where A is an N-by-N symmetric positive definite matrix\n\ * and X and B are N-by-NRHS matrices.\n\ *\n\ * If requested, both normwise and maximum componentwise error bounds\n\ * are returned. SPOSVXX will return a solution with a tiny\n\ * guaranteed error (O(eps) where eps is the working machine\n\ * precision) unless the matrix is very ill-conditioned, in which\n\ * case a warning is returned. Relevant condition numbers also are\n\ * calculated and returned.\n\ *\n\ * SPOSVXX accepts user-provided factorizations and equilibration\n\ * factors; see the definitions of the FACT and EQUED options.\n\ * Solving with refinement and using a factorization from a previous\n\ * SPOSVXX call will also produce a solution with either O(eps)\n\ * errors or warnings, but we cannot make that claim for general\n\ * user-provided factorizations and equilibration factors if they\n\ * differ from what SPOSVXX would itself produce.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', real scaling factors are computed to equilibrate\n\ * the system:\n\ *\n\ * diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B\n\ *\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n\ *\n\ * 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n\ * factor the matrix A (after equilibration if FACT = 'E') as\n\ * A = U**T* U, if UPLO = 'U', or\n\ * A = L * L**T, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is a lower triangular\n\ * matrix.\n\ *\n\ * 3. If the leading i-by-i principal minor is not positive definite,\n\ * then the routine returns with INFO = i. Otherwise, the factored\n\ * form of A is used to estimate the condition number of the matrix\n\ * A (see argument RCOND). If the reciprocal of the condition number\n\ * is less than machine precision, the routine still goes on to solve\n\ * for X and compute error bounds as described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n\ * the routine will use iterative refinement to try to get a small\n\ * error and error bounds. Refinement calculates the residual to at\n\ * least twice the working precision.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(S) so that it solves the original system before\n\ * equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AF contains the factored form of A.\n\ * If EQUED is not 'N', the matrix A has been\n\ * equilibrated with scaling factors given by S.\n\ * A and AF are not modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AF and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A, except if FACT = 'F' and EQUED =\n\ * 'Y', then A must contain the equilibrated matrix\n\ * diag(S)*A*diag(S). If UPLO = 'U', the leading N-by-N upper\n\ * triangular part of A contains the upper triangular part of the\n\ * matrix A, and the strictly lower triangular part of A is not\n\ * referenced. If UPLO = 'L', the leading N-by-N lower triangular\n\ * part of A contains the lower triangular part of the matrix A, and\n\ * the strictly upper triangular part of A is not referenced. A is\n\ * not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED =\n\ * 'N' on exit.\n\ *\n\ * On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n\ * diag(S)*A*diag(S).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input or output) REAL array, dimension (LDAF,N)\n\ * If FACT = 'F', then AF is an input argument and on entry\n\ * contains the triangular factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T, in the same storage\n\ * format as A. If EQUED .ne. 'N', then AF is the factored\n\ * form of the equilibrated matrix diag(S)*A*diag(S).\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T of the original\n\ * matrix A.\n\ *\n\ * If FACT = 'E', then AF is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T of the equilibrated\n\ * matrix A (see the description of A for the form of the\n\ * equilibrated matrix).\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'Y': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(S) * A * diag(S).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * S (input or output) REAL array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'Y', A is multiplied on\n\ * the left and right by diag(S). S is an input argument if FACT =\n\ * 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n\ * = 'Y', each element of S must be positive. If S is output, each\n\ * element of S is a power of the radix. If S is input, each element\n\ * of S should be a power of the radix to ensure a reliable solution\n\ * and error estimates. Scaling by powers of the radix does not cause\n\ * rounding errors unless the result underflows or overflows.\n\ * Rounding errors during scaling lead to refining with a matrix that\n\ * is not equivalent to the input matrix, producing error estimates\n\ * that may not be reliable.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit,\n\ * if EQUED = 'N', B is not modified;\n\ * if EQUED = 'Y', B is overwritten by diag(S)*B;\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) REAL array, dimension (LDX,NRHS)\n\ * If INFO = 0, the N-by-NRHS solution matrix X to the original\n\ * system of equations. Note that A and B are modified on exit if\n\ * EQUED .ne. 'N', and the solution to the equilibrated system is\n\ * inv(diag(S))*X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * RPVGRW (output) REAL\n\ * Reciprocal pivot growth. On exit, this contains the reciprocal\n\ * pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n\ * norm is used. If this is much less than 1, then the stability of\n\ * the LU factorization of the (equilibrated) matrix A could be poor.\n\ * This also means that the solution X, estimated condition numbers,\n\ * and error bounds could be unreliable. If factorization fails with\n\ * 0 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zladiv0000644000175000017500000000200412502223526016475 0ustar uwabamiuwabami--- :name: zladiv :md5sum: 77ac55670f709d4b3ebd8a87ee08a32a :category: :function :type: doublecomplex :arguments: - x: :type: doublecomplex :intent: input - y: :type: doublecomplex :intent: input :substitutions: {} :fortran_help: " COMPLEX*16 FUNCTION ZLADIV( X, Y )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLADIV := X / Y, where X and Y are complex. The computation of X / Y\n\ * will not overflow on an intermediary step unless the results\n\ * overflows.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * X (input) COMPLEX*16\n\ * Y (input) COMPLEX*16\n\ * The complex scalars X and Y.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n DOUBLE PRECISION ZI, ZR\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DLADIV\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC DBLE, DCMPLX, DIMAG\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dtgsja0000644000175000017500000002611612502223526016472 0ustar uwabamiuwabami--- :name: dtgsja :md5sum: bdebfefc02addc07abc6c7dc534b59bb :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobv: :type: char :intent: input - jobq: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - tola: :type: doublereal :intent: input - tolb: :type: doublereal :intent: input - alpha: :type: doublereal :intent: output :dims: - n - beta: :type: doublereal :intent: output :dims: - n - u: :type: doublereal :intent: input/output :dims: - ldu - m - ldu: :type: integer :intent: input - v: :type: doublereal :intent: input/output :dims: - ldv - p - ldv: :type: integer :intent: input - q: :type: doublereal :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 2*n - ncycle: :type: integer :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, NCYCLE, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTGSJA computes the generalized singular value decomposition (GSVD)\n\ * of two real upper triangular (or trapezoidal) matrices A and B.\n\ *\n\ * On entry, it is assumed that matrices A and B have the following\n\ * forms, which may be obtained by the preprocessing subroutine DGGSVP\n\ * from a general M-by-N matrix A and P-by-N matrix B:\n\ *\n\ * N-K-L K L\n\ * A = K ( 0 A12 A13 ) if M-K-L >= 0;\n\ * L ( 0 0 A23 )\n\ * M-K-L ( 0 0 0 )\n\ *\n\ * N-K-L K L\n\ * A = K ( 0 A12 A13 ) if M-K-L < 0;\n\ * M-K ( 0 0 A23 )\n\ *\n\ * N-K-L K L\n\ * B = L ( 0 0 B13 )\n\ * P-L ( 0 0 0 )\n\ *\n\ * where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n\ * upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n\ * otherwise A23 is (M-K)-by-L upper trapezoidal.\n\ *\n\ * On exit,\n\ *\n\ * U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ),\n\ *\n\ * where U, V and Q are orthogonal matrices, Z' denotes the transpose\n\ * of Z, R is a nonsingular upper triangular matrix, and D1 and D2 are\n\ * ``diagonal'' matrices, which are of the following structures:\n\ *\n\ * If M-K-L >= 0,\n\ *\n\ * K L\n\ * D1 = K ( I 0 )\n\ * L ( 0 C )\n\ * M-K-L ( 0 0 )\n\ *\n\ * K L\n\ * D2 = L ( 0 S )\n\ * P-L ( 0 0 )\n\ *\n\ * N-K-L K L\n\ * ( 0 R ) = K ( 0 R11 R12 ) K\n\ * L ( 0 0 R22 ) L\n\ *\n\ * where\n\ *\n\ * C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n\ * S = diag( BETA(K+1), ... , BETA(K+L) ),\n\ * C**2 + S**2 = I.\n\ *\n\ * R is stored in A(1:K+L,N-K-L+1:N) on exit.\n\ *\n\ * If M-K-L < 0,\n\ *\n\ * K M-K K+L-M\n\ * D1 = K ( I 0 0 )\n\ * M-K ( 0 C 0 )\n\ *\n\ * K M-K K+L-M\n\ * D2 = M-K ( 0 S 0 )\n\ * K+L-M ( 0 0 I )\n\ * P-L ( 0 0 0 )\n\ *\n\ * N-K-L K M-K K+L-M\n\ * ( 0 R ) = K ( 0 R11 R12 R13 )\n\ * M-K ( 0 0 R22 R23 )\n\ * K+L-M ( 0 0 0 R33 )\n\ *\n\ * where\n\ * C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n\ * S = diag( BETA(K+1), ... , BETA(M) ),\n\ * C**2 + S**2 = I.\n\ *\n\ * R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored\n\ * ( 0 R22 R23 )\n\ * in B(M-K+1:L,N+M-K-L+1:N) on exit.\n\ *\n\ * The computation of the orthogonal transformation matrices U, V or Q\n\ * is optional. These matrices may either be formed explicitly, or they\n\ * may be postmultiplied into input matrices U1, V1, or Q1.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBU (input) CHARACTER*1\n\ * = 'U': U must contain an orthogonal matrix U1 on entry, and\n\ * the product U1*U is returned;\n\ * = 'I': U is initialized to the unit matrix, and the\n\ * orthogonal matrix U is returned;\n\ * = 'N': U is not computed.\n\ *\n\ * JOBV (input) CHARACTER*1\n\ * = 'V': V must contain an orthogonal matrix V1 on entry, and\n\ * the product V1*V is returned;\n\ * = 'I': V is initialized to the unit matrix, and the\n\ * orthogonal matrix V is returned;\n\ * = 'N': V is not computed.\n\ *\n\ * JOBQ (input) CHARACTER*1\n\ * = 'Q': Q must contain an orthogonal matrix Q1 on entry, and\n\ * the product Q1*Q is returned;\n\ * = 'I': Q is initialized to the unit matrix, and the\n\ * orthogonal matrix Q is returned;\n\ * = 'N': Q is not computed.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A. M >= 0.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows of the matrix B. P >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrices A and B. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * L (input) INTEGER\n\ * K and L specify the subblocks in the input matrices A and B:\n\ * A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,N-L+1:N)\n\ * of A and B, whose GSVD is going to be computed by DTGSJA.\n\ * See Further Details.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular\n\ * matrix R or part of R. See Purpose for details.\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,N)\n\ * On entry, the P-by-N matrix B.\n\ * On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains\n\ * a part of R. See Purpose for details.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,P).\n\ *\n\ * TOLA (input) DOUBLE PRECISION\n\ * TOLB (input) DOUBLE PRECISION\n\ * TOLA and TOLB are the convergence criteria for the Jacobi-\n\ * Kogbetliantz iteration procedure. Generally, they are the\n\ * same as used in the preprocessing step, say\n\ * TOLA = max(M,N)*norm(A)*MAZHEPS,\n\ * TOLB = max(P,N)*norm(B)*MAZHEPS.\n\ *\n\ * ALPHA (output) DOUBLE PRECISION array, dimension (N)\n\ * BETA (output) DOUBLE PRECISION array, dimension (N)\n\ * On exit, ALPHA and BETA contain the generalized singular\n\ * value pairs of A and B;\n\ * ALPHA(1:K) = 1,\n\ * BETA(1:K) = 0,\n\ * and if M-K-L >= 0,\n\ * ALPHA(K+1:K+L) = diag(C),\n\ * BETA(K+1:K+L) = diag(S),\n\ * or if M-K-L < 0,\n\ * ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0\n\ * BETA(K+1:M) = S, BETA(M+1:K+L) = 1.\n\ * Furthermore, if K+L < N,\n\ * ALPHA(K+L+1:N) = 0 and\n\ * BETA(K+L+1:N) = 0.\n\ *\n\ * U (input/output) DOUBLE PRECISION array, dimension (LDU,M)\n\ * On entry, if JOBU = 'U', U must contain a matrix U1 (usually\n\ * the orthogonal matrix returned by DGGSVP).\n\ * On exit,\n\ * if JOBU = 'I', U contains the orthogonal matrix U;\n\ * if JOBU = 'U', U contains the product U1*U.\n\ * If JOBU = 'N', U is not referenced.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= max(1,M) if\n\ * JOBU = 'U'; LDU >= 1 otherwise.\n\ *\n\ * V (input/output) DOUBLE PRECISION array, dimension (LDV,P)\n\ * On entry, if JOBV = 'V', V must contain a matrix V1 (usually\n\ * the orthogonal matrix returned by DGGSVP).\n\ * On exit,\n\ * if JOBV = 'I', V contains the orthogonal matrix V;\n\ * if JOBV = 'V', V contains the product V1*V.\n\ * If JOBV = 'N', V is not referenced.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V. LDV >= max(1,P) if\n\ * JOBV = 'V'; LDV >= 1 otherwise.\n\ *\n\ * Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n\ * On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually\n\ * the orthogonal matrix returned by DGGSVP).\n\ * On exit,\n\ * if JOBQ = 'I', Q contains the orthogonal matrix Q;\n\ * if JOBQ = 'Q', Q contains the product Q1*Q.\n\ * If JOBQ = 'N', Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N) if\n\ * JOBQ = 'Q'; LDQ >= 1 otherwise.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n\ *\n\ * NCYCLE (output) INTEGER\n\ * The number of cycles required for convergence.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * = 1: the procedure does not converge after MAXIT cycles.\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * MAXIT INTEGER\n\ * MAXIT specifies the total loops that the iterative procedure\n\ * may take. If after MAXIT cycles, the routine fails to\n\ * converge, we return INFO = 1.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * DTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce\n\ * min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L\n\ * matrix B13 to the form:\n\ *\n\ * U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1,\n\ *\n\ * where U1, V1 and Q1 are orthogonal matrix, and Z' is the transpose\n\ * of Z. C1 and S1 are diagonal matrices satisfying\n\ *\n\ * C1**2 + S1**2 = I,\n\ *\n\ * and R1 is an L-by-L nonsingular upper triangular matrix.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slatrd0000644000175000017500000001376712502223526016517 0ustar uwabamiuwabami--- :name: slatrd :md5sum: c95f0cc9aadb9f343ff8ec7c58fd0f69 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - e: :type: real :intent: output :dims: - n-1 - tau: :type: real :intent: output :dims: - n-1 - w: :type: real :intent: output :dims: - ldw - MAX(n,nb) - ldw: :type: integer :intent: input :substitutions: ldw: MAX(1,n) :fortran_help: " SUBROUTINE SLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLATRD reduces NB rows and columns of a real symmetric matrix A to\n\ * symmetric tridiagonal form by an orthogonal similarity\n\ * transformation Q' * A * Q, and returns the matrices V and W which are\n\ * needed to apply the transformation to the unreduced part of A.\n\ *\n\ * If UPLO = 'U', SLATRD reduces the last NB rows and columns of a\n\ * matrix, of which the upper triangle is supplied;\n\ * if UPLO = 'L', SLATRD reduces the first NB rows and columns of a\n\ * matrix, of which the lower triangle is supplied.\n\ *\n\ * This is an auxiliary routine called by SSYTRD.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A.\n\ *\n\ * NB (input) INTEGER\n\ * The number of rows and columns to be reduced.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * n-by-n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n-by-n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ * On exit:\n\ * if UPLO = 'U', the last NB columns have been reduced to\n\ * tridiagonal form, with the diagonal elements overwriting\n\ * the diagonal elements of A; the elements above the diagonal\n\ * with the array TAU, represent the orthogonal matrix Q as a\n\ * product of elementary reflectors;\n\ * if UPLO = 'L', the first NB columns have been reduced to\n\ * tridiagonal form, with the diagonal elements overwriting\n\ * the diagonal elements of A; the elements below the diagonal\n\ * with the array TAU, represent the orthogonal matrix Q as a\n\ * product of elementary reflectors.\n\ * See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= (1,N).\n\ *\n\ * E (output) REAL array, dimension (N-1)\n\ * If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal\n\ * elements of the last NB columns of the reduced matrix;\n\ * if UPLO = 'L', E(1:nb) contains the subdiagonal elements of\n\ * the first NB columns of the reduced matrix.\n\ *\n\ * TAU (output) REAL array, dimension (N-1)\n\ * The scalar factors of the elementary reflectors, stored in\n\ * TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.\n\ * See Further Details.\n\ *\n\ * W (output) REAL array, dimension (LDW,NB)\n\ * The n-by-nb matrix W required to update the unreduced part\n\ * of A.\n\ *\n\ * LDW (input) INTEGER\n\ * The leading dimension of the array W. LDW >= max(1,N).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * If UPLO = 'U', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(n) H(n-1) . . . H(n-nb+1).\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(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),\n\ * and tau in TAU(i-1).\n\ *\n\ * If UPLO = 'L', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(nb).\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) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),\n\ * and tau in TAU(i).\n\ *\n\ * The elements of the vectors v together form the n-by-nb matrix V\n\ * which is needed, with W, to apply the transformation to the unreduced\n\ * part of the matrix, using a symmetric rank-2k update of the form:\n\ * A := A - V*W' - W*V'.\n\ *\n\ * The contents of A on exit are illustrated by the following examples\n\ * with n = 5 and nb = 2:\n\ *\n\ * if UPLO = 'U': if UPLO = 'L':\n\ *\n\ * ( a a a v4 v5 ) ( d )\n\ * ( a a v4 v5 ) ( 1 d )\n\ * ( a 1 v5 ) ( v1 1 a )\n\ * ( d 1 ) ( v1 v2 a a )\n\ * ( d ) ( v1 v2 a a a )\n\ *\n\ * where d denotes a diagonal element of the reduced matrix, a denotes\n\ * an element of the original matrix that is unchanged, and vi denotes\n\ * an element of the vector defining H(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgbsvx0000644000175000017500000003471112502223526016541 0ustar uwabamiuwabami--- :name: zgbsvx :md5sum: 37f8005219a7ff25ba6532ce78cd340c :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublecomplex :intent: input/output :dims: - ldafb - n :option: true - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n :option: true - equed: :type: char :intent: input/output :option: true - r: :type: doublereal :intent: input/output :dims: - n :option: true - c: :type: doublereal :intent: input/output :dims: - n :option: true - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldx: n ldafb: 2*kl+ku+1 :fortran_help: " SUBROUTINE ZGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGBSVX uses the LU factorization to compute the solution to a complex\n\ * system of linear equations A * X = B, A**T * X = B, or A**H * X = B,\n\ * where A is a band matrix of order N with KL subdiagonals and KU\n\ * superdiagonals, and X and B are N-by-NRHS matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed by this subroutine:\n\ *\n\ * 1. If FACT = 'E', real scaling factors are computed to equilibrate\n\ * the system:\n\ * TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n\ * TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n\ * TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n\ * or diag(C)*B (if TRANS = 'T' or 'C').\n\ *\n\ * 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n\ * matrix A (after equilibration if FACT = 'E') as\n\ * A = L * U,\n\ * where L is a product of permutation and unit lower triangular\n\ * matrices with KL subdiagonals, and U is upper triangular with\n\ * KL+KU superdiagonals.\n\ *\n\ * 3. If some U(i,i)=0, so that U is exactly singular, then the routine\n\ * returns with INFO = i. Otherwise, the factored form of A is used\n\ * to estimate the condition number of the matrix A. If the\n\ * reciprocal of the condition number is less than machine precision,\n\ * INFO = N+1 is returned as a warning, but the routine still goes on\n\ * to solve for X and compute error bounds as described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n\ * that it solves the original system before equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AFB and IPIV contain the factored form of\n\ * A. If EQUED is not 'N', the matrix A has been\n\ * equilibrated with scaling factors given by R and C.\n\ * AB, AFB, and IPIV are not modified.\n\ * = 'N': The matrix A will be copied to AFB and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AFB and factored.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations.\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose)\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n\ *\n\ * If FACT = 'F' and EQUED is not 'N', then A must have been\n\ * equilibrated by the scaling factors in R and/or C. AB is not\n\ * modified if FACT = 'F' or 'N', or if FACT = 'E' and\n\ * EQUED = 'N' on exit.\n\ *\n\ * On exit, if EQUED .ne. 'N', A is scaled as follows:\n\ * EQUED = 'R': A := diag(R) * A\n\ * EQUED = 'C': A := A * diag(C)\n\ * EQUED = 'B': A := diag(R) * A * diag(C).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * AFB (input or output) COMPLEX*16 array, dimension (LDAFB,N)\n\ * If FACT = 'F', then AFB is an input argument and on entry\n\ * contains details of the LU factorization of the band matrix\n\ * A, as computed by ZGBTRF. U is stored as an upper triangular\n\ * band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n\ * and the multipliers used during the factorization are stored\n\ * in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is\n\ * the factored form of the equilibrated matrix A.\n\ *\n\ * If FACT = 'N', then AFB is an output argument and on exit\n\ * returns details of the LU factorization of A.\n\ *\n\ * If FACT = 'E', then AFB is an output argument and on exit\n\ * returns details of the LU factorization of the equilibrated\n\ * matrix A (see the description of AB for the form of the\n\ * equilibrated matrix).\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains the pivot indices from the factorization A = L*U\n\ * as computed by ZGBTRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = L*U\n\ * of the original matrix A.\n\ *\n\ * If FACT = 'E', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = L*U\n\ * of the equilibrated matrix A.\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * R (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'R' or 'B', A is\n\ * multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n\ * is not accessed. R is an input argument if FACT = 'F';\n\ * otherwise, R is an output argument. If FACT = 'F' and\n\ * EQUED = 'R' or 'B', each element of R must be positive.\n\ *\n\ * C (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The column scale factors for A. If EQUED = 'C' or 'B', A is\n\ * multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n\ * is not accessed. C is an input argument if FACT = 'F';\n\ * otherwise, C is an output argument. If FACT = 'F' and\n\ * EQUED = 'C' or 'B', each element of C must be positive.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit,\n\ * if EQUED = 'N', B is not modified;\n\ * if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n\ * diag(R)*B;\n\ * if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n\ * overwritten by diag(C)*B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n\ * to the original system of equations. Note that A and B are\n\ * modified on exit if EQUED .ne. 'N', and the solution to the\n\ * equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n\ * EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n\ * and EQUED = 'R' or 'B'.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A after equilibration (if done). If RCOND is less than the\n\ * machine precision (in particular, if RCOND = 0), the matrix\n\ * is singular to working precision. This condition is\n\ * indicated by a return code of INFO > 0.\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace/output) DOUBLE PRECISION array, dimension (N)\n\ * On exit, RWORK(1) contains the reciprocal pivot growth\n\ * factor norm(A)/norm(U). The \"max absolute element\" norm is\n\ * used. If RWORK(1) is much less than 1, then the stability\n\ * of the LU factorization of the (equilibrated) matrix A\n\ * could be poor. This also means that the solution X, condition\n\ * estimator RCOND, and forward error bound FERR could be\n\ * unreliable. If factorization fails with 0 0: if INFO = i, and i is\n\ * <= N: U(i,i) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, so the solution and error bounds\n\ * could not be computed. RCOND = 0 is returned.\n\ * = N+1: U is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * =====================================================================\n\ * Moved setting of INFO = N+1 so INFO does not subsequently get\n\ * overwritten. Sven, 17 Mar 05. \n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/claqr40000644000175000017500000001736312502223525016407 0ustar uwabamiuwabami--- :name: claqr4 :md5sum: 234329047676594dccc0a2de8eb860f7 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: complex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - w: :type: complex :intent: output :dims: - n - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: complex :intent: input/output :dims: - ldz - ihi - ldz: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAQR4 computes the eigenvalues of a Hessenberg matrix H\n\ * and, optionally, the matrices T and Z from the Schur decomposition\n\ * H = Z T Z**H, where T is an upper triangular matrix (the\n\ * Schur form), and Z is the unitary matrix of Schur vectors.\n\ *\n\ * Optionally Z may be postmultiplied into an input unitary\n\ * matrix Q so that this routine can give the Schur factorization\n\ * of a matrix A which has been reduced to the Hessenberg form H\n\ * by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * WANTT (input) LOGICAL\n\ * = .TRUE. : the full Schur form T is required;\n\ * = .FALSE.: only eigenvalues are required.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * = .TRUE. : the matrix of Schur vectors Z is required;\n\ * = .FALSE.: Schur vectors are not required.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H. N .GE. 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * It is assumed that H is already upper triangular in rows\n\ * and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n\ * H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n\ * previous call to CGEBAL, and then passed to CGEHRD when the\n\ * matrix output by CGEBAL is reduced to Hessenberg form.\n\ * Otherwise, ILO and IHI should be set to 1 and N,\n\ * respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n\ * If N = 0, then ILO = 1 and IHI = 0.\n\ *\n\ * H (input/output) COMPLEX array, dimension (LDH,N)\n\ * On entry, the upper Hessenberg matrix H.\n\ * On exit, if INFO = 0 and WANTT is .TRUE., then H\n\ * contains the upper triangular matrix T from the Schur\n\ * decomposition (the Schur form). If INFO = 0 and WANT is\n\ * .FALSE., then the contents of H are unspecified on exit.\n\ * (The output value of H when INFO.GT.0 is given under the\n\ * description of INFO below.)\n\ *\n\ * This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n\ * j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n\ *\n\ * LDH (input) INTEGER\n\ * The leading dimension of the array H. LDH .GE. max(1,N).\n\ *\n\ * W (output) COMPLEX array, dimension (N)\n\ * The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored\n\ * in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are\n\ * stored in the same order as on the diagonal of the Schur\n\ * form returned in H, with W(i) = H(i,i).\n\ *\n\ * Z (input/output) COMPLEX array, dimension (LDZ,IHI)\n\ * If WANTZ is .FALSE., then Z is not referenced.\n\ * If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n\ * replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n\ * orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n\ * (The output value of Z when INFO.GT.0 is given under\n\ * the description of INFO below.)\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. if WANTZ is .TRUE.\n\ * then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.\n\ *\n\ * WORK (workspace/output) COMPLEX array, dimension LWORK\n\ * On exit, if LWORK = -1, WORK(1) returns an estimate of\n\ * the optimal value for LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK .GE. max(1,N)\n\ * is sufficient, but LWORK typically as large as 6*N may\n\ * be required for optimal performance. A workspace query\n\ * to determine the optimal workspace size is recommended.\n\ *\n\ * If LWORK = -1, then CLAQR4 does a workspace query.\n\ * In this case, CLAQR4 checks the input parameters and\n\ * estimates the optimal workspace size for the given\n\ * values of N, ILO and IHI. The estimate is returned\n\ * in WORK(1). No error message related to LWORK is\n\ * issued by XERBLA. Neither H nor Z are accessed.\n\ *\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * .GT. 0: if INFO = i, CLAQR4 failed to compute all of\n\ * the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n\ * and WI contain those eigenvalues which have been\n\ * successfully computed. (Failures are rare.)\n\ *\n\ * If INFO .GT. 0 and WANT is .FALSE., then on exit,\n\ * the remaining unconverged eigenvalues are the eigen-\n\ * values of the upper Hessenberg matrix rows and\n\ * columns ILO through INFO of the final, output\n\ * value of H.\n\ *\n\ * If INFO .GT. 0 and WANTT is .TRUE., then on exit\n\ *\n\ * (*) (initial value of H)*U = U*(final value of H)\n\ *\n\ * where U is a unitary matrix. The final\n\ * value of H is upper Hessenberg and triangular in\n\ * rows and columns INFO+1 through IHI.\n\ *\n\ * If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n\ *\n\ * (final value of Z(ILO:IHI,ILOZ:IHIZ)\n\ * = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n\ *\n\ * where U is the unitary matrix in (*) (regard-\n\ * less of the value of WANTT.)\n\ *\n\ * If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n\ * accessed.\n\ *\n\n\ * ================================================================\n\ * Based on contributions by\n\ * Karen Braman and Ralph Byers, Department of Mathematics,\n\ * University of Kansas, USA\n\ *\n\ * ================================================================\n\ * References:\n\ * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n\ * Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n\ * Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n\ * 929--947, 2002.\n\ *\n\ * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n\ * Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n\ * of Matrix Analysis, volume 23, pages 948--973, 2002.\n\ *\n\ * ================================================================\n" ruby-lapack-1.7.2/dev/defs/dsteqr0000644000175000017500000000725312502223526016521 0ustar uwabamiuwabami--- :name: dsteqr :md5sum: 88d76a7dbffcf1191cc46800ecf8affa :category: :subroutine :arguments: - compz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - z: :type: doublereal :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - "lsame_(&compz,\"N\") ? 0 : MAX(1,2*n-2)" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSTEQR computes all eigenvalues and, optionally, eigenvectors of a\n\ * symmetric tridiagonal matrix using the implicit QL or QR method.\n\ * The eigenvectors of a full or band symmetric matrix can also be found\n\ * if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to\n\ * tridiagonal form.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * COMPZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only.\n\ * = 'V': Compute eigenvalues and eigenvectors of the original\n\ * symmetric matrix. On entry, Z must contain the\n\ * orthogonal matrix used to reduce the original matrix\n\ * to tridiagonal form.\n\ * = 'I': Compute eigenvalues and eigenvectors of the\n\ * tridiagonal matrix. Z is initialized to the identity\n\ * matrix.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the diagonal elements of the tridiagonal matrix.\n\ * On exit, if INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * E (input/output) DOUBLE PRECISION array, dimension (N-1)\n\ * On entry, the (n-1) subdiagonal elements of the tridiagonal\n\ * matrix.\n\ * On exit, E has been destroyed.\n\ *\n\ * Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)\n\ * On entry, if COMPZ = 'V', then Z contains the orthogonal\n\ * matrix used in the reduction to tridiagonal form.\n\ * On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n\ * orthonormal eigenvectors of the original symmetric matrix,\n\ * and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n\ * of the symmetric tridiagonal matrix.\n\ * If COMPZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * eigenvectors are desired, then LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))\n\ * If COMPZ = 'N', then WORK is not referenced.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: the algorithm has failed to find all the eigenvalues in\n\ * a total of 30*N iterations; if INFO = i, then i\n\ * elements of E have not converged to zero; on exit, D\n\ * and E contain the elements of a symmetric tridiagonal\n\ * matrix which is orthogonally similar to the original\n\ * matrix.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slarrb0000644000175000017500000001233512502223526016501 0ustar uwabamiuwabami--- :name: slarrb :md5sum: ac43c9637a4b29c89256e616a3b9c674 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - lld: :type: real :intent: input :dims: - n-1 - ifirst: :type: integer :intent: input - ilast: :type: integer :intent: input - rtol1: :type: real :intent: input - rtol2: :type: real :intent: input - offset: :type: integer :intent: input - w: :type: real :intent: input/output :dims: - n - wgap: :type: real :intent: input/output :dims: - n-1 - werr: :type: real :intent: input/output :dims: - n - work: :type: real :intent: workspace :dims: - 2*n - iwork: :type: integer :intent: workspace :dims: - 2*n - pivmin: :type: real :intent: input - spdiam: :type: real :intent: input - twist: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLARRB( N, D, LLD, IFIRST, ILAST, RTOL1, RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK, PIVMIN, SPDIAM, TWIST, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Given the relatively robust representation(RRR) L D L^T, SLARRB\n\ * does \"limited\" bisection to refine the eigenvalues of L D L^T,\n\ * W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial\n\ * guesses for these eigenvalues are input in W, the corresponding estimate\n\ * of the error in these guesses and their gaps are input in WERR\n\ * and WGAP, respectively. During bisection, intervals\n\ * [left, right] are maintained by storing their mid-points and\n\ * semi-widths in the arrays W and WERR respectively.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The N diagonal elements of the diagonal matrix D.\n\ *\n\ * LLD (input) REAL array, dimension (N-1)\n\ * The (N-1) elements L(i)*L(i)*D(i).\n\ *\n\ * IFIRST (input) INTEGER\n\ * The index of the first eigenvalue to be computed.\n\ *\n\ * ILAST (input) INTEGER\n\ * The index of the last eigenvalue to be computed.\n\ *\n\ * RTOL1 (input) REAL \n\ * RTOL2 (input) REAL \n\ * Tolerance for the convergence of the bisection intervals.\n\ * An interval [LEFT,RIGHT] has converged if\n\ * RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n\ * where GAP is the (estimated) distance to the nearest\n\ * eigenvalue.\n\ *\n\ * OFFSET (input) INTEGER\n\ * Offset for the arrays W, WGAP and WERR, i.e., the IFIRST-OFFSET\n\ * through ILAST-OFFSET elements of these arrays are to be used.\n\ *\n\ * W (input/output) REAL array, dimension (N)\n\ * On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are\n\ * estimates of the eigenvalues of L D L^T indexed IFIRST throug\n\ * ILAST.\n\ * On output, these estimates are refined.\n\ *\n\ * WGAP (input/output) REAL array, dimension (N-1)\n\ * On input, the (estimated) gaps between consecutive\n\ * eigenvalues of L D L^T, i.e., WGAP(I-OFFSET) is the gap between\n\ * eigenvalues I and I+1. Note that if IFIRST.EQ.ILAST\n\ * then WGAP(IFIRST-OFFSET) must be set to ZERO.\n\ * On output, these gaps are refined.\n\ *\n\ * WERR (input/output) REAL array, dimension (N)\n\ * On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are\n\ * the errors in the estimates of the corresponding elements in W.\n\ * On output, these errors are refined.\n\ *\n\ * WORK (workspace) REAL array, dimension (2*N)\n\ * Workspace.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (2*N)\n\ * Workspace.\n\ *\n\ * PIVMIN (input) REAL\n\ * The minimum pivot in the Sturm sequence.\n\ *\n\ * SPDIAM (input) REAL\n\ * The spectral diameter of the matrix.\n\ *\n\ * TWIST (input) INTEGER\n\ * The twist index for the twisted factorization that is used\n\ * for the negcount.\n\ * TWIST = N: Compute negcount from L D L^T - LAMBDA I = L+ D+ L+^T\n\ * TWIST = 1: Compute negcount from L D L^T - LAMBDA I = U- D- U-^T\n\ * TWIST = R: Compute negcount from L D L^T - LAMBDA I = N(r) D(r) N(r)\n\ *\n\ * INFO (output) INTEGER\n\ * Error flag.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Beresford Parlett, University of California, Berkeley, USA\n\ * Jim Demmel, University of California, Berkeley, USA\n\ * Inderjit Dhillon, University of Texas, Austin, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, University of California, Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dporfsx0000644000175000017500000003707712502223526016713 0ustar uwabamiuwabami--- :name: dporfsx :md5sum: 4552fe053ceaeaedf9f28e3f06ea1182 :category: :subroutine :arguments: - uplo: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublereal :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " SUBROUTINE DPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPORFSX improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is symmetric positive\n\ * definite, and provides error bounds and backward error estimates\n\ * for the solution. In addition to normwise error bound, the code\n\ * provides maximum componentwise error bound if possible. See\n\ * comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n\ * error bounds.\n\ *\n\ * The original system of linear equations may have been equilibrated\n\ * before calling this routine, as described by arguments EQUED and S\n\ * below. In this case, the solution and error bounds returned are\n\ * for the original unequilibrated system.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * EQUED (input) CHARACTER*1\n\ * Specifies the form of equilibration that was done to A\n\ * before calling this routine. This is needed to compute\n\ * the solution and error bounds correctly.\n\ * = 'N': No equilibration\n\ * = 'Y': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(S) * A * diag(S).\n\ * The right hand side B has been changed accordingly.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular part\n\ * of the matrix A, and the strictly lower triangular part of A\n\ * is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of A contains the lower triangular part of\n\ * the matrix A, and the strictly upper triangular part of A is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T, as computed by DPOTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * S (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'Y', A is multiplied on\n\ * the left and right by diag(S). S is an input argument if FACT =\n\ * 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n\ * = 'Y', each element of S must be positive. If S is output, each\n\ * element of S is a power of the radix. If S is input, each element\n\ * of S should be a power of the radix to ensure a reliable solution\n\ * and error estimates. Scaling by powers of the radix does not cause\n\ * rounding errors unless the result underflows or overflows.\n\ * Rounding errors during scaling lead to refining with a matrix that\n\ * is not equivalent to the input matrix, producing error estimates\n\ * that may not be reliable.\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by DGETRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * Componentwise relative backward error. This is the\n\ * componentwise relative backward error of each solution vector X(j)\n\ * (i.e., the smallest relative change in any element of A or B that\n\ * makes X(j) an exact solution).\n\ *\n\ * N_ERR_BNDS (input) INTEGER\n\ * Number of error bounds to return for each right hand side\n\ * and each type (normwise or componentwise). See ERR_BNDS_NORM and\n\ * ERR_BNDS_COMP below.\n\ *\n\ * ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * dlamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * dlamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * dlamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * dlamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * dlamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * dlamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * NPARAMS (input) INTEGER\n\ * Specifies the number of parameters set in PARAMS. If .LE. 0, the\n\ * PARAMS array is never referenced and default values are used.\n\ *\n\ * PARAMS (input / output) DOUBLE PRECISION array, dimension (NPARAMS)\n\ * Specifies algorithm parameters. If an entry is .LT. 0.0, then\n\ * that entry will be filled with default value used for that\n\ * parameter. Only positions up to NPARAMS are accessed; defaults\n\ * are used for higher-numbered parameters.\n\ *\n\ * PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n\ * refinement or not.\n\ * Default: 1.0D+0\n\ * = 0.0 : No refinement is performed, and no error bounds are\n\ * computed.\n\ * = 1.0 : Use the double-precision refinement algorithm,\n\ * possibly with doubled-single computations if the\n\ * compilation environment does not support DOUBLE\n\ * PRECISION.\n\ * (other values are reserved for future use)\n\ *\n\ * PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n\ * computations allowed for refinement.\n\ * Default: 10\n\ * Aggressive: Set to 100 to permit convergence using approximate\n\ * factorizations or factorizations other than LU. If\n\ * the factorization uses a technique other than\n\ * Gaussian elimination, the guarantees in\n\ * err_bnds_norm and err_bnds_comp may no longer be\n\ * trustworthy.\n\ *\n\ * PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n\ * will attempt to find a solution with small componentwise\n\ * relative error in the double-precision algorithm. Positive\n\ * is true, 0.0 is false.\n\ * Default: 1.0 (attempt componentwise convergence)\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit. The solution to every right-hand side is\n\ * guaranteed.\n\ * < 0: If INFO = -i, the i-th argument had an illegal value\n\ * > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dpprfs0000644000175000017500000001102512502223526016505 0ustar uwabamiuwabami--- :name: dpprfs :md5sum: 7b677d919e716eb66e39a459092c0669 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - n*(n+1)/2 - afp: :type: doublereal :intent: input :dims: - n*(n+1)/2 - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ldb :fortran_help: " SUBROUTINE DPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPPRFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is symmetric positive definite\n\ * and packed, and provides error bounds and backward error estimates\n\ * for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * The upper or lower triangle of the symmetric matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * AFP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T, as computed by DPPTRF/ZPPTRF,\n\ * packed columnwise in a linear array in the same format as A\n\ * (see AP).\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by DPPTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgbtf20000644000175000017500000000743712502223526016373 0ustar uwabamiuwabami--- :name: dgbtf2 :md5sum: 57c00fcbe37b532c6461b03a84b5c002 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGBTF2 computes an LU factorization of a real m-by-n band matrix A\n\ * using partial pivoting with row interchanges.\n\ *\n\ * This is the unblocked version of the algorithm, calling Level 2 BLAS.\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\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows KL+1 to\n\ * 2*KL+KU+1; rows 1 to KL of the array need not be set.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n\ *\n\ * On exit, details of the factorization: U is stored as an\n\ * upper triangular band matrix with KL+KU superdiagonals in\n\ * rows 1 to KL+KU+1, and the multipliers used during the\n\ * factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n\ * See below for further details.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n\ *\n\ * IPIV (output) INTEGER array, dimension (min(M,N))\n\ * The pivot indices; for 1 <= i <= min(M,N), row i of the\n\ * matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, and division by zero will occur if it is used\n\ * to solve a system of equations.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * M = N = 6, KL = 2, KU = 1:\n\ *\n\ * On entry: On exit:\n\ *\n\ * * * * + + + * * * u14 u25 u36\n\ * * * + + + + * * u13 u24 u35 u46\n\ * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n\ * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n\ * a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n\ * a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n\ *\n\ * Array elements marked * are not used by the routine; elements marked\n\ * + need not be set on entry, but are required by the routine to store\n\ * elements of U, because of fill-in resulting from the row\n\ * interchanges.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssteqr0000644000175000017500000000714312502223526016536 0ustar uwabamiuwabami--- :name: ssteqr :md5sum: 75323c7177adfd9bb0df92567a13acaf :category: :subroutine :arguments: - compz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - z: :type: real :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "lsame_(&compz,\"N\") ? 0 : MAX(1,2*n-2)" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSTEQR computes all eigenvalues and, optionally, eigenvectors of a\n\ * symmetric tridiagonal matrix using the implicit QL or QR method.\n\ * The eigenvectors of a full or band symmetric matrix can also be found\n\ * if SSYTRD or SSPTRD or SSBTRD has been used to reduce this matrix to\n\ * tridiagonal form.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * COMPZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only.\n\ * = 'V': Compute eigenvalues and eigenvectors of the original\n\ * symmetric matrix. On entry, Z must contain the\n\ * orthogonal matrix used to reduce the original matrix\n\ * to tridiagonal form.\n\ * = 'I': Compute eigenvalues and eigenvectors of the\n\ * tridiagonal matrix. Z is initialized to the identity\n\ * matrix.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the diagonal elements of the tridiagonal matrix.\n\ * On exit, if INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * E (input/output) REAL array, dimension (N-1)\n\ * On entry, the (n-1) subdiagonal elements of the tridiagonal\n\ * matrix.\n\ * On exit, E has been destroyed.\n\ *\n\ * Z (input/output) REAL array, dimension (LDZ, N)\n\ * On entry, if COMPZ = 'V', then Z contains the orthogonal\n\ * matrix used in the reduction to tridiagonal form.\n\ * On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n\ * orthonormal eigenvectors of the original symmetric matrix,\n\ * and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n\ * of the symmetric tridiagonal matrix.\n\ * If COMPZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * eigenvectors are desired, then LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) REAL array, dimension (max(1,2*N-2))\n\ * If COMPZ = 'N', then WORK is not referenced.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: the algorithm has failed to find all the eigenvalues in\n\ * a total of 30*N iterations; if INFO = i, then i\n\ * elements of E have not converged to zero; on exit, D\n\ * and E contain the elements of a symmetric tridiagonal\n\ * matrix which is orthogonally similar to the original\n\ * matrix.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ddisna0000644000175000017500000000573212502223526016461 0ustar uwabamiuwabami--- :name: ddisna :md5sum: ea986ef961f5fb1f30ce6fd9d42e776f :category: :subroutine :arguments: - job: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - m - sep: :type: doublereal :intent: output :dims: - "lsame_(&job,\"E\") ? m : ((lsame_(&job,\"L\")) || (lsame_(&job,\"R\"))) ? MIN(m,n) : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DDISNA( JOB, M, N, D, SEP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DDISNA computes the reciprocal condition numbers for the eigenvectors\n\ * of a real symmetric or complex Hermitian matrix or for the left or\n\ * right singular vectors of a general m-by-n matrix. The reciprocal\n\ * condition number is the 'gap' between the corresponding eigenvalue or\n\ * singular value and the nearest other one.\n\ *\n\ * The bound on the error, measured by angle in radians, in the I-th\n\ * computed vector is given by\n\ *\n\ * DLAMCH( 'E' ) * ( ANORM / SEP( I ) )\n\ *\n\ * where ANORM = 2-norm(A) = max( abs( D(j) ) ). SEP(I) is not allowed\n\ * to be smaller than DLAMCH( 'E' )*ANORM in order to limit the size of\n\ * the error bound.\n\ *\n\ * DDISNA may also be used to compute error bounds for eigenvectors of\n\ * the generalized symmetric definite eigenproblem.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * Specifies for which problem the reciprocal condition numbers\n\ * should be computed:\n\ * = 'E': the eigenvectors of a symmetric/Hermitian matrix;\n\ * = 'L': the left singular vectors of a general matrix;\n\ * = 'R': the right singular vectors of a general matrix.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * If JOB = 'L' or 'R', the number of columns of the matrix,\n\ * in which case N >= 0. Ignored if JOB = 'E'.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (M) if JOB = 'E'\n\ * dimension (min(M,N)) if JOB = 'L' or 'R'\n\ * The eigenvalues (if JOB = 'E') or singular values (if JOB =\n\ * 'L' or 'R') of the matrix, in either increasing or decreasing\n\ * order. If singular values, they must be non-negative.\n\ *\n\ * SEP (output) DOUBLE PRECISION array, dimension (M) if JOB = 'E'\n\ * dimension (min(M,N)) if JOB = 'L' or 'R'\n\ * The reciprocal condition numbers of the vectors.\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dla_gbrfsx_extended0000644000175000017500000003640012502223526021206 0ustar uwabamiuwabami--- :name: dla_gbrfsx_extended :md5sum: 77409c41c105cbcc5653d6d05aeb4421 :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - trans_type: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublereal :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - colequ: :type: logical :intent: input - c: :type: doublereal :intent: input :dims: - n - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: doublereal :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: doublereal :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: input/output :dims: - nrhs - n_norms - err_bnds_comp: :type: doublereal :intent: input/output :dims: - nrhs - n_norms - res: :type: doublereal :intent: input :dims: - n - ayb: :type: doublereal :intent: input :dims: - n - dy: :type: doublereal :intent: input :dims: - n - y_tail: :type: doublereal :intent: input :dims: - n - rcond: :type: doublereal :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: doublereal :intent: input - dz_ub: :type: doublereal :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: n: ldab ldafb: n n_norms: "3" :fortran_help: " SUBROUTINE DLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n\ * Purpose\n\ * =======\n\ * \n\ * DLA_GBRFSX_EXTENDED improves the computed solution to a system of\n\ * linear equations by performing extra-precise iterative refinement\n\ * and provides error bounds and backward error estimates for the solution.\n\ * This subroutine is called by DGBRFSX to perform iterative refinement.\n\ * In addition to normwise error bound, the code provides maximum\n\ * componentwise error bound if possible. See comments for ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP for details of the error bounds. Note that this\n\ * subroutine is only resonsible for setting the second fields of\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * PREC_TYPE (input) INTEGER\n\ * Specifies the intermediate precision to be used in refinement.\n\ * The value is defined by ILAPREC(P) where P is a CHARACTER and\n\ * P = 'S': Single\n\ * = 'D': Double\n\ * = 'I': Indigenous\n\ * = 'X', 'E': Extra\n\ *\n\ * TRANS_TYPE (input) INTEGER\n\ * Specifies the transposition operation on A.\n\ * The value is defined by ILATRANS(T) where T is a CHARACTER and\n\ * T = 'N': No transpose\n\ * = 'T': Transpose\n\ * = 'C': Conjugate transpose\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right-hand-sides, i.e., the number of columns of the\n\ * matrix B.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n\ * The factors L and U from the factorization\n\ * A = P*L*U as computed by DGBTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from the factorization A = P*L*U\n\ * as computed by DGBTRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * COLEQU (input) LOGICAL\n\ * If .TRUE. then column equilibration was done to A before calling\n\ * this routine. This is needed to compute the solution and error\n\ * bounds correctly.\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension (N)\n\ * The column scale factors for A. If COLEQU = .FALSE., C\n\ * is not accessed. If C is input, each element of C should be a power\n\ * of the radix to ensure a reliable solution and error estimates.\n\ * Scaling by powers of the radix does not cause rounding errors unless\n\ * the result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * The right-hand-side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * Y (input/output) DOUBLE PRECISION array, dimension \n\ * (LDY,NRHS)\n\ * On entry, the solution matrix X, as computed by DGBTRS.\n\ * On exit, the improved solution matrix Y.\n\ *\n\ * LDY (input) INTEGER\n\ * The leading dimension of the array Y. LDY >= max(1,N).\n\ *\n\ * BERR_OUT (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * On exit, BERR_OUT(j) contains the componentwise relative backward\n\ * error for right-hand-side j from the formula\n\ * max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n\ * where abs(Z) is the componentwise absolute value of the matrix\n\ * or vector Z. This is computed by DLA_LIN_BERR.\n\ *\n\ * N_NORMS (input) INTEGER\n\ * Determines which error bounds to return (see ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP).\n\ * If N_NORMS >= 1 return normwise error bounds.\n\ * If N_NORMS >= 2 return componentwise error bounds.\n\ *\n\ * ERR_BNDS_NORM (input/output) DOUBLE PRECISION array, dimension \n\ * (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (input/output) DOUBLE PRECISION array, dimension \n\ * (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * RES (input) DOUBLE PRECISION array, dimension (N)\n\ * Workspace to hold the intermediate residual.\n\ *\n\ * AYB (input) DOUBLE PRECISION array, dimension (N)\n\ * Workspace. This can be the same workspace passed for Y_TAIL.\n\ *\n\ * DY (input) DOUBLE PRECISION array, dimension (N)\n\ * Workspace to hold the intermediate solution.\n\ *\n\ * Y_TAIL (input) DOUBLE PRECISION array, dimension (N)\n\ * Workspace to hold the trailing bits of the intermediate solution.\n\ *\n\ * RCOND (input) DOUBLE PRECISION\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * ITHRESH (input) INTEGER\n\ * The maximum number of residual computations allowed for\n\ * refinement. The default is 10. For 'aggressive' set to 100 to\n\ * permit convergence using approximate factorizations or\n\ * factorizations other than LU. If the factorization uses a\n\ * technique other than Gaussian elimination, the guarantees in\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n\ *\n\ * RTHRESH (input) DOUBLE PRECISION\n\ * Determines when to stop refinement if the error estimate stops\n\ * decreasing. Refinement will stop when the next solution no longer\n\ * satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n\ * the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n\ * default value is 0.5. For 'aggressive' set to 0.9 to permit\n\ * convergence on extremely ill-conditioned matrices. See LAWN 165\n\ * for more details.\n\ *\n\ * DZ_UB (input) DOUBLE PRECISION\n\ * Determines when to start considering componentwise convergence.\n\ * Componentwise convergence is only considered after each component\n\ * of the solution Y is stable, which we definte as the relative\n\ * change in each component being less than DZ_UB. The default value\n\ * is 0.25, requiring the first bit to be stable. See LAWN 165 for\n\ * more details.\n\ *\n\ * IGNORE_CWISE (input) LOGICAL\n\ * If .TRUE. then ignore componentwise convergence. Default value\n\ * is .FALSE..\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * < 0: if INFO = -i, the ith argument to DGBTRS had an illegal\n\ * value\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n CHARACTER TRANS\n INTEGER CNT, I, J, M, X_STATE, Z_STATE, Y_PREC_STATE\n DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zppsv0000644000175000017500000000757312502223526016406 0ustar uwabamiuwabami--- :name: zppsv :md5sum: 16fdc72e2738bd7a738685cfb005158d :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPPSV( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPPSV computes the solution to a complex system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N Hermitian positive definite matrix stored in\n\ * packed format and X and B are N-by-NRHS matrices.\n\ *\n\ * The Cholesky decomposition is used to factor A as\n\ * A = U**H* U, if UPLO = 'U', or\n\ * A = L * L**H, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is a lower triangular\n\ * matrix. The factored form of A is then used to solve the system of\n\ * equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ * See below for further details.\n\ *\n\ * On exit, if INFO = 0, the factor U or L from the Cholesky\n\ * factorization A = U**H*U or A = L*L**H, in the same storage\n\ * format as A.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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 leading minor of order i of A is not\n\ * positive definite, so the factorization could not be\n\ * completed, and the solution has not been computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The packed storage scheme is illustrated by the following example\n\ * when N = 4, UPLO = 'U':\n\ *\n\ * Two-dimensional storage of the Hermitian matrix A:\n\ *\n\ * a11 a12 a13 a14\n\ * a22 a23 a24\n\ * a33 a34 (aij = conjg(aji))\n\ * a44\n\ *\n\ * Packed storage of the upper triangle of A:\n\ *\n\ * AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n\ *\n\ * =====================================================================\n\ *\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZPPTRF, ZPPTRS\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zgglse0000644000175000017500000001220212502223526016500 0ustar uwabamiuwabami--- :name: zgglse :md5sum: 35e6163d310f41393a8f66de172089a5 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - p: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: doublecomplex :intent: input/output :dims: - m - d: :type: doublecomplex :intent: input/output :dims: - p - x: :type: doublecomplex :intent: output :dims: - n - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m+n+p - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGGLSE solves the linear equality-constrained least squares (LSE)\n\ * problem:\n\ *\n\ * minimize || c - A*x ||_2 subject to B*x = d\n\ *\n\ * where A is an M-by-N matrix, B is a P-by-N matrix, c is a given\n\ * M-vector, and d is a given P-vector. It is assumed that\n\ * P <= N <= M+P, and\n\ *\n\ * rank(B) = P and rank( ( A ) ) = N.\n\ * ( ( B ) )\n\ *\n\ * These conditions ensure that the LSE problem has a unique solution,\n\ * which is obtained using a generalized RQ factorization of the\n\ * matrices (B, A) given by\n\ *\n\ * B = (0 R)*Q, A = Z*T*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 matrices A and B. N >= 0.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows of the matrix B. 0 <= P <= N <= M+P.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, the elements on and above the diagonal of the array\n\ * contain the min(M,N)-by-N upper trapezoidal matrix T.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,N)\n\ * On entry, the P-by-N matrix B.\n\ * On exit, the upper triangle of the subarray B(1:P,N-P+1:N)\n\ * contains the P-by-P upper triangular matrix R.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,P).\n\ *\n\ * C (input/output) COMPLEX*16 array, dimension (M)\n\ * On entry, C contains the right hand side vector for the\n\ * least squares part of the LSE problem.\n\ * On exit, the residual sum of squares for the solution\n\ * is given by the sum of squares of elements N-P+1 to M of\n\ * vector C.\n\ *\n\ * D (input/output) COMPLEX*16 array, dimension (P)\n\ * On entry, D contains the right hand side vector for the\n\ * constrained equation.\n\ * On exit, D is destroyed.\n\ *\n\ * X (output) COMPLEX*16 array, dimension (N)\n\ * On exit, X is the solution of the LSE problem.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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+P).\n\ * For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,\n\ * where NB is an upper bound for the optimal blocksizes for\n\ * ZGEQRF, CGERQF, ZUNMQR and CUNMRQ.\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\ * = 1: the upper triangular factor R associated with B in the\n\ * generalized RQ factorization of the pair (B, A) is\n\ * singular, so that rank(B) < P; the least squares\n\ * solution could not be computed.\n\ * = 2: the (N-P) by (N-P) part of the upper trapezoidal factor\n\ * T associated with A in the generalized RQ factorization\n\ * of the pair (B, A) is singular, so that\n\ * rank( (A) ) < N; the least squares solution could not\n\ * ( (B) )\n\ * be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlarz0000644000175000017500000000612212502223526016353 0ustar uwabamiuwabami--- :name: zlarz :md5sum: 51817751cd08b24f60b8544807b10bea :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - l: :type: integer :intent: input - v: :type: doublecomplex :intent: input :dims: - 1+(l-1)*abs(incv) - incv: :type: integer :intent: input - tau: :type: doublecomplex :intent: input - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " SUBROUTINE ZLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLARZ applies a complex elementary reflector H to a complex\n\ * M-by-N matrix C, from either the left or the right. H is represented\n\ * in the form\n\ *\n\ * H = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar and v is a complex vector.\n\ *\n\ * If tau = 0, then H is taken to be the unit matrix.\n\ *\n\ * To apply H' (the conjugate transpose of H), supply conjg(tau) instead\n\ * tau.\n\ *\n\ * H is a product of k elementary reflectors as returned by ZTZRZF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': form H * C\n\ * = 'R': form C * H\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C.\n\ *\n\ * L (input) INTEGER\n\ * The number of entries of the vector V containing\n\ * the meaningful part of the Householder vectors.\n\ * If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n\ *\n\ * V (input) COMPLEX*16 array, dimension (1+(L-1)*abs(INCV))\n\ * The vector v in the representation of H as returned by\n\ * ZTZRZF. V is not used if TAU = 0.\n\ *\n\ * INCV (input) INTEGER\n\ * The increment between elements of v. INCV <> 0.\n\ *\n\ * TAU (input) COMPLEX*16\n\ * The value tau in the representation of H.\n\ *\n\ * C (input/output) COMPLEX*16 array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n\ * or C * H if SIDE = 'R'.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension\n\ * (N) if SIDE = 'L'\n\ * or (M) if SIDE = 'R'\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sla_lin_berr0000644000175000017500000000463612502223526017654 0ustar uwabamiuwabami--- :name: sla_lin_berr :md5sum: a5c1dc09d744f377635f2d5129303a43 :category: :subroutine :arguments: - n: :type: integer :intent: input - nz: :type: integer :intent: input - nrhs: :type: integer :intent: input - res: :type: real :intent: input :dims: - n - nrhs - ayb: :type: real :intent: input :dims: - n - nrhs - berr: :type: real :intent: output :dims: - nrhs :substitutions: {} :fortran_help: " SUBROUTINE SLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLA_LIN_BERR computes componentwise relative backward error from\n\ * the formula\n\ * max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n\ * where abs(Z) is the componentwise absolute value of the matrix\n\ * or vector Z.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NZ (input) INTEGER\n\ * We add (NZ+1)*SLAMCH( 'Safe minimum' ) to R(i) in the numerator to\n\ * guard against spuriously zero residuals. Default value is N.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices AYB, RES, and BERR. NRHS >= 0.\n\ *\n\ * RES (input) REAL array, dimension (N,NRHS)\n\ * The residual matrix, i.e., the matrix R in the relative backward\n\ * error formula above.\n\ *\n\ * AYB (input) REAL array, dimension (N, NRHS)\n\ * The denominator in the relative backward error formula above, i.e.,\n\ * the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B\n\ * are from iterative refinement (see sla_gerfsx_extended.f).\n\ * \n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error from the formula above.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n REAL TMP\n INTEGER I, J\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n\ * ..\n\ * .. External Functions ..\n EXTERNAL SLAMCH\n REAL SLAMCH\n REAL SAFE1\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sgeqrf0000644000175000017500000000721612502223526016505 0ustar uwabamiuwabami--- :name: sgeqrf :md5sum: a14be5141cf6a70a428306a636c55c81 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - MIN(m,n) - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGEQRF computes a QR factorization of a real M-by-N matrix A:\n\ * A = Q * R.\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) REAL array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, the elements on and above the diagonal of the array\n\ * contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n\ * upper triangular if m >= n); the elements below the diagonal,\n\ * with the array TAU, represent the orthogonal matrix Q as a\n\ * product of min(m,n) elementary reflectors (see Further\n\ * Details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (output) REAL array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace/output) REAL 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,N).\n\ * For optimum performance LWORK >= N*NB, where NB is \n\ * the 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(1) H(2) . . . H(k), 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:m) is stored on exit in A(i+1:m,i),\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 SGEQR2, SLARFB, SLARFT, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dormbr0000644000175000017500000001413412502223526016500 0ustar uwabamiuwabami--- :name: dormbr :md5sum: b5ba35a95f74b550f64794efa893d8b7 :category: :subroutine :arguments: - vect: :type: char :intent: input - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - MIN(nq,k) - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - MIN(nq,k) - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: nq: "lsame_(&side,\"L\") ? m : lsame_(&side,\"R\") ? n : 0" :fortran_help: " SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * If VECT = 'Q', DORMBR overwrites the general real M-by-N matrix C\n\ * with\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'T': Q**T * C C * Q**T\n\ *\n\ * If VECT = 'P', DORMBR overwrites the general real M-by-N matrix C\n\ * with\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': P * C C * P\n\ * TRANS = 'T': P**T * C C * P**T\n\ *\n\ * Here Q and P**T are the orthogonal matrices determined by DGEBRD when\n\ * reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and\n\ * P**T are defined as products of elementary reflectors H(i) and G(i)\n\ * respectively.\n\ *\n\ * Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the\n\ * order of the orthogonal matrix Q or P**T that is applied.\n\ *\n\ * If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:\n\ * if nq >= k, Q = H(1) H(2) . . . H(k);\n\ * if nq < k, Q = H(1) H(2) . . . H(nq-1).\n\ *\n\ * If VECT = 'P', A is assumed to have been a K-by-NQ matrix:\n\ * if k < nq, P = G(1) G(2) . . . G(k);\n\ * if k >= nq, P = G(1) G(2) . . . G(nq-1).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * VECT (input) CHARACTER*1\n\ * = 'Q': apply Q or Q**T;\n\ * = 'P': apply P or P**T.\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q, Q**T, P or P**T from the Left;\n\ * = 'R': apply Q, Q**T, P or P**T from the Right.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q or P;\n\ * = 'T': Transpose, apply Q**T or P**T.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * If VECT = 'Q', the number of columns in the original\n\ * matrix reduced by DGEBRD.\n\ * If VECT = 'P', the number of rows in the original\n\ * matrix reduced by DGEBRD.\n\ * K >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension\n\ * (LDA,min(nq,K)) if VECT = 'Q'\n\ * (LDA,nq) if VECT = 'P'\n\ * The vectors which define the elementary reflectors H(i) and\n\ * G(i), whose products determine the matrices Q and P, as\n\ * returned by DGEBRD.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ * If VECT = 'Q', LDA >= max(1,nq);\n\ * if VECT = 'P', LDA >= max(1,min(nq,K)).\n\ *\n\ * TAU (input) DOUBLE PRECISION array, dimension (min(nq,K))\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i) or G(i) which determines Q or P, as returned\n\ * by DGEBRD in the array argument TAUQ or TAUP.\n\ *\n\ * C (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q\n\ * or P*C or P**T*C or C*P or C*P**T.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M).\n\ * For optimum performance LWORK >= N*NB if SIDE = 'L', and\n\ * LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n\ * 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\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN\n CHARACTER TRANST\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DORMLQ, DORMQR, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sorbdb0000644000175000017500000002134412502223526016467 0ustar uwabamiuwabami--- :name: sorbdb :md5sum: 77f4a56e636c0e03cf3f7e9ce0710fd2 :category: :subroutine :arguments: - trans: :type: char :intent: input - signs: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - q: :type: integer :intent: input - x11: :type: real :intent: input/output :dims: - ldx11 - q - ldx11: :type: integer :intent: input - x12: :type: real :intent: input/output :dims: - ldx12 - m-q - ldx12: :type: integer :intent: input - x21: :type: real :intent: input/output :dims: - ldx21 - q - ldx21: :type: integer :intent: input - x22: :type: real :intent: input/output :dims: - ldx22 - m-q - ldx22: :type: integer :intent: input - theta: :type: real :intent: output :dims: - q - phi: :type: real :intent: output :dims: - q-1 - taup1: :type: real :intent: output :dims: - p - taup2: :type: real :intent: output :dims: - m-p - tauq1: :type: real :intent: output :dims: - q - tauq2: :type: real :intent: output :dims: - m-q - work: :type: real :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m-q - info: :type: integer :intent: output :substitutions: p: ldx11 ldx12: p ldx21: p ldx22: p :fortran_help: " SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SORBDB simultaneously bidiagonalizes the blocks of an M-by-M\n\ * partitioned orthogonal matrix X:\n\ *\n\ * [ B11 | B12 0 0 ]\n\ * [ X11 | X12 ] [ P1 | ] [ 0 | 0 -I 0 ] [ Q1 | ]**T\n\ * X = [-----------] = [---------] [----------------] [---------] .\n\ * [ X21 | X22 ] [ | P2 ] [ B21 | B22 0 0 ] [ | Q2 ]\n\ * [ 0 | 0 0 I ]\n\ *\n\ * X11 is P-by-Q. Q must be no larger than P, M-P, or M-Q. (If this is\n\ * not the case, then X must be transposed and/or permuted. This can be\n\ * done in constant time using the TRANS and SIGNS options. See SORCSD\n\ * for details.)\n\ *\n\ * The orthogonal matrices P1, P2, Q1, and Q2 are P-by-P, (M-P)-by-\n\ * (M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. They are\n\ * represented implicitly by Householder vectors.\n\ *\n\ * B11, B12, B21, and B22 are Q-by-Q bidiagonal matrices represented\n\ * implicitly by angles THETA, PHI.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER\n\ * = 'T': X, U1, U2, V1T, and V2T are stored in row-major\n\ * order;\n\ * otherwise: X, U1, U2, V1T, and V2T are stored in column-\n\ * major order.\n\ *\n\ * SIGNS (input) CHARACTER\n\ * = 'O': The lower-left block is made nonpositive (the\n\ * \"other\" convention);\n\ * otherwise: The upper-right block is made nonpositive (the\n\ * \"default\" convention).\n\ *\n\ * M (input) INTEGER\n\ * The number of rows and columns in X.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows in X11 and X12. 0 <= P <= M.\n\ *\n\ * Q (input) INTEGER\n\ * The number of columns in X11 and X21. 0 <= Q <=\n\ * MIN(P,M-P,M-Q).\n\ *\n\ * X11 (input/output) REAL array, dimension (LDX11,Q)\n\ * On entry, the top-left block of the orthogonal matrix to be\n\ * reduced. On exit, the form depends on TRANS:\n\ * If TRANS = 'N', then\n\ * the columns of tril(X11) specify reflectors for P1,\n\ * the rows of triu(X11,1) specify reflectors for Q1;\n\ * else TRANS = 'T', and\n\ * the rows of triu(X11) specify reflectors for P1,\n\ * the columns of tril(X11,-1) specify reflectors for Q1.\n\ *\n\ * LDX11 (input) INTEGER\n\ * The leading dimension of X11. If TRANS = 'N', then LDX11 >=\n\ * P; else LDX11 >= Q.\n\ *\n\ * X12 (input/output) REAL array, dimension (LDX12,M-Q)\n\ * On entry, the top-right block of the orthogonal matrix to\n\ * be reduced. On exit, the form depends on TRANS:\n\ * If TRANS = 'N', then\n\ * the rows of triu(X12) specify the first P reflectors for\n\ * Q2;\n\ * else TRANS = 'T', and\n\ * the columns of tril(X12) specify the first P reflectors\n\ * for Q2.\n\ *\n\ * LDX12 (input) INTEGER\n\ * The leading dimension of X12. If TRANS = 'N', then LDX12 >=\n\ * P; else LDX11 >= M-Q.\n\ *\n\ * X21 (input/output) REAL array, dimension (LDX21,Q)\n\ * On entry, the bottom-left block of the orthogonal matrix to\n\ * be reduced. On exit, the form depends on TRANS:\n\ * If TRANS = 'N', then\n\ * the columns of tril(X21) specify reflectors for P2;\n\ * else TRANS = 'T', and\n\ * the rows of triu(X21) specify reflectors for P2.\n\ *\n\ * LDX21 (input) INTEGER\n\ * The leading dimension of X21. If TRANS = 'N', then LDX21 >=\n\ * M-P; else LDX21 >= Q.\n\ *\n\ * X22 (input/output) REAL array, dimension (LDX22,M-Q)\n\ * On entry, the bottom-right block of the orthogonal matrix to\n\ * be reduced. On exit, the form depends on TRANS:\n\ * If TRANS = 'N', then\n\ * the rows of triu(X22(Q+1:M-P,P+1:M-Q)) specify the last\n\ * M-P-Q reflectors for Q2,\n\ * else TRANS = 'T', and\n\ * the columns of tril(X22(P+1:M-Q,Q+1:M-P)) specify the last\n\ * M-P-Q reflectors for P2.\n\ *\n\ * LDX22 (input) INTEGER\n\ * The leading dimension of X22. If TRANS = 'N', then LDX22 >=\n\ * M-P; else LDX22 >= M-Q.\n\ *\n\ * THETA (output) REAL array, dimension (Q)\n\ * The entries of the bidiagonal blocks B11, B12, B21, B22 can\n\ * be computed from the angles THETA and PHI. See Further\n\ * Details.\n\ *\n\ * PHI (output) REAL array, dimension (Q-1)\n\ * The entries of the bidiagonal blocks B11, B12, B21, B22 can\n\ * be computed from the angles THETA and PHI. See Further\n\ * Details.\n\ *\n\ * TAUP1 (output) REAL array, dimension (P)\n\ * The scalar factors of the elementary reflectors that define\n\ * P1.\n\ *\n\ * TAUP2 (output) REAL array, dimension (M-P)\n\ * The scalar factors of the elementary reflectors that define\n\ * P2.\n\ *\n\ * TAUQ1 (output) REAL array, dimension (Q)\n\ * The scalar factors of the elementary reflectors that define\n\ * Q1.\n\ *\n\ * TAUQ2 (output) REAL array, dimension (M-Q)\n\ * The scalar factors of the elementary reflectors that define\n\ * Q2.\n\ *\n\ * WORK (workspace) REAL array, dimension (LWORK)\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK >= M-Q.\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 bidiagonal blocks B11, B12, B21, and B22 are represented\n\ * implicitly by angles THETA(1), ..., THETA(Q) and PHI(1), ...,\n\ * PHI(Q-1). B11 and B21 are upper bidiagonal, while B21 and B22 are\n\ * lower bidiagonal. Every entry in each bidiagonal band is a product\n\ * of a sine or cosine of a THETA with a sine or cosine of a PHI. See\n\ * [1] or SORCSD for details.\n\ *\n\ * P1, P2, Q1, and Q2 are represented as products of elementary\n\ * reflectors. See SORCSD for details on generating P1, P2, Q1, and Q2\n\ * using SORGQR and SORGLQ.\n\ *\n\ * Reference\n\ * =========\n\ *\n\ * [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.\n\ * Algorithms, 50(1):33-65, 2009.\n\ *\n\ * ====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dla_rpvgrw0000644000175000017500000000406212502223526017361 0ustar uwabamiuwabami--- :name: dla_rpvgrw :md5sum: f34d9e53195025ba4075345e34febe49 :category: :function :type: doublereal :arguments: - n: :type: integer :intent: input - ncols: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION DLA_RPVGRW( N, NCOLS, A, LDA, AF, LDAF )\n\n\ * Purpose\n\ * =======\n\ * \n\ * DLA_RPVGRW computes the reciprocal pivot growth factor\n\ * norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n\ * much less than 1, the stability of the LU factorization of the\n\ * (equilibrated) matrix A could be poor. This also means that the\n\ * solution X, estimated condition numbers, and error bounds could be\n\ * unreliable.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NCOLS (input) INTEGER\n\ * The number of columns of the matrix A. NCOLS >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n\ * The factors L and U from the factorization\n\ * A = P*L*U as computed by DGETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n DOUBLE PRECISION AMAX, UMAX, RPVGRW\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sppcon0000644000175000017500000000505412502223526016516 0ustar uwabamiuwabami--- :name: sppcon :md5sum: 98f94f1d8ffd2bf4f13ec248609b1c13 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input :dims: - ldap - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE SPPCON( UPLO, N, AP, ANORM, RCOND, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPPCON estimates the reciprocal of the condition number (in the\n\ * 1-norm) of a real symmetric positive definite packed matrix using\n\ * the Cholesky factorization A = U**T*U or A = L*L**T computed by\n\ * SPPTRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input) REAL array, dimension (N*(N+1)/2)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T, packed columnwise in a linear\n\ * array. The j-th column of U or L is stored in the array AP\n\ * as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n\ *\n\ * ANORM (input) REAL\n\ * The 1-norm (or infinity-norm) of the symmetric matrix A.\n\ *\n\ * RCOND (output) REAL\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n\ * estimate of the 1-norm of inv(A) computed in this routine.\n\ *\n\ * WORK (workspace) REAL array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgtsv0000644000175000017500000000573112502223526016345 0ustar uwabamiuwabami--- :name: dgtsv :md5sum: 049008f7af4d85ec1a04d1743b655d80 :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: doublereal :intent: input/output :dims: - n-1 - d: :type: doublereal :intent: input/output :dims: - n - du: :type: doublereal :intent: input/output :dims: - n-1 - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGTSV solves the equation\n\ *\n\ * A*X = B,\n\ *\n\ * where A is an n by n tridiagonal matrix, by Gaussian elimination with\n\ * partial pivoting.\n\ *\n\ * Note that the equation A'*X = B may be solved by interchanging the\n\ * order of the arguments DU and DL.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * DL (input/output) DOUBLE PRECISION array, dimension (N-1)\n\ * On entry, DL must contain the (n-1) sub-diagonal elements of\n\ * A.\n\ *\n\ * On exit, DL is overwritten by the (n-2) elements of the\n\ * second super-diagonal of the upper triangular matrix U from\n\ * the LU factorization of A, in DL(1), ..., DL(n-2).\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, D must contain the diagonal elements of A.\n\ *\n\ * On exit, D is overwritten by the n diagonal elements of U.\n\ *\n\ * DU (input/output) DOUBLE PRECISION array, dimension (N-1)\n\ * On entry, DU must contain the (n-1) super-diagonal elements\n\ * of A.\n\ *\n\ * On exit, DU is overwritten by the (n-1) elements of the first\n\ * super-diagonal of U.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the N by NRHS matrix of right hand side matrix B.\n\ * On exit, if INFO = 0, the N by NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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, U(i,i) is exactly zero, and the solution\n\ * has not been computed. The factorization has not been\n\ * completed unless i = N.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/strexc0000644000175000017500000000740412502223526016525 0ustar uwabamiuwabami--- :name: strexc :md5sum: a068be55bb498b1fa71d32054496ba06 :category: :subroutine :arguments: - compq: :type: char :intent: input - n: :type: integer :intent: input - t: :type: real :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - q: :type: real :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - ifst: :type: integer :intent: input/output - ilst: :type: integer :intent: input/output - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE STREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STREXC reorders the real Schur factorization of a real matrix\n\ * A = Q*T*Q**T, so that the diagonal block of T with row index IFST is\n\ * moved to row ILST.\n\ *\n\ * The real Schur form T is reordered by an orthogonal similarity\n\ * transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors\n\ * is updated by postmultiplying it with Z.\n\ *\n\ * T must be in Schur canonical form (as returned by SHSEQR), that is,\n\ * block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each\n\ * 2-by-2 diagonal block has its diagonal elements equal and its\n\ * off-diagonal elements of opposite sign.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * COMPQ (input) CHARACTER*1\n\ * = 'V': update the matrix Q of Schur vectors;\n\ * = 'N': do not update Q.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix T. N >= 0.\n\ *\n\ * T (input/output) REAL array, dimension (LDT,N)\n\ * On entry, the upper quasi-triangular matrix T, in Schur\n\ * Schur canonical form.\n\ * On exit, the reordered upper quasi-triangular matrix, again\n\ * in Schur canonical form.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= max(1,N).\n\ *\n\ * Q (input/output) REAL array, dimension (LDQ,N)\n\ * On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n\ * On exit, if COMPQ = 'V', Q has been postmultiplied by the\n\ * orthogonal transformation matrix Z which reorders T.\n\ * If COMPQ = 'N', Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N).\n\ *\n\ * IFST (input/output) INTEGER\n\ * ILST (input/output) INTEGER\n\ * Specify the reordering of the diagonal blocks of T.\n\ * The block with row index IFST is moved to row ILST, by a\n\ * sequence of transpositions between adjacent blocks.\n\ * On exit, if IFST pointed on entry to the second row of a\n\ * 2-by-2 block, it is changed to point to the first row; ILST\n\ * always points to the first row of the block in its final\n\ * position (which may differ from its input value by +1 or -1).\n\ * 1 <= IFST <= N; 1 <= ILST <= N.\n\ *\n\ * WORK (workspace) REAL array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * = 1: two adjacent blocks were too close to swap (the problem\n\ * is very ill-conditioned); T may have been partially\n\ * reordered, and ILST points to the first row of the\n\ * current position of the block being moved.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chla_transtype0000644000175000017500000000207512502223525020233 0ustar uwabamiuwabami--- :name: chla_transtype :md5sum: 72653dbad54122949a79d609236e064b :category: :function :type: char :arguments: - trans: :type: integer :intent: input :substitutions: {} :fortran_help: " CHARACTER*1 FUNCTION CHLA_TRANSTYPE( TRANS )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This subroutine translates from a BLAST-specified integer constant to\n\ * the character string specifying a transposition operation.\n\ *\n\ * CHLA_TRANSTYPE returns an CHARACTER*1. If CHLA_TRANSTYPE is 'X',\n\ * then input is not an integer indicating a transposition operator.\n\ * Otherwise CHLA_TRANSTYPE returns the constant value corresponding to\n\ * TRANS.\n\ *\n\n\ * Arguments\n\ * =========\n\ * TRANS (input) INTEGER\n\ * Specifies the form of the system of equations:\n\ * = BLAS_NO_TRANS = 111 : No Transpose\n\ * = BLAS_TRANS = 112 : Transpose\n\ * = BLAS_CONJ_TRANS = 113 : Conjugate Transpose\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlagv20000644000175000017500000000731712502223526016377 0ustar uwabamiuwabami--- :name: dlagv2 :md5sum: 0213b40436ec590dd32628d8b5e77774 :category: :subroutine :arguments: - a: :type: doublereal :intent: input/output :dims: - lda - "2" - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - "2" - ldb: :type: integer :intent: input - alphar: :type: doublereal :intent: output :dims: - "2" - alphai: :type: doublereal :intent: output :dims: - "2" - beta: :type: doublereal :intent: output :dims: - "2" - csl: :type: doublereal :intent: output - snl: :type: doublereal :intent: output - csr: :type: doublereal :intent: output - snr: :type: doublereal :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, CSR, SNR )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAGV2 computes the Generalized Schur factorization of a real 2-by-2\n\ * matrix pencil (A,B) where B is upper triangular. This routine\n\ * computes orthogonal (rotation) matrices given by CSL, SNL and CSR,\n\ * SNR such that\n\ *\n\ * 1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0\n\ * types), then\n\ *\n\ * [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ]\n\ * [ 0 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ]\n\ *\n\ * [ b11 b12 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ]\n\ * [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ],\n\ *\n\ * 2) if the pencil (A,B) has a pair of complex conjugate eigenvalues,\n\ * then\n\ *\n\ * [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ]\n\ * [ a21 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ]\n\ *\n\ * [ b11 0 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ]\n\ * [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ]\n\ *\n\ * where b11 >= b22 > 0.\n\ *\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA, 2)\n\ * On entry, the 2 x 2 matrix A.\n\ * On exit, A is overwritten by the ``A-part'' of the\n\ * generalized Schur form.\n\ *\n\ * LDA (input) INTEGER\n\ * THe leading dimension of the array A. LDA >= 2.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB, 2)\n\ * On entry, the upper triangular 2 x 2 matrix B.\n\ * On exit, B is overwritten by the ``B-part'' of the\n\ * generalized Schur form.\n\ *\n\ * LDB (input) INTEGER\n\ * THe leading dimension of the array B. LDB >= 2.\n\ *\n\ * ALPHAR (output) DOUBLE PRECISION array, dimension (2)\n\ * ALPHAI (output) DOUBLE PRECISION array, dimension (2)\n\ * BETA (output) DOUBLE PRECISION array, dimension (2)\n\ * (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the\n\ * pencil (A,B), k=1,2, i = sqrt(-1). Note that BETA(k) may\n\ * be zero.\n\ *\n\ * CSL (output) DOUBLE PRECISION\n\ * The cosine of the left rotation matrix.\n\ *\n\ * SNL (output) DOUBLE PRECISION\n\ * The sine of the left rotation matrix.\n\ *\n\ * CSR (output) DOUBLE PRECISION\n\ * The cosine of the right rotation matrix.\n\ *\n\ * SNR (output) DOUBLE PRECISION\n\ * The sine of the right rotation matrix.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sporfs0000644000175000017500000001135212502223526016526 0ustar uwabamiuwabami--- :name: sporfs :md5sum: 2da5772e924df961dace1e5733835a98 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPORFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is symmetric positive definite,\n\ * and provides error bounds and backward error estimates for the\n\ * solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular part\n\ * of the matrix A, and the strictly lower triangular part of A\n\ * is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of A contains the lower triangular part of\n\ * the matrix A, and the strictly upper triangular part of A is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) REAL array, dimension (LDAF,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T, as computed by SPOTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * B (input) REAL array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) REAL array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by SPOTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) REAL array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgecon0000644000175000017500000000503512502223526016452 0ustar uwabamiuwabami--- :name: dgecon :md5sum: ce08c3cbca5bd107bc2e0dac5059f801 :category: :subroutine :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGECON estimates the reciprocal of the condition number of a general\n\ * real matrix A, in either the 1-norm or the infinity-norm, using\n\ * the LU factorization computed by DGETRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as\n\ * RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies whether the 1-norm condition number or the\n\ * infinity-norm condition number is required:\n\ * = '1' or 'O': 1-norm;\n\ * = 'I': Infinity-norm.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The factors L and U from the factorization A = P*L*U\n\ * as computed by DGETRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * ANORM (input) DOUBLE PRECISION\n\ * If NORM = '1' or 'O', the 1-norm of the original matrix A.\n\ * If NORM = 'I', the infinity-norm of the original matrix A.\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(norm(A) * norm(inv(A))).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zunglq0000644000175000017500000000572612502223526016542 0ustar uwabamiuwabami--- :name: zunglq :md5sum: 9b70bf35a8d9a6feceba04344bf82610 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZUNGLQ generates an M-by-N complex matrix Q with orthonormal rows,\n\ * which is defined as the first M rows of a product of K elementary\n\ * reflectors of order N\n\ *\n\ * Q = H(k)' . . . H(2)' H(1)'\n\ *\n\ * as returned by ZGELQF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. N >= M.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. M >= K >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the i-th row must contain the vector which defines\n\ * the elementary reflector H(i), for i = 1,2,...,k, as returned\n\ * by ZGELQF in the first k rows of its array argument A.\n\ * On exit, the M-by-N matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) COMPLEX*16 array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by ZGELQF.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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\n\ * the 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 has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctbrfs0000644000175000017500000001165412502223525016501 0ustar uwabamiuwabami--- :name: ctbrfs :md5sum: 7c86c62620f2a6d4354d70f9e0b25b2c :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTBRFS provides error bounds and backward error estimates for the\n\ * solution to a system of linear equations with a triangular band\n\ * coefficient matrix.\n\ *\n\ * The solution matrix X must be computed by CTBTRS or some other\n\ * means before entering this routine. CTBRFS does not do iterative\n\ * refinement because doing so cannot improve the backward error.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals or subdiagonals of the\n\ * triangular band matrix A. KD >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AB (input) COMPLEX array, dimension (LDAB,N)\n\ * The upper or lower triangular band matrix A, stored in the\n\ * first kd+1 rows of the array. The j-th column of A is stored\n\ * in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ * If DIAG = 'U', the diagonal elements of A are not referenced\n\ * and are assumed to be 1.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input) COMPLEX array, dimension (LDX,NRHS)\n\ * The solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dtgsen0000644000175000017500000004200712502223526016477 0ustar uwabamiuwabami--- :name: dtgsen :md5sum: b42523cce95d8dd0d43f3e1b716e3eab :category: :subroutine :arguments: - ijob: :type: integer :intent: input - wantq: :type: logical :intent: input - wantz: :type: logical :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alphar: :type: doublereal :intent: output :dims: - n - alphai: :type: doublereal :intent: output :dims: - n - beta: :type: doublereal :intent: output :dims: - n - q: :type: doublereal :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - z: :type: doublereal :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - m: :type: integer :intent: output - pl: :type: doublereal :intent: output - pr: :type: doublereal :intent: output - dif: :type: doublereal :intent: output :dims: - "2" - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(ijob==1||ijob==2||ijob==4) ? MAX(4*n+16,2*m*(n-m)) : (ijob==3||ijob==5) ? MAX(4*n+16,4*m*(n-m)) : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "(ijob==1||ijob==2||ijob==4) ? n+6 : (ijob==3||ijob==5) ? MAX(2*m*(n-m),n+6) : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTGSEN reorders the generalized real Schur decomposition of a real\n\ * matrix pair (A, B) (in terms of an orthonormal equivalence trans-\n\ * formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues\n\ * appears in the leading diagonal blocks of the upper quasi-triangular\n\ * matrix A and the upper triangular B. The leading columns of Q and\n\ * Z form orthonormal bases of the corresponding left and right eigen-\n\ * spaces (deflating subspaces). (A, B) must be in generalized real\n\ * Schur canonical form (as returned by DGGES), i.e. A is block upper\n\ * triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper\n\ * triangular.\n\ *\n\ * DTGSEN also computes the generalized eigenvalues\n\ *\n\ * w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j)\n\ *\n\ * of the reordered matrix pair (A, B).\n\ *\n\ * Optionally, DTGSEN computes the estimates of reciprocal condition\n\ * numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),\n\ * (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)\n\ * between the matrix pairs (A11, B11) and (A22,B22) that correspond to\n\ * the selected cluster and the eigenvalues outside the cluster, resp.,\n\ * and norms of \"projections\" onto left and right eigenspaces w.r.t.\n\ * the selected cluster in the (1,1)-block.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * IJOB (input) INTEGER\n\ * Specifies whether condition numbers are required for the\n\ * cluster of eigenvalues (PL and PR) or the deflating subspaces\n\ * (Difu and Difl):\n\ * =0: Only reorder w.r.t. SELECT. No extras.\n\ * =1: Reciprocal of norms of \"projections\" onto left and right\n\ * eigenspaces w.r.t. the selected cluster (PL and PR).\n\ * =2: Upper bounds on Difu and Difl. F-norm-based estimate\n\ * (DIF(1:2)).\n\ * =3: Estimate of Difu and Difl. 1-norm-based estimate\n\ * (DIF(1:2)).\n\ * About 5 times as expensive as IJOB = 2.\n\ * =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic\n\ * version to get it all.\n\ * =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)\n\ *\n\ * WANTQ (input) LOGICAL\n\ * .TRUE. : update the left transformation matrix Q;\n\ * .FALSE.: do not update Q.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * .TRUE. : update the right transformation matrix Z;\n\ * .FALSE.: do not update Z.\n\ *\n\ * SELECT (input) LOGICAL array, dimension (N)\n\ * SELECT specifies the eigenvalues in the selected cluster.\n\ * To select a real eigenvalue w(j), SELECT(j) must be set to\n\ * .TRUE.. To select a complex conjugate pair of eigenvalues\n\ * w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,\n\ * either SELECT(j) or SELECT(j+1) or both must be set to\n\ * .TRUE.; a complex conjugate pair of eigenvalues must be\n\ * either both included in the cluster or both excluded.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension(LDA,N)\n\ * On entry, the upper quasi-triangular matrix A, with (A, B) in\n\ * generalized real Schur canonical form.\n\ * On exit, A is overwritten by the reordered matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension(LDB,N)\n\ * On entry, the upper triangular matrix B, with (A, B) in\n\ * generalized real Schur canonical form.\n\ * On exit, B is overwritten by the reordered matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * ALPHAR (output) DOUBLE PRECISION array, dimension (N)\n\ * ALPHAI (output) DOUBLE PRECISION array, dimension (N)\n\ * BETA (output) DOUBLE PRECISION array, dimension (N)\n\ * On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n\ * be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i\n\ * and BETA(j),j=1,...,N are the diagonals of the complex Schur\n\ * form (S,T) that would result if the 2-by-2 diagonal blocks of\n\ * the real generalized Schur form of (A,B) were further reduced\n\ * to triangular form using complex unitary transformations.\n\ * If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n\ * positive, then the j-th and (j+1)-st eigenvalues are a\n\ * complex conjugate pair, with ALPHAI(j+1) negative.\n\ *\n\ * Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n\ * On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.\n\ * On exit, Q has been postmultiplied by the left orthogonal\n\ * transformation matrix which reorder (A, B); The leading M\n\ * columns of Q form orthonormal bases for the specified pair of\n\ * left eigenspaces (deflating subspaces).\n\ * If WANTQ = .FALSE., Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= 1;\n\ * and if WANTQ = .TRUE., LDQ >= N.\n\ *\n\ * Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n\ * On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.\n\ * On exit, Z has been postmultiplied by the left orthogonal\n\ * transformation matrix which reorder (A, B); The leading M\n\ * columns of Z form orthonormal bases for the specified pair of\n\ * left eigenspaces (deflating subspaces).\n\ * If WANTZ = .FALSE., Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1;\n\ * If WANTZ = .TRUE., LDZ >= N.\n\ *\n\ * M (output) INTEGER\n\ * The dimension of the specified pair of left and right eigen-\n\ * spaces (deflating subspaces). 0 <= M <= N.\n\ *\n\ * PL (output) DOUBLE PRECISION\n\ * PR (output) DOUBLE PRECISION\n\ * If IJOB = 1, 4 or 5, PL, PR are lower bounds on the\n\ * reciprocal of the norm of \"projections\" onto left and right\n\ * eigenspaces with respect to the selected cluster.\n\ * 0 < PL, PR <= 1.\n\ * If M = 0 or M = N, PL = PR = 1.\n\ * If IJOB = 0, 2 or 3, PL and PR are not referenced.\n\ *\n\ * DIF (output) DOUBLE PRECISION array, dimension (2).\n\ * If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.\n\ * If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on\n\ * Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based\n\ * estimates of Difu and Difl.\n\ * If M = 0 or N, DIF(1:2) = F-norm([A, B]).\n\ * If IJOB = 0 or 1, DIF is not referenced.\n\ *\n\ * WORK (workspace/output) DOUBLE PRECISION array,\n\ * 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 >= 4*N+16.\n\ * If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)).\n\ * If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)).\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\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK. LIWORK >= 1.\n\ * If IJOB = 1, 2 or 4, LIWORK >= N+6.\n\ * If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6).\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal size of the IWORK array,\n\ * returns this value as the first entry of the IWORK array, and\n\ * no error message related to LIWORK 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\ * =1: Reordering of (A, B) failed because the transformed\n\ * matrix pair (A, B) would be too far from generalized\n\ * Schur form; the problem is very ill-conditioned.\n\ * (A, B) may have been partially reordered.\n\ * If requested, 0 is returned in DIF(*), PL and PR.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * DTGSEN first collects the selected eigenvalues by computing\n\ * orthogonal U and W that move them to the top left corner of (A, B).\n\ * In other words, the selected eigenvalues are the eigenvalues of\n\ * (A11, B11) in:\n\ *\n\ * U'*(A, B)*W = (A11 A12) (B11 B12) n1\n\ * ( 0 A22),( 0 B22) n2\n\ * n1 n2 n1 n2\n\ *\n\ * where N = n1+n2 and U' means the transpose of U. The first n1 columns\n\ * of U and W span the specified pair of left and right eigenspaces\n\ * (deflating subspaces) of (A, B).\n\ *\n\ * If (A, B) has been obtained from the generalized real Schur\n\ * decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the\n\ * reordered generalized real Schur form of (C, D) is given by\n\ *\n\ * (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',\n\ *\n\ * and the first n1 columns of Q*U and Z*W span the corresponding\n\ * deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).\n\ *\n\ * Note that if the selected eigenvalue is sufficiently ill-conditioned,\n\ * then its value may differ significantly from its value before\n\ * reordering.\n\ *\n\ * The reciprocal condition numbers of the left and right eigenspaces\n\ * spanned by the first n1 columns of U and W (or Q*U and Z*W) may\n\ * be returned in DIF(1:2), corresponding to Difu and Difl, resp.\n\ *\n\ * The Difu and Difl are defined as:\n\ *\n\ * Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )\n\ * and\n\ * Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],\n\ *\n\ * where sigma-min(Zu) is the smallest singular value of the\n\ * (2*n1*n2)-by-(2*n1*n2) matrix\n\ *\n\ * Zu = [ kron(In2, A11) -kron(A22', In1) ]\n\ * [ kron(In2, B11) -kron(B22', In1) ].\n\ *\n\ * Here, Inx is the identity matrix of size nx and A22' is the\n\ * transpose of A22. kron(X, Y) is the Kronecker product between\n\ * the matrices X and Y.\n\ *\n\ * When DIF(2) is small, small changes in (A, B) can cause large changes\n\ * in the deflating subspace. An approximate (asymptotic) bound on the\n\ * maximum angular error in the computed deflating subspaces is\n\ *\n\ * EPS * norm((A, B)) / DIF(2),\n\ *\n\ * where EPS is the machine precision.\n\ *\n\ * The reciprocal norm of the projectors on the left and right\n\ * eigenspaces associated with (A11, B11) may be returned in PL and PR.\n\ * They are computed as follows. First we compute L and R so that\n\ * P*(A, B)*Q is block diagonal, where\n\ *\n\ * P = ( I -L ) n1 Q = ( I R ) n1\n\ * ( 0 I ) n2 and ( 0 I ) n2\n\ * n1 n2 n1 n2\n\ *\n\ * and (L, R) is the solution to the generalized Sylvester equation\n\ *\n\ * A11*R - L*A22 = -A12\n\ * B11*R - L*B22 = -B12\n\ *\n\ * Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).\n\ * An approximate (asymptotic) bound on the average absolute error of\n\ * the selected eigenvalues is\n\ *\n\ * EPS * norm((A, B)) / PL.\n\ *\n\ * There are also global error bounds which valid for perturbations up\n\ * to a certain restriction: A lower bound (x) on the smallest\n\ * F-norm(E,F) for which an eigenvalue of (A11, B11) may move and\n\ * coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),\n\ * (i.e. (A + E, B + F), is\n\ *\n\ * x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).\n\ *\n\ * An approximate bound on x can be computed from DIF(1:2), PL and PR.\n\ *\n\ * If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed\n\ * (L', R') and unperturbed (L, R) left and right deflating subspaces\n\ * associated with the selected cluster in the (1,1)-blocks can be\n\ * bounded as\n\ *\n\ * max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))\n\ * max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))\n\ *\n\ * See LAPACK User's Guide section 4.11 or the following references\n\ * for more information.\n\ *\n\ * Note that if the default method for computing the Frobenius-norm-\n\ * based estimate DIF is not wanted (see DLATDF), then the parameter\n\ * IDIFJB (see below) should be changed from 3 to 4 (routine DLATDF\n\ * (IJOB = 2 will be used)). See DTGSYL for more details.\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * References\n\ * ==========\n\ *\n\ * [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n\ * Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n\ * M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n\ * Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n\ *\n\ * [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n\ * Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n\ * Estimation: Theory, Algorithms and Software,\n\ * Report UMINF - 94.04, Department of Computing Science, Umea\n\ * University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working\n\ * Note 87. To appear in Numerical Algorithms, 1996.\n\ *\n\ * [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n\ * for Solving the Generalized Sylvester Equation and Estimating the\n\ * Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n\ * Department of Computing Science, Umea University, S-901 87 Umea,\n\ * Sweden, December 1993, Revised April 1994, Also as LAPACK Working\n\ * Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,\n\ * 1996.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgehrd0000644000175000017500000001135112502223526016446 0ustar uwabamiuwabami--- :name: dgehrd :md5sum: 9dba8e3f6472cee11825e94623b48f41 :category: :subroutine :arguments: - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - n-1 - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGEHRD reduces a real general matrix A to upper Hessenberg form H by\n\ * an orthogonal similarity transformation: Q' * A * Q = H .\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * It is assumed that A is already upper triangular in rows\n\ * and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n\ * set by a previous call to DGEBAL; otherwise they should be\n\ * set to 1 and N respectively. See Further Details.\n\ * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the N-by-N general matrix to be reduced.\n\ * On exit, the upper triangle and the first subdiagonal of A\n\ * are overwritten with the upper Hessenberg matrix H, and the\n\ * elements below the first subdiagonal, with the array TAU,\n\ * represent the orthogonal matrix Q as a product of elementary\n\ * reflectors. See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * TAU (output) DOUBLE PRECISION array, dimension (N-1)\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to\n\ * zero.\n\ *\n\ * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of the array WORK. LWORK >= max(1,N).\n\ * For optimum performance LWORK >= N*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 (ihi-ilo) elementary\n\ * reflectors\n\ *\n\ * Q = H(ilo) H(ilo+1) . . . H(ihi-1).\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) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n\ * exit in A(i+2:ihi,i), and tau in TAU(i).\n\ *\n\ * The contents of A are illustrated by the following example, with\n\ * n = 7, ilo = 2 and ihi = 6:\n\ *\n\ * on entry, on exit,\n\ *\n\ * ( a a a a a a a ) ( a a h h h h a )\n\ * ( a a a a a a ) ( a h h h h a )\n\ * ( a a a a a a ) ( h h h h h h )\n\ * ( a a a a a a ) ( v2 h h h h h )\n\ * ( a a a a a a ) ( v2 v3 h h h h )\n\ * ( a a a a a a ) ( v2 v3 v4 h h h )\n\ * ( a ) ( a )\n\ *\n\ * where a denotes an element of the original matrix A, h denotes a\n\ * modified element of the upper Hessenberg matrix H, and vi denotes an\n\ * element of the vector defining H(i).\n\ *\n\ * This file is a slight modification of LAPACK-3.0's DGEHRD\n\ * subroutine incorporating improvements proposed by Quintana-Orti and\n\ * Van de Geijn (2006). (See DLAHR2.)\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/csptri0000644000175000017500000000471112502223525016516 0ustar uwabamiuwabami--- :name: csptri :md5sum: 11624b714c13369e07cbd0797efbed99 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - work: :type: complex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CSPTRI( UPLO, N, AP, IPIV, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSPTRI computes the inverse of a complex symmetric indefinite matrix\n\ * A in packed storage using the factorization A = U*D*U**T or\n\ * A = L*D*L**T computed by CSPTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n\ * On entry, the block diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L as computed by CSPTRF,\n\ * stored as a packed triangular matrix.\n\ *\n\ * On exit, if INFO = 0, the (symmetric) inverse of the original\n\ * matrix, stored as a packed triangular matrix. The j-th column\n\ * of inv(A) is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;\n\ * if UPLO = 'L',\n\ * AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by CSPTRF.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (N)\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, D(i,i) = 0; the matrix is singular and its\n\ * inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlaqr20000644000175000017500000002002212502223526016417 0ustar uwabamiuwabami--- :name: zlaqr2 :md5sum: ffeac35e8baa8da04e2b19326ee08e26 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ktop: :type: integer :intent: input - kbot: :type: integer :intent: input - nw: :type: integer :intent: input - h: :type: doublecomplex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: doublecomplex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - ns: :type: integer :intent: output - nd: :type: integer :intent: output - sh: :type: doublecomplex :intent: output :dims: - MAX(1,kbot) - v: :type: doublecomplex :intent: workspace :dims: - ldv - MAX(1,nw) - ldv: :type: integer :intent: input - nh: :type: integer :intent: input - t: :type: doublecomplex :intent: workspace :dims: - ldv - MAX(1,nw) - ldt: :type: integer :intent: input - nv: :type: integer :intent: input - wv: :type: doublecomplex :intent: workspace :dims: - ldv - MAX(1,nw) - ldwv: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*nw :substitutions: ldwv: nw ldt: nw ldv: nw :fortran_help: " SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n\ * This subroutine is identical to ZLAQR3 except that it avoids\n\ * recursion by calling ZLAHQR instead of ZLAQR4.\n\ *\n\ *\n\ * ******************************************************************\n\ * Aggressive early deflation:\n\ *\n\ * This subroutine accepts as input an upper Hessenberg matrix\n\ * H and performs an unitary similarity transformation\n\ * designed to detect and deflate fully converged eigenvalues from\n\ * a trailing principal submatrix. On output H has been over-\n\ * written by a new Hessenberg matrix that is a perturbation of\n\ * an unitary similarity transformation of H. It is to be\n\ * hoped that the final version of H has many zero subdiagonal\n\ * entries.\n\ *\n\ * ******************************************************************\n\n\ * WANTT (input) LOGICAL\n\ * If .TRUE., then the Hessenberg matrix H is fully updated\n\ * so that the triangular Schur factor may be\n\ * computed (in cooperation with the calling subroutine).\n\ * If .FALSE., then only enough of H is updated to preserve\n\ * the eigenvalues.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * If .TRUE., then the unitary matrix Z is updated so\n\ * so that the unitary Schur factor may be computed\n\ * (in cooperation with the calling subroutine).\n\ * If .FALSE., then Z is not referenced.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H and (if WANTZ is .TRUE.) the\n\ * order of the unitary matrix Z.\n\ *\n\ * KTOP (input) INTEGER\n\ * It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n\ * KBOT and KTOP together determine an isolated block\n\ * along the diagonal of the Hessenberg matrix.\n\ *\n\ * KBOT (input) INTEGER\n\ * It is assumed without a check that either\n\ * KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together\n\ * determine an isolated block along the diagonal of the\n\ * Hessenberg matrix.\n\ *\n\ * NW (input) INTEGER\n\ * Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).\n\ *\n\ * H (input/output) COMPLEX*16 array, dimension (LDH,N)\n\ * On input the initial N-by-N section of H stores the\n\ * Hessenberg matrix undergoing aggressive early deflation.\n\ * On output H has been transformed by a unitary\n\ * similarity transformation, perturbed, and the returned\n\ * to Hessenberg form that (it is to be hoped) has some\n\ * zero subdiagonal entries.\n\ *\n\ * LDH (input) integer\n\ * Leading dimension of H just as declared in the calling\n\ * subroutine. N .LE. LDH\n\ *\n\ * ILOZ (input) INTEGER\n\ * IHIZ (input) INTEGER\n\ * Specify the rows of Z to which transformations must be\n\ * applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n\ *\n\ * Z (input/output) COMPLEX*16 array, dimension (LDZ,N)\n\ * IF WANTZ is .TRUE., then on output, the unitary\n\ * similarity transformation mentioned above has been\n\ * accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n\ * If WANTZ is .FALSE., then Z is unreferenced.\n\ *\n\ * LDZ (input) integer\n\ * The leading dimension of Z just as declared in the\n\ * calling subroutine. 1 .LE. LDZ.\n\ *\n\ * NS (output) integer\n\ * The number of unconverged (ie approximate) eigenvalues\n\ * returned in SR and SI that may be used as shifts by the\n\ * calling subroutine.\n\ *\n\ * ND (output) integer\n\ * The number of converged eigenvalues uncovered by this\n\ * subroutine.\n\ *\n\ * SH (output) COMPLEX*16 array, dimension KBOT\n\ * On output, approximate eigenvalues that may\n\ * be used for shifts are stored in SH(KBOT-ND-NS+1)\n\ * through SR(KBOT-ND). Converged eigenvalues are\n\ * stored in SH(KBOT-ND+1) through SH(KBOT).\n\ *\n\ * V (workspace) COMPLEX*16 array, dimension (LDV,NW)\n\ * An NW-by-NW work array.\n\ *\n\ * LDV (input) integer scalar\n\ * The leading dimension of V just as declared in the\n\ * calling subroutine. NW .LE. LDV\n\ *\n\ * NH (input) integer scalar\n\ * The number of columns of T. NH.GE.NW.\n\ *\n\ * T (workspace) COMPLEX*16 array, dimension (LDT,NW)\n\ *\n\ * LDT (input) integer\n\ * The leading dimension of T just as declared in the\n\ * calling subroutine. NW .LE. LDT\n\ *\n\ * NV (input) integer\n\ * The number of rows of work array WV available for\n\ * workspace. NV.GE.NW.\n\ *\n\ * WV (workspace) COMPLEX*16 array, dimension (LDWV,NW)\n\ *\n\ * LDWV (input) integer\n\ * The leading dimension of W just as declared in the\n\ * calling subroutine. NW .LE. LDV\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension LWORK.\n\ * On exit, WORK(1) is set to an estimate of the optimal value\n\ * of LWORK for the given values of N, NW, KTOP and KBOT.\n\ *\n\ * LWORK (input) integer\n\ * The dimension of the work array WORK. LWORK = 2*NW\n\ * suffices, but greater efficiency may result from larger\n\ * values of LWORK.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; ZLAQR2\n\ * only estimates the optimal workspace size for the given\n\ * values of N, NW, KTOP and KBOT. The estimate is returned\n\ * in WORK(1). No error message related to LWORK is issued\n\ * by XERBLA. Neither H nor Z are accessed.\n\ *\n\n\ * ================================================================\n\ * Based on contributions by\n\ * Karen Braman and Ralph Byers, Department of Mathematics,\n\ * University of Kansas, USA\n\ *\n\ * ================================================================\n" ruby-lapack-1.7.2/dev/defs/zla_gbamv0000644000175000017500000001214312502223526017153 0ustar uwabamiuwabami--- :name: zla_gbamv :md5sum: 9e790ed0e59a002f6667b528896bf632 :category: :subroutine :arguments: - trans: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - alpha: :type: doublereal :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - x: :type: doublereal :intent: input :dims: - "trans == ilatrans_(\"N\") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )" - incx: :type: integer :intent: input - beta: :type: doublereal :intent: input - y: :type: doublereal :intent: input/output :dims: - "trans == ilatrans_(\"N\") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )" - incy: :type: integer :intent: input :substitutions: ldab: MAX(1, m) :fortran_help: " SUBROUTINE ZLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, INCX, BETA, Y, INCY )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLA_GBAMV performs one of the matrix-vector operations\n\ *\n\ * y := alpha*abs(A)*abs(x) + beta*abs(y),\n\ * or y := alpha*abs(A)'*abs(x) + beta*abs(y),\n\ *\n\ * where alpha and beta are scalars, x and y are vectors and A is an\n\ * m by n matrix.\n\ *\n\ * This function is primarily used in calculating error bounds.\n\ * To protect against underflow during evaluation, components in\n\ * the resulting vector are perturbed away from zero by (N+1)\n\ * times the underflow threshold. To prevent unnecessarily large\n\ * errors for block-structure embedded in general matrices,\n\ * \"symbolically\" zero components are not perturbed. A zero\n\ * entry is considered \"symbolic\" if all multiplications involved\n\ * in computing that entry have at least one zero multiplicand.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * TRANS (input) INTEGER\n\ * On entry, TRANS specifies the operation to be performed as\n\ * follows:\n\ *\n\ * BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y)\n\ * BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n\ * BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n\ *\n\ * Unchanged on exit.\n\ *\n\ * M (input) INTEGER\n\ * On entry, M specifies the number of rows of the matrix A.\n\ * M must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the number of columns of the matrix A.\n\ * N must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * ALPHA - DOUBLE PRECISION\n\ * On entry, ALPHA specifies the scalar alpha.\n\ * Unchanged on exit.\n\ *\n\ * A - DOUBLE PRECISION array of DIMENSION ( LDA, n )\n\ * Before entry, the leading m by n part of the array A must\n\ * contain the matrix of coefficients.\n\ * Unchanged on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * On entry, LDA specifies the first dimension of A as declared\n\ * in the calling (sub) program. LDA must be at least\n\ * max( 1, m ).\n\ * Unchanged on exit.\n\ *\n\ * X (input) DOUBLE PRECISION array, dimension\n\ * ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n\ * and at least\n\ * ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n\ * Before entry, the incremented array X must contain the\n\ * vector x.\n\ * Unchanged on exit.\n\ *\n\ * INCX (input) INTEGER\n\ * On entry, INCX specifies the increment for the elements of\n\ * X. INCX must not be zero.\n\ * Unchanged on exit.\n\ *\n\ * BETA - DOUBLE PRECISION\n\ * On entry, BETA specifies the scalar beta. When BETA is\n\ * supplied as zero then Y need not be set on input.\n\ * Unchanged on exit.\n\ *\n\ * Y (input/output) DOUBLE PRECISION array, dimension\n\ * ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n\ * and at least\n\ * ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n\ * Before entry with BETA non-zero, the incremented array Y\n\ * must contain the vector y. On exit, Y is overwritten by the\n\ * updated vector y.\n\ *\n\ * INCY (input) INTEGER\n\ * On entry, INCY specifies the increment for the elements of\n\ * Y. INCY must not be zero.\n\ * Unchanged on exit.\n\ *\n\ *\n\ * Level 2 Blas routine.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssysvx0000644000175000017500000002334312502223526016574 0ustar uwabamiuwabami--- :name: ssysvx :md5sum: 04e4eb2438011793b7546b2ee981c6e3 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE SSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSYSVX uses the diagonal pivoting factorization to compute the\n\ * solution to a real system of linear equations A * X = B,\n\ * where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n\ * matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'N', the diagonal pivoting method is used to factor A.\n\ * The form of the factorization is\n\ * A = U * D * U**T, if UPLO = 'U', or\n\ * A = L * D * L**T, if UPLO = 'L',\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, and D is symmetric and block diagonal with\n\ * 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\ * 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n\ * returns with INFO = i. Otherwise, the factored form of A is used\n\ * to estimate the condition number of the matrix A. If the\n\ * reciprocal of the condition number is less than machine precision,\n\ * INFO = N+1 is returned as a warning, but the routine still goes on\n\ * to solve for X and compute error bounds as described below.\n\ *\n\ * 3. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 4. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of A has been\n\ * supplied on entry.\n\ * = 'F': On entry, AF and IPIV contain the factored form of\n\ * A. AF and IPIV will not be modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular part\n\ * of the matrix A, and the strictly lower triangular part of A\n\ * is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of A contains the lower triangular part of\n\ * the matrix A, and the strictly upper triangular part of A is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input or output) REAL array, dimension (LDAF,N)\n\ * If FACT = 'F', then AF is an input argument and on entry\n\ * contains the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L from the factorization\n\ * A = U*D*U**T or A = L*D*L**T as computed by SSYTRF.\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L from the factorization\n\ * A = U*D*U**T or A = L*D*L**T.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains details of the interchanges and the block structure\n\ * of D, as determined by SSYTRF.\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains details of the interchanges and the block structure\n\ * of D, as determined by SSYTRF.\n\ *\n\ * B (input) REAL array, dimension (LDB,NRHS)\n\ * The N-by-NRHS right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) REAL array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A. If RCOND is less than the machine precision (in\n\ * particular, if RCOND = 0), the matrix is singular to working\n\ * precision. This condition is indicated by a return code of\n\ * INFO > 0.\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of WORK. LWORK >= max(1,3*N), and for best\n\ * performance, when FACT = 'N', LWORK >= max(1,3*N,N*NB), where\n\ * NB is the optimal blocksize for SSYTRF.\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\ * IWORK (workspace) INTEGER array, dimension (N)\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, and i is\n\ * <= N: D(i,i) is exactly zero. The factorization\n\ * has been completed but the factor D is exactly\n\ * singular, so the solution and error bounds could\n\ * not be computed. RCOND = 0 is returned.\n\ * = N+1: D is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slartg0000644000175000017500000000342212502223526016505 0ustar uwabamiuwabami--- :name: slartg :md5sum: 52b75639a9de491257810faa309579ab :category: :subroutine :arguments: - f: :type: real :intent: input - g: :type: real :intent: input - cs: :type: real :intent: output - sn: :type: real :intent: output - r: :type: real :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLARTG( F, G, CS, SN, R )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLARTG generate a plane rotation so that\n\ *\n\ * [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1.\n\ * [ -SN CS ] [ G ] [ 0 ]\n\ *\n\ * This is a slower, more accurate version of the BLAS1 routine SROTG,\n\ * with the following other differences:\n\ * F and G are unchanged on return.\n\ * If G=0, then CS=1 and SN=0.\n\ * If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any\n\ * floating point operations (saves work in SBDSQR when\n\ * there are zeros on the diagonal).\n\ *\n\ * If F exceeds G in magnitude, CS will be positive.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * F (input) REAL\n\ * The first component of vector to be rotated.\n\ *\n\ * G (input) REAL\n\ * The second component of vector to be rotated.\n\ *\n\ * CS (output) REAL\n\ * The cosine of the rotation.\n\ *\n\ * SN (output) REAL\n\ * The sine of the rotation.\n\ *\n\ * R (output) REAL\n\ * The nonzero component of the rotated vector.\n\ *\n\ * This version has a few statements commented out for thread safety\n\ * (machine parameters are computed on each entry). 10 feb 03, SJH.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgeequ0000644000175000017500000000642012502223526016503 0ustar uwabamiuwabami--- :name: sgeequ :md5sum: 5b2618a0032479b4096d2866a08609c9 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - r: :type: real :intent: output :dims: - m - c: :type: real :intent: output :dims: - n - rowcnd: :type: real :intent: output - colcnd: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE SGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGEEQU computes row and column scalings intended to equilibrate an\n\ * M-by-N matrix A and reduce its condition number. R returns the row\n\ * scale factors and C the column scale factors, chosen to try to make\n\ * the largest element in each row and column of the matrix B with\n\ * elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n\ *\n\ * R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n\ * number and BIGNUM = largest safe number. Use of these scaling\n\ * factors is not guaranteed to reduce the condition number of A but\n\ * works well in practice.\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) REAL array, dimension (LDA,N)\n\ * The M-by-N matrix whose equilibration factors are\n\ * to be computed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * R (output) REAL array, dimension (M)\n\ * If INFO = 0 or INFO > M, R contains the row scale factors\n\ * for A.\n\ *\n\ * C (output) REAL array, dimension (N)\n\ * If INFO = 0, C contains the column scale factors for A.\n\ *\n\ * ROWCND (output) REAL\n\ * If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n\ * smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n\ * AMAX is neither too large nor too small, it is not worth\n\ * scaling by R.\n\ *\n\ * COLCND (output) REAL\n\ * If INFO = 0, COLCND contains the ratio of the smallest\n\ * C(i) to the largest C(i). If COLCND >= 0.1, it is not\n\ * worth scaling by C.\n\ *\n\ * AMAX (output) REAL\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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, and i is\n\ * <= M: the i-th row of A is exactly zero\n\ * > M: the (i-M)-th column of A is exactly zero\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgesv0000644000175000017500000000605712502223525016326 0ustar uwabamiuwabami--- :name: cgesv :md5sum: 261cd82623a43e575e6bd00ede93a7d3 :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGESV computes the solution to a complex system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n\ *\n\ * The LU decomposition with partial pivoting and row interchanges is\n\ * used to factor A as\n\ * A = P * L * U,\n\ * where P is a permutation matrix, L is unit lower triangular, and U is\n\ * upper triangular. The factored form of A is then used to solve the\n\ * system of equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the N-by-N coefficient matrix A.\n\ * On exit, the factors L and U from the factorization\n\ * A = P*L*U; the unit diagonal elements of L are not stored.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * The pivot indices that define the permutation matrix P;\n\ * row i of the matrix was interchanged with row IPIV(i).\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS matrix of right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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, U(i,i) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, so the solution could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. External Subroutines ..\n EXTERNAL CGETRF, CGETRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slar1v0000644000175000017500000001450312502223526016423 0ustar uwabamiuwabami--- :name: slar1v :md5sum: 1fc0a916850c2048501bd4c9f734d5d1 :category: :subroutine :arguments: - n: :type: integer :intent: input - b1: :type: integer :intent: input - bn: :type: integer :intent: input - lambda: :type: real :intent: input - d: :type: real :intent: input :dims: - n - l: :type: real :intent: input :dims: - n-1 - ld: :type: real :intent: input :dims: - n-1 - lld: :type: real :intent: input :dims: - n-1 - pivmin: :type: real :intent: input - gaptol: :type: real :intent: input - z: :type: real :intent: input/output :dims: - n - wantnc: :type: logical :intent: input - negcnt: :type: integer :intent: output - ztz: :type: real :intent: output - mingma: :type: real :intent: output - r: :type: integer :intent: input/output - isuppz: :type: integer :intent: output :dims: - "2" - nrminv: :type: real :intent: output - resid: :type: real :intent: output - rqcorr: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 4*n :substitutions: {} :fortran_help: " SUBROUTINE SLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD, PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, R, ISUPPZ, NRMINV, RESID, RQCORR, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAR1V computes the (scaled) r-th column of the inverse of\n\ * the sumbmatrix in rows B1 through BN of the tridiagonal matrix\n\ * L D L^T - sigma I. When sigma is close to an eigenvalue, the\n\ * computed vector is an accurate eigenvector. Usually, r corresponds\n\ * to the index where the eigenvector is largest in magnitude.\n\ * The following steps accomplish this computation :\n\ * (a) Stationary qd transform, L D L^T - sigma I = L(+) D(+) L(+)^T,\n\ * (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T,\n\ * (c) Computation of the diagonal elements of the inverse of\n\ * L D L^T - sigma I by combining the above transforms, and choosing\n\ * r as the index where the diagonal of the inverse is (one of the)\n\ * largest in magnitude.\n\ * (d) Computation of the (scaled) r-th column of the inverse using the\n\ * twisted factorization obtained by combining the top part of the\n\ * the stationary and the bottom part of the progressive transform.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix L D L^T.\n\ *\n\ * B1 (input) INTEGER\n\ * First index of the submatrix of L D L^T.\n\ *\n\ * BN (input) INTEGER\n\ * Last index of the submatrix of L D L^T.\n\ *\n\ * LAMBDA (input) REAL \n\ * The shift. In order to compute an accurate eigenvector,\n\ * LAMBDA should be a good approximation to an eigenvalue\n\ * of L D L^T.\n\ *\n\ * L (input) REAL array, dimension (N-1)\n\ * The (n-1) subdiagonal elements of the unit bidiagonal matrix\n\ * L, in elements 1 to N-1.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The n diagonal elements of the diagonal matrix D.\n\ *\n\ * LD (input) REAL array, dimension (N-1)\n\ * The n-1 elements L(i)*D(i).\n\ *\n\ * LLD (input) REAL array, dimension (N-1)\n\ * The n-1 elements L(i)*L(i)*D(i).\n\ *\n\ * PIVMIN (input) REAL \n\ * The minimum pivot in the Sturm sequence.\n\ *\n\ * GAPTOL (input) REAL \n\ * Tolerance that indicates when eigenvector entries are negligible\n\ * w.r.t. their contribution to the residual.\n\ *\n\ * Z (input/output) REAL array, dimension (N)\n\ * On input, all entries of Z must be set to 0.\n\ * On output, Z contains the (scaled) r-th column of the\n\ * inverse. The scaling is such that Z(R) equals 1.\n\ *\n\ * WANTNC (input) LOGICAL\n\ * Specifies whether NEGCNT has to be computed.\n\ *\n\ * NEGCNT (output) INTEGER\n\ * If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin\n\ * in the matrix factorization L D L^T, and NEGCNT = -1 otherwise.\n\ *\n\ * ZTZ (output) REAL \n\ * The square of the 2-norm of Z.\n\ *\n\ * MINGMA (output) REAL \n\ * The reciprocal of the largest (in magnitude) diagonal\n\ * element of the inverse of L D L^T - sigma I.\n\ *\n\ * R (input/output) INTEGER\n\ * The twist index for the twisted factorization used to\n\ * compute Z.\n\ * On input, 0 <= R <= N. If R is input as 0, R is set to\n\ * the index where (L D L^T - sigma I)^{-1} is largest\n\ * in magnitude. If 1 <= R <= N, R is unchanged.\n\ * On output, R contains the twist index used to compute Z.\n\ * Ideally, R designates the position of the maximum entry in the\n\ * eigenvector.\n\ *\n\ * ISUPPZ (output) INTEGER array, dimension (2)\n\ * The support of the vector in Z, i.e., the vector Z is\n\ * nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ).\n\ *\n\ * NRMINV (output) REAL \n\ * NRMINV = 1/SQRT( ZTZ )\n\ *\n\ * RESID (output) REAL \n\ * The residual of the FP vector.\n\ * RESID = ABS( MINGMA )/SQRT( ZTZ )\n\ *\n\ * RQCORR (output) REAL \n\ * The Rayleigh Quotient correction to LAMBDA.\n\ * RQCORR = MINGMA*TMP\n\ *\n\ * WORK (workspace) REAL array, dimension (4*N)\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Beresford Parlett, University of California, Berkeley, USA\n\ * Jim Demmel, University of California, Berkeley, USA\n\ * Inderjit Dhillon, University of Texas, Austin, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, University of California, Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/stfsm0000644000175000017500000002107012502223526016344 0ustar uwabamiuwabami--- :name: stfsm :md5sum: 1dcdb7177f893a4f654c7e71cf9bfb56 :category: :subroutine :arguments: - transr: :type: char :intent: input - side: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: real :intent: input - a: :type: real :intent: input :dims: - nt - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input :substitutions: ldb: MAX(1,m) :fortran_help: " SUBROUTINE STFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, B, LDB )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Level 3 BLAS like routine for A in RFP Format.\n\ *\n\ * STFSM solves the matrix equation\n\ *\n\ * op( A )*X = alpha*B or X*op( A ) = alpha*B\n\ *\n\ * where alpha is a scalar, X and B are m by n matrices, A is a unit, or\n\ * non-unit, upper or lower triangular matrix and op( A ) is one of\n\ *\n\ * op( A ) = A or op( A ) = A'.\n\ *\n\ * A is in Rectangular Full Packed (RFP) Format.\n\ *\n\ * The matrix X is overwritten on B.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': The Normal Form of RFP A is stored;\n\ * = 'T': The Transpose Form of RFP A is stored.\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * On entry, SIDE specifies whether op( A ) appears on the left\n\ * or right of X as follows:\n\ *\n\ * SIDE = 'L' or 'l' op( A )*X = alpha*B.\n\ *\n\ * SIDE = 'R' or 'r' X*op( A ) = alpha*B.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * On entry, UPLO specifies whether the RFP matrix A came from\n\ * an upper or lower triangular matrix as follows:\n\ * UPLO = 'U' or 'u' RFP A came from an upper triangular matrix\n\ * UPLO = 'L' or 'l' RFP A came from a lower triangular matrix\n\ *\n\ * Unchanged on exit.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * On entry, TRANS specifies the form of op( A ) to be used\n\ * in the matrix multiplication as follows:\n\ *\n\ * TRANS = 'N' or 'n' op( A ) = A.\n\ *\n\ * TRANS = 'T' or 't' op( A ) = A'.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * On entry, DIAG specifies whether or not RFP A is unit\n\ * triangular as follows:\n\ *\n\ * DIAG = 'U' or 'u' A is assumed to be unit triangular.\n\ *\n\ * DIAG = 'N' or 'n' A is not assumed to be unit\n\ * triangular.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * M (input) INTEGER\n\ * On entry, M specifies the number of rows of B. M must be at\n\ * least zero.\n\ * Unchanged on exit.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the number of columns of B. N must be\n\ * at least zero.\n\ * Unchanged on exit.\n\ *\n\ * ALPHA (input) REAL\n\ * On entry, ALPHA specifies the scalar alpha. When alpha is\n\ * zero then A is not referenced and B need not be set before\n\ * entry.\n\ * Unchanged on exit.\n\ *\n\ * A (input) REAL array, dimension (NT)\n\ * NT = N*(N+1)/2. On entry, the matrix A in RFP Format.\n\ * RFP Format is described by TRANSR, UPLO and N as follows:\n\ * If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;\n\ * K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If\n\ * TRANSR = 'T' then RFP is the transpose of RFP A as\n\ * defined when TRANSR = 'N'. The contents of RFP A are defined\n\ * by UPLO as follows: If UPLO = 'U' the RFP A contains the NT\n\ * elements of upper packed A either in normal or\n\ * transpose Format. If UPLO = 'L' the RFP A contains\n\ * the NT elements of lower packed A either in normal or\n\ * transpose Format. The LDA of RFP A is (N+1)/2 when\n\ * TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is\n\ * even and is N when is odd.\n\ * See the Note below for more details. Unchanged on exit.\n\ *\n\ * B (input/output) REAL array, DIMENSION (LDB,N)\n\ * Before entry, the leading m by n part of the array B must\n\ * contain the right-hand side matrix B, and on exit is\n\ * overwritten by the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * On entry, LDB specifies the first dimension of B as declared\n\ * in the calling (sub) program. LDB must be at least\n\ * max( 1, m ).\n\ * Unchanged on exit.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * We first consider Rectangular Full Packed (RFP) Format when N is\n\ * even. We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * the transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * the transpose of the last three columns of AP lower.\n\ * This covers the case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 04 05 33 43 53\n\ * 13 14 15 00 44 54\n\ * 23 24 25 10 11 55\n\ * 33 34 35 20 21 22\n\ * 00 44 45 30 31 32\n\ * 01 11 55 40 41 42\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We then consider Rectangular Full Packed (RFP) Format when N is\n\ * odd. We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * the transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * the transpose of the last two columns of AP lower.\n\ * This covers the case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 03 04 00 33 43\n\ * 12 13 14 10 11 44\n\ * 22 23 24 20 21 22\n\ * 00 33 34 30 31 32\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * Reference\n\ * =========\n\ *\n\ * =====================================================================\n\ *\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cgeevx0000644000175000017500000002274412502223525016501 0ustar uwabamiuwabami--- :name: cgeevx :md5sum: 9f6e8ef099565cc5fbc0ff1866d22dcc :category: :subroutine :arguments: - balanc: :type: char :intent: input - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - w: :type: complex :intent: output :dims: - n - vl: :type: complex :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: complex :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - scale: :type: real :intent: output :dims: - n - abnrm: :type: real :intent: output - rconde: :type: real :intent: output :dims: - n - rcondv: :type: real :intent: output :dims: - n - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(lsame_(&sense,\"N\")||lsame_(&sense,\"E\")) ? 2*n : (lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? n*n+2*n : 0" - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " SUBROUTINE CGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, WORK, LWORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGEEVX computes for an N-by-N complex nonsymmetric matrix A, the\n\ * eigenvalues and, optionally, the left and/or right eigenvectors.\n\ *\n\ * Optionally also, it computes a balancing transformation to improve\n\ * the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n\ * SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues\n\ * (RCONDE), and reciprocal condition numbers for the right\n\ * eigenvectors (RCONDV).\n\ *\n\ * The right eigenvector v(j) of A satisfies\n\ * A * v(j) = lambda(j) * v(j)\n\ * where lambda(j) is its eigenvalue.\n\ * The left eigenvector u(j) of A satisfies\n\ * u(j)**H * A = lambda(j) * u(j)**H\n\ * where u(j)**H denotes the conjugate transpose of u(j).\n\ *\n\ * The computed eigenvectors are normalized to have Euclidean norm\n\ * equal to 1 and largest component real.\n\ *\n\ * Balancing a matrix means permuting the rows and columns to make it\n\ * more nearly upper triangular, and applying a diagonal similarity\n\ * transformation D * A * D**(-1), where D is a diagonal matrix, to\n\ * make its rows and columns closer in norm and the condition numbers\n\ * of its eigenvalues and eigenvectors smaller. The computed\n\ * reciprocal condition numbers correspond to the balanced matrix.\n\ * Permuting rows and columns will not change the condition numbers\n\ * (in exact arithmetic) but diagonal scaling will. For further\n\ * explanation of balancing, see section 4.10.2 of the LAPACK\n\ * Users' Guide.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * BALANC (input) CHARACTER*1\n\ * Indicates how the input matrix should be diagonally scaled\n\ * and/or permuted to improve the conditioning of its\n\ * eigenvalues.\n\ * = 'N': Do not diagonally scale or permute;\n\ * = 'P': Perform permutations to make the matrix more nearly\n\ * upper triangular. Do not diagonally scale;\n\ * = 'S': Diagonally scale the matrix, ie. replace A by\n\ * D*A*D**(-1), where D is a diagonal matrix chosen\n\ * to make the rows and columns of A more equal in\n\ * norm. Do not permute;\n\ * = 'B': Both diagonally scale and permute A.\n\ *\n\ * Computed reciprocal condition numbers will be for the matrix\n\ * after balancing and/or permuting. Permuting does not change\n\ * condition numbers (in exact arithmetic), but balancing does.\n\ *\n\ * JOBVL (input) CHARACTER*1\n\ * = 'N': left eigenvectors of A are not computed;\n\ * = 'V': left eigenvectors of A are computed.\n\ * If SENSE = 'E' or 'B', JOBVL must = 'V'.\n\ *\n\ * JOBVR (input) CHARACTER*1\n\ * = 'N': right eigenvectors of A are not computed;\n\ * = 'V': right eigenvectors of A are computed.\n\ * If SENSE = 'E' or 'B', JOBVR must = 'V'.\n\ *\n\ * SENSE (input) CHARACTER*1\n\ * Determines which reciprocal condition numbers are computed.\n\ * = 'N': None are computed;\n\ * = 'E': Computed for eigenvalues only;\n\ * = 'V': Computed for right eigenvectors only;\n\ * = 'B': Computed for eigenvalues and right eigenvectors.\n\ *\n\ * If SENSE = 'E' or 'B', both left and right eigenvectors\n\ * must also be computed (JOBVL = 'V' and JOBVR = 'V').\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ * On exit, A has been overwritten. If JOBVL = 'V' or\n\ * JOBVR = 'V', A contains the Schur form of the balanced \n\ * version of the matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * W (output) COMPLEX array, dimension (N)\n\ * W contains the computed eigenvalues.\n\ *\n\ * VL (output) COMPLEX array, dimension (LDVL,N)\n\ * If JOBVL = 'V', the left eigenvectors u(j) are stored one\n\ * after another in the columns of VL, in the same order\n\ * as their eigenvalues.\n\ * If JOBVL = 'N', VL is not referenced.\n\ * u(j) = VL(:,j), the j-th column of VL.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the array VL. LDVL >= 1; if\n\ * JOBVL = 'V', LDVL >= N.\n\ *\n\ * VR (output) COMPLEX array, dimension (LDVR,N)\n\ * If JOBVR = 'V', the right eigenvectors v(j) are stored one\n\ * after another in the columns of VR, in the same order\n\ * as their eigenvalues.\n\ * If JOBVR = 'N', VR is not referenced.\n\ * v(j) = VR(:,j), the j-th column of VR.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the array VR. LDVR >= 1; if\n\ * JOBVR = 'V', LDVR >= N.\n\ *\n\ * ILO (output) INTEGER\n\ * IHI (output) INTEGER\n\ * ILO and IHI are integer values determined when A was\n\ * balanced. The balanced A(i,j) = 0 if I > J and\n\ * J = 1,...,ILO-1 or I = IHI+1,...,N.\n\ *\n\ * SCALE (output) REAL array, dimension (N)\n\ * Details of the permutations and scaling factors applied\n\ * when balancing A. If P(j) is the index of the row and column\n\ * interchanged with row and column j, and D(j) is the scaling\n\ * factor applied to row and column j, then\n\ * SCALE(J) = P(J), for J = 1,...,ILO-1\n\ * = D(J), for J = ILO,...,IHI\n\ * = P(J) for J = IHI+1,...,N.\n\ * The order in which the interchanges are made is N to IHI+1,\n\ * then 1 to ILO-1.\n\ *\n\ * ABNRM (output) REAL\n\ * The one-norm of the balanced matrix (the maximum\n\ * of the sum of absolute values of elements of any column).\n\ *\n\ * RCONDE (output) REAL array, dimension (N)\n\ * RCONDE(j) is the reciprocal condition number of the j-th\n\ * eigenvalue.\n\ *\n\ * RCONDV (output) REAL array, dimension (N)\n\ * RCONDV(j) is the reciprocal condition number of the j-th\n\ * right eigenvector.\n\ *\n\ * WORK (workspace/output) COMPLEX 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. If SENSE = 'N' or 'E',\n\ * LWORK >= max(1,2*N), and if SENSE = 'V' or 'B',\n\ * LWORK >= N*N+2*N.\n\ * For good performance, LWORK must generally be larger.\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\ * RWORK (workspace) REAL array, dimension (2*N)\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 QR algorithm failed to compute all the\n\ * eigenvalues, and no eigenvectors or condition numbers\n\ * have been computed; elements 1:ILO-1 and i+1:N of W\n\ * contain eigenvalues which have converged.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ztrsen0000644000175000017500000002105712502223526016542 0ustar uwabamiuwabami--- :name: ztrsen :md5sum: 7f40c848c34c5c1a032580d2374319f6 :category: :subroutine :arguments: - job: :type: char :intent: input - compq: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - t: :type: doublecomplex :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - q: :type: doublecomplex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - w: :type: doublecomplex :intent: output :dims: - n - m: :type: integer :intent: output - s: :type: doublereal :intent: output - sep: :type: doublereal :intent: output - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&job,\"N\") ? n : lsame_(&job,\"E\") ? m*(n-m) : (lsame_(&job,\"V\")||lsame_(&job,\"B\")) ? 2*m*(n-m) : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S, SEP, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTRSEN reorders the Schur factorization of a complex matrix\n\ * A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in\n\ * the leading positions on the diagonal of the upper triangular matrix\n\ * T, and the leading columns of Q form an orthonormal basis of the\n\ * corresponding right invariant subspace.\n\ *\n\ * Optionally the routine computes the reciprocal condition numbers of\n\ * the cluster of eigenvalues and/or the invariant subspace.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * Specifies whether condition numbers are required for the\n\ * cluster of eigenvalues (S) or the invariant subspace (SEP):\n\ * = 'N': none;\n\ * = 'E': for eigenvalues only (S);\n\ * = 'V': for invariant subspace only (SEP);\n\ * = 'B': for both eigenvalues and invariant subspace (S and\n\ * SEP).\n\ *\n\ * COMPQ (input) CHARACTER*1\n\ * = 'V': update the matrix Q of Schur vectors;\n\ * = 'N': do not update Q.\n\ *\n\ * SELECT (input) LOGICAL array, dimension (N)\n\ * SELECT specifies the eigenvalues in the selected cluster. To\n\ * select the j-th eigenvalue, SELECT(j) must be set to .TRUE..\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix T. N >= 0.\n\ *\n\ * T (input/output) COMPLEX*16 array, dimension (LDT,N)\n\ * On entry, the upper triangular matrix T.\n\ * On exit, T is overwritten by the reordered matrix T, with the\n\ * selected eigenvalues as the leading diagonal elements.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= max(1,N).\n\ *\n\ * Q (input/output) COMPLEX*16 array, dimension (LDQ,N)\n\ * On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n\ * On exit, if COMPQ = 'V', Q has been postmultiplied by the\n\ * unitary transformation matrix which reorders T; the leading M\n\ * columns of Q form an orthonormal basis for the specified\n\ * invariant subspace.\n\ * If COMPQ = 'N', Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q.\n\ * LDQ >= 1; and if COMPQ = 'V', LDQ >= N.\n\ *\n\ * W (output) COMPLEX*16 array, dimension (N)\n\ * The reordered eigenvalues of T, in the same order as they\n\ * appear on the diagonal of T.\n\ *\n\ * M (output) INTEGER\n\ * The dimension of the specified invariant subspace.\n\ * 0 <= M <= N.\n\ *\n\ * S (output) DOUBLE PRECISION\n\ * If JOB = 'E' or 'B', S is a lower bound on the reciprocal\n\ * condition number for the selected cluster of eigenvalues.\n\ * S cannot underestimate the true reciprocal condition number\n\ * by more than a factor of sqrt(N). If M = 0 or N, S = 1.\n\ * If JOB = 'N' or 'V', S is not referenced.\n\ *\n\ * SEP (output) DOUBLE PRECISION\n\ * If JOB = 'V' or 'B', SEP is the estimated reciprocal\n\ * condition number of the specified invariant subspace. If\n\ * M = 0 or N, SEP = norm(T).\n\ * If JOB = 'N' or 'E', SEP is not referenced.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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\ * If JOB = 'N', LWORK >= 1;\n\ * if JOB = 'E', LWORK = max(1,M*(N-M));\n\ * if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).\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\ * ZTRSEN first collects the selected eigenvalues by computing a unitary\n\ * transformation Z to move them to the top left corner of T. In other\n\ * words, the selected eigenvalues are the eigenvalues of T11 in:\n\ *\n\ * Z'*T*Z = ( T11 T12 ) n1\n\ * ( 0 T22 ) n2\n\ * n1 n2\n\ *\n\ * where N = n1+n2 and Z' means the conjugate transpose of Z. The first\n\ * n1 columns of Z span the specified invariant subspace of T.\n\ *\n\ * If T has been obtained from the Schur factorization of a matrix\n\ * A = Q*T*Q', then the reordered Schur factorization of A is given by\n\ * A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span the\n\ * corresponding invariant subspace of A.\n\ *\n\ * The reciprocal condition number of the average of the eigenvalues of\n\ * T11 may be returned in S. S lies between 0 (very badly conditioned)\n\ * and 1 (very well conditioned). It is computed as follows. First we\n\ * compute R so that\n\ *\n\ * P = ( I R ) n1\n\ * ( 0 0 ) n2\n\ * n1 n2\n\ *\n\ * is the projector on the invariant subspace associated with T11.\n\ * R is the solution of the Sylvester equation:\n\ *\n\ * T11*R - R*T22 = T12.\n\ *\n\ * Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote\n\ * the two-norm of M. Then S is computed as the lower bound\n\ *\n\ * (1 + F-norm(R)**2)**(-1/2)\n\ *\n\ * on the reciprocal of 2-norm(P), the true reciprocal condition number.\n\ * S cannot underestimate 1 / 2-norm(P) by more than a factor of\n\ * sqrt(N).\n\ *\n\ * An approximate error bound for the computed average of the\n\ * eigenvalues of T11 is\n\ *\n\ * EPS * norm(T) / S\n\ *\n\ * where EPS is the machine precision.\n\ *\n\ * The reciprocal condition number of the right invariant subspace\n\ * spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.\n\ * SEP is defined as the separation of T11 and T22:\n\ *\n\ * sep( T11, T22 ) = sigma-min( C )\n\ *\n\ * where sigma-min(C) is the smallest singular value of the\n\ * n1*n2-by-n1*n2 matrix\n\ *\n\ * C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )\n\ *\n\ * I(m) is an m by m identity matrix, and kprod denotes the Kronecker\n\ * product. We estimate sigma-min(C) by the reciprocal of an estimate of\n\ * the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)\n\ * cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).\n\ *\n\ * When SEP is small, small changes in T can cause large changes in\n\ * the invariant subspace. An approximate bound on the maximum angular\n\ * error in the computed right invariant subspace is\n\ *\n\ * EPS * norm(T) / SEP\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlalsd0000644000175000017500000001271612502223526016510 0ustar uwabamiuwabami--- :name: zlalsd :md5sum: 67b57ad9803fd57023c3c14223c42c05 :category: :subroutine :arguments: - uplo: :type: char :intent: input - smlsiz: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - rcond: :type: doublereal :intent: input - rank: :type: integer :intent: output - work: :type: doublecomplex :intent: workspace :dims: - n * nrhs - rwork: :type: doublereal :intent: workspace :dims: - 9*n+2*n*smlsiz+8*n*nlvl+3*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1) - iwork: :type: integer :intent: workspace :dims: - 3*n*nlvl + 11*n - info: :type: integer :intent: output :substitutions: nlvl: ( (int)( log(((double)n)/(smlsiz+1))/log(2.0) ) ) + 1 :fortran_help: " SUBROUTINE ZLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, RANK, WORK, RWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLALSD uses the singular value decomposition of A to solve the least\n\ * squares problem of finding X to minimize the Euclidean norm of each\n\ * column of A*X-B, where A is N-by-N upper bidiagonal, and X and B\n\ * are N-by-NRHS. The solution X overwrites B.\n\ *\n\ * The singular values of A smaller than RCOND times the largest\n\ * singular value are treated as zero in solving the least squares\n\ * problem; in this case a minimum norm solution is returned.\n\ * The actual singular values are returned in D in ascending order.\n\ *\n\ * This code makes very mild assumptions about floating point\n\ * arithmetic. It will work on machines with a guard digit in\n\ * add/subtract, or on those binary machines without guard digits\n\ * which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.\n\ * It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': D and E define an upper bidiagonal matrix.\n\ * = 'L': D and E define a lower bidiagonal matrix.\n\ *\n\ * SMLSIZ (input) INTEGER\n\ * The maximum size of the subproblems at the bottom of the\n\ * computation tree.\n\ *\n\ * N (input) INTEGER\n\ * The dimension of the bidiagonal matrix. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of columns of B. NRHS must be at least 1.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry D contains the main diagonal of the bidiagonal\n\ * matrix. On exit, if INFO = 0, D contains its singular values.\n\ *\n\ * E (input/output) DOUBLE PRECISION array, dimension (N-1)\n\ * Contains the super-diagonal entries of the bidiagonal matrix.\n\ * On exit, E has been destroyed.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On input, B contains the right hand sides of the least\n\ * squares problem. On output, B contains the solution X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B in the calling subprogram.\n\ * LDB must be at least max(1,N).\n\ *\n\ * RCOND (input) DOUBLE PRECISION\n\ * The singular values of A less than or equal to RCOND times\n\ * the largest singular value are treated as zero in solving\n\ * the least squares problem. If RCOND is negative,\n\ * machine precision is used instead.\n\ * For example, if diag(S)*X=B were the least squares problem,\n\ * where diag(S) is a diagonal matrix of singular values, the\n\ * solution would be X(i) = B(i) / S(i) if S(i) is greater than\n\ * RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to\n\ * RCOND*max(S).\n\ *\n\ * RANK (output) INTEGER\n\ * The number of singular values of A greater than RCOND times\n\ * the largest singular value.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension at least\n\ * (N * NRHS).\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension at least\n\ * (9*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS +\n\ * MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS ),\n\ * where\n\ * NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )\n\ *\n\ * IWORK (workspace) INTEGER array, dimension at least\n\ * (3*N*NLVL + 11*N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit.\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * > 0: The algorithm failed to compute a singular value while\n\ * working on the submatrix lying in rows and columns\n\ * INFO/(N+1) through MOD(INFO,N+1).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ming Gu and Ren-Cang Li, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsbevd0000644000175000017500000001431212502223526016460 0ustar uwabamiuwabami--- :name: dsbevd :md5sum: f4311645f4dac4d301b46deb5fdcd849 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=0 ? 1 : lsame_(&jobz,\"N\") ? 2*n : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "(lsame_(&jobz,\"N\")||n<=0) ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" :fortran_help: " SUBROUTINE DSBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSBEVD computes all the eigenvalues and, optionally, eigenvectors of\n\ * a real symmetric band matrix A. If eigenvectors are desired, it uses\n\ * a divide and conquer algorithm.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * On exit, AB is overwritten by values generated during the\n\ * reduction to tridiagonal form. If UPLO = 'U', the first\n\ * superdiagonal and the diagonal of the tridiagonal matrix T\n\ * are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n\ * the diagonal and first subdiagonal of T are returned in the\n\ * first two rows of AB.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD + 1.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n\ * eigenvectors of the matrix A, with the i-th column of Z\n\ * holding the eigenvector associated with W(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace/output) DOUBLE PRECISION array,\n\ * dimension (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\ * IF N <= 1, LWORK must be at least 1.\n\ * If JOBZ = 'N' and N > 2, LWORK must be at least 2*N.\n\ * If JOBZ = 'V' and N > 2, LWORK must be at least\n\ * ( 1 + 5*N + 2*N**2 ).\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the optimal sizes of the WORK and IWORK\n\ * arrays, returns these values as the first entries of the WORK\n\ * and IWORK arrays, and no error message related to LWORK or\n\ * LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array LIWORK.\n\ * If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.\n\ * If JOBZ = 'V' and N > 2, LIWORK must be at least 3 + 5*N.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK and IWORK arrays, and no error message related to\n\ * LWORK or LIWORK 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 algorithm failed to converge; i\n\ * off-diagonal elements of an intermediate tridiagonal\n\ * form did not converge to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clarscl20000644000175000017500000000301312502223525016711 0ustar uwabamiuwabami--- :name: clarscl2 :md5sum: 2dba756f9cc2571be842927d2cd02442 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - m - x: :type: complex :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE CLARSCL2 ( M, N, D, X, LDX )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLARSCL2 performs a reciprocal diagonal scaling on an vector:\n\ * x <-- inv(D) * x\n\ * where the REAL diagonal matrix D is stored as a vector.\n\ *\n\ * Eventually to be replaced by BLAS_cge_diag_scale in the new BLAS\n\ * standard.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of D and X. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of D and X. N >= 0.\n\ *\n\ * D (input) REAL array, length M\n\ * Diagonal matrix D, stored as a vector of length M.\n\ *\n\ * X (input/output) COMPLEX array, dimension (LDX,N)\n\ * On entry, the vector X to be scaled by D.\n\ * On exit, the scaled vector.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the vector X. LDX >= 0.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dtrtrs0000644000175000017500000000652112502223526016536 0ustar uwabamiuwabami--- :name: dtrtrs :md5sum: 2755db9e25d81bba84931df1c7581f32 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTRTRS solves a triangular system of the form\n\ *\n\ * A * X = B or A**T * X = B,\n\ *\n\ * where A is a triangular matrix of order N, and B is an N-by-NRHS\n\ * matrix. A check is made to verify that A is nonsingular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose = Transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The triangular matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of the array A contains the upper\n\ * triangular matrix, and the strictly lower triangular part of\n\ * A is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of the array A contains the lower triangular\n\ * matrix, and the strictly upper triangular part of A is not\n\ * referenced. If DIAG = 'U', the diagonal elements of A are\n\ * also not referenced and are assumed to be 1.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, if INFO = 0, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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 A is zero,\n\ * indicating that the matrix is singular and the solutions\n\ * X have not been computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dpftri0000644000175000017500000001350612502223526016505 0ustar uwabamiuwabami--- :name: dpftri :md5sum: 60ad689ddf94971f01ab70b0fe6ff89c :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPFTRI( TRANSR, UPLO, N, A, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPFTRI computes the inverse of a (real) symmetric positive definite\n\ * matrix A using the Cholesky factorization A = U**T*U or A = L*L**T\n\ * computed by DPFTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': The Normal TRANSR of RFP A is stored;\n\ * = 'T': The Transpose TRANSR of RFP A is stored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 )\n\ * On entry, the symmetric matrix A in RFP format. RFP format is\n\ * described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n\ * then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n\ * (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is\n\ * the transpose of RFP A as defined when\n\ * TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n\ * follows: If UPLO = 'U' the RFP A contains the nt elements of\n\ * upper packed A. If UPLO = 'L' the RFP A contains the elements\n\ * of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n\ * 'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n\ * is odd. See the Note below for more details.\n\ *\n\ * On exit, the symmetric inverse of the original matrix, in the\n\ * same storage format.\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,i) element of the factor U or L is\n\ * zero, and the inverse could not be computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * We first consider Rectangular Full Packed (RFP) Format when N is\n\ * even. We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * the transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * the transpose of the last three columns of AP lower.\n\ * This covers the case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 04 05 33 43 53\n\ * 13 14 15 00 44 54\n\ * 23 24 25 10 11 55\n\ * 33 34 35 20 21 22\n\ * 00 44 45 30 31 32\n\ * 01 11 55 40 41 42\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We then consider Rectangular Full Packed (RFP) Format when N is\n\ * odd. We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * the transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * the transpose of the last two columns of AP lower.\n\ * This covers the case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 03 04 00 33 43\n\ * 12 13 14 10 11 44\n\ * 22 23 24 20 21 22\n\ * 00 33 34 30 31 32\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ * RFP A RFP A\n\ *\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zsymv0000644000175000017500000001013712502223526016402 0ustar uwabamiuwabami--- :name: zsymv :md5sum: f54cbfcd1edd0de7ed54505e307a23e0 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - alpha: :type: doublecomplex :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: doublecomplex :intent: input :dims: - 1 + ( n - 1 )*abs( incx ) - incx: :type: integer :intent: input - beta: :type: doublecomplex :intent: input - y: :type: doublecomplex :intent: input/output :dims: - 1 + ( n - 1 )*abs( incy ) - incy: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE ZSYMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSYMV performs the matrix-vector operation\n\ *\n\ * y := alpha*A*x + beta*y,\n\ *\n\ * where alpha and beta are scalars, x and y are n element vectors and\n\ * A is an n by n symmetric matrix.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * On entry, UPLO specifies whether the upper or lower\n\ * triangular part of the array A is to be referenced as\n\ * follows:\n\ *\n\ * UPLO = 'U' or 'u' Only the upper triangular part of A\n\ * is to be referenced.\n\ *\n\ * UPLO = 'L' or 'l' Only the lower triangular part of A\n\ * is to be referenced.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the order of the matrix A.\n\ * N must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * ALPHA (input) COMPLEX*16\n\ * On entry, ALPHA specifies the scalar alpha.\n\ * Unchanged on exit.\n\ *\n\ * A (input) COMPLEX*16 array, dimension ( LDA, N )\n\ * Before entry, with UPLO = 'U' or 'u', the leading n by n\n\ * upper triangular part of the array A must contain the upper\n\ * triangular part of the symmetric matrix and the strictly\n\ * lower triangular part of A is not referenced.\n\ * Before entry, with UPLO = 'L' or 'l', the leading n by n\n\ * lower triangular part of the array A must contain the lower\n\ * triangular part of the symmetric matrix and the strictly\n\ * upper triangular part of A is not referenced.\n\ * Unchanged on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * On entry, LDA specifies the first dimension of A as declared\n\ * in the calling (sub) program. LDA must be at least\n\ * max( 1, N ).\n\ * Unchanged on exit.\n\ *\n\ * X (input) COMPLEX*16 array, dimension at least\n\ * ( 1 + ( N - 1 )*abs( INCX ) ).\n\ * Before entry, the incremented array X must contain the N-\n\ * element vector x.\n\ * Unchanged on exit.\n\ *\n\ * INCX (input) INTEGER\n\ * On entry, INCX specifies the increment for the elements of\n\ * X. INCX must not be zero.\n\ * Unchanged on exit.\n\ *\n\ * BETA (input) COMPLEX*16\n\ * On entry, BETA specifies the scalar beta. When BETA is\n\ * supplied as zero then Y need not be set on input.\n\ * Unchanged on exit.\n\ *\n\ * Y (input/output) COMPLEX*16 array, dimension at least\n\ * ( 1 + ( N - 1 )*abs( INCY ) ).\n\ * Before entry, the incremented array Y must contain the n\n\ * element vector y. On exit, Y is overwritten by the updated\n\ * vector y.\n\ *\n\ * INCY (input) INTEGER\n\ * On entry, INCY specifies the increment for the elements of\n\ * Y. INCY must not be zero.\n\ * Unchanged on exit.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhbevx0000644000175000017500000002002012502223526016510 0ustar uwabamiuwabami--- :name: zhbevx :md5sum: 8110f15a075adb5e9c09fc8ccc5ca0f5 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - q: :type: doublecomplex :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - n - rwork: :type: doublereal :intent: workspace :dims: - 7*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" ldq: "lsame_(&jobz,\"V\") ? MAX(1,n) : 0" :fortran_help: " SUBROUTINE ZHBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHBEVX computes selected eigenvalues and, optionally, eigenvectors\n\ * of a complex Hermitian band matrix A. Eigenvalues and eigenvectors\n\ * can be selected by specifying either a range of values or a range of\n\ * indices for the desired eigenvalues.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found;\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found;\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) COMPLEX*16 array, dimension (LDAB, N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * On exit, AB is overwritten by values generated during the\n\ * reduction to tridiagonal form.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD + 1.\n\ *\n\ * Q (output) COMPLEX*16 array, dimension (LDQ, N)\n\ * If JOBZ = 'V', the N-by-N unitary matrix used in the\n\ * reduction to tridiagonal form.\n\ * If JOBZ = 'N', the array Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. If JOBZ = 'V', then\n\ * LDQ >= max(1,N).\n\ *\n\ * VL (input) DOUBLE PRECISION\n\ * VU (input) DOUBLE PRECISION\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) DOUBLE PRECISION\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less than\n\ * or equal to zero, then EPS*|T| will be used in its place,\n\ * where |T| is the 1-norm of the tridiagonal matrix obtained\n\ * by reducing AB to tridiagonal form.\n\ *\n\ * Eigenvalues will be computed most accurately when ABSTOL is\n\ * set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n\ * If this routine returns with INFO>0, indicating that some\n\ * eigenvectors did not converge, try setting ABSTOL to\n\ * 2*DLAMCH('S').\n\ *\n\ * See \"Computing Small Singular Values of Bidiagonal Matrices\n\ * with Guaranteed High Relative Accuracy,\" by Demmel and\n\ * Kahan, LAPACK Working Note #3.\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * The first M elements contain the selected eigenvalues in\n\ * ascending order.\n\ *\n\ * Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M))\n\ * If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix A\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * If an eigenvector fails to converge, then that column of Z\n\ * contains the latest approximation to the eigenvector, and the\n\ * index of the eigenvector is returned in IFAIL.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (7*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (5*N)\n\ *\n\ * IFAIL (output) INTEGER array, dimension (N)\n\ * If JOBZ = 'V', then if INFO = 0, the first M elements of\n\ * IFAIL are zero. If INFO > 0, then IFAIL contains the\n\ * indices of the eigenvectors that failed to converge.\n\ * If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n\ * Their indices are stored in array IFAIL.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlaeda0000644000175000017500000001051512502223526016424 0ustar uwabamiuwabami--- :name: dlaeda :md5sum: 3830f904cb7ee44d5b077cc4cdc94789 :category: :subroutine :arguments: - n: :type: integer :intent: input - tlvls: :type: integer :intent: input - curlvl: :type: integer :intent: input - curpbm: :type: integer :intent: input - prmptr: :type: integer :intent: input :dims: - n*LG(n) - perm: :type: integer :intent: input :dims: - n*LG(n) - givptr: :type: integer :intent: input :dims: - n*LG(n) - givcol: :type: integer :intent: input :dims: - "2" - n*LG(n) - givnum: :type: doublereal :intent: input :dims: - "2" - n*LG(n) - q: :type: doublereal :intent: input :dims: - pow(n,2) - qptr: :type: integer :intent: input :dims: - ldqptr - z: :type: doublereal :intent: output :dims: - n - ztemp: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ldqptr-2 :fortran_help: " SUBROUTINE DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAEDA computes the Z vector corresponding to the merge step in the\n\ * CURLVLth step of the merge process with TLVLS steps for the CURPBMth\n\ * problem.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The dimension of the symmetric tridiagonal matrix. N >= 0.\n\ *\n\ * TLVLS (input) INTEGER\n\ * The total number of merging levels in the overall divide and\n\ * conquer tree.\n\ *\n\ * CURLVL (input) INTEGER\n\ * The current level in the overall merge routine,\n\ * 0 <= curlvl <= tlvls.\n\ *\n\ * CURPBM (input) INTEGER\n\ * The current problem in the current level in the overall\n\ * merge routine (counting from upper left to lower right).\n\ *\n\ * PRMPTR (input) INTEGER array, dimension (N lg N)\n\ * Contains a list of pointers which indicate where in PERM a\n\ * level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)\n\ * indicates the size of the permutation and incidentally the\n\ * size of the full, non-deflated problem.\n\ *\n\ * PERM (input) INTEGER array, dimension (N lg N)\n\ * Contains the permutations (from deflation and sorting) to be\n\ * applied to each eigenblock.\n\ *\n\ * GIVPTR (input) INTEGER array, dimension (N lg N)\n\ * Contains a list of pointers which indicate where in GIVCOL a\n\ * level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)\n\ * indicates the number of Givens rotations.\n\ *\n\ * GIVCOL (input) INTEGER array, dimension (2, N lg N)\n\ * Each pair of numbers indicates a pair of columns to take place\n\ * in a Givens rotation.\n\ *\n\ * GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N)\n\ * Each number indicates the S value to be used in the\n\ * corresponding Givens rotation.\n\ *\n\ * Q (input) DOUBLE PRECISION array, dimension (N**2)\n\ * Contains the square eigenblocks from previous levels, the\n\ * starting positions for blocks are given by QPTR.\n\ *\n\ * QPTR (input) INTEGER array, dimension (N+2)\n\ * Contains a list of pointers which indicate where in Q an\n\ * eigenblock is stored. SQRT( QPTR(i+1) - QPTR(i) ) indicates\n\ * the size of the block.\n\ *\n\ * Z (output) DOUBLE PRECISION array, dimension (N)\n\ * On output this vector contains the updating vector (the last\n\ * row of the first sub-eigenvector matrix and the first row of\n\ * the second sub-eigenvector matrix).\n\ *\n\ * ZTEMP (workspace) DOUBLE PRECISION array, dimension (N)\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\ * Based on contributions by\n\ * Jeff Rutter, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgesvx0000644000175000017500000003262012502223526016541 0ustar uwabamiuwabami--- :name: zgesvx :md5sum: d529ed3b00b33d4672b39add2d571a25 :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input/output :dims: - ldaf - n :option: true - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n :option: true - equed: :type: char :intent: input/output :option: true - r: :type: doublereal :intent: input/output :dims: - n :option: true - c: :type: doublereal :intent: input/output :dims: - n :option: true - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: output :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldx: n ldaf: n :fortran_help: " SUBROUTINE ZGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGESVX uses the LU factorization to compute the solution to a complex\n\ * system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', real scaling factors are computed to equilibrate\n\ * the system:\n\ * TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n\ * TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n\ * TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n\ * or diag(C)*B (if TRANS = 'T' or 'C').\n\ *\n\ * 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n\ * matrix A (after equilibration if FACT = 'E') as\n\ * A = P * L * U,\n\ * where P is a permutation matrix, L is a unit lower triangular\n\ * matrix, and U is upper triangular.\n\ *\n\ * 3. If some U(i,i)=0, so that U is exactly singular, then the routine\n\ * returns with INFO = i. Otherwise, the factored form of A is used\n\ * to estimate the condition number of the matrix A. If the\n\ * reciprocal of the condition number is less than machine precision,\n\ * INFO = N+1 is returned as a warning, but the routine still goes on\n\ * to solve for X and compute error bounds as described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n\ * that it solves the original system before equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AF and IPIV contain the factored form of A.\n\ * If EQUED is not 'N', the matrix A has been\n\ * equilibrated with scaling factors given by R and C.\n\ * A, AF, and IPIV are not modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AF and factored.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose)\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is\n\ * not 'N', then A must have been equilibrated by the scaling\n\ * factors in R and/or C. A is not modified if FACT = 'F' or\n\ * 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n\ *\n\ * On exit, if EQUED .ne. 'N', A is scaled as follows:\n\ * EQUED = 'R': A := diag(R) * A\n\ * EQUED = 'C': A := A * diag(C)\n\ * EQUED = 'B': A := diag(R) * A * diag(C).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input or output) COMPLEX*16 array, dimension (LDAF,N)\n\ * If FACT = 'F', then AF is an input argument and on entry\n\ * contains the factors L and U from the factorization\n\ * A = P*L*U as computed by ZGETRF. If EQUED .ne. 'N', then\n\ * AF is the factored form of the equilibrated matrix A.\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the factors L and U from the factorization A = P*L*U\n\ * of the original matrix A.\n\ *\n\ * If FACT = 'E', then AF is an output argument and on exit\n\ * returns the factors L and U from the factorization A = P*L*U\n\ * of the equilibrated matrix A (see the description of A for\n\ * the form of the equilibrated matrix).\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * as computed by ZGETRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * of the original matrix A.\n\ *\n\ * If FACT = 'E', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * of the equilibrated matrix A.\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * R (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'R' or 'B', A is\n\ * multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n\ * is not accessed. R is an input argument if FACT = 'F';\n\ * otherwise, R is an output argument. If FACT = 'F' and\n\ * EQUED = 'R' or 'B', each element of R must be positive.\n\ *\n\ * C (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The column scale factors for A. If EQUED = 'C' or 'B', A is\n\ * multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n\ * is not accessed. C is an input argument if FACT = 'F';\n\ * otherwise, C is an output argument. If FACT = 'F' and\n\ * EQUED = 'C' or 'B', each element of C must be positive.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit,\n\ * if EQUED = 'N', B is not modified;\n\ * if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n\ * diag(R)*B;\n\ * if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n\ * overwritten by diag(C)*B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n\ * to the original system of equations. Note that A and B are\n\ * modified on exit if EQUED .ne. 'N', and the solution to the\n\ * equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n\ * EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n\ * and EQUED = 'R' or 'B'.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A after equilibration (if done). If RCOND is less than the\n\ * machine precision (in particular, if RCOND = 0), the matrix\n\ * is singular to working precision. This condition is\n\ * indicated by a return code of INFO > 0.\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace/output) DOUBLE PRECISION array, dimension (2*N)\n\ * On exit, RWORK(1) contains the reciprocal pivot growth\n\ * factor norm(A)/norm(U). The \"max absolute element\" norm is\n\ * used. If RWORK(1) is much less than 1, then the stability\n\ * of the LU factorization of the (equilibrated) matrix A\n\ * could be poor. This also means that the solution X, condition\n\ * estimator RCOND, and forward error bound FERR could be\n\ * unreliable. If factorization fails with 0 0: if INFO = i, and i is\n\ * <= N: U(i,i) is exactly zero. The factorization has\n\ * been completed, but the factor U is exactly\n\ * singular, so the solution and error bounds\n\ * could not be computed. RCOND = 0 is returned.\n\ * = N+1: U is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slatrz0000644000175000017500000000656212502223526016540 0ustar uwabamiuwabami--- :name: slatrz :md5sum: 6a5023212b0ccc05fac79ef14eda05f2 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - m - work: :type: real :intent: workspace :dims: - m :substitutions: m: lda :fortran_help: " SUBROUTINE SLATRZ( M, N, L, A, LDA, TAU, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLATRZ factors the M-by-(M+L) real upper trapezoidal matrix\n\ * [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z, by means\n\ * of orthogonal transformations. Z is an (M+L)-by-(M+L) orthogonal\n\ * matrix and, R and A1 are M-by-M upper triangular matrices.\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\ * L (input) INTEGER\n\ * The number of columns of the matrix A containing the\n\ * meaningful part of the Householder vectors. N-M >= L >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the leading M-by-N upper trapezoidal part of the\n\ * array A must contain the matrix to be factorized.\n\ * On exit, the leading M-by-M upper triangular part of A\n\ * contains the upper triangular matrix R, and elements N-L+1 to\n\ * N of the first M rows of A, with the array TAU, represent the\n\ * orthogonal matrix Z as a product of M elementary reflectors.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (output) REAL array, dimension (M)\n\ * The scalar factors of the elementary reflectors.\n\ *\n\ * WORK (workspace) REAL array, dimension (M)\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * The factorization is obtained by Householder's method. The kth\n\ * transformation matrix, Z( k ), which is used to introduce zeros into\n\ * the ( m - k + 1 )th row of A, is given in the form\n\ *\n\ * Z( k ) = ( I 0 ),\n\ * ( 0 T( k ) )\n\ *\n\ * where\n\ *\n\ * T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n\ * ( 0 )\n\ * ( z( k ) )\n\ *\n\ * tau is a scalar and z( k ) is an l element vector. tau and z( k )\n\ * are chosen to annihilate the elements of the kth row of A2.\n\ *\n\ * The scalar tau is returned in the kth element of TAU and the vector\n\ * u( k ) in the kth row of A2, such that the elements of z( k ) are\n\ * in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in\n\ * the upper triangular part of A1.\n\ *\n\ * Z is given by\n\ *\n\ * Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctzrqf0000644000175000017500000000642412502223525016526 0ustar uwabamiuwabami--- :name: ctzrqf :md5sum: 073bf9d20f3eef05da18d6ba71f465f8 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE CTZRQF( M, N, A, LDA, TAU, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This routine is deprecated and has been replaced by routine CTZRZF.\n\ *\n\ * CTZRQF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A\n\ * to upper triangular form by means of unitary transformations.\n\ *\n\ * The upper trapezoidal matrix A is factored as\n\ *\n\ * A = ( R 0 ) * Z,\n\ *\n\ * where Z is an N-by-N unitary matrix and R is an M-by-M upper\n\ * triangular matrix.\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 >= M.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the leading M-by-N upper trapezoidal part of the\n\ * array A must contain the matrix to be factorized.\n\ * On exit, the leading M-by-M upper triangular part of A\n\ * contains the upper triangular matrix R, and elements M+1 to\n\ * N of the first M rows of A, with the array TAU, represent the\n\ * unitary matrix Z as a product of M elementary reflectors.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (output) COMPLEX array, dimension (M)\n\ * The scalar factors of the elementary reflectors.\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 factorization is obtained by Householder's method. The kth\n\ * transformation matrix, Z( k ), whose conjugate transpose is used to\n\ * introduce zeros into the (m - k + 1)th row of A, is given in the form\n\ *\n\ * Z( k ) = ( I 0 ),\n\ * ( 0 T( k ) )\n\ *\n\ * where\n\ *\n\ * T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n\ * ( 0 )\n\ * ( z( k ) )\n\ *\n\ * tau is a scalar and z( k ) is an ( n - m ) element vector.\n\ * tau and z( k ) are chosen to annihilate the elements of the kth row\n\ * of X.\n\ *\n\ * The scalar tau is returned in the kth element of TAU and the vector\n\ * u( k ) in the kth row of A, such that the elements of z( k ) are\n\ * in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n\ * the upper triangular part of A.\n\ *\n\ * Z is given by\n\ *\n\ * Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlasd30000644000175000017500000001445512502223526016373 0ustar uwabamiuwabami--- :name: dlasd3 :md5sum: eea845f53351b22e245c27f4d81cd078 :category: :subroutine :arguments: - nl: :type: integer :intent: input - nr: :type: integer :intent: input - sqre: :type: integer :intent: input - k: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - k - q: :type: doublereal :intent: workspace :dims: - ldq - k - ldq: :type: integer :intent: input - dsigma: :type: doublereal :intent: input :dims: - k - u: :type: doublereal :intent: output :dims: - ldu - n - ldu: :type: integer :intent: input - u2: :type: doublereal :intent: input/output :dims: - ldu2 - n - ldu2: :type: integer :intent: input - vt: :type: doublereal :intent: output :dims: - ldvt - m - ldvt: :type: integer :intent: input - vt2: :type: doublereal :intent: input/output :dims: - ldvt2 - n - ldvt2: :type: integer :intent: input - idxc: :type: integer :intent: input :dims: - n - ctot: :type: integer :intent: input :dims: - "4" - z: :type: doublereal :intent: input :dims: - k - info: :type: integer :intent: output :substitutions: m: n + sqre ldq: k n: nl + nr + 1 ldu2: n ldvt: n ldvt2: n ldu: n :fortran_help: " SUBROUTINE DLASD3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2, LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLASD3 finds all the square roots of the roots of the secular\n\ * equation, as defined by the values in D and Z. It makes the\n\ * appropriate calls to DLASD4 and then updates the singular\n\ * vectors by matrix multiplication.\n\ *\n\ * This code makes very mild assumptions about floating point\n\ * arithmetic. It will work on machines with a guard digit in\n\ * add/subtract, or on those binary machines without guard digits\n\ * which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.\n\ * It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\ * DLASD3 is called from DLASD1.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NL (input) INTEGER\n\ * The row dimension of the upper block. NL >= 1.\n\ *\n\ * NR (input) INTEGER\n\ * The row dimension of the lower block. NR >= 1.\n\ *\n\ * SQRE (input) INTEGER\n\ * = 0: the lower block is an NR-by-NR square matrix.\n\ * = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n\ *\n\ * The bidiagonal matrix has N = NL + NR + 1 rows and\n\ * M = N + SQRE >= N columns.\n\ *\n\ * K (input) INTEGER\n\ * The size of the secular equation, 1 =< K = < N.\n\ *\n\ * D (output) DOUBLE PRECISION array, dimension(K)\n\ * On exit the square roots of the roots of the secular equation,\n\ * in ascending order.\n\ *\n\ * Q (workspace) DOUBLE PRECISION array,\n\ * dimension at least (LDQ,K).\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= K.\n\ *\n\ * DSIGMA (input) DOUBLE PRECISION array, dimension(K)\n\ * The first K elements of this array contain the old roots\n\ * of the deflated updating problem. These are the poles\n\ * of the secular equation.\n\ *\n\ * U (output) DOUBLE PRECISION array, dimension (LDU, N)\n\ * The last N - K columns of this matrix contain the deflated\n\ * left singular vectors.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= N.\n\ *\n\ * U2 (input/output) DOUBLE PRECISION array, dimension (LDU2, N)\n\ * The first K columns of this matrix contain the non-deflated\n\ * left singular vectors for the split problem.\n\ *\n\ * LDU2 (input) INTEGER\n\ * The leading dimension of the array U2. LDU2 >= N.\n\ *\n\ * VT (output) DOUBLE PRECISION array, dimension (LDVT, M)\n\ * The last M - K columns of VT' contain the deflated\n\ * right singular vectors.\n\ *\n\ * LDVT (input) INTEGER\n\ * The leading dimension of the array VT. LDVT >= N.\n\ *\n\ * VT2 (input/output) DOUBLE PRECISION array, dimension (LDVT2, N)\n\ * The first K columns of VT2' contain the non-deflated\n\ * right singular vectors for the split problem.\n\ *\n\ * LDVT2 (input) INTEGER\n\ * The leading dimension of the array VT2. LDVT2 >= N.\n\ *\n\ * IDXC (input) INTEGER array, dimension ( N )\n\ * The permutation used to arrange the columns of U (and rows of\n\ * VT) into three groups: the first group contains non-zero\n\ * entries only at and above (or before) NL +1; the second\n\ * contains non-zero entries only at and below (or after) NL+2;\n\ * and the third is dense. The first column of U and the row of\n\ * VT are treated separately, however.\n\ *\n\ * The rows of the singular vectors found by DLASD4\n\ * must be likewise permuted before the matrix multiplies can\n\ * take place.\n\ *\n\ * CTOT (input) INTEGER array, dimension ( 4 )\n\ * A count of the total number of the various types of columns\n\ * in U (or rows in VT), as described in IDXC. The fourth column\n\ * type is any column which has been deflated.\n\ *\n\ * Z (input) DOUBLE PRECISION array, dimension (K)\n\ * The first K elements of this array contain the components\n\ * of the deflation-adjusted updating row vector.\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 = 1, a singular value did not converge\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ming Gu and Huan Ren, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlat2s0000644000175000017500000000504012502223526016400 0ustar uwabamiuwabami--- :name: dlat2s :md5sum: 14fb3f483c9e3e8966201c93a8b4399b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - sa: :type: real :intent: output :dims: - ldsa - n - ldsa: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: ldsa: MAX(1,n) :fortran_help: " SUBROUTINE DLAT2S( UPLO, N, A, LDA, SA, LDSA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAT2S converts a DOUBLE PRECISION triangular matrix, SA, to a SINGLE\n\ * PRECISION triangular matrix, A.\n\ *\n\ * RMAX is the overflow for the SINGLE PRECISION arithmetic\n\ * DLAS2S checks that all the entries of A are between -RMAX and\n\ * RMAX. If not the convertion is aborted and a flag is raised.\n\ *\n\ * This is an auxiliary routine so there is no argument checking.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * N (input) INTEGER\n\ * The number of rows and columns of the matrix A. N >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the N-by-N triangular coefficient matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * SA (output) REAL array, dimension (LDSA,N)\n\ * Only the UPLO part of SA is referenced. On exit, if INFO=0,\n\ * the N-by-N coefficient matrix SA; if INFO>0, the content of\n\ * the UPLO part of SA is unspecified.\n\ *\n\ * LDSA (input) INTEGER\n\ * The leading dimension of the array SA. LDSA >= max(1,M).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit.\n\ * = 1: an entry of the matrix A is greater than the SINGLE\n\ * PRECISION overflow threshold, in this case, the content\n\ * of the UPLO part of SA in exit is unspecified.\n\ *\n\ * =========\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n DOUBLE PRECISION RMAX\n LOGICAL UPPER\n\ * ..\n\ * .. External Functions ..\n REAL SLAMCH\n LOGICAL LSAME\n EXTERNAL SLAMCH, LSAME\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slasd30000644000175000017500000001424512502223526016407 0ustar uwabamiuwabami--- :name: slasd3 :md5sum: b6481378b272a964c5ec577d73b4ac66 :category: :subroutine :arguments: - nl: :type: integer :intent: input - nr: :type: integer :intent: input - sqre: :type: integer :intent: input - k: :type: integer :intent: input - d: :type: real :intent: output :dims: - k - q: :type: real :intent: workspace :dims: - ldq - k - ldq: :type: integer :intent: input - dsigma: :type: real :intent: input/output :dims: - k - u: :type: real :intent: output :dims: - ldu - n - ldu: :type: integer :intent: input - u2: :type: real :intent: input :dims: - ldu2 - n - ldu2: :type: integer :intent: input - vt: :type: real :intent: output :dims: - ldvt - m - ldvt: :type: integer :intent: input - vt2: :type: real :intent: input/output :dims: - ldvt2 - n - ldvt2: :type: integer :intent: input - idxc: :type: integer :intent: input :dims: - n - ctot: :type: integer :intent: input :dims: - "4" - z: :type: real :intent: input/output :dims: - k - info: :type: integer :intent: output :substitutions: m: n+sqre ldq: k n: nl + nr + 1 ldu2: n ldvt: n ldvt2: n ldu: n :fortran_help: " SUBROUTINE SLASD3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2, LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLASD3 finds all the square roots of the roots of the secular\n\ * equation, as defined by the values in D and Z. It makes the\n\ * appropriate calls to SLASD4 and then updates the singular\n\ * vectors by matrix multiplication.\n\ *\n\ * This code makes very mild assumptions about floating point\n\ * arithmetic. It will work on machines with a guard digit in\n\ * add/subtract, or on those binary machines without guard digits\n\ * which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.\n\ * It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\ * SLASD3 is called from SLASD1.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NL (input) INTEGER\n\ * The row dimension of the upper block. NL >= 1.\n\ *\n\ * NR (input) INTEGER\n\ * The row dimension of the lower block. NR >= 1.\n\ *\n\ * SQRE (input) INTEGER\n\ * = 0: the lower block is an NR-by-NR square matrix.\n\ * = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n\ *\n\ * The bidiagonal matrix has N = NL + NR + 1 rows and\n\ * M = N + SQRE >= N columns.\n\ *\n\ * K (input) INTEGER\n\ * The size of the secular equation, 1 =< K = < N.\n\ *\n\ * D (output) REAL array, dimension(K)\n\ * On exit the square roots of the roots of the secular equation,\n\ * in ascending order.\n\ *\n\ * Q (workspace) REAL array,\n\ * dimension at least (LDQ,K).\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= K.\n\ *\n\ * DSIGMA (input/output) REAL array, dimension(K)\n\ * The first K elements of this array contain the old roots\n\ * of the deflated updating problem. These are the poles\n\ * of the secular equation.\n\ *\n\ * U (output) REAL array, dimension (LDU, N)\n\ * The last N - K columns of this matrix contain the deflated\n\ * left singular vectors.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= N.\n\ *\n\ * U2 (input) REAL array, dimension (LDU2, N)\n\ * The first K columns of this matrix contain the non-deflated\n\ * left singular vectors for the split problem.\n\ *\n\ * LDU2 (input) INTEGER\n\ * The leading dimension of the array U2. LDU2 >= N.\n\ *\n\ * VT (output) REAL array, dimension (LDVT, M)\n\ * The last M - K columns of VT' contain the deflated\n\ * right singular vectors.\n\ *\n\ * LDVT (input) INTEGER\n\ * The leading dimension of the array VT. LDVT >= N.\n\ *\n\ * VT2 (input/output) REAL array, dimension (LDVT2, N)\n\ * The first K columns of VT2' contain the non-deflated\n\ * right singular vectors for the split problem.\n\ *\n\ * LDVT2 (input) INTEGER\n\ * The leading dimension of the array VT2. LDVT2 >= N.\n\ *\n\ * IDXC (input) INTEGER array, dimension (N)\n\ * The permutation used to arrange the columns of U (and rows of\n\ * VT) into three groups: the first group contains non-zero\n\ * entries only at and above (or before) NL +1; the second\n\ * contains non-zero entries only at and below (or after) NL+2;\n\ * and the third is dense. The first column of U and the row of\n\ * VT are treated separately, however.\n\ *\n\ * The rows of the singular vectors found by SLASD4\n\ * must be likewise permuted before the matrix multiplies can\n\ * take place.\n\ *\n\ * CTOT (input) INTEGER array, dimension (4)\n\ * A count of the total number of the various types of columns\n\ * in U (or rows in VT), as described in IDXC. The fourth column\n\ * type is any column which has been deflated.\n\ *\n\ * Z (input/output) REAL array, dimension (K)\n\ * The first K elements of this array contain the components\n\ * of the deflation-adjusted updating row vector.\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 = 1, a singular value did not converge\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ming Gu and Huan Ren, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slaed00000644000175000017500000001222412502223526016361 0ustar uwabamiuwabami--- :name: slaed0 :md5sum: 502ff7fe93854f23945ff52ecee82f3d :category: :subroutine :arguments: - icompq: :type: integer :intent: input - qsiz: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input :dims: - n-1 - q: :type: real :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - qstore: :type: real :intent: workspace :dims: - ldqs - n - ldqs: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "((icompq == 0) || (icompq == 1)) ? 1 + 3*n + 2*n*LG(n) + 2*pow(n,2) : icompq == 2 ? 4*n + pow(n,2) : 0" - iwork: :type: integer :intent: workspace :dims: - "((icompq == 0) || (icompq == 1)) ? 6 + 6*n + 5*n*LG(n) : icompq == 2 ? 3 + 5*n : 0" - info: :type: integer :intent: output :substitutions: ldqs: "icompq == 1 ? MAX(1,n) : 1" :fortran_help: " SUBROUTINE SLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAED0 computes all eigenvalues and corresponding eigenvectors of a\n\ * symmetric tridiagonal matrix using the divide and conquer method.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ICOMPQ (input) INTEGER\n\ * = 0: Compute eigenvalues only.\n\ * = 1: Compute eigenvectors of original dense symmetric matrix\n\ * also. On entry, Q contains the orthogonal matrix used\n\ * to reduce the original matrix to tridiagonal form.\n\ * = 2: Compute eigenvalues and eigenvectors of tridiagonal\n\ * matrix.\n\ *\n\ * QSIZ (input) INTEGER\n\ * The dimension of the orthogonal matrix used to reduce\n\ * the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.\n\ *\n\ * N (input) INTEGER\n\ * The dimension of the symmetric tridiagonal matrix. N >= 0.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the main diagonal of the tridiagonal matrix.\n\ * On exit, its eigenvalues.\n\ *\n\ * E (input) REAL array, dimension (N-1)\n\ * The off-diagonal elements of the tridiagonal matrix.\n\ * On exit, E has been destroyed.\n\ *\n\ * Q (input/output) REAL array, dimension (LDQ, N)\n\ * On entry, Q must contain an N-by-N orthogonal matrix.\n\ * If ICOMPQ = 0 Q is not referenced.\n\ * If ICOMPQ = 1 On entry, Q is a subset of the columns of the\n\ * orthogonal matrix used to reduce the full\n\ * matrix to tridiagonal form corresponding to\n\ * the subset of the full matrix which is being\n\ * decomposed at this time.\n\ * If ICOMPQ = 2 On entry, Q will be the identity matrix.\n\ * On exit, Q contains the eigenvectors of the\n\ * tridiagonal matrix.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. If eigenvectors are\n\ * desired, then LDQ >= max(1,N). In any case, LDQ >= 1.\n\ *\n\ * QSTORE (workspace) REAL array, dimension (LDQS, N)\n\ * Referenced only when ICOMPQ = 1. Used to store parts of\n\ * the eigenvector matrix when the updating matrix multiplies\n\ * take place.\n\ *\n\ * LDQS (input) INTEGER\n\ * The leading dimension of the array QSTORE. If ICOMPQ = 1,\n\ * then LDQS >= max(1,N). In any case, LDQS >= 1.\n\ *\n\ * WORK (workspace) REAL array,\n\ * If ICOMPQ = 0 or 1, the dimension of WORK must be at least\n\ * 1 + 3*N + 2*N*lg N + 2*N**2\n\ * ( lg( N ) = smallest integer k\n\ * such that 2^k >= N )\n\ * If ICOMPQ = 2, the dimension of WORK must be at least\n\ * 4*N + N**2.\n\ *\n\ * IWORK (workspace) INTEGER array,\n\ * If ICOMPQ = 0 or 1, the dimension of IWORK must be at least\n\ * 6 + 6*N + 5*N*lg N.\n\ * ( lg( N ) = smallest integer k\n\ * such that 2^k >= N )\n\ * If ICOMPQ = 2, the dimension of IWORK must be at least\n\ * 3 + 5*N.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit.\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * > 0: The algorithm failed to compute an eigenvalue while\n\ * working on the submatrix lying in rows and columns\n\ * INFO/(N+1) through mod(INFO,N+1).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Jeff Rutter, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgelsy0000644000175000017500000001447712502223526016514 0ustar uwabamiuwabami--- :name: dgelsy :md5sum: e2df8916f4fbca7d7953269868109558 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - rcond: :type: doublereal :intent: input - rank: :type: integer :intent: output - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(MIN(m,n)+3*n+1, 2*MIN(m,n)+nrhs) - info: :type: integer :intent: output :substitutions: m: lda ldb: MAX(m,n) :fortran_help: " SUBROUTINE DGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGELSY computes the minimum-norm solution to a real linear least\n\ * squares problem:\n\ * minimize || A * X - B ||\n\ * using a complete orthogonal factorization of A. A is an M-by-N\n\ * matrix which may be rank-deficient.\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\ * The routine first computes a QR factorization with column pivoting:\n\ * A * P = Q * [ R11 R12 ]\n\ * [ 0 R22 ]\n\ * with R11 defined as the largest leading submatrix whose estimated\n\ * condition number is less than 1/RCOND. The order of R11, RANK,\n\ * is the effective rank of A.\n\ *\n\ * Then, R22 is considered to be negligible, and R12 is annihilated\n\ * by orthogonal transformations from the right, arriving at the\n\ * complete orthogonal factorization:\n\ * A * P = Q * [ T11 0 ] * Z\n\ * [ 0 0 ]\n\ * The minimum-norm solution is then\n\ * X = P * Z' [ inv(T11)*Q1'*B ]\n\ * [ 0 ]\n\ * where Q1 consists of the first RANK columns of Q.\n\ *\n\ * This routine is basically identical to the original xGELSX except\n\ * three differences:\n\ * o The call to the subroutine xGEQPF has been substituted by the\n\ * the call to the subroutine xGEQP3. This subroutine is a Blas-3\n\ * version of the QR factorization with column pivoting.\n\ * o Matrix B (the right hand side) is updated with Blas-3.\n\ * o The permutation of matrix B (the right hand side) is faster and\n\ * more simple.\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\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of\n\ * columns of 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, A has been overwritten by details of its\n\ * complete orthogonal factorization.\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 M-by-NRHS right hand side matrix B.\n\ * On exit, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,M,N).\n\ *\n\ * JPVT (input/output) INTEGER array, dimension (N)\n\ * On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n\ * to the front of AP, otherwise column i is a free column.\n\ * On exit, if JPVT(i) = k, then the i-th column of AP\n\ * was the k-th column of A.\n\ *\n\ * RCOND (input) DOUBLE PRECISION\n\ * RCOND is used to determine the effective rank of A, which\n\ * is defined as the order of the largest leading triangular\n\ * submatrix R11 in the QR factorization with pivoting of A,\n\ * whose estimated condition number < 1/RCOND.\n\ *\n\ * RANK (output) INTEGER\n\ * The effective rank of A, i.e., the order of the submatrix\n\ * R11. This is the same as the order of the submatrix T11\n\ * in the complete orthogonal factorization of A.\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\ * The unblocked strategy requires that:\n\ * LWORK >= MAX( MN+3*N+1, 2*MN+NRHS ),\n\ * where MN = min( M, N ).\n\ * The block algorithm requires that:\n\ * LWORK >= MAX( MN+2*N+NB*(N+1), 2*MN+NB*NRHS ),\n\ * where NB is an upper bound on the blocksize returned\n\ * by ILAENV for the routines DGEQP3, DTZRZF, STZRQF, DORMQR,\n\ * and DORMRZ.\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\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ * E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n\ * G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ilaprec0000644000175000017500000000177712502223526016643 0ustar uwabamiuwabami--- :name: ilaprec :md5sum: ccbd47bb68340bc498273489d1d91536 :category: :function :type: integer :arguments: - prec: :type: char :intent: input :substitutions: {} :fortran_help: " INTEGER FUNCTION ILAPREC( PREC )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This subroutine translated from a character string specifying an\n\ * intermediate precision to the relevant BLAST-specified integer\n\ * constant.\n\ *\n\ * ILAPREC returns an INTEGER. If ILAPREC < 0, then the input is not a\n\ * character indicating a supported intermediate precision. Otherwise\n\ * ILAPREC returns the constant value corresponding to PREC.\n\ *\n\n\ * Arguments\n\ * =========\n\ * PREC (input) CHARACTER\n\ * Specifies the form of the system of equations:\n\ * = 'S': Single\n\ * = 'D': Double\n\ * = 'I': Indigenous\n\ * = 'X', 'E': Extra\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dtrrfs0000644000175000017500000001163412502223526016521 0ustar uwabamiuwabami--- :name: dtrrfs :md5sum: b2012a0affdec5f87254e2ff9d8acb59 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTRRFS provides error bounds and backward error estimates for the\n\ * solution to a system of linear equations with a triangular\n\ * coefficient matrix.\n\ *\n\ * The solution matrix X must be computed by DTRTRS or some other\n\ * means before entering this routine. DTRRFS does not do iterative\n\ * refinement because doing so cannot improve the backward error.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose = Transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The triangular matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of the array A contains the upper\n\ * triangular matrix, and the strictly lower triangular part of\n\ * A is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of the array A contains the lower triangular\n\ * matrix, and the strictly upper triangular part of A is not\n\ * referenced. If DIAG = 'U', the diagonal elements of A are\n\ * also not referenced and are assumed to be 1.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * The solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhegvx0000644000175000017500000002351312502223526016527 0ustar uwabamiuwabami--- :name: zhegvx :md5sum: 7003398fac9b579afd4a69d0f774a610 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - "lsame_(&jobz,\"N\") ? 0 : ldz" - "lsame_(&jobz,\"N\") ? 0 : MAX(1,m)" - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: doublereal :intent: workspace :dims: - 7*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " SUBROUTINE ZHEGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHEGVX computes selected eigenvalues, and optionally, eigenvectors\n\ * of a complex generalized Hermitian-definite eigenproblem, of the form\n\ * A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n\ * B are assumed to be Hermitian and B is also positive definite.\n\ * Eigenvalues and eigenvectors can be selected by specifying either a\n\ * range of values or a range of indices for the desired eigenvalues.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * Specifies the problem type to be solved:\n\ * = 1: A*x = (lambda)*B*x\n\ * = 2: A*B*x = (lambda)*x\n\ * = 3: B*A*x = (lambda)*x\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found.\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found.\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ **\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA, N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of A contains the\n\ * upper triangular part of the matrix A. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of A contains\n\ * the lower triangular part of the matrix A.\n\ *\n\ * On exit, the lower triangle (if UPLO='L') or the upper\n\ * triangle (if UPLO='U') of A, including the diagonal, is\n\ * destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB, N)\n\ * On entry, the Hermitian matrix B. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of B contains the\n\ * upper triangular part of the matrix B. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of B contains\n\ * the lower triangular part of the matrix B.\n\ *\n\ * On exit, if INFO <= N, the part of B containing the matrix is\n\ * overwritten by the triangular factor U or L from the Cholesky\n\ * factorization B = U**H*U or B = L*L**H.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * VL (input) DOUBLE PRECISION\n\ * VU (input) DOUBLE PRECISION\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) DOUBLE PRECISION\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less than\n\ * or equal to zero, then EPS*|T| will be used in its place,\n\ * where |T| is the 1-norm of the tridiagonal matrix obtained\n\ * by reducing A to tridiagonal form.\n\ *\n\ * Eigenvalues will be computed most accurately when ABSTOL is\n\ * set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n\ * If this routine returns with INFO>0, indicating that some\n\ * eigenvectors did not converge, try setting ABSTOL to\n\ * 2*DLAMCH('S').\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * The first M elements contain the selected\n\ * eigenvalues in ascending order.\n\ *\n\ * Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M))\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix A\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * The eigenvectors are normalized as follows:\n\ * if ITYPE = 1 or 2, Z**T*B*Z = I;\n\ * if ITYPE = 3, Z**T*inv(B)*Z = I.\n\ *\n\ * If an eigenvector fails to converge, then that column of Z\n\ * contains the latest approximation to the eigenvector, and the\n\ * index of the eigenvector is returned in IFAIL.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of the array WORK. LWORK >= max(1,2*N).\n\ * For optimal efficiency, LWORK >= (NB+1)*N,\n\ * where NB is the blocksize for ZHETRD returned by ILAENV.\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\ * RWORK (workspace) DOUBLE PRECISION array, dimension (7*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (5*N)\n\ *\n\ * IFAIL (output) INTEGER array, dimension (N)\n\ * If JOBZ = 'V', then if INFO = 0, the first M elements of\n\ * IFAIL are zero. If INFO > 0, then IFAIL contains the\n\ * indices of the eigenvectors that failed to converge.\n\ * If JOBZ = 'N', then IFAIL is not referenced.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: ZPOTRF or ZHEEVX returned an error code:\n\ * <= N: if INFO = i, ZHEEVX failed to converge;\n\ * i eigenvectors failed to converge. Their indices\n\ * are stored in array IFAIL.\n\ * > N: if INFO = N + i, for 1 <= i <= N, then the leading\n\ * minor of order i of B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgelqf0000644000175000017500000000726212502223526016507 0ustar uwabamiuwabami--- :name: zgelqf :md5sum: f67cda2c97b47156b78fc8844b072f73 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - MIN(m,n) - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGELQF computes an LQ factorization of a complex 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) COMPLEX*16 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 unitary 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) COMPLEX*16 array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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 complex scalar, and v is a complex vector with\n\ * v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in\n\ * A(i,i+1: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 XERBLA, ZGELQ2, ZLARFB, ZLARFT\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dstevx0000644000175000017500000001536412502223526016536 0ustar uwabamiuwabami--- :name: dstevx :md5sum: a357b747e988829ca9418642c972bee9 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - MAX(1,n-1) - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 5*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: n :fortran_help: " SUBROUTINE DSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSTEVX computes selected eigenvalues and, optionally, eigenvectors\n\ * of a real symmetric tridiagonal matrix A. Eigenvalues and\n\ * eigenvectors can be selected by specifying either a range of values\n\ * or a range of indices for the desired eigenvalues.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found.\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found.\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the n diagonal elements of the tridiagonal matrix\n\ * A.\n\ * On exit, D may be multiplied by a constant factor chosen\n\ * to avoid over/underflow in computing the eigenvalues.\n\ *\n\ * E (input/output) DOUBLE PRECISION array, dimension (max(1,N-1))\n\ * On entry, the (n-1) subdiagonal elements of the tridiagonal\n\ * matrix A in elements 1 to N-1 of E.\n\ * On exit, E may be multiplied by a constant factor chosen\n\ * to avoid over/underflow in computing the eigenvalues.\n\ *\n\ * VL (input) DOUBLE PRECISION\n\ * VU (input) DOUBLE PRECISION\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) DOUBLE PRECISION\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less\n\ * than or equal to zero, then EPS*|T| will be used in\n\ * its place, where |T| is the 1-norm of the tridiagonal\n\ * matrix.\n\ *\n\ * Eigenvalues will be computed most accurately when ABSTOL is\n\ * set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n\ * If this routine returns with INFO>0, indicating that some\n\ * eigenvectors did not converge, try setting ABSTOL to\n\ * 2*DLAMCH('S').\n\ *\n\ * See \"Computing Small Singular Values of Bidiagonal Matrices\n\ * with Guaranteed High Relative Accuracy,\" by Demmel and\n\ * Kahan, LAPACK Working Note #3.\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * The first M elements contain the selected eigenvalues in\n\ * ascending order.\n\ *\n\ * Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )\n\ * If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix A\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * If an eigenvector fails to converge (INFO > 0), then that\n\ * column of Z contains the latest approximation to the\n\ * eigenvector, and the index of the eigenvector is returned\n\ * in IFAIL. If JOBZ = 'N', then Z is not referenced.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (5*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (5*N)\n\ *\n\ * IFAIL (output) INTEGER array, dimension (N)\n\ * If JOBZ = 'V', then if INFO = 0, the first M elements of\n\ * IFAIL are zero. If INFO > 0, then IFAIL contains the\n\ * indices of the eigenvectors that failed to converge.\n\ * If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n\ * Their indices are stored in array IFAIL.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/icmax10000644000175000017500000000306412502223526016375 0ustar uwabamiuwabami--- :name: icmax1 :md5sum: 6796e7d2b5b097cd869358883d90e06c :category: :function :type: integer :arguments: - n: :type: integer :intent: input - cx: :type: complex :intent: input :dims: - n - incx: :type: integer :intent: input :substitutions: {} :fortran_help: " INTEGER FUNCTION ICMAX1( N, CX, INCX )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ICMAX1 finds the index of the element whose real part has maximum\n\ * absolute value.\n\ *\n\ * Based on ICAMAX from Level 1 BLAS.\n\ * The change is to use the 'genuine' absolute value.\n\ *\n\ * Contributed by Nick Higham for use with CLACON.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of elements in the vector CX.\n\ *\n\ * CX (input) COMPLEX array, dimension (N)\n\ * The vector whose elements will be summed.\n\ *\n\ * INCX (input) INTEGER\n\ * The spacing between successive values of CX. INCX >= 1.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, IX\n REAL SMAX\n COMPLEX ZDUM\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS\n\ * ..\n\ * .. Statement Functions ..\n REAL CABS1\n\ * ..\n\ * .. Statement Function definitions ..\n\ *\n\ * NEXT LINE IS THE ONLY MODIFICATION.\n CABS1( ZDUM ) = ABS( ZDUM )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlasrt0000644000175000017500000000274112502223526016505 0ustar uwabamiuwabami--- :name: dlasrt :md5sum: 3da55e931ca1aaf18ac9c8170eacfd4e :category: :subroutine :arguments: - id: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLASRT( ID, N, D, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Sort the numbers in D in increasing order (if ID = 'I') or\n\ * in decreasing order (if ID = 'D' ).\n\ *\n\ * Use Quick Sort, reverting to Insertion sort on arrays of\n\ * size <= 20. Dimension of STACK limits N to about 2**32.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ID (input) CHARACTER*1\n\ * = 'I': sort D in increasing order;\n\ * = 'D': sort D in decreasing order.\n\ *\n\ * N (input) INTEGER\n\ * The length of the array D.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the array to be sorted.\n\ * On exit, D has been sorted into increasing order\n\ * (D(1) <= ... <= D(N) ) or into decreasing order\n\ * (D(1) >= ... >= D(N) ), depending on ID.\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clauu20000644000175000017500000000413412502223525016404 0ustar uwabamiuwabami--- :name: clauu2 :md5sum: 986c1fc35dfe718d18770f0d9c923763 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CLAUU2( UPLO, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAUU2 computes the product U * U' or L' * L, where the triangular\n\ * factor U or L is stored in the upper or lower triangular part of\n\ * the array A.\n\ *\n\ * If UPLO = 'U' or 'u' then the upper triangle of the result is stored,\n\ * overwriting the factor U in A.\n\ * If UPLO = 'L' or 'l' then the lower triangle of the result is stored,\n\ * overwriting the factor L in A.\n\ *\n\ * This is the unblocked form of the algorithm, calling Level 2 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the triangular factor stored in the array A\n\ * is upper or lower triangular:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the triangular factor U or L. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the triangular factor U or L.\n\ * On exit, if UPLO = 'U', the upper triangle of A is\n\ * overwritten with the upper triangle of the product U * U';\n\ * if UPLO = 'L', the lower triangle of A is overwritten with\n\ * the lower triangle of the product L' * L.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ztgsja0000644000175000017500000002604412502223526016520 0ustar uwabamiuwabami--- :name: ztgsja :md5sum: 4357a596a3013c7a9d950eff2a6b2895 :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobv: :type: char :intent: input - jobq: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - tola: :type: doublereal :intent: input - tolb: :type: doublereal :intent: input - alpha: :type: doublereal :intent: output :dims: - n - beta: :type: doublereal :intent: output :dims: - n - u: :type: doublecomplex :intent: input/output :dims: - ldu - m - ldu: :type: integer :intent: input - v: :type: doublecomplex :intent: input/output :dims: - ldv - p - ldv: :type: integer :intent: input - q: :type: doublecomplex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - 2*n - ncycle: :type: integer :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, NCYCLE, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTGSJA computes the generalized singular value decomposition (GSVD)\n\ * of two complex upper triangular (or trapezoidal) matrices A and B.\n\ *\n\ * On entry, it is assumed that matrices A and B have the following\n\ * forms, which may be obtained by the preprocessing subroutine ZGGSVP\n\ * from a general M-by-N matrix A and P-by-N matrix B:\n\ *\n\ * N-K-L K L\n\ * A = K ( 0 A12 A13 ) if M-K-L >= 0;\n\ * L ( 0 0 A23 )\n\ * M-K-L ( 0 0 0 )\n\ *\n\ * N-K-L K L\n\ * A = K ( 0 A12 A13 ) if M-K-L < 0;\n\ * M-K ( 0 0 A23 )\n\ *\n\ * N-K-L K L\n\ * B = L ( 0 0 B13 )\n\ * P-L ( 0 0 0 )\n\ *\n\ * where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n\ * upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n\ * otherwise A23 is (M-K)-by-L upper trapezoidal.\n\ *\n\ * On exit,\n\ *\n\ * U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ),\n\ *\n\ * where U, V and Q are unitary matrices, Z' denotes the conjugate\n\ * transpose of Z, R is a nonsingular upper triangular matrix, and D1\n\ * and D2 are ``diagonal'' matrices, which are of the following\n\ * structures:\n\ *\n\ * If M-K-L >= 0,\n\ *\n\ * K L\n\ * D1 = K ( I 0 )\n\ * L ( 0 C )\n\ * M-K-L ( 0 0 )\n\ *\n\ * K L\n\ * D2 = L ( 0 S )\n\ * P-L ( 0 0 )\n\ *\n\ * N-K-L K L\n\ * ( 0 R ) = K ( 0 R11 R12 ) K\n\ * L ( 0 0 R22 ) L\n\ *\n\ * where\n\ *\n\ * C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n\ * S = diag( BETA(K+1), ... , BETA(K+L) ),\n\ * C**2 + S**2 = I.\n\ *\n\ * R is stored in A(1:K+L,N-K-L+1:N) on exit.\n\ *\n\ * If M-K-L < 0,\n\ *\n\ * K M-K K+L-M\n\ * D1 = K ( I 0 0 )\n\ * M-K ( 0 C 0 )\n\ *\n\ * K M-K K+L-M\n\ * D2 = M-K ( 0 S 0 )\n\ * K+L-M ( 0 0 I )\n\ * P-L ( 0 0 0 )\n\ *\n\ * N-K-L K M-K K+L-M\n\ * ( 0 R ) = K ( 0 R11 R12 R13 )\n\ * M-K ( 0 0 R22 R23 )\n\ * K+L-M ( 0 0 0 R33 )\n\ *\n\ * where\n\ * C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n\ * S = diag( BETA(K+1), ... , BETA(M) ),\n\ * C**2 + S**2 = I.\n\ *\n\ * R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored\n\ * ( 0 R22 R23 )\n\ * in B(M-K+1:L,N+M-K-L+1:N) on exit.\n\ *\n\ * The computation of the unitary transformation matrices U, V or Q\n\ * is optional. These matrices may either be formed explicitly, or they\n\ * may be postmultiplied into input matrices U1, V1, or Q1.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBU (input) CHARACTER*1\n\ * = 'U': U must contain a unitary matrix U1 on entry, and\n\ * the product U1*U is returned;\n\ * = 'I': U is initialized to the unit matrix, and the\n\ * unitary matrix U is returned;\n\ * = 'N': U is not computed.\n\ *\n\ * JOBV (input) CHARACTER*1\n\ * = 'V': V must contain a unitary matrix V1 on entry, and\n\ * the product V1*V is returned;\n\ * = 'I': V is initialized to the unit matrix, and the\n\ * unitary matrix V is returned;\n\ * = 'N': V is not computed.\n\ *\n\ * JOBQ (input) CHARACTER*1\n\ * = 'Q': Q must contain a unitary matrix Q1 on entry, and\n\ * the product Q1*Q is returned;\n\ * = 'I': Q is initialized to the unit matrix, and the\n\ * unitary matrix Q is returned;\n\ * = 'N': Q is not computed.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A. M >= 0.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows of the matrix B. P >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrices A and B. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * L (input) INTEGER\n\ * K and L specify the subblocks in the input matrices A and B:\n\ * A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,,N-L+1:N)\n\ * of A and B, whose GSVD is going to be computed by ZTGSJA.\n\ * See Further Details.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular\n\ * matrix R or part of R. See Purpose for details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,N)\n\ * On entry, the P-by-N matrix B.\n\ * On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains\n\ * a part of R. See Purpose for details.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,P).\n\ *\n\ * TOLA (input) DOUBLE PRECISION\n\ * TOLB (input) DOUBLE PRECISION\n\ * TOLA and TOLB are the convergence criteria for the Jacobi-\n\ * Kogbetliantz iteration procedure. Generally, they are the\n\ * same as used in the preprocessing step, say\n\ * TOLA = MAX(M,N)*norm(A)*MAZHEPS,\n\ * TOLB = MAX(P,N)*norm(B)*MAZHEPS.\n\ *\n\ * ALPHA (output) DOUBLE PRECISION array, dimension (N)\n\ * BETA (output) DOUBLE PRECISION array, dimension (N)\n\ * On exit, ALPHA and BETA contain the generalized singular\n\ * value pairs of A and B;\n\ * ALPHA(1:K) = 1,\n\ * BETA(1:K) = 0,\n\ * and if M-K-L >= 0,\n\ * ALPHA(K+1:K+L) = diag(C),\n\ * BETA(K+1:K+L) = diag(S),\n\ * or if M-K-L < 0,\n\ * ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0\n\ * BETA(K+1:M) = S, BETA(M+1:K+L) = 1.\n\ * Furthermore, if K+L < N,\n\ * ALPHA(K+L+1:N) = 0\n\ * BETA(K+L+1:N) = 0.\n\ *\n\ * U (input/output) COMPLEX*16 array, dimension (LDU,M)\n\ * On entry, if JOBU = 'U', U must contain a matrix U1 (usually\n\ * the unitary matrix returned by ZGGSVP).\n\ * On exit,\n\ * if JOBU = 'I', U contains the unitary matrix U;\n\ * if JOBU = 'U', U contains the product U1*U.\n\ * If JOBU = 'N', U is not referenced.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= max(1,M) if\n\ * JOBU = 'U'; LDU >= 1 otherwise.\n\ *\n\ * V (input/output) COMPLEX*16 array, dimension (LDV,P)\n\ * On entry, if JOBV = 'V', V must contain a matrix V1 (usually\n\ * the unitary matrix returned by ZGGSVP).\n\ * On exit,\n\ * if JOBV = 'I', V contains the unitary matrix V;\n\ * if JOBV = 'V', V contains the product V1*V.\n\ * If JOBV = 'N', V is not referenced.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V. LDV >= max(1,P) if\n\ * JOBV = 'V'; LDV >= 1 otherwise.\n\ *\n\ * Q (input/output) COMPLEX*16 array, dimension (LDQ,N)\n\ * On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually\n\ * the unitary matrix returned by ZGGSVP).\n\ * On exit,\n\ * if JOBQ = 'I', Q contains the unitary matrix Q;\n\ * if JOBQ = 'Q', Q contains the product Q1*Q.\n\ * If JOBQ = 'N', Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N) if\n\ * JOBQ = 'Q'; LDQ >= 1 otherwise.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * NCYCLE (output) INTEGER\n\ * The number of cycles required for convergence.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * = 1: the procedure does not converge after MAXIT cycles.\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * MAXIT INTEGER\n\ * MAXIT specifies the total loops that the iterative procedure\n\ * may take. If after MAXIT cycles, the routine fails to\n\ * converge, we return INFO = 1.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * ZTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce\n\ * min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L\n\ * matrix B13 to the form:\n\ *\n\ * U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1,\n\ *\n\ * where U1, V1 and Q1 are unitary matrix, and Z' is the conjugate\n\ * transpose of Z. C1 and S1 are diagonal matrices satisfying\n\ *\n\ * C1**2 + S1**2 = I,\n\ *\n\ * and R1 is an L-by-L nonsingular upper triangular matrix.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgees0000644000175000017500000001563312502223526016326 0ustar uwabamiuwabami--- :name: sgees :md5sum: a4548129118af3f395da9ff74b9e634a :category: :subroutine :arguments: - jobvs: :type: char :intent: input - sort: :type: char :intent: input - select: :intent: external procedure :block_type: logical :block_arg_num: 2 :block_arg_type: real - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - sdim: :type: integer :intent: output - wr: :type: real :intent: output :dims: - n - wi: :type: real :intent: output :dims: - n - vs: :type: real :intent: output :dims: - ldvs - n - ldvs: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 3*n - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvs: "lsame_(&jobvs,\"V\") ? n : 1" :fortran_help: " SUBROUTINE SGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, VS, LDVS, WORK, LWORK, BWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGEES computes for an N-by-N real nonsymmetric matrix A, the\n\ * eigenvalues, the real Schur form T, and, optionally, the matrix of\n\ * Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).\n\ *\n\ * Optionally, it also orders the eigenvalues on the diagonal of the\n\ * real Schur form so that selected eigenvalues are at the top left.\n\ * The leading columns of Z then form an orthonormal basis for the\n\ * invariant subspace corresponding to the selected eigenvalues.\n\ *\n\ * A matrix is in real Schur form if it is upper quasi-triangular with\n\ * 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the\n\ * form\n\ * [ a b ]\n\ * [ c a ]\n\ *\n\ * where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVS (input) CHARACTER*1\n\ * = 'N': Schur vectors are not computed;\n\ * = 'V': Schur vectors are computed.\n\ *\n\ * SORT (input) CHARACTER*1\n\ * Specifies whether or not to order the eigenvalues on the\n\ * diagonal of the Schur form.\n\ * = 'N': Eigenvalues are not ordered;\n\ * = 'S': Eigenvalues are ordered (see SELECT).\n\ *\n\ * SELECT (external procedure) LOGICAL FUNCTION of two REAL arguments\n\ * SELECT must be declared EXTERNAL in the calling subroutine.\n\ * If SORT = 'S', SELECT is used to select eigenvalues to sort\n\ * to the top left of the Schur form.\n\ * If SORT = 'N', SELECT is not referenced.\n\ * An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if\n\ * SELECT(WR(j),WI(j)) is true; i.e., if either one of a complex\n\ * conjugate pair of eigenvalues is selected, then both complex\n\ * eigenvalues are selected.\n\ * Note that a selected complex eigenvalue may no longer\n\ * satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since\n\ * ordering may change the value of complex eigenvalues\n\ * (especially if the eigenvalue is ill-conditioned); in this\n\ * case INFO is set to N+2 (see INFO below).\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ * On exit, A has been overwritten by its real Schur form T.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * SDIM (output) INTEGER\n\ * If SORT = 'N', SDIM = 0.\n\ * If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n\ * for which SELECT is true. (Complex conjugate\n\ * pairs for which SELECT is true for either\n\ * eigenvalue count as 2.)\n\ *\n\ * WR (output) REAL array, dimension (N)\n\ * WI (output) REAL array, dimension (N)\n\ * WR and WI contain the real and imaginary parts,\n\ * respectively, of the computed eigenvalues in the same order\n\ * that they appear on the diagonal of the output Schur form T.\n\ * Complex conjugate pairs of eigenvalues will appear\n\ * consecutively with the eigenvalue having the positive\n\ * imaginary part first.\n\ *\n\ * VS (output) REAL array, dimension (LDVS,N)\n\ * If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur\n\ * vectors.\n\ * If JOBVS = 'N', VS is not referenced.\n\ *\n\ * LDVS (input) INTEGER\n\ * The leading dimension of the array VS. LDVS >= 1; if\n\ * JOBVS = 'V', LDVS >= N.\n\ *\n\ * WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) contains the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK >= max(1,3*N).\n\ * For good performance, LWORK must generally be larger.\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\ * BWORK (workspace) LOGICAL array, dimension (N)\n\ * Not referenced if SORT = 'N'.\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, and i is\n\ * <= N: the QR algorithm failed to compute all the\n\ * eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI\n\ * contain those eigenvalues which have converged; if\n\ * JOBVS = 'V', VS contains the matrix which reduces A\n\ * to its partially converged Schur form.\n\ * = N+1: the eigenvalues could not be reordered because some\n\ * eigenvalues were too close to separate (the problem\n\ * is very ill-conditioned);\n\ * = N+2: after reordering, roundoff changed values of some\n\ * complex eigenvalues so that leading eigenvalues in\n\ * the Schur form no longer satisfy SELECT=.TRUE. This\n\ * could also be caused by underflow due to scaling.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhetrf0000644000175000017500000001403212502223526016512 0ustar uwabamiuwabami--- :name: zhetrf :md5sum: 270922db5c4465a08b91b72e143e19ff :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZHETRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHETRF computes the factorization of a complex Hermitian matrix A\n\ * using the Bunch-Kaufman diagonal pivoting method. The form of the\n\ * factorization is\n\ *\n\ * A = U*D*U**H or A = L*D*L**H\n\ *\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, and D is Hermitian and block diagonal with\n\ * 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\ * This is the blocked version of the algorithm, calling Level 3 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L (see below for further details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D.\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of WORK. LWORK >=1. For best performance\n\ * LWORK >= N*NB, where NB is the block size returned by ILAENV.\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, D(i,i) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular, and division by zero will occur if it\n\ * is used to solve a system of equations.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * If UPLO = 'U', then A = U*D*U', where\n\ * U = P(n)*U(n)* ... *P(k)U(k)* ...,\n\ * i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n\ * 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I v 0 ) k-s\n\ * U(k) = ( 0 I 0 ) s\n\ * ( 0 0 I ) n-k\n\ * k-s s n-k\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n\ * If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n\ * and A(k,k), and v overwrites A(1:k-2,k-1:k).\n\ *\n\ * If UPLO = 'L', then A = L*D*L', where\n\ * L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n\ * i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n\ * n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I 0 0 ) k-1\n\ * L(k) = ( 0 I 0 ) s\n\ * ( 0 v I ) n-k-s+1\n\ * k-1 s n-k-s+1\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n\ * If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n\ * and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LQUERY, UPPER\n INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZHETF2, ZLAHEF\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dtrevc0000644000175000017500000001614412502223526016505 0ustar uwabamiuwabami--- :name: dtrevc :md5sum: 22547133be70d0f3940685a9333f6dcb :category: :subroutine :arguments: - side: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input/output :dims: - n - n: :type: integer :intent: input - t: :type: doublereal :intent: input :dims: - ldt - n - ldt: :type: integer :intent: input - vl: :type: doublereal :intent: input/output :dims: - ldvl - mm - ldvl: :type: integer :intent: input - vr: :type: doublereal :intent: input/output :dims: - ldvr - mm - ldvr: :type: integer :intent: input - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: doublereal :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTREVC computes some or all of the right and/or left eigenvectors of\n\ * a real upper quasi-triangular matrix T.\n\ * Matrices of this type are produced by the Schur factorization of\n\ * a real general matrix: A = Q*T*Q**T, as computed by DHSEQR.\n\ * \n\ * The right eigenvector x and the left eigenvector y of T corresponding\n\ * to an eigenvalue w are defined by:\n\ * \n\ * T*x = w*x, (y**H)*T = w*(y**H)\n\ * \n\ * where y**H denotes the conjugate transpose of y.\n\ * The eigenvalues are not input to this routine, but are read directly\n\ * from the diagonal blocks of T.\n\ * \n\ * This routine returns the matrices X and/or Y of right and left\n\ * eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an\n\ * input matrix. If Q is the orthogonal factor that reduces a matrix\n\ * A to Schur form T, then Q*X and Q*Y are the matrices of right and\n\ * left eigenvectors of A.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'R': compute right eigenvectors only;\n\ * = 'L': compute left eigenvectors only;\n\ * = 'B': compute both right and left eigenvectors.\n\ *\n\ * HOWMNY (input) CHARACTER*1\n\ * = 'A': compute all right and/or left eigenvectors;\n\ * = 'B': compute all right and/or left eigenvectors,\n\ * backtransformed by the matrices in VR and/or VL;\n\ * = 'S': compute selected right and/or left eigenvectors,\n\ * as indicated by the logical array SELECT.\n\ *\n\ * SELECT (input/output) LOGICAL array, dimension (N)\n\ * If HOWMNY = 'S', SELECT specifies the eigenvectors to be\n\ * computed.\n\ * If w(j) is a real eigenvalue, the corresponding real\n\ * eigenvector is computed if SELECT(j) is .TRUE..\n\ * If w(j) and w(j+1) are the real and imaginary parts of a\n\ * complex eigenvalue, the corresponding complex eigenvector is\n\ * computed if either SELECT(j) or SELECT(j+1) is .TRUE., and\n\ * on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to\n\ * .FALSE..\n\ * Not referenced if HOWMNY = 'A' or 'B'.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix T. N >= 0.\n\ *\n\ * T (input) DOUBLE PRECISION array, dimension (LDT,N)\n\ * The upper quasi-triangular matrix T in Schur canonical form.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= max(1,N).\n\ *\n\ * VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)\n\ * On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n\ * contain an N-by-N matrix Q (usually the orthogonal matrix Q\n\ * of Schur vectors returned by DHSEQR).\n\ * On exit, if SIDE = 'L' or 'B', VL contains:\n\ * if HOWMNY = 'A', the matrix Y of left eigenvectors of T;\n\ * if HOWMNY = 'B', the matrix Q*Y;\n\ * if HOWMNY = 'S', the left eigenvectors of T specified by\n\ * SELECT, stored consecutively in the columns\n\ * of VL, in the same order as their\n\ * eigenvalues.\n\ * A complex eigenvector corresponding to a complex eigenvalue\n\ * is stored in two consecutive columns, the first holding the\n\ * real part, and the second the imaginary part.\n\ * Not referenced if SIDE = 'R'.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the array VL. LDVL >= 1, and if\n\ * SIDE = 'L' or 'B', LDVL >= N.\n\ *\n\ * VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)\n\ * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n\ * contain an N-by-N matrix Q (usually the orthogonal matrix Q\n\ * of Schur vectors returned by DHSEQR).\n\ * On exit, if SIDE = 'R' or 'B', VR contains:\n\ * if HOWMNY = 'A', the matrix X of right eigenvectors of T;\n\ * if HOWMNY = 'B', the matrix Q*X;\n\ * if HOWMNY = 'S', the right eigenvectors of T specified by\n\ * SELECT, stored consecutively in the columns\n\ * of VR, in the same order as their\n\ * eigenvalues.\n\ * A complex eigenvector corresponding to a complex eigenvalue\n\ * is stored in two consecutive columns, the first holding the\n\ * real part and the second the imaginary part.\n\ * Not referenced if SIDE = 'L'.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the array VR. LDVR >= 1, and if\n\ * SIDE = 'R' or 'B', LDVR >= N.\n\ *\n\ * MM (input) INTEGER\n\ * The number of columns in the arrays VL and/or VR. MM >= M.\n\ *\n\ * M (output) INTEGER\n\ * The number of columns in the arrays VL and/or VR actually\n\ * used to store the eigenvectors.\n\ * If HOWMNY = 'A' or 'B', M is set to N.\n\ * Each selected real eigenvector occupies one column and each\n\ * selected complex eigenvector occupies two columns.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\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 algorithm used in this program is basically backward (forward)\n\ * substitution, with scaling to make the the code robust against\n\ * possible overflow.\n\ *\n\ * Each eigenvector is normalized so that the element of largest\n\ * magnitude has magnitude 1; here the magnitude of a complex number\n\ * (x,y) is taken to be |x| + |y|.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zla_heamv0000644000175000017500000001122412502223526017156 0ustar uwabamiuwabami--- :name: zla_heamv :md5sum: 70eb4515737b3a9e54d3e6092582824a :category: :subroutine :arguments: - uplo: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: doublereal :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: doublecomplex :intent: input :dims: - 1 + (n-1)*abs(incx) - incx: :type: integer :intent: input - beta: :type: doublereal :intent: input - y: :type: doublereal :intent: input/output :dims: - 1 + ( n - 1 )*abs( incy ) - incy: :type: integer :intent: input :substitutions: lda: MAX(1, n) :fortran_help: " SUBROUTINE ZLA_HEAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLA_SYAMV performs the matrix-vector operation\n\ *\n\ * y := alpha*abs(A)*abs(x) + beta*abs(y),\n\ *\n\ * where alpha and beta are scalars, x and y are vectors and A is an\n\ * n by n symmetric matrix.\n\ *\n\ * This function is primarily used in calculating error bounds.\n\ * To protect against underflow during evaluation, components in\n\ * the resulting vector are perturbed away from zero by (N+1)\n\ * times the underflow threshold. To prevent unnecessarily large\n\ * errors for block-structure embedded in general matrices,\n\ * \"symbolically\" zero components are not perturbed. A zero\n\ * entry is considered \"symbolic\" if all multiplications involved\n\ * in computing that entry have at least one zero multiplicand.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * UPLO (input) INTEGER\n\ * On entry, UPLO specifies whether the upper or lower\n\ * triangular part of the array A is to be referenced as\n\ * follows:\n\ *\n\ * UPLO = BLAS_UPPER Only the upper triangular part of A\n\ * is to be referenced.\n\ *\n\ * UPLO = BLAS_LOWER Only the lower triangular part of A\n\ * is to be referenced.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the number of columns of the matrix A.\n\ * N must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * ALPHA - DOUBLE PRECISION .\n\ * On entry, ALPHA specifies the scalar alpha.\n\ * Unchanged on exit.\n\ *\n\ * A - COMPLEX*16 array of DIMENSION ( LDA, n ).\n\ * Before entry, the leading m by n part of the array A must\n\ * contain the matrix of coefficients.\n\ * Unchanged on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * On entry, LDA specifies the first dimension of A as declared\n\ * in the calling (sub) program. LDA must be at least\n\ * max( 1, n ).\n\ * Unchanged on exit.\n\ *\n\ * X - COMPLEX*16 array of DIMENSION at least\n\ * ( 1 + ( n - 1 )*abs( INCX ) )\n\ * Before entry, the incremented array X must contain the\n\ * vector x.\n\ * Unchanged on exit.\n\ *\n\ * INCX (input) INTEGER\n\ * On entry, INCX specifies the increment for the elements of\n\ * X. INCX must not be zero.\n\ * Unchanged on exit.\n\ *\n\ * BETA - DOUBLE PRECISION .\n\ * On entry, BETA specifies the scalar beta. When BETA is\n\ * supplied as zero then Y need not be set on input.\n\ * Unchanged on exit.\n\ *\n\ * Y (input/output) DOUBLE PRECISION array, dimension\n\ * ( 1 + ( n - 1 )*abs( INCY ) )\n\ * Before entry with BETA non-zero, the incremented array Y\n\ * must contain the vector y. On exit, Y is overwritten by the\n\ * updated vector y.\n\ *\n\ * INCY (input) INTEGER\n\ * On entry, INCY specifies the increment for the elements of\n\ * Y. INCY must not be zero.\n\ * Unchanged on exit.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Level 2 Blas routine.\n\ *\n\ * -- Written on 22-October-1986.\n\ * Jack Dongarra, Argonne National Lab.\n\ * Jeremy Du Croz, Nag Central Office.\n\ * Sven Hammarling, Nag Central Office.\n\ * Richard Hanson, Sandia National Labs.\n\ * -- Modified for the absolute-value product, April 2006\n\ * Jason Riedy, UC Berkeley\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/spprfs0000644000175000017500000001062712502223526016533 0ustar uwabamiuwabami--- :name: spprfs :md5sum: 2eeef5bb7a81f158e895ae7daf58f68c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: real :intent: input :dims: - n*(n+1)/2 - afp: :type: real :intent: input :dims: - n*(n+1)/2 - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ldb :fortran_help: " SUBROUTINE SPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPPRFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is symmetric positive definite\n\ * and packed, and provides error bounds and backward error estimates\n\ * for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AP (input) REAL array, dimension (N*(N+1)/2)\n\ * The upper or lower triangle of the symmetric matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * AFP (input) REAL array, dimension (N*(N+1)/2)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T, as computed by SPPTRF/CPPTRF,\n\ * packed columnwise in a linear array in the same format as A\n\ * (see AP).\n\ *\n\ * B (input) REAL array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) REAL array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by SPPTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) REAL array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/claed70000644000175000017500000001744112655767354016403 0ustar uwabamiuwabami--- :name: claed7 :md5sum: 4144e9f8c4eb810edf6ef201330922b3 :category: :subroutine :arguments: - n: :type: integer :intent: input - cutpnt: :type: integer :intent: input - qsiz: :type: integer :intent: input - tlvls: :type: integer :intent: input - curlvl: :type: integer :intent: input - curpbm: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - q: :type: complex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - rho: :type: real :intent: input - indxq: :type: integer :intent: output :dims: - n - qstore: :type: real :intent: input/output :dims: - pow(n,2)+1 - qptr: :type: integer :intent: input/output :dims: - n+2 - prmptr: :type: integer :intent: input :dims: - n*LG(n) - perm: :type: integer :intent: input :dims: - n*LG(n) - givptr: :type: integer :intent: input :dims: - n*LG(n) - givcol: :type: integer :intent: input :dims: - "2" - n*LG(n) - givnum: :type: real :intent: input :dims: - "2" - n*LG(n) - work: :type: complex :intent: workspace :dims: - qsiz*n - rwork: :type: real :intent: workspace :dims: - 3*n+2*qsiz*n - iwork: :type: integer :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CLAED7( N, CUTPNT, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, LDQ, RHO, INDXQ, QSTORE, QPTR, PRMPTR, PERM, GIVPTR, GIVCOL, GIVNUM, WORK, RWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAED7 computes the updated eigensystem of a diagonal\n\ * matrix after modification by a rank-one symmetric matrix. This\n\ * routine is used only for the eigenproblem which requires all\n\ * eigenvalues and optionally eigenvectors of a dense or banded\n\ * Hermitian matrix that has been reduced to tridiagonal form.\n\ *\n\ * T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)\n\ *\n\ * where Z = Q'u, u is a vector of length N with ones in the\n\ * CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.\n\ *\n\ * The eigenvectors of the original matrix are stored in Q, and the\n\ * eigenvalues are in D. The algorithm consists of three stages:\n\ *\n\ * The first stage consists of deflating the size of the problem\n\ * when there are multiple eigenvalues or if there is a zero in\n\ * the Z vector. For each such occurrence the dimension of the\n\ * secular equation problem is reduced by one. This stage is\n\ * performed by the routine SLAED2.\n\ *\n\ * The second stage consists of calculating the updated\n\ * eigenvalues. This is done by finding the roots of the secular\n\ * equation via the routine SLAED4 (as called by SLAED3).\n\ * This routine also calculates the eigenvectors of the current\n\ * problem.\n\ *\n\ * The final stage consists of computing the updated eigenvectors\n\ * directly using the updated eigenvalues. The eigenvectors for\n\ * the current problem are multiplied with the eigenvectors from\n\ * the overall problem.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The dimension of the symmetric tridiagonal matrix. N >= 0.\n\ *\n\ * CUTPNT (input) INTEGER\n\ * Contains the location of the last eigenvalue in the leading\n\ * sub-matrix. min(1,N) <= CUTPNT <= N.\n\ *\n\ * QSIZ (input) INTEGER\n\ * The dimension of the unitary matrix used to reduce\n\ * the full matrix to tridiagonal form. QSIZ >= N.\n\ *\n\ * TLVLS (input) INTEGER\n\ * The total number of merging levels in the overall divide and\n\ * conquer tree.\n\ *\n\ * CURLVL (input) INTEGER\n\ * The current level in the overall merge routine,\n\ * 0 <= curlvl <= tlvls.\n\ *\n\ * CURPBM (input) INTEGER\n\ * The current problem in the current level in the overall\n\ * merge routine (counting from upper left to lower right).\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the eigenvalues of the rank-1-perturbed matrix.\n\ * On exit, the eigenvalues of the repaired matrix.\n\ *\n\ * Q (input/output) COMPLEX array, dimension (LDQ,N)\n\ * On entry, the eigenvectors of the rank-1-perturbed matrix.\n\ * On exit, the eigenvectors of the repaired tridiagonal matrix.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N).\n\ *\n\ * RHO (input) REAL\n\ * Contains the subdiagonal element used to create the rank-1\n\ * modification.\n\ *\n\ * INDXQ (output) INTEGER array, dimension (N)\n\ * This contains the permutation which will reintegrate the\n\ * subproblem just solved back into sorted order,\n\ * ie. D( INDXQ( I = 1, N ) ) will be in ascending order.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (4*N)\n\ *\n\ * RWORK (workspace) REAL array,\n\ * dimension (3*N+2*QSIZ*N)\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (QSIZ*N)\n\ *\n\ * QSTORE (input/output) REAL array, dimension (N**2+1)\n\ * Stores eigenvectors of submatrices encountered during\n\ * divide and conquer, packed together. QPTR points to\n\ * beginning of the submatrices.\n\ *\n\ * QPTR (input/output) INTEGER array, dimension (N+2)\n\ * List of indices pointing to beginning of submatrices stored\n\ * in QSTORE. The submatrices are numbered starting at the\n\ * bottom left of the divide and conquer tree, from left to\n\ * right and bottom to top.\n\ *\n\ * PRMPTR (input) INTEGER array, dimension (N lg N)\n\ * Contains a list of pointers which indicate where in PERM a\n\ * level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)\n\ * indicates the size of the permutation and also the size of\n\ * the full, non-deflated problem.\n\ *\n\ * PERM (input) INTEGER array, dimension (N lg N)\n\ * Contains the permutations (from deflation and sorting) to be\n\ * applied to each eigenblock.\n\ *\n\ * GIVPTR (input) INTEGER array, dimension (N lg N)\n\ * Contains a list of pointers which indicate where in GIVCOL a\n\ * level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)\n\ * indicates the number of Givens rotations.\n\ *\n\ * GIVCOL (input) INTEGER array, dimension (2, N lg N)\n\ * Each pair of numbers indicates a pair of columns to take place\n\ * in a Givens rotation.\n\ *\n\ * GIVNUM (input) REAL array, dimension (2, N lg N)\n\ * Each number indicates the S value to be used in the\n\ * corresponding Givens rotation.\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 = 1, an eigenvalue did not converge\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER COLTYP, CURR, I, IDLMDA, INDX,\n $ INDXC, INDXP, IQ, IW, IZ, K, N1, N2, PTR\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CLACRM, CLAED8, SLAED9, SLAEDA, SLAMRG, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slarrj0000644000175000017500000001000612502223526016502 0ustar uwabamiuwabami--- :name: slarrj :md5sum: caa189892882955b2b29129c51865695 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e2: :type: real :intent: input :dims: - n-1 - ifirst: :type: integer :intent: input - ilast: :type: integer :intent: input - rtol: :type: real :intent: input - offset: :type: integer :intent: input - w: :type: real :intent: input/output :dims: - n - werr: :type: real :intent: input/output :dims: - n - work: :type: real :intent: workspace :dims: - 2*n - iwork: :type: integer :intent: workspace :dims: - 2*n - pivmin: :type: real :intent: input - spdiam: :type: real :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLARRJ( N, D, E2, IFIRST, ILAST, RTOL, OFFSET, W, WERR, WORK, IWORK, PIVMIN, SPDIAM, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Given the initial eigenvalue approximations of T, SLARRJ\n\ * does bisection to refine the eigenvalues of T,\n\ * W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial\n\ * guesses for these eigenvalues are input in W, the corresponding estimate\n\ * of the error in these guesses in WERR. During bisection, intervals\n\ * [left, right] are maintained by storing their mid-points and\n\ * semi-widths in the arrays W and WERR respectively.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The N diagonal elements of T.\n\ *\n\ * E2 (input) REAL array, dimension (N-1)\n\ * The Squares of the (N-1) subdiagonal elements of T.\n\ *\n\ * IFIRST (input) INTEGER\n\ * The index of the first eigenvalue to be computed.\n\ *\n\ * ILAST (input) INTEGER\n\ * The index of the last eigenvalue to be computed.\n\ *\n\ * RTOL (input) REAL \n\ * Tolerance for the convergence of the bisection intervals.\n\ * An interval [LEFT,RIGHT] has converged if\n\ * RIGHT-LEFT.LT.RTOL*MAX(|LEFT|,|RIGHT|).\n\ *\n\ * OFFSET (input) INTEGER\n\ * Offset for the arrays W and WERR, i.e., the IFIRST-OFFSET\n\ * through ILAST-OFFSET elements of these arrays are to be used.\n\ *\n\ * W (input/output) REAL array, dimension (N)\n\ * On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are\n\ * estimates of the eigenvalues of L D L^T indexed IFIRST through\n\ * ILAST.\n\ * On output, these estimates are refined.\n\ *\n\ * WERR (input/output) REAL array, dimension (N)\n\ * On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are\n\ * the errors in the estimates of the corresponding elements in W.\n\ * On output, these errors are refined.\n\ *\n\ * WORK (workspace) REAL array, dimension (2*N)\n\ * Workspace.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (2*N)\n\ * Workspace.\n\ *\n\ * PIVMIN (input) REAL\n\ * The minimum pivot in the Sturm sequence for T.\n\ *\n\ * SPDIAM (input) REAL\n\ * The spectral diameter of T.\n\ *\n\ * INFO (output) INTEGER\n\ * Error flag.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Beresford Parlett, University of California, Berkeley, USA\n\ * Jim Demmel, University of California, Berkeley, USA\n\ * Inderjit Dhillon, University of Texas, Austin, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, University of California, Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssterf0000644000175000017500000000311412502223526016515 0ustar uwabamiuwabami--- :name: ssterf :md5sum: 5ff23162e652c9a2477b1e5c9764dc26 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SSTERF( N, D, E, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSTERF computes all eigenvalues of a symmetric tridiagonal matrix\n\ * using the Pal-Walker-Kahan variant of the QL or QR algorithm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the n diagonal elements of the tridiagonal matrix.\n\ * On exit, if INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * E (input/output) REAL array, dimension (N-1)\n\ * On entry, the (n-1) subdiagonal elements of the tridiagonal\n\ * matrix.\n\ * On exit, E has been destroyed.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: the algorithm failed to find all of the eigenvalues in\n\ * a total of 30*N iterations; if INFO = i, then i\n\ * elements of E have not converged to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlarfx0000644000175000017500000000464012502223526016522 0ustar uwabamiuwabami--- :name: zlarfx :md5sum: 2b9a75e56e7da3bbfc63c5b8030bda4d :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - v: :type: doublecomplex :intent: input :dims: - m - tau: :type: doublecomplex :intent: input - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " SUBROUTINE ZLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLARFX applies a complex elementary reflector H to a complex m by n\n\ * matrix C, from either the left or the right. H is represented in the\n\ * form\n\ *\n\ * H = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar and v is a complex vector.\n\ *\n\ * If tau = 0, then H is taken to be the unit matrix\n\ *\n\ * This version uses inline code if H has order < 11.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': form H * C\n\ * = 'R': form C * H\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C.\n\ *\n\ * V (input) COMPLEX*16 array, dimension (M) if SIDE = 'L'\n\ * or (N) if SIDE = 'R'\n\ * The vector v in the representation of H.\n\ *\n\ * TAU (input) COMPLEX*16\n\ * The value tau in the representation of H.\n\ *\n\ * C (input/output) COMPLEX*16 array, dimension (LDC,N)\n\ * On entry, the m by n matrix C.\n\ * On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n\ * or C * H if SIDE = 'R'.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDA >= max(1,M).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (N) if SIDE = 'L'\n\ * or (M) if SIDE = 'R'\n\ * WORK is not referenced if H has order < 11.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chprfs0000644000175000017500000001134212502223525016475 0ustar uwabamiuwabami--- :name: chprfs :md5sum: 4d6e9e2939bf43ccc422bd54c7607c95 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - afp: :type: complex :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CHPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHPRFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is Hermitian indefinite\n\ * and packed, and provides error bounds and backward error estimates\n\ * for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AP (input) COMPLEX array, dimension (N*(N+1)/2)\n\ * The upper or lower triangle of the Hermitian matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * AFP (input) COMPLEX array, dimension (N*(N+1)/2)\n\ * The factored form of the matrix A. AFP contains the block\n\ * diagonal matrix D and the multipliers used to obtain the\n\ * factor U or L from the factorization A = U*D*U**H or\n\ * A = L*D*L**H as computed by CHPTRF, stored as a packed\n\ * triangular matrix.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by CHPTRF.\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) COMPLEX array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by CHPTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgesvd0000644000175000017500000001630412502223526016516 0ustar uwabamiuwabami--- :name: zgesvd :md5sum: 1b2f6212b027d64d169482e5b471fc93 :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobvt: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n :outdims: - lda - MIN(m,n) - lda: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - MIN(m,n) - u: :type: doublecomplex :intent: output :dims: - ldu - "lsame_(&jobu,\"A\") ? m : lsame_(&jobu,\"S\") ? MIN(m,n) : 0" - ldu: :type: integer :intent: input - vt: :type: doublecomplex :intent: output :dims: - ldvt - n - ldvt: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(1, 2*MIN(m,n)+MAX(m,n)) - rwork: :type: doublereal :intent: workspace :dims: - 5*MIN(m,n) - info: :type: integer :intent: output :substitutions: m: lda ldvt: "lsame_(&jobvt,\"A\") ? n : lsame_(&jobvt,\"S\") ? MIN(m,n) : 1" ldu: "((lsame_(&jobu,\"S\")) || (lsame_(&jobu,\"A\"))) ? m : 1" :fortran_help: " SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGESVD computes the singular value decomposition (SVD) of a complex\n\ * M-by-N matrix A, optionally computing the left and/or right singular\n\ * vectors. The SVD is written\n\ *\n\ * A = U * SIGMA * conjugate-transpose(V)\n\ *\n\ * where SIGMA is an M-by-N matrix which is zero except for its\n\ * min(m,n) diagonal elements, U is an M-by-M unitary matrix, and\n\ * V is an N-by-N unitary matrix. The diagonal elements of SIGMA\n\ * are the singular values of A; they are real and non-negative, and\n\ * are returned in descending order. The first min(m,n) columns of\n\ * U and V are the left and right singular vectors of A.\n\ *\n\ * Note that the routine returns V**H, not V.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBU (input) CHARACTER*1\n\ * Specifies options for computing all or part of the matrix U:\n\ * = 'A': all M columns of U are returned in array U:\n\ * = 'S': the first min(m,n) columns of U (the left singular\n\ * vectors) are returned in the array U;\n\ * = 'O': the first min(m,n) columns of U (the left singular\n\ * vectors) are overwritten on the array A;\n\ * = 'N': no columns of U (no left singular vectors) are\n\ * computed.\n\ *\n\ * JOBVT (input) CHARACTER*1\n\ * Specifies options for computing all or part of the matrix\n\ * V**H:\n\ * = 'A': all N rows of V**H are returned in the array VT;\n\ * = 'S': the first min(m,n) rows of V**H (the right singular\n\ * vectors) are returned in the array VT;\n\ * = 'O': the first min(m,n) rows of V**H (the right singular\n\ * vectors) are overwritten on the array A;\n\ * = 'N': no rows of V**H (no right singular vectors) are\n\ * computed.\n\ *\n\ * JOBVT and JOBU cannot both be 'O'.\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. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit,\n\ * if JOBU = 'O', A is overwritten with the first min(m,n)\n\ * columns of U (the left singular vectors,\n\ * stored columnwise);\n\ * if JOBVT = 'O', A is overwritten with the first min(m,n)\n\ * rows of V**H (the right singular vectors,\n\ * stored rowwise);\n\ * if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A\n\ * are destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * S (output) DOUBLE PRECISION array, dimension (min(M,N))\n\ * The singular values of A, sorted so that S(i) >= S(i+1).\n\ *\n\ * U (output) COMPLEX*16 array, dimension (LDU,UCOL)\n\ * (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.\n\ * If JOBU = 'A', U contains the M-by-M unitary matrix U;\n\ * if JOBU = 'S', U contains the first min(m,n) columns of U\n\ * (the left singular vectors, stored columnwise);\n\ * if JOBU = 'N' or 'O', U is not referenced.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= 1; if\n\ * JOBU = 'S' or 'A', LDU >= M.\n\ *\n\ * VT (output) COMPLEX*16 array, dimension (LDVT,N)\n\ * If JOBVT = 'A', VT contains the N-by-N unitary matrix\n\ * V**H;\n\ * if JOBVT = 'S', VT contains the first min(m,n) rows of\n\ * V**H (the right singular vectors, stored rowwise);\n\ * if JOBVT = 'N' or 'O', VT is not referenced.\n\ *\n\ * LDVT (input) INTEGER\n\ * The leading dimension of the array VT. LDVT >= 1; if\n\ * JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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,2*MIN(M,N)+MAX(M,N)).\n\ * For good performance, LWORK should generally be larger.\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\ * RWORK (workspace) DOUBLE PRECISION array, dimension (5*min(M,N))\n\ * On exit, if INFO > 0, RWORK(1:MIN(M,N)-1) contains the\n\ * unconverged superdiagonal elements of an upper bidiagonal\n\ * matrix B whose diagonal is in S (not necessarily sorted).\n\ * B satisfies A = U * B * VT, so it has the same singular\n\ * values as A, and singular vectors related by U and VT.\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 ZBDSQR did not converge, INFO specifies how many\n\ * superdiagonals of an intermediate bidiagonal form B\n\ * did not converge to zero. See the description of RWORK\n\ * above for details.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slaqr00000644000175000017500000002145012502223526016414 0ustar uwabamiuwabami--- :name: slaqr0 :md5sum: 7cd7bbe11e963bbdc8211e2516e9b634 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: real :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - wr: :type: real :intent: output :dims: - ihi - wi: :type: real :intent: output :dims: - ihi - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: real :intent: input/output :dims: - ldz - ihi - ldz: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAQR0 computes the eigenvalues of a Hessenberg matrix H\n\ * and, optionally, the matrices T and Z from the Schur decomposition\n\ * H = Z T Z**T, where T is an upper quasi-triangular matrix (the\n\ * Schur form), and Z is the orthogonal matrix of Schur vectors.\n\ *\n\ * Optionally Z may be postmultiplied into an input orthogonal\n\ * matrix Q so that this routine can give the Schur factorization\n\ * of a matrix A which has been reduced to the Hessenberg form H\n\ * by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * WANTT (input) LOGICAL\n\ * = .TRUE. : the full Schur form T is required;\n\ * = .FALSE.: only eigenvalues are required.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * = .TRUE. : the matrix of Schur vectors Z is required;\n\ * = .FALSE.: Schur vectors are not required.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H. N .GE. 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * It is assumed that H is already upper triangular in rows\n\ * and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n\ * H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n\ * previous call to SGEBAL, and then passed to SGEHRD when the\n\ * matrix output by SGEBAL is reduced to Hessenberg form.\n\ * Otherwise, ILO and IHI should be set to 1 and N,\n\ * respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n\ * If N = 0, then ILO = 1 and IHI = 0.\n\ *\n\ * H (input/output) REAL array, dimension (LDH,N)\n\ * On entry, the upper Hessenberg matrix H.\n\ * On exit, if INFO = 0 and WANTT is .TRUE., then H contains\n\ * the upper quasi-triangular matrix T from the Schur\n\ * decomposition (the Schur form); 2-by-2 diagonal blocks\n\ * (corresponding to complex conjugate pairs of eigenvalues)\n\ * are returned in standard form, with H(i,i) = H(i+1,i+1)\n\ * and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is\n\ * .FALSE., then the contents of H are unspecified on exit.\n\ * (The output value of H when INFO.GT.0 is given under the\n\ * description of INFO below.)\n\ *\n\ * This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n\ * j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n\ *\n\ * LDH (input) INTEGER\n\ * The leading dimension of the array H. LDH .GE. max(1,N).\n\ *\n\ * WR (output) REAL array, dimension (IHI)\n\ * WI (output) REAL array, dimension (IHI)\n\ * The real and imaginary parts, respectively, of the computed\n\ * eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI)\n\ * and WI(ILO:IHI). If two eigenvalues are computed as a\n\ * complex conjugate pair, they are stored in consecutive\n\ * elements of WR and WI, say the i-th and (i+1)th, with\n\ * WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then\n\ * the eigenvalues are stored in the same order as on the\n\ * diagonal of the Schur form returned in H, with\n\ * WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal\n\ * block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and\n\ * WI(i+1) = -WI(i).\n\ *\n\ * ILOZ (input) INTEGER\n\ * IHIZ (input) INTEGER\n\ * Specify the rows of Z to which transformations must be\n\ * applied if WANTZ is .TRUE..\n\ * 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.\n\ *\n\ * Z (input/output) REAL array, dimension (LDZ,IHI)\n\ * If WANTZ is .FALSE., then Z is not referenced.\n\ * If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n\ * replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n\ * orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n\ * (The output value of Z when INFO.GT.0 is given under\n\ * the description of INFO below.)\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. if WANTZ is .TRUE.\n\ * then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.\n\ *\n\ * WORK (workspace/output) REAL array, dimension LWORK\n\ * On exit, if LWORK = -1, WORK(1) returns an estimate of\n\ * the optimal value for LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK .GE. max(1,N)\n\ * is sufficient, but LWORK typically as large as 6*N may\n\ * be required for optimal performance. A workspace query\n\ * to determine the optimal workspace size is recommended.\n\ *\n\ * If LWORK = -1, then SLAQR0 does a workspace query.\n\ * In this case, SLAQR0 checks the input parameters and\n\ * estimates the optimal workspace size for the given\n\ * values of N, ILO and IHI. The estimate is returned\n\ * in WORK(1). No error message related to LWORK is\n\ * issued by XERBLA. Neither H nor Z are accessed.\n\ *\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * .GT. 0: if INFO = i, SLAQR0 failed to compute all of\n\ * the eigenvalues. Elements 1:ilo-1 and i+1:n of WR\n\ * and WI contain those eigenvalues which have been\n\ * successfully computed. (Failures are rare.)\n\ *\n\ * If INFO .GT. 0 and WANT is .FALSE., then on exit,\n\ * the remaining unconverged eigenvalues are the eigen-\n\ * values of the upper Hessenberg matrix rows and\n\ * columns ILO through INFO of the final, output\n\ * value of H.\n\ *\n\ * If INFO .GT. 0 and WANTT is .TRUE., then on exit\n\ *\n\ * (*) (initial value of H)*U = U*(final value of H)\n\ *\n\ * where U is an orthogonal matrix. The final\n\ * value of H is upper Hessenberg and quasi-triangular\n\ * in rows and columns INFO+1 through IHI.\n\ *\n\ * If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n\ *\n\ * (final value of Z(ILO:IHI,ILOZ:IHIZ)\n\ * = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n\ *\n\ * where U is the orthogonal matrix in (*) (regard-\n\ * less of the value of WANTT.)\n\ *\n\ * If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n\ * accessed.\n\ *\n\n\ * ================================================================\n\ * Based on contributions by\n\ * Karen Braman and Ralph Byers, Department of Mathematics,\n\ * University of Kansas, USA\n\ *\n\ * ================================================================\n\ * References:\n\ * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n\ * Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n\ * Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n\ * 929--947, 2002.\n\ *\n\ * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n\ * Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n\ * of Matrix Analysis, volume 23, pages 948--973, 2002.\n\ *\n\ * ================================================================\n" ruby-lapack-1.7.2/dev/defs/dlarft0000644000175000017500000001076512502223526016475 0ustar uwabamiuwabami--- :name: dlarft :md5sum: 9da79581d3d17e4f1df0d934e54c55b6 :category: :subroutine :arguments: - direct: :type: char :intent: input - storev: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - v: :type: doublereal :intent: input/output :dims: - ldv - "lsame_(&storev,\"C\") ? k : lsame_(&storev,\"R\") ? n : 0" - ldv: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - t: :type: doublereal :intent: output :dims: - ldt - k - ldt: :type: integer :intent: input :substitutions: ldt: k :fortran_help: " SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLARFT forms the triangular factor T of a real block reflector H\n\ * of order n, which is defined as a product of k elementary reflectors.\n\ *\n\ * If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n\ *\n\ * If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n\ *\n\ * If STOREV = 'C', the vector which defines the elementary reflector\n\ * H(i) is stored in the i-th column of the array V, and\n\ *\n\ * H = I - V * T * V'\n\ *\n\ * If STOREV = 'R', the vector which defines the elementary reflector\n\ * H(i) is stored in the i-th row of the array V, and\n\ *\n\ * H = I - V' * T * V\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * DIRECT (input) CHARACTER*1\n\ * Specifies the order in which the elementary reflectors are\n\ * multiplied to form the block reflector:\n\ * = 'F': H = H(1) H(2) . . . H(k) (Forward)\n\ * = 'B': H = H(k) . . . H(2) H(1) (Backward)\n\ *\n\ * STOREV (input) CHARACTER*1\n\ * Specifies how the vectors which define the elementary\n\ * reflectors are stored (see also Further Details):\n\ * = 'C': columnwise\n\ * = 'R': rowwise\n\ *\n\ * N (input) INTEGER\n\ * The order of the block reflector H. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The order of the triangular factor T (= the number of\n\ * elementary reflectors). K >= 1.\n\ *\n\ * V (input/output) DOUBLE PRECISION array, dimension\n\ * (LDV,K) if STOREV = 'C'\n\ * (LDV,N) if STOREV = 'R'\n\ * The matrix V. See further details.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V.\n\ * If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n\ *\n\ * TAU (input) DOUBLE PRECISION array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i).\n\ *\n\ * T (output) DOUBLE PRECISION array, dimension (LDT,K)\n\ * The k by k triangular factor T of the block reflector.\n\ * If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n\ * lower triangular. The rest of the array is not used.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= K.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The shape of the matrix V and the storage of the vectors which define\n\ * the H(i) is best illustrated by the following example with n = 5 and\n\ * k = 3. The elements equal to 1 are not stored; the corresponding\n\ * array elements are modified but restored on exit. The rest of the\n\ * array is not used.\n\ *\n\ * DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':\n\ *\n\ * V = ( 1 ) V = ( 1 v1 v1 v1 v1 )\n\ * ( v1 1 ) ( 1 v2 v2 v2 )\n\ * ( v1 v2 1 ) ( 1 v3 v3 )\n\ * ( v1 v2 v3 )\n\ * ( v1 v2 v3 )\n\ *\n\ * DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':\n\ *\n\ * V = ( v1 v2 v3 ) V = ( v1 v1 1 )\n\ * ( v1 v2 v3 ) ( v2 v2 v2 1 )\n\ * ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )\n\ * ( 1 v3 )\n\ * ( 1 )\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slarrk0000644000175000017500000000616512502223526016516 0ustar uwabamiuwabami--- :name: slarrk :md5sum: 7b058d7040fa9f37d4d1ad325c612b1f :category: :subroutine :arguments: - n: :type: integer :intent: input - iw: :type: integer :intent: input - gl: :type: real :intent: input - gu: :type: real :intent: input - d: :type: real :intent: input :dims: - n - e2: :type: real :intent: input :dims: - n-1 - pivmin: :type: real :intent: input - reltol: :type: real :intent: input - w: :type: real :intent: output - werr: :type: real :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLARRK( N, IW, GL, GU, D, E2, PIVMIN, RELTOL, W, WERR, INFO)\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLARRK computes one eigenvalue of a symmetric tridiagonal\n\ * matrix T to suitable accuracy. This is an auxiliary code to be\n\ * called from SSTEMR.\n\ *\n\ * To avoid overflow, the matrix must be scaled so that its\n\ * largest element is no greater than overflow**(1/2) *\n\ * underflow**(1/4) in absolute value, and for greatest\n\ * accuracy, it should not be much smaller than that.\n\ *\n\ * See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n\ * Matrix\", Report CS41, Computer Science Dept., Stanford\n\ * University, July 21, 1966.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the tridiagonal matrix T. N >= 0.\n\ *\n\ * IW (input) INTEGER\n\ * The index of the eigenvalues to be returned.\n\ *\n\ * GL (input) REAL \n\ * GU (input) REAL \n\ * An upper and a lower bound on the eigenvalue.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The n diagonal elements of the tridiagonal matrix T.\n\ *\n\ * E2 (input) REAL array, dimension (N-1)\n\ * The (n-1) squared off-diagonal elements of the tridiagonal matrix T.\n\ *\n\ * PIVMIN (input) REAL \n\ * The minimum pivot allowed in the Sturm sequence for T.\n\ *\n\ * RELTOL (input) REAL \n\ * The minimum relative width of an interval. When an interval\n\ * is narrower than RELTOL times the larger (in\n\ * magnitude) endpoint, then it is considered to be\n\ * sufficiently small, i.e., converged. Note: this should\n\ * always be at least radix*machine epsilon.\n\ *\n\ * W (output) REAL \n\ *\n\ * WERR (output) REAL \n\ * The error bound on the corresponding eigenvalue approximation\n\ * in W.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Eigenvalue converged\n\ * = -1: Eigenvalue did NOT converge\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * FUDGE REAL , default = 2\n\ * A \"fudge factor\" to widen the Gershgorin intervals.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cungtr0000644000175000017500000000546112502223526016520 0ustar uwabamiuwabami--- :name: cungtr :md5sum: 94a00f30110e67f59804739159d1addd :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - n-1 - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CUNGTR generates a complex unitary matrix Q which is defined as the\n\ * product of n-1 elementary reflectors of order N, as returned by\n\ * CHETRD:\n\ *\n\ * if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),\n\ *\n\ * if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A contains elementary reflectors\n\ * from CHETRD;\n\ * = 'L': Lower triangle of A contains elementary reflectors\n\ * from CHETRD.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix Q. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the vectors which define the elementary reflectors,\n\ * as returned by CHETRD.\n\ * On exit, the N-by-N unitary matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= N.\n\ *\n\ * TAU (input) COMPLEX array, dimension (N-1)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by CHETRD.\n\ *\n\ * WORK (workspace/output) COMPLEX 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 >= N-1.\n\ * For optimum performance LWORK >= (N-1)*NB, where NB is\n\ * the 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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zposvx0000644000175000017500000002571312502223526016571 0ustar uwabamiuwabami--- :name: zposvx :md5sum: 1f3aee2761dee9a6b8c69a6d6362d83d :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - equed: :type: char :intent: input/output - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE ZPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPOSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to\n\ * compute the solution to a complex system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N Hermitian positive definite matrix and X and B\n\ * are N-by-NRHS matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', real scaling factors are computed to equilibrate\n\ * the system:\n\ * diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n\ *\n\ * 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n\ * factor the matrix A (after equilibration if FACT = 'E') as\n\ * A = U**H* U, if UPLO = 'U', or\n\ * A = L * L**H, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is a lower triangular\n\ * matrix.\n\ *\n\ * 3. If the leading i-by-i principal minor is not positive definite,\n\ * then the routine returns with INFO = i. Otherwise, the factored\n\ * form of A is used to estimate the condition number of the matrix\n\ * A. If the reciprocal of the condition number is less than machine\n\ * precision, INFO = N+1 is returned as a warning, but the routine\n\ * still goes on to solve for X and compute error bounds as\n\ * described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(S) so that it solves the original system before\n\ * equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AF contains the factored form of A.\n\ * If EQUED = 'Y', the matrix A has been equilibrated\n\ * with scaling factors given by S. A and AF will not\n\ * be modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AF and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the Hermitian matrix A, except if FACT = 'F' and\n\ * EQUED = 'Y', then A must contain the equilibrated matrix\n\ * diag(S)*A*diag(S). If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced. A is not modified if\n\ * FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n\ *\n\ * On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n\ * diag(S)*A*diag(S).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input or output) COMPLEX*16 array, dimension (LDAF,N)\n\ * If FACT = 'F', then AF is an input argument and on entry\n\ * contains the triangular factor U or L from the Cholesky\n\ * factorization A = U**H*U or A = L*L**H, in the same storage\n\ * format as A. If EQUED .ne. 'N', then AF is the factored form\n\ * of the equilibrated matrix diag(S)*A*diag(S).\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U**H*U or A = L*L**H of the original\n\ * matrix A.\n\ *\n\ * If FACT = 'E', then AF is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U**H*U or A = L*L**H of the equilibrated\n\ * matrix A (see the description of A for the form of the\n\ * equilibrated matrix).\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'Y': Equilibration was done, i.e., A has been replaced by\n\ * diag(S) * A * diag(S).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * S (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The scale factors for A; not accessed if EQUED = 'N'. S is\n\ * an input argument if FACT = 'F'; otherwise, S is an output\n\ * argument. If FACT = 'F' and EQUED = 'Y', each element of S\n\ * must be positive.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS righthand side matrix B.\n\ * On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n\ * B is overwritten by diag(S) * B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n\ * the original system of equations. Note that if EQUED = 'Y',\n\ * A and B are modified on exit, and the solution to the\n\ * equilibrated system is inv(diag(S))*X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A after equilibration (if done). If RCOND is less than the\n\ * machine precision (in particular, if RCOND = 0), the matrix\n\ * is singular to working precision. This condition is\n\ * indicated by a return code of INFO > 0.\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\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, and i is\n\ * <= N: the leading minor of order i of A is\n\ * not positive definite, so the factorization\n\ * could not be completed, and the solution has not\n\ * been computed. RCOND = 0 is returned.\n\ * = N+1: U is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlanht0000644000175000017500000000404112502223526016507 0ustar uwabamiuwabami--- :name: zlanht :md5sum: 6a22c58b6e99c06f31961f03100c6c14 :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublecomplex :intent: input :dims: - n-1 :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION ZLANHT( NORM, N, D, E )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLANHT returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * complex Hermitian tridiagonal matrix A.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * ZLANHT returns the value\n\ *\n\ * ZLANHT = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in ZLANHT as described\n\ * above.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, ZLANHT is\n\ * set to zero.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The diagonal elements of A.\n\ *\n\ * E (input) COMPLEX*16 array, dimension (N-1)\n\ * The (n-1) sub-diagonal or super-diagonal elements of A.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsbtrd0000644000175000017500000001014512502223526016473 0ustar uwabamiuwabami--- :name: dsbtrd :md5sum: f97e07edb1ff5355443723fc32114fa2 :category: :subroutine :arguments: - vect: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - n - e: :type: doublereal :intent: output :dims: - n-1 - q: :type: doublereal :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DSBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSBTRD reduces a real symmetric band matrix A to symmetric\n\ * tridiagonal form T by an orthogonal similarity transformation:\n\ * Q**T * A * Q = T.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * VECT (input) CHARACTER*1\n\ * = 'N': do not form Q;\n\ * = 'V': form Q;\n\ * = 'U': update a matrix X, by forming X*Q.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ * On exit, the diagonal elements of AB are overwritten by the\n\ * diagonal elements of the tridiagonal matrix T; if KD > 0, the\n\ * elements on the first superdiagonal (if UPLO = 'U') or the\n\ * first subdiagonal (if UPLO = 'L') are overwritten by the\n\ * off-diagonal elements of T; the rest of AB is overwritten by\n\ * values generated during the reduction.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * D (output) DOUBLE PRECISION array, dimension (N)\n\ * The diagonal elements of the tridiagonal matrix T.\n\ *\n\ * E (output) DOUBLE PRECISION array, dimension (N-1)\n\ * The off-diagonal elements of the tridiagonal matrix T:\n\ * E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.\n\ *\n\ * Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n\ * On entry, if VECT = 'U', then Q must contain an N-by-N\n\ * matrix X; if VECT = 'N' or 'V', then Q need not be set.\n\ *\n\ * On exit:\n\ * if VECT = 'V', Q contains the N-by-N orthogonal matrix Q;\n\ * if VECT = 'U', Q contains the product X*Q;\n\ * if VECT = 'N', the array Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q.\n\ * LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (N)\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\ * Modified by Linda Kaufman, Bell Labs.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slaqgb0000644000175000017500000000731112502223526016463 0ustar uwabamiuwabami--- :name: slaqgb :md5sum: 6f7c1c7791cc58c86bbce8fb18f95590 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - r: :type: real :intent: input :dims: - m - c: :type: real :intent: input :dims: - n - rowcnd: :type: real :intent: input - colcnd: :type: real :intent: input - amax: :type: real :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAQGB equilibrates a general M by N band matrix A with KL\n\ * subdiagonals and KU superdiagonals using the row and scaling factors\n\ * in the vectors R and C.\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\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * AB (input/output) REAL array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n\ *\n\ * On exit, the equilibrated matrix, in the same storage format\n\ * as A. See EQUED for the form of the equilibrated matrix.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDA >= KL+KU+1.\n\ *\n\ * R (input) REAL array, dimension (M)\n\ * The row scale factors for A.\n\ *\n\ * C (input) REAL array, dimension (N)\n\ * The column scale factors for A.\n\ *\n\ * ROWCND (input) REAL\n\ * Ratio of the smallest R(i) to the largest R(i).\n\ *\n\ * COLCND (input) REAL\n\ * Ratio of the smallest C(i) to the largest C(i).\n\ *\n\ * AMAX (input) REAL\n\ * Absolute value of largest matrix entry.\n\ *\n\ * EQUED (output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * THRESH is a threshold value used to decide if row or column scaling\n\ * should be done based on the ratio of the row or column scaling\n\ * factors. If ROWCND < THRESH, row scaling is done, and if\n\ * COLCND < THRESH, column scaling is done.\n\ *\n\ * LARGE and SMALL are threshold values used to decide if row scaling\n\ * should be done based on the absolute size of the largest matrix\n\ * element. If AMAX > LARGE or AMAX < SMALL, row scaling is done.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slag2d0000644000175000017500000000354212502223526016370 0ustar uwabamiuwabami--- :name: slag2d :md5sum: 66ca6fd237c1f18d65be3a3235538d2d :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - sa: :type: real :intent: input :dims: - ldsa - n - ldsa: :type: integer :intent: input - a: :type: doublereal :intent: output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: lda: MAX(1,m) :fortran_help: " SUBROUTINE SLAG2D( M, N, SA, LDSA, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAG2D converts a SINGLE PRECISION matrix, SA, to a DOUBLE\n\ * PRECISION matrix, A.\n\ *\n\ * Note that while it is possible to overflow while converting\n\ * from double to single, it is not possible to overflow when\n\ * converting from single to double.\n\ *\n\ * This is an auxiliary routine so there is no argument checking.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of lines of the matrix A. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix A. N >= 0.\n\ *\n\ * SA (input) REAL array, dimension (LDSA,N)\n\ * On entry, the M-by-N coefficient matrix SA.\n\ *\n\ * LDSA (input) INTEGER\n\ * The leading dimension of the array SA. LDSA >= max(1,M).\n\ *\n\ * A (output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On exit, the M-by-N coefficient matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * =========\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/clatzm0000644000175000017500000000717512502223525016513 0ustar uwabamiuwabami--- :name: clatzm :md5sum: 31aadd9c9169ced60aa53e18dda4843a :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - v: :type: complex :intent: input :dims: - 1 + (m-1)*abs(incv) - incv: :type: integer :intent: input - tau: :type: complex :intent: input - c1: :type: complex :intent: input/output :dims: - "lsame_(&side,\"L\") ? ldc : lsame_(&side,\"R\") ? m : 0" - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? 1 : 0" - c2: :type: complex :intent: input/output :dims: - ldc - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? n-1 : 0" - ldc: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " SUBROUTINE CLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This routine is deprecated and has been replaced by routine CUNMRZ.\n\ *\n\ * CLATZM applies a Householder matrix generated by CTZRQF to a matrix.\n\ *\n\ * Let P = I - tau*u*u', u = ( 1 ),\n\ * ( v )\n\ * where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if\n\ * SIDE = 'R'.\n\ *\n\ * If SIDE equals 'L', let\n\ * C = [ C1 ] 1\n\ * [ C2 ] m-1\n\ * n\n\ * Then C is overwritten by P*C.\n\ *\n\ * If SIDE equals 'R', let\n\ * C = [ C1, C2 ] m\n\ * 1 n-1\n\ * Then C is overwritten by C*P.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': form P * C\n\ * = 'R': form C * P\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C.\n\ *\n\ * V (input) COMPLEX array, dimension\n\ * (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n\ * (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n\ * The vector v in the representation of P. V is not used\n\ * if TAU = 0.\n\ *\n\ * INCV (input) INTEGER\n\ * The increment between elements of v. INCV <> 0\n\ *\n\ * TAU (input) COMPLEX\n\ * The value tau in the representation of P.\n\ *\n\ * C1 (input/output) COMPLEX array, dimension\n\ * (LDC,N) if SIDE = 'L'\n\ * (M,1) if SIDE = 'R'\n\ * On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1\n\ * if SIDE = 'R'.\n\ *\n\ * On exit, the first row of P*C if SIDE = 'L', or the first\n\ * column of C*P if SIDE = 'R'.\n\ *\n\ * C2 (input/output) COMPLEX array, dimension\n\ * (LDC, N) if SIDE = 'L'\n\ * (LDC, N-1) if SIDE = 'R'\n\ * On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the\n\ * m x (n - 1) matrix C2 if SIDE = 'R'.\n\ *\n\ * On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P\n\ * if SIDE = 'R'.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the arrays C1 and C2.\n\ * LDC >= max(1,M).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension\n\ * (N) if SIDE = 'L'\n\ * (M) if SIDE = 'R'\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgehd20000644000175000017500000000741412502223526016401 0ustar uwabamiuwabami--- :name: zgehd2 :md5sum: 508eab5e25a3d0cf21a0e91f3c9597e0 :category: :subroutine :arguments: - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - n-1 - work: :type: doublecomplex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGEHD2 reduces a complex general matrix A to upper Hessenberg form H\n\ * by a unitary similarity transformation: Q' * A * Q = H .\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * It is assumed that A is already upper triangular in rows\n\ * and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n\ * set by a previous call to ZGEBAL; otherwise they should be\n\ * set to 1 and N respectively. See Further Details.\n\ * 1 <= ILO <= IHI <= max(1,N).\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the n by n general matrix to be reduced.\n\ * On exit, the upper triangle and the first subdiagonal of A\n\ * are overwritten with the upper Hessenberg matrix H, and the\n\ * elements below the first subdiagonal, with the array TAU,\n\ * represent the unitary matrix Q as a product of elementary\n\ * reflectors. See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * TAU (output) COMPLEX*16 array, dimension (N-1)\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (N)\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 (ihi-ilo) elementary\n\ * reflectors\n\ *\n\ * Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar, and v is a complex vector with\n\ * v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n\ * exit in A(i+2:ihi,i), and tau in TAU(i).\n\ *\n\ * The contents of A are illustrated by the following example, with\n\ * n = 7, ilo = 2 and ihi = 6:\n\ *\n\ * on entry, on exit,\n\ *\n\ * ( a a a a a a a ) ( a a h h h h a )\n\ * ( a a a a a a ) ( a h h h h a )\n\ * ( a a a a a a ) ( h h h h h h )\n\ * ( a a a a a a ) ( v2 h h h h h )\n\ * ( a a a a a a ) ( v2 v3 h h h h )\n\ * ( a a a a a a ) ( v2 v3 v4 h h h )\n\ * ( a ) ( a )\n\ *\n\ * where a denotes an element of the original matrix A, h denotes a\n\ * modified element of the upper Hessenberg matrix H, and vi denotes an\n\ * element of the vector defining H(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsbgvx0000644000175000017500000002175512502223526016517 0ustar uwabamiuwabami--- :name: dsbgvx :md5sum: 1ee65cfeddf2efe1e17ddc18f8adf220 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: doublereal :intent: input/output :dims: - ldbb - n - ldbb: :type: integer :intent: input - q: :type: doublereal :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - 7*n - iwork: :type: integer :intent: output :dims: - 5*n - ifail: :type: integer :intent: output :dims: - m - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" ldq: "1 ? jobz = 'n' : MAX(1,n) ? jobz = 'v' : 0" :fortran_help: " SUBROUTINE DSBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSBGVX computes selected eigenvalues, and optionally, eigenvectors\n\ * of a real generalized symmetric-definite banded eigenproblem, of\n\ * the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric\n\ * and banded, and B is also positive definite. Eigenvalues and\n\ * eigenvectors can be selected by specifying either all eigenvalues,\n\ * a range of values or a range of indices for the desired eigenvalues.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found.\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found.\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * KA (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n\ *\n\ * KB (input) INTEGER\n\ * The number of superdiagonals of the matrix B if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n\ *\n\ * AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first ka+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n\ *\n\ * On exit, the contents of AB are destroyed.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KA+1.\n\ *\n\ * BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix B, stored in the first kb+1 rows of the array. The\n\ * j-th column of B is stored in the j-th column of the array BB\n\ * as follows:\n\ * if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n\ * if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n\ *\n\ * On exit, the factor S from the split Cholesky factorization\n\ * B = S**T*S, as returned by DPBSTF.\n\ *\n\ * LDBB (input) INTEGER\n\ * The leading dimension of the array BB. LDBB >= KB+1.\n\ *\n\ * Q (output) DOUBLE PRECISION array, dimension (LDQ, N)\n\ * If JOBZ = 'V', the n-by-n matrix used in the reduction of\n\ * A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x,\n\ * and consequently C to tridiagonal form.\n\ * If JOBZ = 'N', the array Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. If JOBZ = 'N',\n\ * LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N).\n\ *\n\ * VL (input) DOUBLE PRECISION\n\ * VU (input) DOUBLE PRECISION\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) DOUBLE PRECISION\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less than\n\ * or equal to zero, then EPS*|T| will be used in its place,\n\ * where |T| is the 1-norm of the tridiagonal matrix obtained\n\ * by reducing A to tridiagonal form.\n\ *\n\ * Eigenvalues will be computed most accurately when ABSTOL is\n\ * set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n\ * If this routine returns with INFO>0, indicating that some\n\ * eigenvectors did not converge, try setting ABSTOL to\n\ * 2*DLAMCH('S').\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n\ * eigenvectors, with the i-th column of Z holding the\n\ * eigenvector associated with W(i). The eigenvectors are\n\ * normalized so Z**T*B*Z = I.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace/output) DOUBLE PRECISION array, dimension (7*N)\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (5*N)\n\ *\n\ * IFAIL (output) INTEGER array, dimension (M)\n\ * If JOBZ = 'V', then if INFO = 0, the first M elements of\n\ * IFAIL are zero. If INFO > 0, then IFAIL contains the\n\ * indices of the eigenvalues that failed to converge.\n\ * If JOBZ = 'N', then IFAIL is not referenced.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0 : successful exit\n\ * < 0 : if INFO = -i, the i-th argument had an illegal value\n\ * <= N: if INFO = i, then i eigenvectors failed to converge.\n\ * Their indices are stored in IFAIL.\n\ * > N : DPBSTF returned an error code; i.e.,\n\ * if INFO = N + i, for 1 <= i <= N, then the leading\n\ * minor of order i of B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chbgvd0000644000175000017500000002076612502223525016457 0ustar uwabamiuwabami--- :name: chbgvd :md5sum: 0a1e2904f0c5dc3042474aee2dd3aade :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: complex :intent: input/output :dims: - ldbb - n - ldbb: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 2*n*n : 0" - rwork: :type: real :intent: output :dims: - MAX(1,lrwork) - lrwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? n : 1" :fortran_help: " SUBROUTINE CHBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHBGVD computes all the eigenvalues, and optionally, the eigenvectors\n\ * of a complex generalized Hermitian-definite banded eigenproblem, of\n\ * the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian\n\ * and banded, and B is also positive definite. If eigenvectors are\n\ * desired, it uses a divide and conquer algorithm.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * KA (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n\ *\n\ * KB (input) INTEGER\n\ * The number of superdiagonals of the matrix B if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n\ *\n\ * AB (input/output) COMPLEX array, dimension (LDAB, N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix A, stored in the first ka+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n\ *\n\ * On exit, the contents of AB are destroyed.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KA+1.\n\ *\n\ * BB (input/output) COMPLEX array, dimension (LDBB, N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix B, stored in the first kb+1 rows of the array. The\n\ * j-th column of B is stored in the j-th column of the array BB\n\ * as follows:\n\ * if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n\ * if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n\ *\n\ * On exit, the factor S from the split Cholesky factorization\n\ * B = S**H*S, as returned by CPBSTF.\n\ *\n\ * LDBB (input) INTEGER\n\ * The leading dimension of the array BB. LDBB >= KB+1.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) COMPLEX array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n\ * eigenvectors, with the i-th column of Z holding the\n\ * eigenvector associated with W(i). The eigenvectors are\n\ * normalized so that Z**H*B*Z = I.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= N.\n\ *\n\ * WORK (workspace/output) COMPLEX 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\ * If N <= 1, LWORK >= 1.\n\ * If JOBZ = 'N' and N > 1, LWORK >= N.\n\ * If JOBZ = 'V' and N > 1, LWORK >= 2*N**2.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the optimal sizes of the WORK, RWORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK))\n\ * On exit, if INFO=0, RWORK(1) returns the optimal LRWORK.\n\ *\n\ * LRWORK (input) INTEGER\n\ * The dimension of array RWORK.\n\ * If N <= 1, LRWORK >= 1.\n\ * If JOBZ = 'N' and N > 1, LRWORK >= N.\n\ * If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.\n\ *\n\ * If LRWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO=0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of array IWORK.\n\ * If JOBZ = 'N' or N <= 1, LIWORK >= 1.\n\ * If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK 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, and i is:\n\ * <= N: the algorithm failed to converge:\n\ * i off-diagonal elements of an intermediate\n\ * tridiagonal form did not converge to zero;\n\ * > N: if INFO = N + i, for 1 <= i <= N, then CPBSTF\n\ * returned INFO = i: B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgerqf0000644000175000017500000000742612502223526016510 0ustar uwabamiuwabami--- :name: sgerqf :md5sum: fd8676bd3914a45a158ab6460ae027b0 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - MIN(m,n) - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGERQF computes an RQ factorization of a real M-by-N matrix A:\n\ * A = R * 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) REAL array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit,\n\ * if m <= n, the upper triangle of the subarray\n\ * A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R;\n\ * if m >= n, the elements on and above the (m-n)-th subdiagonal\n\ * contain the M-by-N upper trapezoidal matrix R;\n\ * the remaining elements, with the array TAU, represent the\n\ * orthogonal matrix Q as a product of min(m,n) elementary\n\ * 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) REAL array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace/output) REAL 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\n\ * the 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(1) H(2) . . . H(k), 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(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n\ * A(m-k+i,1:n-k+i-1), and tau in TAU(i).\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n $ MU, NB, NBMIN, NU, NX\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SGERQ2, SLARFB, SLARFT, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sorgr20000644000175000017500000000437412502223526016436 0ustar uwabamiuwabami--- :name: sorgr2 :md5sum: 4206ad7b207c0443d7c85619b7300f0d :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - work: :type: real :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE SORGR2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SORGR2 generates an m by n real matrix Q with orthonormal rows,\n\ * which is defined as the last m rows of a product of k elementary\n\ * reflectors of order n\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by SGERQF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. N >= M.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. M >= K >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the (m-k+i)-th row must contain the vector which\n\ * defines the elementary reflector H(i), for i = 1,2,...,k, as\n\ * returned by SGERQF in the last k rows of its array argument\n\ * A.\n\ * On exit, the m by n matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) REAL array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by SGERQF.\n\ *\n\ * WORK (workspace) REAL array, dimension (M)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgehrd0000644000175000017500000001126312502223526016467 0ustar uwabamiuwabami--- :name: sgehrd :md5sum: fc9043ef5024995f553bea9fd9795fcd :category: :subroutine :arguments: - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - n-1 - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGEHRD reduces a real general matrix A to upper Hessenberg form H by\n\ * an orthogonal similarity transformation: Q' * A * Q = H .\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * It is assumed that A is already upper triangular in rows\n\ * and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n\ * set by a previous call to SGEBAL; otherwise they should be\n\ * set to 1 and N respectively. See Further Details.\n\ * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the N-by-N general matrix to be reduced.\n\ * On exit, the upper triangle and the first subdiagonal of A\n\ * are overwritten with the upper Hessenberg matrix H, and the\n\ * elements below the first subdiagonal, with the array TAU,\n\ * represent the orthogonal matrix Q as a product of elementary\n\ * reflectors. See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * TAU (output) REAL array, dimension (N-1)\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to\n\ * zero.\n\ *\n\ * WORK (workspace/output) REAL array, dimension (LWORK)\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of the array WORK. LWORK >= max(1,N).\n\ * For optimum performance LWORK >= N*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 (ihi-ilo) elementary\n\ * reflectors\n\ *\n\ * Q = H(ilo) H(ilo+1) . . . H(ihi-1).\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) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n\ * exit in A(i+2:ihi,i), and tau in TAU(i).\n\ *\n\ * The contents of A are illustrated by the following example, with\n\ * n = 7, ilo = 2 and ihi = 6:\n\ *\n\ * on entry, on exit,\n\ *\n\ * ( a a a a a a a ) ( a a h h h h a )\n\ * ( a a a a a a ) ( a h h h h a )\n\ * ( a a a a a a ) ( h h h h h h )\n\ * ( a a a a a a ) ( v2 h h h h h )\n\ * ( a a a a a a ) ( v2 v3 h h h h )\n\ * ( a a a a a a ) ( v2 v3 v4 h h h )\n\ * ( a ) ( a )\n\ *\n\ * where a denotes an element of the original matrix A, h denotes a\n\ * modified element of the upper Hessenberg matrix H, and vi denotes an\n\ * element of the vector defining H(i).\n\ *\n\ * This file is a slight modification of LAPACK-3.0's DGEHRD\n\ * subroutine incorporating improvements proposed by Quintana-Orti and\n\ * Van de Geijn (2006). (See DLAHR2.)\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgelq20000644000175000017500000000475712502223525016401 0ustar uwabamiuwabami--- :name: cgelq2 :md5sum: b8fcc5877fd42da3a6c7800e8a8bec97 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - MIN(m,n) - work: :type: complex :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE CGELQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGELQ2 computes an LQ factorization of a complex 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) COMPLEX 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 unitary 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) COMPLEX array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace) COMPLEX 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 complex scalar, and v is a complex vector with\n\ * v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in\n\ * A(i,i+1:n), and tau in TAU(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slasd40000644000175000017500000000712012502223526016402 0ustar uwabamiuwabami--- :name: slasd4 :md5sum: 5d9cc23b9dcc49410cef1ca83143a336 :category: :subroutine :arguments: - n: :type: integer :intent: input - i: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - z: :type: real :intent: input :dims: - n - delta: :type: real :intent: output :dims: - n - rho: :type: real :intent: input - sigma: :type: real :intent: output - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This subroutine computes the square root of the I-th updated\n\ * eigenvalue of a positive symmetric rank-one modification to\n\ * a positive diagonal matrix whose entries are given as the squares\n\ * of the corresponding entries in the array d, and that\n\ *\n\ * 0 <= D(i) < D(j) for i < j\n\ *\n\ * and that RHO > 0. This is arranged by the calling routine, and is\n\ * no loss in generality. The rank-one modified system is thus\n\ *\n\ * diag( D ) * diag( D ) + RHO * Z * Z_transpose.\n\ *\n\ * where we assume the Euclidean norm of Z is 1.\n\ *\n\ * The method consists of approximating the rational functions in the\n\ * secular equation by simpler interpolating rational functions.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The length of all arrays.\n\ *\n\ * I (input) INTEGER\n\ * The index of the eigenvalue to be computed. 1 <= I <= N.\n\ *\n\ * D (input) REAL array, dimension ( N )\n\ * The original eigenvalues. It is assumed that they are in\n\ * order, 0 <= D(I) < D(J) for I < J.\n\ *\n\ * Z (input) REAL array, dimension (N)\n\ * The components of the updating vector.\n\ *\n\ * DELTA (output) REAL array, dimension (N)\n\ * If N .ne. 1, DELTA contains (D(j) - sigma_I) in its j-th\n\ * component. If N = 1, then DELTA(1) = 1. The vector DELTA\n\ * contains the information necessary to construct the\n\ * (singular) eigenvectors.\n\ *\n\ * RHO (input) REAL\n\ * The scalar in the symmetric updating formula.\n\ *\n\ * SIGMA (output) REAL\n\ * The computed sigma_I, the I-th updated eigenvalue.\n\ *\n\ * WORK (workspace) REAL array, dimension (N)\n\ * If N .ne. 1, WORK contains (D(j) + sigma_I) in its j-th\n\ * component. If N = 1, then WORK( 1 ) = 1.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * > 0: if INFO = 1, the updating process failed.\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * Logical variable ORGATI (origin-at-i?) is used for distinguishing\n\ * whether D(i) or D(i+1) is treated as the origin.\n\ *\n\ * ORGATI = .true. origin at i\n\ * ORGATI = .false. origin at i+1\n\ *\n\ * Logical variable SWTCH3 (switch-for-3-poles?) is for noting\n\ * if we are working with THREE poles!\n\ *\n\ * MAXIT is the maximum number of iterations allowed for each\n\ * eigenvalue.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ren-Cang Li, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgtsv0000644000175000017500000000565712502223526016402 0ustar uwabamiuwabami--- :name: zgtsv :md5sum: 6f8eba9f6419e66310194d8c7a7cce23 :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: doublecomplex :intent: input/output :dims: - n-1 - d: :type: doublecomplex :intent: input/output :dims: - n - du: :type: doublecomplex :intent: input/output :dims: - n-1 - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGTSV solves the equation\n\ *\n\ * A*X = B,\n\ *\n\ * where A is an N-by-N tridiagonal matrix, by Gaussian elimination with\n\ * partial pivoting.\n\ *\n\ * Note that the equation A'*X = B may be solved by interchanging the\n\ * order of the arguments DU and DL.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * DL (input/output) COMPLEX*16 array, dimension (N-1)\n\ * On entry, DL must contain the (n-1) subdiagonal elements of\n\ * A.\n\ * On exit, DL is overwritten by the (n-2) elements of the\n\ * second superdiagonal of the upper triangular matrix U from\n\ * the LU factorization of A, in DL(1), ..., DL(n-2).\n\ *\n\ * D (input/output) COMPLEX*16 array, dimension (N)\n\ * On entry, D must contain the diagonal elements of A.\n\ * On exit, D is overwritten by the n diagonal elements of U.\n\ *\n\ * DU (input/output) COMPLEX*16 array, dimension (N-1)\n\ * On entry, DU must contain the (n-1) superdiagonal elements\n\ * of A.\n\ * On exit, DU is overwritten by the (n-1) elements of the first\n\ * superdiagonal of U.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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, U(i,i) is exactly zero, and the solution\n\ * has not been computed. The factorization has not been\n\ * completed unless i = N.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clarf0000644000175000017500000000515012502223525016277 0ustar uwabamiuwabami--- :name: clarf :md5sum: 7cf32c88d2dc45466c3c3062072fb5bb :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - v: :type: complex :intent: input :dims: - 1 + (m-1)*abs(incv) - incv: :type: integer :intent: input - tau: :type: complex :intent: input - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " SUBROUTINE CLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLARF applies a complex elementary reflector H to a complex M-by-N\n\ * matrix C, from either the left or the right. H is represented in the\n\ * form\n\ *\n\ * H = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar and v is a complex vector.\n\ *\n\ * If tau = 0, then H is taken to be the unit matrix.\n\ *\n\ * To apply H' (the conjugate transpose of H), supply conjg(tau) instead\n\ * tau.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': form H * C\n\ * = 'R': form C * H\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C.\n\ *\n\ * V (input) COMPLEX array, dimension\n\ * (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n\ * or (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n\ * The vector v in the representation of H. V is not used if\n\ * TAU = 0.\n\ *\n\ * INCV (input) INTEGER\n\ * The increment between elements of v. INCV <> 0.\n\ *\n\ * TAU (input) COMPLEX\n\ * The value tau in the representation of H.\n\ *\n\ * C (input/output) COMPLEX array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n\ * or C * H if SIDE = 'R'.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension\n\ * (N) if SIDE = 'L'\n\ * or (M) if SIDE = 'R'\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/claqhe0000644000175000017500000000575212502223525016455 0ustar uwabamiuwabami--- :name: claqhe :md5sum: 85061ecb19020970fc9555db00b1b596 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - s: :type: real :intent: input :dims: - n - scond: :type: real :intent: input - amax: :type: real :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAQHE equilibrates a Hermitian matrix A using the scaling factors\n\ * in the vector S.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * Hermitian matrix A is stored.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the leading\n\ * n by n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n by n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if EQUED = 'Y', the equilibrated matrix:\n\ * diag(S) * A * diag(S).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(N,1).\n\ *\n\ * S (input) REAL array, dimension (N)\n\ * The scale factors for A.\n\ *\n\ * SCOND (input) REAL\n\ * Ratio of the smallest S(i) to the largest S(i).\n\ *\n\ * AMAX (input) REAL\n\ * Absolute value of largest matrix entry.\n\ *\n\ * EQUED (output) CHARACTER*1\n\ * Specifies whether or not equilibration was done.\n\ * = 'N': No equilibration.\n\ * = 'Y': Equilibration was done, i.e., A has been replaced by\n\ * diag(S) * A * diag(S).\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * THRESH is a threshold value used to decide if scaling should be done\n\ * based on the ratio of the scaling factors. If SCOND < THRESH,\n\ * scaling is done.\n\ *\n\ * LARGE and SMALL are threshold values used to decide if scaling should\n\ * be done based on the absolute size of the largest matrix element.\n\ * If AMAX > LARGE or AMAX < SMALL, scaling is done.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dorbdb0000644000175000017500000002165212502223526016452 0ustar uwabamiuwabami--- :name: dorbdb :md5sum: 6a768cd2fe5db676bc79606b0d918596 :category: :subroutine :arguments: - trans: :type: char :intent: input - signs: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - q: :type: integer :intent: input - x11: :type: doublereal :intent: input/output :dims: - ldx11 - q - ldx11: :type: integer :intent: input - x12: :type: doublereal :intent: input/output :dims: - ldx12 - m-q - ldx12: :type: integer :intent: input - x21: :type: doublereal :intent: input/output :dims: - ldx21 - q - ldx21: :type: integer :intent: input - x22: :type: doublereal :intent: input/output :dims: - ldx22 - m-q - ldx22: :type: integer :intent: input - theta: :type: doublereal :intent: output :dims: - q - phi: :type: doublereal :intent: output :dims: - q-1 - taup1: :type: doublereal :intent: output :dims: - p - taup2: :type: doublereal :intent: output :dims: - m-p - tauq1: :type: doublereal :intent: output :dims: - q - tauq2: :type: doublereal :intent: output :dims: - m-q - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m-q - info: :type: integer :intent: output :substitutions: p: ldx11 ldx12: p ldx21: p ldx22: p :fortran_help: " SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DORBDB simultaneously bidiagonalizes the blocks of an M-by-M\n\ * partitioned orthogonal matrix X:\n\ *\n\ * [ B11 | B12 0 0 ]\n\ * [ X11 | X12 ] [ P1 | ] [ 0 | 0 -I 0 ] [ Q1 | ]**T\n\ * X = [-----------] = [---------] [----------------] [---------] .\n\ * [ X21 | X22 ] [ | P2 ] [ B21 | B22 0 0 ] [ | Q2 ]\n\ * [ 0 | 0 0 I ]\n\ *\n\ * X11 is P-by-Q. Q must be no larger than P, M-P, or M-Q. (If this is\n\ * not the case, then X must be transposed and/or permuted. This can be\n\ * done in constant time using the TRANS and SIGNS options. See DORCSD\n\ * for details.)\n\ *\n\ * The orthogonal matrices P1, P2, Q1, and Q2 are P-by-P, (M-P)-by-\n\ * (M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. They are\n\ * represented implicitly by Householder vectors.\n\ *\n\ * B11, B12, B21, and B22 are Q-by-Q bidiagonal matrices represented\n\ * implicitly by angles THETA, PHI.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER\n\ * = 'T': X, U1, U2, V1T, and V2T are stored in row-major\n\ * order;\n\ * otherwise: X, U1, U2, V1T, and V2T are stored in column-\n\ * major order.\n\ *\n\ * SIGNS (input) CHARACTER\n\ * = 'O': The lower-left block is made nonpositive (the\n\ * \"other\" convention);\n\ * otherwise: The upper-right block is made nonpositive (the\n\ * \"default\" convention).\n\ *\n\ * M (input) INTEGER\n\ * The number of rows and columns in X.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows in X11 and X12. 0 <= P <= M.\n\ *\n\ * Q (input) INTEGER\n\ * The number of columns in X11 and X21. 0 <= Q <=\n\ * MIN(P,M-P,M-Q).\n\ *\n\ * X11 (input/output) DOUBLE PRECISION array, dimension (LDX11,Q)\n\ * On entry, the top-left block of the orthogonal matrix to be\n\ * reduced. On exit, the form depends on TRANS:\n\ * If TRANS = 'N', then\n\ * the columns of tril(X11) specify reflectors for P1,\n\ * the rows of triu(X11,1) specify reflectors for Q1;\n\ * else TRANS = 'T', and\n\ * the rows of triu(X11) specify reflectors for P1,\n\ * the columns of tril(X11,-1) specify reflectors for Q1.\n\ *\n\ * LDX11 (input) INTEGER\n\ * The leading dimension of X11. If TRANS = 'N', then LDX11 >=\n\ * P; else LDX11 >= Q.\n\ *\n\ * X12 (input/output) DOUBLE PRECISION array, dimension (LDX12,M-Q)\n\ * On entry, the top-right block of the orthogonal matrix to\n\ * be reduced. On exit, the form depends on TRANS:\n\ * If TRANS = 'N', then\n\ * the rows of triu(X12) specify the first P reflectors for\n\ * Q2;\n\ * else TRANS = 'T', and\n\ * the columns of tril(X12) specify the first P reflectors\n\ * for Q2.\n\ *\n\ * LDX12 (input) INTEGER\n\ * The leading dimension of X12. If TRANS = 'N', then LDX12 >=\n\ * P; else LDX11 >= M-Q.\n\ *\n\ * X21 (input/output) DOUBLE PRECISION array, dimension (LDX21,Q)\n\ * On entry, the bottom-left block of the orthogonal matrix to\n\ * be reduced. On exit, the form depends on TRANS:\n\ * If TRANS = 'N', then\n\ * the columns of tril(X21) specify reflectors for P2;\n\ * else TRANS = 'T', and\n\ * the rows of triu(X21) specify reflectors for P2.\n\ *\n\ * LDX21 (input) INTEGER\n\ * The leading dimension of X21. If TRANS = 'N', then LDX21 >=\n\ * M-P; else LDX21 >= Q.\n\ *\n\ * X22 (input/output) DOUBLE PRECISION array, dimension (LDX22,M-Q)\n\ * On entry, the bottom-right block of the orthogonal matrix to\n\ * be reduced. On exit, the form depends on TRANS:\n\ * If TRANS = 'N', then\n\ * the rows of triu(X22(Q+1:M-P,P+1:M-Q)) specify the last\n\ * M-P-Q reflectors for Q2,\n\ * else TRANS = 'T', and\n\ * the columns of tril(X22(P+1:M-Q,Q+1:M-P)) specify the last\n\ * M-P-Q reflectors for P2.\n\ *\n\ * LDX22 (input) INTEGER\n\ * The leading dimension of X22. If TRANS = 'N', then LDX22 >=\n\ * M-P; else LDX22 >= M-Q.\n\ *\n\ * THETA (output) DOUBLE PRECISION array, dimension (Q)\n\ * The entries of the bidiagonal blocks B11, B12, B21, B22 can\n\ * be computed from the angles THETA and PHI. See Further\n\ * Details.\n\ *\n\ * PHI (output) DOUBLE PRECISION array, dimension (Q-1)\n\ * The entries of the bidiagonal blocks B11, B12, B21, B22 can\n\ * be computed from the angles THETA and PHI. See Further\n\ * Details.\n\ *\n\ * TAUP1 (output) DOUBLE PRECISION array, dimension (P)\n\ * The scalar factors of the elementary reflectors that define\n\ * P1.\n\ *\n\ * TAUP2 (output) DOUBLE PRECISION array, dimension (M-P)\n\ * The scalar factors of the elementary reflectors that define\n\ * P2.\n\ *\n\ * TAUQ1 (output) DOUBLE PRECISION array, dimension (Q)\n\ * The scalar factors of the elementary reflectors that define\n\ * Q1.\n\ *\n\ * TAUQ2 (output) DOUBLE PRECISION array, dimension (M-Q)\n\ * The scalar factors of the elementary reflectors that define\n\ * Q2.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK >= M-Q.\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 bidiagonal blocks B11, B12, B21, and B22 are represented\n\ * implicitly by angles THETA(1), ..., THETA(Q) and PHI(1), ...,\n\ * PHI(Q-1). B11 and B21 are upper bidiagonal, while B21 and B22 are\n\ * lower bidiagonal. Every entry in each bidiagonal band is a product\n\ * of a sine or cosine of a THETA with a sine or cosine of a PHI. See\n\ * [1] or DORCSD for details.\n\ *\n\ * P1, P2, Q1, and Q2 are represented as products of elementary\n\ * reflectors. See DORCSD for details on generating P1, P2, Q1, and Q2\n\ * using DORGQR and DORGLQ.\n\ *\n\ * Reference\n\ * =========\n\ *\n\ * [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.\n\ * Algorithms, 50(1):33-65, 2009.\n\ *\n\ * ====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sormr20000644000175000017500000000724312502223526016442 0ustar uwabamiuwabami--- :name: sormr2 :md5sum: 5fd8bdc69537641d2383d642976a1f39 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SORMR2 overwrites the general real m by n matrix C with\n\ *\n\ * Q * C if SIDE = 'L' and TRANS = 'N', or\n\ *\n\ * Q'* C if SIDE = 'L' and TRANS = 'T', or\n\ *\n\ * C * Q if SIDE = 'R' and TRANS = 'N', or\n\ *\n\ * C * Q' if SIDE = 'R' and TRANS = 'T',\n\ *\n\ * where Q is a real orthogonal matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by SGERQF. Q is of order m if SIDE = 'L' and of order n\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q' from the Left\n\ * = 'R': apply Q or Q' from the Right\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': apply Q (No transpose)\n\ * = 'T': apply Q' (Transpose)\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) REAL array, dimension\n\ * (LDA,M) if SIDE = 'L',\n\ * (LDA,N) if SIDE = 'R'\n\ * The i-th row must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * SGERQF in the last k rows of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,K).\n\ *\n\ * TAU (input) REAL array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by SGERQF.\n\ *\n\ * C (input/output) REAL array, dimension (LDC,N)\n\ * On entry, the m by n matrix C.\n\ * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) REAL array, dimension\n\ * (N) if SIDE = 'L',\n\ * (M) if SIDE = 'R'\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgerqf0000644000175000017500000000751412502223526016467 0ustar uwabamiuwabami--- :name: dgerqf :md5sum: 522daeb5235e5276cf26a8dc9440df57 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - MIN(m,n) - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGERQF computes an RQ factorization of a real M-by-N matrix A:\n\ * A = R * 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,\n\ * if m <= n, the upper triangle of the subarray\n\ * A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R;\n\ * if m >= n, the elements on and above the (m-n)-th subdiagonal\n\ * contain the M-by-N upper trapezoidal matrix R;\n\ * the remaining elements, with the array TAU, represent the\n\ * orthogonal matrix Q as a product of min(m,n) elementary\n\ * 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\n\ * the 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(1) H(2) . . . H(k), 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(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n\ * A(m-k+i,1:n-k+i-1), and tau in TAU(i).\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n $ MU, NB, NBMIN, NU, NX\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DGERQ2, DLARFB, DLARFT, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlarnv0000644000175000017500000000335712502223526016506 0ustar uwabamiuwabami--- :name: dlarnv :md5sum: dad4be46eef825d7419dd9092100cb4d :category: :subroutine :arguments: - idist: :type: integer :intent: input - iseed: :type: integer :intent: input/output :dims: - "4" - n: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - MAX(1,n) :substitutions: {} :fortran_help: " SUBROUTINE DLARNV( IDIST, ISEED, N, X )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLARNV returns a vector of n random real numbers from a uniform or\n\ * normal distribution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * IDIST (input) INTEGER\n\ * Specifies the distribution of the random numbers:\n\ * = 1: uniform (0,1)\n\ * = 2: uniform (-1,1)\n\ * = 3: normal (0,1)\n\ *\n\ * ISEED (input/output) INTEGER array, dimension (4)\n\ * On entry, the seed of the random number generator; the array\n\ * elements must be between 0 and 4095, and ISEED(4) must be\n\ * odd.\n\ * On exit, the seed is updated.\n\ *\n\ * N (input) INTEGER\n\ * The number of random numbers to be generated.\n\ *\n\ * X (output) DOUBLE PRECISION array, dimension (N)\n\ * The generated random numbers.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * This routine calls the auxiliary routine DLARUV to generate random\n\ * real numbers from a uniform (0,1) distribution, in batches of up to\n\ * 128 using vectorisable code. The Box-Muller method is used to\n\ * transform numbers from a uniform to a normal distribution.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlantr0000644000175000017500000000732112502223526016525 0ustar uwabamiuwabami--- :name: zlantr :md5sum: 9d1a08cb51c9b20cc3eee17c6a416266 :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? m : 0" :fortran_help: " DOUBLE PRECISION FUNCTION ZLANTR( NORM, UPLO, DIAG, M, N, A, LDA, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLANTR returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * trapezoidal or triangular matrix A.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * ZLANTR returns the value\n\ *\n\ * ZLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in ZLANTR as described\n\ * above.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the matrix A is upper or lower trapezoidal.\n\ * = 'U': Upper trapezoidal\n\ * = 'L': Lower trapezoidal\n\ * Note that A is triangular instead of trapezoidal if M = N.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * Specifies whether or not the matrix A has unit diagonal.\n\ * = 'N': Non-unit diagonal\n\ * = 'U': Unit diagonal\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A. M >= 0, and if\n\ * UPLO = 'U', M <= N. When M = 0, ZLANTR is set to zero.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix A. N >= 0, and if\n\ * UPLO = 'L', N <= M. When N = 0, ZLANTR is set to zero.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The trapezoidal matrix A (A is triangular if M = N).\n\ * If UPLO = 'U', the leading m by n upper trapezoidal part of\n\ * the array A contains the upper trapezoidal matrix, and the\n\ * strictly lower triangular part of A is not referenced.\n\ * If UPLO = 'L', the leading m by n lower trapezoidal part of\n\ * the array A contains the lower trapezoidal matrix, and the\n\ * strictly upper triangular part of A is not referenced. Note\n\ * that when DIAG = 'U', the diagonal elements of A are not\n\ * referenced and are assumed to be one.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(M,1).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n\ * referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dtbtrs0000644000175000017500000000667712502223526016532 0ustar uwabamiuwabami--- :name: dtbtrs :md5sum: c3eff624478a9d6e74b0f64935c8c5f3 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTBTRS solves a triangular system of the form\n\ *\n\ * A * X = B or A**T * X = B,\n\ *\n\ * where A is a triangular band matrix of order N, and B is an\n\ * N-by NRHS matrix. A check is made to verify that A is nonsingular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose = Transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals or subdiagonals of the\n\ * triangular band matrix A. KD >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * The upper or lower triangular band matrix A, stored in the\n\ * first kd+1 rows of AB. The j-th column of A is stored\n\ * in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ * If DIAG = 'U', the diagonal elements of A are not referenced\n\ * and are assumed to be 1.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, if INFO = 0, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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 A is zero,\n\ * indicating that the matrix is singular and the\n\ * solutions X have not been computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlantb0000644000175000017500000000712612502223526016462 0ustar uwabamiuwabami--- :name: dlantb :md5sum: e69b4aec54ed535659db6b5c4040807d :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? n : 0" :fortran_help: " DOUBLE PRECISION FUNCTION DLANTB( NORM, UPLO, DIAG, N, K, AB, LDAB, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLANTB returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of an\n\ * n by n triangular band matrix A, with ( k + 1 ) diagonals.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * DLANTB returns the value\n\ *\n\ * DLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in DLANTB as described\n\ * above.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the matrix A is upper or lower triangular.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * Specifies whether or not the matrix A is unit triangular.\n\ * = 'N': Non-unit triangular\n\ * = 'U': Unit triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, DLANTB is\n\ * set to zero.\n\ *\n\ * K (input) INTEGER\n\ * The number of super-diagonals of the matrix A if UPLO = 'U',\n\ * or the number of sub-diagonals of the matrix A if UPLO = 'L'.\n\ * K >= 0.\n\ *\n\ * AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * The upper or lower triangular band matrix A, stored in the\n\ * first k+1 rows of AB. The j-th column of A is stored\n\ * in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).\n\ * Note that when DIAG = 'U', the elements of the array AB\n\ * corresponding to the diagonal elements of the matrix A are\n\ * not referenced, but are assumed to be one.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= K+1.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n\ * referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slatps0000644000175000017500000001610312502223526016517 0ustar uwabamiuwabami--- :name: slatps :md5sum: 566e5a5dc28413e0003d6c0a705a6d4b :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - normin: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input :dims: - n*(n+1)/2 - x: :type: real :intent: input/output :dims: - n - scale: :type: real :intent: output - cnorm: :type: real :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, CNORM, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLATPS solves one of the triangular systems\n\ *\n\ * A *x = s*b or A'*x = s*b\n\ *\n\ * with scaling to prevent overflow, where A is an upper or lower\n\ * triangular matrix stored in packed form. Here A' denotes the\n\ * transpose of A, x and b are n-element vectors, and s is a scaling\n\ * factor, usually less than or equal to 1, chosen so that the\n\ * components of x will be less than the overflow threshold. If the\n\ * unscaled problem will not cause overflow, the Level 2 BLAS routine\n\ * STPSV is called. If the matrix A is singular (A(j,j) = 0 for some j),\n\ * then s is set to 0 and a non-trivial solution to A*x = 0 is returned.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the matrix A is upper or lower triangular.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the operation applied to A.\n\ * = 'N': Solve A * x = s*b (No transpose)\n\ * = 'T': Solve A'* x = s*b (Transpose)\n\ * = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * Specifies whether or not the matrix A is unit triangular.\n\ * = 'N': Non-unit triangular\n\ * = 'U': Unit triangular\n\ *\n\ * NORMIN (input) CHARACTER*1\n\ * Specifies whether CNORM has been set or not.\n\ * = 'Y': CNORM contains the column norms on entry\n\ * = 'N': CNORM is not set on entry. On exit, the norms will\n\ * be computed and stored in CNORM.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input) REAL array, dimension (N*(N+1)/2)\n\ * The upper or lower triangular matrix A, packed columnwise in\n\ * a linear array. The j-th column of A is stored in the array\n\ * AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * X (input/output) REAL array, dimension (N)\n\ * On entry, the right hand side b of the triangular system.\n\ * On exit, X is overwritten by the solution vector x.\n\ *\n\ * SCALE (output) REAL\n\ * The scaling factor s for the triangular system\n\ * A * x = s*b or A'* x = s*b.\n\ * If SCALE = 0, the matrix A is singular or badly scaled, and\n\ * the vector x is an exact or approximate solution to A*x = 0.\n\ *\n\ * CNORM (input or output) REAL array, dimension (N)\n\ *\n\ * If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n\ * contains the norm of the off-diagonal part of the j-th column\n\ * of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n\ * to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n\ * must be greater than or equal to the 1-norm.\n\ *\n\ * If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n\ * returns the 1-norm of the offdiagonal part of the j-th column\n\ * of A.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ *\n\n\ * Further Details\n\ * ======= =======\n\ *\n\ * A rough bound on x is computed; if that is less than overflow, STPSV\n\ * is called, otherwise, specific code is used which checks for possible\n\ * overflow or divide-by-zero at every operation.\n\ *\n\ * A columnwise scheme is used for solving A*x = b. The basic algorithm\n\ * if A is lower triangular is\n\ *\n\ * x[1:n] := b[1:n]\n\ * for j = 1, ..., n\n\ * x(j) := x(j) / A(j,j)\n\ * x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n\ * end\n\ *\n\ * Define bounds on the components of x after j iterations of the loop:\n\ * M(j) = bound on x[1:j]\n\ * G(j) = bound on x[j+1:n]\n\ * Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n\ *\n\ * Then for iteration j+1 we have\n\ * M(j+1) <= G(j) / | A(j+1,j+1) |\n\ * G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n\ * <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n\ *\n\ * where CNORM(j+1) is greater than or equal to the infinity-norm of\n\ * column j+1 of A, not counting the diagonal. Hence\n\ *\n\ * G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n\ * 1<=i<=j\n\ * and\n\ *\n\ * |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n\ * 1<=i< j\n\ *\n\ * Since |x(j)| <= M(j), we use the Level 2 BLAS routine STPSV if the\n\ * reciprocal of the largest M(j), j=1,..,n, is larger than\n\ * max(underflow, 1/overflow).\n\ *\n\ * The bound on x(j) is also used to determine when a step in the\n\ * columnwise method can be performed without fear of overflow. If\n\ * the computed bound is greater than a large constant, x is scaled to\n\ * prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n\ * 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n\ *\n\ * Similarly, a row-wise scheme is used to solve A'*x = b. The basic\n\ * algorithm for A upper triangular is\n\ *\n\ * for j = 1, ..., n\n\ * x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n\ * end\n\ *\n\ * We simultaneously compute two bounds\n\ * G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n\ * M(j) = bound on x(i), 1<=i<=j\n\ *\n\ * The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n\ * add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n\ * Then the bound on x(j) is\n\ *\n\ * M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n\ *\n\ * <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n\ * 1<=i<=j\n\ *\n\ * and we can safely call STPSV if 1/M(n) and 1/G(n) are both greater\n\ * than max(underflow, 1/overflow).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clartg0000644000175000017500000000342712502223525016471 0ustar uwabamiuwabami--- :name: clartg :md5sum: aa8c43ad25ac528306b6dc6dd6d172f6 :category: :subroutine :arguments: - f: :type: complex :intent: input - g: :type: complex :intent: input - cs: :type: real :intent: output - sn: :type: complex :intent: output - r: :type: complex :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CLARTG( F, G, CS, SN, R )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLARTG generates a plane rotation so that\n\ *\n\ * [ CS SN ] [ F ] [ R ]\n\ * [ __ ] . [ ] = [ ] where CS**2 + |SN|**2 = 1.\n\ * [ -SN CS ] [ G ] [ 0 ]\n\ *\n\ * This is a faster version of the BLAS1 routine CROTG, except for\n\ * the following differences:\n\ * F and G are unchanged on return.\n\ * If G=0, then CS=1 and SN=0.\n\ * If F=0, then CS=0 and SN is chosen so that R is real.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * F (input) COMPLEX\n\ * The first component of vector to be rotated.\n\ *\n\ * G (input) COMPLEX\n\ * The second component of vector to be rotated.\n\ *\n\ * CS (output) REAL\n\ * The cosine of the rotation.\n\ *\n\ * SN (output) COMPLEX\n\ * The sine of the rotation.\n\ *\n\ * R (output) COMPLEX\n\ * The nonzero component of the rotated vector.\n\ *\n\n\ * Further Details\n\ * ======= =======\n\ *\n\ * 3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel\n\ *\n\ * This version has a few statements commented out for thread safety\n\ * (machine parameters are computed on each entry). 10 feb 03, SJH.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgbsvx0000644000175000017500000003441012502223526016526 0ustar uwabamiuwabami--- :name: sgbsvx :md5sum: 624316c11a224f632a298e7839e4c07a :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: real :intent: input/output :dims: - ldafb - n :option: true - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n :option: true - equed: :type: char :intent: input/output :option: true - r: :type: real :intent: input/output :dims: - n :option: true - c: :type: real :intent: input/output :dims: - n :option: true - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: output :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: n ldafb: 2*kl+ku+1 :fortran_help: " SUBROUTINE SGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGBSVX uses the LU factorization to compute the solution to a real\n\ * system of linear equations A * X = B, A**T * X = B, or A**H * X = B,\n\ * where A is a band matrix of order N with KL subdiagonals and KU\n\ * superdiagonals, and X and B are N-by-NRHS matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed by this subroutine:\n\ *\n\ * 1. If FACT = 'E', real scaling factors are computed to equilibrate\n\ * the system:\n\ * TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n\ * TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n\ * TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n\ * or diag(C)*B (if TRANS = 'T' or 'C').\n\ *\n\ * 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n\ * matrix A (after equilibration if FACT = 'E') as\n\ * A = L * U,\n\ * where L is a product of permutation and unit lower triangular\n\ * matrices with KL subdiagonals, and U is upper triangular with\n\ * KL+KU superdiagonals.\n\ *\n\ * 3. If some U(i,i)=0, so that U is exactly singular, then the routine\n\ * returns with INFO = i. Otherwise, the factored form of A is used\n\ * to estimate the condition number of the matrix A. If the\n\ * reciprocal of the condition number is less than machine precision,\n\ * INFO = N+1 is returned as a warning, but the routine still goes on\n\ * to solve for X and compute error bounds as described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n\ * that it solves the original system before equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AFB and IPIV contain the factored form of\n\ * A. If EQUED is not 'N', the matrix A has been\n\ * equilibrated with scaling factors given by R and C.\n\ * AB, AFB, and IPIV are not modified.\n\ * = 'N': The matrix A will be copied to AFB and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AFB and factored.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations.\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AB (input/output) REAL array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n\ *\n\ * If FACT = 'F' and EQUED is not 'N', then A must have been\n\ * equilibrated by the scaling factors in R and/or C. AB is not\n\ * modified if FACT = 'F' or 'N', or if FACT = 'E' and\n\ * EQUED = 'N' on exit.\n\ *\n\ * On exit, if EQUED .ne. 'N', A is scaled as follows:\n\ * EQUED = 'R': A := diag(R) * A\n\ * EQUED = 'C': A := A * diag(C)\n\ * EQUED = 'B': A := diag(R) * A * diag(C).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * AFB (input or output) REAL array, dimension (LDAFB,N)\n\ * If FACT = 'F', then AFB is an input argument and on entry\n\ * contains details of the LU factorization of the band matrix\n\ * A, as computed by SGBTRF. U is stored as an upper triangular\n\ * band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n\ * and the multipliers used during the factorization are stored\n\ * in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is\n\ * the factored form of the equilibrated matrix A.\n\ *\n\ * If FACT = 'N', then AFB is an output argument and on exit\n\ * returns details of the LU factorization of A.\n\ *\n\ * If FACT = 'E', then AFB is an output argument and on exit\n\ * returns details of the LU factorization of the equilibrated\n\ * matrix A (see the description of AB for the form of the\n\ * equilibrated matrix).\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains the pivot indices from the factorization A = L*U\n\ * as computed by SGBTRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = L*U\n\ * of the original matrix A.\n\ *\n\ * If FACT = 'E', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = L*U\n\ * of the equilibrated matrix A.\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * R (input or output) REAL array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'R' or 'B', A is\n\ * multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n\ * is not accessed. R is an input argument if FACT = 'F';\n\ * otherwise, R is an output argument. If FACT = 'F' and\n\ * EQUED = 'R' or 'B', each element of R must be positive.\n\ *\n\ * C (input or output) REAL array, dimension (N)\n\ * The column scale factors for A. If EQUED = 'C' or 'B', A is\n\ * multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n\ * is not accessed. C is an input argument if FACT = 'F';\n\ * otherwise, C is an output argument. If FACT = 'F' and\n\ * EQUED = 'C' or 'B', each element of C must be positive.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit,\n\ * if EQUED = 'N', B is not modified;\n\ * if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n\ * diag(R)*B;\n\ * if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n\ * overwritten by diag(C)*B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) REAL array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n\ * to the original system of equations. Note that A and B are\n\ * modified on exit if EQUED .ne. 'N', and the solution to the\n\ * equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n\ * EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n\ * and EQUED = 'R' or 'B'.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A after equilibration (if done). If RCOND is less than the\n\ * machine precision (in particular, if RCOND = 0), the matrix\n\ * is singular to working precision. This condition is\n\ * indicated by a return code of INFO > 0.\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace/output) REAL array, dimension (3*N)\n\ * On exit, WORK(1) contains the reciprocal pivot growth\n\ * factor norm(A)/norm(U). The \"max absolute element\" norm is\n\ * used. If WORK(1) is much less than 1, then the stability\n\ * of the LU factorization of the (equilibrated) matrix A\n\ * could be poor. This also means that the solution X, condition\n\ * estimator RCOND, and forward error bound FERR could be\n\ * unreliable. If factorization fails with 0 0: if INFO = i, and i is\n\ * <= N: U(i,i) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, so the solution and error bounds\n\ * could not be computed. RCOND = 0 is returned.\n\ * = N+1: U is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ *\n\ * value of RCOND would suggest.\n\n\ * =====================================================================\n\ * Moved setting of INFO = N+1 so INFO does not subsequently get\n\ * overwritten. Sven, 17 Mar 05. \n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slar2v0000644000175000017500000000450112502223526016421 0ustar uwabamiuwabami--- :name: slar2v :md5sum: 7102f5b9b61fb66f1047047d8464c701 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - 1+(n-1)*incx - y: :type: real :intent: input/output :dims: - 1+(n-1)*incx - z: :type: real :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - c: :type: real :intent: input :dims: - 1+(n-1)*incc - s: :type: real :intent: input :dims: - 1+(n-1)*incc - incc: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE SLAR2V( N, X, Y, Z, INCX, C, S, INCC )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAR2V applies a vector of real plane rotations from both sides to\n\ * a sequence of 2-by-2 real symmetric matrices, defined by the elements\n\ * of the vectors x, y and z. For i = 1,2,...,n\n\ *\n\ * ( x(i) z(i) ) := ( c(i) s(i) ) ( x(i) z(i) ) ( c(i) -s(i) )\n\ * ( z(i) y(i) ) ( -s(i) c(i) ) ( z(i) y(i) ) ( s(i) c(i) )\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of plane rotations to be applied.\n\ *\n\ * X (input/output) REAL array,\n\ * dimension (1+(N-1)*INCX)\n\ * The vector x.\n\ *\n\ * Y (input/output) REAL array,\n\ * dimension (1+(N-1)*INCX)\n\ * The vector y.\n\ *\n\ * Z (input/output) REAL array,\n\ * dimension (1+(N-1)*INCX)\n\ * The vector z.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between elements of X, Y and Z. INCX > 0.\n\ *\n\ * C (input) REAL array, dimension (1+(N-1)*INCC)\n\ * The cosines of the plane rotations.\n\ *\n\ * S (input) REAL array, dimension (1+(N-1)*INCC)\n\ * The sines of the plane rotations.\n\ *\n\ * INCC (input) INTEGER\n\ * The increment between elements of C and S. INCC > 0.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, IC, IX\n REAL CI, SI, T1, T2, T3, T4, T5, T6, XI, YI, ZI\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/csytrf0000644000175000017500000001447212502223525016531 0ustar uwabamiuwabami--- :name: csytrf :md5sum: dcc01e01acbde525a3b24fce6f4fc7b1 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSYTRF computes the factorization of a complex symmetric matrix A\n\ * using the Bunch-Kaufman diagonal pivoting method. The form of the\n\ * factorization is\n\ *\n\ * A = U*D*U**T or A = L*D*L**T\n\ *\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, and D is symmetric and block diagonal with\n\ * with 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\ * This is the blocked version of the algorithm, calling Level 3 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L (see below for further details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D.\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of WORK. LWORK >=1. For best performance\n\ * LWORK >= N*NB, where NB is the block size returned by ILAENV.\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, D(i,i) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular, and division by zero will occur if it\n\ * is used to solve a system of equations.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * If UPLO = 'U', then A = U*D*U', where\n\ * U = P(n)*U(n)* ... *P(k)U(k)* ...,\n\ * i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n\ * 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I v 0 ) k-s\n\ * U(k) = ( 0 I 0 ) s\n\ * ( 0 0 I ) n-k\n\ * k-s s n-k\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n\ * If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n\ * and A(k,k), and v overwrites A(1:k-2,k-1:k).\n\ *\n\ * If UPLO = 'L', then A = L*D*L', where\n\ * L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n\ * i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n\ * n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I 0 0 ) k-1\n\ * L(k) = ( 0 I 0 ) s\n\ * ( 0 v I ) n-k-s+1\n\ * k-1 s n-k-s+1\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n\ * If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n\ * and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LQUERY, UPPER\n INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CLASYF, CSYTF2, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dorm2l0000644000175000017500000000732112502223526016412 0ustar uwabamiuwabami--- :name: dorm2l :md5sum: bf848d9455fb1572cc2de061259422ae :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DORM2L overwrites the general real m by n matrix C with\n\ *\n\ * Q * C if SIDE = 'L' and TRANS = 'N', or\n\ *\n\ * Q'* C if SIDE = 'L' and TRANS = 'T', or\n\ *\n\ * C * Q if SIDE = 'R' and TRANS = 'N', or\n\ *\n\ * C * Q' if SIDE = 'R' and TRANS = 'T',\n\ *\n\ * where Q is a real orthogonal matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(k) . . . H(2) H(1)\n\ *\n\ * as returned by DGEQLF. Q is of order m if SIDE = 'L' and of order n\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q' from the Left\n\ * = 'R': apply Q or Q' from the Right\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': apply Q (No transpose)\n\ * = 'T': apply Q' (Transpose)\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,K)\n\ * The i-th column must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * DGEQLF in the last k columns of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ * If SIDE = 'L', LDA >= max(1,M);\n\ * if SIDE = 'R', LDA >= max(1,N).\n\ *\n\ * TAU (input) DOUBLE PRECISION array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by DGEQLF.\n\ *\n\ * C (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n\ * On entry, the m by n matrix C.\n\ * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension\n\ * (N) if SIDE = 'L',\n\ * (M) if SIDE = 'R'\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhetrs0000644000175000017500000000501012502223526016523 0ustar uwabamiuwabami--- :name: zhetrs :md5sum: 23eb0d09ccb9891c4e2ae7e710b35ca6 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZHETRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHETRS solves a system of linear equations A*X = B with a complex\n\ * Hermitian matrix A using the factorization A = U*D*U**H or\n\ * A = L*D*L**H computed by ZHETRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**H;\n\ * = 'L': Lower triangular, form is A = L*D*L**H.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by ZHETRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by ZHETRF.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssyconv0000644000175000017500000000507112502223526016717 0ustar uwabamiuwabami--- :name: ssyconv :md5sum: 119fb0834f75cb8910761daec667bf8a :category: :subroutine :arguments: - uplo: :type: char :intent: input - way: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: real :intent: workspace :dims: - MAX(1,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SSYCONV( UPLO, WAY, N, A, LDA, IPIV, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSYCONV convert A given by TRF into L and D and vice-versa.\n\ * Get Non-diag elements of D (returned in workspace) and \n\ * apply or reverse permutation done in TRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ * \n\ * WAY (input) CHARACTER*1\n\ * = 'C': Convert \n\ * = 'R': Revert\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by SSYTRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by SSYTRF.\n\ *\n\ * WORK (workspace) REAL array, dimension (N)\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of WORK. LWORK >=1. \n\ * LWORK = N\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dstevd0000644000175000017500000001175612502223526016513 0ustar uwabamiuwabami--- :name: dstevd :md5sum: ef38913916fd211c452fc4ca318213ff :category: :subroutine :arguments: - jobz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - z: :type: doublereal :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(lsame_(&jobz,\"N\")||n<=1) ? 1 : (lsame_(&jobz,\"V\")&&n>1) ? 1+4*n+n*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "(lsame_(&jobz,\"N\")||n<=1) ? 1 : (lsame_(&jobz,\"V\")&&n>1) ? 3+5*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" :fortran_help: " SUBROUTINE DSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSTEVD computes all eigenvalues and, optionally, eigenvectors of a\n\ * real symmetric tridiagonal matrix. If eigenvectors are desired, it\n\ * uses a divide and conquer algorithm.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the n diagonal elements of the tridiagonal matrix\n\ * A.\n\ * On exit, if INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * E (input/output) DOUBLE PRECISION array, dimension (N-1)\n\ * On entry, the (n-1) subdiagonal elements of the tridiagonal\n\ * matrix A, stored in elements 1 to N-1 of E.\n\ * On exit, the contents of E are destroyed.\n\ *\n\ * Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n\ * eigenvectors of the matrix A, with the i-th column of Z\n\ * holding the eigenvector associated with D(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace/output) DOUBLE PRECISION array,\n\ * dimension (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\ * If JOBZ = 'N' or N <= 1 then LWORK must be at least 1.\n\ * If JOBZ = 'V' and N > 1 then LWORK must be at least\n\ * ( 1 + 4*N + N**2 ).\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the optimal sizes of the WORK and IWORK\n\ * arrays, returns these values as the first entries of the WORK\n\ * and IWORK arrays, and no error message related to LWORK or\n\ * LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK.\n\ * If JOBZ = 'N' or N <= 1 then LIWORK must be at least 1.\n\ * If JOBZ = 'V' and N > 1 then LIWORK must be at least 3+5*N.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK and IWORK arrays, and no error message related to\n\ * LWORK or LIWORK 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 algorithm failed to converge; i\n\ * off-diagonal elements of E did not converge to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlapmr0000644000175000017500000000402212502223526016513 0ustar uwabamiuwabami--- :name: zlapmr :md5sum: 1282557fcda59064b1199667798f0e85 :category: :subroutine :arguments: - forwrd: :type: logical :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input - k: :type: integer :intent: input/output :dims: - m :substitutions: {} :fortran_help: " SUBROUTINE ZLAPMR( FORWRD, M, N, X, LDX, K )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAPMR rearranges the rows of the M by N matrix X as specified\n\ * by the permutation K(1),K(2),...,K(M) of the integers 1,...,M.\n\ * If FORWRD = .TRUE., forward permutation:\n\ *\n\ * X(K(I),*) is moved X(I,*) for I = 1,2,...,M.\n\ *\n\ * If FORWRD = .FALSE., backward permutation:\n\ *\n\ * X(I,*) is moved to X(K(I),*) for I = 1,2,...,M.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FORWRD (input) LOGICAL\n\ * = .TRUE., forward permutation\n\ * = .FALSE., backward permutation\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix X. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix X. N >= 0.\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension (LDX,N)\n\ * On entry, the M by N matrix X.\n\ * On exit, X contains the permuted matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X, LDX >= MAX(1,M).\n\ *\n\ * K (input/output) INTEGER array, dimension (M)\n\ * On entry, K contains the permutation vector. K is used as\n\ * internal workspace, but reset to its original value on\n\ * output.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, IN, J, JJ\n COMPLEX*16 TEMP\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zung2r0000644000175000017500000000446312502223526016446 0ustar uwabamiuwabami--- :name: zung2r :md5sum: 0a4e8b42c3f0427ffcc3bf1dcc07386e :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - work: :type: doublecomplex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZUNG2R generates an m by n complex matrix Q with orthonormal columns,\n\ * which is defined as the first n columns of a product of k elementary\n\ * reflectors of order m\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by ZGEQRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. M >= N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. N >= K >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the i-th column must contain the vector which\n\ * defines the elementary reflector H(i), for i = 1,2,...,k, as\n\ * returned by ZGEQRF in the first k columns of its array\n\ * argument A.\n\ * On exit, the m by n matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) COMPLEX*16 array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by ZGEQRF.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgesv0000644000175000017500000000610112502223526016344 0ustar uwabamiuwabami--- :name: zgesv :md5sum: b7f9978f4df659aa04f0e9358fe50f53 :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGESV computes the solution to a complex system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n\ *\n\ * The LU decomposition with partial pivoting and row interchanges is\n\ * used to factor A as\n\ * A = P * L * U,\n\ * where P is a permutation matrix, L is unit lower triangular, and U is\n\ * upper triangular. The factored form of A is then used to solve the\n\ * system of equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the N-by-N coefficient matrix A.\n\ * On exit, the factors L and U from the factorization\n\ * A = P*L*U; the unit diagonal elements of L are not stored.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * The pivot indices that define the permutation matrix P;\n\ * row i of the matrix was interchanged with row IPIV(i).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS matrix of right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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, U(i,i) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, so the solution could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZGETRF, ZGETRS\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sgtrfs0000644000175000017500000001262112502223526016522 0ustar uwabamiuwabami--- :name: sgtrfs :md5sum: 07d24cfa02e3c548ded77eb4cde10139 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: real :intent: input :dims: - n-1 - d: :type: real :intent: input :dims: - n - du: :type: real :intent: input :dims: - n-1 - dlf: :type: real :intent: input :dims: - n-1 - df: :type: real :intent: input :dims: - n - duf: :type: real :intent: input :dims: - n-1 - du2: :type: real :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGTRFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is tridiagonal, and provides\n\ * error bounds and backward error estimates for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * DL (input) REAL array, dimension (N-1)\n\ * The (n-1) subdiagonal elements of A.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The diagonal elements of A.\n\ *\n\ * DU (input) REAL array, dimension (N-1)\n\ * The (n-1) superdiagonal elements of A.\n\ *\n\ * DLF (input) REAL array, dimension (N-1)\n\ * The (n-1) multipliers that define the matrix L from the\n\ * LU factorization of A as computed by SGTTRF.\n\ *\n\ * DF (input) REAL array, dimension (N)\n\ * The n diagonal elements of the upper triangular matrix U from\n\ * the LU factorization of A.\n\ *\n\ * DUF (input) REAL array, dimension (N-1)\n\ * The (n-1) elements of the first superdiagonal of U.\n\ *\n\ * DU2 (input) REAL array, dimension (N-2)\n\ * The (n-2) elements of the second superdiagonal of U.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices; for 1 <= i <= n, row i of the matrix was\n\ * interchanged with row IPIV(i). IPIV(i) will always be either\n\ * i or i+1; IPIV(i) = i indicates a row interchange was not\n\ * required.\n\ *\n\ * B (input) REAL array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) REAL array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by SGTTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) REAL array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgeequb0000644000175000017500000000725612502223525016634 0ustar uwabamiuwabami--- :name: cgeequb :md5sum: f1ca33c27f777c5067e5fd5df188aa3e :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - r: :type: real :intent: output :dims: - m - c: :type: real :intent: output :dims: - n - rowcnd: :type: real :intent: output - colcnd: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE CGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGEEQUB computes row and column scalings intended to equilibrate an\n\ * M-by-N matrix A and reduce its condition number. R returns the row\n\ * scale factors and C the column scale factors, chosen to try to make\n\ * the largest element in each row and column of the matrix B with\n\ * elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n\ * the radix.\n\ *\n\ * R(i) and C(j) are restricted to be a power of the radix between\n\ * SMLNUM = smallest safe number and BIGNUM = largest safe number. Use\n\ * of these scaling factors is not guaranteed to reduce the condition\n\ * number of A but works well in practice.\n\ *\n\ * This routine differs from CGEEQU by restricting the scaling factors\n\ * to a power of the radix. Baring over- and underflow, scaling by\n\ * these factors introduces no additional rounding errors. However, the\n\ * scaled entries' magnitured are no longer approximately 1 but lie\n\ * between sqrt(radix) and 1/sqrt(radix).\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) COMPLEX array, dimension (LDA,N)\n\ * The M-by-N matrix whose equilibration factors are\n\ * to be computed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * R (output) REAL array, dimension (M)\n\ * If INFO = 0 or INFO > M, R contains the row scale factors\n\ * for A.\n\ *\n\ * C (output) REAL array, dimension (N)\n\ * If INFO = 0, C contains the column scale factors for A.\n\ *\n\ * ROWCND (output) REAL\n\ * If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n\ * smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n\ * AMAX is neither too large nor too small, it is not worth\n\ * scaling by R.\n\ *\n\ * COLCND (output) REAL\n\ * If INFO = 0, COLCND contains the ratio of the smallest\n\ * C(i) to the largest C(i). If COLCND >= 0.1, it is not\n\ * worth scaling by C.\n\ *\n\ * AMAX (output) REAL\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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, and i is\n\ * <= M: the i-th row of A is exactly zero\n\ * > M: the (i-M)-th column of A is exactly zero\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dtptrs0000644000175000017500000000572512502223526016541 0ustar uwabamiuwabami--- :name: dtptrs :md5sum: cbcbfa93edce4661de4773786622527f :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - n*(n+1)/2 - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTPTRS solves a triangular system of the form\n\ *\n\ * A * X = B or A**T * X = B,\n\ *\n\ * where A is a triangular matrix of order N stored in packed format,\n\ * and B is an N-by-NRHS matrix. A check is made to verify that A is\n\ * nonsingular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose = Transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * The upper or lower triangular matrix A, packed columnwise in\n\ * a linear array. The j-th column of A is stored in the array\n\ * AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, if INFO = 0, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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 A is zero,\n\ * indicating that the matrix is singular and the\n\ * solutions X have not been computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/stptrs0000644000175000017500000000566112502223526016557 0ustar uwabamiuwabami--- :name: stptrs :md5sum: 780738733718513efa60d63a4f9ef31f :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: real :intent: input :dims: - n*(n+1)/2 - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE STPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STPTRS solves a triangular system of the form\n\ *\n\ * A * X = B or A**T * X = B,\n\ *\n\ * where A is a triangular matrix of order N stored in packed format,\n\ * and B is an N-by-NRHS matrix. A check is made to verify that A is\n\ * nonsingular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose = Transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AP (input) REAL array, dimension (N*(N+1)/2)\n\ * The upper or lower triangular matrix A, packed columnwise in\n\ * a linear array. The j-th column of A is stored in the array\n\ * AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, if INFO = 0, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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 A is zero,\n\ * indicating that the matrix is singular and the\n\ * solutions X have not been computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgeqrfp0000644000175000017500000000730712502223526016647 0ustar uwabamiuwabami--- :name: dgeqrfp :md5sum: 639abd04a0431d1e20e6a81968c6f63e :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - MIN(m,n) - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGEQRFP computes a QR factorization of a real M-by-N matrix A:\n\ * A = Q * R.\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 above the diagonal of the array\n\ * contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n\ * upper triangular if m >= n); the elements below the diagonal,\n\ * with the array TAU, represent the orthogonal matrix Q as a\n\ * product of min(m,n) elementary reflectors (see Further\n\ * 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,N).\n\ * For optimum performance LWORK >= N*NB, where NB is\n\ * the 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(1) H(2) . . . H(k), 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:m) is stored on exit in A(i+1:m,i),\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 DGEQR2P, DLARFB, DLARFT, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/strtri0000644000175000017500000000455612502223526016551 0ustar uwabamiuwabami--- :name: strtri :md5sum: 26267687ec50d1af53ee98df1e50ae79 :category: :subroutine :arguments: - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE STRTRI( UPLO, DIAG, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STRTRI computes the inverse of a real upper or lower triangular\n\ * matrix A.\n\ *\n\ * This is the Level 3 BLAS version of the algorithm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the triangular matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of the array A contains\n\ * the upper triangular matrix, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of the array A contains\n\ * the lower triangular matrix, and the strictly upper\n\ * triangular part of A is not referenced. If DIAG = 'U', the\n\ * diagonal elements of A are also not referenced and are\n\ * assumed to be 1.\n\ * On exit, the (triangular) inverse of the original matrix, in\n\ * the same storage format.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\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, A(i,i) is exactly zero. The triangular\n\ * matrix is singular and its inverse can not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/spstrf0000644000175000017500000000672712502223526016545 0ustar uwabamiuwabami--- :name: spstrf :md5sum: 3aace2c5c80392dcbc18630e0ce90642 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - piv: :type: integer :intent: output :dims: - n - rank: :type: integer :intent: output - tol: :type: real :intent: input - work: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPSTRF computes the Cholesky factorization with complete\n\ * pivoting of a real symmetric positive semidefinite matrix A.\n\ *\n\ * The factorization has the form\n\ * P' * A * P = U' * U , if UPLO = 'U',\n\ * P' * A * P = L * L', if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is lower triangular, and\n\ * P is stored as vector PIV.\n\ *\n\ * This algorithm does not attempt to check that A is positive\n\ * semidefinite. This version of the algorithm calls level 3 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * n by n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n by n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the factor U or L from the Cholesky\n\ * factorization as above.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * PIV (output) INTEGER array, dimension (N)\n\ * PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n\ *\n\ * RANK (output) INTEGER\n\ * The rank of A given by the number of steps the algorithm\n\ * completed.\n\ *\n\ * TOL (input) REAL\n\ * User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) )\n\ * will be used. The algorithm terminates at the (K-1)st step\n\ * if the pivot <= TOL.\n\ *\n\ * WORK (workspace) REAL array, dimension (2*N)\n\ * Work space.\n\ *\n\ * INFO (output) INTEGER\n\ * < 0: If INFO = -K, the K-th argument had an illegal value,\n\ * = 0: algorithm completed successfully, and\n\ * > 0: the matrix A is either rank deficient with computed rank\n\ * as returned in RANK, or is indefinite. See Section 7 of\n\ * LAPACK Working Note #161 for further information.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssyevx0000644000175000017500000001727412502223526016564 0ustar uwabamiuwabami--- :name: ssyevx :md5sum: 875e9aa1a6f008f17488a10fac754ad6 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : 8*n" - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"I\") ? iu-il+1 : n" :fortran_help: " SUBROUTINE SSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSYEVX computes selected eigenvalues and, optionally, eigenvectors\n\ * of a real symmetric matrix A. Eigenvalues and eigenvectors can be\n\ * selected by specifying either a range of values or a range of indices\n\ * for the desired eigenvalues.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found.\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found.\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA, N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of A contains the\n\ * upper triangular part of the matrix A. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of A contains\n\ * the lower triangular part of the matrix A.\n\ * On exit, the lower triangle (if UPLO='L') or the upper\n\ * triangle (if UPLO='U') of A, including the diagonal, is\n\ * destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * VL (input) REAL\n\ * VU (input) REAL\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) REAL\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less than\n\ * or equal to zero, then EPS*|T| will be used in its place,\n\ * where |T| is the 1-norm of the tridiagonal matrix obtained\n\ * by reducing A to tridiagonal form.\n\ *\n\ * Eigenvalues will be computed most accurately when ABSTOL is\n\ * set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n\ * If this routine returns with INFO>0, indicating that some\n\ * eigenvectors did not converge, try setting ABSTOL to\n\ * 2*SLAMCH('S').\n\ *\n\ * See \"Computing Small Singular Values of Bidiagonal Matrices\n\ * with Guaranteed High Relative Accuracy,\" by Demmel and\n\ * Kahan, LAPACK Working Note #3.\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * On normal exit, the first M elements contain the selected\n\ * eigenvalues in ascending order.\n\ *\n\ * Z (output) REAL array, dimension (LDZ, max(1,M))\n\ * If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix A\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * If an eigenvector fails to converge, then that column of Z\n\ * contains the latest approximation to the eigenvector, and the\n\ * index of the eigenvector is returned in IFAIL.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of the array WORK. LWORK >= 1, when N <= 1;\n\ * otherwise 8*N.\n\ * For optimal efficiency, LWORK >= (NB+3)*N,\n\ * where NB is the max of the blocksize for SSYTRD and SORMTR\n\ * returned by ILAENV.\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\ * IWORK (workspace) INTEGER array, dimension (5*N)\n\ *\n\ * IFAIL (output) INTEGER array, dimension (N)\n\ * If JOBZ = 'V', then if INFO = 0, the first M elements of\n\ * IFAIL are zero. If INFO > 0, then IFAIL contains the\n\ * indices of the eigenvectors that failed to converge.\n\ * If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n\ * Their indices are stored in array IFAIL.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgeev0000644000175000017500000001142212502223525016300 0ustar uwabamiuwabami--- :name: cgeev :md5sum: 27dac225d8198b6ac4bce5bc6918a90a :category: :subroutine :arguments: - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - w: :type: complex :intent: output :dims: - n - vl: :type: complex :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: complex :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " SUBROUTINE CGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGEEV computes for an N-by-N complex nonsymmetric matrix A, the\n\ * eigenvalues and, optionally, the left and/or right eigenvectors.\n\ *\n\ * The right eigenvector v(j) of A satisfies\n\ * A * v(j) = lambda(j) * v(j)\n\ * where lambda(j) is its eigenvalue.\n\ * The left eigenvector u(j) of A satisfies\n\ * u(j)**H * A = lambda(j) * u(j)**H\n\ * where u(j)**H denotes the conjugate transpose of u(j).\n\ *\n\ * The computed eigenvectors are normalized to have Euclidean norm\n\ * equal to 1 and largest component real.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVL (input) CHARACTER*1\n\ * = 'N': left eigenvectors of A are not computed;\n\ * = 'V': left eigenvectors of are computed.\n\ *\n\ * JOBVR (input) CHARACTER*1\n\ * = 'N': right eigenvectors of A are not computed;\n\ * = 'V': right eigenvectors of A are computed.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ * On exit, A has been overwritten.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * W (output) COMPLEX array, dimension (N)\n\ * W contains the computed eigenvalues.\n\ *\n\ * VL (output) COMPLEX array, dimension (LDVL,N)\n\ * If JOBVL = 'V', the left eigenvectors u(j) are stored one\n\ * after another in the columns of VL, in the same order\n\ * as their eigenvalues.\n\ * If JOBVL = 'N', VL is not referenced.\n\ * u(j) = VL(:,j), the j-th column of VL.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the array VL. LDVL >= 1; if\n\ * JOBVL = 'V', LDVL >= N.\n\ *\n\ * VR (output) COMPLEX array, dimension (LDVR,N)\n\ * If JOBVR = 'V', the right eigenvectors v(j) are stored one\n\ * after another in the columns of VR, in the same order\n\ * as their eigenvalues.\n\ * If JOBVR = 'N', VR is not referenced.\n\ * v(j) = VR(:,j), the j-th column of VR.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the array VR. LDVR >= 1; if\n\ * JOBVR = 'V', LDVR >= N.\n\ *\n\ * WORK (workspace/output) COMPLEX 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,2*N).\n\ * For good performance, LWORK must generally be larger.\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\ * RWORK (workspace) REAL array, dimension (2*N)\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 QR algorithm failed to compute all the\n\ * eigenvalues, and no eigenvectors have been computed;\n\ * elements and i+1:N of W contain eigenvalues which have\n\ * converged.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sspsv0000644000175000017500000001151212502223526016366 0ustar uwabamiuwabami--- :name: sspsv :md5sum: 49f355fd85c3827ba9c219ecf5984c77 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: output :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: n: ldb :fortran_help: " SUBROUTINE SSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSPSV computes the solution to a real system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N symmetric matrix stored in packed format and X\n\ * and B are N-by-NRHS matrices.\n\ *\n\ * The diagonal pivoting method is used to factor A as\n\ * A = U * D * U**T, if UPLO = 'U', or\n\ * A = L * D * L**T, if UPLO = 'L',\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, D is symmetric and block diagonal with 1-by-1\n\ * and 2-by-2 diagonal blocks. The factored form of A is then used to\n\ * solve the system of equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AP (input/output) REAL array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ * See below for further details.\n\ *\n\ * On exit, the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L from the factorization\n\ * A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as\n\ * a packed triangular matrix in the same storage format as A.\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D, as\n\ * determined by SSPTRF. If IPIV(k) > 0, then rows and columns\n\ * k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n\ * diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n\ * then rows and columns k-1 and -IPIV(k) were interchanged and\n\ * D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n\ * IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n\ * -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n\ * diagonal block.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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, D(i,i) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular, so the solution could not be\n\ * computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The packed storage scheme is illustrated by the following example\n\ * when N = 4, UPLO = 'U':\n\ *\n\ * Two-dimensional storage of the symmetric matrix A:\n\ *\n\ * a11 a12 a13 a14\n\ * a22 a23 a24\n\ * a33 a34 (aij = aji)\n\ * a44\n\ *\n\ * Packed storage of the upper triangle of A:\n\ *\n\ * AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n\ *\n\ * =====================================================================\n\ *\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SSPTRF, SSPTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dopgtr0000644000175000017500000000452512502223526016515 0ustar uwabamiuwabami--- :name: dopgtr :md5sum: 3be95896182d344b40b94e108282b151 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - ldap - tau: :type: doublereal :intent: input :dims: - ldtau - q: :type: doublereal :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - n-1 - info: :type: integer :intent: output :substitutions: ldq: MAX(1,n) n: ldtau+1 :fortran_help: " SUBROUTINE DOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DOPGTR generates a real orthogonal matrix Q which is defined as the\n\ * product of n-1 elementary reflectors H(i) of order n, as returned by\n\ * DSPTRD using packed storage:\n\ *\n\ * if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),\n\ *\n\ * if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangular packed storage used in previous\n\ * call to DSPTRD;\n\ * = 'L': Lower triangular packed storage used in previous\n\ * call to DSPTRD.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix Q. N >= 0.\n\ *\n\ * AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * The vectors which define the elementary reflectors, as\n\ * returned by DSPTRD.\n\ *\n\ * TAU (input) DOUBLE PRECISION array, dimension (N-1)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by DSPTRD.\n\ *\n\ * Q (output) DOUBLE PRECISION array, dimension (LDQ,N)\n\ * The N-by-N orthogonal matrix Q.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (N-1)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cpotrf0000644000175000017500000000456412502223525016515 0ustar uwabamiuwabami--- :name: cpotrf :md5sum: e578ccb7a6444634bdf1983eb5cf16b9 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPOTRF( UPLO, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPOTRF computes the Cholesky factorization of a complex Hermitian\n\ * positive definite matrix A.\n\ *\n\ * The factorization has the form\n\ * A = U**H * U, if UPLO = 'U', or\n\ * A = L * L**H, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is lower triangular.\n\ *\n\ * This is the block version of the algorithm, calling Level 3 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the factor U or L from the Cholesky\n\ * factorization A = U**H*U or A = L*L**H.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\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 leading minor of order i is not\n\ * positive definite, and the factorization could not be\n\ * completed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sbdsqr0000644000175000017500000001645712502223526016523 0ustar uwabamiuwabami--- :name: sbdsqr :md5sum: 04608bac2e04ed2c5bbedb16150507ac :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ncvt: :type: integer :intent: input - nru: :type: integer :intent: input - ncc: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - vt: :type: real :intent: input/output :dims: - ldvt - ncvt - ldvt: :type: integer :intent: input - u: :type: real :intent: input/output :dims: - ldu - n - ldu: :type: integer :intent: input - c: :type: real :intent: input/output :dims: - ldc - ncc - ldc: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SBDSQR computes the singular values and, optionally, the right and/or\n\ * left singular vectors from the singular value decomposition (SVD) of\n\ * a real N-by-N (upper or lower) bidiagonal matrix B using the implicit\n\ * zero-shift QR algorithm. The SVD of B has the form\n\ * \n\ * B = Q * S * P**T\n\ * \n\ * where S is the diagonal matrix of singular values, Q is an orthogonal\n\ * matrix of left singular vectors, and P is an orthogonal matrix of\n\ * right singular vectors. If left singular vectors are requested, this\n\ * subroutine actually returns U*Q instead of Q, and, if right singular\n\ * vectors are requested, this subroutine returns P**T*VT instead of\n\ * P**T, for given real input matrices U and VT. When U and VT are the\n\ * orthogonal matrices that reduce a general matrix A to bidiagonal\n\ * form: A = U*B*VT, as computed by SGEBRD, then\n\ * \n\ * A = (U*Q) * S * (P**T*VT)\n\ * \n\ * is the SVD of A. Optionally, the subroutine may also compute Q**T*C\n\ * for a given real input matrix C.\n\ *\n\ * See \"Computing Small Singular Values of Bidiagonal Matrices With\n\ * Guaranteed High Relative Accuracy,\" by J. Demmel and W. Kahan,\n\ * LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,\n\ * no. 5, pp. 873-912, Sept 1990) and\n\ * \"Accurate singular values and differential qd algorithms,\" by\n\ * B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics\n\ * Department, University of California at Berkeley, July 1992\n\ * for a detailed description of the algorithm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': B is upper bidiagonal;\n\ * = 'L': B is lower bidiagonal.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix B. N >= 0.\n\ *\n\ * NCVT (input) INTEGER\n\ * The number of columns of the matrix VT. NCVT >= 0.\n\ *\n\ * NRU (input) INTEGER\n\ * The number of rows of the matrix U. NRU >= 0.\n\ *\n\ * NCC (input) INTEGER\n\ * The number of columns of the matrix C. NCC >= 0.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the n diagonal elements of the bidiagonal matrix B.\n\ * On exit, if INFO=0, the singular values of B in decreasing\n\ * order.\n\ *\n\ * E (input/output) REAL array, dimension (N-1)\n\ * On entry, the N-1 offdiagonal elements of the bidiagonal\n\ * matrix B.\n\ * On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E\n\ * will contain the diagonal and superdiagonal elements of a\n\ * bidiagonal matrix orthogonally equivalent to the one given\n\ * as input.\n\ *\n\ * VT (input/output) REAL array, dimension (LDVT, NCVT)\n\ * On entry, an N-by-NCVT matrix VT.\n\ * On exit, VT is overwritten by P**T * VT.\n\ * Not referenced if NCVT = 0.\n\ *\n\ * LDVT (input) INTEGER\n\ * The leading dimension of the array VT.\n\ * LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.\n\ *\n\ * U (input/output) REAL array, dimension (LDU, N)\n\ * On entry, an NRU-by-N matrix U.\n\ * On exit, U is overwritten by U * Q.\n\ * Not referenced if NRU = 0.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= max(1,NRU).\n\ *\n\ * C (input/output) REAL array, dimension (LDC, NCC)\n\ * On entry, an N-by-NCC matrix C.\n\ * On exit, C is overwritten by Q**T * C.\n\ * Not referenced if NCC = 0.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C.\n\ * LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.\n\ *\n\ * WORK (workspace) REAL array, dimension (4*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: If INFO = -i, the i-th argument had an illegal value\n\ * > 0:\n\ * if NCVT = NRU = NCC = 0,\n\ * = 1, a split was marked by a positive value in E\n\ * = 2, current block of Z not diagonalized after 30*N\n\ * iterations (in inner while loop)\n\ * = 3, termination criterion of outer while loop not met \n\ * (program created more than N unreduced blocks)\n\ * else NCVT = NRU = NCC = 0,\n\ * the algorithm did not converge; D and E contain the\n\ * elements of a bidiagonal matrix which is orthogonally\n\ * similar to the input matrix B; if INFO = i, i\n\ * elements of E have not converged to zero.\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * TOLMUL REAL, default = max(10,min(100,EPS**(-1/8)))\n\ * TOLMUL controls the convergence criterion of the QR loop.\n\ * If it is positive, TOLMUL*EPS is the desired relative\n\ * precision in the computed singular values.\n\ * If it is negative, abs(TOLMUL*EPS*sigma_max) is the\n\ * desired absolute accuracy in the computed singular\n\ * values (corresponds to relative accuracy\n\ * abs(TOLMUL*EPS) in the largest singular value.\n\ * abs(TOLMUL) should be between 1 and 1/EPS, and preferably\n\ * between 10 (for fast convergence) and .1/EPS\n\ * (for there to be some accuracy in the results).\n\ * Default is to lose at either one eighth or 2 of the\n\ * available decimal digits in each computed singular value\n\ * (whichever is smaller).\n\ *\n\ * MAXITR INTEGER, default = 6\n\ * MAXITR controls the maximum number of passes of the\n\ * algorithm through its inner loop. The algorithms stops\n\ * (and so fails to converge) if the number of passes\n\ * through the inner loop exceeds MAXITR*N**2.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ilatrans0000644000175000017500000000175612502223526017036 0ustar uwabamiuwabami--- :name: ilatrans :md5sum: acab13cd31e9e8595e98f380ecc03932 :category: :function :type: integer :arguments: - trans: :type: char :intent: input :substitutions: {} :fortran_help: " INTEGER FUNCTION ILATRANS( TRANS )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This subroutine translates from a character string specifying a\n\ * transposition operation to the relevant BLAST-specified integer\n\ * constant.\n\ *\n\ * ILATRANS returns an INTEGER. If ILATRANS < 0, then the input is not\n\ * a character indicating a transposition operator. Otherwise ILATRANS\n\ * returns the constant value corresponding to TRANS.\n\ *\n\n\ * Arguments\n\ * =========\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': No transpose\n\ * = 'T': Transpose\n\ * = 'C': Conjugate transpose\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctgsna0000644000175000017500000002363112502223525016473 0ustar uwabamiuwabami--- :name: ctgsna :md5sum: e17266654acf82fe202bcab72adebbe1 :category: :subroutine :arguments: - job: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - vl: :type: complex :intent: input :dims: - ldvl - m - ldvl: :type: integer :intent: input - vr: :type: complex :intent: input :dims: - ldvr - m - ldvr: :type: integer :intent: input - s: :type: real :intent: output :dims: - mm - dif: :type: real :intent: output :dims: - mm - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(lsame_(&job,\"V\")||lsame_(&job,\"B\")) ? 2*n*n : n" - iwork: :type: integer :intent: workspace :dims: - "lsame_(&job,\"E\") ? 0 : n+2" - info: :type: integer :intent: output :substitutions: mm: m :fortran_help: " SUBROUTINE CTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTGSNA estimates reciprocal condition numbers for specified\n\ * eigenvalues and/or eigenvectors of a matrix pair (A, B).\n\ *\n\ * (A, B) must be in generalized Schur canonical form, that is, A and\n\ * B are both upper triangular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * Specifies whether condition numbers are required for\n\ * eigenvalues (S) or eigenvectors (DIF):\n\ * = 'E': for eigenvalues only (S);\n\ * = 'V': for eigenvectors only (DIF);\n\ * = 'B': for both eigenvalues and eigenvectors (S and DIF).\n\ *\n\ * HOWMNY (input) CHARACTER*1\n\ * = 'A': compute condition numbers for all eigenpairs;\n\ * = 'S': compute condition numbers for selected eigenpairs\n\ * specified by the array SELECT.\n\ *\n\ * SELECT (input) LOGICAL array, dimension (N)\n\ * If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n\ * condition numbers are required. To select condition numbers\n\ * for the corresponding j-th eigenvalue and/or eigenvector,\n\ * SELECT(j) must be set to .TRUE..\n\ * If HOWMNY = 'A', SELECT is not referenced.\n\ *\n\ * N (input) INTEGER\n\ * The order of the square matrix pair (A, B). N >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The upper triangular matrix A in the pair (A,B).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,N)\n\ * The upper triangular matrix B in the pair (A, B).\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * VL (input) COMPLEX array, dimension (LDVL,M)\n\ * IF JOB = 'E' or 'B', VL must contain left eigenvectors of\n\ * (A, B), corresponding to the eigenpairs specified by HOWMNY\n\ * and SELECT. The eigenvectors must be stored in consecutive\n\ * columns of VL, as returned by CTGEVC.\n\ * If JOB = 'V', VL is not referenced.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the array VL. LDVL >= 1; and\n\ * If JOB = 'E' or 'B', LDVL >= N.\n\ *\n\ * VR (input) COMPLEX array, dimension (LDVR,M)\n\ * IF JOB = 'E' or 'B', VR must contain right eigenvectors of\n\ * (A, B), corresponding to the eigenpairs specified by HOWMNY\n\ * and SELECT. The eigenvectors must be stored in consecutive\n\ * columns of VR, as returned by CTGEVC.\n\ * If JOB = 'V', VR is not referenced.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the array VR. LDVR >= 1;\n\ * If JOB = 'E' or 'B', LDVR >= N.\n\ *\n\ * S (output) REAL array, dimension (MM)\n\ * If JOB = 'E' or 'B', the reciprocal condition numbers of the\n\ * selected eigenvalues, stored in consecutive elements of the\n\ * array.\n\ * If JOB = 'V', S is not referenced.\n\ *\n\ * DIF (output) REAL array, dimension (MM)\n\ * If JOB = 'V' or 'B', the estimated reciprocal condition\n\ * numbers of the selected eigenvectors, stored in consecutive\n\ * elements of the array.\n\ * If the eigenvalues cannot be reordered to compute DIF(j),\n\ * DIF(j) is set to 0; this can only occur when the true value\n\ * would be very small anyway.\n\ * For each eigenvalue/vector specified by SELECT, DIF stores\n\ * a Frobenius norm-based estimate of Difl.\n\ * If JOB = 'E', DIF is not referenced.\n\ *\n\ * MM (input) INTEGER\n\ * The number of elements in the arrays S and DIF. MM >= M.\n\ *\n\ * M (output) INTEGER\n\ * The number of elements of the arrays S and DIF used to store\n\ * the specified condition numbers; for each selected eigenvalue\n\ * one element is used. If HOWMNY = 'A', M is set to N.\n\ *\n\ * WORK (workspace/output) COMPLEX 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,N).\n\ * If JOB = 'V' or 'B', LWORK >= max(1,2*N*N).\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N+2)\n\ * If JOB = 'E', IWORK is not referenced.\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 reciprocal of the condition number of the i-th generalized\n\ * eigenvalue w = (a, b) is defined as\n\ *\n\ * S(I) = (|v'Au|**2 + |v'Bu|**2)**(1/2) / (norm(u)*norm(v))\n\ *\n\ * where u and v are the right and left eigenvectors of (A, B)\n\ * corresponding to w; |z| denotes the absolute value of the complex\n\ * number, and norm(u) denotes the 2-norm of the vector u. The pair\n\ * (a, b) corresponds to an eigenvalue w = a/b (= v'Au/v'Bu) of the\n\ * matrix pair (A, B). If both a and b equal zero, then (A,B) is\n\ * singular and S(I) = -1 is returned.\n\ *\n\ * An approximate error bound on the chordal distance between the i-th\n\ * computed generalized eigenvalue w and the corresponding exact\n\ * eigenvalue lambda is\n\ *\n\ * chord(w, lambda) <= EPS * norm(A, B) / S(I),\n\ *\n\ * where EPS is the machine precision.\n\ *\n\ * The reciprocal of the condition number of the right eigenvector u\n\ * and left eigenvector v corresponding to the generalized eigenvalue w\n\ * is defined as follows. Suppose\n\ *\n\ * (A, B) = ( a * ) ( b * ) 1\n\ * ( 0 A22 ),( 0 B22 ) n-1\n\ * 1 n-1 1 n-1\n\ *\n\ * Then the reciprocal condition number DIF(I) is\n\ *\n\ * Difl[(a, b), (A22, B22)] = sigma-min( Zl )\n\ *\n\ * where sigma-min(Zl) denotes the smallest singular value of\n\ *\n\ * Zl = [ kron(a, In-1) -kron(1, A22) ]\n\ * [ kron(b, In-1) -kron(1, B22) ].\n\ *\n\ * Here In-1 is the identity matrix of size n-1 and X' is the conjugate\n\ * transpose of X. kron(X, Y) is the Kronecker product between the\n\ * matrices X and Y.\n\ *\n\ * We approximate the smallest singular value of Zl with an upper\n\ * bound. This is done by CLATDF.\n\ *\n\ * An approximate error bound for a computed eigenvector VL(i) or\n\ * VR(i) is given by\n\ *\n\ * EPS * norm(A, B) / DIF(i).\n\ *\n\ * See ref. [2-3] for more details and further references.\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * References\n\ * ==========\n\ *\n\ * [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n\ * Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n\ * M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n\ * Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n\ *\n\ * [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n\ * Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n\ * Estimation: Theory, Algorithms and Software, Report\n\ * UMINF - 94.04, Department of Computing Science, Umea University,\n\ * S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.\n\ * To appear in Numerical Algorithms, 1996.\n\ *\n\ * [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n\ * for Solving the Generalized Sylvester Equation and Estimating the\n\ * Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n\ * Department of Computing Science, Umea University, S-901 87 Umea,\n\ * Sweden, December 1993, Revised April 1994, Also as LAPACK Working\n\ * Note 75.\n\ * To appear in ACM Trans. on Math. Software, Vol 22, No 1, 1996.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dptts20000644000175000017500000000447112502223526016436 0ustar uwabamiuwabami--- :name: dptts2 :md5sum: e107a9943c6e670481084e9260cc9f12 :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublereal :intent: input :dims: - n-1 - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE DPTTS2( N, NRHS, D, E, B, LDB )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPTTS2 solves a tridiagonal system of the form\n\ * A * X = B\n\ * using the L*D*L' factorization of A computed by DPTTRF. D is a\n\ * diagonal matrix specified in the vector D, L is a unit bidiagonal\n\ * matrix whose subdiagonal is specified in the vector E, and X and B\n\ * are N by NRHS matrices.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the tridiagonal matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The n diagonal elements of the diagonal matrix D from the\n\ * L*D*L' factorization of A.\n\ *\n\ * E (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) subdiagonal elements of the unit bidiagonal factor\n\ * L from the L*D*L' factorization of A. E can also be regarded\n\ * as the superdiagonal of the unit bidiagonal factor U from the\n\ * factorization A = U'*D*U.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the right hand side vectors B for the system of\n\ * linear equations.\n\ * On exit, the solution vectors, X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DSCAL\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slaqsb0000644000175000017500000000635112502223526016502 0ustar uwabamiuwabami--- :name: slaqsb :md5sum: d2d1a5396a266cc4eaa46bf3ff39ef25 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - s: :type: real :intent: input :dims: - n - scond: :type: real :intent: input - amax: :type: real :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAQSB equilibrates a symmetric band matrix A using the scaling\n\ * factors in the vector S.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of super-diagonals of the matrix A if UPLO = 'U',\n\ * or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) REAL array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * On exit, if INFO = 0, the triangular factor U or L from the\n\ * Cholesky factorization A = U'*U or A = L*L' of the band\n\ * matrix A, in the same storage format as A.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * S (input) REAL array, dimension (N)\n\ * The scale factors for A.\n\ *\n\ * SCOND (input) REAL\n\ * Ratio of the smallest S(i) to the largest S(i).\n\ *\n\ * AMAX (input) REAL\n\ * Absolute value of largest matrix entry.\n\ *\n\ * EQUED (output) CHARACTER*1\n\ * Specifies whether or not equilibration was done.\n\ * = 'N': No equilibration.\n\ * = 'Y': Equilibration was done, i.e., A has been replaced by\n\ * diag(S) * A * diag(S).\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * THRESH is a threshold value used to decide if scaling should be done\n\ * based on the ratio of the scaling factors. If SCOND < THRESH,\n\ * scaling is done.\n\ *\n\ * LARGE and SMALL are threshold values used to decide if scaling should\n\ * be done based on the absolute size of the largest matrix element.\n\ * If AMAX > LARGE or AMAX < SMALL, scaling is done.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgelsy0000644000175000017500000001463712502223525016510 0ustar uwabamiuwabami--- :name: cgelsy :md5sum: 2279e3c93a99cd72baf9f763012d87ce :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - rcond: :type: real :intent: input - rank: :type: integer :intent: output - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(MIN(m,n)+3*n+1, 2*MIN(m,n)+nrhs) - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: m: lda ldb: MAX(m,n) :fortran_help: " SUBROUTINE CGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGELSY computes the minimum-norm solution to a complex linear least\n\ * squares problem:\n\ * minimize || A * X - B ||\n\ * using a complete orthogonal factorization of A. A is an M-by-N\n\ * matrix which may be rank-deficient.\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\ * The routine first computes a QR factorization with column pivoting:\n\ * A * P = Q * [ R11 R12 ]\n\ * [ 0 R22 ]\n\ * with R11 defined as the largest leading submatrix whose estimated\n\ * condition number is less than 1/RCOND. The order of R11, RANK,\n\ * is the effective rank of A.\n\ *\n\ * Then, R22 is considered to be negligible, and R12 is annihilated\n\ * by unitary transformations from the right, arriving at the\n\ * complete orthogonal factorization:\n\ * A * P = Q * [ T11 0 ] * Z\n\ * [ 0 0 ]\n\ * The minimum-norm solution is then\n\ * X = P * Z' [ inv(T11)*Q1'*B ]\n\ * [ 0 ]\n\ * where Q1 consists of the first RANK columns of Q.\n\ *\n\ * This routine is basically identical to the original xGELSX except\n\ * three differences:\n\ * o The permutation of matrix B (the right hand side) is faster and\n\ * more simple.\n\ * o The call to the subroutine xGEQPF has been substituted by the\n\ * the call to the subroutine xGEQP3. This subroutine is a Blas-3\n\ * version of the QR factorization with column pivoting.\n\ * o Matrix B (the right hand side) is updated with Blas-3.\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\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of\n\ * columns of matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, A has been overwritten by details of its\n\ * complete orthogonal factorization.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the M-by-NRHS right hand side matrix B.\n\ * On exit, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,M,N).\n\ *\n\ * JPVT (input/output) INTEGER array, dimension (N)\n\ * On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n\ * to the front of AP, otherwise column i is a free column.\n\ * On exit, if JPVT(i) = k, then the i-th column of A*P\n\ * was the k-th column of A.\n\ *\n\ * RCOND (input) REAL\n\ * RCOND is used to determine the effective rank of A, which\n\ * is defined as the order of the largest leading triangular\n\ * submatrix R11 in the QR factorization with pivoting of A,\n\ * whose estimated condition number < 1/RCOND.\n\ *\n\ * RANK (output) INTEGER\n\ * The effective rank of A, i.e., the order of the submatrix\n\ * R11. This is the same as the order of the submatrix T11\n\ * in the complete orthogonal factorization of A.\n\ *\n\ * WORK (workspace/output) COMPLEX 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\ * The unblocked strategy requires that:\n\ * LWORK >= MN + MAX( 2*MN, N+1, MN+NRHS )\n\ * where MN = min(M,N).\n\ * The block algorithm requires that:\n\ * LWORK >= MN + MAX( 2*MN, NB*(N+1), MN+MN*NB, MN+NB*NRHS )\n\ * where NB is an upper bound on the blocksize returned\n\ * by ILAENV for the routines CGEQP3, CTZRZF, CTZRQF, CUNMQR,\n\ * and CUNMRZ.\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\ * RWORK (workspace) REAL array, dimension (2*N)\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\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ * E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n\ * G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zheevr0000644000175000017500000003216112502223526016516 0ustar uwabamiuwabami--- :name: zheevr :md5sum: f47d50a9af6c562dfda0198807baa560 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: doublereal :intent: output :dims: - MAX(1,lrwork) - lrwork: :type: integer :intent: input :option: true :default: 24*n - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: 10*n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " SUBROUTINE ZHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHEEVR computes selected eigenvalues and, optionally, eigenvectors\n\ * of a complex Hermitian matrix A. Eigenvalues and eigenvectors can\n\ * be selected by specifying either a range of values or a range of\n\ * indices for the desired eigenvalues.\n\ *\n\ * ZHEEVR first reduces the matrix A to tridiagonal form T with a call\n\ * to ZHETRD. Then, whenever possible, ZHEEVR calls ZSTEMR to compute\n\ * eigenspectrum using Relatively Robust Representations. ZSTEMR\n\ * computes eigenvalues by the dqds algorithm, while orthogonal\n\ * eigenvectors are computed from various \"good\" L D L^T representations\n\ * (also known as Relatively Robust Representations). Gram-Schmidt\n\ * orthogonalization is avoided as far as possible. More specifically,\n\ * the various steps of the algorithm are as follows.\n\ *\n\ * For each unreduced block (submatrix) of T,\n\ * (a) Compute T - sigma I = L D L^T, so that L and D\n\ * define all the wanted eigenvalues to high relative accuracy.\n\ * This means that small relative changes in the entries of D and L\n\ * cause only small relative changes in the eigenvalues and\n\ * eigenvectors. The standard (unfactored) representation of the\n\ * tridiagonal matrix T does not have this property in general.\n\ * (b) Compute the eigenvalues to suitable accuracy.\n\ * If the eigenvectors are desired, the algorithm attains full\n\ * accuracy of the computed eigenvalues only right before\n\ * the corresponding vectors have to be computed, see steps c) and d).\n\ * (c) For each cluster of close eigenvalues, select a new\n\ * shift close to the cluster, find a new factorization, and refine\n\ * the shifted eigenvalues to suitable accuracy.\n\ * (d) For each eigenvalue with a large enough relative separation compute\n\ * the corresponding eigenvector by forming a rank revealing twisted\n\ * factorization. Go back to (c) for any clusters that remain.\n\ *\n\ * The desired accuracy of the output can be specified by the input\n\ * parameter ABSTOL.\n\ *\n\ * For more details, see DSTEMR's documentation and:\n\ * - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n\ * to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n\ * Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n\ * - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n\ * Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n\ * 2004. Also LAPACK Working Note 154.\n\ * - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n\ * tridiagonal eigenvalue/eigenvector problem\",\n\ * Computer Science Division Technical Report No. UCB/CSD-97-971,\n\ * UC Berkeley, May 1997.\n\ *\n\ *\n\ * Note 1 : ZHEEVR calls ZSTEMR when the full spectrum is requested\n\ * on machines which conform to the ieee-754 floating point standard.\n\ * ZHEEVR calls DSTEBZ and ZSTEIN on non-ieee machines and\n\ * when partial spectrum requests are made.\n\ *\n\ * Normal execution of ZSTEMR may create NaNs and infinities and\n\ * hence may abort due to a floating point exception in environments\n\ * which do not handle NaNs and infinities in the ieee standard default\n\ * manner.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found.\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found.\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ ********** For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and\n\ ********** ZSTEIN are called\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA, N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of A contains the\n\ * upper triangular part of the matrix A. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of A contains\n\ * the lower triangular part of the matrix A.\n\ * On exit, the lower triangle (if UPLO='L') or the upper\n\ * triangle (if UPLO='U') of A, including the diagonal, is\n\ * destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * VL (input) DOUBLE PRECISION\n\ * VU (input) DOUBLE PRECISION\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) DOUBLE PRECISION\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less than\n\ * or equal to zero, then EPS*|T| will be used in its place,\n\ * where |T| is the 1-norm of the tridiagonal matrix obtained\n\ * by reducing A to tridiagonal form.\n\ *\n\ * See \"Computing Small Singular Values of Bidiagonal Matrices\n\ * with Guaranteed High Relative Accuracy,\" by Demmel and\n\ * Kahan, LAPACK Working Note #3.\n\ *\n\ * If high relative accuracy is important, set ABSTOL to\n\ * DLAMCH( 'Safe minimum' ). Doing so will guarantee that\n\ * eigenvalues are computed to high relative accuracy when\n\ * possible in future releases. The current code does not\n\ * make any guarantees about high relative accuracy, but\n\ * furutre releases will. See J. Barlow and J. Demmel,\n\ * \"Computing Accurate Eigensystems of Scaled Diagonally\n\ * Dominant Matrices\", LAPACK Working Note #7, for a discussion\n\ * of which matrices define their eigenvalues to high relative\n\ * accuracy.\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * The first M elements contain the selected eigenvalues in\n\ * ascending order.\n\ *\n\ * Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M))\n\ * If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix A\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )\n\ * The support of the eigenvectors in Z, i.e., the indices\n\ * indicating the nonzero elements in Z. The i-th eigenvector\n\ * is nonzero only in elements ISUPPZ( 2*i-1 ) through\n\ * ISUPPZ( 2*i ).\n\ ********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1\n\ *\n\ * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of the array WORK. LWORK >= max(1,2*N).\n\ * For optimal efficiency, LWORK >= (NB+1)*N,\n\ * where NB is the max of the blocksize for ZHETRD and for\n\ * ZUNMTR as returned by ILAENV.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the optimal sizes of the WORK, RWORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * RWORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))\n\ * On exit, if INFO = 0, RWORK(1) returns the optimal\n\ * (and minimal) LRWORK.\n\ *\n\ * LRWORK (input) INTEGER\n\ * The length of the array RWORK. LRWORK >= max(1,24*N).\n\ *\n\ * If LRWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal\n\ * (and minimal) LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK. LIWORK >= max(1,10*N).\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK 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: Internal error\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Inderjit Dhillon, IBM Almaden, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Ken Stanley, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ * Jason Riedy, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssptri0000644000175000017500000000467212502223526016545 0ustar uwabamiuwabami--- :name: ssptri :md5sum: 253eb732f2689ac417f212ba2df196b9 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SSPTRI( UPLO, N, AP, IPIV, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSPTRI computes the inverse of a real symmetric indefinite matrix\n\ * A in packed storage using the factorization A = U*D*U**T or\n\ * A = L*D*L**T computed by SSPTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) REAL array, dimension (N*(N+1)/2)\n\ * On entry, the block diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L as computed by SSPTRF,\n\ * stored as a packed triangular matrix.\n\ *\n\ * On exit, if INFO = 0, the (symmetric) inverse of the original\n\ * matrix, stored as a packed triangular matrix. The j-th column\n\ * of inv(A) is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;\n\ * if UPLO = 'L',\n\ * AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by SSPTRF.\n\ *\n\ * WORK (workspace) REAL array, dimension (N)\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, D(i,i) = 0; the matrix is singular and its\n\ * inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chesv0000644000175000017500000001270012502223525016317 0ustar uwabamiuwabami--- :name: chesv :md5sum: 3e767c9c17a6d72984bc45f1aa42a2c2 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CHESV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHESV computes the solution to a complex system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS\n\ * matrices.\n\ *\n\ * The diagonal pivoting method is used to factor A as\n\ * A = U * D * U**H, if UPLO = 'U', or\n\ * A = L * D * L**H, if UPLO = 'L',\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, and D is Hermitian and block diagonal with \n\ * 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then\n\ * used to solve the system of equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the block diagonal matrix D and the\n\ * multipliers used to obtain the factor U or L from the\n\ * factorization A = U*D*U**H or A = L*D*L**H as computed by\n\ * CHETRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D, as\n\ * determined by CHETRF. If IPIV(k) > 0, then rows and columns\n\ * k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n\ * diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n\ * then rows and columns k-1 and -IPIV(k) were interchanged and\n\ * D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n\ * IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n\ * -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n\ * diagonal block.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of WORK. LWORK >= 1, and for best performance\n\ * LWORK >= max(1,N*NB), where NB is the optimal blocksize for\n\ * CHETRF.\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, D(i,i) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular, so the solution could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LWKOPT, NB\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL ILAENV, LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CHETRF, CHETRS2, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cpoequb0000644000175000017500000000476712502223525016663 0ustar uwabamiuwabami--- :name: cpoequb :md5sum: f0abc0761ce91060ba240df4dd323aa2 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - s: :type: real :intent: output :dims: - n - scond: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPOEQUB computes row and column scalings intended to equilibrate a\n\ * symmetric positive definite matrix A and reduce its condition number\n\ * (with respect to the two-norm). S contains the scale factors,\n\ * S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n\ * elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n\ * choice of S puts the condition number of B within a factor N of the\n\ * smallest possible condition number over all possible diagonal\n\ * scalings.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The N-by-N symmetric positive definite matrix whose scaling\n\ * factors are to be computed. Only the diagonal elements of A\n\ * are referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * S (output) REAL array, dimension (N)\n\ * If INFO = 0, S contains the scale factors for A.\n\ *\n\ * SCOND (output) REAL\n\ * If INFO = 0, S contains the ratio of the smallest S(i) to\n\ * the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n\ * large nor too small, it is not worth scaling by S.\n\ *\n\ * AMAX (output) REAL\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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 is nonpositive.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slartgs0000644000175000017500000000274412502223526016676 0ustar uwabamiuwabami--- :name: slartgs :md5sum: b94e35bda8fd48cd94048c69f1af78f8 :category: :subroutine :arguments: - x: :type: real :intent: input - y: :type: real :intent: input - sigma: :type: real :intent: input - cs: :type: real :intent: output - sn: :type: real :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLARTGS( X, Y, SIGMA, CS, SN )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLARTGS generates a plane rotation designed to introduce a bulge in\n\ * Golub-Reinsch-style implicit QR iteration for the bidiagonal SVD\n\ * problem. X and Y are the top-row entries, and SIGMA is the shift.\n\ * The computed CS and SN define a plane rotation satisfying\n\ *\n\ * [ CS SN ] . [ X^2 - SIGMA ] = [ R ],\n\ * [ -SN CS ] [ X * Y ] [ 0 ]\n\ *\n\ * with R nonnegative. If X^2 - SIGMA and X * Y are 0, then the\n\ * rotation is by PI/2.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * X (input) REAL\n\ * The (1,1) entry of an upper bidiagonal matrix.\n\ *\n\ * Y (input) REAL\n\ * The (1,2) entry of an upper bidiagonal matrix.\n\ *\n\ * SIGMA (input) REAL\n\ * The shift.\n\ *\n\ * CS (output) REAL\n\ * The cosine of the rotation.\n\ *\n\ * SN (output) REAL\n\ * The sine of the rotation.\n\ *\n\n\ * ===================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chbgv0000644000175000017500000001301212502223525016275 0ustar uwabamiuwabami--- :name: chbgv :md5sum: dddbffb87a4a98ff464f760034bc1a42 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: complex :intent: input/output :dims: - ldbb - n - ldbb: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - n - rwork: :type: real :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? n : 1" :fortran_help: " SUBROUTINE CHBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHBGV computes all the eigenvalues, and optionally, the eigenvectors\n\ * of a complex generalized Hermitian-definite banded eigenproblem, of\n\ * the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian\n\ * and banded, and B is also positive definite.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * KA (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n\ *\n\ * KB (input) INTEGER\n\ * The number of superdiagonals of the matrix B if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n\ *\n\ * AB (input/output) COMPLEX array, dimension (LDAB, N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix A, stored in the first ka+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n\ *\n\ * On exit, the contents of AB are destroyed.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KA+1.\n\ *\n\ * BB (input/output) COMPLEX array, dimension (LDBB, N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix B, stored in the first kb+1 rows of the array. The\n\ * j-th column of B is stored in the j-th column of the array BB\n\ * as follows:\n\ * if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n\ * if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n\ *\n\ * On exit, the factor S from the split Cholesky factorization\n\ * B = S**H*S, as returned by CPBSTF.\n\ *\n\ * LDBB (input) INTEGER\n\ * The leading dimension of the array BB. LDBB >= KB+1.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) COMPLEX array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n\ * eigenvectors, with the i-th column of Z holding the\n\ * eigenvector associated with W(i). The eigenvectors are\n\ * normalized so that Z**H*B*Z = I.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= N.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (3*N)\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, and i is:\n\ * <= N: the algorithm failed to converge:\n\ * i off-diagonal elements of an intermediate\n\ * tridiagonal form did not converge to zero;\n\ * > N: if INFO = N + i, for 1 <= i <= N, then CPBSTF\n\ * returned INFO = i: B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL UPPER, WANTZ\n CHARACTER VECT\n INTEGER IINFO, INDE, INDWRK\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CHBGST, CHBTRD, CPBSTF, CSTEQR, SSTERF, XERBLA\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/csycon0000644000175000017500000000517612502223525016516 0ustar uwabamiuwabami--- :name: csycon :md5sum: 800f12535dbc26a63c273077b3a6fb4b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: complex :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSYCON estimates the reciprocal of the condition number (in the\n\ * 1-norm) of a complex symmetric matrix A using the factorization\n\ * A = U*D*U**T or A = L*D*L**T computed by CSYTRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by CSYTRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by CSYTRF.\n\ *\n\ * ANORM (input) REAL\n\ * The 1-norm of the original matrix A.\n\ *\n\ * RCOND (output) REAL\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n\ * estimate of the 1-norm of inv(A) computed in this routine.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clacrt0000644000175000017500000000354712502223525016470 0ustar uwabamiuwabami--- :name: clacrt :md5sum: 6ca41ce11fcff052a8b28dc9c7778f27 :category: :subroutine :arguments: - n: :type: integer :intent: input - cx: :type: complex :intent: input/output :dims: - n - incx: :type: integer :intent: input - cy: :type: complex :intent: input/output :dims: - n - incy: :type: integer :intent: input - c: :type: complex :intent: input - s: :type: complex :intent: input :substitutions: {} :fortran_help: " SUBROUTINE CLACRT( N, CX, INCX, CY, INCY, C, S )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLACRT performs the operation\n\ *\n\ * ( c s )( x ) ==> ( x )\n\ * ( -s c )( y ) ( y )\n\ *\n\ * where c and s are complex and the vectors x and y are complex.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of elements in the vectors CX and CY.\n\ *\n\ * CX (input/output) COMPLEX array, dimension (N)\n\ * On input, the vector x.\n\ * On output, CX is overwritten with c*x + s*y.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between successive values of CX. INCX <> 0.\n\ *\n\ * CY (input/output) COMPLEX array, dimension (N)\n\ * On input, the vector y.\n\ * On output, CY is overwritten with -s*x + c*y.\n\ *\n\ * INCY (input) INTEGER\n\ * The increment between successive values of CY. INCY <> 0.\n\ *\n\ * C (input) COMPLEX\n\ * S (input) COMPLEX\n\ * C and S define the matrix\n\ * [ C S ].\n\ * [ -S C ]\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, IX, IY\n COMPLEX CTEMP\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/chpgv0000644000175000017500000001212312502223525016315 0ustar uwabamiuwabami--- :name: chpgv :md5sum: 9f30ab07cf54461d441f623e4a879060 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - ldap - bp: :type: complex :intent: input/output :dims: - n*(n+1)/2 - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - MAX(1, 2*n-1) - rwork: :type: real :intent: workspace :dims: - MAX(1, 3*n-2) - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE CHPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHPGV computes all the eigenvalues and, optionally, the eigenvectors\n\ * of a complex generalized Hermitian-definite eigenproblem, of the form\n\ * A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.\n\ * Here A and B are assumed to be Hermitian, stored in packed format,\n\ * and B is also positive definite.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * Specifies the problem type to be solved:\n\ * = 1: A*x = (lambda)*B*x\n\ * = 2: A*B*x = (lambda)*x\n\ * = 3: B*A*x = (lambda)*x\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, the contents of AP are destroyed.\n\ *\n\ * BP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * B, packed columnwise in a linear array. The j-th column of B\n\ * is stored in the array BP as follows:\n\ * if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n\ *\n\ * On exit, the triangular factor U or L from the Cholesky\n\ * factorization B = U**H*U or B = L*L**H, in the same storage\n\ * format as B.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) COMPLEX array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n\ * eigenvectors. The eigenvectors are normalized as follows:\n\ * if ITYPE = 1 or 2, Z**H*B*Z = I;\n\ * if ITYPE = 3, Z**H*inv(B)*Z = I.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (max(1, 2*N-1))\n\ *\n\ * RWORK (workspace) REAL array, dimension (max(1, 3*N-2))\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: CPPTRF or CHPEV returned an error code:\n\ * <= N: if INFO = i, CHPEV failed to converge;\n\ * i off-diagonal elements of an intermediate\n\ * tridiagonal form did not convergeto zero;\n\ * > N: if INFO = N + i, for 1 <= i <= n, then the leading\n\ * minor of order i of B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL UPPER, WANTZ\n CHARACTER TRANS\n INTEGER J, NEIG\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CHPEV, CHPGST, CPPTRF, CTPMV, CTPSV, XERBLA\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/strtrs0000644000175000017500000000645512502223526016563 0ustar uwabamiuwabami--- :name: strtrs :md5sum: f97db8918b10773428e9be5886041cc4 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE STRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STRTRS solves a triangular system of the form\n\ *\n\ * A * X = B or A**T * X = B,\n\ *\n\ * where A is a triangular matrix of order N, and B is an N-by-NRHS\n\ * matrix. A check is made to verify that A is nonsingular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose = Transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * The triangular matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of the array A contains the upper\n\ * triangular matrix, and the strictly lower triangular part of\n\ * A is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of the array A contains the lower triangular\n\ * matrix, and the strictly upper triangular part of A is not\n\ * referenced. If DIAG = 'U', the diagonal elements of A are\n\ * also not referenced and are assumed to be 1.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, if INFO = 0, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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 A is zero,\n\ * indicating that the matrix is singular and the solutions\n\ * X have not been computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgegs0000644000175000017500000001561012502223525016302 0ustar uwabamiuwabami--- :name: cgegs :md5sum: 0d915b089b60c924c71d32fe45a153c2 :category: :subroutine :arguments: - jobvsl: :type: char :intent: input - jobvsr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alpha: :type: complex :intent: output :dims: - n - beta: :type: complex :intent: output :dims: - n - vsl: :type: complex :intent: output :dims: - ldvsl - n - ldvsl: :type: integer :intent: input - vsr: :type: complex :intent: output :dims: - ldvsr - n - ldvsr: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: real :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: ldvsl: "lsame_(&jobvsl,\"V\") ? n : 1" ldvsr: "lsame_(&jobvsr,\"V\") ? n : 1" :fortran_help: " SUBROUTINE CGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This routine is deprecated and has been replaced by routine CGGES.\n\ *\n\ * CGEGS computes the eigenvalues, Schur form, and, optionally, the\n\ * left and or/right Schur vectors of a complex matrix pair (A,B).\n\ * Given two square matrices A and B, the generalized Schur\n\ * factorization has the form\n\ * \n\ * A = Q*S*Z**H, B = Q*T*Z**H\n\ * \n\ * where Q and Z are unitary matrices and S and T are upper triangular.\n\ * The columns of Q are the left Schur vectors\n\ * and the columns of Z are the right Schur vectors.\n\ * \n\ * If only the eigenvalues of (A,B) are needed, the driver routine\n\ * CGEGV should be used instead. See CGEGV for a description of the\n\ * eigenvalues of the generalized nonsymmetric eigenvalue problem\n\ * (GNEP).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVSL (input) CHARACTER*1\n\ * = 'N': do not compute the left Schur vectors;\n\ * = 'V': compute the left Schur vectors (returned in VSL).\n\ *\n\ * JOBVSR (input) CHARACTER*1\n\ * = 'N': do not compute the right Schur vectors;\n\ * = 'V': compute the right Schur vectors (returned in VSR).\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A, B, VSL, and VSR. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA, N)\n\ * On entry, the matrix A.\n\ * On exit, the upper triangular matrix S from the generalized\n\ * Schur factorization.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB, N)\n\ * On entry, the matrix B.\n\ * On exit, the upper triangular matrix T from the generalized\n\ * Schur factorization.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B. LDB >= max(1,N).\n\ *\n\ * ALPHA (output) COMPLEX array, dimension (N)\n\ * The complex scalars alpha that define the eigenvalues of\n\ * GNEP. ALPHA(j) = S(j,j), the diagonal element of the Schur\n\ * form of A.\n\ *\n\ * BETA (output) COMPLEX array, dimension (N)\n\ * The non-negative real scalars beta that define the\n\ * eigenvalues of GNEP. BETA(j) = T(j,j), the diagonal element\n\ * of the triangular factor T.\n\ *\n\ * Together, the quantities alpha = ALPHA(j) and beta = BETA(j)\n\ * represent the j-th eigenvalue of the matrix pair (A,B), in\n\ * one of the forms lambda = alpha/beta or mu = beta/alpha.\n\ * Since either lambda or mu may overflow, they should not,\n\ * in general, be computed.\n\ *\n\ * VSL (output) COMPLEX array, dimension (LDVSL,N)\n\ * If JOBVSL = 'V', the matrix of left Schur vectors Q.\n\ * Not referenced if JOBVSL = 'N'.\n\ *\n\ * LDVSL (input) INTEGER\n\ * The leading dimension of the matrix VSL. LDVSL >= 1, and\n\ * if JOBVSL = 'V', LDVSL >= N.\n\ *\n\ * VSR (output) COMPLEX array, dimension (LDVSR,N)\n\ * If JOBVSR = 'V', the matrix of right Schur vectors Z.\n\ * Not referenced if JOBVSR = 'N'.\n\ *\n\ * LDVSR (input) INTEGER\n\ * The leading dimension of the matrix VSR. LDVSR >= 1, and\n\ * if JOBVSR = 'V', LDVSR >= N.\n\ *\n\ * WORK (workspace/output) COMPLEX 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,2*N).\n\ * For good performance, LWORK must generally be larger.\n\ * To compute the optimal value of LWORK, call ILAENV to get\n\ * blocksizes (for CGEQRF, CUNMQR, and CUNGQR.) Then compute:\n\ * NB -- MAX of the blocksizes for CGEQRF, CUNMQR, and CUNGQR;\n\ * the optimal LWORK is N*(NB+1).\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\ * RWORK (workspace) REAL array, dimension (3*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * =1,...,N:\n\ * The QZ iteration failed. (A,B) are not in Schur\n\ * form, but ALPHA(j) and BETA(j) should be correct for\n\ * j=INFO+1,...,N.\n\ * > N: errors that usually indicate LAPACK problems:\n\ * =N+1: error return from CGGBAL\n\ * =N+2: error return from CGEQRF\n\ * =N+3: error return from CUNMQR\n\ * =N+4: error return from CUNGQR\n\ * =N+5: error return from CGGHRD\n\ * =N+6: error return from CHGEQZ (other than failed\n\ * iteration)\n\ * =N+7: error return from CGGBAK (computing VSL)\n\ * =N+8: error return from CGGBAK (computing VSR)\n\ * =N+9: error return from CLASCL (various places)\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chetf20000644000175000017500000001307612502223525016371 0ustar uwabamiuwabami--- :name: chetf2 :md5sum: 05305896b5675db360a8faa279e8a94d :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CHETF2( UPLO, N, A, LDA, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHETF2 computes the factorization of a complex Hermitian matrix A\n\ * using the Bunch-Kaufman diagonal pivoting method:\n\ *\n\ * A = U*D*U' or A = L*D*L'\n\ *\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, U' is the conjugate transpose of U, and D is\n\ * Hermitian and block diagonal with 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\ * This is the unblocked version of the algorithm, calling Level 2 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * Hermitian matrix A is stored:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the leading\n\ * n-by-n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n-by-n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L (see below for further details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D.\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ * > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular, and division by zero will occur if it\n\ * is used to solve a system of equations.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * 09-29-06 - patch from\n\ * Bobby Cheng, MathWorks\n\ *\n\ * Replace l.210 and l.392\n\ * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN\n\ * by\n\ * IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN\n\ *\n\ * 01-01-96 - Based on modifications by\n\ * J. Lewis, Boeing Computer Services Company\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * If UPLO = 'U', then A = U*D*U', where\n\ * U = P(n)*U(n)* ... *P(k)U(k)* ...,\n\ * i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n\ * 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I v 0 ) k-s\n\ * U(k) = ( 0 I 0 ) s\n\ * ( 0 0 I ) n-k\n\ * k-s s n-k\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n\ * If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n\ * and A(k,k), and v overwrites A(1:k-2,k-1:k).\n\ *\n\ * If UPLO = 'L', then A = L*D*L', where\n\ * L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n\ * i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n\ * n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I 0 0 ) k-1\n\ * L(k) = ( 0 I 0 ) s\n\ * ( 0 v I ) n-k-s+1\n\ * k-1 s n-k-s+1\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n\ * If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n\ * and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dggesx0000644000175000017500000003213512502223526016475 0ustar uwabamiuwabami--- :name: dggesx :md5sum: f3a7ebdeb62d6f9d7568125a545c4ee7 :category: :subroutine :arguments: - jobvsl: :type: char :intent: input - jobvsr: :type: char :intent: input - sort: :type: char :intent: input - selctg: :intent: external procedure :block_type: logical :block_arg_num: 3 :block_arg_type: doublereal - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - sdim: :type: integer :intent: output - alphar: :type: doublereal :intent: output :dims: - n - alphai: :type: doublereal :intent: output :dims: - n - beta: :type: doublereal :intent: output :dims: - n - vsl: :type: doublereal :intent: output :dims: - ldvsl - n - ldvsl: :type: integer :intent: input - vsr: :type: doublereal :intent: output :dims: - ldvsr - n - ldvsr: :type: integer :intent: input - rconde: :type: doublereal :intent: output :dims: - "2" - rcondv: :type: doublereal :intent: output :dims: - "2" - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n==0 ? 1 : (lsame_(&sense,\"E\")||lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? MAX(MAX(8*n,6*n+16),n*n/2) : MAX(8*n,6*n+16)" - iwork: :type: integer :intent: workspace :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "(lsame_(&sense,\"N\")||n==0) ? 1 : n+6" - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvsl: "lsame_(&jobvsl,\"V\") ? n : 1" ldvsr: "lsame_(&jobvsr,\"V\") ? n : 1" :fortran_help: " SUBROUTINE DGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, IWORK, LIWORK, BWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGGESX computes for a pair of N-by-N real nonsymmetric matrices\n\ * (A,B), the generalized eigenvalues, the real Schur form (S,T), and,\n\ * optionally, the left and/or right matrices of Schur vectors (VSL and\n\ * VSR). This gives the generalized Schur factorization\n\ *\n\ * (A,B) = ( (VSL) S (VSR)**T, (VSL) T (VSR)**T )\n\ *\n\ * Optionally, it also orders the eigenvalues so that a selected cluster\n\ * of eigenvalues appears in the leading diagonal blocks of the upper\n\ * quasi-triangular matrix S and the upper triangular matrix T; computes\n\ * a reciprocal condition number for the average of the selected\n\ * eigenvalues (RCONDE); and computes a reciprocal condition number for\n\ * the right and left deflating subspaces corresponding to the selected\n\ * eigenvalues (RCONDV). The leading columns of VSL and VSR then form\n\ * an orthonormal basis for the corresponding left and right eigenspaces\n\ * (deflating subspaces).\n\ *\n\ * A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n\ * or a ratio alpha/beta = w, such that A - w*B is singular. It is\n\ * usually represented as the pair (alpha,beta), as there is a\n\ * reasonable interpretation for beta=0 or for both being zero.\n\ *\n\ * A pair of matrices (S,T) is in generalized real Schur form if T is\n\ * upper triangular with non-negative diagonal and S is block upper\n\ * triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond\n\ * to real generalized eigenvalues, while 2-by-2 blocks of S will be\n\ * \"standardized\" by making the corresponding elements of T have the\n\ * form:\n\ * [ a 0 ]\n\ * [ 0 b ]\n\ *\n\ * and the pair of corresponding 2-by-2 blocks in S and T will have a\n\ * complex conjugate pair of generalized eigenvalues.\n\ *\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVSL (input) CHARACTER*1\n\ * = 'N': do not compute the left Schur vectors;\n\ * = 'V': compute the left Schur vectors.\n\ *\n\ * JOBVSR (input) CHARACTER*1\n\ * = 'N': do not compute the right Schur vectors;\n\ * = 'V': compute the right Schur vectors.\n\ *\n\ * SORT (input) CHARACTER*1\n\ * Specifies whether or not to order the eigenvalues on the\n\ * diagonal of the generalized Schur form.\n\ * = 'N': Eigenvalues are not ordered;\n\ * = 'S': Eigenvalues are ordered (see SELCTG).\n\ *\n\ * SELCTG (external procedure) LOGICAL FUNCTION of three DOUBLE PRECISION arguments\n\ * SELCTG must be declared EXTERNAL in the calling subroutine.\n\ * If SORT = 'N', SELCTG is not referenced.\n\ * If SORT = 'S', SELCTG is used to select eigenvalues to sort\n\ * to the top left of the Schur form.\n\ * An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if\n\ * SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either\n\ * one of a complex conjugate pair of eigenvalues is selected,\n\ * then both complex eigenvalues are selected.\n\ * Note that a selected complex eigenvalue may no longer satisfy\n\ * SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) = .TRUE. after ordering,\n\ * since ordering may change the value of complex eigenvalues\n\ * (especially if the eigenvalue is ill-conditioned), in this\n\ * case INFO is set to N+3.\n\ *\n\ * SENSE (input) CHARACTER*1\n\ * Determines which reciprocal condition numbers are computed.\n\ * = 'N' : None are computed;\n\ * = 'E' : Computed for average of selected eigenvalues only;\n\ * = 'V' : Computed for selected deflating subspaces only;\n\ * = 'B' : Computed for both.\n\ * If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A, B, VSL, and VSR. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n\ * On entry, the first of the pair of matrices.\n\ * On exit, A has been overwritten by its generalized Schur\n\ * form S.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of A. LDA >= max(1,N).\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n\ * On entry, the second of the pair of matrices.\n\ * On exit, B has been overwritten by its generalized Schur\n\ * form T.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B. LDB >= max(1,N).\n\ *\n\ * SDIM (output) INTEGER\n\ * If SORT = 'N', SDIM = 0.\n\ * If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n\ * for which SELCTG is true. (Complex conjugate pairs for which\n\ * SELCTG is true for either eigenvalue count as 2.)\n\ *\n\ * ALPHAR (output) DOUBLE PRECISION array, dimension (N)\n\ * ALPHAI (output) DOUBLE PRECISION array, dimension (N)\n\ * BETA (output) DOUBLE PRECISION array, dimension (N)\n\ * On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n\ * be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i\n\ * and BETA(j),j=1,...,N are the diagonals of the complex Schur\n\ * form (S,T) that would result if the 2-by-2 diagonal blocks of\n\ * the real Schur form of (A,B) were further reduced to\n\ * triangular form using 2-by-2 complex unitary transformations.\n\ * If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n\ * positive, then the j-th and (j+1)-st eigenvalues are a\n\ * complex conjugate pair, with ALPHAI(j+1) negative.\n\ *\n\ * Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n\ * may easily over- or underflow, and BETA(j) may even be zero.\n\ * Thus, the user should avoid naively computing the ratio.\n\ * However, ALPHAR and ALPHAI will be always less than and\n\ * usually comparable with norm(A) in magnitude, and BETA always\n\ * less than and usually comparable with norm(B).\n\ *\n\ * VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N)\n\ * If JOBVSL = 'V', VSL will contain the left Schur vectors.\n\ * Not referenced if JOBVSL = 'N'.\n\ *\n\ * LDVSL (input) INTEGER\n\ * The leading dimension of the matrix VSL. LDVSL >=1, and\n\ * if JOBVSL = 'V', LDVSL >= N.\n\ *\n\ * VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N)\n\ * If JOBVSR = 'V', VSR will contain the right Schur vectors.\n\ * Not referenced if JOBVSR = 'N'.\n\ *\n\ * LDVSR (input) INTEGER\n\ * The leading dimension of the matrix VSR. LDVSR >= 1, and\n\ * if JOBVSR = 'V', LDVSR >= N.\n\ *\n\ * RCONDE (output) DOUBLE PRECISION array, dimension ( 2 )\n\ * If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the\n\ * reciprocal condition numbers for the average of the selected\n\ * eigenvalues.\n\ * Not referenced if SENSE = 'N' or 'V'.\n\ *\n\ * RCONDV (output) DOUBLE PRECISION array, dimension ( 2 )\n\ * If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the\n\ * reciprocal condition numbers for the selected deflating\n\ * subspaces.\n\ * Not referenced if SENSE = 'N' or 'E'.\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\ * If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B',\n\ * LWORK >= max( 8*N, 6*N+16, 2*SDIM*(N-SDIM) ), else\n\ * LWORK >= max( 8*N, 6*N+16 ).\n\ * Note that 2*SDIM*(N-SDIM) <= N*N/2.\n\ * Note also that an error is only returned if\n\ * LWORK < max( 8*N, 6*N+16), but if SENSE = 'E' or 'V' or 'B'\n\ * this may not be large enough.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the bound on the optimal size of the WORK\n\ * array and the minimum size of the IWORK array, returns these\n\ * values as the first entries of the WORK and IWORK arrays, and\n\ * no error message related to LWORK or LIWORK is issued by\n\ * XERBLA.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK.\n\ * If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise\n\ * LIWORK >= N+6.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the bound on the optimal size of the\n\ * WORK array and the minimum size of the IWORK array, returns\n\ * these values as the first entries of the WORK and IWORK\n\ * arrays, and no error message related to LWORK or LIWORK is\n\ * issued by XERBLA.\n\ *\n\ * BWORK (workspace) LOGICAL array, dimension (N)\n\ * Not referenced if SORT = 'N'.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * = 1,...,N:\n\ * The QZ iteration failed. (A,B) are not in Schur\n\ * form, but ALPHAR(j), ALPHAI(j), and BETA(j) should\n\ * be correct for j=INFO+1,...,N.\n\ * > N: =N+1: other than QZ iteration failed in DHGEQZ\n\ * =N+2: after reordering, roundoff changed values of\n\ * some complex eigenvalues so that leading\n\ * eigenvalues in the Generalized Schur form no\n\ * longer satisfy SELCTG=.TRUE. This could also\n\ * be caused due to scaling.\n\ * =N+3: reordering failed in DTGSEN.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * An approximate (asymptotic) bound on the average absolute error of\n\ * the selected eigenvalues is\n\ *\n\ * EPS * norm((A, B)) / RCONDE( 1 ).\n\ *\n\ * An approximate (asymptotic) bound on the maximum angular error in\n\ * the computed deflating subspaces is\n\ *\n\ * EPS * norm((A, B)) / RCONDV( 2 ).\n\ *\n\ * See LAPACK User's Guide, section 4.11 for more information.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgges0000644000175000017500000002144112502223526016331 0ustar uwabamiuwabami--- :name: zgges :md5sum: 910f4c2589adc83dd9ec896220604135 :category: :subroutine :arguments: - jobvsl: :type: char :intent: input - jobvsr: :type: char :intent: input - sort: :type: char :intent: input - selctg: :intent: external procedure :block_type: logical :block_arg_num: 2 :block_arg_type: doublecomplex - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - sdim: :type: integer :intent: output - alpha: :type: doublecomplex :intent: output :dims: - n - beta: :type: doublecomplex :intent: output :dims: - n - vsl: :type: doublecomplex :intent: output :dims: - ldvsl - n - ldvsl: :type: integer :intent: input - vsr: :type: doublecomplex :intent: output :dims: - ldvsr - n - ldvsr: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: doublereal :intent: workspace :dims: - 8*n - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvsl: "lsame_(&jobvsl,\"V\") ? n : 1" ldvsr: "lsame_(&jobvsr,\"V\") ? n : 1" :fortran_help: " SUBROUTINE ZGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, BWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGGES computes for a pair of N-by-N complex nonsymmetric matrices\n\ * (A,B), the generalized eigenvalues, the generalized complex Schur\n\ * form (S, T), and optionally left and/or right Schur vectors (VSL\n\ * and VSR). This gives the generalized Schur factorization\n\ *\n\ * (A,B) = ( (VSL)*S*(VSR)**H, (VSL)*T*(VSR)**H )\n\ *\n\ * where (VSR)**H is the conjugate-transpose of VSR.\n\ *\n\ * Optionally, it also orders the eigenvalues so that a selected cluster\n\ * of eigenvalues appears in the leading diagonal blocks of the upper\n\ * triangular matrix S and the upper triangular matrix T. The leading\n\ * columns of VSL and VSR then form an unitary basis for the\n\ * corresponding left and right eigenspaces (deflating subspaces).\n\ *\n\ * (If only the generalized eigenvalues are needed, use the driver\n\ * ZGGEV instead, which is faster.)\n\ *\n\ * A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n\ * or a ratio alpha/beta = w, such that A - w*B is singular. It is\n\ * usually represented as the pair (alpha,beta), as there is a\n\ * reasonable interpretation for beta=0, and even for both being zero.\n\ *\n\ * A pair of matrices (S,T) is in generalized complex Schur form if S\n\ * and T are upper triangular and, in addition, the diagonal elements\n\ * of T are non-negative real numbers.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVSL (input) CHARACTER*1\n\ * = 'N': do not compute the left Schur vectors;\n\ * = 'V': compute the left Schur vectors.\n\ *\n\ * JOBVSR (input) CHARACTER*1\n\ * = 'N': do not compute the right Schur vectors;\n\ * = 'V': compute the right Schur vectors.\n\ *\n\ * SORT (input) CHARACTER*1\n\ * Specifies whether or not to order the eigenvalues on the\n\ * diagonal of the generalized Schur form.\n\ * = 'N': Eigenvalues are not ordered;\n\ * = 'S': Eigenvalues are ordered (see SELCTG).\n\ *\n\ * SELCTG (external procedure) LOGICAL FUNCTION of two COMPLEX*16 arguments\n\ * SELCTG must be declared EXTERNAL in the calling subroutine.\n\ * If SORT = 'N', SELCTG is not referenced.\n\ * If SORT = 'S', SELCTG is used to select eigenvalues to sort\n\ * to the top left of the Schur form.\n\ * An eigenvalue ALPHA(j)/BETA(j) is selected if\n\ * SELCTG(ALPHA(j),BETA(j)) is true.\n\ *\n\ * Note that a selected complex eigenvalue may no longer satisfy\n\ * SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since\n\ * ordering may change the value of complex eigenvalues\n\ * (especially if the eigenvalue is ill-conditioned), in this\n\ * case INFO is set to N+2 (See INFO below).\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A, B, VSL, and VSR. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA, N)\n\ * On entry, the first of the pair of matrices.\n\ * On exit, A has been overwritten by its generalized Schur\n\ * form S.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB, N)\n\ * On entry, the second of the pair of matrices.\n\ * On exit, B has been overwritten by its generalized Schur\n\ * form T.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B. LDB >= max(1,N).\n\ *\n\ * SDIM (output) INTEGER\n\ * If SORT = 'N', SDIM = 0.\n\ * If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n\ * for which SELCTG is true.\n\ *\n\ * ALPHA (output) COMPLEX*16 array, dimension (N)\n\ * BETA (output) COMPLEX*16 array, dimension (N)\n\ * On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the\n\ * generalized eigenvalues. ALPHA(j), j=1,...,N and BETA(j),\n\ * j=1,...,N are the diagonals of the complex Schur form (A,B)\n\ * output by ZGGES. The BETA(j) will be non-negative real.\n\ *\n\ * Note: the quotients ALPHA(j)/BETA(j) may easily over- or\n\ * underflow, and BETA(j) may even be zero. Thus, the user\n\ * should avoid naively computing the ratio alpha/beta.\n\ * However, ALPHA will be always less than and usually\n\ * comparable with norm(A) in magnitude, and BETA always less\n\ * than and usually comparable with norm(B).\n\ *\n\ * VSL (output) COMPLEX*16 array, dimension (LDVSL,N)\n\ * If JOBVSL = 'V', VSL will contain the left Schur vectors.\n\ * Not referenced if JOBVSL = 'N'.\n\ *\n\ * LDVSL (input) INTEGER\n\ * The leading dimension of the matrix VSL. LDVSL >= 1, and\n\ * if JOBVSL = 'V', LDVSL >= N.\n\ *\n\ * VSR (output) COMPLEX*16 array, dimension (LDVSR,N)\n\ * If JOBVSR = 'V', VSR will contain the right Schur vectors.\n\ * Not referenced if JOBVSR = 'N'.\n\ *\n\ * LDVSR (input) INTEGER\n\ * The leading dimension of the matrix VSR. LDVSR >= 1, and\n\ * if JOBVSR = 'V', LDVSR >= N.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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,2*N).\n\ * For good performance, LWORK must generally be larger.\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\ * RWORK (workspace) DOUBLE PRECISION array, dimension (8*N)\n\ *\n\ * BWORK (workspace) LOGICAL array, dimension (N)\n\ * Not referenced if SORT = 'N'.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * =1,...,N:\n\ * The QZ iteration failed. (A,B) are not in Schur\n\ * form, but ALPHA(j) and BETA(j) should be correct for\n\ * j=INFO+1,...,N.\n\ * > N: =N+1: other than QZ iteration failed in ZHGEQZ\n\ * =N+2: after reordering, roundoff changed values of\n\ * some complex eigenvalues so that leading\n\ * eigenvalues in the Generalized Schur form no\n\ * longer satisfy SELCTG=.TRUE. This could also\n\ * be caused due to scaling.\n\ * =N+3: reordering falied in ZTGSEN.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctrrfs0000644000175000017500000001147112502223525016516 0ustar uwabamiuwabami--- :name: ctrrfs :md5sum: 323b422cdf688d84bac937d4cd0110dd :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTRRFS provides error bounds and backward error estimates for the\n\ * solution to a system of linear equations with a triangular\n\ * coefficient matrix.\n\ *\n\ * The solution matrix X must be computed by CTRTRS or some other\n\ * means before entering this routine. CTRRFS does not do iterative\n\ * refinement because doing so cannot improve the backward error.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The triangular matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of the array A contains the upper\n\ * triangular matrix, and the strictly lower triangular part of\n\ * A is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of the array A contains the lower triangular\n\ * matrix, and the strictly upper triangular part of A is not\n\ * referenced. If DIAG = 'U', the diagonal elements of A are\n\ * also not referenced and are assumed to be 1.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input) COMPLEX array, dimension (LDX,NRHS)\n\ * The solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhpgst0000644000175000017500000000513412502223526016532 0ustar uwabamiuwabami--- :name: zhpgst :md5sum: a1803b2aef0acbf9361949b4fa807afd :category: :subroutine :arguments: - itype: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - bp: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZHPGST( ITYPE, UPLO, N, AP, BP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHPGST reduces a complex Hermitian-definite generalized\n\ * eigenproblem to standard form, using packed storage.\n\ *\n\ * If ITYPE = 1, the problem is A*x = lambda*B*x,\n\ * and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)\n\ *\n\ * If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n\ * B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L.\n\ *\n\ * B must have been previously factorized as U**H*U or L*L**H by ZPPTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);\n\ * = 2 or 3: compute U*A*U**H or L**H*A*L.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored and B is factored as\n\ * U**H*U;\n\ * = 'L': Lower triangle of A is stored and B is factored as\n\ * L*L**H.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, if INFO = 0, the transformed matrix, stored in the\n\ * same format as A.\n\ *\n\ * BP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * The triangular factor from the Cholesky factorization of B,\n\ * stored in the same format as A, as returned by ZPPTRF.\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clarfgp0000644000175000017500000000366612502223525016640 0ustar uwabamiuwabami--- :name: clarfgp :md5sum: 5d0def6a130365d7dc2054a64b3ca16a :category: :subroutine :arguments: - n: :type: integer :intent: input - alpha: :type: complex :intent: input/output - x: :type: complex :intent: input/output :dims: - 1+(n-2)*abs(incx) - incx: :type: integer :intent: input - tau: :type: complex :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CLARFGP( N, ALPHA, X, INCX, TAU )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLARFGP generates a complex elementary reflector H of order n, such\n\ * that\n\ *\n\ * H' * ( alpha ) = ( beta ), H' * H = I.\n\ * ( x ) ( 0 )\n\ *\n\ * where alpha and beta are scalars, beta is real and non-negative, and\n\ * x is an (n-1)-element complex vector. H is represented in the form\n\ *\n\ * H = I - tau * ( 1 ) * ( 1 v' ) ,\n\ * ( v )\n\ *\n\ * where tau is a complex scalar and v is a complex (n-1)-element\n\ * vector. Note that H is not hermitian.\n\ *\n\ * If the elements of x are all zero and alpha is real, then tau = 0\n\ * and H is taken to be the unit matrix.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the elementary reflector.\n\ *\n\ * ALPHA (input/output) COMPLEX\n\ * On entry, the value alpha.\n\ * On exit, it is overwritten with the value beta.\n\ *\n\ * X (input/output) COMPLEX array, dimension\n\ * (1+(N-2)*abs(INCX))\n\ * On entry, the vector x.\n\ * On exit, it is overwritten with the vector v.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between elements of X. INCX > 0.\n\ *\n\ * TAU (output) COMPLEX\n\ * The value tau.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slassq0000644000175000017500000000406012502223526016516 0ustar uwabamiuwabami--- :name: slassq :md5sum: f995f8d885203d131171606c9c567d08 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: real :intent: input :dims: - n - incx: :type: integer :intent: input - scale: :type: real :intent: input/output - sumsq: :type: real :intent: input/output :substitutions: {} :fortran_help: " SUBROUTINE SLASSQ( N, X, INCX, SCALE, SUMSQ )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLASSQ returns the values scl and smsq such that\n\ *\n\ * ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,\n\ *\n\ * where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is\n\ * assumed to be non-negative and scl returns the value\n\ *\n\ * scl = max( scale, abs( x( i ) ) ).\n\ *\n\ * scale and sumsq must be supplied in SCALE and SUMSQ and\n\ * scl and smsq are overwritten on SCALE and SUMSQ respectively.\n\ *\n\ * The routine makes only one pass through the vector x.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of elements to be used from the vector X.\n\ *\n\ * X (input) REAL array, dimension (N)\n\ * The vector for which a scaled sum of squares is computed.\n\ * x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between successive values of the vector X.\n\ * INCX > 0.\n\ *\n\ * SCALE (input/output) REAL\n\ * On entry, the value scale in the equation above.\n\ * On exit, SCALE is overwritten with scl , the scaling factor\n\ * for the sum of squares.\n\ *\n\ * SUMSQ (input/output) REAL\n\ * On entry, the value sumsq in the equation above.\n\ * On exit, SUMSQ is overwritten with smsq , the basic sum of\n\ * squares from which scl has been factored out.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cunmrq0000644000175000017500000001052012502223526016513 0ustar uwabamiuwabami--- :name: cunmrq :md5sum: 063a5e5bb2f967f76f827e9f6cf476bb :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - k - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CUNMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CUNMRQ overwrites the general complex M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'C': Q**H * C C * Q**H\n\ *\n\ * where Q is a complex unitary matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(1)' H(2)' . . . H(k)'\n\ *\n\ * as returned by CGERQF. Q is of order M if SIDE = 'L' and of order N\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**H from the Left;\n\ * = 'R': apply Q or Q**H from the Right.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q;\n\ * = 'C': Transpose, apply Q**H.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension\n\ * (LDA,M) if SIDE = 'L',\n\ * (LDA,N) if SIDE = 'R'\n\ * The i-th row must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * CGERQF in the last k rows of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,K).\n\ *\n\ * TAU (input) COMPLEX array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by CGERQF.\n\ *\n\ * C (input/output) COMPLEX array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace/output) COMPLEX 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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M).\n\ * For optimum performance LWORK >= N*NB if SIDE = 'L', and\n\ * LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n\ * 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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slasy20000644000175000017500000000772012502223526016433 0ustar uwabamiuwabami--- :name: slasy2 :md5sum: ae3def82cfd379e2cd0add43bc32316d :category: :subroutine :arguments: - ltranl: :type: logical :intent: input - ltranr: :type: logical :intent: input - isgn: :type: integer :intent: input - n1: :type: integer :intent: input - n2: :type: integer :intent: input - tl: :type: real :intent: input :dims: - ldtl - "2" - ldtl: :type: integer :intent: input - tr: :type: real :intent: input :dims: - ldtr - "2" - ldtr: :type: integer :intent: input - b: :type: real :intent: input :dims: - ldb - "2" - ldb: :type: integer :intent: input - scale: :type: real :intent: output - x: :type: real :intent: output :dims: - ldx - "2" - ldx: :type: integer :intent: input - xnorm: :type: real :intent: output - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n1) :fortran_help: " SUBROUTINE SLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in\n\ *\n\ * op(TL)*X + ISGN*X*op(TR) = SCALE*B,\n\ *\n\ * where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or\n\ * -1. op(T) = T or T', where T' denotes the transpose of T.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * LTRANL (input) LOGICAL\n\ * On entry, LTRANL specifies the op(TL):\n\ * = .FALSE., op(TL) = TL,\n\ * = .TRUE., op(TL) = TL'.\n\ *\n\ * LTRANR (input) LOGICAL\n\ * On entry, LTRANR specifies the op(TR):\n\ * = .FALSE., op(TR) = TR,\n\ * = .TRUE., op(TR) = TR'.\n\ *\n\ * ISGN (input) INTEGER\n\ * On entry, ISGN specifies the sign of the equation\n\ * as described before. ISGN may only be 1 or -1.\n\ *\n\ * N1 (input) INTEGER\n\ * On entry, N1 specifies the order of matrix TL.\n\ * N1 may only be 0, 1 or 2.\n\ *\n\ * N2 (input) INTEGER\n\ * On entry, N2 specifies the order of matrix TR.\n\ * N2 may only be 0, 1 or 2.\n\ *\n\ * TL (input) REAL array, dimension (LDTL,2)\n\ * On entry, TL contains an N1 by N1 matrix.\n\ *\n\ * LDTL (input) INTEGER\n\ * The leading dimension of the matrix TL. LDTL >= max(1,N1).\n\ *\n\ * TR (input) REAL array, dimension (LDTR,2)\n\ * On entry, TR contains an N2 by N2 matrix.\n\ *\n\ * LDTR (input) INTEGER\n\ * The leading dimension of the matrix TR. LDTR >= max(1,N2).\n\ *\n\ * B (input) REAL array, dimension (LDB,2)\n\ * On entry, the N1 by N2 matrix B contains the right-hand\n\ * side of the equation.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the matrix B. LDB >= max(1,N1).\n\ *\n\ * SCALE (output) REAL\n\ * On exit, SCALE contains the scale factor. SCALE is chosen\n\ * less than or equal to 1 to prevent the solution overflowing.\n\ *\n\ * X (output) REAL array, dimension (LDX,2)\n\ * On exit, X contains the N1 by N2 solution.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the matrix X. LDX >= max(1,N1).\n\ *\n\ * XNORM (output) REAL\n\ * On exit, XNORM is the infinity-norm of the solution.\n\ *\n\ * INFO (output) INTEGER\n\ * On exit, INFO is set to\n\ * 0: successful exit.\n\ * 1: TL and TR have too close eigenvalues, so TL or\n\ * TR is perturbed to get a nonsingular equation.\n\ * NOTE: In the interests of speed, this routine does not\n\ * check the inputs for errors.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slaqtr0000644000175000017500000001010112502223526016507 0ustar uwabamiuwabami--- :name: slaqtr :md5sum: 01fae868ef726aad2b53e42607504b14 :category: :subroutine :arguments: - ltran: :type: logical :intent: input - lreal: :type: logical :intent: input - n: :type: integer :intent: input - t: :type: real :intent: input :dims: - ldt - n - ldt: :type: integer :intent: input - b: :type: real :intent: input :dims: - n - w: :type: real :intent: input - scale: :type: real :intent: output - x: :type: real :intent: input/output :dims: - 2*n - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAQTR solves the real quasi-triangular system\n\ *\n\ * op(T)*p = scale*c, if LREAL = .TRUE.\n\ *\n\ * or the complex quasi-triangular systems\n\ *\n\ * op(T + iB)*(p+iq) = scale*(c+id), if LREAL = .FALSE.\n\ *\n\ * in real arithmetic, where T is upper quasi-triangular.\n\ * If LREAL = .FALSE., then the first diagonal block of T must be\n\ * 1 by 1, B is the specially structured matrix\n\ *\n\ * B = [ b(1) b(2) ... b(n) ]\n\ * [ w ]\n\ * [ w ]\n\ * [ . ]\n\ * [ w ]\n\ *\n\ * op(A) = A or A', A' denotes the conjugate transpose of\n\ * matrix A.\n\ *\n\ * On input, X = [ c ]. On output, X = [ p ].\n\ * [ d ] [ q ]\n\ *\n\ * This subroutine is designed for the condition number estimation\n\ * in routine STRSNA.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * LTRAN (input) LOGICAL\n\ * On entry, LTRAN specifies the option of conjugate transpose:\n\ * = .FALSE., op(T+i*B) = T+i*B,\n\ * = .TRUE., op(T+i*B) = (T+i*B)'.\n\ *\n\ * LREAL (input) LOGICAL\n\ * On entry, LREAL specifies the input matrix structure:\n\ * = .FALSE., the input is complex\n\ * = .TRUE., the input is real\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the order of T+i*B. N >= 0.\n\ *\n\ * T (input) REAL array, dimension (LDT,N)\n\ * On entry, T contains a matrix in Schur canonical form.\n\ * If LREAL = .FALSE., then the first diagonal block of T must\n\ * be 1 by 1.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the matrix T. LDT >= max(1,N).\n\ *\n\ * B (input) REAL array, dimension (N)\n\ * On entry, B contains the elements to form the matrix\n\ * B as described above.\n\ * If LREAL = .TRUE., B is not referenced.\n\ *\n\ * W (input) REAL\n\ * On entry, W is the diagonal element of the matrix B.\n\ * If LREAL = .TRUE., W is not referenced.\n\ *\n\ * SCALE (output) REAL\n\ * On exit, SCALE is the scale factor.\n\ *\n\ * X (input/output) REAL array, dimension (2*N)\n\ * On entry, X contains the right hand side of the system.\n\ * On exit, X is overwritten by the solution.\n\ *\n\ * WORK (workspace) REAL array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * On exit, INFO is set to\n\ * 0: successful exit.\n\ * 1: the some diagonal 1 by 1 block has been perturbed by\n\ * a small number SMIN to keep nonsingularity.\n\ * 2: the some diagonal 2 by 2 block has been perturbed by\n\ * a small number in SLALN2 to keep nonsingularity.\n\ * NOTE: In the interests of speed, this routine does not\n\ * check the inputs for errors.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlaqr30000644000175000017500000001746412502223526016440 0ustar uwabamiuwabami--- :name: zlaqr3 :md5sum: 278a48c359e34540731d6e298ce7c331 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ktop: :type: integer :intent: input - kbot: :type: integer :intent: input - nw: :type: integer :intent: input - h: :type: doublecomplex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: doublecomplex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - ns: :type: integer :intent: output - nd: :type: integer :intent: output - sh: :type: doublecomplex :intent: output :dims: - MAX(1,kbot) - v: :type: doublecomplex :intent: workspace :dims: - ldv - MAX(1,nw) - ldv: :type: integer :intent: input - nh: :type: integer :intent: input - t: :type: doublecomplex :intent: workspace :dims: - ldv - MAX(1,nw) - ldt: :type: integer :intent: input - nv: :type: integer :intent: input - wv: :type: doublecomplex :intent: workspace :dims: - ldv - MAX(1,nw) - ldwv: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*nw :substitutions: ldwv: nw ldt: nw ldv: nw :fortran_help: " SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n\ * Aggressive early deflation:\n\ *\n\ * This subroutine accepts as input an upper Hessenberg matrix\n\ * H and performs an unitary similarity transformation\n\ * designed to detect and deflate fully converged eigenvalues from\n\ * a trailing principal submatrix. On output H has been over-\n\ * written by a new Hessenberg matrix that is a perturbation of\n\ * an unitary similarity transformation of H. It is to be\n\ * hoped that the final version of H has many zero subdiagonal\n\ * entries.\n\ *\n\ * ******************************************************************\n\n\ * WANTT (input) LOGICAL\n\ * If .TRUE., then the Hessenberg matrix H is fully updated\n\ * so that the triangular Schur factor may be\n\ * computed (in cooperation with the calling subroutine).\n\ * If .FALSE., then only enough of H is updated to preserve\n\ * the eigenvalues.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * If .TRUE., then the unitary matrix Z is updated so\n\ * so that the unitary Schur factor may be computed\n\ * (in cooperation with the calling subroutine).\n\ * If .FALSE., then Z is not referenced.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H and (if WANTZ is .TRUE.) the\n\ * order of the unitary matrix Z.\n\ *\n\ * KTOP (input) INTEGER\n\ * It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n\ * KBOT and KTOP together determine an isolated block\n\ * along the diagonal of the Hessenberg matrix.\n\ *\n\ * KBOT (input) INTEGER\n\ * It is assumed without a check that either\n\ * KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together\n\ * determine an isolated block along the diagonal of the\n\ * Hessenberg matrix.\n\ *\n\ * NW (input) INTEGER\n\ * Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).\n\ *\n\ * H (input/output) COMPLEX*16 array, dimension (LDH,N)\n\ * On input the initial N-by-N section of H stores the\n\ * Hessenberg matrix undergoing aggressive early deflation.\n\ * On output H has been transformed by a unitary\n\ * similarity transformation, perturbed, and the returned\n\ * to Hessenberg form that (it is to be hoped) has some\n\ * zero subdiagonal entries.\n\ *\n\ * LDH (input) integer\n\ * Leading dimension of H just as declared in the calling\n\ * subroutine. N .LE. LDH\n\ *\n\ * ILOZ (input) INTEGER\n\ * IHIZ (input) INTEGER\n\ * Specify the rows of Z to which transformations must be\n\ * applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n\ *\n\ * Z (input/output) COMPLEX*16 array, dimension (LDZ,N)\n\ * IF WANTZ is .TRUE., then on output, the unitary\n\ * similarity transformation mentioned above has been\n\ * accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n\ * If WANTZ is .FALSE., then Z is unreferenced.\n\ *\n\ * LDZ (input) integer\n\ * The leading dimension of Z just as declared in the\n\ * calling subroutine. 1 .LE. LDZ.\n\ *\n\ * NS (output) integer\n\ * The number of unconverged (ie approximate) eigenvalues\n\ * returned in SR and SI that may be used as shifts by the\n\ * calling subroutine.\n\ *\n\ * ND (output) integer\n\ * The number of converged eigenvalues uncovered by this\n\ * subroutine.\n\ *\n\ * SH (output) COMPLEX*16 array, dimension KBOT\n\ * On output, approximate eigenvalues that may\n\ * be used for shifts are stored in SH(KBOT-ND-NS+1)\n\ * through SR(KBOT-ND). Converged eigenvalues are\n\ * stored in SH(KBOT-ND+1) through SH(KBOT).\n\ *\n\ * V (workspace) COMPLEX*16 array, dimension (LDV,NW)\n\ * An NW-by-NW work array.\n\ *\n\ * LDV (input) integer scalar\n\ * The leading dimension of V just as declared in the\n\ * calling subroutine. NW .LE. LDV\n\ *\n\ * NH (input) integer scalar\n\ * The number of columns of T. NH.GE.NW.\n\ *\n\ * T (workspace) COMPLEX*16 array, dimension (LDT,NW)\n\ *\n\ * LDT (input) integer\n\ * The leading dimension of T just as declared in the\n\ * calling subroutine. NW .LE. LDT\n\ *\n\ * NV (input) integer\n\ * The number of rows of work array WV available for\n\ * workspace. NV.GE.NW.\n\ *\n\ * WV (workspace) COMPLEX*16 array, dimension (LDWV,NW)\n\ *\n\ * LDWV (input) integer\n\ * The leading dimension of W just as declared in the\n\ * calling subroutine. NW .LE. LDV\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension LWORK.\n\ * On exit, WORK(1) is set to an estimate of the optimal value\n\ * of LWORK for the given values of N, NW, KTOP and KBOT.\n\ *\n\ * LWORK (input) integer\n\ * The dimension of the work array WORK. LWORK = 2*NW\n\ * suffices, but greater efficiency may result from larger\n\ * values of LWORK.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; ZLAQR3\n\ * only estimates the optimal workspace size for the given\n\ * values of N, NW, KTOP and KBOT. The estimate is returned\n\ * in WORK(1). No error message related to LWORK is issued\n\ * by XERBLA. Neither H nor Z are accessed.\n\ *\n\n\ * ================================================================\n\ * Based on contributions by\n\ * Karen Braman and Ralph Byers, Department of Mathematics,\n\ * University of Kansas, USA\n\ *\n\ * ================================================================\n" ruby-lapack-1.7.2/dev/defs/zlaqgb0000644000175000017500000000746212502223526016501 0ustar uwabamiuwabami--- :name: zlaqgb :md5sum: 2b4f33f517dd2fd23e7047fd285f0a66 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - r: :type: doublereal :intent: input :dims: - m - c: :type: doublereal :intent: input :dims: - n - rowcnd: :type: doublereal :intent: input - colcnd: :type: doublereal :intent: input - amax: :type: doublereal :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAQGB equilibrates a general M by N band matrix A with KL\n\ * subdiagonals and KU superdiagonals using the row and scaling factors\n\ * in the vectors R and C.\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\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n\ *\n\ * On exit, the equilibrated matrix, in the same storage format\n\ * as A. See EQUED for the form of the equilibrated matrix.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDA >= KL+KU+1.\n\ *\n\ * R (input) DOUBLE PRECISION array, dimension (M)\n\ * The row scale factors for A.\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension (N)\n\ * The column scale factors for A.\n\ *\n\ * ROWCND (input) DOUBLE PRECISION\n\ * Ratio of the smallest R(i) to the largest R(i).\n\ *\n\ * COLCND (input) DOUBLE PRECISION\n\ * Ratio of the smallest C(i) to the largest C(i).\n\ *\n\ * AMAX (input) DOUBLE PRECISION\n\ * Absolute value of largest matrix entry.\n\ *\n\ * EQUED (output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * THRESH is a threshold value used to decide if row or column scaling\n\ * should be done based on the ratio of the row or column scaling\n\ * factors. If ROWCND < THRESH, row scaling is done, and if\n\ * COLCND < THRESH, column scaling is done.\n\ *\n\ * LARGE and SMALL are threshold values used to decide if row scaling\n\ * should be done based on the absolute size of the largest matrix\n\ * element. If AMAX > LARGE or AMAX < SMALL, row scaling is done.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zunmql0000644000175000017500000001052712502223526016543 0ustar uwabamiuwabami--- :name: zunmql :md5sum: 47e081e59b96669df3b317550a70d83c :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZUNMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZUNMQL overwrites the general complex M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'C': Q**H * C C * Q**H\n\ *\n\ * where Q is a complex unitary matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(k) . . . H(2) H(1)\n\ *\n\ * as returned by ZGEQLF. Q is of order M if SIDE = 'L' and of order N\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**H from the Left;\n\ * = 'R': apply Q or Q**H from the Right.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q;\n\ * = 'C': Transpose, apply Q**H.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,K)\n\ * The i-th column must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * ZGEQLF in the last k columns of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ * If SIDE = 'L', LDA >= max(1,M);\n\ * if SIDE = 'R', LDA >= max(1,N).\n\ *\n\ * TAU (input) COMPLEX*16 array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by ZGEQLF.\n\ *\n\ * C (input/output) COMPLEX*16 array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M).\n\ * For optimum performance LWORK >= N*NB if SIDE = 'L', and\n\ * LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n\ * 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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dggbak0000644000175000017500000000743712502223526016442 0ustar uwabamiuwabami--- :name: dggbak :md5sum: b7d43e8ff3f48a5a2749288abaa6a7c0 :category: :subroutine :arguments: - job: :type: char :intent: input - side: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - lscale: :type: doublereal :intent: input :dims: - n - rscale: :type: doublereal :intent: input :dims: - n - m: :type: integer :intent: input - v: :type: doublereal :intent: input/output :dims: - ldv - m - ldv: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGGBAK forms the right or left eigenvectors of a real generalized\n\ * eigenvalue problem A*x = lambda*B*x, by backward transformation on\n\ * the computed eigenvectors of the balanced pair of matrices output by\n\ * DGGBAL.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * Specifies the type of backward transformation required:\n\ * = 'N': do nothing, return immediately;\n\ * = 'P': do backward transformation for permutation only;\n\ * = 'S': do backward transformation for scaling only;\n\ * = 'B': do backward transformations for both permutation and\n\ * scaling.\n\ * JOB must be the same as the argument JOB supplied to DGGBAL.\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'R': V contains right eigenvectors;\n\ * = 'L': V contains left eigenvectors.\n\ *\n\ * N (input) INTEGER\n\ * The number of rows of the matrix V. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * The integers ILO and IHI determined by DGGBAL.\n\ * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n\ *\n\ * LSCALE (input) DOUBLE PRECISION array, dimension (N)\n\ * Details of the permutations and/or scaling factors applied\n\ * to the left side of A and B, as returned by DGGBAL.\n\ *\n\ * RSCALE (input) DOUBLE PRECISION array, dimension (N)\n\ * Details of the permutations and/or scaling factors applied\n\ * to the right side of A and B, as returned by DGGBAL.\n\ *\n\ * M (input) INTEGER\n\ * The number of columns of the matrix V. M >= 0.\n\ *\n\ * V (input/output) DOUBLE PRECISION array, dimension (LDV,M)\n\ * On entry, the matrix of right or left eigenvectors to be\n\ * transformed, as returned by DTGEVC.\n\ * On exit, V is overwritten by the transformed eigenvectors.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the matrix V. LDV >= max(1,N).\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\ * See R.C. Ward, Balancing the generalized eigenvalue problem,\n\ * SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LEFTV, RIGHTV\n INTEGER I, K\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DSCAL, DSWAP, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cungbr0000644000175000017500000001047612502223526016500 0ustar uwabamiuwabami--- :name: cungbr :md5sum: ebdc563d42e1aaeb9f17a8b5cd146e40 :category: :subroutine :arguments: - vect: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - MIN(m,k) - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CUNGBR generates one of the complex unitary matrices Q or P**H\n\ * determined by CGEBRD when reducing a complex matrix A to bidiagonal\n\ * form: A = Q * B * P**H. Q and P**H are defined as products of\n\ * elementary reflectors H(i) or G(i) respectively.\n\ *\n\ * If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q\n\ * is of order M:\n\ * if m >= k, Q = H(1) H(2) . . . H(k) and CUNGBR returns the first n\n\ * columns of Q, where m >= n >= k;\n\ * if m < k, Q = H(1) H(2) . . . H(m-1) and CUNGBR returns Q as an\n\ * M-by-M matrix.\n\ *\n\ * If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**H\n\ * is of order N:\n\ * if k < n, P**H = G(k) . . . G(2) G(1) and CUNGBR returns the first m\n\ * rows of P**H, where n >= m >= k;\n\ * if k >= n, P**H = G(n-1) . . . G(2) G(1) and CUNGBR returns P**H as\n\ * an N-by-N matrix.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * VECT (input) CHARACTER*1\n\ * Specifies whether the matrix Q or the matrix P**H is\n\ * required, as defined in the transformation applied by CGEBRD:\n\ * = 'Q': generate Q;\n\ * = 'P': generate P**H.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q or P**H to be returned.\n\ * M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q or P**H to be returned.\n\ * N >= 0.\n\ * If VECT = 'Q', M >= N >= min(M,K);\n\ * if VECT = 'P', N >= M >= min(N,K).\n\ *\n\ * K (input) INTEGER\n\ * If VECT = 'Q', the number of columns in the original M-by-K\n\ * matrix reduced by CGEBRD.\n\ * If VECT = 'P', the number of rows in the original K-by-N\n\ * matrix reduced by CGEBRD.\n\ * K >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the vectors which define the elementary reflectors,\n\ * as returned by CGEBRD.\n\ * On exit, the M-by-N matrix Q or P**H.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= M.\n\ *\n\ * TAU (input) COMPLEX array, dimension\n\ * (min(M,K)) if VECT = 'Q'\n\ * (min(N,K)) if VECT = 'P'\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i) or G(i), which determines Q or P**H, as\n\ * returned by CGEBRD in its array argument TAUQ or TAUP.\n\ *\n\ * WORK (workspace/output) COMPLEX 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,min(M,N)).\n\ * For optimum performance LWORK >= min(M,N)*NB, where NB\n\ * is the 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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zstemr0000644000175000017500000003140112502223526016533 0ustar uwabamiuwabami--- :name: zstemr :md5sum: 18429e0d76905fc8f0eb2c094229686f :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - nzc: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - tryrac: :type: logical :intent: input/output - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 18*n : lsame_(&jobz,\"N\") ? 12*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 10*n : lsame_(&jobz,\"N\") ? 8*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " SUBROUTINE ZSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSTEMR computes selected eigenvalues and, optionally, eigenvectors\n\ * of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n\ * a well defined set of pairwise different real eigenvalues, the corresponding\n\ * real eigenvectors are pairwise orthogonal.\n\ *\n\ * The spectrum may be computed either completely or partially by specifying\n\ * either an interval (VL,VU] or a range of indices IL:IU for the desired\n\ * eigenvalues.\n\ *\n\ * Depending on the number of desired eigenvalues, these are computed either\n\ * by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are\n\ * computed by the use of various suitable L D L^T factorizations near clusters\n\ * of close eigenvalues (referred to as RRRs, Relatively Robust\n\ * Representations). An informal sketch of the algorithm follows.\n\ *\n\ * For each unreduced block (submatrix) of T,\n\ * (a) Compute T - sigma I = L D L^T, so that L and D\n\ * define all the wanted eigenvalues to high relative accuracy.\n\ * This means that small relative changes in the entries of D and L\n\ * cause only small relative changes in the eigenvalues and\n\ * eigenvectors. The standard (unfactored) representation of the\n\ * tridiagonal matrix T does not have this property in general.\n\ * (b) Compute the eigenvalues to suitable accuracy.\n\ * If the eigenvectors are desired, the algorithm attains full\n\ * accuracy of the computed eigenvalues only right before\n\ * the corresponding vectors have to be computed, see steps c) and d).\n\ * (c) For each cluster of close eigenvalues, select a new\n\ * shift close to the cluster, find a new factorization, and refine\n\ * the shifted eigenvalues to suitable accuracy.\n\ * (d) For each eigenvalue with a large enough relative separation compute\n\ * the corresponding eigenvector by forming a rank revealing twisted\n\ * factorization. Go back to (c) for any clusters that remain.\n\ *\n\ * For more details, see:\n\ * - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n\ * to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n\ * Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n\ * - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n\ * Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n\ * 2004. Also LAPACK Working Note 154.\n\ * - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n\ * tridiagonal eigenvalue/eigenvector problem\",\n\ * Computer Science Division Technical Report No. UCB/CSD-97-971,\n\ * UC Berkeley, May 1997.\n\ *\n\ * Further Details\n\ * 1.ZSTEMR works only on machines which follow IEEE-754\n\ * floating-point standard in their handling of infinities and NaNs.\n\ * This permits the use of efficient inner loops avoiding a check for\n\ * zero divisors.\n\ *\n\ * 2. LAPACK routines can be used to reduce a complex Hermitean matrix to\n\ * real symmetric tridiagonal form.\n\ *\n\ * (Any complex Hermitean tridiagonal matrix has real values on its diagonal\n\ * and potentially complex numbers on its off-diagonals. By applying a\n\ * similarity transform with an appropriate diagonal matrix\n\ * diag(1,e^{i \\phy_1}, ... , e^{i \\phy_{n-1}}), the complex Hermitean\n\ * matrix can be transformed into a real symmetric matrix and complex\n\ * arithmetic can be entirely avoided.)\n\ *\n\ * While the eigenvectors of the real symmetric tridiagonal matrix are real,\n\ * the eigenvectors of original complex Hermitean matrix have complex entries\n\ * in general.\n\ * Since LAPACK drivers overwrite the matrix data with the eigenvectors,\n\ * ZSTEMR accepts complex workspace to facilitate interoperability\n\ * with ZUNMTR or ZUPMTR.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found.\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found.\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the N diagonal elements of the tridiagonal matrix\n\ * T. On exit, D is overwritten.\n\ *\n\ * E (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the (N-1) subdiagonal elements of the tridiagonal\n\ * matrix T in elements 1 to N-1 of E. E(N) need not be set on\n\ * input, but is used internally as workspace.\n\ * On exit, E is overwritten.\n\ *\n\ * VL (input) DOUBLE PRECISION\n\ * VU (input) DOUBLE PRECISION\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * The first M elements contain the selected eigenvalues in\n\ * ascending order.\n\ *\n\ * Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M) )\n\ * If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix T\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and can be computed with a workspace\n\ * query by setting NZC = -1, see below.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', then LDZ >= max(1,N).\n\ *\n\ * NZC (input) INTEGER\n\ * The number of eigenvectors to be held in the array Z.\n\ * If RANGE = 'A', then NZC >= max(1,N).\n\ * If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].\n\ * If RANGE = 'I', then NZC >= IU-IL+1.\n\ * If NZC = -1, then a workspace query is assumed; the\n\ * routine calculates the number of columns of the array Z that\n\ * are needed to hold the eigenvectors.\n\ * This value is returned as the first entry of the Z array, and\n\ * no error message related to NZC is issued by XERBLA.\n\ *\n\ * ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n\ * The support of the eigenvectors in Z, i.e., the indices\n\ * indicating the nonzero elements in Z. The i-th computed eigenvector\n\ * is nonzero only in elements ISUPPZ( 2*i-1 ) through\n\ * ISUPPZ( 2*i ). This is relevant in the case when the matrix\n\ * is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n\ *\n\ * TRYRAC (input/output) LOGICAL\n\ * If TRYRAC.EQ..TRUE., indicates that the code should check whether\n\ * the tridiagonal matrix defines its eigenvalues to high relative\n\ * accuracy. If so, the code uses relative-accuracy preserving\n\ * algorithms that might be (a bit) slower depending on the matrix.\n\ * If the matrix does not define its eigenvalues to high relative\n\ * accuracy, the code can uses possibly faster algorithms.\n\ * If TRYRAC.EQ..FALSE., the code is not required to guarantee\n\ * relatively accurate eigenvalues and can use the fastest possible\n\ * techniques.\n\ * On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix\n\ * does not define its eigenvalues to high relative accuracy.\n\ *\n\ * WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)\n\ * On exit, if INFO = 0, WORK(1) returns the optimal\n\ * (and minimal) LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK >= max(1,18*N)\n\ * if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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\ * IWORK (workspace/output) INTEGER array, dimension (LIWORK)\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK. LIWORK >= max(1,10*N)\n\ * if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n\ * if only the eigenvalues are to be computed.\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal size of the IWORK array,\n\ * returns this value as the first entry of the IWORK array, and\n\ * no error message related to LIWORK is issued by XERBLA.\n\ *\n\ * INFO (output) INTEGER\n\ * On exit, INFO\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: if INFO = 1X, internal error in DLARRE,\n\ * if INFO = 2X, internal error in ZLARRV.\n\ * Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n\ * the nonzero error code returned by DLARRE or\n\ * ZLARRV, respectively.\n\ *\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Beresford Parlett, University of California, Berkeley, USA\n\ * Jim Demmel, University of California, Berkeley, USA\n\ * Inderjit Dhillon, University of Texas, Austin, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, University of California, Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cpoequ0000644000175000017500000000476412502223525016516 0ustar uwabamiuwabami--- :name: cpoequ :md5sum: 682ec464ccfd2c44926755219357888c :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - s: :type: real :intent: output :dims: - n - scond: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPOEQU computes row and column scalings intended to equilibrate a\n\ * Hermitian positive definite matrix A and reduce its condition number\n\ * (with respect to the two-norm). S contains the scale factors,\n\ * S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n\ * elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n\ * choice of S puts the condition number of B within a factor N of the\n\ * smallest possible condition number over all possible diagonal\n\ * scalings.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The N-by-N Hermitian positive definite matrix whose scaling\n\ * factors are to be computed. Only the diagonal elements of A\n\ * are referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * S (output) REAL array, dimension (N)\n\ * If INFO = 0, S contains the scale factors for A.\n\ *\n\ * SCOND (output) REAL\n\ * If INFO = 0, S contains the ratio of the smallest S(i) to\n\ * the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n\ * large nor too small, it is not worth scaling by S.\n\ *\n\ * AMAX (output) REAL\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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 is nonpositive.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgegv0000644000175000017500000002550512502223526016332 0ustar uwabamiuwabami--- :name: sgegv :md5sum: f9d4bda2151f7908cecf6379e361761b :category: :subroutine :arguments: - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alphar: :type: real :intent: output :dims: - n - alphai: :type: real :intent: output :dims: - n - beta: :type: real :intent: output :dims: - n - vl: :type: real :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: real :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 8*n - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " SUBROUTINE SGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This routine is deprecated and has been replaced by routine SGGEV.\n\ *\n\ * SGEGV computes the eigenvalues and, optionally, the left and/or right\n\ * eigenvectors of a real matrix pair (A,B).\n\ * Given two square matrices A and B,\n\ * the generalized nonsymmetric eigenvalue problem (GNEP) is to find the\n\ * eigenvalues lambda and corresponding (non-zero) eigenvectors x such\n\ * that\n\ *\n\ * A*x = lambda*B*x.\n\ *\n\ * An alternate form is to find the eigenvalues mu and corresponding\n\ * eigenvectors y such that\n\ *\n\ * mu*A*y = B*y.\n\ *\n\ * These two forms are equivalent with mu = 1/lambda and x = y if\n\ * neither lambda nor mu is zero. In order to deal with the case that\n\ * lambda or mu is zero or small, two values alpha and beta are returned\n\ * for each eigenvalue, such that lambda = alpha/beta and\n\ * mu = beta/alpha.\n\ *\n\ * The vectors x and y in the above equations are right eigenvectors of\n\ * the matrix pair (A,B). Vectors u and v satisfying\n\ *\n\ * u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B\n\ *\n\ * are left eigenvectors of (A,B).\n\ *\n\ * Note: this routine performs \"full balancing\" on A and B -- see\n\ * \"Further Details\", below.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVL (input) CHARACTER*1\n\ * = 'N': do not compute the left generalized eigenvectors;\n\ * = 'V': compute the left generalized eigenvectors (returned\n\ * in VL).\n\ *\n\ * JOBVR (input) CHARACTER*1\n\ * = 'N': do not compute the right generalized eigenvectors;\n\ * = 'V': compute the right generalized eigenvectors (returned\n\ * in VR).\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A, B, VL, and VR. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA, N)\n\ * On entry, the matrix A.\n\ * If JOBVL = 'V' or JOBVR = 'V', then on exit A\n\ * contains the real Schur form of A from the generalized Schur\n\ * factorization of the pair (A,B) after balancing.\n\ * If no eigenvectors were computed, then only the diagonal\n\ * blocks from the Schur form will be correct. See SGGHRD and\n\ * SHGEQZ for details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of A. LDA >= max(1,N).\n\ *\n\ * B (input/output) REAL array, dimension (LDB, N)\n\ * On entry, the matrix B.\n\ * If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the\n\ * upper triangular matrix obtained from B in the generalized\n\ * Schur factorization of the pair (A,B) after balancing.\n\ * If no eigenvectors were computed, then only those elements of\n\ * B corresponding to the diagonal blocks from the Schur form of\n\ * A will be correct. See SGGHRD and SHGEQZ for details.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B. LDB >= max(1,N).\n\ *\n\ * ALPHAR (output) REAL array, dimension (N)\n\ * The real parts of each scalar alpha defining an eigenvalue of\n\ * GNEP.\n\ *\n\ * ALPHAI (output) REAL array, dimension (N)\n\ * The imaginary parts of each scalar alpha defining an\n\ * eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th\n\ * eigenvalue is real; if positive, then the j-th and\n\ * (j+1)-st eigenvalues are a complex conjugate pair, with\n\ * ALPHAI(j+1) = -ALPHAI(j).\n\ *\n\ * BETA (output) REAL array, dimension (N)\n\ * The scalars beta that define the eigenvalues of GNEP.\n\ * \n\ * Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and\n\ * beta = BETA(j) represent the j-th eigenvalue of the matrix\n\ * pair (A,B), in one of the forms lambda = alpha/beta or\n\ * mu = beta/alpha. Since either lambda or mu may overflow,\n\ * they should not, in general, be computed.\n\ *\n\ * VL (output) REAL array, dimension (LDVL,N)\n\ * If JOBVL = 'V', the left eigenvectors u(j) are stored\n\ * in the columns of VL, in the same order as their eigenvalues.\n\ * If the j-th eigenvalue is real, then u(j) = VL(:,j).\n\ * If the j-th and (j+1)-st eigenvalues form a complex conjugate\n\ * pair, then\n\ * u(j) = VL(:,j) + i*VL(:,j+1)\n\ * and\n\ * u(j+1) = VL(:,j) - i*VL(:,j+1).\n\ *\n\ * Each eigenvector is scaled so that its largest component has\n\ * abs(real part) + abs(imag. part) = 1, except for eigenvectors\n\ * corresponding to an eigenvalue with alpha = beta = 0, which\n\ * are set to zero.\n\ * Not referenced if JOBVL = 'N'.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the matrix VL. LDVL >= 1, and\n\ * if JOBVL = 'V', LDVL >= N.\n\ *\n\ * VR (output) REAL array, dimension (LDVR,N)\n\ * If JOBVR = 'V', the right eigenvectors x(j) are stored\n\ * in the columns of VR, in the same order as their eigenvalues.\n\ * If the j-th eigenvalue is real, then x(j) = VR(:,j).\n\ * If the j-th and (j+1)-st eigenvalues form a complex conjugate\n\ * pair, then\n\ * x(j) = VR(:,j) + i*VR(:,j+1)\n\ * and\n\ * x(j+1) = VR(:,j) - i*VR(:,j+1).\n\ *\n\ * Each eigenvector is scaled so that its largest component has\n\ * abs(real part) + abs(imag. part) = 1, except for eigenvalues\n\ * corresponding to an eigenvalue with alpha = beta = 0, which\n\ * are set to zero.\n\ * Not referenced if JOBVR = 'N'.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the matrix VR. LDVR >= 1, and\n\ * if JOBVR = 'V', LDVR >= N.\n\ *\n\ * WORK (workspace/output) REAL 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,8*N).\n\ * For good performance, LWORK must generally be larger.\n\ * To compute the optimal value of LWORK, call ILAENV to get\n\ * blocksizes (for SGEQRF, SORMQR, and SORGQR.) Then compute:\n\ * NB -- MAX of the blocksizes for SGEQRF, SORMQR, and SORGQR;\n\ * The optimal LWORK is:\n\ * 2*N + MAX( 6*N, N*(NB+1) ).\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\ * = 1,...,N:\n\ * The QZ iteration failed. No eigenvectors have been\n\ * calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)\n\ * should be correct for j=INFO+1,...,N.\n\ * > N: errors that usually indicate LAPACK problems:\n\ * =N+1: error return from SGGBAL\n\ * =N+2: error return from SGEQRF\n\ * =N+3: error return from SORMQR\n\ * =N+4: error return from SORGQR\n\ * =N+5: error return from SGGHRD\n\ * =N+6: error return from SHGEQZ (other than failed\n\ * iteration)\n\ * =N+7: error return from STGEVC\n\ * =N+8: error return from SGGBAK (computing VL)\n\ * =N+9: error return from SGGBAK (computing VR)\n\ * =N+10: error return from SLASCL (various calls)\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Balancing\n\ * ---------\n\ *\n\ * This driver calls SGGBAL to both permute and scale rows and columns\n\ * of A and B. The permutations PL and PR are chosen so that PL*A*PR\n\ * and PL*B*R will be upper triangular except for the diagonal blocks\n\ * A(i:j,i:j) and B(i:j,i:j), with i and j as close together as\n\ * possible. The diagonal scaling matrices DL and DR are chosen so\n\ * that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to\n\ * one (except for the elements that start out zero.)\n\ *\n\ * After the eigenvalues and eigenvectors of the balanced matrices\n\ * have been computed, SGGBAK transforms the eigenvectors back to what\n\ * they would have been (in perfect arithmetic) if they had not been\n\ * balanced.\n\ *\n\ * Contents of A and B on Exit\n\ * -------- -- - --- - -- ----\n\ *\n\ * If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or\n\ * both), then on exit the arrays A and B will contain the real Schur\n\ * form[*] of the \"balanced\" versions of A and B. If no eigenvectors\n\ * are computed, then only the diagonal blocks will be correct.\n\ *\n\ * [*] See SHGEQZ, SGEGS, or read the book \"Matrix Computations\",\n\ * by Golub & van Loan, pub. by Johns Hopkins U. Press.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chpcon0000644000175000017500000000501512502223525016462 0ustar uwabamiuwabami--- :name: chpcon :md5sum: 45e9e05f044d66f178f8b343741c88fd :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: complex :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CHPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHPCON estimates the reciprocal of the condition number of a complex\n\ * Hermitian packed matrix A using the factorization A = U*D*U**H or\n\ * A = L*D*L**H computed by CHPTRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**H;\n\ * = 'L': Lower triangular, form is A = L*D*L**H.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input) COMPLEX array, dimension (N*(N+1)/2)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by CHPTRF, stored as a\n\ * packed triangular matrix.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by CHPTRF.\n\ *\n\ * ANORM (input) REAL\n\ * The 1-norm of the original matrix A.\n\ *\n\ * RCOND (output) REAL\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n\ * estimate of the 1-norm of inv(A) computed in this routine.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgbsvxx0000644000175000017500000005646712502223526016745 0ustar uwabamiuwabami--- :name: zgbsvxx :md5sum: 58ec725c8a0af23ab9c7821a70c40cc6 :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublecomplex :intent: input/output :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - equed: :type: char :intent: input/output - r: :type: doublereal :intent: input/output :dims: - n - c: :type: doublereal :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - rpvgrw: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " SUBROUTINE ZGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGBSVXX uses the LU factorization to compute the solution to a\n\ * complex*16 system of linear equations A * X = B, where A is an\n\ * N-by-N matrix and X and B are N-by-NRHS matrices.\n\ *\n\ * If requested, both normwise and maximum componentwise error bounds\n\ * are returned. ZGBSVXX will return a solution with a tiny\n\ * guaranteed error (O(eps) where eps is the working machine\n\ * precision) unless the matrix is very ill-conditioned, in which\n\ * case a warning is returned. Relevant condition numbers also are\n\ * calculated and returned.\n\ *\n\ * ZGBSVXX accepts user-provided factorizations and equilibration\n\ * factors; see the definitions of the FACT and EQUED options.\n\ * Solving with refinement and using a factorization from a previous\n\ * ZGBSVXX call will also produce a solution with either O(eps)\n\ * errors or warnings, but we cannot make that claim for general\n\ * user-provided factorizations and equilibration factors if they\n\ * differ from what ZGBSVXX would itself produce.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n\ * the system:\n\ *\n\ * TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n\ * TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n\ * TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n\ *\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n\ * or diag(C)*B (if TRANS = 'T' or 'C').\n\ *\n\ * 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n\ * the matrix A (after equilibration if FACT = 'E') as\n\ *\n\ * A = P * L * U,\n\ *\n\ * where P is a permutation matrix, L is a unit lower triangular\n\ * matrix, and U is upper triangular.\n\ *\n\ * 3. If some U(i,i)=0, so that U is exactly singular, then the\n\ * routine returns with INFO = i. Otherwise, the factored form of A\n\ * is used to estimate the condition number of the matrix A (see\n\ * argument RCOND). If the reciprocal of the condition number is less\n\ * than machine precision, the routine still goes on to solve for X\n\ * and compute error bounds as described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n\ * the routine will use iterative refinement to try to get a small\n\ * error and error bounds. Refinement calculates the residual to at\n\ * least twice the working precision.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n\ * that it solves the original system before equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AF and IPIV contain the factored form of A.\n\ * If EQUED is not 'N', the matrix A has been\n\ * equilibrated with scaling factors given by R and C.\n\ * A, AF, and IPIV are not modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AF and factored.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate Transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n\ *\n\ * If FACT = 'F' and EQUED is not 'N', then AB must have been\n\ * equilibrated by the scaling factors in R and/or C. AB is not\n\ * modified if FACT = 'F' or 'N', or if FACT = 'E' and\n\ * EQUED = 'N' on exit.\n\ *\n\ * On exit, if EQUED .ne. 'N', A is scaled as follows:\n\ * EQUED = 'R': A := diag(R) * A\n\ * EQUED = 'C': A := A * diag(C)\n\ * EQUED = 'B': A := diag(R) * A * diag(C).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * AFB (input or output) COMPLEX*16 array, dimension (LDAFB,N)\n\ * If FACT = 'F', then AFB is an input argument and on entry\n\ * contains details of the LU factorization of the band matrix\n\ * A, as computed by ZGBTRF. U is stored as an upper triangular\n\ * band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n\ * and the multipliers used during the factorization are stored\n\ * in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is\n\ * the factored form of the equilibrated matrix A.\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the factors L and U from the factorization A = P*L*U\n\ * of the original matrix A.\n\ *\n\ * If FACT = 'E', then AF is an output argument and on exit\n\ * returns the factors L and U from the factorization A = P*L*U\n\ * of the equilibrated matrix A (see the description of A for\n\ * the form of the equilibrated matrix).\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * as computed by DGETRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * of the original matrix A.\n\ *\n\ * If FACT = 'E', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * of the equilibrated matrix A.\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * R (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'R' or 'B', A is\n\ * multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n\ * is not accessed. R is an input argument if FACT = 'F';\n\ * otherwise, R is an output argument. If FACT = 'F' and\n\ * EQUED = 'R' or 'B', each element of R must be positive.\n\ * If R is output, each element of R is a power of the radix.\n\ * If R is input, each element of R should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * C (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The column scale factors for A. If EQUED = 'C' or 'B', A is\n\ * multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n\ * is not accessed. C is an input argument if FACT = 'F';\n\ * otherwise, C is an output argument. If FACT = 'F' and\n\ * EQUED = 'C' or 'B', each element of C must be positive.\n\ * If C is output, each element of C is a power of the radix.\n\ * If C is input, each element of C should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit,\n\ * if EQUED = 'N', B is not modified;\n\ * if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n\ * diag(R)*B;\n\ * if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n\ * overwritten by diag(C)*B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * If INFO = 0, the N-by-NRHS solution matrix X to the original\n\ * system of equations. Note that A and B are modified on exit\n\ * if EQUED .ne. 'N', and the solution to the equilibrated system is\n\ * inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n\ * inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * RPVGRW (output) DOUBLE PRECISION\n\ * Reciprocal pivot growth. On exit, this contains the reciprocal\n\ * pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n\ * norm is used. If this is much less than 1, then the stability of\n\ * the LU factorization of the (equilibrated) matrix A could be poor.\n\ * This also means that the solution X, estimated condition numbers,\n\ * and error bounds could be unreliable. If factorization fails with\n\ * 0 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/spocon0000644000175000017500000000463712502223526016523 0ustar uwabamiuwabami--- :name: spocon :md5sum: a8e596611b25d484e9d2cf8ee1b2f6c1 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPOCON estimates the reciprocal of the condition number (in the \n\ * 1-norm) of a real symmetric positive definite matrix using the\n\ * Cholesky factorization A = U**T*U or A = L*L**T computed by SPOTRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T, as computed by SPOTRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * ANORM (input) REAL\n\ * The 1-norm (or infinity-norm) of the symmetric matrix A.\n\ *\n\ * RCOND (output) REAL\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n\ * estimate of the 1-norm of inv(A) computed in this routine.\n\ *\n\ * WORK (workspace) REAL array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clansp0000644000175000017500000000546512502223525016501 0ustar uwabamiuwabami--- :name: clansp :md5sum: 140cc467da7a57d49c7fb0014ea4ecc1 :category: :function :type: real :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - work: :type: real :intent: workspace :dims: - "MAX(1,(lsame_(&norm,\"I\")||lsame_(&norm,\"1\")||lsame_(&norm,\"O\")) ? n : 0)" :substitutions: {} :fortran_help: " REAL FUNCTION CLANSP( NORM, UPLO, N, AP, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLANSP returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * complex symmetric matrix A, supplied in packed form.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * CLANSP returns the value\n\ *\n\ * CLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in CLANSP as described\n\ * above.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is supplied.\n\ * = 'U': Upper triangular part of A is supplied\n\ * = 'L': Lower triangular part of A is supplied\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, CLANSP is\n\ * set to zero.\n\ *\n\ * AP (input) COMPLEX array, dimension (N*(N+1)/2)\n\ * The upper or lower triangle of the symmetric matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n\ * WORK is not referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlapy30000644000175000017500000000145312502223526016407 0ustar uwabamiuwabami--- :name: dlapy3 :md5sum: c296e214a3a458bf2d8aca2d8a9f6f10 :category: :function :type: doublereal :arguments: - x: :type: doublereal :intent: input - y: :type: doublereal :intent: input - z: :type: doublereal :intent: input :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause\n\ * unnecessary overflow.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * X (input) DOUBLE PRECISION\n\ * Y (input) DOUBLE PRECISION\n\ * Z (input) DOUBLE PRECISION\n\ * X, Y and Z specify the values x, y and z.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhesvx0000644000175000017500000002356612502223526016553 0ustar uwabamiuwabami--- :name: zhesvx :md5sum: d32755a1d0cd2467834e0bb251f252c1 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE ZHESVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHESVX uses the diagonal pivoting factorization to compute the\n\ * solution to a complex system of linear equations A * X = B,\n\ * where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS\n\ * matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'N', the diagonal pivoting method is used to factor A.\n\ * The form of the factorization is\n\ * A = U * D * U**H, if UPLO = 'U', or\n\ * A = L * D * L**H, if UPLO = 'L',\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, and D is Hermitian and block diagonal with\n\ * 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\ * 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n\ * returns with INFO = i. Otherwise, the factored form of A is used\n\ * to estimate the condition number of the matrix A. If the\n\ * reciprocal of the condition number is less than machine precision,\n\ * INFO = N+1 is returned as a warning, but the routine still goes on\n\ * to solve for X and compute error bounds as described below.\n\ *\n\ * 3. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 4. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of A has been\n\ * supplied on entry.\n\ * = 'F': On entry, AF and IPIV contain the factored form\n\ * of A. A, AF and IPIV will not be modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The Hermitian matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular part\n\ * of the matrix A, and the strictly lower triangular part of A\n\ * is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of A contains the lower triangular part of\n\ * the matrix A, and the strictly upper triangular part of A is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input or output) COMPLEX*16 array, dimension (LDAF,N)\n\ * If FACT = 'F', then AF is an input argument and on entry\n\ * contains the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L from the factorization\n\ * A = U*D*U**H or A = L*D*L**H as computed by ZHETRF.\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L from the factorization\n\ * A = U*D*U**H or A = L*D*L**H.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains details of the interchanges and the block structure\n\ * of D, as determined by ZHETRF.\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains details of the interchanges and the block structure\n\ * of D, as determined by ZHETRF.\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The N-by-NRHS right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A. If RCOND is less than the machine precision (in\n\ * particular, if RCOND = 0), the matrix is singular to working\n\ * precision. This condition is indicated by a return code of\n\ * INFO > 0.\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of WORK. LWORK >= max(1,2*N), and for best\n\ * performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where\n\ * NB is the optimal blocksize for ZHETRF.\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\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\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, and i is\n\ * <= N: D(i,i) is exactly zero. The factorization\n\ * has been completed but the factor D is exactly\n\ * singular, so the solution and error bounds could\n\ * not be computed. RCOND = 0 is returned.\n\ * = N+1: D is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zggrqf0000644000175000017500000001556712502223526016526 0ustar uwabamiuwabami--- :name: zggrqf :md5sum: 585d26f527a6d3aa55af7c50990d406c :category: :subroutine :arguments: - m: :type: integer :intent: input - p: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - taua: :type: doublecomplex :intent: output :dims: - MIN(m,n) - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - taub: :type: doublecomplex :intent: output :dims: - MIN(p,n) - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(MAX(n,m),p) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGGRQF computes a generalized RQ factorization of an M-by-N matrix A\n\ * and a P-by-N matrix B:\n\ *\n\ * A = R*Q, B = Z*T*Q,\n\ *\n\ * where Q is an N-by-N unitary matrix, Z is a P-by-P unitary\n\ * matrix, and R and T assume one of the forms:\n\ *\n\ * if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N,\n\ * N-M M ( R21 ) N\n\ * N\n\ *\n\ * where R12 or R21 is upper triangular, and\n\ *\n\ * if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P,\n\ * ( 0 ) P-N P N-P\n\ * N\n\ *\n\ * where T11 is upper triangular.\n\ *\n\ * In particular, if B is square and nonsingular, the GRQ factorization\n\ * of A and B implicitly gives the RQ factorization of A*inv(B):\n\ *\n\ * A*inv(B) = (R*inv(T))*Z'\n\ *\n\ * where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n\ * conjugate transpose of the matrix Z.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A. M >= 0.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows of the matrix B. P >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, if M <= N, the upper triangle of the subarray\n\ * A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;\n\ * if M > N, the elements on and above the (M-N)-th subdiagonal\n\ * contain the M-by-N upper trapezoidal matrix R; the remaining\n\ * elements, with the array TAUA, represent the unitary\n\ * matrix Q as a product of elementary reflectors (see Further\n\ * Details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAUA (output) COMPLEX*16 array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the unitary matrix Q (see Further Details).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,N)\n\ * On entry, the P-by-N matrix B.\n\ * On exit, the elements on and above the diagonal of the array\n\ * contain the min(P,N)-by-N upper trapezoidal matrix T (T is\n\ * upper triangular if P >= N); the elements below the diagonal,\n\ * with the array TAUB, represent the unitary matrix Z as a\n\ * product of elementary reflectors (see Further Details).\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,P).\n\ *\n\ * TAUB (output) COMPLEX*16 array, dimension (min(P,N))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the unitary matrix Z (see Further Details).\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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,N,M,P).\n\ * For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n\ * where NB1 is the optimal blocksize for the RQ factorization\n\ * of an M-by-N matrix, NB2 is the optimal blocksize for the\n\ * QR factorization of a P-by-N matrix, and NB3 is the optimal\n\ * blocksize for a call of ZUNMRQ.\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(1) H(2) . . . H(k), where k = min(m,n).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - taua * v * v'\n\ *\n\ * where taua is a complex scalar, and v is a complex vector with\n\ * v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n\ * A(m-k+i,1:n-k+i-1), and taua in TAUA(i).\n\ * To form Q explicitly, use LAPACK subroutine ZUNGRQ.\n\ * To use Q to update another matrix, use LAPACK subroutine ZUNMRQ.\n\ *\n\ * The matrix Z is represented as a product of elementary reflectors\n\ *\n\ * Z = H(1) H(2) . . . H(k), where k = min(p,n).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - taub * v * v'\n\ *\n\ * where taub is a complex scalar, and v is a complex vector with\n\ * v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),\n\ * and taub in TAUB(i).\n\ * To form Z explicitly, use LAPACK subroutine ZUNGQR.\n\ * To use Z to update another matrix, use LAPACK subroutine ZUNMQR.\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZGEQRF, ZGERQF, ZUNMRQ\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC INT, MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zunmr20000644000175000017500000000735712502223526016461 0ustar uwabamiuwabami--- :name: zunmr2 :md5sum: 6bd0a8cf80613c3965370e82e015fa65 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZUNMR2 overwrites the general complex m-by-n matrix C with\n\ *\n\ * Q * C if SIDE = 'L' and TRANS = 'N', or\n\ *\n\ * Q'* C if SIDE = 'L' and TRANS = 'C', or\n\ *\n\ * C * Q if SIDE = 'R' and TRANS = 'N', or\n\ *\n\ * C * Q' if SIDE = 'R' and TRANS = 'C',\n\ *\n\ * where Q is a complex unitary matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(1)' H(2)' . . . H(k)'\n\ *\n\ * as returned by ZGERQF. Q is of order m if SIDE = 'L' and of order n\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q' from the Left\n\ * = 'R': apply Q or Q' from the Right\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': apply Q (No transpose)\n\ * = 'C': apply Q' (Conjugate transpose)\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension\n\ * (LDA,M) if SIDE = 'L',\n\ * (LDA,N) if SIDE = 'R'\n\ * The i-th row must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * ZGERQF in the last k rows of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,K).\n\ *\n\ * TAU (input) COMPLEX*16 array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by ZGERQF.\n\ *\n\ * C (input/output) COMPLEX*16 array, dimension (LDC,N)\n\ * On entry, the m-by-n matrix C.\n\ * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension\n\ * (N) if SIDE = 'L',\n\ * (M) if SIDE = 'R'\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlatps0000644000175000017500000001621312502223526016502 0ustar uwabamiuwabami--- :name: dlatps :md5sum: 14110c3ace99afb7ed820151dddf667f :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - normin: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - n*(n+1)/2 - x: :type: doublereal :intent: input/output :dims: - n - scale: :type: doublereal :intent: output - cnorm: :type: doublereal :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, CNORM, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLATPS solves one of the triangular systems\n\ *\n\ * A *x = s*b or A'*x = s*b\n\ *\n\ * with scaling to prevent overflow, where A is an upper or lower\n\ * triangular matrix stored in packed form. Here A' denotes the\n\ * transpose of A, x and b are n-element vectors, and s is a scaling\n\ * factor, usually less than or equal to 1, chosen so that the\n\ * components of x will be less than the overflow threshold. If the\n\ * unscaled problem will not cause overflow, the Level 2 BLAS routine\n\ * DTPSV is called. If the matrix A is singular (A(j,j) = 0 for some j),\n\ * then s is set to 0 and a non-trivial solution to A*x = 0 is returned.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the matrix A is upper or lower triangular.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the operation applied to A.\n\ * = 'N': Solve A * x = s*b (No transpose)\n\ * = 'T': Solve A'* x = s*b (Transpose)\n\ * = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * Specifies whether or not the matrix A is unit triangular.\n\ * = 'N': Non-unit triangular\n\ * = 'U': Unit triangular\n\ *\n\ * NORMIN (input) CHARACTER*1\n\ * Specifies whether CNORM has been set or not.\n\ * = 'Y': CNORM contains the column norms on entry\n\ * = 'N': CNORM is not set on entry. On exit, the norms will\n\ * be computed and stored in CNORM.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * The upper or lower triangular matrix A, packed columnwise in\n\ * a linear array. The j-th column of A is stored in the array\n\ * AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * X (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the right hand side b of the triangular system.\n\ * On exit, X is overwritten by the solution vector x.\n\ *\n\ * SCALE (output) DOUBLE PRECISION\n\ * The scaling factor s for the triangular system\n\ * A * x = s*b or A'* x = s*b.\n\ * If SCALE = 0, the matrix A is singular or badly scaled, and\n\ * the vector x is an exact or approximate solution to A*x = 0.\n\ *\n\ * CNORM (input or output) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n\ * contains the norm of the off-diagonal part of the j-th column\n\ * of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n\ * to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n\ * must be greater than or equal to the 1-norm.\n\ *\n\ * If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n\ * returns the 1-norm of the offdiagonal part of the j-th column\n\ * of A.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ *\n\n\ * Further Details\n\ * ======= =======\n\ *\n\ * A rough bound on x is computed; if that is less than overflow, DTPSV\n\ * is called, otherwise, specific code is used which checks for possible\n\ * overflow or divide-by-zero at every operation.\n\ *\n\ * A columnwise scheme is used for solving A*x = b. The basic algorithm\n\ * if A is lower triangular is\n\ *\n\ * x[1:n] := b[1:n]\n\ * for j = 1, ..., n\n\ * x(j) := x(j) / A(j,j)\n\ * x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n\ * end\n\ *\n\ * Define bounds on the components of x after j iterations of the loop:\n\ * M(j) = bound on x[1:j]\n\ * G(j) = bound on x[j+1:n]\n\ * Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n\ *\n\ * Then for iteration j+1 we have\n\ * M(j+1) <= G(j) / | A(j+1,j+1) |\n\ * G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n\ * <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n\ *\n\ * where CNORM(j+1) is greater than or equal to the infinity-norm of\n\ * column j+1 of A, not counting the diagonal. Hence\n\ *\n\ * G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n\ * 1<=i<=j\n\ * and\n\ *\n\ * |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n\ * 1<=i< j\n\ *\n\ * Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTPSV if the\n\ * reciprocal of the largest M(j), j=1,..,n, is larger than\n\ * max(underflow, 1/overflow).\n\ *\n\ * The bound on x(j) is also used to determine when a step in the\n\ * columnwise method can be performed without fear of overflow. If\n\ * the computed bound is greater than a large constant, x is scaled to\n\ * prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n\ * 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n\ *\n\ * Similarly, a row-wise scheme is used to solve A'*x = b. The basic\n\ * algorithm for A upper triangular is\n\ *\n\ * for j = 1, ..., n\n\ * x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n\ * end\n\ *\n\ * We simultaneously compute two bounds\n\ * G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n\ * M(j) = bound on x(i), 1<=i<=j\n\ *\n\ * The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n\ * add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n\ * Then the bound on x(j) is\n\ *\n\ * M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n\ *\n\ * <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n\ * 1<=i<=j\n\ *\n\ * and we can safely call DTPSV if 1/M(n) and 1/G(n) are both greater\n\ * than max(underflow, 1/overflow).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/stbtrs0000644000175000017500000000663312502223526016541 0ustar uwabamiuwabami--- :name: stbtrs :md5sum: dad3e4876ded9e7c7b27950c40311c22 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE STBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STBTRS solves a triangular system of the form\n\ *\n\ * A * X = B or A**T * X = B,\n\ *\n\ * where A is a triangular band matrix of order N, and B is an\n\ * N-by NRHS matrix. A check is made to verify that A is nonsingular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose = Transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals or subdiagonals of the\n\ * triangular band matrix A. KD >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AB (input) REAL array, dimension (LDAB,N)\n\ * The upper or lower triangular band matrix A, stored in the\n\ * first kd+1 rows of AB. The j-th column of A is stored\n\ * in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ * If DIAG = 'U', the diagonal elements of A are not referenced\n\ * and are assumed to be 1.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, if INFO = 0, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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 A is zero,\n\ * indicating that the matrix is singular and the\n\ * solutions X have not been computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctptrs0000644000175000017500000000570412502223525016534 0ustar uwabamiuwabami--- :name: ctptrs :md5sum: e9791f6e0e5d2ec2337a6d090c7ae16b :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTPTRS solves a triangular system of the form\n\ *\n\ * A * X = B, A**T * X = B, or A**H * X = B,\n\ *\n\ * where A is a triangular matrix of order N stored in packed format,\n\ * and B is an N-by-NRHS matrix. A check is made to verify that A is\n\ * nonsingular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AP (input) COMPLEX array, dimension (N*(N+1)/2)\n\ * The upper or lower triangular matrix A, packed columnwise in\n\ * a linear array. The j-th column of A is stored in the array\n\ * AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, if INFO = 0, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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 A is zero,\n\ * indicating that the matrix is singular and the\n\ * solutions X have not been computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgetri0000644000175000017500000000523212502223526016516 0ustar uwabamiuwabami--- :name: zgetri :md5sum: ae95eea784f2de933d94eed63a3dcc2d :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGETRI computes the inverse of a matrix using the LU factorization\n\ * computed by ZGETRF.\n\ *\n\ * This method inverts U and then computes inv(A) by solving the system\n\ * inv(A)*L = inv(U) for inv(A).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the factors L and U from the factorization\n\ * A = P*L*U as computed by ZGETRF.\n\ * On exit, if INFO = 0, the inverse of the original matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from ZGETRF; for 1<=i<=N, row i of the\n\ * matrix was interchanged with row IPIV(i).\n\ *\n\ * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO=0, then WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK >= max(1,N).\n\ * For optimal performance LWORK >= N*NB, where NB is\n\ * the optimal blocksize returned by ILAENV.\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, U(i,i) is exactly zero; the matrix is\n\ * singular and its inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/claqr50000644000175000017500000001617112502223525016404 0ustar uwabamiuwabami--- :name: claqr5 :md5sum: 6054ea0e340c303fed500141047341cc :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - kacc22: :type: integer :intent: input - n: :type: integer :intent: input - ktop: :type: integer :intent: input - kbot: :type: integer :intent: input - nshfts: :type: integer :intent: input - s: :type: complex :intent: input/output :dims: - nshfts - h: :type: complex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: complex :intent: input/output :dims: - "wantz ? ldz : 0" - "wantz ? ihiz : 0" - ldz: :type: integer :intent: input - v: :type: complex :intent: workspace :dims: - ldv - nshfts/2 - ldv: :type: integer :intent: input - u: :type: complex :intent: workspace :dims: - ldu - 3*nshfts-3 - ldu: :type: integer :intent: input - nv: :type: integer :intent: input - wv: :type: complex :intent: workspace :dims: - ldwv - 3*nshfts-3 - ldwv: :type: integer :intent: input - nh: :type: integer :intent: input - wh: :type: complex :intent: workspace :dims: - ldwh - MAX(1,nh) - ldwh: :type: integer :intent: input :substitutions: ldwh: 3*nshfts-3 ldwv: nv ldu: 3*nshfts-3 ldv: "3" :fortran_help: " SUBROUTINE CLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, WV, LDWV, NH, WH, LDWH )\n\n\ * This auxiliary subroutine called by CLAQR0 performs a\n\ * single small-bulge multi-shift QR sweep.\n\ *\n\n\ * WANTT (input) logical scalar\n\ * WANTT = .true. if the triangular Schur factor\n\ * is being computed. WANTT is set to .false. otherwise.\n\ *\n\ * WANTZ (input) logical scalar\n\ * WANTZ = .true. if the unitary Schur factor is being\n\ * computed. WANTZ is set to .false. otherwise.\n\ *\n\ * KACC22 (input) integer with value 0, 1, or 2.\n\ * Specifies the computation mode of far-from-diagonal\n\ * orthogonal updates.\n\ * = 0: CLAQR5 does not accumulate reflections and does not\n\ * use matrix-matrix multiply to update far-from-diagonal\n\ * matrix entries.\n\ * = 1: CLAQR5 accumulates reflections and uses matrix-matrix\n\ * multiply to update the far-from-diagonal matrix entries.\n\ * = 2: CLAQR5 accumulates reflections, uses matrix-matrix\n\ * multiply to update the far-from-diagonal matrix entries,\n\ * and takes advantage of 2-by-2 block structure during\n\ * matrix multiplies.\n\ *\n\ * N (input) integer scalar\n\ * N is the order of the Hessenberg matrix H upon which this\n\ * subroutine operates.\n\ *\n\ * KTOP (input) integer scalar\n\ * KBOT (input) integer scalar\n\ * These are the first and last rows and columns of an\n\ * isolated diagonal block upon which the QR sweep is to be\n\ * applied. It is assumed without a check that\n\ * either KTOP = 1 or H(KTOP,KTOP-1) = 0\n\ * and\n\ * either KBOT = N or H(KBOT+1,KBOT) = 0.\n\ *\n\ * NSHFTS (input) integer scalar\n\ * NSHFTS gives the number of simultaneous shifts. NSHFTS\n\ * must be positive and even.\n\ *\n\ * S (input/output) COMPLEX array of size (NSHFTS)\n\ * S contains the shifts of origin that define the multi-\n\ * shift QR sweep. On output S may be reordered.\n\ *\n\ * H (input/output) COMPLEX array of size (LDH,N)\n\ * On input H contains a Hessenberg matrix. On output a\n\ * multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied\n\ * to the isolated diagonal block in rows and columns KTOP\n\ * through KBOT.\n\ *\n\ * LDH (input) integer scalar\n\ * LDH is the leading dimension of H just as declared in the\n\ * calling procedure. LDH.GE.MAX(1,N).\n\ *\n\ * ILOZ (input) INTEGER\n\ * IHIZ (input) INTEGER\n\ * Specify the rows of Z to which transformations must be\n\ * applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N\n\ *\n\ * Z (input/output) COMPLEX array of size (LDZ,IHI)\n\ * If WANTZ = .TRUE., then the QR Sweep unitary\n\ * similarity transformation is accumulated into\n\ * Z(ILOZ:IHIZ,ILO:IHI) from the right.\n\ * If WANTZ = .FALSE., then Z is unreferenced.\n\ *\n\ * LDZ (input) integer scalar\n\ * LDA is the leading dimension of Z just as declared in\n\ * the calling procedure. LDZ.GE.N.\n\ *\n\ * V (workspace) COMPLEX array of size (LDV,NSHFTS/2)\n\ *\n\ * LDV (input) integer scalar\n\ * LDV is the leading dimension of V as declared in the\n\ * calling procedure. LDV.GE.3.\n\ *\n\ * U (workspace) COMPLEX array of size\n\ * (LDU,3*NSHFTS-3)\n\ *\n\ * LDU (input) integer scalar\n\ * LDU is the leading dimension of U just as declared in the\n\ * in the calling subroutine. LDU.GE.3*NSHFTS-3.\n\ *\n\ * NH (input) integer scalar\n\ * NH is the number of columns in array WH available for\n\ * workspace. NH.GE.1.\n\ *\n\ * WH (workspace) COMPLEX array of size (LDWH,NH)\n\ *\n\ * LDWH (input) integer scalar\n\ * Leading dimension of WH just as declared in the\n\ * calling procedure. LDWH.GE.3*NSHFTS-3.\n\ *\n\ * NV (input) integer scalar\n\ * NV is the number of rows in WV agailable for workspace.\n\ * NV.GE.1.\n\ *\n\ * WV (workspace) COMPLEX array of size\n\ * (LDWV,3*NSHFTS-3)\n\ *\n\ * LDWV (input) integer scalar\n\ * LDWV is the leading dimension of WV as declared in the\n\ * in the calling subroutine. LDWV.GE.NV.\n\ *\n\n\ * ================================================================\n\ * Based on contributions by\n\ * Karen Braman and Ralph Byers, Department of Mathematics,\n\ * University of Kansas, USA\n\ *\n\ * ================================================================\n\ * Reference:\n\ *\n\ * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n\ * Algorithm Part I: Maintaining Well Focused Shifts, and\n\ * Level 3 Performance, SIAM Journal of Matrix Analysis,\n\ * volume 23, pages 929--947, 2002.\n\ *\n\ * ================================================================\n" ruby-lapack-1.7.2/dev/defs/dpptrs0000644000175000017500000000522212502223526016525 0ustar uwabamiuwabami--- :name: dpptrs :md5sum: e7c3946ec34bb6e52033f533f20b69ea :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - n*(n+1)/2 - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPPTRS solves a system of linear equations A*X = B with a symmetric\n\ * positive definite matrix A in packed storage using the Cholesky\n\ * factorization A = U**T*U or A = L*L**T computed by DPPTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T, packed columnwise in a linear\n\ * array. The j-th column of U or L is stored in the array AP\n\ * as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL UPPER\n INTEGER I\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DTPSV, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slarnv0000644000175000017500000000333512502223526016521 0ustar uwabamiuwabami--- :name: slarnv :md5sum: ec519a2c67aad07cda6a6014d8db7bf2 :category: :subroutine :arguments: - idist: :type: integer :intent: input - iseed: :type: integer :intent: input/output :dims: - "4" - n: :type: integer :intent: input - x: :type: real :intent: output :dims: - MAX(1,n) :substitutions: {} :fortran_help: " SUBROUTINE SLARNV( IDIST, ISEED, N, X )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLARNV returns a vector of n random real numbers from a uniform or\n\ * normal distribution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * IDIST (input) INTEGER\n\ * Specifies the distribution of the random numbers:\n\ * = 1: uniform (0,1)\n\ * = 2: uniform (-1,1)\n\ * = 3: normal (0,1)\n\ *\n\ * ISEED (input/output) INTEGER array, dimension (4)\n\ * On entry, the seed of the random number generator; the array\n\ * elements must be between 0 and 4095, and ISEED(4) must be\n\ * odd.\n\ * On exit, the seed is updated.\n\ *\n\ * N (input) INTEGER\n\ * The number of random numbers to be generated.\n\ *\n\ * X (output) REAL array, dimension (N)\n\ * The generated random numbers.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * This routine calls the auxiliary routine SLARUV to generate random\n\ * real numbers from a uniform (0,1) distribution, in batches of up to\n\ * 128 using vectorisable code. The Box-Muller method is used to\n\ * transform numbers from a uniform to a normal distribution.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slangb0000644000175000017500000000550312502223526016461 0ustar uwabamiuwabami--- :name: slangb :md5sum: 3f8c81af777bb7ec2cc1b2625266d675 :category: :function :type: real :arguments: - norm: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? n : 0" :fortran_help: " REAL FUNCTION SLANGB( NORM, N, KL, KU, AB, LDAB, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLANGB returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of an\n\ * n by n band matrix A, with kl sub-diagonals and ku super-diagonals.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * SLANGB returns the value\n\ *\n\ * SLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in SLANGB as described\n\ * above.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, SLANGB is\n\ * set to zero.\n\ *\n\ * KL (input) INTEGER\n\ * The number of sub-diagonals of the matrix A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of super-diagonals of the matrix A. KU >= 0.\n\ *\n\ * AB (input) REAL array, dimension (LDAB,N)\n\ * The band matrix A, stored in rows 1 to KL+KU+1. The j-th\n\ * column of A is stored in the j-th column of the array AB as\n\ * follows:\n\ * AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n\ * referenced.\n\ *\n\n\ * =====================================================================\n\ *\n\ *\n" ruby-lapack-1.7.2/dev/defs/zsyrfs0000644000175000017500000001231312502223526016550 0ustar uwabamiuwabami--- :name: zsyrfs :md5sum: ca1036491c4d3d48e02c2ca40d621659 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSYRFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is symmetric indefinite, and\n\ * provides error bounds and backward error estimates for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular part\n\ * of the matrix A, and the strictly lower triangular part of A\n\ * is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of A contains the lower triangular part of\n\ * the matrix A, and the strictly upper triangular part of A is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX*16 array, dimension (LDAF,N)\n\ * The factored form of the matrix A. AF contains the block\n\ * diagonal matrix D and the multipliers used to obtain the\n\ * factor U or L from the factorization A = U*D*U**T or\n\ * A = L*D*L**T as computed by ZSYTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by ZSYTRF.\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by ZSYTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ztpttf0000644000175000017500000001421612502223526016547 0ustar uwabamiuwabami--- :name: ztpttf :md5sum: 9c832135eafbf9d3f6022c7f700da5d3 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - ( n*(n+1)/2 ) - arf: :type: doublecomplex :intent: output :dims: - ( n*(n+1)/2 ) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZTPTTF( TRANSR, UPLO, N, AP, ARF, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTPTTF copies a triangular matrix A from standard packed format (TP)\n\ * to rectangular full packed format (TF).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': ARF in Normal format is wanted;\n\ * = 'C': ARF in Conjugate-transpose format is wanted.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n\ * On entry, the upper or lower triangular matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * ARF (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n\ * On exit, the upper or lower triangular matrix A stored in\n\ * RFP format. For a further discussion see Notes below.\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\ * We first consider Standard Packed Format when N is even.\n\ * We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * conjugate-transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * conjugate-transpose of the last three columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- --\n\ * 03 04 05 33 43 53\n\ * -- --\n\ * 13 14 15 00 44 54\n\ * --\n\ * 23 24 25 10 11 55\n\ *\n\ * 33 34 35 20 21 22\n\ * --\n\ * 00 44 45 30 31 32\n\ * -- --\n\ * 01 11 55 40 41 42\n\ * -- -- --\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We next consider Standard Packed Format when N is odd.\n\ * We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * conjugate-transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * conjugate-transpose of the last two columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- --\n\ * 02 03 04 00 33 43\n\ * --\n\ * 12 13 14 10 11 44\n\ *\n\ * 22 23 24 20 21 22\n\ * --\n\ * 00 33 34 30 31 32\n\ * -- --\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- --\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgeesx0000644000175000017500000001731512502223525016474 0ustar uwabamiuwabami--- :name: cgeesx :md5sum: 239541f0bcff569087e91823b8128f20 :category: :subroutine :arguments: - jobvs: :type: char :intent: input - sort: :type: char :intent: input - select: :intent: external procedure :block_type: logical :block_arg_num: 1 :block_arg_type: complex - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - sdim: :type: integer :intent: output - w: :type: complex :intent: output :dims: - n - vs: :type: complex :intent: output :dims: - ldvs - n - ldvs: :type: integer :intent: input - rconde: :type: real :intent: output - rcondv: :type: real :intent: output - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(lsame_(&sense,\"E\")||lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? n*n/2 : 2*n" - rwork: :type: real :intent: workspace :dims: - n - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvs: "lsame_(&jobvs,\"V\") ? n : 1" :fortran_help: " SUBROUTINE CGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, W, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, RWORK, BWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGEESX computes for an N-by-N complex nonsymmetric matrix A, the\n\ * eigenvalues, the Schur form T, and, optionally, the matrix of Schur\n\ * vectors Z. This gives the Schur factorization A = Z*T*(Z**H).\n\ *\n\ * Optionally, it also orders the eigenvalues on the diagonal of the\n\ * Schur form so that selected eigenvalues are at the top left;\n\ * computes a reciprocal condition number for the average of the\n\ * selected eigenvalues (RCONDE); and computes a reciprocal condition\n\ * number for the right invariant subspace corresponding to the\n\ * selected eigenvalues (RCONDV). The leading columns of Z form an\n\ * orthonormal basis for this invariant subspace.\n\ *\n\ * For further explanation of the reciprocal condition numbers RCONDE\n\ * and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where\n\ * these quantities are called s and sep respectively).\n\ *\n\ * A complex matrix is in Schur form if it is upper triangular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVS (input) CHARACTER*1\n\ * = 'N': Schur vectors are not computed;\n\ * = 'V': Schur vectors are computed.\n\ *\n\ * SORT (input) CHARACTER*1\n\ * Specifies whether or not to order the eigenvalues on the\n\ * diagonal of the Schur form.\n\ * = 'N': Eigenvalues are not ordered;\n\ * = 'S': Eigenvalues are ordered (see SELECT).\n\ *\n\ * SELECT (external procedure) LOGICAL FUNCTION of one COMPLEX argument\n\ * SELECT must be declared EXTERNAL in the calling subroutine.\n\ * If SORT = 'S', SELECT is used to select eigenvalues to order\n\ * to the top left of the Schur form.\n\ * If SORT = 'N', SELECT is not referenced.\n\ * An eigenvalue W(j) is selected if SELECT(W(j)) is true.\n\ *\n\ * SENSE (input) CHARACTER*1\n\ * Determines which reciprocal condition numbers are computed.\n\ * = 'N': None are computed;\n\ * = 'E': Computed for average of selected eigenvalues only;\n\ * = 'V': Computed for selected right invariant subspace only;\n\ * = 'B': Computed for both.\n\ * If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA, N)\n\ * On entry, the N-by-N matrix A.\n\ * On exit, A is overwritten by its Schur form T.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * SDIM (output) INTEGER\n\ * If SORT = 'N', SDIM = 0.\n\ * If SORT = 'S', SDIM = number of eigenvalues for which\n\ * SELECT is true.\n\ *\n\ * W (output) COMPLEX array, dimension (N)\n\ * W contains the computed eigenvalues, in the same order\n\ * that they appear on the diagonal of the output Schur form T.\n\ *\n\ * VS (output) COMPLEX array, dimension (LDVS,N)\n\ * If JOBVS = 'V', VS contains the unitary matrix Z of Schur\n\ * vectors.\n\ * If JOBVS = 'N', VS is not referenced.\n\ *\n\ * LDVS (input) INTEGER\n\ * The leading dimension of the array VS. LDVS >= 1, and if\n\ * JOBVS = 'V', LDVS >= N.\n\ *\n\ * RCONDE (output) REAL\n\ * If SENSE = 'E' or 'B', RCONDE contains the reciprocal\n\ * condition number for the average of the selected eigenvalues.\n\ * Not referenced if SENSE = 'N' or 'V'.\n\ *\n\ * RCONDV (output) REAL\n\ * If SENSE = 'V' or 'B', RCONDV contains the reciprocal\n\ * condition number for the selected right invariant subspace.\n\ * Not referenced if SENSE = 'N' or 'E'.\n\ *\n\ * WORK (workspace/output) COMPLEX 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,2*N).\n\ * Also, if SENSE = 'E' or 'V' or 'B', LWORK >= 2*SDIM*(N-SDIM),\n\ * where SDIM is the number of selected eigenvalues computed by\n\ * this routine. Note that 2*SDIM*(N-SDIM) <= N*N/2. Note also\n\ * that an error is only returned if LWORK < max(1,2*N), but if\n\ * SENSE = 'E' or 'V' or 'B' this may not be large enough.\n\ * For good performance, LWORK must generally be larger.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates upper bound on the optimal size of the\n\ * array WORK, returns this value as the first entry of the WORK\n\ * array, and no error message related to LWORK is issued by\n\ * XERBLA.\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\n\ *\n\ * BWORK (workspace) LOGICAL array, dimension (N)\n\ * Not referenced if SORT = 'N'.\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, and i is\n\ * <= N: the QR algorithm failed to compute all the\n\ * eigenvalues; elements 1:ILO-1 and i+1:N of W\n\ * contain those eigenvalues which have converged; if\n\ * JOBVS = 'V', VS contains the transformation which\n\ * reduces A to its partially converged Schur form.\n\ * = N+1: the eigenvalues could not be reordered because some\n\ * eigenvalues were too close to separate (the problem\n\ * is very ill-conditioned);\n\ * = N+2: after reordering, roundoff changed values of some\n\ * complex eigenvalues so that leading eigenvalues in\n\ * the Schur form no longer satisfy SELECT=.TRUE. This\n\ * could also be caused by underflow due to scaling.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clatbs0000644000175000017500000001702012502223525016457 0ustar uwabamiuwabami--- :name: clatbs :md5sum: 62c760c1f0e34668fbf1dfcec980d0f4 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - normin: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - n - scale: :type: real :intent: output - cnorm: :type: real :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, SCALE, CNORM, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLATBS solves one of the triangular systems\n\ *\n\ * A * x = s*b, A**T * x = s*b, or A**H * x = s*b,\n\ *\n\ * with scaling to prevent overflow, where A is an upper or lower\n\ * triangular band matrix. Here A' denotes the transpose of A, x and b\n\ * are n-element vectors, and s is a scaling factor, usually less than\n\ * or equal to 1, chosen so that the components of x will be less than\n\ * the overflow threshold. If the unscaled problem will not cause\n\ * overflow, the Level 2 BLAS routine CTBSV is called. If the matrix A\n\ * is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n\ * non-trivial solution to A*x = 0 is returned.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the matrix A is upper or lower triangular.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the operation applied to A.\n\ * = 'N': Solve A * x = s*b (No transpose)\n\ * = 'T': Solve A**T * x = s*b (Transpose)\n\ * = 'C': Solve A**H * x = s*b (Conjugate transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * Specifies whether or not the matrix A is unit triangular.\n\ * = 'N': Non-unit triangular\n\ * = 'U': Unit triangular\n\ *\n\ * NORMIN (input) CHARACTER*1\n\ * Specifies whether CNORM has been set or not.\n\ * = 'Y': CNORM contains the column norms on entry\n\ * = 'N': CNORM is not set on entry. On exit, the norms will\n\ * be computed and stored in CNORM.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of subdiagonals or superdiagonals in the\n\ * triangular matrix A. KD >= 0.\n\ *\n\ * AB (input) COMPLEX array, dimension (LDAB,N)\n\ * The upper or lower triangular band matrix A, stored in the\n\ * first KD+1 rows of the array. The j-th column of A is stored\n\ * in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * X (input/output) COMPLEX array, dimension (N)\n\ * On entry, the right hand side b of the triangular system.\n\ * On exit, X is overwritten by the solution vector x.\n\ *\n\ * SCALE (output) REAL\n\ * The scaling factor s for the triangular system\n\ * A * x = s*b, A**T * x = s*b, or A**H * x = s*b.\n\ * If SCALE = 0, the matrix A is singular or badly scaled, and\n\ * the vector x is an exact or approximate solution to A*x = 0.\n\ *\n\ * CNORM (input or output) REAL array, dimension (N)\n\ *\n\ * If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n\ * contains the norm of the off-diagonal part of the j-th column\n\ * of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n\ * to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n\ * must be greater than or equal to the 1-norm.\n\ *\n\ * If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n\ * returns the 1-norm of the offdiagonal part of the j-th column\n\ * of A.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ *\n\n\ * Further Details\n\ * ======= =======\n\ *\n\ * A rough bound on x is computed; if that is less than overflow, CTBSV\n\ * is called, otherwise, specific code is used which checks for possible\n\ * overflow or divide-by-zero at every operation.\n\ *\n\ * A columnwise scheme is used for solving A*x = b. The basic algorithm\n\ * if A is lower triangular is\n\ *\n\ * x[1:n] := b[1:n]\n\ * for j = 1, ..., n\n\ * x(j) := x(j) / A(j,j)\n\ * x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n\ * end\n\ *\n\ * Define bounds on the components of x after j iterations of the loop:\n\ * M(j) = bound on x[1:j]\n\ * G(j) = bound on x[j+1:n]\n\ * Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n\ *\n\ * Then for iteration j+1 we have\n\ * M(j+1) <= G(j) / | A(j+1,j+1) |\n\ * G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n\ * <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n\ *\n\ * where CNORM(j+1) is greater than or equal to the infinity-norm of\n\ * column j+1 of A, not counting the diagonal. Hence\n\ *\n\ * G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n\ * 1<=i<=j\n\ * and\n\ *\n\ * |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n\ * 1<=i< j\n\ *\n\ * Since |x(j)| <= M(j), we use the Level 2 BLAS routine CTBSV if the\n\ * reciprocal of the largest M(j), j=1,..,n, is larger than\n\ * max(underflow, 1/overflow).\n\ *\n\ * The bound on x(j) is also used to determine when a step in the\n\ * columnwise method can be performed without fear of overflow. If\n\ * the computed bound is greater than a large constant, x is scaled to\n\ * prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n\ * 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n\ *\n\ * Similarly, a row-wise scheme is used to solve A**T *x = b or\n\ * A**H *x = b. The basic algorithm for A upper triangular is\n\ *\n\ * for j = 1, ..., n\n\ * x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n\ * end\n\ *\n\ * We simultaneously compute two bounds\n\ * G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n\ * M(j) = bound on x(i), 1<=i<=j\n\ *\n\ * The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n\ * add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n\ * Then the bound on x(j) is\n\ *\n\ * M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n\ *\n\ * <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n\ * 1<=i<=j\n\ *\n\ * and we can safely call CTBSV if 1/M(n) and 1/G(n) are both greater\n\ * than max(underflow, 1/overflow).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sormlq0000644000175000017500000001046312502223526016531 0ustar uwabamiuwabami--- :name: sormlq :md5sum: 9d63f013e5f6db69178cf57382540251 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SORMLQ overwrites the general real M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'T': Q**T * C C * Q**T\n\ *\n\ * where Q is a real orthogonal matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(k) . . . H(2) H(1)\n\ *\n\ * as returned by SGELQF. Q is of order M if SIDE = 'L' and of order N\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**T from the Left;\n\ * = 'R': apply Q or Q**T from the Right.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q;\n\ * = 'T': Transpose, apply Q**T.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) REAL array, dimension\n\ * (LDA,M) if SIDE = 'L',\n\ * (LDA,N) if SIDE = 'R'\n\ * The i-th row must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * SGELQF in the first k rows of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,K).\n\ *\n\ * TAU (input) REAL array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by SGELQF.\n\ *\n\ * C (input/output) REAL array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace/output) REAL 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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M).\n\ * For optimum performance LWORK >= N*NB if SIDE = 'L', and\n\ * LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n\ * 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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sbdsdc0000644000175000017500000001647412502223526016466 0ustar uwabamiuwabami--- :name: sbdsdc :md5sum: 363562a2bf0038c64910ac814e09f1c7 :category: :subroutine :arguments: - uplo: :type: char :intent: input - compq: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - u: :type: real :intent: output :dims: - "lsame_(&compq,\"I\") ? ldu : 0" - "lsame_(&compq,\"I\") ? n : 0" - ldu: :type: integer :intent: input - vt: :type: real :intent: output :dims: - "lsame_(&compq,\"I\") ? ldvt : 0" - "lsame_(&compq,\"I\") ? n : 0" - ldvt: :type: integer :intent: input - q: :type: real :intent: output :dims: - "lsame_(&compq,\"I\") ? ldq : 0" - iq: :type: integer :intent: output :dims: - "lsame_(&compq,\"I\") ? ldiq : 0" - work: :type: real :intent: workspace :dims: - MAX(1,lwork) - iwork: :type: integer :intent: workspace :dims: - 8*n - info: :type: integer :intent: output :substitutions: c__9: "9" c__0: "0" ldq: "lsame_(&compq,\"P\") ? n*(11+2*smlsiz+8*(int)(log(((double)n)/(smlsiz+1))/log(2.0))) : 0" ldvt: "lsame_(&compq,\"I\") ? MAX(1,n) : 0" ldiq: "lsame_(&compq,\"P\") ? n*(3+3*(int)(log(((double)n)/(smlsiz+1))/log(2.0))) : 0" lwork: "lsame_(&compq,\"N\") ? 4*n : lsame_(&compq,\"P\") ? 6*n : lsame_(&compq,\"I\") ? 3*n*n+4*n : 0" ldu: "lsame_(&compq,\"I\") ? MAX(1,n) : 0" smlsiz: ilaenv_(&c__9, "SBDSDC", " ", &c__0, &c__0, &c__0, &c__0) :fortran_help: " SUBROUTINE SBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SBDSDC computes the singular value decomposition (SVD) of a real\n\ * N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT,\n\ * using a divide and conquer method, where S is a diagonal matrix\n\ * with non-negative diagonal elements (the singular values of B), and\n\ * U and VT are orthogonal matrices of left and right singular vectors,\n\ * respectively. SBDSDC can be used to compute all singular values,\n\ * and optionally, singular vectors or singular vectors in compact form.\n\ *\n\ * This code makes very mild assumptions about floating point\n\ * arithmetic. It will work on machines with a guard digit in\n\ * add/subtract, or on those binary machines without guard digits\n\ * which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n\ * It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none. See SLASD3 for details.\n\ *\n\ * The code currently calls SLASDQ if singular values only are desired.\n\ * However, it can be slightly modified to compute singular values\n\ * using the divide and conquer method.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': B is upper bidiagonal.\n\ * = 'L': B is lower bidiagonal.\n\ *\n\ * COMPQ (input) CHARACTER*1\n\ * Specifies whether singular vectors are to be computed\n\ * as follows:\n\ * = 'N': Compute singular values only;\n\ * = 'P': Compute singular values and compute singular\n\ * vectors in compact form;\n\ * = 'I': Compute singular values and singular vectors.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix B. N >= 0.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the n diagonal elements of the bidiagonal matrix B.\n\ * On exit, if INFO=0, the singular values of B.\n\ *\n\ * E (input/output) REAL array, dimension (N-1)\n\ * On entry, the elements of E contain the offdiagonal\n\ * elements of the bidiagonal matrix whose SVD is desired.\n\ * On exit, E has been destroyed.\n\ *\n\ * U (output) REAL array, dimension (LDU,N)\n\ * If COMPQ = 'I', then:\n\ * On exit, if INFO = 0, U contains the left singular vectors\n\ * of the bidiagonal matrix.\n\ * For other values of COMPQ, U is not referenced.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= 1.\n\ * If singular vectors are desired, then LDU >= max( 1, N ).\n\ *\n\ * VT (output) REAL array, dimension (LDVT,N)\n\ * If COMPQ = 'I', then:\n\ * On exit, if INFO = 0, VT' contains the right singular\n\ * vectors of the bidiagonal matrix.\n\ * For other values of COMPQ, VT is not referenced.\n\ *\n\ * LDVT (input) INTEGER\n\ * The leading dimension of the array VT. LDVT >= 1.\n\ * If singular vectors are desired, then LDVT >= max( 1, N ).\n\ *\n\ * Q (output) REAL array, dimension (LDQ)\n\ * If COMPQ = 'P', then:\n\ * On exit, if INFO = 0, Q and IQ contain the left\n\ * and right singular vectors in a compact form,\n\ * requiring O(N log N) space instead of 2*N**2.\n\ * In particular, Q contains all the REAL data in\n\ * LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))\n\ * words of memory, where SMLSIZ is returned by ILAENV and\n\ * is equal to the maximum size of the subproblems at the\n\ * bottom of the computation tree (usually about 25).\n\ * For other values of COMPQ, Q is not referenced.\n\ *\n\ * IQ (output) INTEGER array, dimension (LDIQ)\n\ * If COMPQ = 'P', then:\n\ * On exit, if INFO = 0, Q and IQ contain the left\n\ * and right singular vectors in a compact form,\n\ * requiring O(N log N) space instead of 2*N**2.\n\ * In particular, IQ contains all INTEGER data in\n\ * LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))\n\ * words of memory, where SMLSIZ is returned by ILAENV and\n\ * is equal to the maximum size of the subproblems at the\n\ * bottom of the computation tree (usually about 25).\n\ * For other values of COMPQ, IQ is not referenced.\n\ *\n\ * WORK (workspace) REAL array, dimension (MAX(1,LWORK))\n\ * If COMPQ = 'N' then LWORK >= (4 * N).\n\ * If COMPQ = 'P' then LWORK >= (6 * N).\n\ * If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N).\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (8*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit.\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * > 0: The algorithm failed to compute a singular value.\n\ * The update process of divide and conquer failed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ming Gu and Huan Ren, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ * =====================================================================\n\ * Changed dimension statement in comment describing E from (N) to\n\ * (N-1). Sven, 17 Feb 05.\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgesc20000644000175000017500000000457012502223526016413 0ustar uwabamiuwabami--- :name: zgesc2 :md5sum: 7c06097df40e16822688433d8198c64a :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - rhs: :type: doublecomplex :intent: input/output :dims: - n - ipiv: :type: integer :intent: input :dims: - n - jpiv: :type: integer :intent: input :dims: - n - scale: :type: doublereal :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGESC2 solves a system of linear equations\n\ *\n\ * A * X = scale* RHS\n\ *\n\ * with a general N-by-N matrix A using the LU factorization with\n\ * complete pivoting computed by ZGETC2.\n\ *\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix A.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA, N)\n\ * On entry, the LU part of the factorization of the n-by-n\n\ * matrix A computed by ZGETC2: A = P * L * U * Q\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1, N).\n\ *\n\ * RHS (input/output) COMPLEX*16 array, dimension N.\n\ * On entry, the right hand side vector b.\n\ * On exit, the solution vector X.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N).\n\ * The pivot indices; for 1 <= i <= N, row i of the\n\ * matrix has been interchanged with row IPIV(i).\n\ *\n\ * JPIV (input) INTEGER array, dimension (N).\n\ * The pivot indices; for 1 <= j <= N, column j of the\n\ * matrix has been interchanged with column JPIV(j).\n\ *\n\ * SCALE (output) DOUBLE PRECISION\n\ * On exit, SCALE contains the scale factor. SCALE is chosen\n\ * 0 <= SCALE <= 1 to prevent owerflow in the solution.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgegv0000644000175000017500000002352712502223526016343 0ustar uwabamiuwabami--- :name: zgegv :md5sum: 96caca0b338719751521b432c1b15a00 :category: :subroutine :arguments: - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alpha: :type: doublecomplex :intent: output :dims: - n - beta: :type: doublecomplex :intent: output :dims: - n - vl: :type: doublecomplex :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: doublecomplex :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: doublereal :intent: output :dims: - 8*n - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " SUBROUTINE ZGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This routine is deprecated and has been replaced by routine ZGGEV.\n\ *\n\ * ZGEGV computes the eigenvalues and, optionally, the left and/or right\n\ * eigenvectors of a complex matrix pair (A,B).\n\ * Given two square matrices A and B,\n\ * the generalized nonsymmetric eigenvalue problem (GNEP) is to find the\n\ * eigenvalues lambda and corresponding (non-zero) eigenvectors x such\n\ * that\n\ * A*x = lambda*B*x.\n\ *\n\ * An alternate form is to find the eigenvalues mu and corresponding\n\ * eigenvectors y such that\n\ * mu*A*y = B*y.\n\ *\n\ * These two forms are equivalent with mu = 1/lambda and x = y if\n\ * neither lambda nor mu is zero. In order to deal with the case that\n\ * lambda or mu is zero or small, two values alpha and beta are returned\n\ * for each eigenvalue, such that lambda = alpha/beta and\n\ * mu = beta/alpha.\n\ *\n\ * The vectors x and y in the above equations are right eigenvectors of\n\ * the matrix pair (A,B). Vectors u and v satisfying\n\ * u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B\n\ * are left eigenvectors of (A,B).\n\ *\n\ * Note: this routine performs \"full balancing\" on A and B -- see\n\ * \"Further Details\", below.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVL (input) CHARACTER*1\n\ * = 'N': do not compute the left generalized eigenvectors;\n\ * = 'V': compute the left generalized eigenvectors (returned\n\ * in VL).\n\ *\n\ * JOBVR (input) CHARACTER*1\n\ * = 'N': do not compute the right generalized eigenvectors;\n\ * = 'V': compute the right generalized eigenvectors (returned\n\ * in VR).\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A, B, VL, and VR. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA, N)\n\ * On entry, the matrix A.\n\ * If JOBVL = 'V' or JOBVR = 'V', then on exit A\n\ * contains the Schur form of A from the generalized Schur\n\ * factorization of the pair (A,B) after balancing. If no\n\ * eigenvectors were computed, then only the diagonal elements\n\ * of the Schur form will be correct. See ZGGHRD and ZHGEQZ\n\ * for details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB, N)\n\ * On entry, the matrix B.\n\ * If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the\n\ * upper triangular matrix obtained from B in the generalized\n\ * Schur factorization of the pair (A,B) after balancing.\n\ * If no eigenvectors were computed, then only the diagonal\n\ * elements of B will be correct. See ZGGHRD and ZHGEQZ for\n\ * details.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B. LDB >= max(1,N).\n\ *\n\ * ALPHA (output) COMPLEX*16 array, dimension (N)\n\ * The complex scalars alpha that define the eigenvalues of\n\ * GNEP.\n\ *\n\ * BETA (output) COMPLEX*16 array, dimension (N)\n\ * The complex scalars beta that define the eigenvalues of GNEP.\n\ * \n\ * Together, the quantities alpha = ALPHA(j) and beta = BETA(j)\n\ * represent the j-th eigenvalue of the matrix pair (A,B), in\n\ * one of the forms lambda = alpha/beta or mu = beta/alpha.\n\ * Since either lambda or mu may overflow, they should not,\n\ * in general, be computed.\n\ *\n\ * VL (output) COMPLEX*16 array, dimension (LDVL,N)\n\ * If JOBVL = 'V', the left eigenvectors u(j) are stored\n\ * in the columns of VL, in the same order as their eigenvalues.\n\ * Each eigenvector is scaled so that its largest component has\n\ * abs(real part) + abs(imag. part) = 1, except for eigenvectors\n\ * corresponding to an eigenvalue with alpha = beta = 0, which\n\ * are set to zero.\n\ * Not referenced if JOBVL = 'N'.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the matrix VL. LDVL >= 1, and\n\ * if JOBVL = 'V', LDVL >= N.\n\ *\n\ * VR (output) COMPLEX*16 array, dimension (LDVR,N)\n\ * If JOBVR = 'V', the right eigenvectors x(j) are stored\n\ * in the columns of VR, in the same order as their eigenvalues.\n\ * Each eigenvector is scaled so that its largest component has\n\ * abs(real part) + abs(imag. part) = 1, except for eigenvectors\n\ * corresponding to an eigenvalue with alpha = beta = 0, which\n\ * are set to zero.\n\ * Not referenced if JOBVR = 'N'.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the matrix VR. LDVR >= 1, and\n\ * if JOBVR = 'V', LDVR >= N.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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,2*N).\n\ * For good performance, LWORK must generally be larger.\n\ * To compute the optimal value of LWORK, call ILAENV to get\n\ * blocksizes (for ZGEQRF, ZUNMQR, and ZUNGQR.) Then compute:\n\ * NB -- MAX of the blocksizes for ZGEQRF, ZUNMQR, and ZUNGQR;\n\ * The optimal LWORK is MAX( 2*N, N*(NB+1) ).\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\ * RWORK (workspace/output) DOUBLE PRECISION array, dimension (8*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * =1,...,N:\n\ * The QZ iteration failed. No eigenvectors have been\n\ * calculated, but ALPHA(j) and BETA(j) should be\n\ * correct for j=INFO+1,...,N.\n\ * > N: errors that usually indicate LAPACK problems:\n\ * =N+1: error return from ZGGBAL\n\ * =N+2: error return from ZGEQRF\n\ * =N+3: error return from ZUNMQR\n\ * =N+4: error return from ZUNGQR\n\ * =N+5: error return from ZGGHRD\n\ * =N+6: error return from ZHGEQZ (other than failed\n\ * iteration)\n\ * =N+7: error return from ZTGEVC\n\ * =N+8: error return from ZGGBAK (computing VL)\n\ * =N+9: error return from ZGGBAK (computing VR)\n\ * =N+10: error return from ZLASCL (various calls)\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Balancing\n\ * ---------\n\ *\n\ * This driver calls ZGGBAL to both permute and scale rows and columns\n\ * of A and B. The permutations PL and PR are chosen so that PL*A*PR\n\ * and PL*B*R will be upper triangular except for the diagonal blocks\n\ * A(i:j,i:j) and B(i:j,i:j), with i and j as close together as\n\ * possible. The diagonal scaling matrices DL and DR are chosen so\n\ * that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to\n\ * one (except for the elements that start out zero.)\n\ *\n\ * After the eigenvalues and eigenvectors of the balanced matrices\n\ * have been computed, ZGGBAK transforms the eigenvectors back to what\n\ * they would have been (in perfect arithmetic) if they had not been\n\ * balanced.\n\ *\n\ * Contents of A and B on Exit\n\ * -------- -- - --- - -- ----\n\ *\n\ * If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or\n\ * both), then on exit the arrays A and B will contain the complex Schur\n\ * form[*] of the \"balanced\" versions of A and B. If no eigenvectors\n\ * are computed, then only the diagonal blocks will be correct.\n\ *\n\ * [*] In other words, upper triangular form.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlaswp0000644000175000017500000000450712502223526016536 0ustar uwabamiuwabami--- :name: zlaswp :md5sum: 2ea0638539d177d84800143b1f60e3e4 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - k1: :type: integer :intent: input - k2: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - k2*abs(incx) - incx: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLASWP performs a series of row interchanges on the matrix A.\n\ * One row interchange is initiated for each of rows K1 through K2 of A.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix A.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the matrix of column dimension N to which the row\n\ * interchanges will be applied.\n\ * On exit, the permuted matrix.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ *\n\ * K1 (input) INTEGER\n\ * The first element of IPIV for which a row interchange will\n\ * be done.\n\ *\n\ * K2 (input) INTEGER\n\ * The last element of IPIV for which a row interchange will\n\ * be done.\n\ *\n\ * IPIV (input) INTEGER array, dimension (K2*abs(INCX))\n\ * The vector of pivot indices. Only the elements in positions\n\ * K1 through K2 of IPIV are accessed.\n\ * IPIV(K) = L implies rows K and L are to be interchanged.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between successive values of IPIV. If IPIV\n\ * is negative, the pivots are applied in reverse order.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Modified by\n\ * R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32\n COMPLEX*16 TEMP\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dpptrf0000644000175000017500000000516212502223526016513 0ustar uwabamiuwabami--- :name: dpptrf :md5sum: 114d74d68f2338940fdfcbbc9fe314c0 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPPTRF( UPLO, N, AP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPPTRF computes the Cholesky factorization of a real symmetric\n\ * positive definite matrix A stored in packed format.\n\ *\n\ * The factorization has the form\n\ * A = U**T * U, if UPLO = 'U', or\n\ * A = L * L**T, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is lower triangular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ * See below for further details.\n\ *\n\ * On exit, if INFO = 0, the triangular factor U or L from the\n\ * Cholesky factorization A = U**T*U or A = L*L**T, in the same\n\ * storage format as A.\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 leading minor of order i is not\n\ * positive definite, and the factorization could not be\n\ * completed.\n\ *\n\n\ * Further Details\n\ * ======= =======\n\ *\n\ * The packed storage scheme is illustrated by the following example\n\ * when N = 4, UPLO = 'U':\n\ *\n\ * Two-dimensional storage of the symmetric matrix A:\n\ *\n\ * a11 a12 a13 a14\n\ * a22 a23 a24\n\ * a33 a34 (aij = aji)\n\ * a44\n\ *\n\ * Packed storage of the upper triangle of A:\n\ *\n\ * AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dormrq0000644000175000017500000001057212502223526016521 0ustar uwabamiuwabami--- :name: dormrq :md5sum: 076a38b2e29790a32e3e67694f2b9668 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DORMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DORMRQ overwrites the general real M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'T': Q**T * C C * Q**T\n\ *\n\ * where Q is a real orthogonal matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by DGERQF. Q is of order M if SIDE = 'L' and of order N\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**T from the Left;\n\ * = 'R': apply Q or Q**T from the Right.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q;\n\ * = 'T': Transpose, apply Q**T.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension\n\ * (LDA,M) if SIDE = 'L',\n\ * (LDA,N) if SIDE = 'R'\n\ * The i-th row must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * DGERQF in the last k rows of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,K).\n\ *\n\ * TAU (input) DOUBLE PRECISION array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by DGERQF.\n\ *\n\ * C (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M).\n\ * For optimum performance LWORK >= N*NB if SIDE = 'L', and\n\ * LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n\ * 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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clargv0000644000175000017500000000501012502223525016461 0ustar uwabamiuwabami--- :name: clargv :md5sum: 494d5c7b6b8663202a721836295fac6e :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - y: :type: complex :intent: input/output :dims: - 1+(n-1)*incy - incy: :type: integer :intent: input - c: :type: real :intent: output :dims: - 1+(n-1)*incc - incc: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE CLARGV( N, X, INCX, Y, INCY, C, INCC )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLARGV generates a vector of complex plane rotations with real\n\ * cosines, determined by elements of the complex vectors x and y.\n\ * For i = 1,2,...,n\n\ *\n\ * ( c(i) s(i) ) ( x(i) ) = ( r(i) )\n\ * ( -conjg(s(i)) c(i) ) ( y(i) ) = ( 0 )\n\ *\n\ * where c(i)**2 + ABS(s(i))**2 = 1\n\ *\n\ * The following conventions are used (these are the same as in CLARTG,\n\ * but differ from the BLAS1 routine CROTG):\n\ * If y(i)=0, then c(i)=1 and s(i)=0.\n\ * If x(i)=0, then c(i)=0 and s(i) is chosen so that r(i) is real.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of plane rotations to be generated.\n\ *\n\ * X (input/output) COMPLEX array, dimension (1+(N-1)*INCX)\n\ * On entry, the vector x.\n\ * On exit, x(i) is overwritten by r(i), for i = 1,...,n.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between elements of X. INCX > 0.\n\ *\n\ * Y (input/output) COMPLEX array, dimension (1+(N-1)*INCY)\n\ * On entry, the vector y.\n\ * On exit, the sines of the plane rotations.\n\ *\n\ * INCY (input) INTEGER\n\ * The increment between elements of Y. INCY > 0.\n\ *\n\ * C (output) REAL array, dimension (1+(N-1)*INCC)\n\ * The cosines of the plane rotations.\n\ *\n\ * INCC (input) INTEGER\n\ * The increment between elements of C. INCC > 0.\n\ *\n\n\ * Further Details\n\ * ======= =======\n\ *\n\ * 6-6-96 - Modified with a new algorithm by W. Kahan and J. Demmel\n\ *\n\ * This version has a few statements commented out for thread safety\n\ * (machine parameters are computed on each entry). 10 feb 03, SJH.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlatps0000644000175000017500000001636712502223526016542 0ustar uwabamiuwabami--- :name: zlatps :md5sum: 081885c5bc188c12f74e8c900ae574d9 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - normin: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - x: :type: doublecomplex :intent: input/output :dims: - n - scale: :type: doublereal :intent: output - cnorm: :type: doublereal :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, CNORM, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLATPS solves one of the triangular systems\n\ *\n\ * A * x = s*b, A**T * x = s*b, or A**H * x = s*b,\n\ *\n\ * with scaling to prevent overflow, where A is an upper or lower\n\ * triangular matrix stored in packed form. Here A**T denotes the\n\ * transpose of A, A**H denotes the conjugate transpose of A, x and b\n\ * are n-element vectors, and s is a scaling factor, usually less than\n\ * or equal to 1, chosen so that the components of x will be less than\n\ * the overflow threshold. If the unscaled problem will not cause\n\ * overflow, the Level 2 BLAS routine ZTPSV is called. If the matrix A\n\ * is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n\ * non-trivial solution to A*x = 0 is returned.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the matrix A is upper or lower triangular.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the operation applied to A.\n\ * = 'N': Solve A * x = s*b (No transpose)\n\ * = 'T': Solve A**T * x = s*b (Transpose)\n\ * = 'C': Solve A**H * x = s*b (Conjugate transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * Specifies whether or not the matrix A is unit triangular.\n\ * = 'N': Non-unit triangular\n\ * = 'U': Unit triangular\n\ *\n\ * NORMIN (input) CHARACTER*1\n\ * Specifies whether CNORM has been set or not.\n\ * = 'Y': CNORM contains the column norms on entry\n\ * = 'N': CNORM is not set on entry. On exit, the norms will\n\ * be computed and stored in CNORM.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * The upper or lower triangular matrix A, packed columnwise in\n\ * a linear array. The j-th column of A is stored in the array\n\ * AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension (N)\n\ * On entry, the right hand side b of the triangular system.\n\ * On exit, X is overwritten by the solution vector x.\n\ *\n\ * SCALE (output) DOUBLE PRECISION\n\ * The scaling factor s for the triangular system\n\ * A * x = s*b, A**T * x = s*b, or A**H * x = s*b.\n\ * If SCALE = 0, the matrix A is singular or badly scaled, and\n\ * the vector x is an exact or approximate solution to A*x = 0.\n\ *\n\ * CNORM (input or output) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n\ * contains the norm of the off-diagonal part of the j-th column\n\ * of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n\ * to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n\ * must be greater than or equal to the 1-norm.\n\ *\n\ * If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n\ * returns the 1-norm of the offdiagonal part of the j-th column\n\ * of A.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ *\n\n\ * Further Details\n\ * ======= =======\n\ *\n\ * A rough bound on x is computed; if that is less than overflow, ZTPSV\n\ * is called, otherwise, specific code is used which checks for possible\n\ * overflow or divide-by-zero at every operation.\n\ *\n\ * A columnwise scheme is used for solving A*x = b. The basic algorithm\n\ * if A is lower triangular is\n\ *\n\ * x[1:n] := b[1:n]\n\ * for j = 1, ..., n\n\ * x(j) := x(j) / A(j,j)\n\ * x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n\ * end\n\ *\n\ * Define bounds on the components of x after j iterations of the loop:\n\ * M(j) = bound on x[1:j]\n\ * G(j) = bound on x[j+1:n]\n\ * Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n\ *\n\ * Then for iteration j+1 we have\n\ * M(j+1) <= G(j) / | A(j+1,j+1) |\n\ * G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n\ * <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n\ *\n\ * where CNORM(j+1) is greater than or equal to the infinity-norm of\n\ * column j+1 of A, not counting the diagonal. Hence\n\ *\n\ * G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n\ * 1<=i<=j\n\ * and\n\ *\n\ * |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n\ * 1<=i< j\n\ *\n\ * Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTPSV if the\n\ * reciprocal of the largest M(j), j=1,..,n, is larger than\n\ * max(underflow, 1/overflow).\n\ *\n\ * The bound on x(j) is also used to determine when a step in the\n\ * columnwise method can be performed without fear of overflow. If\n\ * the computed bound is greater than a large constant, x is scaled to\n\ * prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n\ * 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n\ *\n\ * Similarly, a row-wise scheme is used to solve A**T *x = b or\n\ * A**H *x = b. The basic algorithm for A upper triangular is\n\ *\n\ * for j = 1, ..., n\n\ * x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n\ * end\n\ *\n\ * We simultaneously compute two bounds\n\ * G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n\ * M(j) = bound on x(i), 1<=i<=j\n\ *\n\ * The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n\ * add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n\ * Then the bound on x(j) is\n\ *\n\ * M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n\ *\n\ * <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n\ * 1<=i<=j\n\ *\n\ * and we can safely call ZTPSV if 1/M(n) and 1/G(n) are both greater\n\ * than max(underflow, 1/overflow).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/csprfs0000644000175000017500000001134212502223525016510 0ustar uwabamiuwabami--- :name: csprfs :md5sum: 3ec422cb25319a32a48c132c4cf128f4 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - n*(n+1)/2 - afp: :type: complex :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSPRFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is symmetric indefinite\n\ * and packed, and provides error bounds and backward error estimates\n\ * for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AP (input) COMPLEX array, dimension (N*(N+1)/2)\n\ * The upper or lower triangle of the symmetric matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * AFP (input) COMPLEX array, dimension (N*(N+1)/2)\n\ * The factored form of the matrix A. AFP contains the block\n\ * diagonal matrix D and the multipliers used to obtain the\n\ * factor U or L from the factorization A = U*D*U**T or\n\ * A = L*D*L**T as computed by CSPTRF, stored as a packed\n\ * triangular matrix.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by CSPTRF.\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) COMPLEX array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by CSPTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zpttrf0000644000175000017500000000376412502223526016553 0ustar uwabamiuwabami--- :name: zpttrf :md5sum: 732937c80869a4f03cc38b05c7bf0531 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublecomplex :intent: input/output :dims: - n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPTTRF( N, D, E, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPTTRF computes the L*D*L' factorization of a complex Hermitian\n\ * positive definite tridiagonal matrix A. The factorization may also\n\ * be regarded as having the form A = U'*D*U.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the n diagonal elements of the tridiagonal matrix\n\ * A. On exit, the n diagonal elements of the diagonal matrix\n\ * D from the L*D*L' factorization of A.\n\ *\n\ * E (input/output) COMPLEX*16 array, dimension (N-1)\n\ * On entry, the (n-1) subdiagonal elements of the tridiagonal\n\ * matrix A. On exit, the (n-1) subdiagonal elements of the\n\ * unit bidiagonal factor L from the L*D*L' factorization of A.\n\ * E can also be regarded as the superdiagonal of the unit\n\ * bidiagonal factor U from the U'*D*U factorization of A.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ * > 0: if INFO = k, the leading minor of order k is not\n\ * positive definite; if k < N, the factorization could not\n\ * be completed, while if k = N, the factorization was\n\ * completed, but D(N) <= 0.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlarra0000644000175000017500000000647512502223526016471 0ustar uwabamiuwabami--- :name: dlarra :md5sum: 417ebdba02d74121e10b2f2e71e95dba :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublereal :intent: input/output :dims: - n - e2: :type: doublereal :intent: input/output :dims: - n - spltol: :type: doublereal :intent: input - tnrm: :type: doublereal :intent: input - nsplit: :type: integer :intent: output - isplit: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLARRA( N, D, E, E2, SPLTOL, TNRM, NSPLIT, ISPLIT, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Compute the splitting points with threshold SPLTOL.\n\ * DLARRA sets any \"small\" off-diagonal elements to zero.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N > 0.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the N diagonal elements of the tridiagonal\n\ * matrix T.\n\ *\n\ * E (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the first (N-1) entries contain the subdiagonal\n\ * elements of the tridiagonal matrix T; E(N) need not be set.\n\ * On exit, the entries E( ISPLIT( I ) ), 1 <= I <= NSPLIT,\n\ * are set to zero, the other entries of E are untouched.\n\ *\n\ * E2 (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the first (N-1) entries contain the SQUARES of the\n\ * subdiagonal elements of the tridiagonal matrix T;\n\ * E2(N) need not be set.\n\ * On exit, the entries E2( ISPLIT( I ) ),\n\ * 1 <= I <= NSPLIT, have been set to zero\n\ *\n\ * SPLTOL (input) DOUBLE PRECISION\n\ * The threshold for splitting. Two criteria can be used:\n\ * SPLTOL<0 : criterion based on absolute off-diagonal value\n\ * SPLTOL>0 : criterion that preserves relative accuracy\n\ *\n\ * TNRM (input) DOUBLE PRECISION\n\ * The norm of the matrix.\n\ *\n\ * NSPLIT (output) INTEGER\n\ * The number of blocks T splits into. 1 <= NSPLIT <= N.\n\ *\n\ * ISPLIT (output) INTEGER array, dimension (N)\n\ * The splitting points, at which T breaks up into blocks.\n\ * The first block consists of rows/columns 1 to ISPLIT(1),\n\ * the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n\ * etc., and the NSPLIT-th consists of rows/columns\n\ * ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n\ *\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Beresford Parlett, University of California, Berkeley, USA\n\ * Jim Demmel, University of California, Berkeley, USA\n\ * Inderjit Dhillon, University of Texas, Austin, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, University of California, Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zpptrf0000644000175000017500000000517112502223526016541 0ustar uwabamiuwabami--- :name: zpptrf :md5sum: d79b305b7c8dc089f8d4fbd0172bd7d5 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPPTRF( UPLO, N, AP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPPTRF computes the Cholesky factorization of a complex Hermitian\n\ * positive definite matrix A stored in packed format.\n\ *\n\ * The factorization has the form\n\ * A = U**H * U, if UPLO = 'U', or\n\ * A = L * L**H, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is lower triangular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ * See below for further details.\n\ *\n\ * On exit, if INFO = 0, the triangular factor U or L from the\n\ * Cholesky factorization A = U**H*U or A = L*L**H, in the same\n\ * storage format as A.\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 leading minor of order i is not\n\ * positive definite, and the factorization could not be\n\ * completed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The packed storage scheme is illustrated by the following example\n\ * when N = 4, UPLO = 'U':\n\ *\n\ * Two-dimensional storage of the Hermitian matrix A:\n\ *\n\ * a11 a12 a13 a14\n\ * a22 a23 a24\n\ * a33 a34 (aij = conjg(aji))\n\ * a44\n\ *\n\ * Packed storage of the upper triangle of A:\n\ *\n\ * AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/spttrf0000644000175000017500000000372012502223526016534 0ustar uwabamiuwabami--- :name: spttrf :md5sum: 47f8d0a8b02124ba7683b1ce91574c41 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPTTRF( N, D, E, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPTTRF computes the L*D*L' factorization of a real symmetric\n\ * positive definite tridiagonal matrix A. The factorization may also\n\ * be regarded as having the form A = U'*D*U.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the n diagonal elements of the tridiagonal matrix\n\ * A. On exit, the n diagonal elements of the diagonal matrix\n\ * D from the L*D*L' factorization of A.\n\ *\n\ * E (input/output) REAL array, dimension (N-1)\n\ * On entry, the (n-1) subdiagonal elements of the tridiagonal\n\ * matrix A. On exit, the (n-1) subdiagonal elements of the\n\ * unit bidiagonal factor L from the L*D*L' factorization of A.\n\ * E can also be regarded as the superdiagonal of the unit\n\ * bidiagonal factor U from the U'*D*U factorization of A.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ * > 0: if INFO = k, the leading minor of order k is not\n\ * positive definite; if k < N, the factorization could not\n\ * be completed, while if k = N, the factorization was\n\ * completed, but D(N) <= 0.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sla_gbrfsx_extended0000644000175000017500000003571112502223526021231 0ustar uwabamiuwabami--- :name: sla_gbrfsx_extended :md5sum: 2c7e202e5db9c2ecbab23f7b2f5f177f :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - trans_type: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: real :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - colequ: :type: logical :intent: input - c: :type: real :intent: input :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: real :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: real :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - err_bnds_norm: :type: real :intent: input/output :dims: - nrhs - n_norms - err_bnds_comp: :type: real :intent: input/output :dims: - nrhs - n_norms - res: :type: real :intent: input :dims: - n - ayb: :type: real :intent: input :dims: - n - dy: :type: real :intent: input :dims: - n - y_tail: :type: real :intent: input :dims: - n - rcond: :type: real :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: real :intent: input - dz_ub: :type: real :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: n: ldab ldafb: n :fortran_help: " SUBROUTINE SLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLA_GBRFSX_EXTENDED improves the computed solution to a system of\n\ * linear equations by performing extra-precise iterative refinement\n\ * and provides error bounds and backward error estimates for the solution.\n\ * This subroutine is called by SGBRFSX to perform iterative refinement.\n\ * In addition to normwise error bound, the code provides maximum\n\ * componentwise error bound if possible. See comments for ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP for details of the error bounds. Note that this\n\ * subroutine is only resonsible for setting the second fields of\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * PREC_TYPE (input) INTEGER\n\ * Specifies the intermediate precision to be used in refinement.\n\ * The value is defined by ILAPREC(P) where P is a CHARACTER and\n\ * P = 'S': Single\n\ * = 'D': Double\n\ * = 'I': Indigenous\n\ * = 'X', 'E': Extra\n\ *\n\ * TRANS_TYPE (input) INTEGER\n\ * Specifies the transposition operation on A.\n\ * The value is defined by ILATRANS(T) where T is a CHARACTER and\n\ * T = 'N': No transpose\n\ * = 'T': Transpose\n\ * = 'C': Conjugate transpose\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right-hand-sides, i.e., the number of columns of the\n\ * matrix B.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) REAL array, dimension (LDAF,N)\n\ * The factors L and U from the factorization\n\ * A = P*L*U as computed by SGBTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from the factorization A = P*L*U\n\ * as computed by SGBTRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * COLEQU (input) LOGICAL\n\ * If .TRUE. then column equilibration was done to A before calling\n\ * this routine. This is needed to compute the solution and error\n\ * bounds correctly.\n\ *\n\ * C (input) REAL array, dimension (N)\n\ * The column scale factors for A. If COLEQU = .FALSE., C\n\ * is not accessed. If C is input, each element of C should be a power\n\ * of the radix to ensure a reliable solution and error estimates.\n\ * Scaling by powers of the radix does not cause rounding errors unless\n\ * the result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input) REAL array, dimension (LDB,NRHS)\n\ * The right-hand-side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * Y (input/output) REAL array, dimension (LDY,NRHS)\n\ * On entry, the solution matrix X, as computed by SGBTRS.\n\ * On exit, the improved solution matrix Y.\n\ *\n\ * LDY (input) INTEGER\n\ * The leading dimension of the array Y. LDY >= max(1,N).\n\ *\n\ * BERR_OUT (output) REAL array, dimension (NRHS)\n\ * On exit, BERR_OUT(j) contains the componentwise relative backward\n\ * error for right-hand-side j from the formula\n\ * max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n\ * where abs(Z) is the componentwise absolute value of the matrix\n\ * or vector Z. This is computed by SLA_LIN_BERR.\n\ *\n\ * N_NORMS (input) INTEGER\n\ * Determines which error bounds to return (see ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP).\n\ * If N_NORMS >= 1 return normwise error bounds.\n\ * If N_NORMS >= 2 return componentwise error bounds.\n\ *\n\ * ERR_BNDS_NORM (input/output) REAL array, dimension \n\ * (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (input/output) REAL array, dimension \n\ * (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * RES (input) REAL array, dimension (N)\n\ * Workspace to hold the intermediate residual.\n\ *\n\ * AYB (input) REAL array, dimension (N)\n\ * Workspace. This can be the same workspace passed for Y_TAIL.\n\ *\n\ * DY (input) REAL array, dimension (N)\n\ * Workspace to hold the intermediate solution.\n\ *\n\ * Y_TAIL (input) REAL array, dimension (N)\n\ * Workspace to hold the trailing bits of the intermediate solution.\n\ *\n\ * RCOND (input) REAL\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * ITHRESH (input) INTEGER\n\ * The maximum number of residual computations allowed for\n\ * refinement. The default is 10. For 'aggressive' set to 100 to\n\ * permit convergence using approximate factorizations or\n\ * factorizations other than LU. If the factorization uses a\n\ * technique other than Gaussian elimination, the guarantees in\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n\ *\n\ * RTHRESH (input) REAL\n\ * Determines when to stop refinement if the error estimate stops\n\ * decreasing. Refinement will stop when the next solution no longer\n\ * satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n\ * the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n\ * default value is 0.5. For 'aggressive' set to 0.9 to permit\n\ * convergence on extremely ill-conditioned matrices. See LAWN 165\n\ * for more details.\n\ *\n\ * DZ_UB (input) REAL\n\ * Determines when to start considering componentwise convergence.\n\ * Componentwise convergence is only considered after each component\n\ * of the solution Y is stable, which we definte as the relative\n\ * change in each component being less than DZ_UB. The default value\n\ * is 0.25, requiring the first bit to be stable. See LAWN 165 for\n\ * more details.\n\ *\n\ * IGNORE_CWISE (input) LOGICAL\n\ * If .TRUE. then ignore componentwise convergence. Default value\n\ * is .FALSE..\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * < 0: if INFO = -i, the ith argument to SGBTRS had an illegal\n\ * value\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n CHARACTER TRANS\n INTEGER CNT, I, J, M, X_STATE, Z_STATE, Y_PREC_STATE\n REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cpotri0000644000175000017500000000412612502223525016512 0ustar uwabamiuwabami--- :name: cpotri :md5sum: 9ceb1cdb87edadbd814f66025a60044e :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPOTRI( UPLO, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPOTRI computes the inverse of a complex Hermitian positive definite\n\ * matrix A using the Cholesky factorization A = U**H*U or A = L*L**H\n\ * computed by CPOTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the triangular factor U or L from the Cholesky\n\ * factorization A = U**H*U or A = L*L**H, as computed by\n\ * CPOTRF.\n\ * On exit, the upper or lower triangle of the (Hermitian)\n\ * inverse of A, overwriting the input factor U or L.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\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,i) element of the factor U or L is\n\ * zero, and the inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CLAUUM, CTRTRI, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zgetrf0000644000175000017500000000454412502223526016520 0ustar uwabamiuwabami--- :name: zgetrf :md5sum: 41f07c12be32d488ebbabd0cf01a2b70 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGETRF computes an LU factorization of a general M-by-N matrix A\n\ * using partial pivoting with row interchanges.\n\ *\n\ * The factorization has the form\n\ * A = P * L * U\n\ * where P is a permutation matrix, L is lower triangular with unit\n\ * diagonal elements (lower trapezoidal if m > n), and U is upper\n\ * triangular (upper trapezoidal if m < n).\n\ *\n\ * This is the right-looking Level 3 BLAS version of the algorithm.\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) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix to be factored.\n\ * On exit, the factors L and U from the factorization\n\ * A = P*L*U; the unit diagonal elements of L are not stored.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * IPIV (output) INTEGER array, dimension (min(M,N))\n\ * The pivot indices; for 1 <= i <= min(M,N), row i of the\n\ * matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, and division by zero will occur if it is used\n\ * to solve a system of equations.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zla_geamv0000644000175000017500000001141112502223526017153 0ustar uwabamiuwabami--- :name: zla_geamv :md5sum: ee793a4d70e846cfb17334848e117602 :category: :subroutine :arguments: - trans: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: doublereal :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: doublereal :intent: input :dims: - "trans == ilatrans_(\"N\") ? 1+(n-1)*abs(incx) : 1+(m-1)*abs(incx)" - incx: :type: integer :intent: input - beta: :type: doublereal :intent: input - y: :type: doublereal :intent: input/output :dims: - "trans == ilatrans_(\"N\") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )" - incy: :type: integer :intent: input :substitutions: lda: MAX(1, m) :fortran_help: " SUBROUTINE ZLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLA_GEAMV performs one of the matrix-vector operations\n\ *\n\ * y := alpha*abs(A)*abs(x) + beta*abs(y),\n\ * or y := alpha*abs(A)'*abs(x) + beta*abs(y),\n\ *\n\ * where alpha and beta are scalars, x and y are vectors and A is an\n\ * m by n matrix.\n\ *\n\ * This function is primarily used in calculating error bounds.\n\ * To protect against underflow during evaluation, components in\n\ * the resulting vector are perturbed away from zero by (N+1)\n\ * times the underflow threshold. To prevent unnecessarily large\n\ * errors for block-structure embedded in general matrices,\n\ * \"symbolically\" zero components are not perturbed. A zero\n\ * entry is considered \"symbolic\" if all multiplications involved\n\ * in computing that entry have at least one zero multiplicand.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * TRANS (input) INTEGER\n\ * On entry, TRANS specifies the operation to be performed as\n\ * follows:\n\ *\n\ * BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y)\n\ * BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n\ * BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n\ *\n\ * Unchanged on exit.\n\ *\n\ * M (input) INTEGER\n\ * On entry, M specifies the number of rows of the matrix A.\n\ * M must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the number of columns of the matrix A.\n\ * N must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * ALPHA - DOUBLE PRECISION\n\ * On entry, ALPHA specifies the scalar alpha.\n\ * Unchanged on exit.\n\ *\n\ * A - COMPLEX*16 array of DIMENSION ( LDA, n )\n\ * Before entry, the leading m by n part of the array A must\n\ * contain the matrix of coefficients.\n\ * Unchanged on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * On entry, LDA specifies the first dimension of A as declared\n\ * in the calling (sub) program. LDA must be at least\n\ * max( 1, m ).\n\ * Unchanged on exit.\n\ *\n\ * X - COMPLEX*16 array of DIMENSION at least\n\ * ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n\ * and at least\n\ * ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n\ * Before entry, the incremented array X must contain the\n\ * vector x.\n\ * Unchanged on exit.\n\ *\n\ * INCX (input) INTEGER\n\ * On entry, INCX specifies the increment for the elements of\n\ * X. INCX must not be zero.\n\ * Unchanged on exit.\n\ *\n\ * BETA - DOUBLE PRECISION\n\ * On entry, BETA specifies the scalar beta. When BETA is\n\ * supplied as zero then Y need not be set on input.\n\ * Unchanged on exit.\n\ *\n\ * Y (input/output) DOUBLE PRECISION array, dimension\n\ * ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n\ * and at least\n\ * ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n\ * Before entry with BETA non-zero, the incremented array Y\n\ * must contain the vector y. On exit, Y is overwritten by the\n\ * updated vector y.\n\ *\n\ * INCY (input) INTEGER\n\ * On entry, INCY specifies the increment for the elements of\n\ * Y. INCY must not be zero.\n\ * Unchanged on exit.\n\ *\n\ *\n\ * Level 2 Blas routine.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlaqge0000644000175000017500000000626612502223526016505 0ustar uwabamiuwabami--- :name: zlaqge :md5sum: e14f9153c59e94be579139041a5cbd9f :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - r: :type: doublereal :intent: input :dims: - m - c: :type: doublereal :intent: input :dims: - n - rowcnd: :type: doublereal :intent: input - colcnd: :type: doublereal :intent: input - amax: :type: doublereal :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAQGE equilibrates a general M by N matrix A using the row and\n\ * column scaling factors in the vectors R and C.\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) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the M by N matrix A.\n\ * On exit, the equilibrated matrix. See EQUED for the form of\n\ * the equilibrated matrix.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(M,1).\n\ *\n\ * R (input) DOUBLE PRECISION array, dimension (M)\n\ * The row scale factors for A.\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension (N)\n\ * The column scale factors for A.\n\ *\n\ * ROWCND (input) DOUBLE PRECISION\n\ * Ratio of the smallest R(i) to the largest R(i).\n\ *\n\ * COLCND (input) DOUBLE PRECISION\n\ * Ratio of the smallest C(i) to the largest C(i).\n\ *\n\ * AMAX (input) DOUBLE PRECISION\n\ * Absolute value of largest matrix entry.\n\ *\n\ * EQUED (output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * THRESH is a threshold value used to decide if row or column scaling\n\ * should be done based on the ratio of the row or column scaling\n\ * factors. If ROWCND < THRESH, row scaling is done, and if\n\ * COLCND < THRESH, column scaling is done.\n\ *\n\ * LARGE and SMALL are threshold values used to decide if row scaling\n\ * should be done based on the absolute size of the largest matrix\n\ * element. If AMAX > LARGE or AMAX < SMALL, row scaling is done.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dstevr0000644000175000017500000002503612502223526016525 0ustar uwabamiuwabami--- :name: dstevr :md5sum: aebc7a9722c572e03966c68225a5a366 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - MAX(1,n-1) - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 20*n - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: 10*n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"I\") ? iu-il+1 : n" :fortran_help: " SUBROUTINE DSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSTEVR computes selected eigenvalues and, optionally, eigenvectors\n\ * of a real symmetric tridiagonal matrix T. Eigenvalues and\n\ * eigenvectors can be selected by specifying either a range of values\n\ * or a range of indices for the desired eigenvalues.\n\ *\n\ * Whenever possible, DSTEVR calls DSTEMR to compute the\n\ * eigenspectrum using Relatively Robust Representations. DSTEMR\n\ * computes eigenvalues by the dqds algorithm, while orthogonal\n\ * eigenvectors are computed from various \"good\" L D L^T representations\n\ * (also known as Relatively Robust Representations). Gram-Schmidt\n\ * orthogonalization is avoided as far as possible. More specifically,\n\ * the various steps of the algorithm are as follows. For the i-th\n\ * unreduced block of T,\n\ * (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T\n\ * is a relatively robust representation,\n\ * (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high\n\ * relative accuracy by the dqds algorithm,\n\ * (c) If there is a cluster of close eigenvalues, \"choose\" sigma_i\n\ * close to the cluster, and go to step (a),\n\ * (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T,\n\ * compute the corresponding eigenvector by forming a\n\ * rank-revealing twisted factorization.\n\ * The desired accuracy of the output can be specified by the input\n\ * parameter ABSTOL.\n\ *\n\ * For more details, see \"A new O(n^2) algorithm for the symmetric\n\ * tridiagonal eigenvalue/eigenvector problem\", by Inderjit Dhillon,\n\ * Computer Science Division Technical Report No. UCB//CSD-97-971,\n\ * UC Berkeley, May 1997.\n\ *\n\ *\n\ * Note 1 : DSTEVR calls DSTEMR when the full spectrum is requested\n\ * on machines which conform to the ieee-754 floating point standard.\n\ * DSTEVR calls DSTEBZ and DSTEIN on non-ieee machines and\n\ * when partial spectrum requests are made.\n\ *\n\ * Normal execution of DSTEMR may create NaNs and infinities and\n\ * hence may abort due to a floating point exception in environments\n\ * which do not handle NaNs and infinities in the ieee standard default\n\ * manner.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found.\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found.\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ ********** For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and\n\ ********** DSTEIN are called\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the n diagonal elements of the tridiagonal matrix\n\ * A.\n\ * On exit, D may be multiplied by a constant factor chosen\n\ * to avoid over/underflow in computing the eigenvalues.\n\ *\n\ * E (input/output) DOUBLE PRECISION array, dimension (max(1,N-1))\n\ * On entry, the (n-1) subdiagonal elements of the tridiagonal\n\ * matrix A in elements 1 to N-1 of E.\n\ * On exit, E may be multiplied by a constant factor chosen\n\ * to avoid over/underflow in computing the eigenvalues.\n\ *\n\ * VL (input) DOUBLE PRECISION\n\ * VU (input) DOUBLE PRECISION\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) DOUBLE PRECISION\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less than\n\ * or equal to zero, then EPS*|T| will be used in its place,\n\ * where |T| is the 1-norm of the tridiagonal matrix obtained\n\ * by reducing A to tridiagonal form.\n\ *\n\ * See \"Computing Small Singular Values of Bidiagonal Matrices\n\ * with Guaranteed High Relative Accuracy,\" by Demmel and\n\ * Kahan, LAPACK Working Note #3.\n\ *\n\ * If high relative accuracy is important, set ABSTOL to\n\ * DLAMCH( 'Safe minimum' ). Doing so will guarantee that\n\ * eigenvalues are computed to high relative accuracy when\n\ * possible in future releases. The current code does not\n\ * make any guarantees about high relative accuracy, but\n\ * future releases will. See J. Barlow and J. Demmel,\n\ * \"Computing Accurate Eigensystems of Scaled Diagonally\n\ * Dominant Matrices\", LAPACK Working Note #7, for a discussion\n\ * of which matrices define their eigenvalues to high relative\n\ * accuracy.\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * The first M elements contain the selected eigenvalues in\n\ * ascending order.\n\ *\n\ * Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )\n\ * If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix A\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )\n\ * The support of the eigenvectors in Z, i.e., the indices\n\ * indicating the nonzero elements in Z. The i-th eigenvector\n\ * is nonzero only in elements ISUPPZ( 2*i-1 ) through\n\ * ISUPPZ( 2*i ).\n\ ********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1\n\ *\n\ * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal (and\n\ * minimal) LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK >= max(1,20*N).\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the optimal sizes of the WORK and IWORK\n\ * arrays, returns these values as the first entries of the WORK\n\ * and IWORK arrays, and no error message related to LWORK or\n\ * LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal (and\n\ * minimal) LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK. LIWORK >= max(1,10*N).\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK and IWORK arrays, and no error message related to\n\ * LWORK or LIWORK 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: Internal error\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Inderjit Dhillon, IBM Almaden, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Ken Stanley, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dposvxx0000644000175000017500000005057712502223526016741 0ustar uwabamiuwabami--- :name: dposvxx :md5sum: 3fd4b03e21b01e3b820125993ffeaee5 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - equed: :type: char :intent: input/output - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - rpvgrw: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublereal :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " SUBROUTINE DPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T\n\ * to compute the solution to a double precision system of linear equations\n\ * A * X = B, where A is an N-by-N symmetric positive definite matrix\n\ * and X and B are N-by-NRHS matrices.\n\ *\n\ * If requested, both normwise and maximum componentwise error bounds\n\ * are returned. DPOSVXX will return a solution with a tiny\n\ * guaranteed error (O(eps) where eps is the working machine\n\ * precision) unless the matrix is very ill-conditioned, in which\n\ * case a warning is returned. Relevant condition numbers also are\n\ * calculated and returned.\n\ *\n\ * DPOSVXX accepts user-provided factorizations and equilibration\n\ * factors; see the definitions of the FACT and EQUED options.\n\ * Solving with refinement and using a factorization from a previous\n\ * DPOSVXX call will also produce a solution with either O(eps)\n\ * errors or warnings, but we cannot make that claim for general\n\ * user-provided factorizations and equilibration factors if they\n\ * differ from what DPOSVXX would itself produce.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n\ * the system:\n\ *\n\ * diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B\n\ *\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n\ *\n\ * 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n\ * factor the matrix A (after equilibration if FACT = 'E') as\n\ * A = U**T* U, if UPLO = 'U', or\n\ * A = L * L**T, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is a lower triangular\n\ * matrix.\n\ *\n\ * 3. If the leading i-by-i principal minor is not positive definite,\n\ * then the routine returns with INFO = i. Otherwise, the factored\n\ * form of A is used to estimate the condition number of the matrix\n\ * A (see argument RCOND). If the reciprocal of the condition number\n\ * is less than machine precision, the routine still goes on to solve\n\ * for X and compute error bounds as described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n\ * the routine will use iterative refinement to try to get a small\n\ * error and error bounds. Refinement calculates the residual to at\n\ * least twice the working precision.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(S) so that it solves the original system before\n\ * equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AF contains the factored form of A.\n\ * If EQUED is not 'N', the matrix A has been\n\ * equilibrated with scaling factors given by S.\n\ * A and AF are not modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AF and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A, except if FACT = 'F' and EQUED =\n\ * 'Y', then A must contain the equilibrated matrix\n\ * diag(S)*A*diag(S). If UPLO = 'U', the leading N-by-N upper\n\ * triangular part of A contains the upper triangular part of the\n\ * matrix A, and the strictly lower triangular part of A is not\n\ * referenced. If UPLO = 'L', the leading N-by-N lower triangular\n\ * part of A contains the lower triangular part of the matrix A, and\n\ * the strictly upper triangular part of A is not referenced. A is\n\ * not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED =\n\ * 'N' on exit.\n\ *\n\ * On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n\ * diag(S)*A*diag(S).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N)\n\ * If FACT = 'F', then AF is an input argument and on entry\n\ * contains the triangular factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T, in the same storage\n\ * format as A. If EQUED .ne. 'N', then AF is the factored\n\ * form of the equilibrated matrix diag(S)*A*diag(S).\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T of the original\n\ * matrix A.\n\ *\n\ * If FACT = 'E', then AF is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T of the equilibrated\n\ * matrix A (see the description of A for the form of the\n\ * equilibrated matrix).\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'Y': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(S) * A * diag(S).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * S (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'Y', A is multiplied on\n\ * the left and right by diag(S). S is an input argument if FACT =\n\ * 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n\ * = 'Y', each element of S must be positive. If S is output, each\n\ * element of S is a power of the radix. If S is input, each element\n\ * of S should be a power of the radix to ensure a reliable solution\n\ * and error estimates. Scaling by powers of the radix does not cause\n\ * rounding errors unless the result underflows or overflows.\n\ * Rounding errors during scaling lead to refining with a matrix that\n\ * is not equivalent to the input matrix, producing error estimates\n\ * that may not be reliable.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit,\n\ * if EQUED = 'N', B is not modified;\n\ * if EQUED = 'Y', B is overwritten by diag(S)*B;\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * If INFO = 0, the N-by-NRHS solution matrix X to the original\n\ * system of equations. Note that A and B are modified on exit if\n\ * EQUED .ne. 'N', and the solution to the equilibrated system is\n\ * inv(diag(S))*X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * RPVGRW (output) DOUBLE PRECISION\n\ * Reciprocal pivot growth. On exit, this contains the reciprocal\n\ * pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n\ * norm is used. If this is much less than 1, then the stability of\n\ * the LU factorization of the (equilibrated) matrix A could be poor.\n\ * This also means that the solution X, estimated condition numbers,\n\ * and error bounds could be unreliable. If factorization fails with\n\ * 0 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zunmr30000644000175000017500000001122512502223526016447 0ustar uwabamiuwabami--- :name: zunmr3 :md5sum: 9936c02446a1fbd2f55c0aad91334345 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZUNMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZUNMR3 overwrites the general complex m by n matrix C with\n\ *\n\ * Q * C if SIDE = 'L' and TRANS = 'N', or\n\ *\n\ * Q'* C if SIDE = 'L' and TRANS = 'C', or\n\ *\n\ * C * Q if SIDE = 'R' and TRANS = 'N', or\n\ *\n\ * C * Q' if SIDE = 'R' and TRANS = 'C',\n\ *\n\ * where Q is a complex unitary matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by ZTZRZF. Q is of order m if SIDE = 'L' and of order n\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q' from the Left\n\ * = 'R': apply Q or Q' from the Right\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': apply Q (No transpose)\n\ * = 'C': apply Q' (Conjugate transpose)\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * L (input) INTEGER\n\ * The number of columns of the matrix A containing\n\ * the meaningful part of the Householder reflectors.\n\ * If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension\n\ * (LDA,M) if SIDE = 'L',\n\ * (LDA,N) if SIDE = 'R'\n\ * The i-th row must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * ZTZRZF in the last k rows of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,K).\n\ *\n\ * TAU (input) COMPLEX*16 array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by ZTZRZF.\n\ *\n\ * C (input/output) COMPLEX*16 array, dimension (LDC,N)\n\ * On entry, the m-by-n matrix C.\n\ * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension\n\ * (N) if SIDE = 'L',\n\ * (M) if SIDE = 'R'\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\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LEFT, NOTRAN\n INTEGER I, I1, I2, I3, IC, JA, JC, MI, NI, NQ\n COMPLEX*16 TAUI\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZLARZ\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC DCONJG, MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cla_porcond_x0000644000175000017500000000610012502223525020016 0ustar uwabamiuwabami--- :name: cla_porcond_x :md5sum: ec4ec54a78c42bf0a9779386bc95ac15 :category: :function :type: real :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - x: :type: complex :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: complex :intent: input :dims: - 2*n - rwork: :type: real :intent: input :dims: - n :substitutions: {} :fortran_help: " REAL FUNCTION CLA_PORCOND_X( UPLO, N, A, LDA, AF, LDAF, X, INFO, WORK, RWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLA_PORCOND_X Computes the infinity norm condition number of\n\ * op(A) * diag(X) where X is a COMPLEX vector.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX array, dimension (LDAF,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T, as computed by CPOTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * X (input) COMPLEX array, dimension (N)\n\ * The vector X in the formula op(A) * diag(X).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * i > 0: The ith argument is invalid.\n\ *\n\ * WORK (input) COMPLEX array, dimension (2*N).\n\ * Workspace.\n\ *\n\ * RWORK (input) REAL array, dimension (N).\n\ * Workspace.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER KASE, I, J\n REAL AINVNM, ANORM, TMP\n LOGICAL UP\n COMPLEX ZDUM\n\ * ..\n\ * .. Local Arrays ..\n INTEGER ISAVE( 3 )\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CLACN2, CPOTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, REAL, AIMAG\n\ * ..\n\ * .. Statement Functions ..\n REAL CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sorgqr0000644000175000017500000000570312502223526016532 0ustar uwabamiuwabami--- :name: sorgqr :md5sum: 7ef8704c3983d6fc67c5358b41d724c9 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SORGQR generates an M-by-N real matrix Q with orthonormal columns,\n\ * which is defined as the first N columns of a product of K elementary\n\ * reflectors of order M\n\ *\n\ * Q = H(1) H(2) . . . H(k)\n\ *\n\ * as returned by SGEQRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. M >= N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. N >= K >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the i-th column must contain the vector which\n\ * defines the elementary reflector H(i), for i = 1,2,...,k, as\n\ * returned by SGEQRF in the first k columns of its array\n\ * argument A.\n\ * On exit, the M-by-N matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) REAL array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by SGEQRF.\n\ *\n\ * WORK (workspace/output) REAL 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,N).\n\ * For optimum performance LWORK >= N*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 has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhesvxx0000644000175000017500000005133712502223526016740 0ustar uwabamiuwabami--- :name: zhesvxx :md5sum: d41a02cad371c27e3d0b19c85d52f180 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - equed: :type: char :intent: input/output - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - rpvgrw: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " SUBROUTINE ZHESVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHESVXX uses the diagonal pivoting factorization to compute the\n\ * solution to a complex*16 system of linear equations A * X = B, where\n\ * A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n\ * matrices.\n\ *\n\ * If requested, both normwise and maximum componentwise error bounds\n\ * are returned. ZHESVXX will return a solution with a tiny\n\ * guaranteed error (O(eps) where eps is the working machine\n\ * precision) unless the matrix is very ill-conditioned, in which\n\ * case a warning is returned. Relevant condition numbers also are\n\ * calculated and returned.\n\ *\n\ * ZHESVXX accepts user-provided factorizations and equilibration\n\ * factors; see the definitions of the FACT and EQUED options.\n\ * Solving with refinement and using a factorization from a previous\n\ * ZHESVXX call will also produce a solution with either O(eps)\n\ * errors or warnings, but we cannot make that claim for general\n\ * user-provided factorizations and equilibration factors if they\n\ * differ from what ZHESVXX would itself produce.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n\ * the system:\n\ *\n\ * diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B\n\ *\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n\ *\n\ * 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n\ * the matrix A (after equilibration if FACT = 'E') as\n\ *\n\ * A = U * D * U**T, if UPLO = 'U', or\n\ * A = L * D * L**T, if UPLO = 'L',\n\ *\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, and D is symmetric and block diagonal with\n\ * 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\ * 3. If some D(i,i)=0, so that D is exactly singular, then the\n\ * routine returns with INFO = i. Otherwise, the factored form of A\n\ * is used to estimate the condition number of the matrix A (see\n\ * argument RCOND). If the reciprocal of the condition number is\n\ * less than machine precision, the routine still goes on to solve\n\ * for X and compute error bounds as described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n\ * the routine will use iterative refinement to try to get a small\n\ * error and error bounds. Refinement calculates the residual to at\n\ * least twice the working precision.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(R) so that it solves the original system before\n\ * equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AF and IPIV contain the factored form of A.\n\ * If EQUED is not 'N', the matrix A has been\n\ * equilibrated with scaling factors given by S.\n\ * A, AF, and IPIV are not modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AF and factored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular\n\ * part of the matrix A, and the strictly lower triangular\n\ * part of A is not referenced. If UPLO = 'L', the leading\n\ * N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n\ * diag(S)*A*diag(S).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input or output) COMPLEX*16 array, dimension (LDAF,N)\n\ * If FACT = 'F', then AF is an input argument and on entry\n\ * contains the block diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L from the factorization A =\n\ * U*D*U**T or A = L*D*L**T as computed by DSYTRF.\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the block diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L from the factorization A =\n\ * U*D*U**T or A = L*D*L**T.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains details of the interchanges and the block\n\ * structure of D, as determined by ZHETRF. If IPIV(k) > 0,\n\ * then rows and columns k and IPIV(k) were interchanged and\n\ * D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and\n\ * IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and\n\ * -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2\n\ * diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0,\n\ * then rows and columns k+1 and -IPIV(k) were interchanged\n\ * and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains details of the interchanges and the block\n\ * structure of D, as determined by ZHETRF.\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'Y': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(S) * A * diag(S).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * S (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The scale factors for A. If EQUED = 'Y', A is multiplied on\n\ * the left and right by diag(S). S is an input argument if FACT =\n\ * 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n\ * = 'Y', each element of S must be positive. If S is output, each\n\ * element of S is a power of the radix. If S is input, each element\n\ * of S should be a power of the radix to ensure a reliable solution\n\ * and error estimates. Scaling by powers of the radix does not cause\n\ * rounding errors unless the result underflows or overflows.\n\ * Rounding errors during scaling lead to refining with a matrix that\n\ * is not equivalent to the input matrix, producing error estimates\n\ * that may not be reliable.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit,\n\ * if EQUED = 'N', B is not modified;\n\ * if EQUED = 'Y', B is overwritten by diag(S)*B;\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * If INFO = 0, the N-by-NRHS solution matrix X to the original\n\ * system of equations. Note that A and B are modified on exit if\n\ * EQUED .ne. 'N', and the solution to the equilibrated system is\n\ * inv(diag(S))*X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * RPVGRW (output) DOUBLE PRECISION\n\ * Reciprocal pivot growth. On exit, this contains the reciprocal\n\ * pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n\ * norm is used. If this is much less than 1, then the stability of\n\ * the LU factorization of the (equilibrated) matrix A could be poor.\n\ * This also means that the solution X, estimated condition numbers,\n\ * and error bounds could be unreliable. If factorization fails with\n\ * 0 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dtprfs0000644000175000017500000001117712502223526016521 0ustar uwabamiuwabami--- :name: dtprfs :md5sum: 6ebdcf9618f401dd3cc557634f2c0b07 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - n*(n+1)/2 - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ldb :fortran_help: " SUBROUTINE DTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTPRFS provides error bounds and backward error estimates for the\n\ * solution to a system of linear equations with a triangular packed\n\ * coefficient matrix.\n\ *\n\ * The solution matrix X must be computed by DTPTRS or some other\n\ * means before entering this routine. DTPRFS does not do iterative\n\ * refinement because doing so cannot improve the backward error.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose = Transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * The upper or lower triangular matrix A, packed columnwise in\n\ * a linear array. The j-th column of A is stored in the array\n\ * AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ * If DIAG = 'U', the diagonal elements of A are not referenced\n\ * and are assumed to be 1.\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * The solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ztprfs0000644000175000017500000001116512502223526016544 0ustar uwabamiuwabami--- :name: ztprfs :md5sum: 0ad6c6044e04b9f8287f22946398270a :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ldb :fortran_help: " SUBROUTINE ZTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTPRFS provides error bounds and backward error estimates for the\n\ * solution to a system of linear equations with a triangular packed\n\ * coefficient matrix.\n\ *\n\ * The solution matrix X must be computed by ZTPTRS or some other\n\ * means before entering this routine. ZTPRFS does not do iterative\n\ * refinement because doing so cannot improve the backward error.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * The upper or lower triangular matrix A, packed columnwise in\n\ * a linear array. The j-th column of A is stored in the array\n\ * AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ * If DIAG = 'U', the diagonal elements of A are not referenced\n\ * and are assumed to be 1.\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * The solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlalsd0000644000175000017500000001233512502223526016457 0ustar uwabamiuwabami--- :name: dlalsd :md5sum: daa27e524befeb510c616ce5488bea0f :category: :subroutine :arguments: - uplo: :type: char :intent: input - smlsiz: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - rcond: :type: doublereal :intent: input - rank: :type: integer :intent: output - work: :type: doublereal :intent: workspace :dims: - 9*n + 2*n*smlsiz + 8*n*nlvl + n*nrhs + pow(smlsiz+1,2) - iwork: :type: integer :intent: workspace :dims: - 3*n*nlvl + 11*n - info: :type: integer :intent: output :substitutions: nlvl: MAX(0, (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1) :extras: nlvl: integer :fortran_help: " SUBROUTINE DLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, RANK, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLALSD uses the singular value decomposition of A to solve the least\n\ * squares problem of finding X to minimize the Euclidean norm of each\n\ * column of A*X-B, where A is N-by-N upper bidiagonal, and X and B\n\ * are N-by-NRHS. The solution X overwrites B.\n\ *\n\ * The singular values of A smaller than RCOND times the largest\n\ * singular value are treated as zero in solving the least squares\n\ * problem; in this case a minimum norm solution is returned.\n\ * The actual singular values are returned in D in ascending order.\n\ *\n\ * This code makes very mild assumptions about floating point\n\ * arithmetic. It will work on machines with a guard digit in\n\ * add/subtract, or on those binary machines without guard digits\n\ * which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.\n\ * It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': D and E define an upper bidiagonal matrix.\n\ * = 'L': D and E define a lower bidiagonal matrix.\n\ *\n\ * SMLSIZ (input) INTEGER\n\ * The maximum size of the subproblems at the bottom of the\n\ * computation tree.\n\ *\n\ * N (input) INTEGER\n\ * The dimension of the bidiagonal matrix. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of columns of B. NRHS must be at least 1.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry D contains the main diagonal of the bidiagonal\n\ * matrix. On exit, if INFO = 0, D contains its singular values.\n\ *\n\ * E (input/output) DOUBLE PRECISION array, dimension (N-1)\n\ * Contains the super-diagonal entries of the bidiagonal matrix.\n\ * On exit, E has been destroyed.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On input, B contains the right hand sides of the least\n\ * squares problem. On output, B contains the solution X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B in the calling subprogram.\n\ * LDB must be at least max(1,N).\n\ *\n\ * RCOND (input) DOUBLE PRECISION\n\ * The singular values of A less than or equal to RCOND times\n\ * the largest singular value are treated as zero in solving\n\ * the least squares problem. If RCOND is negative,\n\ * machine precision is used instead.\n\ * For example, if diag(S)*X=B were the least squares problem,\n\ * where diag(S) is a diagonal matrix of singular values, the\n\ * solution would be X(i) = B(i) / S(i) if S(i) is greater than\n\ * RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to\n\ * RCOND*max(S).\n\ *\n\ * RANK (output) INTEGER\n\ * The number of singular values of A greater than RCOND times\n\ * the largest singular value.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension at least\n\ * (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2),\n\ * where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1).\n\ *\n\ * IWORK (workspace) INTEGER array, dimension at least\n\ * (3*N*NLVL + 11*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit.\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * > 0: The algorithm failed to compute a singular value while\n\ * working on the submatrix lying in rows and columns\n\ * INFO/(N+1) through MOD(INFO,N+1).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ming Gu and Ren-Cang Li, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhptrs0000644000175000017500000000466712502223526016557 0ustar uwabamiuwabami--- :name: zhptrs :md5sum: 6d68e7a4b40ea6491c12717a153266a3 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZHPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHPTRS solves a system of linear equations A*X = B with a complex\n\ * Hermitian matrix A stored in packed format using the factorization\n\ * A = U*D*U**H or A = L*D*L**H computed by ZHPTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**H;\n\ * = 'L': Lower triangular, form is A = L*D*L**H.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by ZHPTRF, stored as a\n\ * packed triangular matrix.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by ZHPTRF.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cpbstf0000644000175000017500000000775112502223525016502 0ustar uwabamiuwabami--- :name: cpbstf :md5sum: dd6e5004dfa546d7f8f70d62b37358f4 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: complex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPBSTF( UPLO, N, KD, AB, LDAB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPBSTF computes a split Cholesky factorization of a complex\n\ * Hermitian positive definite band matrix A.\n\ *\n\ * This routine is designed to be used in conjunction with CHBGST.\n\ *\n\ * The factorization has the form A = S**H*S where S is a band matrix\n\ * of the same bandwidth as A and the following structure:\n\ *\n\ * S = ( U )\n\ * ( M L )\n\ *\n\ * where U is upper triangular of order m = (n+kd)/2, and L is lower\n\ * triangular of order n-m.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) COMPLEX array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix A, stored in the first kd+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * On exit, if INFO = 0, the factor S from the split Cholesky\n\ * factorization A = S**H*S. See Further Details.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\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 factorization could not be completed,\n\ * because the updated element a(i,i) was negative; the\n\ * matrix A is not positive definite.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * N = 7, KD = 2:\n\ *\n\ * S = ( s11 s12 s13 )\n\ * ( s22 s23 s24 )\n\ * ( s33 s34 )\n\ * ( s44 )\n\ * ( s53 s54 s55 )\n\ * ( s64 s65 s66 )\n\ * ( s75 s76 s77 )\n\ *\n\ * If UPLO = 'U', the array AB holds:\n\ *\n\ * on entry: on exit:\n\ *\n\ * * * a13 a24 a35 a46 a57 * * s13 s24 s53' s64' s75'\n\ * * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54' s65' s76'\n\ * a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77\n\ *\n\ * If UPLO = 'L', the array AB holds:\n\ *\n\ * on entry: on exit:\n\ *\n\ * a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77\n\ * a21 a32 a43 a54 a65 a76 * s12' s23' s34' s54 s65 s76 *\n\ * a31 a42 a53 a64 a64 * * s13' s24' s53 s64 s75 * *\n\ *\n\ * Array elements marked * are not used by the routine; s12' denotes\n\ * conjg(s12); the diagonal elements of S are real.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slasq50000644000175000017500000000452512502223526016426 0ustar uwabamiuwabami--- :name: slasq5 :md5sum: a018da35dc7383c6ffddde2f88b68f5c :category: :subroutine :arguments: - i0: :type: integer :intent: input - n0: :type: integer :intent: input - z: :type: real :intent: input :dims: - 4*n0 - pp: :type: integer :intent: input - tau: :type: real :intent: input - dmin: :type: real :intent: output - dmin1: :type: real :intent: output - dmin2: :type: real :intent: output - dn: :type: real :intent: output - dnm1: :type: real :intent: output - dnm2: :type: real :intent: output - ieee: :type: logical :intent: input :substitutions: {} :fortran_help: " SUBROUTINE SLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, IEEE )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLASQ5 computes one dqds transform in ping-pong form, one\n\ * version for IEEE machines another for non IEEE machines.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * I0 (input) INTEGER\n\ * First index.\n\ *\n\ * N0 (input) INTEGER\n\ * Last index.\n\ *\n\ * Z (input) REAL array, dimension ( 4*N )\n\ * Z holds the qd array. EMIN is stored in Z(4*N0) to avoid\n\ * an extra argument.\n\ *\n\ * PP (input) INTEGER\n\ * PP=0 for ping, PP=1 for pong.\n\ *\n\ * TAU (input) REAL\n\ * This is the shift.\n\ *\n\ * DMIN (output) REAL\n\ * Minimum value of d.\n\ *\n\ * DMIN1 (output) REAL\n\ * Minimum value of d, excluding D( N0 ).\n\ *\n\ * DMIN2 (output) REAL\n\ * Minimum value of d, excluding D( N0 ) and D( N0-1 ).\n\ *\n\ * DN (output) REAL\n\ * d(N0), the last value of d.\n\ *\n\ * DNM1 (output) REAL\n\ * d(N0-1).\n\ *\n\ * DNM2 (output) REAL\n\ * d(N0-2).\n\ *\n\ * IEEE (input) LOGICAL\n\ * Flag for IEEE or non IEEE arithmetic.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Parameter ..\n REAL ZERO\n PARAMETER ( ZERO = 0.0E0 )\n\ * ..\n\ * .. Local Scalars ..\n INTEGER J4, J4P2\n REAL D, EMIN, TEMP\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dpbsv0000644000175000017500000001143212502223526016327 0ustar uwabamiuwabami--- :name: dpbsv :md5sum: a3c3e19a85e1eb645e99446b955890e8 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPBSV computes the solution to a real system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N symmetric positive definite band matrix and X\n\ * and B are N-by-NRHS matrices.\n\ *\n\ * The Cholesky decomposition is used to factor A as\n\ * A = U**T * U, if UPLO = 'U', or\n\ * A = L * L**T, if UPLO = 'L',\n\ * where U is an upper triangular band matrix, and L is a lower\n\ * triangular band matrix, with the same number of superdiagonals or\n\ * subdiagonals as A. The factored form of A is then used to solve the\n\ * system of equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).\n\ * See below for further details.\n\ *\n\ * On exit, if INFO = 0, the triangular factor U or L from the\n\ * Cholesky factorization A = U**T*U or A = L*L**T of the band\n\ * matrix A, in the same storage format as A.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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 leading minor of order i of A is not\n\ * positive definite, so the factorization could not be\n\ * completed, and the solution has not been computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * N = 6, KD = 2, and UPLO = 'U':\n\ *\n\ * On entry: On exit:\n\ *\n\ * * * a13 a24 a35 a46 * * u13 u24 u35 u46\n\ * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n\ * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n\ *\n\ * Similarly, if UPLO = 'L' the format of A is as follows:\n\ *\n\ * On entry: On exit:\n\ *\n\ * a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n\ * a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n\ * a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n\ *\n\ * Array elements marked * are not used by the routine.\n\ *\n\ * =====================================================================\n\ *\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DPBTRF, DPBTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/clanhe0000644000175000017500000000630712502223525016447 0ustar uwabamiuwabami--- :name: clanhe :md5sum: 35c5d3fb031ab7f142837a679fb0d090 :category: :function :type: real :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "MAX(1,(lsame_(&norm,\"I\")||lsame_(&norm,\"1\")||lsame_(&norm,\"o\")) ? n : 0)" :substitutions: {} :fortran_help: " REAL FUNCTION CLANHE( NORM, UPLO, N, A, LDA, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLANHE returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * complex hermitian matrix A.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * CLANHE returns the value\n\ *\n\ * CLANHE = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in CLANHE as described\n\ * above.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * hermitian matrix A is to be referenced.\n\ * = 'U': Upper triangular part of A is referenced\n\ * = 'L': Lower triangular part of A is referenced\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, CLANHE is\n\ * set to zero.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The hermitian matrix A. If UPLO = 'U', the leading n by n\n\ * upper triangular part of A contains the upper triangular part\n\ * of the matrix A, and the strictly lower triangular part of A\n\ * is not referenced. If UPLO = 'L', the leading n by n lower\n\ * triangular part of A contains the lower triangular part of\n\ * the matrix A, and the strictly upper triangular part of A is\n\ * not referenced. Note that the imaginary parts of the diagonal\n\ * elements need not be set and are assumed to be zero.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(N,1).\n\ *\n\ * WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n\ * WORK is not referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dposvx0000644000175000017500000002571412502223526016544 0ustar uwabamiuwabami--- :name: dposvx :md5sum: c2a250ab29628cdb18458b228833428f :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - equed: :type: char :intent: input/output - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE DPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPOSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to\n\ * compute the solution to a real system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N symmetric positive definite matrix and X and B\n\ * are N-by-NRHS matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', real scaling factors are computed to equilibrate\n\ * the system:\n\ * diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n\ *\n\ * 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n\ * factor the matrix A (after equilibration if FACT = 'E') as\n\ * A = U**T* U, if UPLO = 'U', or\n\ * A = L * L**T, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is a lower triangular\n\ * matrix.\n\ *\n\ * 3. If the leading i-by-i principal minor is not positive definite,\n\ * then the routine returns with INFO = i. Otherwise, the factored\n\ * form of A is used to estimate the condition number of the matrix\n\ * A. If the reciprocal of the condition number is less than machine\n\ * precision, INFO = N+1 is returned as a warning, but the routine\n\ * still goes on to solve for X and compute error bounds as\n\ * described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(S) so that it solves the original system before\n\ * equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AF contains the factored form of A.\n\ * If EQUED = 'Y', the matrix A has been equilibrated\n\ * with scaling factors given by S. A and AF will not\n\ * be modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AF and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A, except if FACT = 'F' and\n\ * EQUED = 'Y', then A must contain the equilibrated matrix\n\ * diag(S)*A*diag(S). If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced. A is not modified if\n\ * FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n\ *\n\ * On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n\ * diag(S)*A*diag(S).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N)\n\ * If FACT = 'F', then AF is an input argument and on entry\n\ * contains the triangular factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T, in the same storage\n\ * format as A. If EQUED .ne. 'N', then AF is the factored form\n\ * of the equilibrated matrix diag(S)*A*diag(S).\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T of the original\n\ * matrix A.\n\ *\n\ * If FACT = 'E', then AF is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T of the equilibrated\n\ * matrix A (see the description of A for the form of the\n\ * equilibrated matrix).\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'Y': Equilibration was done, i.e., A has been replaced by\n\ * diag(S) * A * diag(S).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * S (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The scale factors for A; not accessed if EQUED = 'N'. S is\n\ * an input argument if FACT = 'F'; otherwise, S is an output\n\ * argument. If FACT = 'F' and EQUED = 'Y', each element of S\n\ * must be positive.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n\ * B is overwritten by diag(S) * B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n\ * the original system of equations. Note that if EQUED = 'Y',\n\ * A and B are modified on exit, and the solution to the\n\ * equilibrated system is inv(diag(S))*X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A after equilibration (if done). If RCOND is less than the\n\ * machine precision (in particular, if RCOND = 0), the matrix\n\ * is singular to working precision. This condition is\n\ * indicated by a return code of INFO > 0.\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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, and i is\n\ * <= N: the leading minor of order i of A is\n\ * not positive definite, so the factorization\n\ * could not be completed, and the solution has not\n\ * been computed. RCOND = 0 is returned.\n\ * = N+1: U is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clarcm0000644000175000017500000000414312502223525016452 0ustar uwabamiuwabami--- :name: clarcm :md5sum: 1b2fff25bb662279ca1999d0a231aa4a :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - m - lda: :type: integer :intent: input - b: :type: complex :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: complex :intent: output :dims: - ldc - n - ldc: :type: integer :intent: input - rwork: :type: real :intent: workspace :dims: - 2*m*n :substitutions: ldc: MAX(1,m) :fortran_help: " SUBROUTINE CLARCM( M, N, A, LDA, B, LDB, C, LDC, RWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLARCM performs a very simple matrix-matrix multiplication:\n\ * C := A * B,\n\ * where A is M by M and real; B is M by N and complex;\n\ * C is M by N and complex.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A and of the matrix C.\n\ * M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns and rows of the matrix B and\n\ * the number of columns of the matrix C.\n\ * N >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA, M)\n\ * A contains the M by M matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >=max(1,M).\n\ *\n\ * B (input) REAL array, dimension (LDB, N)\n\ * B contains the M by N matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >=max(1,M).\n\ *\n\ * C (input) COMPLEX array, dimension (LDC, N)\n\ * C contains the M by N matrix C.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >=max(1,M).\n\ *\n\ * RWORK (workspace) REAL array, dimension (2*M*N)\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlasq30000644000175000017500000000663512502223526016411 0ustar uwabamiuwabami--- :name: dlasq3 :md5sum: 0e9fda6509d5400632d45ebec7f96a65 :category: :subroutine :arguments: - i0: :type: integer :intent: input - n0: :type: integer :intent: input/output - z: :type: doublereal :intent: input :dims: - 4*n0 - pp: :type: integer :intent: input/output - dmin: :type: doublereal :intent: output - sigma: :type: doublereal :intent: output - desig: :type: doublereal :intent: input/output - qmax: :type: doublereal :intent: input - nfail: :type: integer :intent: output - iter: :type: integer :intent: output - ndiv: :type: integer :intent: output - ieee: :type: logical :intent: input - ttype: :type: integer :intent: input/output - dmin1: :type: doublereal :intent: input/output - dmin2: :type: doublereal :intent: input/output - dn: :type: doublereal :intent: input/output - dn1: :type: doublereal :intent: input/output - dn2: :type: doublereal :intent: input/output - g: :type: doublereal :intent: input/output - tau: :type: doublereal :intent: input/output :substitutions: {} :fortran_help: " SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, DN2, G, TAU )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLASQ3 checks for deflation, computes a shift (TAU) and calls dqds.\n\ * In case of failure it changes shifts, and tries again until output\n\ * is positive.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * I0 (input) INTEGER\n\ * First index.\n\ *\n\ * N0 (input/output) INTEGER\n\ * Last index.\n\ *\n\ * Z (input) DOUBLE PRECISION array, dimension ( 4*N )\n\ * Z holds the qd array.\n\ *\n\ * PP (input/output) INTEGER\n\ * PP=0 for ping, PP=1 for pong.\n\ * PP=2 indicates that flipping was applied to the Z array \n\ * and that the initial tests for deflation should not be \n\ * performed.\n\ *\n\ * DMIN (output) DOUBLE PRECISION\n\ * Minimum value of d.\n\ *\n\ * SIGMA (output) DOUBLE PRECISION\n\ * Sum of shifts used in current segment.\n\ *\n\ * DESIG (input/output) DOUBLE PRECISION\n\ * Lower order part of SIGMA\n\ *\n\ * QMAX (input) DOUBLE PRECISION\n\ * Maximum value of q.\n\ *\n\ * NFAIL (output) INTEGER\n\ * Number of times shift was too big.\n\ *\n\ * ITER (output) INTEGER\n\ * Number of iterations.\n\ *\n\ * NDIV (output) INTEGER\n\ * Number of divisions.\n\ *\n\ * IEEE (input) LOGICAL\n\ * Flag for IEEE or non IEEE arithmetic (passed to DLASQ5).\n\ *\n\ * TTYPE (input/output) INTEGER\n\ * Shift type.\n\ *\n\ * DMIN1 (input/output) DOUBLE PRECISION\n\ *\n\ * DMIN2 (input/output) DOUBLE PRECISION\n\ *\n\ * DN (input/output) DOUBLE PRECISION\n\ *\n\ * DN1 (input/output) DOUBLE PRECISION\n\ *\n\ * DN2 (input/output) DOUBLE PRECISION\n\ *\n\ * G (input/output) DOUBLE PRECISION\n\ *\n\ * TAU (input/output) DOUBLE PRECISION\n\ *\n\ * These are passed as arguments in order to save their values\n\ * between calls to DLASQ3.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgebak0000644000175000017500000000543312502223526016451 0ustar uwabamiuwabami--- :name: sgebak :md5sum: b8fe3fccd7f265282dc765e8f8bfb770 :category: :subroutine :arguments: - job: :type: char :intent: input - side: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - scale: :type: real :intent: input :dims: - n - m: :type: integer :intent: input - v: :type: real :intent: input/output :dims: - ldv - m - ldv: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGEBAK forms the right or left eigenvectors of a real general matrix\n\ * by backward transformation on the computed eigenvectors of the\n\ * balanced matrix output by SGEBAL.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * Specifies the type of backward transformation required:\n\ * = 'N', do nothing, return immediately;\n\ * = 'P', do backward transformation for permutation only;\n\ * = 'S', do backward transformation for scaling only;\n\ * = 'B', do backward transformations for both permutation and\n\ * scaling.\n\ * JOB must be the same as the argument JOB supplied to SGEBAL.\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'R': V contains right eigenvectors;\n\ * = 'L': V contains left eigenvectors.\n\ *\n\ * N (input) INTEGER\n\ * The number of rows of the matrix V. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * The integers ILO and IHI determined by SGEBAL.\n\ * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n\ *\n\ * SCALE (input) REAL array, dimension (N)\n\ * Details of the permutation and scaling factors, as returned\n\ * by SGEBAL.\n\ *\n\ * M (input) INTEGER\n\ * The number of columns of the matrix V. M >= 0.\n\ *\n\ * V (input/output) REAL array, dimension (LDV,M)\n\ * On entry, the matrix of right or left eigenvectors to be\n\ * transformed, as returned by SHSEIN or STREVC.\n\ * On exit, V is overwritten by the transformed eigenvectors.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V. LDV >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dpttrf0000644000175000017500000000376412502223526016525 0ustar uwabamiuwabami--- :name: dpttrf :md5sum: 203e7bbfdbd7f2634ace2a157d4cb178 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPTTRF( N, D, E, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPTTRF computes the L*D*L' factorization of a real symmetric\n\ * positive definite tridiagonal matrix A. The factorization may also\n\ * be regarded as having the form A = U'*D*U.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the n diagonal elements of the tridiagonal matrix\n\ * A. On exit, the n diagonal elements of the diagonal matrix\n\ * D from the L*D*L' factorization of A.\n\ *\n\ * E (input/output) DOUBLE PRECISION array, dimension (N-1)\n\ * On entry, the (n-1) subdiagonal elements of the tridiagonal\n\ * matrix A. On exit, the (n-1) subdiagonal elements of the\n\ * unit bidiagonal factor L from the L*D*L' factorization of A.\n\ * E can also be regarded as the superdiagonal of the unit\n\ * bidiagonal factor U from the U'*D*U factorization of A.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ * > 0: if INFO = k, the leading minor of order k is not\n\ * positive definite; if k < N, the factorization could not\n\ * be completed, while if k = N, the factorization was\n\ * completed, but D(N) <= 0.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlaqp20000644000175000017500000000674612502223526016436 0ustar uwabamiuwabami--- :name: zlaqp2 :md5sum: 43aa720c87c5cf4c98fa3414b977cce5 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - offset: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: doublecomplex :intent: output :dims: - MIN(m,n) - vn1: :type: doublereal :intent: input/output :dims: - n - vn2: :type: doublereal :intent: input/output :dims: - n - work: :type: doublecomplex :intent: workspace :dims: - n :substitutions: {} :fortran_help: " SUBROUTINE ZLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAQP2 computes a QR factorization with column pivoting of\n\ * the block A(OFFSET+1:M,1:N).\n\ * The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\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\ * OFFSET (input) INTEGER\n\ * The number of rows of the matrix A that must be pivoted\n\ * but no factorized. OFFSET >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, the upper triangle of block A(OFFSET+1:M,1:N) is\n\ * the triangular factor obtained; the elements in block\n\ * A(OFFSET+1:M,1:N) below the diagonal, together with the\n\ * array TAU, represent the orthogonal matrix Q as a product of\n\ * elementary reflectors. Block A(1:OFFSET,1:N) has been\n\ * accordingly pivoted, but no factorized.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * JPVT (input/output) INTEGER array, dimension (N)\n\ * On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n\ * to the front of A*P (a leading column); if JPVT(i) = 0,\n\ * the i-th column of A is a free column.\n\ * On exit, if JPVT(i) = k, then the i-th column of A*P\n\ * was the k-th column of A.\n\ *\n\ * TAU (output) COMPLEX*16 array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors.\n\ *\n\ * VN1 (input/output) DOUBLE PRECISION array, dimension (N)\n\ * The vector with the partial column norms.\n\ *\n\ * VN2 (input/output) DOUBLE PRECISION array, dimension (N)\n\ * The vector with the exact column norms.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (N)\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n\ * X. Sun, Computer Science Dept., Duke University, USA\n\ *\n\ * Partial column norm updating strategy modified by\n\ * Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n\ * University of Zagreb, Croatia.\n\ * June 2010\n\ * For more details see LAPACK Working Note 176.\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zpbtrs0000644000175000017500000000612012502223526016533 0ustar uwabamiuwabami--- :name: zpbtrs :md5sum: 6cb711d6aca361e6d95f0a88051dda8c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPBTRS solves a system of linear equations A*X = B with a Hermitian\n\ * positive definite band matrix A using the Cholesky factorization\n\ * A = U**H*U or A = L*L**H computed by ZPBTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangular factor stored in AB;\n\ * = 'L': Lower triangular factor stored in AB.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AB (input) COMPLEX*16 array, dimension (LDAB,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**H*U or A = L*L**H of the band matrix A, stored in the\n\ * first KD+1 rows of the array. The j-th column of U or L is\n\ * stored in the j-th column of the array AB as follows:\n\ * if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL UPPER\n INTEGER J\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZTBSV\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sla_rpvgrw0000644000175000017500000000377312502223526017410 0ustar uwabamiuwabami--- :name: sla_rpvgrw :md5sum: ad9440dfdcfca1213188ee2e5876bf80 :category: :function :type: real :arguments: - n: :type: integer :intent: input - ncols: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input :substitutions: {} :fortran_help: " REAL FUNCTION SLA_RPVGRW( N, NCOLS, A, LDA, AF, LDAF )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLA_RPVGRW computes the reciprocal pivot growth factor\n\ * norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n\ * much less than 1, the stability of the LU factorization of the\n\ * (equilibrated) matrix A could be poor. This also means that the\n\ * solution X, estimated condition numbers, and error bounds could be\n\ * unreliable.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NCOLS (input) INTEGER\n\ * The number of columns of the matrix A. NCOLS >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) REAL array, dimension (LDAF,N)\n\ * The factors L and U from the factorization\n\ * A = P*L*U as computed by SGETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n REAL AMAX, UMAX, RPVGRW\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zgesvxx0000644000175000017500000005503712502223526016740 0ustar uwabamiuwabami--- :name: zgesvxx :md5sum: 355fccce5d4132b8483f562355057c26 :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - equed: :type: char :intent: input/output - r: :type: doublereal :intent: input/output :dims: - n - c: :type: doublereal :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - rpvgrw: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " SUBROUTINE ZGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGESVXX uses the LU factorization to compute the solution to a\n\ * complex*16 system of linear equations A * X = B, where A is an\n\ * N-by-N matrix and X and B are N-by-NRHS matrices.\n\ *\n\ * If requested, both normwise and maximum componentwise error bounds\n\ * are returned. ZGESVXX will return a solution with a tiny\n\ * guaranteed error (O(eps) where eps is the working machine\n\ * precision) unless the matrix is very ill-conditioned, in which\n\ * case a warning is returned. Relevant condition numbers also are\n\ * calculated and returned.\n\ *\n\ * ZGESVXX accepts user-provided factorizations and equilibration\n\ * factors; see the definitions of the FACT and EQUED options.\n\ * Solving with refinement and using a factorization from a previous\n\ * ZGESVXX call will also produce a solution with either O(eps)\n\ * errors or warnings, but we cannot make that claim for general\n\ * user-provided factorizations and equilibration factors if they\n\ * differ from what ZGESVXX would itself produce.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n\ * the system:\n\ *\n\ * TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n\ * TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n\ * TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n\ *\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n\ * or diag(C)*B (if TRANS = 'T' or 'C').\n\ *\n\ * 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n\ * the matrix A (after equilibration if FACT = 'E') as\n\ *\n\ * A = P * L * U,\n\ *\n\ * where P is a permutation matrix, L is a unit lower triangular\n\ * matrix, and U is upper triangular.\n\ *\n\ * 3. If some U(i,i)=0, so that U is exactly singular, then the\n\ * routine returns with INFO = i. Otherwise, the factored form of A\n\ * is used to estimate the condition number of the matrix A (see\n\ * argument RCOND). If the reciprocal of the condition number is less\n\ * than machine precision, the routine still goes on to solve for X\n\ * and compute error bounds as described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n\ * the routine will use iterative refinement to try to get a small\n\ * error and error bounds. Refinement calculates the residual to at\n\ * least twice the working precision.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n\ * that it solves the original system before equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AF and IPIV contain the factored form of A.\n\ * If EQUED is not 'N', the matrix A has been\n\ * equilibrated with scaling factors given by R and C.\n\ * A, AF, and IPIV are not modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AF and factored.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is\n\ * not 'N', then A must have been equilibrated by the scaling\n\ * factors in R and/or C. A is not modified if FACT = 'F' or\n\ * 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n\ *\n\ * On exit, if EQUED .ne. 'N', A is scaled as follows:\n\ * EQUED = 'R': A := diag(R) * A\n\ * EQUED = 'C': A := A * diag(C)\n\ * EQUED = 'B': A := diag(R) * A * diag(C).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input or output) COMPLEX*16 array, dimension (LDAF,N)\n\ * If FACT = 'F', then AF is an input argument and on entry\n\ * contains the factors L and U from the factorization\n\ * A = P*L*U as computed by ZGETRF. If EQUED .ne. 'N', then\n\ * AF is the factored form of the equilibrated matrix A.\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the factors L and U from the factorization A = P*L*U\n\ * of the original matrix A.\n\ *\n\ * If FACT = 'E', then AF is an output argument and on exit\n\ * returns the factors L and U from the factorization A = P*L*U\n\ * of the equilibrated matrix A (see the description of A for\n\ * the form of the equilibrated matrix).\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * as computed by ZGETRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * of the original matrix A.\n\ *\n\ * If FACT = 'E', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * of the equilibrated matrix A.\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * R (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'R' or 'B', A is\n\ * multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n\ * is not accessed. R is an input argument if FACT = 'F';\n\ * otherwise, R is an output argument. If FACT = 'F' and\n\ * EQUED = 'R' or 'B', each element of R must be positive.\n\ * If R is output, each element of R is a power of the radix.\n\ * If R is input, each element of R should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * C (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The column scale factors for A. If EQUED = 'C' or 'B', A is\n\ * multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n\ * is not accessed. C is an input argument if FACT = 'F';\n\ * otherwise, C is an output argument. If FACT = 'F' and\n\ * EQUED = 'C' or 'B', each element of C must be positive.\n\ * If C is output, each element of C is a power of the radix.\n\ * If C is input, each element of C should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit,\n\ * if EQUED = 'N', B is not modified;\n\ * if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n\ * diag(R)*B;\n\ * if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n\ * overwritten by diag(C)*B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * If INFO = 0, the N-by-NRHS solution matrix X to the original\n\ * system of equations. Note that A and B are modified on exit\n\ * if EQUED .ne. 'N', and the solution to the equilibrated system is\n\ * inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n\ * inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * RPVGRW (output) DOUBLE PRECISION\n\ * Reciprocal pivot growth. On exit, this contains the reciprocal\n\ * pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n\ * norm is used. If this is much less than 1, then the stability of\n\ * the LU factorization of the (equilibrated) matrix A could be poor.\n\ * This also means that the solution X, estimated condition numbers,\n\ * and error bounds could be unreliable. If factorization fails with\n\ * 0 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zppcon0000644000175000017500000000517512502223526016531 0ustar uwabamiuwabami--- :name: zppcon :md5sum: 0923e97bff798264005b11a3a98e98b6 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - ldap - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE ZPPCON( UPLO, N, AP, ANORM, RCOND, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPPCON estimates the reciprocal of the condition number (in the\n\ * 1-norm) of a complex Hermitian positive definite packed matrix using\n\ * the Cholesky factorization A = U**H*U or A = L*L**H computed by\n\ * ZPPTRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**H*U or A = L*L**H, packed columnwise in a linear\n\ * array. The j-th column of U or L is stored in the array AP\n\ * as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n\ *\n\ * ANORM (input) DOUBLE PRECISION\n\ * The 1-norm (or infinity-norm) of the Hermitian matrix A.\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n\ * estimate of the 1-norm of inv(A) computed in this routine.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctgsyl0000644000175000017500000002242012502223525016514 0ustar uwabamiuwabami--- :name: ctgsyl :md5sum: 353e93545b3d9d5928409ecbfb8864c2 :category: :subroutine :arguments: - trans: :type: char :intent: input - ijob: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - b: :type: complex :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - d: :type: complex :intent: input :dims: - ldd - m - ldd: :type: integer :intent: input - e: :type: complex :intent: input :dims: - lde - n - lde: :type: integer :intent: input - f: :type: complex :intent: input/output :dims: - ldf - n - ldf: :type: integer :intent: input - scale: :type: real :intent: output - dif: :type: real :intent: output - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "((ijob==1||ijob==2)&&lsame_(&trans,\"N\")) ? 2*m*n : 1" - iwork: :type: integer :intent: workspace :dims: - m+n+2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTGSYL solves the generalized Sylvester equation:\n\ *\n\ * A * R - L * B = scale * C (1)\n\ * D * R - L * E = scale * F\n\ *\n\ * where R and L are unknown m-by-n matrices, (A, D), (B, E) and\n\ * (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n,\n\ * respectively, with complex entries. A, B, D and E are upper\n\ * triangular (i.e., (A,D) and (B,E) in generalized Schur form).\n\ *\n\ * The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1\n\ * is an output scaling factor chosen to avoid overflow.\n\ *\n\ * In matrix notation (1) is equivalent to solve Zx = scale*b, where Z\n\ * is defined as\n\ *\n\ * Z = [ kron(In, A) -kron(B', Im) ] (2)\n\ * [ kron(In, D) -kron(E', Im) ],\n\ *\n\ * Here Ix is the identity matrix of size x and X' is the conjugate\n\ * transpose of X. Kron(X, Y) is the Kronecker product between the\n\ * matrices X and Y.\n\ *\n\ * If TRANS = 'C', y in the conjugate transposed system Z'*y = scale*b\n\ * is solved for, which is equivalent to solve for R and L in\n\ *\n\ * A' * R + D' * L = scale * C (3)\n\ * R * B' + L * E' = scale * -F\n\ *\n\ * This case (TRANS = 'C') is used to compute an one-norm-based estimate\n\ * of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D)\n\ * and (B,E), using CLACON.\n\ *\n\ * If IJOB >= 1, CTGSYL computes a Frobenius norm-based estimate of\n\ * Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the\n\ * reciprocal of the smallest singular value of Z.\n\ *\n\ * This is a level-3 BLAS algorithm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': solve the generalized sylvester equation (1).\n\ * = 'C': solve the \"conjugate transposed\" system (3).\n\ *\n\ * IJOB (input) INTEGER\n\ * Specifies what kind of functionality to be performed.\n\ * =0: solve (1) only.\n\ * =1: The functionality of 0 and 3.\n\ * =2: The functionality of 0 and 4.\n\ * =3: Only an estimate of Dif[(A,D), (B,E)] is computed.\n\ * (look ahead strategy is used).\n\ * =4: Only an estimate of Dif[(A,D), (B,E)] is computed.\n\ * (CGECON on sub-systems is used).\n\ * Not referenced if TRANS = 'C'.\n\ *\n\ * M (input) INTEGER\n\ * The order of the matrices A and D, and the row dimension of\n\ * the matrices C, F, R and L.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices B and E, and the column dimension\n\ * of the matrices C, F, R and L.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA, M)\n\ * The upper triangular matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1, M).\n\ *\n\ * B (input) COMPLEX array, dimension (LDB, N)\n\ * The upper triangular matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1, N).\n\ *\n\ * C (input/output) COMPLEX array, dimension (LDC, N)\n\ * On entry, C contains the right-hand-side of the first matrix\n\ * equation in (1) or (3).\n\ * On exit, if IJOB = 0, 1 or 2, C has been overwritten by\n\ * the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R,\n\ * the solution achieved during the computation of the\n\ * Dif-estimate.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1, M).\n\ *\n\ * D (input) COMPLEX array, dimension (LDD, M)\n\ * The upper triangular matrix D.\n\ *\n\ * LDD (input) INTEGER\n\ * The leading dimension of the array D. LDD >= max(1, M).\n\ *\n\ * E (input) COMPLEX array, dimension (LDE, N)\n\ * The upper triangular matrix E.\n\ *\n\ * LDE (input) INTEGER\n\ * The leading dimension of the array E. LDE >= max(1, N).\n\ *\n\ * F (input/output) COMPLEX array, dimension (LDF, N)\n\ * On entry, F contains the right-hand-side of the second matrix\n\ * equation in (1) or (3).\n\ * On exit, if IJOB = 0, 1 or 2, F has been overwritten by\n\ * the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L,\n\ * the solution achieved during the computation of the\n\ * Dif-estimate.\n\ *\n\ * LDF (input) INTEGER\n\ * The leading dimension of the array F. LDF >= max(1, M).\n\ *\n\ * DIF (output) REAL\n\ * On exit DIF is the reciprocal of a lower bound of the\n\ * reciprocal of the Dif-function, i.e. DIF is an upper bound of\n\ * Dif[(A,D), (B,E)] = sigma-min(Z), where Z as in (2).\n\ * IF IJOB = 0 or TRANS = 'C', DIF is not referenced.\n\ *\n\ * SCALE (output) REAL\n\ * On exit SCALE is the scaling factor in (1) or (3).\n\ * If 0 < SCALE < 1, C and F hold the solutions R and L, resp.,\n\ * to a slightly perturbed system but the input matrices A, B,\n\ * D and E have not been changed. If SCALE = 0, R and L will\n\ * hold the solutions to the homogenious system with C = F = 0.\n\ *\n\ * WORK (workspace/output) COMPLEX 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 > = 1.\n\ * If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N).\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\ * IWORK (workspace) INTEGER array, dimension (M+N+2)\n\ *\n\ * INFO (output) INTEGER\n\ * =0: successful exit\n\ * <0: If INFO = -i, the i-th argument had an illegal value.\n\ * >0: (A, D) and (B, E) have common or very close\n\ * eigenvalues.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n\ * for Solving the Generalized Sylvester Equation and Estimating the\n\ * Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n\ * Department of Computing Science, Umea University, S-901 87 Umea,\n\ * Sweden, December 1993, Revised April 1994, Also as LAPACK Working\n\ * Note 75. To appear in ACM Trans. on Math. Software, Vol 22,\n\ * No 1, 1996.\n\ *\n\ * [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester\n\ * Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal.\n\ * Appl., 15(4):1045-1060, 1994.\n\ *\n\ * [3] B. Kagstrom and L. Westin, Generalized Schur Methods with\n\ * Condition Estimators for Solving the Generalized Sylvester\n\ * Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7,\n\ * July 1989, pp 745-751.\n\ *\n\ * =====================================================================\n\ * Replaced various illegal calls to CCOPY by calls to CLASET.\n\ * Sven Hammarling, 1/5/02.\n\ *\n" ruby-lapack-1.7.2/dev/defs/cunbdb0000644000175000017500000002140612502223526016450 0ustar uwabamiuwabami--- :name: cunbdb :md5sum: f3d37f59c9a21d3cf112e287fa50b474 :category: :subroutine :arguments: - trans: :type: char :intent: input - signs: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - q: :type: integer :intent: input - x11: :type: complex :intent: input/output :dims: - ldx11 - q - ldx11: :type: integer :intent: input - x12: :type: complex :intent: input/output :dims: - ldx12 - m-q - ldx12: :type: integer :intent: input - x21: :type: complex :intent: input/output :dims: - ldx21 - q - ldx21: :type: integer :intent: input - x22: :type: complex :intent: input/output :dims: - ldx22 - m-q - ldx22: :type: integer :intent: input - theta: :type: real :intent: output :dims: - q - phi: :type: real :intent: output :dims: - q-1 - taup1: :type: complex :intent: output :dims: - p - taup2: :type: complex :intent: output :dims: - m-p - tauq1: :type: complex :intent: output :dims: - q - tauq2: :type: complex :intent: output :dims: - m-q - work: :type: complex :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m-q - info: :type: integer :intent: output :substitutions: p: ldx11 ldx12: p ldx21: p ldx22: p :fortran_help: " SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CUNBDB simultaneously bidiagonalizes the blocks of an M-by-M\n\ * partitioned unitary matrix X:\n\ *\n\ * [ B11 | B12 0 0 ]\n\ * [ X11 | X12 ] [ P1 | ] [ 0 | 0 -I 0 ] [ Q1 | ]**H\n\ * X = [-----------] = [---------] [----------------] [---------] .\n\ * [ X21 | X22 ] [ | P2 ] [ B21 | B22 0 0 ] [ | Q2 ]\n\ * [ 0 | 0 0 I ]\n\ *\n\ * X11 is P-by-Q. Q must be no larger than P, M-P, or M-Q. (If this is\n\ * not the case, then X must be transposed and/or permuted. This can be\n\ * done in constant time using the TRANS and SIGNS options. See CUNCSD\n\ * for details.)\n\ *\n\ * The unitary matrices P1, P2, Q1, and Q2 are P-by-P, (M-P)-by-\n\ * (M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. They are\n\ * represented implicitly by Householder vectors.\n\ *\n\ * B11, B12, B21, and B22 are Q-by-Q bidiagonal matrices represented\n\ * implicitly by angles THETA, PHI.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER\n\ * = 'T': X, U1, U2, V1T, and V2T are stored in row-major\n\ * order;\n\ * otherwise: X, U1, U2, V1T, and V2T are stored in column-\n\ * major order.\n\ *\n\ * SIGNS (input) CHARACTER\n\ * = 'O': The lower-left block is made nonpositive (the\n\ * \"other\" convention);\n\ * otherwise: The upper-right block is made nonpositive (the\n\ * \"default\" convention).\n\ *\n\ * M (input) INTEGER\n\ * The number of rows and columns in X.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows in X11 and X12. 0 <= P <= M.\n\ *\n\ * Q (input) INTEGER\n\ * The number of columns in X11 and X21. 0 <= Q <=\n\ * MIN(P,M-P,M-Q).\n\ *\n\ * X11 (input/output) COMPLEX array, dimension (LDX11,Q)\n\ * On entry, the top-left block of the unitary matrix to be\n\ * reduced. On exit, the form depends on TRANS:\n\ * If TRANS = 'N', then\n\ * the columns of tril(X11) specify reflectors for P1,\n\ * the rows of triu(X11,1) specify reflectors for Q1;\n\ * else TRANS = 'T', and\n\ * the rows of triu(X11) specify reflectors for P1,\n\ * the columns of tril(X11,-1) specify reflectors for Q1.\n\ *\n\ * LDX11 (input) INTEGER\n\ * The leading dimension of X11. If TRANS = 'N', then LDX11 >=\n\ * P; else LDX11 >= Q.\n\ *\n\ * X12 (input/output) CMPLX array, dimension (LDX12,M-Q)\n\ * On entry, the top-right block of the unitary matrix to\n\ * be reduced. On exit, the form depends on TRANS:\n\ * If TRANS = 'N', then\n\ * the rows of triu(X12) specify the first P reflectors for\n\ * Q2;\n\ * else TRANS = 'T', and\n\ * the columns of tril(X12) specify the first P reflectors\n\ * for Q2.\n\ *\n\ * LDX12 (input) INTEGER\n\ * The leading dimension of X12. If TRANS = 'N', then LDX12 >=\n\ * P; else LDX11 >= M-Q.\n\ *\n\ * X21 (input/output) COMPLEX array, dimension (LDX21,Q)\n\ * On entry, the bottom-left block of the unitary matrix to\n\ * be reduced. On exit, the form depends on TRANS:\n\ * If TRANS = 'N', then\n\ * the columns of tril(X21) specify reflectors for P2;\n\ * else TRANS = 'T', and\n\ * the rows of triu(X21) specify reflectors for P2.\n\ *\n\ * LDX21 (input) INTEGER\n\ * The leading dimension of X21. If TRANS = 'N', then LDX21 >=\n\ * M-P; else LDX21 >= Q.\n\ *\n\ * X22 (input/output) COMPLEX array, dimension (LDX22,M-Q)\n\ * On entry, the bottom-right block of the unitary matrix to\n\ * be reduced. On exit, the form depends on TRANS:\n\ * If TRANS = 'N', then\n\ * the rows of triu(X22(Q+1:M-P,P+1:M-Q)) specify the last\n\ * M-P-Q reflectors for Q2,\n\ * else TRANS = 'T', and\n\ * the columns of tril(X22(P+1:M-Q,Q+1:M-P)) specify the last\n\ * M-P-Q reflectors for P2.\n\ *\n\ * LDX22 (input) INTEGER\n\ * The leading dimension of X22. If TRANS = 'N', then LDX22 >=\n\ * M-P; else LDX22 >= M-Q.\n\ *\n\ * THETA (output) REAL array, dimension (Q)\n\ * The entries of the bidiagonal blocks B11, B12, B21, B22 can\n\ * be computed from the angles THETA and PHI. See Further\n\ * Details.\n\ *\n\ * PHI (output) REAL array, dimension (Q-1)\n\ * The entries of the bidiagonal blocks B11, B12, B21, B22 can\n\ * be computed from the angles THETA and PHI. See Further\n\ * Details.\n\ *\n\ * TAUP1 (output) COMPLEX array, dimension (P)\n\ * The scalar factors of the elementary reflectors that define\n\ * P1.\n\ *\n\ * TAUP2 (output) COMPLEX array, dimension (M-P)\n\ * The scalar factors of the elementary reflectors that define\n\ * P2.\n\ *\n\ * TAUQ1 (output) COMPLEX array, dimension (Q)\n\ * The scalar factors of the elementary reflectors that define\n\ * Q1.\n\ *\n\ * TAUQ2 (output) COMPLEX array, dimension (M-Q)\n\ * The scalar factors of the elementary reflectors that define\n\ * Q2.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (LWORK)\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK >= M-Q.\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 bidiagonal blocks B11, B12, B21, and B22 are represented\n\ * implicitly by angles THETA(1), ..., THETA(Q) and PHI(1), ...,\n\ * PHI(Q-1). B11 and B21 are upper bidiagonal, while B21 and B22 are\n\ * lower bidiagonal. Every entry in each bidiagonal band is a product\n\ * of a sine or cosine of a THETA with a sine or cosine of a PHI. See\n\ * [1] or CUNCSD for details.\n\ *\n\ * P1, P2, Q1, and Q2 are represented as products of elementary\n\ * reflectors. See CUNCSD for details on generating P1, P2, Q1, and Q2\n\ * using CUNGQR and CUNGLQ.\n\ *\n\ * Reference\n\ * =========\n\ *\n\ * [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.\n\ * Algorithms, 50(1):33-65, 2009.\n\ *\n\ * ====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgbtf20000644000175000017500000000743712502223526016421 0ustar uwabamiuwabami--- :name: zgbtf2 :md5sum: 1ccec6ac7bbb39a605e27108190f051d :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGBTF2 computes an LU factorization of a complex m-by-n band matrix\n\ * A using partial pivoting with row interchanges.\n\ *\n\ * This is the unblocked version of the algorithm, calling Level 2 BLAS.\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\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows KL+1 to\n\ * 2*KL+KU+1; rows 1 to KL of the array need not be set.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n\ *\n\ * On exit, details of the factorization: U is stored as an\n\ * upper triangular band matrix with KL+KU superdiagonals in\n\ * rows 1 to KL+KU+1, and the multipliers used during the\n\ * factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n\ * See below for further details.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= 2*KL+KU+1.\n\ *\n\ * IPIV (output) INTEGER array, dimension (min(M,N))\n\ * The pivot indices; for 1 <= i <= min(M,N), row i of the\n\ * matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, and division by zero will occur if it is used\n\ * to solve a system of equations.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * M = N = 6, KL = 2, KU = 1:\n\ *\n\ * On entry: On exit:\n\ *\n\ * * * * + + + * * * u14 u25 u36\n\ * * * + + + + * * u13 u24 u35 u46\n\ * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n\ * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n\ * a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *\n\ * a31 a42 a53 a64 * * m31 m42 m53 m64 * *\n\ *\n\ * Array elements marked * are not used by the routine; elements marked\n\ * + need not be set on entry, but are required by the routine to store\n\ * elements of U, because of fill-in resulting from the row\n\ * interchanges.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsygvd0000644000175000017500000001726512502223526016523 0ustar uwabamiuwabami--- :name: dsygvd :md5sum: 85e30d3588fe89d67bd116688747e0d2 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 2*n+1 : lsame_(&jobz,\"V\") ? 1+6*n+2*n*n : 1" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSYGVD computes all the eigenvalues, and optionally, the eigenvectors\n\ * of a real generalized symmetric-definite eigenproblem, of the form\n\ * A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n\ * B are assumed to be symmetric and B is also positive definite.\n\ * If eigenvectors are desired, it uses a divide and conquer algorithm.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * Specifies the problem type to be solved:\n\ * = 1: A*x = (lambda)*B*x\n\ * = 2: A*B*x = (lambda)*x\n\ * = 3: B*A*x = (lambda)*x\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of A contains the\n\ * upper triangular part of the matrix A. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of A contains\n\ * the lower triangular part of the matrix A.\n\ *\n\ * On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n\ * matrix Z of eigenvectors. The eigenvectors are normalized\n\ * as follows:\n\ * if ITYPE = 1 or 2, Z**T*B*Z = I;\n\ * if ITYPE = 3, Z**T*inv(B)*Z = I.\n\ * If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n\ * or the lower triangle (if UPLO='L') of A, including the\n\ * diagonal, is destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n\ * On entry, the symmetric matrix B. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of B contains the\n\ * upper triangular part of the matrix B. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of B contains\n\ * the lower triangular part of the matrix B.\n\ *\n\ * On exit, if INFO <= N, the part of B containing the matrix is\n\ * overwritten by the triangular factor U or L from the Cholesky\n\ * factorization B = U**T*U or B = L*L**T.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\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\ * If N <= 1, LWORK >= 1.\n\ * If JOBZ = 'N' and N > 1, LWORK >= 2*N+1.\n\ * If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the optimal sizes of the WORK and IWORK\n\ * arrays, returns these values as the first entries of the WORK\n\ * and IWORK arrays, and no error message related to LWORK or\n\ * LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK.\n\ * If N <= 1, LIWORK >= 1.\n\ * If JOBZ = 'N' and N > 1, LIWORK >= 1.\n\ * If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK and IWORK arrays, and no error message related to\n\ * LWORK or LIWORK 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: DPOTRF or DSYEVD returned an error code:\n\ * <= N: if INFO = i and JOBZ = 'N', then the algorithm\n\ * failed to converge; i off-diagonal elements of an\n\ * intermediate tridiagonal form did not converge to\n\ * zero;\n\ * if INFO = i and JOBZ = 'V', then the algorithm\n\ * failed to compute an eigenvalue while working on\n\ * the submatrix lying in rows and columns INFO/(N+1)\n\ * through mod(INFO,N+1);\n\ * > N: if INFO = N + i, for 1 <= i <= N, then the leading\n\ * minor of order i of B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n\ *\n\ * Modified so that no backsubstitution is performed if DSYEVD fails to\n\ * converge (NEIG in old code could be greater than N causing out of\n\ * bounds reference to A - reported by Ralf Meyer). Also corrected the\n\ * description of INFO and the test on ITYPE. Sven, 16 Feb 05.\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgerfs0000644000175000017500000001112212502223526016476 0ustar uwabamiuwabami--- :name: sgerfs :md5sum: bee46a94b59af9bfbc6a4ed911c55af1 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGERFS improves the computed solution to a system of linear\n\ * equations and provides error bounds and backward error estimates for\n\ * the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * The original N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) REAL array, dimension (LDAF,N)\n\ * The factors L and U from the factorization A = P*L*U\n\ * as computed by SGETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from SGETRF; for 1<=i<=N, row i of the\n\ * matrix was interchanged with row IPIV(i).\n\ *\n\ * B (input) REAL array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) REAL array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by SGETRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) REAL array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slasrt0000644000175000017500000000271712502223526016527 0ustar uwabamiuwabami--- :name: slasrt :md5sum: 15c8d51a595bb1c0feca7da2d1cd0147 :category: :subroutine :arguments: - id: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLASRT( ID, N, D, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Sort the numbers in D in increasing order (if ID = 'I') or\n\ * in decreasing order (if ID = 'D' ).\n\ *\n\ * Use Quick Sort, reverting to Insertion sort on arrays of\n\ * size <= 20. Dimension of STACK limits N to about 2**32.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ID (input) CHARACTER*1\n\ * = 'I': sort D in increasing order;\n\ * = 'D': sort D in decreasing order.\n\ *\n\ * N (input) INTEGER\n\ * The length of the array D.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the array to be sorted.\n\ * On exit, D has been sorted into increasing order\n\ * (D(1) <= ... <= D(N) ) or into decreasing order\n\ * (D(1) >= ... >= D(N) ), depending on ID.\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlar2v0000644000175000017500000000463312502223526016410 0ustar uwabamiuwabami--- :name: dlar2v :md5sum: 6fb47caf55cd693b64352d0bddea77e7 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - 1+(n-1)*incx - y: :type: doublereal :intent: input/output :dims: - 1+(n-1)*incx - z: :type: doublereal :intent: input/output :dims: - 1+(n-1)*incx - incx: :type: integer :intent: input - c: :type: doublereal :intent: input :dims: - 1+(n-1)*incc - s: :type: doublereal :intent: input :dims: - 1+(n-1)*incc - incc: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE DLAR2V( N, X, Y, Z, INCX, C, S, INCC )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAR2V applies a vector of real plane rotations from both sides to\n\ * a sequence of 2-by-2 real symmetric matrices, defined by the elements\n\ * of the vectors x, y and z. For i = 1,2,...,n\n\ *\n\ * ( x(i) z(i) ) := ( c(i) s(i) ) ( x(i) z(i) ) ( c(i) -s(i) )\n\ * ( z(i) y(i) ) ( -s(i) c(i) ) ( z(i) y(i) ) ( s(i) c(i) )\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of plane rotations to be applied.\n\ *\n\ * X (input/output) DOUBLE PRECISION array,\n\ * dimension (1+(N-1)*INCX)\n\ * The vector x.\n\ *\n\ * Y (input/output) DOUBLE PRECISION array,\n\ * dimension (1+(N-1)*INCX)\n\ * The vector y.\n\ *\n\ * Z (input/output) DOUBLE PRECISION array,\n\ * dimension (1+(N-1)*INCX)\n\ * The vector z.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between elements of X, Y and Z. INCX > 0.\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)\n\ * The cosines of the plane rotations.\n\ *\n\ * S (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)\n\ * The sines of the plane rotations.\n\ *\n\ * INCC (input) INTEGER\n\ * The increment between elements of C and S. INCC > 0.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, IC, IX\n DOUBLE PRECISION CI, SI, T1, T2, T3, T4, T5, T6, XI, YI, ZI\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dsysv0000644000175000017500000001300212502223526016354 0ustar uwabamiuwabami--- :name: dsysv :md5sum: ad88b5f290f6f6d3c3471e0ea1db7839 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSYSV computes the solution to a real system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n\ * matrices.\n\ *\n\ * The diagonal pivoting method is used to factor A as\n\ * A = U * D * U**T, if UPLO = 'U', or\n\ * A = L * D * L**T, if UPLO = 'L',\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, and D is symmetric and block diagonal with\n\ * 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then\n\ * used to solve the system of equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the block diagonal matrix D and the\n\ * multipliers used to obtain the factor U or L from the\n\ * factorization A = U*D*U**T or A = L*D*L**T as computed by\n\ * DSYTRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D, as\n\ * determined by DSYTRF. If IPIV(k) > 0, then rows and columns\n\ * k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n\ * diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n\ * then rows and columns k-1 and -IPIV(k) were interchanged and\n\ * D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n\ * IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n\ * -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n\ * diagonal block.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,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 length of WORK. LWORK >= 1, and for best performance\n\ * LWORK >= max(1,N*NB), where NB is the optimal blocksize for\n\ * DSYTRF.\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, D(i,i) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular, so the solution could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LWKOPT, NB\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DSYTRF, DSYTRS2, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slarz0000644000175000017500000000565712502223526016360 0ustar uwabamiuwabami--- :name: slarz :md5sum: 6000475d79cf0b1bd3de8df6c1d97c1f :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - l: :type: integer :intent: input - v: :type: real :intent: input :dims: - 1+(l-1)*abs(incv) - incv: :type: integer :intent: input - tau: :type: real :intent: input - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " SUBROUTINE SLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLARZ applies a real elementary reflector H to a real M-by-N\n\ * matrix C, from either the left or the right. H is represented in the\n\ * form\n\ *\n\ * H = I - tau * v * v'\n\ *\n\ * where tau is a real scalar and v is a real vector.\n\ *\n\ * If tau = 0, then H is taken to be the unit matrix.\n\ *\n\ *\n\ * H is a product of k elementary reflectors as returned by STZRZF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': form H * C\n\ * = 'R': form C * H\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C.\n\ *\n\ * L (input) INTEGER\n\ * The number of entries of the vector V containing\n\ * the meaningful part of the Householder vectors.\n\ * If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n\ *\n\ * V (input) REAL array, dimension (1+(L-1)*abs(INCV))\n\ * The vector v in the representation of H as returned by\n\ * STZRZF. V is not used if TAU = 0.\n\ *\n\ * INCV (input) INTEGER\n\ * The increment between elements of v. INCV <> 0.\n\ *\n\ * TAU (input) REAL\n\ * The value tau in the representation of H.\n\ *\n\ * C (input/output) REAL array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n\ * or C * H if SIDE = 'R'.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) REAL array, dimension\n\ * (N) if SIDE = 'L'\n\ * or (M) if SIDE = 'R'\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zpbtrf0000644000175000017500000000676312502223526016533 0ustar uwabamiuwabami--- :name: zpbtrf :md5sum: e08b91b667e36e9d1e0d906dfc043067 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPBTRF( UPLO, N, KD, AB, LDAB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPBTRF computes the Cholesky factorization of a complex Hermitian\n\ * positive definite band matrix A.\n\ *\n\ * The factorization has the form\n\ * A = U**H * U, if UPLO = 'U', or\n\ * A = L * L**H, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is lower triangular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * On exit, if INFO = 0, the triangular factor U or L from the\n\ * Cholesky factorization A = U**H*U or A = L*L**H of the band\n\ * matrix A, in the same storage format as A.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\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 leading minor of order i is not\n\ * positive definite, and the factorization could not be\n\ * completed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The band storage scheme is illustrated by the following example, when\n\ * N = 6, KD = 2, and UPLO = 'U':\n\ *\n\ * On entry: On exit:\n\ *\n\ * * * a13 a24 a35 a46 * * u13 u24 u35 u46\n\ * * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56\n\ * a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66\n\ *\n\ * Similarly, if UPLO = 'L' the format of A is as follows:\n\ *\n\ * On entry: On exit:\n\ *\n\ * a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66\n\ * a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *\n\ * a31 a42 a53 a64 * * l31 l42 l53 l64 * *\n\ *\n\ * Array elements marked * are not used by the routine.\n\ *\n\ * Contributed by\n\ * Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/claev20000644000175000017500000000467312502223525016375 0ustar uwabamiuwabami--- :name: claev2 :md5sum: c17a6c0ba6505716c01d705bebc81800 :category: :subroutine :arguments: - a: :type: complex :intent: input - b: :type: complex :intent: input - c: :type: complex :intent: input - rt1: :type: real :intent: output - rt2: :type: real :intent: output - cs1: :type: real :intent: output - sn1: :type: complex :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CLAEV2( A, B, C, RT1, RT2, CS1, SN1 )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAEV2 computes the eigendecomposition of a 2-by-2 Hermitian matrix\n\ * [ A B ]\n\ * [ CONJG(B) C ].\n\ * On return, RT1 is the eigenvalue of larger absolute value, RT2 is the\n\ * eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right\n\ * eigenvector for RT1, giving the decomposition\n\ *\n\ * [ CS1 CONJG(SN1) ] [ A B ] [ CS1 -CONJG(SN1) ] = [ RT1 0 ]\n\ * [-SN1 CS1 ] [ CONJG(B) C ] [ SN1 CS1 ] [ 0 RT2 ].\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * A (input) COMPLEX\n\ * The (1,1) element of the 2-by-2 matrix.\n\ *\n\ * B (input) COMPLEX\n\ * The (1,2) element and the conjugate of the (2,1) element of\n\ * the 2-by-2 matrix.\n\ *\n\ * C (input) COMPLEX\n\ * The (2,2) element of the 2-by-2 matrix.\n\ *\n\ * RT1 (output) REAL\n\ * The eigenvalue of larger absolute value.\n\ *\n\ * RT2 (output) REAL\n\ * The eigenvalue of smaller absolute value.\n\ *\n\ * CS1 (output) REAL\n\ * SN1 (output) COMPLEX\n\ * The vector (CS1, SN1) is a unit right eigenvector for RT1.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * RT1 is accurate to a few ulps barring over/underflow.\n\ *\n\ * RT2 may be inaccurate if there is massive cancellation in the\n\ * determinant A*C-B*B; higher precision or correctly rounded or\n\ * correctly truncated arithmetic would be needed to compute RT2\n\ * accurately in all cases.\n\ *\n\ * CS1 and SN1 are accurate to a few ulps barring over/underflow.\n\ *\n\ * Overflow is possible only if RT1 is within a factor of 5 of overflow.\n\ * Underflow is harmless if the input data is 0 or exceeds\n\ * underflow_threshold / macheps.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cporfsx0000644000175000017500000003662112502223525016703 0ustar uwabamiuwabami--- :name: cporfsx :md5sum: db2e61f6b964b4e653e41a1a3252fdb2 :category: :subroutine :arguments: - uplo: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - s: :type: real :intent: input/output :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " SUBROUTINE CPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPORFSX improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is symmetric positive\n\ * definite, and provides error bounds and backward error estimates\n\ * for the solution. In addition to normwise error bound, the code\n\ * provides maximum componentwise error bound if possible. See\n\ * comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n\ * error bounds.\n\ *\n\ * The original system of linear equations may have been equilibrated\n\ * before calling this routine, as described by arguments EQUED and S\n\ * below. In this case, the solution and error bounds returned are\n\ * for the original unequilibrated system.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * EQUED (input) CHARACTER*1\n\ * Specifies the form of equilibration that was done to A\n\ * before calling this routine. This is needed to compute\n\ * the solution and error bounds correctly.\n\ * = 'N': No equilibration\n\ * = 'Y': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(S) * A * diag(S).\n\ * The right hand side B has been changed accordingly.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular part\n\ * of the matrix A, and the strictly lower triangular part of A\n\ * is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of A contains the lower triangular part of\n\ * the matrix A, and the strictly upper triangular part of A is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX array, dimension (LDAF,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T, as computed by SPOTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * S (input or output) REAL array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'Y', A is multiplied on\n\ * the left and right by diag(S). S is an input argument if FACT =\n\ * 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n\ * = 'Y', each element of S must be positive. If S is output, each\n\ * element of S is a power of the radix. If S is input, each element\n\ * of S should be a power of the radix to ensure a reliable solution\n\ * and error estimates. Scaling by powers of the radix does not cause\n\ * rounding errors unless the result underflows or overflows.\n\ * Rounding errors during scaling lead to refining with a matrix that\n\ * is not equivalent to the input matrix, producing error estimates\n\ * that may not be reliable.\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) COMPLEX array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by SGETRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * Componentwise relative backward error. This is the\n\ * componentwise relative backward error of each solution vector X(j)\n\ * (i.e., the smallest relative change in any element of A or B that\n\ * makes X(j) an exact solution).\n\ *\n\ * N_ERR_BNDS (input) INTEGER\n\ * Number of error bounds to return for each right hand side\n\ * and each type (normwise or componentwise). See ERR_BNDS_NORM and\n\ * ERR_BNDS_COMP below.\n\ *\n\ * ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * NPARAMS (input) INTEGER\n\ * Specifies the number of parameters set in PARAMS. If .LE. 0, the\n\ * PARAMS array is never referenced and default values are used.\n\ *\n\ * PARAMS (input / output) REAL array, dimension NPARAMS\n\ * Specifies algorithm parameters. If an entry is .LT. 0.0, then\n\ * that entry will be filled with default value used for that\n\ * parameter. Only positions up to NPARAMS are accessed; defaults\n\ * are used for higher-numbered parameters.\n\ *\n\ * PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n\ * refinement or not.\n\ * Default: 1.0\n\ * = 0.0 : No refinement is performed, and no error bounds are\n\ * computed.\n\ * = 1.0 : Use the double-precision refinement algorithm,\n\ * possibly with doubled-single computations if the\n\ * compilation environment does not support DOUBLE\n\ * PRECISION.\n\ * (other values are reserved for future use)\n\ *\n\ * PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n\ * computations allowed for refinement.\n\ * Default: 10\n\ * Aggressive: Set to 100 to permit convergence using approximate\n\ * factorizations or factorizations other than LU. If\n\ * the factorization uses a technique other than\n\ * Gaussian elimination, the guarantees in\n\ * err_bnds_norm and err_bnds_comp may no longer be\n\ * trustworthy.\n\ *\n\ * PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n\ * will attempt to find a solution with small componentwise\n\ * relative error in the double-precision algorithm. Positive\n\ * is true, 0.0 is false.\n\ * Default: 1.0 (attempt componentwise convergence)\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (2*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit. The solution to every right-hand side is\n\ * guaranteed.\n\ * < 0: If INFO = -i, the i-th argument had an illegal value\n\ * > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slagv20000644000175000017500000000705512502223526016415 0ustar uwabamiuwabami--- :name: slagv2 :md5sum: 00d6ee2cee93c5623638b482ed41daa5 :category: :subroutine :arguments: - a: :type: real :intent: input/output :dims: - lda - "2" - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - "2" - ldb: :type: integer :intent: input - alphar: :type: real :intent: output :dims: - "2" - alphai: :type: real :intent: output :dims: - "2" - beta: :type: real :intent: output :dims: - "2" - csl: :type: real :intent: output - snl: :type: real :intent: output - csr: :type: real :intent: output - snr: :type: real :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, CSR, SNR )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAGV2 computes the Generalized Schur factorization of a real 2-by-2\n\ * matrix pencil (A,B) where B is upper triangular. This routine\n\ * computes orthogonal (rotation) matrices given by CSL, SNL and CSR,\n\ * SNR such that\n\ *\n\ * 1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0\n\ * types), then\n\ *\n\ * [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ]\n\ * [ 0 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ]\n\ *\n\ * [ b11 b12 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ]\n\ * [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ],\n\ *\n\ * 2) if the pencil (A,B) has a pair of complex conjugate eigenvalues,\n\ * then\n\ *\n\ * [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ]\n\ * [ a21 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ]\n\ *\n\ * [ b11 0 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ]\n\ * [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ]\n\ *\n\ * where b11 >= b22 > 0.\n\ *\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * A (input/output) REAL array, dimension (LDA, 2)\n\ * On entry, the 2 x 2 matrix A.\n\ * On exit, A is overwritten by the ``A-part'' of the\n\ * generalized Schur form.\n\ *\n\ * LDA (input) INTEGER\n\ * THe leading dimension of the array A. LDA >= 2.\n\ *\n\ * B (input/output) REAL array, dimension (LDB, 2)\n\ * On entry, the upper triangular 2 x 2 matrix B.\n\ * On exit, B is overwritten by the ``B-part'' of the\n\ * generalized Schur form.\n\ *\n\ * LDB (input) INTEGER\n\ * THe leading dimension of the array B. LDB >= 2.\n\ *\n\ * ALPHAR (output) REAL array, dimension (2)\n\ * ALPHAI (output) REAL array, dimension (2)\n\ * BETA (output) REAL array, dimension (2)\n\ * (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the\n\ * pencil (A,B), k=1,2, i = sqrt(-1). Note that BETA(k) may\n\ * be zero.\n\ *\n\ * CSL (output) REAL\n\ * The cosine of the left rotation matrix.\n\ *\n\ * SNL (output) REAL\n\ * The sine of the left rotation matrix.\n\ *\n\ * CSR (output) REAL\n\ * The cosine of the right rotation matrix.\n\ *\n\ * SNR (output) REAL\n\ * The sine of the right rotation matrix.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgebal0000644000175000017500000001037712502223525016434 0ustar uwabamiuwabami--- :name: cgebal :md5sum: 0465840854417f9abafe565179296d65 :category: :subroutine :arguments: - job: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - scale: :type: real :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGEBAL balances a general complex matrix A. This involves, first,\n\ * permuting A by a similarity transformation to isolate eigenvalues\n\ * in the first 1 to ILO-1 and last IHI+1 to N elements on the\n\ * diagonal; and second, applying a diagonal similarity transformation\n\ * to rows and columns ILO to IHI to make the rows and columns as\n\ * close in norm as possible. Both steps are optional.\n\ *\n\ * Balancing may reduce the 1-norm of the matrix, and improve the\n\ * accuracy of the computed eigenvalues and/or eigenvectors.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * Specifies the operations to be performed on A:\n\ * = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0\n\ * for i = 1,...,N;\n\ * = 'P': permute only;\n\ * = 'S': scale only;\n\ * = 'B': both permute and scale.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the input matrix A.\n\ * On exit, A is overwritten by the balanced matrix.\n\ * If JOB = 'N', A is not referenced.\n\ * See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * ILO (output) INTEGER\n\ * IHI (output) INTEGER\n\ * ILO and IHI are set to integers such that on exit\n\ * A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.\n\ * If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n\ *\n\ * SCALE (output) REAL array, dimension (N)\n\ * Details of the permutations and scaling factors applied to\n\ * A. If P(j) is the index of the row and column interchanged\n\ * with row and column j and D(j) is the scaling factor\n\ * applied to row and column j, then\n\ * SCALE(j) = P(j) for j = 1,...,ILO-1\n\ * = D(j) for j = ILO,...,IHI\n\ * = P(j) for j = IHI+1,...,N.\n\ * The order in which the interchanges are made is N to IHI+1,\n\ * then 1 to ILO-1.\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 permutations consist of row and column interchanges which put\n\ * the matrix in the form\n\ *\n\ * ( T1 X Y )\n\ * P A P = ( 0 B Z )\n\ * ( 0 0 T2 )\n\ *\n\ * where T1 and T2 are upper triangular matrices whose eigenvalues lie\n\ * along the diagonal. The column indices ILO and IHI mark the starting\n\ * and ending columns of the submatrix B. Balancing consists of applying\n\ * a diagonal similarity transformation inv(D) * B * D to make the\n\ * 1-norms of each row of B and its corresponding column nearly equal.\n\ * The output matrix is\n\ *\n\ * ( T1 X*D Y )\n\ * ( 0 inv(D)*B*D inv(D)*Z ).\n\ * ( 0 0 T2 )\n\ *\n\ * Information about the permutations P and the diagonal matrix D is\n\ * returned in the vector SCALE.\n\ *\n\ * This subroutine is based on the EISPACK routine CBAL.\n\ *\n\ * Modified by Tzu-Yi Chen, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlaein0000644000175000017500000001046712502223526016454 0ustar uwabamiuwabami--- :name: dlaein :md5sum: 8991c91a48bac18d81e2639cd6de073f :category: :subroutine :arguments: - rightv: :type: logical :intent: input - noinit: :type: logical :intent: input - n: :type: integer :intent: input - h: :type: doublereal :intent: input :dims: - ldh - n - ldh: :type: integer :intent: input - wr: :type: doublereal :intent: input - wi: :type: doublereal :intent: input - vr: :type: doublereal :intent: input/output :dims: - n - vi: :type: doublereal :intent: input/output :dims: - n - b: :type: doublereal :intent: workspace :dims: - ldb - n - ldb: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - n - eps3: :type: doublereal :intent: input - smlnum: :type: doublereal :intent: input - bignum: :type: doublereal :intent: input - info: :type: integer :intent: output :substitutions: ldb: n+1 :fortran_help: " SUBROUTINE DLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B, LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAEIN uses inverse iteration to find a right or left eigenvector\n\ * corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg\n\ * matrix H.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * RIGHTV (input) LOGICAL\n\ * = .TRUE. : compute right eigenvector;\n\ * = .FALSE.: compute left eigenvector.\n\ *\n\ * NOINIT (input) LOGICAL\n\ * = .TRUE. : no initial vector supplied in (VR,VI).\n\ * = .FALSE.: initial vector supplied in (VR,VI).\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H. N >= 0.\n\ *\n\ * H (input) DOUBLE PRECISION array, dimension (LDH,N)\n\ * The upper Hessenberg matrix H.\n\ *\n\ * LDH (input) INTEGER\n\ * The leading dimension of the array H. LDH >= max(1,N).\n\ *\n\ * WR (input) DOUBLE PRECISION\n\ * WI (input) DOUBLE PRECISION\n\ * The real and imaginary parts of the eigenvalue of H whose\n\ * corresponding right or left eigenvector is to be computed.\n\ *\n\ * VR (input/output) DOUBLE PRECISION array, dimension (N)\n\ * VI (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain\n\ * a real starting vector for inverse iteration using the real\n\ * eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI\n\ * must contain the real and imaginary parts of a complex\n\ * starting vector for inverse iteration using the complex\n\ * eigenvalue (WR,WI); otherwise VR and VI need not be set.\n\ * On exit, if WI = 0.0 (real eigenvalue), VR contains the\n\ * computed real eigenvector; if WI.ne.0.0 (complex eigenvalue),\n\ * VR and VI contain the real and imaginary parts of the\n\ * computed complex eigenvector. The eigenvector is normalized\n\ * so that the component of largest magnitude has magnitude 1;\n\ * here the magnitude of a complex number (x,y) is taken to be\n\ * |x| + |y|.\n\ * VI is not referenced if WI = 0.0.\n\ *\n\ * B (workspace) DOUBLE PRECISION array, dimension (LDB,N)\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= N+1.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * EPS3 (input) DOUBLE PRECISION\n\ * A small machine-dependent value which is used to perturb\n\ * close eigenvalues, and to replace zero pivots.\n\ *\n\ * SMLNUM (input) DOUBLE PRECISION\n\ * A machine-dependent value close to the underflow threshold.\n\ *\n\ * BIGNUM (input) DOUBLE PRECISION\n\ * A machine-dependent value close to the overflow threshold.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * = 1: inverse iteration did not converge; VR is set to the\n\ * last iterate, and so is VI if WI.ne.0.0.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clapmt0000644000175000017500000000401412502223525016466 0ustar uwabamiuwabami--- :name: clapmt :md5sum: 95fff3ce7e61182829396a0511c231f4 :category: :subroutine :arguments: - forwrd: :type: logical :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input - k: :type: integer :intent: input/output :dims: - n :substitutions: {} :fortran_help: " SUBROUTINE CLAPMT( FORWRD, M, N, X, LDX, K )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAPMT rearranges the columns of the M by N matrix X as specified\n\ * by the permutation K(1),K(2),...,K(N) of the integers 1,...,N.\n\ * If FORWRD = .TRUE., forward permutation:\n\ *\n\ * X(*,K(J)) is moved X(*,J) for J = 1,2,...,N.\n\ *\n\ * If FORWRD = .FALSE., backward permutation:\n\ *\n\ * X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FORWRD (input) LOGICAL\n\ * = .TRUE., forward permutation\n\ * = .FALSE., backward permutation\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix X. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix X. N >= 0.\n\ *\n\ * X (input/output) COMPLEX array, dimension (LDX,N)\n\ * On entry, the M by N matrix X.\n\ * On exit, X contains the permuted matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X, LDX >= MAX(1,M).\n\ *\n\ * K (input/output) INTEGER array, dimension (N)\n\ * On entry, K contains the permutation vector. K is used as\n\ * internal workspace, but reset to its original value on\n\ * output.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, II, J, IN\n COMPLEX TEMP\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zggsvd0000644000175000017500000002461712502223526016526 0ustar uwabamiuwabami--- :name: zggsvd :md5sum: 9dac70b38c11dc008b1cd1e000dc4156 :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobv: :type: char :intent: input - jobq: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - p: :type: integer :intent: input - k: :type: integer :intent: output - l: :type: integer :intent: output - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alpha: :type: doublereal :intent: output :dims: - n - beta: :type: doublereal :intent: output :dims: - n - u: :type: doublecomplex :intent: output :dims: - ldu - m - ldu: :type: integer :intent: input - v: :type: doublecomplex :intent: output :dims: - ldv - p - ldv: :type: integer :intent: input - q: :type: doublecomplex :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - MAX(3*n,m - p)+n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - iwork: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: m: lda p: ldb ldq: "lsame_(&jobq,\"Q\") ? MAX(1,n) : 1" ldu: "lsame_(&jobu,\"U\") ? MAX(1,m) : 1" ldv: "lsame_(&jobv,\"V\") ? MAX(1,p) : 1" :fortran_help: " SUBROUTINE ZGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, RWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGGSVD computes the generalized singular value decomposition (GSVD)\n\ * of an M-by-N complex matrix A and P-by-N complex matrix B:\n\ *\n\ * U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R )\n\ *\n\ * where U, V and Q are unitary matrices, and Z' means the conjugate\n\ * transpose of Z. Let K+L = the effective numerical rank of the\n\ * matrix (A',B')', then R is a (K+L)-by-(K+L) nonsingular upper\n\ * triangular matrix, D1 and D2 are M-by-(K+L) and P-by-(K+L) \"diagonal\"\n\ * matrices and of the following structures, respectively:\n\ *\n\ * If M-K-L >= 0,\n\ *\n\ * K L\n\ * D1 = K ( I 0 )\n\ * L ( 0 C )\n\ * M-K-L ( 0 0 )\n\ *\n\ * K L\n\ * D2 = L ( 0 S )\n\ * P-L ( 0 0 )\n\ *\n\ * N-K-L K L\n\ * ( 0 R ) = K ( 0 R11 R12 )\n\ * L ( 0 0 R22 )\n\ * where\n\ *\n\ * C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n\ * S = diag( BETA(K+1), ... , BETA(K+L) ),\n\ * C**2 + S**2 = I.\n\ *\n\ * R is stored in A(1:K+L,N-K-L+1:N) on exit.\n\ *\n\ * If M-K-L < 0,\n\ *\n\ * K M-K K+L-M\n\ * D1 = K ( I 0 0 )\n\ * M-K ( 0 C 0 )\n\ *\n\ * K M-K K+L-M\n\ * D2 = M-K ( 0 S 0 )\n\ * K+L-M ( 0 0 I )\n\ * P-L ( 0 0 0 )\n\ *\n\ * N-K-L K M-K K+L-M\n\ * ( 0 R ) = K ( 0 R11 R12 R13 )\n\ * M-K ( 0 0 R22 R23 )\n\ * K+L-M ( 0 0 0 R33 )\n\ *\n\ * where\n\ *\n\ * C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n\ * S = diag( BETA(K+1), ... , BETA(M) ),\n\ * C**2 + S**2 = I.\n\ *\n\ * (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored\n\ * ( 0 R22 R23 )\n\ * in B(M-K+1:L,N+M-K-L+1:N) on exit.\n\ *\n\ * The routine computes C, S, R, and optionally the unitary\n\ * transformation matrices U, V and Q.\n\ *\n\ * In particular, if B is an N-by-N nonsingular matrix, then the GSVD of\n\ * A and B implicitly gives the SVD of A*inv(B):\n\ * A*inv(B) = U*(D1*inv(D2))*V'.\n\ * If ( A',B')' has orthnormal columns, then the GSVD of A and B is also\n\ * equal to the CS decomposition of A and B. Furthermore, the GSVD can\n\ * be used to derive the solution of the eigenvalue problem:\n\ * A'*A x = lambda* B'*B x.\n\ * In some literature, the GSVD of A and B is presented in the form\n\ * U'*A*X = ( 0 D1 ), V'*B*X = ( 0 D2 )\n\ * where U and V are orthogonal and X is nonsingular, and D1 and D2 are\n\ * ``diagonal''. The former GSVD form can be converted to the latter\n\ * form by taking the nonsingular matrix X as\n\ *\n\ * X = Q*( I 0 )\n\ * ( 0 inv(R) )\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBU (input) CHARACTER*1\n\ * = 'U': Unitary matrix U is computed;\n\ * = 'N': U is not computed.\n\ *\n\ * JOBV (input) CHARACTER*1\n\ * = 'V': Unitary matrix V is computed;\n\ * = 'N': V is not computed.\n\ *\n\ * JOBQ (input) CHARACTER*1\n\ * = 'Q': Unitary matrix Q is computed;\n\ * = 'N': Q is not computed.\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 matrices A and B. N >= 0.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows of the matrix B. P >= 0.\n\ *\n\ * K (output) INTEGER\n\ * L (output) INTEGER\n\ * On exit, K and L specify the dimension of the subblocks\n\ * described in Purpose.\n\ * K + L = effective numerical rank of (A',B')'.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, A contains the triangular matrix R, or part of R.\n\ * See Purpose for details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,N)\n\ * On entry, the P-by-N matrix B.\n\ * On exit, B contains part of the triangular matrix R if\n\ * M-K-L < 0. See Purpose for details.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,P).\n\ *\n\ * ALPHA (output) DOUBLE PRECISION array, dimension (N)\n\ * BETA (output) DOUBLE PRECISION array, dimension (N)\n\ * On exit, ALPHA and BETA contain the generalized singular\n\ * value pairs of A and B;\n\ * ALPHA(1:K) = 1,\n\ * BETA(1:K) = 0,\n\ * and if M-K-L >= 0,\n\ * ALPHA(K+1:K+L) = C,\n\ * BETA(K+1:K+L) = S,\n\ * or if M-K-L < 0,\n\ * ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0\n\ * BETA(K+1:M) = S, BETA(M+1:K+L) = 1\n\ * and\n\ * ALPHA(K+L+1:N) = 0\n\ * BETA(K+L+1:N) = 0\n\ *\n\ * U (output) COMPLEX*16 array, dimension (LDU,M)\n\ * If JOBU = 'U', U contains the M-by-M unitary matrix U.\n\ * If JOBU = 'N', U is not referenced.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= max(1,M) if\n\ * JOBU = 'U'; LDU >= 1 otherwise.\n\ *\n\ * V (output) COMPLEX*16 array, dimension (LDV,P)\n\ * If JOBV = 'V', V contains the P-by-P unitary matrix V.\n\ * If JOBV = 'N', V is not referenced.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V. LDV >= max(1,P) if\n\ * JOBV = 'V'; LDV >= 1 otherwise.\n\ *\n\ * Q (output) COMPLEX*16 array, dimension (LDQ,N)\n\ * If JOBQ = 'Q', Q contains the N-by-N unitary matrix Q.\n\ * If JOBQ = 'N', Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N) if\n\ * JOBQ = 'Q'; LDQ >= 1 otherwise.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (max(3*N,M,P)+N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (N)\n\ * On exit, IWORK stores the sorting information. More\n\ * precisely, the following loop will sort ALPHA\n\ * for I = K+1, min(M,K+L)\n\ * swap ALPHA(I) and ALPHA(IWORK(I))\n\ * endfor\n\ * such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N).\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 = 1, the Jacobi-type procedure failed to\n\ * converge. For further details, see subroutine ZTGSJA.\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * TOLA DOUBLE PRECISION\n\ * TOLB DOUBLE PRECISION\n\ * TOLA and TOLB are the thresholds to determine the effective\n\ * rank of (A',B')'. Generally, they are set to\n\ * TOLA = MAX(M,N)*norm(A)*MAZHEPS,\n\ * TOLB = MAX(P,N)*norm(B)*MAZHEPS.\n\ * The size of TOLA and TOLB may affect the size of backward\n\ * errors of the decomposition.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * 2-96 Based on modifications by\n\ * Ming Gu and Huan Ren, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL WANTQ, WANTU, WANTV\n INTEGER I, IBND, ISUB, J, NCYCLE\n DOUBLE PRECISION ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n DOUBLE PRECISION DLAMCH, ZLANGE\n EXTERNAL LSAME, DLAMCH, ZLANGE\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DCOPY, XERBLA, ZGGSVP, ZTGSJA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/clatrz0000644000175000017500000000660312502223525016513 0ustar uwabamiuwabami--- :name: clatrz :md5sum: f96426c31ee39ce138c0da717ed0c0d5 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - m - work: :type: complex :intent: workspace :dims: - m :substitutions: m: lda :fortran_help: " SUBROUTINE CLATRZ( M, N, L, A, LDA, TAU, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLATRZ factors the M-by-(M+L) complex upper trapezoidal matrix\n\ * [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z by means\n\ * of unitary transformations, where Z is an (M+L)-by-(M+L) unitary\n\ * matrix and, R and A1 are M-by-M upper triangular matrices.\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\ * L (input) INTEGER\n\ * The number of columns of the matrix A containing the\n\ * meaningful part of the Householder vectors. N-M >= L >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the leading M-by-N upper trapezoidal part of the\n\ * array A must contain the matrix to be factorized.\n\ * On exit, the leading M-by-M upper triangular part of A\n\ * contains the upper triangular matrix R, and elements N-L+1 to\n\ * N of the first M rows of A, with the array TAU, represent the\n\ * unitary matrix Z as a product of M elementary reflectors.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (output) COMPLEX array, dimension (M)\n\ * The scalar factors of the elementary reflectors.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (M)\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * The factorization is obtained by Householder's method. The kth\n\ * transformation matrix, Z( k ), which is used to introduce zeros into\n\ * the ( m - k + 1 )th row of A, is given in the form\n\ *\n\ * Z( k ) = ( I 0 ),\n\ * ( 0 T( k ) )\n\ *\n\ * where\n\ *\n\ * T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n\ * ( 0 )\n\ * ( z( k ) )\n\ *\n\ * tau is a scalar and z( k ) is an l element vector. tau and z( k )\n\ * are chosen to annihilate the elements of the kth row of A2.\n\ *\n\ * The scalar tau is returned in the kth element of TAU and the vector\n\ * u( k ) in the kth row of A2, such that the elements of z( k ) are\n\ * in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in\n\ * the upper triangular part of A1.\n\ *\n\ * Z is given by\n\ *\n\ * Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cla_porcond_c0000644000175000017500000000641312502223525020000 0ustar uwabamiuwabami--- :name: cla_porcond_c :md5sum: f6e9460efbf813d2f7b6ca569b512d8e :category: :function :type: real :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - c: :type: real :intent: input :dims: - n - capply: :type: logical :intent: input - info: :type: integer :intent: output - work: :type: complex :intent: input :dims: - 2*n - rwork: :type: real :intent: input :dims: - n :substitutions: {} :fortran_help: " REAL FUNCTION CLA_PORCOND_C( UPLO, N, A, LDA, AF, LDAF, C, CAPPLY, INFO, WORK, RWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLA_PORCOND_C Computes the infinity norm condition number of\n\ * op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX array, dimension (LDAF,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T, as computed by CPOTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * C (input) REAL array, dimension (N)\n\ * The vector C in the formula op(A) * inv(diag(C)).\n\ *\n\ * CAPPLY (input) LOGICAL\n\ * If .TRUE. then access the vector C in the formula above.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * i > 0: The ith argument is invalid.\n\ *\n\ * WORK (input) COMPLEX array, dimension (2*N).\n\ * Workspace.\n\ *\n\ * RWORK (input) REAL array, dimension (N).\n\ * Workspace.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER KASE\n REAL AINVNM, ANORM, TMP\n INTEGER I, J\n LOGICAL UP\n COMPLEX ZDUM\n\ * ..\n\ * .. Local Arrays ..\n INTEGER ISAVE( 3 )\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CLACN2, CPOTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, REAL, AIMAG\n\ * ..\n\ * .. Statement Functions ..\n REAL CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlauu20000644000175000017500000000415012502223526016404 0ustar uwabamiuwabami--- :name: dlauu2 :md5sum: 4f0fa7e3d7bb575ad8296112c8ff7b7f :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLAUU2( UPLO, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAUU2 computes the product U * U' or L' * L, where the triangular\n\ * factor U or L is stored in the upper or lower triangular part of\n\ * the array A.\n\ *\n\ * If UPLO = 'U' or 'u' then the upper triangle of the result is stored,\n\ * overwriting the factor U in A.\n\ * If UPLO = 'L' or 'l' then the lower triangle of the result is stored,\n\ * overwriting the factor L in A.\n\ *\n\ * This is the unblocked form of the algorithm, calling Level 2 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the triangular factor stored in the array A\n\ * is upper or lower triangular:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the triangular factor U or L. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the triangular factor U or L.\n\ * On exit, if UPLO = 'U', the upper triangle of A is\n\ * overwritten with the upper triangle of the product U * U';\n\ * if UPLO = 'L', the lower triangle of A is overwritten with\n\ * the lower triangle of the product L' * L.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slapmr0000644000175000017500000000400312502223526016503 0ustar uwabamiuwabami--- :name: slapmr :md5sum: 7ad0891c9d98cf5770f6ad81a1132d63 :category: :subroutine :arguments: - forwrd: :type: logical :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - n - ldx: :type: integer :intent: input - k: :type: integer :intent: input/output :dims: - m :substitutions: {} :fortran_help: " SUBROUTINE SLAPMR( FORWRD, M, N, X, LDX, K )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAPMR rearranges the rows of the M by N matrix X as specified\n\ * by the permutation K(1),K(2),...,K(M) of the integers 1,...,M.\n\ * If FORWRD = .TRUE., forward permutation:\n\ *\n\ * X(K(I),*) is moved X(I,*) for I = 1,2,...,M.\n\ *\n\ * If FORWRD = .FALSE., backward permutation:\n\ *\n\ * X(I,*) is moved to X(K(I),*) for I = 1,2,...,M.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FORWRD (input) LOGICAL\n\ * = .TRUE., forward permutation\n\ * = .FALSE., backward permutation\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix X. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix X. N >= 0.\n\ *\n\ * X (input/output) REAL array, dimension (LDX,N)\n\ * On entry, the M by N matrix X.\n\ * On exit, X contains the permuted matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X, LDX >= MAX(1,M).\n\ *\n\ * K (input/output) INTEGER array, dimension (M)\n\ * On entry, K contains the permutation vector. K is used as\n\ * internal workspace, but reset to its original value on\n\ * output.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, IN, J, JJ\n REAL TEMP\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slarf0000644000175000017500000000473212502223526016325 0ustar uwabamiuwabami--- :name: slarf :md5sum: 7de47e1254ab712fc96ead026cb44b5f :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - v: :type: real :intent: input :dims: - 1 + (m-1)*abs(incv) - incv: :type: integer :intent: input - tau: :type: real :intent: input - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " SUBROUTINE SLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLARF applies a real elementary reflector H to a real m by n matrix\n\ * C, from either the left or the right. H is represented in the form\n\ *\n\ * H = I - tau * v * v'\n\ *\n\ * where tau is a real scalar and v is a real vector.\n\ *\n\ * If tau = 0, then H is taken to be the unit matrix.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': form H * C\n\ * = 'R': form C * H\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C.\n\ *\n\ * V (input) REAL array, dimension\n\ * (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n\ * or (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n\ * The vector v in the representation of H. V is not used if\n\ * TAU = 0.\n\ *\n\ * INCV (input) INTEGER\n\ * The increment between elements of v. INCV <> 0.\n\ *\n\ * TAU (input) REAL\n\ * The value tau in the representation of H.\n\ *\n\ * C (input/output) REAL array, dimension (LDC,N)\n\ * On entry, the m by n matrix C.\n\ * On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n\ * or C * H if SIDE = 'R'.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) REAL array, dimension\n\ * (N) if SIDE = 'L'\n\ * or (M) if SIDE = 'R'\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgeequb0000644000175000017500000000725012502223526016647 0ustar uwabamiuwabami--- :name: sgeequb :md5sum: 4d9d6bdf1c8036333710b2bc98ec4216 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - r: :type: real :intent: output :dims: - m - c: :type: real :intent: output :dims: - n - rowcnd: :type: real :intent: output - colcnd: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE SGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGEEQUB computes row and column scalings intended to equilibrate an\n\ * M-by-N matrix A and reduce its condition number. R returns the row\n\ * scale factors and C the column scale factors, chosen to try to make\n\ * the largest element in each row and column of the matrix B with\n\ * elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n\ * the radix.\n\ *\n\ * R(i) and C(j) are restricted to be a power of the radix between\n\ * SMLNUM = smallest safe number and BIGNUM = largest safe number. Use\n\ * of these scaling factors is not guaranteed to reduce the condition\n\ * number of A but works well in practice.\n\ *\n\ * This routine differs from SGEEQU by restricting the scaling factors\n\ * to a power of the radix. Baring over- and underflow, scaling by\n\ * these factors introduces no additional rounding errors. However, the\n\ * scaled entries' magnitured are no longer approximately 1 but lie\n\ * between sqrt(radix) and 1/sqrt(radix).\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) REAL array, dimension (LDA,N)\n\ * The M-by-N matrix whose equilibration factors are\n\ * to be computed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * R (output) REAL array, dimension (M)\n\ * If INFO = 0 or INFO > M, R contains the row scale factors\n\ * for A.\n\ *\n\ * C (output) REAL array, dimension (N)\n\ * If INFO = 0, C contains the column scale factors for A.\n\ *\n\ * ROWCND (output) REAL\n\ * If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n\ * smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n\ * AMAX is neither too large nor too small, it is not worth\n\ * scaling by R.\n\ *\n\ * COLCND (output) REAL\n\ * If INFO = 0, COLCND contains the ratio of the smallest\n\ * C(i) to the largest C(i). If COLCND >= 0.1, it is not\n\ * worth scaling by C.\n\ *\n\ * AMAX (output) REAL\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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, and i is\n\ * <= M: the i-th row of A is exactly zero\n\ * > M: the (i-M)-th column of A is exactly zero\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhbtrd0000644000175000017500000001013512502223526016505 0ustar uwabamiuwabami--- :name: zhbtrd :md5sum: b006b2fa43cf22296aff342b25156c72 :category: :subroutine :arguments: - vect: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - d: :type: doublereal :intent: output :dims: - n - e: :type: doublereal :intent: output :dims: - n-1 - q: :type: doublecomplex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZHBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHBTRD reduces a complex Hermitian band matrix A to real symmetric\n\ * tridiagonal form T by a unitary similarity transformation:\n\ * Q**H * A * Q = T.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * VECT (input) CHARACTER*1\n\ * = 'N': do not form Q;\n\ * = 'V': form Q;\n\ * = 'U': update a matrix X, by forming X*Q.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ * On exit, the diagonal elements of AB are overwritten by the\n\ * diagonal elements of the tridiagonal matrix T; if KD > 0, the\n\ * elements on the first superdiagonal (if UPLO = 'U') or the\n\ * first subdiagonal (if UPLO = 'L') are overwritten by the\n\ * off-diagonal elements of T; the rest of AB is overwritten by\n\ * values generated during the reduction.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * D (output) DOUBLE PRECISION array, dimension (N)\n\ * The diagonal elements of the tridiagonal matrix T.\n\ *\n\ * E (output) DOUBLE PRECISION array, dimension (N-1)\n\ * The off-diagonal elements of the tridiagonal matrix T:\n\ * E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.\n\ *\n\ * Q (input/output) COMPLEX*16 array, dimension (LDQ,N)\n\ * On entry, if VECT = 'U', then Q must contain an N-by-N\n\ * matrix X; if VECT = 'N' or 'V', then Q need not be set.\n\ *\n\ * On exit:\n\ * if VECT = 'V', Q contains the N-by-N unitary matrix Q;\n\ * if VECT = 'U', Q contains the product X*Q;\n\ * if VECT = 'N', the array Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q.\n\ * LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (N)\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\ * Modified by Linda Kaufman, Bell Labs.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsptrd0000644000175000017500000000774112502223526016521 0ustar uwabamiuwabami--- :name: dsptrd :md5sum: cf8f4de5c48cb0545e1cda0d8654c0d4 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - ldap - d: :type: doublereal :intent: output :dims: - n - e: :type: doublereal :intent: output :dims: - n-1 - tau: :type: doublereal :intent: output :dims: - n-1 - info: :type: integer :intent: output :substitutions: n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE DSPTRD( UPLO, N, AP, D, E, TAU, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSPTRD reduces a real symmetric matrix A stored in packed form to\n\ * symmetric tridiagonal form T by an orthogonal similarity\n\ * transformation: Q**T * A * Q = T.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ * On exit, if UPLO = 'U', the diagonal and first superdiagonal\n\ * of A are overwritten by the corresponding elements of the\n\ * tridiagonal matrix T, and the elements above the first\n\ * superdiagonal, with the array TAU, represent the orthogonal\n\ * matrix Q as a product of elementary reflectors; if UPLO\n\ * = 'L', the diagonal and first subdiagonal of A are over-\n\ * written by the corresponding elements of the tridiagonal\n\ * matrix T, and the elements below the first subdiagonal, with\n\ * the array TAU, represent the orthogonal matrix Q as a product\n\ * of elementary reflectors. See Further Details.\n\ *\n\ * D (output) DOUBLE PRECISION array, dimension (N)\n\ * The diagonal elements of the tridiagonal matrix T:\n\ * D(i) = A(i,i).\n\ *\n\ * E (output) DOUBLE PRECISION array, dimension (N-1)\n\ * The off-diagonal elements of the tridiagonal matrix T:\n\ * E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n\ *\n\ * TAU (output) DOUBLE PRECISION array, dimension (N-1)\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\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\ * If UPLO = 'U', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(n-1) . . . H(2) H(1).\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(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,\n\ * overwriting A(1:i-1,i+1), and tau is stored in TAU(i).\n\ *\n\ * If UPLO = 'L', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(n-1).\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) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,\n\ * overwriting A(i+2:n,i), and tau is stored in TAU(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/spotf20000644000175000017500000000470212502223526016430 0ustar uwabamiuwabami--- :name: spotf2 :md5sum: ff11b64a0a68b9efbd6f0735f97b2e3c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPOTF2( UPLO, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPOTF2 computes the Cholesky factorization of a real symmetric\n\ * positive definite matrix A.\n\ *\n\ * The factorization has the form\n\ * A = U' * U , if UPLO = 'U', or\n\ * A = L * L', if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is lower triangular.\n\ *\n\ * This is the unblocked version of the algorithm, calling Level 2 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * n by n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n by n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the factor U or L from the Cholesky\n\ * factorization A = U'*U or A = L*L'.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ * > 0: if INFO = k, the leading minor of order k is not\n\ * positive definite, and the factorization could not be\n\ * completed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssbgv0000644000175000017500000001254612502223526016344 0ustar uwabamiuwabami--- :name: ssbgv :md5sum: fc134831f389ed655ad11545afbcdfa8 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: real :intent: input/output :dims: - ldbb - n - ldbb: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? n : 1" :fortran_help: " SUBROUTINE SSBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSBGV computes all the eigenvalues, and optionally, the eigenvectors\n\ * of a real generalized symmetric-definite banded eigenproblem, of\n\ * the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric\n\ * and banded, and B is also positive definite.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * KA (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n\ *\n\ * KB (input) INTEGER\n\ * The number of superdiagonals of the matrix B if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n\ *\n\ * AB (input/output) REAL array, dimension (LDAB, N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first ka+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n\ *\n\ * On exit, the contents of AB are destroyed.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KA+1.\n\ *\n\ * BB (input/output) REAL array, dimension (LDBB, N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix B, stored in the first kb+1 rows of the array. The\n\ * j-th column of B is stored in the j-th column of the array BB\n\ * as follows:\n\ * if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n\ * if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n\ *\n\ * On exit, the factor S from the split Cholesky factorization\n\ * B = S**T*S, as returned by SPBSTF.\n\ *\n\ * LDBB (input) INTEGER\n\ * The leading dimension of the array BB. LDBB >= KB+1.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) REAL array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n\ * eigenvectors, with the i-th column of Z holding the\n\ * eigenvector associated with W(i). The eigenvectors are\n\ * normalized so that Z**T*B*Z = I.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= N.\n\ *\n\ * WORK (workspace) REAL array, dimension (3*N)\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, and i is:\n\ * <= N: the algorithm failed to converge:\n\ * i off-diagonal elements of an intermediate\n\ * tridiagonal form did not converge to zero;\n\ * > N: if INFO = N + i, for 1 <= i <= N, then SPBSTF\n\ * returned INFO = i: B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL UPPER, WANTZ\n CHARACTER VECT\n INTEGER IINFO, INDE, INDWRK\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SPBSTF, SSBGST, SSBTRD, SSTEQR, SSTERF, XERBLA\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dstedc0000644000175000017500000001511712502223526016463 0ustar uwabamiuwabami--- :name: dstedc :md5sum: 419d32b31946e69cbb224aebb04054f0 :category: :subroutine :arguments: - compz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - z: :type: doublereal :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(lsame_(&compz,\"N\")||n<=1) ? 1 : lsame_(&compz,\"V\") ? 1+3*n+2*n*LG(n)+3*n*n : lsame_(&compz,\"I\") ? 1+4*n+2*n*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "(lsame_(&compz,\"N\")||n<=1) ? 1 : lsame_(&compz,\"V\") ? 6+6*n+5*n*LG(n) : lsame_(&compz,\"I\") ? 3+5*n : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSTEDC computes all eigenvalues and, optionally, eigenvectors of a\n\ * symmetric tridiagonal matrix using the divide and conquer method.\n\ * The eigenvectors of a full or band real symmetric matrix can also be\n\ * found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this\n\ * matrix to tridiagonal form.\n\ *\n\ * This code makes very mild assumptions about floating point\n\ * arithmetic. It will work on machines with a guard digit in\n\ * add/subtract, or on those binary machines without guard digits\n\ * which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n\ * It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none. See DLAED3 for details.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * COMPZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only.\n\ * = 'I': Compute eigenvectors of tridiagonal matrix also.\n\ * = 'V': Compute eigenvectors of original dense symmetric\n\ * matrix also. On entry, Z contains the orthogonal\n\ * matrix used to reduce the original matrix to\n\ * tridiagonal form.\n\ *\n\ * N (input) INTEGER\n\ * The dimension of the symmetric tridiagonal matrix. N >= 0.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the diagonal elements of the tridiagonal matrix.\n\ * On exit, if INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * E (input/output) DOUBLE PRECISION array, dimension (N-1)\n\ * On entry, the subdiagonal elements of the tridiagonal matrix.\n\ * On exit, E has been destroyed.\n\ *\n\ * Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n\ * On entry, if COMPZ = 'V', then Z contains the orthogonal\n\ * matrix used in the reduction to tridiagonal form.\n\ * On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n\ * orthonormal eigenvectors of the original symmetric matrix,\n\ * and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n\ * of the symmetric tridiagonal matrix.\n\ * If COMPZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1.\n\ * If eigenvectors are desired, then LDZ >= max(1,N).\n\ *\n\ * WORK (workspace/output) DOUBLE PRECISION array,\n\ * dimension (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\ * If COMPZ = 'N' or N <= 1 then LWORK must be at least 1.\n\ * If COMPZ = 'V' and N > 1 then LWORK must be at least\n\ * ( 1 + 3*N + 2*N*lg N + 3*N**2 ),\n\ * where lg( N ) = smallest integer k such\n\ * that 2**k >= N.\n\ * If COMPZ = 'I' and N > 1 then LWORK must be at least\n\ * ( 1 + 4*N + N**2 ).\n\ * Note that for COMPZ = 'I' or 'V', then if N is less than or\n\ * equal to the minimum divide size, usually 25, then LWORK need\n\ * only be max(1,2*(N-1)).\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\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK.\n\ * If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1.\n\ * If COMPZ = 'V' and N > 1 then LIWORK must be at least\n\ * ( 6 + 6*N + 5*N*lg N ).\n\ * If COMPZ = 'I' and N > 1 then LIWORK must be at least\n\ * ( 3 + 5*N ).\n\ * Note that for COMPZ = 'I' or 'V', then if N is less than or\n\ * equal to the minimum divide size, usually 25, then LIWORK\n\ * need only be 1.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal size of the IWORK array,\n\ * returns this value as the first entry of the IWORK array, and\n\ * no error message related to LIWORK 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: The algorithm failed to compute an eigenvalue while\n\ * working on the submatrix lying in rows and columns\n\ * INFO/(N+1) through mod(INFO,N+1).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Jeff Rutter, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ * Modified by Francoise Tisseur, University of Tennessee.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgsvj00000644000175000017500000001704512502223526016414 0ustar uwabamiuwabami--- :name: dgsvj0 :md5sum: f57558f8638ae633075b0b7979c9eeed :category: :subroutine :arguments: - jobv: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - sva: :type: doublereal :intent: input/output :dims: - n - mv: :type: integer :intent: input - v: :type: doublereal :intent: input/output :dims: - ldv - n - ldv: :type: integer :intent: input - eps: :type: doublereal :intent: input - sfmin: :type: doublereal :intent: input - tol: :type: doublereal :intent: input - nsweep: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - lwork - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: lwork: m :fortran_help: " SUBROUTINE DGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGSVJ0 is called from DGESVJ as a pre-processor and that is its main\n\ * purpose. It applies Jacobi rotations in the same way as DGESVJ does, but\n\ * it does not check convergence (stopping criterion). Few tuning\n\ * parameters (marked by [TP]) are available for the implementer.\n\ *\n\ * Further Details\n\ * ~~~~~~~~~~~~~~~\n\ * DGSVJ0 is used just to enable SGESVJ to call a simplified version of\n\ * itself to work on a submatrix of the original matrix.\n\ *\n\ * Contributors\n\ * ~~~~~~~~~~~~\n\ * Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)\n\ *\n\ * Bugs, Examples and Comments\n\ * ~~~~~~~~~~~~~~~~~~~~~~~~~~~\n\ * Please report all bugs and send interesting test examples and comments to\n\ * drmac@math.hr. Thank you.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBV (input) CHARACTER*1\n\ * Specifies whether the output from this procedure is used\n\ * to compute the matrix V:\n\ * = 'V': the product of the Jacobi rotations is accumulated\n\ * by postmulyiplying the N-by-N array V.\n\ * (See the description of V.)\n\ * = 'A': the product of the Jacobi rotations is accumulated\n\ * by postmulyiplying the MV-by-N array V.\n\ * (See the descriptions of MV and V.)\n\ * = 'N': the Jacobi rotations are not accumulated.\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.\n\ * M >= N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, M-by-N matrix A, such that A*diag(D) represents\n\ * the input matrix.\n\ * On exit,\n\ * A_onexit * D_onexit represents the input matrix A*diag(D)\n\ * post-multiplied by a sequence of Jacobi rotations, where the\n\ * rotation threshold and the total number of sweeps are given in\n\ * TOL and NSWEEP, respectively.\n\ * (See the descriptions of D, TOL and NSWEEP.)\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * D (input/workspace/output) DOUBLE PRECISION array, dimension (N)\n\ * The array D accumulates the scaling factors from the fast scaled\n\ * Jacobi rotations.\n\ * On entry, A*diag(D) represents the input matrix.\n\ * On exit, A_onexit*diag(D_onexit) represents the input matrix\n\ * post-multiplied by a sequence of Jacobi rotations, where the\n\ * rotation threshold and the total number of sweeps are given in\n\ * TOL and NSWEEP, respectively.\n\ * (See the descriptions of A, TOL and NSWEEP.)\n\ *\n\ * SVA (input/workspace/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, SVA contains the Euclidean norms of the columns of\n\ * the matrix A*diag(D).\n\ * On exit, SVA contains the Euclidean norms of the columns of\n\ * the matrix onexit*diag(D_onexit).\n\ *\n\ * MV (input) INTEGER\n\ * If JOBV .EQ. 'A', then MV rows of V are post-multipled by a\n\ * sequence of Jacobi rotations.\n\ * If JOBV = 'N', then MV is not referenced.\n\ *\n\ * V (input/output) DOUBLE PRECISION array, dimension (LDV,N)\n\ * If JOBV .EQ. 'V' then N rows of V are post-multipled by a\n\ * sequence of Jacobi rotations.\n\ * If JOBV .EQ. 'A' then MV rows of V are post-multipled by a\n\ * sequence of Jacobi rotations.\n\ * If JOBV = 'N', then V is not referenced.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V, LDV >= 1.\n\ * If JOBV = 'V', LDV .GE. N.\n\ * If JOBV = 'A', LDV .GE. MV.\n\ *\n\ * EPS (input) DOUBLE PRECISION\n\ * EPS = DLAMCH('Epsilon')\n\ *\n\ * SFMIN (input) DOUBLE PRECISION\n\ * SFMIN = DLAMCH('Safe Minimum')\n\ *\n\ * TOL (input) DOUBLE PRECISION\n\ * TOL is the threshold for Jacobi rotations. For a pair\n\ * A(:,p), A(:,q) of pivot columns, the Jacobi rotation is\n\ * applied only if DABS(COS(angle(A(:,p),A(:,q)))) .GT. TOL.\n\ *\n\ * NSWEEP (input) INTEGER\n\ * NSWEEP is the number of sweeps of Jacobi rotations to be\n\ * performed.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)\n\ *\n\ * LWORK (input) INTEGER\n\ * LWORK is the dimension of WORK. LWORK .GE. M.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0 : successful exit.\n\ * < 0 : if INFO = -i, then the i-th argument had an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Parameters ..\n DOUBLE PRECISION ZERO, HALF, ONE, TWO\n PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0,\n + TWO = 2.0D0 )\n\ * ..\n\ * .. Local Scalars ..\n DOUBLE PRECISION AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,\n + BIGTHETA, CS, MXAAPQ, MXSINJ, ROOTBIG, ROOTEPS,\n + ROOTSFMIN, ROOTTOL, SMALL, SN, T, TEMP1, THETA,\n + THSIGN\n INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1,\n + ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, NBL,\n + NOTROT, p, PSKIPPED, q, ROWSKIP, SWBAND\n LOGICAL APPLV, ROTOK, RSVEC\n\ * ..\n\ * .. Local Arrays ..\n DOUBLE PRECISION FASTR( 5 )\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC DABS, DMAX1, DBLE, MIN0, DSIGN, DSQRT\n\ * ..\n\ * .. External Functions ..\n DOUBLE PRECISION DDOT, DNRM2\n INTEGER IDAMAX\n LOGICAL LSAME\n EXTERNAL IDAMAX, LSAME, DDOT, DNRM2\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DAXPY, DCOPY, DLASCL, DLASSQ, DROTM, DSWAP\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zpstf20000644000175000017500000000701712502223526016445 0ustar uwabamiuwabami--- :name: zpstf2 :md5sum: 44897d97885d7cb615a9081094c0d4f3 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - piv: :type: integer :intent: output :dims: - n - rank: :type: integer :intent: output - tol: :type: doublereal :intent: input - work: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPSTF2 computes the Cholesky factorization with complete\n\ * pivoting of a complex Hermitian positive semidefinite matrix A.\n\ *\n\ * The factorization has the form\n\ * P' * A * P = U' * U , if UPLO = 'U',\n\ * P' * A * P = L * L', if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is lower triangular, and\n\ * P is stored as vector PIV.\n\ *\n\ * This algorithm does not attempt to check that A is positive\n\ * semidefinite. This version of the algorithm calls level 2 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * n by n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n by n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the factor U or L from the Cholesky\n\ * factorization as above.\n\ *\n\ * PIV (output) INTEGER array, dimension (N)\n\ * PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n\ *\n\ * RANK (output) INTEGER\n\ * The rank of A given by the number of steps the algorithm\n\ * completed.\n\ *\n\ * TOL (input) DOUBLE PRECISION\n\ * User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) )\n\ * will be used. The algorithm terminates at the (K-1)st step\n\ * if the pivot <= TOL.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n\ * Work space.\n\ *\n\ * INFO (output) INTEGER\n\ * < 0: If INFO = -K, the K-th argument had an illegal value,\n\ * = 0: algorithm completed successfully, and\n\ * > 0: the matrix A is either rank deficient with computed rank\n\ * as returned in RANK, or is indefinite. See Section 7 of\n\ * LAPACK Working Note #161 for further information.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctrtri0000644000175000017500000000456712502223525016532 0ustar uwabamiuwabami--- :name: ctrtri :md5sum: fb01fa3296c8462888d1c442fee9ca77 :category: :subroutine :arguments: - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CTRTRI( UPLO, DIAG, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTRTRI computes the inverse of a complex upper or lower triangular\n\ * matrix A.\n\ *\n\ * This is the Level 3 BLAS version of the algorithm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the triangular matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of the array A contains\n\ * the upper triangular matrix, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of the array A contains\n\ * the lower triangular matrix, and the strictly upper\n\ * triangular part of A is not referenced. If DIAG = 'U', the\n\ * diagonal elements of A are also not referenced and are\n\ * assumed to be 1.\n\ * On exit, the (triangular) inverse of the original matrix, in\n\ * the same storage format.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\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, A(i,i) is exactly zero. The triangular\n\ * matrix is singular and its inverse can not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cunmhr0000644000175000017500000001222012502223526016501 0ustar uwabamiuwabami--- :name: cunmhr :md5sum: a0c17c73a1656100d77e0619a76540c4 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: complex :intent: input :dims: - m-1 - c: :type: complex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CUNMHR overwrites the general complex M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'C': Q**H * C C * Q**H\n\ *\n\ * where Q is a complex unitary matrix of order nq, with nq = m if\n\ * SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of\n\ * IHI-ILO elementary reflectors, as returned by CGEHRD:\n\ *\n\ * Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**H from the Left;\n\ * = 'R': apply Q or Q**H from the Right.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': apply Q (No transpose)\n\ * = 'C': apply Q**H (Conjugate transpose)\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * ILO and IHI must have the same values as in the previous call\n\ * of CGEHRD. Q is equal to the unit matrix except in the\n\ * submatrix Q(ilo+1:ihi,ilo+1:ihi).\n\ * If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and\n\ * ILO = 1 and IHI = 0, if M = 0;\n\ * if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and\n\ * ILO = 1 and IHI = 0, if N = 0.\n\ *\n\ * A (input) COMPLEX array, dimension\n\ * (LDA,M) if SIDE = 'L'\n\ * (LDA,N) if SIDE = 'R'\n\ * The vectors which define the elementary reflectors, as\n\ * returned by CGEHRD.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ * LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n\ *\n\ * TAU (input) COMPLEX array, dimension\n\ * (M-1) if SIDE = 'L'\n\ * (N-1) if SIDE = 'R'\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by CGEHRD.\n\ *\n\ * C (input/output) COMPLEX array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace/output) COMPLEX 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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M).\n\ * For optimum performance LWORK >= N*NB if SIDE = 'L', and\n\ * LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n\ * 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\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LEFT, LQUERY\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL ILAENV, LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CUNMQR, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zheevx0000644000175000017500000001776612502223526016542 0ustar uwabamiuwabami--- :name: zheevx :md5sum: 58d3330be7b1e45e72df64fff77eb075 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : 2*n" - rwork: :type: doublereal :intent: workspace :dims: - 7*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " SUBROUTINE ZHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHEEVX computes selected eigenvalues and, optionally, eigenvectors\n\ * of a complex Hermitian matrix A. Eigenvalues and eigenvectors can\n\ * be selected by specifying either a range of values or a range of\n\ * indices for the desired eigenvalues.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found.\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found.\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA, N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of A contains the\n\ * upper triangular part of the matrix A. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of A contains\n\ * the lower triangular part of the matrix A.\n\ * On exit, the lower triangle (if UPLO='L') or the upper\n\ * triangle (if UPLO='U') of A, including the diagonal, is\n\ * destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * VL (input) DOUBLE PRECISION\n\ * VU (input) DOUBLE PRECISION\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) DOUBLE PRECISION\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less than\n\ * or equal to zero, then EPS*|T| will be used in its place,\n\ * where |T| is the 1-norm of the tridiagonal matrix obtained\n\ * by reducing A to tridiagonal form.\n\ *\n\ * Eigenvalues will be computed most accurately when ABSTOL is\n\ * set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n\ * If this routine returns with INFO>0, indicating that some\n\ * eigenvectors did not converge, try setting ABSTOL to\n\ * 2*DLAMCH('S').\n\ *\n\ * See \"Computing Small Singular Values of Bidiagonal Matrices\n\ * with Guaranteed High Relative Accuracy,\" by Demmel and\n\ * Kahan, LAPACK Working Note #3.\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * On normal exit, the first M elements contain the selected\n\ * eigenvalues in ascending order.\n\ *\n\ * Z (output) COMPLEX*16 array, dimension (LDZ, max(1,M))\n\ * If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix A\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * If an eigenvector fails to converge, then that column of Z\n\ * contains the latest approximation to the eigenvector, and the\n\ * index of the eigenvector is returned in IFAIL.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of the array WORK. LWORK >= 1, when N <= 1;\n\ * otherwise 2*N.\n\ * For optimal efficiency, LWORK >= (NB+1)*N,\n\ * where NB is the max of the blocksize for ZHETRD and for\n\ * ZUNMTR as returned by ILAENV.\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\ * RWORK (workspace) DOUBLE PRECISION array, dimension (7*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (5*N)\n\ *\n\ * IFAIL (output) INTEGER array, dimension (N)\n\ * If JOBZ = 'V', then if INFO = 0, the first M elements of\n\ * IFAIL are zero. If INFO > 0, then IFAIL contains the\n\ * indices of the eigenvectors that failed to converge.\n\ * If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n\ * Their indices are stored in array IFAIL.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlahqr0000644000175000017500000001463312502223526016472 0ustar uwabamiuwabami--- :name: dlahqr :md5sum: a93986d5c9d574d1cd8150a2f4428399 :category: :subroutine :arguments: - wantt: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: doublereal :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - wr: :type: doublereal :intent: output :dims: - n - wi: :type: doublereal :intent: output :dims: - n - iloz: :type: integer :intent: input - ihiz: :type: integer :intent: input - z: :type: doublereal :intent: input/output :dims: - "wantz ? ldz : 0" - "wantz ? n : 0" - ldz: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILOZ, IHIZ, Z, LDZ, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAHQR is an auxiliary routine called by DHSEQR to update the\n\ * eigenvalues and Schur decomposition already computed by DHSEQR, by\n\ * dealing with the Hessenberg submatrix in rows and columns ILO to\n\ * IHI.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * WANTT (input) LOGICAL\n\ * = .TRUE. : the full Schur form T is required;\n\ * = .FALSE.: only eigenvalues are required.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * = .TRUE. : the matrix of Schur vectors Z is required;\n\ * = .FALSE.: Schur vectors are not required.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * It is assumed that H is already upper quasi-triangular in\n\ * rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless\n\ * ILO = 1). DLAHQR works primarily with the Hessenberg\n\ * submatrix in rows and columns ILO to IHI, but applies\n\ * transformations to all of H if WANTT is .TRUE..\n\ * 1 <= ILO <= max(1,IHI); IHI <= N.\n\ *\n\ * H (input/output) DOUBLE PRECISION array, dimension (LDH,N)\n\ * On entry, the upper Hessenberg matrix H.\n\ * On exit, if INFO is zero and if WANTT is .TRUE., H is upper\n\ * quasi-triangular in rows and columns ILO:IHI, with any\n\ * 2-by-2 diagonal blocks in standard form. If INFO is zero\n\ * and WANTT is .FALSE., the contents of H are unspecified on\n\ * exit. The output state of H if INFO is nonzero is given\n\ * below under the description of INFO.\n\ *\n\ * LDH (input) INTEGER\n\ * The leading dimension of the array H. LDH >= max(1,N).\n\ *\n\ * WR (output) DOUBLE PRECISION array, dimension (N)\n\ * WI (output) DOUBLE PRECISION array, dimension (N)\n\ * The real and imaginary parts, respectively, of the computed\n\ * eigenvalues ILO to IHI are stored in the corresponding\n\ * elements of WR and WI. If two eigenvalues are computed as a\n\ * complex conjugate pair, they are stored in consecutive\n\ * elements of WR and WI, say the i-th and (i+1)th, with\n\ * WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the\n\ * eigenvalues are stored in the same order as on the diagonal\n\ * of the Schur form returned in H, with WR(i) = H(i,i), and, if\n\ * H(i:i+1,i:i+1) is a 2-by-2 diagonal block,\n\ * WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i).\n\ *\n\ * ILOZ (input) INTEGER\n\ * IHIZ (input) INTEGER\n\ * Specify the rows of Z to which transformations must be\n\ * applied if WANTZ is .TRUE..\n\ * 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.\n\ *\n\ * Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n\ * If WANTZ is .TRUE., on entry Z must contain the current\n\ * matrix Z of transformations accumulated by DHSEQR, and on\n\ * exit Z has been updated; transformations are applied only to\n\ * the submatrix Z(ILOZ:IHIZ,ILO:IHI).\n\ * If WANTZ is .FALSE., Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * .GT. 0: If INFO = i, DLAHQR failed to compute all the\n\ * eigenvalues ILO to IHI in a total of 30 iterations\n\ * per eigenvalue; elements i+1:ihi of WR and WI\n\ * contain those eigenvalues which have been\n\ * successfully computed.\n\ *\n\ * If INFO .GT. 0 and WANTT is .FALSE., then on exit,\n\ * the remaining unconverged eigenvalues are the\n\ * eigenvalues of the upper Hessenberg matrix rows\n\ * and columns ILO thorugh INFO of the final, output\n\ * value of H.\n\ *\n\ * If INFO .GT. 0 and WANTT is .TRUE., then on exit\n\ * (*) (initial value of H)*U = U*(final value of H)\n\ * where U is an orthognal matrix. The final\n\ * value of H is upper Hessenberg and triangular in\n\ * rows and columns INFO+1 through IHI.\n\ *\n\ * If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n\ * (final value of Z) = (initial value of Z)*U\n\ * where U is the orthogonal matrix in (*)\n\ * (regardless of the value of WANTT.)\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * 02-96 Based on modifications by\n\ * David Day, Sandia National Laboratory, USA\n\ *\n\ * 12-04 Further modifications by\n\ * Ralph Byers, University of Kansas, USA\n\ * This is a modified version of DLAHQR from LAPACK version 3.0.\n\ * It is (1) more robust against overflow and underflow and\n\ * (2) adopts the more conservative Ahues & Tisseur stopping\n\ * criterion (LAWN 122, 1997).\n\ *\n\ * =========================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slaqge0000644000175000017500000000611512502223526016467 0ustar uwabamiuwabami--- :name: slaqge :md5sum: 93d81ef897fb1286b96cd6d41ebc4bef :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - r: :type: real :intent: input :dims: - m - c: :type: real :intent: input :dims: - n - rowcnd: :type: real :intent: input - colcnd: :type: real :intent: input - amax: :type: real :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAQGE equilibrates a general M by N matrix A using the row and\n\ * column scaling factors in the vectors R and C.\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) REAL array, dimension (LDA,N)\n\ * On entry, the M by N matrix A.\n\ * On exit, the equilibrated matrix. See EQUED for the form of\n\ * the equilibrated matrix.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(M,1).\n\ *\n\ * R (input) REAL array, dimension (M)\n\ * The row scale factors for A.\n\ *\n\ * C (input) REAL array, dimension (N)\n\ * The column scale factors for A.\n\ *\n\ * ROWCND (input) REAL\n\ * Ratio of the smallest R(i) to the largest R(i).\n\ *\n\ * COLCND (input) REAL\n\ * Ratio of the smallest C(i) to the largest C(i).\n\ *\n\ * AMAX (input) REAL\n\ * Absolute value of largest matrix entry.\n\ *\n\ * EQUED (output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * THRESH is a threshold value used to decide if row or column scaling\n\ * should be done based on the ratio of the row or column scaling\n\ * factors. If ROWCND < THRESH, row scaling is done, and if\n\ * COLCND < THRESH, column scaling is done.\n\ *\n\ * LARGE and SMALL are threshold values used to decide if row scaling\n\ * should be done based on the absolute size of the largest matrix\n\ * element. If AMAX > LARGE or AMAX < SMALL, row scaling is done.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlarfg0000644000175000017500000000364212502223526016454 0ustar uwabamiuwabami--- :name: dlarfg :md5sum: b49ee6b8b32b95df33c1bc8b264b644c :category: :subroutine :arguments: - n: :type: integer :intent: input - alpha: :type: doublereal :intent: input/output - x: :type: doublereal :intent: input/output :dims: - 1+(n-2)*abs(incx) - incx: :type: integer :intent: input - tau: :type: doublereal :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLARFG generates a real elementary reflector H of order n, such\n\ * that\n\ *\n\ * H * ( alpha ) = ( beta ), H' * H = I.\n\ * ( x ) ( 0 )\n\ *\n\ * where alpha and beta are scalars, and x is an (n-1)-element real\n\ * vector. H is represented in the form\n\ *\n\ * H = I - tau * ( 1 ) * ( 1 v' ) ,\n\ * ( v )\n\ *\n\ * where tau is a real scalar and v is a real (n-1)-element\n\ * vector.\n\ *\n\ * If the elements of x are all zero, then tau = 0 and H is taken to be\n\ * the unit matrix.\n\ *\n\ * Otherwise 1 <= tau <= 2.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the elementary reflector.\n\ *\n\ * ALPHA (input/output) DOUBLE PRECISION\n\ * On entry, the value alpha.\n\ * On exit, it is overwritten with the value beta.\n\ *\n\ * X (input/output) DOUBLE PRECISION array, dimension\n\ * (1+(N-2)*abs(INCX))\n\ * On entry, the vector x.\n\ * On exit, it is overwritten with the vector v.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between elements of X. INCX > 0.\n\ *\n\ * TAU (output) DOUBLE PRECISION\n\ * The value tau.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cla_syrcond_c0000644000175000017500000000673512502223525020024 0ustar uwabamiuwabami--- :name: cla_syrcond_c :md5sum: 3f35d193001e0256810e7243a7795ae5 :category: :function :type: real :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - c: :type: real :intent: input :dims: - n - capply: :type: logical :intent: input - info: :type: integer :intent: output - work: :type: complex :intent: input :dims: - 2*n - rwork: :type: real :intent: input :dims: - n :substitutions: {} :fortran_help: " REAL FUNCTION CLA_SYRCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLA_SYRCOND_C Computes the infinity norm condition number of\n\ * op(A) * inv(diag(C)) where C is a REAL vector.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX array, dimension (LDAF,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by CSYTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by CSYTRF.\n\ *\n\ * C (input) REAL array, dimension (N)\n\ * The vector C in the formula op(A) * inv(diag(C)).\n\ *\n\ * CAPPLY (input) LOGICAL\n\ * If .TRUE. then access the vector C in the formula above.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * i > 0: The ith argument is invalid.\n\ *\n\ * WORK (input) COMPLEX array, dimension (2*N).\n\ * Workspace.\n\ *\n\ * RWORK (input) REAL array, dimension (N).\n\ * Workspace.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER KASE\n REAL AINVNM, ANORM, TMP\n INTEGER I, J\n LOGICAL UP\n COMPLEX ZDUM\n\ * ..\n\ * .. Local Arrays ..\n INTEGER ISAVE( 3 )\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CLACN2, CSYTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n\ * ..\n\ * .. Statement Functions ..\n REAL CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dpotf20000644000175000017500000000472412502223526016415 0ustar uwabamiuwabami--- :name: dpotf2 :md5sum: a622d364e9e8716c0a7f1c5077370930 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPOTF2 computes the Cholesky factorization of a real symmetric\n\ * positive definite matrix A.\n\ *\n\ * The factorization has the form\n\ * A = U' * U , if UPLO = 'U', or\n\ * A = L * L', if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is lower triangular.\n\ *\n\ * This is the unblocked version of the algorithm, calling Level 2 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * n by n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n by n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the factor U or L from the Cholesky\n\ * factorization A = U'*U or A = L*L'.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ * > 0: if INFO = k, the leading minor of order k is not\n\ * positive definite, and the factorization could not be\n\ * completed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zla_hercond_c0000644000175000017500000000706012502223526020005 0ustar uwabamiuwabami--- :name: zla_hercond_c :md5sum: bbcd580ed7550b8d9f2ce9d894f56ec1 :category: :function :type: doublereal :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - c: :type: doublereal :intent: input :dims: - n - capply: :type: logical :intent: input - info: :type: integer :intent: output - work: :type: doublecomplex :intent: input :dims: - 2*n - rwork: :type: doublereal :intent: input :dims: - n :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION ZLA_HERCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLA_HERCOND_C computes the infinity norm condition number of\n\ * op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX*16 array, dimension (LDAF,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by ZHETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by CHETRF.\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension (N)\n\ * The vector C in the formula op(A) * inv(diag(C)).\n\ *\n\ * CAPPLY (input) LOGICAL\n\ * If .TRUE. then access the vector C in the formula above.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * i > 0: The ith argument is invalid.\n\ *\n\ * WORK (input) COMPLEX*16 array, dimension (2*N).\n\ * Workspace.\n\ *\n\ * RWORK (input) DOUBLE PRECISION array, dimension (N).\n\ * Workspace.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER KASE, I, J\n DOUBLE PRECISION AINVNM, ANORM, TMP\n LOGICAL UP\n COMPLEX*16 ZDUM\n\ * ..\n\ * .. Local Arrays ..\n INTEGER ISAVE( 3 )\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL ZLACN2, ZHETRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n\ * ..\n\ * .. Statement Functions ..\n DOUBLE PRECISION CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zunm2l0000644000175000017500000000732212502223526016443 0ustar uwabamiuwabami--- :name: zunm2l :md5sum: 29b20cea181e052fe946c78217df8872 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - k - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZUNM2L overwrites the general complex m-by-n matrix C with\n\ *\n\ * Q * C if SIDE = 'L' and TRANS = 'N', or\n\ *\n\ * Q'* C if SIDE = 'L' and TRANS = 'C', or\n\ *\n\ * C * Q if SIDE = 'R' and TRANS = 'N', or\n\ *\n\ * C * Q' if SIDE = 'R' and TRANS = 'C',\n\ *\n\ * where Q is a complex unitary matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(k) . . . H(2) H(1)\n\ *\n\ * as returned by ZGEQLF. Q is of order m if SIDE = 'L' and of order n\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q' from the Left\n\ * = 'R': apply Q or Q' from the Right\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': apply Q (No transpose)\n\ * = 'C': apply Q' (Conjugate transpose)\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,K)\n\ * The i-th column must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * ZGEQLF in the last k columns of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ * If SIDE = 'L', LDA >= max(1,M);\n\ * if SIDE = 'R', LDA >= max(1,N).\n\ *\n\ * TAU (input) COMPLEX*16 array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by ZGEQLF.\n\ *\n\ * C (input/output) COMPLEX*16 array, dimension (LDC,N)\n\ * On entry, the m-by-n matrix C.\n\ * On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension\n\ * (N) if SIDE = 'L',\n\ * (M) if SIDE = 'R'\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sbbcsd0000644000175000017500000002212212502223526016447 0ustar uwabamiuwabami--- :name: sbbcsd :md5sum: 654e0ef0681abf89337a04f3b1aad66f :category: :subroutine :arguments: - jobu1: :type: char :intent: input - jobu2: :type: char :intent: input - jobv1t: :type: char :intent: input - jobv2t: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - q: :type: integer :intent: input - theta: :type: real :intent: input/output :dims: - q - phi: :type: real :intent: input :dims: - q-1 - u1: :type: real :intent: input/output :dims: - ldu1 - p - ldu1: :type: integer :intent: input - u2: :type: real :intent: input/output :dims: - ldu2 - m-p - ldu2: :type: integer :intent: input - v1t: :type: real :intent: input/output :dims: - ldv1t - q - ldv1t: :type: integer :intent: input - v2t: :type: real :intent: input/output :dims: - ldv2t - m-q - ldv2t: :type: integer :intent: input - b11d: :type: real :intent: output :dims: - q - b11e: :type: real :intent: output :dims: - q-1 - b12d: :type: real :intent: output :dims: - q - b12e: :type: real :intent: output :dims: - q-1 - b21d: :type: real :intent: output :dims: - q - b21e: :type: real :intent: output :dims: - q-1 - b22d: :type: real :intent: output :dims: - q - b22e: :type: real :intent: output :dims: - q-1 - work: :type: real :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 8*q - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, THETA, PHI, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, B22D, B22E, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SBBCSD computes the CS decomposition of an orthogonal matrix in\n\ * bidiagonal-block form,\n\ *\n\ *\n\ * [ B11 | B12 0 0 ]\n\ * [ 0 | 0 -I 0 ]\n\ * X = [----------------]\n\ * [ B21 | B22 0 0 ]\n\ * [ 0 | 0 0 I ]\n\ *\n\ * [ C | -S 0 0 ]\n\ * [ U1 | ] [ 0 | 0 -I 0 ] [ V1 | ]**T\n\ * = [---------] [---------------] [---------] .\n\ * [ | U2 ] [ S | C 0 0 ] [ | V2 ]\n\ * [ 0 | 0 0 I ]\n\ *\n\ * X is M-by-M, its top-left block is P-by-Q, and Q must be no larger\n\ * than P, M-P, or M-Q. (If Q is not the smallest index, then X must be\n\ * transposed and/or permuted. This can be done in constant time using\n\ * the TRANS and SIGNS options. See SORCSD for details.)\n\ *\n\ * The bidiagonal matrices B11, B12, B21, and B22 are represented\n\ * implicitly by angles THETA(1:Q) and PHI(1:Q-1).\n\ *\n\ * The orthogonal matrices U1, U2, V1T, and V2T are input/output.\n\ * The input matrices are pre- or post-multiplied by the appropriate\n\ * singular vector matrices.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBU1 (input) CHARACTER\n\ * = 'Y': U1 is updated;\n\ * otherwise: U1 is not updated.\n\ *\n\ * JOBU2 (input) CHARACTER\n\ * = 'Y': U2 is updated;\n\ * otherwise: U2 is not updated.\n\ *\n\ * JOBV1T (input) CHARACTER\n\ * = 'Y': V1T is updated;\n\ * otherwise: V1T is not updated.\n\ *\n\ * JOBV2T (input) CHARACTER\n\ * = 'Y': V2T is updated;\n\ * otherwise: V2T is not updated.\n\ *\n\ * TRANS (input) CHARACTER\n\ * = 'T': X, U1, U2, V1T, and V2T are stored in row-major\n\ * order;\n\ * otherwise: X, U1, U2, V1T, and V2T are stored in column-\n\ * major order.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows and columns in X, the orthogonal matrix in\n\ * bidiagonal-block form.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows in the top-left block of X. 0 <= P <= M.\n\ *\n\ * Q (input) INTEGER\n\ * The number of columns in the top-left block of X.\n\ * 0 <= Q <= MIN(P,M-P,M-Q).\n\ *\n\ * THETA (input/output) REAL array, dimension (Q)\n\ * On entry, the angles THETA(1),...,THETA(Q) that, along with\n\ * PHI(1), ...,PHI(Q-1), define the matrix in bidiagonal-block\n\ * form. On exit, the angles whose cosines and sines define the\n\ * diagonal blocks in the CS decomposition.\n\ *\n\ * PHI (input/workspace) REAL array, dimension (Q-1)\n\ * The angles PHI(1),...,PHI(Q-1) that, along with THETA(1),...,\n\ * THETA(Q), define the matrix in bidiagonal-block form.\n\ *\n\ * U1 (input/output) REAL array, dimension (LDU1,P)\n\ * On entry, an LDU1-by-P matrix. On exit, U1 is postmultiplied\n\ * by the left singular vector matrix common to [ B11 ; 0 ] and\n\ * [ B12 0 0 ; 0 -I 0 0 ].\n\ *\n\ * LDU1 (input) INTEGER\n\ * The leading dimension of the array U1.\n\ *\n\ * U2 (input/output) REAL array, dimension (LDU2,M-P)\n\ * On entry, an LDU2-by-(M-P) matrix. On exit, U2 is\n\ * postmultiplied by the left singular vector matrix common to\n\ * [ B21 ; 0 ] and [ B22 0 0 ; 0 0 I ].\n\ *\n\ * LDU2 (input) INTEGER\n\ * The leading dimension of the array U2.\n\ *\n\ * V1T (input/output) REAL array, dimension (LDV1T,Q)\n\ * On entry, a LDV1T-by-Q matrix. On exit, V1T is premultiplied\n\ * by the transpose of the right singular vector\n\ * matrix common to [ B11 ; 0 ] and [ B21 ; 0 ].\n\ *\n\ * LDV1T (input) INTEGER\n\ * The leading dimension of the array V1T.\n\ *\n\ * V2T (input/output) REAL array, dimenison (LDV2T,M-Q)\n\ * On entry, a LDV2T-by-(M-Q) matrix. On exit, V2T is\n\ * premultiplied by the transpose of the right\n\ * singular vector matrix common to [ B12 0 0 ; 0 -I 0 ] and\n\ * [ B22 0 0 ; 0 0 I ].\n\ *\n\ * LDV2T (input) INTEGER\n\ * The leading dimension of the array V2T.\n\ *\n\ * B11D (output) REAL array, dimension (Q)\n\ * When SBBCSD converges, B11D contains the cosines of THETA(1),\n\ * ..., THETA(Q). If SBBCSD fails to converge, then B11D\n\ * contains the diagonal of the partially reduced top-left\n\ * block.\n\ *\n\ * B11E (output) REAL array, dimension (Q-1)\n\ * When SBBCSD converges, B11E contains zeros. If SBBCSD fails\n\ * to converge, then B11E contains the superdiagonal of the\n\ * partially reduced top-left block.\n\ *\n\ * B12D (output) REAL array, dimension (Q)\n\ * When SBBCSD converges, B12D contains the negative sines of\n\ * THETA(1), ..., THETA(Q). If SBBCSD fails to converge, then\n\ * B12D contains the diagonal of the partially reduced top-right\n\ * block.\n\ *\n\ * B12E (output) REAL array, dimension (Q-1)\n\ * When SBBCSD converges, B12E contains zeros. If SBBCSD fails\n\ * to converge, then B12E contains the subdiagonal of the\n\ * partially reduced top-right block.\n\ *\n\ * WORK (workspace) REAL 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,8*Q).\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal size of the WORK array,\n\ * returns this value as the first entry of the work array, and\n\ * no error 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 SBBCSD did not converge, INFO specifies the number\n\ * of nonzero entries in PHI, and B11D, B11E, etc.,\n\ * contain the partially reduced matrix.\n\ *\n\ * Reference\n\ * =========\n\ *\n\ * [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.\n\ * Algorithms, 50(1):33-65, 2009.\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * TOLMUL REAL, default = MAX(10,MIN(100,EPS**(-1/8)))\n\ * TOLMUL controls the convergence criterion of the QR loop.\n\ * Angles THETA(i), PHI(i) are rounded to 0 or PI/2 when they\n\ * are within TOLMUL*EPS of either bound.\n\ *\n\n\ * ===================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cla_herfsx_extended0000644000175000017500000003472312502223525021216 0ustar uwabamiuwabami--- :name: cla_herfsx_extended :md5sum: ec85b6e9843f94e54689deb25b562e34 :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - colequ: :type: logical :intent: input - c: :type: real :intent: input :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: complex :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: real :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - err_bnds_norm: :type: real :intent: input/output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: input/output :dims: - nrhs - n_err_bnds - res: :type: complex :intent: input :dims: - n - ayb: :type: real :intent: input :dims: - n - dy: :type: complex :intent: input :dims: - n - y_tail: :type: complex :intent: input :dims: - n - rcond: :type: real :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: real :intent: input - dz_ub: :type: real :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CLA_HERFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLA_HERFSX_EXTENDED improves the computed solution to a system of\n\ * linear equations by performing extra-precise iterative refinement\n\ * and provides error bounds and backward error estimates for the solution.\n\ * This subroutine is called by CHERFSX to perform iterative refinement.\n\ * In addition to normwise error bound, the code provides maximum\n\ * componentwise error bound if possible. See comments for ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP for details of the error bounds. Note that this\n\ * subroutine is only resonsible for setting the second fields of\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * PREC_TYPE (input) INTEGER\n\ * Specifies the intermediate precision to be used in refinement.\n\ * The value is defined by ILAPREC(P) where P is a CHARACTER and\n\ * P = 'S': Single\n\ * = 'D': Double\n\ * = 'I': Indigenous\n\ * = 'X', 'E': Extra\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right-hand-sides, i.e., the number of columns of the\n\ * matrix B.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX array, dimension (LDAF,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by CHETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by CHETRF.\n\ *\n\ * COLEQU (input) LOGICAL\n\ * If .TRUE. then column equilibration was done to A before calling\n\ * this routine. This is needed to compute the solution and error\n\ * bounds correctly.\n\ *\n\ * C (input) REAL array, dimension (N)\n\ * The column scale factors for A. If COLEQU = .FALSE., C\n\ * is not accessed. If C is input, each element of C should be a power\n\ * of the radix to ensure a reliable solution and error estimates.\n\ * Scaling by powers of the radix does not cause rounding errors unless\n\ * the result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,NRHS)\n\ * The right-hand-side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * Y (input/output) COMPLEX array, dimension\n\ * (LDY,NRHS)\n\ * On entry, the solution matrix X, as computed by CHETRS.\n\ * On exit, the improved solution matrix Y.\n\ *\n\ * LDY (input) INTEGER\n\ * The leading dimension of the array Y. LDY >= max(1,N).\n\ *\n\ * BERR_OUT (output) REAL array, dimension (NRHS)\n\ * On exit, BERR_OUT(j) contains the componentwise relative backward\n\ * error for right-hand-side j from the formula\n\ * max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n\ * where abs(Z) is the componentwise absolute value of the matrix\n\ * or vector Z. This is computed by CLA_LIN_BERR.\n\ *\n\ * N_NORMS (input) INTEGER\n\ * Determines which error bounds to return (see ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP).\n\ * If N_NORMS >= 1 return normwise error bounds.\n\ * If N_NORMS >= 2 return componentwise error bounds.\n\ *\n\ * ERR_BNDS_NORM (input/output) REAL array, dimension\n\ * (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (input/output) REAL array, dimension\n\ * (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * RES (input) COMPLEX array, dimension (N)\n\ * Workspace to hold the intermediate residual.\n\ *\n\ * AYB (input) REAL array, dimension (N)\n\ * Workspace.\n\ *\n\ * DY (input) COMPLEX array, dimension (N)\n\ * Workspace to hold the intermediate solution.\n\ *\n\ * Y_TAIL (input) COMPLEX array, dimension (N)\n\ * Workspace to hold the trailing bits of the intermediate solution.\n\ *\n\ * RCOND (input) REAL\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * ITHRESH (input) INTEGER\n\ * The maximum number of residual computations allowed for\n\ * refinement. The default is 10. For 'aggressive' set to 100 to\n\ * permit convergence using approximate factorizations or\n\ * factorizations other than LU. If the factorization uses a\n\ * technique other than Gaussian elimination, the guarantees in\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n\ *\n\ * RTHRESH (input) REAL\n\ * Determines when to stop refinement if the error estimate stops\n\ * decreasing. Refinement will stop when the next solution no longer\n\ * satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n\ * the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n\ * default value is 0.5. For 'aggressive' set to 0.9 to permit\n\ * convergence on extremely ill-conditioned matrices. See LAWN 165\n\ * for more details.\n\ *\n\ * DZ_UB (input) REAL\n\ * Determines when to start considering componentwise convergence.\n\ * Componentwise convergence is only considered after each component\n\ * of the solution Y is stable, which we definte as the relative\n\ * change in each component being less than DZ_UB. The default value\n\ * is 0.25, requiring the first bit to be stable. See LAWN 165 for\n\ * more details.\n\ *\n\ * IGNORE_CWISE (input) LOGICAL\n\ * If .TRUE. then ignore componentwise convergence. Default value\n\ * is .FALSE..\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * < 0: if INFO = -i, the ith argument to CHETRS had an illegal\n\ * value\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE,\n $ Y_PREC_STATE\n REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n COMPLEX ZDUM\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sgerfsx0000644000175000017500000003776712502223526016715 0ustar uwabamiuwabami--- :name: sgerfsx :md5sum: 876fcf4bac7f0e0eb90f1afa6af67a87 :category: :subroutine :arguments: - trans: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - r: :type: real :intent: input :dims: - n - c: :type: real :intent: input :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: real :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " SUBROUTINE SGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGERFSX improves the computed solution to a system of linear\n\ * equations and provides error bounds and backward error estimates\n\ * for the solution. In addition to normwise error bound, the code\n\ * provides maximum componentwise error bound if possible. See\n\ * comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n\ * error bounds.\n\ *\n\ * The original system of linear equations may have been equilibrated\n\ * before calling this routine, as described by arguments EQUED, R\n\ * and C below. In this case, the solution and error bounds returned\n\ * are for the original unequilibrated system.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose = Transpose)\n\ *\n\ * EQUED (input) CHARACTER*1\n\ * Specifies the form of equilibration that was done to A\n\ * before calling this routine. This is needed to compute\n\ * the solution and error bounds correctly.\n\ * = 'N': No equilibration\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ * The right hand side B has been changed accordingly.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * The original N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) REAL array, dimension (LDAF,N)\n\ * The factors L and U from the factorization A = P*L*U\n\ * as computed by SGETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from SGETRF; for 1<=i<=N, row i of the\n\ * matrix was interchanged with row IPIV(i).\n\ *\n\ * R (input) REAL array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'R' or 'B', A is\n\ * multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n\ * is not accessed. \n\ * If R is accessed, each element of R should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * C (input) REAL array, dimension (N)\n\ * The column scale factors for A. If EQUED = 'C' or 'B', A is\n\ * multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n\ * is not accessed. \n\ * If C is accessed, each element of C should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input) REAL array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) REAL array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by SGETRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * Componentwise relative backward error. This is the\n\ * componentwise relative backward error of each solution vector X(j)\n\ * (i.e., the smallest relative change in any element of A or B that\n\ * makes X(j) an exact solution).\n\ *\n\ * N_ERR_BNDS (input) INTEGER\n\ * Number of error bounds to return for each right hand side\n\ * and each type (normwise or componentwise). See ERR_BNDS_NORM and\n\ * ERR_BNDS_COMP below.\n\ *\n\ * ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * NPARAMS (input) INTEGER\n\ * Specifies the number of parameters set in PARAMS. If .LE. 0, the\n\ * PARAMS array is never referenced and default values are used.\n\ *\n\ * PARAMS (input / output) REAL array, dimension NPARAMS\n\ * Specifies algorithm parameters. If an entry is .LT. 0.0, then\n\ * that entry will be filled with default value used for that\n\ * parameter. Only positions up to NPARAMS are accessed; defaults\n\ * are used for higher-numbered parameters.\n\ *\n\ * PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n\ * refinement or not.\n\ * Default: 1.0\n\ * = 0.0 : No refinement is performed, and no error bounds are\n\ * computed.\n\ * = 1.0 : Use the double-precision refinement algorithm,\n\ * possibly with doubled-single computations if the\n\ * compilation environment does not support DOUBLE\n\ * PRECISION.\n\ * (other values are reserved for future use)\n\ *\n\ * PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n\ * computations allowed for refinement.\n\ * Default: 10\n\ * Aggressive: Set to 100 to permit convergence using approximate\n\ * factorizations or factorizations other than LU. If\n\ * the factorization uses a technique other than\n\ * Gaussian elimination, the guarantees in\n\ * err_bnds_norm and err_bnds_comp may no longer be\n\ * trustworthy.\n\ *\n\ * PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n\ * will attempt to find a solution with small componentwise\n\ * relative error in the double-precision algorithm. Positive\n\ * is true, 0.0 is false.\n\ * Default: 1.0 (attempt componentwise convergence)\n\ *\n\ * WORK (workspace) REAL array, dimension (4*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit. The solution to every right-hand side is\n\ * guaranteed.\n\ * < 0: If INFO = -i, the i-th argument had an illegal value\n\ * > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/claqge0000644000175000017500000000612312502223525016445 0ustar uwabamiuwabami--- :name: claqge :md5sum: 71062e5276a246007a7f507402217ad2 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - r: :type: real :intent: input :dims: - m - c: :type: real :intent: input :dims: - n - rowcnd: :type: real :intent: input - colcnd: :type: real :intent: input - amax: :type: real :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAQGE equilibrates a general M by N matrix A using the row and\n\ * column scaling factors in the vectors R and C.\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) COMPLEX array, dimension (LDA,N)\n\ * On entry, the M by N matrix A.\n\ * On exit, the equilibrated matrix. See EQUED for the form of\n\ * the equilibrated matrix.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(M,1).\n\ *\n\ * R (input) REAL array, dimension (M)\n\ * The row scale factors for A.\n\ *\n\ * C (input) REAL array, dimension (N)\n\ * The column scale factors for A.\n\ *\n\ * ROWCND (input) REAL\n\ * Ratio of the smallest R(i) to the largest R(i).\n\ *\n\ * COLCND (input) REAL\n\ * Ratio of the smallest C(i) to the largest C(i).\n\ *\n\ * AMAX (input) REAL\n\ * Absolute value of largest matrix entry.\n\ *\n\ * EQUED (output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * THRESH is a threshold value used to decide if row or column scaling\n\ * should be done based on the ratio of the row or column scaling\n\ * factors. If ROWCND < THRESH, row scaling is done, and if\n\ * COLCND < THRESH, column scaling is done.\n\ *\n\ * LARGE and SMALL are threshold values used to decide if row scaling\n\ * should be done based on the absolute size of the largest matrix\n\ * element. If AMAX > LARGE or AMAX < SMALL, row scaling is done.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sstevx0000644000175000017500000001514412502223526016551 0ustar uwabamiuwabami--- :name: sstevx :md5sum: 0ce5fc8494230896d0287e84e6702aff :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - MAX(1,n-1) - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 5*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: n :fortran_help: " SUBROUTINE SSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSTEVX computes selected eigenvalues and, optionally, eigenvectors\n\ * of a real symmetric tridiagonal matrix A. Eigenvalues and\n\ * eigenvectors can be selected by specifying either a range of values\n\ * or a range of indices for the desired eigenvalues.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found.\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found.\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the n diagonal elements of the tridiagonal matrix\n\ * A.\n\ * On exit, D may be multiplied by a constant factor chosen\n\ * to avoid over/underflow in computing the eigenvalues.\n\ *\n\ * E (input/output) REAL array, dimension (max(1,N-1))\n\ * On entry, the (n-1) subdiagonal elements of the tridiagonal\n\ * matrix A in elements 1 to N-1 of E.\n\ * On exit, E may be multiplied by a constant factor chosen\n\ * to avoid over/underflow in computing the eigenvalues.\n\ *\n\ * VL (input) REAL\n\ * VU (input) REAL\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) REAL\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less\n\ * than or equal to zero, then EPS*|T| will be used in\n\ * its place, where |T| is the 1-norm of the tridiagonal\n\ * matrix.\n\ *\n\ * Eigenvalues will be computed most accurately when ABSTOL is\n\ * set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n\ * If this routine returns with INFO>0, indicating that some\n\ * eigenvectors did not converge, try setting ABSTOL to\n\ * 2*SLAMCH('S').\n\ *\n\ * See \"Computing Small Singular Values of Bidiagonal Matrices\n\ * with Guaranteed High Relative Accuracy,\" by Demmel and\n\ * Kahan, LAPACK Working Note #3.\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * The first M elements contain the selected eigenvalues in\n\ * ascending order.\n\ *\n\ * Z (output) REAL array, dimension (LDZ, max(1,M) )\n\ * If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix A\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * If an eigenvector fails to converge (INFO > 0), then that\n\ * column of Z contains the latest approximation to the\n\ * eigenvector, and the index of the eigenvector is returned\n\ * in IFAIL. If JOBZ = 'N', then Z is not referenced.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) REAL array, dimension (5*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (5*N)\n\ *\n\ * IFAIL (output) INTEGER array, dimension (N)\n\ * If JOBZ = 'V', then if INFO = 0, the first M elements of\n\ * IFAIL are zero. If INFO > 0, then IFAIL contains the\n\ * indices of the eigenvectors that failed to converge.\n\ * If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n\ * Their indices are stored in array IFAIL.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgghrd0000644000175000017500000001361312502223526016453 0ustar uwabamiuwabami--- :name: dgghrd :md5sum: d3387383d791c77ea93cb356899973a1 :category: :subroutine :arguments: - compq: :type: char :intent: input - compz: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - q: :type: doublereal :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - z: :type: doublereal :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGGHRD reduces a pair of real matrices (A,B) to generalized upper\n\ * Hessenberg form using orthogonal transformations, where A is a\n\ * general matrix and B is upper triangular. The form of the\n\ * generalized eigenvalue problem is\n\ * A*x = lambda*B*x,\n\ * and B is typically made upper triangular by computing its QR\n\ * factorization and moving the orthogonal matrix Q to the left side\n\ * of the equation.\n\ *\n\ * This subroutine simultaneously reduces A to a Hessenberg matrix H:\n\ * Q**T*A*Z = H\n\ * and transforms B to another upper triangular matrix T:\n\ * Q**T*B*Z = T\n\ * in order to reduce the problem to its standard form\n\ * H*y = lambda*T*y\n\ * where y = Z**T*x.\n\ *\n\ * The orthogonal matrices Q and Z are determined as products of Givens\n\ * rotations. They may either be formed explicitly, or they may be\n\ * postmultiplied into input matrices Q1 and Z1, so that\n\ *\n\ * Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T\n\ *\n\ * Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T\n\ *\n\ * If Q1 is the orthogonal matrix from the QR factorization of B in the\n\ * original equation A*x = lambda*B*x, then DGGHRD reduces the original\n\ * problem to generalized Hessenberg form.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * COMPQ (input) CHARACTER*1\n\ * = 'N': do not compute Q;\n\ * = 'I': Q is initialized to the unit matrix, and the\n\ * orthogonal matrix Q is returned;\n\ * = 'V': Q must contain an orthogonal matrix Q1 on entry,\n\ * and the product Q1*Q is returned.\n\ *\n\ * COMPZ (input) CHARACTER*1\n\ * = 'N': do not compute Z;\n\ * = 'I': Z is initialized to the unit matrix, and the\n\ * orthogonal matrix Z is returned;\n\ * = 'V': Z must contain an orthogonal matrix Z1 on entry,\n\ * and the product Z1*Z is returned.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * ILO and IHI mark the rows and columns of A which are to be\n\ * reduced. It is assumed that A is already upper triangular\n\ * in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are\n\ * normally set by a previous call to SGGBAL; otherwise they\n\ * should be set to 1 and N respectively.\n\ * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n\ * On entry, the N-by-N general matrix to be reduced.\n\ * On exit, the upper triangle and the first subdiagonal of A\n\ * are overwritten with the upper Hessenberg matrix H, and the\n\ * rest is set to zero.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n\ * On entry, the N-by-N upper triangular matrix B.\n\ * On exit, the upper triangular matrix T = Q**T B Z. The\n\ * elements below the diagonal are set to zero.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)\n\ * On entry, if COMPQ = 'V', the orthogonal matrix Q1,\n\ * typically from the QR factorization of B.\n\ * On exit, if COMPQ='I', the orthogonal matrix Q, and if\n\ * COMPQ = 'V', the product Q1*Q.\n\ * Not referenced if COMPQ='N'.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q.\n\ * LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.\n\ *\n\ * Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)\n\ * On entry, if COMPZ = 'V', the orthogonal matrix Z1.\n\ * On exit, if COMPZ='I', the orthogonal matrix Z, and if\n\ * COMPZ = 'V', the product Z1*Z.\n\ * Not referenced if COMPZ='N'.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z.\n\ * LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.\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\ * This routine reduces A to Hessenberg and B to triangular form by\n\ * an unblocked reduction, as described in _Matrix_Computations_,\n\ * by Golub and Van Loan (Johns Hopkins Press.)\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chpgvd0000644000175000017500000002102612502223525016463 0ustar uwabamiuwabami--- :name: chpgvd :md5sum: 64f7065ad380a8ee00723d15be61d9d1 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - ldap - bp: :type: complex :intent: input/output :dims: - n*(n+1)/2 - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 2*n : 0" - rwork: :type: real :intent: workspace :dims: - MAX(1,lrwork) - lrwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "(lsame_(&jobz,\"N\")||n<=1) ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE CHPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHPGVD computes all the eigenvalues and, optionally, the eigenvectors\n\ * of a complex generalized Hermitian-definite eigenproblem, of the form\n\ * A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n\ * B are assumed to be Hermitian, stored in packed format, and B is also\n\ * positive definite.\n\ * If eigenvectors are desired, it uses a divide and conquer algorithm.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * Specifies the problem type to be solved:\n\ * = 1: A*x = (lambda)*B*x\n\ * = 2: A*B*x = (lambda)*x\n\ * = 3: B*A*x = (lambda)*x\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, the contents of AP are destroyed.\n\ *\n\ * BP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * B, packed columnwise in a linear array. The j-th column of B\n\ * is stored in the array BP as follows:\n\ * if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n\ *\n\ * On exit, the triangular factor U or L from the Cholesky\n\ * factorization B = U**H*U or B = L*L**H, in the same storage\n\ * format as B.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) COMPLEX array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n\ * eigenvectors. The eigenvectors are normalized as follows:\n\ * if ITYPE = 1 or 2, Z**H*B*Z = I;\n\ * if ITYPE = 3, Z**H*inv(B)*Z = I.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the required LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of array WORK.\n\ * If N <= 1, LWORK >= 1.\n\ * If JOBZ = 'N' and N > 1, LWORK >= N.\n\ * If JOBZ = 'V' and N > 1, LWORK >= 2*N.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the required sizes of the WORK, RWORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * RWORK (workspace) REAL array, dimension (MAX(1,LRWORK))\n\ * On exit, if INFO = 0, RWORK(1) returns the required LRWORK.\n\ *\n\ * LRWORK (input) INTEGER\n\ * The dimension of array RWORK.\n\ * If N <= 1, LRWORK >= 1.\n\ * If JOBZ = 'N' and N > 1, LRWORK >= N.\n\ * If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.\n\ *\n\ * If LRWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the required sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of array IWORK.\n\ * If JOBZ = 'N' or N <= 1, LIWORK >= 1.\n\ * If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the required sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK 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: CPPTRF or CHPEVD returned an error code:\n\ * <= N: if INFO = i, CHPEVD failed to converge;\n\ * i off-diagonal elements of an intermediate\n\ * tridiagonal form did not convergeto zero;\n\ * > N: if INFO = N + i, for 1 <= i <= n, then the leading\n\ * minor of order i of B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LQUERY, UPPER, WANTZ\n CHARACTER TRANS\n INTEGER J, LIWMIN, LRWMIN, LWMIN, NEIG\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CHPEVD, CHPGST, CPPTRF, CTPMV, CTPSV, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, REAL\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/chegvd0000644000175000017500000002130412502223525016447 0ustar uwabamiuwabami--- :name: chegvd :md5sum: fbd11500a15f1d490decf2761cdee3d4 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n+1 : lsame_(&jobz,\"V\") ? 2*n+n*n : 0" - rwork: :type: real :intent: output :dims: - MAX(1,lrwork) - lrwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CHEGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHEGVD computes all the eigenvalues, and optionally, the eigenvectors\n\ * of a complex generalized Hermitian-definite eigenproblem, of the form\n\ * A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n\ * B are assumed to be Hermitian and B is also positive definite.\n\ * If eigenvectors are desired, it uses a divide and conquer algorithm.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * Specifies the problem type to be solved:\n\ * = 1: A*x = (lambda)*B*x\n\ * = 2: A*B*x = (lambda)*x\n\ * = 3: B*A*x = (lambda)*x\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA, N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of A contains the\n\ * upper triangular part of the matrix A. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of A contains\n\ * the lower triangular part of the matrix A.\n\ *\n\ * On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n\ * matrix Z of eigenvectors. The eigenvectors are normalized\n\ * as follows:\n\ * if ITYPE = 1 or 2, Z**H*B*Z = I;\n\ * if ITYPE = 3, Z**H*inv(B)*Z = I.\n\ * If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n\ * or the lower triangle (if UPLO='L') of A, including the\n\ * diagonal, is destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB, N)\n\ * On entry, the Hermitian matrix B. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of B contains the\n\ * upper triangular part of the matrix B. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of B contains\n\ * the lower triangular part of the matrix B.\n\ *\n\ * On exit, if INFO <= N, the part of B containing the matrix is\n\ * overwritten by the triangular factor U or L from the Cholesky\n\ * factorization B = U**H*U or B = L*L**H.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of the array WORK.\n\ * If N <= 1, LWORK >= 1.\n\ * If JOBZ = 'N' and N > 1, LWORK >= N + 1.\n\ * If JOBZ = 'V' and N > 1, LWORK >= 2*N + N**2.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the optimal sizes of the WORK, RWORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK))\n\ * On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n\ *\n\ * LRWORK (input) INTEGER\n\ * The dimension of the array RWORK.\n\ * If N <= 1, LRWORK >= 1.\n\ * If JOBZ = 'N' and N > 1, LRWORK >= N.\n\ * If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.\n\ *\n\ * If LRWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK.\n\ * If N <= 1, LIWORK >= 1.\n\ * If JOBZ = 'N' and N > 1, LIWORK >= 1.\n\ * If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK 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: CPOTRF or CHEEVD returned an error code:\n\ * <= N: if INFO = i and JOBZ = 'N', then the algorithm\n\ * failed to converge; i off-diagonal elements of an\n\ * intermediate tridiagonal form did not converge to\n\ * zero;\n\ * if INFO = i and JOBZ = 'V', then the algorithm\n\ * failed to compute an eigenvalue while working on\n\ * the submatrix lying in rows and columns INFO/(N+1)\n\ * through mod(INFO,N+1);\n\ * > N: if INFO = N + i, for 1 <= i <= N, then the leading\n\ * minor of order i of B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n\ *\n\ * Modified so that no backsubstitution is performed if CHEEVD fails to\n\ * converge (NEIG in old code could be greater than N causing out of\n\ * bounds reference to A - reported by Ralf Meyer). Also corrected the\n\ * description of INFO and the test on ITYPE. Sven, 16 Feb 05.\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhpsvx0000644000175000017500000002270112502223526016554 0ustar uwabamiuwabami--- :name: zhpsvx :md5sum: 1b089b8de3c3c23cb14a6227f6eccf46 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - afp: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE ZHPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHPSVX uses the diagonal pivoting factorization A = U*D*U**H or\n\ * A = L*D*L**H to compute the solution to a complex system of linear\n\ * equations A * X = B, where A is an N-by-N Hermitian matrix stored\n\ * in packed format and X and B are N-by-NRHS matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'N', the diagonal pivoting method is used to factor A as\n\ * A = U * D * U**H, if UPLO = 'U', or\n\ * A = L * D * L**H, if UPLO = 'L',\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices and D is Hermitian and block diagonal with\n\ * 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\ * 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n\ * returns with INFO = i. Otherwise, the factored form of A is used\n\ * to estimate the condition number of the matrix A. If the\n\ * reciprocal of the condition number is less than machine precision,\n\ * INFO = N+1 is returned as a warning, but the routine still goes on\n\ * to solve for X and compute error bounds as described below.\n\ *\n\ * 3. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 4. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of A has been\n\ * supplied on entry.\n\ * = 'F': On entry, AFP and IPIV contain the factored form of\n\ * A. AFP and IPIV will not be modified.\n\ * = 'N': The matrix A will be copied to AFP and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * The upper or lower triangle of the Hermitian matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ * See below for further details.\n\ *\n\ * AFP (input or output) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * If FACT = 'F', then AFP is an input argument and on entry\n\ * contains the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L from the factorization\n\ * A = U*D*U**H or A = L*D*L**H as computed by ZHPTRF, stored as\n\ * a packed triangular matrix in the same storage format as A.\n\ *\n\ * If FACT = 'N', then AFP is an output argument and on exit\n\ * contains the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L from the factorization\n\ * A = U*D*U**H or A = L*D*L**H as computed by ZHPTRF, stored as\n\ * a packed triangular matrix in the same storage format as A.\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains details of the interchanges and the block structure\n\ * of D, as determined by ZHPTRF.\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains details of the interchanges and the block structure\n\ * of D, as determined by ZHPTRF.\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The N-by-NRHS right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A. If RCOND is less than the machine precision (in\n\ * particular, if RCOND = 0), the matrix is singular to working\n\ * precision. This condition is indicated by a return code of\n\ * INFO > 0.\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\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, and i is\n\ * <= N: D(i,i) is exactly zero. The factorization\n\ * has been completed but the factor D is exactly\n\ * singular, so the solution and error bounds could\n\ * not be computed. RCOND = 0 is returned.\n\ * = N+1: D is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The packed storage scheme is illustrated by the following example\n\ * when N = 4, UPLO = 'U':\n\ *\n\ * Two-dimensional storage of the Hermitian matrix A:\n\ *\n\ * a11 a12 a13 a14\n\ * a22 a23 a24\n\ * a33 a34 (aij = conjg(aji))\n\ * a44\n\ *\n\ * Packed storage of the upper triangle of A:\n\ *\n\ * AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlaexc0000644000175000017500000000610112502223526016446 0ustar uwabamiuwabami--- :name: dlaexc :md5sum: 56c861d18592b42e26327b9686122ba6 :category: :subroutine :arguments: - wantq: :type: logical :intent: input - n: :type: integer :intent: input - t: :type: doublereal :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - q: :type: doublereal :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - j1: :type: integer :intent: input - n1: :type: integer :intent: input - n2: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in\n\ * an upper quasi-triangular matrix T by an orthogonal similarity\n\ * transformation.\n\ *\n\ * T must be in Schur canonical form, that is, block upper triangular\n\ * with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block\n\ * has its diagonal elemnts equal and its off-diagonal elements of\n\ * opposite sign.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * WANTQ (input) LOGICAL\n\ * = .TRUE. : accumulate the transformation in the matrix Q;\n\ * = .FALSE.: do not accumulate the transformation.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix T. N >= 0.\n\ *\n\ * T (input/output) DOUBLE PRECISION array, dimension (LDT,N)\n\ * On entry, the upper quasi-triangular matrix T, in Schur\n\ * canonical form.\n\ * On exit, the updated matrix T, again in Schur canonical form.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= max(1,N).\n\ *\n\ * Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n\ * On entry, if WANTQ is .TRUE., the orthogonal matrix Q.\n\ * On exit, if WANTQ is .TRUE., the updated matrix Q.\n\ * If WANTQ is .FALSE., Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q.\n\ * LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N.\n\ *\n\ * J1 (input) INTEGER\n\ * The index of the first row of the first block T11.\n\ *\n\ * N1 (input) INTEGER\n\ * The order of the first block T11. N1 = 0, 1 or 2.\n\ *\n\ * N2 (input) INTEGER\n\ * The order of the second block T22. N2 = 0, 1 or 2.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * = 1: the transformed matrix T would be too far from Schur\n\ * form; the blocks are not swapped and T and Q are\n\ * unchanged.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssytrs20000644000175000017500000000521312502223526016642 0ustar uwabamiuwabami--- :name: ssytrs2 :md5sum: ed50028299accd66eae8dd53a98b6eb0 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSYTRS2 solves a system of linear equations A*X = B with a real\n\ * symmetric matrix A using the factorization A = U*D*U**T or\n\ * A = L*D*L**T computed by SSYTRF and converted by SSYCONV.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by SSYTRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by SSYTRF.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * WORK (workspace) REAL array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/stgsna0000644000175000017500000003262112502223526016513 0ustar uwabamiuwabami--- :name: stgsna :md5sum: df29cdbd8fb6f9df1af4856bd8b8b717 :category: :subroutine :arguments: - job: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - vl: :type: real :intent: input :dims: - ldvl - m - ldvl: :type: integer :intent: input - vr: :type: real :intent: input :dims: - ldvr - m - ldvr: :type: integer :intent: input - s: :type: real :intent: output :dims: - mm - dif: :type: real :intent: output :dims: - mm - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(lsame_(&job,\"V\")||lsame_(&job,\"B\")) ? 2*n*n : n" - iwork: :type: integer :intent: workspace :dims: - "lsame_(&job,\"E\") ? 0 : n + 6" - info: :type: integer :intent: output :substitutions: mm: m :fortran_help: " SUBROUTINE STGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STGSNA estimates reciprocal condition numbers for specified\n\ * eigenvalues and/or eigenvectors of a matrix pair (A, B) in\n\ * generalized real Schur canonical form (or of any matrix pair\n\ * (Q*A*Z', Q*B*Z') with orthogonal matrices Q and Z, where\n\ * Z' denotes the transpose of Z.\n\ *\n\ * (A, B) must be in generalized real Schur form (as returned by SGGES),\n\ * i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal\n\ * blocks. B is upper triangular.\n\ *\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * Specifies whether condition numbers are required for\n\ * eigenvalues (S) or eigenvectors (DIF):\n\ * = 'E': for eigenvalues only (S);\n\ * = 'V': for eigenvectors only (DIF);\n\ * = 'B': for both eigenvalues and eigenvectors (S and DIF).\n\ *\n\ * HOWMNY (input) CHARACTER*1\n\ * = 'A': compute condition numbers for all eigenpairs;\n\ * = 'S': compute condition numbers for selected eigenpairs\n\ * specified by the array SELECT.\n\ *\n\ * SELECT (input) LOGICAL array, dimension (N)\n\ * If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n\ * condition numbers are required. To select condition numbers\n\ * for the eigenpair corresponding to a real eigenvalue w(j),\n\ * SELECT(j) must be set to .TRUE.. To select condition numbers\n\ * corresponding to a complex conjugate pair of eigenvalues w(j)\n\ * and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be\n\ * set to .TRUE..\n\ * If HOWMNY = 'A', SELECT is not referenced.\n\ *\n\ * N (input) INTEGER\n\ * The order of the square matrix pair (A, B). N >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * The upper quasi-triangular matrix A in the pair (A,B).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input) REAL array, dimension (LDB,N)\n\ * The upper triangular matrix B in the pair (A,B).\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * VL (input) REAL array, dimension (LDVL,M)\n\ * If JOB = 'E' or 'B', VL must contain left eigenvectors of\n\ * (A, B), corresponding to the eigenpairs specified by HOWMNY\n\ * and SELECT. The eigenvectors must be stored in consecutive\n\ * columns of VL, as returned by STGEVC.\n\ * If JOB = 'V', VL is not referenced.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the array VL. LDVL >= 1.\n\ * If JOB = 'E' or 'B', LDVL >= N.\n\ *\n\ * VR (input) REAL array, dimension (LDVR,M)\n\ * If JOB = 'E' or 'B', VR must contain right eigenvectors of\n\ * (A, B), corresponding to the eigenpairs specified by HOWMNY\n\ * and SELECT. The eigenvectors must be stored in consecutive\n\ * columns ov VR, as returned by STGEVC.\n\ * If JOB = 'V', VR is not referenced.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the array VR. LDVR >= 1.\n\ * If JOB = 'E' or 'B', LDVR >= N.\n\ *\n\ * S (output) REAL array, dimension (MM)\n\ * If JOB = 'E' or 'B', the reciprocal condition numbers of the\n\ * selected eigenvalues, stored in consecutive elements of the\n\ * array. For a complex conjugate pair of eigenvalues two\n\ * consecutive elements of S are set to the same value. Thus\n\ * S(j), DIF(j), and the j-th columns of VL and VR all\n\ * correspond to the same eigenpair (but not in general the\n\ * j-th eigenpair, unless all eigenpairs are selected).\n\ * If JOB = 'V', S is not referenced.\n\ *\n\ * DIF (output) REAL array, dimension (MM)\n\ * If JOB = 'V' or 'B', the estimated reciprocal condition\n\ * numbers of the selected eigenvectors, stored in consecutive\n\ * elements of the array. For a complex eigenvector two\n\ * consecutive elements of DIF are set to the same value. If\n\ * the eigenvalues cannot be reordered to compute DIF(j), DIF(j)\n\ * is set to 0; this can only occur when the true value would be\n\ * very small anyway.\n\ * If JOB = 'E', DIF is not referenced.\n\ *\n\ * MM (input) INTEGER\n\ * The number of elements in the arrays S and DIF. MM >= M.\n\ *\n\ * M (output) INTEGER\n\ * The number of elements of the arrays S and DIF used to store\n\ * the specified condition numbers; for each selected real\n\ * eigenvalue one element is used, and for each selected complex\n\ * conjugate pair of eigenvalues, two elements are used.\n\ * If HOWMNY = 'A', M is set to N.\n\ *\n\ * WORK (workspace/output) REAL 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,N).\n\ * If JOB = 'V' or 'B' LWORK >= 2*N*(N+2)+16.\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\ * IWORK (workspace) INTEGER array, dimension (N + 6)\n\ * If JOB = 'E', IWORK is not referenced.\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\n\ * Further Details\n\ * ===============\n\ *\n\ * The reciprocal of the condition number of a generalized eigenvalue\n\ * w = (a, b) is defined as\n\ *\n\ * S(w) = (|u'Av|**2 + |u'Bv|**2)**(1/2) / (norm(u)*norm(v))\n\ *\n\ * where u and v are the left and right eigenvectors of (A, B)\n\ * corresponding to w; |z| denotes the absolute value of the complex\n\ * number, and norm(u) denotes the 2-norm of the vector u.\n\ * The pair (a, b) corresponds to an eigenvalue w = a/b (= u'Av/u'Bv)\n\ * of the matrix pair (A, B). If both a and b equal zero, then (A B) is\n\ * singular and S(I) = -1 is returned.\n\ *\n\ * An approximate error bound on the chordal distance between the i-th\n\ * computed generalized eigenvalue w and the corresponding exact\n\ * eigenvalue lambda is\n\ *\n\ * chord(w, lambda) <= EPS * norm(A, B) / S(I)\n\ *\n\ * where EPS is the machine precision.\n\ *\n\ * The reciprocal of the condition number DIF(i) of right eigenvector u\n\ * and left eigenvector v corresponding to the generalized eigenvalue w\n\ * is defined as follows:\n\ *\n\ * a) If the i-th eigenvalue w = (a,b) is real\n\ *\n\ * Suppose U and V are orthogonal transformations such that\n\ *\n\ * U'*(A, B)*V = (S, T) = ( a * ) ( b * ) 1\n\ * ( 0 S22 ),( 0 T22 ) n-1\n\ * 1 n-1 1 n-1\n\ *\n\ * Then the reciprocal condition number DIF(i) is\n\ *\n\ * Difl((a, b), (S22, T22)) = sigma-min( Zl ),\n\ *\n\ * where sigma-min(Zl) denotes the smallest singular value of the\n\ * 2(n-1)-by-2(n-1) matrix\n\ *\n\ * Zl = [ kron(a, In-1) -kron(1, S22) ]\n\ * [ kron(b, In-1) -kron(1, T22) ] .\n\ *\n\ * Here In-1 is the identity matrix of size n-1. kron(X, Y) is the\n\ * Kronecker product between the matrices X and Y.\n\ *\n\ * Note that if the default method for computing DIF(i) is wanted\n\ * (see SLATDF), then the parameter DIFDRI (see below) should be\n\ * changed from 3 to 4 (routine SLATDF(IJOB = 2 will be used)).\n\ * See STGSYL for more details.\n\ *\n\ * b) If the i-th and (i+1)-th eigenvalues are complex conjugate pair,\n\ *\n\ * Suppose U and V are orthogonal transformations such that\n\ *\n\ * U'*(A, B)*V = (S, T) = ( S11 * ) ( T11 * ) 2\n\ * ( 0 S22 ),( 0 T22) n-2\n\ * 2 n-2 2 n-2\n\ *\n\ * and (S11, T11) corresponds to the complex conjugate eigenvalue\n\ * pair (w, conjg(w)). There exist unitary matrices U1 and V1 such\n\ * that\n\ *\n\ * U1'*S11*V1 = ( s11 s12 ) and U1'*T11*V1 = ( t11 t12 )\n\ * ( 0 s22 ) ( 0 t22 )\n\ *\n\ * where the generalized eigenvalues w = s11/t11 and\n\ * conjg(w) = s22/t22.\n\ *\n\ * Then the reciprocal condition number DIF(i) is bounded by\n\ *\n\ * min( d1, max( 1, |real(s11)/real(s22)| )*d2 )\n\ *\n\ * where, d1 = Difl((s11, t11), (s22, t22)) = sigma-min(Z1), where\n\ * Z1 is the complex 2-by-2 matrix\n\ *\n\ * Z1 = [ s11 -s22 ]\n\ * [ t11 -t22 ],\n\ *\n\ * This is done by computing (using real arithmetic) the\n\ * roots of the characteristical polynomial det(Z1' * Z1 - lambda I),\n\ * where Z1' denotes the conjugate transpose of Z1 and det(X) denotes\n\ * the determinant of X.\n\ *\n\ * and d2 is an upper bound on Difl((S11, T11), (S22, T22)), i.e. an\n\ * upper bound on sigma-min(Z2), where Z2 is (2n-2)-by-(2n-2)\n\ *\n\ * Z2 = [ kron(S11', In-2) -kron(I2, S22) ]\n\ * [ kron(T11', In-2) -kron(I2, T22) ]\n\ *\n\ * Note that if the default method for computing DIF is wanted (see\n\ * SLATDF), then the parameter DIFDRI (see below) should be changed\n\ * from 3 to 4 (routine SLATDF(IJOB = 2 will be used)). See STGSYL\n\ * for more details.\n\ *\n\ * For each eigenvalue/vector specified by SELECT, DIF stores a\n\ * Frobenius norm-based estimate of Difl.\n\ *\n\ * An approximate error bound for the i-th computed eigenvector VL(i) or\n\ * VR(i) is given by\n\ *\n\ * EPS * norm(A, B) / DIF(i).\n\ *\n\ * See ref. [2-3] for more details and further references.\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * References\n\ * ==========\n\ *\n\ * [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n\ * Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n\ * M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n\ * Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n\ *\n\ * [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n\ * Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n\ * Estimation: Theory, Algorithms and Software,\n\ * Report UMINF - 94.04, Department of Computing Science, Umea\n\ * University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working\n\ * Note 87. To appear in Numerical Algorithms, 1996.\n\ *\n\ * [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n\ * for Solving the Generalized Sylvester Equation and Estimating the\n\ * Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n\ * Department of Computing Science, Umea University, S-901 87 Umea,\n\ * Sweden, December 1993, Revised April 1994, Also as LAPACK Working\n\ * Note 75. To appear in ACM Trans. on Math. Software, Vol 22,\n\ * No 1, 1996.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/spotrf0000644000175000017500000000455312502223526016534 0ustar uwabamiuwabami--- :name: spotrf :md5sum: cb97be44d916cb601b672d4d31893ab1 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPOTRF( UPLO, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPOTRF computes the Cholesky factorization of a real symmetric\n\ * positive definite matrix A.\n\ *\n\ * The factorization has the form\n\ * A = U**T * U, if UPLO = 'U', or\n\ * A = L * L**T, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is lower triangular.\n\ *\n\ * This is the block version of the algorithm, calling Level 3 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\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 leading minor of order i is not\n\ * positive definite, and the factorization could not be\n\ * completed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgesvx0000644000175000017500000003231312502223526016531 0ustar uwabamiuwabami--- :name: sgesvx :md5sum: 60e2461f042fe2e20d703a515b1117e4 :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input/output :dims: - ldaf - n :option: true - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n :option: true - equed: :type: char :intent: input/output :option: true - r: :type: real :intent: input/output :dims: - n :option: true - c: :type: real :intent: input/output :dims: - n :option: true - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: output :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: n ldaf: n :fortran_help: " SUBROUTINE SGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGESVX uses the LU factorization to compute the solution to a real\n\ * system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', real scaling factors are computed to equilibrate\n\ * the system:\n\ * TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n\ * TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n\ * TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n\ * or diag(C)*B (if TRANS = 'T' or 'C').\n\ *\n\ * 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n\ * matrix A (after equilibration if FACT = 'E') as\n\ * A = P * L * U,\n\ * where P is a permutation matrix, L is a unit lower triangular\n\ * matrix, and U is upper triangular.\n\ *\n\ * 3. If some U(i,i)=0, so that U is exactly singular, then the routine\n\ * returns with INFO = i. Otherwise, the factored form of A is used\n\ * to estimate the condition number of the matrix A. If the\n\ * reciprocal of the condition number is less than machine precision,\n\ * INFO = N+1 is returned as a warning, but the routine still goes on\n\ * to solve for X and compute error bounds as described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n\ * that it solves the original system before equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AF and IPIV contain the factored form of A.\n\ * If EQUED is not 'N', the matrix A has been\n\ * equilibrated with scaling factors given by R and C.\n\ * A, AF, and IPIV are not modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AF and factored.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is\n\ * not 'N', then A must have been equilibrated by the scaling\n\ * factors in R and/or C. A is not modified if FACT = 'F' or\n\ * 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n\ *\n\ * On exit, if EQUED .ne. 'N', A is scaled as follows:\n\ * EQUED = 'R': A := diag(R) * A\n\ * EQUED = 'C': A := A * diag(C)\n\ * EQUED = 'B': A := diag(R) * A * diag(C).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input or output) REAL array, dimension (LDAF,N)\n\ * If FACT = 'F', then AF is an input argument and on entry\n\ * contains the factors L and U from the factorization\n\ * A = P*L*U as computed by SGETRF. If EQUED .ne. 'N', then\n\ * AF is the factored form of the equilibrated matrix A.\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the factors L and U from the factorization A = P*L*U\n\ * of the original matrix A.\n\ *\n\ * If FACT = 'E', then AF is an output argument and on exit\n\ * returns the factors L and U from the factorization A = P*L*U\n\ * of the equilibrated matrix A (see the description of A for\n\ * the form of the equilibrated matrix).\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * as computed by SGETRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * of the original matrix A.\n\ *\n\ * If FACT = 'E', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * of the equilibrated matrix A.\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * R (input or output) REAL array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'R' or 'B', A is\n\ * multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n\ * is not accessed. R is an input argument if FACT = 'F';\n\ * otherwise, R is an output argument. If FACT = 'F' and\n\ * EQUED = 'R' or 'B', each element of R must be positive.\n\ *\n\ * C (input or output) REAL array, dimension (N)\n\ * The column scale factors for A. If EQUED = 'C' or 'B', A is\n\ * multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n\ * is not accessed. C is an input argument if FACT = 'F';\n\ * otherwise, C is an output argument. If FACT = 'F' and\n\ * EQUED = 'C' or 'B', each element of C must be positive.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit,\n\ * if EQUED = 'N', B is not modified;\n\ * if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n\ * diag(R)*B;\n\ * if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n\ * overwritten by diag(C)*B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) REAL array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n\ * to the original system of equations. Note that A and B are\n\ * modified on exit if EQUED .ne. 'N', and the solution to the\n\ * equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n\ * EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n\ * and EQUED = 'R' or 'B'.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A after equilibration (if done). If RCOND is less than the\n\ * machine precision (in particular, if RCOND = 0), the matrix\n\ * is singular to working precision. This condition is\n\ * indicated by a return code of INFO > 0.\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace/output) REAL array, dimension (4*N)\n\ * On exit, WORK(1) contains the reciprocal pivot growth\n\ * factor norm(A)/norm(U). The \"max absolute element\" norm is\n\ * used. If WORK(1) is much less than 1, then the stability\n\ * of the LU factorization of the (equilibrated) matrix A\n\ * could be poor. This also means that the solution X, condition\n\ * estimator RCOND, and forward error bound FERR could be\n\ * unreliable. If factorization fails with 0 0: if INFO = i, and i is\n\ * <= N: U(i,i) is exactly zero. The factorization has\n\ * been completed, but the factor U is exactly\n\ * singular, so the solution and error bounds\n\ * could not be computed. RCOND = 0 is returned.\n\ * = N+1: U is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cpptri0000644000175000017500000000363512502223525016517 0ustar uwabamiuwabami--- :name: cpptri :md5sum: 8720a8073e7c8a28a6d01f6ad7d603d2 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPPTRI( UPLO, N, AP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPPTRI computes the inverse of a complex Hermitian positive definite\n\ * matrix A using the Cholesky factorization A = U**H*U or A = L*L**H\n\ * computed by CPPTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangular factor is stored in AP;\n\ * = 'L': Lower triangular factor is stored in AP.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX array, dimension (N*(N+1)/2)\n\ * On entry, the triangular factor U or L from the Cholesky\n\ * factorization A = U**H*U or A = L*L**H, packed columnwise as\n\ * a linear array. The j-th column of U or L is stored in the\n\ * array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n\ *\n\ * On exit, the upper or lower triangle of the (Hermitian)\n\ * inverse of A, overwriting the input factor U or L.\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,i) element of the factor U or L is\n\ * zero, and the inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlag2s0000644000175000017500000000444112655767354016414 0ustar uwabamiuwabami--- :name: dlag2s :md5sum: 669e5e37ddea7cbcff65fc0b9ae1eca2 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - sa: :type: real :intent: output :dims: - ldsa - n - ldsa: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: ldsa: MAX(1,m) :fortran_help: " SUBROUTINE DLAG2S( M, N, A, LDA, SA, LDSA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAG2S converts a DOUBLE PRECISION matrix, SA, to a SINGLE\n\ * PRECISION matrix, A.\n\ *\n\ * RMAX is the overflow for the SINGLE PRECISION arithmetic\n\ * DLAG2S checks that all the entries of A are between -RMAX and\n\ * RMAX. If not the conversion is aborted and a flag is raised.\n\ *\n\ * This is an auxiliary routine so there is no argument checking.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of lines 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) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the M-by-N coefficient matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * SA (output) REAL array, dimension (LDSA,N)\n\ * On exit, if INFO=0, the M-by-N coefficient matrix SA; if\n\ * INFO>0, the content of SA is unspecified.\n\ *\n\ * LDSA (input) INTEGER\n\ * The leading dimension of the array SA. LDSA >= max(1,M).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit.\n\ * = 1: an entry of the matrix A is greater than the SINGLE\n\ * PRECISION overflow threshold, in this case, the content\n\ * of SA in exit is unspecified.\n\ *\n\ * =========\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n DOUBLE PRECISION RMAX\n\ * ..\n\ * .. External Functions ..\n REAL SLAMCH\n EXTERNAL SLAMCH\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dggsvp0000644000175000017500000001536712502223526016516 0ustar uwabamiuwabami--- :name: dggsvp :md5sum: ce4882820e369faca6fa14e28c83ea25 :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobv: :type: char :intent: input - jobq: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - tola: :type: doublereal :intent: input - tolb: :type: doublereal :intent: input - k: :type: integer :intent: output - l: :type: integer :intent: output - u: :type: doublereal :intent: output :dims: - ldu - m - ldu: :type: integer :intent: input - v: :type: doublereal :intent: output :dims: - ldv - p - ldv: :type: integer :intent: input - q: :type: doublereal :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - iwork: :type: integer :intent: workspace :dims: - n - tau: :type: doublereal :intent: workspace :dims: - n - work: :type: doublereal :intent: workspace :dims: - MAX(MAX(3*n,m),p) - info: :type: integer :intent: output :substitutions: m: lda p: ldb ldq: "lsame_(&jobq,\"Q\") ? MAX(1,n) : 1" ldu: "lsame_(&jobu,\"U\") ? MAX(1,m) : 1" ldv: "lsame_(&jobv,\"V\") ? MAX(1,p) : 1" :fortran_help: " SUBROUTINE DGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGGSVP computes orthogonal matrices U, V and Q such that\n\ *\n\ * N-K-L K L\n\ * U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0;\n\ * L ( 0 0 A23 )\n\ * M-K-L ( 0 0 0 )\n\ *\n\ * N-K-L K L\n\ * = K ( 0 A12 A13 ) if M-K-L < 0;\n\ * M-K ( 0 0 A23 )\n\ *\n\ * N-K-L K L\n\ * V'*B*Q = L ( 0 0 B13 )\n\ * P-L ( 0 0 0 )\n\ *\n\ * where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n\ * upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n\ * otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective\n\ * numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the\n\ * transpose of Z.\n\ *\n\ * This decomposition is the preprocessing step for computing the\n\ * Generalized Singular Value Decomposition (GSVD), see subroutine\n\ * DGGSVD.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBU (input) CHARACTER*1\n\ * = 'U': Orthogonal matrix U is computed;\n\ * = 'N': U is not computed.\n\ *\n\ * JOBV (input) CHARACTER*1\n\ * = 'V': Orthogonal matrix V is computed;\n\ * = 'N': V is not computed.\n\ *\n\ * JOBQ (input) CHARACTER*1\n\ * = 'Q': Orthogonal matrix Q is computed;\n\ * = 'N': Q is not computed.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A. M >= 0.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows of the matrix B. P >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrices A and B. 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, A contains the triangular (or trapezoidal) matrix\n\ * described in the Purpose section.\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,N)\n\ * On entry, the P-by-N matrix B.\n\ * On exit, B contains the triangular matrix described in\n\ * the Purpose section.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,P).\n\ *\n\ * TOLA (input) DOUBLE PRECISION\n\ * TOLB (input) DOUBLE PRECISION\n\ * TOLA and TOLB are the thresholds to determine the effective\n\ * numerical rank of matrix B and a subblock of A. Generally,\n\ * they are set to\n\ * TOLA = MAX(M,N)*norm(A)*MAZHEPS,\n\ * TOLB = MAX(P,N)*norm(B)*MAZHEPS.\n\ * The size of TOLA and TOLB may affect the size of backward\n\ * errors of the decomposition.\n\ *\n\ * K (output) INTEGER\n\ * L (output) INTEGER\n\ * On exit, K and L specify the dimension of the subblocks\n\ * described in Purpose.\n\ * K + L = effective numerical rank of (A',B')'.\n\ *\n\ * U (output) DOUBLE PRECISION array, dimension (LDU,M)\n\ * If JOBU = 'U', U contains the orthogonal matrix U.\n\ * If JOBU = 'N', U is not referenced.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= max(1,M) if\n\ * JOBU = 'U'; LDU >= 1 otherwise.\n\ *\n\ * V (output) DOUBLE PRECISION array, dimension (LDV,P)\n\ * If JOBV = 'V', V contains the orthogonal matrix V.\n\ * If JOBV = 'N', V is not referenced.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V. LDV >= max(1,P) if\n\ * JOBV = 'V'; LDV >= 1 otherwise.\n\ *\n\ * Q (output) DOUBLE PRECISION array, dimension (LDQ,N)\n\ * If JOBQ = 'Q', Q contains the orthogonal matrix Q.\n\ * If JOBQ = 'N', Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N) if\n\ * JOBQ = 'Q'; LDQ >= 1 otherwise.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * TAU (workspace) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (max(3*N,M,P))\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\n\ * Further Details\n\ * ===============\n\ *\n\ * The subroutine uses LAPACK subroutine DGEQPF for the QR factorization\n\ * with column pivoting to detect the effective numerical rank of the\n\ * a matrix. It may be replaced by a better rank determination strategy.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dbdsdc0000644000175000017500000001672212502223526016443 0ustar uwabamiuwabami--- :name: dbdsdc :md5sum: 27fa176c325154bb7249d301f950baf5 :category: :subroutine :arguments: - uplo: :type: char :intent: input - compq: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - u: :type: doublereal :intent: output :dims: - "lsame_(&compq,\"I\") ? ldu : 0" - "lsame_(&compq,\"I\") ? n : 0" - ldu: :type: integer :intent: input - vt: :type: doublereal :intent: output :dims: - "lsame_(&compq,\"I\") ? ldvt : 0" - "lsame_(&compq,\"I\") ? n : 0" - ldvt: :type: integer :intent: input - q: :type: doublereal :intent: output :dims: - "lsame_(&compq,\"I\") ? (lsame_(&compq,\"P\") ? n*(11+2*smlsiz+8*(int)(log(((double)n)/(smlsiz+1))/log(2.0))) : 0) : 0" - iq: :type: integer :intent: output :dims: - "lsame_(&compq,\"I\") ? (lsame_(&compq,\"P\") ? n*(3+3*(int)(log(((double)n)/(smlsiz+1))/log(2.0))) : 0) : 0" - work: :type: doublereal :intent: workspace :dims: - "MAX(1,lsame_(&compq,\"N\") ? 4*n : lsame_(&compq,\"P\") ? 6*n : lsame_(&compq,\"I\") ? 3*n*n+4*n : 0)" - iwork: :type: integer :intent: workspace :dims: - 8*n - info: :type: integer :intent: output :substitutions: c__0: "0" c__9: "9" ldvt: "lsame_(&compq,\"I\") ? MAX(1,n) : 0" ldu: "lsame_(&compq,\"I\") ? MAX(1,n) : 0" smlsiz: "ilaenv_(&c__9, \"DBDSDC\", \" \", &c__0, &c__0, &c__0, &c__0)" :extras: c__0: integer c__9: integer smlsiz: real :fortran_help: " SUBROUTINE DBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DBDSDC computes the singular value decomposition (SVD) of a real\n\ * N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT,\n\ * using a divide and conquer method, where S is a diagonal matrix\n\ * with non-negative diagonal elements (the singular values of B), and\n\ * U and VT are orthogonal matrices of left and right singular vectors,\n\ * respectively. DBDSDC can be used to compute all singular values,\n\ * and optionally, singular vectors or singular vectors in compact form.\n\ *\n\ * This code makes very mild assumptions about floating point\n\ * arithmetic. It will work on machines with a guard digit in\n\ * add/subtract, or on those binary machines without guard digits\n\ * which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n\ * It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none. See DLASD3 for details.\n\ *\n\ * The code currently calls DLASDQ if singular values only are desired.\n\ * However, it can be slightly modified to compute singular values\n\ * using the divide and conquer method.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': B is upper bidiagonal.\n\ * = 'L': B is lower bidiagonal.\n\ *\n\ * COMPQ (input) CHARACTER*1\n\ * Specifies whether singular vectors are to be computed\n\ * as follows:\n\ * = 'N': Compute singular values only;\n\ * = 'P': Compute singular values and compute singular\n\ * vectors in compact form;\n\ * = 'I': Compute singular values and singular vectors.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix B. N >= 0.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the n diagonal elements of the bidiagonal matrix B.\n\ * On exit, if INFO=0, the singular values of B.\n\ *\n\ * E (input/output) DOUBLE PRECISION array, dimension (N-1)\n\ * On entry, the elements of E contain the offdiagonal\n\ * elements of the bidiagonal matrix whose SVD is desired.\n\ * On exit, E has been destroyed.\n\ *\n\ * U (output) DOUBLE PRECISION array, dimension (LDU,N)\n\ * If COMPQ = 'I', then:\n\ * On exit, if INFO = 0, U contains the left singular vectors\n\ * of the bidiagonal matrix.\n\ * For other values of COMPQ, U is not referenced.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= 1.\n\ * If singular vectors are desired, then LDU >= max( 1, N ).\n\ *\n\ * VT (output) DOUBLE PRECISION array, dimension (LDVT,N)\n\ * If COMPQ = 'I', then:\n\ * On exit, if INFO = 0, VT' contains the right singular\n\ * vectors of the bidiagonal matrix.\n\ * For other values of COMPQ, VT is not referenced.\n\ *\n\ * LDVT (input) INTEGER\n\ * The leading dimension of the array VT. LDVT >= 1.\n\ * If singular vectors are desired, then LDVT >= max( 1, N ).\n\ *\n\ * Q (output) DOUBLE PRECISION array, dimension (LDQ)\n\ * If COMPQ = 'P', then:\n\ * On exit, if INFO = 0, Q and IQ contain the left\n\ * and right singular vectors in a compact form,\n\ * requiring O(N log N) space instead of 2*N**2.\n\ * In particular, Q contains all the DOUBLE PRECISION data in\n\ * LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))\n\ * words of memory, where SMLSIZ is returned by ILAENV and\n\ * is equal to the maximum size of the subproblems at the\n\ * bottom of the computation tree (usually about 25).\n\ * For other values of COMPQ, Q is not referenced.\n\ *\n\ * IQ (output) INTEGER array, dimension (LDIQ)\n\ * If COMPQ = 'P', then:\n\ * On exit, if INFO = 0, Q and IQ contain the left\n\ * and right singular vectors in a compact form,\n\ * requiring O(N log N) space instead of 2*N**2.\n\ * In particular, IQ contains all INTEGER data in\n\ * LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))\n\ * words of memory, where SMLSIZ is returned by ILAENV and\n\ * is equal to the maximum size of the subproblems at the\n\ * bottom of the computation tree (usually about 25).\n\ * For other values of COMPQ, IQ is not referenced.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n\ * If COMPQ = 'N' then LWORK >= (4 * N).\n\ * If COMPQ = 'P' then LWORK >= (6 * N).\n\ * If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N).\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (8*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit.\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * > 0: The algorithm failed to compute a singular value.\n\ * The update process of divide and conquer failed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ming Gu and Huan Ren, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ * Changed dimension statement in comment describing E from (N) to\n\ * (N-1). Sven, 17 Feb 05.\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zla_wwaddw0000644000175000017500000000264112502223526017356 0ustar uwabamiuwabami--- :name: zla_wwaddw :md5sum: e64523786b99132b6bdedbd2c060e7e5 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - n - y: :type: doublecomplex :intent: input/output :dims: - n - w: :type: doublecomplex :intent: input :dims: - n :substitutions: {} :fortran_help: " SUBROUTINE ZLA_WWADDW( N, X, Y, W )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLA_WWADDW adds a vector W into a doubled-single vector (X, Y).\n\ *\n\ * This works for all extant IBM's hex and binary floating point\n\ * arithmetics, but not for decimal.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The length of vectors X, Y, and W.\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension (N)\n\ * The first part of the doubled-single accumulation vector.\n\ *\n\ * Y (input/output) COMPLEX*16 array, dimension (N)\n\ * The second part of the doubled-single accumulation vector.\n\ *\n\ * W (input) COMPLEX*16 array, dimension (N)\n\ * The vector to be added.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n COMPLEX*16 S\n INTEGER I\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zlacpy0000644000175000017500000000422412502223526016514 0ustar uwabamiuwabami--- :name: zlacpy :md5sum: 1484db6d74eb437e2eeddcb1bcbca9ef :category: :subroutine :arguments: - uplo: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: output :dims: - ldb - n - ldb: :type: integer :intent: input :substitutions: ldb: MAX(1,m) :fortran_help: " SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLACPY copies all or part of a two-dimensional matrix A to another\n\ * matrix B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies the part of the matrix A to be copied to B.\n\ * = 'U': Upper triangular part\n\ * = 'L': Lower triangular part\n\ * Otherwise: All of the matrix A\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) COMPLEX*16 array, dimension (LDA,N)\n\ * The m by n matrix A. If UPLO = 'U', only the upper trapezium\n\ * is accessed; if UPLO = 'L', only the lower trapezium is\n\ * accessed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (output) COMPLEX*16 array, dimension (LDB,N)\n\ * On exit, B = A in the locations specified by UPLO.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,M).\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sormbr0000644000175000017500000001402412502223526016515 0ustar uwabamiuwabami--- :name: sormbr :md5sum: 30eacbb06a36a13208c27693866dce81 :category: :subroutine :arguments: - vect: :type: char :intent: input - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - MIN(nq,k) - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - MIN(nq,k) - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: nq: "lsame_(&side,\"L\") ? m : lsame_(&side,\"R\") ? n : 0" :fortran_help: " SUBROUTINE SORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * If VECT = 'Q', SORMBR overwrites the general real M-by-N matrix C\n\ * with\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'T': Q**T * C C * Q**T\n\ *\n\ * If VECT = 'P', SORMBR overwrites the general real M-by-N matrix C\n\ * with\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': P * C C * P\n\ * TRANS = 'T': P**T * C C * P**T\n\ *\n\ * Here Q and P**T are the orthogonal matrices determined by SGEBRD when\n\ * reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and\n\ * P**T are defined as products of elementary reflectors H(i) and G(i)\n\ * respectively.\n\ *\n\ * Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the\n\ * order of the orthogonal matrix Q or P**T that is applied.\n\ *\n\ * If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:\n\ * if nq >= k, Q = H(1) H(2) . . . H(k);\n\ * if nq < k, Q = H(1) H(2) . . . H(nq-1).\n\ *\n\ * If VECT = 'P', A is assumed to have been a K-by-NQ matrix:\n\ * if k < nq, P = G(1) G(2) . . . G(k);\n\ * if k >= nq, P = G(1) G(2) . . . G(nq-1).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * VECT (input) CHARACTER*1\n\ * = 'Q': apply Q or Q**T;\n\ * = 'P': apply P or P**T.\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q, Q**T, P or P**T from the Left;\n\ * = 'R': apply Q, Q**T, P or P**T from the Right.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q or P;\n\ * = 'T': Transpose, apply Q**T or P**T.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * If VECT = 'Q', the number of columns in the original\n\ * matrix reduced by SGEBRD.\n\ * If VECT = 'P', the number of rows in the original\n\ * matrix reduced by SGEBRD.\n\ * K >= 0.\n\ *\n\ * A (input) REAL array, dimension\n\ * (LDA,min(nq,K)) if VECT = 'Q'\n\ * (LDA,nq) if VECT = 'P'\n\ * The vectors which define the elementary reflectors H(i) and\n\ * G(i), whose products determine the matrices Q and P, as\n\ * returned by SGEBRD.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ * If VECT = 'Q', LDA >= max(1,nq);\n\ * if VECT = 'P', LDA >= max(1,min(nq,K)).\n\ *\n\ * TAU (input) REAL array, dimension (min(nq,K))\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i) or G(i) which determines Q or P, as returned\n\ * by SGEBRD in the array argument TAUQ or TAUP.\n\ *\n\ * C (input/output) REAL array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q\n\ * or P*C or P**T*C or C*P or C*P**T.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace/output) REAL 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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M).\n\ * For optimum performance LWORK >= N*NB if SIDE = 'L', and\n\ * LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n\ * 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\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN\n CHARACTER TRANST\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL ILAENV, LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SORMLQ, SORMQR, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dsytri2x0000644000175000017500000000532312502223526017003 0ustar uwabamiuwabami--- :name: dsytri2x :md5sum: 683ca7b4f920246786909d9f75b2ce4b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublereal :intent: workspace :dims: - n+nb+1 - nb+3 - nb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSYTRI2X computes the inverse of a real symmetric indefinite matrix\n\ * A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n\ * DSYTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the NNB diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L as computed by DSYTRF.\n\ *\n\ * On exit, if INFO = 0, the (symmetric) inverse of the original\n\ * matrix. If UPLO = 'U', the upper triangular part of the\n\ * inverse is formed and the part of A below the diagonal is not\n\ * referenced; if UPLO = 'L' the lower triangular part of the\n\ * inverse is formed and the part of A above the diagonal is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the NNB structure of D\n\ * as determined by DSYTRF.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (N+NNB+1,NNB+3)\n\ *\n\ * NB (input) INTEGER\n\ * Block size\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, D(i,i) = 0; the matrix is singular and its\n\ * inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgebd20000644000175000017500000001316412502223525016342 0ustar uwabamiuwabami--- :name: cgebd2 :md5sum: 4e86e4849b5df918a38a3984c6f19adf :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: real :intent: output :dims: - MIN(m,n) - e: :type: real :intent: output :dims: - MIN(m,n)-1 - tauq: :type: complex :intent: output :dims: - MIN(m,n) - taup: :type: complex :intent: output :dims: - MIN(m,n) - work: :type: complex :intent: workspace :dims: - MAX(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGEBD2 reduces a complex general m by n matrix A to upper or lower\n\ * real bidiagonal form B by a unitary transformation: Q' * A * P = B.\n\ *\n\ * If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows in the matrix A. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns in the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the m by n general matrix to be reduced.\n\ * On exit,\n\ * if m >= n, the diagonal and the first superdiagonal are\n\ * overwritten with the upper bidiagonal matrix B; the\n\ * elements below the diagonal, with the array TAUQ, represent\n\ * the unitary matrix Q as a product of elementary\n\ * reflectors, and the elements above the first superdiagonal,\n\ * with the array TAUP, represent the unitary matrix P as\n\ * a product of elementary reflectors;\n\ * if m < n, the diagonal and the first subdiagonal are\n\ * overwritten with the lower bidiagonal matrix B; the\n\ * elements below the first subdiagonal, with the array TAUQ,\n\ * represent the unitary matrix Q as a product of\n\ * elementary reflectors, and the elements above the diagonal,\n\ * with the array TAUP, represent the unitary matrix P as\n\ * a product of elementary reflectors.\n\ * See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * D (output) REAL array, dimension (min(M,N))\n\ * The diagonal elements of the bidiagonal matrix B:\n\ * D(i) = A(i,i).\n\ *\n\ * E (output) REAL array, dimension (min(M,N)-1)\n\ * The off-diagonal elements of the bidiagonal matrix B:\n\ * if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n\ * if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n\ *\n\ * TAUQ (output) COMPLEX array dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the unitary matrix Q. See Further Details.\n\ *\n\ * TAUP (output) COMPLEX array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the unitary matrix P. See Further Details.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (max(M,N))\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 matrices Q and P are represented as products of elementary\n\ * reflectors:\n\ *\n\ * If m >= n,\n\ *\n\ * Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)\n\ *\n\ * Each H(i) and G(i) has the form:\n\ *\n\ * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n\ *\n\ * where tauq and taup are complex scalars, and v and u are complex\n\ * vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in\n\ * A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in\n\ * A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n\ *\n\ * If m < n,\n\ *\n\ * Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)\n\ *\n\ * Each H(i) and G(i) has the form:\n\ *\n\ * H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'\n\ *\n\ * where tauq and taup are complex scalars, v and u are complex vectors;\n\ * v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);\n\ * u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);\n\ * tauq is stored in TAUQ(i) and taup in TAUP(i).\n\ *\n\ * The contents of A on exit are illustrated by the following examples:\n\ *\n\ * m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):\n\ *\n\ * ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )\n\ * ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )\n\ * ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )\n\ * ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )\n\ * ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )\n\ * ( v1 v2 v3 v4 v5 )\n\ *\n\ * where d and e denote diagonal and off-diagonal elements of B, vi\n\ * denotes an element of the vector defining H(i), and ui an element of\n\ * the vector defining G(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlaqhb0000644000175000017500000000646012502223526016477 0ustar uwabamiuwabami--- :name: zlaqhb :md5sum: 93d6db03126ffc6978f3941fef25ee6c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - n - scond: :type: doublereal :intent: input - amax: :type: doublereal :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZLAQHB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAQHB equilibrates a symmetric band matrix A using the scaling\n\ * factors in the vector S.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of super-diagonals of the matrix A if UPLO = 'U',\n\ * or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) COMPLEX*16 array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * On exit, if INFO = 0, the triangular factor U or L from the\n\ * Cholesky factorization A = U'*U or A = L*L' of the band\n\ * matrix A, in the same storage format as A.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * S (output) DOUBLE PRECISION array, dimension (N)\n\ * The scale factors for A.\n\ *\n\ * SCOND (input) DOUBLE PRECISION\n\ * Ratio of the smallest S(i) to the largest S(i).\n\ *\n\ * AMAX (input) DOUBLE PRECISION\n\ * Absolute value of largest matrix entry.\n\ *\n\ * EQUED (output) CHARACTER*1\n\ * Specifies whether or not equilibration was done.\n\ * = 'N': No equilibration.\n\ * = 'Y': Equilibration was done, i.e., A has been replaced by\n\ * diag(S) * A * diag(S).\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * THRESH is a threshold value used to decide if scaling should be done\n\ * based on the ratio of the scaling factors. If SCOND < THRESH,\n\ * scaling is done.\n\ *\n\ * LARGE and SMALL are threshold values used to decide if scaling should\n\ * be done based on the absolute size of the largest matrix element.\n\ * If AMAX > LARGE or AMAX < SMALL, scaling is done.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zunmlq0000644000175000017500000001057512502223526016546 0ustar uwabamiuwabami--- :name: zunmlq :md5sum: 83a4204ef6a273e82e35b38f0fd5c3ab :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZUNMLQ overwrites the general complex M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'C': Q**H * C C * Q**H\n\ *\n\ * where Q is a complex unitary matrix defined as the product of k\n\ * elementary reflectors\n\ *\n\ * Q = H(k)' . . . H(2)' H(1)'\n\ *\n\ * as returned by ZGELQF. Q is of order M if SIDE = 'L' and of order N\n\ * if SIDE = 'R'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**H from the Left;\n\ * = 'R': apply Q or Q**H from the Right.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q;\n\ * = 'C': Conjugate transpose, apply Q**H.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines\n\ * the matrix Q.\n\ * If SIDE = 'L', M >= K >= 0;\n\ * if SIDE = 'R', N >= K >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension\n\ * (LDA,M) if SIDE = 'L',\n\ * (LDA,N) if SIDE = 'R'\n\ * The i-th row must contain the vector which defines the\n\ * elementary reflector H(i), for i = 1,2,...,k, as returned by\n\ * ZGELQF in the first k rows of its array argument A.\n\ * A is modified by the routine but restored on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,K).\n\ *\n\ * TAU (input) COMPLEX*16 array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by ZGELQF.\n\ *\n\ * C (input/output) COMPLEX*16 array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M).\n\ * For optimum performance LWORK >= N*NB if SIDE 'L', and\n\ * LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n\ * 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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dporfs0000644000175000017500000001155012502223526016507 0ustar uwabamiuwabami--- :name: dporfs :md5sum: b4307ba92a3d50b996c44d29f72b64d3 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPORFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is symmetric positive definite,\n\ * and provides error bounds and backward error estimates for the\n\ * solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular part\n\ * of the matrix A, and the strictly lower triangular part of A\n\ * is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of A contains the lower triangular part of\n\ * the matrix A, and the strictly upper triangular part of A is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T, as computed by DPOTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by DPOTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/csytf20000644000175000017500000001275012502223525016426 0ustar uwabamiuwabami--- :name: csytf2 :md5sum: a866e0c8cb88e0e0931d644bd4f44e78 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CSYTF2( UPLO, N, A, LDA, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSYTF2 computes the factorization of a complex symmetric matrix A\n\ * using the Bunch-Kaufman diagonal pivoting method:\n\ *\n\ * A = U*D*U' or A = L*D*L'\n\ *\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, U' is the transpose of U, and D is symmetric and\n\ * block diagonal with 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\ * This is the unblocked version of the algorithm, calling Level 2 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * n-by-n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n-by-n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L (see below for further details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D.\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ * > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular, and division by zero will occur if it\n\ * is used to solve a system of equations.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * 09-29-06 - patch from\n\ * Bobby Cheng, MathWorks\n\ *\n\ * Replace l.209 and l.377\n\ * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN\n\ * by\n\ * IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN\n\ *\n\ * 1-96 - Based on modifications by J. Lewis, Boeing Computer Services\n\ * Company\n\ *\n\ * If UPLO = 'U', then A = U*D*U', where\n\ * U = P(n)*U(n)* ... *P(k)U(k)* ...,\n\ * i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n\ * 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I v 0 ) k-s\n\ * U(k) = ( 0 I 0 ) s\n\ * ( 0 0 I ) n-k\n\ * k-s s n-k\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n\ * If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n\ * and A(k,k), and v overwrites A(1:k-2,k-1:k).\n\ *\n\ * If UPLO = 'L', then A = L*D*L', where\n\ * L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n\ * i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n\ * n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I 0 0 ) k-1\n\ * L(k) = ( 0 I 0 ) s\n\ * ( 0 v I ) n-k-s+1\n\ * k-1 s n-k-s+1\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n\ * If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n\ * and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dla_gercond0000644000175000017500000000764012502223526017460 0ustar uwabamiuwabami--- :name: dla_gercond :md5sum: 2049376510eb05d8caae1262a8c242ec :category: :function :type: doublereal :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - cmode: :type: integer :intent: input - c: :type: doublereal :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: doublereal :intent: input :dims: - 3*n - iwork: :type: integer :intent: input :dims: - n :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION DLA_GERCOND ( TRANS, N, A, LDA, AF, LDAF, IPIV, CMODE, C, INFO, WORK, IWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLA_GERCOND estimates the Skeel condition number of op(A) * op2(C)\n\ * where op2 is determined by CMODE as follows\n\ * CMODE = 1 op2(C) = C\n\ * CMODE = 0 op2(C) = I\n\ * CMODE = -1 op2(C) = inv(C)\n\ * The Skeel condition number cond(A) = norminf( |inv(A)||A| )\n\ * is computed by computing scaling factors R such that\n\ * diag(R)*A*op2(C) is row equilibrated and computing the standard\n\ * infinity-norm condition number.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate Transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n\ * The factors L and U from the factorization\n\ * A = P*L*U as computed by DGETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from the factorization A = P*L*U\n\ * as computed by DGETRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * CMODE (input) INTEGER\n\ * Determines op2(C) in the formula op(A) * op2(C) as follows:\n\ * CMODE = 1 op2(C) = C\n\ * CMODE = 0 op2(C) = I\n\ * CMODE = -1 op2(C) = inv(C)\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension (N)\n\ * The vector C in the formula op(A) * op2(C).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * i > 0: The ith argument is invalid.\n\ *\n\ * WORK (input) DOUBLE PRECISION array, dimension (3*N).\n\ * Workspace.\n\ *\n\ * IWORK (input) INTEGER array, dimension (N).\n\ * Workspace.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE, I, J\n DOUBLE PRECISION AINVNM, TMP\n\ * ..\n\ * .. Local Arrays ..\n INTEGER ISAVE( 3 )\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DLACN2, DGETRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cggsvp0000644000175000017500000001540312502223525016503 0ustar uwabamiuwabami--- :name: cggsvp :md5sum: 73af048d60b53bf36e8099ec211860d9 :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobv: :type: char :intent: input - jobq: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - tola: :type: real :intent: input - tolb: :type: real :intent: input - k: :type: integer :intent: output - l: :type: integer :intent: output - u: :type: complex :intent: output :dims: - ldu - m - ldu: :type: integer :intent: input - v: :type: complex :intent: output :dims: - ldv - p - ldv: :type: integer :intent: input - q: :type: complex :intent: output :dims: - ldq - n - ldq: :type: integer :intent: input - iwork: :type: integer :intent: workspace :dims: - n - rwork: :type: real :intent: workspace :dims: - 2*n - tau: :type: complex :intent: workspace :dims: - n - work: :type: complex :intent: workspace :dims: - MAX(3*n,m - p) - info: :type: integer :intent: output :substitutions: m: lda p: ldb ldq: "lsame_(&jobq,\"Q\") ? MAX(1,n) : 1" ldu: "lsame_(&jobu,\"U\") ? MAX(1,m) : 1" ldv: "lsame_(&jobv,\"V\") ? MAX(1,p) : 1" :fortran_help: " SUBROUTINE CGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, RWORK, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGGSVP computes unitary matrices U, V and Q such that\n\ *\n\ * N-K-L K L\n\ * U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0;\n\ * L ( 0 0 A23 )\n\ * M-K-L ( 0 0 0 )\n\ *\n\ * N-K-L K L\n\ * = K ( 0 A12 A13 ) if M-K-L < 0;\n\ * M-K ( 0 0 A23 )\n\ *\n\ * N-K-L K L\n\ * V'*B*Q = L ( 0 0 B13 )\n\ * P-L ( 0 0 0 )\n\ *\n\ * where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n\ * upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n\ * otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective\n\ * numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the\n\ * conjugate transpose of Z.\n\ *\n\ * This decomposition is the preprocessing step for computing the\n\ * Generalized Singular Value Decomposition (GSVD), see subroutine\n\ * CGGSVD.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBU (input) CHARACTER*1\n\ * = 'U': Unitary matrix U is computed;\n\ * = 'N': U is not computed.\n\ *\n\ * JOBV (input) CHARACTER*1\n\ * = 'V': Unitary matrix V is computed;\n\ * = 'N': V is not computed.\n\ *\n\ * JOBQ (input) CHARACTER*1\n\ * = 'Q': Unitary matrix Q is computed;\n\ * = 'N': Q is not computed.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A. M >= 0.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows of the matrix B. P >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, A contains the triangular (or trapezoidal) matrix\n\ * described in the Purpose section.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,N)\n\ * On entry, the P-by-N matrix B.\n\ * On exit, B contains the triangular matrix described in\n\ * the Purpose section.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,P).\n\ *\n\ * TOLA (input) REAL\n\ * TOLB (input) REAL\n\ * TOLA and TOLB are the thresholds to determine the effective\n\ * numerical rank of matrix B and a subblock of A. Generally,\n\ * they are set to\n\ * TOLA = MAX(M,N)*norm(A)*MACHEPS,\n\ * TOLB = MAX(P,N)*norm(B)*MACHEPS.\n\ * The size of TOLA and TOLB may affect the size of backward\n\ * errors of the decomposition.\n\ *\n\ * K (output) INTEGER\n\ * L (output) INTEGER\n\ * On exit, K and L specify the dimension of the subblocks\n\ * described in Purpose section.\n\ * K + L = effective numerical rank of (A',B')'.\n\ *\n\ * U (output) COMPLEX array, dimension (LDU,M)\n\ * If JOBU = 'U', U contains the unitary matrix U.\n\ * If JOBU = 'N', U is not referenced.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= max(1,M) if\n\ * JOBU = 'U'; LDU >= 1 otherwise.\n\ *\n\ * V (output) COMPLEX array, dimension (LDV,P)\n\ * If JOBV = 'V', V contains the unitary matrix V.\n\ * If JOBV = 'N', V is not referenced.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V. LDV >= max(1,P) if\n\ * JOBV = 'V'; LDV >= 1 otherwise.\n\ *\n\ * Q (output) COMPLEX array, dimension (LDQ,N)\n\ * If JOBQ = 'Q', Q contains the unitary matrix Q.\n\ * If JOBQ = 'N', Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N) if\n\ * JOBQ = 'Q'; LDQ >= 1 otherwise.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (2*N)\n\ *\n\ * TAU (workspace) COMPLEX array, dimension (N)\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (max(3*N,M,P))\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 subroutine uses LAPACK subroutine CGEQPF for the QR factorization\n\ * with column pivoting to detect the effective numerical rank of the\n\ * a matrix. It may be replaced by a better rank determination strategy.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dla_gbamv0000644000175000017500000001212712502223526017127 0ustar uwabamiuwabami--- :name: dla_gbamv :md5sum: 49d5577966474bf7d02e9b741c6d963a :category: :subroutine :arguments: - trans: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - alpha: :type: doublereal :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - ldab: :type: integer :intent: input - x: :type: doublereal :intent: input :dims: - "trans == ilatrans_(\"N\") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )" - incx: :type: integer :intent: input - beta: :type: doublereal :intent: input - y: :type: doublereal :intent: input/output :dims: - "trans == ilatrans_(\"N\") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )" - incy: :type: integer :intent: input :substitutions: lda: MAX( 1, m ) :fortran_help: " SUBROUTINE DLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, INCX, BETA, Y, INCY )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLA_GBAMV performs one of the matrix-vector operations\n\ *\n\ * y := alpha*abs(A)*abs(x) + beta*abs(y),\n\ * or y := alpha*abs(A)'*abs(x) + beta*abs(y),\n\ *\n\ * where alpha and beta are scalars, x and y are vectors and A is an\n\ * m by n matrix.\n\ *\n\ * This function is primarily used in calculating error bounds.\n\ * To protect against underflow during evaluation, components in\n\ * the resulting vector are perturbed away from zero by (N+1)\n\ * times the underflow threshold. To prevent unnecessarily large\n\ * errors for block-structure embedded in general matrices,\n\ * \"symbolically\" zero components are not perturbed. A zero\n\ * entry is considered \"symbolic\" if all multiplications involved\n\ * in computing that entry have at least one zero multiplicand.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * TRANS (input) INTEGER\n\ * On entry, TRANS specifies the operation to be performed as\n\ * follows:\n\ *\n\ * BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y)\n\ * BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n\ * BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y)\n\ *\n\ * Unchanged on exit.\n\ *\n\ * M (input) INTEGER\n\ * On entry, M specifies the number of rows of the matrix A.\n\ * M must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the number of columns of the matrix A.\n\ * N must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * ALPHA - DOUBLE PRECISION\n\ * On entry, ALPHA specifies the scalar alpha.\n\ * Unchanged on exit.\n\ *\n\ * A - DOUBLE PRECISION array of DIMENSION ( LDA, n )\n\ * Before entry, the leading m by n part of the array A must\n\ * contain the matrix of coefficients.\n\ * Unchanged on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * On entry, LDA specifies the first dimension of A as declared\n\ * in the calling (sub) program. LDA must be at least\n\ * max( 1, m ).\n\ * Unchanged on exit.\n\ *\n\ * X (input) DOUBLE PRECISION array, dimension\n\ * ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n\ * and at least\n\ * ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n\ * Before entry, the incremented array X must contain the\n\ * vector x.\n\ * Unchanged on exit.\n\ *\n\ * INCX (input) INTEGER\n\ * On entry, INCX specifies the increment for the elements of\n\ * X. INCX must not be zero.\n\ * Unchanged on exit.\n\ *\n\ * BETA - DOUBLE PRECISION\n\ * On entry, BETA specifies the scalar beta. When BETA is\n\ * supplied as zero then Y need not be set on input.\n\ * Unchanged on exit.\n\ *\n\ * Y (input/output) DOUBLE PRECISION array, dimension\n\ * ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n\ * and at least\n\ * ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n\ * Before entry with BETA non-zero, the incremented array Y\n\ * must contain the vector y. On exit, Y is overwritten by the\n\ * updated vector y.\n\ *\n\ * INCY (input) INTEGER\n\ * On entry, INCY specifies the increment for the elements of\n\ * Y. INCY must not be zero.\n\ * Unchanged on exit.\n\ *\n\ *\n\ * Level 2 Blas routine.\n\ *\n\n\ * =====================================================================\n\n" ruby-lapack-1.7.2/dev/defs/sdisna0000644000175000017500000000566612502223526016506 0ustar uwabamiuwabami--- :name: sdisna :md5sum: eacdd5bc759975817056bcf26a816e55 :category: :subroutine :arguments: - job: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - m - sep: :type: real :intent: output :dims: - "lsame_(&job,\"E\") ? m : ((lsame_(&job,\"L\")) || (lsame_(&job,\"R\"))) ? MIN(m,n) : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SDISNA( JOB, M, N, D, SEP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SDISNA computes the reciprocal condition numbers for the eigenvectors\n\ * of a real symmetric or complex Hermitian matrix or for the left or\n\ * right singular vectors of a general m-by-n matrix. The reciprocal\n\ * condition number is the 'gap' between the corresponding eigenvalue or\n\ * singular value and the nearest other one.\n\ *\n\ * The bound on the error, measured by angle in radians, in the I-th\n\ * computed vector is given by\n\ *\n\ * SLAMCH( 'E' ) * ( ANORM / SEP( I ) )\n\ *\n\ * where ANORM = 2-norm(A) = max( abs( D(j) ) ). SEP(I) is not allowed\n\ * to be smaller than SLAMCH( 'E' )*ANORM in order to limit the size of\n\ * the error bound.\n\ *\n\ * SDISNA may also be used to compute error bounds for eigenvectors of\n\ * the generalized symmetric definite eigenproblem.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * Specifies for which problem the reciprocal condition numbers\n\ * should be computed:\n\ * = 'E': the eigenvectors of a symmetric/Hermitian matrix;\n\ * = 'L': the left singular vectors of a general matrix;\n\ * = 'R': the right singular vectors of a general matrix.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * If JOB = 'L' or 'R', the number of columns of the matrix,\n\ * in which case N >= 0. Ignored if JOB = 'E'.\n\ *\n\ * D (input) REAL array, dimension (M) if JOB = 'E'\n\ * dimension (min(M,N)) if JOB = 'L' or 'R'\n\ * The eigenvalues (if JOB = 'E') or singular values (if JOB =\n\ * 'L' or 'R') of the matrix, in either increasing or decreasing\n\ * order. If singular values, they must be non-negative.\n\ *\n\ * SEP (output) REAL array, dimension (M) if JOB = 'E'\n\ * dimension (min(M,N)) if JOB = 'L' or 'R'\n\ * The reciprocal condition numbers of the vectors.\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dspevx0000644000175000017500000001621312502223526016524 0ustar uwabamiuwabami--- :name: dspevx :md5sum: a6eb1b7151c229ba06ead243be18d9d1 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublereal :intent: input/output :dims: - ldap - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - 8*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSPEVX computes selected eigenvalues and, optionally, eigenvectors\n\ * of a real symmetric matrix A in packed storage. Eigenvalues/vectors\n\ * can be selected by specifying either a range of values or a range of\n\ * indices for the desired eigenvalues.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found;\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found;\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, AP is overwritten by values generated during the\n\ * reduction to tridiagonal form. If UPLO = 'U', the diagonal\n\ * and first superdiagonal of the tridiagonal matrix T overwrite\n\ * the corresponding elements of A, and if UPLO = 'L', the\n\ * diagonal and first subdiagonal of T overwrite the\n\ * corresponding elements of A.\n\ *\n\ * VL (input) DOUBLE PRECISION\n\ * VU (input) DOUBLE PRECISION\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) DOUBLE PRECISION\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less than\n\ * or equal to zero, then EPS*|T| will be used in its place,\n\ * where |T| is the 1-norm of the tridiagonal matrix obtained\n\ * by reducing AP to tridiagonal form.\n\ *\n\ * Eigenvalues will be computed most accurately when ABSTOL is\n\ * set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n\ * If this routine returns with INFO>0, indicating that some\n\ * eigenvectors did not converge, try setting ABSTOL to\n\ * 2*DLAMCH('S').\n\ *\n\ * See \"Computing Small Singular Values of Bidiagonal Matrices\n\ * with Guaranteed High Relative Accuracy,\" by Demmel and\n\ * Kahan, LAPACK Working Note #3.\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, the selected eigenvalues in ascending order.\n\ *\n\ * Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))\n\ * If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix A\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * If an eigenvector fails to converge, then that column of Z\n\ * contains the latest approximation to the eigenvector, and the\n\ * index of the eigenvector is returned in IFAIL.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (8*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (5*N)\n\ *\n\ * IFAIL (output) INTEGER array, dimension (N)\n\ * If JOBZ = 'V', then if INFO = 0, the first M elements of\n\ * IFAIL are zero. If INFO > 0, then IFAIL contains the\n\ * indices of the eigenvectors that failed to converge.\n\ * If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n\ * Their indices are stored in array IFAIL.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ilazlc0000644000175000017500000000202112502223526016461 0ustar uwabamiuwabami--- :name: ilazlc :md5sum: 62fe4cba939ea297087c8d208791a31b :category: :function :type: integer :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " INTEGER FUNCTION ILAZLC( M, N, A, LDA )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ILAZLC scans A for its last non-zero column.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix A.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * 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\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chesvxx0000644000175000017500000005131512502223525016704 0ustar uwabamiuwabami--- :name: chesvxx :md5sum: 3b7d96ee13fb907e462bbb16f1bba231 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - equed: :type: char :intent: input/output - s: :type: real :intent: input/output :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - rpvgrw: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " SUBROUTINE CHESVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHESVXX uses the diagonal pivoting factorization to compute the\n\ * solution to a complex system of linear equations A * X = B, where\n\ * A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n\ * matrices.\n\ *\n\ * If requested, both normwise and maximum componentwise error bounds\n\ * are returned. CHESVXX will return a solution with a tiny\n\ * guaranteed error (O(eps) where eps is the working machine\n\ * precision) unless the matrix is very ill-conditioned, in which\n\ * case a warning is returned. Relevant condition numbers also are\n\ * calculated and returned.\n\ *\n\ * CHESVXX accepts user-provided factorizations and equilibration\n\ * factors; see the definitions of the FACT and EQUED options.\n\ * Solving with refinement and using a factorization from a previous\n\ * CHESVXX call will also produce a solution with either O(eps)\n\ * errors or warnings, but we cannot make that claim for general\n\ * user-provided factorizations and equilibration factors if they\n\ * differ from what CHESVXX would itself produce.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', real scaling factors are computed to equilibrate\n\ * the system:\n\ *\n\ * diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B\n\ *\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n\ *\n\ * 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n\ * the matrix A (after equilibration if FACT = 'E') as\n\ *\n\ * A = U * D * U**T, if UPLO = 'U', or\n\ * A = L * D * L**T, if UPLO = 'L',\n\ *\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, and D is symmetric and block diagonal with\n\ * 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\ * 3. If some D(i,i)=0, so that D is exactly singular, then the\n\ * routine returns with INFO = i. Otherwise, the factored form of A\n\ * is used to estimate the condition number of the matrix A (see\n\ * argument RCOND). If the reciprocal of the condition number is\n\ * less than machine precision, the routine still goes on to solve\n\ * for X and compute error bounds as described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n\ * the routine will use iterative refinement to try to get a small\n\ * error and error bounds. Refinement calculates the residual to at\n\ * least twice the working precision.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(R) so that it solves the original system before\n\ * equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AF and IPIV contain the factored form of A.\n\ * If EQUED is not 'N', the matrix A has been\n\ * equilibrated with scaling factors given by S.\n\ * A, AF, and IPIV are not modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AF and factored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * The symmetric matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of A contains the upper triangular\n\ * part of the matrix A, and the strictly lower triangular\n\ * part of A is not referenced. If UPLO = 'L', the leading\n\ * N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n\ * diag(S)*A*diag(S).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input or output) COMPLEX array, dimension (LDAF,N)\n\ * If FACT = 'F', then AF is an input argument and on entry\n\ * contains the block diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L from the factorization A =\n\ * U*D*U**T or A = L*D*L**T as computed by SSYTRF.\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the block diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L from the factorization A =\n\ * U*D*U**T or A = L*D*L**T.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains details of the interchanges and the block\n\ * structure of D, as determined by CHETRF. If IPIV(k) > 0,\n\ * then rows and columns k and IPIV(k) were interchanged and\n\ * D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and\n\ * IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and\n\ * -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2\n\ * diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0,\n\ * then rows and columns k+1 and -IPIV(k) were interchanged\n\ * and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains details of the interchanges and the block\n\ * structure of D, as determined by CHETRF.\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'Y': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(S) * A * diag(S).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * S (input or output) REAL array, dimension (N)\n\ * The scale factors for A. If EQUED = 'Y', A is multiplied on\n\ * the left and right by diag(S). S is an input argument if FACT =\n\ * 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n\ * = 'Y', each element of S must be positive. If S is output, each\n\ * element of S is a power of the radix. If S is input, each element\n\ * of S should be a power of the radix to ensure a reliable solution\n\ * and error estimates. Scaling by powers of the radix does not cause\n\ * rounding errors unless the result underflows or overflows.\n\ * Rounding errors during scaling lead to refining with a matrix that\n\ * is not equivalent to the input matrix, producing error estimates\n\ * that may not be reliable.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit,\n\ * if EQUED = 'N', B is not modified;\n\ * if EQUED = 'Y', B is overwritten by diag(S)*B;\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX array, dimension (LDX,NRHS)\n\ * If INFO = 0, the N-by-NRHS solution matrix X to the original\n\ * system of equations. Note that A and B are modified on exit if\n\ * EQUED .ne. 'N', and the solution to the equilibrated system is\n\ * inv(diag(S))*X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * RPVGRW (output) REAL\n\ * Reciprocal pivot growth. On exit, this contains the reciprocal\n\ * pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n\ * norm is used. If this is much less than 1, then the stability of\n\ * the LU factorization of the (equilibrated) matrix A could be poor.\n\ * This also means that the solution X, estimated condition numbers,\n\ * and error bounds could be unreliable. If factorization fails with\n\ * 0 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slansy0000644000175000017500000000610512502223526016523 0ustar uwabamiuwabami--- :name: slansy :md5sum: 9ac8e2d4146d44485b5a4e92c90c712c :category: :function :type: real :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "((lsame_(&norm,\"I\")) || ((('1') || ('o')))) ? n : 0" :fortran_help: " REAL FUNCTION SLANSY( NORM, UPLO, N, A, LDA, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLANSY returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * real symmetric matrix A.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * SLANSY returns the value\n\ *\n\ * SLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in SLANSY as described\n\ * above.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is to be referenced.\n\ * = 'U': Upper triangular part of A is referenced\n\ * = 'L': Lower triangular part of A is referenced\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, SLANSY is\n\ * set to zero.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * The symmetric matrix A. If UPLO = 'U', the leading n by n\n\ * upper triangular part of A contains the upper triangular part\n\ * of the matrix A, and the strictly lower triangular part of A\n\ * is not referenced. If UPLO = 'L', the leading n by n lower\n\ * triangular part of A contains the lower triangular part of\n\ * the matrix A, and the strictly upper triangular part of A is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(N,1).\n\ *\n\ * WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n\ * WORK is not referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cla_herpvgrw0000644000175000017500000000622712502223525017701 0ustar uwabamiuwabami--- :name: cla_herpvgrw :md5sum: f26107fad597783e3c6c1c2b8110cc14 :category: :function :type: real :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - info: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: complex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: complex :intent: input :dims: - 2*n :substitutions: {} :fortran_help: " REAL FUNCTION CLA_HERPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, WORK )\n\n\ * Purpose\n\ * =======\n\ * \n\ * CLA_HERPVGRW computes the reciprocal pivot growth factor\n\ * norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n\ * much less than 1, the stability of the LU factorization of the\n\ * (equilibrated) matrix A could be poor. This also means that the\n\ * solution X, estimated condition numbers, and error bounds could be\n\ * unreliable.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * INFO (input) INTEGER\n\ * The value of INFO returned from SSYTRF, .i.e., the pivot in\n\ * column INFO is exactly 0.\n\ *\n\ * NCOLS (input) INTEGER\n\ * The number of columns of the matrix A. NCOLS >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX array, dimension (LDAF,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by CHETRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by CHETRF.\n\ *\n\ * WORK (input) COMPLEX array, dimension (2*N)\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER NCOLS, I, J, K, KP\n REAL AMAX, UMAX, RPVGRW, TMP\n LOGICAL UPPER, LSAME\n COMPLEX ZDUM\n\ * ..\n\ * .. External Functions ..\n EXTERNAL LSAME, CLASET\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, REAL, AIMAG, MAX, MIN\n\ * ..\n\ * .. Statement Functions ..\n REAL CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL ( ZDUM ) ) + ABS( AIMAG ( ZDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlarz0000644000175000017500000000576712502223526016343 0ustar uwabamiuwabami--- :name: dlarz :md5sum: 61bd58498447c9dba40be54132c17b25 :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - l: :type: integer :intent: input - v: :type: doublereal :intent: input :dims: - 1+(l-1)*abs(incv) - incv: :type: integer :intent: input - tau: :type: doublereal :intent: input - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " SUBROUTINE DLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLARZ applies a real elementary reflector H to a real M-by-N\n\ * matrix C, from either the left or the right. H is represented in the\n\ * form\n\ *\n\ * H = I - tau * v * v'\n\ *\n\ * where tau is a real scalar and v is a real vector.\n\ *\n\ * If tau = 0, then H is taken to be the unit matrix.\n\ *\n\ *\n\ * H is a product of k elementary reflectors as returned by DTZRZF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': form H * C\n\ * = 'R': form C * H\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C.\n\ *\n\ * L (input) INTEGER\n\ * The number of entries of the vector V containing\n\ * the meaningful part of the Householder vectors.\n\ * If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n\ *\n\ * V (input) DOUBLE PRECISION array, dimension (1+(L-1)*abs(INCV))\n\ * The vector v in the representation of H as returned by\n\ * DTZRZF. V is not used if TAU = 0.\n\ *\n\ * INCV (input) INTEGER\n\ * The increment between elements of v. INCV <> 0.\n\ *\n\ * TAU (input) DOUBLE PRECISION\n\ * The value tau in the representation of H.\n\ *\n\ * C (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n\ * or C * H if SIDE = 'R'.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension\n\ * (N) if SIDE = 'L'\n\ * or (M) if SIDE = 'R'\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlaed70000644000175000017500000001777312655767354016414 0ustar uwabamiuwabami--- :name: dlaed7 :md5sum: 28c523ba917e198d63509b14a5f28ee1 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - n: :type: integer :intent: input - qsiz: :type: integer :intent: input - tlvls: :type: integer :intent: input - curlvl: :type: integer :intent: input - curpbm: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - q: :type: doublereal :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - indxq: :type: integer :intent: output :dims: - n - rho: :type: doublereal :intent: input - cutpnt: :type: integer :intent: input - qstore: :type: doublereal :intent: input/output :dims: - pow(n,2)+1 - qptr: :type: integer :intent: input/output :dims: - n+2 - prmptr: :type: integer :intent: input :dims: - n*LG(n) - perm: :type: integer :intent: input :dims: - n*LG(n) - givptr: :type: integer :intent: input :dims: - n*LG(n) - givcol: :type: integer :intent: input :dims: - "2" - n*LG(n) - givnum: :type: doublereal :intent: input :dims: - "2" - n*LG(n) - work: :type: doublereal :intent: workspace :dims: - 3*n+qsiz*n - iwork: :type: integer :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR, PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAED7 computes the updated eigensystem of a diagonal\n\ * matrix after modification by a rank-one symmetric matrix. This\n\ * routine is used only for the eigenproblem which requires all\n\ * eigenvalues and optionally eigenvectors of a dense symmetric matrix\n\ * that has been reduced to tridiagonal form. DLAED1 handles\n\ * the case in which all eigenvalues and eigenvectors of a symmetric\n\ * tridiagonal matrix are desired.\n\ *\n\ * T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)\n\ *\n\ * where Z = Q'u, u is a vector of length N with ones in the\n\ * CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.\n\ *\n\ * The eigenvectors of the original matrix are stored in Q, and the\n\ * eigenvalues are in D. The algorithm consists of three stages:\n\ *\n\ * The first stage consists of deflating the size of the problem\n\ * when there are multiple eigenvalues or if there is a zero in\n\ * the Z vector. For each such occurrence the dimension of the\n\ * secular equation problem is reduced by one. This stage is\n\ * performed by the routine DLAED8.\n\ *\n\ * The second stage consists of calculating the updated\n\ * eigenvalues. This is done by finding the roots of the secular\n\ * equation via the routine DLAED4 (as called by DLAED9).\n\ * This routine also calculates the eigenvectors of the current\n\ * problem.\n\ *\n\ * The final stage consists of computing the updated eigenvectors\n\ * directly using the updated eigenvalues. The eigenvectors for\n\ * the current problem are multiplied with the eigenvectors from\n\ * the overall problem.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ICOMPQ (input) INTEGER\n\ * = 0: Compute eigenvalues only.\n\ * = 1: Compute eigenvectors of original dense symmetric matrix\n\ * also. On entry, Q contains the orthogonal matrix used\n\ * to reduce the original matrix to tridiagonal form.\n\ *\n\ * N (input) INTEGER\n\ * The dimension of the symmetric tridiagonal matrix. N >= 0.\n\ *\n\ * QSIZ (input) INTEGER\n\ * The dimension of the orthogonal matrix used to reduce\n\ * the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.\n\ *\n\ * TLVLS (input) INTEGER\n\ * The total number of merging levels in the overall divide and\n\ * conquer tree.\n\ *\n\ * CURLVL (input) INTEGER\n\ * The current level in the overall merge routine,\n\ * 0 <= CURLVL <= TLVLS.\n\ *\n\ * CURPBM (input) INTEGER\n\ * The current problem in the current level in the overall\n\ * merge routine (counting from upper left to lower right).\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the eigenvalues of the rank-1-perturbed matrix.\n\ * On exit, the eigenvalues of the repaired matrix.\n\ *\n\ * Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)\n\ * On entry, the eigenvectors of the rank-1-perturbed matrix.\n\ * On exit, the eigenvectors of the repaired tridiagonal matrix.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N).\n\ *\n\ * INDXQ (output) INTEGER array, dimension (N)\n\ * The permutation which will reintegrate the subproblem just\n\ * solved back into sorted order, i.e., D( INDXQ( I = 1, N ) )\n\ * will be in ascending order.\n\ *\n\ * RHO (input) DOUBLE PRECISION\n\ * The subdiagonal element used to create the rank-1\n\ * modification.\n\ *\n\ * CUTPNT (input) INTEGER\n\ * Contains the location of the last eigenvalue in the leading\n\ * sub-matrix. min(1,N) <= CUTPNT <= N.\n\ *\n\ * QSTORE (input/output) DOUBLE PRECISION array, dimension (N**2+1)\n\ * Stores eigenvectors of submatrices encountered during\n\ * divide and conquer, packed together. QPTR points to\n\ * beginning of the submatrices.\n\ *\n\ * QPTR (input/output) INTEGER array, dimension (N+2)\n\ * List of indices pointing to beginning of submatrices stored\n\ * in QSTORE. The submatrices are numbered starting at the\n\ * bottom left of the divide and conquer tree, from left to\n\ * right and bottom to top.\n\ *\n\ * PRMPTR (input) INTEGER array, dimension (N lg N)\n\ * Contains a list of pointers which indicate where in PERM a\n\ * level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)\n\ * indicates the size of the permutation and also the size of\n\ * the full, non-deflated problem.\n\ *\n\ * PERM (input) INTEGER array, dimension (N lg N)\n\ * Contains the permutations (from deflation and sorting) to be\n\ * applied to each eigenblock.\n\ *\n\ * GIVPTR (input) INTEGER array, dimension (N lg N)\n\ * Contains a list of pointers which indicate where in GIVCOL a\n\ * level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)\n\ * indicates the number of Givens rotations.\n\ *\n\ * GIVCOL (input) INTEGER array, dimension (2, N lg N)\n\ * Each pair of numbers indicates a pair of columns to take place\n\ * in a Givens rotation.\n\ *\n\ * GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N)\n\ * Each number indicates the S value to be used in the\n\ * corresponding Givens rotation.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (3*N+QSIZ*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (4*N)\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 = 1, an eigenvalue did not converge\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Jeff Rutter, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sstemr0000644000175000017500000002734612502223526016541 0ustar uwabamiuwabami--- :name: sstemr :md5sum: 2493f4287dcea620213b2c3c882bda51 :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - nzc: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - tryrac: :type: logical :intent: input/output - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 18*n : lsame_(&jobz,\"N\") ? 12*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 10*n : lsame_(&jobz,\"N\") ? 8*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " SUBROUTINE SSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSTEMR computes selected eigenvalues and, optionally, eigenvectors\n\ * of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n\ * a well defined set of pairwise different real eigenvalues, the corresponding\n\ * real eigenvectors are pairwise orthogonal.\n\ *\n\ * The spectrum may be computed either completely or partially by specifying\n\ * either an interval (VL,VU] or a range of indices IL:IU for the desired\n\ * eigenvalues.\n\ *\n\ * Depending on the number of desired eigenvalues, these are computed either\n\ * by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are\n\ * computed by the use of various suitable L D L^T factorizations near clusters\n\ * of close eigenvalues (referred to as RRRs, Relatively Robust\n\ * Representations). An informal sketch of the algorithm follows.\n\ *\n\ * For each unreduced block (submatrix) of T,\n\ * (a) Compute T - sigma I = L D L^T, so that L and D\n\ * define all the wanted eigenvalues to high relative accuracy.\n\ * This means that small relative changes in the entries of D and L\n\ * cause only small relative changes in the eigenvalues and\n\ * eigenvectors. The standard (unfactored) representation of the\n\ * tridiagonal matrix T does not have this property in general.\n\ * (b) Compute the eigenvalues to suitable accuracy.\n\ * If the eigenvectors are desired, the algorithm attains full\n\ * accuracy of the computed eigenvalues only right before\n\ * the corresponding vectors have to be computed, see steps c) and d).\n\ * (c) For each cluster of close eigenvalues, select a new\n\ * shift close to the cluster, find a new factorization, and refine\n\ * the shifted eigenvalues to suitable accuracy.\n\ * (d) For each eigenvalue with a large enough relative separation compute\n\ * the corresponding eigenvector by forming a rank revealing twisted\n\ * factorization. Go back to (c) for any clusters that remain.\n\ *\n\ * For more details, see:\n\ * - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n\ * to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n\ * Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n\ * - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n\ * Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n\ * 2004. Also LAPACK Working Note 154.\n\ * - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n\ * tridiagonal eigenvalue/eigenvector problem\",\n\ * Computer Science Division Technical Report No. UCB/CSD-97-971,\n\ * UC Berkeley, May 1997.\n\ *\n\ * Further Details\n\ * 1.SSTEMR works only on machines which follow IEEE-754\n\ * floating-point standard in their handling of infinities and NaNs.\n\ * This permits the use of efficient inner loops avoiding a check for\n\ * zero divisors.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found.\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found.\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the N diagonal elements of the tridiagonal matrix\n\ * T. On exit, D is overwritten.\n\ *\n\ * E (input/output) REAL array, dimension (N)\n\ * On entry, the (N-1) subdiagonal elements of the tridiagonal\n\ * matrix T in elements 1 to N-1 of E. E(N) need not be set on\n\ * input, but is used internally as workspace.\n\ * On exit, E is overwritten.\n\ *\n\ * VL (input) REAL\n\ * VU (input) REAL\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * The first M elements contain the selected eigenvalues in\n\ * ascending order.\n\ *\n\ * Z (output) REAL array, dimension (LDZ, max(1,M) )\n\ * If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix T\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and can be computed with a workspace\n\ * query by setting NZC = -1, see below.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', then LDZ >= max(1,N).\n\ *\n\ * NZC (input) INTEGER\n\ * The number of eigenvectors to be held in the array Z.\n\ * If RANGE = 'A', then NZC >= max(1,N).\n\ * If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].\n\ * If RANGE = 'I', then NZC >= IU-IL+1.\n\ * If NZC = -1, then a workspace query is assumed; the\n\ * routine calculates the number of columns of the array Z that\n\ * are needed to hold the eigenvectors.\n\ * This value is returned as the first entry of the Z array, and\n\ * no error message related to NZC is issued by XERBLA.\n\ *\n\ * ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n\ * The support of the eigenvectors in Z, i.e., the indices\n\ * indicating the nonzero elements in Z. The i-th computed eigenvector\n\ * is nonzero only in elements ISUPPZ( 2*i-1 ) through\n\ * ISUPPZ( 2*i ). This is relevant in the case when the matrix\n\ * is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n\ *\n\ * TRYRAC (input/output) LOGICAL\n\ * If TRYRAC.EQ..TRUE., indicates that the code should check whether\n\ * the tridiagonal matrix defines its eigenvalues to high relative\n\ * accuracy. If so, the code uses relative-accuracy preserving\n\ * algorithms that might be (a bit) slower depending on the matrix.\n\ * If the matrix does not define its eigenvalues to high relative\n\ * accuracy, the code can uses possibly faster algorithms.\n\ * If TRYRAC.EQ..FALSE., the code is not required to guarantee\n\ * relatively accurate eigenvalues and can use the fastest possible\n\ * techniques.\n\ * On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix\n\ * does not define its eigenvalues to high relative accuracy.\n\ *\n\ * WORK (workspace/output) REAL array, dimension (LWORK)\n\ * On exit, if INFO = 0, WORK(1) returns the optimal\n\ * (and minimal) LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK >= max(1,18*N)\n\ * if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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\ * IWORK (workspace/output) INTEGER array, dimension (LIWORK)\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK. LIWORK >= max(1,10*N)\n\ * if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n\ * if only the eigenvalues are to be computed.\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal size of the IWORK array,\n\ * returns this value as the first entry of the IWORK array, and\n\ * no error message related to LIWORK is issued by XERBLA.\n\ *\n\ * INFO (output) INTEGER\n\ * On exit, INFO\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: if INFO = 1X, internal error in SLARRE,\n\ * if INFO = 2X, internal error in SLARRV.\n\ * Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n\ * the nonzero error code returned by SLARRE or\n\ * SLARRV, respectively.\n\ *\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Beresford Parlett, University of California, Berkeley, USA\n\ * Jim Demmel, University of California, Berkeley, USA\n\ * Inderjit Dhillon, University of Texas, Austin, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, University of California, Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dtrtri0000644000175000017500000000460012502223526016520 0ustar uwabamiuwabami--- :name: dtrtri :md5sum: 8441a50f1dc21d4959daa59006cdb017 :category: :subroutine :arguments: - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTRTRI computes the inverse of a real upper or lower triangular\n\ * matrix A.\n\ *\n\ * This is the Level 3 BLAS version of the algorithm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the triangular matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of the array A contains\n\ * the upper triangular matrix, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of the array A contains\n\ * the lower triangular matrix, and the strictly upper\n\ * triangular part of A is not referenced. If DIAG = 'U', the\n\ * diagonal elements of A are also not referenced and are\n\ * assumed to be 1.\n\ * On exit, the (triangular) inverse of the original matrix, in\n\ * the same storage format.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\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, A(i,i) is exactly zero. The triangular\n\ * matrix is singular and its inverse can not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlatzm0000644000175000017500000000725212502223526016537 0ustar uwabamiuwabami--- :name: zlatzm :md5sum: 45cc18e2b860b2494dfd1b976ed8f61b :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - v: :type: doublecomplex :intent: input :dims: - 1 + (m-1)*abs(incv) - incv: :type: integer :intent: input - tau: :type: doublecomplex :intent: input - c1: :type: doublecomplex :intent: input/output :dims: - "lsame_(&side,\"L\") ? ldc : lsame_(&side,\"R\") ? m : 0" - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? 1 : 0" - c2: :type: doublecomplex :intent: input/output :dims: - ldc - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? n-1 : 0" - ldc: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " SUBROUTINE ZLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This routine is deprecated and has been replaced by routine ZUNMRZ.\n\ *\n\ * ZLATZM applies a Householder matrix generated by ZTZRQF to a matrix.\n\ *\n\ * Let P = I - tau*u*u', u = ( 1 ),\n\ * ( v )\n\ * where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if\n\ * SIDE = 'R'.\n\ *\n\ * If SIDE equals 'L', let\n\ * C = [ C1 ] 1\n\ * [ C2 ] m-1\n\ * n\n\ * Then C is overwritten by P*C.\n\ *\n\ * If SIDE equals 'R', let\n\ * C = [ C1, C2 ] m\n\ * 1 n-1\n\ * Then C is overwritten by C*P.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': form P * C\n\ * = 'R': form C * P\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C.\n\ *\n\ * V (input) COMPLEX*16 array, dimension\n\ * (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n\ * (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n\ * The vector v in the representation of P. V is not used\n\ * if TAU = 0.\n\ *\n\ * INCV (input) INTEGER\n\ * The increment between elements of v. INCV <> 0\n\ *\n\ * TAU (input) COMPLEX*16\n\ * The value tau in the representation of P.\n\ *\n\ * C1 (input/output) COMPLEX*16 array, dimension\n\ * (LDC,N) if SIDE = 'L'\n\ * (M,1) if SIDE = 'R'\n\ * On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1\n\ * if SIDE = 'R'.\n\ *\n\ * On exit, the first row of P*C if SIDE = 'L', or the first\n\ * column of C*P if SIDE = 'R'.\n\ *\n\ * C2 (input/output) COMPLEX*16 array, dimension\n\ * (LDC, N) if SIDE = 'L'\n\ * (LDC, N-1) if SIDE = 'R'\n\ * On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the\n\ * m x (n - 1) matrix C2 if SIDE = 'R'.\n\ *\n\ * On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P\n\ * if SIDE = 'R'.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the arrays C1 and C2.\n\ * LDC >= max(1,M).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension\n\ * (N) if SIDE = 'L'\n\ * (M) if SIDE = 'R'\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dptsv0000644000175000017500000000572612502223526016362 0ustar uwabamiuwabami--- :name: dptsv :md5sum: 8adf057f5fcd9d544d11e80771debc24 :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPTSV( N, NRHS, D, E, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPTSV computes the solution to a real system of linear equations\n\ * A*X = B, where A is an N-by-N symmetric positive definite tridiagonal\n\ * matrix, and X and B are N-by-NRHS matrices.\n\ *\n\ * A is factored as A = L*D*L**T, and the factored form of A is then\n\ * used to solve the system of equations.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the n diagonal elements of the tridiagonal matrix\n\ * A. On exit, the n diagonal elements of the diagonal matrix\n\ * D from the factorization A = L*D*L**T.\n\ *\n\ * E (input/output) DOUBLE PRECISION array, dimension (N-1)\n\ * On entry, the (n-1) subdiagonal elements of the tridiagonal\n\ * matrix A. On exit, the (n-1) subdiagonal elements of the\n\ * unit bidiagonal factor L from the L*D*L**T factorization of\n\ * A. (E can also be regarded as the superdiagonal of the unit\n\ * bidiagonal factor U from the U**T*D*U factorization of A.)\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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 leading minor of order i is not\n\ * positive definite, and the solution has not been\n\ * computed. The factorization has not been completed\n\ * unless i = N.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. External Subroutines ..\n EXTERNAL DPTTRF, DPTTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zgbequb0000644000175000017500000001040612502223526016650 0ustar uwabamiuwabami--- :name: zgbequb :md5sum: cb0bd19ed592f0af1af6e5081b15065e :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - r: :type: doublereal :intent: output :dims: - m - c: :type: doublereal :intent: output :dims: - n - rowcnd: :type: doublereal :intent: output - colcnd: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: m: ldab :fortran_help: " SUBROUTINE ZGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGBEQUB computes row and column scalings intended to equilibrate an\n\ * M-by-N matrix A and reduce its condition number. R returns the row\n\ * scale factors and C the column scale factors, chosen to try to make\n\ * the largest element in each row and column of the matrix B with\n\ * elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n\ * the radix.\n\ *\n\ * R(i) and C(j) are restricted to be a power of the radix between\n\ * SMLNUM = smallest safe number and BIGNUM = largest safe number. Use\n\ * of these scaling factors is not guaranteed to reduce the condition\n\ * number of A but works well in practice.\n\ *\n\ * This routine differs from ZGEEQU by restricting the scaling factors\n\ * to a power of the radix. Baring over- and underflow, scaling by\n\ * these factors introduces no additional rounding errors. However, the\n\ * scaled entries' magnitured are no longer approximately 1 but lie\n\ * between sqrt(radix) and 1/sqrt(radix).\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\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array A. LDAB >= max(1,M).\n\ *\n\ * R (output) DOUBLE PRECISION array, dimension (M)\n\ * If INFO = 0 or INFO > M, R contains the row scale factors\n\ * for A.\n\ *\n\ * C (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, C contains the column scale factors for A.\n\ *\n\ * ROWCND (output) DOUBLE PRECISION\n\ * If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n\ * smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n\ * AMAX is neither too large nor too small, it is not worth\n\ * scaling by R.\n\ *\n\ * COLCND (output) DOUBLE PRECISION\n\ * If INFO = 0, COLCND contains the ratio of the smallest\n\ * C(i) to the largest C(i). If COLCND >= 0.1, it is not\n\ * worth scaling by C.\n\ *\n\ * AMAX (output) DOUBLE PRECISION\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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, and i is\n\ * <= M: the i-th row of A is exactly zero\n\ * > M: the (i-M)-th column of A is exactly zero\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sspgst0000644000175000017500000000507312502223526016540 0ustar uwabamiuwabami--- :name: sspgst :md5sum: 33ef68fb9b8c97de9d8d99a2aa5d9f90 :category: :subroutine :arguments: - itype: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - n*(n+1)/2 - bp: :type: real :intent: input :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SSPGST( ITYPE, UPLO, N, AP, BP, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSPGST reduces a real symmetric-definite generalized eigenproblem\n\ * to standard form, using packed storage.\n\ *\n\ * If ITYPE = 1, the problem is A*x = lambda*B*x,\n\ * and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)\n\ *\n\ * If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n\ * B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.\n\ *\n\ * B must have been previously factorized as U**T*U or L*L**T by SPPTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);\n\ * = 2 or 3: compute U*A*U**T or L**T*A*L.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored and B is factored as\n\ * U**T*U;\n\ * = 'L': Lower triangle of A is stored and B is factored as\n\ * L*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * AP (input/output) REAL array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, if INFO = 0, the transformed matrix, stored in the\n\ * same format as A.\n\ *\n\ * BP (input) REAL array, dimension (N*(N+1)/2)\n\ * The triangular factor from the Cholesky factorization of B,\n\ * stored in the same format as A, as returned by SPPTRF.\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgbequb0000644000175000017500000001040612502223526016622 0ustar uwabamiuwabami--- :name: dgbequb :md5sum: ae4e33ebda663716b4b660ecd0995df2 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - r: :type: doublereal :intent: output :dims: - m - c: :type: doublereal :intent: output :dims: - n - rowcnd: :type: doublereal :intent: output - colcnd: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: m: ldab :fortran_help: " SUBROUTINE DGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGBEQUB computes row and column scalings intended to equilibrate an\n\ * M-by-N matrix A and reduce its condition number. R returns the row\n\ * scale factors and C the column scale factors, chosen to try to make\n\ * the largest element in each row and column of the matrix B with\n\ * elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n\ * the radix.\n\ *\n\ * R(i) and C(j) are restricted to be a power of the radix between\n\ * SMLNUM = smallest safe number and BIGNUM = largest safe number. Use\n\ * of these scaling factors is not guaranteed to reduce the condition\n\ * number of A but works well in practice.\n\ *\n\ * This routine differs from DGEEQU by restricting the scaling factors\n\ * to a power of the radix. Baring over- and underflow, scaling by\n\ * these factors introduces no additional rounding errors. However, the\n\ * scaled entries' magnitured are no longer approximately 1 but lie\n\ * between sqrt(radix) and 1/sqrt(radix).\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\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array A. LDAB >= max(1,M).\n\ *\n\ * R (output) DOUBLE PRECISION array, dimension (M)\n\ * If INFO = 0 or INFO > M, R contains the row scale factors\n\ * for A.\n\ *\n\ * C (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, C contains the column scale factors for A.\n\ *\n\ * ROWCND (output) DOUBLE PRECISION\n\ * If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n\ * smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n\ * AMAX is neither too large nor too small, it is not worth\n\ * scaling by R.\n\ *\n\ * COLCND (output) DOUBLE PRECISION\n\ * If INFO = 0, COLCND contains the ratio of the smallest\n\ * C(i) to the largest C(i). If COLCND >= 0.1, it is not\n\ * worth scaling by C.\n\ *\n\ * AMAX (output) DOUBLE PRECISION\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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, and i is\n\ * <= M: the i-th row of A is exactly zero\n\ * > M: the (i-M)-th column of A is exactly zero\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ztgsna0000644000175000017500000002375212502223526016527 0ustar uwabamiuwabami--- :name: ztgsna :md5sum: bff5e5cd558b65294a02f7c17439aad7 :category: :subroutine :arguments: - job: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - vl: :type: doublecomplex :intent: input :dims: - ldvl - m - ldvl: :type: integer :intent: input - vr: :type: doublecomplex :intent: input :dims: - ldvr - m - ldvr: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - mm - dif: :type: doublereal :intent: output :dims: - mm - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(lsame_(&job,\"V\")||lsame_(&job,\"B\")) ? 2*n*n : n" - iwork: :type: integer :intent: workspace :dims: - "lsame_(&job,\"E\") ? 0 : n+2" - info: :type: integer :intent: output :substitutions: mm: m :fortran_help: " SUBROUTINE ZTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTGSNA estimates reciprocal condition numbers for specified\n\ * eigenvalues and/or eigenvectors of a matrix pair (A, B).\n\ *\n\ * (A, B) must be in generalized Schur canonical form, that is, A and\n\ * B are both upper triangular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * Specifies whether condition numbers are required for\n\ * eigenvalues (S) or eigenvectors (DIF):\n\ * = 'E': for eigenvalues only (S);\n\ * = 'V': for eigenvectors only (DIF);\n\ * = 'B': for both eigenvalues and eigenvectors (S and DIF).\n\ *\n\ * HOWMNY (input) CHARACTER*1\n\ * = 'A': compute condition numbers for all eigenpairs;\n\ * = 'S': compute condition numbers for selected eigenpairs\n\ * specified by the array SELECT.\n\ *\n\ * SELECT (input) LOGICAL array, dimension (N)\n\ * If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n\ * condition numbers are required. To select condition numbers\n\ * for the corresponding j-th eigenvalue and/or eigenvector,\n\ * SELECT(j) must be set to .TRUE..\n\ * If HOWMNY = 'A', SELECT is not referenced.\n\ *\n\ * N (input) INTEGER\n\ * The order of the square matrix pair (A, B). N >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The upper triangular matrix A in the pair (A,B).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,N)\n\ * The upper triangular matrix B in the pair (A, B).\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * VL (input) COMPLEX*16 array, dimension (LDVL,M)\n\ * IF JOB = 'E' or 'B', VL must contain left eigenvectors of\n\ * (A, B), corresponding to the eigenpairs specified by HOWMNY\n\ * and SELECT. The eigenvectors must be stored in consecutive\n\ * columns of VL, as returned by ZTGEVC.\n\ * If JOB = 'V', VL is not referenced.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the array VL. LDVL >= 1; and\n\ * If JOB = 'E' or 'B', LDVL >= N.\n\ *\n\ * VR (input) COMPLEX*16 array, dimension (LDVR,M)\n\ * IF JOB = 'E' or 'B', VR must contain right eigenvectors of\n\ * (A, B), corresponding to the eigenpairs specified by HOWMNY\n\ * and SELECT. The eigenvectors must be stored in consecutive\n\ * columns of VR, as returned by ZTGEVC.\n\ * If JOB = 'V', VR is not referenced.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the array VR. LDVR >= 1;\n\ * If JOB = 'E' or 'B', LDVR >= N.\n\ *\n\ * S (output) DOUBLE PRECISION array, dimension (MM)\n\ * If JOB = 'E' or 'B', the reciprocal condition numbers of the\n\ * selected eigenvalues, stored in consecutive elements of the\n\ * array.\n\ * If JOB = 'V', S is not referenced.\n\ *\n\ * DIF (output) DOUBLE PRECISION array, dimension (MM)\n\ * If JOB = 'V' or 'B', the estimated reciprocal condition\n\ * numbers of the selected eigenvectors, stored in consecutive\n\ * elements of the array.\n\ * If the eigenvalues cannot be reordered to compute DIF(j),\n\ * DIF(j) is set to 0; this can only occur when the true value\n\ * would be very small anyway.\n\ * For each eigenvalue/vector specified by SELECT, DIF stores\n\ * a Frobenius norm-based estimate of Difl.\n\ * If JOB = 'E', DIF is not referenced.\n\ *\n\ * MM (input) INTEGER\n\ * The number of elements in the arrays S and DIF. MM >= M.\n\ *\n\ * M (output) INTEGER\n\ * The number of elements of the arrays S and DIF used to store\n\ * the specified condition numbers; for each selected eigenvalue\n\ * one element is used. If HOWMNY = 'A', M is set to N.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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,N).\n\ * If JOB = 'V' or 'B', LWORK >= max(1,2*N*N).\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N+2)\n\ * If JOB = 'E', IWORK is not referenced.\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 reciprocal of the condition number of the i-th generalized\n\ * eigenvalue w = (a, b) is defined as\n\ *\n\ * S(I) = (|v'Au|**2 + |v'Bu|**2)**(1/2) / (norm(u)*norm(v))\n\ *\n\ * where u and v are the right and left eigenvectors of (A, B)\n\ * corresponding to w; |z| denotes the absolute value of the complex\n\ * number, and norm(u) denotes the 2-norm of the vector u. The pair\n\ * (a, b) corresponds to an eigenvalue w = a/b (= v'Au/v'Bu) of the\n\ * matrix pair (A, B). If both a and b equal zero, then (A,B) is\n\ * singular and S(I) = -1 is returned.\n\ *\n\ * An approximate error bound on the chordal distance between the i-th\n\ * computed generalized eigenvalue w and the corresponding exact\n\ * eigenvalue lambda is\n\ *\n\ * chord(w, lambda) <= EPS * norm(A, B) / S(I),\n\ *\n\ * where EPS is the machine precision.\n\ *\n\ * The reciprocal of the condition number of the right eigenvector u\n\ * and left eigenvector v corresponding to the generalized eigenvalue w\n\ * is defined as follows. Suppose\n\ *\n\ * (A, B) = ( a * ) ( b * ) 1\n\ * ( 0 A22 ),( 0 B22 ) n-1\n\ * 1 n-1 1 n-1\n\ *\n\ * Then the reciprocal condition number DIF(I) is\n\ *\n\ * Difl[(a, b), (A22, B22)] = sigma-min( Zl )\n\ *\n\ * where sigma-min(Zl) denotes the smallest singular value of\n\ *\n\ * Zl = [ kron(a, In-1) -kron(1, A22) ]\n\ * [ kron(b, In-1) -kron(1, B22) ].\n\ *\n\ * Here In-1 is the identity matrix of size n-1 and X' is the conjugate\n\ * transpose of X. kron(X, Y) is the Kronecker product between the\n\ * matrices X and Y.\n\ *\n\ * We approximate the smallest singular value of Zl with an upper\n\ * bound. This is done by ZLATDF.\n\ *\n\ * An approximate error bound for a computed eigenvector VL(i) or\n\ * VR(i) is given by\n\ *\n\ * EPS * norm(A, B) / DIF(i).\n\ *\n\ * See ref. [2-3] for more details and further references.\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * References\n\ * ==========\n\ *\n\ * [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n\ * Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n\ * M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n\ * Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n\ *\n\ * [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n\ * Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n\ * Estimation: Theory, Algorithms and Software, Report\n\ * UMINF - 94.04, Department of Computing Science, Umea University,\n\ * S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.\n\ * To appear in Numerical Algorithms, 1996.\n\ *\n\ * [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n\ * for Solving the Generalized Sylvester Equation and Estimating the\n\ * Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n\ * Department of Computing Science, Umea University, S-901 87 Umea,\n\ * Sweden, December 1993, Revised April 1994, Also as LAPACK Working\n\ * Note 75.\n\ * To appear in ACM Trans. on Math. Software, Vol 22, No 1, 1996.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zungr20000644000175000017500000000445712502223526016451 0ustar uwabamiuwabami--- :name: zungr2 :md5sum: 4a30cf54fa461d95f7ab0a1082f797c4 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - k - work: :type: doublecomplex :intent: workspace :dims: - m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE ZUNGR2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZUNGR2 generates an m by n complex matrix Q with orthonormal rows,\n\ * which is defined as the last m rows of a product of k elementary\n\ * reflectors of order n\n\ *\n\ * Q = H(1)' H(2)' . . . H(k)'\n\ *\n\ * as returned by ZGERQF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. N >= M.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. M >= K >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the (m-k+i)-th row must contain the vector which\n\ * defines the elementary reflector H(i), for i = 1,2,...,k, as\n\ * returned by ZGERQF in the last k rows of its array argument\n\ * A.\n\ * On exit, the m-by-n matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) COMPLEX*16 array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by ZGERQF.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (M)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chsein0000644000175000017500000001663312502223525016471 0ustar uwabamiuwabami--- :name: chsein :md5sum: 47f76f0ff879b1035b2920625919b141 :category: :subroutine :arguments: - side: :type: char :intent: input - eigsrc: :type: char :intent: input - initv: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - h: :type: complex :intent: input :dims: - ldh - n - ldh: :type: integer :intent: input - w: :type: complex :intent: input/output :dims: - n - vl: :type: complex :intent: input/output :dims: - ldvl - mm - ldvl: :type: integer :intent: input - vr: :type: complex :intent: input/output :dims: - ldvr - mm - ldvr: :type: integer :intent: input - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: complex :intent: workspace :dims: - n*n - rwork: :type: real :intent: workspace :dims: - n - ifaill: :type: integer :intent: output :dims: - mm - ifailr: :type: integer :intent: output :dims: - mm - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, W, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, IFAILL, IFAILR, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHSEIN uses inverse iteration to find specified right and/or left\n\ * eigenvectors of a complex upper Hessenberg matrix H.\n\ *\n\ * The right eigenvector x and the left eigenvector y of the matrix H\n\ * corresponding to an eigenvalue w are defined by:\n\ *\n\ * H * x = w * x, y**h * H = w * y**h\n\ *\n\ * where y**h denotes the conjugate transpose of the vector y.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'R': compute right eigenvectors only;\n\ * = 'L': compute left eigenvectors only;\n\ * = 'B': compute both right and left eigenvectors.\n\ *\n\ * EIGSRC (input) CHARACTER*1\n\ * Specifies the source of eigenvalues supplied in W:\n\ * = 'Q': the eigenvalues were found using CHSEQR; thus, if\n\ * H has zero subdiagonal elements, and so is\n\ * block-triangular, then the j-th eigenvalue can be\n\ * assumed to be an eigenvalue of the block containing\n\ * the j-th row/column. This property allows CHSEIN to\n\ * perform inverse iteration on just one diagonal block.\n\ * = 'N': no assumptions are made on the correspondence\n\ * between eigenvalues and diagonal blocks. In this\n\ * case, CHSEIN must always perform inverse iteration\n\ * using the whole matrix H.\n\ *\n\ * INITV (input) CHARACTER*1\n\ * = 'N': no initial vectors are supplied;\n\ * = 'U': user-supplied initial vectors are stored in the arrays\n\ * VL and/or VR.\n\ *\n\ * SELECT (input) LOGICAL array, dimension (N)\n\ * Specifies the eigenvectors to be computed. To select the\n\ * eigenvector corresponding to the eigenvalue W(j),\n\ * SELECT(j) must be set to .TRUE..\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix H. N >= 0.\n\ *\n\ * H (input) COMPLEX array, dimension (LDH,N)\n\ * The upper Hessenberg matrix H.\n\ *\n\ * LDH (input) INTEGER\n\ * The leading dimension of the array H. LDH >= max(1,N).\n\ *\n\ * W (input/output) COMPLEX array, dimension (N)\n\ * On entry, the eigenvalues of H.\n\ * On exit, the real parts of W may have been altered since\n\ * close eigenvalues are perturbed slightly in searching for\n\ * independent eigenvectors.\n\ *\n\ * VL (input/output) COMPLEX array, dimension (LDVL,MM)\n\ * On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must\n\ * contain starting vectors for the inverse iteration for the\n\ * left eigenvectors; the starting vector for each eigenvector\n\ * must be in the same column in which the eigenvector will be\n\ * stored.\n\ * On exit, if SIDE = 'L' or 'B', the left eigenvectors\n\ * specified by SELECT will be stored consecutively in the\n\ * columns of VL, in the same order as their eigenvalues.\n\ * If SIDE = 'R', VL is not referenced.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the array VL.\n\ * LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.\n\ *\n\ * VR (input/output) COMPLEX array, dimension (LDVR,MM)\n\ * On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must\n\ * contain starting vectors for the inverse iteration for the\n\ * right eigenvectors; the starting vector for each eigenvector\n\ * must be in the same column in which the eigenvector will be\n\ * stored.\n\ * On exit, if SIDE = 'R' or 'B', the right eigenvectors\n\ * specified by SELECT will be stored consecutively in the\n\ * columns of VR, in the same order as their eigenvalues.\n\ * If SIDE = 'L', VR is not referenced.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the array VR.\n\ * LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.\n\ *\n\ * MM (input) INTEGER\n\ * The number of columns in the arrays VL and/or VR. MM >= M.\n\ *\n\ * M (output) INTEGER\n\ * The number of columns in the arrays VL and/or VR required to\n\ * store the eigenvectors (= the number of .TRUE. elements in\n\ * SELECT).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (N*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\n\ *\n\ * IFAILL (output) INTEGER array, dimension (MM)\n\ * If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left\n\ * eigenvector in the i-th column of VL (corresponding to the\n\ * eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the\n\ * eigenvector converged satisfactorily.\n\ * If SIDE = 'R', IFAILL is not referenced.\n\ *\n\ * IFAILR (output) INTEGER array, dimension (MM)\n\ * If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right\n\ * eigenvector in the i-th column of VR (corresponding to the\n\ * eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the\n\ * eigenvector converged satisfactorily.\n\ * If SIDE = 'L', IFAILR is not referenced.\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, i is the number of eigenvectors which\n\ * failed to converge; see IFAILL and IFAILR for further\n\ * details.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Each eigenvector is normalized so that the element of largest\n\ * magnitude has magnitude 1; here the magnitude of a complex number\n\ * (x,y) is taken to be |x|+|y|.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhpgvx0000644000175000017500000002225012502223526016537 0ustar uwabamiuwabami--- :name: zhpgvx :md5sum: 7fe4092d2b27387168e9fe2e853c469e :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - ldap - bp: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: doublereal :intent: input - m: :type: integer :intent: output - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - "lsame_(&jobz,\"N\") ? 0 : ldz" - "lsame_(&jobz,\"N\") ? 0 : n" - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - 7*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE ZHPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHPGVX computes selected eigenvalues and, optionally, eigenvectors\n\ * of a complex generalized Hermitian-definite eigenproblem, of the form\n\ * A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n\ * B are assumed to be Hermitian, stored in packed format, and B is also\n\ * positive definite. Eigenvalues and eigenvectors can be selected by\n\ * specifying either a range of values or a range of indices for the\n\ * desired eigenvalues.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * Specifies the problem type to be solved:\n\ * = 1: A*x = (lambda)*B*x\n\ * = 2: A*B*x = (lambda)*x\n\ * = 3: B*A*x = (lambda)*x\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found;\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found;\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, the contents of AP are destroyed.\n\ *\n\ * BP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * B, packed columnwise in a linear array. The j-th column of B\n\ * is stored in the array BP as follows:\n\ * if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n\ *\n\ * On exit, the triangular factor U or L from the Cholesky\n\ * factorization B = U**H*U or B = L*L**H, in the same storage\n\ * format as B.\n\ *\n\ * VL (input) DOUBLE PRECISION\n\ * VU (input) DOUBLE PRECISION\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) DOUBLE PRECISION\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less than\n\ * or equal to zero, then EPS*|T| will be used in its place,\n\ * where |T| is the 1-norm of the tridiagonal matrix obtained\n\ * by reducing AP to tridiagonal form.\n\ *\n\ * Eigenvalues will be computed most accurately when ABSTOL is\n\ * set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n\ * If this routine returns with INFO>0, indicating that some\n\ * eigenvectors did not converge, try setting ABSTOL to\n\ * 2*DLAMCH('S').\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * On normal exit, the first M elements contain the selected\n\ * eigenvalues in ascending order.\n\ *\n\ * Z (output) COMPLEX*16 array, dimension (LDZ, N)\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix A\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * The eigenvectors are normalized as follows:\n\ * if ITYPE = 1 or 2, Z**H*B*Z = I;\n\ * if ITYPE = 3, Z**H*inv(B)*Z = I.\n\ *\n\ * If an eigenvector fails to converge, then that column of Z\n\ * contains the latest approximation to the eigenvector, and the\n\ * index of the eigenvector is returned in IFAIL.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (7*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (5*N)\n\ *\n\ * IFAIL (output) INTEGER array, dimension (N)\n\ * If JOBZ = 'V', then if INFO = 0, the first M elements of\n\ * IFAIL are zero. If INFO > 0, then IFAIL contains the\n\ * indices of the eigenvectors that failed to converge.\n\ * If JOBZ = 'N', then IFAIL is not referenced.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: ZPPTRF or ZHPEVX returned an error code:\n\ * <= N: if INFO = i, ZHPEVX failed to converge;\n\ * i eigenvectors failed to converge. Their indices\n\ * are stored in array IFAIL.\n\ * > N: if INFO = N + i, for 1 <= i <= n, then the leading\n\ * minor of order i of B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL ALLEIG, INDEIG, UPPER, VALEIG, WANTZ\n CHARACTER TRANS\n INTEGER J\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZHPEVX, ZHPGST, ZPPTRF, ZTPMV, ZTPSV\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sgetri0000644000175000017500000000517412502223526016514 0ustar uwabamiuwabami--- :name: sgetri :md5sum: 503b233c194f05b3d4f490711646e246 :category: :subroutine :arguments: - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGETRI computes the inverse of a matrix using the LU factorization\n\ * computed by SGETRF.\n\ *\n\ * This method inverts U and then computes inv(A) by solving the system\n\ * inv(A)*L = inv(U) for inv(A).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the factors L and U from the factorization\n\ * A = P*L*U as computed by SGETRF.\n\ * On exit, if INFO = 0, the inverse of the original matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from SGETRF; for 1<=i<=N, row i of the\n\ * matrix was interchanged with row IPIV(i).\n\ *\n\ * WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO=0, then WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK >= max(1,N).\n\ * For optimal performance LWORK >= N*NB, where NB is\n\ * the optimal blocksize returned by ILAENV.\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, U(i,i) is exactly zero; the matrix is\n\ * singular and its inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zggqrf0000644000175000017500000001562512502223526016521 0ustar uwabamiuwabami--- :name: zggqrf :md5sum: c5fa85edaa431364717c95efec26deae :category: :subroutine :arguments: - n: :type: integer :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - m - lda: :type: integer :intent: input - taua: :type: doublecomplex :intent: output :dims: - MIN(n,m) - b: :type: doublecomplex :intent: input/output :dims: - ldb - p - ldb: :type: integer :intent: input - taub: :type: doublecomplex :intent: output :dims: - MIN(n,p) - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(MAX(n,m),p) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGGQRF computes a generalized QR factorization of an N-by-M matrix A\n\ * and an N-by-P matrix B:\n\ *\n\ * A = Q*R, B = Q*T*Z,\n\ *\n\ * where Q is an N-by-N unitary matrix, Z is a P-by-P unitary matrix,\n\ * and R and T assume one of the forms:\n\ *\n\ * if N >= M, R = ( R11 ) M , or if N < M, R = ( R11 R12 ) N,\n\ * ( 0 ) N-M N M-N\n\ * M\n\ *\n\ * where R11 is upper triangular, and\n\ *\n\ * if N <= P, T = ( 0 T12 ) N, or if N > P, T = ( T11 ) N-P,\n\ * P-N N ( T21 ) P\n\ * P\n\ *\n\ * where T12 or T21 is upper triangular.\n\ *\n\ * In particular, if B is square and nonsingular, the GQR factorization\n\ * of A and B implicitly gives the QR factorization of inv(B)*A:\n\ *\n\ * inv(B)*A = Z'*(inv(T)*R)\n\ *\n\ * where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n\ * conjugate transpose of matrix Z.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of rows of the matrices A and B. N >= 0.\n\ *\n\ * M (input) INTEGER\n\ * The number of columns of the matrix A. M >= 0.\n\ *\n\ * P (input) INTEGER\n\ * The number of columns of the matrix B. P >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,M)\n\ * On entry, the N-by-M matrix A.\n\ * On exit, the elements on and above the diagonal of the array\n\ * contain the min(N,M)-by-M upper trapezoidal matrix R (R is\n\ * upper triangular if N >= M); the elements below the diagonal,\n\ * with the array TAUA, represent the unitary matrix Q as a\n\ * product of min(N,M) elementary reflectors (see Further\n\ * Details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * TAUA (output) COMPLEX*16 array, dimension (min(N,M))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the unitary matrix Q (see Further Details).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,P)\n\ * On entry, the N-by-P matrix B.\n\ * On exit, if N <= P, the upper triangle of the subarray\n\ * B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n\ * if N > P, the elements on and above the (N-P)-th subdiagonal\n\ * contain the N-by-P upper trapezoidal matrix T; the remaining\n\ * elements, with the array TAUB, represent the unitary\n\ * matrix Z as a product of elementary reflectors (see Further\n\ * Details).\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * TAUB (output) COMPLEX*16 array, dimension (min(N,P))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the unitary matrix Z (see Further Details).\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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,N,M,P).\n\ * For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n\ * where NB1 is the optimal blocksize for the QR factorization\n\ * of an N-by-M matrix, NB2 is the optimal blocksize for the\n\ * RQ factorization of an N-by-P matrix, and NB3 is the optimal\n\ * blocksize for a call of ZUNMQR.\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(1) H(2) . . . H(k), where k = min(n,m).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - taua * v * v'\n\ *\n\ * where taua is a complex scalar, and v is a complex vector with\n\ * v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),\n\ * and taua in TAUA(i).\n\ * To form Q explicitly, use LAPACK subroutine ZUNGQR.\n\ * To use Q to update another matrix, use LAPACK subroutine ZUNMQR.\n\ *\n\ * The matrix Z is represented as a product of elementary reflectors\n\ *\n\ * Z = H(1) H(2) . . . H(k), where k = min(n,p).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - taub * v * v'\n\ *\n\ * where taub is a complex scalar, and v is a complex vector with\n\ * v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in\n\ * B(n-k+i,1:p-k+i-1), and taub in TAUB(i).\n\ * To form Z explicitly, use LAPACK subroutine ZUNGRQ.\n\ * To use Z to update another matrix, use LAPACK subroutine ZUNMRQ.\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZGEQRF, ZGERQF, ZUNMQR\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC INT, MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/slaebz0000644000175000017500000002757412502223526016507 0ustar uwabamiuwabami--- :name: slaebz :md5sum: 49712227df054fa19a38f7928b6b8461 :category: :subroutine :arguments: - ijob: :type: integer :intent: input - nitmax: :type: integer :intent: input - n: :type: integer :intent: input - mmax: :type: integer :intent: input - minp: :type: integer :intent: input - nbmin: :type: integer :intent: input - abstol: :type: real :intent: input - reltol: :type: real :intent: input - pivmin: :type: real :intent: input - d: :type: real :intent: input :dims: - n - e: :type: real :intent: input :dims: - n - e2: :type: real :intent: input :dims: - n - nval: :type: integer :intent: input/output :dims: - "(ijob==1||ijob==2) ? 0 : ijob==3 ? minp : 0" - ab: :type: real :intent: input/output :dims: - mmax - "2" - c: :type: real :intent: input/output :dims: - "ijob==1 ? 0 : (ijob==2||ijob==3) ? mmax : 0" - mout: :type: integer :intent: output - nab: :type: integer :intent: input/output :dims: - mmax - "2" - work: :type: real :intent: workspace :dims: - mmax - iwork: :type: integer :intent: workspace :dims: - mmax - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL, RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT, NAB, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAEBZ contains the iteration loops which compute and use the\n\ * function N(w), which is the count of eigenvalues of a symmetric\n\ * tridiagonal matrix T less than or equal to its argument w. It\n\ * performs a choice of two types of loops:\n\ *\n\ * IJOB=1, followed by\n\ * IJOB=2: It takes as input a list of intervals and returns a list of\n\ * sufficiently small intervals whose union contains the same\n\ * eigenvalues as the union of the original intervals.\n\ * The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP.\n\ * The output interval (AB(j,1),AB(j,2)] will contain\n\ * eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT.\n\ *\n\ * IJOB=3: It performs a binary search in each input interval\n\ * (AB(j,1),AB(j,2)] for a point w(j) such that\n\ * N(w(j))=NVAL(j), and uses C(j) as the starting point of\n\ * the search. If such a w(j) is found, then on output\n\ * AB(j,1)=AB(j,2)=w. If no such w(j) is found, then on output\n\ * (AB(j,1),AB(j,2)] will be a small interval containing the\n\ * point where N(w) jumps through NVAL(j), unless that point\n\ * lies outside the initial interval.\n\ *\n\ * Note that the intervals are in all cases half-open intervals,\n\ * i.e., of the form (a,b] , which includes b but not a .\n\ *\n\ * To avoid underflow, the matrix should be scaled so that its largest\n\ * element is no greater than overflow**(1/2) * underflow**(1/4)\n\ * in absolute value. To assure the most accurate computation\n\ * of small eigenvalues, the matrix should be scaled to be\n\ * not much smaller than that, either.\n\ *\n\ * See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n\ * Matrix\", Report CS41, Computer Science Dept., Stanford\n\ * University, July 21, 1966\n\ *\n\ * Note: the arguments are, in general, *not* checked for unreasonable\n\ * values.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * IJOB (input) INTEGER\n\ * Specifies what is to be done:\n\ * = 1: Compute NAB for the initial intervals.\n\ * = 2: Perform bisection iteration to find eigenvalues of T.\n\ * = 3: Perform bisection iteration to invert N(w), i.e.,\n\ * to find a point which has a specified number of\n\ * eigenvalues of T to its left.\n\ * Other values will cause SLAEBZ to return with INFO=-1.\n\ *\n\ * NITMAX (input) INTEGER\n\ * The maximum number of \"levels\" of bisection to be\n\ * performed, i.e., an interval of width W will not be made\n\ * smaller than 2^(-NITMAX) * W. If not all intervals\n\ * have converged after NITMAX iterations, then INFO is set\n\ * to the number of non-converged intervals.\n\ *\n\ * N (input) INTEGER\n\ * The dimension n of the tridiagonal matrix T. It must be at\n\ * least 1.\n\ *\n\ * MMAX (input) INTEGER\n\ * The maximum number of intervals. If more than MMAX intervals\n\ * are generated, then SLAEBZ will quit with INFO=MMAX+1.\n\ *\n\ * MINP (input) INTEGER\n\ * The initial number of intervals. It may not be greater than\n\ * MMAX.\n\ *\n\ * NBMIN (input) INTEGER\n\ * The smallest number of intervals that should be processed\n\ * using a vector loop. If zero, then only the scalar loop\n\ * will be used.\n\ *\n\ * ABSTOL (input) REAL\n\ * The minimum (absolute) width of an interval. When an\n\ * interval is narrower than ABSTOL, or than RELTOL times the\n\ * larger (in magnitude) endpoint, then it is considered to be\n\ * sufficiently small, i.e., converged. This must be at least\n\ * zero.\n\ *\n\ * RELTOL (input) REAL\n\ * The minimum relative width of an interval. When an interval\n\ * is narrower than ABSTOL, or than RELTOL times the larger (in\n\ * magnitude) endpoint, then it is considered to be\n\ * sufficiently small, i.e., converged. Note: this should\n\ * always be at least radix*machine epsilon.\n\ *\n\ * PIVMIN (input) REAL\n\ * The minimum absolute value of a \"pivot\" in the Sturm\n\ * sequence loop. This *must* be at least max |e(j)**2| *\n\ * safe_min and at least safe_min, where safe_min is at least\n\ * the smallest number that can divide one without overflow.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The diagonal elements of the tridiagonal matrix T.\n\ *\n\ * E (input) REAL array, dimension (N)\n\ * The offdiagonal elements of the tridiagonal matrix T in\n\ * positions 1 through N-1. E(N) is arbitrary.\n\ *\n\ * E2 (input) REAL array, dimension (N)\n\ * The squares of the offdiagonal elements of the tridiagonal\n\ * matrix T. E2(N) is ignored.\n\ *\n\ * NVAL (input/output) INTEGER array, dimension (MINP)\n\ * If IJOB=1 or 2, not referenced.\n\ * If IJOB=3, the desired values of N(w). The elements of NVAL\n\ * will be reordered to correspond with the intervals in AB.\n\ * Thus, NVAL(j) on output will not, in general be the same as\n\ * NVAL(j) on input, but it will correspond with the interval\n\ * (AB(j,1),AB(j,2)] on output.\n\ *\n\ * AB (input/output) REAL array, dimension (MMAX,2)\n\ * The endpoints of the intervals. AB(j,1) is a(j), the left\n\ * endpoint of the j-th interval, and AB(j,2) is b(j), the\n\ * right endpoint of the j-th interval. The input intervals\n\ * will, in general, be modified, split, and reordered by the\n\ * calculation.\n\ *\n\ * C (input/output) REAL array, dimension (MMAX)\n\ * If IJOB=1, ignored.\n\ * If IJOB=2, workspace.\n\ * If IJOB=3, then on input C(j) should be initialized to the\n\ * first search point in the binary search.\n\ *\n\ * MOUT (output) INTEGER\n\ * If IJOB=1, the number of eigenvalues in the intervals.\n\ * If IJOB=2 or 3, the number of intervals output.\n\ * If IJOB=3, MOUT will equal MINP.\n\ *\n\ * NAB (input/output) INTEGER array, dimension (MMAX,2)\n\ * If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)).\n\ * If IJOB=2, then on input, NAB(i,j) should be set. It must\n\ * satisfy the condition:\n\ * N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)),\n\ * which means that in interval i only eigenvalues\n\ * NAB(i,1)+1,...,NAB(i,2) will be considered. Usually,\n\ * NAB(i,j)=N(AB(i,j)), from a previous call to SLAEBZ with\n\ * IJOB=1.\n\ * On output, NAB(i,j) will contain\n\ * max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of\n\ * the input interval that the output interval\n\ * (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the\n\ * the input values of NAB(k,1) and NAB(k,2).\n\ * If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)),\n\ * unless N(w) > NVAL(i) for all search points w , in which\n\ * case NAB(i,1) will not be modified, i.e., the output\n\ * value will be the same as the input value (modulo\n\ * reorderings -- see NVAL and AB), or unless N(w) < NVAL(i)\n\ * for all search points w , in which case NAB(i,2) will\n\ * not be modified. Normally, NAB should be set to some\n\ * distinctive value(s) before SLAEBZ is called.\n\ *\n\ * WORK (workspace) REAL array, dimension (MMAX)\n\ * Workspace.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (MMAX)\n\ * Workspace.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: All intervals converged.\n\ * = 1--MMAX: The last INFO intervals did not converge.\n\ * = MMAX+1: More than MMAX intervals were generated.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * This routine is intended to be called only by other LAPACK\n\ * routines, thus the interface is less user-friendly. It is intended\n\ * for two purposes:\n\ *\n\ * (a) finding eigenvalues. In this case, SLAEBZ should have one or\n\ * more initial intervals set up in AB, and SLAEBZ should be called\n\ * with IJOB=1. This sets up NAB, and also counts the eigenvalues.\n\ * Intervals with no eigenvalues would usually be thrown out at\n\ * this point. Also, if not all the eigenvalues in an interval i\n\ * are desired, NAB(i,1) can be increased or NAB(i,2) decreased.\n\ * For example, set NAB(i,1)=NAB(i,2)-1 to get the largest\n\ * eigenvalue. SLAEBZ is then called with IJOB=2 and MMAX\n\ * no smaller than the value of MOUT returned by the call with\n\ * IJOB=1. After this (IJOB=2) call, eigenvalues NAB(i,1)+1\n\ * through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the\n\ * tolerance specified by ABSTOL and RELTOL.\n\ *\n\ * (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l).\n\ * In this case, start with a Gershgorin interval (a,b). Set up\n\ * AB to contain 2 search intervals, both initially (a,b). One\n\ * NVAL element should contain f-1 and the other should contain l\n\ * , while C should contain a and b, resp. NAB(i,1) should be -1\n\ * and NAB(i,2) should be N+1, to flag an error if the desired\n\ * interval does not lie in (a,b). SLAEBZ is then called with\n\ * IJOB=3. On exit, if w(f-1) < w(f), then one of the intervals --\n\ * j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while\n\ * if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r\n\ * >= 0, then the interval will have N(AB(j,1))=NAB(j,1)=f-k and\n\ * N(AB(j,2))=NAB(j,2)=f+r. The cases w(l) < w(l+1) and\n\ * w(l-r)=...=w(l+k) are handled similarly.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sggev0000644000175000017500000001614512502223526016332 0ustar uwabamiuwabami--- :name: sggev :md5sum: c8f02404add51e664f048466e576c7d2 :category: :subroutine :arguments: - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alphar: :type: real :intent: output :dims: - n - alphai: :type: real :intent: output :dims: - n - beta: :type: real :intent: output :dims: - n - vl: :type: real :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: real :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(1,8*n) - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " SUBROUTINE SGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B)\n\ * the generalized eigenvalues, and optionally, the left and/or right\n\ * generalized eigenvectors.\n\ *\n\ * A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n\ * lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n\ * singular. It is usually represented as the pair (alpha,beta), as\n\ * there is a reasonable interpretation for beta=0, and even for both\n\ * being zero.\n\ *\n\ * The right eigenvector v(j) corresponding to the eigenvalue lambda(j)\n\ * of (A,B) satisfies\n\ *\n\ * A * v(j) = lambda(j) * B * v(j).\n\ *\n\ * The left eigenvector u(j) corresponding to the eigenvalue lambda(j)\n\ * of (A,B) satisfies\n\ *\n\ * u(j)**H * A = lambda(j) * u(j)**H * B .\n\ *\n\ * where u(j)**H is the conjugate-transpose of u(j).\n\ *\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVL (input) CHARACTER*1\n\ * = 'N': do not compute the left generalized eigenvectors;\n\ * = 'V': compute the left generalized eigenvectors.\n\ *\n\ * JOBVR (input) CHARACTER*1\n\ * = 'N': do not compute the right generalized eigenvectors;\n\ * = 'V': compute the right generalized eigenvectors.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A, B, VL, and VR. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA, N)\n\ * On entry, the matrix A in the pair (A,B).\n\ * On exit, A has been overwritten.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of A. LDA >= max(1,N).\n\ *\n\ * B (input/output) REAL array, dimension (LDB, N)\n\ * On entry, the matrix B in the pair (A,B).\n\ * On exit, B has been overwritten.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B. LDB >= max(1,N).\n\ *\n\ * ALPHAR (output) REAL array, dimension (N)\n\ * ALPHAI (output) REAL array, dimension (N)\n\ * BETA (output) REAL array, dimension (N)\n\ * On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n\ * be the generalized eigenvalues. If ALPHAI(j) is zero, then\n\ * the j-th eigenvalue is real; if positive, then the j-th and\n\ * (j+1)-st eigenvalues are a complex conjugate pair, with\n\ * ALPHAI(j+1) negative.\n\ *\n\ * Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n\ * may easily over- or underflow, and BETA(j) may even be zero.\n\ * Thus, the user should avoid naively computing the ratio\n\ * alpha/beta. However, ALPHAR and ALPHAI will be always less\n\ * than and usually comparable with norm(A) in magnitude, and\n\ * BETA always less than and usually comparable with norm(B).\n\ *\n\ * VL (output) REAL array, dimension (LDVL,N)\n\ * If JOBVL = 'V', the left eigenvectors u(j) are stored one\n\ * after another in the columns of VL, in the same order as\n\ * their eigenvalues. If the j-th eigenvalue is real, then\n\ * u(j) = VL(:,j), the j-th column of VL. If the j-th and\n\ * (j+1)-th eigenvalues form a complex conjugate pair, then\n\ * u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).\n\ * Each eigenvector is scaled so the largest component has\n\ * abs(real part)+abs(imag. part)=1.\n\ * Not referenced if JOBVL = 'N'.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the matrix VL. LDVL >= 1, and\n\ * if JOBVL = 'V', LDVL >= N.\n\ *\n\ * VR (output) REAL array, dimension (LDVR,N)\n\ * If JOBVR = 'V', the right eigenvectors v(j) are stored one\n\ * after another in the columns of VR, in the same order as\n\ * their eigenvalues. If the j-th eigenvalue is real, then\n\ * v(j) = VR(:,j), the j-th column of VR. If the j-th and\n\ * (j+1)-th eigenvalues form a complex conjugate pair, then\n\ * v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).\n\ * Each eigenvector is scaled so the largest component has\n\ * abs(real part)+abs(imag. part)=1.\n\ * Not referenced if JOBVR = 'N'.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the matrix VR. LDVR >= 1, and\n\ * if JOBVR = 'V', LDVR >= N.\n\ *\n\ * WORK (workspace/output) REAL 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,8*N).\n\ * For good performance, LWORK must generally be larger.\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\ * = 1,...,N:\n\ * The QZ iteration failed. No eigenvectors have been\n\ * calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)\n\ * should be correct for j=INFO+1,...,N.\n\ * > N: =N+1: other than QZ iteration failed in SHGEQZ.\n\ * =N+2: error return from STGEVC.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cptcon0000644000175000017500000000470712502223525016505 0ustar uwabamiuwabami--- :name: cptcon :md5sum: f44569b6ef35f71a7ce889e59b7f2950 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: real :intent: input :dims: - n - e: :type: complex :intent: input :dims: - n-1 - anorm: :type: real :intent: input - rcond: :type: real :intent: output - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPTCON( N, D, E, ANORM, RCOND, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPTCON computes the reciprocal of the condition number (in the\n\ * 1-norm) of a complex Hermitian positive definite tridiagonal matrix\n\ * using the factorization A = L*D*L**H or A = U**H*D*U computed by\n\ * CPTTRF.\n\ *\n\ * Norm(inv(A)) is computed by a direct method, and the reciprocal of\n\ * the condition number is computed as\n\ * RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * D (input) REAL array, dimension (N)\n\ * The n diagonal elements of the diagonal matrix D from the\n\ * factorization of A, as computed by CPTTRF.\n\ *\n\ * E (input) COMPLEX array, dimension (N-1)\n\ * The (n-1) off-diagonal elements of the unit bidiagonal factor\n\ * U or L from the factorization of A, as computed by CPTTRF.\n\ *\n\ * ANORM (input) REAL\n\ * The 1-norm of the original matrix A.\n\ *\n\ * RCOND (output) REAL\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the\n\ * 1-norm of inv(A) computed in this routine.\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\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 method used is described in Nicholas J. Higham, \"Efficient\n\ * Algorithms for Computing the Condition Number of a Tridiagonal\n\ * Matrix\", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/chegv0000644000175000017500000001261312502223525016306 0ustar uwabamiuwabami--- :name: chegv :md5sum: 937cc653b6096de55edba381f27843d8 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - w: :type: real :intent: output :dims: - n - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n-1 - rwork: :type: real :intent: workspace :dims: - MAX(1, 3*n-2) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CHEGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHEGV computes all the eigenvalues, and optionally, the eigenvectors\n\ * of a complex generalized Hermitian-definite eigenproblem, of the form\n\ * A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.\n\ * Here A and B are assumed to be Hermitian and B is also\n\ * positive definite.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * Specifies the problem type to be solved:\n\ * = 1: A*x = (lambda)*B*x\n\ * = 2: A*B*x = (lambda)*x\n\ * = 3: B*A*x = (lambda)*x\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA, N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of A contains the\n\ * upper triangular part of the matrix A. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of A contains\n\ * the lower triangular part of the matrix A.\n\ *\n\ * On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n\ * matrix Z of eigenvectors. The eigenvectors are normalized\n\ * as follows:\n\ * if ITYPE = 1 or 2, Z**H*B*Z = I;\n\ * if ITYPE = 3, Z**H*inv(B)*Z = I.\n\ * If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n\ * or the lower triangle (if UPLO='L') of A, including the\n\ * diagonal, is destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB, N)\n\ * On entry, the Hermitian positive definite matrix B.\n\ * If UPLO = 'U', the leading N-by-N upper triangular part of B\n\ * contains the upper triangular part of the matrix B.\n\ * If UPLO = 'L', the leading N-by-N lower triangular part of B\n\ * contains the lower triangular part of the matrix B.\n\ *\n\ * On exit, if INFO <= N, the part of B containing the matrix is\n\ * overwritten by the triangular factor U or L from the Cholesky\n\ * factorization B = U**H*U or B = L*L**H.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of the array WORK. LWORK >= max(1,2*N-1).\n\ * For optimal efficiency, LWORK >= (NB+1)*N,\n\ * where NB is the blocksize for CHETRD returned by ILAENV.\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\ * RWORK (workspace) REAL array, dimension (max(1, 3*N-2))\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: CPOTRF or CHEEV returned an error code:\n\ * <= N: if INFO = i, CHEEV failed to converge;\n\ * i off-diagonal elements of an intermediate\n\ * tridiagonal form did not converge to zero;\n\ * > N: if INFO = N + i, for 1 <= i <= N, then the leading\n\ * minor of order i of B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgelss0000644000175000017500000001156612502223526016502 0ustar uwabamiuwabami--- :name: dgelss :md5sum: ba7d9a1ddb43c981531b0f82a0a65fd4 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - MIN(m,n) - rcond: :type: doublereal :intent: input - rank: :type: integer :intent: output - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 3*MIN(m,n) + MAX(MAX(2*MIN(m,n),MAX(m,n)),nrhs) - info: :type: integer :intent: output :substitutions: m: lda ldb: MAX(m,n) :fortran_help: " SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGELSS computes the minimum norm solution to a real linear least\n\ * squares problem:\n\ *\n\ * Minimize 2-norm(| b - A*x |).\n\ *\n\ * using the singular value decomposition (SVD) of A. A is an M-by-N\n\ * matrix which may be rank-deficient.\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 matrix\n\ * X.\n\ *\n\ * The effective rank of A is determined by treating as zero those\n\ * singular values which are less than RCOND times the largest singular\n\ * value.\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\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * 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, the first min(m,n) rows of A are overwritten with\n\ * its right singular vectors, stored rowwise.\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 M-by-NRHS right hand side matrix B.\n\ * On exit, B is overwritten by the N-by-NRHS solution\n\ * matrix X. If m >= n and RANK = n, the residual\n\ * sum-of-squares for the solution in the i-th column is given\n\ * by the sum of squares of elements n+1:m in that column.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,max(M,N)).\n\ *\n\ * S (output) DOUBLE PRECISION array, dimension (min(M,N))\n\ * The singular values of A in decreasing order.\n\ * The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n\ *\n\ * RCOND (input) DOUBLE PRECISION\n\ * RCOND is used to determine the effective rank of A.\n\ * Singular values S(i) <= RCOND*S(1) are treated as zero.\n\ * If RCOND < 0, machine precision is used instead.\n\ *\n\ * RANK (output) INTEGER\n\ * The effective rank of A, i.e., the number of singular values\n\ * which are greater than RCOND*S(1).\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 >= 1, and also:\n\ * LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS )\n\ * For good performance, LWORK should generally be larger.\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: the algorithm for computing the SVD failed to converge;\n\ * if INFO = i, i off-diagonal elements of an intermediate\n\ * bidiagonal form did not converge to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgbrfs0000644000175000017500000001261712502223526016505 0ustar uwabamiuwabami--- :name: sgbrfs :md5sum: 5c391cc7af00cb69142b04cd8dda8a1d :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: real :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: real :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGBRFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is banded, and provides\n\ * error bounds and backward error estimates for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AB (input) REAL array, dimension (LDAB,N)\n\ * The original band matrix A, stored in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * AFB (input) REAL array, dimension (LDAFB,N)\n\ * Details of the LU factorization of the band matrix A, as\n\ * computed by SGBTRF. U is stored as an upper triangular band\n\ * matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n\ * the multipliers used during the factorization are stored in\n\ * rows KL+KU+2 to 2*KL+KU+1.\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from SGBTRF; for 1<=i<=N, row i of the\n\ * matrix was interchanged with row IPIV(i).\n\ *\n\ * B (input) REAL array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) REAL array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by SGBTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) REAL array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgbequb0000644000175000017500000001025412502223525016621 0ustar uwabamiuwabami--- :name: cgbequb :md5sum: 5041799a7d0f357f5d903a9c34b04f02 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - r: :type: real :intent: output :dims: - m - c: :type: real :intent: output :dims: - n - rowcnd: :type: real :intent: output - colcnd: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: m: ldab :fortran_help: " SUBROUTINE CGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGBEQUB computes row and column scalings intended to equilibrate an\n\ * M-by-N matrix A and reduce its condition number. R returns the row\n\ * scale factors and C the column scale factors, chosen to try to make\n\ * the largest element in each row and column of the matrix B with\n\ * elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n\ * the radix.\n\ *\n\ * R(i) and C(j) are restricted to be a power of the radix between\n\ * SMLNUM = smallest safe number and BIGNUM = largest safe number. Use\n\ * of these scaling factors is not guaranteed to reduce the condition\n\ * number of A but works well in practice.\n\ *\n\ * This routine differs from CGEEQU by restricting the scaling factors\n\ * to a power of the radix. Baring over- and underflow, scaling by\n\ * these factors introduces no additional rounding errors. However, the\n\ * scaled entries' magnitured are no longer approximately 1 but lie\n\ * between sqrt(radix) and 1/sqrt(radix).\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\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array A. LDAB >= max(1,M).\n\ *\n\ * R (output) REAL array, dimension (M)\n\ * If INFO = 0 or INFO > M, R contains the row scale factors\n\ * for A.\n\ *\n\ * C (output) REAL array, dimension (N)\n\ * If INFO = 0, C contains the column scale factors for A.\n\ *\n\ * ROWCND (output) REAL\n\ * If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n\ * smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n\ * AMAX is neither too large nor too small, it is not worth\n\ * scaling by R.\n\ *\n\ * COLCND (output) REAL\n\ * If INFO = 0, COLCND contains the ratio of the smallest\n\ * C(i) to the largest C(i). If COLCND >= 0.1, it is not\n\ * worth scaling by C.\n\ *\n\ * AMAX (output) REAL\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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, and i is\n\ * <= M: the i-th row of A is exactly zero\n\ * > M: the (i-M)-th column of A is exactly zero\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsyevd0000644000175000017500000001364612502223526016520 0ustar uwabamiuwabami--- :name: dsyevd :md5sum: 0e5b6476a6643a932f9ebab12ff70ff0 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 2*n+1 : lsame_(&jobz,\"V\") ? 1+6*n+2*n*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSYEVD computes all eigenvalues and, optionally, eigenvectors of a\n\ * real symmetric matrix A. If eigenvectors are desired, it uses a\n\ * divide and conquer algorithm.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\ * Because of large use of BLAS of level 3, DSYEVD needs N**2 more\n\ * workspace than DSYEVX.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of A contains the\n\ * upper triangular part of the matrix A. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of A contains\n\ * the lower triangular part of the matrix A.\n\ * On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n\ * orthonormal eigenvectors of the matrix A.\n\ * If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n\ * or the upper triangle (if UPLO='U') of A, including the\n\ * diagonal, is destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * WORK (workspace/output) DOUBLE PRECISION array,\n\ * dimension (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\ * If N <= 1, LWORK must be at least 1.\n\ * If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1.\n\ * If JOBZ = 'V' and N > 1, LWORK must be at least\n\ * 1 + 6*N + 2*N**2.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the optimal sizes of the WORK and IWORK\n\ * arrays, returns these values as the first entries of the WORK\n\ * and IWORK arrays, and no error message related to LWORK or\n\ * LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK.\n\ * If N <= 1, LIWORK must be at least 1.\n\ * If JOBZ = 'N' and N > 1, LIWORK must be at least 1.\n\ * If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK and IWORK arrays, and no error message related to\n\ * LWORK or LIWORK 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 and JOBZ = 'N', then the algorithm failed\n\ * to converge; i off-diagonal elements of an intermediate\n\ * tridiagonal form did not converge to zero;\n\ * if INFO = i and JOBZ = 'V', then the algorithm failed\n\ * to compute an eigenvalue while working on the submatrix\n\ * lying in rows and columns INFO/(N+1) through\n\ * mod(INFO,N+1).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Jeff Rutter, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ * Modified by Francoise Tisseur, University of Tennessee.\n\ *\n\ * Modified description of INFO. Sven, 16 Feb 05.\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgtsvx0000644000175000017500000002330312502223525016526 0ustar uwabamiuwabami--- :name: cgtsvx :md5sum: ed2cc77d71ddf8dbdd89532429553bc3 :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: complex :intent: input :dims: - n-1 - d: :type: complex :intent: input :dims: - n - du: :type: complex :intent: input :dims: - n-1 - dlf: :type: complex :intent: input/output :dims: - n-1 - df: :type: complex :intent: input/output :dims: - n - duf: :type: complex :intent: input/output :dims: - n-1 - du2: :type: complex :intent: input/output :dims: - n-2 - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: complex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: complex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - ferr: :type: real :intent: output :dims: - nrhs - berr: :type: real :intent: output :dims: - nrhs - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE CGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGTSVX uses the LU factorization to compute the solution to a complex\n\ * system of linear equations A * X = B, A**T * X = B, or A**H * X = B,\n\ * where A is a tridiagonal matrix of order N and X and B are N-by-NRHS\n\ * matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'N', the LU decomposition is used to factor the matrix A\n\ * as A = L * U, where L is a product of permutation and unit lower\n\ * bidiagonal matrices and U is upper triangular with nonzeros in\n\ * only the main diagonal and first two superdiagonals.\n\ *\n\ * 2. If some U(i,i)=0, so that U is exactly singular, then the routine\n\ * returns with INFO = i. Otherwise, the factored form of A is used\n\ * to estimate the condition number of the matrix A. If the\n\ * reciprocal of the condition number is less than machine precision,\n\ * INFO = N+1 is returned as a warning, but the routine still goes on\n\ * to solve for X and compute error bounds as described below.\n\ *\n\ * 3. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 4. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of A has been\n\ * supplied on entry.\n\ * = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored form\n\ * of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV will not\n\ * be modified.\n\ * = 'N': The matrix will be copied to DLF, DF, and DUF\n\ * and factored.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * DL (input) COMPLEX array, dimension (N-1)\n\ * The (n-1) subdiagonal elements of A.\n\ *\n\ * D (input) COMPLEX array, dimension (N)\n\ * The n diagonal elements of A.\n\ *\n\ * DU (input) COMPLEX array, dimension (N-1)\n\ * The (n-1) superdiagonal elements of A.\n\ *\n\ * DLF (input or output) COMPLEX array, dimension (N-1)\n\ * If FACT = 'F', then DLF is an input argument and on entry\n\ * contains the (n-1) multipliers that define the matrix L from\n\ * the LU factorization of A as computed by CGTTRF.\n\ *\n\ * If FACT = 'N', then DLF is an output argument and on exit\n\ * contains the (n-1) multipliers that define the matrix L from\n\ * the LU factorization of A.\n\ *\n\ * DF (input or output) COMPLEX array, dimension (N)\n\ * If FACT = 'F', then DF is an input argument and on entry\n\ * contains the n diagonal elements of the upper triangular\n\ * matrix U from the LU factorization of A.\n\ *\n\ * If FACT = 'N', then DF is an output argument and on exit\n\ * contains the n diagonal elements of the upper triangular\n\ * matrix U from the LU factorization of A.\n\ *\n\ * DUF (input or output) COMPLEX array, dimension (N-1)\n\ * If FACT = 'F', then DUF is an input argument and on entry\n\ * contains the (n-1) elements of the first superdiagonal of U.\n\ *\n\ * If FACT = 'N', then DUF is an output argument and on exit\n\ * contains the (n-1) elements of the first superdiagonal of U.\n\ *\n\ * DU2 (input or output) COMPLEX array, dimension (N-2)\n\ * If FACT = 'F', then DU2 is an input argument and on entry\n\ * contains the (n-2) elements of the second superdiagonal of\n\ * U.\n\ *\n\ * If FACT = 'N', then DU2 is an output argument and on exit\n\ * contains the (n-2) elements of the second superdiagonal of\n\ * U.\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains the pivot indices from the LU factorization of A as\n\ * computed by CGTTRF.\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the LU factorization of A;\n\ * row i of the matrix was interchanged with row IPIV(i).\n\ * IPIV(i) will always be either i or i+1; IPIV(i) = i indicates\n\ * a row interchange was not required.\n\ *\n\ * B (input) COMPLEX array, dimension (LDB,NRHS)\n\ * The N-by-NRHS right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A. If RCOND is less than the machine precision (in\n\ * particular, if RCOND = 0), the matrix is singular to working\n\ * precision. This condition is indicated by a return code of\n\ * INFO > 0.\n\ *\n\ * FERR (output) REAL array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\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, and i is\n\ * <= N: U(i,i) is exactly zero. The factorization\n\ * has not been completed unless i = N, but the\n\ * factor U is exactly singular, so the solution\n\ * and error bounds could not be computed.\n\ * RCOND = 0 is returned.\n\ * = N+1: U is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsytf20000644000175000017500000001324012502223526016423 0ustar uwabamiuwabami--- :name: dsytf2 :md5sum: 01fde80942744339ad514c859f1e3b76 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSYTF2 computes the factorization of a real symmetric matrix A using\n\ * the Bunch-Kaufman diagonal pivoting method:\n\ *\n\ * A = U*D*U' or A = L*D*L'\n\ *\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, U' is the transpose of U, and D is symmetric and\n\ * block diagonal with 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\ * This is the unblocked version of the algorithm, calling Level 2 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * n-by-n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n-by-n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L (see below for further details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D.\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ * > 0: if INFO = k, D(k,k) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular, and division by zero will occur if it\n\ * is used to solve a system of equations.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * 09-29-06 - patch from\n\ * Bobby Cheng, MathWorks\n\ *\n\ * Replace l.204 and l.372\n\ * IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN\n\ * by\n\ * IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN\n\ *\n\ * 01-01-96 - Based on modifications by\n\ * J. Lewis, Boeing Computer Services Company\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ * 1-96 - Based on modifications by J. Lewis, Boeing Computer Services\n\ * Company\n\ *\n\ * If UPLO = 'U', then A = U*D*U', where\n\ * U = P(n)*U(n)* ... *P(k)U(k)* ...,\n\ * i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n\ * 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I v 0 ) k-s\n\ * U(k) = ( 0 I 0 ) s\n\ * ( 0 0 I ) n-k\n\ * k-s s n-k\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n\ * If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n\ * and A(k,k), and v overwrites A(1:k-2,k-1:k).\n\ *\n\ * If UPLO = 'L', then A = L*D*L', where\n\ * L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n\ * i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n\ * n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n\ * and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as\n\ * defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n\ * that if the diagonal block D(k) is of order s (s = 1 or 2), then\n\ *\n\ * ( I 0 0 ) k-1\n\ * L(k) = ( 0 I 0 ) s\n\ * ( 0 v I ) n-k-s+1\n\ * k-1 s n-k-s+1\n\ *\n\ * If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n\ * If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n\ * and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cla_gbrcond_c0000644000175000017500000001054712502223525017755 0ustar uwabamiuwabami--- :name: cla_gbrcond_c :md5sum: 67b30cebe554e4047e0ef184e9efd72e :category: :function :type: real :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: complex :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - c: :type: real :intent: input :dims: - n - capply: :type: logical :intent: input - info: :type: integer :intent: output - work: :type: complex :intent: input :dims: - 2*n - rwork: :type: real :intent: input :dims: - n :substitutions: {} :fortran_help: " REAL FUNCTION CLA_GBRCOND_C( TRANS, N, KL, KU, AB, LDAB, AFB, LDAFB, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLA_GBRCOND_C Computes the infinity norm condition number of\n\ * op(A) * inv(diag(C)) where C is a REAL vector.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate Transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * AB (input) COMPLEX array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * AFB (input) COMPLEX array, dimension (LDAFB,N)\n\ * Details of the LU factorization of the band matrix A, as\n\ * computed by CGBTRF. U is stored as an upper triangular\n\ * band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n\ * and the multipliers used during the factorization are stored\n\ * in rows KL+KU+2 to 2*KL+KU+1.\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from the factorization A = P*L*U\n\ * as computed by CGBTRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * C (input) REAL array, dimension (N)\n\ * The vector C in the formula op(A) * inv(diag(C)).\n\ *\n\ * CAPPLY (input) LOGICAL\n\ * If .TRUE. then access the vector C in the formula above.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * i > 0: The ith argument is invalid.\n\ *\n\ * WORK (input) COMPLEX array, dimension (2*N).\n\ * Workspace.\n\ *\n\ * RWORK (input) REAL array, dimension (N).\n\ * Workspace.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE, I, J\n REAL AINVNM, ANORM, TMP\n COMPLEX ZDUM\n\ * ..\n\ * .. Local Arrays ..\n INTEGER ISAVE( 3 )\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CLACN2, CGBTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n\ * ..\n\ * .. Statement Functions ..\n REAL CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sgelsx0000644000175000017500000001174712502223526016527 0ustar uwabamiuwabami--- :name: sgelsx :md5sum: e4e07c42aeca28db21674ddeedfea311 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - rcond: :type: real :intent: input - rank: :type: integer :intent: output - work: :type: real :intent: workspace :dims: - MAX((MIN(m,n))+3*n,2*(MIN(m,n))*nrhs) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This routine is deprecated and has been replaced by routine SGELSY.\n\ *\n\ * SGELSX computes the minimum-norm solution to a real linear least\n\ * squares problem:\n\ * minimize || A * X - B ||\n\ * using a complete orthogonal factorization of A. A is an M-by-N\n\ * matrix which may be rank-deficient.\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\ * The routine first computes a QR factorization with column pivoting:\n\ * A * P = Q * [ R11 R12 ]\n\ * [ 0 R22 ]\n\ * with R11 defined as the largest leading submatrix whose estimated\n\ * condition number is less than 1/RCOND. The order of R11, RANK,\n\ * is the effective rank of A.\n\ *\n\ * Then, R22 is considered to be negligible, and R12 is annihilated\n\ * by orthogonal transformations from the right, arriving at the\n\ * complete orthogonal factorization:\n\ * A * P = Q * [ T11 0 ] * Z\n\ * [ 0 0 ]\n\ * The minimum-norm solution is then\n\ * X = P * Z' [ inv(T11)*Q1'*B ]\n\ * [ 0 ]\n\ * where Q1 consists of the first RANK columns of 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\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of\n\ * columns of matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, A has been overwritten by details of its\n\ * complete orthogonal factorization.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the M-by-NRHS right hand side matrix B.\n\ * On exit, the N-by-NRHS solution matrix X.\n\ * If m >= n and RANK = n, the residual sum-of-squares for\n\ * the solution in the i-th column is given by the sum of\n\ * squares of elements N+1:M in that column.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,M,N).\n\ *\n\ * JPVT (input/output) INTEGER array, dimension (N)\n\ * On entry, if JPVT(i) .ne. 0, the i-th column of A is an\n\ * initial column, otherwise it is a free column. Before\n\ * the QR factorization of A, all initial columns are\n\ * permuted to the leading positions; only the remaining\n\ * free columns are moved as a result of column pivoting\n\ * during the factorization.\n\ * On exit, if JPVT(i) = k, then the i-th column of A*P\n\ * was the k-th column of A.\n\ *\n\ * RCOND (input) REAL\n\ * RCOND is used to determine the effective rank of A, which\n\ * is defined as the order of the largest leading triangular\n\ * submatrix R11 in the QR factorization with pivoting of A,\n\ * whose estimated condition number < 1/RCOND.\n\ *\n\ * RANK (output) INTEGER\n\ * The effective rank of A, i.e., the order of the submatrix\n\ * R11. This is the same as the order of the submatrix T11\n\ * in the complete orthogonal factorization of A.\n\ *\n\ * WORK (workspace) REAL array, dimension\n\ * (max( min(M,N)+3*N, 2*min(M,N)+NRHS )),\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/csytri0000644000175000017500000000506112502223525016526 0ustar uwabamiuwabami--- :name: csytri :md5sum: aa4c75a051e607ba62145c33dc81a023 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: complex :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSYTRI computes the inverse of a complex symmetric indefinite matrix\n\ * A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n\ * CSYTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the block diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L as computed by CSYTRF.\n\ *\n\ * On exit, if INFO = 0, the (symmetric) inverse of the original\n\ * matrix. If UPLO = 'U', the upper triangular part of the\n\ * inverse is formed and the part of A below the diagonal is not\n\ * referenced; if UPLO = 'L' the lower triangular part of the\n\ * inverse is formed and the part of A above the diagonal is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by CSYTRF.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\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, D(i,i) = 0; the matrix is singular and its\n\ * inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sptsv0000644000175000017500000000564012502223526016374 0ustar uwabamiuwabami--- :name: sptsv :md5sum: b5b44ec0183117f08df71d104487fade :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SPTSV( N, NRHS, D, E, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SPTSV computes the solution to a real system of linear equations\n\ * A*X = B, where A is an N-by-N symmetric positive definite tridiagonal\n\ * matrix, and X and B are N-by-NRHS matrices.\n\ *\n\ * A is factored as A = L*D*L**T, and the factored form of A is then\n\ * used to solve the system of equations.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the n diagonal elements of the tridiagonal matrix\n\ * A. On exit, the n diagonal elements of the diagonal matrix\n\ * D from the factorization A = L*D*L**T.\n\ *\n\ * E (input/output) REAL array, dimension (N-1)\n\ * On entry, the (n-1) subdiagonal elements of the tridiagonal\n\ * matrix A. On exit, the (n-1) subdiagonal elements of the\n\ * unit bidiagonal factor L from the L*D*L**T factorization of\n\ * A. (E can also be regarded as the superdiagonal of the unit\n\ * bidiagonal factor U from the U**T*D*U factorization of A.)\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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 leading minor of order i is not\n\ * positive definite, and the solution has not been\n\ * computed. The factorization has not been completed\n\ * unless i = N.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. External Subroutines ..\n EXTERNAL SPTTRF, SPTTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zlacgv0000644000175000017500000000224612502223526016502 0ustar uwabamiuwabami--- :name: zlacgv :md5sum: 062160ffd42244a74a662d0cb3c52b28 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - 1+(n-1)*abs(incx) - incx: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE ZLACGV( N, X, INCX )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLACGV conjugates a complex vector of length N.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The length of the vector X. N >= 0.\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension\n\ * (1+(N-1)*abs(INCX))\n\ * On entry, the vector of length N to be conjugated.\n\ * On exit, X is overwritten with conjg(X).\n\ *\n\ * INCX (input) INTEGER\n\ * The spacing between successive elements of X.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, IOFF\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC DCONJG\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dptcon0000644000175000017500000000502312502223526016477 0ustar uwabamiuwabami--- :name: dptcon :md5sum: 333dd6c839252d776031995183b815cc :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublereal :intent: input :dims: - n-1 - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPTCON( N, D, E, ANORM, RCOND, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPTCON computes the reciprocal of the condition number (in the\n\ * 1-norm) of a real symmetric positive definite tridiagonal matrix\n\ * using the factorization A = L*D*L**T or A = U**T*D*U computed by\n\ * DPTTRF.\n\ *\n\ * Norm(inv(A)) is computed by a direct method, and the reciprocal of\n\ * the condition number is computed as\n\ * RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The n diagonal elements of the diagonal matrix D from the\n\ * factorization of A, as computed by DPTTRF.\n\ *\n\ * E (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) off-diagonal elements of the unit bidiagonal factor\n\ * U or L from the factorization of A, as computed by DPTTRF.\n\ *\n\ * ANORM (input) DOUBLE PRECISION\n\ * The 1-norm of the original matrix A.\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the\n\ * 1-norm of inv(A) computed in this routine.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (N)\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 method used is described in Nicholas J. Higham, \"Efficient\n\ * Algorithms for Computing the Condition Number of a Tridiagonal\n\ * Matrix\", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/csyequb0000644000175000017500000000643012502223525016665 0ustar uwabamiuwabami--- :name: csyequb :md5sum: 6f43922d6b26e70d1e0277e86441bb24 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - s: :type: real :intent: output :dims: - n - scond: :type: real :intent: output - amax: :type: real :intent: output - work: :type: complex :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSYEQUB computes row and column scalings intended to equilibrate a\n\ * symmetric matrix A and reduce its condition number\n\ * (with respect to the two-norm). S contains the scale factors,\n\ * S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n\ * elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n\ * choice of S puts the condition number of B within a factor N of the\n\ * smallest possible condition number over all possible diagonal\n\ * scalings.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The N-by-N symmetric matrix whose scaling\n\ * factors are to be computed. Only the diagonal elements of A\n\ * are referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * S (output) REAL array, dimension (N)\n\ * If INFO = 0, S contains the scale factors for A.\n\ *\n\ * SCOND (output) REAL\n\ * If INFO = 0, S contains the ratio of the smallest S(i) to\n\ * the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n\ * large nor too small, it is not worth scaling by S.\n\ *\n\ * AMAX (output) REAL\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (3*N)\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 is nonpositive.\n\ *\n\n\ * Further Details\n\ * ======= =======\n\ *\n\ * Reference: Livne, O.E. and Golub, G.H., \"Scaling by Binormalization\",\n\ * Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004.\n\ * DOI 10.1023/B:NUMA.0000016606.32820.69\n\ * Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlasd00000644000175000017500000001024512502223526016361 0ustar uwabamiuwabami--- :name: dlasd0 :md5sum: 469c67fd3b988986d8c9fe190b5a3db7 :category: :subroutine :arguments: - n: :type: integer :intent: input - sqre: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input :dims: - m-1 - u: :type: doublereal :intent: output :dims: - ldu - n - ldu: :type: integer :intent: input - vt: :type: doublereal :intent: output :dims: - ldvt - m - ldvt: :type: integer :intent: input - smlsiz: :type: integer :intent: input - iwork: :type: integer :intent: workspace :dims: - (8 * n) - work: :type: doublereal :intent: workspace :dims: - (3 * pow(m,2) + 2 * m) - info: :type: integer :intent: output :substitutions: m: "sqre == 0 ? n : sqre == 1 ? n+1 : 0" ldvt: n ldu: n :fortran_help: " SUBROUTINE DLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Using a divide and conquer approach, DLASD0 computes the singular\n\ * value decomposition (SVD) of a real upper bidiagonal N-by-M\n\ * matrix B with diagonal D and offdiagonal E, where M = N + SQRE.\n\ * The algorithm computes orthogonal matrices U and VT such that\n\ * B = U * S * VT. The singular values S are overwritten on D.\n\ *\n\ * A related subroutine, DLASDA, computes only the singular values,\n\ * and optionally, the singular vectors in compact form.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * On entry, the row dimension of the upper bidiagonal matrix.\n\ * This is also the dimension of the main diagonal array D.\n\ *\n\ * SQRE (input) INTEGER\n\ * Specifies the column dimension of the bidiagonal matrix.\n\ * = 0: The bidiagonal matrix has column dimension M = N;\n\ * = 1: The bidiagonal matrix has column dimension M = N+1;\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry D contains the main diagonal of the bidiagonal\n\ * matrix.\n\ * On exit D, if INFO = 0, contains its singular values.\n\ *\n\ * E (input) DOUBLE PRECISION array, dimension (M-1)\n\ * Contains the subdiagonal entries of the bidiagonal matrix.\n\ * On exit, E has been destroyed.\n\ *\n\ * U (output) DOUBLE PRECISION array, dimension at least (LDQ, N)\n\ * On exit, U contains the left singular vectors.\n\ *\n\ * LDU (input) INTEGER\n\ * On entry, leading dimension of U.\n\ *\n\ * VT (output) DOUBLE PRECISION array, dimension at least (LDVT, M)\n\ * On exit, VT' contains the right singular vectors.\n\ *\n\ * LDVT (input) INTEGER\n\ * On entry, leading dimension of VT.\n\ *\n\ * SMLSIZ (input) INTEGER\n\ * On entry, maximum size of the subproblems at the\n\ * bottom of the computation tree.\n\ *\n\ * IWORK (workspace) INTEGER work array.\n\ * Dimension must be at least (8 * N)\n\ *\n\ * WORK (workspace) DOUBLE PRECISION work array.\n\ * Dimension must be at least (3 * M**2 + 2 * M)\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 = 1, a singular value did not converge\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ming Gu and Huan Ren, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, I1, IC, IDXQ, IDXQC, IM1, INODE, ITEMP, IWK,\n $ J, LF, LL, LVL, M, NCC, ND, NDB1, NDIML, NDIMR,\n $ NL, NLF, NLP1, NLVL, NR, NRF, NRP1, SQREI\n DOUBLE PRECISION ALPHA, BETA\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DLASD1, DLASDQ, DLASDT, XERBLA\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sspgvx0000644000175000017500000002172512502223526016551 0ustar uwabamiuwabami--- :name: sspgvx :md5sum: f1e22435b9665fcf555d8758dff89446 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - ldap - bp: :type: real :intent: input/output :dims: - n*(n+1)/2 - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - "lsame_(&jobz,\"N\") ? 0 : ldz" - "lsame_(&jobz,\"N\") ? 0 : MAX(1,m)" - ldz: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 8*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE SSPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSPGVX computes selected eigenvalues, and optionally, eigenvectors\n\ * of a real generalized symmetric-definite eigenproblem, of the form\n\ * A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A\n\ * and B are assumed to be symmetric, stored in packed storage, and B\n\ * is also positive definite. Eigenvalues and eigenvectors can be\n\ * selected by specifying either a range of values or a range of indices\n\ * for the desired eigenvalues.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * Specifies the problem type to be solved:\n\ * = 1: A*x = (lambda)*B*x\n\ * = 2: A*B*x = (lambda)*x\n\ * = 3: B*A*x = (lambda)*x\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found.\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found.\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A and B are stored;\n\ * = 'L': Lower triangle of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix pencil (A,B). N >= 0.\n\ *\n\ * AP (input/output) REAL array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, the contents of AP are destroyed.\n\ *\n\ * BP (input/output) REAL array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * B, packed columnwise in a linear array. The j-th column of B\n\ * is stored in the array BP as follows:\n\ * if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n\ *\n\ * On exit, the triangular factor U or L from the Cholesky\n\ * factorization B = U**T*U or B = L*L**T, in the same storage\n\ * format as B.\n\ *\n\ * VL (input) REAL\n\ * VU (input) REAL\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) REAL\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less than\n\ * or equal to zero, then EPS*|T| will be used in its place,\n\ * where |T| is the 1-norm of the tridiagonal matrix obtained\n\ * by reducing A to tridiagonal form.\n\ *\n\ * Eigenvalues will be computed most accurately when ABSTOL is\n\ * set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n\ * If this routine returns with INFO>0, indicating that some\n\ * eigenvectors did not converge, try setting ABSTOL to\n\ * 2*SLAMCH('S').\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * On normal exit, the first M elements contain the selected\n\ * eigenvalues in ascending order.\n\ *\n\ * Z (output) REAL array, dimension (LDZ, max(1,M))\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix A\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * The eigenvectors are normalized as follows:\n\ * if ITYPE = 1 or 2, Z**T*B*Z = I;\n\ * if ITYPE = 3, Z**T*inv(B)*Z = I.\n\ *\n\ * If an eigenvector fails to converge, then that column of Z\n\ * contains the latest approximation to the eigenvector, and the\n\ * index of the eigenvector is returned in IFAIL.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) REAL array, dimension (8*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (5*N)\n\ *\n\ * IFAIL (output) INTEGER array, dimension (N)\n\ * If JOBZ = 'V', then if INFO = 0, the first M elements of\n\ * IFAIL are zero. If INFO > 0, then IFAIL contains the\n\ * indices of the eigenvectors that failed to converge.\n\ * If JOBZ = 'N', then IFAIL is not referenced.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: SPPTRF or SSPEVX returned an error code:\n\ * <= N: if INFO = i, SSPEVX failed to converge;\n\ * i eigenvectors failed to converge. Their indices\n\ * are stored in array IFAIL.\n\ * > N: if INFO = N + i, for 1 <= i <= N, then the leading\n\ * minor of order i of B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL ALLEIG, INDEIG, UPPER, VALEIG, WANTZ\n CHARACTER TRANS\n INTEGER J\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SPPTRF, SSPEVX, SSPGST, STPMV, STPSV, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlange0000644000175000017500000000475012502223526016450 0ustar uwabamiuwabami--- :name: dlange :md5sum: 2fe726b4e4a40bde5dcd4f595a41679e :category: :function :type: doublereal :arguments: - norm: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? m : 0" :fortran_help: " DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLANGE returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * real matrix A.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * DLANGE returns the value\n\ *\n\ * DLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in DLANGE as described\n\ * above.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A. M >= 0. When M = 0,\n\ * DLANGE is set to zero.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix A. N >= 0. When N = 0,\n\ * DLANGE is set to zero.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The m by n matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(M,1).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n\ * referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctgevc0000644000175000017500000001504012502223525016462 0ustar uwabamiuwabami--- :name: ctgevc :md5sum: 34fff5554b8b02ba108f616b7c23fbde :category: :subroutine :arguments: - side: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - s: :type: complex :intent: input :dims: - lds - n - lds: :type: integer :intent: input - p: :type: complex :intent: input :dims: - ldp - n - ldp: :type: integer :intent: input - vl: :type: complex :intent: input/output :dims: - ldvl - mm - ldvl: :type: integer :intent: input - vr: :type: complex :intent: input/output :dims: - ldvr - mm - ldvr: :type: integer :intent: input - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTGEVC computes some or all of the right and/or left eigenvectors of\n\ * a pair of complex matrices (S,P), where S and P are upper triangular.\n\ * Matrix pairs of this type are produced by the generalized Schur\n\ * factorization of a complex matrix pair (A,B):\n\ * \n\ * A = Q*S*Z**H, B = Q*P*Z**H\n\ * \n\ * as computed by CGGHRD + CHGEQZ.\n\ * \n\ * The right eigenvector x and the left eigenvector y of (S,P)\n\ * corresponding to an eigenvalue w are defined by:\n\ * \n\ * S*x = w*P*x, (y**H)*S = w*(y**H)*P,\n\ * \n\ * where y**H denotes the conjugate tranpose of y.\n\ * The eigenvalues are not input to this routine, but are computed\n\ * directly from the diagonal elements of S and P.\n\ * \n\ * This routine returns the matrices X and/or Y of right and left\n\ * eigenvectors of (S,P), or the products Z*X and/or Q*Y,\n\ * where Z and Q are input matrices.\n\ * If Q and Z are the unitary factors from the generalized Schur\n\ * factorization of a matrix pair (A,B), then Z*X and Q*Y\n\ * are the matrices of right and left eigenvectors of (A,B).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'R': compute right eigenvectors only;\n\ * = 'L': compute left eigenvectors only;\n\ * = 'B': compute both right and left eigenvectors.\n\ *\n\ * HOWMNY (input) CHARACTER*1\n\ * = 'A': compute all right and/or left eigenvectors;\n\ * = 'B': compute all right and/or left eigenvectors,\n\ * backtransformed by the matrices in VR and/or VL;\n\ * = 'S': compute selected right and/or left eigenvectors,\n\ * specified by the logical array SELECT.\n\ *\n\ * SELECT (input) LOGICAL array, dimension (N)\n\ * If HOWMNY='S', SELECT specifies the eigenvectors to be\n\ * computed. The eigenvector corresponding to the j-th\n\ * eigenvalue is computed if SELECT(j) = .TRUE..\n\ * Not referenced if HOWMNY = 'A' or 'B'.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices S and P. N >= 0.\n\ *\n\ * S (input) COMPLEX array, dimension (LDS,N)\n\ * The upper triangular matrix S from a generalized Schur\n\ * factorization, as computed by CHGEQZ.\n\ *\n\ * LDS (input) INTEGER\n\ * The leading dimension of array S. LDS >= max(1,N).\n\ *\n\ * P (input) COMPLEX array, dimension (LDP,N)\n\ * The upper triangular matrix P from a generalized Schur\n\ * factorization, as computed by CHGEQZ. P must have real\n\ * diagonal elements.\n\ *\n\ * LDP (input) INTEGER\n\ * The leading dimension of array P. LDP >= max(1,N).\n\ *\n\ * VL (input/output) COMPLEX array, dimension (LDVL,MM)\n\ * On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n\ * contain an N-by-N matrix Q (usually the unitary matrix Q\n\ * of left Schur vectors returned by CHGEQZ).\n\ * On exit, if SIDE = 'L' or 'B', VL contains:\n\ * if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);\n\ * if HOWMNY = 'B', the matrix Q*Y;\n\ * if HOWMNY = 'S', the left eigenvectors of (S,P) specified by\n\ * SELECT, stored consecutively in the columns of\n\ * VL, in the same order as their eigenvalues.\n\ * Not referenced if SIDE = 'R'.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of array VL. LDVL >= 1, and if\n\ * SIDE = 'L' or 'l' or 'B' or 'b', LDVL >= N.\n\ *\n\ * VR (input/output) COMPLEX array, dimension (LDVR,MM)\n\ * On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n\ * contain an N-by-N matrix Q (usually the unitary matrix Z\n\ * of right Schur vectors returned by CHGEQZ).\n\ * On exit, if SIDE = 'R' or 'B', VR contains:\n\ * if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);\n\ * if HOWMNY = 'B', the matrix Z*X;\n\ * if HOWMNY = 'S', the right eigenvectors of (S,P) specified by\n\ * SELECT, stored consecutively in the columns of\n\ * VR, in the same order as their eigenvalues.\n\ * Not referenced if SIDE = 'L'.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the array VR. LDVR >= 1, and if\n\ * SIDE = 'R' or 'B', LDVR >= N.\n\ *\n\ * MM (input) INTEGER\n\ * The number of columns in the arrays VL and/or VR. MM >= M.\n\ *\n\ * M (output) INTEGER\n\ * The number of columns in the arrays VL and/or VR actually\n\ * used to store the eigenvectors. If HOWMNY = 'A' or 'B', M\n\ * is set to N. Each selected eigenvector occupies one column.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (2*N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dla_wwaddw0000644000175000017500000000265212502223526017332 0ustar uwabamiuwabami--- :name: dla_wwaddw :md5sum: da58c78a12f4aa29fcb0e297c45ff392 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - n - y: :type: doublereal :intent: input/output :dims: - n - w: :type: doublereal :intent: input :dims: - n :substitutions: {} :fortran_help: " SUBROUTINE DLA_WWADDW( N, X, Y, W )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLA_WWADDW adds a vector W into a doubled-single vector (X, Y).\n\ *\n\ * This works for all extant IBM's hex and binary floating point\n\ * arithmetics, but not for decimal.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The length of vectors X, Y, and W.\n\ *\n\ * X (input/output) DOUBLE PRECISION array, dimension (N)\n\ * The first part of the doubled-single accumulation vector.\n\ *\n\ * Y (input/output) DOUBLE PRECISION array, dimension (N)\n\ * The second part of the doubled-single accumulation vector.\n\ *\n\ * W (input) DOUBLE PRECISION array, dimension (N)\n\ * The vector to be added.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n DOUBLE PRECISION S\n INTEGER I\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sspgvd0000644000175000017500000001574312502223526016530 0ustar uwabamiuwabami--- :name: sspgvd :md5sum: 97ec12398c858d8e33458a3e860d2815 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: real :intent: input/output :dims: - ldap - bp: :type: real :intent: input/output :dims: - n*(n+1)/2 - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 2*n : lsame_(&jobz,\"V\") ? 1+6*n+2*n*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "(lsame_(&jobz,\"N\")||n<=1) ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE SSPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSPGVD computes all the eigenvalues, and optionally, the eigenvectors\n\ * of a real generalized symmetric-definite eigenproblem, of the form\n\ * A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n\ * B are assumed to be symmetric, stored in packed format, and B is also\n\ * positive definite.\n\ * If eigenvectors are desired, it uses a divide and conquer algorithm.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * Specifies the problem type to be solved:\n\ * = 1: A*x = (lambda)*B*x\n\ * = 2: A*B*x = (lambda)*x\n\ * = 3: B*A*x = (lambda)*x\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * AP (input/output) REAL array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, the contents of AP are destroyed.\n\ *\n\ * BP (input/output) REAL array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the symmetric matrix\n\ * B, packed columnwise in a linear array. The j-th column of B\n\ * is stored in the array BP as follows:\n\ * if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n\ *\n\ * On exit, the triangular factor U or L from the Cholesky\n\ * factorization B = U**T*U or B = L*L**T, in the same storage\n\ * format as B.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) REAL array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n\ * eigenvectors. The eigenvectors are normalized as follows:\n\ * if ITYPE = 1 or 2, Z**T*B*Z = I;\n\ * if ITYPE = 3, Z**T*inv(B)*Z = I.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the required LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK.\n\ * If N <= 1, LWORK >= 1.\n\ * If JOBZ = 'N' and N > 1, LWORK >= 2*N.\n\ * If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the required sizes of the WORK and IWORK\n\ * arrays, returns these values as the first entries of the WORK\n\ * and IWORK arrays, and no error message related to LWORK or\n\ * LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK.\n\ * If JOBZ = 'N' or N <= 1, LIWORK >= 1.\n\ * If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the required sizes of the WORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK and IWORK arrays, and no error message related to\n\ * LWORK or LIWORK 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: SPPTRF or SSPEVD returned an error code:\n\ * <= N: if INFO = i, SSPEVD failed to converge;\n\ * i off-diagonal elements of an intermediate\n\ * tridiagonal form did not converge to zero;\n\ * > N: if INFO = N + i, for 1 <= i <= N, then the leading\n\ * minor of order i of B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhbgvd0000644000175000017500000002107612502223526016502 0ustar uwabamiuwabami--- :name: zhbgvd :md5sum: e3c34343db6714b14c8e3b65e7cbccf2 :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: doublecomplex :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: doublecomplex :intent: input/output :dims: - ldbb - n - ldbb: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 2*n*n : 0" - rwork: :type: doublereal :intent: output :dims: - MAX(1,lrwork) - lrwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? n : 1" :fortran_help: " SUBROUTINE ZHBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHBGVD computes all the eigenvalues, and optionally, the eigenvectors\n\ * of a complex generalized Hermitian-definite banded eigenproblem, of\n\ * the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian\n\ * and banded, and B is also positive definite. If eigenvectors are\n\ * desired, it uses a divide and conquer algorithm.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * KA (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n\ *\n\ * KB (input) INTEGER\n\ * The number of superdiagonals of the matrix B if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n\ *\n\ * AB (input/output) COMPLEX*16 array, dimension (LDAB, N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix A, stored in the first ka+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n\ *\n\ * On exit, the contents of AB are destroyed.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KA+1.\n\ *\n\ * BB (input/output) COMPLEX*16 array, dimension (LDBB, N)\n\ * On entry, the upper or lower triangle of the Hermitian band\n\ * matrix B, stored in the first kb+1 rows of the array. The\n\ * j-th column of B is stored in the j-th column of the array BB\n\ * as follows:\n\ * if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n\ * if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n\ *\n\ * On exit, the factor S from the split Cholesky factorization\n\ * B = S**H*S, as returned by ZPBSTF.\n\ *\n\ * LDBB (input) INTEGER\n\ * The leading dimension of the array BB. LDBB >= KB+1.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) COMPLEX*16 array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n\ * eigenvectors, with the i-th column of Z holding the\n\ * eigenvector associated with W(i). The eigenvectors are\n\ * normalized so that Z**H*B*Z = I.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= N.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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\ * If N <= 1, LWORK >= 1.\n\ * If JOBZ = 'N' and N > 1, LWORK >= N.\n\ * If JOBZ = 'V' and N > 1, LWORK >= 2*N**2.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the optimal sizes of the WORK, RWORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * RWORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))\n\ * On exit, if INFO=0, RWORK(1) returns the optimal LRWORK.\n\ *\n\ * LRWORK (input) INTEGER\n\ * The dimension of array RWORK.\n\ * If N <= 1, LRWORK >= 1.\n\ * If JOBZ = 'N' and N > 1, LRWORK >= N.\n\ * If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.\n\ *\n\ * If LRWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO=0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of array IWORK.\n\ * If JOBZ = 'N' or N <= 1, LIWORK >= 1.\n\ * If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK 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, and i is:\n\ * <= N: the algorithm failed to converge:\n\ * i off-diagonal elements of an intermediate\n\ * tridiagonal form did not converge to zero;\n\ * > N: if INFO = N + i, for 1 <= i <= N, then ZPBSTF\n\ * returned INFO = i: B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sorg2l0000644000175000017500000000440712502223526016425 0ustar uwabamiuwabami--- :name: sorg2l :md5sum: 1b06659a1e359f99ff5b80f1bf6b9468 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - k - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SORG2L( M, N, K, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SORG2L generates an m by n real matrix Q with orthonormal columns,\n\ * which is defined as the last n columns of a product of k elementary\n\ * reflectors of order m\n\ *\n\ * Q = H(k) . . . H(2) H(1)\n\ *\n\ * as returned by SGEQLF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. M >= N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. N >= K >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the (n-k+i)-th column must contain the vector which\n\ * defines the elementary reflector H(i), for i = 1,2,...,k, as\n\ * returned by SGEQLF in the last k columns of its array\n\ * argument A.\n\ * On exit, the m by n matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) REAL array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by SGEQLF.\n\ *\n\ * WORK (workspace) REAL array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dgelsd0000644000175000017500000001605012502223526016454 0ustar uwabamiuwabami--- :name: dgelsd :md5sum: 491fcb0747c66a3474c70cafe89194ae :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - MIN(m,n) - rcond: :type: doublereal :intent: input - rank: :type: integer :intent: output - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "m>=n ? 12*n + 2*n*smlsiz + 8*n*nlvl + n*nrhs + (smlsiz+1)*(smlsiz+1) : 12*m + 2*m*smlsiz + 8*m*nlvl + m*nrhs + (smlsiz+1)*(smlsiz+1)" - iwork: :type: integer :intent: workspace :dims: - MAX(1,liwork) - info: :type: integer :intent: output :substitutions: m: lda ldb: MAX(m,n) c__9: "9" c__0: "0" liwork: 3*(MIN(m,n))*nlvl+11*(MIN(m,n)) nlvl: MAX(0,((int)(log(((double)(MIN(m,n)))/(smlsiz+1))/log(2.0))+1)) smlsiz: ilaenv_(&c__9,"DGELSD"," ",&c__0,&c__0,&c__0,&c__0) :fortran_help: " SUBROUTINE DGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGELSD computes the minimum-norm solution to a real linear least\n\ * squares problem:\n\ * minimize 2-norm(| b - A*x |)\n\ * using the singular value decomposition (SVD) of A. A is an M-by-N\n\ * matrix which may be rank-deficient.\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\ * The problem is solved in three steps:\n\ * (1) Reduce the coefficient matrix A to bidiagonal form with\n\ * Householder transformations, reducing the original problem\n\ * into a \"bidiagonal least squares problem\" (BLS)\n\ * (2) Solve the BLS using a divide and conquer approach.\n\ * (3) Apply back all the Householder tranformations to solve\n\ * the original least squares problem.\n\ *\n\ * The effective rank of A is determined by treating as zero those\n\ * singular values which are less than RCOND times the largest singular\n\ * value.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of A. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, A has been destroyed.\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 M-by-NRHS right hand side matrix B.\n\ * On exit, B is overwritten by the N-by-NRHS solution\n\ * matrix X. If m >= n and RANK = n, the residual\n\ * sum-of-squares for the solution in the i-th column is given\n\ * by the sum of squares of elements n+1:m in that column.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,max(M,N)).\n\ *\n\ * S (output) DOUBLE PRECISION array, dimension (min(M,N))\n\ * The singular values of A in decreasing order.\n\ * The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n\ *\n\ * RCOND (input) DOUBLE PRECISION\n\ * RCOND is used to determine the effective rank of A.\n\ * Singular values S(i) <= RCOND*S(1) are treated as zero.\n\ * If RCOND < 0, machine precision is used instead.\n\ *\n\ * RANK (output) INTEGER\n\ * The effective rank of A, i.e., the number of singular values\n\ * which are greater than RCOND*S(1).\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 must be at least 1.\n\ * The exact minimum amount of workspace needed depends on M,\n\ * N and NRHS. As long as LWORK is at least\n\ * 12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2,\n\ * if M is greater than or equal to N or\n\ * 12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2,\n\ * if M is less than N, the code will execute correctly.\n\ * SMLSIZ is returned by ILAENV and is equal to the maximum\n\ * size of the subproblems at the bottom of the computation\n\ * tree (usually about 25), and\n\ * NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )\n\ * For good performance, LWORK should generally be larger.\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\ * IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))\n\ * LIWORK >= max(1, 3 * MINMN * NLVL + 11 * MINMN),\n\ * where MINMN = MIN( M,N ).\n\ * On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * > 0: the algorithm for computing the SVD failed to converge;\n\ * if INFO = i, i off-diagonal elements of an intermediate\n\ * bidiagonal form did not converge to zero.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ming Gu and Ren-Cang Li, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zspcon0000644000175000017500000000512312502223526016525 0ustar uwabamiuwabami--- :name: zspcon :md5sum: b106db9eb942e1f94d952f6558892bb4 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSPCON estimates the reciprocal of the condition number (in the\n\ * 1-norm) of a complex symmetric packed matrix A using the\n\ * factorization A = U*D*U**T or A = L*D*L**T computed by ZSPTRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by ZSPTRF, stored as a\n\ * packed triangular matrix.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by ZSPTRF.\n\ *\n\ * ANORM (input) DOUBLE PRECISION\n\ * The 1-norm of the original matrix A.\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n\ * estimate of the 1-norm of inv(A) computed in this routine.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctpttr0000644000175000017500000000443012502223525016530 0ustar uwabamiuwabami--- :name: ctpttr :md5sum: cff59730a94a7f4cea094f49c60d4f70 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: complex :intent: input :dims: - ldap - a: :type: complex :intent: output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: lda: MAX(1,n) n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE CTPTTR( UPLO, N, AP, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTPTTR copies a triangular matrix A from standard packed format (TP)\n\ * to standard full format (TR).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular.\n\ * = 'L': A is lower triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * AP (input) COMPLEX array, dimension ( N*(N+1)/2 ),\n\ * On entry, the upper or lower triangular matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * A (output) COMPLEX array, dimension ( LDA, N )\n\ * On exit, the triangular matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgeev0000644000175000017500000001152112502223526016330 0ustar uwabamiuwabami--- :name: zgeev :md5sum: a2f45f145f9a86dc68d7611fb89512e0 :category: :subroutine :arguments: - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - w: :type: doublecomplex :intent: output :dims: - n - vl: :type: doublecomplex :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: doublecomplex :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 2*n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGEEV computes for an N-by-N complex nonsymmetric matrix A, the\n\ * eigenvalues and, optionally, the left and/or right eigenvectors.\n\ *\n\ * The right eigenvector v(j) of A satisfies\n\ * A * v(j) = lambda(j) * v(j)\n\ * where lambda(j) is its eigenvalue.\n\ * The left eigenvector u(j) of A satisfies\n\ * u(j)**H * A = lambda(j) * u(j)**H\n\ * where u(j)**H denotes the conjugate transpose of u(j).\n\ *\n\ * The computed eigenvectors are normalized to have Euclidean norm\n\ * equal to 1 and largest component real.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVL (input) CHARACTER*1\n\ * = 'N': left eigenvectors of A are not computed;\n\ * = 'V': left eigenvectors of are computed.\n\ *\n\ * JOBVR (input) CHARACTER*1\n\ * = 'N': right eigenvectors of A are not computed;\n\ * = 'V': right eigenvectors of A are computed.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ * On exit, A has been overwritten.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * W (output) COMPLEX*16 array, dimension (N)\n\ * W contains the computed eigenvalues.\n\ *\n\ * VL (output) COMPLEX*16 array, dimension (LDVL,N)\n\ * If JOBVL = 'V', the left eigenvectors u(j) are stored one\n\ * after another in the columns of VL, in the same order\n\ * as their eigenvalues.\n\ * If JOBVL = 'N', VL is not referenced.\n\ * u(j) = VL(:,j), the j-th column of VL.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the array VL. LDVL >= 1; if\n\ * JOBVL = 'V', LDVL >= N.\n\ *\n\ * VR (output) COMPLEX*16 array, dimension (LDVR,N)\n\ * If JOBVR = 'V', the right eigenvectors v(j) are stored one\n\ * after another in the columns of VR, in the same order\n\ * as their eigenvalues.\n\ * If JOBVR = 'N', VR is not referenced.\n\ * v(j) = VR(:,j), the j-th column of VR.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the array VR. LDVR >= 1; if\n\ * JOBVR = 'V', LDVR >= N.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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,2*N).\n\ * For good performance, LWORK must generally be larger.\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\ * RWORK (workspace) DOUBLE PRECISION array, dimension (2*N)\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 QR algorithm failed to compute all the\n\ * eigenvalues, and no eigenvectors have been computed;\n\ * elements and i+1:N of W contain eigenvalues which have\n\ * converged.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/csrscl0000644000175000017500000000257612502223525016512 0ustar uwabamiuwabami--- :name: csrscl :md5sum: 2d5e6bc7ca9f51ad75c919ce98a07627 :category: :subroutine :arguments: - n: :type: integer :intent: input - sa: :type: real :intent: input - sx: :type: complex :intent: input/output :dims: - 1+(n-1)*abs(incx) - incx: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE CSRSCL( N, SA, SX, INCX )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSRSCL multiplies an n-element complex vector x by the real scalar\n\ * 1/a. This is done without overflow or underflow as long as\n\ * the final result x/a does not overflow or underflow.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of components of the vector x.\n\ *\n\ * SA (input) REAL\n\ * The scalar a which is used to divide each component of x.\n\ * SA must be >= 0, or the subroutine will divide by zero.\n\ *\n\ * SX (input/output) COMPLEX array, dimension\n\ * (1+(N-1)*abs(INCX))\n\ * The n-element vector x.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between successive values of the vector SX.\n\ * > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssytri2x0000644000175000017500000000525712502223526017030 0ustar uwabamiuwabami--- :name: ssytri2x :md5sum: 93ce2bf66c6e6089e4300945dd132c6b :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: real :intent: workspace :dims: - n+nb+1 - nb+3 - nb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSYTRI2X computes the inverse of a real symmetric indefinite matrix\n\ * A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n\ * SSYTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the NNB diagonal matrix D and the multipliers\n\ * used to obtain the factor U or L as computed by SSYTRF.\n\ *\n\ * On exit, if INFO = 0, the (symmetric) inverse of the original\n\ * matrix. If UPLO = 'U', the upper triangular part of the\n\ * inverse is formed and the part of A below the diagonal is not\n\ * referenced; if UPLO = 'L' the lower triangular part of the\n\ * inverse is formed and the part of A above the diagonal is\n\ * not referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the NNB structure of D\n\ * as determined by SSYTRF.\n\ *\n\ * WORK (workspace) REAL array, dimension (N+NNB+1,NNB+3)\n\ *\n\ * NB (input) INTEGER\n\ * Block size\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, D(i,i) = 0; the matrix is singular and its\n\ * inverse could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dtgsy20000644000175000017500000002106012502223526016423 0ustar uwabamiuwabami--- :name: dtgsy2 :md5sum: aac9343f26eb26fda333d93013fb1815 :category: :subroutine :arguments: - trans: :type: char :intent: input - ijob: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - m - lda: :type: integer :intent: input - b: :type: doublereal :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - ldd - m - ldd: :type: integer :intent: input - e: :type: doublereal :intent: input :dims: - lde - n - lde: :type: integer :intent: input - f: :type: doublereal :intent: input/output :dims: - ldf - n - ldf: :type: integer :intent: input - scale: :type: doublereal :intent: output - rdsum: :type: doublereal :intent: input/output - rdscal: :type: doublereal :intent: input/output - iwork: :type: integer :intent: workspace :dims: - m+n+2 - pq: :type: integer :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, IWORK, PQ, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTGSY2 solves the generalized Sylvester equation:\n\ *\n\ * A * R - L * B = scale * C (1)\n\ * D * R - L * E = scale * F,\n\ *\n\ * using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices,\n\ * (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,\n\ * N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E)\n\ * must be in generalized Schur canonical form, i.e. A, B are upper\n\ * quasi triangular and D, E are upper triangular. The solution (R, L)\n\ * overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor\n\ * chosen to avoid overflow.\n\ *\n\ * In matrix notation solving equation (1) corresponds to solve\n\ * Z*x = scale*b, where Z is defined as\n\ *\n\ * Z = [ kron(In, A) -kron(B', Im) ] (2)\n\ * [ kron(In, D) -kron(E', Im) ],\n\ *\n\ * Ik is the identity matrix of size k and X' is the transpose of X.\n\ * kron(X, Y) is the Kronecker product between the matrices X and Y.\n\ * In the process of solving (1), we solve a number of such systems\n\ * where Dim(In), Dim(In) = 1 or 2.\n\ *\n\ * If TRANS = 'T', solve the transposed system Z'*y = scale*b for y,\n\ * which is equivalent to solve for R and L in\n\ *\n\ * A' * R + D' * L = scale * C (3)\n\ * R * B' + L * E' = scale * -F\n\ *\n\ * This case is used to compute an estimate of Dif[(A, D), (B, E)] =\n\ * sigma_min(Z) using reverse communicaton with DLACON.\n\ *\n\ * DTGSY2 also (IJOB >= 1) contributes to the computation in DTGSYL\n\ * of an upper bound on the separation between to matrix pairs. Then\n\ * the input (A, D), (B, E) are sub-pencils of the matrix pair in\n\ * DTGSYL. See DTGSYL for details.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N', solve the generalized Sylvester equation (1).\n\ * = 'T': solve the 'transposed' system (3).\n\ *\n\ * IJOB (input) INTEGER\n\ * Specifies what kind of functionality to be performed.\n\ * = 0: solve (1) only.\n\ * = 1: A contribution from this subsystem to a Frobenius\n\ * norm-based estimate of the separation between two matrix\n\ * pairs is computed. (look ahead strategy is used).\n\ * = 2: A contribution from this subsystem to a Frobenius\n\ * norm-based estimate of the separation between two matrix\n\ * pairs is computed. (DGECON on sub-systems is used.)\n\ * Not referenced if TRANS = 'T'.\n\ *\n\ * M (input) INTEGER\n\ * On entry, M specifies the order of A and D, and the row\n\ * dimension of C, F, R and L.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the order of B and E, and the column\n\ * dimension of C, F, R and L.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA, M)\n\ * On entry, A contains an upper quasi triangular matrix.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the matrix A. LDA >= max(1, M).\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB, N)\n\ * On entry, B contains an upper quasi triangular matrix.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the matrix B. LDB >= max(1, N).\n\ *\n\ * C (input/output) DOUBLE PRECISION array, dimension (LDC, N)\n\ * On entry, C contains the right-hand-side of the first matrix\n\ * equation in (1).\n\ * On exit, if IJOB = 0, C has been overwritten by the\n\ * solution R.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the matrix C. LDC >= max(1, M).\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (LDD, M)\n\ * On entry, D contains an upper triangular matrix.\n\ *\n\ * LDD (input) INTEGER\n\ * The leading dimension of the matrix D. LDD >= max(1, M).\n\ *\n\ * E (input) DOUBLE PRECISION array, dimension (LDE, N)\n\ * On entry, E contains an upper triangular matrix.\n\ *\n\ * LDE (input) INTEGER\n\ * The leading dimension of the matrix E. LDE >= max(1, N).\n\ *\n\ * F (input/output) DOUBLE PRECISION array, dimension (LDF, N)\n\ * On entry, F contains the right-hand-side of the second matrix\n\ * equation in (1).\n\ * On exit, if IJOB = 0, F has been overwritten by the\n\ * solution L.\n\ *\n\ * LDF (input) INTEGER\n\ * The leading dimension of the matrix F. LDF >= max(1, M).\n\ *\n\ * SCALE (output) DOUBLE PRECISION\n\ * On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions\n\ * R and L (C and F on entry) will hold the solutions to a\n\ * slightly perturbed system but the input matrices A, B, D and\n\ * E have not been changed. If SCALE = 0, R and L will hold the\n\ * solutions to the homogeneous system with C = F = 0. Normally,\n\ * SCALE = 1.\n\ *\n\ * RDSUM (input/output) DOUBLE PRECISION\n\ * On entry, the sum of squares of computed contributions to\n\ * the Dif-estimate under computation by DTGSYL, where the\n\ * scaling factor RDSCAL (see below) has been factored out.\n\ * On exit, the corresponding sum of squares updated with the\n\ * contributions from the current sub-system.\n\ * If TRANS = 'T' RDSUM is not touched.\n\ * NOTE: RDSUM only makes sense when DTGSY2 is called by DTGSYL.\n\ *\n\ * RDSCAL (input/output) DOUBLE PRECISION\n\ * On entry, scaling factor used to prevent overflow in RDSUM.\n\ * On exit, RDSCAL is updated w.r.t. the current contributions\n\ * in RDSUM.\n\ * If TRANS = 'T', RDSCAL is not touched.\n\ * NOTE: RDSCAL only makes sense when DTGSY2 is called by\n\ * DTGSYL.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (M+N+2)\n\ *\n\ * PQ (output) INTEGER\n\ * On exit, the number of subsystems (of size 2-by-2, 4-by-4 and\n\ * 8-by-8) solved by this routine.\n\ *\n\ * INFO (output) INTEGER\n\ * On exit, if INFO is set to\n\ * =0: Successful exit\n\ * <0: If INFO = -i, the i-th argument had an illegal value.\n\ * >0: The matrix pairs (A, D) and (B, E) have common or very\n\ * close eigenvalues.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * =====================================================================\n\ * Replaced various illegal calls to DCOPY by calls to DLASET.\n\ * Sven Hammarling, 27/5/02.\n\ *\n" ruby-lapack-1.7.2/dev/defs/sstedc0000644000175000017500000001473712502223526016511 0ustar uwabamiuwabami--- :name: sstedc :md5sum: 9818f0520ca5590cf0b25092ba9cd955 :category: :subroutine :arguments: - compz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - z: :type: real :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(lsame_(&compz,\"N\")||n<=1) ? 1 : lsame_(&compz,\"V\") ? 1+3*n+2*n*LG(n)+3*n*n : lsame_(&compz,\"I\") ? 1+4*n+2*n*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "(lsame_(&compz,\"N\")||n<=1) ? 1 : lsame_(&compz,\"V\") ? 6+6*n+5*n*LG(n) : lsame_(&compz,\"I\") ? 3+5*n : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSTEDC computes all eigenvalues and, optionally, eigenvectors of a\n\ * symmetric tridiagonal matrix using the divide and conquer method.\n\ * The eigenvectors of a full or band real symmetric matrix can also be\n\ * found if SSYTRD or SSPTRD or SSBTRD has been used to reduce this\n\ * matrix to tridiagonal form.\n\ *\n\ * This code makes very mild assumptions about floating point\n\ * arithmetic. It will work on machines with a guard digit in\n\ * add/subtract, or on those binary machines without guard digits\n\ * which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n\ * It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none. See SLAED3 for details.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * COMPZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only.\n\ * = 'I': Compute eigenvectors of tridiagonal matrix also.\n\ * = 'V': Compute eigenvectors of original dense symmetric\n\ * matrix also. On entry, Z contains the orthogonal\n\ * matrix used to reduce the original matrix to\n\ * tridiagonal form.\n\ *\n\ * N (input) INTEGER\n\ * The dimension of the symmetric tridiagonal matrix. N >= 0.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the diagonal elements of the tridiagonal matrix.\n\ * On exit, if INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * E (input/output) REAL array, dimension (N-1)\n\ * On entry, the subdiagonal elements of the tridiagonal matrix.\n\ * On exit, E has been destroyed.\n\ *\n\ * Z (input/output) REAL array, dimension (LDZ,N)\n\ * On entry, if COMPZ = 'V', then Z contains the orthogonal\n\ * matrix used in the reduction to tridiagonal form.\n\ * On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n\ * orthonormal eigenvectors of the original symmetric matrix,\n\ * and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n\ * of the symmetric tridiagonal matrix.\n\ * If COMPZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1.\n\ * If eigenvectors are desired, then LDZ >= max(1,N).\n\ *\n\ * WORK (workspace/output) REAL 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\ * If COMPZ = 'N' or N <= 1 then LWORK must be at least 1.\n\ * If COMPZ = 'V' and N > 1 then LWORK must be at least\n\ * ( 1 + 3*N + 2*N*lg N + 3*N**2 ),\n\ * where lg( N ) = smallest integer k such\n\ * that 2**k >= N.\n\ * If COMPZ = 'I' and N > 1 then LWORK must be at least\n\ * ( 1 + 4*N + N**2 ).\n\ * Note that for COMPZ = 'I' or 'V', then if N is less than or\n\ * equal to the minimum divide size, usually 25, then LWORK need\n\ * only be max(1,2*(N-1)).\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\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK.\n\ * If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1.\n\ * If COMPZ = 'V' and N > 1 then LIWORK must be at least\n\ * ( 6 + 6*N + 5*N*lg N ).\n\ * If COMPZ = 'I' and N > 1 then LIWORK must be at least\n\ * ( 3 + 5*N ).\n\ * Note that for COMPZ = 'I' or 'V', then if N is less than or\n\ * equal to the minimum divide size, usually 25, then LIWORK\n\ * need only be 1.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal size of the IWORK array,\n\ * returns this value as the first entry of the IWORK array, and\n\ * no error message related to LIWORK 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: The algorithm failed to compute an eigenvalue while\n\ * working on the submatrix lying in rows and columns\n\ * INFO/(N+1) through mod(INFO,N+1).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Jeff Rutter, Computer Science Division, University of California\n\ * at Berkeley, USA\n\ * Modified by Francoise Tisseur, University of Tennessee.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/checon0000644000175000017500000000515612502223525016455 0ustar uwabamiuwabami--- :name: checon :md5sum: 4a474de24c651dfefc9c44d20ce9de0c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: complex :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CHECON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CHECON estimates the reciprocal of the condition number of a complex\n\ * Hermitian matrix A using the factorization A = U*D*U**H or\n\ * A = L*D*L**H computed by CHETRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**H;\n\ * = 'L': Lower triangular, form is A = L*D*L**H.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by CHETRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by CHETRF.\n\ *\n\ * ANORM (input) REAL\n\ * The 1-norm of the original matrix A.\n\ *\n\ * RCOND (output) REAL\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n\ * estimate of the 1-norm of inv(A) computed in this routine.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zhfrk0000644000175000017500000001070412502223526016336 0ustar uwabamiuwabami--- :name: zhfrk :md5sum: f710d76bdfec0a51ef55bb6978763909 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - alpha: :type: doublereal :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - "lsame_(&trans,\"N\") ? k : n" - lda: :type: integer :intent: input - beta: :type: doublereal :intent: input - c: :type: doublecomplex :intent: input/output :dims: - ldc :substitutions: lda: "lsame_(&trans,\"N\") ? MAX(1,n) : MAX(1,k)" n: ((int)sqrtf(ldc*8+1.0f)-1)/2 :extras: ldc: integer :fortran_help: " SUBROUTINE ZHFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Level 3 BLAS like routine for C in RFP Format.\n\ *\n\ * ZHFRK performs one of the Hermitian rank--k operations\n\ *\n\ * C := alpha*A*conjg( A' ) + beta*C,\n\ *\n\ * or\n\ *\n\ * C := alpha*conjg( A' )*A + beta*C,\n\ *\n\ * where alpha and beta are real scalars, C is an n--by--n Hermitian\n\ * matrix and A is an n--by--k matrix in the first case and a k--by--n\n\ * matrix in the second case.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': The Normal Form of RFP A is stored;\n\ * = 'C': The Conjugate-transpose Form of RFP A is stored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * On entry, UPLO specifies whether the upper or lower\n\ * triangular part of the array C is to be referenced as\n\ * follows:\n\ *\n\ * UPLO = 'U' or 'u' Only the upper triangular part of C\n\ * is to be referenced.\n\ *\n\ * UPLO = 'L' or 'l' Only the lower triangular part of C\n\ * is to be referenced.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * On entry, TRANS specifies the operation to be performed as\n\ * follows:\n\ *\n\ * TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C.\n\ *\n\ * TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the order of the matrix C. N must be\n\ * at least zero.\n\ * Unchanged on exit.\n\ *\n\ * K (input) INTEGER\n\ * On entry with TRANS = 'N' or 'n', K specifies the number\n\ * of columns of the matrix A, and on entry with\n\ * TRANS = 'C' or 'c', K specifies the number of rows of the\n\ * matrix A. K must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * ALPHA (input) DOUBLE PRECISION\n\ * On entry, ALPHA specifies the scalar alpha.\n\ * Unchanged on exit.\n\ *\n\ * A (input) COMPLEX*16 array of DIMENSION (LDA,ka)\n\ * where KA\n\ * is K when TRANS = 'N' or 'n', and is N otherwise. Before\n\ * entry with TRANS = 'N' or 'n', the leading N--by--K part of\n\ * the array A must contain the matrix A, otherwise the leading\n\ * K--by--N part of the array A must contain the matrix A.\n\ * Unchanged on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * On entry, LDA specifies the first dimension of A as declared\n\ * in the calling (sub) program. When TRANS = 'N' or 'n'\n\ * then LDA must be at least max( 1, n ), otherwise LDA must\n\ * be at least max( 1, k ).\n\ * Unchanged on exit.\n\ *\n\ * BETA (input) DOUBLE PRECISION\n\ * On entry, BETA specifies the scalar beta.\n\ * Unchanged on exit.\n\ *\n\ * C (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * On entry, the matrix A in RFP Format. RFP Format is\n\ * described by TRANSR, UPLO and N. Note that the imaginary\n\ * parts of the diagonal elements need not be set, they are\n\ * assumed to be zero, and on exit they are set to zero.\n\ *\n\ * Arguments\n\ * ==========\n\ *\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zhpgvd0000644000175000017500000002113612502223526016515 0ustar uwabamiuwabami--- :name: zhpgvd :md5sum: e81d6e43ac0f0338388ac1726dcfa821 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ap: :type: doublecomplex :intent: input/output :dims: - ldap - bp: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - w: :type: doublereal :intent: output :dims: - n - z: :type: doublecomplex :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 2*n : 0" - rwork: :type: doublereal :intent: workspace :dims: - MAX(1,lrwork) - lrwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? n : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "(lsame_(&jobz,\"N\")||n<=1) ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" n: ((int)sqrtf(ldap*8+1.0f)-1)/2 :fortran_help: " SUBROUTINE ZHPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHPGVD computes all the eigenvalues and, optionally, the eigenvectors\n\ * of a complex generalized Hermitian-definite eigenproblem, of the form\n\ * A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and\n\ * B are assumed to be Hermitian, stored in packed format, and B is also\n\ * positive definite.\n\ * If eigenvectors are desired, it uses a divide and conquer algorithm.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * Specifies the problem type to be solved:\n\ * = 1: A*x = (lambda)*B*x\n\ * = 2: A*B*x = (lambda)*x\n\ * = 3: B*A*x = (lambda)*x\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * A, packed columnwise in a linear array. The j-th column of A\n\ * is stored in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * On exit, the contents of AP are destroyed.\n\ *\n\ * BP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * On entry, the upper or lower triangle of the Hermitian matrix\n\ * B, packed columnwise in a linear array. The j-th column of B\n\ * is stored in the array BP as follows:\n\ * if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n\ *\n\ * On exit, the triangular factor U or L from the Cholesky\n\ * factorization B = U**H*U or B = L*L**H, in the same storage\n\ * format as B.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) COMPLEX*16 array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n\ * eigenvectors. The eigenvectors are normalized as follows:\n\ * if ITYPE = 1 or 2, Z**H*B*Z = I;\n\ * if ITYPE = 3, Z**H*inv(B)*Z = I.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the required LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of array WORK.\n\ * If N <= 1, LWORK >= 1.\n\ * If JOBZ = 'N' and N > 1, LWORK >= N.\n\ * If JOBZ = 'V' and N > 1, LWORK >= 2*N.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the required sizes of the WORK, RWORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))\n\ * On exit, if INFO = 0, RWORK(1) returns the required LRWORK.\n\ *\n\ * LRWORK (input) INTEGER\n\ * The dimension of array RWORK.\n\ * If N <= 1, LRWORK >= 1.\n\ * If JOBZ = 'N' and N > 1, LRWORK >= N.\n\ * If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.\n\ *\n\ * If LRWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the required sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of array IWORK.\n\ * If JOBZ = 'N' or N <= 1, LIWORK >= 1.\n\ * If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the required sizes of the WORK, RWORK\n\ * and IWORK arrays, returns these values as the first entries\n\ * of the WORK, RWORK and IWORK arrays, and no error message\n\ * related to LWORK or LRWORK or LIWORK 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: ZPPTRF or ZHPEVD returned an error code:\n\ * <= N: if INFO = i, ZHPEVD failed to converge;\n\ * i off-diagonal elements of an intermediate\n\ * tridiagonal form did not convergeto zero;\n\ * > N: if INFO = N + i, for 1 <= i <= n, then the leading\n\ * minor of order i of B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LQUERY, UPPER, WANTZ\n CHARACTER TRANS\n INTEGER J, LIWMIN, LRWMIN, LWMIN, NEIG\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZHPEVD, ZHPGST, ZPPTRF, ZTPMV, ZTPSV\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC DBLE, MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dgges0000644000175000017500000002337712502223526016315 0ustar uwabamiuwabami--- :name: dgges :md5sum: 3eca96ecb9c176b7624b865b6032c1e7 :category: :subroutine :arguments: - jobvsl: :type: char :intent: input - jobvsr: :type: char :intent: input - sort: :type: char :intent: input - selctg: :intent: external procedure :block_type: logical :block_arg_num: 3 :block_arg_type: doublereal - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - sdim: :type: integer :intent: output - alphar: :type: doublereal :intent: output :dims: - n - alphai: :type: doublereal :intent: output :dims: - n - beta: :type: doublereal :intent: output :dims: - n - vsl: :type: doublereal :intent: output :dims: - ldvsl - n - ldvsl: :type: integer :intent: input - vsr: :type: doublereal :intent: output :dims: - ldvsr - n - ldvsr: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(8*n,6*n+16) - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sort,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvsl: "lsame_(&jobvsl,\"V\") ? n : 1" ldvsr: "lsame_(&jobvsr,\"V\") ? n : 1" :fortran_help: " SUBROUTINE DGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, BWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGGES computes for a pair of N-by-N real nonsymmetric matrices (A,B),\n\ * the generalized eigenvalues, the generalized real Schur form (S,T),\n\ * optionally, the left and/or right matrices of Schur vectors (VSL and\n\ * VSR). This gives the generalized Schur factorization\n\ *\n\ * (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T )\n\ *\n\ * Optionally, it also orders the eigenvalues so that a selected cluster\n\ * of eigenvalues appears in the leading diagonal blocks of the upper\n\ * quasi-triangular matrix S and the upper triangular matrix T.The\n\ * leading columns of VSL and VSR then form an orthonormal basis for the\n\ * corresponding left and right eigenspaces (deflating subspaces).\n\ *\n\ * (If only the generalized eigenvalues are needed, use the driver\n\ * DGGEV instead, which is faster.)\n\ *\n\ * A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n\ * or a ratio alpha/beta = w, such that A - w*B is singular. It is\n\ * usually represented as the pair (alpha,beta), as there is a\n\ * reasonable interpretation for beta=0 or both being zero.\n\ *\n\ * A pair of matrices (S,T) is in generalized real Schur form if T is\n\ * upper triangular with non-negative diagonal and S is block upper\n\ * triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond\n\ * to real generalized eigenvalues, while 2-by-2 blocks of S will be\n\ * \"standardized\" by making the corresponding elements of T have the\n\ * form:\n\ * [ a 0 ]\n\ * [ 0 b ]\n\ *\n\ * and the pair of corresponding 2-by-2 blocks in S and T will have a\n\ * complex conjugate pair of generalized eigenvalues.\n\ *\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBVSL (input) CHARACTER*1\n\ * = 'N': do not compute the left Schur vectors;\n\ * = 'V': compute the left Schur vectors.\n\ *\n\ * JOBVSR (input) CHARACTER*1\n\ * = 'N': do not compute the right Schur vectors;\n\ * = 'V': compute the right Schur vectors.\n\ *\n\ * SORT (input) CHARACTER*1\n\ * Specifies whether or not to order the eigenvalues on the\n\ * diagonal of the generalized Schur form.\n\ * = 'N': Eigenvalues are not ordered;\n\ * = 'S': Eigenvalues are ordered (see SELCTG);\n\ *\n\ * SELCTG (external procedure) LOGICAL FUNCTION of three DOUBLE PRECISION arguments\n\ * SELCTG must be declared EXTERNAL in the calling subroutine.\n\ * If SORT = 'N', SELCTG is not referenced.\n\ * If SORT = 'S', SELCTG is used to select eigenvalues to sort\n\ * to the top left of the Schur form.\n\ * An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if\n\ * SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either\n\ * one of a complex conjugate pair of eigenvalues is selected,\n\ * then both complex eigenvalues are selected.\n\ *\n\ * Note that in the ill-conditioned case, a selected complex\n\ * eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j),\n\ * BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2\n\ * in this case.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A, B, VSL, and VSR. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n\ * On entry, the first of the pair of matrices.\n\ * On exit, A has been overwritten by its generalized Schur\n\ * form S.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of A. LDA >= max(1,N).\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n\ * On entry, the second of the pair of matrices.\n\ * On exit, B has been overwritten by its generalized Schur\n\ * form T.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B. LDB >= max(1,N).\n\ *\n\ * SDIM (output) INTEGER\n\ * If SORT = 'N', SDIM = 0.\n\ * If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n\ * for which SELCTG is true. (Complex conjugate pairs for which\n\ * SELCTG is true for either eigenvalue count as 2.)\n\ *\n\ * ALPHAR (output) DOUBLE PRECISION array, dimension (N)\n\ * ALPHAI (output) DOUBLE PRECISION array, dimension (N)\n\ * BETA (output) DOUBLE PRECISION array, dimension (N)\n\ * On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n\ * be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i,\n\ * and BETA(j),j=1,...,N are the diagonals of the complex Schur\n\ * form (S,T) that would result if the 2-by-2 diagonal blocks of\n\ * the real Schur form of (A,B) were further reduced to\n\ * triangular form using 2-by-2 complex unitary transformations.\n\ * If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n\ * positive, then the j-th and (j+1)-st eigenvalues are a\n\ * complex conjugate pair, with ALPHAI(j+1) negative.\n\ *\n\ * Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n\ * may easily over- or underflow, and BETA(j) may even be zero.\n\ * Thus, the user should avoid naively computing the ratio.\n\ * However, ALPHAR and ALPHAI will be always less than and\n\ * usually comparable with norm(A) in magnitude, and BETA always\n\ * less than and usually comparable with norm(B).\n\ *\n\ * VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N)\n\ * If JOBVSL = 'V', VSL will contain the left Schur vectors.\n\ * Not referenced if JOBVSL = 'N'.\n\ *\n\ * LDVSL (input) INTEGER\n\ * The leading dimension of the matrix VSL. LDVSL >=1, and\n\ * if JOBVSL = 'V', LDVSL >= N.\n\ *\n\ * VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N)\n\ * If JOBVSR = 'V', VSR will contain the right Schur vectors.\n\ * Not referenced if JOBVSR = 'N'.\n\ *\n\ * LDVSR (input) INTEGER\n\ * The leading dimension of the matrix VSR. LDVSR >= 1, and\n\ * if JOBVSR = 'V', LDVSR >= 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\ * If N = 0, LWORK >= 1, else LWORK >= 8*N+16.\n\ * For good performance , LWORK must generally be larger.\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\ * BWORK (workspace) LOGICAL array, dimension (N)\n\ * Not referenced if SORT = 'N'.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * = 1,...,N:\n\ * The QZ iteration failed. (A,B) are not in Schur\n\ * form, but ALPHAR(j), ALPHAI(j), and BETA(j) should\n\ * be correct for j=INFO+1,...,N.\n\ * > N: =N+1: other than QZ iteration failed in DHGEQZ.\n\ * =N+2: after reordering, roundoff changed values of\n\ * some complex eigenvalues so that leading\n\ * eigenvalues in the Generalized Schur form no\n\ * longer satisfy SELCTG=.TRUE. This could also\n\ * be caused due to scaling.\n\ * =N+3: reordering failed in DTGSEN.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ilazlr0000644000175000017500000000201612502223526016504 0ustar uwabamiuwabami--- :name: ilazlr :md5sum: e07f8aa44b48e26c9c8627cb2c3fadd1 :category: :function :type: integer :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " INTEGER FUNCTION ILAZLR( M, N, A, LDA )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ILAZLR scans A for its last non-zero row.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix A.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * 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\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zungbr0000644000175000017500000001053112502223526016517 0ustar uwabamiuwabami--- :name: zungbr :md5sum: 3f925e9eac5d8de52577cb97d814c82a :category: :subroutine :arguments: - vect: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: input :dims: - MIN(m,k) - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZUNGBR generates one of the complex unitary matrices Q or P**H\n\ * determined by ZGEBRD when reducing a complex matrix A to bidiagonal\n\ * form: A = Q * B * P**H. Q and P**H are defined as products of\n\ * elementary reflectors H(i) or G(i) respectively.\n\ *\n\ * If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q\n\ * is of order M:\n\ * if m >= k, Q = H(1) H(2) . . . H(k) and ZUNGBR returns the first n\n\ * columns of Q, where m >= n >= k;\n\ * if m < k, Q = H(1) H(2) . . . H(m-1) and ZUNGBR returns Q as an\n\ * M-by-M matrix.\n\ *\n\ * If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**H\n\ * is of order N:\n\ * if k < n, P**H = G(k) . . . G(2) G(1) and ZUNGBR returns the first m\n\ * rows of P**H, where n >= m >= k;\n\ * if k >= n, P**H = G(n-1) . . . G(2) G(1) and ZUNGBR returns P**H as\n\ * an N-by-N matrix.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * VECT (input) CHARACTER*1\n\ * Specifies whether the matrix Q or the matrix P**H is\n\ * required, as defined in the transformation applied by ZGEBRD:\n\ * = 'Q': generate Q;\n\ * = 'P': generate P**H.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q or P**H to be returned.\n\ * M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q or P**H to be returned.\n\ * N >= 0.\n\ * If VECT = 'Q', M >= N >= min(M,K);\n\ * if VECT = 'P', N >= M >= min(N,K).\n\ *\n\ * K (input) INTEGER\n\ * If VECT = 'Q', the number of columns in the original M-by-K\n\ * matrix reduced by ZGEBRD.\n\ * If VECT = 'P', the number of rows in the original K-by-N\n\ * matrix reduced by ZGEBRD.\n\ * K >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the vectors which define the elementary reflectors,\n\ * as returned by ZGEBRD.\n\ * On exit, the M-by-N matrix Q or P**H.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= M.\n\ *\n\ * TAU (input) COMPLEX*16 array, dimension\n\ * (min(M,K)) if VECT = 'Q'\n\ * (min(N,K)) if VECT = 'P'\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i) or G(i), which determines Q or P**H, as\n\ * returned by ZGEBRD in its array argument TAUQ or TAUP.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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,min(M,N)).\n\ * For optimum performance LWORK >= min(M,N)*NB, where NB\n\ * is the 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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgels0000644000175000017500000001321412502223526016326 0ustar uwabamiuwabami--- :name: sgels :md5sum: 994913d24d2a9adf9a93e5dbac66f485 :category: :subroutine :arguments: - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MIN(m,n) + MAX(MIN(m,n),nrhs) - info: :type: integer :intent: output :substitutions: m: lda ldb: MAX(m,n) :fortran_help: " SUBROUTINE SGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGELS 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) REAL 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 SGEQRF;\n\ * if M < N, A is overwritten by details of its LQ\n\ * factorization as returned by SGELQF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input/output) REAL 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) REAL 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" ruby-lapack-1.7.2/dev/defs/ssytd20000644000175000017500000001152512502223526016444 0ustar uwabamiuwabami--- :name: ssytd2 :md5sum: 29aaa26fad35e07fd904dc42d2c17119 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - d: :type: real :intent: output :dims: - n - e: :type: real :intent: output :dims: - n-1 - tau: :type: real :intent: output :dims: - n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal\n\ * form T by an orthogonal similarity transformation: Q' * A * Q = T.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * n-by-n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n-by-n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ * On exit, if UPLO = 'U', the diagonal and first superdiagonal\n\ * of A are overwritten by the corresponding elements of the\n\ * tridiagonal matrix T, and the elements above the first\n\ * superdiagonal, with the array TAU, represent the orthogonal\n\ * matrix Q as a product of elementary reflectors; if UPLO\n\ * = 'L', the diagonal and first subdiagonal of A are over-\n\ * written by the corresponding elements of the tridiagonal\n\ * matrix T, and the elements below the first subdiagonal, with\n\ * the array TAU, represent the orthogonal matrix Q as a product\n\ * of elementary reflectors. See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * D (output) REAL array, dimension (N)\n\ * The diagonal elements of the tridiagonal matrix T:\n\ * D(i) = A(i,i).\n\ *\n\ * E (output) REAL array, dimension (N-1)\n\ * The off-diagonal elements of the tridiagonal matrix T:\n\ * E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n\ *\n\ * TAU (output) REAL array, dimension (N-1)\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\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\ * If UPLO = 'U', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(n-1) . . . H(2) H(1).\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(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n\ * A(1:i-1,i+1), and tau in TAU(i).\n\ *\n\ * If UPLO = 'L', the matrix Q is represented as a product of elementary\n\ * reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(n-1).\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) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n\ * and tau in TAU(i).\n\ *\n\ * The contents of A on exit are illustrated by the following examples\n\ * with n = 5:\n\ *\n\ * if UPLO = 'U': if UPLO = 'L':\n\ *\n\ * ( d e v2 v3 v4 ) ( d )\n\ * ( d e v3 v4 ) ( e d )\n\ * ( d e v4 ) ( v1 e d )\n\ * ( d e ) ( v1 v2 e d )\n\ * ( d ) ( v1 v2 v3 e d )\n\ *\n\ * where d and e denote diagonal and off-diagonal elements of T, and vi\n\ * denotes an element of the vector defining H(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlagtm0000644000175000017500000000617012502223526016464 0ustar uwabamiuwabami--- :name: dlagtm :md5sum: cc3d3f3d4b1b3e13c85f7cbd11769a05 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - alpha: :type: doublereal :intent: input - dl: :type: doublereal :intent: input :dims: - n-1 - d: :type: doublereal :intent: input :dims: - n - du: :type: doublereal :intent: input :dims: - n-1 - x: :type: doublereal :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - beta: :type: doublereal :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE DLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, B, LDB )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAGTM performs a matrix-vector product of the form\n\ *\n\ * B := alpha * A * X + beta * B\n\ *\n\ * where A is a tridiagonal matrix of order N, B and X are N by NRHS\n\ * matrices, and alpha and beta are real scalars, each of which may be\n\ * 0., 1., or -1.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the operation applied to A.\n\ * = 'N': No transpose, B := alpha * A * X + beta * B\n\ * = 'T': Transpose, B := alpha * A'* X + beta * B\n\ * = 'C': Conjugate transpose = Transpose\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices X and B.\n\ *\n\ * ALPHA (input) DOUBLE PRECISION\n\ * The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise,\n\ * it is assumed to be 0.\n\ *\n\ * DL (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) sub-diagonal elements of T.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The diagonal elements of T.\n\ *\n\ * DU (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) super-diagonal elements of T.\n\ *\n\ * X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * The N by NRHS matrix X.\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(N,1).\n\ *\n\ * BETA (input) DOUBLE PRECISION\n\ * The scalar beta. BETA must be 0., 1., or -1.; otherwise,\n\ * it is assumed to be 1.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the N by NRHS matrix B.\n\ * On exit, B is overwritten by the matrix expression\n\ * B := alpha * A * X + beta * B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(N,1).\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/srscl0000644000175000017500000000256112502223526016342 0ustar uwabamiuwabami--- :name: srscl :md5sum: 45d3ebae0bf847fdef2d0c541c71e3e8 :category: :subroutine :arguments: - n: :type: integer :intent: input - sa: :type: real :intent: input - sx: :type: real :intent: input/output :dims: - 1+(n-1)*abs(incx) - incx: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE SRSCL( N, SA, SX, INCX )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SRSCL multiplies an n-element real vector x by the real scalar 1/a.\n\ * This is done without overflow or underflow as long as\n\ * the final result x/a does not overflow or underflow.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of components of the vector x.\n\ *\n\ * SA (input) REAL\n\ * The scalar a which is used to divide each component of x.\n\ * SA must be >= 0, or the subroutine will divide by zero.\n\ *\n\ * SX (input/output) REAL array, dimension\n\ * (1+(N-1)*abs(INCX))\n\ * The n-element vector x.\n\ *\n\ * INCX (input) INTEGER\n\ * The increment between successive values of the vector SX.\n\ * > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zsysv0000644000175000017500000001277412502223526016421 0ustar uwabamiuwabami--- :name: zsysv :md5sum: d9c87655fe579731fe5a3d20af290357 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSYSV computes the solution to a complex system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n\ * matrices.\n\ *\n\ * The diagonal pivoting method is used to factor A as\n\ * A = U * D * U**T, if UPLO = 'U', or\n\ * A = L * D * L**T, if UPLO = 'L',\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, and D is symmetric and block diagonal with\n\ * 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then\n\ * used to solve the system of equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the block diagonal matrix D and the\n\ * multipliers used to obtain the factor U or L from the\n\ * factorization A = U*D*U**T or A = L*D*L**T as computed by\n\ * ZSYTRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D, as\n\ * determined by ZSYTRF. If IPIV(k) > 0, then rows and columns\n\ * k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n\ * diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n\ * then rows and columns k-1 and -IPIV(k) were interchanged and\n\ * D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n\ * IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n\ * -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n\ * diagonal block.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of WORK. LWORK >= 1, and for best performance\n\ * LWORK >= max(1,N*NB), where NB is the optimal blocksize for\n\ * ZSYTRF.\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, D(i,i) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular, so the solution could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LWKOPT, NB\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZSYTRF, ZSYTRS2\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlartg0000644000175000017500000000355412502223526016474 0ustar uwabamiuwabami--- :name: dlartg :md5sum: bb5487cb5406058ab57b2e64f937ebe7 :category: :subroutine :arguments: - f: :type: doublereal :intent: input - g: :type: doublereal :intent: input - cs: :type: doublereal :intent: output - sn: :type: doublereal :intent: output - r: :type: doublereal :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLARTG( F, G, CS, SN, R )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLARTG generate a plane rotation so that\n\ *\n\ * [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1.\n\ * [ -SN CS ] [ G ] [ 0 ]\n\ *\n\ * This is a slower, more accurate version of the BLAS1 routine DROTG,\n\ * with the following other differences:\n\ * F and G are unchanged on return.\n\ * If G=0, then CS=1 and SN=0.\n\ * If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any\n\ * floating point operations (saves work in DBDSQR when\n\ * there are zeros on the diagonal).\n\ *\n\ * If F exceeds G in magnitude, CS will be positive.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * F (input) DOUBLE PRECISION\n\ * The first component of vector to be rotated.\n\ *\n\ * G (input) DOUBLE PRECISION\n\ * The second component of vector to be rotated.\n\ *\n\ * CS (output) DOUBLE PRECISION\n\ * The cosine of the rotation.\n\ *\n\ * SN (output) DOUBLE PRECISION\n\ * The sine of the rotation.\n\ *\n\ * R (output) DOUBLE PRECISION\n\ * The nonzero component of the rotated vector.\n\ *\n\ * This version has a few statements commented out for thread safety\n\ * (machine parameters are computed on each entry). 10 feb 03, SJH.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/claqr10000644000175000017500000000352312502223525016375 0ustar uwabamiuwabami--- :name: claqr1 :md5sum: 3f19c2453a865a3b2236f6174de113ff :category: :subroutine :arguments: - n: :type: integer :intent: input - h: :type: complex :intent: input :dims: - ldh - n - ldh: :type: integer :intent: input - s1: :type: complex :intent: input - s2: :type: complex :intent: input - v: :type: complex :intent: output :dims: - n :substitutions: {} :fortran_help: " SUBROUTINE CLAQR1( N, H, LDH, S1, S2, V )\n\n\ * Given a 2-by-2 or 3-by-3 matrix H, CLAQR1 sets v to a\n\ * scalar multiple of the first column of the product\n\ *\n\ * (*) K = (H - s1*I)*(H - s2*I)\n\ *\n\ * scaling to avoid overflows and most underflows.\n\ *\n\ * This is useful for starting double implicit shift bulges\n\ * in the QR algorithm.\n\ *\n\ *\n\n\ * N (input) integer\n\ * Order of the matrix H. N must be either 2 or 3.\n\ *\n\ * H (input) COMPLEX array of dimension (LDH,N)\n\ * The 2-by-2 or 3-by-3 matrix H in (*).\n\ *\n\ * LDH (input) integer\n\ * The leading dimension of H as declared in\n\ * the calling procedure. LDH.GE.N\n\ *\n\ * S1 (input) COMPLEX\n\ * S2 S1 and S2 are the shifts defining K in (*) above.\n\ *\n\ * V (output) COMPLEX array of dimension N\n\ * A scalar multiple of the first column of the\n\ * matrix K in (*).\n\ *\n\n\ * ================================================================\n\ * Based on contributions by\n\ * Karen Braman and Ralph Byers, Department of Mathematics,\n\ * University of Kansas, USA\n\ *\n\ * ================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slatrs0000644000175000017500000001671212502223526016527 0ustar uwabamiuwabami--- :name: slatrs :md5sum: 1a089a896f377a66e150c7a73da1b5d3 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - normin: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - n - scale: :type: real :intent: output - cnorm: :type: real :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, CNORM, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLATRS solves one of the triangular systems\n\ *\n\ * A *x = s*b or A'*x = s*b\n\ *\n\ * with scaling to prevent overflow. Here A is an upper or lower\n\ * triangular matrix, A' denotes the transpose of A, x and b are\n\ * n-element vectors, and s is a scaling factor, usually less than\n\ * or equal to 1, chosen so that the components of x will be less than\n\ * the overflow threshold. If the unscaled problem will not cause\n\ * overflow, the Level 2 BLAS routine STRSV is called. If the matrix A\n\ * is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n\ * non-trivial solution to A*x = 0 is returned.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the matrix A is upper or lower triangular.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the operation applied to A.\n\ * = 'N': Solve A * x = s*b (No transpose)\n\ * = 'T': Solve A'* x = s*b (Transpose)\n\ * = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * Specifies whether or not the matrix A is unit triangular.\n\ * = 'N': Non-unit triangular\n\ * = 'U': Unit triangular\n\ *\n\ * NORMIN (input) CHARACTER*1\n\ * Specifies whether CNORM has been set or not.\n\ * = 'Y': CNORM contains the column norms on entry\n\ * = 'N': CNORM is not set on entry. On exit, the norms will\n\ * be computed and stored in CNORM.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * The triangular matrix A. If UPLO = 'U', the leading n by n\n\ * upper triangular part of the array A contains the upper\n\ * triangular matrix, and the strictly lower triangular part of\n\ * A is not referenced. If UPLO = 'L', the leading n by n lower\n\ * triangular part of the array A contains the lower triangular\n\ * matrix, and the strictly upper triangular part of A is not\n\ * referenced. If DIAG = 'U', the diagonal elements of A are\n\ * also not referenced and are assumed to be 1.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max (1,N).\n\ *\n\ * X (input/output) REAL array, dimension (N)\n\ * On entry, the right hand side b of the triangular system.\n\ * On exit, X is overwritten by the solution vector x.\n\ *\n\ * SCALE (output) REAL\n\ * The scaling factor s for the triangular system\n\ * A * x = s*b or A'* x = s*b.\n\ * If SCALE = 0, the matrix A is singular or badly scaled, and\n\ * the vector x is an exact or approximate solution to A*x = 0.\n\ *\n\ * CNORM (input or output) REAL array, dimension (N)\n\ *\n\ * If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n\ * contains the norm of the off-diagonal part of the j-th column\n\ * of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n\ * to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n\ * must be greater than or equal to the 1-norm.\n\ *\n\ * If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n\ * returns the 1-norm of the offdiagonal part of the j-th column\n\ * of A.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ *\n\n\ * Further Details\n\ * ======= =======\n\ *\n\ * A rough bound on x is computed; if that is less than overflow, STRSV\n\ * is called, otherwise, specific code is used which checks for possible\n\ * overflow or divide-by-zero at every operation.\n\ *\n\ * A columnwise scheme is used for solving A*x = b. The basic algorithm\n\ * if A is lower triangular is\n\ *\n\ * x[1:n] := b[1:n]\n\ * for j = 1, ..., n\n\ * x(j) := x(j) / A(j,j)\n\ * x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n\ * end\n\ *\n\ * Define bounds on the components of x after j iterations of the loop:\n\ * M(j) = bound on x[1:j]\n\ * G(j) = bound on x[j+1:n]\n\ * Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n\ *\n\ * Then for iteration j+1 we have\n\ * M(j+1) <= G(j) / | A(j+1,j+1) |\n\ * G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n\ * <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n\ *\n\ * where CNORM(j+1) is greater than or equal to the infinity-norm of\n\ * column j+1 of A, not counting the diagonal. Hence\n\ *\n\ * G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n\ * 1<=i<=j\n\ * and\n\ *\n\ * |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n\ * 1<=i< j\n\ *\n\ * Since |x(j)| <= M(j), we use the Level 2 BLAS routine STRSV if the\n\ * reciprocal of the largest M(j), j=1,..,n, is larger than\n\ * max(underflow, 1/overflow).\n\ *\n\ * The bound on x(j) is also used to determine when a step in the\n\ * columnwise method can be performed without fear of overflow. If\n\ * the computed bound is greater than a large constant, x is scaled to\n\ * prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n\ * 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n\ *\n\ * Similarly, a row-wise scheme is used to solve A'*x = b. The basic\n\ * algorithm for A upper triangular is\n\ *\n\ * for j = 1, ..., n\n\ * x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n\ * end\n\ *\n\ * We simultaneously compute two bounds\n\ * G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n\ * M(j) = bound on x(i), 1<=i<=j\n\ *\n\ * The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n\ * add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n\ * Then the bound on x(j) is\n\ *\n\ * M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n\ *\n\ * <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n\ * 1<=i<=j\n\ *\n\ * and we can safely call STRSV if 1/M(n) and 1/G(n) are both greater\n\ * than max(underflow, 1/overflow).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dtrti20000644000175000017500000000455512502223526016431 0ustar uwabamiuwabami--- :name: dtrti2 :md5sum: 79f9cf1a3356f3c9b6db28e00f2a9527 :category: :subroutine :arguments: - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTRTI2 computes the inverse of a real upper or lower triangular\n\ * matrix.\n\ *\n\ * This is the Level 2 BLAS version of the algorithm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the matrix A is upper or lower triangular.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * Specifies whether or not the matrix A is unit triangular.\n\ * = 'N': Non-unit triangular\n\ * = 'U': Unit triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the triangular matrix A. If UPLO = 'U', the\n\ * leading n by n upper triangular part of the array A contains\n\ * the upper triangular matrix, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n by n lower triangular part of the array A contains\n\ * the lower triangular matrix, and the strictly upper\n\ * triangular part of A is not referenced. If DIAG = 'U', the\n\ * diagonal elements of A are also not referenced and are\n\ * assumed to be 1.\n\ *\n\ * On exit, the (triangular) inverse of the original matrix, in\n\ * the same storage format.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlasd70000644000175000017500000002050312502223526016366 0ustar uwabamiuwabami--- :name: dlasd7 :md5sum: f4a96aafe698a9fe1dc5bee822c506d3 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - nl: :type: integer :intent: input - nr: :type: integer :intent: input - sqre: :type: integer :intent: input - k: :type: integer :intent: output - d: :type: doublereal :intent: input/output :dims: - n - z: :type: doublereal :intent: output :dims: - m - zw: :type: doublereal :intent: workspace :dims: - m - vf: :type: doublereal :intent: input/output :dims: - m - vfw: :type: doublereal :intent: workspace :dims: - m - vl: :type: doublereal :intent: input/output :dims: - m - vlw: :type: doublereal :intent: workspace :dims: - m - alpha: :type: doublereal :intent: input - beta: :type: doublereal :intent: input - dsigma: :type: doublereal :intent: output :dims: - n - idx: :type: integer :intent: workspace :dims: - n - idxp: :type: integer :intent: workspace :dims: - n - idxq: :type: integer :intent: input :dims: - n - perm: :type: integer :intent: output :dims: - n - givptr: :type: integer :intent: output - givcol: :type: integer :intent: output :dims: - ldgcol - "2" - ldgcol: :type: integer :intent: input - givnum: :type: doublereal :intent: output :dims: - ldgnum - "2" - ldgnum: :type: integer :intent: input - c: :type: doublereal :intent: output - s: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: ldgnum: n ldgcol: n :fortran_help: " SUBROUTINE DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL, VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, C, S, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLASD7 merges the two sets of singular values together into a single\n\ * sorted set. Then it tries to deflate the size of the problem. There\n\ * are two ways in which deflation can occur: when two or more singular\n\ * values are close together or if there is a tiny entry in the Z\n\ * vector. For each such occurrence the order of the related\n\ * secular equation problem is reduced by one.\n\ *\n\ * DLASD7 is called from DLASD6.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ICOMPQ (input) INTEGER\n\ * Specifies whether singular vectors are to be computed\n\ * in compact form, as follows:\n\ * = 0: Compute singular values only.\n\ * = 1: Compute singular vectors of upper\n\ * bidiagonal matrix in compact form.\n\ *\n\ * NL (input) INTEGER\n\ * The row dimension of the upper block. NL >= 1.\n\ *\n\ * NR (input) INTEGER\n\ * The row dimension of the lower block. NR >= 1.\n\ *\n\ * SQRE (input) INTEGER\n\ * = 0: the lower block is an NR-by-NR square matrix.\n\ * = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n\ *\n\ * The bidiagonal matrix has\n\ * N = NL + NR + 1 rows and\n\ * M = N + SQRE >= N columns.\n\ *\n\ * K (output) INTEGER\n\ * Contains the dimension of the non-deflated matrix, this is\n\ * the order of the related secular equation. 1 <= K <=N.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension ( N )\n\ * On entry D contains the singular values of the two submatrices\n\ * to be combined. On exit D contains the trailing (N-K) updated\n\ * singular values (those which were deflated) sorted into\n\ * increasing order.\n\ *\n\ * Z (output) DOUBLE PRECISION array, dimension ( M )\n\ * On exit Z contains the updating row vector in the secular\n\ * equation.\n\ *\n\ * ZW (workspace) DOUBLE PRECISION array, dimension ( M )\n\ * Workspace for Z.\n\ *\n\ * VF (input/output) DOUBLE PRECISION array, dimension ( M )\n\ * On entry, VF(1:NL+1) contains the first components of all\n\ * right singular vectors of the upper block; and VF(NL+2:M)\n\ * contains the first components of all right singular vectors\n\ * of the lower block. On exit, VF contains the first components\n\ * of all right singular vectors of the bidiagonal matrix.\n\ *\n\ * VFW (workspace) DOUBLE PRECISION array, dimension ( M )\n\ * Workspace for VF.\n\ *\n\ * VL (input/output) DOUBLE PRECISION array, dimension ( M )\n\ * On entry, VL(1:NL+1) contains the last components of all\n\ * right singular vectors of the upper block; and VL(NL+2:M)\n\ * contains the last components of all right singular vectors\n\ * of the lower block. On exit, VL contains the last components\n\ * of all right singular vectors of the bidiagonal matrix.\n\ *\n\ * VLW (workspace) DOUBLE PRECISION array, dimension ( M )\n\ * Workspace for VL.\n\ *\n\ * ALPHA (input) DOUBLE PRECISION\n\ * Contains the diagonal element associated with the added row.\n\ *\n\ * BETA (input) DOUBLE PRECISION\n\ * Contains the off-diagonal element associated with the added\n\ * row.\n\ *\n\ * DSIGMA (output) DOUBLE PRECISION array, dimension ( N )\n\ * Contains a copy of the diagonal elements (K-1 singular values\n\ * and one zero) in the secular equation.\n\ *\n\ * IDX (workspace) INTEGER array, dimension ( N )\n\ * This will contain the permutation used to sort the contents of\n\ * D into ascending order.\n\ *\n\ * IDXP (workspace) INTEGER array, dimension ( N )\n\ * This will contain the permutation used to place deflated\n\ * values of D at the end of the array. On output IDXP(2:K)\n\ * points to the nondeflated D-values and IDXP(K+1:N)\n\ * points to the deflated singular values.\n\ *\n\ * IDXQ (input) INTEGER array, dimension ( N )\n\ * This contains the permutation which separately sorts the two\n\ * sub-problems in D into ascending order. Note that entries in\n\ * the first half of this permutation must first be moved one\n\ * position backward; and entries in the second half\n\ * must first have NL+1 added to their values.\n\ *\n\ * PERM (output) INTEGER array, dimension ( N )\n\ * The permutations (from deflation and sorting) to be applied\n\ * to each singular block. Not referenced if ICOMPQ = 0.\n\ *\n\ * GIVPTR (output) INTEGER\n\ * The number of Givens rotations which took place in this\n\ * subproblem. Not referenced if ICOMPQ = 0.\n\ *\n\ * GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )\n\ * Each pair of numbers indicates a pair of columns to take place\n\ * in a Givens rotation. Not referenced if ICOMPQ = 0.\n\ *\n\ * LDGCOL (input) INTEGER\n\ * The leading dimension of GIVCOL, must be at least N.\n\ *\n\ * GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )\n\ * Each number indicates the C or S value to be used in the\n\ * corresponding Givens rotation. Not referenced if ICOMPQ = 0.\n\ *\n\ * LDGNUM (input) INTEGER\n\ * The leading dimension of GIVNUM, must be at least N.\n\ *\n\ * C (output) DOUBLE PRECISION\n\ * C contains garbage if SQRE =0 and the C-value of a Givens\n\ * rotation related to the right null space if SQRE = 1.\n\ *\n\ * S (output) DOUBLE PRECISION\n\ * S contains garbage if SQRE =0 and the S-value of a Givens\n\ * rotation related to the right null space if SQRE = 1.\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\ * Based on contributions by\n\ * Ming Gu and Huan Ren, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clahrd0000644000175000017500000001054612502223525016452 0ustar uwabamiuwabami--- :name: clahrd :md5sum: 6123a9d87b5a1b9590c8e1a49e30d6f8 :category: :subroutine :arguments: - n: :type: integer :intent: input - k: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n-k+1 - lda: :type: integer :intent: input - tau: :type: complex :intent: output :dims: - MAX(1,nb) - t: :type: complex :intent: output :dims: - ldt - MAX(1,nb) - ldt: :type: integer :intent: input - y: :type: complex :intent: output :dims: - ldy - MAX(1,nb) - ldy: :type: integer :intent: input :substitutions: ldy: MAX(1,n) ldt: nb :fortran_help: " SUBROUTINE CLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAHRD reduces the first NB columns of a complex general n-by-(n-k+1)\n\ * matrix A so that elements below the k-th subdiagonal are zero. The\n\ * reduction is performed by a unitary similarity transformation\n\ * Q' * A * Q. The routine returns the matrices V and T which determine\n\ * Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n\ *\n\ * This is an OBSOLETE auxiliary routine. \n\ * This routine will be 'deprecated' in a future release.\n\ * Please use the new routine CLAHR2 instead.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A.\n\ *\n\ * K (input) INTEGER\n\ * The offset for the reduction. Elements below the k-th\n\ * subdiagonal in the first NB columns are reduced to zero.\n\ *\n\ * NB (input) INTEGER\n\ * The number of columns to be reduced.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N-K+1)\n\ * On entry, the n-by-(n-k+1) general matrix A.\n\ * On exit, the elements on and above the k-th subdiagonal in\n\ * the first NB columns are overwritten with the corresponding\n\ * elements of the reduced matrix; the elements below the k-th\n\ * subdiagonal, with the array TAU, represent the matrix Q as a\n\ * product of elementary reflectors. The other columns of A are\n\ * unchanged. See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * TAU (output) COMPLEX array, dimension (NB)\n\ * The scalar factors of the elementary reflectors. See Further\n\ * Details.\n\ *\n\ * T (output) COMPLEX array, dimension (LDT,NB)\n\ * The upper triangular matrix T.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= NB.\n\ *\n\ * Y (output) COMPLEX array, dimension (LDY,NB)\n\ * The n-by-nb matrix Y.\n\ *\n\ * LDY (input) INTEGER\n\ * The leading dimension of the array Y. LDY >= max(1,N).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The matrix Q is represented as a product of nb elementary reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(nb).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar, and v is a complex vector with\n\ * v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n\ * A(i+k+1:n,i), and tau in TAU(i).\n\ *\n\ * The elements of the vectors v together form the (n-k+1)-by-nb matrix\n\ * V which is needed, with T and Y, to apply the transformation to the\n\ * unreduced part of the matrix, using an update of the form:\n\ * A := (I - V*T*V') * (A - Y*V').\n\ *\n\ * The contents of A on exit are illustrated by the following example\n\ * with n = 7, k = 3 and nb = 2:\n\ *\n\ * ( a h a a a )\n\ * ( a h a a a )\n\ * ( a h a a a )\n\ * ( h h a a a )\n\ * ( v1 h a a a )\n\ * ( v1 v2 a a a )\n\ * ( v1 v2 a a a )\n\ *\n\ * where a denotes an element of the original matrix A, h denotes a\n\ * modified element of the upper Hessenberg matrix H, and vi denotes an\n\ * element of the vector defining H(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlascl0000644000175000017500000000640312502223526016503 0ustar uwabamiuwabami--- :name: zlascl :md5sum: bebaac4c17a950c4466313a4484f3dac :category: :subroutine :arguments: - type: :type: char :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - cfrom: :type: doublereal :intent: input - cto: :type: doublereal :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLASCL multiplies the M by N complex matrix A by the real scalar\n\ * CTO/CFROM. This is done without over/underflow as long as the final\n\ * result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that\n\ * A may be full, upper triangular, lower triangular, upper Hessenberg,\n\ * or banded.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TYPE (input) CHARACTER*1\n\ * TYPE indices the storage type of the input matrix.\n\ * = 'G': A is a full matrix.\n\ * = 'L': A is a lower triangular matrix.\n\ * = 'U': A is an upper triangular matrix.\n\ * = 'H': A is an upper Hessenberg matrix.\n\ * = 'B': A is a symmetric band matrix with lower bandwidth KL\n\ * and upper bandwidth KU and with the only the lower\n\ * half stored.\n\ * = 'Q': A is a symmetric band matrix with lower bandwidth KL\n\ * and upper bandwidth KU and with the only the upper\n\ * half stored.\n\ * = 'Z': A is a band matrix with lower bandwidth KL and upper\n\ * bandwidth KU. See ZGBTRF for storage details.\n\ *\n\ * KL (input) INTEGER\n\ * The lower bandwidth of A. Referenced only if TYPE = 'B',\n\ * 'Q' or 'Z'.\n\ *\n\ * KU (input) INTEGER\n\ * The upper bandwidth of A. Referenced only if TYPE = 'B',\n\ * 'Q' or 'Z'.\n\ *\n\ * CFROM (input) DOUBLE PRECISION\n\ * CTO (input) DOUBLE PRECISION\n\ * The matrix A is multiplied by CTO/CFROM. A(I,J) is computed\n\ * without over/underflow if the final result CTO*A(I,J)/CFROM\n\ * can be represented without over/underflow. CFROM must be\n\ * nonzero.\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) COMPLEX*16 array, dimension (LDA,N)\n\ * The matrix to be multiplied by CTO/CFROM. See TYPE for the\n\ * storage type.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slantb0000644000175000017500000000705412502223526016501 0ustar uwabamiuwabami--- :name: slantb :md5sum: 7d0806eebdfcdd6789f9862ed9fa7fed :category: :function :type: real :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - ab: :type: real :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? n : 0" :fortran_help: " REAL FUNCTION SLANTB( NORM, UPLO, DIAG, N, K, AB, LDAB, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLANTB returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of an\n\ * n by n triangular band matrix A, with ( k + 1 ) diagonals.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * SLANTB returns the value\n\ *\n\ * SLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in SLANTB as described\n\ * above.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the matrix A is upper or lower triangular.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * Specifies whether or not the matrix A is unit triangular.\n\ * = 'N': Non-unit triangular\n\ * = 'U': Unit triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0. When N = 0, SLANTB is\n\ * set to zero.\n\ *\n\ * K (input) INTEGER\n\ * The number of super-diagonals of the matrix A if UPLO = 'U',\n\ * or the number of sub-diagonals of the matrix A if UPLO = 'L'.\n\ * K >= 0.\n\ *\n\ * AB (input) REAL array, dimension (LDAB,N)\n\ * The upper or lower triangular band matrix A, stored in the\n\ * first k+1 rows of AB. The j-th column of A is stored\n\ * in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).\n\ * Note that when DIAG = 'U', the elements of the array AB\n\ * corresponding to the diagonal elements of the matrix A are\n\ * not referenced, but are assumed to be one.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= K+1.\n\ *\n\ * WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n\ * referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgbsvxx0000644000175000017500000005636412502223526016732 0ustar uwabamiuwabami--- :name: sgbsvxx :md5sum: 1a073673d020ab52ceac35b96fd91246 :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: real :intent: input/output :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - equed: :type: char :intent: input/output - r: :type: real :intent: input/output :dims: - n - c: :type: real :intent: input/output :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - rpvgrw: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: real :intent: workspace :dims: - 4*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " SUBROUTINE SGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGBSVXX uses the LU factorization to compute the solution to a\n\ * real system of linear equations A * X = B, where A is an\n\ * N-by-N matrix and X and B are N-by-NRHS matrices.\n\ *\n\ * If requested, both normwise and maximum componentwise error bounds\n\ * are returned. SGBSVXX will return a solution with a tiny\n\ * guaranteed error (O(eps) where eps is the working machine\n\ * precision) unless the matrix is very ill-conditioned, in which\n\ * case a warning is returned. Relevant condition numbers also are\n\ * calculated and returned.\n\ *\n\ * SGBSVXX accepts user-provided factorizations and equilibration\n\ * factors; see the definitions of the FACT and EQUED options.\n\ * Solving with refinement and using a factorization from a previous\n\ * SGBSVXX call will also produce a solution with either O(eps)\n\ * errors or warnings, but we cannot make that claim for general\n\ * user-provided factorizations and equilibration factors if they\n\ * differ from what SGBSVXX would itself produce.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', real scaling factors are computed to equilibrate\n\ * the system:\n\ *\n\ * TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n\ * TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n\ * TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n\ *\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n\ * or diag(C)*B (if TRANS = 'T' or 'C').\n\ *\n\ * 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n\ * the matrix A (after equilibration if FACT = 'E') as\n\ *\n\ * A = P * L * U,\n\ *\n\ * where P is a permutation matrix, L is a unit lower triangular\n\ * matrix, and U is upper triangular.\n\ *\n\ * 3. If some U(i,i)=0, so that U is exactly singular, then the\n\ * routine returns with INFO = i. Otherwise, the factored form of A\n\ * is used to estimate the condition number of the matrix A (see\n\ * argument RCOND). If the reciprocal of the condition number is less\n\ * than machine precision, the routine still goes on to solve for X\n\ * and compute error bounds as described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n\ * the routine will use iterative refinement to try to get a small\n\ * error and error bounds. Refinement calculates the residual to at\n\ * least twice the working precision.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n\ * that it solves the original system before equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AF and IPIV contain the factored form of A.\n\ * If EQUED is not 'N', the matrix A has been\n\ * equilibrated with scaling factors given by R and C.\n\ * A, AF, and IPIV are not modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AF and factored.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate Transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AB (input/output) REAL array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n\ *\n\ * If FACT = 'F' and EQUED is not 'N', then AB must have been\n\ * equilibrated by the scaling factors in R and/or C. AB is not\n\ * modified if FACT = 'F' or 'N', or if FACT = 'E' and\n\ * EQUED = 'N' on exit.\n\ *\n\ * On exit, if EQUED .ne. 'N', A is scaled as follows:\n\ * EQUED = 'R': A := diag(R) * A\n\ * EQUED = 'C': A := A * diag(C)\n\ * EQUED = 'B': A := diag(R) * A * diag(C).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * AFB (input or output) REAL array, dimension (LDAFB,N)\n\ * If FACT = 'F', then AFB is an input argument and on entry\n\ * contains details of the LU factorization of the band matrix\n\ * A, as computed by SGBTRF. U is stored as an upper triangular\n\ * band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n\ * and the multipliers used during the factorization are stored\n\ * in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is\n\ * the factored form of the equilibrated matrix A.\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the factors L and U from the factorization A = P*L*U\n\ * of the original matrix A.\n\ *\n\ * If FACT = 'E', then AF is an output argument and on exit\n\ * returns the factors L and U from the factorization A = P*L*U\n\ * of the equilibrated matrix A (see the description of A for\n\ * the form of the equilibrated matrix).\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * as computed by SGETRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * of the original matrix A.\n\ *\n\ * If FACT = 'E', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * of the equilibrated matrix A.\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * R (input or output) REAL array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'R' or 'B', A is\n\ * multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n\ * is not accessed. R is an input argument if FACT = 'F';\n\ * otherwise, R is an output argument. If FACT = 'F' and\n\ * EQUED = 'R' or 'B', each element of R must be positive.\n\ * If R is output, each element of R is a power of the radix.\n\ * If R is input, each element of R should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * C (input or output) REAL array, dimension (N)\n\ * The column scale factors for A. If EQUED = 'C' or 'B', A is\n\ * multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n\ * is not accessed. C is an input argument if FACT = 'F';\n\ * otherwise, C is an output argument. If FACT = 'F' and\n\ * EQUED = 'C' or 'B', each element of C must be positive.\n\ * If C is output, each element of C is a power of the radix.\n\ * If C is input, each element of C should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit,\n\ * if EQUED = 'N', B is not modified;\n\ * if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n\ * diag(R)*B;\n\ * if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n\ * overwritten by diag(C)*B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) REAL array, dimension (LDX,NRHS)\n\ * If INFO = 0, the N-by-NRHS solution matrix X to the original\n\ * system of equations. Note that A and B are modified on exit\n\ * if EQUED .ne. 'N', and the solution to the equilibrated system is\n\ * inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n\ * inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * RPVGRW (output) REAL\n\ * Reciprocal pivot growth. On exit, this contains the reciprocal\n\ * pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n\ * norm is used. If this is much less than 1, then the stability of\n\ * the LU factorization of the (equilibrated) matrix A could be poor.\n\ * This also means that the solution X, estimated condition numbers,\n\ * and error bounds could be unreliable. If factorization fails with\n\ * 0 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgehd20000644000175000017500000000733612502223526016375 0ustar uwabamiuwabami--- :name: sgehd2 :md5sum: 63d6daed935852377ebae7aa7ad348d6 :category: :subroutine :arguments: - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - n-1 - work: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGEHD2 reduces a real general matrix A to upper Hessenberg form H by\n\ * an orthogonal similarity transformation: Q' * A * Q = H .\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * It is assumed that A is already upper triangular in rows\n\ * and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n\ * set by a previous call to SGEBAL; otherwise they should be\n\ * set to 1 and N respectively. See Further Details.\n\ * 1 <= ILO <= IHI <= max(1,N).\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the n by n general matrix to be reduced.\n\ * On exit, the upper triangle and the first subdiagonal of A\n\ * are overwritten with the upper Hessenberg matrix H, and the\n\ * elements below the first subdiagonal, with the array TAU,\n\ * represent the orthogonal matrix Q as a product of elementary\n\ * reflectors. See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * TAU (output) REAL array, dimension (N-1)\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace) REAL array, dimension (N)\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 (ihi-ilo) elementary\n\ * reflectors\n\ *\n\ * Q = H(ilo) H(ilo+1) . . . H(ihi-1).\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) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n\ * exit in A(i+2:ihi,i), and tau in TAU(i).\n\ *\n\ * The contents of A are illustrated by the following example, with\n\ * n = 7, ilo = 2 and ihi = 6:\n\ *\n\ * on entry, on exit,\n\ *\n\ * ( a a a a a a a ) ( a a h h h h a )\n\ * ( a a a a a a ) ( a h h h h a )\n\ * ( a a a a a a ) ( h h h h h h )\n\ * ( a a a a a a ) ( v2 h h h h h )\n\ * ( a a a a a a ) ( v2 v3 h h h h )\n\ * ( a a a a a a ) ( v2 v3 v4 h h h )\n\ * ( a ) ( a )\n\ *\n\ * where a denotes an element of the original matrix A, h denotes a\n\ * modified element of the upper Hessenberg matrix H, and vi denotes an\n\ * element of the vector defining H(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slas20000644000175000017500000000402012502223526016230 0ustar uwabamiuwabami--- :name: slas2 :md5sum: c614a835281cb4cc90907af6ff259ba5 :category: :subroutine :arguments: - f: :type: real :intent: input - g: :type: real :intent: input - h: :type: real :intent: input - ssmin: :type: real :intent: output - ssmax: :type: real :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLAS2( F, G, H, SSMIN, SSMAX )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLAS2 computes the singular values of the 2-by-2 matrix\n\ * [ F G ]\n\ * [ 0 H ].\n\ * On return, SSMIN is the smaller singular value and SSMAX is the\n\ * larger singular value.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * F (input) REAL\n\ * The (1,1) element of the 2-by-2 matrix.\n\ *\n\ * G (input) REAL\n\ * The (1,2) element of the 2-by-2 matrix.\n\ *\n\ * H (input) REAL\n\ * The (2,2) element of the 2-by-2 matrix.\n\ *\n\ * SSMIN (output) REAL\n\ * The smaller singular value.\n\ *\n\ * SSMAX (output) REAL\n\ * The larger singular value.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Barring over/underflow, all output quantities are correct to within\n\ * a few units in the last place (ulps), even in the absence of a guard\n\ * digit in addition/subtraction.\n\ *\n\ * In IEEE arithmetic, the code works correctly if one matrix element is\n\ * infinite.\n\ *\n\ * Overflow will not occur unless the largest singular value itself\n\ * overflows, or is within a few ulps of overflow. (On machines with\n\ * partial overflow, like the Cray, overflow may occur if the largest\n\ * singular value is within a factor of 2 of overflow.)\n\ *\n\ * Underflow is harmless if underflow is gradual. Otherwise, results\n\ * may correspond to a matrix modified by perturbations of size near\n\ * the underflow threshold.\n\ *\n\ * ====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zpbcon0000644000175000017500000000606712502223526016514 0ustar uwabamiuwabami--- :name: zpbcon :md5sum: dbeb25aefa4d76514d1bf4c3290a6939 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - anorm: :type: doublereal :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPBCON estimates the reciprocal of the condition number (in the\n\ * 1-norm) of a complex Hermitian positive definite band matrix using\n\ * the Cholesky factorization A = U**H*U or A = L*L**H computed by\n\ * ZPBTRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangular factor stored in AB;\n\ * = 'L': Lower triangular factor stored in AB.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input) COMPLEX*16 array, dimension (LDAB,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**H*U or A = L*L**H of the band matrix A, stored in the\n\ * first KD+1 rows of the array. The j-th column of U or L is\n\ * stored in the j-th column of the array AB as follows:\n\ * if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * ANORM (input) DOUBLE PRECISION\n\ * The 1-norm (or infinity-norm) of the Hermitian band matrix A.\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n\ * estimate of the 1-norm of inv(A) computed in this routine.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlaneg0000644000175000017500000000540412502223526016445 0ustar uwabamiuwabami--- :name: dlaneg :md5sum: c5a7742f33a7d96a4fed5f670646bf40 :category: :function :type: integer :arguments: - n: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - lld: :type: doublereal :intent: input :dims: - n-1 - sigma: :type: doublereal :intent: input - pivmin: :type: doublereal :intent: input - r: :type: integer :intent: input :substitutions: {} :fortran_help: " INTEGER FUNCTION DLANEG( N, D, LLD, SIGMA, PIVMIN, R )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLANEG computes the Sturm count, the number of negative pivots\n\ * encountered while factoring tridiagonal T - sigma I = L D L^T.\n\ * This implementation works directly on the factors without forming\n\ * the tridiagonal matrix T. The Sturm count is also the number of\n\ * eigenvalues of T less than sigma.\n\ *\n\ * This routine is called from DLARRB.\n\ *\n\ * The current routine does not use the PIVMIN parameter but rather\n\ * requires IEEE-754 propagation of Infinities and NaNs. This\n\ * routine also has no input range restrictions but does require\n\ * default exception handling such that x/0 produces Inf when x is\n\ * non-zero, and Inf/Inf produces NaN. For more information, see:\n\ *\n\ * Marques, Riedy, and Voemel, \"Benefits of IEEE-754 Features in\n\ * Modern Symmetric Tridiagonal Eigensolvers,\" SIAM Journal on\n\ * Scientific Computing, v28, n5, 2006. DOI 10.1137/050641624\n\ * (Tech report version in LAWN 172 with the same title.)\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The N diagonal elements of the diagonal matrix D.\n\ *\n\ * LLD (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (N-1) elements L(i)*L(i)*D(i).\n\ *\n\ * SIGMA (input) DOUBLE PRECISION\n\ * Shift amount in T - sigma I = L D L^T.\n\ *\n\ * PIVMIN (input) DOUBLE PRECISION\n\ * The minimum pivot in the Sturm sequence. May be used\n\ * when zero pivots are encountered on non-IEEE-754\n\ * architectures.\n\ *\n\ * R (input) INTEGER\n\ * The twist index for the twisted factorization that is used\n\ * for the negcount.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, University of California, Berkeley, USA\n\ * Jason Riedy, University of California, Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlahrd0000644000175000017500000001061212502223526016474 0ustar uwabamiuwabami--- :name: zlahrd :md5sum: a88d81f8a9f0ae03b94abf04574ebfc7 :category: :subroutine :arguments: - n: :type: integer :intent: input - k: :type: integer :intent: input - nb: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n-k+1 - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - MAX(1,nb) - t: :type: doublecomplex :intent: output :dims: - ldt - MAX(1,nb) - ldt: :type: integer :intent: input - y: :type: doublecomplex :intent: output :dims: - ldy - MAX(1,nb) - ldy: :type: integer :intent: input :substitutions: ldy: MAX(1,n) ldt: nb :fortran_help: " SUBROUTINE ZLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAHRD reduces the first NB columns of a complex general n-by-(n-k+1)\n\ * matrix A so that elements below the k-th subdiagonal are zero. The\n\ * reduction is performed by a unitary similarity transformation\n\ * Q' * A * Q. The routine returns the matrices V and T which determine\n\ * Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n\ *\n\ * This is an OBSOLETE auxiliary routine. \n\ * This routine will be 'deprecated' in a future release.\n\ * Please use the new routine ZLAHR2 instead.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A.\n\ *\n\ * K (input) INTEGER\n\ * The offset for the reduction. Elements below the k-th\n\ * subdiagonal in the first NB columns are reduced to zero.\n\ *\n\ * NB (input) INTEGER\n\ * The number of columns to be reduced.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N-K+1)\n\ * On entry, the n-by-(n-k+1) general matrix A.\n\ * On exit, the elements on and above the k-th subdiagonal in\n\ * the first NB columns are overwritten with the corresponding\n\ * elements of the reduced matrix; the elements below the k-th\n\ * subdiagonal, with the array TAU, represent the matrix Q as a\n\ * product of elementary reflectors. The other columns of A are\n\ * unchanged. See Further Details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * TAU (output) COMPLEX*16 array, dimension (NB)\n\ * The scalar factors of the elementary reflectors. See Further\n\ * Details.\n\ *\n\ * T (output) COMPLEX*16 array, dimension (LDT,NB)\n\ * The upper triangular matrix T.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= NB.\n\ *\n\ * Y (output) COMPLEX*16 array, dimension (LDY,NB)\n\ * The n-by-nb matrix Y.\n\ *\n\ * LDY (input) INTEGER\n\ * The leading dimension of the array Y. LDY >= max(1,N).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The matrix Q is represented as a product of nb elementary reflectors\n\ *\n\ * Q = H(1) H(2) . . . H(nb).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - tau * v * v'\n\ *\n\ * where tau is a complex scalar, and v is a complex vector with\n\ * v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n\ * A(i+k+1:n,i), and tau in TAU(i).\n\ *\n\ * The elements of the vectors v together form the (n-k+1)-by-nb matrix\n\ * V which is needed, with T and Y, to apply the transformation to the\n\ * unreduced part of the matrix, using an update of the form:\n\ * A := (I - V*T*V') * (A - Y*V').\n\ *\n\ * The contents of A on exit are illustrated by the following example\n\ * with n = 7, k = 3 and nb = 2:\n\ *\n\ * ( a h a a a )\n\ * ( a h a a a )\n\ * ( a h a a a )\n\ * ( h h a a a )\n\ * ( v1 h a a a )\n\ * ( v1 v2 a a a )\n\ * ( v1 v2 a a a )\n\ *\n\ * where a denotes an element of the original matrix A, h denotes a\n\ * modified element of the upper Hessenberg matrix H, and vi denotes an\n\ * element of the vector defining H(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlaset0000644000175000017500000000441112502223526016512 0ustar uwabamiuwabami--- :name: zlaset :md5sum: 9941400dd2c21dc0dc6001ceb3e73b8d :category: :subroutine :arguments: - uplo: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: doublecomplex :intent: input - beta: :type: doublecomplex :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLASET initializes a 2-D array A to BETA on the diagonal and\n\ * ALPHA on the offdiagonals.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies the part of the matrix A to be set.\n\ * = 'U': Upper triangular part is set. The lower triangle\n\ * is unchanged.\n\ * = 'L': Lower triangular part is set. The upper triangle\n\ * is unchanged.\n\ * Otherwise: All of the matrix A is set.\n\ *\n\ * M (input) INTEGER\n\ * On entry, M specifies the number of rows of A.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the number of columns of A.\n\ *\n\ * ALPHA (input) COMPLEX*16\n\ * All the offdiagonal array elements are set to ALPHA.\n\ *\n\ * BETA (input) COMPLEX*16\n\ * All the diagonal array elements are set to BETA.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the m by n matrix A.\n\ * On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j;\n\ * A(i,i) = BETA , 1 <= i <= min(m,n)\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sladiv0000644000175000017500000000257612502223526016504 0ustar uwabamiuwabami--- :name: sladiv :md5sum: ec621296a17da602467a623f15f8653a :category: :subroutine :arguments: - a: :type: real :intent: input - b: :type: real :intent: input - c: :type: real :intent: input - d: :type: real :intent: input - p: :type: real :intent: output - q: :type: real :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLADIV( A, B, C, D, P, Q )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLADIV performs complex division in real arithmetic\n\ *\n\ * a + i*b\n\ * p + i*q = ---------\n\ * c + i*d\n\ *\n\ * The algorithm is due to Robert L. Smith and can be found\n\ * in D. Knuth, The art of Computer Programming, Vol.2, p.195\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * A (input) REAL\n\ * B (input) REAL\n\ * C (input) REAL\n\ * D (input) REAL\n\ * The scalars a, b, c, and d in the above expression.\n\ *\n\ * P (output) REAL\n\ * Q (output) REAL\n\ * The scalars p and q in the above expression.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n REAL E, F\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/cgtts20000644000175000017500000000610012502223525016412 0ustar uwabamiuwabami--- :name: cgtts2 :md5sum: 1de5c22ebf43da7af448137202541249 :category: :subroutine :arguments: - itrans: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - dl: :type: complex :intent: input :dims: - n-1 - d: :type: complex :intent: input :dims: - n - du: :type: complex :intent: input :dims: - n-1 - du2: :type: complex :intent: input :dims: - n-2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE CGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGTTS2 solves one of the systems of equations\n\ * A * X = B, A**T * X = B, or A**H * X = B,\n\ * with a tridiagonal matrix A using the LU factorization computed\n\ * by CGTTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITRANS (input) INTEGER\n\ * Specifies the form of the system of equations.\n\ * = 0: A * X = B (No transpose)\n\ * = 1: A**T * X = B (Transpose)\n\ * = 2: A**H * X = B (Conjugate transpose)\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * DL (input) COMPLEX array, dimension (N-1)\n\ * The (n-1) multipliers that define the matrix L from the\n\ * LU factorization of A.\n\ *\n\ * D (input) COMPLEX array, dimension (N)\n\ * The n diagonal elements of the upper triangular matrix U from\n\ * the LU factorization of A.\n\ *\n\ * DU (input) COMPLEX array, dimension (N-1)\n\ * The (n-1) elements of the first super-diagonal of U.\n\ *\n\ * DU2 (input) COMPLEX array, dimension (N-2)\n\ * The (n-2) elements of the second super-diagonal of U.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices; for 1 <= i <= n, row i of the matrix was\n\ * interchanged with row IPIV(i). IPIV(i) will always be either\n\ * i or i+1; IPIV(i) = i indicates a row interchange was not\n\ * required.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the matrix of right hand side vectors B.\n\ * On exit, B is overwritten by the solution vectors X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n COMPLEX TEMP\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC CONJG\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sla_syrfsx_extended0000644000175000017500000003450712502223526021276 0ustar uwabamiuwabami--- :name: sla_syrfsx_extended :md5sum: fd7630441b09c3526e2b43719ebdce44 :category: :subroutine :arguments: - prec_type: :type: integer :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - colequ: :type: logical :intent: input - c: :type: real :intent: input :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - y: :type: real :intent: input/output :dims: - ldy - nrhs - ldy: :type: integer :intent: input - berr_out: :type: real :intent: output :dims: - nrhs - n_norms: :type: integer :intent: input - err_bnds_norm: :type: real :intent: input/output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: input/output :dims: - nrhs - n_err_bnds - res: :type: real :intent: input :dims: - n - ayb: :type: real :intent: input :dims: - n - dy: :type: real :intent: input :dims: - n - y_tail: :type: real :intent: input :dims: - n - rcond: :type: real :intent: input - ithresh: :type: integer :intent: input - rthresh: :type: real :intent: input - dz_ub: :type: real :intent: input - ignore_cwise: :type: logical :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n\ * Purpose\n\ * =======\n\ * \n\ * SLA_SYRFSX_EXTENDED improves the computed solution to a system of\n\ * linear equations by performing extra-precise iterative refinement\n\ * and provides error bounds and backward error estimates for the solution.\n\ * This subroutine is called by SSYRFSX to perform iterative refinement.\n\ * In addition to normwise error bound, the code provides maximum\n\ * componentwise error bound if possible. See comments for ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP for details of the error bounds. Note that this\n\ * subroutine is only resonsible for setting the second fields of\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * PREC_TYPE (input) INTEGER\n\ * Specifies the intermediate precision to be used in refinement.\n\ * The value is defined by ILAPREC(P) where P is a CHARACTER and\n\ * P = 'S': Single\n\ * = 'D': Double\n\ * = 'I': Indigenous\n\ * = 'X', 'E': Extra\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right-hand-sides, i.e., the number of columns of the\n\ * matrix B.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) REAL array, dimension (LDAF,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by SSYTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by SSYTRF.\n\ *\n\ * COLEQU (input) LOGICAL\n\ * If .TRUE. then column equilibration was done to A before calling\n\ * this routine. This is needed to compute the solution and error\n\ * bounds correctly.\n\ *\n\ * C (input) REAL array, dimension (N)\n\ * The column scale factors for A. If COLEQU = .FALSE., C\n\ * is not accessed. If C is input, each element of C should be a power\n\ * of the radix to ensure a reliable solution and error estimates.\n\ * Scaling by powers of the radix does not cause rounding errors unless\n\ * the result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input) REAL array, dimension (LDB,NRHS)\n\ * The right-hand-side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * Y (input/output) REAL array, dimension (LDY,NRHS)\n\ * On entry, the solution matrix X, as computed by SSYTRS.\n\ * On exit, the improved solution matrix Y.\n\ *\n\ * LDY (input) INTEGER\n\ * The leading dimension of the array Y. LDY >= max(1,N).\n\ *\n\ * BERR_OUT (output) REAL array, dimension (NRHS)\n\ * On exit, BERR_OUT(j) contains the componentwise relative backward\n\ * error for right-hand-side j from the formula\n\ * max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n\ * where abs(Z) is the componentwise absolute value of the matrix\n\ * or vector Z. This is computed by SLA_LIN_BERR.\n\ *\n\ * N_NORMS (input) INTEGER\n\ * Determines which error bounds to return (see ERR_BNDS_NORM\n\ * and ERR_BNDS_COMP).\n\ * If N_NORMS >= 1 return normwise error bounds.\n\ * If N_NORMS >= 2 return componentwise error bounds.\n\ *\n\ * ERR_BNDS_NORM (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * This subroutine is only responsible for setting the second field\n\ * above.\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * RES (input) REAL array, dimension (N)\n\ * Workspace to hold the intermediate residual.\n\ *\n\ * AYB (input) REAL array, dimension (N)\n\ * Workspace. This can be the same workspace passed for Y_TAIL.\n\ *\n\ * DY (input) REAL array, dimension (N)\n\ * Workspace to hold the intermediate solution.\n\ *\n\ * Y_TAIL (input) REAL array, dimension (N)\n\ * Workspace to hold the trailing bits of the intermediate solution.\n\ *\n\ * RCOND (input) REAL\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * ITHRESH (input) INTEGER\n\ * The maximum number of residual computations allowed for\n\ * refinement. The default is 10. For 'aggressive' set to 100 to\n\ * permit convergence using approximate factorizations or\n\ * factorizations other than LU. If the factorization uses a\n\ * technique other than Gaussian elimination, the guarantees in\n\ * ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n\ *\n\ * RTHRESH (input) REAL\n\ * Determines when to stop refinement if the error estimate stops\n\ * decreasing. Refinement will stop when the next solution no longer\n\ * satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n\ * the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n\ * default value is 0.5. For 'aggressive' set to 0.9 to permit\n\ * convergence on extremely ill-conditioned matrices. See LAWN 165\n\ * for more details.\n\ *\n\ * DZ_UB (input) REAL\n\ * Determines when to start considering componentwise convergence.\n\ * Componentwise convergence is only considered after each component\n\ * of the solution Y is stable, which we definte as the relative\n\ * change in each component being less than DZ_UB. The default value\n\ * is 0.25, requiring the first bit to be stable. See LAWN 165 for\n\ * more details.\n\ *\n\ * IGNORE_CWISE (input) LOGICAL\n\ * If .TRUE. then ignore componentwise convergence. Default value\n\ * is .FALSE..\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * < 0: if INFO = -i, the ith argument to SSYTRS had an illegal\n\ * value\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE\n REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n $ EPS, HUGEVAL, INCR_THRESH\n LOGICAL INCR_PREC\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sla_porpvgrw0000644000175000017500000000452312502223526017741 0ustar uwabamiuwabami--- :name: sla_porpvgrw :md5sum: 2edaf717ab5460c71293b964d4229d50 :category: :function :type: real :arguments: - uplo: :type: char :intent: input - ncols: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: real :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - work: :type: real :intent: input :dims: - 2*n :substitutions: {} :fortran_help: " REAL FUNCTION SLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, LDAF, WORK )\n\n\ * Purpose\n\ * =======\n\ * \n\ * SLA_PORPVGRW computes the reciprocal pivot growth factor\n\ * norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n\ * much less than 1, the stability of the LU factorization of the\n\ * (equilibrated) matrix A could be poor. This also means that the\n\ * solution X, estimated condition numbers, and error bounds could be\n\ * unreliable.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * NCOLS (input) INTEGER\n\ * The number of columns of the matrix A. NCOLS >= 0.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) REAL array, dimension (LDAF,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T, as computed by SPOTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * WORK (input) REAL array, dimension (2*N)\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n REAL AMAX, UMAX, RPVGRW\n LOGICAL UPPER\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN\n\ * ..\n\ * .. External Functions ..\n EXTERNAL LSAME, SLASET\n LOGICAL LSAME\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zhgeqz0000644000175000017500000002246212502223526016526 0ustar uwabamiuwabami--- :name: zhgeqz :md5sum: abe28a9dc3cbffd9489f94d78eb0d905 :category: :subroutine :arguments: - job: :type: char :intent: input - compq: :type: char :intent: input - compz: :type: char :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - h: :type: doublecomplex :intent: input/output :dims: - ldh - n - ldh: :type: integer :intent: input - t: :type: doublecomplex :intent: input/output :dims: - ldt - n - ldt: :type: integer :intent: input - alpha: :type: doublecomplex :intent: output :dims: - n - beta: :type: doublecomplex :intent: output :dims: - n - q: :type: doublecomplex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - z: :type: doublecomplex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHGEQZ computes the eigenvalues of a complex matrix pair (H,T),\n\ * where H is an upper Hessenberg matrix and T is upper triangular,\n\ * using the single-shift QZ method.\n\ * Matrix pairs of this type are produced by the reduction to\n\ * generalized upper Hessenberg form of a complex matrix pair (A,B):\n\ * \n\ * A = Q1*H*Z1**H, B = Q1*T*Z1**H,\n\ * \n\ * as computed by ZGGHRD.\n\ * \n\ * If JOB='S', then the Hessenberg-triangular pair (H,T) is\n\ * also reduced to generalized Schur form,\n\ * \n\ * H = Q*S*Z**H, T = Q*P*Z**H,\n\ * \n\ * where Q and Z are unitary matrices and S and P are upper triangular.\n\ * \n\ * Optionally, the unitary matrix Q from the generalized Schur\n\ * factorization may be postmultiplied into an input matrix Q1, and the\n\ * unitary matrix Z may be postmultiplied into an input matrix Z1.\n\ * If Q1 and Z1 are the unitary matrices from ZGGHRD that reduced\n\ * the matrix pair (A,B) to generalized Hessenberg form, then the output\n\ * matrices Q1*Q and Z1*Z are the unitary factors from the generalized\n\ * Schur factorization of (A,B):\n\ * \n\ * A = (Q1*Q)*S*(Z1*Z)**H, B = (Q1*Q)*P*(Z1*Z)**H.\n\ * \n\ * To avoid overflow, eigenvalues of the matrix pair (H,T)\n\ * (equivalently, of (A,B)) are computed as a pair of complex values\n\ * (alpha,beta). If beta is nonzero, lambda = alpha / beta is an\n\ * eigenvalue of the generalized nonsymmetric eigenvalue problem (GNEP)\n\ * A*x = lambda*B*x\n\ * and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the\n\ * alternate form of the GNEP\n\ * mu*A*y = B*y.\n\ * The values of alpha and beta for the i-th eigenvalue can be read\n\ * directly from the generalized Schur form: alpha = S(i,i),\n\ * beta = P(i,i).\n\ *\n\ * Ref: C.B. Moler & G.W. Stewart, \"An Algorithm for Generalized Matrix\n\ * Eigenvalue Problems\", SIAM J. Numer. Anal., 10(1973),\n\ * pp. 241--256.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * = 'E': Compute eigenvalues only;\n\ * = 'S': Computer eigenvalues and the Schur form.\n\ *\n\ * COMPQ (input) CHARACTER*1\n\ * = 'N': Left Schur vectors (Q) are not computed;\n\ * = 'I': Q is initialized to the unit matrix and the matrix Q\n\ * of left Schur vectors of (H,T) is returned;\n\ * = 'V': Q must contain a unitary matrix Q1 on entry and\n\ * the product Q1*Q is returned.\n\ *\n\ * COMPZ (input) CHARACTER*1\n\ * = 'N': Right Schur vectors (Z) are not computed;\n\ * = 'I': Q is initialized to the unit matrix and the matrix Z\n\ * of right Schur vectors of (H,T) is returned;\n\ * = 'V': Z must contain a unitary matrix Z1 on entry and\n\ * the product Z1*Z is returned.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices H, T, Q, and Z. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * ILO and IHI mark the rows and columns of H which are in\n\ * Hessenberg form. It is assumed that A is already upper\n\ * triangular in rows and columns 1:ILO-1 and IHI+1:N.\n\ * If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.\n\ *\n\ * H (input/output) COMPLEX*16 array, dimension (LDH, N)\n\ * On entry, the N-by-N upper Hessenberg matrix H.\n\ * On exit, if JOB = 'S', H contains the upper triangular\n\ * matrix S from the generalized Schur factorization.\n\ * If JOB = 'E', the diagonal of H matches that of S, but\n\ * the rest of H is unspecified.\n\ *\n\ * LDH (input) INTEGER\n\ * The leading dimension of the array H. LDH >= max( 1, N ).\n\ *\n\ * T (input/output) COMPLEX*16 array, dimension (LDT, N)\n\ * On entry, the N-by-N upper triangular matrix T.\n\ * On exit, if JOB = 'S', T contains the upper triangular\n\ * matrix P from the generalized Schur factorization.\n\ * If JOB = 'E', the diagonal of T matches that of P, but\n\ * the rest of T is unspecified.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= max( 1, N ).\n\ *\n\ * ALPHA (output) COMPLEX*16 array, dimension (N)\n\ * The complex scalars alpha that define the eigenvalues of\n\ * GNEP. ALPHA(i) = S(i,i) in the generalized Schur\n\ * factorization.\n\ *\n\ * BETA (output) COMPLEX*16 array, dimension (N)\n\ * The real non-negative scalars beta that define the\n\ * eigenvalues of GNEP. BETA(i) = P(i,i) in the generalized\n\ * Schur factorization.\n\ *\n\ * Together, the quantities alpha = ALPHA(j) and beta = BETA(j)\n\ * represent the j-th eigenvalue of the matrix pair (A,B), in\n\ * one of the forms lambda = alpha/beta or mu = beta/alpha.\n\ * Since either lambda or mu may overflow, they should not,\n\ * in general, be computed.\n\ *\n\ * Q (input/output) COMPLEX*16 array, dimension (LDQ, N)\n\ * On entry, if COMPZ = 'V', the unitary matrix Q1 used in the\n\ * reduction of (A,B) to generalized Hessenberg form.\n\ * On exit, if COMPZ = 'I', the unitary matrix of left Schur\n\ * vectors of (H,T), and if COMPZ = 'V', the unitary matrix of\n\ * left Schur vectors of (A,B).\n\ * Not referenced if COMPZ = 'N'.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= 1.\n\ * If COMPQ='V' or 'I', then LDQ >= N.\n\ *\n\ * Z (input/output) COMPLEX*16 array, dimension (LDZ, N)\n\ * On entry, if COMPZ = 'V', the unitary matrix Z1 used in the\n\ * reduction of (A,B) to generalized Hessenberg form.\n\ * On exit, if COMPZ = 'I', the unitary matrix of right Schur\n\ * vectors of (H,T), and if COMPZ = 'V', the unitary matrix of\n\ * right Schur vectors of (A,B).\n\ * Not referenced if COMPZ = 'N'.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1.\n\ * If COMPZ='V' or 'I', then LDZ >= N.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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,N).\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\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * = 1,...,N: the QZ iteration did not converge. (H,T) is not\n\ * in Schur form, but ALPHA(i) and BETA(i),\n\ * i=INFO+1,...,N should be correct.\n\ * = N+1,...,2*N: the shift calculation failed. (H,T) is not\n\ * in Schur form, but ALPHA(i) and BETA(i),\n\ * i=INFO-N+1,...,N should be correct.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * We assume that complex ABS works as long as its value is less than\n\ * overflow.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlartg0000644000175000017500000000351512502223526016517 0ustar uwabamiuwabami--- :name: zlartg :md5sum: 669790d67331c2cd17991b7c96ecc53d :category: :subroutine :arguments: - f: :type: doublecomplex :intent: input - g: :type: doublecomplex :intent: input - cs: :type: doublereal :intent: output - sn: :type: doublecomplex :intent: output - r: :type: doublecomplex :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZLARTG( F, G, CS, SN, R )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLARTG generates a plane rotation so that\n\ *\n\ * [ CS SN ] [ F ] [ R ]\n\ * [ __ ] . [ ] = [ ] where CS**2 + |SN|**2 = 1.\n\ * [ -SN CS ] [ G ] [ 0 ]\n\ *\n\ * This is a faster version of the BLAS1 routine ZROTG, except for\n\ * the following differences:\n\ * F and G are unchanged on return.\n\ * If G=0, then CS=1 and SN=0.\n\ * If F=0, then CS=0 and SN is chosen so that R is real.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * F (input) COMPLEX*16\n\ * The first component of vector to be rotated.\n\ *\n\ * G (input) COMPLEX*16\n\ * The second component of vector to be rotated.\n\ *\n\ * CS (output) DOUBLE PRECISION\n\ * The cosine of the rotation.\n\ *\n\ * SN (output) COMPLEX*16\n\ * The sine of the rotation.\n\ *\n\ * R (output) COMPLEX*16\n\ * The nonzero component of the rotated vector.\n\ *\n\n\ * Further Details\n\ * ======= =======\n\ *\n\ * 3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel\n\ *\n\ * This version has a few statements commented out for thread safety\n\ * (machine parameters are computed on each entry). 10 feb 03, SJH.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zggevx0000644000175000017500000003206612502223526016531 0ustar uwabamiuwabami--- :name: zggevx :md5sum: 4e621547183340b05cd234a1dea49486 :category: :subroutine :arguments: - balanc: :type: char :intent: input - jobvl: :type: char :intent: input - jobvr: :type: char :intent: input - sense: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alpha: :type: doublecomplex :intent: output :dims: - n - beta: :type: doublecomplex :intent: output :dims: - n - vl: :type: doublecomplex :intent: output :dims: - ldvl - n - ldvl: :type: integer :intent: input - vr: :type: doublecomplex :intent: output :dims: - ldvr - n - ldvr: :type: integer :intent: input - ilo: :type: integer :intent: output - ihi: :type: integer :intent: output - lscale: :type: doublereal :intent: output :dims: - n - rscale: :type: doublereal :intent: output :dims: - n - abnrm: :type: doublereal :intent: output - bbnrm: :type: doublereal :intent: output - rconde: :type: doublereal :intent: output :dims: - n - rcondv: :type: doublereal :intent: output :dims: - n - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&sense,\"E\") ? 4*n : (lsame_(&sense,\"V\")||lsame_(&sense,\"B\")) ? 2*n*n+2*n : 2*n" - rwork: :type: doublereal :intent: workspace :dims: - lrwork - iwork: :type: integer :intent: workspace :dims: - "lsame_(&sense,\"E\") ? 0 : n+2" - bwork: :type: logical :intent: workspace :dims: - "lsame_(&sense,\"N\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldvr: "lsame_(&jobvr,\"V\") ? n : 1" lrwork: "((lsame_(&balanc,\"S\")) || (lsame_(&balanc,\"B\"))) ? MAX(1,6*n) : MAX(1,2*n)" ldvl: "lsame_(&jobvl,\"V\") ? n : 1" :fortran_help: " SUBROUTINE ZGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, ILO, IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, WORK, LWORK, RWORK, IWORK, BWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGGEVX computes for a pair of N-by-N complex nonsymmetric matrices\n\ * (A,B) the generalized eigenvalues, and optionally, the left and/or\n\ * right generalized eigenvectors.\n\ *\n\ * Optionally, it also computes a balancing transformation to improve\n\ * the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n\ * LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for\n\ * the eigenvalues (RCONDE), and reciprocal condition numbers for the\n\ * right eigenvectors (RCONDV).\n\ *\n\ * A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n\ * lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n\ * singular. It is usually represented as the pair (alpha,beta), as\n\ * there is a reasonable interpretation for beta=0, and even for both\n\ * being zero.\n\ *\n\ * The right eigenvector v(j) corresponding to the eigenvalue lambda(j)\n\ * of (A,B) satisfies\n\ * A * v(j) = lambda(j) * B * v(j) .\n\ * The left eigenvector u(j) corresponding to the eigenvalue lambda(j)\n\ * of (A,B) satisfies\n\ * u(j)**H * A = lambda(j) * u(j)**H * B.\n\ * where u(j)**H is the conjugate-transpose of u(j).\n\ *\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * BALANC (input) CHARACTER*1\n\ * Specifies the balance option to be performed:\n\ * = 'N': do not diagonally scale or permute;\n\ * = 'P': permute only;\n\ * = 'S': scale only;\n\ * = 'B': both permute and scale.\n\ * Computed reciprocal condition numbers will be for the\n\ * matrices after permuting and/or balancing. Permuting does\n\ * not change condition numbers (in exact arithmetic), but\n\ * balancing does.\n\ *\n\ * JOBVL (input) CHARACTER*1\n\ * = 'N': do not compute the left generalized eigenvectors;\n\ * = 'V': compute the left generalized eigenvectors.\n\ *\n\ * JOBVR (input) CHARACTER*1\n\ * = 'N': do not compute the right generalized eigenvectors;\n\ * = 'V': compute the right generalized eigenvectors.\n\ *\n\ * SENSE (input) CHARACTER*1\n\ * Determines which reciprocal condition numbers are computed.\n\ * = 'N': none are computed;\n\ * = 'E': computed for eigenvalues only;\n\ * = 'V': computed for eigenvectors only;\n\ * = 'B': computed for eigenvalues and eigenvectors.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A, B, VL, and VR. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA, N)\n\ * On entry, the matrix A in the pair (A,B).\n\ * On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'\n\ * or both, then A contains the first part of the complex Schur\n\ * form of the \"balanced\" versions of the input A and B.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB, N)\n\ * On entry, the matrix B in the pair (A,B).\n\ * On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'\n\ * or both, then B contains the second part of the complex\n\ * Schur form of the \"balanced\" versions of the input A and B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B. LDB >= max(1,N).\n\ *\n\ * ALPHA (output) COMPLEX*16 array, dimension (N)\n\ * BETA (output) COMPLEX*16 array, dimension (N)\n\ * On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the generalized\n\ * eigenvalues.\n\ *\n\ * Note: the quotient ALPHA(j)/BETA(j) ) may easily over- or\n\ * underflow, and BETA(j) may even be zero. Thus, the user\n\ * should avoid naively computing the ratio ALPHA/BETA.\n\ * However, ALPHA will be always less than and usually\n\ * comparable with norm(A) in magnitude, and BETA always less\n\ * than and usually comparable with norm(B).\n\ *\n\ * VL (output) COMPLEX*16 array, dimension (LDVL,N)\n\ * If JOBVL = 'V', the left generalized eigenvectors u(j) are\n\ * stored one after another in the columns of VL, in the same\n\ * order as their eigenvalues.\n\ * Each eigenvector will be scaled so the largest component\n\ * will have abs(real part) + abs(imag. part) = 1.\n\ * Not referenced if JOBVL = 'N'.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the matrix VL. LDVL >= 1, and\n\ * if JOBVL = 'V', LDVL >= N.\n\ *\n\ * VR (output) COMPLEX*16 array, dimension (LDVR,N)\n\ * If JOBVR = 'V', the right generalized eigenvectors v(j) are\n\ * stored one after another in the columns of VR, in the same\n\ * order as their eigenvalues.\n\ * Each eigenvector will be scaled so the largest component\n\ * will have abs(real part) + abs(imag. part) = 1.\n\ * Not referenced if JOBVR = 'N'.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the matrix VR. LDVR >= 1, and\n\ * if JOBVR = 'V', LDVR >= N.\n\ *\n\ * ILO (output) INTEGER\n\ * IHI (output) INTEGER\n\ * ILO and IHI are integer values such that on exit\n\ * A(i,j) = 0 and B(i,j) = 0 if i > j and\n\ * j = 1,...,ILO-1 or i = IHI+1,...,N.\n\ * If BALANC = 'N' or 'S', ILO = 1 and IHI = N.\n\ *\n\ * LSCALE (output) DOUBLE PRECISION array, dimension (N)\n\ * Details of the permutations and scaling factors applied\n\ * to the left side of A and B. If PL(j) is the index of the\n\ * row interchanged with row j, and DL(j) is the scaling\n\ * factor applied to row j, then\n\ * LSCALE(j) = PL(j) for j = 1,...,ILO-1\n\ * = DL(j) for j = ILO,...,IHI\n\ * = PL(j) for j = IHI+1,...,N.\n\ * The order in which the interchanges are made is N to IHI+1,\n\ * then 1 to ILO-1.\n\ *\n\ * RSCALE (output) DOUBLE PRECISION array, dimension (N)\n\ * Details of the permutations and scaling factors applied\n\ * to the right side of A and B. If PR(j) is the index of the\n\ * column interchanged with column j, and DR(j) is the scaling\n\ * factor applied to column j, then\n\ * RSCALE(j) = PR(j) for j = 1,...,ILO-1\n\ * = DR(j) for j = ILO,...,IHI\n\ * = PR(j) for j = IHI+1,...,N\n\ * The order in which the interchanges are made is N to IHI+1,\n\ * then 1 to ILO-1.\n\ *\n\ * ABNRM (output) DOUBLE PRECISION\n\ * The one-norm of the balanced matrix A.\n\ *\n\ * BBNRM (output) DOUBLE PRECISION\n\ * The one-norm of the balanced matrix B.\n\ *\n\ * RCONDE (output) DOUBLE PRECISION array, dimension (N)\n\ * If SENSE = 'E' or 'B', the reciprocal condition numbers of\n\ * the eigenvalues, stored in consecutive elements of the array.\n\ * If SENSE = 'N' or 'V', RCONDE is not referenced.\n\ *\n\ * RCONDV (output) DOUBLE PRECISION array, dimension (N)\n\ * If JOB = 'V' or 'B', the estimated reciprocal condition\n\ * numbers of the eigenvectors, stored in consecutive elements\n\ * of the array. If the eigenvalues cannot be reordered to\n\ * compute RCONDV(j), RCONDV(j) is set to 0; this can only occur\n\ * when the true value would be very small anyway.\n\ * If SENSE = 'N' or 'E', RCONDV is not referenced.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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,2*N).\n\ * If SENSE = 'E', LWORK >= max(1,4*N).\n\ * If SENSE = 'V' or 'B', LWORK >= max(1,2*N*N+2*N).\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\ * RWORK (workspace) REAL array, dimension (lrwork)\n\ * lrwork must be at least max(1,6*N) if BALANC = 'S' or 'B',\n\ * and at least max(1,2*N) otherwise.\n\ * Real workspace.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N+2)\n\ * If SENSE = 'E', IWORK is not referenced.\n\ *\n\ * BWORK (workspace) LOGICAL array, dimension (N)\n\ * If SENSE = 'N', BWORK is not referenced.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * = 1,...,N:\n\ * The QZ iteration failed. No eigenvectors have been\n\ * calculated, but ALPHA(j) and BETA(j) should be correct\n\ * for j=INFO+1,...,N.\n\ * > N: =N+1: other than QZ iteration failed in ZHGEQZ.\n\ * =N+2: error return from ZTGEVC.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Balancing a matrix pair (A,B) includes, first, permuting rows and\n\ * columns to isolate eigenvalues, second, applying diagonal similarity\n\ * transformation to the rows and columns to make the rows and columns\n\ * as close in norm as possible. The computed reciprocal condition\n\ * numbers correspond to the balanced matrix. Permuting rows and columns\n\ * will not change the condition numbers (in exact arithmetic) but\n\ * diagonal scaling will. For further explanation of balancing, see\n\ * section 4.11.1.2 of LAPACK Users' Guide.\n\ *\n\ * An approximate error bound on the chordal distance between the i-th\n\ * computed generalized eigenvalue w and the corresponding exact\n\ * eigenvalue lambda is\n\ *\n\ * chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)\n\ *\n\ * An approximate error bound for the angle between the i-th computed\n\ * eigenvector VL(i) or VR(i) is given by\n\ *\n\ * EPS * norm(ABNRM, BBNRM) / DIF(i).\n\ *\n\ * For further explanation of the reciprocal condition numbers RCONDE\n\ * and RCONDV, see section 4.11 of LAPACK User's Guide.\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssygvx0000644000175000017500000002306312502223526016557 0ustar uwabamiuwabami--- :name: ssygvx :md5sum: 997610aae4bc990e7bf530106e272869 :category: :subroutine :arguments: - itype: :type: integer :intent: input - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - lda - n - ldb: :type: integer :intent: input - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - "lsame_(&jobz,\"N\") ? 0 : ldz" - "lsame_(&jobz,\"N\") ? 0 : MAX(1,m)" - ldz: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 8*n - iwork: :type: integer :intent: workspace :dims: - 5*n - ifail: :type: integer :intent: output :dims: - n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " SUBROUTINE SSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSYGVX computes selected eigenvalues, and optionally, eigenvectors\n\ * of a real generalized symmetric-definite eigenproblem, of the form\n\ * A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A\n\ * and B are assumed to be symmetric and B is also positive definite.\n\ * Eigenvalues and eigenvectors can be selected by specifying either a\n\ * range of values or a range of indices for the desired eigenvalues.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ITYPE (input) INTEGER\n\ * Specifies the problem type to be solved:\n\ * = 1: A*x = (lambda)*B*x\n\ * = 2: A*B*x = (lambda)*x\n\ * = 3: B*A*x = (lambda)*x\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found.\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found.\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A and B are stored;\n\ * = 'L': Lower triangle of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix pencil (A,B). N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA, N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of A contains the\n\ * upper triangular part of the matrix A. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of A contains\n\ * the lower triangular part of the matrix A.\n\ *\n\ * On exit, the lower triangle (if UPLO='L') or the upper\n\ * triangle (if UPLO='U') of A, including the diagonal, is\n\ * destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) REAL array, dimension (LDA, N)\n\ * On entry, the symmetric matrix B. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of B contains the\n\ * upper triangular part of the matrix B. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of B contains\n\ * the lower triangular part of the matrix B.\n\ *\n\ * On exit, if INFO <= N, the part of B containing the matrix is\n\ * overwritten by the triangular factor U or L from the Cholesky\n\ * factorization B = U**T*U or B = L*L**T.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * VL (input) REAL\n\ * VU (input) REAL\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) REAL\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less than\n\ * or equal to zero, then EPS*|T| will be used in its place,\n\ * where |T| is the 1-norm of the tridiagonal matrix obtained\n\ * by reducing A to tridiagonal form.\n\ *\n\ * Eigenvalues will be computed most accurately when ABSTOL is\n\ * set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n\ * If this routine returns with INFO>0, indicating that some\n\ * eigenvectors did not converge, try setting ABSTOL to\n\ * 2*SLAMCH('S').\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * On normal exit, the first M elements contain the selected\n\ * eigenvalues in ascending order.\n\ *\n\ * Z (output) REAL array, dimension (LDZ, max(1,M))\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix A\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * The eigenvectors are normalized as follows:\n\ * if ITYPE = 1 or 2, Z**T*B*Z = I;\n\ * if ITYPE = 3, Z**T*inv(B)*Z = I.\n\ *\n\ * If an eigenvector fails to converge, then that column of Z\n\ * contains the latest approximation to the eigenvector, and the\n\ * index of the eigenvector is returned in IFAIL.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of the array WORK. LWORK >= max(1,8*N).\n\ * For optimal efficiency, LWORK >= (NB+3)*N,\n\ * where NB is the blocksize for SSYTRD returned by ILAENV.\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\ * IWORK (workspace) INTEGER array, dimension (5*N)\n\ *\n\ * IFAIL (output) INTEGER array, dimension (N)\n\ * If JOBZ = 'V', then if INFO = 0, the first M elements of\n\ * IFAIL are zero. If INFO > 0, then IFAIL contains the\n\ * indices of the eigenvectors that failed to converge.\n\ * If JOBZ = 'N', then IFAIL is not referenced.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: SPOTRF or SSYEVX returned an error code:\n\ * <= N: if INFO = i, SSYEVX failed to converge;\n\ * i eigenvectors failed to converge. Their indices\n\ * are stored in array IFAIL.\n\ * > N: if INFO = N + i, for 1 <= i <= N, then the leading\n\ * minor of order i of B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cposv0000644000175000017500000000705012502223525016343 0ustar uwabamiuwabami--- :name: cposv :md5sum: 1485e74677b64f3f220c975c8c0afcb6 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPOSV computes the solution to a complex system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N Hermitian positive definite matrix and X and B\n\ * are N-by-NRHS matrices.\n\ *\n\ * The Cholesky decomposition is used to factor A as\n\ * A = U**H* U, if UPLO = 'U', or\n\ * A = L * L**H, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is a lower triangular\n\ * matrix. The factored form of A is then used to solve the system of\n\ * equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension (LDA,N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the factor U or L from the Cholesky\n\ * factorization A = U**H*U or A = L*L**H.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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 leading minor of order i of A is not\n\ * positive definite, so the factorization could not be\n\ * completed, and the solution has not been computed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL CPOTRF, CPOTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zlagtm0000644000175000017500000000620212502223526016506 0ustar uwabamiuwabami--- :name: zlagtm :md5sum: 7cbf078fe6ef87658cc59e02f706c853 :category: :subroutine :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - alpha: :type: doublereal :intent: input - dl: :type: doublecomplex :intent: input :dims: - n-1 - d: :type: doublecomplex :intent: input :dims: - n - du: :type: doublecomplex :intent: input :dims: - n-1 - x: :type: doublecomplex :intent: input :dims: - ldx - nrhs - ldx: :type: integer :intent: input - beta: :type: doublereal :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE ZLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, B, LDB )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAGTM performs a matrix-vector product of the form\n\ *\n\ * B := alpha * A * X + beta * B\n\ *\n\ * where A is a tridiagonal matrix of order N, B and X are N by NRHS\n\ * matrices, and alpha and beta are real scalars, each of which may be\n\ * 0., 1., or -1.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the operation applied to A.\n\ * = 'N': No transpose, B := alpha * A * X + beta * B\n\ * = 'T': Transpose, B := alpha * A**T * X + beta * B\n\ * = 'C': Conjugate transpose, B := alpha * A**H * X + beta * B\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices X and B.\n\ *\n\ * ALPHA (input) DOUBLE PRECISION\n\ * The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise,\n\ * it is assumed to be 0.\n\ *\n\ * DL (input) COMPLEX*16 array, dimension (N-1)\n\ * The (n-1) sub-diagonal elements of T.\n\ *\n\ * D (input) COMPLEX*16 array, dimension (N)\n\ * The diagonal elements of T.\n\ *\n\ * DU (input) COMPLEX*16 array, dimension (N-1)\n\ * The (n-1) super-diagonal elements of T.\n\ *\n\ * X (input) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * The N by NRHS matrix X.\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(N,1).\n\ *\n\ * BETA (input) DOUBLE PRECISION\n\ * The scalar beta. BETA must be 0., 1., or -1.; otherwise,\n\ * it is assumed to be 1.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the N by NRHS matrix B.\n\ * On exit, B is overwritten by the matrix expression\n\ * B := alpha * A * X + beta * B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(N,1).\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/stgex20000644000175000017500000001412612502223526016430 0ustar uwabamiuwabami--- :name: stgex2 :md5sum: 0ff12ef41f70e923d7440270d8c9e9f1 :category: :subroutine :arguments: - wantq: :type: logical :intent: input - wantz: :type: logical :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - q: :type: real :intent: input/output :dims: - ldz - n - ldq: :type: integer :intent: input - z: :type: real :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - j1: :type: integer :intent: input - n1: :type: integer :intent: input - n2: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - lwork - lwork: :type: integer :intent: input :option: true :default: MAX(n*(n2+n1), (n2+n1)*(n2+n1)*2) - info: :type: integer :intent: output :substitutions: lwork: MAX(1,(MAX(n*(n2+n1),(n2+n1)*(n2+n1)*2))) :fortran_help: " SUBROUTINE STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, J1, N1, N2, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22)\n\ * of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair\n\ * (A, B) by an orthogonal equivalence transformation.\n\ *\n\ * (A, B) must be in generalized real Schur canonical form (as returned\n\ * by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2\n\ * diagonal blocks. B is upper triangular.\n\ *\n\ * Optionally, the matrices Q and Z of generalized Schur vectors are\n\ * updated.\n\ *\n\ * Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n\ * Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n\ *\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * WANTQ (input) LOGICAL\n\ * .TRUE. : update the left transformation matrix Q;\n\ * .FALSE.: do not update Q.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * .TRUE. : update the right transformation matrix Z;\n\ * .FALSE.: do not update Z.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) REAL arrays, dimensions (LDA,N)\n\ * On entry, the matrix A in the pair (A, B).\n\ * On exit, the updated matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) REAL arrays, dimensions (LDB,N)\n\ * On entry, the matrix B in the pair (A, B).\n\ * On exit, the updated matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * Q (input/output) REAL array, dimension (LDZ,N)\n\ * On entry, if WANTQ = .TRUE., the orthogonal matrix Q.\n\ * On exit, the updated matrix Q.\n\ * Not referenced if WANTQ = .FALSE..\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= 1.\n\ * If WANTQ = .TRUE., LDQ >= N.\n\ *\n\ * Z (input/output) REAL array, dimension (LDZ,N)\n\ * On entry, if WANTZ =.TRUE., the orthogonal matrix Z.\n\ * On exit, the updated matrix Z.\n\ * Not referenced if WANTZ = .FALSE..\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1.\n\ * If WANTZ = .TRUE., LDZ >= N.\n\ *\n\ * J1 (input) INTEGER\n\ * The index to the first block (A11, B11). 1 <= J1 <= N.\n\ *\n\ * N1 (input) INTEGER\n\ * The order of the first block (A11, B11). N1 = 0, 1 or 2.\n\ *\n\ * N2 (input) INTEGER\n\ * The order of the second block (A22, B22). N2 = 0, 1 or 2.\n\ *\n\ * WORK (workspace) REAL array, dimension (MAX(1,LWORK)).\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK.\n\ * LWORK >= MAX( N*(N2+N1), (N2+N1)*(N2+N1)*2 )\n\ *\n\ * INFO (output) INTEGER\n\ * =0: Successful exit\n\ * >0: If INFO = 1, the transformed matrix (A, B) would be\n\ * too far from generalized Schur form; the blocks are\n\ * not swapped and (A, B) and (Q, Z) are unchanged.\n\ * The problem of swapping is too ill-conditioned.\n\ * <0: If INFO = -16: LWORK is too small. Appropriate value\n\ * for LWORK is returned in WORK(1).\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * In the current code both weak and strong stability tests are\n\ * performed. The user can omit the strong stability test by changing\n\ * the internal logical parameter WANDS to .FALSE.. See ref. [2] for\n\ * details.\n\ *\n\ * [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n\ * Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n\ * M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n\ * Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n\ *\n\ * [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n\ * Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n\ * Estimation: Theory, Algorithms and Software,\n\ * Report UMINF - 94.04, Department of Computing Science, Umea\n\ * University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working\n\ * Note 87. To appear in Numerical Algorithms, 1996.\n\ *\n\ * =====================================================================\n\ * Replaced various illegal calls to SCOPY by calls to SLASET, or by DO\n\ * loops. Sven Hammarling, 1/5/02.\n\ *\n" ruby-lapack-1.7.2/dev/defs/ztptrs0000644000175000017500000000572612502223526016570 0ustar uwabamiuwabami--- :name: ztptrs :md5sum: a47aaeb2af101fd548f7d59fe6733d53 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTPTRS solves a triangular system of the form\n\ *\n\ * A * X = B, A**T * X = B, or A**H * X = B,\n\ *\n\ * where A is a triangular matrix of order N stored in packed format,\n\ * and B is an N-by-NRHS matrix. A check is made to verify that A is\n\ * nonsingular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * The upper or lower triangular matrix A, packed columnwise in\n\ * a linear array. The j-th column of A is stored in the array\n\ * AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, if INFO = 0, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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 A is zero,\n\ * indicating that the matrix is singular and the\n\ * solutions X have not been computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sormtr0000644000175000017500000001161112502223526016536 0ustar uwabamiuwabami--- :name: sormtr :md5sum: 5c0d297be3b21e4f035a0da2f474fb36 :category: :subroutine :arguments: - side: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - m-1 - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SORMTR overwrites the general real M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'T': Q**T * C C * Q**T\n\ *\n\ * where Q is a real orthogonal matrix of order nq, with nq = m if\n\ * SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of\n\ * nq-1 elementary reflectors, as returned by SSYTRD:\n\ *\n\ * if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);\n\ *\n\ * if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**T from the Left;\n\ * = 'R': apply Q or Q**T from the Right.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A contains elementary reflectors\n\ * from SSYTRD;\n\ * = 'L': Lower triangle of A contains elementary reflectors\n\ * from SSYTRD.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q;\n\ * = 'T': Transpose, apply Q**T.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * A (input) REAL array, dimension\n\ * (LDA,M) if SIDE = 'L'\n\ * (LDA,N) if SIDE = 'R'\n\ * The vectors which define the elementary reflectors, as\n\ * returned by SSYTRD.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ * LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n\ *\n\ * TAU (input) REAL array, dimension\n\ * (M-1) if SIDE = 'L'\n\ * (N-1) if SIDE = 'R'\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by SSYTRD.\n\ *\n\ * C (input/output) REAL array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace/output) REAL 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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M).\n\ * For optimum performance LWORK >= N*NB if SIDE = 'L', and\n\ * LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n\ * 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\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LEFT, LQUERY, UPPER\n INTEGER I1, I2, IINFO, LWKOPT, MI, NI, NB, NQ, NW\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL ILAENV, LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SORMQL, SORMQR, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/ztrsyl0000644000175000017500000000711712502223526016565 0ustar uwabamiuwabami--- :name: ztrsyl :md5sum: b74a0884c540a69b1720f8f96006957c :category: :subroutine :arguments: - trana: :type: char :intent: input - tranb: :type: char :intent: input - isgn: :type: integer :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - m - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input :dims: - ldb - n - ldb: :type: integer :intent: input - c: :type: doublecomplex :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - scale: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, SCALE, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTRSYL solves the complex Sylvester matrix equation:\n\ *\n\ * op(A)*X + X*op(B) = scale*C or\n\ * op(A)*X - X*op(B) = scale*C,\n\ *\n\ * where op(A) = A or A**H, and A and B are both upper triangular. A is\n\ * M-by-M and B is N-by-N; the right hand side C and the solution X are\n\ * M-by-N; and scale is an output scale factor, set <= 1 to avoid\n\ * overflow in X.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANA (input) CHARACTER*1\n\ * Specifies the option op(A):\n\ * = 'N': op(A) = A (No transpose)\n\ * = 'C': op(A) = A**H (Conjugate transpose)\n\ *\n\ * TRANB (input) CHARACTER*1\n\ * Specifies the option op(B):\n\ * = 'N': op(B) = B (No transpose)\n\ * = 'C': op(B) = B**H (Conjugate transpose)\n\ *\n\ * ISGN (input) INTEGER\n\ * Specifies the sign in the equation:\n\ * = +1: solve op(A)*X + X*op(B) = scale*C\n\ * = -1: solve op(A)*X - X*op(B) = scale*C\n\ *\n\ * M (input) INTEGER\n\ * The order of the matrix A, and the number of rows in the\n\ * matrices X and C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix B, and the number of columns in the\n\ * matrices X and C. N >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,M)\n\ * The upper triangular matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,N)\n\ * The upper triangular matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * C (input/output) COMPLEX*16 array, dimension (LDC,N)\n\ * On entry, the M-by-N right hand side matrix C.\n\ * On exit, C is overwritten by the solution matrix X.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M)\n\ *\n\ * SCALE (output) DOUBLE PRECISION\n\ * The scale factor, scale, set <= 1 to avoid overflow in X.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * = 1: A and B have common or very close eigenvalues; perturbed\n\ * values were used to solve the equation (but the matrices\n\ * A and B are unchanged).\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/stgsja0000644000175000017500000002563212502223526016513 0ustar uwabamiuwabami--- :name: stgsja :md5sum: 604149ded91900c1bd601ad488246cc2 :category: :subroutine :arguments: - jobu: :type: char :intent: input - jobv: :type: char :intent: input - jobq: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - l: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: real :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - tola: :type: real :intent: input - tolb: :type: real :intent: input - alpha: :type: real :intent: output :dims: - n - beta: :type: real :intent: output :dims: - n - u: :type: real :intent: input/output :dims: - ldu - m - ldu: :type: integer :intent: input - v: :type: real :intent: input/output :dims: - ldv - p - ldv: :type: integer :intent: input - q: :type: real :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 2*n - ncycle: :type: integer :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE STGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, NCYCLE, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * STGSJA computes the generalized singular value decomposition (GSVD)\n\ * of two real upper triangular (or trapezoidal) matrices A and B.\n\ *\n\ * On entry, it is assumed that matrices A and B have the following\n\ * forms, which may be obtained by the preprocessing subroutine SGGSVP\n\ * from a general M-by-N matrix A and P-by-N matrix B:\n\ *\n\ * N-K-L K L\n\ * A = K ( 0 A12 A13 ) if M-K-L >= 0;\n\ * L ( 0 0 A23 )\n\ * M-K-L ( 0 0 0 )\n\ *\n\ * N-K-L K L\n\ * A = K ( 0 A12 A13 ) if M-K-L < 0;\n\ * M-K ( 0 0 A23 )\n\ *\n\ * N-K-L K L\n\ * B = L ( 0 0 B13 )\n\ * P-L ( 0 0 0 )\n\ *\n\ * where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n\ * upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n\ * otherwise A23 is (M-K)-by-L upper trapezoidal.\n\ *\n\ * On exit,\n\ *\n\ * U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ),\n\ *\n\ * where U, V and Q are orthogonal matrices, Z' denotes the transpose\n\ * of Z, R is a nonsingular upper triangular matrix, and D1 and D2 are\n\ * ``diagonal'' matrices, which are of the following structures:\n\ *\n\ * If M-K-L >= 0,\n\ *\n\ * K L\n\ * D1 = K ( I 0 )\n\ * L ( 0 C )\n\ * M-K-L ( 0 0 )\n\ *\n\ * K L\n\ * D2 = L ( 0 S )\n\ * P-L ( 0 0 )\n\ *\n\ * N-K-L K L\n\ * ( 0 R ) = K ( 0 R11 R12 ) K\n\ * L ( 0 0 R22 ) L\n\ *\n\ * where\n\ *\n\ * C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n\ * S = diag( BETA(K+1), ... , BETA(K+L) ),\n\ * C**2 + S**2 = I.\n\ *\n\ * R is stored in A(1:K+L,N-K-L+1:N) on exit.\n\ *\n\ * If M-K-L < 0,\n\ *\n\ * K M-K K+L-M\n\ * D1 = K ( I 0 0 )\n\ * M-K ( 0 C 0 )\n\ *\n\ * K M-K K+L-M\n\ * D2 = M-K ( 0 S 0 )\n\ * K+L-M ( 0 0 I )\n\ * P-L ( 0 0 0 )\n\ *\n\ * N-K-L K M-K K+L-M\n\ * ( 0 R ) = K ( 0 R11 R12 R13 )\n\ * M-K ( 0 0 R22 R23 )\n\ * K+L-M ( 0 0 0 R33 )\n\ *\n\ * where\n\ * C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n\ * S = diag( BETA(K+1), ... , BETA(M) ),\n\ * C**2 + S**2 = I.\n\ *\n\ * R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored\n\ * ( 0 R22 R23 )\n\ * in B(M-K+1:L,N+M-K-L+1:N) on exit.\n\ *\n\ * The computation of the orthogonal transformation matrices U, V or Q\n\ * is optional. These matrices may either be formed explicitly, or they\n\ * may be postmultiplied into input matrices U1, V1, or Q1.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBU (input) CHARACTER*1\n\ * = 'U': U must contain an orthogonal matrix U1 on entry, and\n\ * the product U1*U is returned;\n\ * = 'I': U is initialized to the unit matrix, and the\n\ * orthogonal matrix U is returned;\n\ * = 'N': U is not computed.\n\ *\n\ * JOBV (input) CHARACTER*1\n\ * = 'V': V must contain an orthogonal matrix V1 on entry, and\n\ * the product V1*V is returned;\n\ * = 'I': V is initialized to the unit matrix, and the\n\ * orthogonal matrix V is returned;\n\ * = 'N': V is not computed.\n\ *\n\ * JOBQ (input) CHARACTER*1\n\ * = 'Q': Q must contain an orthogonal matrix Q1 on entry, and\n\ * the product Q1*Q is returned;\n\ * = 'I': Q is initialized to the unit matrix, and the\n\ * orthogonal matrix Q is returned;\n\ * = 'N': Q is not computed.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A. M >= 0.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows of the matrix B. P >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrices A and B. N >= 0.\n\ *\n\ * K (input) INTEGER\n\ * L (input) INTEGER\n\ * K and L specify the subblocks in the input matrices A and B:\n\ * A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,N-L+1:N)\n\ * of A and B, whose GSVD is going to be computed by STGSJA.\n\ * See Further Details.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular\n\ * matrix R or part of R. See Purpose for details.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input/output) REAL array, dimension (LDB,N)\n\ * On entry, the P-by-N matrix B.\n\ * On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains\n\ * a part of R. See Purpose for details.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,P).\n\ *\n\ * TOLA (input) REAL\n\ * TOLB (input) REAL\n\ * TOLA and TOLB are the convergence criteria for the Jacobi-\n\ * Kogbetliantz iteration procedure. Generally, they are the\n\ * same as used in the preprocessing step, say\n\ * TOLA = max(M,N)*norm(A)*MACHEPS,\n\ * TOLB = max(P,N)*norm(B)*MACHEPS.\n\ *\n\ * ALPHA (output) REAL array, dimension (N)\n\ * BETA (output) REAL array, dimension (N)\n\ * On exit, ALPHA and BETA contain the generalized singular\n\ * value pairs of A and B;\n\ * ALPHA(1:K) = 1,\n\ * BETA(1:K) = 0,\n\ * and if M-K-L >= 0,\n\ * ALPHA(K+1:K+L) = diag(C),\n\ * BETA(K+1:K+L) = diag(S),\n\ * or if M-K-L < 0,\n\ * ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0\n\ * BETA(K+1:M) = S, BETA(M+1:K+L) = 1.\n\ * Furthermore, if K+L < N,\n\ * ALPHA(K+L+1:N) = 0 and\n\ * BETA(K+L+1:N) = 0.\n\ *\n\ * U (input/output) REAL array, dimension (LDU,M)\n\ * On entry, if JOBU = 'U', U must contain a matrix U1 (usually\n\ * the orthogonal matrix returned by SGGSVP).\n\ * On exit,\n\ * if JOBU = 'I', U contains the orthogonal matrix U;\n\ * if JOBU = 'U', U contains the product U1*U.\n\ * If JOBU = 'N', U is not referenced.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= max(1,M) if\n\ * JOBU = 'U'; LDU >= 1 otherwise.\n\ *\n\ * V (input/output) REAL array, dimension (LDV,P)\n\ * On entry, if JOBV = 'V', V must contain a matrix V1 (usually\n\ * the orthogonal matrix returned by SGGSVP).\n\ * On exit,\n\ * if JOBV = 'I', V contains the orthogonal matrix V;\n\ * if JOBV = 'V', V contains the product V1*V.\n\ * If JOBV = 'N', V is not referenced.\n\ *\n\ * LDV (input) INTEGER\n\ * The leading dimension of the array V. LDV >= max(1,P) if\n\ * JOBV = 'V'; LDV >= 1 otherwise.\n\ *\n\ * Q (input/output) REAL array, dimension (LDQ,N)\n\ * On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually\n\ * the orthogonal matrix returned by SGGSVP).\n\ * On exit,\n\ * if JOBQ = 'I', Q contains the orthogonal matrix Q;\n\ * if JOBQ = 'Q', Q contains the product Q1*Q.\n\ * If JOBQ = 'N', Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= max(1,N) if\n\ * JOBQ = 'Q'; LDQ >= 1 otherwise.\n\ *\n\ * WORK (workspace) REAL array, dimension (2*N)\n\ *\n\ * NCYCLE (output) INTEGER\n\ * The number of cycles required for convergence.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * = 1: the procedure does not converge after MAXIT cycles.\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * MAXIT INTEGER\n\ * MAXIT specifies the total loops that the iterative procedure\n\ * may take. If after MAXIT cycles, the routine fails to\n\ * converge, we return INFO = 1.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * STGSJA essentially uses a variant of Kogbetliantz algorithm to reduce\n\ * min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L\n\ * matrix B13 to the form:\n\ *\n\ * U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1,\n\ *\n\ * where U1, V1 and Q1 are orthogonal matrix, and Z' is the transpose\n\ * of Z. C1 and S1 are diagonal matrices satisfying\n\ *\n\ * C1**2 + S1**2 = I,\n\ *\n\ * and R1 is an L-by-L nonsingular upper triangular matrix.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlarrc0000644000175000017500000000542712502223526016467 0ustar uwabamiuwabami--- :name: dlarrc :md5sum: 2d81dc9eb77d1fa80fe1708beeb85b08 :category: :subroutine :arguments: - jobt: :type: char :intent: input - n: :type: integer :intent: input - vl: :type: doublereal :intent: input - vu: :type: doublereal :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublereal :intent: input :dims: - n - pivmin: :type: doublereal :intent: input - eigcnt: :type: integer :intent: output - lcnt: :type: integer :intent: output - rcnt: :type: integer :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLARRC( JOBT, N, VL, VU, D, E, PIVMIN, EIGCNT, LCNT, RCNT, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Find the number of eigenvalues of the symmetric tridiagonal matrix T\n\ * that are in the interval (VL,VU] if JOBT = 'T', and of L D L^T\n\ * if JOBT = 'L'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBT (input) CHARACTER*1\n\ * = 'T': Compute Sturm count for matrix T.\n\ * = 'L': Compute Sturm count for matrix L D L^T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N > 0.\n\ *\n\ * VL (input) DOUBLE PRECISION\n\ * VU (input) DOUBLE PRECISION\n\ * The lower and upper bounds for the eigenvalues.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * JOBT = 'T': The N diagonal elements of the tridiagonal matrix T.\n\ * JOBT = 'L': The N diagonal elements of the diagonal matrix D.\n\ *\n\ * E (input) DOUBLE PRECISION array, dimension (N)\n\ * JOBT = 'T': The N-1 offdiagonal elements of the matrix T.\n\ * JOBT = 'L': The N-1 offdiagonal elements of the matrix L.\n\ *\n\ * PIVMIN (input) DOUBLE PRECISION\n\ * The minimum pivot in the Sturm sequence for T.\n\ *\n\ * EIGCNT (output) INTEGER\n\ * The number of eigenvalues of the symmetric tridiagonal matrix T\n\ * that are in the interval (VL,VU]\n\ *\n\ * LCNT (output) INTEGER\n\ * RCNT (output) INTEGER\n\ * The left and right negcounts of the interval.\n\ *\n\ * INFO (output) INTEGER\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Beresford Parlett, University of California, Berkeley, USA\n\ * Jim Demmel, University of California, Berkeley, USA\n\ * Inderjit Dhillon, University of Texas, Austin, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, University of California, Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dggqrf0000644000175000017500000001564212502223526016472 0ustar uwabamiuwabami--- :name: dggqrf :md5sum: efab5563e7dc3ab5cf95b5adc2c09cfe :category: :subroutine :arguments: - n: :type: integer :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - m - lda: :type: integer :intent: input - taua: :type: doublereal :intent: output :dims: - MIN(n,m) - b: :type: doublereal :intent: input/output :dims: - ldb - p - ldb: :type: integer :intent: input - taub: :type: doublereal :intent: output :dims: - MIN(n,p) - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MAX(MAX(n,m),p) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGGQRF computes a generalized QR factorization of an N-by-M matrix A\n\ * and an N-by-P matrix B:\n\ *\n\ * A = Q*R, B = Q*T*Z,\n\ *\n\ * where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal\n\ * matrix, and R and T assume one of the forms:\n\ *\n\ * if N >= M, R = ( R11 ) M , or if N < M, R = ( R11 R12 ) N,\n\ * ( 0 ) N-M N M-N\n\ * M\n\ *\n\ * where R11 is upper triangular, and\n\ *\n\ * if N <= P, T = ( 0 T12 ) N, or if N > P, T = ( T11 ) N-P,\n\ * P-N N ( T21 ) P\n\ * P\n\ *\n\ * where T12 or T21 is upper triangular.\n\ *\n\ * In particular, if B is square and nonsingular, the GQR factorization\n\ * of A and B implicitly gives the QR factorization of inv(B)*A:\n\ *\n\ * inv(B)*A = Z'*(inv(T)*R)\n\ *\n\ * where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n\ * transpose of the matrix Z.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The number of rows of the matrices A and B. N >= 0.\n\ *\n\ * M (input) INTEGER\n\ * The number of columns of the matrix A. M >= 0.\n\ *\n\ * P (input) INTEGER\n\ * The number of columns of the matrix B. P >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,M)\n\ * On entry, the N-by-M matrix A.\n\ * On exit, the elements on and above the diagonal of the array\n\ * contain the min(N,M)-by-M upper trapezoidal matrix R (R is\n\ * upper triangular if N >= M); the elements below the diagonal,\n\ * with the array TAUA, represent the orthogonal matrix Q as a\n\ * product of min(N,M) elementary reflectors (see Further\n\ * Details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * TAUA (output) DOUBLE PRECISION array, dimension (min(N,M))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the orthogonal matrix Q (see Further Details).\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,P)\n\ * On entry, the N-by-P matrix B.\n\ * On exit, if N <= P, the upper triangle of the subarray\n\ * B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n\ * if N > P, the elements on and above the (N-P)-th subdiagonal\n\ * contain the N-by-P upper trapezoidal matrix T; the remaining\n\ * elements, with the array TAUB, represent the orthogonal\n\ * matrix Z as a product of elementary reflectors (see Further\n\ * Details).\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * TAUB (output) DOUBLE PRECISION array, dimension (min(N,P))\n\ * The scalar factors of the elementary reflectors which\n\ * represent the orthogonal matrix Z (see Further 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,N,M,P).\n\ * For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n\ * where NB1 is the optimal blocksize for the QR factorization\n\ * of an N-by-M matrix, NB2 is the optimal blocksize for the\n\ * RQ factorization of an N-by-P matrix, and NB3 is the optimal\n\ * blocksize for a call of DORMQR.\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(1) H(2) . . . H(k), where k = min(n,m).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - taua * v * v'\n\ *\n\ * where taua 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+1:n,i),\n\ * and taua in TAUA(i).\n\ * To form Q explicitly, use LAPACK subroutine DORGQR.\n\ * To use Q to update another matrix, use LAPACK subroutine DORMQR.\n\ *\n\ * The matrix Z is represented as a product of elementary reflectors\n\ *\n\ * Z = H(1) H(2) . . . H(k), where k = min(n,p).\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H(i) = I - taub * v * v'\n\ *\n\ * where taub is a real scalar, and v is a real vector with\n\ * v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in\n\ * B(n-k+i,1:p-k+i-1), and taub in TAUB(i).\n\ * To form Z explicitly, use LAPACK subroutine DORGRQ.\n\ * To use Z to update another matrix, use LAPACK subroutine DORMRQ.\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL DGEQRF, DGERQF, DORMQR, XERBLA\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC INT, MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zlatbs0000644000175000017500000001710612502223526016514 0ustar uwabamiuwabami--- :name: zlatbs :md5sum: b9a44e5a032a473e82cf84ccdbe79041 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - normin: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - x: :type: doublecomplex :intent: input/output :dims: - n - scale: :type: doublereal :intent: output - cnorm: :type: doublereal :intent: input/output :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, SCALE, CNORM, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLATBS solves one of the triangular systems\n\ *\n\ * A * x = s*b, A**T * x = s*b, or A**H * x = s*b,\n\ *\n\ * with scaling to prevent overflow, where A is an upper or lower\n\ * triangular band matrix. Here A' denotes the transpose of A, x and b\n\ * are n-element vectors, and s is a scaling factor, usually less than\n\ * or equal to 1, chosen so that the components of x will be less than\n\ * the overflow threshold. If the unscaled problem will not cause\n\ * overflow, the Level 2 BLAS routine ZTBSV is called. If the matrix A\n\ * is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n\ * non-trivial solution to A*x = 0 is returned.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the matrix A is upper or lower triangular.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the operation applied to A.\n\ * = 'N': Solve A * x = s*b (No transpose)\n\ * = 'T': Solve A**T * x = s*b (Transpose)\n\ * = 'C': Solve A**H * x = s*b (Conjugate transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * Specifies whether or not the matrix A is unit triangular.\n\ * = 'N': Non-unit triangular\n\ * = 'U': Unit triangular\n\ *\n\ * NORMIN (input) CHARACTER*1\n\ * Specifies whether CNORM has been set or not.\n\ * = 'Y': CNORM contains the column norms on entry\n\ * = 'N': CNORM is not set on entry. On exit, the norms will\n\ * be computed and stored in CNORM.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of subdiagonals or superdiagonals in the\n\ * triangular matrix A. KD >= 0.\n\ *\n\ * AB (input) COMPLEX*16 array, dimension (LDAB,N)\n\ * The upper or lower triangular band matrix A, stored in the\n\ * first KD+1 rows of the array. The j-th column of A is stored\n\ * in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * X (input/output) COMPLEX*16 array, dimension (N)\n\ * On entry, the right hand side b of the triangular system.\n\ * On exit, X is overwritten by the solution vector x.\n\ *\n\ * SCALE (output) DOUBLE PRECISION\n\ * The scaling factor s for the triangular system\n\ * A * x = s*b, A**T * x = s*b, or A**H * x = s*b.\n\ * If SCALE = 0, the matrix A is singular or badly scaled, and\n\ * the vector x is an exact or approximate solution to A*x = 0.\n\ *\n\ * CNORM (input or output) DOUBLE PRECISION array, dimension (N)\n\ *\n\ * If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n\ * contains the norm of the off-diagonal part of the j-th column\n\ * of A. If TRANS = 'N', CNORM(j) must be greater than or equal\n\ * to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n\ * must be greater than or equal to the 1-norm.\n\ *\n\ * If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n\ * returns the 1-norm of the offdiagonal part of the j-th column\n\ * of A.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ *\n\n\ * Further Details\n\ * ======= =======\n\ *\n\ * A rough bound on x is computed; if that is less than overflow, ZTBSV\n\ * is called, otherwise, specific code is used which checks for possible\n\ * overflow or divide-by-zero at every operation.\n\ *\n\ * A columnwise scheme is used for solving A*x = b. The basic algorithm\n\ * if A is lower triangular is\n\ *\n\ * x[1:n] := b[1:n]\n\ * for j = 1, ..., n\n\ * x(j) := x(j) / A(j,j)\n\ * x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n\ * end\n\ *\n\ * Define bounds on the components of x after j iterations of the loop:\n\ * M(j) = bound on x[1:j]\n\ * G(j) = bound on x[j+1:n]\n\ * Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n\ *\n\ * Then for iteration j+1 we have\n\ * M(j+1) <= G(j) / | A(j+1,j+1) |\n\ * G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n\ * <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n\ *\n\ * where CNORM(j+1) is greater than or equal to the infinity-norm of\n\ * column j+1 of A, not counting the diagonal. Hence\n\ *\n\ * G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n\ * 1<=i<=j\n\ * and\n\ *\n\ * |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n\ * 1<=i< j\n\ *\n\ * Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTBSV if the\n\ * reciprocal of the largest M(j), j=1,..,n, is larger than\n\ * max(underflow, 1/overflow).\n\ *\n\ * The bound on x(j) is also used to determine when a step in the\n\ * columnwise method can be performed without fear of overflow. If\n\ * the computed bound is greater than a large constant, x is scaled to\n\ * prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n\ * 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n\ *\n\ * Similarly, a row-wise scheme is used to solve A**T *x = b or\n\ * A**H *x = b. The basic algorithm for A upper triangular is\n\ *\n\ * for j = 1, ..., n\n\ * x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n\ * end\n\ *\n\ * We simultaneously compute two bounds\n\ * G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n\ * M(j) = bound on x(i), 1<=i<=j\n\ *\n\ * The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n\ * add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n\ * Then the bound on x(j) is\n\ *\n\ * M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n\ *\n\ * <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n\ * 1<=i<=j\n\ *\n\ * and we can safely call ZTBSV if 1/M(n) and 1/G(n) are both greater\n\ * than max(underflow, 1/overflow).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ztfsm0000644000175000017500000002253612502223526016363 0ustar uwabamiuwabami--- :name: ztfsm :md5sum: bed1c95a4d04ac36ac05706919521fe2 :category: :subroutine :arguments: - transr: :type: char :intent: input - side: :type: char :intent: input - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: doublecomplex :intent: input - a: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE ZTFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, B, LDB )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Level 3 BLAS like routine for A in RFP Format.\n\ *\n\ * ZTFSM solves the matrix equation\n\ *\n\ * op( A )*X = alpha*B or X*op( A ) = alpha*B\n\ *\n\ * where alpha is a scalar, X and B are m by n matrices, A is a unit, or\n\ * non-unit, upper or lower triangular matrix and op( A ) is one of\n\ *\n\ * op( A ) = A or op( A ) = conjg( A' ).\n\ *\n\ * A is in Rectangular Full Packed (RFP) Format.\n\ *\n\ * The matrix X is overwritten on B.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': The Normal Form of RFP A is stored;\n\ * = 'C': The Conjugate-transpose Form of RFP A is stored.\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * On entry, SIDE specifies whether op( A ) appears on the left\n\ * or right of X as follows:\n\ *\n\ * SIDE = 'L' or 'l' op( A )*X = alpha*B.\n\ *\n\ * SIDE = 'R' or 'r' X*op( A ) = alpha*B.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * On entry, UPLO specifies whether the RFP matrix A came from\n\ * an upper or lower triangular matrix as follows:\n\ * UPLO = 'U' or 'u' RFP A came from an upper triangular matrix\n\ * UPLO = 'L' or 'l' RFP A came from a lower triangular matrix\n\ *\n\ * Unchanged on exit.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * On entry, TRANS specifies the form of op( A ) to be used\n\ * in the matrix multiplication as follows:\n\ *\n\ * TRANS = 'N' or 'n' op( A ) = A.\n\ *\n\ * TRANS = 'C' or 'c' op( A ) = conjg( A' ).\n\ *\n\ * Unchanged on exit.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * On entry, DIAG specifies whether or not RFP A is unit\n\ * triangular as follows:\n\ *\n\ * DIAG = 'U' or 'u' A is assumed to be unit triangular.\n\ *\n\ * DIAG = 'N' or 'n' A is not assumed to be unit\n\ * triangular.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * M (input) INTEGER\n\ * On entry, M specifies the number of rows of B. M must be at\n\ * least zero.\n\ * Unchanged on exit.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the number of columns of B. N must be\n\ * at least zero.\n\ * Unchanged on exit.\n\ *\n\ * ALPHA (input) COMPLEX*16\n\ * On entry, ALPHA specifies the scalar alpha. When alpha is\n\ * zero then A is not referenced and B need not be set before\n\ * entry.\n\ * Unchanged on exit.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * NT = N*(N+1)/2. On entry, the matrix A in RFP Format.\n\ * RFP Format is described by TRANSR, UPLO and N as follows:\n\ * If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;\n\ * K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If\n\ * TRANSR = 'C' then RFP is the Conjugate-transpose of RFP A as\n\ * defined when TRANSR = 'N'. The contents of RFP A are defined\n\ * by UPLO as follows: If UPLO = 'U' the RFP A contains the NT\n\ * elements of upper packed A either in normal or\n\ * conjugate-transpose Format. If UPLO = 'L' the RFP A contains\n\ * the NT elements of lower packed A either in normal or\n\ * conjugate-transpose Format. The LDA of RFP A is (N+1)/2 when\n\ * TRANSR = 'C'. When TRANSR is 'N' the LDA is N+1 when N is\n\ * even and is N when is odd.\n\ * See the Note below for more details. Unchanged on exit.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,N)\n\ * Before entry, the leading m by n part of the array B must\n\ * contain the right-hand side matrix B, and on exit is\n\ * overwritten by the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * On entry, LDB specifies the first dimension of B as declared\n\ * in the calling (sub) program. LDB must be at least\n\ * max( 1, m ).\n\ * Unchanged on exit.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * We first consider Standard Packed Format when N is even.\n\ * We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * conjugate-transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * conjugate-transpose of the last three columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- --\n\ * 03 04 05 33 43 53\n\ * -- --\n\ * 13 14 15 00 44 54\n\ * --\n\ * 23 24 25 10 11 55\n\ *\n\ * 33 34 35 20 21 22\n\ * --\n\ * 00 44 45 30 31 32\n\ * -- --\n\ * 01 11 55 40 41 42\n\ * -- -- --\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We next consider Standard Packed Format when N is odd.\n\ * We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * conjugate-transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * conjugate-transpose of the last two columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- --\n\ * 02 03 04 00 33 43\n\ * --\n\ * 12 13 14 10 11 44\n\ *\n\ * 22 23 24 20 21 22\n\ * --\n\ * 00 33 34 30 31 32\n\ * -- --\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- --\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sla_wwaddw0000644000175000017500000000256412502223526017353 0ustar uwabamiuwabami--- :name: sla_wwaddw :md5sum: 7fcd8de2e27cfe0dee3a476f013791a0 :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - n - y: :type: real :intent: input/output :dims: - n - w: :type: real :intent: input :dims: - n :substitutions: {} :fortran_help: " SUBROUTINE SLA_WWADDW( N, X, Y, W )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLA_WWADDW adds a vector W into a doubled-single vector (X, Y).\n\ *\n\ * This works for all extant IBM's hex and binary floating point\n\ * arithmetics, but not for decimal.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The length of vectors X, Y, and W.\n\ *\n\ * X (input/output) REAL array, dimension (N)\n\ * The first part of the doubled-single accumulation vector.\n\ *\n\ * Y (input/output) REAL array, dimension (N)\n\ * The second part of the doubled-single accumulation vector.\n\ *\n\ * W (input) REAL array, dimension (N)\n\ * The vector to be added.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n REAL S\n INTEGER I\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zla_gbrcond_x0000644000175000017500000001041212502223526020021 0ustar uwabamiuwabami--- :name: zla_gbrcond_x :md5sum: 82710e74ceba14453857104a1281a7b2 :category: :function :type: doublereal :arguments: - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublecomplex :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - x: :type: doublecomplex :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: doublecomplex :intent: input :dims: - 2*n - rwork: :type: doublereal :intent: input :dims: - n :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION ZLA_GBRCOND_X( TRANS, N, KL, KU, AB, LDAB, AFB, LDAFB, IPIV, X, INFO, WORK, RWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLA_GBRCOND_X Computes the infinity norm condition number of\n\ * op(A) * diag(X) where X is a COMPLEX*16 vector.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate Transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * AB (input) COMPLEX*16 array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * AFB (input) COMPLEX*16 array, dimension (LDAFB,N)\n\ * Details of the LU factorization of the band matrix A, as\n\ * computed by ZGBTRF. U is stored as an upper triangular\n\ * band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n\ * and the multipliers used during the factorization are stored\n\ * in rows KL+KU+2 to 2*KL+KU+1.\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from the factorization A = P*L*U\n\ * as computed by ZGBTRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * X (input) COMPLEX*16 array, dimension (N)\n\ * The vector X in the formula op(A) * diag(X).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * i > 0: The ith argument is invalid.\n\ *\n\ * WORK (input) COMPLEX*16 array, dimension (2*N).\n\ * Workspace.\n\ *\n\ * RWORK (input) DOUBLE PRECISION array, dimension (N).\n\ * Workspace.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL NOTRANS\n INTEGER KASE, I, J\n DOUBLE PRECISION AINVNM, ANORM, TMP\n COMPLEX*16 ZDUM\n\ * ..\n\ * .. Local Arrays ..\n INTEGER ISAVE( 3 )\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL ZLACN2, ZGBTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n\ * ..\n\ * .. Statement Functions ..\n DOUBLE PRECISION CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlauum0000644000175000017500000000414612502223526016504 0ustar uwabamiuwabami--- :name: dlauum :md5sum: f5db6017186c241df76a0021dec24cdc :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLAUUM( UPLO, N, A, LDA, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAUUM computes the product U * U' or L' * L, where the triangular\n\ * factor U or L is stored in the upper or lower triangular part of\n\ * the array A.\n\ *\n\ * If UPLO = 'U' or 'u' then the upper triangle of the result is stored,\n\ * overwriting the factor U in A.\n\ * If UPLO = 'L' or 'l' then the lower triangle of the result is stored,\n\ * overwriting the factor L in A.\n\ *\n\ * This is the blocked form of the algorithm, calling Level 3 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the triangular factor stored in the array A\n\ * is upper or lower triangular:\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the triangular factor U or L. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the triangular factor U or L.\n\ * On exit, if UPLO = 'U', the upper triangle of A is\n\ * overwritten with the upper triangle of the product U * U';\n\ * if UPLO = 'L', the lower triangle of A is overwritten with\n\ * the lower triangle of the product L' * L.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlarnv0000644000175000017500000000372112502223526016527 0ustar uwabamiuwabami--- :name: zlarnv :md5sum: 36e5ab2161ffb5a09faacf3c756eed1b :category: :subroutine :arguments: - idist: :type: integer :intent: input - iseed: :type: integer :intent: input/output :dims: - "4" - n: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - MAX(1,n) :substitutions: {} :fortran_help: " SUBROUTINE ZLARNV( IDIST, ISEED, N, X )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLARNV returns a vector of n random complex numbers from a uniform or\n\ * normal distribution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * IDIST (input) INTEGER\n\ * Specifies the distribution of the random numbers:\n\ * = 1: real and imaginary parts each uniform (0,1)\n\ * = 2: real and imaginary parts each uniform (-1,1)\n\ * = 3: real and imaginary parts each normal (0,1)\n\ * = 4: uniformly distributed on the disc abs(z) < 1\n\ * = 5: uniformly distributed on the circle abs(z) = 1\n\ *\n\ * ISEED (input/output) INTEGER array, dimension (4)\n\ * On entry, the seed of the random number generator; the array\n\ * elements must be between 0 and 4095, and ISEED(4) must be\n\ * odd.\n\ * On exit, the seed is updated.\n\ *\n\ * N (input) INTEGER\n\ * The number of random numbers to be generated.\n\ *\n\ * X (output) COMPLEX*16 array, dimension (N)\n\ * The generated random numbers.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * This routine calls the auxiliary routine DLARUV to generate random\n\ * real numbers from a uniform (0,1) distribution, in batches of up to\n\ * 128 using vectorisable code. The Box-Muller method is used to\n\ * transform numbers from a uniform to a normal distribution.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cstemr0000644000175000017500000003121412502223525016505 0ustar uwabamiuwabami--- :name: cstemr :md5sum: 67d185e1ab47a23685d6c651ae0c225b :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: complex :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - nzc: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - tryrac: :type: logical :intent: input/output - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 18*n : lsame_(&jobz,\"N\") ? 12*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"V\") ? 10*n : lsame_(&jobz,\"N\") ? 8*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"A\") ? n : lsame_(&range,\"I\") ? iu-il+1 : 0" :fortran_help: " SUBROUTINE CSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSTEMR computes selected eigenvalues and, optionally, eigenvectors\n\ * of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n\ * a well defined set of pairwise different real eigenvalues, the corresponding\n\ * real eigenvectors are pairwise orthogonal.\n\ *\n\ * The spectrum may be computed either completely or partially by specifying\n\ * either an interval (VL,VU] or a range of indices IL:IU for the desired\n\ * eigenvalues.\n\ *\n\ * Depending on the number of desired eigenvalues, these are computed either\n\ * by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are\n\ * computed by the use of various suitable L D L^T factorizations near clusters\n\ * of close eigenvalues (referred to as RRRs, Relatively Robust\n\ * Representations). An informal sketch of the algorithm follows.\n\ *\n\ * For each unreduced block (submatrix) of T,\n\ * (a) Compute T - sigma I = L D L^T, so that L and D\n\ * define all the wanted eigenvalues to high relative accuracy.\n\ * This means that small relative changes in the entries of D and L\n\ * cause only small relative changes in the eigenvalues and\n\ * eigenvectors. The standard (unfactored) representation of the\n\ * tridiagonal matrix T does not have this property in general.\n\ * (b) Compute the eigenvalues to suitable accuracy.\n\ * If the eigenvectors are desired, the algorithm attains full\n\ * accuracy of the computed eigenvalues only right before\n\ * the corresponding vectors have to be computed, see steps c) and d).\n\ * (c) For each cluster of close eigenvalues, select a new\n\ * shift close to the cluster, find a new factorization, and refine\n\ * the shifted eigenvalues to suitable accuracy.\n\ * (d) For each eigenvalue with a large enough relative separation compute\n\ * the corresponding eigenvector by forming a rank revealing twisted\n\ * factorization. Go back to (c) for any clusters that remain.\n\ *\n\ * For more details, see:\n\ * - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n\ * to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n\ * Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n\ * - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n\ * Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n\ * 2004. Also LAPACK Working Note 154.\n\ * - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n\ * tridiagonal eigenvalue/eigenvector problem\",\n\ * Computer Science Division Technical Report No. UCB/CSD-97-971,\n\ * UC Berkeley, May 1997.\n\ *\n\ * Further Details\n\ * 1.CSTEMR works only on machines which follow IEEE-754\n\ * floating-point standard in their handling of infinities and NaNs.\n\ * This permits the use of efficient inner loops avoiding a check for\n\ * zero divisors.\n\ *\n\ * 2. LAPACK routines can be used to reduce a complex Hermitean matrix to\n\ * real symmetric tridiagonal form.\n\ *\n\ * (Any complex Hermitean tridiagonal matrix has real values on its diagonal\n\ * and potentially complex numbers on its off-diagonals. By applying a\n\ * similarity transform with an appropriate diagonal matrix\n\ * diag(1,e^{i \\phy_1}, ... , e^{i \\phy_{n-1}}), the complex Hermitean\n\ * matrix can be transformed into a real symmetric matrix and complex\n\ * arithmetic can be entirely avoided.)\n\ *\n\ * While the eigenvectors of the real symmetric tridiagonal matrix are real,\n\ * the eigenvectors of original complex Hermitean matrix have complex entries\n\ * in general.\n\ * Since LAPACK drivers overwrite the matrix data with the eigenvectors,\n\ * CSTEMR accepts complex workspace to facilitate interoperability\n\ * with CUNMTR or CUPMTR.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found.\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found.\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the N diagonal elements of the tridiagonal matrix\n\ * T. On exit, D is overwritten.\n\ *\n\ * E (input/output) REAL array, dimension (N)\n\ * On entry, the (N-1) subdiagonal elements of the tridiagonal\n\ * matrix T in elements 1 to N-1 of E. E(N) need not be set on\n\ * input, but is used internally as workspace.\n\ * On exit, E is overwritten.\n\ *\n\ * VL (input) REAL\n\ * VU (input) REAL\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * The first M elements contain the selected eigenvalues in\n\ * ascending order.\n\ *\n\ * Z (output) COMPLEX array, dimension (LDZ, max(1,M) )\n\ * If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix T\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and can be computed with a workspace\n\ * query by setting NZC = -1, see below.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', then LDZ >= max(1,N).\n\ *\n\ * NZC (input) INTEGER\n\ * The number of eigenvectors to be held in the array Z.\n\ * If RANGE = 'A', then NZC >= max(1,N).\n\ * If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].\n\ * If RANGE = 'I', then NZC >= IU-IL+1.\n\ * If NZC = -1, then a workspace query is assumed; the\n\ * routine calculates the number of columns of the array Z that\n\ * are needed to hold the eigenvectors.\n\ * This value is returned as the first entry of the Z array, and\n\ * no error message related to NZC is issued by XERBLA.\n\ *\n\ * ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n\ * The support of the eigenvectors in Z, i.e., the indices\n\ * indicating the nonzero elements in Z. The i-th computed eigenvector\n\ * is nonzero only in elements ISUPPZ( 2*i-1 ) through\n\ * ISUPPZ( 2*i ). This is relevant in the case when the matrix\n\ * is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n\ *\n\ * TRYRAC (input/output) LOGICAL\n\ * If TRYRAC.EQ..TRUE., indicates that the code should check whether\n\ * the tridiagonal matrix defines its eigenvalues to high relative\n\ * accuracy. If so, the code uses relative-accuracy preserving\n\ * algorithms that might be (a bit) slower depending on the matrix.\n\ * If the matrix does not define its eigenvalues to high relative\n\ * accuracy, the code can uses possibly faster algorithms.\n\ * If TRYRAC.EQ..FALSE., the code is not required to guarantee\n\ * relatively accurate eigenvalues and can use the fastest possible\n\ * techniques.\n\ * On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix\n\ * does not define its eigenvalues to high relative accuracy.\n\ *\n\ * WORK (workspace/output) REAL array, dimension (LWORK)\n\ * On exit, if INFO = 0, WORK(1) returns the optimal\n\ * (and minimal) LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK >= max(1,18*N)\n\ * if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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\ * IWORK (workspace/output) INTEGER array, dimension (LIWORK)\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK. LIWORK >= max(1,10*N)\n\ * if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n\ * if only the eigenvalues are to be computed.\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal size of the IWORK array,\n\ * returns this value as the first entry of the IWORK array, and\n\ * no error message related to LIWORK is issued by XERBLA.\n\ *\n\ * INFO (output) INTEGER\n\ * On exit, INFO\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ * > 0: if INFO = 1X, internal error in SLARRE,\n\ * if INFO = 2X, internal error in CLARRV.\n\ * Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n\ * the nonzero error code returned by SLARRE or\n\ * CLARRV, respectively.\n\ *\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Beresford Parlett, University of California, Berkeley, USA\n\ * Jim Demmel, University of California, Berkeley, USA\n\ * Inderjit Dhillon, University of Texas, Austin, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, University of California, Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgetf20000644000175000017500000000451712502223526016411 0ustar uwabamiuwabami--- :name: sgetf2 :md5sum: 6afacce566d20b4c1f8a8014c205bd97 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGETF2( M, N, A, LDA, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGETF2 computes an LU factorization of a general m-by-n matrix A\n\ * using partial pivoting with row interchanges.\n\ *\n\ * The factorization has the form\n\ * A = P * L * U\n\ * where P is a permutation matrix, L is lower triangular with unit\n\ * diagonal elements (lower trapezoidal if m > n), and U is upper\n\ * triangular (upper trapezoidal if m < n).\n\ *\n\ * This is the right-looking Level 2 BLAS version of the algorithm.\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) REAL array, dimension (LDA,N)\n\ * On entry, the m by n matrix to be factored.\n\ * On exit, the factors L and U from the factorization\n\ * A = P*L*U; the unit diagonal elements of L are not stored.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * IPIV (output) INTEGER array, dimension (min(M,N))\n\ * The pivot indices; for 1 <= i <= min(M,N), row i of the\n\ * matrix was interchanged with row IPIV(i).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ * > 0: if INFO = k, U(k,k) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, and division by zero will occur if it is used\n\ * to solve a system of equations.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgetf20000644000175000017500000000453612502223526016421 0ustar uwabamiuwabami--- :name: zgetf2 :md5sum: 1e1593a51365d9fcf134a0057e1d857d :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - MIN(m,n) - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGETF2 computes an LU factorization of a general m-by-n matrix A\n\ * using partial pivoting with row interchanges.\n\ *\n\ * The factorization has the form\n\ * A = P * L * U\n\ * where P is a permutation matrix, L is lower triangular with unit\n\ * diagonal elements (lower trapezoidal if m > n), and U is upper\n\ * triangular (upper trapezoidal if m < n).\n\ *\n\ * This is the right-looking Level 2 BLAS version of the algorithm.\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) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the m by n matrix to be factored.\n\ * On exit, the factors L and U from the factorization\n\ * A = P*L*U; the unit diagonal elements of L are not stored.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * IPIV (output) INTEGER array, dimension (min(M,N))\n\ * The pivot indices; for 1 <= i <= min(M,N), row i of the\n\ * matrix was interchanged with row IPIV(i).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ * > 0: if INFO = k, U(k,k) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly\n\ * singular, and division by zero will occur if it is used\n\ * to solve a system of equations.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ztrcon0000644000175000017500000000615412502223526016535 0ustar uwabamiuwabami--- :name: ztrcon :md5sum: 2ddd97473ce42e3675346106a0b53f3e :category: :subroutine :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTRCON estimates the reciprocal of the condition number of a\n\ * triangular matrix A, in either the 1-norm or the infinity-norm.\n\ *\n\ * The norm of A is computed and an estimate is obtained for\n\ * norm(inv(A)), then the reciprocal of the condition number is\n\ * computed as\n\ * RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies whether the 1-norm condition number or the\n\ * infinity-norm condition number is required:\n\ * = '1' or 'O': 1-norm;\n\ * = 'I': Infinity-norm.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * The triangular matrix A. If UPLO = 'U', the leading N-by-N\n\ * upper triangular part of the array A contains the upper\n\ * triangular matrix, and the strictly lower triangular part of\n\ * A is not referenced. If UPLO = 'L', the leading N-by-N lower\n\ * triangular part of the array A contains the lower triangular\n\ * matrix, and the strictly upper triangular part of A is not\n\ * referenced. If DIAG = 'U', the diagonal elements of A are\n\ * also not referenced and are assumed to be 1.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(norm(A) * norm(inv(A))).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsptrs0000644000175000017500000000467212502223526016540 0ustar uwabamiuwabami--- :name: dsptrs :md5sum: 410e8a2f4bef32f27f6075ab0bf5372c :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublereal :intent: input :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input :dims: - n - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSPTRS solves a system of linear equations A*X = B with a real\n\ * symmetric matrix A stored in packed format using the factorization\n\ * A = U*D*U**T or A = L*D*L**T computed by DSPTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by DSPTRF, stored as a\n\ * packed triangular matrix.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by DSPTRF.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cpftrf0000644000175000017500000001571412502223525016503 0ustar uwabamiuwabami--- :name: cpftrf :md5sum: c3098b2d776c64593a40443315a45dfd :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPFTRF( TRANSR, UPLO, N, A, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPFTRF computes the Cholesky factorization of a complex Hermitian\n\ * positive definite matrix A.\n\ *\n\ * The factorization has the form\n\ * A = U**H * U, if UPLO = 'U', or\n\ * A = L * L**H, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is lower triangular.\n\ *\n\ * This is the block version of the algorithm, calling Level 3 BLAS.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': The Normal TRANSR of RFP A is stored;\n\ * = 'C': The Conjugate-transpose TRANSR of RFP A is stored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of RFP A is stored;\n\ * = 'L': Lower triangle of RFP A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension ( N*(N+1)/2 );\n\ * On entry, the Hermitian matrix A in RFP format. RFP format is\n\ * described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n\ * then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n\ * (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is\n\ * the Conjugate-transpose of RFP A as defined when\n\ * TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n\ * follows: If UPLO = 'U' the RFP A contains the nt elements of\n\ * upper packed A. If UPLO = 'L' the RFP A contains the elements\n\ * of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n\ * 'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n\ * is odd. See the Note below for more details.\n\ *\n\ * On exit, if INFO = 0, the factor U or L from the Cholesky\n\ * factorization RFP A = U**H*U or RFP A = L*L**H.\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 leading minor of order i is not\n\ * positive definite, and the factorization could not be\n\ * completed.\n\ *\n\ * Further Notes on RFP Format:\n\ * ============================\n\ *\n\ *\n\ * We first consider Standard Packed Format when N is even.\n\ * We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * conjugate-transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * conjugate-transpose of the last three columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- --\n\ * 03 04 05 33 43 53\n\ * -- --\n\ * 13 14 15 00 44 54\n\ * --\n\ * 23 24 25 10 11 55\n\ *\n\ * 33 34 35 20 21 22\n\ * --\n\ * 00 44 45 30 31 32\n\ * -- --\n\ * 01 11 55 40 41 42\n\ * -- -- --\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We next consider Standard Packed Format when N is odd.\n\ * We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * conjugate-transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * conjugate-transpose of the last two columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- --\n\ * 02 03 04 00 33 43\n\ * --\n\ * 12 13 14 10 11 44\n\ *\n\ * 22 23 24 20 21 22\n\ * --\n\ * 00 33 34 30 31 32\n\ * -- --\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- --\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ssyevr0000644000175000017500000003013512502223526016545 0ustar uwabamiuwabami--- :name: ssyevr :md5sum: aeda6b168ea42a1a378f58c635a709cc :category: :subroutine :arguments: - jobz: :type: char :intent: input - range: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - vl: :type: real :intent: input - vu: :type: real :intent: input - il: :type: integer :intent: input - iu: :type: integer :intent: input - abstol: :type: real :intent: input - m: :type: integer :intent: output - w: :type: real :intent: output :dims: - n - z: :type: real :intent: output :dims: - ldz - MAX(1,m) - ldz: :type: integer :intent: input - isuppz: :type: integer :intent: output :dims: - 2*MAX(1,m) - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: 26*n - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: 10*n - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" m: "lsame_(&range,\"I\") ? iu-il+1 : n" :fortran_help: " SUBROUTINE SSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSYEVR computes selected eigenvalues and, optionally, eigenvectors\n\ * of a real symmetric matrix A. Eigenvalues and eigenvectors can be\n\ * selected by specifying either a range of values or a range of\n\ * indices for the desired eigenvalues.\n\ *\n\ * SSYEVR first reduces the matrix A to tridiagonal form T with a call\n\ * to SSYTRD. Then, whenever possible, SSYEVR calls SSTEMR to compute\n\ * the eigenspectrum using Relatively Robust Representations. SSTEMR\n\ * computes eigenvalues by the dqds algorithm, while orthogonal\n\ * eigenvectors are computed from various \"good\" L D L^T representations\n\ * (also known as Relatively Robust Representations). Gram-Schmidt\n\ * orthogonalization is avoided as far as possible. More specifically,\n\ * the various steps of the algorithm are as follows.\n\ *\n\ * For each unreduced block (submatrix) of T,\n\ * (a) Compute T - sigma I = L D L^T, so that L and D\n\ * define all the wanted eigenvalues to high relative accuracy.\n\ * This means that small relative changes in the entries of D and L\n\ * cause only small relative changes in the eigenvalues and\n\ * eigenvectors. The standard (unfactored) representation of the\n\ * tridiagonal matrix T does not have this property in general.\n\ * (b) Compute the eigenvalues to suitable accuracy.\n\ * If the eigenvectors are desired, the algorithm attains full\n\ * accuracy of the computed eigenvalues only right before\n\ * the corresponding vectors have to be computed, see steps c) and d).\n\ * (c) For each cluster of close eigenvalues, select a new\n\ * shift close to the cluster, find a new factorization, and refine\n\ * the shifted eigenvalues to suitable accuracy.\n\ * (d) For each eigenvalue with a large enough relative separation compute\n\ * the corresponding eigenvector by forming a rank revealing twisted\n\ * factorization. Go back to (c) for any clusters that remain.\n\ *\n\ * The desired accuracy of the output can be specified by the input\n\ * parameter ABSTOL.\n\ *\n\ * For more details, see SSTEMR's documentation and:\n\ * - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n\ * to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n\ * Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n\ * - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n\ * Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n\ * 2004. Also LAPACK Working Note 154.\n\ * - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n\ * tridiagonal eigenvalue/eigenvector problem\",\n\ * Computer Science Division Technical Report No. UCB/CSD-97-971,\n\ * UC Berkeley, May 1997.\n\ *\n\ *\n\ * Note 1 : SSYEVR calls SSTEMR when the full spectrum is requested\n\ * on machines which conform to the ieee-754 floating point standard.\n\ * SSYEVR calls SSTEBZ and SSTEIN on non-ieee machines and\n\ * when partial spectrum requests are made.\n\ *\n\ * Normal execution of SSTEMR may create NaNs and infinities and\n\ * hence may abort due to a floating point exception in environments\n\ * which do not handle NaNs and infinities in the ieee standard default\n\ * manner.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * RANGE (input) CHARACTER*1\n\ * = 'A': all eigenvalues will be found.\n\ * = 'V': all eigenvalues in the half-open interval (VL,VU]\n\ * will be found.\n\ * = 'I': the IL-th through IU-th eigenvalues will be found.\n\ ********** For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and\n\ ********** SSTEIN are called\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA, N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the\n\ * leading N-by-N upper triangular part of A contains the\n\ * upper triangular part of the matrix A. If UPLO = 'L',\n\ * the leading N-by-N lower triangular part of A contains\n\ * the lower triangular part of the matrix A.\n\ * On exit, the lower triangle (if UPLO='L') or the upper\n\ * triangle (if UPLO='U') of A, including the diagonal, is\n\ * destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * VL (input) REAL\n\ * VU (input) REAL\n\ * If RANGE='V', the lower and upper bounds of the interval to\n\ * be searched for eigenvalues. VL < VU.\n\ * Not referenced if RANGE = 'A' or 'I'.\n\ *\n\ * IL (input) INTEGER\n\ * IU (input) INTEGER\n\ * If RANGE='I', the indices (in ascending order) of the\n\ * smallest and largest eigenvalues to be returned.\n\ * 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n\ * Not referenced if RANGE = 'A' or 'V'.\n\ *\n\ * ABSTOL (input) REAL\n\ * The absolute error tolerance for the eigenvalues.\n\ * An approximate eigenvalue is accepted as converged\n\ * when it is determined to lie in an interval [a,b]\n\ * of width less than or equal to\n\ *\n\ * ABSTOL + EPS * max( |a|,|b| ) ,\n\ *\n\ * where EPS is the machine precision. If ABSTOL is less than\n\ * or equal to zero, then EPS*|T| will be used in its place,\n\ * where |T| is the 1-norm of the tridiagonal matrix obtained\n\ * by reducing A to tridiagonal form.\n\ *\n\ * See \"Computing Small Singular Values of Bidiagonal Matrices\n\ * with Guaranteed High Relative Accuracy,\" by Demmel and\n\ * Kahan, LAPACK Working Note #3.\n\ *\n\ * If high relative accuracy is important, set ABSTOL to\n\ * SLAMCH( 'Safe minimum' ). Doing so will guarantee that\n\ * eigenvalues are computed to high relative accuracy when\n\ * possible in future releases. The current code does not\n\ * make any guarantees about high relative accuracy, but\n\ * future releases will. See J. Barlow and J. Demmel,\n\ * \"Computing Accurate Eigensystems of Scaled Diagonally\n\ * Dominant Matrices\", LAPACK Working Note #7, for a discussion\n\ * of which matrices define their eigenvalues to high relative\n\ * accuracy.\n\ *\n\ * M (output) INTEGER\n\ * The total number of eigenvalues found. 0 <= M <= N.\n\ * If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n\ *\n\ * W (output) REAL array, dimension (N)\n\ * The first M elements contain the selected eigenvalues in\n\ * ascending order.\n\ *\n\ * Z (output) REAL array, dimension (LDZ, max(1,M))\n\ * If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n\ * contain the orthonormal eigenvectors of the matrix A\n\ * corresponding to the selected eigenvalues, with the i-th\n\ * column of Z holding the eigenvector associated with W(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ * Note: the user must ensure that at least max(1,M) columns are\n\ * supplied in the array Z; if RANGE = 'V', the exact value of M\n\ * is not known in advance and an upper bound must be used.\n\ * Supplying N columns is always safe.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )\n\ * The support of the eigenvectors in Z, i.e., the indices\n\ * indicating the nonzero elements in Z. The i-th eigenvector\n\ * is nonzero only in elements ISUPPZ( 2*i-1 ) through\n\ * ISUPPZ( 2*i ).\n\ ********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1\n\ *\n\ * WORK (workspace/output) REAL 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,26*N).\n\ * For optimal efficiency, LWORK >= (NB+6)*N,\n\ * where NB is the max of the blocksize for SSYTRD and SORMTR\n\ * returned by ILAENV.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the optimal sizes of the WORK and IWORK\n\ * arrays, returns these values as the first entries of the WORK\n\ * and IWORK arrays, and no error message related to LWORK or\n\ * LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK. LIWORK >= max(1,10*N).\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK and IWORK arrays, and no error message related to\n\ * LWORK or LIWORK 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: Internal error\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Inderjit Dhillon, IBM Almaden, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Ken Stanley, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ * Jason Riedy, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dorcsd0000644000175000017500000001731112502223526016471 0ustar uwabamiuwabami--- :name: dorcsd :md5sum: 16a44e6711210545e42e19e9eb2e970f :category: :subroutine :arguments: - jobu1: :type: char :intent: input - jobu2: :type: char :intent: input - jobv1t: :type: char :intent: input - jobv2t: :type: char :intent: input - trans: :type: char :intent: input - signs: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - q: :type: integer :intent: input - x11: :type: doublereal :intent: input :dims: - ldx11 - q - ldx11: :type: integer :intent: input - x12: :type: doublereal :intent: input :dims: - ldx12 - m-q - ldx12: :type: integer :intent: input - x21: :type: doublereal :intent: input :dims: - ldx21 - q - ldx21: :type: integer :intent: input - x22: :type: doublereal :intent: input :dims: - ldx22 - m-q - ldx22: :type: integer :intent: input - theta: :type: doublereal :intent: output :dims: - MIN(MIN(MIN(p,m-p),q),m-q) - u1: :type: doublereal :intent: output :dims: - p - ldu1: :type: integer :intent: input - u2: :type: doublereal :intent: output :dims: - m-p - ldu2: :type: integer :intent: input - v1t: :type: doublereal :intent: output :dims: - q - ldv1t: :type: integer :intent: input - v2t: :type: doublereal :intent: output :dims: - m-q - ldv2t: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - iwork: :type: integer :intent: workspace :dims: - m-q - info: :type: integer :intent: output :substitutions: ldv2t: "lsame_(&jobv2t,\"Y\") ? MAX(1,m-q) : 0" ldv1t: "lsame_(&jobv1t,\"Y\") ? MAX(1,q) : 0" ldu1: "lsame_(&jobu1,\"Y\") ? MAX(1,p) : 0" ldu2: "lsame_(&jobu2,\"Y\") ? MAX(1,m-p) : 0" p: ldx11 ldx12: p ldx21: p ldx22: p :fortran_help: " RECURSIVE SUBROUTINE DORCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, WORK, LWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DORCSD computes the CS decomposition of an M-by-M partitioned\n\ * orthogonal matrix X:\n\ *\n\ * [ I 0 0 | 0 0 0 ]\n\ * [ 0 C 0 | 0 -S 0 ]\n\ * [ X11 | X12 ] [ U1 | ] [ 0 0 0 | 0 0 -I ] [ V1 | ]**T\n\ * X = [-----------] = [---------] [---------------------] [---------] .\n\ * [ X21 | X22 ] [ | U2 ] [ 0 0 0 | I 0 0 ] [ | V2 ]\n\ * [ 0 S 0 | 0 C 0 ]\n\ * [ 0 0 I | 0 0 0 ]\n\ *\n\ * X11 is P-by-Q. The orthogonal matrices U1, U2, V1, and V2 are P-by-P,\n\ * (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are\n\ * R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in\n\ * which R = MIN(P,M-P,Q,M-Q).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBU1 (input) CHARACTER\n\ * = 'Y': U1 is computed;\n\ * otherwise: U1 is not computed.\n\ *\n\ * JOBU2 (input) CHARACTER\n\ * = 'Y': U2 is computed;\n\ * otherwise: U2 is not computed.\n\ *\n\ * JOBV1T (input) CHARACTER\n\ * = 'Y': V1T is computed;\n\ * otherwise: V1T is not computed.\n\ *\n\ * JOBV2T (input) CHARACTER\n\ * = 'Y': V2T is computed;\n\ * otherwise: V2T is not computed.\n\ *\n\ * TRANS (input) CHARACTER\n\ * = 'T': X, U1, U2, V1T, and V2T are stored in row-major\n\ * order;\n\ * otherwise: X, U1, U2, V1T, and V2T are stored in column-\n\ * major order.\n\ *\n\ * SIGNS (input) CHARACTER\n\ * = 'O': The lower-left block is made nonpositive (the\n\ * \"other\" convention);\n\ * otherwise: The upper-right block is made nonpositive (the\n\ * \"default\" convention).\n\ *\n\ * M (input) INTEGER\n\ * The number of rows and columns in X.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows in X11 and X12. 0 <= P <= M.\n\ *\n\ * Q (input) INTEGER\n\ * The number of columns in X11 and X21. 0 <= Q <= M.\n\ *\n\ * X (input/workspace) DOUBLE PRECISION array, dimension (LDX,M)\n\ * On entry, the orthogonal matrix whose CSD is desired.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of X. LDX >= MAX(1,M).\n\ *\n\ * THETA (output) DOUBLE PRECISION array, dimension (R), in which R =\n\ * MIN(P,M-P,Q,M-Q).\n\ * C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and\n\ * S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).\n\ *\n\ * U1 (output) DOUBLE PRECISION array, dimension (P)\n\ * If JOBU1 = 'Y', U1 contains the P-by-P orthogonal matrix U1.\n\ *\n\ * LDU1 (input) INTEGER\n\ * The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=\n\ * MAX(1,P).\n\ *\n\ * U2 (output) DOUBLE PRECISION array, dimension (M-P)\n\ * If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) orthogonal\n\ * matrix U2.\n\ *\n\ * LDU2 (input) INTEGER\n\ * The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=\n\ * MAX(1,M-P).\n\ *\n\ * V1T (output) DOUBLE PRECISION array, dimension (Q)\n\ * If JOBV1T = 'Y', V1T contains the Q-by-Q matrix orthogonal\n\ * matrix V1**T.\n\ *\n\ * LDV1T (input) INTEGER\n\ * The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=\n\ * MAX(1,Q).\n\ *\n\ * V2T (output) DOUBLE PRECISION array, dimension (M-Q)\n\ * If JOBV2T = 'Y', V2T contains the (M-Q)-by-(M-Q) orthogonal\n\ * matrix V2**T.\n\ *\n\ * LDV2T (input) INTEGER\n\ * The leading dimension of V2T. If JOBV2T = 'Y', LDV2T >=\n\ * MAX(1,M-Q).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ * If INFO > 0 on exit, WORK(2:R) contains the values PHI(1),\n\ * ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),\n\ * define the matrix in intermediate bidiagonal-block form\n\ * remaining after nonconvergence. INFO specifies the number\n\ * of nonzero PHI's.\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK.\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\ * IWORK (workspace) INTEGER array, dimension (M-Q)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit.\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * > 0: DBBCSD did not converge. See the description of WORK\n\ * above for details.\n\ *\n\ * Reference\n\ * =========\n\ *\n\ * [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.\n\ * Algorithms, 50(1):33-65, 2009.\n\ *\n\n\ * ===================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgbequ0000644000175000017500000000754312502223526016516 0ustar uwabamiuwabami--- :name: zgbequ :md5sum: 96c7688bd118d8f4f184aa7107831370 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: doublecomplex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - r: :type: doublereal :intent: output :dims: - MAX(1,m) - c: :type: doublereal :intent: output :dims: - n - rowcnd: :type: doublereal :intent: output - colcnd: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGBEQU computes row and column scalings intended to equilibrate an\n\ * M-by-N band matrix A and reduce its condition number. R returns the\n\ * row scale factors and C the column scale factors, chosen to try to\n\ * make the largest element in each row and column of the matrix B with\n\ * elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n\ *\n\ * R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n\ * number and BIGNUM = largest safe number. Use of these scaling\n\ * factors is not guaranteed to reduce the condition number of A but\n\ * works well in practice.\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\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * AB (input) COMPLEX*16 array, dimension (LDAB,N)\n\ * The band matrix A, stored in rows 1 to KL+KU+1. The j-th\n\ * column of A is stored in the j-th column of the array AB as\n\ * follows:\n\ * AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * R (output) DOUBLE PRECISION array, dimension (M)\n\ * If INFO = 0, or INFO > M, R contains the row scale factors\n\ * for A.\n\ *\n\ * C (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, C contains the column scale factors for A.\n\ *\n\ * ROWCND (output) DOUBLE PRECISION\n\ * If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n\ * smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n\ * AMAX is neither too large nor too small, it is not worth\n\ * scaling by R.\n\ *\n\ * COLCND (output) DOUBLE PRECISION\n\ * If INFO = 0, COLCND contains the ratio of the smallest\n\ * C(i) to the largest C(i). If COLCND >= 0.1, it is not\n\ * worth scaling by C.\n\ *\n\ * AMAX (output) DOUBLE PRECISION\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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, and i is\n\ * <= M: the i-th row of A is exactly zero\n\ * > M: the (i-M)-th column of A is exactly zero\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgeqpf0000644000175000017500000000637012502223526016503 0ustar uwabamiuwabami--- :name: sgeqpf :md5sum: d0a540162c9e235819915865a59db357 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - jpvt: :type: integer :intent: input/output :dims: - n - tau: :type: real :intent: output :dims: - MIN(m,n) - work: :type: real :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This routine is deprecated and has been replaced by routine SGEQP3.\n\ *\n\ * SGEQPF computes a QR factorization with column pivoting of a\n\ * real M-by-N matrix A: A*P = Q*R.\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) REAL array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit, the upper triangle of the array contains the\n\ * min(M,N)-by-N upper triangular matrix R; the elements\n\ * below the diagonal, together with the array TAU,\n\ * represent the orthogonal matrix Q as a product of\n\ * min(m,n) elementary reflectors.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * JPVT (input/output) INTEGER array, dimension (N)\n\ * On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n\ * to the front of A*P (a leading column); if JPVT(i) = 0,\n\ * the i-th column of A is a free column.\n\ * On exit, if JPVT(i) = k, then the i-th column of A*P\n\ * was the k-th column of A.\n\ *\n\ * TAU (output) REAL array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors.\n\ *\n\ * WORK (workspace) REAL array, dimension (3*N)\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(1) H(2) . . . H(n)\n\ *\n\ * Each H(i) has the form\n\ *\n\ * H = 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:m) is stored on exit in A(i+1:m,i).\n\ *\n\ * The matrix P is represented in jpvt as follows: If\n\ * jpvt(j) = i\n\ * then the jth column of P is the ith canonical unit vector.\n\ *\n\ * Partial column norm updating strategy modified by\n\ * Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n\ * University of Zagreb, Croatia.\n\ * June 2010\n\ * For more details see LAPACK Working Note 176.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/clags20000644000175000017500000000625112502223525016366 0ustar uwabamiuwabami--- :name: clags2 :md5sum: dd5ce497c6159dda6d9710975dc6d15a :category: :subroutine :arguments: - upper: :type: logical :intent: input - a1: :type: real :intent: input - a2: :type: complex :intent: input - a3: :type: real :intent: input - b1: :type: real :intent: input - b2: :type: complex :intent: input - b3: :type: real :intent: input - csu: :type: real :intent: output - snu: :type: complex :intent: output - csv: :type: real :intent: output - snv: :type: complex :intent: output - csq: :type: real :intent: output - snq: :type: complex :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, SNV, CSQ, SNQ )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLAGS2 computes 2-by-2 unitary matrices U, V and Q, such\n\ * that if ( UPPER ) then\n\ *\n\ * U'*A*Q = U'*( A1 A2 )*Q = ( x 0 )\n\ * ( 0 A3 ) ( x x )\n\ * and\n\ * V'*B*Q = V'*( B1 B2 )*Q = ( x 0 )\n\ * ( 0 B3 ) ( x x )\n\ *\n\ * or if ( .NOT.UPPER ) then\n\ *\n\ * U'*A*Q = U'*( A1 0 )*Q = ( x x )\n\ * ( A2 A3 ) ( 0 x )\n\ * and\n\ * V'*B*Q = V'*( B1 0 )*Q = ( x x )\n\ * ( B2 B3 ) ( 0 x )\n\ * where\n\ *\n\ * U = ( CSU SNU ), V = ( CSV SNV ),\n\ * ( -CONJG(SNU) CSU ) ( -CONJG(SNV) CSV )\n\ *\n\ * Q = ( CSQ SNQ )\n\ * ( -CONJG(SNQ) CSQ )\n\ *\n\ * Z' denotes the conjugate transpose of Z.\n\ *\n\ * The rows of the transformed A and B are parallel. Moreover, if the\n\ * input 2-by-2 matrix A is not zero, then the transformed (1,1) entry\n\ * of A is not zero. If the input matrices A and B are both not zero,\n\ * then the transformed (2,2) element of B is not zero, except when the\n\ * first rows of input A and B are parallel and the second rows are\n\ * zero.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPPER (input) LOGICAL\n\ * = .TRUE.: the input matrices A and B are upper triangular.\n\ * = .FALSE.: the input matrices A and B are lower triangular.\n\ *\n\ * A1 (input) REAL\n\ * A2 (input) COMPLEX\n\ * A3 (input) REAL\n\ * On entry, A1, A2 and A3 are elements of the input 2-by-2\n\ * upper (lower) triangular matrix A.\n\ *\n\ * B1 (input) REAL\n\ * B2 (input) COMPLEX\n\ * B3 (input) REAL\n\ * On entry, B1, B2 and B3 are elements of the input 2-by-2\n\ * upper (lower) triangular matrix B.\n\ *\n\ * CSU (output) REAL\n\ * SNU (output) COMPLEX\n\ * The desired unitary matrix U.\n\ *\n\ * CSV (output) REAL\n\ * SNV (output) COMPLEX\n\ * The desired unitary matrix V.\n\ *\n\ * CSQ (output) REAL\n\ * SNQ (output) COMPLEX\n\ * The desired unitary matrix Q.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cptsv0000644000175000017500000000565512502223525016361 0ustar uwabamiuwabami--- :name: cptsv :md5sum: 51cb8a965fde05d2a1884508d277624f :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: complex :intent: input/output :dims: - n-1 - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPTSV( N, NRHS, D, E, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPTSV computes the solution to a complex system of linear equations\n\ * A*X = B, where A is an N-by-N Hermitian positive definite tridiagonal\n\ * matrix, and X and B are N-by-NRHS matrices.\n\ *\n\ * A is factored as A = L*D*L**H, and the factored form of A is then\n\ * used to solve the system of equations.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the n diagonal elements of the tridiagonal matrix\n\ * A. On exit, the n diagonal elements of the diagonal matrix\n\ * D from the factorization A = L*D*L**H.\n\ *\n\ * E (input/output) COMPLEX array, dimension (N-1)\n\ * On entry, the (n-1) subdiagonal elements of the tridiagonal\n\ * matrix A. On exit, the (n-1) subdiagonal elements of the\n\ * unit bidiagonal factor L from the L*D*L**H factorization of\n\ * A. E can also be regarded as the superdiagonal of the unit\n\ * bidiagonal factor U from the U**H*D*U factorization of A.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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 leading minor of order i is not\n\ * positive definite, and the solution has not been\n\ * computed. The factorization has not been completed\n\ * unless i = N.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. External Subroutines ..\n EXTERNAL CPTTRF, CPTTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sstev0000644000175000017500000000517312502223526016362 0ustar uwabamiuwabami--- :name: sstev :md5sum: 51a1acebfd740cd57ebd5d2033013bbe :category: :subroutine :arguments: - jobz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - n-1 - z: :type: real :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "lsame_(&jobz,\"N\") ? 0 : MAX(1,2*n-2)" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" :fortran_help: " SUBROUTINE SSTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SSTEV computes all eigenvalues and, optionally, eigenvectors of a\n\ * real symmetric tridiagonal matrix A.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the n diagonal elements of the tridiagonal matrix\n\ * A.\n\ * On exit, if INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * E (input/output) REAL array, dimension (N-1)\n\ * On entry, the (n-1) subdiagonal elements of the tridiagonal\n\ * matrix A, stored in elements 1 to N-1 of E.\n\ * On exit, the contents of E are destroyed.\n\ *\n\ * Z (output) REAL array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n\ * eigenvectors of the matrix A, with the i-th column of Z\n\ * holding the eigenvector associated with D(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) REAL array, dimension (max(1,2*N-2))\n\ * If JOBZ = 'N', WORK is not referenced.\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 algorithm failed to converge; i\n\ * off-diagonal elements of E did not converge to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlaset0000644000175000017500000000501212502223526016462 0ustar uwabamiuwabami--- :name: dlaset :md5sum: c2f6317581bca79e8eb4cd9e8db8f3c7 :category: :subroutine :arguments: - uplo: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - alpha: :type: doublereal :intent: input - beta: :type: doublereal :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLASET initializes an m-by-n matrix A to BETA on the diagonal and\n\ * ALPHA on the offdiagonals.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies the part of the matrix A to be set.\n\ * = 'U': Upper triangular part is set; the strictly lower\n\ * triangular part of A is not changed.\n\ * = 'L': Lower triangular part is set; the strictly upper\n\ * triangular part of A is not changed.\n\ * Otherwise: All of the matrix A is set.\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\ * ALPHA (input) DOUBLE PRECISION\n\ * The constant to which the offdiagonal elements are to be set.\n\ *\n\ * BETA (input) DOUBLE PRECISION\n\ * The constant to which the diagonal elements are to be set.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On exit, the leading m-by-n submatrix of A is set as follows:\n\ *\n\ * if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n,\n\ * if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n,\n\ * otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j,\n\ *\n\ * and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER I, J\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlaqsb0000644000175000017500000000646112502223526016465 0ustar uwabamiuwabami--- :name: dlaqsb :md5sum: c7dc33589acebc95caeb49a34f486200 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - s: :type: doublereal :intent: input :dims: - n - scond: :type: doublereal :intent: input - amax: :type: doublereal :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAQSB equilibrates a symmetric band matrix A using the scaling\n\ * factors in the vector S.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of super-diagonals of the matrix A if UPLO = 'U',\n\ * or the number of sub-diagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first KD+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * On exit, if INFO = 0, the triangular factor U or L from the\n\ * Cholesky factorization A = U'*U or A = L*L' of the band\n\ * matrix A, in the same storage format as A.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * S (input) DOUBLE PRECISION array, dimension (N)\n\ * The scale factors for A.\n\ *\n\ * SCOND (input) DOUBLE PRECISION\n\ * Ratio of the smallest S(i) to the largest S(i).\n\ *\n\ * AMAX (input) DOUBLE PRECISION\n\ * Absolute value of largest matrix entry.\n\ *\n\ * EQUED (output) CHARACTER*1\n\ * Specifies whether or not equilibration was done.\n\ * = 'N': No equilibration.\n\ * = 'Y': Equilibration was done, i.e., A has been replaced by\n\ * diag(S) * A * diag(S).\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * THRESH is a threshold value used to decide if scaling should be done\n\ * based on the ratio of the scaling factors. If SCOND < THRESH,\n\ * scaling is done.\n\ *\n\ * LARGE and SMALL are threshold values used to decide if scaling should\n\ * be done based on the absolute size of the largest matrix element.\n\ * If AMAX > LARGE or AMAX < SMALL, scaling is done.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slange0000644000175000017500000000467612502223526016476 0ustar uwabamiuwabami--- :name: slange :md5sum: da9734ebe746c544e9ebeed6a02e5f99 :category: :function :type: real :arguments: - norm: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - n - lda: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - MAX(1,lwork) :substitutions: lwork: "lsame_(&norm,\"I\") ? m : 0" :fortran_help: " REAL FUNCTION SLANGE( NORM, M, N, A, LDA, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLANGE returns the value of the one norm, or the Frobenius norm, or\n\ * the infinity norm, or the element of largest absolute value of a\n\ * real matrix A.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * SLANGE returns the value\n\ *\n\ * SLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n\ * (\n\ * ( norm1(A), NORM = '1', 'O' or 'o'\n\ * (\n\ * ( normI(A), NORM = 'I' or 'i'\n\ * (\n\ * ( normF(A), NORM = 'F', 'f', 'E' or 'e'\n\ *\n\ * where norm1 denotes the one norm of a matrix (maximum column sum),\n\ * normI denotes the infinity norm of a matrix (maximum row sum) and\n\ * normF denotes the Frobenius norm of a matrix (square root of sum of\n\ * squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies the value to be returned in SLANGE as described\n\ * above.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix A. M >= 0. When M = 0,\n\ * SLANGE is set to zero.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix A. N >= 0. When N = 0,\n\ * SLANGE is set to zero.\n\ *\n\ * A (input) REAL array, dimension (LDA,N)\n\ * The m by n matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(M,1).\n\ *\n\ * WORK (workspace) REAL array, dimension (MAX(1,LWORK)),\n\ * where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n\ * referenced.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zpttrs0000644000175000017500000000637512502223526016571 0ustar uwabamiuwabami--- :name: zpttrs :md5sum: ea4804bfafab003158ad8975579e6d8a :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublecomplex :intent: input :dims: - n-1 - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZPTTRS( UPLO, N, NRHS, D, E, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPTTRS solves a tridiagonal system of the form\n\ * A * X = B\n\ * using the factorization A = U'*D*U or A = L*D*L' computed by ZPTTRF.\n\ * D is a diagonal matrix specified in the vector D, U (or L) is a unit\n\ * bidiagonal matrix whose superdiagonal (subdiagonal) is specified in\n\ * the vector E, and X and B are N by NRHS matrices.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies the form of the factorization and whether the\n\ * vector E is the superdiagonal of the upper bidiagonal factor\n\ * U or the subdiagonal of the lower bidiagonal factor L.\n\ * = 'U': A = U'*D*U, E is the superdiagonal of U\n\ * = 'L': A = L*D*L', E is the subdiagonal of L\n\ *\n\ * N (input) INTEGER\n\ * The order of the tridiagonal matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The n diagonal elements of the diagonal matrix D from the\n\ * factorization A = U'*D*U or A = L*D*L'.\n\ *\n\ * E (input) COMPLEX*16 array, dimension (N-1)\n\ * If UPLO = 'U', the (n-1) superdiagonal elements of the unit\n\ * bidiagonal factor U from the factorization A = U'*D*U.\n\ * If UPLO = 'L', the (n-1) subdiagonal elements of the unit\n\ * bidiagonal factor L from the factorization A = L*D*L'.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the right hand side vectors B for the system of\n\ * linear equations.\n\ * On exit, the solution vectors, X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL UPPER\n INTEGER IUPLO, J, JB, NB\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZPTTS2\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dtzrzf0000644000175000017500000001023512502223526016534 0ustar uwabamiuwabami--- :name: dtzrzf :md5sum: 2407e3cc3aa3ddd54e3c67c69e211f95 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: output :dims: - m - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: m: lda :fortran_help: " SUBROUTINE DTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTZRZF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A\n\ * to upper triangular form by means of orthogonal transformations.\n\ *\n\ * The upper trapezoidal matrix A is factored as\n\ *\n\ * A = ( R 0 ) * Z,\n\ *\n\ * where Z is an N-by-N orthogonal matrix and R is an M-by-M upper\n\ * triangular matrix.\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 >= M.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the leading M-by-N upper trapezoidal part of the\n\ * array A must contain the matrix to be factorized.\n\ * On exit, the leading M-by-M upper triangular part of A\n\ * contains the upper triangular matrix R, and elements M+1 to\n\ * N of the first M rows of A, with the array TAU, represent the\n\ * orthogonal matrix Z as a product of M elementary reflectors.\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 (M)\n\ * The scalar factors of the elementary reflectors.\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\n\ * the 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\ * Based on contributions by\n\ * A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n\ *\n\ * The factorization is obtained by Householder's method. The kth\n\ * transformation matrix, Z( k ), which is used to introduce zeros into\n\ * the ( m - k + 1 )th row of A, is given in the form\n\ *\n\ * Z( k ) = ( I 0 ),\n\ * ( 0 T( k ) )\n\ *\n\ * where\n\ *\n\ * T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),\n\ * ( 0 )\n\ * ( z( k ) )\n\ *\n\ * tau is a scalar and z( k ) is an ( n - m ) element vector.\n\ * tau and z( k ) are chosen to annihilate the elements of the kth row\n\ * of X.\n\ *\n\ * The scalar tau is returned in the kth element of TAU and the vector\n\ * u( k ) in the kth row of A, such that the elements of z( k ) are\n\ * in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n\ * the upper triangular part of A.\n\ *\n\ * Z is given by\n\ *\n\ * Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dstev0000644000175000017500000000530312502223526016336 0ustar uwabamiuwabami--- :name: dstev :md5sum: 2f4d636a27f6e1a3441dbd47afa973cb :category: :subroutine :arguments: - jobz: :type: char :intent: input - n: :type: integer :intent: input - d: :type: doublereal :intent: input/output :dims: - n - e: :type: doublereal :intent: input/output :dims: - n-1 - z: :type: doublereal :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - "lsame_(&jobz,\"N\") ? 0 : MAX(1,2*n-2)" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" :fortran_help: " SUBROUTINE DSTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSTEV computes all eigenvalues and, optionally, eigenvectors of a\n\ * real symmetric tridiagonal matrix A.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N >= 0.\n\ *\n\ * D (input/output) DOUBLE PRECISION array, dimension (N)\n\ * On entry, the n diagonal elements of the tridiagonal matrix\n\ * A.\n\ * On exit, if INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * E (input/output) DOUBLE PRECISION array, dimension (N-1)\n\ * On entry, the (n-1) subdiagonal elements of the tridiagonal\n\ * matrix A, stored in elements 1 to N-1 of E.\n\ * On exit, the contents of E are destroyed.\n\ *\n\ * Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n\ * eigenvectors of the matrix A, with the i-th column of Z\n\ * holding the eigenvector associated with D(i).\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,N).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))\n\ * If JOBZ = 'N', WORK is not referenced.\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 algorithm failed to converge; i\n\ * off-diagonal elements of E did not converge to zero.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cpttrf0000644000175000017500000000373112502223525016515 0ustar uwabamiuwabami--- :name: cpttrf :md5sum: 3c95d303d2eee9086e51e0c7a963a9a6 :category: :subroutine :arguments: - n: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: complex :intent: input/output :dims: - n-1 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPTTRF( N, D, E, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPTTRF computes the L*D*L' factorization of a complex Hermitian\n\ * positive definite tridiagonal matrix A. The factorization may also\n\ * be regarded as having the form A = U'*D*U.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, the n diagonal elements of the tridiagonal matrix\n\ * A. On exit, the n diagonal elements of the diagonal matrix\n\ * D from the L*D*L' factorization of A.\n\ *\n\ * E (input/output) COMPLEX array, dimension (N-1)\n\ * On entry, the (n-1) subdiagonal elements of the tridiagonal\n\ * matrix A. On exit, the (n-1) subdiagonal elements of the\n\ * unit bidiagonal factor L from the L*D*L' factorization of A.\n\ * E can also be regarded as the superdiagonal of the unit\n\ * bidiagonal factor U from the U'*D*U factorization of A.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -k, the k-th argument had an illegal value\n\ * > 0: if INFO = k, the leading minor of order k is not\n\ * positive definite; if k < N, the factorization could not\n\ * be completed, while if k = N, the factorization was\n\ * completed, but D(N) <= 0.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slarfx0000644000175000017500000000453012502223526016511 0ustar uwabamiuwabami--- :name: slarfx :md5sum: b8357cd512a788dd72b74cc45e72bafe :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - v: :type: real :intent: input :dims: - m - tau: :type: real :intent: input - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " SUBROUTINE SLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLARFX applies a real elementary reflector H to a real m by n\n\ * matrix C, from either the left or the right. H is represented in the\n\ * form\n\ *\n\ * H = I - tau * v * v'\n\ *\n\ * where tau is a real scalar and v is a real vector.\n\ *\n\ * If tau = 0, then H is taken to be the unit matrix\n\ *\n\ * This version uses inline code if H has order < 11.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': form H * C\n\ * = 'R': form C * H\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C.\n\ *\n\ * V (input) REAL array, dimension (M) if SIDE = 'L'\n\ * or (N) if SIDE = 'R'\n\ * The vector v in the representation of H.\n\ *\n\ * TAU (input) REAL\n\ * The value tau in the representation of H.\n\ *\n\ * C (input/output) REAL array, dimension (LDC,N)\n\ * On entry, the m by n matrix C.\n\ * On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n\ * or C * H if SIDE = 'R'.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDA >= (1,M).\n\ *\n\ * WORK (workspace) REAL array, dimension\n\ * (N) if SIDE = 'L'\n\ * or (M) if SIDE = 'R'\n\ * WORK is not referenced if H has order < 11.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zspsvx0000644000175000017500000002267612502223526016602 0ustar uwabamiuwabami--- :name: zspsvx :md5sum: 9c40d411fd1ff7d129647eafdb7a0405 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - ap: :type: doublecomplex :intent: input :dims: - n*(n+1)/2 - afp: :type: doublecomplex :intent: input/output :dims: - n*(n+1)/2 - ipiv: :type: integer :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) :fortran_help: " SUBROUTINE ZSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZSPSVX uses the diagonal pivoting factorization A = U*D*U**T or\n\ * A = L*D*L**T to compute the solution to a complex system of linear\n\ * equations A * X = B, where A is an N-by-N symmetric matrix stored\n\ * in packed format and X and B are N-by-NRHS matrices.\n\ *\n\ * Error bounds on the solution and a condition estimate are also\n\ * provided.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'N', the diagonal pivoting method is used to factor A as\n\ * A = U * D * U**T, if UPLO = 'U', or\n\ * A = L * D * L**T, if UPLO = 'L',\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices and D is symmetric and block diagonal with\n\ * 1-by-1 and 2-by-2 diagonal blocks.\n\ *\n\ * 2. If some D(i,i)=0, so that D is exactly singular, then the routine\n\ * returns with INFO = i. Otherwise, the factored form of A is used\n\ * to estimate the condition number of the matrix A. If the\n\ * reciprocal of the condition number is less than machine precision,\n\ * INFO = N+1 is returned as a warning, but the routine still goes on\n\ * to solve for X and compute error bounds as described below.\n\ *\n\ * 3. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 4. Iterative refinement is applied to improve the computed solution\n\ * matrix and calculate error bounds and backward error estimates\n\ * for it.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of A has been\n\ * supplied on entry.\n\ * = 'F': On entry, AFP and IPIV contain the factored form\n\ * of A. AP, AFP and IPIV will not be modified.\n\ * = 'N': The matrix A will be copied to AFP and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AP (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * The upper or lower triangle of the symmetric matrix A, packed\n\ * columnwise in a linear array. The j-th column of A is stored\n\ * in the array AP as follows:\n\ * if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n\ * if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n\ * See below for further details.\n\ *\n\ * AFP (input or output) COMPLEX*16 array, dimension (N*(N+1)/2)\n\ * If FACT = 'F', then AFP is an input argument and on entry\n\ * contains the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L from the factorization\n\ * A = U*D*U**T or A = L*D*L**T as computed by ZSPTRF, stored as\n\ * a packed triangular matrix in the same storage format as A.\n\ *\n\ * If FACT = 'N', then AFP is an output argument and on exit\n\ * contains the block diagonal matrix D and the multipliers used\n\ * to obtain the factor U or L from the factorization\n\ * A = U*D*U**T or A = L*D*L**T as computed by ZSPTRF, stored as\n\ * a packed triangular matrix in the same storage format as A.\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains details of the interchanges and the block structure\n\ * of D, as determined by ZSPTRF.\n\ * If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n\ * interchanged and D(k,k) is a 1-by-1 diagonal block.\n\ * If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n\ * columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n\ * is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =\n\ * IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n\ * interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains details of the interchanges and the block structure\n\ * of D, as determined by ZSPTRF.\n\ *\n\ * B (input) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * The N-by-NRHS right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The estimate of the reciprocal condition number of the matrix\n\ * A. If RCOND is less than the machine precision (in\n\ * particular, if RCOND = 0), the matrix is singular to working\n\ * precision. This condition is indicated by a return code of\n\ * INFO > 0.\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The estimated forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j). The estimate is as reliable as\n\ * the estimate for RCOND, and is almost always a slight\n\ * overestimate of the true error.\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (2*N)\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\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, and i is\n\ * <= N: D(i,i) is exactly zero. The factorization\n\ * has been completed but the factor D is exactly\n\ * singular, so the solution and error bounds could\n\ * not be computed. RCOND = 0 is returned.\n\ * = N+1: D is nonsingular, but RCOND is less than machine\n\ * precision, meaning that the matrix is singular\n\ * to working precision. Nevertheless, the\n\ * solution and error bounds are computed because\n\ * there are a number of situations where the\n\ * computed solution can be more accurate than the\n\ * value of RCOND would suggest.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * The packed storage scheme is illustrated by the following example\n\ * when N = 4, UPLO = 'U':\n\ *\n\ * Two-dimensional storage of the symmetric matrix A:\n\ *\n\ * a11 a12 a13 a14\n\ * a22 a23 a24\n\ * a33 a34 (aij = aji)\n\ * a44\n\ *\n\ * Packed storage of the upper triangle of A:\n\ *\n\ * AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/csymv0000644000175000017500000001006212502223525016347 0ustar uwabamiuwabami--- :name: csymv :md5sum: 28f107317aaa4462049422975308edee :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - alpha: :type: complex :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - x: :type: complex :intent: input :dims: - 1 + ( n - 1 )*abs( incx ) - incx: :type: integer :intent: input - beta: :type: complex :intent: input - y: :type: complex :intent: input/output :dims: - 1 + ( n - 1 )*abs( incy ) - incy: :type: integer :intent: input :substitutions: {} :fortran_help: " SUBROUTINE CSYMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CSYMV performs the matrix-vector operation\n\ *\n\ * y := alpha*A*x + beta*y,\n\ *\n\ * where alpha and beta are scalars, x and y are n element vectors and\n\ * A is an n by n symmetric matrix.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * On entry, UPLO specifies whether the upper or lower\n\ * triangular part of the array A is to be referenced as\n\ * follows:\n\ *\n\ * UPLO = 'U' or 'u' Only the upper triangular part of A\n\ * is to be referenced.\n\ *\n\ * UPLO = 'L' or 'l' Only the lower triangular part of A\n\ * is to be referenced.\n\ *\n\ * Unchanged on exit.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the order of the matrix A.\n\ * N must be at least zero.\n\ * Unchanged on exit.\n\ *\n\ * ALPHA (input) COMPLEX\n\ * On entry, ALPHA specifies the scalar alpha.\n\ * Unchanged on exit.\n\ *\n\ * A (input) COMPLEX array, dimension ( LDA, N )\n\ * Before entry, with UPLO = 'U' or 'u', the leading n by n\n\ * upper triangular part of the array A must contain the upper\n\ * triangular part of the symmetric matrix and the strictly\n\ * lower triangular part of A is not referenced.\n\ * Before entry, with UPLO = 'L' or 'l', the leading n by n\n\ * lower triangular part of the array A must contain the lower\n\ * triangular part of the symmetric matrix and the strictly\n\ * upper triangular part of A is not referenced.\n\ * Unchanged on exit.\n\ *\n\ * LDA (input) INTEGER\n\ * On entry, LDA specifies the first dimension of A as declared\n\ * in the calling (sub) program. LDA must be at least\n\ * max( 1, N ).\n\ * Unchanged on exit.\n\ *\n\ * X (input) COMPLEX array, dimension at least\n\ * ( 1 + ( N - 1 )*abs( INCX ) ).\n\ * Before entry, the incremented array X must contain the N-\n\ * element vector x.\n\ * Unchanged on exit.\n\ *\n\ * INCX (input) INTEGER\n\ * On entry, INCX specifies the increment for the elements of\n\ * X. INCX must not be zero.\n\ * Unchanged on exit.\n\ *\n\ * BETA (input) COMPLEX\n\ * On entry, BETA specifies the scalar beta. When BETA is\n\ * supplied as zero then Y need not be set on input.\n\ * Unchanged on exit.\n\ *\n\ * Y (input/output) COMPLEX array, dimension at least\n\ * ( 1 + ( N - 1 )*abs( INCY ) ).\n\ * Before entry, the incremented array Y must contain the n\n\ * element vector y. On exit, Y is overwritten by the updated\n\ * vector y.\n\ *\n\ * INCY (input) INTEGER\n\ * On entry, INCY specifies the increment for the elements of\n\ * Y. INCY must not be zero.\n\ * Unchanged on exit.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctftri0000644000175000017500000001546112502223525016511 0ustar uwabamiuwabami--- :name: ctftri :md5sum: a5ecbd1b6b84ce5c5fe2fc099ead92f8 :category: :subroutine :arguments: - transr: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - n*(n+1)/2 - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CTFTRI( TRANSR, UPLO, DIAG, N, A, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTFTRI computes the inverse of a triangular matrix A stored in RFP\n\ * format.\n\ *\n\ * This is a Level 3 BLAS version of the algorithm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANSR (input) CHARACTER*1\n\ * = 'N': The Normal TRANSR of RFP A is stored;\n\ * = 'C': The Conjugate-transpose TRANSR of RFP A is stored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) COMPLEX array, dimension ( N*(N+1)/2 );\n\ * On entry, the triangular matrix A in RFP format. RFP format\n\ * is described by TRANSR, UPLO, and N as follows: If TRANSR =\n\ * 'N' then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n\ * (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is\n\ * the Conjugate-transpose of RFP A as defined when\n\ * TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n\ * follows: If UPLO = 'U' the RFP A contains the nt elements of\n\ * upper packed A; If UPLO = 'L' the RFP A contains the nt\n\ * elements of lower packed A. The LDA of RFP A is (N+1)/2 when\n\ * TRANSR = 'C'. When TRANSR is 'N' the LDA is N+1 when N is\n\ * even and N is odd. See the Note below for more details.\n\ *\n\ * On exit, the (triangular) inverse of the original matrix, in\n\ * the same storage format.\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, A(i,i) is exactly zero. The triangular\n\ * matrix is singular and its inverse can not be computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * We first consider Standard Packed Format when N is even.\n\ * We give an example where N = 6.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 05 00\n\ * 11 12 13 14 15 10 11\n\ * 22 23 24 25 20 21 22\n\ * 33 34 35 30 31 32 33\n\ * 44 45 40 41 42 43 44\n\ * 55 50 51 52 53 54 55\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n\ * conjugate-transpose of the first three columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n\ * conjugate-transpose of the last three columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N even and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- --\n\ * 03 04 05 33 43 53\n\ * -- --\n\ * 13 14 15 00 44 54\n\ * --\n\ * 23 24 25 10 11 55\n\ *\n\ * 33 34 35 20 21 22\n\ * --\n\ * 00 44 45 30 31 32\n\ * -- --\n\ * 01 11 55 40 41 42\n\ * -- -- --\n\ * 02 12 22 50 51 52\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 00 01 02 33 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 11 12 43 44 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- -- --\n\ * 05 15 25 35 45 55 22 53 54 55 22 32 42 52\n\ *\n\ *\n\ * We next consider Standard Packed Format when N is odd.\n\ * We give an example where N = 5.\n\ *\n\ * AP is Upper AP is Lower\n\ *\n\ * 00 01 02 03 04 00\n\ * 11 12 13 14 10 11\n\ * 22 23 24 20 21 22\n\ * 33 34 30 31 32 33\n\ * 44 40 41 42 43 44\n\ *\n\ *\n\ * Let TRANSR = 'N'. RFP holds AP as follows:\n\ * For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n\ * three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n\ * conjugate-transpose of the first two columns of AP upper.\n\ * For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n\ * three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n\ * conjugate-transpose of the last two columns of AP lower.\n\ * To denote conjugate we place -- above the element. This covers the\n\ * case N odd and TRANSR = 'N'.\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- --\n\ * 02 03 04 00 33 43\n\ * --\n\ * 12 13 14 10 11 44\n\ *\n\ * 22 23 24 20 21 22\n\ * --\n\ * 00 33 34 30 31 32\n\ * -- --\n\ * 01 11 44 40 41 42\n\ *\n\ * Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n\ * transpose of RFP A above. One therefore gets:\n\ *\n\ *\n\ * RFP A RFP A\n\ *\n\ * -- -- -- -- -- -- -- -- --\n\ * 02 12 22 00 01 00 10 20 30 40 50\n\ * -- -- -- -- -- -- -- -- --\n\ * 03 13 23 33 11 33 11 21 31 41 51\n\ * -- -- -- -- -- -- -- -- --\n\ * 04 14 24 34 44 43 44 22 32 42 52\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sorghr0000644000175000017500000000557412502223526016527 0ustar uwabamiuwabami--- :name: sorghr :md5sum: 15d5df3b0bf735669e7d3581fa3c5dcb :category: :subroutine :arguments: - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - n-1 - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: ihi-ilo - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SORGHR generates a real orthogonal matrix Q which is defined as the\n\ * product of IHI-ILO elementary reflectors of order N, as returned by\n\ * SGEHRD:\n\ *\n\ * Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix Q. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * ILO and IHI must have the same values as in the previous call\n\ * of SGEHRD. Q is equal to the unit matrix except in the\n\ * submatrix Q(ilo+1:ihi,ilo+1:ihi).\n\ * 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the vectors which define the elementary reflectors,\n\ * as returned by SGEHRD.\n\ * On exit, the N-by-N orthogonal matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * TAU (input) REAL array, dimension (N-1)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by SGEHRD.\n\ *\n\ * WORK (workspace/output) REAL 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 >= IHI-ILO.\n\ * For optimum performance LWORK >= (IHI-ILO)*NB, where NB is\n\ * the 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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dpotrs0000644000175000017500000000422412502223526016525 0ustar uwabamiuwabami--- :name: dpotrs :md5sum: d5099d9bfdde3ecc9937572a960308cb :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPOTRS solves a system of linear equations A*X = B with a symmetric\n\ * positive definite matrix A using the Cholesky factorization\n\ * A = U**T*U or A = L*L**T computed by DPOTRF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T, as computed by DPOTRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dla_lin_berr0000644000175000017500000000473212502223526017632 0ustar uwabamiuwabami--- :name: dla_lin_berr :md5sum: 3661649ee822d0355f02d5b222d14624 :category: :subroutine :arguments: - n: :type: integer :intent: input - nz: :type: integer :intent: input - nrhs: :type: integer :intent: input - res: :type: doublereal :intent: input :dims: - n - nrhs - ayb: :type: doublereal :intent: input :dims: - n - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs :substitutions: {} :fortran_help: " SUBROUTINE DLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLA_LIN_BERR computes component-wise relative backward error from\n\ * the formula\n\ * max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n\ * where abs(Z) is the component-wise absolute value of the matrix\n\ * or vector Z.\n\ *\n\n\ * Arguments\n\ * ==========\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NZ (input) INTEGER\n\ * We add (NZ+1)*SLAMCH( 'Safe minimum' ) to R(i) in the numerator to\n\ * guard against spuriously zero residuals. Default value is N.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices AYB, RES, and BERR. NRHS >= 0.\n\ *\n\ * RES (input) DOUBLE PRECISION array, dimension (N,NRHS)\n\ * The residual matrix, i.e., the matrix R in the relative backward\n\ * error formula above.\n\ *\n\ * AYB (input) DOUBLE PRECISION array, dimension (N, NRHS)\n\ * The denominator in the relative backward error formula above, i.e.,\n\ * the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B\n\ * are from iterative refinement (see dla_gerfsx_extended.f).\n\ * \n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The component-wise relative backward error from the formula above.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n DOUBLE PRECISION TMP\n INTEGER I, J\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX\n\ * ..\n\ * .. External Functions ..\n EXTERNAL DLAMCH\n DOUBLE PRECISION DLAMCH\n DOUBLE PRECISION SAFE1\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zhesv0000644000175000017500000001273212502223526016354 0ustar uwabamiuwabami--- :name: zhesv :md5sum: e745a4fbd2863ca527128103dc22130f :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - ipiv: :type: integer :intent: output :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZHESV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZHESV computes the solution to a complex system of linear equations\n\ * A * X = B,\n\ * where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS\n\ * matrices.\n\ *\n\ * The diagonal pivoting method is used to factor A as\n\ * A = U * D * U**H, if UPLO = 'U', or\n\ * A = L * D * L**H, if UPLO = 'L',\n\ * where U (or L) is a product of permutation and unit upper (lower)\n\ * triangular matrices, and D is Hermitian and block diagonal with\n\ * 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then\n\ * used to solve the system of equations A * X = B.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the Hermitian matrix A. If UPLO = 'U', the leading\n\ * N-by-N upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading N-by-N lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if INFO = 0, the block diagonal matrix D and the\n\ * multipliers used to obtain the factor U or L from the\n\ * factorization A = U*D*U**H or A = L*D*L**H as computed by\n\ * ZHETRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * IPIV (output) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D, as\n\ * determined by ZHETRF. If IPIV(k) > 0, then rows and columns\n\ * k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n\ * diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n\ * then rows and columns k-1 and -IPIV(k) were interchanged and\n\ * D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and\n\ * IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n\ * -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n\ * diagonal block.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * WORK (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n\ * On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n\ *\n\ * LWORK (input) INTEGER\n\ * The length of WORK. LWORK >= 1, and for best performance\n\ * LWORK >= max(1,N*NB), where NB is the optimal blocksize for\n\ * ZHETRF.\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, D(i,i) is exactly zero. The factorization\n\ * has been completed, but the block diagonal matrix D is\n\ * exactly singular, so the solution could not be computed.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER LWKOPT, NB\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL LSAME, ILAENV\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL XERBLA, ZHETRF, ZHETRS2\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/iladiag0000644000175000017500000000164212502223526016605 0ustar uwabamiuwabami--- :name: iladiag :md5sum: dc4a24ef58c1ee18a364cb9ea175b8b2 :category: :function :type: integer :arguments: - diag: :type: char :intent: input :substitutions: {} :fortran_help: " INTEGER FUNCTION ILADIAG( DIAG )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This subroutine translated from a character string specifying if a\n\ * matrix has unit diagonal or not to the relevant BLAST-specified\n\ * integer constant.\n\ *\n\ * ILADIAG returns an INTEGER. If ILADIAG < 0, then the input is not a\n\ * character indicating a unit or non-unit diagonal. Otherwise ILADIAG\n\ * returns the constant value corresponding to DIAG.\n\ *\n\n\ * Arguments\n\ * =========\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cla_wwaddw0000644000175000017500000000260612502223525017327 0ustar uwabamiuwabami--- :name: cla_wwaddw :md5sum: e6fda1b93199f58e559cbd022af359dc :category: :subroutine :arguments: - n: :type: integer :intent: input - x: :type: complex :intent: input/output :dims: - n - y: :type: complex :intent: input/output :dims: - n - w: :type: complex :intent: input :dims: - n :substitutions: {} :fortran_help: " SUBROUTINE CLA_WWADDW( N, X, Y, W )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CLA_WWADDW adds a vector W into a doubled-single vector (X, Y).\n\ *\n\ * This works for all extant IBM's hex and binary floating point\n\ * arithmetics, but not for decimal.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The length of vectors X, Y, and W.\n\ *\n\ * X (input/output) COMPLEX array, dimension (N)\n\ * The first part of the doubled-single accumulation vector.\n\ *\n\ * Y (input/output) COMPLEX array, dimension (N)\n\ * The second part of the doubled-single accumulation vector.\n\ *\n\ * W (input) COMPLEX array, dimension (N)\n\ * The vector to be added.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n COMPLEX S\n INTEGER I\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/sormhr0000644000175000017500000001215412502223526016525 0ustar uwabamiuwabami--- :name: sormhr :md5sum: 28091a9f0628e186adcb28eac6dffe34 :category: :subroutine :arguments: - side: :type: char :intent: input - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - ilo: :type: integer :intent: input - ihi: :type: integer :intent: input - a: :type: real :intent: input :dims: - lda - m - lda: :type: integer :intent: input - tau: :type: real :intent: input :dims: - m-1 - c: :type: real :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SORMHR overwrites the general real M-by-N matrix C with\n\ *\n\ * SIDE = 'L' SIDE = 'R'\n\ * TRANS = 'N': Q * C C * Q\n\ * TRANS = 'T': Q**T * C C * Q**T\n\ *\n\ * where Q is a real orthogonal matrix of order nq, with nq = m if\n\ * SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of\n\ * IHI-ILO elementary reflectors, as returned by SGEHRD:\n\ *\n\ * Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': apply Q or Q**T from the Left;\n\ * = 'R': apply Q or Q**T from the Right.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * = 'N': No transpose, apply Q;\n\ * = 'T': Transpose, apply Q**T.\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C. N >= 0.\n\ *\n\ * ILO (input) INTEGER\n\ * IHI (input) INTEGER\n\ * ILO and IHI must have the same values as in the previous call\n\ * of SGEHRD. Q is equal to the unit matrix except in the\n\ * submatrix Q(ilo+1:ihi,ilo+1:ihi).\n\ * If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and\n\ * ILO = 1 and IHI = 0, if M = 0;\n\ * if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and\n\ * ILO = 1 and IHI = 0, if N = 0.\n\ *\n\ * A (input) REAL array, dimension\n\ * (LDA,M) if SIDE = 'L'\n\ * (LDA,N) if SIDE = 'R'\n\ * The vectors which define the elementary reflectors, as\n\ * returned by SGEHRD.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A.\n\ * LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n\ *\n\ * TAU (input) REAL array, dimension\n\ * (M-1) if SIDE = 'L'\n\ * (N-1) if SIDE = 'R'\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by SGEHRD.\n\ *\n\ * C (input/output) REAL array, dimension (LDC,N)\n\ * On entry, the M-by-N matrix C.\n\ * On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace/output) REAL 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\ * If SIDE = 'L', LWORK >= max(1,N);\n\ * if SIDE = 'R', LWORK >= max(1,M).\n\ * For optimum performance LWORK >= N*NB if SIDE = 'L', and\n\ * LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n\ * 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\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LEFT, LQUERY\n INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n INTEGER ILAENV\n EXTERNAL ILAENV, LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SORMQR, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/zunbdb0000644000175000017500000002157512502223526016506 0ustar uwabamiuwabami--- :name: zunbdb :md5sum: d974370cb07cbf7b36573d0df6d5be03 :category: :subroutine :arguments: - trans: :type: char :intent: input - signs: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - q: :type: integer :intent: input - x11: :type: doublecomplex :intent: input/output :dims: - ldx11 - q - ldx11: :type: integer :intent: input - x12: :type: doublecomplex :intent: input/output :dims: - ldx12 - m-q - ldx12: :type: integer :intent: input - x21: :type: doublecomplex :intent: input/output :dims: - ldx21 - q - ldx21: :type: integer :intent: input - x22: :type: doublecomplex :intent: input/output :dims: - ldx22 - m-q - ldx22: :type: integer :intent: input - theta: :type: doublereal :intent: output :dims: - q - phi: :type: doublereal :intent: output :dims: - q-1 - taup1: :type: doublecomplex :intent: output :dims: - p - taup2: :type: doublecomplex :intent: output :dims: - m-p - tauq1: :type: doublecomplex :intent: output :dims: - q - tauq2: :type: doublecomplex :intent: output :dims: - m-q - work: :type: doublecomplex :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m-q - info: :type: integer :intent: output :substitutions: p: ldx11 ldx12: p ldx21: p ldx22: p :fortran_help: " SUBROUTINE ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZUNBDB simultaneously bidiagonalizes the blocks of an M-by-M\n\ * partitioned unitary matrix X:\n\ *\n\ * [ B11 | B12 0 0 ]\n\ * [ X11 | X12 ] [ P1 | ] [ 0 | 0 -I 0 ] [ Q1 | ]**H\n\ * X = [-----------] = [---------] [----------------] [---------] .\n\ * [ X21 | X22 ] [ | P2 ] [ B21 | B22 0 0 ] [ | Q2 ]\n\ * [ 0 | 0 0 I ]\n\ *\n\ * X11 is P-by-Q. Q must be no larger than P, M-P, or M-Q. (If this is\n\ * not the case, then X must be transposed and/or permuted. This can be\n\ * done in constant time using the TRANS and SIGNS options. See ZUNCSD\n\ * for details.)\n\ *\n\ * The unitary matrices P1, P2, Q1, and Q2 are P-by-P, (M-P)-by-\n\ * (M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. They are\n\ * represented implicitly by Householder vectors.\n\ *\n\ * B11, B12, B21, and B22 are Q-by-Q bidiagonal matrices represented\n\ * implicitly by angles THETA, PHI.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * TRANS (input) CHARACTER\n\ * = 'T': X, U1, U2, V1T, and V2T are stored in row-major\n\ * order;\n\ * otherwise: X, U1, U2, V1T, and V2T are stored in column-\n\ * major order.\n\ *\n\ * SIGNS (input) CHARACTER\n\ * = 'O': The lower-left block is made nonpositive (the\n\ * \"other\" convention);\n\ * otherwise: The upper-right block is made nonpositive (the\n\ * \"default\" convention).\n\ *\n\ * M (input) INTEGER\n\ * The number of rows and columns in X.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows in X11 and X12. 0 <= P <= M.\n\ *\n\ * Q (input) INTEGER\n\ * The number of columns in X11 and X21. 0 <= Q <=\n\ * MIN(P,M-P,M-Q).\n\ *\n\ * X11 (input/output) COMPLEX*16 array, dimension (LDX11,Q)\n\ * On entry, the top-left block of the unitary matrix to be\n\ * reduced. On exit, the form depends on TRANS:\n\ * If TRANS = 'N', then\n\ * the columns of tril(X11) specify reflectors for P1,\n\ * the rows of triu(X11,1) specify reflectors for Q1;\n\ * else TRANS = 'T', and\n\ * the rows of triu(X11) specify reflectors for P1,\n\ * the columns of tril(X11,-1) specify reflectors for Q1.\n\ *\n\ * LDX11 (input) INTEGER\n\ * The leading dimension of X11. If TRANS = 'N', then LDX11 >=\n\ * P; else LDX11 >= Q.\n\ *\n\ * X12 (input/output) COMPLEX*16 array, dimension (LDX12,M-Q)\n\ * On entry, the top-right block of the unitary matrix to\n\ * be reduced. On exit, the form depends on TRANS:\n\ * If TRANS = 'N', then\n\ * the rows of triu(X12) specify the first P reflectors for\n\ * Q2;\n\ * else TRANS = 'T', and\n\ * the columns of tril(X12) specify the first P reflectors\n\ * for Q2.\n\ *\n\ * LDX12 (input) INTEGER\n\ * The leading dimension of X12. If TRANS = 'N', then LDX12 >=\n\ * P; else LDX11 >= M-Q.\n\ *\n\ * X21 (input/output) COMPLEX*16 array, dimension (LDX21,Q)\n\ * On entry, the bottom-left block of the unitary matrix to\n\ * be reduced. On exit, the form depends on TRANS:\n\ * If TRANS = 'N', then\n\ * the columns of tril(X21) specify reflectors for P2;\n\ * else TRANS = 'T', and\n\ * the rows of triu(X21) specify reflectors for P2.\n\ *\n\ * LDX21 (input) INTEGER\n\ * The leading dimension of X21. If TRANS = 'N', then LDX21 >=\n\ * M-P; else LDX21 >= Q.\n\ *\n\ * X22 (input/output) COMPLEX*16 array, dimension (LDX22,M-Q)\n\ * On entry, the bottom-right block of the unitary matrix to\n\ * be reduced. On exit, the form depends on TRANS:\n\ * If TRANS = 'N', then\n\ * the rows of triu(X22(Q+1:M-P,P+1:M-Q)) specify the last\n\ * M-P-Q reflectors for Q2,\n\ * else TRANS = 'T', and\n\ * the columns of tril(X22(P+1:M-Q,Q+1:M-P)) specify the last\n\ * M-P-Q reflectors for P2.\n\ *\n\ * LDX22 (input) INTEGER\n\ * The leading dimension of X22. If TRANS = 'N', then LDX22 >=\n\ * M-P; else LDX22 >= M-Q.\n\ *\n\ * THETA (output) DOUBLE PRECISION array, dimension (Q)\n\ * The entries of the bidiagonal blocks B11, B12, B21, B22 can\n\ * be computed from the angles THETA and PHI. See Further\n\ * Details.\n\ *\n\ * PHI (output) DOUBLE PRECISION array, dimension (Q-1)\n\ * The entries of the bidiagonal blocks B11, B12, B21, B22 can\n\ * be computed from the angles THETA and PHI. See Further\n\ * Details.\n\ *\n\ * TAUP1 (output) COMPLEX*16 array, dimension (P)\n\ * The scalar factors of the elementary reflectors that define\n\ * P1.\n\ *\n\ * TAUP2 (output) COMPLEX*16 array, dimension (M-P)\n\ * The scalar factors of the elementary reflectors that define\n\ * P2.\n\ *\n\ * TAUQ1 (output) COMPLEX*16 array, dimension (Q)\n\ * The scalar factors of the elementary reflectors that define\n\ * Q1.\n\ *\n\ * TAUQ2 (output) COMPLEX*16 array, dimension (M-Q)\n\ * The scalar factors of the elementary reflectors that define\n\ * Q2.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (LWORK)\n\ *\n\ * LWORK (input) INTEGER\n\ * The dimension of the array WORK. LWORK >= M-Q.\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 bidiagonal blocks B11, B12, B21, and B22 are represented\n\ * implicitly by angles THETA(1), ..., THETA(Q) and PHI(1), ...,\n\ * PHI(Q-1). B11 and B21 are upper bidiagonal, while B21 and B22 are\n\ * lower bidiagonal. Every entry in each bidiagonal band is a product\n\ * of a sine or cosine of a THETA with a sine or cosine of a PHI. See\n\ * [1] or ZUNCSD for details.\n\ *\n\ * P1, P2, Q1, and Q2 are represented as products of elementary\n\ * reflectors. See ZUNCSD for details on generating P1, P2, Q1, and Q2\n\ * using ZUNGQR and ZUNGLQ.\n\ *\n\ * Reference\n\ * =========\n\ *\n\ * [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.\n\ * Algorithms, 50(1):33-65, 2009.\n\ *\n\ * ====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zposvxx0000644000175000017500000005057212502223526016762 0ustar uwabamiuwabami--- :name: zposvxx :md5sum: 9520bbcc218f403f56ee61a9968ac608 :category: :subroutine :arguments: - fact: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input/output :dims: - ldaf - n - ldaf: :type: integer :intent: input - equed: :type: char :intent: input/output - s: :type: doublereal :intent: input/output :dims: - n - b: :type: doublecomplex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublecomplex :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: doublereal :intent: output - rpvgrw: :type: doublereal :intent: output - berr: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: doublereal :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: doublereal :intent: input/output :dims: - nparams - work: :type: doublecomplex :intent: workspace :dims: - 2*n - rwork: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " SUBROUTINE ZPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T\n\ * to compute the solution to a complex*16 system of linear equations\n\ * A * X = B, where A is an N-by-N symmetric positive definite matrix\n\ * and X and B are N-by-NRHS matrices.\n\ *\n\ * If requested, both normwise and maximum componentwise error bounds\n\ * are returned. ZPOSVXX will return a solution with a tiny\n\ * guaranteed error (O(eps) where eps is the working machine\n\ * precision) unless the matrix is very ill-conditioned, in which\n\ * case a warning is returned. Relevant condition numbers also are\n\ * calculated and returned.\n\ *\n\ * ZPOSVXX accepts user-provided factorizations and equilibration\n\ * factors; see the definitions of the FACT and EQUED options.\n\ * Solving with refinement and using a factorization from a previous\n\ * ZPOSVXX call will also produce a solution with either O(eps)\n\ * errors or warnings, but we cannot make that claim for general\n\ * user-provided factorizations and equilibration factors if they\n\ * differ from what ZPOSVXX would itself produce.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n\ * the system:\n\ *\n\ * diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B\n\ *\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n\ *\n\ * 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n\ * factor the matrix A (after equilibration if FACT = 'E') as\n\ * A = U**T* U, if UPLO = 'U', or\n\ * A = L * L**T, if UPLO = 'L',\n\ * where U is an upper triangular matrix and L is a lower triangular\n\ * matrix.\n\ *\n\ * 3. If the leading i-by-i principal minor is not positive definite,\n\ * then the routine returns with INFO = i. Otherwise, the factored\n\ * form of A is used to estimate the condition number of the matrix\n\ * A (see argument RCOND). If the reciprocal of the condition number\n\ * is less than machine precision, the routine still goes on to solve\n\ * for X and compute error bounds as described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n\ * the routine will use iterative refinement to try to get a small\n\ * error and error bounds. Refinement calculates the residual to at\n\ * least twice the working precision.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(S) so that it solves the original system before\n\ * equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AF contains the factored form of A.\n\ * If EQUED is not 'N', the matrix A has been\n\ * equilibrated with scaling factors given by S.\n\ * A and AF are not modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AF and factored.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A, except if FACT = 'F' and EQUED =\n\ * 'Y', then A must contain the equilibrated matrix\n\ * diag(S)*A*diag(S). If UPLO = 'U', the leading N-by-N upper\n\ * triangular part of A contains the upper triangular part of the\n\ * matrix A, and the strictly lower triangular part of A is not\n\ * referenced. If UPLO = 'L', the leading N-by-N lower triangular\n\ * part of A contains the lower triangular part of the matrix A, and\n\ * the strictly upper triangular part of A is not referenced. A is\n\ * not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED =\n\ * 'N' on exit.\n\ *\n\ * On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n\ * diag(S)*A*diag(S).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input or output) COMPLEX*16 array, dimension (LDAF,N)\n\ * If FACT = 'F', then AF is an input argument and on entry\n\ * contains the triangular factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T, in the same storage\n\ * format as A. If EQUED .ne. 'N', then AF is the factored\n\ * form of the equilibrated matrix diag(S)*A*diag(S).\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T of the original\n\ * matrix A.\n\ *\n\ * If FACT = 'E', then AF is an output argument and on exit\n\ * returns the triangular factor U or L from the Cholesky\n\ * factorization A = U**T*U or A = L*L**T of the equilibrated\n\ * matrix A (see the description of A for the form of the\n\ * equilibrated matrix).\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'Y': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(S) * A * diag(S).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * S (input or output) DOUBLE PRECISION array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'Y', A is multiplied on\n\ * the left and right by diag(S). S is an input argument if FACT =\n\ * 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED\n\ * = 'Y', each element of S must be positive. If S is output, each\n\ * element of S is a power of the radix. If S is input, each element\n\ * of S should be a power of the radix to ensure a reliable solution\n\ * and error estimates. Scaling by powers of the radix does not cause\n\ * rounding errors unless the result underflows or overflows.\n\ * Rounding errors during scaling lead to refining with a matrix that\n\ * is not equivalent to the input matrix, producing error estimates\n\ * that may not be reliable.\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit,\n\ * if EQUED = 'N', B is not modified;\n\ * if EQUED = 'Y', B is overwritten by diag(S)*B;\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) COMPLEX*16 array, dimension (LDX,NRHS)\n\ * If INFO = 0, the N-by-NRHS solution matrix X to the original\n\ * system of equations. Note that A and B are modified on exit if\n\ * EQUED .ne. 'N', and the solution to the equilibrated system is\n\ * inv(diag(S))*X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * RPVGRW (output) DOUBLE PRECISION\n\ * Reciprocal pivot growth. On exit, this contains the reciprocal\n\ * pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n\ * norm is used. If this is much less than 1, then the stability of\n\ * the LU factorization of the (equilibrated) matrix A could be poor.\n\ * This also means that the solution X, estimated condition numbers,\n\ * and error bounds could be unreliable. If factorization fails with\n\ * 0 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlarf0000644000175000017500000000504212502223526016301 0ustar uwabamiuwabami--- :name: dlarf :md5sum: 8e2a3aa760cbf5b5a973bac159402732 :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - v: :type: doublereal :intent: input :dims: - 1 + (m-1)*abs(incv) - incv: :type: integer :intent: input - tau: :type: doublereal :intent: input - c: :type: doublereal :intent: input/output :dims: - ldc - n - ldc: :type: integer :intent: input - work: :type: doublereal :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLARF applies a real elementary reflector H to a real m by n matrix\n\ * C, from either the left or the right. H is represented in the form\n\ *\n\ * H = I - tau * v * v'\n\ *\n\ * where tau is a real scalar and v is a real vector.\n\ *\n\ * If tau = 0, then H is taken to be the unit matrix.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': form H * C\n\ * = 'R': form C * H\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C.\n\ *\n\ * V (input) DOUBLE PRECISION array, dimension\n\ * (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n\ * or (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n\ * The vector v in the representation of H. V is not used if\n\ * TAU = 0.\n\ *\n\ * INCV (input) INTEGER\n\ * The increment between elements of v. INCV <> 0.\n\ *\n\ * TAU (input) DOUBLE PRECISION\n\ * The value tau in the representation of H.\n\ *\n\ * C (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n\ * On entry, the m by n matrix C.\n\ * On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n\ * or C * H if SIDE = 'R'.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the array C. LDC >= max(1,M).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension\n\ * (N) if SIDE = 'L'\n\ * or (M) if SIDE = 'R'\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgbequ0000644000175000017500000000740012502223525016456 0ustar uwabamiuwabami--- :name: cgbequ :md5sum: 8fc652d617124429e7e171353face8d7 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - r: :type: real :intent: output :dims: - MAX(1,m) - c: :type: real :intent: output :dims: - n - rowcnd: :type: real :intent: output - colcnd: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGBEQU computes row and column scalings intended to equilibrate an\n\ * M-by-N band matrix A and reduce its condition number. R returns the\n\ * row scale factors and C the column scale factors, chosen to try to\n\ * make the largest element in each row and column of the matrix B with\n\ * elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n\ *\n\ * R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n\ * number and BIGNUM = largest safe number. Use of these scaling\n\ * factors is not guaranteed to reduce the condition number of A but\n\ * works well in practice.\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\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * AB (input) COMPLEX array, dimension (LDAB,N)\n\ * The band matrix A, stored in rows 1 to KL+KU+1. The j-th\n\ * column of A is stored in the j-th column of the array AB as\n\ * follows:\n\ * AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * R (output) REAL array, dimension (M)\n\ * If INFO = 0, or INFO > M, R contains the row scale factors\n\ * for A.\n\ *\n\ * C (output) REAL array, dimension (N)\n\ * If INFO = 0, C contains the column scale factors for A.\n\ *\n\ * ROWCND (output) REAL\n\ * If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n\ * smallest R(i) to the largest R(i). If ROWCND >= 0.1 and\n\ * AMAX is neither too large nor too small, it is not worth\n\ * scaling by R.\n\ *\n\ * COLCND (output) REAL\n\ * If INFO = 0, COLCND contains the ratio of the smallest\n\ * C(i) to the largest C(i). If COLCND >= 0.1, it is not\n\ * worth scaling by C.\n\ *\n\ * AMAX (output) REAL\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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, and i is\n\ * <= M: the i-th row of A is exactly zero\n\ * > M: the (i-M)-th column of A is exactly zero\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ztrsna0000644000175000017500000001677312502223526016547 0ustar uwabamiuwabami--- :name: ztrsna :md5sum: 339c335b53f98021869d2715ea8e18f8 :category: :subroutine :arguments: - job: :type: char :intent: input - howmny: :type: char :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - t: :type: doublecomplex :intent: input :dims: - ldt - n - ldt: :type: integer :intent: input - vl: :type: doublecomplex :intent: input :dims: - ldvl - m - ldvl: :type: integer :intent: input - vr: :type: doublecomplex :intent: input :dims: - ldvr - m - ldvr: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - mm - sep: :type: doublereal :intent: output :dims: - mm - mm: :type: integer :intent: input - m: :type: integer :intent: output - work: :type: doublecomplex :intent: workspace :dims: - "lsame_(&job,\"E\") ? 0 : ldwork" - "lsame_(&job,\"E\") ? 0 : n+6" - ldwork: :type: integer :intent: input - rwork: :type: doublereal :intent: workspace :dims: - "lsame_(&job,\"E\") ? 0 : n" - info: :type: integer :intent: output :substitutions: ldwork: "((lsame_(&job,\"V\")) || (lsame_(&job,\"B\"))) ? n : 1" mm: m :fortran_help: " SUBROUTINE ZTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTRSNA estimates reciprocal condition numbers for specified\n\ * eigenvalues and/or right eigenvectors of a complex upper triangular\n\ * matrix T (or of any matrix Q*T*Q**H with Q unitary).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOB (input) CHARACTER*1\n\ * Specifies whether condition numbers are required for\n\ * eigenvalues (S) or eigenvectors (SEP):\n\ * = 'E': for eigenvalues only (S);\n\ * = 'V': for eigenvectors only (SEP);\n\ * = 'B': for both eigenvalues and eigenvectors (S and SEP).\n\ *\n\ * HOWMNY (input) CHARACTER*1\n\ * = 'A': compute condition numbers for all eigenpairs;\n\ * = 'S': compute condition numbers for selected eigenpairs\n\ * specified by the array SELECT.\n\ *\n\ * SELECT (input) LOGICAL array, dimension (N)\n\ * If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n\ * condition numbers are required. To select condition numbers\n\ * for the j-th eigenpair, SELECT(j) must be set to .TRUE..\n\ * If HOWMNY = 'A', SELECT is not referenced.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix T. N >= 0.\n\ *\n\ * T (input) COMPLEX*16 array, dimension (LDT,N)\n\ * The upper triangular matrix T.\n\ *\n\ * LDT (input) INTEGER\n\ * The leading dimension of the array T. LDT >= max(1,N).\n\ *\n\ * VL (input) COMPLEX*16 array, dimension (LDVL,M)\n\ * If JOB = 'E' or 'B', VL must contain left eigenvectors of T\n\ * (or of any Q*T*Q**H with Q unitary), corresponding to the\n\ * eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n\ * must be stored in consecutive columns of VL, as returned by\n\ * ZHSEIN or ZTREVC.\n\ * If JOB = 'V', VL is not referenced.\n\ *\n\ * LDVL (input) INTEGER\n\ * The leading dimension of the array VL.\n\ * LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.\n\ *\n\ * VR (input) COMPLEX*16 array, dimension (LDVR,M)\n\ * If JOB = 'E' or 'B', VR must contain right eigenvectors of T\n\ * (or of any Q*T*Q**H with Q unitary), corresponding to the\n\ * eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n\ * must be stored in consecutive columns of VR, as returned by\n\ * ZHSEIN or ZTREVC.\n\ * If JOB = 'V', VR is not referenced.\n\ *\n\ * LDVR (input) INTEGER\n\ * The leading dimension of the array VR.\n\ * LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.\n\ *\n\ * S (output) DOUBLE PRECISION array, dimension (MM)\n\ * If JOB = 'E' or 'B', the reciprocal condition numbers of the\n\ * selected eigenvalues, stored in consecutive elements of the\n\ * array. Thus S(j), SEP(j), and the j-th columns of VL and VR\n\ * all correspond to the same eigenpair (but not in general the\n\ * j-th eigenpair, unless all eigenpairs are selected).\n\ * If JOB = 'V', S is not referenced.\n\ *\n\ * SEP (output) DOUBLE PRECISION array, dimension (MM)\n\ * If JOB = 'V' or 'B', the estimated reciprocal condition\n\ * numbers of the selected eigenvectors, stored in consecutive\n\ * elements of the array.\n\ * If JOB = 'E', SEP is not referenced.\n\ *\n\ * MM (input) INTEGER\n\ * The number of elements in the arrays S (if JOB = 'E' or 'B')\n\ * and/or SEP (if JOB = 'V' or 'B'). MM >= M.\n\ *\n\ * M (output) INTEGER\n\ * The number of elements of the arrays S and/or SEP actually\n\ * used to store the estimated condition numbers.\n\ * If HOWMNY = 'A', M is set to N.\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (LDWORK,N+6)\n\ * If JOB = 'E', WORK is not referenced.\n\ *\n\ * LDWORK (input) INTEGER\n\ * The leading dimension of the array WORK.\n\ * LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.\n\ *\n\ * RWORK (workspace) DOUBLE PRECISION array, dimension (N)\n\ * If JOB = 'E', RWORK is not referenced.\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 reciprocal of the condition number of an eigenvalue lambda is\n\ * defined as\n\ *\n\ * S(lambda) = |v'*u| / (norm(u)*norm(v))\n\ *\n\ * where u and v are the right and left eigenvectors of T corresponding\n\ * to lambda; v' denotes the conjugate transpose of v, and norm(u)\n\ * denotes the Euclidean norm. These reciprocal condition numbers always\n\ * lie between zero (very badly conditioned) and one (very well\n\ * conditioned). If n = 1, S(lambda) is defined to be 1.\n\ *\n\ * An approximate error bound for a computed eigenvalue W(i) is given by\n\ *\n\ * EPS * norm(T) / S(i)\n\ *\n\ * where EPS is the machine precision.\n\ *\n\ * The reciprocal of the condition number of the right eigenvector u\n\ * corresponding to lambda is defined as follows. Suppose\n\ *\n\ * T = ( lambda c )\n\ * ( 0 T22 )\n\ *\n\ * Then the reciprocal condition number is\n\ *\n\ * SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )\n\ *\n\ * where sigma-min denotes the smallest singular value. We approximate\n\ * the smallest singular value by the reciprocal of an estimate of the\n\ * one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is\n\ * defined to be abs(T(1,1)).\n\ *\n\ * An approximate error bound for a computed right eigenvector VR(i)\n\ * is given by\n\ *\n\ * EPS * norm(T) / SEP(i)\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dtbcon0000644000175000017500000000633112502223526016464 0ustar uwabamiuwabami--- :name: dtbcon :md5sum: b93a38a966efb195be781a50ffe5a3ce :category: :subroutine :arguments: - norm: :type: char :intent: input - uplo: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - rcond: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 3*n - iwork: :type: integer :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DTBCON estimates the reciprocal of the condition number of a\n\ * triangular band matrix A, in either the 1-norm or the infinity-norm.\n\ *\n\ * The norm of A is computed and an estimate is obtained for\n\ * norm(inv(A)), then the reciprocal of the condition number is\n\ * computed as\n\ * RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * NORM (input) CHARACTER*1\n\ * Specifies whether the 1-norm condition number or the\n\ * infinity-norm condition number is required:\n\ * = '1' or 'O': 1-norm;\n\ * = 'I': Infinity-norm.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals or subdiagonals of the\n\ * triangular band matrix A. KD >= 0.\n\ *\n\ * AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * The upper or lower triangular band matrix A, stored in the\n\ * first kd+1 rows of the array. The j-th column of A is stored\n\ * in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ * If DIAG = 'U', the diagonal elements of A are not referenced\n\ * and are assumed to be 1.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * RCOND (output) DOUBLE PRECISION\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(norm(A) * norm(inv(A))).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dlapy20000644000175000017500000000130512502223526016402 0ustar uwabamiuwabami--- :name: dlapy2 :md5sum: b3aaae9d309eec4c8fefd63e3e59e662 :category: :function :type: doublereal :arguments: - x: :type: doublereal :intent: input - y: :type: doublereal :intent: input :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION DLAPY2( X, Y )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary\n\ * overflow.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * X (input) DOUBLE PRECISION\n\ * Y (input) DOUBLE PRECISION\n\ * X and Y specify the values x and y.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zla_porcond_x0000644000175000017500000000622712502223526020060 0ustar uwabamiuwabami--- :name: zla_porcond_x :md5sum: 0fa4ca3979f7fa847286e416f8ffbeda :category: :function :type: doublereal :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - x: :type: doublecomplex :intent: input :dims: - n - info: :type: integer :intent: output - work: :type: doublecomplex :intent: input :dims: - 2*n - rwork: :type: doublereal :intent: input :dims: - n :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION ZLA_PORCOND_X( UPLO, N, A, LDA, AF, LDAF, X, INFO, WORK, RWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLA_PORCOND_X Computes the infinity norm condition number of\n\ * op(A) * diag(X) where X is a COMPLEX*16 vector.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX*16 array, dimension (LDAF,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T, as computed by ZPOTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * X (input) COMPLEX*16 array, dimension (N)\n\ * The vector X in the formula op(A) * diag(X).\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * i > 0: The ith argument is invalid.\n\ *\n\ * WORK (input) COMPLEX*16 array, dimension (2*N).\n\ * Workspace.\n\ *\n\ * RWORK (input) DOUBLE PRECISION array, dimension (N).\n\ * Workspace.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER KASE, I, J\n DOUBLE PRECISION AINVNM, ANORM, TMP\n LOGICAL UP\n COMPLEX*16 ZDUM\n\ * ..\n\ * .. Local Arrays ..\n INTEGER ISAVE( 3 )\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL ZLACN2, ZPOTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, REAL, DIMAG\n\ * ..\n\ * .. Statement Functions ..\n DOUBLE PRECISION CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlals00000644000175000017500000001705612502223526016400 0ustar uwabamiuwabami--- :name: dlals0 :md5sum: 1da4beec06cb8156b553b2d754a11426 :category: :subroutine :arguments: - icompq: :type: integer :intent: input - nl: :type: integer :intent: input - nr: :type: integer :intent: input - sqre: :type: integer :intent: input - nrhs: :type: integer :intent: input - b: :type: doublereal :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - bx: :type: doublereal :intent: workspace :dims: - ldbx - nrhs - ldbx: :type: integer :intent: input - perm: :type: integer :intent: input :dims: - n - givptr: :type: integer :intent: input - givcol: :type: integer :intent: input :dims: - ldgcol - "2" - ldgcol: :type: integer :intent: input - givnum: :type: doublereal :intent: input :dims: - ldgnum - "2" - ldgnum: :type: integer :intent: input - poles: :type: doublereal :intent: input :dims: - ldgnum - "2" - difl: :type: doublereal :intent: input :dims: - k - difr: :type: doublereal :intent: input :dims: - ldgnum - "2" - z: :type: doublereal :intent: input :dims: - k - k: :type: integer :intent: input - c: :type: doublereal :intent: input - s: :type: doublereal :intent: input - work: :type: doublereal :intent: workspace :dims: - k - info: :type: integer :intent: output :substitutions: ldbx: n :fortran_help: " SUBROUTINE DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLALS0 applies back the multiplying factors of either the left or the\n\ * right singular vector matrix of a diagonal matrix appended by a row\n\ * to the right hand side matrix B in solving the least squares problem\n\ * using the divide-and-conquer SVD approach.\n\ *\n\ * For the left singular vector matrix, three types of orthogonal\n\ * matrices are involved:\n\ *\n\ * (1L) Givens rotations: the number of such rotations is GIVPTR; the\n\ * pairs of columns/rows they were applied to are stored in GIVCOL;\n\ * and the C- and S-values of these rotations are stored in GIVNUM.\n\ *\n\ * (2L) Permutation. The (NL+1)-st row of B is to be moved to the first\n\ * row, and for J=2:N, PERM(J)-th row of B is to be moved to the\n\ * J-th row.\n\ *\n\ * (3L) The left singular vector matrix of the remaining matrix.\n\ *\n\ * For the right singular vector matrix, four types of orthogonal\n\ * matrices are involved:\n\ *\n\ * (1R) The right singular vector matrix of the remaining matrix.\n\ *\n\ * (2R) If SQRE = 1, one extra Givens rotation to generate the right\n\ * null space.\n\ *\n\ * (3R) The inverse transformation of (2L).\n\ *\n\ * (4R) The inverse transformation of (1L).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * ICOMPQ (input) INTEGER\n\ * Specifies whether singular vectors are to be computed in\n\ * factored form:\n\ * = 0: Left singular vector matrix.\n\ * = 1: Right singular vector matrix.\n\ *\n\ * NL (input) INTEGER\n\ * The row dimension of the upper block. NL >= 1.\n\ *\n\ * NR (input) INTEGER\n\ * The row dimension of the lower block. NR >= 1.\n\ *\n\ * SQRE (input) INTEGER\n\ * = 0: the lower block is an NR-by-NR square matrix.\n\ * = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n\ *\n\ * The bidiagonal matrix has row dimension N = NL + NR + 1,\n\ * and column dimension M = N + SQRE.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of columns of B and BX. NRHS must be at least 1.\n\ *\n\ * B (input/output) DOUBLE PRECISION array, dimension ( LDB, NRHS )\n\ * On input, B contains the right hand sides of the least\n\ * squares problem in rows 1 through M. On output, B contains\n\ * the solution X in rows 1 through N.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of B. LDB must be at least\n\ * max(1,MAX( M, N ) ).\n\ *\n\ * BX (workspace) DOUBLE PRECISION array, dimension ( LDBX, NRHS )\n\ *\n\ * LDBX (input) INTEGER\n\ * The leading dimension of BX.\n\ *\n\ * PERM (input) INTEGER array, dimension ( N )\n\ * The permutations (from deflation and sorting) applied\n\ * to the two blocks.\n\ *\n\ * GIVPTR (input) INTEGER\n\ * The number of Givens rotations which took place in this\n\ * subproblem.\n\ *\n\ * GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )\n\ * Each pair of numbers indicates a pair of rows/columns\n\ * involved in a Givens rotation.\n\ *\n\ * LDGCOL (input) INTEGER\n\ * The leading dimension of GIVCOL, must be at least N.\n\ *\n\ * GIVNUM (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )\n\ * Each number indicates the C or S value used in the\n\ * corresponding Givens rotation.\n\ *\n\ * LDGNUM (input) INTEGER\n\ * The leading dimension of arrays DIFR, POLES and\n\ * GIVNUM, must be at least K.\n\ *\n\ * POLES (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )\n\ * On entry, POLES(1:K, 1) contains the new singular\n\ * values obtained from solving the secular equation, and\n\ * POLES(1:K, 2) is an array containing the poles in the secular\n\ * equation.\n\ *\n\ * DIFL (input) DOUBLE PRECISION array, dimension ( K ).\n\ * On entry, DIFL(I) is the distance between I-th updated\n\ * (undeflated) singular value and the I-th (undeflated) old\n\ * singular value.\n\ *\n\ * DIFR (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ).\n\ * On entry, DIFR(I, 1) contains the distances between I-th\n\ * updated (undeflated) singular value and the I+1-th\n\ * (undeflated) old singular value. And DIFR(I, 2) is the\n\ * normalizing factor for the I-th right singular vector.\n\ *\n\ * Z (input) DOUBLE PRECISION array, dimension ( K )\n\ * Contain the components of the deflation-adjusted updating row\n\ * vector.\n\ *\n\ * K (input) INTEGER\n\ * Contains the dimension of the non-deflated matrix,\n\ * This is the order of the related secular equation. 1 <= K <=N.\n\ *\n\ * C (input) DOUBLE PRECISION\n\ * C contains garbage if SQRE =0 and the C-value of a Givens\n\ * rotation related to the right null space if SQRE = 1.\n\ *\n\ * S (input) DOUBLE PRECISION\n\ * S contains garbage if SQRE =0 and the S-value of a Givens\n\ * rotation related to the right null space if SQRE = 1.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension ( K )\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\ * Based on contributions by\n\ * Ming Gu and Ren-Cang Li, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsyequb0000644000175000017500000000654612502223526016677 0ustar uwabamiuwabami--- :name: dsyequb :md5sum: e64c1e10d53f2652cb55a29099f76c13 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - n - scond: :type: doublereal :intent: output - amax: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 3*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSYEQUB computes row and column scalings intended to equilibrate a\n\ * symmetric matrix A and reduce its condition number\n\ * (with respect to the two-norm). S contains the scale factors,\n\ * S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n\ * elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n\ * choice of S puts the condition number of B within a factor N of the\n\ * smallest possible condition number over all possible diagonal\n\ * scalings.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the details of the factorization are stored\n\ * as an upper or lower triangular matrix.\n\ * = 'U': Upper triangular, form is A = U*D*U**T;\n\ * = 'L': Lower triangular, form is A = L*D*L**T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * The N-by-N symmetric matrix whose scaling\n\ * factors are to be computed. Only the diagonal elements of A\n\ * are referenced.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * S (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, S contains the scale factors for A.\n\ *\n\ * SCOND (output) DOUBLE PRECISION\n\ * If INFO = 0, S contains the ratio of the smallest S(i) to\n\ * the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n\ * large nor too small, it is not worth scaling by S.\n\ *\n\ * AMAX (output) DOUBLE PRECISION\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (3*N)\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 is nonpositive.\n\ *\n\n\ * Further Details\n\ * ======= =======\n\ *\n\ * Reference: Livne, O.E. and Golub, G.H., \"Scaling by Binormalization\",\n\ * Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004.\n\ * DOI 10.1023/B:NUMA.0000016606.32820.69\n\ * Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ctbtrs0000644000175000017500000000666112502223525016521 0ustar uwabamiuwabami--- :name: ctbtrs :md5sum: c9693dc332b90354ae799914b6e7d411 :category: :subroutine :arguments: - uplo: :type: char :intent: input - trans: :type: char :intent: input - diag: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CTBTRS solves a triangular system of the form\n\ *\n\ * A * X = B, A**T * X = B, or A**H * X = B,\n\ *\n\ * where A is a triangular band matrix of order N, and B is an\n\ * N-by-NRHS matrix. A check is made to verify that A is nonsingular.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': A is upper triangular;\n\ * = 'L': A is lower triangular.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose)\n\ *\n\ * DIAG (input) CHARACTER*1\n\ * = 'N': A is non-unit triangular;\n\ * = 'U': A is unit triangular.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals or subdiagonals of the\n\ * triangular band matrix A. KD >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * AB (input) COMPLEX array, dimension (LDAB,N)\n\ * The upper or lower triangular band matrix A, stored in the\n\ * first kd+1 rows of AB. The j-th column of A is stored\n\ * in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ * If DIAG = 'U', the diagonal elements of A are not referenced\n\ * and are assumed to be 1.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KD+1.\n\ *\n\ * B (input/output) COMPLEX array, dimension (LDB,NRHS)\n\ * On entry, the right hand side matrix B.\n\ * On exit, if INFO = 0, the solution matrix X.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\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 A is zero,\n\ * indicating that the matrix is singular and the\n\ * solutions X have not been computed.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zgeqr20000644000175000017500000000477112502223526016433 0ustar uwabamiuwabami--- :name: zgeqr2 :md5sum: b8c457332b3f63fff4aa0e6dd390f3b3 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublecomplex :intent: output :dims: - MIN(m,n) - work: :type: doublecomplex :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZGEQR2 computes a QR factorization of a complex m by n matrix A:\n\ * A = Q * R.\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) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the m by n matrix A.\n\ * On exit, the elements on and above the diagonal of the array\n\ * contain the min(m,n) by n upper trapezoidal matrix R (R is\n\ * upper triangular if m >= n); the elements below the diagonal,\n\ * with the array TAU, represent the unitary 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) COMPLEX*16 array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace) COMPLEX*16 array, dimension (N)\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(1) H(2) . . . H(k), 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 complex scalar, and v is a complex vector with\n\ * v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\n\ * and tau in TAU(i).\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slasdq0000644000175000017500000001447412502223526016511 0ustar uwabamiuwabami--- :name: slasdq :md5sum: ca31c86dcb1ae2e16419d7f2adab408a :category: :subroutine :arguments: - uplo: :type: char :intent: input - sqre: :type: integer :intent: input - n: :type: integer :intent: input - ncvt: :type: integer :intent: input - nru: :type: integer :intent: input - ncc: :type: integer :intent: input - d: :type: real :intent: input/output :dims: - n - e: :type: real :intent: input/output :dims: - "sqre==0 ? n-1 : sqre==1 ? n : 0" - vt: :type: real :intent: input/output :dims: - ldvt - ncvt - ldvt: :type: integer :intent: input - u: :type: real :intent: input/output :dims: - ldu - n - ldu: :type: integer :intent: input - c: :type: real :intent: input/output :dims: - ldc - ncc - ldc: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - 4*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SLASDQ computes the singular value decomposition (SVD) of a real\n\ * (upper or lower) bidiagonal matrix with diagonal D and offdiagonal\n\ * E, accumulating the transformations if desired. Letting B denote\n\ * the input bidiagonal matrix, the algorithm computes orthogonal\n\ * matrices Q and P such that B = Q * S * P' (P' denotes the transpose\n\ * of P). The singular values S are overwritten on D.\n\ *\n\ * The input matrix U is changed to U * Q if desired.\n\ * The input matrix VT is changed to P' * VT if desired.\n\ * The input matrix C is changed to Q' * C if desired.\n\ *\n\ * See \"Computing Small Singular Values of Bidiagonal Matrices With\n\ * Guaranteed High Relative Accuracy,\" by J. Demmel and W. Kahan,\n\ * LAPACK Working Note #3, for a detailed description of the algorithm.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * On entry, UPLO specifies whether the input bidiagonal matrix\n\ * is upper or lower bidiagonal, and wether it is square are\n\ * not.\n\ * UPLO = 'U' or 'u' B is upper bidiagonal.\n\ * UPLO = 'L' or 'l' B is lower bidiagonal.\n\ *\n\ * SQRE (input) INTEGER\n\ * = 0: then the input matrix is N-by-N.\n\ * = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and\n\ * (N+1)-by-N if UPLU = 'L'.\n\ *\n\ * The bidiagonal matrix has\n\ * N = NL + NR + 1 rows and\n\ * M = N + SQRE >= N columns.\n\ *\n\ * N (input) INTEGER\n\ * On entry, N specifies the number of rows and columns\n\ * in the matrix. N must be at least 0.\n\ *\n\ * NCVT (input) INTEGER\n\ * On entry, NCVT specifies the number of columns of\n\ * the matrix VT. NCVT must be at least 0.\n\ *\n\ * NRU (input) INTEGER\n\ * On entry, NRU specifies the number of rows of\n\ * the matrix U. NRU must be at least 0.\n\ *\n\ * NCC (input) INTEGER\n\ * On entry, NCC specifies the number of columns of\n\ * the matrix C. NCC must be at least 0.\n\ *\n\ * D (input/output) REAL array, dimension (N)\n\ * On entry, D contains the diagonal entries of the\n\ * bidiagonal matrix whose SVD is desired. On normal exit,\n\ * D contains the singular values in ascending order.\n\ *\n\ * E (input/output) REAL array.\n\ * dimension is (N-1) if SQRE = 0 and N if SQRE = 1.\n\ * On entry, the entries of E contain the offdiagonal entries\n\ * of the bidiagonal matrix whose SVD is desired. On normal\n\ * exit, E will contain 0. If the algorithm does not converge,\n\ * D and E will contain the diagonal and superdiagonal entries\n\ * of a bidiagonal matrix orthogonally equivalent to the one\n\ * given as input.\n\ *\n\ * VT (input/output) REAL array, dimension (LDVT, NCVT)\n\ * On entry, contains a matrix which on exit has been\n\ * premultiplied by P', dimension N-by-NCVT if SQRE = 0\n\ * and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0).\n\ *\n\ * LDVT (input) INTEGER\n\ * On entry, LDVT specifies the leading dimension of VT as\n\ * declared in the calling (sub) program. LDVT must be at\n\ * least 1. If NCVT is nonzero LDVT must also be at least N.\n\ *\n\ * U (input/output) REAL array, dimension (LDU, N)\n\ * On entry, contains a matrix which on exit has been\n\ * postmultiplied by Q, dimension NRU-by-N if SQRE = 0\n\ * and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0).\n\ *\n\ * LDU (input) INTEGER\n\ * On entry, LDU specifies the leading dimension of U as\n\ * declared in the calling (sub) program. LDU must be at\n\ * least max( 1, NRU ) .\n\ *\n\ * C (input/output) REAL array, dimension (LDC, NCC)\n\ * On entry, contains an N-by-NCC matrix which on exit\n\ * has been premultiplied by Q' dimension N-by-NCC if SQRE = 0\n\ * and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0).\n\ *\n\ * LDC (input) INTEGER\n\ * On entry, LDC specifies the leading dimension of C as\n\ * declared in the calling (sub) program. LDC must be at\n\ * least 1. If NCC is nonzero, LDC must also be at least N.\n\ *\n\ * WORK (workspace) REAL array, dimension (4*N)\n\ * Workspace. Only referenced if one of NCVT, NRU, or NCC is\n\ * nonzero, and if N is at least 2.\n\ *\n\ * INFO (output) INTEGER\n\ * On exit, a value of 0 indicates a successful exit.\n\ * If INFO < 0, argument number -INFO is illegal.\n\ * If INFO > 0, the algorithm did not converge, and INFO\n\ * specifies how many superdiagonals did not converge.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ming Gu and Huan Ren, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slatzm0000644000175000017500000000711412502223526016525 0ustar uwabamiuwabami--- :name: slatzm :md5sum: 172c0c1f0dd2ca607bc873687a1c0d69 :category: :subroutine :arguments: - side: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - v: :type: real :intent: input :dims: - 1 + (m-1)*abs(incv) - incv: :type: integer :intent: input - tau: :type: real :intent: input - c1: :type: real :intent: input/output :dims: - "lsame_(&side,\"L\") ? ldc : lsame_(&side,\"R\") ? m : 0" - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? 1 : 0" - c2: :type: real :intent: input/output :dims: - ldc - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? n-1 : 0" - ldc: :type: integer :intent: input - work: :type: real :intent: workspace :dims: - "lsame_(&side,\"L\") ? n : lsame_(&side,\"R\") ? m : 0" :substitutions: {} :fortran_help: " SUBROUTINE SLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * This routine is deprecated and has been replaced by routine SORMRZ.\n\ *\n\ * SLATZM applies a Householder matrix generated by STZRQF to a matrix.\n\ *\n\ * Let P = I - tau*u*u', u = ( 1 ),\n\ * ( v )\n\ * where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if\n\ * SIDE = 'R'.\n\ *\n\ * If SIDE equals 'L', let\n\ * C = [ C1 ] 1\n\ * [ C2 ] m-1\n\ * n\n\ * Then C is overwritten by P*C.\n\ *\n\ * If SIDE equals 'R', let\n\ * C = [ C1, C2 ] m\n\ * 1 n-1\n\ * Then C is overwritten by C*P.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * SIDE (input) CHARACTER*1\n\ * = 'L': form P * C\n\ * = 'R': form C * P\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix C.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix C.\n\ *\n\ * V (input) REAL array, dimension\n\ * (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n\ * (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n\ * The vector v in the representation of P. V is not used\n\ * if TAU = 0.\n\ *\n\ * INCV (input) INTEGER\n\ * The increment between elements of v. INCV <> 0\n\ *\n\ * TAU (input) REAL\n\ * The value tau in the representation of P.\n\ *\n\ * C1 (input/output) REAL array, dimension\n\ * (LDC,N) if SIDE = 'L'\n\ * (M,1) if SIDE = 'R'\n\ * On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1\n\ * if SIDE = 'R'.\n\ *\n\ * On exit, the first row of P*C if SIDE = 'L', or the first\n\ * column of C*P if SIDE = 'R'.\n\ *\n\ * C2 (input/output) REAL array, dimension\n\ * (LDC, N) if SIDE = 'L'\n\ * (LDC, N-1) if SIDE = 'R'\n\ * On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the\n\ * m x (n - 1) matrix C2 if SIDE = 'R'.\n\ *\n\ * On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P\n\ * if SIDE = 'R'.\n\ *\n\ * LDC (input) INTEGER\n\ * The leading dimension of the arrays C1 and C2. LDC >= (1,M).\n\ *\n\ * WORK (workspace) REAL array, dimension\n\ * (N) if SIDE = 'L'\n\ * (M) if SIDE = 'R'\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zlar1v0000644000175000017500000001463212502223526016435 0ustar uwabamiuwabami--- :name: zlar1v :md5sum: fc48ffc43e478939142fe3cbe328113b :category: :subroutine :arguments: - n: :type: integer :intent: input - b1: :type: integer :intent: input - bn: :type: integer :intent: input - lambda: :type: doublereal :intent: input - d: :type: doublereal :intent: input :dims: - n - l: :type: doublereal :intent: input :dims: - n-1 - ld: :type: doublereal :intent: input :dims: - n-1 - lld: :type: doublereal :intent: input :dims: - n-1 - pivmin: :type: doublereal :intent: input - gaptol: :type: doublereal :intent: input - z: :type: doublecomplex :intent: input/output :dims: - n - wantnc: :type: logical :intent: input - negcnt: :type: integer :intent: output - ztz: :type: doublereal :intent: output - mingma: :type: doublereal :intent: output - r: :type: integer :intent: input/output - isuppz: :type: integer :intent: output :dims: - "2" - nrminv: :type: doublereal :intent: output - resid: :type: doublereal :intent: output - rqcorr: :type: doublereal :intent: output - work: :type: doublereal :intent: workspace :dims: - 4*n :substitutions: {} :fortran_help: " SUBROUTINE ZLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD, PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, R, ISUPPZ, NRMINV, RESID, RQCORR, WORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLAR1V computes the (scaled) r-th column of the inverse of\n\ * the sumbmatrix in rows B1 through BN of the tridiagonal matrix\n\ * L D L^T - sigma I. When sigma is close to an eigenvalue, the\n\ * computed vector is an accurate eigenvector. Usually, r corresponds\n\ * to the index where the eigenvector is largest in magnitude.\n\ * The following steps accomplish this computation :\n\ * (a) Stationary qd transform, L D L^T - sigma I = L(+) D(+) L(+)^T,\n\ * (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T,\n\ * (c) Computation of the diagonal elements of the inverse of\n\ * L D L^T - sigma I by combining the above transforms, and choosing\n\ * r as the index where the diagonal of the inverse is (one of the)\n\ * largest in magnitude.\n\ * (d) Computation of the (scaled) r-th column of the inverse using the\n\ * twisted factorization obtained by combining the top part of the\n\ * the stationary and the bottom part of the progressive transform.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix L D L^T.\n\ *\n\ * B1 (input) INTEGER\n\ * First index of the submatrix of L D L^T.\n\ *\n\ * BN (input) INTEGER\n\ * Last index of the submatrix of L D L^T.\n\ *\n\ * LAMBDA (input) DOUBLE PRECISION\n\ * The shift. In order to compute an accurate eigenvector,\n\ * LAMBDA should be a good approximation to an eigenvalue\n\ * of L D L^T.\n\ *\n\ * L (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) subdiagonal elements of the unit bidiagonal matrix\n\ * L, in elements 1 to N-1.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The n diagonal elements of the diagonal matrix D.\n\ *\n\ * LD (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The n-1 elements L(i)*D(i).\n\ *\n\ * LLD (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The n-1 elements L(i)*L(i)*D(i).\n\ *\n\ * PIVMIN (input) DOUBLE PRECISION\n\ * The minimum pivot in the Sturm sequence.\n\ *\n\ * GAPTOL (input) DOUBLE PRECISION\n\ * Tolerance that indicates when eigenvector entries are negligible\n\ * w.r.t. their contribution to the residual.\n\ *\n\ * Z (input/output) COMPLEX*16 array, dimension (N)\n\ * On input, all entries of Z must be set to 0.\n\ * On output, Z contains the (scaled) r-th column of the\n\ * inverse. The scaling is such that Z(R) equals 1.\n\ *\n\ * WANTNC (input) LOGICAL\n\ * Specifies whether NEGCNT has to be computed.\n\ *\n\ * NEGCNT (output) INTEGER\n\ * If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin\n\ * in the matrix factorization L D L^T, and NEGCNT = -1 otherwise.\n\ *\n\ * ZTZ (output) DOUBLE PRECISION\n\ * The square of the 2-norm of Z.\n\ *\n\ * MINGMA (output) DOUBLE PRECISION\n\ * The reciprocal of the largest (in magnitude) diagonal\n\ * element of the inverse of L D L^T - sigma I.\n\ *\n\ * R (input/output) INTEGER\n\ * The twist index for the twisted factorization used to\n\ * compute Z.\n\ * On input, 0 <= R <= N. If R is input as 0, R is set to\n\ * the index where (L D L^T - sigma I)^{-1} is largest\n\ * in magnitude. If 1 <= R <= N, R is unchanged.\n\ * On output, R contains the twist index used to compute Z.\n\ * Ideally, R designates the position of the maximum entry in the\n\ * eigenvector.\n\ *\n\ * ISUPPZ (output) INTEGER array, dimension (2)\n\ * The support of the vector in Z, i.e., the vector Z is\n\ * nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ).\n\ *\n\ * NRMINV (output) DOUBLE PRECISION\n\ * NRMINV = 1/SQRT( ZTZ )\n\ *\n\ * RESID (output) DOUBLE PRECISION\n\ * The residual of the FP vector.\n\ * RESID = ABS( MINGMA )/SQRT( ZTZ )\n\ *\n\ * RQCORR (output) DOUBLE PRECISION\n\ * The Rayleigh Quotient correction to LAMBDA.\n\ * RQCORR = MINGMA*TMP\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (4*N)\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Beresford Parlett, University of California, Berkeley, USA\n\ * Jim Demmel, University of California, Berkeley, USA\n\ * Inderjit Dhillon, University of Texas, Austin, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, University of California, Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cpbequ0000644000175000017500000000620212502223525016466 0ustar uwabamiuwabami--- :name: cpbequ :md5sum: 23fe815105e015e77f5f060fae9224b5 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - kd: :type: integer :intent: input - ab: :type: complex :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - s: :type: real :intent: output :dims: - n - scond: :type: real :intent: output - amax: :type: real :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPBEQU computes row and column scalings intended to equilibrate a\n\ * Hermitian positive definite band matrix A and reduce its condition\n\ * number (with respect to the two-norm). S contains the scale factors,\n\ * S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n\ * elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This\n\ * choice of S puts the condition number of B within a factor N of the\n\ * smallest possible condition number over all possible diagonal\n\ * scalings.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangular of A is stored;\n\ * = 'L': Lower triangular of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KD (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KD >= 0.\n\ *\n\ * AB (input) COMPLEX array, dimension (LDAB,N)\n\ * The upper or lower triangle of the Hermitian band matrix A,\n\ * stored in the first KD+1 rows of the array. The j-th column\n\ * of A is stored in the j-th column of the array AB as follows:\n\ * if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array A. LDAB >= KD+1.\n\ *\n\ * S (output) REAL array, dimension (N)\n\ * If INFO = 0, S contains the scale factors for A.\n\ *\n\ * SCOND (output) REAL\n\ * If INFO = 0, S contains the ratio of the smallest S(i) to\n\ * the largest S(i). If SCOND >= 0.1 and AMAX is neither too\n\ * large nor too small, it is not worth scaling by S.\n\ *\n\ * AMAX (output) REAL\n\ * Absolute value of largest matrix element. If AMAX is very\n\ * close to overflow or very close to underflow, the matrix\n\ * should be scaled.\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 is nonpositive.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dorglq0000644000175000017500000000573012502223526016505 0ustar uwabamiuwabami--- :name: dorglq :md5sum: 312b7a0a9316ed4c8b1081726e032b69 :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - k: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: doublereal :intent: input :dims: - k - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: m - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DORGLQ generates an M-by-N real matrix Q with orthonormal rows,\n\ * which is defined as the first M rows of a product of K elementary\n\ * reflectors of order N\n\ *\n\ * Q = H(k) . . . H(2) H(1)\n\ *\n\ * as returned by DGELQF.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * M (input) INTEGER\n\ * The number of rows of the matrix Q. M >= 0.\n\ *\n\ * N (input) INTEGER\n\ * The number of columns of the matrix Q. N >= M.\n\ *\n\ * K (input) INTEGER\n\ * The number of elementary reflectors whose product defines the\n\ * matrix Q. M >= K >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the i-th row must contain the vector which defines\n\ * the elementary reflector H(i), for i = 1,2,...,k, as returned\n\ * by DGELQF in the first k rows of its array argument A.\n\ * On exit, the M-by-N matrix Q.\n\ *\n\ * LDA (input) INTEGER\n\ * The first dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (input) DOUBLE PRECISION array, dimension (K)\n\ * TAU(i) must contain the scalar factor of the elementary\n\ * reflector H(i), as returned by DGELQF.\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\n\ * the 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 has an illegal value\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgeqlf0000644000175000017500000000741612502223526016501 0ustar uwabamiuwabami--- :name: sgeqlf :md5sum: 22cbd1cd4a3f380748b6ebbd31b6179e :category: :subroutine :arguments: - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - tau: :type: real :intent: output :dims: - MIN(m,n) - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGEQLF computes a QL factorization of a real M-by-N matrix A:\n\ * A = Q * L.\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) REAL array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit,\n\ * if m >= n, the lower triangle of the subarray\n\ * A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L;\n\ * if m <= n, the elements on and below the (n-m)-th\n\ * superdiagonal contain the M-by-N lower trapezoidal matrix L;\n\ * the remaining elements, with the array TAU, represent the\n\ * orthogonal matrix Q as a product of elementary reflectors\n\ * (see Further Details).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * TAU (output) REAL array, dimension (min(M,N))\n\ * The scalar factors of the elementary reflectors (see Further\n\ * Details).\n\ *\n\ * WORK (workspace/output) REAL 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,N).\n\ * For optimum performance LWORK >= N*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(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n\ * A(1:m-k+i-1,n-k+i), and tau in TAU(i).\n\ *\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n LOGICAL LQUERY\n INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n $ MU, NB, NBMIN, NU, NX\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL SGEQL2, SLARFB, SLARFT, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC MAX, MIN\n\ * ..\n\ * .. External Functions ..\n INTEGER ILAENV\n EXTERNAL ILAENV\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dlaqsy0000644000175000017500000000605412502223526016512 0ustar uwabamiuwabami--- :name: dlaqsy :md5sum: 13b532db3d981114daeb56ec93631e26 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - s: :type: doublereal :intent: input :dims: - n - scond: :type: doublereal :intent: input - amax: :type: doublereal :intent: input - equed: :type: char :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DLAQSY equilibrates a symmetric matrix A using the scaling factors\n\ * in the vector S.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * Specifies whether the upper or lower triangular part of the\n\ * symmetric matrix A is stored.\n\ * = 'U': Upper triangular\n\ * = 'L': Lower triangular\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the symmetric matrix A. If UPLO = 'U', the leading\n\ * n by n upper triangular part of A contains the upper\n\ * triangular part of the matrix A, and the strictly lower\n\ * triangular part of A is not referenced. If UPLO = 'L', the\n\ * leading n by n lower triangular part of A contains the lower\n\ * triangular part of the matrix A, and the strictly upper\n\ * triangular part of A is not referenced.\n\ *\n\ * On exit, if EQUED = 'Y', the equilibrated matrix:\n\ * diag(S) * A * diag(S).\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(N,1).\n\ *\n\ * S (input) DOUBLE PRECISION array, dimension (N)\n\ * The scale factors for A.\n\ *\n\ * SCOND (input) DOUBLE PRECISION\n\ * Ratio of the smallest S(i) to the largest S(i).\n\ *\n\ * AMAX (input) DOUBLE PRECISION\n\ * Absolute value of largest matrix entry.\n\ *\n\ * EQUED (output) CHARACTER*1\n\ * Specifies whether or not equilibration was done.\n\ * = 'N': No equilibration.\n\ * = 'Y': Equilibration was done, i.e., A has been replaced by\n\ * diag(S) * A * diag(S).\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * THRESH is a threshold value used to decide if scaling should be done\n\ * based on the ratio of the scaling factors. If SCOND < THRESH,\n\ * scaling is done.\n\ *\n\ * LARGE and SMALL are threshold values used to decide if scaling should\n\ * be done based on the absolute size of the largest matrix element.\n\ * If AMAX > LARGE or AMAX < SMALL, scaling is done.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgels0000644000175000017500000001325312502223525016310 0ustar uwabamiuwabami--- :name: cgels :md5sum: 29da08d26d560d2b4db9388e142fdc4c :category: :subroutine :arguments: - trans: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - a: :type: complex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: complex :intent: input/output :dims: - m - nrhs :outdims: - n - nrhs - ldb: :type: integer :intent: input - work: :type: complex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: MIN(m,n) + MAX(MIN(m,n),nrhs) - info: :type: integer :intent: output :substitutions: m: lda ldb: MAX(m,n) :fortran_help: " SUBROUTINE CGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGELS solves overdetermined or underdetermined complex linear systems\n\ * involving an M-by-N matrix A, or its conjugate-transpose, using a QR\n\ * or LQ 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 = 'C' and m >= n: find the minimum norm solution of\n\ * an undetermined system A**H * X = B.\n\ *\n\ * 4. If TRANS = 'C' and m < n: find the least squares solution of\n\ * an overdetermined system, i.e., solve the least squares problem\n\ * minimize || B - A**H * 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\ * = 'C': the linear system involves A**H.\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) COMPLEX array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * if M >= N, A is overwritten by details of its QR\n\ * factorization as returned by CGEQRF;\n\ * if M < N, A is overwritten by details of its LQ\n\ * factorization as returned by CGELQF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * B (input/output) COMPLEX 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 = 'C'.\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 the\n\ * modulus of 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 = 'C' and m >= n, rows 1 to M of B contain the\n\ * minimum norm solution vectors;\n\ * if TRANS = 'C' 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 the modulus 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) COMPLEX 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" ruby-lapack-1.7.2/dev/defs/dptrfs0000644000175000017500000001011712502223526016512 0ustar uwabamiuwabami--- :name: dptrfs :md5sum: 39ea43178ed941789a2071e466d3b8b6 :category: :subroutine :arguments: - n: :type: integer :intent: input - nrhs: :type: integer :intent: input - d: :type: doublereal :intent: input :dims: - n - e: :type: doublereal :intent: input :dims: - n-1 - df: :type: doublereal :intent: input :dims: - n - ef: :type: doublereal :intent: input :dims: - n-1 - b: :type: doublereal :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: doublereal :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - ferr: :type: doublereal :intent: output :dims: - nrhs - berr: :type: doublereal :intent: output :dims: - nrhs - work: :type: doublereal :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE DPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR, WORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DPTRFS improves the computed solution to a system of linear\n\ * equations when the coefficient matrix is symmetric positive definite\n\ * and tridiagonal, and provides error bounds and backward error\n\ * estimates for the solution.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrix B. NRHS >= 0.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * The n diagonal elements of the tridiagonal matrix A.\n\ *\n\ * E (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) subdiagonal elements of the tridiagonal matrix A.\n\ *\n\ * DF (input) DOUBLE PRECISION array, dimension (N)\n\ * The n diagonal elements of the diagonal matrix D from the\n\ * factorization computed by DPTTRF.\n\ *\n\ * EF (input) DOUBLE PRECISION array, dimension (N-1)\n\ * The (n-1) subdiagonal elements of the unit bidiagonal factor\n\ * L from the factorization computed by DPTTRF.\n\ *\n\ * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by DPTTRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * FERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The forward error bound for each solution vector\n\ * X(j) (the j-th column of the solution matrix X).\n\ * If XTRUE is the true solution corresponding to X(j), FERR(j)\n\ * is an estimated upper bound for the magnitude of the largest\n\ * element in (X(j) - XTRUE) divided by the magnitude of the\n\ * largest element in X(j).\n\ *\n\ * BERR (output) DOUBLE PRECISION array, dimension (NRHS)\n\ * The componentwise relative backward error of each solution\n\ * vector X(j) (i.e., the smallest relative change in\n\ * any element of A or B that makes X(j) an exact solution).\n\ *\n\ * WORK (workspace) DOUBLE PRECISION array, dimension (2*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit\n\ * < 0: if INFO = -i, the i-th argument had an illegal value\n\ *\n\ * Internal Parameters\n\ * ===================\n\ *\n\ * ITMAX is the maximum number of steps of iterative refinement.\n\ *\n\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/ztgsen0000644000175000017500000003755212502223526016536 0ustar uwabamiuwabami--- :name: ztgsen :md5sum: 87009453b32005aef76d43901d546116 :category: :subroutine :arguments: - ijob: :type: integer :intent: input - wantq: :type: logical :intent: input - wantz: :type: logical :intent: input - select: :type: logical :intent: input :dims: - n - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - b: :type: doublecomplex :intent: input/output :dims: - ldb - n - ldb: :type: integer :intent: input - alpha: :type: doublecomplex :intent: output :dims: - n - beta: :type: doublecomplex :intent: output :dims: - n - q: :type: doublecomplex :intent: input/output :dims: - ldq - n - ldq: :type: integer :intent: input - z: :type: doublecomplex :intent: input/output :dims: - ldz - n - ldz: :type: integer :intent: input - m: :type: integer :intent: output - pl: :type: doublereal :intent: output - pr: :type: doublereal :intent: output - dif: :type: doublereal :intent: output :dims: - "2" - work: :type: doublecomplex :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "(ijob==1||ijob==2||ijob==4) ? 2*m*(n-m) : (ijob==3||ijob==5) ? 4*m*(n-m) : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "(ijob==1||ijob==2||ijob==4) ? n+2 : (ijob==3||ijob==5) ? 2*m*(n-m) : 0" - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE ZTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZTGSEN reorders the generalized Schur decomposition of a complex\n\ * matrix pair (A, B) (in terms of an unitary equivalence trans-\n\ * formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues\n\ * appears in the leading diagonal blocks of the pair (A,B). The leading\n\ * columns of Q and Z form unitary bases of the corresponding left and\n\ * right eigenspaces (deflating subspaces). (A, B) must be in\n\ * generalized Schur canonical form, that is, A and B are both upper\n\ * triangular.\n\ *\n\ * ZTGSEN also computes the generalized eigenvalues\n\ *\n\ * w(j)= ALPHA(j) / BETA(j)\n\ *\n\ * of the reordered matrix pair (A, B).\n\ *\n\ * Optionally, the routine computes estimates of reciprocal condition\n\ * numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),\n\ * (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)\n\ * between the matrix pairs (A11, B11) and (A22,B22) that correspond to\n\ * the selected cluster and the eigenvalues outside the cluster, resp.,\n\ * and norms of \"projections\" onto left and right eigenspaces w.r.t.\n\ * the selected cluster in the (1,1)-block.\n\ *\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * IJOB (input) integer\n\ * Specifies whether condition numbers are required for the\n\ * cluster of eigenvalues (PL and PR) or the deflating subspaces\n\ * (Difu and Difl):\n\ * =0: Only reorder w.r.t. SELECT. No extras.\n\ * =1: Reciprocal of norms of \"projections\" onto left and right\n\ * eigenspaces w.r.t. the selected cluster (PL and PR).\n\ * =2: Upper bounds on Difu and Difl. F-norm-based estimate\n\ * (DIF(1:2)).\n\ * =3: Estimate of Difu and Difl. 1-norm-based estimate\n\ * (DIF(1:2)).\n\ * About 5 times as expensive as IJOB = 2.\n\ * =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic\n\ * version to get it all.\n\ * =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)\n\ *\n\ * WANTQ (input) LOGICAL\n\ * .TRUE. : update the left transformation matrix Q;\n\ * .FALSE.: do not update Q.\n\ *\n\ * WANTZ (input) LOGICAL\n\ * .TRUE. : update the right transformation matrix Z;\n\ * .FALSE.: do not update Z.\n\ *\n\ * SELECT (input) LOGICAL array, dimension (N)\n\ * SELECT specifies the eigenvalues in the selected cluster. To\n\ * select an eigenvalue w(j), SELECT(j) must be set to\n\ * .TRUE..\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * A (input/output) COMPLEX*16 array, dimension(LDA,N)\n\ * On entry, the upper triangular matrix A, in generalized\n\ * Schur canonical form.\n\ * On exit, A is overwritten by the reordered matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * B (input/output) COMPLEX*16 array, dimension(LDB,N)\n\ * On entry, the upper triangular matrix B, in generalized\n\ * Schur canonical form.\n\ * On exit, B is overwritten by the reordered matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * ALPHA (output) COMPLEX*16 array, dimension (N)\n\ * BETA (output) COMPLEX*16 array, dimension (N)\n\ * The diagonal elements of A and B, respectively,\n\ * when the pair (A,B) has been reduced to generalized Schur\n\ * form. ALPHA(i)/BETA(i) i=1,...,N are the generalized\n\ * eigenvalues.\n\ *\n\ * Q (input/output) COMPLEX*16 array, dimension (LDQ,N)\n\ * On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.\n\ * On exit, Q has been postmultiplied by the left unitary\n\ * transformation matrix which reorder (A, B); The leading M\n\ * columns of Q form orthonormal bases for the specified pair of\n\ * left eigenspaces (deflating subspaces).\n\ * If WANTQ = .FALSE., Q is not referenced.\n\ *\n\ * LDQ (input) INTEGER\n\ * The leading dimension of the array Q. LDQ >= 1.\n\ * If WANTQ = .TRUE., LDQ >= N.\n\ *\n\ * Z (input/output) COMPLEX*16 array, dimension (LDZ,N)\n\ * On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.\n\ * On exit, Z has been postmultiplied by the left unitary\n\ * transformation matrix which reorder (A, B); The leading M\n\ * columns of Z form orthonormal bases for the specified pair of\n\ * left eigenspaces (deflating subspaces).\n\ * If WANTZ = .FALSE., Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1.\n\ * If WANTZ = .TRUE., LDZ >= N.\n\ *\n\ * M (output) INTEGER\n\ * The dimension of the specified pair of left and right\n\ * eigenspaces, (deflating subspaces) 0 <= M <= N.\n\ *\n\ * PL (output) DOUBLE PRECISION\n\ * PR (output) DOUBLE PRECISION\n\ * If IJOB = 1, 4 or 5, PL, PR are lower bounds on the\n\ * reciprocal of the norm of \"projections\" onto left and right\n\ * eigenspace with respect to the selected cluster.\n\ * 0 < PL, PR <= 1.\n\ * If M = 0 or M = N, PL = PR = 1.\n\ * If IJOB = 0, 2 or 3 PL, PR are not referenced.\n\ *\n\ * DIF (output) DOUBLE PRECISION array, dimension (2).\n\ * If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.\n\ * If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on\n\ * Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based\n\ * estimates of Difu and Difl, computed using reversed\n\ * communication with ZLACN2.\n\ * If M = 0 or N, DIF(1:2) = F-norm([A, B]).\n\ * If IJOB = 0 or 1, DIF is not referenced.\n\ *\n\ * WORK (workspace/output) COMPLEX*16 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 >= 1\n\ * If IJOB = 1, 2 or 4, LWORK >= 2*M*(N-M)\n\ * If IJOB = 3 or 5, LWORK >= 4*M*(N-M)\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\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK. LIWORK >= 1.\n\ * If IJOB = 1, 2 or 4, LIWORK >= N+2;\n\ * If IJOB = 3 or 5, LIWORK >= MAX(N+2, 2*M*(N-M));\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal size of the IWORK array,\n\ * returns this value as the first entry of the IWORK array, and\n\ * no error message related to LIWORK 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\ * =1: Reordering of (A, B) failed because the transformed\n\ * matrix pair (A, B) would be too far from generalized\n\ * Schur form; the problem is very ill-conditioned.\n\ * (A, B) may have been partially reordered.\n\ * If requested, 0 is returned in DIF(*), PL and PR.\n\ *\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * ZTGSEN first collects the selected eigenvalues by computing unitary\n\ * U and W that move them to the top left corner of (A, B). In other\n\ * words, the selected eigenvalues are the eigenvalues of (A11, B11) in\n\ *\n\ * U'*(A, B)*W = (A11 A12) (B11 B12) n1\n\ * ( 0 A22),( 0 B22) n2\n\ * n1 n2 n1 n2\n\ *\n\ * where N = n1+n2 and U' means the conjugate transpose of U. The first\n\ * n1 columns of U and W span the specified pair of left and right\n\ * eigenspaces (deflating subspaces) of (A, B).\n\ *\n\ * If (A, B) has been obtained from the generalized real Schur\n\ * decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the\n\ * reordered generalized Schur form of (C, D) is given by\n\ *\n\ * (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',\n\ *\n\ * and the first n1 columns of Q*U and Z*W span the corresponding\n\ * deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).\n\ *\n\ * Note that if the selected eigenvalue is sufficiently ill-conditioned,\n\ * then its value may differ significantly from its value before\n\ * reordering.\n\ *\n\ * The reciprocal condition numbers of the left and right eigenspaces\n\ * spanned by the first n1 columns of U and W (or Q*U and Z*W) may\n\ * be returned in DIF(1:2), corresponding to Difu and Difl, resp.\n\ *\n\ * The Difu and Difl are defined as:\n\ *\n\ * Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )\n\ * and\n\ * Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],\n\ *\n\ * where sigma-min(Zu) is the smallest singular value of the\n\ * (2*n1*n2)-by-(2*n1*n2) matrix\n\ *\n\ * Zu = [ kron(In2, A11) -kron(A22', In1) ]\n\ * [ kron(In2, B11) -kron(B22', In1) ].\n\ *\n\ * Here, Inx is the identity matrix of size nx and A22' is the\n\ * transpose of A22. kron(X, Y) is the Kronecker product between\n\ * the matrices X and Y.\n\ *\n\ * When DIF(2) is small, small changes in (A, B) can cause large changes\n\ * in the deflating subspace. An approximate (asymptotic) bound on the\n\ * maximum angular error in the computed deflating subspaces is\n\ *\n\ * EPS * norm((A, B)) / DIF(2),\n\ *\n\ * where EPS is the machine precision.\n\ *\n\ * The reciprocal norm of the projectors on the left and right\n\ * eigenspaces associated with (A11, B11) may be returned in PL and PR.\n\ * They are computed as follows. First we compute L and R so that\n\ * P*(A, B)*Q is block diagonal, where\n\ *\n\ * P = ( I -L ) n1 Q = ( I R ) n1\n\ * ( 0 I ) n2 and ( 0 I ) n2\n\ * n1 n2 n1 n2\n\ *\n\ * and (L, R) is the solution to the generalized Sylvester equation\n\ *\n\ * A11*R - L*A22 = -A12\n\ * B11*R - L*B22 = -B12\n\ *\n\ * Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).\n\ * An approximate (asymptotic) bound on the average absolute error of\n\ * the selected eigenvalues is\n\ *\n\ * EPS * norm((A, B)) / PL.\n\ *\n\ * There are also global error bounds which valid for perturbations up\n\ * to a certain restriction: A lower bound (x) on the smallest\n\ * F-norm(E,F) for which an eigenvalue of (A11, B11) may move and\n\ * coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),\n\ * (i.e. (A + E, B + F), is\n\ *\n\ * x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).\n\ *\n\ * An approximate bound on x can be computed from DIF(1:2), PL and PR.\n\ *\n\ * If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed\n\ * (L', R') and unperturbed (L, R) left and right deflating subspaces\n\ * associated with the selected cluster in the (1,1)-blocks can be\n\ * bounded as\n\ *\n\ * max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))\n\ * max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))\n\ *\n\ * See LAPACK User's Guide section 4.11 or the following references\n\ * for more information.\n\ *\n\ * Note that if the default method for computing the Frobenius-norm-\n\ * based estimate DIF is not wanted (see ZLATDF), then the parameter\n\ * IDIFJB (see below) should be changed from 3 to 4 (routine ZLATDF\n\ * (IJOB = 2 will be used)). See ZTGSYL for more details.\n\ *\n\ * Based on contributions by\n\ * Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n\ * Umea University, S-901 87 Umea, Sweden.\n\ *\n\ * References\n\ * ==========\n\ *\n\ * [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n\ * Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n\ * M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n\ * Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n\ *\n\ * [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n\ * Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n\ * Estimation: Theory, Algorithms and Software, Report\n\ * UMINF - 94.04, Department of Computing Science, Umea University,\n\ * S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.\n\ * To appear in Numerical Algorithms, 1996.\n\ *\n\ * [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n\ * for Solving the Generalized Sylvester Equation and Estimating the\n\ * Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n\ * Department of Computing Science, Umea University, S-901 87 Umea,\n\ * Sweden, December 1993, Revised April 1994, Also as LAPACK working\n\ * Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,\n\ * 1996.\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cuncsd0000644000175000017500000002036212502223526016472 0ustar uwabamiuwabami--- :name: cuncsd :md5sum: d8aa106ce46e78717abfa350e82b3bf7 :category: :subroutine :arguments: - jobu1: :type: char :intent: input - jobu2: :type: char :intent: input - jobv1t: :type: char :intent: input - jobv2t: :type: char :intent: input - trans: :type: char :intent: input - signs: :type: char :intent: input - m: :type: integer :intent: input - p: :type: integer :intent: input - q: :type: integer :intent: input - x11: :type: complex :intent: input :dims: - p - q - ldx11: :type: integer :intent: input - x12: :type: complex :intent: input :dims: - p - m-q - ldx12: :type: integer :intent: input - x21: :type: complex :intent: input :dims: - p - q - ldx21: :type: integer :intent: input - x22: :type: complex :intent: input :dims: - p - m-q - ldx22: :type: integer :intent: input - theta: :type: real :intent: output :dims: - MIN(MIN(MIN(p,m-p),q),m-q) - u1: :type: complex :intent: output :dims: - p - ldu1: :type: integer :intent: input - u2: :type: complex :intent: output :dims: - m-p - ldu2: :type: integer :intent: input - v1t: :type: complex :intent: output :dims: - q - ldv1t: :type: integer :intent: input - v2t: :type: complex :intent: output :dims: - m-q - ldv2t: :type: integer :intent: input - work: :type: complex :intent: workspace :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input - rwork: :type: real :intent: workspace :dims: - MAX(1,lrwork) - lrwork: :type: integer :intent: input - iwork: :type: integer :intent: workspace :dims: - m-q - info: :type: integer :intent: output :substitutions: ldv2t: "lsame_(&jobv2t,\"Y\") ? MAX(1,m-q) : 0" ldv1t: "lsame_(&jobv1t,\"Y\") ? MAX(1,q) : 0" ldu1: "lsame_(&jobu1,\"Y\") ? MAX(1,p) : 0" ldu2: "lsame_(&jobu2,\"Y\") ? MAX(1,m-p) : 0" ldx11: p ldx12: p ldx21: p ldx22: p :fortran_help: " RECURSIVE SUBROUTINE CUNCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, WORK, LWORK, RWORK, LRWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CUNCSD computes the CS decomposition of an M-by-M partitioned\n\ * unitary matrix X:\n\ *\n\ * [ I 0 0 | 0 0 0 ]\n\ * [ 0 C 0 | 0 -S 0 ]\n\ * [ X11 | X12 ] [ U1 | ] [ 0 0 0 | 0 0 -I ] [ V1 | ]**H\n\ * X = [-----------] = [---------] [---------------------] [---------] .\n\ * [ X21 | X22 ] [ | U2 ] [ 0 0 0 | I 0 0 ] [ | V2 ]\n\ * [ 0 S 0 | 0 C 0 ]\n\ * [ 0 0 I | 0 0 0 ]\n\ *\n\ * X11 is P-by-Q. The unitary matrices U1, U2, V1, and V2 are P-by-P,\n\ * (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are\n\ * R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in\n\ * which R = MIN(P,M-P,Q,M-Q).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBU1 (input) CHARACTER\n\ * = 'Y': U1 is computed;\n\ * otherwise: U1 is not computed.\n\ *\n\ * JOBU2 (input) CHARACTER\n\ * = 'Y': U2 is computed;\n\ * otherwise: U2 is not computed.\n\ *\n\ * JOBV1T (input) CHARACTER\n\ * = 'Y': V1T is computed;\n\ * otherwise: V1T is not computed.\n\ *\n\ * JOBV2T (input) CHARACTER\n\ * = 'Y': V2T is computed;\n\ * otherwise: V2T is not computed.\n\ *\n\ * TRANS (input) CHARACTER\n\ * = 'T': X, U1, U2, V1T, and V2T are stored in row-major\n\ * order;\n\ * otherwise: X, U1, U2, V1T, and V2T are stored in column-\n\ * major order.\n\ *\n\ * SIGNS (input) CHARACTER\n\ * = 'O': The lower-left block is made nonpositive (the\n\ * \"other\" convention);\n\ * otherwise: The upper-right block is made nonpositive (the\n\ * \"default\" convention).\n\ *\n\ * M (input) INTEGER\n\ * The number of rows and columns in X.\n\ *\n\ * P (input) INTEGER\n\ * The number of rows in X11 and X12. 0 <= P <= M.\n\ *\n\ * Q (input) INTEGER\n\ * The number of columns in X11 and X21. 0 <= Q <= M.\n\ *\n\ * X (input/workspace) COMPLEX array, dimension (LDX,M)\n\ * On entry, the unitary matrix whose CSD is desired.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of X. LDX >= MAX(1,M).\n\ *\n\ * THETA (output) REAL array, dimension (R), in which R =\n\ * MIN(P,M-P,Q,M-Q).\n\ * C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and\n\ * S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).\n\ *\n\ * U1 (output) COMPLEX array, dimension (P)\n\ * If JOBU1 = 'Y', U1 contains the P-by-P unitary matrix U1.\n\ *\n\ * LDU1 (input) INTEGER\n\ * The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=\n\ * MAX(1,P).\n\ *\n\ * U2 (output) COMPLEX array, dimension (M-P)\n\ * If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) unitary\n\ * matrix U2.\n\ *\n\ * LDU2 (input) INTEGER\n\ * The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=\n\ * MAX(1,M-P).\n\ *\n\ * V1T (output) COMPLEX array, dimension (Q)\n\ * If JOBV1T = 'Y', V1T contains the Q-by-Q matrix unitary\n\ * matrix V1**H.\n\ *\n\ * LDV1T (input) INTEGER\n\ * The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=\n\ * MAX(1,Q).\n\ *\n\ * V2T (output) COMPLEX array, dimension (M-Q)\n\ * If JOBV2T = 'Y', V2T contains the (M-Q)-by-(M-Q) unitary\n\ * matrix V2**H.\n\ *\n\ * LDV2T (input) INTEGER\n\ * The leading dimension of V2T. If JOBV2T = 'Y', LDV2T >=\n\ * MAX(1,M-Q).\n\ *\n\ * WORK (workspace) COMPLEX 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\ *\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\ * RWORK (workspace) REAL array, dimension MAX(1,LRWORK)\n\ * On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n\ * If INFO > 0 on exit, RWORK(2:R) contains the values PHI(1),\n\ * ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),\n\ * define the matrix in intermediate bidiagonal-block form\n\ * remaining after nonconvergence. INFO specifies the number\n\ * of nonzero PHI's.\n\ *\n\ * LRWORK (input) INTEGER\n\ * The dimension of the array RWORK.\n\ *\n\ * If LRWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the optimal size of the RWORK array, returns\n\ * this value as the first entry of the work array, and no error\n\ * message related to LRWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (M-Q)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit.\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * > 0: CBBCSD did not converge. See the description of RWORK\n\ * above for details.\n\ *\n\ * Reference\n\ * =========\n\ *\n\ * [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.\n\ * Algorithms, 50(1):33-65, 2009.\n\ *\n\n\ * ===================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dla_syrpvgrw0000644000175000017500000000574512502223526017746 0ustar uwabamiuwabami--- :name: dla_syrpvgrw :md5sum: 801aa0fa7e5fb338b1f7a6dbea3e4b55 :category: :function :type: doublereal :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - info: :type: integer :intent: input - a: :type: doublereal :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublereal :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - work: :type: doublereal :intent: input :dims: - 2*n :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION DLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, WORK )\n\n\ * Purpose\n\ * =======\n\ * \n\ * DLA_SYRPVGRW computes the reciprocal pivot growth factor\n\ * norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n\ * much less than 1, the stability of the LU factorization of the\n\ * (equilibrated) matrix A could be poor. This also means that the\n\ * solution X, estimated condition numbers, and error bounds could be\n\ * unreliable.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * INFO (input) INTEGER\n\ * The value of INFO returned from DSYTRF, .i.e., the pivot in\n\ * column INFO is exactly 0.\n\ *\n\ * NCOLS (input) INTEGER\n\ * The number of columns of the matrix A. NCOLS >= 0.\n\ *\n\ * A (input) DOUBLE PRECISION array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) DOUBLE PRECISION array, dimension (LDAF,N)\n\ * The block diagonal matrix D and the multipliers used to\n\ * obtain the factor U or L as computed by DSYTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * Details of the interchanges and the block structure of D\n\ * as determined by DSYTRF.\n\ *\n\ * WORK (input) DOUBLE PRECISION array, dimension (2*N)\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER NCOLS, I, J, K, KP\n DOUBLE PRECISION AMAX, UMAX, RPVGRW, TMP\n LOGICAL UPPER\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, MIN\n\ * ..\n\ * .. External Functions ..\n EXTERNAL LSAME, DLASET\n LOGICAL LSAME\n\ * ..\n" ruby-lapack-1.7.2/dev/defs/dgesdd0000644000175000017500000001713712502223526016453 0ustar uwabamiuwabami--- :name: dgesdd :md5sum: 31309f179f21f12ed15aae51ac120086 :category: :subroutine :arguments: - jobz: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: doublereal :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - s: :type: doublereal :intent: output :dims: - MIN(m,n) - u: :type: doublereal :intent: output :dims: - ldu - ucol - ldu: :type: integer :intent: input - vt: :type: doublereal :intent: output :dims: - ldvt - n - ldvt: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"N\") ? 3*MIN(m,n)+MAX(MAX(m,n),7*MIN(m,n)) : lsame_(&jobz,\"O\") ? 3*MIN(m,n)+MAX(MAX(m,n),5*MIN(m,n)*MIN(m,n)+4*MIN(m,n)) : (lsame_(&jobz,\"S\")||lsame_(&jobz,\"A\")) ? 3*MIN(m,n)+MAX(MAX(m,n),4*MIN(m,n)*MIN(m,n)+4*MIN(m,n)) : 0" - iwork: :type: integer :intent: workspace :dims: - 8*MIN(m,n) - info: :type: integer :intent: output :substitutions: m: lda ucol: "((lsame_(&jobz,\"A\")) || (((lsame_(&jobz,\"O\")) && (m < n)))) ? m : lsame_(&jobz,\"S\") ? MIN(m,n) : 0" ldvt: "((lsame_(&jobz,\"A\")) || (((lsame_(&jobz,\"O\")) && (m >= n)))) ? n : lsame_(&jobz,\"S\") ? MIN(m,n) : 1" ldu: "(lsame_(&jobz,\"S\") || lsame_(&jobz,\"A\") || (lsame_(&jobz,\"O\") && m < n)) ? m : 1" :fortran_help: " SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DGESDD computes the singular value decomposition (SVD) of a real\n\ * M-by-N matrix A, optionally computing the left and right singular\n\ * vectors. If singular vectors are desired, it uses a\n\ * divide-and-conquer algorithm.\n\ *\n\ * The SVD is written\n\ *\n\ * A = U * SIGMA * transpose(V)\n\ *\n\ * where SIGMA is an M-by-N matrix which is zero except for its\n\ * min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and\n\ * V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA\n\ * are the singular values of A; they are real and non-negative, and\n\ * are returned in descending order. The first min(m,n) columns of\n\ * U and V are the left and right singular vectors of A.\n\ *\n\ * Note that the routine returns VT = V**T, not V.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * Specifies options for computing all or part of the matrix U:\n\ * = 'A': all M columns of U and all N rows of V**T are\n\ * returned in the arrays U and VT;\n\ * = 'S': the first min(M,N) columns of U and the first\n\ * min(M,N) rows of V**T are returned in the arrays U\n\ * and VT;\n\ * = 'O': If M >= N, the first N columns of U are overwritten\n\ * on the array A and all rows of V**T are returned in\n\ * the array VT;\n\ * otherwise, all columns of U are returned in the\n\ * array U and the first M rows of V**T are overwritten\n\ * in the array A;\n\ * = 'N': no columns of U or rows of V**T are computed.\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. 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,\n\ * if JOBZ = 'O', A is overwritten with the first N columns\n\ * of U (the left singular vectors, stored\n\ * columnwise) if M >= N;\n\ * A is overwritten with the first M rows\n\ * of V**T (the right singular vectors, stored\n\ * rowwise) otherwise.\n\ * if JOBZ .ne. 'O', the contents of A are destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * S (output) DOUBLE PRECISION array, dimension (min(M,N))\n\ * The singular values of A, sorted so that S(i) >= S(i+1).\n\ *\n\ * U (output) DOUBLE PRECISION array, dimension (LDU,UCOL)\n\ * UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;\n\ * UCOL = min(M,N) if JOBZ = 'S'.\n\ * If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M\n\ * orthogonal matrix U;\n\ * if JOBZ = 'S', U contains the first min(M,N) columns of U\n\ * (the left singular vectors, stored columnwise);\n\ * if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= 1; if\n\ * JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.\n\ *\n\ * VT (output) DOUBLE PRECISION array, dimension (LDVT,N)\n\ * If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the\n\ * N-by-N orthogonal matrix V**T;\n\ * if JOBZ = 'S', VT contains the first min(M,N) rows of\n\ * V**T (the right singular vectors, stored rowwise);\n\ * if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.\n\ *\n\ * LDVT (input) INTEGER\n\ * The leading dimension of the array VT. LDVT >= 1; if\n\ * JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;\n\ * if JOBZ = 'S', LDVT >= min(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. LWORK >= 1.\n\ * If JOBZ = 'N',\n\ * LWORK >= 3*min(M,N) + max(max(M,N),7*min(M,N)).\n\ * If JOBZ = 'O',\n\ * LWORK >= 3*min(M,N) + \n\ * max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)).\n\ * If JOBZ = 'S' or 'A'\n\ * LWORK >= 3*min(M,N) +\n\ * max(max(M,N),4*min(M,N)*min(M,N)+4*min(M,N)).\n\ * For good performance, LWORK should generally be larger.\n\ * If LWORK = -1 but other input arguments are legal, WORK(1)\n\ * returns the optimal LWORK.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (8*min(M,N))\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit.\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * > 0: DBDSDC did not converge, updating process failed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ming Gu and Huan Ren, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/sgesdd0000644000175000017500000001700512502223526016464 0ustar uwabamiuwabami--- :name: sgesdd :md5sum: 4cf2bd2eb74c4dd85a572b817ec81b1a :category: :subroutine :arguments: - jobz: :type: char :intent: input - m: :type: integer :intent: input - n: :type: integer :intent: input - a: :type: real :intent: input/output :dims: - lda - n - lda: :type: integer :intent: input - s: :type: real :intent: output :dims: - MIN(m,n) - u: :type: real :intent: output :dims: - ldu - ucol - ldu: :type: integer :intent: input - vt: :type: real :intent: output :dims: - ldvt - n - ldvt: :type: integer :intent: input - work: :type: real :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "lsame_(&jobz,\"N\") ? 3*MIN(m,n)+MAX(MAX(m,n),7*MIN(m,n)) : lsame_(&jobz,\"O\") ? 3*MIN(m,n)+MAX(MAX(m,n),5*MIN(m,n)*MIN(m,n)+4*MIN(m,n)) : (lsame_(&jobz,\"S\")||lsame_(&jobz,\"A\")) ? 3*MIN(m,n)+MAX(MAX(m,n),4*MIN(m,n)*MIN(m,n)+4*MIN(m,n)) : 0" - iwork: :type: integer :intent: workspace :dims: - 8*MIN(m,n) - info: :type: integer :intent: output :substitutions: m: lda ucol: "((lsame_(&jobz,\"A\")) || (((lsame_(&jobz,\"O\")) && (m < n)))) ? m : lsame_(&jobz,\"S\") ? MIN(m,n) : 0" ldvt: "((lsame_(&jobz,\"A\")) || (((lsame_(&jobz,\"O\")) && (m >= n)))) ? n : lsame_(&jobz,\"S\") ? MIN(m,n) : 1" ldu: "(lsame_(&jobz,\"S\") || lsame_(&jobz,\"A\") || (lsame_(&jobz,\"O\") && m < n)) ? m : 1" :fortran_help: " SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, IWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * SGESDD computes the singular value decomposition (SVD) of a real\n\ * M-by-N matrix A, optionally computing the left and right singular\n\ * vectors. If singular vectors are desired, it uses a\n\ * divide-and-conquer algorithm.\n\ *\n\ * The SVD is written\n\ *\n\ * A = U * SIGMA * transpose(V)\n\ *\n\ * where SIGMA is an M-by-N matrix which is zero except for its\n\ * min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and\n\ * V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA\n\ * are the singular values of A; they are real and non-negative, and\n\ * are returned in descending order. The first min(m,n) columns of\n\ * U and V are the left and right singular vectors of A.\n\ *\n\ * Note that the routine returns VT = V**T, not V.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * Specifies options for computing all or part of the matrix U:\n\ * = 'A': all M columns of U and all N rows of V**T are\n\ * returned in the arrays U and VT;\n\ * = 'S': the first min(M,N) columns of U and the first\n\ * min(M,N) rows of V**T are returned in the arrays U\n\ * and VT;\n\ * = 'O': If M >= N, the first N columns of U are overwritten\n\ * on the array A and all rows of V**T are returned in\n\ * the array VT;\n\ * otherwise, all columns of U are returned in the\n\ * array U and the first M rows of V**T are overwritten\n\ * in the array A;\n\ * = 'N': no columns of U or rows of V**T are computed.\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. N >= 0.\n\ *\n\ * A (input/output) REAL array, dimension (LDA,N)\n\ * On entry, the M-by-N matrix A.\n\ * On exit,\n\ * if JOBZ = 'O', A is overwritten with the first N columns\n\ * of U (the left singular vectors, stored\n\ * columnwise) if M >= N;\n\ * A is overwritten with the first M rows\n\ * of V**T (the right singular vectors, stored\n\ * rowwise) otherwise.\n\ * if JOBZ .ne. 'O', the contents of A are destroyed.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,M).\n\ *\n\ * S (output) REAL array, dimension (min(M,N))\n\ * The singular values of A, sorted so that S(i) >= S(i+1).\n\ *\n\ * U (output) REAL array, dimension (LDU,UCOL)\n\ * UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;\n\ * UCOL = min(M,N) if JOBZ = 'S'.\n\ * If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M\n\ * orthogonal matrix U;\n\ * if JOBZ = 'S', U contains the first min(M,N) columns of U\n\ * (the left singular vectors, stored columnwise);\n\ * if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.\n\ *\n\ * LDU (input) INTEGER\n\ * The leading dimension of the array U. LDU >= 1; if\n\ * JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.\n\ *\n\ * VT (output) REAL array, dimension (LDVT,N)\n\ * If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the\n\ * N-by-N orthogonal matrix V**T;\n\ * if JOBZ = 'S', VT contains the first min(M,N) rows of\n\ * V**T (the right singular vectors, stored rowwise);\n\ * if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.\n\ *\n\ * LDVT (input) INTEGER\n\ * The leading dimension of the array VT. LDVT >= 1; if\n\ * JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;\n\ * if JOBZ = 'S', LDVT >= min(M,N).\n\ *\n\ * WORK (workspace/output) REAL 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 >= 1.\n\ * If JOBZ = 'N',\n\ * LWORK >= 3*min(M,N) + max(max(M,N),6*min(M,N)).\n\ * If JOBZ = 'O',\n\ * LWORK >= 3*min(M,N) + \n\ * max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)).\n\ * If JOBZ = 'S' or 'A'\n\ * LWORK >= 3*min(M,N) +\n\ * max(max(M,N),4*min(M,N)*min(M,N)+4*min(M,N)).\n\ * For good performance, LWORK should generally be larger.\n\ * If LWORK = -1 but other input arguments are legal, WORK(1)\n\ * returns the optimal LWORK.\n\ *\n\ * IWORK (workspace) INTEGER array, dimension (8*min(M,N))\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: successful exit.\n\ * < 0: if INFO = -i, the i-th argument had an illegal value.\n\ * > 0: SBDSDC did not converge, updating process failed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Ming Gu and Huan Ren, Computer Science Division, University of\n\ * California at Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/slarrc0000644000175000017500000000535512502223526016506 0ustar uwabamiuwabami--- :name: slarrc :md5sum: 4fc70568a595ea2437abc06e26daf307 :category: :subroutine :arguments: - jobt: :type: char :intent: input - n: :type: integer :intent: input - vl: :type: real :intent: input - vu: :type: real :intent: input - d: :type: real :intent: input :dims: - n - e: :type: real :intent: input :dims: - n - pivmin: :type: real :intent: input - eigcnt: :type: integer :intent: output - lcnt: :type: integer :intent: output - rcnt: :type: integer :intent: output - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE SLARRC( JOBT, N, VL, VU, D, E, PIVMIN, EIGCNT, LCNT, RCNT, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * Find the number of eigenvalues of the symmetric tridiagonal matrix T\n\ * that are in the interval (VL,VU] if JOBT = 'T', and of L D L^T\n\ * if JOBT = 'L'.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBT (input) CHARACTER*1\n\ * = 'T': Compute Sturm count for matrix T.\n\ * = 'L': Compute Sturm count for matrix L D L^T.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix. N > 0.\n\ *\n\ * VL (input) DOUBLE PRECISION\n\ * VU (input) DOUBLE PRECISION\n\ * The lower and upper bounds for the eigenvalues.\n\ *\n\ * D (input) DOUBLE PRECISION array, dimension (N)\n\ * JOBT = 'T': The N diagonal elements of the tridiagonal matrix T.\n\ * JOBT = 'L': The N diagonal elements of the diagonal matrix D.\n\ *\n\ * E (input) DOUBLE PRECISION array, dimension (N)\n\ * JOBT = 'T': The N-1 offdiagonal elements of the matrix T.\n\ * JOBT = 'L': The N-1 offdiagonal elements of the matrix L.\n\ *\n\ * PIVMIN (input) REAL\n\ * The minimum pivot in the Sturm sequence for T.\n\ *\n\ * EIGCNT (output) INTEGER\n\ * The number of eigenvalues of the symmetric tridiagonal matrix T\n\ * that are in the interval (VL,VU]\n\ *\n\ * LCNT (output) INTEGER\n\ * RCNT (output) INTEGER\n\ * The left and right negcounts of the interval.\n\ *\n\ * INFO (output) INTEGER\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Beresford Parlett, University of California, Berkeley, USA\n\ * Jim Demmel, University of California, Berkeley, USA\n\ * Inderjit Dhillon, University of Texas, Austin, USA\n\ * Osni Marques, LBNL/NERSC, USA\n\ * Christof Voemel, University of California, Berkeley, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/dsbgvd0000644000175000017500000001703212502223526016464 0ustar uwabamiuwabami--- :name: dsbgvd :md5sum: abed2add2591a833e7d03dc10381944d :category: :subroutine :arguments: - jobz: :type: char :intent: input - uplo: :type: char :intent: input - n: :type: integer :intent: input - ka: :type: integer :intent: input - kb: :type: integer :intent: input - ab: :type: doublereal :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - bb: :type: doublereal :intent: input/output :dims: - ldbb - n - ldbb: :type: integer :intent: input - w: :type: doublereal :intent: output :dims: - n - z: :type: doublereal :intent: output :dims: - ldz - n - ldz: :type: integer :intent: input - work: :type: doublereal :intent: output :dims: - MAX(1,lwork) - lwork: :type: integer :intent: input :option: true :default: "n<=1 ? 1 : lsame_(&jobz,\"N\") ? 3*n : lsame_(&jobz,\"V\") ? 1+5*n+2*n*n : 0" - iwork: :type: integer :intent: output :dims: - MAX(1,liwork) - liwork: :type: integer :intent: input :option: true :default: "(lsame_(&jobz,\"N\")||n<=0) ? 1 : lsame_(&jobz,\"V\") ? 3+5*n : 0" - info: :type: integer :intent: output :substitutions: ldz: "lsame_(&jobz,\"V\") ? MAX(1,n) : 1" :fortran_help: " SUBROUTINE DSBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * DSBGVD computes all the eigenvalues, and optionally, the eigenvectors\n\ * of a real generalized symmetric-definite banded eigenproblem, of the\n\ * form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric and\n\ * banded, and B is also positive definite. If eigenvectors are\n\ * desired, it uses a divide and conquer algorithm.\n\ *\n\ * The divide and conquer algorithm makes very mild assumptions about\n\ * floating point arithmetic. It will work on machines with a guard\n\ * digit in add/subtract, or on those binary machines without guard\n\ * digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n\ * Cray-2. It could conceivably fail on hexadecimal or decimal machines\n\ * without guard digits, but we know of none.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * JOBZ (input) CHARACTER*1\n\ * = 'N': Compute eigenvalues only;\n\ * = 'V': Compute eigenvalues and eigenvectors.\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangles of A and B are stored;\n\ * = 'L': Lower triangles of A and B are stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrices A and B. N >= 0.\n\ *\n\ * KA (input) INTEGER\n\ * The number of superdiagonals of the matrix A if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n\ *\n\ * KB (input) INTEGER\n\ * The number of superdiagonals of the matrix B if UPLO = 'U',\n\ * or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n\ *\n\ * AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix A, stored in the first ka+1 rows of the array. The\n\ * j-th column of A is stored in the j-th column of the array AB\n\ * as follows:\n\ * if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n\ * if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).\n\ *\n\ * On exit, the contents of AB are destroyed.\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KA+1.\n\ *\n\ * BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N)\n\ * On entry, the upper or lower triangle of the symmetric band\n\ * matrix B, stored in the first kb+1 rows of the array. The\n\ * j-th column of B is stored in the j-th column of the array BB\n\ * as follows:\n\ * if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n\ * if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).\n\ *\n\ * On exit, the factor S from the split Cholesky factorization\n\ * B = S**T*S, as returned by DPBSTF.\n\ *\n\ * LDBB (input) INTEGER\n\ * The leading dimension of the array BB. LDBB >= KB+1.\n\ *\n\ * W (output) DOUBLE PRECISION array, dimension (N)\n\ * If INFO = 0, the eigenvalues in ascending order.\n\ *\n\ * Z (output) DOUBLE PRECISION array, dimension (LDZ, N)\n\ * If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n\ * eigenvectors, with the i-th column of Z holding the\n\ * eigenvector associated with W(i). The eigenvectors are\n\ * normalized so Z**T*B*Z = I.\n\ * If JOBZ = 'N', then Z is not referenced.\n\ *\n\ * LDZ (input) INTEGER\n\ * The leading dimension of the array Z. LDZ >= 1, and if\n\ * JOBZ = 'V', LDZ >= max(1,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\ * If N <= 1, LWORK >= 1.\n\ * If JOBZ = 'N' and N > 1, LWORK >= 3*N.\n\ * If JOBZ = 'V' and N > 1, LWORK >= 1 + 5*N + 2*N**2.\n\ *\n\ * If LWORK = -1, then a workspace query is assumed; the routine\n\ * only calculates the optimal sizes of the WORK and IWORK\n\ * arrays, returns these values as the first entries of the WORK\n\ * and IWORK arrays, and no error message related to LWORK or\n\ * LIWORK is issued by XERBLA.\n\ *\n\ * IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n\ * On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK.\n\ *\n\ * LIWORK (input) INTEGER\n\ * The dimension of the array IWORK.\n\ * If JOBZ = 'N' or N <= 1, LIWORK >= 1.\n\ * If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n\ *\n\ * If LIWORK = -1, then a workspace query is assumed; the\n\ * routine only calculates the optimal sizes of the WORK and\n\ * IWORK arrays, returns these values as the first entries of\n\ * the WORK and IWORK arrays, and no error message related to\n\ * LWORK or LIWORK 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, and i is:\n\ * <= N: the algorithm failed to converge:\n\ * i off-diagonal elements of an intermediate\n\ * tridiagonal form did not converge to zero;\n\ * > N: if INFO = N + i, for 1 <= i <= N, then DPBSTF\n\ * returned INFO = i: B is not positive definite.\n\ * The factorization of B could not be completed and\n\ * no eigenvalues or eigenvectors were computed.\n\ *\n\n\ * Further Details\n\ * ===============\n\ *\n\ * Based on contributions by\n\ * Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n\ *\n\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgbrfsx0000644000175000017500000004242012502223525016647 0ustar uwabamiuwabami--- :name: cgbrfsx :md5sum: 28dea64997d0d586014683ff61054a97 :category: :subroutine :arguments: - trans: :type: char :intent: input - equed: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: doublereal :intent: input :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: doublereal :intent: input :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input :dims: - n - r: :type: real :intent: input/output :dims: - n - c: :type: real :intent: input/output :dims: - n - b: :type: real :intent: input :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: input/output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: n_err_bnds: "3" :fortran_help: " SUBROUTINE CGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGBRFSX improves the computed solution to a system of linear\n\ * equations and provides error bounds and backward error estimates\n\ * for the solution. In addition to normwise error bound, the code\n\ * provides maximum componentwise error bound if possible. See\n\ * comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n\ * error bounds.\n\ *\n\ * The original system of linear equations may have been equilibrated\n\ * before calling this routine, as described by arguments EQUED, R\n\ * and C below. In this case, the solution and error bounds returned\n\ * are for the original unequilibrated system.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate transpose = Transpose)\n\ *\n\ * EQUED (input) CHARACTER*1\n\ * Specifies the form of equilibration that was done to A\n\ * before calling this routine. This is needed to compute\n\ * the solution and error bounds correctly.\n\ * = 'N': No equilibration\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ * The right hand side B has been changed accordingly.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AB (input) DOUBLE PRECISION array, dimension (LDAB,N)\n\ * The original band matrix A, stored in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n\ * Details of the LU factorization of the band matrix A, as\n\ * computed by DGBTRF. U is stored as an upper triangular band\n\ * matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n\ * the multipliers used during the factorization are stored in\n\ * rows KL+KU+2 to 2*KL+KU+1.\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.\n\ *\n\ * IPIV (input) INTEGER array, dimension (N)\n\ * The pivot indices from SGETRF; for 1<=i<=N, row i of the\n\ * matrix was interchanged with row IPIV(i).\n\ *\n\ * R (input or output) REAL array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'R' or 'B', A is\n\ * multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n\ * is not accessed. R is an input argument if FACT = 'F';\n\ * otherwise, R is an output argument. If FACT = 'F' and\n\ * EQUED = 'R' or 'B', each element of R must be positive.\n\ * If R is output, each element of R is a power of the radix.\n\ * If R is input, each element of R should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * C (input or output) REAL array, dimension (N)\n\ * The column scale factors for A. If EQUED = 'C' or 'B', A is\n\ * multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n\ * is not accessed. C is an input argument if FACT = 'F';\n\ * otherwise, C is an output argument. If FACT = 'F' and\n\ * EQUED = 'C' or 'B', each element of C must be positive.\n\ * If C is output, each element of C is a power of the radix.\n\ * If C is input, each element of C should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input) REAL array, dimension (LDB,NRHS)\n\ * The right hand side matrix B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (input/output) REAL array, dimension (LDX,NRHS)\n\ * On entry, the solution matrix X, as computed by SGETRS.\n\ * On exit, the improved solution matrix X.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * BERR (output) REAL array, dimension (NRHS)\n\ * Componentwise relative backward error. This is the\n\ * componentwise relative backward error of each solution vector X(j)\n\ * (i.e., the smallest relative change in any element of A or B that\n\ * makes X(j) an exact solution).\n\ *\n\ * N_ERR_BNDS (input) INTEGER\n\ * Number of error bounds to return for each right hand side\n\ * and each type (normwise or componentwise). See ERR_BNDS_NORM and\n\ * ERR_BNDS_COMP below.\n\ *\n\ * ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * normwise relative error, which is defined as follows:\n\ *\n\ * Normwise relative error in the ith solution vector:\n\ * max_j (abs(XTRUE(j,i) - X(j,i)))\n\ * ------------------------------\n\ * max_j abs(X(j,i))\n\ *\n\ * The array is indexed by the type of error information as described\n\ * below. There currently are up to three pieces of information\n\ * returned.\n\ *\n\ * The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_NORM(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated normwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*A, where S scales each row by a power of the\n\ * radix so all absolute row sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n\ * For each right-hand side, this array contains information about\n\ * various error bounds and condition numbers corresponding to the\n\ * componentwise relative error, which is defined as follows:\n\ *\n\ * Componentwise relative error in the ith solution vector:\n\ * abs(XTRUE(j,i) - X(j,i))\n\ * max_j ----------------------\n\ * abs(X(j,i))\n\ *\n\ * The array is indexed by the right-hand side i (on which the\n\ * componentwise relative error depends), and the type of error\n\ * information as described below. There currently are up to three\n\ * pieces of information returned for each right-hand side. If\n\ * componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n\ * ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most\n\ * the first (:,N_ERR_BNDS) entries are returned.\n\ *\n\ * The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n\ * right-hand side.\n\ *\n\ * The second index in ERR_BNDS_COMP(:,err) contains the following\n\ * three fields:\n\ * err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n\ * reciprocal condition number is less than the threshold\n\ * sqrt(n) * slamch('Epsilon').\n\ *\n\ * err = 2 \"Guaranteed\" error bound: The estimated forward error,\n\ * almost certainly within a factor of 10 of the true error\n\ * so long as the next entry is greater than the threshold\n\ * sqrt(n) * slamch('Epsilon'). This error bound should only\n\ * be trusted if the previous boolean is true.\n\ *\n\ * err = 3 Reciprocal condition number: Estimated componentwise\n\ * reciprocal condition number. Compared with the threshold\n\ * sqrt(n) * slamch('Epsilon') to determine if the error\n\ * estimate is \"guaranteed\". These reciprocal condition\n\ * numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n\ * appropriately scaled matrix Z.\n\ * Let Z = S*(A*diag(x)), where x is the solution for the\n\ * current right-hand side and S scales each row of\n\ * A*diag(x) by a power of the radix so all absolute row\n\ * sums of Z are approximately 1.\n\ *\n\ * See Lapack Working Note 165 for further details and extra\n\ * cautions.\n\ *\n\ * NPARAMS (input) INTEGER\n\ * Specifies the number of parameters set in PARAMS. If .LE. 0, the\n\ * PARAMS array is never referenced and default values are used.\n\ *\n\ * PARAMS (input / output) REAL array, dimension NPARAMS\n\ * Specifies algorithm parameters. If an entry is .LT. 0.0, then\n\ * that entry will be filled with default value used for that\n\ * parameter. Only positions up to NPARAMS are accessed; defaults\n\ * are used for higher-numbered parameters.\n\ *\n\ * PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n\ * refinement or not.\n\ * Default: 1.0\n\ * = 0.0 : No refinement is performed, and no error bounds are\n\ * computed.\n\ * = 1.0 : Use the double-precision refinement algorithm,\n\ * possibly with doubled-single computations if the\n\ * compilation environment does not support DOUBLE\n\ * PRECISION.\n\ * (other values are reserved for future use)\n\ *\n\ * PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n\ * computations allowed for refinement.\n\ * Default: 10\n\ * Aggressive: Set to 100 to permit convergence using approximate\n\ * factorizations or factorizations other than LU. If\n\ * the factorization uses a technique other than\n\ * Gaussian elimination, the guarantees in\n\ * err_bnds_norm and err_bnds_comp may no longer be\n\ * trustworthy.\n\ *\n\ * PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n\ * will attempt to find a solution with small componentwise\n\ * relative error in the double-precision algorithm. Positive\n\ * is true, 0.0 is false.\n\ * Default: 1.0 (attempt componentwise convergence)\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (2*N)\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit. The solution to every right-hand side is\n\ * guaranteed.\n\ * < 0: If INFO = -i, the i-th argument had an illegal value\n\ * > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cpocon0000644000175000017500000000464712502223525016503 0ustar uwabamiuwabami--- :name: cpocon :md5sum: 0582d260e85edffd69e2b598d76d7f02 :category: :subroutine :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: complex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - anorm: :type: real :intent: input - rcond: :type: real :intent: output - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - n - info: :type: integer :intent: output :substitutions: {} :fortran_help: " SUBROUTINE CPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CPOCON estimates the reciprocal of the condition number (in the\n\ * 1-norm) of a complex Hermitian positive definite matrix using the\n\ * Cholesky factorization A = U**H*U or A = L*L**H computed by CPOTRF.\n\ *\n\ * An estimate is obtained for norm(inv(A)), and the reciprocal of the\n\ * condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The order of the matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX array, dimension (LDA,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**H*U or A = L*L**H, as computed by CPOTRF.\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * ANORM (input) REAL\n\ * The 1-norm (or infinity-norm) of the Hermitian matrix A.\n\ *\n\ * RCOND (output) REAL\n\ * The reciprocal of the condition number of the matrix A,\n\ * computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n\ * estimate of the 1-norm of inv(A) computed in this routine.\n\ *\n\ * WORK (workspace) COMPLEX array, dimension (2*N)\n\ *\n\ * RWORK (workspace) REAL array, dimension (N)\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\ * =====================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/cgbsvxx0000644000175000017500000005637312502223525016711 0ustar uwabamiuwabami--- :name: cgbsvxx :md5sum: 801194546c21b97849616b544a6977ee :category: :subroutine :arguments: - fact: :type: char :intent: input - trans: :type: char :intent: input - n: :type: integer :intent: input - kl: :type: integer :intent: input - ku: :type: integer :intent: input - nrhs: :type: integer :intent: input - ab: :type: real :intent: input/output :dims: - ldab - n - ldab: :type: integer :intent: input - afb: :type: real :intent: input/output :dims: - ldafb - n - ldafb: :type: integer :intent: input - ipiv: :type: integer :intent: input/output :dims: - n - equed: :type: char :intent: input/output - r: :type: real :intent: input/output :dims: - n - c: :type: real :intent: input/output :dims: - n - b: :type: real :intent: input/output :dims: - ldb - nrhs - ldb: :type: integer :intent: input - x: :type: real :intent: output :dims: - ldx - nrhs - ldx: :type: integer :intent: input - rcond: :type: real :intent: output - rpvgrw: :type: real :intent: output - berr: :type: real :intent: output :dims: - nrhs - n_err_bnds: :type: integer :intent: input - err_bnds_norm: :type: real :intent: output :dims: - nrhs - n_err_bnds - err_bnds_comp: :type: real :intent: output :dims: - nrhs - n_err_bnds - nparams: :type: integer :intent: input - params: :type: real :intent: input/output :dims: - nparams - work: :type: complex :intent: workspace :dims: - 2*n - rwork: :type: real :intent: workspace :dims: - 2*n - info: :type: integer :intent: output :substitutions: ldx: MAX(1,n) n_err_bnds: "3" :fortran_help: " SUBROUTINE CGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n\ * Purpose\n\ * =======\n\ *\n\ * CGBSVXX uses the LU factorization to compute the solution to a\n\ * complex system of linear equations A * X = B, where A is an\n\ * N-by-N matrix and X and B are N-by-NRHS matrices.\n\ *\n\ * If requested, both normwise and maximum componentwise error bounds\n\ * are returned. CGBSVXX will return a solution with a tiny\n\ * guaranteed error (O(eps) where eps is the working machine\n\ * precision) unless the matrix is very ill-conditioned, in which\n\ * case a warning is returned. Relevant condition numbers also are\n\ * calculated and returned.\n\ *\n\ * CGBSVXX accepts user-provided factorizations and equilibration\n\ * factors; see the definitions of the FACT and EQUED options.\n\ * Solving with refinement and using a factorization from a previous\n\ * CGBSVXX call will also produce a solution with either O(eps)\n\ * errors or warnings, but we cannot make that claim for general\n\ * user-provided factorizations and equilibration factors if they\n\ * differ from what CGBSVXX would itself produce.\n\ *\n\ * Description\n\ * ===========\n\ *\n\ * The following steps are performed:\n\ *\n\ * 1. If FACT = 'E', real scaling factors are computed to equilibrate\n\ * the system:\n\ *\n\ * TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B\n\ * TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n\ * TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n\ *\n\ * Whether or not the system will be equilibrated depends on the\n\ * scaling of the matrix A, but if equilibration is used, A is\n\ * overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n\ * or diag(C)*B (if TRANS = 'T' or 'C').\n\ *\n\ * 2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n\ * the matrix A (after equilibration if FACT = 'E') as\n\ *\n\ * A = P * L * U,\n\ *\n\ * where P is a permutation matrix, L is a unit lower triangular\n\ * matrix, and U is upper triangular.\n\ *\n\ * 3. If some U(i,i)=0, so that U is exactly singular, then the\n\ * routine returns with INFO = i. Otherwise, the factored form of A\n\ * is used to estimate the condition number of the matrix A (see\n\ * argument RCOND). If the reciprocal of the condition number is less\n\ * than machine precision, the routine still goes on to solve for X\n\ * and compute error bounds as described below.\n\ *\n\ * 4. The system of equations is solved for X using the factored form\n\ * of A.\n\ *\n\ * 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n\ * the routine will use iterative refinement to try to get a small\n\ * error and error bounds. Refinement calculates the residual to at\n\ * least twice the working precision.\n\ *\n\ * 6. If equilibration was used, the matrix X is premultiplied by\n\ * diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n\ * that it solves the original system before equilibration.\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * Some optional parameters are bundled in the PARAMS array. These\n\ * settings determine how refinement is performed, but often the\n\ * defaults are acceptable. If the defaults are acceptable, users\n\ * can pass NPARAMS = 0 which prevents the source code from accessing\n\ * the PARAMS argument.\n\ *\n\ * FACT (input) CHARACTER*1\n\ * Specifies whether or not the factored form of the matrix A is\n\ * supplied on entry, and if not, whether the matrix A should be\n\ * equilibrated before it is factored.\n\ * = 'F': On entry, AF and IPIV contain the factored form of A.\n\ * If EQUED is not 'N', the matrix A has been\n\ * equilibrated with scaling factors given by R and C.\n\ * A, AF, and IPIV are not modified.\n\ * = 'N': The matrix A will be copied to AF and factored.\n\ * = 'E': The matrix A will be equilibrated if necessary, then\n\ * copied to AF and factored.\n\ *\n\ * TRANS (input) CHARACTER*1\n\ * Specifies the form of the system of equations:\n\ * = 'N': A * X = B (No transpose)\n\ * = 'T': A**T * X = B (Transpose)\n\ * = 'C': A**H * X = B (Conjugate Transpose = Transpose)\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * KL (input) INTEGER\n\ * The number of subdiagonals within the band of A. KL >= 0.\n\ *\n\ * KU (input) INTEGER\n\ * The number of superdiagonals within the band of A. KU >= 0.\n\ *\n\ * NRHS (input) INTEGER\n\ * The number of right hand sides, i.e., the number of columns\n\ * of the matrices B and X. NRHS >= 0.\n\ *\n\ * AB (input/output) REAL array, dimension (LDAB,N)\n\ * On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n\ * The j-th column of A is stored in the j-th column of the\n\ * array AB as follows:\n\ * AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n\ *\n\ * If FACT = 'F' and EQUED is not 'N', then AB must have been\n\ * equilibrated by the scaling factors in R and/or C. AB is not\n\ * modified if FACT = 'F' or 'N', or if FACT = 'E' and\n\ * EQUED = 'N' on exit.\n\ *\n\ * On exit, if EQUED .ne. 'N', A is scaled as follows:\n\ * EQUED = 'R': A := diag(R) * A\n\ * EQUED = 'C': A := A * diag(C)\n\ * EQUED = 'B': A := diag(R) * A * diag(C).\n\ *\n\ * LDAB (input) INTEGER\n\ * The leading dimension of the array AB. LDAB >= KL+KU+1.\n\ *\n\ * AFB (input or output) REAL array, dimension (LDAFB,N)\n\ * If FACT = 'F', then AFB is an input argument and on entry\n\ * contains details of the LU factorization of the band matrix\n\ * A, as computed by CGBTRF. U is stored as an upper triangular\n\ * band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n\ * and the multipliers used during the factorization are stored\n\ * in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is\n\ * the factored form of the equilibrated matrix A.\n\ *\n\ * If FACT = 'N', then AF is an output argument and on exit\n\ * returns the factors L and U from the factorization A = P*L*U\n\ * of the original matrix A.\n\ *\n\ * If FACT = 'E', then AF is an output argument and on exit\n\ * returns the factors L and U from the factorization A = P*L*U\n\ * of the equilibrated matrix A (see the description of A for\n\ * the form of the equilibrated matrix).\n\ *\n\ * LDAFB (input) INTEGER\n\ * The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.\n\ *\n\ * IPIV (input or output) INTEGER array, dimension (N)\n\ * If FACT = 'F', then IPIV is an input argument and on entry\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * as computed by SGETRF; row i of the matrix was interchanged\n\ * with row IPIV(i).\n\ *\n\ * If FACT = 'N', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * of the original matrix A.\n\ *\n\ * If FACT = 'E', then IPIV is an output argument and on exit\n\ * contains the pivot indices from the factorization A = P*L*U\n\ * of the equilibrated matrix A.\n\ *\n\ * EQUED (input or output) CHARACTER*1\n\ * Specifies the form of equilibration that was done.\n\ * = 'N': No equilibration (always true if FACT = 'N').\n\ * = 'R': Row equilibration, i.e., A has been premultiplied by\n\ * diag(R).\n\ * = 'C': Column equilibration, i.e., A has been postmultiplied\n\ * by diag(C).\n\ * = 'B': Both row and column equilibration, i.e., A has been\n\ * replaced by diag(R) * A * diag(C).\n\ * EQUED is an input argument if FACT = 'F'; otherwise, it is an\n\ * output argument.\n\ *\n\ * R (input or output) REAL array, dimension (N)\n\ * The row scale factors for A. If EQUED = 'R' or 'B', A is\n\ * multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n\ * is not accessed. R is an input argument if FACT = 'F';\n\ * otherwise, R is an output argument. If FACT = 'F' and\n\ * EQUED = 'R' or 'B', each element of R must be positive.\n\ * If R is output, each element of R is a power of the radix.\n\ * If R is input, each element of R should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * C (input or output) REAL array, dimension (N)\n\ * The column scale factors for A. If EQUED = 'C' or 'B', A is\n\ * multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n\ * is not accessed. C is an input argument if FACT = 'F';\n\ * otherwise, C is an output argument. If FACT = 'F' and\n\ * EQUED = 'C' or 'B', each element of C must be positive.\n\ * If C is output, each element of C is a power of the radix.\n\ * If C is input, each element of C should be a power of the radix\n\ * to ensure a reliable solution and error estimates. Scaling by\n\ * powers of the radix does not cause rounding errors unless the\n\ * result underflows or overflows. Rounding errors during scaling\n\ * lead to refining with a matrix that is not equivalent to the\n\ * input matrix, producing error estimates that may not be\n\ * reliable.\n\ *\n\ * B (input/output) REAL array, dimension (LDB,NRHS)\n\ * On entry, the N-by-NRHS right hand side matrix B.\n\ * On exit,\n\ * if EQUED = 'N', B is not modified;\n\ * if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n\ * diag(R)*B;\n\ * if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n\ * overwritten by diag(C)*B.\n\ *\n\ * LDB (input) INTEGER\n\ * The leading dimension of the array B. LDB >= max(1,N).\n\ *\n\ * X (output) REAL array, dimension (LDX,NRHS)\n\ * If INFO = 0, the N-by-NRHS solution matrix X to the original\n\ * system of equations. Note that A and B are modified on exit\n\ * if EQUED .ne. 'N', and the solution to the equilibrated system is\n\ * inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n\ * inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n\ *\n\ * LDX (input) INTEGER\n\ * The leading dimension of the array X. LDX >= max(1,N).\n\ *\n\ * RCOND (output) REAL\n\ * Reciprocal scaled condition number. This is an estimate of the\n\ * reciprocal Skeel condition number of the matrix A after\n\ * equilibration (if done). If this is less than the machine\n\ * precision (in particular, if it is zero), the matrix is singular\n\ * to working precision. Note that the error may still be small even\n\ * if this number is very small and the matrix appears ill-\n\ * conditioned.\n\ *\n\ * RPVGRW (output) REAL\n\ * Reciprocal pivot growth. On exit, this contains the reciprocal\n\ * pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n\ * norm is used. If this is much less than 1, then the stability of\n\ * the LU factorization of the (equilibrated) matrix A could be poor.\n\ * This also means that the solution X, estimated condition numbers,\n\ * and error bounds could be unreliable. If factorization fails with\n\ * 0 0 and <= N: U(INFO,INFO) is exactly zero. The factorization\n\ * has been completed, but the factor U is exactly singular, so\n\ * the solution and error bounds could not be computed. RCOND = 0\n\ * is returned.\n\ * = N+J: The solution corresponding to the Jth right-hand side is\n\ * not guaranteed. The solutions corresponding to other right-\n\ * hand sides K with K > J may not be guaranteed as well, but\n\ * only the first such right-hand side is reported. If a small\n\ * componentwise error is not requested (PARAMS(3) = 0.0) then\n\ * the Jth right-hand side is the first with a normwise error\n\ * bound that is not guaranteed (the smallest J such\n\ * that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n\ * the Jth right-hand side is the first with either a normwise or\n\ * componentwise error bound that is not guaranteed (the smallest\n\ * J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n\ * ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n\ * ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n\ * about all of the right-hand sides check ERR_BNDS_NORM or\n\ * ERR_BNDS_COMP.\n\ *\n\n\ * ==================================================================\n\ *\n" ruby-lapack-1.7.2/dev/defs/zla_porcond_c0000644000175000017500000000655112502223526020033 0ustar uwabamiuwabami--- :name: zla_porcond_c :md5sum: 7f972d94051304574e069015710f2e69 :category: :function :type: doublereal :arguments: - uplo: :type: char :intent: input - n: :type: integer :intent: input - a: :type: doublecomplex :intent: input :dims: - lda - n - lda: :type: integer :intent: input - af: :type: doublecomplex :intent: input :dims: - ldaf - n - ldaf: :type: integer :intent: input - c: :type: doublereal :intent: input :dims: - n - capply: :type: logical :intent: input - info: :type: integer :intent: output - work: :type: doublecomplex :intent: input :dims: - 2*n - rwork: :type: doublereal :intent: input :dims: - n :substitutions: {} :fortran_help: " DOUBLE PRECISION FUNCTION ZLA_PORCOND_C( UPLO, N, A, LDA, AF, LDAF, C, CAPPLY, INFO, WORK, RWORK )\n\n\ * Purpose\n\ * =======\n\ *\n\ * ZLA_PORCOND_C Computes the infinity norm condition number of\n\ * op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector\n\ *\n\n\ * Arguments\n\ * =========\n\ *\n\ * UPLO (input) CHARACTER*1\n\ * = 'U': Upper triangle of A is stored;\n\ * = 'L': Lower triangle of A is stored.\n\ *\n\ * N (input) INTEGER\n\ * The number of linear equations, i.e., the order of the\n\ * matrix A. N >= 0.\n\ *\n\ * A (input) COMPLEX*16 array, dimension (LDA,N)\n\ * On entry, the N-by-N matrix A\n\ *\n\ * LDA (input) INTEGER\n\ * The leading dimension of the array A. LDA >= max(1,N).\n\ *\n\ * AF (input) COMPLEX*16 array, dimension (LDAF,N)\n\ * The triangular factor U or L from the Cholesky factorization\n\ * A = U**T*U or A = L*L**T, as computed by ZPOTRF.\n\ *\n\ * LDAF (input) INTEGER\n\ * The leading dimension of the array AF. LDAF >= max(1,N).\n\ *\n\ * C (input) DOUBLE PRECISION array, dimension (N)\n\ * The vector C in the formula op(A) * inv(diag(C)).\n\ *\n\ * CAPPLY (input) LOGICAL\n\ * If .TRUE. then access the vector C in the formula above.\n\ *\n\ * INFO (output) INTEGER\n\ * = 0: Successful exit.\n\ * i > 0: The ith argument is invalid.\n\ *\n\ * WORK (input) COMPLEX*16 array, dimension (2*N).\n\ * Workspace.\n\ *\n\ * RWORK (input) DOUBLE PRECISION array, dimension (N).\n\ * Workspace.\n\ *\n\n\ * =====================================================================\n\ *\n\ * .. Local Scalars ..\n INTEGER KASE\n DOUBLE PRECISION AINVNM, ANORM, TMP\n INTEGER I, J\n LOGICAL UP\n COMPLEX*16 ZDUM\n\ * ..\n\ * .. Local Arrays ..\n INTEGER ISAVE( 3 )\n\ * ..\n\ * .. External Functions ..\n LOGICAL LSAME\n EXTERNAL LSAME\n\ * ..\n\ * .. External Subroutines ..\n EXTERNAL ZLACN2, ZPOTRS, XERBLA\n\ * ..\n\ * .. Intrinsic Functions ..\n INTRINSIC ABS, MAX, REAL, DIMAG\n\ * ..\n\ * .. Statement Functions ..\n DOUBLE PRECISION CABS1\n\ * ..\n\ * .. Statement Function Definitions ..\n CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n\ * ..\n" ruby-lapack-1.7.2/dev/mkdoc.rb0000644000175000017500000001406412502223526015773 0ustar uwabamiuwabamiDataTypes = [ ["S", "REAL"], ["D", "DOUBLE PRECISION"], ["C", "COMPLEX"], ["Z", "COMPLEX*16 or DOUBLE COMPLEX"], ["DS", "Data type in double but solving problem using single precision"], ["ZC", "Data type in complex*16 but solving problem using complex precision"] ] MatrixTypes = [ ["BD", "bidiagonal"], ["DI", "diagonal"], ["GB", "general band"], ["GE", "general (i.e., unsymmetric, in some cases rectangular)"], ["GG", "general matrices, generalized problem (i.e., a pair of general matrices)"], ["GT", "general tridiagonal"], ["HB", "(complex) Hermitian band"], ["HE", "(complex) Hermitian"], ["HG", "upper Hessenberg matrix, generalized problem (i.e a Hessenberg and a triangular matrix)"], ["HP", "(complex) Hermitian, packed storage"], ["HS", "upper Hessenberg"], ["OP", "(real) orthogonal, packed storage"], ["OR", "(real) orthogonal"], ["PB", "symmetric or Hermitian positive definite band"], ["PO", "symmetric or Hermitian positive definite"], ["PP", "symmetric or Hermitian positive definite, packed storage"], ["PT", "symmetric or Hermitian positive definite tridiagonal"], ["SB", "(real) symmetric band"], ["SP", "symmetric, packed storage"], ["ST", "(real) symmetric tridiagonal"], ["SY", "symmetric"], ["TB", "triangular band"], ["TG", "triangular matrices, generalized problem (i.e., a pair of triangular matrices)"], ["TP", "triangular, packed storage"], ["TR", "triangular (or in some cases quasi-triangular)"], ["TZ", "trapezoidal"], ["UN", "(complex) unitary"], ["UP", "(complex) unitary, packed storageBDbidiagonal"] ] require "numru/lapack" include NumRu prefix = File.dirname(__FILE__)+"/../doc" desc = Hash.new methods = Lapack.singleton_methods dts = Hash.new DataTypes.each{|cdt, dt| cdt = cdt.downcase dmethods = Array.new methods.each{|m| dmethods.push m if /^#{cdt}/ =~ m } dmethods.each do |m| methods.delete m end mts = Array.new MatrixTypes.each{|cmt, mt| cmt = cmt.downcase reg = /^#{cdt}#{cmt}/ ms = Array.new dmethods.each{|m| next unless reg =~ m ms.push m } ms.sort! unless ms.empty? mts.push [cmt,mt] dts[cmt] ||= Array.new dts[cmt].push [cdt, dt] File.open(File.join(prefix,"#{cdt}#{cmt}.html"),"w"){|file| file.print <<"EOF" #{dt} routines for #{mt} matrix

#{dt} routines for #{mt} matrix

    EOF ms.each{|m| file.print <<"EOF"
  • #{m}
    • EOF } file.print <<"EOF"
EOF ms.each{|m| file.print <<"EOF"

#{m}

EOF
          IO.popen("-") do |io|
            if io # parent
              file.print io.read
            else # child
              Lapack.send(m, :help => true)
            end
          end
          file.print <<"EOF"
go to the page top EOF } file.print <<"EOF"
back to matrix types
back to data types EOF } end } unless mts.empty? File.open(File.join(prefix,"#{cdt}.html"),"w"){|file| file.print <<"EOF" #{dt} routines

#{dt} routines

back to index.html EOF } end } MatrixTypes.each do |cmt,mt| cmt = cmt.downcase if dts[cmt] File.open(File.join(prefix,"#{cmt}.html"),"w") do |file| file.print <<"EOF" #{mt} routines

#{mt} routines

back to index.html EOF end end end if methods.any? File.open(File.join(prefix,"others.html"),"w") do |file| file.print < other routines

other routines

    EOF methods.each do |m| file.print <#{m} EOF end file.print < EOF methods.each do |m| file.print <

    #{m}

    EOF
      IO.popen("-") do |io|
        if io # parent
          file.print io.read
        else # child
          Lapack.send(m, :help => true)
        end
      end
      file.print <
    go to the page top

EOF
    end
    file.print <<"EOF"
    
    
    back to index
  

EOF
  end
end

File.open(File.join(prefix,"index.html"),"w"){|file|
  file.print <<"EOF"

  
    LAPACK routines
  
  
    
    Data types
    
    
      
EOF
  DataTypes.each{|cdt,dt|
    file.print "      
    • #{cdt}: #{dt}
      • \n"
  }
  file.print <<"EOF"
    
    

    
    Matrix types
    
    
      
EOF
  MatrixTypes.each do |cmt,mt|
    if dts[cmt.downcase]
      file.print "     
    • #{cmt}: #{mt}
      • \n"
    end
  end
  file.print <<"EOF"
    
    
EOF
  if methods.any?
    file.print <others
    
EOF
  end
  file.print <<"EOF"
  

EOF
}
ruby-lapack-1.7.2/dev/parse.rb0000644000175000017500000015300512655767354016034 0ustar  uwabamiuwabami$:.unshift File.dirname(__FILE__)

require "yaml"
require "digest/md5"
require "pp"
require "common"

CTYPES = {
  "INTEGER" => "integer",
  "CHARACTER" => "char",
  "REAL" => "real",
  "DOUBLE PRECISION" => "doublereal",
  "COMPLEX" => "complex",
  "COMPLEX*16" => "doublecomplex",
  "DOUBLE COMPLEX" => "doublecomplex",
  "LOGICAL" => "logical"
}

ARGS = {
  "csyequb" => {
    "uplo" => {:intent => "input", :type => "char"},
    "work" => {:intent => "input", :type => "real"}
  },
  "zsyequb" => {
    "uplo" => {:intent => "input", :type => "char"},
    "work" => {:intent => "input", :type => "doublereal"}
  },
  "zhfrk" => {
    "uplo" => {:intent => "input", :type => "char"},
    "trans" => {:intent => "input", :type => "char"},
    "n" => {:intent => "input", :type => "integer"},
    "k" => {:intent => "input", :type => "integer"},
    "alpha" => {:intent => "input", :type => "doublereal"},
    "beta" => {:intent => "input", :type => "doublereal"},
    "a" => {:intent => "input", :type => "doublereal"},
    "lda" => {:intent => "input", :type => "integer"},
    "c" => {:intent => "input", :type => "doublereal"},
  },
  "zpstf2" => {
    "work" => {:intent => "input", :type => "doublereal"}
  },
  "ssfrk" => {
    "uplo" => {:intent => "input", :type => "char"},
    "trans" => {:intent => "input", :type => "char"},
    "n" => {:intent => "input", :type => "integer"},
    "k" => {:intent => "input", :type => "integer"},
    "alpha" => {:intent => "input", :type => "real"},
    "beta" => {:intent => "input", :type => "real"},
    "a" => {:intent => "input", :type => "real"},
    "lda" => {:intent => "input", :type => "integer"},
    "c" => {:intent => "input", :type => "real"},
  },
  "dsfrk" => {
    "uplo" => {:intent => "input", :type => "char"},
    "trans" => {:intent => "input", :type => "char"},
    "n" => {:intent => "input", :type => "integer"},
    "k" => {:intent => "input", :type => "integer"},
    "alpha" => {:intent => "input", :type => "doublereal"},
    "beta" => {:intent => "input", :type => "doublereal"},
    "a" => {:intent => "input", :type => "doublereal"},
    "lda" => {:intent => "input", :type => "integer"},
    "c" => {:intent => "input", :type => "doublereal"},
  },
  "spstf2" => {
    "work" => {:intent => "input", :type => "real"}
  },
  "cheequb" => {
    "uplo" => {:intent => "input", :type => "char"},
    "work" => {:intent => "input", :type => "complex"}
  },
  "zheequb" => {
    "uplo" => {:intent => "input", :type => "char"},
    "work" => {:intent => "input", :type => "doublecomplex"}
  },
  "dsyequb" => {
    "uplo" => {:intent => "input", :type => "char"},
    "work" => {:intent => "input", :type => "doublereal"}
  },
  "chesvxx" => {
    "uplo" => {:intent => "input", :type => "char"}
  },
  "zhesvxx" => {
    "uplo" => {:intent => "input", :type => "char"}
  },
  "dgesvj" => {
    "lwork" => {:intent => "input", :type => "integer"}
  },
  "dpstf2" => {
    "work" => {:intent => "input", :type => "doublereal"}
  },
  "cpstf2" => {
    "work" => {:intent => "input", :type => "real"}
  },
  "spstrf" => {
    "work" => {:intent => "input", :type => "real"}
  },
  "dpstrf" => {
    "work" => {:intent => "input", :type => "doublereal"}
  },
  "zpstrf" => {
    "work" => {:intent => "input", :type => "doublereal"}
  },
  "cpstrf" => {
    "work" => {:intent => "input", :type => "doublereal"}
  },
  "sgesvj" => {
    "lwork" => {:intent => "input", :type => "integer"}
  },
  "sla_lin_berr" => {
    "berr" => {:intent => "output", :type => "real"}
  },
  "dla_lin_berr" => {
    "berr" => {:intent => "output", :type => "doublereal"}
  },
  "ssyequb" => {
    "uplo" => {:intent => "input", :type => "char"},
    "work" => {:intent => "input", :type => "real"},
  },
  "slasq4" => {
    "n0in" => {:intent => "input", :type => "integer"},
  },
  "dlasq4" => {
    "n0in" => {:intent => "input", :type => "integer"},
  },
  "slaqr1" => {
    "si1" => {:intent => "input", :type => "real"},
    "sr2" => {:intent => "input", :type => "real"},
    "si2" => {:intent => "input", :type => "real"},
  },
  "dlaqr1" => {
    "si1" => {:intent => "input", :type => "doublereal"},
    "sr2" => {:intent => "input", :type => "doublereal"},
    "si2" => {:intent => "input", :type => "doublereal"},
  },
  "claqr1" => {
    "s2" => {:intent => "input", :type => "complex"},
  },
  "zlaqr1" => {
    "s2" => {:intent => "input", :type => "doublecomplex"},
  },
  "slarrf" => {
    "clgapl" => {:intent => "input", :type => "real"},
    "clgapr" => {:intent => "input", :type => "real"},
    "info" => {:intent => "output", :type => "integer"},
  },
  "dlarrf" => {
    "clgapl" => {:intent => "input", :type => "doublereal"},
    "clgapr" => {:intent => "input", :type => "doublereal"},
    "info" => {:intent => "output", :type => "integer"},
  }
}

DIMS = {
  "strttp" => {
    "ap" => ["n*(n+1)/2"]
  },
  "dtrttp" => {
    "ap" => ["n*(n+1)/2"]
  },
  "stftri" => {
    "a" => ["n*(n+1)/2"]
  },
  "dtftri" => {
    "a" => ["n*(n+1)/2"]
  },
  "zpstrf" => {
    "work" => ["2*n"]
  },
  "spftrf" => {
    "a" => ["n*(n+1)/2"]
  },
  "cpftrf" => {
    "a" => ["n*(n+1)/2"]
  },
  "cpftrs" => {
    "a" => ["n*(n+1)/2"]
  },
  "zpftrs" => {
    "a" => ["n*(n+1)/2"]
  },
  "strttf" => {
    "arf" => ["n*(n+1)/2"]
  },
  "dtrttf" => {
    "arf" => ["n*(n+1)/2"]
  },
  "sla_gbrfsx_extended" => {
    "ab" => ["ldab", "n"]
  },
  "stgex2" => {
    "work" => ["lwork"]
  },
  "dtgex2" => {
    "work" => ["lwork"]
  },
  "dlasd1" => {
    "d" => ["n"]
  },
  "slaruv" => {
    "x" => ["MAX(1,n)"]
  },
  "dlaruv" => {
    "x" => ["MAX(1,n)"]
  },
  "slasyf" => {
    "w" => ["ldw","MAX(1,nb)"]
  },
  "dlasyf" => {
    "w" => ["ldw","MAX(1,nb)"]
  },
  "clasyf" => {
    "w" => ["ldw","MAX(1,nb)"]
  },
  "zlasyf" => {
    "w" => ["ldw","MAX(1,nb)"]
  },
  "slaeda" => {
    "qptr" => ["ldqptr"]
  },
  "dlaeda" => {
    "qptr" => ["ldqptr"]
  },
  "slasdt" => {
    "inode" => ["MAX(1,n)"],
    "ndiml" => ["MAX(1,n)"],
    "ndimr" => ["MAX(1,n)"],
  },
  "dlasdt" => {
    "inode" => ["MAX(1,n)"],
    "ndiml" => ["MAX(1,n)"],
    "ndimr" => ["MAX(1,n)"],
  },
  "sgbequ" => {
    "r" => ["MAX(1,m)"]
  },
  "dgbequ" => {
    "r" => ["MAX(1,m)"]
  },
  "cgbequ" => {
    "r" => ["MAX(1,m)"]
  },
  "zgbequ" => {
    "r" => ["MAX(1,m)"]
  },
  "slaed9" => {
    "d" => ["MAX(1,n)"],
    "q" => ["ldq", "MAX(1,n)"]
  },
  "dlaed9" => {
    "d" => ["MAX(1,n)"],
    "q" => ["ldq", "MAX(1,n)"]
  },
  "slarnv" => {
    "x" => ["MAX(1,n)"],
  },
  "dlarnv" => {
    "x" => ["MAX(1,n)"],
  },
  "clarnv" => {
    "x" => ["MAX(1,n)"],
  },
  "zlarnv" => {
    "x" => ["MAX(1,n)"]
  },
  "slabrd" => {
    "d" => ["MAX(1,nb)"],
    "e" => ["MAX(1,nb)"],
    "tauq" => ["MAX(1,nb)"],
    "taup" => ["MAX(1,nb)"],
    "x" => ["ldx", "MAX(1,nb)"],
    "y" => ["ldy", "MAX(1,nb)"],
  },
  "dlabrd" => {
    "d" => ["MAX(1,nb)"],
    "e" => ["MAX(1,nb)"],
    "tauq" => ["MAX(1,nb)"],
    "taup" => ["MAX(1,nb)"],
    "x" => ["ldx", "MAX(1,nb)"],
    "y" => ["ldy", "MAX(1,nb)"],
  },
  "clabrd" => {
    "d" => ["MAX(1,nb)"],
    "e" => ["MAX(1,nb)"],
    "tauq" => ["MAX(1,nb)"],
    "taup" => ["MAX(1,nb)"],
    "x" => ["ldx", "MAX(1,nb)"],
    "y" => ["ldy", "MAX(1,nb)"],
  },
  "zlabrd" => {
    "d" => ["MAX(1,nb)"],
    "e" => ["MAX(1,nb)"],
    "tauq" => ["MAX(1,nb)"],
    "taup" => ["MAX(1,nb)"],
    "x" => ["ldx", "MAX(1,nb)"],
    "y" => ["ldy", "MAX(1,nb)"],
  },
  "slahr2" => {
    "tau" => ["MAX(1,nb)"],
    "t" => ["ldt","MAX(1,nb)"],
    "y" => ["ldy","MAX(1,nb)"],
  },
  "dlahr2" => {
    "tau" => ["MAX(1,nb)"],
    "t" => ["ldt","MAX(1,nb)"],
    "y" => ["ldy","MAX(1,nb)"],
  },
  "clahr2" => {
    "tau" => ["MAX(1,nb)"],
    "t" => ["ldt","MAX(1,nb)"],
    "y" => ["ldy","MAX(1,nb)"],
  },
  "zlahr2" => {
    "tau" => ["MAX(1,nb)"],
    "t" => ["ldt","MAX(1,nb)"],
    "y" => ["ldy","MAX(1,nb)"],
  },
  "slahrd" => {
    "tau" => ["MAX(1,nb)"],
    "t" => ["ldt","MAX(1,nb)"],
    "y" => ["ldy","MAX(1,nb)"],
  },
  "dlahrd" => {
    "tau" => ["MAX(1,nb)"],
    "t" => ["ldt","MAX(1,nb)"],
    "y" => ["ldy","MAX(1,nb)"],
  },
  "clahrd" => {
    "tau" => ["MAX(1,nb)"],
    "t" => ["ldt","MAX(1,nb)"],
    "y" => ["ldy","MAX(1,nb)"],
  },
  "zlahrd" => {
    "tau" => ["MAX(1,nb)"],
    "t" => ["ldt","MAX(1,nb)"],
    "y" => ["ldy","MAX(1,nb)"],
  },
  "slaqr2" => {
    "sr" => ["MAX(1,kbot)"],
    "si" => ["MAX(1,kbot)"],
    "v" => ["ldv", "MAX(1,nw)"],
    "t" => ["ldt", "MAX(1,nw)"],
    "wv" => ["ldwv", "MAX(1,nw)"],
  },
  "dlaqr2" => {
    "sr" => ["MAX(1,kbot)"],
    "si" => ["MAX(1,kbot)"],
    "v" => ["ldv", "MAX(1,nw)"],
    "t" => ["ldt", "MAX(1,nw)"],
    "wv" => ["ldwv", "MAX(1,nw)"],
  },
  "claqr2" => {
    "sh" => ["MAX(1,kbot)"],
    "v" => ["ldv", "MAX(1,nw)"],
    "t" => ["ldv", "MAX(1,nw)"],
    "wv" => ["ldv", "MAX(1,nw)"],
  },
  "zlaqr2" => {
    "sh" => ["MAX(1,kbot)"],
    "v" => ["ldv", "MAX(1,nw)"],
    "t" => ["ldv", "MAX(1,nw)"],
    "wv" => ["ldv", "MAX(1,nw)"],
  },
  "slaqr3" => {
    "sr" => ["MAX(1,kbot)"],
    "si" => ["MAX(1,kbot)"],
    "v" => ["ldv", "MAX(1,nw)"],
    "t" => ["ldt", "MAX(1,nw)"],
    "wv" => ["ldwv", "MAX(1,nw)"],
  },
  "dlaqr3" => {
    "sr" => ["MAX(1,kbot)"],
    "si" => ["MAX(1,kbot)"],
    "v" => ["ldv", "MAX(1,nw)"],
    "t" => ["ldt", "MAX(1,nw)"],
    "wv" => ["ldwv", "MAX(1,nw)"],
  },
  "claqr3" => {
    "sh" => ["MAX(1,kbot)"],
    "v" => ["ldv", "MAX(1,nw)"],
    "t" => ["ldv", "MAX(1,nw)"],
    "wv" => ["ldv", "MAX(1,nw)"],
  },
  "zlaqr3" => {
    "sh" => ["MAX(1,kbot)"],
    "v" => ["ldv", "MAX(1,nw)"],
    "t" => ["ldv", "MAX(1,nw)"],
    "wv" => ["ldv", "MAX(1,nw)"],
  },
  "slatrd" => {
    "w" => ["ldw", "MAX(n,nb)"]
  },
  "dlatrd" => {
    "w" => ["ldw", "MAX(n,nb)"]
  },
  "clatrd" => {
    "w" => ["ldw", "MAX(n,nb)"]
  },
  "zlatrd" => {
    "w" => ["ldw", "MAX(n,nb)"]
  },
  "clahef" => {
    "w" => ["ldw", "MAX(n,nb)"]
  },
  "zlahef" => {
    "w" => ["ldw", "MAX(n,nb)"]
  },
  "sopgtr" => {
    "ap" => ["ldap"],
    "tau" => ["ldtau"],
  },
  "dopgtr" => {
    "ap" => ["ldap"],
    "tau" => ["ldtau"],
  },
  "cupgtr" => {
    "ap" => ["ldap"],
    "tau" => ["ldtau"],
  },
  "zupgtr" => {
    "ap" => ["ldap"],
    "tau" => ["ldtau"],
  },
  "ssptrd" => {
    "ap" => ["ldap"]
  },
  "dsptrd" => {
    "ap" => ["ldap"]
  },
  "chptrd" => {
    "ap" => ["ldap"]
  },
  "zhptrd" => {
    "ap" => ["ldap"]
  },
  "sspgv" => {
    "ap" => ["ldap"]
  },
  "chpev" => {
    "ap" => ["ldap"],
  },
  "zhpev" => {
    "ap" => ["ldap"],
  },
  "chpevx" => {
    "ap" => ["ldap"],
  },
  "zhpevx" => {
    "ap" => ["ldap"],
  },
  "dspgv" => {
    "ap" => ["ldap"]
  },
  "sppequ" => {
    "ap" => ["ldap"]
  },
  "dppequ" => {
    "ap" => ["ldap"]
  },
  "cppequ" => {
    "ap" => ["ldap"]
  },
  "zppequ" => {
    "ap" => ["ldap"]
  },
  "sspgvd" => {
    "ap" => ["ldap"]
  },
  "dspgvd" => {
    "ap" => ["ldap"]
  },
  "stpcon" => {
    "ap" => ["ldap"]
  },
  "dtpcon" => {
    "ap" => ["ldap"]
  },
  "ctpcon" => {
    "ap" => ["ldap"]
  },
  "ztpcon" => {
    "ap" => ["ldap"]
  },
  "sspgvx" => {
    "ap" => ["ldap"],
  },
  "dspgvx" => {
    "ap" => ["ldap"],
  },
  "chpevd" => {
    "ap" => ["ldap"],
  },
  "zhpevd" => {
    "ap" => ["ldap"],
  },
  "sspev" => {
    "ap" => ["ldap"],
  },
  "dspev" => {
    "ap" => ["ldap"],
  },
  "sspevd" => {
    "ap" => ["ldap"],
  },
  "dspevd" => {
    "ap" => ["ldap"],
  },
  "sspevx" => {
    "ap" => ["ldap"],
  },
  "dspevx" => {
    "ap" => ["ldap"],
  },
  "sppcon" => {
    "ap" => ["ldap"]
  },
  "dppcon" => {
    "ap" => ["ldap"]
  },
  "cppcon" => {
    "ap" => ["ldap"]
  },
  "zppcon" => {
    "ap" => ["ldap"]
  },
  "chpgv" => {
    "ap" => ["ldap"]
  },
  "zhpgv" => {
    "ap" => ["ldap"]
  },
  "chpgvd" => {
    "ap" => ["ldap"]
  },
  "zhpgvd" => {
    "ap" => ["ldap"]
  },
  "chpgvx" => {
    "ap" => ["ldap"]
  },
  "zhpgvx" => {
    "ap" => ["ldap"]
  },
  "chptrf" => {
    "ap" => ["ldap"]
  },
  "zhptrf" => {
    "ap" => ["ldap"]
  },
  "ssptrf" => {
    "ap" => ["ldap"]
  },
  "dsptrf" => {
    "ap" => ["ldap"]
  },
  "csptrf" => {
    "ap" => ["ldap"]
  },
  "zsptrf" => {
    "ap" => ["ldap"]
  },
  "slaqr0" => {
    "z" => ["ldz","ihi"]
  },
  "dlaqr0" => {
    "z" => ["ldz","ihi"]
  },
  "claqr0" => {
    "z" => ["ldz","ihi"],
    "work" => ["MAX(1,lwork)"]
  },
  "zlaqr0" => {
    "z" => ["wantz ? ldz : 0","wantz ? ihi : 0"],
    "work" => ["MAX(1,lwork)"]
  },
  "slaqr4" => {
    "z" => ["ldz","ihi"]
  },
  "dlaqr4" => {
    "z" => ["ldz","ihi"]
  },
  "claqr4" => {
    "z" => ["ldz","ihi"]
  },
  "zlaqr4" => {
    "z" => ["ldz","ihi"]
  },
  "slaqr5" => {
    "z" => ["wantz ? ldz : 0","wantz ? ihiz : 0"],
    "wh" => ["ldwh", "MAX(1,nh)"]
  },
  "dlaqr5" => {
    "z" => ["wantz ? ldz : 0","wantz ? ihiz : 0"],
    "wh" => ["ldwh", "MAX(1,nh)"]
  },
  "claqr5" => {
    "z" => ["wantz ? ldz : 0","wantz ? ihiz : 0"],
    "wh" => ["ldwh", "MAX(1,nh)"]
  },
  "zlaqr5" => {
    "z" => ["wantz ? ldz : 0","wantz ? ihiz : 0"],
    "wh" => ["ldwh", "MAX(1,nh)"]
  },
  "slasd0" => {
    "u" => ["ldu", "n"]
  },
  "dlasd0" => {
    "u" => ["ldu", "n"]
  },
  "slasd4" => {
    "delta" => ["n"],
    "work" => ["n"]
  },
  "dlasd4" => {
    "delta" => ["n"],
    "work" => ["n"]
  },
  "slasdq" => {
    "e" => ['sqre==0 ? n-1 : sqre==1 ? n : 0'],
    "work" => ["4*n"]
  },
  "dlasdq" => {
    "e" => ['sqre==0 ? n-1 : sqre==1 ? n : 0'],
    "work" => ["4*n"]
  },
  "slaed3" => {
    "q2" => ["n","n"]
  },
  "dlaed3" => {
    "q2" => ["n","n"]
  },
  "slaed4" => {
    "delta" => ["n"]
  },
  "dlaed4" => {
    "delta" => ["n"]
  },
  "slaed8" => {
    "q" => ['icompq==0 ? 0 : ldq', 'icompq==0 ? 0 : n'],
    "q2" => ['icompq==0 ? 0 : ldq2', 'icompq==0 ? 0 : n']
  },
  "dlaed8" => {
    "q" => ['icompq==0 ? 0 : ldq', 'icompq==0 ? 0 : n'],
    "q2" => ['icompq==0 ? 0 : ldq2', 'icompq==0 ? 0 : n']
  },
  "claed8" => {
    "q2" => ['ldq2', 'n']
  },
  "zlaed8" => {
    "q2" => ['ldq2', 'n']
  },
  "slasq3" => {
    "z" => ['4*n0']
  },
  "dlasq3" => {
    "z" => ['4*n0']
  },
  "slasq4" => {
    "z" => ['4*n0']
  },
  "dlasq4" => {
    "z" => ['4*n0']
  },
  "slasq5" => {
    "z" => ['4*n0']
  },
  "dlasq5" => {
    "z" => ['4*n0']
  },
  "slasq6" => {
    "z" => ['4*n0']
  },
  "dlasq6" => {
    "z" => ['4*n0']
  },
  "slazq3" => {
    "z" => ['4*n0']
  },
  "dlazq3" => {
    "z" => ['4*n0']
  },
  "slazq4" => {
    "z" => ['4*n0']
  },
  "dlazq4" => {
    "z" => ['4*n0']
  },
  "slahqr" => {
    "z" => ['wantz ? ldz : 0', 'wantz ? n : 0']
  },
  "dlahqr" => {
    "z" => ['wantz ? ldz : 0', 'wantz ? n : 0']
  },
  "clahqr" => {
    "z" => ['wantz ? ldz : 0', 'wantz ? n : 0']
  },
  "zlahqr" => {
    "z" => ['wantz ? ldz : 0', 'wantz ? n : 0']
  },
  "cpbsvx" => {
    "afb" => ["ldafb","n"]
  },
  "dgesdd" => {
    "vt" => ["ldvt","n"]
  },
  "slasda" => {
    "u" => ["ldu", "MAX(1,smlsiz)"],
    "s" => ['icompq==1 ? n : icompq==0 ? 1 : 0']
  },
  "dlasda" => {
    "u" => ["ldu", "MAX(1,smlsiz)"],
    "s" => ['icompq==1 ? n : icompq==0 ? 1 : 0']
  },
  "clalsa" => {
    "rwork" => ['MAX(n,(smlsiz+1)*nrhs*3)']
  },
  "zlalsa" => {
    "rwork" => ['MAX(n,(smlsiz+1)*nrhs*3)']
  },
  "stgsen" => {
    "iwork" => ['ijob==0 ? 0 : MAX(1,liwork)']
  },
  "dtgsen" => {
    "iwork" => ['ijob==0 ? 0 : MAX(1,liwork)']
  },
  "ztgsen" => {
    "work" => ['ijob==0 ? 0 : MAX(1,lwork)'],
    "iwork" => ['ijob==0 ? 0 : MAX(1,liwork)']
  },
  "ctgsen" => {
    "work" => ['ijob==0 ? 0 : MAX(1,lwork)'],
    "iwork" => ['ijob==0 ? 0 : MAX(1,liwork)']
  },
  "slarfx" => {
    "work" => ['lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0']
  },
  "dlarfx" => {
    "work" => ['lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0']
  },
  "clarfx" => {
    "work" => ['lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0']
  },
  "zlarfx" => {
    "work" => ['lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0']
  },
  "slaebz" => {
    "nval" => ['(ijob==1||ijob==2) ? 0 : ijob==3 ? minp : 0'],
    "c" => ['ijob==1 ? 0 : (ijob==2||ijob==3) ? mmax : 0'],
    "nab" => ['mmax', '2']
  },
  "dlaebz" => {
    "nval" => ['(ijob==1||ijob==2) ? 0 : ijob==3 ? minp : 0'],
    "c" => ['ijob==1 ? 0 : (ijob==2||ijob==3) ? mmax : 0'],
    "nab" => ['mmax', '2']
  },
  "sbdsdc" => {
    "u" => ['lsame_(&compq,"I") ? ldu : 0','lsame_(&compq,"I") ? n : 0'],
    "vt" => ['lsame_(&compq,"I") ? ldvt : 0','lsame_(&compq,"I") ? n : 0'],
    "q" => ['lsame_(&compq,"I") ? ldq : 0'],
    "iq" => ['lsame_(&compq,"I") ? ldiq : 0'],
    "work" => ['MAX(1,lwork)']
  },
  "dbdsdc" => {
    "u" => ['lsame_(&compq,"I") ? ldu : 0','lsame_(&compq,"I") ? n : 0'],
    "vt" => ['lsame_(&compq,"I") ? ldvt : 0','lsame_(&compq,"I") ? n : 0'],
    "q" => ['lsame_(&compq,"I") ? ldq : 0'],
    "iq" => ['lsame_(&compq,"I") ? ldiq : 0'],
    "work" => ['MAX(1,lwork)']
  },
  "sgelsx" => {
    "work" => ['MAX((MIN(m,n))+3*n,2*(MIN(m,n))*nrhs)']
  },
  "dgelsx" => {
    "work" => ['MAX((MIN(m,n))+3*n,2*(MIN(m,n))*nrhs)']
  },
  "cgelsx" => {
    "work" => ['MIN(m,n) + MAX(n,2*(MIN(m,n))+nrhs)']
  },
  "zgelsx" => {
    "work" => ['MIN(m,n) + MAX(n,2*(MIN(m,n))+nrhs)']
  },
  "sgeevx" => {
    "iwork" => ['(lsame_(&sense,"N")||lsame_(&sense,"E")) ? 0 : 2*n-2']
  },
  "dgeevx" => {
    "iwork" => ['(lsame_(&sense,"N")||lsame_(&sense,"E")) ? 0 : 2*n-2']
  },
  "ctgex2" => {
    "q" => ['wantq ? ldq : 0', 'wantq ? n : 0'],
    "z" => ['wantq ? ldz : 0', 'wantq ? n : 0']
  },
  "ztgex2" => {
    "q" => ['wantq ? ldq : 0', 'wantq ? n : 0'],
    "z" => ['wantq ? ldz : 0', 'wantq ? n : 0']
  },
  "clalsd" => {
    "rwork" => ['9*n+2*n*smlsiz+8*n*nlvl+3*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1)']
  },
  "zlalsd" => {
    "rwork" => ['9*n+2*n*smlsiz+8*n*nlvl+3*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1)']
  },
  "ssbgvx" => {
    "work" => ['7*n'],
    "iwork" => ['5*n'],
  }
}


TYPES = {
  "slarrc" => {
    "vl" => "real",
    "vu" => "real",
    "d" => "real",
    "e" => "real",
    "pivmin" => "real"
  },
  "slarrb" => {
    "pivmin" => "real",
    "spdiam" => "real"
  },
  "slarre" => {
    "pivmin" => "real"
  },
  "slarrf" => {
    "pivmin" => "real",
    "spdiam" => "real"
  },
  "dlarrf" => {
    "spdiam" => "doublereal"
  },
  "slarrj" => {
    "pivmin" => "real",
    "spdiam" => "real"
  },
  "slarrv" => {
    "pivmin" => "real"
  },
  "clarrv" =>{
    "pivmin" => "real"
  },
  "zggbal" => {
    "work" => "doublereal"
  },
  "clarcm" => {
    "b" => "complex"
  },
  "zlarcm" => {
    "b" => "doublecomplex"
  },
  "clatdf" => {
    "z" => "complex",
    "rhs" => "complex",
  },
  "zlatdf" => {
    "z" => "doublecomplex",
    "rhs" => "doublecomplex",
  },
  "dggbal" => {
    "work" => "doublereal"
  },
  "zggevx" => {
    "rwork" => "doublereal"
  },
  "dlazq3" => {
    "dmin1" => "doublereal",
    "dmin2" => "doublereal",
    "dn" => "doublereal",
    "dn1" => "doublereal",
    "dn2" => "doublereal",
    "tau" => "doublereal",
  },
  "zlag2c" => {
    "a" => "doublecomplex",
    "sa" => "complex"
  },
  "clag2z" => {
    "a" => "doublecomplex",
    "sa" => "complex"
  },
  "cptts2" => {
    "b" => "complex"
  },
  "zptts2" => {
    "b" => "doublecomplex"
  },
  "cpttrs" => {
    "b" => "complex"
  },
  "zpttrs" => {
    "b" => "doublecomplex"
  },
  "zpbrfs" => {
    "ab" => "doublecomplex"
  }
}



SUBSTS = Hash.new
SUBSTS["dlasd1"] = {"n" => "nl+nr+1"}
%w(slaeda dlaeda).each{|n| SUBSTS[n] = {"n" => "ldqptr-2"}}
%w(sgbbrd dgbbrd cgbbrd zgbbrd).each{|n| SUBSTS[n] = {"m" => "ldab"}}
%w(sggsvp dggsvp cggsvp zggsvp sgeequ dgeequ cgeequ zgeequ cungr2 zungr2 cungl2 zungl2 sorgr2 dorgr2 sorgl2 dorgl2 stzrqf dtzrqf ctzrqf ztzrqf stzrzf dtzrzf ctzrzf ztzrzf sgerq2 dgerq2 cgerq2 zgerq2 sgelq2 dgelq2 cgelq2 zgelq2 slatrz dlatrz clatrz zlatrz).each{|n| SUBSTS[n] = {"m" => "lda"}}
%w(slaqps dlaqps claqps zlaqps).each{|n| SUBSTS[n] = {"kb" => "nb"}}
%w(sstevx dstevx sstein dstein cstein zstein).each{|n| SUBSTS[n] = {"m" => "n"}}
%w(sopgtr dopgtr cupgtr zupgtr).each{|n| SUBSTS[n] = {"n" => "ldtau+1"}}
%w(stgsna dtgsna ctgsna ztgsna strsna dtrsna ctrsna ztrsna).each{|n| SUBSTS[n] = {"mm" => "m"}}
%w(sggsvd dggsvd cggsvd zggsvd).each{|n| SUBSTS[n] = {"m" => "lda", "p" => "ldb"}}
SUBSTS["dlansp"] = {"lwork" => '(lsame_(&norm,"I") || lsame_(&norm,"1") || lsame_(&norm,"0")) ? n : 0'}
%w(ssptrd dsptrd chptrd zhptrd sppequ dppequ cppequ zppequ chpevd zhpevd sspev dspev sspevd dspevd chpev zhpev sspgv chpgvx zhpgvx dspgv sspgvd dspgvd chpgv zhpgv chpgvd zhpgvd chptrf zhptrf ssptrf dsptrf csptrf zsptrf stpcon dtpcon ctpcon ztpcon sppcon dppcon cppcon zppcon).each{|n| SUBSTS[n]  = {"n" => '(int)(sqrt((double)8*ldap+1)-1)/2'}}
%w(sspgvx dspgvx sspevx dspevx chpevx zhpevx).each{|n| SUBSTS[n] = {"n" => '((int)sqrtf(ldap*8+1.0f)-1)/2', "m" => 'lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0'}}
%w(sstevr dstevr ssyevr dsyevr dsyevx ssyevx).each{|n| SUBSTS[n] = {"m" => 'lsame_(&range,"I") ? iu-il+1 : n'}}
%w(ssygvx dsygvx cheevr zheevr chbevx zhbevx sstemr dstemr cstemr zstemr sstegr dstegr cstegr zstegr ssbevx dsbevx cheevx zheevx chegvx zhegvx ssbgvx dsbgvx).each{|n| SUBSTS[n] = {"m" => 'lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0'}}
%w(stgex2 dtgex2).each{|n| SUBSTS[n] = {"lwork" => 'MAX(1,(MAX(n*(n2+n1),(n2+n1)*(n2+n1)*2)))'}}
%w(zlange zlanhs).each{|n| SUBSTS[n] = {"lwork" => 'lsame_(&norm,"I") ? n : 0'}}
%w(spprfs dpprfs cpprfs zpprfs chpsv zhpsv sspsv dspsv cspsv zspsv stprfs dtprfs ctprfs ztprfs).each{|n| SUBSTS[n] = {"n" => 'ldb'}}
SUBSTS["slasd0"] = {"m" => "sqre == 0 ? n : sqre == 1 ? n+1 : 0", "ldu" => "n", "ldvt" => "m"}
SUBSTS["dlasd0"] = {"m" => "sqre == 0 ? n : sqre == 1 ? n+1 : 0", "ldu" => "n",  "ldvt" => "n"}
SUBSTS["slasd3"] = {"ldu2" => "n", "n" => "nl + nr + 1", "ldvt2" => "n", "m" => "n+sqre"}
SUBSTS["dlasd3"] = {"ldu2" => "n", "n" => "nl + nr + 1", "ldvt2" => "n", "m" => "n + sqre"}
%w(slasda dlasda).each{|n| SUBSTS[n] = {"m" => "sqre == 0 ? n : sqre == 1 ? n+1 : 0", "ldu" => "n"}}
%w(slals0 dlals0 clals0 zlals0 slalsa dlalsa clalsa zlalsa).each{|n| SUBSTS[n] = {"ldbx" => "n"}}
%w(slasd2 dlasd2).each{|n| SUBSTS[n] = {"ldu2" => "n", "ldvt2" => "m"}}
%w(slasd6 dlasd6).each{|n| SUBSTS[n] = {"m" => "n + sqre", "n" => "nl + nr + 1"}}
SUBSTS["dgesdd"] = {"ldvt" => '(lsame_(&jobz,"A")||(lsame_(&jobz,"O")&&(m>=n))) ? n : lsame_(&jobz,"S") ? MIN(m,n) : 0'}
SUBSTS["zlaqr4"] = {"ldz" => 'wantz ? MAX(1,ihiz) : 1'}
%w(slaqr5 dlaqr5).each{|n| SUBSTS[n] = {"ldz" => 'n'}}
%w(sgelsd dgelsd).each{|n| SUBSTS[n] = {"c__0" => "0", "c__9" => "9", "smlsiz" => 'ilaenv_(&c__9,"'+n.upcase+'"," ",&c__0,&c__0,&c__0,&c__0)', "nlvl" => 'MAX(0,((int)(log(((double)(MIN(m,n)))/(smlsiz+1))/log(2.0))+1))', "liwork" => '3*(MIN(m,n))*nlvl+11*(MIN(m,n))'}}
%w(cgelsd zgelsd).each{|n| SUBSTS[n] = {"c__9" => "9", "c__0" => "0", "smlsiz" => 'ilaenv_(&c__9,"'+n.upcase+'"," ",&c__0,&c__0,&c__0,&c__0)', "nlvl" => 'MAX(0,(int)(log(1.0*MIN(m,n)/(smlsiz+1))/log(2.0)))', "lrwork" => 'm>=n ? 10*n+2*n*smlsiz+8*n*nlvl+3*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1) : 10*m+2*m*smlsiz+8*m*nlvl+2*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1)', "liwork" => 'MAX(1,3*(MIN(m,n))*nlvl+11*(MIN(m,n)))'}}
%w(sormbr dormbr cunmbr zunmbr).each{|n| SUBSTS[n] = {"nq" => 'lsame_(&side,"L") ? m : lsame_(&side,"R") ? n : 0'}}
%w(sbdsdc dbdsdc).each{|n| SUBSTS[n] = {"c__0" => "0", "c__9" => "9", "smlsiz" => 'ilaenv_(&c__9, "'+n.upcase+'", " ", &c__0, &c__0, &c__0, &c__0)', "ldq" => 'lsame_(&compq,"P") ? n*(11+2*smlsiz+8*(int)(log(((double)n)/(smlsiz+1))/log(2.0))) : 0', "ldiq" => 'lsame_(&compq,"P") ? n*(3+3*(int)(log(((double)n)/(smlsiz+1))/log(2.0))) : 0', "lwork" => 'lsame_(&compq,"N") ? 4*n : lsame_(&compq,"P") ? 6*n : lsame_(&compq,"I") ? 3*n*n+4*n : 0'}}
%w(clalsd zlalsd).each{|n| SUBSTS[n] = {"nlvl" => '( (int)( log(((double)n)/(smlsiz+1))/log(2.0) ) ) + 1'}}
%w(claed8 zlaed8).each{|n| SUBSTS[n] = {"ldq2" => "n"}}





def pow(str)
  str = str.gsub(/([A-Z\d]+?)\*\*([A-Z\d]+)/, 'pow(\\1,\\2)')
  str = str.gsub(/\(([^\)]+)\)\*\*([A-Z\d]+)/, 'pow(\\1,\\2)')
  str.gsub!(/lg (\w+)/, 'LG(\\1)')
  str.gsub!(/(\w) (LG\()/, '\\1*\\2')
  return str
end


def get_vname(str)
  v = pow(str).strip.downcase.gsub(/lg\(/,"LG(").gsub(/([^a-z])max/,'\\1MAX').gsub(/^max/,'MAX').gsub(/min/,"MIN")
  if /if / =~ v || (/\,/ =~ v && /(MIN|MAX|pow)\(/ !~ v) || / the / =~ v
    raise "vname is invalid #{v}"
  end
  v
end


def get_dims(str)
  if /^\((.*)\)\.?$/ =~ str
    str = $1.strip
  end
  if /(max|min)/i =~ str
    dims = Array.new
    while (str && str != "")
      if /^((((MAX|MIN)\s*\([^\,]+\,)|[^\,])+)\,?(.*)$/i =~ str
        dns = $1.strip
        str = $5.strip
        dims.push dns
        next
      else
        /^([^\,]+)(\,.*)$/ =~ str
        dims.push $1
        str = $2.strip
      end
      if /^\,(.*)/ =~ str
        str = $1.strip
      end
    end
  else
    dims = str.split(",").collect{|dim| dim.sub(/\.$/,"")}
  end
  dims.collect do |dim|
    dim.sub!(/;\Z/,"")
    if /\A\((.+)\)\Z/ =~ dim
      dim = $1
    end
    get_vname(dim)
  end
end

AO = {"and"=>"&&","or"=>"||"}
def get_cond(cond,v=nil)
  cond.sub!(/\.$/,"")
  if /^(.+?)\s*(and|or)\s*(.+)$/ =~ cond
    c0 = $1.strip
    ao = $2
    c1 = $3.strip
    if /^([A-Z\d]+)\s*=/ =~ c0
      v = get_vname($1)
    else
      v = nil
    end
    cond = "((#{get_cond(c0,v)}) #{AO[ao]} (#{get_cond(c1,v)}))"
  elsif /^(.+?)\s*=\s*\'(.+)'$/ =~ cond
    cond = "lsame_(&#{$1.downcase},\"#{$2}\")"
  else
    if /=.*=/ =~ cond
      conds = cond.split("=").collect{|c| c.strip.downcase}
      cond = Array.new
      (conds.length-1).times{|i|
        cond.push "(#{conds[i]}==#{conds[i+1]})"
      }
      cond = cond.join("&&")
    elsif v && (/^\'(.+)\'$/ =~ cond)
      cond = "lsame_(&#{v},\"#{$1}\")"
    elsif v && (/^\d+$/ =~ cond)
      cond = "#{v} == #{cond}"
    else
      cond = cond.gsub(/=/,"==").downcase
    end
  end
  cond
end



def read_file(fname)
  flag_sub = false
  subr = nil
  sub_type = nil
  flag_pur = false
  purpose = nil
  flag_arg = false
  args = nil
  flag_fd = false
  fd = nil
  File.foreach(fname){|line|

    if /This routine is not for general use\./ =~ line
      return nil
    end
    if /^\*\s+\.\. Parameters \.\./ =~ line || /^\*\s+\.\. Executable Statements \.\./ =~ line
      break
    end

    if flag_sub
      if (/^     \$\s* (.+)$/ =~ line) || (/^     \+\s* (.+)$/ =~ line) || (/^     \&\s* (.+)$/ =~ line)
        subr << " " << $1.chomp
      else
        flag_sub = false
      end
      next
    elsif /^      SUBROUTINE/ =~ line
      subr = line.chomp
      flag_sub = true
      next
    elsif /^      RECURSIVE SUBROUTINE/ =~ line
      subr = line.chomp
      flag_sub = true
      next
    elsif /^      ([A-Z\s\d\*]+)\s+FUNCTION/ =~ line
      subr = line.chomp
      flag_sub = true
    elsif /^      FUNCTION/ =~ line && /^[sd]laneg/ =~ File.basename(fname)
      subr = line.chomp
      flag_sub = true
    end

    if flag_pur
      if /^\*\s+Arguments$/ =~ line
        flag_pur = false
        args = line
        flag_arg = true
        next
      else
        case File.basename(fname)
        when /^[cz]la_lin_berr/
          if /^\*     N       \(input\) INTEGER$/ =~ line
            flag_pur = false
            args = line
            flag_arg = true
            next
          end
        when /^[sdcz]laqr1/
          if /^\*       N      \(input\) integer$/ =~ line
            flag_pur = false
            args = line
            flag_arg = true
            next
          end
        when /^[sdcz]laqr2/, /^[sdcz]laqr3/
          if /^\*     WANTT   \(input\) LOGICAL$/ =~ line
            flag_pur = false
            args = line
            flag_arg = true
            next
          end
        when /^[sdcz]laqr5/
          if /^\*      WANTT  \(input\) logical scalar$/ =~ line
            flag_pur = false
            args = line
            flag_arg = true
            next
          end
        when /^[sd]lasq4/, /^[sd]lazq4/
          if /^\*  I0    \(input\) INTEGER$/ =~ line
            flag_pur = false
            args = line
            flag_arg = true
            next
          end
        end
        purpose << line
        next
      end
    elsif /^\*\s+Purpose$/ =~ line
      purpose = line
      flag_pur = true
      next
    else
      case File.basename(fname)
      when /^[sdcz]laqr1/
        if /^\*       Given a 2-by-2 or 3-by-3 matrix H, [SDCZ]LAQR1 sets v to a$/ =~ line
          purpose = line
          flag_pur = true
        end
      when /^[sdcz]laqr2/
        if /^\*     This subroutine is identical to [SDCZ]LAQR3 except that it avoids$/ =~ line
          purpose = line
          flag_pur = true
        end
      when /^[sdcz]laqr3/
        if /^\*     Aggressive early deflation:$/ =~ line
          purpose = line
          flag_pur = true
        end
      when /^[sdcz]laqr5/
        if /^\*     This auxiliary subroutine called by [SDCZ]LAQR0 performs a$/ =~ line
          purpose = line
          flag_pur = true
        end
      end
    end

    if flag_arg
      if /^\*\s+Further Details$/ =~ line || /^\*\s+={40,}$/ =~ line
        flag_arg = false
        fd = line
        flag_fd = true
        next
      else
        args << line
        next
      end
    end
    
    if flag_fd
      fd << line
      next
    end
  }

  unless subr
    raise "subr not found #{fname}"
  end
  unless purpose
    raise "purpose not found #{fname}"
  end
  unless args
    raise "args not found #{fname}"
  end

  help = subr + "\n\n" + purpose + "\n" + args
  help << "\n" + fd if fd

  return {:subr => subr, :purpose => purpose, :args => args, :help => help}
end

def parse_file(fname, debug)
  hash = read_file(fname)
  subr = hash[:subr]
  purpose = hash[:purpose]
  args = hash[:args]
  help = hash[:help]

  if /^      (?:RECURSIVE )?SUBROUTINE\s+([A-Z\d_]+)\s*\(([^\)]+)\)/ =~ subr
    sub_name = $1.downcase
    arg_names = $2
    sub_type = :subroutine
  elsif /^      ([A-Z\s\*\d]+[A-Z\d])\s+FUNCTION\s+([A-Z\d_]+)\s*\(([^\)]+)\)/ =~ subr
    f_type = $1.strip
    sub_name = $2.downcase
    arg_names = $3
    sub_type = :function
    if f_type == "CHARACTER*1"
      f_type = "CHARACTER"
    end
    func_type = CTYPES[f_type]
    unless func_type
      raise "func_type #{f_type} is not defined"
    end
  elsif /^      FUNCTION\s+([A-Z\d]+)\(([^\)]+)\)/ =~ subr
    sub_name = $1.downcase
    arg_names = $2
    sub_type = :function
    case File.basename(fname)
    when /^[sd]laneg/
      func_type = "integer"
    else
      raise "function name is invalid #{subr}"
    end
  else
    raise "subroutine or function name is invalid #{subr}"
  end
  arg_names = arg_names.split(",").collect{|arg| arg.strip.downcase}
  unless arg_names
    raise "arg_names is nil #{fname}"
  end

  if debug
    p sub_name
    p arg_names
  end

  flag = false
  flag1 = false
  ary = Array.new
  args.each{|line|
    case line
    when /^\*\s*$/, /^\*  Arguments$/, /^\*  =========$/
      flag = false
      flag1 = false
      next
    end

    if /^\*\s+([A-Z_\d,\s]+)\s+\((input|output|workspace|in|external procedure)[^\)]*\)\s+([A-Za-z]+)/ =~ line
      name = $1
      intent = $2
      type = $3
      name.strip!
      ary.push line.chomp
      if /array/i =~ line
        flag = true
      elsif (/^LD/=~name || /L.*WORK/=~name) && /input/=~intent && /INTEGER/i=~type
        flag1 = true
      end
    elsif flag
      line.sub!(/^\*\s*/,"")
      if /[Ii]f / =~ line || /where / =~ line || /^[a-z]/ =~ line || /[a-z]$/ =~ ary[-1] || /is not referenced/ =~ line || /dimension (of [A-Z\d]+ must be )?at least/ =~ ary[-1] || /^Otherwise, / =~ line
        if /^[^\s]+ is the/ =~ line || /^If [^\.]+ must contain/ =~ line || /where in / =~ line || /At each / =~ line || /^[^\.]+\, [A-Z\d]+ contains / =~ line || /[A-Z]+\(\d\) and [A-Z]+\(\d\) contain the/ =~ line
          flag = false
          next
        end
        if  /^\( lg\(\s*\w?\s*\) = smallest integer \w$/ =~ line || /^such that 2\^\w \>= \w \)$/ =~ line
          next
        end
        while /^(.*)On exit/ =~ line || /^(.*?)[^\.]+ on exit/ =~ line || /^(.*)On entry/ =~ line || /^(.*)The/ =~ line || /^(.*?)[^\.]+ the [^d]/=~ line || /^(.*?)[^\.]+ is an /=~ line
          line = $1.strip
          flag = false
        end
        if line != ""
          if /^[A-Z]/ =~ line && /[\.\,;]$/ !~ ary[-1] && /if$/ !~ ary[-1]
            ary[-1] << ";"
          end
          if /\)$/ =~ ary[-1] && /^\(/ =~ line
            ary[-1] << ";"
          end
          ary[-1] << " " << line.chomp
        end
      elsif /^(?:The d|D)imension must be at least (.*)$/ =~ line
        dim = $1
        ary[-1].sub!(/\.$/," ")
        ary[-1] << "(#{dim})"
        flag = false
      else
        flag = false
      end
    elsif flag1
      line.sub!(/^\*\s*/,"")
      ary[-1] << " " << line.chomp
    else
      if /^\*\s+If L.?WORK = -1, .*a workspace query/ =~ line
        line.sub!(/^\*\s*/,"")
        ary[-1] << " " << line.chomp
        flag1 = true
      end
    end
  }

  if debug
    pp ary
  end

  args = Hash.new
  subst = SUBSTS[sub_name] || Hash.new
  ary.each{|line|
    line.strip!
    /^\*\s+([A-Z\d_,\s]+)\s+\(([^\)]+)\)\s*(.*)$/ =~ line
    name = $1.downcase.strip
    intent = $2
    type = $3.sub(/\.$/,"")
    hash =  Hash.new

    intent = "input" if intent == "in"
    intent = "input or input/output" if intent == "input or input/ouptut"
    case sub_name
    when /^[cz]larcm$/
      case name
      when "c"
        intent = "output"
      end
    when /^[cz]lacrm$/
      case name
      when "c"
        intent = "output"
      end
    end
    hash[:intent] =  intent
    if /^l.*work/ =~ name && (/The (dimension|length)? of (the )?(array|work|WORK)/ =~ type || /The amount of workspace available/ =~ type)
      if (/^(.*?) The (?:dimension|length)? of (?:the )?array\s+(?:WORK\.\s*)?(.+)/ =~ type) || (/^(.*?) The (?:dimension|length)? of (?:the )?(?:array|work|WORK)\.?\s+(.+)/ =~ type)
        type = $1.strip
        str = $2
      elsif /^(.+?) The amount of workspace available/ =~ type
        type = $1.strip
        str = nil
      else
        raise "invalid:  #{type}, #{name}, #{sub_name}"
      end
      aname = name.sub(/^l/,"")
      fff = false
      if (/If #{name.upcase} = -1, (then )?.*a workspace query/ =~ str) || (/If #{name.upcase} = -1 .+? returns the optimal/ =~ str)
        fff = true
      elsif /^([cz]tgsna|[cz]hetrf)$/=~sub_name && name=="lwork"
        fff = true
      elsif str
        unless /^[sd]tgex2$/ =~ sub_name && name == "lwork"
          warn "invalid #{str} #{name} #{sub_name}"
        end
      end
      if fff
        unless ar = args[aname]
          raise "array not found #{aname} #{name} #{sub_name}"
        end
        d = ar[:dims]
        unless d.length == 1
          raise "array length is not 1 #{aname} #{name} #{sub_name}"
        end
        if /^[a-z\d_]+$/ =~ d[0]
          d[0] = "MAX(1,#{d[0]})"
        end
      end
    elsif /^ld/ =~ name && (/(leading|first) dimension of/ =~ type || /(Leading|First) dimension of/ =~ type)
      if /^([^,]+) T[Hh]e (?:leading|first) dimension of\s+(?:(?:the )?vector)?(?:the array(?:s)?)?\s*(.+)$/ =~ type || /^(.+?) LD[A-Z]+ is the leading dimension of\s+(.+)$/ =~ type || /^(.+?) On entry, (?:LD[A-Z]+\s+specifies the )?(?:leading|first) dimension of (.+)$/ =~ type || /^([^,]+) (?:[Ll]eading|First) dimension of\s+(.+)$/ =~ type
        type = $1.strip
        str = $2.strip
      elsif /^([^,]+)\,\s+(.+?)\s+The (?:leading|first) dimension of\s+(.+)$/ =~ type
        type = $1.strip
        str0 = $2.strip
        str1 = $3.strip
        str = str1 + ", " + str0
      else
        raise "invalid #{type}, #{name} #{sub_name}"
      end
      if /^(?:the )?arrays (.+?),? and ([A-Z\d_]+)[\,\.]?\s*(.*)$/ =~ str
        anames = $1.strip
        aname1 = $2
        str = $3.strip
        anames = anames.split(",")
        anames.push aname1
        anames.collect!{|an| an.downcase}
      elsif /^([A-Z\d_]+) and ([A-Z\d_]+)\, must be at least (.*)$/ =~ str
        anames = [$1.downcase, $2.downcase]
        str = $3.strip
      elsif /^(?:the )?(?:array |matrix )?([A-Z\d_]+)\.?\,?\s*(.*)$/ =~ str
        anames = [$1.strip.downcase]
        str = $2.strip
        case sub_name
        when /^[cz]laqr[23]$/, /^[sd]laqr3$/, /^[sd]laqr2$/
          case name
          when "ldwv"
            anames = ["wv"]
          end
        when /^[sdcz]pbsvx$/, /^[sdcz]gbbrd$/, /^[sdcz]pbequ$/
          case name
          when "ldab"
            anames = ["ab"]
          end
        end
      else
        raise "error #{str} #{name} #{sub_name}"
      end
      ff0 = false
      ff1 = true
      anames.each{|an|
        if (ar = args[an])
          ff0 = true
          if /input/ =~ ar[:intent]
            ff1 = false
            break
          end
        end
      }
      unless ff0
        warn "arg not found [#{anames.join(",")}], #{name}, #{sub_name}"
      end
      if ff1 && str != ""
        if anames.length == 1
          aname = anames[0]
        elsif anames.include?(name.sub(/^ld/,""))
          aname = name.sub(/^ld/,"")
        else
          case sub_name
          when /^[sd]lasda$/
            case name
            when "ldgcol"
              aname = "givcol"
            end
          when /^[sd]lasd6$/
            case name
            when "ldgnum"
              aname = "givnum"
            end
          end
        end
        unless aname
          raise "cannot select anames [#{anames.join(",")}], #{name}, #{sub_name}"
        end
        un = name.upcase
        str.sub!(/\.$/,"")
        str.gsub!(/\.GE\./,"=")
        str.gsub!(/>=/,"=")
        str.gsub!(/=\s*>/,"=")
        str.gsub!(/(It )?must be at least/, "")
        str.gsub!(/#{un}\s*=/," ")
        str.sub!(/(just )?as declared in the (in the )?calling (subroutine|procedure)\./,"")
        str.strip
        if  /^([^;]+); if ([^,]+), ([^;]+); if ([^,]+), (.+)$/ =~ str
          if debug
            p 100
          end
          v = get_vname($1)
          cond0 = get_cond($2)
          v0 = get_vname($3)
          cond1 = get_cond($4)
          v1 = get_vname($5)
          str = "#{cond0} ? #{v0} : #{cond1} ? #{v1} : #{v}"
        elsif /^If ([^\,]+)\,\s+([^;]+); if ([^\,]+)\,\s+(.*)$/ =~ str || /^If ([^\,]+)\,\s+([^\.]+)\. If ([^\,]+)\,\s+(.*)$/ =~ str
          if debug
            p 110
          end
          v0 = get_vname($1)
          cond0 = get_cond($2)
          v1 = get_vname($3)
          cond1 = get_cond($4)
          str = "#{cond0} ? #{v0} : #{cond1} ? #{v1} : 0"
        elsif /^([^\,]+)\, and if ([^\,]+)\, (?:then )?(.*)$/ =~ str || /^([^;]+); if ([^\,]+)\, (?:then )?(.*)$/ =~ str
          if debug
            p 120
          end
          v0 = get_vname($1)
          cond1 = get_cond($2)
          v1 = get_vname($3)
          str = "#{cond1} ? #{v1} : #{v0}"
        elsif /^(.+?) if ([^;]+); (.+?) otherwise$/ =~ str
          if debug
            p 130
          end
          v0 = get_vname($1)
          cond0 = get_cond($2)
          v = get_vname($3)
          str = "#{cond0} ? #{v0} : #{v}"
        elsif /^If ([^,]+), then\s+(.+?)\.\s+In any case, (.+)$/ =~ str
          if debug
            p 140
          end
          cond0 = get_cond($1)
          v0 = get_vname($2)
          v = get_vname($3)
          str = "#{cond0} ? #{v0} : #{v}"
        elsif  /^([^;]+); and if ([^,]+), (.+)$/ =~ str
          if debug
            p 150
          end
          v = get_vname($1)
          cond0 = get_cond($2)
          v0 = get_vname($3)
          str = "#{cond0} ? #{v0} : #{v}"
        elsif /^(.+?) \.LE\. #{un}$/ =~ str
          if debug
            p 160
          end
          str = get_vname($1)
        elsif /^If ([^,]+), then\s+(.+)$/ =~ str
          if debug
            p 170
          end
          cond0 = get_cond($1)
          v0 = get_vname($2)
          str = "#{cond0} ? #{v0} : 0"
        elsif (/^[sd]bdsdc$/ =~ sub_name && /^ld(u|vt)$/ =~ name)
          if debug
            p 180
          end
          str = 'lsame_(&compq,"I") ? MAX(1,n) : 0'
        else
          if debug
            p 190
          end
          if /^[sdcz]laqr[23]$/ =~ sub_name && name == "ldwv"
            str = "nw"
          end
          begin
            str = get_vname(str)
          rescue
            warn "error #{str}, #{name}, #{sub_name}"
          end
        end
        if /^[sdcz]larrv$/ =~ sub_name && name == "ldz"
          str = "n"
        end
        subst[name] = str
      end
    elsif /^(.*?) array of size (.*)$/ =~ type || /^(.*?) arrays?,?(.*)$/i =~ type
      type = $1.strip
      str = $2.strip
      if /^([A-Z\s]+) work$/ =~ type
        type = $1.strip
      end
      if "CHARACTER(1)" == type
        type = "CHARACTER"
      end
      if /\Alength (.*)\z/ =~ str
        str = $1
      end
      d = DIMS[sub_name]
      dims = d[name] if d

      unless dims
        str.gsub!(/(#{name}) must be at least\s+/,'\\1 = ')
        str.gsub!(/must be at least\s+/,"")
        str.gsub!(/at least\s*/,"")
        str.gsub!(/dimension ([^\(]+) if/, '(\\1) if')
        str.gsub!(/dimension \>= /,"")
        str.gsub!(/the dimension of #{name.upcase}/,"")
        str.gsub!(/.?\s+dimension is/,"")
        str.gsub!(/(of )?dimensions?/,"")
        str.gsub!(/\.GE\.?/,">=")
        str.gsub!(/\.GT\.?/,">")
        str.gsub!(/\.LE\.?/,"<=")
        str.gsub!(/\.LT\.?/,"<")
        str.gsub!(/\.TRUE\.?/,"TRUE")
        str.gsub!(/\.FALSE\.?/,"FALSE")
        str.gsub!(/log_2\s*\(/,"1.0/log(2.0)*log((double)")
        str.gsub!(/INT\s*\(/,"(int)\(")

        str.strip!
        if intent == "input"
          str.sub!(/\s*if .*$/i, "")
        end
        if /(...rfsx|...svxx)/ =~ sub_name && name == "params"
          str = ""
        end
        if /[Ii]f/ =~ str || /where/ =~ str || /when/ =~ str
          dims = Array.new
          flag = true
          str.sub!(/;$/,"")
          if /^\([^;]+\); (\(.+?\) if [A-Z\d]+ = .+? or \(.+?\) if [A-Z\d]+ = .+)$/ =~ str
            str = $1
          end
          if debug
            p name
            p str
          end
          while (str && str!="")
            if (/^(?:and )?\((.*?)\)\s+if\s+([^\,\;]+)[\,\;]\s+(.*)$/ =~ str) && (dim = $1.strip) && (cond = $2.strip) && (str_tmp = $3.strip) && (/ if .* if / !~ cond) && (/\([^\)]+$/ !~ cond) && (/=/ !~ dim)
              if debug
                p 1
              end
              str = str_tmp
            elsif (/^\(([^;]+?)\)\s+if\s+(.+?)\s+(?:or|and)\s+(\(.*\) if.*)$/ =~ str) || (/^\(([^;]+?)\)\s+if\s+(.+?)\s+(\(.*\)\s+if.*)$/ =~ str)
              if debug
                p 2
              end
              dim = $1
              cond = $2.strip
              str = $3.strip
            elsif /^If ([^\,]+)\,\s+([^;\.]+)[;\.]?(.*)$/ =~ str
              if debug
                p 2.5
              end
              cond = $1.strip
              dim = $2
              str = $3.strip
            elsif /^\((.*?)\)\s+if\s+([^\,]+)\, (\(.*\) otherwise)$/ =~ str
              if debug
                p 3
              end
              dim = $1.strip
              cond = $2.strip
              str = $3.strip
            elsif (/^(?:and )?\((.+?)\)\s+if\s+(.*)$/ =~ str) && (dim = $1.strip) && (cond = $2.strip) && (/if/ !~ dim) && (/ if /i !~ cond) && (/^[^\(]+\)/ !~ dim)
              if debug
                p 4
              end
              str = nil
            elsif /\A\((.*)\) when (.*) and/ =~ str
              dim = $1
              cond = $2
              str = $'
            elsif /^(.*?)\s+otherwise$/ =~ str && (dim = $1.strip) && (/ if / !~ dim)
              if debug
                p 5
              end
              if cond == "not referenced"
                dims = dims.collect{|d| d + "0"}
              else
                get_dims(dim).each_with_index{|d,i|
                  dims[i] = dims[i] + d
                }
              end
              flag = false
              break
            elsif /^\((.+?)\);?\s+If ([A-Z_\d]+ = [^\,]+)\, (then )?#{name.upcase} is not referenced.?$/ =~ str
              if debug
                p 6
              end
              dims = get_dims($1)
              cond = get_cond($2)
              dims = dims.collect{|dim|
                "#{cond} ? 0 : #{dim}"
              }
              flag = false
              break
            elsif /^\((.+?)\); Not referenced if (.*)$/ =~ str
              if debug
                p 6.5
              end
              v0 = get_vname($1)
              cond0 = get_cond($2)
              dims = ["#{cond0} ? 0 : #{v0}"]
              flag = false
              break
            elsif /\((.+?)\)\, where ([A-Z\d]+) >= ([A-Z\d]+) when ([^;]+); otherwise, #{name.upcase} is not referenced\.?$/ =~ str
              if debug
                p 7
              end
              dims = get_dims($1)
              c0 = $2
              c1 = $3
              cond = get_cond($4)
              subst[get_vname(c0)] = "#{cond} ? #{get_vname(c1)} : 0"
              flag = false
              break
            elsif /\((.+)\)[\.\,] where ([A-Z\d]+) = (.+)\.?$/ =~ str
              if debug
                p 8
              end
              dims = get_dims($1)
              c0 = $2
              c1 = $3
              subst[get_vname(c0)] = get_vname(c1)
              flag = false
              break
            elsif /^(?:and )?(not referenced) if (.+).?$/ =~ str
              if debug
                p 9
              end
              dim = $1
              cond = $2
              str = nil
            elsif (/^\((.+?)\) where ([A-Z\d_]+) = (.*)$/ =~ str) && (dim = $1) && (c0 = $2) && (c1 = $3) && /=/ !~ c1
              dims = get_dims(dim)
              subst[get_vname(c0)] = get_vname(c1)
              flag = false
              break
            else
              if /^\((.+?)\) (.+?) = (.+?) (?:when|if) ([^,]+), and (.+?) when (.+)$/ =~ str
                if debug
                  p 10
                end
                dim = $1
                dim1 = $2
                unless dim == dim1
                  raise "error #{name} #{sub_name}"
                end
                c0 = $3
                cond0 = get_cond($4)
                c1 = $5
                cond1 = get_cond($6)
                dims = get_dims($1)
                subst[get_vname(dim)] = "#{cond0} ? #{get_vname(c0)} : #{cond1} ? #{get_vname(c1)} : 0"
                flag = false
                break
              elsif /^\((.+?)\) (.+?) = (.+?) (?:when|if) ([^,]+), and (.+?) otherwise.?$/ =~ str
                if debug
                  p 11
                end
                dim = $1
                dim1 = $2
                unless dim == dim1
                  raise "error #{name} #{sub_name}"
                end
                c0 = $3
                cond0 = get_cond($4)
                c1 = $5
                dims = get_dims(dim)
                subst[get_vname(dim)] = "#{cond0} ? #{get_vname(c0)} : #{get_vname(c1)}"
                flag = false
                break
              elsif /^\((.+?)\);\s+[Ii]f ([A-Z_\d]+ = [^\,]+)\, ([A-Z_\d]+) \>?= ([^\.]+)\.\s+Otherwise\, ([A-Z_\d]+) \>?= (.*)$/ =~ str
                if debug
                  p 14
                end
                dim = $1
                cond0 = $2
                c00 = $3.downcase
                c01 = $4.downcase
                c10 = $5.downcase
                c11 = $6.downcase
                unless c00==c10
                  raise "error #{name} #{sub_name}"
                end
                dims = get_dims(dim)
                cond0 = get_cond(cond0)
                subst[get_vname(c00)] = "#{cond0} ? #{get_vname(c01)} : #{get_vname(c11)}"
                flag = false
                break
              end
              if /^\((.+?)\)\.\s+[Ii]f ([A-Z_\d]+ = [^\,]+)\, ([A-Z_\d]+) = ([A-Z_\d]+); if ([A-Z_\d]+ = [^\,]+), ([A-Z_\d]+) = ([A-Z_\d]+)$/ =~ str
                if debug
                  p 13
                end
                dim = $1
                cond0 = $2
                c00 = $3.downcase
                c01 = $4.downcase
                cond1 = $5
                c10 = $6.downcase
                c11 = $7.downcase
              elsif /\((.+?)\);? ([A-Z_\d]+) = (.+?) if ([^;]+); ([A-Z_\d]+) = (.+?) if (.+)$/ =~ str
                if debug
                  p 13
                end
                dim = $1
                c00 = $2.downcase
                c01 = $3.downcase
                cond0 = $4
                c10 = $5.downcase
                c11 = $6.downcase
                cond1 = $7
              else
#                raise "error '#{str}' in #{name} (#{fname})"
                 warn "'#{str}' in #{name} (#{fname})"
                 dim = "dummy_" + str
              end
              if /dummy_/ =~ dim
                dims = dim
              else
                dims = get_dims(dim)
                cond0 = get_cond(cond0)
                cond1 = get_cond(cond1)
                if c00 == c10
                  subst[get_vname(c00)] = "#{cond0} ? #{get_vname(c01)} : #{cond1} ? #{get_vname(c11)} : 0"
                else
                  raise "error #{name} #{sub_name}"
                end
              end
              flag = false
              break
            end
            if flag
              cond = get_cond(cond)
              if dim == "not referenced"
                dims = dims.collect{|d| d + cond + " ? 0 : "}
              else
                ds = get_dims(dim)
                ds.each_with_index{|d,i|
                  dims[i] ||= ""
                  dims[i] << cond + " ? " + d + " : "
                }
              end
            end
          end
          dims = dims.collect{|d| d + "0"} if flag
        else
          dims = get_dims(str)
        end

        dims.each_with_index{|dim,i|
          if /\?/ =~ dim
            str = dim
            aa = Array.new
            while( /^[^\?]+ \? ([^:]+) : (.+)$/ =~ str )
              aa.push $1
              str = $2
            end
            aa.push str
            if aa.length > 2
              aa = aa.uniq
              if aa.length == 1 || (aa.length == 2 && aa[-1] == "0")
                dims[i] = aa[0]
              end
            elsif aa.length == 2
              if aa.uniq.length == 1
                dims[i] = aa[0]
              end
            else
              raise "error [#{aa.join(",")}] #{dim} #{name} #{sub_name}"
            end
          end
        }
      end
      if /^[sd]lasda$/ =~ sub_name  && name == "difl"
        subst["nlvl"].sub!(/\)$/,"")
      end
      hash[:dims] = dims
    elsif (/^(.+) work array$/ =~ type) || (/^(.+) array$/ =~ type)
      type = $1.strip
      dims = DIMS[sub_name] && DIMS[sub_name][name]
      unless dims
        raise "dimension is not defined (#{name} in #{fname})"
      end
    elsif /^CHARACTER\*\s*(\d+)$/ =~ type || /^CHARACTER\*?\((\d+)\)$/ =~ type || /^character string/ =~ type
      type = "CHARACTER"
      if $1 && $1 != "1"
        hash[:dims] = [$1]
      end
    elsif /^CHARACTER\*\(\*\)$/ =~ type
      type = "CHARACTER"
      hash[:dims] = ["*"]
    elsif /^(.*)\,\s*#{name}\s*=\s*>/i =~ type
      type = $1.strip
    elsif /^(.+?)\s+scalar$/ =~ type
      type = $1
    elsif /^(.+?)\s+with value/ =~ type
      type = $1
    end
    if (t = TYPES[sub_name]) && (t = t[name])
      hash[:type] = t
    else
      type.sub!(/ scalar/,"")
      if /^(.+?) FUNCTION of ([^\s]+) (.+?) arguments?$/ =~ type
        hash[:block_type] = CTYPES[$1] || raise("error block type is invalid #{$1} #{name} #{sub_name}")
        hash[:block_arg_num] = {"one"=>1,"two"=>2,"three"=>3}[$2] || raise("error #{$2}")
        hash[:block_arg_type] = CTYPES[$3] || raise("error block arg type is invalid #{$3} #{name} #{sub_name}")
      else
        hash[:type] = CTYPES[type.upcase]
        unless hash[:type]
          warn("type (#{type}) is not defined in #{name} (#{fname})")
        end
      end
    end
    if /,/ =~ name
      name.split(",").each{|n1|
        args[n1.strip] = hash.dup
      }
    else
      args[name] = hash
    end
  }
  case sub_name
  when /^[cz]laqr[04]$/
    args["iloz"] = {:type => "integer", :intent => "input"}
    args["ihiz"] = {:type => "integer", :intent => "input"}
  end
  if debug
    pp args
  end

  return  {:name => sub_name, :category => sub_type, :type => func_type, :argument_names => arg_names, :arguments => args, :fortran_help => help, :md5sum => get_md5sum(help), :substitutions => subst}


end


def create_hash(fname, debug)
  hash = parse_file(fname, debug)
  if hash.nil?
    warn "skip #{fname}"
    return nil
  end
  sub_name = hash[:name]
  arg_names = hash.delete(:argument_names)
  args = hash.delete(:arguments)

  args.each do |k,v|
    case v[:intent]
    when "input or output", "input or input/output", "input / output", "input/workspace/output", "input/workspace"
      v[:intent] = "input/output"
    when "workspace/output"
      v[:intent] = "output"
    end
  end


  unless sub_name
    warn "this has no subroutine (#{fname})"
    return nil
  end
  unless arg_names
    raise "no arg_names (#{fname})"
  end
  unless args && !args.empty?
    raise "no args (#{fname})"
  end

  hash[:arguments] = arg_names.map{|name| {name => args[name]} }

  return hash
end

def generate_code(fnames, debug)
  nfnames = fnames.length
  sub_names = Array.new
  fnames.each_with_index{|fname,i|
    print "#{i+1}/#{nfnames}\n" if (i+1)%100==0
    hash = read_file(fname)
    next if hash.nil?
    help = hash[:help]
    basename = File.basename(fname, ".f")
    def_dir = File.join(File.dirname(__FILE__), "defs")
    def_fname = File.join(def_dir, basename)
    if File.exists?(def_fname)
      hash = nil
      File.open(def_fname){|file| hash = YAML.load(file.read) }
      md5sum = hash[:md5sum]
      next if get_md5sum(help) == md5sum && !@@force
    end

    hash = create_hash(fname, debug)
    def hash.each
      [:name, :md5sum, :category].each do |k|
        yield(k, self[k])
      end
      if self[:category] == :function
        yield(:type, self[k])
      end
      [:arguments, :substitutions, :fortran_help].each do |k|
        yield(k, self[k])
      end
    end
    p "write #{hash[:name]}" if debug
    File.open(def_fname, "w") do |file|
      file.write hash.to_yaml
    end
  }
end

def get_md5sum(src)
  Digest::MD5.hexdigest(src.sub(/LAPACK routine \(version \d.\d\) --/,""))
end





debug = ARGV.delete("--debug")
force = ARGV.delete("--force")

dname = ARGV[0] || raise("Usage: ruby #$0 path_to_lapack_src")
if File.directory?(dname)
  fnames = Dir[ File.join(dname,"*.f") ]
elsif File.file?(dname)
  fnames = [dname]
#  @@debug = true
end

generate_code(fnames, debug)


ruby-lapack-1.7.2/dev/make_csrc.rb0000644000175000017500000005172712655767354016661 0ustar  uwabamiuwabami$:.unshift File.dirname(__FILE__)

require "yaml"
require "pp"
require "common"

RBPREFIX = "rblapack_"

NATYPES = {
  "integer" => "NA_LINT",
  "real" => "NA_SFLOAT",
  "doublereal" => "NA_DFLOAT",
  "complex" => "NA_SCOMPLEX",
  "doublecomplex" => "NA_DCOMPLEX",
  "logical" => "NA_LINT",
}


TOPDIR = File.join(File.dirname(__FILE__), "..")



def get_cobj(name, type, sub_name, indent=2)
  indent = " "*indent
  case type
  when "integer"
    return "#{indent}#{name} = NUM2INT(#{RBPREFIX}#{name});\n"
  when "real"
    return "#{indent}#{name} = (real)NUM2DBL(#{RBPREFIX}#{name});\n"
  when "doublereal"
    return "#{indent}#{name} = NUM2DBL(#{RBPREFIX}#{name});\n"
  when "complex"
    code =<<"EOF"
#{indent}#{name}.r = (real)NUM2DBL(rb_funcall(#{RBPREFIX}#{name}, rb_intern("real"), 0));
#{indent}#{name}.i = (real)NUM2DBL(rb_funcall(#{RBPREFIX}#{name}, rb_intern("imag"), 0));
EOF
    return code
  when "doublecomplex"
    code =<<"EOF"
  #{name}.r = NUM2DBL(rb_funcall(#{RBPREFIX}#{name}, rb_intern("real"), 0));
  #{name}.i = NUM2DBL(rb_funcall(#{RBPREFIX}#{name}, rb_intern("imag"), 0));
EOF
    return code
  when "char"
    return "  #{name} = StringValueCStr(#{RBPREFIX}#{name})[0];\n"
  when "logical"
    return "  #{name} = (#{RBPREFIX}#{name} == Qtrue);\n"
  else
    raise "type (#{type}) is not defined in #{name} (#{sub_name})"
  end
end

def get_robj(name, type, flag=false)
  case type
  when "integer"
    cname =  flag ? "(*#{name})" : name
    return "  #{RBPREFIX}#{name} = INT2NUM(#{cname});\n"
  when "real", "doublereal"
    cname =  flag ? "(*#{name})" : name
    return "  #{RBPREFIX}#{name} = rb_float_new((double)#{cname});\n"
  when "complex", "doublecomplex"
    if flag
      r = "(#{name}->r)"
      i = "(#{name}->i)"
    else
      r = "(#{name}.r)"
      i = "(#{name}.i)"
    end
    return "  #{RBPREFIX}#{name} = rb_funcall(rb_gv_get(\"Complex\"), rb_intern(\"new\"), 2, rb_float_new((double)#{r}), rb_float_new((double)#{i}));\n"
  when "char"
    return "  #{RBPREFIX}#{name} = rb_str_new(&#{name},1);\n"
  when "logical"
    return "  #{RBPREFIX}#{name} = #{name} ? Qtrue : Qfalse;\n"
  else
    raise "type (#{type}) is not defined in #{name}"
  end
end


def get_input(name, type, dims, i, varset, sub_name, subst, indent=2)
  if dims.nil?
    return get_cobj(name, type, sub_name, indent)
  else
    indent = " "*indent
    if type == "char"
      return "#{indent}#{name} = StringValueCStr(#{RBPREFIX}#{name});\n"
    end
    if i.kind_of?(Integer)
      arg = "#{i+1}th argument"
    else
      arg = "option"
    end
    code =<<"EOF"
#{indent}if (!NA_IsNArray(#{RBPREFIX}#{name}))
#{indent}  rb_raise(rb_eArgError, "#{name} (#{arg}) must be NArray");
#{indent}if (NA_RANK(#{RBPREFIX}#{name}) != #{dims.length})
#{indent}  rb_raise(rb_eArgError, "rank of #{name} (#{arg}) must be %d", #{dims.length});
EOF
#    ndim = dims.length
#    ndim.times do |jj|
#      j = ndim - jj - 1
#      dim = dims[j]
    dims.each_with_index do |dim, j|
      raise "bug: NA_SHAPE? cannot use {#{dim} in #{name}: #{sub_name}" if j>2
      if varset.include?(dim)
        dimo = subst[dim] || dim
        code << <<"EOF"
#{indent}if (NA_SHAPE#{j}(#{RBPREFIX}#{name}) != #{dim})
#{indent}  rb_raise(rb_eRuntimeError, "shape #{j} of #{name} must be #{dimo.gsub(/"/,'\"')}");
EOF
      elsif (shape = @shape[dim])
        code << <<"EOF"
#{indent}if (NA_SHAPE#{j}(#{RBPREFIX}#{name}) != #{dim})
#{indent}  rb_raise(rb_eRuntimeError, "shape #{j} of #{name} must be the same as shape #{shape[:index]} of #{shape[:name]}");
EOF
      elsif /^[a-z][a-z_\d]*$/ !~ dim
        get_vars(dim).each{|d|
          unless varset.include?(d) || @shape.include?(d)
            raise "undefined #{d}  #{name} #{sub_name}"
          end
        }
        code << <<"EOF"
#{indent}if (NA_SHAPE#{j}(#{RBPREFIX}#{name}) != (#{dim}))
#{indent}  rb_raise(rb_eRuntimeError, "shape #{j} of #{name} must be %d", #{dim});
EOF
      else
        code << "#{indent}#{dim} = NA_SHAPE#{j}(#{RBPREFIX}#{name});\n"
        @shape[dim] = {:name => name, :index => j}
        if s = subst[dim]
          if /^[a-z][a-z_\d]*$/ =~ s && !varset.include?(s)
            code << "#{indent}#{s} = #{dim};\n"
            varset.push s
          else
            code << < func_type}
    if /complex/ =~ func_type || func_type == "char"
      code << "extern VOID #{sub_name}_(#{func_type} *__out__, #{cargs});\n\n"
    else
      code << "extern #{func_type} #{sub_name}_(#{cargs});\n\n"
    end
  else
    raise "category is invalid: #{sub_type} (#{sub_name})"
  end

  code << <<"EOF"

static VALUE
#{RBPREFIX}#{sub_name}(int argc, VALUE *argv, VALUE self){
EOF

  dimdefs = Array.new
  (inputs+options+outputs).each{|aname|
    arg = args[aname]
    code << <<"EOF"
  VALUE #{RBPREFIX}#{aname};
  #{arg[:type]} #{arg[:dims] ? "*" : ""}#{aname}; 
EOF
    dimdefs.push aname
  }
  inouts.each{|aname|
    arg = args[aname]
    if arg[:dims]
      code << <<"EOF"
  VALUE #{RBPREFIX}#{aname}_out__;
  #{arg[:type]} *#{aname}_out__;
EOF
    end
  }
  if extras
    extras.each do |k,v|
      code << "  #{v} #{k};\n"
      dimdefs.push k
    end
  end

  workspaces.each{|aname|
    arg = args[aname]
    code << "  #{arg[:type]} #{arg[:dims] ? "*" : ""}#{aname};\n"
  }
  code << "\n"
  (inputs+options+outputs+workspaces).each{|aname|
    arg = args[aname]
    if dims = arg[:dims]
      dims.each{|dim|
        if dim.kind_of?(Hash)
          p name
        end
        if /^[a-z][a-z_\d]*$/ !~ dim # if dim is a Numeric
          next
        end
        unless dimdefs.include?(dim) # untill it's defined
          code << "  integer #{dim};\n"
          dimdefs.push dim
        end
      }
    end
  }
  if ss = subst
    ss.each{|k,v|
      unless dimdefs.include?(k)
        code << "  integer #{k};\n"
        dimdefs.push k
      end
    }
  end



  code << "\n"

  if block
    block_help = "{|" + ['a','b','c'][0...args[block][:block_arg_num]].join(",") + "| ... }"
  else
    block_help = ""
  end

  usage_code = <<"EOF"
USAGE:
  #{(outputs+inouts).join(", ")} = NumRu::Lapack.#{sub_name}( #{inputs.join(", ")}, [#{(options+["usage","help"]).map{|on| ":"+on+" => "+on}.join(", ")}])#{block_help}
EOF

  help_code = <<"EOF"
#{usage_code}

FORTRAN MANUAL
#{help}
EOF
  ilen = inputs.length
  code << <<"EOF"
  VALUE #{RBPREFIX}options;
  if (argc > 0 && TYPE(argv[argc-1]) == T_HASH) {
    argc--;
    #{RBPREFIX}options = argv[argc];
    if (rb_hash_aref(#{RBPREFIX}options, sHelp) == Qtrue) {
      printf("%s\\n", "#{help_code.gsub(/\\/,'\\\\\\').gsub(/\n/,'\n').gsub(/"/,'\"')}");
      return Qnil;
    }
    if (rb_hash_aref(#{RBPREFIX}options, sUsage) == Qtrue) {
      printf("%s\\n", "#{usage_code.gsub(/\\/,'\\\\\\').gsub(/\n/,'\n').gsub(/"/,'\"')}");
      return Qnil;
    } 
  } else
    #{RBPREFIX}options = Qnil;
  if (argc != #{ilen} && argc != #{ilen+options.length})
    rb_raise(rb_eArgError,"wrong number of arguments (%d for #{ilen})", argc);
EOF
  inputs.each_with_index{|arg,i|
    code << "  #{RBPREFIX}#{arg} = argv[#{i}];\n"
  }
  code << "  if (argc == #{ilen+options.length}) {\n"
  options.each_with_index do |arg,i|
    code << "    #{RBPREFIX}#{arg} = argv[#{i+ilen}];\n"
  end
  code << "  } else if (#{RBPREFIX}options != Qnil) {\n"
  options.each do |opt|
    code << "    #{RBPREFIX}#{opt} = rb_hash_aref(#{RBPREFIX}options, ID2SYM(rb_intern(\"#{opt}\")));\n"
  end
  code << "  } else {\n"
  options.each_with_index do |arg,i|
    code << "    #{RBPREFIX}#{arg} = Qnil;\n"
  end
  code << "  }\n"

  code << "\n"

  order = Hash.new
  (inputs+options).each_with_index do |arg,i|
    aryd = Array.new
    aryp = Array.new
    if dim = args[arg][:dims]
      dim.each do |d|
        vs = get_vars(d)
        if vs.length==1 && vs[0] == d && !subst.keys.include?(d) && !args[arg][:option]
          aryp.push d
        else
          aryd.push vs
        end
      end
    end
    if vs = args[arg][:default]
      begin
        get_vars(vs).each do |v|
          aryd.push v
        end
      rescue
        p sub_name
        raise $!
      end
    end
    aryd.flatten!
    aryp.uniq!
    aryd.uniq!
    order[arg] = {:depends => aryd, :type => :input, :order => i, :provides => aryp}
  end
  subst.each do |k,v|
    order[k] = {:depends => get_vars(v).uniq, :type => :subst, :value => v}
  end

  oks = order.keys
  new_order = Array.new
  while oks.any?
    flag = false
    oks.each do |k0|
      df = false
      v0 = order[k0]
      catch(:depend) do
        v0[:depends].each do |d|
          if oks.include?(d)
            if (odd = order[d][:depends]).any?
              odd.each do |od|
                throw(:depend) unless (pr=v0[:provides]) && pr.include?(od)
              end
            else
              throw(:depend)
            end
          end
          oks.each do |k1|
            throw(:depend) if (pr=order[k1][:provides]) && pr.include?(d)
          end
        end
        new_order.push [k0, v0]
        oks.delete(k0)
        flag = true
      end
    end
    unless flag
      p "order"
      pp order
      raise "depends each others: #{oks.join(", ")} (#{sub_name})"
    end
  end
  order = new_order

 if debug
   p "order"
   pp order
 end

  varset = Array.new
  @shape = Hash.new
  order.each do |name, v|
    if v[:type] == :input
      arg = args[name]
      if arg[:option]
        if arg[:default]
          code << <
#include 
#include "ruby.h"
#include "narray.h"
#include "f2c_minimal.h"

#define MAX(a,b) ((a) > (b) ? (a) : (b))
#define MIN(a,b) ((a) < (b) ? (a) : (b))
#define LG(n) ((int)ceil(log((double)(n))/log(2.0)))

extern logical lsame_(char *ca, char *cb);
extern integer ilatrans_(char* trans);
extern integer ilaenv_(integer* ispec, char* name, char* opts, integer* n1, integer* n2, integer* n3, integer* n4);


static VALUE sHelp, sUsage;
static VALUE #{RBPREFIX}ZERO;

/* for compatibility for NArray and NArray with bigmem patch */
#ifndef NARRAY_BIGMEM
typedef int    na_shape_t;
#endif


EOF
  }


  File.open(File.join(TOPDIR,"ext","rb_lapack.c"), "w"){|file|
    file.print <<"EOF"
#include "ruby.h"
#include "rb_lapack.h"

EOF

    sub_names.each{|sname|
      file.print "extern void init_lapack_#{sname}(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE #{RBPREFIX}ZERO);\n"
    }

    file.print <<"EOF"

void Init_lapack(){
  VALUE mNumRu;
  VALUE mLapack;

  rb_require("narray");

  mNumRu = rb_define_module("NumRu");
  mLapack = rb_define_module_under(mNumRu, "Lapack");

  sHelp = ID2SYM(rb_intern("help"));
  sUsage = ID2SYM(rb_intern("usage"));

  #{RBPREFIX}ZERO = INT2NUM(0);

EOF
    sub_names.each{|sname|
      file.print "  init_lapack_#{sname}(mLapack, sHelp, sUsage, #{RBPREFIX}ZERO);\n"
    }
    file.print "}\n"
  }
end





debug = ARGV.delete("--debug")

#dname = ARGV.shift || raise("Usage: ruby #$0 path_to_lapack_src [name0, name1, ..]")
dname = File.join(TOPDIR, "dev", "defs")
unless File.directory?(dname)
  raise "the first argument must be directory"
end

unless ARGV.empty?
  names = ARGV
  debug = true
else
  names = nil
end

reg = File.join(dname, "[a-z]*[a-z0-9]")
fnames = Dir[reg]

generate_code(fnames, names, debug)
ruby-lapack-1.7.2/dev/common.rb0000644000175000017500000000072612502223525016165 0ustar  uwabamiuwabamidef get_vars(dim)
  ary = Array.new
  dim.gsub(/MAX\(/,",").gsub(/MIN\(/,",").gsub(/log\(/,",").gsub(/abs\(/,",").gsub(/sqrt\(/,",").gsub(/pow\(/,",").gsub(/LG\(/,",").gsub(/lsame_\(\&([^,]+),[^)]+\)/,'\1').gsub(/ilatrans_\([^)]+\)/,",").gsub(/ilaenv_\(([^,]+),[^,]+/,'\1').gsub(/[\(\)\+\-\*\/:\?=\&\|]+/,",").split(",").each{|d|
    d.strip!
    next if (d == "") || (/^\d+(\.\d+)?$/ =~ d) || /^\"[^\"]+\"$/ =~ d || d=="int" || d=="double"
    ary.push d
  }
  ary
end
ruby-lapack-1.7.2/GPL0000644000175000017500000004313112502223525014134 0ustar  uwabamiuwabami		    GNU GENERAL PUBLIC LICENSE
		       Version 2, June 1991

 Copyright (C) 1989, 1991 Free Software Foundation, Inc.
                       59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 Everyone is permitted to copy and distribute verbatim copies
 of this license document, but changing it is not allowed.

			    Preamble

  The licenses for most software are designed to take away your
freedom to share and change it.  By contrast, the GNU General Public
License is intended to guarantee your freedom to share and change free
software--to make sure the software is free for all its users.  This
General Public License applies to most of the Free Software
Foundation's software and to any other program whose authors commit to
using it.  (Some other Free Software Foundation software is covered by
the GNU Library General Public License instead.)  You can apply it to
your programs, too.

  When we speak of free software, we are referring to freedom, not
price.  Our General Public Licenses are designed to make sure that you
have the freedom to distribute copies of free software (and charge for
this service if you wish), that you receive source code or can get it
if you want it, that you can change the software or use pieces of it
in new free programs; and that you know you can do these things.

  To protect your rights, we need to make restrictions that forbid
anyone to deny you these rights or to ask you to surrender the rights.
These restrictions translate to certain responsibilities for you if you
distribute copies of the software, or if you modify it.

  For example, if you distribute copies of such a program, whether
gratis or for a fee, you must give the recipients all the rights that
you have.  You must make sure that they, too, receive or can get the
source code.  And you must show them these terms so they know their
rights.

  We protect your rights with two steps: (1) copyright the software, and
(2) offer you this license which gives you legal permission to copy,
distribute and/or modify the software.

  Also, for each author's protection and ours, we want to make certain
that everyone understands that there is no warranty for this free
software.  If the software is modified by someone else and passed on, we
want its recipients to know that what they have is not the original, so
that any problems introduced by others will not reflect on the original
authors' reputations.

  Finally, any free program is threatened constantly by software
patents.  We wish to avoid the danger that redistributors of a free
program will individually obtain patent licenses, in effect making the
program proprietary.  To prevent this, we have made it clear that any
patent must be licensed for everyone's free use or not licensed at all.

  The precise terms and conditions for copying, distribution and
modification follow.

		    GNU GENERAL PUBLIC LICENSE
   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION

  0. This License applies to any program or other work which contains
a notice placed by the copyright holder saying it may be distributed
under the terms of this General Public License.  The "Program", below,
refers to any such program or work, and a "work based on the Program"
means either the Program or any derivative work under copyright law:
that is to say, a work containing the Program or a portion of it,
either verbatim or with modifications and/or translated into another
language.  (Hereinafter, translation is included without limitation in
the term "modification".)  Each licensee is addressed as "you".

Activities other than copying, distribution and modification are not
covered by this License; they are outside its scope.  The act of
running the Program is not restricted, and the output from the Program
is covered only if its contents constitute a work based on the
Program (independent of having been made by running the Program).
Whether that is true depends on what the Program does.

  1. You may copy and distribute verbatim copies of the Program's
source code as you receive it, in any medium, provided that you
conspicuously and appropriately publish on each copy an appropriate
copyright notice and disclaimer of warranty; keep intact all the
notices that refer to this License and to the absence of any warranty;
and give any other recipients of the Program a copy of this License
along with the Program.

You may charge a fee for the physical act of transferring a copy, and
you may at your option offer warranty protection in exchange for a fee.

  2. You may modify your copy or copies of the Program or any portion
of it, thus forming a work based on the Program, and copy and
distribute such modifications or work under the terms of Section 1
above, provided that you also meet all of these conditions:

    a) You must cause the modified files to carry prominent notices
    stating that you changed the files and the date of any change.

    b) You must cause any work that you distribute or publish, that in
    whole or in part contains or is derived from the Program or any
    part thereof, to be licensed as a whole at no charge to all third
    parties under the terms of this License.

    c) If the modified program normally reads commands interactively
    when run, you must cause it, when started running for such
    interactive use in the most ordinary way, to print or display an
    announcement including an appropriate copyright notice and a
    notice that there is no warranty (or else, saying that you provide
    a warranty) and that users may redistribute the program under
    these conditions, and telling the user how to view a copy of this
    License.  (Exception: if the Program itself is interactive but
    does not normally print such an announcement, your work based on
    the Program is not required to print an announcement.)

These requirements apply to the modified work as a whole.  If
identifiable sections of that work are not derived from the Program,
and can be reasonably considered independent and separate works in
themselves, then this License, and its terms, do not apply to those
sections when you distribute them as separate works.  But when you
distribute the same sections as part of a whole which is a work based
on the Program, the distribution of the whole must be on the terms of
this License, whose permissions for other licensees extend to the
entire whole, and thus to each and every part regardless of who wrote it.

Thus, it is not the intent of this section to claim rights or contest
your rights to work written entirely by you; rather, the intent is to
exercise the right to control the distribution of derivative or
collective works based on the Program.

In addition, mere aggregation of another work not based on the Program
with the Program (or with a work based on the Program) on a volume of
a storage or distribution medium does not bring the other work under
the scope of this License.

  3. You may copy and distribute the Program (or a work based on it,
under Section 2) in object code or executable form under the terms of
Sections 1 and 2 above provided that you also do one of the following:

    a) Accompany it with the complete corresponding machine-readable
    source code, which must be distributed under the terms of Sections
    1 and 2 above on a medium customarily used for software interchange; or,

    b) Accompany it with a written offer, valid for at least three
    years, to give any third party, for a charge no more than your
    cost of physically performing source distribution, a complete
    machine-readable copy of the corresponding source code, to be
    distributed under the terms of Sections 1 and 2 above on a medium
    customarily used for software interchange; or,

    c) Accompany it with the information you received as to the offer
    to distribute corresponding source code.  (This alternative is
    allowed only for noncommercial distribution and only if you
    received the program in object code or executable form with such
    an offer, in accord with Subsection b above.)

The source code for a work means the preferred form of the work for
making modifications to it.  For an executable work, complete source
code means all the source code for all modules it contains, plus any
associated interface definition files, plus the scripts used to
control compilation and installation of the executable.  However, as a
special exception, the source code distributed need not include
anything that is normally distributed (in either source or binary
form) with the major components (compiler, kernel, and so on) of the
operating system on which the executable runs, unless that component
itself accompanies the executable.

If distribution of executable or object code is made by offering
access to copy from a designated place, then offering equivalent
access to copy the source code from the same place counts as
distribution of the source code, even though third parties are not
compelled to copy the source along with the object code.

  4. You may not copy, modify, sublicense, or distribute the Program
except as expressly provided under this License.  Any attempt
otherwise to copy, modify, sublicense or distribute the Program is
void, and will automatically terminate your rights under this License.
However, parties who have received copies, or rights, from you under
this License will not have their licenses terminated so long as such
parties remain in full compliance.

  5. You are not required to accept this License, since you have not
signed it.  However, nothing else grants you permission to modify or
distribute the Program or its derivative works.  These actions are
prohibited by law if you do not accept this License.  Therefore, by
modifying or distributing the Program (or any work based on the
Program), you indicate your acceptance of this License to do so, and
all its terms and conditions for copying, distributing or modifying
the Program or works based on it.

  6. Each time you redistribute the Program (or any work based on the
Program), the recipient automatically receives a license from the
original licensor to copy, distribute or modify the Program subject to
these terms and conditions.  You may not impose any further
restrictions on the recipients' exercise of the rights granted herein.
You are not responsible for enforcing compliance by third parties to
this License.

  7. If, as a consequence of a court judgment or allegation of patent
infringement or for any other reason (not limited to patent issues),
conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License.  If you cannot
distribute so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you
may not distribute the Program at all.  For example, if a patent
license would not permit royalty-free redistribution of the Program by
all those who receive copies directly or indirectly through you, then
the only way you could satisfy both it and this License would be to
refrain entirely from distribution of the Program.

If any portion of this section is held invalid or unenforceable under
any particular circumstance, the balance of the section is intended to
apply and the section as a whole is intended to apply in other
circumstances.

It is not the purpose of this section to induce you to infringe any
patents or other property right claims or to contest validity of any
such claims; this section has the sole purpose of protecting the
integrity of the free software distribution system, which is
implemented by public license practices.  Many people have made
generous contributions to the wide range of software distributed
through that system in reliance on consistent application of that
system; it is up to the author/donor to decide if he or she is willing
to distribute software through any other system and a licensee cannot
impose that choice.

This section is intended to make thoroughly clear what is believed to
be a consequence of the rest of this License.

  8. If the distribution and/or use of the Program is restricted in
certain countries either by patents or by copyrighted interfaces, the
original copyright holder who places the Program under this License
may add an explicit geographical distribution limitation excluding
those countries, so that distribution is permitted only in or among
countries not thus excluded.  In such case, this License incorporates
the limitation as if written in the body of this License.

  9. The Free Software Foundation may publish revised and/or new versions
of the General Public License from time to time.  Such new versions will
be similar in spirit to the present version, but may differ in detail to
address new problems or concerns.

Each version is given a distinguishing version number.  If the Program
specifies a version number of this License which applies to it and "any
later version", you have the option of following the terms and conditions
either of that version or of any later version published by the Free
Software Foundation.  If the Program does not specify a version number of
this License, you may choose any version ever published by the Free Software
Foundation.

  10. If you wish to incorporate parts of the Program into other free
programs whose distribution conditions are different, write to the author
to ask for permission.  For software which is copyrighted by the Free
Software Foundation, write to the Free Software Foundation; we sometimes
make exceptions for this.  Our decision will be guided by the two goals
of preserving the free status of all derivatives of our free software and
of promoting the sharing and reuse of software generally.

			    NO WARRANTY

  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS
TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE
PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
REPAIR OR CORRECTION.

  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
POSSIBILITY OF SUCH DAMAGES.

		     END OF TERMS AND CONDITIONS

	    How to Apply These Terms to Your New Programs

  If you develop a new program, and you want it to be of the greatest
possible use to the public, the best way to achieve this is to make it
free software which everyone can redistribute and change under these terms.

  To do so, attach the following notices to the program.  It is safest
to attach them to the start of each source file to most effectively
convey the exclusion of warranty; and each file should have at least
the "copyright" line and a pointer to where the full notice is found.

    
    Copyright (C)   

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA


Also add information on how to contact you by electronic and paper mail.

If the program is interactive, make it output a short notice like this
when it starts in an interactive mode:

    Gnomovision version 69, Copyright (C) year name of author
    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
    This is free software, and you are welcome to redistribute it
    under certain conditions; type `show c' for details.

The hypothetical commands `show w' and `show c' should show the appropriate
parts of the General Public License.  Of course, the commands you use may
be called something other than `show w' and `show c'; they could even be
mouse-clicks or menu items--whatever suits your program.

You should also get your employer (if you work as a programmer) or your
school, if any, to sign a "copyright disclaimer" for the program, if
necessary.  Here is a sample; alter the names:

  Yoyodyne, Inc., hereby disclaims all copyright interest in the program
  `Gnomovision' (which makes passes at compilers) written by James Hacker.

  , 1 April 1989
  Ty Coon, President of Vice

This General Public License does not permit incorporating your program into
proprietary programs.  If your program is a subroutine library, you may
consider it more useful to permit linking proprietary applications with the
library.  If this is what you want to do, use the GNU Library General
Public License instead of this License.
ruby-lapack-1.7.2/samples/0000755000175000017500000000000012655767602015253 5ustar  uwabamiuwabamiruby-lapack-1.7.2/samples/dpotrf.rb0000644000175000017500000000071712502223526017062 0ustar  uwabamiuwabamirequire "numru/lapack"

uplo = "L"
p a = NArray[[ 4.16, -3.12,  0.56, -0.10],
             [-3.12,  5.03, -0.83,  1.18],
             [ 0.56, -0.83,  0.76,  0.34],
             [-0.10,  1.18,  0.34,  1.18]]
a_org = a.dup
info, a = NumRu::Lapack.dpotrf(uplo, a)

p info
p a

for i in 0...a.shape[0]
  for j in 0...i
    a[j,i] = 0.0
  end
end

a = NMatrix.ref(a)

if (NArray.ref(a.transpose * a) - a_org).abs.gt(1.0e-10).count_true == 0
  p "OK"
else
  p "NG"
end
ruby-lapack-1.7.2/samples/dsyevr.rb0000644000175000017500000000062512502223526017076 0ustar  uwabamiuwabamirequire "numru/lapack"

jobz = "V"
range = "I"
uplo = "U"
a = NArray[[1,1,0], [1,2,1], [0,1,1]]
vl = vu = 0 # not be used in this example
il = 1
iu = 3
abstol = 0.0
lwork = 78
liwork = 30

m, w, z, isuppz, work, iwork, info, a =
  NumRu::Lapack.dsyevr(jobz, range, uplo,
                       a, vl, vu, il, iu, abstol, :lwork => lwork, :liwork => liwork)

p m
p w
p z
p isuppz
p work
p iwork
p info
p a
ruby-lapack-1.7.2/lib/0000755000175000017500000000000012655767602014355 5ustar  uwabamiuwabamiruby-lapack-1.7.2/lib/numru/0000755000175000017500000000000012655767602015523 5ustar  uwabamiuwabamiruby-lapack-1.7.2/lib/numru/lapack.rb0000644000175000017500000000170612502223526017266 0ustar  uwabamiuwabamibegin
  require "rubygems"
rescue LoadError
end
require "narray"
require "numru/lapack.so"



class NMatrix

  # to lapack matrix
  def to_lm
    NArray.ref(self.transpose)
  end

  # to lapack band matrix
  def to_lb(kl, ku, shift=0)
    n = shape[0]
    na = NArray.ref(self)
    lb = NArray.new(typecode, kl+ku+1+shift, n)
    n.times do |j|
      i0 = [n-1,j+kl].min
      i1 = [0,j-ku].max
      l = i0 - i1 + 1
      lb[-i1-1..-i0-1,j] = na[j,i0..i1]
    end
    lb
  end

  # to lapack symmetrix band matrix
  def to_lsb(uplo, kd)
    n = shape[0]
    lsb = NArray.new(typecode, kd+1, n)
    na = NArray.ref(self)
    case uplo
    when /U/i
      n.times do |j|
        i0 = [0,j-kd].max
        i1 = j
        lsb[i0+kd-j..i1+kd-j, j] = na[j,i0..i1]
      end
    when /L/i
      n.times do |j|
        i0 = j
        i1 = [n-1,j+kd].min
        lsb[i0-j..i1-j, j] = na[j,i0..i1]
      end
    else
      raise "uplo is invalid"
    end
    lsb
   end

end
ruby-lapack-1.7.2/COPYING0000644000175000017500000000472112502223525014624 0ustar  uwabamiuwabamiRuby-lapack is copyrighted free software by Seiya Nishizawa .
You can redistribute it and/or modify it under either the terms of the GPL
version 2 (see the file GPL), or the conditions below:

  1. You may make and give away verbatim copies of the source form of the
     software without restriction, provided that you duplicate all of the
     original copyright notices and associated disclaimers.

  2. You may modify your copy of the software in any way, provided that
     you do at least ONE of the following:

       a) place your modifications in the Public Domain or otherwise
          make them Freely Available, such as by posting said
	  modifications to Usenet or an equivalent medium, or by allowing
	  the author to include your modifications in the software.

       b) use the modified software only within your corporation or
          organization.

       c) give non-standard binaries non-standard names, with
          instructions on where to get the original software distribution.

       d) make other distribution arrangements with the author.

  3. You may distribute the software in object code or binary form,
     provided that you do at least ONE of the following:

       a) distribute the binaries and library files of the software,
	  together with instructions (in the manual page or equivalent)
	  on where to get the original distribution.

       b) accompany the distribution with the machine-readable source of
	  the software.

       c) give non-standard binaries non-standard names, with
          instructions on where to get the original software distribution.

       d) make other distribution arrangements with the author.

  4. You may modify and include the part of the software into any other
     software (possibly commercial).  But some files in the distribution
     are not written by the author, so that they are not under these terms.

     For the list of those files and their copying conditions, see the
     file LEGAL.

  5. The scripts and library files supplied as input to or produced as 
     output from the software do not automatically fall under the
     copyright of the software, but belong to whomever generated them, 
     and may be sold commercially, and may be aggregated with this
     software.

  6. THIS SOFTWARE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
     IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
     WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
     PURPOSE.
ruby-lapack-1.7.2/tests/0000755000175000017500000000000012655767602014751 5ustar  uwabamiuwabamiruby-lapack-1.7.2/tests/lin/0000755000175000017500000000000012655767602015533 5ustar  uwabamiuwabamiruby-lapack-1.7.2/tests/lin/gt/0000755000175000017500000000000012655767602016145 5ustar  uwabamiuwabamiruby-lapack-1.7.2/tests/lin/gt/test_gtsv.rb0000644000175000017500000000220512502223526020472 0ustar  uwabamiuwabami$:.push File.dirname(__FILE__) + "/../.."
require "lapack_test"

class GtsvTest < Test::Unit::TestCase
  include LapackTest

  def setup
    @du = Hash.new
    @d  = Hash.new
    @dl = Hash.new
    @b = Hash.new
    @b_exp = Hash.new

    @du[:r] = NArray[2.1, -1.0,  1.9,  8.0]
    @d[:r]  = NArray[3.0,  2.3, -5.0, -0.9, 7.1]
    @dl[:r] = NArray[3.4,  3.6,  7.0, -6.0]
    @b[:r] = NArray[[2.7, -0.5,  2.6,  0.6, 2.7]]
    @b_exp[:r] = NArray[[-4.0, 7.0, 3.0, -4.0, -3.0]]

    @du[:c] = NArray[ 2.0-1.0*I,  2.0+1.0*I, -1.0+1.0*I,  1.0-1.0*I]
    @d[:c]  = NArray[-1.3+1.3*I, -1.3+1.3*I, -1.3+3.3*I, -0.3+4.3*I, -3.3+1.3*I]
    @dl[:c] = NArray[ 1.0-2.0*I,  1.0+1.0*I,  2.0-3.0*I,  1.0+1.0*I]
    @b[:c] = NArray[[2.4-5.0*I, 3.4+18.2*I, -14.7+9.7*I, 31.9-7.7*I, -1.0+1.6*I]]
    @b_exp[:c] = NArray[[1.0+1.0*I, 3.0-1.0*I, 4.0+5.0*I, -1.0-2.0*I, 1.0-1.0*I]]
  end

  %w(s d c z).each do |x|
    method = "#{x}gtsv"
    rc = LapackTest.get_rc(x)

    define_method("test_#{method}") do 
      info, dl, d, du, b = NumRu::Lapack.send(method, @dl[rc], @d[rc], @du[rc], @b[rc])
      assert_equal 0, info
      assert_narray @b_exp[rc], b
    end

  end

end
ruby-lapack-1.7.2/tests/lin/gb/0000755000175000017500000000000012655767602016123 5ustar  uwabamiuwabamiruby-lapack-1.7.2/tests/lin/gb/test_gbsv.rb0000644000175000017500000000270312502223526020431 0ustar  uwabamiuwabami$:.push File.dirname(__FILE__) + "/../.."
require "lapack_test"

class GbsvTest < Test::Unit::TestCase
  include LapackTest

  def setup
    @ab = Hash.new
    @b = Hash.new
    @b_exp = Hash.new
    @ipiv_exp = Hash.new

    @kl = 1
    @ku = 2

    @ab[:r] = NMatrix[[-0.23,  2.54, -3.66,  0.00],
                      [-6.98,  2.46, -2.73, -2.13],
                      [ 0.00,  2.56,  2.46,  4.07],
                      [ 0.00,  0.00, -4.78, -3.82]].to_lb(@kl, @ku, @kl)
    @b[:r] = NVector[[4.42, 27.13, -6.14, 10.50]]
    @b_exp[:r] = NArray[[-2.0, 3.0, 1.0, -4.0]]
    @ipiv_exp[:r] = NArray[2, 3, 3, 4]

    @ab[:c] = NMatrix[[-1.65+2.26*I, -2.05-0.85*I,  0.97-2.84*I, 0.00+0.00*I],
                      [ 0.00+6.30*I, -1.48-1.75*I, -3.99+4.01*I, 0.59-0.48*I],
                      [ 0.00+0.00*I, -0.77+2.83*I, -1.06+1.94*I, 3.33-1.04*I],
                      [ 0.00+0.00*I,  0.00+0.00*I,  4.48-1.09*I, -0.46-1.72*I]].to_lb(@kl, @ku, @kl)
    @b[:c] = NVector[[-1.06+21.50*I, -22.72-53.90*I, 28.24-38.60*I, -34.56+16.73*I]]
    @b_exp[:c] = NArray[[-3.0+2.0*I, 1.0-7.0*I, -5.0+4.0*I, 6.0-8.0*I]]
    @ipiv_exp[:c] = NArray[2, 3, 3, 4]
  end

  %w(s d c z).each do |x|
    method = "#{x}gbsv"
    rc = LapackTest.get_rc(x)

    define_method("test_#{method}") do
      ipiv, info, ab, b = NumRu::Lapack.send(method, @kl, @ku, @ab[rc], @b[rc])
      assert_equal 0, info
      assert_narray @b_exp[rc], b
      assert_equal @ipiv_exp[rc], ipiv
    end

  end

end
ruby-lapack-1.7.2/tests/lin/gb/test_gbsvx.rb0000644000175000017500000000370212502223526020621 0ustar  uwabamiuwabami$:.push File.dirname(__FILE__) + "/../.."
require "lapack_test"

class GbsvxTest < Test::Unit::TestCase
  include LapackTest

  def setup
    @ab = Hash.new
    @b = Hash.new
    @x_exp = Hash.new
    @ipiv_exp = Hash.new
    @rcond_exp = Hash.new

    @kl = 1
    @ku = 2
    @rpgf_exp = 1.0

    @ab[:r] = NMatrix[[-0.23,  2.54, -3.66,  0.00],
                      [-6.98,  2.46, -2.73, -2.13],
                      [ 0.00,  2.56,  2.46,  4.07],
                      [ 0.00,  0.00, -4.78, -3.82]].to_lb(@kl, @ku)
    @b[:r] = NVector[[  4.42,  27.13, -6.14,  10.50],
                     [-36.01, -31.67, -1.16, -25.82]]
    @x_exp[:r] = NArray[[-2.0,  3.0, 1.0, -4.0],
                        [ 1.0, -4.0, 7.0, -2.0]]
    @ipiv_exp[:r] = NArray[2, 3, 3, 4]
    @rcond_exp[:r] = 1.8e-2

    @ab[:c] = NMatrix[[-1.65+2.26*I, -2.05-0.85*I,  0.97-2.84*I, 0.00+0.00*I],
                      [ 0.00+6.30*I, -1.48-1.75*I, -3.99+4.01*I, 0.59-0.48*I],
                      [ 0.00+0.00*I, -0.77+2.83*I, -1.06+1.94*I, 3.33-1.04*I],
                      [ 0.00+0.00*I,  0.00+0.00*I,  4.48-1.09*I, -0.46-1.72*I]].to_lb(@kl, @ku)
    @b[:c] = NVector[[-1.06+21.50*I, -22.72-53.90*I, 28.24-38.60*I, -34.56+16.73*I],
                     [12.85+ 2.84*I, -70.22+21.57*I, -20.73- 1.23*I,  26.01+31.97*I]]
    @x_exp[:c] = NArray[[-3.0+2.0*I,  1.0-7.0*I, -5.0+4.0*I,  6.0-8.0*I],
                        [ 1.0+6.0*I, -7.0-4.0*I,  3.0+5.0*I, -8.0+2.0*I]]
    @ipiv_exp[:c] = NArray[2, 3, 3, 4]
    @rcond_exp[:c] = 9.6e-3
  end

  %w(s d c z).each do |x|
    method = "#{x}gbsvx"
    rc = LapackTest.get_rc(x)

    define_method("test_#{method}") do
      x, rcond, ferr, berr, work, info, ab, afb, ipiv, equed, r, c, b = NumRu::Lapack.send(method, "E", "N", @kl, @ku, @ab[rc], @b[rc])
      assert_equal(0, info)
      assert_narray @x_exp[rc], x
      assert_equal @ipiv_exp[rc], ipiv
      assert_in_delta @rcond_exp[rc], rcond, 1.0e-3
      assert_equal @rpgf_exp, work[0]
    end

  end

end
ruby-lapack-1.7.2/tests/lin/sy/0000755000175000017500000000000012655767602016166 5ustar  uwabamiuwabamiruby-lapack-1.7.2/tests/lin/sy/test_sysv.rb0000644000175000017500000000427112502223526020541 0ustar  uwabamiuwabami$:.push File.dirname(__FILE__) + "/../.."
require "lapack_test"

class SysvTest < Test::Unit::TestCase
  include LapackTest

  def setup
    @a = Hash.new
    @b = Hash.new
    @b_exp = Hash.new
    @ipiv_exp = Hash.new

    @a[:r] = NMatrix[[-1.81,  2.06,  0.63, -1.15],
                     [ 2.06,  1.15,  1.87,  4.20],
                     [ 0.63,  1.87, -0.21,  3.87],
                     [-1.15,  4.20,  3.87,  2.07]].to_lm
    @b[:r] = NVector[[0.96, 6.07, 8.38, 9.50]]
    @b_exp[:r] = NArray[[-5.0, -2.0, 1.0, 4.0]]
    @ipiv_exp[:r] = NArray[1, 2, -2, -2]

    @a[:c] = NMatrix[[-0.56+0.12*I, -1.54-2.86*I,  5.32-1.59*I,  3.80+0.92*I],
                     [-1.54-2.86*I, -2.83-0.03*I, -3.52+0.58*I, -7.86-2.96*I],
                     [ 5.32-1.59*I, -3.52+0.58*I,  8.86+1.81*I,  5.14-0.64*I],
                     [ 3.80+0.92*I, -7.86-2.96*I,  5.14-0.64*I, -0.39-0.71*I]].to_lm
    @b[:c] = NVector[[-6.43+19.24*I, -0.49-1.47*I, -48.18+66.0*I, -55.64+41.22*I]]
    @b_exp[:c] = NArray[[-4.0+3.0*I, 3.0-2.0*I, -2.0+5.0*I, 1.0-1.0*I]]
    @ipiv_exp[:c] = NArray[1, 2, -2, -2]
  end

  %w(s d c z).each do |x|
    method = "#{x}sysv"
    rc = LapackTest.get_rc(x)

    define_method("test_#{method}") do
      ipiv, work, info, a, b = NumRu::Lapack.send(method, "U", @a[rc], @b[rc])
      assert_equal 0, info
      assert_narray @b_exp[rc], b
      assert_narray @ipiv_exp[rc], ipiv
    end

    define_method("test_#{method}_inquiring_lwork") do
      rank, work, info, = NumRu::Lapack.send(method, "U", @a[rc], @b[rc], :lwork => -1)
      assert_equal 0, info
      lwork = get_int(work[0])
      ipiv, work, info, a, b = NumRu::Lapack.send(method, "U", @a[rc], @b[rc], :lwork => lwork)
      assert_equal 0, info
      assert_equal lwork, get_int(work[0])
      assert_narray @b_exp[rc], b
      assert_narray @ipiv_exp[rc], ipiv
    end

    define_method("test_#{method}_inquiring_lwork_oldargstyle") do
      rank, work, info, = NumRu::Lapack.send(method, "U", @a[rc], @b[rc], :lwork => -1)
      assert_equal 0, info
      lwork = get_int(work[0])
      rank, work, info, = NumRu::Lapack.send(method, "U", @a[rc], @b[rc], -1)
      assert_equal 0, info
      assert_equal lwork, get_int(work[0])
    end

  end

end
ruby-lapack-1.7.2/tests/lin/ge/0000755000175000017500000000000012655767602016126 5ustar  uwabamiuwabamiruby-lapack-1.7.2/tests/lin/ge/test_gels.rb0000644000175000017500000000453512502223526020432 0ustar  uwabamiuwabami$:.push File.dirname(__FILE__) + "/../.."
require "lapack_test"

class GelsTest < Test::Unit::TestCase
  include LapackTest

  def setup
    @a = Hash.new
    @b = Hash.new
    @b_exp = Hash.new

    @a[:r] = NMatrix[[-0.57, -1.28, -0.39,  0.25],
                     [-1.93,  1.08, -0.31, -2.14],
                     [ 2.30,  0.24,  0.40, -0.35],
                     [-1.93,  0.64, -0.66,  0.08],
                     [ 0.15,  0.30,  0.15, -2.13],
                     [-0.02,  1.03, -1.43,  0.50]].to_lm
    @b[:r] = NVector[[-2.67, -0.55, 3.34, -0.77, 0.48, 4.10]]
    @b_exp[:r] = NArray[[1.5339, 1.8707, -1.5241, 0.0392]]

    i = Complex::I
    @a[:c] = NMatrix[[ 0.96-0.81*I, -0.03+0.96*I, -0.91+2.06*I, -0.05+0.41*I],
                     [-0.98+1.98*I, -1.20+0.19*I, -0.66+0.42*I, -0.81+0.56*I],
                     [ 0.62-0.46*I,  1.01+0.02*I,  0.63-0.17*I, -1.11+0.60*I],
                     [-0.37+0.38*I,  0.19-0.54*I, -0.98-0.36*I,  0.22-0.20*I],
                     [ 0.83+0.51*I,  0.20+0.01*I, -0.17-0.46*I,  1.47+1.59*I],
                     [ 1.08-0.28*I,  0.20-0.12*I, -0.07+1.23*I,  0.26+0.26*I]].to_lm
    @b[:c] = NVector[[-2.09+1.93*I, 3.34-3.53*I, -4.94-2.04*I, 0.17+4.23*I, -5.19+3.63*I, 0.98+2.53*I]]
    @b_exp[:c] = NArray[[-0.5044-1.2179*I, -2.4281+2.8574*I, 1.4872-2.1955*I, 0.4537+2.6904*I]]
  end

  %w(s d c z).each do |x|
    method = "#{x}gels"
    rc = LapackTest.get_rc(x)

    define_method("test_#{method}") do
      work, info, a, b = NumRu::Lapack.send(method, "N", @a[rc], @b[rc])
      assert_equal 0, info
      assert_narray @b_exp[rc], b, 1.0e-4
    end

    define_method("test_#{method}_inquiring_lwork") do
      work, info, a, b = NumRu::Lapack.send(method, "N", @a[rc], @b[rc], :lwork => -1)
      assert_equal 0, info
      lwork = get_int(work[0])
      work, info, a, b = NumRu::Lapack.send(method, "N", @a[rc], @b[rc], :lwork => lwork)
      assert_equal 0, info
      assert_equal lwork, get_int(work[0])
      assert_narray @b_exp[rc], b, 1.0e-4
    end

    define_method("test_#{method}_inquiring_lwork_oldargstyle") do
      work, info, a, b = NumRu::Lapack.send(method, "N", @a[rc], @b[rc], :lwork => -1)
      assert_equal 0, info
      lwork = get_int(work[0])
      work, info, a, b = NumRu::Lapack.send(method, "N", @a[rc], @b[rc], -1)
      assert_equal 0, info
      assert_equal lwork, get_int(work[0])
    end

  end

end
ruby-lapack-1.7.2/tests/lin/ge/test_gelsd.rb0000644000175000017500000000375112502223526020575 0ustar  uwabamiuwabami$:.push File.dirname(__FILE__) + "/../.."
require "lapack_test"

class GelsdTest < Test::Unit::TestCase
  include LapackTest

  def setup
    @a = Hash.new
    @b = Hash.new
    @b_exp = Hash.new
    @s_exp = Hash.new
    @rank_exp = Hash.new

    @a[:r] = NMatrix[[-0.09, -1.56, -1.48, -1.09,  0.08, -1.59],
                     [ 0.14,  0.20, -0.43,  0.84,  0.55, -0.72],
                     [-0.46,  0.29,  0.89,  0.77, -1.13,  1.06],
                     [ 0.68,  1.09, -0.71,  2.11,  0.14,  1.24],
                     [ 1.29,  0.51, -0.96, -1.27,  1.74,  0.34]].to_lm
    @b[:r] = NVector[[7.4, 4.3, -8.1, 1.8, 8.7]]
    @b_exp[:r] = NArray[[1.5938, -0.1180, -3.1501, 0.1554, 2.5529, -1.6730]]
    @s_exp[:r] = NArray[3.9997, 2.9962, 2.0001, 0.9988, 0.0025]
    @rank_exp[:r] = 4

    @a[:c] = NMatrix[[ 0.47-0.34*I, -0.32-0.23*I,  0.35-0.60*I,  0.89+0.71*I, -0.19+0.06*I],
                     [-0.40+0.54*I, -0.05+0.20*I, -0.52-0.34*I, -0.45-0.45*I,  0.11-0.85*I],
                     [ 0.60+0.01*I, -0.26-0.44*I,  0.87-0.11*I, -0.02-0.57*I,  1.44+0.80*I],
                     [ 0.80-1.02*I, -0.43+0.17*I, -0.34-0.09*I,  1.14-0.78*I,  0.07+1.14*I]].to_lm
    @b[:c] = NVector[[2.15-0.20*I, -2.24+1.82*I, 4.45-4.28*I, 5.70-6.25*I]]

    @b_exp[:c] = NArray[[3.9747-1.8377*I, -0.9186+0.8253*I, -0.3105+0.1477*I, 1.0050+0.8626*I, -0.2256-1.9425*I]]
    @s_exp[:c] = NArray[2.9979, 1.9983, 1.0044, 0.0064]
    @rank_exp[:c] = 3

    @rcond = 0.01
  end

  %w(s d c z).each do |x|
    method = "#{x}gelsd"
    rc = LapackTest.get_rc(x)

    define_method("test_#{method}") do
      s, rank, work, info, b = NumRu::Lapack.send(method, @a[rc], @b[rc], @rcond, -1)
      assert_equal 0, info
      lwork = get_int(work[0])
      s, rank, work, info, b = NumRu::Lapack.send(method, @a[rc], @b[rc], @rcond, lwork)
      assert_equal 0, info
      assert_equal lwork, get_int(work[0])
      assert_equal @rank_exp[rc], rank
      assert_narray @b_exp[rc], b, 10e-4
      assert_narray @s_exp[rc], s, 10e-4
    end
  end

end
ruby-lapack-1.7.2/tests/lin/ge/test_gesvx.rb0000644000175000017500000000356412502223526020635 0ustar  uwabamiuwabami$:.push File.dirname(__FILE__) + "/../.."
require "lapack_test"

class GesvxTest < Test::Unit::TestCase
  include LapackTest

  def setup
    @a = Hash.new
    @b = Hash.new
    @x_exp = Hash.new
    @ipiv_exp = Hash.new
    @rcond_exp = Hash.new
    @rpgf_exp = Hash.new

    @a[:r] = NMatrix[[   1.80,    2.88,  2.05,   -0.89],
                     [ 525.00, -295.00,-95.00, -380.00],
                     [   1.58,   -2.69, -2.90,   -1.04],
                     [  -1.11,   -0.66, -0.59,    0.80]].to_lm
    @b[:r] = NVector[[ 9.52, 2435.00,   0.77, -6.22],
                     [18.47,  225.00, -13.28, -6.21]]
    @x_exp[:r] = NArray[[1.0, -1.0, 3.0, -5.0],
                        [3.0,  2.0, 4.0,  1.0]]
    @rcond_exp[:r] = 1.8e-2
    @rpgf_exp[:r] = 7.4e-1

    @a[:c] = NMatrix[[-1.34 +2.55*I,  0.28+3.17*I, -6.39 -2.20*I,  0.72 -0.92*I],
                     [-1.70-14.10*I, 33.10-1.50*I, -1.50+13.40*I, 12.90+13.80*I],
                     [-3.29 -2.39*I, -1.91+4.42*I, -0.14 -1.35*I,  1.72 +1.35*I],
                     [ 2.41 +0.39*I, -0.56+1.47*I, -0.83 -0.69*I, -1.96 +0.67*I]].to_lm
    @b[:c] = NVector[[26.26+51.78*I,  64.30-86.80*I, -5.75+25.31*I,  1.16+2.57*I],
                     [31.32 -6.70*I, 158.60-14.20*I, -2.15+30.19*I, -2.56+7.55*I]]
    @x_exp[:c] = NArray[[ 1.0+1.0*I, 2.0-3.0*I, -4.0-5.0*I, 0.0+6.0*I],
                        [-1.0-2.0*I, 5.0+1.0*I, -3.0+4.0*I, 2.0-3.0*I]]
    @rcond_exp[:c] = 1.0e-2
    @rpgf_exp[:c] = 8.3e-1
  end

  %w(s d c z).each do |x|
    method = "#{x}gesvx"
    rc = LapackTest.get_rc(x)

    define_method("test_#{method}") do 
      x, rcond, ferr, berr, work, info, a, af, ipiv, equed, r, c, b = NumRu::Lapack.send(method, "E", "N", @a[rc], @b[rc])
      assert_equal 0, info
      assert_narray @x_exp[rc], x, 1.0e-4
      assert_in_delta @rcond_exp[rc], rcond, 1e-3
      assert_in_delta @rpgf_exp[rc], work[0], 1e-2
    end

  end

end
ruby-lapack-1.7.2/tests/lin/ge/test_gelss.rb0000644000175000017500000000532312502223526020611 0ustar  uwabamiuwabami$:.push File.dirname(__FILE__) + "/../.."
require "lapack_test"

class GelssTest < Test::Unit::TestCase
  include LapackTest

  def setup
    @a = Hash.new
    @b = Hash.new
    @b_exp = Hash.new
    @s_exp = Hash.new
    @rank_exp = Hash.new

    @a[:r] = NMatrix[[-0.09,  0.14, -0.46,  0.68,  1.29],
                     [-1.56,  0.20,  0.29,  1.09,  0.51],
                     [-1.48, -0.43,  0.89, -0.71, -0.96],
                     [-1.09,  0.84,  0.77,  2.11, -1.27],
                     [ 0.08,  0.55, -1.13,  0.14,  1.74],
                     [-1.59, -0.72,  1.06,  1.24,  0.34]].to_lm
    @b[:r] = NVector[[7.4, 4.2, -8.3, 1.8, 8.6, 2.1]]
    @rank_exp[:r] = 4
    @b_exp[:r] = NArray[[0.6344, 0.9699, -1.4403, 3.3678, 3.3992]]
    @s_exp[:r] = NArray[3.9997, 2.9962, 2.0001, 0.9988, 0.0025]

    @a[:c] = NMatrix[[ 0.47-0.34*I, -0.40+0.54*I,  0.60+0.01*I,  0.80-1.02*I],
                     [-0.32-0.23*I, -0.05+0.20*I, -0.26-0.44*I, -0.43+0.17*I],
                     [ 0.35-0.60*I, -0.52-0.34*I,  0.87-0.11*I, -0.34-0.09*I],
                     [ 0.89+0.71*I, -0.45-0.45*I, -0.02-0.57*I,  1.14-0.78*I],
                     [-0.19+0.06*I,  0.11-0.85*I,  1.44+0.80*I,  0.07+1.14*I]].to_lm
    @b[:c] = NVector[[-1.08-2.59*I, -2.61-1.49*I, 3.13-3.61*I, 7.33-8.01*I, 9.12+7.63*I]]
    @b_exp[:c] = NArray[[1.1673-3.3222*I, 1.3480+5.5028*I, 4.1762+2.3434*I, 0.6465+0.0105*I]]
    @s_exp[:c] = NArray[2.9979, 1.9983, 1.0044, 0.0064]
    @rank_exp[:c] = 3

    @rcond = 0.01
  end

  %w(s d c z).each do |x|
    method = "#{x}gelss"
    rc = LapackTest.get_rc(x)

    define_method("test_#{method}") do
      s, rank, work, info, a, b = NumRu::Lapack.send(method, @a[rc], @b[rc], @rcond)
      assert_equal 0, info
      assert_narray @b_exp[rc], b, 1e-4
      assert_narray @s_exp[rc], s, 1e-4
      assert_equal @rank_exp[rc], rank
    end

    define_method("test_#{method}_inquiring_lwork") do
      s, rank, work, info, a, b = NumRu::Lapack.send(method, @a[rc], @b[rc], @rcond, :lwork => -1)
      assert_equal 0, info
      lwork = get_int(work[0])
      s, rank, work, info, a, b = NumRu::Lapack.send(method, @a[rc], @b[rc], @rcond, :lwork => lwork)
      assert_equal 0, info
      assert_equal lwork, get_int(work[0])
      assert_narray @b_exp[rc], b, 1e-4
      assert_narray @s_exp[rc], s, 1e-4
      assert_equal @rank_exp[rc], rank
    end

    define_method("test_#{method}_inquiring_lwork_oldargstyle") do
      s, rank, work, info, a, b = NumRu::Lapack.send(method, @a[rc], @b[rc], @rcond, :lwork => -1)
      assert_equal 0, info
      lwork = get_int(work[0])
      s, rank, work, info, a, b = NumRu::Lapack.send(method, @a[rc], @b[rc], @rcond, -1)
      assert_equal 0, info
      assert_equal lwork, get_int(work[0])
    end

  end

end
ruby-lapack-1.7.2/tests/lin/ge/test_gelsy.rb0000644000175000017500000000524612502223526020623 0ustar  uwabamiuwabami$:.push File.dirname(__FILE__) + "/../.."
require "lapack_test"

class GelsyTest < Test::Unit::TestCase
  include LapackTest

  def setup
    @a = Hash.new
    @b = Hash.new
    @jpvt = Hash.new
    @b_exp = Hash.new
    @rank_exp = Hash.new

    @a[:r] = NMatrix[[-0.09,  0.14, -0.46,  0.68,  1.29],
                     [-1.56,  0.20,  0.29,  1.09,  0.51],
                     [-1.48, -0.43,  0.89, -0.71, -0.96],
                     [-1.09,  0.84,  0.77,  2.11, -1.27],
                     [ 0.08,  0.55, -1.13,  0.14,  1.74],
                     [-1.59, -0.72,  1.06,  1.24,  0.34]].to_lm
    @b[:r] = NVector[[7.4, 4.2, -8.3, 1.8, 8.6, 2.1]]
    @jpvt[:r] = NArray.int(@a[:r].shape[1])
    @b_exp[:r] = NArray[[0.6344, 0.9699, -1.4403, 3.3678, 3.3992]]
    @rank_exp[:r] = 4

    i = Complex::I
    @a[:c] = NMatrix[[ 0.47-0.34*I, -0.40+0.54*I,  0.60+0.01*I,  0.80-1.02*I],
                     [-0.32-0.23*I, -0.05+0.20*I, -0.26-0.44*I, -0.43+0.17*I],
                     [ 0.35-0.60*I, -0.52-0.34*I,  0.87-0.11*I, -0.34-0.09*I],
                     [ 0.89+0.71*I, -0.45-0.45*I, -0.02-0.57*I,  1.14-0.78*I],
                     [-0.19+0.06*I,  0.11-0.85*I,  1.44+0.80*I,  0.07+1.14*I]].to_lm
    @b[:c] = NVector[[-1.08-2.59*I, -2.61-1.49*I, 3.13-3.61*I, 7.33-8.01*I, 9.12+7.63*I]]
    @jpvt[:c] = NArray.int(@a[:c].shape[1])
    @b_exp[:c] = NArray[[1.1669-3.3224*I, 1.3486+5.5027*I, 4.1764+2.3435*I, 0.6467+0.0107*I]]
    @rank_exp[:c] = 3

    @rcond = 0.01
  end


  %w(s d c z).each do |x|
    method = "#{x}gelsy"
    rc = LapackTest.get_rc(x)

    define_method("test_#{method}") do
      rank, work, info, a, b, jpvt = NumRu::Lapack.send(method, @a[rc], @b[rc], @jpvt[rc], @rcond)
      assert_equal 0, info
      assert_narray @b_exp[rc], b, 1e-4
      assert_equal @rank_exp[rc], rank
    end

    define_method("test_#{method}_inquiring_lwork") do
      rank, work, info, = NumRu::Lapack.send(method, @a[rc], @b[rc], @jpvt[rc], @rcond, :lwork => -1)
      assert_equal 0, info
      lwork = get_int(work[0])
      rank, work, info, a, b, jpvt = NumRu::Lapack.send(method, @a[rc], @b[rc], @jpvt[rc], @rcond, :lwork => lwork)
      assert_equal 0, info
      assert_equal lwork, get_int(work[0])
      assert_narray @b_exp[rc], b, 1e-4
      assert_equal @rank_exp[rc], rank
    end

    define_method("test_#{method}_inquiring_lwork_oldargstyle") do
      rank, work, info, = NumRu::Lapack.send(method, @a[rc], @b[rc], @jpvt[rc], @rcond, :lwork => -1)
      assert_equal 0, info
      lwork = get_int(work[0])
      rank, work, info, a, b, jpvt = NumRu::Lapack.send(method, @a[rc], @b[rc], @jpvt[rc], @rcond, -1)
      assert_equal 0, info
      assert_equal lwork, get_int(work[0])
    end

  end

end
ruby-lapack-1.7.2/tests/lin/ge/test_gesv.rb0000644000175000017500000000256412502223526020444 0ustar  uwabamiuwabami$:.push File.dirname(__FILE__) + "/../.."
require "lapack_test"

class GesvTest < Test::Unit::TestCase
  include LapackTest

  def setup
    @a = Hash.new
    @b = Hash.new
    @b_exp = Hash.new
    @ipiv_exp = Hash.new

    @a[:r] = NMatrix[[ 1.80,  2.88,  2.05, -0.89],
                     [ 5.25, -2.95, -0.95, -3.80],
                     [ 1.58, -2.69, -2.90, -1.04],
                     [-1.11, -0.66, -0.59,  0.80]].to_lm
    @b[:r] = NVector[[9.52, 24.35, 0.77, -6.22]]
    @b_exp[:r] = NArray[[1.0, -1.0, 3.0, -5.0]]
    @ipiv_exp[:r] = NArray[2, 2, 3, 4]

    @a[:c] = NMatrix[[-1.34+2.55*I,  0.28+3.17*I, -6.39-2.20*I,  0.72-0.92*I],
                     [-0.17-1.41*I,  3.31-0.15*I, -0.15+1.34*I,  1.29+1.38*I],
                     [-3.29-2.39*I, -1.91+4.42*I, -0.14-1.35*I,  1.72+1.35*I],
                     [ 2.41+0.39*I, -0.56+1.47*I, -0.83-0.69*I, -1.96+0.67*I]].to_lm
    @b[:c] = NVector[[26.26+51.78*I, 6.43-8.68*I, -5.75+25.31*I, 1.16+2.57*I]]
    @b_exp[:c] = NArray[[1.0+1.0*I, 2.0-3.0*I, -4.0-5.0*I, 0.0+6.0*I]]
    @ipiv_exp[:c] = NArray[3, 2, 3, 4]
  end

  %w(s d c z).each do |x|
    method = "#{x}gesv"
    rc = LapackTest.get_rc(x)

    define_method("test_#{method}") do 
      ipiv, info, a, b = NumRu::Lapack.send(method, @a[rc], @b[rc])
      assert_equal 0, info
      assert_narray @b_exp[rc], b
      assert_narray @ipiv_exp[rc], ipiv
    end

  end

end
ruby-lapack-1.7.2/tests/eig/0000755000175000017500000000000012655767602015515 5ustar  uwabamiuwabamiruby-lapack-1.7.2/tests/eig/gg/0000755000175000017500000000000012655767602016112 5ustar  uwabamiuwabamiruby-lapack-1.7.2/tests/eig/gg/test_ggsvd.rb0000644000175000017500000001026012502223526020566 0ustar  uwabamiuwabami$:.push File.dirname(__FILE__) + "/../.."
require "lapack_test"

class GgsvdTest < Test::Unit::TestCase
  include LapackTest

  def setup
    @a = Hash.new
    @b = Hash.new
    @k_exp = Hash.new
    @l_exp = Hash.new
    @gsv_exp = Hash.new
    @u_exp = Hash.new
    @v_exp = Hash.new
    @q_exp = Hash.new

    @a[:r] =  NMatrix[[1.0, 2.0, 3.0],
                      [3.0, 2.0, 1.0],
                      [4.0, 5.0, 6.0],
                      [7.0, 8.0, 8.0]].to_lm
    @b[:r] = NMatrix[[-2.0, -3.0, 3.0],
                     [ 4.0,  6.0, 5.0]].to_lm
    @k_exp[:r] = 1
    @l_exp[:r] = 2
    @gsv_exp[:r] = NArray[1.3151, 8.0185e-2]
    @u_exp[:r] = NMatrix[[-1.3484e-1,  5.2524e-1, -2.0924e-1,  8.1373e-1 ],
                         [ 6.7420e-1, -5.2213e-1, -3.8886e-1,  3.4874e-1 ],
                         [ 2.6968e-1,  5.2757e-1, -6.5782e-1, -4.6499e-1 ],
                         [ 6.7420e-1,  4.1615e-1,  6.1014e-1,  1.5127e-15]].to_lm
    @v_exp[:r] = NMatrix[[3.5539e-1, -9.3472e-1],
                         [9.3472e-1,  3.5539e-1]].to_lm
    @q_exp[:r] = NMatrix[[-8.3205e-1, -9.4633e-2, -5.4657e-1],
                         [ 5.5470e-1, -1.4195e-1, -8.1985e-1],
                         [ 0.0000e+0, -9.8534e-1,  1.7060e-1]].to_lm

    @a[:c] = NMatrix[[ 0.96-0.81*I, -0.03+0.96*I, -0.91+2.06*I, -0.05+0.41*I],
                     [-0.98+1.98*I, -1.20+0.19*I, -0.66+0.42*I, -0.81+0.56*I],
                     [ 0.62-0.46*I,  1.01+0.02*I,  0.63-0.17*I, -1.11+0.60*I],
                     [ 0.37+0.38*I,  0.19-0.54*I, -0.98-0.36*I,  0.22-0.20*I],
                     [ 0.83+0.51*I,  0.20+0.01*I, -0.17-0.46*I,  1.47+1.59*I],
                     [ 1.08-0.28*I,  0.20-0.12*I, -0.07+1.23*I,  0.26+0.26*I]].to_lm
    @b[:c] = NMatrix[[ 1.00+0.00*I,  0.00+0.00*I, -1.00+0.00*I,  0.00+0.00*I],
                     [ 0.00+0.00*I,  1.00+0.00*I,  0.00+0.00*I, -1.00+0.00*I]].to_lm
    @k_exp[:c] = 2
    @l_exp[:c] = 2
    @gsv_exp[:c] = NArray[2.0720e+0, 1.1058e+0]
    @u_exp[:c] = NMatrix[[-1.3038e-02-3.2595e-01*I, -1.4039e-01-2.6167e-01*I,  2.5177e-01-7.9789e-01*I, -5.0956e-02-2.1750e-01*I, -4.5947e-02+1.4052e-04*I, -5.2773e-02-2.2492e-01*I],
                         [ 4.2764e-01-6.2582e-01*I,  8.6298e-02-3.8174e-02*I, -3.2188e-01+1.6112e-01*I,  1.1979e-01+1.6319e-01*I, -8.0311e-02-4.3605e-01*I, -3.8117e-02-2.1907e-01*I],
                         [-3.2595e-01+1.6428e-01*I,  3.8163e-01-1.8219e-01*I,  1.3231e-01-1.4565e-02*I, -5.0671e-01+1.8615e-01*I,  5.9714e-02-5.8974e-01*I, -1.3850e-01-9.0941e-02*I],
                         [ 1.5906e-01-5.2151e-03*I, -2.8207e-01+1.9732e-01*I,  2.1598e-01+1.8813e-01*I, -4.0163e-01+2.6787e-01*I, -4.6443e-02+3.0864e-01*I, -3.7354e-01-5.5148e-01*I],
                         [-1.7210e-01-1.3038e-02*I, -5.0942e-01-5.0319e-01*I,  3.6488e-02+2.0316e-01*I,  1.9271e-01+1.5574e-01*I,  5.7843e-01-1.2439e-01*I, -1.8815e-02-5.5686e-02*I],
                         [-2.6336e-01-2.4772e-01*I, -1.0861e-01+2.8474e-01*I,  1.0906e-01-1.2712e-01*I, -8.8159e-02+5.6169e-01*I,  1.5763e-02+4.7130e-02*I,  6.5007e-01+4.9173e-03*I]].to_lm
    @v_exp[:c] = NMatrix[[ 9.8930e-01+1.9041e-19*I, -1.1461e-01+9.0250e-02*I],
                         [-1.1461e-01-9.0250e-02*I, -9.8930e-01+1.9041e-19*I]].to_lm
    @q_exp[:c] = NMatrix[[7.0711e-01+0.0000e+00*I,  0.0000e+00+0.0000e+00*I,  6.9954e-01+4.7274e-19*I,  8.1044e-02-6.3817e-02*I],
                         [0.0000e+00+0.0000e+00*I,  7.0711e-01+0.0000e+00*I, -8.1044e-02-6.3817e-02*I,  6.9954e-01-4.7274e-19*I],
                         [7.0711e-01+0.0000e+00*I,  0.0000e+00+0.0000e+00*I, -6.9954e-01-4.7274e-19*I, -8.1044e-02+6.3817e-02*I],
                         [0.0000e+00+0.0000e+00*I,  7.0711e-01+0.0000e+00*I,  8.1044e-02+6.3817e-02*I, -6.9954e-01+4.7274e-19*I]].to_lm
  end

  %w(s d c z).each do |x|
    method = "#{x}ggsvd"
    rc = LapackTest.get_rc(x)

    define_method("test_#{method}") do
      k, l, alpha, beta, u, v, q, iwork, info, a, b = NumRu::Lapack.send(method, "U", "V", "Q", @a[rc], @b[rc])
        assert_equal 0, info
        assert_narray @gsv_exp[rc], alpha[k...k+l]/beta[k...k+l], 1.0e-4
        assert_narray @u_exp[rc], u, 1.0e-4
        assert_narray @v_exp[rc], v, 1.0e-4
        assert_narray @q_exp[rc], q, 1.0e-4
      end

  end

end
ruby-lapack-1.7.2/tests/eig/gg/test_ggev.rb0000644000175000017500000001222012502223526020402 0ustar  uwabamiuwabami$:.push File.dirname(__FILE__) + "/../.."
require "lapack_test"

class GgevTest < Test::Unit::TestCase
  include LapackTest

  def setup
    @a = Hash.new
    @b = Hash.new
    @vr_exp = Hash.new

    @a[:r] = NMatrix[[3.9,  12.5, -34.5,  -0.5],
                     [4.3,  21.5, -47.5,   7.5],
                     [4.3,  21.5, -43.5,   3.5],
                     [4.4,  26.0, -46.0,   6.0]].to_lm
    @b[:r] = NMatrix[[1.0, 2.0, -3.0, 1.0],
                     [1.0, 3.0, -5.0, 4.0],
                     [1.0, 3.0, -4.0, 3.0],
                     [1.0, 3.0, -4.0, 4.0]].to_lm

    @evr_exp = NArray[2.0, 3.0,  3.0, 4.0]
    @evi_exp = NArray[0.0, 4.0, -4.0, 0.0]
    @vr_exp[:r] = NArray[[ 1.0000e-0,  5.7143e-3,  6.2857e-2,  6.2857e-2],
                         [-4.3979e-1, -8.7958e-2, -1.4241e-1, -1.4241e-1],
                         [-5.6021e-1, -1.1204e-1,  3.1418e-3,  3.1418e-3],
                         [-1.0000e+0, -1.1111e-2,  3.3333e-2, -1.5556e-1]]

    @a[:c] = NMatrix[[-21.10-22.50*I, 53.50-50.50*I, -34.50+127.50*I,   7.50 +0.50*I],
                     [ -0.46 -7.78*I, -3.50-37.50*I, -15.50 +58.50*I, -10.50 -1.50*I],
                     [  4.30 -5.50*I, 39.70-17.10*I, -68.50 +12.50*I,  -7.50 -3.50*I],
                     [  5.50 +4.40*I, 14.40+43.30*I, -32.50 -46.00*I, -19.00-32.50*I]].to_lm
    @b[:c] = NMatrix[[1.00-5.00*I,  1.60+1.20*I, -3.00+0.00*I,  0.00-1.00*I],
                     [0.80-0.60*I,  3.00-5.00*I, -4.00+3.00*I, -2.40-3.20*I],
                     [1.00+0.00*I,  2.40+1.80*I, -4.00-5.00*I,  0.00-3.00*I],
                     [0.00+1.00*I, -1.80+2.40*I,  0.00-4.00*I,  4.00-5.00*I]].to_lm

    @ev_exp = NArray[3.0-9.0*I, 2.0-5.0*I, 3.0-1.0*I, 4.0-5.0*I]
    @vr_exp[:c] = NArray[[-8.2377e-1-1.7623e-1*I, -1.5295e-1+7.0655e-2*I, -7.0655e-2-1.5295e-1*I,  1.5295e-1-7.0655e-2*I],
                         [ 6.3974e-1+3.6026e-1*I,  4.1597e-3-5.4650e-4*I,  4.0212e-2+2.2645e-2*I, -2.2645e-2+4.0212e-2*I],
                         [ 9.7754e-1+2.2465e-2*I,  1.5910e-1-1.1371e-1*I,  1.2090e-1-1.5371e-1*I,  1.5371e-1+1.2090e-1*I],
                         [-9.0623e-1+9.3766e-2*I, -7.4303e-3+6.8750e-3*I,  3.0208e-2-3.1255e-3*I, -1.4586e-2-1.4097e-1*I]]


  end

  %w(s d).each do |x|
    method = "#{x}ggev"
    rc = :r

    define_method("test_#{method}") do
      alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.send(method, "N", "V", @a[rc], @b[rc])
      assert_equal 0, info
      assert_narray @evr_exp, alphar/beta, 1.0e-4
      assert_narray @evi_exp, alphai/beta, 1.0e-4
      vr.shape[1].times do |i|
        vr[true,i] *= -1 if comp_sign(@vr_exp[rc][0,i], vr[0,i])
      end
      assert_narray @vr_exp[rc], vr, 1.0e-4
    end

    define_method("test_#{method}_inquiring_lwork") do
      alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.send(method, "N", "V", @a[rc], @b[rc], :lwork => -1)
      assert_equal 0, info
      lwork = get_int(work[0])
      alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.send(method, "N", "V", @a[rc], @b[rc], :lwork => lwork)
      assert_equal 0, info
      assert_narray @evr_exp, alphar/beta, 1.0e-4
      assert_narray @evi_exp, alphai/beta, 1.0e-4
      vr.shape[1].times do |i|
        vr[true,i] *= -1 if comp_sign(@vr_exp[rc][0,i], vr[0,i])
      end
      assert_narray @vr_exp[rc], vr, 1.0e-4
    end

    define_method("test_#{method}_inquiring_lwork_oldargstyle") do
      alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.send(method, "N", "V", @a[rc], @b[rc], :lwork => -1)
      assert_equal 0, info
      lwork = get_int(work[0])
      alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.send(method, "N", "V", @a[rc], @b[rc], -1)
      assert_equal 0, info
      assert_equal lwork, get_int(work[0])
    end

  end

  %w(c z).each do |x|
    method = "#{x}ggev"
    rc = :c

    define_method("test_#{method}") do
      alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.send(method, "N", "V", @a[rc], @b[rc])
      assert_equal 0, info
      assert_narray @ev_exp, alpha/beta, 1.0e-4
      vr.shape[1].times do |i|
        vr[true,i] *= -1 if comp_sign(@vr_exp[rc][0,i], vr[0,i])
      end
      assert_narray @vr_exp[rc], vr, 2.0e-2
    end

    define_method("test_#{method}_inquiring_lwork") do
      alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.send(method, "N", "V", @a[rc], @b[rc], :lwork => -1)
      assert_equal 0, info
      lwork = get_int(work[0])
      alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.send(method, "N", "V", @a[rc], @b[rc], :lwork => lwork)
      assert_equal 0, info
      assert_narray @ev_exp, alpha/beta, 1.0e-4
      vr.shape[1].times do |i|
        vr[true,i] *= -1 if comp_sign(@vr_exp[rc][0,i], vr[0,i])
      end
      assert_narray @vr_exp[rc], vr, 2.0e-2
    end

    define_method("test_#{method}_inquiring_lwork_oldargstyle") do
      alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.send(method, "N", "V", @a[rc], @b[rc], :lwork => -1)
      assert_equal 0, info
      lwork = get_int(work[0])
      alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.send(method, "N", "V", @a[rc], @b[rc], -1)
      assert_equal 0, info
      assert_equal lwork, get_int(work[0])
    end

  end

end
ruby-lapack-1.7.2/tests/eig/sb/0000755000175000017500000000000012655767602016121 5ustar  uwabamiuwabamiruby-lapack-1.7.2/tests/eig/sb/test_sbev.rb0000644000175000017500000000237312502223526020430 0ustar  uwabamiuwabami$:.push File.dirname(__FILE__) + "/../.."
require "lapack_test"

class SbevTest < Test::Unit::TestCase
  include LapackTest

  def setup
    @kd = 2
    @ab =  NMatrix[[1.0, 2.0, 3.0, 0.0, 0.0],
                      [2.0, 2.0, 3.0, 4.0, 0.0],
                      [3.0, 3.0, 3.0, 4.0, 5.0],
                      [0.0, 4.0, 4.0, 4.0, 5.0],
                      [0.0, 0.0, 5.0, 5.0, 5.0]]
    @w_exp = NArray[-3.2474, -2.6633, 1.7511, 4.1599, 14.9997]
    @z_exp = NArray[[-0.0394, -0.5721,  0.4372,  0.4424, -0.5332],
                        [ 0.6238, -0.2575, -0.5900,  0.4308,  0.1039],
                        [ 0.5635, -0.3896,  0.4008, -0.5581,  0.2421],
                        [-0.5165, -0.5955, -0.1470,  0.0470,  0.5956],
                        [-0.1582, -0.3161, -0.5277, -0.5523, -0.5400] ]
  end

  %w(s d).each do |x|
    method = "#{x}sbev"

    %w(U L).each do |uplo|
      define_method("test_#{method}_uplo_#{uplo}") do
        w, z, info, ab = NumRu::Lapack.send(method, "V", uplo, @kd, @ab.to_lsb(uplo, @kd))
        assert_equal 0, info
        assert_narray @w_exp, w, 1.0e-4
        for n in 0...z.shape[1]
          z[true,n] *= -1 if comp_sign(@z_exp[0,n], z[0,n])
        end
        assert_narray @z_exp, z, 1.0e-4
      end
    end

  end

end
ruby-lapack-1.7.2/tests/eig/ge/0000755000175000017500000000000012655767602016110 5ustar  uwabamiuwabamiruby-lapack-1.7.2/tests/eig/ge/test_gesdd.rb0000644000175000017500000001016312502223526020542 0ustar  uwabamiuwabami$:.push File.dirname(__FILE__) + "/../.."
require "lapack_test"

class GesddTest < Test::Unit::TestCase
  include LapackTest

  def setup
    @a = Hash.new
    @s_exp = Hash.new
    @u_exp = Hash.new
    @a_exp = Hash.new

    @a[:r] = NMatrix[[ 2.27,  0.28, -0.48,  1.07, -2.35,  0.62],
                     [-1.54, -1.67, -3.09,  1.22,  2.93, -7.39],
                     [ 1.15,  0.94,  0.99,  0.79, -1.45,  1.03],
                     [-1.94, -0.78, -0.21,  0.63,  2.30, -2.57]].to_lm
    @s_exp[:r] = NArray[9.9966, 3.6831, 1.3569, 0.5000]
    @u_exp[:r] = NMatrix[[-0.1921,  0.8030,  0.0041, -0.5642],
                         [ 0.8794,  0.3926, -0.0752,  0.2587],
                         [-0.2140,  0.2980,  0.7827,  0.5027],
                         [ 0.3795, -0.3351,  0.6178, -0.6017]].to_lm
    @a_exp[:r] = NMatrix[[-0.2774, -0.2020, -0.2918,  0.0938,  0.4213, -0.7816],
                         [ 0.6003,  0.0301, -0.3348,  0.3699, -0.5266, -0.3353],
                         [-0.1277,  0.2805,  0.6453,  0.6781,  0.0413, -0.1645],
                         [ 0.1323,  0.7034,  0.1906, -0.5399, -0.0575, -0.3957]].to_lm


    @a[:c] = NMatrix[[ 0.96+0.81*I, -0.98-1.98*I,  0.62+0.46*I, -0.37-0.38*I,  0.83-0.51*I,  1.08+0.28*I],
                     [-0.03-0.96*I, -1.20-0.19*I,  1.01-0.02*I,  0.19+0.54*I,  0.20-0.01*I,  0.20+0.12*I],
                     [-0.91-2.06*I, -0.66-0.42*I,  0.63+0.17*I, -0.98+0.36*I, -0.17+0.46*I, -0.07-1.23*I],
                     [-0.05-0.41*I, -0.81-0.56*I, -1.11-0.60*I,  0.22+0.20*I,  1.47-1.59*I,  0.26-0.26*I]].to_lm
    @s_exp[:c] = NArray[3.9994, 3.0003, 1.9944, 0.9995]
    @u_exp[:c] = NMatrix[[ 0.6971+0.0000*I,  0.2403+0.0000*I, -0.5123+0.0000*I, -0.4403+0.0000*I],
                         [ 0.0867-0.3548*I,  0.0725+0.2336*I, -0.3030+0.1735*I,  0.5294-0.6361*I],
                         [-0.0560-0.5400*I, -0.2477+0.5291*I,  0.0678-0.5162*I, -0.3027+0.0346*I],
                         [ 0.1878-0.2253*I,  0.7026-0.2177*I,  0.4418-0.3864*I,  0.1667-0.0258*I]].to_lm
    @a_exp[:c] = NMatrix[[ 0.5634+0.0016*I, -0.1205-0.6108*I,  0.0816+0.1613*I, -0.1441-0.1532*I,  0.2487-0.0926*I,  0.3758+0.0793*I],
                         [-0.2687+0.2749*I, -0.2909-0.1085*I, -0.1660-0.3885*I,  0.1984+0.1737*I,  0.6253-0.3304*I, -0.0307+0.0816*I],
                         [ 0.2451-0.4657*I,  0.4329+0.1758*I, -0.4667-0.3821*I, -0.0034-0.1555*I,  0.2643+0.0194*I,  0.1266-0.1747*I],
                         [ 0.3787-0.2987*I, -0.0182+0.0437*I, -0.0800+0.2276*I,  0.2608+0.5382*I,  0.1002-0.0140*I, -0.4175+0.4058*I]].to_lm
  end

  %w(s d c z).each do |x|
    method = "#{x}gesdd"
    rc = LapackTest.get_rc(x)

    define_method("test_#{method}") do
      s, u, vt, work, info, a = NumRu::Lapack.send(method, "O", @a[rc])
      assert_equal 0, info
      assert_narray @s_exp[rc], s, 1.0e-4
      u.shape[1].times do |i|
        u[true,i] *= -1 if comp_sign(u[0,i], @u_exp[rc][0,i])
      end
      assert_narray @u_exp[rc], u, 1.0e-4
      a.shape[0].times do |i|
        a[i,true] *= -1 if comp_sign(a[i,0], @a_exp[rc][i,0])
      end
      assert_narray @a_exp[rc], a, 1.0e-4
    end

    define_method("test_#{method}_inquireing_lwork") do
      s, u, vt, work, info, = NumRu::Lapack.send(method, "O", @a[rc], :lwork => -1)
      assert_equal 0, info
      lwork = get_int(work[0])
      s, u, vt, work, info, a = NumRu::Lapack.send(method, "O", @a[rc], :lwork => lwork)
      assert_equal 0, info
      assert_equal lwork, get_int(work[0])
      assert_narray @s_exp[rc], s, 1.0e-4
      u.shape[1].times do |i|
        u[true,i] *= -1 if comp_sign(u[0,i], @u_exp[rc][0,i])
      end
      assert_narray @u_exp[rc], u, 1.0e-4
      a.shape[0].times do |i|
        a[i,true] *= -1 if comp_sign(a[i,0], @a_exp[rc][i,0])
      end
      assert_narray @a_exp[rc], a, 1.0e-4
    end

    define_method("test_#{method}_inquireing_lwork_oldargstyle") do
      s, u, vt, work, info, = NumRu::Lapack.send(method, "O", @a[rc], :lwork => -1)
      assert_equal 0, info
      lwork = get_int(work[0])
      s, u, vt, work, info, a = NumRu::Lapack.send(method, "O", @a[rc], -1)
      assert_equal 0, info
      assert_equal lwork, get_int(work[0])
    end

  end

end
ruby-lapack-1.7.2/tests/eig/ge/test_gesvd.rb0000644000175000017500000001053012502223526020562 0ustar  uwabamiuwabami$:.push File.dirname(__FILE__) + "/../.."
require "lapack_test"

class GesvdTest < Test::Unit::TestCase
  include LapackTest

  def setup
    @a = Hash.new
    @s_exp = Hash.new
    @vt_exp = Hash.new
    @a_exp = Hash.new

    @a[:r] = NMatrix[[ 2.27, -1.54,  1.15, -1.94],
                     [ 0.28, -1.67,  0.94, -0.78],
                     [-0.48, -3.09,  0.99, -0.21],
                     [ 1.07,  1.22,  0.79,  0.63],
                     [-2.35,  2.93, -1.45,  2.30],
                     [ 0.62, -7.39,  1.03, -2.57]].to_lm
    @s_exp[:r] = NArray[9.9966, 3.6831, 1.3569, 0.5000]
    @vt_exp[:r] = NMatrix[[-0.1921,  0.8794, -0.2140,  0.3795],
                          [ 0.8030,  0.3926,  0.2980, -0.3351],
                          [ 0.0041, -0.0752,  0.7827,  0.6178],
                          [-0.5642,  0.2587,  0.5027, -0.6017]].to_lm
    @a_exp[:r] = NMatrix[[-0.2774,  0.6003, -0.1277,  0.1323],
                         [-0.2020,  0.0301,  0.2805,  0.7034],
                         [-0.2918, -0.3348,  0.6453,  0.1906],
                         [ 0.0938,  0.3699,  0.6781, -0.5399],
                         [ 0.4213, -0.5266,  0.0413, -0.0575],
                         [-0.7816, -0.3353, -0.1645, -0.3957] ].to_lm

    @a[:c] = NMatrix[[ 0.96+0.81*I, -0.03-0.96*I, -0.91-2.06*I, -0.05-0.41*I],
                     [-0.98-1.98*I, -1.20-0.19*I, -0.66-0.42*I, -0.81-0.56*I],
                     [ 0.62+0.46*I,  1.01-0.02*I,  0.63+0.17*I, -1.11-0.60*I],
                     [-0.37-0.38*I,  0.19+0.54*I, -0.98+0.36*I,  0.22+0.20*I],
                     [ 0.83-0.51*I,  0.20-0.01*I, -0.17+0.46*I,  1.47-1.59*I],
                     [ 1.08+0.28*I,  0.20+0.12*I, -0.07-1.23*I,  0.26-0.26*I]].to_lm
    @s_exp[:c] = NArray[3.9994, 3.0003, 1.9944, 0.9995]
    @vt_exp[:c] = NMatrix[[ 0.6971+0.0*I,  0.0867-0.3548*I, -0.0560-0.5400*I, 0.1878-0.2253*I],
                          [ 0.2403+0.0*I,  0.0725+0.2336*I, -0.2477+0.5291*I, 0.7026-0.2177*I],
                          [-0.5123+0.0*I, -0.3030+0.1735*I,  0.0678-0.5162*I, 0.4418-0.3864*I],
                          [-0.4403+0.0*I,  0.5294-0.6361*I, -0.3027+0.0346*I, 0.1667-0.0258*I]].to_lm
    @a_exp[:c] = NMatrix[[ 0.5634+0.0016*I, -0.2687+0.2749*I, 0.2451-0.4657*I, 0.3787-0.2987*I],
                         [-0.1205-0.6108*I, -0.2909-0.1085*I,  0.4329+0.1758*I, -0.0182+0.0437*I],
                         [ 0.0816+0.1613*I, -0.1660-0.3885*I, -0.4667-0.3821*I, -0.0800+0.2276*I],
                         [-0.1441-0.1532*I,  0.1984+0.1737*I, -0.0034-0.1555*I,  0.2608+0.5382*I],
                         [ 0.2487-0.0926*I,  0.6253-0.3304*I,  0.2643+0.0194*I,  0.1002-0.0140*I],
                         [ 0.3758+0.0793*I, -0.0307+0.0816*I,  0.1266-0.1747*I, -0.4175+0.4058*I]].to_lm

  end

  %w(s d c z).each do |x|
    method = "#{x}gesvd"
    rc = LapackTest.get_rc(x)

    define_method("test_#{method}") do
      s, u, vt, work, info, a = NumRu::Lapack.send(method, "O", "S", @a[rc])
      assert_equal 0, info
      assert_narray @s_exp[rc], s, 1.0e-4

      vt.shape[0].times do |i|
        vt[i,true] *= -1 if comp_sign(vt[i,0], @vt_exp[rc][i,0])
      end
      assert_narray @vt_exp[rc], u, 1.0e-4
      a.shape[1].times do |i|
        a[true,i] *= -1 if comp_sign(a[0,i], @a_exp[rc][0,i])
      end
      assert_narray @a_exp[rc], a, 1.0e-4
    end

    define_method("test_#{method}_inquireing_lwork") do
      s, u, vt, work, info, = NumRu::Lapack.send(method, "O", "S", @a[rc], :lwork => -1)
      assert_equal 0, info
      lwork = get_int(work[0])
      s, u, vt, work, info, a = NumRu::Lapack.send(method, "O", "S", @a[rc], :lwork => lwork)
      assert_equal 0, info
      assert_equal lwork, get_int(work[0])
      assert_narray @s_exp[rc], s, 1.0e-4
      vt.shape[0].times do |i|
        vt[i,true] *= -1 if comp_sign(vt[i,0], @vt_exp[rc][i,0])
      end
      assert_narray @vt_exp[rc], vt, 1.0e-4
      a.shape[1].times do |i|
        a[true,i] *= -1 if comp_sign(a[0,i], @a_exp[rc][0,i])
      end
      assert_narray @a_exp[rc], a, 1.0e-4
    end

    define_method("test_#{method}_inquireing_lwork_oldargstyle") do
      s, u, vt, work, info, a = NumRu::Lapack.send(method, "O", "S", @a[rc], :lwork => -1)
      assert_equal 0, info
      lwork = get_int(work[0])
      s, u, vt, work, info, = NumRu::Lapack.send(method, "O", "S", @a[rc], -1)
      assert_equal 0, info
      assert_equal lwork, get_int(work[0])
    end

  end

end
ruby-lapack-1.7.2/tests/lapack_test.rb0000644000175000017500000000200112502223526017540 0ustar  uwabamiuwabami$:.unshift(File.join(File.dirname(__FILE__), "..", "lib"))
require "test/unit"
require "numru/lapack"

module LapackTest

  I = Complex::I

  def assert_narray(expected, actual, delta=nil, message="")
    unless delta
      case actual.typecode
      when NArray::SFLOAT, NArray::SCOMPLEX
        delta = 5.0e-5
      when NArray::DFLOAT, NArray::DCOMPLEX
        delta = 1.0e-13
      when NArray::INT, NArray::LINT
        delta = 0
      else
        raise "typecode is invalid"
      end
    end
    if message.empty?
      message = <
and
<#{actual.inspect}>
expected to have maximan differnce <#{(expected-actual).abs.max}> within
<#{delta}>.
EOF
    end
    assert (expected - actual).abs.max <= delta, message
  end

  def get_int(x)
    x = x.real if x.respond_to?(:real)
    x.to_i
  end

  def comp_sign(a, b)
    a = a.real if a.respond_to?(:real)
    b = b.real if b.respond_to?(:real)
    a*b < 0
  end

  def get_rc(x)
    /\A[sd]/ =~ x ? :r : :c
  end
  module_function :get_rc

end
ruby-lapack-1.7.2/Rakefile0000644000175000017500000000570312656000225015237 0ustar  uwabamiuwabamirequire "rubygems"
require "rubygems/package_task"
require "rake/clean"
require "rake/testtask"

version = "1.7.2"
target_prefix = "numru"

# get options
destdir = ENV["DESTDIR"] || ""
libdir = ENV["SITELIBDIR"] || RbConfig::CONFIG["sitelibdir"]
archdir = ENV["SITEARCHDIR"] || RbConfig::CONFIG["sitearchdir"]
config_opts = ENV["CONFIG_OPTIONS"]

NAME = "lapack"
LIBS = FileList["lib/#{target_prefix}/*rb"]

case RbConfig::CONFIG["host_os"]
when /darwin/
  extension = "bundle"
else
  extension = "so"
end
DLLIB = "ext/#{NAME}.#{extension}"
so_file = File.join("lib", target_prefix, "#{NAME}.#{extension}")


task :default => so_file

desc "Building extensions"
file so_file => DLLIB do
  mkdir_p File.dirname(so_file)
  rm_f so_file
  cp DLLIB, so_file
end
file DLLIB => "ext/Makefile" do
  system("cd ext; make")
end
file "ext/Makefile" => "ext/rb_lapack.h" do
  unless system("cd ext; ruby extconf.rb #{config_opts}")
    warn <<-EOL

To give options to extconf.rb, set the options to CONFIG_OPTIONS
e.g.
% rake CONFIG_OPTIONS="--with-lapack=/opt/lapack"
    EOL
  end
end
file "ext/rb_lapack.h" => "dev/make_csrc.rb" do
  system("ruby dev/make_csrc.rb")
end

desc "Install files to system"
task :install => [:install_so, :install_rb]

task :install_so => DLLIB do
  dst = File.join(destdir, archdir, target_prefix)
  mkdir_p dst
  install DLLIB, dst, :mode => 0755
end

task :install_rb => LIBS do
  dst = File.join(destdir, libdir, target_prefix)
  mkdir_p dst
  LIBS.each do |lib|
    install lib, dst, :mode => 0644
  end
end

CLEAN.include("ext/*.o")
CLOBBER.include(DLLIB, so_file)
CLOBBER.include("ext/Makefile")


PKG_FILES = FileList["lib/#{target_prefix}/*rb"]
PKG_FILES.include("ext/rb_lapack.h")
PKG_FILES.include("ext/f2c_minimal.h")
PKG_FILES.include("ext/*.c")
PKG_FILES.include("Rakefile")
PKG_FILES.include("COPYING", "GPL", "README.rdoc")
PKG_FILES.include("doc/*.html", "samples/**/*rb")
PKG_FILES.include("dev/*.rb", "dev/defs/*")
TEST_FILES = FileList["tests/**/*.rb"]

Rake::TestTask.new do |t|
  t.libs << "lib"
  t.libs << "tests"
  t.test_files = TEST_FILES
end

spec = Gem::Specification.new do |s|
  s.name = "ruby-lapack"
  s.version = version
  s.summary = "A Ruby wrapper of Lapack"
  s.description = < binary_pkg

file binary_pkg => gem_pkg do
  system "gem compile --fat 1.8:ruby1.8,1.9:ruby1.9 #{gem_pkg}"
end
ruby-lapack-1.7.2/ext/0000755000175000017500000000000012655767602014407 5ustar  uwabamiuwabamiruby-lapack-1.7.2/ext/chpevx.c0000644000175000017500000002325012502221016016021 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chpevx_(char* jobz, char* range, char* uplo, integer* n, complex* ap, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, complex* z, integer* ldz, complex* work, real* rwork, integer* iwork, integer* ifail, integer* info);


static VALUE
rblapack_chpevx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_vl;
  real vl; 
  VALUE rblapack_vu;
  real vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  real abstol; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_ifail;
  integer *ifail; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  complex *ap_out__;
  complex *work;
  real *rwork;
  integer *iwork;

  integer ldap;
  integer n;
  integer ldz;

  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  m, w, z, ifail, info, ap = NumRu::Lapack.chpevx( jobz, range, uplo, ap, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHPEVX computes selected eigenvalues and, optionally, eigenvectors\n*  of a complex Hermitian matrix A in packed storage.\n*  Eigenvalues/vectors can be selected by specifying either a range of\n*  values or a range of indices for the desired eigenvalues.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found;\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found;\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, AP is overwritten by values generated during the\n*          reduction to tridiagonal form.  If UPLO = 'U', the diagonal\n*          and first superdiagonal of the tridiagonal matrix T overwrite\n*          the corresponding elements of A, and if UPLO = 'L', the\n*          diagonal and first subdiagonal of T overwrite the\n*          corresponding elements of A.\n*\n*  VL      (input) REAL\n*  VU      (input) REAL\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) REAL\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less than\n*          or equal to zero, then  EPS*|T|  will be used in its place,\n*          where |T| is the 1-norm of the tridiagonal matrix obtained\n*          by reducing AP to tridiagonal form.\n*\n*          Eigenvalues will be computed most accurately when ABSTOL is\n*          set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n*          If this routine returns with INFO>0, indicating that some\n*          eigenvectors did not converge, try setting ABSTOL to\n*          2*SLAMCH('S').\n*\n*          See \"Computing Small Singular Values of Bidiagonal Matrices\n*          with Guaranteed High Relative Accuracy,\" by Demmel and\n*          Kahan, LAPACK Working Note #3.\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) REAL array, dimension (N)\n*          If INFO = 0, the selected eigenvalues in ascending order.\n*\n*  Z       (output) COMPLEX array, dimension (LDZ, max(1,M))\n*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix A\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          If an eigenvector fails to converge, then that column of Z\n*          contains the latest approximation to the eigenvector, and\n*          the index of the eigenvector is returned in IFAIL.\n*          If JOBZ = 'N', then Z is not referenced.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (7*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (5*N)\n*\n*  IFAIL   (output) INTEGER array, dimension (N)\n*          If JOBZ = 'V', then if INFO = 0, the first M elements of\n*          IFAIL are zero.  If INFO > 0, then IFAIL contains the\n*          indices of the eigenvectors that failed to converge.\n*          If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n*                Their indices are stored in array IFAIL.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, ifail, info, ap = NumRu::Lapack.chpevx( jobz, range, uplo, ap, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_uplo = argv[2];
  rblapack_ap = argv[3];
  rblapack_vl = argv[4];
  rblapack_vu = argv[5];
  rblapack_il = argv[6];
  rblapack_iu = argv[7];
  rblapack_abstol = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  vl = (real)NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  abstol = (real)NUM2DBL(rblapack_abstol);
  range = StringValueCStr(rblapack_range)[0];
  vu = (real)NUM2DBL(rblapack_vu);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  iu = NUM2INT(rblapack_iu);
  m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
  MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (7*n));
  iwork = ALLOC_N(integer, (5*n));

  chpevx_(&jobz, &range, &uplo, &n, ap, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, rwork, iwork, ifail, &info);

  free(work);
  free(rwork);
  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_ap);
}

void
init_lapack_chpevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chpevx", rblapack_chpevx, -1);
}
ruby-lapack-1.7.2/ext/dpttrs.c0000644000175000017500000001204612502221016016045 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dpttrs_(integer* n, integer* nrhs, doublereal* d, doublereal* e, doublereal* b, integer* ldb, integer* info);


static VALUE
rblapack_dpttrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublereal *b_out__;

  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.dpttrs( d, e, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPTTRS( N, NRHS, D, E, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPTTRS solves a tridiagonal system of the form\n*     A * X = B\n*  using the L*D*L' factorization of A computed by DPTTRF.  D is a\n*  diagonal matrix specified in the vector D, L is a unit bidiagonal\n*  matrix whose subdiagonal is specified in the vector E, and X and B\n*  are N by NRHS matrices.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the tridiagonal matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          The n diagonal elements of the diagonal matrix D from the\n*          L*D*L' factorization of A.\n*\n*  E       (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (n-1) subdiagonal elements of the unit bidiagonal factor\n*          L from the L*D*L' factorization of A.  E can also be regarded\n*          as the superdiagonal of the unit bidiagonal factor U from the\n*          factorization A = U'*D*U.\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the right hand side vectors B for the system of\n*          linear equations.\n*          On exit, the solution vectors, X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            J, JB, NB\n*     ..\n*     .. External Functions ..\n      INTEGER            ILAENV\n      EXTERNAL           ILAENV\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DPTTS2, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.dpttrs( d, e, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_d = argv[0];
  rblapack_e = argv[1];
  rblapack_b = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  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);
  ldb = NA_SHAPE0(rblapack_b);
  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 (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (2th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dpttrs_(&n, &nrhs, d, e, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_dpttrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dpttrs", rblapack_dpttrs, -1);
}
ruby-lapack-1.7.2/ext/slangt.c0000644000175000017500000001052112502221024016010 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real slangt_(char* norm, integer* n, real* dl, real* d, real* du);


static VALUE
rblapack_slangt(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_dl;
  real *dl; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_du;
  real *du; 
  VALUE rblapack___out__;
  real __out__; 

  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  __out__ = NumRu::Lapack.slangt( norm, dl, d, du, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL             FUNCTION SLANGT( NORM, N, DL, D, DU )\n\n*  Purpose\n*  =======\n*\n*  SLANGT  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  real tridiagonal matrix A.\n*\n*  Description\n*  ===========\n*\n*  SLANGT returns the value\n*\n*     SLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in SLANGT as described\n*          above.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, SLANGT is\n*          set to zero.\n*\n*  DL      (input) REAL array, dimension (N-1)\n*          The (n-1) sub-diagonal elements of A.\n*\n*  D       (input) REAL array, dimension (N)\n*          The diagonal elements of A.\n*\n*  DU      (input) REAL array, dimension (N-1)\n*          The (n-1) super-diagonal elements of A.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.slangt( norm, dl, d, du, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_norm = argv[0];
  rblapack_dl = argv[1];
  rblapack_d = argv[2];
  rblapack_du = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_SFLOAT)
    rblapack_dl = na_change_type(rblapack_dl, NA_SFLOAT);
  dl = NA_PTR_TYPE(rblapack_dl, real*);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (4th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_SFLOAT)
    rblapack_du = na_change_type(rblapack_du, NA_SFLOAT);
  du = NA_PTR_TYPE(rblapack_du, real*);

  __out__ = slangt_(&norm, &n, dl, d, du);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_slangt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slangt", rblapack_slangt, -1);
}
ruby-lapack-1.7.2/ext/zlacrt.c0000644000175000017500000001135312502221012016020 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlacrt_(integer* n, doublecomplex* cx, integer* incx, doublecomplex* cy, integer* incy, doublecomplex* c, doublecomplex* s);


static VALUE
rblapack_zlacrt(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_cx;
  doublecomplex *cx; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_cy;
  doublecomplex *cy; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_c;
  doublecomplex c; 
  VALUE rblapack_s;
  doublecomplex s; 
  VALUE rblapack_cx_out__;
  doublecomplex *cx_out__;
  VALUE rblapack_cy_out__;
  doublecomplex *cy_out__;

  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  cx, cy = NumRu::Lapack.zlacrt( cx, incx, cy, incy, c, s, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLACRT( N, CX, INCX, CY, INCY, C, S )\n\n*  Purpose\n*  =======\n*\n*  ZLACRT performs the operation\n*\n*     (  c  s )( x )  ==> ( x )\n*     ( -s  c )( y )      ( y )\n*\n*  where c and s are complex and the vectors x and y are complex.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of elements in the vectors CX and CY.\n*\n*  CX      (input/output) COMPLEX*16 array, dimension (N)\n*          On input, the vector x.\n*          On output, CX is overwritten with c*x + s*y.\n*\n*  INCX    (input) INTEGER\n*          The increment between successive values of CX.  INCX <> 0.\n*\n*  CY      (input/output) COMPLEX*16 array, dimension (N)\n*          On input, the vector y.\n*          On output, CY is overwritten with -s*x + c*y.\n*\n*  INCY    (input) INTEGER\n*          The increment between successive values of CY.  INCY <> 0.\n*\n*  C       (input) COMPLEX*16\n*  S       (input) COMPLEX*16\n*          C and S define the matrix\n*             [  C   S  ].\n*             [ -S   C  ]\n*\n\n* =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, IX, IY\n      COMPLEX*16         CTEMP\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  cx, cy = NumRu::Lapack.zlacrt( cx, incx, cy, incy, c, s, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_cx = argv[0];
  rblapack_incx = argv[1];
  rblapack_cy = argv[2];
  rblapack_incy = argv[3];
  rblapack_c = argv[4];
  rblapack_s = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_cx))
    rb_raise(rb_eArgError, "cx (1th argument) must be NArray");
  if (NA_RANK(rblapack_cx) != 1)
    rb_raise(rb_eArgError, "rank of cx (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_cx);
  if (NA_TYPE(rblapack_cx) != NA_DCOMPLEX)
    rblapack_cx = na_change_type(rblapack_cx, NA_DCOMPLEX);
  cx = NA_PTR_TYPE(rblapack_cx, doublecomplex*);
  if (!NA_IsNArray(rblapack_cy))
    rb_raise(rb_eArgError, "cy (3th argument) must be NArray");
  if (NA_RANK(rblapack_cy) != 1)
    rb_raise(rb_eArgError, "rank of cy (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_cy) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of cy must be the same as shape 0 of cx");
  if (NA_TYPE(rblapack_cy) != NA_DCOMPLEX)
    rblapack_cy = na_change_type(rblapack_cy, NA_DCOMPLEX);
  cy = NA_PTR_TYPE(rblapack_cy, doublecomplex*);
  c.r = NUM2DBL(rb_funcall(rblapack_c, rb_intern("real"), 0));
  c.i = NUM2DBL(rb_funcall(rblapack_c, rb_intern("imag"), 0));
  incx = NUM2INT(rblapack_incx);
  s.r = NUM2DBL(rb_funcall(rblapack_s, rb_intern("real"), 0));
  s.i = NUM2DBL(rb_funcall(rblapack_s, rb_intern("imag"), 0));
  incy = NUM2INT(rblapack_incy);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_cx_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  cx_out__ = NA_PTR_TYPE(rblapack_cx_out__, doublecomplex*);
  MEMCPY(cx_out__, cx, doublecomplex, NA_TOTAL(rblapack_cx));
  rblapack_cx = rblapack_cx_out__;
  cx = cx_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_cy_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  cy_out__ = NA_PTR_TYPE(rblapack_cy_out__, doublecomplex*);
  MEMCPY(cy_out__, cy, doublecomplex, NA_TOTAL(rblapack_cy));
  rblapack_cy = rblapack_cy_out__;
  cy = cy_out__;

  zlacrt_(&n, cx, &incx, cy, &incy, &c, &s);

  return rb_ary_new3(2, rblapack_cx, rblapack_cy);
}

void
init_lapack_zlacrt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlacrt", rblapack_zlacrt, -1);
}
ruby-lapack-1.7.2/ext/zhbgv.c0000644000175000017500000002105312502221025015643 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhbgv_(char* jobz, char* uplo, integer* n, integer* ka, integer* kb, doublecomplex* ab, integer* ldab, doublecomplex* bb, integer* ldbb, doublereal* w, doublecomplex* z, integer* ldz, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zhbgv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ka;
  integer ka; 
  VALUE rblapack_kb;
  integer kb; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_bb;
  doublecomplex *bb; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublecomplex *ab_out__;
  VALUE rblapack_bb_out__;
  doublecomplex *bb_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer ldab;
  integer n;
  integer ldbb;
  integer ldz;

  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  w, z, info, ab, bb = NumRu::Lapack.zhbgv( jobz, uplo, ka, kb, ab, bb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHBGV computes all the eigenvalues, and optionally, the eigenvectors\n*  of a complex generalized Hermitian-definite banded eigenproblem, of\n*  the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian\n*  and banded, and B is also positive definite.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  KA      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n*  KB      (input) INTEGER\n*          The number of superdiagonals of the matrix B if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n*  AB      (input/output) COMPLEX*16 array, dimension (LDAB, N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix A, stored in the first ka+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).\n*\n*          On exit, the contents of AB are destroyed.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KA+1.\n*\n*  BB      (input/output) COMPLEX*16 array, dimension (LDBB, N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix B, stored in the first kb+1 rows of the array.  The\n*          j-th column of B is stored in the j-th column of the array BB\n*          as follows:\n*          if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n*          if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb).\n*\n*          On exit, the factor S from the split Cholesky factorization\n*          B = S**H*S, as returned by ZPBSTF.\n*\n*  LDBB    (input) INTEGER\n*          The leading dimension of the array BB.  LDBB >= KB+1.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) COMPLEX*16 array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n*          eigenvectors, with the i-th column of Z holding the\n*          eigenvector associated with W(i). The eigenvectors are\n*          normalized so that Z**H*B*Z = I.\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= N.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (3*N)\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, and i is:\n*             <= N:  the algorithm failed to converge:\n*                    i off-diagonal elements of an intermediate\n*                    tridiagonal form did not converge to zero;\n*             > N:   if INFO = N + i, for 1 <= i <= N, then ZPBSTF\n*                    returned INFO = i: B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            UPPER, WANTZ\n      CHARACTER          VECT\n      INTEGER            IINFO, INDE, INDWRK\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DSTERF, XERBLA, ZHBGST, ZHBTRD, ZPBSTF, ZSTEQR\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, info, ab, bb = NumRu::Lapack.zhbgv( jobz, uplo, ka, kb, ab, bb, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_ka = argv[2];
  rblapack_kb = argv[3];
  rblapack_ab = argv[4];
  rblapack_bb = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  ka = NUM2INT(rblapack_ka);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_bb))
    rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
  if (NA_RANK(rblapack_bb) != 2)
    rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
  ldbb = NA_SHAPE0(rblapack_bb);
  if (NA_SHAPE1(rblapack_bb) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of bb must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_bb) != NA_DCOMPLEX)
    rblapack_bb = na_change_type(rblapack_bb, NA_DCOMPLEX);
  bb = NA_PTR_TYPE(rblapack_bb, doublecomplex*);
  kb = NUM2INT(rblapack_kb);
  ldz = lsame_(&jobz,"V") ? n : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
  MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldbb;
    shape[1] = n;
    rblapack_bb_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  bb_out__ = NA_PTR_TYPE(rblapack_bb_out__, doublecomplex*);
  MEMCPY(bb_out__, bb, doublecomplex, NA_TOTAL(rblapack_bb));
  rblapack_bb = rblapack_bb_out__;
  bb = bb_out__;
  work = ALLOC_N(doublecomplex, (n));
  rwork = ALLOC_N(doublereal, (3*n));

  zhbgv_(&jobz, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, w, z, &ldz, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_w, rblapack_z, rblapack_info, rblapack_ab, rblapack_bb);
}

void
init_lapack_zhbgv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhbgv", rblapack_zhbgv, -1);
}
ruby-lapack-1.7.2/ext/ctbcon.c0000644000175000017500000001141312502221025015772 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctbcon_(char* norm, char* uplo, char* diag, integer* n, integer* kd, complex* ab, integer* ldab, real* rcond, complex* work, real* rwork, integer* info);


static VALUE
rblapack_ctbcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_info;
  integer info; 
  complex *work;
  real *rwork;

  integer ldab;
  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  rcond, info = NumRu::Lapack.ctbcon( norm, uplo, diag, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTBCON estimates the reciprocal of the condition number of a\n*  triangular band matrix A, in either the 1-norm or the infinity-norm.\n*\n*  The norm of A is computed and an estimate is obtained for\n*  norm(inv(A)), then the reciprocal of the condition number is\n*  computed as\n*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies whether the 1-norm condition number or the\n*          infinity-norm condition number is required:\n*          = '1' or 'O':  1-norm;\n*          = 'I':         Infinity-norm.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals or subdiagonals of the\n*          triangular band matrix A.  KD >= 0.\n*\n*  AB      (input) COMPLEX array, dimension (LDAB,N)\n*          The upper or lower triangular band matrix A, stored in the\n*          first kd+1 rows of the array. The j-th column of A is stored\n*          in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*          If DIAG = 'U', the diagonal elements of A are not referenced\n*          and are assumed to be 1.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  RCOND   (output) REAL\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(norm(A) * norm(inv(A))).\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.ctbcon( norm, uplo, diag, kd, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_diag = argv[2];
  rblapack_kd = argv[3];
  rblapack_ab = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  kd = NUM2INT(rblapack_kd);
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (n));

  ctbcon_(&norm, &uplo, &diag, &n, &kd, ab, &ldab, &rcond, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_ctbcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctbcon", rblapack_ctbcon, -1);
}
ruby-lapack-1.7.2/ext/ssterf.c0000644000175000017500000000755512502221014016042 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssterf_(integer* n, real* d, real* e, integer* info);


static VALUE
rblapack_ssterf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_e_out__;
  real *e_out__;

  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  info, d, e = NumRu::Lapack.ssterf( d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSTERF( N, D, E, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSTERF computes all eigenvalues of a symmetric tridiagonal matrix\n*  using the Pal-Walker-Kahan variant of the QL or QR algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  D       (input/output) REAL array, dimension (N)\n*          On entry, the n diagonal elements of the tridiagonal matrix.\n*          On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n*  E       (input/output) REAL array, dimension (N-1)\n*          On entry, the (n-1) subdiagonal elements of the tridiagonal\n*          matrix.\n*          On exit, E has been destroyed.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  the algorithm failed to find all of the eigenvalues in\n*                a total of 30*N iterations; if INFO = i, then i\n*                elements of E have not converged to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, e = NumRu::Lapack.ssterf( d, e, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_d = argv[0];
  rblapack_e = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (2th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
  MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;

  ssterf_(&n, d, e, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_d, rblapack_e);
}

void
init_lapack_ssterf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssterf", rblapack_ssterf, -1);
}
ruby-lapack-1.7.2/ext/cgtrfs.c0000644000175000017500000002663512502221017016027 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgtrfs_(char* trans, integer* n, integer* nrhs, complex* dl, complex* d, complex* du, complex* dlf, complex* df, complex* duf, complex* du2, integer* ipiv, complex* b, integer* ldb, complex* x, integer* ldx, real* ferr, real* berr, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cgtrfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_dl;
  complex *dl; 
  VALUE rblapack_d;
  complex *d; 
  VALUE rblapack_du;
  complex *du; 
  VALUE rblapack_dlf;
  complex *dlf; 
  VALUE rblapack_df;
  complex *df; 
  VALUE rblapack_duf;
  complex *duf; 
  VALUE rblapack_du2;
  complex *du2; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  complex *x_out__;
  complex *work;
  real *rwork;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.cgtrfs( trans, dl, d, du, dlf, df, duf, du2, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGTRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is tridiagonal, and provides\n*  error bounds and backward error estimates for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  DL      (input) COMPLEX array, dimension (N-1)\n*          The (n-1) subdiagonal elements of A.\n*\n*  D       (input) COMPLEX array, dimension (N)\n*          The diagonal elements of A.\n*\n*  DU      (input) COMPLEX array, dimension (N-1)\n*          The (n-1) superdiagonal elements of A.\n*\n*  DLF     (input) COMPLEX array, dimension (N-1)\n*          The (n-1) multipliers that define the matrix L from the\n*          LU factorization of A as computed by CGTTRF.\n*\n*  DF      (input) COMPLEX array, dimension (N)\n*          The n diagonal elements of the upper triangular matrix U from\n*          the LU factorization of A.\n*\n*  DUF     (input) COMPLEX array, dimension (N-1)\n*          The (n-1) elements of the first superdiagonal of U.\n*\n*  DU2     (input) COMPLEX array, dimension (N-2)\n*          The (n-2) elements of the second superdiagonal of U.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices; for 1 <= i <= n, row i of the matrix was\n*          interchanged with row IPIV(i).  IPIV(i) will always be either\n*          i or i+1; IPIV(i) = i indicates a row interchange was not\n*          required.\n*\n*  B       (input) COMPLEX array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) COMPLEX array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by CGTTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.cgtrfs( trans, dl, d, du, dlf, df, duf, du2, ipiv, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 11 && argc != 11)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
  rblapack_trans = argv[0];
  rblapack_dl = argv[1];
  rblapack_d = argv[2];
  rblapack_du = argv[3];
  rblapack_dlf = argv[4];
  rblapack_df = argv[5];
  rblapack_duf = argv[6];
  rblapack_du2 = argv[7];
  rblapack_ipiv = argv[8];
  rblapack_b = argv[9];
  rblapack_x = argv[10];
  if (argc == 11) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SCOMPLEX)
    rblapack_d = na_change_type(rblapack_d, NA_SCOMPLEX);
  d = NA_PTR_TYPE(rblapack_d, complex*);
  if (!NA_IsNArray(rblapack_df))
    rb_raise(rb_eArgError, "df (6th argument) must be NArray");
  if (NA_RANK(rblapack_df) != 1)
    rb_raise(rb_eArgError, "rank of df (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_df) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of df must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_df) != NA_SCOMPLEX)
    rblapack_df = na_change_type(rblapack_df, NA_SCOMPLEX);
  df = NA_PTR_TYPE(rblapack_df, complex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (9th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (11th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (11th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_SCOMPLEX)
    rblapack_dl = na_change_type(rblapack_dl, NA_SCOMPLEX);
  dl = NA_PTR_TYPE(rblapack_dl, complex*);
  if (!NA_IsNArray(rblapack_dlf))
    rb_raise(rb_eArgError, "dlf (5th argument) must be NArray");
  if (NA_RANK(rblapack_dlf) != 1)
    rb_raise(rb_eArgError, "rank of dlf (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dlf) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dlf must be %d", n-1);
  if (NA_TYPE(rblapack_dlf) != NA_SCOMPLEX)
    rblapack_dlf = na_change_type(rblapack_dlf, NA_SCOMPLEX);
  dlf = NA_PTR_TYPE(rblapack_dlf, complex*);
  if (!NA_IsNArray(rblapack_du2))
    rb_raise(rb_eArgError, "du2 (8th argument) must be NArray");
  if (NA_RANK(rblapack_du2) != 1)
    rb_raise(rb_eArgError, "rank of du2 (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du2) != (n-2))
    rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
  if (NA_TYPE(rblapack_du2) != NA_SCOMPLEX)
    rblapack_du2 = na_change_type(rblapack_du2, NA_SCOMPLEX);
  du2 = NA_PTR_TYPE(rblapack_du2, complex*);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (4th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_SCOMPLEX)
    rblapack_du = na_change_type(rblapack_du, NA_SCOMPLEX);
  du = NA_PTR_TYPE(rblapack_du, complex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (10th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (10th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (!NA_IsNArray(rblapack_duf))
    rb_raise(rb_eArgError, "duf (7th argument) must be NArray");
  if (NA_RANK(rblapack_duf) != 1)
    rb_raise(rb_eArgError, "rank of duf (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_duf) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of duf must be %d", n-1);
  if (NA_TYPE(rblapack_duf) != NA_SCOMPLEX)
    rblapack_duf = na_change_type(rblapack_duf, NA_SCOMPLEX);
  duf = NA_PTR_TYPE(rblapack_duf, complex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (n));

  cgtrfs_(&trans, &n, &nrhs, dl, d, du, dlf, df, duf, du2, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_cgtrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgtrfs", rblapack_cgtrfs, -1);
}
ruby-lapack-1.7.2/ext/sgehrd.c0000644000175000017500000001536012502221020015776 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgehrd_(integer* n, integer* ilo, integer* ihi, real* a, integer* lda, real* tau, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sgehrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *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.sgehrd( ilo, ihi, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGEHRD reduces a real general matrix A to upper Hessenberg form H by\n*  an orthogonal similarity transformation:  Q' * A * Q = H .\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          It is assumed that A is already upper triangular in rows\n*          and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n*          set by a previous call to SGEBAL; otherwise they should be\n*          set to 1 and N respectively. See Further Details.\n*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the N-by-N general matrix to be reduced.\n*          On exit, the upper triangle and the first subdiagonal of A\n*          are overwritten with the upper Hessenberg matrix H, and the\n*          elements below the first subdiagonal, with the array TAU,\n*          represent the orthogonal matrix Q as a product of elementary\n*          reflectors. See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  TAU     (output) REAL array, dimension (N-1)\n*          The scalar factors of the elementary reflectors (see Further\n*          Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to\n*          zero.\n*\n*  WORK    (workspace/output) REAL array, dimension (LWORK)\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of the array WORK.  LWORK >= max(1,N).\n*          For optimum performance LWORK >= N*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 (ihi-ilo) elementary\n*  reflectors\n*\n*     Q = H(ilo) H(ilo+1) . . . H(ihi-1).\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) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n*  exit in A(i+2:ihi,i), and tau in TAU(i).\n*\n*  The contents of A are illustrated by the following example, with\n*  n = 7, ilo = 2 and ihi = 6:\n*\n*  on entry,                        on exit,\n*\n*  ( a   a   a   a   a   a   a )    (  a   a   h   h   h   h   a )\n*  (     a   a   a   a   a   a )    (      a   h   h   h   h   a )\n*  (     a   a   a   a   a   a )    (      h   h   h   h   h   h )\n*  (     a   a   a   a   a   a )    (      v2  h   h   h   h   h )\n*  (     a   a   a   a   a   a )    (      v2  v3  h   h   h   h )\n*  (     a   a   a   a   a   a )    (      v2  v3  v4  h   h   h )\n*  (                         a )    (                          a )\n*\n*  where a denotes an element of the original matrix A, h denotes a\n*  modified element of the upper Hessenberg matrix H, and vi denotes an\n*  element of the vector defining H(i).\n*\n*  This file is a slight modification of LAPACK-3.0's DGEHRD\n*  subroutine incorporating improvements proposed by Quintana-Orti and\n*  Van de Geijn (2006). (See DLAHR2.)\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, work, info, a = NumRu::Lapack.sgehrd( ilo, ihi, a, [: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_ilo = argv[0];
  rblapack_ihi = argv[1];
  rblapack_a = 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;
  }

  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  ihi = NUM2INT(rblapack_ihi);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  sgehrd_(&n, &ilo, &ihi, 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_sgehrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgehrd", rblapack_sgehrd, -1);
}
ruby-lapack-1.7.2/ext/zla_gbrfsx_extended.c0000644000175000017500000006055312502221013020551 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zla_gbrfsx_extended_(integer* prec_type, integer* trans_type, integer* n, integer* kl, integer* ku, integer* nrhs, doublecomplex* ab, integer* ldab, doublecomplex* afb, integer* ldafb, integer* ipiv, logical* colequ, doublereal* c, doublecomplex* b, integer* ldb, doublecomplex* y, integer* ldy, doublereal* berr_out, integer* n_norms, doublereal* err_bnds_norm, doublereal* err_bnds_comp, doublecomplex* res, doublereal* ayb, doublecomplex* dy, doublecomplex* y_tail, doublereal* rcond, integer* ithresh, doublereal* rthresh, doublereal* dz_ub, logical* ignore_cwise, integer* info);


static VALUE
rblapack_zla_gbrfsx_extended(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_prec_type;
  integer prec_type; 
  VALUE rblapack_trans_type;
  integer trans_type; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_afb;
  doublecomplex *afb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_colequ;
  logical colequ; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_y;
  doublecomplex *y; 
  VALUE rblapack_n_norms;
  integer n_norms; 
  VALUE rblapack_err_bnds_norm;
  doublereal *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  doublereal *err_bnds_comp; 
  VALUE rblapack_res;
  doublecomplex *res; 
  VALUE rblapack_ayb;
  doublereal *ayb; 
  VALUE rblapack_dy;
  doublecomplex *dy; 
  VALUE rblapack_y_tail;
  doublecomplex *y_tail; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_ithresh;
  integer ithresh; 
  VALUE rblapack_rthresh;
  doublereal rthresh; 
  VALUE rblapack_dz_ub;
  doublereal dz_ub; 
  VALUE rblapack_ignore_cwise;
  logical ignore_cwise; 
  VALUE rblapack_berr_out;
  doublereal *berr_out; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_y_out__;
  doublecomplex *y_out__;
  VALUE rblapack_err_bnds_norm_out__;
  doublereal *err_bnds_norm_out__;
  VALUE rblapack_err_bnds_comp_out__;
  doublereal *err_bnds_comp_out__;

  integer ldab;
  integer n;
  integer ldafb;
  integer ldb;
  integer nrhs;
  integer ldy;
  integer n_err_bnds;

  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  berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.zla_gbrfsx_extended( prec_type, trans_type, kl, ku, ab, afb, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZLA_GBRFSX_EXTENDED improves the computed solution to a system of\n*  linear equations by performing extra-precise iterative refinement\n*  and provides error bounds and backward error estimates for the solution.\n*  This subroutine is called by ZGBRFSX to perform iterative refinement.\n*  In addition to normwise error bound, the code provides maximum\n*  componentwise error bound if possible. See comments for ERR_BNDS_NORM\n*  and ERR_BNDS_COMP for details of the error bounds. Note that this\n*  subroutine is only resonsible for setting the second fields of\n*  ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n*  Arguments\n*  =========\n*\n*     PREC_TYPE      (input) INTEGER\n*     Specifies the intermediate precision to be used in refinement.\n*     The value is defined by ILAPREC(P) where P is a CHARACTER and\n*     P    = 'S':  Single\n*          = 'D':  Double\n*          = 'I':  Indigenous\n*          = 'X', 'E':  Extra\n*\n*     TRANS_TYPE     (input) INTEGER\n*     Specifies the transposition operation on A.\n*     The value is defined by ILATRANS(T) where T is a CHARACTER and\n*     T    = 'N':  No transpose\n*          = 'T':  Transpose\n*          = 'C':  Conjugate transpose\n*\n*     N              (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     KL             (input) INTEGER\n*     The number of subdiagonals within the band of A.  KL >= 0.\n*\n*     KU             (input) INTEGER\n*     The number of superdiagonals within the band of A.  KU >= 0\n*\n*     NRHS           (input) INTEGER\n*     The number of right-hand-sides, i.e., the number of columns of the\n*     matrix B.\n*\n*     AB             (input) COMPLEX*16 array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDAB           (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AFB            (input) COMPLEX*16 array, dimension (LDAF,N)\n*     The factors L and U from the factorization\n*     A = P*L*U as computed by ZGBTRF.\n*\n*     LDAFB          (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV           (input) INTEGER array, dimension (N)\n*     The pivot indices from the factorization A = P*L*U\n*     as computed by ZGBTRF; row i of the matrix was interchanged\n*     with row IPIV(i).\n*\n*     COLEQU         (input) LOGICAL\n*     If .TRUE. then column equilibration was done to A before calling\n*     this routine. This is needed to compute the solution and error\n*     bounds correctly.\n*\n*     C              (input) DOUBLE PRECISION array, dimension (N)\n*     The column scale factors for A. If COLEQU = .FALSE., C\n*     is not accessed. If C is input, each element of C should be a power\n*     of the radix to ensure a reliable solution and error estimates.\n*     Scaling by powers of the radix does not cause rounding errors unless\n*     the result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B              (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*     The right-hand-side matrix B.\n*\n*     LDB            (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     Y              (input/output) COMPLEX*16 array, dimension (LDY,NRHS)\n*     On entry, the solution matrix X, as computed by ZGBTRS.\n*     On exit, the improved solution matrix Y.\n*\n*     LDY            (input) INTEGER\n*     The leading dimension of the array Y.  LDY >= max(1,N).\n*\n*     BERR_OUT       (output) DOUBLE PRECISION array, dimension (NRHS)\n*     On exit, BERR_OUT(j) contains the componentwise relative backward\n*     error for right-hand-side j from the formula\n*         max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n*     where abs(Z) is the componentwise absolute value of the matrix\n*     or vector Z. This is computed by ZLA_LIN_BERR.\n*\n*     N_NORMS        (input) INTEGER\n*     Determines which error bounds to return (see ERR_BNDS_NORM\n*     and ERR_BNDS_COMP).\n*     If N_NORMS >= 1 return normwise error bounds.\n*     If N_NORMS >= 2 return componentwise error bounds.\n*\n*     ERR_BNDS_NORM  (input/output) DOUBLE PRECISION array, dimension\n*                    (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (input/output) DOUBLE PRECISION array, dimension\n*                    (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     RES            (input) COMPLEX*16 array, dimension (N)\n*     Workspace to hold the intermediate residual.\n*\n*     AYB            (input) DOUBLE PRECISION array, dimension (N)\n*     Workspace.\n*\n*     DY             (input) COMPLEX*16 array, dimension (N)\n*     Workspace to hold the intermediate solution.\n*\n*     Y_TAIL         (input) COMPLEX*16 array, dimension (N)\n*     Workspace to hold the trailing bits of the intermediate solution.\n*\n*     RCOND          (input) DOUBLE PRECISION\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     ITHRESH        (input) INTEGER\n*     The maximum number of residual computations allowed for\n*     refinement. The default is 10. For 'aggressive' set to 100 to\n*     permit convergence using approximate factorizations or\n*     factorizations other than LU. If the factorization uses a\n*     technique other than Gaussian elimination, the guarantees in\n*     ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n*     RTHRESH        (input) DOUBLE PRECISION\n*     Determines when to stop refinement if the error estimate stops\n*     decreasing. Refinement will stop when the next solution no longer\n*     satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n*     the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n*     default value is 0.5. For 'aggressive' set to 0.9 to permit\n*     convergence on extremely ill-conditioned matrices. See LAWN 165\n*     for more details.\n*\n*     DZ_UB          (input) DOUBLE PRECISION\n*     Determines when to start considering componentwise convergence.\n*     Componentwise convergence is only considered after each component\n*     of the solution Y is stable, which we definte as the relative\n*     change in each component being less than DZ_UB. The default value\n*     is 0.25, requiring the first bit to be stable. See LAWN 165 for\n*     more details.\n*\n*     IGNORE_CWISE   (input) LOGICAL\n*     If .TRUE. then ignore componentwise convergence. Default value\n*     is .FALSE..\n*\n*     INFO           (output) INTEGER\n*       = 0:  Successful exit.\n*       < 0:  if INFO = -i, the ith argument to ZGBTRS had an illegal\n*             value\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      CHARACTER          TRANS\n      INTEGER            CNT, I, J, M, X_STATE, Z_STATE, Y_PREC_STATE\n      DOUBLE PRECISION   YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n     $                   DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n     $                   DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n     $                   EPS, HUGEVAL, INCR_THRESH\n      LOGICAL            INCR_PREC\n      COMPLEX*16         ZDUM\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.zla_gbrfsx_extended( prec_type, trans_type, kl, ku, ab, afb, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 23 && argc != 23)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 23)", argc);
  rblapack_prec_type = argv[0];
  rblapack_trans_type = argv[1];
  rblapack_kl = argv[2];
  rblapack_ku = argv[3];
  rblapack_ab = argv[4];
  rblapack_afb = argv[5];
  rblapack_ipiv = argv[6];
  rblapack_colequ = argv[7];
  rblapack_c = argv[8];
  rblapack_b = argv[9];
  rblapack_y = argv[10];
  rblapack_n_norms = argv[11];
  rblapack_err_bnds_norm = argv[12];
  rblapack_err_bnds_comp = argv[13];
  rblapack_res = argv[14];
  rblapack_ayb = argv[15];
  rblapack_dy = argv[16];
  rblapack_y_tail = argv[17];
  rblapack_rcond = argv[18];
  rblapack_ithresh = argv[19];
  rblapack_rthresh = argv[20];
  rblapack_dz_ub = argv[21];
  rblapack_ignore_cwise = argv[22];
  if (argc == 23) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  prec_type = NUM2INT(rblapack_prec_type);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  ldab = n;
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  colequ = (rblapack_colequ == Qtrue);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (10th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (10th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  n_norms = NUM2INT(rblapack_n_norms);
  if (!NA_IsNArray(rblapack_err_bnds_comp))
    rb_raise(rb_eArgError, "err_bnds_comp (14th argument) must be NArray");
  if (NA_RANK(rblapack_err_bnds_comp) != 2)
    rb_raise(rb_eArgError, "rank of err_bnds_comp (14th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_err_bnds_comp) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of b");
  n_err_bnds = NA_SHAPE1(rblapack_err_bnds_comp);
  if (NA_TYPE(rblapack_err_bnds_comp) != NA_DFLOAT)
    rblapack_err_bnds_comp = na_change_type(rblapack_err_bnds_comp, NA_DFLOAT);
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
  rcond = NUM2DBL(rblapack_rcond);
  rthresh = NUM2DBL(rblapack_rthresh);
  ignore_cwise = (rblapack_ignore_cwise == Qtrue);
  trans_type = NUM2INT(rblapack_trans_type);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (11th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 2)
    rb_raise(rb_eArgError, "rank of y (11th argument) must be %d", 2);
  ldy = NA_SHAPE0(rblapack_y);
  if (NA_SHAPE1(rblapack_y) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_y) != NA_DCOMPLEX)
    rblapack_y = na_change_type(rblapack_y, NA_DCOMPLEX);
  y = NA_PTR_TYPE(rblapack_y, doublecomplex*);
  ithresh = NUM2INT(rblapack_ithresh);
  n = ldab;
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be ldab");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_err_bnds_norm))
    rb_raise(rb_eArgError, "err_bnds_norm (13th argument) must be NArray");
  if (NA_RANK(rblapack_err_bnds_norm) != 2)
    rb_raise(rb_eArgError, "rank of err_bnds_norm (13th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_err_bnds_norm) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of b");
  if (NA_SHAPE1(rblapack_err_bnds_norm) != n_err_bnds)
    rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_norm must be the same as shape 1 of err_bnds_comp");
  if (NA_TYPE(rblapack_err_bnds_norm) != NA_DFLOAT)
    rblapack_err_bnds_norm = na_change_type(rblapack_err_bnds_norm, NA_DFLOAT);
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
  if (!NA_IsNArray(rblapack_ayb))
    rb_raise(rb_eArgError, "ayb (16th argument) must be NArray");
  if (NA_RANK(rblapack_ayb) != 1)
    rb_raise(rb_eArgError, "rank of ayb (16th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ayb) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ayb must be ldab");
  if (NA_TYPE(rblapack_ayb) != NA_DFLOAT)
    rblapack_ayb = na_change_type(rblapack_ayb, NA_DFLOAT);
  ayb = NA_PTR_TYPE(rblapack_ayb, doublereal*);
  if (!NA_IsNArray(rblapack_y_tail))
    rb_raise(rb_eArgError, "y_tail (18th argument) must be NArray");
  if (NA_RANK(rblapack_y_tail) != 1)
    rb_raise(rb_eArgError, "rank of y_tail (18th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y_tail) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be ldab");
  if (NA_TYPE(rblapack_y_tail) != NA_DCOMPLEX)
    rblapack_y_tail = na_change_type(rblapack_y_tail, NA_DCOMPLEX);
  y_tail = NA_PTR_TYPE(rblapack_y_tail, doublecomplex*);
  ldafb = MAX(1,n);
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_afb) != ldafb)
    rb_raise(rb_eRuntimeError, "shape 0 of afb must be MAX(1,n)");
  if (NA_SHAPE1(rblapack_afb) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of afb must be ldab");
  if (NA_TYPE(rblapack_afb) != NA_DCOMPLEX)
    rblapack_afb = na_change_type(rblapack_afb, NA_DCOMPLEX);
  afb = NA_PTR_TYPE(rblapack_afb, doublecomplex*);
  if (!NA_IsNArray(rblapack_res))
    rb_raise(rb_eArgError, "res (15th argument) must be NArray");
  if (NA_RANK(rblapack_res) != 1)
    rb_raise(rb_eArgError, "rank of res (15th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_res) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of res must be ldab");
  if (NA_TYPE(rblapack_res) != NA_DCOMPLEX)
    rblapack_res = na_change_type(rblapack_res, NA_DCOMPLEX);
  res = NA_PTR_TYPE(rblapack_res, doublecomplex*);
  dz_ub = NUM2DBL(rblapack_dz_ub);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (9th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be ldab");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_dy))
    rb_raise(rb_eArgError, "dy (17th argument) must be NArray");
  if (NA_RANK(rblapack_dy) != 1)
    rb_raise(rb_eArgError, "rank of dy (17th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dy) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of dy must be ldab");
  if (NA_TYPE(rblapack_dy) != NA_DCOMPLEX)
    rblapack_dy = na_change_type(rblapack_dy, NA_DCOMPLEX);
  dy = NA_PTR_TYPE(rblapack_dy, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr_out = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr_out = NA_PTR_TYPE(rblapack_berr_out, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldy;
    shape[1] = nrhs;
    rblapack_y_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublecomplex*);
  MEMCPY(y_out__, y, doublecomplex, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm_out__ = NA_PTR_TYPE(rblapack_err_bnds_norm_out__, doublereal*);
  MEMCPY(err_bnds_norm_out__, err_bnds_norm, doublereal, NA_TOTAL(rblapack_err_bnds_norm));
  rblapack_err_bnds_norm = rblapack_err_bnds_norm_out__;
  err_bnds_norm = err_bnds_norm_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp_out__ = NA_PTR_TYPE(rblapack_err_bnds_comp_out__, doublereal*);
  MEMCPY(err_bnds_comp_out__, err_bnds_comp, doublereal, NA_TOTAL(rblapack_err_bnds_comp));
  rblapack_err_bnds_comp = rblapack_err_bnds_comp_out__;
  err_bnds_comp = err_bnds_comp_out__;

  zla_gbrfsx_extended_(&prec_type, &trans_type, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_err_bnds_norm, rblapack_err_bnds_comp);
}

void
init_lapack_zla_gbrfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zla_gbrfsx_extended", rblapack_zla_gbrfsx_extended, -1);
}
ruby-lapack-1.7.2/ext/dpstf2.c0000644000175000017500000001263012502221022015723 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dpstf2_(char* uplo, integer* n, doublereal* a, integer* lda, integer* piv, integer* rank, doublereal* tol, doublereal* work, integer* info);


static VALUE
rblapack_dpstf2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_tol;
  doublereal tol; 
  VALUE rblapack_piv;
  integer *piv; 
  VALUE rblapack_rank;
  integer rank; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  doublereal *work;

  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  piv, rank, info, a = NumRu::Lapack.dpstf2( uplo, a, tol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPSTF2 computes the Cholesky factorization with complete\n*  pivoting of a real symmetric positive semidefinite matrix A.\n*\n*  The factorization has the form\n*     P' * A * P = U' * U ,  if UPLO = 'U',\n*     P' * A * P = L  * L',  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is lower triangular, and\n*  P is stored as vector PIV.\n*\n*  This algorithm does not attempt to check that A is positive\n*  semidefinite. This version of the algorithm calls level 2 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          n by n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n by n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the factor U or L from the Cholesky\n*          factorization as above.\n*\n*  PIV     (output) INTEGER array, dimension (N)\n*          PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n*\n*  RANK    (output) INTEGER\n*          The rank of A given by the number of steps the algorithm\n*          completed.\n*\n*  TOL     (input) DOUBLE PRECISION\n*          User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) )\n*          will be used. The algorithm terminates at the (K-1)st step\n*          if the pivot <= TOL.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N)\n*          Work space.\n*\n*  INFO    (output) INTEGER\n*          < 0: If INFO = -K, the K-th argument had an illegal value,\n*          = 0: algorithm completed successfully, and\n*          > 0: the matrix A is either rank deficient with computed rank\n*               as returned in RANK, or is indefinite.  See Section 7 of\n*               LAPACK Working Note #161 for further information.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  piv, rank, info, a = NumRu::Lapack.dpstf2( uplo, a, tol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_tol = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  tol = NUM2DBL(rblapack_tol);
  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*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_piv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  piv = NA_PTR_TYPE(rblapack_piv, integer*);
  {
    na_shape_t 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, (2*n));

  dpstf2_(&uplo, &n, a, &lda, piv, &rank, &tol, work, &info);

  free(work);
  rblapack_rank = INT2NUM(rank);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_piv, rblapack_rank, rblapack_info, rblapack_a);
}

void
init_lapack_dpstf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dpstf2", rblapack_dpstf2, -1);
}
ruby-lapack-1.7.2/ext/ssfrk.c0000644000175000017500000001462212502221021015653 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssfrk_(char* transr, char* uplo, char* trans, integer* n, integer* k, real* alpha, real* a, integer* lda, real* beta, real* c);


static VALUE
rblapack_ssfrk(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_alpha;
  real alpha; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_beta;
  real beta; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_c_out__;
  real *c_out__;

  integer lda;
  integer nt;

  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  c = NumRu::Lapack.ssfrk( transr, uplo, trans, n, k, alpha, a, beta, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C )\n\n*  Purpose\n*  =======\n*\n*  Level 3 BLAS like routine for C in RFP Format.\n*\n*  SSFRK performs one of the symmetric rank--k operations\n*\n*     C := alpha*A*A' + beta*C,\n*\n*  or\n*\n*     C := alpha*A'*A + beta*C,\n*\n*  where alpha and beta are real scalars, C is an n--by--n symmetric\n*  matrix and A is an n--by--k matrix in the first case and a k--by--n\n*  matrix in the second case.\n*\n\n*  Arguments\n*  ==========\n*\n*  TRANSR   (input) CHARACTER*1\n*          = 'N':  The Normal Form of RFP A is stored;\n*          = 'T':  The Transpose Form of RFP A is stored.\n*\n*  UPLO     (input) CHARACTER*1\n*           On  entry, UPLO specifies whether the upper or lower\n*           triangular part of the array C is to be referenced as\n*           follows:\n*\n*              UPLO = 'U' or 'u'   Only the upper triangular part of C\n*                                  is to be referenced.\n*\n*              UPLO = 'L' or 'l'   Only the lower triangular part of C\n*                                  is to be referenced.\n*\n*           Unchanged on exit.\n*\n*  TRANS    (input) CHARACTER*1\n*           On entry, TRANS specifies the operation to be performed as\n*           follows:\n*\n*              TRANS = 'N' or 'n'   C := alpha*A*A' + beta*C.\n*\n*              TRANS = 'T' or 't'   C := alpha*A'*A + beta*C.\n*\n*           Unchanged on exit.\n*\n*  N       (input) INTEGER\n*           On entry, N specifies the order of the matrix C. N must be\n*           at least zero.\n*           Unchanged on exit.\n*\n*  K       (input) INTEGER\n*           On entry with TRANS = 'N' or 'n', K specifies the number\n*           of  columns of the matrix A, and on entry with TRANS = 'T'\n*           or 't', K specifies the number of rows of the matrix A. K\n*           must be at least zero.\n*           Unchanged on exit.\n*\n*  ALPHA   (input) REAL\n*           On entry, ALPHA specifies the scalar alpha.\n*           Unchanged on exit.\n*\n*  A       (input) REAL array of DIMENSION (LDA,ka)\n*           where KA\n*           is K  when TRANS = 'N' or 'n', and is N otherwise. Before\n*           entry with TRANS = 'N' or 'n', the leading N--by--K part of\n*           the array A must contain the matrix A, otherwise the leading\n*           K--by--N part of the array A must contain the matrix A.\n*           Unchanged on exit.\n*\n*  LDA     (input) INTEGER\n*           On entry, LDA specifies the first dimension of A as declared\n*           in  the  calling  (sub)  program.   When  TRANS = 'N' or 'n'\n*           then  LDA must be at least  max( 1, n ), otherwise  LDA must\n*           be at least  max( 1, k ).\n*           Unchanged on exit.\n*\n*  BETA    (input) REAL\n*           On entry, BETA specifies the scalar beta.\n*           Unchanged on exit.\n*\n*\n*  C       (input/output) REAL array, dimension (NT)\n*           NT = N*(N+1)/2. On entry, the symmetric matrix C in RFP\n*           Format. RFP Format is described by TRANSR, UPLO and N.\n*\n*  Arguments\n*  ==========\n*\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.ssfrk( transr, uplo, trans, n, k, alpha, a, beta, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_trans = argv[2];
  rblapack_n = argv[3];
  rblapack_k = argv[4];
  rblapack_alpha = argv[5];
  rblapack_a = argv[6];
  rblapack_beta = argv[7];
  rblapack_c = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  trans = StringValueCStr(rblapack_trans)[0];
  k = NUM2INT(rblapack_k);
  beta = (real)NUM2DBL(rblapack_beta);
  uplo = StringValueCStr(rblapack_uplo)[0];
  alpha = (real)NUM2DBL(rblapack_alpha);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (9th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 1);
  nt = NA_SHAPE0(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (7th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (7th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != ((lsame_(&trans,"N") || lsame_(&trans,"n")) ? k : n))
    rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", (lsame_(&trans,"N") || lsame_(&trans,"n")) ? k : n);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[1];
    shape[0] = nt;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  ssfrk_(&transr, &uplo, &trans, &n, &k, &alpha, a, &lda, &beta, c);

  return rblapack_c;
}

void
init_lapack_ssfrk(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssfrk", rblapack_ssfrk, -1);
}
ruby-lapack-1.7.2/ext/slasd0.c0000644000175000017500000001451112502221016015712 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slasd0_(integer* n, integer* sqre, real* d, real* e, real* u, integer* ldu, real* vt, integer* ldvt, integer* smlsiz, integer* iwork, real* work, integer* info);


static VALUE
rblapack_slasd0(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_sqre;
  integer sqre; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_smlsiz;
  integer smlsiz; 
  VALUE rblapack_u;
  real *u; 
  VALUE rblapack_vt;
  real *vt; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  integer *iwork;
  real *work;

  integer n;
  integer ldu;
  integer ldvt;
  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  u, vt, info, d = NumRu::Lapack.slasd0( sqre, d, e, smlsiz, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  Using a divide and conquer approach, SLASD0 computes the singular\n*  value decomposition (SVD) of a real upper bidiagonal N-by-M\n*  matrix B with diagonal D and offdiagonal E, where M = N + SQRE.\n*  The algorithm computes orthogonal matrices U and VT such that\n*  B = U * S * VT. The singular values S are overwritten on D.\n*\n*  A related subroutine, SLASDA, computes only the singular values,\n*  and optionally, the singular vectors in compact form.\n*\n\n*  Arguments\n*  =========\n*\n*  N      (input) INTEGER\n*         On entry, the row dimension of the upper bidiagonal matrix.\n*         This is also the dimension of the main diagonal array D.\n*\n*  SQRE   (input) INTEGER\n*         Specifies the column dimension of the bidiagonal matrix.\n*         = 0: The bidiagonal matrix has column dimension M = N;\n*         = 1: The bidiagonal matrix has column dimension M = N+1;\n*\n*  D      (input/output) REAL array, dimension (N)\n*         On entry D contains the main diagonal of the bidiagonal\n*         matrix.\n*         On exit D, if INFO = 0, contains its singular values.\n*\n*  E      (input) REAL array, dimension (M-1)\n*         Contains the subdiagonal entries of the bidiagonal matrix.\n*         On exit, E has been destroyed.\n*\n*  U      (output) REAL array, dimension at least (LDQ, N)\n*         On exit, U contains the left singular vectors.\n*\n*  LDU    (input) INTEGER\n*         On entry, leading dimension of U.\n*\n*  VT     (output) REAL array, dimension at least (LDVT, M)\n*         On exit, VT' contains the right singular vectors.\n*\n*  LDVT   (input) INTEGER\n*         On entry, leading dimension of VT.\n*\n*  SMLSIZ (input) INTEGER\n*         On entry, maximum size of the subproblems at the\n*         bottom of the computation tree.\n*\n*  IWORK  (workspace) INTEGER array, dimension (8*N)\n*\n*  WORK   (workspace) REAL array, dimension (3*M**2+2*M)\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 = 1, a singular value did not converge\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, I1, IC, IDXQ, IDXQC, IM1, INODE, ITEMP, IWK,\n     $                   J, LF, LL, LVL, M, NCC, ND, NDB1, NDIML, NDIMR,\n     $                   NL, NLF, NLP1, NLVL, NR, NRF, NRP1, SQREI\n      REAL               ALPHA, BETA\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SLASD1, SLASDQ, SLASDT, XERBLA\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  u, vt, info, d = NumRu::Lapack.slasd0( sqre, d, e, smlsiz, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_sqre = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  rblapack_smlsiz = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  sqre = NUM2INT(rblapack_sqre);
  smlsiz = NUM2INT(rblapack_smlsiz);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  m = sqre == 0 ? n : sqre == 1 ? n+1 : 0;
  ldu = n;
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (m-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", m-1);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  ldvt = m;
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = n;
    rblapack_u = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  u = NA_PTR_TYPE(rblapack_u, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldvt;
    shape[1] = m;
    rblapack_vt = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vt = NA_PTR_TYPE(rblapack_vt, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  iwork = ALLOC_N(integer, (8*n));
  work = ALLOC_N(real, (3*pow(m,2)+2*m));

  slasd0_(&n, &sqre, d, e, u, &ldu, vt, &ldvt, &smlsiz, iwork, work, &info);

  free(iwork);
  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_u, rblapack_vt, rblapack_info, rblapack_d);
}

void
init_lapack_slasd0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slasd0", rblapack_slasd0, -1);
}
ruby-lapack-1.7.2/ext/zla_gbrcond_c.c0000644000175000017500000002107212502221026017313 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal zla_gbrcond_c_(char* trans, integer* n, integer* kl, integer* ku, doublecomplex* ab, integer* ldab, doublecomplex* afb, integer* ldafb, integer* ipiv, doublereal* c, logical* capply, integer* info, doublecomplex* work, doublereal* rwork);


static VALUE
rblapack_zla_gbrcond_c(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_afb;
  doublecomplex *afb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_capply;
  logical capply; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_rwork;
  doublereal *rwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack___out__;
  doublereal __out__; 

  integer ldab;
  integer n;
  integer ldafb;

  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  info, __out__ = NumRu::Lapack.zla_gbrcond_c( trans, kl, ku, ab, afb, ipiv, c, capply, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION ZLA_GBRCOND_C( TRANS, N, KL, KU, AB,  LDAB, AFB, LDAFB, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n*  Purpose\n*  =======\n*\n*     ZLA_GBRCOND_C Computes the infinity norm condition number of\n*     op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector.\n*\n\n*  Arguments\n*  =========\n*\n*     TRANS   (input) CHARACTER*1\n*     Specifies the form of the system of equations:\n*       = 'N':  A * X = B     (No transpose)\n*       = 'T':  A**T * X = B  (Transpose)\n*       = 'C':  A**H * X = B  (Conjugate Transpose = Transpose)\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     KL      (input) INTEGER\n*     The number of subdiagonals within the band of A.  KL >= 0.\n*\n*     KU      (input) INTEGER\n*     The number of superdiagonals within the band of A.  KU >= 0.\n*\n*     AB      (input) COMPLEX*16 array, dimension (LDAB,N)\n*     On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n*     The j-th column of A is stored in the j-th column of the\n*     array AB as follows:\n*     AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n*     LDAB    (input) INTEGER\n*     The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*     AFB     (input) COMPLEX*16 array, dimension (LDAFB,N)\n*     Details of the LU factorization of the band matrix A, as\n*     computed by ZGBTRF.  U is stored as an upper triangular\n*     band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n*     and the multipliers used during the factorization are stored\n*     in rows KL+KU+2 to 2*KL+KU+1.\n*\n*     LDAFB   (input) INTEGER\n*     The leading dimension of the array AFB.  LDAFB >= 2*KL+KU+1.\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     The pivot indices from the factorization A = P*L*U\n*     as computed by ZGBTRF; row i of the matrix was interchanged\n*     with row IPIV(i).\n*\n*     C       (input) DOUBLE PRECISION array, dimension (N)\n*     The vector C in the formula op(A) * inv(diag(C)).\n*\n*     CAPPLY  (input) LOGICAL\n*     If .TRUE. then access the vector C in the formula above.\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit.\n*     i > 0:  The ith argument is invalid.\n*\n*     WORK    (input) COMPLEX*16 array, dimension (2*N).\n*     Workspace.\n*\n*     RWORK   (input) DOUBLE PRECISION array, dimension (N).\n*     Workspace.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            NOTRANS\n      INTEGER            KASE, I, J\n      DOUBLE PRECISION   AINVNM, ANORM, TMP\n      COMPLEX*16         ZDUM\n*     ..\n*     .. Local Arrays ..\n      INTEGER            ISAVE( 3 )\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           ZLACN2, ZGBTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX\n*     ..\n*     .. Statement Functions ..\n      DOUBLE PRECISION   CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, __out__ = NumRu::Lapack.zla_gbrcond_c( trans, kl, ku, ab, afb, ipiv, c, capply, work, rwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_trans = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  rblapack_afb = argv[4];
  rblapack_ipiv = argv[5];
  rblapack_c = argv[6];
  rblapack_capply = argv[7];
  rblapack_work = argv[8];
  rblapack_rwork = argv[9];
  if (argc == 10) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
  ldafb = NA_SHAPE0(rblapack_afb);
  n = NA_SHAPE1(rblapack_afb);
  if (NA_TYPE(rblapack_afb) != NA_DCOMPLEX)
    rblapack_afb = na_change_type(rblapack_afb, NA_DCOMPLEX);
  afb = NA_PTR_TYPE(rblapack_afb, doublecomplex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_rwork))
    rb_raise(rb_eArgError, "rwork (10th argument) must be NArray");
  if (NA_RANK(rblapack_rwork) != 1)
    rb_raise(rb_eArgError, "rank of rwork (10th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_rwork) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_rwork) != NA_DFLOAT)
    rblapack_rwork = na_change_type(rblapack_rwork, NA_DFLOAT);
  rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  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);
  if (NA_SHAPE0(rblapack_work) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
  if (NA_TYPE(rblapack_work) != NA_DCOMPLEX)
    rblapack_work = na_change_type(rblapack_work, NA_DCOMPLEX);
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  capply = (rblapack_capply == Qtrue);

  __out__ = zla_gbrcond_c_(&trans, &n, &kl, &ku, ab, &ldab, afb, &ldafb, ipiv, c, &capply, &info, work, rwork);

  rblapack_info = INT2NUM(info);
  rblapack___out__ = rb_float_new((double)__out__);
  return rb_ary_new3(2, rblapack_info, rblapack___out__);
}

void
init_lapack_zla_gbrcond_c(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zla_gbrcond_c", rblapack_zla_gbrcond_c, -1);
}
ruby-lapack-1.7.2/ext/dladiv.c0000644000175000017500000000524112502221024015766 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dladiv_(doublereal* a, doublereal* b, doublereal* c, doublereal* d, doublereal* p, doublereal* q);


static VALUE
rblapack_dladiv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublereal a; 
  VALUE rblapack_b;
  doublereal b; 
  VALUE rblapack_c;
  doublereal c; 
  VALUE rblapack_d;
  doublereal d; 
  VALUE rblapack_p;
  doublereal p; 
  VALUE rblapack_q;
  doublereal q; 


  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  p, q = NumRu::Lapack.dladiv( a, b, c, d, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLADIV( A, B, C, D, P, Q )\n\n*  Purpose\n*  =======\n*\n*  DLADIV performs complex division in  real arithmetic\n*\n*                        a + i*b\n*             p + i*q = ---------\n*                        c + i*d\n*\n*  The algorithm is due to Robert L. Smith and can be found\n*  in D. Knuth, The art of Computer Programming, Vol.2, p.195\n*\n\n*  Arguments\n*  =========\n*\n*  A       (input) DOUBLE PRECISION\n*  B       (input) DOUBLE PRECISION\n*  C       (input) DOUBLE PRECISION\n*  D       (input) DOUBLE PRECISION\n*          The scalars a, b, c, and d in the above expression.\n*\n*  P       (output) DOUBLE PRECISION\n*  Q       (output) DOUBLE PRECISION\n*          The scalars p and q in the above expression.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      DOUBLE PRECISION   E, F\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  p, q = NumRu::Lapack.dladiv( a, b, c, d, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  rblapack_c = argv[2];
  rblapack_d = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  a = NUM2DBL(rblapack_a);
  c = NUM2DBL(rblapack_c);
  b = NUM2DBL(rblapack_b);
  d = NUM2DBL(rblapack_d);

  dladiv_(&a, &b, &c, &d, &p, &q);

  rblapack_p = rb_float_new((double)p);
  rblapack_q = rb_float_new((double)q);
  return rb_ary_new3(2, rblapack_p, rblapack_q);
}

void
init_lapack_dladiv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dladiv", rblapack_dladiv, -1);
}
ruby-lapack-1.7.2/ext/cgbrfsx.c0000644000175000017500000005630412502221015016167 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgbrfsx_(char* trans, char* equed, integer* n, integer* kl, integer* ku, integer* nrhs, doublereal* ab, integer* ldab, doublereal* afb, integer* ldafb, integer* ipiv, real* r, real* c, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cgbrfsx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_afb;
  doublereal *afb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_r;
  real *r; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_params;
  real *params; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_err_bnds_norm;
  real *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  real *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_r_out__;
  real *r_out__;
  VALUE rblapack_c_out__;
  real *c_out__;
  VALUE rblapack_x_out__;
  real *x_out__;
  VALUE rblapack_params_out__;
  real *params_out__;
  complex *work;
  real *rwork;

  integer ldab;
  integer n;
  integer ldafb;
  integer ldb;
  integer nrhs;
  integer ldx;
  integer nparams;
  integer n_err_bnds;

  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  rcond, berr, err_bnds_norm, err_bnds_comp, info, r, c, x, params = NumRu::Lapack.cgbrfsx( trans, equed, kl, ku, ab, afb, ipiv, r, c, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     CGBRFSX improves the computed solution to a system of linear\n*     equations and provides error bounds and backward error estimates\n*     for the solution.  In addition to normwise error bound, the code\n*     provides maximum componentwise error bound if possible.  See\n*     comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n*     error bounds.\n*\n*     The original system of linear equations may have been equilibrated\n*     before calling this routine, as described by arguments EQUED, R\n*     and C below. In this case, the solution and error bounds returned\n*     are for the original unequilibrated system.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     TRANS   (input) CHARACTER*1\n*     Specifies the form of the system of equations:\n*       = 'N':  A * X = B     (No transpose)\n*       = 'T':  A**T * X = B  (Transpose)\n*       = 'C':  A**H * X = B  (Conjugate transpose = Transpose)\n*\n*     EQUED   (input) CHARACTER*1\n*     Specifies the form of equilibration that was done to A\n*     before calling this routine. This is needed to compute\n*     the solution and error bounds correctly.\n*       = 'N':  No equilibration\n*       = 'R':  Row equilibration, i.e., A has been premultiplied by\n*               diag(R).\n*       = 'C':  Column equilibration, i.e., A has been postmultiplied\n*               by diag(C).\n*       = 'B':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(R) * A * diag(C).\n*               The right hand side B has been changed accordingly.\n*\n*     N       (input) INTEGER\n*     The order of the matrix A.  N >= 0.\n*\n*     KL      (input) INTEGER\n*     The number of subdiagonals within the band of A.  KL >= 0.\n*\n*     KU      (input) INTEGER\n*     The number of superdiagonals within the band of A.  KU >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)\n*     The original band matrix A, stored in rows 1 to KL+KU+1.\n*     The j-th column of A is stored in the j-th column of the\n*     array AB as follows:\n*     AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n*     LDAB    (input) INTEGER\n*     The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*     AFB     (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n*     Details of the LU factorization of the band matrix A, as\n*     computed by DGBTRF.  U is stored as an upper triangular band\n*     matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n*     the multipliers used during the factorization are stored in\n*     rows KL+KU+2 to 2*KL+KU+1.\n*\n*     LDAFB   (input) INTEGER\n*     The leading dimension of the array AFB.  LDAFB >= 2*KL*KU+1.\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     The pivot indices from SGETRF; for 1<=i<=N, row i of the\n*     matrix was interchanged with row IPIV(i).\n*\n*     R       (input or output) REAL array, dimension (N)\n*     The row scale factors for A.  If EQUED = 'R' or 'B', A is\n*     multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n*     is not accessed.  R is an input argument if FACT = 'F';\n*     otherwise, R is an output argument.  If FACT = 'F' and\n*     EQUED = 'R' or 'B', each element of R must be positive.\n*     If R is output, each element of R is a power of the radix.\n*     If R is input, each element of R should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     C       (input or output) REAL array, dimension (N)\n*     The column scale factors for A.  If EQUED = 'C' or 'B', A is\n*     multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n*     is not accessed.  C is an input argument if FACT = 'F';\n*     otherwise, C is an output argument.  If FACT = 'F' and\n*     EQUED = 'C' or 'B', each element of C must be positive.\n*     If C is output, each element of C is a power of the radix.\n*     If C is input, each element of C should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B       (input) REAL array, dimension (LDB,NRHS)\n*     The right hand side matrix B.\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (input/output) REAL array, dimension (LDX,NRHS)\n*     On entry, the solution matrix X, as computed by SGETRS.\n*     On exit, the improved solution matrix X.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) REAL\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     BERR    (output) REAL array, dimension (NRHS)\n*     Componentwise relative backward error.  This is the\n*     componentwise relative backward error of each solution vector X(j)\n*     (i.e., the smallest relative change in any element of A or B that\n*     makes X(j) an exact solution).\n*\n*     N_ERR_BNDS (input) INTEGER\n*     Number of error bounds to return for each right hand side\n*     and each type (normwise or componentwise).  See ERR_BNDS_NORM and\n*     ERR_BNDS_COMP below.\n*\n*     ERR_BNDS_NORM  (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     NPARAMS (input) INTEGER\n*     Specifies the number of parameters set in PARAMS.  If .LE. 0, the\n*     PARAMS array is never referenced and default values are used.\n*\n*     PARAMS  (input / output) REAL array, dimension NPARAMS\n*     Specifies algorithm parameters.  If an entry is .LT. 0.0, then\n*     that entry will be filled with default value used for that\n*     parameter.  Only positions up to NPARAMS are accessed; defaults\n*     are used for higher-numbered parameters.\n*\n*       PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n*            refinement or not.\n*         Default: 1.0\n*            = 0.0 : No refinement is performed, and no error bounds are\n*                    computed.\n*            = 1.0 : Use the double-precision refinement algorithm,\n*                    possibly with doubled-single computations if the\n*                    compilation environment does not support DOUBLE\n*                    PRECISION.\n*              (other values are reserved for future use)\n*\n*       PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n*            computations allowed for refinement.\n*         Default: 10\n*         Aggressive: Set to 100 to permit convergence using approximate\n*                     factorizations or factorizations other than LU. If\n*                     the factorization uses a technique other than\n*                     Gaussian elimination, the guarantees in\n*                     err_bnds_norm and err_bnds_comp may no longer be\n*                     trustworthy.\n*\n*       PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n*            will attempt to find a solution with small componentwise\n*            relative error in the double-precision algorithm.  Positive\n*            is true, 0.0 is false.\n*         Default: 1.0 (attempt componentwise convergence)\n*\n*     WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*     RWORK   (workspace) REAL array, dimension (2*N)\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit. The solution to every right-hand side is\n*         guaranteed.\n*       < 0:  If INFO = -i, the i-th argument had an illegal value\n*       > 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, berr, err_bnds_norm, err_bnds_comp, info, r, c, x, params = NumRu::Lapack.cgbrfsx( trans, equed, kl, ku, ab, afb, ipiv, r, c, b, x, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_trans = argv[0];
  rblapack_equed = argv[1];
  rblapack_kl = argv[2];
  rblapack_ku = argv[3];
  rblapack_ab = argv[4];
  rblapack_afb = argv[5];
  rblapack_ipiv = argv[6];
  rblapack_r = argv[7];
  rblapack_c = argv[8];
  rblapack_b = argv[9];
  rblapack_x = argv[10];
  rblapack_params = argv[11];
  if (argc == 12) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (9th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (11th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (11th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  n_err_bnds = 3;
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
  ldafb = NA_SHAPE0(rblapack_afb);
  if (NA_SHAPE1(rblapack_afb) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_afb) != NA_DFLOAT)
    rblapack_afb = na_change_type(rblapack_afb, NA_DFLOAT);
  afb = NA_PTR_TYPE(rblapack_afb, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (10th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (10th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (12th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (12th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_SFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
  params = NA_PTR_TYPE(rblapack_params, real*);
  if (!NA_IsNArray(rblapack_r))
    rb_raise(rb_eArgError, "r (8th argument) must be NArray");
  if (NA_RANK(rblapack_r) != 1)
    rb_raise(rb_eArgError, "rank of r (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_r) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_r) != NA_SFLOAT)
    rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
  r = NA_PTR_TYPE(rblapack_r, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_r_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  r_out__ = NA_PTR_TYPE(rblapack_r_out__, real*);
  MEMCPY(r_out__, r, real, NA_TOTAL(rblapack_r));
  rblapack_r = rblapack_r_out__;
  r = r_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
  MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (2*n));

  cgbrfsx_(&trans, &equed, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, r, c, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_r, rblapack_c, rblapack_x, rblapack_params);
}

void
init_lapack_cgbrfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgbrfsx", rblapack_cgbrfsx, -1);
}
ruby-lapack-1.7.2/ext/claev2.c0000644000175000017500000001004112502221023015670 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID claev2_(complex* a, complex* b, complex* c, real* rt1, real* rt2, real* cs1, complex* sn1);


static VALUE
rblapack_claev2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  complex a; 
  VALUE rblapack_b;
  complex b; 
  VALUE rblapack_c;
  complex c; 
  VALUE rblapack_rt1;
  real rt1; 
  VALUE rblapack_rt2;
  real rt2; 
  VALUE rblapack_cs1;
  real cs1; 
  VALUE rblapack_sn1;
  complex sn1; 


  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  rt1, rt2, cs1, sn1 = NumRu::Lapack.claev2( a, b, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAEV2( A, B, C, RT1, RT2, CS1, SN1 )\n\n*  Purpose\n*  =======\n*\n*  CLAEV2 computes the eigendecomposition of a 2-by-2 Hermitian matrix\n*     [  A         B  ]\n*     [  CONJG(B)  C  ].\n*  On return, RT1 is the eigenvalue of larger absolute value, RT2 is the\n*  eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right\n*  eigenvector for RT1, giving the decomposition\n*\n*  [ CS1  CONJG(SN1) ] [    A     B ] [ CS1 -CONJG(SN1) ] = [ RT1  0  ]\n*  [-SN1     CS1     ] [ CONJG(B) C ] [ SN1     CS1     ]   [  0  RT2 ].\n*\n\n*  Arguments\n*  =========\n*\n*  A      (input) COMPLEX\n*         The (1,1) element of the 2-by-2 matrix.\n*\n*  B      (input) COMPLEX\n*         The (1,2) element and the conjugate of the (2,1) element of\n*         the 2-by-2 matrix.\n*\n*  C      (input) COMPLEX\n*         The (2,2) element of the 2-by-2 matrix.\n*\n*  RT1    (output) REAL\n*         The eigenvalue of larger absolute value.\n*\n*  RT2    (output) REAL\n*         The eigenvalue of smaller absolute value.\n*\n*  CS1    (output) REAL\n*  SN1    (output) COMPLEX\n*         The vector (CS1, SN1) is a unit right eigenvector for RT1.\n*\n\n*  Further Details\n*  ===============\n*\n*  RT1 is accurate to a few ulps barring over/underflow.\n*\n*  RT2 may be inaccurate if there is massive cancellation in the\n*  determinant A*C-B*B; higher precision or correctly rounded or\n*  correctly truncated arithmetic would be needed to compute RT2\n*  accurately in all cases.\n*\n*  CS1 and SN1 are accurate to a few ulps barring over/underflow.\n*\n*  Overflow is possible only if RT1 is within a factor of 5 of overflow.\n*  Underflow is harmless if the input data is 0 or exceeds\n*     underflow_threshold / macheps.\n*\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rt1, rt2, cs1, sn1 = NumRu::Lapack.claev2( a, b, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  rblapack_c = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  a.r = (real)NUM2DBL(rb_funcall(rblapack_a, rb_intern("real"), 0));
  a.i = (real)NUM2DBL(rb_funcall(rblapack_a, rb_intern("imag"), 0));
  c.r = (real)NUM2DBL(rb_funcall(rblapack_c, rb_intern("real"), 0));
  c.i = (real)NUM2DBL(rb_funcall(rblapack_c, rb_intern("imag"), 0));
  b.r = (real)NUM2DBL(rb_funcall(rblapack_b, rb_intern("real"), 0));
  b.i = (real)NUM2DBL(rb_funcall(rblapack_b, rb_intern("imag"), 0));

  claev2_(&a, &b, &c, &rt1, &rt2, &cs1, &sn1);

  rblapack_rt1 = rb_float_new((double)rt1);
  rblapack_rt2 = rb_float_new((double)rt2);
  rblapack_cs1 = rb_float_new((double)cs1);
  rblapack_sn1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(sn1.r)), rb_float_new((double)(sn1.i)));
  return rb_ary_new3(4, rblapack_rt1, rblapack_rt2, rblapack_cs1, rblapack_sn1);
}

void
init_lapack_claev2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "claev2", rblapack_claev2, -1);
}
ruby-lapack-1.7.2/ext/dlat2s.c0000644000175000017500000000772312502221026015725 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlat2s_(char* uplo, integer* n, doublereal* a, integer* lda, real* sa, integer* ldsa, integer* info);


static VALUE
rblapack_dlat2s(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_sa;
  real *sa; 
  VALUE rblapack_info;
  integer info; 

  integer lda;
  integer n;
  integer ldsa;

  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  sa, info = NumRu::Lapack.dlat2s( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAT2S( UPLO, N, A, LDA, SA, LDSA, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLAT2S converts a DOUBLE PRECISION triangular matrix, SA, to a SINGLE\n*  PRECISION triangular matrix, A.\n*\n*  RMAX is the overflow for the SINGLE PRECISION arithmetic\n*  DLAS2S checks that all the entries of A are between -RMAX and\n*  RMAX. If not the convertion is aborted and a flag is raised.\n*\n*  This is an auxiliary routine so there is no argument checking.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  N       (input) INTEGER\n*          The number of rows and columns of the matrix A.  N >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the N-by-N triangular coefficient matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  SA      (output) REAL array, dimension (LDSA,N)\n*          Only the UPLO part of SA is referenced.  On exit, if INFO=0,\n*          the N-by-N coefficient matrix SA; if INFO>0, the content of\n*          the UPLO part of SA is unspecified.\n*\n*  LDSA    (input) INTEGER\n*          The leading dimension of the array SA.  LDSA >= max(1,M).\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit.\n*          = 1:  an entry of the matrix A is greater than the SINGLE\n*                PRECISION overflow threshold, in this case, the content\n*                of the UPLO part of SA in exit is unspecified.\n*\n*  =========\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n      DOUBLE PRECISION   RMAX\n      LOGICAL            UPPER\n*     ..\n*     .. External Functions ..\n      REAL               SLAMCH\n      LOGICAL            LSAME\n      EXTERNAL           SLAMCH, LSAME\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sa, info = NumRu::Lapack.dlat2s( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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*);
  ldsa = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = ldsa;
    shape[1] = n;
    rblapack_sa = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  sa = NA_PTR_TYPE(rblapack_sa, real*);

  dlat2s_(&uplo, &n, a, &lda, sa, &ldsa, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_sa, rblapack_info);
}

void
init_lapack_dlat2s(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlat2s", rblapack_dlat2s, -1);
}
ruby-lapack-1.7.2/ext/sgeevx.c0000644000175000017500000003334712502221023016033 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgeevx_(char* balanc, char* jobvl, char* jobvr, char* sense, integer* n, real* a, integer* lda, real* wr, real* wi, real* vl, integer* ldvl, real* vr, integer* ldvr, integer* ilo, integer* ihi, real* scale, real* abnrm, real* rconde, real* rcondv, real* work, integer* lwork, integer* iwork, integer* info);


static VALUE
rblapack_sgeevx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_balanc;
  char balanc; 
  VALUE rblapack_jobvl;
  char jobvl; 
  VALUE rblapack_jobvr;
  char jobvr; 
  VALUE rblapack_sense;
  char sense; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_wr;
  real *wr; 
  VALUE rblapack_wi;
  real *wi; 
  VALUE rblapack_vl;
  real *vl; 
  VALUE rblapack_vr;
  real *vr; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_scale;
  real *scale; 
  VALUE rblapack_abnrm;
  real abnrm; 
  VALUE rblapack_rconde;
  real *rconde; 
  VALUE rblapack_rcondv;
  real *rcondv; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  integer *iwork;

  integer lda;
  integer n;
  integer ldvl;
  integer ldvr;

  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  wr, wi, vl, vr, ilo, ihi, scale, abnrm, rconde, rcondv, work, info, a = NumRu::Lapack.sgeevx( balanc, jobvl, jobvr, sense, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, WORK, LWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGEEVX computes for an N-by-N real nonsymmetric matrix A, the\n*  eigenvalues and, optionally, the left and/or right eigenvectors.\n*\n*  Optionally also, it computes a balancing transformation to improve\n*  the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n*  SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues\n*  (RCONDE), and reciprocal condition numbers for the right\n*  eigenvectors (RCONDV).\n*\n*  The right eigenvector v(j) of A satisfies\n*                   A * v(j) = lambda(j) * v(j)\n*  where lambda(j) is its eigenvalue.\n*  The left eigenvector u(j) of A satisfies\n*                u(j)**H * A = lambda(j) * u(j)**H\n*  where u(j)**H denotes the conjugate transpose of u(j).\n*\n*  The computed eigenvectors are normalized to have Euclidean norm\n*  equal to 1 and largest component real.\n*\n*  Balancing a matrix means permuting the rows and columns to make it\n*  more nearly upper triangular, and applying a diagonal similarity\n*  transformation D * A * D**(-1), where D is a diagonal matrix, to\n*  make its rows and columns closer in norm and the condition numbers\n*  of its eigenvalues and eigenvectors smaller.  The computed\n*  reciprocal condition numbers correspond to the balanced matrix.\n*  Permuting rows and columns will not change the condition numbers\n*  (in exact arithmetic) but diagonal scaling will.  For further\n*  explanation of balancing, see section 4.10.2 of the LAPACK\n*  Users' Guide.\n*\n\n*  Arguments\n*  =========\n*\n*  BALANC  (input) CHARACTER*1\n*          Indicates how the input matrix should be diagonally scaled\n*          and/or permuted to improve the conditioning of its\n*          eigenvalues.\n*          = 'N': Do not diagonally scale or permute;\n*          = 'P': Perform permutations to make the matrix more nearly\n*                 upper triangular. Do not diagonally scale;\n*          = 'S': Diagonally scale the matrix, i.e. replace A by\n*                 D*A*D**(-1), where D is a diagonal matrix chosen\n*                 to make the rows and columns of A more equal in\n*                 norm. Do not permute;\n*          = 'B': Both diagonally scale and permute A.\n*\n*          Computed reciprocal condition numbers will be for the matrix\n*          after balancing and/or permuting. Permuting does not change\n*          condition numbers (in exact arithmetic), but balancing does.\n*\n*  JOBVL   (input) CHARACTER*1\n*          = 'N': left eigenvectors of A are not computed;\n*          = 'V': left eigenvectors of A are computed.\n*          If SENSE = 'E' or 'B', JOBVL must = 'V'.\n*\n*  JOBVR   (input) CHARACTER*1\n*          = 'N': right eigenvectors of A are not computed;\n*          = 'V': right eigenvectors of A are computed.\n*          If SENSE = 'E' or 'B', JOBVR must = 'V'.\n*\n*  SENSE   (input) CHARACTER*1\n*          Determines which reciprocal condition numbers are computed.\n*          = 'N': None are computed;\n*          = 'E': Computed for eigenvalues only;\n*          = 'V': Computed for right eigenvectors only;\n*          = 'B': Computed for eigenvalues and right eigenvectors.\n*\n*          If SENSE = 'E' or 'B', both left and right eigenvectors\n*          must also be computed (JOBVL = 'V' and JOBVR = 'V').\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the N-by-N matrix A.\n*          On exit, A has been overwritten.  If JOBVL = 'V' or\n*          JOBVR = 'V', A contains the real Schur form of the balanced\n*          version of the input matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  WR      (output) REAL array, dimension (N)\n*  WI      (output) REAL array, dimension (N)\n*          WR and WI contain the real and imaginary parts,\n*          respectively, of the computed eigenvalues.  Complex\n*          conjugate pairs of eigenvalues will appear consecutively\n*          with the eigenvalue having the positive imaginary part\n*          first.\n*\n*  VL      (output) REAL array, dimension (LDVL,N)\n*          If JOBVL = 'V', the left eigenvectors u(j) are stored one\n*          after another in the columns of VL, in the same order\n*          as their eigenvalues.\n*          If JOBVL = 'N', VL is not referenced.\n*          If the j-th eigenvalue is real, then u(j) = VL(:,j),\n*          the j-th column of VL.\n*          If the j-th and (j+1)-st eigenvalues form a complex\n*          conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and\n*          u(j+1) = VL(:,j) - i*VL(:,j+1).\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the array VL.  LDVL >= 1; if\n*          JOBVL = 'V', LDVL >= N.\n*\n*  VR      (output) REAL array, dimension (LDVR,N)\n*          If JOBVR = 'V', the right eigenvectors v(j) are stored one\n*          after another in the columns of VR, in the same order\n*          as their eigenvalues.\n*          If JOBVR = 'N', VR is not referenced.\n*          If the j-th eigenvalue is real, then v(j) = VR(:,j),\n*          the j-th column of VR.\n*          If the j-th and (j+1)-st eigenvalues form a complex\n*          conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and\n*          v(j+1) = VR(:,j) - i*VR(:,j+1).\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the array VR.  LDVR >= 1, and if\n*          JOBVR = 'V', LDVR >= N.\n*\n*  ILO     (output) INTEGER\n*  IHI     (output) INTEGER\n*          ILO and IHI are integer values determined when A was\n*          balanced.  The balanced A(i,j) = 0 if I > J and \n*          J = 1,...,ILO-1 or I = IHI+1,...,N.\n*\n*  SCALE   (output) REAL array, dimension (N)\n*          Details of the permutations and scaling factors applied\n*          when balancing A.  If P(j) is the index of the row and column\n*          interchanged with row and column j, and D(j) is the scaling\n*          factor applied to row and column j, then\n*          SCALE(J) = P(J),    for J = 1,...,ILO-1\n*                   = D(J),    for J = ILO,...,IHI\n*                   = P(J)     for J = IHI+1,...,N.\n*          The order in which the interchanges are made is N to IHI+1,\n*          then 1 to ILO-1.\n*\n*  ABNRM   (output) REAL\n*          The one-norm of the balanced matrix (the maximum\n*          of the sum of absolute values of elements of any column).\n*\n*  RCONDE  (output) REAL array, dimension (N)\n*          RCONDE(j) is the reciprocal condition number of the j-th\n*          eigenvalue.\n*\n*  RCONDV  (output) REAL array, dimension (N)\n*          RCONDV(j) is the reciprocal condition number of the j-th\n*          right eigenvector.\n*\n*  WORK    (workspace/output) REAL 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.   If SENSE = 'N' or 'E',\n*          LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V',\n*          LWORK >= 3*N.  If SENSE = 'V' or 'B', LWORK >= N*(N+6).\n*          For good performance, LWORK must generally be larger.\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*  IWORK   (workspace) INTEGER array, dimension (2*N-2)\n*          If SENSE = 'N' or 'E', not referenced.\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 QR algorithm failed to compute all the\n*                eigenvalues, and no eigenvectors or condition numbers\n*                have been computed; elements 1:ILO-1 and i+1:N of WR\n*                and WI contain eigenvalues which have converged.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  wr, wi, vl, vr, ilo, ihi, scale, abnrm, rconde, rcondv, work, info, a = NumRu::Lapack.sgeevx( balanc, jobvl, jobvr, sense, a, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_balanc = argv[0];
  rblapack_jobvl = argv[1];
  rblapack_jobvr = argv[2];
  rblapack_sense = argv[3];
  rblapack_a = argv[4];
  if (argc == 6) {
    rblapack_lwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  balanc = StringValueCStr(rblapack_balanc)[0];
  jobvr = StringValueCStr(rblapack_jobvr)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  ldvr = lsame_(&jobvr,"V") ? n : 1;
  jobvl = StringValueCStr(rblapack_jobvl)[0];
  ldvl = lsame_(&jobvl,"V") ? n : 1;
  sense = StringValueCStr(rblapack_sense)[0];
  if (rblapack_lwork == Qnil)
    lwork = (lsame_(&sense,"N")||lsame_(&sense,"E")) ? 2*n : (lsame_(&jobvl,"V")||lsame_(&jobvr,"V")) ? 3*n : (lsame_(&sense,"V")||lsame_(&sense,"B")) ? n*(n+6) : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  wr = NA_PTR_TYPE(rblapack_wr, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  wi = NA_PTR_TYPE(rblapack_wi, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = n;
    rblapack_vl = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vl = NA_PTR_TYPE(rblapack_vl, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = n;
    rblapack_vr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vr = NA_PTR_TYPE(rblapack_vr, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_scale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  scale = NA_PTR_TYPE(rblapack_scale, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rconde = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  rconde = NA_PTR_TYPE(rblapack_rconde, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rcondv = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  rcondv = NA_PTR_TYPE(rblapack_rcondv, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  iwork = ALLOC_N(integer, ((lsame_(&sense,"N")||lsame_(&sense,"E")) ? 0 : 2*n-2));

  sgeevx_(&balanc, &jobvl, &jobvr, &sense, &n, a, &lda, wr, wi, vl, &ldvl, vr, &ldvr, &ilo, &ihi, scale, &abnrm, rconde, rcondv, work, &lwork, iwork, &info);

  free(iwork);
  rblapack_ilo = INT2NUM(ilo);
  rblapack_ihi = INT2NUM(ihi);
  rblapack_abnrm = rb_float_new((double)abnrm);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(13, rblapack_wr, rblapack_wi, rblapack_vl, rblapack_vr, rblapack_ilo, rblapack_ihi, rblapack_scale, rblapack_abnrm, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_sgeevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgeevx", rblapack_sgeevx, -1);
}
ruby-lapack-1.7.2/ext/slag2.c0000644000175000017500000001500612655767574015575 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slag2_(real* a, integer* lda, real* b, integer* ldb, real* safmin, real* scale1, real* scale2, real* wr1, real* wr2, real* wi);


static VALUE
rblapack_slag2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_safmin;
  real safmin; 
  VALUE rblapack_scale1;
  real scale1; 
  VALUE rblapack_scale2;
  real scale2; 
  VALUE rblapack_wr1;
  real wr1; 
  VALUE rblapack_wr2;
  real wr2; 
  VALUE rblapack_wi;
  real wi; 

  integer lda;
  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  scale1, scale2, wr1, wr2, wi = NumRu::Lapack.slag2( a, b, safmin, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, WR2, WI )\n\n*  Purpose\n*  =======\n*\n*  SLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue\n*  problem  A - w B, with scaling as necessary to avoid over-/underflow.\n*\n*  The scaling factor \"s\" results in a modified eigenvalue equation\n*\n*      s A - w B\n*\n*  where  s  is a non-negative scaling factor chosen so that  w,  w B,\n*  and  s A  do not overflow and, if possible, do not underflow, either.\n*\n\n*  Arguments\n*  =========\n*\n*  A       (input) REAL array, dimension (LDA, 2)\n*          On entry, the 2 x 2 matrix A.  It is assumed that its 1-norm\n*          is less than 1/SAFMIN.  Entries less than\n*          sqrt(SAFMIN)*norm(A) are subject to being treated as zero.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= 2.\n*\n*  B       (input) REAL array, dimension (LDB, 2)\n*          On entry, the 2 x 2 upper triangular matrix B.  It is\n*          assumed that the one-norm of B is less than 1/SAFMIN.  The\n*          diagonals should be at least sqrt(SAFMIN) times the largest\n*          element of B (in absolute value); if a diagonal is smaller\n*          than that, then  +/- sqrt(SAFMIN) will be used instead of\n*          that diagonal.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= 2.\n*\n*  SAFMIN  (input) REAL\n*          The smallest positive number s.t. 1/SAFMIN does not\n*          overflow.  (This should always be SLAMCH('S') -- it is an\n*          argument in order to avoid having to call SLAMCH frequently.)\n*\n*  SCALE1  (output) REAL\n*          A scaling factor used to avoid over-/underflow in the\n*          eigenvalue equation which defines the first eigenvalue.  If\n*          the eigenvalues are complex, then the eigenvalues are\n*          ( WR1  +/-  WI i ) / SCALE1  (which may lie outside the\n*          exponent range of the machine), SCALE1=SCALE2, and SCALE1\n*          will always be positive.  If the eigenvalues are real, then\n*          the first (real) eigenvalue is  WR1 / SCALE1 , but this may\n*          overflow or underflow, and in fact, SCALE1 may be zero or\n*          less than the underflow threshold if the exact eigenvalue\n*          is sufficiently large.\n*\n*  SCALE2  (output) REAL\n*          A scaling factor used to avoid over-/underflow in the\n*          eigenvalue equation which defines the second eigenvalue.  If\n*          the eigenvalues are complex, then SCALE2=SCALE1.  If the\n*          eigenvalues are real, then the second (real) eigenvalue is\n*          WR2 / SCALE2 , but this may overflow or underflow, and in\n*          fact, SCALE2 may be zero or less than the underflow\n*          threshold if the exact eigenvalue is sufficiently large.\n*\n*  WR1     (output) REAL\n*          If the eigenvalue is real, then WR1 is SCALE1 times the\n*          eigenvalue closest to the (2,2) element of A B**(-1).  If the\n*          eigenvalue is complex, then WR1=WR2 is SCALE1 times the real\n*          part of the eigenvalues.\n*\n*  WR2     (output) REAL\n*          If the eigenvalue is real, then WR2 is SCALE2 times the\n*          other eigenvalue.  If the eigenvalue is complex, then\n*          WR1=WR2 is SCALE1 times the real part of the eigenvalues.\n*\n*  WI      (output) REAL\n*          If the eigenvalue is real, then WI is zero.  If the\n*          eigenvalue is complex, then WI is SCALE1 times the imaginary\n*          part of the eigenvalues.  WI will always be non-negative.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale1, scale2, wr1, wr2, wi = NumRu::Lapack.slag2( a, b, safmin, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  rblapack_safmin = argv[2];
  if (argc == 3) {
  } 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);
  if (NA_SHAPE1(rblapack_a) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", 2);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  safmin = (real)NUM2DBL(rblapack_safmin);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of b must be %d", 2);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);

  slag2_(a, &lda, b, &ldb, &safmin, &scale1, &scale2, &wr1, &wr2, &wi);

  rblapack_scale1 = rb_float_new((double)scale1);
  rblapack_scale2 = rb_float_new((double)scale2);
  rblapack_wr1 = rb_float_new((double)wr1);
  rblapack_wr2 = rb_float_new((double)wr2);
  rblapack_wi = rb_float_new((double)wi);
  return rb_ary_new3(5, rblapack_scale1, rblapack_scale2, rblapack_wr1, rblapack_wr2, rblapack_wi);
}

void
init_lapack_slag2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slag2", rblapack_slag2, -1);
}
ruby-lapack-1.7.2/ext/zlansy.c0000644000175000017500000001101012502221016016033 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal zlansy_(char* norm, char* uplo, integer* n, doublecomplex* a, integer* lda, doublereal* work);


static VALUE
rblapack_zlansy(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack___out__;
  doublereal __out__; 
  doublereal *work;

  integer lda;
  integer n;
  integer lwork;

  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  __out__ = NumRu::Lapack.zlansy( norm, uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION ZLANSY( NORM, UPLO, N, A, LDA, WORK )\n\n*  Purpose\n*  =======\n*\n*  ZLANSY  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  complex symmetric matrix A.\n*\n*  Description\n*  ===========\n*\n*  ZLANSY returns the value\n*\n*     ZLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in ZLANSY as described\n*          above.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is to be referenced.\n*          = 'U':  Upper triangular part of A is referenced\n*          = 'L':  Lower triangular part of A is referenced\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, ZLANSY is\n*          set to zero.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          The symmetric matrix A.  If UPLO = 'U', the leading n by n\n*          upper triangular part of A contains the upper triangular part\n*          of the matrix A, and the strictly lower triangular part of A\n*          is not referenced.  If UPLO = 'L', the leading n by n lower\n*          triangular part of A contains the lower triangular part of\n*          the matrix A, and the strictly upper triangular part of A is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(N,1).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n*          WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.zlansy( norm, uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
  work = ALLOC_N(doublereal, (MAX(1,lwork)));

  __out__ = zlansy_(&norm, &uplo, &n, a, &lda, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_zlansy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlansy", rblapack_zlansy, -1);
}
ruby-lapack-1.7.2/ext/dsygs2.c0000644000175000017500000001220312502221014015731 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsygs2_(integer* itype, char* uplo, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, integer* info);


static VALUE
rblapack_dsygs2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;

  integer lda;
  integer n;
  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  info, a = NumRu::Lapack.dsygs2( itype, uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSYGS2 reduces a real symmetric-definite generalized eigenproblem\n*  to standard form.\n*\n*  If ITYPE = 1, the problem is A*x = lambda*B*x,\n*  and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')\n*\n*  If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n*  B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.\n*\n*  B must have been previously factorized as U'*U or L*L' by DPOTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');\n*          = 2 or 3: compute U*A*U' or L'*A*L.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored, and how B has been factorized.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          n by n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n by n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the transformed matrix, stored in the\n*          same format as A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input) DOUBLE PRECISION array, dimension (LDB,N)\n*          The triangular factor from the Cholesky factorization of B,\n*          as returned by DPOTRF.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.dsygs2( itype, uplo, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_itype = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  itype = NUM2INT(rblapack_itype);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  {
    na_shape_t 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__;

  dsygs2_(&itype, &uplo, &n, a, &lda, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_dsygs2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsygs2", rblapack_dsygs2, -1);
}
ruby-lapack-1.7.2/ext/cla_porcond_x.c0000644000175000017500000001464412502221025017345 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real cla_porcond_x_(char* uplo, integer* n, complex* a, integer* lda, complex* af, integer* ldaf, complex* x, integer* info, complex* work, real* rwork);


static VALUE
rblapack_cla_porcond_x(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_rwork;
  real *rwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack___out__;
  real __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  info, __out__ = NumRu::Lapack.cla_porcond_x( uplo, a, af, x, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL FUNCTION CLA_PORCOND_X( UPLO, N, A, LDA, AF, LDAF, X, INFO, WORK, RWORK )\n\n*  Purpose\n*  =======\n*\n*     CLA_PORCOND_X Computes the infinity norm condition number of\n*     op(A) * diag(X) where X is a COMPLEX vector.\n*\n\n*  Arguments\n*  =========\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     A       (input) COMPLEX array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX array, dimension (LDAF,N)\n*     The triangular factor U or L from the Cholesky factorization\n*     A = U**T*U or A = L*L**T, as computed by CPOTRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     X       (input) COMPLEX array, dimension (N)\n*     The vector X in the formula op(A) * diag(X).\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit.\n*     i > 0:  The ith argument is invalid.\n*\n*     WORK    (input) COMPLEX array, dimension (2*N).\n*     Workspace.\n*\n*     RWORK   (input) REAL array, dimension (N).\n*     Workspace.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            KASE, I, J\n      REAL               AINVNM, ANORM, TMP\n      LOGICAL            UP\n      COMPLEX            ZDUM\n*     ..\n*     .. Local Arrays ..\n      INTEGER            ISAVE( 3 )\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CLACN2, CPOTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX, REAL, AIMAG\n*     ..\n*     .. Statement Functions ..\n      REAL CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, __out__ = NumRu::Lapack.cla_porcond_x( uplo, a, af, x, work, rwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_x = argv[3];
  rblapack_work = argv[4];
  rblapack_rwork = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  if (!NA_IsNArray(rblapack_rwork))
    rb_raise(rb_eArgError, "rwork (6th argument) must be NArray");
  if (NA_RANK(rblapack_rwork) != 1)
    rb_raise(rb_eArgError, "rank of rwork (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_rwork) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_rwork) != NA_SFLOAT)
    rblapack_rwork = na_change_type(rblapack_rwork, NA_SFLOAT);
  rwork = NA_PTR_TYPE(rblapack_rwork, real*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (4th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (5th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
  if (NA_TYPE(rblapack_work) != NA_SCOMPLEX)
    rblapack_work = na_change_type(rblapack_work, NA_SCOMPLEX);
  work = NA_PTR_TYPE(rblapack_work, complex*);

  __out__ = cla_porcond_x_(&uplo, &n, a, &lda, af, &ldaf, x, &info, work, rwork);

  rblapack_info = INT2NUM(info);
  rblapack___out__ = rb_float_new((double)__out__);
  return rb_ary_new3(2, rblapack_info, rblapack___out__);
}

void
init_lapack_cla_porcond_x(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cla_porcond_x", rblapack_cla_porcond_x, -1);
}
ruby-lapack-1.7.2/ext/slaqr3.c0000644000175000017500000002647712502221015015746 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaqr3_(logical* wantt, logical* wantz, integer* n, integer* ktop, integer* kbot, integer* nw, real* h, integer* ldh, integer* iloz, integer* ihiz, real* z, integer* ldz, integer* ns, integer* nd, real* sr, real* si, real* v, integer* ldv, integer* nh, real* t, integer* ldt, integer* nv, real* wv, integer* ldwv, real* work, integer* lwork);


static VALUE
rblapack_slaqr3(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantt;
  logical wantt; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_ktop;
  integer ktop; 
  VALUE rblapack_kbot;
  integer kbot; 
  VALUE rblapack_nw;
  integer nw; 
  VALUE rblapack_h;
  real *h; 
  VALUE rblapack_iloz;
  integer iloz; 
  VALUE rblapack_ihiz;
  integer ihiz; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_nh;
  integer nh; 
  VALUE rblapack_nv;
  integer nv; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_ns;
  integer ns; 
  VALUE rblapack_nd;
  integer nd; 
  VALUE rblapack_sr;
  real *sr; 
  VALUE rblapack_si;
  real *si; 
  VALUE rblapack_h_out__;
  real *h_out__;
  VALUE rblapack_z_out__;
  real *z_out__;
  real *v;
  real *t;
  real *wv;
  real *work;

  integer ldh;
  integer n;
  integer ldz;
  integer ldv;
  integer ldt;
  integer ldwv;

  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  ns, nd, sr, si, h, z = NumRu::Lapack.slaqr3( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n*     Aggressive early deflation:\n*\n*     This subroutine accepts as input an upper Hessenberg matrix\n*     H and performs an orthogonal similarity transformation\n*     designed to detect and deflate fully converged eigenvalues from\n*     a trailing principal submatrix.  On output H has been over-\n*     written by a new Hessenberg matrix that is a perturbation of\n*     an orthogonal similarity transformation of H.  It is to be\n*     hoped that the final version of H has many zero subdiagonal\n*     entries.\n*\n*     ******************************************************************\n\n*     WANTT   (input) LOGICAL\n*          If .TRUE., then the Hessenberg matrix H is fully updated\n*          so that the quasi-triangular Schur factor may be\n*          computed (in cooperation with the calling subroutine).\n*          If .FALSE., then only enough of H is updated to preserve\n*          the eigenvalues.\n*\n*     WANTZ   (input) LOGICAL\n*          If .TRUE., then the orthogonal matrix Z is updated so\n*          so that the orthogonal Schur factor may be computed\n*          (in cooperation with the calling subroutine).\n*          If .FALSE., then Z is not referenced.\n*\n*     N       (input) INTEGER\n*          The order of the matrix H and (if WANTZ is .TRUE.) the\n*          order of the orthogonal matrix Z.\n*\n*     KTOP    (input) INTEGER\n*          It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n*          KBOT and KTOP together determine an isolated block\n*          along the diagonal of the Hessenberg matrix.\n*\n*     KBOT    (input) INTEGER\n*          It is assumed without a check that either\n*          KBOT = N or H(KBOT+1,KBOT)=0.  KBOT and KTOP together\n*          determine an isolated block along the diagonal of the\n*          Hessenberg matrix.\n*\n*     NW      (input) INTEGER\n*          Deflation window size.  1 .LE. NW .LE. (KBOT-KTOP+1).\n*\n*     H       (input/output) REAL array, dimension (LDH,N)\n*          On input the initial N-by-N section of H stores the\n*          Hessenberg matrix undergoing aggressive early deflation.\n*          On output H has been transformed by an orthogonal\n*          similarity transformation, perturbed, and the returned\n*          to Hessenberg form that (it is to be hoped) has some\n*          zero subdiagonal entries.\n*\n*     LDH     (input) integer\n*          Leading dimension of H just as declared in the calling\n*          subroutine.  N .LE. LDH\n*\n*     ILOZ    (input) INTEGER\n*     IHIZ    (input) INTEGER\n*          Specify the rows of Z to which transformations must be\n*          applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n*\n*     Z       (input/output) REAL array, dimension (LDZ,N)\n*          IF WANTZ is .TRUE., then on output, the orthogonal\n*          similarity transformation mentioned above has been\n*          accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n*          If WANTZ is .FALSE., then Z is unreferenced.\n*\n*     LDZ     (input) integer\n*          The leading dimension of Z just as declared in the\n*          calling subroutine.  1 .LE. LDZ.\n*\n*     NS      (output) integer\n*          The number of unconverged (ie approximate) eigenvalues\n*          returned in SR and SI that may be used as shifts by the\n*          calling subroutine.\n*\n*     ND      (output) integer\n*          The number of converged eigenvalues uncovered by this\n*          subroutine.\n*\n*     SR      (output) REAL array, dimension KBOT\n*     SI      (output) REAL array, dimension KBOT\n*          On output, the real and imaginary parts of approximate\n*          eigenvalues that may be used for shifts are stored in\n*          SR(KBOT-ND-NS+1) through SR(KBOT-ND) and\n*          SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.\n*          The real and imaginary parts of converged eigenvalues\n*          are stored in SR(KBOT-ND+1) through SR(KBOT) and\n*          SI(KBOT-ND+1) through SI(KBOT), respectively.\n*\n*     V       (workspace) REAL array, dimension (LDV,NW)\n*          An NW-by-NW work array.\n*\n*     LDV     (input) integer scalar\n*          The leading dimension of V just as declared in the\n*          calling subroutine.  NW .LE. LDV\n*\n*     NH      (input) integer scalar\n*          The number of columns of T.  NH.GE.NW.\n*\n*     T       (workspace) REAL array, dimension (LDT,NW)\n*\n*     LDT     (input) integer\n*          The leading dimension of T just as declared in the\n*          calling subroutine.  NW .LE. LDT\n*\n*     NV      (input) integer\n*          The number of rows of work array WV available for\n*          workspace.  NV.GE.NW.\n*\n*     WV      (workspace) REAL array, dimension (LDWV,NW)\n*\n*     LDWV    (input) integer\n*          The leading dimension of W just as declared in the\n*          calling subroutine.  NW .LE. LDV\n*\n*     WORK    (workspace) REAL array, dimension LWORK.\n*          On exit, WORK(1) is set to an estimate of the optimal value\n*          of LWORK for the given values of N, NW, KTOP and KBOT.\n*\n*     LWORK   (input) integer\n*          The dimension of the work array WORK.  LWORK = 2*NW\n*          suffices, but greater efficiency may result from larger\n*          values of LWORK.\n*\n*          If LWORK = -1, then a workspace query is assumed; SLAQR3\n*          only estimates the optimal workspace size for the given\n*          values of N, NW, KTOP and KBOT.  The estimate is returned\n*          in WORK(1).  No error message related to LWORK is issued\n*          by XERBLA.  Neither H nor Z are accessed.\n*\n\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ns, nd, sr, si, h, z = NumRu::Lapack.slaqr3( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 11 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
  rblapack_wantt = argv[0];
  rblapack_wantz = argv[1];
  rblapack_ktop = argv[2];
  rblapack_kbot = argv[3];
  rblapack_nw = argv[4];
  rblapack_h = argv[5];
  rblapack_iloz = argv[6];
  rblapack_ihiz = argv[7];
  rblapack_z = argv[8];
  rblapack_nh = argv[9];
  rblapack_nv = argv[10];
  if (argc == 12) {
    rblapack_lwork = argv[11];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  wantt = (rblapack_wantt == Qtrue);
  ktop = NUM2INT(rblapack_ktop);
  nw = NUM2INT(rblapack_nw);
  iloz = NUM2INT(rblapack_iloz);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (9th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  n = NA_SHAPE1(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  nv = NUM2INT(rblapack_nv);
  ldwv = nw;
  ldv = nw;
  wantz = (rblapack_wantz == Qtrue);
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (6th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  if (NA_SHAPE1(rblapack_h) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of z");
  if (NA_TYPE(rblapack_h) != NA_SFLOAT)
    rblapack_h = na_change_type(rblapack_h, NA_SFLOAT);
  h = NA_PTR_TYPE(rblapack_h, real*);
  nh = NUM2INT(rblapack_nh);
  ldt = nw;
  kbot = NUM2INT(rblapack_kbot);
  if (rblapack_lwork == Qnil)
    lwork = 2*nw;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ihiz = NUM2INT(rblapack_ihiz);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,kbot);
    rblapack_sr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  sr = NA_PTR_TYPE(rblapack_sr, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,kbot);
    rblapack_si = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  si = NA_PTR_TYPE(rblapack_si, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, real*);
  MEMCPY(h_out__, h, real, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
  MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  v = ALLOC_N(real, (ldv)*(MAX(1,nw)));
  t = ALLOC_N(real, (ldt)*(MAX(1,nw)));
  wv = ALLOC_N(real, (ldwv)*(MAX(1,nw)));
  work = ALLOC_N(real, (MAX(1,lwork)));

  slaqr3_(&wantt, &wantz, &n, &ktop, &kbot, &nw, h, &ldh, &iloz, &ihiz, z, &ldz, &ns, &nd, sr, si, v, &ldv, &nh, t, &ldt, &nv, wv, &ldwv, work, &lwork);

  free(v);
  free(t);
  free(wv);
  free(work);
  rblapack_ns = INT2NUM(ns);
  rblapack_nd = INT2NUM(nd);
  return rb_ary_new3(6, rblapack_ns, rblapack_nd, rblapack_sr, rblapack_si, rblapack_h, rblapack_z);
}

void
init_lapack_slaqr3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaqr3", rblapack_slaqr3, -1);
}
ruby-lapack-1.7.2/ext/ztrsna.c0000644000175000017500000002455512502221015016055 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztrsna_(char* job, char* howmny, logical* select, integer* n, doublecomplex* t, integer* ldt, doublecomplex* vl, integer* ldvl, doublecomplex* vr, integer* ldvr, doublereal* s, doublereal* sep, integer* mm, integer* m, doublecomplex* work, integer* ldwork, doublereal* rwork, integer* info);


static VALUE
rblapack_ztrsna(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_howmny;
  char howmny; 
  VALUE rblapack_select;
  logical *select; 
  VALUE rblapack_t;
  doublecomplex *t; 
  VALUE rblapack_vl;
  doublecomplex *vl; 
  VALUE rblapack_vr;
  doublecomplex *vr; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_sep;
  doublereal *sep; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_info;
  integer info; 
  doublecomplex *work;
  doublereal *rwork;

  integer n;
  integer ldt;
  integer ldvl;
  integer ldvr;
  integer mm;
  integer ldwork;

  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  s, sep, m, info = NumRu::Lapack.ztrsna( job, howmny, select, t, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTRSNA estimates reciprocal condition numbers for specified\n*  eigenvalues and/or right eigenvectors of a complex upper triangular\n*  matrix T (or of any matrix Q*T*Q**H with Q unitary).\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies whether condition numbers are required for\n*          eigenvalues (S) or eigenvectors (SEP):\n*          = 'E': for eigenvalues only (S);\n*          = 'V': for eigenvectors only (SEP);\n*          = 'B': for both eigenvalues and eigenvectors (S and SEP).\n*\n*  HOWMNY  (input) CHARACTER*1\n*          = 'A': compute condition numbers for all eigenpairs;\n*          = 'S': compute condition numbers for selected eigenpairs\n*                 specified by the array SELECT.\n*\n*  SELECT  (input) LOGICAL array, dimension (N)\n*          If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n*          condition numbers are required. To select condition numbers\n*          for the j-th eigenpair, SELECT(j) must be set to .TRUE..\n*          If HOWMNY = 'A', SELECT is not referenced.\n*\n*  N       (input) INTEGER\n*          The order of the matrix T. N >= 0.\n*\n*  T       (input) COMPLEX*16 array, dimension (LDT,N)\n*          The upper triangular matrix T.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= max(1,N).\n*\n*  VL      (input) COMPLEX*16 array, dimension (LDVL,M)\n*          If JOB = 'E' or 'B', VL must contain left eigenvectors of T\n*          (or of any Q*T*Q**H with Q unitary), corresponding to the\n*          eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n*          must be stored in consecutive columns of VL, as returned by\n*          ZHSEIN or ZTREVC.\n*          If JOB = 'V', VL is not referenced.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the array VL.\n*          LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.\n*\n*  VR      (input) COMPLEX*16 array, dimension (LDVR,M)\n*          If JOB = 'E' or 'B', VR must contain right eigenvectors of T\n*          (or of any Q*T*Q**H with Q unitary), corresponding to the\n*          eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n*          must be stored in consecutive columns of VR, as returned by\n*          ZHSEIN or ZTREVC.\n*          If JOB = 'V', VR is not referenced.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the array VR.\n*          LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.\n*\n*  S       (output) DOUBLE PRECISION array, dimension (MM)\n*          If JOB = 'E' or 'B', the reciprocal condition numbers of the\n*          selected eigenvalues, stored in consecutive elements of the\n*          array. Thus S(j), SEP(j), and the j-th columns of VL and VR\n*          all correspond to the same eigenpair (but not in general the\n*          j-th eigenpair, unless all eigenpairs are selected).\n*          If JOB = 'V', S is not referenced.\n*\n*  SEP     (output) DOUBLE PRECISION array, dimension (MM)\n*          If JOB = 'V' or 'B', the estimated reciprocal condition\n*          numbers of the selected eigenvectors, stored in consecutive\n*          elements of the array.\n*          If JOB = 'E', SEP is not referenced.\n*\n*  MM      (input) INTEGER\n*          The number of elements in the arrays S (if JOB = 'E' or 'B')\n*           and/or SEP (if JOB = 'V' or 'B'). MM >= M.\n*\n*  M       (output) INTEGER\n*          The number of elements of the arrays S and/or SEP actually\n*          used to store the estimated condition numbers.\n*          If HOWMNY = 'A', M is set to N.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (LDWORK,N+6)\n*          If JOB = 'E', WORK is not referenced.\n*\n*  LDWORK  (input) INTEGER\n*          The leading dimension of the array WORK.\n*          LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\n*          If JOB = 'E', RWORK is not referenced.\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 reciprocal of the condition number of an eigenvalue lambda is\n*  defined as\n*\n*          S(lambda) = |v'*u| / (norm(u)*norm(v))\n*\n*  where u and v are the right and left eigenvectors of T corresponding\n*  to lambda; v' denotes the conjugate transpose of v, and norm(u)\n*  denotes the Euclidean norm. These reciprocal condition numbers always\n*  lie between zero (very badly conditioned) and one (very well\n*  conditioned). If n = 1, S(lambda) is defined to be 1.\n*\n*  An approximate error bound for a computed eigenvalue W(i) is given by\n*\n*                      EPS * norm(T) / S(i)\n*\n*  where EPS is the machine precision.\n*\n*  The reciprocal of the condition number of the right eigenvector u\n*  corresponding to lambda is defined as follows. Suppose\n*\n*              T = ( lambda  c  )\n*                  (   0    T22 )\n*\n*  Then the reciprocal condition number is\n*\n*          SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )\n*\n*  where sigma-min denotes the smallest singular value. We approximate\n*  the smallest singular value by the reciprocal of an estimate of the\n*  one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is\n*  defined to be abs(T(1,1)).\n*\n*  An approximate error bound for a computed right eigenvector VR(i)\n*  is given by\n*\n*                      EPS * norm(T) / SEP(i)\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, sep, m, info = NumRu::Lapack.ztrsna( job, howmny, select, t, vl, vr, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_job = argv[0];
  rblapack_howmny = argv[1];
  rblapack_select = argv[2];
  rblapack_t = argv[3];
  rblapack_vl = argv[4];
  rblapack_vr = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  job = StringValueCStr(rblapack_job)[0];
  if (!NA_IsNArray(rblapack_select))
    rb_raise(rb_eArgError, "select (3th argument) must be NArray");
  if (NA_RANK(rblapack_select) != 1)
    rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_select);
  if (NA_TYPE(rblapack_select) != NA_LINT)
    rblapack_select = na_change_type(rblapack_select, NA_LINT);
  select = NA_PTR_TYPE(rblapack_select, logical*);
  if (!NA_IsNArray(rblapack_vl))
    rb_raise(rb_eArgError, "vl (5th argument) must be NArray");
  if (NA_RANK(rblapack_vl) != 2)
    rb_raise(rb_eArgError, "rank of vl (5th argument) must be %d", 2);
  ldvl = NA_SHAPE0(rblapack_vl);
  m = NA_SHAPE1(rblapack_vl);
  if (NA_TYPE(rblapack_vl) != NA_DCOMPLEX)
    rblapack_vl = na_change_type(rblapack_vl, NA_DCOMPLEX);
  vl = NA_PTR_TYPE(rblapack_vl, doublecomplex*);
  howmny = StringValueCStr(rblapack_howmny)[0];
  if (!NA_IsNArray(rblapack_vr))
    rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
  if (NA_RANK(rblapack_vr) != 2)
    rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 2);
  ldvr = NA_SHAPE0(rblapack_vr);
  if (NA_SHAPE1(rblapack_vr) != m)
    rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
  if (NA_TYPE(rblapack_vr) != NA_DCOMPLEX)
    rblapack_vr = na_change_type(rblapack_vr, NA_DCOMPLEX);
  vr = NA_PTR_TYPE(rblapack_vr, doublecomplex*);
  mm = m;
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (4th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  if (NA_SHAPE1(rblapack_t) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_t) != NA_DCOMPLEX)
    rblapack_t = na_change_type(rblapack_t, NA_DCOMPLEX);
  t = NA_PTR_TYPE(rblapack_t, doublecomplex*);
  ldwork = ((lsame_(&job,"V")) || (lsame_(&job,"B"))) ? n : 1;
  {
    na_shape_t shape[1];
    shape[0] = mm;
    rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = mm;
    rblapack_sep = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  sep = NA_PTR_TYPE(rblapack_sep, doublereal*);
  work = ALLOC_N(doublecomplex, (lsame_(&job,"E") ? 0 : ldwork)*(lsame_(&job,"E") ? 0 : n+6));
  rwork = ALLOC_N(doublereal, (lsame_(&job,"E") ? 0 : n));

  ztrsna_(&job, &howmny, select, &n, t, &ldt, vl, &ldvl, vr, &ldvr, s, sep, &mm, &m, work, &ldwork, rwork, &info);

  free(work);
  free(rwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_s, rblapack_sep, rblapack_m, rblapack_info);
}

void
init_lapack_ztrsna(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztrsna", rblapack_ztrsna, -1);
}
ruby-lapack-1.7.2/ext/cggsvp.c0000644000175000017500000002345612502221015016024 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cggsvp_(char* jobu, char* jobv, char* jobq, integer* m, integer* p, integer* n, complex* a, integer* lda, complex* b, integer* ldb, real* tola, real* tolb, integer* k, integer* l, complex* u, integer* ldu, complex* v, integer* ldv, complex* q, integer* ldq, integer* iwork, real* rwork, complex* tau, complex* work, integer* info);


static VALUE
rblapack_cggsvp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobu;
  char jobu; 
  VALUE rblapack_jobv;
  char jobv; 
  VALUE rblapack_jobq;
  char jobq; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_tola;
  real tola; 
  VALUE rblapack_tolb;
  real tolb; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_u;
  complex *u; 
  VALUE rblapack_v;
  complex *v; 
  VALUE rblapack_q;
  complex *q; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;
  integer *iwork;
  real *rwork;
  complex *tau;
  complex *work;

  integer lda;
  integer n;
  integer ldb;
  integer ldu;
  integer m;
  integer ldv;
  integer p;
  integer ldq;

  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  k, l, u, v, q, info, a, b = NumRu::Lapack.cggsvp( jobu, jobv, jobq, a, b, tola, tolb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, RWORK, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGGSVP computes unitary matrices U, V and Q such that\n*\n*                   N-K-L  K    L\n*   U'*A*Q =     K ( 0    A12  A13 )  if M-K-L >= 0;\n*                L ( 0     0   A23 )\n*            M-K-L ( 0     0    0  )\n*\n*                   N-K-L  K    L\n*          =     K ( 0    A12  A13 )  if M-K-L < 0;\n*              M-K ( 0     0   A23 )\n*\n*                 N-K-L  K    L\n*   V'*B*Q =   L ( 0     0   B13 )\n*            P-L ( 0     0    0  )\n*\n*  where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n*  upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n*  otherwise A23 is (M-K)-by-L upper trapezoidal.  K+L = the effective\n*  numerical rank of the (M+P)-by-N matrix (A',B')'.  Z' denotes the\n*  conjugate transpose of Z.\n*\n*  This decomposition is the preprocessing step for computing the\n*  Generalized Singular Value Decomposition (GSVD), see subroutine\n*  CGGSVD.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBU    (input) CHARACTER*1\n*          = 'U':  Unitary matrix U is computed;\n*          = 'N':  U is not computed.\n*\n*  JOBV    (input) CHARACTER*1\n*          = 'V':  Unitary matrix V is computed;\n*          = 'N':  V is not computed.\n*\n*  JOBQ    (input) CHARACTER*1\n*          = 'Q':  Unitary matrix Q is computed;\n*          = 'N':  Q is not computed.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.  M >= 0.\n*\n*  P       (input) INTEGER\n*          The number of rows of the matrix B.  P >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrices A and B.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, A contains the triangular (or trapezoidal) matrix\n*          described in the Purpose section.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,N)\n*          On entry, the P-by-N matrix B.\n*          On exit, B contains the triangular matrix described in\n*          the Purpose section.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,P).\n*\n*  TOLA    (input) REAL\n*  TOLB    (input) REAL\n*          TOLA and TOLB are the thresholds to determine the effective\n*          numerical rank of matrix B and a subblock of A. Generally,\n*          they are set to\n*             TOLA = MAX(M,N)*norm(A)*MACHEPS,\n*             TOLB = MAX(P,N)*norm(B)*MACHEPS.\n*          The size of TOLA and TOLB may affect the size of backward\n*          errors of the decomposition.\n*\n*  K       (output) INTEGER\n*  L       (output) INTEGER\n*          On exit, K and L specify the dimension of the subblocks\n*          described in Purpose section.\n*          K + L = effective numerical rank of (A',B')'.\n*\n*  U       (output) COMPLEX array, dimension (LDU,M)\n*          If JOBU = 'U', U contains the unitary matrix U.\n*          If JOBU = 'N', U is not referenced.\n*\n*  LDU     (input) INTEGER\n*          The leading dimension of the array U. LDU >= max(1,M) if\n*          JOBU = 'U'; LDU >= 1 otherwise.\n*\n*  V       (output) COMPLEX array, dimension (LDV,P)\n*          If JOBV = 'V', V contains the unitary matrix V.\n*          If JOBV = 'N', V is not referenced.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V. LDV >= max(1,P) if\n*          JOBV = 'V'; LDV >= 1 otherwise.\n*\n*  Q       (output) COMPLEX array, dimension (LDQ,N)\n*          If JOBQ = 'Q', Q contains the unitary matrix Q.\n*          If JOBQ = 'N', Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q. LDQ >= max(1,N) if\n*          JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\n*\n*  RWORK   (workspace) REAL array, dimension (2*N)\n*\n*  TAU     (workspace) COMPLEX array, dimension (N)\n*\n*  WORK    (workspace) COMPLEX array, dimension (max(3*N,M,P))\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 subroutine uses LAPACK subroutine CGEQPF for the QR factorization\n*  with column pivoting to detect the effective numerical rank of the\n*  a matrix. It may be replaced by a better rank determination strategy.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  k, l, u, v, q, info, a, b = NumRu::Lapack.cggsvp( jobu, jobv, jobq, a, b, tola, tolb, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_jobu = argv[0];
  rblapack_jobv = argv[1];
  rblapack_jobq = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  rblapack_tola = argv[5];
  rblapack_tolb = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobu = StringValueCStr(rblapack_jobu)[0];
  jobq = StringValueCStr(rblapack_jobq)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  tolb = (real)NUM2DBL(rblapack_tolb);
  p = ldb;
  jobv = StringValueCStr(rblapack_jobv)[0];
  tola = (real)NUM2DBL(rblapack_tola);
  ldv = lsame_(&jobv,"V") ? MAX(1,p) : 1;
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  ldq = lsame_(&jobq,"Q") ? MAX(1,n) : 1;
  m = lda;
  ldu = lsame_(&jobu,"U") ? MAX(1,m) : 1;
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = m;
    rblapack_u = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  u = NA_PTR_TYPE(rblapack_u, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = p;
    rblapack_v = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  v = NA_PTR_TYPE(rblapack_v, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  q = NA_PTR_TYPE(rblapack_q, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  iwork = ALLOC_N(integer, (n));
  rwork = ALLOC_N(real, (2*n));
  tau = ALLOC_N(complex, (n));
  work = ALLOC_N(complex, (MAX(3*n,m)*(p)));

  cggsvp_(&jobu, &jobv, &jobq, &m, &p, &n, a, &lda, b, &ldb, &tola, &tolb, &k, &l, u, &ldu, v, &ldv, q, &ldq, iwork, rwork, tau, work, &info);

  free(iwork);
  free(rwork);
  free(tau);
  free(work);
  rblapack_k = INT2NUM(k);
  rblapack_l = INT2NUM(l);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_k, rblapack_l, rblapack_u, rblapack_v, rblapack_q, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_cggsvp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cggsvp", rblapack_cggsvp, -1);
}
ruby-lapack-1.7.2/ext/sgesc2.c0000644000175000017500000001246612502221012015715 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgesc2_(integer* n, real* a, integer* lda, real* rhs, integer* ipiv, integer* jpiv, real* scale);


static VALUE
rblapack_sgesc2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_rhs;
  real *rhs; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_jpiv;
  integer *jpiv; 
  VALUE rblapack_scale;
  real scale; 
  VALUE rblapack_rhs_out__;
  real *rhs_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  scale, rhs = NumRu::Lapack.sgesc2( a, rhs, ipiv, jpiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )\n\n*  Purpose\n*  =======\n*\n*  SGESC2 solves a system of linear equations\n*\n*            A * X = scale* RHS\n*\n*  with a general N-by-N matrix A using the LU factorization with\n*  complete pivoting computed by SGETC2.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.\n*\n*  A       (input) REAL array, dimension (LDA,N)\n*          On entry, the  LU part of the factorization of the n-by-n\n*          matrix A computed by SGETC2:  A = P * L * U * Q\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1, N).\n*\n*  RHS     (input/output) REAL array, dimension (N).\n*          On entry, the right hand side vector b.\n*          On exit, the solution vector X.\n*\n*  IPIV    (input) INTEGER array, dimension (N).\n*          The pivot indices; for 1 <= i <= N, row i of the\n*          matrix has been interchanged with row IPIV(i).\n*\n*  JPIV    (input) INTEGER array, dimension (N).\n*          The pivot indices; for 1 <= j <= N, column j of the\n*          matrix has been interchanged with column JPIV(j).\n*\n*  SCALE    (output) REAL\n*           On exit, SCALE contains the scale factor. SCALE is chosen\n*           0 <= SCALE <= 1 to prevent owerflow in the solution.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, rhs = NumRu::Lapack.sgesc2( a, rhs, ipiv, jpiv, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_a = argv[0];
  rblapack_rhs = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_jpiv = argv[3];
  if (argc == 4) {
  } 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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_rhs))
    rb_raise(rb_eArgError, "rhs (2th argument) must be NArray");
  if (NA_RANK(rblapack_rhs) != 1)
    rb_raise(rb_eArgError, "rank of rhs (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_rhs) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of rhs must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_rhs) != NA_SFLOAT)
    rblapack_rhs = na_change_type(rblapack_rhs, NA_SFLOAT);
  rhs = NA_PTR_TYPE(rblapack_rhs, real*);
  if (!NA_IsNArray(rblapack_jpiv))
    rb_raise(rb_eArgError, "jpiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_jpiv) != 1)
    rb_raise(rb_eArgError, "rank of jpiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_jpiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of jpiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_jpiv) != NA_LINT)
    rblapack_jpiv = na_change_type(rblapack_jpiv, NA_LINT);
  jpiv = NA_PTR_TYPE(rblapack_jpiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rhs_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  rhs_out__ = NA_PTR_TYPE(rblapack_rhs_out__, real*);
  MEMCPY(rhs_out__, rhs, real, NA_TOTAL(rblapack_rhs));
  rblapack_rhs = rblapack_rhs_out__;
  rhs = rhs_out__;

  sgesc2_(&n, a, &lda, rhs, ipiv, jpiv, &scale);

  rblapack_scale = rb_float_new((double)scale);
  return rb_ary_new3(2, rblapack_scale, rblapack_rhs);
}

void
init_lapack_sgesc2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgesc2", rblapack_sgesc2, -1);
}
ruby-lapack-1.7.2/ext/dtgsja.c0000644000175000017500000004002012502221014015770 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtgsja_(char* jobu, char* jobv, char* jobq, integer* m, integer* p, integer* n, integer* k, integer* l, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* tola, doublereal* tolb, doublereal* alpha, doublereal* beta, doublereal* u, integer* ldu, doublereal* v, integer* ldv, doublereal* q, integer* ldq, doublereal* work, integer* ncycle, integer* info);


static VALUE
rblapack_dtgsja(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobu;
  char jobu; 
  VALUE rblapack_jobv;
  char jobv; 
  VALUE rblapack_jobq;
  char jobq; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_tola;
  doublereal tola; 
  VALUE rblapack_tolb;
  doublereal tolb; 
  VALUE rblapack_u;
  doublereal *u; 
  VALUE rblapack_v;
  doublereal *v; 
  VALUE rblapack_q;
  doublereal *q; 
  VALUE rblapack_alpha;
  doublereal *alpha; 
  VALUE rblapack_beta;
  doublereal *beta; 
  VALUE rblapack_ncycle;
  integer ncycle; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;
  VALUE rblapack_u_out__;
  doublereal *u_out__;
  VALUE rblapack_v_out__;
  doublereal *v_out__;
  VALUE rblapack_q_out__;
  doublereal *q_out__;
  doublereal *work;

  integer lda;
  integer n;
  integer ldb;
  integer ldu;
  integer m;
  integer ldv;
  integer p;
  integer ldq;

  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  alpha, beta, ncycle, info, a, b, u, v, q = NumRu::Lapack.dtgsja( jobu, jobv, jobq, k, l, a, b, tola, tolb, u, v, q, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, NCYCLE, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTGSJA computes the generalized singular value decomposition (GSVD)\n*  of two real upper triangular (or trapezoidal) matrices A and B.\n*\n*  On entry, it is assumed that matrices A and B have the following\n*  forms, which may be obtained by the preprocessing subroutine DGGSVP\n*  from a general M-by-N matrix A and P-by-N matrix B:\n*\n*               N-K-L  K    L\n*     A =    K ( 0    A12  A13 ) if M-K-L >= 0;\n*            L ( 0     0   A23 )\n*        M-K-L ( 0     0    0  )\n*\n*             N-K-L  K    L\n*     A =  K ( 0    A12  A13 ) if M-K-L < 0;\n*        M-K ( 0     0   A23 )\n*\n*             N-K-L  K    L\n*     B =  L ( 0     0   B13 )\n*        P-L ( 0     0    0  )\n*\n*  where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n*  upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n*  otherwise A23 is (M-K)-by-L upper trapezoidal.\n*\n*  On exit,\n*\n*              U'*A*Q = D1*( 0 R ),    V'*B*Q = D2*( 0 R ),\n*\n*  where U, V and Q are orthogonal matrices, Z' denotes the transpose\n*  of Z, R is a nonsingular upper triangular matrix, and D1 and D2 are\n*  ``diagonal'' matrices, which are of the following structures:\n*\n*  If M-K-L >= 0,\n*\n*                      K  L\n*         D1 =     K ( I  0 )\n*                  L ( 0  C )\n*              M-K-L ( 0  0 )\n*\n*                    K  L\n*         D2 = L   ( 0  S )\n*              P-L ( 0  0 )\n*\n*                 N-K-L  K    L\n*    ( 0 R ) = K (  0   R11  R12 ) K\n*              L (  0    0   R22 ) L\n*\n*  where\n*\n*    C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n*    S = diag( BETA(K+1),  ... , BETA(K+L) ),\n*    C**2 + S**2 = I.\n*\n*    R is stored in A(1:K+L,N-K-L+1:N) on exit.\n*\n*  If M-K-L < 0,\n*\n*                 K M-K K+L-M\n*      D1 =   K ( I  0    0   )\n*           M-K ( 0  C    0   )\n*\n*                   K M-K K+L-M\n*      D2 =   M-K ( 0  S    0   )\n*           K+L-M ( 0  0    I   )\n*             P-L ( 0  0    0   )\n*\n*                 N-K-L  K   M-K  K+L-M\n* ( 0 R ) =    K ( 0    R11  R12  R13  )\n*            M-K ( 0     0   R22  R23  )\n*          K+L-M ( 0     0    0   R33  )\n*\n*  where\n*  C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n*  S = diag( BETA(K+1),  ... , BETA(M) ),\n*  C**2 + S**2 = I.\n*\n*  R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored\n*      (  0  R22 R23 )\n*  in B(M-K+1:L,N+M-K-L+1:N) on exit.\n*\n*  The computation of the orthogonal transformation matrices U, V or Q\n*  is optional.  These matrices may either be formed explicitly, or they\n*  may be postmultiplied into input matrices U1, V1, or Q1.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBU    (input) CHARACTER*1\n*          = 'U':  U must contain an orthogonal matrix U1 on entry, and\n*                  the product U1*U is returned;\n*          = 'I':  U is initialized to the unit matrix, and the\n*                  orthogonal matrix U is returned;\n*          = 'N':  U is not computed.\n*\n*  JOBV    (input) CHARACTER*1\n*          = 'V':  V must contain an orthogonal matrix V1 on entry, and\n*                  the product V1*V is returned;\n*          = 'I':  V is initialized to the unit matrix, and the\n*                  orthogonal matrix V is returned;\n*          = 'N':  V is not computed.\n*\n*  JOBQ    (input) CHARACTER*1\n*          = 'Q':  Q must contain an orthogonal matrix Q1 on entry, and\n*                  the product Q1*Q is returned;\n*          = 'I':  Q is initialized to the unit matrix, and the\n*                  orthogonal matrix Q is returned;\n*          = 'N':  Q is not computed.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.  M >= 0.\n*\n*  P       (input) INTEGER\n*          The number of rows of the matrix B.  P >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrices A and B.  N >= 0.\n*\n*  K       (input) INTEGER\n*  L       (input) INTEGER\n*          K and L specify the subblocks in the input matrices A and B:\n*          A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,N-L+1:N)\n*          of A and B, whose GSVD is going to be computed by DTGSJA.\n*          See Further Details.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular\n*          matrix R or part of R.  See Purpose for details.\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,N)\n*          On entry, the P-by-N matrix B.\n*          On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains\n*          a part of R.  See Purpose for details.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,P).\n*\n*  TOLA    (input) DOUBLE PRECISION\n*  TOLB    (input) DOUBLE PRECISION\n*          TOLA and TOLB are the convergence criteria for the Jacobi-\n*          Kogbetliantz iteration procedure. Generally, they are the\n*          same as used in the preprocessing step, say\n*              TOLA = max(M,N)*norm(A)*MAZHEPS,\n*              TOLB = max(P,N)*norm(B)*MAZHEPS.\n*\n*  ALPHA   (output) DOUBLE PRECISION array, dimension (N)\n*  BETA    (output) DOUBLE PRECISION array, dimension (N)\n*          On exit, ALPHA and BETA contain the generalized singular\n*          value pairs of A and B;\n*            ALPHA(1:K) = 1,\n*            BETA(1:K)  = 0,\n*          and if M-K-L >= 0,\n*            ALPHA(K+1:K+L) = diag(C),\n*            BETA(K+1:K+L)  = diag(S),\n*          or if M-K-L < 0,\n*            ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0\n*            BETA(K+1:M) = S, BETA(M+1:K+L) = 1.\n*          Furthermore, if K+L < N,\n*            ALPHA(K+L+1:N) = 0 and\n*            BETA(K+L+1:N)  = 0.\n*\n*  U       (input/output) DOUBLE PRECISION array, dimension (LDU,M)\n*          On entry, if JOBU = 'U', U must contain a matrix U1 (usually\n*          the orthogonal matrix returned by DGGSVP).\n*          On exit,\n*          if JOBU = 'I', U contains the orthogonal matrix U;\n*          if JOBU = 'U', U contains the product U1*U.\n*          If JOBU = 'N', U is not referenced.\n*\n*  LDU     (input) INTEGER\n*          The leading dimension of the array U. LDU >= max(1,M) if\n*          JOBU = 'U'; LDU >= 1 otherwise.\n*\n*  V       (input/output) DOUBLE PRECISION array, dimension (LDV,P)\n*          On entry, if JOBV = 'V', V must contain a matrix V1 (usually\n*          the orthogonal matrix returned by DGGSVP).\n*          On exit,\n*          if JOBV = 'I', V contains the orthogonal matrix V;\n*          if JOBV = 'V', V contains the product V1*V.\n*          If JOBV = 'N', V is not referenced.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V. LDV >= max(1,P) if\n*          JOBV = 'V'; LDV >= 1 otherwise.\n*\n*  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n*          On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually\n*          the orthogonal matrix returned by DGGSVP).\n*          On exit,\n*          if JOBQ = 'I', Q contains the orthogonal matrix Q;\n*          if JOBQ = 'Q', Q contains the product Q1*Q.\n*          If JOBQ = 'N', Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q. LDQ >= max(1,N) if\n*          JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n*  NCYCLE  (output) INTEGER\n*          The number of cycles required for convergence.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          = 1:  the procedure does not converge after MAXIT cycles.\n*\n*  Internal Parameters\n*  ===================\n*\n*  MAXIT   INTEGER\n*          MAXIT specifies the total loops that the iterative procedure\n*          may take. If after MAXIT cycles, the routine fails to\n*          converge, we return INFO = 1.\n*\n\n*  Further Details\n*  ===============\n*\n*  DTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce\n*  min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L\n*  matrix B13 to the form:\n*\n*           U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1,\n*\n*  where U1, V1 and Q1 are orthogonal matrix, and Z' is the transpose\n*  of Z.  C1 and S1 are diagonal matrices satisfying\n*\n*                C1**2 + S1**2 = I,\n*\n*  and R1 is an L-by-L nonsingular upper triangular matrix.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  alpha, beta, ncycle, info, a, b, u, v, q = NumRu::Lapack.dtgsja( jobu, jobv, jobq, k, l, a, b, tola, tolb, u, v, q, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_jobu = argv[0];
  rblapack_jobv = argv[1];
  rblapack_jobq = argv[2];
  rblapack_k = argv[3];
  rblapack_l = argv[4];
  rblapack_a = argv[5];
  rblapack_b = argv[6];
  rblapack_tola = argv[7];
  rblapack_tolb = argv[8];
  rblapack_u = argv[9];
  rblapack_v = argv[10];
  rblapack_q = argv[11];
  if (argc == 12) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobu = StringValueCStr(rblapack_jobu)[0];
  jobq = StringValueCStr(rblapack_jobq)[0];
  l = NUM2INT(rblapack_l);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = 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*);
  tolb = NUM2DBL(rblapack_tolb);
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (11th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (11th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  p = NA_SHAPE1(rblapack_v);
  if (NA_TYPE(rblapack_v) != NA_DFLOAT)
    rblapack_v = na_change_type(rblapack_v, NA_DFLOAT);
  v = NA_PTR_TYPE(rblapack_v, doublereal*);
  jobv = StringValueCStr(rblapack_jobv)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (6th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (6th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  if (!NA_IsNArray(rblapack_u))
    rb_raise(rb_eArgError, "u (10th argument) must be NArray");
  if (NA_RANK(rblapack_u) != 2)
    rb_raise(rb_eArgError, "rank of u (10th argument) must be %d", 2);
  ldu = NA_SHAPE0(rblapack_u);
  m = NA_SHAPE1(rblapack_u);
  if (NA_TYPE(rblapack_u) != NA_DFLOAT)
    rblapack_u = na_change_type(rblapack_u, NA_DFLOAT);
  u = NA_PTR_TYPE(rblapack_u, doublereal*);
  k = NUM2INT(rblapack_k);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (12th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (12th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_q) != NA_DFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
  q = NA_PTR_TYPE(rblapack_q, doublereal*);
  tola = NUM2DBL(rblapack_tola);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alpha = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  alpha = NA_PTR_TYPE(rblapack_alpha, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, doublereal*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = m;
    rblapack_u_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  u_out__ = NA_PTR_TYPE(rblapack_u_out__, doublereal*);
  MEMCPY(u_out__, u, doublereal, NA_TOTAL(rblapack_u));
  rblapack_u = rblapack_u_out__;
  u = u_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = p;
    rblapack_v_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  v_out__ = NA_PTR_TYPE(rblapack_v_out__, doublereal*);
  MEMCPY(v_out__, v, doublereal, NA_TOTAL(rblapack_v));
  rblapack_v = rblapack_v_out__;
  v = v_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
  MEMCPY(q_out__, q, doublereal, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  work = ALLOC_N(doublereal, (2*n));

  dtgsja_(&jobu, &jobv, &jobq, &m, &p, &n, &k, &l, a, &lda, b, &ldb, &tola, &tolb, alpha, beta, u, &ldu, v, &ldv, q, &ldq, work, &ncycle, &info);

  free(work);
  rblapack_ncycle = INT2NUM(ncycle);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_alpha, rblapack_beta, rblapack_ncycle, rblapack_info, rblapack_a, rblapack_b, rblapack_u, rblapack_v, rblapack_q);
}

void
init_lapack_dtgsja(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtgsja", rblapack_dtgsja, -1);
}
ruby-lapack-1.7.2/ext/cpocon.c0000644000175000017500000000762312502221012016007 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cpocon_(char* uplo, integer* n, complex* a, integer* lda, real* anorm, real* rcond, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cpocon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_anorm;
  real anorm; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_info;
  integer info; 
  complex *work;
  real *rwork;

  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  rcond, info = NumRu::Lapack.cpocon( uplo, a, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPOCON estimates the reciprocal of the condition number (in the\n*  1-norm) of a complex Hermitian positive definite matrix using the\n*  Cholesky factorization A = U**H*U or A = L*L**H computed by CPOTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**H*U or A = L*L**H, as computed by CPOTRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  ANORM   (input) REAL\n*          The 1-norm (or infinity-norm) of the Hermitian matrix A.\n*\n*  RCOND   (output) REAL\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n*          estimate of the 1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.cpocon( uplo, a, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_anorm = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  anorm = (real)NUM2DBL(rblapack_anorm);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (n));

  cpocon_(&uplo, &n, a, &lda, &anorm, &rcond, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_cpocon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cpocon", rblapack_cpocon, -1);
}
ruby-lapack-1.7.2/ext/clalsd.c0000644000175000017500000002076512502221025015776 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clalsd_(char* uplo, integer* smlsiz, integer* n, integer* nrhs, real* d, real* e, complex* b, integer* ldb, real* rcond, integer* rank, complex* work, real* rwork, integer* iwork, integer* info);


static VALUE
rblapack_clalsd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_smlsiz;
  integer smlsiz; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_rank;
  integer rank; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_e_out__;
  real *e_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;
  integer nlvl;
  complex *work;
  real *rwork;
  integer *iwork;

  integer n;
  integer ldb;
  integer nrhs;

  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  rank, info, d, e, b = NumRu::Lapack.clalsd( uplo, smlsiz, d, e, b, rcond, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, RANK, WORK, RWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CLALSD uses the singular value decomposition of A to solve the least\n*  squares problem of finding X to minimize the Euclidean norm of each\n*  column of A*X-B, where A is N-by-N upper bidiagonal, and X and B\n*  are N-by-NRHS. The solution X overwrites B.\n*\n*  The singular values of A smaller than RCOND times the largest\n*  singular value are treated as zero in solving the least squares\n*  problem; in this case a minimum norm solution is returned.\n*  The actual singular values are returned in D in ascending order.\n*\n*  This code makes very mild assumptions about floating point\n*  arithmetic. It will work on machines with a guard digit in\n*  add/subtract, or on those binary machines without guard digits\n*  which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.\n*  It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO   (input) CHARACTER*1\n*         = 'U': D and E define an upper bidiagonal matrix.\n*         = 'L': D and E define a  lower bidiagonal matrix.\n*\n*  SMLSIZ (input) INTEGER\n*         The maximum size of the subproblems at the bottom of the\n*         computation tree.\n*\n*  N      (input) INTEGER\n*         The dimension of the  bidiagonal matrix.  N >= 0.\n*\n*  NRHS   (input) INTEGER\n*         The number of columns of B. NRHS must be at least 1.\n*\n*  D      (input/output) REAL array, dimension (N)\n*         On entry D contains the main diagonal of the bidiagonal\n*         matrix. On exit, if INFO = 0, D contains its singular values.\n*\n*  E      (input/output) REAL array, dimension (N-1)\n*         Contains the super-diagonal entries of the bidiagonal matrix.\n*         On exit, E has been destroyed.\n*\n*  B      (input/output) COMPLEX array, dimension (LDB,NRHS)\n*         On input, B contains the right hand sides of the least\n*         squares problem. On output, B contains the solution X.\n*\n*  LDB    (input) INTEGER\n*         The leading dimension of B in the calling subprogram.\n*         LDB must be at least max(1,N).\n*\n*  RCOND  (input) REAL\n*         The singular values of A less than or equal to RCOND times\n*         the largest singular value are treated as zero in solving\n*         the least squares problem. If RCOND is negative,\n*         machine precision is used instead.\n*         For example, if diag(S)*X=B were the least squares problem,\n*         where diag(S) is a diagonal matrix of singular values, the\n*         solution would be X(i) = B(i) / S(i) if S(i) is greater than\n*         RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to\n*         RCOND*max(S).\n*\n*  RANK   (output) INTEGER\n*         The number of singular values of A greater than RCOND times\n*         the largest singular value.\n*\n*  WORK   (workspace) COMPLEX array, dimension (N * NRHS).\n*\n*  RWORK  (workspace) REAL array, dimension at least\n*         (9*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS +\n*         MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS ),\n*         where\n*         NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )\n*\n*  IWORK  (workspace) INTEGER array, dimension (3*N*NLVL + 11*N).\n*\n*  INFO   (output) INTEGER\n*         = 0:  successful exit.\n*         < 0:  if INFO = -i, the i-th argument had an illegal value.\n*         > 0:  The algorithm failed to compute a singular value while\n*               working on the submatrix lying in rows and columns\n*               INFO/(N+1) through MOD(INFO,N+1).\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Ren-Cang Li, Computer Science Division, University of\n*       California at Berkeley, USA\n*     Osni Marques, LBNL/NERSC, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rank, info, d, e, b = NumRu::Lapack.clalsd( uplo, smlsiz, d, e, b, rcond, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_smlsiz = argv[1];
  rblapack_d = argv[2];
  rblapack_e = argv[3];
  rblapack_b = argv[4];
  rblapack_rcond = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  smlsiz = NUM2INT(rblapack_smlsiz);
  rcond = (real)NUM2DBL(rblapack_rcond);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (4th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  nlvl = ( (int)( log(((double)n)/(smlsiz+1))/log(2.0) ) ) + 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
  MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(complex, (n * nrhs));
  rwork = ALLOC_N(real, (9*n+2*n*smlsiz+8*n*nlvl+3*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1)));
  iwork = ALLOC_N(integer, (3*n*nlvl + 11*n));

  clalsd_(&uplo, &smlsiz, &n, &nrhs, d, e, b, &ldb, &rcond, &rank, work, rwork, iwork, &info);

  free(work);
  free(rwork);
  free(iwork);
  rblapack_rank = INT2NUM(rank);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_rank, rblapack_info, rblapack_d, rblapack_e, rblapack_b);
}

void
init_lapack_clalsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clalsd", rblapack_clalsd, -1);
}
ruby-lapack-1.7.2/ext/sorg2l.c0000644000175000017500000001032212502221017015731 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sorg2l_(integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* work, integer* info);


static VALUE
rblapack_sorg2l(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  real *work;

  integer lda;
  integer n;
  integer k;

  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  info, a = NumRu::Lapack.sorg2l( m, a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SORG2L( M, N, K, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SORG2L generates an m by n real matrix Q with orthonormal columns,\n*  which is defined as the last n columns of a product of k elementary\n*  reflectors of order m\n*\n*        Q  =  H(k) . . . H(2) H(1)\n*\n*  as returned by SGEQLF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. M >= N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. N >= K >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the (n-k+i)-th column must contain the vector which\n*          defines the elementary reflector H(i), for i = 1,2,...,k, as\n*          returned by SGEQLF in the last k columns of its array\n*          argument A.\n*          On exit, the m by n matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) REAL array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by SGEQLF.\n*\n*  WORK    (workspace) REAL array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -i, the i-th argument has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.sorg2l( m, a, tau, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  rblapack_tau = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(real, (n));

  sorg2l_(&m, &n, &k, a, &lda, tau, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_sorg2l(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sorg2l", rblapack_sorg2l, -1);
}
ruby-lapack-1.7.2/ext/ztfttp.c0000644000175000017500000001676712502221022016073 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztfttp_(char* transr, char* uplo, integer* n, doublecomplex* arf, doublecomplex* ap, integer* info);


static VALUE
rblapack_ztfttp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_arf;
  doublecomplex *arf; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_info;
  integer info; 


  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  ap, info = NumRu::Lapack.ztfttp( transr, uplo, n, arf, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTFTTP( TRANSR, UPLO, N, ARF, AP, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTFTTP copies a triangular matrix A from rectangular full packed\n*  format (TF) to standard packed format (TP).\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR   (input) CHARACTER*1\n*          = 'N':  ARF is in Normal format;\n*          = 'C':  ARF is in Conjugate-transpose format;\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0.\n*\n*  ARF     (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n*          On entry, the upper or lower triangular matrix A stored in\n*          RFP format. For a further discussion see Notes below.\n*\n*  AP      (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n*          On exit, the upper or lower triangular matrix A, packed\n*          columnwise in a linear array. The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\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*  We first consider Standard Packed Format when N is even.\n*  We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  conjugate-transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  conjugate-transpose of the last three columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                -- -- --\n*        03 04 05                33 43 53\n*                                   -- --\n*        13 14 15                00 44 54\n*                                      --\n*        23 24 25                10 11 55\n*\n*        33 34 35                20 21 22\n*        --\n*        00 44 45                30 31 32\n*        -- --\n*        01 11 55                40 41 42\n*        -- -- --\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- -- --                -- -- -- -- -- --\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     -- -- -- -- --                -- -- -- -- --\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     -- -- -- -- -- --                -- -- -- --\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We next consider Standard Packed Format when N is odd.\n*  We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  conjugate-transpose of the first two   columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  conjugate-transpose of the last two   columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N odd  and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                   -- --\n*        02 03 04                00 33 43\n*                                      --\n*        12 13 14                10 11 44\n*\n*        22 23 24                20 21 22\n*        --\n*        00 33 34                30 31 32\n*        -- --\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- --                   -- -- -- -- -- --\n*     02 12 22 00 01             00 10 20 30 40 50\n*     -- -- -- --                   -- -- -- -- --\n*     03 13 23 33 11             33 11 21 31 41 51\n*     -- -- -- -- --                   -- -- -- --\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ap, info = NumRu::Lapack.ztfttp( transr, uplo, n, arf, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_n = argv[2];
  rblapack_arf = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  n = NUM2INT(rblapack_n);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_arf))
    rb_raise(rb_eArgError, "arf (4th argument) must be NArray");
  if (NA_RANK(rblapack_arf) != 1)
    rb_raise(rb_eArgError, "rank of arf (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_arf) != (( n*(n+1)/2 )))
    rb_raise(rb_eRuntimeError, "shape 0 of arf must be %d", ( n*(n+1)/2 ));
  if (NA_TYPE(rblapack_arf) != NA_DCOMPLEX)
    rblapack_arf = na_change_type(rblapack_arf, NA_DCOMPLEX);
  arf = NA_PTR_TYPE(rblapack_arf, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = ( n*(n+1)/2 );
    rblapack_ap = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);

  ztfttp_(&transr, &uplo, &n, arf, ap, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_ap, rblapack_info);
}

void
init_lapack_ztfttp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztfttp", rblapack_ztfttp, -1);
}
ruby-lapack-1.7.2/ext/dbdsqr.c0000644000175000017500000002754112502221025016012 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dbdsqr_(char* uplo, integer* n, integer* ncvt, integer* nru, integer* ncc, doublereal* d, doublereal* e, doublereal* vt, integer* ldvt, doublereal* u, integer* ldu, doublereal* c, integer* ldc, doublereal* work, integer* info);


static VALUE
rblapack_dbdsqr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_nru;
  integer nru; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_vt;
  doublereal *vt; 
  VALUE rblapack_u;
  doublereal *u; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_e_out__;
  doublereal *e_out__;
  VALUE rblapack_vt_out__;
  doublereal *vt_out__;
  VALUE rblapack_u_out__;
  doublereal *u_out__;
  VALUE rblapack_c_out__;
  doublereal *c_out__;
  doublereal *work;

  integer n;
  integer ldvt;
  integer ncvt;
  integer ldu;
  integer ldc;
  integer ncc;

  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  info, d, e, vt, u, c = NumRu::Lapack.dbdsqr( uplo, nru, d, e, vt, u, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DBDSQR computes the singular values and, optionally, the right and/or\n*  left singular vectors from the singular value decomposition (SVD) of\n*  a real N-by-N (upper or lower) bidiagonal matrix B using the implicit\n*  zero-shift QR algorithm.  The SVD of B has the form\n* \n*     B = Q * S * P**T\n* \n*  where S is the diagonal matrix of singular values, Q is an orthogonal\n*  matrix of left singular vectors, and P is an orthogonal matrix of\n*  right singular vectors.  If left singular vectors are requested, this\n*  subroutine actually returns U*Q instead of Q, and, if right singular\n*  vectors are requested, this subroutine returns P**T*VT instead of\n*  P**T, for given real input matrices U and VT.  When U and VT are the\n*  orthogonal matrices that reduce a general matrix A to bidiagonal\n*  form:  A = U*B*VT, as computed by DGEBRD, then\n*\n*     A = (U*Q) * S * (P**T*VT)\n*\n*  is the SVD of A.  Optionally, the subroutine may also compute Q**T*C\n*  for a given real input matrix C.\n*\n*  See \"Computing  Small Singular Values of Bidiagonal Matrices With\n*  Guaranteed High Relative Accuracy,\" by J. Demmel and W. Kahan,\n*  LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,\n*  no. 5, pp. 873-912, Sept 1990) and\n*  \"Accurate singular values and differential qd algorithms,\" by\n*  B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics\n*  Department, University of California at Berkeley, July 1992\n*  for a detailed description of the algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  B is upper bidiagonal;\n*          = 'L':  B is lower bidiagonal.\n*\n*  N       (input) INTEGER\n*          The order of the matrix B.  N >= 0.\n*\n*  NCVT    (input) INTEGER\n*          The number of columns of the matrix VT. NCVT >= 0.\n*\n*  NRU     (input) INTEGER\n*          The number of rows of the matrix U. NRU >= 0.\n*\n*  NCC     (input) INTEGER\n*          The number of columns of the matrix C. NCC >= 0.\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the n diagonal elements of the bidiagonal matrix B.\n*          On exit, if INFO=0, the singular values of B in decreasing\n*          order.\n*\n*  E       (input/output) DOUBLE PRECISION array, dimension (N-1)\n*          On entry, the N-1 offdiagonal elements of the bidiagonal\n*          matrix B. \n*          On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E\n*          will contain the diagonal and superdiagonal elements of a\n*          bidiagonal matrix orthogonally equivalent to the one given\n*          as input.\n*\n*  VT      (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT)\n*          On entry, an N-by-NCVT matrix VT.\n*          On exit, VT is overwritten by P**T * VT.\n*          Not referenced if NCVT = 0.\n*\n*  LDVT    (input) INTEGER\n*          The leading dimension of the array VT.\n*          LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.\n*\n*  U       (input/output) DOUBLE PRECISION array, dimension (LDU, N)\n*          On entry, an NRU-by-N matrix U.\n*          On exit, U is overwritten by U * Q.\n*          Not referenced if NRU = 0.\n*\n*  LDU     (input) INTEGER\n*          The leading dimension of the array U.  LDU >= max(1,NRU).\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (LDC, NCC)\n*          On entry, an N-by-NCC matrix C.\n*          On exit, C is overwritten by Q**T * C.\n*          Not referenced if NCC = 0.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C.\n*          LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  If INFO = -i, the i-th argument had an illegal value\n*          > 0:\n*             if NCVT = NRU = NCC = 0,\n*                = 1, a split was marked by a positive value in E\n*                = 2, current block of Z not diagonalized after 30*N\n*                     iterations (in inner while loop)\n*                = 3, termination criterion of outer while loop not met \n*                     (program created more than N unreduced blocks)\n*             else NCVT = NRU = NCC = 0,\n*                   the algorithm did not converge; D and E contain the\n*                   elements of a bidiagonal matrix which is orthogonally\n*                   similar to the input matrix B;  if INFO = i, i\n*                   elements of E have not converged to zero.\n*\n*  Internal Parameters\n*  ===================\n*\n*  TOLMUL  DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8)))\n*          TOLMUL controls the convergence criterion of the QR loop.\n*          If it is positive, TOLMUL*EPS is the desired relative\n*             precision in the computed singular values.\n*          If it is negative, abs(TOLMUL*EPS*sigma_max) is the\n*             desired absolute accuracy in the computed singular\n*             values (corresponds to relative accuracy\n*             abs(TOLMUL*EPS) in the largest singular value.\n*          abs(TOLMUL) should be between 1 and 1/EPS, and preferably\n*             between 10 (for fast convergence) and .1/EPS\n*             (for there to be some accuracy in the results).\n*          Default is to lose at either one eighth or 2 of the\n*             available decimal digits in each computed singular value\n*             (whichever is smaller).\n*\n*  MAXITR  INTEGER, default = 6\n*          MAXITR controls the maximum number of passes of the\n*          algorithm through its inner loop. The algorithms stops\n*          (and so fails to converge) if the number of passes\n*          through the inner loop exceeds MAXITR*N**2.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, e, vt, u, c = NumRu::Lapack.dbdsqr( uplo, nru, d, e, vt, u, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_uplo = argv[0];
  rblapack_nru = argv[1];
  rblapack_d = argv[2];
  rblapack_e = argv[3];
  rblapack_vt = argv[4];
  rblapack_u = argv[5];
  rblapack_c = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_vt))
    rb_raise(rb_eArgError, "vt (5th argument) must be NArray");
  if (NA_RANK(rblapack_vt) != 2)
    rb_raise(rb_eArgError, "rank of vt (5th argument) must be %d", 2);
  ldvt = NA_SHAPE0(rblapack_vt);
  ncvt = NA_SHAPE1(rblapack_vt);
  if (NA_TYPE(rblapack_vt) != NA_DFLOAT)
    rblapack_vt = na_change_type(rblapack_vt, NA_DFLOAT);
  vt = NA_PTR_TYPE(rblapack_vt, doublereal*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  ncc = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  nru = NUM2INT(rblapack_nru);
  if (!NA_IsNArray(rblapack_u))
    rb_raise(rb_eArgError, "u (6th argument) must be NArray");
  if (NA_RANK(rblapack_u) != 2)
    rb_raise(rb_eArgError, "rank of u (6th argument) must be %d", 2);
  ldu = NA_SHAPE0(rblapack_u);
  if (NA_SHAPE1(rblapack_u) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of u must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_u) != NA_DFLOAT)
    rblapack_u = na_change_type(rblapack_u, NA_DFLOAT);
  u = NA_PTR_TYPE(rblapack_u, doublereal*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (4th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
  MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvt;
    shape[1] = ncvt;
    rblapack_vt_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vt_out__ = NA_PTR_TYPE(rblapack_vt_out__, doublereal*);
  MEMCPY(vt_out__, vt, doublereal, NA_TOTAL(rblapack_vt));
  rblapack_vt = rblapack_vt_out__;
  vt = vt_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = n;
    rblapack_u_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  u_out__ = NA_PTR_TYPE(rblapack_u_out__, doublereal*);
  MEMCPY(u_out__, u, doublereal, NA_TOTAL(rblapack_u));
  rblapack_u = rblapack_u_out__;
  u = u_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = ncc;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(doublereal, (4*n));

  dbdsqr_(&uplo, &n, &ncvt, &nru, &ncc, d, e, vt, &ldvt, u, &ldu, c, &ldc, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_info, rblapack_d, rblapack_e, rblapack_vt, rblapack_u, rblapack_c);
}

void
init_lapack_dbdsqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dbdsqr", rblapack_dbdsqr, -1);
}
ruby-lapack-1.7.2/ext/sggsvp.c0000644000175000017500000002305712502221015016041 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sggsvp_(char* jobu, char* jobv, char* jobq, integer* m, integer* p, integer* n, real* a, integer* lda, real* b, integer* ldb, real* tola, real* tolb, integer* k, integer* l, real* u, integer* ldu, real* v, integer* ldv, real* q, integer* ldq, integer* iwork, real* tau, real* work, integer* info);


static VALUE
rblapack_sggsvp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobu;
  char jobu; 
  VALUE rblapack_jobv;
  char jobv; 
  VALUE rblapack_jobq;
  char jobq; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_tola;
  real tola; 
  VALUE rblapack_tolb;
  real tolb; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_u;
  real *u; 
  VALUE rblapack_v;
  real *v; 
  VALUE rblapack_q;
  real *q; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_b_out__;
  real *b_out__;
  integer *iwork;
  real *tau;
  real *work;

  integer lda;
  integer n;
  integer ldb;
  integer ldu;
  integer m;
  integer ldv;
  integer p;
  integer ldq;

  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  k, l, u, v, q, info, a, b = NumRu::Lapack.sggsvp( jobu, jobv, jobq, a, b, tola, tolb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGGSVP computes orthogonal matrices U, V and Q such that\n*\n*                   N-K-L  K    L\n*   U'*A*Q =     K ( 0    A12  A13 )  if M-K-L >= 0;\n*                L ( 0     0   A23 )\n*            M-K-L ( 0     0    0  )\n*\n*                   N-K-L  K    L\n*          =     K ( 0    A12  A13 )  if M-K-L < 0;\n*              M-K ( 0     0   A23 )\n*\n*                 N-K-L  K    L\n*   V'*B*Q =   L ( 0     0   B13 )\n*            P-L ( 0     0    0  )\n*\n*  where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n*  upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n*  otherwise A23 is (M-K)-by-L upper trapezoidal.  K+L = the effective\n*  numerical rank of the (M+P)-by-N matrix (A',B')'.  Z' denotes the\n*  transpose of Z.\n*\n*  This decomposition is the preprocessing step for computing the\n*  Generalized Singular Value Decomposition (GSVD), see subroutine\n*  SGGSVD.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBU    (input) CHARACTER*1\n*          = 'U':  Orthogonal matrix U is computed;\n*          = 'N':  U is not computed.\n*\n*  JOBV    (input) CHARACTER*1\n*          = 'V':  Orthogonal matrix V is computed;\n*          = 'N':  V is not computed.\n*\n*  JOBQ    (input) CHARACTER*1\n*          = 'Q':  Orthogonal matrix Q is computed;\n*          = 'N':  Q is not computed.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.  M >= 0.\n*\n*  P       (input) INTEGER\n*          The number of rows of the matrix B.  P >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrices A and B.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, A contains the triangular (or trapezoidal) matrix\n*          described in the Purpose section.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  B       (input/output) REAL array, dimension (LDB,N)\n*          On entry, the P-by-N matrix B.\n*          On exit, B contains the triangular matrix described in\n*          the Purpose section.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,P).\n*\n*  TOLA    (input) REAL\n*  TOLB    (input) REAL\n*          TOLA and TOLB are the thresholds to determine the effective\n*          numerical rank of matrix B and a subblock of A. Generally,\n*          they are set to\n*             TOLA = MAX(M,N)*norm(A)*MACHEPS,\n*             TOLB = MAX(P,N)*norm(B)*MACHEPS.\n*          The size of TOLA and TOLB may affect the size of backward\n*          errors of the decomposition.\n*\n*  K       (output) INTEGER\n*  L       (output) INTEGER\n*          On exit, K and L specify the dimension of the subblocks\n*          described in Purpose.\n*          K + L = effective numerical rank of (A',B')'.\n*\n*  U       (output) REAL array, dimension (LDU,M)\n*          If JOBU = 'U', U contains the orthogonal matrix U.\n*          If JOBU = 'N', U is not referenced.\n*\n*  LDU     (input) INTEGER\n*          The leading dimension of the array U. LDU >= max(1,M) if\n*          JOBU = 'U'; LDU >= 1 otherwise.\n*\n*  V       (output) REAL array, dimension (LDV,P)\n*          If JOBV = 'V', V contains the orthogonal matrix V.\n*          If JOBV = 'N', V is not referenced.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V. LDV >= max(1,P) if\n*          JOBV = 'V'; LDV >= 1 otherwise.\n*\n*  Q       (output) REAL array, dimension (LDQ,N)\n*          If JOBQ = 'Q', Q contains the orthogonal matrix Q.\n*          If JOBQ = 'N', Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q. LDQ >= max(1,N) if\n*          JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\n*\n*  TAU     (workspace) REAL array, dimension (N)\n*\n*  WORK    (workspace) REAL array, dimension (max(3*N,M,P))\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\n*  Further Details\n*  ===============\n*\n*  The subroutine uses LAPACK subroutine SGEQPF for the QR factorization\n*  with column pivoting to detect the effective numerical rank of the\n*  a matrix. It may be replaced by a better rank determination strategy.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  k, l, u, v, q, info, a, b = NumRu::Lapack.sggsvp( jobu, jobv, jobq, a, b, tola, tolb, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_jobu = argv[0];
  rblapack_jobv = argv[1];
  rblapack_jobq = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  rblapack_tola = argv[5];
  rblapack_tolb = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobu = StringValueCStr(rblapack_jobu)[0];
  jobq = StringValueCStr(rblapack_jobq)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  tolb = (real)NUM2DBL(rblapack_tolb);
  p = ldb;
  jobv = StringValueCStr(rblapack_jobv)[0];
  tola = (real)NUM2DBL(rblapack_tola);
  ldv = lsame_(&jobv,"V") ? MAX(1,p) : 1;
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  ldq = lsame_(&jobq,"Q") ? MAX(1,n) : 1;
  m = lda;
  ldu = lsame_(&jobu,"U") ? MAX(1,m) : 1;
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = m;
    rblapack_u = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  u = NA_PTR_TYPE(rblapack_u, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = p;
    rblapack_v = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  v = NA_PTR_TYPE(rblapack_v, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  q = NA_PTR_TYPE(rblapack_q, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  iwork = ALLOC_N(integer, (n));
  tau = ALLOC_N(real, (n));
  work = ALLOC_N(real, (MAX(MAX(3*n,m),p)));

  sggsvp_(&jobu, &jobv, &jobq, &m, &p, &n, a, &lda, b, &ldb, &tola, &tolb, &k, &l, u, &ldu, v, &ldv, q, &ldq, iwork, tau, work, &info);

  free(iwork);
  free(tau);
  free(work);
  rblapack_k = INT2NUM(k);
  rblapack_l = INT2NUM(l);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_k, rblapack_l, rblapack_u, rblapack_v, rblapack_q, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_sggsvp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sggsvp", rblapack_sggsvp, -1);
}
ruby-lapack-1.7.2/ext/strttf.c0000644000175000017500000001630112502221017016052 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID strttf_(char* transr, char* uplo, integer* n, real* a, integer* lda, real* arf, integer* info);


static VALUE
rblapack_strttf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_arf;
  real *arf; 
  VALUE rblapack_info;
  integer info; 

  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  arf, info = NumRu::Lapack.strttf( transr, uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO )\n\n*  Purpose\n*  =======\n*\n*  STRTTF copies a triangular matrix A from standard full format (TR)\n*  to rectangular full packed format (TF) .\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR   (input) CHARACTER*1\n*          = 'N':  ARF in Normal form is wanted;\n*          = 'T':  ARF in Transpose form is wanted.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0.\n*\n*  A       (input) REAL array, dimension (LDA,N).\n*          On entry, the triangular matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of the array A contains\n*          the upper triangular matrix, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of the array A contains\n*          the lower triangular matrix, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the matrix A. LDA >= max(1,N).\n*\n*  ARF     (output) REAL array, dimension (NT).\n*          NT=N*(N+1)/2. On exit, the triangular matrix A in RFP format.\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*  We first consider Rectangular Full Packed (RFP) Format when N is\n*  even. We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  the transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  the transpose of the last three columns of AP lower.\n*  This covers the case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        03 04 05                33 43 53\n*        13 14 15                00 44 54\n*        23 24 25                10 11 55\n*        33 34 35                20 21 22\n*        00 44 45                30 31 32\n*        01 11 55                40 41 42\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We then consider Rectangular Full Packed (RFP) Format when N is\n*  odd. We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  the transpose of the first two columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  the transpose of the last two columns of AP lower.\n*  This covers the case N odd and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        02 03 04                00 33 43\n*        12 13 14                10 11 44\n*        22 23 24                20 21 22\n*        00 33 34                30 31 32\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*           RFP A                   RFP A\n*\n*     02 12 22 00 01             00 10 20 30 40 50\n*     03 13 23 33 11             33 11 21 31 41 51\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  Reference\n*  =========\n*\n*  =====================================================================\n*\n*     ..\n*     .. Local Scalars ..\n      LOGICAL            LOWER, NISODD, NORMALTRANSR\n      INTEGER            I, IJ, J, K, L, N1, N2, NT, NX2, NP1X2\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MOD\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  arf, info = NumRu::Lapack.strttf( transr, uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_arf = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  arf = NA_PTR_TYPE(rblapack_arf, real*);

  strttf_(&transr, &uplo, &n, a, &lda, arf, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_arf, rblapack_info);
}

void
init_lapack_strttf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "strttf", rblapack_strttf, -1);
}
ruby-lapack-1.7.2/ext/zungtr.c0000644000175000017500000001256312502221022016057 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zungtr_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zungtr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *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  work, info, a = NumRu::Lapack.zungtr( uplo, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZUNGTR generates a complex unitary matrix Q which is defined as the\n*  product of n-1 elementary reflectors of order N, as returned by\n*  ZHETRD:\n*\n*  if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),\n*\n*  if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U': Upper triangle of A contains elementary reflectors\n*                 from ZHETRD;\n*          = 'L': Lower triangle of A contains elementary reflectors\n*                 from ZHETRD.\n*\n*  N       (input) INTEGER\n*          The order of the matrix Q. N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the vectors which define the elementary reflectors,\n*          as returned by ZHETRD.\n*          On exit, the N-by-N unitary matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= N.\n*\n*  TAU     (input) COMPLEX*16 array, dimension (N-1)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by ZHETRD.\n*\n*  WORK    (workspace/output) COMPLEX*16 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 >= N-1.\n*          For optimum performance LWORK >= (N-1)*NB, where NB is\n*          the 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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, a = NumRu::Lapack.zungtr( uplo, a, tau, [: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_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_tau = 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;
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (rblapack_lwork == Qnil)
    lwork = n-1;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_tau) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", n-1);
  if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zungtr_(&uplo, &n, a, &lda, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_zungtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zungtr", rblapack_zungtr, -1);
}
ruby-lapack-1.7.2/ext/ztgsyl.c0000644000175000017500000003360712502221017016070 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztgsyl_(char* trans, integer* ijob, integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* c, integer* ldc, doublecomplex* d, integer* ldd, doublecomplex* e, integer* lde, doublecomplex* f, integer* ldf, doublereal* scale, doublereal* dif, doublecomplex* work, integer* lwork, integer* iwork, integer* info);


static VALUE
rblapack_ztgsyl(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_ijob;
  integer ijob; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_c;
  doublecomplex *c; 
  VALUE rblapack_d;
  doublecomplex *d; 
  VALUE rblapack_e;
  doublecomplex *e; 
  VALUE rblapack_f;
  doublecomplex *f; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_scale;
  doublereal scale; 
  VALUE rblapack_dif;
  doublereal dif; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublecomplex *c_out__;
  VALUE rblapack_f_out__;
  doublecomplex *f_out__;
  integer *iwork;

  integer lda;
  integer m;
  integer ldb;
  integer n;
  integer ldc;
  integer ldd;
  integer lde;
  integer ldf;

  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  scale, dif, work, info, c, f = NumRu::Lapack.ztgsyl( trans, ijob, a, b, c, d, e, f, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTGSYL solves the generalized Sylvester equation:\n*\n*              A * R - L * B = scale * C            (1)\n*              D * R - L * E = scale * F\n*\n*  where R and L are unknown m-by-n matrices, (A, D), (B, E) and\n*  (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n,\n*  respectively, with complex entries. A, B, D and E are upper\n*  triangular (i.e., (A,D) and (B,E) in generalized Schur form).\n*\n*  The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1\n*  is an output scaling factor chosen to avoid overflow.\n*\n*  In matrix notation (1) is equivalent to solve Zx = scale*b, where Z\n*  is defined as\n*\n*         Z = [ kron(In, A)  -kron(B', Im) ]        (2)\n*             [ kron(In, D)  -kron(E', Im) ],\n*\n*  Here Ix is the identity matrix of size x and X' is the conjugate\n*  transpose of X. Kron(X, Y) is the Kronecker product between the\n*  matrices X and Y.\n*\n*  If TRANS = 'C', y in the conjugate transposed system Z'*y = scale*b\n*  is solved for, which is equivalent to solve for R and L in\n*\n*              A' * R + D' * L = scale * C           (3)\n*              R * B' + L * E' = scale * -F\n*\n*  This case (TRANS = 'C') is used to compute an one-norm-based estimate\n*  of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D)\n*  and (B,E), using ZLACON.\n*\n*  If IJOB >= 1, ZTGSYL computes a Frobenius norm-based estimate of\n*  Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the\n*  reciprocal of the smallest singular value of Z.\n*\n*  This is a level-3 BLAS algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': solve the generalized sylvester equation (1).\n*          = 'C': solve the \"conjugate transposed\" system (3).\n*\n*  IJOB    (input) INTEGER\n*          Specifies what kind of functionality to be performed.\n*          =0: solve (1) only.\n*          =1: The functionality of 0 and 3.\n*          =2: The functionality of 0 and 4.\n*          =3: Only an estimate of Dif[(A,D), (B,E)] is computed.\n*              (look ahead strategy is used).\n*          =4: Only an estimate of Dif[(A,D), (B,E)] is computed.\n*              (ZGECON on sub-systems is used).\n*          Not referenced if TRANS = 'C'.\n*\n*  M       (input) INTEGER\n*          The order of the matrices A and D, and the row dimension of\n*          the matrices C, F, R and L.\n*\n*  N       (input) INTEGER\n*          The order of the matrices B and E, and the column dimension\n*          of the matrices C, F, R and L.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA, M)\n*          The upper triangular matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1, M).\n*\n*  B       (input) COMPLEX*16 array, dimension (LDB, N)\n*          The upper triangular matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1, N).\n*\n*  C       (input/output) COMPLEX*16 array, dimension (LDC, N)\n*          On entry, C contains the right-hand-side of the first matrix\n*          equation in (1) or (3).\n*          On exit, if IJOB = 0, 1 or 2, C has been overwritten by\n*          the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R,\n*          the solution achieved during the computation of the\n*          Dif-estimate.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1, M).\n*\n*  D       (input) COMPLEX*16 array, dimension (LDD, M)\n*          The upper triangular matrix D.\n*\n*  LDD     (input) INTEGER\n*          The leading dimension of the array D. LDD >= max(1, M).\n*\n*  E       (input) COMPLEX*16 array, dimension (LDE, N)\n*          The upper triangular matrix E.\n*\n*  LDE     (input) INTEGER\n*          The leading dimension of the array E. LDE >= max(1, N).\n*\n*  F       (input/output) COMPLEX*16 array, dimension (LDF, N)\n*          On entry, F contains the right-hand-side of the second matrix\n*          equation in (1) or (3).\n*          On exit, if IJOB = 0, 1 or 2, F has been overwritten by\n*          the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L,\n*          the solution achieved during the computation of the\n*          Dif-estimate.\n*\n*  LDF     (input) INTEGER\n*          The leading dimension of the array F. LDF >= max(1, M).\n*\n*  DIF     (output) DOUBLE PRECISION\n*          On exit DIF is the reciprocal of a lower bound of the\n*          reciprocal of the Dif-function, i.e. DIF is an upper bound of\n*          Dif[(A,D), (B,E)] = sigma-min(Z), where Z as in (2).\n*          IF IJOB = 0 or TRANS = 'C', DIF is not referenced.\n*\n*  SCALE   (output) DOUBLE PRECISION\n*          On exit SCALE is the scaling factor in (1) or (3).\n*          If 0 < SCALE < 1, C and F hold the solutions R and L, resp.,\n*          to a slightly perturbed system but the input matrices A, B,\n*          D and E have not been changed. If SCALE = 0, R and L will\n*          hold the solutions to the homogenious system with C = F = 0.\n*\n*  WORK    (workspace/output) COMPLEX*16 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 > = 1.\n*          If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N).\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*  IWORK   (workspace) INTEGER array, dimension (M+N+2)\n*\n*  INFO    (output) INTEGER\n*            =0: successful exit\n*            <0: If INFO = -i, the i-th argument had an illegal value.\n*            >0: (A, D) and (B, E) have common or very close\n*                eigenvalues.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n*      for Solving the Generalized Sylvester Equation and Estimating the\n*      Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n*      Department of Computing Science, Umea University, S-901 87 Umea,\n*      Sweden, December 1993, Revised April 1994, Also as LAPACK Working\n*      Note 75.  To appear in ACM Trans. on Math. Software, Vol 22,\n*      No 1, 1996.\n*\n*  [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester\n*      Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal.\n*      Appl., 15(4):1045-1060, 1994.\n*\n*  [3] B. Kagstrom and L. Westin, Generalized Schur Methods with\n*      Condition Estimators for Solving the Generalized Sylvester\n*      Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7,\n*      July 1989, pp 745-751.\n*\n*  =====================================================================\n*  Replaced various illegal calls to CCOPY by calls to CLASET.\n*  Sven Hammarling, 1/5/02.\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, dif, work, info, c, f = NumRu::Lapack.ztgsyl( trans, ijob, a, b, c, d, e, f, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_trans = argv[0];
  rblapack_ijob = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  rblapack_c = argv[4];
  rblapack_d = argv[5];
  rblapack_e = argv[6];
  rblapack_f = argv[7];
  if (argc == 9) {
    rblapack_lwork = argv[8];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (7th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 2)
    rb_raise(rb_eArgError, "rank of e (7th argument) must be %d", 2);
  lde = NA_SHAPE0(rblapack_e);
  if (NA_SHAPE1(rblapack_e) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of e must be the same as shape 1 of c");
  if (NA_TYPE(rblapack_e) != NA_DCOMPLEX)
    rblapack_e = na_change_type(rblapack_e, NA_DCOMPLEX);
  e = NA_PTR_TYPE(rblapack_e, doublecomplex*);
  ijob = NUM2INT(rblapack_ijob);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (6th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 2)
    rb_raise(rb_eArgError, "rank of d (6th argument) must be %d", 2);
  ldd = NA_SHAPE0(rblapack_d);
  if (NA_SHAPE1(rblapack_d) != m)
    rb_raise(rb_eRuntimeError, "shape 1 of d must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_d) != NA_DCOMPLEX)
    rblapack_d = na_change_type(rblapack_d, NA_DCOMPLEX);
  d = NA_PTR_TYPE(rblapack_d, doublecomplex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of c");
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  if (!NA_IsNArray(rblapack_f))
    rb_raise(rb_eArgError, "f (8th argument) must be NArray");
  if (NA_RANK(rblapack_f) != 2)
    rb_raise(rb_eArgError, "rank of f (8th argument) must be %d", 2);
  ldf = NA_SHAPE0(rblapack_f);
  if (NA_SHAPE1(rblapack_f) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of f must be the same as shape 1 of c");
  if (NA_TYPE(rblapack_f) != NA_DCOMPLEX)
    rblapack_f = na_change_type(rblapack_f, NA_DCOMPLEX);
  f = NA_PTR_TYPE(rblapack_f, doublecomplex*);
  if (rblapack_lwork == Qnil)
    lwork = ((ijob==1||ijob==2)&&lsame_(&trans,"N")) ? 2*m*n : 1;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
  MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldf;
    shape[1] = n;
    rblapack_f_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  f_out__ = NA_PTR_TYPE(rblapack_f_out__, doublecomplex*);
  MEMCPY(f_out__, f, doublecomplex, NA_TOTAL(rblapack_f));
  rblapack_f = rblapack_f_out__;
  f = f_out__;
  iwork = ALLOC_N(integer, (m+n+2));

  ztgsyl_(&trans, &ijob, &m, &n, a, &lda, b, &ldb, c, &ldc, d, &ldd, e, &lde, f, &ldf, &scale, &dif, work, &lwork, iwork, &info);

  free(iwork);
  rblapack_scale = rb_float_new((double)scale);
  rblapack_dif = rb_float_new((double)dif);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_scale, rblapack_dif, rblapack_work, rblapack_info, rblapack_c, rblapack_f);
}

void
init_lapack_ztgsyl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztgsyl", rblapack_ztgsyl, -1);
}
ruby-lapack-1.7.2/ext/dtgsyl.c0000644000175000017500000003370112502221020016027 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtgsyl_(char* trans, integer* ijob, integer* m, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* c, integer* ldc, doublereal* d, integer* ldd, doublereal* e, integer* lde, doublereal* f, integer* ldf, doublereal* scale, doublereal* dif, doublereal* work, integer* lwork, integer* iwork, integer* info);


static VALUE
rblapack_dtgsyl(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_ijob;
  integer ijob; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_f;
  doublereal *f; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_scale;
  doublereal scale; 
  VALUE rblapack_dif;
  doublereal dif; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublereal *c_out__;
  VALUE rblapack_f_out__;
  doublereal *f_out__;
  integer *iwork;

  integer lda;
  integer m;
  integer ldb;
  integer n;
  integer ldc;
  integer ldd;
  integer lde;
  integer ldf;

  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  scale, dif, work, info, c, f = NumRu::Lapack.dtgsyl( trans, ijob, a, b, c, d, e, f, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTGSYL solves the generalized Sylvester equation:\n*\n*              A * R - L * B = scale * C                 (1)\n*              D * R - L * E = scale * F\n*\n*  where R and L are unknown m-by-n matrices, (A, D), (B, E) and\n*  (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n,\n*  respectively, with real entries. (A, D) and (B, E) must be in\n*  generalized (real) Schur canonical form, i.e. A, B are upper quasi\n*  triangular and D, E are upper triangular.\n*\n*  The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output\n*  scaling factor chosen to avoid overflow.\n*\n*  In matrix notation (1) is equivalent to solve  Zx = scale b, where\n*  Z is defined as\n*\n*             Z = [ kron(In, A)  -kron(B', Im) ]         (2)\n*                 [ kron(In, D)  -kron(E', Im) ].\n*\n*  Here Ik is the identity matrix of size k and X' is the transpose of\n*  X. kron(X, Y) is the Kronecker product between the matrices X and Y.\n*\n*  If TRANS = 'T', DTGSYL solves the transposed system Z'*y = scale*b,\n*  which is equivalent to solve for R and L in\n*\n*              A' * R  + D' * L   = scale *  C           (3)\n*              R  * B' + L  * E'  = scale * (-F)\n*\n*  This case (TRANS = 'T') is used to compute an one-norm-based estimate\n*  of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D)\n*  and (B,E), using DLACON.\n*\n*  If IJOB >= 1, DTGSYL computes a Frobenius norm-based estimate\n*  of Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the\n*  reciprocal of the smallest singular value of Z. See [1-2] for more\n*  information.\n*\n*  This is a level 3 BLAS algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N', solve the generalized Sylvester equation (1).\n*          = 'T', solve the 'transposed' system (3).\n*\n*  IJOB    (input) INTEGER\n*          Specifies what kind of functionality to be performed.\n*           =0: solve (1) only.\n*           =1: The functionality of 0 and 3.\n*           =2: The functionality of 0 and 4.\n*           =3: Only an estimate of Dif[(A,D), (B,E)] is computed.\n*               (look ahead strategy IJOB  = 1 is used).\n*           =4: Only an estimate of Dif[(A,D), (B,E)] is computed.\n*               ( DGECON on sub-systems is used ).\n*          Not referenced if TRANS = 'T'.\n*\n*  M       (input) INTEGER\n*          The order of the matrices A and D, and the row dimension of\n*          the matrices C, F, R and L.\n*\n*  N       (input) INTEGER\n*          The order of the matrices B and E, and the column dimension\n*          of the matrices C, F, R and L.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA, M)\n*          The upper quasi triangular matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1, M).\n*\n*  B       (input) DOUBLE PRECISION array, dimension (LDB, N)\n*          The upper quasi triangular matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1, N).\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (LDC, N)\n*          On entry, C contains the right-hand-side of the first matrix\n*          equation in (1) or (3).\n*          On exit, if IJOB = 0, 1 or 2, C has been overwritten by\n*          the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R,\n*          the solution achieved during the computation of the\n*          Dif-estimate.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1, M).\n*\n*  D       (input) DOUBLE PRECISION array, dimension (LDD, M)\n*          The upper triangular matrix D.\n*\n*  LDD     (input) INTEGER\n*          The leading dimension of the array D. LDD >= max(1, M).\n*\n*  E       (input) DOUBLE PRECISION array, dimension (LDE, N)\n*          The upper triangular matrix E.\n*\n*  LDE     (input) INTEGER\n*          The leading dimension of the array E. LDE >= max(1, N).\n*\n*  F       (input/output) DOUBLE PRECISION array, dimension (LDF, N)\n*          On entry, F contains the right-hand-side of the second matrix\n*          equation in (1) or (3).\n*          On exit, if IJOB = 0, 1 or 2, F has been overwritten by\n*          the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L,\n*          the solution achieved during the computation of the\n*          Dif-estimate.\n*\n*  LDF     (input) INTEGER\n*          The leading dimension of the array F. LDF >= max(1, M).\n*\n*  DIF     (output) DOUBLE PRECISION\n*          On exit DIF is the reciprocal of a lower bound of the\n*          reciprocal of the Dif-function, i.e. DIF is an upper bound of\n*          Dif[(A,D), (B,E)] = sigma_min(Z), where Z as in (2).\n*          IF IJOB = 0 or TRANS = 'T', DIF is not touched.\n*\n*  SCALE   (output) DOUBLE PRECISION\n*          On exit SCALE is the scaling factor in (1) or (3).\n*          If 0 < SCALE < 1, C and F hold the solutions R and L, resp.,\n*          to a slightly perturbed system but the input matrices A, B, D\n*          and E have not been changed. If SCALE = 0, C and F hold the\n*          solutions R and L, respectively, to the homogeneous system\n*          with C = F = 0. Normally, SCALE = 1.\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 > = 1.\n*          If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N).\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*  IWORK   (workspace) INTEGER array, dimension (M+N+6)\n*\n*  INFO    (output) INTEGER\n*            =0: successful exit\n*            <0: If INFO = -i, the i-th argument had an illegal value.\n*            >0: (A, D) and (B, E) have common or close eigenvalues.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n*      for Solving the Generalized Sylvester Equation and Estimating the\n*      Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n*      Department of Computing Science, Umea University, S-901 87 Umea,\n*      Sweden, December 1993, Revised April 1994, Also as LAPACK Working\n*      Note 75.  To appear in ACM Trans. on Math. Software, Vol 22,\n*      No 1, 1996.\n*\n*  [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester\n*      Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal.\n*      Appl., 15(4):1045-1060, 1994\n*\n*  [3] B. Kagstrom and L. Westin, Generalized Schur Methods with\n*      Condition Estimators for Solving the Generalized Sylvester\n*      Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7,\n*      July 1989, pp 745-751.\n*\n*  =====================================================================\n*  Replaced various illegal calls to DCOPY by calls to DLASET.\n*  Sven Hammarling, 1/5/02.\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, dif, work, info, c, f = NumRu::Lapack.dtgsyl( trans, ijob, a, b, c, d, e, f, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_trans = argv[0];
  rblapack_ijob = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  rblapack_c = argv[4];
  rblapack_d = argv[5];
  rblapack_e = argv[6];
  rblapack_f = argv[7];
  if (argc == 9) {
    rblapack_lwork = argv[8];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = 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*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (7th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 2)
    rb_raise(rb_eArgError, "rank of e (7th argument) must be %d", 2);
  lde = NA_SHAPE0(rblapack_e);
  if (NA_SHAPE1(rblapack_e) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of e must be the same as shape 1 of c");
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  ijob = NUM2INT(rblapack_ijob);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (6th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 2)
    rb_raise(rb_eArgError, "rank of d (6th argument) must be %d", 2);
  ldd = NA_SHAPE0(rblapack_d);
  if (NA_SHAPE1(rblapack_d) != m)
    rb_raise(rb_eRuntimeError, "shape 1 of d must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of c");
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  if (!NA_IsNArray(rblapack_f))
    rb_raise(rb_eArgError, "f (8th argument) must be NArray");
  if (NA_RANK(rblapack_f) != 2)
    rb_raise(rb_eArgError, "rank of f (8th argument) must be %d", 2);
  ldf = NA_SHAPE0(rblapack_f);
  if (NA_SHAPE1(rblapack_f) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of f must be the same as shape 1 of c");
  if (NA_TYPE(rblapack_f) != NA_DFLOAT)
    rblapack_f = na_change_type(rblapack_f, NA_DFLOAT);
  f = NA_PTR_TYPE(rblapack_f, doublereal*);
  if (rblapack_lwork == Qnil)
    lwork = ((ijob==1||ijob==2)&&lsame_(&trans,"N")) ? 2*m*n : 1;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldf;
    shape[1] = n;
    rblapack_f_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  f_out__ = NA_PTR_TYPE(rblapack_f_out__, doublereal*);
  MEMCPY(f_out__, f, doublereal, NA_TOTAL(rblapack_f));
  rblapack_f = rblapack_f_out__;
  f = f_out__;
  iwork = ALLOC_N(integer, (m+n+6));

  dtgsyl_(&trans, &ijob, &m, &n, a, &lda, b, &ldb, c, &ldc, d, &ldd, e, &lde, f, &ldf, &scale, &dif, work, &lwork, iwork, &info);

  free(iwork);
  rblapack_scale = rb_float_new((double)scale);
  rblapack_dif = rb_float_new((double)dif);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_scale, rblapack_dif, rblapack_work, rblapack_info, rblapack_c, rblapack_f);
}

void
init_lapack_dtgsyl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtgsyl", rblapack_dtgsyl, -1);
}
ruby-lapack-1.7.2/ext/dgels.c0000644000175000017500000002117412502221025015625 0ustar  uwabamiuwabami#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;
  }

  trans = StringValueCStr(rblapack_trans)[0];
  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 = lda;
  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*);
  ldb = MAX(m,n);
  if (rblapack_lwork == Qnil)
    lwork = MIN(m,n) + MAX(MIN(m,n),nrhs);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;
  {
    na_shape_t 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, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgels", rblapack_dgels, -1);
}
ruby-lapack-1.7.2/ext/dsytrs2.c0000644000175000017500000001226212502221021016133 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsytrs2_(char* uplo, integer* n, integer* nrhs, doublereal* a, integer* lda, integer* ipiv, doublereal* b, integer* ldb, real* work, integer* info);


static VALUE
rblapack_dsytrs2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublereal *b_out__;
  real *work;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.dsytrs2( uplo, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,  WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSYTRS2 solves a system of linear equations A*X = B with a real\n*  symmetric matrix A using the factorization A = U*D*U**T or\n*  A = L*D*L**T computed by DSYTRF and converted by DSYCONV.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by DSYTRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by DSYTRF.\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  WORK    (workspace) REAL array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.dsytrs2( uplo, a, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(real, (n));

  dsytrs2_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_dsytrs2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsytrs2", rblapack_dsytrs2, -1);
}
ruby-lapack-1.7.2/ext/dlacn2.c0000644000175000017500000001277712502221025015703 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlacn2_(integer* n, doublereal* v, doublereal* x, integer* isgn, doublereal* est, integer* kase, integer* isave);


static VALUE
rblapack_dlacn2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_est;
  doublereal est; 
  VALUE rblapack_kase;
  integer kase; 
  VALUE rblapack_isave;
  integer *isave; 
  VALUE rblapack_x_out__;
  doublereal *x_out__;
  VALUE rblapack_isave_out__;
  integer *isave_out__;
  doublereal *v;
  integer *isgn;

  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  x, est, kase, isave = NumRu::Lapack.dlacn2( x, est, kase, isave, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE )\n\n*  Purpose\n*  =======\n*\n*  DLACN2 estimates the 1-norm of a square, real matrix A.\n*  Reverse communication is used for evaluating matrix-vector products.\n*\n\n*  Arguments\n*  =========\n*\n*  N      (input) INTEGER\n*         The order of the matrix.  N >= 1.\n*\n*  V      (workspace) DOUBLE PRECISION array, dimension (N)\n*         On the final return, V = A*W,  where  EST = norm(V)/norm(W)\n*         (W is not returned).\n*\n*  X      (input/output) DOUBLE PRECISION array, dimension (N)\n*         On an intermediate return, X should be overwritten by\n*               A * X,   if KASE=1,\n*               A' * X,  if KASE=2,\n*         and DLACN2 must be re-called with all the other parameters\n*         unchanged.\n*\n*  ISGN   (workspace) INTEGER array, dimension (N)\n*\n*  EST    (input/output) DOUBLE PRECISION\n*         On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be\n*         unchanged from the previous call to DLACN2.\n*         On exit, EST is an estimate (a lower bound) for norm(A). \n*\n*  KASE   (input/output) INTEGER\n*         On the initial call to DLACN2, KASE should be 0.\n*         On an intermediate return, KASE will be 1 or 2, indicating\n*         whether X should be overwritten by A * X  or A' * X.\n*         On the final return from DLACN2, KASE will again be 0.\n*\n*  ISAVE  (input/output) INTEGER array, dimension (3)\n*         ISAVE is used to save variables between calls to DLACN2\n*\n\n*  Further Details\n*  ======= =======\n*\n*  Contributed by Nick Higham, University of Manchester.\n*  Originally named SONEST, dated March 16, 1988.\n*\n*  Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n*  a real or complex matrix, with applications to condition estimation\",\n*  ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n*\n*  This is a thread safe version of DLACON, which uses the array ISAVE\n*  in place of a SAVE statement, as follows:\n*\n*     DLACON     DLACN2\n*      JUMP     ISAVE(1)\n*      J        ISAVE(2)\n*      ITER     ISAVE(3)\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, est, kase, isave = NumRu::Lapack.dlacn2( x, est, kase, isave, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_x = argv[0];
  rblapack_est = argv[1];
  rblapack_kase = argv[2];
  rblapack_isave = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (1th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  kase = NUM2INT(rblapack_kase);
  est = NUM2DBL(rblapack_est);
  if (!NA_IsNArray(rblapack_isave))
    rb_raise(rb_eArgError, "isave (4th argument) must be NArray");
  if (NA_RANK(rblapack_isave) != 1)
    rb_raise(rb_eArgError, "rank of isave (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_isave) != (3))
    rb_raise(rb_eRuntimeError, "shape 0 of isave must be %d", 3);
  if (NA_TYPE(rblapack_isave) != NA_LINT)
    rblapack_isave = na_change_type(rblapack_isave, NA_LINT);
  isave = NA_PTR_TYPE(rblapack_isave, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = 3;
    rblapack_isave_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isave_out__ = NA_PTR_TYPE(rblapack_isave_out__, integer*);
  MEMCPY(isave_out__, isave, integer, NA_TOTAL(rblapack_isave));
  rblapack_isave = rblapack_isave_out__;
  isave = isave_out__;
  v = ALLOC_N(doublereal, (n));
  isgn = ALLOC_N(integer, (n));

  dlacn2_(&n, v, x, isgn, &est, &kase, isave);

  free(v);
  free(isgn);
  rblapack_est = rb_float_new((double)est);
  rblapack_kase = INT2NUM(kase);
  return rb_ary_new3(4, rblapack_x, rblapack_est, rblapack_kase, rblapack_isave);
}

void
init_lapack_dlacn2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlacn2", rblapack_dlacn2, -1);
}
ruby-lapack-1.7.2/ext/zhbev.c0000644000175000017500000001405012502221021015634 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhbev_(char* jobz, char* uplo, integer* n, integer* kd, doublecomplex* ab, integer* ldab, doublereal* w, doublecomplex* z, integer* ldz, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zhbev(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublecomplex *ab_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer ldab;
  integer n;
  integer ldz;

  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  w, z, info, ab = NumRu::Lapack.zhbev( jobz, uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHBEV computes all the eigenvalues and, optionally, eigenvectors of\n*  a complex Hermitian band matrix A.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) COMPLEX*16 array, dimension (LDAB, N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*          On exit, AB is overwritten by values generated during the\n*          reduction to tridiagonal form.  If UPLO = 'U', the first\n*          superdiagonal and the diagonal of the tridiagonal matrix T\n*          are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n*          the diagonal and first subdiagonal of T are returned in the\n*          first two rows of AB.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD + 1.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) COMPLEX*16 array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n*          eigenvectors of the matrix A, with the i-th column of Z\n*          holding the eigenvector associated with W(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (max(1,3*N-2))\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 algorithm failed to converge; i\n*                off-diagonal elements of an intermediate tridiagonal\n*                form did not converge to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, info, ab = NumRu::Lapack.zhbev( jobz, uplo, kd, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_kd = argv[2];
  rblapack_ab = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  kd = NUM2INT(rblapack_kd);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
  MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  work = ALLOC_N(doublecomplex, (n));
  rwork = ALLOC_N(doublereal, (MAX(1,3*n-2)));

  zhbev_(&jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_w, rblapack_z, rblapack_info, rblapack_ab);
}

void
init_lapack_zhbev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhbev", rblapack_zhbev, -1);
}
ruby-lapack-1.7.2/ext/dlassq.c0000644000175000017500000000717412502221022016017 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlassq_(integer* n, doublereal* x, integer* incx, doublereal* scale, doublereal* sumsq);


static VALUE
rblapack_dlassq(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_scale;
  doublereal scale; 
  VALUE rblapack_sumsq;
  doublereal sumsq; 

  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  scale, sumsq = NumRu::Lapack.dlassq( x, incx, scale, sumsq, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ )\n\n*  Purpose\n*  =======\n*\n*  DLASSQ  returns the values  scl  and  smsq  such that\n*\n*     ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,\n*\n*  where  x( i ) = X( 1 + ( i - 1 )*INCX ). The value of  sumsq  is\n*  assumed to be non-negative and  scl  returns the value\n*\n*     scl = max( scale, abs( x( i ) ) ).\n*\n*  scale and sumsq must be supplied in SCALE and SUMSQ and\n*  scl and smsq are overwritten on SCALE and SUMSQ respectively.\n*\n*  The routine makes only one pass through the vector x.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of elements to be used from the vector X.\n*\n*  X       (input) DOUBLE PRECISION array, dimension (N)\n*          The vector for which a scaled sum of squares is computed.\n*             x( i )  = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.\n*\n*  INCX    (input) INTEGER\n*          The increment between successive values of the vector X.\n*          INCX > 0.\n*\n*  SCALE   (input/output) DOUBLE PRECISION\n*          On entry, the value  scale  in the equation above.\n*          On exit, SCALE is overwritten with  scl , the scaling factor\n*          for the sum of squares.\n*\n*  SUMSQ   (input/output) DOUBLE PRECISION\n*          On entry, the value  sumsq  in the equation above.\n*          On exit, SUMSQ is overwritten with  smsq , the basic sum of\n*          squares from which  scl  has been factored out.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, sumsq = NumRu::Lapack.dlassq( x, incx, scale, sumsq, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_x = argv[0];
  rblapack_incx = argv[1];
  rblapack_scale = argv[2];
  rblapack_sumsq = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (1th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  scale = NUM2DBL(rblapack_scale);
  incx = NUM2INT(rblapack_incx);
  sumsq = NUM2DBL(rblapack_sumsq);

  dlassq_(&n, x, &incx, &scale, &sumsq);

  rblapack_scale = rb_float_new((double)scale);
  rblapack_sumsq = rb_float_new((double)sumsq);
  return rb_ary_new3(2, rblapack_scale, rblapack_sumsq);
}

void
init_lapack_dlassq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlassq", rblapack_dlassq, -1);
}
ruby-lapack-1.7.2/ext/cheequb.c0000644000175000017500000001027712502221020016140 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cheequb_(char* uplo, integer* n, complex* a, integer* lda, real* s, real* scond, real* amax, complex* work, integer* info);


static VALUE
rblapack_cheequb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_scond;
  real scond; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_info;
  integer info; 
  complex *work;

  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  s, scond, amax, info = NumRu::Lapack.cheequb( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHEEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CSYEQUB computes row and column scalings intended to equilibrate a\n*  symmetric matrix A and reduce its condition number\n*  (with respect to the two-norm).  S contains the scale factors,\n*  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n*  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This\n*  choice of S puts the condition number of B within a factor N of the\n*  smallest possible condition number over all possible diagonal\n*  scalings.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The N-by-N symmetric matrix whose scaling\n*          factors are to be computed.  Only the diagonal elements of A\n*          are referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  S       (output) REAL array, dimension (N)\n*          If INFO = 0, S contains the scale factors for A.\n*\n*  SCOND   (output) REAL\n*          If INFO = 0, S contains the ratio of the smallest S(i) to\n*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too\n*          large nor too small, it is not worth scaling by S.\n*\n*  AMAX    (output) REAL\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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 is nonpositive.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, scond, amax, info = NumRu::Lapack.cheequb( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, real*);
  work = ALLOC_N(complex, (3*n));

  cheequb_(&uplo, &n, a, &lda, s, &scond, &amax, work, &info);

  free(work);
  rblapack_scond = rb_float_new((double)scond);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
}

void
init_lapack_cheequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cheequb", rblapack_cheequb, -1);
}
ruby-lapack-1.7.2/ext/clasyf.c0000644000175000017500000001427012502221016016007 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clasyf_(char* uplo, integer* n, integer* nb, integer* kb, complex* a, integer* lda, integer* ipiv, complex* w, integer* ldw, integer* info);


static VALUE
rblapack_clasyf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_nb;
  integer nb; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_kb;
  integer kb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  complex *w;

  integer lda;
  integer n;
  integer ldw;

  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  kb, ipiv, info, a = NumRu::Lapack.clasyf( uplo, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )\n\n*  Purpose\n*  =======\n*\n*  CLASYF computes a partial factorization of a complex symmetric matrix\n*  A using the Bunch-Kaufman diagonal pivoting method. The partial\n*  factorization has the form:\n*\n*  A  =  ( I  U12 ) ( A11  0  ) (  I    0   )  if UPLO = 'U', or:\n*        ( 0  U22 ) (  0   D  ) ( U12' U22' )\n*\n*  A  =  ( L11  0 ) ( D    0  ) ( L11' L21' )  if UPLO = 'L'\n*        ( L21  I ) ( 0   A22 ) (  0    I   )\n*\n*  where the order of D is at most NB. The actual order is returned in\n*  the argument KB, and is either NB or NB-1, or N if N <= NB.\n*  Note that U' denotes the transpose of U.\n*\n*  CLASYF is an auxiliary routine called by CSYTRF. It uses blocked code\n*  (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or\n*  A22 (if UPLO = 'L').\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored:\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NB      (input) INTEGER\n*          The maximum number of columns of the matrix A that should be\n*          factored.  NB should be at least 2 to allow for 2-by-2 pivot\n*          blocks.\n*\n*  KB      (output) INTEGER\n*          The number of columns of A that were actually factored.\n*          KB is either NB-1 or NB, or N if N <= NB.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          n-by-n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n-by-n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*          On exit, A contains details of the partial factorization.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D.\n*          If UPLO = 'U', only the last KB elements of IPIV are set;\n*          if UPLO = 'L', only the first KB elements are set.\n*\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*  W       (workspace) COMPLEX array, dimension (LDW,NB)\n*\n*  LDW     (input) INTEGER\n*          The leading dimension of the array W.  LDW >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          > 0: if INFO = k, D(k,k) is exactly zero.  The factorization\n*               has been completed, but the block diagonal matrix D is\n*               exactly singular.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  kb, ipiv, info, a = NumRu::Lapack.clasyf( uplo, nb, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_nb = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  nb = NUM2INT(rblapack_nb);
  ldw = MAX(1,n);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  w = ALLOC_N(complex, (ldw)*(MAX(1,nb)));

  clasyf_(&uplo, &n, &nb, &kb, a, &lda, ipiv, w, &ldw, &info);

  free(w);
  rblapack_kb = INT2NUM(kb);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_kb, rblapack_ipiv, rblapack_info, rblapack_a);
}

void
init_lapack_clasyf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clasyf", rblapack_clasyf, -1);
}
ruby-lapack-1.7.2/ext/zlantr.c0000644000175000017500000001233412502221025016037 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal zlantr_(char* norm, char* uplo, char* diag, integer* m, integer* n, doublecomplex* a, integer* lda, doublereal* work);


static VALUE
rblapack_zlantr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack___out__;
  doublereal __out__; 
  doublereal *work;

  integer lda;
  integer n;
  integer lwork;

  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  __out__ = NumRu::Lapack.zlantr( norm, uplo, diag, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION ZLANTR( NORM, UPLO, DIAG, M, N, A, LDA, WORK )\n\n*  Purpose\n*  =======\n*\n*  ZLANTR  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  trapezoidal or triangular matrix A.\n*\n*  Description\n*  ===========\n*\n*  ZLANTR returns the value\n*\n*     ZLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in ZLANTR as described\n*          above.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the matrix A is upper or lower trapezoidal.\n*          = 'U':  Upper trapezoidal\n*          = 'L':  Lower trapezoidal\n*          Note that A is triangular instead of trapezoidal if M = N.\n*\n*  DIAG    (input) CHARACTER*1\n*          Specifies whether or not the matrix A has unit diagonal.\n*          = 'N':  Non-unit diagonal\n*          = 'U':  Unit diagonal\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.  M >= 0, and if\n*          UPLO = 'U', M <= N.  When M = 0, ZLANTR is set to zero.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.  N >= 0, and if\n*          UPLO = 'L', N <= M.  When N = 0, ZLANTR is set to zero.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          The trapezoidal matrix A (A is triangular if M = N).\n*          If UPLO = 'U', the leading m by n upper trapezoidal part of\n*          the array A contains the upper trapezoidal matrix, and the\n*          strictly lower triangular part of A is not referenced.\n*          If UPLO = 'L', the leading m by n lower trapezoidal part of\n*          the array A contains the lower trapezoidal matrix, and the\n*          strictly upper triangular part of A is not referenced.  Note\n*          that when DIAG = 'U', the diagonal elements of A are not\n*          referenced and are assumed to be one.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(M,1).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n*          where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n*          referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.zlantr( norm, uplo, diag, m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_diag = argv[2];
  rblapack_m = argv[3];
  rblapack_a = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  m = NUM2INT(rblapack_m);
  lwork = lsame_(&norm,"I") ? m : 0;
  work = ALLOC_N(doublereal, (MAX(1,lwork)));

  __out__ = zlantr_(&norm, &uplo, &diag, &m, &n, a, &lda, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_zlantr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlantr", rblapack_zlantr, -1);
}
ruby-lapack-1.7.2/ext/zla_porcond_c.c0000644000175000017500000001554212502221016017345 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal zla_porcond_c_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, doublereal* c, logical* capply, integer* info, doublecomplex* work, doublereal* rwork);


static VALUE
rblapack_zla_porcond_c(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_capply;
  logical capply; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_rwork;
  doublereal *rwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack___out__;
  doublereal __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  info, __out__ = NumRu::Lapack.zla_porcond_c( uplo, a, af, c, capply, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION ZLA_PORCOND_C( UPLO, N, A, LDA, AF,  LDAF, C, CAPPLY, INFO, WORK, RWORK )\n\n*  Purpose\n*  =======\n*\n*     ZLA_PORCOND_C Computes the infinity norm condition number of\n*     op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector\n*\n\n*  Arguments\n*  =========\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     A       (input) COMPLEX*16 array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX*16 array, dimension (LDAF,N)\n*     The triangular factor U or L from the Cholesky factorization\n*     A = U**T*U or A = L*L**T, as computed by ZPOTRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     C       (input) DOUBLE PRECISION array, dimension (N)\n*     The vector C in the formula op(A) * inv(diag(C)).\n*\n*     CAPPLY  (input) LOGICAL\n*     If .TRUE. then access the vector C in the formula above.\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit.\n*     i > 0:  The ith argument is invalid.\n*\n*     WORK    (input) COMPLEX*16 array, dimension (2*N).\n*     Workspace.\n*\n*     RWORK   (input) DOUBLE PRECISION array, dimension (N).\n*     Workspace.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            KASE\n      DOUBLE PRECISION   AINVNM, ANORM, TMP\n      INTEGER            I, J\n      LOGICAL            UP\n      COMPLEX*16         ZDUM\n*     ..\n*     .. Local Arrays ..\n      INTEGER            ISAVE( 3 )\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           ZLACN2, ZPOTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX, REAL, DIMAG\n*     ..\n*     .. Statement Functions ..\n      DOUBLE PRECISION CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, __out__ = NumRu::Lapack.zla_porcond_c( uplo, a, af, c, capply, work, rwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_c = argv[3];
  rblapack_capply = argv[4];
  rblapack_work = argv[5];
  rblapack_rwork = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  capply = (rblapack_capply == Qtrue);
  if (!NA_IsNArray(rblapack_rwork))
    rb_raise(rb_eArgError, "rwork (7th argument) must be NArray");
  if (NA_RANK(rblapack_rwork) != 1)
    rb_raise(rb_eArgError, "rank of rwork (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_rwork) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_rwork) != NA_DFLOAT)
    rblapack_rwork = na_change_type(rblapack_rwork, NA_DFLOAT);
  rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (4th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (6th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
  if (NA_TYPE(rblapack_work) != NA_DCOMPLEX)
    rblapack_work = na_change_type(rblapack_work, NA_DCOMPLEX);
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);

  __out__ = zla_porcond_c_(&uplo, &n, a, &lda, af, &ldaf, c, &capply, &info, work, rwork);

  rblapack_info = INT2NUM(info);
  rblapack___out__ = rb_float_new((double)__out__);
  return rb_ary_new3(2, rblapack_info, rblapack___out__);
}

void
init_lapack_zla_porcond_c(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zla_porcond_c", rblapack_zla_porcond_c, -1);
}
ruby-lapack-1.7.2/ext/dptsvx.c0000644000175000017500000002654612502221015016066 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dptsvx_(char* fact, integer* n, integer* nrhs, doublereal* d, doublereal* e, doublereal* df, doublereal* ef, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublereal* work, integer* info);


static VALUE
rblapack_dptsvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_df;
  doublereal *df; 
  VALUE rblapack_ef;
  doublereal *ef; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_df_out__;
  doublereal *df_out__;
  VALUE rblapack_ef_out__;
  doublereal *ef_out__;
  doublereal *work;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, info, df, ef = NumRu::Lapack.dptsvx( fact, d, e, df, ef, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPTSVX uses the factorization A = L*D*L**T to compute the solution\n*  to a real system of linear equations A*X = B, where A is an N-by-N\n*  symmetric positive definite tridiagonal matrix and X and B are\n*  N-by-NRHS matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'N', the matrix A is factored as A = L*D*L**T, where L\n*     is a unit lower bidiagonal matrix and D is diagonal.  The\n*     factorization can also be regarded as having the form\n*     A = U**T*D*U.\n*\n*  2. If the leading i-by-i principal minor is not positive definite,\n*     then the routine returns with INFO = i. Otherwise, the factored\n*     form of A is used to estimate the condition number of the matrix\n*     A.  If the reciprocal of the condition number is less than machine\n*     precision, INFO = N+1 is returned as a warning, but the routine\n*     still goes on to solve for X and compute error bounds as\n*     described below.\n*\n*  3. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  4. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of A has been\n*          supplied on entry.\n*          = 'F':  On entry, DF and EF contain the factored form of A.\n*                  D, E, DF, and EF will not be modified.\n*          = 'N':  The matrix A will be copied to DF and EF and\n*                  factored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          The n diagonal elements of the tridiagonal matrix A.\n*\n*  E       (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (n-1) subdiagonal elements of the tridiagonal matrix A.\n*\n*  DF      (input or output) DOUBLE PRECISION array, dimension (N)\n*          If FACT = 'F', then DF is an input argument and on entry\n*          contains the n diagonal elements of the diagonal matrix D\n*          from the L*D*L**T factorization of A.\n*          If FACT = 'N', then DF is an output argument and on exit\n*          contains the n diagonal elements of the diagonal matrix D\n*          from the L*D*L**T factorization of A.\n*\n*  EF      (input or output) DOUBLE PRECISION array, dimension (N-1)\n*          If FACT = 'F', then EF is an input argument and on entry\n*          contains the (n-1) subdiagonal elements of the unit\n*          bidiagonal factor L from the L*D*L**T factorization of A.\n*          If FACT = 'N', then EF is an output argument and on exit\n*          contains the (n-1) subdiagonal elements of the unit\n*          bidiagonal factor L from the L*D*L**T factorization of A.\n*\n*  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          The N-by-NRHS right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*          If INFO = 0 of INFO = N+1, the N-by-NRHS solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The reciprocal condition number of the matrix A.  If RCOND\n*          is less than the machine precision (in particular, if\n*          RCOND = 0), the matrix is singular to working precision.\n*          This condition is indicated by a return code of INFO > 0.\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in any\n*          element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N)\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, and i is\n*                <= N:  the leading minor of order i of A is\n*                       not positive definite, so the factorization\n*                       could not be completed, and the solution has not\n*                       been computed. RCOND = 0 is returned.\n*                = N+1: U is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, info, df, ef = NumRu::Lapack.dptsvx( fact, d, e, df, ef, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_fact = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  rblapack_df = argv[3];
  rblapack_ef = argv[4];
  rblapack_b = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_df))
    rb_raise(rb_eArgError, "df (4th argument) must be NArray");
  if (NA_RANK(rblapack_df) != 1)
    rb_raise(rb_eArgError, "rank of df (4th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_df);
  if (NA_TYPE(rblapack_df) != NA_DFLOAT)
    rblapack_df = na_change_type(rblapack_df, NA_DFLOAT);
  df = NA_PTR_TYPE(rblapack_df, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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 (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of df");
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_ef))
    rb_raise(rb_eArgError, "ef (5th argument) must be NArray");
  if (NA_RANK(rblapack_ef) != 1)
    rb_raise(rb_eArgError, "rank of ef (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ef) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of ef must be %d", n-1);
  if (NA_TYPE(rblapack_ef) != NA_DFLOAT)
    rblapack_ef = na_change_type(rblapack_ef, NA_DFLOAT);
  ef = NA_PTR_TYPE(rblapack_ef, doublereal*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  ldx = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_df_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  df_out__ = NA_PTR_TYPE(rblapack_df_out__, doublereal*);
  MEMCPY(df_out__, df, doublereal, NA_TOTAL(rblapack_df));
  rblapack_df = rblapack_df_out__;
  df = df_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_ef_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ef_out__ = NA_PTR_TYPE(rblapack_ef_out__, doublereal*);
  MEMCPY(ef_out__, ef, doublereal, NA_TOTAL(rblapack_ef));
  rblapack_ef = rblapack_ef_out__;
  ef = ef_out__;
  work = ALLOC_N(doublereal, (2*n));

  dptsvx_(&fact, &n, &nrhs, d, e, df, ef, b, &ldb, x, &ldx, &rcond, ferr, berr, work, &info);

  free(work);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_df, rblapack_ef);
}

void
init_lapack_dptsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dptsvx", rblapack_dptsvx, -1);
}
ruby-lapack-1.7.2/ext/dla_porcond.c0000644000175000017500000001574712502221022017021 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal dla_porcond_(char* uplo, integer* n, doublereal* a, integer* lda, doublereal* af, integer* ldaf, integer* cmode, doublereal* c, integer* info, doublereal* work, integer* iwork);


static VALUE
rblapack_dla_porcond(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_af;
  doublereal *af; 
  VALUE rblapack_cmode;
  integer cmode; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack___out__;
  doublereal __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  info, __out__ = NumRu::Lapack.dla_porcond( uplo, a, af, cmode, c, work, iwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION DLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, CMODE, C, INFO, WORK, IWORK )\n\n*  Purpose\n*  =======\n*\n*     DLA_PORCOND Estimates the Skeel condition number of  op(A) * op2(C)\n*     where op2 is determined by CMODE as follows\n*     CMODE =  1    op2(C) = C\n*     CMODE =  0    op2(C) = I\n*     CMODE = -1    op2(C) = inv(C)\n*     The Skeel condition number  cond(A) = norminf( |inv(A)||A| )\n*     is computed by computing scaling factors R such that\n*     diag(R)*A*op2(C) is row equilibrated and computing the standard\n*     infinity-norm condition number.\n*\n\n*  Arguments\n*  ==========\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) DOUBLE PRECISION array, dimension (LDAF,N)\n*     The triangular factor U or L from the Cholesky factorization\n*     A = U**T*U or A = L*L**T, as computed by DPOTRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     CMODE   (input) INTEGER\n*     Determines op2(C) in the formula op(A) * op2(C) as follows:\n*     CMODE =  1    op2(C) = C\n*     CMODE =  0    op2(C) = I\n*     CMODE = -1    op2(C) = inv(C)\n*\n*     C       (input) DOUBLE PRECISION array, dimension (N)\n*     The vector C in the formula op(A) * op2(C).\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit.\n*     i > 0:  The ith argument is invalid.\n*\n*     WORK    (input) DOUBLE PRECISION array, dimension (3*N).\n*     Workspace.\n*\n*     IWORK   (input) INTEGER array, dimension (N).\n*     Workspace.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            KASE, I, J\n      DOUBLE PRECISION   AINVNM, TMP\n      LOGICAL            UP\n*     ..\n*     .. Array Arguments ..\n      INTEGER            ISAVE( 3 )\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            IDAMAX\n      EXTERNAL           LSAME, IDAMAX\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DLACN2, DPOTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, __out__ = NumRu::Lapack.dla_porcond( uplo, a, af, cmode, c, work, iwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_cmode = argv[3];
  rblapack_c = argv[4];
  rblapack_work = argv[5];
  rblapack_iwork = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_DFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
  af = NA_PTR_TYPE(rblapack_af, doublereal*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_iwork))
    rb_raise(rb_eArgError, "iwork (7th argument) must be NArray");
  if (NA_RANK(rblapack_iwork) != 1)
    rb_raise(rb_eArgError, "rank of iwork (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_iwork) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of iwork must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_iwork) != NA_LINT)
    rblapack_iwork = na_change_type(rblapack_iwork, NA_LINT);
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (6th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (3*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 3*n);
  if (NA_TYPE(rblapack_work) != NA_DFLOAT)
    rblapack_work = na_change_type(rblapack_work, NA_DFLOAT);
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  cmode = NUM2INT(rblapack_cmode);

  __out__ = dla_porcond_(&uplo, &n, a, &lda, af, &ldaf, &cmode, c, &info, work, iwork);

  rblapack_info = INT2NUM(info);
  rblapack___out__ = rb_float_new((double)__out__);
  return rb_ary_new3(2, rblapack_info, rblapack___out__);
}

void
init_lapack_dla_porcond(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dla_porcond", rblapack_dla_porcond, -1);
}
ruby-lapack-1.7.2/ext/slasd5.c0000644000175000017500000001046312502221016015721 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slasd5_(integer* i, real* d, real* z, real* delta, real* rho, real* dsigma, real* work);


static VALUE
rblapack_slasd5(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_i;
  integer i; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_rho;
  real rho; 
  VALUE rblapack_delta;
  real *delta; 
  VALUE rblapack_dsigma;
  real dsigma; 
  real *work;


  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  delta, dsigma = NumRu::Lapack.slasd5( i, d, z, rho, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK )\n\n*  Purpose\n*  =======\n*\n*  This subroutine computes the square root of the I-th eigenvalue\n*  of a positive symmetric rank-one modification of a 2-by-2 diagonal\n*  matrix\n*\n*             diag( D ) * diag( D ) +  RHO *  Z * transpose(Z) .\n*\n*  The diagonal entries in the array D are assumed to satisfy\n*\n*             0 <= D(i) < D(j)  for  i < j .\n*\n*  We also assume RHO > 0 and that the Euclidean norm of the vector\n*  Z is one.\n*\n\n*  Arguments\n*  =========\n*\n*  I      (input) INTEGER\n*         The index of the eigenvalue to be computed.  I = 1 or I = 2.\n*\n*  D      (input) REAL array, dimension (2)\n*         The original eigenvalues.  We assume 0 <= D(1) < D(2).\n*\n*  Z      (input) REAL array, dimension (2)\n*         The components of the updating vector.\n*\n*  DELTA  (output) REAL array, dimension (2)\n*         Contains (D(j) - sigma_I) in its  j-th component.\n*         The vector DELTA contains the information necessary\n*         to construct the eigenvectors.\n*\n*  RHO    (input) REAL\n*         The scalar in the symmetric updating formula.\n*\n*  DSIGMA (output) REAL\n*         The computed sigma_I, the I-th updated eigenvalue.\n*\n*  WORK   (workspace) REAL array, dimension (2)\n*         WORK contains (D(j) + sigma_I) in its  j-th component.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ren-Cang Li, Computer Science Division, University of California\n*     at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  delta, dsigma = NumRu::Lapack.slasd5( i, d, z, rho, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_i = argv[0];
  rblapack_d = argv[1];
  rblapack_z = argv[2];
  rblapack_rho = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  i = NUM2INT(rblapack_i);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (3th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != (2))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 2);
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != (2))
    rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", 2);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  rho = (real)NUM2DBL(rblapack_rho);
  {
    na_shape_t shape[1];
    shape[0] = 2;
    rblapack_delta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  delta = NA_PTR_TYPE(rblapack_delta, real*);
  work = ALLOC_N(real, (2));

  slasd5_(&i, d, z, delta, &rho, &dsigma, work);

  free(work);
  rblapack_dsigma = rb_float_new((double)dsigma);
  return rb_ary_new3(2, rblapack_delta, rblapack_dsigma);
}

void
init_lapack_slasd5(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slasd5", rblapack_slasd5, -1);
}
ruby-lapack-1.7.2/ext/dsterf.c0000644000175000017500000000771512502221015016022 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsterf_(integer* n, doublereal* d, doublereal* e, integer* info);


static VALUE
rblapack_dsterf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_e_out__;
  doublereal *e_out__;

  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  info, d, e = NumRu::Lapack.dsterf( d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSTERF( N, D, E, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSTERF computes all eigenvalues of a symmetric tridiagonal matrix\n*  using the Pal-Walker-Kahan variant of the QL or QR algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the n diagonal elements of the tridiagonal matrix.\n*          On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n*  E       (input/output) DOUBLE PRECISION array, dimension (N-1)\n*          On entry, the (n-1) subdiagonal elements of the tridiagonal\n*          matrix.\n*          On exit, E has been destroyed.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  the algorithm failed to find all of the eigenvalues in\n*                a total of 30*N iterations; if INFO = i, then i\n*                elements of E have not converged to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, e = NumRu::Lapack.dsterf( d, e, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_d = argv[0];
  rblapack_e = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (2th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
  MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;

  dsterf_(&n, d, e, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_d, rblapack_e);
}

void
init_lapack_dsterf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsterf", rblapack_dsterf, -1);
}
ruby-lapack-1.7.2/ext/dlaset.c0000644000175000017500000001043312502221014015775 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaset_(char* uplo, integer* m, integer* n, doublereal* alpha, doublereal* beta, doublereal* a, integer* lda);


static VALUE
rblapack_dlaset(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_alpha;
  doublereal alpha; 
  VALUE rblapack_beta;
  doublereal beta; 
  VALUE rblapack_a;
  doublereal *a; 
  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  a = NumRu::Lapack.dlaset( uplo, m, alpha, beta, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA )\n\n*  Purpose\n*  =======\n*\n*  DLASET initializes an m-by-n matrix A to BETA on the diagonal and\n*  ALPHA on the offdiagonals.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies the part of the matrix A to be set.\n*          = 'U':      Upper triangular part is set; the strictly lower\n*                      triangular part of A is not changed.\n*          = 'L':      Lower triangular part is set; the strictly upper\n*                      triangular part of A is not changed.\n*          Otherwise:  All of the matrix A is set.\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*  ALPHA   (input) DOUBLE PRECISION\n*          The constant to which the offdiagonal elements are to be set.\n*\n*  BETA    (input) DOUBLE PRECISION\n*          The constant to which the diagonal elements are to be set.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On exit, the leading m-by-n submatrix of A is set as follows:\n*\n*          if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n,\n*          if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n,\n*          otherwise,     A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j,\n*\n*          and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  a = NumRu::Lapack.dlaset( uplo, m, alpha, beta, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_m = argv[1];
  rblapack_alpha = argv[2];
  rblapack_beta = argv[3];
  rblapack_a = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  alpha = NUM2DBL(rblapack_alpha);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th 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);
  beta = NUM2DBL(rblapack_beta);
  {
    na_shape_t 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__;

  dlaset_(&uplo, &m, &n, &alpha, &beta, a, &lda);

  return rblapack_a;
}

void
init_lapack_dlaset(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaset", rblapack_dlaset, -1);
}
ruby-lapack-1.7.2/ext/dlaed0.c0000644000175000017500000002010112502221021015641 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaed0_(integer* icompq, integer* qsiz, integer* n, doublereal* d, doublereal* e, doublereal* q, integer* ldq, doublereal* qstore, integer* ldqs, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dlaed0(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_icompq;
  integer icompq; 
  VALUE rblapack_qsiz;
  integer qsiz; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_q;
  doublereal *q; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_q_out__;
  doublereal *q_out__;
  doublereal *qstore;
  doublereal *work;
  integer *iwork;

  integer n;
  integer ldq;
  integer ldqs;

  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  info, d, q = NumRu::Lapack.dlaed0( icompq, qsiz, d, e, q, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLAED0 computes all eigenvalues and corresponding eigenvectors of a\n*  symmetric tridiagonal matrix using the divide and conquer method.\n*\n\n*  Arguments\n*  =========\n*\n*  ICOMPQ  (input) INTEGER\n*          = 0:  Compute eigenvalues only.\n*          = 1:  Compute eigenvectors of original dense symmetric matrix\n*                also.  On entry, Q contains the orthogonal matrix used\n*                to reduce the original matrix to tridiagonal form.\n*          = 2:  Compute eigenvalues and eigenvectors of tridiagonal\n*                matrix.\n*\n*  QSIZ   (input) INTEGER\n*         The dimension of the orthogonal matrix used to reduce\n*         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.\n*\n*  N      (input) INTEGER\n*         The dimension of the symmetric tridiagonal matrix.  N >= 0.\n*\n*  D      (input/output) DOUBLE PRECISION array, dimension (N)\n*         On entry, the main diagonal of the tridiagonal matrix.\n*         On exit, its eigenvalues.\n*\n*  E      (input) DOUBLE PRECISION array, dimension (N-1)\n*         The off-diagonal elements of the tridiagonal matrix.\n*         On exit, E has been destroyed.\n*\n*  Q      (input/output) DOUBLE PRECISION array, dimension (LDQ, N)\n*         On entry, Q must contain an N-by-N orthogonal matrix.\n*         If ICOMPQ = 0    Q is not referenced.\n*         If ICOMPQ = 1    On entry, Q is a subset of the columns of the\n*                          orthogonal matrix used to reduce the full\n*                          matrix to tridiagonal form corresponding to\n*                          the subset of the full matrix which is being\n*                          decomposed at this time.\n*         If ICOMPQ = 2    On entry, Q will be the identity matrix.\n*                          On exit, Q contains the eigenvectors of the\n*                          tridiagonal matrix.\n*\n*  LDQ    (input) INTEGER\n*         The leading dimension of the array Q.  If eigenvectors are\n*         desired, then  LDQ >= max(1,N).  In any case,  LDQ >= 1.\n*\n*  QSTORE (workspace) DOUBLE PRECISION array, dimension (LDQS, N)\n*         Referenced only when ICOMPQ = 1.  Used to store parts of\n*         the eigenvector matrix when the updating matrix multiplies\n*         take place.\n*\n*  LDQS   (input) INTEGER\n*         The leading dimension of the array QSTORE.  If ICOMPQ = 1,\n*         then  LDQS >= max(1,N).  In any case,  LDQS >= 1.\n*\n*  WORK   (workspace) DOUBLE PRECISION array,\n*         If ICOMPQ = 0 or 1, the dimension of WORK must be at least\n*                     1 + 3*N + 2*N*lg N + 2*N**2\n*                     ( lg( N ) = smallest integer k\n*                                 such that 2^k >= N )\n*         If ICOMPQ = 2, the dimension of WORK must be at least\n*                     4*N + N**2.\n*\n*  IWORK  (workspace) INTEGER array,\n*         If ICOMPQ = 0 or 1, the dimension of IWORK must be at least\n*                        6 + 6*N + 5*N*lg N.\n*                        ( lg( N ) = smallest integer k\n*                                    such that 2^k >= N )\n*         If ICOMPQ = 2, the dimension of IWORK must be at least\n*                        3 + 5*N.\n*\n*  INFO   (output) INTEGER\n*          = 0:  successful exit.\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          > 0:  The algorithm failed to compute an eigenvalue while\n*                working on the submatrix lying in rows and columns\n*                INFO/(N+1) through mod(INFO,N+1).\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Jeff Rutter, Computer Science Division, University of California\n*     at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, q = NumRu::Lapack.dlaed0( icompq, qsiz, d, e, q, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_icompq = argv[0];
  rblapack_qsiz = argv[1];
  rblapack_d = argv[2];
  rblapack_e = argv[3];
  rblapack_q = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  icompq = NUM2INT(rblapack_icompq);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (5th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_q) != NA_DFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
  q = NA_PTR_TYPE(rblapack_q, doublereal*);
  qsiz = NUM2INT(rblapack_qsiz);
  ldqs = icompq == 1 ? MAX(1,n) : 1;
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (4th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
  MEMCPY(q_out__, q, doublereal, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  qstore = ALLOC_N(doublereal, (ldqs)*(n));
  work = ALLOC_N(doublereal, (((icompq == 0) || (icompq == 1)) ? 1 + 3*n + 2*n*LG(n) + 2*pow(n,2) : icompq == 2 ? 4*n + pow(n,2) : 0));
  iwork = ALLOC_N(integer, (((icompq == 0) || (icompq == 1)) ? 6 + 6*n + 5*n*LG(n) : icompq == 2 ? 3 + 5*n : 0));

  dlaed0_(&icompq, &qsiz, &n, d, e, q, &ldq, qstore, &ldqs, work, iwork, &info);

  free(qstore);
  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_d, rblapack_q);
}

void
init_lapack_dlaed0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaed0", rblapack_dlaed0, -1);
}
ruby-lapack-1.7.2/ext/zstedc.c0000644000175000017500000003004712502221016016022 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zstedc_(char* compz, integer* n, doublereal* d, doublereal* e, doublecomplex* z, integer* ldz, doublecomplex* work, integer* lwork, doublereal* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_zstedc(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_compz;
  char compz; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_lrwork;
  integer lrwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_rwork;
  doublereal *rwork; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_e_out__;
  doublereal *e_out__;
  VALUE rblapack_z_out__;
  doublecomplex *z_out__;

  integer n;
  integer ldz;

  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, rwork, iwork, info, d, e, z = NumRu::Lapack.zstedc( compz, d, e, z, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZSTEDC computes all eigenvalues and, optionally, eigenvectors of a\n*  symmetric tridiagonal matrix using the divide and conquer method.\n*  The eigenvectors of a full or band complex Hermitian matrix can also\n*  be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this\n*  matrix to tridiagonal form.\n*\n*  This code makes very mild assumptions about floating point\n*  arithmetic. It will work on machines with a guard digit in\n*  add/subtract, or on those binary machines without guard digits\n*  which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n*  It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.  See DLAED3 for details.\n*\n\n*  Arguments\n*  =========\n*\n*  COMPZ   (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only.\n*          = 'I':  Compute eigenvectors of tridiagonal matrix also.\n*          = 'V':  Compute eigenvectors of original Hermitian matrix\n*                  also.  On entry, Z contains the unitary matrix used\n*                  to reduce the original matrix to tridiagonal form.\n*\n*  N       (input) INTEGER\n*          The dimension of the symmetric tridiagonal matrix.  N >= 0.\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the diagonal elements of the tridiagonal matrix.\n*          On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n*  E       (input/output) DOUBLE PRECISION array, dimension (N-1)\n*          On entry, the subdiagonal elements of the tridiagonal matrix.\n*          On exit, E has been destroyed.\n*\n*  Z       (input/output) COMPLEX*16 array, dimension (LDZ,N)\n*          On entry, if COMPZ = 'V', then Z contains the unitary\n*          matrix used in the reduction to tridiagonal form.\n*          On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n*          orthonormal eigenvectors of the original Hermitian matrix,\n*          and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n*          of the symmetric tridiagonal matrix.\n*          If  COMPZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1.\n*          If eigenvectors are desired, then LDZ >= max(1,N).\n*\n*  WORK    (workspace/output) COMPLEX*16 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*          If COMPZ = 'N' or 'I', or N <= 1, LWORK must be at least 1.\n*          If COMPZ = 'V' and N > 1, LWORK must be at least N*N.\n*          Note that for COMPZ = 'V', then if N is less than or\n*          equal to the minimum divide size, usually 25, then LWORK need\n*          only be 1.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal sizes of the WORK, RWORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  RWORK   (workspace/output) DOUBLE PRECISION array,\n*                                         dimension (LRWORK)\n*          On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n*\n*  LRWORK  (input) INTEGER\n*          The dimension of the array RWORK.\n*          If COMPZ = 'N' or N <= 1, LRWORK must be at least 1.\n*          If COMPZ = 'V' and N > 1, LRWORK must be at least\n*                         1 + 3*N + 2*N*lg N + 3*N**2 ,\n*                         where lg( N ) = smallest integer k such\n*                         that 2**k >= N.\n*          If COMPZ = 'I' and N > 1, LRWORK must be at least\n*                         1 + 4*N + 2*N**2 .\n*          Note that for COMPZ = 'I' or 'V', then if N is less than or\n*          equal to the minimum divide size, usually 25, then LRWORK\n*          need only be max(1,2*(N-1)).\n*\n*          If LRWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.\n*          If COMPZ = 'N' or N <= 1, LIWORK must be at least 1.\n*          If COMPZ = 'V' or N > 1,  LIWORK must be at least\n*                                    6 + 6*N + 5*N*lg N.\n*          If COMPZ = 'I' or N > 1,  LIWORK must be at least\n*                                    3 + 5*N .\n*          Note that for COMPZ = 'I' or 'V', then if N is less than or\n*          equal to the minimum divide size, usually 25, then LIWORK\n*          need only be 1.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK 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:  The algorithm failed to compute an eigenvalue while\n*                working on the submatrix lying in rows and columns\n*                INFO/(N+1) through mod(INFO,N+1).\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Jeff Rutter, Computer Science Division, University of California\n*     at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, rwork, iwork, info, d, e, z = NumRu::Lapack.zstedc( compz, d, e, z, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_compz = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  rblapack_z = argv[3];
  if (argc == 7) {
    rblapack_lwork = argv[4];
    rblapack_lrwork = argv[5];
    rblapack_liwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_lrwork = Qnil;
    rblapack_liwork = Qnil;
  }

  compz = StringValueCStr(rblapack_compz)[0];
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (4th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  n = NA_SHAPE1(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_DCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of z");
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (rblapack_lwork == Qnil)
    lwork = (lsame_(&compz,"N")||lsame_(&compz,"I")||n<=1) ? 1 : lsame_(&compz,"V") ? n*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (rblapack_liwork == Qnil)
    liwork = (lsame_(&compz,"N")||n<=1) ? 1 : lsame_(&compz,"V") ? 6+6*n+5*n*LG(n) : lsame_(&compz,"I") ? 3+5*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  if (rblapack_lrwork == Qnil)
    lrwork = (lsame_(&compz,"N")||n<=1) ? 1 : lsame_(&compz,"V") ? 1+3*n+2*n*LG(n)+3*n*n : lsame_(&compz,"I") ? 1+4*n+2*n*n : 0;
  else {
    lrwork = NUM2INT(rblapack_lrwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lrwork);
    rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
  MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublecomplex*);
  MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  zstedc_(&compz, &n, d, e, z, &ldz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_work, rblapack_rwork, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e, rblapack_z);
}

void
init_lapack_zstedc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zstedc", rblapack_zstedc, -1);
}
ruby-lapack-1.7.2/ext/slaqps.c0000644000175000017500000002346512502221013016034 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaqps_(integer* m, integer* n, integer* offset, integer* nb, integer* kb, real* a, integer* lda, integer* jpvt, real* tau, real* vn1, real* vn2, real* auxv, real* f, integer* ldf);


static VALUE
rblapack_slaqps(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_offset;
  integer offset; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_jpvt;
  integer *jpvt; 
  VALUE rblapack_vn1;
  real *vn1; 
  VALUE rblapack_vn2;
  real *vn2; 
  VALUE rblapack_auxv;
  real *auxv; 
  VALUE rblapack_f;
  real *f; 
  VALUE rblapack_kb;
  integer kb; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_jpvt_out__;
  integer *jpvt_out__;
  VALUE rblapack_vn1_out__;
  real *vn1_out__;
  VALUE rblapack_vn2_out__;
  real *vn2_out__;
  VALUE rblapack_auxv_out__;
  real *auxv_out__;
  VALUE rblapack_f_out__;
  real *f_out__;

  integer lda;
  integer n;
  integer nb;
  integer ldf;

  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  kb, tau, a, jpvt, vn1, vn2, auxv, f = NumRu::Lapack.slaqps( m, offset, a, jpvt, vn1, vn2, auxv, f, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, VN2, AUXV, F, LDF )\n\n*  Purpose\n*  =======\n*\n*  SLAQPS computes a step of QR factorization with column pivoting\n*  of a real M-by-N matrix A by using Blas-3.  It tries to factorize\n*  NB columns from A starting from the row OFFSET+1, and updates all\n*  of the matrix with Blas-3 xGEMM.\n*\n*  In some cases, due to catastrophic cancellations, it cannot\n*  factorize NB columns.  Hence, the actual number of factorized\n*  columns is returned in KB.\n*\n*  Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\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*  OFFSET  (input) INTEGER\n*          The number of rows of A that have been factorized in\n*          previous steps.\n*\n*  NB      (input) INTEGER\n*          The number of columns to factorize.\n*\n*  KB      (output) INTEGER\n*          The number of columns actually factorized.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, block A(OFFSET+1:M,1:KB) is the triangular\n*          factor obtained and block A(1:OFFSET,1:N) has been\n*          accordingly pivoted, but no factorized.\n*          The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has\n*          been updated.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  JPVT    (input/output) INTEGER array, dimension (N)\n*          JPVT(I) = K <==> Column K of the full matrix A has been\n*          permuted into position I in AP.\n*\n*  TAU     (output) REAL array, dimension (KB)\n*          The scalar factors of the elementary reflectors.\n*\n*  VN1     (input/output) REAL array, dimension (N)\n*          The vector with the partial column norms.\n*\n*  VN2     (input/output) REAL array, dimension (N)\n*          The vector with the exact column norms.\n*\n*  AUXV    (input/output) REAL array, dimension (NB)\n*          Auxiliar vector.\n*\n*  F       (input/output) REAL array, dimension (LDF,NB)\n*          Matrix F' = L*Y'*A.\n*\n*  LDF     (input) INTEGER\n*          The leading dimension of the array F. LDF >= max(1,N).\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n*    X. Sun, Computer Science Dept., Duke University, USA\n*\n*  Partial column norm updating strategy modified by\n*    Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n*    University of Zagreb, Croatia.\n*     June 2010\n*  For more details see LAPACK Working Note 176.\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  kb, tau, a, jpvt, vn1, vn2, auxv, f = NumRu::Lapack.slaqps( m, offset, a, jpvt, vn1, vn2, auxv, f, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_m = argv[0];
  rblapack_offset = argv[1];
  rblapack_a = argv[2];
  rblapack_jpvt = argv[3];
  rblapack_vn1 = argv[4];
  rblapack_vn2 = argv[5];
  rblapack_auxv = argv[6];
  rblapack_f = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_vn1))
    rb_raise(rb_eArgError, "vn1 (5th argument) must be NArray");
  if (NA_RANK(rblapack_vn1) != 1)
    rb_raise(rb_eArgError, "rank of vn1 (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_vn1) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of vn1 must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_vn1) != NA_SFLOAT)
    rblapack_vn1 = na_change_type(rblapack_vn1, NA_SFLOAT);
  vn1 = NA_PTR_TYPE(rblapack_vn1, real*);
  if (!NA_IsNArray(rblapack_auxv))
    rb_raise(rb_eArgError, "auxv (7th argument) must be NArray");
  if (NA_RANK(rblapack_auxv) != 1)
    rb_raise(rb_eArgError, "rank of auxv (7th argument) must be %d", 1);
  nb = NA_SHAPE0(rblapack_auxv);
  if (NA_TYPE(rblapack_auxv) != NA_SFLOAT)
    rblapack_auxv = na_change_type(rblapack_auxv, NA_SFLOAT);
  auxv = NA_PTR_TYPE(rblapack_auxv, real*);
  offset = NUM2INT(rblapack_offset);
  if (!NA_IsNArray(rblapack_vn2))
    rb_raise(rb_eArgError, "vn2 (6th argument) must be NArray");
  if (NA_RANK(rblapack_vn2) != 1)
    rb_raise(rb_eArgError, "rank of vn2 (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_vn2) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of vn2 must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_vn2) != NA_SFLOAT)
    rblapack_vn2 = na_change_type(rblapack_vn2, NA_SFLOAT);
  vn2 = NA_PTR_TYPE(rblapack_vn2, real*);
  if (!NA_IsNArray(rblapack_jpvt))
    rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
  if (NA_RANK(rblapack_jpvt) != 1)
    rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_jpvt) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_jpvt) != NA_LINT)
    rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
  jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
  if (!NA_IsNArray(rblapack_f))
    rb_raise(rb_eArgError, "f (8th argument) must be NArray");
  if (NA_RANK(rblapack_f) != 2)
    rb_raise(rb_eArgError, "rank of f (8th argument) must be %d", 2);
  ldf = NA_SHAPE0(rblapack_f);
  if (NA_SHAPE1(rblapack_f) != nb)
    rb_raise(rb_eRuntimeError, "shape 1 of f must be the same as shape 0 of auxv");
  if (NA_TYPE(rblapack_f) != NA_SFLOAT)
    rblapack_f = na_change_type(rblapack_f, NA_SFLOAT);
  f = NA_PTR_TYPE(rblapack_f, real*);
  kb = nb;
  {
    na_shape_t shape[1];
    shape[0] = kb;
    rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
  MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
  rblapack_jpvt = rblapack_jpvt_out__;
  jpvt = jpvt_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_vn1_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  vn1_out__ = NA_PTR_TYPE(rblapack_vn1_out__, real*);
  MEMCPY(vn1_out__, vn1, real, NA_TOTAL(rblapack_vn1));
  rblapack_vn1 = rblapack_vn1_out__;
  vn1 = vn1_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_vn2_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  vn2_out__ = NA_PTR_TYPE(rblapack_vn2_out__, real*);
  MEMCPY(vn2_out__, vn2, real, NA_TOTAL(rblapack_vn2));
  rblapack_vn2 = rblapack_vn2_out__;
  vn2 = vn2_out__;
  {
    na_shape_t shape[1];
    shape[0] = nb;
    rblapack_auxv_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  auxv_out__ = NA_PTR_TYPE(rblapack_auxv_out__, real*);
  MEMCPY(auxv_out__, auxv, real, NA_TOTAL(rblapack_auxv));
  rblapack_auxv = rblapack_auxv_out__;
  auxv = auxv_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldf;
    shape[1] = nb;
    rblapack_f_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  f_out__ = NA_PTR_TYPE(rblapack_f_out__, real*);
  MEMCPY(f_out__, f, real, NA_TOTAL(rblapack_f));
  rblapack_f = rblapack_f_out__;
  f = f_out__;

  slaqps_(&m, &n, &offset, &nb, &kb, a, &lda, jpvt, tau, vn1, vn2, auxv, f, &ldf);

  rblapack_kb = INT2NUM(kb);
  return rb_ary_new3(8, rblapack_kb, rblapack_tau, rblapack_a, rblapack_jpvt, rblapack_vn1, rblapack_vn2, rblapack_auxv, rblapack_f);
}

void
init_lapack_slaqps(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaqps", rblapack_slaqps, -1);
}
ruby-lapack-1.7.2/ext/strrfs.c0000644000175000017500000001645312502221025016056 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID strrfs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, real* a, integer* lda, real* b, integer* ldb, real* x, integer* ldx, real* ferr, real* berr, real* work, integer* iwork, integer* info);


static VALUE
rblapack_strrfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  real *work;
  integer *iwork;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info = NumRu::Lapack.strrfs( uplo, trans, diag, a, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  STRRFS provides error bounds and backward error estimates for the\n*  solution to a system of linear equations with a triangular\n*  coefficient matrix.\n*\n*  The solution matrix X must be computed by STRTRS or some other\n*  means before entering this routine.  STRRFS does not do iterative\n*  refinement because doing so cannot improve the backward error.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B  (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input) REAL array, dimension (LDA,N)\n*          The triangular matrix A.  If UPLO = 'U', the leading N-by-N\n*          upper triangular part of the array A contains the upper\n*          triangular matrix, and the strictly lower triangular part of\n*          A is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*          triangular part of the array A contains the lower triangular\n*          matrix, and the strictly upper triangular part of A is not\n*          referenced.  If DIAG = 'U', the diagonal elements of A are\n*          also not referenced and are assumed to be 1.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input) REAL array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input) REAL array, dimension (LDX,NRHS)\n*          The solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) REAL array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info = NumRu::Lapack.strrfs( uplo, trans, diag, a, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  work = ALLOC_N(real, (3*n));
  iwork = ALLOC_N(integer, (n));

  strrfs_(&uplo, &trans, &diag, &n, &nrhs, a, &lda, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ferr, rblapack_berr, rblapack_info);
}

void
init_lapack_strrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "strrfs", rblapack_strrfs, -1);
}
ruby-lapack-1.7.2/ext/zlauu2.c0000644000175000017500000000740612502221015015752 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlauu2_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* info);


static VALUE
rblapack_zlauu2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *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  info, a = NumRu::Lapack.zlauu2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAUU2( UPLO, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZLAUU2 computes the product U * U' or L' * L, where the triangular\n*  factor U or L is stored in the upper or lower triangular part of\n*  the array A.\n*\n*  If UPLO = 'U' or 'u' then the upper triangle of the result is stored,\n*  overwriting the factor U in A.\n*  If UPLO = 'L' or 'l' then the lower triangle of the result is stored,\n*  overwriting the factor L in A.\n*\n*  This is the unblocked form of the algorithm, calling Level 2 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the triangular factor stored in the array A\n*          is upper or lower triangular:\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the triangular factor U or L.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the triangular factor U or L.\n*          On exit, if UPLO = 'U', the upper triangle of A is\n*          overwritten with the upper triangle of the product U * U';\n*          if UPLO = 'L', the lower triangle of A is overwritten with\n*          the lower triangle of the product L' * L.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.zlauu2( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zlauu2_(&uplo, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_zlauu2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlauu2", rblapack_zlauu2, -1);
}
ruby-lapack-1.7.2/ext/ssytri.c0000644000175000017500000001117712502221014016064 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssytri_(char* uplo, integer* n, real* a, integer* lda, integer* ipiv, real* work, integer* info);


static VALUE
rblapack_ssytri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  real *work;

  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  info, a = NumRu::Lapack.ssytri( uplo, a, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSYTRI computes the inverse of a real symmetric indefinite matrix\n*  A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n*  SSYTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the block diagonal matrix D and the multipliers\n*          used to obtain the factor U or L as computed by SSYTRF.\n*\n*          On exit, if INFO = 0, the (symmetric) inverse of the original\n*          matrix.  If UPLO = 'U', the upper triangular part of the\n*          inverse is formed and the part of A below the diagonal is not\n*          referenced; if UPLO = 'L' the lower triangular part of the\n*          inverse is formed and the part of A above the diagonal is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by SSYTRF.\n*\n*  WORK    (workspace) REAL array, dimension (N)\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, D(i,i) = 0; the matrix is singular and its\n*               inverse could not be computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.ssytri( uplo, a, ipiv, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(real, (n));

  ssytri_(&uplo, &n, a, &lda, ipiv, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_ssytri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssytri", rblapack_ssytri, -1);
}
ruby-lapack-1.7.2/ext/dpoequb.c0000644000175000017500000001012412502221024016156 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dpoequb_(integer* n, doublereal* a, integer* lda, doublereal* s, doublereal* scond, doublereal* amax, integer* info);


static VALUE
rblapack_dpoequb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_scond;
  doublereal scond; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_info;
  integer info; 

  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  s, scond, amax, info = NumRu::Lapack.dpoequb( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPOEQU computes row and column scalings intended to equilibrate a\n*  symmetric positive definite matrix A and reduce its condition number\n*  (with respect to the two-norm).  S contains the scale factors,\n*  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n*  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This\n*  choice of S puts the condition number of B within a factor N of the\n*  smallest possible condition number over all possible diagonal\n*  scalings.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*          The N-by-N symmetric positive definite matrix whose scaling\n*          factors are to be computed.  Only the diagonal elements of A\n*          are referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  S       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, S contains the scale factors for A.\n*\n*  SCOND   (output) DOUBLE PRECISION\n*          If INFO = 0, S contains the ratio of the smallest S(i) to\n*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too\n*          large nor too small, it is not worth scaling by S.\n*\n*  AMAX    (output) DOUBLE PRECISION\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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 is nonpositive.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, scond, amax, info = NumRu::Lapack.dpoequb( 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*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, doublereal*);

  dpoequb_(&n, a, &lda, s, &scond, &amax, &info);

  rblapack_scond = rb_float_new((double)scond);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
}

void
init_lapack_dpoequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dpoequb", rblapack_dpoequb, -1);
}
ruby-lapack-1.7.2/ext/slarrd.c0000644000175000017500000003617212502221021016016 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slarrd_(char* range, char* order, integer* n, real* vl, real* vu, integer* il, integer* iu, real* gers, real* reltol, real* d, real* e, real* e2, real* pivmin, integer* nsplit, integer* isplit, integer* m, real* w, real* werr, real* wl, real* wu, integer* iblock, integer* indexw, real* work, integer* iwork, integer* info);


static VALUE
rblapack_slarrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_order;
  char order; 
  VALUE rblapack_vl;
  real vl; 
  VALUE rblapack_vu;
  real vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_gers;
  real *gers; 
  VALUE rblapack_reltol;
  real reltol; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_e2;
  real *e2; 
  VALUE rblapack_pivmin;
  real pivmin; 
  VALUE rblapack_nsplit;
  integer nsplit; 
  VALUE rblapack_isplit;
  integer *isplit; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_werr;
  real *werr; 
  VALUE rblapack_wl;
  real wl; 
  VALUE rblapack_wu;
  real wu; 
  VALUE rblapack_iblock;
  integer *iblock; 
  VALUE rblapack_indexw;
  integer *indexw; 
  VALUE rblapack_info;
  integer info; 
  real *work;
  integer *iwork;

  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  m, w, werr, wl, wu, iblock, indexw, info = NumRu::Lapack.slarrd( range, order, vl, vu, il, iu, gers, reltol, d, e, e2, pivmin, nsplit, isplit, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLARRD( RANGE, ORDER, N, VL, VU, IL, IU, GERS, RELTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT, M, W, WERR, WL, WU, IBLOCK, INDEXW, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLARRD computes the eigenvalues of a symmetric tridiagonal\n*  matrix T to suitable accuracy. This is an auxiliary code to be\n*  called from SSTEMR.\n*  The user may ask for all eigenvalues, all eigenvalues\n*  in the half-open interval (VL, VU], or the IL-th through IU-th\n*  eigenvalues.\n*\n*  To avoid overflow, the matrix must be scaled so that its\n*  largest element is no greater than overflow**(1/2) *\n*  underflow**(1/4) in absolute value, and for greatest\n*  accuracy, it should not be much smaller than that.\n*\n*  See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n*  Matrix\", Report CS41, Computer Science Dept., Stanford\n*  University, July 21, 1966.\n*\n\n*  Arguments\n*  =========\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': (\"All\")   all eigenvalues will be found.\n*          = 'V': (\"Value\") all eigenvalues in the half-open interval\n*                           (VL, VU] will be found.\n*          = 'I': (\"Index\") the IL-th through IU-th eigenvalues (of the\n*                           entire matrix) will be found.\n*\n*  ORDER   (input) CHARACTER*1\n*          = 'B': (\"By Block\") the eigenvalues will be grouped by\n*                              split-off block (see IBLOCK, ISPLIT) and\n*                              ordered from smallest to largest within\n*                              the block.\n*          = 'E': (\"Entire matrix\")\n*                              the eigenvalues for the entire matrix\n*                              will be ordered from smallest to\n*                              largest.\n*\n*  N       (input) INTEGER\n*          The order of the tridiagonal matrix T.  N >= 0.\n*\n*  VL      (input) REAL            \n*  VU      (input) REAL            \n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues.  Eigenvalues less than or equal\n*          to VL, or greater than VU, will not be returned.  VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  GERS    (input) REAL             array, dimension (2*N)\n*          The N Gerschgorin intervals (the i-th Gerschgorin interval\n*          is (GERS(2*i-1), GERS(2*i)).\n*\n*  RELTOL  (input) REAL            \n*          The minimum relative width of an interval.  When an interval\n*          is narrower than RELTOL times the larger (in\n*          magnitude) endpoint, then it is considered to be\n*          sufficiently small, i.e., converged.  Note: this should\n*          always be at least radix*machine epsilon.\n*\n*  D       (input) REAL             array, dimension (N)\n*          The n diagonal elements of the tridiagonal matrix T.\n*\n*  E       (input) REAL             array, dimension (N-1)\n*          The (n-1) off-diagonal elements of the tridiagonal matrix T.\n*\n*  E2      (input) REAL             array, dimension (N-1)\n*          The (n-1) squared off-diagonal elements of the tridiagonal matrix T.\n*\n*  PIVMIN  (input) REAL            \n*          The minimum pivot allowed in the Sturm sequence for T.\n*\n*  NSPLIT  (input) INTEGER\n*          The number of diagonal blocks in the matrix T.\n*          1 <= NSPLIT <= N.\n*\n*  ISPLIT  (input) INTEGER array, dimension (N)\n*          The splitting points, at which T breaks up into submatrices.\n*          The first submatrix consists of rows/columns 1 to ISPLIT(1),\n*          the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n*          etc., and the NSPLIT-th consists of rows/columns\n*          ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n*          (Only the first NSPLIT elements will actually be used, but\n*          since the user cannot know a priori what value NSPLIT will\n*          have, N words must be reserved for ISPLIT.)\n*\n*  M       (output) INTEGER\n*          The actual number of eigenvalues found. 0 <= M <= N.\n*          (See also the description of INFO=2,3.)\n*\n*  W       (output) REAL             array, dimension (N)\n*          On exit, the first M elements of W will contain the\n*          eigenvalue approximations. SLARRD computes an interval\n*          I_j = (a_j, b_j] that includes eigenvalue j. The eigenvalue\n*          approximation is given as the interval midpoint\n*          W(j)= ( a_j + b_j)/2. The corresponding error is bounded by\n*          WERR(j) = abs( a_j - b_j)/2\n*\n*  WERR    (output) REAL             array, dimension (N)\n*          The error bound on the corresponding eigenvalue approximation\n*          in W.\n*\n*  WL      (output) REAL            \n*  WU      (output) REAL            \n*          The interval (WL, WU] contains all the wanted eigenvalues.\n*          If RANGE='V', then WL=VL and WU=VU.\n*          If RANGE='A', then WL and WU are the global Gerschgorin bounds\n*                        on the spectrum.\n*          If RANGE='I', then WL and WU are computed by SLAEBZ from the\n*                        index range specified.\n*\n*  IBLOCK  (output) INTEGER array, dimension (N)\n*          At each row/column j where E(j) is zero or small, the\n*          matrix T is considered to split into a block diagonal\n*          matrix.  On exit, if INFO = 0, IBLOCK(i) specifies to which\n*          block (from 1 to the number of blocks) the eigenvalue W(i)\n*          belongs.  (SLARRD may use the remaining N-M elements as\n*          workspace.)\n*\n*  INDEXW  (output) INTEGER array, dimension (N)\n*          The indices of the eigenvalues within each block (submatrix);\n*          for example, INDEXW(i)= j and IBLOCK(i)=k imply that the\n*          i-th eigenvalue W(i) is the j-th eigenvalue in block k.\n*\n*  WORK    (workspace) REAL             array, dimension (4*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (3*N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  some or all of the eigenvalues failed to converge or\n*                were not computed:\n*                =1 or 3: Bisection failed to converge for some\n*                        eigenvalues; these eigenvalues are flagged by a\n*                        negative block number.  The effect is that the\n*                        eigenvalues may not be as accurate as the\n*                        absolute and relative tolerances.  This is\n*                        generally caused by unexpectedly inaccurate\n*                        arithmetic.\n*                =2 or 3: RANGE='I' only: Not all of the eigenvalues\n*                        IL:IU were found.\n*                        Effect: M < IU+1-IL\n*                        Cause:  non-monotonic arithmetic, causing the\n*                                Sturm sequence to be non-monotonic.\n*                        Cure:   recalculate, using RANGE='A', and pick\n*                                out eigenvalues IL:IU.  In some cases,\n*                                increasing the PARAMETER \"FUDGE\" may\n*                                make things work.\n*                = 4:    RANGE='I', and the Gershgorin interval\n*                        initially used was too small.  No eigenvalues\n*                        were computed.\n*                        Probable cause: your machine has sloppy\n*                                        floating-point arithmetic.\n*                        Cure: Increase the PARAMETER \"FUDGE\",\n*                              recompile, and try again.\n*\n*  Internal Parameters\n*  ===================\n*\n*  FUDGE   REAL            , default = 2\n*          A \"fudge factor\" to widen the Gershgorin intervals.  Ideally,\n*          a value of 1 should work, but on machines with sloppy\n*          arithmetic, this needs to be larger.  The default for\n*          publicly released versions should be large enough to handle\n*          the worst machine around.  Note that this has no effect\n*          on accuracy of the solution.\n*\n*  Based on contributions by\n*     W. Kahan, University of California, Berkeley, USA\n*     Beresford Parlett, University of California, Berkeley, USA\n*     Jim Demmel, University of California, Berkeley, USA\n*     Inderjit Dhillon, University of Texas, Austin, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, werr, wl, wu, iblock, indexw, info = NumRu::Lapack.slarrd( range, order, vl, vu, il, iu, gers, reltol, d, e, e2, pivmin, nsplit, isplit, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 14 && argc != 14)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 14)", argc);
  rblapack_range = argv[0];
  rblapack_order = argv[1];
  rblapack_vl = argv[2];
  rblapack_vu = argv[3];
  rblapack_il = argv[4];
  rblapack_iu = argv[5];
  rblapack_gers = argv[6];
  rblapack_reltol = argv[7];
  rblapack_d = argv[8];
  rblapack_e = argv[9];
  rblapack_e2 = argv[10];
  rblapack_pivmin = argv[11];
  rblapack_nsplit = argv[12];
  rblapack_isplit = argv[13];
  if (argc == 14) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  range = StringValueCStr(rblapack_range)[0];
  vl = (real)NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  reltol = (real)NUM2DBL(rblapack_reltol);
  pivmin = (real)NUM2DBL(rblapack_pivmin);
  if (!NA_IsNArray(rblapack_isplit))
    rb_raise(rb_eArgError, "isplit (14th argument) must be NArray");
  if (NA_RANK(rblapack_isplit) != 1)
    rb_raise(rb_eArgError, "rank of isplit (14th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_isplit);
  if (NA_TYPE(rblapack_isplit) != NA_LINT)
    rblapack_isplit = na_change_type(rblapack_isplit, NA_LINT);
  isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
  order = StringValueCStr(rblapack_order)[0];
  iu = NUM2INT(rblapack_iu);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (9th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of isplit");
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_e2))
    rb_raise(rb_eArgError, "e2 (11th argument) must be NArray");
  if (NA_RANK(rblapack_e2) != 1)
    rb_raise(rb_eArgError, "rank of e2 (11th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e2) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e2 must be %d", n-1);
  if (NA_TYPE(rblapack_e2) != NA_SFLOAT)
    rblapack_e2 = na_change_type(rblapack_e2, NA_SFLOAT);
  e2 = NA_PTR_TYPE(rblapack_e2, real*);
  vu = (real)NUM2DBL(rblapack_vu);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (10th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (10th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  if (!NA_IsNArray(rblapack_gers))
    rb_raise(rb_eArgError, "gers (7th argument) must be NArray");
  if (NA_RANK(rblapack_gers) != 1)
    rb_raise(rb_eArgError, "rank of gers (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_gers) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of gers must be %d", 2*n);
  if (NA_TYPE(rblapack_gers) != NA_SFLOAT)
    rblapack_gers = na_change_type(rblapack_gers, NA_SFLOAT);
  gers = NA_PTR_TYPE(rblapack_gers, real*);
  nsplit = NUM2INT(rblapack_nsplit);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_werr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  werr = NA_PTR_TYPE(rblapack_werr, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_iblock = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iblock = NA_PTR_TYPE(rblapack_iblock, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_indexw = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  indexw = NA_PTR_TYPE(rblapack_indexw, integer*);
  work = ALLOC_N(real, (4*n));
  iwork = ALLOC_N(integer, (3*n));

  slarrd_(&range, &order, &n, &vl, &vu, &il, &iu, gers, &reltol, d, e, e2, &pivmin, &nsplit, isplit, &m, w, werr, &wl, &wu, iblock, indexw, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_wl = rb_float_new((double)wl);
  rblapack_wu = rb_float_new((double)wu);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_m, rblapack_w, rblapack_werr, rblapack_wl, rblapack_wu, rblapack_iblock, rblapack_indexw, rblapack_info);
}

void
init_lapack_slarrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slarrd", rblapack_slarrd, -1);
}
ruby-lapack-1.7.2/ext/cbdsqr.c0000644000175000017500000002653112502221015016006 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cbdsqr_(char* uplo, integer* n, integer* ncvt, integer* nru, integer* ncc, real* d, real* e, complex* vt, integer* ldvt, complex* u, integer* ldu, complex* c, integer* ldc, real* rwork, integer* info);


static VALUE
rblapack_cbdsqr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_nru;
  integer nru; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_vt;
  complex *vt; 
  VALUE rblapack_u;
  complex *u; 
  VALUE rblapack_c;
  complex *c; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_e_out__;
  real *e_out__;
  VALUE rblapack_vt_out__;
  complex *vt_out__;
  VALUE rblapack_u_out__;
  complex *u_out__;
  VALUE rblapack_c_out__;
  complex *c_out__;
  real *rwork;

  integer n;
  integer ldvt;
  integer ncvt;
  integer ldu;
  integer ldc;
  integer ncc;

  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  info, d, e, vt, u, c = NumRu::Lapack.cbdsqr( uplo, nru, d, e, vt, u, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CBDSQR computes the singular values and, optionally, the right and/or\n*  left singular vectors from the singular value decomposition (SVD) of\n*  a real N-by-N (upper or lower) bidiagonal matrix B using the implicit\n*  zero-shift QR algorithm.  The SVD of B has the form\n*  \n*     B = Q * S * P**H\n*  \n*  where S is the diagonal matrix of singular values, Q is an orthogonal\n*  matrix of left singular vectors, and P is an orthogonal matrix of\n*  right singular vectors.  If left singular vectors are requested, this\n*  subroutine actually returns U*Q instead of Q, and, if right singular\n*  vectors are requested, this subroutine returns P**H*VT instead of\n*  P**H, for given complex input matrices U and VT.  When U and VT are\n*  the unitary matrices that reduce a general matrix A to bidiagonal\n*  form: A = U*B*VT, as computed by CGEBRD, then\n*  \n*     A = (U*Q) * S * (P**H*VT)\n*  \n*  is the SVD of A.  Optionally, the subroutine may also compute Q**H*C\n*  for a given complex input matrix C.\n*\n*  See \"Computing  Small Singular Values of Bidiagonal Matrices With\n*  Guaranteed High Relative Accuracy,\" by J. Demmel and W. Kahan,\n*  LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,\n*  no. 5, pp. 873-912, Sept 1990) and\n*  \"Accurate singular values and differential qd algorithms,\" by\n*  B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics\n*  Department, University of California at Berkeley, July 1992\n*  for a detailed description of the algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  B is upper bidiagonal;\n*          = 'L':  B is lower bidiagonal.\n*\n*  N       (input) INTEGER\n*          The order of the matrix B.  N >= 0.\n*\n*  NCVT    (input) INTEGER\n*          The number of columns of the matrix VT. NCVT >= 0.\n*\n*  NRU     (input) INTEGER\n*          The number of rows of the matrix U. NRU >= 0.\n*\n*  NCC     (input) INTEGER\n*          The number of columns of the matrix C. NCC >= 0.\n*\n*  D       (input/output) REAL array, dimension (N)\n*          On entry, the n diagonal elements of the bidiagonal matrix B.\n*          On exit, if INFO=0, the singular values of B in decreasing\n*          order.\n*\n*  E       (input/output) REAL array, dimension (N-1)\n*          On entry, the N-1 offdiagonal elements of the bidiagonal\n*          matrix B.\n*          On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E\n*          will contain the diagonal and superdiagonal elements of a\n*          bidiagonal matrix orthogonally equivalent to the one given\n*          as input.\n*\n*  VT      (input/output) COMPLEX array, dimension (LDVT, NCVT)\n*          On entry, an N-by-NCVT matrix VT.\n*          On exit, VT is overwritten by P**H * VT.\n*          Not referenced if NCVT = 0.\n*\n*  LDVT    (input) INTEGER\n*          The leading dimension of the array VT.\n*          LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.\n*\n*  U       (input/output) COMPLEX array, dimension (LDU, N)\n*          On entry, an NRU-by-N matrix U.\n*          On exit, U is overwritten by U * Q.\n*          Not referenced if NRU = 0.\n*\n*  LDU     (input) INTEGER\n*          The leading dimension of the array U.  LDU >= max(1,NRU).\n*\n*  C       (input/output) COMPLEX array, dimension (LDC, NCC)\n*          On entry, an N-by-NCC matrix C.\n*          On exit, C is overwritten by Q**H * C.\n*          Not referenced if NCC = 0.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C.\n*          LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.\n*\n*  RWORK   (workspace) REAL array, dimension (2*N) \n*          if NCVT = NRU = NCC = 0, (max(1, 4*N-4)) otherwise\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  If INFO = -i, the i-th argument had an illegal value\n*          > 0:  the algorithm did not converge; D and E contain the\n*                elements of a bidiagonal matrix which is orthogonally\n*                similar to the input matrix B;  if INFO = i, i\n*                elements of E have not converged to zero.\n*\n*  Internal Parameters\n*  ===================\n*\n*  TOLMUL  REAL, default = max(10,min(100,EPS**(-1/8)))\n*          TOLMUL controls the convergence criterion of the QR loop.\n*          If it is positive, TOLMUL*EPS is the desired relative\n*             precision in the computed singular values.\n*          If it is negative, abs(TOLMUL*EPS*sigma_max) is the\n*             desired absolute accuracy in the computed singular\n*             values (corresponds to relative accuracy\n*             abs(TOLMUL*EPS) in the largest singular value.\n*          abs(TOLMUL) should be between 1 and 1/EPS, and preferably\n*             between 10 (for fast convergence) and .1/EPS\n*             (for there to be some accuracy in the results).\n*          Default is to lose at either one eighth or 2 of the\n*             available decimal digits in each computed singular value\n*             (whichever is smaller).\n*\n*  MAXITR  INTEGER, default = 6\n*          MAXITR controls the maximum number of passes of the\n*          algorithm through its inner loop. The algorithms stops\n*          (and so fails to converge) if the number of passes\n*          through the inner loop exceeds MAXITR*N**2.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, e, vt, u, c = NumRu::Lapack.cbdsqr( uplo, nru, d, e, vt, u, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_uplo = argv[0];
  rblapack_nru = argv[1];
  rblapack_d = argv[2];
  rblapack_e = argv[3];
  rblapack_vt = argv[4];
  rblapack_u = argv[5];
  rblapack_c = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_vt))
    rb_raise(rb_eArgError, "vt (5th argument) must be NArray");
  if (NA_RANK(rblapack_vt) != 2)
    rb_raise(rb_eArgError, "rank of vt (5th argument) must be %d", 2);
  ldvt = NA_SHAPE0(rblapack_vt);
  ncvt = NA_SHAPE1(rblapack_vt);
  if (NA_TYPE(rblapack_vt) != NA_SCOMPLEX)
    rblapack_vt = na_change_type(rblapack_vt, NA_SCOMPLEX);
  vt = NA_PTR_TYPE(rblapack_vt, complex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  ncc = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, complex*);
  nru = NUM2INT(rblapack_nru);
  if (!NA_IsNArray(rblapack_u))
    rb_raise(rb_eArgError, "u (6th argument) must be NArray");
  if (NA_RANK(rblapack_u) != 2)
    rb_raise(rb_eArgError, "rank of u (6th argument) must be %d", 2);
  ldu = NA_SHAPE0(rblapack_u);
  if (NA_SHAPE1(rblapack_u) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of u must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_u) != NA_SCOMPLEX)
    rblapack_u = na_change_type(rblapack_u, NA_SCOMPLEX);
  u = NA_PTR_TYPE(rblapack_u, complex*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (4th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
  MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvt;
    shape[1] = ncvt;
    rblapack_vt_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  vt_out__ = NA_PTR_TYPE(rblapack_vt_out__, complex*);
  MEMCPY(vt_out__, vt, complex, NA_TOTAL(rblapack_vt));
  rblapack_vt = rblapack_vt_out__;
  vt = vt_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = n;
    rblapack_u_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  u_out__ = NA_PTR_TYPE(rblapack_u_out__, complex*);
  MEMCPY(u_out__, u, complex, NA_TOTAL(rblapack_u));
  rblapack_u = rblapack_u_out__;
  u = u_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = ncc;
    rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
  MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  rwork = ALLOC_N(real, ((ncvt==nru)&&(nru==ncc)&&(ncc==0) ? 2*n : MAX(1, 4*n-4)));

  cbdsqr_(&uplo, &n, &ncvt, &nru, &ncc, d, e, vt, &ldvt, u, &ldu, c, &ldc, rwork, &info);

  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_info, rblapack_d, rblapack_e, rblapack_vt, rblapack_u, rblapack_c);
}

void
init_lapack_cbdsqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cbdsqr", rblapack_cbdsqr, -1);
}
ruby-lapack-1.7.2/ext/cptrfs.c0000644000175000017500000002121412502221023016021 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cptrfs_(char* uplo, integer* n, integer* nrhs, real* d, complex* e, real* df, complex* ef, complex* b, integer* ldb, complex* x, integer* ldx, real* ferr, real* berr, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cptrfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  complex *e; 
  VALUE rblapack_df;
  real *df; 
  VALUE rblapack_ef;
  complex *ef; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  complex *x_out__;
  complex *work;
  real *rwork;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.cptrfs( uplo, d, e, df, ef, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPTRFS( UPLO, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPTRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is Hermitian positive definite\n*  and tridiagonal, and provides error bounds and backward error\n*  estimates for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the superdiagonal or the subdiagonal of the\n*          tridiagonal matrix A is stored and the form of the\n*          factorization:\n*          = 'U':  E is the superdiagonal of A, and A = U**H*D*U;\n*          = 'L':  E is the subdiagonal of A, and A = L*D*L**H.\n*          (The two forms are equivalent if A is real.)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  D       (input) REAL array, dimension (N)\n*          The n real diagonal elements of the tridiagonal matrix A.\n*\n*  E       (input) COMPLEX array, dimension (N-1)\n*          The (n-1) off-diagonal elements of the tridiagonal matrix A\n*          (see UPLO).\n*\n*  DF      (input) REAL array, dimension (N)\n*          The n diagonal elements of the diagonal matrix D from\n*          the factorization computed by CPTTRF.\n*\n*  EF      (input) COMPLEX array, dimension (N-1)\n*          The (n-1) off-diagonal elements of the unit bidiagonal\n*          factor U or L from the factorization computed by CPTTRF\n*          (see UPLO).\n*\n*  B       (input) COMPLEX array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) COMPLEX array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by CPTTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX array, dimension (N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.cptrfs( uplo, d, e, df, ef, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_uplo = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  rblapack_df = argv[3];
  rblapack_ef = argv[4];
  rblapack_b = argv[5];
  rblapack_x = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_df))
    rb_raise(rb_eArgError, "df (4th argument) must be NArray");
  if (NA_RANK(rblapack_df) != 1)
    rb_raise(rb_eArgError, "rank of df (4th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_df);
  if (NA_TYPE(rblapack_df) != NA_SFLOAT)
    rblapack_df = na_change_type(rblapack_df, NA_SFLOAT);
  df = NA_PTR_TYPE(rblapack_df, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of df");
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_ef))
    rb_raise(rb_eArgError, "ef (5th argument) must be NArray");
  if (NA_RANK(rblapack_ef) != 1)
    rb_raise(rb_eArgError, "rank of ef (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ef) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of ef must be %d", n-1);
  if (NA_TYPE(rblapack_ef) != NA_SCOMPLEX)
    rblapack_ef = na_change_type(rblapack_ef, NA_SCOMPLEX);
  ef = NA_PTR_TYPE(rblapack_ef, complex*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SCOMPLEX)
    rblapack_e = na_change_type(rblapack_e, NA_SCOMPLEX);
  e = NA_PTR_TYPE(rblapack_e, complex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (7th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(complex, (n));
  rwork = ALLOC_N(real, (n));

  cptrfs_(&uplo, &n, &nrhs, d, e, df, ef, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_cptrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cptrfs", rblapack_cptrfs, -1);
}
ruby-lapack-1.7.2/ext/dtgsen.c0000644000175000017500000005517412502221014016020 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtgsen_(integer* ijob, logical* wantq, logical* wantz, logical* select, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* alphar, doublereal* alphai, doublereal* beta, doublereal* q, integer* ldq, doublereal* z, integer* ldz, integer* m, doublereal* pl, doublereal* pr, doublereal* dif, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_dtgsen(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ijob;
  integer ijob; 
  VALUE rblapack_wantq;
  logical wantq; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_select;
  logical *select; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_q;
  doublereal *q; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_alphar;
  doublereal *alphar; 
  VALUE rblapack_alphai;
  doublereal *alphai; 
  VALUE rblapack_beta;
  doublereal *beta; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_pl;
  doublereal pl; 
  VALUE rblapack_pr;
  doublereal pr; 
  VALUE rblapack_dif;
  doublereal *dif; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;
  VALUE rblapack_q_out__;
  doublereal *q_out__;
  VALUE rblapack_z_out__;
  doublereal *z_out__;

  integer n;
  integer lda;
  integer ldb;
  integer ldq;
  integer ldz;

  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  alphar, alphai, beta, m, pl, pr, dif, work, iwork, info, a, b, q, z = NumRu::Lapack.dtgsen( ijob, wantq, wantz, select, a, b, q, z, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTGSEN reorders the generalized real Schur decomposition of a real\n*  matrix pair (A, B) (in terms of an orthonormal equivalence trans-\n*  formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues\n*  appears in the leading diagonal blocks of the upper quasi-triangular\n*  matrix A and the upper triangular B. The leading columns of Q and\n*  Z form orthonormal bases of the corresponding left and right eigen-\n*  spaces (deflating subspaces). (A, B) must be in generalized real\n*  Schur canonical form (as returned by DGGES), i.e. A is block upper\n*  triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper\n*  triangular.\n*\n*  DTGSEN also computes the generalized eigenvalues\n*\n*              w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j)\n*\n*  of the reordered matrix pair (A, B).\n*\n*  Optionally, DTGSEN computes the estimates of reciprocal condition\n*  numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),\n*  (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)\n*  between the matrix pairs (A11, B11) and (A22,B22) that correspond to\n*  the selected cluster and the eigenvalues outside the cluster, resp.,\n*  and norms of \"projections\" onto left and right eigenspaces w.r.t.\n*  the selected cluster in the (1,1)-block.\n*\n\n*  Arguments\n*  =========\n*\n*  IJOB    (input) INTEGER\n*          Specifies whether condition numbers are required for the\n*          cluster of eigenvalues (PL and PR) or the deflating subspaces\n*          (Difu and Difl):\n*           =0: Only reorder w.r.t. SELECT. No extras.\n*           =1: Reciprocal of norms of \"projections\" onto left and right\n*               eigenspaces w.r.t. the selected cluster (PL and PR).\n*           =2: Upper bounds on Difu and Difl. F-norm-based estimate\n*               (DIF(1:2)).\n*           =3: Estimate of Difu and Difl. 1-norm-based estimate\n*               (DIF(1:2)).\n*               About 5 times as expensive as IJOB = 2.\n*           =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic\n*               version to get it all.\n*           =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)\n*\n*  WANTQ   (input) LOGICAL\n*          .TRUE. : update the left transformation matrix Q;\n*          .FALSE.: do not update Q.\n*\n*  WANTZ   (input) LOGICAL\n*          .TRUE. : update the right transformation matrix Z;\n*          .FALSE.: do not update Z.\n*\n*  SELECT  (input) LOGICAL array, dimension (N)\n*          SELECT specifies the eigenvalues in the selected cluster.\n*          To select a real eigenvalue w(j), SELECT(j) must be set to\n*          .TRUE.. To select a complex conjugate pair of eigenvalues\n*          w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,\n*          either SELECT(j) or SELECT(j+1) or both must be set to\n*          .TRUE.; a complex conjugate pair of eigenvalues must be\n*          either both included in the cluster or both excluded.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B. N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension(LDA,N)\n*          On entry, the upper quasi-triangular matrix A, with (A, B) in\n*          generalized real Schur canonical form.\n*          On exit, A is overwritten by the reordered matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension(LDB,N)\n*          On entry, the upper triangular matrix B, with (A, B) in\n*          generalized real Schur canonical form.\n*          On exit, B is overwritten by the reordered matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  ALPHAR  (output) DOUBLE PRECISION array, dimension (N)\n*  ALPHAI  (output) DOUBLE PRECISION array, dimension (N)\n*  BETA    (output) DOUBLE PRECISION array, dimension (N)\n*          On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n*          be the generalized eigenvalues.  ALPHAR(j) + ALPHAI(j)*i\n*          and BETA(j),j=1,...,N  are the diagonals of the complex Schur\n*          form (S,T) that would result if the 2-by-2 diagonal blocks of\n*          the real generalized Schur form of (A,B) were further reduced\n*          to triangular form using complex unitary transformations.\n*          If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n*          positive, then the j-th and (j+1)-st eigenvalues are a\n*          complex conjugate pair, with ALPHAI(j+1) negative.\n*\n*  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n*          On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.\n*          On exit, Q has been postmultiplied by the left orthogonal\n*          transformation matrix which reorder (A, B); The leading M\n*          columns of Q form orthonormal bases for the specified pair of\n*          left eigenspaces (deflating subspaces).\n*          If WANTQ = .FALSE., Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.  LDQ >= 1;\n*          and if WANTQ = .TRUE., LDQ >= N.\n*\n*  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n*          On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.\n*          On exit, Z has been postmultiplied by the left orthogonal\n*          transformation matrix which reorder (A, B); The leading M\n*          columns of Z form orthonormal bases for the specified pair of\n*          left eigenspaces (deflating subspaces).\n*          If WANTZ = .FALSE., Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z. LDZ >= 1;\n*          If WANTZ = .TRUE., LDZ >= N.\n*\n*  M       (output) INTEGER\n*          The dimension of the specified pair of left and right eigen-\n*          spaces (deflating subspaces). 0 <= M <= N.\n*\n*  PL      (output) DOUBLE PRECISION\n*  PR      (output) DOUBLE PRECISION\n*          If IJOB = 1, 4 or 5, PL, PR are lower bounds on the\n*          reciprocal of the norm of \"projections\" onto left and right\n*          eigenspaces with respect to the selected cluster.\n*          0 < PL, PR <= 1.\n*          If M = 0 or M = N, PL = PR  = 1.\n*          If IJOB = 0, 2 or 3, PL and PR are not referenced.\n*\n*  DIF     (output) DOUBLE PRECISION array, dimension (2).\n*          If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.\n*          If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on\n*          Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based\n*          estimates of Difu and Difl.\n*          If M = 0 or N, DIF(1:2) = F-norm([A, B]).\n*          If IJOB = 0 or 1, DIF is not referenced.\n*\n*  WORK    (workspace/output) DOUBLE PRECISION array,\n*          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 >=  4*N+16.\n*          If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)).\n*          If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)).\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*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK. LIWORK >= 1.\n*          If IJOB = 1, 2 or 4, LIWORK >=  N+6.\n*          If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6).\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal size of the IWORK array,\n*          returns this value as the first entry of the IWORK array, and\n*          no error message related to LIWORK 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*            =1: Reordering of (A, B) failed because the transformed\n*                matrix pair (A, B) would be too far from generalized\n*                Schur form; the problem is very ill-conditioned.\n*                (A, B) may have been partially reordered.\n*                If requested, 0 is returned in DIF(*), PL and PR.\n*\n\n*  Further Details\n*  ===============\n*\n*  DTGSEN first collects the selected eigenvalues by computing\n*  orthogonal U and W that move them to the top left corner of (A, B).\n*  In other words, the selected eigenvalues are the eigenvalues of\n*  (A11, B11) in:\n*\n*                U'*(A, B)*W = (A11 A12) (B11 B12) n1\n*                              ( 0  A22),( 0  B22) n2\n*                                n1  n2    n1  n2\n*\n*  where N = n1+n2 and U' means the transpose of U. The first n1 columns\n*  of U and W span the specified pair of left and right eigenspaces\n*  (deflating subspaces) of (A, B).\n*\n*  If (A, B) has been obtained from the generalized real Schur\n*  decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the\n*  reordered generalized real Schur form of (C, D) is given by\n*\n*           (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',\n*\n*  and the first n1 columns of Q*U and Z*W span the corresponding\n*  deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).\n*\n*  Note that if the selected eigenvalue is sufficiently ill-conditioned,\n*  then its value may differ significantly from its value before\n*  reordering.\n*\n*  The reciprocal condition numbers of the left and right eigenspaces\n*  spanned by the first n1 columns of U and W (or Q*U and Z*W) may\n*  be returned in DIF(1:2), corresponding to Difu and Difl, resp.\n*\n*  The Difu and Difl are defined as:\n*\n*       Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )\n*  and\n*       Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],\n*\n*  where sigma-min(Zu) is the smallest singular value of the\n*  (2*n1*n2)-by-(2*n1*n2) matrix\n*\n*       Zu = [ kron(In2, A11)  -kron(A22', In1) ]\n*            [ kron(In2, B11)  -kron(B22', In1) ].\n*\n*  Here, Inx is the identity matrix of size nx and A22' is the\n*  transpose of A22. kron(X, Y) is the Kronecker product between\n*  the matrices X and Y.\n*\n*  When DIF(2) is small, small changes in (A, B) can cause large changes\n*  in the deflating subspace. An approximate (asymptotic) bound on the\n*  maximum angular error in the computed deflating subspaces is\n*\n*       EPS * norm((A, B)) / DIF(2),\n*\n*  where EPS is the machine precision.\n*\n*  The reciprocal norm of the projectors on the left and right\n*  eigenspaces associated with (A11, B11) may be returned in PL and PR.\n*  They are computed as follows. First we compute L and R so that\n*  P*(A, B)*Q is block diagonal, where\n*\n*       P = ( I -L ) n1           Q = ( I R ) n1\n*           ( 0  I ) n2    and        ( 0 I ) n2\n*             n1 n2                    n1 n2\n*\n*  and (L, R) is the solution to the generalized Sylvester equation\n*\n*       A11*R - L*A22 = -A12\n*       B11*R - L*B22 = -B12\n*\n*  Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).\n*  An approximate (asymptotic) bound on the average absolute error of\n*  the selected eigenvalues is\n*\n*       EPS * norm((A, B)) / PL.\n*\n*  There are also global error bounds which valid for perturbations up\n*  to a certain restriction:  A lower bound (x) on the smallest\n*  F-norm(E,F) for which an eigenvalue of (A11, B11) may move and\n*  coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),\n*  (i.e. (A + E, B + F), is\n*\n*   x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).\n*\n*  An approximate bound on x can be computed from DIF(1:2), PL and PR.\n*\n*  If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed\n*  (L', R') and unperturbed (L, R) left and right deflating subspaces\n*  associated with the selected cluster in the (1,1)-blocks can be\n*  bounded as\n*\n*   max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))\n*   max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))\n*\n*  See LAPACK User's Guide section 4.11 or the following references\n*  for more information.\n*\n*  Note that if the default method for computing the Frobenius-norm-\n*  based estimate DIF is not wanted (see DLATDF), then the parameter\n*  IDIFJB (see below) should be changed from 3 to 4 (routine DLATDF\n*  (IJOB = 2 will be used)). See DTGSYL for more details.\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  References\n*  ==========\n*\n*  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n*      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n*      M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n*      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n*  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n*      Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n*      Estimation: Theory, Algorithms and Software,\n*      Report UMINF - 94.04, Department of Computing Science, Umea\n*      University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working\n*      Note 87. To appear in Numerical Algorithms, 1996.\n*\n*  [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n*      for Solving the Generalized Sylvester Equation and Estimating the\n*      Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n*      Department of Computing Science, Umea University, S-901 87 Umea,\n*      Sweden, December 1993, Revised April 1994, Also as LAPACK Working\n*      Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,\n*      1996.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  alphar, alphai, beta, m, pl, pr, dif, work, iwork, info, a, b, q, z = NumRu::Lapack.dtgsen( ijob, wantq, wantz, select, a, b, q, z, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_ijob = argv[0];
  rblapack_wantq = argv[1];
  rblapack_wantz = argv[2];
  rblapack_select = argv[3];
  rblapack_a = argv[4];
  rblapack_b = argv[5];
  rblapack_q = argv[6];
  rblapack_z = argv[7];
  if (argc == 10) {
    rblapack_lwork = argv[8];
    rblapack_liwork = argv[9];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  ijob = NUM2INT(rblapack_ijob);
  wantz = (rblapack_wantz == Qtrue);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th 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*);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (7th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_q) != NA_DFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
  q = NA_PTR_TYPE(rblapack_q, doublereal*);
  wantq = (rblapack_wantq == Qtrue);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  if (!NA_IsNArray(rblapack_select))
    rb_raise(rb_eArgError, "select (4th argument) must be NArray");
  if (NA_RANK(rblapack_select) != 1)
    rb_raise(rb_eArgError, "rank of select (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_select) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_select) != NA_LINT)
    rblapack_select = na_change_type(rblapack_select, NA_LINT);
  select = NA_PTR_TYPE(rblapack_select, logical*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (8th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  if (NA_SHAPE1(rblapack_z) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  if (rblapack_liwork == Qnil)
    liwork = (ijob==1||ijob==2||ijob==4) ? n+6 : (ijob==3||ijob==5) ? MAX(2*m*(n-m),n+6) : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  if (rblapack_lwork == Qnil)
    lwork = (ijob==1||ijob==2||ijob==4) ? MAX(4*n+16,2*m*(n-m)) : (ijob==3||ijob==5) ? MAX(4*n+16,4*m*(n-m)) : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  alphar = NA_PTR_TYPE(rblapack_alphar, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  alphai = NA_PTR_TYPE(rblapack_alphai, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 2;
    rblapack_dif = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  dif = NA_PTR_TYPE(rblapack_dif, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
  MEMCPY(q_out__, q, doublereal, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
  MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  dtgsen_(&ijob, &wantq, &wantz, select, &n, a, &lda, b, &ldb, alphar, alphai, beta, q, &ldq, z, &ldz, &m, &pl, &pr, dif, work, &lwork, iwork, &liwork, &info);

  rblapack_m = INT2NUM(m);
  rblapack_pl = rb_float_new((double)pl);
  rblapack_pr = rb_float_new((double)pr);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(14, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_m, rblapack_pl, rblapack_pr, rblapack_dif, rblapack_work, rblapack_iwork, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z);
}

void
init_lapack_dtgsen(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtgsen", rblapack_dtgsen, -1);
}
ruby-lapack-1.7.2/ext/dlaed7.c0000644000175000017500000003667712655767575015747 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaed7_(integer* icompq, integer* n, integer* qsiz, integer* tlvls, integer* curlvl, integer* curpbm, doublereal* d, doublereal* q, integer* ldq, integer* indxq, doublereal* rho, integer* cutpnt, doublereal* qstore, integer* qptr, integer* prmptr, integer* perm, integer* givptr, integer* givcol, doublereal* givnum, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dlaed7(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_icompq;
  integer icompq; 
  VALUE rblapack_qsiz;
  integer qsiz; 
  VALUE rblapack_tlvls;
  integer tlvls; 
  VALUE rblapack_curlvl;
  integer curlvl; 
  VALUE rblapack_curpbm;
  integer curpbm; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_q;
  doublereal *q; 
  VALUE rblapack_rho;
  doublereal rho; 
  VALUE rblapack_cutpnt;
  integer cutpnt; 
  VALUE rblapack_qstore;
  doublereal *qstore; 
  VALUE rblapack_qptr;
  integer *qptr; 
  VALUE rblapack_prmptr;
  integer *prmptr; 
  VALUE rblapack_perm;
  integer *perm; 
  VALUE rblapack_givptr;
  integer *givptr; 
  VALUE rblapack_givcol;
  integer *givcol; 
  VALUE rblapack_givnum;
  doublereal *givnum; 
  VALUE rblapack_indxq;
  integer *indxq; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_q_out__;
  doublereal *q_out__;
  VALUE rblapack_qstore_out__;
  doublereal *qstore_out__;
  VALUE rblapack_qptr_out__;
  integer *qptr_out__;
  doublereal *work;
  integer *iwork;

  integer n;
  integer ldq;

  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  indxq, info, d, q, qstore, qptr = NumRu::Lapack.dlaed7( icompq, qsiz, tlvls, curlvl, curpbm, d, q, rho, cutpnt, qstore, qptr, prmptr, perm, givptr, givcol, givnum, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR, PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLAED7 computes the updated eigensystem of a diagonal\n*  matrix after modification by a rank-one symmetric matrix. This\n*  routine is used only for the eigenproblem which requires all\n*  eigenvalues and optionally eigenvectors of a dense symmetric matrix\n*  that has been reduced to tridiagonal form.  DLAED1 handles\n*  the case in which all eigenvalues and eigenvectors of a symmetric\n*  tridiagonal matrix are desired.\n*\n*    T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)\n*\n*     where Z = Q'u, u is a vector of length N with ones in the\n*     CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.\n*\n*     The eigenvectors of the original matrix are stored in Q, and the\n*     eigenvalues are in D.  The algorithm consists of three stages:\n*\n*        The first stage consists of deflating the size of the problem\n*        when there are multiple eigenvalues or if there is a zero in\n*        the Z vector.  For each such occurrence the dimension of the\n*        secular equation problem is reduced by one.  This stage is\n*        performed by the routine DLAED8.\n*\n*        The second stage consists of calculating the updated\n*        eigenvalues. This is done by finding the roots of the secular\n*        equation via the routine DLAED4 (as called by DLAED9).\n*        This routine also calculates the eigenvectors of the current\n*        problem.\n*\n*        The final stage consists of computing the updated eigenvectors\n*        directly using the updated eigenvalues.  The eigenvectors for\n*        the current problem are multiplied with the eigenvectors from\n*        the overall problem.\n*\n\n*  Arguments\n*  =========\n*\n*  ICOMPQ  (input) INTEGER\n*          = 0:  Compute eigenvalues only.\n*          = 1:  Compute eigenvectors of original dense symmetric matrix\n*                also.  On entry, Q contains the orthogonal matrix used\n*                to reduce the original matrix to tridiagonal form.\n*\n*  N      (input) INTEGER\n*         The dimension of the symmetric tridiagonal matrix.  N >= 0.\n*\n*  QSIZ   (input) INTEGER\n*         The dimension of the orthogonal matrix used to reduce\n*         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.\n*\n*  TLVLS  (input) INTEGER\n*         The total number of merging levels in the overall divide and\n*         conquer tree.\n*\n*  CURLVL (input) INTEGER\n*         The current level in the overall merge routine,\n*         0 <= CURLVL <= TLVLS.\n*\n*  CURPBM (input) INTEGER\n*         The current problem in the current level in the overall\n*         merge routine (counting from upper left to lower right).\n*\n*  D      (input/output) DOUBLE PRECISION array, dimension (N)\n*         On entry, the eigenvalues of the rank-1-perturbed matrix.\n*         On exit, the eigenvalues of the repaired matrix.\n*\n*  Q      (input/output) DOUBLE PRECISION array, dimension (LDQ, N)\n*         On entry, the eigenvectors of the rank-1-perturbed matrix.\n*         On exit, the eigenvectors of the repaired tridiagonal matrix.\n*\n*  LDQ    (input) INTEGER\n*         The leading dimension of the array Q.  LDQ >= max(1,N).\n*\n*  INDXQ  (output) INTEGER array, dimension (N)\n*         The permutation which will reintegrate the subproblem just\n*         solved back into sorted order, i.e., D( INDXQ( I = 1, N ) )\n*         will be in ascending order.\n*\n*  RHO    (input) DOUBLE PRECISION\n*         The subdiagonal element used to create the rank-1\n*         modification.\n*\n*  CUTPNT (input) INTEGER\n*         Contains the location of the last eigenvalue in the leading\n*         sub-matrix.  min(1,N) <= CUTPNT <= N.\n*\n*  QSTORE (input/output) DOUBLE PRECISION array, dimension (N**2+1)\n*         Stores eigenvectors of submatrices encountered during\n*         divide and conquer, packed together. QPTR points to\n*         beginning of the submatrices.\n*\n*  QPTR   (input/output) INTEGER array, dimension (N+2)\n*         List of indices pointing to beginning of submatrices stored\n*         in QSTORE. The submatrices are numbered starting at the\n*         bottom left of the divide and conquer tree, from left to\n*         right and bottom to top.\n*\n*  PRMPTR (input) INTEGER array, dimension (N lg N)\n*         Contains a list of pointers which indicate where in PERM a\n*         level's permutation is stored.  PRMPTR(i+1) - PRMPTR(i)\n*         indicates the size of the permutation and also the size of\n*         the full, non-deflated problem.\n*\n*  PERM   (input) INTEGER array, dimension (N lg N)\n*         Contains the permutations (from deflation and sorting) to be\n*         applied to each eigenblock.\n*\n*  GIVPTR (input) INTEGER array, dimension (N lg N)\n*         Contains a list of pointers which indicate where in GIVCOL a\n*         level's Givens rotations are stored.  GIVPTR(i+1) - GIVPTR(i)\n*         indicates the number of Givens rotations.\n*\n*  GIVCOL (input) INTEGER array, dimension (2, N lg N)\n*         Each pair of numbers indicates a pair of columns to take place\n*         in a Givens rotation.\n*\n*  GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N)\n*         Each number indicates the S value to be used in the\n*         corresponding Givens rotation.\n*\n*  WORK   (workspace) DOUBLE PRECISION array, dimension (3*N+QSIZ*N)\n*\n*  IWORK  (workspace) INTEGER array, dimension (4*N)\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 = 1, an eigenvalue did not converge\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Jeff Rutter, Computer Science Division, University of California\n*     at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  indxq, info, d, q, qstore, qptr = NumRu::Lapack.dlaed7( icompq, qsiz, tlvls, curlvl, curpbm, d, q, rho, cutpnt, qstore, qptr, prmptr, perm, givptr, givcol, givnum, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 16 && argc != 16)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 16)", argc);
  rblapack_icompq = argv[0];
  rblapack_qsiz = argv[1];
  rblapack_tlvls = argv[2];
  rblapack_curlvl = argv[3];
  rblapack_curpbm = argv[4];
  rblapack_d = argv[5];
  rblapack_q = argv[6];
  rblapack_rho = argv[7];
  rblapack_cutpnt = argv[8];
  rblapack_qstore = argv[9];
  rblapack_qptr = argv[10];
  rblapack_prmptr = argv[11];
  rblapack_perm = argv[12];
  rblapack_givptr = argv[13];
  rblapack_givcol = argv[14];
  rblapack_givnum = argv[15];
  if (argc == 16) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  icompq = NUM2INT(rblapack_icompq);
  tlvls = NUM2INT(rblapack_tlvls);
  curpbm = NUM2INT(rblapack_curpbm);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (7th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  n = NA_SHAPE1(rblapack_q);
  if (NA_TYPE(rblapack_q) != NA_DFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
  q = NA_PTR_TYPE(rblapack_q, doublereal*);
  cutpnt = NUM2INT(rblapack_cutpnt);
  qsiz = NUM2INT(rblapack_qsiz);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (6th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of q");
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_qstore))
    rb_raise(rb_eArgError, "qstore (10th argument) must be NArray");
  if (NA_RANK(rblapack_qstore) != 1)
    rb_raise(rb_eArgError, "rank of qstore (10th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_qstore) != (pow(n,2)+1))
    rb_raise(rb_eRuntimeError, "shape 0 of qstore must be %d", pow(n,2)+1);
  if (NA_TYPE(rblapack_qstore) != NA_DFLOAT)
    rblapack_qstore = na_change_type(rblapack_qstore, NA_DFLOAT);
  qstore = NA_PTR_TYPE(rblapack_qstore, doublereal*);
  if (!NA_IsNArray(rblapack_prmptr))
    rb_raise(rb_eArgError, "prmptr (12th argument) must be NArray");
  if (NA_RANK(rblapack_prmptr) != 1)
    rb_raise(rb_eArgError, "rank of prmptr (12th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_prmptr) != (n*LG(n)))
    rb_raise(rb_eRuntimeError, "shape 0 of prmptr must be %d", n*LG(n));
  if (NA_TYPE(rblapack_prmptr) != NA_LINT)
    rblapack_prmptr = na_change_type(rblapack_prmptr, NA_LINT);
  prmptr = NA_PTR_TYPE(rblapack_prmptr, integer*);
  if (!NA_IsNArray(rblapack_givptr))
    rb_raise(rb_eArgError, "givptr (14th argument) must be NArray");
  if (NA_RANK(rblapack_givptr) != 1)
    rb_raise(rb_eArgError, "rank of givptr (14th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_givptr) != (n*LG(n)))
    rb_raise(rb_eRuntimeError, "shape 0 of givptr must be %d", n*LG(n));
  if (NA_TYPE(rblapack_givptr) != NA_LINT)
    rblapack_givptr = na_change_type(rblapack_givptr, NA_LINT);
  givptr = NA_PTR_TYPE(rblapack_givptr, integer*);
  if (!NA_IsNArray(rblapack_givnum))
    rb_raise(rb_eArgError, "givnum (16th argument) must be NArray");
  if (NA_RANK(rblapack_givnum) != 2)
    rb_raise(rb_eArgError, "rank of givnum (16th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_givnum) != (2))
    rb_raise(rb_eRuntimeError, "shape 0 of givnum must be %d", 2);
  if (NA_SHAPE1(rblapack_givnum) != (n*LG(n)))
    rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", n*LG(n));
  if (NA_TYPE(rblapack_givnum) != NA_DFLOAT)
    rblapack_givnum = na_change_type(rblapack_givnum, NA_DFLOAT);
  givnum = NA_PTR_TYPE(rblapack_givnum, doublereal*);
  curlvl = NUM2INT(rblapack_curlvl);
  if (!NA_IsNArray(rblapack_qptr))
    rb_raise(rb_eArgError, "qptr (11th argument) must be NArray");
  if (NA_RANK(rblapack_qptr) != 1)
    rb_raise(rb_eArgError, "rank of qptr (11th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_qptr) != (n+2))
    rb_raise(rb_eRuntimeError, "shape 0 of qptr must be %d", n+2);
  if (NA_TYPE(rblapack_qptr) != NA_LINT)
    rblapack_qptr = na_change_type(rblapack_qptr, NA_LINT);
  qptr = NA_PTR_TYPE(rblapack_qptr, integer*);
  if (!NA_IsNArray(rblapack_givcol))
    rb_raise(rb_eArgError, "givcol (15th argument) must be NArray");
  if (NA_RANK(rblapack_givcol) != 2)
    rb_raise(rb_eArgError, "rank of givcol (15th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_givcol) != (2))
    rb_raise(rb_eRuntimeError, "shape 0 of givcol must be %d", 2);
  if (NA_SHAPE1(rblapack_givcol) != (n*LG(n)))
    rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", n*LG(n));
  if (NA_TYPE(rblapack_givcol) != NA_LINT)
    rblapack_givcol = na_change_type(rblapack_givcol, NA_LINT);
  givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
  rho = NUM2DBL(rblapack_rho);
  if (!NA_IsNArray(rblapack_perm))
    rb_raise(rb_eArgError, "perm (13th argument) must be NArray");
  if (NA_RANK(rblapack_perm) != 1)
    rb_raise(rb_eArgError, "rank of perm (13th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_perm) != (n*LG(n)))
    rb_raise(rb_eRuntimeError, "shape 0 of perm must be %d", n*LG(n));
  if (NA_TYPE(rblapack_perm) != NA_LINT)
    rblapack_perm = na_change_type(rblapack_perm, NA_LINT);
  perm = NA_PTR_TYPE(rblapack_perm, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_indxq = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  indxq = NA_PTR_TYPE(rblapack_indxq, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
  MEMCPY(q_out__, q, doublereal, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  {
    na_shape_t shape[1];
    shape[0] = pow(n,2)+1;
    rblapack_qstore_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  qstore_out__ = NA_PTR_TYPE(rblapack_qstore_out__, doublereal*);
  MEMCPY(qstore_out__, qstore, doublereal, NA_TOTAL(rblapack_qstore));
  rblapack_qstore = rblapack_qstore_out__;
  qstore = qstore_out__;
  {
    na_shape_t shape[1];
    shape[0] = n+2;
    rblapack_qptr_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  qptr_out__ = NA_PTR_TYPE(rblapack_qptr_out__, integer*);
  MEMCPY(qptr_out__, qptr, integer, NA_TOTAL(rblapack_qptr));
  rblapack_qptr = rblapack_qptr_out__;
  qptr = qptr_out__;
  work = ALLOC_N(doublereal, (3*n+qsiz*n));
  iwork = ALLOC_N(integer, (4*n));

  dlaed7_(&icompq, &n, &qsiz, &tlvls, &curlvl, &curpbm, d, q, &ldq, indxq, &rho, &cutpnt, qstore, qptr, prmptr, perm, givptr, givcol, givnum, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_indxq, rblapack_info, rblapack_d, rblapack_q, rblapack_qstore, rblapack_qptr);
}

void
init_lapack_dlaed7(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaed7", rblapack_dlaed7, -1);
}
ruby-lapack-1.7.2/ext/dtptrs.c0000644000175000017500000001241612502221022016043 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtptrs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, doublereal* ap, doublereal* b, integer* ldb, integer* info);


static VALUE
rblapack_dtptrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublereal *b_out__;

  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.dtptrs( uplo, trans, diag, n, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTPTRS solves a triangular system of the form\n*\n*     A * X = B  or  A**T * X = B,\n*\n*  where A is a triangular matrix of order N stored in packed format,\n*  and B is an N-by-NRHS matrix.  A check is made to verify that A is\n*  nonsingular.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B  (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          The upper or lower triangular matrix A, packed columnwise in\n*          a linear array.  The j-th column of A is stored in the array\n*          AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, if INFO = 0, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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 A is zero,\n*                indicating that the matrix is singular and the\n*                solutions X have not been computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.dtptrs( uplo, trans, diag, n, ap, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_n = argv[3];
  rblapack_ap = argv[4];
  rblapack_b = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  trans = StringValueCStr(rblapack_trans)[0];
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dtptrs_(&uplo, &trans, &diag, &n, &nrhs, ap, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_dtptrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtptrs", rblapack_dtptrs, -1);
}
ruby-lapack-1.7.2/ext/dsyswapr.c0000644000175000017500000000771412502221025016407 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsyswapr_(char* uplo, integer* n, doublereal* a, integer* i1, integer* i2);


static VALUE
rblapack_dsyswapr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_i1;
  integer i1; 
  VALUE rblapack_i2;
  integer i2; 
  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  a = NumRu::Lapack.dsyswapr( uplo, a, i1, i2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSYSWAPR( UPLO, N, A, I1, I2)\n\n*  Purpose\n*  =======\n*\n*  DSYSWAPR applies an elementary permutation on the rows and the columns of\n*  a symmetric matrix.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the NB diagonal matrix D and the multipliers\n*          used to obtain the factor U or L as computed by DSYTRF.\n*\n*          On exit, if INFO = 0, the (symmetric) inverse of the original\n*          matrix.  If UPLO = 'U', the upper triangular part of the\n*          inverse is formed and the part of A below the diagonal is not\n*          referenced; if UPLO = 'L' the lower triangular part of the\n*          inverse is formed and the part of A above the diagonal is\n*          not referenced.\n*\n*  I1      (input) INTEGER\n*          Index of the first row to swap\n*\n*  I2      (input) INTEGER\n*          Index of the second row to swap\n*\n\n*  =====================================================================\n*\n*     ..\n*     .. Local Scalars ..\n      LOGICAL            UPPER\n      INTEGER            I\n      DOUBLE PRECISION   TMP\n*\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL         DSWAP\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  a = NumRu::Lapack.dsyswapr( uplo, a, i1, i2, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_i1 = argv[2];
  rblapack_i2 = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  i1 = NUM2INT(rblapack_i1);
  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*);
  i2 = NUM2INT(rblapack_i2);
  {
    na_shape_t 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__;

  dsyswapr_(&uplo, &n, a, &i1, &i2);

  return rblapack_a;
}

void
init_lapack_dsyswapr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsyswapr", rblapack_dsyswapr, -1);
}
ruby-lapack-1.7.2/ext/dgehd2.c0000644000175000017500000001304012502221012015651 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgehd2_(integer* n, integer* ilo, integer* ihi, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* info);


static VALUE
rblapack_dgehd2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  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;

  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.dgehd2( ilo, ihi, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGEHD2 reduces a real general matrix A to upper Hessenberg form H by\n*  an orthogonal similarity transformation:  Q' * A * Q = H .\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          It is assumed that A is already upper triangular in rows\n*          and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n*          set by a previous call to DGEBAL; otherwise they should be\n*          set to 1 and N respectively. See Further Details.\n*          1 <= ILO <= IHI <= max(1,N).\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the n by n general matrix to be reduced.\n*          On exit, the upper triangle and the first subdiagonal of A\n*          are overwritten with the upper Hessenberg matrix H, and the\n*          elements below the first subdiagonal, with the array TAU,\n*          represent the orthogonal matrix Q as a product of elementary\n*          reflectors. See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  TAU     (output) DOUBLE PRECISION array, dimension (N-1)\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (N)\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 (ihi-ilo) elementary\n*  reflectors\n*\n*     Q = H(ilo) H(ilo+1) . . . H(ihi-1).\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) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n*  exit in A(i+2:ihi,i), and tau in TAU(i).\n*\n*  The contents of A are illustrated by the following example, with\n*  n = 7, ilo = 2 and ihi = 6:\n*\n*  on entry,                        on exit,\n*\n*  ( a   a   a   a   a   a   a )    (  a   a   h   h   h   h   a )\n*  (     a   a   a   a   a   a )    (      a   h   h   h   h   a )\n*  (     a   a   a   a   a   a )    (      h   h   h   h   h   h )\n*  (     a   a   a   a   a   a )    (      v2  h   h   h   h   h )\n*  (     a   a   a   a   a   a )    (      v2  v3  h   h   h   h )\n*  (     a   a   a   a   a   a )    (      v2  v3  v4  h   h   h )\n*  (                         a )    (                          a )\n*\n*  where a denotes an element of the original matrix A, h denotes a\n*  modified element of the upper Hessenberg matrix H, and vi denotes an\n*  element of the vector defining H(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.dgehd2( ilo, ihi, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_ilo = argv[0];
  rblapack_ihi = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  ihi = NUM2INT(rblapack_ihi);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t 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, (n));

  dgehd2_(&n, &ilo, &ihi, 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_dgehd2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgehd2", rblapack_dgehd2, -1);
}
ruby-lapack-1.7.2/ext/dlarrf.c0000644000175000017500000002347012655767574016043 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlarrf_(integer* n, doublereal* d, doublereal* l, doublereal* ld, integer* clstrt, integer* clend, doublereal* w, doublereal* wgap, doublereal* werr, doublereal* spdiam, doublereal* clgapl, doublereal* clgapr, doublereal* pivmin, doublereal* sigma, doublereal* dplus, doublereal* lplus, doublereal* work, integer* info);


static VALUE
rblapack_dlarrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_l;
  doublereal *l; 
  VALUE rblapack_ld;
  doublereal *ld; 
  VALUE rblapack_clstrt;
  integer clstrt; 
  VALUE rblapack_clend;
  integer clend; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_wgap;
  doublereal *wgap; 
  VALUE rblapack_werr;
  doublereal *werr; 
  VALUE rblapack_spdiam;
  doublereal spdiam; 
  VALUE rblapack_clgapl;
  doublereal clgapl; 
  VALUE rblapack_clgapr;
  doublereal clgapr; 
  VALUE rblapack_pivmin;
  doublereal pivmin; 
  VALUE rblapack_sigma;
  doublereal sigma; 
  VALUE rblapack_dplus;
  doublereal *dplus; 
  VALUE rblapack_lplus;
  doublereal *lplus; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_wgap_out__;
  doublereal *wgap_out__;
  doublereal *work;

  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  sigma, dplus, lplus, info, wgap = NumRu::Lapack.dlarrf( d, l, ld, clstrt, clend, w, wgap, werr, spdiam, clgapl, clgapr, pivmin, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLARRF( N, D, L, LD, CLSTRT, CLEND, W, WGAP, WERR, SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA, DPLUS, LPLUS, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  Given the initial representation L D L^T and its cluster of close\n*  eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ...\n*  W( CLEND ), DLARRF finds a new relatively robust representation\n*  L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the\n*  eigenvalues of L(+) D(+) L(+)^T is relatively isolated.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix (subblock, if the matrix split).\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          The N diagonal elements of the diagonal matrix D.\n*\n*  L       (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (N-1) subdiagonal elements of the unit bidiagonal\n*          matrix L.\n*\n*  LD      (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (N-1) elements L(i)*D(i).\n*\n*  CLSTRT  (input) INTEGER\n*          The index of the first eigenvalue in the cluster.\n*\n*  CLEND   (input) INTEGER\n*          The index of the last eigenvalue in the cluster.\n*\n*  W       (input) DOUBLE PRECISION array, dimension\n*          dimension is >=  (CLEND-CLSTRT+1)\n*          The eigenvalue APPROXIMATIONS of L D L^T in ascending order.\n*          W( CLSTRT ) through W( CLEND ) form the cluster of relatively\n*          close eigenalues.\n*\n*  WGAP    (input/output) DOUBLE PRECISION array, dimension\n*          dimension is >=  (CLEND-CLSTRT+1)\n*          The separation from the right neighbor eigenvalue in W.\n*\n*  WERR    (input) DOUBLE PRECISION array, dimension\n*          dimension is  >=  (CLEND-CLSTRT+1)\n*          WERR contain the semiwidth of the uncertainty\n*          interval of the corresponding eigenvalue APPROXIMATION in W\n*\n*  SPDIAM  (input) DOUBLE PRECISION\n*          estimate of the spectral diameter obtained from the\n*          Gerschgorin intervals\n*\n*  CLGAPL  (input) DOUBLE PRECISION\n*\n*  CLGAPR  (input) DOUBLE PRECISION\n*          absolute gap on each end of the cluster.\n*          Set by the calling routine to protect against shifts too close\n*          to eigenvalues outside the cluster.\n*\n*  PIVMIN  (input) DOUBLE PRECISION\n*          The minimum pivot allowed in the Sturm sequence.\n*\n*  SIGMA   (output) DOUBLE PRECISION\n*          The shift used to form L(+) D(+) L(+)^T.\n*\n*  DPLUS   (output) DOUBLE PRECISION array, dimension (N)\n*          The N diagonal elements of the diagonal matrix D(+).\n*\n*  LPLUS   (output) DOUBLE PRECISION array, dimension (N-1)\n*          The first (N-1) elements of LPLUS contain the subdiagonal\n*          elements of the unit bidiagonal matrix L(+).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N)\n*          Workspace.\n*\n*  INFO    (output) INTEGER\n*          Signals processing OK (=0) or failure (=1)\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Beresford Parlett, University of California, Berkeley, USA\n*     Jim Demmel, University of California, Berkeley, USA\n*     Inderjit Dhillon, University of Texas, Austin, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sigma, dplus, lplus, info, wgap = NumRu::Lapack.dlarrf( d, l, ld, clstrt, clend, w, wgap, werr, spdiam, clgapl, clgapr, pivmin, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_d = argv[0];
  rblapack_l = argv[1];
  rblapack_ld = argv[2];
  rblapack_clstrt = argv[3];
  rblapack_clend = argv[4];
  rblapack_w = argv[5];
  rblapack_wgap = argv[6];
  rblapack_werr = argv[7];
  rblapack_spdiam = argv[8];
  rblapack_clgapl = argv[9];
  rblapack_clgapr = argv[10];
  rblapack_pivmin = argv[11];
  if (argc == 12) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_ld))
    rb_raise(rb_eArgError, "ld (3th argument) must be NArray");
  if (NA_RANK(rblapack_ld) != 1)
    rb_raise(rb_eArgError, "rank of ld (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ld) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of ld must be %d", n-1);
  if (NA_TYPE(rblapack_ld) != NA_DFLOAT)
    rblapack_ld = na_change_type(rblapack_ld, NA_DFLOAT);
  ld = NA_PTR_TYPE(rblapack_ld, doublereal*);
  clend = NUM2INT(rblapack_clend);
  spdiam = NUM2DBL(rblapack_spdiam);
  clgapr = NUM2DBL(rblapack_clgapr);
  if (!NA_IsNArray(rblapack_l))
    rb_raise(rb_eArgError, "l (2th argument) must be NArray");
  if (NA_RANK(rblapack_l) != 1)
    rb_raise(rb_eArgError, "rank of l (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_l) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of l must be %d", n-1);
  if (NA_TYPE(rblapack_l) != NA_DFLOAT)
    rblapack_l = na_change_type(rblapack_l, NA_DFLOAT);
  l = NA_PTR_TYPE(rblapack_l, doublereal*);
  clgapl = NUM2DBL(rblapack_clgapl);
  clstrt = NUM2INT(rblapack_clstrt);
  if (!NA_IsNArray(rblapack_wgap))
    rb_raise(rb_eArgError, "wgap (7th argument) must be NArray");
  if (NA_RANK(rblapack_wgap) != 1)
    rb_raise(rb_eArgError, "rank of wgap (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_wgap) != (clend-clstrt+1))
    rb_raise(rb_eRuntimeError, "shape 0 of wgap must be %d", clend-clstrt+1);
  if (NA_TYPE(rblapack_wgap) != NA_DFLOAT)
    rblapack_wgap = na_change_type(rblapack_wgap, NA_DFLOAT);
  wgap = NA_PTR_TYPE(rblapack_wgap, doublereal*);
  pivmin = NUM2DBL(rblapack_pivmin);
  if (!NA_IsNArray(rblapack_w))
    rb_raise(rb_eArgError, "w (6th argument) must be NArray");
  if (NA_RANK(rblapack_w) != 1)
    rb_raise(rb_eArgError, "rank of w (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_w) != (clend-clstrt+1))
    rb_raise(rb_eRuntimeError, "shape 0 of w must be %d", clend-clstrt+1);
  if (NA_TYPE(rblapack_w) != NA_DFLOAT)
    rblapack_w = na_change_type(rblapack_w, NA_DFLOAT);
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  if (!NA_IsNArray(rblapack_werr))
    rb_raise(rb_eArgError, "werr (8th argument) must be NArray");
  if (NA_RANK(rblapack_werr) != 1)
    rb_raise(rb_eArgError, "rank of werr (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_werr) != (clend-clstrt+1))
    rb_raise(rb_eRuntimeError, "shape 0 of werr must be %d", clend-clstrt+1);
  if (NA_TYPE(rblapack_werr) != NA_DFLOAT)
    rblapack_werr = na_change_type(rblapack_werr, NA_DFLOAT);
  werr = NA_PTR_TYPE(rblapack_werr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_dplus = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  dplus = NA_PTR_TYPE(rblapack_dplus, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_lplus = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  lplus = NA_PTR_TYPE(rblapack_lplus, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = clend-clstrt+1;
    rblapack_wgap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  wgap_out__ = NA_PTR_TYPE(rblapack_wgap_out__, doublereal*);
  MEMCPY(wgap_out__, wgap, doublereal, NA_TOTAL(rblapack_wgap));
  rblapack_wgap = rblapack_wgap_out__;
  wgap = wgap_out__;
  work = ALLOC_N(doublereal, (2*n));

  dlarrf_(&n, d, l, ld, &clstrt, &clend, w, wgap, werr, &spdiam, &clgapl, &clgapr, &pivmin, &sigma, dplus, lplus, work, &info);

  free(work);
  rblapack_sigma = rb_float_new((double)sigma);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_sigma, rblapack_dplus, rblapack_lplus, rblapack_info, rblapack_wgap);
}

void
init_lapack_dlarrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlarrf", rblapack_dlarrf, -1);
}
ruby-lapack-1.7.2/ext/zlanhp.c0000644000175000017500000001103312502221024016013 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal zlanhp_(char* norm, char* uplo, integer* n, doublecomplex* ap, doublereal* work);


static VALUE
rblapack_zlanhp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack___out__;
  doublereal __out__; 
  doublereal *work;

  integer lwork;

  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  __out__ = NumRu::Lapack.zlanhp( norm, uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION ZLANHP( NORM, UPLO, N, AP, WORK )\n\n*  Purpose\n*  =======\n*\n*  ZLANHP  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  complex hermitian matrix A,  supplied in packed form.\n*\n*  Description\n*  ===========\n*\n*  ZLANHP returns the value\n*\n*     ZLANHP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in ZLANHP as described\n*          above.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          hermitian matrix A is supplied.\n*          = 'U':  Upper triangular part of A is supplied\n*          = 'L':  Lower triangular part of A is supplied\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, ZLANHP is\n*          set to zero.\n*\n*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          The upper or lower triangle of the hermitian matrix A, packed\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          Note that the  imaginary parts of the diagonal elements need\n*          not be set and are assumed to be zero.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n*          WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.zlanhp( norm, uplo, n, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_n = argv[2];
  rblapack_ap = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  n = NUM2INT(rblapack_n);
  lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  work = ALLOC_N(doublereal, (MAX(1,lwork)));

  __out__ = zlanhp_(&norm, &uplo, &n, ap, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_zlanhp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlanhp", rblapack_zlanhp, -1);
}
ruby-lapack-1.7.2/ext/sla_porpvgrw.c0000644000175000017500000001141512502221023017247 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real sla_porpvgrw_(char* uplo, integer* ncols, real* a, integer* lda, real* af, integer* ldaf, real* work);


static VALUE
rblapack_sla_porpvgrw(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ncols;
  integer ncols; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_af;
  real *af; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack___out__;
  real __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  __out__ = NumRu::Lapack.sla_porpvgrw( uplo, ncols, a, af, work, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL FUNCTION SLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, LDAF, WORK )\n\n*  Purpose\n*  =======\n* \n*  SLA_PORPVGRW computes the reciprocal pivot growth factor\n*  norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n*  much less than 1, the stability of the LU factorization of the\n*  (equilibrated) matrix A could be poor. This also means that the\n*  solution X, estimated condition numbers, and error bounds could be\n*  unreliable.\n*\n\n*  Arguments\n*  =========\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     NCOLS   (input) INTEGER\n*     The number of columns of the matrix A. NCOLS >= 0.\n*\n*     A       (input) REAL array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) REAL array, dimension (LDAF,N)\n*     The triangular factor U or L from the Cholesky factorization\n*     A = U**T*U or A = L*L**T, as computed by SPOTRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     WORK    (input) REAL array, dimension (2*N)\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n      REAL               AMAX, UMAX, RPVGRW\n      LOGICAL            UPPER\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX, MIN\n*     ..\n*     .. External Functions ..\n      EXTERNAL           LSAME, SLASET\n      LOGICAL            LSAME\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.sla_porpvgrw( uplo, ncols, a, af, work, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_ncols = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_work = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  ncols = NUM2INT(rblapack_ncols);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
  af = NA_PTR_TYPE(rblapack_af, real*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (5th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
  if (NA_TYPE(rblapack_work) != NA_SFLOAT)
    rblapack_work = na_change_type(rblapack_work, NA_SFLOAT);
  work = NA_PTR_TYPE(rblapack_work, real*);

  __out__ = sla_porpvgrw_(&uplo, &ncols, a, &lda, af, &ldaf, work);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_sla_porpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sla_porpvgrw", rblapack_sla_porpvgrw, -1);
}
ruby-lapack-1.7.2/ext/ztrti2.c0000644000175000017500000001013112502221012015750 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztrti2_(char* uplo, char* diag, integer* n, doublecomplex* a, integer* lda, integer* info);


static VALUE
rblapack_ztrti2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *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  info, a = NumRu::Lapack.ztrti2( uplo, diag, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTRTI2( UPLO, DIAG, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTRTI2 computes the inverse of a complex upper or lower triangular\n*  matrix.\n*\n*  This is the Level 2 BLAS version of the algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the matrix A is upper or lower triangular.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  DIAG    (input) CHARACTER*1\n*          Specifies whether or not the matrix A is unit triangular.\n*          = 'N':  Non-unit triangular\n*          = 'U':  Unit triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the triangular matrix A.  If UPLO = 'U', the\n*          leading n by n upper triangular part of the array A contains\n*          the upper triangular matrix, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n by n lower triangular part of the array A contains\n*          the lower triangular matrix, and the strictly upper\n*          triangular part of A is not referenced.  If DIAG = 'U', the\n*          diagonal elements of A are also not referenced and are\n*          assumed to be 1.\n*\n*          On exit, the (triangular) inverse of the original matrix, in\n*          the same storage format.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.ztrti2( uplo, diag, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_diag = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  diag = StringValueCStr(rblapack_diag)[0];
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  ztrti2_(&uplo, &diag, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_ztrti2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztrti2", rblapack_ztrti2, -1);
}
ruby-lapack-1.7.2/ext/dlaev2.c0000644000175000017500000000735012502221021015700 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaev2_(doublereal* a, doublereal* b, doublereal* c, doublereal* rt1, doublereal* rt2, doublereal* cs1, doublereal* sn1);


static VALUE
rblapack_dlaev2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublereal a; 
  VALUE rblapack_b;
  doublereal b; 
  VALUE rblapack_c;
  doublereal c; 
  VALUE rblapack_rt1;
  doublereal rt1; 
  VALUE rblapack_rt2;
  doublereal rt2; 
  VALUE rblapack_cs1;
  doublereal cs1; 
  VALUE rblapack_sn1;
  doublereal sn1; 


  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  rt1, rt2, cs1, sn1 = NumRu::Lapack.dlaev2( a, b, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 )\n\n*  Purpose\n*  =======\n*\n*  DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix\n*     [  A   B  ]\n*     [  B   C  ].\n*  On return, RT1 is the eigenvalue of larger absolute value, RT2 is the\n*  eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right\n*  eigenvector for RT1, giving the decomposition\n*\n*     [ CS1  SN1 ] [  A   B  ] [ CS1 -SN1 ]  =  [ RT1  0  ]\n*     [-SN1  CS1 ] [  B   C  ] [ SN1  CS1 ]     [  0  RT2 ].\n*\n\n*  Arguments\n*  =========\n*\n*  A       (input) DOUBLE PRECISION\n*          The (1,1) element of the 2-by-2 matrix.\n*\n*  B       (input) DOUBLE PRECISION\n*          The (1,2) element and the conjugate of the (2,1) element of\n*          the 2-by-2 matrix.\n*\n*  C       (input) DOUBLE PRECISION\n*          The (2,2) element of the 2-by-2 matrix.\n*\n*  RT1     (output) DOUBLE PRECISION\n*          The eigenvalue of larger absolute value.\n*\n*  RT2     (output) DOUBLE PRECISION\n*          The eigenvalue of smaller absolute value.\n*\n*  CS1     (output) DOUBLE PRECISION\n*  SN1     (output) DOUBLE PRECISION\n*          The vector (CS1, SN1) is a unit right eigenvector for RT1.\n*\n\n*  Further Details\n*  ===============\n*\n*  RT1 is accurate to a few ulps barring over/underflow.\n*\n*  RT2 may be inaccurate if there is massive cancellation in the\n*  determinant A*C-B*B; higher precision or correctly rounded or\n*  correctly truncated arithmetic would be needed to compute RT2\n*  accurately in all cases.\n*\n*  CS1 and SN1 are accurate to a few ulps barring over/underflow.\n*\n*  Overflow is possible only if RT1 is within a factor of 5 of overflow.\n*  Underflow is harmless if the input data is 0 or exceeds\n*     underflow_threshold / macheps.\n*\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rt1, rt2, cs1, sn1 = NumRu::Lapack.dlaev2( a, b, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  rblapack_c = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  a = NUM2DBL(rblapack_a);
  c = NUM2DBL(rblapack_c);
  b = NUM2DBL(rblapack_b);

  dlaev2_(&a, &b, &c, &rt1, &rt2, &cs1, &sn1);

  rblapack_rt1 = rb_float_new((double)rt1);
  rblapack_rt2 = rb_float_new((double)rt2);
  rblapack_cs1 = rb_float_new((double)cs1);
  rblapack_sn1 = rb_float_new((double)sn1);
  return rb_ary_new3(4, rblapack_rt1, rblapack_rt2, rblapack_cs1, rblapack_sn1);
}

void
init_lapack_dlaev2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaev2", rblapack_dlaev2, -1);
}
ruby-lapack-1.7.2/ext/chsein.c0000644000175000017500000002766612502221016016014 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chsein_(char* side, char* eigsrc, char* initv, logical* select, integer* n, complex* h, integer* ldh, complex* w, complex* vl, integer* ldvl, complex* vr, integer* ldvr, integer* mm, integer* m, complex* work, real* rwork, integer* ifaill, integer* ifailr, integer* info);


static VALUE
rblapack_chsein(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_eigsrc;
  char eigsrc; 
  VALUE rblapack_initv;
  char initv; 
  VALUE rblapack_select;
  logical *select; 
  VALUE rblapack_h;
  complex *h; 
  VALUE rblapack_w;
  complex *w; 
  VALUE rblapack_vl;
  complex *vl; 
  VALUE rblapack_vr;
  complex *vr; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_ifaill;
  integer *ifaill; 
  VALUE rblapack_ifailr;
  integer *ifailr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_w_out__;
  complex *w_out__;
  VALUE rblapack_vl_out__;
  complex *vl_out__;
  VALUE rblapack_vr_out__;
  complex *vr_out__;
  complex *work;
  real *rwork;

  integer n;
  integer ldh;
  integer ldvl;
  integer mm;
  integer ldvr;

  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  m, ifaill, ifailr, info, w, vl, vr = NumRu::Lapack.chsein( side, eigsrc, initv, select, h, w, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, W, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, IFAILL, IFAILR, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHSEIN uses inverse iteration to find specified right and/or left\n*  eigenvectors of a complex upper Hessenberg matrix H.\n*\n*  The right eigenvector x and the left eigenvector y of the matrix H\n*  corresponding to an eigenvalue w are defined by:\n*\n*               H * x = w * x,     y**h * H = w * y**h\n*\n*  where y**h denotes the conjugate transpose of the vector y.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'R': compute right eigenvectors only;\n*          = 'L': compute left eigenvectors only;\n*          = 'B': compute both right and left eigenvectors.\n*\n*  EIGSRC  (input) CHARACTER*1\n*          Specifies the source of eigenvalues supplied in W:\n*          = 'Q': the eigenvalues were found using CHSEQR; thus, if\n*                 H has zero subdiagonal elements, and so is\n*                 block-triangular, then the j-th eigenvalue can be\n*                 assumed to be an eigenvalue of the block containing\n*                 the j-th row/column.  This property allows CHSEIN to\n*                 perform inverse iteration on just one diagonal block.\n*          = 'N': no assumptions are made on the correspondence\n*                 between eigenvalues and diagonal blocks.  In this\n*                 case, CHSEIN must always perform inverse iteration\n*                 using the whole matrix H.\n*\n*  INITV   (input) CHARACTER*1\n*          = 'N': no initial vectors are supplied;\n*          = 'U': user-supplied initial vectors are stored in the arrays\n*                 VL and/or VR.\n*\n*  SELECT  (input) LOGICAL array, dimension (N)\n*          Specifies the eigenvectors to be computed. To select the\n*          eigenvector corresponding to the eigenvalue W(j),\n*          SELECT(j) must be set to .TRUE..\n*\n*  N       (input) INTEGER\n*          The order of the matrix H.  N >= 0.\n*\n*  H       (input) COMPLEX array, dimension (LDH,N)\n*          The upper Hessenberg matrix H.\n*\n*  LDH     (input) INTEGER\n*          The leading dimension of the array H.  LDH >= max(1,N).\n*\n*  W       (input/output) COMPLEX array, dimension (N)\n*          On entry, the eigenvalues of H.\n*          On exit, the real parts of W may have been altered since\n*          close eigenvalues are perturbed slightly in searching for\n*          independent eigenvectors.\n*\n*  VL      (input/output) COMPLEX array, dimension (LDVL,MM)\n*          On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must\n*          contain starting vectors for the inverse iteration for the\n*          left eigenvectors; the starting vector for each eigenvector\n*          must be in the same column in which the eigenvector will be\n*          stored.\n*          On exit, if SIDE = 'L' or 'B', the left eigenvectors\n*          specified by SELECT will be stored consecutively in the\n*          columns of VL, in the same order as their eigenvalues.\n*          If SIDE = 'R', VL is not referenced.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the array VL.\n*          LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.\n*\n*  VR      (input/output) COMPLEX array, dimension (LDVR,MM)\n*          On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must\n*          contain starting vectors for the inverse iteration for the\n*          right eigenvectors; the starting vector for each eigenvector\n*          must be in the same column in which the eigenvector will be\n*          stored.\n*          On exit, if SIDE = 'R' or 'B', the right eigenvectors\n*          specified by SELECT will be stored consecutively in the\n*          columns of VR, in the same order as their eigenvalues.\n*          If SIDE = 'L', VR is not referenced.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the array VR.\n*          LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.\n*\n*  MM      (input) INTEGER\n*          The number of columns in the arrays VL and/or VR. MM >= M.\n*\n*  M       (output) INTEGER\n*          The number of columns in the arrays VL and/or VR required to\n*          store the eigenvectors (= the number of .TRUE. elements in\n*          SELECT).\n*\n*  WORK    (workspace) COMPLEX array, dimension (N*N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\n*\n*  IFAILL  (output) INTEGER array, dimension (MM)\n*          If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left\n*          eigenvector in the i-th column of VL (corresponding to the\n*          eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the\n*          eigenvector converged satisfactorily.\n*          If SIDE = 'R', IFAILL is not referenced.\n*\n*  IFAILR  (output) INTEGER array, dimension (MM)\n*          If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right\n*          eigenvector in the i-th column of VR (corresponding to the\n*          eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the\n*          eigenvector converged satisfactorily.\n*          If SIDE = 'L', IFAILR is not referenced.\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, i is the number of eigenvectors which\n*                failed to converge; see IFAILL and IFAILR for further\n*                details.\n*\n\n*  Further Details\n*  ===============\n*\n*  Each eigenvector is normalized so that the element of largest\n*  magnitude has magnitude 1; here the magnitude of a complex number\n*  (x,y) is taken to be |x|+|y|.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, ifaill, ifailr, info, w, vl, vr = NumRu::Lapack.chsein( side, eigsrc, initv, select, h, w, vl, vr, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_side = argv[0];
  rblapack_eigsrc = argv[1];
  rblapack_initv = argv[2];
  rblapack_select = argv[3];
  rblapack_h = argv[4];
  rblapack_w = argv[5];
  rblapack_vl = argv[6];
  rblapack_vr = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  initv = StringValueCStr(rblapack_initv)[0];
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (5th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_SCOMPLEX)
    rblapack_h = na_change_type(rblapack_h, NA_SCOMPLEX);
  h = NA_PTR_TYPE(rblapack_h, complex*);
  if (!NA_IsNArray(rblapack_vl))
    rb_raise(rb_eArgError, "vl (7th argument) must be NArray");
  if (NA_RANK(rblapack_vl) != 2)
    rb_raise(rb_eArgError, "rank of vl (7th argument) must be %d", 2);
  ldvl = NA_SHAPE0(rblapack_vl);
  mm = NA_SHAPE1(rblapack_vl);
  if (NA_TYPE(rblapack_vl) != NA_SCOMPLEX)
    rblapack_vl = na_change_type(rblapack_vl, NA_SCOMPLEX);
  vl = NA_PTR_TYPE(rblapack_vl, complex*);
  eigsrc = StringValueCStr(rblapack_eigsrc)[0];
  if (!NA_IsNArray(rblapack_w))
    rb_raise(rb_eArgError, "w (6th argument) must be NArray");
  if (NA_RANK(rblapack_w) != 1)
    rb_raise(rb_eArgError, "rank of w (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_w) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 1 of h");
  if (NA_TYPE(rblapack_w) != NA_SCOMPLEX)
    rblapack_w = na_change_type(rblapack_w, NA_SCOMPLEX);
  w = NA_PTR_TYPE(rblapack_w, complex*);
  if (!NA_IsNArray(rblapack_select))
    rb_raise(rb_eArgError, "select (4th argument) must be NArray");
  if (NA_RANK(rblapack_select) != 1)
    rb_raise(rb_eArgError, "rank of select (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_select) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of h");
  if (NA_TYPE(rblapack_select) != NA_LINT)
    rblapack_select = na_change_type(rblapack_select, NA_LINT);
  select = NA_PTR_TYPE(rblapack_select, logical*);
  if (!NA_IsNArray(rblapack_vr))
    rb_raise(rb_eArgError, "vr (8th argument) must be NArray");
  if (NA_RANK(rblapack_vr) != 2)
    rb_raise(rb_eArgError, "rank of vr (8th argument) must be %d", 2);
  ldvr = NA_SHAPE0(rblapack_vr);
  if (NA_SHAPE1(rblapack_vr) != mm)
    rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
  if (NA_TYPE(rblapack_vr) != NA_SCOMPLEX)
    rblapack_vr = na_change_type(rblapack_vr, NA_SCOMPLEX);
  vr = NA_PTR_TYPE(rblapack_vr, complex*);
  {
    na_shape_t shape[1];
    shape[0] = mm;
    rblapack_ifaill = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifaill = NA_PTR_TYPE(rblapack_ifaill, integer*);
  {
    na_shape_t shape[1];
    shape[0] = mm;
    rblapack_ifailr = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifailr = NA_PTR_TYPE(rblapack_ifailr, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  w_out__ = NA_PTR_TYPE(rblapack_w_out__, complex*);
  MEMCPY(w_out__, w, complex, NA_TOTAL(rblapack_w));
  rblapack_w = rblapack_w_out__;
  w = w_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = mm;
    rblapack_vl_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, complex*);
  MEMCPY(vl_out__, vl, complex, NA_TOTAL(rblapack_vl));
  rblapack_vl = rblapack_vl_out__;
  vl = vl_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = mm;
    rblapack_vr_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  vr_out__ = NA_PTR_TYPE(rblapack_vr_out__, complex*);
  MEMCPY(vr_out__, vr, complex, NA_TOTAL(rblapack_vr));
  rblapack_vr = rblapack_vr_out__;
  vr = vr_out__;
  work = ALLOC_N(complex, (n*n));
  rwork = ALLOC_N(real, (n));

  chsein_(&side, &eigsrc, &initv, select, &n, h, &ldh, w, vl, &ldvl, vr, &ldvr, &mm, &m, work, rwork, ifaill, ifailr, &info);

  free(work);
  free(rwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_m, rblapack_ifaill, rblapack_ifailr, rblapack_info, rblapack_w, rblapack_vl, rblapack_vr);
}

void
init_lapack_chsein(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chsein", rblapack_chsein, -1);
}
ruby-lapack-1.7.2/ext/zla_porpvgrw.c0000644000175000017500000001220412502221026017256 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal zla_porpvgrw_(char* uplo, integer* ncols, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, doublecomplex* work);


static VALUE
rblapack_zla_porpvgrw(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ncols;
  integer ncols; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack___out__;
  doublereal __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  __out__ = NumRu::Lapack.zla_porpvgrw( uplo, ncols, a, af, work, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION ZLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF,  LDAF, WORK )\n\n*  Purpose\n*  =======\n* \n*  ZLA_PORPVGRW computes the reciprocal pivot growth factor\n*  norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n*  much less than 1, the stability of the LU factorization of the\n*  (equilibrated) matrix A could be poor. This also means that the\n*  solution X, estimated condition numbers, and error bounds could be\n*  unreliable.\n*\n\n*  Arguments\n*  =========\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     NCOLS   (input) INTEGER\n*     The number of columns of the matrix A. NCOLS >= 0.\n*\n*     A       (input) COMPLEX*16 array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX*16 array, dimension (LDAF,N)\n*     The triangular factor U or L from the Cholesky factorization\n*     A = U**T*U or A = L*L**T, as computed by ZPOTRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     WORK    (input) COMPLEX*16 array, dimension (2*N)\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n      DOUBLE PRECISION   AMAX, UMAX, RPVGRW\n      LOGICAL            UPPER\n      COMPLEX*16         ZDUM\n*     ..\n*     .. External Functions ..\n      EXTERNAL           LSAME, ZLASET\n      LOGICAL            LSAME\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX, MIN, REAL, DIMAG\n*     ..\n*     .. Statement Functions ..\n      DOUBLE PRECISION   CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.zla_porpvgrw( uplo, ncols, a, af, work, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_ncols = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_work = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  ncols = NUM2INT(rblapack_ncols);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (5th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
  if (NA_TYPE(rblapack_work) != NA_DCOMPLEX)
    rblapack_work = na_change_type(rblapack_work, NA_DCOMPLEX);
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);

  __out__ = zla_porpvgrw_(&uplo, &ncols, a, &lda, af, &ldaf, work);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_zla_porpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zla_porpvgrw", rblapack_zla_porpvgrw, -1);
}
ruby-lapack-1.7.2/ext/claqhe.c0000644000175000017500000001226312502221021015757 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID claqhe_(char* uplo, integer* n, complex* a, integer* lda, real* s, real* scond, real* amax, char* equed);


static VALUE
rblapack_claqhe(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_scond;
  real scond; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_a_out__;
  complex *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  equed, a = NumRu::Lapack.claqhe( uplo, a, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )\n\n*  Purpose\n*  =======\n*\n*  CLAQHE equilibrates a Hermitian matrix A using the scaling factors\n*  in the vector S.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          Hermitian matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading\n*          n by n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n by n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if EQUED = 'Y', the equilibrated matrix:\n*          diag(S) * A * diag(S).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(N,1).\n*\n*  S       (input) REAL array, dimension (N)\n*          The scale factors for A.\n*\n*  SCOND   (input) REAL\n*          Ratio of the smallest S(i) to the largest S(i).\n*\n*  AMAX    (input) REAL\n*          Absolute value of largest matrix entry.\n*\n*  EQUED   (output) CHARACTER*1\n*          Specifies whether or not equilibration was done.\n*          = 'N':  No equilibration.\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*\n*  Internal Parameters\n*  ===================\n*\n*  THRESH is a threshold value used to decide if scaling should be done\n*  based on the ratio of the scaling factors.  If SCOND < THRESH,\n*  scaling is done.\n*\n*  LARGE and SMALL are threshold values used to decide if scaling should\n*  be done based on the absolute size of the largest matrix element.\n*  If AMAX > LARGE or AMAX < SMALL, scaling is done.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  equed, a = NumRu::Lapack.claqhe( uplo, a, s, scond, amax, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_s = argv[2];
  rblapack_scond = argv[3];
  rblapack_amax = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (3th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_s);
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  amax = (real)NUM2DBL(rblapack_amax);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of s");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  scond = (real)NUM2DBL(rblapack_scond);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  claqhe_(&uplo, &n, a, &lda, s, &scond, &amax, &equed);

  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(2, rblapack_equed, rblapack_a);
}

void
init_lapack_claqhe(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "claqhe", rblapack_claqhe, -1);
}
ruby-lapack-1.7.2/ext/ssysvxx.c0000644000175000017500000006473512502221015016307 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssysvxx_(char* fact, char* uplo, integer* n, integer* nrhs, real* a, integer* lda, real* af, integer* ldaf, integer* ipiv, char* equed, real* s, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* rpvgrw, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, real* work, integer* iwork, integer* info);


static VALUE
rblapack_ssysvxx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_af;
  real *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_params;
  real *params; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_rpvgrw;
  real rpvgrw; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_err_bnds_norm;
  real *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  real *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_af_out__;
  real *af_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  VALUE rblapack_s_out__;
  real *s_out__;
  VALUE rblapack_b_out__;
  real *b_out__;
  VALUE rblapack_params_out__;
  real *params_out__;
  real *work;
  integer *iwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer nparams;
  integer ldx;
  integer n_err_bnds;

  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  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.ssysvxx( fact, uplo, a, af, ipiv, equed, s, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     SSYSVXX uses the diagonal pivoting factorization to compute the\n*     solution to a real system of linear equations A * X = B, where A\n*     is an N-by-N symmetric matrix and X and B are N-by-NRHS matrices.\n*\n*     If requested, both normwise and maximum componentwise error bounds\n*     are returned. SSYSVXX will return a solution with a tiny\n*     guaranteed error (O(eps) where eps is the working machine\n*     precision) unless the matrix is very ill-conditioned, in which\n*     case a warning is returned. Relevant condition numbers also are\n*     calculated and returned.\n*\n*     SSYSVXX accepts user-provided factorizations and equilibration\n*     factors; see the definitions of the FACT and EQUED options.\n*     Solving with refinement and using a factorization from a previous\n*     SSYSVXX call will also produce a solution with either O(eps)\n*     errors or warnings, but we cannot make that claim for general\n*     user-provided factorizations and equilibration factors if they\n*     differ from what SSYSVXX would itself produce.\n*\n*     Description\n*     ===========\n*\n*     The following steps are performed:\n*\n*     1. If FACT = 'E', real scaling factors are computed to equilibrate\n*     the system:\n*\n*       diag(S)*A*diag(S)     *inv(diag(S))*X = diag(S)*B\n*\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n*     2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n*     the matrix A (after equilibration if FACT = 'E') as\n*\n*        A = U * D * U**T,  if UPLO = 'U', or\n*        A = L * D * L**T,  if UPLO = 'L',\n*\n*     where U (or L) is a product of permutation and unit upper (lower)\n*     triangular matrices, and D is symmetric and block diagonal with\n*     1-by-1 and 2-by-2 diagonal blocks.\n*\n*     3. If some D(i,i)=0, so that D is exactly singular, then the\n*     routine returns with INFO = i. Otherwise, the factored form of A\n*     is used to estimate the condition number of the matrix A (see\n*     argument RCOND).  If the reciprocal of the condition number is\n*     less than machine precision, the routine still goes on to solve\n*     for X and compute error bounds as described below.\n*\n*     4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*     5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n*     the routine will use iterative refinement to try to get a small\n*     error and error bounds.  Refinement calculates the residual to at\n*     least twice the working precision.\n*\n*     6. If equilibration was used, the matrix X is premultiplied by\n*     diag(R) so that it solves the original system before\n*     equilibration.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     FACT    (input) CHARACTER*1\n*     Specifies whether or not the factored form of the matrix A is\n*     supplied on entry, and if not, whether the matrix A should be\n*     equilibrated before it is factored.\n*       = 'F':  On entry, AF and IPIV contain the factored form of A.\n*               If EQUED is not 'N', the matrix A has been\n*               equilibrated with scaling factors given by S.\n*               A, AF, and IPIV are not modified.\n*       = 'N':  The matrix A will be copied to AF and factored.\n*       = 'E':  The matrix A will be equilibrated if necessary, then\n*               copied to AF and factored.\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     A       (input/output) REAL array, dimension (LDA,N)\n*     The symmetric matrix A.  If UPLO = 'U', the leading N-by-N\n*     upper triangular part of A contains the upper triangular\n*     part of the matrix A, and the strictly lower triangular\n*     part of A is not referenced.  If UPLO = 'L', the leading\n*     N-by-N lower triangular part of A contains the lower\n*     triangular part of the matrix A, and the strictly upper\n*     triangular part of A is not referenced.\n*\n*     On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n*     diag(S)*A*diag(S).\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input or output) REAL array, dimension (LDAF,N)\n*     If FACT = 'F', then AF is an input argument and on entry\n*     contains the block diagonal matrix D and the multipliers\n*     used to obtain the factor U or L from the factorization A =\n*     U*D*U**T or A = L*D*L**T as computed by SSYTRF.\n*\n*     If FACT = 'N', then AF is an output argument and on exit\n*     returns the block diagonal matrix D and the multipliers\n*     used to obtain the factor U or L from the factorization A =\n*     U*D*U**T or A = L*D*L**T.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input or output) INTEGER array, dimension (N)\n*     If FACT = 'F', then IPIV is an input argument and on entry\n*     contains details of the interchanges and the block\n*     structure of D, as determined by SSYTRF.  If IPIV(k) > 0,\n*     then rows and columns k and IPIV(k) were interchanged and\n*     D(k,k) is a 1-by-1 diagonal block.  If UPLO = 'U' and\n*     IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and\n*     -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2\n*     diagonal block.  If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0,\n*     then rows and columns k+1 and -IPIV(k) were interchanged\n*     and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*     If FACT = 'N', then IPIV is an output argument and on exit\n*     contains details of the interchanges and the block\n*     structure of D, as determined by SSYTRF.\n*\n*     EQUED   (input or output) CHARACTER*1\n*     Specifies the form of equilibration that was done.\n*       = 'N':  No equilibration (always true if FACT = 'N').\n*       = 'Y':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(S) * A * diag(S).\n*     EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*     output argument.\n*\n*     S       (input or output) REAL array, dimension (N)\n*     The scale factors for A.  If EQUED = 'Y', A is multiplied on\n*     the left and right by diag(S).  S is an input argument if FACT =\n*     'F'; otherwise, S is an output argument.  If FACT = 'F' and EQUED\n*     = 'Y', each element of S must be positive.  If S is output, each\n*     element of S is a power of the radix. If S is input, each element\n*     of S should be a power of the radix to ensure a reliable solution\n*     and error estimates. Scaling by powers of the radix does not cause\n*     rounding errors unless the result underflows or overflows.\n*     Rounding errors during scaling lead to refining with a matrix that\n*     is not equivalent to the input matrix, producing error estimates\n*     that may not be reliable.\n*\n*     B       (input/output) REAL array, dimension (LDB,NRHS)\n*     On entry, the N-by-NRHS right hand side matrix B.\n*     On exit,\n*     if EQUED = 'N', B is not modified;\n*     if EQUED = 'Y', B is overwritten by diag(S)*B;\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (output) REAL array, dimension (LDX,NRHS)\n*     If INFO = 0, the N-by-NRHS solution matrix X to the original\n*     system of equations.  Note that A and B are modified on exit if\n*     EQUED .ne. 'N', and the solution to the equilibrated system is\n*     inv(diag(S))*X.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) REAL\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     RPVGRW  (output) REAL\n*     Reciprocal pivot growth.  On exit, this contains the reciprocal\n*     pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n*     norm is used.  If this is much less than 1, then the stability of\n*     the LU factorization of the (equilibrated) matrix A could be poor.\n*     This also means that the solution X, estimated condition numbers,\n*     and error bounds could be unreliable. If factorization fails with\n*     0 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.ssysvxx( fact, uplo, a, af, ipiv, equed, s, b, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_equed = argv[5];
  rblapack_s = argv[6];
  rblapack_b = argv[7];
  rblapack_params = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (7th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (9th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_SFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
  params = NA_PTR_TYPE(rblapack_params, real*);
  n_err_bnds = 3;
  uplo = StringValueCStr(rblapack_uplo)[0];
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
  af = NA_PTR_TYPE(rblapack_af, real*);
  ldx = MAX(1,n);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldaf;
    shape[1] = n;
    rblapack_af_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  af_out__ = NA_PTR_TYPE(rblapack_af_out__, real*);
  MEMCPY(af_out__, af, real, NA_TOTAL(rblapack_af));
  rblapack_af = rblapack_af_out__;
  af = af_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
  MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
  MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(real, (4*n));
  iwork = ALLOC_N(integer, (n));

  ssysvxx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, s, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_rpvgrw = rb_float_new((double)rpvgrw);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(14, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_a, rblapack_af, rblapack_ipiv, rblapack_equed, rblapack_s, rblapack_b, rblapack_params);
}

void
init_lapack_ssysvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssysvxx", rblapack_ssysvxx, -1);
}
ruby-lapack-1.7.2/ext/slartgp.c0000644000175000017500000000535612502221023016205 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slartgp_(real* f, real* g, real* cs, real* sn, real* r);


static VALUE
rblapack_slartgp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_f;
  real f; 
  VALUE rblapack_g;
  real g; 
  VALUE rblapack_cs;
  real cs; 
  VALUE rblapack_sn;
  real sn; 
  VALUE rblapack_r;
  real r; 


  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  cs, sn, r = NumRu::Lapack.slartgp( f, g, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLARTGP( F, G, CS, SN, R )\n\n*  Purpose\n*  =======\n*\n*  SLARTGP generates a plane rotation so that\n*\n*     [  CS  SN  ]  .  [ F ]  =  [ R ]   where CS**2 + SN**2 = 1.\n*     [ -SN  CS  ]     [ G ]     [ 0 ]\n*\n*  This is a slower, more accurate version of the Level 1 BLAS routine SROTG,\n*  with the following other differences:\n*     F and G are unchanged on return.\n*     If G=0, then CS=(+/-)1 and SN=0.\n*     If F=0 and (G .ne. 0), then CS=0 and SN=(+/-)1.\n*\n*  The sign is chosen so that R >= 0.\n*\n\n*  Arguments\n*  =========\n*\n*  F       (input) REAL\n*          The first component of vector to be rotated.\n*\n*  G       (input) REAL\n*          The second component of vector to be rotated.\n*\n*  CS      (output) REAL\n*          The cosine of the rotation.\n*\n*  SN      (output) REAL\n*          The sine of the rotation.\n*\n*  R       (output) REAL\n*          The nonzero component of the rotated vector.\n*\n*  This version has a few statements commented out for thread safety\n*  (machine parameters are computed on each entry). 10 feb 03, SJH.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  cs, sn, r = NumRu::Lapack.slartgp( f, g, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_f = argv[0];
  rblapack_g = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  f = (real)NUM2DBL(rblapack_f);
  g = (real)NUM2DBL(rblapack_g);

  slartgp_(&f, &g, &cs, &sn, &r);

  rblapack_cs = rb_float_new((double)cs);
  rblapack_sn = rb_float_new((double)sn);
  rblapack_r = rb_float_new((double)r);
  return rb_ary_new3(3, rblapack_cs, rblapack_sn, rblapack_r);
}

void
init_lapack_slartgp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slartgp", rblapack_slartgp, -1);
}
ruby-lapack-1.7.2/ext/sptsv.c0000644000175000017500000001345512502221020015704 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sptsv_(integer* n, integer* nrhs, real* d, real* e, real* b, integer* ldb, integer* info);


static VALUE
rblapack_sptsv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_e_out__;
  real *e_out__;
  VALUE rblapack_b_out__;
  real *b_out__;

  integer n;
  integer ldb;
  integer nrhs;

  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  info, d, e, b = NumRu::Lapack.sptsv( d, e, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPTSV( N, NRHS, D, E, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPTSV computes the solution to a real system of linear equations\n*  A*X = B, where A is an N-by-N symmetric positive definite tridiagonal\n*  matrix, and X and B are N-by-NRHS matrices.\n*\n*  A is factored as A = L*D*L**T, and the factored form of A is then\n*  used to solve the system of equations.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  D       (input/output) REAL array, dimension (N)\n*          On entry, the n diagonal elements of the tridiagonal matrix\n*          A.  On exit, the n diagonal elements of the diagonal matrix\n*          D from the factorization A = L*D*L**T.\n*\n*  E       (input/output) REAL array, dimension (N-1)\n*          On entry, the (n-1) subdiagonal elements of the tridiagonal\n*          matrix A.  On exit, the (n-1) subdiagonal elements of the\n*          unit bidiagonal factor L from the L*D*L**T factorization of\n*          A.  (E can also be regarded as the superdiagonal of the unit\n*          bidiagonal factor U from the U**T*D*U factorization of A.)\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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 leading minor of order i is not\n*                positive definite, and the solution has not been\n*                computed.  The factorization has not been completed\n*                unless i = N.\n*\n\n*  =====================================================================\n*\n*     .. External Subroutines ..\n      EXTERNAL           SPTTRF, SPTTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, e, b = NumRu::Lapack.sptsv( d, e, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_d = argv[0];
  rblapack_e = argv[1];
  rblapack_b = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  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);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (2th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
  MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  sptsv_(&n, &nrhs, d, e, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_e, rblapack_b);
}

void
init_lapack_sptsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sptsv", rblapack_sptsv, -1);
}
ruby-lapack-1.7.2/ext/slaqr2.c0000644000175000017500000002701112502221016015727 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaqr2_(logical* wantt, logical* wantz, integer* n, integer* ktop, integer* kbot, integer* nw, real* h, integer* ldh, integer* iloz, integer* ihiz, real* z, integer* ldz, integer* ns, integer* nd, real* sr, real* si, real* v, integer* ldv, integer* nh, real* t, integer* ldt, integer* nv, real* wv, integer* ldwv, real* work, integer* lwork);


static VALUE
rblapack_slaqr2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantt;
  logical wantt; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_ktop;
  integer ktop; 
  VALUE rblapack_kbot;
  integer kbot; 
  VALUE rblapack_nw;
  integer nw; 
  VALUE rblapack_h;
  real *h; 
  VALUE rblapack_iloz;
  integer iloz; 
  VALUE rblapack_ihiz;
  integer ihiz; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_nh;
  integer nh; 
  VALUE rblapack_nv;
  integer nv; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_ns;
  integer ns; 
  VALUE rblapack_nd;
  integer nd; 
  VALUE rblapack_sr;
  real *sr; 
  VALUE rblapack_si;
  real *si; 
  VALUE rblapack_h_out__;
  real *h_out__;
  VALUE rblapack_z_out__;
  real *z_out__;
  real *v;
  real *t;
  real *wv;
  real *work;

  integer ldh;
  integer n;
  integer ldz;
  integer ldv;
  integer ldt;
  integer ldwv;

  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  ns, nd, sr, si, h, z = NumRu::Lapack.slaqr2( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n*     This subroutine is identical to SLAQR3 except that it avoids\n*     recursion by calling SLAHQR instead of SLAQR4.\n*\n*\n*     ******************************************************************\n*     Aggressive early deflation:\n*\n*     This subroutine accepts as input an upper Hessenberg matrix\n*     H and performs an orthogonal similarity transformation\n*     designed to detect and deflate fully converged eigenvalues from\n*     a trailing principal submatrix.  On output H has been over-\n*     written by a new Hessenberg matrix that is a perturbation of\n*     an orthogonal similarity transformation of H.  It is to be\n*     hoped that the final version of H has many zero subdiagonal\n*     entries.\n*\n*     ******************************************************************\n\n*     WANTT   (input) LOGICAL\n*          If .TRUE., then the Hessenberg matrix H is fully updated\n*          so that the quasi-triangular Schur factor may be\n*          computed (in cooperation with the calling subroutine).\n*          If .FALSE., then only enough of H is updated to preserve\n*          the eigenvalues.\n*\n*     WANTZ   (input) LOGICAL\n*          If .TRUE., then the orthogonal matrix Z is updated so\n*          so that the orthogonal Schur factor may be computed\n*          (in cooperation with the calling subroutine).\n*          If .FALSE., then Z is not referenced.\n*\n*     N       (input) INTEGER\n*          The order of the matrix H and (if WANTZ is .TRUE.) the\n*          order of the orthogonal matrix Z.\n*\n*     KTOP    (input) INTEGER\n*          It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n*          KBOT and KTOP together determine an isolated block\n*          along the diagonal of the Hessenberg matrix.\n*\n*     KBOT    (input) INTEGER\n*          It is assumed without a check that either\n*          KBOT = N or H(KBOT+1,KBOT)=0.  KBOT and KTOP together\n*          determine an isolated block along the diagonal of the\n*          Hessenberg matrix.\n*\n*     NW      (input) INTEGER\n*          Deflation window size.  1 .LE. NW .LE. (KBOT-KTOP+1).\n*\n*     H       (input/output) REAL array, dimension (LDH,N)\n*          On input the initial N-by-N section of H stores the\n*          Hessenberg matrix undergoing aggressive early deflation.\n*          On output H has been transformed by an orthogonal\n*          similarity transformation, perturbed, and the returned\n*          to Hessenberg form that (it is to be hoped) has some\n*          zero subdiagonal entries.\n*\n*     LDH     (input) integer\n*          Leading dimension of H just as declared in the calling\n*          subroutine.  N .LE. LDH\n*\n*     ILOZ    (input) INTEGER\n*     IHIZ    (input) INTEGER\n*          Specify the rows of Z to which transformations must be\n*          applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n*\n*     Z       (input/output) REAL array, dimension (LDZ,N)\n*          IF WANTZ is .TRUE., then on output, the orthogonal\n*          similarity transformation mentioned above has been\n*          accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n*          If WANTZ is .FALSE., then Z is unreferenced.\n*\n*     LDZ     (input) integer\n*          The leading dimension of Z just as declared in the\n*          calling subroutine.  1 .LE. LDZ.\n*\n*     NS      (output) integer\n*          The number of unconverged (ie approximate) eigenvalues\n*          returned in SR and SI that may be used as shifts by the\n*          calling subroutine.\n*\n*     ND      (output) integer\n*          The number of converged eigenvalues uncovered by this\n*          subroutine.\n*\n*     SR      (output) REAL array, dimension KBOT\n*     SI      (output) REAL array, dimension KBOT\n*          On output, the real and imaginary parts of approximate\n*          eigenvalues that may be used for shifts are stored in\n*          SR(KBOT-ND-NS+1) through SR(KBOT-ND) and\n*          SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.\n*          The real and imaginary parts of converged eigenvalues\n*          are stored in SR(KBOT-ND+1) through SR(KBOT) and\n*          SI(KBOT-ND+1) through SI(KBOT), respectively.\n*\n*     V       (workspace) REAL array, dimension (LDV,NW)\n*          An NW-by-NW work array.\n*\n*     LDV     (input) integer scalar\n*          The leading dimension of V just as declared in the\n*          calling subroutine.  NW .LE. LDV\n*\n*     NH      (input) integer scalar\n*          The number of columns of T.  NH.GE.NW.\n*\n*     T       (workspace) REAL array, dimension (LDT,NW)\n*\n*     LDT     (input) integer\n*          The leading dimension of T just as declared in the\n*          calling subroutine.  NW .LE. LDT\n*\n*     NV      (input) integer\n*          The number of rows of work array WV available for\n*          workspace.  NV.GE.NW.\n*\n*     WV      (workspace) REAL array, dimension (LDWV,NW)\n*\n*     LDWV    (input) integer\n*          The leading dimension of W just as declared in the\n*          calling subroutine.  NW .LE. LDV\n*\n*     WORK    (workspace) REAL array, dimension LWORK.\n*          On exit, WORK(1) is set to an estimate of the optimal value\n*          of LWORK for the given values of N, NW, KTOP and KBOT.\n*\n*     LWORK   (input) integer\n*          The dimension of the work array WORK.  LWORK = 2*NW\n*          suffices, but greater efficiency may result from larger\n*          values of LWORK.\n*\n*          If LWORK = -1, then a workspace query is assumed; SLAQR2\n*          only estimates the optimal workspace size for the given\n*          values of N, NW, KTOP and KBOT.  The estimate is returned\n*          in WORK(1).  No error message related to LWORK is issued\n*          by XERBLA.  Neither H nor Z are accessed.\n*\n\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ns, nd, sr, si, h, z = NumRu::Lapack.slaqr2( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 11 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
  rblapack_wantt = argv[0];
  rblapack_wantz = argv[1];
  rblapack_ktop = argv[2];
  rblapack_kbot = argv[3];
  rblapack_nw = argv[4];
  rblapack_h = argv[5];
  rblapack_iloz = argv[6];
  rblapack_ihiz = argv[7];
  rblapack_z = argv[8];
  rblapack_nh = argv[9];
  rblapack_nv = argv[10];
  if (argc == 12) {
    rblapack_lwork = argv[11];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  wantt = (rblapack_wantt == Qtrue);
  ktop = NUM2INT(rblapack_ktop);
  nw = NUM2INT(rblapack_nw);
  iloz = NUM2INT(rblapack_iloz);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (9th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  n = NA_SHAPE1(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  nv = NUM2INT(rblapack_nv);
  ldwv = nw;
  ldv = nw;
  wantz = (rblapack_wantz == Qtrue);
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (6th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  if (NA_SHAPE1(rblapack_h) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of z");
  if (NA_TYPE(rblapack_h) != NA_SFLOAT)
    rblapack_h = na_change_type(rblapack_h, NA_SFLOAT);
  h = NA_PTR_TYPE(rblapack_h, real*);
  nh = NUM2INT(rblapack_nh);
  ldt = nw;
  kbot = NUM2INT(rblapack_kbot);
  if (rblapack_lwork == Qnil)
    lwork = 2*nw;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ihiz = NUM2INT(rblapack_ihiz);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,kbot);
    rblapack_sr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  sr = NA_PTR_TYPE(rblapack_sr, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,kbot);
    rblapack_si = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  si = NA_PTR_TYPE(rblapack_si, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, real*);
  MEMCPY(h_out__, h, real, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
  MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  v = ALLOC_N(real, (ldv)*(MAX(1,nw)));
  t = ALLOC_N(real, (ldt)*(MAX(1,nw)));
  wv = ALLOC_N(real, (ldwv)*(MAX(1,nw)));
  work = ALLOC_N(real, (MAX(1,lwork)));

  slaqr2_(&wantt, &wantz, &n, &ktop, &kbot, &nw, h, &ldh, &iloz, &ihiz, z, &ldz, &ns, &nd, sr, si, v, &ldv, &nh, t, &ldt, &nv, wv, &ldwv, work, &lwork);

  free(v);
  free(t);
  free(wv);
  free(work);
  rblapack_ns = INT2NUM(ns);
  rblapack_nd = INT2NUM(nd);
  return rb_ary_new3(6, rblapack_ns, rblapack_nd, rblapack_sr, rblapack_si, rblapack_h, rblapack_z);
}

void
init_lapack_slaqr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaqr2", rblapack_slaqr2, -1);
}
ruby-lapack-1.7.2/ext/slarfgp.c0000644000175000017500000000740212502221021016157 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slarfgp_(integer* n, real* alpha, real* x, integer* incx, real* tau);


static VALUE
rblapack_slarfgp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_alpha;
  real alpha; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_tau;
  real tau; 
  VALUE rblapack_x_out__;
  real *x_out__;


  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, alpha, x = NumRu::Lapack.slarfgp( n, alpha, x, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLARFGP( N, ALPHA, X, INCX, TAU )\n\n*  Purpose\n*  =======\n*\n*  SLARFGP generates a real elementary reflector H of order n, such\n*  that\n*\n*        H * ( alpha ) = ( beta ),   H' * H = I.\n*            (   x   )   (   0  )\n*\n*  where alpha and beta are scalars, beta is non-negative, and x is\n*  an (n-1)-element real vector.  H is represented in the form\n*\n*        H = I - tau * ( 1 ) * ( 1 v' ) ,\n*                      ( v )\n*\n*  where tau is a real scalar and v is a real (n-1)-element\n*  vector.\n*\n*  If the elements of x are all zero, then tau = 0 and H is taken to be\n*  the unit matrix.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the elementary reflector.\n*\n*  ALPHA   (input/output) REAL\n*          On entry, the value alpha.\n*          On exit, it is overwritten with the value beta.\n*\n*  X       (input/output) REAL array, dimension\n*                         (1+(N-2)*abs(INCX))\n*          On entry, the vector x.\n*          On exit, it is overwritten with the vector v.\n*\n*  INCX    (input) INTEGER\n*          The increment between elements of X. INCX > 0.\n*\n*  TAU     (output) REAL\n*          The value tau.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, alpha, x = NumRu::Lapack.slarfgp( n, alpha, x, incx, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_n = argv[0];
  rblapack_alpha = argv[1];
  rblapack_x = argv[2];
  rblapack_incx = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  incx = NUM2INT(rblapack_incx);
  alpha = (real)NUM2DBL(rblapack_alpha);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (3th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1+(n-2)*abs(incx)))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-2)*abs(incx));
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-2)*abs(incx);
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;

  slarfgp_(&n, &alpha, x, &incx, &tau);

  rblapack_tau = rb_float_new((double)tau);
  rblapack_alpha = rb_float_new((double)alpha);
  return rb_ary_new3(3, rblapack_tau, rblapack_alpha, rblapack_x);
}

void
init_lapack_slarfgp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slarfgp", rblapack_slarfgp, -1);
}
ruby-lapack-1.7.2/ext/zherfsx.c0000644000175000017500000005225512502221023016222 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zherfsx_(char* uplo, char* equed, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublereal* s, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zherfsx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_params;
  doublereal *params; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_err_bnds_norm;
  doublereal *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  doublereal *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_s_out__;
  doublereal *s_out__;
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;
  VALUE rblapack_params_out__;
  doublereal *params_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;
  integer nparams;
  integer n_err_bnds;

  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  rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.zherfsx( uplo, equed, a, af, ipiv, s, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHERFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     ZHERFSX improves the computed solution to a system of linear\n*     equations when the coefficient matrix is Hermitian indefinite, and\n*     provides error bounds and backward error estimates for the\n*     solution.  In addition to normwise error bound, the code provides\n*     maximum componentwise error bound if possible.  See comments for\n*     ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.\n*\n*     The original system of linear equations may have been equilibrated\n*     before calling this routine, as described by arguments EQUED and S\n*     below. In this case, the solution and error bounds returned are\n*     for the original unequilibrated system.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     EQUED   (input) CHARACTER*1\n*     Specifies the form of equilibration that was done to A\n*     before calling this routine. This is needed to compute\n*     the solution and error bounds correctly.\n*       = 'N':  No equilibration\n*       = 'Y':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(S) * A * diag(S).\n*               The right hand side B has been changed accordingly.\n*\n*     N       (input) INTEGER\n*     The order of the matrix A.  N >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     A       (input) COMPLEX*16 array, dimension (LDA,N)\n*     The symmetric matrix A.  If UPLO = 'U', the leading N-by-N\n*     upper triangular part of A contains the upper triangular\n*     part of the matrix A, and the strictly lower triangular\n*     part of A is not referenced.  If UPLO = 'L', the leading\n*     N-by-N lower triangular part of A contains the lower\n*     triangular part of the matrix A, and the strictly upper\n*     triangular part of A is not referenced.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX*16 array, dimension (LDAF,N)\n*     The factored form of the matrix A.  AF contains the block\n*     diagonal matrix D and the multipliers used to obtain the\n*     factor U or L from the factorization A = U*D*U**T or A =\n*     L*D*L**T as computed by DSYTRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     Details of the interchanges and the block structure of D\n*     as determined by DSYTRF.\n*\n*     S       (input or output) DOUBLE PRECISION array, dimension (N)\n*     The scale factors for A.  If EQUED = 'Y', A is multiplied on\n*     the left and right by diag(S).  S is an input argument if FACT =\n*     'F'; otherwise, S is an output argument.  If FACT = 'F' and EQUED\n*     = 'Y', each element of S must be positive.  If S is output, each\n*     element of S is a power of the radix. If S is input, each element\n*     of S should be a power of the radix to ensure a reliable solution\n*     and error estimates. Scaling by powers of the radix does not cause\n*     rounding errors unless the result underflows or overflows.\n*     Rounding errors during scaling lead to refining with a matrix that\n*     is not equivalent to the input matrix, producing error estimates\n*     that may not be reliable.\n*\n*     B       (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*     The right hand side matrix B.\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (input/output) COMPLEX*16 array, dimension (LDX,NRHS)\n*     On entry, the solution matrix X, as computed by DGETRS.\n*     On exit, the improved solution matrix X.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) DOUBLE PRECISION\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*     Componentwise relative backward error.  This is the\n*     componentwise relative backward error of each solution vector X(j)\n*     (i.e., the smallest relative change in any element of A or B that\n*     makes X(j) an exact solution).\n*\n*     N_ERR_BNDS (input) INTEGER\n*     Number of error bounds to return for each right hand side\n*     and each type (normwise or componentwise).  See ERR_BNDS_NORM and\n*     ERR_BNDS_COMP below.\n*\n*     ERR_BNDS_NORM  (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * dlamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * dlamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * dlamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * dlamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * dlamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * dlamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     NPARAMS (input) INTEGER\n*     Specifies the number of parameters set in PARAMS.  If .LE. 0, the\n*     PARAMS array is never referenced and default values are used.\n*\n*     PARAMS  (input / output) DOUBLE PRECISION array, dimension NPARAMS\n*     Specifies algorithm parameters.  If an entry is .LT. 0.0, then\n*     that entry will be filled with default value used for that\n*     parameter.  Only positions up to NPARAMS are accessed; defaults\n*     are used for higher-numbered parameters.\n*\n*       PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n*            refinement or not.\n*         Default: 1.0D+0\n*            = 0.0 : No refinement is performed, and no error bounds are\n*                    computed.\n*            = 1.0 : Use the double-precision refinement algorithm,\n*                    possibly with doubled-single computations if the\n*                    compilation environment does not support DOUBLE\n*                    PRECISION.\n*              (other values are reserved for future use)\n*\n*       PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n*            computations allowed for refinement.\n*         Default: 10\n*         Aggressive: Set to 100 to permit convergence using approximate\n*                     factorizations or factorizations other than LU. If\n*                     the factorization uses a technique other than\n*                     Gaussian elimination, the guarantees in\n*                     err_bnds_norm and err_bnds_comp may no longer be\n*                     trustworthy.\n*\n*       PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n*            will attempt to find a solution with small componentwise\n*            relative error in the double-precision algorithm.  Positive\n*            is true, 0.0 is false.\n*         Default: 1.0 (attempt componentwise convergence)\n*\n*     WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*     RWORK   (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit. The solution to every right-hand side is\n*         guaranteed.\n*       < 0:  If INFO = -i, the i-th argument had an illegal value\n*       > 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.zherfsx( uplo, equed, a, af, ipiv, s, b, x, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_uplo = argv[0];
  rblapack_equed = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_s = argv[5];
  rblapack_b = argv[6];
  rblapack_x = argv[7];
  rblapack_params = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (9th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_DFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
  params = NA_PTR_TYPE(rblapack_params, doublereal*);
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (6th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  n_err_bnds = 3;
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (8th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (8th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
  MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
  MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (2*n));

  zherfsx_(&uplo, &equed, &n, &nrhs, a, &lda, af, &ldaf, ipiv, s, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_s, rblapack_x, rblapack_params);
}

void
init_lapack_zherfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zherfsx", rblapack_zherfsx, -1);
}
ruby-lapack-1.7.2/ext/zla_herpvgrw.c0000644000175000017500000001414212502221015017235 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal zla_herpvgrw_(char* uplo, integer* n, integer* info, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublecomplex* work);


static VALUE
rblapack_zla_herpvgrw(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack___out__;
  doublereal __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  __out__ = NumRu::Lapack.zla_herpvgrw( uplo, info, a, af, ipiv, work, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION ZLA_HERPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, WORK )\n\n*  Purpose\n*  =======\n* \n*  ZLA_HERPVGRW computes the reciprocal pivot growth factor\n*  norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n*  much less than 1, the stability of the LU factorization of the\n*  (equilibrated) matrix A could be poor. This also means that the\n*  solution X, estimated condition numbers, and error bounds could be\n*  unreliable.\n*\n\n*  Arguments\n*  =========\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     INFO    (input) INTEGER\n*     The value of INFO returned from ZHETRF, .i.e., the pivot in\n*     column INFO is exactly 0.\n*\n*     NCOLS   (input) INTEGER\n*     The number of columns of the matrix A. NCOLS >= 0.\n*\n*     A       (input) COMPLEX*16 array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX*16 array, dimension (LDAF,N)\n*     The block diagonal matrix D and the multipliers used to\n*     obtain the factor U or L as computed by ZHETRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     Details of the interchanges and the block structure of D\n*     as determined by ZHETRF.\n*\n*     WORK    (input) COMPLEX*16 array, dimension (2*N)\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            NCOLS, I, J, K, KP\n      DOUBLE PRECISION   AMAX, UMAX, RPVGRW, TMP\n      LOGICAL            UPPER, LSAME\n      COMPLEX*16         ZDUM\n*     ..\n*     .. External Functions ..\n      EXTERNAL           LSAME, ZLASET\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, REAL, DIMAG, MAX, MIN\n*     ..\n*     .. Statement Functions ..\n      DOUBLE PRECISION   CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( ZDUM ) = ABS( DBLE ( ZDUM ) ) + ABS( DIMAG ( ZDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.zla_herpvgrw( uplo, info, a, af, ipiv, work, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_info = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_work = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  info = NUM2INT(rblapack_info);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (6th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
  if (NA_TYPE(rblapack_work) != NA_DCOMPLEX)
    rblapack_work = na_change_type(rblapack_work, NA_DCOMPLEX);
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);

  __out__ = zla_herpvgrw_(&uplo, &n, &info, a, &lda, af, &ldaf, ipiv, work);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_zla_herpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zla_herpvgrw", rblapack_zla_herpvgrw, -1);
}
ruby-lapack-1.7.2/ext/dla_syrpvgrw.c0000644000175000017500000001356512502221015017256 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal dla_syrpvgrw_(char* uplo, integer* n, integer* info, doublereal* a, integer* lda, doublereal* af, integer* ldaf, integer* ipiv, doublereal* work);


static VALUE
rblapack_dla_syrpvgrw(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_af;
  doublereal *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack___out__;
  doublereal __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  __out__ = NumRu::Lapack.dla_syrpvgrw( uplo, info, a, af, ipiv, work, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION DLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, WORK )\n\n*  Purpose\n*  =======\n* \n*  DLA_SYRPVGRW computes the reciprocal pivot growth factor\n*  norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n*  much less than 1, the stability of the LU factorization of the\n*  (equilibrated) matrix A could be poor. This also means that the\n*  solution X, estimated condition numbers, and error bounds could be\n*  unreliable.\n*\n\n*  Arguments\n*  =========\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     INFO    (input) INTEGER\n*     The value of INFO returned from DSYTRF, .i.e., the pivot in\n*     column INFO is exactly 0.\n*\n*     NCOLS   (input) INTEGER\n*     The number of columns of the matrix A. NCOLS >= 0.\n*\n*     A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) DOUBLE PRECISION array, dimension (LDAF,N)\n*     The block diagonal matrix D and the multipliers used to\n*     obtain the factor U or L as computed by DSYTRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     Details of the interchanges and the block structure of D\n*     as determined by DSYTRF.\n*\n*     WORK    (input) DOUBLE PRECISION array, dimension (2*N)\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            NCOLS, I, J, K, KP\n      DOUBLE PRECISION   AMAX, UMAX, RPVGRW, TMP\n      LOGICAL            UPPER\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX, MIN\n*     ..\n*     .. External Functions ..\n      EXTERNAL           LSAME, DLASET\n      LOGICAL            LSAME\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.dla_syrpvgrw( uplo, info, a, af, ipiv, work, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_info = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_work = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  info = NUM2INT(rblapack_info);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
  af = NA_PTR_TYPE(rblapack_af, doublereal*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (6th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
  if (NA_TYPE(rblapack_work) != NA_DFLOAT)
    rblapack_work = na_change_type(rblapack_work, NA_DFLOAT);
  work = NA_PTR_TYPE(rblapack_work, doublereal*);

  __out__ = dla_syrpvgrw_(&uplo, &n, &info, a, &lda, af, &ldaf, ipiv, work);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_dla_syrpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dla_syrpvgrw", rblapack_dla_syrpvgrw, -1);
}
ruby-lapack-1.7.2/ext/dsytri.c0000644000175000017500000001131512502221021016035 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsytri_(char* uplo, integer* n, doublereal* a, integer* lda, integer* ipiv, doublereal* work, integer* info);


static VALUE
rblapack_dsytri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  doublereal *work;

  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  info, a = NumRu::Lapack.dsytri( uplo, a, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSYTRI computes the inverse of a real symmetric indefinite matrix\n*  A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n*  DSYTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the block diagonal matrix D and the multipliers\n*          used to obtain the factor U or L as computed by DSYTRF.\n*\n*          On exit, if INFO = 0, the (symmetric) inverse of the original\n*          matrix.  If UPLO = 'U', the upper triangular part of the\n*          inverse is formed and the part of A below the diagonal is not\n*          referenced; if UPLO = 'L' the lower triangular part of the\n*          inverse is formed and the part of A above the diagonal is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by DSYTRF.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (N)\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, D(i,i) = 0; the matrix is singular and its\n*               inverse could not be computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.dsytri( uplo, a, ipiv, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  {
    na_shape_t 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, (n));

  dsytri_(&uplo, &n, a, &lda, ipiv, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_dsytri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsytri", rblapack_dsytri, -1);
}
ruby-lapack-1.7.2/ext/clauu2.c0000644000175000017500000000733712502221020015722 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clauu2_(char* uplo, integer* n, complex* a, integer* lda, integer* info);


static VALUE
rblapack_clauu2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *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  info, a = NumRu::Lapack.clauu2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAUU2( UPLO, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  CLAUU2 computes the product U * U' or L' * L, where the triangular\n*  factor U or L is stored in the upper or lower triangular part of\n*  the array A.\n*\n*  If UPLO = 'U' or 'u' then the upper triangle of the result is stored,\n*  overwriting the factor U in A.\n*  If UPLO = 'L' or 'l' then the lower triangle of the result is stored,\n*  overwriting the factor L in A.\n*\n*  This is the unblocked form of the algorithm, calling Level 2 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the triangular factor stored in the array A\n*          is upper or lower triangular:\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the triangular factor U or L.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the triangular factor U or L.\n*          On exit, if UPLO = 'U', the upper triangle of A is\n*          overwritten with the upper triangle of the product U * U';\n*          if UPLO = 'L', the lower triangle of A is overwritten with\n*          the lower triangle of the product L' * L.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.clauu2( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  clauu2_(&uplo, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_clauu2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clauu2", rblapack_clauu2, -1);
}
ruby-lapack-1.7.2/ext/ssygv.c0000644000175000017500000002024312502221016015676 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssygv_(integer* itype, char* jobz, char* uplo, integer* n, real* a, integer* lda, real* b, integer* ldb, real* w, real* work, integer* lwork, integer* info);


static VALUE
rblapack_ssygv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_b_out__;
  real *b_out__;

  integer lda;
  integer n;
  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  w, work, info, a, b = NumRu::Lapack.ssygv( itype, jobz, uplo, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSYGV computes all the eigenvalues, and optionally, the eigenvectors\n*  of a real generalized symmetric-definite eigenproblem, of the form\n*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.\n*  Here A and B are assumed to be symmetric and B is also\n*  positive definite.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          Specifies the problem type to be solved:\n*          = 1:  A*x = (lambda)*B*x\n*          = 2:  A*B*x = (lambda)*x\n*          = 3:  B*A*x = (lambda)*x\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA, N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of A contains the\n*          upper triangular part of the matrix A.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of A contains\n*          the lower triangular part of the matrix A.\n*\n*          On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n*          matrix Z of eigenvectors.  The eigenvectors are normalized\n*          as follows:\n*          if ITYPE = 1 or 2, Z**T*B*Z = I;\n*          if ITYPE = 3, Z**T*inv(B)*Z = I.\n*          If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n*          or the lower triangle (if UPLO='L') of A, including the\n*          diagonal, is destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input/output) REAL array, dimension (LDB, N)\n*          On entry, the symmetric positive definite matrix B.\n*          If UPLO = 'U', the leading N-by-N upper triangular part of B\n*          contains the upper triangular part of the matrix B.\n*          If UPLO = 'L', the leading N-by-N lower triangular part of B\n*          contains the lower triangular part of the matrix B.\n*\n*          On exit, if INFO <= N, the part of B containing the matrix is\n*          overwritten by the triangular factor U or L from the Cholesky\n*          factorization B = U**T*U or B = L*L**T.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  W       (output) REAL array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  WORK    (workspace/output) REAL array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of the array WORK.  LWORK >= max(1,3*N-1).\n*          For optimal efficiency, LWORK >= (NB+2)*N,\n*          where NB is the blocksize for SSYTRD returned by ILAENV.\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:  SPOTRF or SSYEV returned an error code:\n*             <= N:  if INFO = i, SSYEV failed to converge;\n*                    i off-diagonal elements of an intermediate\n*                    tridiagonal form did not converge to zero;\n*             > N:   if INFO = N + i, for 1 <= i <= N, then the leading\n*                    minor of order i of B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, work, info, a, b = NumRu::Lapack.ssygv( itype, jobz, uplo, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_itype = argv[0];
  rblapack_jobz = argv[1];
  rblapack_uplo = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  if (argc == 6) {
    rblapack_lwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  itype = NUM2INT(rblapack_itype);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (rblapack_lwork == Qnil)
    lwork = 3*n-1;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  ssygv_(&itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_w, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_ssygv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssygv", rblapack_ssygv, -1);
}
ruby-lapack-1.7.2/ext/zlangt.c0000644000175000017500000001071712502221015016026 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal zlangt_(char* norm, integer* n, doublecomplex* dl, doublecomplex* d, doublecomplex* du);


static VALUE
rblapack_zlangt(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_dl;
  doublecomplex *dl; 
  VALUE rblapack_d;
  doublecomplex *d; 
  VALUE rblapack_du;
  doublecomplex *du; 
  VALUE rblapack___out__;
  doublereal __out__; 

  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  __out__ = NumRu::Lapack.zlangt( norm, dl, d, du, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION ZLANGT( NORM, N, DL, D, DU )\n\n*  Purpose\n*  =======\n*\n*  ZLANGT  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  complex tridiagonal matrix A.\n*\n*  Description\n*  ===========\n*\n*  ZLANGT returns the value\n*\n*     ZLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in ZLANGT as described\n*          above.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, ZLANGT is\n*          set to zero.\n*\n*  DL      (input) COMPLEX*16 array, dimension (N-1)\n*          The (n-1) sub-diagonal elements of A.\n*\n*  D       (input) COMPLEX*16 array, dimension (N)\n*          The diagonal elements of A.\n*\n*  DU      (input) COMPLEX*16 array, dimension (N-1)\n*          The (n-1) super-diagonal elements of A.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.zlangt( norm, dl, d, du, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_norm = argv[0];
  rblapack_dl = argv[1];
  rblapack_d = argv[2];
  rblapack_du = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DCOMPLEX)
    rblapack_d = na_change_type(rblapack_d, NA_DCOMPLEX);
  d = NA_PTR_TYPE(rblapack_d, doublecomplex*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_DCOMPLEX)
    rblapack_dl = na_change_type(rblapack_dl, NA_DCOMPLEX);
  dl = NA_PTR_TYPE(rblapack_dl, doublecomplex*);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (4th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_DCOMPLEX)
    rblapack_du = na_change_type(rblapack_du, NA_DCOMPLEX);
  du = NA_PTR_TYPE(rblapack_du, doublecomplex*);

  __out__ = zlangt_(&norm, &n, dl, d, du);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_zlangt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlangt", rblapack_zlangt, -1);
}
ruby-lapack-1.7.2/ext/slagv2.c0000644000175000017500000001507712502221025015732 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slagv2_(real* a, integer* lda, real* b, integer* ldb, real* alphar, real* alphai, real* beta, real* csl, real* snl, real* csr, real* snr);


static VALUE
rblapack_slagv2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_alphar;
  real *alphar; 
  VALUE rblapack_alphai;
  real *alphai; 
  VALUE rblapack_beta;
  real *beta; 
  VALUE rblapack_csl;
  real csl; 
  VALUE rblapack_snl;
  real snl; 
  VALUE rblapack_csr;
  real csr; 
  VALUE rblapack_snr;
  real snr; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_b_out__;
  real *b_out__;

  integer lda;
  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  alphar, alphai, beta, csl, snl, csr, snr, a, b = NumRu::Lapack.slagv2( a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, CSR, SNR )\n\n*  Purpose\n*  =======\n*\n*  SLAGV2 computes the Generalized Schur factorization of a real 2-by-2\n*  matrix pencil (A,B) where B is upper triangular. This routine\n*  computes orthogonal (rotation) matrices given by CSL, SNL and CSR,\n*  SNR such that\n*\n*  1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0\n*     types), then\n*\n*     [ a11 a12 ] := [  CSL  SNL ] [ a11 a12 ] [  CSR -SNR ]\n*     [  0  a22 ]    [ -SNL  CSL ] [ a21 a22 ] [  SNR  CSR ]\n*\n*     [ b11 b12 ] := [  CSL  SNL ] [ b11 b12 ] [  CSR -SNR ]\n*     [  0  b22 ]    [ -SNL  CSL ] [  0  b22 ] [  SNR  CSR ],\n*\n*  2) if the pencil (A,B) has a pair of complex conjugate eigenvalues,\n*     then\n*\n*     [ a11 a12 ] := [  CSL  SNL ] [ a11 a12 ] [  CSR -SNR ]\n*     [ a21 a22 ]    [ -SNL  CSL ] [ a21 a22 ] [  SNR  CSR ]\n*\n*     [ b11  0  ] := [  CSL  SNL ] [ b11 b12 ] [  CSR -SNR ]\n*     [  0  b22 ]    [ -SNL  CSL ] [  0  b22 ] [  SNR  CSR ]\n*\n*     where b11 >= b22 > 0.\n*\n*\n\n*  Arguments\n*  =========\n*\n*  A       (input/output) REAL array, dimension (LDA, 2)\n*          On entry, the 2 x 2 matrix A.\n*          On exit, A is overwritten by the ``A-part'' of the\n*          generalized Schur form.\n*\n*  LDA     (input) INTEGER\n*          THe leading dimension of the array A.  LDA >= 2.\n*\n*  B       (input/output) REAL array, dimension (LDB, 2)\n*          On entry, the upper triangular 2 x 2 matrix B.\n*          On exit, B is overwritten by the ``B-part'' of the\n*          generalized Schur form.\n*\n*  LDB     (input) INTEGER\n*          THe leading dimension of the array B.  LDB >= 2.\n*\n*  ALPHAR  (output) REAL array, dimension (2)\n*  ALPHAI  (output) REAL array, dimension (2)\n*  BETA    (output) REAL array, dimension (2)\n*          (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the\n*          pencil (A,B), k=1,2, i = sqrt(-1).  Note that BETA(k) may\n*          be zero.\n*\n*  CSL     (output) REAL\n*          The cosine of the left rotation matrix.\n*\n*  SNL     (output) REAL\n*          The sine of the left rotation matrix.\n*\n*  CSR     (output) REAL\n*          The cosine of the right rotation matrix.\n*\n*  SNR     (output) REAL\n*          The sine of the right rotation matrix.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  alphar, alphai, beta, csl, snl, csr, snr, a, b = NumRu::Lapack.slagv2( a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  if (argc == 2) {
  } 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);
  if (NA_SHAPE1(rblapack_a) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", 2);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of b must be %d", 2);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  {
    na_shape_t shape[1];
    shape[0] = 2;
    rblapack_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  alphar = NA_PTR_TYPE(rblapack_alphar, real*);
  {
    na_shape_t shape[1];
    shape[0] = 2;
    rblapack_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  alphai = NA_PTR_TYPE(rblapack_alphai, real*);
  {
    na_shape_t shape[1];
    shape[0] = 2;
    rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = 2;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = 2;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  slagv2_(a, &lda, b, &ldb, alphar, alphai, beta, &csl, &snl, &csr, &snr);

  rblapack_csl = rb_float_new((double)csl);
  rblapack_snl = rb_float_new((double)snl);
  rblapack_csr = rb_float_new((double)csr);
  rblapack_snr = rb_float_new((double)snr);
  return rb_ary_new3(9, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_csl, rblapack_snl, rblapack_csr, rblapack_snr, rblapack_a, rblapack_b);
}

void
init_lapack_slagv2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slagv2", rblapack_slagv2, -1);
}
ruby-lapack-1.7.2/ext/spbstf.c0000644000175000017500000001270012502221025016023 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID spbstf_(char* uplo, integer* n, integer* kd, real* ab, integer* ldab, integer* info);


static VALUE
rblapack_spbstf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  real *ab_out__;

  integer ldab;
  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  info, ab = NumRu::Lapack.spbstf( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPBSTF( UPLO, N, KD, AB, LDAB, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPBSTF computes a split Cholesky factorization of a real\n*  symmetric positive definite band matrix A.\n*\n*  This routine is designed to be used in conjunction with SSBGST.\n*\n*  The factorization has the form  A = S**T*S  where S is a band matrix\n*  of the same bandwidth as A and the following structure:\n*\n*    S = ( U    )\n*        ( M  L )\n*\n*  where U is upper triangular of order m = (n+kd)/2, and L is lower\n*  triangular of order n-m.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) REAL array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first kd+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*          On exit, if INFO = 0, the factor S from the split Cholesky\n*          factorization A = S**T*S. See Further Details.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\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 factorization could not be completed,\n*               because the updated element a(i,i) was negative; the\n*               matrix A is not positive definite.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  N = 7, KD = 2:\n*\n*  S = ( s11  s12  s13                     )\n*      (      s22  s23  s24                )\n*      (           s33  s34                )\n*      (                s44                )\n*      (           s53  s54  s55           )\n*      (                s64  s65  s66      )\n*      (                     s75  s76  s77 )\n*\n*  If UPLO = 'U', the array AB holds:\n*\n*  on entry:                          on exit:\n*\n*   *    *   a13  a24  a35  a46  a57   *    *   s13  s24  s53  s64  s75\n*   *   a12  a23  a34  a45  a56  a67   *   s12  s23  s34  s54  s65  s76\n*  a11  a22  a33  a44  a55  a66  a77  s11  s22  s33  s44  s55  s66  s77\n*\n*  If UPLO = 'L', the array AB holds:\n*\n*  on entry:                          on exit:\n*\n*  a11  a22  a33  a44  a55  a66  a77  s11  s22  s33  s44  s55  s66  s77\n*  a21  a32  a43  a54  a65  a76   *   s12  s23  s34  s54  s65  s76   *\n*  a31  a42  a53  a64  a64   *    *   s13  s24  s53  s64  s75   *    *\n*\n*  Array elements marked * are not used by the routine.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ab = NumRu::Lapack.spbstf( uplo, kd, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  kd = NUM2INT(rblapack_kd);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
  MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  spbstf_(&uplo, &n, &kd, ab, &ldab, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ab);
}

void
init_lapack_spbstf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "spbstf", rblapack_spbstf, -1);
}
ruby-lapack-1.7.2/ext/spptrs.c0000644000175000017500000001132712502221012016055 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID spptrs_(char* uplo, integer* n, integer* nrhs, real* ap, real* b, integer* ldb, integer* info);


static VALUE
rblapack_spptrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  real *b_out__;

  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.spptrs( uplo, n, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPPTRS solves a system of linear equations A*X = B with a symmetric\n*  positive definite matrix A in packed storage using the Cholesky\n*  factorization A = U**T*U or A = L*L**T computed by SPPTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AP      (input) REAL array, dimension (N*(N+1)/2)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**T*U or A = L*L**T, packed columnwise in a linear\n*          array.  The j-th column of U or L is stored in the array AP\n*          as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            UPPER\n      INTEGER            I\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           STPSV, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.spptrs( uplo, n, ap, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_n = argv[1];
  rblapack_ap = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  spptrs_(&uplo, &n, &nrhs, ap, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_spptrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "spptrs", rblapack_spptrs, -1);
}
ruby-lapack-1.7.2/ext/zlals0.c0000644000175000017500000003174312502221025015737 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlals0_(integer* icompq, integer* nl, integer* nr, integer* sqre, integer* nrhs, doublecomplex* b, integer* ldb, doublecomplex* bx, integer* ldbx, integer* perm, integer* givptr, integer* givcol, integer* ldgcol, doublereal* givnum, integer* ldgnum, doublereal* poles, doublereal* difl, doublereal* difr, doublereal* z, integer* k, doublereal* c, doublereal* s, doublereal* rwork, integer* info);


static VALUE
rblapack_zlals0(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_icompq;
  integer icompq; 
  VALUE rblapack_nl;
  integer nl; 
  VALUE rblapack_nr;
  integer nr; 
  VALUE rblapack_sqre;
  integer sqre; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_perm;
  integer *perm; 
  VALUE rblapack_givptr;
  integer givptr; 
  VALUE rblapack_givcol;
  integer *givcol; 
  VALUE rblapack_givnum;
  doublereal *givnum; 
  VALUE rblapack_poles;
  doublereal *poles; 
  VALUE rblapack_difl;
  doublereal *difl; 
  VALUE rblapack_difr;
  doublereal *difr; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_c;
  doublereal c; 
  VALUE rblapack_s;
  doublereal s; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  doublecomplex *bx;
  doublereal *rwork;

  integer ldb;
  integer nrhs;
  integer n;
  integer ldgcol;
  integer ldgnum;
  integer k;
  integer ldbx;

  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  info, b = NumRu::Lapack.zlals0( icompq, nl, nr, sqre, b, perm, givptr, givcol, givnum, poles, difl, difr, z, c, s, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZLALS0 applies back the multiplying factors of either the left or the\n*  right singular vector matrix of a diagonal matrix appended by a row\n*  to the right hand side matrix B in solving the least squares problem\n*  using the divide-and-conquer SVD approach.\n*\n*  For the left singular vector matrix, three types of orthogonal\n*  matrices are involved:\n*\n*  (1L) Givens rotations: the number of such rotations is GIVPTR; the\n*       pairs of columns/rows they were applied to are stored in GIVCOL;\n*       and the C- and S-values of these rotations are stored in GIVNUM.\n*\n*  (2L) Permutation. The (NL+1)-st row of B is to be moved to the first\n*       row, and for J=2:N, PERM(J)-th row of B is to be moved to the\n*       J-th row.\n*\n*  (3L) The left singular vector matrix of the remaining matrix.\n*\n*  For the right singular vector matrix, four types of orthogonal\n*  matrices are involved:\n*\n*  (1R) The right singular vector matrix of the remaining matrix.\n*\n*  (2R) If SQRE = 1, one extra Givens rotation to generate the right\n*       null space.\n*\n*  (3R) The inverse transformation of (2L).\n*\n*  (4R) The inverse transformation of (1L).\n*\n\n*  Arguments\n*  =========\n*\n*  ICOMPQ (input) INTEGER\n*         Specifies whether singular vectors are to be computed in\n*         factored form:\n*         = 0: Left singular vector matrix.\n*         = 1: Right singular vector matrix.\n*\n*  NL     (input) INTEGER\n*         The row dimension of the upper block. NL >= 1.\n*\n*  NR     (input) INTEGER\n*         The row dimension of the lower block. NR >= 1.\n*\n*  SQRE   (input) INTEGER\n*         = 0: the lower block is an NR-by-NR square matrix.\n*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n*         The bidiagonal matrix has row dimension N = NL + NR + 1,\n*         and column dimension M = N + SQRE.\n*\n*  NRHS   (input) INTEGER\n*         The number of columns of B and BX. NRHS must be at least 1.\n*\n*  B      (input/output) COMPLEX*16 array, dimension ( LDB, NRHS )\n*         On input, B contains the right hand sides of the least\n*         squares problem in rows 1 through M. On output, B contains\n*         the solution X in rows 1 through N.\n*\n*  LDB    (input) INTEGER\n*         The leading dimension of B. LDB must be at least\n*         max(1,MAX( M, N ) ).\n*\n*  BX     (workspace) COMPLEX*16 array, dimension ( LDBX, NRHS )\n*\n*  LDBX   (input) INTEGER\n*         The leading dimension of BX.\n*\n*  PERM   (input) INTEGER array, dimension ( N )\n*         The permutations (from deflation and sorting) applied\n*         to the two blocks.\n*\n*  GIVPTR (input) INTEGER\n*         The number of Givens rotations which took place in this\n*         subproblem.\n*\n*  GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )\n*         Each pair of numbers indicates a pair of rows/columns\n*         involved in a Givens rotation.\n*\n*  LDGCOL (input) INTEGER\n*         The leading dimension of GIVCOL, must be at least N.\n*\n*  GIVNUM (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )\n*         Each number indicates the C or S value used in the\n*         corresponding Givens rotation.\n*\n*  LDGNUM (input) INTEGER\n*         The leading dimension of arrays DIFR, POLES and\n*         GIVNUM, must be at least K.\n*\n*  POLES  (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )\n*         On entry, POLES(1:K, 1) contains the new singular\n*         values obtained from solving the secular equation, and\n*         POLES(1:K, 2) is an array containing the poles in the secular\n*         equation.\n*\n*  DIFL   (input) DOUBLE PRECISION array, dimension ( K ).\n*         On entry, DIFL(I) is the distance between I-th updated\n*         (undeflated) singular value and the I-th (undeflated) old\n*         singular value.\n*\n*  DIFR   (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ).\n*         On entry, DIFR(I, 1) contains the distances between I-th\n*         updated (undeflated) singular value and the I+1-th\n*         (undeflated) old singular value. And DIFR(I, 2) is the\n*         normalizing factor for the I-th right singular vector.\n*\n*  Z      (input) DOUBLE PRECISION array, dimension ( K )\n*         Contain the components of the deflation-adjusted updating row\n*         vector.\n*\n*  K      (input) INTEGER\n*         Contains the dimension of the non-deflated matrix,\n*         This is the order of the related secular equation. 1 <= K <=N.\n*\n*  C      (input) DOUBLE PRECISION\n*         C contains garbage if SQRE =0 and the C-value of a Givens\n*         rotation related to the right null space if SQRE = 1.\n*\n*  S      (input) DOUBLE PRECISION\n*         S contains garbage if SQRE =0 and the S-value of a Givens\n*         rotation related to the right null space if SQRE = 1.\n*\n*  RWORK  (workspace) DOUBLE PRECISION array, dimension\n*         ( K*(1+NRHS) + 2*NRHS )\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*  Based on contributions by\n*     Ming Gu and Ren-Cang Li, Computer Science Division, University of\n*       California at Berkeley, USA\n*     Osni Marques, LBNL/NERSC, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.zlals0( icompq, nl, nr, sqre, b, perm, givptr, givcol, givnum, poles, difl, difr, z, c, s, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 15 && argc != 15)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
  rblapack_icompq = argv[0];
  rblapack_nl = argv[1];
  rblapack_nr = argv[2];
  rblapack_sqre = argv[3];
  rblapack_b = argv[4];
  rblapack_perm = argv[5];
  rblapack_givptr = argv[6];
  rblapack_givcol = argv[7];
  rblapack_givnum = argv[8];
  rblapack_poles = argv[9];
  rblapack_difl = argv[10];
  rblapack_difr = argv[11];
  rblapack_z = argv[12];
  rblapack_c = argv[13];
  rblapack_s = argv[14];
  if (argc == 15) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  icompq = NUM2INT(rblapack_icompq);
  nr = NUM2INT(rblapack_nr);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  givptr = NUM2INT(rblapack_givptr);
  if (!NA_IsNArray(rblapack_givnum))
    rb_raise(rb_eArgError, "givnum (9th argument) must be NArray");
  if (NA_RANK(rblapack_givnum) != 2)
    rb_raise(rb_eArgError, "rank of givnum (9th argument) must be %d", 2);
  ldgnum = NA_SHAPE0(rblapack_givnum);
  if (NA_SHAPE1(rblapack_givnum) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", 2);
  if (NA_TYPE(rblapack_givnum) != NA_DFLOAT)
    rblapack_givnum = na_change_type(rblapack_givnum, NA_DFLOAT);
  givnum = NA_PTR_TYPE(rblapack_givnum, doublereal*);
  if (!NA_IsNArray(rblapack_difl))
    rb_raise(rb_eArgError, "difl (11th argument) must be NArray");
  if (NA_RANK(rblapack_difl) != 1)
    rb_raise(rb_eArgError, "rank of difl (11th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_difl);
  if (NA_TYPE(rblapack_difl) != NA_DFLOAT)
    rblapack_difl = na_change_type(rblapack_difl, NA_DFLOAT);
  difl = NA_PTR_TYPE(rblapack_difl, doublereal*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (13th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (13th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != k)
    rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of difl");
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  s = NUM2DBL(rblapack_s);
  nl = NUM2INT(rblapack_nl);
  if (!NA_IsNArray(rblapack_perm))
    rb_raise(rb_eArgError, "perm (6th argument) must be NArray");
  if (NA_RANK(rblapack_perm) != 1)
    rb_raise(rb_eArgError, "rank of perm (6th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_perm);
  if (NA_TYPE(rblapack_perm) != NA_LINT)
    rblapack_perm = na_change_type(rblapack_perm, NA_LINT);
  perm = NA_PTR_TYPE(rblapack_perm, integer*);
  if (!NA_IsNArray(rblapack_poles))
    rb_raise(rb_eArgError, "poles (10th argument) must be NArray");
  if (NA_RANK(rblapack_poles) != 2)
    rb_raise(rb_eArgError, "rank of poles (10th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_poles) != ldgnum)
    rb_raise(rb_eRuntimeError, "shape 0 of poles must be the same as shape 0 of givnum");
  if (NA_SHAPE1(rblapack_poles) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of poles must be %d", 2);
  if (NA_TYPE(rblapack_poles) != NA_DFLOAT)
    rblapack_poles = na_change_type(rblapack_poles, NA_DFLOAT);
  poles = NA_PTR_TYPE(rblapack_poles, doublereal*);
  c = NUM2DBL(rblapack_c);
  sqre = NUM2INT(rblapack_sqre);
  if (!NA_IsNArray(rblapack_difr))
    rb_raise(rb_eArgError, "difr (12th argument) must be NArray");
  if (NA_RANK(rblapack_difr) != 2)
    rb_raise(rb_eArgError, "rank of difr (12th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_difr) != ldgnum)
    rb_raise(rb_eRuntimeError, "shape 0 of difr must be the same as shape 0 of givnum");
  if (NA_SHAPE1(rblapack_difr) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of difr must be %d", 2);
  if (NA_TYPE(rblapack_difr) != NA_DFLOAT)
    rblapack_difr = na_change_type(rblapack_difr, NA_DFLOAT);
  difr = NA_PTR_TYPE(rblapack_difr, doublereal*);
  if (!NA_IsNArray(rblapack_givcol))
    rb_raise(rb_eArgError, "givcol (8th argument) must be NArray");
  if (NA_RANK(rblapack_givcol) != 2)
    rb_raise(rb_eArgError, "rank of givcol (8th argument) must be %d", 2);
  ldgcol = NA_SHAPE0(rblapack_givcol);
  if (NA_SHAPE1(rblapack_givcol) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", 2);
  if (NA_TYPE(rblapack_givcol) != NA_LINT)
    rblapack_givcol = na_change_type(rblapack_givcol, NA_LINT);
  givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
  ldbx = n;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  bx = ALLOC_N(doublecomplex, (ldbx)*(nrhs));
  rwork = ALLOC_N(doublereal, (k*(1+nrhs) + 2*nrhs));

  zlals0_(&icompq, &nl, &nr, &sqre, &nrhs, b, &ldb, bx, &ldbx, perm, &givptr, givcol, &ldgcol, givnum, &ldgnum, poles, difl, difr, z, &k, &c, &s, rwork, &info);

  free(bx);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_zlals0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlals0", rblapack_zlals0, -1);
}
ruby-lapack-1.7.2/ext/zlantp.c0000644000175000017500000001142112502221022016026 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal zlantp_(char* norm, char* uplo, char* diag, integer* n, doublecomplex* ap, doublereal* work);


static VALUE
rblapack_zlantp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack___out__;
  doublereal __out__; 
  doublereal *work;

  integer lwork;

  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  __out__ = NumRu::Lapack.zlantp( norm, uplo, diag, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION ZLANTP( NORM, UPLO, DIAG, N, AP, WORK )\n\n*  Purpose\n*  =======\n*\n*  ZLANTP  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  triangular matrix A, supplied in packed form.\n*\n*  Description\n*  ===========\n*\n*  ZLANTP returns the value\n*\n*     ZLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in ZLANTP as described\n*          above.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the matrix A is upper or lower triangular.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  DIAG    (input) CHARACTER*1\n*          Specifies whether or not the matrix A is unit triangular.\n*          = 'N':  Non-unit triangular\n*          = 'U':  Unit triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, ZLANTP is\n*          set to zero.\n*\n*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          The upper or lower triangular matrix A, packed columnwise in\n*          a linear array.  The j-th column of A is stored in the array\n*          AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          Note that when DIAG = 'U', the elements of the array AP\n*          corresponding to the diagonal elements of the matrix A are\n*          not referenced, but are assumed to be one.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n*          referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.zlantp( norm, uplo, diag, n, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_diag = argv[2];
  rblapack_n = argv[3];
  rblapack_ap = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  n = NUM2INT(rblapack_n);
  lwork = lsame_(&norm,"I") ? n : 0;
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  work = ALLOC_N(doublereal, (MAX(1,lwork)));

  __out__ = zlantp_(&norm, &uplo, &diag, &n, ap, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_zlantp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlantp", rblapack_zlantp, -1);
}
ruby-lapack-1.7.2/ext/sgghrd.c0000644000175000017500000002344712502221012016006 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgghrd_(char* compq, char* compz, integer* n, integer* ilo, integer* ihi, real* a, integer* lda, real* b, integer* ldb, real* q, integer* ldq, real* z, integer* ldz, integer* info);


static VALUE
rblapack_sgghrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_compq;
  char compq; 
  VALUE rblapack_compz;
  char compz; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_q;
  real *q; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_b_out__;
  real *b_out__;
  VALUE rblapack_q_out__;
  real *q_out__;
  VALUE rblapack_z_out__;
  real *z_out__;

  integer lda;
  integer n;
  integer ldb;
  integer ldq;
  integer ldz;

  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  info, a, b, q, z = NumRu::Lapack.sgghrd( compq, compz, ilo, ihi, a, b, q, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGGHRD reduces a pair of real matrices (A,B) to generalized upper\n*  Hessenberg form using orthogonal transformations, where A is a\n*  general matrix and B is upper triangular.  The form of the\n*  generalized eigenvalue problem is\n*     A*x = lambda*B*x,\n*  and B is typically made upper triangular by computing its QR\n*  factorization and moving the orthogonal matrix Q to the left side\n*  of the equation.\n*\n*  This subroutine simultaneously reduces A to a Hessenberg matrix H:\n*     Q**T*A*Z = H\n*  and transforms B to another upper triangular matrix T:\n*     Q**T*B*Z = T\n*  in order to reduce the problem to its standard form\n*     H*y = lambda*T*y\n*  where y = Z**T*x.\n*\n*  The orthogonal matrices Q and Z are determined as products of Givens\n*  rotations.  They may either be formed explicitly, or they may be\n*  postmultiplied into input matrices Q1 and Z1, so that\n*\n*       Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T\n*\n*       Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T\n*\n*  If Q1 is the orthogonal matrix from the QR factorization of B in the\n*  original equation A*x = lambda*B*x, then SGGHRD reduces the original\n*  problem to generalized Hessenberg form.\n*\n\n*  Arguments\n*  =========\n*\n*  COMPQ   (input) CHARACTER*1\n*          = 'N': do not compute Q;\n*          = 'I': Q is initialized to the unit matrix, and the\n*                 orthogonal matrix Q is returned;\n*          = 'V': Q must contain an orthogonal matrix Q1 on entry,\n*                 and the product Q1*Q is returned.\n*\n*  COMPZ   (input) CHARACTER*1\n*          = 'N': do not compute Z;\n*          = 'I': Z is initialized to the unit matrix, and the\n*                 orthogonal matrix Z is returned;\n*          = 'V': Z must contain an orthogonal matrix Z1 on entry,\n*                 and the product Z1*Z is returned.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          ILO and IHI mark the rows and columns of A which are to be\n*          reduced.  It is assumed that A is already upper triangular\n*          in rows and columns 1:ILO-1 and IHI+1:N.  ILO and IHI are\n*          normally set by a previous call to SGGBAL; otherwise they\n*          should be set to 1 and N respectively.\n*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n*  A       (input/output) REAL array, dimension (LDA, N)\n*          On entry, the N-by-N general matrix to be reduced.\n*          On exit, the upper triangle and the first subdiagonal of A\n*          are overwritten with the upper Hessenberg matrix H, and the\n*          rest is set to zero.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input/output) REAL array, dimension (LDB, N)\n*          On entry, the N-by-N upper triangular matrix B.\n*          On exit, the upper triangular matrix T = Q**T B Z.  The\n*          elements below the diagonal are set to zero.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  Q       (input/output) REAL array, dimension (LDQ, N)\n*          On entry, if COMPQ = 'V', the orthogonal matrix Q1,\n*          typically from the QR factorization of B.\n*          On exit, if COMPQ='I', the orthogonal matrix Q, and if\n*          COMPQ = 'V', the product Q1*Q.\n*          Not referenced if COMPQ='N'.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.\n*          LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.\n*\n*  Z       (input/output) REAL array, dimension (LDZ, N)\n*          On entry, if COMPZ = 'V', the orthogonal matrix Z1.\n*          On exit, if COMPZ='I', the orthogonal matrix Z, and if\n*          COMPZ = 'V', the product Z1*Z.\n*          Not referenced if COMPZ='N'.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.\n*          LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.\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*  This routine reduces A to Hessenberg and B to triangular form by\n*  an unblocked reduction, as described in _Matrix_Computations_,\n*  by Golub and Van Loan (Johns Hopkins Press.)\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a, b, q, z = NumRu::Lapack.sgghrd( compq, compz, ilo, ihi, a, b, q, z, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_compq = argv[0];
  rblapack_compz = argv[1];
  rblapack_ilo = argv[2];
  rblapack_ihi = argv[3];
  rblapack_a = argv[4];
  rblapack_b = argv[5];
  rblapack_q = argv[6];
  rblapack_z = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  compq = StringValueCStr(rblapack_compq)[0];
  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (7th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_q) != NA_SFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
  q = NA_PTR_TYPE(rblapack_q, real*);
  compz = StringValueCStr(rblapack_compz)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  ihi = NUM2INT(rblapack_ihi);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (8th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  if (NA_SHAPE1(rblapack_z) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
  MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
  MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  sgghrd_(&compq, &compz, &n, &ilo, &ihi, a, &lda, b, &ldb, q, &ldq, z, &ldz, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z);
}

void
init_lapack_sgghrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgghrd", rblapack_sgghrd, -1);
}
ruby-lapack-1.7.2/ext/zporfs.c0000644000175000017500000002020412502221017016044 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zporfs_(char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zporfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.zporfs( uplo, a, af, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPORFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is Hermitian positive definite,\n*  and provides error bounds and backward error estimates for the\n*  solution.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          The Hermitian matrix A.  If UPLO = 'U', the leading N-by-N\n*          upper triangular part of A contains the upper triangular part\n*          of the matrix A, and the strictly lower triangular part of A\n*          is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*          triangular part of A contains the lower triangular part of\n*          the matrix A, and the strictly upper triangular part of A is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AF      (input) COMPLEX*16 array, dimension (LDAF,N)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**H*U or A = L*L**H, as computed by ZPOTRF.\n*\n*  LDAF    (input) INTEGER\n*          The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*  B       (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) COMPLEX*16 array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by ZPOTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  ====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.zporfs( uplo, a, af, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_b = argv[3];
  rblapack_x = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (5th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (n));

  zporfs_(&uplo, &n, &nrhs, a, &lda, af, &ldaf, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_zporfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zporfs", rblapack_zporfs, -1);
}
ruby-lapack-1.7.2/ext/dlarrd.c0000644000175000017500000003645012502221026016003 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlarrd_(char* range, char* order, integer* n, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* gers, doublereal* reltol, doublereal* d, doublereal* e, doublereal* e2, doublereal* pivmin, integer* nsplit, integer* isplit, integer* m, doublereal* w, doublereal* werr, doublereal* wl, doublereal* wu, integer* iblock, integer* indexw, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dlarrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_order;
  char order; 
  VALUE rblapack_vl;
  doublereal vl; 
  VALUE rblapack_vu;
  doublereal vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_gers;
  doublereal *gers; 
  VALUE rblapack_reltol;
  doublereal reltol; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_e2;
  doublereal *e2; 
  VALUE rblapack_pivmin;
  doublereal pivmin; 
  VALUE rblapack_nsplit;
  integer nsplit; 
  VALUE rblapack_isplit;
  integer *isplit; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_werr;
  doublereal *werr; 
  VALUE rblapack_wl;
  doublereal wl; 
  VALUE rblapack_wu;
  doublereal wu; 
  VALUE rblapack_iblock;
  integer *iblock; 
  VALUE rblapack_indexw;
  integer *indexw; 
  VALUE rblapack_info;
  integer info; 
  doublereal *work;
  integer *iwork;

  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  m, w, werr, wl, wu, iblock, indexw, info = NumRu::Lapack.dlarrd( range, order, vl, vu, il, iu, gers, reltol, d, e, e2, pivmin, nsplit, isplit, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLARRD( RANGE, ORDER, N, VL, VU, IL, IU, GERS, RELTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT, M, W, WERR, WL, WU, IBLOCK, INDEXW, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLARRD computes the eigenvalues of a symmetric tridiagonal\n*  matrix T to suitable accuracy. This is an auxiliary code to be\n*  called from DSTEMR.\n*  The user may ask for all eigenvalues, all eigenvalues\n*  in the half-open interval (VL, VU], or the IL-th through IU-th\n*  eigenvalues.\n*\n*  To avoid overflow, the matrix must be scaled so that its\n*  largest element is no greater than overflow**(1/2) *\n*  underflow**(1/4) in absolute value, and for greatest\n*  accuracy, it should not be much smaller than that.\n*\n*  See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n*  Matrix\", Report CS41, Computer Science Dept., Stanford\n*  University, July 21, 1966.\n*\n\n*  Arguments\n*  =========\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': (\"All\")   all eigenvalues will be found.\n*          = 'V': (\"Value\") all eigenvalues in the half-open interval\n*                           (VL, VU] will be found.\n*          = 'I': (\"Index\") the IL-th through IU-th eigenvalues (of the\n*                           entire matrix) will be found.\n*\n*  ORDER   (input) CHARACTER*1\n*          = 'B': (\"By Block\") the eigenvalues will be grouped by\n*                              split-off block (see IBLOCK, ISPLIT) and\n*                              ordered from smallest to largest within\n*                              the block.\n*          = 'E': (\"Entire matrix\")\n*                              the eigenvalues for the entire matrix\n*                              will be ordered from smallest to\n*                              largest.\n*\n*  N       (input) INTEGER\n*          The order of the tridiagonal matrix T.  N >= 0.\n*\n*  VL      (input) DOUBLE PRECISION\n*  VU      (input) DOUBLE PRECISION\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues.  Eigenvalues less than or equal\n*          to VL, or greater than VU, will not be returned.  VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  GERS    (input) DOUBLE PRECISION array, dimension (2*N)\n*          The N Gerschgorin intervals (the i-th Gerschgorin interval\n*          is (GERS(2*i-1), GERS(2*i)).\n*\n*  RELTOL  (input) DOUBLE PRECISION\n*          The minimum relative width of an interval.  When an interval\n*          is narrower than RELTOL times the larger (in\n*          magnitude) endpoint, then it is considered to be\n*          sufficiently small, i.e., converged.  Note: this should\n*          always be at least radix*machine epsilon.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          The n diagonal elements of the tridiagonal matrix T.\n*\n*  E       (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (n-1) off-diagonal elements of the tridiagonal matrix T.\n*\n*  E2      (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (n-1) squared off-diagonal elements of the tridiagonal matrix T.\n*\n*  PIVMIN  (input) DOUBLE PRECISION\n*          The minimum pivot allowed in the Sturm sequence for T.\n*\n*  NSPLIT  (input) INTEGER\n*          The number of diagonal blocks in the matrix T.\n*          1 <= NSPLIT <= N.\n*\n*  ISPLIT  (input) INTEGER array, dimension (N)\n*          The splitting points, at which T breaks up into submatrices.\n*          The first submatrix consists of rows/columns 1 to ISPLIT(1),\n*          the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n*          etc., and the NSPLIT-th consists of rows/columns\n*          ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n*          (Only the first NSPLIT elements will actually be used, but\n*          since the user cannot know a priori what value NSPLIT will\n*          have, N words must be reserved for ISPLIT.)\n*\n*  M       (output) INTEGER\n*          The actual number of eigenvalues found. 0 <= M <= N.\n*          (See also the description of INFO=2,3.)\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          On exit, the first M elements of W will contain the\n*          eigenvalue approximations. DLARRD computes an interval\n*          I_j = (a_j, b_j] that includes eigenvalue j. The eigenvalue\n*          approximation is given as the interval midpoint\n*          W(j)= ( a_j + b_j)/2. The corresponding error is bounded by\n*          WERR(j) = abs( a_j - b_j)/2\n*\n*  WERR    (output) DOUBLE PRECISION array, dimension (N)\n*          The error bound on the corresponding eigenvalue approximation\n*          in W.\n*\n*  WL      (output) DOUBLE PRECISION\n*  WU      (output) DOUBLE PRECISION\n*          The interval (WL, WU] contains all the wanted eigenvalues.\n*          If RANGE='V', then WL=VL and WU=VU.\n*          If RANGE='A', then WL and WU are the global Gerschgorin bounds\n*                        on the spectrum.\n*          If RANGE='I', then WL and WU are computed by DLAEBZ from the\n*                        index range specified.\n*\n*  IBLOCK  (output) INTEGER array, dimension (N)\n*          At each row/column j where E(j) is zero or small, the\n*          matrix T is considered to split into a block diagonal\n*          matrix.  On exit, if INFO = 0, IBLOCK(i) specifies to which\n*          block (from 1 to the number of blocks) the eigenvalue W(i)\n*          belongs.  (DLARRD may use the remaining N-M elements as\n*          workspace.)\n*\n*  INDEXW  (output) INTEGER array, dimension (N)\n*          The indices of the eigenvalues within each block (submatrix);\n*          for example, INDEXW(i)= j and IBLOCK(i)=k imply that the\n*          i-th eigenvalue W(i) is the j-th eigenvalue in block k.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (3*N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  some or all of the eigenvalues failed to converge or\n*                were not computed:\n*                =1 or 3: Bisection failed to converge for some\n*                        eigenvalues; these eigenvalues are flagged by a\n*                        negative block number.  The effect is that the\n*                        eigenvalues may not be as accurate as the\n*                        absolute and relative tolerances.  This is\n*                        generally caused by unexpectedly inaccurate\n*                        arithmetic.\n*                =2 or 3: RANGE='I' only: Not all of the eigenvalues\n*                        IL:IU were found.\n*                        Effect: M < IU+1-IL\n*                        Cause:  non-monotonic arithmetic, causing the\n*                                Sturm sequence to be non-monotonic.\n*                        Cure:   recalculate, using RANGE='A', and pick\n*                                out eigenvalues IL:IU.  In some cases,\n*                                increasing the PARAMETER \"FUDGE\" may\n*                                make things work.\n*                = 4:    RANGE='I', and the Gershgorin interval\n*                        initially used was too small.  No eigenvalues\n*                        were computed.\n*                        Probable cause: your machine has sloppy\n*                                        floating-point arithmetic.\n*                        Cure: Increase the PARAMETER \"FUDGE\",\n*                              recompile, and try again.\n*\n*  Internal Parameters\n*  ===================\n*\n*  FUDGE   DOUBLE PRECISION, default = 2\n*          A \"fudge factor\" to widen the Gershgorin intervals.  Ideally,\n*          a value of 1 should work, but on machines with sloppy\n*          arithmetic, this needs to be larger.  The default for\n*          publicly released versions should be large enough to handle\n*          the worst machine around.  Note that this has no effect\n*          on accuracy of the solution.\n*\n*  Based on contributions by\n*     W. Kahan, University of California, Berkeley, USA\n*     Beresford Parlett, University of California, Berkeley, USA\n*     Jim Demmel, University of California, Berkeley, USA\n*     Inderjit Dhillon, University of Texas, Austin, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, werr, wl, wu, iblock, indexw, info = NumRu::Lapack.dlarrd( range, order, vl, vu, il, iu, gers, reltol, d, e, e2, pivmin, nsplit, isplit, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 14 && argc != 14)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 14)", argc);
  rblapack_range = argv[0];
  rblapack_order = argv[1];
  rblapack_vl = argv[2];
  rblapack_vu = argv[3];
  rblapack_il = argv[4];
  rblapack_iu = argv[5];
  rblapack_gers = argv[6];
  rblapack_reltol = argv[7];
  rblapack_d = argv[8];
  rblapack_e = argv[9];
  rblapack_e2 = argv[10];
  rblapack_pivmin = argv[11];
  rblapack_nsplit = argv[12];
  rblapack_isplit = argv[13];
  if (argc == 14) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  range = StringValueCStr(rblapack_range)[0];
  vl = NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  reltol = NUM2DBL(rblapack_reltol);
  pivmin = NUM2DBL(rblapack_pivmin);
  if (!NA_IsNArray(rblapack_isplit))
    rb_raise(rb_eArgError, "isplit (14th argument) must be NArray");
  if (NA_RANK(rblapack_isplit) != 1)
    rb_raise(rb_eArgError, "rank of isplit (14th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_isplit);
  if (NA_TYPE(rblapack_isplit) != NA_LINT)
    rblapack_isplit = na_change_type(rblapack_isplit, NA_LINT);
  isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
  order = StringValueCStr(rblapack_order)[0];
  iu = NUM2INT(rblapack_iu);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (9th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of isplit");
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_e2))
    rb_raise(rb_eArgError, "e2 (11th argument) must be NArray");
  if (NA_RANK(rblapack_e2) != 1)
    rb_raise(rb_eArgError, "rank of e2 (11th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e2) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e2 must be %d", n-1);
  if (NA_TYPE(rblapack_e2) != NA_DFLOAT)
    rblapack_e2 = na_change_type(rblapack_e2, NA_DFLOAT);
  e2 = NA_PTR_TYPE(rblapack_e2, doublereal*);
  vu = NUM2DBL(rblapack_vu);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (10th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (10th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  if (!NA_IsNArray(rblapack_gers))
    rb_raise(rb_eArgError, "gers (7th argument) must be NArray");
  if (NA_RANK(rblapack_gers) != 1)
    rb_raise(rb_eArgError, "rank of gers (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_gers) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of gers must be %d", 2*n);
  if (NA_TYPE(rblapack_gers) != NA_DFLOAT)
    rblapack_gers = na_change_type(rblapack_gers, NA_DFLOAT);
  gers = NA_PTR_TYPE(rblapack_gers, doublereal*);
  nsplit = NUM2INT(rblapack_nsplit);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_werr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  werr = NA_PTR_TYPE(rblapack_werr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_iblock = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iblock = NA_PTR_TYPE(rblapack_iblock, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_indexw = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  indexw = NA_PTR_TYPE(rblapack_indexw, integer*);
  work = ALLOC_N(doublereal, (4*n));
  iwork = ALLOC_N(integer, (3*n));

  dlarrd_(&range, &order, &n, &vl, &vu, &il, &iu, gers, &reltol, d, e, e2, &pivmin, &nsplit, isplit, &m, w, werr, &wl, &wu, iblock, indexw, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_wl = rb_float_new((double)wl);
  rblapack_wu = rb_float_new((double)wu);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_m, rblapack_w, rblapack_werr, rblapack_wl, rblapack_wu, rblapack_iblock, rblapack_indexw, rblapack_info);
}

void
init_lapack_dlarrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlarrd", rblapack_dlarrd, -1);
}
ruby-lapack-1.7.2/ext/sggbal.c0000644000175000017500000001724112502221015015765 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sggbal_(char* job, integer* n, real* a, integer* lda, real* b, integer* ldb, integer* ilo, integer* ihi, real* lscale, real* rscale, real* work, integer* info);


static VALUE
rblapack_sggbal(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_lscale;
  real *lscale; 
  VALUE rblapack_rscale;
  real *rscale; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_b_out__;
  real *b_out__;
  real *work;

  integer lda;
  integer n;
  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  ilo, ihi, lscale, rscale, info, a, b = NumRu::Lapack.sggbal( job, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGGBAL balances a pair of general real matrices (A,B).  This\n*  involves, first, permuting A and B by similarity transformations to\n*  isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N\n*  elements on the diagonal; and second, applying a diagonal similarity\n*  transformation to rows and columns ILO to IHI to make the rows\n*  and columns as close in norm as possible. Both steps are optional.\n*\n*  Balancing may reduce the 1-norm of the matrices, and improve the\n*  accuracy of the computed eigenvalues and/or eigenvectors in the\n*  generalized eigenvalue problem A*x = lambda*B*x.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies the operations to be performed on A and B:\n*          = 'N':  none:  simply set ILO = 1, IHI = N, LSCALE(I) = 1.0\n*                  and RSCALE(I) = 1.0 for i = 1,...,N.\n*          = 'P':  permute only;\n*          = 'S':  scale only;\n*          = 'B':  both permute and scale.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the input matrix A.\n*          On exit,  A is overwritten by the balanced matrix.\n*          If JOB = 'N', A is not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  B       (input/output) REAL array, dimension (LDB,N)\n*          On entry, the input matrix B.\n*          On exit,  B is overwritten by the balanced matrix.\n*          If JOB = 'N', B is not referenced.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  ILO     (output) INTEGER\n*  IHI     (output) INTEGER\n*          ILO and IHI are set to integers such that on exit\n*          A(i,j) = 0 and B(i,j) = 0 if i > j and\n*          j = 1,...,ILO-1 or i = IHI+1,...,N.\n*          If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n*\n*  LSCALE  (output) REAL array, dimension (N)\n*          Details of the permutations and scaling factors applied\n*          to the left side of A and B.  If P(j) is the index of the\n*          row interchanged with row j, and D(j)\n*          is the scaling factor applied to row j, then\n*            LSCALE(j) = P(j)    for J = 1,...,ILO-1\n*                      = D(j)    for J = ILO,...,IHI\n*                      = P(j)    for J = IHI+1,...,N.\n*          The order in which the interchanges are made is N to IHI+1,\n*          then 1 to ILO-1.\n*\n*  RSCALE  (output) REAL array, dimension (N)\n*          Details of the permutations and scaling factors applied\n*          to the right side of A and B.  If P(j) is the index of the\n*          column interchanged with column j, and D(j)\n*          is the scaling factor applied to column j, then\n*            LSCALE(j) = P(j)    for J = 1,...,ILO-1\n*                      = D(j)    for J = ILO,...,IHI\n*                      = P(j)    for J = IHI+1,...,N.\n*          The order in which the interchanges are made is N to IHI+1,\n*          then 1 to ILO-1.\n*\n*  WORK    (workspace) REAL array, dimension (lwork)\n*          lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and\n*          at least 1 when JOB = 'N' or 'P'.\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*  See R.C. WARD, Balancing the generalized eigenvalue problem,\n*                 SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ilo, ihi, lscale, rscale, info, a, b = NumRu::Lapack.sggbal( job, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_job = argv[0];
  rblapack_a = argv[1];
  rblapack_b = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  job = StringValueCStr(rblapack_job)[0];
  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);
  ldb = NA_SHAPE0(rblapack_b);
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_lscale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  lscale = NA_PTR_TYPE(rblapack_lscale, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rscale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  rscale = NA_PTR_TYPE(rblapack_rscale, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(real, ((lsame_(&job,"S")||lsame_(&job,"B")) ? MAX(1,6*n) : (lsame_(&job,"N")||lsame_(&job,"P")) ? 1 : 0));

  sggbal_(&job, &n, a, &lda, b, &ldb, &ilo, &ihi, lscale, rscale, work, &info);

  free(work);
  rblapack_ilo = INT2NUM(ilo);
  rblapack_ihi = INT2NUM(ihi);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_ilo, rblapack_ihi, rblapack_lscale, rblapack_rscale, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_sggbal(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sggbal", rblapack_sggbal, -1);
}
ruby-lapack-1.7.2/ext/dorgrq.c0000644000175000017500000001255012502221013016020 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dorgrq_(integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dorgrq(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;

  integer lda;
  integer n;
  integer k;

  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 = NumRu::Lapack.dorgrq( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DORGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DORGRQ generates an M-by-N real matrix Q with orthonormal rows,\n*  which is defined as the last M rows of a product of K elementary\n*  reflectors of order N\n*\n*        Q  =  H(1) H(2) . . . H(k)\n*\n*  as returned by DGERQF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. N >= M.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. M >= K >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the (m-k+i)-th row must contain the vector which\n*          defines the elementary reflector H(i), for i = 1,2,...,k, as\n*          returned by DGERQF in the last k rows of its array argument\n*          A.\n*          On exit, the M-by-N matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) DOUBLE PRECISION array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by DGERQF.\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 has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, a = NumRu::Lapack.dorgrq( m, a, tau, [: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_m = argv[0];
  rblapack_a = argv[1];
  rblapack_tau = 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;
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  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*);
  if (rblapack_lwork == Qnil)
    lwork = m;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;

  dorgrq_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_dorgrq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dorgrq", rblapack_dorgrq, -1);
}
ruby-lapack-1.7.2/ext/dlarnv.c0000644000175000017500000000730712502221015016016 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlarnv_(integer* idist, integer* iseed, integer* n, doublereal* x);


static VALUE
rblapack_dlarnv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_idist;
  integer idist; 
  VALUE rblapack_iseed;
  integer *iseed; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_iseed_out__;
  integer *iseed_out__;


  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  x, iseed = NumRu::Lapack.dlarnv( idist, iseed, n, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLARNV( IDIST, ISEED, N, X )\n\n*  Purpose\n*  =======\n*\n*  DLARNV returns a vector of n random real numbers from a uniform or\n*  normal distribution.\n*\n\n*  Arguments\n*  =========\n*\n*  IDIST   (input) INTEGER\n*          Specifies the distribution of the random numbers:\n*          = 1:  uniform (0,1)\n*          = 2:  uniform (-1,1)\n*          = 3:  normal (0,1)\n*\n*  ISEED   (input/output) INTEGER array, dimension (4)\n*          On entry, the seed of the random number generator; the array\n*          elements must be between 0 and 4095, and ISEED(4) must be\n*          odd.\n*          On exit, the seed is updated.\n*\n*  N       (input) INTEGER\n*          The number of random numbers to be generated.\n*\n*  X       (output) DOUBLE PRECISION array, dimension (N)\n*          The generated random numbers.\n*\n\n*  Further Details\n*  ===============\n*\n*  This routine calls the auxiliary routine DLARUV to generate random\n*  real numbers from a uniform (0,1) distribution, in batches of up to\n*  128 using vectorisable code. The Box-Muller method is used to\n*  transform numbers from a uniform to a normal distribution.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, iseed = NumRu::Lapack.dlarnv( idist, iseed, n, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_idist = argv[0];
  rblapack_iseed = argv[1];
  rblapack_n = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  idist = NUM2INT(rblapack_idist);
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_iseed))
    rb_raise(rb_eArgError, "iseed (2th argument) must be NArray");
  if (NA_RANK(rblapack_iseed) != 1)
    rb_raise(rb_eArgError, "rank of iseed (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_iseed) != (4))
    rb_raise(rb_eRuntimeError, "shape 0 of iseed must be %d", 4);
  if (NA_TYPE(rblapack_iseed) != NA_LINT)
    rblapack_iseed = na_change_type(rblapack_iseed, NA_LINT);
  iseed = NA_PTR_TYPE(rblapack_iseed, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,n);
    rblapack_x = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 4;
    rblapack_iseed_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iseed_out__ = NA_PTR_TYPE(rblapack_iseed_out__, integer*);
  MEMCPY(iseed_out__, iseed, integer, NA_TOTAL(rblapack_iseed));
  rblapack_iseed = rblapack_iseed_out__;
  iseed = iseed_out__;

  dlarnv_(&idist, iseed, &n, x);

  return rb_ary_new3(2, rblapack_x, rblapack_iseed);
}

void
init_lapack_dlarnv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlarnv", rblapack_dlarnv, -1);
}
ruby-lapack-1.7.2/ext/zcgesv.c0000644000175000017500000002043712502221012016025 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zcgesv_(integer* n, integer* nrhs, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublecomplex* work, complex* swork, doublereal* rwork, integer* iter, integer* info);


static VALUE
rblapack_zcgesv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_iter;
  integer iter; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  doublecomplex *work;
  complex *swork;
  doublereal *rwork;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ipiv, x, iter, info, a = NumRu::Lapack.zcgesv( a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZCGESV( N, NRHS, A, LDA, IPIV, B, LDB, X, LDX, WORK, SWORK, RWORK, ITER, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZCGESV computes the solution to a complex system of linear equations\n*     A * X = B,\n*  where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n*  ZCGESV first attempts to factorize the matrix in COMPLEX and use this\n*  factorization within an iterative refinement procedure to produce a\n*  solution with COMPLEX*16 normwise backward error quality (see below).\n*  If the approach fails the method switches to a COMPLEX*16\n*  factorization and solve.\n*\n*  The iterative refinement is not going to be a winning strategy if\n*  the ratio COMPLEX performance over COMPLEX*16 performance is too\n*  small. A reasonable strategy should take the number of right-hand\n*  sides and the size of the matrix into account. This might be done\n*  with a call to ILAENV in the future. Up to now, we always try\n*  iterative refinement.\n*\n*  The iterative refinement process is stopped if\n*      ITER > ITERMAX\n*  or for all the RHS we have:\n*      RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX\n*  where\n*      o ITER is the number of the current iteration in the iterative\n*        refinement process\n*      o RNRM is the infinity-norm of the residual\n*      o XNRM is the infinity-norm of the solution\n*      o ANRM is the infinity-operator-norm of the matrix A\n*      o EPS is the machine epsilon returned by DLAMCH('Epsilon')\n*  The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00\n*  respectively.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input/output) COMPLEX*16 array,\n*          dimension (LDA,N)\n*          On entry, the N-by-N coefficient matrix A.\n*          On exit, if iterative refinement has been successfully used\n*          (INFO.EQ.0 and ITER.GE.0, see description below), then A is\n*          unchanged, if double precision factorization has been used\n*          (INFO.EQ.0 and ITER.LT.0, see description below), then the\n*          array A contains the factors L and U from the factorization\n*          A = P*L*U; the unit diagonal elements of L are not stored.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          The pivot indices that define the permutation matrix P;\n*          row i of the matrix was interchanged with row IPIV(i).\n*          Corresponds either to the single precision factorization\n*          (if INFO.EQ.0 and ITER.GE.0) or the double precision\n*          factorization (if INFO.EQ.0 and ITER.LT.0).\n*\n*  B       (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*          The N-by-NRHS right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) COMPLEX*16 array, dimension (LDX,NRHS)\n*          If INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (N*NRHS)\n*          This array is used to hold the residual vectors.\n*\n*  SWORK   (workspace) COMPLEX array, dimension (N*(N+NRHS))\n*          This array is used to use the single precision matrix and the\n*          right-hand sides or solutions in single precision.\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\n*\n*  ITER    (output) INTEGER\n*          < 0: iterative refinement has failed, COMPLEX*16\n*               factorization has been performed\n*               -1 : the routine fell back to full precision for\n*                    implementation- or machine-specific reasons\n*               -2 : narrowing the precision induced an overflow,\n*                    the routine fell back to full precision\n*               -3 : failure of CGETRF\n*               -31: stop the iterative refinement after the 30th\n*                    iterations\n*          > 0: iterative refinement has been sucessfully used.\n*               Returns the number of iterations\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, U(i,i) computed in COMPLEX*16 is exactly\n*                zero.  The factorization has been completed, but the\n*                factor U is exactly singular, so the solution\n*                could not be computed.\n*\n*  =========\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, x, iter, info, a = NumRu::Lapack.zcgesv( a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  if (argc == 2) {
  } 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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  ldx = MAX(1,n);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(doublecomplex, (n*nrhs));
  swork = ALLOC_N(complex, (n*(n+nrhs)));
  rwork = ALLOC_N(doublereal, (n));

  zcgesv_(&n, &nrhs, a, &lda, ipiv, b, &ldb, x, &ldx, work, swork, rwork, &iter, &info);

  free(work);
  free(swork);
  free(rwork);
  rblapack_iter = INT2NUM(iter);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_ipiv, rblapack_x, rblapack_iter, rblapack_info, rblapack_a);
}

void
init_lapack_zcgesv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zcgesv", rblapack_zcgesv, -1);
}
ruby-lapack-1.7.2/ext/dgtcon.c0000644000175000017500000001546412502221017016013 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgtcon_(char* norm, integer* n, doublereal* dl, doublereal* d, doublereal* du, doublereal* du2, integer* ipiv, doublereal* anorm, doublereal* rcond, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dgtcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_dl;
  doublereal *dl; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_du;
  doublereal *du; 
  VALUE rblapack_du2;
  doublereal *du2; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_anorm;
  doublereal anorm; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_info;
  integer info; 
  doublereal *work;
  integer *iwork;

  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  rcond, info = NumRu::Lapack.dgtcon( norm, dl, d, du, du2, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGTCON estimates the reciprocal of the condition number of a real\n*  tridiagonal matrix A using the LU factorization as computed by\n*  DGTTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies whether the 1-norm condition number or the\n*          infinity-norm condition number is required:\n*          = '1' or 'O':  1-norm;\n*          = 'I':         Infinity-norm.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  DL      (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (n-1) multipliers that define the matrix L from the\n*          LU factorization of A as computed by DGTTRF.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          The n diagonal elements of the upper triangular matrix U from\n*          the LU factorization of A.\n*\n*  DU      (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (n-1) elements of the first superdiagonal of U.\n*\n*  DU2     (input) DOUBLE PRECISION array, dimension (N-2)\n*          The (n-2) elements of the second superdiagonal of U.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices; for 1 <= i <= n, row i of the matrix was\n*          interchanged with row IPIV(i).  IPIV(i) will always be either\n*          i or i+1; IPIV(i) = i indicates a row interchange was not\n*          required.\n*\n*  ANORM   (input) DOUBLE PRECISION\n*          If NORM = '1' or 'O', the 1-norm of the original matrix A.\n*          If NORM = 'I', the infinity-norm of the original matrix A.\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n*          estimate of the 1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.dgtcon( norm, dl, d, du, du2, ipiv, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_norm = argv[0];
  rblapack_dl = argv[1];
  rblapack_d = argv[2];
  rblapack_du = argv[3];
  rblapack_du2 = argv[4];
  rblapack_ipiv = argv[5];
  rblapack_anorm = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_DFLOAT)
    rblapack_dl = na_change_type(rblapack_dl, NA_DFLOAT);
  dl = NA_PTR_TYPE(rblapack_dl, doublereal*);
  if (!NA_IsNArray(rblapack_du2))
    rb_raise(rb_eArgError, "du2 (5th argument) must be NArray");
  if (NA_RANK(rblapack_du2) != 1)
    rb_raise(rb_eArgError, "rank of du2 (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du2) != (n-2))
    rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
  if (NA_TYPE(rblapack_du2) != NA_DFLOAT)
    rblapack_du2 = na_change_type(rblapack_du2, NA_DFLOAT);
  du2 = NA_PTR_TYPE(rblapack_du2, doublereal*);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (4th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_DFLOAT)
    rblapack_du = na_change_type(rblapack_du, NA_DFLOAT);
  du = NA_PTR_TYPE(rblapack_du, doublereal*);
  anorm = NUM2DBL(rblapack_anorm);
  work = ALLOC_N(doublereal, (2*n));
  iwork = ALLOC_N(integer, (n));

  dgtcon_(&norm, &n, dl, d, du, du2, ipiv, &anorm, &rcond, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_dgtcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgtcon", rblapack_dgtcon, -1);
}
ruby-lapack-1.7.2/ext/dgesvxx.c0000644000175000017500000007220112502221023016212 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgesvxx_(char* fact, char* trans, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* af, integer* ldaf, integer* ipiv, char* equed, doublereal* r, doublereal* c, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* rpvgrw, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dgesvxx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_af;
  doublereal *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_r;
  doublereal *r; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_params;
  doublereal *params; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_rpvgrw;
  doublereal rpvgrw; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_err_bnds_norm;
  doublereal *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  doublereal *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  VALUE rblapack_af_out__;
  doublereal *af_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  VALUE rblapack_r_out__;
  doublereal *r_out__;
  VALUE rblapack_c_out__;
  doublereal *c_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;
  VALUE rblapack_params_out__;
  doublereal *params_out__;
  doublereal *work;
  integer *iwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer nparams;
  integer ldx;
  integer n_err_bnds;

  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  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, r, c, b, params = NumRu::Lapack.dgesvxx( fact, trans, a, af, ipiv, equed, r, c, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     DGESVXX uses the LU factorization to compute the solution to a\n*     double precision system of linear equations  A * X = B,  where A is an\n*     N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n*     If requested, both normwise and maximum componentwise error bounds\n*     are returned. DGESVXX will return a solution with a tiny\n*     guaranteed error (O(eps) where eps is the working machine\n*     precision) unless the matrix is very ill-conditioned, in which\n*     case a warning is returned. Relevant condition numbers also are\n*     calculated and returned.\n*\n*     DGESVXX accepts user-provided factorizations and equilibration\n*     factors; see the definitions of the FACT and EQUED options.\n*     Solving with refinement and using a factorization from a previous\n*     DGESVXX call will also produce a solution with either O(eps)\n*     errors or warnings, but we cannot make that claim for general\n*     user-provided factorizations and equilibration factors if they\n*     differ from what DGESVXX would itself produce.\n*\n*     Description\n*     ===========\n*\n*     The following steps are performed:\n*\n*     1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n*     the system:\n*\n*       TRANS = 'N':  diag(R)*A*diag(C)     *inv(diag(C))*X = diag(R)*B\n*       TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n*       TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n*     or diag(C)*B (if TRANS = 'T' or 'C').\n*\n*     2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n*     the matrix A (after equilibration if FACT = 'E') as\n*\n*       A = P * L * U,\n*\n*     where P is a permutation matrix, L is a unit lower triangular\n*     matrix, and U is upper triangular.\n*\n*     3. If some U(i,i)=0, so that U is exactly singular, then the\n*     routine returns with INFO = i. Otherwise, the factored form of A\n*     is used to estimate the condition number of the matrix A (see\n*     argument RCOND). If the reciprocal of the condition number is less\n*     than machine precision, the routine still goes on to solve for X\n*     and compute error bounds as described below.\n*\n*     4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*     5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n*     the routine will use iterative refinement to try to get a small\n*     error and error bounds.  Refinement calculates the residual to at\n*     least twice the working precision.\n*\n*     6. If equilibration was used, the matrix X is premultiplied by\n*     diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n*     that it solves the original system before equilibration.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     FACT    (input) CHARACTER*1\n*     Specifies whether or not the factored form of the matrix A is\n*     supplied on entry, and if not, whether the matrix A should be\n*     equilibrated before it is factored.\n*       = 'F':  On entry, AF and IPIV contain the factored form of A.\n*               If EQUED is not 'N', the matrix A has been\n*               equilibrated with scaling factors given by R and C.\n*               A, AF, and IPIV are not modified.\n*       = 'N':  The matrix A will be copied to AF and factored.\n*       = 'E':  The matrix A will be equilibrated if necessary, then\n*               copied to AF and factored.\n*\n*     TRANS   (input) CHARACTER*1\n*     Specifies the form of the system of equations:\n*       = 'N':  A * X = B     (No transpose)\n*       = 'T':  A**T * X = B  (Transpose)\n*       = 'C':  A**H * X = B  (Conjugate Transpose = Transpose)\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.  If FACT = 'F' and EQUED is\n*     not 'N', then A must have been equilibrated by the scaling\n*     factors in R and/or C.  A is not modified if FACT = 'F' or\n*     'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n*     On exit, if EQUED .ne. 'N', A is scaled as follows:\n*     EQUED = 'R':  A := diag(R) * A\n*     EQUED = 'C':  A := A * diag(C)\n*     EQUED = 'B':  A := diag(R) * A * diag(C).\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input or output) DOUBLE PRECISION array, dimension (LDAF,N)\n*     If FACT = 'F', then AF is an input argument and on entry\n*     contains the factors L and U from the factorization\n*     A = P*L*U as computed by DGETRF.  If EQUED .ne. 'N', then\n*     AF is the factored form of the equilibrated matrix A.\n*\n*     If FACT = 'N', then AF is an output argument and on exit\n*     returns the factors L and U from the factorization A = P*L*U\n*     of the original matrix A.\n*\n*     If FACT = 'E', then AF is an output argument and on exit\n*     returns the factors L and U from the factorization A = P*L*U\n*     of the equilibrated matrix A (see the description of A for\n*     the form of the equilibrated matrix).\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input or output) INTEGER array, dimension (N)\n*     If FACT = 'F', then IPIV is an input argument and on entry\n*     contains the pivot indices from the factorization A = P*L*U\n*     as computed by DGETRF; row i of the matrix was interchanged\n*     with row IPIV(i).\n*\n*     If FACT = 'N', then IPIV is an output argument and on exit\n*     contains the pivot indices from the factorization A = P*L*U\n*     of the original matrix A.\n*\n*     If FACT = 'E', then IPIV is an output argument and on exit\n*     contains the pivot indices from the factorization A = P*L*U\n*     of the equilibrated matrix A.\n*\n*     EQUED   (input or output) CHARACTER*1\n*     Specifies the form of equilibration that was done.\n*       = 'N':  No equilibration (always true if FACT = 'N').\n*       = 'R':  Row equilibration, i.e., A has been premultiplied by\n*               diag(R).\n*       = 'C':  Column equilibration, i.e., A has been postmultiplied\n*               by diag(C).\n*       = 'B':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(R) * A * diag(C).\n*     EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*     output argument.\n*\n*     R       (input or output) DOUBLE PRECISION array, dimension (N)\n*     The row scale factors for A.  If EQUED = 'R' or 'B', A is\n*     multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n*     is not accessed.  R is an input argument if FACT = 'F';\n*     otherwise, R is an output argument.  If FACT = 'F' and\n*     EQUED = 'R' or 'B', each element of R must be positive.\n*     If R is output, each element of R is a power of the radix.\n*     If R is input, each element of R should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     C       (input or output) DOUBLE PRECISION array, dimension (N)\n*     The column scale factors for A.  If EQUED = 'C' or 'B', A is\n*     multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n*     is not accessed.  C is an input argument if FACT = 'F';\n*     otherwise, C is an output argument.  If FACT = 'F' and\n*     EQUED = 'C' or 'B', each element of C must be positive.\n*     If C is output, each element of C is a power of the radix.\n*     If C is input, each element of C should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*     On entry, the N-by-NRHS right hand side matrix B.\n*     On exit,\n*     if EQUED = 'N', B is not modified;\n*     if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n*        diag(R)*B;\n*     if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n*        overwritten by diag(C)*B.\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*     If INFO = 0, the N-by-NRHS solution matrix X to the original\n*     system of equations.  Note that A and B are modified on exit\n*     if EQUED .ne. 'N', and the solution to the equilibrated system is\n*     inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n*     inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) DOUBLE PRECISION\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     RPVGRW  (output) DOUBLE PRECISION\n*     Reciprocal pivot growth.  On exit, this contains the reciprocal\n*     pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n*     norm is used.  If this is much less than 1, then the stability of\n*     the LU factorization of the (equilibrated) matrix A could be poor.\n*     This also means that the solution X, estimated condition numbers,\n*     and error bounds could be unreliable. If factorization fails with\n*     0 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, r, c, b, params = NumRu::Lapack.dgesvxx( fact, trans, a, af, ipiv, equed, r, c, b, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_fact = argv[0];
  rblapack_trans = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_equed = argv[5];
  rblapack_r = argv[6];
  rblapack_c = argv[7];
  rblapack_b = argv[8];
  rblapack_params = argv[9];
  if (argc == 10) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_r))
    rb_raise(rb_eArgError, "r (7th argument) must be NArray");
  if (NA_RANK(rblapack_r) != 1)
    rb_raise(rb_eArgError, "rank of r (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_r) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_r) != NA_DFLOAT)
    rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
  r = NA_PTR_TYPE(rblapack_r, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (9th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (9th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  n_err_bnds = 3;
  trans = StringValueCStr(rblapack_trans)[0];
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (10th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (10th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_DFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
  params = NA_PTR_TYPE(rblapack_params, doublereal*);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
  af = NA_PTR_TYPE(rblapack_af, doublereal*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (8th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  ldx = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[2];
    shape[0] = ldaf;
    shape[1] = n;
    rblapack_af_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  af_out__ = NA_PTR_TYPE(rblapack_af_out__, doublereal*);
  MEMCPY(af_out__, af, doublereal, NA_TOTAL(rblapack_af));
  rblapack_af = rblapack_af_out__;
  af = af_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_r_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  r_out__ = NA_PTR_TYPE(rblapack_r_out__, doublereal*);
  MEMCPY(r_out__, r, doublereal, NA_TOTAL(rblapack_r));
  rblapack_r = rblapack_r_out__;
  r = r_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
  MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(doublereal, (4*n));
  iwork = ALLOC_N(integer, (n));

  dgesvxx_(&fact, &trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_rpvgrw = rb_float_new((double)rpvgrw);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(15, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_a, rblapack_af, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b, rblapack_params);
}

void
init_lapack_dgesvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgesvxx", rblapack_dgesvxx, -1);
}
ruby-lapack-1.7.2/ext/cstedc.c0000644000175000017500000002751412502221025016000 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cstedc_(char* compz, integer* n, real* d, real* e, complex* z, integer* ldz, complex* work, integer* lwork, real* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_cstedc(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_compz;
  char compz; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_lrwork;
  integer lrwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_rwork;
  real *rwork; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_e_out__;
  real *e_out__;
  VALUE rblapack_z_out__;
  complex *z_out__;

  integer n;
  integer ldz;

  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, rwork, iwork, info, d, e, z = NumRu::Lapack.cstedc( compz, d, e, z, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CSTEDC computes all eigenvalues and, optionally, eigenvectors of a\n*  symmetric tridiagonal matrix using the divide and conquer method.\n*  The eigenvectors of a full or band complex Hermitian matrix can also\n*  be found if CHETRD or CHPTRD or CHBTRD has been used to reduce this\n*  matrix to tridiagonal form.\n*\n*  This code makes very mild assumptions about floating point\n*  arithmetic. It will work on machines with a guard digit in\n*  add/subtract, or on those binary machines without guard digits\n*  which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n*  It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.  See SLAED3 for details.\n*\n\n*  Arguments\n*  =========\n*\n*  COMPZ   (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only.\n*          = 'I':  Compute eigenvectors of tridiagonal matrix also.\n*          = 'V':  Compute eigenvectors of original Hermitian matrix\n*                  also.  On entry, Z contains the unitary matrix used\n*                  to reduce the original matrix to tridiagonal form.\n*\n*  N       (input) INTEGER\n*          The dimension of the symmetric tridiagonal matrix.  N >= 0.\n*\n*  D       (input/output) REAL array, dimension (N)\n*          On entry, the diagonal elements of the tridiagonal matrix.\n*          On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n*  E       (input/output) REAL array, dimension (N-1)\n*          On entry, the subdiagonal elements of the tridiagonal matrix.\n*          On exit, E has been destroyed.\n*\n*  Z       (input/output) COMPLEX array, dimension (LDZ,N)\n*          On entry, if COMPZ = 'V', then Z contains the unitary\n*          matrix used in the reduction to tridiagonal form.\n*          On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n*          orthonormal eigenvectors of the original Hermitian matrix,\n*          and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n*          of the symmetric tridiagonal matrix.\n*          If  COMPZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1.\n*          If eigenvectors are desired, then LDZ >= max(1,N).\n*\n*  WORK    (workspace/output) COMPLEX    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*          If COMPZ = 'N' or 'I', or N <= 1, LWORK must be at least 1.\n*          If COMPZ = 'V' and N > 1, LWORK must be at least N*N.\n*          Note that for COMPZ = 'V', then if N is less than or\n*          equal to the minimum divide size, usually 25, then LWORK need\n*          only be 1.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal sizes of the WORK, RWORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  RWORK   (workspace/output) REAL array, dimension (MAX(1,LRWORK))\n*          On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n*\n*  LRWORK  (input) INTEGER\n*          The dimension of the array RWORK.\n*          If COMPZ = 'N' or N <= 1, LRWORK must be at least 1.\n*          If COMPZ = 'V' and N > 1, LRWORK must be at least\n*                         1 + 3*N + 2*N*lg N + 3*N**2 ,\n*                         where lg( N ) = smallest integer k such\n*                         that 2**k >= N.\n*          If COMPZ = 'I' and N > 1, LRWORK must be at least\n*                         1 + 4*N + 2*N**2 .\n*          Note that for COMPZ = 'I' or 'V', then if N is less than or\n*          equal to the minimum divide size, usually 25, then LRWORK\n*          need only be max(1,2*(N-1)).\n*\n*          If LRWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.\n*          If COMPZ = 'N' or N <= 1, LIWORK must be at least 1.\n*          If COMPZ = 'V' or N > 1,  LIWORK must be at least\n*                                    6 + 6*N + 5*N*lg N.\n*          If COMPZ = 'I' or N > 1,  LIWORK must be at least\n*                                    3 + 5*N .\n*          Note that for COMPZ = 'I' or 'V', then if N is less than or\n*          equal to the minimum divide size, usually 25, then LIWORK\n*          need only be 1.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK 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:  The algorithm failed to compute an eigenvalue while\n*                working on the submatrix lying in rows and columns\n*                INFO/(N+1) through mod(INFO,N+1).\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Jeff Rutter, Computer Science Division, University of California\n*     at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, rwork, iwork, info, d, e, z = NumRu::Lapack.cstedc( compz, d, e, z, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_compz = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  rblapack_z = argv[3];
  if (argc == 7) {
    rblapack_lwork = argv[4];
    rblapack_lrwork = argv[5];
    rblapack_liwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_lrwork = Qnil;
    rblapack_liwork = Qnil;
  }

  compz = StringValueCStr(rblapack_compz)[0];
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (4th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  n = NA_SHAPE1(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, complex*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of z");
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (rblapack_lwork == Qnil)
    lwork = (lsame_(&compz,"N")||lsame_(&compz,"I")||n<=1) ? 1 : lsame_(&compz,"V") ? n*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (rblapack_liwork == Qnil)
    liwork = (lsame_(&compz,"N")||n<=1) ? 1 : lsame_(&compz,"V") ? 6+6*n+5*n*LG(n) : lsame_(&compz,"I") ? 3+5*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  if (rblapack_lrwork == Qnil)
    lrwork = (lsame_(&compz,"N")||n<=1) ? 1 : lsame_(&compz,"V") ? 1+3*n+2*n*LG(n)+3*n*n : lsame_(&compz,"I") ? 1+4*n+2*n*n : 0;
  else {
    lrwork = NUM2INT(rblapack_lrwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lrwork);
    rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  rwork = NA_PTR_TYPE(rblapack_rwork, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
  MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
  MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  cstedc_(&compz, &n, d, e, z, &ldz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_work, rblapack_rwork, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e, rblapack_z);
}

void
init_lapack_cstedc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cstedc", rblapack_cstedc, -1);
}
ruby-lapack-1.7.2/ext/ztptri.c0000644000175000017500000001100412502221025016052 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztptri_(char* uplo, char* diag, integer* n, doublecomplex* ap, integer* info);


static VALUE
rblapack_ztptri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublecomplex *ap_out__;


  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  info, ap = NumRu::Lapack.ztptri( uplo, diag, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTPTRI( UPLO, DIAG, N, AP, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTPTRI computes the inverse of a complex upper or lower triangular\n*  matrix A stored in packed format.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangular matrix A, stored\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n.\n*          See below for further details.\n*          On exit, the (triangular) inverse of the original matrix, in\n*          the same packed storage format.\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, A(i,i) is exactly zero.  The triangular\n*                matrix is singular and its inverse can not be computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  A triangular matrix A can be transferred to packed storage using one\n*  of the following program segments:\n*\n*  UPLO = 'U':                      UPLO = 'L':\n*\n*        JC = 1                           JC = 1\n*        DO 2 J = 1, N                    DO 2 J = 1, N\n*           DO 1 I = 1, J                    DO 1 I = J, N\n*              AP(JC+I-1) = A(I,J)              AP(JC+I-J) = A(I,J)\n*      1    CONTINUE                    1    CONTINUE\n*           JC = JC + J                      JC = JC + N - J + 1\n*      2 CONTINUE                       2 CONTINUE\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ap = NumRu::Lapack.ztptri( uplo, diag, n, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_diag = argv[1];
  rblapack_n = argv[2];
  rblapack_ap = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  n = NUM2INT(rblapack_n);
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
  MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  ztptri_(&uplo, &diag, &n, ap, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ap);
}

void
init_lapack_ztptri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztptri", rblapack_ztptri, -1);
}
ruby-lapack-1.7.2/ext/slahrd.c0000644000175000017500000001460612502221020016001 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slahrd_(integer* n, integer* k, integer* nb, real* a, integer* lda, real* tau, real* t, integer* ldt, real* y, integer* ldy);


static VALUE
rblapack_slahrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_nb;
  integer nb; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_t;
  real *t; 
  VALUE rblapack_y;
  real *y; 
  VALUE rblapack_a_out__;
  real *a_out__;

  integer lda;
  integer ldt;
  integer ldy;

  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, t, y, a = NumRu::Lapack.slahrd( n, k, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n*  Purpose\n*  =======\n*\n*  SLAHRD reduces the first NB columns of a real general n-by-(n-k+1)\n*  matrix A so that elements below the k-th subdiagonal are zero. The\n*  reduction is performed by an orthogonal similarity transformation\n*  Q' * A * Q. The routine returns the matrices V and T which determine\n*  Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n*\n*  This is an OBSOLETE auxiliary routine. \n*  This routine will be 'deprecated' in a  future release.\n*  Please use the new routine SLAHR2 instead.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.\n*\n*  K       (input) INTEGER\n*          The offset for the reduction. Elements below the k-th\n*          subdiagonal in the first NB columns are reduced to zero.\n*\n*  NB      (input) INTEGER\n*          The number of columns to be reduced.\n*\n*  A       (input/output) REAL array, dimension (LDA,N-K+1)\n*          On entry, the n-by-(n-k+1) general matrix A.\n*          On exit, the elements on and above the k-th subdiagonal in\n*          the first NB columns are overwritten with the corresponding\n*          elements of the reduced matrix; the elements below the k-th\n*          subdiagonal, with the array TAU, represent the matrix Q as a\n*          product of elementary reflectors. The other columns of A are\n*          unchanged. See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  TAU     (output) REAL array, dimension (NB)\n*          The scalar factors of the elementary reflectors. See Further\n*          Details.\n*\n*  T       (output) REAL array, dimension (LDT,NB)\n*          The upper triangular matrix T.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T.  LDT >= NB.\n*\n*  Y       (output) REAL array, dimension (LDY,NB)\n*          The n-by-nb matrix Y.\n*\n*  LDY     (input) INTEGER\n*          The leading dimension of the array Y. LDY >= N.\n*\n\n*  Further Details\n*  ===============\n*\n*  The matrix Q is represented as a product of nb elementary reflectors\n*\n*     Q = H(1) H(2) . . . H(nb).\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+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n*  A(i+k+1:n,i), and tau in TAU(i).\n*\n*  The elements of the vectors v together form the (n-k+1)-by-nb matrix\n*  V which is needed, with T and Y, to apply the transformation to the\n*  unreduced part of the matrix, using an update of the form:\n*  A := (I - V*T*V') * (A - Y*V').\n*\n*  The contents of A on exit are illustrated by the following example\n*  with n = 7, k = 3 and nb = 2:\n*\n*     ( a   h   a   a   a )\n*     ( a   h   a   a   a )\n*     ( a   h   a   a   a )\n*     ( h   h   a   a   a )\n*     ( v1  h   a   a   a )\n*     ( v1  v2  a   a   a )\n*     ( v1  v2  a   a   a )\n*\n*  where a denotes an element of the original matrix A, h denotes a\n*  modified element of the upper Hessenberg matrix H, and vi denotes an\n*  element of the vector defining H(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, t, y, a = NumRu::Lapack.slahrd( n, k, nb, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_n = argv[0];
  rblapack_k = argv[1];
  rblapack_nb = argv[2];
  rblapack_a = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  nb = NUM2INT(rblapack_nb);
  lda = n;
  ldt = nb;
  k = NUM2INT(rblapack_k);
  ldy = n;
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_a) != lda)
    rb_raise(rb_eRuntimeError, "shape 0 of a must be n");
  if (NA_SHAPE1(rblapack_a) != (n-k+1))
    rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", n-k+1);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,nb);
    rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = MAX(1,nb);
    rblapack_t = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  t = NA_PTR_TYPE(rblapack_t, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldy;
    shape[1] = MAX(1,nb);
    rblapack_y = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  y = NA_PTR_TYPE(rblapack_y, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n-k+1;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  slahrd_(&n, &k, &nb, a, &lda, tau, t, &ldt, y, &ldy);

  return rb_ary_new3(4, rblapack_tau, rblapack_t, rblapack_y, rblapack_a);
}

void
init_lapack_slahrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slahrd", rblapack_slahrd, -1);
}
ruby-lapack-1.7.2/ext/cla_porcond_c.c0000644000175000017500000001530212502221016017310 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real cla_porcond_c_(char* uplo, integer* n, complex* a, integer* lda, complex* af, integer* ldaf, real* c, logical* capply, integer* info, complex* work, real* rwork);


static VALUE
rblapack_cla_porcond_c(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_capply;
  logical capply; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_rwork;
  real *rwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack___out__;
  real __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  info, __out__ = NumRu::Lapack.cla_porcond_c( uplo, a, af, c, capply, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL FUNCTION CLA_PORCOND_C( UPLO, N, A, LDA, AF, LDAF, C, CAPPLY, INFO, WORK, RWORK )\n\n*  Purpose\n*  =======\n*\n*     CLA_PORCOND_C Computes the infinity norm condition number of\n*     op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector\n*\n\n*  Arguments\n*  =========\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     A       (input) COMPLEX array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX array, dimension (LDAF,N)\n*     The triangular factor U or L from the Cholesky factorization\n*     A = U**T*U or A = L*L**T, as computed by CPOTRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     C       (input) REAL array, dimension (N)\n*     The vector C in the formula op(A) * inv(diag(C)).\n*\n*     CAPPLY  (input) LOGICAL\n*     If .TRUE. then access the vector C in the formula above.\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit.\n*     i > 0:  The ith argument is invalid.\n*\n*     WORK    (input) COMPLEX array, dimension (2*N).\n*     Workspace.\n*\n*     RWORK   (input) REAL array, dimension (N).\n*     Workspace.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            KASE\n      REAL               AINVNM, ANORM, TMP\n      INTEGER            I, J\n      LOGICAL            UP\n      COMPLEX            ZDUM\n*     ..\n*     .. Local Arrays ..\n      INTEGER            ISAVE( 3 )\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CLACN2, CPOTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX, REAL, AIMAG\n*     ..\n*     .. Statement Functions ..\n      REAL CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, __out__ = NumRu::Lapack.cla_porcond_c( uplo, a, af, c, capply, work, rwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_c = argv[3];
  rblapack_capply = argv[4];
  rblapack_work = argv[5];
  rblapack_rwork = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  capply = (rblapack_capply == Qtrue);
  if (!NA_IsNArray(rblapack_rwork))
    rb_raise(rb_eArgError, "rwork (7th argument) must be NArray");
  if (NA_RANK(rblapack_rwork) != 1)
    rb_raise(rb_eArgError, "rank of rwork (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_rwork) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_rwork) != NA_SFLOAT)
    rblapack_rwork = na_change_type(rblapack_rwork, NA_SFLOAT);
  rwork = NA_PTR_TYPE(rblapack_rwork, real*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (4th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (6th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
  if (NA_TYPE(rblapack_work) != NA_SCOMPLEX)
    rblapack_work = na_change_type(rblapack_work, NA_SCOMPLEX);
  work = NA_PTR_TYPE(rblapack_work, complex*);

  __out__ = cla_porcond_c_(&uplo, &n, a, &lda, af, &ldaf, c, &capply, &info, work, rwork);

  rblapack_info = INT2NUM(info);
  rblapack___out__ = rb_float_new((double)__out__);
  return rb_ary_new3(2, rblapack_info, rblapack___out__);
}

void
init_lapack_cla_porcond_c(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cla_porcond_c", rblapack_cla_porcond_c, -1);
}
ruby-lapack-1.7.2/ext/stpttf.c0000644000175000017500000001531412502221023016050 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID stpttf_(char* transr, char* uplo, integer* n, real* ap, real* arf, integer* info);


static VALUE
rblapack_stpttf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_arf;
  real *arf; 
  VALUE rblapack_info;
  integer info; 


  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  arf, info = NumRu::Lapack.stpttf( transr, uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STPTTF( TRANSR, UPLO, N, AP, ARF, INFO )\n\n*  Purpose\n*  =======\n*\n*  STPTTF copies a triangular matrix A from standard packed format (TP)\n*  to rectangular full packed format (TF).\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR   (input) CHARACTER*1\n*          = 'N':  ARF in Normal format is wanted;\n*          = 'T':  ARF in Conjugate-transpose format is wanted.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input) REAL array, dimension ( N*(N+1)/2 ),\n*          On entry, the upper or lower triangular matrix A, packed\n*          columnwise in a linear array. The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  ARF     (output) REAL array, dimension ( N*(N+1)/2 ),\n*          On exit, the upper or lower triangular matrix A stored in\n*          RFP format. For a further discussion see Notes below.\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*  We first consider Rectangular Full Packed (RFP) Format when N is\n*  even. We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  the transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  the transpose of the last three columns of AP lower.\n*  This covers the case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        03 04 05                33 43 53\n*        13 14 15                00 44 54\n*        23 24 25                10 11 55\n*        33 34 35                20 21 22\n*        00 44 45                30 31 32\n*        01 11 55                40 41 42\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We then consider Rectangular Full Packed (RFP) Format when N is\n*  odd. We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  the transpose of the first two columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  the transpose of the last two columns of AP lower.\n*  This covers the case N odd and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        02 03 04                00 33 43\n*        12 13 14                10 11 44\n*        22 23 24                20 21 22\n*        00 33 34                30 31 32\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*           RFP A                   RFP A\n*\n*     02 12 22 00 01             00 10 20 30 40 50\n*     03 13 23 33 11             33 11 21 31 41 51\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  arf, info = NumRu::Lapack.stpttf( transr, uplo, n, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_n = argv[2];
  rblapack_ap = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  n = NUM2INT(rblapack_n);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (( n*(n+1)/2 )))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", ( n*(n+1)/2 ));
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  {
    na_shape_t shape[1];
    shape[0] = ( n*(n+1)/2 );
    rblapack_arf = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  arf = NA_PTR_TYPE(rblapack_arf, real*);

  stpttf_(&transr, &uplo, &n, ap, arf, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_arf, rblapack_info);
}

void
init_lapack_stpttf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "stpttf", rblapack_stpttf, -1);
}
ruby-lapack-1.7.2/ext/zgbrfsx.c0000644000175000017500000005711212502221016016215 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgbrfsx_(char* trans, char* equed, integer* n, integer* kl, integer* ku, integer* nrhs, doublereal* ab, integer* ldab, doublereal* afb, integer* ldafb, integer* ipiv, doublereal* r, doublereal* c, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zgbrfsx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_afb;
  doublereal *afb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_r;
  doublereal *r; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_params;
  doublereal *params; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_err_bnds_norm;
  doublereal *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  doublereal *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_r_out__;
  doublereal *r_out__;
  VALUE rblapack_c_out__;
  doublereal *c_out__;
  VALUE rblapack_x_out__;
  doublereal *x_out__;
  VALUE rblapack_params_out__;
  doublereal *params_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer ldab;
  integer n;
  integer ldafb;
  integer ldb;
  integer nrhs;
  integer ldx;
  integer nparams;
  integer n_err_bnds;

  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  rcond, berr, err_bnds_norm, err_bnds_comp, info, r, c, x, params = NumRu::Lapack.zgbrfsx( trans, equed, kl, ku, ab, afb, ipiv, r, c, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     ZGBRFSX improves the computed solution to a system of linear\n*     equations and provides error bounds and backward error estimates\n*     for the solution.  In addition to normwise error bound, the code\n*     provides maximum componentwise error bound if possible.  See\n*     comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n*     error bounds.\n*\n*     The original system of linear equations may have been equilibrated\n*     before calling this routine, as described by arguments EQUED, R\n*     and C below. In this case, the solution and error bounds returned\n*     are for the original unequilibrated system.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     TRANS   (input) CHARACTER*1\n*     Specifies the form of the system of equations:\n*       = 'N':  A * X = B     (No transpose)\n*       = 'T':  A**T * X = B  (Transpose)\n*       = 'C':  A**H * X = B  (Conjugate transpose = Transpose)\n*\n*     EQUED   (input) CHARACTER*1\n*     Specifies the form of equilibration that was done to A\n*     before calling this routine. This is needed to compute\n*     the solution and error bounds correctly.\n*       = 'N':  No equilibration\n*       = 'R':  Row equilibration, i.e., A has been premultiplied by\n*               diag(R).\n*       = 'C':  Column equilibration, i.e., A has been postmultiplied\n*               by diag(C).\n*       = 'B':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(R) * A * diag(C).\n*               The right hand side B has been changed accordingly.\n*\n*     N       (input) INTEGER\n*     The order of the matrix A.  N >= 0.\n*\n*     KL      (input) INTEGER\n*     The number of subdiagonals within the band of A.  KL >= 0.\n*\n*     KU      (input) INTEGER\n*     The number of superdiagonals within the band of A.  KU >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)\n*     The original band matrix A, stored in rows 1 to KL+KU+1.\n*     The j-th column of A is stored in the j-th column of the\n*     array AB as follows:\n*     AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n*     LDAB    (input) INTEGER\n*     The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*     AFB     (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n*     Details of the LU factorization of the band matrix A, as\n*     computed by DGBTRF.  U is stored as an upper triangular band\n*     matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n*     the multipliers used during the factorization are stored in\n*     rows KL+KU+2 to 2*KL+KU+1.\n*\n*     LDAFB   (input) INTEGER\n*     The leading dimension of the array AFB.  LDAFB >= 2*KL*KU+1.\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     The pivot indices from DGETRF; for 1<=i<=N, row i of the\n*     matrix was interchanged with row IPIV(i).\n*\n*     R       (input or output) DOUBLE PRECISION array, dimension (N)\n*     The row scale factors for A.  If EQUED = 'R' or 'B', A is\n*     multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n*     is not accessed.  R is an input argument if FACT = 'F';\n*     otherwise, R is an output argument.  If FACT = 'F' and\n*     EQUED = 'R' or 'B', each element of R must be positive.\n*     If R is output, each element of R is a power of the radix.\n*     If R is input, each element of R should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     C       (input or output) DOUBLE PRECISION array, dimension (N)\n*     The column scale factors for A.  If EQUED = 'C' or 'B', A is\n*     multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n*     is not accessed.  C is an input argument if FACT = 'F';\n*     otherwise, C is an output argument.  If FACT = 'F' and\n*     EQUED = 'C' or 'B', each element of C must be positive.\n*     If C is output, each element of C is a power of the radix.\n*     If C is input, each element of C should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*     The right hand side matrix B.\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*     On entry, the solution matrix X, as computed by DGETRS.\n*     On exit, the improved solution matrix X.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) DOUBLE PRECISION\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*     Componentwise relative backward error.  This is the\n*     componentwise relative backward error of each solution vector X(j)\n*     (i.e., the smallest relative change in any element of A or B that\n*     makes X(j) an exact solution).\n*\n*     N_ERR_BNDS (input) INTEGER\n*     Number of error bounds to return for each right hand side\n*     and each type (normwise or componentwise).  See ERR_BNDS_NORM and\n*     ERR_BNDS_COMP below.\n*\n*     ERR_BNDS_NORM  (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * dlamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * dlamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * dlamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * dlamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * dlamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * dlamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     NPARAMS (input) INTEGER\n*     Specifies the number of parameters set in PARAMS.  If .LE. 0, the\n*     PARAMS array is never referenced and default values are used.\n*\n*     PARAMS  (input / output) DOUBLE PRECISION array, dimension NPARAMS\n*     Specifies algorithm parameters.  If an entry is .LT. 0.0, then\n*     that entry will be filled with default value used for that\n*     parameter.  Only positions up to NPARAMS are accessed; defaults\n*     are used for higher-numbered parameters.\n*\n*       PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n*            refinement or not.\n*         Default: 1.0D+0\n*            = 0.0 : No refinement is performed, and no error bounds are\n*                    computed.\n*            = 1.0 : Use the double-precision refinement algorithm,\n*                    possibly with doubled-single computations if the\n*                    compilation environment does not support DOUBLE\n*                    PRECISION.\n*              (other values are reserved for future use)\n*\n*       PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n*            computations allowed for refinement.\n*         Default: 10\n*         Aggressive: Set to 100 to permit convergence using approximate\n*                     factorizations or factorizations other than LU. If\n*                     the factorization uses a technique other than\n*                     Gaussian elimination, the guarantees in\n*                     err_bnds_norm and err_bnds_comp may no longer be\n*                     trustworthy.\n*\n*       PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n*            will attempt to find a solution with small componentwise\n*            relative error in the double-precision algorithm.  Positive\n*            is true, 0.0 is false.\n*         Default: 1.0 (attempt componentwise convergence)\n*\n*     WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*     RWORK   (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit. The solution to every right-hand side is\n*         guaranteed.\n*       < 0:  If INFO = -i, the i-th argument had an illegal value\n*       > 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, berr, err_bnds_norm, err_bnds_comp, info, r, c, x, params = NumRu::Lapack.zgbrfsx( trans, equed, kl, ku, ab, afb, ipiv, r, c, b, x, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_trans = argv[0];
  rblapack_equed = argv[1];
  rblapack_kl = argv[2];
  rblapack_ku = argv[3];
  rblapack_ab = argv[4];
  rblapack_afb = argv[5];
  rblapack_ipiv = argv[6];
  rblapack_r = argv[7];
  rblapack_c = argv[8];
  rblapack_b = argv[9];
  rblapack_x = argv[10];
  rblapack_params = argv[11];
  if (argc == 12) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (9th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (11th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (11th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  n_err_bnds = 3;
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
  ldafb = NA_SHAPE0(rblapack_afb);
  if (NA_SHAPE1(rblapack_afb) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_afb) != NA_DFLOAT)
    rblapack_afb = na_change_type(rblapack_afb, NA_DFLOAT);
  afb = NA_PTR_TYPE(rblapack_afb, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (10th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (10th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (12th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (12th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_DFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
  params = NA_PTR_TYPE(rblapack_params, doublereal*);
  if (!NA_IsNArray(rblapack_r))
    rb_raise(rb_eArgError, "r (8th argument) must be NArray");
  if (NA_RANK(rblapack_r) != 1)
    rb_raise(rb_eArgError, "rank of r (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_r) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_r) != NA_DFLOAT)
    rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
  r = NA_PTR_TYPE(rblapack_r, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_r_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  r_out__ = NA_PTR_TYPE(rblapack_r_out__, doublereal*);
  MEMCPY(r_out__, r, doublereal, NA_TOTAL(rblapack_r));
  rblapack_r = rblapack_r_out__;
  r = r_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
  MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (2*n));

  zgbrfsx_(&trans, &equed, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, r, c, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_r, rblapack_c, rblapack_x, rblapack_params);
}

void
init_lapack_zgbrfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgbrfsx", rblapack_zgbrfsx, -1);
}
ruby-lapack-1.7.2/ext/ssyswapr.c0000644000175000017500000000763612502221020016424 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssyswapr_(char* uplo, integer* n, real* a, integer* i1, integer* i2);


static VALUE
rblapack_ssyswapr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_i1;
  integer i1; 
  VALUE rblapack_i2;
  integer i2; 
  VALUE rblapack_a_out__;
  real *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  a = NumRu::Lapack.ssyswapr( uplo, a, i1, i2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSYSWAPR( UPLO, N, A, I1, I2)\n\n*  Purpose\n*  =======\n*\n*  SSYSWAPR applies an elementary permutation on the rows and the columns of\n*  a symmetric matrix.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the NB diagonal matrix D and the multipliers\n*          used to obtain the factor U or L as computed by SSYTRF.\n*\n*          On exit, if INFO = 0, the (symmetric) inverse of the original\n*          matrix.  If UPLO = 'U', the upper triangular part of the\n*          inverse is formed and the part of A below the diagonal is not\n*          referenced; if UPLO = 'L' the lower triangular part of the\n*          inverse is formed and the part of A above the diagonal is\n*          not referenced.\n*\n*  I1      (input) INTEGER\n*          Index of the first row to swap\n*\n*  I2      (input) INTEGER\n*          Index of the second row to swap\n*\n\n*  =====================================================================\n*\n*     ..\n*     .. Local Scalars ..\n      LOGICAL            UPPER\n      INTEGER            I\n      REAL               TMP\n*\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SSWAP\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  a = NumRu::Lapack.ssyswapr( uplo, a, i1, i2, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_i1 = argv[2];
  rblapack_i2 = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  i1 = NUM2INT(rblapack_i1);
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  i2 = NUM2INT(rblapack_i2);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  ssyswapr_(&uplo, &n, a, &i1, &i2);

  return rblapack_a;
}

void
init_lapack_ssyswapr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssyswapr", rblapack_ssyswapr, -1);
}
ruby-lapack-1.7.2/ext/clanhp.c0000644000175000017500000001071012502221015015765 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real clanhp_(char* norm, char* uplo, integer* n, complex* ap, real* work);


static VALUE
rblapack_clanhp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack___out__;
  real __out__; 
  real *work;


  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  __out__ = NumRu::Lapack.clanhp( norm, uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL             FUNCTION CLANHP( NORM, UPLO, N, AP, WORK )\n\n*  Purpose\n*  =======\n*\n*  CLANHP  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  complex hermitian matrix A,  supplied in packed form.\n*\n*  Description\n*  ===========\n*\n*  CLANHP returns the value\n*\n*     CLANHP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in CLANHP as described\n*          above.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          hermitian matrix A is supplied.\n*          = 'U':  Upper triangular part of A is supplied\n*          = 'L':  Lower triangular part of A is supplied\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, CLANHP is\n*          set to zero.\n*\n*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)\n*          The upper or lower triangle of the hermitian matrix A, packed\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          Note that the  imaginary parts of the diagonal elements need\n*          not be set and are assumed to be zero.\n*\n*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n*          WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.clanhp( norm, uplo, n, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_n = argv[2];
  rblapack_ap = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  n = NUM2INT(rblapack_n);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  work = ALLOC_N(real, (MAX(1,(lsame_(&norm,"I")||lsame_(&norm,"1")||lsame_(&norm,"O")) ? n : 0)));

  __out__ = clanhp_(&norm, &uplo, &n, ap, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_clanhp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clanhp", rblapack_clanhp, -1);
}
ruby-lapack-1.7.2/ext/zsytri.c0000644000175000017500000001135112502221015016066 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zsytri_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* work, integer* info);


static VALUE
rblapack_zsytri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  doublecomplex *work;

  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  info, a = NumRu::Lapack.zsytri( uplo, a, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZSYTRI computes the inverse of a complex symmetric indefinite matrix\n*  A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n*  ZSYTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the block diagonal matrix D and the multipliers\n*          used to obtain the factor U or L as computed by ZSYTRF.\n*\n*          On exit, if INFO = 0, the (symmetric) inverse of the original\n*          matrix.  If UPLO = 'U', the upper triangular part of the\n*          inverse is formed and the part of A below the diagonal is not\n*          referenced; if UPLO = 'L' the lower triangular part of the\n*          inverse is formed and the part of A above the diagonal is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by ZSYTRF.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\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, D(i,i) = 0; the matrix is singular and its\n*               inverse could not be computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.zsytri( uplo, a, ipiv, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(doublecomplex, (2*n));

  zsytri_(&uplo, &n, a, &lda, ipiv, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_zsytri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zsytri", rblapack_zsytri, -1);
}
ruby-lapack-1.7.2/ext/slapy2.c0000644000175000017500000000337512502221016015744 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real slapy2_(real* x, real* y);


static VALUE
rblapack_slapy2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_x;
  real x; 
  VALUE rblapack_y;
  real y; 
  VALUE rblapack___out__;
  real __out__; 


  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  __out__ = NumRu::Lapack.slapy2( x, y, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL             FUNCTION SLAPY2( X, Y )\n\n*  Purpose\n*  =======\n*\n*  SLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary\n*  overflow.\n*\n\n*  Arguments\n*  =========\n*\n*  X       (input) REAL\n*  Y       (input) REAL\n*          X and Y specify the values x and y.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.slapy2( x, y, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_x = argv[0];
  rblapack_y = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  x = (real)NUM2DBL(rblapack_x);
  y = (real)NUM2DBL(rblapack_y);

  __out__ = slapy2_(&x, &y);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_slapy2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slapy2", rblapack_slapy2, -1);
}
ruby-lapack-1.7.2/ext/csyequb.c0000644000175000017500000001150612502221013016175 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID csyequb_(char* uplo, integer* n, complex* a, integer* lda, real* s, real* scond, real* amax, complex* work, integer* info);


static VALUE
rblapack_csyequb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_scond;
  real scond; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_info;
  integer info; 
  complex *work;

  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  s, scond, amax, info = NumRu::Lapack.csyequb( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CSYEQUB computes row and column scalings intended to equilibrate a\n*  symmetric matrix A and reduce its condition number\n*  (with respect to the two-norm).  S contains the scale factors,\n*  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n*  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This\n*  choice of S puts the condition number of B within a factor N of the\n*  smallest possible condition number over all possible diagonal\n*  scalings.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The N-by-N symmetric matrix whose scaling\n*          factors are to be computed.  Only the diagonal elements of A\n*          are referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  S       (output) REAL array, dimension (N)\n*          If INFO = 0, S contains the scale factors for A.\n*\n*  SCOND   (output) REAL\n*          If INFO = 0, S contains the ratio of the smallest S(i) to\n*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too\n*          large nor too small, it is not worth scaling by S.\n*\n*  AMAX    (output) REAL\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\n*\n*  WORK    (workspace) COMPLEX array, dimension (3*N)\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 is nonpositive.\n*\n\n*  Further Details\n*  ======= =======\n*\n*  Reference: Livne, O.E. and Golub, G.H., \"Scaling by Binormalization\",\n*  Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004.\n*  DOI 10.1023/B:NUMA.0000016606.32820.69\n*  Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, scond, amax, info = NumRu::Lapack.csyequb( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, real*);
  work = ALLOC_N(complex, (3*n));

  csyequb_(&uplo, &n, a, &lda, s, &scond, &amax, work, &info);

  free(work);
  rblapack_scond = rb_float_new((double)scond);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
}

void
init_lapack_csyequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "csyequb", rblapack_csyequb, -1);
}
ruby-lapack-1.7.2/ext/chpsvx.c0000644000175000017500000003164112502221025016042 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chpsvx_(char* fact, char* uplo, integer* n, integer* nrhs, complex* ap, complex* afp, integer* ipiv, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* ferr, real* berr, complex* work, real* rwork, integer* info);


static VALUE
rblapack_chpsvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_afp;
  complex *afp; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_afp_out__;
  complex *afp_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  complex *work;
  real *rwork;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.chpsvx( fact, uplo, ap, afp, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHPSVX uses the diagonal pivoting factorization A = U*D*U**H or\n*  A = L*D*L**H to compute the solution to a complex system of linear\n*  equations A * X = B, where A is an N-by-N Hermitian matrix stored\n*  in packed format and X and B are N-by-NRHS matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'N', the diagonal pivoting method is used to factor A as\n*        A = U * D * U**H,  if UPLO = 'U', or\n*        A = L * D * L**H,  if UPLO = 'L',\n*     where U (or L) is a product of permutation and unit upper (lower)\n*     triangular matrices and D is Hermitian and block diagonal with\n*     1-by-1 and 2-by-2 diagonal blocks.\n*\n*  2. If some D(i,i)=0, so that D is exactly singular, then the routine\n*     returns with INFO = i. Otherwise, the factored form of A is used\n*     to estimate the condition number of the matrix A.  If the\n*     reciprocal of the condition number is less than machine precision,\n*     INFO = N+1 is returned as a warning, but the routine still goes on\n*     to solve for X and compute error bounds as described below.\n*\n*  3. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  4. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of A has been\n*          supplied on entry.\n*          = 'F':  On entry, AFP and IPIV contain the factored form of\n*                  A.  AFP and IPIV will not be modified.\n*          = 'N':  The matrix A will be copied to AFP and factored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)\n*          The upper or lower triangle of the Hermitian matrix A, packed\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*          See below for further details.\n*\n*  AFP     (input or output) COMPLEX array, dimension (N*(N+1)/2)\n*          If FACT = 'F', then AFP is an input argument and on entry\n*          contains the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L from the factorization\n*          A = U*D*U**H or A = L*D*L**H as computed by CHPTRF, stored as\n*          a packed triangular matrix in the same storage format as A.\n*\n*          If FACT = 'N', then AFP is an output argument and on exit\n*          contains the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L from the factorization\n*          A = U*D*U**H or A = L*D*L**H as computed by CHPTRF, stored as\n*          a packed triangular matrix in the same storage format as A.\n*\n*  IPIV    (input or output) INTEGER array, dimension (N)\n*          If FACT = 'F', then IPIV is an input argument and on entry\n*          contains details of the interchanges and the block structure\n*          of D, as determined by CHPTRF.\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*          If FACT = 'N', then IPIV is an output argument and on exit\n*          contains details of the interchanges and the block structure\n*          of D, as determined by CHPTRF.\n*\n*  B       (input) COMPLEX array, dimension (LDB,NRHS)\n*          The N-by-NRHS right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) COMPLEX array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) REAL\n*          The estimate of the reciprocal condition number of the matrix\n*          A.  If RCOND is less than the machine precision (in\n*          particular, if RCOND = 0), the matrix is singular to working\n*          precision.  This condition is indicated by a return code of\n*          INFO > 0.\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\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, and i is\n*                <= N:  D(i,i) is exactly zero.  The factorization\n*                       has been completed but the factor D is exactly\n*                       singular, so the solution and error bounds could\n*                       not be computed. RCOND = 0 is returned.\n*                = N+1: D is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  Further Details\n*  ===============\n*\n*  The packed storage scheme is illustrated by the following example\n*  when N = 4, UPLO = 'U':\n*\n*  Two-dimensional storage of the Hermitian matrix A:\n*\n*     a11 a12 a13 a14\n*         a22 a23 a24\n*             a33 a34     (aij = conjg(aji))\n*                 a44\n*\n*  Packed storage of the upper triangle of A:\n*\n*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.chpsvx( fact, uplo, ap, afp, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_ap = argv[2];
  rblapack_afp = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_b = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  ldx = MAX(1,n);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_afp))
    rb_raise(rb_eArgError, "afp (4th argument) must be NArray");
  if (NA_RANK(rblapack_afp) != 1)
    rb_raise(rb_eArgError, "rank of afp (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_afp) != NA_SCOMPLEX)
    rblapack_afp = na_change_type(rblapack_afp, NA_SCOMPLEX);
  afp = NA_PTR_TYPE(rblapack_afp, complex*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_afp_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  afp_out__ = NA_PTR_TYPE(rblapack_afp_out__, complex*);
  MEMCPY(afp_out__, afp, complex, NA_TOTAL(rblapack_afp));
  rblapack_afp = rblapack_afp_out__;
  afp = afp_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (n));

  chpsvx_(&fact, &uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_afp, rblapack_ipiv);
}

void
init_lapack_chpsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chpsvx", rblapack_chpsvx, -1);
}
ruby-lapack-1.7.2/ext/dhgeqz.c0000644000175000017500000003713212502221024016011 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dhgeqz_(char* job, char* compq, char* compz, integer* n, integer* ilo, integer* ihi, doublereal* h, integer* ldh, doublereal* t, integer* ldt, doublereal* alphar, doublereal* alphai, doublereal* beta, doublereal* q, integer* ldq, doublereal* z, integer* ldz, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dhgeqz(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_compq;
  char compq; 
  VALUE rblapack_compz;
  char compz; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_h;
  doublereal *h; 
  VALUE rblapack_t;
  doublereal *t; 
  VALUE rblapack_q;
  doublereal *q; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_alphar;
  doublereal *alphar; 
  VALUE rblapack_alphai;
  doublereal *alphai; 
  VALUE rblapack_beta;
  doublereal *beta; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_h_out__;
  doublereal *h_out__;
  VALUE rblapack_t_out__;
  doublereal *t_out__;
  VALUE rblapack_q_out__;
  doublereal *q_out__;
  VALUE rblapack_z_out__;
  doublereal *z_out__;

  integer ldh;
  integer n;
  integer ldt;
  integer ldq;
  integer ldz;

  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  alphar, alphai, beta, work, info, h, t, q, z = NumRu::Lapack.dhgeqz( job, compq, compz, ilo, ihi, h, t, q, z, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DHGEQZ computes the eigenvalues of a real matrix pair (H,T),\n*  where H is an upper Hessenberg matrix and T is upper triangular,\n*  using the double-shift QZ method.\n*  Matrix pairs of this type are produced by the reduction to\n*  generalized upper Hessenberg form of a real matrix pair (A,B):\n*\n*     A = Q1*H*Z1**T,  B = Q1*T*Z1**T,\n*\n*  as computed by DGGHRD.\n*\n*  If JOB='S', then the Hessenberg-triangular pair (H,T) is\n*  also reduced to generalized Schur form,\n*  \n*     H = Q*S*Z**T,  T = Q*P*Z**T,\n*  \n*  where Q and Z are orthogonal matrices, P is an upper triangular\n*  matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2\n*  diagonal blocks.\n*\n*  The 1-by-1 blocks correspond to real eigenvalues of the matrix pair\n*  (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of\n*  eigenvalues.\n*\n*  Additionally, the 2-by-2 upper triangular diagonal blocks of P\n*  corresponding to 2-by-2 blocks of S are reduced to positive diagonal\n*  form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0,\n*  P(j,j) > 0, and P(j+1,j+1) > 0.\n*\n*  Optionally, the orthogonal matrix Q from the generalized Schur\n*  factorization may be postmultiplied into an input matrix Q1, and the\n*  orthogonal matrix Z may be postmultiplied into an input matrix Z1.\n*  If Q1 and Z1 are the orthogonal matrices from DGGHRD that reduced\n*  the matrix pair (A,B) to generalized upper Hessenberg form, then the\n*  output matrices Q1*Q and Z1*Z are the orthogonal factors from the\n*  generalized Schur factorization of (A,B):\n*\n*     A = (Q1*Q)*S*(Z1*Z)**T,  B = (Q1*Q)*P*(Z1*Z)**T.\n*  \n*  To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently,\n*  of (A,B)) are computed as a pair of values (alpha,beta), where alpha is\n*  complex and beta real.\n*  If beta is nonzero, lambda = alpha / beta is an eigenvalue of the\n*  generalized nonsymmetric eigenvalue problem (GNEP)\n*     A*x = lambda*B*x\n*  and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the\n*  alternate form of the GNEP\n*     mu*A*y = B*y.\n*  Real eigenvalues can be read directly from the generalized Schur\n*  form: \n*    alpha = S(i,i), beta = P(i,i).\n*\n*  Ref: C.B. Moler & G.W. Stewart, \"An Algorithm for Generalized Matrix\n*       Eigenvalue Problems\", SIAM J. Numer. Anal., 10(1973),\n*       pp. 241--256.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          = 'E': Compute eigenvalues only;\n*          = 'S': Compute eigenvalues and the Schur form. \n*\n*  COMPQ   (input) CHARACTER*1\n*          = 'N': Left Schur vectors (Q) are not computed;\n*          = 'I': Q is initialized to the unit matrix and the matrix Q\n*                 of left Schur vectors of (H,T) is returned;\n*          = 'V': Q must contain an orthogonal matrix Q1 on entry and\n*                 the product Q1*Q is returned.\n*\n*  COMPZ   (input) CHARACTER*1\n*          = 'N': Right Schur vectors (Z) are not computed;\n*          = 'I': Z is initialized to the unit matrix and the matrix Z\n*                 of right Schur vectors of (H,T) is returned;\n*          = 'V': Z must contain an orthogonal matrix Z1 on entry and\n*                 the product Z1*Z is returned.\n*\n*  N       (input) INTEGER\n*          The order of the matrices H, T, Q, and Z.  N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          ILO and IHI mark the rows and columns of H which are in\n*          Hessenberg form.  It is assumed that A is already upper\n*          triangular in rows and columns 1:ILO-1 and IHI+1:N.\n*          If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.\n*\n*  H       (input/output) DOUBLE PRECISION array, dimension (LDH, N)\n*          On entry, the N-by-N upper Hessenberg matrix H.\n*          On exit, if JOB = 'S', H contains the upper quasi-triangular\n*          matrix S from the generalized Schur factorization;\n*          2-by-2 diagonal blocks (corresponding to complex conjugate\n*          pairs of eigenvalues) are returned in standard form, with\n*          H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0.\n*          If JOB = 'E', the diagonal blocks of H match those of S, but\n*          the rest of H is unspecified.\n*\n*  LDH     (input) INTEGER\n*          The leading dimension of the array H.  LDH >= max( 1, N ).\n*\n*  T       (input/output) DOUBLE PRECISION array, dimension (LDT, N)\n*          On entry, the N-by-N upper triangular matrix T.\n*          On exit, if JOB = 'S', T contains the upper triangular\n*          matrix P from the generalized Schur factorization;\n*          2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S\n*          are reduced to positive diagonal form, i.e., if H(j+1,j) is\n*          non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and\n*          T(j+1,j+1) > 0.\n*          If JOB = 'E', the diagonal blocks of T match those of P, but\n*          the rest of T is unspecified.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T.  LDT >= max( 1, N ).\n*\n*  ALPHAR  (output) DOUBLE PRECISION array, dimension (N)\n*          The real parts of each scalar alpha defining an eigenvalue\n*          of GNEP.\n*\n*  ALPHAI  (output) DOUBLE PRECISION array, dimension (N)\n*          The imaginary parts of each scalar alpha defining an\n*          eigenvalue of GNEP.\n*          If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n*          positive, then the j-th and (j+1)-st eigenvalues are a\n*          complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j).\n*\n*  BETA    (output) DOUBLE PRECISION array, dimension (N)\n*          The scalars beta that define the eigenvalues of GNEP.\n*          Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and\n*          beta = BETA(j) represent the j-th eigenvalue of the matrix\n*          pair (A,B), in one of the forms lambda = alpha/beta or\n*          mu = beta/alpha.  Since either lambda or mu may overflow,\n*          they should not, in general, be computed.\n*\n*  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ, N)\n*          On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in\n*          the reduction of (A,B) to generalized Hessenberg form.\n*          On exit, if COMPZ = 'I', the orthogonal matrix of left Schur\n*          vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix\n*          of left Schur vectors of (A,B).\n*          Not referenced if COMPZ = 'N'.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.  LDQ >= 1.\n*          If COMPQ='V' or 'I', then LDQ >= N.\n*\n*  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ, N)\n*          On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in\n*          the reduction of (A,B) to generalized Hessenberg form.\n*          On exit, if COMPZ = 'I', the orthogonal matrix of\n*          right Schur vectors of (H,T), and if COMPZ = 'V', the\n*          orthogonal matrix of right Schur vectors of (A,B).\n*          Not referenced if COMPZ = 'N'.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1.\n*          If COMPZ='V' or 'I', then LDZ >= 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.  LWORK >= max(1,N).\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*          = 1,...,N: the QZ iteration did not converge.  (H,T) is not\n*                     in Schur form, but ALPHAR(i), ALPHAI(i), and\n*                     BETA(i), i=INFO+1,...,N should be correct.\n*          = N+1,...,2*N: the shift calculation failed.  (H,T) is not\n*                     in Schur form, but ALPHAR(i), ALPHAI(i), and\n*                     BETA(i), i=INFO-N+1,...,N should be correct.\n*\n\n*  Further Details\n*  ===============\n*\n*  Iteration counters:\n*\n*  JITER  -- counts iterations.\n*  IITER  -- counts iterations run since ILAST was last\n*            changed.  This is therefore reset only when a 1-by-1 or\n*            2-by-2 block deflates off the bottom.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  alphar, alphai, beta, work, info, h, t, q, z = NumRu::Lapack.dhgeqz( job, compq, compz, ilo, ihi, h, t, q, z, [: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_job = argv[0];
  rblapack_compq = argv[1];
  rblapack_compz = argv[2];
  rblapack_ilo = argv[3];
  rblapack_ihi = argv[4];
  rblapack_h = argv[5];
  rblapack_t = argv[6];
  rblapack_q = argv[7];
  rblapack_z = 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;
  }

  job = StringValueCStr(rblapack_job)[0];
  compz = StringValueCStr(rblapack_compz)[0];
  ihi = NUM2INT(rblapack_ihi);
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (7th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (7th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  n = NA_SHAPE1(rblapack_t);
  if (NA_TYPE(rblapack_t) != NA_DFLOAT)
    rblapack_t = na_change_type(rblapack_t, NA_DFLOAT);
  t = NA_PTR_TYPE(rblapack_t, doublereal*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (9th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  if (NA_SHAPE1(rblapack_z) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of t");
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  compq = StringValueCStr(rblapack_compq)[0];
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (6th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  if (NA_SHAPE1(rblapack_h) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of t");
  if (NA_TYPE(rblapack_h) != NA_DFLOAT)
    rblapack_h = na_change_type(rblapack_h, NA_DFLOAT);
  h = NA_PTR_TYPE(rblapack_h, doublereal*);
  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (8th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (8th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of t");
  if (NA_TYPE(rblapack_q) != NA_DFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
  q = NA_PTR_TYPE(rblapack_q, doublereal*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  alphar = NA_PTR_TYPE(rblapack_alphar, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  alphai = NA_PTR_TYPE(rblapack_alphai, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublereal*);
  MEMCPY(h_out__, h, doublereal, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = n;
    rblapack_t_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  t_out__ = NA_PTR_TYPE(rblapack_t_out__, doublereal*);
  MEMCPY(t_out__, t, doublereal, NA_TOTAL(rblapack_t));
  rblapack_t = rblapack_t_out__;
  t = t_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
  MEMCPY(q_out__, q, doublereal, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
  MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  dhgeqz_(&job, &compq, &compz, &n, &ilo, &ihi, h, &ldh, t, &ldt, alphar, alphai, beta, q, &ldq, z, &ldz, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_work, rblapack_info, rblapack_h, rblapack_t, rblapack_q, rblapack_z);
}

void
init_lapack_dhgeqz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dhgeqz", rblapack_dhgeqz, -1);
}
ruby-lapack-1.7.2/ext/cungtr.c0000644000175000017500000001244212502221020016022 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cungtr_(char* uplo, integer* n, complex* a, integer* lda, complex* tau, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_cungtr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *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  work, info, a = NumRu::Lapack.cungtr( uplo, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CUNGTR generates a complex unitary matrix Q which is defined as the\n*  product of n-1 elementary reflectors of order N, as returned by\n*  CHETRD:\n*\n*  if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),\n*\n*  if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U': Upper triangle of A contains elementary reflectors\n*                 from CHETRD;\n*          = 'L': Lower triangle of A contains elementary reflectors\n*                 from CHETRD.\n*\n*  N       (input) INTEGER\n*          The order of the matrix Q. N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the vectors which define the elementary reflectors,\n*          as returned by CHETRD.\n*          On exit, the N-by-N unitary matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= N.\n*\n*  TAU     (input) COMPLEX array, dimension (N-1)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by CHETRD.\n*\n*  WORK    (workspace/output) COMPLEX 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 >= N-1.\n*          For optimum performance LWORK >= (N-1)*NB, where NB is\n*          the 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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, a = NumRu::Lapack.cungtr( uplo, a, tau, [: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_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_tau = 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;
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (rblapack_lwork == Qnil)
    lwork = n-1;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_tau) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", n-1);
  if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  cungtr_(&uplo, &n, a, &lda, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_cungtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cungtr", rblapack_cungtr, -1);
}
ruby-lapack-1.7.2/ext/dlasda.c0000644000175000017500000003304212502221022015751 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlasda_(integer* icompq, integer* smlsiz, integer* n, integer* sqre, doublereal* d, doublereal* e, doublereal* u, integer* ldu, doublereal* vt, integer* k, doublereal* difl, doublereal* difr, doublereal* z, doublereal* poles, integer* givptr, integer* givcol, integer* ldgcol, integer* perm, doublereal* givnum, doublereal* c, doublereal* s, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dlasda(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_icompq;
  integer icompq; 
  VALUE rblapack_smlsiz;
  integer smlsiz; 
  VALUE rblapack_sqre;
  integer sqre; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_u;
  doublereal *u; 
  VALUE rblapack_vt;
  doublereal *vt; 
  VALUE rblapack_k;
  integer *k; 
  VALUE rblapack_difl;
  doublereal *difl; 
  VALUE rblapack_difr;
  doublereal *difr; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_poles;
  doublereal *poles; 
  VALUE rblapack_givptr;
  integer *givptr; 
  VALUE rblapack_givcol;
  integer *givcol; 
  VALUE rblapack_perm;
  integer *perm; 
  VALUE rblapack_givnum;
  doublereal *givnum; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  doublereal *work;
  integer *iwork;

  integer n;
  integer ldu;
  integer nlvl;
  integer ldgcol;
  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  u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s, info, d = NumRu::Lapack.dlasda( icompq, smlsiz, sqre, d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  Using a divide and conquer approach, DLASDA computes the singular\n*  value decomposition (SVD) of a real upper bidiagonal N-by-M matrix\n*  B with diagonal D and offdiagonal E, where M = N + SQRE. The\n*  algorithm computes the singular values in the SVD B = U * S * VT.\n*  The orthogonal matrices U and VT are optionally computed in\n*  compact form.\n*\n*  A related subroutine, DLASD0, computes the singular values and\n*  the singular vectors in explicit form.\n*\n\n*  Arguments\n*  =========\n*\n*  ICOMPQ (input) INTEGER\n*         Specifies whether singular vectors are to be computed\n*         in compact form, as follows\n*         = 0: Compute singular values only.\n*         = 1: Compute singular vectors of upper bidiagonal\n*              matrix in compact form.\n*\n*  SMLSIZ (input) INTEGER\n*         The maximum size of the subproblems at the bottom of the\n*         computation tree.\n*\n*  N      (input) INTEGER\n*         The row dimension of the upper bidiagonal matrix. This is\n*         also the dimension of the main diagonal array D.\n*\n*  SQRE   (input) INTEGER\n*         Specifies the column dimension of the bidiagonal matrix.\n*         = 0: The bidiagonal matrix has column dimension M = N;\n*         = 1: The bidiagonal matrix has column dimension M = N + 1.\n*\n*  D      (input/output) DOUBLE PRECISION array, dimension ( N )\n*         On entry D contains the main diagonal of the bidiagonal\n*         matrix. On exit D, if INFO = 0, contains its singular values.\n*\n*  E      (input) DOUBLE PRECISION array, dimension ( M-1 )\n*         Contains the subdiagonal entries of the bidiagonal matrix.\n*         On exit, E has been destroyed.\n*\n*  U      (output) DOUBLE PRECISION array,\n*         dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced\n*         if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left\n*         singular vector matrices of all subproblems at the bottom\n*         level.\n*\n*  LDU    (input) INTEGER, LDU = > N.\n*         The leading dimension of arrays U, VT, DIFL, DIFR, POLES,\n*         GIVNUM, and Z.\n*\n*  VT     (output) DOUBLE PRECISION array,\n*         dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced\n*         if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT' contains the right\n*         singular vector matrices of all subproblems at the bottom\n*         level.\n*\n*  K      (output) INTEGER array,\n*         dimension ( N ) if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0.\n*         If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th\n*         secular equation on the computation tree.\n*\n*  DIFL   (output) DOUBLE PRECISION array, dimension ( LDU, NLVL ),\n*         where NLVL = floor(log_2 (N/SMLSIZ))).\n*\n*  DIFR   (output) DOUBLE PRECISION array,\n*                  dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and\n*                  dimension ( N ) if ICOMPQ = 0.\n*         If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1)\n*         record distances between singular values on the I-th\n*         level and singular values on the (I -1)-th level, and\n*         DIFR(1:N, 2 * I ) contains the normalizing factors for\n*         the right singular vector matrix. See DLASD8 for details.\n*\n*  Z      (output) DOUBLE PRECISION array,\n*                  dimension ( LDU, NLVL ) if ICOMPQ = 1 and\n*                  dimension ( N ) if ICOMPQ = 0.\n*         The first K elements of Z(1, I) contain the components of\n*         the deflation-adjusted updating row vector for subproblems\n*         on the I-th level.\n*\n*  POLES  (output) DOUBLE PRECISION array,\n*         dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced\n*         if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and\n*         POLES(1, 2*I) contain  the new and old singular values\n*         involved in the secular equations on the I-th level.\n*\n*  GIVPTR (output) INTEGER array,\n*         dimension ( N ) if ICOMPQ = 1, and not referenced if\n*         ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records\n*         the number of Givens rotations performed on the I-th\n*         problem on the computation tree.\n*\n*  GIVCOL (output) INTEGER array,\n*         dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not\n*         referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,\n*         GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations\n*         of Givens rotations performed on the I-th level on the\n*         computation tree.\n*\n*  LDGCOL (input) INTEGER, LDGCOL = > N.\n*         The leading dimension of arrays GIVCOL and PERM.\n*\n*  PERM   (output) INTEGER array,\n*         dimension ( LDGCOL, NLVL ) if ICOMPQ = 1, and not referenced\n*         if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records\n*         permutations done on the I-th level of the computation tree.\n*\n*  GIVNUM (output) DOUBLE PRECISION array,\n*         dimension ( LDU,  2 * NLVL ) if ICOMPQ = 1, and not\n*         referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,\n*         GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S-\n*         values of Givens rotations performed on the I-th level on\n*         the computation tree.\n*\n*  C      (output) DOUBLE PRECISION array,\n*         dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0.\n*         If ICOMPQ = 1 and the I-th subproblem is not square, on exit,\n*         C( I ) contains the C-value of a Givens rotation related to\n*         the right null space of the I-th subproblem.\n*\n*  S      (output) DOUBLE PRECISION array, dimension ( N ) if\n*         ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1\n*         and the I-th subproblem is not square, on exit, S( I )\n*         contains the S-value of a Givens rotation related to\n*         the right null space of the I-th subproblem.\n*\n*  WORK   (workspace) DOUBLE PRECISION array, dimension\n*         (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)).\n*\n*  IWORK  (workspace) INTEGER array.\n*         Dimension must be at least (7 * N).\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 = 1, a singular value did not converge\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s, info, d = NumRu::Lapack.dlasda( icompq, smlsiz, sqre, d, e, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_icompq = argv[0];
  rblapack_smlsiz = argv[1];
  rblapack_sqre = argv[2];
  rblapack_d = argv[3];
  rblapack_e = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  icompq = NUM2INT(rblapack_icompq);
  sqre = NUM2INT(rblapack_sqre);
  smlsiz = NUM2INT(rblapack_smlsiz);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  m = sqre == 0 ? n : sqre == 1 ? n+1 : 0;
  nlvl = floor(1.0/log(2.0)*log((double)n/smlsiz));
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (5th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (m-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", m-1);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  ldgcol = n;
  ldu = n;
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = MAX(1,smlsiz);
    rblapack_u = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  u = NA_PTR_TYPE(rblapack_u, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = smlsiz+1;
    rblapack_vt = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vt = NA_PTR_TYPE(rblapack_vt, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = icompq == 1 ? n : icompq == 0 ? 1 : 0;
    rblapack_k = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  k = NA_PTR_TYPE(rblapack_k, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = nlvl;
    rblapack_difl = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  difl = NA_PTR_TYPE(rblapack_difl, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = icompq == 1 ? ldu : icompq == 0 ? n : 0;
    shape[1] = icompq == 1 ? 2 * nlvl : 0;
    rblapack_difr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  difr = NA_PTR_TYPE(rblapack_difr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = icompq == 1 ? ldu : icompq == 0 ? n : 0;
    shape[1] = icompq == 1 ? nlvl : 0;
    rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = 2 * nlvl;
    rblapack_poles = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  poles = NA_PTR_TYPE(rblapack_poles, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_givptr = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  givptr = NA_PTR_TYPE(rblapack_givptr, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldgcol;
    shape[1] = 2 * nlvl;
    rblapack_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
  }
  givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldgcol;
    shape[1] = nlvl;
    rblapack_perm = na_make_object(NA_LINT, 2, shape, cNArray);
  }
  perm = NA_PTR_TYPE(rblapack_perm, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = 2 * nlvl;
    rblapack_givnum = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  givnum = NA_PTR_TYPE(rblapack_givnum, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = icompq == 1 ? n : icompq == 0 ? 1 : 0;
    rblapack_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = icompq==1 ? n : icompq==0 ? 1 : 0;
    rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  work = ALLOC_N(doublereal, (6 * n + (smlsiz + 1)*(smlsiz + 1)));
  iwork = ALLOC_N(integer, ((7 * n)));

  dlasda_(&icompq, &smlsiz, &n, &sqre, d, e, u, &ldu, vt, k, difl, difr, z, poles, givptr, givcol, &ldgcol, perm, givnum, c, s, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(15, rblapack_u, rblapack_vt, rblapack_k, rblapack_difl, rblapack_difr, rblapack_z, rblapack_poles, rblapack_givptr, rblapack_givcol, rblapack_perm, rblapack_givnum, rblapack_c, rblapack_s, rblapack_info, rblapack_d);
}

void
init_lapack_dlasda(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlasda", rblapack_dlasda, -1);
}
ruby-lapack-1.7.2/ext/sgerq2.c0000644000175000017500000001030712502221025015726 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgerq2_(integer* m, integer* n, real* a, integer* lda, real* tau, real* work, integer* info);


static VALUE
rblapack_sgerq2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  real *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.sgerq2( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGERQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGERQ2 computes an RQ factorization of a real m by n matrix A:\n*  A = R * 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) REAL array, dimension (LDA,N)\n*          On entry, the m by n matrix A.\n*          On exit, if m <= n, the upper triangle of the subarray\n*          A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;\n*          if m >= n, the elements on and above the (m-n)-th subdiagonal\n*          contain the m by n upper trapezoidal matrix R; the remaining\n*          elements, with the array TAU, represent the orthogonal matrix\n*          Q as a product of elementary reflectors (see Further\n*          Details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  TAU     (output) REAL array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace) REAL 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(1) H(2) . . . H(k), 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(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n*  A(m-k+i,1:n-k+i-1), 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.sgerq2( 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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  m = lda;
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(real, (m));

  sgerq2_(&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_sgerq2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgerq2", rblapack_sgerq2, -1);
}
ruby-lapack-1.7.2/ext/zunmql.c0000644000175000017500000001647312502221024016062 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zunmql_(char* side, char* trans, integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zunmql(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_c;
  doublecomplex *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublecomplex *c_out__;

  integer lda;
  integer k;
  integer ldc;
  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  work, info, c = NumRu::Lapack.zunmql( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZUNMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZUNMQL overwrites the general complex M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'C':      Q**H * C       C * Q**H\n*\n*  where Q is a complex unitary matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(k) . . . H(2) H(1)\n*\n*  as returned by ZGEQLF. Q is of order M if SIDE = 'L' and of order N\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**H from the Left;\n*          = 'R': apply Q or Q**H from the Right.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'C':  Transpose, apply Q**H.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,K)\n*          The i-th column must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          ZGEQLF in the last k columns of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*          If SIDE = 'L', LDA >= max(1,M);\n*          if SIDE = 'R', LDA >= max(1,N).\n*\n*  TAU     (input) COMPLEX*16 array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by ZGEQLF.\n*\n*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace/output) COMPLEX*16 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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M).\n*          For optimum performance LWORK >= N*NB if SIDE = 'L', and\n*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n*          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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.zunmql( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_m = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 7) {
    rblapack_lwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  side = StringValueCStr(rblapack_side)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != k)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
  MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  zunmql_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_zunmql(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zunmql", rblapack_zunmql, -1);
}
ruby-lapack-1.7.2/ext/sla_gerfsx_extended.c0000644000175000017500000005653112502221013020546 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sla_gerfsx_extended_(integer* prec_type, integer* trans_type, integer* n, integer* nrhs, real* a, integer* lda, real* af, integer* ldaf, integer* ipiv, logical* colequ, real* c, real* b, integer* ldb, real* y, integer* ldy, real* berr_out, integer* n_norms, real* err_bnds_norm, real* err_bnds_comp, real* res, real* ayb, real* dy, real* y_tail, real* rcond, integer* ithresh, real* rthresh, real* dz_ub, logical* ignore_cwise, integer* info);


static VALUE
rblapack_sla_gerfsx_extended(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_prec_type;
  integer prec_type; 
  VALUE rblapack_trans_type;
  integer trans_type; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_af;
  real *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_colequ;
  logical colequ; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_y;
  real *y; 
  VALUE rblapack_n_norms;
  integer n_norms; 
  VALUE rblapack_err_bnds_norm;
  real *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  real *err_bnds_comp; 
  VALUE rblapack_res;
  real *res; 
  VALUE rblapack_ayb;
  real *ayb; 
  VALUE rblapack_dy;
  real *dy; 
  VALUE rblapack_y_tail;
  real *y_tail; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_ithresh;
  integer ithresh; 
  VALUE rblapack_rthresh;
  real rthresh; 
  VALUE rblapack_dz_ub;
  real dz_ub; 
  VALUE rblapack_ignore_cwise;
  logical ignore_cwise; 
  VALUE rblapack_berr_out;
  real *berr_out; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_y_out__;
  real *y_out__;
  VALUE rblapack_err_bnds_norm_out__;
  real *err_bnds_norm_out__;
  VALUE rblapack_err_bnds_comp_out__;
  real *err_bnds_comp_out__;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldy;
  integer n_err_bnds;

  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  berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.sla_gerfsx_extended( prec_type, trans_type, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLA_GERFSX_EXTENDED improves the computed solution to a system of\n*  linear equations by performing extra-precise iterative refinement\n*  and provides error bounds and backward error estimates for the solution.\n*  This subroutine is called by SGERFSX to perform iterative refinement.\n*  In addition to normwise error bound, the code provides maximum\n*  componentwise error bound if possible. See comments for ERR_BNDS_NORM\n*  and ERR_BNDS_COMP for details of the error bounds. Note that this\n*  subroutine is only resonsible for setting the second fields of\n*  ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n*  Arguments\n*  =========\n*\n*     PREC_TYPE      (input) INTEGER\n*     Specifies the intermediate precision to be used in refinement.\n*     The value is defined by ILAPREC(P) where P is a CHARACTER and\n*     P    = 'S':  Single\n*          = 'D':  Double\n*          = 'I':  Indigenous\n*          = 'X', 'E':  Extra\n*\n*     TRANS_TYPE     (input) INTEGER\n*     Specifies the transposition operation on A.\n*     The value is defined by ILATRANS(T) where T is a CHARACTER and\n*     T    = 'N':  No transpose\n*          = 'T':  Transpose\n*          = 'C':  Conjugate transpose\n*\n*     N              (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NRHS           (input) INTEGER\n*     The number of right-hand-sides, i.e., the number of columns of the\n*     matrix B.\n*\n*     A              (input) REAL array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA            (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF             (input) REAL array, dimension (LDAF,N)\n*     The factors L and U from the factorization\n*     A = P*L*U as computed by SGETRF.\n*\n*     LDAF           (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV           (input) INTEGER array, dimension (N)\n*     The pivot indices from the factorization A = P*L*U\n*     as computed by SGETRF; row i of the matrix was interchanged\n*     with row IPIV(i).\n*\n*     COLEQU         (input) LOGICAL\n*     If .TRUE. then column equilibration was done to A before calling\n*     this routine. This is needed to compute the solution and error\n*     bounds correctly.\n*\n*     C              (input) REAL array, dimension (N)\n*     The column scale factors for A. If COLEQU = .FALSE., C\n*     is not accessed. If C is input, each element of C should be a power\n*     of the radix to ensure a reliable solution and error estimates.\n*     Scaling by powers of the radix does not cause rounding errors unless\n*     the result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B              (input) REAL array, dimension (LDB,NRHS)\n*     The right-hand-side matrix B.\n*\n*     LDB            (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     Y              (input/output) REAL array, dimension (LDY,NRHS)\n*     On entry, the solution matrix X, as computed by SGETRS.\n*     On exit, the improved solution matrix Y.\n*\n*     LDY            (input) INTEGER\n*     The leading dimension of the array Y.  LDY >= max(1,N).\n*\n*     BERR_OUT       (output) REAL array, dimension (NRHS)\n*     On exit, BERR_OUT(j) contains the componentwise relative backward\n*     error for right-hand-side j from the formula\n*         max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n*     where abs(Z) is the componentwise absolute value of the matrix\n*     or vector Z. This is computed by SLA_LIN_BERR.\n*\n*     N_NORMS        (input) INTEGER\n*     Determines which error bounds to return (see ERR_BNDS_NORM\n*     and ERR_BNDS_COMP).\n*     If N_NORMS >= 1 return normwise error bounds.\n*     If N_NORMS >= 2 return componentwise error bounds.\n*\n*     ERR_BNDS_NORM  (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     RES            (input) REAL array, dimension (N)\n*     Workspace to hold the intermediate residual.\n*\n*     AYB            (input) REAL array, dimension (N)\n*     Workspace. This can be the same workspace passed for Y_TAIL.\n*\n*     DY             (input) REAL array, dimension (N)\n*     Workspace to hold the intermediate solution.\n*\n*     Y_TAIL         (input) REAL array, dimension (N)\n*     Workspace to hold the trailing bits of the intermediate solution.\n*\n*     RCOND          (input) REAL\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     ITHRESH        (input) INTEGER\n*     The maximum number of residual computations allowed for\n*     refinement. The default is 10. For 'aggressive' set to 100 to\n*     permit convergence using approximate factorizations or\n*     factorizations other than LU. If the factorization uses a\n*     technique other than Gaussian elimination, the guarantees in\n*     ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n*     RTHRESH        (input) REAL\n*     Determines when to stop refinement if the error estimate stops\n*     decreasing. Refinement will stop when the next solution no longer\n*     satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n*     the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n*     default value is 0.5. For 'aggressive' set to 0.9 to permit\n*     convergence on extremely ill-conditioned matrices. See LAWN 165\n*     for more details.\n*\n*     DZ_UB          (input) REAL\n*     Determines when to start considering componentwise convergence.\n*     Componentwise convergence is only considered after each component\n*     of the solution Y is stable, which we definte as the relative\n*     change in each component being less than DZ_UB. The default value\n*     is 0.25, requiring the first bit to be stable. See LAWN 165 for\n*     more details.\n*\n*     IGNORE_CWISE   (input) LOGICAL\n*     If .TRUE. then ignore componentwise convergence. Default value\n*     is .FALSE..\n*\n*     INFO           (output) INTEGER\n*       = 0:  Successful exit.\n*       < 0:  if INFO = -i, the ith argument to SGETRS had an illegal\n*             value\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      CHARACTER          TRANS\n      INTEGER            CNT, I, J, X_STATE, Z_STATE, Y_PREC_STATE\n      REAL               YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n     $                   DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n     $                   DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n     $                   EPS, HUGEVAL, INCR_THRESH\n      LOGICAL            INCR_PREC\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.sla_gerfsx_extended( prec_type, trans_type, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 21 && argc != 21)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 21)", argc);
  rblapack_prec_type = argv[0];
  rblapack_trans_type = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_colequ = argv[5];
  rblapack_c = argv[6];
  rblapack_b = argv[7];
  rblapack_y = argv[8];
  rblapack_n_norms = argv[9];
  rblapack_err_bnds_norm = argv[10];
  rblapack_err_bnds_comp = argv[11];
  rblapack_res = argv[12];
  rblapack_ayb = argv[13];
  rblapack_dy = argv[14];
  rblapack_y_tail = argv[15];
  rblapack_rcond = argv[16];
  rblapack_ithresh = argv[17];
  rblapack_rthresh = argv[18];
  rblapack_dz_ub = argv[19];
  rblapack_ignore_cwise = argv[20];
  if (argc == 21) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  prec_type = NUM2INT(rblapack_prec_type);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (9th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 2)
    rb_raise(rb_eArgError, "rank of y (9th argument) must be %d", 2);
  ldy = NA_SHAPE0(rblapack_y);
  nrhs = NA_SHAPE1(rblapack_y);
  if (NA_TYPE(rblapack_y) != NA_SFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
  y = NA_PTR_TYPE(rblapack_y, real*);
  if (!NA_IsNArray(rblapack_err_bnds_norm))
    rb_raise(rb_eArgError, "err_bnds_norm (11th argument) must be NArray");
  if (NA_RANK(rblapack_err_bnds_norm) != 2)
    rb_raise(rb_eArgError, "rank of err_bnds_norm (11th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_err_bnds_norm) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of y");
  n_err_bnds = NA_SHAPE1(rblapack_err_bnds_norm);
  if (NA_TYPE(rblapack_err_bnds_norm) != NA_SFLOAT)
    rblapack_err_bnds_norm = na_change_type(rblapack_err_bnds_norm, NA_SFLOAT);
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
  if (!NA_IsNArray(rblapack_res))
    rb_raise(rb_eArgError, "res (13th argument) must be NArray");
  if (NA_RANK(rblapack_res) != 1)
    rb_raise(rb_eArgError, "rank of res (13th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_res) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_res) != NA_SFLOAT)
    rblapack_res = na_change_type(rblapack_res, NA_SFLOAT);
  res = NA_PTR_TYPE(rblapack_res, real*);
  if (!NA_IsNArray(rblapack_dy))
    rb_raise(rb_eArgError, "dy (15th argument) must be NArray");
  if (NA_RANK(rblapack_dy) != 1)
    rb_raise(rb_eArgError, "rank of dy (15th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dy) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_dy) != NA_SFLOAT)
    rblapack_dy = na_change_type(rblapack_dy, NA_SFLOAT);
  dy = NA_PTR_TYPE(rblapack_dy, real*);
  rcond = (real)NUM2DBL(rblapack_rcond);
  rthresh = (real)NUM2DBL(rblapack_rthresh);
  ignore_cwise = (rblapack_ignore_cwise == Qtrue);
  trans_type = NUM2INT(rblapack_trans_type);
  colequ = (rblapack_colequ == Qtrue);
  n_norms = NUM2INT(rblapack_n_norms);
  if (!NA_IsNArray(rblapack_ayb))
    rb_raise(rb_eArgError, "ayb (14th argument) must be NArray");
  if (NA_RANK(rblapack_ayb) != 1)
    rb_raise(rb_eArgError, "rank of ayb (14th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ayb) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ayb) != NA_SFLOAT)
    rblapack_ayb = na_change_type(rblapack_ayb, NA_SFLOAT);
  ayb = NA_PTR_TYPE(rblapack_ayb, real*);
  ithresh = NUM2INT(rblapack_ithresh);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
  af = NA_PTR_TYPE(rblapack_af, real*);
  if (!NA_IsNArray(rblapack_err_bnds_comp))
    rb_raise(rb_eArgError, "err_bnds_comp (12th argument) must be NArray");
  if (NA_RANK(rblapack_err_bnds_comp) != 2)
    rb_raise(rb_eArgError, "rank of err_bnds_comp (12th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_err_bnds_comp) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of y");
  if (NA_SHAPE1(rblapack_err_bnds_comp) != n_err_bnds)
    rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_comp must be the same as shape 1 of err_bnds_norm");
  if (NA_TYPE(rblapack_err_bnds_comp) != NA_SFLOAT)
    rblapack_err_bnds_comp = na_change_type(rblapack_err_bnds_comp, NA_SFLOAT);
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
  dz_ub = (real)NUM2DBL(rblapack_dz_ub);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of y");
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (!NA_IsNArray(rblapack_y_tail))
    rb_raise(rb_eArgError, "y_tail (16th argument) must be NArray");
  if (NA_RANK(rblapack_y_tail) != 1)
    rb_raise(rb_eArgError, "rank of y_tail (16th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y_tail) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_y_tail) != NA_SFLOAT)
    rblapack_y_tail = na_change_type(rblapack_y_tail, NA_SFLOAT);
  y_tail = NA_PTR_TYPE(rblapack_y_tail, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr_out = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr_out = NA_PTR_TYPE(rblapack_berr_out, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldy;
    shape[1] = nrhs;
    rblapack_y_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
  MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm_out__ = NA_PTR_TYPE(rblapack_err_bnds_norm_out__, real*);
  MEMCPY(err_bnds_norm_out__, err_bnds_norm, real, NA_TOTAL(rblapack_err_bnds_norm));
  rblapack_err_bnds_norm = rblapack_err_bnds_norm_out__;
  err_bnds_norm = err_bnds_norm_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp_out__ = NA_PTR_TYPE(rblapack_err_bnds_comp_out__, real*);
  MEMCPY(err_bnds_comp_out__, err_bnds_comp, real, NA_TOTAL(rblapack_err_bnds_comp));
  rblapack_err_bnds_comp = rblapack_err_bnds_comp_out__;
  err_bnds_comp = err_bnds_comp_out__;

  sla_gerfsx_extended_(&prec_type, &trans_type, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_err_bnds_norm, rblapack_err_bnds_comp);
}

void
init_lapack_sla_gerfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sla_gerfsx_extended", rblapack_sla_gerfsx_extended, -1);
}
ruby-lapack-1.7.2/ext/slasd4.c0000644000175000017500000001274212502221012015716 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slasd4_(integer* n, integer* i, real* d, real* z, real* delta, real* rho, real* sigma, real* work, integer* info);


static VALUE
rblapack_slasd4(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_i;
  integer i; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_rho;
  real rho; 
  VALUE rblapack_delta;
  real *delta; 
  VALUE rblapack_sigma;
  real sigma; 
  VALUE rblapack_info;
  integer info; 
  real *work;

  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  delta, sigma, info = NumRu::Lapack.slasd4( i, d, z, rho, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  This subroutine computes the square root of the I-th updated\n*  eigenvalue of a positive symmetric rank-one modification to\n*  a positive diagonal matrix whose entries are given as the squares\n*  of the corresponding entries in the array d, and that\n*\n*         0 <= D(i) < D(j)  for  i < j\n*\n*  and that RHO > 0. This is arranged by the calling routine, and is\n*  no loss in generality.  The rank-one modified system is thus\n*\n*         diag( D ) * diag( D ) +  RHO *  Z * Z_transpose.\n*\n*  where we assume the Euclidean norm of Z is 1.\n*\n*  The method consists of approximating the rational functions in the\n*  secular equation by simpler interpolating rational functions.\n*\n\n*  Arguments\n*  =========\n*\n*  N      (input) INTEGER\n*         The length of all arrays.\n*\n*  I      (input) INTEGER\n*         The index of the eigenvalue to be computed.  1 <= I <= N.\n*\n*  D      (input) REAL array, dimension ( N )\n*         The original eigenvalues.  It is assumed that they are in\n*         order, 0 <= D(I) < D(J)  for I < J.\n*\n*  Z      (input) REAL array, dimension (N)\n*         The components of the updating vector.\n*\n*  DELTA  (output) REAL array, dimension (N)\n*         If N .ne. 1, DELTA contains (D(j) - sigma_I) in its  j-th\n*         component.  If N = 1, then DELTA(1) = 1.  The vector DELTA\n*         contains the information necessary to construct the\n*         (singular) eigenvectors.\n*\n*  RHO    (input) REAL\n*         The scalar in the symmetric updating formula.\n*\n*  SIGMA  (output) REAL\n*         The computed sigma_I, the I-th updated eigenvalue.\n*\n*  WORK   (workspace) REAL array, dimension (N)\n*         If N .ne. 1, WORK contains (D(j) + sigma_I) in its  j-th\n*         component.  If N = 1, then WORK( 1 ) = 1.\n*\n*  INFO   (output) INTEGER\n*         = 0:  successful exit\n*         > 0:  if INFO = 1, the updating process failed.\n*\n*  Internal Parameters\n*  ===================\n*\n*  Logical variable ORGATI (origin-at-i?) is used for distinguishing\n*  whether D(i) or D(i+1) is treated as the origin.\n*\n*            ORGATI = .true.    origin at i\n*            ORGATI = .false.   origin at i+1\n*\n*  Logical variable SWTCH3 (switch-for-3-poles?) is for noting\n*  if we are working with THREE poles!\n*\n*  MAXIT is the maximum number of iterations allowed for each\n*  eigenvalue.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ren-Cang Li, Computer Science Division, University of California\n*     at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  delta, sigma, info = NumRu::Lapack.slasd4( i, d, z, rho, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_i = argv[0];
  rblapack_d = argv[1];
  rblapack_z = argv[2];
  rblapack_rho = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  i = NUM2INT(rblapack_i);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (3th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of z");
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  rho = (real)NUM2DBL(rblapack_rho);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_delta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  delta = NA_PTR_TYPE(rblapack_delta, real*);
  work = ALLOC_N(real, (n));

  slasd4_(&n, &i, d, z, delta, &rho, &sigma, work, &info);

  free(work);
  rblapack_sigma = rb_float_new((double)sigma);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_delta, rblapack_sigma, rblapack_info);
}

void
init_lapack_slasd4(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slasd4", rblapack_slasd4, -1);
}
ruby-lapack-1.7.2/ext/ssptri.c0000644000175000017500000001104112502221017016044 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssptri_(char* uplo, integer* n, real* ap, integer* ipiv, real* work, integer* info);


static VALUE
rblapack_ssptri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  real *ap_out__;
  real *work;

  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  info, ap = NumRu::Lapack.ssptri( uplo, ap, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSPTRI( UPLO, N, AP, IPIV, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSPTRI computes the inverse of a real symmetric indefinite matrix\n*  A in packed storage using the factorization A = U*D*U**T or\n*  A = L*D*L**T computed by SSPTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) REAL array, dimension (N*(N+1)/2)\n*          On entry, the block diagonal matrix D and the multipliers\n*          used to obtain the factor U or L as computed by SSPTRF,\n*          stored as a packed triangular matrix.\n*\n*          On exit, if INFO = 0, the (symmetric) inverse of the original\n*          matrix, stored as a packed triangular matrix. The j-th column\n*          of inv(A) is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;\n*          if UPLO = 'L',\n*             AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by SSPTRF.\n*\n*  WORK    (workspace) REAL array, dimension (N)\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, D(i,i) = 0; the matrix is singular and its\n*               inverse could not be computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ap = NumRu::Lapack.ssptri( uplo, ap, ipiv, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_ipiv = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, real*);
  MEMCPY(ap_out__, ap, real, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  work = ALLOC_N(real, (n));

  ssptri_(&uplo, &n, ap, ipiv, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ap);
}

void
init_lapack_ssptri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssptri", rblapack_ssptri, -1);
}
ruby-lapack-1.7.2/ext/slar2v.c0000644000175000017500000001474512502221021015742 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slar2v_(integer* n, real* x, real* y, real* z, integer* incx, real* c, real* s, integer* incc);


static VALUE
rblapack_slar2v(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_y;
  real *y; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_incc;
  integer incc; 
  VALUE rblapack_x_out__;
  real *x_out__;
  VALUE rblapack_y_out__;
  real *y_out__;
  VALUE rblapack_z_out__;
  real *z_out__;


  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  x, y, z = NumRu::Lapack.slar2v( n, x, y, z, incx, c, s, incc, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAR2V( N, X, Y, Z, INCX, C, S, INCC )\n\n*  Purpose\n*  =======\n*\n*  SLAR2V applies a vector of real plane rotations from both sides to\n*  a sequence of 2-by-2 real symmetric matrices, defined by the elements\n*  of the vectors x, y and z. For i = 1,2,...,n\n*\n*     ( x(i)  z(i) ) := (  c(i)  s(i) ) ( x(i)  z(i) ) ( c(i) -s(i) )\n*     ( z(i)  y(i) )    ( -s(i)  c(i) ) ( z(i)  y(i) ) ( s(i)  c(i) )\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of plane rotations to be applied.\n*\n*  X       (input/output) REAL array,\n*                         dimension (1+(N-1)*INCX)\n*          The vector x.\n*\n*  Y       (input/output) REAL array,\n*                         dimension (1+(N-1)*INCX)\n*          The vector y.\n*\n*  Z       (input/output) REAL array,\n*                         dimension (1+(N-1)*INCX)\n*          The vector z.\n*\n*  INCX    (input) INTEGER\n*          The increment between elements of X, Y and Z. INCX > 0.\n*\n*  C       (input) REAL array, dimension (1+(N-1)*INCC)\n*          The cosines of the plane rotations.\n*\n*  S       (input) REAL array, dimension (1+(N-1)*INCC)\n*          The sines of the plane rotations.\n*\n*  INCC    (input) INTEGER\n*          The increment between elements of C and S. INCC > 0.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, IC, IX\n      REAL               CI, SI, T1, T2, T3, T4, T5, T6, XI, YI, ZI\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, y, z = NumRu::Lapack.slar2v( n, x, y, z, incx, c, s, incc, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_n = argv[0];
  rblapack_x = argv[1];
  rblapack_y = argv[2];
  rblapack_z = argv[3];
  rblapack_incx = argv[4];
  rblapack_c = argv[5];
  rblapack_s = argv[6];
  rblapack_incc = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  incx = NUM2INT(rblapack_incx);
  incc = NUM2INT(rblapack_incc);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1+(n-1)*incx))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (4th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != (1+(n-1)*incx))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 1+(n-1)*incx);
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (7th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != (1+(n-1)*incc))
    rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", 1+(n-1)*incc);
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (3th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incx))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incx);
  if (NA_TYPE(rblapack_y) != NA_SFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
  y = NA_PTR_TYPE(rblapack_y, real*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != (1+(n-1)*incc))
    rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", 1+(n-1)*incc);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incx;
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incx;
    rblapack_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
  MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incx;
    rblapack_z_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
  MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  slar2v_(&n, x, y, z, &incx, c, s, &incc);

  return rb_ary_new3(3, rblapack_x, rblapack_y, rblapack_z);
}

void
init_lapack_slar2v(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slar2v", rblapack_slar2v, -1);
}
ruby-lapack-1.7.2/ext/dgelsx.c0000644000175000017500000002035412502221025016014 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgelsx_(integer* m, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* b, integer* ldb, integer* jpvt, doublereal* rcond, integer* rank, doublereal* work, integer* info);


static VALUE
rblapack_dgelsx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_jpvt;
  integer *jpvt; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_rank;
  integer rank; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;
  VALUE rblapack_jpvt_out__;
  integer *jpvt_out__;
  doublereal *work;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  rank, info, a, b, jpvt = NumRu::Lapack.dgelsx( m, a, b, jpvt, rcond, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  This routine is deprecated and has been replaced by routine DGELSY.\n*\n*  DGELSX computes the minimum-norm solution to a real linear least\n*  squares problem:\n*      minimize || A * X - B ||\n*  using a complete orthogonal factorization of A.  A is an M-by-N\n*  matrix which may be rank-deficient.\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*  The routine first computes a QR factorization with column pivoting:\n*      A * P = Q * [ R11 R12 ]\n*                  [  0  R22 ]\n*  with R11 defined as the largest leading submatrix whose estimated\n*  condition number is less than 1/RCOND.  The order of R11, RANK,\n*  is the effective rank of A.\n*\n*  Then, R22 is considered to be negligible, and R12 is annihilated\n*  by orthogonal transformations from the right, arriving at the\n*  complete orthogonal factorization:\n*     A * P = Q * [ T11 0 ] * Z\n*                 [  0  0 ]\n*  The minimum-norm solution is then\n*     X = P * Z' [ inv(T11)*Q1'*B ]\n*                [        0       ]\n*  where Q1 consists of the first RANK columns of 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*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of\n*          columns of 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, A has been overwritten by details of its\n*          complete orthogonal factorization.\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 M-by-NRHS right hand side matrix B.\n*          On exit, the N-by-NRHS solution matrix X.\n*          If m >= n and RANK = n, the residual sum-of-squares for\n*          the solution in the i-th column is given by the sum of\n*          squares of elements N+1:M in that column.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,M,N).\n*\n*  JPVT    (input/output) INTEGER array, dimension (N)\n*          On entry, if JPVT(i) .ne. 0, the i-th column of A is an\n*          initial column, otherwise it is a free column.  Before\n*          the QR factorization of A, all initial columns are\n*          permuted to the leading positions; only the remaining\n*          free columns are moved as a result of column pivoting\n*          during the factorization.\n*          On exit, if JPVT(i) = k, then the i-th column of A*P\n*          was the k-th column of A.\n*\n*  RCOND   (input) DOUBLE PRECISION\n*          RCOND is used to determine the effective rank of A, which\n*          is defined as the order of the largest leading triangular\n*          submatrix R11 in the QR factorization with pivoting of A,\n*          whose estimated condition number < 1/RCOND.\n*\n*  RANK    (output) INTEGER\n*          The effective rank of A, i.e., the order of the submatrix\n*          R11.  This is the same as the order of the submatrix T11\n*          in the complete orthogonal factorization of A.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension\n*                      (max( min(M,N)+3*N, 2*min(M,N)+NRHS )),\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rank, info, a, b, jpvt = NumRu::Lapack.dgelsx( m, a, b, jpvt, rcond, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  rblapack_b = argv[2];
  rblapack_jpvt = argv[3];
  rblapack_rcond = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  rcond = NUM2DBL(rblapack_rcond);
  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*);
  if (!NA_IsNArray(rblapack_jpvt))
    rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
  if (NA_RANK(rblapack_jpvt) != 1)
    rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_jpvt) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_jpvt) != NA_LINT)
    rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
  jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
  MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
  rblapack_jpvt = rblapack_jpvt_out__;
  jpvt = jpvt_out__;
  work = ALLOC_N(doublereal, (MAX((MIN(m,n))+3*n,2*(MIN(m,n))*nrhs)));

  dgelsx_(&m, &n, &nrhs, a, &lda, b, &ldb, jpvt, &rcond, &rank, work, &info);

  free(work);
  rblapack_rank = INT2NUM(rank);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_rank, rblapack_info, rblapack_a, rblapack_b, rblapack_jpvt);
}

void
init_lapack_dgelsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgelsx", rblapack_dgelsx, -1);
}
ruby-lapack-1.7.2/ext/zheevx.c0000644000175000017500000002563512502221022016043 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zheevx_(char* jobz, char* range, char* uplo, integer* n, doublecomplex* a, integer* lda, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublecomplex* z, integer* ldz, doublecomplex* work, integer* lwork, doublereal* rwork, integer* iwork, integer* ifail, integer* info);


static VALUE
rblapack_zheevx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_vl;
  doublereal vl; 
  VALUE rblapack_vu;
  doublereal vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  doublereal abstol; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_ifail;
  integer *ifail; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  doublereal *rwork;
  integer *iwork;

  integer lda;
  integer n;
  integer ldz;

  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  m, w, z, work, ifail, info, a = NumRu::Lapack.zheevx( jobz, range, uplo, a, vl, vu, il, iu, abstol, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHEEVX computes selected eigenvalues and, optionally, eigenvectors\n*  of a complex Hermitian matrix A.  Eigenvalues and eigenvectors can\n*  be selected by specifying either a range of values or a range of\n*  indices for the desired eigenvalues.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found.\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found.\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA, N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of A contains the\n*          upper triangular part of the matrix A.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of A contains\n*          the lower triangular part of the matrix A.\n*          On exit, the lower triangle (if UPLO='L') or the upper\n*          triangle (if UPLO='U') of A, including the diagonal, is\n*          destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  VL      (input) DOUBLE PRECISION\n*  VU      (input) DOUBLE PRECISION\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) DOUBLE PRECISION\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less than\n*          or equal to zero, then  EPS*|T|  will be used in its place,\n*          where |T| is the 1-norm of the tridiagonal matrix obtained\n*          by reducing A to tridiagonal form.\n*\n*          Eigenvalues will be computed most accurately when ABSTOL is\n*          set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n*          If this routine returns with INFO>0, indicating that some\n*          eigenvectors did not converge, try setting ABSTOL to\n*          2*DLAMCH('S').\n*\n*          See \"Computing Small Singular Values of Bidiagonal Matrices\n*          with Guaranteed High Relative Accuracy,\" by Demmel and\n*          Kahan, LAPACK Working Note #3.\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          On normal exit, the first M elements contain the selected\n*          eigenvalues in ascending order.\n*\n*  Z       (output) COMPLEX*16 array, dimension (LDZ, max(1,M))\n*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix A\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          If an eigenvector fails to converge, then that column of Z\n*          contains the latest approximation to the eigenvector, and the\n*          index of the eigenvector is returned in IFAIL.\n*          If JOBZ = 'N', then Z is not referenced.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of the array WORK.  LWORK >= 1, when N <= 1;\n*          otherwise 2*N.\n*          For optimal efficiency, LWORK >= (NB+1)*N,\n*          where NB is the max of the blocksize for ZHETRD and for\n*          ZUNMTR as returned by ILAENV.\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*  RWORK   (workspace) DOUBLE PRECISION array, dimension (7*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (5*N)\n*\n*  IFAIL   (output) INTEGER array, dimension (N)\n*          If JOBZ = 'V', then if INFO = 0, the first M elements of\n*          IFAIL are zero.  If INFO > 0, then IFAIL contains the\n*          indices of the eigenvectors that failed to converge.\n*          If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n*                Their indices are stored in array IFAIL.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, work, ifail, info, a = NumRu::Lapack.zheevx( jobz, range, uplo, a, vl, vu, il, iu, abstol, [: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_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_uplo = argv[2];
  rblapack_a = argv[3];
  rblapack_vl = argv[4];
  rblapack_vu = argv[5];
  rblapack_il = argv[6];
  rblapack_iu = argv[7];
  rblapack_abstol = 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;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  vl = NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  abstol = NUM2DBL(rblapack_abstol);
  range = StringValueCStr(rblapack_range)[0];
  vu = NUM2DBL(rblapack_vu);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (rblapack_lwork == Qnil)
    lwork = n<=1 ? 1 : 2*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  iu = NUM2INT(rblapack_iu);
  m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  rwork = ALLOC_N(doublereal, (7*n));
  iwork = ALLOC_N(integer, (5*n));

  zheevx_(&jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, &lwork, rwork, iwork, ifail, &info);

  free(rwork);
  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_m, rblapack_w, rblapack_z, rblapack_work, rblapack_ifail, rblapack_info, rblapack_a);
}

void
init_lapack_zheevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zheevx", rblapack_zheevx, -1);
}
ruby-lapack-1.7.2/ext/dlauu2.c0000644000175000017500000000736412502221023015726 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlauu2_(char* uplo, integer* n, doublereal* a, integer* lda, integer* info);


static VALUE
rblapack_dlauu2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  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  info, a = NumRu::Lapack.dlauu2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAUU2( UPLO, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLAUU2 computes the product U * U' or L' * L, where the triangular\n*  factor U or L is stored in the upper or lower triangular part of\n*  the array A.\n*\n*  If UPLO = 'U' or 'u' then the upper triangle of the result is stored,\n*  overwriting the factor U in A.\n*  If UPLO = 'L' or 'l' then the lower triangle of the result is stored,\n*  overwriting the factor L in A.\n*\n*  This is the unblocked form of the algorithm, calling Level 2 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the triangular factor stored in the array A\n*          is upper or lower triangular:\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the triangular factor U or L.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the triangular factor U or L.\n*          On exit, if UPLO = 'U', the upper triangle of A is\n*          overwritten with the upper triangle of the product U * U';\n*          if UPLO = 'L', the lower triangle of A is overwritten with\n*          the lower triangle of the product L' * L.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.dlauu2( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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*);
  {
    na_shape_t 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__;

  dlauu2_(&uplo, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_dlauu2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlauu2", rblapack_dlauu2, -1);
}
ruby-lapack-1.7.2/ext/dpbstf.c0000644000175000017500000001276012502221017016013 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dpbstf_(char* uplo, integer* n, integer* kd, doublereal* ab, integer* ldab, integer* info);


static VALUE
rblapack_dpbstf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublereal *ab_out__;

  integer ldab;
  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  info, ab = NumRu::Lapack.dpbstf( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPBSTF( UPLO, N, KD, AB, LDAB, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPBSTF computes a split Cholesky factorization of a real\n*  symmetric positive definite band matrix A.\n*\n*  This routine is designed to be used in conjunction with DSBGST.\n*\n*  The factorization has the form  A = S**T*S  where S is a band matrix\n*  of the same bandwidth as A and the following structure:\n*\n*    S = ( U    )\n*        ( M  L )\n*\n*  where U is upper triangular of order m = (n+kd)/2, and L is lower\n*  triangular of order n-m.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first kd+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*          On exit, if INFO = 0, the factor S from the split Cholesky\n*          factorization A = S**T*S. See Further Details.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\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 factorization could not be completed,\n*               because the updated element a(i,i) was negative; the\n*               matrix A is not positive definite.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  N = 7, KD = 2:\n*\n*  S = ( s11  s12  s13                     )\n*      (      s22  s23  s24                )\n*      (           s33  s34                )\n*      (                s44                )\n*      (           s53  s54  s55           )\n*      (                s64  s65  s66      )\n*      (                     s75  s76  s77 )\n*\n*  If UPLO = 'U', the array AB holds:\n*\n*  on entry:                          on exit:\n*\n*   *    *   a13  a24  a35  a46  a57   *    *   s13  s24  s53  s64  s75\n*   *   a12  a23  a34  a45  a56  a67   *   s12  s23  s34  s54  s65  s76\n*  a11  a22  a33  a44  a55  a66  a77  s11  s22  s33  s44  s55  s66  s77\n*\n*  If UPLO = 'L', the array AB holds:\n*\n*  on entry:                          on exit:\n*\n*  a11  a22  a33  a44  a55  a66  a77  s11  s22  s33  s44  s55  s66  s77\n*  a21  a32  a43  a54  a65  a76   *   s12  s23  s34  s54  s65  s76   *\n*  a31  a42  a53  a64  a64   *    *   s13  s24  s53  s64  s75   *    *\n*\n*  Array elements marked * are not used by the routine.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ab = NumRu::Lapack.dpbstf( uplo, kd, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  kd = NUM2INT(rblapack_kd);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
  MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  dpbstf_(&uplo, &n, &kd, ab, &ldab, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ab);
}

void
init_lapack_dpbstf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dpbstf", rblapack_dpbstf, -1);
}
ruby-lapack-1.7.2/ext/zhegs2.c0000644000175000017500000001223712502221017015732 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhegs2_(integer* itype, char* uplo, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, integer* info);


static VALUE
rblapack_zhegs2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;

  integer lda;
  integer n;
  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  info, a = NumRu::Lapack.zhegs2( itype, uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHEGS2 reduces a complex Hermitian-definite generalized\n*  eigenproblem to standard form.\n*\n*  If ITYPE = 1, the problem is A*x = lambda*B*x,\n*  and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')\n*\n*  If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n*  B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.\n*\n*  B must have been previously factorized as U'*U or L*L' by ZPOTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');\n*          = 2 or 3: compute U*A*U' or L'*A*L.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          Hermitian matrix A is stored, and how B has been factorized.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading\n*          n by n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n by n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the transformed matrix, stored in the\n*          same format as A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input) COMPLEX*16 array, dimension (LDB,N)\n*          The triangular factor from the Cholesky factorization of B,\n*          as returned by ZPOTRF.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.zhegs2( itype, uplo, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_itype = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  itype = NUM2INT(rblapack_itype);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zhegs2_(&itype, &uplo, &n, a, &lda, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_zhegs2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhegs2", rblapack_zhegs2, -1);
}
ruby-lapack-1.7.2/ext/dspsv.c0000644000175000017500000001643712502221023015672 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dspsv_(char* uplo, integer* n, integer* nrhs, doublereal* ap, integer* ipiv, doublereal* b, integer* ldb, integer* info);


static VALUE
rblapack_dspsv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublereal *ap_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;

  integer ldb;
  integer nrhs;
  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  ipiv, info, ap, b = NumRu::Lapack.dspsv( uplo, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSPSV computes the solution to a real system of linear equations\n*     A * X = B,\n*  where A is an N-by-N symmetric matrix stored in packed format and X\n*  and B are N-by-NRHS matrices.\n*\n*  The diagonal pivoting method is used to factor A as\n*     A = U * D * U**T,  if UPLO = 'U', or\n*     A = L * D * L**T,  if UPLO = 'L',\n*  where U (or L) is a product of permutation and unit upper (lower)\n*  triangular matrices, D is symmetric and block diagonal with 1-by-1\n*  and 2-by-2 diagonal blocks.  The factored form of A is then used to\n*  solve the system of equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          See below for further details.\n*\n*          On exit, the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L from the factorization\n*          A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as\n*          a packed triangular matrix in the same storage format as A.\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D, as\n*          determined by DSPTRF.  If IPIV(k) > 0, then rows and columns\n*          k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n*          diagonal block.  If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n*          then rows and columns k-1 and -IPIV(k) were interchanged and\n*          D(k-1:k,k-1:k) is a 2-by-2 diagonal block.  If UPLO = 'L' and\n*          IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n*          -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n*          diagonal block.\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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, D(i,i) is exactly zero.  The factorization\n*                has been completed, but the block diagonal matrix D is\n*                exactly singular, so the solution could not be\n*                computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  The packed storage scheme is illustrated by the following example\n*  when N = 4, UPLO = 'U':\n*\n*  Two-dimensional storage of the symmetric matrix A:\n*\n*     a11 a12 a13 a14\n*         a22 a23 a24\n*             a33 a34     (aij = aji)\n*                 a44\n*\n*  Packed storage of the upper triangle of A:\n*\n*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n*  =====================================================================\n*\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DSPTRF, DSPTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, ap, b = NumRu::Lapack.dspsv( uplo, ap, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_b = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  n = ldb;
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
  MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dspsv_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ipiv, rblapack_info, rblapack_ap, rblapack_b);
}

void
init_lapack_dspsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dspsv", rblapack_dspsv, -1);
}
ruby-lapack-1.7.2/ext/cgesvx.c0000644000175000017500000005006212502221012016020 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgesvx_(char* fact, char* trans, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, char* equed, real* r, real* c, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* ferr, real* berr, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cgesvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_r;
  real *r; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_rwork;
  real *rwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_af_out__;
  complex *af_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  VALUE rblapack_r_out__;
  real *r_out__;
  VALUE rblapack_c_out__;
  real *c_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;
  complex *work;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;
  integer ldaf;
  integer ldx;

  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  x, rcond, ferr, berr, rwork, info, a, af, ipiv, equed, r, c, b = NumRu::Lapack.cgesvx( fact, trans, a, b, [:af => af, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGESVX uses the LU factorization to compute the solution to a complex\n*  system of linear equations\n*     A * X = B,\n*  where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'E', real scaling factors are computed to equilibrate\n*     the system:\n*        TRANS = 'N':  diag(R)*A*diag(C)     *inv(diag(C))*X = diag(R)*B\n*        TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n*        TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n*     or diag(C)*B (if TRANS = 'T' or 'C').\n*\n*  2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n*     matrix A (after equilibration if FACT = 'E') as\n*        A = P * L * U,\n*     where P is a permutation matrix, L is a unit lower triangular\n*     matrix, and U is upper triangular.\n*\n*  3. If some U(i,i)=0, so that U is exactly singular, then the routine\n*     returns with INFO = i. Otherwise, the factored form of A is used\n*     to estimate the condition number of the matrix A.  If the\n*     reciprocal of the condition number is less than machine precision,\n*     INFO = N+1 is returned as a warning, but the routine still goes on\n*     to solve for X and compute error bounds as described below.\n*\n*  4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  5. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n*  6. If equilibration was used, the matrix X is premultiplied by\n*     diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n*     that it solves the original system before equilibration.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of the matrix A is\n*          supplied on entry, and if not, whether the matrix A should be\n*          equilibrated before it is factored.\n*          = 'F':  On entry, AF and IPIV contain the factored form of A.\n*                  If EQUED is not 'N', the matrix A has been\n*                  equilibrated with scaling factors given by R and C.\n*                  A, AF, and IPIV are not modified.\n*          = 'N':  The matrix A will be copied to AF and factored.\n*          = 'E':  The matrix A will be equilibrated if necessary, then\n*                  copied to AF and factored.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose)\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the N-by-N matrix A.  If FACT = 'F' and EQUED is\n*          not 'N', then A must have been equilibrated by the scaling\n*          factors in R and/or C.  A is not modified if FACT = 'F' or\n*          'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n*          On exit, if EQUED .ne. 'N', A is scaled as follows:\n*          EQUED = 'R':  A := diag(R) * A\n*          EQUED = 'C':  A := A * diag(C)\n*          EQUED = 'B':  A := diag(R) * A * diag(C).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AF      (input or output) COMPLEX array, dimension (LDAF,N)\n*          If FACT = 'F', then AF is an input argument and on entry\n*          contains the factors L and U from the factorization\n*          A = P*L*U as computed by CGETRF.  If EQUED .ne. 'N', then\n*          AF is the factored form of the equilibrated matrix A.\n*\n*          If FACT = 'N', then AF is an output argument and on exit\n*          returns the factors L and U from the factorization A = P*L*U\n*          of the original matrix A.\n*\n*          If FACT = 'E', then AF is an output argument and on exit\n*          returns the factors L and U from the factorization A = P*L*U\n*          of the equilibrated matrix A (see the description of A for\n*          the form of the equilibrated matrix).\n*\n*  LDAF    (input) INTEGER\n*          The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*  IPIV    (input or output) INTEGER array, dimension (N)\n*          If FACT = 'F', then IPIV is an input argument and on entry\n*          contains the pivot indices from the factorization A = P*L*U\n*          as computed by CGETRF; row i of the matrix was interchanged\n*          with row IPIV(i).\n*\n*          If FACT = 'N', then IPIV is an output argument and on exit\n*          contains the pivot indices from the factorization A = P*L*U\n*          of the original matrix A.\n*\n*          If FACT = 'E', then IPIV is an output argument and on exit\n*          contains the pivot indices from the factorization A = P*L*U\n*          of the equilibrated matrix A.\n*\n*  EQUED   (input or output) CHARACTER*1\n*          Specifies the form of equilibration that was done.\n*          = 'N':  No equilibration (always true if FACT = 'N').\n*          = 'R':  Row equilibration, i.e., A has been premultiplied by\n*                  diag(R).\n*          = 'C':  Column equilibration, i.e., A has been postmultiplied\n*                  by diag(C).\n*          = 'B':  Both row and column equilibration, i.e., A has been\n*                  replaced by diag(R) * A * diag(C).\n*          EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*          output argument.\n*\n*  R       (input or output) REAL array, dimension (N)\n*          The row scale factors for A.  If EQUED = 'R' or 'B', A is\n*          multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n*          is not accessed.  R is an input argument if FACT = 'F';\n*          otherwise, R is an output argument.  If FACT = 'F' and\n*          EQUED = 'R' or 'B', each element of R must be positive.\n*\n*  C       (input or output) REAL array, dimension (N)\n*          The column scale factors for A.  If EQUED = 'C' or 'B', A is\n*          multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n*          is not accessed.  C is an input argument if FACT = 'F';\n*          otherwise, C is an output argument.  If FACT = 'F' and\n*          EQUED = 'C' or 'B', each element of C must be positive.\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit,\n*          if EQUED = 'N', B is not modified;\n*          if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n*          diag(R)*B;\n*          if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n*          overwritten by diag(C)*B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) COMPLEX array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n*          to the original system of equations.  Note that A and B are\n*          modified on exit if EQUED .ne. 'N', and the solution to the\n*          equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n*          EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n*          and EQUED = 'R' or 'B'.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) REAL\n*          The estimate of the reciprocal condition number of the matrix\n*          A after equilibration (if done).  If RCOND is less than the\n*          machine precision (in particular, if RCOND = 0), the matrix\n*          is singular to working precision.  This condition is\n*          indicated by a return code of INFO > 0.\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace/output) REAL array, dimension (2*N)\n*          On exit, RWORK(1) contains the reciprocal pivot growth\n*          factor norm(A)/norm(U). The \"max absolute element\" norm is\n*          used. If RWORK(1) is much less than 1, then the stability\n*          of the LU factorization of the (equilibrated) matrix A\n*          could be poor. This also means that the solution X, condition\n*          estimator RCOND, and forward error bound FERR could be\n*          unreliable. If factorization fails with 0 0:  if INFO = i, and i is\n*                <= N:  U(i,i) is exactly zero.  The factorization has\n*                       been completed, but the factor U is exactly\n*                       singular, so the solution and error bounds\n*                       could not be computed. RCOND = 0 is returned.\n*                = N+1: U is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, rwork, info, a, af, ipiv, equed, r, c, b = NumRu::Lapack.cgesvx( fact, trans, a, b, [:af => af, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_fact = argv[0];
  rblapack_trans = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  if (argc == 9) {
    rblapack_af = argv[4];
    rblapack_ipiv = argv[5];
    rblapack_equed = argv[6];
    rblapack_r = argv[7];
    rblapack_c = argv[8];
  } else if (rblapack_options != Qnil) {
    rblapack_af = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("af")));
    rblapack_ipiv = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("ipiv")));
    rblapack_equed = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("equed")));
    rblapack_r = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("r")));
    rblapack_c = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("c")));
  } else {
    rblapack_af = Qnil;
    rblapack_ipiv = Qnil;
    rblapack_equed = Qnil;
    rblapack_r = Qnil;
    rblapack_c = Qnil;
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (rblapack_ipiv != Qnil) {
    if (!NA_IsNArray(rblapack_ipiv))
      rb_raise(rb_eArgError, "ipiv (option) must be NArray");
    if (NA_RANK(rblapack_ipiv) != 1)
      rb_raise(rb_eArgError, "rank of ipiv (option) must be %d", 1);
    if (NA_SHAPE0(rblapack_ipiv) != n)
      rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
    if (NA_TYPE(rblapack_ipiv) != NA_LINT)
      rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
    ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  }
  if (rblapack_r != Qnil) {
    if (!NA_IsNArray(rblapack_r))
      rb_raise(rb_eArgError, "r (option) must be NArray");
    if (NA_RANK(rblapack_r) != 1)
      rb_raise(rb_eArgError, "rank of r (option) must be %d", 1);
    if (NA_SHAPE0(rblapack_r) != n)
      rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of a");
    if (NA_TYPE(rblapack_r) != NA_SFLOAT)
      rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
    r = NA_PTR_TYPE(rblapack_r, real*);
  }
  ldx = n;
  trans = StringValueCStr(rblapack_trans)[0];
  if (rblapack_equed != Qnil) {
  equed = StringValueCStr(rblapack_equed)[0];
  }
  ldaf = n;
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (rblapack_c != Qnil) {
    if (!NA_IsNArray(rblapack_c))
      rb_raise(rb_eArgError, "c (option) must be NArray");
    if (NA_RANK(rblapack_c) != 1)
      rb_raise(rb_eArgError, "rank of c (option) must be %d", 1);
    if (NA_SHAPE0(rblapack_c) != n)
      rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
    if (NA_TYPE(rblapack_c) != NA_SFLOAT)
      rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
    c = NA_PTR_TYPE(rblapack_c, real*);
  }
  if (rblapack_af != Qnil) {
    if (!NA_IsNArray(rblapack_af))
      rb_raise(rb_eArgError, "af (option) must be NArray");
    if (NA_RANK(rblapack_af) != 2)
      rb_raise(rb_eArgError, "rank of af (option) must be %d", 2);
    if (NA_SHAPE0(rblapack_af) != ldaf)
      rb_raise(rb_eRuntimeError, "shape 0 of af must be n");
    if (NA_SHAPE1(rblapack_af) != n)
      rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
    if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
      rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
    af = NA_PTR_TYPE(rblapack_af, complex*);
  }
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[1];
    shape[0] = 2*n;
    rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  rwork = NA_PTR_TYPE(rblapack_rwork, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldaf;
    shape[1] = n;
    rblapack_af_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  af_out__ = NA_PTR_TYPE(rblapack_af_out__, complex*);
  if (rblapack_af != Qnil) {
    MEMCPY(af_out__, af, complex, NA_TOTAL(rblapack_af));
  }
  rblapack_af = rblapack_af_out__;
  af = af_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  if (rblapack_ipiv != Qnil) {
    MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  }
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_r_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  r_out__ = NA_PTR_TYPE(rblapack_r_out__, real*);
  if (rblapack_r != Qnil) {
    MEMCPY(r_out__, r, real, NA_TOTAL(rblapack_r));
  }
  rblapack_r = rblapack_r_out__;
  r = r_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  if (rblapack_c != Qnil) {
    MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  }
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(complex, (2*n));

  cgesvx_(&fact, &trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);

  free(work);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(13, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_rwork, rblapack_info, rblapack_a, rblapack_af, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b);
}

void
init_lapack_cgesvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgesvx", rblapack_cgesvx, -1);
}
ruby-lapack-1.7.2/ext/slatps.c0000644000175000017500000002373412502221014016037 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slatps_(char* uplo, char* trans, char* diag, char* normin, integer* n, real* ap, real* x, real* scale, real* cnorm, integer* info);


static VALUE
rblapack_slatps(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_normin;
  char normin; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_cnorm;
  real *cnorm; 
  VALUE rblapack_scale;
  real scale; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  real *x_out__;
  VALUE rblapack_cnorm_out__;
  real *cnorm_out__;

  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  scale, info, x, cnorm = NumRu::Lapack.slatps( uplo, trans, diag, normin, ap, x, cnorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, CNORM, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLATPS solves one of the triangular systems\n*\n*     A *x = s*b  or  A'*x = s*b\n*\n*  with scaling to prevent overflow, where A is an upper or lower\n*  triangular matrix stored in packed form.  Here A' denotes the\n*  transpose of A, x and b are n-element vectors, and s is a scaling\n*  factor, usually less than or equal to 1, chosen so that the\n*  components of x will be less than the overflow threshold.  If the\n*  unscaled problem will not cause overflow, the Level 2 BLAS routine\n*  STPSV is called. If the matrix A is singular (A(j,j) = 0 for some j),\n*  then s is set to 0 and a non-trivial solution to A*x = 0 is returned.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the matrix A is upper or lower triangular.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the operation applied to A.\n*          = 'N':  Solve A * x = s*b  (No transpose)\n*          = 'T':  Solve A'* x = s*b  (Transpose)\n*          = 'C':  Solve A'* x = s*b  (Conjugate transpose = Transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          Specifies whether or not the matrix A is unit triangular.\n*          = 'N':  Non-unit triangular\n*          = 'U':  Unit triangular\n*\n*  NORMIN  (input) CHARACTER*1\n*          Specifies whether CNORM has been set or not.\n*          = 'Y':  CNORM contains the column norms on entry\n*          = 'N':  CNORM is not set on entry.  On exit, the norms will\n*                  be computed and stored in CNORM.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input) REAL array, dimension (N*(N+1)/2)\n*          The upper or lower triangular matrix A, packed columnwise in\n*          a linear array.  The j-th column of A is stored in the array\n*          AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  X       (input/output) REAL array, dimension (N)\n*          On entry, the right hand side b of the triangular system.\n*          On exit, X is overwritten by the solution vector x.\n*\n*  SCALE   (output) REAL\n*          The scaling factor s for the triangular system\n*             A * x = s*b  or  A'* x = s*b.\n*          If SCALE = 0, the matrix A is singular or badly scaled, and\n*          the vector x is an exact or approximate solution to A*x = 0.\n*\n*  CNORM   (input or output) REAL array, dimension (N)\n*\n*          If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n*          contains the norm of the off-diagonal part of the j-th column\n*          of A.  If TRANS = 'N', CNORM(j) must be greater than or equal\n*          to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n*          must be greater than or equal to the 1-norm.\n*\n*          If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n*          returns the 1-norm of the offdiagonal part of the j-th column\n*          of A.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -k, the k-th argument had an illegal value\n*\n\n*  Further Details\n*  ======= =======\n*\n*  A rough bound on x is computed; if that is less than overflow, STPSV\n*  is called, otherwise, specific code is used which checks for possible\n*  overflow or divide-by-zero at every operation.\n*\n*  A columnwise scheme is used for solving A*x = b.  The basic algorithm\n*  if A is lower triangular is\n*\n*       x[1:n] := b[1:n]\n*       for j = 1, ..., n\n*            x(j) := x(j) / A(j,j)\n*            x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n*       end\n*\n*  Define bounds on the components of x after j iterations of the loop:\n*     M(j) = bound on x[1:j]\n*     G(j) = bound on x[j+1:n]\n*  Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n*  Then for iteration j+1 we have\n*     M(j+1) <= G(j) / | A(j+1,j+1) |\n*     G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n*            <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n*  where CNORM(j+1) is greater than or equal to the infinity-norm of\n*  column j+1 of A, not counting the diagonal.  Hence\n*\n*     G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n*                  1<=i<=j\n*  and\n*\n*     |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n*                                   1<=i< j\n*\n*  Since |x(j)| <= M(j), we use the Level 2 BLAS routine STPSV if the\n*  reciprocal of the largest M(j), j=1,..,n, is larger than\n*  max(underflow, 1/overflow).\n*\n*  The bound on x(j) is also used to determine when a step in the\n*  columnwise method can be performed without fear of overflow.  If\n*  the computed bound is greater than a large constant, x is scaled to\n*  prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n*  1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n*  Similarly, a row-wise scheme is used to solve A'*x = b.  The basic\n*  algorithm for A upper triangular is\n*\n*       for j = 1, ..., n\n*            x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n*       end\n*\n*  We simultaneously compute two bounds\n*       G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n*       M(j) = bound on x(i), 1<=i<=j\n*\n*  The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n*  add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n*  Then the bound on x(j) is\n*\n*       M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n*            <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n*                      1<=i<=j\n*\n*  and we can safely call STPSV if 1/M(n) and 1/G(n) are both greater\n*  than max(underflow, 1/overflow).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, info, x, cnorm = NumRu::Lapack.slatps( uplo, trans, diag, normin, ap, x, cnorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_normin = argv[3];
  rblapack_ap = argv[4];
  rblapack_x = argv[5];
  rblapack_cnorm = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_cnorm))
    rb_raise(rb_eArgError, "cnorm (7th argument) must be NArray");
  if (NA_RANK(rblapack_cnorm) != 1)
    rb_raise(rb_eArgError, "rank of cnorm (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_cnorm) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of cnorm must be the same as shape 0 of x");
  if (NA_TYPE(rblapack_cnorm) != NA_SFLOAT)
    rblapack_cnorm = na_change_type(rblapack_cnorm, NA_SFLOAT);
  cnorm = NA_PTR_TYPE(rblapack_cnorm, real*);
  normin = StringValueCStr(rblapack_normin)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_cnorm_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  cnorm_out__ = NA_PTR_TYPE(rblapack_cnorm_out__, real*);
  MEMCPY(cnorm_out__, cnorm, real, NA_TOTAL(rblapack_cnorm));
  rblapack_cnorm = rblapack_cnorm_out__;
  cnorm = cnorm_out__;

  slatps_(&uplo, &trans, &diag, &normin, &n, ap, x, &scale, cnorm, &info);

  rblapack_scale = rb_float_new((double)scale);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_scale, rblapack_info, rblapack_x, rblapack_cnorm);
}

void
init_lapack_slatps(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slatps", rblapack_slatps, -1);
}
ruby-lapack-1.7.2/ext/zlaqhp.c0000644000175000017500000001202612502221024016021 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlaqhp_(char* uplo, integer* n, doublecomplex* ap, doublereal* s, doublereal* scond, doublereal* amax, char* equed);


static VALUE
rblapack_zlaqhp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_scond;
  doublereal scond; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_ap_out__;
  doublecomplex *ap_out__;

  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  equed, ap = NumRu::Lapack.zlaqhp( uplo, ap, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAQHP( UPLO, N, AP, S, SCOND, AMAX, EQUED )\n\n*  Purpose\n*  =======\n*\n*  ZLAQHP equilibrates a Hermitian matrix A using the scaling factors\n*  in the vector S.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          Hermitian matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, the equilibrated matrix:  diag(S) * A * diag(S), in\n*          the same storage format as A.\n*\n*  S       (input) DOUBLE PRECISION array, dimension (N)\n*          The scale factors for A.\n*\n*  SCOND   (input) DOUBLE PRECISION\n*          Ratio of the smallest S(i) to the largest S(i).\n*\n*  AMAX    (input) DOUBLE PRECISION\n*          Absolute value of largest matrix entry.\n*\n*  EQUED   (output) CHARACTER*1\n*          Specifies whether or not equilibration was done.\n*          = 'N':  No equilibration.\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*\n*  Internal Parameters\n*  ===================\n*\n*  THRESH is a threshold value used to decide if scaling should be done\n*  based on the ratio of the scaling factors.  If SCOND < THRESH,\n*  scaling is done.\n*\n*  LARGE and SMALL are threshold values used to decide if scaling should\n*  be done based on the absolute size of the largest matrix element.\n*  If AMAX > LARGE or AMAX < SMALL, scaling is done.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  equed, ap = NumRu::Lapack.zlaqhp( uplo, ap, s, scond, amax, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_s = argv[2];
  rblapack_scond = argv[3];
  rblapack_amax = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (3th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_s);
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  amax = NUM2DBL(rblapack_amax);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  scond = NUM2DBL(rblapack_scond);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
  MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  zlaqhp_(&uplo, &n, ap, s, &scond, &amax, &equed);

  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(2, rblapack_equed, rblapack_ap);
}

void
init_lapack_zlaqhp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlaqhp", rblapack_zlaqhp, -1);
}
ruby-lapack-1.7.2/ext/slaqp2.c0000644000175000017500000001715412502221023015732 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaqp2_(integer* m, integer* n, integer* offset, real* a, integer* lda, integer* jpvt, real* tau, real* vn1, real* vn2, real* work);


static VALUE
rblapack_slaqp2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_offset;
  integer offset; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_jpvt;
  integer *jpvt; 
  VALUE rblapack_vn1;
  real *vn1; 
  VALUE rblapack_vn2;
  real *vn2; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_jpvt_out__;
  integer *jpvt_out__;
  VALUE rblapack_vn1_out__;
  real *vn1_out__;
  VALUE rblapack_vn2_out__;
  real *vn2_out__;
  real *work;

  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, a, jpvt, vn1, vn2 = NumRu::Lapack.slaqp2( m, offset, a, jpvt, vn1, vn2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, WORK )\n\n*  Purpose\n*  =======\n*\n*  SLAQP2 computes a QR factorization with column pivoting of\n*  the block A(OFFSET+1:M,1:N).\n*  The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\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*  OFFSET  (input) INTEGER\n*          The number of rows of the matrix A that must be pivoted\n*          but no factorized. OFFSET >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, the upper triangle of block A(OFFSET+1:M,1:N) is \n*          the triangular factor obtained; the elements in block \n*          A(OFFSET+1:M,1:N) below the diagonal, together with the \n*          array TAU, represent the orthogonal matrix Q as a product of\n*          elementary reflectors. Block A(1:OFFSET,1:N) has been\n*          accordingly pivoted, but no factorized.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  JPVT    (input/output) INTEGER array, dimension (N)\n*          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n*          to the front of A*P (a leading column); if JPVT(i) = 0,\n*          the i-th column of A is a free column.\n*          On exit, if JPVT(i) = k, then the i-th column of A*P\n*          was the k-th column of A.\n*\n*  TAU     (output) REAL array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors.\n*\n*  VN1     (input/output) REAL array, dimension (N)\n*          The vector with the partial column norms.\n*\n*  VN2     (input/output) REAL array, dimension (N)\n*          The vector with the exact column norms.\n*\n*  WORK    (workspace) REAL array, dimension (N)\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n*    X. Sun, Computer Science Dept., Duke University, USA\n*\n*  Partial column norm updating strategy modified by\n*    Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n*    University of Zagreb, Croatia.\n*     June 2010\n*  For more details see LAPACK Working Note 176.\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, a, jpvt, vn1, vn2 = NumRu::Lapack.slaqp2( m, offset, a, jpvt, vn1, vn2, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_m = argv[0];
  rblapack_offset = argv[1];
  rblapack_a = argv[2];
  rblapack_jpvt = argv[3];
  rblapack_vn1 = argv[4];
  rblapack_vn2 = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_vn1))
    rb_raise(rb_eArgError, "vn1 (5th argument) must be NArray");
  if (NA_RANK(rblapack_vn1) != 1)
    rb_raise(rb_eArgError, "rank of vn1 (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_vn1) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of vn1 must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_vn1) != NA_SFLOAT)
    rblapack_vn1 = na_change_type(rblapack_vn1, NA_SFLOAT);
  vn1 = NA_PTR_TYPE(rblapack_vn1, real*);
  offset = NUM2INT(rblapack_offset);
  if (!NA_IsNArray(rblapack_vn2))
    rb_raise(rb_eArgError, "vn2 (6th argument) must be NArray");
  if (NA_RANK(rblapack_vn2) != 1)
    rb_raise(rb_eArgError, "rank of vn2 (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_vn2) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of vn2 must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_vn2) != NA_SFLOAT)
    rblapack_vn2 = na_change_type(rblapack_vn2, NA_SFLOAT);
  vn2 = NA_PTR_TYPE(rblapack_vn2, real*);
  if (!NA_IsNArray(rblapack_jpvt))
    rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
  if (NA_RANK(rblapack_jpvt) != 1)
    rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_jpvt) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_jpvt) != NA_LINT)
    rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
  jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
  MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
  rblapack_jpvt = rblapack_jpvt_out__;
  jpvt = jpvt_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_vn1_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  vn1_out__ = NA_PTR_TYPE(rblapack_vn1_out__, real*);
  MEMCPY(vn1_out__, vn1, real, NA_TOTAL(rblapack_vn1));
  rblapack_vn1 = rblapack_vn1_out__;
  vn1 = vn1_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_vn2_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  vn2_out__ = NA_PTR_TYPE(rblapack_vn2_out__, real*);
  MEMCPY(vn2_out__, vn2, real, NA_TOTAL(rblapack_vn2));
  rblapack_vn2 = rblapack_vn2_out__;
  vn2 = vn2_out__;
  work = ALLOC_N(real, (n));

  slaqp2_(&m, &n, &offset, a, &lda, jpvt, tau, vn1, vn2, work);

  free(work);
  return rb_ary_new3(5, rblapack_tau, rblapack_a, rblapack_jpvt, rblapack_vn1, rblapack_vn2);
}

void
init_lapack_slaqp2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaqp2", rblapack_slaqp2, -1);
}
ruby-lapack-1.7.2/ext/clatzm.c0000644000175000017500000001631412502221021016015 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clatzm_(char* side, integer* m, integer* n, complex* v, integer* incv, complex* tau, complex* c1, complex* c2, integer* ldc, complex* work);


static VALUE
rblapack_clatzm(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_v;
  complex *v; 
  VALUE rblapack_incv;
  integer incv; 
  VALUE rblapack_tau;
  complex tau; 
  VALUE rblapack_c1;
  complex *c1; 
  VALUE rblapack_c2;
  complex *c2; 
  VALUE rblapack_c1_out__;
  complex *c1_out__;
  VALUE rblapack_c2_out__;
  complex *c2_out__;
  complex *work;

  integer ldc;

  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  c1, c2 = NumRu::Lapack.clatzm( side, m, n, v, incv, tau, c1, c2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK )\n\n*  Purpose\n*  =======\n*\n*  This routine is deprecated and has been replaced by routine CUNMRZ.\n*\n*  CLATZM applies a Householder matrix generated by CTZRQF to a matrix.\n*\n*  Let P = I - tau*u*u',   u = ( 1 ),\n*                              ( v )\n*  where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if\n*  SIDE = 'R'.\n*\n*  If SIDE equals 'L', let\n*         C = [ C1 ] 1\n*             [ C2 ] m-1\n*               n\n*  Then C is overwritten by P*C.\n*\n*  If SIDE equals 'R', let\n*         C = [ C1, C2 ] m\n*                1  n-1\n*  Then C is overwritten by C*P.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': form P * C\n*          = 'R': form C * P\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C.\n*\n*  V       (input) COMPLEX array, dimension\n*                  (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n*                  (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n*          The vector v in the representation of P. V is not used\n*          if TAU = 0.\n*\n*  INCV    (input) INTEGER\n*          The increment between elements of v. INCV <> 0\n*\n*  TAU     (input) COMPLEX\n*          The value tau in the representation of P.\n*\n*  C1      (input/output) COMPLEX array, dimension\n*                         (LDC,N) if SIDE = 'L'\n*                         (M,1)   if SIDE = 'R'\n*          On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1\n*          if SIDE = 'R'.\n*\n*          On exit, the first row of P*C if SIDE = 'L', or the first\n*          column of C*P if SIDE = 'R'.\n*\n*  C2      (input/output) COMPLEX array, dimension\n*                         (LDC, N)   if SIDE = 'L'\n*                         (LDC, N-1) if SIDE = 'R'\n*          On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the\n*          m x (n - 1) matrix C2 if SIDE = 'R'.\n*\n*          On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P\n*          if SIDE = 'R'.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the arrays C1 and C2.\n*          LDC >= max(1,M).\n*\n*  WORK    (workspace) COMPLEX array, dimension\n*                      (N) if SIDE = 'L'\n*                      (M) if SIDE = 'R'\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c1, c2 = NumRu::Lapack.clatzm( side, m, n, v, incv, tau, c1, c2, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_side = argv[0];
  rblapack_m = argv[1];
  rblapack_n = argv[2];
  rblapack_v = argv[3];
  rblapack_incv = argv[4];
  rblapack_tau = argv[5];
  rblapack_c1 = argv[6];
  rblapack_c2 = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  n = NUM2INT(rblapack_n);
  incv = NUM2INT(rblapack_incv);
  if (!NA_IsNArray(rblapack_c2))
    rb_raise(rb_eArgError, "c2 (8th argument) must be NArray");
  if (NA_RANK(rblapack_c2) != 2)
    rb_raise(rb_eArgError, "rank of c2 (8th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c2);
  if (NA_SHAPE1(rblapack_c2) != (lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0))
    rb_raise(rb_eRuntimeError, "shape 1 of c2 must be %d", lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0);
  if (NA_TYPE(rblapack_c2) != NA_SCOMPLEX)
    rblapack_c2 = na_change_type(rblapack_c2, NA_SCOMPLEX);
  c2 = NA_PTR_TYPE(rblapack_c2, complex*);
  m = NUM2INT(rblapack_m);
  tau.r = (real)NUM2DBL(rb_funcall(rblapack_tau, rb_intern("real"), 0));
  tau.i = (real)NUM2DBL(rb_funcall(rblapack_tau, rb_intern("imag"), 0));
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (4th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 1)
    rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_v) != (1 + (m-1)*abs(incv)))
    rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1 + (m-1)*abs(incv));
  if (NA_TYPE(rblapack_v) != NA_SCOMPLEX)
    rblapack_v = na_change_type(rblapack_v, NA_SCOMPLEX);
  v = NA_PTR_TYPE(rblapack_v, complex*);
  if (!NA_IsNArray(rblapack_c1))
    rb_raise(rb_eArgError, "c1 (7th argument) must be NArray");
  if (NA_RANK(rblapack_c1) != 2)
    rb_raise(rb_eArgError, "rank of c1 (7th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_c1) != (lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0))
    rb_raise(rb_eRuntimeError, "shape 0 of c1 must be %d", lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0);
  if (NA_SHAPE1(rblapack_c1) != (lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0))
    rb_raise(rb_eRuntimeError, "shape 1 of c1 must be %d", lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0);
  if (NA_TYPE(rblapack_c1) != NA_SCOMPLEX)
    rblapack_c1 = na_change_type(rblapack_c1, NA_SCOMPLEX);
  c1 = NA_PTR_TYPE(rblapack_c1, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0;
    shape[1] = lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0;
    rblapack_c1_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  c1_out__ = NA_PTR_TYPE(rblapack_c1_out__, complex*);
  MEMCPY(c1_out__, c1, complex, NA_TOTAL(rblapack_c1));
  rblapack_c1 = rblapack_c1_out__;
  c1 = c1_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0;
    rblapack_c2_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  c2_out__ = NA_PTR_TYPE(rblapack_c2_out__, complex*);
  MEMCPY(c2_out__, c2, complex, NA_TOTAL(rblapack_c2));
  rblapack_c2 = rblapack_c2_out__;
  c2 = c2_out__;
  work = ALLOC_N(complex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  clatzm_(&side, &m, &n, v, &incv, &tau, c1, c2, &ldc, work);

  free(work);
  return rb_ary_new3(2, rblapack_c1, rblapack_c2);
}

void
init_lapack_clatzm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clatzm", rblapack_clatzm, -1);
}
ruby-lapack-1.7.2/ext/claqr0.c0000644000175000017500000002521512502221020015704 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID claqr0_(logical* wantt, logical* wantz, integer* n, integer* ilo, integer* ihi, complex* h, integer* ldh, complex* w, integer* iloz, integer* ihiz, complex* z, integer* ldz, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_claqr0(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantt;
  logical wantt; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_h;
  complex *h; 
  VALUE rblapack_iloz;
  integer iloz; 
  VALUE rblapack_ihiz;
  integer ihiz; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_w;
  complex *w; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_h_out__;
  complex *h_out__;
  VALUE rblapack_z_out__;
  complex *z_out__;

  integer ldh;
  integer n;
  integer ldz;
  integer ihi;

  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  w, work, info, h, z = NumRu::Lapack.claqr0( wantt, wantz, ilo, h, iloz, ihiz, z, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     CLAQR0 computes the eigenvalues of a Hessenberg matrix H\n*     and, optionally, the matrices T and Z from the Schur decomposition\n*     H = Z T Z**H, where T is an upper triangular matrix (the\n*     Schur form), and Z is the unitary matrix of Schur vectors.\n*\n*     Optionally Z may be postmultiplied into an input unitary\n*     matrix Q so that this routine can give the Schur factorization\n*     of a matrix A which has been reduced to the Hessenberg form H\n*     by the unitary matrix Q:  A = Q*H*Q**H = (QZ)*H*(QZ)**H.\n*\n\n*     Arguments\n*     =========\n*\n*     WANTT   (input) LOGICAL\n*          = .TRUE. : the full Schur form T is required;\n*          = .FALSE.: only eigenvalues are required.\n*\n*     WANTZ   (input) LOGICAL\n*          = .TRUE. : the matrix of Schur vectors Z is required;\n*          = .FALSE.: Schur vectors are not required.\n*\n*     N     (input) INTEGER\n*           The order of the matrix H.  N .GE. 0.\n*\n*     ILO   (input) INTEGER\n*     IHI   (input) INTEGER\n*           It is assumed that H is already upper triangular in rows\n*           and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n*           H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n*           previous call to CGEBAL, and then passed to CGEHRD when the\n*           matrix output by CGEBAL is reduced to Hessenberg form.\n*           Otherwise, ILO and IHI should be set to 1 and N,\n*           respectively.  If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n*           If N = 0, then ILO = 1 and IHI = 0.\n*\n*     H     (input/output) COMPLEX array, dimension (LDH,N)\n*           On entry, the upper Hessenberg matrix H.\n*           On exit, if INFO = 0 and WANTT is .TRUE., then H\n*           contains the upper triangular matrix T from the Schur\n*           decomposition (the Schur form). If INFO = 0 and WANT is\n*           .FALSE., then the contents of H are unspecified on exit.\n*           (The output value of H when INFO.GT.0 is given under the\n*           description of INFO below.)\n*\n*           This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n*           j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n*\n*     LDH   (input) INTEGER\n*           The leading dimension of the array H. LDH .GE. max(1,N).\n*\n*     W        (output) COMPLEX array, dimension (N)\n*           The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored\n*           in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are\n*           stored in the same order as on the diagonal of the Schur\n*           form returned in H, with W(i) = H(i,i).\n*\n*     Z     (input/output) COMPLEX array, dimension (LDZ,IHI)\n*           If WANTZ is .FALSE., then Z is not referenced.\n*           If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n*           replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n*           orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n*           (The output value of Z when INFO.GT.0 is given under\n*           the description of INFO below.)\n*\n*     LDZ   (input) INTEGER\n*           The leading dimension of the array Z.  if WANTZ is .TRUE.\n*           then LDZ.GE.MAX(1,IHIZ).  Otherwize, LDZ.GE.1.\n*\n*     WORK  (workspace/output) COMPLEX array, dimension LWORK\n*           On exit, if LWORK = -1, WORK(1) returns an estimate of\n*           the optimal value for LWORK.\n*\n*     LWORK (input) INTEGER\n*           The dimension of the array WORK.  LWORK .GE. max(1,N)\n*           is sufficient, but LWORK typically as large as 6*N may\n*           be required for optimal performance.  A workspace query\n*           to determine the optimal workspace size is recommended.\n*\n*           If LWORK = -1, then CLAQR0 does a workspace query.\n*           In this case, CLAQR0 checks the input parameters and\n*           estimates the optimal workspace size for the given\n*           values of N, ILO and IHI.  The estimate is returned\n*           in WORK(1).  No error message related to LWORK is\n*           issued by XERBLA.  Neither H nor Z are accessed.\n*\n*\n*     INFO  (output) INTEGER\n*             =  0:  successful exit\n*           .GT. 0:  if INFO = i, CLAQR0 failed to compute all of\n*                the eigenvalues.  Elements 1:ilo-1 and i+1:n of WR\n*                and WI contain those eigenvalues which have been\n*                successfully computed.  (Failures are rare.)\n*\n*                If INFO .GT. 0 and WANT is .FALSE., then on exit,\n*                the remaining unconverged eigenvalues are the eigen-\n*                values of the upper Hessenberg matrix rows and\n*                columns ILO through INFO of the final, output\n*                value of H.\n*\n*                If INFO .GT. 0 and WANTT is .TRUE., then on exit\n*\n*           (*)  (initial value of H)*U  = U*(final value of H)\n*\n*                where U is a unitary matrix.  The final\n*                value of  H is upper Hessenberg and triangular in\n*                rows and columns INFO+1 through IHI.\n*\n*                If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n*\n*                  (final value of Z(ILO:IHI,ILOZ:IHIZ)\n*                   =  (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n*\n*                where U is the unitary matrix in (*) (regard-\n*                less of the value of WANTT.)\n*\n*                If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n*                accessed.\n*\n\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n*     References:\n*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n*       Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n*       Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n*       929--947, 2002.\n*\n*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n*       Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n*       of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n*     ================================================================\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, work, info, h, z = NumRu::Lapack.claqr0( wantt, wantz, ilo, h, iloz, ihiz, z, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_wantt = argv[0];
  rblapack_wantz = argv[1];
  rblapack_ilo = argv[2];
  rblapack_h = argv[3];
  rblapack_iloz = argv[4];
  rblapack_ihiz = argv[5];
  rblapack_z = argv[6];
  if (argc == 8) {
    rblapack_lwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  wantt = (rblapack_wantt == Qtrue);
  ilo = NUM2INT(rblapack_ilo);
  iloz = NUM2INT(rblapack_iloz);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (7th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  ihi = NA_SHAPE1(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, complex*);
  wantz = (rblapack_wantz == Qtrue);
  ihiz = NUM2INT(rblapack_ihiz);
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (4th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (4th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_SCOMPLEX)
    rblapack_h = na_change_type(rblapack_h, NA_SCOMPLEX);
  h = NA_PTR_TYPE(rblapack_h, complex*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, complex*);
  MEMCPY(h_out__, h, complex, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = ihi;
    rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
  MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  claqr0_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, w, &iloz, &ihiz, z, &ldz, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_w, rblapack_work, rblapack_info, rblapack_h, rblapack_z);
}

void
init_lapack_claqr0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "claqr0", rblapack_claqr0, -1);
}
ruby-lapack-1.7.2/ext/zhegvx.c0000644000175000017500000003305112502221026016040 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhegvx_(integer* itype, char* jobz, char* range, char* uplo, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublecomplex* z, integer* ldz, doublecomplex* work, integer* lwork, doublereal* rwork, integer* iwork, integer* ifail, integer* info);


static VALUE
rblapack_zhegvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_vl;
  doublereal vl; 
  VALUE rblapack_vu;
  doublereal vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  doublereal abstol; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_ifail;
  integer *ifail; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  doublereal *rwork;
  integer *iwork;

  integer lda;
  integer n;
  integer ldb;
  integer ldz;

  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  m, w, z, work, ifail, info, a, b = NumRu::Lapack.zhegvx( itype, jobz, range, uplo, a, b, vl, vu, il, iu, abstol, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHEGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHEGVX computes selected eigenvalues, and optionally, eigenvectors\n*  of a complex generalized Hermitian-definite eigenproblem, of the form\n*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A and\n*  B are assumed to be Hermitian and B is also positive definite.\n*  Eigenvalues and eigenvectors can be selected by specifying either a\n*  range of values or a range of indices for the desired eigenvalues.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          Specifies the problem type to be solved:\n*          = 1:  A*x = (lambda)*B*x\n*          = 2:  A*B*x = (lambda)*x\n*          = 3:  B*A*x = (lambda)*x\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found.\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found.\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n**\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA, N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of A contains the\n*          upper triangular part of the matrix A.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of A contains\n*          the lower triangular part of the matrix A.\n*\n*          On exit,  the lower triangle (if UPLO='L') or the upper\n*          triangle (if UPLO='U') of A, including the diagonal, is\n*          destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB, N)\n*          On entry, the Hermitian matrix B.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of B contains the\n*          upper triangular part of the matrix B.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of B contains\n*          the lower triangular part of the matrix B.\n*\n*          On exit, if INFO <= N, the part of B containing the matrix is\n*          overwritten by the triangular factor U or L from the Cholesky\n*          factorization B = U**H*U or B = L*L**H.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  VL      (input) DOUBLE PRECISION\n*  VU      (input) DOUBLE PRECISION\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) DOUBLE PRECISION\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less than\n*          or equal to zero, then  EPS*|T|  will be used in its place,\n*          where |T| is the 1-norm of the tridiagonal matrix obtained\n*          by reducing A to tridiagonal form.\n*\n*          Eigenvalues will be computed most accurately when ABSTOL is\n*          set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n*          If this routine returns with INFO>0, indicating that some\n*          eigenvectors did not converge, try setting ABSTOL to\n*          2*DLAMCH('S').\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          The first M elements contain the selected\n*          eigenvalues in ascending order.\n*\n*  Z       (output) COMPLEX*16 array, dimension (LDZ, max(1,M))\n*          If JOBZ = 'N', then Z is not referenced.\n*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix A\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          The eigenvectors are normalized as follows:\n*          if ITYPE = 1 or 2, Z**T*B*Z = I;\n*          if ITYPE = 3, Z**T*inv(B)*Z = I.\n*\n*          If an eigenvector fails to converge, then that column of Z\n*          contains the latest approximation to the eigenvector, and the\n*          index of the eigenvector is returned in IFAIL.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of the array WORK.  LWORK >= max(1,2*N).\n*          For optimal efficiency, LWORK >= (NB+1)*N,\n*          where NB is the blocksize for ZHETRD returned by ILAENV.\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*  RWORK   (workspace) DOUBLE PRECISION array, dimension (7*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (5*N)\n*\n*  IFAIL   (output) INTEGER array, dimension (N)\n*          If JOBZ = 'V', then if INFO = 0, the first M elements of\n*          IFAIL are zero.  If INFO > 0, then IFAIL contains the\n*          indices of the eigenvectors that failed to converge.\n*          If JOBZ = 'N', then IFAIL is not referenced.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  ZPOTRF or ZHEEVX returned an error code:\n*             <= N:  if INFO = i, ZHEEVX failed to converge;\n*                    i eigenvectors failed to converge.  Their indices\n*                    are stored in array IFAIL.\n*             > N:   if INFO = N + i, for 1 <= i <= N, then the leading\n*                    minor of order i of B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, work, ifail, info, a, b = NumRu::Lapack.zhegvx( itype, jobz, range, uplo, a, b, vl, vu, il, iu, abstol, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 11 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
  rblapack_itype = argv[0];
  rblapack_jobz = argv[1];
  rblapack_range = argv[2];
  rblapack_uplo = argv[3];
  rblapack_a = argv[4];
  rblapack_b = argv[5];
  rblapack_vl = argv[6];
  rblapack_vu = argv[7];
  rblapack_il = argv[8];
  rblapack_iu = argv[9];
  rblapack_abstol = argv[10];
  if (argc == 12) {
    rblapack_lwork = argv[11];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  itype = NUM2INT(rblapack_itype);
  range = StringValueCStr(rblapack_range)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  vl = NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  abstol = NUM2DBL(rblapack_abstol);
  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  iu = NUM2INT(rblapack_iu);
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (rblapack_lwork == Qnil)
    lwork = 2*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  vu = NUM2DBL(rblapack_vu);
  m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = lsame_(&jobz,"N") ? 0 : ldz;
    shape[1] = lsame_(&jobz,"N") ? 0 : MAX(1,m);
    rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  rwork = ALLOC_N(doublereal, (7*n));
  iwork = ALLOC_N(integer, (5*n));

  zhegvx_(&itype, &jobz, &range, &uplo, &n, a, &lda, b, &ldb, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, &lwork, rwork, iwork, ifail, &info);

  free(rwork);
  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_m, rblapack_w, rblapack_z, rblapack_work, rblapack_ifail, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_zhegvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhegvx", rblapack_zhegvx, -1);
}
ruby-lapack-1.7.2/ext/dsytf2.c0000644000175000017500000001631312502221024015740 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsytf2_(char* uplo, integer* n, doublereal* a, integer* lda, integer* ipiv, integer* info);


static VALUE
rblapack_dsytf2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  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  ipiv, info, a = NumRu::Lapack.dsytf2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSYTF2 computes the factorization of a real symmetric matrix A using\n*  the Bunch-Kaufman diagonal pivoting method:\n*\n*     A = U*D*U'  or  A = L*D*L'\n*\n*  where U (or L) is a product of permutation and unit upper (lower)\n*  triangular matrices, U' is the transpose of U, and D is symmetric and\n*  block diagonal with 1-by-1 and 2-by-2 diagonal blocks.\n*\n*  This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored:\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          n-by-n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n-by-n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L (see below for further details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D.\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*          > 0: if INFO = k, D(k,k) is exactly zero.  The factorization\n*               has been completed, but the block diagonal matrix D is\n*               exactly singular, and division by zero will occur if it\n*               is used to solve a system of equations.\n*\n\n*  Further Details\n*  ===============\n*\n*  09-29-06 - patch from\n*    Bobby Cheng, MathWorks\n*\n*    Replace l.204 and l.372\n*         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN\n*    by\n*         IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN\n*\n*  01-01-96 - Based on modifications by\n*    J. Lewis, Boeing Computer Services Company\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*  1-96 - Based on modifications by J. Lewis, Boeing Computer Services\n*         Company\n*\n*  If UPLO = 'U', then A = U*D*U', where\n*     U = P(n)*U(n)* ... *P(k)U(k)* ...,\n*  i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n*  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    v    0   )   k-s\n*     U(k) =  (   0    I    0   )   s\n*             (   0    0    I   )   n-k\n*                k-s   s   n-k\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n*  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n*  and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n*  If UPLO = 'L', then A = L*D*L', where\n*     L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n*  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n*  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    0     0   )  k-1\n*     L(k) =  (   0    I     0   )  s\n*             (   0    v     I   )  n-k-s+1\n*                k-1   s  n-k-s+1\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n*  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n*  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, a = NumRu::Lapack.dsytf2( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t 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__;

  dsytf2_(&uplo, &n, a, &lda, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_a);
}

void
init_lapack_dsytf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsytf2", rblapack_dsytf2, -1);
}
ruby-lapack-1.7.2/ext/dgelq2.c0000644000175000017500000001030312502221017015676 0ustar  uwabamiuwabami#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;
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t 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, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgelq2", rblapack_dgelq2, -1);
}
ruby-lapack-1.7.2/ext/dgtsv.c0000644000175000017500000001540612502221012015653 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgtsv_(integer* n, integer* nrhs, doublereal* dl, doublereal* d, doublereal* du, doublereal* b, integer* ldb, integer* info);


static VALUE
rblapack_dgtsv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_dl;
  doublereal *dl; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_du;
  doublereal *du; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_dl_out__;
  doublereal *dl_out__;
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_du_out__;
  doublereal *du_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;

  integer n;
  integer ldb;
  integer nrhs;

  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  info, dl, d, du, b = NumRu::Lapack.dgtsv( dl, d, du, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGTSV  solves the equation\n*\n*     A*X = B,\n*\n*  where A is an n by n tridiagonal matrix, by Gaussian elimination with\n*  partial pivoting.\n*\n*  Note that the equation  A'*X = B  may be solved by interchanging the\n*  order of the arguments DU and DL.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  DL      (input/output) DOUBLE PRECISION array, dimension (N-1)\n*          On entry, DL must contain the (n-1) sub-diagonal elements of\n*          A.\n*\n*          On exit, DL is overwritten by the (n-2) elements of the\n*          second super-diagonal of the upper triangular matrix U from\n*          the LU factorization of A, in DL(1), ..., DL(n-2).\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, D must contain the diagonal elements of A.\n*\n*          On exit, D is overwritten by the n diagonal elements of U.\n*\n*  DU      (input/output) DOUBLE PRECISION array, dimension (N-1)\n*          On entry, DU must contain the (n-1) super-diagonal elements\n*          of A.\n*\n*          On exit, DU is overwritten by the (n-1) elements of the first\n*          super-diagonal of U.\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the N by NRHS matrix of right hand side matrix B.\n*          On exit, if INFO = 0, the N by NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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, U(i,i) is exactly zero, and the solution\n*               has not been computed.  The factorization has not been\n*               completed unless i = N.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, dl, d, du, b = NumRu::Lapack.dgtsv( dl, d, du, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_dl = argv[0];
  rblapack_d = argv[1];
  rblapack_du = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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 (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (1th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (1th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_DFLOAT)
    rblapack_dl = na_change_type(rblapack_dl, NA_DFLOAT);
  dl = NA_PTR_TYPE(rblapack_dl, doublereal*);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (3th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_DFLOAT)
    rblapack_du = na_change_type(rblapack_du, NA_DFLOAT);
  du = NA_PTR_TYPE(rblapack_du, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_dl_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  dl_out__ = NA_PTR_TYPE(rblapack_dl_out__, doublereal*);
  MEMCPY(dl_out__, dl, doublereal, NA_TOTAL(rblapack_dl));
  rblapack_dl = rblapack_dl_out__;
  dl = dl_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_du_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  du_out__ = NA_PTR_TYPE(rblapack_du_out__, doublereal*);
  MEMCPY(du_out__, du, doublereal, NA_TOTAL(rblapack_du));
  rblapack_du = rblapack_du_out__;
  du = du_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dgtsv_(&n, &nrhs, dl, d, du, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_info, rblapack_dl, rblapack_d, rblapack_du, rblapack_b);
}

void
init_lapack_dgtsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgtsv", rblapack_dgtsv, -1);
}
ruby-lapack-1.7.2/ext/zporfsx.c0000644000175000017500000005056312502221026016247 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zporfsx_(char* uplo, char* equed, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, doublereal* s, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zporfsx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_params;
  doublereal *params; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_err_bnds_norm;
  doublereal *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  doublereal *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_s_out__;
  doublereal *s_out__;
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;
  VALUE rblapack_params_out__;
  doublereal *params_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;
  integer nparams;
  integer n_err_bnds;

  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  rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.zporfsx( uplo, equed, a, af, s, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     ZPORFSX improves the computed solution to a system of linear\n*     equations when the coefficient matrix is symmetric positive\n*     definite, and provides error bounds and backward error estimates\n*     for the solution.  In addition to normwise error bound, the code\n*     provides maximum componentwise error bound if possible.  See\n*     comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n*     error bounds.\n*\n*     The original system of linear equations may have been equilibrated\n*     before calling this routine, as described by arguments EQUED and S\n*     below. In this case, the solution and error bounds returned are\n*     for the original unequilibrated system.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     EQUED   (input) CHARACTER*1\n*     Specifies the form of equilibration that was done to A\n*     before calling this routine. This is needed to compute\n*     the solution and error bounds correctly.\n*       = 'N':  No equilibration\n*       = 'Y':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(S) * A * diag(S).\n*               The right hand side B has been changed accordingly.\n*\n*     N       (input) INTEGER\n*     The order of the matrix A.  N >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     A       (input) COMPLEX*16 array, dimension (LDA,N)\n*     The symmetric matrix A.  If UPLO = 'U', the leading N-by-N\n*     upper triangular part of A contains the upper triangular part\n*     of the matrix A, and the strictly lower triangular part of A\n*     is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*     triangular part of A contains the lower triangular part of\n*     the matrix A, and the strictly upper triangular part of A is\n*     not referenced.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX*16 array, dimension (LDAF,N)\n*     The triangular factor U or L from the Cholesky factorization\n*     A = U**T*U or A = L*L**T, as computed by DPOTRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     S       (input or output) DOUBLE PRECISION array, dimension (N)\n*     The row scale factors for A.  If EQUED = 'Y', A is multiplied on\n*     the left and right by diag(S).  S is an input argument if FACT =\n*     'F'; otherwise, S is an output argument.  If FACT = 'F' and EQUED\n*     = 'Y', each element of S must be positive.  If S is output, each\n*     element of S is a power of the radix. If S is input, each element\n*     of S should be a power of the radix to ensure a reliable solution\n*     and error estimates. Scaling by powers of the radix does not cause\n*     rounding errors unless the result underflows or overflows.\n*     Rounding errors during scaling lead to refining with a matrix that\n*     is not equivalent to the input matrix, producing error estimates\n*     that may not be reliable.\n*\n*     B       (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*     The right hand side matrix B.\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (input/output) COMPLEX*16 array, dimension (LDX,NRHS)\n*     On entry, the solution matrix X, as computed by DGETRS.\n*     On exit, the improved solution matrix X.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) DOUBLE PRECISION\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*     Componentwise relative backward error.  This is the\n*     componentwise relative backward error of each solution vector X(j)\n*     (i.e., the smallest relative change in any element of A or B that\n*     makes X(j) an exact solution).\n*\n*     N_ERR_BNDS (input) INTEGER\n*     Number of error bounds to return for each right hand side\n*     and each type (normwise or componentwise).  See ERR_BNDS_NORM and\n*     ERR_BNDS_COMP below.\n*\n*     ERR_BNDS_NORM  (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * dlamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * dlamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * dlamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * dlamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * dlamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * dlamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     NPARAMS (input) INTEGER\n*     Specifies the number of parameters set in PARAMS.  If .LE. 0, the\n*     PARAMS array is never referenced and default values are used.\n*\n*     PARAMS  (input / output) DOUBLE PRECISION array, dimension NPARAMS\n*     Specifies algorithm parameters.  If an entry is .LT. 0.0, then\n*     that entry will be filled with default value used for that\n*     parameter.  Only positions up to NPARAMS are accessed; defaults\n*     are used for higher-numbered parameters.\n*\n*       PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n*            refinement or not.\n*         Default: 1.0D+0\n*            = 0.0 : No refinement is performed, and no error bounds are\n*                    computed.\n*            = 1.0 : Use the double-precision refinement algorithm,\n*                    possibly with doubled-single computations if the\n*                    compilation environment does not support DOUBLE\n*                    PRECISION.\n*              (other values are reserved for future use)\n*\n*       PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n*            computations allowed for refinement.\n*         Default: 10\n*         Aggressive: Set to 100 to permit convergence using approximate\n*                     factorizations or factorizations other than LU. If\n*                     the factorization uses a technique other than\n*                     Gaussian elimination, the guarantees in\n*                     err_bnds_norm and err_bnds_comp may no longer be\n*                     trustworthy.\n*\n*       PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n*            will attempt to find a solution with small componentwise\n*            relative error in the double-precision algorithm.  Positive\n*            is true, 0.0 is false.\n*         Default: 1.0 (attempt componentwise convergence)\n*\n*     WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*     RWORK   (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit. The solution to every right-hand side is\n*         guaranteed.\n*       < 0:  If INFO = -i, the i-th argument had an illegal value\n*       > 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.zporfsx( uplo, equed, a, af, s, b, x, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_uplo = argv[0];
  rblapack_equed = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_s = argv[4];
  rblapack_b = argv[5];
  rblapack_x = argv[6];
  rblapack_params = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (5th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (7th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  n_err_bnds = 3;
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (8th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (8th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_DFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
  params = NA_PTR_TYPE(rblapack_params, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
  MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
  MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (2*n));

  zporfsx_(&uplo, &equed, &n, &nrhs, a, &lda, af, &ldaf, s, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_s, rblapack_x, rblapack_params);
}

void
init_lapack_zporfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zporfsx", rblapack_zporfsx, -1);
}
ruby-lapack-1.7.2/ext/zgelqf.c0000644000175000017500000001347312502221015016021 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgelqf_(integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zgelqf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *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.zgelqf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGELQF computes an LQ factorization of a complex 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) COMPLEX*16 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 unitary 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) COMPLEX*16 array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace/output) COMPLEX*16 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 complex scalar, and v is a complex vector with\n*  v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in\n*  A(i,i+1: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           XERBLA, ZGELQ2, ZLARFB, ZLARFT\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.zgelqf( 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;
  }

  m = NUM2INT(rblapack_m);
  if (rblapack_lwork == Qnil)
    lwork = m;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zgelqf_(&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_zgelqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgelqf", rblapack_zgelqf, -1);
}
ruby-lapack-1.7.2/ext/slarrb.c0000644000175000017500000002367112502221014016016 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slarrb_(integer* n, real* d, real* lld, integer* ifirst, integer* ilast, real* rtol1, real* rtol2, integer* offset, real* w, real* wgap, real* werr, real* work, integer* iwork, real* pivmin, real* spdiam, integer* twist, integer* info);


static VALUE
rblapack_slarrb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_lld;
  real *lld; 
  VALUE rblapack_ifirst;
  integer ifirst; 
  VALUE rblapack_ilast;
  integer ilast; 
  VALUE rblapack_rtol1;
  real rtol1; 
  VALUE rblapack_rtol2;
  real rtol2; 
  VALUE rblapack_offset;
  integer offset; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_wgap;
  real *wgap; 
  VALUE rblapack_werr;
  real *werr; 
  VALUE rblapack_pivmin;
  real pivmin; 
  VALUE rblapack_spdiam;
  real spdiam; 
  VALUE rblapack_twist;
  integer twist; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_w_out__;
  real *w_out__;
  VALUE rblapack_wgap_out__;
  real *wgap_out__;
  VALUE rblapack_werr_out__;
  real *werr_out__;
  real *work;
  integer *iwork;

  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  info, w, wgap, werr = NumRu::Lapack.slarrb( d, lld, ifirst, ilast, rtol1, rtol2, offset, w, wgap, werr, pivmin, spdiam, twist, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLARRB( N, D, LLD, IFIRST, ILAST, RTOL1, RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK, PIVMIN, SPDIAM, TWIST, INFO )\n\n*  Purpose\n*  =======\n*\n*  Given the relatively robust representation(RRR) L D L^T, SLARRB\n*  does \"limited\" bisection to refine the eigenvalues of L D L^T,\n*  W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial\n*  guesses for these eigenvalues are input in W, the corresponding estimate\n*  of the error in these guesses and their gaps are input in WERR\n*  and WGAP, respectively. During bisection, intervals\n*  [left, right] are maintained by storing their mid-points and\n*  semi-widths in the arrays W and WERR respectively.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix.\n*\n*  D       (input) REAL             array, dimension (N)\n*          The N diagonal elements of the diagonal matrix D.\n*\n*  LLD     (input) REAL             array, dimension (N-1)\n*          The (N-1) elements L(i)*L(i)*D(i).\n*\n*  IFIRST  (input) INTEGER\n*          The index of the first eigenvalue to be computed.\n*\n*  ILAST   (input) INTEGER\n*          The index of the last eigenvalue to be computed.\n*\n*  RTOL1   (input) REAL            \n*  RTOL2   (input) REAL            \n*          Tolerance for the convergence of the bisection intervals.\n*          An interval [LEFT,RIGHT] has converged if\n*          RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n*          where GAP is the (estimated) distance to the nearest\n*          eigenvalue.\n*\n*  OFFSET  (input) INTEGER\n*          Offset for the arrays W, WGAP and WERR, i.e., the IFIRST-OFFSET\n*          through ILAST-OFFSET elements of these arrays are to be used.\n*\n*  W       (input/output) REAL             array, dimension (N)\n*          On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are\n*          estimates of the eigenvalues of L D L^T indexed IFIRST throug\n*          ILAST.\n*          On output, these estimates are refined.\n*\n*  WGAP    (input/output) REAL             array, dimension (N-1)\n*          On input, the (estimated) gaps between consecutive\n*          eigenvalues of L D L^T, i.e., WGAP(I-OFFSET) is the gap between\n*          eigenvalues I and I+1. Note that if IFIRST.EQ.ILAST\n*          then WGAP(IFIRST-OFFSET) must be set to ZERO.\n*          On output, these gaps are refined.\n*\n*  WERR    (input/output) REAL             array, dimension (N)\n*          On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are\n*          the errors in the estimates of the corresponding elements in W.\n*          On output, these errors are refined.\n*\n*  WORK    (workspace) REAL             array, dimension (2*N)\n*          Workspace.\n*\n*  IWORK   (workspace) INTEGER array, dimension (2*N)\n*          Workspace.\n*\n*  PIVMIN  (input) REAL\n*          The minimum pivot in the Sturm sequence.\n*\n*  SPDIAM  (input) REAL\n*          The spectral diameter of the matrix.\n*\n*  TWIST   (input) INTEGER\n*          The twist index for the twisted factorization that is used\n*          for the negcount.\n*          TWIST = N: Compute negcount from L D L^T - LAMBDA I = L+ D+ L+^T\n*          TWIST = 1: Compute negcount from L D L^T - LAMBDA I = U- D- U-^T\n*          TWIST = R: Compute negcount from L D L^T - LAMBDA I = N(r) D(r) N(r)\n*\n*  INFO    (output) INTEGER\n*          Error flag.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Beresford Parlett, University of California, Berkeley, USA\n*     Jim Demmel, University of California, Berkeley, USA\n*     Inderjit Dhillon, University of Texas, Austin, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, w, wgap, werr = NumRu::Lapack.slarrb( d, lld, ifirst, ilast, rtol1, rtol2, offset, w, wgap, werr, pivmin, spdiam, twist, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 13 && argc != 13)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 13)", argc);
  rblapack_d = argv[0];
  rblapack_lld = argv[1];
  rblapack_ifirst = argv[2];
  rblapack_ilast = argv[3];
  rblapack_rtol1 = argv[4];
  rblapack_rtol2 = argv[5];
  rblapack_offset = argv[6];
  rblapack_w = argv[7];
  rblapack_wgap = argv[8];
  rblapack_werr = argv[9];
  rblapack_pivmin = argv[10];
  rblapack_spdiam = argv[11];
  rblapack_twist = argv[12];
  if (argc == 13) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  ifirst = NUM2INT(rblapack_ifirst);
  rtol1 = (real)NUM2DBL(rblapack_rtol1);
  offset = NUM2INT(rblapack_offset);
  if (!NA_IsNArray(rblapack_werr))
    rb_raise(rb_eArgError, "werr (10th argument) must be NArray");
  if (NA_RANK(rblapack_werr) != 1)
    rb_raise(rb_eArgError, "rank of werr (10th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_werr) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of werr must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_werr) != NA_SFLOAT)
    rblapack_werr = na_change_type(rblapack_werr, NA_SFLOAT);
  werr = NA_PTR_TYPE(rblapack_werr, real*);
  spdiam = (real)NUM2DBL(rblapack_spdiam);
  ilast = NUM2INT(rblapack_ilast);
  if (!NA_IsNArray(rblapack_w))
    rb_raise(rb_eArgError, "w (8th argument) must be NArray");
  if (NA_RANK(rblapack_w) != 1)
    rb_raise(rb_eArgError, "rank of w (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_w) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_w) != NA_SFLOAT)
    rblapack_w = na_change_type(rblapack_w, NA_SFLOAT);
  w = NA_PTR_TYPE(rblapack_w, real*);
  pivmin = (real)NUM2DBL(rblapack_pivmin);
  if (!NA_IsNArray(rblapack_lld))
    rb_raise(rb_eArgError, "lld (2th argument) must be NArray");
  if (NA_RANK(rblapack_lld) != 1)
    rb_raise(rb_eArgError, "rank of lld (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_lld) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of lld must be %d", n-1);
  if (NA_TYPE(rblapack_lld) != NA_SFLOAT)
    rblapack_lld = na_change_type(rblapack_lld, NA_SFLOAT);
  lld = NA_PTR_TYPE(rblapack_lld, real*);
  if (!NA_IsNArray(rblapack_wgap))
    rb_raise(rb_eArgError, "wgap (9th argument) must be NArray");
  if (NA_RANK(rblapack_wgap) != 1)
    rb_raise(rb_eArgError, "rank of wgap (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_wgap) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of wgap must be %d", n-1);
  if (NA_TYPE(rblapack_wgap) != NA_SFLOAT)
    rblapack_wgap = na_change_type(rblapack_wgap, NA_SFLOAT);
  wgap = NA_PTR_TYPE(rblapack_wgap, real*);
  rtol2 = (real)NUM2DBL(rblapack_rtol2);
  twist = NUM2INT(rblapack_twist);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w_out__ = NA_PTR_TYPE(rblapack_w_out__, real*);
  MEMCPY(w_out__, w, real, NA_TOTAL(rblapack_w));
  rblapack_w = rblapack_w_out__;
  w = w_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_wgap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  wgap_out__ = NA_PTR_TYPE(rblapack_wgap_out__, real*);
  MEMCPY(wgap_out__, wgap, real, NA_TOTAL(rblapack_wgap));
  rblapack_wgap = rblapack_wgap_out__;
  wgap = wgap_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_werr_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  werr_out__ = NA_PTR_TYPE(rblapack_werr_out__, real*);
  MEMCPY(werr_out__, werr, real, NA_TOTAL(rblapack_werr));
  rblapack_werr = rblapack_werr_out__;
  werr = werr_out__;
  work = ALLOC_N(real, (2*n));
  iwork = ALLOC_N(integer, (2*n));

  slarrb_(&n, d, lld, &ifirst, &ilast, &rtol1, &rtol2, &offset, w, wgap, werr, work, iwork, &pivmin, &spdiam, &twist, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_info, rblapack_w, rblapack_wgap, rblapack_werr);
}

void
init_lapack_slarrb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slarrb", rblapack_slarrb, -1);
}
ruby-lapack-1.7.2/ext/strsyl.c0000644000175000017500000001505712502221021016066 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID strsyl_(char* trana, char* tranb, integer* isgn, integer* m, integer* n, real* a, integer* lda, real* b, integer* ldb, real* c, integer* ldc, real* scale, integer* info);


static VALUE
rblapack_strsyl(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trana;
  char trana; 
  VALUE rblapack_tranb;
  char tranb; 
  VALUE rblapack_isgn;
  integer isgn; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_scale;
  real scale; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  real *c_out__;

  integer lda;
  integer m;
  integer ldb;
  integer n;
  integer ldc;

  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  scale, info, c = NumRu::Lapack.strsyl( trana, tranb, isgn, a, b, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, SCALE, INFO )\n\n*  Purpose\n*  =======\n*\n*  STRSYL solves the real Sylvester matrix equation:\n*\n*     op(A)*X + X*op(B) = scale*C or\n*     op(A)*X - X*op(B) = scale*C,\n*\n*  where op(A) = A or A**T, and  A and B are both upper quasi-\n*  triangular. A is M-by-M and B is N-by-N; the right hand side C and\n*  the solution X are M-by-N; and scale is an output scale factor, set\n*  <= 1 to avoid overflow in X.\n*\n*  A and B must be in Schur canonical form (as returned by SHSEQR), that\n*  is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks;\n*  each 2-by-2 diagonal block has its diagonal elements equal and its\n*  off-diagonal elements of opposite sign.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANA   (input) CHARACTER*1\n*          Specifies the option op(A):\n*          = 'N': op(A) = A    (No transpose)\n*          = 'T': op(A) = A**T (Transpose)\n*          = 'C': op(A) = A**H (Conjugate transpose = Transpose)\n*\n*  TRANB   (input) CHARACTER*1\n*          Specifies the option op(B):\n*          = 'N': op(B) = B    (No transpose)\n*          = 'T': op(B) = B**T (Transpose)\n*          = 'C': op(B) = B**H (Conjugate transpose = Transpose)\n*\n*  ISGN    (input) INTEGER\n*          Specifies the sign in the equation:\n*          = +1: solve op(A)*X + X*op(B) = scale*C\n*          = -1: solve op(A)*X - X*op(B) = scale*C\n*\n*  M       (input) INTEGER\n*          The order of the matrix A, and the number of rows in the\n*          matrices X and C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The order of the matrix B, and the number of columns in the\n*          matrices X and C. N >= 0.\n*\n*  A       (input) REAL array, dimension (LDA,M)\n*          The upper quasi-triangular matrix A, in Schur canonical form.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  B       (input) REAL array, dimension (LDB,N)\n*          The upper quasi-triangular matrix B, in Schur canonical form.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  C       (input/output) REAL array, dimension (LDC,N)\n*          On entry, the M-by-N right hand side matrix C.\n*          On exit, C is overwritten by the solution matrix X.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M)\n*\n*  SCALE   (output) REAL\n*          The scale factor, scale, set <= 1 to avoid overflow in X.\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -i, the i-th argument had an illegal value\n*          = 1: A and B have common or very close eigenvalues; perturbed\n*               values were used to solve the equation (but the matrices\n*               A and B are unchanged).\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, info, c = NumRu::Lapack.strsyl( trana, tranb, isgn, a, b, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_trana = argv[0];
  rblapack_tranb = argv[1];
  rblapack_isgn = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  rblapack_c = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trana = StringValueCStr(rblapack_trana)[0];
  isgn = NUM2INT(rblapack_isgn);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  tranb = StringValueCStr(rblapack_tranb)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  if (NA_SHAPE1(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of c must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  strsyl_(&trana, &tranb, &isgn, &m, &n, a, &lda, b, &ldb, c, &ldc, &scale, &info);

  rblapack_scale = rb_float_new((double)scale);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_scale, rblapack_info, rblapack_c);
}

void
init_lapack_strsyl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "strsyl", rblapack_strsyl, -1);
}
ruby-lapack-1.7.2/ext/clanhb.c0000644000175000017500000001130212502221022015743 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real clanhb_(char* norm, char* uplo, integer* n, integer* k, complex* ab, integer* ldab, real* work);


static VALUE
rblapack_clanhb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack___out__;
  real __out__; 
  real *work;

  integer ldab;
  integer n;
  integer lwork;

  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  __out__ = NumRu::Lapack.clanhb( norm, uplo, k, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL             FUNCTION CLANHB( NORM, UPLO, N, K, AB, LDAB, WORK )\n\n*  Purpose\n*  =======\n*\n*  CLANHB  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the element of  largest absolute value  of an\n*  n by n hermitian band matrix A,  with k super-diagonals.\n*\n*  Description\n*  ===========\n*\n*  CLANHB returns the value\n*\n*     CLANHB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in CLANHB as described\n*          above.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          band matrix A is supplied.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, CLANHB is\n*          set to zero.\n*\n*  K       (input) INTEGER\n*          The number of super-diagonals or sub-diagonals of the\n*          band matrix A.  K >= 0.\n*\n*  AB      (input) COMPLEX array, dimension (LDAB,N)\n*          The upper or lower triangle of the hermitian band matrix A,\n*          stored in the first K+1 rows of AB.  The j-th column of A is\n*          stored in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)   = A(i,j) for j<=i<=min(n,j+k).\n*          Note that the imaginary parts of the diagonal elements need\n*          not be set and are assumed to be zero.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= K+1.\n*\n*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n*          WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.clanhb( norm, uplo, k, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_k = argv[2];
  rblapack_ab = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  k = NUM2INT(rblapack_k);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
  work = ALLOC_N(real, (MAX(1,lwork)));

  __out__ = clanhb_(&norm, &uplo, &n, &k, ab, &ldab, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_clanhb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clanhb", rblapack_clanhb, -1);
}
ruby-lapack-1.7.2/ext/dlalsd.c0000644000175000017500000002070112502221025015765 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlalsd_(char* uplo, integer* smlsiz, integer* n, integer* nrhs, doublereal* d, doublereal* e, doublereal* b, integer* ldb, doublereal* rcond, integer* rank, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dlalsd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_smlsiz;
  integer smlsiz; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_rank;
  integer rank; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_e_out__;
  doublereal *e_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;
  integer nlvl;
  doublereal *work;
  integer *iwork;

  integer n;
  integer ldb;
  integer nrhs;

  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  rank, info, d, e, b = NumRu::Lapack.dlalsd( uplo, smlsiz, d, e, b, rcond, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, RANK, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLALSD uses the singular value decomposition of A to solve the least\n*  squares problem of finding X to minimize the Euclidean norm of each\n*  column of A*X-B, where A is N-by-N upper bidiagonal, and X and B\n*  are N-by-NRHS. The solution X overwrites B.\n*\n*  The singular values of A smaller than RCOND times the largest\n*  singular value are treated as zero in solving the least squares\n*  problem; in this case a minimum norm solution is returned.\n*  The actual singular values are returned in D in ascending order.\n*\n*  This code makes very mild assumptions about floating point\n*  arithmetic. It will work on machines with a guard digit in\n*  add/subtract, or on those binary machines without guard digits\n*  which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.\n*  It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO   (input) CHARACTER*1\n*         = 'U': D and E define an upper bidiagonal matrix.\n*         = 'L': D and E define a  lower bidiagonal matrix.\n*\n*  SMLSIZ (input) INTEGER\n*         The maximum size of the subproblems at the bottom of the\n*         computation tree.\n*\n*  N      (input) INTEGER\n*         The dimension of the  bidiagonal matrix.  N >= 0.\n*\n*  NRHS   (input) INTEGER\n*         The number of columns of B. NRHS must be at least 1.\n*\n*  D      (input/output) DOUBLE PRECISION array, dimension (N)\n*         On entry D contains the main diagonal of the bidiagonal\n*         matrix. On exit, if INFO = 0, D contains its singular values.\n*\n*  E      (input/output) DOUBLE PRECISION array, dimension (N-1)\n*         Contains the super-diagonal entries of the bidiagonal matrix.\n*         On exit, E has been destroyed.\n*\n*  B      (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*         On input, B contains the right hand sides of the least\n*         squares problem. On output, B contains the solution X.\n*\n*  LDB    (input) INTEGER\n*         The leading dimension of B in the calling subprogram.\n*         LDB must be at least max(1,N).\n*\n*  RCOND  (input) DOUBLE PRECISION\n*         The singular values of A less than or equal to RCOND times\n*         the largest singular value are treated as zero in solving\n*         the least squares problem. If RCOND is negative,\n*         machine precision is used instead.\n*         For example, if diag(S)*X=B were the least squares problem,\n*         where diag(S) is a diagonal matrix of singular values, the\n*         solution would be X(i) = B(i) / S(i) if S(i) is greater than\n*         RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to\n*         RCOND*max(S).\n*\n*  RANK   (output) INTEGER\n*         The number of singular values of A greater than RCOND times\n*         the largest singular value.\n*\n*  WORK   (workspace) DOUBLE PRECISION array, dimension at least\n*         (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2),\n*         where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1).\n*\n*  IWORK  (workspace) INTEGER array, dimension at least\n*         (3*N*NLVL + 11*N)\n*\n*  INFO   (output) INTEGER\n*         = 0:  successful exit.\n*         < 0:  if INFO = -i, the i-th argument had an illegal value.\n*         > 0:  The algorithm failed to compute a singular value while\n*               working on the submatrix lying in rows and columns\n*               INFO/(N+1) through MOD(INFO,N+1).\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Ren-Cang Li, Computer Science Division, University of\n*       California at Berkeley, USA\n*     Osni Marques, LBNL/NERSC, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rank, info, d, e, b = NumRu::Lapack.dlalsd( uplo, smlsiz, d, e, b, rcond, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_smlsiz = argv[1];
  rblapack_d = argv[2];
  rblapack_e = argv[3];
  rblapack_b = argv[4];
  rblapack_rcond = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  smlsiz = NUM2INT(rblapack_smlsiz);
  rcond = NUM2DBL(rblapack_rcond);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (4th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  nlvl = MAX(0, (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
  MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(doublereal, (9*n + 2*n*smlsiz + 8*n*nlvl + n*nrhs + pow(smlsiz+1,2)));
  iwork = ALLOC_N(integer, (3*n*nlvl + 11*n));

  dlalsd_(&uplo, &smlsiz, &n, &nrhs, d, e, b, &ldb, &rcond, &rank, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rank = INT2NUM(rank);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_rank, rblapack_info, rblapack_d, rblapack_e, rblapack_b);
}

void
init_lapack_dlalsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlalsd", rblapack_dlalsd, -1);
}
ruby-lapack-1.7.2/ext/zlanhb.c0000644000175000017500000001140112502221023015773 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal zlanhb_(char* norm, char* uplo, integer* n, integer* k, doublecomplex* ab, integer* ldab, doublereal* work);


static VALUE
rblapack_zlanhb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack___out__;
  doublereal __out__; 
  doublereal *work;

  integer ldab;
  integer n;
  integer lwork;

  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  __out__ = NumRu::Lapack.zlanhb( norm, uplo, k, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION ZLANHB( NORM, UPLO, N, K, AB, LDAB, WORK )\n\n*  Purpose\n*  =======\n*\n*  ZLANHB  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the element of  largest absolute value  of an\n*  n by n hermitian band matrix A,  with k super-diagonals.\n*\n*  Description\n*  ===========\n*\n*  ZLANHB returns the value\n*\n*     ZLANHB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in ZLANHB as described\n*          above.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          band matrix A is supplied.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, ZLANHB is\n*          set to zero.\n*\n*  K       (input) INTEGER\n*          The number of super-diagonals or sub-diagonals of the\n*          band matrix A.  K >= 0.\n*\n*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)\n*          The upper or lower triangle of the hermitian band matrix A,\n*          stored in the first K+1 rows of AB.  The j-th column of A is\n*          stored in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)   = A(i,j) for j<=i<=min(n,j+k).\n*          Note that the imaginary parts of the diagonal elements need\n*          not be set and are assumed to be zero.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= K+1.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n*          WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.zlanhb( norm, uplo, k, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_k = argv[2];
  rblapack_ab = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  k = NUM2INT(rblapack_k);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
  work = ALLOC_N(doublereal, (MAX(1,lwork)));

  __out__ = zlanhb_(&norm, &uplo, &n, &k, ab, &ldab, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_zlanhb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlanhb", rblapack_zlanhb, -1);
}
ruby-lapack-1.7.2/ext/dorg2l.c0000644000175000017500000001047612502221022015720 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dorg2l_(integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* info);


static VALUE
rblapack_dorg2l(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  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 k;

  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  info, a = NumRu::Lapack.dorg2l( m, a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DORG2L generates an m by n real matrix Q with orthonormal columns,\n*  which is defined as the last n columns of a product of k elementary\n*  reflectors of order m\n*\n*        Q  =  H(k) . . . H(2) H(1)\n*\n*  as returned by DGEQLF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. M >= N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. N >= K >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the (n-k+i)-th column must contain the vector which\n*          defines the elementary reflector H(i), for i = 1,2,...,k, as\n*          returned by DGEQLF in the last k columns of its array\n*          argument A.\n*          On exit, the m by n matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) DOUBLE PRECISION array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by DGEQLF.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -i, the i-th argument has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.dorg2l( m, a, tau, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  rblapack_tau = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  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*);
  {
    na_shape_t 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, (n));

  dorg2l_(&m, &n, &k, a, &lda, tau, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_dorg2l(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dorg2l", rblapack_dorg2l, -1);
}
ruby-lapack-1.7.2/ext/dspsvx.c0000644000175000017500000003215412502221015016055 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dspsvx_(char* fact, char* uplo, integer* n, integer* nrhs, doublereal* ap, doublereal* afp, integer* ipiv, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dspsvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_afp;
  doublereal *afp; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_afp_out__;
  doublereal *afp_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  doublereal *work;
  integer *iwork;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.dspsvx( fact, uplo, ap, afp, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSPSVX uses the diagonal pivoting factorization A = U*D*U**T or\n*  A = L*D*L**T to compute the solution to a real system of linear\n*  equations A * X = B, where A is an N-by-N symmetric matrix stored\n*  in packed format and X and B are N-by-NRHS matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'N', the diagonal pivoting method is used to factor A as\n*        A = U * D * U**T,  if UPLO = 'U', or\n*        A = L * D * L**T,  if UPLO = 'L',\n*     where U (or L) is a product of permutation and unit upper (lower)\n*     triangular matrices and D is symmetric and block diagonal with\n*     1-by-1 and 2-by-2 diagonal blocks.\n*\n*  2. If some D(i,i)=0, so that D is exactly singular, then the routine\n*     returns with INFO = i. Otherwise, the factored form of A is used\n*     to estimate the condition number of the matrix A.  If the\n*     reciprocal of the condition number is less than machine precision,\n*     INFO = N+1 is returned as a warning, but the routine still goes on\n*     to solve for X and compute error bounds as described below.\n*\n*  3. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  4. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of A has been\n*          supplied on entry.\n*          = 'F':  On entry, AFP and IPIV contain the factored form of\n*                  A.  AP, AFP and IPIV will not be modified.\n*          = 'N':  The matrix A will be copied to AFP and factored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          The upper or lower triangle of the symmetric matrix A, packed\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*          See below for further details.\n*\n*  AFP     (input or output) DOUBLE PRECISION array, dimension\n*                            (N*(N+1)/2)\n*          If FACT = 'F', then AFP is an input argument and on entry\n*          contains the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L from the factorization\n*          A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as\n*          a packed triangular matrix in the same storage format as A.\n*\n*          If FACT = 'N', then AFP is an output argument and on exit\n*          contains the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L from the factorization\n*          A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as\n*          a packed triangular matrix in the same storage format as A.\n*\n*  IPIV    (input or output) INTEGER array, dimension (N)\n*          If FACT = 'F', then IPIV is an input argument and on entry\n*          contains details of the interchanges and the block structure\n*          of D, as determined by DSPTRF.\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*          If FACT = 'N', then IPIV is an output argument and on exit\n*          contains details of the interchanges and the block structure\n*          of D, as determined by DSPTRF.\n*\n*  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          The N-by-NRHS right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The estimate of the reciprocal condition number of the matrix\n*          A.  If RCOND is less than the machine precision (in\n*          particular, if RCOND = 0), the matrix is singular to working\n*          precision.  This condition is indicated by a return code of\n*          INFO > 0.\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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, and i is\n*                <= N:  D(i,i) is exactly zero.  The factorization\n*                       has been completed but the factor D is exactly\n*                       singular, so the solution and error bounds could\n*                       not be computed. RCOND = 0 is returned.\n*                = N+1: D is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  Further Details\n*  ===============\n*\n*  The packed storage scheme is illustrated by the following example\n*  when N = 4, UPLO = 'U':\n*\n*  Two-dimensional storage of the symmetric matrix A:\n*\n*     a11 a12 a13 a14\n*         a22 a23 a24\n*             a33 a34     (aij = aji)\n*                 a44\n*\n*  Packed storage of the upper triangle of A:\n*\n*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.dspsvx( fact, uplo, ap, afp, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_ap = argv[2];
  rblapack_afp = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_b = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  ldx = MAX(1,n);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_afp))
    rb_raise(rb_eArgError, "afp (4th argument) must be NArray");
  if (NA_RANK(rblapack_afp) != 1)
    rb_raise(rb_eArgError, "rank of afp (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_afp) != NA_DFLOAT)
    rblapack_afp = na_change_type(rblapack_afp, NA_DFLOAT);
  afp = NA_PTR_TYPE(rblapack_afp, doublereal*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_afp_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  afp_out__ = NA_PTR_TYPE(rblapack_afp_out__, doublereal*);
  MEMCPY(afp_out__, afp, doublereal, NA_TOTAL(rblapack_afp));
  rblapack_afp = rblapack_afp_out__;
  afp = afp_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  work = ALLOC_N(doublereal, (3*n));
  iwork = ALLOC_N(integer, (n));

  dspsvx_(&fact, &uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_afp, rblapack_ipiv);
}

void
init_lapack_dspsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dspsvx", rblapack_dspsvx, -1);
}
ruby-lapack-1.7.2/ext/cla_gbrfsx_extended.c0000644000175000017500000006010712502221014020516 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cla_gbrfsx_extended_(integer* prec_type, integer* trans_type, integer* n, integer* kl, integer* ku, integer* nrhs, complex* ab, integer* ldab, complex* afb, integer* ldafb, integer* ipiv, logical* colequ, real* c, complex* b, integer* ldb, complex* y, integer* ldy, real* berr_out, integer* n_norms, real* err_bnds_norm, real* err_bnds_comp, complex* res, real* ayb, complex* dy, complex* y_tail, real* rcond, integer* ithresh, real* rthresh, real* dz_ub, logical* ignore_cwise, integer* info);


static VALUE
rblapack_cla_gbrfsx_extended(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_prec_type;
  integer prec_type; 
  VALUE rblapack_trans_type;
  integer trans_type; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_afb;
  complex *afb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_colequ;
  logical colequ; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_y;
  complex *y; 
  VALUE rblapack_n_norms;
  integer n_norms; 
  VALUE rblapack_err_bnds_norm;
  real *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  real *err_bnds_comp; 
  VALUE rblapack_res;
  complex *res; 
  VALUE rblapack_ayb;
  real *ayb; 
  VALUE rblapack_dy;
  complex *dy; 
  VALUE rblapack_y_tail;
  complex *y_tail; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_ithresh;
  integer ithresh; 
  VALUE rblapack_rthresh;
  real rthresh; 
  VALUE rblapack_dz_ub;
  real dz_ub; 
  VALUE rblapack_ignore_cwise;
  logical ignore_cwise; 
  VALUE rblapack_berr_out;
  real *berr_out; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_y_out__;
  complex *y_out__;
  VALUE rblapack_err_bnds_norm_out__;
  real *err_bnds_norm_out__;
  VALUE rblapack_err_bnds_comp_out__;
  real *err_bnds_comp_out__;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldy;
  integer n_err_bnds;
  integer ldafb;
  integer ldab;

  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  berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.cla_gbrfsx_extended( prec_type, trans_type, kl, ku, ab, afb, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLA_GBRFSX_EXTENDED ( PREC_TYPE, TRANS_TYPE, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n*  Purpose\n*  =======\n*\n*  CLA_GBRFSX_EXTENDED improves the computed solution to a system of\n*  linear equations by performing extra-precise iterative refinement\n*  and provides error bounds and backward error estimates for the solution.\n*  This subroutine is called by CGBRFSX to perform iterative refinement.\n*  In addition to normwise error bound, the code provides maximum\n*  componentwise error bound if possible. See comments for ERR_BNDS_NORM\n*  and ERR_BNDS_COMP for details of the error bounds. Note that this\n*  subroutine is only resonsible for setting the second fields of\n*  ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n*  Arguments\n*  =========\n*\n*     PREC_TYPE      (input) INTEGER\n*     Specifies the intermediate precision to be used in refinement.\n*     The value is defined by ILAPREC(P) where P is a CHARACTER and\n*     P    = 'S':  Single\n*          = 'D':  Double\n*          = 'I':  Indigenous\n*          = 'X', 'E':  Extra\n*\n*     TRANS_TYPE     (input) INTEGER\n*     Specifies the transposition operation on A.\n*     The value is defined by ILATRANS(T) where T is a CHARACTER and\n*     T    = 'N':  No transpose\n*          = 'T':  Transpose\n*          = 'C':  Conjugate transpose\n*\n*     N              (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     KL             (input) INTEGER\n*     The number of subdiagonals within the band of A.  KL >= 0.\n*\n*     KU             (input) INTEGER\n*     The number of superdiagonals within the band of A.  KU >= 0\n*\n*     NRHS           (input) INTEGER\n*     The number of right-hand-sides, i.e., the number of columns of the\n*     matrix B.\n*\n*     AB             (input) COMPLEX array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDAB           (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AFB            (input) COMPLEX array, dimension (LDAF,N)\n*     The factors L and U from the factorization\n*     A = P*L*U as computed by CGBTRF.\n*\n*     LDAFB          (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV           (input) INTEGER array, dimension (N)\n*     The pivot indices from the factorization A = P*L*U\n*     as computed by CGBTRF; row i of the matrix was interchanged\n*     with row IPIV(i).\n*\n*     COLEQU         (input) LOGICAL\n*     If .TRUE. then column equilibration was done to A before calling\n*     this routine. This is needed to compute the solution and error\n*     bounds correctly.\n*\n*     C              (input) REAL array, dimension (N)\n*     The column scale factors for A. If COLEQU = .FALSE., C\n*     is not accessed. If C is input, each element of C should be a power\n*     of the radix to ensure a reliable solution and error estimates.\n*     Scaling by powers of the radix does not cause rounding errors unless\n*     the result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B              (input) COMPLEX array, dimension (LDB,NRHS)\n*     The right-hand-side matrix B.\n*\n*     LDB            (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     Y              (input/output) COMPLEX array, dimension (LDY,NRHS)\n*     On entry, the solution matrix X, as computed by CGBTRS.\n*     On exit, the improved solution matrix Y.\n*\n*     LDY            (input) INTEGER\n*     The leading dimension of the array Y.  LDY >= max(1,N).\n*\n*     BERR_OUT       (output) REAL array, dimension (NRHS)\n*     On exit, BERR_OUT(j) contains the componentwise relative backward\n*     error for right-hand-side j from the formula\n*         max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n*     where abs(Z) is the componentwise absolute value of the matrix\n*     or vector Z. This is computed by CLA_LIN_BERR.\n*\n*     N_NORMS        (input) INTEGER\n*     Determines which error bounds to return (see ERR_BNDS_NORM\n*     and ERR_BNDS_COMP).\n*     If N_NORMS >= 1 return normwise error bounds.\n*     If N_NORMS >= 2 return componentwise error bounds.\n*\n*     ERR_BNDS_NORM  (input/output) REAL array, dimension\n*                    (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (input/output) REAL array, dimension\n*                    (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     RES            (input) COMPLEX array, dimension (N)\n*     Workspace to hold the intermediate residual.\n*\n*     AYB            (input) REAL array, dimension (N)\n*     Workspace.\n*\n*     DY             (input) COMPLEX array, dimension (N)\n*     Workspace to hold the intermediate solution.\n*\n*     Y_TAIL         (input) COMPLEX array, dimension (N)\n*     Workspace to hold the trailing bits of the intermediate solution.\n*\n*     RCOND          (input) REAL\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     ITHRESH        (input) INTEGER\n*     The maximum number of residual computations allowed for\n*     refinement. The default is 10. For 'aggressive' set to 100 to\n*     permit convergence using approximate factorizations or\n*     factorizations other than LU. If the factorization uses a\n*     technique other than Gaussian elimination, the guarantees in\n*     ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n*     RTHRESH        (input) REAL\n*     Determines when to stop refinement if the error estimate stops\n*     decreasing. Refinement will stop when the next solution no longer\n*     satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n*     the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n*     default value is 0.5. For 'aggressive' set to 0.9 to permit\n*     convergence on extremely ill-conditioned matrices. See LAWN 165\n*     for more details.\n*\n*     DZ_UB          (input) REAL\n*     Determines when to start considering componentwise convergence.\n*     Componentwise convergence is only considered after each component\n*     of the solution Y is stable, which we definte as the relative\n*     change in each component being less than DZ_UB. The default value\n*     is 0.25, requiring the first bit to be stable. See LAWN 165 for\n*     more details.\n*\n*     IGNORE_CWISE   (input) LOGICAL\n*     If .TRUE. then ignore componentwise convergence. Default value\n*     is .FALSE..\n*\n*     INFO           (output) INTEGER\n*       = 0:  Successful exit.\n*       < 0:  if INFO = -i, the ith argument to CGBTRS had an illegal\n*             value\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      CHARACTER          TRANS\n      INTEGER            CNT, I, J, M, X_STATE, Z_STATE, Y_PREC_STATE\n      REAL               YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n     $                   DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n     $                   DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n     $                   EPS, HUGEVAL, INCR_THRESH\n      LOGICAL            INCR_PREC\n      COMPLEX            ZDUM\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.cla_gbrfsx_extended( prec_type, trans_type, kl, ku, ab, afb, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 23 && argc != 23)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 23)", argc);
  rblapack_prec_type = argv[0];
  rblapack_trans_type = argv[1];
  rblapack_kl = argv[2];
  rblapack_ku = argv[3];
  rblapack_ab = argv[4];
  rblapack_afb = argv[5];
  rblapack_ipiv = argv[6];
  rblapack_colequ = argv[7];
  rblapack_c = argv[8];
  rblapack_b = argv[9];
  rblapack_y = argv[10];
  rblapack_n_norms = argv[11];
  rblapack_err_bnds_norm = argv[12];
  rblapack_err_bnds_comp = argv[13];
  rblapack_res = argv[14];
  rblapack_ayb = argv[15];
  rblapack_dy = argv[16];
  rblapack_y_tail = argv[17];
  rblapack_rcond = argv[18];
  rblapack_ithresh = argv[19];
  rblapack_rthresh = argv[20];
  rblapack_dz_ub = argv[21];
  rblapack_ignore_cwise = argv[22];
  if (argc == 23) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  prec_type = NUM2INT(rblapack_prec_type);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (9th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (11th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 2)
    rb_raise(rb_eArgError, "rank of y (11th argument) must be %d", 2);
  ldy = NA_SHAPE0(rblapack_y);
  nrhs = NA_SHAPE1(rblapack_y);
  if (NA_TYPE(rblapack_y) != NA_SCOMPLEX)
    rblapack_y = na_change_type(rblapack_y, NA_SCOMPLEX);
  y = NA_PTR_TYPE(rblapack_y, complex*);
  if (!NA_IsNArray(rblapack_err_bnds_norm))
    rb_raise(rb_eArgError, "err_bnds_norm (13th argument) must be NArray");
  if (NA_RANK(rblapack_err_bnds_norm) != 2)
    rb_raise(rb_eArgError, "rank of err_bnds_norm (13th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_err_bnds_norm) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of y");
  n_err_bnds = NA_SHAPE1(rblapack_err_bnds_norm);
  if (NA_TYPE(rblapack_err_bnds_norm) != NA_SFLOAT)
    rblapack_err_bnds_norm = na_change_type(rblapack_err_bnds_norm, NA_SFLOAT);
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
  if (!NA_IsNArray(rblapack_res))
    rb_raise(rb_eArgError, "res (15th argument) must be NArray");
  if (NA_RANK(rblapack_res) != 1)
    rb_raise(rb_eArgError, "rank of res (15th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_res) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_res) != NA_SCOMPLEX)
    rblapack_res = na_change_type(rblapack_res, NA_SCOMPLEX);
  res = NA_PTR_TYPE(rblapack_res, complex*);
  if (!NA_IsNArray(rblapack_dy))
    rb_raise(rb_eArgError, "dy (17th argument) must be NArray");
  if (NA_RANK(rblapack_dy) != 1)
    rb_raise(rb_eArgError, "rank of dy (17th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dy) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_dy) != NA_SCOMPLEX)
    rblapack_dy = na_change_type(rblapack_dy, NA_SCOMPLEX);
  dy = NA_PTR_TYPE(rblapack_dy, complex*);
  rcond = (real)NUM2DBL(rblapack_rcond);
  rthresh = (real)NUM2DBL(rblapack_rthresh);
  ignore_cwise = (rblapack_ignore_cwise == Qtrue);
  trans_type = NUM2INT(rblapack_trans_type);
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_afb);
  if (NA_SHAPE1(rblapack_afb) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_afb) != NA_SCOMPLEX)
    rblapack_afb = na_change_type(rblapack_afb, NA_SCOMPLEX);
  afb = NA_PTR_TYPE(rblapack_afb, complex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (10th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (10th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of y");
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (!NA_IsNArray(rblapack_err_bnds_comp))
    rb_raise(rb_eArgError, "err_bnds_comp (14th argument) must be NArray");
  if (NA_RANK(rblapack_err_bnds_comp) != 2)
    rb_raise(rb_eArgError, "rank of err_bnds_comp (14th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_err_bnds_comp) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of y");
  if (NA_SHAPE1(rblapack_err_bnds_comp) != n_err_bnds)
    rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_comp must be the same as shape 1 of err_bnds_norm");
  if (NA_TYPE(rblapack_err_bnds_comp) != NA_SFLOAT)
    rblapack_err_bnds_comp = na_change_type(rblapack_err_bnds_comp, NA_SFLOAT);
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
  if (!NA_IsNArray(rblapack_y_tail))
    rb_raise(rb_eArgError, "y_tail (18th argument) must be NArray");
  if (NA_RANK(rblapack_y_tail) != 1)
    rb_raise(rb_eArgError, "rank of y_tail (18th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y_tail) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_y_tail) != NA_SCOMPLEX)
    rblapack_y_tail = na_change_type(rblapack_y_tail, NA_SCOMPLEX);
  y_tail = NA_PTR_TYPE(rblapack_y_tail, complex*);
  dz_ub = (real)NUM2DBL(rblapack_dz_ub);
  ku = NUM2INT(rblapack_ku);
  n_norms = NUM2INT(rblapack_n_norms);
  ithresh = NUM2INT(rblapack_ithresh);
  colequ = (rblapack_colequ == Qtrue);
  if (!NA_IsNArray(rblapack_ayb))
    rb_raise(rb_eArgError, "ayb (16th argument) must be NArray");
  if (NA_RANK(rblapack_ayb) != 1)
    rb_raise(rb_eArgError, "rank of ayb (16th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ayb) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_ayb) != NA_SFLOAT)
    rblapack_ayb = na_change_type(rblapack_ayb, NA_SFLOAT);
  ayb = NA_PTR_TYPE(rblapack_ayb, real*);
  ldab = lda = MAX(1,n);
  ldafb = ldaf = MAX(1,n);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr_out = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr_out = NA_PTR_TYPE(rblapack_berr_out, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldy;
    shape[1] = nrhs;
    rblapack_y_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, complex*);
  MEMCPY(y_out__, y, complex, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm_out__ = NA_PTR_TYPE(rblapack_err_bnds_norm_out__, real*);
  MEMCPY(err_bnds_norm_out__, err_bnds_norm, real, NA_TOTAL(rblapack_err_bnds_norm));
  rblapack_err_bnds_norm = rblapack_err_bnds_norm_out__;
  err_bnds_norm = err_bnds_norm_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp_out__ = NA_PTR_TYPE(rblapack_err_bnds_comp_out__, real*);
  MEMCPY(err_bnds_comp_out__, err_bnds_comp, real, NA_TOTAL(rblapack_err_bnds_comp));
  rblapack_err_bnds_comp = rblapack_err_bnds_comp_out__;
  err_bnds_comp = err_bnds_comp_out__;

  cla_gbrfsx_extended_(&prec_type, &trans_type, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_err_bnds_norm, rblapack_err_bnds_comp);
}

void
init_lapack_cla_gbrfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cla_gbrfsx_extended", rblapack_cla_gbrfsx_extended, -1);
}
ruby-lapack-1.7.2/ext/dormhr.c0000644000175000017500000002021312502221024016012 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dormhr_(char* side, char* trans, integer* m, integer* n, integer* ilo, integer* ihi, doublereal* a, integer* lda, doublereal* tau, doublereal* c, integer* ldc, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dormhr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublereal *c_out__;

  integer lda;
  integer m;
  integer ldc;
  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  work, info, c = NumRu::Lapack.dormhr( side, trans, ilo, ihi, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DORMHR overwrites the general real M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'T':      Q**T * C       C * Q**T\n*\n*  where Q is a real orthogonal matrix of order nq, with nq = m if\n*  SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of\n*  IHI-ILO elementary reflectors, as returned by DGEHRD:\n*\n*  Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**T from the Left;\n*          = 'R': apply Q or Q**T from the Right.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'T':  Transpose, apply Q**T.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          ILO and IHI must have the same values as in the previous call\n*          of DGEHRD. Q is equal to the unit matrix except in the\n*          submatrix Q(ilo+1:ihi,ilo+1:ihi).\n*          If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and\n*          ILO = 1 and IHI = 0, if M = 0;\n*          if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and\n*          ILO = 1 and IHI = 0, if N = 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension\n*                               (LDA,M) if SIDE = 'L'\n*                               (LDA,N) if SIDE = 'R'\n*          The vectors which define the elementary reflectors, as\n*          returned by DGEHRD.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*          LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n*\n*  TAU     (input) DOUBLE PRECISION array, dimension\n*                               (M-1) if SIDE = 'L'\n*                               (N-1) if SIDE = 'R'\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by DGEHRD.\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M).\n*          For optimum performance LWORK >= N*NB if SIDE = 'L', and\n*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n*          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*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LEFT, LQUERY\n      INTEGER            I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            ILAENV\n      EXTERNAL           LSAME, ILAENV\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DORMQR, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.dormhr( side, trans, ilo, ihi, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_ilo = argv[2];
  rblapack_ihi = argv[3];
  rblapack_a = argv[4];
  rblapack_tau = argv[5];
  rblapack_c = argv[6];
  if (argc == 8) {
    rblapack_lwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  side = StringValueCStr(rblapack_side)[0];
  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = 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*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (6th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_tau) != (m-1))
    rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", m-1);
  if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  ihi = NUM2INT(rblapack_ihi);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  dormhr_(&side, &trans, &m, &n, &ilo, &ihi, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_dormhr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dormhr", rblapack_dormhr, -1);
}
ruby-lapack-1.7.2/ext/strtrs.c0000644000175000017500000001260612502221017016071 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID strtrs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, real* a, integer* lda, real* b, integer* ldb, integer* info);


static VALUE
rblapack_strtrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  real *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.strtrs( uplo, trans, diag, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  STRTRS solves a triangular system of the form\n*\n*     A * X = B  or  A**T * X = B,\n*\n*  where A is a triangular matrix of order N, and B is an N-by-NRHS\n*  matrix.  A check is made to verify that A is nonsingular.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B  (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input) REAL array, dimension (LDA,N)\n*          The triangular matrix A.  If UPLO = 'U', the leading N-by-N\n*          upper triangular part of the array A contains the upper\n*          triangular matrix, and the strictly lower triangular part of\n*          A is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*          triangular part of the array A contains the lower triangular\n*          matrix, and the strictly upper triangular part of A is not\n*          referenced.  If DIAG = 'U', the diagonal elements of A are\n*          also not referenced and are assumed to be 1.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, if INFO = 0, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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 A is zero,\n*               indicating that the matrix is singular and the solutions\n*               X have not been computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.strtrs( uplo, trans, diag, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  strtrs_(&uplo, &trans, &diag, &n, &nrhs, a, &lda, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_strtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "strtrs", rblapack_strtrs, -1);
}
ruby-lapack-1.7.2/ext/clacp2.c0000644000175000017500000000704012502221022015664 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clacp2_(char* uplo, integer* m, integer* n, real* a, integer* lda, complex* b, integer* ldb);


static VALUE
rblapack_clacp2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  complex *b; 

  integer lda;
  integer n;
  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  b = NumRu::Lapack.clacp2( uplo, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLACP2( UPLO, M, N, A, LDA, B, LDB )\n\n*  Purpose\n*  =======\n*\n*  CLACP2 copies all or part of a real two-dimensional matrix A to a\n*  complex matrix B.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies the part of the matrix A to be copied to B.\n*          = 'U':      Upper triangular part\n*          = 'L':      Lower triangular part\n*          Otherwise:  All of the matrix A\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) REAL array, dimension (LDA,N)\n*          The m by n matrix A.  If UPLO = 'U', only the upper trapezium\n*          is accessed; if UPLO = 'L', only the lower trapezium is\n*          accessed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  B       (output) COMPLEX array, dimension (LDB,N)\n*          On exit, B = A in the locations specified by UPLO.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,M).\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  b = NumRu::Lapack.clacp2( uplo, m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_m = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  m = NUM2INT(rblapack_m);
  ldb = MAX(1,m);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b = NA_PTR_TYPE(rblapack_b, complex*);

  clacp2_(&uplo, &m, &n, a, &lda, b, &ldb);

  return rblapack_b;
}

void
init_lapack_clacp2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clacp2", rblapack_clacp2, -1);
}
ruby-lapack-1.7.2/ext/zhptrf.c0000644000175000017500000001500412502221020016032 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhptrf_(char* uplo, integer* n, doublecomplex* ap, integer* ipiv, integer* info);


static VALUE
rblapack_zhptrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublecomplex *ap_out__;

  integer ldap;
  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  ipiv, info, ap = NumRu::Lapack.zhptrf( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHPTRF( UPLO, N, AP, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHPTRF computes the factorization of a complex Hermitian packed\n*  matrix A using the Bunch-Kaufman diagonal pivoting method:\n*\n*     A = U*D*U**H  or  A = L*D*L**H\n*\n*  where U (or L) is a product of permutation and unit upper (lower)\n*  triangular matrices, and D is Hermitian and block diagonal with\n*  1-by-1 and 2-by-2 diagonal blocks.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L, stored as a packed triangular\n*          matrix overwriting A (see below for further details).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D.\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\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, D(i,i) is exactly zero.  The factorization\n*               has been completed, but the block diagonal matrix D is\n*               exactly singular, and division by zero will occur if it\n*               is used to solve a system of equations.\n*\n\n*  Further Details\n*  ===============\n*\n*  5-96 - Based on modifications by J. Lewis, Boeing Computer Services\n*         Company\n*\n*  If UPLO = 'U', then A = U*D*U', where\n*     U = P(n)*U(n)* ... *P(k)U(k)* ...,\n*  i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n*  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    v    0   )   k-s\n*     U(k) =  (   0    I    0   )   s\n*             (   0    0    I   )   n-k\n*                k-s   s   n-k\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n*  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n*  and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n*  If UPLO = 'L', then A = L*D*L', where\n*     L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n*  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n*  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    0     0   )  k-1\n*     L(k) =  (   0    I     0   )  s\n*             (   0    v     I   )  n-k-s+1\n*                k-1   s  n-k-s+1\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n*  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n*  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, ap = NumRu::Lapack.zhptrf( uplo, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
  MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  zhptrf_(&uplo, &n, ap, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_ap);
}

void
init_lapack_zhptrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhptrf", rblapack_zhptrf, -1);
}
ruby-lapack-1.7.2/ext/zgetrs.c0000644000175000017500000001201512502221026016040 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgetrs_(char* trans, integer* n, integer* nrhs, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* b, integer* ldb, integer* info);


static VALUE
rblapack_zgetrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.zgetrs( trans, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGETRS solves a system of linear equations\n*     A * X = B,  A**T * X = B,  or  A**H * X = B\n*  with a general N-by-N matrix A using the LU factorization computed\n*  by ZGETRF.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          The factors L and U from the factorization A = P*L*U\n*          as computed by ZGETRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices from ZGETRF; for 1<=i<=N, row i of the\n*          matrix was interchanged with row IPIV(i).\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.zgetrs( trans, a, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_trans = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zgetrs_(&trans, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_zgetrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgetrs", rblapack_zgetrs, -1);
}
ruby-lapack-1.7.2/ext/spteqr.c0000644000175000017500000001641112502221020016036 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID spteqr_(char* compz, integer* n, real* d, real* e, real* z, integer* ldz, real* work, integer* info);


static VALUE
rblapack_spteqr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_compz;
  char compz; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_e_out__;
  real *e_out__;
  VALUE rblapack_z_out__;
  real *z_out__;
  real *work;

  integer n;
  integer ldz;

  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  info, d, e, z = NumRu::Lapack.spteqr( compz, d, e, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPTEQR computes all eigenvalues and, optionally, eigenvectors of a\n*  symmetric positive definite tridiagonal matrix by first factoring the\n*  matrix using SPTTRF, and then calling SBDSQR to compute the singular\n*  values of the bidiagonal factor.\n*\n*  This routine computes the eigenvalues of the positive definite\n*  tridiagonal matrix to high relative accuracy.  This means that if the\n*  eigenvalues range over many orders of magnitude in size, then the\n*  small eigenvalues and corresponding eigenvectors will be computed\n*  more accurately than, for example, with the standard QR method.\n*\n*  The eigenvectors of a full or band symmetric positive definite matrix\n*  can also be found if SSYTRD, SSPTRD, or SSBTRD has been used to\n*  reduce this matrix to tridiagonal form. (The reduction to tridiagonal\n*  form, however, may preclude the possibility of obtaining high\n*  relative accuracy in the small eigenvalues of the original matrix, if\n*  these eigenvalues range over many orders of magnitude.)\n*\n\n*  Arguments\n*  =========\n*\n*  COMPZ   (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only.\n*          = 'V':  Compute eigenvectors of original symmetric\n*                  matrix also.  Array Z contains the orthogonal\n*                  matrix used to reduce the original matrix to\n*                  tridiagonal form.\n*          = 'I':  Compute eigenvectors of tridiagonal matrix also.\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  D       (input/output) REAL array, dimension (N)\n*          On entry, the n diagonal elements of the tridiagonal\n*          matrix.\n*          On normal exit, D contains the eigenvalues, in descending\n*          order.\n*\n*  E       (input/output) REAL array, dimension (N-1)\n*          On entry, the (n-1) subdiagonal elements of the tridiagonal\n*          matrix.\n*          On exit, E has been destroyed.\n*\n*  Z       (input/output) REAL array, dimension (LDZ, N)\n*          On entry, if COMPZ = 'V', the orthogonal matrix used in the\n*          reduction to tridiagonal form.\n*          On exit, if COMPZ = 'V', the orthonormal eigenvectors of the\n*          original symmetric matrix;\n*          if COMPZ = 'I', the orthonormal eigenvectors of the\n*          tridiagonal matrix.\n*          If INFO > 0 on exit, Z contains the eigenvectors associated\n*          with only the stored eigenvalues.\n*          If  COMPZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          COMPZ = 'V' or 'I', LDZ >= max(1,N).\n*\n*  WORK    (workspace) REAL array, dimension (4*N)\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, and i is:\n*                <= N  the Cholesky factorization of the matrix could\n*                      not be performed because the i-th principal minor\n*                      was not positive definite.\n*                > N   the SVD algorithm failed to converge;\n*                      if INFO = N+i, i off-diagonal elements of the\n*                      bidiagonal factor did not converge to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, e, z = NumRu::Lapack.spteqr( compz, d, e, z, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_compz = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  rblapack_z = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  compz = StringValueCStr(rblapack_compz)[0];
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (4th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  n = NA_SHAPE1(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of z");
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
  MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
  MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  work = ALLOC_N(real, (4*n));

  spteqr_(&compz, &n, d, e, z, &ldz, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_e, rblapack_z);
}

void
init_lapack_spteqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "spteqr", rblapack_spteqr, -1);
}
ruby-lapack-1.7.2/ext/dtfttp.c0000644000175000017500000001536612502221021016036 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtfttp_(char* transr, char* uplo, integer* n, doublereal* arf, doublereal* ap, integer* info);


static VALUE
rblapack_dtfttp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_arf;
  doublereal *arf; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_info;
  integer info; 


  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  ap, info = NumRu::Lapack.dtfttp( transr, uplo, n, arf, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTFTTP( TRANSR, UPLO, N, ARF, AP, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTFTTP copies a triangular matrix A from rectangular full packed\n*  format (TF) to standard packed format (TP).\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR  (input) CHARACTER*1\n*          = 'N':  ARF is in Normal format;\n*          = 'T':  ARF is in Transpose format;\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0.\n*\n*  ARF     (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ),\n*          On entry, the upper or lower triangular matrix A stored in\n*          RFP format. For a further discussion see Notes below.\n*\n*  AP      (output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ),\n*          On exit, the upper or lower triangular matrix A, packed\n*          columnwise in a linear array. The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\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*  We first consider Rectangular Full Packed (RFP) Format when N is\n*  even. We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  the transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  the transpose of the last three columns of AP lower.\n*  This covers the case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        03 04 05                33 43 53\n*        13 14 15                00 44 54\n*        23 24 25                10 11 55\n*        33 34 35                20 21 22\n*        00 44 45                30 31 32\n*        01 11 55                40 41 42\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We then consider Rectangular Full Packed (RFP) Format when N is\n*  odd. We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  the transpose of the first two columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  the transpose of the last two columns of AP lower.\n*  This covers the case N odd and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        02 03 04                00 33 43\n*        12 13 14                10 11 44\n*        22 23 24                20 21 22\n*        00 33 34                30 31 32\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*           RFP A                   RFP A\n*\n*     02 12 22 00 01             00 10 20 30 40 50\n*     03 13 23 33 11             33 11 21 31 41 51\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ap, info = NumRu::Lapack.dtfttp( transr, uplo, n, arf, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_n = argv[2];
  rblapack_arf = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  n = NUM2INT(rblapack_n);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_arf))
    rb_raise(rb_eArgError, "arf (4th argument) must be NArray");
  if (NA_RANK(rblapack_arf) != 1)
    rb_raise(rb_eArgError, "rank of arf (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_arf) != (( n*(n+1)/2 )))
    rb_raise(rb_eRuntimeError, "shape 0 of arf must be %d", ( n*(n+1)/2 ));
  if (NA_TYPE(rblapack_arf) != NA_DFLOAT)
    rblapack_arf = na_change_type(rblapack_arf, NA_DFLOAT);
  arf = NA_PTR_TYPE(rblapack_arf, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = ( n*(n+1)/2 );
    rblapack_ap = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);

  dtfttp_(&transr, &uplo, &n, arf, ap, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_ap, rblapack_info);
}

void
init_lapack_dtfttp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtfttp", rblapack_dtfttp, -1);
}
ruby-lapack-1.7.2/ext/cungl2.c0000644000175000017500000001025312502221012015711 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cungl2_(integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* work, integer* info);


static VALUE
rblapack_cungl2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  complex *work;

  integer lda;
  integer n;
  integer k;
  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  info, a = NumRu::Lapack.cungl2( a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CUNGL2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CUNGL2 generates an m-by-n complex matrix Q with orthonormal rows,\n*  which is defined as the first m rows of a product of k elementary\n*  reflectors of order n\n*\n*        Q  =  H(k)' . . . H(2)' H(1)'\n*\n*  as returned by CGELQF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. N >= M.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. M >= K >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the i-th row must contain the vector which defines\n*          the elementary reflector H(i), for i = 1,2,...,k, as returned\n*          by CGELQF in the first k rows of its array argument A.\n*          On exit, the m by n matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) COMPLEX array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by CGELQF.\n*\n*  WORK    (workspace) COMPLEX array, dimension (M)\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -i, the i-th argument has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.cungl2( a, tau, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_a = argv[0];
  rblapack_tau = argv[1];
  if (argc == 2) {
  } 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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  m = lda;
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (2th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (2th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(complex, (m));

  cungl2_(&m, &n, &k, a, &lda, tau, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_cungl2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cungl2", rblapack_cungl2, -1);
}
ruby-lapack-1.7.2/ext/chbgvd.c0000644000175000017500000003070612502221020015760 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chbgvd_(char* jobz, char* uplo, integer* n, integer* ka, integer* kb, complex* ab, integer* ldab, complex* bb, integer* ldbb, real* w, complex* z, integer* ldz, complex* work, integer* lwork, real* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_chbgvd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ka;
  integer ka; 
  VALUE rblapack_kb;
  integer kb; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_bb;
  complex *bb; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_lrwork;
  integer lrwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_rwork;
  real *rwork; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  complex *ab_out__;
  VALUE rblapack_bb_out__;
  complex *bb_out__;

  integer ldab;
  integer n;
  integer ldbb;
  integer ldz;

  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  w, z, work, rwork, iwork, info, ab, bb = NumRu::Lapack.chbgvd( jobz, uplo, ka, kb, ab, bb, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHBGVD computes all the eigenvalues, and optionally, the eigenvectors\n*  of a complex generalized Hermitian-definite banded eigenproblem, of\n*  the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian\n*  and banded, and B is also positive definite.  If eigenvectors are\n*  desired, it uses a divide and conquer algorithm.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  KA      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n*  KB      (input) INTEGER\n*          The number of superdiagonals of the matrix B if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n*  AB      (input/output) COMPLEX array, dimension (LDAB, N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix A, stored in the first ka+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).\n*\n*          On exit, the contents of AB are destroyed.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KA+1.\n*\n*  BB      (input/output) COMPLEX array, dimension (LDBB, N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix B, stored in the first kb+1 rows of the array.  The\n*          j-th column of B is stored in the j-th column of the array BB\n*          as follows:\n*          if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n*          if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb).\n*\n*          On exit, the factor S from the split Cholesky factorization\n*          B = S**H*S, as returned by CPBSTF.\n*\n*  LDBB    (input) INTEGER\n*          The leading dimension of the array BB.  LDBB >= KB+1.\n*\n*  W       (output) REAL array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) COMPLEX array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n*          eigenvectors, with the i-th column of Z holding the\n*          eigenvector associated with W(i). The eigenvectors are\n*          normalized so that Z**H*B*Z = I.\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= N.\n*\n*  WORK    (workspace/output) COMPLEX 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*          If N <= 1,               LWORK >= 1.\n*          If JOBZ = 'N' and N > 1, LWORK >= N.\n*          If JOBZ = 'V' and N > 1, LWORK >= 2*N**2.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal sizes of the WORK, RWORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  RWORK   (workspace/output) REAL array, dimension (MAX(1,LRWORK))\n*          On exit, if INFO=0, RWORK(1) returns the optimal LRWORK.\n*\n*  LRWORK  (input) INTEGER\n*          The dimension of array RWORK.\n*          If N <= 1,               LRWORK >= 1.\n*          If JOBZ = 'N' and N > 1, LRWORK >= N.\n*          If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.\n*\n*          If LRWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO=0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of array IWORK.\n*          If JOBZ = 'N' or N <= 1, LIWORK >= 1.\n*          If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK 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, and i is:\n*             <= N:  the algorithm failed to converge:\n*                    i off-diagonal elements of an intermediate\n*                    tridiagonal form did not converge to zero;\n*             > N:   if INFO = N + i, for 1 <= i <= N, then CPBSTF\n*                    returned INFO = i: B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, work, rwork, iwork, info, ab, bb = NumRu::Lapack.chbgvd( jobz, uplo, ka, kb, ab, bb, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_ka = argv[2];
  rblapack_kb = argv[3];
  rblapack_ab = argv[4];
  rblapack_bb = argv[5];
  if (argc == 9) {
    rblapack_lwork = argv[6];
    rblapack_lrwork = argv[7];
    rblapack_liwork = argv[8];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_lrwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  ka = NUM2INT(rblapack_ka);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_bb))
    rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
  if (NA_RANK(rblapack_bb) != 2)
    rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
  ldbb = NA_SHAPE0(rblapack_bb);
  if (NA_SHAPE1(rblapack_bb) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of bb must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_bb) != NA_SCOMPLEX)
    rblapack_bb = na_change_type(rblapack_bb, NA_SCOMPLEX);
  bb = NA_PTR_TYPE(rblapack_bb, complex*);
  if (rblapack_lrwork == Qnil)
    lrwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
  else {
    lrwork = NUM2INT(rblapack_lrwork);
  }
  ldz = lsame_(&jobz,"V") ? n : 1;
  kb = NUM2INT(rblapack_kb);
  if (rblapack_liwork == Qnil)
    liwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  if (rblapack_lwork == Qnil)
    lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 2*n*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lrwork);
    rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  rwork = NA_PTR_TYPE(rblapack_rwork, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
  MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldbb;
    shape[1] = n;
    rblapack_bb_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  bb_out__ = NA_PTR_TYPE(rblapack_bb_out__, complex*);
  MEMCPY(bb_out__, bb, complex, NA_TOTAL(rblapack_bb));
  rblapack_bb = rblapack_bb_out__;
  bb = bb_out__;

  chbgvd_(&jobz, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, w, z, &ldz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_w, rblapack_z, rblapack_work, rblapack_rwork, rblapack_iwork, rblapack_info, rblapack_ab, rblapack_bb);
}

void
init_lapack_chbgvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chbgvd", rblapack_chbgvd, -1);
}
ruby-lapack-1.7.2/ext/sisnan.c0000644000175000017500000000340112502221020016006 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern logical sisnan_(real* sin);


static VALUE
rblapack_sisnan(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_sin;
  real sin; 
  VALUE rblapack___out__;
  logical __out__; 


  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  __out__ = NumRu::Lapack.sisnan( sin, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      LOGICAL FUNCTION SISNAN( SIN )\n\n*  Purpose\n*  =======\n*\n*  SISNAN returns .TRUE. if its argument is NaN, and .FALSE.\n*  otherwise.  To be replaced by the Fortran 2003 intrinsic in the\n*  future.\n*\n\n*  Arguments\n*  =========\n*\n*  SIN     (input) REAL\n*          Input to test for NaN.\n*\n\n*  =====================================================================\n*\n*  .. External Functions ..\n      LOGICAL SLAISNAN\n      EXTERNAL SLAISNAN\n*  ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.sisnan( sin, [: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_sin = argv[0];
  if (argc == 1) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  sin = (real)NUM2DBL(rblapack_sin);

  __out__ = sisnan_(&sin);

  rblapack___out__ = __out__ ? Qtrue : Qfalse;
  return rblapack___out__;
}

void
init_lapack_sisnan(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sisnan", rblapack_sisnan, -1);
}
ruby-lapack-1.7.2/ext/zggqrf.c0000644000175000017500000002334312502221024016026 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zggqrf_(integer* n, integer* m, integer* p, doublecomplex* a, integer* lda, doublecomplex* taua, doublecomplex* b, integer* ldb, doublecomplex* taub, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zggqrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_taua;
  doublecomplex *taua; 
  VALUE rblapack_taub;
  doublecomplex *taub; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer lda;
  integer m;
  integer ldb;
  integer p;

  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  taua, taub, work, info, a, b = NumRu::Lapack.zggqrf( n, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGGQRF computes a generalized QR factorization of an N-by-M matrix A\n*  and an N-by-P matrix B:\n*\n*              A = Q*R,        B = Q*T*Z,\n*\n*  where Q is an N-by-N unitary matrix, Z is a P-by-P unitary matrix,\n*  and R and T assume one of the forms:\n*\n*  if N >= M,  R = ( R11 ) M  ,   or if N < M,  R = ( R11  R12 ) N,\n*                  (  0  ) N-M                         N   M-N\n*                     M\n*\n*  where R11 is upper triangular, and\n*\n*  if N <= P,  T = ( 0  T12 ) N,   or if N > P,  T = ( T11 ) N-P,\n*                   P-N  N                           ( T21 ) P\n*                                                       P\n*\n*  where T12 or T21 is upper triangular.\n*\n*  In particular, if B is square and nonsingular, the GQR factorization\n*  of A and B implicitly gives the QR factorization of inv(B)*A:\n*\n*               inv(B)*A = Z'*(inv(T)*R)\n*\n*  where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n*  conjugate transpose of matrix Z.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of rows of the matrices A and B. N >= 0.\n*\n*  M       (input) INTEGER\n*          The number of columns of the matrix A.  M >= 0.\n*\n*  P       (input) INTEGER\n*          The number of columns of the matrix B.  P >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,M)\n*          On entry, the N-by-M matrix A.\n*          On exit, the elements on and above the diagonal of the array\n*          contain the min(N,M)-by-M upper trapezoidal matrix R (R is\n*          upper triangular if N >= M); the elements below the diagonal,\n*          with the array TAUA, represent the unitary matrix Q as a\n*          product of min(N,M) elementary reflectors (see Further\n*          Details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  TAUA    (output) COMPLEX*16 array, dimension (min(N,M))\n*          The scalar factors of the elementary reflectors which\n*          represent the unitary matrix Q (see Further Details).\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,P)\n*          On entry, the N-by-P matrix B.\n*          On exit, if N <= P, the upper triangle of the subarray\n*          B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n*          if N > P, the elements on and above the (N-P)-th subdiagonal\n*          contain the N-by-P upper trapezoidal matrix T; the remaining\n*          elements, with the array TAUB, represent the unitary\n*          matrix Z as a product of elementary reflectors (see Further\n*          Details).\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  TAUB    (output) COMPLEX*16 array, dimension (min(N,P))\n*          The scalar factors of the elementary reflectors which\n*          represent the unitary matrix Z (see Further Details).\n*\n*  WORK    (workspace/output) COMPLEX*16 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,N,M,P).\n*          For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n*          where NB1 is the optimal blocksize for the QR factorization\n*          of an N-by-M matrix, NB2 is the optimal blocksize for the\n*          RQ factorization of an N-by-P matrix, and NB3 is the optimal\n*          blocksize for a call of ZUNMQR.\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(1) H(2) . . . H(k), where k = min(n,m).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - taua * v * v'\n*\n*  where taua is a complex scalar, and v is a complex vector with\n*  v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),\n*  and taua in TAUA(i).\n*  To form Q explicitly, use LAPACK subroutine ZUNGQR.\n*  To use Q to update another matrix, use LAPACK subroutine ZUNMQR.\n*\n*  The matrix Z is represented as a product of elementary reflectors\n*\n*     Z = H(1) H(2) . . . H(k), where k = min(n,p).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - taub * v * v'\n*\n*  where taub is a complex scalar, and v is a complex vector with\n*  v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in\n*  B(n-k+i,1:p-k+i-1), and taub in TAUB(i).\n*  To form Z explicitly, use LAPACK subroutine ZUNGRQ.\n*  To use Z to update another matrix, use LAPACK subroutine ZUNMRQ.\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY\n      INTEGER            LOPT, LWKOPT, NB, NB1, NB2, NB3\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZGEQRF, ZGERQF, ZUNMQR\n*     ..\n*     .. External Functions ..\n      INTEGER            ILAENV\n      EXTERNAL           ILAENV\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          INT, MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  taua, taub, work, info, a, b = NumRu::Lapack.zggqrf( n, 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_n = 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;
  }

  n = NUM2INT(rblapack_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);
  ldb = NA_SHAPE0(rblapack_b);
  p = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  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);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (rblapack_lwork == Qnil)
    lwork = MAX(MAX(n,m),p);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(n,m);
    rblapack_taua = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  taua = NA_PTR_TYPE(rblapack_taua, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(n,p);
    rblapack_taub = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  taub = NA_PTR_TYPE(rblapack_taub, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = m;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = p;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zggqrf_(&n, &m, &p, a, &lda, taua, b, &ldb, taub, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_taua, rblapack_taub, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_zggqrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zggqrf", rblapack_zggqrf, -1);
}
ruby-lapack-1.7.2/ext/dpbcon.c0000644000175000017500000001113712502221021015766 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dpbcon_(char* uplo, integer* n, integer* kd, doublereal* ab, integer* ldab, doublereal* anorm, doublereal* rcond, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dpbcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_anorm;
  doublereal anorm; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_info;
  integer info; 
  doublereal *work;
  integer *iwork;

  integer ldab;
  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  rcond, info = NumRu::Lapack.dpbcon( uplo, kd, ab, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPBCON estimates the reciprocal of the condition number (in the\n*  1-norm) of a real symmetric positive definite band matrix using the\n*  Cholesky factorization A = U**T*U or A = L*L**T computed by DPBTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangular factor stored in AB;\n*          = 'L':  Lower triangular factor stored in AB.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**T*U or A = L*L**T of the band matrix A, stored in the\n*          first KD+1 rows of the array.  The j-th column of U or L is\n*          stored in the j-th column of the array AB as follows:\n*          if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO ='L', AB(1+i-j,j)    = L(i,j) for j<=i<=min(n,j+kd).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  ANORM   (input) DOUBLE PRECISION\n*          The 1-norm (or infinity-norm) of the symmetric band matrix A.\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n*          estimate of the 1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.dpbcon( uplo, kd, ab, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  rblapack_anorm = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  kd = NUM2INT(rblapack_kd);
  anorm = NUM2DBL(rblapack_anorm);
  work = ALLOC_N(doublereal, (3*n));
  iwork = ALLOC_N(integer, (n));

  dpbcon_(&uplo, &n, &kd, ab, &ldab, &anorm, &rcond, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_dpbcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dpbcon", rblapack_dpbcon, -1);
}
ruby-lapack-1.7.2/ext/cla_herfsx_extended.c0000644000175000017500000005646012502221021020527 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cla_herfsx_extended_(integer* prec_type, char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, logical* colequ, real* c, complex* b, integer* ldb, complex* y, integer* ldy, real* berr_out, integer* n_norms, real* err_bnds_norm, real* err_bnds_comp, complex* res, real* ayb, complex* dy, complex* y_tail, real* rcond, integer* ithresh, real* rthresh, real* dz_ub, logical* ignore_cwise, integer* info);


static VALUE
rblapack_cla_herfsx_extended(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_prec_type;
  integer prec_type; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_colequ;
  logical colequ; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_y;
  complex *y; 
  VALUE rblapack_n_norms;
  integer n_norms; 
  VALUE rblapack_err_bnds_norm;
  real *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  real *err_bnds_comp; 
  VALUE rblapack_res;
  complex *res; 
  VALUE rblapack_ayb;
  real *ayb; 
  VALUE rblapack_dy;
  complex *dy; 
  VALUE rblapack_y_tail;
  complex *y_tail; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_ithresh;
  integer ithresh; 
  VALUE rblapack_rthresh;
  real rthresh; 
  VALUE rblapack_dz_ub;
  real dz_ub; 
  VALUE rblapack_ignore_cwise;
  logical ignore_cwise; 
  VALUE rblapack_berr_out;
  real *berr_out; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_y_out__;
  complex *y_out__;
  VALUE rblapack_err_bnds_norm_out__;
  real *err_bnds_norm_out__;
  VALUE rblapack_err_bnds_comp_out__;
  real *err_bnds_comp_out__;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldy;
  integer n_err_bnds;

  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  berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.cla_herfsx_extended( prec_type, uplo, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLA_HERFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n*  Purpose\n*  =======\n*\n*  CLA_HERFSX_EXTENDED improves the computed solution to a system of\n*  linear equations by performing extra-precise iterative refinement\n*  and provides error bounds and backward error estimates for the solution.\n*  This subroutine is called by CHERFSX to perform iterative refinement.\n*  In addition to normwise error bound, the code provides maximum\n*  componentwise error bound if possible. See comments for ERR_BNDS_NORM\n*  and ERR_BNDS_COMP for details of the error bounds. Note that this\n*  subroutine is only resonsible for setting the second fields of\n*  ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n*  Arguments\n*  =========\n*\n*     PREC_TYPE      (input) INTEGER\n*     Specifies the intermediate precision to be used in refinement.\n*     The value is defined by ILAPREC(P) where P is a CHARACTER and\n*     P    = 'S':  Single\n*          = 'D':  Double\n*          = 'I':  Indigenous\n*          = 'X', 'E':  Extra\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N              (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NRHS           (input) INTEGER\n*     The number of right-hand-sides, i.e., the number of columns of the\n*     matrix B.\n*\n*     A              (input) COMPLEX array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA            (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF             (input) COMPLEX array, dimension (LDAF,N)\n*     The block diagonal matrix D and the multipliers used to\n*     obtain the factor U or L as computed by CHETRF.\n*\n*     LDAF           (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV           (input) INTEGER array, dimension (N)\n*     Details of the interchanges and the block structure of D\n*     as determined by CHETRF.\n*\n*     COLEQU         (input) LOGICAL\n*     If .TRUE. then column equilibration was done to A before calling\n*     this routine. This is needed to compute the solution and error\n*     bounds correctly.\n*\n*     C              (input) REAL array, dimension (N)\n*     The column scale factors for A. If COLEQU = .FALSE., C\n*     is not accessed. If C is input, each element of C should be a power\n*     of the radix to ensure a reliable solution and error estimates.\n*     Scaling by powers of the radix does not cause rounding errors unless\n*     the result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B              (input) COMPLEX array, dimension (LDB,NRHS)\n*     The right-hand-side matrix B.\n*\n*     LDB            (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     Y              (input/output) COMPLEX array, dimension\n*                    (LDY,NRHS)\n*     On entry, the solution matrix X, as computed by CHETRS.\n*     On exit, the improved solution matrix Y.\n*\n*     LDY            (input) INTEGER\n*     The leading dimension of the array Y.  LDY >= max(1,N).\n*\n*     BERR_OUT       (output) REAL array, dimension (NRHS)\n*     On exit, BERR_OUT(j) contains the componentwise relative backward\n*     error for right-hand-side j from the formula\n*         max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n*     where abs(Z) is the componentwise absolute value of the matrix\n*     or vector Z. This is computed by CLA_LIN_BERR.\n*\n*     N_NORMS        (input) INTEGER\n*     Determines which error bounds to return (see ERR_BNDS_NORM\n*     and ERR_BNDS_COMP).\n*     If N_NORMS >= 1 return normwise error bounds.\n*     If N_NORMS >= 2 return componentwise error bounds.\n*\n*     ERR_BNDS_NORM  (input/output) REAL array, dimension\n*                    (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (input/output) REAL array, dimension\n*                    (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     RES            (input) COMPLEX array, dimension (N)\n*     Workspace to hold the intermediate residual.\n*\n*     AYB            (input) REAL array, dimension (N)\n*     Workspace.\n*\n*     DY             (input) COMPLEX array, dimension (N)\n*     Workspace to hold the intermediate solution.\n*\n*     Y_TAIL         (input) COMPLEX array, dimension (N)\n*     Workspace to hold the trailing bits of the intermediate solution.\n*\n*     RCOND          (input) REAL\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     ITHRESH        (input) INTEGER\n*     The maximum number of residual computations allowed for\n*     refinement. The default is 10. For 'aggressive' set to 100 to\n*     permit convergence using approximate factorizations or\n*     factorizations other than LU. If the factorization uses a\n*     technique other than Gaussian elimination, the guarantees in\n*     ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n*     RTHRESH        (input) REAL\n*     Determines when to stop refinement if the error estimate stops\n*     decreasing. Refinement will stop when the next solution no longer\n*     satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n*     the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n*     default value is 0.5. For 'aggressive' set to 0.9 to permit\n*     convergence on extremely ill-conditioned matrices. See LAWN 165\n*     for more details.\n*\n*     DZ_UB          (input) REAL\n*     Determines when to start considering componentwise convergence.\n*     Componentwise convergence is only considered after each component\n*     of the solution Y is stable, which we definte as the relative\n*     change in each component being less than DZ_UB. The default value\n*     is 0.25, requiring the first bit to be stable. See LAWN 165 for\n*     more details.\n*\n*     IGNORE_CWISE   (input) LOGICAL\n*     If .TRUE. then ignore componentwise convergence. Default value\n*     is .FALSE..\n*\n*     INFO           (output) INTEGER\n*       = 0:  Successful exit.\n*       < 0:  if INFO = -i, the ith argument to CHETRS had an illegal\n*             value\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            UPLO2, CNT, I, J, X_STATE, Z_STATE,\n     $                   Y_PREC_STATE\n      REAL               YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n     $                   DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n     $                   DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n     $                   EPS, HUGEVAL, INCR_THRESH\n      LOGICAL            INCR_PREC\n      COMPLEX            ZDUM\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.cla_herfsx_extended( prec_type, uplo, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 21 && argc != 21)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 21)", argc);
  rblapack_prec_type = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_colequ = argv[5];
  rblapack_c = argv[6];
  rblapack_b = argv[7];
  rblapack_y = argv[8];
  rblapack_n_norms = argv[9];
  rblapack_err_bnds_norm = argv[10];
  rblapack_err_bnds_comp = argv[11];
  rblapack_res = argv[12];
  rblapack_ayb = argv[13];
  rblapack_dy = argv[14];
  rblapack_y_tail = argv[15];
  rblapack_rcond = argv[16];
  rblapack_ithresh = argv[17];
  rblapack_rthresh = argv[18];
  rblapack_dz_ub = argv[19];
  rblapack_ignore_cwise = argv[20];
  if (argc == 21) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  prec_type = NUM2INT(rblapack_prec_type);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (9th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 2)
    rb_raise(rb_eArgError, "rank of y (9th argument) must be %d", 2);
  ldy = NA_SHAPE0(rblapack_y);
  nrhs = NA_SHAPE1(rblapack_y);
  if (NA_TYPE(rblapack_y) != NA_SCOMPLEX)
    rblapack_y = na_change_type(rblapack_y, NA_SCOMPLEX);
  y = NA_PTR_TYPE(rblapack_y, complex*);
  if (!NA_IsNArray(rblapack_err_bnds_norm))
    rb_raise(rb_eArgError, "err_bnds_norm (11th argument) must be NArray");
  if (NA_RANK(rblapack_err_bnds_norm) != 2)
    rb_raise(rb_eArgError, "rank of err_bnds_norm (11th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_err_bnds_norm) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of y");
  n_err_bnds = NA_SHAPE1(rblapack_err_bnds_norm);
  if (NA_TYPE(rblapack_err_bnds_norm) != NA_SFLOAT)
    rblapack_err_bnds_norm = na_change_type(rblapack_err_bnds_norm, NA_SFLOAT);
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
  if (!NA_IsNArray(rblapack_res))
    rb_raise(rb_eArgError, "res (13th argument) must be NArray");
  if (NA_RANK(rblapack_res) != 1)
    rb_raise(rb_eArgError, "rank of res (13th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_res) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_res) != NA_SCOMPLEX)
    rblapack_res = na_change_type(rblapack_res, NA_SCOMPLEX);
  res = NA_PTR_TYPE(rblapack_res, complex*);
  if (!NA_IsNArray(rblapack_dy))
    rb_raise(rb_eArgError, "dy (15th argument) must be NArray");
  if (NA_RANK(rblapack_dy) != 1)
    rb_raise(rb_eArgError, "rank of dy (15th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dy) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_dy) != NA_SCOMPLEX)
    rblapack_dy = na_change_type(rblapack_dy, NA_SCOMPLEX);
  dy = NA_PTR_TYPE(rblapack_dy, complex*);
  rcond = (real)NUM2DBL(rblapack_rcond);
  rthresh = (real)NUM2DBL(rblapack_rthresh);
  ignore_cwise = (rblapack_ignore_cwise == Qtrue);
  uplo = StringValueCStr(rblapack_uplo)[0];
  colequ = (rblapack_colequ == Qtrue);
  n_norms = NUM2INT(rblapack_n_norms);
  if (!NA_IsNArray(rblapack_ayb))
    rb_raise(rb_eArgError, "ayb (14th argument) must be NArray");
  if (NA_RANK(rblapack_ayb) != 1)
    rb_raise(rb_eArgError, "rank of ayb (14th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ayb) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ayb) != NA_SFLOAT)
    rblapack_ayb = na_change_type(rblapack_ayb, NA_SFLOAT);
  ayb = NA_PTR_TYPE(rblapack_ayb, real*);
  ithresh = NUM2INT(rblapack_ithresh);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  if (!NA_IsNArray(rblapack_err_bnds_comp))
    rb_raise(rb_eArgError, "err_bnds_comp (12th argument) must be NArray");
  if (NA_RANK(rblapack_err_bnds_comp) != 2)
    rb_raise(rb_eArgError, "rank of err_bnds_comp (12th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_err_bnds_comp) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of y");
  if (NA_SHAPE1(rblapack_err_bnds_comp) != n_err_bnds)
    rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_comp must be the same as shape 1 of err_bnds_norm");
  if (NA_TYPE(rblapack_err_bnds_comp) != NA_SFLOAT)
    rblapack_err_bnds_comp = na_change_type(rblapack_err_bnds_comp, NA_SFLOAT);
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
  dz_ub = (real)NUM2DBL(rblapack_dz_ub);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of y");
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (!NA_IsNArray(rblapack_y_tail))
    rb_raise(rb_eArgError, "y_tail (16th argument) must be NArray");
  if (NA_RANK(rblapack_y_tail) != 1)
    rb_raise(rb_eArgError, "rank of y_tail (16th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y_tail) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_y_tail) != NA_SCOMPLEX)
    rblapack_y_tail = na_change_type(rblapack_y_tail, NA_SCOMPLEX);
  y_tail = NA_PTR_TYPE(rblapack_y_tail, complex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr_out = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr_out = NA_PTR_TYPE(rblapack_berr_out, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldy;
    shape[1] = nrhs;
    rblapack_y_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, complex*);
  MEMCPY(y_out__, y, complex, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm_out__ = NA_PTR_TYPE(rblapack_err_bnds_norm_out__, real*);
  MEMCPY(err_bnds_norm_out__, err_bnds_norm, real, NA_TOTAL(rblapack_err_bnds_norm));
  rblapack_err_bnds_norm = rblapack_err_bnds_norm_out__;
  err_bnds_norm = err_bnds_norm_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp_out__ = NA_PTR_TYPE(rblapack_err_bnds_comp_out__, real*);
  MEMCPY(err_bnds_comp_out__, err_bnds_comp, real, NA_TOTAL(rblapack_err_bnds_comp));
  rblapack_err_bnds_comp = rblapack_err_bnds_comp_out__;
  err_bnds_comp = err_bnds_comp_out__;

  cla_herfsx_extended_(&prec_type, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_err_bnds_norm, rblapack_err_bnds_comp);
}

void
init_lapack_cla_herfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cla_herfsx_extended", rblapack_cla_herfsx_extended, -1);
}
ruby-lapack-1.7.2/ext/clarrv.c0000644000175000017500000004122512655767573016057 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clarrv_(integer* n, real* vl, real* vu, real* d, real* l, real* pivmin, integer* isplit, integer* m, integer* dol, integer* dou, real* minrgp, real* rtol1, real* rtol2, real* w, real* werr, real* wgap, integer* iblock, integer* indexw, real* gers, complex* z, integer* ldz, integer* isuppz, real* work, integer* iwork, integer* info);


static VALUE
rblapack_clarrv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_vl;
  real vl; 
  VALUE rblapack_vu;
  real vu; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_l;
  real *l; 
  VALUE rblapack_pivmin;
  real pivmin; 
  VALUE rblapack_isplit;
  integer *isplit; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_dol;
  integer dol; 
  VALUE rblapack_dou;
  integer dou; 
  VALUE rblapack_minrgp;
  real minrgp; 
  VALUE rblapack_rtol1;
  real rtol1; 
  VALUE rblapack_rtol2;
  real rtol2; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_werr;
  real *werr; 
  VALUE rblapack_wgap;
  real *wgap; 
  VALUE rblapack_iblock;
  integer *iblock; 
  VALUE rblapack_indexw;
  integer *indexw; 
  VALUE rblapack_gers;
  real *gers; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_isuppz;
  integer *isuppz; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_l_out__;
  real *l_out__;
  VALUE rblapack_w_out__;
  real *w_out__;
  VALUE rblapack_werr_out__;
  real *werr_out__;
  VALUE rblapack_wgap_out__;
  real *wgap_out__;
  real *work;
  integer *iwork;

  integer n;
  integer ldz;

  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  z, isuppz, info, d, l, w, werr, wgap = NumRu::Lapack.clarrv( vl, vu, d, l, pivmin, isplit, m, dol, dou, minrgp, rtol1, rtol2, w, werr, wgap, iblock, indexw, gers, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLARRV( N, VL, VU, D, L, PIVMIN, ISPLIT, M, DOL, DOU, MINRGP, RTOL1, RTOL2, W, WERR, WGAP, IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CLARRV computes the eigenvectors of the tridiagonal matrix\n*  T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T.\n*  The input eigenvalues should have been computed by SLARRE.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  VL      (input) REAL            \n*  VU      (input) REAL            \n*          Lower and upper bounds of the interval that contains the desired\n*          eigenvalues. VL < VU. Needed to compute gaps on the left or right\n*          end of the extremal eigenvalues in the desired RANGE.\n*\n*  D       (input/output) REAL             array, dimension (N)\n*          On entry, the N diagonal elements of the diagonal matrix D.\n*          On exit, D may be overwritten.\n*\n*  L       (input/output) REAL             array, dimension (N)\n*          On entry, the (N-1) subdiagonal elements of the unit\n*          bidiagonal matrix L are in elements 1 to N-1 of L\n*          (if the matrix is not split.) At the end of each block\n*          is stored the corresponding shift as given by SLARRE.\n*          On exit, L is overwritten.\n*\n*  PIVMIN  (in) DOUBLE PRECISION\n*          The minimum pivot allowed in the Sturm sequence.\n*\n*  ISPLIT  (input) INTEGER array, dimension (N)\n*          The splitting points, at which T breaks up into blocks.\n*          The first block consists of rows/columns 1 to\n*          ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n*          through ISPLIT( 2 ), etc.\n*\n*  M       (input) INTEGER\n*          The total number of input eigenvalues.  0 <= M <= N.\n*\n*  DOL     (input) INTEGER\n*  DOU     (input) INTEGER\n*          If the user wants to compute only selected eigenvectors from all\n*          the eigenvalues supplied, he can specify an index range DOL:DOU.\n*          Or else the setting DOL=1, DOU=M should be applied.\n*          Note that DOL and DOU refer to the order in which the eigenvalues\n*          are stored in W.\n*          If the user wants to compute only selected eigenpairs, then\n*          the columns DOL-1 to DOU+1 of the eigenvector space Z contain the\n*          computed eigenvectors. All other columns of Z are set to zero.\n*\n*  MINRGP  (input) REAL            \n*\n*  RTOL1   (input) REAL            \n*  RTOL2   (input) REAL            \n*           Parameters for bisection.\n*           An interval [LEFT,RIGHT] has converged if\n*           RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n*\n*  W       (input/output) REAL             array, dimension (N)\n*          The first M elements of W contain the APPROXIMATE eigenvalues for\n*          which eigenvectors are to be computed.  The eigenvalues\n*          should be grouped by split-off block and ordered from\n*          smallest to largest within the block ( The output array\n*          W from SLARRE is expected here ). Furthermore, they are with\n*          respect to the shift of the corresponding root representation\n*          for their block. On exit, W holds the eigenvalues of the\n*          UNshifted matrix.\n*\n*  WERR    (input/output) REAL             array, dimension (N)\n*          The first M elements contain the semiwidth of the uncertainty\n*          interval of the corresponding eigenvalue in W\n*\n*  WGAP    (input/output) REAL             array, dimension (N)\n*          The separation from the right neighbor eigenvalue in W.\n*\n*  IBLOCK  (input) INTEGER array, dimension (N)\n*          The indices of the blocks (submatrices) associated with the\n*          corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue\n*          W(i) belongs to the first block from the top, =2 if W(i)\n*          belongs to the second block, etc.\n*\n*  INDEXW  (input) INTEGER array, dimension (N)\n*          The indices of the eigenvalues within each block (submatrix);\n*          for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the\n*          i-th eigenvalue W(i) is the 10-th eigenvalue in the second block.\n*\n*  GERS    (input) REAL             array, dimension (2*N)\n*          The N Gerschgorin intervals (the i-th Gerschgorin interval\n*          is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should\n*          be computed from the original UNshifted matrix.\n*\n*  Z       (output) COMPLEX          array, dimension (LDZ, max(1,M) )\n*          If INFO = 0, the first M columns of Z contain the\n*          orthonormal eigenvectors of the matrix T\n*          corresponding to the input eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  ISUPPZ  (output) INTEGER array, dimension ( 2*max(1,M) )\n*          The support of the eigenvectors in Z, i.e., the indices\n*          indicating the nonzero elements in Z. The I-th eigenvector\n*          is nonzero only in elements ISUPPZ( 2*I-1 ) through\n*          ISUPPZ( 2*I ).\n*\n*  WORK    (workspace) REAL             array, dimension (12*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (7*N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*\n*          > 0:  A problem occured in CLARRV.\n*          < 0:  One of the called subroutines signaled an internal problem.\n*                Needs inspection of the corresponding parameter IINFO\n*                for further information.\n*\n*          =-1:  Problem in SLARRB when refining a child's eigenvalues.\n*          =-2:  Problem in SLARRF when computing the RRR of a child.\n*                When a child is inside a tight cluster, it can be difficult\n*                to find an RRR. A partial remedy from the user's point of\n*                view is to make the parameter MINRGP smaller and recompile.\n*                However, as the orthogonality of the computed vectors is\n*                proportional to 1/MINRGP, the user should be aware that\n*                he might be trading in precision when he decreases MINRGP.\n*          =-3:  Problem in SLARRB when refining a single eigenvalue\n*                after the Rayleigh correction was rejected.\n*          = 5:  The Rayleigh Quotient Iteration failed to converge to\n*                full accuracy in MAXITR steps.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Beresford Parlett, University of California, Berkeley, USA\n*     Jim Demmel, University of California, Berkeley, USA\n*     Inderjit Dhillon, University of Texas, Austin, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  z, isuppz, info, d, l, w, werr, wgap = NumRu::Lapack.clarrv( vl, vu, d, l, pivmin, isplit, m, dol, dou, minrgp, rtol1, rtol2, w, werr, wgap, iblock, indexw, gers, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 18 && argc != 18)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 18)", argc);
  rblapack_vl = argv[0];
  rblapack_vu = argv[1];
  rblapack_d = argv[2];
  rblapack_l = argv[3];
  rblapack_pivmin = argv[4];
  rblapack_isplit = argv[5];
  rblapack_m = argv[6];
  rblapack_dol = argv[7];
  rblapack_dou = argv[8];
  rblapack_minrgp = argv[9];
  rblapack_rtol1 = argv[10];
  rblapack_rtol2 = argv[11];
  rblapack_w = argv[12];
  rblapack_werr = argv[13];
  rblapack_wgap = argv[14];
  rblapack_iblock = argv[15];
  rblapack_indexw = argv[16];
  rblapack_gers = argv[17];
  if (argc == 18) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  vl = (real)NUM2DBL(rblapack_vl);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  pivmin = (real)NUM2DBL(rblapack_pivmin);
  m = NUM2INT(rblapack_m);
  dou = NUM2INT(rblapack_dou);
  rtol1 = (real)NUM2DBL(rblapack_rtol1);
  if (!NA_IsNArray(rblapack_w))
    rb_raise(rb_eArgError, "w (13th argument) must be NArray");
  if (NA_RANK(rblapack_w) != 1)
    rb_raise(rb_eArgError, "rank of w (13th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_w) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_w) != NA_SFLOAT)
    rblapack_w = na_change_type(rblapack_w, NA_SFLOAT);
  w = NA_PTR_TYPE(rblapack_w, real*);
  if (!NA_IsNArray(rblapack_wgap))
    rb_raise(rb_eArgError, "wgap (15th argument) must be NArray");
  if (NA_RANK(rblapack_wgap) != 1)
    rb_raise(rb_eArgError, "rank of wgap (15th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_wgap) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of wgap must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_wgap) != NA_SFLOAT)
    rblapack_wgap = na_change_type(rblapack_wgap, NA_SFLOAT);
  wgap = NA_PTR_TYPE(rblapack_wgap, real*);
  if (!NA_IsNArray(rblapack_indexw))
    rb_raise(rb_eArgError, "indexw (17th argument) must be NArray");
  if (NA_RANK(rblapack_indexw) != 1)
    rb_raise(rb_eArgError, "rank of indexw (17th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_indexw) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of indexw must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_indexw) != NA_LINT)
    rblapack_indexw = na_change_type(rblapack_indexw, NA_LINT);
  indexw = NA_PTR_TYPE(rblapack_indexw, integer*);
  vu = (real)NUM2DBL(rblapack_vu);
  if (!NA_IsNArray(rblapack_isplit))
    rb_raise(rb_eArgError, "isplit (6th argument) must be NArray");
  if (NA_RANK(rblapack_isplit) != 1)
    rb_raise(rb_eArgError, "rank of isplit (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_isplit) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of isplit must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_isplit) != NA_LINT)
    rblapack_isplit = na_change_type(rblapack_isplit, NA_LINT);
  isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
  minrgp = (real)NUM2DBL(rblapack_minrgp);
  if (!NA_IsNArray(rblapack_werr))
    rb_raise(rb_eArgError, "werr (14th argument) must be NArray");
  if (NA_RANK(rblapack_werr) != 1)
    rb_raise(rb_eArgError, "rank of werr (14th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_werr) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of werr must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_werr) != NA_SFLOAT)
    rblapack_werr = na_change_type(rblapack_werr, NA_SFLOAT);
  werr = NA_PTR_TYPE(rblapack_werr, real*);
  if (!NA_IsNArray(rblapack_l))
    rb_raise(rb_eArgError, "l (4th argument) must be NArray");
  if (NA_RANK(rblapack_l) != 1)
    rb_raise(rb_eArgError, "rank of l (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_l) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of l must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_l) != NA_SFLOAT)
    rblapack_l = na_change_type(rblapack_l, NA_SFLOAT);
  l = NA_PTR_TYPE(rblapack_l, real*);
  rtol2 = (real)NUM2DBL(rblapack_rtol2);
  dol = NUM2INT(rblapack_dol);
  if (!NA_IsNArray(rblapack_iblock))
    rb_raise(rb_eArgError, "iblock (16th argument) must be NArray");
  if (NA_RANK(rblapack_iblock) != 1)
    rb_raise(rb_eArgError, "rank of iblock (16th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_iblock) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of iblock must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_iblock) != NA_LINT)
    rblapack_iblock = na_change_type(rblapack_iblock, NA_LINT);
  iblock = NA_PTR_TYPE(rblapack_iblock, integer*);
  ldz = n;
  if (!NA_IsNArray(rblapack_gers))
    rb_raise(rb_eArgError, "gers (18th argument) must be NArray");
  if (NA_RANK(rblapack_gers) != 1)
    rb_raise(rb_eArgError, "rank of gers (18th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_gers) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of gers must be %d", 2*n);
  if (NA_TYPE(rblapack_gers) != NA_SFLOAT)
    rblapack_gers = na_change_type(rblapack_gers, NA_SFLOAT);
  gers = NA_PTR_TYPE(rblapack_gers, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, complex*);
  {
    na_shape_t shape[1];
    shape[0] = 2*MAX(1,m);
    rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_l_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  l_out__ = NA_PTR_TYPE(rblapack_l_out__, real*);
  MEMCPY(l_out__, l, real, NA_TOTAL(rblapack_l));
  rblapack_l = rblapack_l_out__;
  l = l_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w_out__ = NA_PTR_TYPE(rblapack_w_out__, real*);
  MEMCPY(w_out__, w, real, NA_TOTAL(rblapack_w));
  rblapack_w = rblapack_w_out__;
  w = w_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_werr_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  werr_out__ = NA_PTR_TYPE(rblapack_werr_out__, real*);
  MEMCPY(werr_out__, werr, real, NA_TOTAL(rblapack_werr));
  rblapack_werr = rblapack_werr_out__;
  werr = werr_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wgap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  wgap_out__ = NA_PTR_TYPE(rblapack_wgap_out__, real*);
  MEMCPY(wgap_out__, wgap, real, NA_TOTAL(rblapack_wgap));
  rblapack_wgap = rblapack_wgap_out__;
  wgap = wgap_out__;
  work = ALLOC_N(real, (12*n));
  iwork = ALLOC_N(integer, (7*n));

  clarrv_(&n, &vl, &vu, d, l, &pivmin, isplit, &m, &dol, &dou, &minrgp, &rtol1, &rtol2, w, werr, wgap, iblock, indexw, gers, z, &ldz, isuppz, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_z, rblapack_isuppz, rblapack_info, rblapack_d, rblapack_l, rblapack_w, rblapack_werr, rblapack_wgap);
}

void
init_lapack_clarrv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clarrv", rblapack_clarrv, -1);
}
ruby-lapack-1.7.2/ext/zrot.c0000644000175000017500000001133112502221013015514 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zrot_(integer* n, doublecomplex* cx, integer* incx, doublecomplex* cy, integer* incy, doublereal* c, doublecomplex* s);


static VALUE
rblapack_zrot(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_cx;
  doublecomplex *cx; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_cy;
  doublecomplex *cy; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_c;
  doublereal c; 
  VALUE rblapack_s;
  doublecomplex s; 
  VALUE rblapack_cx_out__;
  doublecomplex *cx_out__;
  VALUE rblapack_cy_out__;
  doublecomplex *cy_out__;

  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  cx, cy = NumRu::Lapack.zrot( cx, incx, cy, incy, c, s, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S )\n\n*  Purpose\n*  =======\n*\n*  ZROT   applies a plane rotation, where the cos (C) is real and the\n*  sin (S) is complex, and the vectors CX and CY are complex.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of elements in the vectors CX and CY.\n*\n*  CX      (input/output) COMPLEX*16 array, dimension (N)\n*          On input, the vector X.\n*          On output, CX is overwritten with C*X + S*Y.\n*\n*  INCX    (input) INTEGER\n*          The increment between successive values of CY.  INCX <> 0.\n*\n*  CY      (input/output) COMPLEX*16 array, dimension (N)\n*          On input, the vector Y.\n*          On output, CY is overwritten with -CONJG(S)*X + C*Y.\n*\n*  INCY    (input) INTEGER\n*          The increment between successive values of CY.  INCX <> 0.\n*\n*  C       (input) DOUBLE PRECISION\n*  S       (input) COMPLEX*16\n*          C and S define a rotation\n*             [  C          S  ]\n*             [ -conjg(S)   C  ]\n*          where C*C + S*CONJG(S) = 1.0.\n*\n\n* =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, IX, IY\n      COMPLEX*16         STEMP\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          DCONJG\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  cx, cy = NumRu::Lapack.zrot( cx, incx, cy, incy, c, s, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_cx = argv[0];
  rblapack_incx = argv[1];
  rblapack_cy = argv[2];
  rblapack_incy = argv[3];
  rblapack_c = argv[4];
  rblapack_s = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_cx))
    rb_raise(rb_eArgError, "cx (1th argument) must be NArray");
  if (NA_RANK(rblapack_cx) != 1)
    rb_raise(rb_eArgError, "rank of cx (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_cx);
  if (NA_TYPE(rblapack_cx) != NA_DCOMPLEX)
    rblapack_cx = na_change_type(rblapack_cx, NA_DCOMPLEX);
  cx = NA_PTR_TYPE(rblapack_cx, doublecomplex*);
  if (!NA_IsNArray(rblapack_cy))
    rb_raise(rb_eArgError, "cy (3th argument) must be NArray");
  if (NA_RANK(rblapack_cy) != 1)
    rb_raise(rb_eArgError, "rank of cy (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_cy) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of cy must be the same as shape 0 of cx");
  if (NA_TYPE(rblapack_cy) != NA_DCOMPLEX)
    rblapack_cy = na_change_type(rblapack_cy, NA_DCOMPLEX);
  cy = NA_PTR_TYPE(rblapack_cy, doublecomplex*);
  c = NUM2DBL(rblapack_c);
  incx = NUM2INT(rblapack_incx);
  s.r = NUM2DBL(rb_funcall(rblapack_s, rb_intern("real"), 0));
  s.i = NUM2DBL(rb_funcall(rblapack_s, rb_intern("imag"), 0));
  incy = NUM2INT(rblapack_incy);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_cx_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  cx_out__ = NA_PTR_TYPE(rblapack_cx_out__, doublecomplex*);
  MEMCPY(cx_out__, cx, doublecomplex, NA_TOTAL(rblapack_cx));
  rblapack_cx = rblapack_cx_out__;
  cx = cx_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_cy_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  cy_out__ = NA_PTR_TYPE(rblapack_cy_out__, doublecomplex*);
  MEMCPY(cy_out__, cy, doublecomplex, NA_TOTAL(rblapack_cy));
  rblapack_cy = rblapack_cy_out__;
  cy = cy_out__;

  zrot_(&n, cx, &incx, cy, &incy, &c, &s);

  return rb_ary_new3(2, rblapack_cx, rblapack_cy);
}

void
init_lapack_zrot(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zrot", rblapack_zrot, -1);
}
ruby-lapack-1.7.2/ext/dtprfs.c0000644000175000017500000001645312502221020016030 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtprfs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, doublereal* ap, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dtprfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  doublereal *work;
  integer *iwork;

  integer ldb;
  integer nrhs;
  integer ldx;
  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  ferr, berr, info = NumRu::Lapack.dtprfs( uplo, trans, diag, ap, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTPRFS provides error bounds and backward error estimates for the\n*  solution to a system of linear equations with a triangular packed\n*  coefficient matrix.\n*\n*  The solution matrix X must be computed by DTPTRS or some other\n*  means before entering this routine.  DTPRFS does not do iterative\n*  refinement because doing so cannot improve the backward error.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B  (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          The upper or lower triangular matrix A, packed columnwise in\n*          a linear array.  The j-th column of A is stored in the array\n*          AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*          If DIAG = 'U', the diagonal elements of A are not referenced\n*          and are assumed to be 1.\n*\n*  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*          The solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info = NumRu::Lapack.dtprfs( uplo, trans, diag, ap, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_ap = argv[3];
  rblapack_b = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  n = ldb;
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  work = ALLOC_N(doublereal, (3*n));
  iwork = ALLOC_N(integer, (n));

  dtprfs_(&uplo, &trans, &diag, &n, &nrhs, ap, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ferr, rblapack_berr, rblapack_info);
}

void
init_lapack_dtprfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtprfs", rblapack_dtprfs, -1);
}
ruby-lapack-1.7.2/ext/zhetrd.c0000644000175000017500000001745112502221014016030 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhetrd_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublereal* d, doublereal* e, doublecomplex* tau, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zhetrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *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  d, e, tau, work, info, a = NumRu::Lapack.zhetrd( uplo, a, lwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHETRD reduces a complex Hermitian matrix A to real symmetric\n*  tridiagonal form T by a unitary similarity transformation:\n*  Q**H * A * Q = T.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*          On exit, if UPLO = 'U', the diagonal and first superdiagonal\n*          of A are overwritten by the corresponding elements of the\n*          tridiagonal matrix T, and the elements above the first\n*          superdiagonal, with the array TAU, represent the unitary\n*          matrix Q as a product of elementary reflectors; if UPLO\n*          = 'L', the diagonal and first subdiagonal of A are over-\n*          written by the corresponding elements of the tridiagonal\n*          matrix T, and the elements below the first subdiagonal, with\n*          the array TAU, represent the unitary matrix Q as a product\n*          of elementary reflectors. See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  D       (output) DOUBLE PRECISION array, dimension (N)\n*          The diagonal elements of the tridiagonal matrix T:\n*          D(i) = A(i,i).\n*\n*  E       (output) DOUBLE PRECISION array, dimension (N-1)\n*          The off-diagonal elements of the tridiagonal matrix T:\n*          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n*  TAU     (output) COMPLEX*16 array, dimension (N-1)\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace/output) COMPLEX*16 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 >= 1.\n*          For optimum performance LWORK >= N*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*  If UPLO = 'U', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(n-1) . . . H(2) H(1).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - tau * v * v'\n*\n*  where tau is a complex scalar, and v is a complex vector with\n*  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n*  A(1:i-1,i+1), and tau in TAU(i).\n*\n*  If UPLO = 'L', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(1) H(2) . . . H(n-1).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - tau * v * v'\n*\n*  where tau is a complex scalar, and v is a complex vector with\n*  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n*  and tau in TAU(i).\n*\n*  The contents of A on exit are illustrated by the following examples\n*  with n = 5:\n*\n*  if UPLO = 'U':                       if UPLO = 'L':\n*\n*    (  d   e   v2  v3  v4 )              (  d                  )\n*    (      d   e   v3  v4 )              (  e   d              )\n*    (          d   e   v4 )              (  v1  e   d          )\n*    (              d   e  )              (  v1  v2  e   d      )\n*    (                  d  )              (  v1  v2  v3  e   d  )\n*\n*  where d and e denote diagonal and off-diagonal elements of T, and vi\n*  denotes an element of the vector defining H(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, tau, work, info, a = NumRu::Lapack.zhetrd( uplo, a, lwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_lwork = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  lwork = NUM2INT(rblapack_lwork);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zhetrd_(&uplo, &n, a, &lda, d, e, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_d, rblapack_e, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_zhetrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhetrd", rblapack_zhetrd, -1);
}
ruby-lapack-1.7.2/ext/dlabrd.c0000644000175000017500000002137512502221017015763 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlabrd_(integer* m, integer* n, integer* nb, doublereal* a, integer* lda, doublereal* d, doublereal* e, doublereal* tauq, doublereal* taup, doublereal* x, integer* ldx, doublereal* y, integer* ldy);


static VALUE
rblapack_dlabrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_nb;
  integer nb; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_tauq;
  doublereal *tauq; 
  VALUE rblapack_taup;
  doublereal *taup; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_y;
  doublereal *y; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;

  integer lda;
  integer n;
  integer ldx;
  integer ldy;

  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  d, e, tauq, taup, x, y, a = NumRu::Lapack.dlabrd( m, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, LDY )\n\n*  Purpose\n*  =======\n*\n*  DLABRD reduces the first NB rows and columns of a real general\n*  m by n matrix A to upper or lower bidiagonal form by an orthogonal\n*  transformation Q' * A * P, and returns the matrices X and Y which\n*  are needed to apply the transformation to the unreduced part of A.\n*\n*  If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower\n*  bidiagonal form.\n*\n*  This is an auxiliary routine called by DGEBRD\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows in the matrix A.\n*\n*  N       (input) INTEGER\n*          The number of columns in the matrix A.\n*\n*  NB      (input) INTEGER\n*          The number of leading rows and columns of A to be reduced.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the m by n general matrix to be reduced.\n*          On exit, the first NB rows and columns of the matrix are\n*          overwritten; the rest of the array is unchanged.\n*          If m >= n, elements on and below the diagonal in the first NB\n*            columns, with the array TAUQ, represent the orthogonal\n*            matrix Q as a product of elementary reflectors; and\n*            elements above the diagonal in the first NB rows, with the\n*            array TAUP, represent the orthogonal matrix P as a product\n*            of elementary reflectors.\n*          If m < n, elements below the diagonal in the first NB\n*            columns, with the array TAUQ, represent the orthogonal\n*            matrix Q as a product of elementary reflectors, and\n*            elements on and above the diagonal in the first NB rows,\n*            with the array TAUP, represent the orthogonal matrix P as\n*            a product of elementary reflectors.\n*          See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  D       (output) DOUBLE PRECISION array, dimension (NB)\n*          The diagonal elements of the first NB rows and columns of\n*          the reduced matrix.  D(i) = A(i,i).\n*\n*  E       (output) DOUBLE PRECISION array, dimension (NB)\n*          The off-diagonal elements of the first NB rows and columns of\n*          the reduced matrix.\n*\n*  TAUQ    (output) DOUBLE PRECISION array dimension (NB)\n*          The scalar factors of the elementary reflectors which\n*          represent the orthogonal matrix Q. See Further Details.\n*\n*  TAUP    (output) DOUBLE PRECISION array, dimension (NB)\n*          The scalar factors of the elementary reflectors which\n*          represent the orthogonal matrix P. See Further Details.\n*\n*  X       (output) DOUBLE PRECISION array, dimension (LDX,NB)\n*          The m-by-nb matrix X required to update the unreduced part\n*          of A.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X. LDX >= M.\n*\n*  Y       (output) DOUBLE PRECISION array, dimension (LDY,NB)\n*          The n-by-nb matrix Y required to update the unreduced part\n*          of A.\n*\n*  LDY     (input) INTEGER\n*          The leading dimension of the array Y. LDY >= N.\n*\n\n*  Further Details\n*  ===============\n*\n*  The matrices Q and P are represented as products of elementary\n*  reflectors:\n*\n*     Q = H(1) H(2) . . . H(nb)  and  P = G(1) G(2) . . . G(nb)\n*\n*  Each H(i) and G(i) has the form:\n*\n*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'\n*\n*  where tauq and taup are real scalars, and v and u are real vectors.\n*\n*  If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in\n*  A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in\n*  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n*  If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in\n*  A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in\n*  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n*  The elements of the vectors v and u together form the m-by-nb matrix\n*  V and the nb-by-n matrix U' which are needed, with X and Y, to apply\n*  the transformation to the unreduced part of the matrix, using a block\n*  update of the form:  A := A - V*Y' - X*U'.\n*\n*  The contents of A on exit are illustrated by the following examples\n*  with nb = 2:\n*\n*  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):\n*\n*    (  1   1   u1  u1  u1 )           (  1   u1  u1  u1  u1  u1 )\n*    (  v1  1   1   u2  u2 )           (  1   1   u2  u2  u2  u2 )\n*    (  v1  v2  a   a   a  )           (  v1  1   a   a   a   a  )\n*    (  v1  v2  a   a   a  )           (  v1  v2  a   a   a   a  )\n*    (  v1  v2  a   a   a  )           (  v1  v2  a   a   a   a  )\n*    (  v1  v2  a   a   a  )\n*\n*  where a denotes an element of the original matrix which is unchanged,\n*  vi denotes an element of the vector defining H(i), and ui an element\n*  of the vector defining G(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, tauq, taup, x, y, a = NumRu::Lapack.dlabrd( m, nb, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_m = argv[0];
  rblapack_nb = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  ldy = n;
  nb = NUM2INT(rblapack_nb);
  ldx = m;
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,nb);
    rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,nb);
    rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,nb);
    rblapack_tauq = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  tauq = NA_PTR_TYPE(rblapack_tauq, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,nb);
    rblapack_taup = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  taup = NA_PTR_TYPE(rblapack_taup, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = MAX(1,nb);
    rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldy;
    shape[1] = MAX(1,nb);
    rblapack_y = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  y = NA_PTR_TYPE(rblapack_y, doublereal*);
  {
    na_shape_t 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__;

  dlabrd_(&m, &n, &nb, a, &lda, d, e, tauq, taup, x, &ldx, y, &ldy);

  return rb_ary_new3(7, rblapack_d, rblapack_e, rblapack_tauq, rblapack_taup, rblapack_x, rblapack_y, rblapack_a);
}

void
init_lapack_dlabrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlabrd", rblapack_dlabrd, -1);
}
ruby-lapack-1.7.2/ext/zhegst.c0000644000175000017500000001223412502221017016031 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhegst_(integer* itype, char* uplo, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, integer* info);


static VALUE
rblapack_zhegst(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;

  integer lda;
  integer n;
  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  info, a = NumRu::Lapack.zhegst( itype, uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHEGST reduces a complex Hermitian-definite generalized\n*  eigenproblem to standard form.\n*\n*  If ITYPE = 1, the problem is A*x = lambda*B*x,\n*  and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)\n*\n*  If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n*  B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L.\n*\n*  B must have been previously factorized as U**H*U or L*L**H by ZPOTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);\n*          = 2 or 3: compute U*A*U**H or L**H*A*L.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored and B is factored as\n*                  U**H*U;\n*          = 'L':  Lower triangle of A is stored and B is factored as\n*                  L*L**H.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the transformed matrix, stored in the\n*          same format as A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input) COMPLEX*16 array, dimension (LDB,N)\n*          The triangular factor from the Cholesky factorization of B,\n*          as returned by ZPOTRF.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.zhegst( itype, uplo, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_itype = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  itype = NUM2INT(rblapack_itype);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zhegst_(&itype, &uplo, &n, a, &lda, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_zhegst(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhegst", rblapack_zhegst, -1);
}
ruby-lapack-1.7.2/ext/zlacp2.c0000644000175000017500000000712312502221023015716 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlacp2_(char* uplo, integer* m, integer* n, doublereal* a, integer* lda, doublecomplex* b, integer* ldb);


static VALUE
rblapack_zlacp2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublecomplex *b; 

  integer lda;
  integer n;
  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  b = NumRu::Lapack.zlacp2( uplo, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLACP2( UPLO, M, N, A, LDA, B, LDB )\n\n*  Purpose\n*  =======\n*\n*  ZLACP2 copies all or part of a real two-dimensional matrix A to a\n*  complex matrix B.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies the part of the matrix A to be copied to B.\n*          = 'U':      Upper triangular part\n*          = 'L':      Lower triangular part\n*          Otherwise:  All of the matrix A\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) DOUBLE PRECISION array, dimension (LDA,N)\n*          The m by n matrix A.  If UPLO = 'U', only the upper trapezium\n*          is accessed; if UPLO = 'L', only the lower trapezium is\n*          accessed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  B       (output) COMPLEX*16 array, dimension (LDB,N)\n*          On exit, B = A in the locations specified by UPLO.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,M).\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  b = NumRu::Lapack.zlacp2( uplo, m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_m = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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);
  ldb = MAX(1,m);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);

  zlacp2_(&uplo, &m, &n, a, &lda, b, &ldb);

  return rblapack_b;
}

void
init_lapack_zlacp2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlacp2", rblapack_zlacp2, -1);
}
ruby-lapack-1.7.2/ext/dppequ.c0000644000175000017500000001066012502221020016016 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dppequ_(char* uplo, integer* n, doublereal* ap, doublereal* s, doublereal* scond, doublereal* amax, integer* info);


static VALUE
rblapack_dppequ(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_scond;
  doublereal scond; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_info;
  integer info; 

  integer ldap;
  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  s, scond, amax, info = NumRu::Lapack.dppequ( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPPEQU computes row and column scalings intended to equilibrate a\n*  symmetric positive definite matrix A in packed storage and reduce\n*  its condition number (with respect to the two-norm).  S contains the\n*  scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix\n*  B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.\n*  This choice of S puts the condition number of B within a factor N of\n*  the smallest possible condition number over all possible diagonal\n*  scalings.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          The upper or lower triangle of the symmetric matrix A, packed\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  S       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, S contains the scale factors for A.\n*\n*  SCOND   (output) DOUBLE PRECISION\n*          If INFO = 0, S contains the ratio of the smallest S(i) to\n*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too\n*          large nor too small, it is not worth scaling by S.\n*\n*  AMAX    (output) DOUBLE PRECISION\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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 is nonpositive.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, scond, amax, info = NumRu::Lapack.dppequ( uplo, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, doublereal*);

  dppequ_(&uplo, &n, ap, s, &scond, &amax, &info);

  rblapack_scond = rb_float_new((double)scond);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
}

void
init_lapack_dppequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dppequ", rblapack_dppequ, -1);
}
ruby-lapack-1.7.2/ext/sgbtf2.c0000644000175000017500000001310712502221022015710 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgbtf2_(integer* m, integer* n, integer* kl, integer* ku, real* ab, integer* ldab, integer* ipiv, integer* info);


static VALUE
rblapack_sgbtf2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  real *ab_out__;

  integer ldab;
  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  ipiv, info, ab = NumRu::Lapack.sgbtf2( m, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGBTF2 computes an LU factorization of a real m-by-n band matrix A\n*  using partial pivoting with row interchanges.\n*\n*  This is the unblocked version of the algorithm, calling Level 2 BLAS.\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*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  AB      (input/output) REAL array, dimension (LDAB,N)\n*          On entry, the matrix A in band storage, in rows KL+1 to\n*          2*KL+KU+1; rows 1 to KL of the array need not be set.\n*          The j-th column of A is stored in the j-th column of the\n*          array AB as follows:\n*          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n*          On exit, details of the factorization: U is stored as an\n*          upper triangular band matrix with KL+KU superdiagonals in\n*          rows 1 to KL+KU+1, and the multipliers used during the\n*          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n*          See below for further details.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.\n*\n*  IPIV    (output) INTEGER array, dimension (min(M,N))\n*          The pivot indices; for 1 <= i <= min(M,N), row i of the\n*          matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n*               has been completed, but the factor U is exactly\n*               singular, and division by zero will occur if it is used\n*               to solve a system of equations.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  M = N = 6, KL = 2, KU = 1:\n*\n*  On entry:                       On exit:\n*\n*      *    *    *    +    +    +       *    *    *   u14  u25  u36\n*      *    *    +    +    +    +       *    *   u13  u24  u35  u46\n*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56\n*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66\n*     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *\n*     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *\n*\n*  Array elements marked * are not used by the routine; elements marked\n*  + need not be set on entry, but are required by the routine to store\n*  elements of U, because of fill-in resulting from the row\n*  interchanges.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, ab = NumRu::Lapack.sgbtf2( m, kl, ku, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_m = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  ku = NUM2INT(rblapack_ku);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
  MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  sgbtf2_(&m, &n, &kl, &ku, ab, &ldab, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_ab);
}

void
init_lapack_sgbtf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgbtf2", rblapack_sgbtf2, -1);
}
ruby-lapack-1.7.2/ext/csptri.c0000644000175000017500000001111312502221026016024 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID csptri_(char* uplo, integer* n, complex* ap, integer* ipiv, complex* work, integer* info);


static VALUE
rblapack_csptri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  complex *ap_out__;
  complex *work;

  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  info, ap = NumRu::Lapack.csptri( uplo, ap, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSPTRI( UPLO, N, AP, IPIV, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CSPTRI computes the inverse of a complex symmetric indefinite matrix\n*  A in packed storage using the factorization A = U*D*U**T or\n*  A = L*D*L**T computed by CSPTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)\n*          On entry, the block diagonal matrix D and the multipliers\n*          used to obtain the factor U or L as computed by CSPTRF,\n*          stored as a packed triangular matrix.\n*\n*          On exit, if INFO = 0, the (symmetric) inverse of the original\n*          matrix, stored as a packed triangular matrix. The j-th column\n*          of inv(A) is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;\n*          if UPLO = 'L',\n*             AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by CSPTRF.\n*\n*  WORK    (workspace) COMPLEX array, dimension (N)\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, D(i,i) = 0; the matrix is singular and its\n*               inverse could not be computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ap = NumRu::Lapack.csptri( uplo, ap, ipiv, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_ipiv = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
  MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  work = ALLOC_N(complex, (n));

  csptri_(&uplo, &n, ap, ipiv, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ap);
}

void
init_lapack_csptri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "csptri", rblapack_csptri, -1);
}
ruby-lapack-1.7.2/ext/slanst.c0000644000175000017500000000734212502221017016035 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real slanst_(char* norm, integer* n, real* d, real* e);


static VALUE
rblapack_slanst(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack___out__;
  real __out__; 

  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  __out__ = NumRu::Lapack.slanst( norm, d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL             FUNCTION SLANST( NORM, N, D, E )\n\n*  Purpose\n*  =======\n*\n*  SLANST  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  real symmetric tridiagonal matrix A.\n*\n*  Description\n*  ===========\n*\n*  SLANST returns the value\n*\n*     SLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in SLANST as described\n*          above.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, SLANST is\n*          set to zero.\n*\n*  D       (input) REAL array, dimension (N)\n*          The diagonal elements of A.\n*\n*  E       (input) REAL array, dimension (N-1)\n*          The (n-1) sub-diagonal or super-diagonal elements of A.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.slanst( norm, d, e, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_norm = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);

  __out__ = slanst_(&norm, &n, d, e);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_slanst(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slanst", rblapack_slanst, -1);
}
ruby-lapack-1.7.2/ext/chptrs.c0000644000175000017500000001163212502221022016025 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chptrs_(char* uplo, integer* n, integer* nrhs, complex* ap, integer* ipiv, complex* b, integer* ldb, integer* info);


static VALUE
rblapack_chptrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.chptrs( uplo, ap, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHPTRS solves a system of linear equations A*X = B with a complex\n*  Hermitian matrix A stored in packed format using the factorization\n*  A = U*D*U**H or A = L*D*L**H computed by CHPTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**H;\n*          = 'L':  Lower triangular, form is A = L*D*L**H.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by CHPTRF, stored as a\n*          packed triangular matrix.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by CHPTRF.\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.chptrs( uplo, ap, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  chptrs_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_chptrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chptrs", rblapack_chptrs, -1);
}
ruby-lapack-1.7.2/ext/zgerq2.c0000644000175000017500000001053512502221024015737 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgerq2_(integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* info);


static VALUE
rblapack_zgerq2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  doublecomplex *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.zgerq2( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGERQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGERQ2 computes an RQ factorization of a complex m by n matrix A:\n*  A = R * 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) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the m by n matrix A.\n*          On exit, if m <= n, the upper triangle of the subarray\n*          A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;\n*          if m >= n, the elements on and above the (m-n)-th subdiagonal\n*          contain the m by n upper trapezoidal matrix R; the remaining\n*          elements, with the array TAU, represent the unitary matrix\n*          Q as a product of elementary reflectors (see Further\n*          Details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  TAU     (output) COMPLEX*16 array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace) COMPLEX*16 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(1)' H(2)' . . . H(k)', 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 complex scalar, and v is a complex vector with\n*  v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on\n*  exit in A(m-k+i,1:n-k+i-1), 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.zgerq2( 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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  m = lda;
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(doublecomplex, (m));

  zgerq2_(&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_zgerq2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgerq2", rblapack_zgerq2, -1);
}
ruby-lapack-1.7.2/ext/cgesdd.c0000644000175000017500000002400112502221023015746 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgesdd_(char* jobz, integer* m, integer* n, complex* a, integer* lda, real* s, complex* u, integer* ldu, complex* vt, integer* ldvt, complex* work, integer* lwork, real* rwork, integer* iwork, integer* info);


static VALUE
rblapack_cgesdd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_u;
  complex *u; 
  VALUE rblapack_vt;
  complex *vt; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  real *rwork;
  integer *iwork;

  integer lda;
  integer n;
  integer ldu;
  integer ucol;
  integer ldvt;
  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  s, u, vt, work, info, a = NumRu::Lapack.cgesdd( jobz, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGESDD computes the singular value decomposition (SVD) of a complex\n*  M-by-N matrix A, optionally computing the left and/or right singular\n*  vectors, by using divide-and-conquer method. The SVD is written\n*\n*       A = U * SIGMA * conjugate-transpose(V)\n*\n*  where SIGMA is an M-by-N matrix which is zero except for its\n*  min(m,n) diagonal elements, U is an M-by-M unitary matrix, and\n*  V is an N-by-N unitary matrix.  The diagonal elements of SIGMA\n*  are the singular values of A; they are real and non-negative, and\n*  are returned in descending order.  The first min(m,n) columns of\n*  U and V are the left and right singular vectors of A.\n*\n*  Note that the routine returns VT = V**H, not V.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          Specifies options for computing all or part of the matrix U:\n*          = 'A':  all M columns of U and all N rows of V**H are\n*                  returned in the arrays U and VT;\n*          = 'S':  the first min(M,N) columns of U and the first\n*                  min(M,N) rows of V**H are returned in the arrays U\n*                  and VT;\n*          = 'O':  If M >= N, the first N columns of U are overwritten\n*                  in the array A and all rows of V**H are returned in\n*                  the array VT;\n*                  otherwise, all columns of U are returned in the\n*                  array U and the first M rows of V**H are overwritten\n*                  in the array A;\n*          = 'N':  no columns of U or rows of V**H are computed.\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.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit,\n*          if JOBZ = 'O',  A is overwritten with the first N columns\n*                          of U (the left singular vectors, stored\n*                          columnwise) if M >= N;\n*                          A is overwritten with the first M rows\n*                          of V**H (the right singular vectors, stored\n*                          rowwise) otherwise.\n*          if JOBZ .ne. 'O', the contents of A are destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  S       (output) REAL array, dimension (min(M,N))\n*          The singular values of A, sorted so that S(i) >= S(i+1).\n*\n*  U       (output) COMPLEX array, dimension (LDU,UCOL)\n*          UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;\n*          UCOL = min(M,N) if JOBZ = 'S'.\n*          If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M\n*          unitary matrix U;\n*          if JOBZ = 'S', U contains the first min(M,N) columns of U\n*          (the left singular vectors, stored columnwise);\n*          if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.\n*\n*  LDU     (input) INTEGER\n*          The leading dimension of the array U.  LDU >= 1; if\n*          JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.\n*\n*  VT      (output) COMPLEX array, dimension (LDVT,N)\n*          If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the\n*          N-by-N unitary matrix V**H;\n*          if JOBZ = 'S', VT contains the first min(M,N) rows of\n*          V**H (the right singular vectors, stored rowwise);\n*          if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.\n*\n*  LDVT    (input) INTEGER\n*          The leading dimension of the array VT.  LDVT >= 1; if\n*          JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;\n*          if JOBZ = 'S', LDVT >= min(M,N).\n*\n*  WORK    (workspace/output) COMPLEX 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 >= 1.\n*          if JOBZ = 'N', LWORK >= 2*min(M,N)+max(M,N).\n*          if JOBZ = 'O',\n*                LWORK >= 2*min(M,N)*min(M,N)+2*min(M,N)+max(M,N).\n*          if JOBZ = 'S' or 'A',\n*                LWORK >= min(M,N)*min(M,N)+2*min(M,N)+max(M,N).\n*          For good performance, LWORK should generally be larger.\n*\n*          If LWORK = -1, a workspace query is assumed.  The optimal\n*          size for the WORK array is calculated and stored in WORK(1),\n*          and no other work except argument checking is performed.\n*\n*  RWORK   (workspace) REAL array, dimension (MAX(1,LRWORK))\n*          If JOBZ = 'N', LRWORK >= 5*min(M,N).\n*          Otherwise, \n*          LRWORK >= min(M,N)*max(5*min(M,N)+7,2*max(M,N)+2*min(M,N)+1)\n*\n*  IWORK   (workspace) INTEGER array, dimension (8*min(M,N))\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit.\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          > 0:  The updating process of SBDSDC did not converge.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, u, vt, work, info, a = NumRu::Lapack.cgesdd( jobz, 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_jobz = 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;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  m = lda;
  ldvt = ((lsame_(&jobz,"A")) || (((lsame_(&jobz,"O")) && (m >= n)))) ? n : lsame_(&jobz,"S") ? MIN(m,n) : 1;
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&jobz,"N") ? 2*MIN(m,n)+MAX(m,n) : lsame_(&jobz,"O") ? 2*MIN(m,n)*MIN(m,n)+2*MIN(m,n)+MAX(m,n) : (lsame_(&jobz,"S")||lsame_(&jobz,"A")) ? MIN(m,n)*MIN(m,n)+2*MIN(m,n)+MAX(m,n) : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldu = (lsame_(&jobz,"S") || lsame_(&jobz,"A") || (lsame_(&jobz,"O") && m < n)) ? m : 1;
  ucol = ((lsame_(&jobz,"A")) || (((lsame_(&jobz,"O")) && (m < n)))) ? m : lsame_(&jobz,"S") ? MIN(m,n) : 0;
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = ucol;
    rblapack_u = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  u = NA_PTR_TYPE(rblapack_u, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvt;
    shape[1] = n;
    rblapack_vt = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  vt = NA_PTR_TYPE(rblapack_vt, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  rwork = ALLOC_N(real, (MAX(1, (lsame_(&jobz,"N") ? 5*MIN(m,n) : MIN(m,n)*MAX(5*MIN(m,n)+7,2*MAX(m,n)+2*MIN(m,n)+1)))));
  iwork = ALLOC_N(integer, (8*MIN(m,n)));

  cgesdd_(&jobz, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, rwork, iwork, &info);

  free(rwork);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_s, rblapack_u, rblapack_vt, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_cgesdd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgesdd", rblapack_cgesdd, -1);
}
ruby-lapack-1.7.2/ext/slaeda.c0000644000175000017500000002203312502221020015746 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaeda_(integer* n, integer* tlvls, integer* curlvl, integer* curpbm, integer* prmptr, integer* perm, integer* givptr, integer* givcol, real* givnum, real* q, integer* qptr, real* z, real* ztemp, integer* info);


static VALUE
rblapack_slaeda(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_tlvls;
  integer tlvls; 
  VALUE rblapack_curlvl;
  integer curlvl; 
  VALUE rblapack_curpbm;
  integer curpbm; 
  VALUE rblapack_prmptr;
  integer *prmptr; 
  VALUE rblapack_perm;
  integer *perm; 
  VALUE rblapack_givptr;
  integer *givptr; 
  VALUE rblapack_givcol;
  integer *givcol; 
  VALUE rblapack_givnum;
  real *givnum; 
  VALUE rblapack_q;
  real *q; 
  VALUE rblapack_qptr;
  integer *qptr; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_info;
  integer info; 
  real *ztemp;

  integer ldqptr;
  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  z, info = NumRu::Lapack.slaeda( tlvls, curlvl, curpbm, prmptr, perm, givptr, givcol, givnum, q, qptr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLAEDA computes the Z vector corresponding to the merge step in the\n*  CURLVLth step of the merge process with TLVLS steps for the CURPBMth\n*  problem.\n*\n\n*  Arguments\n*  =========\n*\n*  N      (input) INTEGER\n*         The dimension of the symmetric tridiagonal matrix.  N >= 0.\n*\n*  TLVLS  (input) INTEGER\n*         The total number of merging levels in the overall divide and\n*         conquer tree.\n*\n*  CURLVL (input) INTEGER\n*         The current level in the overall merge routine,\n*         0 <= curlvl <= tlvls.\n*\n*  CURPBM (input) INTEGER\n*         The current problem in the current level in the overall\n*         merge routine (counting from upper left to lower right).\n*\n*  PRMPTR (input) INTEGER array, dimension (N lg N)\n*         Contains a list of pointers which indicate where in PERM a\n*         level's permutation is stored.  PRMPTR(i+1) - PRMPTR(i)\n*         indicates the size of the permutation and incidentally the\n*         size of the full, non-deflated problem.\n*\n*  PERM   (input) INTEGER array, dimension (N lg N)\n*         Contains the permutations (from deflation and sorting) to be\n*         applied to each eigenblock.\n*\n*  GIVPTR (input) INTEGER array, dimension (N lg N)\n*         Contains a list of pointers which indicate where in GIVCOL a\n*         level's Givens rotations are stored.  GIVPTR(i+1) - GIVPTR(i)\n*         indicates the number of Givens rotations.\n*\n*  GIVCOL (input) INTEGER array, dimension (2, N lg N)\n*         Each pair of numbers indicates a pair of columns to take place\n*         in a Givens rotation.\n*\n*  GIVNUM (input) REAL array, dimension (2, N lg N)\n*         Each number indicates the S value to be used in the\n*         corresponding Givens rotation.\n*\n*  Q      (input) REAL array, dimension (N**2)\n*         Contains the square eigenblocks from previous levels, the\n*         starting positions for blocks are given by QPTR.\n*\n*  QPTR   (input) INTEGER array, dimension (N+2)\n*         Contains a list of pointers which indicate where in Q an\n*         eigenblock is stored.  SQRT( QPTR(i+1) - QPTR(i) ) indicates\n*         the size of the block.\n*\n*  Z      (output) REAL array, dimension (N)\n*         On output this vector contains the updating vector (the last\n*         row of the first sub-eigenvector matrix and the first row of\n*         the second sub-eigenvector matrix).\n*\n*  ZTEMP  (workspace) REAL array, dimension (N)\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*  Based on contributions by\n*     Jeff Rutter, Computer Science Division, University of California\n*     at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  z, info = NumRu::Lapack.slaeda( tlvls, curlvl, curpbm, prmptr, perm, givptr, givcol, givnum, q, qptr, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_tlvls = argv[0];
  rblapack_curlvl = argv[1];
  rblapack_curpbm = argv[2];
  rblapack_prmptr = argv[3];
  rblapack_perm = argv[4];
  rblapack_givptr = argv[5];
  rblapack_givcol = argv[6];
  rblapack_givnum = argv[7];
  rblapack_q = argv[8];
  rblapack_qptr = argv[9];
  if (argc == 10) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  tlvls = NUM2INT(rblapack_tlvls);
  curpbm = NUM2INT(rblapack_curpbm);
  if (!NA_IsNArray(rblapack_qptr))
    rb_raise(rb_eArgError, "qptr (10th argument) must be NArray");
  if (NA_RANK(rblapack_qptr) != 1)
    rb_raise(rb_eArgError, "rank of qptr (10th argument) must be %d", 1);
  ldqptr = NA_SHAPE0(rblapack_qptr);
  if (NA_TYPE(rblapack_qptr) != NA_LINT)
    rblapack_qptr = na_change_type(rblapack_qptr, NA_LINT);
  qptr = NA_PTR_TYPE(rblapack_qptr, integer*);
  curlvl = NUM2INT(rblapack_curlvl);
  n = ldqptr-2;
  if (!NA_IsNArray(rblapack_prmptr))
    rb_raise(rb_eArgError, "prmptr (4th argument) must be NArray");
  if (NA_RANK(rblapack_prmptr) != 1)
    rb_raise(rb_eArgError, "rank of prmptr (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_prmptr) != (n*LG(n)))
    rb_raise(rb_eRuntimeError, "shape 0 of prmptr must be %d", n*LG(n));
  if (NA_TYPE(rblapack_prmptr) != NA_LINT)
    rblapack_prmptr = na_change_type(rblapack_prmptr, NA_LINT);
  prmptr = NA_PTR_TYPE(rblapack_prmptr, integer*);
  if (!NA_IsNArray(rblapack_givptr))
    rb_raise(rb_eArgError, "givptr (6th argument) must be NArray");
  if (NA_RANK(rblapack_givptr) != 1)
    rb_raise(rb_eArgError, "rank of givptr (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_givptr) != (n*LG(n)))
    rb_raise(rb_eRuntimeError, "shape 0 of givptr must be %d", n*LG(n));
  if (NA_TYPE(rblapack_givptr) != NA_LINT)
    rblapack_givptr = na_change_type(rblapack_givptr, NA_LINT);
  givptr = NA_PTR_TYPE(rblapack_givptr, integer*);
  if (!NA_IsNArray(rblapack_givnum))
    rb_raise(rb_eArgError, "givnum (8th argument) must be NArray");
  if (NA_RANK(rblapack_givnum) != 2)
    rb_raise(rb_eArgError, "rank of givnum (8th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_givnum) != (2))
    rb_raise(rb_eRuntimeError, "shape 0 of givnum must be %d", 2);
  if (NA_SHAPE1(rblapack_givnum) != (n*LG(n)))
    rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", n*LG(n));
  if (NA_TYPE(rblapack_givnum) != NA_SFLOAT)
    rblapack_givnum = na_change_type(rblapack_givnum, NA_SFLOAT);
  givnum = NA_PTR_TYPE(rblapack_givnum, real*);
  if (!NA_IsNArray(rblapack_perm))
    rb_raise(rb_eArgError, "perm (5th argument) must be NArray");
  if (NA_RANK(rblapack_perm) != 1)
    rb_raise(rb_eArgError, "rank of perm (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_perm) != (n*LG(n)))
    rb_raise(rb_eRuntimeError, "shape 0 of perm must be %d", n*LG(n));
  if (NA_TYPE(rblapack_perm) != NA_LINT)
    rblapack_perm = na_change_type(rblapack_perm, NA_LINT);
  perm = NA_PTR_TYPE(rblapack_perm, integer*);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (9th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 1)
    rb_raise(rb_eArgError, "rank of q (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_q) != (pow(n,2)))
    rb_raise(rb_eRuntimeError, "shape 0 of q must be %d", pow(n,2));
  if (NA_TYPE(rblapack_q) != NA_SFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
  q = NA_PTR_TYPE(rblapack_q, real*);
  if (!NA_IsNArray(rblapack_givcol))
    rb_raise(rb_eArgError, "givcol (7th argument) must be NArray");
  if (NA_RANK(rblapack_givcol) != 2)
    rb_raise(rb_eArgError, "rank of givcol (7th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_givcol) != (2))
    rb_raise(rb_eRuntimeError, "shape 0 of givcol must be %d", 2);
  if (NA_SHAPE1(rblapack_givcol) != (n*LG(n)))
    rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", n*LG(n));
  if (NA_TYPE(rblapack_givcol) != NA_LINT)
    rblapack_givcol = na_change_type(rblapack_givcol, NA_LINT);
  givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_z = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, real*);
  ztemp = ALLOC_N(real, (n));

  slaeda_(&n, &tlvls, &curlvl, &curpbm, prmptr, perm, givptr, givcol, givnum, q, qptr, z, ztemp, &info);

  free(ztemp);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_z, rblapack_info);
}

void
init_lapack_slaeda(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaeda", rblapack_slaeda, -1);
}
ruby-lapack-1.7.2/ext/zhpev.c0000644000175000017500000001316012502221023015655 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhpev_(char* jobz, char* uplo, integer* n, doublecomplex* ap, doublereal* w, doublecomplex* z, integer* ldz, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zhpev(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublecomplex *ap_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer ldap;
  integer n;
  integer ldz;

  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  w, z, info, ap = NumRu::Lapack.zhpev( jobz, uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHPEV computes all the eigenvalues and, optionally, eigenvectors of a\n*  complex Hermitian matrix in packed storage.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, AP is overwritten by values generated during the\n*          reduction to tridiagonal form.  If UPLO = 'U', the diagonal\n*          and first superdiagonal of the tridiagonal matrix T overwrite\n*          the corresponding elements of A, and if UPLO = 'L', the\n*          diagonal and first subdiagonal of T overwrite the\n*          corresponding elements of A.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) COMPLEX*16 array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n*          eigenvectors of the matrix A, with the i-th column of Z\n*          holding the eigenvector associated with W(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (max(1, 2*N-1))\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2))\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 algorithm failed to converge; i\n*                off-diagonal elements of an intermediate tridiagonal\n*                form did not converge to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, info, ap = NumRu::Lapack.zhpev( jobz, uplo, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_ap = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  uplo = StringValueCStr(rblapack_uplo)[0];
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
  MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  work = ALLOC_N(doublecomplex, (MAX(1, 2*n-1)));
  rwork = ALLOC_N(doublereal, (MAX(1, 3*n-2)));

  zhpev_(&jobz, &uplo, &n, ap, w, z, &ldz, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_w, rblapack_z, rblapack_info, rblapack_ap);
}

void
init_lapack_zhpev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhpev", rblapack_zhpev, -1);
}
ruby-lapack-1.7.2/ext/ssbgvd.c0000644000175000017500000002572212502221020016015 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssbgvd_(char* jobz, char* uplo, integer* n, integer* ka, integer* kb, real* ab, integer* ldab, real* bb, integer* ldbb, real* w, real* z, integer* ldz, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_ssbgvd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ka;
  integer ka; 
  VALUE rblapack_kb;
  integer kb; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_bb;
  real *bb; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  real *ab_out__;
  VALUE rblapack_bb_out__;
  real *bb_out__;

  integer ldab;
  integer n;
  integer ldbb;
  integer ldz;

  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  w, z, work, iwork, info, ab, bb = NumRu::Lapack.ssbgvd( jobz, uplo, ka, kb, ab, bb, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSBGVD computes all the eigenvalues, and optionally, the eigenvectors\n*  of a real generalized symmetric-definite banded eigenproblem, of the\n*  form A*x=(lambda)*B*x.  Here A and B are assumed to be symmetric and\n*  banded, and B is also positive definite.  If eigenvectors are\n*  desired, it uses a divide and conquer algorithm.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  KA      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KA >= 0.\n*\n*  KB      (input) INTEGER\n*          The number of superdiagonals of the matrix B if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KB >= 0.\n*\n*  AB      (input/output) REAL array, dimension (LDAB, N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first ka+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).\n*\n*          On exit, the contents of AB are destroyed.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KA+1.\n*\n*  BB      (input/output) REAL array, dimension (LDBB, N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix B, stored in the first kb+1 rows of the array.  The\n*          j-th column of B is stored in the j-th column of the array BB\n*          as follows:\n*          if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n*          if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb).\n*\n*          On exit, the factor S from the split Cholesky factorization\n*          B = S**T*S, as returned by SPBSTF.\n*\n*  LDBB    (input) INTEGER\n*          The leading dimension of the array BB.  LDBB >= KB+1.\n*\n*  W       (output) REAL array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) REAL array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n*          eigenvectors, with the i-th column of Z holding the\n*          eigenvector associated with W(i).  The eigenvectors are\n*          normalized so Z**T*B*Z = I.\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace/output) REAL 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*          If N <= 1,               LWORK >= 1.\n*          If JOBZ = 'N' and N > 1, LWORK >= 3*N.\n*          If JOBZ = 'V' and N > 1, LWORK >= 1 + 5*N + 2*N**2.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal sizes of the WORK and IWORK\n*          arrays, returns these values as the first entries of the WORK\n*          and IWORK arrays, and no error message related to LWORK or\n*          LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.\n*          If JOBZ  = 'N' or N <= 1, LIWORK >= 1.\n*          If JOBZ  = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK and IWORK arrays, and no error message related to\n*          LWORK or LIWORK 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, and i is:\n*             <= N:  the algorithm failed to converge:\n*                    i off-diagonal elements of an intermediate\n*                    tridiagonal form did not converge to zero;\n*             > N:   if INFO = N + i, for 1 <= i <= N, then SPBSTF\n*                    returned INFO = i: B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, work, iwork, info, ab, bb = NumRu::Lapack.ssbgvd( jobz, uplo, ka, kb, ab, bb, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_ka = argv[2];
  rblapack_kb = argv[3];
  rblapack_ab = argv[4];
  rblapack_bb = argv[5];
  if (argc == 8) {
    rblapack_lwork = argv[6];
    rblapack_liwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  ka = NUM2INT(rblapack_ka);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_bb))
    rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
  if (NA_RANK(rblapack_bb) != 2)
    rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
  ldbb = NA_SHAPE0(rblapack_bb);
  if (NA_SHAPE1(rblapack_bb) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of bb must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_bb) != NA_SFLOAT)
    rblapack_bb = na_change_type(rblapack_bb, NA_SFLOAT);
  bb = NA_PTR_TYPE(rblapack_bb, real*);
  if (rblapack_liwork == Qnil)
    liwork = (lsame_(&jobz,"N")||n<=0) ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  kb = NUM2INT(rblapack_kb);
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  if (rblapack_lwork == Qnil)
    lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 3*n : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
  MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldbb;
    shape[1] = n;
    rblapack_bb_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  bb_out__ = NA_PTR_TYPE(rblapack_bb_out__, real*);
  MEMCPY(bb_out__, bb, real, NA_TOTAL(rblapack_bb));
  rblapack_bb = rblapack_bb_out__;
  bb = bb_out__;

  ssbgvd_(&jobz, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, w, z, &ldz, work, &lwork, iwork, &liwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_w, rblapack_z, rblapack_work, rblapack_iwork, rblapack_info, rblapack_ab, rblapack_bb);
}

void
init_lapack_ssbgvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssbgvd", rblapack_ssbgvd, -1);
}
ruby-lapack-1.7.2/ext/ztzrqf.c0000644000175000017500000001164012502221016016064 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztzrqf_(integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* tau, integer* info);


static VALUE
rblapack_ztzrqf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;

  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.ztzrqf( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTZRQF( M, N, A, LDA, TAU, INFO )\n\n*  Purpose\n*  =======\n*\n*  This routine is deprecated and has been replaced by routine ZTZRZF.\n*\n*  ZTZRQF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A\n*  to upper triangular form by means of unitary transformations.\n*\n*  The upper trapezoidal matrix A is factored as\n*\n*     A = ( R  0 ) * Z,\n*\n*  where Z is an N-by-N unitary matrix and R is an M-by-M upper\n*  triangular matrix.\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 >= M.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the leading M-by-N upper trapezoidal part of the\n*          array A must contain the matrix to be factorized.\n*          On exit, the leading M-by-M upper triangular part of A\n*          contains the upper triangular matrix R, and elements M+1 to\n*          N of the first M rows of A, with the array TAU, represent the\n*          unitary matrix Z as a product of M elementary reflectors.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  TAU     (output) COMPLEX*16 array, dimension (M)\n*          The scalar factors of the elementary reflectors.\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  factorization is obtained by Householder's method.  The kth\n*  transformation matrix, Z( k ), whose conjugate transpose is used to\n*  introduce zeros into the (m - k + 1)th row of A, is given in the form\n*\n*     Z( k ) = ( I     0   ),\n*              ( 0  T( k ) )\n*\n*  where\n*\n*     T( k ) = I - tau*u( k )*u( k )',   u( k ) = (   1    ),\n*                                                 (   0    )\n*                                                 ( z( k ) )\n*\n*  tau is a scalar and z( k ) is an ( n - m ) element vector.\n*  tau and z( k ) are chosen to annihilate the elements of the kth row\n*  of X.\n*\n*  The scalar tau is returned in the kth element of TAU and the vector\n*  u( k ) in the kth row of A, such that the elements of z( k ) are\n*  in  a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n*  the upper triangular part of A.\n*\n*  Z is given by\n*\n*     Z =  Z( 1 ) * Z( 2 ) * ... * Z( m ).\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.ztzrqf( 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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  m = lda;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  ztzrqf_(&m, &n, a, &lda, tau, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
}

void
init_lapack_ztzrqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztzrqf", rblapack_ztzrqf, -1);
}
ruby-lapack-1.7.2/ext/cunmtr.c0000644000175000017500000001747412502221023016045 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cunmtr_(char* side, char* uplo, char* trans, integer* m, integer* n, complex* a, integer* lda, complex* tau, complex* c, integer* ldc, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_cunmtr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_c;
  complex *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  complex *c_out__;

  integer lda;
  integer m;
  integer ldc;
  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  work, info, c = NumRu::Lapack.cunmtr( side, uplo, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CUNMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CUNMTR overwrites the general complex M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'C':      Q**H * C       C * Q**H\n*\n*  where Q is a complex unitary matrix of order nq, with nq = m if\n*  SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of\n*  nq-1 elementary reflectors, as returned by CHETRD:\n*\n*  if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);\n*\n*  if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**H from the Left;\n*          = 'R': apply Q or Q**H from the Right.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U': Upper triangle of A contains elementary reflectors\n*                 from CHETRD;\n*          = 'L': Lower triangle of A contains elementary reflectors\n*                 from CHETRD.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'C':  Conjugate transpose, apply Q**H.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  A       (input) COMPLEX array, dimension\n*                               (LDA,M) if SIDE = 'L'\n*                               (LDA,N) if SIDE = 'R'\n*          The vectors which define the elementary reflectors, as\n*          returned by CHETRD.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*          LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n*\n*  TAU     (input) COMPLEX array, dimension\n*                               (M-1) if SIDE = 'L'\n*                               (N-1) if SIDE = 'R'\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by CHETRD.\n*\n*  C       (input/output) COMPLEX array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace/output) COMPLEX 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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M).\n*          For optimum performance LWORK >= N*NB if SIDE = 'L', and\n*          LWORK >=M*NB if SIDE = 'R', where NB is the optimal\n*          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*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LEFT, LQUERY, UPPER\n      INTEGER            I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            ILAENV\n      EXTERNAL           ILAENV, LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CUNMQL, CUNMQR, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.cunmtr( side, uplo, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_uplo = argv[1];
  rblapack_trans = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 7) {
    rblapack_lwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  side = StringValueCStr(rblapack_side)[0];
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, complex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_tau) != (m-1))
    rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", m-1);
  if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
  MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  cunmtr_(&side, &uplo, &trans, &m, &n, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_cunmtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cunmtr", rblapack_cunmtr, -1);
}
ruby-lapack-1.7.2/ext/zungrq.c0000644000175000017500000001261412502221021016050 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zungrq_(integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zungrq(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;

  integer lda;
  integer n;
  integer k;

  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 = NumRu::Lapack.zungrq( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZUNGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZUNGRQ generates an M-by-N complex matrix Q with orthonormal rows,\n*  which is defined as the last M rows of a product of K elementary\n*  reflectors of order N\n*\n*        Q  =  H(1)' H(2)' . . . H(k)'\n*\n*  as returned by ZGERQF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. N >= M.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. M >= K >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the (m-k+i)-th row must contain the vector which\n*          defines the elementary reflector H(i), for i = 1,2,...,k, as\n*          returned by ZGERQF in the last k rows of its array argument\n*          A.\n*          On exit, the M-by-N matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) COMPLEX*16 array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by ZGERQF.\n*\n*  WORK    (workspace/output) COMPLEX*16 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 has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, a = NumRu::Lapack.zungrq( m, a, tau, [: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_m = argv[0];
  rblapack_a = argv[1];
  rblapack_tau = 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;
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (rblapack_lwork == Qnil)
    lwork = m;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zungrq_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_zungrq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zungrq", rblapack_zungrq, -1);
}
ruby-lapack-1.7.2/ext/cggqrf.c0000644000175000017500000002312712502221012015774 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cggqrf_(integer* n, integer* m, integer* p, complex* a, integer* lda, complex* taua, complex* b, integer* ldb, complex* taub, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_cggqrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_taua;
  complex *taua; 
  VALUE rblapack_taub;
  complex *taub; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer lda;
  integer m;
  integer ldb;
  integer p;

  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  taua, taub, work, info, a, b = NumRu::Lapack.cggqrf( n, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGGQRF computes a generalized QR factorization of an N-by-M matrix A\n*  and an N-by-P matrix B:\n*\n*              A = Q*R,        B = Q*T*Z,\n*\n*  where Q is an N-by-N unitary matrix, Z is a P-by-P unitary matrix,\n*  and R and T assume one of the forms:\n*\n*  if N >= M,  R = ( R11 ) M  ,   or if N < M,  R = ( R11  R12 ) N,\n*                  (  0  ) N-M                         N   M-N\n*                     M\n*\n*  where R11 is upper triangular, and\n*\n*  if N <= P,  T = ( 0  T12 ) N,   or if N > P,  T = ( T11 ) N-P,\n*                   P-N  N                           ( T21 ) P\n*                                                       P\n*\n*  where T12 or T21 is upper triangular.\n*\n*  In particular, if B is square and nonsingular, the GQR factorization\n*  of A and B implicitly gives the QR factorization of inv(B)*A:\n*\n*               inv(B)*A = Z'*(inv(T)*R)\n*\n*  where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n*  conjugate transpose of matrix Z.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of rows of the matrices A and B. N >= 0.\n*\n*  M       (input) INTEGER\n*          The number of columns of the matrix A.  M >= 0.\n*\n*  P       (input) INTEGER\n*          The number of columns of the matrix B.  P >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,M)\n*          On entry, the N-by-M matrix A.\n*          On exit, the elements on and above the diagonal of the array\n*          contain the min(N,M)-by-M upper trapezoidal matrix R (R is\n*          upper triangular if N >= M); the elements below the diagonal,\n*          with the array TAUA, represent the unitary matrix Q as a\n*          product of min(N,M) elementary reflectors (see Further\n*          Details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  TAUA    (output) COMPLEX array, dimension (min(N,M))\n*          The scalar factors of the elementary reflectors which\n*          represent the unitary matrix Q (see Further Details).\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,P)\n*          On entry, the N-by-P matrix B.\n*          On exit, if N <= P, the upper triangle of the subarray\n*          B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n*          if N > P, the elements on and above the (N-P)-th subdiagonal\n*          contain the N-by-P upper trapezoidal matrix T; the remaining\n*          elements, with the array TAUB, represent the unitary\n*          matrix Z as a product of elementary reflectors (see Further\n*          Details).\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  TAUB    (output) COMPLEX array, dimension (min(N,P))\n*          The scalar factors of the elementary reflectors which\n*          represent the unitary matrix Z (see Further Details).\n*\n*  WORK    (workspace/output) COMPLEX 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,N,M,P).\n*          For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n*          where NB1 is the optimal blocksize for the QR factorization\n*          of an N-by-M matrix, NB2 is the optimal blocksize for the\n*          RQ factorization of an N-by-P matrix, and NB3 is the optimal\n*          blocksize for a call of CUNMQR.\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(1) H(2) . . . H(k), where k = min(n,m).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - taua * v * v'\n*\n*  where taua is a complex scalar, and v is a complex vector with\n*  v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),\n*  and taua in TAUA(i).\n*  To form Q explicitly, use LAPACK subroutine CUNGQR.\n*  To use Q to update another matrix, use LAPACK subroutine CUNMQR.\n*\n*  The matrix Z is represented as a product of elementary reflectors\n*\n*     Z = H(1) H(2) . . . H(k), where k = min(n,p).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - taub * v * v'\n*\n*  where taub is a complex scalar, and v is a complex vector with\n*  v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in\n*  B(n-k+i,1:p-k+i-1), and taub in TAUB(i).\n*  To form Z explicitly, use LAPACK subroutine CUNGRQ.\n*  To use Z to update another matrix, use LAPACK subroutine CUNMRQ.\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY\n      INTEGER            LOPT, LWKOPT, NB, NB1, NB2, NB3\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CGEQRF, CGERQF, CUNMQR, XERBLA\n*     ..\n*     .. External Functions ..\n      INTEGER            ILAENV \n      EXTERNAL           ILAENV\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          INT, MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  taua, taub, work, info, a, b = NumRu::Lapack.cggqrf( n, 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_n = 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;
  }

  n = NUM2INT(rblapack_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);
  ldb = NA_SHAPE0(rblapack_b);
  p = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  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);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (rblapack_lwork == Qnil)
    lwork = MAX(MAX(n,m),p);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(n,m);
    rblapack_taua = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  taua = NA_PTR_TYPE(rblapack_taua, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(n,p);
    rblapack_taub = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  taub = NA_PTR_TYPE(rblapack_taub, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = m;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = p;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  cggqrf_(&n, &m, &p, a, &lda, taua, b, &ldb, taub, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_taua, rblapack_taub, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_cggqrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cggqrf", rblapack_cggqrf, -1);
}
ruby-lapack-1.7.2/ext/sspgv.c0000644000175000017500000001722412502221016015672 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sspgv_(integer* itype, char* jobz, char* uplo, integer* n, real* ap, real* bp, real* w, real* z, integer* ldz, real* work, integer* info);


static VALUE
rblapack_sspgv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_bp;
  real *bp; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  real *ap_out__;
  VALUE rblapack_bp_out__;
  real *bp_out__;
  real *work;

  integer ldap;
  integer n;
  integer ldz;

  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  w, z, info, ap, bp = NumRu::Lapack.sspgv( itype, jobz, uplo, ap, bp, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSPGV computes all the eigenvalues and, optionally, the eigenvectors\n*  of a real generalized symmetric-definite eigenproblem, of the form\n*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.\n*  Here A and B are assumed to be symmetric, stored in packed format,\n*  and B is also positive definite.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          Specifies the problem type to be solved:\n*          = 1:  A*x = (lambda)*B*x\n*          = 2:  A*B*x = (lambda)*x\n*          = 3:  B*A*x = (lambda)*x\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  AP      (input/output) REAL array, dimension\n*                            (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, the contents of AP are destroyed.\n*\n*  BP      (input/output) REAL array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          B, packed columnwise in a linear array.  The j-th column of B\n*          is stored in the array BP as follows:\n*          if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n*          if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n*          On exit, the triangular factor U or L from the Cholesky\n*          factorization B = U**T*U or B = L*L**T, in the same storage\n*          format as B.\n*\n*  W       (output) REAL array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) REAL array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n*          eigenvectors.  The eigenvectors are normalized as follows:\n*          if ITYPE = 1 or 2, Z**T*B*Z = I;\n*          if ITYPE = 3, Z**T*inv(B)*Z = I.\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace) REAL array, dimension (3*N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  SPPTRF or SSPEV returned an error code:\n*             <= N:  if INFO = i, SSPEV failed to converge;\n*                    i off-diagonal elements of an intermediate\n*                    tridiagonal form did not converge to zero.\n*             > N:   if INFO = n + i, for 1 <= i <= n, then the leading\n*                    minor of order i of B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            UPPER, WANTZ\n      CHARACTER          TRANS\n      INTEGER            J, NEIG\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SPPTRF, SSPEV, SSPGST, STPMV, STPSV, XERBLA\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, info, ap, bp = NumRu::Lapack.sspgv( itype, jobz, uplo, ap, bp, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_itype = argv[0];
  rblapack_jobz = argv[1];
  rblapack_uplo = argv[2];
  rblapack_ap = argv[3];
  rblapack_bp = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  itype = NUM2INT(rblapack_itype);
  uplo = StringValueCStr(rblapack_uplo)[0];
  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  if (!NA_IsNArray(rblapack_bp))
    rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
  if (NA_RANK(rblapack_bp) != 1)
    rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_bp) != NA_SFLOAT)
    rblapack_bp = na_change_type(rblapack_bp, NA_SFLOAT);
  bp = NA_PTR_TYPE(rblapack_bp, real*);
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, real*);
  MEMCPY(ap_out__, ap, real, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_bp_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  bp_out__ = NA_PTR_TYPE(rblapack_bp_out__, real*);
  MEMCPY(bp_out__, bp, real, NA_TOTAL(rblapack_bp));
  rblapack_bp = rblapack_bp_out__;
  bp = bp_out__;
  work = ALLOC_N(real, (3*n));

  sspgv_(&itype, &jobz, &uplo, &n, ap, bp, w, z, &ldz, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_w, rblapack_z, rblapack_info, rblapack_ap, rblapack_bp);
}

void
init_lapack_sspgv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sspgv", rblapack_sspgv, -1);
}
ruby-lapack-1.7.2/ext/dstevd.c0000644000175000017500000002036612502221014016020 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dstevd_(char* jobz, integer* n, doublereal* d, doublereal* e, doublereal* z, integer* ldz, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_dstevd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_e_out__;
  doublereal *e_out__;

  integer n;
  integer ldz;

  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  z, work, iwork, info, d, e = NumRu::Lapack.dstevd( jobz, d, e, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSTEVD computes all eigenvalues and, optionally, eigenvectors of a\n*  real symmetric tridiagonal matrix. If eigenvectors are desired, it\n*  uses a divide and conquer algorithm.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the n diagonal elements of the tridiagonal matrix\n*          A.\n*          On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n*  E       (input/output) DOUBLE PRECISION array, dimension (N-1)\n*          On entry, the (n-1) subdiagonal elements of the tridiagonal\n*          matrix A, stored in elements 1 to N-1 of E.\n*          On exit, the contents of E are destroyed.\n*\n*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n*          eigenvectors of the matrix A, with the i-th column of Z\n*          holding the eigenvector associated with D(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace/output) DOUBLE PRECISION array,\n*                                         dimension (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*          If JOBZ  = 'N' or N <= 1 then LWORK must be at least 1.\n*          If JOBZ  = 'V' and N > 1 then LWORK must be at least\n*                         ( 1 + 4*N + N**2 ).\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal sizes of the WORK and IWORK\n*          arrays, returns these values as the first entries of the WORK\n*          and IWORK arrays, and no error message related to LWORK or\n*          LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.\n*          If JOBZ  = 'N' or N <= 1 then LIWORK must be at least 1.\n*          If JOBZ  = 'V' and N > 1 then LIWORK must be at least 3+5*N.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK and IWORK arrays, and no error message related to\n*          LWORK or LIWORK 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 algorithm failed to converge; i\n*                off-diagonal elements of E did not converge to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  z, work, iwork, info, d, e = NumRu::Lapack.dstevd( jobz, d, e, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_jobz = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  if (argc == 5) {
    rblapack_lwork = argv[3];
    rblapack_liwork = argv[4];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (rblapack_lwork == Qnil)
    lwork = (lsame_(&jobz,"N")||n<=1) ? 1 : (lsame_(&jobz,"V")&&n>1) ? 1+4*n+n*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  if (rblapack_liwork == Qnil)
    liwork = (lsame_(&jobz,"N")||n<=1) ? 1 : (lsame_(&jobz,"V")&&n>1) ? 3+5*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
  MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;

  dstevd_(&jobz, &n, d, e, z, &ldz, work, &lwork, iwork, &liwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_z, rblapack_work, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e);
}

void
init_lapack_dstevd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dstevd", rblapack_dstevd, -1);
}
ruby-lapack-1.7.2/ext/sormrz.c0000644000175000017500000001673712502221016016074 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sormrz_(char* side, char* trans, integer* m, integer* n, integer* k, integer* l, real* a, integer* lda, real* tau, real* c, integer* ldc, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sormrz(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  real *c_out__;

  integer lda;
  integer m;
  integer k;
  integer ldc;
  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  work, info, c = NumRu::Lapack.sormrz( side, trans, l, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SORMRZ overwrites the general real M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'T':      Q**T * C       C * Q**T\n*\n*  where Q is a real orthogonal matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(1) H(2) . . . H(k)\n*\n*  as returned by STZRZF. Q is of order M if SIDE = 'L' and of order N\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**T from the Left;\n*          = 'R': apply Q or Q**T from the Right.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'T':  Transpose, apply Q**T.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  L       (input) INTEGER\n*          The number of columns of the matrix A containing\n*          the meaningful part of the Householder reflectors.\n*          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n*  A       (input) REAL array, dimension\n*                               (LDA,M) if SIDE = 'L',\n*                               (LDA,N) if SIDE = 'R'\n*          The i-th row must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          STZRZF in the last k rows of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,K).\n*\n*  TAU     (input) REAL array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by STZRZF.\n*\n*  C       (input/output) REAL array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace/output) REAL 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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M).\n*          For optimum performance LWORK >= N*NB if SIDE = 'L', and\n*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n*          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*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.sormrz( side, trans, l, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_l = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 7) {
    rblapack_lwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  side = StringValueCStr(rblapack_side)[0];
  l = NUM2INT(rblapack_l);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  sormrz_(&side, &trans, &m, &n, &k, &l, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_sormrz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sormrz", rblapack_sormrz, -1);
}
ruby-lapack-1.7.2/ext/sspev.c0000644000175000017500000001236512502221015015670 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sspev_(char* jobz, char* uplo, integer* n, real* ap, real* w, real* z, integer* ldz, real* work, integer* info);


static VALUE
rblapack_sspev(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  real *ap_out__;
  real *work;

  integer ldap;
  integer n;
  integer ldz;

  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  w, z, info, ap = NumRu::Lapack.sspev( jobz, uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSPEV computes all the eigenvalues and, optionally, eigenvectors of a\n*  real symmetric matrix A in packed storage.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) REAL array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, AP is overwritten by values generated during the\n*          reduction to tridiagonal form.  If UPLO = 'U', the diagonal\n*          and first superdiagonal of the tridiagonal matrix T overwrite\n*          the corresponding elements of A, and if UPLO = 'L', the\n*          diagonal and first subdiagonal of T overwrite the\n*          corresponding elements of A.\n*\n*  W       (output) REAL array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) REAL array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n*          eigenvectors of the matrix A, with the i-th column of Z\n*          holding the eigenvector associated with W(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace) REAL array, dimension (3*N)\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 algorithm failed to converge; i\n*                off-diagonal elements of an intermediate tridiagonal\n*                form did not converge to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, info, ap = NumRu::Lapack.sspev( jobz, uplo, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_ap = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  uplo = StringValueCStr(rblapack_uplo)[0];
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, real*);
  MEMCPY(ap_out__, ap, real, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  work = ALLOC_N(real, (3*n));

  sspev_(&jobz, &uplo, &n, ap, w, z, &ldz, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_w, rblapack_z, rblapack_info, rblapack_ap);
}

void
init_lapack_sspev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sspev", rblapack_sspev, -1);
}
ruby-lapack-1.7.2/ext/zunmtr.c0000644000175000017500000001764212502221020016066 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zunmtr_(char* side, char* uplo, char* trans, integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zunmtr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_c;
  doublecomplex *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublecomplex *c_out__;

  integer lda;
  integer m;
  integer ldc;
  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  work, info, c = NumRu::Lapack.zunmtr( side, uplo, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZUNMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZUNMTR overwrites the general complex M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'C':      Q**H * C       C * Q**H\n*\n*  where Q is a complex unitary matrix of order nq, with nq = m if\n*  SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of\n*  nq-1 elementary reflectors, as returned by ZHETRD:\n*\n*  if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);\n*\n*  if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**H from the Left;\n*          = 'R': apply Q or Q**H from the Right.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U': Upper triangle of A contains elementary reflectors\n*                 from ZHETRD;\n*          = 'L': Lower triangle of A contains elementary reflectors\n*                 from ZHETRD.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'C':  Conjugate transpose, apply Q**H.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension\n*                               (LDA,M) if SIDE = 'L'\n*                               (LDA,N) if SIDE = 'R'\n*          The vectors which define the elementary reflectors, as\n*          returned by ZHETRD.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*          LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n*\n*  TAU     (input) COMPLEX*16 array, dimension\n*                               (M-1) if SIDE = 'L'\n*                               (N-1) if SIDE = 'R'\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by ZHETRD.\n*\n*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace/output) COMPLEX*16 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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M).\n*          For optimum performance LWORK >= N*NB if SIDE = 'L', and\n*          LWORK >=M*NB if SIDE = 'R', where NB is the optimal\n*          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*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LEFT, LQUERY, UPPER\n      INTEGER            I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            ILAENV\n      EXTERNAL           LSAME, ILAENV\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZUNMQL, ZUNMQR\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.zunmtr( side, uplo, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_uplo = argv[1];
  rblapack_trans = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 7) {
    rblapack_lwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  side = StringValueCStr(rblapack_side)[0];
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_tau) != (m-1))
    rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", m-1);
  if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
  MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  zunmtr_(&side, &uplo, &trans, &m, &n, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_zunmtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zunmtr", rblapack_zunmtr, -1);
}
ruby-lapack-1.7.2/ext/cgerfs.c0000644000175000017500000002043112502221016015773 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgerfs_(char* trans, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, complex* b, integer* ldb, complex* x, integer* ldx, real* ferr, real* berr, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cgerfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  complex *x_out__;
  complex *work;
  real *rwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.cgerfs( trans, a, af, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGERFS improves the computed solution to a system of linear\n*  equations and provides error bounds and backward error estimates for\n*  the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The original N-by-N matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AF      (input) COMPLEX array, dimension (LDAF,N)\n*          The factors L and U from the factorization A = P*L*U\n*          as computed by CGETRF.\n*\n*  LDAF    (input) INTEGER\n*          The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices from CGETRF; for 1<=i<=N, row i of the\n*          matrix was interchanged with row IPIV(i).\n*\n*  B       (input) COMPLEX array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) COMPLEX array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by CGETRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.cgerfs( trans, a, af, ipiv, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_trans = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_b = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (n));

  cgerfs_(&trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_cgerfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgerfs", rblapack_cgerfs, -1);
}
ruby-lapack-1.7.2/ext/claqsp.c0000644000175000017500000001165512502221025016015 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID claqsp_(char* uplo, integer* n, complex* ap, real* s, real* scond, real* amax, char* equed);


static VALUE
rblapack_claqsp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_scond;
  real scond; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_ap_out__;
  complex *ap_out__;

  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  equed, ap = NumRu::Lapack.claqsp( uplo, ap, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )\n\n*  Purpose\n*  =======\n*\n*  CLAQSP equilibrates a symmetric matrix A using the scaling factors\n*  in the vector S.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, the equilibrated matrix:  diag(S) * A * diag(S), in\n*          the same storage format as A.\n*\n*  S       (input) REAL array, dimension (N)\n*          The scale factors for A.\n*\n*  SCOND   (input) REAL\n*          Ratio of the smallest S(i) to the largest S(i).\n*\n*  AMAX    (input) REAL\n*          Absolute value of largest matrix entry.\n*\n*  EQUED   (output) CHARACTER*1\n*          Specifies whether or not equilibration was done.\n*          = 'N':  No equilibration.\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*\n*  Internal Parameters\n*  ===================\n*\n*  THRESH is a threshold value used to decide if scaling should be done\n*  based on the ratio of the scaling factors.  If SCOND < THRESH,\n*  scaling is done.\n*\n*  LARGE and SMALL are threshold values used to decide if scaling should\n*  be done based on the absolute size of the largest matrix element.\n*  If AMAX > LARGE or AMAX < SMALL, scaling is done.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  equed, ap = NumRu::Lapack.claqsp( uplo, ap, s, scond, amax, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_s = argv[2];
  rblapack_scond = argv[3];
  rblapack_amax = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (3th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_s);
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  amax = (real)NUM2DBL(rblapack_amax);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  scond = (real)NUM2DBL(rblapack_scond);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
  MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  claqsp_(&uplo, &n, ap, s, &scond, &amax, &equed);

  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(2, rblapack_equed, rblapack_ap);
}

void
init_lapack_claqsp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "claqsp", rblapack_claqsp, -1);
}
ruby-lapack-1.7.2/ext/scsum1.c0000644000175000017500000000530212502221013015732 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real scsum1_(integer* n, complex* cx, integer* incx);


static VALUE
rblapack_scsum1(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_cx;
  complex *cx; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack___out__;
  real __out__; 

  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  __out__ = NumRu::Lapack.scsum1( cx, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL             FUNCTION SCSUM1( N, CX, INCX )\n\n*  Purpose\n*  =======\n*\n*  SCSUM1 takes the sum of the absolute values of a complex\n*  vector and returns a single precision result.\n*\n*  Based on SCASUM from the Level 1 BLAS.\n*  The change is to use the 'genuine' absolute value.\n*\n*  Contributed by Nick Higham for use with CLACON.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of elements in the vector CX.\n*\n*  CX      (input) COMPLEX array, dimension (N)\n*          The vector whose elements will be summed.\n*\n*  INCX    (input) INTEGER\n*          The spacing between successive values of CX.  INCX > 0.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, NINCX\n      REAL               STEMP\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.scsum1( cx, incx, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_cx = argv[0];
  rblapack_incx = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_cx))
    rb_raise(rb_eArgError, "cx (1th argument) must be NArray");
  if (NA_RANK(rblapack_cx) != 1)
    rb_raise(rb_eArgError, "rank of cx (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_cx);
  if (NA_TYPE(rblapack_cx) != NA_SCOMPLEX)
    rblapack_cx = na_change_type(rblapack_cx, NA_SCOMPLEX);
  cx = NA_PTR_TYPE(rblapack_cx, complex*);
  incx = NUM2INT(rblapack_incx);

  __out__ = scsum1_(&n, cx, &incx);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_scsum1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "scsum1", rblapack_scsum1, -1);
}
ruby-lapack-1.7.2/ext/ctrtri.c0000644000175000017500000001011112502221017016024 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctrtri_(char* uplo, char* diag, integer* n, complex* a, integer* lda, integer* info);


static VALUE
rblapack_ctrtri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *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  info, a = NumRu::Lapack.ctrtri( uplo, diag, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTRTRI( UPLO, DIAG, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTRTRI computes the inverse of a complex upper or lower triangular\n*  matrix A.\n*\n*  This is the Level 3 BLAS version of the algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the triangular matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of the array A contains\n*          the upper triangular matrix, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of the array A contains\n*          the lower triangular matrix, and the strictly upper\n*          triangular part of A is not referenced.  If DIAG = 'U', the\n*          diagonal elements of A are also not referenced and are\n*          assumed to be 1.\n*          On exit, the (triangular) inverse of the original matrix, in\n*          the same storage format.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\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, A(i,i) is exactly zero.  The triangular\n*               matrix is singular and its inverse can not be computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.ctrtri( uplo, diag, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_diag = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  diag = StringValueCStr(rblapack_diag)[0];
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  ctrtri_(&uplo, &diag, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_ctrtri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctrtri", rblapack_ctrtri, -1);
}
ruby-lapack-1.7.2/ext/cungr2.c0000644000175000017500000001027312502221015015724 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cungr2_(integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* work, integer* info);


static VALUE
rblapack_cungr2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  complex *work;

  integer lda;
  integer n;
  integer k;
  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  info, a = NumRu::Lapack.cungr2( a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CUNGR2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CUNGR2 generates an m by n complex matrix Q with orthonormal rows,\n*  which is defined as the last m rows of a product of k elementary\n*  reflectors of order n\n*\n*        Q  =  H(1)' H(2)' . . . H(k)'\n*\n*  as returned by CGERQF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. N >= M.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. M >= K >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the (m-k+i)-th row must contain the vector which\n*          defines the elementary reflector H(i), for i = 1,2,...,k, as\n*          returned by CGERQF in the last k rows of its array argument\n*          A.\n*          On exit, the m-by-n matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) COMPLEX array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by CGERQF.\n*\n*  WORK    (workspace) COMPLEX array, dimension (M)\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -i, the i-th argument has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.cungr2( a, tau, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_a = argv[0];
  rblapack_tau = argv[1];
  if (argc == 2) {
  } 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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  m = lda;
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (2th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (2th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(complex, (m));

  cungr2_(&m, &n, &k, a, &lda, tau, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_cungr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cungr2", rblapack_cungr2, -1);
}
ruby-lapack-1.7.2/ext/ctrsna.c0000644000175000017500000002427712502221015016027 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctrsna_(char* job, char* howmny, logical* select, integer* n, complex* t, integer* ldt, complex* vl, integer* ldvl, complex* vr, integer* ldvr, real* s, real* sep, integer* mm, integer* m, complex* work, integer* ldwork, real* rwork, integer* info);


static VALUE
rblapack_ctrsna(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_howmny;
  char howmny; 
  VALUE rblapack_select;
  logical *select; 
  VALUE rblapack_t;
  complex *t; 
  VALUE rblapack_vl;
  complex *vl; 
  VALUE rblapack_vr;
  complex *vr; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_sep;
  real *sep; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_info;
  integer info; 
  complex *work;
  real *rwork;

  integer n;
  integer ldt;
  integer ldvl;
  integer ldvr;
  integer mm;
  integer ldwork;

  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  s, sep, m, info = NumRu::Lapack.ctrsna( job, howmny, select, t, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTRSNA estimates reciprocal condition numbers for specified\n*  eigenvalues and/or right eigenvectors of a complex upper triangular\n*  matrix T (or of any matrix Q*T*Q**H with Q unitary).\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies whether condition numbers are required for\n*          eigenvalues (S) or eigenvectors (SEP):\n*          = 'E': for eigenvalues only (S);\n*          = 'V': for eigenvectors only (SEP);\n*          = 'B': for both eigenvalues and eigenvectors (S and SEP).\n*\n*  HOWMNY  (input) CHARACTER*1\n*          = 'A': compute condition numbers for all eigenpairs;\n*          = 'S': compute condition numbers for selected eigenpairs\n*                 specified by the array SELECT.\n*\n*  SELECT  (input) LOGICAL array, dimension (N)\n*          If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n*          condition numbers are required. To select condition numbers\n*          for the j-th eigenpair, SELECT(j) must be set to .TRUE..\n*          If HOWMNY = 'A', SELECT is not referenced.\n*\n*  N       (input) INTEGER\n*          The order of the matrix T. N >= 0.\n*\n*  T       (input) COMPLEX array, dimension (LDT,N)\n*          The upper triangular matrix T.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= max(1,N).\n*\n*  VL      (input) COMPLEX array, dimension (LDVL,M)\n*          If JOB = 'E' or 'B', VL must contain left eigenvectors of T\n*          (or of any Q*T*Q**H with Q unitary), corresponding to the\n*          eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n*          must be stored in consecutive columns of VL, as returned by\n*          CHSEIN or CTREVC.\n*          If JOB = 'V', VL is not referenced.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the array VL.\n*          LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.\n*\n*  VR      (input) COMPLEX array, dimension (LDVR,M)\n*          If JOB = 'E' or 'B', VR must contain right eigenvectors of T\n*          (or of any Q*T*Q**H with Q unitary), corresponding to the\n*          eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n*          must be stored in consecutive columns of VR, as returned by\n*          CHSEIN or CTREVC.\n*          If JOB = 'V', VR is not referenced.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the array VR.\n*          LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.\n*\n*  S       (output) REAL array, dimension (MM)\n*          If JOB = 'E' or 'B', the reciprocal condition numbers of the\n*          selected eigenvalues, stored in consecutive elements of the\n*          array. Thus S(j), SEP(j), and the j-th columns of VL and VR\n*          all correspond to the same eigenpair (but not in general the\n*          j-th eigenpair, unless all eigenpairs are selected).\n*          If JOB = 'V', S is not referenced.\n*\n*  SEP     (output) REAL array, dimension (MM)\n*          If JOB = 'V' or 'B', the estimated reciprocal condition\n*          numbers of the selected eigenvectors, stored in consecutive\n*          elements of the array.\n*          If JOB = 'E', SEP is not referenced.\n*\n*  MM      (input) INTEGER\n*          The number of elements in the arrays S (if JOB = 'E' or 'B')\n*           and/or SEP (if JOB = 'V' or 'B'). MM >= M.\n*\n*  M       (output) INTEGER\n*          The number of elements of the arrays S and/or SEP actually\n*          used to store the estimated condition numbers.\n*          If HOWMNY = 'A', M is set to N.\n*\n*  WORK    (workspace) COMPLEX array, dimension (LDWORK,N+6)\n*          If JOB = 'E', WORK is not referenced.\n*\n*  LDWORK  (input) INTEGER\n*          The leading dimension of the array WORK.\n*          LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.\n*\n*  RWORK   (workspace) REAL array, dimension (N)\n*          If JOB = 'E', RWORK is not referenced.\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 reciprocal of the condition number of an eigenvalue lambda is\n*  defined as\n*\n*          S(lambda) = |v'*u| / (norm(u)*norm(v))\n*\n*  where u and v are the right and left eigenvectors of T corresponding\n*  to lambda; v' denotes the conjugate transpose of v, and norm(u)\n*  denotes the Euclidean norm. These reciprocal condition numbers always\n*  lie between zero (very badly conditioned) and one (very well\n*  conditioned). If n = 1, S(lambda) is defined to be 1.\n*\n*  An approximate error bound for a computed eigenvalue W(i) is given by\n*\n*                      EPS * norm(T) / S(i)\n*\n*  where EPS is the machine precision.\n*\n*  The reciprocal of the condition number of the right eigenvector u\n*  corresponding to lambda is defined as follows. Suppose\n*\n*              T = ( lambda  c  )\n*                  (   0    T22 )\n*\n*  Then the reciprocal condition number is\n*\n*          SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )\n*\n*  where sigma-min denotes the smallest singular value. We approximate\n*  the smallest singular value by the reciprocal of an estimate of the\n*  one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is\n*  defined to be abs(T(1,1)).\n*\n*  An approximate error bound for a computed right eigenvector VR(i)\n*  is given by\n*\n*                      EPS * norm(T) / SEP(i)\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, sep, m, info = NumRu::Lapack.ctrsna( job, howmny, select, t, vl, vr, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_job = argv[0];
  rblapack_howmny = argv[1];
  rblapack_select = argv[2];
  rblapack_t = argv[3];
  rblapack_vl = argv[4];
  rblapack_vr = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  job = StringValueCStr(rblapack_job)[0];
  if (!NA_IsNArray(rblapack_select))
    rb_raise(rb_eArgError, "select (3th argument) must be NArray");
  if (NA_RANK(rblapack_select) != 1)
    rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_select);
  if (NA_TYPE(rblapack_select) != NA_LINT)
    rblapack_select = na_change_type(rblapack_select, NA_LINT);
  select = NA_PTR_TYPE(rblapack_select, logical*);
  if (!NA_IsNArray(rblapack_vl))
    rb_raise(rb_eArgError, "vl (5th argument) must be NArray");
  if (NA_RANK(rblapack_vl) != 2)
    rb_raise(rb_eArgError, "rank of vl (5th argument) must be %d", 2);
  ldvl = NA_SHAPE0(rblapack_vl);
  m = NA_SHAPE1(rblapack_vl);
  if (NA_TYPE(rblapack_vl) != NA_SCOMPLEX)
    rblapack_vl = na_change_type(rblapack_vl, NA_SCOMPLEX);
  vl = NA_PTR_TYPE(rblapack_vl, complex*);
  howmny = StringValueCStr(rblapack_howmny)[0];
  if (!NA_IsNArray(rblapack_vr))
    rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
  if (NA_RANK(rblapack_vr) != 2)
    rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 2);
  ldvr = NA_SHAPE0(rblapack_vr);
  if (NA_SHAPE1(rblapack_vr) != m)
    rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
  if (NA_TYPE(rblapack_vr) != NA_SCOMPLEX)
    rblapack_vr = na_change_type(rblapack_vr, NA_SCOMPLEX);
  vr = NA_PTR_TYPE(rblapack_vr, complex*);
  mm = m;
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (4th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  if (NA_SHAPE1(rblapack_t) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_t) != NA_SCOMPLEX)
    rblapack_t = na_change_type(rblapack_t, NA_SCOMPLEX);
  t = NA_PTR_TYPE(rblapack_t, complex*);
  ldwork = ((lsame_(&job,"V")) || (lsame_(&job,"B"))) ? n : 1;
  {
    na_shape_t shape[1];
    shape[0] = mm;
    rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, real*);
  {
    na_shape_t shape[1];
    shape[0] = mm;
    rblapack_sep = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  sep = NA_PTR_TYPE(rblapack_sep, real*);
  work = ALLOC_N(complex, (lsame_(&job,"E") ? 0 : ldwork)*(lsame_(&job,"E") ? 0 : n+6));
  rwork = ALLOC_N(real, (lsame_(&job,"E") ? 0 : n));

  ctrsna_(&job, &howmny, select, &n, t, &ldt, vl, &ldvl, vr, &ldvr, s, sep, &mm, &m, work, &ldwork, rwork, &info);

  free(work);
  free(rwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_s, rblapack_sep, rblapack_m, rblapack_info);
}

void
init_lapack_ctrsna(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctrsna", rblapack_ctrsna, -1);
}
ruby-lapack-1.7.2/ext/sorgbr.c0000644000175000017500000001541512502221014016024 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sorgbr_(char* vect, integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sorgbr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_vect;
  char vect; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *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  work, info, a = NumRu::Lapack.sorgbr( vect, m, k, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SORGBR generates one of the real orthogonal matrices Q or P**T\n*  determined by SGEBRD when reducing a real matrix A to bidiagonal\n*  form: A = Q * B * P**T.  Q and P**T are defined as products of\n*  elementary reflectors H(i) or G(i) respectively.\n*\n*  If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q\n*  is of order M:\n*  if m >= k, Q = H(1) H(2) . . . H(k) and SORGBR returns the first n\n*  columns of Q, where m >= n >= k;\n*  if m < k, Q = H(1) H(2) . . . H(m-1) and SORGBR returns Q as an\n*  M-by-M matrix.\n*\n*  If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T\n*  is of order N:\n*  if k < n, P**T = G(k) . . . G(2) G(1) and SORGBR returns the first m\n*  rows of P**T, where n >= m >= k;\n*  if k >= n, P**T = G(n-1) . . . G(2) G(1) and SORGBR returns P**T as\n*  an N-by-N matrix.\n*\n\n*  Arguments\n*  =========\n*\n*  VECT    (input) CHARACTER*1\n*          Specifies whether the matrix Q or the matrix P**T is\n*          required, as defined in the transformation applied by SGEBRD:\n*          = 'Q':  generate Q;\n*          = 'P':  generate P**T.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q or P**T to be returned.\n*          M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q or P**T to be returned.\n*          N >= 0.\n*          If VECT = 'Q', M >= N >= min(M,K);\n*          if VECT = 'P', N >= M >= min(N,K).\n*\n*  K       (input) INTEGER\n*          If VECT = 'Q', the number of columns in the original M-by-K\n*          matrix reduced by SGEBRD.\n*          If VECT = 'P', the number of rows in the original K-by-N\n*          matrix reduced by SGEBRD.\n*          K >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the vectors which define the elementary reflectors,\n*          as returned by SGEBRD.\n*          On exit, the M-by-N matrix Q or P**T.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) REAL array, dimension\n*                                (min(M,K)) if VECT = 'Q'\n*                                (min(N,K)) if VECT = 'P'\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i) or G(i), which determines Q or P**T, as\n*          returned by SGEBRD in its array argument TAUQ or TAUP.\n*\n*  WORK    (workspace/output) REAL 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,min(M,N)).\n*          For optimum performance LWORK >= min(M,N)*NB, where NB\n*          is the 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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, a = NumRu::Lapack.sorgbr( vect, m, k, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_vect = argv[0];
  rblapack_m = argv[1];
  rblapack_k = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  if (argc == 6) {
    rblapack_lwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  vect = StringValueCStr(rblapack_vect)[0];
  k = NUM2INT(rblapack_k);
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_tau) != (MIN(m,k)))
    rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", MIN(m,k));
  if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (rblapack_lwork == Qnil)
    lwork = MIN(m,n);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  sorgbr_(&vect, &m, &n, &k, a, &lda, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_sorgbr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sorgbr", rblapack_sorgbr, -1);
}
ruby-lapack-1.7.2/ext/sggev.c0000644000175000017500000002511412502221016015640 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sggev_(char* jobvl, char* jobvr, integer* n, real* a, integer* lda, real* b, integer* ldb, real* alphar, real* alphai, real* beta, real* vl, integer* ldvl, real* vr, integer* ldvr, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sggev(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvl;
  char jobvl; 
  VALUE rblapack_jobvr;
  char jobvr; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_alphar;
  real *alphar; 
  VALUE rblapack_alphai;
  real *alphai; 
  VALUE rblapack_beta;
  real *beta; 
  VALUE rblapack_vl;
  real *vl; 
  VALUE rblapack_vr;
  real *vr; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_b_out__;
  real *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer ldvl;
  integer ldvr;

  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  alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.sggev( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B)\n*  the generalized eigenvalues, and optionally, the left and/or right\n*  generalized eigenvectors.\n*\n*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n*  lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n*  singular. It is usually represented as the pair (alpha,beta), as\n*  there is a reasonable interpretation for beta=0, and even for both\n*  being zero.\n*\n*  The right eigenvector v(j) corresponding to the eigenvalue lambda(j)\n*  of (A,B) satisfies\n*\n*                   A * v(j) = lambda(j) * B * v(j).\n*\n*  The left eigenvector u(j) corresponding to the eigenvalue lambda(j)\n*  of (A,B) satisfies\n*\n*                   u(j)**H * A  = lambda(j) * u(j)**H * B .\n*\n*  where u(j)**H is the conjugate-transpose of u(j).\n*\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVL   (input) CHARACTER*1\n*          = 'N':  do not compute the left generalized eigenvectors;\n*          = 'V':  compute the left generalized eigenvectors.\n*\n*  JOBVR   (input) CHARACTER*1\n*          = 'N':  do not compute the right generalized eigenvectors;\n*          = 'V':  compute the right generalized eigenvectors.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A, B, VL, and VR.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA, N)\n*          On entry, the matrix A in the pair (A,B).\n*          On exit, A has been overwritten.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of A.  LDA >= max(1,N).\n*\n*  B       (input/output) REAL array, dimension (LDB, N)\n*          On entry, the matrix B in the pair (A,B).\n*          On exit, B has been overwritten.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of B.  LDB >= max(1,N).\n*\n*  ALPHAR  (output) REAL array, dimension (N)\n*  ALPHAI  (output) REAL array, dimension (N)\n*  BETA    (output) REAL array, dimension (N)\n*          On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n*          be the generalized eigenvalues.  If ALPHAI(j) is zero, then\n*          the j-th eigenvalue is real; if positive, then the j-th and\n*          (j+1)-st eigenvalues are a complex conjugate pair, with\n*          ALPHAI(j+1) negative.\n*\n*          Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n*          may easily over- or underflow, and BETA(j) may even be zero.\n*          Thus, the user should avoid naively computing the ratio\n*          alpha/beta.  However, ALPHAR and ALPHAI will be always less\n*          than and usually comparable with norm(A) in magnitude, and\n*          BETA always less than and usually comparable with norm(B).\n*\n*  VL      (output) REAL array, dimension (LDVL,N)\n*          If JOBVL = 'V', the left eigenvectors u(j) are stored one\n*          after another in the columns of VL, in the same order as\n*          their eigenvalues. If the j-th eigenvalue is real, then\n*          u(j) = VL(:,j), the j-th column of VL. If the j-th and\n*          (j+1)-th eigenvalues form a complex conjugate pair, then\n*          u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).\n*          Each eigenvector is scaled so the largest component has\n*          abs(real part)+abs(imag. part)=1.\n*          Not referenced if JOBVL = 'N'.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the matrix VL. LDVL >= 1, and\n*          if JOBVL = 'V', LDVL >= N.\n*\n*  VR      (output) REAL array, dimension (LDVR,N)\n*          If JOBVR = 'V', the right eigenvectors v(j) are stored one\n*          after another in the columns of VR, in the same order as\n*          their eigenvalues. If the j-th eigenvalue is real, then\n*          v(j) = VR(:,j), the j-th column of VR. If the j-th and\n*          (j+1)-th eigenvalues form a complex conjugate pair, then\n*          v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).\n*          Each eigenvector is scaled so the largest component has\n*          abs(real part)+abs(imag. part)=1.\n*          Not referenced if JOBVR = 'N'.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the matrix VR. LDVR >= 1, and\n*          if JOBVR = 'V', LDVR >= N.\n*\n*  WORK    (workspace/output) REAL 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,8*N).\n*          For good performance, LWORK must generally be larger.\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*          = 1,...,N:\n*                The QZ iteration failed.  No eigenvectors have been\n*                calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)\n*                should be correct for j=INFO+1,...,N.\n*          > N:  =N+1: other than QZ iteration failed in SHGEQZ.\n*                =N+2: error return from STGEVC.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.sggev( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_jobvl = argv[0];
  rblapack_jobvr = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  jobvl = StringValueCStr(rblapack_jobvl)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  jobvr = StringValueCStr(rblapack_jobvr)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  ldvr = lsame_(&jobvr,"V") ? n : 1;
  if (rblapack_lwork == Qnil)
    lwork = MAX(1,8*n);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldvl = lsame_(&jobvl,"V") ? n : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  alphar = NA_PTR_TYPE(rblapack_alphar, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  alphai = NA_PTR_TYPE(rblapack_alphai, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = n;
    rblapack_vl = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vl = NA_PTR_TYPE(rblapack_vl, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = n;
    rblapack_vr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vr = NA_PTR_TYPE(rblapack_vr, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  sggev_(&jobvl, &jobvr, &n, a, &lda, b, &ldb, alphar, alphai, beta, vl, &ldvl, vr, &ldvr, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_vl, rblapack_vr, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_sggev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sggev", rblapack_sggev, -1);
}
ruby-lapack-1.7.2/ext/dgecon.c0000644000175000017500000001002112502221016015753 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgecon_(char* norm, integer* n, doublereal* a, integer* lda, doublereal* anorm, doublereal* rcond, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dgecon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_anorm;
  doublereal anorm; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_info;
  integer info; 
  doublereal *work;
  integer *iwork;

  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  rcond, info = NumRu::Lapack.dgecon( norm, a, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGECON estimates the reciprocal of the condition number of a general\n*  real matrix A, in either the 1-norm or the infinity-norm, using\n*  the LU factorization computed by DGETRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as\n*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies whether the 1-norm condition number or the\n*          infinity-norm condition number is required:\n*          = '1' or 'O':  1-norm;\n*          = 'I':         Infinity-norm.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*          The factors L and U from the factorization A = P*L*U\n*          as computed by DGETRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  ANORM   (input) DOUBLE PRECISION\n*          If NORM = '1' or 'O', the 1-norm of the original matrix A.\n*          If NORM = 'I', the infinity-norm of the original matrix A.\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(norm(A) * norm(inv(A))).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.dgecon( norm, a, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_norm = argv[0];
  rblapack_a = argv[1];
  rblapack_anorm = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  anorm = NUM2DBL(rblapack_anorm);
  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*);
  work = ALLOC_N(doublereal, (4*n));
  iwork = ALLOC_N(integer, (n));

  dgecon_(&norm, &n, a, &lda, &anorm, &rcond, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_dgecon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgecon", rblapack_dgecon, -1);
}
ruby-lapack-1.7.2/ext/zunm2l.c0000644000175000017500000001445512502221026015763 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zunm2l_(char* side, char* trans, integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work, integer* info);


static VALUE
rblapack_zunm2l(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_c;
  doublecomplex *c; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublecomplex *c_out__;
  doublecomplex *work;

  integer lda;
  integer k;
  integer ldc;
  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  info, c = NumRu::Lapack.zunm2l( side, trans, m, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZUNM2L overwrites the general complex m-by-n matrix C with\n*\n*        Q * C  if SIDE = 'L' and TRANS = 'N', or\n*\n*        Q'* C  if SIDE = 'L' and TRANS = 'C', or\n*\n*        C * Q  if SIDE = 'R' and TRANS = 'N', or\n*\n*        C * Q' if SIDE = 'R' and TRANS = 'C',\n*\n*  where Q is a complex unitary matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(k) . . . H(2) H(1)\n*\n*  as returned by ZGEQLF. Q is of order m if SIDE = 'L' and of order n\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q' from the Left\n*          = 'R': apply Q or Q' from the Right\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': apply Q  (No transpose)\n*          = 'C': apply Q' (Conjugate transpose)\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,K)\n*          The i-th column must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          ZGEQLF in the last k columns of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*          If SIDE = 'L', LDA >= max(1,M);\n*          if SIDE = 'R', LDA >= max(1,N).\n*\n*  TAU     (input) COMPLEX*16 array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by ZGEQLF.\n*\n*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)\n*          On entry, the m-by-n matrix C.\n*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension\n*                                   (N) if SIDE = 'L',\n*                                   (M) if SIDE = 'R'\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, c = NumRu::Lapack.zunm2l( side, trans, m, a, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_m = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != k)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
  MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(doublecomplex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  zunm2l_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_c);
}

void
init_lapack_zunm2l(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zunm2l", rblapack_zunm2l, -1);
}
ruby-lapack-1.7.2/ext/chegs2.c0000644000175000017500000001214312502221012015672 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chegs2_(integer* itype, char* uplo, integer* n, complex* a, integer* lda, complex* b, integer* ldb, integer* info);


static VALUE
rblapack_chegs2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;

  integer lda;
  integer n;
  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  info, a = NumRu::Lapack.chegs2( itype, uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHEGS2 reduces a complex Hermitian-definite generalized\n*  eigenproblem to standard form.\n*\n*  If ITYPE = 1, the problem is A*x = lambda*B*x,\n*  and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')\n*\n*  If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n*  B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.\n*\n*  B must have been previously factorized as U'*U or L*L' by CPOTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');\n*          = 2 or 3: compute U*A*U' or L'*A*L.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          Hermitian matrix A is stored, and how B has been factorized.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading\n*          n by n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n by n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the transformed matrix, stored in the\n*          same format as A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input) COMPLEX array, dimension (LDB,N)\n*          The triangular factor from the Cholesky factorization of B,\n*          as returned by CPOTRF.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.chegs2( itype, uplo, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_itype = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  itype = NUM2INT(rblapack_itype);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  chegs2_(&itype, &uplo, &n, a, &lda, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_chegs2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chegs2", rblapack_chegs2, -1);
}
ruby-lapack-1.7.2/ext/slartgs.c0000644000175000017500000000517012502221021016200 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slartgs_(real* x, real* y, real* sigma, real* cs, real* sn);


static VALUE
rblapack_slartgs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_x;
  real x; 
  VALUE rblapack_y;
  real y; 
  VALUE rblapack_sigma;
  real sigma; 
  VALUE rblapack_cs;
  real cs; 
  VALUE rblapack_sn;
  real sn; 


  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  cs, sn = NumRu::Lapack.slartgs( x, y, sigma, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLARTGS( X, Y, SIGMA, CS, SN )\n\n*  Purpose\n*  =======\n*\n*  SLARTGS generates a plane rotation designed to introduce a bulge in\n*  Golub-Reinsch-style implicit QR iteration for the bidiagonal SVD\n*  problem. X and Y are the top-row entries, and SIGMA is the shift.\n*  The computed CS and SN define a plane rotation satisfying\n*\n*     [  CS  SN  ]  .  [ X^2 - SIGMA ]  =  [ R ],\n*     [ -SN  CS  ]     [    X * Y    ]     [ 0 ]\n*\n*  with R nonnegative.  If X^2 - SIGMA and X * Y are 0, then the\n*  rotation is by PI/2.\n*\n\n*  Arguments\n*  =========\n*\n*  X       (input) REAL\n*          The (1,1) entry of an upper bidiagonal matrix.\n*\n*  Y       (input) REAL\n*          The (1,2) entry of an upper bidiagonal matrix.\n*\n*  SIGMA   (input) REAL\n*          The shift.\n*\n*  CS      (output) REAL\n*          The cosine of the rotation.\n*\n*  SN      (output) REAL\n*          The sine of the rotation.\n*\n\n*  ===================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  cs, sn = NumRu::Lapack.slartgs( x, y, sigma, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_x = argv[0];
  rblapack_y = argv[1];
  rblapack_sigma = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  x = (real)NUM2DBL(rblapack_x);
  sigma = (real)NUM2DBL(rblapack_sigma);
  y = (real)NUM2DBL(rblapack_y);

  slartgs_(&x, &y, &sigma, &cs, &sn);

  rblapack_cs = rb_float_new((double)cs);
  rblapack_sn = rb_float_new((double)sn);
  return rb_ary_new3(2, rblapack_cs, rblapack_sn);
}

void
init_lapack_slartgs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slartgs", rblapack_slartgs, -1);
}
ruby-lapack-1.7.2/ext/spptrf.c0000644000175000017500000001045712502221016016047 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID spptrf_(char* uplo, integer* n, real* ap, integer* info);


static VALUE
rblapack_spptrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  real *ap_out__;


  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  info, ap = NumRu::Lapack.spptrf( uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPPTRF( UPLO, N, AP, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPPTRF computes the Cholesky factorization of a real symmetric\n*  positive definite matrix A stored in packed format.\n*\n*  The factorization has the form\n*     A = U**T * U,  if UPLO = 'U', or\n*     A = L  * L**T,  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is lower triangular.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) REAL array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          See below for further details.\n*\n*          On exit, if INFO = 0, the triangular factor U or L from the\n*          Cholesky factorization A = U**T*U or A = L*L**T, in the same\n*          storage format as A.\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 leading minor of order i is not\n*                positive definite, and the factorization could not be\n*                completed.\n*\n\n*  Further Details\n*  ======= =======\n*\n*  The packed storage scheme is illustrated by the following example\n*  when N = 4, UPLO = 'U':\n*\n*  Two-dimensional storage of the symmetric matrix A:\n*\n*     a11 a12 a13 a14\n*         a22 a23 a24\n*             a33 a34     (aij = aji)\n*                 a44\n*\n*  Packed storage of the upper triangle of A:\n*\n*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ap = NumRu::Lapack.spptrf( uplo, n, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_n = argv[1];
  rblapack_ap = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, real*);
  MEMCPY(ap_out__, ap, real, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  spptrf_(&uplo, &n, ap, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ap);
}

void
init_lapack_spptrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "spptrf", rblapack_spptrf, -1);
}
ruby-lapack-1.7.2/ext/dlarzb.c0000644000175000017500000001555112502221021016003 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlarzb_(char* side, char* trans, char* direct, char* storev, integer* m, integer* n, integer* k, integer* l, doublereal* v, integer* ldv, doublereal* t, integer* ldt, doublereal* c, integer* ldc, doublereal* work, integer* ldwork);


static VALUE
rblapack_dlarzb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_direct;
  char direct; 
  VALUE rblapack_storev;
  char storev; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_v;
  doublereal *v; 
  VALUE rblapack_t;
  doublereal *t; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_c_out__;
  doublereal *c_out__;
  doublereal *work;

  integer ldv;
  integer nv;
  integer ldt;
  integer k;
  integer ldc;
  integer n;
  integer ldwork;

  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  c = NumRu::Lapack.dlarzb( side, trans, direct, storev, m, l, v, t, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n*  Purpose\n*  =======\n*\n*  DLARZB applies a real block reflector H or its transpose H**T to\n*  a real distributed M-by-N  C from the left or the right.\n*\n*  Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply H or H' from the Left\n*          = 'R': apply H or H' from the Right\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': apply H (No transpose)\n*          = 'C': apply H' (Transpose)\n*\n*  DIRECT  (input) CHARACTER*1\n*          Indicates how H is formed from a product of elementary\n*          reflectors\n*          = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n*          = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n*  STOREV  (input) CHARACTER*1\n*          Indicates how the vectors which define the elementary\n*          reflectors are stored:\n*          = 'C': Columnwise                        (not supported yet)\n*          = 'R': Rowwise\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C.\n*\n*  K       (input) INTEGER\n*          The order of the matrix T (= the number of elementary\n*          reflectors whose product defines the block reflector).\n*\n*  L       (input) INTEGER\n*          The number of columns of the matrix V containing the\n*          meaningful part of the Householder reflectors.\n*          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n*  V       (input) DOUBLE PRECISION array, dimension (LDV,NV).\n*          If STOREV = 'C', NV = K; if STOREV = 'R', NV = L.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V.\n*          If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K.\n*\n*  T       (input) DOUBLE PRECISION array, dimension (LDT,K)\n*          The triangular K-by-K matrix T in the representation of the\n*          block reflector.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= K.\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by H*C or H'*C or C*H or C*H'.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (LDWORK,K)\n*\n*  LDWORK  (input) INTEGER\n*          The leading dimension of the array WORK.\n*          If SIDE = 'L', LDWORK >= max(1,N);\n*          if SIDE = 'R', LDWORK >= max(1,M).\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.dlarzb( side, trans, direct, storev, m, l, v, t, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_direct = argv[2];
  rblapack_storev = argv[3];
  rblapack_m = argv[4];
  rblapack_l = argv[5];
  rblapack_v = argv[6];
  rblapack_t = argv[7];
  rblapack_c = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  direct = StringValueCStr(rblapack_direct)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (7th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  nv = NA_SHAPE1(rblapack_v);
  if (NA_TYPE(rblapack_v) != NA_DFLOAT)
    rblapack_v = na_change_type(rblapack_v, NA_DFLOAT);
  v = NA_PTR_TYPE(rblapack_v, doublereal*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (9th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  trans = StringValueCStr(rblapack_trans)[0];
  l = NUM2INT(rblapack_l);
  ldwork = MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0;
  storev = StringValueCStr(rblapack_storev)[0];
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (8th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (8th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  k = NA_SHAPE1(rblapack_t);
  if (NA_TYPE(rblapack_t) != NA_DFLOAT)
    rblapack_t = na_change_type(rblapack_t, NA_DFLOAT);
  t = NA_PTR_TYPE(rblapack_t, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(doublereal, (ldwork)*(k));

  dlarzb_(&side, &trans, &direct, &storev, &m, &n, &k, &l, v, &ldv, t, &ldt, c, &ldc, work, &ldwork);

  free(work);
  return rblapack_c;
}

void
init_lapack_dlarzb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlarzb", rblapack_dlarzb, -1);
}
ruby-lapack-1.7.2/ext/cppsvx.c0000644000175000017500000003625512502221015016057 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cppsvx_(char* fact, char* uplo, integer* n, integer* nrhs, complex* ap, complex* afp, char* equed, real* s, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* ferr, real* berr, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cppsvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_afp;
  complex *afp; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  complex *ap_out__;
  VALUE rblapack_afp_out__;
  complex *afp_out__;
  VALUE rblapack_s_out__;
  real *s_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;
  complex *work;
  real *rwork;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, info, ap, afp, equed, s, b = NumRu::Lapack.cppsvx( fact, uplo, ap, afp, equed, s, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPPSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to\n*  compute the solution to a complex system of linear equations\n*     A * X = B,\n*  where A is an N-by-N Hermitian positive definite matrix stored in\n*  packed format and X and B are N-by-NRHS matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'E', real scaling factors are computed to equilibrate\n*     the system:\n*        diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n*  2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n*     factor the matrix A (after equilibration if FACT = 'E') as\n*        A = U'* U ,  if UPLO = 'U', or\n*        A = L * L',  if UPLO = 'L',\n*     where U is an upper triangular matrix, L is a lower triangular\n*     matrix, and ' indicates conjugate transpose.\n*\n*  3. If the leading i-by-i principal minor is not positive definite,\n*     then the routine returns with INFO = i. Otherwise, the factored\n*     form of A is used to estimate the condition number of the matrix\n*     A.  If the reciprocal of the condition number is less than machine\n*     precision, INFO = N+1 is returned as a warning, but the routine\n*     still goes on to solve for X and compute error bounds as\n*     described below.\n*\n*  4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  5. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n*  6. If equilibration was used, the matrix X is premultiplied by\n*     diag(S) so that it solves the original system before\n*     equilibration.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of the matrix A is\n*          supplied on entry, and if not, whether the matrix A should be\n*          equilibrated before it is factored.\n*          = 'F':  On entry, AFP contains the factored form of A.\n*                  If EQUED = 'Y', the matrix A has been equilibrated\n*                  with scaling factors given by S.  AP and AFP will not\n*                  be modified.\n*          = 'N':  The matrix A will be copied to AFP and factored.\n*          = 'E':  The matrix A will be equilibrated if necessary, then\n*                  copied to AFP and factored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          A, packed columnwise in a linear array, except if FACT = 'F'\n*          and EQUED = 'Y', then A must contain the equilibrated matrix\n*          diag(S)*A*diag(S).  The j-th column of A is stored in the\n*          array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          See below for further details.  A is not modified if\n*          FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n*          On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n*          diag(S)*A*diag(S).\n*\n*  AFP     (input or output) COMPLEX array, dimension (N*(N+1)/2)\n*          If FACT = 'F', then AFP is an input argument and on entry\n*          contains the triangular factor U or L from the Cholesky\n*          factorization A = U**H*U or A = L*L**H, in the same storage\n*          format as A.  If EQUED .ne. 'N', then AFP is the factored\n*          form of the equilibrated matrix A.\n*\n*          If FACT = 'N', then AFP is an output argument and on exit\n*          returns the triangular factor U or L from the Cholesky\n*          factorization A = U**H*U or A = L*L**H of the original\n*          matrix A.\n*\n*          If FACT = 'E', then AFP is an output argument and on exit\n*          returns the triangular factor U or L from the Cholesky\n*          factorization A = U**H*U or A = L*L**H of the equilibrated\n*          matrix A (see the description of AP for the form of the\n*          equilibrated matrix).\n*\n*  EQUED   (input or output) CHARACTER*1\n*          Specifies the form of equilibration that was done.\n*          = 'N':  No equilibration (always true if FACT = 'N').\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*          EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*          output argument.\n*\n*  S       (input or output) REAL array, dimension (N)\n*          The scale factors for A; not accessed if EQUED = 'N'.  S is\n*          an input argument if FACT = 'F'; otherwise, S is an output\n*          argument.  If FACT = 'F' and EQUED = 'Y', each element of S\n*          must be positive.\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n*          B is overwritten by diag(S) * B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) COMPLEX array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n*          the original system of equations.  Note that if EQUED = 'Y',\n*          A and B are modified on exit, and the solution to the\n*          equilibrated system is inv(diag(S))*X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) REAL\n*          The estimate of the reciprocal condition number of the matrix\n*          A after equilibration (if done).  If RCOND is less than the\n*          machine precision (in particular, if RCOND = 0), the matrix\n*          is singular to working precision.  This condition is\n*          indicated by a return code of INFO > 0.\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\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, and i is\n*                <= N:  the leading minor of order i of A is\n*                       not positive definite, so the factorization\n*                       could not be completed, and the solution has not\n*                       been computed. RCOND = 0 is returned.\n*                = N+1: U is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  Further Details\n*  ===============\n*\n*  The packed storage scheme is illustrated by the following example\n*  when N = 4, UPLO = 'U':\n*\n*  Two-dimensional storage of the Hermitian matrix A:\n*\n*     a11 a12 a13 a14\n*         a22 a23 a24\n*             a33 a34     (aij = conjg(aji))\n*                 a44\n*\n*  Packed storage of the upper triangle of A:\n*\n*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, info, ap, afp, equed, s, b = NumRu::Lapack.cppsvx( fact, uplo, ap, afp, equed, s, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_ap = argv[2];
  rblapack_afp = argv[3];
  rblapack_equed = argv[4];
  rblapack_s = argv[5];
  rblapack_b = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (6th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_s);
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  ldx = MAX(1,n);
  if (!NA_IsNArray(rblapack_afp))
    rb_raise(rb_eArgError, "afp (4th argument) must be NArray");
  if (NA_RANK(rblapack_afp) != 1)
    rb_raise(rb_eArgError, "rank of afp (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_afp) != NA_SCOMPLEX)
    rblapack_afp = na_change_type(rblapack_afp, NA_SCOMPLEX);
  afp = NA_PTR_TYPE(rblapack_afp, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
  MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_afp_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  afp_out__ = NA_PTR_TYPE(rblapack_afp_out__, complex*);
  MEMCPY(afp_out__, afp, complex, NA_TOTAL(rblapack_afp));
  rblapack_afp = rblapack_afp_out__;
  afp = afp_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
  MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (n));

  cppsvx_(&fact, &uplo, &n, &nrhs, ap, afp, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_ap, rblapack_afp, rblapack_equed, rblapack_s, rblapack_b);
}

void
init_lapack_cppsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cppsvx", rblapack_cppsvx, -1);
}
ruby-lapack-1.7.2/ext/stgsen.c0000644000175000017500000005435112502221015016034 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID stgsen_(integer* ijob, logical* wantq, logical* wantz, logical* select, integer* n, real* a, integer* lda, real* b, integer* ldb, real* alphar, real* alphai, real* beta, real* q, integer* ldq, real* z, integer* ldz, integer* m, real* pl, real* pr, real* dif, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_stgsen(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ijob;
  integer ijob; 
  VALUE rblapack_wantq;
  logical wantq; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_select;
  logical *select; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_q;
  real *q; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_alphar;
  real *alphar; 
  VALUE rblapack_alphai;
  real *alphai; 
  VALUE rblapack_beta;
  real *beta; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_pl;
  real pl; 
  VALUE rblapack_pr;
  real pr; 
  VALUE rblapack_dif;
  real *dif; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_b_out__;
  real *b_out__;
  VALUE rblapack_q_out__;
  real *q_out__;
  VALUE rblapack_z_out__;
  real *z_out__;

  integer n;
  integer lda;
  integer ldb;
  integer ldq;
  integer ldz;

  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  alphar, alphai, beta, m, pl, pr, dif, work, iwork, info, a, b, q, z = NumRu::Lapack.stgsen( ijob, wantq, wantz, select, a, b, q, z, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  STGSEN reorders the generalized real Schur decomposition of a real\n*  matrix pair (A, B) (in terms of an orthonormal equivalence trans-\n*  formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues\n*  appears in the leading diagonal blocks of the upper quasi-triangular\n*  matrix A and the upper triangular B. The leading columns of Q and\n*  Z form orthonormal bases of the corresponding left and right eigen-\n*  spaces (deflating subspaces). (A, B) must be in generalized real\n*  Schur canonical form (as returned by SGGES), i.e. A is block upper\n*  triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper\n*  triangular.\n*\n*  STGSEN also computes the generalized eigenvalues\n*\n*              w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j)\n*\n*  of the reordered matrix pair (A, B).\n*\n*  Optionally, STGSEN computes the estimates of reciprocal condition\n*  numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),\n*  (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)\n*  between the matrix pairs (A11, B11) and (A22,B22) that correspond to\n*  the selected cluster and the eigenvalues outside the cluster, resp.,\n*  and norms of \"projections\" onto left and right eigenspaces w.r.t.\n*  the selected cluster in the (1,1)-block.\n*\n\n*  Arguments\n*  =========\n*\n*  IJOB    (input) INTEGER\n*          Specifies whether condition numbers are required for the\n*          cluster of eigenvalues (PL and PR) or the deflating subspaces\n*          (Difu and Difl):\n*           =0: Only reorder w.r.t. SELECT. No extras.\n*           =1: Reciprocal of norms of \"projections\" onto left and right\n*               eigenspaces w.r.t. the selected cluster (PL and PR).\n*           =2: Upper bounds on Difu and Difl. F-norm-based estimate\n*               (DIF(1:2)).\n*           =3: Estimate of Difu and Difl. 1-norm-based estimate\n*               (DIF(1:2)).\n*               About 5 times as expensive as IJOB = 2.\n*           =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic\n*               version to get it all.\n*           =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)\n*\n*  WANTQ   (input) LOGICAL\n*          .TRUE. : update the left transformation matrix Q;\n*          .FALSE.: do not update Q.\n*\n*  WANTZ   (input) LOGICAL\n*          .TRUE. : update the right transformation matrix Z;\n*          .FALSE.: do not update Z.\n*\n*  SELECT  (input) LOGICAL array, dimension (N)\n*          SELECT specifies the eigenvalues in the selected cluster.\n*          To select a real eigenvalue w(j), SELECT(j) must be set to\n*          .TRUE.. To select a complex conjugate pair of eigenvalues\n*          w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,\n*          either SELECT(j) or SELECT(j+1) or both must be set to\n*          .TRUE.; a complex conjugate pair of eigenvalues must be\n*          either both included in the cluster or both excluded.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B. N >= 0.\n*\n*  A       (input/output) REAL array, dimension(LDA,N)\n*          On entry, the upper quasi-triangular matrix A, with (A, B) in\n*          generalized real Schur canonical form.\n*          On exit, A is overwritten by the reordered matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  B       (input/output) REAL array, dimension(LDB,N)\n*          On entry, the upper triangular matrix B, with (A, B) in\n*          generalized real Schur canonical form.\n*          On exit, B is overwritten by the reordered matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  ALPHAR  (output) REAL array, dimension (N)\n*  ALPHAI  (output) REAL array, dimension (N)\n*  BETA    (output) REAL array, dimension (N)\n*          On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n*          be the generalized eigenvalues.  ALPHAR(j) + ALPHAI(j)*i\n*          and BETA(j),j=1,...,N  are the diagonals of the complex Schur\n*          form (S,T) that would result if the 2-by-2 diagonal blocks of\n*          the real generalized Schur form of (A,B) were further reduced\n*          to triangular form using complex unitary transformations.\n*          If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n*          positive, then the j-th and (j+1)-st eigenvalues are a\n*          complex conjugate pair, with ALPHAI(j+1) negative.\n*\n*  Q       (input/output) REAL array, dimension (LDQ,N)\n*          On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.\n*          On exit, Q has been postmultiplied by the left orthogonal\n*          transformation matrix which reorder (A, B); The leading M\n*          columns of Q form orthonormal bases for the specified pair of\n*          left eigenspaces (deflating subspaces).\n*          If WANTQ = .FALSE., Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.  LDQ >= 1;\n*          and if WANTQ = .TRUE., LDQ >= N.\n*\n*  Z       (input/output) REAL array, dimension (LDZ,N)\n*          On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.\n*          On exit, Z has been postmultiplied by the left orthogonal\n*          transformation matrix which reorder (A, B); The leading M\n*          columns of Z form orthonormal bases for the specified pair of\n*          left eigenspaces (deflating subspaces).\n*          If WANTZ = .FALSE., Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z. LDZ >= 1;\n*          If WANTZ = .TRUE., LDZ >= N.\n*\n*  M       (output) INTEGER\n*          The dimension of the specified pair of left and right eigen-\n*          spaces (deflating subspaces). 0 <= M <= N.\n*\n*  PL      (output) REAL\n*  PR      (output) REAL\n*          If IJOB = 1, 4 or 5, PL, PR are lower bounds on the\n*          reciprocal of the norm of \"projections\" onto left and right\n*          eigenspaces with respect to the selected cluster.\n*          0 < PL, PR <= 1.\n*          If M = 0 or M = N, PL = PR  = 1.\n*          If IJOB = 0, 2 or 3, PL and PR are not referenced.\n*\n*  DIF     (output) REAL array, dimension (2).\n*          If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.\n*          If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on\n*          Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based\n*          estimates of Difu and Difl.\n*          If M = 0 or N, DIF(1:2) = F-norm([A, B]).\n*          If IJOB = 0 or 1, DIF is not referenced.\n*\n*  WORK    (workspace/output) REAL 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 >=  4*N+16.\n*          If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)).\n*          If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)).\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*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK. LIWORK >= 1.\n*          If IJOB = 1, 2 or 4, LIWORK >=  N+6.\n*          If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6).\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal size of the IWORK array,\n*          returns this value as the first entry of the IWORK array, and\n*          no error message related to LIWORK 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*            =1: Reordering of (A, B) failed because the transformed\n*                matrix pair (A, B) would be too far from generalized\n*                Schur form; the problem is very ill-conditioned.\n*                (A, B) may have been partially reordered.\n*                If requested, 0 is returned in DIF(*), PL and PR.\n*\n\n*  Further Details\n*  ===============\n*\n*  STGSEN first collects the selected eigenvalues by computing\n*  orthogonal U and W that move them to the top left corner of (A, B).\n*  In other words, the selected eigenvalues are the eigenvalues of\n*  (A11, B11) in:\n*\n*                U'*(A, B)*W = (A11 A12) (B11 B12) n1\n*                              ( 0  A22),( 0  B22) n2\n*                                n1  n2    n1  n2\n*\n*  where N = n1+n2 and U' means the transpose of U. The first n1 columns\n*  of U and W span the specified pair of left and right eigenspaces\n*  (deflating subspaces) of (A, B).\n*\n*  If (A, B) has been obtained from the generalized real Schur\n*  decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the\n*  reordered generalized real Schur form of (C, D) is given by\n*\n*           (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',\n*\n*  and the first n1 columns of Q*U and Z*W span the corresponding\n*  deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).\n*\n*  Note that if the selected eigenvalue is sufficiently ill-conditioned,\n*  then its value may differ significantly from its value before\n*  reordering.\n*\n*  The reciprocal condition numbers of the left and right eigenspaces\n*  spanned by the first n1 columns of U and W (or Q*U and Z*W) may\n*  be returned in DIF(1:2), corresponding to Difu and Difl, resp.\n*\n*  The Difu and Difl are defined as:\n*\n*       Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )\n*  and\n*       Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],\n*\n*  where sigma-min(Zu) is the smallest singular value of the\n*  (2*n1*n2)-by-(2*n1*n2) matrix\n*\n*       Zu = [ kron(In2, A11)  -kron(A22', In1) ]\n*            [ kron(In2, B11)  -kron(B22', In1) ].\n*\n*  Here, Inx is the identity matrix of size nx and A22' is the\n*  transpose of A22. kron(X, Y) is the Kronecker product between\n*  the matrices X and Y.\n*\n*  When DIF(2) is small, small changes in (A, B) can cause large changes\n*  in the deflating subspace. An approximate (asymptotic) bound on the\n*  maximum angular error in the computed deflating subspaces is\n*\n*       EPS * norm((A, B)) / DIF(2),\n*\n*  where EPS is the machine precision.\n*\n*  The reciprocal norm of the projectors on the left and right\n*  eigenspaces associated with (A11, B11) may be returned in PL and PR.\n*  They are computed as follows. First we compute L and R so that\n*  P*(A, B)*Q is block diagonal, where\n*\n*       P = ( I -L ) n1           Q = ( I R ) n1\n*           ( 0  I ) n2    and        ( 0 I ) n2\n*             n1 n2                    n1 n2\n*\n*  and (L, R) is the solution to the generalized Sylvester equation\n*\n*       A11*R - L*A22 = -A12\n*       B11*R - L*B22 = -B12\n*\n*  Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).\n*  An approximate (asymptotic) bound on the average absolute error of\n*  the selected eigenvalues is\n*\n*       EPS * norm((A, B)) / PL.\n*\n*  There are also global error bounds which valid for perturbations up\n*  to a certain restriction:  A lower bound (x) on the smallest\n*  F-norm(E,F) for which an eigenvalue of (A11, B11) may move and\n*  coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),\n*  (i.e. (A + E, B + F), is\n*\n*   x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).\n*\n*  An approximate bound on x can be computed from DIF(1:2), PL and PR.\n*\n*  If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed\n*  (L', R') and unperturbed (L, R) left and right deflating subspaces\n*  associated with the selected cluster in the (1,1)-blocks can be\n*  bounded as\n*\n*   max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))\n*   max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))\n*\n*  See LAPACK User's Guide section 4.11 or the following references\n*  for more information.\n*\n*  Note that if the default method for computing the Frobenius-norm-\n*  based estimate DIF is not wanted (see SLATDF), then the parameter\n*  IDIFJB (see below) should be changed from 3 to 4 (routine SLATDF\n*  (IJOB = 2 will be used)). See STGSYL for more details.\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  References\n*  ==========\n*\n*  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n*      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n*      M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n*      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n*  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n*      Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n*      Estimation: Theory, Algorithms and Software,\n*      Report UMINF - 94.04, Department of Computing Science, Umea\n*      University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working\n*      Note 87. To appear in Numerical Algorithms, 1996.\n*\n*  [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n*      for Solving the Generalized Sylvester Equation and Estimating the\n*      Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n*      Department of Computing Science, Umea University, S-901 87 Umea,\n*      Sweden, December 1993, Revised April 1994, Also as LAPACK Working\n*      Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,\n*      1996.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  alphar, alphai, beta, m, pl, pr, dif, work, iwork, info, a, b, q, z = NumRu::Lapack.stgsen( ijob, wantq, wantz, select, a, b, q, z, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_ijob = argv[0];
  rblapack_wantq = argv[1];
  rblapack_wantz = argv[2];
  rblapack_select = argv[3];
  rblapack_a = argv[4];
  rblapack_b = argv[5];
  rblapack_q = argv[6];
  rblapack_z = argv[7];
  if (argc == 10) {
    rblapack_lwork = argv[8];
    rblapack_liwork = argv[9];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  ijob = NUM2INT(rblapack_ijob);
  wantz = (rblapack_wantz == Qtrue);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (7th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_q) != NA_SFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
  q = NA_PTR_TYPE(rblapack_q, real*);
  wantq = (rblapack_wantq == Qtrue);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (!NA_IsNArray(rblapack_select))
    rb_raise(rb_eArgError, "select (4th argument) must be NArray");
  if (NA_RANK(rblapack_select) != 1)
    rb_raise(rb_eArgError, "rank of select (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_select) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_select) != NA_LINT)
    rblapack_select = na_change_type(rblapack_select, NA_LINT);
  select = NA_PTR_TYPE(rblapack_select, logical*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (8th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  if (NA_SHAPE1(rblapack_z) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  if (rblapack_liwork == Qnil)
    liwork = (ijob==1||ijob==2||ijob==4) ? n+6 : (ijob==3||ijob==5) ? MAX(2*m*(n-m),n+6) : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  if (rblapack_lwork == Qnil)
    lwork = (ijob==1||ijob==2||ijob==4) ? MAX(4*n+16,2*m*(n-m)) : (ijob==3||ijob==5) ? MAX(4*n+16,4*m*(n-m)) : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  alphar = NA_PTR_TYPE(rblapack_alphar, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  alphai = NA_PTR_TYPE(rblapack_alphai, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, real*);
  {
    na_shape_t shape[1];
    shape[0] = 2;
    rblapack_dif = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  dif = NA_PTR_TYPE(rblapack_dif, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
  MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
  MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  stgsen_(&ijob, &wantq, &wantz, select, &n, a, &lda, b, &ldb, alphar, alphai, beta, q, &ldq, z, &ldz, &m, &pl, &pr, dif, work, &lwork, iwork, &liwork, &info);

  rblapack_m = INT2NUM(m);
  rblapack_pl = rb_float_new((double)pl);
  rblapack_pr = rb_float_new((double)pr);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(14, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_m, rblapack_pl, rblapack_pr, rblapack_dif, rblapack_work, rblapack_iwork, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z);
}

void
init_lapack_stgsen(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "stgsen", rblapack_stgsen, -1);
}
ruby-lapack-1.7.2/ext/ztbtrs.c0000644000175000017500000001326312502221014016055 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztbtrs_(char* uplo, char* trans, char* diag, integer* n, integer* kd, integer* nrhs, doublecomplex* ab, integer* ldab, doublecomplex* b, integer* ldb, integer* info);


static VALUE
rblapack_ztbtrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer ldab;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.ztbtrs( uplo, trans, diag, kd, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTBTRS solves a triangular system of the form\n*\n*     A * X = B,  A**T * X = B,  or  A**H * X = B,\n*\n*  where A is a triangular band matrix of order N, and B is an\n*  N-by-NRHS matrix.  A check is made to verify that A is nonsingular.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals or subdiagonals of the\n*          triangular band matrix A.  KD >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)\n*          The upper or lower triangular band matrix A, stored in the\n*          first kd+1 rows of AB.  The j-th column of A is stored\n*          in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*          If DIAG = 'U', the diagonal elements of A are not referenced\n*          and are assumed to be 1.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, if INFO = 0, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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 A is zero,\n*                indicating that the matrix is singular and the\n*                solutions X have not been computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.ztbtrs( uplo, trans, diag, kd, ab, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_kd = argv[3];
  rblapack_ab = argv[4];
  rblapack_b = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  kd = NUM2INT(rblapack_kd);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  ztbtrs_(&uplo, &trans, &diag, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_ztbtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztbtrs", rblapack_ztbtrs, -1);
}
ruby-lapack-1.7.2/ext/dtpttr.c0000644000175000017500000000743012502221022016044 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtpttr_(char* uplo, integer* n, doublereal* ap, doublereal* a, integer* lda, integer* info);


static VALUE
rblapack_dtpttr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_info;
  integer info; 

  integer ldap;
  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  a, info = NumRu::Lapack.dtpttr( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTPTTR( UPLO, N, AP, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTPTTR copies a triangular matrix A from standard packed format (TP)\n*  to standard full format (TR).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular.\n*          = 'L':  A is lower triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0.\n*\n*  AP      (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ),\n*          On entry, the upper or lower triangular matrix A, packed\n*          columnwise in a linear array. The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  A       (output) DOUBLE PRECISION array, dimension ( LDA, N )\n*          On exit, the triangular matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  a, info = NumRu::Lapack.dtpttr( uplo, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  lda = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  a = NA_PTR_TYPE(rblapack_a, doublereal*);

  dtpttr_(&uplo, &n, ap, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_a, rblapack_info);
}

void
init_lapack_dtpttr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtpttr", rblapack_dtpttr, -1);
}
ruby-lapack-1.7.2/ext/slasrt.c0000644000175000017500000000607312502221025016040 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slasrt_(char* id, integer* n, real* d, integer* info);


static VALUE
rblapack_slasrt(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_id;
  char id; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;

  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  info, d = NumRu::Lapack.slasrt( id, d, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASRT( ID, N, D, INFO )\n\n*  Purpose\n*  =======\n*\n*  Sort the numbers in D in increasing order (if ID = 'I') or\n*  in decreasing order (if ID = 'D' ).\n*\n*  Use Quick Sort, reverting to Insertion sort on arrays of\n*  size <= 20. Dimension of STACK limits N to about 2**32.\n*\n\n*  Arguments\n*  =========\n*\n*  ID      (input) CHARACTER*1\n*          = 'I': sort D in increasing order;\n*          = 'D': sort D in decreasing order.\n*\n*  N       (input) INTEGER\n*          The length of the array D.\n*\n*  D       (input/output) REAL array, dimension (N)\n*          On entry, the array to be sorted.\n*          On exit, D has been sorted into increasing order\n*          (D(1) <= ... <= D(N) ) or into decreasing order\n*          (D(1) >= ... >= D(N) ), depending on ID.\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d = NumRu::Lapack.slasrt( id, d, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_id = argv[0];
  rblapack_d = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  id = StringValueCStr(rblapack_id)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;

  slasrt_(&id, &n, d, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_d);
}

void
init_lapack_slasrt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slasrt", rblapack_slasrt, -1);
}
ruby-lapack-1.7.2/ext/zgetf2.c0000644000175000017500000001021212502221021015713 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgetf2_(integer* m, integer* n, doublecomplex* a, integer* lda, integer* ipiv, integer* info);


static VALUE
rblapack_zgetf2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *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  ipiv, info, a = NumRu::Lapack.zgetf2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGETF2 computes an LU factorization of a general m-by-n matrix A\n*  using partial pivoting with row interchanges.\n*\n*  The factorization has the form\n*     A = P * L * U\n*  where P is a permutation matrix, L is lower triangular with unit\n*  diagonal elements (lower trapezoidal if m > n), and U is upper\n*  triangular (upper trapezoidal if m < n).\n*\n*  This is the right-looking Level 2 BLAS version of the algorithm.\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) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the m by n matrix to be factored.\n*          On exit, the factors L and U from the factorization\n*          A = P*L*U; the unit diagonal elements of L are not stored.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  IPIV    (output) INTEGER array, dimension (min(M,N))\n*          The pivot indices; for 1 <= i <= min(M,N), row i of the\n*          matrix was interchanged with row IPIV(i).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*          > 0: if INFO = k, U(k,k) is exactly zero. The factorization\n*               has been completed, but the factor U is exactly\n*               singular, and division by zero will occur if it is used\n*               to solve a system of equations.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, a = NumRu::Lapack.zgetf2( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zgetf2_(&m, &n, a, &lda, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_a);
}

void
init_lapack_zgetf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgetf2", rblapack_zgetf2, -1);
}
ruby-lapack-1.7.2/ext/dlascl2.c0000644000175000017500000000660012502221013016045 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlascl2_(integer* m, integer* n, doublereal* d, doublereal* x, integer* ldx);


static VALUE
rblapack_dlascl2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_x_out__;
  doublereal *x_out__;

  integer m;
  integer ldx;
  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  x = NumRu::Lapack.dlascl2( d, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLASCL2 ( M, N, D, X, LDX )\n\n*  Purpose\n*  =======\n*\n*  DLASCL2 performs a diagonal scaling on a vector:\n*    x <-- D * x\n*  where the diagonal matrix D is stored as a vector.\n*\n*  Eventually to be replaced by BLAS_dge_diag_scale in the new BLAS\n*  standard.\n*\n\n*  Arguments\n*  =========\n*\n*     M       (input) INTEGER\n*     The number of rows of D and X. M >= 0.\n*\n*     N       (input) INTEGER\n*     The number of columns of D and X. N >= 0.\n*\n*     D       (input) DOUBLE PRECISION array, length M\n*     Diagonal matrix D, stored as a vector of length M.\n*\n*     X       (input/output) DOUBLE PRECISION array, dimension (LDX,N)\n*     On entry, the vector X to be scaled by D.\n*     On exit, the scaled vector.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the vector X. LDX >= 0.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x = NumRu::Lapack.dlascl2( d, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_d = argv[0];
  rblapack_x = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  n = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = n;
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;

  dlascl2_(&m, &n, d, x, &ldx);

  return rblapack_x;
}

void
init_lapack_dlascl2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlascl2", rblapack_dlascl2, -1);
}
ruby-lapack-1.7.2/ext/sla_gbrfsx_extended.c0000644000175000017500000005731512502221024020546 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sla_gbrfsx_extended_(integer* prec_type, integer* trans_type, integer* n, integer* kl, integer* ku, integer* nrhs, real* ab, integer* ldab, real* afb, integer* ldafb, integer* ipiv, logical* colequ, real* c, real* b, integer* ldb, real* y, integer* ldy, real* berr_out, integer* n_norms, real* err_bnds_norm, real* err_bnds_comp, real* res, real* ayb, real* dy, real* y_tail, real* rcond, integer* ithresh, real* rthresh, real* dz_ub, logical* ignore_cwise, integer* info);


static VALUE
rblapack_sla_gbrfsx_extended(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_prec_type;
  integer prec_type; 
  VALUE rblapack_trans_type;
  integer trans_type; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_afb;
  real *afb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_colequ;
  logical colequ; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_y;
  real *y; 
  VALUE rblapack_err_bnds_norm;
  real *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  real *err_bnds_comp; 
  VALUE rblapack_res;
  real *res; 
  VALUE rblapack_ayb;
  real *ayb; 
  VALUE rblapack_dy;
  real *dy; 
  VALUE rblapack_y_tail;
  real *y_tail; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_ithresh;
  integer ithresh; 
  VALUE rblapack_rthresh;
  real rthresh; 
  VALUE rblapack_dz_ub;
  real dz_ub; 
  VALUE rblapack_ignore_cwise;
  logical ignore_cwise; 
  VALUE rblapack_berr_out;
  real *berr_out; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_y_out__;
  real *y_out__;
  VALUE rblapack_err_bnds_norm_out__;
  real *err_bnds_norm_out__;
  VALUE rblapack_err_bnds_comp_out__;
  real *err_bnds_comp_out__;

  integer ldab;
  integer n;
  integer ldafb;
  integer ldb;
  integer nrhs;
  integer ldy;
  integer n_norms;

  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  berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.sla_gbrfsx_extended( prec_type, trans_type, kl, ku, ab, afb, ipiv, colequ, c, b, y, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLA_GBRFSX_EXTENDED improves the computed solution to a system of\n*  linear equations by performing extra-precise iterative refinement\n*  and provides error bounds and backward error estimates for the solution.\n*  This subroutine is called by SGBRFSX to perform iterative refinement.\n*  In addition to normwise error bound, the code provides maximum\n*  componentwise error bound if possible. See comments for ERR_BNDS_NORM\n*  and ERR_BNDS_COMP for details of the error bounds. Note that this\n*  subroutine is only resonsible for setting the second fields of\n*  ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n*  Arguments\n*  =========\n*\n*     PREC_TYPE      (input) INTEGER\n*     Specifies the intermediate precision to be used in refinement.\n*     The value is defined by ILAPREC(P) where P is a CHARACTER and\n*     P    = 'S':  Single\n*          = 'D':  Double\n*          = 'I':  Indigenous\n*          = 'X', 'E':  Extra\n*\n*     TRANS_TYPE     (input) INTEGER\n*     Specifies the transposition operation on A.\n*     The value is defined by ILATRANS(T) where T is a CHARACTER and\n*     T    = 'N':  No transpose\n*          = 'T':  Transpose\n*          = 'C':  Conjugate transpose\n*\n*     N              (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     KL             (input) INTEGER\n*     The number of subdiagonals within the band of A.  KL >= 0.\n*\n*     KU             (input) INTEGER\n*     The number of superdiagonals within the band of A.  KU >= 0\n*\n*     NRHS           (input) INTEGER\n*     The number of right-hand-sides, i.e., the number of columns of the\n*     matrix B.\n*\n*     A              (input) REAL array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA            (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF             (input) REAL array, dimension (LDAF,N)\n*     The factors L and U from the factorization\n*     A = P*L*U as computed by SGBTRF.\n*\n*     LDAF           (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV           (input) INTEGER array, dimension (N)\n*     The pivot indices from the factorization A = P*L*U\n*     as computed by SGBTRF; row i of the matrix was interchanged\n*     with row IPIV(i).\n*\n*     COLEQU         (input) LOGICAL\n*     If .TRUE. then column equilibration was done to A before calling\n*     this routine. This is needed to compute the solution and error\n*     bounds correctly.\n*\n*     C              (input) REAL array, dimension (N)\n*     The column scale factors for A. If COLEQU = .FALSE., C\n*     is not accessed. If C is input, each element of C should be a power\n*     of the radix to ensure a reliable solution and error estimates.\n*     Scaling by powers of the radix does not cause rounding errors unless\n*     the result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B              (input) REAL array, dimension (LDB,NRHS)\n*     The right-hand-side matrix B.\n*\n*     LDB            (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     Y              (input/output) REAL array, dimension (LDY,NRHS)\n*     On entry, the solution matrix X, as computed by SGBTRS.\n*     On exit, the improved solution matrix Y.\n*\n*     LDY            (input) INTEGER\n*     The leading dimension of the array Y.  LDY >= max(1,N).\n*\n*     BERR_OUT       (output) REAL array, dimension (NRHS)\n*     On exit, BERR_OUT(j) contains the componentwise relative backward\n*     error for right-hand-side j from the formula\n*         max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n*     where abs(Z) is the componentwise absolute value of the matrix\n*     or vector Z. This is computed by SLA_LIN_BERR.\n*\n*     N_NORMS        (input) INTEGER\n*     Determines which error bounds to return (see ERR_BNDS_NORM\n*     and ERR_BNDS_COMP).\n*     If N_NORMS >= 1 return normwise error bounds.\n*     If N_NORMS >= 2 return componentwise error bounds.\n*\n*     ERR_BNDS_NORM  (input/output) REAL array, dimension \n*                    (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (input/output) REAL array, dimension \n*                    (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     RES            (input) REAL array, dimension (N)\n*     Workspace to hold the intermediate residual.\n*\n*     AYB            (input) REAL array, dimension (N)\n*     Workspace. This can be the same workspace passed for Y_TAIL.\n*\n*     DY             (input) REAL array, dimension (N)\n*     Workspace to hold the intermediate solution.\n*\n*     Y_TAIL         (input) REAL array, dimension (N)\n*     Workspace to hold the trailing bits of the intermediate solution.\n*\n*     RCOND          (input) REAL\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     ITHRESH        (input) INTEGER\n*     The maximum number of residual computations allowed for\n*     refinement. The default is 10. For 'aggressive' set to 100 to\n*     permit convergence using approximate factorizations or\n*     factorizations other than LU. If the factorization uses a\n*     technique other than Gaussian elimination, the guarantees in\n*     ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n*     RTHRESH        (input) REAL\n*     Determines when to stop refinement if the error estimate stops\n*     decreasing. Refinement will stop when the next solution no longer\n*     satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n*     the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n*     default value is 0.5. For 'aggressive' set to 0.9 to permit\n*     convergence on extremely ill-conditioned matrices. See LAWN 165\n*     for more details.\n*\n*     DZ_UB          (input) REAL\n*     Determines when to start considering componentwise convergence.\n*     Componentwise convergence is only considered after each component\n*     of the solution Y is stable, which we definte as the relative\n*     change in each component being less than DZ_UB. The default value\n*     is 0.25, requiring the first bit to be stable. See LAWN 165 for\n*     more details.\n*\n*     IGNORE_CWISE   (input) LOGICAL\n*     If .TRUE. then ignore componentwise convergence. Default value\n*     is .FALSE..\n*\n*     INFO           (output) INTEGER\n*       = 0:  Successful exit.\n*       < 0:  if INFO = -i, the ith argument to SGBTRS had an illegal\n*             value\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      CHARACTER          TRANS\n      INTEGER            CNT, I, J, M, X_STATE, Z_STATE, Y_PREC_STATE\n      REAL               YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n     $                   DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n     $                   DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n     $                   EPS, HUGEVAL, INCR_THRESH\n      LOGICAL            INCR_PREC\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.sla_gbrfsx_extended( prec_type, trans_type, kl, ku, ab, afb, ipiv, colequ, c, b, y, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 22 && argc != 22)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 22)", argc);
  rblapack_prec_type = argv[0];
  rblapack_trans_type = argv[1];
  rblapack_kl = argv[2];
  rblapack_ku = argv[3];
  rblapack_ab = argv[4];
  rblapack_afb = argv[5];
  rblapack_ipiv = argv[6];
  rblapack_colequ = argv[7];
  rblapack_c = argv[8];
  rblapack_b = argv[9];
  rblapack_y = argv[10];
  rblapack_err_bnds_norm = argv[11];
  rblapack_err_bnds_comp = argv[12];
  rblapack_res = argv[13];
  rblapack_ayb = argv[14];
  rblapack_dy = argv[15];
  rblapack_y_tail = argv[16];
  rblapack_rcond = argv[17];
  rblapack_ithresh = argv[18];
  rblapack_rthresh = argv[19];
  rblapack_dz_ub = argv[20];
  rblapack_ignore_cwise = argv[21];
  if (argc == 22) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  prec_type = NUM2INT(rblapack_prec_type);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  ldab = n;
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  colequ = (rblapack_colequ == Qtrue);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (10th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (10th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (!NA_IsNArray(rblapack_err_bnds_norm))
    rb_raise(rb_eArgError, "err_bnds_norm (12th argument) must be NArray");
  if (NA_RANK(rblapack_err_bnds_norm) != 2)
    rb_raise(rb_eArgError, "rank of err_bnds_norm (12th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_err_bnds_norm) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of b");
  n_norms = NA_SHAPE1(rblapack_err_bnds_norm);
  if (NA_TYPE(rblapack_err_bnds_norm) != NA_SFLOAT)
    rblapack_err_bnds_norm = na_change_type(rblapack_err_bnds_norm, NA_SFLOAT);
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
  rcond = (real)NUM2DBL(rblapack_rcond);
  rthresh = (real)NUM2DBL(rblapack_rthresh);
  ignore_cwise = (rblapack_ignore_cwise == Qtrue);
  trans_type = NUM2INT(rblapack_trans_type);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (11th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 2)
    rb_raise(rb_eArgError, "rank of y (11th argument) must be %d", 2);
  ldy = NA_SHAPE0(rblapack_y);
  if (NA_SHAPE1(rblapack_y) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_y) != NA_SFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
  y = NA_PTR_TYPE(rblapack_y, real*);
  ithresh = NUM2INT(rblapack_ithresh);
  n = ldab;
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be ldab");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_err_bnds_comp))
    rb_raise(rb_eArgError, "err_bnds_comp (13th argument) must be NArray");
  if (NA_RANK(rblapack_err_bnds_comp) != 2)
    rb_raise(rb_eArgError, "rank of err_bnds_comp (13th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_err_bnds_comp) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of b");
  if (NA_SHAPE1(rblapack_err_bnds_comp) != n_norms)
    rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_comp must be the same as shape 1 of err_bnds_norm");
  if (NA_TYPE(rblapack_err_bnds_comp) != NA_SFLOAT)
    rblapack_err_bnds_comp = na_change_type(rblapack_err_bnds_comp, NA_SFLOAT);
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
  if (!NA_IsNArray(rblapack_ayb))
    rb_raise(rb_eArgError, "ayb (15th argument) must be NArray");
  if (NA_RANK(rblapack_ayb) != 1)
    rb_raise(rb_eArgError, "rank of ayb (15th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ayb) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ayb must be ldab");
  if (NA_TYPE(rblapack_ayb) != NA_SFLOAT)
    rblapack_ayb = na_change_type(rblapack_ayb, NA_SFLOAT);
  ayb = NA_PTR_TYPE(rblapack_ayb, real*);
  if (!NA_IsNArray(rblapack_y_tail))
    rb_raise(rb_eArgError, "y_tail (17th argument) must be NArray");
  if (NA_RANK(rblapack_y_tail) != 1)
    rb_raise(rb_eArgError, "rank of y_tail (17th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y_tail) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be ldab");
  if (NA_TYPE(rblapack_y_tail) != NA_SFLOAT)
    rblapack_y_tail = na_change_type(rblapack_y_tail, NA_SFLOAT);
  y_tail = NA_PTR_TYPE(rblapack_y_tail, real*);
  ldafb = n;
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_afb) != ldafb)
    rb_raise(rb_eRuntimeError, "shape 0 of afb must be n");
  if (NA_SHAPE1(rblapack_afb) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of afb must be ldab");
  if (NA_TYPE(rblapack_afb) != NA_SFLOAT)
    rblapack_afb = na_change_type(rblapack_afb, NA_SFLOAT);
  afb = NA_PTR_TYPE(rblapack_afb, real*);
  if (!NA_IsNArray(rblapack_res))
    rb_raise(rb_eArgError, "res (14th argument) must be NArray");
  if (NA_RANK(rblapack_res) != 1)
    rb_raise(rb_eArgError, "rank of res (14th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_res) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of res must be ldab");
  if (NA_TYPE(rblapack_res) != NA_SFLOAT)
    rblapack_res = na_change_type(rblapack_res, NA_SFLOAT);
  res = NA_PTR_TYPE(rblapack_res, real*);
  dz_ub = (real)NUM2DBL(rblapack_dz_ub);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (9th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be ldab");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_dy))
    rb_raise(rb_eArgError, "dy (16th argument) must be NArray");
  if (NA_RANK(rblapack_dy) != 1)
    rb_raise(rb_eArgError, "rank of dy (16th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dy) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of dy must be ldab");
  if (NA_TYPE(rblapack_dy) != NA_SFLOAT)
    rblapack_dy = na_change_type(rblapack_dy, NA_SFLOAT);
  dy = NA_PTR_TYPE(rblapack_dy, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr_out = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr_out = NA_PTR_TYPE(rblapack_berr_out, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldy;
    shape[1] = nrhs;
    rblapack_y_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
  MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_norms;
    rblapack_err_bnds_norm_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm_out__ = NA_PTR_TYPE(rblapack_err_bnds_norm_out__, real*);
  MEMCPY(err_bnds_norm_out__, err_bnds_norm, real, NA_TOTAL(rblapack_err_bnds_norm));
  rblapack_err_bnds_norm = rblapack_err_bnds_norm_out__;
  err_bnds_norm = err_bnds_norm_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_norms;
    rblapack_err_bnds_comp_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp_out__ = NA_PTR_TYPE(rblapack_err_bnds_comp_out__, real*);
  MEMCPY(err_bnds_comp_out__, err_bnds_comp, real, NA_TOTAL(rblapack_err_bnds_comp));
  rblapack_err_bnds_comp = rblapack_err_bnds_comp_out__;
  err_bnds_comp = err_bnds_comp_out__;

  sla_gbrfsx_extended_(&prec_type, &trans_type, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_err_bnds_norm, rblapack_err_bnds_comp);
}

void
init_lapack_sla_gbrfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sla_gbrfsx_extended", rblapack_sla_gbrfsx_extended, -1);
}
ruby-lapack-1.7.2/ext/dpotrs.c0000644000175000017500000001025112502221023016032 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dpotrs_(char* uplo, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* b, integer* ldb, integer* info);


static VALUE
rblapack_dpotrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublereal *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.dpotrs( uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPOTRS solves a system of linear equations A*X = B with a symmetric\n*  positive definite matrix A using the Cholesky factorization\n*  A = U**T*U or A = L*L**T computed by DPOTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**T*U or A = L*L**T, as computed by DPOTRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.dpotrs( uplo, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_b = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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);
  ldb = NA_SHAPE0(rblapack_b);
  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 (!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*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dpotrs_(&uplo, &n, &nrhs, a, &lda, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_dpotrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dpotrs", rblapack_dpotrs, -1);
}
ruby-lapack-1.7.2/ext/cherfs.c0000644000175000017500000002140312502221012015770 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cherfs_(char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, complex* b, integer* ldb, complex* x, integer* ldx, real* ferr, real* berr, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cherfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  complex *x_out__;
  complex *work;
  real *rwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.cherfs( uplo, a, af, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHERFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHERFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is Hermitian indefinite, and\n*  provides error bounds and backward error estimates for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The Hermitian matrix A.  If UPLO = 'U', the leading N-by-N\n*          upper triangular part of A contains the upper triangular part\n*          of the matrix A, and the strictly lower triangular part of A\n*          is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*          triangular part of A contains the lower triangular part of\n*          the matrix A, and the strictly upper triangular part of A is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AF      (input) COMPLEX array, dimension (LDAF,N)\n*          The factored form of the matrix A.  AF contains the block\n*          diagonal matrix D and the multipliers used to obtain the\n*          factor U or L from the factorization A = U*D*U**H or\n*          A = L*D*L**H as computed by CHETRF.\n*\n*  LDAF    (input) INTEGER\n*          The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by CHETRF.\n*\n*  B       (input) COMPLEX array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) COMPLEX array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by CHETRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.cherfs( uplo, a, af, ipiv, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_b = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (n));

  cherfs_(&uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_cherfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cherfs", rblapack_cherfs, -1);
}
ruby-lapack-1.7.2/ext/dlascl.c0000644000175000017500000001230412502221014015762 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlascl_(char* type, integer* kl, integer* ku, doublereal* cfrom, doublereal* cto, integer* m, integer* n, doublereal* a, integer* lda, integer* info);


static VALUE
rblapack_dlascl(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_type;
  char type; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_cfrom;
  doublereal cfrom; 
  VALUE rblapack_cto;
  doublereal cto; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublereal *a; 
  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  info, a = NumRu::Lapack.dlascl( type, kl, ku, cfrom, cto, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLASCL multiplies the M by N real matrix A by the real scalar\n*  CTO/CFROM.  This is done without over/underflow as long as the final\n*  result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that\n*  A may be full, upper triangular, lower triangular, upper Hessenberg,\n*  or banded.\n*\n\n*  Arguments\n*  =========\n*\n*  TYPE    (input) CHARACTER*1\n*          TYPE indices the storage type of the input matrix.\n*          = 'G':  A is a full matrix.\n*          = 'L':  A is a lower triangular matrix.\n*          = 'U':  A is an upper triangular matrix.\n*          = 'H':  A is an upper Hessenberg matrix.\n*          = 'B':  A is a symmetric band matrix with lower bandwidth KL\n*                  and upper bandwidth KU and with the only the lower\n*                  half stored.\n*          = 'Q':  A is a symmetric band matrix with lower bandwidth KL\n*                  and upper bandwidth KU and with the only the upper\n*                  half stored.\n*          = 'Z':  A is a band matrix with lower bandwidth KL and upper\n*                  bandwidth KU. See DGBTRF for storage details.\n*\n*  KL      (input) INTEGER\n*          The lower bandwidth of A.  Referenced only if TYPE = 'B',\n*          'Q' or 'Z'.\n*\n*  KU      (input) INTEGER\n*          The upper bandwidth of A.  Referenced only if TYPE = 'B',\n*          'Q' or 'Z'.\n*\n*  CFROM   (input) DOUBLE PRECISION\n*  CTO     (input) DOUBLE PRECISION\n*          The matrix A is multiplied by CTO/CFROM. A(I,J) is computed\n*          without over/underflow if the final result CTO*A(I,J)/CFROM\n*          can be represented without over/underflow.  CFROM must be\n*          nonzero.\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*          The matrix to be multiplied by CTO/CFROM.  See TYPE for the\n*          storage type.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.dlascl( type, kl, ku, cfrom, cto, m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_type = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_cfrom = argv[3];
  rblapack_cto = argv[4];
  rblapack_m = argv[5];
  rblapack_a = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  type = StringValueCStr(rblapack_type)[0];
  ku = NUM2INT(rblapack_ku);
  cto = NUM2DBL(rblapack_cto);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (7th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (7th 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*);
  kl = NUM2INT(rblapack_kl);
  m = NUM2INT(rblapack_m);
  cfrom = NUM2DBL(rblapack_cfrom);
  {
    na_shape_t 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__;

  dlascl_(&type, &kl, &ku, &cfrom, &cto, &m, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_dlascl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlascl", rblapack_dlascl, -1);
}
ruby-lapack-1.7.2/ext/cgehd2.c0000644000175000017500000001275212502221015015664 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgehd2_(integer* n, integer* ilo, integer* ihi, complex* a, integer* lda, complex* tau, complex* work, integer* info);


static VALUE
rblapack_cgehd2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  complex *work;

  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, info, a = NumRu::Lapack.cgehd2( ilo, ihi, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGEHD2 reduces a complex general matrix A to upper Hessenberg form H\n*  by a unitary similarity transformation:  Q' * A * Q = H .\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          It is assumed that A is already upper triangular in rows\n*          and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n*          set by a previous call to CGEBAL; otherwise they should be\n*          set to 1 and N respectively. See Further Details.\n*          1 <= ILO <= IHI <= max(1,N).\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the n by n general matrix to be reduced.\n*          On exit, the upper triangle and the first subdiagonal of A\n*          are overwritten with the upper Hessenberg matrix H, and the\n*          elements below the first subdiagonal, with the array TAU,\n*          represent the unitary matrix Q as a product of elementary\n*          reflectors. See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  TAU     (output) COMPLEX array, dimension (N-1)\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace) COMPLEX array, dimension (N)\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 (ihi-ilo) elementary\n*  reflectors\n*\n*     Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - tau * v * v'\n*\n*  where tau is a complex scalar, and v is a complex vector with\n*  v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n*  exit in A(i+2:ihi,i), and tau in TAU(i).\n*\n*  The contents of A are illustrated by the following example, with\n*  n = 7, ilo = 2 and ihi = 6:\n*\n*  on entry,                        on exit,\n*\n*  ( a   a   a   a   a   a   a )    (  a   a   h   h   h   h   a )\n*  (     a   a   a   a   a   a )    (      a   h   h   h   h   a )\n*  (     a   a   a   a   a   a )    (      h   h   h   h   h   h )\n*  (     a   a   a   a   a   a )    (      v2  h   h   h   h   h )\n*  (     a   a   a   a   a   a )    (      v2  v3  h   h   h   h )\n*  (     a   a   a   a   a   a )    (      v2  v3  v4  h   h   h )\n*  (                         a )    (                          a )\n*\n*  where a denotes an element of the original matrix A, h denotes a\n*  modified element of the upper Hessenberg matrix H, and vi denotes an\n*  element of the vector defining H(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.cgehd2( ilo, ihi, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_ilo = argv[0];
  rblapack_ihi = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  ihi = NUM2INT(rblapack_ihi);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(complex, (n));

  cgehd2_(&n, &ilo, &ihi, 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_cgehd2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgehd2", rblapack_cgehd2, -1);
}
ruby-lapack-1.7.2/ext/spbsv.c0000644000175000017500000001570212502221021015660 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID spbsv_(char* uplo, integer* n, integer* kd, integer* nrhs, real* ab, integer* ldab, real* b, integer* ldb, integer* info);


static VALUE
rblapack_spbsv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  real *ab_out__;
  VALUE rblapack_b_out__;
  real *b_out__;

  integer ldab;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, ab, b = NumRu::Lapack.spbsv( uplo, kd, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPBSV computes the solution to a real system of linear equations\n*     A * X = B,\n*  where A is an N-by-N symmetric positive definite band matrix and X\n*  and B are N-by-NRHS matrices.\n*\n*  The Cholesky decomposition is used to factor A as\n*     A = U**T * U,  if UPLO = 'U', or\n*     A = L * L**T,  if UPLO = 'L',\n*  where U is an upper triangular band matrix, and L is a lower\n*  triangular band matrix, with the same number of superdiagonals or\n*  subdiagonals as A.  The factored form of A is then used to solve the\n*  system of equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AB      (input/output) REAL array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(N,j+KD).\n*          See below for further details.\n*\n*          On exit, if INFO = 0, the triangular factor U or L from the\n*          Cholesky factorization A = U**T*U or A = L*L**T of the band\n*          matrix A, in the same storage format as A.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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 leading minor of order i of A is not\n*                positive definite, so the factorization could not be\n*                completed, and the solution has not been computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  N = 6, KD = 2, and UPLO = 'U':\n*\n*  On entry:                       On exit:\n*\n*      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46\n*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56\n*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66\n*\n*  Similarly, if UPLO = 'L' the format of A is as follows:\n*\n*  On entry:                       On exit:\n*\n*     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66\n*     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *\n*     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *\n*\n*  Array elements marked * are not used by the routine.\n*\n*  =====================================================================\n*\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SPBTRF, SPBTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ab, b = NumRu::Lapack.spbsv( uplo, kd, ab, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  kd = NUM2INT(rblapack_kd);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
  MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  spbsv_(&uplo, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_ab, rblapack_b);
}

void
init_lapack_spbsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "spbsv", rblapack_spbsv, -1);
}
ruby-lapack-1.7.2/ext/cposv.c0000644000175000017500000001344412502221020015655 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cposv_(char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, complex* b, integer* ldb, integer* info);


static VALUE
rblapack_cposv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, a, b = NumRu::Lapack.cposv( uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPOSV computes the solution to a complex system of linear equations\n*     A * X = B,\n*  where A is an N-by-N Hermitian positive definite matrix and X and B\n*  are N-by-NRHS matrices.\n*\n*  The Cholesky decomposition is used to factor A as\n*     A = U**H* U,  if UPLO = 'U', or\n*     A = L * L**H,  if UPLO = 'L',\n*  where U is an upper triangular matrix and  L is a lower triangular\n*  matrix.  The factored form of A is then used to solve the system of\n*  equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the factor U or L from the Cholesky\n*          factorization A = U**H*U or A = L*L**H.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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 leading minor of order i of A is not\n*                positive definite, so the factorization could not be\n*                completed, and the solution has not been computed.\n*\n\n*  =====================================================================\n*\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CPOTRF, CPOTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a, b = NumRu::Lapack.cposv( uplo, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_b = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  cposv_(&uplo, &n, &nrhs, a, &lda, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_cposv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cposv", rblapack_cposv, -1);
}
ruby-lapack-1.7.2/ext/dlarf.c0000644000175000017500000001136612502221026015622 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlarf_(char* side, integer* m, integer* n, doublereal* v, integer* incv, doublereal* tau, doublereal* c, integer* ldc, doublereal* work);


static VALUE
rblapack_dlarf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_v;
  doublereal *v; 
  VALUE rblapack_incv;
  integer incv; 
  VALUE rblapack_tau;
  doublereal tau; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_c_out__;
  doublereal *c_out__;
  doublereal *work;

  integer ldc;
  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  c = NumRu::Lapack.dlarf( side, m, v, incv, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )\n\n*  Purpose\n*  =======\n*\n*  DLARF applies a real elementary reflector H to a real m by n matrix\n*  C, from either the left or the right. H is represented in the form\n*\n*        H = I - tau * v * v'\n*\n*  where tau is a real scalar and v is a real vector.\n*\n*  If tau = 0, then H is taken to be the unit matrix.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': form  H * C\n*          = 'R': form  C * H\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C.\n*\n*  V       (input) DOUBLE PRECISION array, dimension\n*                     (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n*                  or (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n*          The vector v in the representation of H. V is not used if\n*          TAU = 0.\n*\n*  INCV    (input) INTEGER\n*          The increment between elements of v. INCV <> 0.\n*\n*  TAU     (input) DOUBLE PRECISION\n*          The value tau in the representation of H.\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n*          On entry, the m by n matrix C.\n*          On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n*          or C * H if SIDE = 'R'.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension\n*                         (N) if SIDE = 'L'\n*                      or (M) if SIDE = 'R'\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.dlarf( side, m, v, incv, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_m = argv[1];
  rblapack_v = argv[2];
  rblapack_incv = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  incv = NUM2INT(rblapack_incv);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  m = NUM2INT(rblapack_m);
  tau = NUM2DBL(rblapack_tau);
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (3th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 1)
    rb_raise(rb_eArgError, "rank of v (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_v) != (1 + (m-1)*abs(incv)))
    rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1 + (m-1)*abs(incv));
  if (NA_TYPE(rblapack_v) != NA_DFLOAT)
    rblapack_v = na_change_type(rblapack_v, NA_DFLOAT);
  v = NA_PTR_TYPE(rblapack_v, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  dlarf_(&side, &m, &n, v, &incv, &tau, c, &ldc, work);

  free(work);
  return rblapack_c;
}

void
init_lapack_dlarf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlarf", rblapack_dlarf, -1);
}
ruby-lapack-1.7.2/ext/cpbcon.c0000644000175000017500000001102112502221014015757 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cpbcon_(char* uplo, integer* n, integer* kd, complex* ab, integer* ldab, real* anorm, real* rcond, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cpbcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_anorm;
  real anorm; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_info;
  integer info; 
  complex *work;
  real *rwork;

  integer ldab;
  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  rcond, info = NumRu::Lapack.cpbcon( uplo, kd, ab, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPBCON estimates the reciprocal of the condition number (in the\n*  1-norm) of a complex Hermitian positive definite band matrix using\n*  the Cholesky factorization A = U**H*U or A = L*L**H computed by\n*  CPBTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangular factor stored in AB;\n*          = 'L':  Lower triangular factor stored in AB.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input) COMPLEX array, dimension (LDAB,N)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**H*U or A = L*L**H of the band matrix A, stored in the\n*          first KD+1 rows of the array.  The j-th column of U or L is\n*          stored in the j-th column of the array AB as follows:\n*          if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO ='L', AB(1+i-j,j)    = L(i,j) for j<=i<=min(n,j+kd).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  ANORM   (input) REAL\n*          The 1-norm (or infinity-norm) of the Hermitian band matrix A.\n*\n*  RCOND   (output) REAL\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n*          estimate of the 1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.cpbcon( uplo, kd, ab, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  rblapack_anorm = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  kd = NUM2INT(rblapack_kd);
  anorm = (real)NUM2DBL(rblapack_anorm);
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (n));

  cpbcon_(&uplo, &n, &kd, ab, &ldab, &anorm, &rcond, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_cpbcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cpbcon", rblapack_cpbcon, -1);
}
ruby-lapack-1.7.2/ext/zpbsv.c0000644000175000017500000001611112502221014015664 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zpbsv_(char* uplo, integer* n, integer* kd, integer* nrhs, doublecomplex* ab, integer* ldab, doublecomplex* b, integer* ldb, integer* info);


static VALUE
rblapack_zpbsv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublecomplex *ab_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer ldab;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, ab, b = NumRu::Lapack.zpbsv( uplo, kd, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPBSV computes the solution to a complex system of linear equations\n*     A * X = B,\n*  where A is an N-by-N Hermitian positive definite band matrix and X\n*  and B are N-by-NRHS matrices.\n*\n*  The Cholesky decomposition is used to factor A as\n*     A = U**H * U,  if UPLO = 'U', or\n*     A = L * L**H,  if UPLO = 'L',\n*  where U is an upper triangular band matrix, and L is a lower\n*  triangular band matrix, with the same number of superdiagonals or\n*  subdiagonals as A.  The factored form of A is then used to solve the\n*  system of equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(N,j+KD).\n*          See below for further details.\n*\n*          On exit, if INFO = 0, the triangular factor U or L from the\n*          Cholesky factorization A = U**H*U or A = L*L**H of the band\n*          matrix A, in the same storage format as A.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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 leading minor of order i of A is not\n*                positive definite, so the factorization could not be\n*                completed, and the solution has not been computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  N = 6, KD = 2, and UPLO = 'U':\n*\n*  On entry:                       On exit:\n*\n*      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46\n*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56\n*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66\n*\n*  Similarly, if UPLO = 'L' the format of A is as follows:\n*\n*  On entry:                       On exit:\n*\n*     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66\n*     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *\n*     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *\n*\n*  Array elements marked * are not used by the routine.\n*\n*  =====================================================================\n*\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZPBTRF, ZPBTRS\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ab, b = NumRu::Lapack.zpbsv( uplo, kd, ab, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  kd = NUM2INT(rblapack_kd);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
  MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zpbsv_(&uplo, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_ab, rblapack_b);
}

void
init_lapack_zpbsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zpbsv", rblapack_zpbsv, -1);
}
ruby-lapack-1.7.2/ext/sporfsx.c0000644000175000017500000004766612502221015016250 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sporfsx_(char* uplo, char* equed, integer* n, integer* nrhs, real* a, integer* lda, real* af, integer* ldaf, real* s, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, real* work, integer* iwork, integer* info);


static VALUE
rblapack_sporfsx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_af;
  real *af; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_params;
  real *params; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_err_bnds_norm;
  real *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  real *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_s_out__;
  real *s_out__;
  VALUE rblapack_x_out__;
  real *x_out__;
  VALUE rblapack_params_out__;
  real *params_out__;
  real *work;
  integer *iwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;
  integer nparams;
  integer n_err_bnds;

  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  rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.sporfsx( uplo, equed, a, af, s, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     SPORFSX improves the computed solution to a system of linear\n*     equations when the coefficient matrix is symmetric positive\n*     definite, and provides error bounds and backward error estimates\n*     for the solution.  In addition to normwise error bound, the code\n*     provides maximum componentwise error bound if possible.  See\n*     comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n*     error bounds.\n*\n*     The original system of linear equations may have been equilibrated\n*     before calling this routine, as described by arguments EQUED and S\n*     below. In this case, the solution and error bounds returned are\n*     for the original unequilibrated system.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     EQUED   (input) CHARACTER*1\n*     Specifies the form of equilibration that was done to A\n*     before calling this routine. This is needed to compute\n*     the solution and error bounds correctly.\n*       = 'N':  No equilibration\n*       = 'Y':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(S) * A * diag(S).\n*               The right hand side B has been changed accordingly.\n*\n*     N       (input) INTEGER\n*     The order of the matrix A.  N >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     A       (input) REAL array, dimension (LDA,N)\n*     The symmetric matrix A.  If UPLO = 'U', the leading N-by-N\n*     upper triangular part of A contains the upper triangular part\n*     of the matrix A, and the strictly lower triangular part of A\n*     is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*     triangular part of A contains the lower triangular part of\n*     the matrix A, and the strictly upper triangular part of A is\n*     not referenced.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) REAL array, dimension (LDAF,N)\n*     The triangular factor U or L from the Cholesky factorization\n*     A = U**T*U or A = L*L**T, as computed by SPOTRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     S       (input or output) REAL array, dimension (N)\n*     The row scale factors for A.  If EQUED = 'Y', A is multiplied on\n*     the left and right by diag(S).  S is an input argument if FACT =\n*     'F'; otherwise, S is an output argument.  If FACT = 'F' and EQUED\n*     = 'Y', each element of S must be positive.  If S is output, each\n*     element of S is a power of the radix. If S is input, each element\n*     of S should be a power of the radix to ensure a reliable solution\n*     and error estimates. Scaling by powers of the radix does not cause\n*     rounding errors unless the result underflows or overflows.\n*     Rounding errors during scaling lead to refining with a matrix that\n*     is not equivalent to the input matrix, producing error estimates\n*     that may not be reliable.\n*\n*     B       (input) REAL array, dimension (LDB,NRHS)\n*     The right hand side matrix B.\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (input/output) REAL array, dimension (LDX,NRHS)\n*     On entry, the solution matrix X, as computed by SGETRS.\n*     On exit, the improved solution matrix X.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) REAL\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     BERR    (output) REAL array, dimension (NRHS)\n*     Componentwise relative backward error.  This is the\n*     componentwise relative backward error of each solution vector X(j)\n*     (i.e., the smallest relative change in any element of A or B that\n*     makes X(j) an exact solution).\n*\n*     N_ERR_BNDS (input) INTEGER\n*     Number of error bounds to return for each right hand side\n*     and each type (normwise or componentwise).  See ERR_BNDS_NORM and\n*     ERR_BNDS_COMP below.\n*\n*     ERR_BNDS_NORM  (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     NPARAMS (input) INTEGER\n*     Specifies the number of parameters set in PARAMS.  If .LE. 0, the\n*     PARAMS array is never referenced and default values are used.\n*\n*     PARAMS  (input / output) REAL array, dimension NPARAMS\n*     Specifies algorithm parameters.  If an entry is .LT. 0.0, then\n*     that entry will be filled with default value used for that\n*     parameter.  Only positions up to NPARAMS are accessed; defaults\n*     are used for higher-numbered parameters.\n*\n*       PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n*            refinement or not.\n*         Default: 1.0\n*            = 0.0 : No refinement is performed, and no error bounds are\n*                    computed.\n*            = 1.0 : Use the double-precision refinement algorithm,\n*                    possibly with doubled-single computations if the\n*                    compilation environment does not support DOUBLE\n*                    PRECISION.\n*              (other values are reserved for future use)\n*\n*       PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n*            computations allowed for refinement.\n*         Default: 10\n*         Aggressive: Set to 100 to permit convergence using approximate\n*                     factorizations or factorizations other than LU. If\n*                     the factorization uses a technique other than\n*                     Gaussian elimination, the guarantees in\n*                     err_bnds_norm and err_bnds_comp may no longer be\n*                     trustworthy.\n*\n*       PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n*            will attempt to find a solution with small componentwise\n*            relative error in the double-precision algorithm.  Positive\n*            is true, 0.0 is false.\n*         Default: 1.0 (attempt componentwise convergence)\n*\n*     WORK    (workspace) REAL array, dimension (4*N)\n*\n*     IWORK   (workspace) INTEGER array, dimension (N)\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit. The solution to every right-hand side is\n*         guaranteed.\n*       < 0:  If INFO = -i, the i-th argument had an illegal value\n*       > 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.sporfsx( uplo, equed, a, af, s, b, x, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_uplo = argv[0];
  rblapack_equed = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_s = argv[4];
  rblapack_b = argv[5];
  rblapack_x = argv[6];
  rblapack_params = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (5th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (7th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  n_err_bnds = 3;
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
  af = NA_PTR_TYPE(rblapack_af, real*);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (8th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (8th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_SFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
  params = NA_PTR_TYPE(rblapack_params, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
  MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
  MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(real, (4*n));
  iwork = ALLOC_N(integer, (n));

  sporfsx_(&uplo, &equed, &n, &nrhs, a, &lda, af, &ldaf, s, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_s, rblapack_x, rblapack_params);
}

void
init_lapack_sporfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sporfsx", rblapack_sporfsx, -1);
}
ruby-lapack-1.7.2/ext/cgtts2.c0000644000175000017500000001550412502221023015733 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgtts2_(integer* itrans, integer* n, integer* nrhs, complex* dl, complex* d, complex* du, complex* du2, integer* ipiv, complex* b, integer* ldb);


static VALUE
rblapack_cgtts2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itrans;
  integer itrans; 
  VALUE rblapack_dl;
  complex *dl; 
  VALUE rblapack_d;
  complex *d; 
  VALUE rblapack_du;
  complex *du; 
  VALUE rblapack_du2;
  complex *du2; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer n;
  integer ldb;
  integer nrhs;

  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  b = NumRu::Lapack.cgtts2( itrans, dl, d, du, du2, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )\n\n*  Purpose\n*  =======\n*\n*  CGTTS2 solves one of the systems of equations\n*     A * X = B,  A**T * X = B,  or  A**H * X = B,\n*  with a tridiagonal matrix A using the LU factorization computed\n*  by CGTTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  ITRANS  (input) INTEGER\n*          Specifies the form of the system of equations.\n*          = 0:  A * X = B     (No transpose)\n*          = 1:  A**T * X = B  (Transpose)\n*          = 2:  A**H * X = B  (Conjugate transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  DL      (input) COMPLEX array, dimension (N-1)\n*          The (n-1) multipliers that define the matrix L from the\n*          LU factorization of A.\n*\n*  D       (input) COMPLEX array, dimension (N)\n*          The n diagonal elements of the upper triangular matrix U from\n*          the LU factorization of A.\n*\n*  DU      (input) COMPLEX array, dimension (N-1)\n*          The (n-1) elements of the first super-diagonal of U.\n*\n*  DU2     (input) COMPLEX array, dimension (N-2)\n*          The (n-2) elements of the second super-diagonal of U.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices; for 1 <= i <= n, row i of the matrix was\n*          interchanged with row IPIV(i).  IPIV(i) will always be either\n*          i or i+1; IPIV(i) = i indicates a row interchange was not\n*          required.\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the matrix of right hand side vectors B.\n*          On exit, B is overwritten by the solution vectors X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n      COMPLEX            TEMP\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          CONJG\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  b = NumRu::Lapack.cgtts2( itrans, dl, d, du, du2, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_itrans = argv[0];
  rblapack_dl = argv[1];
  rblapack_d = argv[2];
  rblapack_du = argv[3];
  rblapack_du2 = argv[4];
  rblapack_ipiv = argv[5];
  rblapack_b = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  itrans = NUM2INT(rblapack_itrans);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SCOMPLEX)
    rblapack_d = na_change_type(rblapack_d, NA_SCOMPLEX);
  d = NA_PTR_TYPE(rblapack_d, complex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_SCOMPLEX)
    rblapack_dl = na_change_type(rblapack_dl, NA_SCOMPLEX);
  dl = NA_PTR_TYPE(rblapack_dl, complex*);
  if (!NA_IsNArray(rblapack_du2))
    rb_raise(rb_eArgError, "du2 (5th argument) must be NArray");
  if (NA_RANK(rblapack_du2) != 1)
    rb_raise(rb_eArgError, "rank of du2 (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du2) != (n-2))
    rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
  if (NA_TYPE(rblapack_du2) != NA_SCOMPLEX)
    rblapack_du2 = na_change_type(rblapack_du2, NA_SCOMPLEX);
  du2 = NA_PTR_TYPE(rblapack_du2, complex*);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (4th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_SCOMPLEX)
    rblapack_du = na_change_type(rblapack_du, NA_SCOMPLEX);
  du = NA_PTR_TYPE(rblapack_du, complex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  cgtts2_(&itrans, &n, &nrhs, dl, d, du, du2, ipiv, b, &ldb);

  return rblapack_b;
}

void
init_lapack_cgtts2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgtts2", rblapack_cgtts2, -1);
}
ruby-lapack-1.7.2/ext/dptrfs.c0000644000175000017500000002017612502221022016027 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dptrfs_(integer* n, integer* nrhs, doublereal* d, doublereal* e, doublereal* df, doublereal* ef, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* ferr, doublereal* berr, doublereal* work, integer* info);


static VALUE
rblapack_dptrfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_df;
  doublereal *df; 
  VALUE rblapack_ef;
  doublereal *ef; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  doublereal *x_out__;
  doublereal *work;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.dptrfs( d, e, df, ef, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPTRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is symmetric positive definite\n*  and tridiagonal, and provides error bounds and backward error\n*  estimates for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          The n diagonal elements of the tridiagonal matrix A.\n*\n*  E       (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (n-1) subdiagonal elements of the tridiagonal matrix A.\n*\n*  DF      (input) DOUBLE PRECISION array, dimension (N)\n*          The n diagonal elements of the diagonal matrix D from the\n*          factorization computed by DPTTRF.\n*\n*  EF      (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (n-1) subdiagonal elements of the unit bidiagonal factor\n*          L from the factorization computed by DPTTRF.\n*\n*  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by DPTTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.dptrfs( d, e, df, ef, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_d = argv[0];
  rblapack_e = argv[1];
  rblapack_df = argv[2];
  rblapack_ef = argv[3];
  rblapack_b = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_df))
    rb_raise(rb_eArgError, "df (3th argument) must be NArray");
  if (NA_RANK(rblapack_df) != 1)
    rb_raise(rb_eArgError, "rank of df (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_df) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of df must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_df) != NA_DFLOAT)
    rblapack_df = na_change_type(rblapack_df, NA_DFLOAT);
  df = NA_PTR_TYPE(rblapack_df, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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 (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (2th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  if (!NA_IsNArray(rblapack_ef))
    rb_raise(rb_eArgError, "ef (4th argument) must be NArray");
  if (NA_RANK(rblapack_ef) != 1)
    rb_raise(rb_eArgError, "rank of ef (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ef) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of ef must be %d", n-1);
  if (NA_TYPE(rblapack_ef) != NA_DFLOAT)
    rblapack_ef = na_change_type(rblapack_ef, NA_DFLOAT);
  ef = NA_PTR_TYPE(rblapack_ef, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(doublereal, (2*n));

  dptrfs_(&n, &nrhs, d, e, df, ef, b, &ldb, x, &ldx, ferr, berr, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_dptrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dptrfs", rblapack_dptrfs, -1);
}
ruby-lapack-1.7.2/ext/dtrsyl.c0000644000175000017500000001526312502221013016047 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtrsyl_(char* trana, char* tranb, integer* isgn, integer* m, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* c, integer* ldc, doublereal* scale, integer* info);


static VALUE
rblapack_dtrsyl(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trana;
  char trana; 
  VALUE rblapack_tranb;
  char tranb; 
  VALUE rblapack_isgn;
  integer isgn; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_scale;
  doublereal scale; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublereal *c_out__;

  integer lda;
  integer m;
  integer ldb;
  integer n;
  integer ldc;

  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  scale, info, c = NumRu::Lapack.dtrsyl( trana, tranb, isgn, a, b, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, SCALE, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTRSYL solves the real Sylvester matrix equation:\n*\n*     op(A)*X + X*op(B) = scale*C or\n*     op(A)*X - X*op(B) = scale*C,\n*\n*  where op(A) = A or A**T, and  A and B are both upper quasi-\n*  triangular. A is M-by-M and B is N-by-N; the right hand side C and\n*  the solution X are M-by-N; and scale is an output scale factor, set\n*  <= 1 to avoid overflow in X.\n*\n*  A and B must be in Schur canonical form (as returned by DHSEQR), that\n*  is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks;\n*  each 2-by-2 diagonal block has its diagonal elements equal and its\n*  off-diagonal elements of opposite sign.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANA   (input) CHARACTER*1\n*          Specifies the option op(A):\n*          = 'N': op(A) = A    (No transpose)\n*          = 'T': op(A) = A**T (Transpose)\n*          = 'C': op(A) = A**H (Conjugate transpose = Transpose)\n*\n*  TRANB   (input) CHARACTER*1\n*          Specifies the option op(B):\n*          = 'N': op(B) = B    (No transpose)\n*          = 'T': op(B) = B**T (Transpose)\n*          = 'C': op(B) = B**H (Conjugate transpose = Transpose)\n*\n*  ISGN    (input) INTEGER\n*          Specifies the sign in the equation:\n*          = +1: solve op(A)*X + X*op(B) = scale*C\n*          = -1: solve op(A)*X - X*op(B) = scale*C\n*\n*  M       (input) INTEGER\n*          The order of the matrix A, and the number of rows in the\n*          matrices X and C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The order of the matrix B, and the number of columns in the\n*          matrices X and C. N >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,M)\n*          The upper quasi-triangular matrix A, in Schur canonical form.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  B       (input) DOUBLE PRECISION array, dimension (LDB,N)\n*          The upper quasi-triangular matrix B, in Schur canonical form.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n*          On entry, the M-by-N right hand side matrix C.\n*          On exit, C is overwritten by the solution matrix X.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M)\n*\n*  SCALE   (output) DOUBLE PRECISION\n*          The scale factor, scale, set <= 1 to avoid overflow in X.\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -i, the i-th argument had an illegal value\n*          = 1: A and B have common or very close eigenvalues; perturbed\n*               values were used to solve the equation (but the matrices\n*               A and B are unchanged).\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, info, c = NumRu::Lapack.dtrsyl( trana, tranb, isgn, a, b, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_trana = argv[0];
  rblapack_tranb = argv[1];
  rblapack_isgn = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  rblapack_c = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trana = StringValueCStr(rblapack_trana)[0];
  isgn = NUM2INT(rblapack_isgn);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = 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*);
  tranb = StringValueCStr(rblapack_tranb)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  if (NA_SHAPE1(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of c must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = 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*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  dtrsyl_(&trana, &tranb, &isgn, &m, &n, a, &lda, b, &ldb, c, &ldc, &scale, &info);

  rblapack_scale = rb_float_new((double)scale);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_scale, rblapack_info, rblapack_c);
}

void
init_lapack_dtrsyl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtrsyl", rblapack_dtrsyl, -1);
}
ruby-lapack-1.7.2/ext/dtrtrs.c0000644000175000017500000001272412502221023016050 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtrtrs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* b, integer* ldb, integer* info);


static VALUE
rblapack_dtrtrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublereal *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.dtrtrs( uplo, trans, diag, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTRTRS solves a triangular system of the form\n*\n*     A * X = B  or  A**T * X = B,\n*\n*  where A is a triangular matrix of order N, and B is an N-by-NRHS\n*  matrix.  A check is made to verify that A is nonsingular.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B  (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*          The triangular matrix A.  If UPLO = 'U', the leading N-by-N\n*          upper triangular part of the array A contains the upper\n*          triangular matrix, and the strictly lower triangular part of\n*          A is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*          triangular part of the array A contains the lower triangular\n*          matrix, and the strictly upper triangular part of A is not\n*          referenced.  If DIAG = 'U', the diagonal elements of A are\n*          also not referenced and are assumed to be 1.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, if INFO = 0, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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 A is zero,\n*               indicating that the matrix is singular and the solutions\n*               X have not been computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.dtrtrs( uplo, trans, diag, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th 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*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dtrtrs_(&uplo, &trans, &diag, &n, &nrhs, a, &lda, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_dtrtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtrtrs", rblapack_dtrtrs, -1);
}
ruby-lapack-1.7.2/ext/dggglm.c0000644000175000017500000002136312502221022015765 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dggglm_(integer* n, integer* m, integer* p, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* d, doublereal* x, doublereal* y, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dggglm(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_y;
  doublereal *y; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;
  VALUE rblapack_d_out__;
  doublereal *d_out__;

  integer lda;
  integer m;
  integer ldb;
  integer p;
  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  x, y, work, info, a, b, d = NumRu::Lapack.dggglm( a, b, d, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGGGLM solves a general Gauss-Markov linear model (GLM) problem:\n*\n*          minimize || y ||_2   subject to   d = A*x + B*y\n*              x\n*\n*  where A is an N-by-M matrix, B is an N-by-P matrix, and d is a\n*  given N-vector. It is assumed that M <= N <= M+P, and\n*\n*             rank(A) = M    and    rank( A B ) = N.\n*\n*  Under these assumptions, the constrained equation is always\n*  consistent, and there is a unique solution x and a minimal 2-norm\n*  solution y, which is obtained using a generalized QR factorization\n*  of the matrices (A, B) given by\n*\n*     A = Q*(R),   B = Q*T*Z.\n*           (0)\n*\n*  In particular, if matrix B is square nonsingular, then the problem\n*  GLM is equivalent to the following weighted linear least squares\n*  problem\n*\n*               minimize || inv(B)*(d-A*x) ||_2\n*                   x\n*\n*  where inv(B) denotes the inverse of B.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of rows of the matrices A and B.  N >= 0.\n*\n*  M       (input) INTEGER\n*          The number of columns of the matrix A.  0 <= M <= N.\n*\n*  P       (input) INTEGER\n*          The number of columns of the matrix B.  P >= N-M.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,M)\n*          On entry, the N-by-M matrix A.\n*          On exit, the upper triangular part of the array A contains\n*          the M-by-M upper triangular matrix R.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,P)\n*          On entry, the N-by-P matrix B.\n*          On exit, if N <= P, the upper triangle of the subarray\n*          B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n*          if N > P, the elements on and above the (N-P)th subdiagonal\n*          contain the N-by-P upper trapezoidal matrix T.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, D is the left hand side of the GLM equation.\n*          On exit, D is destroyed.\n*\n*  X       (output) DOUBLE PRECISION array, dimension (M)\n*  Y       (output) DOUBLE PRECISION array, dimension (P)\n*          On exit, X and Y are the solutions of the GLM problem.\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,N+M+P).\n*          For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,\n*          where NB is an upper bound for the optimal blocksizes for\n*          DGEQRF, SGERQF, DORMQR and SORMRQ.\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*          = 1:  the upper triangular factor R associated with A in the\n*                generalized QR factorization of the pair (A, B) is\n*                singular, so that rank(A) < M; the least squares\n*                solution could not be computed.\n*          = 2:  the bottom (N-M) by (N-M) part of the upper trapezoidal\n*                factor T associated with B in the generalized QR\n*                factorization of the pair (A, B) is singular, so that\n*                rank( A B ) < N; the least squares solution could not\n*                be computed.\n*\n\n*  ===================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, y, work, info, a, b, d = NumRu::Lapack.dggglm( a, b, d, [: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_a = argv[0];
  rblapack_b = argv[1];
  rblapack_d = 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 (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);
  m = 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*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  p = 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 = m+n+p;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_x = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = p;
    rblapack_y = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  y = NA_PTR_TYPE(rblapack_y, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = m;
    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__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = p;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;

  dggglm_(&n, &m, &p, a, &lda, b, &ldb, d, x, y, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_x, rblapack_y, rblapack_work, rblapack_info, rblapack_a, rblapack_b, rblapack_d);
}

void
init_lapack_dggglm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dggglm", rblapack_dggglm, -1);
}
ruby-lapack-1.7.2/ext/izmax1.c0000644000175000017500000000564412502221024015743 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern integer izmax1_(integer* n, doublecomplex* cx, integer* incx);


static VALUE
rblapack_izmax1(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_cx;
  doublecomplex *cx; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack___out__;
  integer __out__; 

  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  __out__ = NumRu::Lapack.izmax1( cx, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      INTEGER          FUNCTION IZMAX1( N, CX, INCX )\n\n*  Purpose\n*  =======\n*\n*  IZMAX1 finds the index of the element whose real part has maximum\n*  absolute value.\n*\n*  Based on IZAMAX from Level 1 BLAS.\n*  The change is to use the 'genuine' absolute value.\n*\n*  Contributed by Nick Higham for use with ZLACON.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of elements in the vector CX.\n*\n*  CX      (input) COMPLEX*16 array, dimension (N)\n*          The vector whose elements will be summed.\n*\n*  INCX    (input) INTEGER\n*          The spacing between successive values of CX.  INCX >= 1.\n*\n\n* =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, IX\n      DOUBLE PRECISION   SMAX\n      COMPLEX*16         ZDUM\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS\n*     ..\n*     .. Statement Functions ..\n      DOUBLE PRECISION   CABS1\n*     ..\n*     .. Statement Function definitions ..\n*\n*     NEXT LINE IS THE ONLY MODIFICATION.\n      CABS1( ZDUM ) = ABS( ZDUM )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.izmax1( cx, incx, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_cx = argv[0];
  rblapack_incx = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_cx))
    rb_raise(rb_eArgError, "cx (1th argument) must be NArray");
  if (NA_RANK(rblapack_cx) != 1)
    rb_raise(rb_eArgError, "rank of cx (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_cx);
  if (NA_TYPE(rblapack_cx) != NA_DCOMPLEX)
    rblapack_cx = na_change_type(rblapack_cx, NA_DCOMPLEX);
  cx = NA_PTR_TYPE(rblapack_cx, doublecomplex*);
  incx = NUM2INT(rblapack_incx);

  __out__ = izmax1_(&n, cx, &incx);

  rblapack___out__ = INT2NUM(__out__);
  return rblapack___out__;
}

void
init_lapack_izmax1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "izmax1", rblapack_izmax1, -1);
}
ruby-lapack-1.7.2/ext/dgbrfsx.c0000644000175000017500000005706312502221015016173 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgbrfsx_(char* trans, char* equed, integer* n, integer* kl, integer* ku, integer* nrhs, doublereal* ab, integer* ldab, doublereal* afb, integer* ldafb, integer* ipiv, doublereal* r, doublereal* c, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dgbrfsx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_afb;
  doublereal *afb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_r;
  doublereal *r; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_params;
  doublereal *params; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_err_bnds_norm;
  doublereal *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  doublereal *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_r_out__;
  doublereal *r_out__;
  VALUE rblapack_c_out__;
  doublereal *c_out__;
  VALUE rblapack_x_out__;
  doublereal *x_out__;
  VALUE rblapack_params_out__;
  doublereal *params_out__;
  doublereal *work;
  integer *iwork;

  integer ldab;
  integer n;
  integer ldafb;
  integer ldb;
  integer nrhs;
  integer ldx;
  integer nparams;
  integer n_err_bnds;

  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  rcond, berr, err_bnds_norm, err_bnds_comp, info, r, c, x, params = NumRu::Lapack.dgbrfsx( trans, equed, kl, ku, ab, afb, ipiv, r, c, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     DGBRFSX improves the computed solution to a system of linear\n*     equations and provides error bounds and backward error estimates\n*     for the solution.  In addition to normwise error bound, the code\n*     provides maximum componentwise error bound if possible.  See\n*     comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n*     error bounds.\n*\n*     The original system of linear equations may have been equilibrated\n*     before calling this routine, as described by arguments EQUED, R\n*     and C below. In this case, the solution and error bounds returned\n*     are for the original unequilibrated system.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     TRANS   (input) CHARACTER*1\n*     Specifies the form of the system of equations:\n*       = 'N':  A * X = B     (No transpose)\n*       = 'T':  A**T * X = B  (Transpose)\n*       = 'C':  A**H * X = B  (Conjugate transpose = Transpose)\n*\n*     EQUED   (input) CHARACTER*1\n*     Specifies the form of equilibration that was done to A\n*     before calling this routine. This is needed to compute\n*     the solution and error bounds correctly.\n*       = 'N':  No equilibration\n*       = 'R':  Row equilibration, i.e., A has been premultiplied by\n*               diag(R).\n*       = 'C':  Column equilibration, i.e., A has been postmultiplied\n*               by diag(C).\n*       = 'B':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(R) * A * diag(C).\n*               The right hand side B has been changed accordingly.\n*\n*     N       (input) INTEGER\n*     The order of the matrix A.  N >= 0.\n*\n*     KL      (input) INTEGER\n*     The number of subdiagonals within the band of A.  KL >= 0.\n*\n*     KU      (input) INTEGER\n*     The number of superdiagonals within the band of A.  KU >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)\n*     The original band matrix A, stored in rows 1 to KL+KU+1.\n*     The j-th column of A is stored in the j-th column of the\n*     array AB as follows:\n*     AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n*     LDAB    (input) INTEGER\n*     The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*     AFB     (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n*     Details of the LU factorization of the band matrix A, as\n*     computed by DGBTRF.  U is stored as an upper triangular band\n*     matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n*     the multipliers used during the factorization are stored in\n*     rows KL+KU+2 to 2*KL+KU+1.\n*\n*     LDAFB   (input) INTEGER\n*     The leading dimension of the array AFB.  LDAFB >= 2*KL*KU+1.\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     The pivot indices from DGETRF; for 1<=i<=N, row i of the\n*     matrix was interchanged with row IPIV(i).\n*\n*     R       (input or output) DOUBLE PRECISION array, dimension (N)\n*     The row scale factors for A.  If EQUED = 'R' or 'B', A is\n*     multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n*     is not accessed.  R is an input argument if FACT = 'F';\n*     otherwise, R is an output argument.  If FACT = 'F' and\n*     EQUED = 'R' or 'B', each element of R must be positive.\n*     If R is output, each element of R is a power of the radix.\n*     If R is input, each element of R should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     C       (input or output) DOUBLE PRECISION array, dimension (N)\n*     The column scale factors for A.  If EQUED = 'C' or 'B', A is\n*     multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n*     is not accessed.  C is an input argument if FACT = 'F';\n*     otherwise, C is an output argument.  If FACT = 'F' and\n*     EQUED = 'C' or 'B', each element of C must be positive.\n*     If C is output, each element of C is a power of the radix.\n*     If C is input, each element of C should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*     The right hand side matrix B.\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*     On entry, the solution matrix X, as computed by DGETRS.\n*     On exit, the improved solution matrix X.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) DOUBLE PRECISION\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*     Componentwise relative backward error.  This is the\n*     componentwise relative backward error of each solution vector X(j)\n*     (i.e., the smallest relative change in any element of A or B that\n*     makes X(j) an exact solution).\n*\n*     N_ERR_BNDS (input) INTEGER\n*     Number of error bounds to return for each right hand side\n*     and each type (normwise or componentwise).  See ERR_BNDS_NORM and\n*     ERR_BNDS_COMP below.\n*\n*     ERR_BNDS_NORM  (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * dlamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * dlamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * dlamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * dlamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * dlamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * dlamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     NPARAMS (input) INTEGER\n*     Specifies the number of parameters set in PARAMS.  If .LE. 0, the\n*     PARAMS array is never referenced and default values are used.\n*\n*     PARAMS  (input / output) DOUBLE PRECISION array, dimension (NPARAMS)\n*     Specifies algorithm parameters.  If an entry is .LT. 0.0, then\n*     that entry will be filled with default value used for that\n*     parameter.  Only positions up to NPARAMS are accessed; defaults\n*     are used for higher-numbered parameters.\n*\n*       PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n*            refinement or not.\n*         Default: 1.0D+0\n*            = 0.0 : No refinement is performed, and no error bounds are\n*                    computed.\n*            = 1.0 : Use the double-precision refinement algorithm,\n*                    possibly with doubled-single computations if the\n*                    compilation environment does not support DOUBLE\n*                    PRECISION.\n*              (other values are reserved for future use)\n*\n*       PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n*            computations allowed for refinement.\n*         Default: 10\n*         Aggressive: Set to 100 to permit convergence using approximate\n*                     factorizations or factorizations other than LU. If\n*                     the factorization uses a technique other than\n*                     Gaussian elimination, the guarantees in\n*                     err_bnds_norm and err_bnds_comp may no longer be\n*                     trustworthy.\n*\n*       PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n*            will attempt to find a solution with small componentwise\n*            relative error in the double-precision algorithm.  Positive\n*            is true, 0.0 is false.\n*         Default: 1.0 (attempt componentwise convergence)\n*\n*     WORK    (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n*     IWORK   (workspace) INTEGER array, dimension (N)\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit. The solution to every right-hand side is\n*         guaranteed.\n*       < 0:  If INFO = -i, the i-th argument had an illegal value\n*       > 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, berr, err_bnds_norm, err_bnds_comp, info, r, c, x, params = NumRu::Lapack.dgbrfsx( trans, equed, kl, ku, ab, afb, ipiv, r, c, b, x, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_trans = argv[0];
  rblapack_equed = argv[1];
  rblapack_kl = argv[2];
  rblapack_ku = argv[3];
  rblapack_ab = argv[4];
  rblapack_afb = argv[5];
  rblapack_ipiv = argv[6];
  rblapack_r = argv[7];
  rblapack_c = argv[8];
  rblapack_b = argv[9];
  rblapack_x = argv[10];
  rblapack_params = argv[11];
  if (argc == 12) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (9th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (11th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (11th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  n_err_bnds = 3;
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
  ldafb = NA_SHAPE0(rblapack_afb);
  if (NA_SHAPE1(rblapack_afb) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_afb) != NA_DFLOAT)
    rblapack_afb = na_change_type(rblapack_afb, NA_DFLOAT);
  afb = NA_PTR_TYPE(rblapack_afb, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (10th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (10th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (12th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (12th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_DFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
  params = NA_PTR_TYPE(rblapack_params, doublereal*);
  if (!NA_IsNArray(rblapack_r))
    rb_raise(rb_eArgError, "r (8th argument) must be NArray");
  if (NA_RANK(rblapack_r) != 1)
    rb_raise(rb_eArgError, "rank of r (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_r) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_r) != NA_DFLOAT)
    rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
  r = NA_PTR_TYPE(rblapack_r, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_r_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  r_out__ = NA_PTR_TYPE(rblapack_r_out__, doublereal*);
  MEMCPY(r_out__, r, doublereal, NA_TOTAL(rblapack_r));
  rblapack_r = rblapack_r_out__;
  r = r_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
  MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(doublereal, (4*n));
  iwork = ALLOC_N(integer, (n));

  dgbrfsx_(&trans, &equed, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, r, c, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_r, rblapack_c, rblapack_x, rblapack_params);
}

void
init_lapack_dgbrfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgbrfsx", rblapack_dgbrfsx, -1);
}
ruby-lapack-1.7.2/ext/chetrs2.c0000644000175000017500000001223612502221016016100 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chetrs2_(char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, integer* ipiv, complex* b, integer* ldb, complex* work, integer* info);


static VALUE
rblapack_chetrs2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  complex *b_out__;
  complex *work;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.chetrs2( uplo, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,  WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHETRS2 solves a system of linear equations A*X = B with a COMPLEX\n*  Hermitian matrix A using the factorization A = U*D*U**T or\n*  A = L*D*L**T computed by CSYTRF and converted by CSYCONV.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**H;\n*          = 'L':  Lower triangular, form is A = L*D*L**H.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by CHETRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by CHETRF.\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  WORK    (workspace) COMPLEX array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.chetrs2( uplo, a, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(complex, (n));

  chetrs2_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_chetrs2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chetrs2", rblapack_chetrs2, -1);
}
ruby-lapack-1.7.2/ext/slaqr4.c0000644000175000017500000002735612502221022015742 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaqr4_(logical* wantt, logical* wantz, integer* n, integer* ilo, integer* ihi, real* h, integer* ldh, real* wr, real* wi, integer* iloz, integer* ihiz, real* z, integer* ldz, real* work, integer* lwork, integer* info);


static VALUE
rblapack_slaqr4(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantt;
  logical wantt; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_h;
  real *h; 
  VALUE rblapack_iloz;
  integer iloz; 
  VALUE rblapack_ihiz;
  integer ihiz; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_wr;
  real *wr; 
  VALUE rblapack_wi;
  real *wi; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_h_out__;
  real *h_out__;
  VALUE rblapack_z_out__;
  real *z_out__;

  integer ldh;
  integer n;
  integer ldz;
  integer ihi;

  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  wr, wi, work, info, h, z = NumRu::Lapack.slaqr4( wantt, wantz, ilo, h, iloz, ihiz, z, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     SLAQR4 computes the eigenvalues of a Hessenberg matrix H\n*     and, optionally, the matrices T and Z from the Schur decomposition\n*     H = Z T Z**T, where T is an upper quasi-triangular matrix (the\n*     Schur form), and Z is the orthogonal matrix of Schur vectors.\n*\n*     Optionally Z may be postmultiplied into an input orthogonal\n*     matrix Q so that this routine can give the Schur factorization\n*     of a matrix A which has been reduced to the Hessenberg form H\n*     by the orthogonal matrix Q:  A = Q*H*Q**T = (QZ)*T*(QZ)**T.\n*\n\n*     Arguments\n*     =========\n*\n*     WANTT   (input) LOGICAL\n*          = .TRUE. : the full Schur form T is required;\n*          = .FALSE.: only eigenvalues are required.\n*\n*     WANTZ   (input) LOGICAL\n*          = .TRUE. : the matrix of Schur vectors Z is required;\n*          = .FALSE.: Schur vectors are not required.\n*\n*     N     (input) INTEGER\n*           The order of the matrix H.  N .GE. 0.\n*\n*     ILO   (input) INTEGER\n*     IHI   (input) INTEGER\n*           It is assumed that H is already upper triangular in rows\n*           and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n*           H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n*           previous call to SGEBAL, and then passed to SGEHRD when the\n*           matrix output by SGEBAL is reduced to Hessenberg form.\n*           Otherwise, ILO and IHI should be set to 1 and N,\n*           respectively.  If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n*           If N = 0, then ILO = 1 and IHI = 0.\n*\n*     H     (input/output) REAL array, dimension (LDH,N)\n*           On entry, the upper Hessenberg matrix H.\n*           On exit, if INFO = 0 and WANTT is .TRUE., then H contains\n*           the upper quasi-triangular matrix T from the Schur\n*           decomposition (the Schur form); 2-by-2 diagonal blocks\n*           (corresponding to complex conjugate pairs of eigenvalues)\n*           are returned in standard form, with H(i,i) = H(i+1,i+1)\n*           and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is\n*           .FALSE., then the contents of H are unspecified on exit.\n*           (The output value of H when INFO.GT.0 is given under the\n*           description of INFO below.)\n*\n*           This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n*           j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n*\n*     LDH   (input) INTEGER\n*           The leading dimension of the array H. LDH .GE. max(1,N).\n*\n*     WR    (output) REAL array, dimension (IHI)\n*     WI    (output) REAL array, dimension (IHI)\n*           The real and imaginary parts, respectively, of the computed\n*           eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI)\n*           and WI(ILO:IHI). If two eigenvalues are computed as a\n*           complex conjugate pair, they are stored in consecutive\n*           elements of WR and WI, say the i-th and (i+1)th, with\n*           WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then\n*           the eigenvalues are stored in the same order as on the\n*           diagonal of the Schur form returned in H, with\n*           WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal\n*           block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and\n*           WI(i+1) = -WI(i).\n*\n*     ILOZ     (input) INTEGER\n*     IHIZ     (input) INTEGER\n*           Specify the rows of Z to which transformations must be\n*           applied if WANTZ is .TRUE..\n*           1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.\n*\n*     Z     (input/output) REAL array, dimension (LDZ,IHI)\n*           If WANTZ is .FALSE., then Z is not referenced.\n*           If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n*           replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n*           orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n*           (The output value of Z when INFO.GT.0 is given under\n*           the description of INFO below.)\n*\n*     LDZ   (input) INTEGER\n*           The leading dimension of the array Z.  if WANTZ is .TRUE.\n*           then LDZ.GE.MAX(1,IHIZ).  Otherwize, LDZ.GE.1.\n*\n*     WORK  (workspace/output) REAL array, dimension LWORK\n*           On exit, if LWORK = -1, WORK(1) returns an estimate of\n*           the optimal value for LWORK.\n*\n*     LWORK (input) INTEGER\n*           The dimension of the array WORK.  LWORK .GE. max(1,N)\n*           is sufficient, but LWORK typically as large as 6*N may\n*           be required for optimal performance.  A workspace query\n*           to determine the optimal workspace size is recommended.\n*\n*           If LWORK = -1, then SLAQR4 does a workspace query.\n*           In this case, SLAQR4 checks the input parameters and\n*           estimates the optimal workspace size for the given\n*           values of N, ILO and IHI.  The estimate is returned\n*           in WORK(1).  No error message related to LWORK is\n*           issued by XERBLA.  Neither H nor Z are accessed.\n*\n*\n*     INFO  (output) INTEGER\n*             =  0:  successful exit\n*           .GT. 0:  if INFO = i, SLAQR4 failed to compute all of\n*                the eigenvalues.  Elements 1:ilo-1 and i+1:n of WR\n*                and WI contain those eigenvalues which have been\n*                successfully computed.  (Failures are rare.)\n*\n*                If INFO .GT. 0 and WANT is .FALSE., then on exit,\n*                the remaining unconverged eigenvalues are the eigen-\n*                values of the upper Hessenberg matrix rows and\n*                columns ILO through INFO of the final, output\n*                value of H.\n*\n*                If INFO .GT. 0 and WANTT is .TRUE., then on exit\n*\n*           (*)  (initial value of H)*U  = U*(final value of H)\n*\n*                where U is an orthogonal matrix.  The final\n*                value of H is upper Hessenberg and quasi-triangular\n*                in rows and columns INFO+1 through IHI.\n*\n*                If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n*\n*                  (final value of Z(ILO:IHI,ILOZ:IHIZ)\n*                   =  (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n*\n*                where U is the orthogonal matrix in (*) (regard-\n*                less of the value of WANTT.)\n*\n*                If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n*                accessed.\n*\n\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n*     References:\n*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n*       Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n*       Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n*       929--947, 2002.\n*\n*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n*       Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n*       of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n*     ================================================================\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  wr, wi, work, info, h, z = NumRu::Lapack.slaqr4( wantt, wantz, ilo, h, iloz, ihiz, z, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_wantt = argv[0];
  rblapack_wantz = argv[1];
  rblapack_ilo = argv[2];
  rblapack_h = argv[3];
  rblapack_iloz = argv[4];
  rblapack_ihiz = argv[5];
  rblapack_z = argv[6];
  if (argc == 8) {
    rblapack_lwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  wantt = (rblapack_wantt == Qtrue);
  ilo = NUM2INT(rblapack_ilo);
  iloz = NUM2INT(rblapack_iloz);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (7th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  ihi = NA_SHAPE1(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  wantz = (rblapack_wantz == Qtrue);
  ihiz = NUM2INT(rblapack_ihiz);
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (4th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (4th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_SFLOAT)
    rblapack_h = na_change_type(rblapack_h, NA_SFLOAT);
  h = NA_PTR_TYPE(rblapack_h, real*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = ihi;
    rblapack_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  wr = NA_PTR_TYPE(rblapack_wr, real*);
  {
    na_shape_t shape[1];
    shape[0] = ihi;
    rblapack_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  wi = NA_PTR_TYPE(rblapack_wi, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, real*);
  MEMCPY(h_out__, h, real, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = ihi;
    rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
  MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  slaqr4_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, wr, wi, &iloz, &ihiz, z, &ldz, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_wr, rblapack_wi, rblapack_work, rblapack_info, rblapack_h, rblapack_z);
}

void
init_lapack_slaqr4(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaqr4", rblapack_slaqr4, -1);
}
ruby-lapack-1.7.2/ext/zposvx.c0000644000175000017500000003661612502221023016105 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zposvx_(char* fact, char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, char* equed, doublereal* s, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zposvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_af_out__;
  doublecomplex *af_out__;
  VALUE rblapack_s_out__;
  doublereal *s_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, info, a, af, equed, s, b = NumRu::Lapack.zposvx( fact, uplo, a, af, equed, s, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPOSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to\n*  compute the solution to a complex system of linear equations\n*     A * X = B,\n*  where A is an N-by-N Hermitian positive definite matrix and X and B\n*  are N-by-NRHS matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'E', real scaling factors are computed to equilibrate\n*     the system:\n*        diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n*  2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n*     factor the matrix A (after equilibration if FACT = 'E') as\n*        A = U**H* U,  if UPLO = 'U', or\n*        A = L * L**H,  if UPLO = 'L',\n*     where U is an upper triangular matrix and L is a lower triangular\n*     matrix.\n*\n*  3. If the leading i-by-i principal minor is not positive definite,\n*     then the routine returns with INFO = i. Otherwise, the factored\n*     form of A is used to estimate the condition number of the matrix\n*     A.  If the reciprocal of the condition number is less than machine\n*     precision, INFO = N+1 is returned as a warning, but the routine\n*     still goes on to solve for X and compute error bounds as\n*     described below.\n*\n*  4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  5. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n*  6. If equilibration was used, the matrix X is premultiplied by\n*     diag(S) so that it solves the original system before\n*     equilibration.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of the matrix A is\n*          supplied on entry, and if not, whether the matrix A should be\n*          equilibrated before it is factored.\n*          = 'F':  On entry, AF contains the factored form of A.\n*                  If EQUED = 'Y', the matrix A has been equilibrated\n*                  with scaling factors given by S.  A and AF will not\n*                  be modified.\n*          = 'N':  The matrix A will be copied to AF and factored.\n*          = 'E':  The matrix A will be equilibrated if necessary, then\n*                  copied to AF and factored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the Hermitian matrix A, except if FACT = 'F' and\n*          EQUED = 'Y', then A must contain the equilibrated matrix\n*          diag(S)*A*diag(S).  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.  A is not modified if\n*          FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n*          On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n*          diag(S)*A*diag(S).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AF      (input or output) COMPLEX*16 array, dimension (LDAF,N)\n*          If FACT = 'F', then AF is an input argument and on entry\n*          contains the triangular factor U or L from the Cholesky\n*          factorization A = U**H*U or A = L*L**H, in the same storage\n*          format as A.  If EQUED .ne. 'N', then AF is the factored form\n*          of the equilibrated matrix diag(S)*A*diag(S).\n*\n*          If FACT = 'N', then AF is an output argument and on exit\n*          returns the triangular factor U or L from the Cholesky\n*          factorization A = U**H*U or A = L*L**H of the original\n*          matrix A.\n*\n*          If FACT = 'E', then AF is an output argument and on exit\n*          returns the triangular factor U or L from the Cholesky\n*          factorization A = U**H*U or A = L*L**H of the equilibrated\n*          matrix A (see the description of A for the form of the\n*          equilibrated matrix).\n*\n*  LDAF    (input) INTEGER\n*          The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*  EQUED   (input or output) CHARACTER*1\n*          Specifies the form of equilibration that was done.\n*          = 'N':  No equilibration (always true if FACT = 'N').\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*          EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*          output argument.\n*\n*  S       (input or output) DOUBLE PRECISION array, dimension (N)\n*          The scale factors for A; not accessed if EQUED = 'N'.  S is\n*          an input argument if FACT = 'F'; otherwise, S is an output\n*          argument.  If FACT = 'F' and EQUED = 'Y', each element of S\n*          must be positive.\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS righthand side matrix B.\n*          On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n*          B is overwritten by diag(S) * B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) COMPLEX*16 array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n*          the original system of equations.  Note that if EQUED = 'Y',\n*          A and B are modified on exit, and the solution to the\n*          equilibrated system is inv(diag(S))*X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The estimate of the reciprocal condition number of the matrix\n*          A after equilibration (if done).  If RCOND is less than the\n*          machine precision (in particular, if RCOND = 0), the matrix\n*          is singular to working precision.  This condition is\n*          indicated by a return code of INFO > 0.\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\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, and i is\n*                <= N:  the leading minor of order i of A is\n*                       not positive definite, so the factorization\n*                       could not be completed, and the solution has not\n*                       been computed. RCOND = 0 is returned.\n*                = N+1: U is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, info, a, af, equed, s, b = NumRu::Lapack.zposvx( fact, uplo, a, af, equed, s, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_equed = argv[4];
  rblapack_s = argv[5];
  rblapack_b = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (6th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  ldx = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldaf;
    shape[1] = n;
    rblapack_af_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  af_out__ = NA_PTR_TYPE(rblapack_af_out__, doublecomplex*);
  MEMCPY(af_out__, af, doublecomplex, NA_TOTAL(rblapack_af));
  rblapack_af = rblapack_af_out__;
  af = af_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
  MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (n));

  zposvx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_a, rblapack_af, rblapack_equed, rblapack_s, rblapack_b);
}

void
init_lapack_zposvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zposvx", rblapack_zposvx, -1);
}
ruby-lapack-1.7.2/ext/dsptri.c0000644000175000017500000001115712502221017016035 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsptri_(char* uplo, integer* n, doublereal* ap, integer* ipiv, doublereal* work, integer* info);


static VALUE
rblapack_dsptri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublereal *ap_out__;
  doublereal *work;

  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  info, ap = NumRu::Lapack.dsptri( uplo, ap, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSPTRI( UPLO, N, AP, IPIV, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSPTRI computes the inverse of a real symmetric indefinite matrix\n*  A in packed storage using the factorization A = U*D*U**T or\n*  A = L*D*L**T computed by DSPTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          On entry, the block diagonal matrix D and the multipliers\n*          used to obtain the factor U or L as computed by DSPTRF,\n*          stored as a packed triangular matrix.\n*\n*          On exit, if INFO = 0, the (symmetric) inverse of the original\n*          matrix, stored as a packed triangular matrix. The j-th column\n*          of inv(A) is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;\n*          if UPLO = 'L',\n*             AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by DSPTRF.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (N)\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, D(i,i) = 0; the matrix is singular and its\n*               inverse could not be computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ap = NumRu::Lapack.dsptri( uplo, ap, ipiv, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_ipiv = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
  MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  work = ALLOC_N(doublereal, (n));

  dsptri_(&uplo, &n, ap, ipiv, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ap);
}

void
init_lapack_dsptri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsptri", rblapack_dsptri, -1);
}
ruby-lapack-1.7.2/ext/dhseqr.c0000644000175000017500000003613712502221024016021 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dhseqr_(char* job, char* compz, integer* n, integer* ilo, integer* ihi, doublereal* h, integer* ldh, doublereal* wr, doublereal* wi, doublereal* z, integer* ldz, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dhseqr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_compz;
  char compz; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_h;
  doublereal *h; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_ldz;
  integer ldz; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_wr;
  doublereal *wr; 
  VALUE rblapack_wi;
  doublereal *wi; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_h_out__;
  doublereal *h_out__;
  VALUE rblapack_z_out__;
  doublereal *z_out__;

  integer ldh;
  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  wr, wi, work, info, h, z = NumRu::Lapack.dhseqr( job, compz, ilo, ihi, h, z, ldz, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, LDZ, WORK, LWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     DHSEQR computes the eigenvalues of a Hessenberg matrix H\n*     and, optionally, the matrices T and Z from the Schur decomposition\n*     H = Z T Z**T, where T is an upper quasi-triangular matrix (the\n*     Schur form), and Z is the orthogonal matrix of Schur vectors.\n*\n*     Optionally Z may be postmultiplied into an input orthogonal\n*     matrix Q so that this routine can give the Schur factorization\n*     of a matrix A which has been reduced to the Hessenberg form H\n*     by the orthogonal matrix Q:  A = Q*H*Q**T = (QZ)*T*(QZ)**T.\n*\n\n*     Arguments\n*     =========\n*\n*     JOB   (input) CHARACTER*1\n*           = 'E':  compute eigenvalues only;\n*           = 'S':  compute eigenvalues and the Schur form T.\n*\n*     COMPZ (input) CHARACTER*1\n*           = 'N':  no Schur vectors are computed;\n*           = 'I':  Z is initialized to the unit matrix and the matrix Z\n*                   of Schur vectors of H is returned;\n*           = 'V':  Z must contain an orthogonal matrix Q on entry, and\n*                   the product Q*Z is returned.\n*\n*     N     (input) INTEGER\n*           The order of the matrix H.  N .GE. 0.\n*\n*     ILO   (input) INTEGER\n*     IHI   (input) INTEGER\n*           It is assumed that H is already upper triangular in rows\n*           and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n*           set by a previous call to DGEBAL, and then passed to DGEHRD\n*           when the matrix output by DGEBAL is reduced to Hessenberg\n*           form. Otherwise ILO and IHI should be set to 1 and N\n*           respectively.  If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n*           If N = 0, then ILO = 1 and IHI = 0.\n*\n*     H     (input/output) DOUBLE PRECISION array, dimension (LDH,N)\n*           On entry, the upper Hessenberg matrix H.\n*           On exit, if INFO = 0 and JOB = 'S', then H contains the\n*           upper quasi-triangular matrix T from the Schur decomposition\n*           (the Schur form); 2-by-2 diagonal blocks (corresponding to\n*           complex conjugate pairs of eigenvalues) are returned in\n*           standard form, with H(i,i) = H(i+1,i+1) and\n*           H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and JOB = 'E', the\n*           contents of H are unspecified on exit.  (The output value of\n*           H when INFO.GT.0 is given under the description of INFO\n*           below.)\n*\n*           Unlike earlier versions of DHSEQR, this subroutine may\n*           explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1\n*           or j = IHI+1, IHI+2, ... N.\n*\n*     LDH   (input) INTEGER\n*           The leading dimension of the array H. LDH .GE. max(1,N).\n*\n*     WR    (output) DOUBLE PRECISION array, dimension (N)\n*     WI    (output) DOUBLE PRECISION array, dimension (N)\n*           The real and imaginary parts, respectively, of the computed\n*           eigenvalues. If two eigenvalues are computed as a complex\n*           conjugate pair, they are stored in consecutive elements of\n*           WR and WI, say the i-th and (i+1)th, with WI(i) .GT. 0 and\n*           WI(i+1) .LT. 0. If JOB = 'S', the eigenvalues are stored in\n*           the same order as on the diagonal of the Schur form returned\n*           in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2\n*           diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and\n*           WI(i+1) = -WI(i).\n*\n*     Z     (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n*           If COMPZ = 'N', Z is not referenced.\n*           If COMPZ = 'I', on entry Z need not be set and on exit,\n*           if INFO = 0, Z contains the orthogonal matrix Z of the Schur\n*           vectors of H.  If COMPZ = 'V', on entry Z must contain an\n*           N-by-N matrix Q, which is assumed to be equal to the unit\n*           matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,\n*           if INFO = 0, Z contains Q*Z.\n*           Normally Q is the orthogonal matrix generated by DORGHR\n*           after the call to DGEHRD which formed the Hessenberg matrix\n*           H. (The output value of Z when INFO.GT.0 is given under\n*           the description of INFO below.)\n*\n*     LDZ   (input) INTEGER\n*           The leading dimension of the array Z.  if COMPZ = 'I' or\n*           COMPZ = 'V', then LDZ.GE.MAX(1,N).  Otherwize, LDZ.GE.1.\n*\n*     WORK  (workspace/output) DOUBLE PRECISION array, dimension (LWORK)\n*           On exit, if INFO = 0, WORK(1) returns an estimate of\n*           the optimal value for LWORK.\n*\n*     LWORK (input) INTEGER\n*           The dimension of the array WORK.  LWORK .GE. max(1,N)\n*           is sufficient and delivers very good and sometimes\n*           optimal performance.  However, LWORK as large as 11*N\n*           may be required for optimal performance.  A workspace\n*           query is recommended to determine the optimal workspace\n*           size.\n*\n*           If LWORK = -1, then DHSEQR does a workspace query.\n*           In this case, DHSEQR checks the input parameters and\n*           estimates the optimal workspace size for the given\n*           values of N, ILO and IHI.  The estimate is returned\n*           in WORK(1).  No error message related to LWORK is\n*           issued by XERBLA.  Neither H nor Z are accessed.\n*\n*\n*     INFO  (output) INTEGER\n*             =  0:  successful exit\n*           .LT. 0:  if INFO = -i, the i-th argument had an illegal\n*                    value\n*           .GT. 0:  if INFO = i, DHSEQR failed to compute all of\n*                the eigenvalues.  Elements 1:ilo-1 and i+1:n of WR\n*                and WI contain those eigenvalues which have been\n*                successfully computed.  (Failures are rare.)\n*\n*                If INFO .GT. 0 and JOB = 'E', then on exit, the\n*                remaining unconverged eigenvalues are the eigen-\n*                values of the upper Hessenberg matrix rows and\n*                columns ILO through INFO of the final, output\n*                value of H.\n*\n*                If INFO .GT. 0 and JOB   = 'S', then on exit\n*\n*           (*)  (initial value of H)*U  = U*(final value of H)\n*\n*                where U is an orthogonal matrix.  The final\n*                value of H is upper Hessenberg and quasi-triangular\n*                in rows and columns INFO+1 through IHI.\n*\n*                If INFO .GT. 0 and COMPZ = 'V', then on exit\n*\n*                  (final value of Z)  =  (initial value of Z)*U\n*\n*                where U is the orthogonal matrix in (*) (regard-\n*                less of the value of JOB.)\n*\n*                If INFO .GT. 0 and COMPZ = 'I', then on exit\n*                      (final value of Z)  = U\n*                where U is the orthogonal matrix in (*) (regard-\n*                less of the value of JOB.)\n*\n*                If INFO .GT. 0 and COMPZ = 'N', then Z is not\n*                accessed.\n*\n\n*     ================================================================\n*             Default values supplied by\n*             ILAENV(ISPEC,'DHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).\n*             It is suggested that these defaults be adjusted in order\n*             to attain best performance in each particular\n*             computational environment.\n*\n*            ISPEC=12: The DLAHQR vs DLAQR0 crossover point.\n*                      Default: 75. (Must be at least 11.)\n*\n*            ISPEC=13: Recommended deflation window size.\n*                      This depends on ILO, IHI and NS.  NS is the\n*                      number of simultaneous shifts returned\n*                      by ILAENV(ISPEC=15).  (See ISPEC=15 below.)\n*                      The default for (IHI-ILO+1).LE.500 is NS.\n*                      The default for (IHI-ILO+1).GT.500 is 3*NS/2.\n*\n*            ISPEC=14: Nibble crossover point. (See IPARMQ for\n*                      details.)  Default: 14% of deflation window\n*                      size.\n*\n*            ISPEC=15: Number of simultaneous shifts in a multishift\n*                      QR iteration.\n*\n*                      If IHI-ILO+1 is ...\n*\n*                      greater than      ...but less    ... the\n*                      or equal to ...      than        default is\n*\n*                           1               30          NS =   2(+)\n*                          30               60          NS =   4(+)\n*                          60              150          NS =  10(+)\n*                         150              590          NS =  **\n*                         590             3000          NS =  64\n*                        3000             6000          NS = 128\n*                        6000             infinity      NS = 256\n*\n*                  (+)  By default some or all matrices of this order\n*                       are passed to the implicit double shift routine\n*                       DLAHQR and this parameter is ignored.  See\n*                       ISPEC=12 above and comments in IPARMQ for\n*                       details.\n*\n*                 (**)  The asterisks (**) indicate an ad-hoc\n*                       function of N increasing from 10 to 64.\n*\n*            ISPEC=16: Select structured matrix multiply.\n*                      If the number of simultaneous shifts (specified\n*                      by ISPEC=15) is less than 14, then the default\n*                      for ISPEC=16 is 0.  Otherwise the default for\n*                      ISPEC=16 is 2.\n*\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n*     References:\n*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n*       Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n*       Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n*       929--947, 2002.\n*\n*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n*       Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n*       of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n*     ================================================================\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  wr, wi, work, info, h, z = NumRu::Lapack.dhseqr( job, compz, ilo, ihi, h, z, ldz, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_job = argv[0];
  rblapack_compz = argv[1];
  rblapack_ilo = argv[2];
  rblapack_ihi = argv[3];
  rblapack_h = argv[4];
  rblapack_z = argv[5];
  rblapack_ldz = argv[6];
  if (argc == 8) {
    rblapack_lwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  job = StringValueCStr(rblapack_job)[0];
  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (5th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_DFLOAT)
    rblapack_h = na_change_type(rblapack_h, NA_DFLOAT);
  h = NA_PTR_TYPE(rblapack_h, doublereal*);
  ldz = NUM2INT(rblapack_ldz);
  compz = StringValueCStr(rblapack_compz)[0];
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (6th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (6th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_z) != (lsame_(&compz,"N") ? 0 : ldz))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", lsame_(&compz,"N") ? 0 : ldz);
  if (NA_SHAPE1(rblapack_z) != (lsame_(&compz,"N") ? 0 : n))
    rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", lsame_(&compz,"N") ? 0 : n);
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  ihi = NUM2INT(rblapack_ihi);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  wr = NA_PTR_TYPE(rblapack_wr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  wi = NA_PTR_TYPE(rblapack_wi, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublereal*);
  MEMCPY(h_out__, h, doublereal, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = lsame_(&compz,"N") ? 0 : ldz;
    shape[1] = lsame_(&compz,"N") ? 0 : n;
    rblapack_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
  MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  dhseqr_(&job, &compz, &n, &ilo, &ihi, h, &ldh, wr, wi, z, &ldz, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_wr, rblapack_wi, rblapack_work, rblapack_info, rblapack_h, rblapack_z);
}

void
init_lapack_dhseqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dhseqr", rblapack_dhseqr, -1);
}
ruby-lapack-1.7.2/ext/cla_gbrcond_x.c0000644000175000017500000002023112502221022017301 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real cla_gbrcond_x_(char* trans, integer* n, integer* kl, integer* ku, complex* ab, integer* ldab, complex* afb, integer* ldafb, integer* ipiv, complex* x, integer* info, complex* work, real* rwork);


static VALUE
rblapack_cla_gbrcond_x(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_afb;
  complex *afb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_rwork;
  real *rwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack___out__;
  real __out__; 

  integer ldab;
  integer n;
  integer ldafb;

  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  info, __out__ = NumRu::Lapack.cla_gbrcond_x( trans, kl, ku, ab, afb, ipiv, x, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL FUNCTION CLA_GBRCOND_X( TRANS, N, KL, KU, AB, LDAB, AFB, LDAFB, IPIV, X, INFO, WORK, RWORK )\n\n*  Purpose\n*  =======\n*\n*     CLA_GBRCOND_X Computes the infinity norm condition number of\n*     op(A) * diag(X) where X is a COMPLEX vector.\n*\n\n*  Arguments\n*  =========\n*\n*     TRANS   (input) CHARACTER*1\n*     Specifies the form of the system of equations:\n*       = 'N':  A * X = B     (No transpose)\n*       = 'T':  A**T * X = B  (Transpose)\n*       = 'C':  A**H * X = B  (Conjugate Transpose = Transpose)\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     KL      (input) INTEGER\n*     The number of subdiagonals within the band of A.  KL >= 0.\n*\n*     KU      (input) INTEGER\n*     The number of superdiagonals within the band of A.  KU >= 0.\n*\n*     AB      (input) COMPLEX array, dimension (LDAB,N)\n*     On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n*     The j-th column of A is stored in the j-th column of the\n*     array AB as follows:\n*     AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n*     LDAB    (input) INTEGER\n*     The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*     AFB     (input) COMPLEX array, dimension (LDAFB,N)\n*     Details of the LU factorization of the band matrix A, as\n*     computed by CGBTRF.  U is stored as an upper triangular\n*     band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n*     and the multipliers used during the factorization are stored\n*     in rows KL+KU+2 to 2*KL+KU+1.\n*\n*     LDAFB   (input) INTEGER\n*     The leading dimension of the array AFB.  LDAFB >= 2*KL+KU+1.\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     The pivot indices from the factorization A = P*L*U\n*     as computed by CGBTRF; row i of the matrix was interchanged\n*     with row IPIV(i).\n*\n*     X       (input) COMPLEX array, dimension (N)\n*     The vector X in the formula op(A) * diag(X).\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit.\n*     i > 0:  The ith argument is invalid.\n*\n*     WORK    (input) COMPLEX array, dimension (2*N).\n*     Workspace.\n*\n*     RWORK   (input) REAL array, dimension (N).\n*     Workspace.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            NOTRANS\n      INTEGER            KASE, I, J\n      REAL               AINVNM, ANORM, TMP\n      COMPLEX            ZDUM\n*     ..\n*     .. Local Arrays ..\n      INTEGER            ISAVE( 3 )\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CLACN2, CGBTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX\n*     ..\n*     .. Statement Functions ..\n      REAL               CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, __out__ = NumRu::Lapack.cla_gbrcond_x( trans, kl, ku, ab, afb, ipiv, x, work, rwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_trans = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  rblapack_afb = argv[4];
  rblapack_ipiv = argv[5];
  rblapack_x = argv[6];
  rblapack_work = argv[7];
  rblapack_rwork = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
  ldafb = NA_SHAPE0(rblapack_afb);
  n = NA_SHAPE1(rblapack_afb);
  if (NA_TYPE(rblapack_afb) != NA_SCOMPLEX)
    rblapack_afb = na_change_type(rblapack_afb, NA_SCOMPLEX);
  afb = NA_PTR_TYPE(rblapack_afb, complex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (7th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  if (!NA_IsNArray(rblapack_rwork))
    rb_raise(rb_eArgError, "rwork (9th argument) must be NArray");
  if (NA_RANK(rblapack_rwork) != 1)
    rb_raise(rb_eArgError, "rank of rwork (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_rwork) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_rwork) != NA_SFLOAT)
    rblapack_rwork = na_change_type(rblapack_rwork, NA_SFLOAT);
  rwork = NA_PTR_TYPE(rblapack_rwork, real*);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (8th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
  if (NA_TYPE(rblapack_work) != NA_SCOMPLEX)
    rblapack_work = na_change_type(rblapack_work, NA_SCOMPLEX);
  work = NA_PTR_TYPE(rblapack_work, complex*);

  __out__ = cla_gbrcond_x_(&trans, &n, &kl, &ku, ab, &ldab, afb, &ldafb, ipiv, x, &info, work, rwork);

  rblapack_info = INT2NUM(info);
  rblapack___out__ = rb_float_new((double)__out__);
  return rb_ary_new3(2, rblapack_info, rblapack___out__);
}

void
init_lapack_cla_gbrcond_x(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cla_gbrcond_x", rblapack_cla_gbrcond_x, -1);
}
ruby-lapack-1.7.2/ext/slaqge.c0000644000175000017500000001316612502221016016005 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaqge_(integer* m, integer* n, real* a, integer* lda, real* r, real* c, real* rowcnd, real* colcnd, real* amax, char* equed);


static VALUE
rblapack_slaqge(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_r;
  real *r; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_rowcnd;
  real rowcnd; 
  VALUE rblapack_colcnd;
  real colcnd; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_a_out__;
  real *a_out__;

  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  equed, a = NumRu::Lapack.slaqge( a, r, c, rowcnd, colcnd, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n*  Purpose\n*  =======\n*\n*  SLAQGE equilibrates a general M by N matrix A using the row and\n*  column scaling factors in the vectors R and C.\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) REAL array, dimension (LDA,N)\n*          On entry, the M by N matrix A.\n*          On exit, the equilibrated matrix.  See EQUED for the form of\n*          the equilibrated matrix.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(M,1).\n*\n*  R       (input) REAL array, dimension (M)\n*          The row scale factors for A.\n*\n*  C       (input) REAL array, dimension (N)\n*          The column scale factors for A.\n*\n*  ROWCND  (input) REAL\n*          Ratio of the smallest R(i) to the largest R(i).\n*\n*  COLCND  (input) REAL\n*          Ratio of the smallest C(i) to the largest C(i).\n*\n*  AMAX    (input) REAL\n*          Absolute value of largest matrix entry.\n*\n*  EQUED   (output) CHARACTER*1\n*          Specifies the form of equilibration that was done.\n*          = 'N':  No equilibration\n*          = 'R':  Row equilibration, i.e., A has been premultiplied by\n*                  diag(R).\n*          = 'C':  Column equilibration, i.e., A has been postmultiplied\n*                  by diag(C).\n*          = 'B':  Both row and column equilibration, i.e., A has been\n*                  replaced by diag(R) * A * diag(C).\n*\n*  Internal Parameters\n*  ===================\n*\n*  THRESH is a threshold value used to decide if row or column scaling\n*  should be done based on the ratio of the row or column scaling\n*  factors.  If ROWCND < THRESH, row scaling is done, and if\n*  COLCND < THRESH, column scaling is done.\n*\n*  LARGE and SMALL are threshold values used to decide if row scaling\n*  should be done based on the absolute size of the largest matrix\n*  element.  If AMAX > LARGE or AMAX < SMALL, row scaling is done.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  equed, a = NumRu::Lapack.slaqge( a, r, c, rowcnd, colcnd, amax, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_a = argv[0];
  rblapack_r = argv[1];
  rblapack_c = argv[2];
  rblapack_rowcnd = argv[3];
  rblapack_colcnd = argv[4];
  rblapack_amax = argv[5];
  if (argc == 6) {
  } 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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (3th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  colcnd = (real)NUM2DBL(rblapack_colcnd);
  if (!NA_IsNArray(rblapack_r))
    rb_raise(rb_eArgError, "r (2th argument) must be NArray");
  if (NA_RANK(rblapack_r) != 1)
    rb_raise(rb_eArgError, "rank of r (2th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_r);
  if (NA_TYPE(rblapack_r) != NA_SFLOAT)
    rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
  r = NA_PTR_TYPE(rblapack_r, real*);
  amax = (real)NUM2DBL(rblapack_amax);
  rowcnd = (real)NUM2DBL(rblapack_rowcnd);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  slaqge_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &equed);

  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(2, rblapack_equed, rblapack_a);
}

void
init_lapack_slaqge(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaqge", rblapack_slaqge, -1);
}
ruby-lapack-1.7.2/ext/dgbtrf.c0000644000175000017500000001316012502221024015772 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgbtrf_(integer* m, integer* n, integer* kl, integer* ku, doublereal* ab, integer* ldab, integer* ipiv, integer* info);


static VALUE
rblapack_dgbtrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublereal *ab_out__;

  integer ldab;
  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  ipiv, info, ab = NumRu::Lapack.dgbtrf( m, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGBTRF computes an LU factorization of a real m-by-n band matrix A\n*  using partial pivoting with row interchanges.\n*\n*  This is the blocked version of the algorithm, calling Level 3 BLAS.\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*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n*          On entry, the matrix A in band storage, in rows KL+1 to\n*          2*KL+KU+1; rows 1 to KL of the array need not be set.\n*          The j-th column of A is stored in the j-th column of the\n*          array AB as follows:\n*          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n*          On exit, details of the factorization: U is stored as an\n*          upper triangular band matrix with KL+KU superdiagonals in\n*          rows 1 to KL+KU+1, and the multipliers used during the\n*          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n*          See below for further details.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.\n*\n*  IPIV    (output) INTEGER array, dimension (min(M,N))\n*          The pivot indices; for 1 <= i <= min(M,N), row i of the\n*          matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n*               has been completed, but the factor U is exactly\n*               singular, and division by zero will occur if it is used\n*               to solve a system of equations.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  M = N = 6, KL = 2, KU = 1:\n*\n*  On entry:                       On exit:\n*\n*      *    *    *    +    +    +       *    *    *   u14  u25  u36\n*      *    *    +    +    +    +       *    *   u13  u24  u35  u46\n*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56\n*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66\n*     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *\n*     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *\n*\n*  Array elements marked * are not used by the routine; elements marked\n*  + need not be set on entry, but are required by the routine to store\n*  elements of U because of fill-in resulting from the row interchanges.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, ab = NumRu::Lapack.dgbtrf( m, kl, ku, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_m = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  ku = NUM2INT(rblapack_ku);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
  MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  dgbtrf_(&m, &n, &kl, &ku, ab, &ldab, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_ab);
}

void
init_lapack_dgbtrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgbtrf", rblapack_dgbtrf, -1);
}
ruby-lapack-1.7.2/ext/dlaqsy.c0000644000175000017500000001241212502221024016016 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaqsy_(char* uplo, integer* n, doublereal* a, integer* lda, doublereal* s, doublereal* scond, doublereal* amax, char* equed);


static VALUE
rblapack_dlaqsy(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_scond;
  doublereal scond; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_equed;
  char equed; 
  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  equed, a = NumRu::Lapack.dlaqsy( uplo, a, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )\n\n*  Purpose\n*  =======\n*\n*  DLAQSY equilibrates a symmetric matrix A using the scaling factors\n*  in the vector S.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          n by n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n by n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if EQUED = 'Y', the equilibrated matrix:\n*          diag(S) * A * diag(S).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(N,1).\n*\n*  S       (input) DOUBLE PRECISION array, dimension (N)\n*          The scale factors for A.\n*\n*  SCOND   (input) DOUBLE PRECISION\n*          Ratio of the smallest S(i) to the largest S(i).\n*\n*  AMAX    (input) DOUBLE PRECISION\n*          Absolute value of largest matrix entry.\n*\n*  EQUED   (output) CHARACTER*1\n*          Specifies whether or not equilibration was done.\n*          = 'N':  No equilibration.\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*\n*  Internal Parameters\n*  ===================\n*\n*  THRESH is a threshold value used to decide if scaling should be done\n*  based on the ratio of the scaling factors.  If SCOND < THRESH,\n*  scaling is done.\n*\n*  LARGE and SMALL are threshold values used to decide if scaling should\n*  be done based on the absolute size of the largest matrix element.\n*  If AMAX > LARGE or AMAX < SMALL, scaling is done.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  equed, a = NumRu::Lapack.dlaqsy( uplo, a, s, scond, amax, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_s = argv[2];
  rblapack_scond = argv[3];
  rblapack_amax = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (3th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_s);
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  amax = NUM2DBL(rblapack_amax);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of s");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  scond = NUM2DBL(rblapack_scond);
  {
    na_shape_t 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__;

  dlaqsy_(&uplo, &n, a, &lda, s, &scond, &amax, &equed);

  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(2, rblapack_equed, rblapack_a);
}

void
init_lapack_dlaqsy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaqsy", rblapack_dlaqsy, -1);
}
ruby-lapack-1.7.2/ext/ztpttf.c0000644000175000017500000001677712502221021016073 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztpttf_(char* transr, char* uplo, integer* n, doublecomplex* ap, doublecomplex* arf, integer* info);


static VALUE
rblapack_ztpttf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_arf;
  doublecomplex *arf; 
  VALUE rblapack_info;
  integer info; 


  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  arf, info = NumRu::Lapack.ztpttf( transr, uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTPTTF( TRANSR, UPLO, N, AP, ARF, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTPTTF copies a triangular matrix A from standard packed format (TP)\n*  to rectangular full packed format (TF).\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR   (input) CHARACTER*1\n*          = 'N':  ARF in Normal format is wanted;\n*          = 'C':  ARF in Conjugate-transpose format is wanted.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n*          On entry, the upper or lower triangular matrix A, packed\n*          columnwise in a linear array. The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  ARF     (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n*          On exit, the upper or lower triangular matrix A stored in\n*          RFP format. For a further discussion see Notes below.\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*  We first consider Standard Packed Format when N is even.\n*  We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  conjugate-transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  conjugate-transpose of the last three columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                -- -- --\n*        03 04 05                33 43 53\n*                                   -- --\n*        13 14 15                00 44 54\n*                                      --\n*        23 24 25                10 11 55\n*\n*        33 34 35                20 21 22\n*        --\n*        00 44 45                30 31 32\n*        -- --\n*        01 11 55                40 41 42\n*        -- -- --\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- -- --                -- -- -- -- -- --\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     -- -- -- -- --                -- -- -- -- --\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     -- -- -- -- -- --                -- -- -- --\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We next  consider Standard Packed Format when N is odd.\n*  We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  conjugate-transpose of the first two   columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  conjugate-transpose of the last two   columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N odd  and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                   -- --\n*        02 03 04                00 33 43\n*                                      --\n*        12 13 14                10 11 44\n*\n*        22 23 24                20 21 22\n*        --\n*        00 33 34                30 31 32\n*        -- --\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- --                   -- -- -- -- -- --\n*     02 12 22 00 01             00 10 20 30 40 50\n*     -- -- -- --                   -- -- -- -- --\n*     03 13 23 33 11             33 11 21 31 41 51\n*     -- -- -- -- --                   -- -- -- --\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  arf, info = NumRu::Lapack.ztpttf( transr, uplo, n, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_n = argv[2];
  rblapack_ap = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  n = NUM2INT(rblapack_n);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (( n*(n+1)/2 )))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", ( n*(n+1)/2 ));
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = ( n*(n+1)/2 );
    rblapack_arf = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  arf = NA_PTR_TYPE(rblapack_arf, doublecomplex*);

  ztpttf_(&transr, &uplo, &n, ap, arf, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_arf, rblapack_info);
}

void
init_lapack_ztpttf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztpttf", rblapack_ztpttf, -1);
}
ruby-lapack-1.7.2/ext/spotf2.c0000644000175000017500000001002412502221017015735 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID spotf2_(char* uplo, integer* n, real* a, integer* lda, integer* info);


static VALUE
rblapack_spotf2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *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  info, a = NumRu::Lapack.spotf2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPOTF2( UPLO, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPOTF2 computes the Cholesky factorization of a real symmetric\n*  positive definite matrix A.\n*\n*  The factorization has the form\n*     A = U' * U ,  if UPLO = 'U', or\n*     A = L  * L',  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is lower triangular.\n*\n*  This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          n by n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n by n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the factor U or L from the Cholesky\n*          factorization A = U'*U  or A = L*L'.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*          > 0: if INFO = k, the leading minor of order k is not\n*               positive definite, and the factorization could not be\n*               completed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.spotf2( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  spotf2_(&uplo, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_spotf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "spotf2", rblapack_spotf2, -1);
}
ruby-lapack-1.7.2/ext/zlahr2.c0000644000175000017500000001572212502221021015727 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlahr2_(integer* n, integer* k, integer* nb, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* t, integer* ldt, doublecomplex* y, integer* ldy);


static VALUE
rblapack_zlahr2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_nb;
  integer nb; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_t;
  doublecomplex *t; 
  VALUE rblapack_y;
  doublecomplex *y; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;

  integer lda;
  integer ldt;
  integer ldy;

  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, t, y, a = NumRu::Lapack.zlahr2( n, k, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n*  Purpose\n*  =======\n*\n*  ZLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1)\n*  matrix A so that elements below the k-th subdiagonal are zero. The\n*  reduction is performed by an unitary similarity transformation\n*  Q' * A * Q. The routine returns the matrices V and T which determine\n*  Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n*\n*  This is an auxiliary routine called by ZGEHRD.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.\n*\n*  K       (input) INTEGER\n*          The offset for the reduction. Elements below the k-th\n*          subdiagonal in the first NB columns are reduced to zero.\n*          K < N.\n*\n*  NB      (input) INTEGER\n*          The number of columns to be reduced.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N-K+1)\n*          On entry, the n-by-(n-k+1) general matrix A.\n*          On exit, the elements on and above the k-th subdiagonal in\n*          the first NB columns are overwritten with the corresponding\n*          elements of the reduced matrix; the elements below the k-th\n*          subdiagonal, with the array TAU, represent the matrix Q as a\n*          product of elementary reflectors. The other columns of A are\n*          unchanged. See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  TAU     (output) COMPLEX*16 array, dimension (NB)\n*          The scalar factors of the elementary reflectors. See Further\n*          Details.\n*\n*  T       (output) COMPLEX*16 array, dimension (LDT,NB)\n*          The upper triangular matrix T.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T.  LDT >= NB.\n*\n*  Y       (output) COMPLEX*16 array, dimension (LDY,NB)\n*          The n-by-nb matrix Y.\n*\n*  LDY     (input) INTEGER\n*          The leading dimension of the array Y. LDY >= N.\n*\n\n*  Further Details\n*  ===============\n*\n*  The matrix Q is represented as a product of nb elementary reflectors\n*\n*     Q = H(1) H(2) . . . H(nb).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - tau * v * v'\n*\n*  where tau is a complex scalar, and v is a complex vector with\n*  v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n*  A(i+k+1:n,i), and tau in TAU(i).\n*\n*  The elements of the vectors v together form the (n-k+1)-by-nb matrix\n*  V which is needed, with T and Y, to apply the transformation to the\n*  unreduced part of the matrix, using an update of the form:\n*  A := (I - V*T*V') * (A - Y*V').\n*\n*  The contents of A on exit are illustrated by the following example\n*  with n = 7, k = 3 and nb = 2:\n*\n*     ( a   a   a   a   a )\n*     ( a   a   a   a   a )\n*     ( a   a   a   a   a )\n*     ( h   h   a   a   a )\n*     ( v1  h   a   a   a )\n*     ( v1  v2  a   a   a )\n*     ( v1  v2  a   a   a )\n*\n*  where a denotes an element of the original matrix A, h denotes a\n*  modified element of the upper Hessenberg matrix H, and vi denotes an\n*  element of the vector defining H(i).\n*\n*  This subroutine is a slight modification of LAPACK-3.0's DLAHRD\n*  incorporating improvements proposed by Quintana-Orti and Van de\n*  Gejin. Note that the entries of A(1:K,2:NB) differ from those\n*  returned by the original LAPACK-3.0's DLAHRD routine. (This\n*  subroutine is not backward compatible with LAPACK-3.0's DLAHRD.)\n*\n*  References\n*  ==========\n*\n*  Gregorio Quintana-Orti and Robert van de Geijn, \"Improving the\n*  performance of reduction to Hessenberg form,\" ACM Transactions on\n*  Mathematical Software, 32(2):180-194, June 2006.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, t, y, a = NumRu::Lapack.zlahr2( n, k, nb, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_n = argv[0];
  rblapack_k = argv[1];
  rblapack_nb = argv[2];
  rblapack_a = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  nb = NUM2INT(rblapack_nb);
  ldy = n;
  k = NUM2INT(rblapack_k);
  ldt = nb;
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != (n-k+1))
    rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", n-k+1);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,nb);
    rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = MAX(1,nb);
    rblapack_t = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  t = NA_PTR_TYPE(rblapack_t, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldy;
    shape[1] = MAX(1,nb);
    rblapack_y = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  y = NA_PTR_TYPE(rblapack_y, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n-k+1;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zlahr2_(&n, &k, &nb, a, &lda, tau, t, &ldt, y, &ldy);

  return rb_ary_new3(4, rblapack_tau, rblapack_t, rblapack_y, rblapack_a);
}

void
init_lapack_zlahr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlahr2", rblapack_zlahr2, -1);
}
ruby-lapack-1.7.2/ext/cla_gbrpvgrw.c0000644000175000017500000001176212502221026017211 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real cla_gbrpvgrw_(integer* n, integer* kl, integer* ku, integer* ncols, complex* ab, integer* ldab, complex* afb, integer* ldafb);


static VALUE
rblapack_cla_gbrpvgrw(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ncols;
  integer ncols; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_afb;
  complex *afb; 
  VALUE rblapack___out__;
  real __out__; 

  integer ldab;
  integer n;
  integer ldafb;

  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  __out__ = NumRu::Lapack.cla_gbrpvgrw( kl, ku, ncols, ab, afb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL FUNCTION CLA_GBRPVGRW( N, KL, KU, NCOLS, AB, LDAB, AFB, LDAFB )\n\n*  Purpose\n*  =======\n*\n*  CLA_GBRPVGRW computes the reciprocal pivot growth factor\n*  norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n*  much less than 1, the stability of the LU factorization of the\n*  (equilibrated) matrix A could be poor. This also means that the\n*  solution X, estimated condition numbers, and error bounds could be\n*  unreliable.\n*\n\n*  Arguments\n*  =========\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     KL      (input) INTEGER\n*     The number of subdiagonals within the band of A.  KL >= 0.\n*\n*     KU      (input) INTEGER\n*     The number of superdiagonals within the band of A.  KU >= 0.\n*\n*     NCOLS   (input) INTEGER\n*     The number of columns of the matrix A.  NCOLS >= 0.\n*\n*     AB      (input) COMPLEX array, dimension (LDAB,N)\n*     On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n*     The j-th column of A is stored in the j-th column of the\n*     array AB as follows:\n*     AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n*     LDAB    (input) INTEGER\n*     The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*     AFB     (input) COMPLEX array, dimension (LDAFB,N)\n*     Details of the LU factorization of the band matrix A, as\n*     computed by CGBTRF.  U is stored as an upper triangular\n*     band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n*     and the multipliers used during the factorization are stored\n*     in rows KL+KU+2 to 2*KL+KU+1.\n*\n*     LDAFB   (input) INTEGER\n*     The leading dimension of the array AFB.  LDAFB >= 2*KL+KU+1.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J, KD\n      REAL               AMAX, UMAX, RPVGRW\n      COMPLEX            ZDUM\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX, MIN, REAL, AIMAG\n*     ..\n*     .. Statement Functions ..\n      REAL               CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.cla_gbrpvgrw( kl, ku, ncols, ab, afb, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_kl = argv[0];
  rblapack_ku = argv[1];
  rblapack_ncols = argv[2];
  rblapack_ab = argv[3];
  rblapack_afb = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  kl = NUM2INT(rblapack_kl);
  ncols = NUM2INT(rblapack_ncols);
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
  ldafb = NA_SHAPE0(rblapack_afb);
  n = NA_SHAPE1(rblapack_afb);
  if (NA_TYPE(rblapack_afb) != NA_SCOMPLEX)
    rblapack_afb = na_change_type(rblapack_afb, NA_SCOMPLEX);
  afb = NA_PTR_TYPE(rblapack_afb, complex*);
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);

  __out__ = cla_gbrpvgrw_(&n, &kl, &ku, &ncols, ab, &ldab, afb, &ldafb);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_cla_gbrpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cla_gbrpvgrw", rblapack_cla_gbrpvgrw, -1);
}
ruby-lapack-1.7.2/ext/dormlq.c0000644000175000017500000001621012502221020016013 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dormlq_(char* side, char* trans, integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* c, integer* ldc, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dormlq(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublereal *c_out__;

  integer lda;
  integer m;
  integer k;
  integer ldc;
  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  work, info, c = NumRu::Lapack.dormlq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DORMLQ overwrites the general real M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'T':      Q**T * C       C * Q**T\n*\n*  where Q is a real orthogonal matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(k) . . . H(2) H(1)\n*\n*  as returned by DGELQF. Q is of order M if SIDE = 'L' and of order N\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**T from the Left;\n*          = 'R': apply Q or Q**T from the Right.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'T':  Transpose, apply Q**T.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension\n*                               (LDA,M) if SIDE = 'L',\n*                               (LDA,N) if SIDE = 'R'\n*          The i-th row must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          DGELQF in the first k rows of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,K).\n*\n*  TAU     (input) DOUBLE PRECISION array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by DGELQF.\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M).\n*          For optimum performance LWORK >= N*NB if SIDE = 'L', and\n*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n*          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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.dormlq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_a = argv[2];
  rblapack_tau = argv[3];
  rblapack_c = argv[4];
  if (argc == 6) {
    rblapack_lwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = 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*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  dormlq_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_dormlq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dormlq", rblapack_dormlq, -1);
}
ruby-lapack-1.7.2/ext/zlatdf.c0000644000175000017500000002024712502221014016011 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlatdf_(integer* ijob, integer* n, doublecomplex* z, integer* ldz, doublecomplex* rhs, doublereal* rdsum, doublereal* rdscal, integer* ipiv, integer* jpiv);


static VALUE
rblapack_zlatdf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ijob;
  integer ijob; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_rhs;
  doublecomplex *rhs; 
  VALUE rblapack_rdsum;
  doublereal rdsum; 
  VALUE rblapack_rdscal;
  doublereal rdscal; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_jpiv;
  integer *jpiv; 
  VALUE rblapack_rhs_out__;
  doublecomplex *rhs_out__;

  integer ldz;
  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  rhs, rdsum, rdscal = NumRu::Lapack.zlatdf( ijob, z, rhs, rdsum, rdscal, ipiv, jpiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, JPIV )\n\n*  Purpose\n*  =======\n*\n*  ZLATDF computes the contribution to the reciprocal Dif-estimate\n*  by solving for x in Z * x = b, where b is chosen such that the norm\n*  of x is as large as possible. It is assumed that LU decomposition\n*  of Z has been computed by ZGETC2. On entry RHS = f holds the\n*  contribution from earlier solved sub-systems, and on return RHS = x.\n*\n*  The factorization of Z returned by ZGETC2 has the form\n*  Z = P * L * U * Q, where P and Q are permutation matrices. L is lower\n*  triangular with unit diagonal elements and U is upper triangular.\n*\n\n*  Arguments\n*  =========\n*\n*  IJOB    (input) INTEGER\n*          IJOB = 2: First compute an approximative null-vector e\n*              of Z using ZGECON, e is normalized and solve for\n*              Zx = +-e - f with the sign giving the greater value of\n*              2-norm(x).  About 5 times as expensive as Default.\n*          IJOB .ne. 2: Local look ahead strategy where\n*              all entries of the r.h.s. b is choosen as either +1 or\n*              -1.  Default.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Z.\n*\n*  Z       (input) DOUBLE PRECISION array, dimension (LDZ, N)\n*          On entry, the LU part of the factorization of the n-by-n\n*          matrix Z computed by ZGETC2:  Z = P * L * U * Q\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDA >= max(1, N).\n*\n*  RHS     (input/output) DOUBLE PRECISION array, dimension (N).\n*          On entry, RHS contains contributions from other subsystems.\n*          On exit, RHS contains the solution of the subsystem with\n*          entries according to the value of IJOB (see above).\n*\n*  RDSUM   (input/output) DOUBLE PRECISION\n*          On entry, the sum of squares of computed contributions to\n*          the Dif-estimate under computation by ZTGSYL, where the\n*          scaling factor RDSCAL (see below) has been factored out.\n*          On exit, the corresponding sum of squares updated with the\n*          contributions from the current sub-system.\n*          If TRANS = 'T' RDSUM is not touched.\n*          NOTE: RDSUM only makes sense when ZTGSY2 is called by CTGSYL.\n*\n*  RDSCAL  (input/output) DOUBLE PRECISION\n*          On entry, scaling factor used to prevent overflow in RDSUM.\n*          On exit, RDSCAL is updated w.r.t. the current contributions\n*          in RDSUM.\n*          If TRANS = 'T', RDSCAL is not touched.\n*          NOTE: RDSCAL only makes sense when ZTGSY2 is called by\n*          ZTGSYL.\n*\n*  IPIV    (input) INTEGER array, dimension (N).\n*          The pivot indices; for 1 <= i <= N, row i of the\n*          matrix has been interchanged with row IPIV(i).\n*\n*  JPIV    (input) INTEGER array, dimension (N).\n*          The pivot indices; for 1 <= j <= N, column j of the\n*          matrix has been interchanged with column JPIV(j).\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  This routine is a further developed implementation of algorithm\n*  BSOLVE in [1] using complete pivoting in the LU factorization.\n*\n*   [1]   Bo Kagstrom and Lars Westin,\n*         Generalized Schur Methods with Condition Estimators for\n*         Solving the Generalized Sylvester Equation, IEEE Transactions\n*         on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.\n*\n*   [2]   Peter Poromaa,\n*         On Efficient and Robust Estimators for the Separation\n*         between two Regular Matrix Pairs with Applications in\n*         Condition Estimation. Report UMINF-95.05, Department of\n*         Computing Science, Umea University, S-901 87 Umea, Sweden,\n*         1995.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rhs, rdsum, rdscal = NumRu::Lapack.zlatdf( ijob, z, rhs, rdsum, rdscal, ipiv, jpiv, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_ijob = argv[0];
  rblapack_z = argv[1];
  rblapack_rhs = argv[2];
  rblapack_rdsum = argv[3];
  rblapack_rdscal = argv[4];
  rblapack_ipiv = argv[5];
  rblapack_jpiv = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  ijob = NUM2INT(rblapack_ijob);
  if (!NA_IsNArray(rblapack_rhs))
    rb_raise(rb_eArgError, "rhs (3th argument) must be NArray");
  if (NA_RANK(rblapack_rhs) != 1)
    rb_raise(rb_eArgError, "rank of rhs (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_rhs);
  if (NA_TYPE(rblapack_rhs) != NA_DCOMPLEX)
    rblapack_rhs = na_change_type(rblapack_rhs, NA_DCOMPLEX);
  rhs = NA_PTR_TYPE(rblapack_rhs, doublecomplex*);
  rdscal = NUM2DBL(rblapack_rdscal);
  if (!NA_IsNArray(rblapack_jpiv))
    rb_raise(rb_eArgError, "jpiv (7th argument) must be NArray");
  if (NA_RANK(rblapack_jpiv) != 1)
    rb_raise(rb_eArgError, "rank of jpiv (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_jpiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of jpiv must be the same as shape 0 of rhs");
  if (NA_TYPE(rblapack_jpiv) != NA_LINT)
    rblapack_jpiv = na_change_type(rblapack_jpiv, NA_LINT);
  jpiv = NA_PTR_TYPE(rblapack_jpiv, integer*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (2th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (2th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  if (NA_SHAPE1(rblapack_z) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 0 of rhs");
  if (NA_TYPE(rblapack_z) != NA_DCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of rhs");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  rdsum = NUM2DBL(rblapack_rdsum);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rhs_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  rhs_out__ = NA_PTR_TYPE(rblapack_rhs_out__, doublecomplex*);
  MEMCPY(rhs_out__, rhs, doublecomplex, NA_TOTAL(rblapack_rhs));
  rblapack_rhs = rblapack_rhs_out__;
  rhs = rhs_out__;

  zlatdf_(&ijob, &n, z, &ldz, rhs, &rdsum, &rdscal, ipiv, jpiv);

  rblapack_rdsum = rb_float_new((double)rdsum);
  rblapack_rdscal = rb_float_new((double)rdscal);
  return rb_ary_new3(3, rblapack_rhs, rblapack_rdsum, rblapack_rdscal);
}

void
init_lapack_zlatdf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlatdf", rblapack_zlatdf, -1);
}
ruby-lapack-1.7.2/ext/ssysv.c0000644000175000017500000002022012502221012015701 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssysv_(char* uplo, integer* n, integer* nrhs, real* a, integer* lda, integer* ipiv, real* b, integer* ldb, real* work, integer* lwork, integer* info);


static VALUE
rblapack_ssysv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_b_out__;
  real *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  ipiv, work, info, a, b = NumRu::Lapack.ssysv( uplo, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSYSV computes the solution to a real system of linear equations\n*     A * X = B,\n*  where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n*  matrices.\n*\n*  The diagonal pivoting method is used to factor A as\n*     A = U * D * U**T,  if UPLO = 'U', or\n*     A = L * D * L**T,  if UPLO = 'L',\n*  where U (or L) is a product of permutation and unit upper (lower)\n*  triangular matrices, and D is symmetric and block diagonal with \n*  1-by-1 and 2-by-2 diagonal blocks.  The factored form of A is then\n*  used to solve the system of equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the block diagonal matrix D and the\n*          multipliers used to obtain the factor U or L from the\n*          factorization A = U*D*U**T or A = L*D*L**T as computed by\n*          SSYTRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D, as\n*          determined by SSYTRF.  If IPIV(k) > 0, then rows and columns\n*          k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n*          diagonal block.  If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n*          then rows and columns k-1 and -IPIV(k) were interchanged and\n*          D(k-1:k,k-1:k) is a 2-by-2 diagonal block.  If UPLO = 'L' and\n*          IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n*          -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n*          diagonal block.\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  WORK    (workspace/output) REAL array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of WORK.  LWORK >= 1, and for best performance\n*          LWORK >= max(1,N*NB), where NB is the optimal blocksize for\n*          SSYTRF.\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, D(i,i) is exactly zero.  The factorization\n*               has been completed, but the block diagonal matrix D is\n*               exactly singular, so the solution could not be computed.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY\n      INTEGER            LWKOPT, NB\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            ILAENV\n      EXTERNAL           ILAENV, LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SSYTRF, SSYTRS2, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, work, info, a, b = NumRu::Lapack.ssysv( uplo, 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_uplo = 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;
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  ssysv_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_ipiv, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_ssysv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssysv", rblapack_ssysv, -1);
}
ruby-lapack-1.7.2/ext/zlaqr4.c0000644000175000017500000002557312502221023015751 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlaqr4_(logical* wantt, logical* wantz, integer* n, integer* ilo, integer* ihi, doublecomplex* h, integer* ldh, doublecomplex* w, integer* iloz, integer* ihiz, doublecomplex* z, integer* ldz, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zlaqr4(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantt;
  logical wantt; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_h;
  doublecomplex *h; 
  VALUE rblapack_iloz;
  integer iloz; 
  VALUE rblapack_ihiz;
  integer ihiz; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_w;
  doublecomplex *w; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_h_out__;
  doublecomplex *h_out__;
  VALUE rblapack_z_out__;
  doublecomplex *z_out__;

  integer ldh;
  integer n;
  integer ldz;
  integer ihi;

  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  w, work, info, h, z = NumRu::Lapack.zlaqr4( wantt, wantz, ilo, h, iloz, ihiz, z, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     ZLAQR4 computes the eigenvalues of a Hessenberg matrix H\n*     and, optionally, the matrices T and Z from the Schur decomposition\n*     H = Z T Z**H, where T is an upper triangular matrix (the\n*     Schur form), and Z is the unitary matrix of Schur vectors.\n*\n*     Optionally Z may be postmultiplied into an input unitary\n*     matrix Q so that this routine can give the Schur factorization\n*     of a matrix A which has been reduced to the Hessenberg form H\n*     by the unitary matrix Q:  A = Q*H*Q**H = (QZ)*H*(QZ)**H.\n*\n\n*     Arguments\n*     =========\n*\n*     WANTT   (input) LOGICAL\n*          = .TRUE. : the full Schur form T is required;\n*          = .FALSE.: only eigenvalues are required.\n*\n*     WANTZ   (input) LOGICAL\n*          = .TRUE. : the matrix of Schur vectors Z is required;\n*          = .FALSE.: Schur vectors are not required.\n*\n*     N     (input) INTEGER\n*           The order of the matrix H.  N .GE. 0.\n*\n*     ILO   (input) INTEGER\n*     IHI   (input) INTEGER\n*           It is assumed that H is already upper triangular in rows\n*           and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n*           H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n*           previous call to ZGEBAL, and then passed to ZGEHRD when the\n*           matrix output by ZGEBAL is reduced to Hessenberg form.\n*           Otherwise, ILO and IHI should be set to 1 and N,\n*           respectively.  If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n*           If N = 0, then ILO = 1 and IHI = 0.\n*\n*     H     (input/output) COMPLEX*16 array, dimension (LDH,N)\n*           On entry, the upper Hessenberg matrix H.\n*           On exit, if INFO = 0 and WANTT is .TRUE., then H\n*           contains the upper triangular matrix T from the Schur\n*           decomposition (the Schur form). If INFO = 0 and WANT is\n*           .FALSE., then the contents of H are unspecified on exit.\n*           (The output value of H when INFO.GT.0 is given under the\n*           description of INFO below.)\n*\n*           This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n*           j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n*\n*     LDH   (input) INTEGER\n*           The leading dimension of the array H. LDH .GE. max(1,N).\n*\n*     W        (output) COMPLEX*16 array, dimension (N)\n*           The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored\n*           in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are\n*           stored in the same order as on the diagonal of the Schur\n*           form returned in H, with W(i) = H(i,i).\n*\n*     Z     (input/output) COMPLEX*16 array, dimension (LDZ,IHI)\n*           If WANTZ is .FALSE., then Z is not referenced.\n*           If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n*           replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n*           orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n*           (The output value of Z when INFO.GT.0 is given under\n*           the description of INFO below.)\n*\n*     LDZ   (input) INTEGER\n*           The leading dimension of the array Z.  if WANTZ is .TRUE.\n*           then LDZ.GE.MAX(1,IHIZ).  Otherwize, LDZ.GE.1.\n*\n*     WORK  (workspace/output) COMPLEX*16 array, dimension LWORK\n*           On exit, if LWORK = -1, WORK(1) returns an estimate of\n*           the optimal value for LWORK.\n*\n*     LWORK (input) INTEGER\n*           The dimension of the array WORK.  LWORK .GE. max(1,N)\n*           is sufficient, but LWORK typically as large as 6*N may\n*           be required for optimal performance.  A workspace query\n*           to determine the optimal workspace size is recommended.\n*\n*           If LWORK = -1, then ZLAQR4 does a workspace query.\n*           In this case, ZLAQR4 checks the input parameters and\n*           estimates the optimal workspace size for the given\n*           values of N, ILO and IHI.  The estimate is returned\n*           in WORK(1).  No error message related to LWORK is\n*           issued by XERBLA.  Neither H nor Z are accessed.\n*\n*\n*     INFO  (output) INTEGER\n*             =  0:  successful exit\n*           .GT. 0:  if INFO = i, ZLAQR4 failed to compute all of\n*                the eigenvalues.  Elements 1:ilo-1 and i+1:n of WR\n*                and WI contain those eigenvalues which have been\n*                successfully computed.  (Failures are rare.)\n*\n*                If INFO .GT. 0 and WANT is .FALSE., then on exit,\n*                the remaining unconverged eigenvalues are the eigen-\n*                values of the upper Hessenberg matrix rows and\n*                columns ILO through INFO of the final, output\n*                value of H.\n*\n*                If INFO .GT. 0 and WANTT is .TRUE., then on exit\n*\n*           (*)  (initial value of H)*U  = U*(final value of H)\n*\n*                where U is a unitary matrix.  The final\n*                value of  H is upper Hessenberg and triangular in\n*                rows and columns INFO+1 through IHI.\n*\n*                If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n*\n*                  (final value of Z(ILO:IHI,ILOZ:IHIZ)\n*                   =  (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n*\n*                where U is the unitary matrix in (*) (regard-\n*                less of the value of WANTT.)\n*\n*                If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n*                accessed.\n*\n\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n*     References:\n*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n*       Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n*       Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n*       929--947, 2002.\n*\n*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n*       Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n*       of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n*     ================================================================\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, work, info, h, z = NumRu::Lapack.zlaqr4( wantt, wantz, ilo, h, iloz, ihiz, z, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_wantt = argv[0];
  rblapack_wantz = argv[1];
  rblapack_ilo = argv[2];
  rblapack_h = argv[3];
  rblapack_iloz = argv[4];
  rblapack_ihiz = argv[5];
  rblapack_z = argv[6];
  if (argc == 8) {
    rblapack_lwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  wantt = (rblapack_wantt == Qtrue);
  ilo = NUM2INT(rblapack_ilo);
  iloz = NUM2INT(rblapack_iloz);
  wantz = (rblapack_wantz == Qtrue);
  ihiz = NUM2INT(rblapack_ihiz);
  ldz = wantz ? MAX(1,ihiz) : 1;
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (4th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (4th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_DCOMPLEX)
    rblapack_h = na_change_type(rblapack_h, NA_DCOMPLEX);
  h = NA_PTR_TYPE(rblapack_h, doublecomplex*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (7th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_z) != ldz)
    rb_raise(rb_eRuntimeError, "shape 0 of z must be wantz ? MAX(1,ihiz) : 1");
  ihi = NA_SHAPE1(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_DCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublecomplex*);
  MEMCPY(h_out__, h, doublecomplex, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = ihi;
    rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublecomplex*);
  MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  zlaqr4_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, w, &iloz, &ihiz, z, &ldz, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_w, rblapack_work, rblapack_info, rblapack_h, rblapack_z);
}

void
init_lapack_zlaqr4(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlaqr4", rblapack_zlaqr4, -1);
}
ruby-lapack-1.7.2/ext/zggsvd.c0000644000175000017500000003313012502221014016024 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zggsvd_(char* jobu, char* jobv, char* jobq, integer* m, integer* n, integer* p, integer* k, integer* l, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublereal* alpha, doublereal* beta, doublecomplex* u, integer* ldu, doublecomplex* v, integer* ldv, doublecomplex* q, integer* ldq, doublecomplex* work, doublereal* rwork, integer* iwork, integer* info);


static VALUE
rblapack_zggsvd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobu;
  char jobu; 
  VALUE rblapack_jobv;
  char jobv; 
  VALUE rblapack_jobq;
  char jobq; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_alpha;
  doublereal *alpha; 
  VALUE rblapack_beta;
  doublereal *beta; 
  VALUE rblapack_u;
  doublecomplex *u; 
  VALUE rblapack_v;
  doublecomplex *v; 
  VALUE rblapack_q;
  doublecomplex *q; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer lda;
  integer n;
  integer ldb;
  integer ldu;
  integer m;
  integer ldv;
  integer p;
  integer ldq;

  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  k, l, alpha, beta, u, v, q, iwork, info, a, b = NumRu::Lapack.zggsvd( jobu, jobv, jobq, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, RWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGGSVD computes the generalized singular value decomposition (GSVD)\n*  of an M-by-N complex matrix A and P-by-N complex matrix B:\n*\n*        U'*A*Q = D1*( 0 R ),    V'*B*Q = D2*( 0 R )\n*\n*  where U, V and Q are unitary matrices, and Z' means the conjugate\n*  transpose of Z.  Let K+L = the effective numerical rank of the\n*  matrix (A',B')', then R is a (K+L)-by-(K+L) nonsingular upper\n*  triangular matrix, D1 and D2 are M-by-(K+L) and P-by-(K+L) \"diagonal\"\n*  matrices and of the following structures, respectively:\n*\n*  If M-K-L >= 0,\n*\n*                      K  L\n*         D1 =     K ( I  0 )\n*                  L ( 0  C )\n*              M-K-L ( 0  0 )\n*\n*                    K  L\n*         D2 =   L ( 0  S )\n*              P-L ( 0  0 )\n*\n*                  N-K-L  K    L\n*    ( 0 R ) = K (  0   R11  R12 )\n*              L (  0    0   R22 )\n*  where\n*\n*    C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n*    S = diag( BETA(K+1),  ... , BETA(K+L) ),\n*    C**2 + S**2 = I.\n*\n*    R is stored in A(1:K+L,N-K-L+1:N) on exit.\n*\n*  If M-K-L < 0,\n*\n*                    K M-K K+L-M\n*         D1 =   K ( I  0    0   )\n*              M-K ( 0  C    0   )\n*\n*                      K M-K K+L-M\n*         D2 =   M-K ( 0  S    0  )\n*              K+L-M ( 0  0    I  )\n*                P-L ( 0  0    0  )\n*\n*                     N-K-L  K   M-K  K+L-M\n*    ( 0 R ) =     K ( 0    R11  R12  R13  )\n*                M-K ( 0     0   R22  R23  )\n*              K+L-M ( 0     0    0   R33  )\n*\n*  where\n*\n*    C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n*    S = diag( BETA(K+1),  ... , BETA(M) ),\n*    C**2 + S**2 = I.\n*\n*    (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored\n*    ( 0  R22 R23 )\n*    in B(M-K+1:L,N+M-K-L+1:N) on exit.\n*\n*  The routine computes C, S, R, and optionally the unitary\n*  transformation matrices U, V and Q.\n*\n*  In particular, if B is an N-by-N nonsingular matrix, then the GSVD of\n*  A and B implicitly gives the SVD of A*inv(B):\n*                       A*inv(B) = U*(D1*inv(D2))*V'.\n*  If ( A',B')' has orthnormal columns, then the GSVD of A and B is also\n*  equal to the CS decomposition of A and B. Furthermore, the GSVD can\n*  be used to derive the solution of the eigenvalue problem:\n*                       A'*A x = lambda* B'*B x.\n*  In some literature, the GSVD of A and B is presented in the form\n*                   U'*A*X = ( 0 D1 ),   V'*B*X = ( 0 D2 )\n*  where U and V are orthogonal and X is nonsingular, and D1 and D2 are\n*  ``diagonal''.  The former GSVD form can be converted to the latter\n*  form by taking the nonsingular matrix X as\n*\n*                        X = Q*(  I   0    )\n*                              (  0 inv(R) )\n*\n\n*  Arguments\n*  =========\n*\n*  JOBU    (input) CHARACTER*1\n*          = 'U':  Unitary matrix U is computed;\n*          = 'N':  U is not computed.\n*\n*  JOBV    (input) CHARACTER*1\n*          = 'V':  Unitary matrix V is computed;\n*          = 'N':  V is not computed.\n*\n*  JOBQ    (input) CHARACTER*1\n*          = 'Q':  Unitary matrix Q is computed;\n*          = 'N':  Q is not computed.\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 matrices A and B.  N >= 0.\n*\n*  P       (input) INTEGER\n*          The number of rows of the matrix B.  P >= 0.\n*\n*  K       (output) INTEGER\n*  L       (output) INTEGER\n*          On exit, K and L specify the dimension of the subblocks\n*          described in Purpose.\n*          K + L = effective numerical rank of (A',B')'.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, A contains the triangular matrix R, or part of R.\n*          See Purpose for details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,N)\n*          On entry, the P-by-N matrix B.\n*          On exit, B contains part of the triangular matrix R if\n*          M-K-L < 0.  See Purpose for details.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,P).\n*\n*  ALPHA   (output) DOUBLE PRECISION array, dimension (N)\n*  BETA    (output) DOUBLE PRECISION array, dimension (N)\n*          On exit, ALPHA and BETA contain the generalized singular\n*          value pairs of A and B;\n*            ALPHA(1:K) = 1,\n*            BETA(1:K)  = 0,\n*          and if M-K-L >= 0,\n*            ALPHA(K+1:K+L) = C,\n*            BETA(K+1:K+L)  = S,\n*          or if M-K-L < 0,\n*            ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0\n*            BETA(K+1:M) = S, BETA(M+1:K+L) = 1\n*          and\n*            ALPHA(K+L+1:N) = 0\n*            BETA(K+L+1:N)  = 0\n*\n*  U       (output) COMPLEX*16 array, dimension (LDU,M)\n*          If JOBU = 'U', U contains the M-by-M unitary matrix U.\n*          If JOBU = 'N', U is not referenced.\n*\n*  LDU     (input) INTEGER\n*          The leading dimension of the array U. LDU >= max(1,M) if\n*          JOBU = 'U'; LDU >= 1 otherwise.\n*\n*  V       (output) COMPLEX*16 array, dimension (LDV,P)\n*          If JOBV = 'V', V contains the P-by-P unitary matrix V.\n*          If JOBV = 'N', V is not referenced.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V. LDV >= max(1,P) if\n*          JOBV = 'V'; LDV >= 1 otherwise.\n*\n*  Q       (output) COMPLEX*16 array, dimension (LDQ,N)\n*          If JOBQ = 'Q', Q contains the N-by-N unitary matrix Q.\n*          If JOBQ = 'N', Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q. LDQ >= max(1,N) if\n*          JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (max(3*N,M,P)+N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (N)\n*          On exit, IWORK stores the sorting information. More\n*          precisely, the following loop will sort ALPHA\n*             for I = K+1, min(M,K+L)\n*                 swap ALPHA(I) and ALPHA(IWORK(I))\n*             endfor\n*          such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N).\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 = 1, the Jacobi-type procedure failed to\n*                converge.  For further details, see subroutine ZTGSJA.\n*\n*  Internal Parameters\n*  ===================\n*\n*  TOLA    DOUBLE PRECISION\n*  TOLB    DOUBLE PRECISION\n*          TOLA and TOLB are the thresholds to determine the effective\n*          rank of (A',B')'. Generally, they are set to\n*                   TOLA = MAX(M,N)*norm(A)*MAZHEPS,\n*                   TOLB = MAX(P,N)*norm(B)*MAZHEPS.\n*          The size of TOLA and TOLB may affect the size of backward\n*          errors of the decomposition.\n*\n\n*  Further Details\n*  ===============\n*\n*  2-96 Based on modifications by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            WANTQ, WANTU, WANTV\n      INTEGER            I, IBND, ISUB, J, NCYCLE\n      DOUBLE PRECISION   ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      DOUBLE PRECISION   DLAMCH, ZLANGE\n      EXTERNAL           LSAME, DLAMCH, ZLANGE\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DCOPY, XERBLA, ZGGSVP, ZTGSJA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  k, l, alpha, beta, u, v, q, iwork, info, a, b = NumRu::Lapack.zggsvd( jobu, jobv, jobq, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_jobu = argv[0];
  rblapack_jobv = argv[1];
  rblapack_jobq = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobu = StringValueCStr(rblapack_jobu)[0];
  jobq = StringValueCStr(rblapack_jobq)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  p = ldb;
  jobv = StringValueCStr(rblapack_jobv)[0];
  ldv = lsame_(&jobv,"V") ? MAX(1,p) : 1;
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  ldq = lsame_(&jobq,"Q") ? MAX(1,n) : 1;
  m = lda;
  ldu = lsame_(&jobu,"U") ? MAX(1,m) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alpha = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  alpha = NA_PTR_TYPE(rblapack_alpha, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = m;
    rblapack_u = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  u = NA_PTR_TYPE(rblapack_u, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = p;
    rblapack_v = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  v = NA_PTR_TYPE(rblapack_v, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(doublecomplex, (MAX(3*n,m)*(p)+n));
  rwork = ALLOC_N(doublereal, (2*n));

  zggsvd_(&jobu, &jobv, &jobq, &m, &n, &p, &k, &l, a, &lda, b, &ldb, alpha, beta, u, &ldu, v, &ldv, q, &ldq, work, rwork, iwork, &info);

  free(work);
  free(rwork);
  rblapack_k = INT2NUM(k);
  rblapack_l = INT2NUM(l);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(11, rblapack_k, rblapack_l, rblapack_alpha, rblapack_beta, rblapack_u, rblapack_v, rblapack_q, rblapack_iwork, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_zggsvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zggsvd", rblapack_zggsvd, -1);
}
ruby-lapack-1.7.2/ext/dla_gbrcond.c0000644000175000017500000002127412502221016016766 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal dla_gbrcond_(char* trans, integer* n, integer* kl, integer* ku, doublereal* ab, integer* ldab, doublereal* afb, integer* ldafb, integer* ipiv, integer* cmode, doublereal* c, integer* info, doublereal* work, integer* iwork);


static VALUE
rblapack_dla_gbrcond(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_afb;
  doublereal *afb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_cmode;
  integer cmode; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack___out__;
  doublereal __out__; 

  integer ldab;
  integer n;
  integer ldafb;

  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  info, __out__ = NumRu::Lapack.dla_gbrcond( trans, kl, ku, ab, afb, ipiv, cmode, c, work, iwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION DLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, AFB, LDAFB, IPIV, CMODE, C, INFO, WORK, IWORK )\n\n*  Purpose\n*  =======\n*\n*     DLA_GBRCOND Estimates the Skeel condition number of  op(A) * op2(C)\n*     where op2 is determined by CMODE as follows\n*     CMODE =  1    op2(C) = C\n*     CMODE =  0    op2(C) = I\n*     CMODE = -1    op2(C) = inv(C)\n*     The Skeel condition number  cond(A) = norminf( |inv(A)||A| )\n*     is computed by computing scaling factors R such that\n*     diag(R)*A*op2(C) is row equilibrated and computing the standard\n*     infinity-norm condition number.\n*\n\n*  Arguments\n*  =========\n*\n*     TRANS   (input) CHARACTER*1\n*     Specifies the form of the system of equations:\n*       = 'N':  A * X = B     (No transpose)\n*       = 'T':  A**T * X = B  (Transpose)\n*       = 'C':  A**H * X = B  (Conjugate Transpose = Transpose)\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     KL      (input) INTEGER\n*     The number of subdiagonals within the band of A.  KL >= 0.\n*\n*     KU      (input) INTEGER\n*     The number of superdiagonals within the band of A.  KU >= 0.\n*\n*     AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)\n*     On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n*     The j-th column of A is stored in the j-th column of the\n*     array AB as follows:\n*     AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n*     LDAB    (input) INTEGER\n*     The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*     AFB     (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n*     Details of the LU factorization of the band matrix A, as\n*     computed by DGBTRF.  U is stored as an upper triangular\n*     band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n*     and the multipliers used during the factorization are stored\n*     in rows KL+KU+2 to 2*KL+KU+1.\n*\n*     LDAFB   (input) INTEGER\n*     The leading dimension of the array AFB.  LDAFB >= 2*KL+KU+1.\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     The pivot indices from the factorization A = P*L*U\n*     as computed by DGBTRF; row i of the matrix was interchanged\n*     with row IPIV(i).\n*\n*     CMODE   (input) INTEGER\n*     Determines op2(C) in the formula op(A) * op2(C) as follows:\n*     CMODE =  1    op2(C) = C\n*     CMODE =  0    op2(C) = I\n*     CMODE = -1    op2(C) = inv(C)\n*\n*     C       (input) DOUBLE PRECISION array, dimension (N)\n*     The vector C in the formula op(A) * op2(C).\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit.\n*     i > 0:  The ith argument is invalid.\n*\n*     WORK    (input) DOUBLE PRECISION array, dimension (5*N).\n*     Workspace.\n*\n*     IWORK   (input) INTEGER array, dimension (N).\n*     Workspace.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            NOTRANS\n      INTEGER            KASE, I, J, KD, KE\n      DOUBLE PRECISION   AINVNM, TMP\n*     ..\n*     .. Local Arrays ..\n      INTEGER            ISAVE( 3 )\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DLACN2, DGBTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, __out__ = NumRu::Lapack.dla_gbrcond( trans, kl, ku, ab, afb, ipiv, cmode, c, work, iwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_trans = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  rblapack_afb = argv[4];
  rblapack_ipiv = argv[5];
  rblapack_cmode = argv[6];
  rblapack_c = argv[7];
  rblapack_work = argv[8];
  rblapack_iwork = argv[9];
  if (argc == 10) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
  ldafb = NA_SHAPE0(rblapack_afb);
  n = NA_SHAPE1(rblapack_afb);
  if (NA_TYPE(rblapack_afb) != NA_DFLOAT)
    rblapack_afb = na_change_type(rblapack_afb, NA_DFLOAT);
  afb = NA_PTR_TYPE(rblapack_afb, doublereal*);
  cmode = NUM2INT(rblapack_cmode);
  if (!NA_IsNArray(rblapack_iwork))
    rb_raise(rb_eArgError, "iwork (10th argument) must be NArray");
  if (NA_RANK(rblapack_iwork) != 1)
    rb_raise(rb_eArgError, "rank of iwork (10th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_iwork) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of iwork must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_iwork) != NA_LINT)
    rblapack_iwork = na_change_type(rblapack_iwork, NA_LINT);
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (8th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  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);
  if (NA_SHAPE0(rblapack_work) != (5*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 5*n);
  if (NA_TYPE(rblapack_work) != NA_DFLOAT)
    rblapack_work = na_change_type(rblapack_work, NA_DFLOAT);
  work = NA_PTR_TYPE(rblapack_work, doublereal*);

  __out__ = dla_gbrcond_(&trans, &n, &kl, &ku, ab, &ldab, afb, &ldafb, ipiv, &cmode, c, &info, work, iwork);

  rblapack_info = INT2NUM(info);
  rblapack___out__ = rb_float_new((double)__out__);
  return rb_ary_new3(2, rblapack_info, rblapack___out__);
}

void
init_lapack_dla_gbrcond(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dla_gbrcond", rblapack_dla_gbrcond, -1);
}
ruby-lapack-1.7.2/ext/spotrs.c0000644000175000017500000001013312502221021016046 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID spotrs_(char* uplo, integer* n, integer* nrhs, real* a, integer* lda, real* b, integer* ldb, integer* info);


static VALUE
rblapack_spotrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  real *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.spotrs( uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPOTRS solves a system of linear equations A*X = B with a symmetric\n*  positive definite matrix A using the Cholesky factorization\n*  A = U**T*U or A = L*L**T computed by SPOTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input) REAL array, dimension (LDA,N)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**T*U or A = L*L**T, as computed by SPOTRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.spotrs( uplo, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_b = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  spotrs_(&uplo, &n, &nrhs, a, &lda, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_spotrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "spotrs", rblapack_spotrs, -1);
}
ruby-lapack-1.7.2/ext/zhpgst.c0000644000175000017500000001171212502221020016036 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhpgst_(integer* itype, char* uplo, integer* n, doublecomplex* ap, doublecomplex* bp, integer* info);


static VALUE
rblapack_zhpgst(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_bp;
  doublecomplex *bp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublecomplex *ap_out__;


  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  info, ap = NumRu::Lapack.zhpgst( itype, uplo, n, ap, bp, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHPGST( ITYPE, UPLO, N, AP, BP, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHPGST reduces a complex Hermitian-definite generalized\n*  eigenproblem to standard form, using packed storage.\n*\n*  If ITYPE = 1, the problem is A*x = lambda*B*x,\n*  and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)\n*\n*  If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n*  B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L.\n*\n*  B must have been previously factorized as U**H*U or L*L**H by ZPPTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);\n*          = 2 or 3: compute U*A*U**H or L**H*A*L.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored and B is factored as\n*                  U**H*U;\n*          = 'L':  Lower triangle of A is stored and B is factored as\n*                  L*L**H.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, if INFO = 0, the transformed matrix, stored in the\n*          same format as A.\n*\n*  BP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          The triangular factor from the Cholesky factorization of B,\n*          stored in the same format as A, as returned by ZPPTRF.\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ap = NumRu::Lapack.zhpgst( itype, uplo, n, ap, bp, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_itype = argv[0];
  rblapack_uplo = argv[1];
  rblapack_n = argv[2];
  rblapack_ap = argv[3];
  rblapack_bp = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  itype = NUM2INT(rblapack_itype);
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_bp))
    rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
  if (NA_RANK(rblapack_bp) != 1)
    rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_bp) != NA_DCOMPLEX)
    rblapack_bp = na_change_type(rblapack_bp, NA_DCOMPLEX);
  bp = NA_PTR_TYPE(rblapack_bp, doublecomplex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
  MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  zhpgst_(&itype, &uplo, &n, ap, bp, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ap);
}

void
init_lapack_zhpgst(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhpgst", rblapack_zhpgst, -1);
}
ruby-lapack-1.7.2/ext/zlanhe.c0000644000175000017500000001116712502221025016011 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal zlanhe_(char* norm, char* uplo, integer* n, doublecomplex* a, integer* lda, doublereal* work);


static VALUE
rblapack_zlanhe(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack___out__;
  doublereal __out__; 
  doublereal *work;

  integer lda;
  integer n;
  integer lwork;

  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  __out__ = NumRu::Lapack.zlanhe( norm, uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK )\n\n*  Purpose\n*  =======\n*\n*  ZLANHE  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  complex hermitian matrix A.\n*\n*  Description\n*  ===========\n*\n*  ZLANHE returns the value\n*\n*     ZLANHE = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in ZLANHE as described\n*          above.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          hermitian matrix A is to be referenced.\n*          = 'U':  Upper triangular part of A is referenced\n*          = 'L':  Lower triangular part of A is referenced\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, ZLANHE is\n*          set to zero.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          The hermitian matrix A.  If UPLO = 'U', the leading n by n\n*          upper triangular part of A contains the upper triangular part\n*          of the matrix A, and the strictly lower triangular part of A\n*          is not referenced.  If UPLO = 'L', the leading n by n lower\n*          triangular part of A contains the lower triangular part of\n*          the matrix A, and the strictly upper triangular part of A is\n*          not referenced. Note that the imaginary parts of the diagonal\n*          elements need not be set and are assumed to be zero.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(N,1).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n*          WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.zlanhe( norm, uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
  work = ALLOC_N(doublereal, (MAX(1,lwork)));

  __out__ = zlanhe_(&norm, &uplo, &n, a, &lda, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_zlanhe(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlanhe", rblapack_zlanhe, -1);
}
ruby-lapack-1.7.2/ext/dlals0.c0000644000175000017500000003163112502221022015702 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlals0_(integer* icompq, integer* nl, integer* nr, integer* sqre, integer* nrhs, doublereal* b, integer* ldb, doublereal* bx, integer* ldbx, integer* perm, integer* givptr, integer* givcol, integer* ldgcol, doublereal* givnum, integer* ldgnum, doublereal* poles, doublereal* difl, doublereal* difr, doublereal* z, integer* k, doublereal* c, doublereal* s, doublereal* work, integer* info);


static VALUE
rblapack_dlals0(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_icompq;
  integer icompq; 
  VALUE rblapack_nl;
  integer nl; 
  VALUE rblapack_nr;
  integer nr; 
  VALUE rblapack_sqre;
  integer sqre; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_perm;
  integer *perm; 
  VALUE rblapack_givptr;
  integer givptr; 
  VALUE rblapack_givcol;
  integer *givcol; 
  VALUE rblapack_givnum;
  doublereal *givnum; 
  VALUE rblapack_poles;
  doublereal *poles; 
  VALUE rblapack_difl;
  doublereal *difl; 
  VALUE rblapack_difr;
  doublereal *difr; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_c;
  doublereal c; 
  VALUE rblapack_s;
  doublereal s; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublereal *b_out__;
  doublereal *bx;
  doublereal *work;

  integer ldb;
  integer nrhs;
  integer n;
  integer ldgcol;
  integer ldgnum;
  integer k;
  integer ldbx;

  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  info, b = NumRu::Lapack.dlals0( icompq, nl, nr, sqre, b, perm, givptr, givcol, givnum, poles, difl, difr, z, c, s, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLALS0 applies back the multiplying factors of either the left or the\n*  right singular vector matrix of a diagonal matrix appended by a row\n*  to the right hand side matrix B in solving the least squares problem\n*  using the divide-and-conquer SVD approach.\n*\n*  For the left singular vector matrix, three types of orthogonal\n*  matrices are involved:\n*\n*  (1L) Givens rotations: the number of such rotations is GIVPTR; the\n*       pairs of columns/rows they were applied to are stored in GIVCOL;\n*       and the C- and S-values of these rotations are stored in GIVNUM.\n*\n*  (2L) Permutation. The (NL+1)-st row of B is to be moved to the first\n*       row, and for J=2:N, PERM(J)-th row of B is to be moved to the\n*       J-th row.\n*\n*  (3L) The left singular vector matrix of the remaining matrix.\n*\n*  For the right singular vector matrix, four types of orthogonal\n*  matrices are involved:\n*\n*  (1R) The right singular vector matrix of the remaining matrix.\n*\n*  (2R) If SQRE = 1, one extra Givens rotation to generate the right\n*       null space.\n*\n*  (3R) The inverse transformation of (2L).\n*\n*  (4R) The inverse transformation of (1L).\n*\n\n*  Arguments\n*  =========\n*\n*  ICOMPQ (input) INTEGER\n*         Specifies whether singular vectors are to be computed in\n*         factored form:\n*         = 0: Left singular vector matrix.\n*         = 1: Right singular vector matrix.\n*\n*  NL     (input) INTEGER\n*         The row dimension of the upper block. NL >= 1.\n*\n*  NR     (input) INTEGER\n*         The row dimension of the lower block. NR >= 1.\n*\n*  SQRE   (input) INTEGER\n*         = 0: the lower block is an NR-by-NR square matrix.\n*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n*         The bidiagonal matrix has row dimension N = NL + NR + 1,\n*         and column dimension M = N + SQRE.\n*\n*  NRHS   (input) INTEGER\n*         The number of columns of B and BX. NRHS must be at least 1.\n*\n*  B      (input/output) DOUBLE PRECISION array, dimension ( LDB, NRHS )\n*         On input, B contains the right hand sides of the least\n*         squares problem in rows 1 through M. On output, B contains\n*         the solution X in rows 1 through N.\n*\n*  LDB    (input) INTEGER\n*         The leading dimension of B. LDB must be at least\n*         max(1,MAX( M, N ) ).\n*\n*  BX     (workspace) DOUBLE PRECISION array, dimension ( LDBX, NRHS )\n*\n*  LDBX   (input) INTEGER\n*         The leading dimension of BX.\n*\n*  PERM   (input) INTEGER array, dimension ( N )\n*         The permutations (from deflation and sorting) applied\n*         to the two blocks.\n*\n*  GIVPTR (input) INTEGER\n*         The number of Givens rotations which took place in this\n*         subproblem.\n*\n*  GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )\n*         Each pair of numbers indicates a pair of rows/columns\n*         involved in a Givens rotation.\n*\n*  LDGCOL (input) INTEGER\n*         The leading dimension of GIVCOL, must be at least N.\n*\n*  GIVNUM (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )\n*         Each number indicates the C or S value used in the\n*         corresponding Givens rotation.\n*\n*  LDGNUM (input) INTEGER\n*         The leading dimension of arrays DIFR, POLES and\n*         GIVNUM, must be at least K.\n*\n*  POLES  (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )\n*         On entry, POLES(1:K, 1) contains the new singular\n*         values obtained from solving the secular equation, and\n*         POLES(1:K, 2) is an array containing the poles in the secular\n*         equation.\n*\n*  DIFL   (input) DOUBLE PRECISION array, dimension ( K ).\n*         On entry, DIFL(I) is the distance between I-th updated\n*         (undeflated) singular value and the I-th (undeflated) old\n*         singular value.\n*\n*  DIFR   (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ).\n*         On entry, DIFR(I, 1) contains the distances between I-th\n*         updated (undeflated) singular value and the I+1-th\n*         (undeflated) old singular value. And DIFR(I, 2) is the\n*         normalizing factor for the I-th right singular vector.\n*\n*  Z      (input) DOUBLE PRECISION array, dimension ( K )\n*         Contain the components of the deflation-adjusted updating row\n*         vector.\n*\n*  K      (input) INTEGER\n*         Contains the dimension of the non-deflated matrix,\n*         This is the order of the related secular equation. 1 <= K <=N.\n*\n*  C      (input) DOUBLE PRECISION\n*         C contains garbage if SQRE =0 and the C-value of a Givens\n*         rotation related to the right null space if SQRE = 1.\n*\n*  S      (input) DOUBLE PRECISION\n*         S contains garbage if SQRE =0 and the S-value of a Givens\n*         rotation related to the right null space if SQRE = 1.\n*\n*  WORK   (workspace) DOUBLE PRECISION array, dimension ( K )\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*  Based on contributions by\n*     Ming Gu and Ren-Cang Li, Computer Science Division, University of\n*       California at Berkeley, USA\n*     Osni Marques, LBNL/NERSC, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.dlals0( icompq, nl, nr, sqre, b, perm, givptr, givcol, givnum, poles, difl, difr, z, c, s, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 15 && argc != 15)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
  rblapack_icompq = argv[0];
  rblapack_nl = argv[1];
  rblapack_nr = argv[2];
  rblapack_sqre = argv[3];
  rblapack_b = argv[4];
  rblapack_perm = argv[5];
  rblapack_givptr = argv[6];
  rblapack_givcol = argv[7];
  rblapack_givnum = argv[8];
  rblapack_poles = argv[9];
  rblapack_difl = argv[10];
  rblapack_difr = argv[11];
  rblapack_z = argv[12];
  rblapack_c = argv[13];
  rblapack_s = argv[14];
  if (argc == 15) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  icompq = NUM2INT(rblapack_icompq);
  nr = NUM2INT(rblapack_nr);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  givptr = NUM2INT(rblapack_givptr);
  if (!NA_IsNArray(rblapack_givnum))
    rb_raise(rb_eArgError, "givnum (9th argument) must be NArray");
  if (NA_RANK(rblapack_givnum) != 2)
    rb_raise(rb_eArgError, "rank of givnum (9th argument) must be %d", 2);
  ldgnum = NA_SHAPE0(rblapack_givnum);
  if (NA_SHAPE1(rblapack_givnum) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", 2);
  if (NA_TYPE(rblapack_givnum) != NA_DFLOAT)
    rblapack_givnum = na_change_type(rblapack_givnum, NA_DFLOAT);
  givnum = NA_PTR_TYPE(rblapack_givnum, doublereal*);
  if (!NA_IsNArray(rblapack_difl))
    rb_raise(rb_eArgError, "difl (11th argument) must be NArray");
  if (NA_RANK(rblapack_difl) != 1)
    rb_raise(rb_eArgError, "rank of difl (11th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_difl);
  if (NA_TYPE(rblapack_difl) != NA_DFLOAT)
    rblapack_difl = na_change_type(rblapack_difl, NA_DFLOAT);
  difl = NA_PTR_TYPE(rblapack_difl, doublereal*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (13th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (13th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != k)
    rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of difl");
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  s = NUM2DBL(rblapack_s);
  nl = NUM2INT(rblapack_nl);
  if (!NA_IsNArray(rblapack_perm))
    rb_raise(rb_eArgError, "perm (6th argument) must be NArray");
  if (NA_RANK(rblapack_perm) != 1)
    rb_raise(rb_eArgError, "rank of perm (6th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_perm);
  if (NA_TYPE(rblapack_perm) != NA_LINT)
    rblapack_perm = na_change_type(rblapack_perm, NA_LINT);
  perm = NA_PTR_TYPE(rblapack_perm, integer*);
  if (!NA_IsNArray(rblapack_poles))
    rb_raise(rb_eArgError, "poles (10th argument) must be NArray");
  if (NA_RANK(rblapack_poles) != 2)
    rb_raise(rb_eArgError, "rank of poles (10th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_poles) != ldgnum)
    rb_raise(rb_eRuntimeError, "shape 0 of poles must be the same as shape 0 of givnum");
  if (NA_SHAPE1(rblapack_poles) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of poles must be %d", 2);
  if (NA_TYPE(rblapack_poles) != NA_DFLOAT)
    rblapack_poles = na_change_type(rblapack_poles, NA_DFLOAT);
  poles = NA_PTR_TYPE(rblapack_poles, doublereal*);
  c = NUM2DBL(rblapack_c);
  sqre = NUM2INT(rblapack_sqre);
  if (!NA_IsNArray(rblapack_difr))
    rb_raise(rb_eArgError, "difr (12th argument) must be NArray");
  if (NA_RANK(rblapack_difr) != 2)
    rb_raise(rb_eArgError, "rank of difr (12th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_difr) != ldgnum)
    rb_raise(rb_eRuntimeError, "shape 0 of difr must be the same as shape 0 of givnum");
  if (NA_SHAPE1(rblapack_difr) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of difr must be %d", 2);
  if (NA_TYPE(rblapack_difr) != NA_DFLOAT)
    rblapack_difr = na_change_type(rblapack_difr, NA_DFLOAT);
  difr = NA_PTR_TYPE(rblapack_difr, doublereal*);
  if (!NA_IsNArray(rblapack_givcol))
    rb_raise(rb_eArgError, "givcol (8th argument) must be NArray");
  if (NA_RANK(rblapack_givcol) != 2)
    rb_raise(rb_eArgError, "rank of givcol (8th argument) must be %d", 2);
  ldgcol = NA_SHAPE0(rblapack_givcol);
  if (NA_SHAPE1(rblapack_givcol) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", 2);
  if (NA_TYPE(rblapack_givcol) != NA_LINT)
    rblapack_givcol = na_change_type(rblapack_givcol, NA_LINT);
  givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
  ldbx = n;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  bx = ALLOC_N(doublereal, (ldbx)*(nrhs));
  work = ALLOC_N(doublereal, (k));

  dlals0_(&icompq, &nl, &nr, &sqre, &nrhs, b, &ldb, bx, &ldbx, perm, &givptr, givcol, &ldgcol, givnum, &ldgnum, poles, difl, difr, z, &k, &c, &s, work, &info);

  free(bx);
  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_dlals0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlals0", rblapack_dlals0, -1);
}
ruby-lapack-1.7.2/ext/zsytri2x.c0000644000175000017500000001170312502221026016343 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zsytri2x_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* work, integer* nb, integer* info);


static VALUE
rblapack_zsytri2x(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_nb;
  integer nb; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  doublecomplex *work;

  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  info, a = NumRu::Lapack.zsytri2x( uplo, a, ipiv, nb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZSYTRI2X computes the inverse of a complex symmetric indefinite matrix\n*  A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n*  ZSYTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE COMPLEX array, dimension (LDA,N)\n*          On entry, the NNB diagonal matrix D and the multipliers\n*          used to obtain the factor U or L as computed by ZSYTRF.\n*\n*          On exit, if INFO = 0, the (symmetric) inverse of the original\n*          matrix.  If UPLO = 'U', the upper triangular part of the\n*          inverse is formed and the part of A below the diagonal is not\n*          referenced; if UPLO = 'L' the lower triangular part of the\n*          inverse is formed and the part of A above the diagonal is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the NNB structure of D\n*          as determined by ZSYTRF.\n*\n*  WORK    (workspace) DOUBLE COMPLEX array, dimension (N+NNB+1,NNB+3)\n*\n*  NB      (input) INTEGER\n*          Block size\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, D(i,i) = 0; the matrix is singular and its\n*               inverse could not be computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.zsytri2x( uplo, a, ipiv, nb, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_nb = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  nb = NUM2INT(rblapack_nb);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(doublecomplex, (n+nb+1)*(nb+3));

  zsytri2x_(&uplo, &n, a, &lda, ipiv, work, &nb, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_zsytri2x(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zsytri2x", rblapack_zsytri2x, -1);
}
ruby-lapack-1.7.2/ext/chpsv.c0000644000175000017500000001637712502221017015664 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chpsv_(char* uplo, integer* n, integer* nrhs, complex* ap, integer* ipiv, complex* b, integer* ldb, integer* info);


static VALUE
rblapack_chpsv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  complex *ap_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer ldb;
  integer nrhs;
  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  ipiv, info, ap, b = NumRu::Lapack.chpsv( uplo, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHPSV computes the solution to a complex system of linear equations\n*     A * X = B,\n*  where A is an N-by-N Hermitian matrix stored in packed format and X\n*  and B are N-by-NRHS matrices.\n*\n*  The diagonal pivoting method is used to factor A as\n*     A = U * D * U**H,  if UPLO = 'U', or\n*     A = L * D * L**H,  if UPLO = 'L',\n*  where U (or L) is a product of permutation and unit upper (lower)\n*  triangular matrices, D is Hermitian and block diagonal with 1-by-1\n*  and 2-by-2 diagonal blocks.  The factored form of A is then used to\n*  solve the system of equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          See below for further details.\n*\n*          On exit, the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L from the factorization\n*          A = U*D*U**H or A = L*D*L**H as computed by CHPTRF, stored as\n*          a packed triangular matrix in the same storage format as A.\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D, as\n*          determined by CHPTRF.  If IPIV(k) > 0, then rows and columns\n*          k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n*          diagonal block.  If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n*          then rows and columns k-1 and -IPIV(k) were interchanged and\n*          D(k-1:k,k-1:k) is a 2-by-2 diagonal block.  If UPLO = 'L' and\n*          IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n*          -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n*          diagonal block.\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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, D(i,i) is exactly zero.  The factorization\n*                has been completed, but the block diagonal matrix D is\n*                exactly singular, so the solution could not be\n*                computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  The packed storage scheme is illustrated by the following example\n*  when N = 4, UPLO = 'U':\n*\n*  Two-dimensional storage of the Hermitian matrix A:\n*\n*     a11 a12 a13 a14\n*         a22 a23 a24\n*             a33 a34     (aij = conjg(aji))\n*                 a44\n*\n*  Packed storage of the upper triangle of A:\n*\n*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n*  =====================================================================\n*\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CHPTRF, CHPTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, ap, b = NumRu::Lapack.chpsv( uplo, ap, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_b = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  n = ldb;
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
  MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  chpsv_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ipiv, rblapack_info, rblapack_ap, rblapack_b);
}

void
init_lapack_chpsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chpsv", rblapack_chpsv, -1);
}
ruby-lapack-1.7.2/ext/crot.c0000644000175000017500000001116512502221022015472 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID crot_(integer* n, complex* cx, integer* incx, complex* cy, integer* incy, real* c, complex* s);


static VALUE
rblapack_crot(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_cx;
  complex *cx; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_cy;
  complex *cy; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_c;
  real c; 
  VALUE rblapack_s;
  complex s; 
  VALUE rblapack_cx_out__;
  complex *cx_out__;
  VALUE rblapack_cy_out__;
  complex *cy_out__;

  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  cx, cy = NumRu::Lapack.crot( cx, incx, cy, incy, c, s, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CROT( N, CX, INCX, CY, INCY, C, S )\n\n*  Purpose\n*  =======\n*\n*  CROT   applies a plane rotation, where the cos (C) is real and the\n*  sin (S) is complex, and the vectors CX and CY are complex.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of elements in the vectors CX and CY.\n*\n*  CX      (input/output) COMPLEX array, dimension (N)\n*          On input, the vector X.\n*          On output, CX is overwritten with C*X + S*Y.\n*\n*  INCX    (input) INTEGER\n*          The increment between successive values of CY.  INCX <> 0.\n*\n*  CY      (input/output) COMPLEX array, dimension (N)\n*          On input, the vector Y.\n*          On output, CY is overwritten with -CONJG(S)*X + C*Y.\n*\n*  INCY    (input) INTEGER\n*          The increment between successive values of CY.  INCX <> 0.\n*\n*  C       (input) REAL\n*  S       (input) COMPLEX\n*          C and S define a rotation\n*             [  C          S  ]\n*             [ -conjg(S)   C  ]\n*          where C*C + S*CONJG(S) = 1.0.\n*\n\n* =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, IX, IY\n      COMPLEX            STEMP\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          CONJG\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  cx, cy = NumRu::Lapack.crot( cx, incx, cy, incy, c, s, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_cx = argv[0];
  rblapack_incx = argv[1];
  rblapack_cy = argv[2];
  rblapack_incy = argv[3];
  rblapack_c = argv[4];
  rblapack_s = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_cx))
    rb_raise(rb_eArgError, "cx (1th argument) must be NArray");
  if (NA_RANK(rblapack_cx) != 1)
    rb_raise(rb_eArgError, "rank of cx (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_cx);
  if (NA_TYPE(rblapack_cx) != NA_SCOMPLEX)
    rblapack_cx = na_change_type(rblapack_cx, NA_SCOMPLEX);
  cx = NA_PTR_TYPE(rblapack_cx, complex*);
  if (!NA_IsNArray(rblapack_cy))
    rb_raise(rb_eArgError, "cy (3th argument) must be NArray");
  if (NA_RANK(rblapack_cy) != 1)
    rb_raise(rb_eArgError, "rank of cy (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_cy) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of cy must be the same as shape 0 of cx");
  if (NA_TYPE(rblapack_cy) != NA_SCOMPLEX)
    rblapack_cy = na_change_type(rblapack_cy, NA_SCOMPLEX);
  cy = NA_PTR_TYPE(rblapack_cy, complex*);
  c = (real)NUM2DBL(rblapack_c);
  incx = NUM2INT(rblapack_incx);
  s.r = (real)NUM2DBL(rb_funcall(rblapack_s, rb_intern("real"), 0));
  s.i = (real)NUM2DBL(rb_funcall(rblapack_s, rb_intern("imag"), 0));
  incy = NUM2INT(rblapack_incy);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_cx_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  cx_out__ = NA_PTR_TYPE(rblapack_cx_out__, complex*);
  MEMCPY(cx_out__, cx, complex, NA_TOTAL(rblapack_cx));
  rblapack_cx = rblapack_cx_out__;
  cx = cx_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_cy_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  cy_out__ = NA_PTR_TYPE(rblapack_cy_out__, complex*);
  MEMCPY(cy_out__, cy, complex, NA_TOTAL(rblapack_cy));
  rblapack_cy = rblapack_cy_out__;
  cy = cy_out__;

  crot_(&n, cx, &incx, cy, &incy, &c, &s);

  return rb_ary_new3(2, rblapack_cx, rblapack_cy);
}

void
init_lapack_crot(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "crot", rblapack_crot, -1);
}
ruby-lapack-1.7.2/ext/dlarscl2.c0000644000175000017500000000664012502221017016237 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlarscl2_(integer* m, integer* n, doublereal* d, doublereal* x, integer* ldx);


static VALUE
rblapack_dlarscl2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_x_out__;
  doublereal *x_out__;

  integer m;
  integer ldx;
  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  x = NumRu::Lapack.dlarscl2( d, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLARSCL2 ( M, N, D, X, LDX )\n\n*  Purpose\n*  =======\n*\n*  DLARSCL2 performs a reciprocal diagonal scaling on an vector:\n*    x <-- inv(D) * x\n*  where the diagonal matrix D is stored as a vector.\n*\n*  Eventually to be replaced by BLAS_dge_diag_scale in the new BLAS\n*  standard.\n*\n\n*  Arguments\n*  =========\n*\n*     M       (input) INTEGER\n*     The number of rows of D and X. M >= 0.\n*\n*     N       (input) INTEGER\n*     The number of columns of D and X. N >= 0.\n*\n*     D       (input) DOUBLE PRECISION array, dimension (M)\n*     Diagonal matrix D, stored as a vector of length M.\n*\n*     X       (input/output) DOUBLE PRECISION array, dimension (LDX,N)\n*     On entry, the vector X to be scaled by D.\n*     On exit, the scaled vector.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the vector X. LDX >= 0.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x = NumRu::Lapack.dlarscl2( d, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_d = argv[0];
  rblapack_x = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  n = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = n;
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;

  dlarscl2_(&m, &n, d, x, &ldx);

  return rblapack_x;
}

void
init_lapack_dlarscl2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlarscl2", rblapack_dlarscl2, -1);
}
ruby-lapack-1.7.2/ext/zhecon.c0000644000175000017500000001122312502221022016004 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhecon_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* ipiv, doublereal* anorm, doublereal* rcond, doublecomplex* work, integer* info);


static VALUE
rblapack_zhecon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_anorm;
  doublereal anorm; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_info;
  integer info; 
  doublecomplex *work;

  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  rcond, info = NumRu::Lapack.zhecon( uplo, a, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHECON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHECON estimates the reciprocal of the condition number of a complex\n*  Hermitian matrix A using the factorization A = U*D*U**H or\n*  A = L*D*L**H computed by ZHETRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**H;\n*          = 'L':  Lower triangular, form is A = L*D*L**H.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by ZHETRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by ZHETRF.\n*\n*  ANORM   (input) DOUBLE PRECISION\n*          The 1-norm of the original matrix A.\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n*          estimate of the 1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.zhecon( uplo, a, ipiv, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_anorm = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  anorm = NUM2DBL(rblapack_anorm);
  work = ALLOC_N(doublecomplex, (2*n));

  zhecon_(&uplo, &n, a, &lda, ipiv, &anorm, &rcond, work, &info);

  free(work);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_zhecon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhecon", rblapack_zhecon, -1);
}
ruby-lapack-1.7.2/ext/chbgv.c0000644000175000017500000002056712502221022015622 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chbgv_(char* jobz, char* uplo, integer* n, integer* ka, integer* kb, complex* ab, integer* ldab, complex* bb, integer* ldbb, real* w, complex* z, integer* ldz, complex* work, real* rwork, integer* info);


static VALUE
rblapack_chbgv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ka;
  integer ka; 
  VALUE rblapack_kb;
  integer kb; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_bb;
  complex *bb; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  complex *ab_out__;
  VALUE rblapack_bb_out__;
  complex *bb_out__;
  complex *work;
  real *rwork;

  integer ldab;
  integer n;
  integer ldbb;
  integer ldz;

  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  w, z, info, ab, bb = NumRu::Lapack.chbgv( jobz, uplo, ka, kb, ab, bb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHBGV computes all the eigenvalues, and optionally, the eigenvectors\n*  of a complex generalized Hermitian-definite banded eigenproblem, of\n*  the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian\n*  and banded, and B is also positive definite.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  KA      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n*  KB      (input) INTEGER\n*          The number of superdiagonals of the matrix B if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n*  AB      (input/output) COMPLEX array, dimension (LDAB, N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix A, stored in the first ka+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).\n*\n*          On exit, the contents of AB are destroyed.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KA+1.\n*\n*  BB      (input/output) COMPLEX array, dimension (LDBB, N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix B, stored in the first kb+1 rows of the array.  The\n*          j-th column of B is stored in the j-th column of the array BB\n*          as follows:\n*          if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n*          if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb).\n*\n*          On exit, the factor S from the split Cholesky factorization\n*          B = S**H*S, as returned by CPBSTF.\n*\n*  LDBB    (input) INTEGER\n*          The leading dimension of the array BB.  LDBB >= KB+1.\n*\n*  W       (output) REAL array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) COMPLEX array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n*          eigenvectors, with the i-th column of Z holding the\n*          eigenvector associated with W(i). The eigenvectors are\n*          normalized so that Z**H*B*Z = I.\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= N.\n*\n*  WORK    (workspace) COMPLEX array, dimension (N)\n*\n*  RWORK   (workspace) REAL array, dimension (3*N)\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, and i is:\n*             <= N:  the algorithm failed to converge:\n*                    i off-diagonal elements of an intermediate\n*                    tridiagonal form did not converge to zero;\n*             > N:   if INFO = N + i, for 1 <= i <= N, then CPBSTF\n*                    returned INFO = i: B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            UPPER, WANTZ\n      CHARACTER          VECT\n      INTEGER            IINFO, INDE, INDWRK\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CHBGST, CHBTRD, CPBSTF, CSTEQR, SSTERF, XERBLA\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, info, ab, bb = NumRu::Lapack.chbgv( jobz, uplo, ka, kb, ab, bb, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_ka = argv[2];
  rblapack_kb = argv[3];
  rblapack_ab = argv[4];
  rblapack_bb = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  ka = NUM2INT(rblapack_ka);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_bb))
    rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
  if (NA_RANK(rblapack_bb) != 2)
    rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
  ldbb = NA_SHAPE0(rblapack_bb);
  if (NA_SHAPE1(rblapack_bb) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of bb must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_bb) != NA_SCOMPLEX)
    rblapack_bb = na_change_type(rblapack_bb, NA_SCOMPLEX);
  bb = NA_PTR_TYPE(rblapack_bb, complex*);
  kb = NUM2INT(rblapack_kb);
  ldz = lsame_(&jobz,"V") ? n : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
  MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldbb;
    shape[1] = n;
    rblapack_bb_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  bb_out__ = NA_PTR_TYPE(rblapack_bb_out__, complex*);
  MEMCPY(bb_out__, bb, complex, NA_TOTAL(rblapack_bb));
  rblapack_bb = rblapack_bb_out__;
  bb = bb_out__;
  work = ALLOC_N(complex, (n));
  rwork = ALLOC_N(real, (3*n));

  chbgv_(&jobz, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, w, z, &ldz, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_w, rblapack_z, rblapack_info, rblapack_ab, rblapack_bb);
}

void
init_lapack_chbgv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chbgv", rblapack_chbgv, -1);
}
ruby-lapack-1.7.2/ext/cgeevx.c0000644000175000017500000003122112502221025016002 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgeevx_(char* balanc, char* jobvl, char* jobvr, char* sense, integer* n, complex* a, integer* lda, complex* w, complex* vl, integer* ldvl, complex* vr, integer* ldvr, integer* ilo, integer* ihi, real* scale, real* abnrm, real* rconde, real* rcondv, complex* work, integer* lwork, real* rwork, integer* info);


static VALUE
rblapack_cgeevx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_balanc;
  char balanc; 
  VALUE rblapack_jobvl;
  char jobvl; 
  VALUE rblapack_jobvr;
  char jobvr; 
  VALUE rblapack_sense;
  char sense; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_w;
  complex *w; 
  VALUE rblapack_vl;
  complex *vl; 
  VALUE rblapack_vr;
  complex *vr; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_scale;
  real *scale; 
  VALUE rblapack_abnrm;
  real abnrm; 
  VALUE rblapack_rconde;
  real *rconde; 
  VALUE rblapack_rcondv;
  real *rcondv; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  real *rwork;

  integer lda;
  integer n;
  integer ldvl;
  integer ldvr;

  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  w, vl, vr, ilo, ihi, scale, abnrm, rconde, rcondv, work, info, a = NumRu::Lapack.cgeevx( balanc, jobvl, jobvr, sense, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, WORK, LWORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGEEVX computes for an N-by-N complex nonsymmetric matrix A, the\n*  eigenvalues and, optionally, the left and/or right eigenvectors.\n*\n*  Optionally also, it computes a balancing transformation to improve\n*  the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n*  SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues\n*  (RCONDE), and reciprocal condition numbers for the right\n*  eigenvectors (RCONDV).\n*\n*  The right eigenvector v(j) of A satisfies\n*                   A * v(j) = lambda(j) * v(j)\n*  where lambda(j) is its eigenvalue.\n*  The left eigenvector u(j) of A satisfies\n*                u(j)**H * A = lambda(j) * u(j)**H\n*  where u(j)**H denotes the conjugate transpose of u(j).\n*\n*  The computed eigenvectors are normalized to have Euclidean norm\n*  equal to 1 and largest component real.\n*\n*  Balancing a matrix means permuting the rows and columns to make it\n*  more nearly upper triangular, and applying a diagonal similarity\n*  transformation D * A * D**(-1), where D is a diagonal matrix, to\n*  make its rows and columns closer in norm and the condition numbers\n*  of its eigenvalues and eigenvectors smaller.  The computed\n*  reciprocal condition numbers correspond to the balanced matrix.\n*  Permuting rows and columns will not change the condition numbers\n*  (in exact arithmetic) but diagonal scaling will.  For further\n*  explanation of balancing, see section 4.10.2 of the LAPACK\n*  Users' Guide.\n*\n\n*  Arguments\n*  =========\n*\n*  BALANC  (input) CHARACTER*1\n*          Indicates how the input matrix should be diagonally scaled\n*          and/or permuted to improve the conditioning of its\n*          eigenvalues.\n*          = 'N': Do not diagonally scale or permute;\n*          = 'P': Perform permutations to make the matrix more nearly\n*                 upper triangular. Do not diagonally scale;\n*          = 'S': Diagonally scale the matrix, ie. replace A by\n*                 D*A*D**(-1), where D is a diagonal matrix chosen\n*                 to make the rows and columns of A more equal in\n*                 norm. Do not permute;\n*          = 'B': Both diagonally scale and permute A.\n*\n*          Computed reciprocal condition numbers will be for the matrix\n*          after balancing and/or permuting. Permuting does not change\n*          condition numbers (in exact arithmetic), but balancing does.\n*\n*  JOBVL   (input) CHARACTER*1\n*          = 'N': left eigenvectors of A are not computed;\n*          = 'V': left eigenvectors of A are computed.\n*          If SENSE = 'E' or 'B', JOBVL must = 'V'.\n*\n*  JOBVR   (input) CHARACTER*1\n*          = 'N': right eigenvectors of A are not computed;\n*          = 'V': right eigenvectors of A are computed.\n*          If SENSE = 'E' or 'B', JOBVR must = 'V'.\n*\n*  SENSE   (input) CHARACTER*1\n*          Determines which reciprocal condition numbers are computed.\n*          = 'N': None are computed;\n*          = 'E': Computed for eigenvalues only;\n*          = 'V': Computed for right eigenvectors only;\n*          = 'B': Computed for eigenvalues and right eigenvectors.\n*\n*          If SENSE = 'E' or 'B', both left and right eigenvectors\n*          must also be computed (JOBVL = 'V' and JOBVR = 'V').\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the N-by-N matrix A.\n*          On exit, A has been overwritten.  If JOBVL = 'V' or\n*          JOBVR = 'V', A contains the Schur form of the balanced \n*          version of the matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  W       (output) COMPLEX array, dimension (N)\n*          W contains the computed eigenvalues.\n*\n*  VL      (output) COMPLEX array, dimension (LDVL,N)\n*          If JOBVL = 'V', the left eigenvectors u(j) are stored one\n*          after another in the columns of VL, in the same order\n*          as their eigenvalues.\n*          If JOBVL = 'N', VL is not referenced.\n*          u(j) = VL(:,j), the j-th column of VL.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the array VL.  LDVL >= 1; if\n*          JOBVL = 'V', LDVL >= N.\n*\n*  VR      (output) COMPLEX array, dimension (LDVR,N)\n*          If JOBVR = 'V', the right eigenvectors v(j) are stored one\n*          after another in the columns of VR, in the same order\n*          as their eigenvalues.\n*          If JOBVR = 'N', VR is not referenced.\n*          v(j) = VR(:,j), the j-th column of VR.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the array VR.  LDVR >= 1; if\n*          JOBVR = 'V', LDVR >= N.\n*\n*  ILO     (output) INTEGER\n*  IHI     (output) INTEGER\n*          ILO and IHI are integer values determined when A was\n*          balanced.  The balanced A(i,j) = 0 if I > J and\n*          J = 1,...,ILO-1 or I = IHI+1,...,N.\n*\n*  SCALE   (output) REAL array, dimension (N)\n*          Details of the permutations and scaling factors applied\n*          when balancing A.  If P(j) is the index of the row and column\n*          interchanged with row and column j, and D(j) is the scaling\n*          factor applied to row and column j, then\n*          SCALE(J) = P(J),    for J = 1,...,ILO-1\n*                   = D(J),    for J = ILO,...,IHI\n*                   = P(J)     for J = IHI+1,...,N.\n*          The order in which the interchanges are made is N to IHI+1,\n*          then 1 to ILO-1.\n*\n*  ABNRM   (output) REAL\n*          The one-norm of the balanced matrix (the maximum\n*          of the sum of absolute values of elements of any column).\n*\n*  RCONDE  (output) REAL array, dimension (N)\n*          RCONDE(j) is the reciprocal condition number of the j-th\n*          eigenvalue.\n*\n*  RCONDV  (output) REAL array, dimension (N)\n*          RCONDV(j) is the reciprocal condition number of the j-th\n*          right eigenvector.\n*\n*  WORK    (workspace/output) COMPLEX 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.  If SENSE = 'N' or 'E',\n*          LWORK >= max(1,2*N), and if SENSE = 'V' or 'B',\n*          LWORK >= N*N+2*N.\n*          For good performance, LWORK must generally be larger.\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*  RWORK   (workspace) REAL array, dimension (2*N)\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 QR algorithm failed to compute all the\n*                eigenvalues, and no eigenvectors or condition numbers\n*                have been computed; elements 1:ILO-1 and i+1:N of W\n*                contain eigenvalues which have converged.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, vl, vr, ilo, ihi, scale, abnrm, rconde, rcondv, work, info, a = NumRu::Lapack.cgeevx( balanc, jobvl, jobvr, sense, a, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_balanc = argv[0];
  rblapack_jobvl = argv[1];
  rblapack_jobvr = argv[2];
  rblapack_sense = argv[3];
  rblapack_a = argv[4];
  if (argc == 6) {
    rblapack_lwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  balanc = StringValueCStr(rblapack_balanc)[0];
  jobvr = StringValueCStr(rblapack_jobvr)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  ldvr = lsame_(&jobvr,"V") ? n : 1;
  jobvl = StringValueCStr(rblapack_jobvl)[0];
  ldvl = lsame_(&jobvl,"V") ? n : 1;
  sense = StringValueCStr(rblapack_sense)[0];
  if (rblapack_lwork == Qnil)
    lwork = (lsame_(&sense,"N")||lsame_(&sense,"E")) ? 2*n : (lsame_(&sense,"V")||lsame_(&sense,"B")) ? n*n+2*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = n;
    rblapack_vl = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  vl = NA_PTR_TYPE(rblapack_vl, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = n;
    rblapack_vr = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  vr = NA_PTR_TYPE(rblapack_vr, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_scale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  scale = NA_PTR_TYPE(rblapack_scale, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rconde = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  rconde = NA_PTR_TYPE(rblapack_rconde, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rcondv = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  rcondv = NA_PTR_TYPE(rblapack_rcondv, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  rwork = ALLOC_N(real, (2*n));

  cgeevx_(&balanc, &jobvl, &jobvr, &sense, &n, a, &lda, w, vl, &ldvl, vr, &ldvr, &ilo, &ihi, scale, &abnrm, rconde, rcondv, work, &lwork, rwork, &info);

  free(rwork);
  rblapack_ilo = INT2NUM(ilo);
  rblapack_ihi = INT2NUM(ihi);
  rblapack_abnrm = rb_float_new((double)abnrm);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(12, rblapack_w, rblapack_vl, rblapack_vr, rblapack_ilo, rblapack_ihi, rblapack_scale, rblapack_abnrm, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_cgeevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgeevx", rblapack_cgeevx, -1);
}
ruby-lapack-1.7.2/ext/zhpcon.c0000644000175000017500000001106512502221023016024 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhpcon_(char* uplo, integer* n, doublecomplex* ap, integer* ipiv, doublereal* anorm, doublereal* rcond, doublecomplex* work, integer* info);


static VALUE
rblapack_zhpcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_anorm;
  doublereal anorm; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_info;
  integer info; 
  doublecomplex *work;

  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  rcond, info = NumRu::Lapack.zhpcon( uplo, ap, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHPCON estimates the reciprocal of the condition number of a complex\n*  Hermitian packed matrix A using the factorization A = U*D*U**H or\n*  A = L*D*L**H computed by ZHPTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**H;\n*          = 'L':  Lower triangular, form is A = L*D*L**H.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by ZHPTRF, stored as a\n*          packed triangular matrix.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by ZHPTRF.\n*\n*  ANORM   (input) DOUBLE PRECISION\n*          The 1-norm of the original matrix A.\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n*          estimate of the 1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.zhpcon( uplo, ap, ipiv, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_anorm = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  anorm = NUM2DBL(rblapack_anorm);
  work = ALLOC_N(doublecomplex, (2*n));

  zhpcon_(&uplo, &n, ap, ipiv, &anorm, &rcond, work, &info);

  free(work);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_zhpcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhpcon", rblapack_zhpcon, -1);
}
ruby-lapack-1.7.2/ext/clantp.c0000644000175000017500000001132212502221015016001 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real clantp_(char* norm, char* uplo, char* diag, integer* n, complex* ap, real* work);


static VALUE
rblapack_clantp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack___out__;
  real __out__; 
  real *work;

  integer lwork;

  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  __out__ = NumRu::Lapack.clantp( norm, uplo, diag, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL             FUNCTION CLANTP( NORM, UPLO, DIAG, N, AP, WORK )\n\n*  Purpose\n*  =======\n*\n*  CLANTP  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  triangular matrix A, supplied in packed form.\n*\n*  Description\n*  ===========\n*\n*  CLANTP returns the value\n*\n*     CLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in CLANTP as described\n*          above.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the matrix A is upper or lower triangular.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  DIAG    (input) CHARACTER*1\n*          Specifies whether or not the matrix A is unit triangular.\n*          = 'N':  Non-unit triangular\n*          = 'U':  Unit triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, CLANTP is\n*          set to zero.\n*\n*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)\n*          The upper or lower triangular matrix A, packed columnwise in\n*          a linear array.  The j-th column of A is stored in the array\n*          AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          Note that when DIAG = 'U', the elements of the array AP\n*          corresponding to the diagonal elements of the matrix A are\n*          not referenced, but are assumed to be one.\n*\n*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n*          referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.clantp( norm, uplo, diag, n, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_diag = argv[2];
  rblapack_n = argv[3];
  rblapack_ap = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  n = NUM2INT(rblapack_n);
  lwork = lsame_(&norm,"I") ? n : 0;
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  work = ALLOC_N(real, (MAX(1,lwork)));

  __out__ = clantp_(&norm, &uplo, &diag, &n, ap, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_clantp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clantp", rblapack_clantp, -1);
}
ruby-lapack-1.7.2/ext/slarscl2.c0000644000175000017500000000651512502221025016256 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slarscl2_(integer* m, integer* n, real* d, real* x, integer* ldx);


static VALUE
rblapack_slarscl2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_x_out__;
  real *x_out__;

  integer m;
  integer ldx;
  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  x = NumRu::Lapack.slarscl2( d, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLARSCL2 ( M, N, D, X, LDX )\n\n*  Purpose\n*  =======\n*\n*  SLARSCL2 performs a reciprocal diagonal scaling on an vector:\n*    x <-- inv(D) * x\n*  where the diagonal matrix D is stored as a vector.\n*\n*  Eventually to be replaced by BLAS_sge_diag_scale in the new BLAS\n*  standard.\n*\n\n*  Arguments\n*  =========\n*\n*     M       (input) INTEGER\n*     The number of rows of D and X. M >= 0.\n*\n*     N       (input) INTEGER\n*     The number of columns of D and X. N >= 0.\n*\n*     D       (input) REAL array, length M\n*     Diagonal matrix D, stored as a vector of length M.\n*\n*     X       (input/output) REAL array, dimension (LDX,N)\n*     On entry, the vector X to be scaled by D.\n*     On exit, the scaled vector.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the vector X. LDX >= 0.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x = NumRu::Lapack.slarscl2( d, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_d = argv[0];
  rblapack_x = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  n = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = n;
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;

  slarscl2_(&m, &n, d, x, &ldx);

  return rblapack_x;
}

void
init_lapack_slarscl2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slarscl2", rblapack_slarscl2, -1);
}
ruby-lapack-1.7.2/ext/csptrf.c0000644000175000017500000001476212502221013016032 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID csptrf_(char* uplo, integer* n, complex* ap, integer* ipiv, integer* info);


static VALUE
rblapack_csptrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  complex *ap_out__;

  integer ldap;
  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  ipiv, info, ap = NumRu::Lapack.csptrf( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSPTRF( UPLO, N, AP, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  CSPTRF computes the factorization of a complex symmetric matrix A\n*  stored in packed format using the Bunch-Kaufman diagonal pivoting\n*  method:\n*\n*     A = U*D*U**T  or  A = L*D*L**T\n*\n*  where U (or L) is a product of permutation and unit upper (lower)\n*  triangular matrices, and D is symmetric and block diagonal with\n*  1-by-1 and 2-by-2 diagonal blocks.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L, stored as a packed triangular\n*          matrix overwriting A (see below for further details).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D.\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\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, D(i,i) is exactly zero.  The factorization\n*               has been completed, but the block diagonal matrix D is\n*               exactly singular, and division by zero will occur if it\n*               is used to solve a system of equations.\n*\n\n*  Further Details\n*  ===============\n*\n*  5-96 - Based on modifications by J. Lewis, Boeing Computer Services\n*         Company\n*\n*  If UPLO = 'U', then A = U*D*U', where\n*     U = P(n)*U(n)* ... *P(k)U(k)* ...,\n*  i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n*  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    v    0   )   k-s\n*     U(k) =  (   0    I    0   )   s\n*             (   0    0    I   )   n-k\n*                k-s   s   n-k\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n*  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n*  and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n*  If UPLO = 'L', then A = L*D*L', where\n*     L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n*  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n*  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    0     0   )  k-1\n*     L(k) =  (   0    I     0   )  s\n*             (   0    v     I   )  n-k-s+1\n*                k-1   s  n-k-s+1\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n*  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n*  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, ap = NumRu::Lapack.csptrf( uplo, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
  MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  csptrf_(&uplo, &n, ap, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_ap);
}

void
init_lapack_csptrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "csptrf", rblapack_csptrf, -1);
}
ruby-lapack-1.7.2/ext/dgebal.c0000644000175000017500000001406412502221020015740 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgebal_(char* job, integer* n, doublereal* a, integer* lda, integer* ilo, integer* ihi, doublereal* scale, integer* info);


static VALUE
rblapack_dgebal(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_scale;
  doublereal *scale; 
  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  ilo, ihi, scale, info, a = NumRu::Lapack.dgebal( job, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGEBAL balances a general real matrix A.  This involves, first,\n*  permuting A by a similarity transformation to isolate eigenvalues\n*  in the first 1 to ILO-1 and last IHI+1 to N elements on the\n*  diagonal; and second, applying a diagonal similarity transformation\n*  to rows and columns ILO to IHI to make the rows and columns as\n*  close in norm as possible.  Both steps are optional.\n*\n*  Balancing may reduce the 1-norm of the matrix, and improve the\n*  accuracy of the computed eigenvalues and/or eigenvectors.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies the operations to be performed on A:\n*          = 'N':  none:  simply set ILO = 1, IHI = N, SCALE(I) = 1.0\n*                  for i = 1,...,N;\n*          = 'P':  permute only;\n*          = 'S':  scale only;\n*          = 'B':  both permute and scale.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the input matrix A.\n*          On exit,  A is overwritten by the balanced matrix.\n*          If JOB = 'N', A is not referenced.\n*          See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  ILO     (output) INTEGER\n*  IHI     (output) INTEGER\n*          ILO and IHI are set to integers such that on exit\n*          A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.\n*          If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n*\n*  SCALE   (output) DOUBLE PRECISION array, dimension (N)\n*          Details of the permutations and scaling factors applied to\n*          A.  If P(j) is the index of the row and column interchanged\n*          with row and column j and D(j) is the scaling factor\n*          applied to row and column j, then\n*          SCALE(j) = P(j)    for j = 1,...,ILO-1\n*                   = D(j)    for j = ILO,...,IHI\n*                   = P(j)    for j = IHI+1,...,N.\n*          The order in which the interchanges are made is N to IHI+1,\n*          then 1 to ILO-1.\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 permutations consist of row and column interchanges which put\n*  the matrix in the form\n*\n*             ( T1   X   Y  )\n*     P A P = (  0   B   Z  )\n*             (  0   0   T2 )\n*\n*  where T1 and T2 are upper triangular matrices whose eigenvalues lie\n*  along the diagonal.  The column indices ILO and IHI mark the starting\n*  and ending columns of the submatrix B. Balancing consists of applying\n*  a diagonal similarity transformation inv(D) * B * D to make the\n*  1-norms of each row of B and its corresponding column nearly equal.\n*  The output matrix is\n*\n*     ( T1     X*D          Y    )\n*     (  0  inv(D)*B*D  inv(D)*Z ).\n*     (  0      0           T2   )\n*\n*  Information about the permutations P and the diagonal matrix D is\n*  returned in the vector SCALE.\n*\n*  This subroutine is based on the EISPACK routine BALANC.\n*\n*  Modified by Tzu-Yi Chen, Computer Science Division, University of\n*    California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ilo, ihi, scale, info, a = NumRu::Lapack.dgebal( job, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_job = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  job = StringValueCStr(rblapack_job)[0];
  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*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_scale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  scale = NA_PTR_TYPE(rblapack_scale, doublereal*);
  {
    na_shape_t 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__;

  dgebal_(&job, &n, a, &lda, &ilo, &ihi, scale, &info);

  rblapack_ilo = INT2NUM(ilo);
  rblapack_ihi = INT2NUM(ihi);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_ilo, rblapack_ihi, rblapack_scale, rblapack_info, rblapack_a);
}

void
init_lapack_dgebal(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgebal", rblapack_dgebal, -1);
}
ruby-lapack-1.7.2/ext/dsytrs.c0000644000175000017500000001201012502221021016040 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsytrs_(char* uplo, integer* n, integer* nrhs, doublereal* a, integer* lda, integer* ipiv, doublereal* b, integer* ldb, integer* info);


static VALUE
rblapack_dsytrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublereal *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.dsytrs( uplo, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSYTRS solves a system of linear equations A*X = B with a real\n*  symmetric matrix A using the factorization A = U*D*U**T or\n*  A = L*D*L**T computed by DSYTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by DSYTRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by DSYTRF.\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.dsytrs( uplo, a, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dsytrs_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_dsytrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsytrs", rblapack_dsytrs, -1);
}
ruby-lapack-1.7.2/ext/zpbtrs.c0000644000175000017500000001223612502221025016052 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zpbtrs_(char* uplo, integer* n, integer* kd, integer* nrhs, doublecomplex* ab, integer* ldab, doublecomplex* b, integer* ldb, integer* info);


static VALUE
rblapack_zpbtrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer ldab;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.zpbtrs( uplo, kd, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPBTRS solves a system of linear equations A*X = B with a Hermitian\n*  positive definite band matrix A using the Cholesky factorization\n*  A = U**H*U or A = L*L**H computed by ZPBTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangular factor stored in AB;\n*          = 'L':  Lower triangular factor stored in AB.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**H*U or A = L*L**H of the band matrix A, stored in the\n*          first KD+1 rows of the array.  The j-th column of U or L is\n*          stored in the j-th column of the array AB as follows:\n*          if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO ='L', AB(1+i-j,j)    = L(i,j) for j<=i<=min(n,j+kd).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            UPPER\n      INTEGER            J\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZTBSV\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.zpbtrs( uplo, kd, ab, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  kd = NUM2INT(rblapack_kd);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zpbtrs_(&uplo, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_zpbtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zpbtrs", rblapack_zpbtrs, -1);
}
ruby-lapack-1.7.2/ext/zgerfsx.c0000644000175000017500000005314012502221017016216 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgerfsx_(char* trans, char* equed, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublereal* r, doublereal* c, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zgerfsx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_r;
  doublereal *r; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_params;
  doublereal *params; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_err_bnds_norm;
  doublereal *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  doublereal *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;
  VALUE rblapack_params_out__;
  doublereal *params_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;
  integer nparams;
  integer n_err_bnds;

  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  rcond, berr, err_bnds_norm, err_bnds_comp, info, x, params = NumRu::Lapack.zgerfsx( trans, equed, a, af, ipiv, r, c, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     ZGERFSX improves the computed solution to a system of linear\n*     equations and provides error bounds and backward error estimates\n*     for the solution.  In addition to normwise error bound, the code\n*     provides maximum componentwise error bound if possible.  See\n*     comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n*     error bounds.\n*\n*     The original system of linear equations may have been equilibrated\n*     before calling this routine, as described by arguments EQUED, R\n*     and C below. In this case, the solution and error bounds returned\n*     are for the original unequilibrated system.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     TRANS   (input) CHARACTER*1\n*     Specifies the form of the system of equations:\n*       = 'N':  A * X = B     (No transpose)\n*       = 'T':  A**T * X = B  (Transpose)\n*       = 'C':  A**H * X = B  (Conjugate transpose = Transpose)\n*\n*     EQUED   (input) CHARACTER*1\n*     Specifies the form of equilibration that was done to A\n*     before calling this routine. This is needed to compute\n*     the solution and error bounds correctly.\n*       = 'N':  No equilibration\n*       = 'R':  Row equilibration, i.e., A has been premultiplied by\n*               diag(R).\n*       = 'C':  Column equilibration, i.e., A has been postmultiplied\n*               by diag(C).\n*       = 'B':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(R) * A * diag(C).\n*               The right hand side B has been changed accordingly.\n*\n*     N       (input) INTEGER\n*     The order of the matrix A.  N >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     A       (input) COMPLEX*16 array, dimension (LDA,N)\n*     The original N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX*16 array, dimension (LDAF,N)\n*     The factors L and U from the factorization A = P*L*U\n*     as computed by ZGETRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     The pivot indices from ZGETRF; for 1<=i<=N, row i of the\n*     matrix was interchanged with row IPIV(i).\n*\n*     R       (input) DOUBLE PRECISION array, dimension (N)\n*     The row scale factors for A.  If EQUED = 'R' or 'B', A is\n*     multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n*     is not accessed.  \n*     If R is accessed, each element of R should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     C       (input) DOUBLE PRECISION array, dimension (N)\n*     The column scale factors for A.  If EQUED = 'C' or 'B', A is\n*     multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n*     is not accessed.\n*     If C is accessed, each element of C should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B       (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*     The right hand side matrix B.\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (input/output) COMPLEX*16 array, dimension (LDX,NRHS)\n*     On entry, the solution matrix X, as computed by ZGETRS.\n*     On exit, the improved solution matrix X.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) DOUBLE PRECISION\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*     Componentwise relative backward error.  This is the\n*     componentwise relative backward error of each solution vector X(j)\n*     (i.e., the smallest relative change in any element of A or B that\n*     makes X(j) an exact solution).\n*\n*     N_ERR_BNDS (input) INTEGER\n*     Number of error bounds to return for each right hand side\n*     and each type (normwise or componentwise).  See ERR_BNDS_NORM and\n*     ERR_BNDS_COMP below.\n*\n*     ERR_BNDS_NORM  (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * dlamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * dlamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * dlamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * dlamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * dlamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * dlamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     NPARAMS (input) INTEGER\n*     Specifies the number of parameters set in PARAMS.  If .LE. 0, the\n*     PARAMS array is never referenced and default values are used.\n*\n*     PARAMS  (input / output) DOUBLE PRECISION array, dimension NPARAMS\n*     Specifies algorithm parameters.  If an entry is .LT. 0.0, then\n*     that entry will be filled with default value used for that\n*     parameter.  Only positions up to NPARAMS are accessed; defaults\n*     are used for higher-numbered parameters.\n*\n*       PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n*            refinement or not.\n*         Default: 1.0D+0\n*            = 0.0 : No refinement is performed, and no error bounds are\n*                    computed.\n*            = 1.0 : Use the double-precision refinement algorithm,\n*                    possibly with doubled-single computations if the\n*                    compilation environment does not support DOUBLE\n*                    PRECISION.\n*              (other values are reserved for future use)\n*\n*       PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n*            computations allowed for refinement.\n*         Default: 10\n*         Aggressive: Set to 100 to permit convergence using approximate\n*                     factorizations or factorizations other than LU. If\n*                     the factorization uses a technique other than\n*                     Gaussian elimination, the guarantees in\n*                     err_bnds_norm and err_bnds_comp may no longer be\n*                     trustworthy.\n*\n*       PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n*            will attempt to find a solution with small componentwise\n*            relative error in the double-precision algorithm.  Positive\n*            is true, 0.0 is false.\n*         Default: 1.0 (attempt componentwise convergence)\n*\n*     WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*     RWORK   (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit. The solution to every right-hand side is\n*         guaranteed.\n*       < 0:  If INFO = -i, the i-th argument had an illegal value\n*       > 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, berr, err_bnds_norm, err_bnds_comp, info, x, params = NumRu::Lapack.zgerfsx( trans, equed, a, af, ipiv, r, c, b, x, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_trans = argv[0];
  rblapack_equed = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_r = argv[5];
  rblapack_c = argv[6];
  rblapack_b = argv[7];
  rblapack_x = argv[8];
  rblapack_params = argv[9];
  if (argc == 10) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (9th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (9th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  n_err_bnds = 3;
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_r))
    rb_raise(rb_eArgError, "r (6th argument) must be NArray");
  if (NA_RANK(rblapack_r) != 1)
    rb_raise(rb_eArgError, "rank of r (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_r) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_r) != NA_DFLOAT)
    rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
  r = NA_PTR_TYPE(rblapack_r, doublereal*);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (10th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (10th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_DFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
  params = NA_PTR_TYPE(rblapack_params, doublereal*);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
  MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (2*n));

  zgerfsx_(&trans, &equed, &n, &nrhs, a, &lda, af, &ldaf, ipiv, r, c, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_x, rblapack_params);
}

void
init_lapack_zgerfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgerfsx", rblapack_zgerfsx, -1);
}
ruby-lapack-1.7.2/ext/sla_rpvgrw.c0000644000175000017500000000751512502221021016714 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real sla_rpvgrw_(integer* n, integer* ncols, real* a, integer* lda, real* af, integer* ldaf);


static VALUE
rblapack_sla_rpvgrw(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ncols;
  integer ncols; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_af;
  real *af; 
  VALUE rblapack___out__;
  real __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  __out__ = NumRu::Lapack.sla_rpvgrw( ncols, a, af, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL FUNCTION SLA_RPVGRW( N, NCOLS, A, LDA, AF, LDAF )\n\n*  Purpose\n*  =======\n*\n*  SLA_RPVGRW computes the reciprocal pivot growth factor\n*  norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n*  much less than 1, the stability of the LU factorization of the\n*  (equilibrated) matrix A could be poor. This also means that the\n*  solution X, estimated condition numbers, and error bounds could be\n*  unreliable.\n*\n\n*  Arguments\n*  =========\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NCOLS   (input) INTEGER\n*     The number of columns of the matrix A. NCOLS >= 0.\n*\n*     A       (input) REAL array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) REAL array, dimension (LDAF,N)\n*     The factors L and U from the factorization\n*     A = P*L*U as computed by SGETRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n      REAL               AMAX, UMAX, RPVGRW\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.sla_rpvgrw( ncols, a, af, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_ncols = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  ncols = NUM2INT(rblapack_ncols);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_SFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
  af = NA_PTR_TYPE(rblapack_af, real*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);

  __out__ = sla_rpvgrw_(&n, &ncols, a, &lda, af, &ldaf);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_sla_rpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sla_rpvgrw", rblapack_sla_rpvgrw, -1);
}
ruby-lapack-1.7.2/ext/sgesvj.c0000644000175000017500000004473112502221021016030 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgesvj_(char* joba, char* jobu, char* jobv, integer* m, integer* n, real* a, integer* lda, real* sva, integer* mv, real* v, integer* ldv, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sgesvj(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_joba;
  char joba; 
  VALUE rblapack_jobu;
  char jobu; 
  VALUE rblapack_jobv;
  char jobv; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_mv;
  integer mv; 
  VALUE rblapack_v;
  real *v; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_sva;
  real *sva; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_v_out__;
  real *v_out__;
  VALUE rblapack_work_out__;
  real *work_out__;

  integer lda;
  integer n;
  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, info, a, v, work = NumRu::Lapack.sgesvj( joba, jobu, jobv, m, a, mv, v, work, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, LDV, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGESVJ computes the singular value decomposition (SVD) of a real\n*  M-by-N matrix A, where M >= N. The SVD of A is written as\n*                                     [++]   [xx]   [x0]   [xx]\n*               A = U * SIGMA * V^t,  [++] = [xx] * [ox] * [xx]\n*                                     [++]   [xx]\n*  where SIGMA is an N-by-N diagonal matrix, U is an M-by-N orthonormal\n*  matrix, and V is an N-by-N orthogonal matrix. The diagonal elements\n*  of SIGMA are the singular values of A. The columns of U and V are the\n*  left and the right singular vectors of A, respectively.\n*\n*  Further Details\n*  ~~~~~~~~~~~~~~~\n*  The orthogonal N-by-N matrix V is obtained as a product of Jacobi plane\n*  rotations. The rotations are implemented as fast scaled rotations of\n*  Anda and Park [1]. In the case of underflow of the Jacobi angle, a\n*  modified Jacobi transformation of Drmac [4] is used. Pivot strategy uses\n*  column interchanges of de Rijk [2]. The relative accuracy of the computed\n*  singular values and the accuracy of the computed singular vectors (in\n*  angle metric) is as guaranteed by the theory of Demmel and Veselic [3].\n*  The condition number that determines the accuracy in the full rank case\n*  is essentially min_{D=diag} kappa(A*D), where kappa(.) is the\n*  spectral condition number. The best performance of this Jacobi SVD\n*  procedure is achieved if used in an  accelerated version of Drmac and\n*  Veselic [5,6], and it is the kernel routine in the SIGMA library [7].\n*  Some tunning parameters (marked with [TP]) are available for the\n*  implementer.\n*  The computational range for the nonzero singular values is the  machine\n*  number interval ( UNDERFLOW , OVERFLOW ). In extreme cases, even\n*  denormalized singular values can be computed with the corresponding\n*  gradual loss of accurate digits.\n*\n*  Contributors\n*  ~~~~~~~~~~~~\n*  Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)\n*\n*  References\n*  ~~~~~~~~~~\n* [1] A. A. Anda and H. Park: Fast plane rotations with dynamic scaling.\n*     SIAM J. matrix Anal. Appl., Vol. 15 (1994), pp. 162-174.\n* [2] P. P. M. De Rijk: A one-sided Jacobi algorithm for computing the\n*     singular value decomposition on a vector computer.\n*     SIAM J. Sci. Stat. Comp., Vol. 10 (1998), pp. 359-371.\n* [3] J. Demmel and K. Veselic: Jacobi method is more accurate than QR.\n* [4] Z. Drmac: Implementation of Jacobi rotations for accurate singular\n*     value computation in floating point arithmetic.\n*     SIAM J. Sci. Comp., Vol. 18 (1997), pp. 1200-1222.\n* [5] 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* [6] 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* [7] 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 test examples and comments to\n*  drmac@math.hr. Thank you.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBA    (input) CHARACTER* 1\n*          Specifies the structure of A.\n*          = 'L': The input matrix A is lower triangular;\n*          = 'U': The input matrix A is upper triangular;\n*          = 'G': The input matrix A is general M-by-N matrix, M >= N.\n*\n*  JOBU    (input) CHARACTER*1\n*          Specifies whether to compute the left singular vectors\n*          (columns of U):\n*          = 'U': The left singular vectors corresponding to the nonzero\n*                 singular values are computed and returned in the leading\n*                 columns of A. See more details in the description of A.\n*                 The default numerical orthogonality threshold is set to\n*                 approximately TOL=CTOL*EPS, CTOL=SQRT(M), EPS=SLAMCH('E').\n*          = 'C': Analogous to JOBU='U', except that user can control the\n*                 level of numerical orthogonality of the computed left\n*                 singular vectors. TOL can be set to TOL = CTOL*EPS, where\n*                 CTOL is given on input in the array WORK.\n*                 No CTOL smaller than ONE is allowed. CTOL greater\n*                 than 1 / EPS is meaningless. The option 'C'\n*                 can be used if M*EPS is satisfactory orthogonality\n*                 of the computed left singular vectors, so CTOL=M could\n*                 save few sweeps of Jacobi rotations.\n*                 See the descriptions of A and WORK(1).\n*          = 'N': The matrix U is not computed. However, see the\n*                 description of A.\n*\n*  JOBV    (input) CHARACTER*1\n*          Specifies whether to compute the right singular vectors, that\n*          is, the matrix V:\n*          = 'V' : the matrix V is computed and returned in the array V\n*          = 'A' : the Jacobi rotations are applied to the MV-by-N\n*                  array V. In other words, the right singular vector\n*                  matrix V is not computed explicitly; instead it is\n*                  applied to an MV-by-N matrix initially stored in the\n*                  first MV rows of V.\n*          = 'N' : the matrix V is not computed and the array V is not\n*                  referenced\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.\n*          M >= N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit,\n*          If JOBU .EQ. 'U' .OR. JOBU .EQ. 'C':\n*                 If INFO .EQ. 0 :\n*                 RANKA orthonormal columns of U are returned in the\n*                 leading RANKA columns of the array A. Here RANKA <= N\n*                 is the number of computed singular values of A that are\n*                 above the underflow threshold SLAMCH('S'). The singular\n*                 vectors corresponding to underflowed or zero singular\n*                 values are not computed. The value of RANKA is returned\n*                 in the array WORK as RANKA=NINT(WORK(2)). Also see the\n*                 descriptions of SVA and WORK. The computed columns of U\n*                 are mutually numerically orthogonal up to approximately\n*                 TOL=SQRT(M)*EPS (default); or TOL=CTOL*EPS (JOBU.EQ.'C'),\n*                 see the description of JOBU.\n*                 If INFO .GT. 0,\n*                 the procedure SGESVJ did not converge in the given number\n*                 of iterations (sweeps). In that case, the computed\n*                 columns of U may not be orthogonal up to TOL. The output\n*                 U (stored in A), SIGMA (given by the computed singular\n*                 values in SVA(1:N)) and V is still a decomposition of the\n*                 input matrix A in the sense that the residual\n*                 ||A-SCALE*U*SIGMA*V^T||_2 / ||A||_2 is small.\n*          If JOBU .EQ. 'N':\n*                 If INFO .EQ. 0 :\n*                 Note that the left singular vectors are 'for free' in the\n*                 one-sided Jacobi SVD algorithm. However, if only the\n*                 singular values are needed, the level of numerical\n*                 orthogonality of U is not an issue and iterations are\n*                 stopped when the columns of the iterated matrix are\n*                 numerically orthogonal up to approximately M*EPS. Thus,\n*                 on exit, A contains the columns of U scaled with the\n*                 corresponding singular values.\n*                 If INFO .GT. 0 :\n*                 the procedure SGESVJ did not converge in the given number\n*                 of iterations (sweeps).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  SVA     (workspace/output) REAL array, dimension (N)\n*          On exit,\n*          If INFO .EQ. 0 :\n*          depending on the value SCALE = WORK(1), we have:\n*                 If SCALE .EQ. ONE:\n*                 SVA(1:N) contains the computed singular values of A.\n*                 During the computation SVA contains the Euclidean column\n*                 norms of the iterated matrices in the array A.\n*                 If SCALE .NE. ONE:\n*                 The singular values of A are SCALE*SVA(1:N), and this\n*                 factored representation is due to the fact that some of the\n*                 singular values of A might underflow or overflow.\n*\n*          If INFO .GT. 0 :\n*          the procedure SGESVJ did not converge in the given number of\n*          iterations (sweeps) and SCALE*SVA(1:N) may not be accurate.\n*\n*  MV      (input) INTEGER\n*          If JOBV .EQ. 'A', then the product of Jacobi rotations in SGESVJ\n*          is applied to the first MV rows of V. See the description of JOBV.\n*\n*  V       (input/output) REAL array, dimension (LDV,N)\n*          If JOBV = 'V', then V contains on exit the N-by-N matrix of\n*                         the right singular vectors;\n*          If JOBV = 'A', then V contains the product of the computed right\n*                         singular vector matrix and the initial matrix in\n*                         the array V.\n*          If JOBV = 'N', then V is not referenced.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V, LDV .GE. 1.\n*          If JOBV .EQ. 'V', then LDV .GE. max(1,N).\n*          If JOBV .EQ. 'A', then LDV .GE. max(1,MV) .\n*\n*  WORK    (input/workspace/output) REAL array, dimension max(4,M+N).\n*          On entry,\n*          If JOBU .EQ. 'C' :\n*          WORK(1) = CTOL, where CTOL defines the threshold for convergence.\n*                    The process stops if all columns of A are mutually\n*                    orthogonal up to CTOL*EPS, EPS=SLAMCH('E').\n*                    It is required that CTOL >= ONE, i.e. it is not\n*                    allowed to force the routine to obtain orthogonality\n*                    below EPSILON.\n*          On exit,\n*          WORK(1) = SCALE is the scaling factor such that SCALE*SVA(1:N)\n*                    are the computed singular vcalues of A.\n*                    (See description of SVA().)\n*          WORK(2) = NINT(WORK(2)) is the number of the computed nonzero\n*                    singular values.\n*          WORK(3) = NINT(WORK(3)) is the number of the computed singular\n*                    values that are larger than the underflow threshold.\n*          WORK(4) = NINT(WORK(4)) is the number of sweeps of Jacobi\n*                    rotations needed for numerical convergence.\n*          WORK(5) = max_{i.NE.j} |COS(A(:,i),A(:,j))| in the last sweep.\n*                    This is useful information in cases when SGESVJ did\n*                    not converge, as it can be used to estimate whether\n*                    the output is stil useful and for post festum analysis.\n*          WORK(6) = the largest absolute value over all sines of the\n*                    Jacobi rotation angles in the last sweep. It can be\n*                    useful for a post festum analysis.\n*\n*  LWORK   length of WORK, WORK >= MAX(6,M+N)\n*\n*  INFO    (output) INTEGER\n*          = 0 : successful exit.\n*          < 0 : if INFO = -i, then the i-th argument had an illegal value\n*          > 0 : SGESVJ did not converge in the maximal allowed number (30)\n*                of sweeps. The output may still be useful. See the\n*                description of WORK.\n\n*  =====================================================================\n*\n*     .. Local Parameters ..\n      REAL               ZERO, HALF, ONE, TWO\n      PARAMETER          ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0,\n     +                   TWO = 2.0E0 )\n      INTEGER            NSWEEP\n      PARAMETER          ( NSWEEP = 30 )\n*     ..\n*     .. Local Scalars ..\n      REAL               AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,\n     +                   BIGTHETA, CS, CTOL, EPSLN, LARGE, MXAAPQ,\n     +                   MXSINJ, ROOTBIG, ROOTEPS, ROOTSFMIN, ROOTTOL,\n     +                   SKL, SFMIN, SMALL, SN, T, TEMP1, THETA,\n     +                   THSIGN, TOL\n      INTEGER            BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1,\n     +                   ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, N2, N34,\n     +                   N4, NBL, NOTROT, p, PSKIPPED, q, ROWSKIP,\n     +                   SWBAND\n      LOGICAL            APPLV, GOSCALE, LOWER, LSVEC, NOSCALE, ROTOK,\n     +                   RSVEC, UCTOL, UPPER\n*     ..\n*     .. Local Arrays ..\n      REAL               FASTR( 5 )\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, AMAX1, AMIN1, FLOAT, MIN0, SIGN, SQRT\n*     ..\n*     .. External Functions ..\n*     from BLAS\n      REAL               SDOT, SNRM2\n      EXTERNAL           SDOT, SNRM2\n      INTEGER            ISAMAX\n      EXTERNAL           ISAMAX\n*     from LAPACK\n      REAL               SLAMCH\n      EXTERNAL           SLAMCH\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n*     from BLAS\n      EXTERNAL           SAXPY, SCOPY, SROTM, SSCAL, SSWAP\n*     from LAPACK\n      EXTERNAL           SLASCL, SLASET, SLASSQ, XERBLA\n*\n      EXTERNAL           SGSVJ0, SGSVJ1\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sva, info, a, v, work = NumRu::Lapack.sgesvj( joba, jobu, jobv, m, a, mv, v, work, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_joba = argv[0];
  rblapack_jobu = argv[1];
  rblapack_jobv = argv[2];
  rblapack_m = argv[3];
  rblapack_a = argv[4];
  rblapack_mv = argv[5];
  rblapack_v = argv[6];
  rblapack_work = argv[7];
  if (argc == 9) {
    rblapack_lwork = argv[8];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  joba = StringValueCStr(rblapack_joba)[0];
  jobv = StringValueCStr(rblapack_jobv)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (7th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  if (NA_SHAPE1(rblapack_v) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of v must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_v) != NA_SFLOAT)
    rblapack_v = na_change_type(rblapack_v, NA_SFLOAT);
  v = NA_PTR_TYPE(rblapack_v, real*);
  jobu = StringValueCStr(rblapack_jobu)[0];
  mv = NUM2INT(rblapack_mv);
  m = NUM2INT(rblapack_m);
  lwork = MAX(6,m+n);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (8th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != lwork)
    rb_raise(rb_eRuntimeError, "shape 0 of work must be MAX(6,m+n)");
  if (NA_TYPE(rblapack_work) != NA_SFLOAT)
    rblapack_work = na_change_type(rblapack_work, NA_SFLOAT);
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_sva = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  sva = NA_PTR_TYPE(rblapack_sva, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = n;
    rblapack_v_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  v_out__ = NA_PTR_TYPE(rblapack_v_out__, real*);
  MEMCPY(v_out__, v, real, NA_TOTAL(rblapack_v));
  rblapack_v = rblapack_v_out__;
  v = v_out__;
  {
    na_shape_t shape[1];
    shape[0] = lwork;
    rblapack_work_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work_out__ = NA_PTR_TYPE(rblapack_work_out__, real*);
  MEMCPY(work_out__, work, real, NA_TOTAL(rblapack_work));
  rblapack_work = rblapack_work_out__;
  work = work_out__;

  sgesvj_(&joba, &jobu, &jobv, &m, &n, a, &lda, sva, &mv, v, &ldv, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_sva, rblapack_info, rblapack_a, rblapack_v, rblapack_work);
}

void
init_lapack_sgesvj(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgesvj", rblapack_sgesvj, -1);
}
ruby-lapack-1.7.2/ext/spptri.c0000644000175000017500000000727712502221021016054 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID spptri_(char* uplo, integer* n, real* ap, integer* info);


static VALUE
rblapack_spptri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  real *ap_out__;


  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  info, ap = NumRu::Lapack.spptri( uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPPTRI( UPLO, N, AP, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPPTRI computes the inverse of a real symmetric positive definite\n*  matrix A using the Cholesky factorization A = U**T*U or A = L*L**T\n*  computed by SPPTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangular factor is stored in AP;\n*          = 'L':  Lower triangular factor is stored in AP.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) REAL array, dimension (N*(N+1)/2)\n*          On entry, the triangular factor U or L from the Cholesky\n*          factorization A = U**T*U or A = L*L**T, packed columnwise as\n*          a linear array.  The j-th column of U or L is stored in the\n*          array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n*          On exit, the upper or lower triangle of the (symmetric)\n*          inverse of A, overwriting the input factor U or L.\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,i) element of the factor U or L is\n*                zero, and the inverse could not be computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ap = NumRu::Lapack.spptri( uplo, n, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_n = argv[1];
  rblapack_ap = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, real*);
  MEMCPY(ap_out__, ap, real, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  spptri_(&uplo, &n, ap, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ap);
}

void
init_lapack_spptri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "spptri", rblapack_spptri, -1);
}
ruby-lapack-1.7.2/ext/sormhr.c0000644000175000017500000002000112502221024016024 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sormhr_(char* side, char* trans, integer* m, integer* n, integer* ilo, integer* ihi, real* a, integer* lda, real* tau, real* c, integer* ldc, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sormhr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  real *c_out__;

  integer lda;
  integer m;
  integer ldc;
  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  work, info, c = NumRu::Lapack.sormhr( side, trans, ilo, ihi, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SORMHR overwrites the general real M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'T':      Q**T * C       C * Q**T\n*\n*  where Q is a real orthogonal matrix of order nq, with nq = m if\n*  SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of\n*  IHI-ILO elementary reflectors, as returned by SGEHRD:\n*\n*  Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**T from the Left;\n*          = 'R': apply Q or Q**T from the Right.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'T':  Transpose, apply Q**T.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          ILO and IHI must have the same values as in the previous call\n*          of SGEHRD. Q is equal to the unit matrix except in the\n*          submatrix Q(ilo+1:ihi,ilo+1:ihi).\n*          If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and\n*          ILO = 1 and IHI = 0, if M = 0;\n*          if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and\n*          ILO = 1 and IHI = 0, if N = 0.\n*\n*  A       (input) REAL array, dimension\n*                               (LDA,M) if SIDE = 'L'\n*                               (LDA,N) if SIDE = 'R'\n*          The vectors which define the elementary reflectors, as\n*          returned by SGEHRD.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*          LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n*\n*  TAU     (input) REAL array, dimension\n*                               (M-1) if SIDE = 'L'\n*                               (N-1) if SIDE = 'R'\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by SGEHRD.\n*\n*  C       (input/output) REAL array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace/output) REAL 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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M).\n*          For optimum performance LWORK >= N*NB if SIDE = 'L', and\n*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n*          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*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LEFT, LQUERY\n      INTEGER            I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            ILAENV\n      EXTERNAL           ILAENV, LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SORMQR, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.sormhr( side, trans, ilo, ihi, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_ilo = argv[2];
  rblapack_ihi = argv[3];
  rblapack_a = argv[4];
  rblapack_tau = argv[5];
  rblapack_c = argv[6];
  if (argc == 8) {
    rblapack_lwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  side = StringValueCStr(rblapack_side)[0];
  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (6th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_tau) != (m-1))
    rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", m-1);
  if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  ihi = NUM2INT(rblapack_ihi);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  sormhr_(&side, &trans, &m, &n, &ilo, &ihi, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_sormhr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sormhr", rblapack_sormhr, -1);
}
ruby-lapack-1.7.2/ext/ssytrf.c0000644000175000017500000002006212502221023016052 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssytrf_(char* uplo, integer* n, real* a, integer* lda, integer* ipiv, real* work, integer* lwork, integer* info);


static VALUE
rblapack_ssytrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *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  ipiv, work, info, a = NumRu::Lapack.ssytrf( uplo, a, lwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSYTRF computes the factorization of a real symmetric matrix A using\n*  the Bunch-Kaufman diagonal pivoting method.  The form of the\n*  factorization is\n*\n*     A = U*D*U**T  or  A = L*D*L**T\n*\n*  where U (or L) is a product of permutation and unit upper (lower)\n*  triangular matrices, and D is symmetric and block diagonal with \n*  1-by-1 and 2-by-2 diagonal blocks.\n*\n*  This is the blocked version of the algorithm, calling Level 3 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L (see below for further details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D.\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*  WORK    (workspace/output) REAL array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of WORK.  LWORK >=1.  For best performance\n*          LWORK >= N*NB, where NB is the block size returned by ILAENV.\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, D(i,i) is exactly zero.  The factorization\n*                has been completed, but the block diagonal matrix D is\n*                exactly singular, and division by zero will occur if it\n*                is used to solve a system of equations.\n*\n\n*  Further Details\n*  ===============\n*\n*  If UPLO = 'U', then A = U*D*U', where\n*     U = P(n)*U(n)* ... *P(k)U(k)* ...,\n*  i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n*  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    v    0   )   k-s\n*     U(k) =  (   0    I    0   )   s\n*             (   0    0    I   )   n-k\n*                k-s   s   n-k\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n*  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n*  and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n*  If UPLO = 'L', then A = L*D*L', where\n*     L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n*  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n*  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    0     0   )  k-1\n*     L(k) =  (   0    I     0   )  s\n*             (   0    v     I   )  n-k-s+1\n*                k-1   s  n-k-s+1\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n*  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n*  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY, UPPER\n      INTEGER            IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            ILAENV\n      EXTERNAL           LSAME, ILAENV\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SLASYF, SSYTF2, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, work, info, a = NumRu::Lapack.ssytrf( uplo, a, lwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_lwork = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  lwork = NUM2INT(rblapack_lwork);
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  ssytrf_(&uplo, &n, a, &lda, ipiv, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ipiv, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_ssytrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssytrf", rblapack_ssytrf, -1);
}
ruby-lapack-1.7.2/ext/slaqsy.c0000644000175000017500000001223012502221016016034 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaqsy_(char* uplo, integer* n, real* a, integer* lda, real* s, real* scond, real* amax, char* equed);


static VALUE
rblapack_slaqsy(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_scond;
  real scond; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_a_out__;
  real *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  equed, a = NumRu::Lapack.slaqsy( uplo, a, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )\n\n*  Purpose\n*  =======\n*\n*  SLAQSY equilibrates a symmetric matrix A using the scaling factors\n*  in the vector S.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          n by n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n by n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if EQUED = 'Y', the equilibrated matrix:\n*          diag(S) * A * diag(S).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(N,1).\n*\n*  S       (input) REAL array, dimension (N)\n*          The scale factors for A.\n*\n*  SCOND   (input) REAL\n*          Ratio of the smallest S(i) to the largest S(i).\n*\n*  AMAX    (input) REAL\n*          Absolute value of largest matrix entry.\n*\n*  EQUED   (output) CHARACTER*1\n*          Specifies whether or not equilibration was done.\n*          = 'N':  No equilibration.\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*\n*  Internal Parameters\n*  ===================\n*\n*  THRESH is a threshold value used to decide if scaling should be done\n*  based on the ratio of the scaling factors.  If SCOND < THRESH,\n*  scaling is done.\n*\n*  LARGE and SMALL are threshold values used to decide if scaling should\n*  be done based on the absolute size of the largest matrix element.\n*  If AMAX > LARGE or AMAX < SMALL, scaling is done.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  equed, a = NumRu::Lapack.slaqsy( uplo, a, s, scond, amax, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_s = argv[2];
  rblapack_scond = argv[3];
  rblapack_amax = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (3th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_s);
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  amax = (real)NUM2DBL(rblapack_amax);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of s");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  scond = (real)NUM2DBL(rblapack_scond);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  slaqsy_(&uplo, &n, a, &lda, s, &scond, &amax, &equed);

  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(2, rblapack_equed, rblapack_a);
}

void
init_lapack_slaqsy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaqsy", rblapack_slaqsy, -1);
}
ruby-lapack-1.7.2/ext/zhbgvd.c0000644000175000017500000003117212502221013016007 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhbgvd_(char* jobz, char* uplo, integer* n, integer* ka, integer* kb, doublecomplex* ab, integer* ldab, doublecomplex* bb, integer* ldbb, doublereal* w, doublecomplex* z, integer* ldz, doublecomplex* work, integer* lwork, doublereal* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_zhbgvd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ka;
  integer ka; 
  VALUE rblapack_kb;
  integer kb; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_bb;
  doublecomplex *bb; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_lrwork;
  integer lrwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_rwork;
  doublereal *rwork; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublecomplex *ab_out__;
  VALUE rblapack_bb_out__;
  doublecomplex *bb_out__;

  integer ldab;
  integer n;
  integer ldbb;
  integer ldz;

  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  w, z, work, rwork, iwork, info, ab, bb = NumRu::Lapack.zhbgvd( jobz, uplo, ka, kb, ab, bb, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHBGVD computes all the eigenvalues, and optionally, the eigenvectors\n*  of a complex generalized Hermitian-definite banded eigenproblem, of\n*  the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian\n*  and banded, and B is also positive definite.  If eigenvectors are\n*  desired, it uses a divide and conquer algorithm.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  KA      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n*  KB      (input) INTEGER\n*          The number of superdiagonals of the matrix B if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n*  AB      (input/output) COMPLEX*16 array, dimension (LDAB, N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix A, stored in the first ka+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).\n*\n*          On exit, the contents of AB are destroyed.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KA+1.\n*\n*  BB      (input/output) COMPLEX*16 array, dimension (LDBB, N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix B, stored in the first kb+1 rows of the array.  The\n*          j-th column of B is stored in the j-th column of the array BB\n*          as follows:\n*          if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n*          if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb).\n*\n*          On exit, the factor S from the split Cholesky factorization\n*          B = S**H*S, as returned by ZPBSTF.\n*\n*  LDBB    (input) INTEGER\n*          The leading dimension of the array BB.  LDBB >= KB+1.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) COMPLEX*16 array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n*          eigenvectors, with the i-th column of Z holding the\n*          eigenvector associated with W(i). The eigenvectors are\n*          normalized so that Z**H*B*Z = I.\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= N.\n*\n*  WORK    (workspace/output) COMPLEX*16 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*          If N <= 1,               LWORK >= 1.\n*          If JOBZ = 'N' and N > 1, LWORK >= N.\n*          If JOBZ = 'V' and N > 1, LWORK >= 2*N**2.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal sizes of the WORK, RWORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  RWORK   (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))\n*          On exit, if INFO=0, RWORK(1) returns the optimal LRWORK.\n*\n*  LRWORK  (input) INTEGER\n*          The dimension of array RWORK.\n*          If N <= 1,               LRWORK >= 1.\n*          If JOBZ = 'N' and N > 1, LRWORK >= N.\n*          If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.\n*\n*          If LRWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO=0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of array IWORK.\n*          If JOBZ = 'N' or N <= 1, LIWORK >= 1.\n*          If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK 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, and i is:\n*             <= N:  the algorithm failed to converge:\n*                    i off-diagonal elements of an intermediate\n*                    tridiagonal form did not converge to zero;\n*             > N:   if INFO = N + i, for 1 <= i <= N, then ZPBSTF\n*                    returned INFO = i: B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, work, rwork, iwork, info, ab, bb = NumRu::Lapack.zhbgvd( jobz, uplo, ka, kb, ab, bb, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_ka = argv[2];
  rblapack_kb = argv[3];
  rblapack_ab = argv[4];
  rblapack_bb = argv[5];
  if (argc == 9) {
    rblapack_lwork = argv[6];
    rblapack_lrwork = argv[7];
    rblapack_liwork = argv[8];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_lrwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  ka = NUM2INT(rblapack_ka);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_bb))
    rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
  if (NA_RANK(rblapack_bb) != 2)
    rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
  ldbb = NA_SHAPE0(rblapack_bb);
  if (NA_SHAPE1(rblapack_bb) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of bb must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_bb) != NA_DCOMPLEX)
    rblapack_bb = na_change_type(rblapack_bb, NA_DCOMPLEX);
  bb = NA_PTR_TYPE(rblapack_bb, doublecomplex*);
  if (rblapack_lrwork == Qnil)
    lrwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
  else {
    lrwork = NUM2INT(rblapack_lrwork);
  }
  ldz = lsame_(&jobz,"V") ? n : 1;
  kb = NUM2INT(rblapack_kb);
  if (rblapack_liwork == Qnil)
    liwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  if (rblapack_lwork == Qnil)
    lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 2*n*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lrwork);
    rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
  MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldbb;
    shape[1] = n;
    rblapack_bb_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  bb_out__ = NA_PTR_TYPE(rblapack_bb_out__, doublecomplex*);
  MEMCPY(bb_out__, bb, doublecomplex, NA_TOTAL(rblapack_bb));
  rblapack_bb = rblapack_bb_out__;
  bb = bb_out__;

  zhbgvd_(&jobz, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, w, z, &ldz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_w, rblapack_z, rblapack_work, rblapack_rwork, rblapack_iwork, rblapack_info, rblapack_ab, rblapack_bb);
}

void
init_lapack_zhbgvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhbgvd", rblapack_zhbgvd, -1);
}
ruby-lapack-1.7.2/ext/chbev.c0000644000175000017500000001363312502221022015614 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chbev_(char* jobz, char* uplo, integer* n, integer* kd, complex* ab, integer* ldab, real* w, complex* z, integer* ldz, complex* work, real* rwork, integer* info);


static VALUE
rblapack_chbev(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  complex *ab_out__;
  complex *work;
  real *rwork;

  integer ldab;
  integer n;
  integer ldz;

  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  w, z, info, ab = NumRu::Lapack.chbev( jobz, uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHBEV computes all the eigenvalues and, optionally, eigenvectors of\n*  a complex Hermitian band matrix A.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) COMPLEX array, dimension (LDAB, N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*          On exit, AB is overwritten by values generated during the\n*          reduction to tridiagonal form.  If UPLO = 'U', the first\n*          superdiagonal and the diagonal of the tridiagonal matrix T\n*          are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n*          the diagonal and first subdiagonal of T are returned in the\n*          first two rows of AB.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD + 1.\n*\n*  W       (output) REAL array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) COMPLEX array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n*          eigenvectors of the matrix A, with the i-th column of Z\n*          holding the eigenvector associated with W(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace) COMPLEX array, dimension (N)\n*\n*  RWORK   (workspace) REAL array, dimension (max(1,3*N-2))\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 algorithm failed to converge; i\n*                off-diagonal elements of an intermediate tridiagonal\n*                form did not converge to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, info, ab = NumRu::Lapack.chbev( jobz, uplo, kd, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_kd = argv[2];
  rblapack_ab = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  kd = NUM2INT(rblapack_kd);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
  MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  work = ALLOC_N(complex, (n));
  rwork = ALLOC_N(real, (MAX(1,3*n-2)));

  chbev_(&jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_w, rblapack_z, rblapack_info, rblapack_ab);
}

void
init_lapack_chbev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chbev", rblapack_chbev, -1);
}
ruby-lapack-1.7.2/ext/shgeqz.c0000644000175000017500000003644212502221014016032 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID shgeqz_(char* job, char* compq, char* compz, integer* n, integer* ilo, integer* ihi, real* h, integer* ldh, real* t, integer* ldt, real* alphar, real* alphai, real* beta, real* q, integer* ldq, real* z, integer* ldz, real* work, integer* lwork, integer* info);


static VALUE
rblapack_shgeqz(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_compq;
  char compq; 
  VALUE rblapack_compz;
  char compz; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_h;
  real *h; 
  VALUE rblapack_t;
  real *t; 
  VALUE rblapack_q;
  real *q; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_alphar;
  real *alphar; 
  VALUE rblapack_alphai;
  real *alphai; 
  VALUE rblapack_beta;
  real *beta; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_h_out__;
  real *h_out__;
  VALUE rblapack_t_out__;
  real *t_out__;
  VALUE rblapack_q_out__;
  real *q_out__;
  VALUE rblapack_z_out__;
  real *z_out__;

  integer ldh;
  integer n;
  integer ldt;
  integer ldq;
  integer ldz;

  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  alphar, alphai, beta, work, info, h, t, q, z = NumRu::Lapack.shgeqz( job, compq, compz, ilo, ihi, h, t, q, z, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SHGEQZ computes the eigenvalues of a real matrix pair (H,T),\n*  where H is an upper Hessenberg matrix and T is upper triangular,\n*  using the double-shift QZ method.\n*  Matrix pairs of this type are produced by the reduction to\n*  generalized upper Hessenberg form of a real matrix pair (A,B):\n*\n*     A = Q1*H*Z1**T,  B = Q1*T*Z1**T,\n*\n*  as computed by SGGHRD.\n*\n*  If JOB='S', then the Hessenberg-triangular pair (H,T) is\n*  also reduced to generalized Schur form,\n*  \n*     H = Q*S*Z**T,  T = Q*P*Z**T,\n*  \n*  where Q and Z are orthogonal matrices, P is an upper triangular\n*  matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2\n*  diagonal blocks.\n*\n*  The 1-by-1 blocks correspond to real eigenvalues of the matrix pair\n*  (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of\n*  eigenvalues.\n*\n*  Additionally, the 2-by-2 upper triangular diagonal blocks of P\n*  corresponding to 2-by-2 blocks of S are reduced to positive diagonal\n*  form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0,\n*  P(j,j) > 0, and P(j+1,j+1) > 0.\n*\n*  Optionally, the orthogonal matrix Q from the generalized Schur\n*  factorization may be postmultiplied into an input matrix Q1, and the\n*  orthogonal matrix Z may be postmultiplied into an input matrix Z1.\n*  If Q1 and Z1 are the orthogonal matrices from SGGHRD that reduced\n*  the matrix pair (A,B) to generalized upper Hessenberg form, then the\n*  output matrices Q1*Q and Z1*Z are the orthogonal factors from the\n*  generalized Schur factorization of (A,B):\n*\n*     A = (Q1*Q)*S*(Z1*Z)**T,  B = (Q1*Q)*P*(Z1*Z)**T.\n*  \n*  To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently,\n*  of (A,B)) are computed as a pair of values (alpha,beta), where alpha is\n*  complex and beta real.\n*  If beta is nonzero, lambda = alpha / beta is an eigenvalue of the\n*  generalized nonsymmetric eigenvalue problem (GNEP)\n*     A*x = lambda*B*x\n*  and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the\n*  alternate form of the GNEP\n*     mu*A*y = B*y.\n*  Real eigenvalues can be read directly from the generalized Schur\n*  form: \n*    alpha = S(i,i), beta = P(i,i).\n*\n*  Ref: C.B. Moler & G.W. Stewart, \"An Algorithm for Generalized Matrix\n*       Eigenvalue Problems\", SIAM J. Numer. Anal., 10(1973),\n*       pp. 241--256.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          = 'E': Compute eigenvalues only;\n*          = 'S': Compute eigenvalues and the Schur form. \n*\n*  COMPQ   (input) CHARACTER*1\n*          = 'N': Left Schur vectors (Q) are not computed;\n*          = 'I': Q is initialized to the unit matrix and the matrix Q\n*                 of left Schur vectors of (H,T) is returned;\n*          = 'V': Q must contain an orthogonal matrix Q1 on entry and\n*                 the product Q1*Q is returned.\n*\n*  COMPZ   (input) CHARACTER*1\n*          = 'N': Right Schur vectors (Z) are not computed;\n*          = 'I': Z is initialized to the unit matrix and the matrix Z\n*                 of right Schur vectors of (H,T) is returned;\n*          = 'V': Z must contain an orthogonal matrix Z1 on entry and\n*                 the product Z1*Z is returned.\n*\n*  N       (input) INTEGER\n*          The order of the matrices H, T, Q, and Z.  N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          ILO and IHI mark the rows and columns of H which are in\n*          Hessenberg form.  It is assumed that A is already upper\n*          triangular in rows and columns 1:ILO-1 and IHI+1:N.\n*          If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.\n*\n*  H       (input/output) REAL array, dimension (LDH, N)\n*          On entry, the N-by-N upper Hessenberg matrix H.\n*          On exit, if JOB = 'S', H contains the upper quasi-triangular\n*          matrix S from the generalized Schur factorization;\n*          2-by-2 diagonal blocks (corresponding to complex conjugate\n*          pairs of eigenvalues) are returned in standard form, with\n*          H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0.\n*          If JOB = 'E', the diagonal blocks of H match those of S, but\n*          the rest of H is unspecified.\n*\n*  LDH     (input) INTEGER\n*          The leading dimension of the array H.  LDH >= max( 1, N ).\n*\n*  T       (input/output) REAL array, dimension (LDT, N)\n*          On entry, the N-by-N upper triangular matrix T.\n*          On exit, if JOB = 'S', T contains the upper triangular\n*          matrix P from the generalized Schur factorization;\n*          2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S\n*          are reduced to positive diagonal form, i.e., if H(j+1,j) is\n*          non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and\n*          T(j+1,j+1) > 0.\n*          If JOB = 'E', the diagonal blocks of T match those of P, but\n*          the rest of T is unspecified.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T.  LDT >= max( 1, N ).\n*\n*  ALPHAR  (output) REAL array, dimension (N)\n*          The real parts of each scalar alpha defining an eigenvalue\n*          of GNEP.\n*\n*  ALPHAI  (output) REAL array, dimension (N)\n*          The imaginary parts of each scalar alpha defining an\n*          eigenvalue of GNEP.\n*          If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n*          positive, then the j-th and (j+1)-st eigenvalues are a\n*          complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j).\n*\n*  BETA    (output) REAL array, dimension (N)\n*          The scalars beta that define the eigenvalues of GNEP.\n*          Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and\n*          beta = BETA(j) represent the j-th eigenvalue of the matrix\n*          pair (A,B), in one of the forms lambda = alpha/beta or\n*          mu = beta/alpha.  Since either lambda or mu may overflow,\n*          they should not, in general, be computed.\n*\n*  Q       (input/output) REAL array, dimension (LDQ, N)\n*          On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in\n*          the reduction of (A,B) to generalized Hessenberg form.\n*          On exit, if COMPZ = 'I', the orthogonal matrix of left Schur\n*          vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix\n*          of left Schur vectors of (A,B).\n*          Not referenced if COMPZ = 'N'.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.  LDQ >= 1.\n*          If COMPQ='V' or 'I', then LDQ >= N.\n*\n*  Z       (input/output) REAL array, dimension (LDZ, N)\n*          On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in\n*          the reduction of (A,B) to generalized Hessenberg form.\n*          On exit, if COMPZ = 'I', the orthogonal matrix of\n*          right Schur vectors of (H,T), and if COMPZ = 'V', the\n*          orthogonal matrix of right Schur vectors of (A,B).\n*          Not referenced if COMPZ = 'N'.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1.\n*          If COMPZ='V' or 'I', then LDZ >= N.\n*\n*  WORK    (workspace/output) REAL 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,N).\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*          = 1,...,N: the QZ iteration did not converge.  (H,T) is not\n*                     in Schur form, but ALPHAR(i), ALPHAI(i), and\n*                     BETA(i), i=INFO+1,...,N should be correct.\n*          = N+1,...,2*N: the shift calculation failed.  (H,T) is not\n*                     in Schur form, but ALPHAR(i), ALPHAI(i), and\n*                     BETA(i), i=INFO-N+1,...,N should be correct.\n*\n\n*  Further Details\n*  ===============\n*\n*  Iteration counters:\n*\n*  JITER  -- counts iterations.\n*  IITER  -- counts iterations run since ILAST was last\n*            changed.  This is therefore reset only when a 1-by-1 or\n*            2-by-2 block deflates off the bottom.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  alphar, alphai, beta, work, info, h, t, q, z = NumRu::Lapack.shgeqz( job, compq, compz, ilo, ihi, h, t, q, z, [: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_job = argv[0];
  rblapack_compq = argv[1];
  rblapack_compz = argv[2];
  rblapack_ilo = argv[3];
  rblapack_ihi = argv[4];
  rblapack_h = argv[5];
  rblapack_t = argv[6];
  rblapack_q = argv[7];
  rblapack_z = 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;
  }

  job = StringValueCStr(rblapack_job)[0];
  compz = StringValueCStr(rblapack_compz)[0];
  ihi = NUM2INT(rblapack_ihi);
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (7th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (7th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  n = NA_SHAPE1(rblapack_t);
  if (NA_TYPE(rblapack_t) != NA_SFLOAT)
    rblapack_t = na_change_type(rblapack_t, NA_SFLOAT);
  t = NA_PTR_TYPE(rblapack_t, real*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (9th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  if (NA_SHAPE1(rblapack_z) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of t");
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  compq = StringValueCStr(rblapack_compq)[0];
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (6th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  if (NA_SHAPE1(rblapack_h) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of t");
  if (NA_TYPE(rblapack_h) != NA_SFLOAT)
    rblapack_h = na_change_type(rblapack_h, NA_SFLOAT);
  h = NA_PTR_TYPE(rblapack_h, real*);
  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (8th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (8th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of t");
  if (NA_TYPE(rblapack_q) != NA_SFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
  q = NA_PTR_TYPE(rblapack_q, real*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  alphar = NA_PTR_TYPE(rblapack_alphar, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  alphai = NA_PTR_TYPE(rblapack_alphai, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, real*);
  MEMCPY(h_out__, h, real, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = n;
    rblapack_t_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  t_out__ = NA_PTR_TYPE(rblapack_t_out__, real*);
  MEMCPY(t_out__, t, real, NA_TOTAL(rblapack_t));
  rblapack_t = rblapack_t_out__;
  t = t_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
  MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
  MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  shgeqz_(&job, &compq, &compz, &n, &ilo, &ihi, h, &ldh, t, &ldt, alphar, alphai, beta, q, &ldq, z, &ldz, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_work, rblapack_info, rblapack_h, rblapack_t, rblapack_q, rblapack_z);
}

void
init_lapack_shgeqz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "shgeqz", rblapack_shgeqz, -1);
}
ruby-lapack-1.7.2/ext/cgerq2.c0000644000175000017500000001041412502221024015704 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgerq2_(integer* m, integer* n, complex* a, integer* lda, complex* tau, complex* work, integer* info);


static VALUE
rblapack_cgerq2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  complex *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.cgerq2( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGERQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGERQ2 computes an RQ factorization of a complex m by n matrix A:\n*  A = R * 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) COMPLEX array, dimension (LDA,N)\n*          On entry, the m by n matrix A.\n*          On exit, if m <= n, the upper triangle of the subarray\n*          A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;\n*          if m >= n, the elements on and above the (m-n)-th subdiagonal\n*          contain the m by n upper trapezoidal matrix R; the remaining\n*          elements, with the array TAU, represent the unitary matrix\n*          Q as a product of elementary reflectors (see Further\n*          Details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  TAU     (output) COMPLEX array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace) COMPLEX 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(1)' H(2)' . . . H(k)', 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 complex scalar, and v is a complex vector with\n*  v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on\n*  exit in A(m-k+i,1:n-k+i-1), 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.cgerq2( 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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  m = lda;
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(complex, (m));

  cgerq2_(&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_cgerq2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgerq2", rblapack_cgerq2, -1);
}
ruby-lapack-1.7.2/ext/zhptri.c0000644000175000017500000001120712502221020016036 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhptri_(char* uplo, integer* n, doublecomplex* ap, integer* ipiv, doublecomplex* work, integer* info);


static VALUE
rblapack_zhptri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublecomplex *ap_out__;
  doublecomplex *work;

  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  info, ap = NumRu::Lapack.zhptri( uplo, ap, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHPTRI( UPLO, N, AP, IPIV, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHPTRI computes the inverse of a complex Hermitian indefinite matrix\n*  A in packed storage using the factorization A = U*D*U**H or\n*  A = L*D*L**H computed by ZHPTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**H;\n*          = 'L':  Lower triangular, form is A = L*D*L**H.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          On entry, the block diagonal matrix D and the multipliers\n*          used to obtain the factor U or L as computed by ZHPTRF,\n*          stored as a packed triangular matrix.\n*\n*          On exit, if INFO = 0, the (Hermitian) inverse of the original\n*          matrix, stored as a packed triangular matrix. The j-th column\n*          of inv(A) is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;\n*          if UPLO = 'L',\n*             AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by ZHPTRF.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (N)\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, D(i,i) = 0; the matrix is singular and its\n*               inverse could not be computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ap = NumRu::Lapack.zhptri( uplo, ap, ipiv, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_ipiv = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
  MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  work = ALLOC_N(doublecomplex, (n));

  zhptri_(&uplo, &n, ap, ipiv, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ap);
}

void
init_lapack_zhptri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhptri", rblapack_zhptri, -1);
}
ruby-lapack-1.7.2/ext/classq.c0000644000175000017500000000716512502221022016016 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID classq_(integer* n, complex* x, integer* incx, real* scale, real* sumsq);


static VALUE
rblapack_classq(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_scale;
  real scale; 
  VALUE rblapack_sumsq;
  real sumsq; 

  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  scale, sumsq = NumRu::Lapack.classq( x, incx, scale, sumsq, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLASSQ( N, X, INCX, SCALE, SUMSQ )\n\n*  Purpose\n*  =======\n*\n*  CLASSQ returns the values scl and ssq such that\n*\n*     ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,\n*\n*  where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is\n*  assumed to be at least unity and the value of ssq will then satisfy\n*\n*     1.0 .le. ssq .le. ( sumsq + 2*n ).\n*\n*  scale is assumed to be non-negative and scl returns the value\n*\n*     scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ),\n*            i\n*\n*  scale and sumsq must be supplied in SCALE and SUMSQ respectively.\n*  SCALE and SUMSQ are overwritten by scl and ssq respectively.\n*\n*  The routine makes only one pass through the vector X.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of elements to be used from the vector X.\n*\n*  X       (input) COMPLEX array, dimension (N)\n*          The vector x as described above.\n*             x( i )  = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.\n*\n*  INCX    (input) INTEGER\n*          The increment between successive values of the vector X.\n*          INCX > 0.\n*\n*  SCALE   (input/output) REAL\n*          On entry, the value  scale  in the equation above.\n*          On exit, SCALE is overwritten with the value  scl .\n*\n*  SUMSQ   (input/output) REAL\n*          On entry, the value  sumsq  in the equation above.\n*          On exit, SUMSQ is overwritten with the value  ssq .\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, sumsq = NumRu::Lapack.classq( x, incx, scale, sumsq, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_x = argv[0];
  rblapack_incx = argv[1];
  rblapack_scale = argv[2];
  rblapack_sumsq = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (1th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  scale = (real)NUM2DBL(rblapack_scale);
  incx = NUM2INT(rblapack_incx);
  sumsq = (real)NUM2DBL(rblapack_sumsq);

  classq_(&n, x, &incx, &scale, &sumsq);

  rblapack_scale = rb_float_new((double)scale);
  rblapack_sumsq = rb_float_new((double)sumsq);
  return rb_ary_new3(2, rblapack_scale, rblapack_sumsq);
}

void
init_lapack_classq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "classq", rblapack_classq, -1);
}
ruby-lapack-1.7.2/ext/zlahrd.c0000644000175000017500000001477212502221015016020 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlahrd_(integer* n, integer* k, integer* nb, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* t, integer* ldt, doublecomplex* y, integer* ldy);


static VALUE
rblapack_zlahrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_nb;
  integer nb; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_t;
  doublecomplex *t; 
  VALUE rblapack_y;
  doublecomplex *y; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;

  integer lda;
  integer ldt;
  integer ldy;

  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, t, y, a = NumRu::Lapack.zlahrd( n, k, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n*  Purpose\n*  =======\n*\n*  ZLAHRD reduces the first NB columns of a complex general n-by-(n-k+1)\n*  matrix A so that elements below the k-th subdiagonal are zero. The\n*  reduction is performed by a unitary similarity transformation\n*  Q' * A * Q. The routine returns the matrices V and T which determine\n*  Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n*\n*  This is an OBSOLETE auxiliary routine. \n*  This routine will be 'deprecated' in a  future release.\n*  Please use the new routine ZLAHR2 instead.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.\n*\n*  K       (input) INTEGER\n*          The offset for the reduction. Elements below the k-th\n*          subdiagonal in the first NB columns are reduced to zero.\n*\n*  NB      (input) INTEGER\n*          The number of columns to be reduced.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N-K+1)\n*          On entry, the n-by-(n-k+1) general matrix A.\n*          On exit, the elements on and above the k-th subdiagonal in\n*          the first NB columns are overwritten with the corresponding\n*          elements of the reduced matrix; the elements below the k-th\n*          subdiagonal, with the array TAU, represent the matrix Q as a\n*          product of elementary reflectors. The other columns of A are\n*          unchanged. See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  TAU     (output) COMPLEX*16 array, dimension (NB)\n*          The scalar factors of the elementary reflectors. See Further\n*          Details.\n*\n*  T       (output) COMPLEX*16 array, dimension (LDT,NB)\n*          The upper triangular matrix T.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T.  LDT >= NB.\n*\n*  Y       (output) COMPLEX*16 array, dimension (LDY,NB)\n*          The n-by-nb matrix Y.\n*\n*  LDY     (input) INTEGER\n*          The leading dimension of the array Y. LDY >= max(1,N).\n*\n\n*  Further Details\n*  ===============\n*\n*  The matrix Q is represented as a product of nb elementary reflectors\n*\n*     Q = H(1) H(2) . . . H(nb).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - tau * v * v'\n*\n*  where tau is a complex scalar, and v is a complex vector with\n*  v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n*  A(i+k+1:n,i), and tau in TAU(i).\n*\n*  The elements of the vectors v together form the (n-k+1)-by-nb matrix\n*  V which is needed, with T and Y, to apply the transformation to the\n*  unreduced part of the matrix, using an update of the form:\n*  A := (I - V*T*V') * (A - Y*V').\n*\n*  The contents of A on exit are illustrated by the following example\n*  with n = 7, k = 3 and nb = 2:\n*\n*     ( a   h   a   a   a )\n*     ( a   h   a   a   a )\n*     ( a   h   a   a   a )\n*     ( h   h   a   a   a )\n*     ( v1  h   a   a   a )\n*     ( v1  v2  a   a   a )\n*     ( v1  v2  a   a   a )\n*\n*  where a denotes an element of the original matrix A, h denotes a\n*  modified element of the upper Hessenberg matrix H, and vi denotes an\n*  element of the vector defining H(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, t, y, a = NumRu::Lapack.zlahrd( n, k, nb, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_n = argv[0];
  rblapack_k = argv[1];
  rblapack_nb = argv[2];
  rblapack_a = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  nb = NUM2INT(rblapack_nb);
  ldy = MAX(1,n);
  k = NUM2INT(rblapack_k);
  ldt = nb;
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != (n-k+1))
    rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", n-k+1);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,nb);
    rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = MAX(1,nb);
    rblapack_t = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  t = NA_PTR_TYPE(rblapack_t, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldy;
    shape[1] = MAX(1,nb);
    rblapack_y = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  y = NA_PTR_TYPE(rblapack_y, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n-k+1;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zlahrd_(&n, &k, &nb, a, &lda, tau, t, &ldt, y, &ldy);

  return rb_ary_new3(4, rblapack_tau, rblapack_t, rblapack_y, rblapack_a);
}

void
init_lapack_zlahrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlahrd", rblapack_zlahrd, -1);
}
ruby-lapack-1.7.2/ext/zpbequ.c0000644000175000017500000001156112502221016016034 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zpbequ_(char* uplo, integer* n, integer* kd, doublecomplex* ab, integer* ldab, doublereal* s, doublereal* scond, doublereal* amax, integer* info);


static VALUE
rblapack_zpbequ(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_scond;
  doublereal scond; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_info;
  integer info; 

  integer ldab;
  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  s, scond, amax, info = NumRu::Lapack.zpbequ( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPBEQU computes row and column scalings intended to equilibrate a\n*  Hermitian positive definite band matrix A and reduce its condition\n*  number (with respect to the two-norm).  S contains the scale factors,\n*  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n*  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This\n*  choice of S puts the condition number of B within a factor N of the\n*  smallest possible condition number over all possible diagonal\n*  scalings.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangular of A is stored;\n*          = 'L':  Lower triangular of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)\n*          The upper or lower triangle of the Hermitian band matrix A,\n*          stored in the first KD+1 rows of the array.  The j-th column\n*          of A is stored in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*  LDAB     (input) INTEGER\n*          The leading dimension of the array A.  LDAB >= KD+1.\n*\n*  S       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, S contains the scale factors for A.\n*\n*  SCOND   (output) DOUBLE PRECISION\n*          If INFO = 0, S contains the ratio of the smallest S(i) to\n*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too\n*          large nor too small, it is not worth scaling by S.\n*\n*  AMAX    (output) DOUBLE PRECISION\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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 is nonpositive.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, scond, amax, info = NumRu::Lapack.zpbequ( uplo, kd, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  kd = NUM2INT(rblapack_kd);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, doublereal*);

  zpbequ_(&uplo, &n, &kd, ab, &ldab, s, &scond, &amax, &info);

  rblapack_scond = rb_float_new((double)scond);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
}

void
init_lapack_zpbequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zpbequ", rblapack_zpbequ, -1);
}
ruby-lapack-1.7.2/ext/zlanht.c0000644000175000017500000000746412502221016016035 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal zlanht_(char* norm, integer* n, doublereal* d, doublecomplex* e);


static VALUE
rblapack_zlanht(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublecomplex *e; 
  VALUE rblapack___out__;
  doublereal __out__; 

  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  __out__ = NumRu::Lapack.zlanht( norm, d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION ZLANHT( NORM, N, D, E )\n\n*  Purpose\n*  =======\n*\n*  ZLANHT  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  complex Hermitian tridiagonal matrix A.\n*\n*  Description\n*  ===========\n*\n*  ZLANHT returns the value\n*\n*     ZLANHT = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in ZLANHT as described\n*          above.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, ZLANHT is\n*          set to zero.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          The diagonal elements of A.\n*\n*  E       (input) COMPLEX*16 array, dimension (N-1)\n*          The (n-1) sub-diagonal or super-diagonal elements of A.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.zlanht( norm, d, e, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_norm = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DCOMPLEX)
    rblapack_e = na_change_type(rblapack_e, NA_DCOMPLEX);
  e = NA_PTR_TYPE(rblapack_e, doublecomplex*);

  __out__ = zlanht_(&norm, &n, d, e);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_zlanht(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlanht", rblapack_zlanht, -1);
}
ruby-lapack-1.7.2/ext/dtbtrs.c0000644000175000017500000001322012502221026016023 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtbtrs_(char* uplo, char* trans, char* diag, integer* n, integer* kd, integer* nrhs, doublereal* ab, integer* ldab, doublereal* b, integer* ldb, integer* info);


static VALUE
rblapack_dtbtrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublereal *b_out__;

  integer ldab;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.dtbtrs( uplo, trans, diag, kd, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTBTRS solves a triangular system of the form\n*\n*     A * X = B  or  A**T * X = B,\n*\n*  where A is a triangular band matrix of order N, and B is an\n*  N-by NRHS matrix.  A check is made to verify that A is nonsingular.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form the system of equations:\n*          = 'N':  A * X = B  (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals or subdiagonals of the\n*          triangular band matrix A.  KD >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)\n*          The upper or lower triangular band matrix A, stored in the\n*          first kd+1 rows of AB.  The j-th column of A is stored\n*          in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*          If DIAG = 'U', the diagonal elements of A are not referenced\n*          and are assumed to be 1.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, if INFO = 0, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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 A is zero,\n*                indicating that the matrix is singular and the\n*                solutions X have not been computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.dtbtrs( uplo, trans, diag, kd, ab, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_kd = argv[3];
  rblapack_ab = argv[4];
  rblapack_b = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  kd = NUM2INT(rblapack_kd);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dtbtrs_(&uplo, &trans, &diag, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_dtbtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtbtrs", rblapack_dtbtrs, -1);
}
ruby-lapack-1.7.2/ext/dlarz.c0000644000175000017500000001232412502221017015641 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlarz_(char* side, integer* m, integer* n, integer* l, doublereal* v, integer* incv, doublereal* tau, doublereal* c, integer* ldc, doublereal* work);


static VALUE
rblapack_dlarz(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_v;
  doublereal *v; 
  VALUE rblapack_incv;
  integer incv; 
  VALUE rblapack_tau;
  doublereal tau; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_c_out__;
  doublereal *c_out__;
  doublereal *work;

  integer ldc;
  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  c = NumRu::Lapack.dlarz( side, m, l, v, incv, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK )\n\n*  Purpose\n*  =======\n*\n*  DLARZ applies a real elementary reflector H to a real M-by-N\n*  matrix C, from either the left or the right. H is represented in the\n*  form\n*\n*        H = I - tau * v * v'\n*\n*  where tau is a real scalar and v is a real vector.\n*\n*  If tau = 0, then H is taken to be the unit matrix.\n*\n*\n*  H is a product of k elementary reflectors as returned by DTZRZF.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': form  H * C\n*          = 'R': form  C * H\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C.\n*\n*  L       (input) INTEGER\n*          The number of entries of the vector V containing\n*          the meaningful part of the Householder vectors.\n*          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n*  V       (input) DOUBLE PRECISION array, dimension (1+(L-1)*abs(INCV))\n*          The vector v in the representation of H as returned by\n*          DTZRZF. V is not used if TAU = 0.\n*\n*  INCV    (input) INTEGER\n*          The increment between elements of v. INCV <> 0.\n*\n*  TAU     (input) DOUBLE PRECISION\n*          The value tau in the representation of H.\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n*          or C * H if SIDE = 'R'.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension\n*                         (N) if SIDE = 'L'\n*                      or (M) if SIDE = 'R'\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.dlarz( side, m, l, v, incv, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_side = argv[0];
  rblapack_m = argv[1];
  rblapack_l = argv[2];
  rblapack_v = argv[3];
  rblapack_incv = argv[4];
  rblapack_tau = argv[5];
  rblapack_c = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  l = NUM2INT(rblapack_l);
  incv = NUM2INT(rblapack_incv);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  m = NUM2INT(rblapack_m);
  tau = NUM2DBL(rblapack_tau);
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (4th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 1)
    rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_v) != (1+(l-1)*abs(incv)))
    rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1+(l-1)*abs(incv));
  if (NA_TYPE(rblapack_v) != NA_DFLOAT)
    rblapack_v = na_change_type(rblapack_v, NA_DFLOAT);
  v = NA_PTR_TYPE(rblapack_v, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  dlarz_(&side, &m, &n, &l, v, &incv, &tau, c, &ldc, work);

  free(work);
  return rblapack_c;
}

void
init_lapack_dlarz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlarz", rblapack_dlarz, -1);
}
ruby-lapack-1.7.2/ext/dorcsd.c0000644000175000017500000002766212502221026016016 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dorcsd_(char* jobu1, char* jobu2, char* jobv1t, char* jobv2t, char* trans, char* signs, integer* m, integer* p, integer* q, doublereal* x11, integer* ldx11, doublereal* x12, integer* ldx12, doublereal* x21, integer* ldx21, doublereal* x22, integer* ldx22, doublereal* theta, doublereal* u1, integer* ldu1, doublereal* u2, integer* ldu2, doublereal* v1t, integer* ldv1t, doublereal* v2t, integer* ldv2t, doublereal* work, integer* lwork, integer* iwork, integer* info);


static VALUE
rblapack_dorcsd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobu1;
  char jobu1; 
  VALUE rblapack_jobu2;
  char jobu2; 
  VALUE rblapack_jobv1t;
  char jobv1t; 
  VALUE rblapack_jobv2t;
  char jobv2t; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_signs;
  char signs; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_x11;
  doublereal *x11; 
  VALUE rblapack_x12;
  doublereal *x12; 
  VALUE rblapack_x21;
  doublereal *x21; 
  VALUE rblapack_x22;
  doublereal *x22; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_theta;
  doublereal *theta; 
  VALUE rblapack_u1;
  doublereal *u1; 
  VALUE rblapack_u2;
  doublereal *u2; 
  VALUE rblapack_v1t;
  doublereal *v1t; 
  VALUE rblapack_v2t;
  doublereal *v2t; 
  VALUE rblapack_info;
  integer info; 
  doublereal *work;
  integer *iwork;

  integer ldx11;
  integer q;
  integer ldx12;
  integer ldx21;
  integer ldx22;
  integer p;
  integer ldv2t;
  integer ldv1t;
  integer ldu1;
  integer ldu2;

  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  theta, u1, u2, v1t, v2t, info = NumRu::Lapack.dorcsd( jobu1, jobu2, jobv1t, jobv2t, trans, signs, m, x11, x12, x21, x22, lwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      RECURSIVE SUBROUTINE DORCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, WORK, LWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DORCSD computes the CS decomposition of an M-by-M partitioned\n*  orthogonal matrix X:\n*\n*                                  [  I  0  0 |  0  0  0 ]\n*                                  [  0  C  0 |  0 -S  0 ]\n*      [ X11 | X12 ]   [ U1 |    ] [  0  0  0 |  0  0 -I ] [ V1 |    ]**T\n*  X = [-----------] = [---------] [---------------------] [---------]   .\n*      [ X21 | X22 ]   [    | U2 ] [  0  0  0 |  I  0  0 ] [    | V2 ]\n*                                  [  0  S  0 |  0  C  0 ]\n*                                  [  0  0  I |  0  0  0 ]\n*\n*  X11 is P-by-Q. The orthogonal matrices U1, U2, V1, and V2 are P-by-P,\n*  (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are\n*  R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in\n*  which R = MIN(P,M-P,Q,M-Q).\n*\n\n*  Arguments\n*  =========\n*\n*  JOBU1   (input) CHARACTER\n*          = 'Y':      U1 is computed;\n*          otherwise:  U1 is not computed.\n*\n*  JOBU2   (input) CHARACTER\n*          = 'Y':      U2 is computed;\n*          otherwise:  U2 is not computed.\n*\n*  JOBV1T  (input) CHARACTER\n*          = 'Y':      V1T is computed;\n*          otherwise:  V1T is not computed.\n*\n*  JOBV2T  (input) CHARACTER\n*          = 'Y':      V2T is computed;\n*          otherwise:  V2T is not computed.\n*\n*  TRANS   (input) CHARACTER\n*          = 'T':      X, U1, U2, V1T, and V2T are stored in row-major\n*                      order;\n*          otherwise:  X, U1, U2, V1T, and V2T are stored in column-\n*                      major order.\n*\n*  SIGNS   (input) CHARACTER\n*          = 'O':      The lower-left block is made nonpositive (the\n*                      \"other\" convention);\n*          otherwise:  The upper-right block is made nonpositive (the\n*                      \"default\" convention).\n*\n*  M       (input) INTEGER\n*          The number of rows and columns in X.\n*\n*  P       (input) INTEGER\n*          The number of rows in X11 and X12. 0 <= P <= M.\n*\n*  Q       (input) INTEGER\n*          The number of columns in X11 and X21. 0 <= Q <= M.\n*\n*  X       (input/workspace) DOUBLE PRECISION array, dimension (LDX,M)\n*          On entry, the orthogonal matrix whose CSD is desired.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of X. LDX >= MAX(1,M).\n*\n*  THETA   (output) DOUBLE PRECISION array, dimension (R), in which R =\n*          MIN(P,M-P,Q,M-Q).\n*          C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and\n*          S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).\n*\n*  U1      (output) DOUBLE PRECISION array, dimension (P)\n*          If JOBU1 = 'Y', U1 contains the P-by-P orthogonal matrix U1.\n*\n*  LDU1    (input) INTEGER\n*          The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=\n*          MAX(1,P).\n*\n*  U2      (output) DOUBLE PRECISION array, dimension (M-P)\n*          If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) orthogonal\n*          matrix U2.\n*\n*  LDU2    (input) INTEGER\n*          The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=\n*          MAX(1,M-P).\n*\n*  V1T     (output) DOUBLE PRECISION array, dimension (Q)\n*          If JOBV1T = 'Y', V1T contains the Q-by-Q matrix orthogonal\n*          matrix V1**T.\n*\n*  LDV1T   (input) INTEGER\n*          The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=\n*          MAX(1,Q).\n*\n*  V2T     (output) DOUBLE PRECISION array, dimension (M-Q)\n*          If JOBV2T = 'Y', V2T contains the (M-Q)-by-(M-Q) orthogonal\n*          matrix V2**T.\n*\n*  LDV2T   (input) INTEGER\n*          The leading dimension of V2T. If JOBV2T = 'Y', LDV2T >=\n*          MAX(1,M-Q).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*          If INFO > 0 on exit, WORK(2:R) contains the values PHI(1),\n*          ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),\n*          define the matrix in intermediate bidiagonal-block form\n*          remaining after nonconvergence. INFO specifies the number\n*          of nonzero PHI's.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK.\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*  IWORK   (workspace) INTEGER array, dimension (M-Q)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit.\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          > 0:  DBBCSD did not converge. See the description of WORK\n*                above for details.\n*\n*  Reference\n*  =========\n*\n*  [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.\n*      Algorithms, 50(1):33-65, 2009.\n*\n\n*  ===================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  theta, u1, u2, v1t, v2t, info = NumRu::Lapack.dorcsd( jobu1, jobu2, jobv1t, jobv2t, trans, signs, m, x11, x12, x21, x22, lwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_jobu1 = argv[0];
  rblapack_jobu2 = argv[1];
  rblapack_jobv1t = argv[2];
  rblapack_jobv2t = argv[3];
  rblapack_trans = argv[4];
  rblapack_signs = argv[5];
  rblapack_m = argv[6];
  rblapack_x11 = argv[7];
  rblapack_x12 = argv[8];
  rblapack_x21 = argv[9];
  rblapack_x22 = argv[10];
  rblapack_lwork = argv[11];
  if (argc == 12) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobu1 = StringValueCStr(rblapack_jobu1)[0];
  jobv1t = StringValueCStr(rblapack_jobv1t)[0];
  trans = StringValueCStr(rblapack_trans)[0];
  m = NUM2INT(rblapack_m);
  lwork = NUM2INT(rblapack_lwork);
  jobu2 = StringValueCStr(rblapack_jobu2)[0];
  signs = StringValueCStr(rblapack_signs)[0];
  jobv2t = StringValueCStr(rblapack_jobv2t)[0];
  if (!NA_IsNArray(rblapack_x11))
    rb_raise(rb_eArgError, "x11 (8th argument) must be NArray");
  if (NA_RANK(rblapack_x11) != 2)
    rb_raise(rb_eArgError, "rank of x11 (8th argument) must be %d", 2);
  ldx11 = NA_SHAPE0(rblapack_x11);
  q = NA_SHAPE1(rblapack_x11);
  if (NA_TYPE(rblapack_x11) != NA_DFLOAT)
    rblapack_x11 = na_change_type(rblapack_x11, NA_DFLOAT);
  x11 = NA_PTR_TYPE(rblapack_x11, doublereal*);
  p = ldx11;
  ldx21 = p;
  if (!NA_IsNArray(rblapack_x21))
    rb_raise(rb_eArgError, "x21 (10th argument) must be NArray");
  if (NA_RANK(rblapack_x21) != 2)
    rb_raise(rb_eArgError, "rank of x21 (10th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_x21) != ldx21)
    rb_raise(rb_eRuntimeError, "shape 0 of x21 must be p");
  if (NA_SHAPE1(rblapack_x21) != q)
    rb_raise(rb_eRuntimeError, "shape 1 of x21 must be the same as shape 1 of x11");
  if (NA_TYPE(rblapack_x21) != NA_DFLOAT)
    rblapack_x21 = na_change_type(rblapack_x21, NA_DFLOAT);
  x21 = NA_PTR_TYPE(rblapack_x21, doublereal*);
  ldv2t = lsame_(&jobv2t,"Y") ? MAX(1,m-q) : 0;
  ldu1 = lsame_(&jobu1,"Y") ? MAX(1,p) : 0;
  ldx12 = p;
  if (!NA_IsNArray(rblapack_x12))
    rb_raise(rb_eArgError, "x12 (9th argument) must be NArray");
  if (NA_RANK(rblapack_x12) != 2)
    rb_raise(rb_eArgError, "rank of x12 (9th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_x12) != ldx12)
    rb_raise(rb_eRuntimeError, "shape 0 of x12 must be p");
  if (NA_SHAPE1(rblapack_x12) != (m-q))
    rb_raise(rb_eRuntimeError, "shape 1 of x12 must be %d", m-q);
  if (NA_TYPE(rblapack_x12) != NA_DFLOAT)
    rblapack_x12 = na_change_type(rblapack_x12, NA_DFLOAT);
  x12 = NA_PTR_TYPE(rblapack_x12, doublereal*);
  ldv1t = lsame_(&jobv1t,"Y") ? MAX(1,q) : 0;
  ldx22 = p;
  if (!NA_IsNArray(rblapack_x22))
    rb_raise(rb_eArgError, "x22 (11th argument) must be NArray");
  if (NA_RANK(rblapack_x22) != 2)
    rb_raise(rb_eArgError, "rank of x22 (11th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_x22) != ldx22)
    rb_raise(rb_eRuntimeError, "shape 0 of x22 must be p");
  if (NA_SHAPE1(rblapack_x22) != (m-q))
    rb_raise(rb_eRuntimeError, "shape 1 of x22 must be %d", m-q);
  if (NA_TYPE(rblapack_x22) != NA_DFLOAT)
    rblapack_x22 = na_change_type(rblapack_x22, NA_DFLOAT);
  x22 = NA_PTR_TYPE(rblapack_x22, doublereal*);
  ldu2 = lsame_(&jobu2,"Y") ? MAX(1,m-p) : 0;
  {
    na_shape_t shape[1];
    shape[0] = MIN(MIN(MIN(p,m-p),q),m-q);
    rblapack_theta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  theta = NA_PTR_TYPE(rblapack_theta, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = p;
    rblapack_u1 = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  u1 = NA_PTR_TYPE(rblapack_u1, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = m-p;
    rblapack_u2 = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  u2 = NA_PTR_TYPE(rblapack_u2, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_v1t = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  v1t = NA_PTR_TYPE(rblapack_v1t, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = m-q;
    rblapack_v2t = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  v2t = NA_PTR_TYPE(rblapack_v2t, doublereal*);
  work = ALLOC_N(doublereal, (MAX(1,lwork)));
  iwork = ALLOC_N(integer, (m-q));

  dorcsd_(&jobu1, &jobu2, &jobv1t, &jobv2t, &trans, &signs, &m, &p, &q, x11, &ldx11, x12, &ldx12, x21, &ldx21, x22, &ldx22, theta, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, v2t, &ldv2t, work, &lwork, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_theta, rblapack_u1, rblapack_u2, rblapack_v1t, rblapack_v2t, rblapack_info);
}

void
init_lapack_dorcsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dorcsd", rblapack_dorcsd, -1);
}
ruby-lapack-1.7.2/ext/slasq5.c0000644000175000017500000001053112502221026015733 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slasq5_(integer* i0, integer* n0, real* z, integer* pp, real* tau, real* dmin, real* dmin1, real* dmin2, real* dn, real* dnm1, real* dnm2, logical* ieee);


static VALUE
rblapack_slasq5(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_i0;
  integer i0; 
  VALUE rblapack_n0;
  integer n0; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_pp;
  integer pp; 
  VALUE rblapack_tau;
  real tau; 
  VALUE rblapack_ieee;
  logical ieee; 
  VALUE rblapack_dmin;
  real dmin; 
  VALUE rblapack_dmin1;
  real dmin1; 
  VALUE rblapack_dmin2;
  real dmin2; 
  VALUE rblapack_dn;
  real dn; 
  VALUE rblapack_dnm1;
  real dnm1; 
  VALUE rblapack_dnm2;
  real dnm2; 


  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  dmin, dmin1, dmin2, dn, dnm1, dnm2 = NumRu::Lapack.slasq5( i0, n0, z, pp, tau, ieee, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, IEEE )\n\n*  Purpose\n*  =======\n*\n*  SLASQ5 computes one dqds transform in ping-pong form, one\n*  version for IEEE machines another for non IEEE machines.\n*\n\n*  Arguments\n*  =========\n*\n*  I0    (input) INTEGER\n*        First index.\n*\n*  N0    (input) INTEGER\n*        Last index.\n*\n*  Z     (input) REAL array, dimension ( 4*N )\n*        Z holds the qd array. EMIN is stored in Z(4*N0) to avoid\n*        an extra argument.\n*\n*  PP    (input) INTEGER\n*        PP=0 for ping, PP=1 for pong.\n*\n*  TAU   (input) REAL\n*        This is the shift.\n*\n*  DMIN  (output) REAL\n*        Minimum value of d.\n*\n*  DMIN1 (output) REAL\n*        Minimum value of d, excluding D( N0 ).\n*\n*  DMIN2 (output) REAL\n*        Minimum value of d, excluding D( N0 ) and D( N0-1 ).\n*\n*  DN    (output) REAL\n*        d(N0), the last value of d.\n*\n*  DNM1  (output) REAL\n*        d(N0-1).\n*\n*  DNM2  (output) REAL\n*        d(N0-2).\n*\n*  IEEE  (input) LOGICAL\n*        Flag for IEEE or non IEEE arithmetic.\n*\n\n*  =====================================================================\n*\n*     .. Parameter ..\n      REAL               ZERO\n      PARAMETER          ( ZERO = 0.0E0 )\n*     ..\n*     .. Local Scalars ..\n      INTEGER            J4, J4P2\n      REAL               D, EMIN, TEMP\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  dmin, dmin1, dmin2, dn, dnm1, dnm2 = NumRu::Lapack.slasq5( i0, n0, z, pp, tau, ieee, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_i0 = argv[0];
  rblapack_n0 = argv[1];
  rblapack_z = argv[2];
  rblapack_pp = argv[3];
  rblapack_tau = argv[4];
  rblapack_ieee = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  i0 = NUM2INT(rblapack_i0);
  pp = NUM2INT(rblapack_pp);
  ieee = (rblapack_ieee == Qtrue);
  n0 = NUM2INT(rblapack_n0);
  tau = (real)NUM2DBL(rblapack_tau);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (3th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != (4*n0))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 4*n0);
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);

  slasq5_(&i0, &n0, z, &pp, &tau, &dmin, &dmin1, &dmin2, &dn, &dnm1, &dnm2, &ieee);

  rblapack_dmin = rb_float_new((double)dmin);
  rblapack_dmin1 = rb_float_new((double)dmin1);
  rblapack_dmin2 = rb_float_new((double)dmin2);
  rblapack_dn = rb_float_new((double)dn);
  rblapack_dnm1 = rb_float_new((double)dnm1);
  rblapack_dnm2 = rb_float_new((double)dnm2);
  return rb_ary_new3(6, rblapack_dmin, rblapack_dmin1, rblapack_dmin2, rblapack_dn, rblapack_dnm1, rblapack_dnm2);
}

void
init_lapack_slasq5(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slasq5", rblapack_slasq5, -1);
}
ruby-lapack-1.7.2/ext/dlarfx.c0000644000175000017500000001060312502221022015777 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlarfx_(char* side, integer* m, integer* n, doublereal* v, doublereal* tau, doublereal* c, integer* ldc, doublereal* work);


static VALUE
rblapack_dlarfx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_v;
  doublereal *v; 
  VALUE rblapack_tau;
  doublereal tau; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_c_out__;
  doublereal *c_out__;
  doublereal *work;

  integer m;
  integer ldc;
  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  c = NumRu::Lapack.dlarfx( side, v, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )\n\n*  Purpose\n*  =======\n*\n*  DLARFX applies a real elementary reflector H to a real m by n\n*  matrix C, from either the left or the right. H is represented in the\n*  form\n*\n*        H = I - tau * v * v'\n*\n*  where tau is a real scalar and v is a real vector.\n*\n*  If tau = 0, then H is taken to be the unit matrix\n*\n*  This version uses inline code if H has order < 11.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': form  H * C\n*          = 'R': form  C * H\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C.\n*\n*  V       (input) DOUBLE PRECISION array, dimension (M) if SIDE = 'L'\n*                                     or (N) if SIDE = 'R'\n*          The vector v in the representation of H.\n*\n*  TAU     (input) DOUBLE PRECISION\n*          The value tau in the representation of H.\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n*          On entry, the m by n matrix C.\n*          On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n*          or C * H if SIDE = 'R'.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDA >= (1,M).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension\n*                      (N) if SIDE = 'L'\n*                      or (M) if SIDE = 'R'\n*          WORK is not referenced if H has order < 11.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.dlarfx( side, v, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_side = argv[0];
  rblapack_v = argv[1];
  rblapack_tau = argv[2];
  rblapack_c = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  tau = NUM2DBL(rblapack_tau);
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (2th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 1)
    rb_raise(rb_eArgError, "rank of v (2th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_v);
  if (NA_TYPE(rblapack_v) != NA_DFLOAT)
    rblapack_v = na_change_type(rblapack_v, NA_DFLOAT);
  v = NA_PTR_TYPE(rblapack_v, doublereal*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (4th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (4th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  dlarfx_(&side, &m, &n, v, &tau, c, &ldc, work);

  free(work);
  return rblapack_c;
}

void
init_lapack_dlarfx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlarfx", rblapack_dlarfx, -1);
}
ruby-lapack-1.7.2/ext/sgerqf.c0000644000175000017500000001347012502221014016014 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgerqf_(integer* m, integer* n, real* a, integer* lda, real* tau, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sgerqf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *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.sgerqf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGERQF computes an RQ factorization of a real M-by-N matrix A:\n*  A = R * 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) REAL array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit,\n*          if m <= n, the upper triangle of the subarray\n*          A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R;\n*          if m >= n, the elements on and above the (m-n)-th subdiagonal\n*          contain the M-by-N upper trapezoidal matrix R;\n*          the remaining elements, with the array TAU, represent the\n*          orthogonal matrix Q as a product of min(m,n) elementary\n*          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) REAL array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace/output) REAL 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\n*          the 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(1) H(2) . . . H(k), 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(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n*  A(m-k+i,1:n-k+i-1), and tau in TAU(i).\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY\n      INTEGER            I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n     $                   MU, NB, NBMIN, NU, NX\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SGERQ2, SLARFB, SLARFT, 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.sgerqf( 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;
  }

  m = NUM2INT(rblapack_m);
  if (rblapack_lwork == Qnil)
    lwork = m;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  sgerqf_(&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_sgerqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgerqf", rblapack_sgerqf, -1);
}
ruby-lapack-1.7.2/ext/cla_gercond_x.c0000644000175000017500000001650012502221013017310 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real cla_gercond_x_(char* trans, integer* n, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, complex* x, integer* info, complex* work, real* rwork);


static VALUE
rblapack_cla_gercond_x(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_rwork;
  real *rwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack___out__;
  real __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  info, __out__ = NumRu::Lapack.cla_gercond_x( trans, a, af, ipiv, x, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL FUNCTION CLA_GERCOND_X( TRANS, N, A, LDA, AF, LDAF, IPIV, X, INFO, WORK, RWORK )\n\n*  Purpose\n*  =======\n* \n*     CLA_GERCOND_X computes the infinity norm condition number of\n*     op(A) * diag(X) where X is a COMPLEX vector.\n*\n\n*  Arguments\n*  =========\n*\n*     TRANS   (input) CHARACTER*1\n*     Specifies the form of the system of equations:\n*       = 'N':  A * X = B     (No transpose)\n*       = 'T':  A**T * X = B  (Transpose)\n*       = 'C':  A**H * X = B  (Conjugate Transpose = Transpose)\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     A       (input) COMPLEX array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX array, dimension (LDAF,N)\n*     The factors L and U from the factorization\n*     A = P*L*U as computed by CGETRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     The pivot indices from the factorization A = P*L*U\n*     as computed by CGETRF; row i of the matrix was interchanged\n*     with row IPIV(i).\n*\n*     X       (input) COMPLEX array, dimension (N)\n*     The vector X in the formula op(A) * diag(X).\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit.\n*     i > 0:  The ith argument is invalid.\n*\n*     WORK    (input) COMPLEX array, dimension (2*N).\n*     Workspace.\n*\n*     RWORK   (input) REAL array, dimension (N).\n*     Workspace.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            NOTRANS\n      INTEGER            KASE\n      REAL               AINVNM, ANORM, TMP\n      INTEGER            I, J\n      COMPLEX            ZDUM\n*     ..\n*     .. Local Arrays ..\n      INTEGER            ISAVE( 3 )\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CLACN2, CGETRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX, REAL, AIMAG\n*     ..\n*     .. Statement Functions ..\n      REAL               CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, __out__ = NumRu::Lapack.cla_gercond_x( trans, a, af, ipiv, x, work, rwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_trans = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_x = argv[4];
  rblapack_work = argv[5];
  rblapack_rwork = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (5th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  if (!NA_IsNArray(rblapack_rwork))
    rb_raise(rb_eArgError, "rwork (7th argument) must be NArray");
  if (NA_RANK(rblapack_rwork) != 1)
    rb_raise(rb_eArgError, "rank of rwork (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_rwork) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_rwork) != NA_SFLOAT)
    rblapack_rwork = na_change_type(rblapack_rwork, NA_SFLOAT);
  rwork = NA_PTR_TYPE(rblapack_rwork, real*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (6th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
  if (NA_TYPE(rblapack_work) != NA_SCOMPLEX)
    rblapack_work = na_change_type(rblapack_work, NA_SCOMPLEX);
  work = NA_PTR_TYPE(rblapack_work, complex*);

  __out__ = cla_gercond_x_(&trans, &n, a, &lda, af, &ldaf, ipiv, x, &info, work, rwork);

  rblapack_info = INT2NUM(info);
  rblapack___out__ = rb_float_new((double)__out__);
  return rb_ary_new3(2, rblapack_info, rblapack___out__);
}

void
init_lapack_cla_gercond_x(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cla_gercond_x", rblapack_cla_gercond_x, -1);
}
ruby-lapack-1.7.2/ext/zptsv.c0000644000175000017500000001421712502221017015716 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zptsv_(integer* n, integer* nrhs, doublereal* d, doublecomplex* e, doublecomplex* b, integer* ldb, integer* info);


static VALUE
rblapack_zptsv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_nrhs;
  integer nrhs; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublecomplex *e; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_e_out__;
  doublecomplex *e_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer n;
  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  info, d, e, b = NumRu::Lapack.zptsv( nrhs, d, e, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPTSV( N, NRHS, D, E, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPTSV computes the solution to a complex system of linear equations\n*  A*X = B, where A is an N-by-N Hermitian positive definite tridiagonal\n*  matrix, and X and B are N-by-NRHS matrices.\n*\n*  A is factored as A = L*D*L**H, and the factored form of A is then\n*  used to solve the system of equations.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the n diagonal elements of the tridiagonal matrix\n*          A.  On exit, the n diagonal elements of the diagonal matrix\n*          D from the factorization A = L*D*L**H.\n*\n*  E       (input/output) COMPLEX*16 array, dimension (N-1)\n*          On entry, the (n-1) subdiagonal elements of the tridiagonal\n*          matrix A.  On exit, the (n-1) subdiagonal elements of the\n*          unit bidiagonal factor L from the L*D*L**H factorization of\n*          A.  E can also be regarded as the superdiagonal of the unit\n*          bidiagonal factor U from the U**H*D*U factorization of A.\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,N)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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 leading minor of order i is not\n*                positive definite, and the solution has not been\n*                computed.  The factorization has not been completed\n*                unless i = N.\n*\n\n*  =====================================================================\n*\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZPTTRF, ZPTTRS\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, e, b = NumRu::Lapack.zptsv( nrhs, d, e, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_nrhs = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  nrhs = NUM2INT(rblapack_nrhs);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DCOMPLEX)
    rblapack_e = na_change_type(rblapack_e, NA_DCOMPLEX);
  e = NA_PTR_TYPE(rblapack_e, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublecomplex*);
  MEMCPY(e_out__, e, doublecomplex, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zptsv_(&n, &nrhs, d, e, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_e, rblapack_b);
}

void
init_lapack_zptsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zptsv", rblapack_zptsv, -1);
}
ruby-lapack-1.7.2/ext/ssyrfsx.c0000644000175000017500000005136012502221025016250 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssyrfsx_(char* uplo, char* equed, integer* n, integer* nrhs, real* a, integer* lda, real* af, integer* ldaf, integer* ipiv, real* s, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, real* work, integer* iwork, integer* info);


static VALUE
rblapack_ssyrfsx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_af;
  real *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_params;
  real *params; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_err_bnds_norm;
  real *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  real *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_s_out__;
  real *s_out__;
  VALUE rblapack_x_out__;
  real *x_out__;
  VALUE rblapack_params_out__;
  real *params_out__;
  real *work;
  integer *iwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;
  integer nparams;
  integer n_err_bnds;

  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  rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.ssyrfsx( uplo, equed, a, af, ipiv, s, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     SSYRFSX improves the computed solution to a system of linear\n*     equations when the coefficient matrix is symmetric indefinite, and\n*     provides error bounds and backward error estimates for the\n*     solution.  In addition to normwise error bound, the code provides\n*     maximum componentwise error bound if possible.  See comments for\n*     ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.\n*\n*     The original system of linear equations may have been equilibrated\n*     before calling this routine, as described by arguments EQUED and S\n*     below. In this case, the solution and error bounds returned are\n*     for the original unequilibrated system.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     EQUED   (input) CHARACTER*1\n*     Specifies the form of equilibration that was done to A\n*     before calling this routine. This is needed to compute\n*     the solution and error bounds correctly.\n*       = 'N':  No equilibration\n*       = 'Y':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(S) * A * diag(S).\n*               The right hand side B has been changed accordingly.\n*\n*     N       (input) INTEGER\n*     The order of the matrix A.  N >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     A       (input) REAL array, dimension (LDA,N)\n*     The symmetric matrix A.  If UPLO = 'U', the leading N-by-N\n*     upper triangular part of A contains the upper triangular\n*     part of the matrix A, and the strictly lower triangular\n*     part of A is not referenced.  If UPLO = 'L', the leading\n*     N-by-N lower triangular part of A contains the lower\n*     triangular part of the matrix A, and the strictly upper\n*     triangular part of A is not referenced.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) REAL array, dimension (LDAF,N)\n*     The factored form of the matrix A.  AF contains the block\n*     diagonal matrix D and the multipliers used to obtain the\n*     factor U or L from the factorization A = U*D*U**T or A =\n*     L*D*L**T as computed by SSYTRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     Details of the interchanges and the block structure of D\n*     as determined by SSYTRF.\n*\n*     S       (input or output) REAL array, dimension (N)\n*     The scale factors for A.  If EQUED = 'Y', A is multiplied on\n*     the left and right by diag(S).  S is an input argument if FACT =\n*     'F'; otherwise, S is an output argument.  If FACT = 'F' and EQUED\n*     = 'Y', each element of S must be positive.  If S is output, each\n*     element of S is a power of the radix. If S is input, each element\n*     of S should be a power of the radix to ensure a reliable solution\n*     and error estimates. Scaling by powers of the radix does not cause\n*     rounding errors unless the result underflows or overflows.\n*     Rounding errors during scaling lead to refining with a matrix that\n*     is not equivalent to the input matrix, producing error estimates\n*     that may not be reliable.\n*\n*     B       (input) REAL array, dimension (LDB,NRHS)\n*     The right hand side matrix B.\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (input/output) REAL array, dimension (LDX,NRHS)\n*     On entry, the solution matrix X, as computed by SGETRS.\n*     On exit, the improved solution matrix X.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) REAL\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     BERR    (output) REAL array, dimension (NRHS)\n*     Componentwise relative backward error.  This is the\n*     componentwise relative backward error of each solution vector X(j)\n*     (i.e., the smallest relative change in any element of A or B that\n*     makes X(j) an exact solution).\n*\n*     N_ERR_BNDS (input) INTEGER\n*     Number of error bounds to return for each right hand side\n*     and each type (normwise or componentwise).  See ERR_BNDS_NORM and\n*     ERR_BNDS_COMP below.\n*\n*     ERR_BNDS_NORM  (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     NPARAMS (input) INTEGER\n*     Specifies the number of parameters set in PARAMS.  If .LE. 0, the\n*     PARAMS array is never referenced and default values are used.\n*\n*     PARAMS  (input / output) REAL array, dimension NPARAMS\n*     Specifies algorithm parameters.  If an entry is .LT. 0.0, then\n*     that entry will be filled with default value used for that\n*     parameter.  Only positions up to NPARAMS are accessed; defaults\n*     are used for higher-numbered parameters.\n*\n*       PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n*            refinement or not.\n*         Default: 1.0\n*            = 0.0 : No refinement is performed, and no error bounds are\n*                    computed.\n*            = 1.0 : Use the double-precision refinement algorithm,\n*                    possibly with doubled-single computations if the\n*                    compilation environment does not support DOUBLE\n*                    PRECISION.\n*              (other values are reserved for future use)\n*\n*       PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n*            computations allowed for refinement.\n*         Default: 10\n*         Aggressive: Set to 100 to permit convergence using approximate\n*                     factorizations or factorizations other than LU. If\n*                     the factorization uses a technique other than\n*                     Gaussian elimination, the guarantees in\n*                     err_bnds_norm and err_bnds_comp may no longer be\n*                     trustworthy.\n*\n*       PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n*            will attempt to find a solution with small componentwise\n*            relative error in the double-precision algorithm.  Positive\n*            is true, 0.0 is false.\n*         Default: 1.0 (attempt componentwise convergence)\n*\n*     WORK    (workspace) REAL array, dimension (4*N)\n*\n*     IWORK   (workspace) INTEGER array, dimension (N)\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit. The solution to every right-hand side is\n*         guaranteed.\n*       < 0:  If INFO = -i, the i-th argument had an illegal value\n*       > 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.ssyrfsx( uplo, equed, a, af, ipiv, s, b, x, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_uplo = argv[0];
  rblapack_equed = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_s = argv[5];
  rblapack_b = argv[6];
  rblapack_x = argv[7];
  rblapack_params = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (9th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_SFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
  params = NA_PTR_TYPE(rblapack_params, real*);
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (6th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  n_err_bnds = 3;
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
  af = NA_PTR_TYPE(rblapack_af, real*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (8th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (8th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
  MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
  MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(real, (4*n));
  iwork = ALLOC_N(integer, (n));

  ssyrfsx_(&uplo, &equed, &n, &nrhs, a, &lda, af, &ldaf, ipiv, s, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_s, rblapack_x, rblapack_params);
}

void
init_lapack_ssyrfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssyrfsx", rblapack_ssyrfsx, -1);
}
ruby-lapack-1.7.2/ext/ssygvx.c0000644000175000017500000003243112502221022016065 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssygvx_(integer* itype, char* jobz, char* range, char* uplo, integer* n, real* a, integer* lda, real* b, integer* ldb, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, real* z, integer* ldz, real* work, integer* lwork, integer* iwork, integer* ifail, integer* info);


static VALUE
rblapack_ssygvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_ldb;
  integer ldb; 
  VALUE rblapack_vl;
  real vl; 
  VALUE rblapack_vu;
  real vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  real abstol; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_ifail;
  integer *ifail; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_b_out__;
  real *b_out__;
  integer *iwork;

  integer lda;
  integer n;
  integer ldz;

  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  m, w, z, work, ifail, info, a, b = NumRu::Lapack.ssygvx( itype, jobz, range, uplo, a, b, ldb, vl, vu, il, iu, abstol, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSYGVX computes selected eigenvalues, and optionally, eigenvectors\n*  of a real generalized symmetric-definite eigenproblem, of the form\n*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A\n*  and B are assumed to be symmetric and B is also positive definite.\n*  Eigenvalues and eigenvectors can be selected by specifying either a\n*  range of values or a range of indices for the desired eigenvalues.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          Specifies the problem type to be solved:\n*          = 1:  A*x = (lambda)*B*x\n*          = 2:  A*B*x = (lambda)*x\n*          = 3:  B*A*x = (lambda)*x\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found.\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found.\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A and B are stored;\n*          = 'L':  Lower triangle of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix pencil (A,B).  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA, N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of A contains the\n*          upper triangular part of the matrix A.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of A contains\n*          the lower triangular part of the matrix A.\n*\n*          On exit, the lower triangle (if UPLO='L') or the upper\n*          triangle (if UPLO='U') of A, including the diagonal, is\n*          destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input/output) REAL array, dimension (LDA, N)\n*          On entry, the symmetric matrix B.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of B contains the\n*          upper triangular part of the matrix B.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of B contains\n*          the lower triangular part of the matrix B.\n*\n*          On exit, if INFO <= N, the part of B containing the matrix is\n*          overwritten by the triangular factor U or L from the Cholesky\n*          factorization B = U**T*U or B = L*L**T.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  VL      (input) REAL\n*  VU      (input) REAL\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) REAL\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less than\n*          or equal to zero, then  EPS*|T|  will be used in its place,\n*          where |T| is the 1-norm of the tridiagonal matrix obtained\n*          by reducing A to tridiagonal form.\n*\n*          Eigenvalues will be computed most accurately when ABSTOL is\n*          set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n*          If this routine returns with INFO>0, indicating that some\n*          eigenvectors did not converge, try setting ABSTOL to\n*          2*SLAMCH('S').\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) REAL array, dimension (N)\n*          On normal exit, the first M elements contain the selected\n*          eigenvalues in ascending order.\n*\n*  Z       (output) REAL array, dimension (LDZ, max(1,M))\n*          If JOBZ = 'N', then Z is not referenced.\n*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix A\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          The eigenvectors are normalized as follows:\n*          if ITYPE = 1 or 2, Z**T*B*Z = I;\n*          if ITYPE = 3, Z**T*inv(B)*Z = I.\n*\n*          If an eigenvector fails to converge, then that column of Z\n*          contains the latest approximation to the eigenvector, and the\n*          index of the eigenvector is returned in IFAIL.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace/output) REAL array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of the array WORK.  LWORK >= max(1,8*N).\n*          For optimal efficiency, LWORK >= (NB+3)*N,\n*          where NB is the blocksize for SSYTRD returned by ILAENV.\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*  IWORK   (workspace) INTEGER array, dimension (5*N)\n*\n*  IFAIL   (output) INTEGER array, dimension (N)\n*          If JOBZ = 'V', then if INFO = 0, the first M elements of\n*          IFAIL are zero.  If INFO > 0, then IFAIL contains the\n*          indices of the eigenvectors that failed to converge.\n*          If JOBZ = 'N', then IFAIL is not referenced.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  SPOTRF or SSYEVX returned an error code:\n*             <= N:  if INFO = i, SSYEVX failed to converge;\n*                    i eigenvectors failed to converge.  Their indices\n*                    are stored in array IFAIL.\n*             > N:   if INFO = N + i, for 1 <= i <= N, then the leading\n*                    minor of order i of B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, work, ifail, info, a, b = NumRu::Lapack.ssygvx( itype, jobz, range, uplo, a, b, ldb, vl, vu, il, iu, abstol, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 13)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_itype = argv[0];
  rblapack_jobz = argv[1];
  rblapack_range = argv[2];
  rblapack_uplo = argv[3];
  rblapack_a = argv[4];
  rblapack_b = argv[5];
  rblapack_ldb = argv[6];
  rblapack_vl = argv[7];
  rblapack_vu = argv[8];
  rblapack_il = argv[9];
  rblapack_iu = argv[10];
  rblapack_abstol = argv[11];
  if (argc == 13) {
    rblapack_lwork = argv[12];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  itype = NUM2INT(rblapack_itype);
  range = StringValueCStr(rblapack_range)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  ldb = NUM2INT(rblapack_ldb);
  vu = (real)NUM2DBL(rblapack_vu);
  iu = NUM2INT(rblapack_iu);
  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_b) != lda)
    rb_raise(rb_eRuntimeError, "shape 0 of b must be the same as shape 0 of a");
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  il = NUM2INT(rblapack_il);
  if (rblapack_lwork == Qnil)
    lwork = 8*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
  uplo = StringValueCStr(rblapack_uplo)[0];
  abstol = (real)NUM2DBL(rblapack_abstol);
  vl = (real)NUM2DBL(rblapack_vl);
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = lsame_(&jobz,"N") ? 0 : ldz;
    shape[1] = lsame_(&jobz,"N") ? 0 : MAX(1,m);
    rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  iwork = ALLOC_N(integer, (5*n));

  ssygvx_(&itype, &jobz, &range, &uplo, &n, a, &lda, b, &ldb, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, &lwork, iwork, ifail, &info);

  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_m, rblapack_w, rblapack_z, rblapack_work, rblapack_ifail, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_ssygvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssygvx", rblapack_ssygvx, -1);
}
ruby-lapack-1.7.2/ext/csysvx.c0000644000175000017500000003340712502221012016064 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID csysvx_(char* fact, char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* ferr, real* berr, complex* work, integer* lwork, real* rwork, integer* info);


static VALUE
rblapack_csysvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_af_out__;
  complex *af_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  real *rwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.csysvx( fact, uplo, a, af, ipiv, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CSYSVX uses the diagonal pivoting factorization to compute the\n*  solution to a complex system of linear equations A * X = B,\n*  where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n*  matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'N', the diagonal pivoting method is used to factor A.\n*     The form of the factorization is\n*        A = U * D * U**T,  if UPLO = 'U', or\n*        A = L * D * L**T,  if UPLO = 'L',\n*     where U (or L) is a product of permutation and unit upper (lower)\n*     triangular matrices, and D is symmetric and block diagonal with\n*     1-by-1 and 2-by-2 diagonal blocks.\n*\n*  2. If some D(i,i)=0, so that D is exactly singular, then the routine\n*     returns with INFO = i. Otherwise, the factored form of A is used\n*     to estimate the condition number of the matrix A.  If the\n*     reciprocal of the condition number is less than machine precision,\n*     INFO = N+1 is returned as a warning, but the routine still goes on\n*     to solve for X and compute error bounds as described below.\n*\n*  3. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  4. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of A has been\n*          supplied on entry.\n*          = 'F':  On entry, AF and IPIV contain the factored form\n*                  of A.  A, AF and IPIV will not be modified.\n*          = 'N':  The matrix A will be copied to AF and factored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The symmetric matrix A.  If UPLO = 'U', the leading N-by-N\n*          upper triangular part of A contains the upper triangular part\n*          of the matrix A, and the strictly lower triangular part of A\n*          is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*          triangular part of A contains the lower triangular part of\n*          the matrix A, and the strictly upper triangular part of A is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AF      (input or output) COMPLEX array, dimension (LDAF,N)\n*          If FACT = 'F', then AF is an input argument and on entry\n*          contains the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L from the factorization\n*          A = U*D*U**T or A = L*D*L**T as computed by CSYTRF.\n*\n*          If FACT = 'N', then AF is an output argument and on exit\n*          returns the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L from the factorization\n*          A = U*D*U**T or A = L*D*L**T.\n*\n*  LDAF    (input) INTEGER\n*          The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*  IPIV    (input or output) INTEGER array, dimension (N)\n*          If FACT = 'F', then IPIV is an input argument and on entry\n*          contains details of the interchanges and the block structure\n*          of D, as determined by CSYTRF.\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*          If FACT = 'N', then IPIV is an output argument and on exit\n*          contains details of the interchanges and the block structure\n*          of D, as determined by CSYTRF.\n*\n*  B       (input) COMPLEX array, dimension (LDB,NRHS)\n*          The N-by-NRHS right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) COMPLEX array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) REAL\n*          The estimate of the reciprocal condition number of the matrix\n*          A.  If RCOND is less than the machine precision (in\n*          particular, if RCOND = 0), the matrix is singular to working\n*          precision.  This condition is indicated by a return code of\n*          INFO > 0.\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of WORK.  LWORK >= max(1,2*N), and for best\n*          performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where\n*          NB is the optimal blocksize for CSYTRF.\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*  RWORK   (workspace) REAL array, dimension (N)\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, and i is\n*                <= N:  D(i,i) is exactly zero.  The factorization\n*                       has been completed but the factor D is exactly\n*                       singular, so the solution and error bounds could\n*                       not be computed. RCOND = 0 is returned.\n*                = N+1: D is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.csysvx( fact, uplo, a, af, ipiv, b, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_b = argv[5];
  if (argc == 7) {
    rblapack_lwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  ldx = MAX(1,n);
  if (rblapack_lwork == Qnil)
    lwork = 3*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldaf;
    shape[1] = n;
    rblapack_af_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  af_out__ = NA_PTR_TYPE(rblapack_af_out__, complex*);
  MEMCPY(af_out__, af, complex, NA_TOTAL(rblapack_af));
  rblapack_af = rblapack_af_out__;
  af = af_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  rwork = ALLOC_N(real, (n));

  csysvx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, &lwork, rwork, &info);

  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_work, rblapack_info, rblapack_af, rblapack_ipiv);
}

void
init_lapack_csysvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "csysvx", rblapack_csysvx, -1);
}
ruby-lapack-1.7.2/ext/zla_hercond_c.c0000644000175000017500000001703212502221022017314 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal zla_hercond_c_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublereal* c, logical* capply, integer* info, doublecomplex* work, doublereal* rwork);


static VALUE
rblapack_zla_hercond_c(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_capply;
  logical capply; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_rwork;
  doublereal *rwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack___out__;
  doublereal __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  info, __out__ = NumRu::Lapack.zla_hercond_c( uplo, a, af, ipiv, c, capply, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION ZLA_HERCOND_C( UPLO, N, A, LDA, AF,  LDAF, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n*  Purpose\n*  =======\n*\n*     ZLA_HERCOND_C computes the infinity norm condition number of\n*     op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector.\n*\n\n*  Arguments\n*  =========\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     A       (input) COMPLEX*16 array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX*16 array, dimension (LDAF,N)\n*     The block diagonal matrix D and the multipliers used to\n*     obtain the factor U or L as computed by ZHETRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     Details of the interchanges and the block structure of D\n*     as determined by CHETRF.\n*\n*     C       (input) DOUBLE PRECISION array, dimension (N)\n*     The vector C in the formula op(A) * inv(diag(C)).\n*\n*     CAPPLY  (input) LOGICAL\n*     If .TRUE. then access the vector C in the formula above.\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit.\n*     i > 0:  The ith argument is invalid.\n*\n*     WORK    (input) COMPLEX*16 array, dimension (2*N).\n*     Workspace.\n*\n*     RWORK   (input) DOUBLE PRECISION array, dimension (N).\n*     Workspace.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            KASE, I, J\n      DOUBLE PRECISION   AINVNM, ANORM, TMP\n      LOGICAL            UP\n      COMPLEX*16         ZDUM\n*     ..\n*     .. Local Arrays ..\n      INTEGER            ISAVE( 3 )\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           ZLACN2, ZHETRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX\n*     ..\n*     .. Statement Functions ..\n      DOUBLE PRECISION   CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, __out__ = NumRu::Lapack.zla_hercond_c( uplo, a, af, ipiv, c, capply, work, rwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_c = argv[4];
  rblapack_capply = argv[5];
  rblapack_work = argv[6];
  rblapack_rwork = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_rwork))
    rb_raise(rb_eArgError, "rwork (8th argument) must be NArray");
  if (NA_RANK(rblapack_rwork) != 1)
    rb_raise(rb_eArgError, "rank of rwork (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_rwork) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_rwork) != NA_DFLOAT)
    rblapack_rwork = na_change_type(rblapack_rwork, NA_DFLOAT);
  rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  capply = (rblapack_capply == Qtrue);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (7th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
  if (NA_TYPE(rblapack_work) != NA_DCOMPLEX)
    rblapack_work = na_change_type(rblapack_work, NA_DCOMPLEX);
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);

  __out__ = zla_hercond_c_(&uplo, &n, a, &lda, af, &ldaf, ipiv, c, &capply, &info, work, rwork);

  rblapack_info = INT2NUM(info);
  rblapack___out__ = rb_float_new((double)__out__);
  return rb_ary_new3(2, rblapack_info, rblapack___out__);
}

void
init_lapack_zla_hercond_c(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zla_hercond_c", rblapack_zla_hercond_c, -1);
}
ruby-lapack-1.7.2/ext/dggevx.c0000644000175000017500000004542312502221013016013 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dggevx_(char* balanc, char* jobvl, char* jobvr, char* sense, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* alphar, doublereal* alphai, doublereal* beta, doublereal* vl, integer* ldvl, doublereal* vr, integer* ldvr, integer* ilo, integer* ihi, doublereal* lscale, doublereal* rscale, doublereal* abnrm, doublereal* bbnrm, doublereal* rconde, doublereal* rcondv, doublereal* work, integer* lwork, integer* iwork, logical* bwork, integer* info);


static VALUE
rblapack_dggevx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_balanc;
  char balanc; 
  VALUE rblapack_jobvl;
  char jobvl; 
  VALUE rblapack_jobvr;
  char jobvr; 
  VALUE rblapack_sense;
  char sense; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_alphar;
  doublereal *alphar; 
  VALUE rblapack_alphai;
  doublereal *alphai; 
  VALUE rblapack_beta;
  doublereal *beta; 
  VALUE rblapack_vl;
  doublereal *vl; 
  VALUE rblapack_vr;
  doublereal *vr; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_lscale;
  doublereal *lscale; 
  VALUE rblapack_rscale;
  doublereal *rscale; 
  VALUE rblapack_abnrm;
  doublereal abnrm; 
  VALUE rblapack_bbnrm;
  doublereal bbnrm; 
  VALUE rblapack_rconde;
  doublereal *rconde; 
  VALUE rblapack_rcondv;
  doublereal *rcondv; 
  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 *iwork;
  logical *bwork;

  integer lda;
  integer n;
  integer ldb;
  integer ldvl;
  integer ldvr;

  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  alphar, alphai, beta, vl, vr, ilo, ihi, lscale, rscale, abnrm, bbnrm, rconde, rcondv, work, info, a, b = NumRu::Lapack.dggevx( balanc, jobvl, jobvr, sense, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, ILO, IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, WORK, LWORK, IWORK, BWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B)\n*  the generalized eigenvalues, and optionally, the left and/or right\n*  generalized eigenvectors.\n*\n*  Optionally also, it computes a balancing transformation to improve\n*  the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n*  LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for\n*  the eigenvalues (RCONDE), and reciprocal condition numbers for the\n*  right eigenvectors (RCONDV).\n*\n*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n*  lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n*  singular. It is usually represented as the pair (alpha,beta), as\n*  there is a reasonable interpretation for beta=0, and even for both\n*  being zero.\n*\n*  The right eigenvector v(j) corresponding to the eigenvalue lambda(j)\n*  of (A,B) satisfies\n*\n*                   A * v(j) = lambda(j) * B * v(j) .\n*\n*  The left eigenvector u(j) corresponding to the eigenvalue lambda(j)\n*  of (A,B) satisfies\n*\n*                   u(j)**H * A  = lambda(j) * u(j)**H * B.\n*\n*  where u(j)**H is the conjugate-transpose of u(j).\n*\n*\n\n*  Arguments\n*  =========\n*\n*  BALANC  (input) CHARACTER*1\n*          Specifies the balance option to be performed.\n*          = 'N':  do not diagonally scale or permute;\n*          = 'P':  permute only;\n*          = 'S':  scale only;\n*          = 'B':  both permute and scale.\n*          Computed reciprocal condition numbers will be for the\n*          matrices after permuting and/or balancing. Permuting does\n*          not change condition numbers (in exact arithmetic), but\n*          balancing does.\n*\n*  JOBVL   (input) CHARACTER*1\n*          = 'N':  do not compute the left generalized eigenvectors;\n*          = 'V':  compute the left generalized eigenvectors.\n*\n*  JOBVR   (input) CHARACTER*1\n*          = 'N':  do not compute the right generalized eigenvectors;\n*          = 'V':  compute the right generalized eigenvectors.\n*\n*  SENSE   (input) CHARACTER*1\n*          Determines which reciprocal condition numbers are computed.\n*          = 'N': none are computed;\n*          = 'E': computed for eigenvalues only;\n*          = 'V': computed for eigenvectors only;\n*          = 'B': computed for eigenvalues and eigenvectors.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A, B, VL, and VR.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n*          On entry, the matrix A in the pair (A,B).\n*          On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'\n*          or both, then A contains the first part of the real Schur\n*          form of the \"balanced\" versions of the input A and B.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of A.  LDA >= max(1,N).\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n*          On entry, the matrix B in the pair (A,B).\n*          On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'\n*          or both, then B contains the second part of the real Schur\n*          form of the \"balanced\" versions of the input A and B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of B.  LDB >= max(1,N).\n*\n*  ALPHAR  (output) DOUBLE PRECISION array, dimension (N)\n*  ALPHAI  (output) DOUBLE PRECISION array, dimension (N)\n*  BETA    (output) DOUBLE PRECISION array, dimension (N)\n*          On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n*          be the generalized eigenvalues.  If ALPHAI(j) is zero, then\n*          the j-th eigenvalue is real; if positive, then the j-th and\n*          (j+1)-st eigenvalues are a complex conjugate pair, with\n*          ALPHAI(j+1) negative.\n*\n*          Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n*          may easily over- or underflow, and BETA(j) may even be zero.\n*          Thus, the user should avoid naively computing the ratio\n*          ALPHA/BETA. However, ALPHAR and ALPHAI will be always less\n*          than and usually comparable with norm(A) in magnitude, and\n*          BETA always less than and usually comparable with norm(B).\n*\n*  VL      (output) DOUBLE PRECISION array, dimension (LDVL,N)\n*          If JOBVL = 'V', the left eigenvectors u(j) are stored one\n*          after another in the columns of VL, in the same order as\n*          their eigenvalues. If the j-th eigenvalue is real, then\n*          u(j) = VL(:,j), the j-th column of VL. If the j-th and\n*          (j+1)-th eigenvalues form a complex conjugate pair, then\n*          u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).\n*          Each eigenvector will be scaled so the largest component have\n*          abs(real part) + abs(imag. part) = 1.\n*          Not referenced if JOBVL = 'N'.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the matrix VL. LDVL >= 1, and\n*          if JOBVL = 'V', LDVL >= N.\n*\n*  VR      (output) DOUBLE PRECISION array, dimension (LDVR,N)\n*          If JOBVR = 'V', the right eigenvectors v(j) are stored one\n*          after another in the columns of VR, in the same order as\n*          their eigenvalues. If the j-th eigenvalue is real, then\n*          v(j) = VR(:,j), the j-th column of VR. If the j-th and\n*          (j+1)-th eigenvalues form a complex conjugate pair, then\n*          v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).\n*          Each eigenvector will be scaled so the largest component have\n*          abs(real part) + abs(imag. part) = 1.\n*          Not referenced if JOBVR = 'N'.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the matrix VR. LDVR >= 1, and\n*          if JOBVR = 'V', LDVR >= N.\n*\n*  ILO     (output) INTEGER\n*  IHI     (output) INTEGER\n*          ILO and IHI are integer values such that on exit\n*          A(i,j) = 0 and B(i,j) = 0 if i > j and\n*          j = 1,...,ILO-1 or i = IHI+1,...,N.\n*          If BALANC = 'N' or 'S', ILO = 1 and IHI = N.\n*\n*  LSCALE  (output) DOUBLE PRECISION array, dimension (N)\n*          Details of the permutations and scaling factors applied\n*          to the left side of A and B.  If PL(j) is the index of the\n*          row interchanged with row j, and DL(j) is the scaling\n*          factor applied to row j, then\n*            LSCALE(j) = PL(j)  for j = 1,...,ILO-1\n*                      = DL(j)  for j = ILO,...,IHI\n*                      = PL(j)  for j = IHI+1,...,N.\n*          The order in which the interchanges are made is N to IHI+1,\n*          then 1 to ILO-1.\n*\n*  RSCALE  (output) DOUBLE PRECISION array, dimension (N)\n*          Details of the permutations and scaling factors applied\n*          to the right side of A and B.  If PR(j) is the index of the\n*          column interchanged with column j, and DR(j) is the scaling\n*          factor applied to column j, then\n*            RSCALE(j) = PR(j)  for j = 1,...,ILO-1\n*                      = DR(j)  for j = ILO,...,IHI\n*                      = PR(j)  for j = IHI+1,...,N\n*          The order in which the interchanges are made is N to IHI+1,\n*          then 1 to ILO-1.\n*\n*  ABNRM   (output) DOUBLE PRECISION\n*          The one-norm of the balanced matrix A.\n*\n*  BBNRM   (output) DOUBLE PRECISION\n*          The one-norm of the balanced matrix B.\n*\n*  RCONDE  (output) DOUBLE PRECISION array, dimension (N)\n*          If SENSE = 'E' or 'B', the reciprocal condition numbers of\n*          the eigenvalues, stored in consecutive elements of the array.\n*          For a complex conjugate pair of eigenvalues two consecutive\n*          elements of RCONDE are set to the same value. Thus RCONDE(j),\n*          RCONDV(j), and the j-th columns of VL and VR all correspond\n*          to the j-th eigenpair.\n*          If SENSE = 'N or 'V', RCONDE is not referenced.\n*\n*  RCONDV  (output) DOUBLE PRECISION array, dimension (N)\n*          If SENSE = 'V' or 'B', the estimated reciprocal condition\n*          numbers of the eigenvectors, stored in consecutive elements\n*          of the array. For a complex eigenvector two consecutive\n*          elements of RCONDV are set to the same value. If the\n*          eigenvalues cannot be reordered to compute RCONDV(j),\n*          RCONDV(j) is set to 0; this can only occur when the true\n*          value would be very small anyway.\n*          If SENSE = 'N' or 'E', RCONDV is not referenced.\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,2*N).\n*          If BALANC = 'S' or 'B', or JOBVL = 'V', or JOBVR = 'V',\n*          LWORK >= max(1,6*N).\n*          If SENSE = 'E' or 'B', LWORK >= max(1,10*N).\n*          If SENSE = 'V' or 'B', LWORK >= 2*N*N+8*N+16.\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*  IWORK   (workspace) INTEGER array, dimension (N+6)\n*          If SENSE = 'E', IWORK is not referenced.\n*\n*  BWORK   (workspace) LOGICAL array, dimension (N)\n*          If SENSE = 'N', BWORK is not referenced.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          = 1,...,N:\n*                The QZ iteration failed.  No eigenvectors have been\n*                calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)\n*                should be correct for j=INFO+1,...,N.\n*          > N:  =N+1: other than QZ iteration failed in DHGEQZ.\n*                =N+2: error return from DTGEVC.\n*\n\n*  Further Details\n*  ===============\n*\n*  Balancing a matrix pair (A,B) includes, first, permuting rows and\n*  columns to isolate eigenvalues, second, applying diagonal similarity\n*  transformation to the rows and columns to make the rows and columns\n*  as close in norm as possible. The computed reciprocal condition\n*  numbers correspond to the balanced matrix. Permuting rows and columns\n*  will not change the condition numbers (in exact arithmetic) but\n*  diagonal scaling will.  For further explanation of balancing, see\n*  section 4.11.1.2 of LAPACK Users' Guide.\n*\n*  An approximate error bound on the chordal distance between the i-th\n*  computed generalized eigenvalue w and the corresponding exact\n*  eigenvalue lambda is\n*\n*       chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)\n*\n*  An approximate error bound for the angle between the i-th computed\n*  eigenvector VL(i) or VR(i) is given by\n*\n*       EPS * norm(ABNRM, BBNRM) / DIF(i).\n*\n*  For further explanation of the reciprocal condition numbers RCONDE\n*  and RCONDV, see section 4.11 of LAPACK User's Guide.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  alphar, alphai, beta, vl, vr, ilo, ihi, lscale, rscale, abnrm, bbnrm, rconde, rcondv, work, info, a, b = NumRu::Lapack.dggevx( balanc, jobvl, jobvr, sense, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_balanc = argv[0];
  rblapack_jobvl = argv[1];
  rblapack_jobvr = argv[2];
  rblapack_sense = argv[3];
  rblapack_a = argv[4];
  rblapack_b = argv[5];
  if (argc == 7) {
    rblapack_lwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  balanc = StringValueCStr(rblapack_balanc)[0];
  jobvr = StringValueCStr(rblapack_jobvr)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th 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*);
  jobvl = StringValueCStr(rblapack_jobvl)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  ldvr = lsame_(&jobvr,"V") ? n : 1;
  sense = StringValueCStr(rblapack_sense)[0];
  ldvl = lsame_(&jobvl,"V") ? n : 1;
  if (rblapack_lwork == Qnil)
    lwork = (lsame_(&balanc,"S")||lsame_(&balanc,"B")||lsame_(&jobvl,"V")||lsame_(&jobvr,"V")) ? 6*n : lsame_(&sense,"E") ? 10*n : (lsame_(&sense,"V")||lsame_(&sense,"B")) ? 2*n*n+8*n+16 : 2*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  alphar = NA_PTR_TYPE(rblapack_alphar, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  alphai = NA_PTR_TYPE(rblapack_alphai, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = n;
    rblapack_vl = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vl = NA_PTR_TYPE(rblapack_vl, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = n;
    rblapack_vr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vr = NA_PTR_TYPE(rblapack_vr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_lscale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  lscale = NA_PTR_TYPE(rblapack_lscale, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rscale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  rscale = NA_PTR_TYPE(rblapack_rscale, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rconde = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  rconde = NA_PTR_TYPE(rblapack_rconde, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rcondv = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  rcondv = NA_PTR_TYPE(rblapack_rcondv, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  iwork = ALLOC_N(integer, (lsame_(&sense,"E") ? 0 : n+6));
  bwork = ALLOC_N(logical, (lsame_(&sense,"N") ? 0 : n));

  dggevx_(&balanc, &jobvl, &jobvr, &sense, &n, a, &lda, b, &ldb, alphar, alphai, beta, vl, &ldvl, vr, &ldvr, &ilo, &ihi, lscale, rscale, &abnrm, &bbnrm, rconde, rcondv, work, &lwork, iwork, bwork, &info);

  free(iwork);
  free(bwork);
  rblapack_ilo = INT2NUM(ilo);
  rblapack_ihi = INT2NUM(ihi);
  rblapack_abnrm = rb_float_new((double)abnrm);
  rblapack_bbnrm = rb_float_new((double)bbnrm);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(17, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_vl, rblapack_vr, rblapack_ilo, rblapack_ihi, rblapack_lscale, rblapack_rscale, rblapack_abnrm, rblapack_bbnrm, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_dggevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dggevx", rblapack_dggevx, -1);
}
ruby-lapack-1.7.2/ext/ctfttp.c0000644000175000017500000001671612502221024016040 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctfttp_(char* transr, char* uplo, integer* n, complex* arf, complex* ap, integer* info);


static VALUE
rblapack_ctfttp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_arf;
  complex *arf; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_info;
  integer info; 


  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  ap, info = NumRu::Lapack.ctfttp( transr, uplo, n, arf, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTFTTP( TRANSR, UPLO, N, ARF, AP, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTFTTP copies a triangular matrix A from rectangular full packed\n*  format (TF) to standard packed format (TP).\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR   (input) CHARACTER*1\n*          = 'N':  ARF is in Normal format;\n*          = 'C':  ARF is in Conjugate-transpose format;\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0.\n*\n*  ARF     (input) COMPLEX array, dimension ( N*(N+1)/2 ),\n*          On entry, the upper or lower triangular matrix A stored in\n*          RFP format. For a further discussion see Notes below.\n*\n*  AP      (output) COMPLEX array, dimension ( N*(N+1)/2 ),\n*          On exit, the upper or lower triangular matrix A, packed\n*          columnwise in a linear array. The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\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*  We first consider Standard Packed Format when N is even.\n*  We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  conjugate-transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  conjugate-transpose of the last three columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                -- -- --\n*        03 04 05                33 43 53\n*                                   -- --\n*        13 14 15                00 44 54\n*                                      --\n*        23 24 25                10 11 55\n*\n*        33 34 35                20 21 22\n*        --\n*        00 44 45                30 31 32\n*        -- --\n*        01 11 55                40 41 42\n*        -- -- --\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- -- --                -- -- -- -- -- --\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     -- -- -- -- --                -- -- -- -- --\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     -- -- -- -- -- --                -- -- -- --\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We next  consider Standard Packed Format when N is odd.\n*  We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  conjugate-transpose of the first two   columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  conjugate-transpose of the last two   columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N odd  and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                   -- --\n*        02 03 04                00 33 43\n*                                      --\n*        12 13 14                10 11 44\n*\n*        22 23 24                20 21 22\n*        --\n*        00 33 34                30 31 32\n*        -- --\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- --                   -- -- -- -- -- --\n*     02 12 22 00 01             00 10 20 30 40 50\n*     -- -- -- --                   -- -- -- -- --\n*     03 13 23 33 11             33 11 21 31 41 51\n*     -- -- -- -- --                   -- -- -- --\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ap, info = NumRu::Lapack.ctfttp( transr, uplo, n, arf, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_n = argv[2];
  rblapack_arf = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  n = NUM2INT(rblapack_n);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_arf))
    rb_raise(rb_eArgError, "arf (4th argument) must be NArray");
  if (NA_RANK(rblapack_arf) != 1)
    rb_raise(rb_eArgError, "rank of arf (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_arf) != (( n*(n+1)/2 )))
    rb_raise(rb_eRuntimeError, "shape 0 of arf must be %d", ( n*(n+1)/2 ));
  if (NA_TYPE(rblapack_arf) != NA_SCOMPLEX)
    rblapack_arf = na_change_type(rblapack_arf, NA_SCOMPLEX);
  arf = NA_PTR_TYPE(rblapack_arf, complex*);
  {
    na_shape_t shape[1];
    shape[0] = ( n*(n+1)/2 );
    rblapack_ap = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  ap = NA_PTR_TYPE(rblapack_ap, complex*);

  ctfttp_(&transr, &uplo, &n, arf, ap, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_ap, rblapack_info);
}

void
init_lapack_ctfttp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctfttp", rblapack_ctfttp, -1);
}
ruby-lapack-1.7.2/ext/dgeequ.c0000644000175000017500000001213512502221024015775 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgeequ_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* r, doublereal* c, doublereal* rowcnd, doublereal* colcnd, doublereal* amax, integer* info);


static VALUE
rblapack_dgeequ(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_r;
  doublereal *r; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_rowcnd;
  doublereal rowcnd; 
  VALUE rblapack_colcnd;
  doublereal colcnd; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_info;
  integer info; 

  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  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.dgeequ( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGEEQU computes row and column scalings intended to equilibrate an\n*  M-by-N matrix A and reduce its condition number.  R returns the row\n*  scale factors and C the column scale factors, chosen to try to make\n*  the largest element in each row and column of the matrix B with\n*  elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n*\n*  R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n*  number and BIGNUM = largest safe number.  Use of these scaling\n*  factors is not guaranteed to reduce the condition number of A but\n*  works well in practice.\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) DOUBLE PRECISION array, dimension (LDA,N)\n*          The M-by-N matrix whose equilibration factors are\n*          to be computed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  R       (output) DOUBLE PRECISION array, dimension (M)\n*          If INFO = 0 or INFO > M, R contains the row scale factors\n*          for A.\n*\n*  C       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0,  C contains the column scale factors for A.\n*\n*  ROWCND  (output) DOUBLE PRECISION\n*          If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n*          smallest R(i) to the largest R(i).  If ROWCND >= 0.1 and\n*          AMAX is neither too large nor too small, it is not worth\n*          scaling by R.\n*\n*  COLCND  (output) DOUBLE PRECISION\n*          If INFO = 0, COLCND contains the ratio of the smallest\n*          C(i) to the largest C(i).  If COLCND >= 0.1, it is not\n*          worth scaling by C.\n*\n*  AMAX    (output) DOUBLE PRECISION\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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,  and i is\n*                <= M:  the i-th row of A is exactly zero\n*                >  M:  the (i-M)-th column of A is exactly zero\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.dgeequ( 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;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_r = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  r = NA_PTR_TYPE(rblapack_r, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  c = NA_PTR_TYPE(rblapack_c, doublereal*);

  dgeequ_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &info);

  rblapack_rowcnd = rb_float_new((double)rowcnd);
  rblapack_colcnd = rb_float_new((double)colcnd);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
}

void
init_lapack_dgeequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgeequ", rblapack_dgeequ, -1);
}
ruby-lapack-1.7.2/ext/strttp.c0000644000175000017500000000722712502221022016067 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID strttp_(char* uplo, integer* n, real* a, integer* lda, real* ap, integer* info);


static VALUE
rblapack_strttp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_info;
  integer info; 

  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  ap, info = NumRu::Lapack.strttp( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STRTTP( UPLO, N, A, LDA, AP, INFO )\n\n*  Purpose\n*  =======\n*\n*  STRTTP copies a triangular matrix A from full format (TR) to standard\n*  packed format (TP).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular.\n*          = 'L':  A is lower triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrices AP and A.  N >= 0.\n*\n*  A       (input) REAL array, dimension (LDA,N)\n*          On exit, the triangular matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AP      (output) REAL array, dimension (N*(N+1)/2\n*          On exit, the upper or lower triangular matrix A, packed\n*          columnwise in a linear array. The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ap, info = NumRu::Lapack.strttp( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ap = NA_PTR_TYPE(rblapack_ap, real*);

  strttp_(&uplo, &n, a, &lda, ap, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_ap, rblapack_info);
}

void
init_lapack_strttp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "strttp", rblapack_strttp, -1);
}
ruby-lapack-1.7.2/ext/cpptrs.c0000644000175000017500000001140212502221013016030 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cpptrs_(char* uplo, integer* n, integer* nrhs, complex* ap, complex* b, integer* ldb, integer* info);


static VALUE
rblapack_cpptrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.cpptrs( uplo, n, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPPTRS solves a system of linear equations A*X = B with a Hermitian\n*  positive definite matrix A in packed storage using the Cholesky\n*  factorization A = U**H*U or A = L*L**H computed by CPPTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**H*U or A = L*L**H, packed columnwise in a linear\n*          array.  The j-th column of U or L is stored in the array AP\n*          as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            UPPER\n      INTEGER            I\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CTPSV, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.cpptrs( uplo, n, ap, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_n = argv[1];
  rblapack_ap = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  cpptrs_(&uplo, &n, &nrhs, ap, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_cpptrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cpptrs", rblapack_cpptrs, -1);
}
ruby-lapack-1.7.2/ext/sgetrs.c0000644000175000017500000001162712502221023016036 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgetrs_(char* trans, integer* n, integer* nrhs, real* a, integer* lda, integer* ipiv, real* b, integer* ldb, integer* info);


static VALUE
rblapack_sgetrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  real *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.sgetrs( trans, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGETRS solves a system of linear equations\n*     A * X = B  or  A' * X = B\n*  with a general N-by-N matrix A using the LU factorization computed\n*  by SGETRF.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B  (No transpose)\n*          = 'T':  A'* X = B  (Transpose)\n*          = 'C':  A'* X = B  (Conjugate transpose = Transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input) REAL array, dimension (LDA,N)\n*          The factors L and U from the factorization A = P*L*U\n*          as computed by SGETRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices from SGETRF; for 1<=i<=N, row i of the\n*          matrix was interchanged with row IPIV(i).\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.sgetrs( trans, a, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_trans = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  sgetrs_(&trans, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_sgetrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgetrs", rblapack_sgetrs, -1);
}
ruby-lapack-1.7.2/ext/cpftrs.c0000644000175000017500000002042612502221013016024 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cpftrs_(char* transr, char* uplo, integer* n, integer* nrhs, complex* a, complex* b, integer* ldb, integer* info);


static VALUE
rblapack_cpftrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.cpftrs( transr, uplo, n, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPFTRS solves a system of linear equations A*X = B with a Hermitian\n*  positive definite matrix A using the Cholesky factorization\n*  A = U**H*U or A = L*L**H computed by CPFTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR    (input) CHARACTER*1\n*          = 'N':  The Normal TRANSR of RFP A is stored;\n*          = 'C':  The Conjugate-transpose TRANSR of RFP A is stored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of RFP A is stored;\n*          = 'L':  Lower triangle of RFP A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input) COMPLEX array, dimension ( N*(N+1)/2 );\n*          The triangular factor U or L from the Cholesky factorization\n*          of RFP A = U**H*U or RFP A = L*L**H, as computed by CPFTRF.\n*          See note below for more details about RFP A.\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  We first consider Standard Packed Format when N is even.\n*  We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  conjugate-transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  conjugate-transpose of the last three columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                -- -- --\n*        03 04 05                33 43 53\n*                                   -- --\n*        13 14 15                00 44 54\n*                                      --\n*        23 24 25                10 11 55\n*\n*        33 34 35                20 21 22\n*        --\n*        00 44 45                30 31 32\n*        -- --\n*        01 11 55                40 41 42\n*        -- -- --\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- -- --                -- -- -- -- -- --\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     -- -- -- -- --                -- -- -- -- --\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     -- -- -- -- -- --                -- -- -- --\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We next  consider Standard Packed Format when N is odd.\n*  We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  conjugate-transpose of the first two   columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  conjugate-transpose of the last two   columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N odd  and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                   -- --\n*        02 03 04                00 33 43\n*                                      --\n*        12 13 14                10 11 44\n*\n*        22 23 24                20 21 22\n*        --\n*        00 33 34                30 31 32\n*        -- --\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- --                   -- -- -- -- -- --\n*     02 12 22 00 01             00 10 20 30 40 50\n*     -- -- -- --                   -- -- -- -- --\n*     03 13 23 33 11             33 11 21 31 41 51\n*     -- -- -- -- --                   -- -- -- --\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.cpftrs( transr, uplo, n, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_n = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 1)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  cpftrs_(&transr, &uplo, &n, &nrhs, a, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_cpftrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cpftrs", rblapack_cpftrs, -1);
}
ruby-lapack-1.7.2/ext/csytrs.c0000644000175000017500000001175012502221015016054 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID csytrs_(char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, integer* ipiv, complex* b, integer* ldb, integer* info);


static VALUE
rblapack_csytrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.csytrs( uplo, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  CSYTRS solves a system of linear equations A*X = B with a complex\n*  symmetric matrix A using the factorization A = U*D*U**T or\n*  A = L*D*L**T computed by CSYTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by CSYTRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by CSYTRF.\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.csytrs( uplo, a, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  csytrs_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_csytrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "csytrs", rblapack_csytrs, -1);
}
ruby-lapack-1.7.2/ext/zgelsx.c0000644000175000017500000002067712502221023016050 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgelsx_(integer* m, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, integer* jpvt, doublereal* rcond, integer* rank, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zgelsx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_jpvt;
  integer *jpvt; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_rank;
  integer rank; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  VALUE rblapack_jpvt_out__;
  integer *jpvt_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  rank, info, a, b, jpvt = NumRu::Lapack.zgelsx( m, a, b, jpvt, rcond, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  This routine is deprecated and has been replaced by routine ZGELSY.\n*\n*  ZGELSX computes the minimum-norm solution to a complex linear least\n*  squares problem:\n*      minimize || A * X - B ||\n*  using a complete orthogonal factorization of A.  A is an M-by-N\n*  matrix which may be rank-deficient.\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*  The routine first computes a QR factorization with column pivoting:\n*      A * P = Q * [ R11 R12 ]\n*                  [  0  R22 ]\n*  with R11 defined as the largest leading submatrix whose estimated\n*  condition number is less than 1/RCOND.  The order of R11, RANK,\n*  is the effective rank of A.\n*\n*  Then, R22 is considered to be negligible, and R12 is annihilated\n*  by unitary transformations from the right, arriving at the\n*  complete orthogonal factorization:\n*     A * P = Q * [ T11 0 ] * Z\n*                 [  0  0 ]\n*  The minimum-norm solution is then\n*     X = P * Z' [ inv(T11)*Q1'*B ]\n*                [        0       ]\n*  where Q1 consists of the first RANK columns of 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*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of\n*          columns of matrices B and X. NRHS >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, A has been overwritten by details of its\n*          complete orthogonal factorization.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the M-by-NRHS right hand side matrix B.\n*          On exit, the N-by-NRHS solution matrix X.\n*          If m >= n and RANK = n, the residual sum-of-squares for\n*          the solution in the i-th column is given by the sum of\n*          squares of elements N+1:M in that column.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,M,N).\n*\n*  JPVT    (input/output) INTEGER array, dimension (N)\n*          On entry, if JPVT(i) .ne. 0, the i-th column of A is an\n*          initial column, otherwise it is a free column.  Before\n*          the QR factorization of A, all initial columns are\n*          permuted to the leading positions; only the remaining\n*          free columns are moved as a result of column pivoting\n*          during the factorization.\n*          On exit, if JPVT(i) = k, then the i-th column of A*P\n*          was the k-th column of A.\n*\n*  RCOND   (input) DOUBLE PRECISION\n*          RCOND is used to determine the effective rank of A, which\n*          is defined as the order of the largest leading triangular\n*          submatrix R11 in the QR factorization with pivoting of A,\n*          whose estimated condition number < 1/RCOND.\n*\n*  RANK    (output) INTEGER\n*          The effective rank of A, i.e., the order of the submatrix\n*          R11.  This is the same as the order of the submatrix T11\n*          in the complete orthogonal factorization of A.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension\n*                      (min(M,N) + max( N, 2*min(M,N)+NRHS )),\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (2*N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rank, info, a, b, jpvt = NumRu::Lapack.zgelsx( m, a, b, jpvt, rcond, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  rblapack_b = argv[2];
  rblapack_jpvt = argv[3];
  rblapack_rcond = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  rcond = NUM2DBL(rblapack_rcond);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_jpvt))
    rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
  if (NA_RANK(rblapack_jpvt) != 1)
    rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_jpvt) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_jpvt) != NA_LINT)
    rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
  jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
  MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
  rblapack_jpvt = rblapack_jpvt_out__;
  jpvt = jpvt_out__;
  work = ALLOC_N(doublecomplex, (MIN(m,n) + MAX(n,2*(MIN(m,n))+nrhs)));
  rwork = ALLOC_N(doublereal, (2*n));

  zgelsx_(&m, &n, &nrhs, a, &lda, b, &ldb, jpvt, &rcond, &rank, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rank = INT2NUM(rank);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_rank, rblapack_info, rblapack_a, rblapack_b, rblapack_jpvt);
}

void
init_lapack_zgelsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgelsx", rblapack_zgelsx, -1);
}
ruby-lapack-1.7.2/ext/clag2z.c0000644000175000017500000000644312502221017015714 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clag2z_(integer* m, integer* n, complex* sa, integer* ldsa, doublecomplex* a, integer* lda, integer* info);


static VALUE
rblapack_clag2z(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_sa;
  complex *sa; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_info;
  integer info; 

  integer ldsa;
  integer n;
  integer lda;

  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  a, info = NumRu::Lapack.clag2z( m, sa, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAG2Z( M, N, SA, LDSA, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  CLAG2Z converts a COMPLEX matrix, SA, to a COMPLEX*16 matrix, A.\n*\n*  Note that while it is possible to overflow while converting\n*  from double to single, it is not possible to overflow when\n*  converting from single to double.\n*\n*  This is an auxiliary routine so there is no argument checking.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of lines of the matrix A.  M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.  N >= 0.\n*\n*  SA      (input) COMPLEX array, dimension (LDSA,N)\n*          On entry, the M-by-N coefficient matrix SA.\n*\n*  LDSA    (input) INTEGER\n*          The leading dimension of the array SA.  LDSA >= max(1,M).\n*\n*  A       (output) COMPLEX*16 array, dimension (LDA,N)\n*          On exit, the M-by-N coefficient matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*  =========\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  a, info = NumRu::Lapack.clag2z( m, sa, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_sa = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  lda = MAX(1,m);
  if (!NA_IsNArray(rblapack_sa))
    rb_raise(rb_eArgError, "sa (2th argument) must be NArray");
  if (NA_RANK(rblapack_sa) != 2)
    rb_raise(rb_eArgError, "rank of sa (2th argument) must be %d", 2);
  ldsa = NA_SHAPE0(rblapack_sa);
  n = NA_SHAPE1(rblapack_sa);
  if (NA_TYPE(rblapack_sa) != NA_SCOMPLEX)
    rblapack_sa = na_change_type(rblapack_sa, NA_SCOMPLEX);
  sa = NA_PTR_TYPE(rblapack_sa, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);

  clag2z_(&m, &n, sa, &ldsa, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_a, rblapack_info);
}

void
init_lapack_clag2z(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clag2z", rblapack_clag2z, -1);
}
ruby-lapack-1.7.2/ext/zlatbs.c0000644000175000017500000002521512502221012016022 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlatbs_(char* uplo, char* trans, char* diag, char* normin, integer* n, integer* kd, doublecomplex* ab, integer* ldab, doublecomplex* x, doublereal* scale, doublereal* cnorm, integer* info);


static VALUE
rblapack_zlatbs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_normin;
  char normin; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_cnorm;
  doublereal *cnorm; 
  VALUE rblapack_scale;
  doublereal scale; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;
  VALUE rblapack_cnorm_out__;
  doublereal *cnorm_out__;

  integer ldab;
  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  scale, info, x, cnorm = NumRu::Lapack.zlatbs( uplo, trans, diag, normin, kd, ab, x, cnorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, SCALE, CNORM, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZLATBS solves one of the triangular systems\n*\n*     A * x = s*b,  A**T * x = s*b,  or  A**H * x = s*b,\n*\n*  with scaling to prevent overflow, where A is an upper or lower\n*  triangular band matrix.  Here A' denotes the transpose of A, x and b\n*  are n-element vectors, and s is a scaling factor, usually less than\n*  or equal to 1, chosen so that the components of x will be less than\n*  the overflow threshold.  If the unscaled problem will not cause\n*  overflow, the Level 2 BLAS routine ZTBSV is called.  If the matrix A\n*  is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n*  non-trivial solution to A*x = 0 is returned.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the matrix A is upper or lower triangular.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the operation applied to A.\n*          = 'N':  Solve A * x = s*b     (No transpose)\n*          = 'T':  Solve A**T * x = s*b  (Transpose)\n*          = 'C':  Solve A**H * x = s*b  (Conjugate transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          Specifies whether or not the matrix A is unit triangular.\n*          = 'N':  Non-unit triangular\n*          = 'U':  Unit triangular\n*\n*  NORMIN  (input) CHARACTER*1\n*          Specifies whether CNORM has been set or not.\n*          = 'Y':  CNORM contains the column norms on entry\n*          = 'N':  CNORM is not set on entry.  On exit, the norms will\n*                  be computed and stored in CNORM.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of subdiagonals or superdiagonals in the\n*          triangular matrix A.  KD >= 0.\n*\n*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)\n*          The upper or lower triangular band matrix A, stored in the\n*          first KD+1 rows of the array. The j-th column of A is stored\n*          in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  X       (input/output) COMPLEX*16 array, dimension (N)\n*          On entry, the right hand side b of the triangular system.\n*          On exit, X is overwritten by the solution vector x.\n*\n*  SCALE   (output) DOUBLE PRECISION\n*          The scaling factor s for the triangular system\n*             A * x = s*b,  A**T * x = s*b,  or  A**H * x = s*b.\n*          If SCALE = 0, the matrix A is singular or badly scaled, and\n*          the vector x is an exact or approximate solution to A*x = 0.\n*\n*  CNORM   (input or output) DOUBLE PRECISION array, dimension (N)\n*\n*          If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n*          contains the norm of the off-diagonal part of the j-th column\n*          of A.  If TRANS = 'N', CNORM(j) must be greater than or equal\n*          to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n*          must be greater than or equal to the 1-norm.\n*\n*          If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n*          returns the 1-norm of the offdiagonal part of the j-th column\n*          of A.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -k, the k-th argument had an illegal value\n*\n\n*  Further Details\n*  ======= =======\n*\n*  A rough bound on x is computed; if that is less than overflow, ZTBSV\n*  is called, otherwise, specific code is used which checks for possible\n*  overflow or divide-by-zero at every operation.\n*\n*  A columnwise scheme is used for solving A*x = b.  The basic algorithm\n*  if A is lower triangular is\n*\n*       x[1:n] := b[1:n]\n*       for j = 1, ..., n\n*            x(j) := x(j) / A(j,j)\n*            x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n*       end\n*\n*  Define bounds on the components of x after j iterations of the loop:\n*     M(j) = bound on x[1:j]\n*     G(j) = bound on x[j+1:n]\n*  Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n*  Then for iteration j+1 we have\n*     M(j+1) <= G(j) / | A(j+1,j+1) |\n*     G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n*            <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n*  where CNORM(j+1) is greater than or equal to the infinity-norm of\n*  column j+1 of A, not counting the diagonal.  Hence\n*\n*     G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n*                  1<=i<=j\n*  and\n*\n*     |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n*                                   1<=i< j\n*\n*  Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTBSV if the\n*  reciprocal of the largest M(j), j=1,..,n, is larger than\n*  max(underflow, 1/overflow).\n*\n*  The bound on x(j) is also used to determine when a step in the\n*  columnwise method can be performed without fear of overflow.  If\n*  the computed bound is greater than a large constant, x is scaled to\n*  prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n*  1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n*  Similarly, a row-wise scheme is used to solve A**T *x = b  or\n*  A**H *x = b.  The basic algorithm for A upper triangular is\n*\n*       for j = 1, ..., n\n*            x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n*       end\n*\n*  We simultaneously compute two bounds\n*       G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n*       M(j) = bound on x(i), 1<=i<=j\n*\n*  The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n*  add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n*  Then the bound on x(j) is\n*\n*       M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n*            <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n*                      1<=i<=j\n*\n*  and we can safely call ZTBSV if 1/M(n) and 1/G(n) are both greater\n*  than max(underflow, 1/overflow).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, info, x, cnorm = NumRu::Lapack.zlatbs( uplo, trans, diag, normin, kd, ab, x, cnorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_normin = argv[3];
  rblapack_kd = argv[4];
  rblapack_ab = argv[5];
  rblapack_x = argv[6];
  rblapack_cnorm = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  kd = NUM2INT(rblapack_kd);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (7th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (6th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (6th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of x");
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  normin = StringValueCStr(rblapack_normin)[0];
  if (!NA_IsNArray(rblapack_cnorm))
    rb_raise(rb_eArgError, "cnorm (8th argument) must be NArray");
  if (NA_RANK(rblapack_cnorm) != 1)
    rb_raise(rb_eArgError, "rank of cnorm (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_cnorm) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of cnorm must be the same as shape 0 of x");
  if (NA_TYPE(rblapack_cnorm) != NA_DFLOAT)
    rblapack_cnorm = na_change_type(rblapack_cnorm, NA_DFLOAT);
  cnorm = NA_PTR_TYPE(rblapack_cnorm, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_cnorm_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  cnorm_out__ = NA_PTR_TYPE(rblapack_cnorm_out__, doublereal*);
  MEMCPY(cnorm_out__, cnorm, doublereal, NA_TOTAL(rblapack_cnorm));
  rblapack_cnorm = rblapack_cnorm_out__;
  cnorm = cnorm_out__;

  zlatbs_(&uplo, &trans, &diag, &normin, &n, &kd, ab, &ldab, x, &scale, cnorm, &info);

  rblapack_scale = rb_float_new((double)scale);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_scale, rblapack_info, rblapack_x, rblapack_cnorm);
}

void
init_lapack_zlatbs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlatbs", rblapack_zlatbs, -1);
}
ruby-lapack-1.7.2/ext/cgbequ.c0000644000175000017500000001317712502221024016000 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgbequ_(integer* m, integer* n, integer* kl, integer* ku, complex* ab, integer* ldab, real* r, real* c, real* rowcnd, real* colcnd, real* amax, integer* info);


static VALUE
rblapack_cgbequ(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_r;
  real *r; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_rowcnd;
  real rowcnd; 
  VALUE rblapack_colcnd;
  real colcnd; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_info;
  integer info; 

  integer ldab;
  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  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.cgbequ( m, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGBEQU computes row and column scalings intended to equilibrate an\n*  M-by-N band matrix A and reduce its condition number.  R returns the\n*  row scale factors and C the column scale factors, chosen to try to\n*  make the largest element in each row and column of the matrix B with\n*  elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n*\n*  R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n*  number and BIGNUM = largest safe number.  Use of these scaling\n*  factors is not guaranteed to reduce the condition number of A but\n*  works well in practice.\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*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  AB      (input) COMPLEX array, dimension (LDAB,N)\n*          The band matrix A, stored in rows 1 to KL+KU+1.  The j-th\n*          column of A is stored in the j-th column of the array AB as\n*          follows:\n*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*  R       (output) REAL array, dimension (M)\n*          If INFO = 0, or INFO > M, R contains the row scale factors\n*          for A.\n*\n*  C       (output) REAL array, dimension (N)\n*          If INFO = 0, C contains the column scale factors for A.\n*\n*  ROWCND  (output) REAL\n*          If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n*          smallest R(i) to the largest R(i).  If ROWCND >= 0.1 and\n*          AMAX is neither too large nor too small, it is not worth\n*          scaling by R.\n*\n*  COLCND  (output) REAL\n*          If INFO = 0, COLCND contains the ratio of the smallest\n*          C(i) to the largest C(i).  If COLCND >= 0.1, it is not\n*          worth scaling by C.\n*\n*  AMAX    (output) REAL\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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, and i is\n*                <= M:  the i-th row of A is exactly zero\n*                >  M:  the (i-M)-th column of A is exactly zero\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.cgbequ( m, kl, ku, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_m = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  ku = NUM2INT(rblapack_ku);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,m);
    rblapack_r = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  r = NA_PTR_TYPE(rblapack_r, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  c = NA_PTR_TYPE(rblapack_c, real*);

  cgbequ_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &info);

  rblapack_rowcnd = rb_float_new((double)rowcnd);
  rblapack_colcnd = rb_float_new((double)colcnd);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
}

void
init_lapack_cgbequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgbequ", rblapack_cgbequ, -1);
}
ruby-lapack-1.7.2/ext/zlag2c.c0000644000175000017500000000743312655767576015756 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlag2c_(integer* m, integer* n, doublecomplex* a, integer* lda, complex* sa, integer* ldsa, integer* info);


static VALUE
rblapack_zlag2c(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_sa;
  complex *sa; 
  VALUE rblapack_info;
  integer info; 

  integer lda;
  integer n;
  integer ldsa;

  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  sa, info = NumRu::Lapack.zlag2c( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAG2C( M, N, A, LDA, SA, LDSA, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZLAG2C converts a COMPLEX*16 matrix, SA, to a COMPLEX matrix, A.\n*\n*  RMAX is the overflow for the SINGLE PRECISION arithmetic\n*  ZLAG2C checks that all the entries of A are between -RMAX and\n*  RMAX. If not the conversion is aborted and a flag is raised.\n*\n*  This is an auxiliary routine so there is no argument checking.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of lines 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) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the M-by-N coefficient matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  SA      (output) COMPLEX array, dimension (LDSA,N)\n*          On exit, if INFO=0, the M-by-N coefficient matrix SA; if\n*          INFO>0, the content of SA is unspecified.\n*\n*  LDSA    (input) INTEGER\n*          The leading dimension of the array SA.  LDSA >= max(1,M).\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit.\n*          = 1:  an entry of the matrix A is greater than the SINGLE\n*                PRECISION overflow threshold, in this case, the content\n*                of SA in exit is unspecified.\n*\n*  =========\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n      DOUBLE PRECISION   RMAX\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          DBLE, DIMAG\n*     ..\n*     .. External Functions ..\n      REAL               SLAMCH\n      EXTERNAL           SLAMCH\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sa, info = NumRu::Lapack.zlag2c( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  ldsa = MAX(1,m);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldsa;
    shape[1] = n;
    rblapack_sa = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  sa = NA_PTR_TYPE(rblapack_sa, complex*);

  zlag2c_(&m, &n, a, &lda, sa, &ldsa, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_sa, rblapack_info);
}

void
init_lapack_zlag2c(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlag2c", rblapack_zlag2c, -1);
}
ruby-lapack-1.7.2/ext/cstein.c0000644000175000017500000002043112502221015016006 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cstein_(integer* n, real* d, real* e, integer* m, real* w, integer* iblock, integer* isplit, complex* z, integer* ldz, real* work, integer* iwork, integer* ifail, integer* info);


static VALUE
rblapack_cstein(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_iblock;
  integer *iblock; 
  VALUE rblapack_isplit;
  integer *isplit; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_ifail;
  integer *ifail; 
  VALUE rblapack_info;
  integer info; 
  real *work;
  integer *iwork;

  integer n;
  integer ldz;
  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  z, ifail, info = NumRu::Lapack.cstein( d, e, w, iblock, isplit, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n*  Purpose\n*  =======\n*\n*  CSTEIN computes the eigenvectors of a real symmetric tridiagonal\n*  matrix T corresponding to specified eigenvalues, using inverse\n*  iteration.\n*\n*  The maximum number of iterations allowed for each eigenvector is\n*  specified by an internal parameter MAXITS (currently set to 5).\n*\n*  Although the eigenvectors are real, they are stored in a complex\n*  array, which may be passed to CUNMTR or CUPMTR for back\n*  transformation to the eigenvectors of a complex Hermitian matrix\n*  which was reduced to tridiagonal form.\n*\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  D       (input) REAL array, dimension (N)\n*          The n diagonal elements of the tridiagonal matrix T.\n*\n*  E       (input) REAL array, dimension (N-1)\n*          The (n-1) subdiagonal elements of the tridiagonal matrix\n*          T, stored in elements 1 to N-1.\n*\n*  M       (input) INTEGER\n*          The number of eigenvectors to be found.  0 <= M <= N.\n*\n*  W       (input) REAL array, dimension (N)\n*          The first M elements of W contain the eigenvalues for\n*          which eigenvectors are to be computed.  The eigenvalues\n*          should be grouped by split-off block and ordered from\n*          smallest to largest within the block.  ( The output array\n*          W from SSTEBZ with ORDER = 'B' is expected here. )\n*\n*  IBLOCK  (input) INTEGER array, dimension (N)\n*          The submatrix indices associated with the corresponding\n*          eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to\n*          the first submatrix from the top, =2 if W(i) belongs to\n*          the second submatrix, etc.  ( The output array IBLOCK\n*          from SSTEBZ is expected here. )\n*\n*  ISPLIT  (input) INTEGER array, dimension (N)\n*          The splitting points, at which T breaks up into submatrices.\n*          The first submatrix consists of rows/columns 1 to\n*          ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n*          through ISPLIT( 2 ), etc.\n*          ( The output array ISPLIT from SSTEBZ is expected here. )\n*\n*  Z       (output) COMPLEX array, dimension (LDZ, M)\n*          The computed eigenvectors.  The eigenvector associated\n*          with the eigenvalue W(i) is stored in the i-th column of\n*          Z.  Any vector which fails to converge is set to its current\n*          iterate after MAXITS iterations.\n*          The imaginary parts of the eigenvectors are set to zero.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= max(1,N).\n*\n*  WORK    (workspace) REAL array, dimension (5*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\n*\n*  IFAIL   (output) INTEGER array, dimension (M)\n*          On normal exit, all elements of IFAIL are zero.\n*          If one or more eigenvectors fail to converge after\n*          MAXITS iterations, then their indices are stored in\n*          array IFAIL.\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, then i eigenvectors failed to converge\n*               in MAXITS iterations.  Their indices are stored in\n*               array IFAIL.\n*\n*  Internal Parameters\n*  ===================\n*\n*  MAXITS  INTEGER, default = 5\n*          The maximum number of iterations performed.\n*\n*  EXTRA   INTEGER, default = 2\n*          The number of iterations performed after norm growth\n*          criterion is satisfied, should be at least 1.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  z, ifail, info = NumRu::Lapack.cstein( d, e, w, iblock, isplit, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_d = argv[0];
  rblapack_e = argv[1];
  rblapack_w = argv[2];
  rblapack_iblock = argv[3];
  rblapack_isplit = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_w))
    rb_raise(rb_eArgError, "w (3th argument) must be NArray");
  if (NA_RANK(rblapack_w) != 1)
    rb_raise(rb_eArgError, "rank of w (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_w) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_w) != NA_SFLOAT)
    rblapack_w = na_change_type(rblapack_w, NA_SFLOAT);
  w = NA_PTR_TYPE(rblapack_w, real*);
  if (!NA_IsNArray(rblapack_isplit))
    rb_raise(rb_eArgError, "isplit (5th argument) must be NArray");
  if (NA_RANK(rblapack_isplit) != 1)
    rb_raise(rb_eArgError, "rank of isplit (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_isplit) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of isplit must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_isplit) != NA_LINT)
    rblapack_isplit = na_change_type(rblapack_isplit, NA_LINT);
  isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
  if (!NA_IsNArray(rblapack_iblock))
    rb_raise(rb_eArgError, "iblock (4th argument) must be NArray");
  if (NA_RANK(rblapack_iblock) != 1)
    rb_raise(rb_eArgError, "rank of iblock (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_iblock) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of iblock must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_iblock) != NA_LINT)
    rblapack_iblock = na_change_type(rblapack_iblock, NA_LINT);
  iblock = NA_PTR_TYPE(rblapack_iblock, integer*);
  m = n;
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (2th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  ldz = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = m;
    rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, complex*);
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
  work = ALLOC_N(real, (5*n));
  iwork = ALLOC_N(integer, (n));

  cstein_(&n, d, e, &m, w, iblock, isplit, z, &ldz, work, iwork, ifail, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_z, rblapack_ifail, rblapack_info);
}

void
init_lapack_cstein(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cstein", rblapack_cstein, -1);
}
ruby-lapack-1.7.2/ext/zpotri.c0000644000175000017500000000740412502221012016052 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zpotri_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* info);


static VALUE
rblapack_zpotri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *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  info, a = NumRu::Lapack.zpotri( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPOTRI( UPLO, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPOTRI computes the inverse of a complex Hermitian positive definite\n*  matrix A using the Cholesky factorization A = U**H*U or A = L*L**H\n*  computed by ZPOTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the triangular factor U or L from the Cholesky\n*          factorization A = U**H*U or A = L*L**H, as computed by\n*          ZPOTRF.\n*          On exit, the upper or lower triangle of the (Hermitian)\n*          inverse of A, overwriting the input factor U or L.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\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,i) element of the factor U or L is\n*                zero, and the inverse could not be computed.\n*\n\n*  =====================================================================\n*\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZLAUUM, ZTRTRI\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.zpotri( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zpotri_(&uplo, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_zpotri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zpotri", rblapack_zpotri, -1);
}
ruby-lapack-1.7.2/ext/zsptrf.c0000644000175000017500000001503112502221014016050 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zsptrf_(char* uplo, integer* n, doublecomplex* ap, integer* ipiv, integer* info);


static VALUE
rblapack_zsptrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublecomplex *ap_out__;

  integer ldap;
  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  ipiv, info, ap = NumRu::Lapack.zsptrf( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSPTRF( UPLO, N, AP, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZSPTRF computes the factorization of a complex symmetric matrix A\n*  stored in packed format using the Bunch-Kaufman diagonal pivoting\n*  method:\n*\n*     A = U*D*U**T  or  A = L*D*L**T\n*\n*  where U (or L) is a product of permutation and unit upper (lower)\n*  triangular matrices, and D is symmetric and block diagonal with\n*  1-by-1 and 2-by-2 diagonal blocks.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L, stored as a packed triangular\n*          matrix overwriting A (see below for further details).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D.\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\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, D(i,i) is exactly zero.  The factorization\n*               has been completed, but the block diagonal matrix D is\n*               exactly singular, and division by zero will occur if it\n*               is used to solve a system of equations.\n*\n\n*  Further Details\n*  ===============\n*\n*  5-96 - Based on modifications by J. Lewis, Boeing Computer Services\n*         Company\n*\n*  If UPLO = 'U', then A = U*D*U', where\n*     U = P(n)*U(n)* ... *P(k)U(k)* ...,\n*  i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n*  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    v    0   )   k-s\n*     U(k) =  (   0    I    0   )   s\n*             (   0    0    I   )   n-k\n*                k-s   s   n-k\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n*  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n*  and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n*  If UPLO = 'L', then A = L*D*L', where\n*     L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n*  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n*  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    0     0   )  k-1\n*     L(k) =  (   0    I     0   )  s\n*             (   0    v     I   )  n-k-s+1\n*                k-1   s  n-k-s+1\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n*  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n*  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, ap = NumRu::Lapack.zsptrf( uplo, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
  MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  zsptrf_(&uplo, &n, ap, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_ap);
}

void
init_lapack_zsptrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zsptrf", rblapack_zsptrf, -1);
}
ruby-lapack-1.7.2/ext/chla_transtype.c0000644000175000017500000000424612502221020017543 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chla_transtype_(char *__out__, integer* trans);


static VALUE
rblapack_chla_transtype(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  integer trans; 
  VALUE rblapack___out__;
  char __out__; 


  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  __out__ = NumRu::Lapack.chla_transtype( trans, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      CHARACTER*1 FUNCTION CHLA_TRANSTYPE( TRANS )\n\n*  Purpose\n*  =======\n*\n*  This subroutine translates from a BLAST-specified integer constant to\n*  the character string specifying a transposition operation.\n*\n*  CHLA_TRANSTYPE returns an CHARACTER*1.  If CHLA_TRANSTYPE is 'X',\n*  then input is not an integer indicating a transposition operator.\n*  Otherwise CHLA_TRANSTYPE returns the constant value corresponding to\n*  TRANS.\n*\n\n*  Arguments\n*  =========\n*  TRANS   (input) INTEGER\n*          Specifies the form of the system of equations:\n*          = BLAS_NO_TRANS   = 111 :  No Transpose\n*          = BLAS_TRANS      = 112 :  Transpose\n*          = BLAS_CONJ_TRANS = 113 :  Conjugate Transpose\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.chla_transtype( trans, [: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_trans = argv[0];
  if (argc == 1) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = NUM2INT(rblapack_trans);

  chla_transtype_(&__out__, &trans);

  rblapack___out__ = rb_str_new(&__out__,1);
  return rblapack___out__;
}

void
init_lapack_chla_transtype(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chla_transtype", rblapack_chla_transtype, -1);
}
ruby-lapack-1.7.2/ext/ssprfs.c0000644000175000017500000002047712502221025016054 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssprfs_(char* uplo, integer* n, integer* nrhs, real* ap, real* afp, integer* ipiv, real* b, integer* ldb, real* x, integer* ldx, real* ferr, real* berr, real* work, integer* iwork, integer* info);


static VALUE
rblapack_ssprfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_afp;
  real *afp; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  real *x_out__;
  real *work;
  integer *iwork;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.ssprfs( uplo, ap, afp, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSPRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is symmetric indefinite\n*  and packed, and provides error bounds and backward error estimates\n*  for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AP      (input) REAL array, dimension (N*(N+1)/2)\n*          The upper or lower triangle of the symmetric matrix A, packed\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  AFP     (input) REAL array, dimension (N*(N+1)/2)\n*          The factored form of the matrix A.  AFP contains the block\n*          diagonal matrix D and the multipliers used to obtain the\n*          factor U or L from the factorization A = U*D*U**T or\n*          A = L*D*L**T as computed by SSPTRF, stored as a packed\n*          triangular matrix.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by SSPTRF.\n*\n*  B       (input) REAL array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) REAL array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by SSPTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) REAL array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.ssprfs( uplo, ap, afp, ipiv, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_afp = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_b = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (!NA_IsNArray(rblapack_afp))
    rb_raise(rb_eArgError, "afp (3th argument) must be NArray");
  if (NA_RANK(rblapack_afp) != 1)
    rb_raise(rb_eArgError, "rank of afp (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_afp) != NA_SFLOAT)
    rblapack_afp = na_change_type(rblapack_afp, NA_SFLOAT);
  afp = NA_PTR_TYPE(rblapack_afp, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(real, (3*n));
  iwork = ALLOC_N(integer, (n));

  ssprfs_(&uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_ssprfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssprfs", rblapack_ssprfs, -1);
}
ruby-lapack-1.7.2/ext/clagtm.c0000644000175000017500000001474012502221022015774 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clagtm_(char* trans, integer* n, integer* nrhs, real* alpha, complex* dl, complex* d, complex* du, complex* x, integer* ldx, real* beta, complex* b, integer* ldb);


static VALUE
rblapack_clagtm(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_alpha;
  real alpha; 
  VALUE rblapack_dl;
  complex *dl; 
  VALUE rblapack_d;
  complex *d; 
  VALUE rblapack_du;
  complex *du; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_beta;
  real beta; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer n;
  integer ldx;
  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  b = NumRu::Lapack.clagtm( trans, alpha, dl, d, du, x, beta, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, B, LDB )\n\n*  Purpose\n*  =======\n*\n*  CLAGTM performs a matrix-vector product of the form\n*\n*     B := alpha * A * X + beta * B\n*\n*  where A is a tridiagonal matrix of order N, B and X are N by NRHS\n*  matrices, and alpha and beta are real scalars, each of which may be\n*  0., 1., or -1.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the operation applied to A.\n*          = 'N':  No transpose, B := alpha * A * X + beta * B\n*          = 'T':  Transpose,    B := alpha * A**T * X + beta * B\n*          = 'C':  Conjugate transpose, B := alpha * A**H * X + beta * B\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices X and B.\n*\n*  ALPHA   (input) REAL\n*          The scalar alpha.  ALPHA must be 0., 1., or -1.; otherwise,\n*          it is assumed to be 0.\n*\n*  DL      (input) COMPLEX array, dimension (N-1)\n*          The (n-1) sub-diagonal elements of T.\n*\n*  D       (input) COMPLEX array, dimension (N)\n*          The diagonal elements of T.\n*\n*  DU      (input) COMPLEX array, dimension (N-1)\n*          The (n-1) super-diagonal elements of T.\n*\n*  X       (input) COMPLEX array, dimension (LDX,NRHS)\n*          The N by NRHS matrix X.\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(N,1).\n*\n*  BETA    (input) REAL\n*          The scalar beta.  BETA must be 0., 1., or -1.; otherwise,\n*          it is assumed to be 1.\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the N by NRHS matrix B.\n*          On exit, B is overwritten by the matrix expression\n*          B := alpha * A * X + beta * B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(N,1).\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  b = NumRu::Lapack.clagtm( trans, alpha, dl, d, du, x, beta, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_trans = argv[0];
  rblapack_alpha = argv[1];
  rblapack_dl = argv[2];
  rblapack_d = argv[3];
  rblapack_du = argv[4];
  rblapack_x = argv[5];
  rblapack_beta = argv[6];
  rblapack_b = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SCOMPLEX)
    rblapack_d = na_change_type(rblapack_d, NA_SCOMPLEX);
  d = NA_PTR_TYPE(rblapack_d, complex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  alpha = (real)NUM2DBL(rblapack_alpha);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (5th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_SCOMPLEX)
    rblapack_du = na_change_type(rblapack_du, NA_SCOMPLEX);
  du = NA_PTR_TYPE(rblapack_du, complex*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (3th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_SCOMPLEX)
    rblapack_dl = na_change_type(rblapack_dl, NA_SCOMPLEX);
  dl = NA_PTR_TYPE(rblapack_dl, complex*);
  beta = (real)NUM2DBL(rblapack_beta);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  clagtm_(&trans, &n, &nrhs, &alpha, dl, d, du, x, &ldx, &beta, b, &ldb);

  return rblapack_b;
}

void
init_lapack_clagtm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clagtm", rblapack_clagtm, -1);
}
ruby-lapack-1.7.2/ext/csprfs.c0000644000175000017500000002061212502221016016023 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID csprfs_(char* uplo, integer* n, integer* nrhs, complex* ap, complex* afp, integer* ipiv, complex* b, integer* ldb, complex* x, integer* ldx, real* ferr, real* berr, complex* work, real* rwork, integer* info);


static VALUE
rblapack_csprfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_afp;
  complex *afp; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  complex *x_out__;
  complex *work;
  real *rwork;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.csprfs( uplo, ap, afp, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CSPRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is symmetric indefinite\n*  and packed, and provides error bounds and backward error estimates\n*  for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)\n*          The upper or lower triangle of the symmetric matrix A, packed\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  AFP     (input) COMPLEX array, dimension (N*(N+1)/2)\n*          The factored form of the matrix A.  AFP contains the block\n*          diagonal matrix D and the multipliers used to obtain the\n*          factor U or L from the factorization A = U*D*U**T or\n*          A = L*D*L**T as computed by CSPTRF, stored as a packed\n*          triangular matrix.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by CSPTRF.\n*\n*  B       (input) COMPLEX array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) COMPLEX array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by CSPTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.csprfs( uplo, ap, afp, ipiv, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_afp = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_b = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (!NA_IsNArray(rblapack_afp))
    rb_raise(rb_eArgError, "afp (3th argument) must be NArray");
  if (NA_RANK(rblapack_afp) != 1)
    rb_raise(rb_eArgError, "rank of afp (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_afp) != NA_SCOMPLEX)
    rblapack_afp = na_change_type(rblapack_afp, NA_SCOMPLEX);
  afp = NA_PTR_TYPE(rblapack_afp, complex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (n));

  csprfs_(&uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_csprfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "csprfs", rblapack_csprfs, -1);
}
ruby-lapack-1.7.2/ext/cla_syrcond_x.c0000644000175000017500000001623112502221024017353 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real cla_syrcond_x_(char* uplo, integer* n, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, complex* x, integer* info, complex* work, real* rwork);


static VALUE
rblapack_cla_syrcond_x(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_rwork;
  real *rwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack___out__;
  real __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  info, __out__ = NumRu::Lapack.cla_syrcond_x( uplo, a, af, ipiv, x, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL FUNCTION CLA_SYRCOND_X( UPLO, N, A, LDA, AF, LDAF, IPIV, X, INFO, WORK, RWORK )\n\n*  Purpose\n*  =======\n*\n*     CLA_SYRCOND_X Computes the infinity norm condition number of\n*     op(A) * diag(X) where X is a COMPLEX vector.\n*\n\n*  Arguments\n*  =========\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     A       (input) COMPLEX array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX array, dimension (LDAF,N)\n*     The block diagonal matrix D and the multipliers used to\n*     obtain the factor U or L as computed by CSYTRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     Details of the interchanges and the block structure of D\n*     as determined by CSYTRF.\n*\n*     X       (input) COMPLEX array, dimension (N)\n*     The vector X in the formula op(A) * diag(X).\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit.\n*     i > 0:  The ith argument is invalid.\n*\n*     WORK    (input) COMPLEX array, dimension (2*N).\n*     Workspace.\n*\n*     RWORK   (input) REAL array, dimension (N).\n*     Workspace.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            KASE\n      REAL               AINVNM, ANORM, TMP\n      INTEGER            I, J\n      LOGICAL            UP\n      COMPLEX            ZDUM\n*     ..\n*     .. Local Arrays ..\n      INTEGER            ISAVE( 3 )\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CLACN2, CSYTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX\n*     ..\n*     .. Statement Functions ..\n      REAL               CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, __out__ = NumRu::Lapack.cla_syrcond_x( uplo, a, af, ipiv, x, work, rwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_x = argv[4];
  rblapack_work = argv[5];
  rblapack_rwork = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (5th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  if (!NA_IsNArray(rblapack_rwork))
    rb_raise(rb_eArgError, "rwork (7th argument) must be NArray");
  if (NA_RANK(rblapack_rwork) != 1)
    rb_raise(rb_eArgError, "rank of rwork (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_rwork) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_rwork) != NA_SFLOAT)
    rblapack_rwork = na_change_type(rblapack_rwork, NA_SFLOAT);
  rwork = NA_PTR_TYPE(rblapack_rwork, real*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (6th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
  if (NA_TYPE(rblapack_work) != NA_SCOMPLEX)
    rblapack_work = na_change_type(rblapack_work, NA_SCOMPLEX);
  work = NA_PTR_TYPE(rblapack_work, complex*);

  __out__ = cla_syrcond_x_(&uplo, &n, a, &lda, af, &ldaf, ipiv, x, &info, work, rwork);

  rblapack_info = INT2NUM(info);
  rblapack___out__ = rb_float_new((double)__out__);
  return rb_ary_new3(2, rblapack_info, rblapack___out__);
}

void
init_lapack_cla_syrcond_x(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cla_syrcond_x", rblapack_cla_syrcond_x, -1);
}
ruby-lapack-1.7.2/ext/cunglq.c0000644000175000017500000001245412502221022016016 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cunglq_(integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_cunglq(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;

  integer lda;
  integer n;
  integer k;

  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 = NumRu::Lapack.cunglq( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CUNGLQ generates an M-by-N complex matrix Q with orthonormal rows,\n*  which is defined as the first M rows of a product of K elementary\n*  reflectors of order N\n*\n*        Q  =  H(k)' . . . H(2)' H(1)'\n*\n*  as returned by CGELQF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. N >= M.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. M >= K >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the i-th row must contain the vector which defines\n*          the elementary reflector H(i), for i = 1,2,...,k, as returned\n*          by CGELQF in the first k rows of its array argument A.\n*          On exit, the M-by-N matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) COMPLEX array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by CGELQF.\n*\n*  WORK    (workspace/output) COMPLEX 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\n*          the 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 has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, a = NumRu::Lapack.cunglq( m, a, tau, [: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_m = argv[0];
  rblapack_a = argv[1];
  rblapack_tau = 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;
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (rblapack_lwork == Qnil)
    lwork = m;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  cunglq_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_cunglq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cunglq", rblapack_cunglq, -1);
}
ruby-lapack-1.7.2/ext/dppsvx.c0000644000175000017500000003660212502221017016056 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dppsvx_(char* fact, char* uplo, integer* n, integer* nrhs, doublereal* ap, doublereal* afp, char* equed, doublereal* s, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dppsvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_afp;
  doublereal *afp; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublereal *ap_out__;
  VALUE rblapack_afp_out__;
  doublereal *afp_out__;
  VALUE rblapack_s_out__;
  doublereal *s_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;
  doublereal *work;
  integer *iwork;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, info, ap, afp, equed, s, b = NumRu::Lapack.dppsvx( fact, uplo, ap, afp, equed, s, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPPSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to\n*  compute the solution to a real system of linear equations\n*     A * X = B,\n*  where A is an N-by-N symmetric positive definite matrix stored in\n*  packed format and X and B are N-by-NRHS matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'E', real scaling factors are computed to equilibrate\n*     the system:\n*        diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n*  2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n*     factor the matrix A (after equilibration if FACT = 'E') as\n*        A = U**T* U,  if UPLO = 'U', or\n*        A = L * L**T,  if UPLO = 'L',\n*     where U is an upper triangular matrix and L is a lower triangular\n*     matrix.\n*\n*  3. If the leading i-by-i principal minor is not positive definite,\n*     then the routine returns with INFO = i. Otherwise, the factored\n*     form of A is used to estimate the condition number of the matrix\n*     A.  If the reciprocal of the condition number is less than machine\n*     precision, INFO = N+1 is returned as a warning, but the routine\n*     still goes on to solve for X and compute error bounds as\n*     described below.\n*\n*  4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  5. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n*  6. If equilibration was used, the matrix X is premultiplied by\n*     diag(S) so that it solves the original system before\n*     equilibration.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of the matrix A is\n*          supplied on entry, and if not, whether the matrix A should be\n*          equilibrated before it is factored.\n*          = 'F':  On entry, AFP contains the factored form of A.\n*                  If EQUED = 'Y', the matrix A has been equilibrated\n*                  with scaling factors given by S.  AP and AFP will not\n*                  be modified.\n*          = 'N':  The matrix A will be copied to AFP and factored.\n*          = 'E':  The matrix A will be equilibrated if necessary, then\n*                  copied to AFP and factored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array, except if FACT = 'F'\n*          and EQUED = 'Y', then A must contain the equilibrated matrix\n*          diag(S)*A*diag(S).  The j-th column of A is stored in the\n*          array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          See below for further details.  A is not modified if\n*          FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n*          On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n*          diag(S)*A*diag(S).\n*\n*  AFP     (input or output) DOUBLE PRECISION array, dimension\n*                            (N*(N+1)/2)\n*          If FACT = 'F', then AFP is an input argument and on entry\n*          contains the triangular factor U or L from the Cholesky\n*          factorization A = U'*U or A = L*L', in the same storage\n*          format as A.  If EQUED .ne. 'N', then AFP is the factored\n*          form of the equilibrated matrix A.\n*\n*          If FACT = 'N', then AFP is an output argument and on exit\n*          returns the triangular factor U or L from the Cholesky\n*          factorization A = U'*U or A = L*L' of the original matrix A.\n*\n*          If FACT = 'E', then AFP is an output argument and on exit\n*          returns the triangular factor U or L from the Cholesky\n*          factorization A = U'*U or A = L*L' of the equilibrated\n*          matrix A (see the description of AP for the form of the\n*          equilibrated matrix).\n*\n*  EQUED   (input or output) CHARACTER*1\n*          Specifies the form of equilibration that was done.\n*          = 'N':  No equilibration (always true if FACT = 'N').\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*          EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*          output argument.\n*\n*  S       (input or output) DOUBLE PRECISION array, dimension (N)\n*          The scale factors for A; not accessed if EQUED = 'N'.  S is\n*          an input argument if FACT = 'F'; otherwise, S is an output\n*          argument.  If FACT = 'F' and EQUED = 'Y', each element of S\n*          must be positive.\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n*          B is overwritten by diag(S) * B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n*          the original system of equations.  Note that if EQUED = 'Y',\n*          A and B are modified on exit, and the solution to the\n*          equilibrated system is inv(diag(S))*X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The estimate of the reciprocal condition number of the matrix\n*          A after equilibration (if done).  If RCOND is less than the\n*          machine precision (in particular, if RCOND = 0), the matrix\n*          is singular to working precision.  This condition is\n*          indicated by a return code of INFO > 0.\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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, and i is\n*                <= N:  the leading minor of order i of A is\n*                       not positive definite, so the factorization\n*                       could not be completed, and the solution has not\n*                       been computed. RCOND = 0 is returned.\n*                = N+1: U is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  Further Details\n*  ===============\n*\n*  The packed storage scheme is illustrated by the following example\n*  when N = 4, UPLO = 'U':\n*\n*  Two-dimensional storage of the symmetric matrix A:\n*\n*     a11 a12 a13 a14\n*         a22 a23 a24\n*             a33 a34     (aij = conjg(aji))\n*                 a44\n*\n*  Packed storage of the upper triangle of A:\n*\n*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, info, ap, afp, equed, s, b = NumRu::Lapack.dppsvx( fact, uplo, ap, afp, equed, s, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_ap = argv[2];
  rblapack_afp = argv[3];
  rblapack_equed = argv[4];
  rblapack_s = argv[5];
  rblapack_b = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (6th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_s);
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  ldx = MAX(1,n);
  if (!NA_IsNArray(rblapack_afp))
    rb_raise(rb_eArgError, "afp (4th argument) must be NArray");
  if (NA_RANK(rblapack_afp) != 1)
    rb_raise(rb_eArgError, "rank of afp (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_afp) != NA_DFLOAT)
    rblapack_afp = na_change_type(rblapack_afp, NA_DFLOAT);
  afp = NA_PTR_TYPE(rblapack_afp, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
  MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_afp_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  afp_out__ = NA_PTR_TYPE(rblapack_afp_out__, doublereal*);
  MEMCPY(afp_out__, afp, doublereal, NA_TOTAL(rblapack_afp));
  rblapack_afp = rblapack_afp_out__;
  afp = afp_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
  MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(doublereal, (3*n));
  iwork = ALLOC_N(integer, (n));

  dppsvx_(&fact, &uplo, &n, &nrhs, ap, afp, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_ap, rblapack_afp, rblapack_equed, rblapack_s, rblapack_b);
}

void
init_lapack_dppsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dppsvx", rblapack_dppsvx, -1);
}
ruby-lapack-1.7.2/ext/slabad.c0000644000175000017500000000533212502221024015752 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slabad_(real* small, real* large);


static VALUE
rblapack_slabad(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_small;
  real small; 
  VALUE rblapack_large;
  real large; 


  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  small, large = NumRu::Lapack.slabad( small, large, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLABAD( SMALL, LARGE )\n\n*  Purpose\n*  =======\n*\n*  SLABAD takes as input the values computed by SLAMCH for underflow and\n*  overflow, and returns the square root of each of these values if the\n*  log of LARGE is sufficiently large.  This subroutine is intended to\n*  identify machines with a large exponent range, such as the Crays, and\n*  redefine the underflow and overflow limits to be the square roots of\n*  the values computed by SLAMCH.  This subroutine is needed because\n*  SLAMCH does not compensate for poor arithmetic in the upper half of\n*  the exponent range, as is found on a Cray.\n*\n\n*  Arguments\n*  =========\n*\n*  SMALL   (input/output) REAL\n*          On entry, the underflow threshold as computed by SLAMCH.\n*          On exit, if LOG10(LARGE) is sufficiently large, the square\n*          root of SMALL, otherwise unchanged.\n*\n*  LARGE   (input/output) REAL\n*          On entry, the overflow threshold as computed by SLAMCH.\n*          On exit, if LOG10(LARGE) is sufficiently large, the square\n*          root of LARGE, otherwise unchanged.\n*\n\n*  =====================================================================\n*\n*     .. Intrinsic Functions ..\n      INTRINSIC          LOG10, SQRT\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  small, large = NumRu::Lapack.slabad( small, large, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_small = argv[0];
  rblapack_large = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  small = (real)NUM2DBL(rblapack_small);
  large = (real)NUM2DBL(rblapack_large);

  slabad_(&small, &large);

  rblapack_small = rb_float_new((double)small);
  rblapack_large = rb_float_new((double)large);
  return rb_ary_new3(2, rblapack_small, rblapack_large);
}

void
init_lapack_slabad(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slabad", rblapack_slabad, -1);
}
ruby-lapack-1.7.2/ext/slag2d.c0000644000175000017500000000644112502221020015676 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slag2d_(integer* m, integer* n, real* sa, integer* ldsa, doublereal* a, integer* lda, integer* info);


static VALUE
rblapack_slag2d(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_sa;
  real *sa; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_info;
  integer info; 

  integer ldsa;
  integer n;
  integer lda;

  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  a, info = NumRu::Lapack.slag2d( m, sa, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAG2D( M, N, SA, LDSA, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLAG2D converts a SINGLE PRECISION matrix, SA, to a DOUBLE\n*  PRECISION matrix, A.\n*\n*  Note that while it is possible to overflow while converting\n*  from double to single, it is not possible to overflow when\n*  converting from single to double.\n*\n*  This is an auxiliary routine so there is no argument checking.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of lines of the matrix A.  M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.  N >= 0.\n*\n*  SA      (input) REAL array, dimension (LDSA,N)\n*          On entry, the M-by-N coefficient matrix SA.\n*\n*  LDSA    (input) INTEGER\n*          The leading dimension of the array SA.  LDSA >= max(1,M).\n*\n*  A       (output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On exit, the M-by-N coefficient matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*  =========\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  a, info = NumRu::Lapack.slag2d( m, sa, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_sa = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  lda = MAX(1,m);
  if (!NA_IsNArray(rblapack_sa))
    rb_raise(rb_eArgError, "sa (2th argument) must be NArray");
  if (NA_RANK(rblapack_sa) != 2)
    rb_raise(rb_eArgError, "rank of sa (2th argument) must be %d", 2);
  ldsa = NA_SHAPE0(rblapack_sa);
  n = NA_SHAPE1(rblapack_sa);
  if (NA_TYPE(rblapack_sa) != NA_SFLOAT)
    rblapack_sa = na_change_type(rblapack_sa, NA_SFLOAT);
  sa = NA_PTR_TYPE(rblapack_sa, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  a = NA_PTR_TYPE(rblapack_a, doublereal*);

  slag2d_(&m, &n, sa, &ldsa, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_a, rblapack_info);
}

void
init_lapack_slag2d(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slag2d", rblapack_slag2d, -1);
}
ruby-lapack-1.7.2/ext/ctpttr.c0000644000175000017500000000737212502221021016047 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctpttr_(char* uplo, integer* n, complex* ap, complex* a, integer* lda, integer* info);


static VALUE
rblapack_ctpttr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_info;
  integer info; 

  integer ldap;
  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  a, info = NumRu::Lapack.ctpttr( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTPTTR( UPLO, N, AP, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTPTTR copies a triangular matrix A from standard packed format (TP)\n*  to standard full format (TR).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular.\n*          = 'L':  A is lower triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0.\n*\n*  AP      (input) COMPLEX array, dimension ( N*(N+1)/2 ),\n*          On entry, the upper or lower triangular matrix A, packed\n*          columnwise in a linear array. The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  A       (output) COMPLEX array, dimension ( LDA, N )\n*          On exit, the triangular matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  a, info = NumRu::Lapack.ctpttr( uplo, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  lda = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a = NA_PTR_TYPE(rblapack_a, complex*);

  ctpttr_(&uplo, &n, ap, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_a, rblapack_info);
}

void
init_lapack_ctpttr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctpttr", rblapack_ctpttr, -1);
}
ruby-lapack-1.7.2/ext/dlaebz.c0000644000175000017500000004360712502221016015775 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaebz_(integer* ijob, integer* nitmax, integer* n, integer* mmax, integer* minp, integer* nbmin, doublereal* abstol, doublereal* reltol, doublereal* pivmin, doublereal* d, doublereal* e, doublereal* e2, integer* nval, doublereal* ab, doublereal* c, integer* mout, integer* nab, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dlaebz(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ijob;
  integer ijob; 
  VALUE rblapack_nitmax;
  integer nitmax; 
  VALUE rblapack_minp;
  integer minp; 
  VALUE rblapack_nbmin;
  integer nbmin; 
  VALUE rblapack_abstol;
  doublereal abstol; 
  VALUE rblapack_reltol;
  doublereal reltol; 
  VALUE rblapack_pivmin;
  doublereal pivmin; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_e2;
  doublereal *e2; 
  VALUE rblapack_nval;
  integer *nval; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_nab;
  integer *nab; 
  VALUE rblapack_mout;
  integer mout; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_nval_out__;
  integer *nval_out__;
  VALUE rblapack_ab_out__;
  doublereal *ab_out__;
  VALUE rblapack_c_out__;
  doublereal *c_out__;
  VALUE rblapack_nab_out__;
  integer *nab_out__;
  doublereal *work;
  integer *iwork;

  integer n;
  integer mmax;

  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  mout, info, nval, ab, c, nab = NumRu::Lapack.dlaebz( ijob, nitmax, minp, nbmin, abstol, reltol, pivmin, d, e, e2, nval, ab, c, nab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL, RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT, NAB, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLAEBZ contains the iteration loops which compute and use the\n*  function N(w), which is the count of eigenvalues of a symmetric\n*  tridiagonal matrix T less than or equal to its argument  w.  It\n*  performs a choice of two types of loops:\n*\n*  IJOB=1, followed by\n*  IJOB=2: It takes as input a list of intervals and returns a list of\n*          sufficiently small intervals whose union contains the same\n*          eigenvalues as the union of the original intervals.\n*          The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP.\n*          The output interval (AB(j,1),AB(j,2)] will contain\n*          eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT.\n*\n*  IJOB=3: It performs a binary search in each input interval\n*          (AB(j,1),AB(j,2)] for a point  w(j)  such that\n*          N(w(j))=NVAL(j), and uses  C(j)  as the starting point of\n*          the search.  If such a w(j) is found, then on output\n*          AB(j,1)=AB(j,2)=w.  If no such w(j) is found, then on output\n*          (AB(j,1),AB(j,2)] will be a small interval containing the\n*          point where N(w) jumps through NVAL(j), unless that point\n*          lies outside the initial interval.\n*\n*  Note that the intervals are in all cases half-open intervals,\n*  i.e., of the form  (a,b] , which includes  b  but not  a .\n*\n*  To avoid underflow, the matrix should be scaled so that its largest\n*  element is no greater than  overflow**(1/2) * underflow**(1/4)\n*  in absolute value.  To assure the most accurate computation\n*  of small eigenvalues, the matrix should be scaled to be\n*  not much smaller than that, either.\n*\n*  See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n*  Matrix\", Report CS41, Computer Science Dept., Stanford\n*  University, July 21, 1966\n*\n*  Note: the arguments are, in general, *not* checked for unreasonable\n*  values.\n*\n\n*  Arguments\n*  =========\n*\n*  IJOB    (input) INTEGER\n*          Specifies what is to be done:\n*          = 1:  Compute NAB for the initial intervals.\n*          = 2:  Perform bisection iteration to find eigenvalues of T.\n*          = 3:  Perform bisection iteration to invert N(w), i.e.,\n*                to find a point which has a specified number of\n*                eigenvalues of T to its left.\n*          Other values will cause DLAEBZ to return with INFO=-1.\n*\n*  NITMAX  (input) INTEGER\n*          The maximum number of \"levels\" of bisection to be\n*          performed, i.e., an interval of width W will not be made\n*          smaller than 2^(-NITMAX) * W.  If not all intervals\n*          have converged after NITMAX iterations, then INFO is set\n*          to the number of non-converged intervals.\n*\n*  N       (input) INTEGER\n*          The dimension n of the tridiagonal matrix T.  It must be at\n*          least 1.\n*\n*  MMAX    (input) INTEGER\n*          The maximum number of intervals.  If more than MMAX intervals\n*          are generated, then DLAEBZ will quit with INFO=MMAX+1.\n*\n*  MINP    (input) INTEGER\n*          The initial number of intervals.  It may not be greater than\n*          MMAX.\n*\n*  NBMIN   (input) INTEGER\n*          The smallest number of intervals that should be processed\n*          using a vector loop.  If zero, then only the scalar loop\n*          will be used.\n*\n*  ABSTOL  (input) DOUBLE PRECISION\n*          The minimum (absolute) width of an interval.  When an\n*          interval is narrower than ABSTOL, or than RELTOL times the\n*          larger (in magnitude) endpoint, then it is considered to be\n*          sufficiently small, i.e., converged.  This must be at least\n*          zero.\n*\n*  RELTOL  (input) DOUBLE PRECISION\n*          The minimum relative width of an interval.  When an interval\n*          is narrower than ABSTOL, or than RELTOL times the larger (in\n*          magnitude) endpoint, then it is considered to be\n*          sufficiently small, i.e., converged.  Note: this should\n*          always be at least radix*machine epsilon.\n*\n*  PIVMIN  (input) DOUBLE PRECISION\n*          The minimum absolute value of a \"pivot\" in the Sturm\n*          sequence loop.  This *must* be at least  max |e(j)**2| *\n*          safe_min  and at least safe_min, where safe_min is at least\n*          the smallest number that can divide one without overflow.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          The diagonal elements of the tridiagonal matrix T.\n*\n*  E       (input) DOUBLE PRECISION array, dimension (N)\n*          The offdiagonal elements of the tridiagonal matrix T in\n*          positions 1 through N-1.  E(N) is arbitrary.\n*\n*  E2      (input) DOUBLE PRECISION array, dimension (N)\n*          The squares of the offdiagonal elements of the tridiagonal\n*          matrix T.  E2(N) is ignored.\n*\n*  NVAL    (input/output) INTEGER array, dimension (MINP)\n*          If IJOB=1 or 2, not referenced.\n*          If IJOB=3, the desired values of N(w).  The elements of NVAL\n*          will be reordered to correspond with the intervals in AB.\n*          Thus, NVAL(j) on output will not, in general be the same as\n*          NVAL(j) on input, but it will correspond with the interval\n*          (AB(j,1),AB(j,2)] on output.\n*\n*  AB      (input/output) DOUBLE PRECISION array, dimension (MMAX,2)\n*          The endpoints of the intervals.  AB(j,1) is  a(j), the left\n*          endpoint of the j-th interval, and AB(j,2) is b(j), the\n*          right endpoint of the j-th interval.  The input intervals\n*          will, in general, be modified, split, and reordered by the\n*          calculation.\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (MMAX)\n*          If IJOB=1, ignored.\n*          If IJOB=2, workspace.\n*          If IJOB=3, then on input C(j) should be initialized to the\n*          first search point in the binary search.\n*\n*  MOUT    (output) INTEGER\n*          If IJOB=1, the number of eigenvalues in the intervals.\n*          If IJOB=2 or 3, the number of intervals output.\n*          If IJOB=3, MOUT will equal MINP.\n*\n*  NAB     (input/output) INTEGER array, dimension (MMAX,2)\n*          If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)).\n*          If IJOB=2, then on input, NAB(i,j) should be set.  It must\n*             satisfy the condition:\n*             N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)),\n*             which means that in interval i only eigenvalues\n*             NAB(i,1)+1,...,NAB(i,2) will be considered.  Usually,\n*             NAB(i,j)=N(AB(i,j)), from a previous call to DLAEBZ with\n*             IJOB=1.\n*             On output, NAB(i,j) will contain\n*             max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of\n*             the input interval that the output interval\n*             (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the\n*             the input values of NAB(k,1) and NAB(k,2).\n*          If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)),\n*             unless N(w) > NVAL(i) for all search points  w , in which\n*             case NAB(i,1) will not be modified, i.e., the output\n*             value will be the same as the input value (modulo\n*             reorderings -- see NVAL and AB), or unless N(w) < NVAL(i)\n*             for all search points  w , in which case NAB(i,2) will\n*             not be modified.  Normally, NAB should be set to some\n*             distinctive value(s) before DLAEBZ is called.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (MMAX)\n*          Workspace.\n*\n*  IWORK   (workspace) INTEGER array, dimension (MMAX)\n*          Workspace.\n*\n*  INFO    (output) INTEGER\n*          = 0:       All intervals converged.\n*          = 1--MMAX: The last INFO intervals did not converge.\n*          = MMAX+1:  More than MMAX intervals were generated.\n*\n\n*  Further Details\n*  ===============\n*\n*      This routine is intended to be called only by other LAPACK\n*  routines, thus the interface is less user-friendly.  It is intended\n*  for two purposes:\n*\n*  (a) finding eigenvalues.  In this case, DLAEBZ should have one or\n*      more initial intervals set up in AB, and DLAEBZ should be called\n*      with IJOB=1.  This sets up NAB, and also counts the eigenvalues.\n*      Intervals with no eigenvalues would usually be thrown out at\n*      this point.  Also, if not all the eigenvalues in an interval i\n*      are desired, NAB(i,1) can be increased or NAB(i,2) decreased.\n*      For example, set NAB(i,1)=NAB(i,2)-1 to get the largest\n*      eigenvalue.  DLAEBZ is then called with IJOB=2 and MMAX\n*      no smaller than the value of MOUT returned by the call with\n*      IJOB=1.  After this (IJOB=2) call, eigenvalues NAB(i,1)+1\n*      through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the\n*      tolerance specified by ABSTOL and RELTOL.\n*\n*  (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l).\n*      In this case, start with a Gershgorin interval  (a,b).  Set up\n*      AB to contain 2 search intervals, both initially (a,b).  One\n*      NVAL element should contain  f-1  and the other should contain  l\n*      , while C should contain a and b, resp.  NAB(i,1) should be -1\n*      and NAB(i,2) should be N+1, to flag an error if the desired\n*      interval does not lie in (a,b).  DLAEBZ is then called with\n*      IJOB=3.  On exit, if w(f-1) < w(f), then one of the intervals --\n*      j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while\n*      if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r\n*      >= 0, then the interval will have  N(AB(j,1))=NAB(j,1)=f-k and\n*      N(AB(j,2))=NAB(j,2)=f+r.  The cases w(l) < w(l+1) and\n*      w(l-r)=...=w(l+k) are handled similarly.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  mout, info, nval, ab, c, nab = NumRu::Lapack.dlaebz( ijob, nitmax, minp, nbmin, abstol, reltol, pivmin, d, e, e2, nval, ab, c, nab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 14 && argc != 14)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 14)", argc);
  rblapack_ijob = argv[0];
  rblapack_nitmax = argv[1];
  rblapack_minp = argv[2];
  rblapack_nbmin = argv[3];
  rblapack_abstol = argv[4];
  rblapack_reltol = argv[5];
  rblapack_pivmin = argv[6];
  rblapack_d = argv[7];
  rblapack_e = argv[8];
  rblapack_e2 = argv[9];
  rblapack_nval = argv[10];
  rblapack_ab = argv[11];
  rblapack_c = argv[12];
  rblapack_nab = argv[13];
  if (argc == 14) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  ijob = NUM2INT(rblapack_ijob);
  minp = NUM2INT(rblapack_minp);
  abstol = NUM2DBL(rblapack_abstol);
  pivmin = NUM2DBL(rblapack_pivmin);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (9th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (9th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_e);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  if (!NA_IsNArray(rblapack_nval))
    rb_raise(rb_eArgError, "nval (11th argument) must be NArray");
  if (NA_RANK(rblapack_nval) != 1)
    rb_raise(rb_eArgError, "rank of nval (11th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_nval) != ((ijob==1||ijob==2) ? 0 : ijob==3 ? minp : 0))
    rb_raise(rb_eRuntimeError, "shape 0 of nval must be %d", (ijob==1||ijob==2) ? 0 : ijob==3 ? minp : 0);
  if (NA_TYPE(rblapack_nval) != NA_LINT)
    rblapack_nval = na_change_type(rblapack_nval, NA_LINT);
  nval = NA_PTR_TYPE(rblapack_nval, integer*);
  if (!NA_IsNArray(rblapack_nab))
    rb_raise(rb_eArgError, "nab (14th argument) must be NArray");
  if (NA_RANK(rblapack_nab) != 2)
    rb_raise(rb_eArgError, "rank of nab (14th argument) must be %d", 2);
  mmax = NA_SHAPE0(rblapack_nab);
  if (NA_SHAPE1(rblapack_nab) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of nab must be %d", 2);
  if (NA_TYPE(rblapack_nab) != NA_LINT)
    rblapack_nab = na_change_type(rblapack_nab, NA_LINT);
  nab = NA_PTR_TYPE(rblapack_nab, integer*);
  nitmax = NUM2INT(rblapack_nitmax);
  reltol = NUM2DBL(rblapack_reltol);
  if (!NA_IsNArray(rblapack_e2))
    rb_raise(rb_eArgError, "e2 (10th argument) must be NArray");
  if (NA_RANK(rblapack_e2) != 1)
    rb_raise(rb_eArgError, "rank of e2 (10th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e2) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of e2 must be the same as shape 0 of e");
  if (NA_TYPE(rblapack_e2) != NA_DFLOAT)
    rblapack_e2 = na_change_type(rblapack_e2, NA_DFLOAT);
  e2 = NA_PTR_TYPE(rblapack_e2, doublereal*);
  nbmin = NUM2INT(rblapack_nbmin);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (12th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (12th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_ab) != mmax)
    rb_raise(rb_eRuntimeError, "shape 0 of ab must be the same as shape 0 of nab");
  if (NA_SHAPE1(rblapack_ab) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be %d", 2);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (8th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of e");
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (13th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (13th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != (ijob==1 ? 0 : (ijob==2||ijob==3) ? mmax : 0))
    rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", ijob==1 ? 0 : (ijob==2||ijob==3) ? mmax : 0);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = (ijob==1||ijob==2) ? 0 : ijob==3 ? minp : 0;
    rblapack_nval_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  nval_out__ = NA_PTR_TYPE(rblapack_nval_out__, integer*);
  MEMCPY(nval_out__, nval, integer, NA_TOTAL(rblapack_nval));
  rblapack_nval = rblapack_nval_out__;
  nval = nval_out__;
  {
    na_shape_t shape[2];
    shape[0] = mmax;
    shape[1] = 2;
    rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
  MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[1];
    shape[0] = ijob==1 ? 0 : (ijob==2||ijob==3) ? mmax : 0;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[2];
    shape[0] = mmax;
    shape[1] = 2;
    rblapack_nab_out__ = na_make_object(NA_LINT, 2, shape, cNArray);
  }
  nab_out__ = NA_PTR_TYPE(rblapack_nab_out__, integer*);
  MEMCPY(nab_out__, nab, integer, NA_TOTAL(rblapack_nab));
  rblapack_nab = rblapack_nab_out__;
  nab = nab_out__;
  work = ALLOC_N(doublereal, (mmax));
  iwork = ALLOC_N(integer, (mmax));

  dlaebz_(&ijob, &nitmax, &n, &mmax, &minp, &nbmin, &abstol, &reltol, &pivmin, d, e, e2, nval, ab, c, &mout, nab, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_mout = INT2NUM(mout);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_mout, rblapack_info, rblapack_nval, rblapack_ab, rblapack_c, rblapack_nab);
}

void
init_lapack_dlaebz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaebz", rblapack_dlaebz, -1);
}
ruby-lapack-1.7.2/ext/dggbal.c0000644000175000017500000001753312502221013015750 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dggbal_(char* job, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, integer* ilo, integer* ihi, doublereal* lscale, doublereal* rscale, doublereal* work, integer* info);


static VALUE
rblapack_dggbal(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_lscale;
  doublereal *lscale; 
  VALUE rblapack_rscale;
  doublereal *rscale; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;
  doublereal *work;

  integer lda;
  integer n;
  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  ilo, ihi, lscale, rscale, info, a, b = NumRu::Lapack.dggbal( job, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGGBAL balances a pair of general real matrices (A,B).  This\n*  involves, first, permuting A and B by similarity transformations to\n*  isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N\n*  elements on the diagonal; and second, applying a diagonal similarity\n*  transformation to rows and columns ILO to IHI to make the rows\n*  and columns as close in norm as possible. Both steps are optional.\n*\n*  Balancing may reduce the 1-norm of the matrices, and improve the\n*  accuracy of the computed eigenvalues and/or eigenvectors in the\n*  generalized eigenvalue problem A*x = lambda*B*x.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies the operations to be performed on A and B:\n*          = 'N':  none:  simply set ILO = 1, IHI = N, LSCALE(I) = 1.0\n*                  and RSCALE(I) = 1.0 for i = 1,...,N.\n*          = 'P':  permute only;\n*          = 'S':  scale only;\n*          = 'B':  both permute and scale.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the input matrix A.\n*          On exit,  A is overwritten by the balanced matrix.\n*          If JOB = 'N', A is not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)\n*          On entry, the input matrix B.\n*          On exit,  B is overwritten by the balanced matrix.\n*          If JOB = 'N', B is not referenced.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  ILO     (output) INTEGER\n*  IHI     (output) INTEGER\n*          ILO and IHI are set to integers such that on exit\n*          A(i,j) = 0 and B(i,j) = 0 if i > j and\n*          j = 1,...,ILO-1 or i = IHI+1,...,N.\n*          If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n*\n*  LSCALE  (output) DOUBLE PRECISION array, dimension (N)\n*          Details of the permutations and scaling factors applied\n*          to the left side of A and B.  If P(j) is the index of the\n*          row interchanged with row j, and D(j)\n*          is the scaling factor applied to row j, then\n*            LSCALE(j) = P(j)    for J = 1,...,ILO-1\n*                      = D(j)    for J = ILO,...,IHI\n*                      = P(j)    for J = IHI+1,...,N.\n*          The order in which the interchanges are made is N to IHI+1,\n*          then 1 to ILO-1.\n*\n*  RSCALE  (output) DOUBLE PRECISION array, dimension (N)\n*          Details of the permutations and scaling factors applied\n*          to the right side of A and B.  If P(j) is the index of the\n*          column interchanged with column j, and D(j)\n*          is the scaling factor applied to column j, then\n*            LSCALE(j) = P(j)    for J = 1,...,ILO-1\n*                      = D(j)    for J = ILO,...,IHI\n*                      = P(j)    for J = IHI+1,...,N.\n*          The order in which the interchanges are made is N to IHI+1,\n*          then 1 to ILO-1.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (lwork)\n*          lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and\n*          at least 1 when JOB = 'N' or 'P'.\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*  See R.C. WARD, Balancing the generalized eigenvalue problem,\n*                 SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ilo, ihi, lscale, rscale, info, a, b = NumRu::Lapack.dggbal( job, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_job = argv[0];
  rblapack_a = argv[1];
  rblapack_b = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  job = StringValueCStr(rblapack_job)[0];
  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);
  ldb = NA_SHAPE0(rblapack_b);
  n = 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 (!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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_lscale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  lscale = NA_PTR_TYPE(rblapack_lscale, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rscale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  rscale = NA_PTR_TYPE(rblapack_rscale, doublereal*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(doublereal, ((lsame_(&job,"S")||lsame_(&job,"B")) ? MAX(1,6*n) : (lsame_(&job,"N")||lsame_(&job,"P")) ? 1 : 0));

  dggbal_(&job, &n, a, &lda, b, &ldb, &ilo, &ihi, lscale, rscale, work, &info);

  free(work);
  rblapack_ilo = INT2NUM(ilo);
  rblapack_ihi = INT2NUM(ihi);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_ilo, rblapack_ihi, rblapack_lscale, rblapack_rscale, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_dggbal(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dggbal", rblapack_dggbal, -1);
}
ruby-lapack-1.7.2/ext/slaqsb.c0000644000175000017500000001277012502221024016015 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaqsb_(char* uplo, integer* n, integer* kd, real* ab, integer* ldab, real* s, real* scond, real* amax, char* equed);


static VALUE
rblapack_slaqsb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_scond;
  real scond; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_ab_out__;
  real *ab_out__;

  integer ldab;
  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  equed, ab = NumRu::Lapack.slaqsb( uplo, kd, ab, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )\n\n*  Purpose\n*  =======\n*\n*  SLAQSB equilibrates a symmetric band matrix A using the scaling\n*  factors in the vector S.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of super-diagonals of the matrix A if UPLO = 'U',\n*          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) REAL array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*          On exit, if INFO = 0, the triangular factor U or L from the\n*          Cholesky factorization A = U'*U or A = L*L' of the band\n*          matrix A, in the same storage format as A.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  S       (input) REAL array, dimension (N)\n*          The scale factors for A.\n*\n*  SCOND   (input) REAL\n*          Ratio of the smallest S(i) to the largest S(i).\n*\n*  AMAX    (input) REAL\n*          Absolute value of largest matrix entry.\n*\n*  EQUED   (output) CHARACTER*1\n*          Specifies whether or not equilibration was done.\n*          = 'N':  No equilibration.\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*\n*  Internal Parameters\n*  ===================\n*\n*  THRESH is a threshold value used to decide if scaling should be done\n*  based on the ratio of the scaling factors.  If SCOND < THRESH,\n*  scaling is done.\n*\n*  LARGE and SMALL are threshold values used to decide if scaling should\n*  be done based on the absolute size of the largest matrix element.\n*  If AMAX > LARGE or AMAX < SMALL, scaling is done.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  equed, ab = NumRu::Lapack.slaqsb( uplo, kd, ab, s, scond, amax, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  rblapack_s = argv[3];
  rblapack_scond = argv[4];
  rblapack_amax = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  scond = (real)NUM2DBL(rblapack_scond);
  kd = NUM2INT(rblapack_kd);
  amax = (real)NUM2DBL(rblapack_amax);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (4th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
  MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  slaqsb_(&uplo, &n, &kd, ab, &ldab, s, &scond, &amax, &equed);

  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(2, rblapack_equed, rblapack_ab);
}

void
init_lapack_slaqsb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaqsb", rblapack_slaqsb, -1);
}
ruby-lapack-1.7.2/ext/cpotrf.c0000644000175000017500000000774312502221025016032 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cpotrf_(char* uplo, integer* n, complex* a, integer* lda, integer* info);


static VALUE
rblapack_cpotrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *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  info, a = NumRu::Lapack.cpotrf( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPOTRF( UPLO, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPOTRF computes the Cholesky factorization of a complex Hermitian\n*  positive definite matrix A.\n*\n*  The factorization has the form\n*     A = U**H * U,  if UPLO = 'U', or\n*     A = L  * L**H,  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is lower triangular.\n*\n*  This is the block version of the algorithm, calling Level 3 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the factor U or L from the Cholesky\n*          factorization A = U**H*U or A = L*L**H.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\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 leading minor of order i is not\n*                positive definite, and the factorization could not be\n*                completed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.cpotrf( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  cpotrf_(&uplo, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_cpotrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cpotrf", rblapack_cpotrf, -1);
}
ruby-lapack-1.7.2/ext/zlarz.c0000644000175000017500000001266612502221022015674 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlarz_(char* side, integer* m, integer* n, integer* l, doublecomplex* v, integer* incv, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work);


static VALUE
rblapack_zlarz(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_v;
  doublecomplex *v; 
  VALUE rblapack_incv;
  integer incv; 
  VALUE rblapack_tau;
  doublecomplex tau; 
  VALUE rblapack_c;
  doublecomplex *c; 
  VALUE rblapack_c_out__;
  doublecomplex *c_out__;
  doublecomplex *work;

  integer ldc;
  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  c = NumRu::Lapack.zlarz( side, m, l, v, incv, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK )\n\n*  Purpose\n*  =======\n*\n*  ZLARZ applies a complex elementary reflector H to a complex\n*  M-by-N matrix C, from either the left or the right. H is represented\n*  in the form\n*\n*        H = I - tau * v * v'\n*\n*  where tau is a complex scalar and v is a complex vector.\n*\n*  If tau = 0, then H is taken to be the unit matrix.\n*\n*  To apply H' (the conjugate transpose of H), supply conjg(tau) instead\n*  tau.\n*\n*  H is a product of k elementary reflectors as returned by ZTZRZF.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': form  H * C\n*          = 'R': form  C * H\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C.\n*\n*  L       (input) INTEGER\n*          The number of entries of the vector V containing\n*          the meaningful part of the Householder vectors.\n*          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n*  V       (input) COMPLEX*16 array, dimension (1+(L-1)*abs(INCV))\n*          The vector v in the representation of H as returned by\n*          ZTZRZF. V is not used if TAU = 0.\n*\n*  INCV    (input) INTEGER\n*          The increment between elements of v. INCV <> 0.\n*\n*  TAU     (input) COMPLEX*16\n*          The value tau in the representation of H.\n*\n*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n*          or C * H if SIDE = 'R'.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension\n*                         (N) if SIDE = 'L'\n*                      or (M) if SIDE = 'R'\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.zlarz( side, m, l, v, incv, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_side = argv[0];
  rblapack_m = argv[1];
  rblapack_l = argv[2];
  rblapack_v = argv[3];
  rblapack_incv = argv[4];
  rblapack_tau = argv[5];
  rblapack_c = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  l = NUM2INT(rblapack_l);
  incv = NUM2INT(rblapack_incv);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
  m = NUM2INT(rblapack_m);
  tau.r = NUM2DBL(rb_funcall(rblapack_tau, rb_intern("real"), 0));
  tau.i = NUM2DBL(rb_funcall(rblapack_tau, rb_intern("imag"), 0));
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (4th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 1)
    rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_v) != (1+(l-1)*abs(incv)))
    rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1+(l-1)*abs(incv));
  if (NA_TYPE(rblapack_v) != NA_DCOMPLEX)
    rblapack_v = na_change_type(rblapack_v, NA_DCOMPLEX);
  v = NA_PTR_TYPE(rblapack_v, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
  MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(doublecomplex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  zlarz_(&side, &m, &n, &l, v, &incv, &tau, c, &ldc, work);

  free(work);
  return rblapack_c;
}

void
init_lapack_zlarz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlarz", rblapack_zlarz, -1);
}
ruby-lapack-1.7.2/ext/strsna.c0000644000175000017500000002613012502221012016032 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID strsna_(char* job, char* howmny, logical* select, integer* n, real* t, integer* ldt, real* vl, integer* ldvl, real* vr, integer* ldvr, real* s, real* sep, integer* mm, integer* m, real* work, integer* ldwork, integer* iwork, integer* info);


static VALUE
rblapack_strsna(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_howmny;
  char howmny; 
  VALUE rblapack_select;
  logical *select; 
  VALUE rblapack_t;
  real *t; 
  VALUE rblapack_vl;
  real *vl; 
  VALUE rblapack_vr;
  real *vr; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_sep;
  real *sep; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_info;
  integer info; 
  real *work;
  integer *iwork;

  integer n;
  integer ldt;
  integer ldvl;
  integer ldvr;
  integer mm;
  integer ldwork;

  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  s, sep, m, info = NumRu::Lapack.strsna( job, howmny, select, t, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  STRSNA estimates reciprocal condition numbers for specified\n*  eigenvalues and/or right eigenvectors of a real upper\n*  quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q\n*  orthogonal).\n*\n*  T must be in Schur canonical form (as returned by SHSEQR), that is,\n*  block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each\n*  2-by-2 diagonal block has its diagonal elements equal and its\n*  off-diagonal elements of opposite sign.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies whether condition numbers are required for\n*          eigenvalues (S) or eigenvectors (SEP):\n*          = 'E': for eigenvalues only (S);\n*          = 'V': for eigenvectors only (SEP);\n*          = 'B': for both eigenvalues and eigenvectors (S and SEP).\n*\n*  HOWMNY  (input) CHARACTER*1\n*          = 'A': compute condition numbers for all eigenpairs;\n*          = 'S': compute condition numbers for selected eigenpairs\n*                 specified by the array SELECT.\n*\n*  SELECT  (input) LOGICAL array, dimension (N)\n*          If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n*          condition numbers are required. To select condition numbers\n*          for the eigenpair corresponding to a real eigenvalue w(j),\n*          SELECT(j) must be set to .TRUE.. To select condition numbers\n*          corresponding to a complex conjugate pair of eigenvalues w(j)\n*          and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be\n*          set to .TRUE..\n*          If HOWMNY = 'A', SELECT is not referenced.\n*\n*  N       (input) INTEGER\n*          The order of the matrix T. N >= 0.\n*\n*  T       (input) REAL array, dimension (LDT,N)\n*          The upper quasi-triangular matrix T, in Schur canonical form.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= max(1,N).\n*\n*  VL      (input) REAL array, dimension (LDVL,M)\n*          If JOB = 'E' or 'B', VL must contain left eigenvectors of T\n*          (or of any Q*T*Q**T with Q orthogonal), corresponding to the\n*          eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n*          must be stored in consecutive columns of VL, as returned by\n*          SHSEIN or STREVC.\n*          If JOB = 'V', VL is not referenced.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the array VL.\n*          LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.\n*\n*  VR      (input) REAL array, dimension (LDVR,M)\n*          If JOB = 'E' or 'B', VR must contain right eigenvectors of T\n*          (or of any Q*T*Q**T with Q orthogonal), corresponding to the\n*          eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n*          must be stored in consecutive columns of VR, as returned by\n*          SHSEIN or STREVC.\n*          If JOB = 'V', VR is not referenced.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the array VR.\n*          LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.\n*\n*  S       (output) REAL array, dimension (MM)\n*          If JOB = 'E' or 'B', the reciprocal condition numbers of the\n*          selected eigenvalues, stored in consecutive elements of the\n*          array. For a complex conjugate pair of eigenvalues two\n*          consecutive elements of S are set to the same value. Thus\n*          S(j), SEP(j), and the j-th columns of VL and VR all\n*          correspond to the same eigenpair (but not in general the\n*          j-th eigenpair, unless all eigenpairs are selected).\n*          If JOB = 'V', S is not referenced.\n*\n*  SEP     (output) REAL array, dimension (MM)\n*          If JOB = 'V' or 'B', the estimated reciprocal condition\n*          numbers of the selected eigenvectors, stored in consecutive\n*          elements of the array. For a complex eigenvector two\n*          consecutive elements of SEP are set to the same value. If\n*          the eigenvalues cannot be reordered to compute SEP(j), SEP(j)\n*          is set to 0; this can only occur when the true value would be\n*          very small anyway.\n*          If JOB = 'E', SEP is not referenced.\n*\n*  MM      (input) INTEGER\n*          The number of elements in the arrays S (if JOB = 'E' or 'B')\n*           and/or SEP (if JOB = 'V' or 'B'). MM >= M.\n*\n*  M       (output) INTEGER\n*          The number of elements of the arrays S and/or SEP actually\n*          used to store the estimated condition numbers.\n*          If HOWMNY = 'A', M is set to N.\n*\n*  WORK    (workspace) REAL array, dimension (LDWORK,N+6)\n*          If JOB = 'E', WORK is not referenced.\n*\n*  LDWORK  (input) INTEGER\n*          The leading dimension of the array WORK.\n*          LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.\n*\n*  IWORK   (workspace) INTEGER array, dimension (2*(N-1))\n*          If JOB = 'E', IWORK is not referenced.\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 reciprocal of the condition number of an eigenvalue lambda is\n*  defined as\n*\n*          S(lambda) = |v'*u| / (norm(u)*norm(v))\n*\n*  where u and v are the right and left eigenvectors of T corresponding\n*  to lambda; v' denotes the conjugate-transpose of v, and norm(u)\n*  denotes the Euclidean norm. These reciprocal condition numbers always\n*  lie between zero (very badly conditioned) and one (very well\n*  conditioned). If n = 1, S(lambda) is defined to be 1.\n*\n*  An approximate error bound for a computed eigenvalue W(i) is given by\n*\n*                      EPS * norm(T) / S(i)\n*\n*  where EPS is the machine precision.\n*\n*  The reciprocal of the condition number of the right eigenvector u\n*  corresponding to lambda is defined as follows. Suppose\n*\n*              T = ( lambda  c  )\n*                  (   0    T22 )\n*\n*  Then the reciprocal condition number is\n*\n*          SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )\n*\n*  where sigma-min denotes the smallest singular value. We approximate\n*  the smallest singular value by the reciprocal of an estimate of the\n*  one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is\n*  defined to be abs(T(1,1)).\n*\n*  An approximate error bound for a computed right eigenvector VR(i)\n*  is given by\n*\n*                      EPS * norm(T) / SEP(i)\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, sep, m, info = NumRu::Lapack.strsna( job, howmny, select, t, vl, vr, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_job = argv[0];
  rblapack_howmny = argv[1];
  rblapack_select = argv[2];
  rblapack_t = argv[3];
  rblapack_vl = argv[4];
  rblapack_vr = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  job = StringValueCStr(rblapack_job)[0];
  if (!NA_IsNArray(rblapack_select))
    rb_raise(rb_eArgError, "select (3th argument) must be NArray");
  if (NA_RANK(rblapack_select) != 1)
    rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_select);
  if (NA_TYPE(rblapack_select) != NA_LINT)
    rblapack_select = na_change_type(rblapack_select, NA_LINT);
  select = NA_PTR_TYPE(rblapack_select, logical*);
  if (!NA_IsNArray(rblapack_vl))
    rb_raise(rb_eArgError, "vl (5th argument) must be NArray");
  if (NA_RANK(rblapack_vl) != 2)
    rb_raise(rb_eArgError, "rank of vl (5th argument) must be %d", 2);
  ldvl = NA_SHAPE0(rblapack_vl);
  m = NA_SHAPE1(rblapack_vl);
  if (NA_TYPE(rblapack_vl) != NA_SFLOAT)
    rblapack_vl = na_change_type(rblapack_vl, NA_SFLOAT);
  vl = NA_PTR_TYPE(rblapack_vl, real*);
  howmny = StringValueCStr(rblapack_howmny)[0];
  if (!NA_IsNArray(rblapack_vr))
    rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
  if (NA_RANK(rblapack_vr) != 2)
    rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 2);
  ldvr = NA_SHAPE0(rblapack_vr);
  if (NA_SHAPE1(rblapack_vr) != m)
    rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
  if (NA_TYPE(rblapack_vr) != NA_SFLOAT)
    rblapack_vr = na_change_type(rblapack_vr, NA_SFLOAT);
  vr = NA_PTR_TYPE(rblapack_vr, real*);
  mm = m;
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (4th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  if (NA_SHAPE1(rblapack_t) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_t) != NA_SFLOAT)
    rblapack_t = na_change_type(rblapack_t, NA_SFLOAT);
  t = NA_PTR_TYPE(rblapack_t, real*);
  ldwork = ((lsame_(&job,"V")) || (lsame_(&job,"B"))) ? n : 1;
  {
    na_shape_t shape[1];
    shape[0] = mm;
    rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, real*);
  {
    na_shape_t shape[1];
    shape[0] = mm;
    rblapack_sep = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  sep = NA_PTR_TYPE(rblapack_sep, real*);
  work = ALLOC_N(real, (lsame_(&job,"E") ? 0 : ldwork)*(lsame_(&job,"E") ? 0 : n+6));
  iwork = ALLOC_N(integer, (lsame_(&job,"E") ? 0 : 2*(n-1)));

  strsna_(&job, &howmny, select, &n, t, &ldt, vl, &ldvl, vr, &ldvr, s, sep, &mm, &m, work, &ldwork, iwork, &info);

  free(work);
  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_s, rblapack_sep, rblapack_m, rblapack_info);
}

void
init_lapack_strsna(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "strsna", rblapack_strsna, -1);
}
ruby-lapack-1.7.2/ext/cla_gbrcond_c.c0000644000175000017500000002063212502221020017257 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real cla_gbrcond_c_(char* trans, integer* n, integer* kl, integer* ku, complex* ab, integer* ldab, complex* afb, integer* ldafb, integer* ipiv, real* c, logical* capply, integer* info, complex* work, real* rwork);


static VALUE
rblapack_cla_gbrcond_c(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_afb;
  complex *afb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_capply;
  logical capply; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_rwork;
  real *rwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack___out__;
  real __out__; 

  integer ldab;
  integer n;
  integer ldafb;

  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  info, __out__ = NumRu::Lapack.cla_gbrcond_c( trans, kl, ku, ab, afb, ipiv, c, capply, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL FUNCTION CLA_GBRCOND_C( TRANS, N, KL, KU, AB, LDAB, AFB, LDAFB, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n*  Purpose\n*  =======\n*\n*     CLA_GBRCOND_C Computes the infinity norm condition number of\n*     op(A) * inv(diag(C)) where C is a REAL vector.\n*\n\n*  Arguments\n*  =========\n*\n*     TRANS   (input) CHARACTER*1\n*     Specifies the form of the system of equations:\n*       = 'N':  A * X = B     (No transpose)\n*       = 'T':  A**T * X = B  (Transpose)\n*       = 'C':  A**H * X = B  (Conjugate Transpose = Transpose)\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     KL      (input) INTEGER\n*     The number of subdiagonals within the band of A.  KL >= 0.\n*\n*     KU      (input) INTEGER\n*     The number of superdiagonals within the band of A.  KU >= 0.\n*\n*     AB      (input) COMPLEX array, dimension (LDAB,N)\n*     On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n*     The j-th column of A is stored in the j-th column of the\n*     array AB as follows:\n*     AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n*     LDAB    (input) INTEGER\n*     The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*     AFB     (input) COMPLEX array, dimension (LDAFB,N)\n*     Details of the LU factorization of the band matrix A, as\n*     computed by CGBTRF.  U is stored as an upper triangular\n*     band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n*     and the multipliers used during the factorization are stored\n*     in rows KL+KU+2 to 2*KL+KU+1.\n*\n*     LDAFB   (input) INTEGER\n*     The leading dimension of the array AFB.  LDAFB >= 2*KL+KU+1.\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     The pivot indices from the factorization A = P*L*U\n*     as computed by CGBTRF; row i of the matrix was interchanged\n*     with row IPIV(i).\n*\n*     C       (input) REAL array, dimension (N)\n*     The vector C in the formula op(A) * inv(diag(C)).\n*\n*     CAPPLY  (input) LOGICAL\n*     If .TRUE. then access the vector C in the formula above.\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit.\n*     i > 0:  The ith argument is invalid.\n*\n*     WORK    (input) COMPLEX array, dimension (2*N).\n*     Workspace.\n*\n*     RWORK   (input) REAL array, dimension (N).\n*     Workspace.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            NOTRANS\n      INTEGER            KASE, I, J\n      REAL               AINVNM, ANORM, TMP\n      COMPLEX            ZDUM\n*     ..\n*     .. Local Arrays ..\n      INTEGER            ISAVE( 3 )\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CLACN2, CGBTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX\n*     ..\n*     .. Statement Functions ..\n      REAL               CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, __out__ = NumRu::Lapack.cla_gbrcond_c( trans, kl, ku, ab, afb, ipiv, c, capply, work, rwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_trans = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  rblapack_afb = argv[4];
  rblapack_ipiv = argv[5];
  rblapack_c = argv[6];
  rblapack_capply = argv[7];
  rblapack_work = argv[8];
  rblapack_rwork = argv[9];
  if (argc == 10) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
  ldafb = NA_SHAPE0(rblapack_afb);
  n = NA_SHAPE1(rblapack_afb);
  if (NA_TYPE(rblapack_afb) != NA_SCOMPLEX)
    rblapack_afb = na_change_type(rblapack_afb, NA_SCOMPLEX);
  afb = NA_PTR_TYPE(rblapack_afb, complex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_rwork))
    rb_raise(rb_eArgError, "rwork (10th argument) must be NArray");
  if (NA_RANK(rblapack_rwork) != 1)
    rb_raise(rb_eArgError, "rank of rwork (10th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_rwork) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_rwork) != NA_SFLOAT)
    rblapack_rwork = na_change_type(rblapack_rwork, NA_SFLOAT);
  rwork = NA_PTR_TYPE(rblapack_rwork, real*);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  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);
  if (NA_SHAPE0(rblapack_work) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
  if (NA_TYPE(rblapack_work) != NA_SCOMPLEX)
    rblapack_work = na_change_type(rblapack_work, NA_SCOMPLEX);
  work = NA_PTR_TYPE(rblapack_work, complex*);
  capply = (rblapack_capply == Qtrue);

  __out__ = cla_gbrcond_c_(&trans, &n, &kl, &ku, ab, &ldab, afb, &ldafb, ipiv, c, &capply, &info, work, rwork);

  rblapack_info = INT2NUM(info);
  rblapack___out__ = rb_float_new((double)__out__);
  return rb_ary_new3(2, rblapack_info, rblapack___out__);
}

void
init_lapack_cla_gbrcond_c(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cla_gbrcond_c", rblapack_cla_gbrcond_c, -1);
}
ruby-lapack-1.7.2/ext/zhesvx.c0000644000175000017500000003376412502221021016062 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhesvx_(char* fact, char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublecomplex* work, integer* lwork, doublereal* rwork, integer* info);


static VALUE
rblapack_zhesvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_af_out__;
  doublecomplex *af_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  doublereal *rwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.zhesvx( fact, uplo, a, af, ipiv, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHESVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHESVX uses the diagonal pivoting factorization to compute the\n*  solution to a complex system of linear equations A * X = B,\n*  where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS\n*  matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'N', the diagonal pivoting method is used to factor A.\n*     The form of the factorization is\n*        A = U * D * U**H,  if UPLO = 'U', or\n*        A = L * D * L**H,  if UPLO = 'L',\n*     where U (or L) is a product of permutation and unit upper (lower)\n*     triangular matrices, and D is Hermitian and block diagonal with\n*     1-by-1 and 2-by-2 diagonal blocks.\n*\n*  2. If some D(i,i)=0, so that D is exactly singular, then the routine\n*     returns with INFO = i. Otherwise, the factored form of A is used\n*     to estimate the condition number of the matrix A.  If the\n*     reciprocal of the condition number is less than machine precision,\n*     INFO = N+1 is returned as a warning, but the routine still goes on\n*     to solve for X and compute error bounds as described below.\n*\n*  3. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  4. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of A has been\n*          supplied on entry.\n*          = 'F':  On entry, AF and IPIV contain the factored form\n*                  of A.  A, AF and IPIV will not be modified.\n*          = 'N':  The matrix A will be copied to AF and factored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          The Hermitian matrix A.  If UPLO = 'U', the leading N-by-N\n*          upper triangular part of A contains the upper triangular part\n*          of the matrix A, and the strictly lower triangular part of A\n*          is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*          triangular part of A contains the lower triangular part of\n*          the matrix A, and the strictly upper triangular part of A is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AF      (input or output) COMPLEX*16 array, dimension (LDAF,N)\n*          If FACT = 'F', then AF is an input argument and on entry\n*          contains the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L from the factorization\n*          A = U*D*U**H or A = L*D*L**H as computed by ZHETRF.\n*\n*          If FACT = 'N', then AF is an output argument and on exit\n*          returns the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L from the factorization\n*          A = U*D*U**H or A = L*D*L**H.\n*\n*  LDAF    (input) INTEGER\n*          The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*  IPIV    (input or output) INTEGER array, dimension (N)\n*          If FACT = 'F', then IPIV is an input argument and on entry\n*          contains details of the interchanges and the block structure\n*          of D, as determined by ZHETRF.\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*          If FACT = 'N', then IPIV is an output argument and on exit\n*          contains details of the interchanges and the block structure\n*          of D, as determined by ZHETRF.\n*\n*  B       (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*          The N-by-NRHS right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) COMPLEX*16 array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The estimate of the reciprocal condition number of the matrix\n*          A.  If RCOND is less than the machine precision (in\n*          particular, if RCOND = 0), the matrix is singular to working\n*          precision.  This condition is indicated by a return code of\n*          INFO > 0.\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of WORK.  LWORK >= max(1,2*N), and for best\n*          performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where\n*          NB is the optimal blocksize for ZHETRF.\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*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\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, and i is\n*                <= N:  D(i,i) is exactly zero.  The factorization\n*                       has been completed but the factor D is exactly\n*                       singular, so the solution and error bounds could\n*                       not be computed. RCOND = 0 is returned.\n*                = N+1: D is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.zhesvx( fact, uplo, a, af, ipiv, b, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_b = argv[5];
  if (argc == 7) {
    rblapack_lwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  ldx = MAX(1,n);
  if (rblapack_lwork == Qnil)
    lwork = 2*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldaf;
    shape[1] = n;
    rblapack_af_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  af_out__ = NA_PTR_TYPE(rblapack_af_out__, doublecomplex*);
  MEMCPY(af_out__, af, doublecomplex, NA_TOTAL(rblapack_af));
  rblapack_af = rblapack_af_out__;
  af = af_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  rwork = ALLOC_N(doublereal, (n));

  zhesvx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, &lwork, rwork, &info);

  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_work, rblapack_info, rblapack_af, rblapack_ipiv);
}

void
init_lapack_zhesvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhesvx", rblapack_zhesvx, -1);
}
ruby-lapack-1.7.2/ext/zgees.c0000644000175000017500000002114612502221021015637 0ustar  uwabamiuwabami#include "rb_lapack.h"

static logical
rblapack_select(doublecomplex *arg0){
  VALUE rblapack_arg0;

  VALUE rblapack_ret;
  logical ret;

  rblapack_arg0 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg0->r)), rb_float_new((double)(arg0->i)));

  rblapack_ret = rb_yield_values(1, rblapack_arg0);

  ret = (rblapack_ret == Qtrue);
  return ret;
}

extern VOID zgees_(char* jobvs, char* sort, L_fp select, integer* n, doublecomplex* a, integer* lda, integer* sdim, doublecomplex* w, doublecomplex* vs, integer* ldvs, doublecomplex* work, integer* lwork, doublereal* rwork, logical* bwork, integer* info);


static VALUE
rblapack_zgees(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvs;
  char jobvs; 
  VALUE rblapack_sort;
  char sort; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_sdim;
  integer sdim; 
  VALUE rblapack_w;
  doublecomplex *w; 
  VALUE rblapack_vs;
  doublecomplex *vs; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  doublereal *rwork;
  logical *bwork;

  integer lda;
  integer n;
  integer ldvs;

  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  sdim, w, vs, work, info, a = NumRu::Lapack.zgees( jobvs, sort, a, [:lwork => lwork, :usage => usage, :help => help]){|a| ... }\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS, LDVS, WORK, LWORK, RWORK, BWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGEES computes for an N-by-N complex nonsymmetric matrix A, the\n*  eigenvalues, the Schur form T, and, optionally, the matrix of Schur\n*  vectors Z.  This gives the Schur factorization A = Z*T*(Z**H).\n*\n*  Optionally, it also orders the eigenvalues on the diagonal of the\n*  Schur form so that selected eigenvalues are at the top left.\n*  The leading columns of Z then form an orthonormal basis for the\n*  invariant subspace corresponding to the selected eigenvalues.\n*\n*  A complex matrix is in Schur form if it is upper triangular.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVS   (input) CHARACTER*1\n*          = 'N': Schur vectors are not computed;\n*          = 'V': Schur vectors are computed.\n*\n*  SORT    (input) CHARACTER*1\n*          Specifies whether or not to order the eigenvalues on the\n*          diagonal of the Schur form.\n*          = 'N': Eigenvalues are not ordered:\n*          = 'S': Eigenvalues are ordered (see SELECT).\n*\n*  SELECT  (external procedure) LOGICAL FUNCTION of one COMPLEX*16 argument\n*          SELECT must be declared EXTERNAL in the calling subroutine.\n*          If SORT = 'S', SELECT is used to select eigenvalues to order\n*          to the top left of the Schur form.\n*          IF SORT = 'N', SELECT is not referenced.\n*          The eigenvalue W(j) is selected if SELECT(W(j)) is true.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the N-by-N matrix A.\n*          On exit, A has been overwritten by its Schur form T.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  SDIM    (output) INTEGER\n*          If SORT = 'N', SDIM = 0.\n*          If SORT = 'S', SDIM = number of eigenvalues for which\n*                         SELECT is true.\n*\n*  W       (output) COMPLEX*16 array, dimension (N)\n*          W contains the computed eigenvalues, in the same order that\n*          they appear on the diagonal of the output Schur form T.\n*\n*  VS      (output) COMPLEX*16 array, dimension (LDVS,N)\n*          If JOBVS = 'V', VS contains the unitary matrix Z of Schur\n*          vectors.\n*          If JOBVS = 'N', VS is not referenced.\n*\n*  LDVS    (input) INTEGER\n*          The leading dimension of the array VS.  LDVS >= 1; if\n*          JOBVS = 'V', LDVS >= N.\n*\n*  WORK    (workspace/output) COMPLEX*16 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,2*N).\n*          For good performance, LWORK must generally be larger.\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*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\n*\n*  BWORK   (workspace) LOGICAL array, dimension (N)\n*          Not referenced if SORT = 'N'.\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, and i is\n*               <= N:  the QR algorithm failed to compute all the\n*                      eigenvalues; elements 1:ILO-1 and i+1:N of W\n*                      contain those eigenvalues which have converged;\n*                      if JOBVS = 'V', VS contains the matrix which\n*                      reduces A to its partially converged Schur form.\n*               = N+1: the eigenvalues could not be reordered because\n*                      some eigenvalues were too close to separate (the\n*                      problem is very ill-conditioned);\n*               = N+2: after reordering, roundoff changed values of\n*                      some complex eigenvalues so that leading\n*                      eigenvalues in the Schur form no longer satisfy\n*                      SELECT = .TRUE..  This could also be caused by\n*                      underflow due to scaling.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sdim, w, vs, work, info, a = NumRu::Lapack.zgees( jobvs, sort, a, [:lwork => lwork, :usage => usage, :help => help]){|a| ... }\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_jobvs = argv[0];
  rblapack_sort = argv[1];
  rblapack_a = 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;
  }

  jobvs = StringValueCStr(rblapack_jobvs)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  ldvs = lsame_(&jobvs,"V") ? n : 1;
  sort = StringValueCStr(rblapack_sort)[0];
  if (rblapack_lwork == Qnil)
    lwork = 2*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvs;
    shape[1] = n;
    rblapack_vs = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  vs = NA_PTR_TYPE(rblapack_vs, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  rwork = ALLOC_N(doublereal, (n));
  bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));

  zgees_(&jobvs, &sort, rblapack_select, &n, a, &lda, &sdim, w, vs, &ldvs, work, &lwork, rwork, bwork, &info);

  free(rwork);
  free(bwork);
  rblapack_sdim = INT2NUM(sdim);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_sdim, rblapack_w, rblapack_vs, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_zgees(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgees", rblapack_zgees, -1);
}
ruby-lapack-1.7.2/ext/zung2r.c0000644000175000017500000001053112502221023015747 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zung2r_(integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* info);


static VALUE
rblapack_zung2r(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  doublecomplex *work;

  integer lda;
  integer n;
  integer k;

  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  info, a = NumRu::Lapack.zung2r( m, a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZUNG2R generates an m by n complex matrix Q with orthonormal columns,\n*  which is defined as the first n columns of a product of k elementary\n*  reflectors of order m\n*\n*        Q  =  H(1) H(2) . . . H(k)\n*\n*  as returned by ZGEQRF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. M >= N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. N >= K >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the i-th column must contain the vector which\n*          defines the elementary reflector H(i), for i = 1,2,...,k, as\n*          returned by ZGEQRF in the first k columns of its array\n*          argument A.\n*          On exit, the m by n matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) COMPLEX*16 array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by ZGEQRF.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -i, the i-th argument has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.zung2r( m, a, tau, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  rblapack_tau = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(doublecomplex, (n));

  zung2r_(&m, &n, &k, a, &lda, tau, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_zung2r(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zung2r", rblapack_zung2r, -1);
}
ruby-lapack-1.7.2/ext/zpstrf.c0000644000175000017500000001265312502221014016057 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zpstrf_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* piv, integer* rank, doublereal* tol, doublereal* work, integer* info);


static VALUE
rblapack_zpstrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tol;
  doublereal tol; 
  VALUE rblapack_piv;
  integer *piv; 
  VALUE rblapack_rank;
  integer rank; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  doublereal *work;

  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  piv, rank, info, a = NumRu::Lapack.zpstrf( uplo, a, tol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPSTRF computes the Cholesky factorization with complete\n*  pivoting of a complex Hermitian positive semidefinite matrix A.\n*\n*  The factorization has the form\n*     P' * A * P = U' * U ,  if UPLO = 'U',\n*     P' * A * P = L  * L',  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is lower triangular, and\n*  P is stored as vector PIV.\n*\n*  This algorithm does not attempt to check that A is positive\n*  semidefinite. This version of the algorithm calls level 3 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          n by n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n by n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the factor U or L from the Cholesky\n*          factorization as above.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  PIV     (output) INTEGER array, dimension (N)\n*          PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n*\n*  RANK    (output) INTEGER\n*          The rank of A given by the number of steps the algorithm\n*          completed.\n*\n*  TOL     (input) DOUBLE PRECISION\n*          User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) )\n*          will be used. The algorithm terminates at the (K-1)st step\n*          if the pivot <= TOL.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N)\n*          Work space.\n*\n*  INFO    (output) INTEGER\n*          < 0: If INFO = -K, the K-th argument had an illegal value,\n*          = 0: algorithm completed successfully, and\n*          > 0: the matrix A is either rank deficient with computed rank\n*               as returned in RANK, or is indefinite.  See Section 7 of\n*               LAPACK Working Note #161 for further information.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  piv, rank, info, a = NumRu::Lapack.zpstrf( uplo, a, tol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_tol = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  tol = NUM2DBL(rblapack_tol);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_piv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  piv = NA_PTR_TYPE(rblapack_piv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(doublereal, (2*n));

  zpstrf_(&uplo, &n, a, &lda, piv, &rank, &tol, work, &info);

  free(work);
  rblapack_rank = INT2NUM(rank);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_piv, rblapack_rank, rblapack_info, rblapack_a);
}

void
init_lapack_zpstrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zpstrf", rblapack_zpstrf, -1);
}
ruby-lapack-1.7.2/ext/sla_wwaddw.c0000644000175000017500000001011312502221012016646 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sla_wwaddw_(integer* n, real* x, real* y, real* w);


static VALUE
rblapack_sla_wwaddw(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_y;
  real *y; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_x_out__;
  real *x_out__;
  VALUE rblapack_y_out__;
  real *y_out__;

  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  x, y = NumRu::Lapack.sla_wwaddw( x, y, w, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLA_WWADDW( N, X, Y, W )\n\n*     Purpose\n*     =======\n*\n*     SLA_WWADDW adds a vector W into a doubled-single vector (X, Y).\n*\n*     This works for all extant IBM's hex and binary floating point\n*     arithmetics, but not for decimal.\n*\n\n*     Arguments\n*     =========\n*\n*     N      (input) INTEGER\n*            The length of vectors X, Y, and W.\n*\n*     X      (input/output) REAL array, dimension (N)\n*            The first part of the doubled-single accumulation vector.\n*\n*     Y      (input/output) REAL array, dimension (N)\n*            The second part of the doubled-single accumulation vector.\n*\n*     W      (input) REAL array, dimension (N)\n*            The vector to be added.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      REAL               S\n      INTEGER            I\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, y = NumRu::Lapack.sla_wwaddw( x, y, w, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_x = argv[0];
  rblapack_y = argv[1];
  rblapack_w = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (1th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  if (!NA_IsNArray(rblapack_w))
    rb_raise(rb_eArgError, "w (3th argument) must be NArray");
  if (NA_RANK(rblapack_w) != 1)
    rb_raise(rb_eArgError, "rank of w (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_w) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of x");
  if (NA_TYPE(rblapack_w) != NA_SFLOAT)
    rblapack_w = na_change_type(rblapack_w, NA_SFLOAT);
  w = NA_PTR_TYPE(rblapack_w, real*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (2th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of y must be the same as shape 0 of x");
  if (NA_TYPE(rblapack_y) != NA_SFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
  y = NA_PTR_TYPE(rblapack_y, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
  MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  sla_wwaddw_(&n, x, y, w);

  return rb_ary_new3(2, rblapack_x, rblapack_y);
}

void
init_lapack_sla_wwaddw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sla_wwaddw", rblapack_sla_wwaddw, -1);
}
ruby-lapack-1.7.2/ext/zla_heamv.c0000644000175000017500000001661212502221022016473 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zla_heamv_(integer* uplo, integer* n, doublereal* alpha, doublereal* a, integer* lda, doublecomplex* x, integer* incx, doublereal* beta, doublereal* y, integer* incy);


static VALUE
rblapack_zla_heamv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  integer uplo; 
  VALUE rblapack_alpha;
  doublereal alpha; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_beta;
  doublereal beta; 
  VALUE rblapack_y;
  doublereal *y; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_y_out__;
  doublereal *y_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  y = NumRu::Lapack.zla_heamv( uplo, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLA_HEAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n*  Purpose\n*  =======\n*\n*  ZLA_SYAMV  performs the matrix-vector operation\n*\n*          y := alpha*abs(A)*abs(x) + beta*abs(y),\n*\n*  where alpha and beta are scalars, x and y are vectors and A is an\n*  n by n symmetric matrix.\n*\n*  This function is primarily used in calculating error bounds.\n*  To protect against underflow during evaluation, components in\n*  the resulting vector are perturbed away from zero by (N+1)\n*  times the underflow threshold.  To prevent unnecessarily large\n*  errors for block-structure embedded in general matrices,\n*  \"symbolically\" zero components are not perturbed.  A zero\n*  entry is considered \"symbolic\" if all multiplications involved\n*  in computing that entry have at least one zero multiplicand.\n*\n\n*  Arguments\n*  ==========\n*\n*  UPLO    (input) INTEGER\n*           On entry, UPLO specifies whether the upper or lower\n*           triangular part of the array A is to be referenced as\n*           follows:\n*\n*              UPLO = BLAS_UPPER   Only the upper triangular part of A\n*                                  is to be referenced.\n*\n*              UPLO = BLAS_LOWER   Only the lower triangular part of A\n*                                  is to be referenced.\n*\n*           Unchanged on exit.\n*\n*  N       (input) INTEGER\n*           On entry, N specifies the number of columns of the matrix A.\n*           N must be at least zero.\n*           Unchanged on exit.\n*\n*  ALPHA  - DOUBLE PRECISION   .\n*           On entry, ALPHA specifies the scalar alpha.\n*           Unchanged on exit.\n*\n*  A      - COMPLEX*16         array of DIMENSION ( LDA, n ).\n*           Before entry, the leading m by n part of the array A must\n*           contain the matrix of coefficients.\n*           Unchanged on exit.\n*\n*  LDA     (input) INTEGER\n*           On entry, LDA specifies the first dimension of A as declared\n*           in the calling (sub) program. LDA must be at least\n*           max( 1, n ).\n*           Unchanged on exit.\n*\n*  X      - COMPLEX*16         array of DIMENSION at least\n*           ( 1 + ( n - 1 )*abs( INCX ) )\n*           Before entry, the incremented array X must contain the\n*           vector x.\n*           Unchanged on exit.\n*\n*  INCX    (input) INTEGER\n*           On entry, INCX specifies the increment for the elements of\n*           X. INCX must not be zero.\n*           Unchanged on exit.\n*\n*  BETA   - DOUBLE PRECISION   .\n*           On entry, BETA specifies the scalar beta. When BETA is\n*           supplied as zero then Y need not be set on input.\n*           Unchanged on exit.\n*\n*  Y       (input/output) DOUBLE PRECISION  array, dimension\n*           ( 1 + ( n - 1 )*abs( INCY ) )\n*           Before entry with BETA non-zero, the incremented array Y\n*           must contain the vector y. On exit, Y is overwritten by the\n*           updated vector y.\n*\n*  INCY    (input) INTEGER\n*           On entry, INCY specifies the increment for the elements of\n*           Y. INCY must not be zero.\n*           Unchanged on exit.\n*\n\n*  Further Details\n*  ===============\n*\n*  Level 2 Blas routine.\n*\n*  -- Written on 22-October-1986.\n*     Jack Dongarra, Argonne National Lab.\n*     Jeremy Du Croz, Nag Central Office.\n*     Sven Hammarling, Nag Central Office.\n*     Richard Hanson, Sandia National Labs.\n*  -- Modified for the absolute-value product, April 2006\n*     Jason Riedy, UC Berkeley\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  y = NumRu::Lapack.zla_heamv( uplo, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_uplo = argv[0];
  rblapack_alpha = argv[1];
  rblapack_a = argv[2];
  rblapack_x = argv[3];
  rblapack_incx = argv[4];
  rblapack_beta = argv[5];
  rblapack_y = argv[6];
  rblapack_incy = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = NUM2INT(rblapack_uplo);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (lda != (MAX(1, n)))
    rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", MAX(1, n));
  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*);
  incx = NUM2INT(rblapack_incx);
  incy = NUM2INT(rblapack_incy);
  alpha = NUM2DBL(rblapack_alpha);
  beta = NUM2DBL(rblapack_beta);
  lda = MAX(1, n);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (4th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1 + (n-1)*abs(incx)))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + (n-1)*abs(incx));
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (7th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (1 + ( n - 1 )*abs( incy )))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1 + ( n - 1 )*abs( incy ));
  if (NA_TYPE(rblapack_y) != NA_DFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
  y = NA_PTR_TYPE(rblapack_y, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 1 + ( n - 1 )*abs( incy );
    rblapack_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
  MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  zla_heamv_(&uplo, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);

  return rblapack_y;
}

void
init_lapack_zla_heamv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zla_heamv", rblapack_zla_heamv, -1);
}
ruby-lapack-1.7.2/ext/zhesvxx.c0000644000175000017500000006531412502221021016246 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhesvxx_(char* fact, char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, char* equed, doublereal* s, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* rpvgrw, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zhesvxx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_params;
  doublereal *params; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_rpvgrw;
  doublereal rpvgrw; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_err_bnds_norm;
  doublereal *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  doublereal *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_af_out__;
  doublecomplex *af_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  VALUE rblapack_s_out__;
  doublereal *s_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  VALUE rblapack_params_out__;
  doublereal *params_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer nparams;
  integer ldx;
  integer n_err_bnds;

  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  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.zhesvxx( fact, uplo, a, af, ipiv, equed, s, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHESVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     ZHESVXX uses the diagonal pivoting factorization to compute the\n*     solution to a complex*16 system of linear equations A * X = B, where\n*     A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n*     matrices.\n*\n*     If requested, both normwise and maximum componentwise error bounds\n*     are returned. ZHESVXX will return a solution with a tiny\n*     guaranteed error (O(eps) where eps is the working machine\n*     precision) unless the matrix is very ill-conditioned, in which\n*     case a warning is returned. Relevant condition numbers also are\n*     calculated and returned.\n*\n*     ZHESVXX accepts user-provided factorizations and equilibration\n*     factors; see the definitions of the FACT and EQUED options.\n*     Solving with refinement and using a factorization from a previous\n*     ZHESVXX call will also produce a solution with either O(eps)\n*     errors or warnings, but we cannot make that claim for general\n*     user-provided factorizations and equilibration factors if they\n*     differ from what ZHESVXX would itself produce.\n*\n*     Description\n*     ===========\n*\n*     The following steps are performed:\n*\n*     1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n*     the system:\n*\n*       diag(S)*A*diag(S)     *inv(diag(S))*X = diag(S)*B\n*\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n*     2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n*     the matrix A (after equilibration if FACT = 'E') as\n*\n*        A = U * D * U**T,  if UPLO = 'U', or\n*        A = L * D * L**T,  if UPLO = 'L',\n*\n*     where U (or L) is a product of permutation and unit upper (lower)\n*     triangular matrices, and D is symmetric and block diagonal with\n*     1-by-1 and 2-by-2 diagonal blocks.\n*\n*     3. If some D(i,i)=0, so that D is exactly singular, then the\n*     routine returns with INFO = i. Otherwise, the factored form of A\n*     is used to estimate the condition number of the matrix A (see\n*     argument RCOND).  If the reciprocal of the condition number is\n*     less than machine precision, the routine still goes on to solve\n*     for X and compute error bounds as described below.\n*\n*     4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*     5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n*     the routine will use iterative refinement to try to get a small\n*     error and error bounds.  Refinement calculates the residual to at\n*     least twice the working precision.\n*\n*     6. If equilibration was used, the matrix X is premultiplied by\n*     diag(R) so that it solves the original system before\n*     equilibration.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     FACT    (input) CHARACTER*1\n*     Specifies whether or not the factored form of the matrix A is\n*     supplied on entry, and if not, whether the matrix A should be\n*     equilibrated before it is factored.\n*       = 'F':  On entry, AF and IPIV contain the factored form of A.\n*               If EQUED is not 'N', the matrix A has been\n*               equilibrated with scaling factors given by S.\n*               A, AF, and IPIV are not modified.\n*       = 'N':  The matrix A will be copied to AF and factored.\n*       = 'E':  The matrix A will be equilibrated if necessary, then\n*               copied to AF and factored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*     The symmetric matrix A.  If UPLO = 'U', the leading N-by-N\n*     upper triangular part of A contains the upper triangular\n*     part of the matrix A, and the strictly lower triangular\n*     part of A is not referenced.  If UPLO = 'L', the leading\n*     N-by-N lower triangular part of A contains the lower\n*     triangular part of the matrix A, and the strictly upper\n*     triangular part of A is not referenced.\n*\n*     On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n*     diag(S)*A*diag(S).\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input or output) COMPLEX*16 array, dimension (LDAF,N)\n*     If FACT = 'F', then AF is an input argument and on entry\n*     contains the block diagonal matrix D and the multipliers\n*     used to obtain the factor U or L from the factorization A =\n*     U*D*U**T or A = L*D*L**T as computed by DSYTRF.\n*\n*     If FACT = 'N', then AF is an output argument and on exit\n*     returns the block diagonal matrix D and the multipliers\n*     used to obtain the factor U or L from the factorization A =\n*     U*D*U**T or A = L*D*L**T.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input or output) INTEGER array, dimension (N)\n*     If FACT = 'F', then IPIV is an input argument and on entry\n*     contains details of the interchanges and the block\n*     structure of D, as determined by ZHETRF.  If IPIV(k) > 0,\n*     then rows and columns k and IPIV(k) were interchanged and\n*     D(k,k) is a 1-by-1 diagonal block.  If UPLO = 'U' and\n*     IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and\n*     -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2\n*     diagonal block.  If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0,\n*     then rows and columns k+1 and -IPIV(k) were interchanged\n*     and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*     If FACT = 'N', then IPIV is an output argument and on exit\n*     contains details of the interchanges and the block\n*     structure of D, as determined by ZHETRF.\n*\n*     EQUED   (input or output) CHARACTER*1\n*     Specifies the form of equilibration that was done.\n*       = 'N':  No equilibration (always true if FACT = 'N').\n*       = 'Y':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(S) * A * diag(S).\n*     EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*     output argument.\n*\n*     S       (input or output) DOUBLE PRECISION array, dimension (N)\n*     The scale factors for A.  If EQUED = 'Y', A is multiplied on\n*     the left and right by diag(S).  S is an input argument if FACT =\n*     'F'; otherwise, S is an output argument.  If FACT = 'F' and EQUED\n*     = 'Y', each element of S must be positive.  If S is output, each\n*     element of S is a power of the radix. If S is input, each element\n*     of S should be a power of the radix to ensure a reliable solution\n*     and error estimates. Scaling by powers of the radix does not cause\n*     rounding errors unless the result underflows or overflows.\n*     Rounding errors during scaling lead to refining with a matrix that\n*     is not equivalent to the input matrix, producing error estimates\n*     that may not be reliable.\n*\n*     B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*     On entry, the N-by-NRHS right hand side matrix B.\n*     On exit,\n*     if EQUED = 'N', B is not modified;\n*     if EQUED = 'Y', B is overwritten by diag(S)*B;\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (output) COMPLEX*16 array, dimension (LDX,NRHS)\n*     If INFO = 0, the N-by-NRHS solution matrix X to the original\n*     system of equations.  Note that A and B are modified on exit if\n*     EQUED .ne. 'N', and the solution to the equilibrated system is\n*     inv(diag(S))*X.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) DOUBLE PRECISION\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     RPVGRW  (output) DOUBLE PRECISION\n*     Reciprocal pivot growth.  On exit, this contains the reciprocal\n*     pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n*     norm is used.  If this is much less than 1, then the stability of\n*     the LU factorization of the (equilibrated) matrix A could be poor.\n*     This also means that the solution X, estimated condition numbers,\n*     and error bounds could be unreliable. If factorization fails with\n*     0 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.zhesvxx( fact, uplo, a, af, ipiv, equed, s, b, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_equed = argv[5];
  rblapack_s = argv[6];
  rblapack_b = argv[7];
  rblapack_params = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (7th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (9th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_DFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
  params = NA_PTR_TYPE(rblapack_params, doublereal*);
  n_err_bnds = 3;
  uplo = StringValueCStr(rblapack_uplo)[0];
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  ldx = MAX(1,n);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldaf;
    shape[1] = n;
    rblapack_af_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  af_out__ = NA_PTR_TYPE(rblapack_af_out__, doublecomplex*);
  MEMCPY(af_out__, af, doublecomplex, NA_TOTAL(rblapack_af));
  rblapack_af = rblapack_af_out__;
  af = af_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
  MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
  MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (2*n));

  zhesvxx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, s, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_rpvgrw = rb_float_new((double)rpvgrw);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(14, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_a, rblapack_af, rblapack_ipiv, rblapack_equed, rblapack_s, rblapack_b, rblapack_params);
}

void
init_lapack_zhesvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhesvxx", rblapack_zhesvxx, -1);
}
ruby-lapack-1.7.2/ext/dlartgp.c0000644000175000017500000000553212502221021016160 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlartgp_(doublereal* f, doublereal* g, doublereal* cs, doublereal* sn, doublereal* r);


static VALUE
rblapack_dlartgp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_f;
  doublereal f; 
  VALUE rblapack_g;
  doublereal g; 
  VALUE rblapack_cs;
  doublereal cs; 
  VALUE rblapack_sn;
  doublereal sn; 
  VALUE rblapack_r;
  doublereal r; 


  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  cs, sn, r = NumRu::Lapack.dlartgp( f, g, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLARTGP( F, G, CS, SN, R )\n\n*  Purpose\n*  =======\n*\n*  DLARTGP generates a plane rotation so that\n*\n*     [  CS  SN  ]  .  [ F ]  =  [ R ]   where CS**2 + SN**2 = 1.\n*     [ -SN  CS  ]     [ G ]     [ 0 ]\n*\n*  This is a slower, more accurate version of the Level 1 BLAS routine DROTG,\n*  with the following other differences:\n*     F and G are unchanged on return.\n*     If G=0, then CS=(+/-)1 and SN=0.\n*     If F=0 and (G .ne. 0), then CS=0 and SN=(+/-)1.\n*\n*  The sign is chosen so that R >= 0.\n*\n\n*  Arguments\n*  =========\n*\n*  F       (input) DOUBLE PRECISION\n*          The first component of vector to be rotated.\n*\n*  G       (input) DOUBLE PRECISION\n*          The second component of vector to be rotated.\n*\n*  CS      (output) DOUBLE PRECISION\n*          The cosine of the rotation.\n*\n*  SN      (output) DOUBLE PRECISION\n*          The sine of the rotation.\n*\n*  R       (output) DOUBLE PRECISION\n*          The nonzero component of the rotated vector.\n*\n*  This version has a few statements commented out for thread safety\n*  (machine parameters are computed on each entry). 10 feb 03, SJH.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  cs, sn, r = NumRu::Lapack.dlartgp( f, g, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_f = argv[0];
  rblapack_g = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  f = NUM2DBL(rblapack_f);
  g = NUM2DBL(rblapack_g);

  dlartgp_(&f, &g, &cs, &sn, &r);

  rblapack_cs = rb_float_new((double)cs);
  rblapack_sn = rb_float_new((double)sn);
  rblapack_r = rb_float_new((double)r);
  return rb_ary_new3(3, rblapack_cs, rblapack_sn, rblapack_r);
}

void
init_lapack_dlartgp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlartgp", rblapack_dlartgp, -1);
}
ruby-lapack-1.7.2/ext/sgeesx.c0000644000175000017500000003166112502221016016027 0ustar  uwabamiuwabami#include "rb_lapack.h"

static logical
rblapack_select(real *arg0, real *arg1){
  VALUE rblapack_arg0, rblapack_arg1;

  VALUE rblapack_ret;
  logical ret;

  rblapack_arg0 = rb_float_new((double)(*arg0));
  rblapack_arg1 = rb_float_new((double)(*arg1));

  rblapack_ret = rb_yield_values(2, rblapack_arg0, rblapack_arg1);

  ret = (rblapack_ret == Qtrue);
  return ret;
}

extern VOID sgeesx_(char* jobvs, char* sort, L_fp select, char* sense, integer* n, real* a, integer* lda, integer* sdim, real* wr, real* wi, real* vs, integer* ldvs, real* rconde, real* rcondv, real* work, integer* lwork, integer* iwork, integer* liwork, logical* bwork, integer* info);


static VALUE
rblapack_sgeesx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvs;
  char jobvs; 
  VALUE rblapack_sort;
  char sort; 
  VALUE rblapack_sense;
  char sense; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_sdim;
  integer sdim; 
  VALUE rblapack_wr;
  real *wr; 
  VALUE rblapack_wi;
  real *wi; 
  VALUE rblapack_vs;
  real *vs; 
  VALUE rblapack_rconde;
  real rconde; 
  VALUE rblapack_rcondv;
  real rcondv; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  logical *bwork;

  integer lda;
  integer n;
  integer ldvs;

  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  sdim, wr, wi, vs, rconde, rcondv, work, iwork, info, a = NumRu::Lapack.sgeesx( jobvs, sort, sense, a, liwork, [:lwork => lwork, :usage => usage, :help => help]){|a,b| ... }\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, IWORK, LIWORK, BWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGEESX computes for an N-by-N real nonsymmetric matrix A, the\n*  eigenvalues, the real Schur form T, and, optionally, the matrix of\n*  Schur vectors Z.  This gives the Schur factorization A = Z*T*(Z**T).\n*\n*  Optionally, it also orders the eigenvalues on the diagonal of the\n*  real Schur form so that selected eigenvalues are at the top left;\n*  computes a reciprocal condition number for the average of the\n*  selected eigenvalues (RCONDE); and computes a reciprocal condition\n*  number for the right invariant subspace corresponding to the\n*  selected eigenvalues (RCONDV).  The leading columns of Z form an\n*  orthonormal basis for this invariant subspace.\n*\n*  For further explanation of the reciprocal condition numbers RCONDE\n*  and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where\n*  these quantities are called s and sep respectively).\n*\n*  A real matrix is in real Schur form if it is upper quasi-triangular\n*  with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in\n*  the form\n*            [  a  b  ]\n*            [  c  a  ]\n*\n*  where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVS   (input) CHARACTER*1\n*          = 'N': Schur vectors are not computed;\n*          = 'V': Schur vectors are computed.\n*\n*  SORT    (input) CHARACTER*1\n*          Specifies whether or not to order the eigenvalues on the\n*          diagonal of the Schur form.\n*          = 'N': Eigenvalues are not ordered;\n*          = 'S': Eigenvalues are ordered (see SELECT).\n*\n*  SELECT  (external procedure) LOGICAL FUNCTION of two REAL arguments\n*          SELECT must be declared EXTERNAL in the calling subroutine.\n*          If SORT = 'S', SELECT is used to select eigenvalues to sort\n*          to the top left of the Schur form.\n*          If SORT = 'N', SELECT is not referenced.\n*          An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if\n*          SELECT(WR(j),WI(j)) is true; i.e., if either one of a\n*          complex conjugate pair of eigenvalues is selected, then both\n*          are.  Note that a selected complex eigenvalue may no longer\n*          satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since\n*          ordering may change the value of complex eigenvalues\n*          (especially if the eigenvalue is ill-conditioned); in this\n*          case INFO may be set to N+3 (see INFO below).\n*\n*  SENSE   (input) CHARACTER*1\n*          Determines which reciprocal condition numbers are computed.\n*          = 'N': None are computed;\n*          = 'E': Computed for average of selected eigenvalues only;\n*          = 'V': Computed for selected right invariant subspace only;\n*          = 'B': Computed for both.\n*          If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA, N)\n*          On entry, the N-by-N matrix A.\n*          On exit, A is overwritten by its real Schur form T.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  SDIM    (output) INTEGER\n*          If SORT = 'N', SDIM = 0.\n*          If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n*                         for which SELECT is true. (Complex conjugate\n*                         pairs for which SELECT is true for either\n*                         eigenvalue count as 2.)\n*\n*  WR      (output) REAL array, dimension (N)\n*  WI      (output) REAL array, dimension (N)\n*          WR and WI contain the real and imaginary parts, respectively,\n*          of the computed eigenvalues, in the same order that they\n*          appear on the diagonal of the output Schur form T.  Complex\n*          conjugate pairs of eigenvalues appear consecutively with the\n*          eigenvalue having the positive imaginary part first.\n*\n*  VS      (output) REAL array, dimension (LDVS,N)\n*          If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur\n*          vectors.\n*          If JOBVS = 'N', VS is not referenced.\n*\n*  LDVS    (input) INTEGER\n*          The leading dimension of the array VS.  LDVS >= 1, and if\n*          JOBVS = 'V', LDVS >= N.\n*\n*  RCONDE  (output) REAL\n*          If SENSE = 'E' or 'B', RCONDE contains the reciprocal\n*          condition number for the average of the selected eigenvalues.\n*          Not referenced if SENSE = 'N' or 'V'.\n*\n*  RCONDV  (output) REAL\n*          If SENSE = 'V' or 'B', RCONDV contains the reciprocal\n*          condition number for the selected right invariant subspace.\n*          Not referenced if SENSE = 'N' or 'E'.\n*\n*  WORK    (workspace/output) REAL 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,3*N).\n*          Also, if SENSE = 'E' or 'V' or 'B',\n*          LWORK >= N+2*SDIM*(N-SDIM), where SDIM is the number of\n*          selected eigenvalues computed by this routine.  Note that\n*          N+2*SDIM*(N-SDIM) <= N+N*N/2. Note also that an error is only\n*          returned if LWORK < max(1,3*N), but if SENSE = 'E' or 'V' or\n*          'B' this may not be large enough.\n*          For good performance, LWORK must generally be larger.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates upper bounds on the optimal sizes of the\n*          arrays WORK and IWORK, returns these values as the first\n*          entries of the WORK and IWORK arrays, and no error messages\n*          related to LWORK or LIWORK are issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.\n*          LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM).\n*          Note that SDIM*(N-SDIM) <= N*N/4. Note also that an error is\n*          only returned if LIWORK < 1, but if SENSE = 'V' or 'B' this\n*          may not be large enough.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates upper bounds on the optimal sizes of\n*          the arrays WORK and IWORK, returns these values as the first\n*          entries of the WORK and IWORK arrays, and no error messages\n*          related to LWORK or LIWORK are issued by XERBLA.\n*\n*  BWORK   (workspace) LOGICAL array, dimension (N)\n*          Not referenced if SORT = 'N'.\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, and i is\n*             <= N: the QR algorithm failed to compute all the\n*                   eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI\n*                   contain those eigenvalues which have converged; if\n*                   JOBVS = 'V', VS contains the transformation which\n*                   reduces A to its partially converged Schur form.\n*             = N+1: the eigenvalues could not be reordered because some\n*                   eigenvalues were too close to separate (the problem\n*                   is very ill-conditioned);\n*             = N+2: after reordering, roundoff changed values of some\n*                   complex eigenvalues so that leading eigenvalues in\n*                   the Schur form no longer satisfy SELECT=.TRUE.  This\n*                   could also be caused by underflow due to scaling.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sdim, wr, wi, vs, rconde, rcondv, work, iwork, info, a = NumRu::Lapack.sgeesx( jobvs, sort, sense, a, liwork, [:lwork => lwork, :usage => usage, :help => help]){|a,b| ... }\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_jobvs = argv[0];
  rblapack_sort = argv[1];
  rblapack_sense = argv[2];
  rblapack_a = argv[3];
  rblapack_liwork = argv[4];
  if (argc == 6) {
    rblapack_lwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  jobvs = StringValueCStr(rblapack_jobvs)[0];
  sense = StringValueCStr(rblapack_sense)[0];
  liwork = NUM2INT(rblapack_liwork);
  sort = StringValueCStr(rblapack_sort)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  ldvs = lsame_(&jobvs,"V") ? n : 1;
  if (rblapack_lwork == Qnil)
    lwork = (lsame_(&sense,"E")||lsame_(&sense,"V")||lsame_(&sense,"B")) ? n+n*n/2 : 3*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  wr = NA_PTR_TYPE(rblapack_wr, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  wi = NA_PTR_TYPE(rblapack_wi, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldvs;
    shape[1] = n;
    rblapack_vs = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vs = NA_PTR_TYPE(rblapack_vs, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));

  sgeesx_(&jobvs, &sort, rblapack_select, &sense, &n, a, &lda, &sdim, wr, wi, vs, &ldvs, &rconde, &rcondv, work, &lwork, iwork, &liwork, bwork, &info);

  free(bwork);
  rblapack_sdim = INT2NUM(sdim);
  rblapack_rconde = rb_float_new((double)rconde);
  rblapack_rcondv = rb_float_new((double)rcondv);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(10, rblapack_sdim, rblapack_wr, rblapack_wi, rblapack_vs, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_iwork, rblapack_info, rblapack_a);
}

void
init_lapack_sgeesx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgeesx", rblapack_sgeesx, -1);
}
ruby-lapack-1.7.2/ext/dpstrf.c0000644000175000017500000001262612502221022016030 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dpstrf_(char* uplo, integer* n, doublereal* a, integer* lda, integer* piv, integer* rank, doublereal* tol, doublereal* work, integer* info);


static VALUE
rblapack_dpstrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_tol;
  doublereal tol; 
  VALUE rblapack_piv;
  integer *piv; 
  VALUE rblapack_rank;
  integer rank; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  doublereal *work;

  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  piv, rank, info, a = NumRu::Lapack.dpstrf( uplo, a, tol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPSTRF computes the Cholesky factorization with complete\n*  pivoting of a real symmetric positive semidefinite matrix A.\n*\n*  The factorization has the form\n*     P' * A * P = U' * U ,  if UPLO = 'U',\n*     P' * A * P = L  * L',  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is lower triangular, and\n*  P is stored as vector PIV.\n*\n*  This algorithm does not attempt to check that A is positive\n*  semidefinite. This version of the algorithm calls level 3 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          n by n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n by n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the factor U or L from the Cholesky\n*          factorization as above.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  PIV     (output) INTEGER array, dimension (N)\n*          PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n*\n*  RANK    (output) INTEGER\n*          The rank of A given by the number of steps the algorithm\n*          completed.\n*\n*  TOL     (input) DOUBLE PRECISION\n*          User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) )\n*          will be used. The algorithm terminates at the (K-1)st step\n*          if the pivot <= TOL.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N)\n*          Work space.\n*\n*  INFO    (output) INTEGER\n*          < 0: If INFO = -K, the K-th argument had an illegal value,\n*          = 0: algorithm completed successfully, and\n*          > 0: the matrix A is either rank deficient with computed rank\n*               as returned in RANK, or is indefinite.  See Section 7 of\n*               LAPACK Working Note #161 for further information.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  piv, rank, info, a = NumRu::Lapack.dpstrf( uplo, a, tol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_tol = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  tol = NUM2DBL(rblapack_tol);
  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*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_piv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  piv = NA_PTR_TYPE(rblapack_piv, integer*);
  {
    na_shape_t 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, (2*n));

  dpstrf_(&uplo, &n, a, &lda, piv, &rank, &tol, work, &info);

  free(work);
  rblapack_rank = INT2NUM(rank);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_piv, rblapack_rank, rblapack_info, rblapack_a);
}

void
init_lapack_dpstrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dpstrf", rblapack_dpstrf, -1);
}
ruby-lapack-1.7.2/ext/spbtf2.c0000644000175000017500000001222412502221016015723 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID spbtf2_(char* uplo, integer* n, integer* kd, real* ab, integer* ldab, integer* info);


static VALUE
rblapack_spbtf2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  real *ab_out__;

  integer ldab;
  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  info, ab = NumRu::Lapack.spbtf2( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPBTF2( UPLO, N, KD, AB, LDAB, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPBTF2 computes the Cholesky factorization of a real symmetric\n*  positive definite band matrix A.\n*\n*  The factorization has the form\n*     A = U' * U ,  if UPLO = 'U', or\n*     A = L  * L',  if UPLO = 'L',\n*  where U is an upper triangular matrix, U' is the transpose of U, and\n*  L is lower triangular.\n*\n*  This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored:\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of super-diagonals of the matrix A if UPLO = 'U',\n*          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) REAL array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*          On exit, if INFO = 0, the triangular factor U or L from the\n*          Cholesky factorization A = U'*U or A = L*L' of the band\n*          matrix A, in the same storage format as A.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*          > 0: if INFO = k, the leading minor of order k is not\n*               positive definite, and the factorization could not be\n*               completed.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  N = 6, KD = 2, and UPLO = 'U':\n*\n*  On entry:                       On exit:\n*\n*      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46\n*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56\n*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66\n*\n*  Similarly, if UPLO = 'L' the format of A is as follows:\n*\n*  On entry:                       On exit:\n*\n*     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66\n*     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *\n*     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *\n*\n*  Array elements marked * are not used by the routine.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ab = NumRu::Lapack.spbtf2( uplo, kd, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  kd = NUM2INT(rblapack_kd);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
  MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  spbtf2_(&uplo, &n, &kd, ab, &ldab, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ab);
}

void
init_lapack_spbtf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "spbtf2", rblapack_spbtf2, -1);
}
ruby-lapack-1.7.2/ext/dgbrfs.c0000644000175000017500000002260212502221022015770 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgbrfs_(char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, doublereal* ab, integer* ldab, doublereal* afb, integer* ldafb, integer* ipiv, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dgbrfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_afb;
  doublereal *afb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  doublereal *x_out__;
  doublereal *work;
  integer *iwork;

  integer ldab;
  integer n;
  integer ldafb;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.dgbrfs( trans, kl, ku, ab, afb, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGBRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is banded, and provides\n*  error bounds and backward error estimates for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)\n*          The original band matrix A, stored in rows 1 to KL+KU+1.\n*          The j-th column of A is stored in the j-th column of the\n*          array AB as follows:\n*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*  AFB     (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n*          Details of the LU factorization of the band matrix A, as\n*          computed by DGBTRF.  U is stored as an upper triangular band\n*          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n*          the multipliers used during the factorization are stored in\n*          rows KL+KU+2 to 2*KL+KU+1.\n*\n*  LDAFB   (input) INTEGER\n*          The leading dimension of the array AFB.  LDAFB >= 2*KL*KU+1.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices from DGBTRF; for 1<=i<=N, row i of the\n*          matrix was interchanged with row IPIV(i).\n*\n*  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by DGBTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.dgbrfs( trans, kl, ku, ab, afb, ipiv, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_trans = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  rblapack_afb = argv[4];
  rblapack_ipiv = argv[5];
  rblapack_b = argv[6];
  rblapack_x = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
  ldafb = NA_SHAPE0(rblapack_afb);
  n = NA_SHAPE1(rblapack_afb);
  if (NA_TYPE(rblapack_afb) != NA_DFLOAT)
    rblapack_afb = na_change_type(rblapack_afb, NA_DFLOAT);
  afb = NA_PTR_TYPE(rblapack_afb, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (8th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (8th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(doublereal, (3*n));
  iwork = ALLOC_N(integer, (n));

  dgbrfs_(&trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_dgbrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgbrfs", rblapack_dgbrfs, -1);
}
ruby-lapack-1.7.2/ext/cgbbrd.c0000644000175000017500000001755512502221024015761 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgbbrd_(char* vect, integer* m, integer* n, integer* ncc, integer* kl, integer* ku, complex* ab, integer* ldab, real* d, real* e, complex* q, integer* ldq, complex* pt, integer* ldpt, complex* c, integer* ldc, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cgbbrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_vect;
  char vect; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_c;
  complex *c; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_q;
  complex *q; 
  VALUE rblapack_pt;
  complex *pt; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  complex *ab_out__;
  VALUE rblapack_c_out__;
  complex *c_out__;
  complex *work;
  real *rwork;

  integer ldab;
  integer n;
  integer ldc;
  integer ncc;
  integer ldq;
  integer m;
  integer ldpt;

  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  d, e, q, pt, info, ab, c = NumRu::Lapack.cgbbrd( vect, kl, ku, ab, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, LDQ, PT, LDPT, C, LDC, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGBBRD reduces a complex general m-by-n band matrix A to real upper\n*  bidiagonal form B by a unitary transformation: Q' * A * P = B.\n*\n*  The routine computes B, and optionally forms Q or P', or computes\n*  Q'*C for a given matrix C.\n*\n\n*  Arguments\n*  =========\n*\n*  VECT    (input) CHARACTER*1\n*          Specifies whether or not the matrices Q and P' are to be\n*          formed.\n*          = 'N': do not form Q or P';\n*          = 'Q': form Q only;\n*          = 'P': form P' only;\n*          = 'B': form both.\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*  NCC     (input) INTEGER\n*          The number of columns of the matrix C.  NCC >= 0.\n*\n*  KL      (input) INTEGER\n*          The number of subdiagonals of the matrix A. KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals of the matrix A. KU >= 0.\n*\n*  AB      (input/output) COMPLEX array, dimension (LDAB,N)\n*          On entry, the m-by-n band matrix A, stored in rows 1 to\n*          KL+KU+1. The j-th column of A is stored in the j-th column of\n*          the array AB as follows:\n*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n*          On exit, A is overwritten by values generated during the\n*          reduction.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array A. LDAB >= KL+KU+1.\n*\n*  D       (output) REAL array, dimension (min(M,N))\n*          The diagonal elements of the bidiagonal matrix B.\n*\n*  E       (output) REAL array, dimension (min(M,N)-1)\n*          The superdiagonal elements of the bidiagonal matrix B.\n*\n*  Q       (output) COMPLEX array, dimension (LDQ,M)\n*          If VECT = 'Q' or 'B', the m-by-m unitary matrix Q.\n*          If VECT = 'N' or 'P', the array Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.\n*          LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.\n*\n*  PT      (output) COMPLEX array, dimension (LDPT,N)\n*          If VECT = 'P' or 'B', the n-by-n unitary matrix P'.\n*          If VECT = 'N' or 'Q', the array PT is not referenced.\n*\n*  LDPT    (input) INTEGER\n*          The leading dimension of the array PT.\n*          LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.\n*\n*  C       (input/output) COMPLEX array, dimension (LDC,NCC)\n*          On entry, an m-by-ncc matrix C.\n*          On exit, C is overwritten by Q'*C.\n*          C is not referenced if NCC = 0.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C.\n*          LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.\n*\n*  WORK    (workspace) COMPLEX array, dimension (max(M,N))\n*\n*  RWORK   (workspace) REAL array, dimension (max(M,N))\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, q, pt, info, ab, c = NumRu::Lapack.cgbbrd( vect, kl, ku, ab, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_vect = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  rblapack_c = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  vect = StringValueCStr(rblapack_vect)[0];
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  ncc = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, complex*);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  ldpt = ((lsame_(&vect,"P")) || (lsame_(&vect,"B"))) ? MAX(1,n) : 1;
  m = ldab;
  ldq = ((lsame_(&vect,"Q")) || (lsame_(&vect,"B"))) ? MAX(1,m) : 1;
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, real*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n)-1;
    rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = m;
    rblapack_q = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  q = NA_PTR_TYPE(rblapack_q, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldpt;
    shape[1] = n;
    rblapack_pt = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  pt = NA_PTR_TYPE(rblapack_pt, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
  MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = ncc;
    rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
  MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(complex, (MAX(m,n)));
  rwork = ALLOC_N(real, (MAX(m,n)));

  cgbbrd_(&vect, &m, &n, &ncc, &kl, &ku, ab, &ldab, d, e, q, &ldq, pt, &ldpt, c, &ldc, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_d, rblapack_e, rblapack_q, rblapack_pt, rblapack_info, rblapack_ab, rblapack_c);
}

void
init_lapack_cgbbrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgbbrd", rblapack_cgbbrd, -1);
}
ruby-lapack-1.7.2/ext/dstebz.c0000644000175000017500000002671412502221017016030 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dstebz_(char* range, char* order, integer* n, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, doublereal* d, doublereal* e, integer* m, integer* nsplit, doublereal* w, integer* iblock, integer* isplit, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dstebz(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_order;
  char order; 
  VALUE rblapack_vl;
  doublereal vl; 
  VALUE rblapack_vu;
  doublereal vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  doublereal abstol; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_nsplit;
  integer nsplit; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_iblock;
  integer *iblock; 
  VALUE rblapack_isplit;
  integer *isplit; 
  VALUE rblapack_info;
  integer info; 
  doublereal *work;
  integer *iwork;

  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  m, nsplit, w, iblock, isplit, info = NumRu::Lapack.dstebz( range, order, vl, vu, il, iu, abstol, d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSTEBZ computes the eigenvalues of a symmetric tridiagonal\n*  matrix T.  The user may ask for all eigenvalues, all eigenvalues\n*  in the half-open interval (VL, VU], or the IL-th through IU-th\n*  eigenvalues.\n*\n*  To avoid overflow, the matrix must be scaled so that its\n*  largest element is no greater than overflow**(1/2) *\n*  underflow**(1/4) in absolute value, and for greatest\n*  accuracy, it should not be much smaller than that.\n*\n*  See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n*  Matrix\", Report CS41, Computer Science Dept., Stanford\n*  University, July 21, 1966.\n*\n\n*  Arguments\n*  =========\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': (\"All\")   all eigenvalues will be found.\n*          = 'V': (\"Value\") all eigenvalues in the half-open interval\n*                           (VL, VU] will be found.\n*          = 'I': (\"Index\") the IL-th through IU-th eigenvalues (of the\n*                           entire matrix) will be found.\n*\n*  ORDER   (input) CHARACTER*1\n*          = 'B': (\"By Block\") the eigenvalues will be grouped by\n*                              split-off block (see IBLOCK, ISPLIT) and\n*                              ordered from smallest to largest within\n*                              the block.\n*          = 'E': (\"Entire matrix\")\n*                              the eigenvalues for the entire matrix\n*                              will be ordered from smallest to\n*                              largest.\n*\n*  N       (input) INTEGER\n*          The order of the tridiagonal matrix T.  N >= 0.\n*\n*  VL      (input) DOUBLE PRECISION\n*  VU      (input) DOUBLE PRECISION\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues.  Eigenvalues less than or equal\n*          to VL, or greater than VU, will not be returned.  VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) DOUBLE PRECISION\n*          The absolute tolerance for the eigenvalues.  An eigenvalue\n*          (or cluster) is considered to be located if it has been\n*          determined to lie in an interval whose width is ABSTOL or\n*          less.  If ABSTOL is less than or equal to zero, then ULP*|T|\n*          will be used, where |T| means the 1-norm of T.\n*\n*          Eigenvalues will be computed most accurately when ABSTOL is\n*          set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          The n diagonal elements of the tridiagonal matrix T.\n*\n*  E       (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (n-1) off-diagonal elements of the tridiagonal matrix T.\n*\n*  M       (output) INTEGER\n*          The actual number of eigenvalues found. 0 <= M <= N.\n*          (See also the description of INFO=2,3.)\n*\n*  NSPLIT  (output) INTEGER\n*          The number of diagonal blocks in the matrix T.\n*          1 <= NSPLIT <= N.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          On exit, the first M elements of W will contain the\n*          eigenvalues.  (DSTEBZ may use the remaining N-M elements as\n*          workspace.)\n*\n*  IBLOCK  (output) INTEGER array, dimension (N)\n*          At each row/column j where E(j) is zero or small, the\n*          matrix T is considered to split into a block diagonal\n*          matrix.  On exit, if INFO = 0, IBLOCK(i) specifies to which\n*          block (from 1 to the number of blocks) the eigenvalue W(i)\n*          belongs.  (DSTEBZ may use the remaining N-M elements as\n*          workspace.)\n*\n*  ISPLIT  (output) INTEGER array, dimension (N)\n*          The splitting points, at which T breaks up into submatrices.\n*          The first submatrix consists of rows/columns 1 to ISPLIT(1),\n*          the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n*          etc., and the NSPLIT-th consists of rows/columns\n*          ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n*          (Only the first NSPLIT elements will actually be used, but\n*          since the user cannot know a priori what value NSPLIT will\n*          have, N words must be reserved for ISPLIT.)\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (3*N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  some or all of the eigenvalues failed to converge or\n*                were not computed:\n*                =1 or 3: Bisection failed to converge for some\n*                        eigenvalues; these eigenvalues are flagged by a\n*                        negative block number.  The effect is that the\n*                        eigenvalues may not be as accurate as the\n*                        absolute and relative tolerances.  This is\n*                        generally caused by unexpectedly inaccurate\n*                        arithmetic.\n*                =2 or 3: RANGE='I' only: Not all of the eigenvalues\n*                        IL:IU were found.\n*                        Effect: M < IU+1-IL\n*                        Cause:  non-monotonic arithmetic, causing the\n*                                Sturm sequence to be non-monotonic.\n*                        Cure:   recalculate, using RANGE='A', and pick\n*                                out eigenvalues IL:IU.  In some cases,\n*                                increasing the PARAMETER \"FUDGE\" may\n*                                make things work.\n*                = 4:    RANGE='I', and the Gershgorin interval\n*                        initially used was too small.  No eigenvalues\n*                        were computed.\n*                        Probable cause: your machine has sloppy\n*                                        floating-point arithmetic.\n*                        Cure: Increase the PARAMETER \"FUDGE\",\n*                              recompile, and try again.\n*\n*  Internal Parameters\n*  ===================\n*\n*  RELFAC  DOUBLE PRECISION, default = 2.0e0\n*          The relative tolerance.  An interval (a,b] lies within\n*          \"relative tolerance\" if  b-a < RELFAC*ulp*max(|a|,|b|),\n*          where \"ulp\" is the machine precision (distance from 1 to\n*          the next larger floating point number.)\n*\n*  FUDGE   DOUBLE PRECISION, default = 2\n*          A \"fudge factor\" to widen the Gershgorin intervals.  Ideally,\n*          a value of 1 should work, but on machines with sloppy\n*          arithmetic, this needs to be larger.  The default for\n*          publicly released versions should be large enough to handle\n*          the worst machine around.  Note that this has no effect\n*          on accuracy of the solution.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, nsplit, w, iblock, isplit, info = NumRu::Lapack.dstebz( range, order, vl, vu, il, iu, abstol, d, e, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_range = argv[0];
  rblapack_order = argv[1];
  rblapack_vl = argv[2];
  rblapack_vu = argv[3];
  rblapack_il = argv[4];
  rblapack_iu = argv[5];
  rblapack_abstol = argv[6];
  rblapack_d = argv[7];
  rblapack_e = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  range = StringValueCStr(rblapack_range)[0];
  vl = NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  abstol = NUM2DBL(rblapack_abstol);
  order = StringValueCStr(rblapack_order)[0];
  iu = NUM2INT(rblapack_iu);
  vu = NUM2DBL(rblapack_vu);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (8th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (8th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (9th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_iblock = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iblock = NA_PTR_TYPE(rblapack_iblock, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_isplit = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
  work = ALLOC_N(doublereal, (4*n));
  iwork = ALLOC_N(integer, (3*n));

  dstebz_(&range, &order, &n, &vl, &vu, &il, &iu, &abstol, d, e, &m, &nsplit, w, iblock, isplit, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_nsplit = INT2NUM(nsplit);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_m, rblapack_nsplit, rblapack_w, rblapack_iblock, rblapack_isplit, rblapack_info);
}

void
init_lapack_dstebz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dstebz", rblapack_dstebz, -1);
}
ruby-lapack-1.7.2/ext/dggsvd.c0000644000175000017500000003260612502221026016010 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dggsvd_(char* jobu, char* jobv, char* jobq, integer* m, integer* n, integer* p, integer* k, integer* l, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* alpha, doublereal* beta, doublereal* u, integer* ldu, doublereal* v, integer* ldv, doublereal* q, integer* ldq, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dggsvd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobu;
  char jobu; 
  VALUE rblapack_jobv;
  char jobv; 
  VALUE rblapack_jobq;
  char jobq; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_alpha;
  doublereal *alpha; 
  VALUE rblapack_beta;
  doublereal *beta; 
  VALUE rblapack_u;
  doublereal *u; 
  VALUE rblapack_v;
  doublereal *v; 
  VALUE rblapack_q;
  doublereal *q; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;
  doublereal *work;

  integer lda;
  integer n;
  integer ldb;
  integer ldu;
  integer m;
  integer ldv;
  integer p;
  integer ldq;

  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  k, l, alpha, beta, u, v, q, iwork, info, a, b = NumRu::Lapack.dggsvd( jobu, jobv, jobq, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGGSVD computes the generalized singular value decomposition (GSVD)\n*  of an M-by-N real matrix A and P-by-N real matrix B:\n*\n*      U'*A*Q = D1*( 0 R ),    V'*B*Q = D2*( 0 R )\n*\n*  where U, V and Q are orthogonal matrices, and Z' is the transpose\n*  of Z.  Let K+L = the effective numerical rank of the matrix (A',B')',\n*  then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and\n*  D2 are M-by-(K+L) and P-by-(K+L) \"diagonal\" matrices and of the\n*  following structures, respectively:\n*\n*  If M-K-L >= 0,\n*\n*                      K  L\n*         D1 =     K ( I  0 )\n*                  L ( 0  C )\n*              M-K-L ( 0  0 )\n*\n*                    K  L\n*         D2 =   L ( 0  S )\n*              P-L ( 0  0 )\n*\n*                  N-K-L  K    L\n*    ( 0 R ) = K (  0   R11  R12 )\n*              L (  0    0   R22 )\n*\n*  where\n*\n*    C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n*    S = diag( BETA(K+1),  ... , BETA(K+L) ),\n*    C**2 + S**2 = I.\n*\n*    R is stored in A(1:K+L,N-K-L+1:N) on exit.\n*\n*  If M-K-L < 0,\n*\n*                    K M-K K+L-M\n*         D1 =   K ( I  0    0   )\n*              M-K ( 0  C    0   )\n*\n*                      K M-K K+L-M\n*         D2 =   M-K ( 0  S    0  )\n*              K+L-M ( 0  0    I  )\n*                P-L ( 0  0    0  )\n*\n*                     N-K-L  K   M-K  K+L-M\n*    ( 0 R ) =     K ( 0    R11  R12  R13  )\n*                M-K ( 0     0   R22  R23  )\n*              K+L-M ( 0     0    0   R33  )\n*\n*  where\n*\n*    C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n*    S = diag( BETA(K+1),  ... , BETA(M) ),\n*    C**2 + S**2 = I.\n*\n*    (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored\n*    ( 0  R22 R23 )\n*    in B(M-K+1:L,N+M-K-L+1:N) on exit.\n*\n*  The routine computes C, S, R, and optionally the orthogonal\n*  transformation matrices U, V and Q.\n*\n*  In particular, if B is an N-by-N nonsingular matrix, then the GSVD of\n*  A and B implicitly gives the SVD of A*inv(B):\n*                       A*inv(B) = U*(D1*inv(D2))*V'.\n*  If ( A',B')' has orthonormal columns, then the GSVD of A and B is\n*  also equal to the CS decomposition of A and B. Furthermore, the GSVD\n*  can be used to derive the solution of the eigenvalue problem:\n*                       A'*A x = lambda* B'*B x.\n*  In some literature, the GSVD of A and B is presented in the form\n*                   U'*A*X = ( 0 D1 ),   V'*B*X = ( 0 D2 )\n*  where U and V are orthogonal and X is nonsingular, D1 and D2 are\n*  ``diagonal''.  The former GSVD form can be converted to the latter\n*  form by taking the nonsingular matrix X as\n*\n*                       X = Q*( I   0    )\n*                             ( 0 inv(R) ).\n*\n\n*  Arguments\n*  =========\n*\n*  JOBU    (input) CHARACTER*1\n*          = 'U':  Orthogonal matrix U is computed;\n*          = 'N':  U is not computed.\n*\n*  JOBV    (input) CHARACTER*1\n*          = 'V':  Orthogonal matrix V is computed;\n*          = 'N':  V is not computed.\n*\n*  JOBQ    (input) CHARACTER*1\n*          = 'Q':  Orthogonal matrix Q is computed;\n*          = 'N':  Q is not computed.\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 matrices A and B.  N >= 0.\n*\n*  P       (input) INTEGER\n*          The number of rows of the matrix B.  P >= 0.\n*\n*  K       (output) INTEGER\n*  L       (output) INTEGER\n*          On exit, K and L specify the dimension of the subblocks\n*          described in the Purpose section.\n*          K + L = effective numerical rank of (A',B')'.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, A contains the triangular matrix R, or part of R.\n*          See Purpose for details.\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,N)\n*          On entry, the P-by-N matrix B.\n*          On exit, B contains the triangular matrix R if M-K-L < 0.\n*          See Purpose for details.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,P).\n*\n*  ALPHA   (output) DOUBLE PRECISION array, dimension (N)\n*  BETA    (output) DOUBLE PRECISION array, dimension (N)\n*          On exit, ALPHA and BETA contain the generalized singular\n*          value pairs of A and B;\n*            ALPHA(1:K) = 1,\n*            BETA(1:K)  = 0,\n*          and if M-K-L >= 0,\n*            ALPHA(K+1:K+L) = C,\n*            BETA(K+1:K+L)  = S,\n*          or if M-K-L < 0,\n*            ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0\n*            BETA(K+1:M) =S, BETA(M+1:K+L) =1\n*          and\n*            ALPHA(K+L+1:N) = 0\n*            BETA(K+L+1:N)  = 0\n*\n*  U       (output) DOUBLE PRECISION array, dimension (LDU,M)\n*          If JOBU = 'U', U contains the M-by-M orthogonal matrix U.\n*          If JOBU = 'N', U is not referenced.\n*\n*  LDU     (input) INTEGER\n*          The leading dimension of the array U. LDU >= max(1,M) if\n*          JOBU = 'U'; LDU >= 1 otherwise.\n*\n*  V       (output) DOUBLE PRECISION array, dimension (LDV,P)\n*          If JOBV = 'V', V contains the P-by-P orthogonal matrix V.\n*          If JOBV = 'N', V is not referenced.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V. LDV >= max(1,P) if\n*          JOBV = 'V'; LDV >= 1 otherwise.\n*\n*  Q       (output) DOUBLE PRECISION array, dimension (LDQ,N)\n*          If JOBQ = 'Q', Q contains the N-by-N orthogonal matrix Q.\n*          If JOBQ = 'N', Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q. LDQ >= max(1,N) if\n*          JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n*  WORK    (workspace) DOUBLE PRECISION array,\n*                      dimension (max(3*N,M,P)+N)\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (N)\n*          On exit, IWORK stores the sorting information. More\n*          precisely, the following loop will sort ALPHA\n*             for I = K+1, min(M,K+L)\n*                 swap ALPHA(I) and ALPHA(IWORK(I))\n*             endfor\n*          such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N).\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 = 1, the Jacobi-type procedure failed to\n*                converge.  For further details, see subroutine DTGSJA.\n*\n*  Internal Parameters\n*  ===================\n*\n*  TOLA    DOUBLE PRECISION\n*  TOLB    DOUBLE PRECISION\n*          TOLA and TOLB are the thresholds to determine the effective\n*          rank of (A',B')'. Generally, they are set to\n*                   TOLA = MAX(M,N)*norm(A)*MAZHEPS,\n*                   TOLB = MAX(P,N)*norm(B)*MAZHEPS.\n*          The size of TOLA and TOLB may affect the size of backward\n*          errors of the decomposition.\n*\n\n*  Further Details\n*  ===============\n*\n*  2-96 Based on modifications by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            WANTQ, WANTU, WANTV\n      INTEGER            I, IBND, ISUB, J, NCYCLE\n      DOUBLE PRECISION   ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      DOUBLE PRECISION   DLAMCH, DLANGE\n      EXTERNAL           LSAME, DLAMCH, DLANGE\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DCOPY, DGGSVP, DTGSJA, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  k, l, alpha, beta, u, v, q, iwork, info, a, b = NumRu::Lapack.dggsvd( jobu, jobv, jobq, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_jobu = argv[0];
  rblapack_jobv = argv[1];
  rblapack_jobq = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobu = StringValueCStr(rblapack_jobu)[0];
  jobq = StringValueCStr(rblapack_jobq)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = 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*);
  p = ldb;
  jobv = StringValueCStr(rblapack_jobv)[0];
  ldv = lsame_(&jobv,"V") ? MAX(1,p) : 1;
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  ldq = lsame_(&jobq,"Q") ? MAX(1,n) : 1;
  m = lda;
  ldu = lsame_(&jobu,"U") ? MAX(1,m) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alpha = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  alpha = NA_PTR_TYPE(rblapack_alpha, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = m;
    rblapack_u = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  u = NA_PTR_TYPE(rblapack_u, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = p;
    rblapack_v = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  v = NA_PTR_TYPE(rblapack_v, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  q = NA_PTR_TYPE(rblapack_q, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(doublereal, (MAX(3*n,m)*(p)+n));

  dggsvd_(&jobu, &jobv, &jobq, &m, &n, &p, &k, &l, a, &lda, b, &ldb, alpha, beta, u, &ldu, v, &ldv, q, &ldq, work, iwork, &info);

  free(work);
  rblapack_k = INT2NUM(k);
  rblapack_l = INT2NUM(l);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(11, rblapack_k, rblapack_l, rblapack_alpha, rblapack_beta, rblapack_u, rblapack_v, rblapack_q, rblapack_iwork, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_dggsvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dggsvd", rblapack_dggsvd, -1);
}
ruby-lapack-1.7.2/ext/ztrtri.c0000644000175000017500000001016012502221013016053 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztrtri_(char* uplo, char* diag, integer* n, doublecomplex* a, integer* lda, integer* info);


static VALUE
rblapack_ztrtri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *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  info, a = NumRu::Lapack.ztrtri( uplo, diag, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTRTRI( UPLO, DIAG, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTRTRI computes the inverse of a complex upper or lower triangular\n*  matrix A.\n*\n*  This is the Level 3 BLAS version of the algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the triangular matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of the array A contains\n*          the upper triangular matrix, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of the array A contains\n*          the lower triangular matrix, and the strictly upper\n*          triangular part of A is not referenced.  If DIAG = 'U', the\n*          diagonal elements of A are also not referenced and are\n*          assumed to be 1.\n*          On exit, the (triangular) inverse of the original matrix, in\n*          the same storage format.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\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, A(i,i) is exactly zero.  The triangular\n*               matrix is singular and its inverse can not be computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.ztrtri( uplo, diag, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_diag = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  diag = StringValueCStr(rblapack_diag)[0];
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  ztrtri_(&uplo, &diag, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_ztrtri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztrtri", rblapack_ztrtri, -1);
}
ruby-lapack-1.7.2/ext/clalsa.c0000644000175000017500000004046112502221016015766 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clalsa_(integer* icompq, integer* smlsiz, integer* n, integer* nrhs, complex* b, integer* ldb, complex* bx, integer* ldbx, real* u, integer* ldu, real* vt, integer* k, real* difl, real* difr, real* z, real* poles, integer* givptr, integer* givcol, integer* ldgcol, integer* perm, real* givnum, real* c, real* s, real* rwork, integer* iwork, integer* info);


static VALUE
rblapack_clalsa(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_icompq;
  integer icompq; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_u;
  real *u; 
  VALUE rblapack_vt;
  real *vt; 
  VALUE rblapack_k;
  integer *k; 
  VALUE rblapack_difl;
  real *difl; 
  VALUE rblapack_difr;
  real *difr; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_poles;
  real *poles; 
  VALUE rblapack_givptr;
  integer *givptr; 
  VALUE rblapack_givcol;
  integer *givcol; 
  VALUE rblapack_perm;
  integer *perm; 
  VALUE rblapack_givnum;
  real *givnum; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_bx;
  complex *bx; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  complex *b_out__;
  real *rwork;
  integer *iwork;

  integer ldb;
  integer nrhs;
  integer ldu;
  integer smlsiz;
  integer n;
  integer nlvl;
  integer ldgcol;
  integer ldbx;

  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  bx, info, b = NumRu::Lapack.clalsa( icompq, b, u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, PERM, GIVNUM, C, S, RWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CLALSA is an itermediate step in solving the least squares problem\n*  by computing the SVD of the coefficient matrix in compact form (The\n*  singular vectors are computed as products of simple orthorgonal\n*  matrices.).\n*\n*  If ICOMPQ = 0, CLALSA applies the inverse of the left singular vector\n*  matrix of an upper bidiagonal matrix to the right hand side; and if\n*  ICOMPQ = 1, CLALSA applies the right singular vector matrix to the\n*  right hand side. The singular vector matrices were generated in\n*  compact form by CLALSA.\n*\n\n*  Arguments\n*  =========\n*\n*  ICOMPQ (input) INTEGER\n*         Specifies whether the left or the right singular vector\n*         matrix is involved.\n*         = 0: Left singular vector matrix\n*         = 1: Right singular vector matrix\n*\n*  SMLSIZ (input) INTEGER\n*         The maximum size of the subproblems at the bottom of the\n*         computation tree.\n*\n*  N      (input) INTEGER\n*         The row and column dimensions of the upper bidiagonal matrix.\n*\n*  NRHS   (input) INTEGER\n*         The number of columns of B and BX. NRHS must be at least 1.\n*\n*  B      (input/output) COMPLEX array, dimension ( LDB, NRHS )\n*         On input, B contains the right hand sides of the least\n*         squares problem in rows 1 through M.\n*         On output, B contains the solution X in rows 1 through N.\n*\n*  LDB    (input) INTEGER\n*         The leading dimension of B in the calling subprogram.\n*         LDB must be at least max(1,MAX( M, N ) ).\n*\n*  BX     (output) COMPLEX array, dimension ( LDBX, NRHS )\n*         On exit, the result of applying the left or right singular\n*         vector matrix to B.\n*\n*  LDBX   (input) INTEGER\n*         The leading dimension of BX.\n*\n*  U      (input) REAL array, dimension ( LDU, SMLSIZ ).\n*         On entry, U contains the left singular vector matrices of all\n*         subproblems at the bottom level.\n*\n*  LDU    (input) INTEGER, LDU = > N.\n*         The leading dimension of arrays U, VT, DIFL, DIFR,\n*         POLES, GIVNUM, and Z.\n*\n*  VT     (input) REAL array, dimension ( LDU, SMLSIZ+1 ).\n*         On entry, VT' contains the right singular vector matrices of\n*         all subproblems at the bottom level.\n*\n*  K      (input) INTEGER array, dimension ( N ).\n*\n*  DIFL   (input) REAL array, dimension ( LDU, NLVL ).\n*         where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.\n*\n*  DIFR   (input) REAL array, dimension ( LDU, 2 * NLVL ).\n*         On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record\n*         distances between singular values on the I-th level and\n*         singular values on the (I -1)-th level, and DIFR(*, 2 * I)\n*         record the normalizing factors of the right singular vectors\n*         matrices of subproblems on I-th level.\n*\n*  Z      (input) REAL array, dimension ( LDU, NLVL ).\n*         On entry, Z(1, I) contains the components of the deflation-\n*         adjusted updating row vector for subproblems on the I-th\n*         level.\n*\n*  POLES  (input) REAL array, dimension ( LDU, 2 * NLVL ).\n*         On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old\n*         singular values involved in the secular equations on the I-th\n*         level.\n*\n*  GIVPTR (input) INTEGER array, dimension ( N ).\n*         On entry, GIVPTR( I ) records the number of Givens\n*         rotations performed on the I-th problem on the computation\n*         tree.\n*\n*  GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ).\n*         On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the\n*         locations of Givens rotations performed on the I-th level on\n*         the computation tree.\n*\n*  LDGCOL (input) INTEGER, LDGCOL = > N.\n*         The leading dimension of arrays GIVCOL and PERM.\n*\n*  PERM   (input) INTEGER array, dimension ( LDGCOL, NLVL ).\n*         On entry, PERM(*, I) records permutations done on the I-th\n*         level of the computation tree.\n*\n*  GIVNUM (input) REAL array, dimension ( LDU, 2 * NLVL ).\n*         On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-\n*         values of Givens rotations performed on the I-th level on the\n*         computation tree.\n*\n*  C      (input) REAL array, dimension ( N ).\n*         On entry, if the I-th subproblem is not square,\n*         C( I ) contains the C-value of a Givens rotation related to\n*         the right null space of the I-th subproblem.\n*\n*  S      (input) REAL array, dimension ( N ).\n*         On entry, if the I-th subproblem is not square,\n*         S( I ) contains the S-value of a Givens rotation related to\n*         the right null space of the I-th subproblem.\n*\n*  RWORK  (workspace) REAL array, dimension at least\n*         MAX( (SMLSZ+1)*NRHS*3, N*(1+NRHS) + 2*NRHS ).\n*\n*  IWORK  (workspace) INTEGER array.\n*         The dimension must be at least 3 * N\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*  Based on contributions by\n*     Ming Gu and Ren-Cang Li, Computer Science Division, University of\n*       California at Berkeley, USA\n*     Osni Marques, LBNL/NERSC, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  bx, info, b = NumRu::Lapack.clalsa( icompq, b, u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 15 && argc != 15)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
  rblapack_icompq = argv[0];
  rblapack_b = argv[1];
  rblapack_u = argv[2];
  rblapack_vt = argv[3];
  rblapack_k = argv[4];
  rblapack_difl = argv[5];
  rblapack_difr = argv[6];
  rblapack_z = argv[7];
  rblapack_poles = argv[8];
  rblapack_givptr = argv[9];
  rblapack_givcol = argv[10];
  rblapack_perm = argv[11];
  rblapack_givnum = argv[12];
  rblapack_c = argv[13];
  rblapack_s = argv[14];
  if (argc == 15) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  icompq = NUM2INT(rblapack_icompq);
  if (!NA_IsNArray(rblapack_u))
    rb_raise(rb_eArgError, "u (3th argument) must be NArray");
  if (NA_RANK(rblapack_u) != 2)
    rb_raise(rb_eArgError, "rank of u (3th argument) must be %d", 2);
  ldu = NA_SHAPE0(rblapack_u);
  smlsiz = NA_SHAPE1(rblapack_u);
  if (NA_TYPE(rblapack_u) != NA_SFLOAT)
    rblapack_u = na_change_type(rblapack_u, NA_SFLOAT);
  u = NA_PTR_TYPE(rblapack_u, real*);
  if (!NA_IsNArray(rblapack_k))
    rb_raise(rb_eArgError, "k (5th argument) must be NArray");
  if (NA_RANK(rblapack_k) != 1)
    rb_raise(rb_eArgError, "rank of k (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_k);
  if (NA_TYPE(rblapack_k) != NA_LINT)
    rblapack_k = na_change_type(rblapack_k, NA_LINT);
  k = NA_PTR_TYPE(rblapack_k, integer*);
  if (!NA_IsNArray(rblapack_givptr))
    rb_raise(rb_eArgError, "givptr (10th argument) must be NArray");
  if (NA_RANK(rblapack_givptr) != 1)
    rb_raise(rb_eArgError, "rank of givptr (10th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_givptr) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of givptr must be the same as shape 0 of k");
  if (NA_TYPE(rblapack_givptr) != NA_LINT)
    rblapack_givptr = na_change_type(rblapack_givptr, NA_LINT);
  givptr = NA_PTR_TYPE(rblapack_givptr, integer*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (14th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (14th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of k");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (15th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (15th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 0 of k");
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  nlvl = (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1;
  if (!NA_IsNArray(rblapack_vt))
    rb_raise(rb_eArgError, "vt (4th argument) must be NArray");
  if (NA_RANK(rblapack_vt) != 2)
    rb_raise(rb_eArgError, "rank of vt (4th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_vt) != ldu)
    rb_raise(rb_eRuntimeError, "shape 0 of vt must be the same as shape 0 of u");
  if (NA_SHAPE1(rblapack_vt) != (smlsiz+1))
    rb_raise(rb_eRuntimeError, "shape 1 of vt must be %d", smlsiz+1);
  if (NA_TYPE(rblapack_vt) != NA_SFLOAT)
    rblapack_vt = na_change_type(rblapack_vt, NA_SFLOAT);
  vt = NA_PTR_TYPE(rblapack_vt, real*);
  if (!NA_IsNArray(rblapack_difr))
    rb_raise(rb_eArgError, "difr (7th argument) must be NArray");
  if (NA_RANK(rblapack_difr) != 2)
    rb_raise(rb_eArgError, "rank of difr (7th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_difr) != ldu)
    rb_raise(rb_eRuntimeError, "shape 0 of difr must be the same as shape 0 of u");
  if (NA_SHAPE1(rblapack_difr) != (2 * nlvl))
    rb_raise(rb_eRuntimeError, "shape 1 of difr must be %d", 2 * nlvl);
  if (NA_TYPE(rblapack_difr) != NA_SFLOAT)
    rblapack_difr = na_change_type(rblapack_difr, NA_SFLOAT);
  difr = NA_PTR_TYPE(rblapack_difr, real*);
  if (!NA_IsNArray(rblapack_poles))
    rb_raise(rb_eArgError, "poles (9th argument) must be NArray");
  if (NA_RANK(rblapack_poles) != 2)
    rb_raise(rb_eArgError, "rank of poles (9th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_poles) != ldu)
    rb_raise(rb_eRuntimeError, "shape 0 of poles must be the same as shape 0 of u");
  if (NA_SHAPE1(rblapack_poles) != (2 * nlvl))
    rb_raise(rb_eRuntimeError, "shape 1 of poles must be %d", 2 * nlvl);
  if (NA_TYPE(rblapack_poles) != NA_SFLOAT)
    rblapack_poles = na_change_type(rblapack_poles, NA_SFLOAT);
  poles = NA_PTR_TYPE(rblapack_poles, real*);
  if (!NA_IsNArray(rblapack_perm))
    rb_raise(rb_eArgError, "perm (12th argument) must be NArray");
  if (NA_RANK(rblapack_perm) != 2)
    rb_raise(rb_eArgError, "rank of perm (12th argument) must be %d", 2);
  ldgcol = NA_SHAPE0(rblapack_perm);
  if (NA_SHAPE1(rblapack_perm) != nlvl)
    rb_raise(rb_eRuntimeError, "shape 1 of perm must be (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1");
  if (NA_TYPE(rblapack_perm) != NA_LINT)
    rblapack_perm = na_change_type(rblapack_perm, NA_LINT);
  perm = NA_PTR_TYPE(rblapack_perm, integer*);
  ldbx = n;
  if (!NA_IsNArray(rblapack_difl))
    rb_raise(rb_eArgError, "difl (6th argument) must be NArray");
  if (NA_RANK(rblapack_difl) != 2)
    rb_raise(rb_eArgError, "rank of difl (6th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_difl) != ldu)
    rb_raise(rb_eRuntimeError, "shape 0 of difl must be the same as shape 0 of u");
  if (NA_SHAPE1(rblapack_difl) != nlvl)
    rb_raise(rb_eRuntimeError, "shape 1 of difl must be (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1");
  if (NA_TYPE(rblapack_difl) != NA_SFLOAT)
    rblapack_difl = na_change_type(rblapack_difl, NA_SFLOAT);
  difl = NA_PTR_TYPE(rblapack_difl, real*);
  if (!NA_IsNArray(rblapack_givcol))
    rb_raise(rb_eArgError, "givcol (11th argument) must be NArray");
  if (NA_RANK(rblapack_givcol) != 2)
    rb_raise(rb_eArgError, "rank of givcol (11th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_givcol) != ldgcol)
    rb_raise(rb_eRuntimeError, "shape 0 of givcol must be the same as shape 0 of perm");
  if (NA_SHAPE1(rblapack_givcol) != (2 * nlvl))
    rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", 2 * nlvl);
  if (NA_TYPE(rblapack_givcol) != NA_LINT)
    rblapack_givcol = na_change_type(rblapack_givcol, NA_LINT);
  givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (8th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_z) != ldu)
    rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of u");
  if (NA_SHAPE1(rblapack_z) != nlvl)
    rb_raise(rb_eRuntimeError, "shape 1 of z must be (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1");
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  if (!NA_IsNArray(rblapack_givnum))
    rb_raise(rb_eArgError, "givnum (13th argument) must be NArray");
  if (NA_RANK(rblapack_givnum) != 2)
    rb_raise(rb_eArgError, "rank of givnum (13th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_givnum) != ldu)
    rb_raise(rb_eRuntimeError, "shape 0 of givnum must be the same as shape 0 of u");
  if (NA_SHAPE1(rblapack_givnum) != (2 * nlvl))
    rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", 2 * nlvl);
  if (NA_TYPE(rblapack_givnum) != NA_SFLOAT)
    rblapack_givnum = na_change_type(rblapack_givnum, NA_SFLOAT);
  givnum = NA_PTR_TYPE(rblapack_givnum, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldbx;
    shape[1] = nrhs;
    rblapack_bx = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  bx = NA_PTR_TYPE(rblapack_bx, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  rwork = ALLOC_N(real, (MAX(n,(smlsiz+1)*nrhs*3)));
  iwork = ALLOC_N(integer, (3 * n));

  clalsa_(&icompq, &smlsiz, &n, &nrhs, b, &ldb, bx, &ldbx, u, &ldu, vt, k, difl, difr, z, poles, givptr, givcol, &ldgcol, perm, givnum, c, s, rwork, iwork, &info);

  free(rwork);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_bx, rblapack_info, rblapack_b);
}

void
init_lapack_clalsa(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clalsa", rblapack_clalsa, -1);
}
ruby-lapack-1.7.2/ext/dlaqge.c0000644000175000017500000001343012502221014015756 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaqge_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* r, doublereal* c, doublereal* rowcnd, doublereal* colcnd, doublereal* amax, char* equed);


static VALUE
rblapack_dlaqge(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_r;
  doublereal *r; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_rowcnd;
  doublereal rowcnd; 
  VALUE rblapack_colcnd;
  doublereal colcnd; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;

  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  equed, a = NumRu::Lapack.dlaqge( a, r, c, rowcnd, colcnd, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n*  Purpose\n*  =======\n*\n*  DLAQGE equilibrates a general M by N matrix A using the row and\n*  column scaling factors in the vectors R and C.\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 equilibrated matrix.  See EQUED for the form of\n*          the equilibrated matrix.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(M,1).\n*\n*  R       (input) DOUBLE PRECISION array, dimension (M)\n*          The row scale factors for A.\n*\n*  C       (input) DOUBLE PRECISION array, dimension (N)\n*          The column scale factors for A.\n*\n*  ROWCND  (input) DOUBLE PRECISION\n*          Ratio of the smallest R(i) to the largest R(i).\n*\n*  COLCND  (input) DOUBLE PRECISION\n*          Ratio of the smallest C(i) to the largest C(i).\n*\n*  AMAX    (input) DOUBLE PRECISION\n*          Absolute value of largest matrix entry.\n*\n*  EQUED   (output) CHARACTER*1\n*          Specifies the form of equilibration that was done.\n*          = 'N':  No equilibration\n*          = 'R':  Row equilibration, i.e., A has been premultiplied by\n*                  diag(R).\n*          = 'C':  Column equilibration, i.e., A has been postmultiplied\n*                  by diag(C).\n*          = 'B':  Both row and column equilibration, i.e., A has been\n*                  replaced by diag(R) * A * diag(C).\n*\n*  Internal Parameters\n*  ===================\n*\n*  THRESH is a threshold value used to decide if row or column scaling\n*  should be done based on the ratio of the row or column scaling\n*  factors.  If ROWCND < THRESH, row scaling is done, and if\n*  COLCND < THRESH, column scaling is done.\n*\n*  LARGE and SMALL are threshold values used to decide if row scaling\n*  should be done based on the absolute size of the largest matrix\n*  element.  If AMAX > LARGE or AMAX < SMALL, row scaling is done.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  equed, a = NumRu::Lapack.dlaqge( a, r, c, rowcnd, colcnd, amax, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_a = argv[0];
  rblapack_r = argv[1];
  rblapack_c = argv[2];
  rblapack_rowcnd = argv[3];
  rblapack_colcnd = argv[4];
  rblapack_amax = argv[5];
  if (argc == 6) {
  } 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*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (3th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  colcnd = NUM2DBL(rblapack_colcnd);
  if (!NA_IsNArray(rblapack_r))
    rb_raise(rb_eArgError, "r (2th argument) must be NArray");
  if (NA_RANK(rblapack_r) != 1)
    rb_raise(rb_eArgError, "rank of r (2th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_r);
  if (NA_TYPE(rblapack_r) != NA_DFLOAT)
    rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
  r = NA_PTR_TYPE(rblapack_r, doublereal*);
  amax = NUM2DBL(rblapack_amax);
  rowcnd = NUM2DBL(rblapack_rowcnd);
  {
    na_shape_t 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__;

  dlaqge_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &equed);

  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(2, rblapack_equed, rblapack_a);
}

void
init_lapack_dlaqge(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaqge", rblapack_dlaqge, -1);
}
ruby-lapack-1.7.2/ext/dlasd4.c0000644000175000017500000001321212502221016015674 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlasd4_(integer* n, integer* i, doublereal* d, doublereal* z, doublereal* delta, doublereal* rho, doublereal* sigma, doublereal* work, integer* info);


static VALUE
rblapack_dlasd4(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_i;
  integer i; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_rho;
  doublereal rho; 
  VALUE rblapack_delta;
  doublereal *delta; 
  VALUE rblapack_sigma;
  doublereal sigma; 
  VALUE rblapack_info;
  integer info; 
  doublereal *work;

  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  delta, sigma, info = NumRu::Lapack.dlasd4( i, d, z, rho, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  This subroutine computes the square root of the I-th updated\n*  eigenvalue of a positive symmetric rank-one modification to\n*  a positive diagonal matrix whose entries are given as the squares\n*  of the corresponding entries in the array d, and that\n*\n*         0 <= D(i) < D(j)  for  i < j\n*\n*  and that RHO > 0. This is arranged by the calling routine, and is\n*  no loss in generality.  The rank-one modified system is thus\n*\n*         diag( D ) * diag( D ) +  RHO *  Z * Z_transpose.\n*\n*  where we assume the Euclidean norm of Z is 1.\n*\n*  The method consists of approximating the rational functions in the\n*  secular equation by simpler interpolating rational functions.\n*\n\n*  Arguments\n*  =========\n*\n*  N      (input) INTEGER\n*         The length of all arrays.\n*\n*  I      (input) INTEGER\n*         The index of the eigenvalue to be computed.  1 <= I <= N.\n*\n*  D      (input) DOUBLE PRECISION array, dimension ( N )\n*         The original eigenvalues.  It is assumed that they are in\n*         order, 0 <= D(I) < D(J)  for I < J.\n*\n*  Z      (input) DOUBLE PRECISION array, dimension ( N )\n*         The components of the updating vector.\n*\n*  DELTA  (output) DOUBLE PRECISION array, dimension ( N )\n*         If N .ne. 1, DELTA contains (D(j) - sigma_I) in its  j-th\n*         component.  If N = 1, then DELTA(1) = 1.  The vector DELTA\n*         contains the information necessary to construct the\n*         (singular) eigenvectors.\n*\n*  RHO    (input) DOUBLE PRECISION\n*         The scalar in the symmetric updating formula.\n*\n*  SIGMA  (output) DOUBLE PRECISION\n*         The computed sigma_I, the I-th updated eigenvalue.\n*\n*  WORK   (workspace) DOUBLE PRECISION array, dimension ( N )\n*         If N .ne. 1, WORK contains (D(j) + sigma_I) in its  j-th\n*         component.  If N = 1, then WORK( 1 ) = 1.\n*\n*  INFO   (output) INTEGER\n*         = 0:  successful exit\n*         > 0:  if INFO = 1, the updating process failed.\n*\n*  Internal Parameters\n*  ===================\n*\n*  Logical variable ORGATI (origin-at-i?) is used for distinguishing\n*  whether D(i) or D(i+1) is treated as the origin.\n*\n*            ORGATI = .true.    origin at i\n*            ORGATI = .false.   origin at i+1\n*\n*  Logical variable SWTCH3 (switch-for-3-poles?) is for noting\n*  if we are working with THREE poles!\n*\n*  MAXIT is the maximum number of iterations allowed for each\n*  eigenvalue.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ren-Cang Li, Computer Science Division, University of California\n*     at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  delta, sigma, info = NumRu::Lapack.dlasd4( i, d, z, rho, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_i = argv[0];
  rblapack_d = argv[1];
  rblapack_z = argv[2];
  rblapack_rho = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  i = NUM2INT(rblapack_i);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (3th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of z");
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  rho = NUM2DBL(rblapack_rho);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_delta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  delta = NA_PTR_TYPE(rblapack_delta, doublereal*);
  work = ALLOC_N(doublereal, (n));

  dlasd4_(&n, &i, d, z, delta, &rho, &sigma, work, &info);

  free(work);
  rblapack_sigma = rb_float_new((double)sigma);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_delta, rblapack_sigma, rblapack_info);
}

void
init_lapack_dlasd4(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlasd4", rblapack_dlasd4, -1);
}
ruby-lapack-1.7.2/ext/dgelsd.c0000644000175000017500000002362512502221023015772 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgelsd_(integer* m, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* s, doublereal* rcond, integer* rank, doublereal* work, integer* lwork, integer* iwork, integer* info);


static VALUE
rblapack_dgelsd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_rank;
  integer rank; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublereal *b_out__;
  integer *iwork;

  integer lda;
  integer n;
  integer m;
  integer nrhs;
  integer ldb;
  integer c__9;
  integer c__0;
  integer liwork;
  integer nlvl;
  integer smlsiz;

  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  s, rank, work, info, b = NumRu::Lapack.dgelsd( a, b, rcond, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGELSD computes the minimum-norm solution to a real linear least\n*  squares problem:\n*      minimize 2-norm(| b - A*x |)\n*  using the singular value decomposition (SVD) of A. A is an M-by-N\n*  matrix which may be rank-deficient.\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*  The problem is solved in three steps:\n*  (1) Reduce the coefficient matrix A to bidiagonal form with\n*      Householder transformations, reducing the original problem\n*      into a \"bidiagonal least squares problem\" (BLS)\n*  (2) Solve the BLS using a divide and conquer approach.\n*  (3) Apply back all the Householder tranformations to solve\n*      the original least squares problem.\n*\n*  The effective rank of A is determined by treating as zero those\n*  singular values which are less than RCOND times the largest singular\n*  value.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of A. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of A. N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X. NRHS >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, A has been destroyed.\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 M-by-NRHS right hand side matrix B.\n*          On exit, B is overwritten by the N-by-NRHS solution\n*          matrix X.  If m >= n and RANK = n, the residual\n*          sum-of-squares for the solution in the i-th column is given\n*          by the sum of squares of elements n+1:m in that column.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,max(M,N)).\n*\n*  S       (output) DOUBLE PRECISION array, dimension (min(M,N))\n*          The singular values of A in decreasing order.\n*          The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n*\n*  RCOND   (input) DOUBLE PRECISION\n*          RCOND is used to determine the effective rank of A.\n*          Singular values S(i) <= RCOND*S(1) are treated as zero.\n*          If RCOND < 0, machine precision is used instead.\n*\n*  RANK    (output) INTEGER\n*          The effective rank of A, i.e., the number of singular values\n*          which are greater than RCOND*S(1).\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 must be at least 1.\n*          The exact minimum amount of workspace needed depends on M,\n*          N and NRHS. As long as LWORK is at least\n*              12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2,\n*          if M is greater than or equal to N or\n*              12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2,\n*          if M is less than N, the code will execute correctly.\n*          SMLSIZ is returned by ILAENV and is equal to the maximum\n*          size of the subproblems at the bottom of the computation\n*          tree (usually about 25), and\n*             NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )\n*          For good performance, LWORK should generally be larger.\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*  IWORK   (workspace) INTEGER array, dimension (MAX(1,LIWORK))\n*          LIWORK >= max(1, 3 * MINMN * NLVL + 11 * MINMN),\n*          where MINMN = MIN( M,N ).\n*          On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          > 0:  the algorithm for computing the SVD failed to converge;\n*                if INFO = i, i off-diagonal elements of an intermediate\n*                bidiagonal form did not converge to zero.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Ren-Cang Li, Computer Science Division, University of\n*       California at Berkeley, USA\n*     Osni Marques, LBNL/NERSC, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, rank, work, info, b = NumRu::Lapack.dgelsd( a, b, rcond, [: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_a = argv[0];
  rblapack_b = argv[1];
  rblapack_rcond = 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 (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*);
  rcond = NUM2DBL(rblapack_rcond);
  m = lda;
  c__9 = 9;
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th 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*);
  ldb = MAX(m,n);
  c__0 = 0;
  smlsiz = ilaenv_(&c__9,"DGELSD"," ",&c__0,&c__0,&c__0,&c__0);
  nlvl = MAX(0,((int)(log(((double)(MIN(m,n)))/(smlsiz+1))/log(2.0))+1));
  if (rblapack_lwork == Qnil)
    lwork = m>=n ? 12*n + 2*n*smlsiz + 8*n*nlvl + n*nrhs + (smlsiz+1)*(smlsiz+1) : 12*m + 2*m*smlsiz + 8*m*nlvl + m*nrhs + (smlsiz+1)*(smlsiz+1);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  liwork = 3*(MIN(m,n))*nlvl+11*(MIN(m,n));
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;
  iwork = ALLOC_N(integer, (MAX(1,liwork)));

  dgelsd_(&m, &n, &nrhs, a, &lda, b, &ldb, s, &rcond, &rank, work, &lwork, iwork, &info);

  free(iwork);
  rblapack_rank = INT2NUM(rank);
  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(5, rblapack_s, rblapack_rank, rblapack_work, rblapack_info, rblapack_b);
}

void
init_lapack_dgelsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgelsd", rblapack_dgelsd, -1);
}
ruby-lapack-1.7.2/ext/dsbgst.c0000644000175000017500000001464412502221024016020 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsbgst_(char* vect, char* uplo, integer* n, integer* ka, integer* kb, doublereal* ab, integer* ldab, doublereal* bb, integer* ldbb, doublereal* x, integer* ldx, doublereal* work, integer* info);


static VALUE
rblapack_dsbgst(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_vect;
  char vect; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ka;
  integer ka; 
  VALUE rblapack_kb;
  integer kb; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_bb;
  doublereal *bb; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublereal *ab_out__;
  doublereal *work;

  integer ldab;
  integer n;
  integer ldbb;
  integer ldx;

  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  x, info, ab = NumRu::Lapack.dsbgst( vect, uplo, ka, kb, ab, bb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, LDX, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSBGST reduces a real symmetric-definite banded generalized\n*  eigenproblem  A*x = lambda*B*x  to standard form  C*y = lambda*y,\n*  such that C has the same bandwidth as A.\n*\n*  B must have been previously factorized as S**T*S by DPBSTF, using a\n*  split Cholesky factorization. A is overwritten by C = X**T*A*X, where\n*  X = S**(-1)*Q and Q is an orthogonal matrix chosen to preserve the\n*  bandwidth of A.\n*\n\n*  Arguments\n*  =========\n*\n*  VECT    (input) CHARACTER*1\n*          = 'N':  do not form the transformation matrix X;\n*          = 'V':  form X.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  KA      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KA >= 0.\n*\n*  KB      (input) INTEGER\n*          The number of superdiagonals of the matrix B if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KA >= KB >= 0.\n*\n*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first ka+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).\n*\n*          On exit, the transformed matrix X**T*A*X, stored in the same\n*          format as A.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KA+1.\n*\n*  BB      (input) DOUBLE PRECISION array, dimension (LDBB,N)\n*          The banded factor S from the split Cholesky factorization of\n*          B, as returned by DPBSTF, stored in the first KB+1 rows of\n*          the array.\n*\n*  LDBB    (input) INTEGER\n*          The leading dimension of the array BB.  LDBB >= KB+1.\n*\n*  X       (output) DOUBLE PRECISION array, dimension (LDX,N)\n*          If VECT = 'V', the n-by-n matrix X.\n*          If VECT = 'N', the array X is not referenced.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.\n*          LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, info, ab = NumRu::Lapack.dsbgst( vect, uplo, ka, kb, ab, bb, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_vect = argv[0];
  rblapack_uplo = argv[1];
  rblapack_ka = argv[2];
  rblapack_kb = argv[3];
  rblapack_ab = argv[4];
  rblapack_bb = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  vect = StringValueCStr(rblapack_vect)[0];
  ka = NUM2INT(rblapack_ka);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_bb))
    rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
  if (NA_RANK(rblapack_bb) != 2)
    rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
  ldbb = NA_SHAPE0(rblapack_bb);
  if (NA_SHAPE1(rblapack_bb) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of bb must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_bb) != NA_DFLOAT)
    rblapack_bb = na_change_type(rblapack_bb, NA_DFLOAT);
  bb = NA_PTR_TYPE(rblapack_bb, doublereal*);
  kb = NUM2INT(rblapack_kb);
  ldx = lsame_(&vect,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = n;
    rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
  MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  work = ALLOC_N(doublereal, (2*n));

  dsbgst_(&vect, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, x, &ldx, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_x, rblapack_info, rblapack_ab);
}

void
init_lapack_dsbgst(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsbgst", rblapack_dsbgst, -1);
}
ruby-lapack-1.7.2/ext/sormbr.c0000644000175000017500000002201312502221022016021 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sormbr_(char* vect, char* side, char* trans, integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* c, integer* ldc, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sormbr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_vect;
  char vect; 
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  real *c_out__;

  integer lda;
  integer ldc;
  integer n;
  integer nq;

  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, c = NumRu::Lapack.sormbr( vect, side, trans, m, k, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  If VECT = 'Q', SORMBR overwrites the general real M-by-N matrix C\n*  with\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'T':      Q**T * C       C * Q**T\n*\n*  If VECT = 'P', SORMBR overwrites the general real M-by-N matrix C\n*  with\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      P * C          C * P\n*  TRANS = 'T':      P**T * C       C * P**T\n*\n*  Here Q and P**T are the orthogonal matrices determined by SGEBRD when\n*  reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and\n*  P**T are defined as products of elementary reflectors H(i) and G(i)\n*  respectively.\n*\n*  Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the\n*  order of the orthogonal matrix Q or P**T that is applied.\n*\n*  If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:\n*  if nq >= k, Q = H(1) H(2) . . . H(k);\n*  if nq < k, Q = H(1) H(2) . . . H(nq-1).\n*\n*  If VECT = 'P', A is assumed to have been a K-by-NQ matrix:\n*  if k < nq, P = G(1) G(2) . . . G(k);\n*  if k >= nq, P = G(1) G(2) . . . G(nq-1).\n*\n\n*  Arguments\n*  =========\n*\n*  VECT    (input) CHARACTER*1\n*          = 'Q': apply Q or Q**T;\n*          = 'P': apply P or P**T.\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q, Q**T, P or P**T from the Left;\n*          = 'R': apply Q, Q**T, P or P**T from the Right.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q  or P;\n*          = 'T':  Transpose, apply Q**T or P**T.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          If VECT = 'Q', the number of columns in the original\n*          matrix reduced by SGEBRD.\n*          If VECT = 'P', the number of rows in the original\n*          matrix reduced by SGEBRD.\n*          K >= 0.\n*\n*  A       (input) REAL array, dimension\n*                                (LDA,min(nq,K)) if VECT = 'Q'\n*                                (LDA,nq)        if VECT = 'P'\n*          The vectors which define the elementary reflectors H(i) and\n*          G(i), whose products determine the matrices Q and P, as\n*          returned by SGEBRD.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*          If VECT = 'Q', LDA >= max(1,nq);\n*          if VECT = 'P', LDA >= max(1,min(nq,K)).\n*\n*  TAU     (input) REAL array, dimension (min(nq,K))\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i) or G(i) which determines Q or P, as returned\n*          by SGEBRD in the array argument TAUQ or TAUP.\n*\n*  C       (input/output) REAL array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q\n*          or P*C or P**T*C or C*P or C*P**T.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace/output) REAL 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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M).\n*          For optimum performance LWORK >= N*NB if SIDE = 'L', and\n*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n*          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*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            APPLYQ, LEFT, LQUERY, NOTRAN\n      CHARACTER          TRANST\n      INTEGER            I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            ILAENV\n      EXTERNAL           ILAENV, LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SORMLQ, SORMQR, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.sormbr( vect, side, trans, m, k, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_vect = argv[0];
  rblapack_side = argv[1];
  rblapack_trans = argv[2];
  rblapack_m = argv[3];
  rblapack_k = argv[4];
  rblapack_a = argv[5];
  rblapack_tau = argv[6];
  rblapack_c = argv[7];
  if (argc == 9) {
    rblapack_lwork = argv[8];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  vect = StringValueCStr(rblapack_vect)[0];
  trans = StringValueCStr(rblapack_trans)[0];
  k = NUM2INT(rblapack_k);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (8th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  side = StringValueCStr(rblapack_side)[0];
  m = NUM2INT(rblapack_m);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  nq = lsame_(&side,"L") ? m : lsame_(&side,"R") ? n : 0;
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (6th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (6th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != (MIN(nq,k)))
    rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", MIN(nq,k));
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (7th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_tau) != (MIN(nq,k)))
    rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", MIN(nq,k));
  if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  sormbr_(&vect, &side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_sormbr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sormbr", rblapack_sormbr, -1);
}
ruby-lapack-1.7.2/ext/spstrf.c0000644000175000017500000001246612502221014016052 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID spstrf_(char* uplo, integer* n, real* a, integer* lda, integer* piv, integer* rank, real* tol, real* work, integer* info);


static VALUE
rblapack_spstrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tol;
  real tol; 
  VALUE rblapack_piv;
  integer *piv; 
  VALUE rblapack_rank;
  integer rank; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  real *work;

  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  piv, rank, info, a = NumRu::Lapack.spstrf( uplo, a, tol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPSTRF computes the Cholesky factorization with complete\n*  pivoting of a real symmetric positive semidefinite matrix A.\n*\n*  The factorization has the form\n*     P' * A * P = U' * U ,  if UPLO = 'U',\n*     P' * A * P = L  * L',  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is lower triangular, and\n*  P is stored as vector PIV.\n*\n*  This algorithm does not attempt to check that A is positive\n*  semidefinite. This version of the algorithm calls level 3 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          n by n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n by n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the factor U or L from the Cholesky\n*          factorization as above.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  PIV     (output) INTEGER array, dimension (N)\n*          PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n*\n*  RANK    (output) INTEGER\n*          The rank of A given by the number of steps the algorithm\n*          completed.\n*\n*  TOL     (input) REAL\n*          User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) )\n*          will be used. The algorithm terminates at the (K-1)st step\n*          if the pivot <= TOL.\n*\n*  WORK    (workspace) REAL array, dimension (2*N)\n*          Work space.\n*\n*  INFO    (output) INTEGER\n*          < 0: If INFO = -K, the K-th argument had an illegal value,\n*          = 0: algorithm completed successfully, and\n*          > 0: the matrix A is either rank deficient with computed rank\n*               as returned in RANK, or is indefinite.  See Section 7 of\n*               LAPACK Working Note #161 for further information.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  piv, rank, info, a = NumRu::Lapack.spstrf( uplo, a, tol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_tol = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  tol = (real)NUM2DBL(rblapack_tol);
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_piv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  piv = NA_PTR_TYPE(rblapack_piv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(real, (2*n));

  spstrf_(&uplo, &n, a, &lda, piv, &rank, &tol, work, &info);

  free(work);
  rblapack_rank = INT2NUM(rank);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_piv, rblapack_rank, rblapack_info, rblapack_a);
}

void
init_lapack_spstrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "spstrf", rblapack_spstrf, -1);
}
ruby-lapack-1.7.2/ext/cupgtr.c0000644000175000017500000001026112502221014016024 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cupgtr_(char* uplo, integer* n, complex* ap, complex* tau, complex* q, integer* ldq, complex* work, integer* info);


static VALUE
rblapack_cupgtr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_q;
  complex *q; 
  VALUE rblapack_info;
  integer info; 
  complex *work;

  integer ldap;
  integer ldtau;
  integer ldq;
  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  q, info = NumRu::Lapack.cupgtr( uplo, ap, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CUPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CUPGTR generates a complex unitary matrix Q which is defined as the\n*  product of n-1 elementary reflectors H(i) of order n, as returned by\n*  CHPTRD using packed storage:\n*\n*  if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),\n*\n*  if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U': Upper triangular packed storage used in previous\n*                 call to CHPTRD;\n*          = 'L': Lower triangular packed storage used in previous\n*                 call to CHPTRD.\n*\n*  N       (input) INTEGER\n*          The order of the matrix Q. N >= 0.\n*\n*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)\n*          The vectors which define the elementary reflectors, as\n*          returned by CHPTRD.\n*\n*  TAU     (input) COMPLEX array, dimension (N-1)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by CHPTRD.\n*\n*  Q       (output) COMPLEX array, dimension (LDQ,N)\n*          The N-by-N unitary matrix Q.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q. LDQ >= max(1,N).\n*\n*  WORK    (workspace) COMPLEX array, dimension (N-1)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  q, info = NumRu::Lapack.cupgtr( uplo, ap, tau, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_tau = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  ldtau = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  n = ldtau+1;
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  ldq = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  q = NA_PTR_TYPE(rblapack_q, complex*);
  work = ALLOC_N(complex, (n-1));

  cupgtr_(&uplo, &n, ap, tau, q, &ldq, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_q, rblapack_info);
}

void
init_lapack_cupgtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cupgtr", rblapack_cupgtr, -1);
}
ruby-lapack-1.7.2/ext/dgeqpf.c0000644000175000017500000001355112502221024015774 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgeqpf_(integer* m, integer* n, doublereal* a, integer* lda, integer* jpvt, doublereal* tau, doublereal* work, integer* info);


static VALUE
rblapack_dgeqpf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_jpvt;
  integer *jpvt; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  VALUE rblapack_jpvt_out__;
  integer *jpvt_out__;
  doublereal *work;

  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, info, a, jpvt = NumRu::Lapack.dgeqpf( m, a, jpvt, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  This routine is deprecated and has been replaced by routine DGEQP3.\n*\n*  DGEQPF computes a QR factorization with column pivoting of a\n*  real M-by-N matrix A: A*P = Q*R.\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 upper triangle of the array contains the\n*          min(M,N)-by-N upper triangular matrix R; the elements\n*          below the diagonal, together with the array TAU,\n*          represent the orthogonal matrix Q as a product of\n*          min(m,n) elementary reflectors.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  JPVT    (input/output) INTEGER array, dimension (N)\n*          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n*          to the front of A*P (a leading column); if JPVT(i) = 0,\n*          the i-th column of A is a free column.\n*          On exit, if JPVT(i) = k, then the i-th column of A*P\n*          was the k-th column of A.\n*\n*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)\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(1) H(2) . . . H(n)\n*\n*  Each H(i) has the form\n*\n*     H = 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:m) is stored on exit in A(i+1:m,i).\n*\n*  The matrix P is represented in jpvt as follows: If\n*     jpvt(j) = i\n*  then the jth column of P is the ith canonical unit vector.\n*\n*  Partial column norm updating strategy modified by\n*    Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n*    University of Zagreb, Croatia.\n*     June 2010\n*  For more details see LAPACK Working Note 176.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, info, a, jpvt = NumRu::Lapack.dgeqpf( m, a, jpvt, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  rblapack_jpvt = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_jpvt))
    rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
  if (NA_RANK(rblapack_jpvt) != 1)
    rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_jpvt);
  if (NA_TYPE(rblapack_jpvt) != NA_LINT)
    rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
  jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of jpvt");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
  MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
  rblapack_jpvt = rblapack_jpvt_out__;
  jpvt = jpvt_out__;
  work = ALLOC_N(doublereal, (3*n));

  dgeqpf_(&m, &n, a, &lda, jpvt, tau, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_tau, rblapack_info, rblapack_a, rblapack_jpvt);
}

void
init_lapack_dgeqpf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgeqpf", rblapack_dgeqpf, -1);
}
ruby-lapack-1.7.2/ext/dlaed5.c0000644000175000017500000001015412502221021015655 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaed5_(integer* i, doublereal* d, doublereal* z, doublereal* delta, doublereal* rho, doublereal* dlam);


static VALUE
rblapack_dlaed5(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_i;
  integer i; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_rho;
  doublereal rho; 
  VALUE rblapack_delta;
  doublereal *delta; 
  VALUE rblapack_dlam;
  doublereal dlam; 


  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  delta, dlam = NumRu::Lapack.dlaed5( i, d, z, rho, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM )\n\n*  Purpose\n*  =======\n*\n*  This subroutine computes the I-th eigenvalue of a symmetric rank-one\n*  modification of a 2-by-2 diagonal matrix\n*\n*             diag( D )  +  RHO *  Z * transpose(Z) .\n*\n*  The diagonal elements in the array D are assumed to satisfy\n*\n*             D(i) < D(j)  for  i < j .\n*\n*  We also assume RHO > 0 and that the Euclidean norm of the vector\n*  Z is one.\n*\n\n*  Arguments\n*  =========\n*\n*  I      (input) INTEGER\n*         The index of the eigenvalue to be computed.  I = 1 or I = 2.\n*\n*  D      (input) DOUBLE PRECISION array, dimension (2)\n*         The original eigenvalues.  We assume D(1) < D(2).\n*\n*  Z      (input) DOUBLE PRECISION array, dimension (2)\n*         The components of the updating vector.\n*\n*  DELTA  (output) DOUBLE PRECISION array, dimension (2)\n*         The vector DELTA contains the information necessary\n*         to construct the eigenvectors.\n*\n*  RHO    (input) DOUBLE PRECISION\n*         The scalar in the symmetric updating formula.\n*\n*  DLAM   (output) DOUBLE PRECISION\n*         The computed lambda_I, the I-th updated eigenvalue.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ren-Cang Li, Computer Science Division, University of California\n*     at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  delta, dlam = NumRu::Lapack.dlaed5( i, d, z, rho, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_i = argv[0];
  rblapack_d = argv[1];
  rblapack_z = argv[2];
  rblapack_rho = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  i = NUM2INT(rblapack_i);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (3th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != (2))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 2);
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != (2))
    rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", 2);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  rho = NUM2DBL(rblapack_rho);
  {
    na_shape_t shape[1];
    shape[0] = 2;
    rblapack_delta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  delta = NA_PTR_TYPE(rblapack_delta, doublereal*);

  dlaed5_(&i, d, z, delta, &rho, &dlam);

  rblapack_dlam = rb_float_new((double)dlam);
  return rb_ary_new3(2, rblapack_delta, rblapack_dlam);
}

void
init_lapack_dlaed5(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaed5", rblapack_dlaed5, -1);
}
ruby-lapack-1.7.2/ext/sgeequ.c0000644000175000017500000001167312502221012016017 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgeequ_(integer* m, integer* n, real* a, integer* lda, real* r, real* c, real* rowcnd, real* colcnd, real* amax, integer* info);


static VALUE
rblapack_sgeequ(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_r;
  real *r; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_rowcnd;
  real rowcnd; 
  VALUE rblapack_colcnd;
  real colcnd; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_info;
  integer info; 

  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  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.sgeequ( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGEEQU computes row and column scalings intended to equilibrate an\n*  M-by-N matrix A and reduce its condition number.  R returns the row\n*  scale factors and C the column scale factors, chosen to try to make\n*  the largest element in each row and column of the matrix B with\n*  elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n*\n*  R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n*  number and BIGNUM = largest safe number.  Use of these scaling\n*  factors is not guaranteed to reduce the condition number of A but\n*  works well in practice.\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) REAL array, dimension (LDA,N)\n*          The M-by-N matrix whose equilibration factors are\n*          to be computed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  R       (output) REAL array, dimension (M)\n*          If INFO = 0 or INFO > M, R contains the row scale factors\n*          for A.\n*\n*  C       (output) REAL array, dimension (N)\n*          If INFO = 0,  C contains the column scale factors for A.\n*\n*  ROWCND  (output) REAL\n*          If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n*          smallest R(i) to the largest R(i).  If ROWCND >= 0.1 and\n*          AMAX is neither too large nor too small, it is not worth\n*          scaling by R.\n*\n*  COLCND  (output) REAL\n*          If INFO = 0, COLCND contains the ratio of the smallest\n*          C(i) to the largest C(i).  If COLCND >= 0.1, it is not\n*          worth scaling by C.\n*\n*  AMAX    (output) REAL\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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,  and i is\n*                <= M:  the i-th row of A is exactly zero\n*                >  M:  the (i-M)-th column of A is exactly zero\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.sgeequ( 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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  m = lda;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_r = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  r = NA_PTR_TYPE(rblapack_r, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  c = NA_PTR_TYPE(rblapack_c, real*);

  sgeequ_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &info);

  rblapack_rowcnd = rb_float_new((double)rowcnd);
  rblapack_colcnd = rb_float_new((double)colcnd);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
}

void
init_lapack_sgeequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgeequ", rblapack_sgeequ, -1);
}
ruby-lapack-1.7.2/ext/slaqgb.c0000644000175000017500000001457012502221021015776 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaqgb_(integer* m, integer* n, integer* kl, integer* ku, real* ab, integer* ldab, real* r, real* c, real* rowcnd, real* colcnd, real* amax, char* equed);


static VALUE
rblapack_slaqgb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_r;
  real *r; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_rowcnd;
  real rowcnd; 
  VALUE rblapack_colcnd;
  real colcnd; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_ab_out__;
  real *ab_out__;

  integer ldab;
  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  equed, ab = NumRu::Lapack.slaqgb( kl, ku, ab, r, c, rowcnd, colcnd, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n*  Purpose\n*  =======\n*\n*  SLAQGB equilibrates a general M by N band matrix A with KL\n*  subdiagonals and KU superdiagonals using the row and scaling factors\n*  in the vectors R and C.\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*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  AB      (input/output) REAL array, dimension (LDAB,N)\n*          On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n*          The j-th column of A is stored in the j-th column of the\n*          array AB as follows:\n*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n*          On exit, the equilibrated matrix, in the same storage format\n*          as A.  See EQUED for the form of the equilibrated matrix.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDA >= KL+KU+1.\n*\n*  R       (input) REAL array, dimension (M)\n*          The row scale factors for A.\n*\n*  C       (input) REAL array, dimension (N)\n*          The column scale factors for A.\n*\n*  ROWCND  (input) REAL\n*          Ratio of the smallest R(i) to the largest R(i).\n*\n*  COLCND  (input) REAL\n*          Ratio of the smallest C(i) to the largest C(i).\n*\n*  AMAX    (input) REAL\n*          Absolute value of largest matrix entry.\n*\n*  EQUED   (output) CHARACTER*1\n*          Specifies the form of equilibration that was done.\n*          = 'N':  No equilibration\n*          = 'R':  Row equilibration, i.e., A has been premultiplied by\n*                  diag(R).\n*          = 'C':  Column equilibration, i.e., A has been postmultiplied\n*                  by diag(C).\n*          = 'B':  Both row and column equilibration, i.e., A has been\n*                  replaced by diag(R) * A * diag(C).\n*\n*  Internal Parameters\n*  ===================\n*\n*  THRESH is a threshold value used to decide if row or column scaling\n*  should be done based on the ratio of the row or column scaling\n*  factors.  If ROWCND < THRESH, row scaling is done, and if\n*  COLCND < THRESH, column scaling is done.\n*\n*  LARGE and SMALL are threshold values used to decide if row scaling\n*  should be done based on the absolute size of the largest matrix\n*  element.  If AMAX > LARGE or AMAX < SMALL, row scaling is done.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  equed, ab = NumRu::Lapack.slaqgb( kl, ku, ab, r, c, rowcnd, colcnd, amax, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_kl = argv[0];
  rblapack_ku = argv[1];
  rblapack_ab = argv[2];
  rblapack_r = argv[3];
  rblapack_c = argv[4];
  rblapack_rowcnd = argv[5];
  rblapack_colcnd = argv[6];
  rblapack_amax = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  colcnd = (real)NUM2DBL(rblapack_colcnd);
  ku = NUM2INT(rblapack_ku);
  rowcnd = (real)NUM2DBL(rblapack_rowcnd);
  if (!NA_IsNArray(rblapack_r))
    rb_raise(rb_eArgError, "r (4th argument) must be NArray");
  if (NA_RANK(rblapack_r) != 1)
    rb_raise(rb_eArgError, "rank of r (4th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_r);
  if (NA_TYPE(rblapack_r) != NA_SFLOAT)
    rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
  r = NA_PTR_TYPE(rblapack_r, real*);
  amax = (real)NUM2DBL(rblapack_amax);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
  MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  slaqgb_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &equed);

  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(2, rblapack_equed, rblapack_ab);
}

void
init_lapack_slaqgb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaqgb", rblapack_slaqgb, -1);
}
ruby-lapack-1.7.2/ext/cungbr.c0000644000175000017500000001550212502221015016004 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cungbr_(char* vect, integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_cungbr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_vect;
  char vect; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *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  work, info, a = NumRu::Lapack.cungbr( vect, m, k, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CUNGBR generates one of the complex unitary matrices Q or P**H\n*  determined by CGEBRD when reducing a complex matrix A to bidiagonal\n*  form: A = Q * B * P**H.  Q and P**H are defined as products of\n*  elementary reflectors H(i) or G(i) respectively.\n*\n*  If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q\n*  is of order M:\n*  if m >= k, Q = H(1) H(2) . . . H(k) and CUNGBR returns the first n\n*  columns of Q, where m >= n >= k;\n*  if m < k, Q = H(1) H(2) . . . H(m-1) and CUNGBR returns Q as an\n*  M-by-M matrix.\n*\n*  If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**H\n*  is of order N:\n*  if k < n, P**H = G(k) . . . G(2) G(1) and CUNGBR returns the first m\n*  rows of P**H, where n >= m >= k;\n*  if k >= n, P**H = G(n-1) . . . G(2) G(1) and CUNGBR returns P**H as\n*  an N-by-N matrix.\n*\n\n*  Arguments\n*  =========\n*\n*  VECT    (input) CHARACTER*1\n*          Specifies whether the matrix Q or the matrix P**H is\n*          required, as defined in the transformation applied by CGEBRD:\n*          = 'Q':  generate Q;\n*          = 'P':  generate P**H.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q or P**H to be returned.\n*          M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q or P**H to be returned.\n*          N >= 0.\n*          If VECT = 'Q', M >= N >= min(M,K);\n*          if VECT = 'P', N >= M >= min(N,K).\n*\n*  K       (input) INTEGER\n*          If VECT = 'Q', the number of columns in the original M-by-K\n*          matrix reduced by CGEBRD.\n*          If VECT = 'P', the number of rows in the original K-by-N\n*          matrix reduced by CGEBRD.\n*          K >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the vectors which define the elementary reflectors,\n*          as returned by CGEBRD.\n*          On exit, the M-by-N matrix Q or P**H.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= M.\n*\n*  TAU     (input) COMPLEX array, dimension\n*                                (min(M,K)) if VECT = 'Q'\n*                                (min(N,K)) if VECT = 'P'\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i) or G(i), which determines Q or P**H, as\n*          returned by CGEBRD in its array argument TAUQ or TAUP.\n*\n*  WORK    (workspace/output) COMPLEX 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,min(M,N)).\n*          For optimum performance LWORK >= min(M,N)*NB, where NB\n*          is the 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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, a = NumRu::Lapack.cungbr( vect, m, k, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_vect = argv[0];
  rblapack_m = argv[1];
  rblapack_k = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  if (argc == 6) {
    rblapack_lwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  vect = StringValueCStr(rblapack_vect)[0];
  k = NUM2INT(rblapack_k);
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_tau) != (MIN(m,k)))
    rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", MIN(m,k));
  if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (rblapack_lwork == Qnil)
    lwork = MIN(m,n);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  cungbr_(&vect, &m, &n, &k, a, &lda, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_cungbr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cungbr", rblapack_cungbr, -1);
}
ruby-lapack-1.7.2/ext/clatrd.c0000644000175000017500000001747312502221017016010 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clatrd_(char* uplo, integer* n, integer* nb, complex* a, integer* lda, real* e, complex* tau, complex* w, integer* ldw);


static VALUE
rblapack_clatrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_nb;
  integer nb; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_w;
  complex *w; 
  VALUE rblapack_a_out__;
  complex *a_out__;

  integer lda;
  integer n;
  integer ldw;

  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  e, tau, w, a = NumRu::Lapack.clatrd( uplo, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )\n\n*  Purpose\n*  =======\n*\n*  CLATRD reduces NB rows and columns of a complex Hermitian matrix A to\n*  Hermitian tridiagonal form by a unitary similarity\n*  transformation Q' * A * Q, and returns the matrices V and W which are\n*  needed to apply the transformation to the unreduced part of A.\n*\n*  If UPLO = 'U', CLATRD reduces the last NB rows and columns of a\n*  matrix, of which the upper triangle is supplied;\n*  if UPLO = 'L', CLATRD reduces the first NB rows and columns of a\n*  matrix, of which the lower triangle is supplied.\n*\n*  This is an auxiliary routine called by CHETRD.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          Hermitian matrix A is stored:\n*          = 'U': Upper triangular\n*          = 'L': Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.\n*\n*  NB      (input) INTEGER\n*          The number of rows and columns to be reduced.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading\n*          n-by-n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n-by-n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*          On exit:\n*          if UPLO = 'U', the last NB columns have been reduced to\n*            tridiagonal form, with the diagonal elements overwriting\n*            the diagonal elements of A; the elements above the diagonal\n*            with the array TAU, represent the unitary matrix Q as a\n*            product of elementary reflectors;\n*          if UPLO = 'L', the first NB columns have been reduced to\n*            tridiagonal form, with the diagonal elements overwriting\n*            the diagonal elements of A; the elements below the diagonal\n*            with the array TAU, represent the  unitary matrix Q as a\n*            product of elementary reflectors.\n*          See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  E       (output) REAL array, dimension (N-1)\n*          If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal\n*          elements of the last NB columns of the reduced matrix;\n*          if UPLO = 'L', E(1:nb) contains the subdiagonal elements of\n*          the first NB columns of the reduced matrix.\n*\n*  TAU     (output) COMPLEX array, dimension (N-1)\n*          The scalar factors of the elementary reflectors, stored in\n*          TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.\n*          See Further Details.\n*\n*  W       (output) COMPLEX array, dimension (LDW,NB)\n*          The n-by-nb matrix W required to update the unreduced part\n*          of A.\n*\n*  LDW     (input) INTEGER\n*          The leading dimension of the array W. LDW >= max(1,N).\n*\n\n*  Further Details\n*  ===============\n*\n*  If UPLO = 'U', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(n) H(n-1) . . . H(n-nb+1).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - tau * v * v'\n*\n*  where tau is a complex scalar, and v is a complex vector with\n*  v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),\n*  and tau in TAU(i-1).\n*\n*  If UPLO = 'L', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(1) H(2) . . . H(nb).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - tau * v * v'\n*\n*  where tau is a complex scalar, and v is a complex vector with\n*  v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),\n*  and tau in TAU(i).\n*\n*  The elements of the vectors v together form the n-by-nb matrix V\n*  which is needed, with W, to apply the transformation to the unreduced\n*  part of the matrix, using a Hermitian rank-2k update of the form:\n*  A := A - V*W' - W*V'.\n*\n*  The contents of A on exit are illustrated by the following examples\n*  with n = 5 and nb = 2:\n*\n*  if UPLO = 'U':                       if UPLO = 'L':\n*\n*    (  a   a   a   v4  v5 )              (  d                  )\n*    (      a   a   v4  v5 )              (  1   d              )\n*    (          a   1   v5 )              (  v1  1   a          )\n*    (              d   1  )              (  v1  v2  a   a      )\n*    (                  d  )              (  v1  v2  a   a   a  )\n*\n*  where d denotes a diagonal element of the reduced matrix, a denotes\n*  an element of the original matrix that is unchanged, and vi denotes\n*  an element of the vector defining H(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  e, tau, w, a = NumRu::Lapack.clatrd( uplo, nb, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_nb = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  nb = NUM2INT(rblapack_nb);
  ldw = MAX(1,n);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldw;
    shape[1] = MAX(n,nb);
    rblapack_w = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  clatrd_(&uplo, &n, &nb, a, &lda, e, tau, w, &ldw);

  return rb_ary_new3(4, rblapack_e, rblapack_tau, rblapack_w, rblapack_a);
}

void
init_lapack_clatrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clatrd", rblapack_clatrd, -1);
}
ruby-lapack-1.7.2/ext/ctgex2.c0000644000175000017500000002244512502221024015724 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctgex2_(logical* wantq, logical* wantz, integer* n, complex* a, integer* lda, complex* b, integer* ldb, complex* q, integer* ldq, complex* z, integer* ldz, integer* j1, integer* info);


static VALUE
rblapack_ctgex2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantq;
  logical wantq; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_q;
  complex *q; 
  VALUE rblapack_ldq;
  integer ldq; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_ldz;
  integer ldz; 
  VALUE rblapack_j1;
  integer j1; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;
  VALUE rblapack_q_out__;
  complex *q_out__;
  VALUE rblapack_z_out__;
  complex *z_out__;

  integer lda;
  integer n;
  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  info, a, b, q, z = NumRu::Lapack.ctgex2( wantq, wantz, a, b, q, ldq, z, ldz, j1, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, J1, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTGEX2 swaps adjacent diagonal 1 by 1 blocks (A11,B11) and (A22,B22)\n*  in an upper triangular matrix pair (A, B) by an unitary equivalence\n*  transformation.\n*\n*  (A, B) must be in generalized Schur canonical form, that is, A and\n*  B are both upper triangular.\n*\n*  Optionally, the matrices Q and Z of generalized Schur vectors are\n*  updated.\n*\n*         Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n*         Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n*\n*\n\n*  Arguments\n*  =========\n*\n*  WANTQ   (input) LOGICAL\n*          .TRUE. : update the left transformation matrix Q;\n*          .FALSE.: do not update Q.\n*\n*  WANTZ   (input) LOGICAL\n*          .TRUE. : update the right transformation matrix Z;\n*          .FALSE.: do not update Z.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B. N >= 0.\n*\n*  A       (input/output) COMPLEX arrays, dimensions (LDA,N)\n*          On entry, the matrix A in the pair (A, B).\n*          On exit, the updated matrix A.\n*\n*  LDA     (input)  INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX arrays, dimensions (LDB,N)\n*          On entry, the matrix B in the pair (A, B).\n*          On exit, the updated matrix B.\n*\n*  LDB     (input)  INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  Q       (input/output) COMPLEX array, dimension (LDZ,N)\n*          If WANTQ = .TRUE, on entry, the unitary matrix Q. On exit,\n*          the updated matrix Q.\n*          Not referenced if WANTQ = .FALSE..\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q. LDQ >= 1;\n*          If WANTQ = .TRUE., LDQ >= N.\n*\n*  Z       (input/output) COMPLEX array, dimension (LDZ,N)\n*          If WANTZ = .TRUE, on entry, the unitary matrix Z. On exit,\n*          the updated matrix Z.\n*          Not referenced if WANTZ = .FALSE..\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z. LDZ >= 1;\n*          If WANTZ = .TRUE., LDZ >= N.\n*\n*  J1      (input) INTEGER\n*          The index to the first block (A11, B11).\n*\n*  INFO    (output) INTEGER\n*           =0:  Successful exit.\n*           =1:  The transformed matrix pair (A, B) would be too far\n*                from generalized Schur form; the problem is ill-\n*                conditioned.\n*\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  In the current code both weak and strong stability tests are\n*  performed. The user can omit the strong stability test by changing\n*  the internal logical parameter WANDS to .FALSE.. See ref. [2] for\n*  details.\n*\n*  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n*      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n*      M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n*      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n*  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n*      Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n*      Estimation: Theory, Algorithms and Software, Report UMINF-94.04,\n*      Department of Computing Science, Umea University, S-901 87 Umea,\n*      Sweden, 1994. Also as LAPACK Working Note 87. To appear in\n*      Numerical Algorithms, 1996.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a, b, q, z = NumRu::Lapack.ctgex2( wantq, wantz, a, b, q, ldq, z, ldz, j1, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_wantq = argv[0];
  rblapack_wantz = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  rblapack_q = argv[4];
  rblapack_ldq = argv[5];
  rblapack_z = argv[6];
  rblapack_ldz = argv[7];
  rblapack_j1 = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  wantq = (rblapack_wantq == Qtrue);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  ldq = NUM2INT(rblapack_ldq);
  ldz = NUM2INT(rblapack_ldz);
  wantz = (rblapack_wantz == Qtrue);
  j1 = NUM2INT(rblapack_j1);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (7th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_z) != (wantq ? ldz : 0))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantq ? ldz : 0);
  if (NA_SHAPE1(rblapack_z) != (wantq ? n : 0))
    rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantq ? n : 0);
  if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, complex*);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (5th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_q) != (wantq ? ldq : 0))
    rb_raise(rb_eRuntimeError, "shape 0 of q must be %d", wantq ? ldq : 0);
  if (NA_SHAPE1(rblapack_q) != (wantq ? n : 0))
    rb_raise(rb_eRuntimeError, "shape 1 of q must be %d", wantq ? n : 0);
  if (NA_TYPE(rblapack_q) != NA_SCOMPLEX)
    rblapack_q = na_change_type(rblapack_q, NA_SCOMPLEX);
  q = NA_PTR_TYPE(rblapack_q, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[2];
    shape[0] = wantq ? ldq : 0;
    shape[1] = wantq ? n : 0;
    rblapack_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, complex*);
  MEMCPY(q_out__, q, complex, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  {
    na_shape_t shape[2];
    shape[0] = wantq ? ldz : 0;
    shape[1] = wantq ? n : 0;
    rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
  MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  ctgex2_(&wantq, &wantz, &n, a, &lda, b, &ldb, q, &ldq, z, &ldz, &j1, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z);
}

void
init_lapack_ctgex2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctgex2", rblapack_ctgex2, -1);
}
ruby-lapack-1.7.2/ext/cpotri.c0000644000175000017500000000733512502221015016031 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cpotri_(char* uplo, integer* n, complex* a, integer* lda, integer* info);


static VALUE
rblapack_cpotri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *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  info, a = NumRu::Lapack.cpotri( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPOTRI( UPLO, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPOTRI computes the inverse of a complex Hermitian positive definite\n*  matrix A using the Cholesky factorization A = U**H*U or A = L*L**H\n*  computed by CPOTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the triangular factor U or L from the Cholesky\n*          factorization A = U**H*U or A = L*L**H, as computed by\n*          CPOTRF.\n*          On exit, the upper or lower triangle of the (Hermitian)\n*          inverse of A, overwriting the input factor U or L.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\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,i) element of the factor U or L is\n*                zero, and the inverse could not be computed.\n*\n\n*  =====================================================================\n*\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CLAUUM, CTRTRI, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.cpotri( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  cpotri_(&uplo, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_cpotri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cpotri", rblapack_cpotri, -1);
}
ruby-lapack-1.7.2/ext/slagtf.c0000644000175000017500000001727212502221013016010 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slagtf_(integer* n, real* a, real* lambda, real* b, real* c, real* tol, real* d, integer* in, integer* info);


static VALUE
rblapack_slagtf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_lambda;
  real lambda; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_tol;
  real tol; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_in;
  integer *in; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_b_out__;
  real *b_out__;
  VALUE rblapack_c_out__;
  real *c_out__;

  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  d, in, info, a, b, c = NumRu::Lapack.slagtf( a, lambda, b, c, tol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLAGTF factorizes the matrix (T - lambda*I), where T is an n by n\n*  tridiagonal matrix and lambda is a scalar, as\n*\n*     T - lambda*I = PLU,\n*\n*  where P is a permutation matrix, L is a unit lower tridiagonal matrix\n*  with at most one non-zero sub-diagonal elements per column and U is\n*  an upper triangular matrix with at most two non-zero super-diagonal\n*  elements per column.\n*\n*  The factorization is obtained by Gaussian elimination with partial\n*  pivoting and implicit row scaling.\n*\n*  The parameter LAMBDA is included in the routine so that SLAGTF may\n*  be used, in conjunction with SLAGTS, to obtain eigenvectors of T by\n*  inverse iteration.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix T.\n*\n*  A       (input/output) REAL array, dimension (N)\n*          On entry, A must contain the diagonal elements of T.\n*\n*          On exit, A is overwritten by the n diagonal elements of the\n*          upper triangular matrix U of the factorization of T.\n*\n*  LAMBDA  (input) REAL\n*          On entry, the scalar lambda.\n*\n*  B       (input/output) REAL array, dimension (N-1)\n*          On entry, B must contain the (n-1) super-diagonal elements of\n*          T.\n*\n*          On exit, B is overwritten by the (n-1) super-diagonal\n*          elements of the matrix U of the factorization of T.\n*\n*  C       (input/output) REAL array, dimension (N-1)\n*          On entry, C must contain the (n-1) sub-diagonal elements of\n*          T.\n*\n*          On exit, C is overwritten by the (n-1) sub-diagonal elements\n*          of the matrix L of the factorization of T.\n*\n*  TOL     (input) REAL\n*          On entry, a relative tolerance used to indicate whether or\n*          not the matrix (T - lambda*I) is nearly singular. TOL should\n*          normally be chose as approximately the largest relative error\n*          in the elements of T. For example, if the elements of T are\n*          correct to about 4 significant figures, then TOL should be\n*          set to about 5*10**(-4). If TOL is supplied as less than eps,\n*          where eps is the relative machine precision, then the value\n*          eps is used in place of TOL.\n*\n*  D       (output) REAL array, dimension (N-2)\n*          On exit, D is overwritten by the (n-2) second super-diagonal\n*          elements of the matrix U of the factorization of T.\n*\n*  IN      (output) INTEGER array, dimension (N)\n*          On exit, IN contains details of the permutation matrix P. If\n*          an interchange occurred at the kth step of the elimination,\n*          then IN(k) = 1, otherwise IN(k) = 0. The element IN(n)\n*          returns the smallest positive integer j such that\n*\n*             abs( u(j,j) ).le. norm( (T - lambda*I)(j) )*TOL,\n*\n*          where norm( A(j) ) denotes the sum of the absolute values of\n*          the jth row of the matrix A. If no such j exists then IN(n)\n*          is returned as zero. If IN(n) is returned as positive, then a\n*          diagonal element of U is small, indicating that\n*          (T - lambda*I) is singular or nearly singular,\n*\n*  INFO    (output) INTEGER\n*          = 0   : successful exit\n*          .lt. 0: if INFO = -k, the kth argument had an illegal value\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, in, info, a, b, c = NumRu::Lapack.slagtf( a, lambda, b, c, tol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_a = argv[0];
  rblapack_lambda = argv[1];
  rblapack_b = argv[2];
  rblapack_c = argv[3];
  rblapack_tol = argv[4];
  if (argc == 5) {
  } 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) != 1)
    rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (3th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 1)
    rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_b) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of b must be %d", n-1);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  tol = (real)NUM2DBL(rblapack_tol);
  lambda = (real)NUM2DBL(rblapack_lambda);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (4th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", n-1);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  {
    na_shape_t shape[1];
    shape[0] = n-2;
    rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_in = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  in = NA_PTR_TYPE(rblapack_in, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  slagtf_(&n, a, &lambda, b, c, &tol, d, in, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_d, rblapack_in, rblapack_info, rblapack_a, rblapack_b, rblapack_c);
}

void
init_lapack_slagtf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slagtf", rblapack_slagtf, -1);
}
ruby-lapack-1.7.2/ext/slarz.c0000644000175000017500000001212612502221021015653 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slarz_(char* side, integer* m, integer* n, integer* l, real* v, integer* incv, real* tau, real* c, integer* ldc, real* work);


static VALUE
rblapack_slarz(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_v;
  real *v; 
  VALUE rblapack_incv;
  integer incv; 
  VALUE rblapack_tau;
  real tau; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_c_out__;
  real *c_out__;
  real *work;

  integer ldc;
  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  c = NumRu::Lapack.slarz( side, m, l, v, incv, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK )\n\n*  Purpose\n*  =======\n*\n*  SLARZ applies a real elementary reflector H to a real M-by-N\n*  matrix C, from either the left or the right. H is represented in the\n*  form\n*\n*        H = I - tau * v * v'\n*\n*  where tau is a real scalar and v is a real vector.\n*\n*  If tau = 0, then H is taken to be the unit matrix.\n*\n*\n*  H is a product of k elementary reflectors as returned by STZRZF.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': form  H * C\n*          = 'R': form  C * H\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C.\n*\n*  L       (input) INTEGER\n*          The number of entries of the vector V containing\n*          the meaningful part of the Householder vectors.\n*          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n*  V       (input) REAL array, dimension (1+(L-1)*abs(INCV))\n*          The vector v in the representation of H as returned by\n*          STZRZF. V is not used if TAU = 0.\n*\n*  INCV    (input) INTEGER\n*          The increment between elements of v. INCV <> 0.\n*\n*  TAU     (input) REAL\n*          The value tau in the representation of H.\n*\n*  C       (input/output) REAL array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n*          or C * H if SIDE = 'R'.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) REAL array, dimension\n*                         (N) if SIDE = 'L'\n*                      or (M) if SIDE = 'R'\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.slarz( side, m, l, v, incv, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_side = argv[0];
  rblapack_m = argv[1];
  rblapack_l = argv[2];
  rblapack_v = argv[3];
  rblapack_incv = argv[4];
  rblapack_tau = argv[5];
  rblapack_c = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  l = NUM2INT(rblapack_l);
  incv = NUM2INT(rblapack_incv);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  m = NUM2INT(rblapack_m);
  tau = (real)NUM2DBL(rblapack_tau);
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (4th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 1)
    rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_v) != (1+(l-1)*abs(incv)))
    rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1+(l-1)*abs(incv));
  if (NA_TYPE(rblapack_v) != NA_SFLOAT)
    rblapack_v = na_change_type(rblapack_v, NA_SFLOAT);
  v = NA_PTR_TYPE(rblapack_v, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  slarz_(&side, &m, &n, &l, v, &incv, &tau, c, &ldc, work);

  free(work);
  return rblapack_c;
}

void
init_lapack_slarz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slarz", rblapack_slarz, -1);
}
ruby-lapack-1.7.2/ext/cstemr.c0000644000175000017500000004055712502221013016027 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cstemr_(char* jobz, char* range, integer* n, real* d, real* e, real* vl, real* vu, integer* il, integer* iu, integer* m, real* w, complex* z, integer* ldz, integer* nzc, integer* isuppz, logical* tryrac, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_cstemr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_vl;
  real vl; 
  VALUE rblapack_vu;
  real vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_nzc;
  integer nzc; 
  VALUE rblapack_tryrac;
  logical tryrac; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_isuppz;
  integer *isuppz; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_e_out__;
  real *e_out__;

  integer n;
  integer ldz;

  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  m, w, z, isuppz, work, iwork, info, d, e, tryrac = NumRu::Lapack.cstemr( jobz, range, d, e, vl, vu, il, iu, nzc, tryrac, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CSTEMR computes selected eigenvalues and, optionally, eigenvectors\n*  of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n*  a well defined set of pairwise different real eigenvalues, the corresponding\n*  real eigenvectors are pairwise orthogonal.\n*\n*  The spectrum may be computed either completely or partially by specifying\n*  either an interval (VL,VU] or a range of indices IL:IU for the desired\n*  eigenvalues.\n*\n*  Depending on the number of desired eigenvalues, these are computed either\n*  by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are\n*  computed by the use of various suitable L D L^T factorizations near clusters\n*  of close eigenvalues (referred to as RRRs, Relatively Robust\n*  Representations). An informal sketch of the algorithm follows.\n*\n*  For each unreduced block (submatrix) of T,\n*     (a) Compute T - sigma I  = L D L^T, so that L and D\n*         define all the wanted eigenvalues to high relative accuracy.\n*         This means that small relative changes in the entries of D and L\n*         cause only small relative changes in the eigenvalues and\n*         eigenvectors. The standard (unfactored) representation of the\n*         tridiagonal matrix T does not have this property in general.\n*     (b) Compute the eigenvalues to suitable accuracy.\n*         If the eigenvectors are desired, the algorithm attains full\n*         accuracy of the computed eigenvalues only right before\n*         the corresponding vectors have to be computed, see steps c) and d).\n*     (c) For each cluster of close eigenvalues, select a new\n*         shift close to the cluster, find a new factorization, and refine\n*         the shifted eigenvalues to suitable accuracy.\n*     (d) For each eigenvalue with a large enough relative separation compute\n*         the corresponding eigenvector by forming a rank revealing twisted\n*         factorization. Go back to (c) for any clusters that remain.\n*\n*  For more details, see:\n*  - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n*    to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n*    Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n*  - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n*    Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n*    2004.  Also LAPACK Working Note 154.\n*  - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n*    tridiagonal eigenvalue/eigenvector problem\",\n*    Computer Science Division Technical Report No. UCB/CSD-97-971,\n*    UC Berkeley, May 1997.\n*\n*  Further Details\n*  1.CSTEMR works only on machines which follow IEEE-754\n*  floating-point standard in their handling of infinities and NaNs.\n*  This permits the use of efficient inner loops avoiding a check for\n*  zero divisors.\n*\n*  2. LAPACK routines can be used to reduce a complex Hermitean matrix to\n*  real symmetric tridiagonal form.\n*\n*  (Any complex Hermitean tridiagonal matrix has real values on its diagonal\n*  and potentially complex numbers on its off-diagonals. By applying a\n*  similarity transform with an appropriate diagonal matrix\n*  diag(1,e^{i \\phy_1}, ... , e^{i \\phy_{n-1}}), the complex Hermitean\n*  matrix can be transformed into a real symmetric matrix and complex\n*  arithmetic can be entirely avoided.)\n*\n*  While the eigenvectors of the real symmetric tridiagonal matrix are real,\n*  the eigenvectors of original complex Hermitean matrix have complex entries\n*  in general.\n*  Since LAPACK drivers overwrite the matrix data with the eigenvectors,\n*  CSTEMR accepts complex workspace to facilitate interoperability\n*  with CUNMTR or CUPMTR.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found.\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found.\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  D       (input/output) REAL array, dimension (N)\n*          On entry, the N diagonal elements of the tridiagonal matrix\n*          T. On exit, D is overwritten.\n*\n*  E       (input/output) REAL array, dimension (N)\n*          On entry, the (N-1) subdiagonal elements of the tridiagonal\n*          matrix T in elements 1 to N-1 of E. E(N) need not be set on\n*          input, but is used internally as workspace.\n*          On exit, E is overwritten.\n*\n*  VL      (input) REAL\n*  VU      (input) REAL\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) REAL array, dimension (N)\n*          The first M elements contain the selected eigenvalues in\n*          ascending order.\n*\n*  Z       (output) COMPLEX array, dimension (LDZ, max(1,M) )\n*          If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix T\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and can be computed with a workspace\n*          query by setting NZC = -1, see below.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', then LDZ >= max(1,N).\n*\n*  NZC     (input) INTEGER\n*          The number of eigenvectors to be held in the array Z.\n*          If RANGE = 'A', then NZC >= max(1,N).\n*          If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].\n*          If RANGE = 'I', then NZC >= IU-IL+1.\n*          If NZC = -1, then a workspace query is assumed; the\n*          routine calculates the number of columns of the array Z that\n*          are needed to hold the eigenvectors.\n*          This value is returned as the first entry of the Z array, and\n*          no error message related to NZC is issued by XERBLA.\n*\n*  ISUPPZ  (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n*          The support of the eigenvectors in Z, i.e., the indices\n*          indicating the nonzero elements in Z. The i-th computed eigenvector\n*          is nonzero only in elements ISUPPZ( 2*i-1 ) through\n*          ISUPPZ( 2*i ). This is relevant in the case when the matrix\n*          is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n*\n*  TRYRAC  (input/output) LOGICAL\n*          If TRYRAC.EQ..TRUE., indicates that the code should check whether\n*          the tridiagonal matrix defines its eigenvalues to high relative\n*          accuracy.  If so, the code uses relative-accuracy preserving\n*          algorithms that might be (a bit) slower depending on the matrix.\n*          If the matrix does not define its eigenvalues to high relative\n*          accuracy, the code can uses possibly faster algorithms.\n*          If TRYRAC.EQ..FALSE., the code is not required to guarantee\n*          relatively accurate eigenvalues and can use the fastest possible\n*          techniques.\n*          On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix\n*          does not define its eigenvalues to high relative accuracy.\n*\n*  WORK    (workspace/output) REAL array, dimension (LWORK)\n*          On exit, if INFO = 0, WORK(1) returns the optimal\n*          (and minimal) LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK. LWORK >= max(1,18*N)\n*          if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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*  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.  LIWORK >= max(1,10*N)\n*          if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n*          if only the eigenvalues are to be computed.\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal size of the IWORK array,\n*          returns this value as the first entry of the IWORK array, and\n*          no error message related to LIWORK is issued by XERBLA.\n*\n*  INFO    (output) INTEGER\n*          On exit, INFO\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  if INFO = 1X, internal error in SLARRE,\n*                if INFO = 2X, internal error in CLARRV.\n*                Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n*                the nonzero error code returned by SLARRE or\n*                CLARRV, respectively.\n*\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Beresford Parlett, University of California, Berkeley, USA\n*     Jim Demmel, University of California, Berkeley, USA\n*     Inderjit Dhillon, University of Texas, Austin, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, isuppz, work, iwork, info, d, e, tryrac = NumRu::Lapack.cstemr( jobz, range, d, e, vl, vu, il, iu, nzc, tryrac, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_d = argv[2];
  rblapack_e = argv[3];
  rblapack_vl = argv[4];
  rblapack_vu = argv[5];
  rblapack_il = argv[6];
  rblapack_iu = argv[7];
  rblapack_nzc = argv[8];
  rblapack_tryrac = argv[9];
  if (argc == 12) {
    rblapack_lwork = argv[10];
    rblapack_liwork = argv[11];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  vl = (real)NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  nzc = NUM2INT(rblapack_nzc);
  range = StringValueCStr(rblapack_range)[0];
  vu = (real)NUM2DBL(rblapack_vu);
  tryrac = (rblapack_tryrac == Qtrue);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (4th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&jobz,"V") ? 18*n : lsame_(&jobz,"N") ? 12*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  iu = NUM2INT(rblapack_iu);
  m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
  if (rblapack_liwork == Qnil)
    liwork = lsame_(&jobz,"V") ? 10*n : lsame_(&jobz,"N") ? 8*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, complex*);
  {
    na_shape_t shape[1];
    shape[0] = 2*MAX(1,m);
    rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
  MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;

  cstemr_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &m, w, z, &ldz, &nzc, isuppz, &tryrac, work, &lwork, iwork, &liwork, &info);

  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  rblapack_tryrac = tryrac ? Qtrue : Qfalse;
  return rb_ary_new3(10, rblapack_m, rblapack_w, rblapack_z, rblapack_isuppz, rblapack_work, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e, rblapack_tryrac);
}

void
init_lapack_cstemr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cstemr", rblapack_cstemr, -1);
}
ruby-lapack-1.7.2/ext/csyrfs.c0000644000175000017500000002140312502221022016030 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID csyrfs_(char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, complex* b, integer* ldb, complex* x, integer* ldx, real* ferr, real* berr, complex* work, real* rwork, integer* info);


static VALUE
rblapack_csyrfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  complex *x_out__;
  complex *work;
  real *rwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.csyrfs( uplo, a, af, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CSYRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is symmetric indefinite, and\n*  provides error bounds and backward error estimates for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The symmetric matrix A.  If UPLO = 'U', the leading N-by-N\n*          upper triangular part of A contains the upper triangular part\n*          of the matrix A, and the strictly lower triangular part of A\n*          is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*          triangular part of A contains the lower triangular part of\n*          the matrix A, and the strictly upper triangular part of A is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AF      (input) COMPLEX array, dimension (LDAF,N)\n*          The factored form of the matrix A.  AF contains the block\n*          diagonal matrix D and the multipliers used to obtain the\n*          factor U or L from the factorization A = U*D*U**T or\n*          A = L*D*L**T as computed by CSYTRF.\n*\n*  LDAF    (input) INTEGER\n*          The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by CSYTRF.\n*\n*  B       (input) COMPLEX array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) COMPLEX array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by CSYTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.csyrfs( uplo, a, af, ipiv, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_b = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (n));

  csyrfs_(&uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_csyrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "csyrfs", rblapack_csyrfs, -1);
}
ruby-lapack-1.7.2/ext/chfrk.c0000644000175000017500000001534112502221020015616 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chfrk_(char* transr, char* uplo, char* trans, integer* n, integer* k, real* alpha, complex* a, integer* lda, real* beta, complex* c);


static VALUE
rblapack_chfrk(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_alpha;
  real alpha; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_beta;
  real beta; 
  VALUE rblapack_c;
  complex *c; 
  VALUE rblapack_c_out__;
  complex *c_out__;

  integer lda;
  integer ldc;
  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  c = NumRu::Lapack.chfrk( transr, uplo, trans, k, alpha, a, beta, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C )\n\n*  Purpose\n*  =======\n*\n*  Level 3 BLAS like routine for C in RFP Format.\n*\n*  CHFRK performs one of the Hermitian rank--k operations\n*\n*     C := alpha*A*conjg( A' ) + beta*C,\n*\n*  or\n*\n*     C := alpha*conjg( A' )*A + beta*C,\n*\n*  where alpha and beta are real scalars, C is an n--by--n Hermitian\n*  matrix and A is an n--by--k matrix in the first case and a k--by--n\n*  matrix in the second case.\n*\n\n*  Arguments\n*  ==========\n*\n*  TRANSR  (input) CHARACTER*1\n*          = 'N':  The Normal Form of RFP A is stored;\n*          = 'C':  The Conjugate-transpose Form of RFP A is stored.\n*\n*  UPLO    (input) CHARACTER*1\n*           On  entry,   UPLO  specifies  whether  the  upper  or  lower\n*           triangular  part  of the  array  C  is to be  referenced  as\n*           follows:\n*\n*              UPLO = 'U' or 'u'   Only the  upper triangular part of  C\n*                                  is to be referenced.\n*\n*              UPLO = 'L' or 'l'   Only the  lower triangular part of  C\n*                                  is to be referenced.\n*\n*           Unchanged on exit.\n*\n*  TRANS   (input) CHARACTER*1\n*           On entry,  TRANS  specifies the operation to be performed as\n*           follows:\n*\n*              TRANS = 'N' or 'n'   C := alpha*A*conjg( A' ) + beta*C.\n*\n*              TRANS = 'C' or 'c'   C := alpha*conjg( A' )*A + beta*C.\n*\n*           Unchanged on exit.\n*\n*  N       (input) INTEGER\n*           On entry,  N specifies the order of the matrix C.  N must be\n*           at least zero.\n*           Unchanged on exit.\n*\n*  K       (input) INTEGER\n*           On entry with  TRANS = 'N' or 'n',  K  specifies  the number\n*           of  columns   of  the   matrix   A,   and  on   entry   with\n*           TRANS = 'C' or 'c',  K  specifies  the number of rows of the\n*           matrix A.  K must be at least zero.\n*           Unchanged on exit.\n*\n*  ALPHA   (input) REAL\n*           On entry, ALPHA specifies the scalar alpha.\n*           Unchanged on exit.\n*\n*  A       (input) COMPLEX array, dimension (LDA,ka)\n*           where KA\n*           is K  when TRANS = 'N' or 'n', and is N otherwise. Before\n*           entry with TRANS = 'N' or 'n', the leading N--by--K part of\n*           the array A must contain the matrix A, otherwise the leading\n*           K--by--N part of the array A must contain the matrix A.\n*           Unchanged on exit.\n*\n*  LDA     (input) INTEGER\n*           On entry, LDA specifies the first dimension of A as declared\n*           in  the  calling  (sub)  program.   When  TRANS = 'N' or 'n'\n*           then  LDA must be at least  max( 1, n ), otherwise  LDA must\n*           be at least  max( 1, k ).\n*           Unchanged on exit.\n*\n*  BETA    (input) REAL\n*           On entry, BETA specifies the scalar beta.\n*           Unchanged on exit.\n*\n*  C       (input/output) COMPLEX array, dimension (N*(N+1)/2)\n*           On entry, the matrix A in RFP Format. RFP Format is\n*           described by TRANSR, UPLO and N. Note that the imaginary\n*           parts of the diagonal elements need not be set, they are\n*           assumed to be zero, and on exit they are set to zero.\n*\n*  Arguments\n*  ==========\n*\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.chfrk( transr, uplo, trans, k, alpha, a, beta, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_trans = argv[2];
  rblapack_k = argv[3];
  rblapack_alpha = argv[4];
  rblapack_a = argv[5];
  rblapack_beta = argv[6];
  rblapack_c = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  trans = StringValueCStr(rblapack_trans)[0];
  alpha = (real)NUM2DBL(rblapack_alpha);
  beta = (real)NUM2DBL(rblapack_beta);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (8th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 1);
  ldc = NA_SHAPE0(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, complex*);
  n = ((int)sqrtf(ldc*8+1.0f)-1)/2;
  k = NUM2INT(rblapack_k);
  lda = lsame_(&trans,"N") ? MAX(1,n) : MAX(1,k);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (6th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (6th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_a) != lda)
    rb_raise(rb_eRuntimeError, "shape 0 of a must be lsame_(&trans,\"N\") ? MAX(1,n) : MAX(1,k)");
  if (NA_SHAPE1(rblapack_a) != (lsame_(&trans,"N") ? k : n))
    rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", lsame_(&trans,"N") ? k : n);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = ldc;
    rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
  MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  chfrk_(&transr, &uplo, &trans, &n, &k, &alpha, a, &lda, &beta, c);

  return rblapack_c;
}

void
init_lapack_chfrk(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chfrk", rblapack_chfrk, -1);
}
ruby-lapack-1.7.2/ext/zgeqr2p.c0000644000175000017500000001045712502221021016117 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgeqr2p_(integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* info);


static VALUE
rblapack_zgeqr2p(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  doublecomplex *work;

  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, info, a = NumRu::Lapack.zgeqr2p( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGEQR2P( M, N, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGEQR2P computes a QR factorization of a complex m by n matrix A:\n*  A = Q * R.\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) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the m by n matrix A.\n*          On exit, the elements on and above the diagonal of the array\n*          contain the min(m,n) by n upper trapezoidal matrix R (R is\n*          upper triangular if m >= n); the elements below the diagonal,\n*          with the array TAU, represent the unitary 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) COMPLEX*16 array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (N)\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(1) H(2) . . . H(k), 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 complex scalar, and v is a complex vector with\n*  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\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.zgeqr2p( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(doublecomplex, (n));

  zgeqr2p_(&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_zgeqr2p(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgeqr2p", rblapack_zgeqr2p, -1);
}
ruby-lapack-1.7.2/ext/dgsvj0.c0000644000175000017500000002775112502221015015732 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgsvj0_(char* jobv, integer* m, integer* n, doublereal* a, integer* lda, doublereal* d, doublereal* sva, integer* mv, doublereal* v, integer* ldv, doublereal* eps, doublereal* sfmin, doublereal* tol, integer* nsweep, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dgsvj0(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobv;
  char jobv; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_sva;
  doublereal *sva; 
  VALUE rblapack_mv;
  integer mv; 
  VALUE rblapack_v;
  doublereal *v; 
  VALUE rblapack_eps;
  doublereal eps; 
  VALUE rblapack_sfmin;
  doublereal sfmin; 
  VALUE rblapack_tol;
  doublereal tol; 
  VALUE rblapack_nsweep;
  integer nsweep; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_sva_out__;
  doublereal *sva_out__;
  VALUE rblapack_v_out__;
  doublereal *v_out__;
  doublereal *work;

  integer lda;
  integer n;
  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  info, a, d, sva, v = NumRu::Lapack.dgsvj0( jobv, m, a, d, sva, mv, v, eps, sfmin, tol, nsweep, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGSVJ0 is called from DGESVJ as a pre-processor and that is its main\n*  purpose. It applies Jacobi rotations in the same way as DGESVJ does, but\n*  it does not check convergence (stopping criterion). Few tuning\n*  parameters (marked by [TP]) are available for the implementer.\n*\n*  Further Details\n*  ~~~~~~~~~~~~~~~\n*  DGSVJ0 is used just to enable SGESVJ to call a simplified version of\n*  itself to work on a submatrix of the original matrix.\n*\n*  Contributors\n*  ~~~~~~~~~~~~\n*  Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)\n*\n*  Bugs, Examples and Comments\n*  ~~~~~~~~~~~~~~~~~~~~~~~~~~~\n*  Please report all bugs and send interesting test examples and comments to\n*  drmac@math.hr. Thank you.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBV    (input) CHARACTER*1\n*          Specifies whether the output from this procedure is used\n*          to compute the matrix V:\n*          = 'V': the product of the Jacobi rotations is accumulated\n*                 by postmulyiplying the N-by-N array V.\n*                (See the description of V.)\n*          = 'A': the product of the Jacobi rotations is accumulated\n*                 by postmulyiplying the MV-by-N array V.\n*                (See the descriptions of MV and V.)\n*          = 'N': the Jacobi rotations are not accumulated.\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.\n*          M >= N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, M-by-N matrix A, such that A*diag(D) represents\n*          the input matrix.\n*          On exit,\n*          A_onexit * D_onexit represents the input matrix A*diag(D)\n*          post-multiplied by a sequence of Jacobi rotations, where the\n*          rotation threshold and the total number of sweeps are given in\n*          TOL and NSWEEP, respectively.\n*          (See the descriptions of D, TOL and NSWEEP.)\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  D       (input/workspace/output) DOUBLE PRECISION array, dimension (N)\n*          The array D accumulates the scaling factors from the fast scaled\n*          Jacobi rotations.\n*          On entry, A*diag(D) represents the input matrix.\n*          On exit, A_onexit*diag(D_onexit) represents the input matrix\n*          post-multiplied by a sequence of Jacobi rotations, where the\n*          rotation threshold and the total number of sweeps are given in\n*          TOL and NSWEEP, respectively.\n*          (See the descriptions of A, TOL and NSWEEP.)\n*\n*  SVA     (input/workspace/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, SVA contains the Euclidean norms of the columns of\n*          the matrix A*diag(D).\n*          On exit, SVA contains the Euclidean norms of the columns of\n*          the matrix onexit*diag(D_onexit).\n*\n*  MV      (input) INTEGER\n*          If JOBV .EQ. 'A', then MV rows of V are post-multipled by a\n*                           sequence of Jacobi rotations.\n*          If JOBV = 'N',   then MV is not referenced.\n*\n*  V       (input/output) DOUBLE PRECISION array, dimension (LDV,N)\n*          If JOBV .EQ. 'V' then N rows of V are post-multipled by a\n*                           sequence of Jacobi rotations.\n*          If JOBV .EQ. 'A' then MV rows of V are post-multipled by a\n*                           sequence of Jacobi rotations.\n*          If JOBV = 'N',   then V is not referenced.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V,  LDV >= 1.\n*          If JOBV = 'V', LDV .GE. N.\n*          If JOBV = 'A', LDV .GE. MV.\n*\n*  EPS     (input) DOUBLE PRECISION\n*          EPS = DLAMCH('Epsilon')\n*\n*  SFMIN   (input) DOUBLE PRECISION\n*          SFMIN = DLAMCH('Safe Minimum')\n*\n*  TOL     (input) DOUBLE PRECISION\n*          TOL is the threshold for Jacobi rotations. For a pair\n*          A(:,p), A(:,q) of pivot columns, the Jacobi rotation is\n*          applied only if DABS(COS(angle(A(:,p),A(:,q)))) .GT. TOL.\n*\n*  NSWEEP  (input) INTEGER\n*          NSWEEP is the number of sweeps of Jacobi rotations to be\n*          performed.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (LWORK)\n*\n*  LWORK   (input) INTEGER\n*          LWORK is the dimension of WORK. LWORK .GE. M.\n*\n*  INFO    (output) INTEGER\n*          = 0 : successful exit.\n*          < 0 : if INFO = -i, then the i-th argument had an illegal value\n*\n\n*  =====================================================================\n*\n*     .. Local Parameters ..\n      DOUBLE PRECISION   ZERO, HALF, ONE, TWO\n      PARAMETER          ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0,\n     +                   TWO = 2.0D0 )\n*     ..\n*     .. Local Scalars ..\n      DOUBLE PRECISION   AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,\n     +                   BIGTHETA, CS, MXAAPQ, MXSINJ, ROOTBIG, ROOTEPS,\n     +                   ROOTSFMIN, ROOTTOL, SMALL, SN, T, TEMP1, THETA,\n     +                   THSIGN\n      INTEGER            BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1,\n     +                   ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, NBL,\n     +                   NOTROT, p, PSKIPPED, q, ROWSKIP, SWBAND\n      LOGICAL            APPLV, ROTOK, RSVEC\n*     ..\n*     .. Local Arrays ..\n      DOUBLE PRECISION   FASTR( 5 )\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          DABS, DMAX1, DBLE, MIN0, DSIGN, DSQRT\n*     ..\n*     .. External Functions ..\n      DOUBLE PRECISION   DDOT, DNRM2\n      INTEGER            IDAMAX\n      LOGICAL            LSAME\n      EXTERNAL           IDAMAX, LSAME, DDOT, DNRM2\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DAXPY, DCOPY, DLASCL, DLASSQ, DROTM, DSWAP\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a, d, sva, v = NumRu::Lapack.dgsvj0( jobv, m, a, d, sva, mv, v, eps, sfmin, tol, nsweep, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 11 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
  rblapack_jobv = argv[0];
  rblapack_m = argv[1];
  rblapack_a = argv[2];
  rblapack_d = argv[3];
  rblapack_sva = argv[4];
  rblapack_mv = argv[5];
  rblapack_v = argv[6];
  rblapack_eps = argv[7];
  rblapack_sfmin = argv[8];
  rblapack_tol = argv[9];
  rblapack_nsweep = argv[10];
  if (argc == 12) {
    rblapack_lwork = argv[11];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  jobv = StringValueCStr(rblapack_jobv)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  if (!NA_IsNArray(rblapack_sva))
    rb_raise(rb_eArgError, "sva (5th argument) must be NArray");
  if (NA_RANK(rblapack_sva) != 1)
    rb_raise(rb_eArgError, "rank of sva (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_sva) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of sva must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_sva) != NA_DFLOAT)
    rblapack_sva = na_change_type(rblapack_sva, NA_DFLOAT);
  sva = NA_PTR_TYPE(rblapack_sva, doublereal*);
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (7th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  if (NA_SHAPE1(rblapack_v) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of v must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_v) != NA_DFLOAT)
    rblapack_v = na_change_type(rblapack_v, NA_DFLOAT);
  v = NA_PTR_TYPE(rblapack_v, doublereal*);
  sfmin = NUM2DBL(rblapack_sfmin);
  nsweep = NUM2INT(rblapack_nsweep);
  m = NUM2INT(rblapack_m);
  mv = NUM2INT(rblapack_mv);
  tol = NUM2DBL(rblapack_tol);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  lwork = m;
  eps = NUM2DBL(rblapack_eps);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_sva_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  sva_out__ = NA_PTR_TYPE(rblapack_sva_out__, doublereal*);
  MEMCPY(sva_out__, sva, doublereal, NA_TOTAL(rblapack_sva));
  rblapack_sva = rblapack_sva_out__;
  sva = sva_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = n;
    rblapack_v_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  v_out__ = NA_PTR_TYPE(rblapack_v_out__, doublereal*);
  MEMCPY(v_out__, v, doublereal, NA_TOTAL(rblapack_v));
  rblapack_v = rblapack_v_out__;
  v = v_out__;
  work = ALLOC_N(doublereal, (lwork));

  dgsvj0_(&jobv, &m, &n, a, &lda, d, sva, &mv, v, &ldv, &eps, &sfmin, &tol, &nsweep, work, &lwork, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_info, rblapack_a, rblapack_d, rblapack_sva, rblapack_v);
}

void
init_lapack_dgsvj0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgsvj0", rblapack_dgsvj0, -1);
}
ruby-lapack-1.7.2/ext/clarfb.c0000644000175000017500000001505312502221024015756 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clarfb_(char* side, char* trans, char* direct, char* storev, integer* m, integer* n, integer* k, complex* v, integer* ldv, complex* t, integer* ldt, complex* c, integer* ldc, complex* work, integer* ldwork);


static VALUE
rblapack_clarfb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_direct;
  char direct; 
  VALUE rblapack_storev;
  char storev; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_v;
  complex *v; 
  VALUE rblapack_t;
  complex *t; 
  VALUE rblapack_c;
  complex *c; 
  VALUE rblapack_c_out__;
  complex *c_out__;
  complex *work;

  integer ldv;
  integer k;
  integer ldt;
  integer ldc;
  integer n;
  integer ldwork;

  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  c = NumRu::Lapack.clarfb( side, trans, direct, storev, m, v, t, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n*  Purpose\n*  =======\n*\n*  CLARFB applies a complex block reflector H or its transpose H' to a\n*  complex M-by-N matrix C, from either the left or the right.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply H or H' from the Left\n*          = 'R': apply H or H' from the Right\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': apply H (No transpose)\n*          = 'C': apply H' (Conjugate transpose)\n*\n*  DIRECT  (input) CHARACTER*1\n*          Indicates how H is formed from a product of elementary\n*          reflectors\n*          = 'F': H = H(1) H(2) . . . H(k) (Forward)\n*          = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n*  STOREV  (input) CHARACTER*1\n*          Indicates how the vectors which define the elementary\n*          reflectors are stored:\n*          = 'C': Columnwise\n*          = 'R': Rowwise\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C.\n*\n*  K       (input) INTEGER\n*          The order of the matrix T (= the number of elementary\n*          reflectors whose product defines the block reflector).\n*\n*  V       (input) COMPLEX array, dimension\n*                                (LDV,K) if STOREV = 'C'\n*                                (LDV,M) if STOREV = 'R' and SIDE = 'L'\n*                                (LDV,N) if STOREV = 'R' and SIDE = 'R'\n*          The matrix V. See further details.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V.\n*          If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);\n*          if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);\n*          if STOREV = 'R', LDV >= K.\n*\n*  T       (input) COMPLEX array, dimension (LDT,K)\n*          The triangular K-by-K matrix T in the representation of the\n*          block reflector.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= K.\n*\n*  C       (input/output) COMPLEX array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by H*C or H'*C or C*H or C*H'.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) COMPLEX array, dimension (LDWORK,K)\n*\n*  LDWORK  (input) INTEGER\n*          The leading dimension of the array WORK.\n*          If SIDE = 'L', LDWORK >= max(1,N);\n*          if SIDE = 'R', LDWORK >= max(1,M).\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.clarfb( side, trans, direct, storev, m, v, t, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_direct = argv[2];
  rblapack_storev = argv[3];
  rblapack_m = argv[4];
  rblapack_v = argv[5];
  rblapack_t = argv[6];
  rblapack_c = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  direct = StringValueCStr(rblapack_direct)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (7th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (7th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  k = NA_SHAPE1(rblapack_t);
  if (NA_TYPE(rblapack_t) != NA_SCOMPLEX)
    rblapack_t = na_change_type(rblapack_t, NA_SCOMPLEX);
  t = NA_PTR_TYPE(rblapack_t, complex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (6th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (6th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  if (NA_SHAPE1(rblapack_v) != k)
    rb_raise(rb_eRuntimeError, "shape 1 of v must be the same as shape 1 of t");
  if (NA_TYPE(rblapack_v) != NA_SCOMPLEX)
    rblapack_v = na_change_type(rblapack_v, NA_SCOMPLEX);
  v = NA_PTR_TYPE(rblapack_v, complex*);
  storev = StringValueCStr(rblapack_storev)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (8th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, complex*);
  ldwork = MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0;
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
  MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(complex, (ldwork)*(k));

  clarfb_(&side, &trans, &direct, &storev, &m, &n, &k, v, &ldv, t, &ldt, c, &ldc, work, &ldwork);

  free(work);
  return rblapack_c;
}

void
init_lapack_clarfb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clarfb", rblapack_clarfb, -1);
}
ruby-lapack-1.7.2/ext/dlaqp2.c0000644000175000017500000001746612502221014015721 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaqp2_(integer* m, integer* n, integer* offset, doublereal* a, integer* lda, integer* jpvt, doublereal* tau, doublereal* vn1, doublereal* vn2, doublereal* work);


static VALUE
rblapack_dlaqp2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_offset;
  integer offset; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_jpvt;
  integer *jpvt; 
  VALUE rblapack_vn1;
  doublereal *vn1; 
  VALUE rblapack_vn2;
  doublereal *vn2; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  VALUE rblapack_jpvt_out__;
  integer *jpvt_out__;
  VALUE rblapack_vn1_out__;
  doublereal *vn1_out__;
  VALUE rblapack_vn2_out__;
  doublereal *vn2_out__;
  doublereal *work;

  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, a, jpvt, vn1, vn2 = NumRu::Lapack.dlaqp2( m, offset, a, jpvt, vn1, vn2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, WORK )\n\n*  Purpose\n*  =======\n*\n*  DLAQP2 computes a QR factorization with column pivoting of\n*  the block A(OFFSET+1:M,1:N).\n*  The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\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*  OFFSET  (input) INTEGER\n*          The number of rows of the matrix A that must be pivoted\n*          but no factorized. OFFSET >= 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 upper triangle of block A(OFFSET+1:M,1:N) is \n*          the triangular factor obtained; the elements in block\n*          A(OFFSET+1:M,1:N) below the diagonal, together with the\n*          array TAU, represent the orthogonal matrix Q as a product of\n*          elementary reflectors. Block A(1:OFFSET,1:N) has been\n*          accordingly pivoted, but no factorized.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  JPVT    (input/output) INTEGER array, dimension (N)\n*          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n*          to the front of A*P (a leading column); if JPVT(i) = 0,\n*          the i-th column of A is a free column.\n*          On exit, if JPVT(i) = k, then the i-th column of A*P\n*          was the k-th column of A.\n*\n*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors.\n*\n*  VN1     (input/output) DOUBLE PRECISION array, dimension (N)\n*          The vector with the partial column norms.\n*\n*  VN2     (input/output) DOUBLE PRECISION array, dimension (N)\n*          The vector with the exact column norms.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (N)\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n*    X. Sun, Computer Science Dept., Duke University, USA\n*\n*  Partial column norm updating strategy modified by\n*    Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n*    University of Zagreb, Croatia.\n*     June 2010\n*  For more details see LAPACK Working Note 176.\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, a, jpvt, vn1, vn2 = NumRu::Lapack.dlaqp2( m, offset, a, jpvt, vn1, vn2, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_m = argv[0];
  rblapack_offset = argv[1];
  rblapack_a = argv[2];
  rblapack_jpvt = argv[3];
  rblapack_vn1 = argv[4];
  rblapack_vn2 = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  if (!NA_IsNArray(rblapack_vn1))
    rb_raise(rb_eArgError, "vn1 (5th argument) must be NArray");
  if (NA_RANK(rblapack_vn1) != 1)
    rb_raise(rb_eArgError, "rank of vn1 (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_vn1) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of vn1 must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_vn1) != NA_DFLOAT)
    rblapack_vn1 = na_change_type(rblapack_vn1, NA_DFLOAT);
  vn1 = NA_PTR_TYPE(rblapack_vn1, doublereal*);
  offset = NUM2INT(rblapack_offset);
  if (!NA_IsNArray(rblapack_vn2))
    rb_raise(rb_eArgError, "vn2 (6th argument) must be NArray");
  if (NA_RANK(rblapack_vn2) != 1)
    rb_raise(rb_eArgError, "rank of vn2 (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_vn2) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of vn2 must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_vn2) != NA_DFLOAT)
    rblapack_vn2 = na_change_type(rblapack_vn2, NA_DFLOAT);
  vn2 = NA_PTR_TYPE(rblapack_vn2, doublereal*);
  if (!NA_IsNArray(rblapack_jpvt))
    rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
  if (NA_RANK(rblapack_jpvt) != 1)
    rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_jpvt) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_jpvt) != NA_LINT)
    rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
  jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
  MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
  rblapack_jpvt = rblapack_jpvt_out__;
  jpvt = jpvt_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_vn1_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  vn1_out__ = NA_PTR_TYPE(rblapack_vn1_out__, doublereal*);
  MEMCPY(vn1_out__, vn1, doublereal, NA_TOTAL(rblapack_vn1));
  rblapack_vn1 = rblapack_vn1_out__;
  vn1 = vn1_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_vn2_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  vn2_out__ = NA_PTR_TYPE(rblapack_vn2_out__, doublereal*);
  MEMCPY(vn2_out__, vn2, doublereal, NA_TOTAL(rblapack_vn2));
  rblapack_vn2 = rblapack_vn2_out__;
  vn2 = vn2_out__;
  work = ALLOC_N(doublereal, (n));

  dlaqp2_(&m, &n, &offset, a, &lda, jpvt, tau, vn1, vn2, work);

  free(work);
  return rb_ary_new3(5, rblapack_tau, rblapack_a, rblapack_jpvt, rblapack_vn1, rblapack_vn2);
}

void
init_lapack_dlaqp2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaqp2", rblapack_dlaqp2, -1);
}
ruby-lapack-1.7.2/ext/sgtcon.c0000644000175000017500000001516412502221022016023 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgtcon_(char* norm, integer* n, real* dl, real* d, real* du, real* du2, integer* ipiv, real* anorm, real* rcond, real* work, integer* iwork, integer* info);


static VALUE
rblapack_sgtcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_dl;
  real *dl; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_du;
  real *du; 
  VALUE rblapack_du2;
  real *du2; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_anorm;
  real anorm; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_info;
  integer info; 
  real *work;
  integer *iwork;

  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  rcond, info = NumRu::Lapack.sgtcon( norm, dl, d, du, du2, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGTCON estimates the reciprocal of the condition number of a real\n*  tridiagonal matrix A using the LU factorization as computed by\n*  SGTTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies whether the 1-norm condition number or the\n*          infinity-norm condition number is required:\n*          = '1' or 'O':  1-norm;\n*          = 'I':         Infinity-norm.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  DL      (input) REAL array, dimension (N-1)\n*          The (n-1) multipliers that define the matrix L from the\n*          LU factorization of A as computed by SGTTRF.\n*\n*  D       (input) REAL array, dimension (N)\n*          The n diagonal elements of the upper triangular matrix U from\n*          the LU factorization of A.\n*\n*  DU      (input) REAL array, dimension (N-1)\n*          The (n-1) elements of the first superdiagonal of U.\n*\n*  DU2     (input) REAL array, dimension (N-2)\n*          The (n-2) elements of the second superdiagonal of U.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices; for 1 <= i <= n, row i of the matrix was\n*          interchanged with row IPIV(i).  IPIV(i) will always be either\n*          i or i+1; IPIV(i) = i indicates a row interchange was not\n*          required.\n*\n*  ANORM   (input) REAL\n*          If NORM = '1' or 'O', the 1-norm of the original matrix A.\n*          If NORM = 'I', the infinity-norm of the original matrix A.\n*\n*  RCOND   (output) REAL\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n*          estimate of the 1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) REAL array, dimension (2*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.sgtcon( norm, dl, d, du, du2, ipiv, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_norm = argv[0];
  rblapack_dl = argv[1];
  rblapack_d = argv[2];
  rblapack_du = argv[3];
  rblapack_du2 = argv[4];
  rblapack_ipiv = argv[5];
  rblapack_anorm = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_SFLOAT)
    rblapack_dl = na_change_type(rblapack_dl, NA_SFLOAT);
  dl = NA_PTR_TYPE(rblapack_dl, real*);
  if (!NA_IsNArray(rblapack_du2))
    rb_raise(rb_eArgError, "du2 (5th argument) must be NArray");
  if (NA_RANK(rblapack_du2) != 1)
    rb_raise(rb_eArgError, "rank of du2 (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du2) != (n-2))
    rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
  if (NA_TYPE(rblapack_du2) != NA_SFLOAT)
    rblapack_du2 = na_change_type(rblapack_du2, NA_SFLOAT);
  du2 = NA_PTR_TYPE(rblapack_du2, real*);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (4th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_SFLOAT)
    rblapack_du = na_change_type(rblapack_du, NA_SFLOAT);
  du = NA_PTR_TYPE(rblapack_du, real*);
  anorm = (real)NUM2DBL(rblapack_anorm);
  work = ALLOC_N(real, (2*n));
  iwork = ALLOC_N(integer, (n));

  sgtcon_(&norm, &n, dl, d, du, du2, ipiv, &anorm, &rcond, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_sgtcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgtcon", rblapack_sgtcon, -1);
}
ruby-lapack-1.7.2/ext/cggesx.c0000644000175000017500000004001012502221025015775 0ustar  uwabamiuwabami#include "rb_lapack.h"

static logical
rblapack_selctg(complex *arg0, complex *arg1){
  VALUE rblapack_arg0, rblapack_arg1;

  VALUE rblapack_ret;
  logical ret;

  rblapack_arg0 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg0->r)), rb_float_new((double)(arg0->i)));
  rblapack_arg1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg1->r)), rb_float_new((double)(arg1->i)));

  rblapack_ret = rb_yield_values(2, rblapack_arg0, rblapack_arg1);

  ret = (rblapack_ret == Qtrue);
  return ret;
}

extern VOID cggesx_(char* jobvsl, char* jobvsr, char* sort, L_fp selctg, char* sense, integer* n, complex* a, integer* lda, complex* b, integer* ldb, integer* sdim, complex* alpha, complex* beta, complex* vsl, integer* ldvsl, complex* vsr, integer* ldvsr, real* rconde, real* rcondv, complex* work, integer* lwork, real* rwork, integer* iwork, integer* liwork, logical* bwork, integer* info);


static VALUE
rblapack_cggesx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvsl;
  char jobvsl; 
  VALUE rblapack_jobvsr;
  char jobvsr; 
  VALUE rblapack_sort;
  char sort; 
  VALUE rblapack_sense;
  char sense; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_sdim;
  integer sdim; 
  VALUE rblapack_alpha;
  complex *alpha; 
  VALUE rblapack_beta;
  complex *beta; 
  VALUE rblapack_vsl;
  complex *vsl; 
  VALUE rblapack_vsr;
  complex *vsr; 
  VALUE rblapack_rconde;
  real *rconde; 
  VALUE rblapack_rcondv;
  real *rcondv; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;
  real *rwork;
  logical *bwork;

  integer lda;
  integer n;
  integer ldb;
  integer ldvsl;
  integer ldvsr;

  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  sdim, alpha, beta, vsl, vsr, rconde, rcondv, work, iwork, info, a, b = NumRu::Lapack.cggesx( jobvsl, jobvsr, sort, sense, a, b, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help]){|a,b| ... }\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, B, LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, RWORK, IWORK, LIWORK, BWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGGESX computes for a pair of N-by-N complex nonsymmetric matrices\n*  (A,B), the generalized eigenvalues, the complex Schur form (S,T),\n*  and, optionally, the left and/or right matrices of Schur vectors (VSL\n*  and VSR).  This gives the generalized Schur factorization\n*\n*       (A,B) = ( (VSL) S (VSR)**H, (VSL) T (VSR)**H )\n*\n*  where (VSR)**H is the conjugate-transpose of VSR.\n*\n*  Optionally, it also orders the eigenvalues so that a selected cluster\n*  of eigenvalues appears in the leading diagonal blocks of the upper\n*  triangular matrix S and the upper triangular matrix T; computes\n*  a reciprocal condition number for the average of the selected\n*  eigenvalues (RCONDE); and computes a reciprocal condition number for\n*  the right and left deflating subspaces corresponding to the selected\n*  eigenvalues (RCONDV). The leading columns of VSL and VSR then form\n*  an orthonormal basis for the corresponding left and right eigenspaces\n*  (deflating subspaces).\n*\n*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n*  or a ratio alpha/beta = w, such that  A - w*B is singular.  It is\n*  usually represented as the pair (alpha,beta), as there is a\n*  reasonable interpretation for beta=0 or for both being zero.\n*\n*  A pair of matrices (S,T) is in generalized complex Schur form if T is\n*  upper triangular with non-negative diagonal and S is upper\n*  triangular.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVSL  (input) CHARACTER*1\n*          = 'N':  do not compute the left Schur vectors;\n*          = 'V':  compute the left Schur vectors.\n*\n*  JOBVSR  (input) CHARACTER*1\n*          = 'N':  do not compute the right Schur vectors;\n*          = 'V':  compute the right Schur vectors.\n*\n*  SORT    (input) CHARACTER*1\n*          Specifies whether or not to order the eigenvalues on the\n*          diagonal of the generalized Schur form.\n*          = 'N':  Eigenvalues are not ordered;\n*          = 'S':  Eigenvalues are ordered (see SELCTG).\n*\n*  SELCTG  (external procedure) LOGICAL FUNCTION of two COMPLEX arguments\n*          SELCTG must be declared EXTERNAL in the calling subroutine.\n*          If SORT = 'N', SELCTG is not referenced.\n*          If SORT = 'S', SELCTG is used to select eigenvalues to sort\n*          to the top left of the Schur form.\n*          Note that a selected complex eigenvalue may no longer satisfy\n*          SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since\n*          ordering may change the value of complex eigenvalues\n*          (especially if the eigenvalue is ill-conditioned), in this\n*          case INFO is set to N+3 see INFO below).\n*\n*  SENSE   (input) CHARACTER*1\n*          Determines which reciprocal condition numbers are computed.\n*          = 'N' : None are computed;\n*          = 'E' : Computed for average of selected eigenvalues only;\n*          = 'V' : Computed for selected deflating subspaces only;\n*          = 'B' : Computed for both.\n*          If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A, B, VSL, and VSR.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA, N)\n*          On entry, the first of the pair of matrices.\n*          On exit, A has been overwritten by its generalized Schur\n*          form S.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of A.  LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX array, dimension (LDB, N)\n*          On entry, the second of the pair of matrices.\n*          On exit, B has been overwritten by its generalized Schur\n*          form T.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of B.  LDB >= max(1,N).\n*\n*  SDIM    (output) INTEGER\n*          If SORT = 'N', SDIM = 0.\n*          If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n*          for which SELCTG is true.\n*\n*  ALPHA   (output) COMPLEX array, dimension (N)\n*  BETA    (output) COMPLEX array, dimension (N)\n*          On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the\n*          generalized eigenvalues.  ALPHA(j) and BETA(j),j=1,...,N  are\n*          the diagonals of the complex Schur form (S,T).  BETA(j) will\n*          be non-negative real.\n*\n*          Note: the quotients ALPHA(j)/BETA(j) may easily over- or\n*          underflow, and BETA(j) may even be zero.  Thus, the user\n*          should avoid naively computing the ratio alpha/beta.\n*          However, ALPHA will be always less than and usually\n*          comparable with norm(A) in magnitude, and BETA always less\n*          than and usually comparable with norm(B).\n*\n*  VSL     (output) COMPLEX array, dimension (LDVSL,N)\n*          If JOBVSL = 'V', VSL will contain the left Schur vectors.\n*          Not referenced if JOBVSL = 'N'.\n*\n*  LDVSL   (input) INTEGER\n*          The leading dimension of the matrix VSL. LDVSL >=1, and\n*          if JOBVSL = 'V', LDVSL >= N.\n*\n*  VSR     (output) COMPLEX array, dimension (LDVSR,N)\n*          If JOBVSR = 'V', VSR will contain the right Schur vectors.\n*          Not referenced if JOBVSR = 'N'.\n*\n*  LDVSR   (input) INTEGER\n*          The leading dimension of the matrix VSR. LDVSR >= 1, and\n*          if JOBVSR = 'V', LDVSR >= N.\n*\n*  RCONDE  (output) REAL array, dimension ( 2 )\n*          If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the\n*          reciprocal condition numbers for the average of the selected\n*          eigenvalues.\n*          Not referenced if SENSE = 'N' or 'V'.\n*\n*  RCONDV  (output) REAL array, dimension ( 2 )\n*          If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the\n*          reciprocal condition number for the selected deflating\n*          subspaces.\n*          Not referenced if SENSE = 'N' or 'E'.\n*\n*  WORK    (workspace/output) COMPLEX 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*          If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B',\n*          LWORK >= MAX(1,2*N,2*SDIM*(N-SDIM)), else\n*          LWORK >= MAX(1,2*N).  Note that 2*SDIM*(N-SDIM) <= N*N/2.\n*          Note also that an error is only returned if\n*          LWORK < MAX(1,2*N), but if SENSE = 'E' or 'V' or 'B' this may\n*          not be large enough.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the bound on the optimal size of the WORK\n*          array and the minimum size of the IWORK array, returns these\n*          values as the first entries of the WORK and IWORK arrays, and\n*          no error message related to LWORK or LIWORK is issued by\n*          XERBLA.\n*\n*  RWORK   (workspace) REAL array, dimension ( 8*N )\n*          Real workspace.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array WORK.\n*          If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise\n*          LIWORK >= N+2.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the bound on the optimal size of the\n*          WORK array and the minimum size of the IWORK array, returns\n*          these values as the first entries of the WORK and IWORK\n*          arrays, and no error message related to LWORK or LIWORK is\n*          issued by XERBLA.\n*\n*  BWORK   (workspace) LOGICAL array, dimension (N)\n*          Not referenced if SORT = 'N'.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          = 1,...,N:\n*                The QZ iteration failed.  (A,B) are not in Schur\n*                form, but ALPHA(j) and BETA(j) should be correct for\n*                j=INFO+1,...,N.\n*          > N:  =N+1: other than QZ iteration failed in CHGEQZ\n*                =N+2: after reordering, roundoff changed values of\n*                      some complex eigenvalues so that leading\n*                      eigenvalues in the Generalized Schur form no\n*                      longer satisfy SELCTG=.TRUE.  This could also\n*                      be caused due to scaling.\n*                =N+3: reordering failed in CTGSEN.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sdim, alpha, beta, vsl, vsr, rconde, rcondv, work, iwork, info, a, b = NumRu::Lapack.cggesx( jobvsl, jobvsr, sort, sense, a, b, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help]){|a,b| ... }\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_jobvsl = argv[0];
  rblapack_jobvsr = argv[1];
  rblapack_sort = argv[2];
  rblapack_sense = argv[3];
  rblapack_a = argv[4];
  rblapack_b = argv[5];
  if (argc == 8) {
    rblapack_lwork = argv[6];
    rblapack_liwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobvsl = StringValueCStr(rblapack_jobvsl)[0];
  sort = StringValueCStr(rblapack_sort)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  jobvsr = StringValueCStr(rblapack_jobvsr)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  ldvsl = lsame_(&jobvsl,"V") ? n : 1;
  sense = StringValueCStr(rblapack_sense)[0];
  if (rblapack_liwork == Qnil)
    liwork = (lsame_(&sense,"N")||n==0) ? 1 : n+2;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  if (rblapack_lwork == Qnil)
    lwork = n==0 ? 1 : (lsame_(&sense,"E")||lsame_(&sense,"V")||lsame_(&sense,"B")) ? MAX(2*n,n*n/2) : 2*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldvsr = lsame_(&jobvsr,"V") ? n : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  alpha = NA_PTR_TYPE(rblapack_alpha, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvsl;
    shape[1] = n;
    rblapack_vsl = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  vsl = NA_PTR_TYPE(rblapack_vsl, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvsr;
    shape[1] = n;
    rblapack_vsr = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  vsr = NA_PTR_TYPE(rblapack_vsr, complex*);
  {
    na_shape_t shape[1];
    shape[0] = 2;
    rblapack_rconde = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  rconde = NA_PTR_TYPE(rblapack_rconde, real*);
  {
    na_shape_t shape[1];
    shape[0] = 2;
    rblapack_rcondv = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  rcondv = NA_PTR_TYPE(rblapack_rcondv, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  rwork = ALLOC_N(real, (8*n));
  bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));

  cggesx_(&jobvsl, &jobvsr, &sort, rblapack_selctg, &sense, &n, a, &lda, b, &ldb, &sdim, alpha, beta, vsl, &ldvsl, vsr, &ldvsr, rconde, rcondv, work, &lwork, rwork, iwork, &liwork, bwork, &info);

  free(rwork);
  free(bwork);
  rblapack_sdim = INT2NUM(sdim);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(12, rblapack_sdim, rblapack_alpha, rblapack_beta, rblapack_vsl, rblapack_vsr, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_iwork, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_cggesx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cggesx", rblapack_cggesx, -1);
}
ruby-lapack-1.7.2/ext/cla_lin_berr.c0000644000175000017500000001126612502221024017142 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cla_lin_berr_(integer* n, integer* nz, integer* nrhs, doublereal* res, doublereal* ayb, complex* berr);


static VALUE
rblapack_cla_lin_berr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_nz;
  integer nz; 
  VALUE rblapack_res;
  doublereal *res; 
  VALUE rblapack_ayb;
  doublereal *ayb; 
  VALUE rblapack_berr;
  complex *berr; 

  integer n;
  integer nrhs;

  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  berr = NumRu::Lapack.cla_lin_berr( nz, res, ayb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR )\n\n*  Purpose\n*  =======\n*\n*     CLA_LIN_BERR computes componentwise relative backward error from\n*     the formula\n*         max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n*     where abs(Z) is the componentwise absolute value of the matrix\n*     or vector Z.\n*\n\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NZ      (input) INTEGER\n*     We add (NZ+1)*SLAMCH( 'Safe minimum' ) to R(i) in the numerator to\n*     guard against spuriously zero residuals. Default value is N.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices AYB, RES, and BERR.  NRHS >= 0.\n*\n*     RES    (input) DOUBLE PRECISION array, dimension (N,NRHS)\n*     The residual matrix, i.e., the matrix R in the relative backward\n*     error formula above.\n*\n*     AYB    (input) DOUBLE PRECISION array, dimension (N, NRHS)\n*     The denominator in the relative backward error formula above, i.e.,\n*     the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B\n*     are from iterative refinement (see cla_gerfsx_extended.f).\n*     \n*     BERR   (output) COMPLEX array, dimension (NRHS)\n*     The componentwise relative backward error from the formula above.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      REAL               TMP\n      INTEGER            I, J\n      COMPLEX            CDUM\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, REAL, AIMAG, MAX\n*     ..\n*     .. External Functions ..\n      EXTERNAL           SLAMCH\n      REAL               SLAMCH\n      REAL               SAFE1\n*     ..\n*     .. Statement Functions ..\n      COMPLEX            CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  berr = NumRu::Lapack.cla_lin_berr( nz, res, ayb, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_nz = argv[0];
  rblapack_res = argv[1];
  rblapack_ayb = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  nz = NUM2INT(rblapack_nz);
  if (!NA_IsNArray(rblapack_ayb))
    rb_raise(rb_eArgError, "ayb (3th argument) must be NArray");
  if (NA_RANK(rblapack_ayb) != 2)
    rb_raise(rb_eArgError, "rank of ayb (3th argument) must be %d", 2);
  n = NA_SHAPE0(rblapack_ayb);
  nrhs = NA_SHAPE1(rblapack_ayb);
  if (NA_TYPE(rblapack_ayb) != NA_DFLOAT)
    rblapack_ayb = na_change_type(rblapack_ayb, NA_DFLOAT);
  ayb = NA_PTR_TYPE(rblapack_ayb, doublereal*);
  if (!NA_IsNArray(rblapack_res))
    rb_raise(rb_eArgError, "res (2th argument) must be NArray");
  if (NA_RANK(rblapack_res) != 2)
    rb_raise(rb_eArgError, "rank of res (2th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_res) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 0 of ayb");
  if (NA_SHAPE1(rblapack_res) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of res must be the same as shape 1 of ayb");
  if (NA_TYPE(rblapack_res) != NA_DFLOAT)
    rblapack_res = na_change_type(rblapack_res, NA_DFLOAT);
  res = NA_PTR_TYPE(rblapack_res, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, complex*);

  cla_lin_berr_(&n, &nz, &nrhs, res, ayb, berr);

  return rblapack_berr;
}

void
init_lapack_cla_lin_berr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cla_lin_berr", rblapack_cla_lin_berr, -1);
}
ruby-lapack-1.7.2/ext/zgebrd.c0000644000175000017500000002152312502221020015775 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgebrd_(integer* m, integer* n, doublecomplex* a, integer* lda, doublereal* d, doublereal* e, doublecomplex* tauq, doublecomplex* taup, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zgebrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_tauq;
  doublecomplex *tauq; 
  VALUE rblapack_taup;
  doublecomplex *taup; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *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  d, e, tauq, taup, work, info, a = NumRu::Lapack.zgebrd( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGEBRD reduces a general complex M-by-N matrix A to upper or lower\n*  bidiagonal form B by a unitary transformation: Q**H * A * P = B.\n*\n*  If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows in the matrix A.  M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns in the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the M-by-N general matrix to be reduced.\n*          On exit,\n*          if m >= n, the diagonal and the first superdiagonal are\n*            overwritten with the upper bidiagonal matrix B; the\n*            elements below the diagonal, with the array TAUQ, represent\n*            the unitary matrix Q as a product of elementary\n*            reflectors, and the elements above the first superdiagonal,\n*            with the array TAUP, represent the unitary matrix P as\n*            a product of elementary reflectors;\n*          if m < n, the diagonal and the first subdiagonal are\n*            overwritten with the lower bidiagonal matrix B; the\n*            elements below the first subdiagonal, with the array TAUQ,\n*            represent the unitary matrix Q as a product of\n*            elementary reflectors, and the elements above the diagonal,\n*            with the array TAUP, represent the unitary matrix P as\n*            a product of elementary reflectors.\n*          See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  D       (output) DOUBLE PRECISION array, dimension (min(M,N))\n*          The diagonal elements of the bidiagonal matrix B:\n*          D(i) = A(i,i).\n*\n*  E       (output) DOUBLE PRECISION array, dimension (min(M,N)-1)\n*          The off-diagonal elements of the bidiagonal matrix B:\n*          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n*          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n*\n*  TAUQ    (output) COMPLEX*16 array dimension (min(M,N))\n*          The scalar factors of the elementary reflectors which\n*          represent the unitary matrix Q. See Further Details.\n*\n*  TAUP    (output) COMPLEX*16 array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors which\n*          represent the unitary matrix P. See Further Details.\n*\n*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of the array WORK.  LWORK >= max(1,M,N).\n*          For optimum performance LWORK >= (M+N)*NB, where NB\n*          is the 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 matrices Q and P are represented as products of elementary\n*  reflectors:\n*\n*  If m >= n,\n*\n*     Q = H(1) H(2) . . . H(n)  and  P = G(1) G(2) . . . G(n-1)\n*\n*  Each H(i) and G(i) has the form:\n*\n*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'\n*\n*  where tauq and taup are complex scalars, and v and u are complex\n*  vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in\n*  A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in\n*  A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n*  If m < n,\n*\n*     Q = H(1) H(2) . . . H(m-1)  and  P = G(1) G(2) . . . G(m)\n*\n*  Each H(i) and G(i) has the form:\n*\n*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'\n*\n*  where tauq and taup are complex scalars, and v and u are complex\n*  vectors; v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in\n*  A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in\n*  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n*  The contents of A on exit are illustrated by the following examples:\n*\n*  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):\n*\n*    (  d   e   u1  u1  u1 )           (  d   u1  u1  u1  u1  u1 )\n*    (  v1  d   e   u2  u2 )           (  e   d   u2  u2  u2  u2 )\n*    (  v1  v2  d   e   u3 )           (  v1  e   d   u3  u3  u3 )\n*    (  v1  v2  v3  d   e  )           (  v1  v2  e   d   u4  u4 )\n*    (  v1  v2  v3  v4  d  )           (  v1  v2  v3  e   d   u5 )\n*    (  v1  v2  v3  v4  v5 )\n*\n*  where d and e denote diagonal and off-diagonal elements of B, vi\n*  denotes an element of the vector defining H(i), and ui an element of\n*  the vector defining G(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, tauq, taup, work, info, a = NumRu::Lapack.zgebrd( 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;
  }

  m = NUM2INT(rblapack_m);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (rblapack_lwork == Qnil)
    lwork = MAX(m,n);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n)-1;
    rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tauq = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  tauq = NA_PTR_TYPE(rblapack_tauq, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_taup = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  taup = NA_PTR_TYPE(rblapack_taup, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zgebrd_(&m, &n, a, &lda, d, e, tauq, taup, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_d, rblapack_e, rblapack_tauq, rblapack_taup, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_zgebrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgebrd", rblapack_zgebrd, -1);
}
ruby-lapack-1.7.2/ext/dorgtr.c0000644000175000017500000001254612502221023016031 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dorgtr_(char* uplo, integer* n, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dorgtr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_lwork;
  integer lwork; 
  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  work, info, a = NumRu::Lapack.dorgtr( uplo, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DORGTR generates a real orthogonal matrix Q which is defined as the\n*  product of n-1 elementary reflectors of order N, as returned by\n*  DSYTRD:\n*\n*  if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),\n*\n*  if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U': Upper triangle of A contains elementary reflectors\n*                 from DSYTRD;\n*          = 'L': Lower triangle of A contains elementary reflectors\n*                 from DSYTRD.\n*\n*  N       (input) INTEGER\n*          The order of the matrix Q. N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the vectors which define the elementary reflectors,\n*          as returned by DSYTRD.\n*          On exit, the N-by-N orthogonal matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  TAU     (input) DOUBLE PRECISION array, dimension (N-1)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by DSYTRD.\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,N-1).\n*          For optimum performance LWORK >= (N-1)*NB, where NB is\n*          the 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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, a = NumRu::Lapack.dorgtr( uplo, a, tau, [: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_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_tau = 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;
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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*);
  if (rblapack_lwork == Qnil)
    lwork = n-1;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_tau) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", n-1);
  if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;

  dorgtr_(&uplo, &n, a, &lda, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_dorgtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dorgtr", rblapack_dorgtr, -1);
}
ruby-lapack-1.7.2/ext/zla_rpvgrw.c0000644000175000017500000001022112502221015016712 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal zla_rpvgrw_(integer* n, integer* ncols, doublereal* a, integer* lda, doublereal* af, integer* ldaf);


static VALUE
rblapack_zla_rpvgrw(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ncols;
  integer ncols; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_af;
  doublereal *af; 
  VALUE rblapack___out__;
  doublereal __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  __out__ = NumRu::Lapack.zla_rpvgrw( ncols, a, af, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION ZLA_RPVGRW( N, NCOLS, A, LDA, AF, LDAF )\n\n*  Purpose\n*  =======\n* \n*  ZLA_RPVGRW computes the reciprocal pivot growth factor\n*  norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n*  much less than 1, the stability of the LU factorization of the\n*  (equilibrated) matrix A could be poor. This also means that the\n*  solution X, estimated condition numbers, and error bounds could be\n*  unreliable.\n*\n\n*  Arguments\n*  =========\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NCOLS   (input) INTEGER\n*     The number of columns of the matrix A. NCOLS >= 0.\n*\n*     A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) DOUBLE PRECISION array, dimension (LDAF,N)\n*     The factors L and U from the factorization\n*     A = P*L*U as computed by ZGETRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n      DOUBLE PRECISION   AMAX, UMAX, RPVGRW\n      COMPLEX*16         ZDUM\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MIN, ABS, REAL, DIMAG\n*     ..\n*     .. Statement Functions ..\n      DOUBLE PRECISION   CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.zla_rpvgrw( ncols, a, af, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_ncols = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  ncols = NUM2INT(rblapack_ncols);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_DFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
  af = NA_PTR_TYPE(rblapack_af, doublereal*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);

  __out__ = zla_rpvgrw_(&n, &ncols, a, &lda, af, &ldaf);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_zla_rpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zla_rpvgrw", rblapack_zla_rpvgrw, -1);
}
ruby-lapack-1.7.2/ext/clacrt.c0000644000175000017500000001122712502221021015771 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clacrt_(integer* n, complex* cx, integer* incx, complex* cy, integer* incy, complex* c, complex* s);


static VALUE
rblapack_clacrt(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_cx;
  complex *cx; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_cy;
  complex *cy; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_c;
  complex c; 
  VALUE rblapack_s;
  complex s; 
  VALUE rblapack_cx_out__;
  complex *cx_out__;
  VALUE rblapack_cy_out__;
  complex *cy_out__;

  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  cx, cy = NumRu::Lapack.clacrt( cx, incx, cy, incy, c, s, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLACRT( N, CX, INCX, CY, INCY, C, S )\n\n*  Purpose\n*  =======\n*\n*  CLACRT performs the operation\n*\n*     (  c  s )( x )  ==> ( x )\n*     ( -s  c )( y )      ( y )\n*\n*  where c and s are complex and the vectors x and y are complex.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of elements in the vectors CX and CY.\n*\n*  CX      (input/output) COMPLEX array, dimension (N)\n*          On input, the vector x.\n*          On output, CX is overwritten with c*x + s*y.\n*\n*  INCX    (input) INTEGER\n*          The increment between successive values of CX.  INCX <> 0.\n*\n*  CY      (input/output) COMPLEX array, dimension (N)\n*          On input, the vector y.\n*          On output, CY is overwritten with -s*x + c*y.\n*\n*  INCY    (input) INTEGER\n*          The increment between successive values of CY.  INCY <> 0.\n*\n*  C       (input) COMPLEX\n*  S       (input) COMPLEX\n*          C and S define the matrix\n*             [  C   S  ].\n*             [ -S   C  ]\n*\n\n* =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, IX, IY\n      COMPLEX            CTEMP\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  cx, cy = NumRu::Lapack.clacrt( cx, incx, cy, incy, c, s, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_cx = argv[0];
  rblapack_incx = argv[1];
  rblapack_cy = argv[2];
  rblapack_incy = argv[3];
  rblapack_c = argv[4];
  rblapack_s = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_cx))
    rb_raise(rb_eArgError, "cx (1th argument) must be NArray");
  if (NA_RANK(rblapack_cx) != 1)
    rb_raise(rb_eArgError, "rank of cx (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_cx);
  if (NA_TYPE(rblapack_cx) != NA_SCOMPLEX)
    rblapack_cx = na_change_type(rblapack_cx, NA_SCOMPLEX);
  cx = NA_PTR_TYPE(rblapack_cx, complex*);
  if (!NA_IsNArray(rblapack_cy))
    rb_raise(rb_eArgError, "cy (3th argument) must be NArray");
  if (NA_RANK(rblapack_cy) != 1)
    rb_raise(rb_eArgError, "rank of cy (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_cy) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of cy must be the same as shape 0 of cx");
  if (NA_TYPE(rblapack_cy) != NA_SCOMPLEX)
    rblapack_cy = na_change_type(rblapack_cy, NA_SCOMPLEX);
  cy = NA_PTR_TYPE(rblapack_cy, complex*);
  c.r = (real)NUM2DBL(rb_funcall(rblapack_c, rb_intern("real"), 0));
  c.i = (real)NUM2DBL(rb_funcall(rblapack_c, rb_intern("imag"), 0));
  incx = NUM2INT(rblapack_incx);
  s.r = (real)NUM2DBL(rb_funcall(rblapack_s, rb_intern("real"), 0));
  s.i = (real)NUM2DBL(rb_funcall(rblapack_s, rb_intern("imag"), 0));
  incy = NUM2INT(rblapack_incy);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_cx_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  cx_out__ = NA_PTR_TYPE(rblapack_cx_out__, complex*);
  MEMCPY(cx_out__, cx, complex, NA_TOTAL(rblapack_cx));
  rblapack_cx = rblapack_cx_out__;
  cx = cx_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_cy_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  cy_out__ = NA_PTR_TYPE(rblapack_cy_out__, complex*);
  MEMCPY(cy_out__, cy, complex, NA_TOTAL(rblapack_cy));
  rblapack_cy = rblapack_cy_out__;
  cy = cy_out__;

  clacrt_(&n, cx, &incx, cy, &incy, &c, &s);

  return rb_ary_new3(2, rblapack_cx, rblapack_cy);
}

void
init_lapack_clacrt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clacrt", rblapack_clacrt, -1);
}
ruby-lapack-1.7.2/ext/cgttrs.c0000644000175000017500000001646512502221025016044 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgttrs_(char* trans, integer* n, integer* nrhs, complex* dl, complex* d, complex* du, complex* du2, integer* ipiv, complex* b, integer* ldb, integer* info);


static VALUE
rblapack_cgttrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_dl;
  complex *dl; 
  VALUE rblapack_d;
  complex *d; 
  VALUE rblapack_du;
  complex *du; 
  VALUE rblapack_du2;
  complex *du2; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.cgttrs( trans, dl, d, du, du2, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGTTRS solves one of the systems of equations\n*     A * X = B,  A**T * X = B,  or  A**H * X = B,\n*  with a tridiagonal matrix A using the LU factorization computed\n*  by CGTTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations.\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  DL      (input) COMPLEX array, dimension (N-1)\n*          The (n-1) multipliers that define the matrix L from the\n*          LU factorization of A.\n*\n*  D       (input) COMPLEX array, dimension (N)\n*          The n diagonal elements of the upper triangular matrix U from\n*          the LU factorization of A.\n*\n*  DU      (input) COMPLEX array, dimension (N-1)\n*          The (n-1) elements of the first super-diagonal of U.\n*\n*  DU2     (input) COMPLEX array, dimension (N-2)\n*          The (n-2) elements of the second super-diagonal of U.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices; for 1 <= i <= n, row i of the matrix was\n*          interchanged with row IPIV(i).  IPIV(i) will always be either\n*          i or i+1; IPIV(i) = i indicates a row interchange was not\n*          required.\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the matrix of right hand side vectors B.\n*          On exit, B is overwritten by the solution vectors X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -k, the k-th argument had an illegal value\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            NOTRAN\n      INTEGER            ITRANS, J, JB, NB\n*     ..\n*     .. External Functions ..\n      INTEGER            ILAENV\n      EXTERNAL           ILAENV\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CGTTS2, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.cgttrs( trans, dl, d, du, du2, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_trans = argv[0];
  rblapack_dl = argv[1];
  rblapack_d = argv[2];
  rblapack_du = argv[3];
  rblapack_du2 = argv[4];
  rblapack_ipiv = argv[5];
  rblapack_b = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SCOMPLEX)
    rblapack_d = na_change_type(rblapack_d, NA_SCOMPLEX);
  d = NA_PTR_TYPE(rblapack_d, complex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_SCOMPLEX)
    rblapack_dl = na_change_type(rblapack_dl, NA_SCOMPLEX);
  dl = NA_PTR_TYPE(rblapack_dl, complex*);
  if (!NA_IsNArray(rblapack_du2))
    rb_raise(rb_eArgError, "du2 (5th argument) must be NArray");
  if (NA_RANK(rblapack_du2) != 1)
    rb_raise(rb_eArgError, "rank of du2 (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du2) != (n-2))
    rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
  if (NA_TYPE(rblapack_du2) != NA_SCOMPLEX)
    rblapack_du2 = na_change_type(rblapack_du2, NA_SCOMPLEX);
  du2 = NA_PTR_TYPE(rblapack_du2, complex*);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (4th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_SCOMPLEX)
    rblapack_du = na_change_type(rblapack_du, NA_SCOMPLEX);
  du = NA_PTR_TYPE(rblapack_du, complex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  cgttrs_(&trans, &n, &nrhs, dl, d, du, du2, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_cgttrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgttrs", rblapack_cgttrs, -1);
}
ruby-lapack-1.7.2/ext/dla_gerfsx_extended.c0000644000175000017500000005643312502221017020534 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dla_gerfsx_extended_(integer* prec_type, integer* trans_type, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* af, integer* ldaf, integer* ipiv, logical* colequ, doublereal* c, doublereal* b, integer* ldb, doublereal* y, integer* ldy, doublereal* berr_out, integer* n_norms, doublereal* errs_n, doublereal* errs_c, doublereal* res, doublereal* ayb, doublereal* dy, doublereal* y_tail, doublereal* rcond, integer* ithresh, doublereal* rthresh, doublereal* dz_ub, logical* ignore_cwise, integer* info);


static VALUE
rblapack_dla_gerfsx_extended(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_prec_type;
  integer prec_type; 
  VALUE rblapack_trans_type;
  integer trans_type; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_af;
  doublereal *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_colequ;
  logical colequ; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_y;
  doublereal *y; 
  VALUE rblapack_errs_n;
  doublereal *errs_n; 
  VALUE rblapack_errs_c;
  doublereal *errs_c; 
  VALUE rblapack_res;
  doublereal *res; 
  VALUE rblapack_ayb;
  doublereal *ayb; 
  VALUE rblapack_dy;
  doublereal *dy; 
  VALUE rblapack_y_tail;
  doublereal *y_tail; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_ithresh;
  integer ithresh; 
  VALUE rblapack_rthresh;
  doublereal rthresh; 
  VALUE rblapack_dz_ub;
  doublereal dz_ub; 
  VALUE rblapack_ignore_cwise;
  logical ignore_cwise; 
  VALUE rblapack_berr_out;
  doublereal *berr_out; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_y_out__;
  doublereal *y_out__;
  VALUE rblapack_errs_n_out__;
  doublereal *errs_n_out__;
  VALUE rblapack_errs_c_out__;
  doublereal *errs_c_out__;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldy;
  integer n_norms;

  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  berr_out, info, y, errs_n, errs_c = NumRu::Lapack.dla_gerfsx_extended( prec_type, trans_type, a, af, ipiv, colequ, c, b, y, errs_n, errs_c, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERRS_N, ERRS_C, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n*  Purpose\n*  =======\n* \n*  DLA_GERFSX_EXTENDED improves the computed solution to a system of\n*  linear equations by performing extra-precise iterative refinement\n*  and provides error bounds and backward error estimates for the solution.\n*  This subroutine is called by DGERFSX to perform iterative refinement.\n*  In addition to normwise error bound, the code provides maximum\n*  componentwise error bound if possible. See comments for ERR_BNDS_NORM\n*  and ERR_BNDS_COMP for details of the error bounds. Note that this\n*  subroutine is only resonsible for setting the second fields of\n*  ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n*  Arguments\n*  =========\n*\n*     PREC_TYPE      (input) INTEGER\n*     Specifies the intermediate precision to be used in refinement.\n*     The value is defined by ILAPREC(P) where P is a CHARACTER and\n*     P    = 'S':  Single\n*          = 'D':  Double\n*          = 'I':  Indigenous\n*          = 'X', 'E':  Extra\n*\n*     TRANS_TYPE     (input) INTEGER\n*     Specifies the transposition operation on A.\n*     The value is defined by ILATRANS(T) where T is a CHARACTER and\n*     T    = 'N':  No transpose\n*          = 'T':  Transpose\n*          = 'C':  Conjugate transpose\n*\n*     N              (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NRHS           (input) INTEGER\n*     The number of right-hand-sides, i.e., the number of columns of the\n*     matrix B.\n*\n*     A              (input) DOUBLE PRECISION array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA            (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF             (input) DOUBLE PRECISION array, dimension (LDAF,N)\n*     The factors L and U from the factorization\n*     A = P*L*U as computed by DGETRF.\n*\n*     LDAF           (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV           (input) INTEGER array, dimension (N)\n*     The pivot indices from the factorization A = P*L*U\n*     as computed by DGETRF; row i of the matrix was interchanged\n*     with row IPIV(i).\n*\n*     COLEQU         (input) LOGICAL\n*     If .TRUE. then column equilibration was done to A before calling\n*     this routine. This is needed to compute the solution and error\n*     bounds correctly.\n*\n*     C              (input) DOUBLE PRECISION  array, dimension (N)\n*     The column scale factors for A. If COLEQU = .FALSE., C\n*     is not accessed. If C is input, each element of C should be a power\n*     of the radix to ensure a reliable solution and error estimates.\n*     Scaling by powers of the radix does not cause rounding errors unless\n*     the result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B              (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*     The right-hand-side matrix B.\n*\n*     LDB            (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     Y              (input/output) DOUBLE PRECISION array, dimension\n*                    (LDY,NRHS)\n*     On entry, the solution matrix X, as computed by DGETRS.\n*     On exit, the improved solution matrix Y.\n*\n*     LDY            (input) INTEGER\n*     The leading dimension of the array Y.  LDY >= max(1,N).\n*\n*     BERR_OUT       (output) DOUBLE PRECISION array, dimension (NRHS)\n*     On exit, BERR_OUT(j) contains the componentwise relative backward\n*     error for right-hand-side j from the formula\n*         max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n*     where abs(Z) is the componentwise absolute value of the matrix\n*     or vector Z. This is computed by DLA_LIN_BERR.\n*\n*     N_NORMS        (input) INTEGER\n*     Determines which error bounds to return (see ERR_BNDS_NORM\n*     and ERR_BNDS_COMP).\n*     If N_NORMS >= 1 return normwise error bounds.\n*     If N_NORMS >= 2 return componentwise error bounds.\n*\n*     ERR_BNDS_NORM  (input/output) DOUBLE PRECISION array, dimension\n*                    (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (input/output) DOUBLE PRECISION array, dimension\n*                    (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     RES            (input) DOUBLE PRECISION array, dimension (N)\n*     Workspace to hold the intermediate residual.\n*\n*     AYB            (input) DOUBLE PRECISION array, dimension (N)\n*     Workspace. This can be the same workspace passed for Y_TAIL.\n*\n*     DY             (input) DOUBLE PRECISION array, dimension (N)\n*     Workspace to hold the intermediate solution.\n*\n*     Y_TAIL         (input) DOUBLE PRECISION array, dimension (N)\n*     Workspace to hold the trailing bits of the intermediate solution.\n*\n*     RCOND          (input) DOUBLE PRECISION\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     ITHRESH        (input) INTEGER\n*     The maximum number of residual computations allowed for\n*     refinement. The default is 10. For 'aggressive' set to 100 to\n*     permit convergence using approximate factorizations or\n*     factorizations other than LU. If the factorization uses a\n*     technique other than Gaussian elimination, the guarantees in\n*     ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n*     RTHRESH        (input) DOUBLE PRECISION\n*     Determines when to stop refinement if the error estimate stops\n*     decreasing. Refinement will stop when the next solution no longer\n*     satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n*     the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n*     default value is 0.5. For 'aggressive' set to 0.9 to permit\n*     convergence on extremely ill-conditioned matrices. See LAWN 165\n*     for more details.\n*\n*     DZ_UB          (input) DOUBLE PRECISION\n*     Determines when to start considering componentwise convergence.\n*     Componentwise convergence is only considered after each component\n*     of the solution Y is stable, which we definte as the relative\n*     change in each component being less than DZ_UB. The default value\n*     is 0.25, requiring the first bit to be stable. See LAWN 165 for\n*     more details.\n*\n*     IGNORE_CWISE   (input) LOGICAL\n*     If .TRUE. then ignore componentwise convergence. Default value\n*     is .FALSE..\n*\n*     INFO           (output) INTEGER\n*       = 0:  Successful exit.\n*       < 0:  if INFO = -i, the ith argument to DGETRS had an illegal\n*             value\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      CHARACTER          TRANS\n      INTEGER            CNT, I, J, X_STATE, Z_STATE, Y_PREC_STATE\n      DOUBLE PRECISION   YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n     $                   DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n     $                   DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n     $                   EPS, HUGEVAL, INCR_THRESH\n      LOGICAL            INCR_PREC\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  berr_out, info, y, errs_n, errs_c = NumRu::Lapack.dla_gerfsx_extended( prec_type, trans_type, a, af, ipiv, colequ, c, b, y, errs_n, errs_c, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 20 && argc != 20)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 20)", argc);
  rblapack_prec_type = argv[0];
  rblapack_trans_type = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_colequ = argv[5];
  rblapack_c = argv[6];
  rblapack_b = argv[7];
  rblapack_y = argv[8];
  rblapack_errs_n = argv[9];
  rblapack_errs_c = argv[10];
  rblapack_res = argv[11];
  rblapack_ayb = argv[12];
  rblapack_dy = argv[13];
  rblapack_y_tail = argv[14];
  rblapack_rcond = argv[15];
  rblapack_ithresh = argv[16];
  rblapack_rthresh = argv[17];
  rblapack_dz_ub = argv[18];
  rblapack_ignore_cwise = argv[19];
  if (argc == 20) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  prec_type = NUM2INT(rblapack_prec_type);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (9th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 2)
    rb_raise(rb_eArgError, "rank of y (9th argument) must be %d", 2);
  ldy = NA_SHAPE0(rblapack_y);
  nrhs = NA_SHAPE1(rblapack_y);
  if (NA_TYPE(rblapack_y) != NA_DFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
  y = NA_PTR_TYPE(rblapack_y, doublereal*);
  if (!NA_IsNArray(rblapack_res))
    rb_raise(rb_eArgError, "res (12th argument) must be NArray");
  if (NA_RANK(rblapack_res) != 1)
    rb_raise(rb_eArgError, "rank of res (12th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_res) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_res) != NA_DFLOAT)
    rblapack_res = na_change_type(rblapack_res, NA_DFLOAT);
  res = NA_PTR_TYPE(rblapack_res, doublereal*);
  if (!NA_IsNArray(rblapack_dy))
    rb_raise(rb_eArgError, "dy (14th argument) must be NArray");
  if (NA_RANK(rblapack_dy) != 1)
    rb_raise(rb_eArgError, "rank of dy (14th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dy) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_dy) != NA_DFLOAT)
    rblapack_dy = na_change_type(rblapack_dy, NA_DFLOAT);
  dy = NA_PTR_TYPE(rblapack_dy, doublereal*);
  rcond = NUM2DBL(rblapack_rcond);
  rthresh = NUM2DBL(rblapack_rthresh);
  ignore_cwise = (rblapack_ignore_cwise == Qtrue);
  trans_type = NUM2INT(rblapack_trans_type);
  colequ = (rblapack_colequ == Qtrue);
  if (!NA_IsNArray(rblapack_ayb))
    rb_raise(rb_eArgError, "ayb (13th argument) must be NArray");
  if (NA_RANK(rblapack_ayb) != 1)
    rb_raise(rb_eArgError, "rank of ayb (13th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ayb) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ayb) != NA_DFLOAT)
    rblapack_ayb = na_change_type(rblapack_ayb, NA_DFLOAT);
  ayb = NA_PTR_TYPE(rblapack_ayb, doublereal*);
  ithresh = NUM2INT(rblapack_ithresh);
  n_norms = 3;
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
  af = NA_PTR_TYPE(rblapack_af, doublereal*);
  if (!NA_IsNArray(rblapack_errs_n))
    rb_raise(rb_eArgError, "errs_n (10th argument) must be NArray");
  if (NA_RANK(rblapack_errs_n) != 2)
    rb_raise(rb_eArgError, "rank of errs_n (10th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_errs_n) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of errs_n must be the same as shape 1 of y");
  if (NA_SHAPE1(rblapack_errs_n) != n_norms)
    rb_raise(rb_eRuntimeError, "shape 1 of errs_n must be 3");
  if (NA_TYPE(rblapack_errs_n) != NA_DFLOAT)
    rblapack_errs_n = na_change_type(rblapack_errs_n, NA_DFLOAT);
  errs_n = NA_PTR_TYPE(rblapack_errs_n, doublereal*);
  if (!NA_IsNArray(rblapack_y_tail))
    rb_raise(rb_eArgError, "y_tail (15th argument) must be NArray");
  if (NA_RANK(rblapack_y_tail) != 1)
    rb_raise(rb_eArgError, "rank of y_tail (15th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y_tail) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_y_tail) != NA_DFLOAT)
    rblapack_y_tail = na_change_type(rblapack_y_tail, NA_DFLOAT);
  y_tail = NA_PTR_TYPE(rblapack_y_tail, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of y");
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  dz_ub = NUM2DBL(rblapack_dz_ub);
  if (!NA_IsNArray(rblapack_errs_c))
    rb_raise(rb_eArgError, "errs_c (11th argument) must be NArray");
  if (NA_RANK(rblapack_errs_c) != 2)
    rb_raise(rb_eArgError, "rank of errs_c (11th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_errs_c) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of errs_c must be the same as shape 1 of y");
  if (NA_SHAPE1(rblapack_errs_c) != n_norms)
    rb_raise(rb_eRuntimeError, "shape 1 of errs_c must be 3");
  if (NA_TYPE(rblapack_errs_c) != NA_DFLOAT)
    rblapack_errs_c = na_change_type(rblapack_errs_c, NA_DFLOAT);
  errs_c = NA_PTR_TYPE(rblapack_errs_c, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr_out = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr_out = NA_PTR_TYPE(rblapack_berr_out, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldy;
    shape[1] = nrhs;
    rblapack_y_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
  MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_norms;
    rblapack_errs_n_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  errs_n_out__ = NA_PTR_TYPE(rblapack_errs_n_out__, doublereal*);
  MEMCPY(errs_n_out__, errs_n, doublereal, NA_TOTAL(rblapack_errs_n));
  rblapack_errs_n = rblapack_errs_n_out__;
  errs_n = errs_n_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_norms;
    rblapack_errs_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  errs_c_out__ = NA_PTR_TYPE(rblapack_errs_c_out__, doublereal*);
  MEMCPY(errs_c_out__, errs_c, doublereal, NA_TOTAL(rblapack_errs_c));
  rblapack_errs_c = rblapack_errs_c_out__;
  errs_c = errs_c_out__;

  dla_gerfsx_extended_(&prec_type, &trans_type, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, errs_n, errs_c, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_errs_n, rblapack_errs_c);
}

void
init_lapack_dla_gerfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dla_gerfsx_extended", rblapack_dla_gerfsx_extended, -1);
}
ruby-lapack-1.7.2/ext/stgsja.c0000644000175000017500000003724212502221013016022 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID stgsja_(char* jobu, char* jobv, char* jobq, integer* m, integer* p, integer* n, integer* k, integer* l, real* a, integer* lda, real* b, integer* ldb, real* tola, real* tolb, real* alpha, real* beta, real* u, integer* ldu, real* v, integer* ldv, real* q, integer* ldq, real* work, integer* ncycle, integer* info);


static VALUE
rblapack_stgsja(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobu;
  char jobu; 
  VALUE rblapack_jobv;
  char jobv; 
  VALUE rblapack_jobq;
  char jobq; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_tola;
  real tola; 
  VALUE rblapack_tolb;
  real tolb; 
  VALUE rblapack_u;
  real *u; 
  VALUE rblapack_v;
  real *v; 
  VALUE rblapack_q;
  real *q; 
  VALUE rblapack_alpha;
  real *alpha; 
  VALUE rblapack_beta;
  real *beta; 
  VALUE rblapack_ncycle;
  integer ncycle; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_b_out__;
  real *b_out__;
  VALUE rblapack_u_out__;
  real *u_out__;
  VALUE rblapack_v_out__;
  real *v_out__;
  VALUE rblapack_q_out__;
  real *q_out__;
  real *work;

  integer lda;
  integer n;
  integer ldb;
  integer ldu;
  integer m;
  integer ldv;
  integer p;
  integer ldq;

  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  alpha, beta, ncycle, info, a, b, u, v, q = NumRu::Lapack.stgsja( jobu, jobv, jobq, k, l, a, b, tola, tolb, u, v, q, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, NCYCLE, INFO )\n\n*  Purpose\n*  =======\n*\n*  STGSJA computes the generalized singular value decomposition (GSVD)\n*  of two real upper triangular (or trapezoidal) matrices A and B.\n*\n*  On entry, it is assumed that matrices A and B have the following\n*  forms, which may be obtained by the preprocessing subroutine SGGSVP\n*  from a general M-by-N matrix A and P-by-N matrix B:\n*\n*               N-K-L  K    L\n*     A =    K ( 0    A12  A13 ) if M-K-L >= 0;\n*            L ( 0     0   A23 )\n*        M-K-L ( 0     0    0  )\n*\n*             N-K-L  K    L\n*     A =  K ( 0    A12  A13 ) if M-K-L < 0;\n*        M-K ( 0     0   A23 )\n*\n*             N-K-L  K    L\n*     B =  L ( 0     0   B13 )\n*        P-L ( 0     0    0  )\n*\n*  where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n*  upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n*  otherwise A23 is (M-K)-by-L upper trapezoidal.\n*\n*  On exit,\n*\n*              U'*A*Q = D1*( 0 R ),    V'*B*Q = D2*( 0 R ),\n*\n*  where U, V and Q are orthogonal matrices, Z' denotes the transpose\n*  of Z, R is a nonsingular upper triangular matrix, and D1 and D2 are\n*  ``diagonal'' matrices, which are of the following structures:\n*\n*  If M-K-L >= 0,\n*\n*                      K  L\n*         D1 =     K ( I  0 )\n*                  L ( 0  C )\n*              M-K-L ( 0  0 )\n*\n*                    K  L\n*         D2 = L   ( 0  S )\n*              P-L ( 0  0 )\n*\n*                 N-K-L  K    L\n*    ( 0 R ) = K (  0   R11  R12 ) K\n*              L (  0    0   R22 ) L\n*\n*  where\n*\n*    C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n*    S = diag( BETA(K+1),  ... , BETA(K+L) ),\n*    C**2 + S**2 = I.\n*\n*    R is stored in A(1:K+L,N-K-L+1:N) on exit.\n*\n*  If M-K-L < 0,\n*\n*                 K M-K K+L-M\n*      D1 =   K ( I  0    0   )\n*           M-K ( 0  C    0   )\n*\n*                   K M-K K+L-M\n*      D2 =   M-K ( 0  S    0   )\n*           K+L-M ( 0  0    I   )\n*             P-L ( 0  0    0   )\n*\n*                 N-K-L  K   M-K  K+L-M\n* ( 0 R ) =    K ( 0    R11  R12  R13  )\n*            M-K ( 0     0   R22  R23  )\n*          K+L-M ( 0     0    0   R33  )\n*\n*  where\n*  C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n*  S = diag( BETA(K+1),  ... , BETA(M) ),\n*  C**2 + S**2 = I.\n*\n*  R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored\n*      (  0  R22 R23 )\n*  in B(M-K+1:L,N+M-K-L+1:N) on exit.\n*\n*  The computation of the orthogonal transformation matrices U, V or Q\n*  is optional.  These matrices may either be formed explicitly, or they\n*  may be postmultiplied into input matrices U1, V1, or Q1.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBU    (input) CHARACTER*1\n*          = 'U':  U must contain an orthogonal matrix U1 on entry, and\n*                  the product U1*U is returned;\n*          = 'I':  U is initialized to the unit matrix, and the\n*                  orthogonal matrix U is returned;\n*          = 'N':  U is not computed.\n*\n*  JOBV    (input) CHARACTER*1\n*          = 'V':  V must contain an orthogonal matrix V1 on entry, and\n*                  the product V1*V is returned;\n*          = 'I':  V is initialized to the unit matrix, and the\n*                  orthogonal matrix V is returned;\n*          = 'N':  V is not computed.\n*\n*  JOBQ    (input) CHARACTER*1\n*          = 'Q':  Q must contain an orthogonal matrix Q1 on entry, and\n*                  the product Q1*Q is returned;\n*          = 'I':  Q is initialized to the unit matrix, and the\n*                  orthogonal matrix Q is returned;\n*          = 'N':  Q is not computed.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.  M >= 0.\n*\n*  P       (input) INTEGER\n*          The number of rows of the matrix B.  P >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrices A and B.  N >= 0.\n*\n*  K       (input) INTEGER\n*  L       (input) INTEGER\n*          K and L specify the subblocks in the input matrices A and B:\n*          A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,N-L+1:N)\n*          of A and B, whose GSVD is going to be computed by STGSJA.\n*          See Further Details.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular\n*          matrix R or part of R.  See Purpose for details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  B       (input/output) REAL array, dimension (LDB,N)\n*          On entry, the P-by-N matrix B.\n*          On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains\n*          a part of R.  See Purpose for details.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,P).\n*\n*  TOLA    (input) REAL\n*  TOLB    (input) REAL\n*          TOLA and TOLB are the convergence criteria for the Jacobi-\n*          Kogbetliantz iteration procedure. Generally, they are the\n*          same as used in the preprocessing step, say\n*              TOLA = max(M,N)*norm(A)*MACHEPS,\n*              TOLB = max(P,N)*norm(B)*MACHEPS.\n*\n*  ALPHA   (output) REAL array, dimension (N)\n*  BETA    (output) REAL array, dimension (N)\n*          On exit, ALPHA and BETA contain the generalized singular\n*          value pairs of A and B;\n*            ALPHA(1:K) = 1,\n*            BETA(1:K)  = 0,\n*          and if M-K-L >= 0,\n*            ALPHA(K+1:K+L) = diag(C),\n*            BETA(K+1:K+L)  = diag(S),\n*          or if M-K-L < 0,\n*            ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0\n*            BETA(K+1:M) = S, BETA(M+1:K+L) = 1.\n*          Furthermore, if K+L < N,\n*            ALPHA(K+L+1:N) = 0 and\n*            BETA(K+L+1:N)  = 0.\n*\n*  U       (input/output) REAL array, dimension (LDU,M)\n*          On entry, if JOBU = 'U', U must contain a matrix U1 (usually\n*          the orthogonal matrix returned by SGGSVP).\n*          On exit,\n*          if JOBU = 'I', U contains the orthogonal matrix U;\n*          if JOBU = 'U', U contains the product U1*U.\n*          If JOBU = 'N', U is not referenced.\n*\n*  LDU     (input) INTEGER\n*          The leading dimension of the array U. LDU >= max(1,M) if\n*          JOBU = 'U'; LDU >= 1 otherwise.\n*\n*  V       (input/output) REAL array, dimension (LDV,P)\n*          On entry, if JOBV = 'V', V must contain a matrix V1 (usually\n*          the orthogonal matrix returned by SGGSVP).\n*          On exit,\n*          if JOBV = 'I', V contains the orthogonal matrix V;\n*          if JOBV = 'V', V contains the product V1*V.\n*          If JOBV = 'N', V is not referenced.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V. LDV >= max(1,P) if\n*          JOBV = 'V'; LDV >= 1 otherwise.\n*\n*  Q       (input/output) REAL array, dimension (LDQ,N)\n*          On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually\n*          the orthogonal matrix returned by SGGSVP).\n*          On exit,\n*          if JOBQ = 'I', Q contains the orthogonal matrix Q;\n*          if JOBQ = 'Q', Q contains the product Q1*Q.\n*          If JOBQ = 'N', Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q. LDQ >= max(1,N) if\n*          JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n*  WORK    (workspace) REAL array, dimension (2*N)\n*\n*  NCYCLE  (output) INTEGER\n*          The number of cycles required for convergence.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          = 1:  the procedure does not converge after MAXIT cycles.\n*\n*  Internal Parameters\n*  ===================\n*\n*  MAXIT   INTEGER\n*          MAXIT specifies the total loops that the iterative procedure\n*          may take. If after MAXIT cycles, the routine fails to\n*          converge, we return INFO = 1.\n*\n\n*  Further Details\n*  ===============\n*\n*  STGSJA essentially uses a variant of Kogbetliantz algorithm to reduce\n*  min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L\n*  matrix B13 to the form:\n*\n*           U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1,\n*\n*  where U1, V1 and Q1 are orthogonal matrix, and Z' is the transpose\n*  of Z.  C1 and S1 are diagonal matrices satisfying\n*\n*                C1**2 + S1**2 = I,\n*\n*  and R1 is an L-by-L nonsingular upper triangular matrix.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  alpha, beta, ncycle, info, a, b, u, v, q = NumRu::Lapack.stgsja( jobu, jobv, jobq, k, l, a, b, tola, tolb, u, v, q, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_jobu = argv[0];
  rblapack_jobv = argv[1];
  rblapack_jobq = argv[2];
  rblapack_k = argv[3];
  rblapack_l = argv[4];
  rblapack_a = argv[5];
  rblapack_b = argv[6];
  rblapack_tola = argv[7];
  rblapack_tolb = argv[8];
  rblapack_u = argv[9];
  rblapack_v = argv[10];
  rblapack_q = argv[11];
  if (argc == 12) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobu = StringValueCStr(rblapack_jobu)[0];
  jobq = StringValueCStr(rblapack_jobq)[0];
  l = NUM2INT(rblapack_l);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  tolb = (real)NUM2DBL(rblapack_tolb);
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (11th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (11th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  p = NA_SHAPE1(rblapack_v);
  if (NA_TYPE(rblapack_v) != NA_SFLOAT)
    rblapack_v = na_change_type(rblapack_v, NA_SFLOAT);
  v = NA_PTR_TYPE(rblapack_v, real*);
  jobv = StringValueCStr(rblapack_jobv)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (6th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (6th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_u))
    rb_raise(rb_eArgError, "u (10th argument) must be NArray");
  if (NA_RANK(rblapack_u) != 2)
    rb_raise(rb_eArgError, "rank of u (10th argument) must be %d", 2);
  ldu = NA_SHAPE0(rblapack_u);
  m = NA_SHAPE1(rblapack_u);
  if (NA_TYPE(rblapack_u) != NA_SFLOAT)
    rblapack_u = na_change_type(rblapack_u, NA_SFLOAT);
  u = NA_PTR_TYPE(rblapack_u, real*);
  k = NUM2INT(rblapack_k);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (12th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (12th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_q) != NA_SFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
  q = NA_PTR_TYPE(rblapack_q, real*);
  tola = (real)NUM2DBL(rblapack_tola);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alpha = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  alpha = NA_PTR_TYPE(rblapack_alpha, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = m;
    rblapack_u_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  u_out__ = NA_PTR_TYPE(rblapack_u_out__, real*);
  MEMCPY(u_out__, u, real, NA_TOTAL(rblapack_u));
  rblapack_u = rblapack_u_out__;
  u = u_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = p;
    rblapack_v_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  v_out__ = NA_PTR_TYPE(rblapack_v_out__, real*);
  MEMCPY(v_out__, v, real, NA_TOTAL(rblapack_v));
  rblapack_v = rblapack_v_out__;
  v = v_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
  MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  work = ALLOC_N(real, (2*n));

  stgsja_(&jobu, &jobv, &jobq, &m, &p, &n, &k, &l, a, &lda, b, &ldb, &tola, &tolb, alpha, beta, u, &ldu, v, &ldv, q, &ldq, work, &ncycle, &info);

  free(work);
  rblapack_ncycle = INT2NUM(ncycle);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_alpha, rblapack_beta, rblapack_ncycle, rblapack_info, rblapack_a, rblapack_b, rblapack_u, rblapack_v, rblapack_q);
}

void
init_lapack_stgsja(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "stgsja", rblapack_stgsja, -1);
}
ruby-lapack-1.7.2/ext/cla_geamv.c0000644000175000017500000001703512502221017016447 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cla_geamv_(integer* trans, integer* m, integer* n, real* alpha, complex* a, integer* lda, complex* x, integer* incx, real* beta, real* y, integer* incy);


static VALUE
rblapack_cla_geamv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  integer trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_alpha;
  real alpha; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_beta;
  real beta; 
  VALUE rblapack_y;
  real *y; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_y_out__;
  real *y_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  y = NumRu::Lapack.cla_geamv( trans, m, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n*  Purpose\n*  =======\n*\n*  CLA_GEAMV  performs one of the matrix-vector operations\n*\n*          y := alpha*abs(A)*abs(x) + beta*abs(y),\n*     or   y := alpha*abs(A)'*abs(x) + beta*abs(y),\n*\n*  where alpha and beta are scalars, x and y are vectors and A is an\n*  m by n matrix.\n*\n*  This function is primarily used in calculating error bounds.\n*  To protect against underflow during evaluation, components in\n*  the resulting vector are perturbed away from zero by (N+1)\n*  times the underflow threshold.  To prevent unnecessarily large\n*  errors for block-structure embedded in general matrices,\n*  \"symbolically\" zero components are not perturbed.  A zero\n*  entry is considered \"symbolic\" if all multiplications involved\n*  in computing that entry have at least one zero multiplicand.\n*\n\n*  Arguments\n*  ==========\n*\n*  TRANS   (input) INTEGER\n*           On entry, TRANS specifies the operation to be performed as\n*           follows:\n*\n*             BLAS_NO_TRANS      y := alpha*abs(A)*abs(x) + beta*abs(y)\n*             BLAS_TRANS         y := alpha*abs(A')*abs(x) + beta*abs(y)\n*             BLAS_CONJ_TRANS    y := alpha*abs(A')*abs(x) + beta*abs(y)\n*\n*           Unchanged on exit.\n*\n*  M       (input) INTEGER\n*           On entry, M specifies the number of rows of the matrix A.\n*           M must be at least zero.\n*           Unchanged on exit.\n*\n*  N       (input) INTEGER\n*           On entry, N specifies the number of columns of the matrix A.\n*           N must be at least zero.\n*           Unchanged on exit.\n*\n*  ALPHA   (input) REAL\n*           On entry, ALPHA specifies the scalar alpha.\n*           Unchanged on exit.\n*\n*  A       (input) COMPLEX array, dimension (LDA,n)\n*           Before entry, the leading m by n part of the array A must\n*           contain the matrix of coefficients.\n*           Unchanged on exit.\n*\n*  LDA     (input) INTEGER\n*           On entry, LDA specifies the first dimension of A as declared\n*           in the calling (sub) program. LDA must be at least\n*           max( 1, m ).\n*           Unchanged on exit.\n*\n*  X       (input) COMPLEX array, dimension\n*           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n*           and at least\n*           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n*           Before entry, the incremented array X must contain the\n*           vector x.\n*           Unchanged on exit.\n*\n*  INCX    (input) INTEGER\n*           On entry, INCX specifies the increment for the elements of\n*           X. INCX must not be zero.\n*           Unchanged on exit.\n*\n*  BETA    (input) REAL\n*           On entry, BETA specifies the scalar beta. When BETA is\n*           supplied as zero then Y need not be set on input.\n*           Unchanged on exit.\n*\n*  Y       (input/output) REAL array, dimension\n*           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n*           and at least\n*           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n*           Before entry with BETA non-zero, the incremented array Y\n*           must contain the vector y. On exit, Y is overwritten by the\n*           updated vector y.\n*\n*  INCY    (input) INTEGER\n*           On entry, INCY specifies the increment for the elements of\n*           Y. INCY must not be zero.\n*           Unchanged on exit.\n*\n*\n*  Level 2 Blas routine.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  y = NumRu::Lapack.cla_geamv( trans, m, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_trans = argv[0];
  rblapack_m = argv[1];
  rblapack_alpha = argv[2];
  rblapack_a = argv[3];
  rblapack_x = argv[4];
  rblapack_incx = argv[5];
  rblapack_beta = argv[6];
  rblapack_y = argv[7];
  rblapack_incy = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = NUM2INT(rblapack_trans);
  alpha = (real)NUM2DBL(rblapack_alpha);
  incx = NUM2INT(rblapack_incx);
  incy = NUM2INT(rblapack_incy);
  m = NUM2INT(rblapack_m);
  beta = (real)NUM2DBL(rblapack_beta);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (8th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy ));
  if (NA_TYPE(rblapack_y) != NA_SFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
  y = NA_PTR_TYPE(rblapack_y, real*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (5th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (trans == ilatrans_("N") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", trans == ilatrans_("N") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx ));
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[1];
    shape[0] = trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy );
    rblapack_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
  MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  cla_geamv_(&trans, &m, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);

  return rblapack_y;
}

void
init_lapack_cla_geamv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cla_geamv", rblapack_cla_geamv, -1);
}
ruby-lapack-1.7.2/ext/dlasd0.c0000644000175000017500000001510712502221013015672 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlasd0_(integer* n, integer* sqre, doublereal* d, doublereal* e, doublereal* u, integer* ldu, doublereal* vt, integer* ldvt, integer* smlsiz, integer* iwork, doublereal* work, integer* info);


static VALUE
rblapack_dlasd0(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_sqre;
  integer sqre; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_smlsiz;
  integer smlsiz; 
  VALUE rblapack_u;
  doublereal *u; 
  VALUE rblapack_vt;
  doublereal *vt; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  integer *iwork;
  doublereal *work;

  integer n;
  integer ldu;
  integer ldvt;
  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  u, vt, info, d = NumRu::Lapack.dlasd0( sqre, d, e, smlsiz, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  Using a divide and conquer approach, DLASD0 computes the singular\n*  value decomposition (SVD) of a real upper bidiagonal N-by-M\n*  matrix B with diagonal D and offdiagonal E, where M = N + SQRE.\n*  The algorithm computes orthogonal matrices U and VT such that\n*  B = U * S * VT. The singular values S are overwritten on D.\n*\n*  A related subroutine, DLASDA, computes only the singular values,\n*  and optionally, the singular vectors in compact form.\n*\n\n*  Arguments\n*  =========\n*\n*  N      (input) INTEGER\n*         On entry, the row dimension of the upper bidiagonal matrix.\n*         This is also the dimension of the main diagonal array D.\n*\n*  SQRE   (input) INTEGER\n*         Specifies the column dimension of the bidiagonal matrix.\n*         = 0: The bidiagonal matrix has column dimension M = N;\n*         = 1: The bidiagonal matrix has column dimension M = N+1;\n*\n*  D      (input/output) DOUBLE PRECISION array, dimension (N)\n*         On entry D contains the main diagonal of the bidiagonal\n*         matrix.\n*         On exit D, if INFO = 0, contains its singular values.\n*\n*  E      (input) DOUBLE PRECISION array, dimension (M-1)\n*         Contains the subdiagonal entries of the bidiagonal matrix.\n*         On exit, E has been destroyed.\n*\n*  U      (output) DOUBLE PRECISION array, dimension at least (LDQ, N)\n*         On exit, U contains the left singular vectors.\n*\n*  LDU    (input) INTEGER\n*         On entry, leading dimension of U.\n*\n*  VT     (output) DOUBLE PRECISION array, dimension at least (LDVT, M)\n*         On exit, VT' contains the right singular vectors.\n*\n*  LDVT   (input) INTEGER\n*         On entry, leading dimension of VT.\n*\n*  SMLSIZ (input) INTEGER\n*         On entry, maximum size of the subproblems at the\n*         bottom of the computation tree.\n*\n*  IWORK  (workspace) INTEGER work array.\n*         Dimension must be at least (8 * N)\n*\n*  WORK   (workspace) DOUBLE PRECISION work array.\n*         Dimension must be at least (3 * M**2 + 2 * M)\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 = 1, a singular value did not converge\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, I1, IC, IDXQ, IDXQC, IM1, INODE, ITEMP, IWK,\n     $                   J, LF, LL, LVL, M, NCC, ND, NDB1, NDIML, NDIMR,\n     $                   NL, NLF, NLP1, NLVL, NR, NRF, NRP1, SQREI\n      DOUBLE PRECISION   ALPHA, BETA\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DLASD1, DLASDQ, DLASDT, XERBLA\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  u, vt, info, d = NumRu::Lapack.dlasd0( sqre, d, e, smlsiz, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_sqre = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  rblapack_smlsiz = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  sqre = NUM2INT(rblapack_sqre);
  smlsiz = NUM2INT(rblapack_smlsiz);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  m = sqre == 0 ? n : sqre == 1 ? n+1 : 0;
  ldu = n;
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (m-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", m-1);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  ldvt = n;
  {
    na_shape_t 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*);
  {
    na_shape_t shape[2];
    shape[0] = ldvt;
    shape[1] = m;
    rblapack_vt = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vt = NA_PTR_TYPE(rblapack_vt, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  iwork = ALLOC_N(integer, ((8 * n)));
  work = ALLOC_N(doublereal, ((3 * pow(m,2) + 2 * m)));

  dlasd0_(&n, &sqre, d, e, u, &ldu, vt, &ldvt, &smlsiz, iwork, work, &info);

  free(iwork);
  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_u, rblapack_vt, rblapack_info, rblapack_d);
}

void
init_lapack_dlasd0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlasd0", rblapack_dlasd0, -1);
}
ruby-lapack-1.7.2/ext/zgeqrfp.c0000644000175000017500000001352012502221015016200 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgeqrfp_(integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zgeqrfp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *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.zgeqrfp( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGEQRFP computes a QR factorization of a complex M-by-N matrix A:\n*  A = Q * R.\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) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, the elements on and above the diagonal of the array\n*          contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n*          upper triangular if m >= n); the elements below the diagonal,\n*          with the array TAU, represent the unitary matrix Q as a\n*          product of min(m,n) elementary reflectors (see Further\n*          Details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  TAU     (output) COMPLEX*16 array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace/output) COMPLEX*16 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,N).\n*          For optimum performance LWORK >= N*NB, where NB is\n*          the 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(1) H(2) . . . H(k), 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 complex scalar, and v is a complex vector with\n*  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\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           XERBLA, ZGEQR2P, ZLARFB, ZLARFT\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.zgeqrfp( 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;
  }

  m = NUM2INT(rblapack_m);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zgeqrfp_(&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_zgeqrfp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgeqrfp", rblapack_zgeqrfp, -1);
}
ruby-lapack-1.7.2/ext/slatbs.c0000644000175000017500000002464112502221012016015 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slatbs_(char* uplo, char* trans, char* diag, char* normin, integer* n, integer* kd, real* ab, integer* ldab, real* x, real* scale, real* cnorm, integer* info);


static VALUE
rblapack_slatbs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_normin;
  char normin; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_cnorm;
  real *cnorm; 
  VALUE rblapack_scale;
  real scale; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  real *x_out__;
  VALUE rblapack_cnorm_out__;
  real *cnorm_out__;

  integer ldab;
  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  scale, info, x, cnorm = NumRu::Lapack.slatbs( uplo, trans, diag, normin, kd, ab, x, cnorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, SCALE, CNORM, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLATBS solves one of the triangular systems\n*\n*     A *x = s*b  or  A'*x = s*b\n*\n*  with scaling to prevent overflow, where A is an upper or lower\n*  triangular band matrix.  Here A' denotes the transpose of A, x and b\n*  are n-element vectors, and s is a scaling factor, usually less than\n*  or equal to 1, chosen so that the components of x will be less than\n*  the overflow threshold.  If the unscaled problem will not cause\n*  overflow, the Level 2 BLAS routine STBSV is called.  If the matrix A\n*  is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n*  non-trivial solution to A*x = 0 is returned.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the matrix A is upper or lower triangular.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the operation applied to A.\n*          = 'N':  Solve A * x = s*b  (No transpose)\n*          = 'T':  Solve A'* x = s*b  (Transpose)\n*          = 'C':  Solve A'* x = s*b  (Conjugate transpose = Transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          Specifies whether or not the matrix A is unit triangular.\n*          = 'N':  Non-unit triangular\n*          = 'U':  Unit triangular\n*\n*  NORMIN  (input) CHARACTER*1\n*          Specifies whether CNORM has been set or not.\n*          = 'Y':  CNORM contains the column norms on entry\n*          = 'N':  CNORM is not set on entry.  On exit, the norms will\n*                  be computed and stored in CNORM.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of subdiagonals or superdiagonals in the\n*          triangular matrix A.  KD >= 0.\n*\n*  AB      (input) REAL array, dimension (LDAB,N)\n*          The upper or lower triangular band matrix A, stored in the\n*          first KD+1 rows of the array. The j-th column of A is stored\n*          in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  X       (input/output) REAL array, dimension (N)\n*          On entry, the right hand side b of the triangular system.\n*          On exit, X is overwritten by the solution vector x.\n*\n*  SCALE   (output) REAL\n*          The scaling factor s for the triangular system\n*             A * x = s*b  or  A'* x = s*b.\n*          If SCALE = 0, the matrix A is singular or badly scaled, and\n*          the vector x is an exact or approximate solution to A*x = 0.\n*\n*  CNORM   (input or output) REAL array, dimension (N)\n*\n*          If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n*          contains the norm of the off-diagonal part of the j-th column\n*          of A.  If TRANS = 'N', CNORM(j) must be greater than or equal\n*          to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n*          must be greater than or equal to the 1-norm.\n*\n*          If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n*          returns the 1-norm of the offdiagonal part of the j-th column\n*          of A.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -k, the k-th argument had an illegal value\n*\n\n*  Further Details\n*  ======= =======\n*\n*  A rough bound on x is computed; if that is less than overflow, STBSV\n*  is called, otherwise, specific code is used which checks for possible\n*  overflow or divide-by-zero at every operation.\n*\n*  A columnwise scheme is used for solving A*x = b.  The basic algorithm\n*  if A is lower triangular is\n*\n*       x[1:n] := b[1:n]\n*       for j = 1, ..., n\n*            x(j) := x(j) / A(j,j)\n*            x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n*       end\n*\n*  Define bounds on the components of x after j iterations of the loop:\n*     M(j) = bound on x[1:j]\n*     G(j) = bound on x[j+1:n]\n*  Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n*  Then for iteration j+1 we have\n*     M(j+1) <= G(j) / | A(j+1,j+1) |\n*     G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n*            <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n*  where CNORM(j+1) is greater than or equal to the infinity-norm of\n*  column j+1 of A, not counting the diagonal.  Hence\n*\n*     G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n*                  1<=i<=j\n*  and\n*\n*     |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n*                                   1<=i< j\n*\n*  Since |x(j)| <= M(j), we use the Level 2 BLAS routine STBSV if the\n*  reciprocal of the largest M(j), j=1,..,n, is larger than\n*  max(underflow, 1/overflow).\n*\n*  The bound on x(j) is also used to determine when a step in the\n*  columnwise method can be performed without fear of overflow.  If\n*  the computed bound is greater than a large constant, x is scaled to\n*  prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n*  1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n*  Similarly, a row-wise scheme is used to solve A'*x = b.  The basic\n*  algorithm for A upper triangular is\n*\n*       for j = 1, ..., n\n*            x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n*       end\n*\n*  We simultaneously compute two bounds\n*       G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n*       M(j) = bound on x(i), 1<=i<=j\n*\n*  The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n*  add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n*  Then the bound on x(j) is\n*\n*       M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n*            <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n*                      1<=i<=j\n*\n*  and we can safely call STBSV if 1/M(n) and 1/G(n) are both greater\n*  than max(underflow, 1/overflow).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, info, x, cnorm = NumRu::Lapack.slatbs( uplo, trans, diag, normin, kd, ab, x, cnorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_normin = argv[3];
  rblapack_kd = argv[4];
  rblapack_ab = argv[5];
  rblapack_x = argv[6];
  rblapack_cnorm = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  kd = NUM2INT(rblapack_kd);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (7th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (6th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (6th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of x");
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  normin = StringValueCStr(rblapack_normin)[0];
  if (!NA_IsNArray(rblapack_cnorm))
    rb_raise(rb_eArgError, "cnorm (8th argument) must be NArray");
  if (NA_RANK(rblapack_cnorm) != 1)
    rb_raise(rb_eArgError, "rank of cnorm (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_cnorm) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of cnorm must be the same as shape 0 of x");
  if (NA_TYPE(rblapack_cnorm) != NA_SFLOAT)
    rblapack_cnorm = na_change_type(rblapack_cnorm, NA_SFLOAT);
  cnorm = NA_PTR_TYPE(rblapack_cnorm, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_cnorm_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  cnorm_out__ = NA_PTR_TYPE(rblapack_cnorm_out__, real*);
  MEMCPY(cnorm_out__, cnorm, real, NA_TOTAL(rblapack_cnorm));
  rblapack_cnorm = rblapack_cnorm_out__;
  cnorm = cnorm_out__;

  slatbs_(&uplo, &trans, &diag, &normin, &n, &kd, ab, &ldab, x, &scale, cnorm, &info);

  rblapack_scale = rb_float_new((double)scale);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_scale, rblapack_info, rblapack_x, rblapack_cnorm);
}

void
init_lapack_slatbs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slatbs", rblapack_slatbs, -1);
}
ruby-lapack-1.7.2/ext/dstemr.c0000644000175000017500000003734312502221014016030 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dstemr_(char* jobz, char* range, integer* n, doublereal* d, doublereal* e, doublereal* vl, doublereal* vu, integer* il, integer* iu, integer* m, doublereal* w, doublereal* z, integer* ldz, integer* nzc, integer* isuppz, logical* tryrac, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_dstemr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_vl;
  doublereal vl; 
  VALUE rblapack_vu;
  doublereal vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_nzc;
  integer nzc; 
  VALUE rblapack_tryrac;
  logical tryrac; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_isuppz;
  integer *isuppz; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_e_out__;
  doublereal *e_out__;

  integer n;
  integer ldz;

  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  m, w, z, isuppz, work, iwork, info, d, e, tryrac = NumRu::Lapack.dstemr( jobz, range, d, e, vl, vu, il, iu, nzc, tryrac, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSTEMR computes selected eigenvalues and, optionally, eigenvectors\n*  of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n*  a well defined set of pairwise different real eigenvalues, the corresponding\n*  real eigenvectors are pairwise orthogonal.\n*\n*  The spectrum may be computed either completely or partially by specifying\n*  either an interval (VL,VU] or a range of indices IL:IU for the desired\n*  eigenvalues.\n*\n*  Depending on the number of desired eigenvalues, these are computed either\n*  by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are\n*  computed by the use of various suitable L D L^T factorizations near clusters\n*  of close eigenvalues (referred to as RRRs, Relatively Robust\n*  Representations). An informal sketch of the algorithm follows.\n*\n*  For each unreduced block (submatrix) of T,\n*     (a) Compute T - sigma I  = L D L^T, so that L and D\n*         define all the wanted eigenvalues to high relative accuracy.\n*         This means that small relative changes in the entries of D and L\n*         cause only small relative changes in the eigenvalues and\n*         eigenvectors. The standard (unfactored) representation of the\n*         tridiagonal matrix T does not have this property in general.\n*     (b) Compute the eigenvalues to suitable accuracy.\n*         If the eigenvectors are desired, the algorithm attains full\n*         accuracy of the computed eigenvalues only right before\n*         the corresponding vectors have to be computed, see steps c) and d).\n*     (c) For each cluster of close eigenvalues, select a new\n*         shift close to the cluster, find a new factorization, and refine\n*         the shifted eigenvalues to suitable accuracy.\n*     (d) For each eigenvalue with a large enough relative separation compute\n*         the corresponding eigenvector by forming a rank revealing twisted\n*         factorization. Go back to (c) for any clusters that remain.\n*\n*  For more details, see:\n*  - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n*    to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n*    Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n*  - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n*    Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n*    2004.  Also LAPACK Working Note 154.\n*  - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n*    tridiagonal eigenvalue/eigenvector problem\",\n*    Computer Science Division Technical Report No. UCB/CSD-97-971,\n*    UC Berkeley, May 1997.\n*\n*  Further Details\n*  1.DSTEMR works only on machines which follow IEEE-754\n*  floating-point standard in their handling of infinities and NaNs.\n*  This permits the use of efficient inner loops avoiding a check for\n*  zero divisors.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found.\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found.\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the N diagonal elements of the tridiagonal matrix\n*          T. On exit, D is overwritten.\n*\n*  E       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the (N-1) subdiagonal elements of the tridiagonal\n*          matrix T in elements 1 to N-1 of E. E(N) need not be set on\n*          input, but is used internally as workspace.\n*          On exit, E is overwritten.\n*\n*  VL      (input) DOUBLE PRECISION\n*  VU      (input) DOUBLE PRECISION\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          The first M elements contain the selected eigenvalues in\n*          ascending order.\n*\n*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )\n*          If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix T\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and can be computed with a workspace\n*          query by setting NZC = -1, see below.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', then LDZ >= max(1,N).\n*\n*  NZC     (input) INTEGER\n*          The number of eigenvectors to be held in the array Z.\n*          If RANGE = 'A', then NZC >= max(1,N).\n*          If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].\n*          If RANGE = 'I', then NZC >= IU-IL+1.\n*          If NZC = -1, then a workspace query is assumed; the\n*          routine calculates the number of columns of the array Z that\n*          are needed to hold the eigenvectors.\n*          This value is returned as the first entry of the Z array, and\n*          no error message related to NZC is issued by XERBLA.\n*\n*  ISUPPZ  (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n*          The support of the eigenvectors in Z, i.e., the indices\n*          indicating the nonzero elements in Z. The i-th computed eigenvector\n*          is nonzero only in elements ISUPPZ( 2*i-1 ) through\n*          ISUPPZ( 2*i ). This is relevant in the case when the matrix\n*          is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n*\n*  TRYRAC  (input/output) LOGICAL\n*          If TRYRAC.EQ..TRUE., indicates that the code should check whether\n*          the tridiagonal matrix defines its eigenvalues to high relative\n*          accuracy.  If so, the code uses relative-accuracy preserving\n*          algorithms that might be (a bit) slower depending on the matrix.\n*          If the matrix does not define its eigenvalues to high relative\n*          accuracy, the code can uses possibly faster algorithms.\n*          If TRYRAC.EQ..FALSE., the code is not required to guarantee\n*          relatively accurate eigenvalues and can use the fastest possible\n*          techniques.\n*          On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix\n*          does not define its eigenvalues to high relative accuracy.\n*\n*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)\n*          On exit, if INFO = 0, WORK(1) returns the optimal\n*          (and minimal) LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK. LWORK >= max(1,18*N)\n*          if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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*  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.  LIWORK >= max(1,10*N)\n*          if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n*          if only the eigenvalues are to be computed.\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal size of the IWORK array,\n*          returns this value as the first entry of the IWORK array, and\n*          no error message related to LIWORK is issued by XERBLA.\n*\n*  INFO    (output) INTEGER\n*          On exit, INFO\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  if INFO = 1X, internal error in DLARRE,\n*                if INFO = 2X, internal error in DLARRV.\n*                Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n*                the nonzero error code returned by DLARRE or\n*                DLARRV, respectively.\n*\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Beresford Parlett, University of California, Berkeley, USA\n*     Jim Demmel, University of California, Berkeley, USA\n*     Inderjit Dhillon, University of Texas, Austin, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, isuppz, work, iwork, info, d, e, tryrac = NumRu::Lapack.dstemr( jobz, range, d, e, vl, vu, il, iu, nzc, tryrac, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_d = argv[2];
  rblapack_e = argv[3];
  rblapack_vl = argv[4];
  rblapack_vu = argv[5];
  rblapack_il = argv[6];
  rblapack_iu = argv[7];
  rblapack_nzc = argv[8];
  rblapack_tryrac = argv[9];
  if (argc == 12) {
    rblapack_lwork = argv[10];
    rblapack_liwork = argv[11];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  vl = NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  nzc = NUM2INT(rblapack_nzc);
  range = StringValueCStr(rblapack_range)[0];
  vu = NUM2DBL(rblapack_vu);
  tryrac = (rblapack_tryrac == Qtrue);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (4th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&jobz,"V") ? 18*n : lsame_(&jobz,"N") ? 12*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  iu = NUM2INT(rblapack_iu);
  m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
  if (rblapack_liwork == Qnil)
    liwork = lsame_(&jobz,"V") ? 10*n : lsame_(&jobz,"N") ? 8*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 2*MAX(1,m);
    rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
  MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;

  dstemr_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &m, w, z, &ldz, &nzc, isuppz, &tryrac, work, &lwork, iwork, &liwork, &info);

  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  rblapack_tryrac = tryrac ? Qtrue : Qfalse;
  return rb_ary_new3(10, rblapack_m, rblapack_w, rblapack_z, rblapack_isuppz, rblapack_work, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e, rblapack_tryrac);
}

void
init_lapack_dstemr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dstemr", rblapack_dstemr, -1);
}
ruby-lapack-1.7.2/ext/slalsd.c0000644000175000017500000002040112502221014015777 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slalsd_(char* uplo, integer* smlsiz, integer* n, integer* nrhs, real* d, real* e, real* b, integer* ldb, real* rcond, integer* rank, real* work, integer* iwork, integer* info);


static VALUE
rblapack_slalsd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_smlsiz;
  integer smlsiz; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_rank;
  integer rank; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_e_out__;
  real *e_out__;
  VALUE rblapack_b_out__;
  real *b_out__;
  real *work;
  integer *iwork;

  integer n;
  integer ldb;
  integer nrhs;
  integer nlvl;

  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  rank, info, d, e, b = NumRu::Lapack.slalsd( uplo, smlsiz, d, e, b, rcond, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, RANK, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLALSD uses the singular value decomposition of A to solve the least\n*  squares problem of finding X to minimize the Euclidean norm of each\n*  column of A*X-B, where A is N-by-N upper bidiagonal, and X and B\n*  are N-by-NRHS. The solution X overwrites B.\n*\n*  The singular values of A smaller than RCOND times the largest\n*  singular value are treated as zero in solving the least squares\n*  problem; in this case a minimum norm solution is returned.\n*  The actual singular values are returned in D in ascending order.\n*\n*  This code makes very mild assumptions about floating point\n*  arithmetic. It will work on machines with a guard digit in\n*  add/subtract, or on those binary machines without guard digits\n*  which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.\n*  It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO   (input) CHARACTER*1\n*         = 'U': D and E define an upper bidiagonal matrix.\n*         = 'L': D and E define a  lower bidiagonal matrix.\n*\n*  SMLSIZ (input) INTEGER\n*         The maximum size of the subproblems at the bottom of the\n*         computation tree.\n*\n*  N      (input) INTEGER\n*         The dimension of the  bidiagonal matrix.  N >= 0.\n*\n*  NRHS   (input) INTEGER\n*         The number of columns of B. NRHS must be at least 1.\n*\n*  D      (input/output) REAL array, dimension (N)\n*         On entry D contains the main diagonal of the bidiagonal\n*         matrix. On exit, if INFO = 0, D contains its singular values.\n*\n*  E      (input/output) REAL array, dimension (N-1)\n*         Contains the super-diagonal entries of the bidiagonal matrix.\n*         On exit, E has been destroyed.\n*\n*  B      (input/output) REAL array, dimension (LDB,NRHS)\n*         On input, B contains the right hand sides of the least\n*         squares problem. On output, B contains the solution X.\n*\n*  LDB    (input) INTEGER\n*         The leading dimension of B in the calling subprogram.\n*         LDB must be at least max(1,N).\n*\n*  RCOND  (input) REAL\n*         The singular values of A less than or equal to RCOND times\n*         the largest singular value are treated as zero in solving\n*         the least squares problem. If RCOND is negative,\n*         machine precision is used instead.\n*         For example, if diag(S)*X=B were the least squares problem,\n*         where diag(S) is a diagonal matrix of singular values, the\n*         solution would be X(i) = B(i) / S(i) if S(i) is greater than\n*         RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to\n*         RCOND*max(S).\n*\n*  RANK   (output) INTEGER\n*         The number of singular values of A greater than RCOND times\n*         the largest singular value.\n*\n*  WORK   (workspace) REAL array, dimension at least\n*         (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2),\n*         where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1).\n*\n*  IWORK  (workspace) INTEGER array, dimension at least\n*         (3*N*NLVL + 11*N)\n*\n*  INFO   (output) INTEGER\n*         = 0:  successful exit.\n*         < 0:  if INFO = -i, the i-th argument had an illegal value.\n*         > 0:  The algorithm failed to compute a singular value while\n*               working on the submatrix lying in rows and columns\n*               INFO/(N+1) through MOD(INFO,N+1).\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Ren-Cang Li, Computer Science Division, University of\n*       California at Berkeley, USA\n*     Osni Marques, LBNL/NERSC, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rank, info, d, e, b = NumRu::Lapack.slalsd( uplo, smlsiz, d, e, b, rcond, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_smlsiz = argv[1];
  rblapack_d = argv[2];
  rblapack_e = argv[3];
  rblapack_b = argv[4];
  rblapack_rcond = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  smlsiz = NUM2INT(rblapack_smlsiz);
  rcond = (real)NUM2DBL(rblapack_rcond);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (4th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  nlvl = MAX(0, (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
  MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(real, (9*n + 2*n*smlsiz + 8*n*nlvl + n*nrhs + pow(smlsiz+1,2)));
  iwork = ALLOC_N(integer, (3*n*nlvl + 11*n));

  slalsd_(&uplo, &smlsiz, &n, &nrhs, d, e, b, &ldb, &rcond, &rank, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rank = INT2NUM(rank);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_rank, rblapack_info, rblapack_d, rblapack_e, rblapack_b);
}

void
init_lapack_slalsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slalsd", rblapack_slalsd, -1);
}
ruby-lapack-1.7.2/ext/dorglq.c0000644000175000017500000001253012502221020016006 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dorglq_(integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dorglq(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;

  integer lda;
  integer n;
  integer k;

  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 = NumRu::Lapack.dorglq( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DORGLQ generates an M-by-N real matrix Q with orthonormal rows,\n*  which is defined as the first M rows of a product of K elementary\n*  reflectors of order N\n*\n*        Q  =  H(k) . . . H(2) H(1)\n*\n*  as returned by DGELQF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. N >= M.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. M >= K >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the i-th row must contain the vector which defines\n*          the elementary reflector H(i), for i = 1,2,...,k, as returned\n*          by DGELQF in the first k rows of its array argument A.\n*          On exit, the M-by-N matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) DOUBLE PRECISION array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by DGELQF.\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\n*          the 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 has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, a = NumRu::Lapack.dorglq( m, a, tau, [: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_m = argv[0];
  rblapack_a = argv[1];
  rblapack_tau = 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;
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  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*);
  if (rblapack_lwork == Qnil)
    lwork = m;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;

  dorglq_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_dorglq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dorglq", rblapack_dorglq, -1);
}
ruby-lapack-1.7.2/ext/slaset.c0000644000175000017500000001030712502221026016017 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaset_(char* uplo, integer* m, integer* n, real* alpha, real* beta, real* a, integer* lda);


static VALUE
rblapack_slaset(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_alpha;
  real alpha; 
  VALUE rblapack_beta;
  real beta; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_a_out__;
  real *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  a = NumRu::Lapack.slaset( uplo, m, alpha, beta, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASET( UPLO, M, N, ALPHA, BETA, A, LDA )\n\n*  Purpose\n*  =======\n*\n*  SLASET initializes an m-by-n matrix A to BETA on the diagonal and\n*  ALPHA on the offdiagonals.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies the part of the matrix A to be set.\n*          = 'U':      Upper triangular part is set; the strictly lower\n*                      triangular part of A is not changed.\n*          = 'L':      Lower triangular part is set; the strictly upper\n*                      triangular part of A is not changed.\n*          Otherwise:  All of the matrix A is set.\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*  ALPHA   (input) REAL\n*          The constant to which the offdiagonal elements are to be set.\n*\n*  BETA    (input) REAL\n*          The constant to which the diagonal elements are to be set.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On exit, the leading m-by-n submatrix of A is set as follows:\n*\n*          if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n,\n*          if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n,\n*          otherwise,     A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j,\n*\n*          and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n\n* =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  a = NumRu::Lapack.slaset( uplo, m, alpha, beta, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_m = argv[1];
  rblapack_alpha = argv[2];
  rblapack_beta = argv[3];
  rblapack_a = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  alpha = (real)NUM2DBL(rblapack_alpha);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  m = NUM2INT(rblapack_m);
  beta = (real)NUM2DBL(rblapack_beta);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  slaset_(&uplo, &m, &n, &alpha, &beta, a, &lda);

  return rblapack_a;
}

void
init_lapack_slaset(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaset", rblapack_slaset, -1);
}
ruby-lapack-1.7.2/ext/cgbrfs.c0000644000175000017500000002233512502221014015773 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgbrfs_(char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, complex* ab, integer* ldab, complex* afb, integer* ldafb, integer* ipiv, complex* b, integer* ldb, complex* x, integer* ldx, real* ferr, real* berr, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cgbrfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_afb;
  complex *afb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  complex *x_out__;
  complex *work;
  real *rwork;

  integer ldab;
  integer n;
  integer ldafb;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.cgbrfs( trans, kl, ku, ab, afb, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGBRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is banded, and provides\n*  error bounds and backward error estimates for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AB      (input) COMPLEX array, dimension (LDAB,N)\n*          The original band matrix A, stored in rows 1 to KL+KU+1.\n*          The j-th column of A is stored in the j-th column of the\n*          array AB as follows:\n*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*  AFB     (input) COMPLEX array, dimension (LDAFB,N)\n*          Details of the LU factorization of the band matrix A, as\n*          computed by CGBTRF.  U is stored as an upper triangular band\n*          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n*          the multipliers used during the factorization are stored in\n*          rows KL+KU+2 to 2*KL+KU+1.\n*\n*  LDAFB   (input) INTEGER\n*          The leading dimension of the array AFB.  LDAFB >= 2*KL*KU+1.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices from CGBTRF; for 1<=i<=N, row i of the\n*          matrix was interchanged with row IPIV(i).\n*\n*  B       (input) COMPLEX array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) COMPLEX array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by CGBTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.cgbrfs( trans, kl, ku, ab, afb, ipiv, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_trans = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  rblapack_afb = argv[4];
  rblapack_ipiv = argv[5];
  rblapack_b = argv[6];
  rblapack_x = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
  ldafb = NA_SHAPE0(rblapack_afb);
  n = NA_SHAPE1(rblapack_afb);
  if (NA_TYPE(rblapack_afb) != NA_SCOMPLEX)
    rblapack_afb = na_change_type(rblapack_afb, NA_SCOMPLEX);
  afb = NA_PTR_TYPE(rblapack_afb, complex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (8th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (8th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (n));

  cgbrfs_(&trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_cgbrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgbrfs", rblapack_cgbrfs, -1);
}
ruby-lapack-1.7.2/ext/dsycon.c0000644000175000017500000001145612502221020016023 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsycon_(char* uplo, integer* n, doublereal* a, integer* lda, integer* ipiv, doublereal* anorm, doublereal* rcond, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dsycon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_anorm;
  doublereal anorm; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_info;
  integer info; 
  doublereal *work;
  integer *iwork;

  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  rcond, info = NumRu::Lapack.dsycon( uplo, a, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSYCON estimates the reciprocal of the condition number (in the\n*  1-norm) of a real symmetric matrix A using the factorization\n*  A = U*D*U**T or A = L*D*L**T computed by DSYTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by DSYTRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by DSYTRF.\n*\n*  ANORM   (input) DOUBLE PRECISION\n*          The 1-norm of the original matrix A.\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n*          estimate of the 1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.dsycon( uplo, a, ipiv, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_anorm = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  anorm = NUM2DBL(rblapack_anorm);
  work = ALLOC_N(doublereal, (2*n));
  iwork = ALLOC_N(integer, (n));

  dsycon_(&uplo, &n, a, &lda, ipiv, &anorm, &rcond, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_dsycon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsycon", rblapack_dsycon, -1);
}
ruby-lapack-1.7.2/ext/zsprfs.c0000644000175000017500000002113712502221021016051 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zsprfs_(char* uplo, integer* n, integer* nrhs, doublecomplex* ap, doublecomplex* afp, integer* ipiv, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zsprfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_afp;
  doublecomplex *afp; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.zsprfs( uplo, ap, afp, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZSPRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is symmetric indefinite\n*  and packed, and provides error bounds and backward error estimates\n*  for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          The upper or lower triangle of the symmetric matrix A, packed\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  AFP     (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          The factored form of the matrix A.  AFP contains the block\n*          diagonal matrix D and the multipliers used to obtain the\n*          factor U or L from the factorization A = U*D*U**T or\n*          A = L*D*L**T as computed by ZSPTRF, stored as a packed\n*          triangular matrix.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by ZSPTRF.\n*\n*  B       (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) COMPLEX*16 array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by ZSPTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.zsprfs( uplo, ap, afp, ipiv, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_afp = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_b = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  if (!NA_IsNArray(rblapack_afp))
    rb_raise(rb_eArgError, "afp (3th argument) must be NArray");
  if (NA_RANK(rblapack_afp) != 1)
    rb_raise(rb_eArgError, "rank of afp (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_afp) != NA_DCOMPLEX)
    rblapack_afp = na_change_type(rblapack_afp, NA_DCOMPLEX);
  afp = NA_PTR_TYPE(rblapack_afp, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (n));

  zsprfs_(&uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_zsprfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zsprfs", rblapack_zsprfs, -1);
}
ruby-lapack-1.7.2/ext/dpotrf.c0000644000175000017500000000776512502221021016033 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dpotrf_(char* uplo, integer* n, doublereal* a, integer* lda, integer* info);


static VALUE
rblapack_dpotrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  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  info, a = NumRu::Lapack.dpotrf( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPOTRF computes the Cholesky factorization of a real symmetric\n*  positive definite matrix A.\n*\n*  The factorization has the form\n*     A = U**T * U,  if UPLO = 'U', or\n*     A = L  * L**T,  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is lower triangular.\n*\n*  This is the block version of the algorithm, calling Level 3 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the factor U or L from the Cholesky\n*          factorization A = U**T*U or A = L*L**T.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\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 leading minor of order i is not\n*                positive definite, and the factorization could not be\n*                completed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.dpotrf( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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*);
  {
    na_shape_t 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__;

  dpotrf_(&uplo, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_dpotrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dpotrf", rblapack_dpotrf, -1);
}
ruby-lapack-1.7.2/ext/zunmqr.c0000644000175000017500000001650612502221020016061 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zunmqr_(char* side, char* trans, integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zunmqr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_c;
  doublecomplex *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublecomplex *c_out__;

  integer lda;
  integer k;
  integer ldc;
  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  work, info, c = NumRu::Lapack.zunmqr( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZUNMQR overwrites the general complex M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'C':      Q**H * C       C * Q**H\n*\n*  where Q is a complex unitary matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(1) H(2) . . . H(k)\n*\n*  as returned by ZGEQRF. Q is of order M if SIDE = 'L' and of order N\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**H from the Left;\n*          = 'R': apply Q or Q**H from the Right.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'C':  Conjugate transpose, apply Q**H.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,K)\n*          The i-th column must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          ZGEQRF in the first k columns of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*          If SIDE = 'L', LDA >= max(1,M);\n*          if SIDE = 'R', LDA >= max(1,N).\n*\n*  TAU     (input) COMPLEX*16 array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by ZGEQRF.\n*\n*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace/output) COMPLEX*16 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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M).\n*          For optimum performance LWORK >= N*NB if SIDE = 'L', and\n*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n*          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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.zunmqr( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_m = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 7) {
    rblapack_lwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  side = StringValueCStr(rblapack_side)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != k)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
  MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  zunmqr_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_zunmqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zunmqr", rblapack_zunmqr, -1);
}
ruby-lapack-1.7.2/ext/clargv.c0000644000175000017500000001240512502221015016001 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clargv_(integer* n, complex* x, integer* incx, complex* y, integer* incy, real* c, integer* incc);


static VALUE
rblapack_clargv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_y;
  complex *y; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_incc;
  integer incc; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_x_out__;
  complex *x_out__;
  VALUE rblapack_y_out__;
  complex *y_out__;


  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  c, x, y = NumRu::Lapack.clargv( n, x, incx, y, incy, incc, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLARGV( N, X, INCX, Y, INCY, C, INCC )\n\n*  Purpose\n*  =======\n*\n*  CLARGV generates a vector of complex plane rotations with real\n*  cosines, determined by elements of the complex vectors x and y.\n*  For i = 1,2,...,n\n*\n*     (        c(i)   s(i) ) ( x(i) ) = ( r(i) )\n*     ( -conjg(s(i))  c(i) ) ( y(i) ) = (   0  )\n*\n*     where c(i)**2 + ABS(s(i))**2 = 1\n*\n*  The following conventions are used (these are the same as in CLARTG,\n*  but differ from the BLAS1 routine CROTG):\n*     If y(i)=0, then c(i)=1 and s(i)=0.\n*     If x(i)=0, then c(i)=0 and s(i) is chosen so that r(i) is real.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of plane rotations to be generated.\n*\n*  X       (input/output) COMPLEX array, dimension (1+(N-1)*INCX)\n*          On entry, the vector x.\n*          On exit, x(i) is overwritten by r(i), for i = 1,...,n.\n*\n*  INCX    (input) INTEGER\n*          The increment between elements of X. INCX > 0.\n*\n*  Y       (input/output) COMPLEX array, dimension (1+(N-1)*INCY)\n*          On entry, the vector y.\n*          On exit, the sines of the plane rotations.\n*\n*  INCY    (input) INTEGER\n*          The increment between elements of Y. INCY > 0.\n*\n*  C       (output) REAL array, dimension (1+(N-1)*INCC)\n*          The cosines of the plane rotations.\n*\n*  INCC    (input) INTEGER\n*          The increment between elements of C. INCC > 0.\n*\n\n*  Further Details\n*  ======= =======\n*\n*  6-6-96 - Modified with a new algorithm by W. Kahan and J. Demmel\n*\n*  This version has a few statements commented out for thread safety\n*  (machine parameters are computed on each entry). 10 feb 03, SJH.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c, x, y = NumRu::Lapack.clargv( n, x, incx, y, incy, incc, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_n = argv[0];
  rblapack_x = argv[1];
  rblapack_incx = argv[2];
  rblapack_y = argv[3];
  rblapack_incy = argv[4];
  rblapack_incc = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  incx = NUM2INT(rblapack_incx);
  incy = NUM2INT(rblapack_incy);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1+(n-1)*incx))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  incc = NUM2INT(rblapack_incc);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (4th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incy))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
  if (NA_TYPE(rblapack_y) != NA_SCOMPLEX)
    rblapack_y = na_change_type(rblapack_y, NA_SCOMPLEX);
  y = NA_PTR_TYPE(rblapack_y, complex*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incc;
    rblapack_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  c = NA_PTR_TYPE(rblapack_c, real*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incx;
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incy;
    rblapack_y_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, complex*);
  MEMCPY(y_out__, y, complex, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  clargv_(&n, x, &incx, y, &incy, c, &incc);

  return rb_ary_new3(3, rblapack_c, rblapack_x, rblapack_y);
}

void
init_lapack_clargv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clargv", rblapack_clargv, -1);
}
ruby-lapack-1.7.2/ext/zuncsd.c0000644000175000017500000003146012502221024016033 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zuncsd_(char* jobu1, char* jobu2, char* jobv1t, char* jobv2t, char* trans, char* signs, integer* m, integer* p, integer* q, doublecomplex* x11, integer* ldx11, doublecomplex* x12, integer* ldx12, doublecomplex* x21, integer* ldx21, doublecomplex* x22, integer* ldx22, doublereal* theta, doublecomplex* u1, integer* ldu1, doublecomplex* u2, integer* ldu2, doublecomplex* v1t, integer* ldv1t, doublecomplex* v2t, integer* ldv2t, doublecomplex* work, integer* lwork, doublereal* rwork, integer* lrwork, integer* iwork, integer* info);


static VALUE
rblapack_zuncsd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobu1;
  char jobu1; 
  VALUE rblapack_jobu2;
  char jobu2; 
  VALUE rblapack_jobv1t;
  char jobv1t; 
  VALUE rblapack_jobv2t;
  char jobv2t; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_signs;
  char signs; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_x11;
  doublecomplex *x11; 
  VALUE rblapack_x12;
  doublecomplex *x12; 
  VALUE rblapack_x21;
  doublecomplex *x21; 
  VALUE rblapack_x22;
  doublecomplex *x22; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_lrwork;
  integer lrwork; 
  VALUE rblapack_theta;
  doublereal *theta; 
  VALUE rblapack_u1;
  doublecomplex *u1; 
  VALUE rblapack_u2;
  doublecomplex *u2; 
  VALUE rblapack_v1t;
  doublecomplex *v1t; 
  VALUE rblapack_v2t;
  doublecomplex *v2t; 
  VALUE rblapack_info;
  integer info; 
  doublecomplex *work;
  doublereal *rwork;
  integer *iwork;

  integer p;
  integer q;
  integer ldv2t;
  integer ldv1t;
  integer ldu1;
  integer ldu2;
  integer ldx11;
  integer ldx12;
  integer ldx21;
  integer ldx22;

  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  theta, u1, u2, v1t, v2t, info = NumRu::Lapack.zuncsd( jobu1, jobu2, jobv1t, jobv2t, trans, signs, m, x11, x12, x21, x22, lwork, lrwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      RECURSIVE SUBROUTINE ZUNCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, WORK, LWORK, RWORK, LRWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZUNCSD computes the CS decomposition of an M-by-M partitioned\n*  unitary matrix X:\n*\n*                                  [  I  0  0 |  0  0  0 ]\n*                                  [  0  C  0 |  0 -S  0 ]\n*      [ X11 | X12 ]   [ U1 |    ] [  0  0  0 |  0  0 -I ] [ V1 |    ]**H\n*  X = [-----------] = [---------] [---------------------] [---------]   .\n*      [ X21 | X22 ]   [    | U2 ] [  0  0  0 |  I  0  0 ] [    | V2 ]\n*                                  [  0  S  0 |  0  C  0 ]\n*                                  [  0  0  I |  0  0  0 ]\n*\n*  X11 is P-by-Q. The unitary matrices U1, U2, V1, and V2 are P-by-P,\n*  (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are\n*  R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in\n*  which R = MIN(P,M-P,Q,M-Q).\n*\n\n*  Arguments\n*  =========\n*\n*  JOBU1   (input) CHARACTER\n*          = 'Y':      U1 is computed;\n*          otherwise:  U1 is not computed.\n*\n*  JOBU2   (input) CHARACTER\n*          = 'Y':      U2 is computed;\n*          otherwise:  U2 is not computed.\n*\n*  JOBV1T  (input) CHARACTER\n*          = 'Y':      V1T is computed;\n*          otherwise:  V1T is not computed.\n*\n*  JOBV2T  (input) CHARACTER\n*          = 'Y':      V2T is computed;\n*          otherwise:  V2T is not computed.\n*\n*  TRANS   (input) CHARACTER\n*          = 'T':      X, U1, U2, V1T, and V2T are stored in row-major\n*                      order;\n*          otherwise:  X, U1, U2, V1T, and V2T are stored in column-\n*                      major order.\n*\n*  SIGNS   (input) CHARACTER\n*          = 'O':      The lower-left block is made nonpositive (the\n*                      \"other\" convention);\n*          otherwise:  The upper-right block is made nonpositive (the\n*                      \"default\" convention).\n*\n*  M       (input) INTEGER\n*          The number of rows and columns in X.\n*\n*  P       (input) INTEGER\n*          The number of rows in X11 and X12. 0 <= P <= M.\n*\n*  Q       (input) INTEGER\n*          The number of columns in X11 and X21. 0 <= Q <= M.\n*\n*  X       (input/workspace) COMPLEX*16 array, dimension (LDX,M)\n*          On entry, the unitary matrix whose CSD is desired.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of X. LDX >= MAX(1,M).\n*\n*  THETA   (output) DOUBLE PRECISION array, dimension (R), in which R =\n*          MIN(P,M-P,Q,M-Q).\n*          C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and\n*          S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).\n*\n*  U1      (output) COMPLEX*16 array, dimension (P)\n*          If JOBU1 = 'Y', U1 contains the P-by-P unitary matrix U1.\n*\n*  LDU1    (input) INTEGER\n*          The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=\n*          MAX(1,P).\n*\n*  U2      (output) COMPLEX*16 array, dimension (M-P)\n*          If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) unitary\n*          matrix U2.\n*\n*  LDU2    (input) INTEGER\n*          The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=\n*          MAX(1,M-P).\n*\n*  V1T     (output) COMPLEX*16 array, dimension (Q)\n*          If JOBV1T = 'Y', V1T contains the Q-by-Q matrix unitary\n*          matrix V1**H.\n*\n*  LDV1T   (input) INTEGER\n*          The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=\n*          MAX(1,Q).\n*\n*  V2T     (output) COMPLEX*16 array, dimension (M-Q)\n*          If JOBV2T = 'Y', V2T contains the (M-Q)-by-(M-Q) unitary\n*          matrix V2**H.\n*\n*  LDV2T   (input) INTEGER\n*          The leading dimension of V2T. If JOBV2T = 'Y', LDV2T >=\n*          MAX(1,M-Q).\n*\n*  WORK    (workspace) COMPLEX*16 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*\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*  RWORK   (workspace) DOUBLE PRECISION array, dimension MAX(1,LRWORK)\n*          On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n*          If INFO > 0 on exit, RWORK(2:R) contains the values PHI(1),\n*          ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),\n*          define the matrix in intermediate bidiagonal-block form\n*          remaining after nonconvergence. INFO specifies the number\n*          of nonzero PHI's.\n*\n*  LRWORK  (input) INTEGER\n*          The dimension of the array RWORK.\n*\n*          If LRWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal size of the RWORK array, returns\n*          this value as the first entry of the work array, and no error\n*          message related to LRWORK is issued by XERBLA.\n*\n*  IWORK   (workspace) INTEGER array, dimension (M-Q)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit.\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          > 0:  ZBBCSD did not converge. See the description of RWORK\n*                above for details.\n*\n*  Reference\n*  =========\n*\n*  [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.\n*      Algorithms, 50(1):33-65, 2009.\n*\n\n*  ===================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  theta, u1, u2, v1t, v2t, info = NumRu::Lapack.zuncsd( jobu1, jobu2, jobv1t, jobv2t, trans, signs, m, x11, x12, x21, x22, lwork, lrwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 13 && argc != 13)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 13)", argc);
  rblapack_jobu1 = argv[0];
  rblapack_jobu2 = argv[1];
  rblapack_jobv1t = argv[2];
  rblapack_jobv2t = argv[3];
  rblapack_trans = argv[4];
  rblapack_signs = argv[5];
  rblapack_m = argv[6];
  rblapack_x11 = argv[7];
  rblapack_x12 = argv[8];
  rblapack_x21 = argv[9];
  rblapack_x22 = argv[10];
  rblapack_lwork = argv[11];
  rblapack_lrwork = argv[12];
  if (argc == 13) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobu1 = StringValueCStr(rblapack_jobu1)[0];
  jobv1t = StringValueCStr(rblapack_jobv1t)[0];
  trans = StringValueCStr(rblapack_trans)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_x21))
    rb_raise(rb_eArgError, "x21 (10th argument) must be NArray");
  if (NA_RANK(rblapack_x21) != 2)
    rb_raise(rb_eArgError, "rank of x21 (10th argument) must be %d", 2);
  p = NA_SHAPE0(rblapack_x21);
  q = NA_SHAPE1(rblapack_x21);
  if (NA_TYPE(rblapack_x21) != NA_DCOMPLEX)
    rblapack_x21 = na_change_type(rblapack_x21, NA_DCOMPLEX);
  x21 = NA_PTR_TYPE(rblapack_x21, doublecomplex*);
  lwork = NUM2INT(rblapack_lwork);
  jobu2 = StringValueCStr(rblapack_jobu2)[0];
  signs = StringValueCStr(rblapack_signs)[0];
  lrwork = NUM2INT(rblapack_lrwork);
  jobv2t = StringValueCStr(rblapack_jobv2t)[0];
  if (!NA_IsNArray(rblapack_x11))
    rb_raise(rb_eArgError, "x11 (8th argument) must be NArray");
  if (NA_RANK(rblapack_x11) != 2)
    rb_raise(rb_eArgError, "rank of x11 (8th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_x11) != p)
    rb_raise(rb_eRuntimeError, "shape 0 of x11 must be the same as shape 0 of x21");
  if (NA_SHAPE1(rblapack_x11) != q)
    rb_raise(rb_eRuntimeError, "shape 1 of x11 must be the same as shape 1 of x21");
  if (NA_TYPE(rblapack_x11) != NA_DCOMPLEX)
    rblapack_x11 = na_change_type(rblapack_x11, NA_DCOMPLEX);
  x11 = NA_PTR_TYPE(rblapack_x11, doublecomplex*);
  if (!NA_IsNArray(rblapack_x22))
    rb_raise(rb_eArgError, "x22 (11th argument) must be NArray");
  if (NA_RANK(rblapack_x22) != 2)
    rb_raise(rb_eArgError, "rank of x22 (11th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_x22) != p)
    rb_raise(rb_eRuntimeError, "shape 0 of x22 must be the same as shape 0 of x21");
  if (NA_SHAPE1(rblapack_x22) != (m-q))
    rb_raise(rb_eRuntimeError, "shape 1 of x22 must be %d", m-q);
  if (NA_TYPE(rblapack_x22) != NA_DCOMPLEX)
    rblapack_x22 = na_change_type(rblapack_x22, NA_DCOMPLEX);
  x22 = NA_PTR_TYPE(rblapack_x22, doublecomplex*);
  ldv1t = lsame_(&jobv1t,"Y") ? MAX(1,q) : 0;
  if (!NA_IsNArray(rblapack_x12))
    rb_raise(rb_eArgError, "x12 (9th argument) must be NArray");
  if (NA_RANK(rblapack_x12) != 2)
    rb_raise(rb_eArgError, "rank of x12 (9th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_x12) != p)
    rb_raise(rb_eRuntimeError, "shape 0 of x12 must be the same as shape 0 of x21");
  if (NA_SHAPE1(rblapack_x12) != (m-q))
    rb_raise(rb_eRuntimeError, "shape 1 of x12 must be %d", m-q);
  if (NA_TYPE(rblapack_x12) != NA_DCOMPLEX)
    rblapack_x12 = na_change_type(rblapack_x12, NA_DCOMPLEX);
  x12 = NA_PTR_TYPE(rblapack_x12, doublecomplex*);
  ldu1 = lsame_(&jobu1,"Y") ? MAX(1,p) : 0;
  ldx11 = p;
  ldx21 = p;
  ldv2t = lsame_(&jobv2t,"Y") ? MAX(1,m-q) : 0;
  ldx12 = p;
  ldu2 = lsame_(&jobu2,"Y") ? MAX(1,m-p) : 0;
  ldx22 = p;
  {
    na_shape_t shape[1];
    shape[0] = MIN(MIN(MIN(p,m-p),q),m-q);
    rblapack_theta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  theta = NA_PTR_TYPE(rblapack_theta, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = p;
    rblapack_u1 = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  u1 = NA_PTR_TYPE(rblapack_u1, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = m-p;
    rblapack_u2 = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  u2 = NA_PTR_TYPE(rblapack_u2, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_v1t = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  v1t = NA_PTR_TYPE(rblapack_v1t, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = m-q;
    rblapack_v2t = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  v2t = NA_PTR_TYPE(rblapack_v2t, doublecomplex*);
  work = ALLOC_N(doublecomplex, (MAX(1,lwork)));
  rwork = ALLOC_N(doublereal, (MAX(1,lrwork)));
  iwork = ALLOC_N(integer, (m-q));

  zuncsd_(&jobu1, &jobu2, &jobv1t, &jobv2t, &trans, &signs, &m, &p, &q, x11, &ldx11, x12, &ldx12, x21, &ldx21, x22, &ldx22, theta, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, v2t, &ldv2t, work, &lwork, rwork, &lrwork, iwork, &info);

  free(work);
  free(rwork);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_theta, rblapack_u1, rblapack_u2, rblapack_v1t, rblapack_v2t, rblapack_info);
}

void
init_lapack_zuncsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zuncsd", rblapack_zuncsd, -1);
}
ruby-lapack-1.7.2/ext/zgbtrf.c0000644000175000017500000001320512502221014016017 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgbtrf_(integer* m, integer* n, integer* kl, integer* ku, doublecomplex* ab, integer* ldab, integer* ipiv, integer* info);


static VALUE
rblapack_zgbtrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublecomplex *ab_out__;

  integer ldab;
  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  ipiv, info, ab = NumRu::Lapack.zgbtrf( m, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGBTRF computes an LU factorization of a complex m-by-n band matrix A\n*  using partial pivoting with row interchanges.\n*\n*  This is the blocked version of the algorithm, calling Level 3 BLAS.\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*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)\n*          On entry, the matrix A in band storage, in rows KL+1 to\n*          2*KL+KU+1; rows 1 to KL of the array need not be set.\n*          The j-th column of A is stored in the j-th column of the\n*          array AB as follows:\n*          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n*          On exit, details of the factorization: U is stored as an\n*          upper triangular band matrix with KL+KU superdiagonals in\n*          rows 1 to KL+KU+1, and the multipliers used during the\n*          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n*          See below for further details.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.\n*\n*  IPIV    (output) INTEGER array, dimension (min(M,N))\n*          The pivot indices; for 1 <= i <= min(M,N), row i of the\n*          matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n*               has been completed, but the factor U is exactly\n*               singular, and division by zero will occur if it is used\n*               to solve a system of equations.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  M = N = 6, KL = 2, KU = 1:\n*\n*  On entry:                       On exit:\n*\n*      *    *    *    +    +    +       *    *    *   u14  u25  u36\n*      *    *    +    +    +    +       *    *   u13  u24  u35  u46\n*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56\n*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66\n*     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *\n*     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *\n*\n*  Array elements marked * are not used by the routine; elements marked\n*  + need not be set on entry, but are required by the routine to store\n*  elements of U because of fill-in resulting from the row interchanges.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, ab = NumRu::Lapack.zgbtrf( m, kl, ku, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_m = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  ku = NUM2INT(rblapack_ku);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
  MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  zgbtrf_(&m, &n, &kl, &ku, ab, &ldab, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_ab);
}

void
init_lapack_zgbtrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgbtrf", rblapack_zgbtrf, -1);
}
ruby-lapack-1.7.2/ext/spotrf.c0000644000175000017500000000770512502221026016051 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID spotrf_(char* uplo, integer* n, real* a, integer* lda, integer* info);


static VALUE
rblapack_spotrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *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  info, a = NumRu::Lapack.spotrf( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPOTRF( UPLO, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPOTRF computes the Cholesky factorization of a real symmetric\n*  positive definite matrix A.\n*\n*  The factorization has the form\n*     A = U**T * U,  if UPLO = 'U', or\n*     A = L  * L**T,  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is lower triangular.\n*\n*  This is the block version of the algorithm, calling Level 3 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the factor U or L from the Cholesky\n*          factorization A = U**T*U or A = L*L**T.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\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 leading minor of order i is not\n*                positive definite, and the factorization could not be\n*                completed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.spotrf( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  spotrf_(&uplo, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_spotrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "spotrf", rblapack_spotrf, -1);
}
ruby-lapack-1.7.2/ext/zsteqr.c0000644000175000017500000001552712502221017016065 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zsteqr_(char* compz, integer* n, doublereal* d, doublereal* e, doublecomplex* z, integer* ldz, doublereal* work, integer* info);


static VALUE
rblapack_zsteqr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_compz;
  char compz; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_e_out__;
  doublereal *e_out__;
  VALUE rblapack_z_out__;
  doublecomplex *z_out__;
  doublereal *work;

  integer n;
  integer ldz;

  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  info, d, e, z = NumRu::Lapack.zsteqr( compz, d, e, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZSTEQR computes all eigenvalues and, optionally, eigenvectors of a\n*  symmetric tridiagonal matrix using the implicit QL or QR method.\n*  The eigenvectors of a full or band complex Hermitian matrix can also\n*  be found if ZHETRD or ZHPTRD or ZHBTRD has been used to reduce this\n*  matrix to tridiagonal form.\n*\n\n*  Arguments\n*  =========\n*\n*  COMPZ   (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only.\n*          = 'V':  Compute eigenvalues and eigenvectors of the original\n*                  Hermitian matrix.  On entry, Z must contain the\n*                  unitary matrix used to reduce the original matrix\n*                  to tridiagonal form.\n*          = 'I':  Compute eigenvalues and eigenvectors of the\n*                  tridiagonal matrix.  Z is initialized to the identity\n*                  matrix.\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the diagonal elements of the tridiagonal matrix.\n*          On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n*  E       (input/output) DOUBLE PRECISION array, dimension (N-1)\n*          On entry, the (n-1) subdiagonal elements of the tridiagonal\n*          matrix.\n*          On exit, E has been destroyed.\n*\n*  Z       (input/output) COMPLEX*16 array, dimension (LDZ, N)\n*          On entry, if  COMPZ = 'V', then Z contains the unitary\n*          matrix used in the reduction to tridiagonal form.\n*          On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n*          orthonormal eigenvectors of the original Hermitian matrix,\n*          and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n*          of the symmetric tridiagonal matrix.\n*          If COMPZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          eigenvectors are desired, then  LDZ >= max(1,N).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))\n*          If COMPZ = 'N', then WORK is not referenced.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  the algorithm has failed to find all the eigenvalues in\n*                a total of 30*N iterations; if INFO = i, then i\n*                elements of E have not converged to zero; on exit, D\n*                and E contain the elements of a symmetric tridiagonal\n*                matrix which is unitarily similar to the original\n*                matrix.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, e, z = NumRu::Lapack.zsteqr( compz, d, e, z, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_compz = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  rblapack_z = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  compz = StringValueCStr(rblapack_compz)[0];
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (4th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  n = NA_SHAPE1(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_DCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of z");
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
  MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublecomplex*);
  MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  work = ALLOC_N(doublereal, (lsame_(&compz,"N") ? 0 : MAX(1,2*n-2)));

  zsteqr_(&compz, &n, d, e, z, &ldz, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_e, rblapack_z);
}

void
init_lapack_zsteqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zsteqr", rblapack_zsteqr, -1);
}
ruby-lapack-1.7.2/ext/cgecon.c0000644000175000017500000000770212502221015015765 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgecon_(char* norm, integer* n, complex* a, integer* lda, real* anorm, real* rcond, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cgecon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_anorm;
  real anorm; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_info;
  integer info; 
  complex *work;
  real *rwork;

  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  rcond, info = NumRu::Lapack.cgecon( norm, a, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGECON estimates the reciprocal of the condition number of a general\n*  complex matrix A, in either the 1-norm or the infinity-norm, using\n*  the LU factorization computed by CGETRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as\n*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies whether the 1-norm condition number or the\n*          infinity-norm condition number is required:\n*          = '1' or 'O':  1-norm;\n*          = 'I':         Infinity-norm.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The factors L and U from the factorization A = P*L*U\n*          as computed by CGETRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  ANORM   (input) REAL\n*          If NORM = '1' or 'O', the 1-norm of the original matrix A.\n*          If NORM = 'I', the infinity-norm of the original matrix A.\n*\n*  RCOND   (output) REAL\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(norm(A) * norm(inv(A))).\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (2*N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.cgecon( norm, a, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_norm = argv[0];
  rblapack_a = argv[1];
  rblapack_anorm = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  anorm = (real)NUM2DBL(rblapack_anorm);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (2*n));

  cgecon_(&norm, &n, a, &lda, &anorm, &rcond, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_cgecon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgecon", rblapack_cgecon, -1);
}
ruby-lapack-1.7.2/ext/cgbequb.c0000644000175000017500000001371712502221013016140 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgbequb_(integer* m, integer* n, integer* kl, integer* ku, doublereal* ab, integer* ldab, real* r, real* c, real* rowcnd, real* colcnd, real* amax, integer* info);


static VALUE
rblapack_cgbequb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_r;
  real *r; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_rowcnd;
  real rowcnd; 
  VALUE rblapack_colcnd;
  real colcnd; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_info;
  integer info; 

  integer ldab;
  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  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.cgbequb( kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGBEQUB computes row and column scalings intended to equilibrate an\n*  M-by-N matrix A and reduce its condition number.  R returns the row\n*  scale factors and C the column scale factors, chosen to try to make\n*  the largest element in each row and column of the matrix B with\n*  elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n*  the radix.\n*\n*  R(i) and C(j) are restricted to be a power of the radix between\n*  SMLNUM = smallest safe number and BIGNUM = largest safe number.  Use\n*  of these scaling factors is not guaranteed to reduce the condition\n*  number of A but works well in practice.\n*\n*  This routine differs from CGEEQU by restricting the scaling factors\n*  to a power of the radix.  Baring over- and underflow, scaling by\n*  these factors introduces no additional rounding errors.  However, the\n*  scaled entries' magnitured are no longer approximately 1 but lie\n*  between sqrt(radix) and 1/sqrt(radix).\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*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)\n*          On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n*          The j-th column of A is stored in the j-th column of the\n*          array AB as follows:\n*          AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array A.  LDAB >= max(1,M).\n*\n*  R       (output) REAL array, dimension (M)\n*          If INFO = 0 or INFO > M, R contains the row scale factors\n*          for A.\n*\n*  C       (output) REAL array, dimension (N)\n*          If INFO = 0,  C contains the column scale factors for A.\n*\n*  ROWCND  (output) REAL\n*          If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n*          smallest R(i) to the largest R(i).  If ROWCND >= 0.1 and\n*          AMAX is neither too large nor too small, it is not worth\n*          scaling by R.\n*\n*  COLCND  (output) REAL\n*          If INFO = 0, COLCND contains the ratio of the smallest\n*          C(i) to the largest C(i).  If COLCND >= 0.1, it is not\n*          worth scaling by C.\n*\n*  AMAX    (output) REAL\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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,  and i is\n*                <= M:  the i-th row of A is exactly zero\n*                >  M:  the (i-M)-th column of A is exactly zero\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.cgbequb( kl, ku, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_kl = argv[0];
  rblapack_ku = argv[1];
  rblapack_ab = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  ku = NUM2INT(rblapack_ku);
  m = ldab;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_r = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  r = NA_PTR_TYPE(rblapack_r, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  c = NA_PTR_TYPE(rblapack_c, real*);

  cgbequb_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &info);

  rblapack_rowcnd = rb_float_new((double)rowcnd);
  rblapack_colcnd = rb_float_new((double)colcnd);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
}

void
init_lapack_cgbequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgbequb", rblapack_cgbequb, -1);
}
ruby-lapack-1.7.2/ext/csyr.c0000644000175000017500000001316012502221021015477 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID csyr_(char* uplo, integer* n, complex* alpha, complex* x, integer* incx, complex* a, integer* lda);


static VALUE
rblapack_csyr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_alpha;
  complex alpha; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_a_out__;
  complex *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  a = NumRu::Lapack.csyr( uplo, alpha, x, incx, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSYR( UPLO, N, ALPHA, X, INCX, A, LDA )\n\n*  Purpose\n*  =======\n*\n*  CSYR   performs the symmetric rank 1 operation\n*\n*     A := alpha*x*( x' ) + A,\n*\n*  where alpha is a complex scalar, x is an n element vector and A is an\n*  n by n symmetric matrix.\n*\n\n*  Arguments\n*  ==========\n*\n*  UPLO     (input) CHARACTER*1\n*           On entry, UPLO specifies whether the upper or lower\n*           triangular part of the array A is to be referenced as\n*           follows:\n*\n*              UPLO = 'U' or 'u'   Only the upper triangular part of A\n*                                  is to be referenced.\n*\n*              UPLO = 'L' or 'l'   Only the lower triangular part of A\n*                                  is to be referenced.\n*\n*           Unchanged on exit.\n*\n*  N        (input) INTEGER\n*           On entry, N specifies the order of the matrix A.\n*           N must be at least zero.\n*           Unchanged on exit.\n*\n*  ALPHA    (input) COMPLEX\n*           On entry, ALPHA specifies the scalar alpha.\n*           Unchanged on exit.\n*\n*  X        (input) COMPLEX array, dimension at least\n*           ( 1 + ( N - 1 )*abs( INCX ) ).\n*           Before entry, the incremented array X must contain the N-\n*           element vector x.\n*           Unchanged on exit.\n*\n*  INCX     (input) INTEGER\n*           On entry, INCX specifies the increment for the elements of\n*           X. INCX must not be zero.\n*           Unchanged on exit.\n*\n*  A        (input/output) COMPLEX array, dimension ( LDA, N )\n*           Before entry, with  UPLO = 'U' or 'u', the leading n by n\n*           upper triangular part of the array A must contain the upper\n*           triangular part of the symmetric matrix and the strictly\n*           lower triangular part of A is not referenced. On exit, the\n*           upper triangular part of the array A is overwritten by the\n*           upper triangular part of the updated matrix.\n*           Before entry, with UPLO = 'L' or 'l', the leading n by n\n*           lower triangular part of the array A must contain the lower\n*           triangular part of the symmetric matrix and the strictly\n*           upper triangular part of A is not referenced. On exit, the\n*           lower triangular part of the array A is overwritten by the\n*           lower triangular part of the updated matrix.\n*\n*  LDA      (input) INTEGER\n*           On entry, LDA specifies the first dimension of A as declared\n*           in the calling (sub) program. LDA must be at least\n*           max( 1, N ).\n*           Unchanged on exit.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  a = NumRu::Lapack.csyr( uplo, alpha, x, incx, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_alpha = argv[1];
  rblapack_x = argv[2];
  rblapack_incx = argv[3];
  rblapack_a = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  incx = NUM2INT(rblapack_incx);
  alpha.r = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
  alpha.i = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (3th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1 + ( n - 1 )*abs( incx )))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  csyr_(&uplo, &n, &alpha, x, &incx, a, &lda);

  return rblapack_a;
}

void
init_lapack_csyr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "csyr", rblapack_csyr, -1);
}
ruby-lapack-1.7.2/ext/dlasd5.c0000644000175000017500000001073512502221026015705 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlasd5_(integer* i, doublereal* d, doublereal* z, doublereal* delta, doublereal* rho, doublereal* dsigma, doublereal* work);


static VALUE
rblapack_dlasd5(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_i;
  integer i; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_rho;
  doublereal rho; 
  VALUE rblapack_delta;
  doublereal *delta; 
  VALUE rblapack_dsigma;
  doublereal dsigma; 
  doublereal *work;


  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  delta, dsigma = NumRu::Lapack.dlasd5( i, d, z, rho, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK )\n\n*  Purpose\n*  =======\n*\n*  This subroutine computes the square root of the I-th eigenvalue\n*  of a positive symmetric rank-one modification of a 2-by-2 diagonal\n*  matrix\n*\n*             diag( D ) * diag( D ) +  RHO *  Z * transpose(Z) .\n*\n*  The diagonal entries in the array D are assumed to satisfy\n*\n*             0 <= D(i) < D(j)  for  i < j .\n*\n*  We also assume RHO > 0 and that the Euclidean norm of the vector\n*  Z is one.\n*\n\n*  Arguments\n*  =========\n*\n*  I      (input) INTEGER\n*         The index of the eigenvalue to be computed.  I = 1 or I = 2.\n*\n*  D      (input) DOUBLE PRECISION array, dimension ( 2 )\n*         The original eigenvalues.  We assume 0 <= D(1) < D(2).\n*\n*  Z      (input) DOUBLE PRECISION array, dimension ( 2 )\n*         The components of the updating vector.\n*\n*  DELTA  (output) DOUBLE PRECISION array, dimension ( 2 )\n*         Contains (D(j) - sigma_I) in its  j-th component.\n*         The vector DELTA contains the information necessary\n*         to construct the eigenvectors.\n*\n*  RHO    (input) DOUBLE PRECISION\n*         The scalar in the symmetric updating formula.\n*\n*  DSIGMA (output) DOUBLE PRECISION\n*         The computed sigma_I, the I-th updated eigenvalue.\n*\n*  WORK   (workspace) DOUBLE PRECISION array, dimension ( 2 )\n*         WORK contains (D(j) + sigma_I) in its  j-th component.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ren-Cang Li, Computer Science Division, University of California\n*     at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  delta, dsigma = NumRu::Lapack.dlasd5( i, d, z, rho, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_i = argv[0];
  rblapack_d = argv[1];
  rblapack_z = argv[2];
  rblapack_rho = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  i = NUM2INT(rblapack_i);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (3th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != (2))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 2);
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != (2))
    rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", 2);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  rho = NUM2DBL(rblapack_rho);
  {
    na_shape_t shape[1];
    shape[0] = 2;
    rblapack_delta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  delta = NA_PTR_TYPE(rblapack_delta, doublereal*);
  work = ALLOC_N(doublereal, (2));

  dlasd5_(&i, d, z, delta, &rho, &dsigma, work);

  free(work);
  rblapack_dsigma = rb_float_new((double)dsigma);
  return rb_ary_new3(2, rblapack_delta, rblapack_dsigma);
}

void
init_lapack_dlasd5(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlasd5", rblapack_dlasd5, -1);
}
ruby-lapack-1.7.2/ext/dgeesx.c0000644000175000017500000003224112502221021015777 0ustar  uwabamiuwabami#include "rb_lapack.h"

static logical
rblapack_select(doublereal *arg0, doublereal *arg1){
  VALUE rblapack_arg0, rblapack_arg1;

  VALUE rblapack_ret;
  logical ret;

  rblapack_arg0 = rb_float_new((double)(*arg0));
  rblapack_arg1 = rb_float_new((double)(*arg1));

  rblapack_ret = rb_yield_values(2, rblapack_arg0, rblapack_arg1);

  ret = (rblapack_ret == Qtrue);
  return ret;
}

extern VOID dgeesx_(char* jobvs, char* sort, L_fp select, char* sense, integer* n, doublereal* a, integer* lda, integer* sdim, doublereal* wr, doublereal* wi, doublereal* vs, integer* ldvs, doublereal* rconde, doublereal* rcondv, doublereal* work, integer* lwork, integer* iwork, integer* liwork, logical* bwork, integer* info);


static VALUE
rblapack_dgeesx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvs;
  char jobvs; 
  VALUE rblapack_sort;
  char sort; 
  VALUE rblapack_sense;
  char sense; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_sdim;
  integer sdim; 
  VALUE rblapack_wr;
  doublereal *wr; 
  VALUE rblapack_wi;
  doublereal *wi; 
  VALUE rblapack_vs;
  doublereal *vs; 
  VALUE rblapack_rconde;
  doublereal rconde; 
  VALUE rblapack_rcondv;
  doublereal rcondv; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  logical *bwork;

  integer lda;
  integer n;
  integer ldvs;

  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  sdim, wr, wi, vs, rconde, rcondv, work, iwork, info, a = NumRu::Lapack.dgeesx( jobvs, sort, sense, a, liwork, [:lwork => lwork, :usage => usage, :help => help]){|a,b| ... }\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, IWORK, LIWORK, BWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGEESX computes for an N-by-N real nonsymmetric matrix A, the\n*  eigenvalues, the real Schur form T, and, optionally, the matrix of\n*  Schur vectors Z.  This gives the Schur factorization A = Z*T*(Z**T).\n*\n*  Optionally, it also orders the eigenvalues on the diagonal of the\n*  real Schur form so that selected eigenvalues are at the top left;\n*  computes a reciprocal condition number for the average of the\n*  selected eigenvalues (RCONDE); and computes a reciprocal condition\n*  number for the right invariant subspace corresponding to the\n*  selected eigenvalues (RCONDV).  The leading columns of Z form an\n*  orthonormal basis for this invariant subspace.\n*\n*  For further explanation of the reciprocal condition numbers RCONDE\n*  and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where\n*  these quantities are called s and sep respectively).\n*\n*  A real matrix is in real Schur form if it is upper quasi-triangular\n*  with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in\n*  the form\n*            [  a  b  ]\n*            [  c  a  ]\n*\n*  where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVS   (input) CHARACTER*1\n*          = 'N': Schur vectors are not computed;\n*          = 'V': Schur vectors are computed.\n*\n*  SORT    (input) CHARACTER*1\n*          Specifies whether or not to order the eigenvalues on the\n*          diagonal of the Schur form.\n*          = 'N': Eigenvalues are not ordered;\n*          = 'S': Eigenvalues are ordered (see SELECT).\n*\n*  SELECT  (external procedure) LOGICAL FUNCTION of two DOUBLE PRECISION arguments\n*          SELECT must be declared EXTERNAL in the calling subroutine.\n*          If SORT = 'S', SELECT is used to select eigenvalues to sort\n*          to the top left of the Schur form.\n*          If SORT = 'N', SELECT is not referenced.\n*          An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if\n*          SELECT(WR(j),WI(j)) is true; i.e., if either one of a\n*          complex conjugate pair of eigenvalues is selected, then both\n*          are.  Note that a selected complex eigenvalue may no longer\n*          satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since\n*          ordering may change the value of complex eigenvalues\n*          (especially if the eigenvalue is ill-conditioned); in this\n*          case INFO may be set to N+3 (see INFO below).\n*\n*  SENSE   (input) CHARACTER*1\n*          Determines which reciprocal condition numbers are computed.\n*          = 'N': None are computed;\n*          = 'E': Computed for average of selected eigenvalues only;\n*          = 'V': Computed for selected right invariant subspace only;\n*          = 'B': Computed for both.\n*          If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n*          On entry, the N-by-N matrix A.\n*          On exit, A is overwritten by its real Schur form T.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  SDIM    (output) INTEGER\n*          If SORT = 'N', SDIM = 0.\n*          If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n*                         for which SELECT is true. (Complex conjugate\n*                         pairs for which SELECT is true for either\n*                         eigenvalue count as 2.)\n*\n*  WR      (output) DOUBLE PRECISION array, dimension (N)\n*  WI      (output) DOUBLE PRECISION array, dimension (N)\n*          WR and WI contain the real and imaginary parts, respectively,\n*          of the computed eigenvalues, in the same order that they\n*          appear on the diagonal of the output Schur form T.  Complex\n*          conjugate pairs of eigenvalues appear consecutively with the\n*          eigenvalue having the positive imaginary part first.\n*\n*  VS      (output) DOUBLE PRECISION array, dimension (LDVS,N)\n*          If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur\n*          vectors.\n*          If JOBVS = 'N', VS is not referenced.\n*\n*  LDVS    (input) INTEGER\n*          The leading dimension of the array VS.  LDVS >= 1, and if\n*          JOBVS = 'V', LDVS >= N.\n*\n*  RCONDE  (output) DOUBLE PRECISION\n*          If SENSE = 'E' or 'B', RCONDE contains the reciprocal\n*          condition number for the average of the selected eigenvalues.\n*          Not referenced if SENSE = 'N' or 'V'.\n*\n*  RCONDV  (output) DOUBLE PRECISION\n*          If SENSE = 'V' or 'B', RCONDV contains the reciprocal\n*          condition number for the selected right invariant subspace.\n*          Not referenced if SENSE = 'N' or 'E'.\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,3*N).\n*          Also, if SENSE = 'E' or 'V' or 'B',\n*          LWORK >= N+2*SDIM*(N-SDIM), where SDIM is the number of\n*          selected eigenvalues computed by this routine.  Note that\n*          N+2*SDIM*(N-SDIM) <= N+N*N/2. Note also that an error is only\n*          returned if LWORK < max(1,3*N), but if SENSE = 'E' or 'V' or\n*          'B' this may not be large enough.\n*          For good performance, LWORK must generally be larger.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates upper bounds on the optimal sizes of the\n*          arrays WORK and IWORK, returns these values as the first\n*          entries of the WORK and IWORK arrays, and no error messages\n*          related to LWORK or LIWORK are issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.\n*          LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM).\n*          Note that SDIM*(N-SDIM) <= N*N/4. Note also that an error is\n*          only returned if LIWORK < 1, but if SENSE = 'V' or 'B' this\n*          may not be large enough.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates upper bounds on the optimal sizes of\n*          the arrays WORK and IWORK, returns these values as the first\n*          entries of the WORK and IWORK arrays, and no error messages\n*          related to LWORK or LIWORK are issued by XERBLA.\n*\n*  BWORK   (workspace) LOGICAL array, dimension (N)\n*          Not referenced if SORT = 'N'.\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, and i is\n*             <= N: the QR algorithm failed to compute all the\n*                   eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI\n*                   contain those eigenvalues which have converged; if\n*                   JOBVS = 'V', VS contains the transformation which\n*                   reduces A to its partially converged Schur form.\n*             = N+1: the eigenvalues could not be reordered because some\n*                   eigenvalues were too close to separate (the problem\n*                   is very ill-conditioned);\n*             = N+2: after reordering, roundoff changed values of some\n*                   complex eigenvalues so that leading eigenvalues in\n*                   the Schur form no longer satisfy SELECT=.TRUE.  This\n*                   could also be caused by underflow due to scaling.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sdim, wr, wi, vs, rconde, rcondv, work, iwork, info, a = NumRu::Lapack.dgeesx( jobvs, sort, sense, a, liwork, [:lwork => lwork, :usage => usage, :help => help]){|a,b| ... }\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_jobvs = argv[0];
  rblapack_sort = argv[1];
  rblapack_sense = argv[2];
  rblapack_a = argv[3];
  rblapack_liwork = argv[4];
  if (argc == 6) {
    rblapack_lwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  jobvs = StringValueCStr(rblapack_jobvs)[0];
  sense = StringValueCStr(rblapack_sense)[0];
  liwork = NUM2INT(rblapack_liwork);
  sort = StringValueCStr(rblapack_sort)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th 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*);
  ldvs = lsame_(&jobvs,"V") ? n : 1;
  if (rblapack_lwork == Qnil)
    lwork = (lsame_(&sense,"E")||lsame_(&sense,"V")||lsame_(&sense,"B")) ? n+n*n/2 : 3*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  wr = NA_PTR_TYPE(rblapack_wr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  wi = NA_PTR_TYPE(rblapack_wi, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldvs;
    shape[1] = n;
    rblapack_vs = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vs = NA_PTR_TYPE(rblapack_vs, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t 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__;
  bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));

  dgeesx_(&jobvs, &sort, rblapack_select, &sense, &n, a, &lda, &sdim, wr, wi, vs, &ldvs, &rconde, &rcondv, work, &lwork, iwork, &liwork, bwork, &info);

  free(bwork);
  rblapack_sdim = INT2NUM(sdim);
  rblapack_rconde = rb_float_new((double)rconde);
  rblapack_rcondv = rb_float_new((double)rcondv);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(10, rblapack_sdim, rblapack_wr, rblapack_wi, rblapack_vs, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_iwork, rblapack_info, rblapack_a);
}

void
init_lapack_dgeesx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgeesx", rblapack_dgeesx, -1);
}
ruby-lapack-1.7.2/ext/dlags2.c0000644000175000017500000001122212502221026015675 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlags2_(logical* upper, doublereal* a1, doublereal* a2, doublereal* a3, doublereal* b1, doublereal* b2, doublereal* b3, doublereal* csu, doublereal* snu, doublereal* csv, doublereal* snv, doublereal* csq, doublereal* snq);


static VALUE
rblapack_dlags2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_upper;
  logical upper; 
  VALUE rblapack_a1;
  doublereal a1; 
  VALUE rblapack_a2;
  doublereal a2; 
  VALUE rblapack_a3;
  doublereal a3; 
  VALUE rblapack_b1;
  doublereal b1; 
  VALUE rblapack_b2;
  doublereal b2; 
  VALUE rblapack_b3;
  doublereal b3; 
  VALUE rblapack_csu;
  doublereal csu; 
  VALUE rblapack_snu;
  doublereal snu; 
  VALUE rblapack_csv;
  doublereal csv; 
  VALUE rblapack_snv;
  doublereal snv; 
  VALUE rblapack_csq;
  doublereal csq; 
  VALUE rblapack_snq;
  doublereal snq; 


  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  csu, snu, csv, snv, csq, snq = NumRu::Lapack.dlags2( upper, a1, a2, a3, b1, b2, b3, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, SNV, CSQ, SNQ )\n\n*  Purpose\n*  =======\n*\n*  DLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such\n*  that if ( UPPER ) then\n*\n*            U'*A*Q = U'*( A1 A2 )*Q = ( x  0  )\n*                        ( 0  A3 )     ( x  x  )\n*  and\n*            V'*B*Q = V'*( B1 B2 )*Q = ( x  0  )\n*                        ( 0  B3 )     ( x  x  )\n*\n*  or if ( .NOT.UPPER ) then\n*\n*            U'*A*Q = U'*( A1 0  )*Q = ( x  x  )\n*                        ( A2 A3 )     ( 0  x  )\n*  and\n*            V'*B*Q = V'*( B1 0  )*Q = ( x  x  )\n*                        ( B2 B3 )     ( 0  x  )\n*\n*  The rows of the transformed A and B are parallel, where\n*\n*    U = (  CSU  SNU ), V = (  CSV SNV ), Q = (  CSQ   SNQ )\n*        ( -SNU  CSU )      ( -SNV CSV )      ( -SNQ   CSQ )\n*\n*  Z' denotes the transpose of Z.\n*\n*\n\n*  Arguments\n*  =========\n*\n*  UPPER   (input) LOGICAL\n*          = .TRUE.: the input matrices A and B are upper triangular.\n*          = .FALSE.: the input matrices A and B are lower triangular.\n*\n*  A1      (input) DOUBLE PRECISION\n*  A2      (input) DOUBLE PRECISION\n*  A3      (input) DOUBLE PRECISION\n*          On entry, A1, A2 and A3 are elements of the input 2-by-2\n*          upper (lower) triangular matrix A.\n*\n*  B1      (input) DOUBLE PRECISION\n*  B2      (input) DOUBLE PRECISION\n*  B3      (input) DOUBLE PRECISION\n*          On entry, B1, B2 and B3 are elements of the input 2-by-2\n*          upper (lower) triangular matrix B.\n*\n*  CSU     (output) DOUBLE PRECISION\n*  SNU     (output) DOUBLE PRECISION\n*          The desired orthogonal matrix U.\n*\n*  CSV     (output) DOUBLE PRECISION\n*  SNV     (output) DOUBLE PRECISION\n*          The desired orthogonal matrix V.\n*\n*  CSQ     (output) DOUBLE PRECISION\n*  SNQ     (output) DOUBLE PRECISION\n*          The desired orthogonal matrix Q.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  csu, snu, csv, snv, csq, snq = NumRu::Lapack.dlags2( upper, a1, a2, a3, b1, b2, b3, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_upper = argv[0];
  rblapack_a1 = argv[1];
  rblapack_a2 = argv[2];
  rblapack_a3 = argv[3];
  rblapack_b1 = argv[4];
  rblapack_b2 = argv[5];
  rblapack_b3 = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  upper = (rblapack_upper == Qtrue);
  a2 = NUM2DBL(rblapack_a2);
  b1 = NUM2DBL(rblapack_b1);
  b3 = NUM2DBL(rblapack_b3);
  a1 = NUM2DBL(rblapack_a1);
  b2 = NUM2DBL(rblapack_b2);
  a3 = NUM2DBL(rblapack_a3);

  dlags2_(&upper, &a1, &a2, &a3, &b1, &b2, &b3, &csu, &snu, &csv, &snv, &csq, &snq);

  rblapack_csu = rb_float_new((double)csu);
  rblapack_snu = rb_float_new((double)snu);
  rblapack_csv = rb_float_new((double)csv);
  rblapack_snv = rb_float_new((double)snv);
  rblapack_csq = rb_float_new((double)csq);
  rblapack_snq = rb_float_new((double)snq);
  return rb_ary_new3(6, rblapack_csu, rblapack_snu, rblapack_csv, rblapack_snv, rblapack_csq, rblapack_snq);
}

void
init_lapack_dlags2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlags2", rblapack_dlags2, -1);
}
ruby-lapack-1.7.2/ext/chseqr.c0000644000175000017500000003406612502221015016017 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chseqr_(char* job, char* compz, integer* n, integer* ilo, integer* ihi, complex* h, integer* ldh, complex* w, complex* z, integer* ldz, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_chseqr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_compz;
  char compz; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_h;
  complex *h; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_ldz;
  integer ldz; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_w;
  complex *w; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_h_out__;
  complex *h_out__;
  VALUE rblapack_z_out__;
  complex *z_out__;

  integer ldh;
  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  w, work, info, h, z = NumRu::Lapack.chseqr( job, compz, ilo, ihi, h, z, ldz, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, WORK, LWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     CHSEQR computes the eigenvalues of a Hessenberg matrix H\n*     and, optionally, the matrices T and Z from the Schur decomposition\n*     H = Z T Z**H, where T is an upper triangular matrix (the\n*     Schur form), and Z is the unitary matrix of Schur vectors.\n*\n*     Optionally Z may be postmultiplied into an input unitary\n*     matrix Q so that this routine can give the Schur factorization\n*     of a matrix A which has been reduced to the Hessenberg form H\n*     by the unitary matrix Q:  A = Q*H*Q**H = (QZ)*H*(QZ)**H.\n*\n\n*     Arguments\n*     =========\n*\n*     JOB   (input) CHARACTER*1\n*           = 'E':  compute eigenvalues only;\n*           = 'S':  compute eigenvalues and the Schur form T.\n*\n*     COMPZ (input) CHARACTER*1\n*           = 'N':  no Schur vectors are computed;\n*           = 'I':  Z is initialized to the unit matrix and the matrix Z\n*                   of Schur vectors of H is returned;\n*           = 'V':  Z must contain an unitary matrix Q on entry, and\n*                   the product Q*Z is returned.\n*\n*     N     (input) INTEGER\n*           The order of the matrix H.  N .GE. 0.\n*\n*     ILO   (input) INTEGER\n*     IHI   (input) INTEGER\n*           It is assumed that H is already upper triangular in rows\n*           and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n*           set by a previous call to CGEBAL, and then passed to CGEHRD\n*           when the matrix output by CGEBAL is reduced to Hessenberg\n*           form. Otherwise ILO and IHI should be set to 1 and N\n*           respectively.  If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n*           If N = 0, then ILO = 1 and IHI = 0.\n*\n*     H     (input/output) COMPLEX array, dimension (LDH,N)\n*           On entry, the upper Hessenberg matrix H.\n*           On exit, if INFO = 0 and JOB = 'S', H contains the upper\n*           triangular matrix T from the Schur decomposition (the\n*           Schur form). If INFO = 0 and JOB = 'E', the contents of\n*           H are unspecified on exit.  (The output value of H when\n*           INFO.GT.0 is given under the description of INFO below.)\n*\n*           Unlike earlier versions of CHSEQR, this subroutine may\n*           explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1\n*           or j = IHI+1, IHI+2, ... N.\n*\n*     LDH   (input) INTEGER\n*           The leading dimension of the array H. LDH .GE. max(1,N).\n*\n*     W        (output) COMPLEX array, dimension (N)\n*           The computed eigenvalues. If JOB = 'S', the eigenvalues are\n*           stored in the same order as on the diagonal of the Schur\n*           form returned in H, with W(i) = H(i,i).\n*\n*     Z     (input/output) COMPLEX array, dimension (LDZ,N)\n*           If COMPZ = 'N', Z is not referenced.\n*           If COMPZ = 'I', on entry Z need not be set and on exit,\n*           if INFO = 0, Z contains the unitary matrix Z of the Schur\n*           vectors of H.  If COMPZ = 'V', on entry Z must contain an\n*           N-by-N matrix Q, which is assumed to be equal to the unit\n*           matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,\n*           if INFO = 0, Z contains Q*Z.\n*           Normally Q is the unitary matrix generated by CUNGHR\n*           after the call to CGEHRD which formed the Hessenberg matrix\n*           H. (The output value of Z when INFO.GT.0 is given under\n*           the description of INFO below.)\n*\n*     LDZ   (input) INTEGER\n*           The leading dimension of the array Z.  if COMPZ = 'I' or\n*           COMPZ = 'V', then LDZ.GE.MAX(1,N).  Otherwize, LDZ.GE.1.\n*\n*     WORK  (workspace/output) COMPLEX array, dimension (LWORK)\n*           On exit, if INFO = 0, WORK(1) returns an estimate of\n*           the optimal value for LWORK.\n*\n*     LWORK (input) INTEGER\n*           The dimension of the array WORK.  LWORK .GE. max(1,N)\n*           is sufficient and delivers very good and sometimes\n*           optimal performance.  However, LWORK as large as 11*N\n*           may be required for optimal performance.  A workspace\n*           query is recommended to determine the optimal workspace\n*           size.\n*\n*           If LWORK = -1, then CHSEQR does a workspace query.\n*           In this case, CHSEQR checks the input parameters and\n*           estimates the optimal workspace size for the given\n*           values of N, ILO and IHI.  The estimate is returned\n*           in WORK(1).  No error message related to LWORK is\n*           issued by XERBLA.  Neither H nor Z are accessed.\n*\n*\n*     INFO  (output) INTEGER\n*             =  0:  successful exit\n*           .LT. 0:  if INFO = -i, the i-th argument had an illegal\n*                    value\n*           .GT. 0:  if INFO = i, CHSEQR failed to compute all of\n*                the eigenvalues.  Elements 1:ilo-1 and i+1:n of WR\n*                and WI contain those eigenvalues which have been\n*                successfully computed.  (Failures are rare.)\n*\n*                If INFO .GT. 0 and JOB = 'E', then on exit, the\n*                remaining unconverged eigenvalues are the eigen-\n*                values of the upper Hessenberg matrix rows and\n*                columns ILO through INFO of the final, output\n*                value of H.\n*\n*                If INFO .GT. 0 and JOB   = 'S', then on exit\n*\n*           (*)  (initial value of H)*U  = U*(final value of H)\n*\n*                where U is a unitary matrix.  The final\n*                value of  H is upper Hessenberg and triangular in\n*                rows and columns INFO+1 through IHI.\n*\n*                If INFO .GT. 0 and COMPZ = 'V', then on exit\n*\n*                  (final value of Z)  =  (initial value of Z)*U\n*\n*                where U is the unitary matrix in (*) (regard-\n*                less of the value of JOB.)\n*\n*                If INFO .GT. 0 and COMPZ = 'I', then on exit\n*                      (final value of Z)  = U\n*                where U is the unitary matrix in (*) (regard-\n*                less of the value of JOB.)\n*\n*                If INFO .GT. 0 and COMPZ = 'N', then Z is not\n*                accessed.\n*\n\n*     ================================================================\n*             Default values supplied by\n*             ILAENV(ISPEC,'CHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).\n*             It is suggested that these defaults be adjusted in order\n*             to attain best performance in each particular\n*             computational environment.\n*\n*            ISPEC=12: The CLAHQR vs CLAQR0 crossover point.\n*                      Default: 75. (Must be at least 11.)\n*\n*            ISPEC=13: Recommended deflation window size.\n*                      This depends on ILO, IHI and NS.  NS is the\n*                      number of simultaneous shifts returned\n*                      by ILAENV(ISPEC=15).  (See ISPEC=15 below.)\n*                      The default for (IHI-ILO+1).LE.500 is NS.\n*                      The default for (IHI-ILO+1).GT.500 is 3*NS/2.\n*\n*            ISPEC=14: Nibble crossover point. (See IPARMQ for\n*                      details.)  Default: 14% of deflation window\n*                      size.\n*\n*            ISPEC=15: Number of simultaneous shifts in a multishift\n*                      QR iteration.\n*\n*                      If IHI-ILO+1 is ...\n*\n*                      greater than      ...but less    ... the\n*                      or equal to ...      than        default is\n*\n*                           1               30          NS =   2(+)\n*                          30               60          NS =   4(+)\n*                          60              150          NS =  10(+)\n*                         150              590          NS =  **\n*                         590             3000          NS =  64\n*                        3000             6000          NS = 128\n*                        6000             infinity      NS = 256\n*\n*                  (+)  By default some or all matrices of this order\n*                       are passed to the implicit double shift routine\n*                       CLAHQR and this parameter is ignored.  See\n*                       ISPEC=12 above and comments in IPARMQ for\n*                       details.\n*\n*                 (**)  The asterisks (**) indicate an ad-hoc\n*                       function of N increasing from 10 to 64.\n*\n*            ISPEC=16: Select structured matrix multiply.\n*                      If the number of simultaneous shifts (specified\n*                      by ISPEC=15) is less than 14, then the default\n*                      for ISPEC=16 is 0.  Otherwise the default for\n*                      ISPEC=16 is 2.\n*\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n*     References:\n*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n*       Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n*       Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n*       929--947, 2002.\n*\n*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n*       Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n*       of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n*     ================================================================\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, work, info, h, z = NumRu::Lapack.chseqr( job, compz, ilo, ihi, h, z, ldz, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_job = argv[0];
  rblapack_compz = argv[1];
  rblapack_ilo = argv[2];
  rblapack_ihi = argv[3];
  rblapack_h = argv[4];
  rblapack_z = argv[5];
  rblapack_ldz = argv[6];
  if (argc == 8) {
    rblapack_lwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  job = StringValueCStr(rblapack_job)[0];
  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (5th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_SCOMPLEX)
    rblapack_h = na_change_type(rblapack_h, NA_SCOMPLEX);
  h = NA_PTR_TYPE(rblapack_h, complex*);
  ldz = NUM2INT(rblapack_ldz);
  compz = StringValueCStr(rblapack_compz)[0];
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (6th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (6th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_z) != (lsame_(&compz,"N") ? 0 : ldz))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", lsame_(&compz,"N") ? 0 : ldz);
  if (NA_SHAPE1(rblapack_z) != (lsame_(&compz,"N") ? 0 : n))
    rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", lsame_(&compz,"N") ? 0 : n);
  if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, complex*);
  ihi = NUM2INT(rblapack_ihi);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, complex*);
  MEMCPY(h_out__, h, complex, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = lsame_(&compz,"N") ? 0 : ldz;
    shape[1] = lsame_(&compz,"N") ? 0 : n;
    rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
  MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  chseqr_(&job, &compz, &n, &ilo, &ihi, h, &ldh, w, z, &ldz, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_w, rblapack_work, rblapack_info, rblapack_h, rblapack_z);
}

void
init_lapack_chseqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chseqr", rblapack_chseqr, -1);
}
ruby-lapack-1.7.2/ext/dlasd2.c0000644000175000017500000003336312502221017015704 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlasd2_(integer* nl, integer* nr, integer* sqre, integer* k, doublereal* d, doublereal* z, doublereal* alpha, doublereal* beta, doublereal* u, integer* ldu, doublereal* vt, integer* ldvt, doublereal* dsigma, doublereal* u2, integer* ldu2, doublereal* vt2, integer* ldvt2, integer* idxp, integer* idx, integer* idxc, integer* idxq, integer* coltyp, integer* info);


static VALUE
rblapack_dlasd2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_nl;
  integer nl; 
  VALUE rblapack_nr;
  integer nr; 
  VALUE rblapack_sqre;
  integer sqre; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_alpha;
  doublereal alpha; 
  VALUE rblapack_beta;
  doublereal beta; 
  VALUE rblapack_u;
  doublereal *u; 
  VALUE rblapack_vt;
  doublereal *vt; 
  VALUE rblapack_idxq;
  integer *idxq; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_dsigma;
  doublereal *dsigma; 
  VALUE rblapack_u2;
  doublereal *u2; 
  VALUE rblapack_vt2;
  doublereal *vt2; 
  VALUE rblapack_idxc;
  integer *idxc; 
  VALUE rblapack_coltyp;
  integer *coltyp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_u_out__;
  doublereal *u_out__;
  VALUE rblapack_vt_out__;
  doublereal *vt_out__;
  VALUE rblapack_idxq_out__;
  integer *idxq_out__;
  integer *idxp;
  integer *idx;

  integer n;
  integer ldu;
  integer ldvt;
  integer m;
  integer ldu2;
  integer ldvt2;

  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  k, z, dsigma, u2, vt2, idxc, coltyp, info, d, u, vt, idxq = NumRu::Lapack.dlasd2( nl, nr, sqre, d, alpha, beta, u, vt, idxq, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX, IDXC, IDXQ, COLTYP, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLASD2 merges the two sets of singular values together into a single\n*  sorted set.  Then it tries to deflate the size of the problem.\n*  There are two ways in which deflation can occur:  when two or more\n*  singular values are close together or if there is a tiny entry in the\n*  Z vector.  For each such occurrence the order of the related secular\n*  equation problem is reduced by one.\n*\n*  DLASD2 is called from DLASD1.\n*\n\n*  Arguments\n*  =========\n*\n*  NL     (input) INTEGER\n*         The row dimension of the upper block.  NL >= 1.\n*\n*  NR     (input) INTEGER\n*         The row dimension of the lower block.  NR >= 1.\n*\n*  SQRE   (input) INTEGER\n*         = 0: the lower block is an NR-by-NR square matrix.\n*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n*         The bidiagonal matrix has N = NL + NR + 1 rows and\n*         M = N + SQRE >= N columns.\n*\n*  K      (output) INTEGER\n*         Contains the dimension of the non-deflated matrix,\n*         This is the order of the related secular equation. 1 <= K <=N.\n*\n*  D      (input/output) DOUBLE PRECISION array, dimension(N)\n*         On entry D contains the singular values of the two submatrices\n*         to be combined.  On exit D contains the trailing (N-K) updated\n*         singular values (those which were deflated) sorted into\n*         increasing order.\n*\n*  Z      (output) DOUBLE PRECISION array, dimension(N)\n*         On exit Z contains the updating row vector in the secular\n*         equation.\n*\n*  ALPHA  (input) DOUBLE PRECISION\n*         Contains the diagonal element associated with the added row.\n*\n*  BETA   (input) DOUBLE PRECISION\n*         Contains the off-diagonal element associated with the added\n*         row.\n*\n*  U      (input/output) DOUBLE PRECISION array, dimension(LDU,N)\n*         On entry U contains the left singular vectors of two\n*         submatrices in the two square blocks with corners at (1,1),\n*         (NL, NL), and (NL+2, NL+2), (N,N).\n*         On exit U contains the trailing (N-K) updated left singular\n*         vectors (those which were deflated) in its last N-K columns.\n*\n*  LDU    (input) INTEGER\n*         The leading dimension of the array U.  LDU >= N.\n*\n*  VT     (input/output) DOUBLE PRECISION array, dimension(LDVT,M)\n*         On entry VT' contains the right singular vectors of two\n*         submatrices in the two square blocks with corners at (1,1),\n*         (NL+1, NL+1), and (NL+2, NL+2), (M,M).\n*         On exit VT' contains the trailing (N-K) updated right singular\n*         vectors (those which were deflated) in its last N-K columns.\n*         In case SQRE =1, the last row of VT spans the right null\n*         space.\n*\n*  LDVT   (input) INTEGER\n*         The leading dimension of the array VT.  LDVT >= M.\n*\n*  DSIGMA (output) DOUBLE PRECISION array, dimension (N)\n*         Contains a copy of the diagonal elements (K-1 singular values\n*         and one zero) in the secular equation.\n*\n*  U2     (output) DOUBLE PRECISION array, dimension(LDU2,N)\n*         Contains a copy of the first K-1 left singular vectors which\n*         will be used by DLASD3 in a matrix multiply (DGEMM) to solve\n*         for the new left singular vectors. U2 is arranged into four\n*         blocks. The first block contains a column with 1 at NL+1 and\n*         zero everywhere else; the second block contains non-zero\n*         entries only at and above NL; the third contains non-zero\n*         entries only below NL+1; and the fourth is dense.\n*\n*  LDU2   (input) INTEGER\n*         The leading dimension of the array U2.  LDU2 >= N.\n*\n*  VT2    (output) DOUBLE PRECISION array, dimension(LDVT2,N)\n*         VT2' contains a copy of the first K right singular vectors\n*         which will be used by DLASD3 in a matrix multiply (DGEMM) to\n*         solve for the new right singular vectors. VT2 is arranged into\n*         three blocks. The first block contains a row that corresponds\n*         to the special 0 diagonal element in SIGMA; the second block\n*         contains non-zeros only at and before NL +1; the third block\n*         contains non-zeros only at and after  NL +2.\n*\n*  LDVT2  (input) INTEGER\n*         The leading dimension of the array VT2.  LDVT2 >= M.\n*\n*  IDXP   (workspace) INTEGER array dimension(N)\n*         This will contain the permutation used to place deflated\n*         values of D at the end of the array. On output IDXP(2:K)\n*         points to the nondeflated D-values and IDXP(K+1:N)\n*         points to the deflated singular values.\n*\n*  IDX    (workspace) INTEGER array dimension(N)\n*         This will contain the permutation used to sort the contents of\n*         D into ascending order.\n*\n*  IDXC   (output) INTEGER array dimension(N)\n*         This will contain the permutation used to arrange the columns\n*         of the deflated U matrix into three groups:  the first group\n*         contains non-zero entries only at and above NL, the second\n*         contains non-zero entries only below NL+2, and the third is\n*         dense.\n*\n*  IDXQ   (input/output) INTEGER array dimension(N)\n*         This contains the permutation which separately sorts the two\n*         sub-problems in D into ascending order.  Note that entries in\n*         the first hlaf of this permutation must first be moved one\n*         position backward; and entries in the second half\n*         must first have NL+1 added to their values.\n*\n*  COLTYP (workspace/output) INTEGER array dimension(N)\n*         As workspace, this will contain a label which will indicate\n*         which of the following types a column in the U2 matrix or a\n*         row in the VT2 matrix is:\n*         1 : non-zero in the upper half only\n*         2 : non-zero in the lower half only\n*         3 : dense\n*         4 : deflated\n*\n*         On exit, it is an array of dimension 4, with COLTYP(I) being\n*         the dimension of the I-th type columns.\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*  Based on contributions by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  k, z, dsigma, u2, vt2, idxc, coltyp, info, d, u, vt, idxq = NumRu::Lapack.dlasd2( nl, nr, sqre, d, alpha, beta, u, vt, idxq, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_nl = argv[0];
  rblapack_nr = argv[1];
  rblapack_sqre = argv[2];
  rblapack_d = argv[3];
  rblapack_alpha = argv[4];
  rblapack_beta = argv[5];
  rblapack_u = argv[6];
  rblapack_vt = argv[7];
  rblapack_idxq = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  nl = NUM2INT(rblapack_nl);
  sqre = NUM2INT(rblapack_sqre);
  alpha = NUM2DBL(rblapack_alpha);
  if (!NA_IsNArray(rblapack_u))
    rb_raise(rb_eArgError, "u (7th argument) must be NArray");
  if (NA_RANK(rblapack_u) != 2)
    rb_raise(rb_eArgError, "rank of u (7th argument) must be %d", 2);
  ldu = NA_SHAPE0(rblapack_u);
  n = NA_SHAPE1(rblapack_u);
  if (NA_TYPE(rblapack_u) != NA_DFLOAT)
    rblapack_u = na_change_type(rblapack_u, NA_DFLOAT);
  u = NA_PTR_TYPE(rblapack_u, doublereal*);
  if (!NA_IsNArray(rblapack_idxq))
    rb_raise(rb_eArgError, "idxq (9th argument) must be NArray");
  if (NA_RANK(rblapack_idxq) != 1)
    rb_raise(rb_eArgError, "rank of idxq (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_idxq) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of idxq must be the same as shape 1 of u");
  if (NA_TYPE(rblapack_idxq) != NA_LINT)
    rblapack_idxq = na_change_type(rblapack_idxq, NA_LINT);
  idxq = NA_PTR_TYPE(rblapack_idxq, integer*);
  nr = NUM2INT(rblapack_nr);
  beta = NUM2DBL(rblapack_beta);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of u");
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  ldu2 = n;
  if (!NA_IsNArray(rblapack_vt))
    rb_raise(rb_eArgError, "vt (8th argument) must be NArray");
  if (NA_RANK(rblapack_vt) != 2)
    rb_raise(rb_eArgError, "rank of vt (8th argument) must be %d", 2);
  ldvt = NA_SHAPE0(rblapack_vt);
  m = NA_SHAPE1(rblapack_vt);
  if (NA_TYPE(rblapack_vt) != NA_DFLOAT)
    rblapack_vt = na_change_type(rblapack_vt, NA_DFLOAT);
  vt = NA_PTR_TYPE(rblapack_vt, doublereal*);
  ldvt2 = m;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_z = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_dsigma = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  dsigma = NA_PTR_TYPE(rblapack_dsigma, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldu2;
    shape[1] = n;
    rblapack_u2 = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  u2 = NA_PTR_TYPE(rblapack_u2, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldvt2;
    shape[1] = n;
    rblapack_vt2 = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vt2 = NA_PTR_TYPE(rblapack_vt2, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_idxc = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  idxc = NA_PTR_TYPE(rblapack_idxc, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_coltyp = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  coltyp = NA_PTR_TYPE(rblapack_coltyp, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = n;
    rblapack_u_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  u_out__ = NA_PTR_TYPE(rblapack_u_out__, doublereal*);
  MEMCPY(u_out__, u, doublereal, NA_TOTAL(rblapack_u));
  rblapack_u = rblapack_u_out__;
  u = u_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvt;
    shape[1] = m;
    rblapack_vt_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vt_out__ = NA_PTR_TYPE(rblapack_vt_out__, doublereal*);
  MEMCPY(vt_out__, vt, doublereal, NA_TOTAL(rblapack_vt));
  rblapack_vt = rblapack_vt_out__;
  vt = vt_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_idxq_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  idxq_out__ = NA_PTR_TYPE(rblapack_idxq_out__, integer*);
  MEMCPY(idxq_out__, idxq, integer, NA_TOTAL(rblapack_idxq));
  rblapack_idxq = rblapack_idxq_out__;
  idxq = idxq_out__;
  idxp = ALLOC_N(integer, (n));
  idx = ALLOC_N(integer, (n));

  dlasd2_(&nl, &nr, &sqre, &k, d, z, &alpha, &beta, u, &ldu, vt, &ldvt, dsigma, u2, &ldu2, vt2, &ldvt2, idxp, idx, idxc, idxq, coltyp, &info);

  free(idxp);
  free(idx);
  rblapack_k = INT2NUM(k);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(12, rblapack_k, rblapack_z, rblapack_dsigma, rblapack_u2, rblapack_vt2, rblapack_idxc, rblapack_coltyp, rblapack_info, rblapack_d, rblapack_u, rblapack_vt, rblapack_idxq);
}

void
init_lapack_dlasd2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlasd2", rblapack_dlasd2, -1);
}
ruby-lapack-1.7.2/ext/dlatbs.c0000644000175000017500000002506712502221013016002 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlatbs_(char* uplo, char* trans, char* diag, char* normin, integer* n, integer* kd, doublereal* ab, integer* ldab, doublereal* x, doublereal* scale, doublereal* cnorm, integer* info);


static VALUE
rblapack_dlatbs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_normin;
  char normin; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_cnorm;
  doublereal *cnorm; 
  VALUE rblapack_scale;
  doublereal scale; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  doublereal *x_out__;
  VALUE rblapack_cnorm_out__;
  doublereal *cnorm_out__;

  integer ldab;
  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  scale, info, x, cnorm = NumRu::Lapack.dlatbs( uplo, trans, diag, normin, kd, ab, x, cnorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, SCALE, CNORM, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLATBS solves one of the triangular systems\n*\n*     A *x = s*b  or  A'*x = s*b\n*\n*  with scaling to prevent overflow, where A is an upper or lower\n*  triangular band matrix.  Here A' denotes the transpose of A, x and b\n*  are n-element vectors, and s is a scaling factor, usually less than\n*  or equal to 1, chosen so that the components of x will be less than\n*  the overflow threshold.  If the unscaled problem will not cause\n*  overflow, the Level 2 BLAS routine DTBSV is called.  If the matrix A\n*  is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n*  non-trivial solution to A*x = 0 is returned.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the matrix A is upper or lower triangular.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the operation applied to A.\n*          = 'N':  Solve A * x = s*b  (No transpose)\n*          = 'T':  Solve A'* x = s*b  (Transpose)\n*          = 'C':  Solve A'* x = s*b  (Conjugate transpose = Transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          Specifies whether or not the matrix A is unit triangular.\n*          = 'N':  Non-unit triangular\n*          = 'U':  Unit triangular\n*\n*  NORMIN  (input) CHARACTER*1\n*          Specifies whether CNORM has been set or not.\n*          = 'Y':  CNORM contains the column norms on entry\n*          = 'N':  CNORM is not set on entry.  On exit, the norms will\n*                  be computed and stored in CNORM.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of subdiagonals or superdiagonals in the\n*          triangular matrix A.  KD >= 0.\n*\n*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)\n*          The upper or lower triangular band matrix A, stored in the\n*          first KD+1 rows of the array. The j-th column of A is stored\n*          in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  X       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the right hand side b of the triangular system.\n*          On exit, X is overwritten by the solution vector x.\n*\n*  SCALE   (output) DOUBLE PRECISION\n*          The scaling factor s for the triangular system\n*             A * x = s*b  or  A'* x = s*b.\n*          If SCALE = 0, the matrix A is singular or badly scaled, and\n*          the vector x is an exact or approximate solution to A*x = 0.\n*\n*  CNORM   (input or output) DOUBLE PRECISION array, dimension (N)\n*\n*          If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n*          contains the norm of the off-diagonal part of the j-th column\n*          of A.  If TRANS = 'N', CNORM(j) must be greater than or equal\n*          to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n*          must be greater than or equal to the 1-norm.\n*\n*          If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n*          returns the 1-norm of the offdiagonal part of the j-th column\n*          of A.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -k, the k-th argument had an illegal value\n*\n\n*  Further Details\n*  ======= =======\n*\n*  A rough bound on x is computed; if that is less than overflow, DTBSV\n*  is called, otherwise, specific code is used which checks for possible\n*  overflow or divide-by-zero at every operation.\n*\n*  A columnwise scheme is used for solving A*x = b.  The basic algorithm\n*  if A is lower triangular is\n*\n*       x[1:n] := b[1:n]\n*       for j = 1, ..., n\n*            x(j) := x(j) / A(j,j)\n*            x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n*       end\n*\n*  Define bounds on the components of x after j iterations of the loop:\n*     M(j) = bound on x[1:j]\n*     G(j) = bound on x[j+1:n]\n*  Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n*  Then for iteration j+1 we have\n*     M(j+1) <= G(j) / | A(j+1,j+1) |\n*     G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n*            <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n*  where CNORM(j+1) is greater than or equal to the infinity-norm of\n*  column j+1 of A, not counting the diagonal.  Hence\n*\n*     G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n*                  1<=i<=j\n*  and\n*\n*     |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n*                                   1<=i< j\n*\n*  Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTBSV if the\n*  reciprocal of the largest M(j), j=1,..,n, is larger than\n*  max(underflow, 1/overflow).\n*\n*  The bound on x(j) is also used to determine when a step in the\n*  columnwise method can be performed without fear of overflow.  If\n*  the computed bound is greater than a large constant, x is scaled to\n*  prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n*  1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n*  Similarly, a row-wise scheme is used to solve A'*x = b.  The basic\n*  algorithm for A upper triangular is\n*\n*       for j = 1, ..., n\n*            x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n*       end\n*\n*  We simultaneously compute two bounds\n*       G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n*       M(j) = bound on x(i), 1<=i<=j\n*\n*  The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n*  add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n*  Then the bound on x(j) is\n*\n*       M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n*            <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n*                      1<=i<=j\n*\n*  and we can safely call DTBSV if 1/M(n) and 1/G(n) are both greater\n*  than max(underflow, 1/overflow).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, info, x, cnorm = NumRu::Lapack.dlatbs( uplo, trans, diag, normin, kd, ab, x, cnorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_normin = argv[3];
  rblapack_kd = argv[4];
  rblapack_ab = argv[5];
  rblapack_x = argv[6];
  rblapack_cnorm = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  kd = NUM2INT(rblapack_kd);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (7th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (6th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (6th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of x");
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  normin = StringValueCStr(rblapack_normin)[0];
  if (!NA_IsNArray(rblapack_cnorm))
    rb_raise(rb_eArgError, "cnorm (8th argument) must be NArray");
  if (NA_RANK(rblapack_cnorm) != 1)
    rb_raise(rb_eArgError, "rank of cnorm (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_cnorm) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of cnorm must be the same as shape 0 of x");
  if (NA_TYPE(rblapack_cnorm) != NA_DFLOAT)
    rblapack_cnorm = na_change_type(rblapack_cnorm, NA_DFLOAT);
  cnorm = NA_PTR_TYPE(rblapack_cnorm, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_cnorm_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  cnorm_out__ = NA_PTR_TYPE(rblapack_cnorm_out__, doublereal*);
  MEMCPY(cnorm_out__, cnorm, doublereal, NA_TOTAL(rblapack_cnorm));
  rblapack_cnorm = rblapack_cnorm_out__;
  cnorm = cnorm_out__;

  dlatbs_(&uplo, &trans, &diag, &normin, &n, &kd, ab, &ldab, x, &scale, cnorm, &info);

  rblapack_scale = rb_float_new((double)scale);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_scale, rblapack_info, rblapack_x, rblapack_cnorm);
}

void
init_lapack_dlatbs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlatbs", rblapack_dlatbs, -1);
}
ruby-lapack-1.7.2/ext/zgbsvxx.c0000644000175000017500000007420012502221026016241 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgbsvxx_(char* fact, char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, doublecomplex* ab, integer* ldab, doublecomplex* afb, integer* ldafb, integer* ipiv, char* equed, doublereal* r, doublereal* c, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* rpvgrw, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zgbsvxx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_afb;
  doublecomplex *afb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_r;
  doublereal *r; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_params;
  doublereal *params; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_rpvgrw;
  doublereal rpvgrw; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_err_bnds_norm;
  doublereal *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  doublereal *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublecomplex *ab_out__;
  VALUE rblapack_afb_out__;
  doublecomplex *afb_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  VALUE rblapack_r_out__;
  doublereal *r_out__;
  VALUE rblapack_c_out__;
  doublereal *c_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  VALUE rblapack_params_out__;
  doublereal *params_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer ldab;
  integer n;
  integer ldafb;
  integer ldb;
  integer nrhs;
  integer nparams;
  integer ldx;
  integer n_err_bnds;

  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  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, ab, afb, ipiv, equed, r, c, b, params = NumRu::Lapack.zgbsvxx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     ZGBSVXX uses the LU factorization to compute the solution to a\n*     complex*16 system of linear equations  A * X = B,  where A is an\n*     N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n*     If requested, both normwise and maximum componentwise error bounds\n*     are returned. ZGBSVXX will return a solution with a tiny\n*     guaranteed error (O(eps) where eps is the working machine\n*     precision) unless the matrix is very ill-conditioned, in which\n*     case a warning is returned. Relevant condition numbers also are\n*     calculated and returned.\n*\n*     ZGBSVXX accepts user-provided factorizations and equilibration\n*     factors; see the definitions of the FACT and EQUED options.\n*     Solving with refinement and using a factorization from a previous\n*     ZGBSVXX call will also produce a solution with either O(eps)\n*     errors or warnings, but we cannot make that claim for general\n*     user-provided factorizations and equilibration factors if they\n*     differ from what ZGBSVXX would itself produce.\n*\n*     Description\n*     ===========\n*\n*     The following steps are performed:\n*\n*     1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n*     the system:\n*\n*       TRANS = 'N':  diag(R)*A*diag(C)     *inv(diag(C))*X = diag(R)*B\n*       TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n*       TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n*     or diag(C)*B (if TRANS = 'T' or 'C').\n*\n*     2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n*     the matrix A (after equilibration if FACT = 'E') as\n*\n*       A = P * L * U,\n*\n*     where P is a permutation matrix, L is a unit lower triangular\n*     matrix, and U is upper triangular.\n*\n*     3. If some U(i,i)=0, so that U is exactly singular, then the\n*     routine returns with INFO = i. Otherwise, the factored form of A\n*     is used to estimate the condition number of the matrix A (see\n*     argument RCOND). If the reciprocal of the condition number is less\n*     than machine precision, the routine still goes on to solve for X\n*     and compute error bounds as described below.\n*\n*     4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*     5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n*     the routine will use iterative refinement to try to get a small\n*     error and error bounds.  Refinement calculates the residual to at\n*     least twice the working precision.\n*\n*     6. If equilibration was used, the matrix X is premultiplied by\n*     diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n*     that it solves the original system before equilibration.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     FACT    (input) CHARACTER*1\n*     Specifies whether or not the factored form of the matrix A is\n*     supplied on entry, and if not, whether the matrix A should be\n*     equilibrated before it is factored.\n*       = 'F':  On entry, AF and IPIV contain the factored form of A.\n*               If EQUED is not 'N', the matrix A has been\n*               equilibrated with scaling factors given by R and C.\n*               A, AF, and IPIV are not modified.\n*       = 'N':  The matrix A will be copied to AF and factored.\n*       = 'E':  The matrix A will be equilibrated if necessary, then\n*               copied to AF and factored.\n*\n*     TRANS   (input) CHARACTER*1\n*     Specifies the form of the system of equations:\n*       = 'N':  A * X = B     (No transpose)\n*       = 'T':  A**T * X = B  (Transpose)\n*       = 'C':  A**H * X = B  (Conjugate Transpose = Transpose)\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     KL      (input) INTEGER\n*     The number of subdiagonals within the band of A.  KL >= 0.\n*\n*     KU      (input) INTEGER\n*     The number of superdiagonals within the band of A.  KU >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)\n*     On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n*     The j-th column of A is stored in the j-th column of the\n*     array AB as follows:\n*     AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n*     If FACT = 'F' and EQUED is not 'N', then AB must have been\n*     equilibrated by the scaling factors in R and/or C.  AB is not\n*     modified if FACT = 'F' or 'N', or if FACT = 'E' and\n*     EQUED = 'N' on exit.\n*\n*     On exit, if EQUED .ne. 'N', A is scaled as follows:\n*     EQUED = 'R':  A := diag(R) * A\n*     EQUED = 'C':  A := A * diag(C)\n*     EQUED = 'B':  A := diag(R) * A * diag(C).\n*\n*     LDAB    (input) INTEGER\n*     The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*     AFB     (input or output) COMPLEX*16 array, dimension (LDAFB,N)\n*     If FACT = 'F', then AFB is an input argument and on entry\n*     contains details of the LU factorization of the band matrix\n*     A, as computed by ZGBTRF.  U is stored as an upper triangular\n*     band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n*     and the multipliers used during the factorization are stored\n*     in rows KL+KU+2 to 2*KL+KU+1.  If EQUED .ne. 'N', then AFB is\n*     the factored form of the equilibrated matrix A.\n*\n*     If FACT = 'N', then AF is an output argument and on exit\n*     returns the factors L and U from the factorization A = P*L*U\n*     of the original matrix A.\n*\n*     If FACT = 'E', then AF is an output argument and on exit\n*     returns the factors L and U from the factorization A = P*L*U\n*     of the equilibrated matrix A (see the description of A for\n*     the form of the equilibrated matrix).\n*\n*     LDAFB   (input) INTEGER\n*     The leading dimension of the array AFB.  LDAFB >= 2*KL+KU+1.\n*\n*     IPIV    (input or output) INTEGER array, dimension (N)\n*     If FACT = 'F', then IPIV is an input argument and on entry\n*     contains the pivot indices from the factorization A = P*L*U\n*     as computed by DGETRF; row i of the matrix was interchanged\n*     with row IPIV(i).\n*\n*     If FACT = 'N', then IPIV is an output argument and on exit\n*     contains the pivot indices from the factorization A = P*L*U\n*     of the original matrix A.\n*\n*     If FACT = 'E', then IPIV is an output argument and on exit\n*     contains the pivot indices from the factorization A = P*L*U\n*     of the equilibrated matrix A.\n*\n*     EQUED   (input or output) CHARACTER*1\n*     Specifies the form of equilibration that was done.\n*       = 'N':  No equilibration (always true if FACT = 'N').\n*       = 'R':  Row equilibration, i.e., A has been premultiplied by\n*               diag(R).\n*       = 'C':  Column equilibration, i.e., A has been postmultiplied\n*               by diag(C).\n*       = 'B':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(R) * A * diag(C).\n*     EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*     output argument.\n*\n*     R       (input or output) DOUBLE PRECISION array, dimension (N)\n*     The row scale factors for A.  If EQUED = 'R' or 'B', A is\n*     multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n*     is not accessed.  R is an input argument if FACT = 'F';\n*     otherwise, R is an output argument.  If FACT = 'F' and\n*     EQUED = 'R' or 'B', each element of R must be positive.\n*     If R is output, each element of R is a power of the radix.\n*     If R is input, each element of R should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     C       (input or output) DOUBLE PRECISION array, dimension (N)\n*     The column scale factors for A.  If EQUED = 'C' or 'B', A is\n*     multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n*     is not accessed.  C is an input argument if FACT = 'F';\n*     otherwise, C is an output argument.  If FACT = 'F' and\n*     EQUED = 'C' or 'B', each element of C must be positive.\n*     If C is output, each element of C is a power of the radix.\n*     If C is input, each element of C should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*     On entry, the N-by-NRHS right hand side matrix B.\n*     On exit,\n*     if EQUED = 'N', B is not modified;\n*     if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n*        diag(R)*B;\n*     if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n*        overwritten by diag(C)*B.\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (output) COMPLEX*16 array, dimension (LDX,NRHS)\n*     If INFO = 0, the N-by-NRHS solution matrix X to the original\n*     system of equations.  Note that A and B are modified on exit\n*     if EQUED .ne. 'N', and the solution to the equilibrated system is\n*     inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n*     inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) DOUBLE PRECISION\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     RPVGRW  (output) DOUBLE PRECISION\n*     Reciprocal pivot growth.  On exit, this contains the reciprocal\n*     pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n*     norm is used.  If this is much less than 1, then the stability of\n*     the LU factorization of the (equilibrated) matrix A could be poor.\n*     This also means that the solution X, estimated condition numbers,\n*     and error bounds could be unreliable. If factorization fails with\n*     0 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, ab, afb, ipiv, equed, r, c, b, params = NumRu::Lapack.zgbsvxx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_fact = argv[0];
  rblapack_trans = argv[1];
  rblapack_kl = argv[2];
  rblapack_ku = argv[3];
  rblapack_ab = argv[4];
  rblapack_afb = argv[5];
  rblapack_ipiv = argv[6];
  rblapack_equed = argv[7];
  rblapack_r = argv[8];
  rblapack_c = argv[9];
  rblapack_b = argv[10];
  rblapack_params = argv[11];
  if (argc == 12) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_r))
    rb_raise(rb_eArgError, "r (9th argument) must be NArray");
  if (NA_RANK(rblapack_r) != 1)
    rb_raise(rb_eArgError, "rank of r (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_r) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_r) != NA_DFLOAT)
    rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
  r = NA_PTR_TYPE(rblapack_r, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (11th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (11th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  n_err_bnds = 3;
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
  ldafb = NA_SHAPE0(rblapack_afb);
  if (NA_SHAPE1(rblapack_afb) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_afb) != NA_DCOMPLEX)
    rblapack_afb = na_change_type(rblapack_afb, NA_DCOMPLEX);
  afb = NA_PTR_TYPE(rblapack_afb, doublecomplex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (10th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (10th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  ldx = MAX(1,n);
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (12th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (12th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_DFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
  params = NA_PTR_TYPE(rblapack_params, doublereal*);
  equed = StringValueCStr(rblapack_equed)[0];
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
  MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldafb;
    shape[1] = n;
    rblapack_afb_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  afb_out__ = NA_PTR_TYPE(rblapack_afb_out__, doublecomplex*);
  MEMCPY(afb_out__, afb, doublecomplex, NA_TOTAL(rblapack_afb));
  rblapack_afb = rblapack_afb_out__;
  afb = afb_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_r_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  r_out__ = NA_PTR_TYPE(rblapack_r_out__, doublereal*);
  MEMCPY(r_out__, r, doublereal, NA_TOTAL(rblapack_r));
  rblapack_r = rblapack_r_out__;
  r = r_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
  MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (2*n));

  zgbsvxx_(&fact, &trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_rpvgrw = rb_float_new((double)rpvgrw);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(15, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_ab, rblapack_afb, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b, rblapack_params);
}

void
init_lapack_zgbsvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgbsvxx", rblapack_zgbsvxx, -1);
}
ruby-lapack-1.7.2/ext/srscl.c0000644000175000017500000000626112502221016015655 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID srscl_(integer* n, real* sa, real* sx, integer* incx);


static VALUE
rblapack_srscl(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_sa;
  real sa; 
  VALUE rblapack_sx;
  real *sx; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_sx_out__;
  real *sx_out__;


  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  sx = NumRu::Lapack.srscl( n, sa, sx, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SRSCL( N, SA, SX, INCX )\n\n*  Purpose\n*  =======\n*\n*  SRSCL multiplies an n-element real vector x by the real scalar 1/a.\n*  This is done without overflow or underflow as long as\n*  the final result x/a does not overflow or underflow.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of components of the vector x.\n*\n*  SA      (input) REAL\n*          The scalar a which is used to divide each component of x.\n*          SA must be >= 0, or the subroutine will divide by zero.\n*\n*  SX      (input/output) REAL array, dimension\n*                         (1+(N-1)*abs(INCX))\n*          The n-element vector x.\n*\n*  INCX    (input) INTEGER\n*          The increment between successive values of the vector SX.\n*          > 0:  SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i),     1< i<= n\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sx = NumRu::Lapack.srscl( n, sa, sx, incx, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_n = argv[0];
  rblapack_sa = argv[1];
  rblapack_sx = argv[2];
  rblapack_incx = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  incx = NUM2INT(rblapack_incx);
  sa = (real)NUM2DBL(rblapack_sa);
  if (!NA_IsNArray(rblapack_sx))
    rb_raise(rb_eArgError, "sx (3th argument) must be NArray");
  if (NA_RANK(rblapack_sx) != 1)
    rb_raise(rb_eArgError, "rank of sx (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_sx) != (1+(n-1)*abs(incx)))
    rb_raise(rb_eRuntimeError, "shape 0 of sx must be %d", 1+(n-1)*abs(incx));
  if (NA_TYPE(rblapack_sx) != NA_SFLOAT)
    rblapack_sx = na_change_type(rblapack_sx, NA_SFLOAT);
  sx = NA_PTR_TYPE(rblapack_sx, real*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*abs(incx);
    rblapack_sx_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  sx_out__ = NA_PTR_TYPE(rblapack_sx_out__, real*);
  MEMCPY(sx_out__, sx, real, NA_TOTAL(rblapack_sx));
  rblapack_sx = rblapack_sx_out__;
  sx = sx_out__;

  srscl_(&n, &sa, sx, &incx);

  return rblapack_sx;
}

void
init_lapack_srscl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "srscl", rblapack_srscl, -1);
}
ruby-lapack-1.7.2/ext/dlaed1.c0000644000175000017500000002041512655767576015721 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaed1_(integer* n, doublereal* d, doublereal* q, integer* ldq, integer* indxq, doublereal* rho, integer* cutpnt, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dlaed1(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_q;
  doublereal *q; 
  VALUE rblapack_indxq;
  integer *indxq; 
  VALUE rblapack_rho;
  doublereal rho; 
  VALUE rblapack_cutpnt;
  integer cutpnt; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_q_out__;
  doublereal *q_out__;
  VALUE rblapack_indxq_out__;
  integer *indxq_out__;
  doublereal *work;
  integer *iwork;

  integer n;
  integer ldq;

  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  info, d, q, indxq = NumRu::Lapack.dlaed1( d, q, indxq, rho, cutpnt, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLAED1 computes the updated eigensystem of a diagonal\n*  matrix after modification by a rank-one symmetric matrix.  This\n*  routine is used only for the eigenproblem which requires all\n*  eigenvalues and eigenvectors of a tridiagonal matrix.  DLAED7 handles\n*  the case in which eigenvalues only or eigenvalues and eigenvectors\n*  of a full symmetric matrix (which was reduced to tridiagonal form)\n*  are desired.\n*\n*    T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)\n*\n*     where Z = Q'u, u is a vector of length N with ones in the\n*     CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.\n*\n*     The eigenvectors of the original matrix are stored in Q, and the\n*     eigenvalues are in D.  The algorithm consists of three stages:\n*\n*        The first stage consists of deflating the size of the problem\n*        when there are multiple eigenvalues or if there is a zero in\n*        the Z vector.  For each such occurrence the dimension of the\n*        secular equation problem is reduced by one.  This stage is\n*        performed by the routine DLAED2.\n*\n*        The second stage consists of calculating the updated\n*        eigenvalues. This is done by finding the roots of the secular\n*        equation via the routine DLAED4 (as called by DLAED3).\n*        This routine also calculates the eigenvectors of the current\n*        problem.\n*\n*        The final stage consists of computing the updated eigenvectors\n*        directly using the updated eigenvalues.  The eigenvectors for\n*        the current problem are multiplied with the eigenvectors from\n*        the overall problem.\n*\n\n*  Arguments\n*  =========\n*\n*  N      (input) INTEGER\n*         The dimension of the symmetric tridiagonal matrix.  N >= 0.\n*\n*  D      (input/output) DOUBLE PRECISION array, dimension (N)\n*         On entry, the eigenvalues of the rank-1-perturbed matrix.\n*         On exit, the eigenvalues of the repaired matrix.\n*\n*  Q      (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n*         On entry, the eigenvectors of the rank-1-perturbed matrix.\n*         On exit, the eigenvectors of the repaired tridiagonal matrix.\n*\n*  LDQ    (input) INTEGER\n*         The leading dimension of the array Q.  LDQ >= max(1,N).\n*\n*  INDXQ  (input/output) INTEGER array, dimension (N)\n*         On entry, the permutation which separately sorts the two\n*         subproblems in D into ascending order.\n*         On exit, the permutation which will reintegrate the\n*         subproblems back into sorted order,\n*         i.e. D( INDXQ( I = 1, N ) ) will be in ascending order.\n*\n*  RHO    (input) DOUBLE PRECISION\n*         The subdiagonal entry used to create the rank-1 modification.\n*\n*  CUTPNT (input) INTEGER\n*         The location of the last eigenvalue in the leading sub-matrix.\n*         min(1,N) <= CUTPNT <= N/2.\n*\n*  WORK   (workspace) DOUBLE PRECISION array, dimension (4*N + N**2)\n*\n*  IWORK  (workspace) INTEGER array, dimension (4*N)\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 = 1, an eigenvalue did not converge\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Jeff Rutter, Computer Science Division, University of California\n*     at Berkeley, USA\n*  Modified by Francoise Tisseur, University of Tennessee.\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            COLTYP, I, IDLMDA, INDX, INDXC, INDXP, IQ2, IS,\n     $                   IW, IZ, K, N1, N2, ZPP1\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DCOPY, DLAED2, DLAED3, DLAMRG, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, q, indxq = NumRu::Lapack.dlaed1( d, q, indxq, rho, cutpnt, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_d = argv[0];
  rblapack_q = argv[1];
  rblapack_indxq = argv[2];
  rblapack_rho = argv[3];
  rblapack_cutpnt = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_indxq))
    rb_raise(rb_eArgError, "indxq (3th argument) must be NArray");
  if (NA_RANK(rblapack_indxq) != 1)
    rb_raise(rb_eArgError, "rank of indxq (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_indxq) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of indxq must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_indxq) != NA_LINT)
    rblapack_indxq = na_change_type(rblapack_indxq, NA_LINT);
  indxq = NA_PTR_TYPE(rblapack_indxq, integer*);
  cutpnt = NUM2INT(rblapack_cutpnt);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (2th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (2th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_q) != NA_DFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
  q = NA_PTR_TYPE(rblapack_q, doublereal*);
  rho = NUM2DBL(rblapack_rho);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
  MEMCPY(q_out__, q, doublereal, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_indxq_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  indxq_out__ = NA_PTR_TYPE(rblapack_indxq_out__, integer*);
  MEMCPY(indxq_out__, indxq, integer, NA_TOTAL(rblapack_indxq));
  rblapack_indxq = rblapack_indxq_out__;
  indxq = indxq_out__;
  work = ALLOC_N(doublereal, (4*n + pow(n,2)));
  iwork = ALLOC_N(integer, (4*n));

  dlaed1_(&n, d, q, &ldq, indxq, &rho, &cutpnt, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_q, rblapack_indxq);
}

void
init_lapack_dlaed1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaed1", rblapack_dlaed1, -1);
}
ruby-lapack-1.7.2/ext/zstegr.c0000644000175000017500000003064512502221023016046 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zstegr_(char* jobz, char* range, integer* n, doublereal* d, doublereal* e, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublecomplex* z, integer* ldz, integer* isuppz, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_zstegr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_vl;
  doublereal vl; 
  VALUE rblapack_vu;
  doublereal vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  doublereal abstol; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_isuppz;
  integer *isuppz; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_e_out__;
  doublereal *e_out__;

  integer n;
  integer ldz;

  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  m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.zstegr( jobz, range, d, e, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZSTEGR computes selected eigenvalues and, optionally, eigenvectors\n*  of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n*  a well defined set of pairwise different real eigenvalues, the corresponding\n*  real eigenvectors are pairwise orthogonal.\n*\n*  The spectrum may be computed either completely or partially by specifying\n*  either an interval (VL,VU] or a range of indices IL:IU for the desired\n*  eigenvalues.\n*\n*  ZSTEGR is a compatability wrapper around the improved ZSTEMR routine.\n*  See DSTEMR for further details.\n*\n*  One important change is that the ABSTOL parameter no longer provides any\n*  benefit and hence is no longer used.\n*\n*  Note : ZSTEGR and ZSTEMR work only on machines which follow\n*  IEEE-754 floating-point standard in their handling of infinities and\n*  NaNs.  Normal execution may create these exceptiona values and hence\n*  may abort due to a floating point exception in environments which\n*  do not conform to the IEEE-754 standard.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found.\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found.\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the N diagonal elements of the tridiagonal matrix\n*          T. On exit, D is overwritten.\n*\n*  E       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the (N-1) subdiagonal elements of the tridiagonal\n*          matrix T in elements 1 to N-1 of E. E(N) need not be set on\n*          input, but is used internally as workspace.\n*          On exit, E is overwritten.\n*\n*  VL      (input) DOUBLE PRECISION\n*  VU      (input) DOUBLE PRECISION\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) DOUBLE PRECISION\n*          Unused.  Was the absolute error tolerance for the\n*          eigenvalues/eigenvectors in previous versions.\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          The first M elements contain the selected eigenvalues in\n*          ascending order.\n*\n*  Z       (output) COMPLEX*16 array, dimension (LDZ, max(1,M) )\n*          If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix T\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*          Supplying N columns is always safe.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', then LDZ >= max(1,N).\n*\n*  ISUPPZ  (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n*          The support of the eigenvectors in Z, i.e., the indices\n*          indicating the nonzero elements in Z. The i-th computed eigenvector\n*          is nonzero only in elements ISUPPZ( 2*i-1 ) through\n*          ISUPPZ( 2*i ). This is relevant in the case when the matrix\n*          is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n*\n*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)\n*          On exit, if INFO = 0, WORK(1) returns the optimal\n*          (and minimal) LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK. LWORK >= max(1,18*N)\n*          if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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*  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.  LIWORK >= max(1,10*N)\n*          if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n*          if only the eigenvalues are to be computed.\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal size of the IWORK array,\n*          returns this value as the first entry of the IWORK array, and\n*          no error message related to LIWORK is issued by XERBLA.\n*\n*  INFO    (output) INTEGER\n*          On exit, INFO\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  if INFO = 1X, internal error in DLARRE,\n*                if INFO = 2X, internal error in ZLARRV.\n*                Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n*                the nonzero error code returned by DLARRE or\n*                ZLARRV, respectively.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Inderjit Dhillon, IBM Almaden, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, LBNL/NERSC, USA\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL TRYRAC\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL ZSTEMR\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.zstegr( jobz, range, d, e, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 11)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_d = argv[2];
  rblapack_e = argv[3];
  rblapack_vl = argv[4];
  rblapack_vu = argv[5];
  rblapack_il = argv[6];
  rblapack_iu = argv[7];
  rblapack_abstol = argv[8];
  if (argc == 11) {
    rblapack_lwork = argv[9];
    rblapack_liwork = argv[10];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  vl = NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  abstol = NUM2DBL(rblapack_abstol);
  range = StringValueCStr(rblapack_range)[0];
  vu = NUM2DBL(rblapack_vu);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (4th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&jobz,"V") ? 18*n : lsame_(&jobz,"N") ? 12*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  iu = NUM2INT(rblapack_iu);
  m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
  if (rblapack_liwork == Qnil)
    liwork = lsame_(&jobz,"V") ? 10*n : lsame_(&jobz,"N") ? 8*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = 2*MAX(1,m);
    rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
  MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;

  zstegr_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, isuppz, work, &lwork, iwork, &liwork, &info);

  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_m, rblapack_w, rblapack_z, rblapack_isuppz, rblapack_work, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e);
}

void
init_lapack_zstegr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zstegr", rblapack_zstegr, -1);
}
ruby-lapack-1.7.2/ext/zunm2r.c0000644000175000017500000001445612502221014015767 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zunm2r_(char* side, char* trans, integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work, integer* info);


static VALUE
rblapack_zunm2r(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_c;
  doublecomplex *c; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublecomplex *c_out__;
  doublecomplex *work;

  integer lda;
  integer k;
  integer ldc;
  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  info, c = NumRu::Lapack.zunm2r( side, trans, m, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZUNM2R overwrites the general complex m-by-n matrix C with\n*\n*        Q * C  if SIDE = 'L' and TRANS = 'N', or\n*\n*        Q'* C  if SIDE = 'L' and TRANS = 'C', or\n*\n*        C * Q  if SIDE = 'R' and TRANS = 'N', or\n*\n*        C * Q' if SIDE = 'R' and TRANS = 'C',\n*\n*  where Q is a complex unitary matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(1) H(2) . . . H(k)\n*\n*  as returned by ZGEQRF. Q is of order m if SIDE = 'L' and of order n\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q' from the Left\n*          = 'R': apply Q or Q' from the Right\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': apply Q  (No transpose)\n*          = 'C': apply Q' (Conjugate transpose)\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,K)\n*          The i-th column must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          ZGEQRF in the first k columns of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*          If SIDE = 'L', LDA >= max(1,M);\n*          if SIDE = 'R', LDA >= max(1,N).\n*\n*  TAU     (input) COMPLEX*16 array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by ZGEQRF.\n*\n*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)\n*          On entry, the m-by-n matrix C.\n*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension\n*                                   (N) if SIDE = 'L',\n*                                   (M) if SIDE = 'R'\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, c = NumRu::Lapack.zunm2r( side, trans, m, a, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_m = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != k)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
  MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(doublecomplex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  zunm2r_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_c);
}

void
init_lapack_zunm2r(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zunm2r", rblapack_zunm2r, -1);
}
ruby-lapack-1.7.2/ext/clarz.c0000644000175000017500000001254212502221016015641 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clarz_(char* side, integer* m, integer* n, integer* l, complex* v, integer* incv, complex* tau, complex* c, integer* ldc, complex* work);


static VALUE
rblapack_clarz(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_v;
  complex *v; 
  VALUE rblapack_incv;
  integer incv; 
  VALUE rblapack_tau;
  complex tau; 
  VALUE rblapack_c;
  complex *c; 
  VALUE rblapack_c_out__;
  complex *c_out__;
  complex *work;

  integer ldc;
  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  c = NumRu::Lapack.clarz( side, m, l, v, incv, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK )\n\n*  Purpose\n*  =======\n*\n*  CLARZ applies a complex elementary reflector H to a complex\n*  M-by-N matrix C, from either the left or the right. H is represented\n*  in the form\n*\n*        H = I - tau * v * v'\n*\n*  where tau is a complex scalar and v is a complex vector.\n*\n*  If tau = 0, then H is taken to be the unit matrix.\n*\n*  To apply H' (the conjugate transpose of H), supply conjg(tau) instead\n*  tau.\n*\n*  H is a product of k elementary reflectors as returned by CTZRZF.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': form  H * C\n*          = 'R': form  C * H\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C.\n*\n*  L       (input) INTEGER\n*          The number of entries of the vector V containing\n*          the meaningful part of the Householder vectors.\n*          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n*  V       (input) COMPLEX array, dimension (1+(L-1)*abs(INCV))\n*          The vector v in the representation of H as returned by\n*          CTZRZF. V is not used if TAU = 0.\n*\n*  INCV    (input) INTEGER\n*          The increment between elements of v. INCV <> 0.\n*\n*  TAU     (input) COMPLEX\n*          The value tau in the representation of H.\n*\n*  C       (input/output) COMPLEX array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n*          or C * H if SIDE = 'R'.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) COMPLEX array, dimension\n*                         (N) if SIDE = 'L'\n*                      or (M) if SIDE = 'R'\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.clarz( side, m, l, v, incv, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_side = argv[0];
  rblapack_m = argv[1];
  rblapack_l = argv[2];
  rblapack_v = argv[3];
  rblapack_incv = argv[4];
  rblapack_tau = argv[5];
  rblapack_c = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  l = NUM2INT(rblapack_l);
  incv = NUM2INT(rblapack_incv);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, complex*);
  m = NUM2INT(rblapack_m);
  tau.r = (real)NUM2DBL(rb_funcall(rblapack_tau, rb_intern("real"), 0));
  tau.i = (real)NUM2DBL(rb_funcall(rblapack_tau, rb_intern("imag"), 0));
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (4th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 1)
    rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_v) != (1+(l-1)*abs(incv)))
    rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1+(l-1)*abs(incv));
  if (NA_TYPE(rblapack_v) != NA_SCOMPLEX)
    rblapack_v = na_change_type(rblapack_v, NA_SCOMPLEX);
  v = NA_PTR_TYPE(rblapack_v, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
  MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(complex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  clarz_(&side, &m, &n, &l, v, &incv, &tau, c, &ldc, work);

  free(work);
  return rblapack_c;
}

void
init_lapack_clarz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clarz", rblapack_clarz, -1);
}
ruby-lapack-1.7.2/ext/dlasy2.c0000644000175000017500000001565412502221022015730 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlasy2_(logical* ltranl, logical* ltranr, integer* isgn, integer* n1, integer* n2, doublereal* tl, integer* ldtl, doublereal* tr, integer* ldtr, doublereal* b, integer* ldb, doublereal* scale, doublereal* x, integer* ldx, doublereal* xnorm, integer* info);


static VALUE
rblapack_dlasy2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ltranl;
  logical ltranl; 
  VALUE rblapack_ltranr;
  logical ltranr; 
  VALUE rblapack_isgn;
  integer isgn; 
  VALUE rblapack_n1;
  integer n1; 
  VALUE rblapack_n2;
  integer n2; 
  VALUE rblapack_tl;
  doublereal *tl; 
  VALUE rblapack_tr;
  doublereal *tr; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_scale;
  doublereal scale; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_xnorm;
  doublereal xnorm; 
  VALUE rblapack_info;
  integer info; 

  integer ldtl;
  integer ldtr;
  integer ldb;
  integer ldx;

  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  scale, x, xnorm, info = NumRu::Lapack.dlasy2( ltranl, ltranr, isgn, n1, n2, tl, tr, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in\n*\n*         op(TL)*X + ISGN*X*op(TR) = SCALE*B,\n*\n*  where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or\n*  -1.  op(T) = T or T', where T' denotes the transpose of T.\n*\n\n*  Arguments\n*  =========\n*\n*  LTRANL  (input) LOGICAL\n*          On entry, LTRANL specifies the op(TL):\n*             = .FALSE., op(TL) = TL,\n*             = .TRUE., op(TL) = TL'.\n*\n*  LTRANR  (input) LOGICAL\n*          On entry, LTRANR specifies the op(TR):\n*            = .FALSE., op(TR) = TR,\n*            = .TRUE., op(TR) = TR'.\n*\n*  ISGN    (input) INTEGER\n*          On entry, ISGN specifies the sign of the equation\n*          as described before. ISGN may only be 1 or -1.\n*\n*  N1      (input) INTEGER\n*          On entry, N1 specifies the order of matrix TL.\n*          N1 may only be 0, 1 or 2.\n*\n*  N2      (input) INTEGER\n*          On entry, N2 specifies the order of matrix TR.\n*          N2 may only be 0, 1 or 2.\n*\n*  TL      (input) DOUBLE PRECISION array, dimension (LDTL,2)\n*          On entry, TL contains an N1 by N1 matrix.\n*\n*  LDTL    (input) INTEGER\n*          The leading dimension of the matrix TL. LDTL >= max(1,N1).\n*\n*  TR      (input) DOUBLE PRECISION array, dimension (LDTR,2)\n*          On entry, TR contains an N2 by N2 matrix.\n*\n*  LDTR    (input) INTEGER\n*          The leading dimension of the matrix TR. LDTR >= max(1,N2).\n*\n*  B       (input) DOUBLE PRECISION array, dimension (LDB,2)\n*          On entry, the N1 by N2 matrix B contains the right-hand\n*          side of the equation.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the matrix B. LDB >= max(1,N1).\n*\n*  SCALE   (output) DOUBLE PRECISION\n*          On exit, SCALE contains the scale factor. SCALE is chosen\n*          less than or equal to 1 to prevent the solution overflowing.\n*\n*  X       (output) DOUBLE PRECISION array, dimension (LDX,2)\n*          On exit, X contains the N1 by N2 solution.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the matrix X. LDX >= max(1,N1).\n*\n*  XNORM   (output) DOUBLE PRECISION\n*          On exit, XNORM is the infinity-norm of the solution.\n*\n*  INFO    (output) INTEGER\n*          On exit, INFO is set to\n*             0: successful exit.\n*             1: TL and TR have too close eigenvalues, so TL or\n*                TR is perturbed to get a nonsingular equation.\n*          NOTE: In the interests of speed, this routine does not\n*                check the inputs for errors.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, x, xnorm, info = NumRu::Lapack.dlasy2( ltranl, ltranr, isgn, n1, n2, tl, tr, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_ltranl = argv[0];
  rblapack_ltranr = argv[1];
  rblapack_isgn = argv[2];
  rblapack_n1 = argv[3];
  rblapack_n2 = argv[4];
  rblapack_tl = argv[5];
  rblapack_tr = argv[6];
  rblapack_b = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  ltranl = (rblapack_ltranl == Qtrue);
  isgn = NUM2INT(rblapack_isgn);
  n2 = NUM2INT(rblapack_n2);
  if (!NA_IsNArray(rblapack_tr))
    rb_raise(rb_eArgError, "tr (7th argument) must be NArray");
  if (NA_RANK(rblapack_tr) != 2)
    rb_raise(rb_eArgError, "rank of tr (7th argument) must be %d", 2);
  ldtr = NA_SHAPE0(rblapack_tr);
  if (NA_SHAPE1(rblapack_tr) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of tr must be %d", 2);
  if (NA_TYPE(rblapack_tr) != NA_DFLOAT)
    rblapack_tr = na_change_type(rblapack_tr, NA_DFLOAT);
  tr = NA_PTR_TYPE(rblapack_tr, doublereal*);
  ltranr = (rblapack_ltranr == Qtrue);
  if (!NA_IsNArray(rblapack_tl))
    rb_raise(rb_eArgError, "tl (6th argument) must be NArray");
  if (NA_RANK(rblapack_tl) != 2)
    rb_raise(rb_eArgError, "rank of tl (6th argument) must be %d", 2);
  ldtl = NA_SHAPE0(rblapack_tl);
  if (NA_SHAPE1(rblapack_tl) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of tl must be %d", 2);
  if (NA_TYPE(rblapack_tl) != NA_DFLOAT)
    rblapack_tl = na_change_type(rblapack_tl, NA_DFLOAT);
  tl = NA_PTR_TYPE(rblapack_tl, doublereal*);
  n1 = NUM2INT(rblapack_n1);
  ldx = MAX(1,n1);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of b must be %d", 2);
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = 2;
    rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublereal*);

  dlasy2_(<ranl, <ranr, &isgn, &n1, &n2, tl, &ldtl, tr, &ldtr, b, &ldb, &scale, x, &ldx, &xnorm, &info);

  rblapack_scale = rb_float_new((double)scale);
  rblapack_xnorm = rb_float_new((double)xnorm);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_scale, rblapack_x, rblapack_xnorm, rblapack_info);
}

void
init_lapack_dlasy2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlasy2", rblapack_dlasy2, -1);
}
ruby-lapack-1.7.2/ext/dlaed2.c0000644000175000017500000002605212502221021015656 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaed2_(integer* k, integer* n, integer* n1, doublereal* d, doublereal* q, integer* ldq, integer* indxq, doublereal* rho, doublereal* z, doublereal* dlamda, doublereal* w, doublereal* q2, integer* indx, integer* indxc, integer* indxp, integer* coltyp, integer* info);


static VALUE
rblapack_dlaed2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n1;
  integer n1; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_q;
  doublereal *q; 
  VALUE rblapack_indxq;
  integer *indxq; 
  VALUE rblapack_rho;
  doublereal rho; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_dlamda;
  doublereal *dlamda; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_q2;
  doublereal *q2; 
  VALUE rblapack_indxc;
  integer *indxc; 
  VALUE rblapack_coltyp;
  integer *coltyp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_q_out__;
  doublereal *q_out__;
  VALUE rblapack_indxq_out__;
  integer *indxq_out__;
  integer *indx;
  integer *indxp;

  integer n;
  integer ldq;

  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  k, dlamda, w, q2, indxc, coltyp, info, d, q, indxq, rho = NumRu::Lapack.dlaed2( n1, d, q, indxq, rho, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, Q2, INDX, INDXC, INDXP, COLTYP, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLAED2 merges the two sets of eigenvalues together into a single\n*  sorted set.  Then it tries to deflate the size of the problem.\n*  There are two ways in which deflation can occur:  when two or more\n*  eigenvalues are close together or if there is a tiny entry in the\n*  Z vector.  For each such occurrence the order of the related secular\n*  equation problem is reduced by one.\n*\n\n*  Arguments\n*  =========\n*\n*  K      (output) INTEGER\n*         The number of non-deflated eigenvalues, and the order of the\n*         related secular equation. 0 <= K <=N.\n*\n*  N      (input) INTEGER\n*         The dimension of the symmetric tridiagonal matrix.  N >= 0.\n*\n*  N1     (input) INTEGER\n*         The location of the last eigenvalue in the leading sub-matrix.\n*         min(1,N) <= N1 <= N/2.\n*\n*  D      (input/output) DOUBLE PRECISION array, dimension (N)\n*         On entry, D contains the eigenvalues of the two submatrices to\n*         be combined.\n*         On exit, D contains the trailing (N-K) updated eigenvalues\n*         (those which were deflated) sorted into increasing order.\n*\n*  Q      (input/output) DOUBLE PRECISION array, dimension (LDQ, N)\n*         On entry, Q contains the eigenvectors of two submatrices in\n*         the two square blocks with corners at (1,1), (N1,N1)\n*         and (N1+1, N1+1), (N,N).\n*         On exit, Q contains the trailing (N-K) updated eigenvectors\n*         (those which were deflated) in its last N-K columns.\n*\n*  LDQ    (input) INTEGER\n*         The leading dimension of the array Q.  LDQ >= max(1,N).\n*\n*  INDXQ  (input/output) INTEGER array, dimension (N)\n*         The permutation which separately sorts the two sub-problems\n*         in D into ascending order.  Note that elements in the second\n*         half of this permutation must first have N1 added to their\n*         values. Destroyed on exit.\n*\n*  RHO    (input/output) DOUBLE PRECISION\n*         On entry, the off-diagonal element associated with the rank-1\n*         cut which originally split the two submatrices which are now\n*         being recombined.\n*         On exit, RHO has been modified to the value required by\n*         DLAED3.\n*\n*  Z      (input) DOUBLE PRECISION array, dimension (N)\n*         On entry, Z contains the updating vector (the last\n*         row of the first sub-eigenvector matrix and the first row of\n*         the second sub-eigenvector matrix).\n*         On exit, the contents of Z have been destroyed by the updating\n*         process.\n*\n*  DLAMDA (output) DOUBLE PRECISION array, dimension (N)\n*         A copy of the first K eigenvalues which will be used by\n*         DLAED3 to form the secular equation.\n*\n*  W      (output) DOUBLE PRECISION array, dimension (N)\n*         The first k values of the final deflation-altered z-vector\n*         which will be passed to DLAED3.\n*\n*  Q2     (output) DOUBLE PRECISION array, dimension (N1**2+(N-N1)**2)\n*         A copy of the first K eigenvectors which will be used by\n*         DLAED3 in a matrix multiply (DGEMM) to solve for the new\n*         eigenvectors.\n*\n*  INDX   (workspace) INTEGER array, dimension (N)\n*         The permutation used to sort the contents of DLAMDA into\n*         ascending order.\n*\n*  INDXC  (output) INTEGER array, dimension (N)\n*         The permutation used to arrange the columns of the deflated\n*         Q matrix into three groups:  the first group contains non-zero\n*         elements only at and above N1, the second contains\n*         non-zero elements only below N1, and the third is dense.\n*\n*  INDXP  (workspace) INTEGER array, dimension (N)\n*         The permutation used to place deflated values of D at the end\n*         of the array.  INDXP(1:K) points to the nondeflated D-values\n*         and INDXP(K+1:N) points to the deflated eigenvalues.\n*\n*  COLTYP (workspace/output) INTEGER array, dimension (N)\n*         During execution, a label which will indicate which of the\n*         following types a column in the Q2 matrix is:\n*         1 : non-zero in the upper half only;\n*         2 : dense;\n*         3 : non-zero in the lower half only;\n*         4 : deflated.\n*         On exit, COLTYP(i) is the number of columns of type i,\n*         for i=1 to 4 only.\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*  Based on contributions by\n*     Jeff Rutter, Computer Science Division, University of California\n*     at Berkeley, USA\n*  Modified by Francoise Tisseur, University of Tennessee.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  k, dlamda, w, q2, indxc, coltyp, info, d, q, indxq, rho = NumRu::Lapack.dlaed2( n1, d, q, indxq, rho, z, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_n1 = argv[0];
  rblapack_d = argv[1];
  rblapack_q = argv[2];
  rblapack_indxq = argv[3];
  rblapack_rho = argv[4];
  rblapack_z = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n1 = NUM2INT(rblapack_n1);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (3th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (3th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  n = NA_SHAPE1(rblapack_q);
  if (NA_TYPE(rblapack_q) != NA_DFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
  q = NA_PTR_TYPE(rblapack_q, doublereal*);
  rho = NUM2DBL(rblapack_rho);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of q");
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (6th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 1 of q");
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  if (!NA_IsNArray(rblapack_indxq))
    rb_raise(rb_eArgError, "indxq (4th argument) must be NArray");
  if (NA_RANK(rblapack_indxq) != 1)
    rb_raise(rb_eArgError, "rank of indxq (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_indxq) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of indxq must be the same as shape 1 of q");
  if (NA_TYPE(rblapack_indxq) != NA_LINT)
    rblapack_indxq = na_change_type(rblapack_indxq, NA_LINT);
  indxq = NA_PTR_TYPE(rblapack_indxq, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_dlamda = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  dlamda = NA_PTR_TYPE(rblapack_dlamda, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = pow(n1,2)+pow(n-n1,2);
    rblapack_q2 = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  q2 = NA_PTR_TYPE(rblapack_q2, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_indxc = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  indxc = NA_PTR_TYPE(rblapack_indxc, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_coltyp = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  coltyp = NA_PTR_TYPE(rblapack_coltyp, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
  MEMCPY(q_out__, q, doublereal, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_indxq_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  indxq_out__ = NA_PTR_TYPE(rblapack_indxq_out__, integer*);
  MEMCPY(indxq_out__, indxq, integer, NA_TOTAL(rblapack_indxq));
  rblapack_indxq = rblapack_indxq_out__;
  indxq = indxq_out__;
  indx = ALLOC_N(integer, (n));
  indxp = ALLOC_N(integer, (n));

  dlaed2_(&k, &n, &n1, d, q, &ldq, indxq, &rho, z, dlamda, w, q2, indx, indxc, indxp, coltyp, &info);

  free(indx);
  free(indxp);
  rblapack_k = INT2NUM(k);
  rblapack_info = INT2NUM(info);
  rblapack_rho = rb_float_new((double)rho);
  return rb_ary_new3(11, rblapack_k, rblapack_dlamda, rblapack_w, rblapack_q2, rblapack_indxc, rblapack_coltyp, rblapack_info, rblapack_d, rblapack_q, rblapack_indxq, rblapack_rho);
}

void
init_lapack_dlaed2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaed2", rblapack_dlaed2, -1);
}
ruby-lapack-1.7.2/ext/dlanst.c0000644000175000017500000000745212502221021016013 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal dlanst_(char* norm, integer* n, doublereal* d, doublereal* e);


static VALUE
rblapack_dlanst(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack___out__;
  doublereal __out__; 

  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  __out__ = NumRu::Lapack.dlanst( norm, d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E )\n\n*  Purpose\n*  =======\n*\n*  DLANST  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  real symmetric tridiagonal matrix A.\n*\n*  Description\n*  ===========\n*\n*  DLANST returns the value\n*\n*     DLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in DLANST as described\n*          above.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, DLANST is\n*          set to zero.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          The diagonal elements of A.\n*\n*  E       (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (n-1) sub-diagonal or super-diagonal elements of A.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.dlanst( norm, d, e, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_norm = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);

  __out__ = dlanst_(&norm, &n, d, e);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_dlanst(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlanst", rblapack_dlanst, -1);
}
ruby-lapack-1.7.2/ext/chprfs.c0000644000175000017500000002061212502221017016011 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chprfs_(char* uplo, integer* n, integer* nrhs, complex* ap, complex* afp, integer* ipiv, complex* b, integer* ldb, complex* x, integer* ldx, real* ferr, real* berr, complex* work, real* rwork, integer* info);


static VALUE
rblapack_chprfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_afp;
  complex *afp; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  complex *x_out__;
  complex *work;
  real *rwork;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.chprfs( uplo, ap, afp, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHPRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is Hermitian indefinite\n*  and packed, and provides error bounds and backward error estimates\n*  for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)\n*          The upper or lower triangle of the Hermitian matrix A, packed\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  AFP     (input) COMPLEX array, dimension (N*(N+1)/2)\n*          The factored form of the matrix A.  AFP contains the block\n*          diagonal matrix D and the multipliers used to obtain the\n*          factor U or L from the factorization A = U*D*U**H or\n*          A = L*D*L**H as computed by CHPTRF, stored as a packed\n*          triangular matrix.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by CHPTRF.\n*\n*  B       (input) COMPLEX array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) COMPLEX array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by CHPTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.chprfs( uplo, ap, afp, ipiv, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_afp = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_b = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (!NA_IsNArray(rblapack_afp))
    rb_raise(rb_eArgError, "afp (3th argument) must be NArray");
  if (NA_RANK(rblapack_afp) != 1)
    rb_raise(rb_eArgError, "rank of afp (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_afp) != NA_SCOMPLEX)
    rblapack_afp = na_change_type(rblapack_afp, NA_SCOMPLEX);
  afp = NA_PTR_TYPE(rblapack_afp, complex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (n));

  chprfs_(&uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_chprfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chprfs", rblapack_chprfs, -1);
}
ruby-lapack-1.7.2/ext/csymv.c0000644000175000017500000001570412502221017015673 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID csymv_(char* uplo, integer* n, complex* alpha, complex* a, integer* lda, complex* x, integer* incx, complex* beta, complex* y, integer* incy);


static VALUE
rblapack_csymv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_alpha;
  complex alpha; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_beta;
  complex beta; 
  VALUE rblapack_y;
  complex *y; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_y_out__;
  complex *y_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  y = NumRu::Lapack.csymv( uplo, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSYMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n*  Purpose\n*  =======\n*\n*  CSYMV  performs the matrix-vector  operation\n*\n*     y := alpha*A*x + beta*y,\n*\n*  where alpha and beta are scalars, x and y are n element vectors and\n*  A is an n by n symmetric matrix.\n*\n\n*  Arguments\n*  ==========\n*\n*  UPLO     (input) CHARACTER*1\n*           On entry, UPLO specifies whether the upper or lower\n*           triangular part of the array A is to be referenced as\n*           follows:\n*\n*              UPLO = 'U' or 'u'   Only the upper triangular part of A\n*                                  is to be referenced.\n*\n*              UPLO = 'L' or 'l'   Only the lower triangular part of A\n*                                  is to be referenced.\n*\n*           Unchanged on exit.\n*\n*  N        (input) INTEGER\n*           On entry, N specifies the order of the matrix A.\n*           N must be at least zero.\n*           Unchanged on exit.\n*\n*  ALPHA    (input) COMPLEX\n*           On entry, ALPHA specifies the scalar alpha.\n*           Unchanged on exit.\n*\n*  A        (input) COMPLEX array, dimension ( LDA, N )\n*           Before entry, with  UPLO = 'U' or 'u', the leading n by n\n*           upper triangular part of the array A must contain the upper\n*           triangular part of the symmetric matrix and the strictly\n*           lower triangular part of A is not referenced.\n*           Before entry, with UPLO = 'L' or 'l', the leading n by n\n*           lower triangular part of the array A must contain the lower\n*           triangular part of the symmetric matrix and the strictly\n*           upper triangular part of A is not referenced.\n*           Unchanged on exit.\n*\n*  LDA      (input) INTEGER\n*           On entry, LDA specifies the first dimension of A as declared\n*           in the calling (sub) program. LDA must be at least\n*           max( 1, N ).\n*           Unchanged on exit.\n*\n*  X        (input) COMPLEX array, dimension at least\n*           ( 1 + ( N - 1 )*abs( INCX ) ).\n*           Before entry, the incremented array X must contain the N-\n*           element vector x.\n*           Unchanged on exit.\n*\n*  INCX     (input) INTEGER\n*           On entry, INCX specifies the increment for the elements of\n*           X. INCX must not be zero.\n*           Unchanged on exit.\n*\n*  BETA     (input) COMPLEX\n*           On entry, BETA specifies the scalar beta. When BETA is\n*           supplied as zero then Y need not be set on input.\n*           Unchanged on exit.\n*\n*  Y        (input/output) COMPLEX array, dimension at least\n*           ( 1 + ( N - 1 )*abs( INCY ) ).\n*           Before entry, the incremented array Y must contain the n\n*           element vector y. On exit, Y is overwritten by the updated\n*           vector y.\n*\n*  INCY     (input) INTEGER\n*           On entry, INCY specifies the increment for the elements of\n*           Y. INCY must not be zero.\n*           Unchanged on exit.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  y = NumRu::Lapack.csymv( uplo, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_uplo = argv[0];
  rblapack_alpha = argv[1];
  rblapack_a = argv[2];
  rblapack_x = argv[3];
  rblapack_incx = argv[4];
  rblapack_beta = argv[5];
  rblapack_y = argv[6];
  rblapack_incy = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  incx = NUM2INT(rblapack_incx);
  incy = NUM2INT(rblapack_incy);
  alpha.r = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
  alpha.i = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
  beta.r = (real)NUM2DBL(rb_funcall(rblapack_beta, rb_intern("real"), 0));
  beta.i = (real)NUM2DBL(rb_funcall(rblapack_beta, rb_intern("imag"), 0));
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (4th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1 + ( n - 1 )*abs( incx )))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (7th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (1 + ( n - 1 )*abs( incy )))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1 + ( n - 1 )*abs( incy ));
  if (NA_TYPE(rblapack_y) != NA_SCOMPLEX)
    rblapack_y = na_change_type(rblapack_y, NA_SCOMPLEX);
  y = NA_PTR_TYPE(rblapack_y, complex*);
  {
    na_shape_t shape[1];
    shape[0] = 1 + ( n - 1 )*abs( incy );
    rblapack_y_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, complex*);
  MEMCPY(y_out__, y, complex, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  csymv_(&uplo, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);

  return rblapack_y;
}

void
init_lapack_csymv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "csymv", rblapack_csymv, -1);
}
ruby-lapack-1.7.2/ext/zsyr.c0000644000175000017500000001325712502221020015534 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zsyr_(char* uplo, integer* n, doublecomplex* alpha, doublecomplex* x, integer* incx, doublecomplex* a, integer* lda);


static VALUE
rblapack_zsyr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_alpha;
  doublecomplex alpha; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_a_out__;
  doublecomplex *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  a = NumRu::Lapack.zsyr( uplo, alpha, x, incx, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSYR( UPLO, N, ALPHA, X, INCX, A, LDA )\n\n*  Purpose\n*  =======\n*\n*  ZSYR   performs the symmetric rank 1 operation\n*\n*     A := alpha*x*( x' ) + A,\n*\n*  where alpha is a complex scalar, x is an n element vector and A is an\n*  n by n symmetric matrix.\n*\n\n*  Arguments\n*  ==========\n*\n*  UPLO     (input) CHARACTER*1\n*           On entry, UPLO specifies whether the upper or lower\n*           triangular part of the array A is to be referenced as\n*           follows:\n*\n*              UPLO = 'U' or 'u'   Only the upper triangular part of A\n*                                  is to be referenced.\n*\n*              UPLO = 'L' or 'l'   Only the lower triangular part of A\n*                                  is to be referenced.\n*\n*           Unchanged on exit.\n*\n*  N        (input) INTEGER\n*           On entry, N specifies the order of the matrix A.\n*           N must be at least zero.\n*           Unchanged on exit.\n*\n*  ALPHA    (input) COMPLEX*16\n*           On entry, ALPHA specifies the scalar alpha.\n*           Unchanged on exit.\n*\n*  X        (input) COMPLEX*16 array, dimension at least\n*           ( 1 + ( N - 1 )*abs( INCX ) ).\n*           Before entry, the incremented array X must contain the N-\n*           element vector x.\n*           Unchanged on exit.\n*\n*  INCX     (input) INTEGER\n*           On entry, INCX specifies the increment for the elements of\n*           X. INCX must not be zero.\n*           Unchanged on exit.\n*\n*  A        (input/output) COMPLEX*16 array, dimension ( LDA, N )\n*           Before entry, with  UPLO = 'U' or 'u', the leading n by n\n*           upper triangular part of the array A must contain the upper\n*           triangular part of the symmetric matrix and the strictly\n*           lower triangular part of A is not referenced. On exit, the\n*           upper triangular part of the array A is overwritten by the\n*           upper triangular part of the updated matrix.\n*           Before entry, with UPLO = 'L' or 'l', the leading n by n\n*           lower triangular part of the array A must contain the lower\n*           triangular part of the symmetric matrix and the strictly\n*           upper triangular part of A is not referenced. On exit, the\n*           lower triangular part of the array A is overwritten by the\n*           lower triangular part of the updated matrix.\n*\n*  LDA      (input) INTEGER\n*           On entry, LDA specifies the first dimension of A as declared\n*           in the calling (sub) program. LDA must be at least\n*           max( 1, N ).\n*           Unchanged on exit.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  a = NumRu::Lapack.zsyr( uplo, alpha, x, incx, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_alpha = argv[1];
  rblapack_x = argv[2];
  rblapack_incx = argv[3];
  rblapack_a = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  incx = NUM2INT(rblapack_incx);
  alpha.r = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
  alpha.i = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (3th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1 + ( n - 1 )*abs( incx )))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zsyr_(&uplo, &n, &alpha, x, &incx, a, &lda);

  return rblapack_a;
}

void
init_lapack_zsyr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zsyr", rblapack_zsyr, -1);
}
ruby-lapack-1.7.2/ext/f2c_minimal.h0000644000175000017500000000133012655766751016741 0ustar  uwabamiuwabami/* f2c.h  --  Standard Fortran to C header file */

/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."

	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */

#ifndef F2C_INCLUDE
#define F2C_INCLUDE

#include 

#if UINTPTR_MAX == UINT64_MAX
typedef int integer;
typedef int logical;
#else
typedef long int integer;
typedef long int logical;
#endif
typedef float real;
typedef double doublereal;
typedef struct { real r, i; } complex;
typedef struct { doublereal r, i; } doublecomplex;

#ifdef f2c_i2
typedef short ftnlen;
#else
#if UINTPTR_MAX == UINT64_MAX
typedef int ftnlen;
#else
typedef long int ftnlen;
#endif
#endif

typedef logical (*L_fp)();

#define VOID void

#endif
ruby-lapack-1.7.2/ext/sormqr.c0000644000175000017500000001621212502221026016050 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sormqr_(char* side, char* trans, integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* c, integer* ldc, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sormqr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  real *c_out__;

  integer lda;
  integer k;
  integer ldc;
  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  work, info, c = NumRu::Lapack.sormqr( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SORMQR overwrites the general real M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'T':      Q**T * C       C * Q**T\n*\n*  where Q is a real orthogonal matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(1) H(2) . . . H(k)\n*\n*  as returned by SGEQRF. Q is of order M if SIDE = 'L' and of order N\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**T from the Left;\n*          = 'R': apply Q or Q**T from the Right.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'T':  Transpose, apply Q**T.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) REAL array, dimension (LDA,K)\n*          The i-th column must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          SGEQRF in the first k columns of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*          If SIDE = 'L', LDA >= max(1,M);\n*          if SIDE = 'R', LDA >= max(1,N).\n*\n*  TAU     (input) REAL array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by SGEQRF.\n*\n*  C       (input/output) REAL array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace/output) REAL 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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M).\n*          For optimum performance LWORK >= N*NB if SIDE = 'L', and\n*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n*          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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.sormqr( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_m = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 7) {
    rblapack_lwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  side = StringValueCStr(rblapack_side)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != k)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  sormqr_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_sormqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sormqr", rblapack_sormqr, -1);
}
ruby-lapack-1.7.2/ext/dlagts.c0000644000175000017500000002117412502221020016000 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlagts_(integer* job, integer* n, doublereal* a, doublereal* b, doublereal* c, doublereal* d, integer* in, doublereal* y, doublereal* tol, integer* info);


static VALUE
rblapack_dlagts(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  integer job; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_in;
  integer *in; 
  VALUE rblapack_y;
  doublereal *y; 
  VALUE rblapack_tol;
  doublereal tol; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_y_out__;
  doublereal *y_out__;

  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  info, y, tol = NumRu::Lapack.dlagts( job, a, b, c, d, in, y, tol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLAGTS may be used to solve one of the systems of equations\n*\n*     (T - lambda*I)*x = y   or   (T - lambda*I)'*x = y,\n*\n*  where T is an n by n tridiagonal matrix, for x, following the\n*  factorization of (T - lambda*I) as\n*\n*     (T - lambda*I) = P*L*U ,\n*\n*  by routine DLAGTF. The choice of equation to be solved is\n*  controlled by the argument JOB, and in each case there is an option\n*  to perturb zero or very small diagonal elements of U, this option\n*  being intended for use in applications such as inverse iteration.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) INTEGER\n*          Specifies the job to be performed by DLAGTS as follows:\n*          =  1: The equations  (T - lambda*I)x = y  are to be solved,\n*                but diagonal elements of U are not to be perturbed.\n*          = -1: The equations  (T - lambda*I)x = y  are to be solved\n*                and, if overflow would otherwise occur, the diagonal\n*                elements of U are to be perturbed. See argument TOL\n*                below.\n*          =  2: The equations  (T - lambda*I)'x = y  are to be solved,\n*                but diagonal elements of U are not to be perturbed.\n*          = -2: The equations  (T - lambda*I)'x = y  are to be solved\n*                and, if overflow would otherwise occur, the diagonal\n*                elements of U are to be perturbed. See argument TOL\n*                below.\n*\n*  N       (input) INTEGER\n*          The order of the matrix T.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (N)\n*          On entry, A must contain the diagonal elements of U as\n*          returned from DLAGTF.\n*\n*  B       (input) DOUBLE PRECISION array, dimension (N-1)\n*          On entry, B must contain the first super-diagonal elements of\n*          U as returned from DLAGTF.\n*\n*  C       (input) DOUBLE PRECISION array, dimension (N-1)\n*          On entry, C must contain the sub-diagonal elements of L as\n*          returned from DLAGTF.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N-2)\n*          On entry, D must contain the second super-diagonal elements\n*          of U as returned from DLAGTF.\n*\n*  IN      (input) INTEGER array, dimension (N)\n*          On entry, IN must contain details of the matrix P as returned\n*          from DLAGTF.\n*\n*  Y       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the right hand side vector y.\n*          On exit, Y is overwritten by the solution vector x.\n*\n*  TOL     (input/output) DOUBLE PRECISION\n*          On entry, with  JOB .lt. 0, TOL should be the minimum\n*          perturbation to be made to very small diagonal elements of U.\n*          TOL should normally be chosen as about eps*norm(U), where eps\n*          is the relative machine precision, but if TOL is supplied as\n*          non-positive, then it is reset to eps*max( abs( u(i,j) ) ).\n*          If  JOB .gt. 0  then TOL is not referenced.\n*\n*          On exit, TOL is changed as described above, only if TOL is\n*          non-positive on entry. Otherwise TOL is unchanged.\n*\n*  INFO    (output) INTEGER\n*          = 0   : successful exit\n*          .lt. 0: if INFO = -i, the i-th argument had an illegal value\n*          .gt. 0: overflow would occur when computing the INFO(th)\n*                  element of the solution vector x. This can only occur\n*                  when JOB is supplied as positive and either means\n*                  that a diagonal element of U is very small, or that\n*                  the elements of the right-hand side vector y are very\n*                  large.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, y, tol = NumRu::Lapack.dlagts( job, a, b, c, d, in, y, tol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_job = argv[0];
  rblapack_a = argv[1];
  rblapack_b = argv[2];
  rblapack_c = argv[3];
  rblapack_d = argv[4];
  rblapack_in = argv[5];
  rblapack_y = argv[6];
  rblapack_tol = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  job = NUM2INT(rblapack_job);
  if (!NA_IsNArray(rblapack_in))
    rb_raise(rb_eArgError, "in (6th argument) must be NArray");
  if (NA_RANK(rblapack_in) != 1)
    rb_raise(rb_eArgError, "rank of in (6th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_in);
  if (NA_TYPE(rblapack_in) != NA_LINT)
    rblapack_in = na_change_type(rblapack_in, NA_LINT);
  in = NA_PTR_TYPE(rblapack_in, integer*);
  tol = NUM2DBL(rblapack_tol);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (2th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 1)
    rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of a must be the same as shape 0 of in");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (7th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of y must be the same as shape 0 of in");
  if (NA_TYPE(rblapack_y) != NA_DFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
  y = NA_PTR_TYPE(rblapack_y, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (3th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 1)
    rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_b) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of b must be %d", n-1);
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (5th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != (n-2))
    rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", n-2);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (4th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", n-1);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
  MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  dlagts_(&job, &n, a, b, c, d, in, y, &tol, &info);

  rblapack_info = INT2NUM(info);
  rblapack_tol = rb_float_new((double)tol);
  return rb_ary_new3(3, rblapack_info, rblapack_y, rblapack_tol);
}

void
init_lapack_dlagts(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlagts", rblapack_dlagts, -1);
}
ruby-lapack-1.7.2/ext/slacn2.c0000644000175000017500000001263712502221014015713 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slacn2_(integer* n, real* v, real* x, integer* isgn, real* est, integer* kase, integer* isave);


static VALUE
rblapack_slacn2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_est;
  real est; 
  VALUE rblapack_kase;
  integer kase; 
  VALUE rblapack_isave;
  integer *isave; 
  VALUE rblapack_x_out__;
  real *x_out__;
  VALUE rblapack_isave_out__;
  integer *isave_out__;
  real *v;
  integer *isgn;

  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  x, est, kase, isave = NumRu::Lapack.slacn2( x, est, kase, isave, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLACN2( N, V, X, ISGN, EST, KASE, ISAVE )\n\n*  Purpose\n*  =======\n*\n*  SLACN2 estimates the 1-norm of a square, real matrix A.\n*  Reverse communication is used for evaluating matrix-vector products.\n*\n\n*  Arguments\n*  =========\n*\n*  N      (input) INTEGER\n*         The order of the matrix.  N >= 1.\n*\n*  V      (workspace) REAL array, dimension (N)\n*         On the final return, V = A*W,  where  EST = norm(V)/norm(W)\n*         (W is not returned).\n*\n*  X      (input/output) REAL array, dimension (N)\n*         On an intermediate return, X should be overwritten by\n*               A * X,   if KASE=1,\n*               A' * X,  if KASE=2,\n*         and SLACN2 must be re-called with all the other parameters\n*         unchanged.\n*\n*  ISGN   (workspace) INTEGER array, dimension (N)\n*\n*  EST    (input/output) REAL\n*         On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be\n*         unchanged from the previous call to SLACN2.\n*         On exit, EST is an estimate (a lower bound) for norm(A). \n*\n*  KASE   (input/output) INTEGER\n*         On the initial call to SLACN2, KASE should be 0.\n*         On an intermediate return, KASE will be 1 or 2, indicating\n*         whether X should be overwritten by A * X  or A' * X.\n*         On the final return from SLACN2, KASE will again be 0.\n*\n*  ISAVE  (input/output) INTEGER array, dimension (3)\n*         ISAVE is used to save variables between calls to SLACN2\n*\n\n*  Further Details\n*  ======= =======\n*\n*  Contributed by Nick Higham, University of Manchester.\n*  Originally named SONEST, dated March 16, 1988.\n*\n*  Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n*  a real or complex matrix, with applications to condition estimation\",\n*  ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n*\n*  This is a thread safe version of SLACON, which uses the array ISAVE\n*  in place of a SAVE statement, as follows:\n*\n*     SLACON     SLACN2\n*      JUMP     ISAVE(1)\n*      J        ISAVE(2)\n*      ITER     ISAVE(3)\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, est, kase, isave = NumRu::Lapack.slacn2( x, est, kase, isave, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_x = argv[0];
  rblapack_est = argv[1];
  rblapack_kase = argv[2];
  rblapack_isave = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (1th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  kase = NUM2INT(rblapack_kase);
  est = (real)NUM2DBL(rblapack_est);
  if (!NA_IsNArray(rblapack_isave))
    rb_raise(rb_eArgError, "isave (4th argument) must be NArray");
  if (NA_RANK(rblapack_isave) != 1)
    rb_raise(rb_eArgError, "rank of isave (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_isave) != (3))
    rb_raise(rb_eRuntimeError, "shape 0 of isave must be %d", 3);
  if (NA_TYPE(rblapack_isave) != NA_LINT)
    rblapack_isave = na_change_type(rblapack_isave, NA_LINT);
  isave = NA_PTR_TYPE(rblapack_isave, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = 3;
    rblapack_isave_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isave_out__ = NA_PTR_TYPE(rblapack_isave_out__, integer*);
  MEMCPY(isave_out__, isave, integer, NA_TOTAL(rblapack_isave));
  rblapack_isave = rblapack_isave_out__;
  isave = isave_out__;
  v = ALLOC_N(real, (n));
  isgn = ALLOC_N(integer, (n));

  slacn2_(&n, v, x, isgn, &est, &kase, isave);

  free(v);
  free(isgn);
  rblapack_est = rb_float_new((double)est);
  rblapack_kase = INT2NUM(kase);
  return rb_ary_new3(4, rblapack_x, rblapack_est, rblapack_kase, rblapack_isave);
}

void
init_lapack_slacn2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slacn2", rblapack_slacn2, -1);
}
ruby-lapack-1.7.2/ext/ztrcon.c0000644000175000017500000001125212502221013016037 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztrcon_(char* norm, char* uplo, char* diag, integer* n, doublecomplex* a, integer* lda, doublereal* rcond, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_ztrcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_info;
  integer info; 
  doublecomplex *work;
  doublereal *rwork;

  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  rcond, info = NumRu::Lapack.ztrcon( norm, uplo, diag, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTRCON estimates the reciprocal of the condition number of a\n*  triangular matrix A, in either the 1-norm or the infinity-norm.\n*\n*  The norm of A is computed and an estimate is obtained for\n*  norm(inv(A)), then the reciprocal of the condition number is\n*  computed as\n*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies whether the 1-norm condition number or the\n*          infinity-norm condition number is required:\n*          = '1' or 'O':  1-norm;\n*          = 'I':         Infinity-norm.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          The triangular matrix A.  If UPLO = 'U', the leading N-by-N\n*          upper triangular part of the array A contains the upper\n*          triangular matrix, and the strictly lower triangular part of\n*          A is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*          triangular part of the array A contains the lower triangular\n*          matrix, and the strictly upper triangular part of A is not\n*          referenced.  If DIAG = 'U', the diagonal elements of A are\n*          also not referenced and are assumed to be 1.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(norm(A) * norm(inv(A))).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.ztrcon( norm, uplo, diag, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_diag = argv[2];
  rblapack_a = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (n));

  ztrcon_(&norm, &uplo, &diag, &n, a, &lda, &rcond, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_ztrcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztrcon", rblapack_ztrcon, -1);
}
ruby-lapack-1.7.2/ext/zgeqlf.c0000644000175000017500000001367612502221024016026 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgeqlf_(integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zgeqlf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *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.zgeqlf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGEQLF computes a QL factorization of a complex M-by-N matrix A:\n*  A = Q * L.\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) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit,\n*          if m >= n, the lower triangle of the subarray\n*          A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L;\n*          if m <= n, the elements on and below the (n-m)-th\n*          superdiagonal contain the M-by-N lower trapezoidal matrix L;\n*          the remaining elements, with the array TAU, represent the\n*          unitary matrix Q as a product of elementary reflectors\n*          (see Further Details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  TAU     (output) COMPLEX*16 array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace/output) COMPLEX*16 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,N).\n*          For optimum performance LWORK >= N*NB, where NB is\n*          the 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 complex scalar, and v is a complex vector with\n*  v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n*  A(1:m-k+i-1,n-k+i), and tau in TAU(i).\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY\n      INTEGER            I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n     $                   MU, NB, NBMIN, NU, NX\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZGEQL2, ZLARFB, ZLARFT\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.zgeqlf( 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;
  }

  m = NUM2INT(rblapack_m);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zgeqlf_(&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_zgeqlf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgeqlf", rblapack_zgeqlf, -1);
}
ruby-lapack-1.7.2/ext/cgeqpf.c0000644000175000017500000001370412502221015015773 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgeqpf_(integer* m, integer* n, complex* a, integer* lda, integer* jpvt, complex* tau, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cgeqpf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_jpvt;
  integer *jpvt; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_jpvt_out__;
  integer *jpvt_out__;
  complex *work;
  real *rwork;

  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, info, a, jpvt = NumRu::Lapack.cgeqpf( m, a, jpvt, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  This routine is deprecated and has been replaced by routine CGEQP3.\n*\n*  CGEQPF computes a QR factorization with column pivoting of a\n*  complex M-by-N matrix A: A*P = Q*R.\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) COMPLEX array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, the upper triangle of the array contains the\n*          min(M,N)-by-N upper triangular matrix R; the elements\n*          below the diagonal, together with the array TAU,\n*          represent the unitary matrix Q as a product of\n*          min(m,n) elementary reflectors.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  JPVT    (input/output) INTEGER array, dimension (N)\n*          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n*          to the front of A*P (a leading column); if JPVT(i) = 0,\n*          the i-th column of A is a free column.\n*          On exit, if JPVT(i) = k, then the i-th column of A*P\n*          was the k-th column of A.\n*\n*  TAU     (output) COMPLEX array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors.\n*\n*  WORK    (workspace) COMPLEX array, dimension (N)\n*\n*  RWORK   (workspace) REAL array, dimension (2*N)\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(1) H(2) . . . H(n)\n*\n*  Each H(i) has the form\n*\n*     H = I - tau * v * v'\n*\n*  where tau is a complex scalar, and v is a complex vector with\n*  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).\n*\n*  The matrix P is represented in jpvt as follows: If\n*     jpvt(j) = i\n*  then the jth column of P is the ith canonical unit vector.\n*\n*  Partial column norm updating strategy modified by\n*    Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n*    University of Zagreb, Croatia.\n*     June 2010\n*  For more details see LAPACK Working Note 176.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, info, a, jpvt = NumRu::Lapack.cgeqpf( m, a, jpvt, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  rblapack_jpvt = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_jpvt))
    rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
  if (NA_RANK(rblapack_jpvt) != 1)
    rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_jpvt);
  if (NA_TYPE(rblapack_jpvt) != NA_LINT)
    rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
  jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of jpvt");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
  MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
  rblapack_jpvt = rblapack_jpvt_out__;
  jpvt = jpvt_out__;
  work = ALLOC_N(complex, (n));
  rwork = ALLOC_N(real, (2*n));

  cgeqpf_(&m, &n, a, &lda, jpvt, tau, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_tau, rblapack_info, rblapack_a, rblapack_jpvt);
}

void
init_lapack_cgeqpf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgeqpf", rblapack_cgeqpf, -1);
}
ruby-lapack-1.7.2/ext/zgbcon.c0000644000175000017500000001273712502221022016013 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgbcon_(char* norm, integer* n, integer* kl, integer* ku, doublecomplex* ab, integer* ldab, integer* ipiv, doublereal* anorm, doublereal* rcond, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zgbcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_anorm;
  doublereal anorm; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_info;
  integer info; 
  doublecomplex *work;
  doublereal *rwork;

  integer ldab;
  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  rcond, info = NumRu::Lapack.zgbcon( norm, kl, ku, ab, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGBCON estimates the reciprocal of the condition number of a complex\n*  general band matrix A, in either the 1-norm or the infinity-norm,\n*  using the LU factorization computed by ZGBTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as\n*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies whether the 1-norm condition number or the\n*          infinity-norm condition number is required:\n*          = '1' or 'O':  1-norm;\n*          = 'I':         Infinity-norm.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)\n*          Details of the LU factorization of the band matrix A, as\n*          computed by ZGBTRF.  U is stored as an upper triangular band\n*          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n*          the multipliers used during the factorization are stored in\n*          rows KL+KU+2 to 2*KL+KU+1.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices; for 1 <= i <= N, row i of the matrix was\n*          interchanged with row IPIV(i).\n*\n*  ANORM   (input) DOUBLE PRECISION\n*          If NORM = '1' or 'O', the 1-norm of the original matrix A.\n*          If NORM = 'I', the infinity-norm of the original matrix A.\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(norm(A) * norm(inv(A))).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.zgbcon( norm, kl, ku, ab, ipiv, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_norm = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_anorm = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  kl = NUM2INT(rblapack_kl);
  anorm = NUM2DBL(rblapack_anorm);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (n));

  zgbcon_(&norm, &n, &kl, &ku, ab, &ldab, ipiv, &anorm, &rcond, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_zgbcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgbcon", rblapack_zgbcon, -1);
}
ruby-lapack-1.7.2/ext/checon.c0000644000175000017500000001107712502221024015766 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID checon_(char* uplo, integer* n, complex* a, integer* lda, integer* ipiv, real* anorm, real* rcond, complex* work, integer* info);


static VALUE
rblapack_checon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_anorm;
  real anorm; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_info;
  integer info; 
  complex *work;

  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  rcond, info = NumRu::Lapack.checon( uplo, a, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHECON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHECON estimates the reciprocal of the condition number of a complex\n*  Hermitian matrix A using the factorization A = U*D*U**H or\n*  A = L*D*L**H computed by CHETRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**H;\n*          = 'L':  Lower triangular, form is A = L*D*L**H.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by CHETRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by CHETRF.\n*\n*  ANORM   (input) REAL\n*          The 1-norm of the original matrix A.\n*\n*  RCOND   (output) REAL\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n*          estimate of the 1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.checon( uplo, a, ipiv, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_anorm = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  anorm = (real)NUM2DBL(rblapack_anorm);
  work = ALLOC_N(complex, (2*n));

  checon_(&uplo, &n, a, &lda, ipiv, &anorm, &rcond, work, &info);

  free(work);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_checon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "checon", rblapack_checon, -1);
}
ruby-lapack-1.7.2/ext/slaed0.c0000644000175000017500000001760712502221017015706 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaed0_(integer* icompq, integer* qsiz, integer* n, real* d, real* e, real* q, integer* ldq, real* qstore, integer* ldqs, real* work, integer* iwork, integer* info);


static VALUE
rblapack_slaed0(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_icompq;
  integer icompq; 
  VALUE rblapack_qsiz;
  integer qsiz; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_q;
  real *q; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_q_out__;
  real *q_out__;
  real *qstore;
  real *work;
  integer *iwork;

  integer n;
  integer ldq;
  integer ldqs;

  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  info, d, q = NumRu::Lapack.slaed0( icompq, qsiz, d, e, q, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLAED0 computes all eigenvalues and corresponding eigenvectors of a\n*  symmetric tridiagonal matrix using the divide and conquer method.\n*\n\n*  Arguments\n*  =========\n*\n*  ICOMPQ  (input) INTEGER\n*          = 0:  Compute eigenvalues only.\n*          = 1:  Compute eigenvectors of original dense symmetric matrix\n*                also.  On entry, Q contains the orthogonal matrix used\n*                to reduce the original matrix to tridiagonal form.\n*          = 2:  Compute eigenvalues and eigenvectors of tridiagonal\n*                matrix.\n*\n*  QSIZ   (input) INTEGER\n*         The dimension of the orthogonal matrix used to reduce\n*         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.\n*\n*  N      (input) INTEGER\n*         The dimension of the symmetric tridiagonal matrix.  N >= 0.\n*\n*  D      (input/output) REAL array, dimension (N)\n*         On entry, the main diagonal of the tridiagonal matrix.\n*         On exit, its eigenvalues.\n*\n*  E      (input) REAL array, dimension (N-1)\n*         The off-diagonal elements of the tridiagonal matrix.\n*         On exit, E has been destroyed.\n*\n*  Q      (input/output) REAL array, dimension (LDQ, N)\n*         On entry, Q must contain an N-by-N orthogonal matrix.\n*         If ICOMPQ = 0    Q is not referenced.\n*         If ICOMPQ = 1    On entry, Q is a subset of the columns of the\n*                          orthogonal matrix used to reduce the full\n*                          matrix to tridiagonal form corresponding to\n*                          the subset of the full matrix which is being\n*                          decomposed at this time.\n*         If ICOMPQ = 2    On entry, Q will be the identity matrix.\n*                          On exit, Q contains the eigenvectors of the\n*                          tridiagonal matrix.\n*\n*  LDQ    (input) INTEGER\n*         The leading dimension of the array Q.  If eigenvectors are\n*         desired, then  LDQ >= max(1,N).  In any case,  LDQ >= 1.\n*\n*  QSTORE (workspace) REAL array, dimension (LDQS, N)\n*         Referenced only when ICOMPQ = 1.  Used to store parts of\n*         the eigenvector matrix when the updating matrix multiplies\n*         take place.\n*\n*  LDQS   (input) INTEGER\n*         The leading dimension of the array QSTORE.  If ICOMPQ = 1,\n*         then  LDQS >= max(1,N).  In any case,  LDQS >= 1.\n*\n*  WORK   (workspace) REAL array,\n*         If ICOMPQ = 0 or 1, the dimension of WORK must be at least\n*                     1 + 3*N + 2*N*lg N + 2*N**2\n*                     ( lg( N ) = smallest integer k\n*                                 such that 2^k >= N )\n*         If ICOMPQ = 2, the dimension of WORK must be at least\n*                     4*N + N**2.\n*\n*  IWORK  (workspace) INTEGER array,\n*         If ICOMPQ = 0 or 1, the dimension of IWORK must be at least\n*                        6 + 6*N + 5*N*lg N.\n*                        ( lg( N ) = smallest integer k\n*                                    such that 2^k >= N )\n*         If ICOMPQ = 2, the dimension of IWORK must be at least\n*                        3 + 5*N.\n*\n*  INFO   (output) INTEGER\n*          = 0:  successful exit.\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          > 0:  The algorithm failed to compute an eigenvalue while\n*                working on the submatrix lying in rows and columns\n*                INFO/(N+1) through mod(INFO,N+1).\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Jeff Rutter, Computer Science Division, University of California\n*     at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, q = NumRu::Lapack.slaed0( icompq, qsiz, d, e, q, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_icompq = argv[0];
  rblapack_qsiz = argv[1];
  rblapack_d = argv[2];
  rblapack_e = argv[3];
  rblapack_q = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  icompq = NUM2INT(rblapack_icompq);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (5th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_q) != NA_SFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
  q = NA_PTR_TYPE(rblapack_q, real*);
  qsiz = NUM2INT(rblapack_qsiz);
  ldqs = icompq == 1 ? MAX(1,n) : 1;
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (4th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
  MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  qstore = ALLOC_N(real, (ldqs)*(n));
  work = ALLOC_N(real, (((icompq == 0) || (icompq == 1)) ? 1 + 3*n + 2*n*LG(n) + 2*pow(n,2) : icompq == 2 ? 4*n + pow(n,2) : 0));
  iwork = ALLOC_N(integer, (((icompq == 0) || (icompq == 1)) ? 6 + 6*n + 5*n*LG(n) : icompq == 2 ? 3 + 5*n : 0));

  slaed0_(&icompq, &qsiz, &n, d, e, q, &ldq, qstore, &ldqs, work, iwork, &info);

  free(qstore);
  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_d, rblapack_q);
}

void
init_lapack_slaed0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaed0", rblapack_slaed0, -1);
}
ruby-lapack-1.7.2/ext/zsymv.c0000644000175000017500000001603312502221016015715 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zsymv_(char* uplo, integer* n, doublecomplex* alpha, doublecomplex* a, integer* lda, doublecomplex* x, integer* incx, doublecomplex* beta, doublecomplex* y, integer* incy);


static VALUE
rblapack_zsymv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_alpha;
  doublecomplex alpha; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_beta;
  doublecomplex beta; 
  VALUE rblapack_y;
  doublecomplex *y; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_y_out__;
  doublecomplex *y_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  y = NumRu::Lapack.zsymv( uplo, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSYMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n*  Purpose\n*  =======\n*\n*  ZSYMV  performs the matrix-vector  operation\n*\n*     y := alpha*A*x + beta*y,\n*\n*  where alpha and beta are scalars, x and y are n element vectors and\n*  A is an n by n symmetric matrix.\n*\n\n*  Arguments\n*  ==========\n*\n*  UPLO     (input) CHARACTER*1\n*           On entry, UPLO specifies whether the upper or lower\n*           triangular part of the array A is to be referenced as\n*           follows:\n*\n*              UPLO = 'U' or 'u'   Only the upper triangular part of A\n*                                  is to be referenced.\n*\n*              UPLO = 'L' or 'l'   Only the lower triangular part of A\n*                                  is to be referenced.\n*\n*           Unchanged on exit.\n*\n*  N        (input) INTEGER\n*           On entry, N specifies the order of the matrix A.\n*           N must be at least zero.\n*           Unchanged on exit.\n*\n*  ALPHA    (input) COMPLEX*16\n*           On entry, ALPHA specifies the scalar alpha.\n*           Unchanged on exit.\n*\n*  A        (input) COMPLEX*16 array, dimension ( LDA, N )\n*           Before entry, with  UPLO = 'U' or 'u', the leading n by n\n*           upper triangular part of the array A must contain the upper\n*           triangular part of the symmetric matrix and the strictly\n*           lower triangular part of A is not referenced.\n*           Before entry, with UPLO = 'L' or 'l', the leading n by n\n*           lower triangular part of the array A must contain the lower\n*           triangular part of the symmetric matrix and the strictly\n*           upper triangular part of A is not referenced.\n*           Unchanged on exit.\n*\n*  LDA      (input) INTEGER\n*           On entry, LDA specifies the first dimension of A as declared\n*           in the calling (sub) program. LDA must be at least\n*           max( 1, N ).\n*           Unchanged on exit.\n*\n*  X        (input) COMPLEX*16 array, dimension at least\n*           ( 1 + ( N - 1 )*abs( INCX ) ).\n*           Before entry, the incremented array X must contain the N-\n*           element vector x.\n*           Unchanged on exit.\n*\n*  INCX     (input) INTEGER\n*           On entry, INCX specifies the increment for the elements of\n*           X. INCX must not be zero.\n*           Unchanged on exit.\n*\n*  BETA     (input) COMPLEX*16\n*           On entry, BETA specifies the scalar beta. When BETA is\n*           supplied as zero then Y need not be set on input.\n*           Unchanged on exit.\n*\n*  Y        (input/output) COMPLEX*16 array, dimension at least\n*           ( 1 + ( N - 1 )*abs( INCY ) ).\n*           Before entry, the incremented array Y must contain the n\n*           element vector y. On exit, Y is overwritten by the updated\n*           vector y.\n*\n*  INCY     (input) INTEGER\n*           On entry, INCY specifies the increment for the elements of\n*           Y. INCY must not be zero.\n*           Unchanged on exit.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  y = NumRu::Lapack.zsymv( uplo, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_uplo = argv[0];
  rblapack_alpha = argv[1];
  rblapack_a = argv[2];
  rblapack_x = argv[3];
  rblapack_incx = argv[4];
  rblapack_beta = argv[5];
  rblapack_y = argv[6];
  rblapack_incy = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  incx = NUM2INT(rblapack_incx);
  incy = NUM2INT(rblapack_incy);
  alpha.r = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
  alpha.i = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
  beta.r = NUM2DBL(rb_funcall(rblapack_beta, rb_intern("real"), 0));
  beta.i = NUM2DBL(rb_funcall(rblapack_beta, rb_intern("imag"), 0));
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (4th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1 + ( n - 1 )*abs( incx )))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (7th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (1 + ( n - 1 )*abs( incy )))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1 + ( n - 1 )*abs( incy ));
  if (NA_TYPE(rblapack_y) != NA_DCOMPLEX)
    rblapack_y = na_change_type(rblapack_y, NA_DCOMPLEX);
  y = NA_PTR_TYPE(rblapack_y, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = 1 + ( n - 1 )*abs( incy );
    rblapack_y_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublecomplex*);
  MEMCPY(y_out__, y, doublecomplex, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  zsymv_(&uplo, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);

  return rblapack_y;
}

void
init_lapack_zsymv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zsymv", rblapack_zsymv, -1);
}
ruby-lapack-1.7.2/ext/zgbtrs.c0000644000175000017500000001327612502221014016044 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgbtrs_(char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, doublecomplex* ab, integer* ldab, integer* ipiv, doublecomplex* b, integer* ldb, integer* info);


static VALUE
rblapack_zgbtrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer ldab;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.zgbtrs( trans, kl, ku, ab, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGBTRS solves a system of linear equations\n*     A * X = B,  A**T * X = B,  or  A**H * X = B\n*  with a general band matrix A using the LU factorization computed\n*  by ZGBTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations.\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)\n*          Details of the LU factorization of the band matrix A, as\n*          computed by ZGBTRF.  U is stored as an upper triangular band\n*          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n*          the multipliers used during the factorization are stored in\n*          rows KL+KU+2 to 2*KL+KU+1.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices; for 1 <= i <= N, row i of the matrix was\n*          interchanged with row IPIV(i).\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.zgbtrs( trans, kl, ku, ab, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_trans = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_b = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zgbtrs_(&trans, &n, &kl, &ku, &nrhs, ab, &ldab, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_zgbtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgbtrs", rblapack_zgbtrs, -1);
}
ruby-lapack-1.7.2/ext/dlarrv.c0000644000175000017500000004163312655767573016063 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlarrv_(integer* n, doublereal* vl, doublereal* vu, doublereal* d, doublereal* l, doublereal* pivmin, integer* isplit, integer* m, integer* dol, integer* dou, doublereal* minrgp, doublereal* rtol1, doublereal* rtol2, doublereal* w, doublereal* werr, doublereal* wgap, integer* iblock, integer* indexw, doublereal* gers, doublereal* z, integer* ldz, integer* isuppz, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dlarrv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_vl;
  doublereal vl; 
  VALUE rblapack_vu;
  doublereal vu; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_l;
  doublereal *l; 
  VALUE rblapack_pivmin;
  doublereal pivmin; 
  VALUE rblapack_isplit;
  integer *isplit; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_dol;
  integer dol; 
  VALUE rblapack_dou;
  integer dou; 
  VALUE rblapack_minrgp;
  doublereal minrgp; 
  VALUE rblapack_rtol1;
  doublereal rtol1; 
  VALUE rblapack_rtol2;
  doublereal rtol2; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_werr;
  doublereal *werr; 
  VALUE rblapack_wgap;
  doublereal *wgap; 
  VALUE rblapack_iblock;
  integer *iblock; 
  VALUE rblapack_indexw;
  integer *indexw; 
  VALUE rblapack_gers;
  doublereal *gers; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_isuppz;
  integer *isuppz; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_l_out__;
  doublereal *l_out__;
  VALUE rblapack_w_out__;
  doublereal *w_out__;
  VALUE rblapack_werr_out__;
  doublereal *werr_out__;
  VALUE rblapack_wgap_out__;
  doublereal *wgap_out__;
  doublereal *work;
  integer *iwork;

  integer n;
  integer ldz;

  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  z, isuppz, info, d, l, w, werr, wgap = NumRu::Lapack.dlarrv( vl, vu, d, l, pivmin, isplit, m, dol, dou, minrgp, rtol1, rtol2, w, werr, wgap, iblock, indexw, gers, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLARRV( N, VL, VU, D, L, PIVMIN, ISPLIT, M, DOL, DOU, MINRGP, RTOL1, RTOL2, W, WERR, WGAP, IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLARRV computes the eigenvectors of the tridiagonal matrix\n*  T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T.\n*  The input eigenvalues should have been computed by DLARRE.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  VL      (input) DOUBLE PRECISION\n*  VU      (input) DOUBLE PRECISION\n*          Lower and upper bounds of the interval that contains the desired\n*          eigenvalues. VL < VU. Needed to compute gaps on the left or right\n*          end of the extremal eigenvalues in the desired RANGE.\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the N diagonal elements of the diagonal matrix D.\n*          On exit, D may be overwritten.\n*\n*  L       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the (N-1) subdiagonal elements of the unit\n*          bidiagonal matrix L are in elements 1 to N-1 of L\n*          (if the matrix is not split.) At the end of each block\n*          is stored the corresponding shift as given by DLARRE.\n*          On exit, L is overwritten.\n*\n*  PIVMIN  (input) DOUBLE PRECISION\n*          The minimum pivot allowed in the Sturm sequence.\n*\n*  ISPLIT  (input) INTEGER array, dimension (N)\n*          The splitting points, at which T breaks up into blocks.\n*          The first block consists of rows/columns 1 to\n*          ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n*          through ISPLIT( 2 ), etc.\n*\n*  M       (input) INTEGER\n*          The total number of input eigenvalues.  0 <= M <= N.\n*\n*  DOL     (input) INTEGER\n*  DOU     (input) INTEGER\n*          If the user wants to compute only selected eigenvectors from all\n*          the eigenvalues supplied, he can specify an index range DOL:DOU.\n*          Or else the setting DOL=1, DOU=M should be applied.\n*          Note that DOL and DOU refer to the order in which the eigenvalues\n*          are stored in W.\n*          If the user wants to compute only selected eigenpairs, then\n*          the columns DOL-1 to DOU+1 of the eigenvector space Z contain the\n*          computed eigenvectors. All other columns of Z are set to zero.\n*\n*  MINRGP  (input) DOUBLE PRECISION\n*\n*  RTOL1   (input) DOUBLE PRECISION\n*  RTOL2   (input) DOUBLE PRECISION\n*           Parameters for bisection.\n*           An interval [LEFT,RIGHT] has converged if\n*           RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n*\n*  W       (input/output) DOUBLE PRECISION array, dimension (N)\n*          The first M elements of W contain the APPROXIMATE eigenvalues for\n*          which eigenvectors are to be computed.  The eigenvalues\n*          should be grouped by split-off block and ordered from\n*          smallest to largest within the block ( The output array\n*          W from DLARRE is expected here ). Furthermore, they are with\n*          respect to the shift of the corresponding root representation\n*          for their block. On exit, W holds the eigenvalues of the\n*          UNshifted matrix.\n*\n*  WERR    (input/output) DOUBLE PRECISION array, dimension (N)\n*          The first M elements contain the semiwidth of the uncertainty\n*          interval of the corresponding eigenvalue in W\n*\n*  WGAP    (input/output) DOUBLE PRECISION array, dimension (N)\n*          The separation from the right neighbor eigenvalue in W.\n*\n*  IBLOCK  (input) INTEGER array, dimension (N)\n*          The indices of the blocks (submatrices) associated with the\n*          corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue\n*          W(i) belongs to the first block from the top, =2 if W(i)\n*          belongs to the second block, etc.\n*\n*  INDEXW  (input) INTEGER array, dimension (N)\n*          The indices of the eigenvalues within each block (submatrix);\n*          for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the\n*          i-th eigenvalue W(i) is the 10-th eigenvalue in the second block.\n*\n*  GERS    (input) DOUBLE PRECISION array, dimension (2*N)\n*          The N Gerschgorin intervals (the i-th Gerschgorin interval\n*          is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should\n*          be computed from the original UNshifted matrix.\n*\n*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )\n*          If INFO = 0, the first M columns of Z contain the\n*          orthonormal eigenvectors of the matrix T\n*          corresponding to the input eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  ISUPPZ  (output) INTEGER array, dimension ( 2*max(1,M) )\n*          The support of the eigenvectors in Z, i.e., the indices\n*          indicating the nonzero elements in Z. The I-th eigenvector\n*          is nonzero only in elements ISUPPZ( 2*I-1 ) through\n*          ISUPPZ( 2*I ).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (12*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (7*N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*\n*          > 0:  A problem occured in DLARRV.\n*          < 0:  One of the called subroutines signaled an internal problem.\n*                Needs inspection of the corresponding parameter IINFO\n*                for further information.\n*\n*          =-1:  Problem in DLARRB when refining a child's eigenvalues.\n*          =-2:  Problem in DLARRF when computing the RRR of a child.\n*                When a child is inside a tight cluster, it can be difficult\n*                to find an RRR. A partial remedy from the user's point of\n*                view is to make the parameter MINRGP smaller and recompile.\n*                However, as the orthogonality of the computed vectors is\n*                proportional to 1/MINRGP, the user should be aware that\n*                he might be trading in precision when he decreases MINRGP.\n*          =-3:  Problem in DLARRB when refining a single eigenvalue\n*                after the Rayleigh correction was rejected.\n*          = 5:  The Rayleigh Quotient Iteration failed to converge to\n*                full accuracy in MAXITR steps.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Beresford Parlett, University of California, Berkeley, USA\n*     Jim Demmel, University of California, Berkeley, USA\n*     Inderjit Dhillon, University of Texas, Austin, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  z, isuppz, info, d, l, w, werr, wgap = NumRu::Lapack.dlarrv( vl, vu, d, l, pivmin, isplit, m, dol, dou, minrgp, rtol1, rtol2, w, werr, wgap, iblock, indexw, gers, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 18 && argc != 18)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 18)", argc);
  rblapack_vl = argv[0];
  rblapack_vu = argv[1];
  rblapack_d = argv[2];
  rblapack_l = argv[3];
  rblapack_pivmin = argv[4];
  rblapack_isplit = argv[5];
  rblapack_m = argv[6];
  rblapack_dol = argv[7];
  rblapack_dou = argv[8];
  rblapack_minrgp = argv[9];
  rblapack_rtol1 = argv[10];
  rblapack_rtol2 = argv[11];
  rblapack_w = argv[12];
  rblapack_werr = argv[13];
  rblapack_wgap = argv[14];
  rblapack_iblock = argv[15];
  rblapack_indexw = argv[16];
  rblapack_gers = argv[17];
  if (argc == 18) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  vl = NUM2DBL(rblapack_vl);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  pivmin = NUM2DBL(rblapack_pivmin);
  m = NUM2INT(rblapack_m);
  dou = NUM2INT(rblapack_dou);
  rtol1 = NUM2DBL(rblapack_rtol1);
  if (!NA_IsNArray(rblapack_w))
    rb_raise(rb_eArgError, "w (13th argument) must be NArray");
  if (NA_RANK(rblapack_w) != 1)
    rb_raise(rb_eArgError, "rank of w (13th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_w) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_w) != NA_DFLOAT)
    rblapack_w = na_change_type(rblapack_w, NA_DFLOAT);
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  if (!NA_IsNArray(rblapack_wgap))
    rb_raise(rb_eArgError, "wgap (15th argument) must be NArray");
  if (NA_RANK(rblapack_wgap) != 1)
    rb_raise(rb_eArgError, "rank of wgap (15th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_wgap) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of wgap must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_wgap) != NA_DFLOAT)
    rblapack_wgap = na_change_type(rblapack_wgap, NA_DFLOAT);
  wgap = NA_PTR_TYPE(rblapack_wgap, doublereal*);
  if (!NA_IsNArray(rblapack_indexw))
    rb_raise(rb_eArgError, "indexw (17th argument) must be NArray");
  if (NA_RANK(rblapack_indexw) != 1)
    rb_raise(rb_eArgError, "rank of indexw (17th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_indexw) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of indexw must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_indexw) != NA_LINT)
    rblapack_indexw = na_change_type(rblapack_indexw, NA_LINT);
  indexw = NA_PTR_TYPE(rblapack_indexw, integer*);
  vu = NUM2DBL(rblapack_vu);
  if (!NA_IsNArray(rblapack_isplit))
    rb_raise(rb_eArgError, "isplit (6th argument) must be NArray");
  if (NA_RANK(rblapack_isplit) != 1)
    rb_raise(rb_eArgError, "rank of isplit (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_isplit) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of isplit must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_isplit) != NA_LINT)
    rblapack_isplit = na_change_type(rblapack_isplit, NA_LINT);
  isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
  minrgp = NUM2DBL(rblapack_minrgp);
  if (!NA_IsNArray(rblapack_werr))
    rb_raise(rb_eArgError, "werr (14th argument) must be NArray");
  if (NA_RANK(rblapack_werr) != 1)
    rb_raise(rb_eArgError, "rank of werr (14th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_werr) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of werr must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_werr) != NA_DFLOAT)
    rblapack_werr = na_change_type(rblapack_werr, NA_DFLOAT);
  werr = NA_PTR_TYPE(rblapack_werr, doublereal*);
  if (!NA_IsNArray(rblapack_l))
    rb_raise(rb_eArgError, "l (4th argument) must be NArray");
  if (NA_RANK(rblapack_l) != 1)
    rb_raise(rb_eArgError, "rank of l (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_l) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of l must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_l) != NA_DFLOAT)
    rblapack_l = na_change_type(rblapack_l, NA_DFLOAT);
  l = NA_PTR_TYPE(rblapack_l, doublereal*);
  rtol2 = NUM2DBL(rblapack_rtol2);
  dol = NUM2INT(rblapack_dol);
  if (!NA_IsNArray(rblapack_iblock))
    rb_raise(rb_eArgError, "iblock (16th argument) must be NArray");
  if (NA_RANK(rblapack_iblock) != 1)
    rb_raise(rb_eArgError, "rank of iblock (16th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_iblock) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of iblock must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_iblock) != NA_LINT)
    rblapack_iblock = na_change_type(rblapack_iblock, NA_LINT);
  iblock = NA_PTR_TYPE(rblapack_iblock, integer*);
  ldz = n;
  if (!NA_IsNArray(rblapack_gers))
    rb_raise(rb_eArgError, "gers (18th argument) must be NArray");
  if (NA_RANK(rblapack_gers) != 1)
    rb_raise(rb_eArgError, "rank of gers (18th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_gers) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of gers must be %d", 2*n);
  if (NA_TYPE(rblapack_gers) != NA_DFLOAT)
    rblapack_gers = na_change_type(rblapack_gers, NA_DFLOAT);
  gers = NA_PTR_TYPE(rblapack_gers, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 2*MAX(1,m);
    rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_l_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  l_out__ = NA_PTR_TYPE(rblapack_l_out__, doublereal*);
  MEMCPY(l_out__, l, doublereal, NA_TOTAL(rblapack_l));
  rblapack_l = rblapack_l_out__;
  l = l_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w_out__ = NA_PTR_TYPE(rblapack_w_out__, doublereal*);
  MEMCPY(w_out__, w, doublereal, NA_TOTAL(rblapack_w));
  rblapack_w = rblapack_w_out__;
  w = w_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_werr_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  werr_out__ = NA_PTR_TYPE(rblapack_werr_out__, doublereal*);
  MEMCPY(werr_out__, werr, doublereal, NA_TOTAL(rblapack_werr));
  rblapack_werr = rblapack_werr_out__;
  werr = werr_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wgap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  wgap_out__ = NA_PTR_TYPE(rblapack_wgap_out__, doublereal*);
  MEMCPY(wgap_out__, wgap, doublereal, NA_TOTAL(rblapack_wgap));
  rblapack_wgap = rblapack_wgap_out__;
  wgap = wgap_out__;
  work = ALLOC_N(doublereal, (12*n));
  iwork = ALLOC_N(integer, (7*n));

  dlarrv_(&n, &vl, &vu, d, l, &pivmin, isplit, &m, &dol, &dou, &minrgp, &rtol1, &rtol2, w, werr, wgap, iblock, indexw, gers, z, &ldz, isuppz, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_z, rblapack_isuppz, rblapack_info, rblapack_d, rblapack_l, rblapack_w, rblapack_werr, rblapack_wgap);
}

void
init_lapack_dlarrv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlarrv", rblapack_dlarrv, -1);
}
ruby-lapack-1.7.2/ext/stgsyl.c0000644000175000017500000003323312502221013016050 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID stgsyl_(char* trans, integer* ijob, integer* m, integer* n, real* a, integer* lda, real* b, integer* ldb, real* c, integer* ldc, real* d, integer* ldd, real* e, integer* lde, real* f, integer* ldf, real* scale, real* dif, real* work, integer* lwork, integer* iwork, integer* info);


static VALUE
rblapack_stgsyl(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_ijob;
  integer ijob; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_f;
  real *f; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_scale;
  real scale; 
  VALUE rblapack_dif;
  real dif; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  real *c_out__;
  VALUE rblapack_f_out__;
  real *f_out__;
  integer *iwork;

  integer lda;
  integer m;
  integer ldb;
  integer n;
  integer ldc;
  integer ldd;
  integer lde;
  integer ldf;

  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  scale, dif, work, info, c, f = NumRu::Lapack.stgsyl( trans, ijob, a, b, c, d, e, f, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  STGSYL solves the generalized Sylvester equation:\n*\n*              A * R - L * B = scale * C                 (1)\n*              D * R - L * E = scale * F\n*\n*  where R and L are unknown m-by-n matrices, (A, D), (B, E) and\n*  (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n,\n*  respectively, with real entries. (A, D) and (B, E) must be in\n*  generalized (real) Schur canonical form, i.e. A, B are upper quasi\n*  triangular and D, E are upper triangular.\n*\n*  The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output\n*  scaling factor chosen to avoid overflow.\n*\n*  In matrix notation (1) is equivalent to solve  Zx = scale b, where\n*  Z is defined as\n*\n*             Z = [ kron(In, A)  -kron(B', Im) ]         (2)\n*                 [ kron(In, D)  -kron(E', Im) ].\n*\n*  Here Ik is the identity matrix of size k and X' is the transpose of\n*  X. kron(X, Y) is the Kronecker product between the matrices X and Y.\n*\n*  If TRANS = 'T', STGSYL solves the transposed system Z'*y = scale*b,\n*  which is equivalent to solve for R and L in\n*\n*              A' * R  + D' * L   = scale *  C           (3)\n*              R  * B' + L  * E'  = scale * (-F)\n*\n*  This case (TRANS = 'T') is used to compute an one-norm-based estimate\n*  of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D)\n*  and (B,E), using SLACON.\n*\n*  If IJOB >= 1, STGSYL computes a Frobenius norm-based estimate\n*  of Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the\n*  reciprocal of the smallest singular value of Z. See [1-2] for more\n*  information.\n*\n*  This is a level 3 BLAS algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N', solve the generalized Sylvester equation (1).\n*          = 'T', solve the 'transposed' system (3).\n*\n*  IJOB    (input) INTEGER\n*          Specifies what kind of functionality to be performed.\n*           =0: solve (1) only.\n*           =1: The functionality of 0 and 3.\n*           =2: The functionality of 0 and 4.\n*           =3: Only an estimate of Dif[(A,D), (B,E)] is computed.\n*               (look ahead strategy IJOB  = 1 is used).\n*           =4: Only an estimate of Dif[(A,D), (B,E)] is computed.\n*               ( SGECON on sub-systems is used ).\n*          Not referenced if TRANS = 'T'.\n*\n*  M       (input) INTEGER\n*          The order of the matrices A and D, and the row dimension of\n*          the matrices C, F, R and L.\n*\n*  N       (input) INTEGER\n*          The order of the matrices B and E, and the column dimension\n*          of the matrices C, F, R and L.\n*\n*  A       (input) REAL array, dimension (LDA, M)\n*          The upper quasi triangular matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1, M).\n*\n*  B       (input) REAL array, dimension (LDB, N)\n*          The upper quasi triangular matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1, N).\n*\n*  C       (input/output) REAL array, dimension (LDC, N)\n*          On entry, C contains the right-hand-side of the first matrix\n*          equation in (1) or (3).\n*          On exit, if IJOB = 0, 1 or 2, C has been overwritten by\n*          the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R,\n*          the solution achieved during the computation of the\n*          Dif-estimate.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1, M).\n*\n*  D       (input) REAL array, dimension (LDD, M)\n*          The upper triangular matrix D.\n*\n*  LDD     (input) INTEGER\n*          The leading dimension of the array D. LDD >= max(1, M).\n*\n*  E       (input) REAL array, dimension (LDE, N)\n*          The upper triangular matrix E.\n*\n*  LDE     (input) INTEGER\n*          The leading dimension of the array E. LDE >= max(1, N).\n*\n*  F       (input/output) REAL array, dimension (LDF, N)\n*          On entry, F contains the right-hand-side of the second matrix\n*          equation in (1) or (3).\n*          On exit, if IJOB = 0, 1 or 2, F has been overwritten by\n*          the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L,\n*          the solution achieved during the computation of the\n*          Dif-estimate.\n*\n*  LDF     (input) INTEGER\n*          The leading dimension of the array F. LDF >= max(1, M).\n*\n*  DIF     (output) REAL\n*          On exit DIF is the reciprocal of a lower bound of the\n*          reciprocal of the Dif-function, i.e. DIF is an upper bound of\n*          Dif[(A,D), (B,E)] = sigma_min(Z), where Z as in (2).\n*          IF IJOB = 0 or TRANS = 'T', DIF is not touched.\n*\n*  SCALE   (output) REAL\n*          On exit SCALE is the scaling factor in (1) or (3).\n*          If 0 < SCALE < 1, C and F hold the solutions R and L, resp.,\n*          to a slightly perturbed system but the input matrices A, B, D\n*          and E have not been changed. If SCALE = 0, C and F hold the\n*          solutions R and L, respectively, to the homogeneous system\n*          with C = F = 0. Normally, SCALE = 1.\n*\n*  WORK    (workspace/output) REAL 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 > = 1.\n*          If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N).\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*  IWORK   (workspace) INTEGER array, dimension (M+N+6)\n*\n*  INFO    (output) INTEGER\n*            =0: successful exit\n*            <0: If INFO = -i, the i-th argument had an illegal value.\n*            >0: (A, D) and (B, E) have common or close eigenvalues.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n*      for Solving the Generalized Sylvester Equation and Estimating the\n*      Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n*      Department of Computing Science, Umea University, S-901 87 Umea,\n*      Sweden, December 1993, Revised April 1994, Also as LAPACK Working\n*      Note 75.  To appear in ACM Trans. on Math. Software, Vol 22,\n*      No 1, 1996.\n*\n*  [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester\n*      Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal.\n*      Appl., 15(4):1045-1060, 1994\n*\n*  [3] B. Kagstrom and L. Westin, Generalized Schur Methods with\n*      Condition Estimators for Solving the Generalized Sylvester\n*      Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7,\n*      July 1989, pp 745-751.\n*\n*  =====================================================================\n*  Replaced various illegal calls to SCOPY by calls to SLASET.\n*  Sven Hammarling, 1/5/02.\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, dif, work, info, c, f = NumRu::Lapack.stgsyl( trans, ijob, a, b, c, d, e, f, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_trans = argv[0];
  rblapack_ijob = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  rblapack_c = argv[4];
  rblapack_d = argv[5];
  rblapack_e = argv[6];
  rblapack_f = argv[7];
  if (argc == 9) {
    rblapack_lwork = argv[8];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (7th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 2)
    rb_raise(rb_eArgError, "rank of e (7th argument) must be %d", 2);
  lde = NA_SHAPE0(rblapack_e);
  if (NA_SHAPE1(rblapack_e) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of e must be the same as shape 1 of c");
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  ijob = NUM2INT(rblapack_ijob);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (6th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 2)
    rb_raise(rb_eArgError, "rank of d (6th argument) must be %d", 2);
  ldd = NA_SHAPE0(rblapack_d);
  if (NA_SHAPE1(rblapack_d) != m)
    rb_raise(rb_eRuntimeError, "shape 1 of d must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of c");
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (!NA_IsNArray(rblapack_f))
    rb_raise(rb_eArgError, "f (8th argument) must be NArray");
  if (NA_RANK(rblapack_f) != 2)
    rb_raise(rb_eArgError, "rank of f (8th argument) must be %d", 2);
  ldf = NA_SHAPE0(rblapack_f);
  if (NA_SHAPE1(rblapack_f) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of f must be the same as shape 1 of c");
  if (NA_TYPE(rblapack_f) != NA_SFLOAT)
    rblapack_f = na_change_type(rblapack_f, NA_SFLOAT);
  f = NA_PTR_TYPE(rblapack_f, real*);
  if (rblapack_lwork == Qnil)
    lwork = ((ijob==1||ijob==2)&&lsame_(&trans,"N")) ? 2*m*n : 1;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldf;
    shape[1] = n;
    rblapack_f_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  f_out__ = NA_PTR_TYPE(rblapack_f_out__, real*);
  MEMCPY(f_out__, f, real, NA_TOTAL(rblapack_f));
  rblapack_f = rblapack_f_out__;
  f = f_out__;
  iwork = ALLOC_N(integer, (m+n+6));

  stgsyl_(&trans, &ijob, &m, &n, a, &lda, b, &ldb, c, &ldc, d, &ldd, e, &lde, f, &ldf, &scale, &dif, work, &lwork, iwork, &info);

  free(iwork);
  rblapack_scale = rb_float_new((double)scale);
  rblapack_dif = rb_float_new((double)dif);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_scale, rblapack_dif, rblapack_work, rblapack_info, rblapack_c, rblapack_f);
}

void
init_lapack_stgsyl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "stgsyl", rblapack_stgsyl, -1);
}
ruby-lapack-1.7.2/ext/zlatrd.c0000644000175000017500000001765212502221015016034 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlatrd_(char* uplo, integer* n, integer* nb, doublecomplex* a, integer* lda, doublereal* e, doublecomplex* tau, doublecomplex* w, integer* ldw);


static VALUE
rblapack_zlatrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_nb;
  integer nb; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_w;
  doublecomplex *w; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;

  integer lda;
  integer n;
  integer ldw;

  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  e, tau, w, a = NumRu::Lapack.zlatrd( uplo, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )\n\n*  Purpose\n*  =======\n*\n*  ZLATRD reduces NB rows and columns of a complex Hermitian matrix A to\n*  Hermitian tridiagonal form by a unitary similarity\n*  transformation Q' * A * Q, and returns the matrices V and W which are\n*  needed to apply the transformation to the unreduced part of A.\n*\n*  If UPLO = 'U', ZLATRD reduces the last NB rows and columns of a\n*  matrix, of which the upper triangle is supplied;\n*  if UPLO = 'L', ZLATRD reduces the first NB rows and columns of a\n*  matrix, of which the lower triangle is supplied.\n*\n*  This is an auxiliary routine called by ZHETRD.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          Hermitian matrix A is stored:\n*          = 'U': Upper triangular\n*          = 'L': Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.\n*\n*  NB      (input) INTEGER\n*          The number of rows and columns to be reduced.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading\n*          n-by-n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n-by-n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*          On exit:\n*          if UPLO = 'U', the last NB columns have been reduced to\n*            tridiagonal form, with the diagonal elements overwriting\n*            the diagonal elements of A; the elements above the diagonal\n*            with the array TAU, represent the unitary matrix Q as a\n*            product of elementary reflectors;\n*          if UPLO = 'L', the first NB columns have been reduced to\n*            tridiagonal form, with the diagonal elements overwriting\n*            the diagonal elements of A; the elements below the diagonal\n*            with the array TAU, represent the  unitary matrix Q as a\n*            product of elementary reflectors.\n*          See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  E       (output) DOUBLE PRECISION array, dimension (N-1)\n*          If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal\n*          elements of the last NB columns of the reduced matrix;\n*          if UPLO = 'L', E(1:nb) contains the subdiagonal elements of\n*          the first NB columns of the reduced matrix.\n*\n*  TAU     (output) COMPLEX*16 array, dimension (N-1)\n*          The scalar factors of the elementary reflectors, stored in\n*          TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.\n*          See Further Details.\n*\n*  W       (output) COMPLEX*16 array, dimension (LDW,NB)\n*          The n-by-nb matrix W required to update the unreduced part\n*          of A.\n*\n*  LDW     (input) INTEGER\n*          The leading dimension of the array W. LDW >= max(1,N).\n*\n\n*  Further Details\n*  ===============\n*\n*  If UPLO = 'U', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(n) H(n-1) . . . H(n-nb+1).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - tau * v * v'\n*\n*  where tau is a complex scalar, and v is a complex vector with\n*  v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),\n*  and tau in TAU(i-1).\n*\n*  If UPLO = 'L', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(1) H(2) . . . H(nb).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - tau * v * v'\n*\n*  where tau is a complex scalar, and v is a complex vector with\n*  v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),\n*  and tau in TAU(i).\n*\n*  The elements of the vectors v together form the n-by-nb matrix V\n*  which is needed, with W, to apply the transformation to the unreduced\n*  part of the matrix, using a Hermitian rank-2k update of the form:\n*  A := A - V*W' - W*V'.\n*\n*  The contents of A on exit are illustrated by the following examples\n*  with n = 5 and nb = 2:\n*\n*  if UPLO = 'U':                       if UPLO = 'L':\n*\n*    (  a   a   a   v4  v5 )              (  d                  )\n*    (      a   a   v4  v5 )              (  1   d              )\n*    (          a   1   v5 )              (  v1  1   a          )\n*    (              d   1  )              (  v1  v2  a   a      )\n*    (                  d  )              (  v1  v2  a   a   a  )\n*\n*  where d denotes a diagonal element of the reduced matrix, a denotes\n*  an element of the original matrix that is unchanged, and vi denotes\n*  an element of the vector defining H(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  e, tau, w, a = NumRu::Lapack.zlatrd( uplo, nb, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_nb = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  nb = NUM2INT(rblapack_nb);
  ldw = MAX(1,n);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldw;
    shape[1] = MAX(n,nb);
    rblapack_w = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zlatrd_(&uplo, &n, &nb, a, &lda, e, tau, w, &ldw);

  return rb_ary_new3(4, rblapack_e, rblapack_tau, rblapack_w, rblapack_a);
}

void
init_lapack_zlatrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlatrd", rblapack_zlatrd, -1);
}
ruby-lapack-1.7.2/ext/dspgst.c0000644000175000017500000001165612502221014016035 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dspgst_(integer* itype, char* uplo, integer* n, doublereal* ap, doublereal* bp, integer* info);


static VALUE
rblapack_dspgst(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_bp;
  doublereal *bp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublereal *ap_out__;


  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  info, ap = NumRu::Lapack.dspgst( itype, uplo, n, ap, bp, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSPGST( ITYPE, UPLO, N, AP, BP, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSPGST reduces a real symmetric-definite generalized eigenproblem\n*  to standard form, using packed storage.\n*\n*  If ITYPE = 1, the problem is A*x = lambda*B*x,\n*  and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)\n*\n*  If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n*  B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.\n*\n*  B must have been previously factorized as U**T*U or L*L**T by DPPTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);\n*          = 2 or 3: compute U*A*U**T or L**T*A*L.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored and B is factored as\n*                  U**T*U;\n*          = 'L':  Lower triangle of A is stored and B is factored as\n*                  L*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, if INFO = 0, the transformed matrix, stored in the\n*          same format as A.\n*\n*  BP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          The triangular factor from the Cholesky factorization of B,\n*          stored in the same format as A, as returned by DPPTRF.\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ap = NumRu::Lapack.dspgst( itype, uplo, n, ap, bp, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_itype = argv[0];
  rblapack_uplo = argv[1];
  rblapack_n = argv[2];
  rblapack_ap = argv[3];
  rblapack_bp = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  itype = NUM2INT(rblapack_itype);
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_bp))
    rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
  if (NA_RANK(rblapack_bp) != 1)
    rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_bp) != NA_DFLOAT)
    rblapack_bp = na_change_type(rblapack_bp, NA_DFLOAT);
  bp = NA_PTR_TYPE(rblapack_bp, doublereal*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
  MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  dspgst_(&itype, &uplo, &n, ap, bp, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ap);
}

void
init_lapack_dspgst(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dspgst", rblapack_dspgst, -1);
}
ruby-lapack-1.7.2/ext/dlarft.c0000644000175000017500000001544512502221013016004 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlarft_(char* direct, char* storev, integer* n, integer* k, doublereal* v, integer* ldv, doublereal* tau, doublereal* t, integer* ldt);


static VALUE
rblapack_dlarft(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_direct;
  char direct; 
  VALUE rblapack_storev;
  char storev; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_v;
  doublereal *v; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_t;
  doublereal *t; 
  VALUE rblapack_v_out__;
  doublereal *v_out__;

  integer ldv;
  integer k;
  integer ldt;

  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  t, v = NumRu::Lapack.dlarft( direct, storev, n, v, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n*  Purpose\n*  =======\n*\n*  DLARFT forms the triangular factor T of a real block reflector H\n*  of order n, which is defined as a product of k elementary reflectors.\n*\n*  If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n*\n*  If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n*\n*  If STOREV = 'C', the vector which defines the elementary reflector\n*  H(i) is stored in the i-th column of the array V, and\n*\n*     H  =  I - V * T * V'\n*\n*  If STOREV = 'R', the vector which defines the elementary reflector\n*  H(i) is stored in the i-th row of the array V, and\n*\n*     H  =  I - V' * T * V\n*\n\n*  Arguments\n*  =========\n*\n*  DIRECT  (input) CHARACTER*1\n*          Specifies the order in which the elementary reflectors are\n*          multiplied to form the block reflector:\n*          = 'F': H = H(1) H(2) . . . H(k) (Forward)\n*          = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n*  STOREV  (input) CHARACTER*1\n*          Specifies how the vectors which define the elementary\n*          reflectors are stored (see also Further Details):\n*          = 'C': columnwise\n*          = 'R': rowwise\n*\n*  N       (input) INTEGER\n*          The order of the block reflector H. N >= 0.\n*\n*  K       (input) INTEGER\n*          The order of the triangular factor T (= the number of\n*          elementary reflectors). K >= 1.\n*\n*  V       (input/output) DOUBLE PRECISION array, dimension\n*                               (LDV,K) if STOREV = 'C'\n*                               (LDV,N) if STOREV = 'R'\n*          The matrix V. See further details.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V.\n*          If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n*\n*  TAU     (input) DOUBLE PRECISION array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i).\n*\n*  T       (output) DOUBLE PRECISION array, dimension (LDT,K)\n*          The k by k triangular factor T of the block reflector.\n*          If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n*          lower triangular. The rest of the array is not used.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= K.\n*\n\n*  Further Details\n*  ===============\n*\n*  The shape of the matrix V and the storage of the vectors which define\n*  the H(i) is best illustrated by the following example with n = 5 and\n*  k = 3. The elements equal to 1 are not stored; the corresponding\n*  array elements are modified but restored on exit. The rest of the\n*  array is not used.\n*\n*  DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R':\n*\n*               V = (  1       )                 V = (  1 v1 v1 v1 v1 )\n*                   ( v1  1    )                     (     1 v2 v2 v2 )\n*                   ( v1 v2  1 )                     (        1 v3 v3 )\n*                   ( v1 v2 v3 )\n*                   ( v1 v2 v3 )\n*\n*  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R':\n*\n*               V = ( v1 v2 v3 )                 V = ( v1 v1  1       )\n*                   ( v1 v2 v3 )                     ( v2 v2 v2  1    )\n*                   (  1 v2 v3 )                     ( v3 v3 v3 v3  1 )\n*                   (     1 v3 )\n*                   (        1 )\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  t, v = NumRu::Lapack.dlarft( direct, storev, n, v, tau, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_direct = argv[0];
  rblapack_storev = argv[1];
  rblapack_n = argv[2];
  rblapack_v = argv[3];
  rblapack_tau = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  direct = StringValueCStr(rblapack_direct)[0];
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  storev = StringValueCStr(rblapack_storev)[0];
  ldt = k;
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (4th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  if (NA_SHAPE1(rblapack_v) != (lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0))
    rb_raise(rb_eRuntimeError, "shape 1 of v must be %d", lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0);
  if (NA_TYPE(rblapack_v) != NA_DFLOAT)
    rblapack_v = na_change_type(rblapack_v, NA_DFLOAT);
  v = NA_PTR_TYPE(rblapack_v, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = k;
    rblapack_t = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  t = NA_PTR_TYPE(rblapack_t, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0;
    rblapack_v_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  v_out__ = NA_PTR_TYPE(rblapack_v_out__, doublereal*);
  MEMCPY(v_out__, v, doublereal, NA_TOTAL(rblapack_v));
  rblapack_v = rblapack_v_out__;
  v = v_out__;

  dlarft_(&direct, &storev, &n, &k, v, &ldv, tau, t, &ldt);

  return rb_ary_new3(2, rblapack_t, rblapack_v);
}

void
init_lapack_dlarft(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlarft", rblapack_dlarft, -1);
}
ruby-lapack-1.7.2/ext/ilauplo.c0000644000175000017500000000372312502221013016171 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern integer ilauplo_(char* uplo);


static VALUE
rblapack_ilauplo(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack___out__;
  integer __out__; 


  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  __out__ = NumRu::Lapack.ilauplo( uplo, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      INTEGER FUNCTION ILAUPLO( UPLO )\n\n*  Purpose\n*  =======\n*\n*  This subroutine translated from a character string specifying a\n*  upper- or lower-triangular matrix to the relevant BLAST-specified\n*  integer constant.\n*\n*  ILAUPLO returns an INTEGER.  If ILAUPLO < 0, then the input is not\n*  a character indicating an upper- or lower-triangular matrix.\n*  Otherwise ILAUPLO returns the constant value corresponding to UPLO.\n*\n\n*  Arguments\n*  =========\n*  UPLO    (input) CHARACTER\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.ilauplo( uplo, [: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_uplo = argv[0];
  if (argc == 1) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];

  __out__ = ilauplo_(&uplo);

  rblapack___out__ = INT2NUM(__out__);
  return rblapack___out__;
}

void
init_lapack_ilauplo(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ilauplo", rblapack_ilauplo, -1);
}
ruby-lapack-1.7.2/ext/cgtcon.c0000644000175000017500000001505312502221012015777 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgtcon_(char* norm, integer* n, complex* dl, complex* d, complex* du, complex* du2, integer* ipiv, real* anorm, real* rcond, complex* work, integer* info);


static VALUE
rblapack_cgtcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_dl;
  complex *dl; 
  VALUE rblapack_d;
  complex *d; 
  VALUE rblapack_du;
  complex *du; 
  VALUE rblapack_du2;
  complex *du2; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_anorm;
  real anorm; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_info;
  integer info; 
  complex *work;

  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  rcond, info = NumRu::Lapack.cgtcon( norm, dl, d, du, du2, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGTCON estimates the reciprocal of the condition number of a complex\n*  tridiagonal matrix A using the LU factorization as computed by\n*  CGTTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies whether the 1-norm condition number or the\n*          infinity-norm condition number is required:\n*          = '1' or 'O':  1-norm;\n*          = 'I':         Infinity-norm.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  DL      (input) COMPLEX array, dimension (N-1)\n*          The (n-1) multipliers that define the matrix L from the\n*          LU factorization of A as computed by CGTTRF.\n*\n*  D       (input) COMPLEX array, dimension (N)\n*          The n diagonal elements of the upper triangular matrix U from\n*          the LU factorization of A.\n*\n*  DU      (input) COMPLEX array, dimension (N-1)\n*          The (n-1) elements of the first superdiagonal of U.\n*\n*  DU2     (input) COMPLEX array, dimension (N-2)\n*          The (n-2) elements of the second superdiagonal of U.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices; for 1 <= i <= n, row i of the matrix was\n*          interchanged with row IPIV(i).  IPIV(i) will always be either\n*          i or i+1; IPIV(i) = i indicates a row interchange was not\n*          required.\n*\n*  ANORM   (input) REAL\n*          If NORM = '1' or 'O', the 1-norm of the original matrix A.\n*          If NORM = 'I', the infinity-norm of the original matrix A.\n*\n*  RCOND   (output) REAL\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n*          estimate of the 1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.cgtcon( norm, dl, d, du, du2, ipiv, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_norm = argv[0];
  rblapack_dl = argv[1];
  rblapack_d = argv[2];
  rblapack_du = argv[3];
  rblapack_du2 = argv[4];
  rblapack_ipiv = argv[5];
  rblapack_anorm = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SCOMPLEX)
    rblapack_d = na_change_type(rblapack_d, NA_SCOMPLEX);
  d = NA_PTR_TYPE(rblapack_d, complex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_SCOMPLEX)
    rblapack_dl = na_change_type(rblapack_dl, NA_SCOMPLEX);
  dl = NA_PTR_TYPE(rblapack_dl, complex*);
  if (!NA_IsNArray(rblapack_du2))
    rb_raise(rb_eArgError, "du2 (5th argument) must be NArray");
  if (NA_RANK(rblapack_du2) != 1)
    rb_raise(rb_eArgError, "rank of du2 (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du2) != (n-2))
    rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
  if (NA_TYPE(rblapack_du2) != NA_SCOMPLEX)
    rblapack_du2 = na_change_type(rblapack_du2, NA_SCOMPLEX);
  du2 = NA_PTR_TYPE(rblapack_du2, complex*);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (4th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_SCOMPLEX)
    rblapack_du = na_change_type(rblapack_du, NA_SCOMPLEX);
  du = NA_PTR_TYPE(rblapack_du, complex*);
  anorm = (real)NUM2DBL(rblapack_anorm);
  work = ALLOC_N(complex, (2*n));

  cgtcon_(&norm, &n, dl, d, du, du2, ipiv, &anorm, &rcond, work, &info);

  free(work);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_cgtcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgtcon", rblapack_cgtcon, -1);
}
ruby-lapack-1.7.2/ext/dggqrf.c0000644000175000017500000002325612502221021016000 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dggqrf_(integer* n, integer* m, integer* p, doublereal* a, integer* lda, doublereal* taua, doublereal* b, integer* ldb, doublereal* taub, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dggqrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_taua;
  doublereal *taua; 
  VALUE rblapack_taub;
  doublereal *taub; 
  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 m;
  integer ldb;
  integer p;

  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  taua, taub, work, info, a, b = NumRu::Lapack.dggqrf( n, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGGQRF computes a generalized QR factorization of an N-by-M matrix A\n*  and an N-by-P matrix B:\n*\n*              A = Q*R,        B = Q*T*Z,\n*\n*  where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal\n*  matrix, and R and T assume one of the forms:\n*\n*  if N >= M,  R = ( R11 ) M  ,   or if N < M,  R = ( R11  R12 ) N,\n*                  (  0  ) N-M                         N   M-N\n*                     M\n*\n*  where R11 is upper triangular, and\n*\n*  if N <= P,  T = ( 0  T12 ) N,   or if N > P,  T = ( T11 ) N-P,\n*                   P-N  N                           ( T21 ) P\n*                                                       P\n*\n*  where T12 or T21 is upper triangular.\n*\n*  In particular, if B is square and nonsingular, the GQR factorization\n*  of A and B implicitly gives the QR factorization of inv(B)*A:\n*\n*               inv(B)*A = Z'*(inv(T)*R)\n*\n*  where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n*  transpose of the matrix Z.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of rows of the matrices A and B. N >= 0.\n*\n*  M       (input) INTEGER\n*          The number of columns of the matrix A.  M >= 0.\n*\n*  P       (input) INTEGER\n*          The number of columns of the matrix B.  P >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,M)\n*          On entry, the N-by-M matrix A.\n*          On exit, the elements on and above the diagonal of the array\n*          contain the min(N,M)-by-M upper trapezoidal matrix R (R is\n*          upper triangular if N >= M); the elements below the diagonal,\n*          with the array TAUA, represent the orthogonal matrix Q as a\n*          product of min(N,M) elementary reflectors (see Further\n*          Details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  TAUA    (output) DOUBLE PRECISION array, dimension (min(N,M))\n*          The scalar factors of the elementary reflectors which\n*          represent the orthogonal matrix Q (see Further Details).\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,P)\n*          On entry, the N-by-P matrix B.\n*          On exit, if N <= P, the upper triangle of the subarray\n*          B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n*          if N > P, the elements on and above the (N-P)-th subdiagonal\n*          contain the N-by-P upper trapezoidal matrix T; the remaining\n*          elements, with the array TAUB, represent the orthogonal\n*          matrix Z as a product of elementary reflectors (see Further\n*          Details).\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  TAUB    (output) DOUBLE PRECISION array, dimension (min(N,P))\n*          The scalar factors of the elementary reflectors which\n*          represent the orthogonal matrix Z (see Further 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,N,M,P).\n*          For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n*          where NB1 is the optimal blocksize for the QR factorization\n*          of an N-by-M matrix, NB2 is the optimal blocksize for the\n*          RQ factorization of an N-by-P matrix, and NB3 is the optimal\n*          blocksize for a call of DORMQR.\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(1) H(2) . . . H(k), where k = min(n,m).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - taua * v * v'\n*\n*  where taua 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+1:n,i),\n*  and taua in TAUA(i).\n*  To form Q explicitly, use LAPACK subroutine DORGQR.\n*  To use Q to update another matrix, use LAPACK subroutine DORMQR.\n*\n*  The matrix Z is represented as a product of elementary reflectors\n*\n*     Z = H(1) H(2) . . . H(k), where k = min(n,p).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - taub * v * v'\n*\n*  where taub is a real scalar, and v is a real vector with\n*  v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in\n*  B(n-k+i,1:p-k+i-1), and taub in TAUB(i).\n*  To form Z explicitly, use LAPACK subroutine DORGRQ.\n*  To use Z to update another matrix, use LAPACK subroutine DORMRQ.\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY\n      INTEGER            LOPT, LWKOPT, NB, NB1, NB2, NB3\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DGEQRF, DGERQF, DORMQR, XERBLA\n*     ..\n*     .. External Functions ..\n      INTEGER            ILAENV\n      EXTERNAL           ILAENV\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          INT, MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  taua, taub, work, info, a, b = NumRu::Lapack.dggqrf( n, 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_n = 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;
  }

  n = NUM2INT(rblapack_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);
  ldb = NA_SHAPE0(rblapack_b);
  p = 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 (!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);
  m = 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*);
  if (rblapack_lwork == Qnil)
    lwork = MAX(MAX(n,m),p);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(n,m);
    rblapack_taua = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  taua = NA_PTR_TYPE(rblapack_taua, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(n,p);
    rblapack_taub = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  taub = NA_PTR_TYPE(rblapack_taub, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = m;
    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__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = p;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dggqrf_(&n, &m, &p, a, &lda, taua, b, &ldb, taub, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_taua, rblapack_taub, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_dggqrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dggqrf", rblapack_dggqrf, -1);
}
ruby-lapack-1.7.2/ext/slaebz.c0000644000175000017500000004317112502221025016010 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaebz_(integer* ijob, integer* nitmax, integer* n, integer* mmax, integer* minp, integer* nbmin, real* abstol, real* reltol, real* pivmin, real* d, real* e, real* e2, integer* nval, real* ab, real* c, integer* mout, integer* nab, real* work, integer* iwork, integer* info);


static VALUE
rblapack_slaebz(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ijob;
  integer ijob; 
  VALUE rblapack_nitmax;
  integer nitmax; 
  VALUE rblapack_minp;
  integer minp; 
  VALUE rblapack_nbmin;
  integer nbmin; 
  VALUE rblapack_abstol;
  real abstol; 
  VALUE rblapack_reltol;
  real reltol; 
  VALUE rblapack_pivmin;
  real pivmin; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_e2;
  real *e2; 
  VALUE rblapack_nval;
  integer *nval; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_nab;
  integer *nab; 
  VALUE rblapack_mout;
  integer mout; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_nval_out__;
  integer *nval_out__;
  VALUE rblapack_ab_out__;
  real *ab_out__;
  VALUE rblapack_c_out__;
  real *c_out__;
  VALUE rblapack_nab_out__;
  integer *nab_out__;
  real *work;
  integer *iwork;

  integer n;
  integer mmax;

  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  mout, info, nval, ab, c, nab = NumRu::Lapack.slaebz( ijob, nitmax, minp, nbmin, abstol, reltol, pivmin, d, e, e2, nval, ab, c, nab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL, RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT, NAB, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLAEBZ contains the iteration loops which compute and use the\n*  function N(w), which is the count of eigenvalues of a symmetric\n*  tridiagonal matrix T less than or equal to its argument  w.  It\n*  performs a choice of two types of loops:\n*\n*  IJOB=1, followed by\n*  IJOB=2: It takes as input a list of intervals and returns a list of\n*          sufficiently small intervals whose union contains the same\n*          eigenvalues as the union of the original intervals.\n*          The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP.\n*          The output interval (AB(j,1),AB(j,2)] will contain\n*          eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT.\n*\n*  IJOB=3: It performs a binary search in each input interval\n*          (AB(j,1),AB(j,2)] for a point  w(j)  such that\n*          N(w(j))=NVAL(j), and uses  C(j)  as the starting point of\n*          the search.  If such a w(j) is found, then on output\n*          AB(j,1)=AB(j,2)=w.  If no such w(j) is found, then on output\n*          (AB(j,1),AB(j,2)] will be a small interval containing the\n*          point where N(w) jumps through NVAL(j), unless that point\n*          lies outside the initial interval.\n*\n*  Note that the intervals are in all cases half-open intervals,\n*  i.e., of the form  (a,b] , which includes  b  but not  a .\n*\n*  To avoid underflow, the matrix should be scaled so that its largest\n*  element is no greater than  overflow**(1/2) * underflow**(1/4)\n*  in absolute value.  To assure the most accurate computation\n*  of small eigenvalues, the matrix should be scaled to be\n*  not much smaller than that, either.\n*\n*  See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n*  Matrix\", Report CS41, Computer Science Dept., Stanford\n*  University, July 21, 1966\n*\n*  Note: the arguments are, in general, *not* checked for unreasonable\n*  values.\n*\n\n*  Arguments\n*  =========\n*\n*  IJOB    (input) INTEGER\n*          Specifies what is to be done:\n*          = 1:  Compute NAB for the initial intervals.\n*          = 2:  Perform bisection iteration to find eigenvalues of T.\n*          = 3:  Perform bisection iteration to invert N(w), i.e.,\n*                to find a point which has a specified number of\n*                eigenvalues of T to its left.\n*          Other values will cause SLAEBZ to return with INFO=-1.\n*\n*  NITMAX  (input) INTEGER\n*          The maximum number of \"levels\" of bisection to be\n*          performed, i.e., an interval of width W will not be made\n*          smaller than 2^(-NITMAX) * W.  If not all intervals\n*          have converged after NITMAX iterations, then INFO is set\n*          to the number of non-converged intervals.\n*\n*  N       (input) INTEGER\n*          The dimension n of the tridiagonal matrix T.  It must be at\n*          least 1.\n*\n*  MMAX    (input) INTEGER\n*          The maximum number of intervals.  If more than MMAX intervals\n*          are generated, then SLAEBZ will quit with INFO=MMAX+1.\n*\n*  MINP    (input) INTEGER\n*          The initial number of intervals.  It may not be greater than\n*          MMAX.\n*\n*  NBMIN   (input) INTEGER\n*          The smallest number of intervals that should be processed\n*          using a vector loop.  If zero, then only the scalar loop\n*          will be used.\n*\n*  ABSTOL  (input) REAL\n*          The minimum (absolute) width of an interval.  When an\n*          interval is narrower than ABSTOL, or than RELTOL times the\n*          larger (in magnitude) endpoint, then it is considered to be\n*          sufficiently small, i.e., converged.  This must be at least\n*          zero.\n*\n*  RELTOL  (input) REAL\n*          The minimum relative width of an interval.  When an interval\n*          is narrower than ABSTOL, or than RELTOL times the larger (in\n*          magnitude) endpoint, then it is considered to be\n*          sufficiently small, i.e., converged.  Note: this should\n*          always be at least radix*machine epsilon.\n*\n*  PIVMIN  (input) REAL\n*          The minimum absolute value of a \"pivot\" in the Sturm\n*          sequence loop.  This *must* be at least  max |e(j)**2| *\n*          safe_min  and at least safe_min, where safe_min is at least\n*          the smallest number that can divide one without overflow.\n*\n*  D       (input) REAL array, dimension (N)\n*          The diagonal elements of the tridiagonal matrix T.\n*\n*  E       (input) REAL array, dimension (N)\n*          The offdiagonal elements of the tridiagonal matrix T in\n*          positions 1 through N-1.  E(N) is arbitrary.\n*\n*  E2      (input) REAL array, dimension (N)\n*          The squares of the offdiagonal elements of the tridiagonal\n*          matrix T.  E2(N) is ignored.\n*\n*  NVAL    (input/output) INTEGER array, dimension (MINP)\n*          If IJOB=1 or 2, not referenced.\n*          If IJOB=3, the desired values of N(w).  The elements of NVAL\n*          will be reordered to correspond with the intervals in AB.\n*          Thus, NVAL(j) on output will not, in general be the same as\n*          NVAL(j) on input, but it will correspond with the interval\n*          (AB(j,1),AB(j,2)] on output.\n*\n*  AB      (input/output) REAL array, dimension (MMAX,2)\n*          The endpoints of the intervals.  AB(j,1) is  a(j), the left\n*          endpoint of the j-th interval, and AB(j,2) is b(j), the\n*          right endpoint of the j-th interval.  The input intervals\n*          will, in general, be modified, split, and reordered by the\n*          calculation.\n*\n*  C       (input/output) REAL array, dimension (MMAX)\n*          If IJOB=1, ignored.\n*          If IJOB=2, workspace.\n*          If IJOB=3, then on input C(j) should be initialized to the\n*          first search point in the binary search.\n*\n*  MOUT    (output) INTEGER\n*          If IJOB=1, the number of eigenvalues in the intervals.\n*          If IJOB=2 or 3, the number of intervals output.\n*          If IJOB=3, MOUT will equal MINP.\n*\n*  NAB     (input/output) INTEGER array, dimension (MMAX,2)\n*          If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)).\n*          If IJOB=2, then on input, NAB(i,j) should be set.  It must\n*             satisfy the condition:\n*             N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)),\n*             which means that in interval i only eigenvalues\n*             NAB(i,1)+1,...,NAB(i,2) will be considered.  Usually,\n*             NAB(i,j)=N(AB(i,j)), from a previous call to SLAEBZ with\n*             IJOB=1.\n*             On output, NAB(i,j) will contain\n*             max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of\n*             the input interval that the output interval\n*             (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the\n*             the input values of NAB(k,1) and NAB(k,2).\n*          If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)),\n*             unless N(w) > NVAL(i) for all search points  w , in which\n*             case NAB(i,1) will not be modified, i.e., the output\n*             value will be the same as the input value (modulo\n*             reorderings -- see NVAL and AB), or unless N(w) < NVAL(i)\n*             for all search points  w , in which case NAB(i,2) will\n*             not be modified.  Normally, NAB should be set to some\n*             distinctive value(s) before SLAEBZ is called.\n*\n*  WORK    (workspace) REAL array, dimension (MMAX)\n*          Workspace.\n*\n*  IWORK   (workspace) INTEGER array, dimension (MMAX)\n*          Workspace.\n*\n*  INFO    (output) INTEGER\n*          = 0:       All intervals converged.\n*          = 1--MMAX: The last INFO intervals did not converge.\n*          = MMAX+1:  More than MMAX intervals were generated.\n*\n\n*  Further Details\n*  ===============\n*\n*      This routine is intended to be called only by other LAPACK\n*  routines, thus the interface is less user-friendly.  It is intended\n*  for two purposes:\n*\n*  (a) finding eigenvalues.  In this case, SLAEBZ should have one or\n*      more initial intervals set up in AB, and SLAEBZ should be called\n*      with IJOB=1.  This sets up NAB, and also counts the eigenvalues.\n*      Intervals with no eigenvalues would usually be thrown out at\n*      this point.  Also, if not all the eigenvalues in an interval i\n*      are desired, NAB(i,1) can be increased or NAB(i,2) decreased.\n*      For example, set NAB(i,1)=NAB(i,2)-1 to get the largest\n*      eigenvalue.  SLAEBZ is then called with IJOB=2 and MMAX\n*      no smaller than the value of MOUT returned by the call with\n*      IJOB=1.  After this (IJOB=2) call, eigenvalues NAB(i,1)+1\n*      through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the\n*      tolerance specified by ABSTOL and RELTOL.\n*\n*  (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l).\n*      In this case, start with a Gershgorin interval  (a,b).  Set up\n*      AB to contain 2 search intervals, both initially (a,b).  One\n*      NVAL element should contain  f-1  and the other should contain  l\n*      , while C should contain a and b, resp.  NAB(i,1) should be -1\n*      and NAB(i,2) should be N+1, to flag an error if the desired\n*      interval does not lie in (a,b).  SLAEBZ is then called with\n*      IJOB=3.  On exit, if w(f-1) < w(f), then one of the intervals --\n*      j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while\n*      if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r\n*      >= 0, then the interval will have  N(AB(j,1))=NAB(j,1)=f-k and\n*      N(AB(j,2))=NAB(j,2)=f+r.  The cases w(l) < w(l+1) and\n*      w(l-r)=...=w(l+k) are handled similarly.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  mout, info, nval, ab, c, nab = NumRu::Lapack.slaebz( ijob, nitmax, minp, nbmin, abstol, reltol, pivmin, d, e, e2, nval, ab, c, nab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 14 && argc != 14)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 14)", argc);
  rblapack_ijob = argv[0];
  rblapack_nitmax = argv[1];
  rblapack_minp = argv[2];
  rblapack_nbmin = argv[3];
  rblapack_abstol = argv[4];
  rblapack_reltol = argv[5];
  rblapack_pivmin = argv[6];
  rblapack_d = argv[7];
  rblapack_e = argv[8];
  rblapack_e2 = argv[9];
  rblapack_nval = argv[10];
  rblapack_ab = argv[11];
  rblapack_c = argv[12];
  rblapack_nab = argv[13];
  if (argc == 14) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  ijob = NUM2INT(rblapack_ijob);
  minp = NUM2INT(rblapack_minp);
  abstol = (real)NUM2DBL(rblapack_abstol);
  pivmin = (real)NUM2DBL(rblapack_pivmin);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (9th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (9th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_e);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  if (!NA_IsNArray(rblapack_nval))
    rb_raise(rb_eArgError, "nval (11th argument) must be NArray");
  if (NA_RANK(rblapack_nval) != 1)
    rb_raise(rb_eArgError, "rank of nval (11th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_nval) != ((ijob==1||ijob==2) ? 0 : ijob==3 ? minp : 0))
    rb_raise(rb_eRuntimeError, "shape 0 of nval must be %d", (ijob==1||ijob==2) ? 0 : ijob==3 ? minp : 0);
  if (NA_TYPE(rblapack_nval) != NA_LINT)
    rblapack_nval = na_change_type(rblapack_nval, NA_LINT);
  nval = NA_PTR_TYPE(rblapack_nval, integer*);
  if (!NA_IsNArray(rblapack_nab))
    rb_raise(rb_eArgError, "nab (14th argument) must be NArray");
  if (NA_RANK(rblapack_nab) != 2)
    rb_raise(rb_eArgError, "rank of nab (14th argument) must be %d", 2);
  mmax = NA_SHAPE0(rblapack_nab);
  if (NA_SHAPE1(rblapack_nab) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of nab must be %d", 2);
  if (NA_TYPE(rblapack_nab) != NA_LINT)
    rblapack_nab = na_change_type(rblapack_nab, NA_LINT);
  nab = NA_PTR_TYPE(rblapack_nab, integer*);
  nitmax = NUM2INT(rblapack_nitmax);
  reltol = (real)NUM2DBL(rblapack_reltol);
  if (!NA_IsNArray(rblapack_e2))
    rb_raise(rb_eArgError, "e2 (10th argument) must be NArray");
  if (NA_RANK(rblapack_e2) != 1)
    rb_raise(rb_eArgError, "rank of e2 (10th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e2) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of e2 must be the same as shape 0 of e");
  if (NA_TYPE(rblapack_e2) != NA_SFLOAT)
    rblapack_e2 = na_change_type(rblapack_e2, NA_SFLOAT);
  e2 = NA_PTR_TYPE(rblapack_e2, real*);
  nbmin = NUM2INT(rblapack_nbmin);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (12th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (12th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_ab) != mmax)
    rb_raise(rb_eRuntimeError, "shape 0 of ab must be the same as shape 0 of nab");
  if (NA_SHAPE1(rblapack_ab) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be %d", 2);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (8th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of e");
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (13th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (13th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != (ijob==1 ? 0 : (ijob==2||ijob==3) ? mmax : 0))
    rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", ijob==1 ? 0 : (ijob==2||ijob==3) ? mmax : 0);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  {
    na_shape_t shape[1];
    shape[0] = (ijob==1||ijob==2) ? 0 : ijob==3 ? minp : 0;
    rblapack_nval_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  nval_out__ = NA_PTR_TYPE(rblapack_nval_out__, integer*);
  MEMCPY(nval_out__, nval, integer, NA_TOTAL(rblapack_nval));
  rblapack_nval = rblapack_nval_out__;
  nval = nval_out__;
  {
    na_shape_t shape[2];
    shape[0] = mmax;
    shape[1] = 2;
    rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
  MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[1];
    shape[0] = ijob==1 ? 0 : (ijob==2||ijob==3) ? mmax : 0;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[2];
    shape[0] = mmax;
    shape[1] = 2;
    rblapack_nab_out__ = na_make_object(NA_LINT, 2, shape, cNArray);
  }
  nab_out__ = NA_PTR_TYPE(rblapack_nab_out__, integer*);
  MEMCPY(nab_out__, nab, integer, NA_TOTAL(rblapack_nab));
  rblapack_nab = rblapack_nab_out__;
  nab = nab_out__;
  work = ALLOC_N(real, (mmax));
  iwork = ALLOC_N(integer, (mmax));

  slaebz_(&ijob, &nitmax, &n, &mmax, &minp, &nbmin, &abstol, &reltol, &pivmin, d, e, e2, nval, ab, c, &mout, nab, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_mout = INT2NUM(mout);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_mout, rblapack_info, rblapack_nval, rblapack_ab, rblapack_c, rblapack_nab);
}

void
init_lapack_slaebz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaebz", rblapack_slaebz, -1);
}
ruby-lapack-1.7.2/ext/claqr1.c0000644000175000017500000000675012502221013015712 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID claqr1_(integer* n, complex* h, integer* ldh, complex* s1, complex* s2, complex* v);


static VALUE
rblapack_claqr1(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_h;
  complex *h; 
  VALUE rblapack_s1;
  complex s1; 
  VALUE rblapack_s2;
  complex s2; 
  VALUE rblapack_v;
  complex *v; 

  integer ldh;
  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  v = NumRu::Lapack.claqr1( h, s1, s2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAQR1( N, H, LDH, S1, S2, V )\n\n*       Given a 2-by-2 or 3-by-3 matrix H, CLAQR1 sets v to a\n*       scalar multiple of the first column of the product\n*\n*       (*)  K = (H - s1*I)*(H - s2*I)\n*\n*       scaling to avoid overflows and most underflows.\n*\n*       This is useful for starting double implicit shift bulges\n*       in the QR algorithm.\n*\n*\n\n*       N      (input) integer\n*              Order of the matrix H. N must be either 2 or 3.\n*\n*       H      (input) COMPLEX array of dimension (LDH,N)\n*              The 2-by-2 or 3-by-3 matrix H in (*).\n*\n*       LDH    (input) integer\n*              The leading dimension of H as declared in\n*              the calling procedure.  LDH.GE.N\n*\n*       S1     (input) COMPLEX\n*       S2     S1 and S2 are the shifts defining K in (*) above.\n*\n*       V      (output) COMPLEX array of dimension N\n*              A scalar multiple of the first column of the\n*              matrix K in (*).\n*\n\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  v = NumRu::Lapack.claqr1( h, s1, s2, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_h = argv[0];
  rblapack_s1 = argv[1];
  rblapack_s2 = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (1th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (1th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_SCOMPLEX)
    rblapack_h = na_change_type(rblapack_h, NA_SCOMPLEX);
  h = NA_PTR_TYPE(rblapack_h, complex*);
  s2.r = (real)NUM2DBL(rb_funcall(rblapack_s2, rb_intern("real"), 0));
  s2.i = (real)NUM2DBL(rb_funcall(rblapack_s2, rb_intern("imag"), 0));
  s1.r = (real)NUM2DBL(rb_funcall(rblapack_s1, rb_intern("real"), 0));
  s1.i = (real)NUM2DBL(rb_funcall(rblapack_s1, rb_intern("imag"), 0));
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_v = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  v = NA_PTR_TYPE(rblapack_v, complex*);

  claqr1_(&n, h, &ldh, &s1, &s2, v);

  return rblapack_v;
}

void
init_lapack_claqr1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "claqr1", rblapack_claqr1, -1);
}
ruby-lapack-1.7.2/ext/zgeql2.c0000644000175000017500000001062712502221024015733 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgeql2_(integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* info);


static VALUE
rblapack_zgeql2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  doublecomplex *work;

  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, info, a = NumRu::Lapack.zgeql2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGEQL2( M, N, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGEQL2 computes a QL factorization of a complex m by n matrix A:\n*  A = Q * L.\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) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the m by n matrix A.\n*          On exit, if m >= n, the lower triangle of the subarray\n*          A(m-n+1:m,1:n) contains the n by n lower triangular matrix L;\n*          if m <= n, the elements on and below the (n-m)-th\n*          superdiagonal contain the m by n lower trapezoidal matrix L;\n*          the remaining elements, with the array TAU, represent the\n*          unitary matrix Q as a product of elementary reflectors\n*          (see Further Details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  TAU     (output) COMPLEX*16 array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (N)\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 complex scalar, and v is a complex vector with\n*  v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n*  A(1:m-k+i-1,n-k+i), 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.zgeql2( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(doublecomplex, (n));

  zgeql2_(&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_zgeql2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgeql2", rblapack_zgeql2, -1);
}
ruby-lapack-1.7.2/ext/zla_gbrpvgrw.c0000644000175000017500000001206412502221024017232 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal zla_gbrpvgrw_(integer* n, integer* kl, integer* ku, integer* ncols, doublecomplex* ab, integer* ldab, doublecomplex* afb, integer* ldafb);


static VALUE
rblapack_zla_gbrpvgrw(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ncols;
  integer ncols; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_afb;
  doublecomplex *afb; 
  VALUE rblapack___out__;
  doublereal __out__; 

  integer ldab;
  integer n;
  integer ldafb;

  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  __out__ = NumRu::Lapack.zla_gbrpvgrw( kl, ku, ncols, ab, afb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION ZLA_GBRPVGRW( N, KL, KU, NCOLS, AB, LDAB, AFB, LDAFB )\n\n*  Purpose\n*  =======\n*\n*  ZLA_GBRPVGRW computes the reciprocal pivot growth factor\n*  norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n*  much less than 1, the stability of the LU factorization of the\n*  (equilibrated) matrix A could be poor. This also means that the\n*  solution X, estimated condition numbers, and error bounds could be\n*  unreliable.\n*\n\n*  Arguments\n*  =========\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     KL      (input) INTEGER\n*     The number of subdiagonals within the band of A.  KL >= 0.\n*\n*     KU      (input) INTEGER\n*     The number of superdiagonals within the band of A.  KU >= 0.\n*\n*     NCOLS   (input) INTEGER\n*     The number of columns of the matrix A.  NCOLS >= 0.\n*\n*     AB      (input) COMPLEX*16 array, dimension (LDAB,N)\n*     On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n*     The j-th column of A is stored in the j-th column of the\n*     array AB as follows:\n*     AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n*     LDAB    (input) INTEGER\n*     The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*     AFB     (input) COMPLEX*16 array, dimension (LDAFB,N)\n*     Details of the LU factorization of the band matrix A, as\n*     computed by ZGBTRF.  U is stored as an upper triangular\n*     band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n*     and the multipliers used during the factorization are stored\n*     in rows KL+KU+2 to 2*KL+KU+1.\n*\n*     LDAFB   (input) INTEGER\n*     The leading dimension of the array AFB.  LDAFB >= 2*KL+KU+1.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J, KD\n      DOUBLE PRECISION   AMAX, UMAX, RPVGRW\n      COMPLEX*16         ZDUM\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX, MIN, REAL, DIMAG\n*     ..\n*     .. Statement Functions ..\n      DOUBLE PRECISION   CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.zla_gbrpvgrw( kl, ku, ncols, ab, afb, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_kl = argv[0];
  rblapack_ku = argv[1];
  rblapack_ncols = argv[2];
  rblapack_ab = argv[3];
  rblapack_afb = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  kl = NUM2INT(rblapack_kl);
  ncols = NUM2INT(rblapack_ncols);
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
  ldafb = NA_SHAPE0(rblapack_afb);
  n = NA_SHAPE1(rblapack_afb);
  if (NA_TYPE(rblapack_afb) != NA_DCOMPLEX)
    rblapack_afb = na_change_type(rblapack_afb, NA_DCOMPLEX);
  afb = NA_PTR_TYPE(rblapack_afb, doublecomplex*);
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);

  __out__ = zla_gbrpvgrw_(&n, &kl, &ku, &ncols, ab, &ldab, afb, &ldafb);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_zla_gbrpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zla_gbrpvgrw", rblapack_zla_gbrpvgrw, -1);
}
ruby-lapack-1.7.2/ext/sgbsvx.c0000644000175000017500000005223712502221022016044 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgbsvx_(char* fact, char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, real* ab, integer* ldab, real* afb, integer* ldafb, integer* ipiv, char* equed, real* r, real* c, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* ferr, real* berr, real* work, integer* iwork, integer* info);


static VALUE
rblapack_sgbsvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_afb;
  real *afb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_r;
  real *r; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  real *ab_out__;
  VALUE rblapack_afb_out__;
  real *afb_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  VALUE rblapack_r_out__;
  real *r_out__;
  VALUE rblapack_c_out__;
  real *c_out__;
  VALUE rblapack_b_out__;
  real *b_out__;
  integer *iwork;

  integer ldab;
  integer n;
  integer ldb;
  integer nrhs;
  integer ldafb;
  integer ldx;

  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  x, rcond, ferr, berr, work, info, ab, afb, ipiv, equed, r, c, b = NumRu::Lapack.sgbsvx( fact, trans, kl, ku, ab, b, [:afb => afb, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGBSVX uses the LU factorization to compute the solution to a real\n*  system of linear equations A * X = B, A**T * X = B, or A**H * X = B,\n*  where A is a band matrix of order N with KL subdiagonals and KU\n*  superdiagonals, and X and B are N-by-NRHS matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed by this subroutine:\n*\n*  1. If FACT = 'E', real scaling factors are computed to equilibrate\n*     the system:\n*        TRANS = 'N':  diag(R)*A*diag(C)     *inv(diag(C))*X = diag(R)*B\n*        TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n*        TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n*     or diag(C)*B (if TRANS = 'T' or 'C').\n*\n*  2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n*     matrix A (after equilibration if FACT = 'E') as\n*        A = L * U,\n*     where L is a product of permutation and unit lower triangular\n*     matrices with KL subdiagonals, and U is upper triangular with\n*     KL+KU superdiagonals.\n*\n*  3. If some U(i,i)=0, so that U is exactly singular, then the routine\n*     returns with INFO = i. Otherwise, the factored form of A is used\n*     to estimate the condition number of the matrix A.  If the\n*     reciprocal of the condition number is less than machine precision,\n*     INFO = N+1 is returned as a warning, but the routine still goes on\n*     to solve for X and compute error bounds as described below.\n*\n*  4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  5. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n*  6. If equilibration was used, the matrix X is premultiplied by\n*     diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n*     that it solves the original system before equilibration.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of the matrix A is\n*          supplied on entry, and if not, whether the matrix A should be\n*          equilibrated before it is factored.\n*          = 'F':  On entry, AFB and IPIV contain the factored form of\n*                  A.  If EQUED is not 'N', the matrix A has been\n*                  equilibrated with scaling factors given by R and C.\n*                  AB, AFB, and IPIV are not modified.\n*          = 'N':  The matrix A will be copied to AFB and factored.\n*          = 'E':  The matrix A will be equilibrated if necessary, then\n*                  copied to AFB and factored.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations.\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Transpose)\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AB      (input/output) REAL array, dimension (LDAB,N)\n*          On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n*          The j-th column of A is stored in the j-th column of the\n*          array AB as follows:\n*          AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n*          If FACT = 'F' and EQUED is not 'N', then A must have been\n*          equilibrated by the scaling factors in R and/or C.  AB is not\n*          modified if FACT = 'F' or 'N', or if FACT = 'E' and\n*          EQUED = 'N' on exit.\n*\n*          On exit, if EQUED .ne. 'N', A is scaled as follows:\n*          EQUED = 'R':  A := diag(R) * A\n*          EQUED = 'C':  A := A * diag(C)\n*          EQUED = 'B':  A := diag(R) * A * diag(C).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*  AFB     (input or output) REAL array, dimension (LDAFB,N)\n*          If FACT = 'F', then AFB is an input argument and on entry\n*          contains details of the LU factorization of the band matrix\n*          A, as computed by SGBTRF.  U is stored as an upper triangular\n*          band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n*          and the multipliers used during the factorization are stored\n*          in rows KL+KU+2 to 2*KL+KU+1.  If EQUED .ne. 'N', then AFB is\n*          the factored form of the equilibrated matrix A.\n*\n*          If FACT = 'N', then AFB is an output argument and on exit\n*          returns details of the LU factorization of A.\n*\n*          If FACT = 'E', then AFB is an output argument and on exit\n*          returns details of the LU factorization of the equilibrated\n*          matrix A (see the description of AB for the form of the\n*          equilibrated matrix).\n*\n*  LDAFB   (input) INTEGER\n*          The leading dimension of the array AFB.  LDAFB >= 2*KL+KU+1.\n*\n*  IPIV    (input or output) INTEGER array, dimension (N)\n*          If FACT = 'F', then IPIV is an input argument and on entry\n*          contains the pivot indices from the factorization A = L*U\n*          as computed by SGBTRF; row i of the matrix was interchanged\n*          with row IPIV(i).\n*\n*          If FACT = 'N', then IPIV is an output argument and on exit\n*          contains the pivot indices from the factorization A = L*U\n*          of the original matrix A.\n*\n*          If FACT = 'E', then IPIV is an output argument and on exit\n*          contains the pivot indices from the factorization A = L*U\n*          of the equilibrated matrix A.\n*\n*  EQUED   (input or output) CHARACTER*1\n*          Specifies the form of equilibration that was done.\n*          = 'N':  No equilibration (always true if FACT = 'N').\n*          = 'R':  Row equilibration, i.e., A has been premultiplied by\n*                  diag(R).\n*          = 'C':  Column equilibration, i.e., A has been postmultiplied\n*                  by diag(C).\n*          = 'B':  Both row and column equilibration, i.e., A has been\n*                  replaced by diag(R) * A * diag(C).\n*          EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*          output argument.\n*\n*  R       (input or output) REAL array, dimension (N)\n*          The row scale factors for A.  If EQUED = 'R' or 'B', A is\n*          multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n*          is not accessed.  R is an input argument if FACT = 'F';\n*          otherwise, R is an output argument.  If FACT = 'F' and\n*          EQUED = 'R' or 'B', each element of R must be positive.\n*\n*  C       (input or output) REAL array, dimension (N)\n*          The column scale factors for A.  If EQUED = 'C' or 'B', A is\n*          multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n*          is not accessed.  C is an input argument if FACT = 'F';\n*          otherwise, C is an output argument.  If FACT = 'F' and\n*          EQUED = 'C' or 'B', each element of C must be positive.\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit,\n*          if EQUED = 'N', B is not modified;\n*          if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n*          diag(R)*B;\n*          if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n*          overwritten by diag(C)*B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) REAL array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n*          to the original system of equations.  Note that A and B are\n*          modified on exit if EQUED .ne. 'N', and the solution to the\n*          equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n*          EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n*          and EQUED = 'R' or 'B'.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) REAL\n*          The estimate of the reciprocal condition number of the matrix\n*          A after equilibration (if done).  If RCOND is less than the\n*          machine precision (in particular, if RCOND = 0), the matrix\n*          is singular to working precision.  This condition is\n*          indicated by a return code of INFO > 0.\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace/output) REAL array, dimension (3*N)\n*          On exit, WORK(1) contains the reciprocal pivot growth\n*          factor norm(A)/norm(U). The \"max absolute element\" norm is\n*          used. If WORK(1) is much less than 1, then the stability\n*          of the LU factorization of the (equilibrated) matrix A\n*          could be poor. This also means that the solution X, condition\n*          estimator RCOND, and forward error bound FERR could be\n*          unreliable. If factorization fails with 0 0:  if INFO = i, and i is\n*                <= N:  U(i,i) is exactly zero.  The factorization\n*                       has been completed, but the factor U is exactly\n*                       singular, so the solution and error bounds\n*                       could not be computed. RCOND = 0 is returned.\n*                = N+1: U is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*\n*                       value of RCOND would suggest.\n\n*  =====================================================================\n*  Moved setting of INFO = N+1 so INFO does not subsequently get\n*  overwritten.  Sven, 17 Mar 05. \n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, work, info, ab, afb, ipiv, equed, r, c, b = NumRu::Lapack.sgbsvx( fact, trans, kl, ku, ab, b, [:afb => afb, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 11)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_fact = argv[0];
  rblapack_trans = argv[1];
  rblapack_kl = argv[2];
  rblapack_ku = argv[3];
  rblapack_ab = argv[4];
  rblapack_b = argv[5];
  if (argc == 11) {
    rblapack_afb = argv[6];
    rblapack_ipiv = argv[7];
    rblapack_equed = argv[8];
    rblapack_r = argv[9];
    rblapack_c = argv[10];
  } else if (rblapack_options != Qnil) {
    rblapack_afb = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("afb")));
    rblapack_ipiv = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("ipiv")));
    rblapack_equed = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("equed")));
    rblapack_r = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("r")));
    rblapack_c = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("c")));
  } else {
    rblapack_afb = Qnil;
    rblapack_ipiv = Qnil;
    rblapack_equed = Qnil;
    rblapack_r = Qnil;
    rblapack_c = Qnil;
  }

  fact = StringValueCStr(rblapack_fact)[0];
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  if (rblapack_ipiv != Qnil) {
    if (!NA_IsNArray(rblapack_ipiv))
      rb_raise(rb_eArgError, "ipiv (option) must be NArray");
    if (NA_RANK(rblapack_ipiv) != 1)
      rb_raise(rb_eArgError, "rank of ipiv (option) must be %d", 1);
    if (NA_SHAPE0(rblapack_ipiv) != n)
      rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of ab");
    if (NA_TYPE(rblapack_ipiv) != NA_LINT)
      rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
    ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  }
  if (rblapack_r != Qnil) {
    if (!NA_IsNArray(rblapack_r))
      rb_raise(rb_eArgError, "r (option) must be NArray");
    if (NA_RANK(rblapack_r) != 1)
      rb_raise(rb_eArgError, "rank of r (option) must be %d", 1);
    if (NA_SHAPE0(rblapack_r) != n)
      rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of ab");
    if (NA_TYPE(rblapack_r) != NA_SFLOAT)
      rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
    r = NA_PTR_TYPE(rblapack_r, real*);
  }
  ldx = n;
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (rblapack_equed != Qnil) {
  equed = StringValueCStr(rblapack_equed)[0];
  }
  ku = NUM2INT(rblapack_ku);
  if (rblapack_c != Qnil) {
    if (!NA_IsNArray(rblapack_c))
      rb_raise(rb_eArgError, "c (option) must be NArray");
    if (NA_RANK(rblapack_c) != 1)
      rb_raise(rb_eArgError, "rank of c (option) must be %d", 1);
    if (NA_SHAPE0(rblapack_c) != n)
      rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
    if (NA_TYPE(rblapack_c) != NA_SFLOAT)
      rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
    c = NA_PTR_TYPE(rblapack_c, real*);
  }
  ldafb = 2*kl+ku+1;
  if (rblapack_afb != Qnil) {
    if (!NA_IsNArray(rblapack_afb))
      rb_raise(rb_eArgError, "afb (option) must be NArray");
    if (NA_RANK(rblapack_afb) != 2)
      rb_raise(rb_eArgError, "rank of afb (option) must be %d", 2);
    if (NA_SHAPE0(rblapack_afb) != ldafb)
      rb_raise(rb_eRuntimeError, "shape 0 of afb must be 2*kl+ku+1");
    if (NA_SHAPE1(rblapack_afb) != n)
      rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
    if (NA_TYPE(rblapack_afb) != NA_SFLOAT)
      rblapack_afb = na_change_type(rblapack_afb, NA_SFLOAT);
    afb = NA_PTR_TYPE(rblapack_afb, real*);
  }
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[1];
    shape[0] = 3*n;
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
  MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldafb;
    shape[1] = n;
    rblapack_afb_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  afb_out__ = NA_PTR_TYPE(rblapack_afb_out__, real*);
  if (rblapack_afb != Qnil) {
    MEMCPY(afb_out__, afb, real, NA_TOTAL(rblapack_afb));
  }
  rblapack_afb = rblapack_afb_out__;
  afb = afb_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  if (rblapack_ipiv != Qnil) {
    MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  }
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_r_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  r_out__ = NA_PTR_TYPE(rblapack_r_out__, real*);
  if (rblapack_r != Qnil) {
    MEMCPY(r_out__, r, real, NA_TOTAL(rblapack_r));
  }
  rblapack_r = rblapack_r_out__;
  r = r_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  if (rblapack_c != Qnil) {
    MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  }
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  iwork = ALLOC_N(integer, (n));

  sgbsvx_(&fact, &trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);

  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(13, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_work, rblapack_info, rblapack_ab, rblapack_afb, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b);
}

void
init_lapack_sgbsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgbsvx", rblapack_sgbsvx, -1);
}
ruby-lapack-1.7.2/ext/sgels.c0000644000175000017500000002101212502221020015626 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgels_(char* trans, integer* m, integer* n, integer* nrhs, real* a, integer* lda, real* b, integer* ldb, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sgels(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_b_out__;
  real *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.sgels( trans, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGELS 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) REAL 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 SGEQRF;\n*            if M <  N, A is overwritten by details of its LQ\n*                       factorization as returned by SGELQF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  B       (input/output) REAL 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) REAL 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.sgels( 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;
  }

  trans = StringValueCStr(rblapack_trans)[0];
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  m = lda;
  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_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  ldb = MAX(m,n);
  if (rblapack_lwork == Qnil)
    lwork = MIN(m,n) + MAX(MIN(m,n),nrhs);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = MAX(m, n);
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  {
    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__;

  sgels_(&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_sgels(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgels", rblapack_sgels, -1);
}
ruby-lapack-1.7.2/ext/zlartg.c0000644000175000017500000000644512502221013016033 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlartg_(doublecomplex* f, doublecomplex* g, doublereal* cs, doublecomplex* sn, doublecomplex* r);


static VALUE
rblapack_zlartg(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_f;
  doublecomplex f; 
  VALUE rblapack_g;
  doublecomplex g; 
  VALUE rblapack_cs;
  doublereal cs; 
  VALUE rblapack_sn;
  doublecomplex sn; 
  VALUE rblapack_r;
  doublecomplex r; 


  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  cs, sn, r = NumRu::Lapack.zlartg( f, g, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLARTG( F, G, CS, SN, R )\n\n*  Purpose\n*  =======\n*\n*  ZLARTG generates a plane rotation so that\n*\n*     [  CS  SN  ]     [ F ]     [ R ]\n*     [  __      ]  .  [   ]  =  [   ]   where CS**2 + |SN|**2 = 1.\n*     [ -SN  CS  ]     [ G ]     [ 0 ]\n*\n*  This is a faster version of the BLAS1 routine ZROTG, except for\n*  the following differences:\n*     F and G are unchanged on return.\n*     If G=0, then CS=1 and SN=0.\n*     If F=0, then CS=0 and SN is chosen so that R is real.\n*\n\n*  Arguments\n*  =========\n*\n*  F       (input) COMPLEX*16\n*          The first component of vector to be rotated.\n*\n*  G       (input) COMPLEX*16\n*          The second component of vector to be rotated.\n*\n*  CS      (output) DOUBLE PRECISION\n*          The cosine of the rotation.\n*\n*  SN      (output) COMPLEX*16\n*          The sine of the rotation.\n*\n*  R       (output) COMPLEX*16\n*          The nonzero component of the rotated vector.\n*\n\n*  Further Details\n*  ======= =======\n*\n*  3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel\n*\n*  This version has a few statements commented out for thread safety\n*  (machine parameters are computed on each entry). 10 feb 03, SJH.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  cs, sn, r = NumRu::Lapack.zlartg( f, g, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_f = argv[0];
  rblapack_g = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  f.r = NUM2DBL(rb_funcall(rblapack_f, rb_intern("real"), 0));
  f.i = NUM2DBL(rb_funcall(rblapack_f, rb_intern("imag"), 0));
  g.r = NUM2DBL(rb_funcall(rblapack_g, rb_intern("real"), 0));
  g.i = NUM2DBL(rb_funcall(rblapack_g, rb_intern("imag"), 0));

  zlartg_(&f, &g, &cs, &sn, &r);

  rblapack_cs = rb_float_new((double)cs);
  rblapack_sn = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(sn.r)), rb_float_new((double)(sn.i)));
  rblapack_r = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(r.r)), rb_float_new((double)(r.i)));
  return rb_ary_new3(3, rblapack_cs, rblapack_sn, rblapack_r);
}

void
init_lapack_zlartg(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlartg", rblapack_zlartg, -1);
}
ruby-lapack-1.7.2/ext/zlatrz.c0000644000175000017500000001206212502221021016045 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlatrz_(integer* m, integer* n, integer* l, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work);


static VALUE
rblapack_zlatrz(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  doublecomplex *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, a = NumRu::Lapack.zlatrz( l, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLATRZ( M, N, L, A, LDA, TAU, WORK )\n\n*  Purpose\n*  =======\n*\n*  ZLATRZ factors the M-by-(M+L) complex upper trapezoidal matrix\n*  [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R  0 ) * Z by means\n*  of unitary transformations, where  Z is an (M+L)-by-(M+L) unitary\n*  matrix and, R and A1 are M-by-M upper triangular matrices.\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*  L       (input) INTEGER\n*          The number of columns of the matrix A containing the\n*          meaningful part of the Householder vectors. N-M >= L >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the leading M-by-N upper trapezoidal part of the\n*          array A must contain the matrix to be factorized.\n*          On exit, the leading M-by-M upper triangular part of A\n*          contains the upper triangular matrix R, and elements N-L+1 to\n*          N of the first M rows of A, with the array TAU, represent the\n*          unitary matrix Z as a product of M elementary reflectors.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  TAU     (output) COMPLEX*16 array, dimension (M)\n*          The scalar factors of the elementary reflectors.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (M)\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n*  The factorization is obtained by Householder's method.  The kth\n*  transformation matrix, Z( k ), which is used to introduce zeros into\n*  the ( m - k + 1 )th row of A, is given in the form\n*\n*     Z( k ) = ( I     0   ),\n*              ( 0  T( k ) )\n*\n*  where\n*\n*     T( k ) = I - tau*u( k )*u( k )',   u( k ) = (   1    ),\n*                                                 (   0    )\n*                                                 ( z( k ) )\n*\n*  tau is a scalar and z( k ) is an l element vector. tau and z( k )\n*  are chosen to annihilate the elements of the kth row of A2.\n*\n*  The scalar tau is returned in the kth element of TAU and the vector\n*  u( k ) in the kth row of A2, such that the elements of z( k ) are\n*  in  a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in\n*  the upper triangular part of A1.\n*\n*  Z is given by\n*\n*     Z =  Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, a = NumRu::Lapack.zlatrz( l, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_l = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  l = NUM2INT(rblapack_l);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  m = lda;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(doublecomplex, (m));

  zlatrz_(&m, &n, &l, a, &lda, tau, work);

  free(work);
  return rb_ary_new3(2, rblapack_tau, rblapack_a);
}

void
init_lapack_zlatrz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlatrz", rblapack_zlatrz, -1);
}
ruby-lapack-1.7.2/ext/zhseqr.c0000644000175000017500000003425612502221020016043 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhseqr_(char* job, char* compz, integer* n, integer* ilo, integer* ihi, doublecomplex* h, integer* ldh, doublecomplex* w, doublecomplex* z, integer* ldz, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zhseqr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_compz;
  char compz; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_h;
  doublecomplex *h; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_ldz;
  integer ldz; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_w;
  doublecomplex *w; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_h_out__;
  doublecomplex *h_out__;
  VALUE rblapack_z_out__;
  doublecomplex *z_out__;

  integer ldh;
  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  w, work, info, h, z = NumRu::Lapack.zhseqr( job, compz, ilo, ihi, h, z, ldz, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, WORK, LWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     ZHSEQR computes the eigenvalues of a Hessenberg matrix H\n*     and, optionally, the matrices T and Z from the Schur decomposition\n*     H = Z T Z**H, where T is an upper triangular matrix (the\n*     Schur form), and Z is the unitary matrix of Schur vectors.\n*\n*     Optionally Z may be postmultiplied into an input unitary\n*     matrix Q so that this routine can give the Schur factorization\n*     of a matrix A which has been reduced to the Hessenberg form H\n*     by the unitary matrix Q:  A = Q*H*Q**H = (QZ)*H*(QZ)**H.\n*\n\n*     Arguments\n*     =========\n*\n*     JOB   (input) CHARACTER*1\n*           = 'E':  compute eigenvalues only;\n*           = 'S':  compute eigenvalues and the Schur form T.\n*\n*     COMPZ (input) CHARACTER*1\n*           = 'N':  no Schur vectors are computed;\n*           = 'I':  Z is initialized to the unit matrix and the matrix Z\n*                   of Schur vectors of H is returned;\n*           = 'V':  Z must contain an unitary matrix Q on entry, and\n*                   the product Q*Z is returned.\n*\n*     N     (input) INTEGER\n*           The order of the matrix H.  N .GE. 0.\n*\n*     ILO   (input) INTEGER\n*     IHI   (input) INTEGER\n*           It is assumed that H is already upper triangular in rows\n*           and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n*           set by a previous call to ZGEBAL, and then passed to ZGEHRD\n*           when the matrix output by ZGEBAL is reduced to Hessenberg\n*           form. Otherwise ILO and IHI should be set to 1 and N\n*           respectively.  If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n*           If N = 0, then ILO = 1 and IHI = 0.\n*\n*     H     (input/output) COMPLEX*16 array, dimension (LDH,N)\n*           On entry, the upper Hessenberg matrix H.\n*           On exit, if INFO = 0 and JOB = 'S', H contains the upper\n*           triangular matrix T from the Schur decomposition (the\n*           Schur form). If INFO = 0 and JOB = 'E', the contents of\n*           H are unspecified on exit.  (The output value of H when\n*           INFO.GT.0 is given under the description of INFO below.)\n*\n*           Unlike earlier versions of ZHSEQR, this subroutine may\n*           explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1\n*           or j = IHI+1, IHI+2, ... N.\n*\n*     LDH   (input) INTEGER\n*           The leading dimension of the array H. LDH .GE. max(1,N).\n*\n*     W        (output) COMPLEX*16 array, dimension (N)\n*           The computed eigenvalues. If JOB = 'S', the eigenvalues are\n*           stored in the same order as on the diagonal of the Schur\n*           form returned in H, with W(i) = H(i,i).\n*\n*     Z     (input/output) COMPLEX*16 array, dimension (LDZ,N)\n*           If COMPZ = 'N', Z is not referenced.\n*           If COMPZ = 'I', on entry Z need not be set and on exit,\n*           if INFO = 0, Z contains the unitary matrix Z of the Schur\n*           vectors of H.  If COMPZ = 'V', on entry Z must contain an\n*           N-by-N matrix Q, which is assumed to be equal to the unit\n*           matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,\n*           if INFO = 0, Z contains Q*Z.\n*           Normally Q is the unitary matrix generated by ZUNGHR\n*           after the call to ZGEHRD which formed the Hessenberg matrix\n*           H. (The output value of Z when INFO.GT.0 is given under\n*           the description of INFO below.)\n*\n*     LDZ   (input) INTEGER\n*           The leading dimension of the array Z.  if COMPZ = 'I' or\n*           COMPZ = 'V', then LDZ.GE.MAX(1,N).  Otherwize, LDZ.GE.1.\n*\n*     WORK  (workspace/output) COMPLEX*16 array, dimension (LWORK)\n*           On exit, if INFO = 0, WORK(1) returns an estimate of\n*           the optimal value for LWORK.\n*\n*     LWORK (input) INTEGER\n*           The dimension of the array WORK.  LWORK .GE. max(1,N)\n*           is sufficient and delivers very good and sometimes\n*           optimal performance.  However, LWORK as large as 11*N\n*           may be required for optimal performance.  A workspace\n*           query is recommended to determine the optimal workspace\n*           size.\n*\n*           If LWORK = -1, then ZHSEQR does a workspace query.\n*           In this case, ZHSEQR checks the input parameters and\n*           estimates the optimal workspace size for the given\n*           values of N, ILO and IHI.  The estimate is returned\n*           in WORK(1).  No error message related to LWORK is\n*           issued by XERBLA.  Neither H nor Z are accessed.\n*\n*\n*     INFO  (output) INTEGER\n*             =  0:  successful exit\n*           .LT. 0:  if INFO = -i, the i-th argument had an illegal\n*                    value\n*           .GT. 0:  if INFO = i, ZHSEQR failed to compute all of\n*                the eigenvalues.  Elements 1:ilo-1 and i+1:n of WR\n*                and WI contain those eigenvalues which have been\n*                successfully computed.  (Failures are rare.)\n*\n*                If INFO .GT. 0 and JOB = 'E', then on exit, the\n*                remaining unconverged eigenvalues are the eigen-\n*                values of the upper Hessenberg matrix rows and\n*                columns ILO through INFO of the final, output\n*                value of H.\n*\n*                If INFO .GT. 0 and JOB   = 'S', then on exit\n*\n*           (*)  (initial value of H)*U  = U*(final value of H)\n*\n*                where U is a unitary matrix.  The final\n*                value of  H is upper Hessenberg and triangular in\n*                rows and columns INFO+1 through IHI.\n*\n*                If INFO .GT. 0 and COMPZ = 'V', then on exit\n*\n*                  (final value of Z)  =  (initial value of Z)*U\n*\n*                where U is the unitary matrix in (*) (regard-\n*                less of the value of JOB.)\n*\n*                If INFO .GT. 0 and COMPZ = 'I', then on exit\n*                      (final value of Z)  = U\n*                where U is the unitary matrix in (*) (regard-\n*                less of the value of JOB.)\n*\n*                If INFO .GT. 0 and COMPZ = 'N', then Z is not\n*                accessed.\n*\n\n*     ================================================================\n*             Default values supplied by\n*             ILAENV(ISPEC,'ZHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).\n*             It is suggested that these defaults be adjusted in order\n*             to attain best performance in each particular\n*             computational environment.\n*\n*            ISPEC=12: The ZLAHQR vs ZLAQR0 crossover point.\n*                      Default: 75. (Must be at least 11.)\n*\n*            ISPEC=13: Recommended deflation window size.\n*                      This depends on ILO, IHI and NS.  NS is the\n*                      number of simultaneous shifts returned\n*                      by ILAENV(ISPEC=15).  (See ISPEC=15 below.)\n*                      The default for (IHI-ILO+1).LE.500 is NS.\n*                      The default for (IHI-ILO+1).GT.500 is 3*NS/2.\n*\n*            ISPEC=14: Nibble crossover point. (See IPARMQ for\n*                      details.)  Default: 14% of deflation window\n*                      size.\n*\n*            ISPEC=15: Number of simultaneous shifts in a multishift\n*                      QR iteration.\n*\n*                      If IHI-ILO+1 is ...\n*\n*                      greater than      ...but less    ... the\n*                      or equal to ...      than        default is\n*\n*                           1               30          NS =   2(+)\n*                          30               60          NS =   4(+)\n*                          60              150          NS =  10(+)\n*                         150              590          NS =  **\n*                         590             3000          NS =  64\n*                        3000             6000          NS = 128\n*                        6000             infinity      NS = 256\n*\n*                  (+)  By default some or all matrices of this order\n*                       are passed to the implicit double shift routine\n*                       ZLAHQR and this parameter is ignored.  See\n*                       ISPEC=12 above and comments in IPARMQ for\n*                       details.\n*\n*                 (**)  The asterisks (**) indicate an ad-hoc\n*                       function of N increasing from 10 to 64.\n*\n*            ISPEC=16: Select structured matrix multiply.\n*                      If the number of simultaneous shifts (specified\n*                      by ISPEC=15) is less than 14, then the default\n*                      for ISPEC=16 is 0.  Otherwise the default for\n*                      ISPEC=16 is 2.\n*\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n*     References:\n*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n*       Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n*       Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n*       929--947, 2002.\n*\n*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n*       Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n*       of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n*     ================================================================\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, work, info, h, z = NumRu::Lapack.zhseqr( job, compz, ilo, ihi, h, z, ldz, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_job = argv[0];
  rblapack_compz = argv[1];
  rblapack_ilo = argv[2];
  rblapack_ihi = argv[3];
  rblapack_h = argv[4];
  rblapack_z = argv[5];
  rblapack_ldz = argv[6];
  if (argc == 8) {
    rblapack_lwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  job = StringValueCStr(rblapack_job)[0];
  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (5th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_DCOMPLEX)
    rblapack_h = na_change_type(rblapack_h, NA_DCOMPLEX);
  h = NA_PTR_TYPE(rblapack_h, doublecomplex*);
  ldz = NUM2INT(rblapack_ldz);
  compz = StringValueCStr(rblapack_compz)[0];
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (6th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (6th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_z) != (lsame_(&compz,"N") ? 0 : ldz))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", lsame_(&compz,"N") ? 0 : ldz);
  if (NA_SHAPE1(rblapack_z) != (lsame_(&compz,"N") ? 0 : n))
    rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", lsame_(&compz,"N") ? 0 : n);
  if (NA_TYPE(rblapack_z) != NA_DCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  ihi = NUM2INT(rblapack_ihi);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublecomplex*);
  MEMCPY(h_out__, h, doublecomplex, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = lsame_(&compz,"N") ? 0 : ldz;
    shape[1] = lsame_(&compz,"N") ? 0 : n;
    rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublecomplex*);
  MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  zhseqr_(&job, &compz, &n, &ilo, &ihi, h, &ldh, w, z, &ldz, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_w, rblapack_work, rblapack_info, rblapack_h, rblapack_z);
}

void
init_lapack_zhseqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhseqr", rblapack_zhseqr, -1);
}
ruby-lapack-1.7.2/ext/slasd7.c0000644000175000017500000003167412502221021015726 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slasd7_(integer* icompq, integer* nl, integer* nr, integer* sqre, integer* k, real* d, real* z, real* zw, real* vf, real* vfw, real* vl, real* vlw, real* alpha, real* beta, real* dsigma, integer* idx, integer* idxp, integer* idxq, integer* perm, integer* givptr, integer* givcol, integer* ldgcol, real* givnum, integer* ldgnum, real* c, real* s, integer* info);


static VALUE
rblapack_slasd7(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_icompq;
  integer icompq; 
  VALUE rblapack_nl;
  integer nl; 
  VALUE rblapack_nr;
  integer nr; 
  VALUE rblapack_sqre;
  integer sqre; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_vf;
  real *vf; 
  VALUE rblapack_vl;
  real *vl; 
  VALUE rblapack_alpha;
  real alpha; 
  VALUE rblapack_beta;
  real beta; 
  VALUE rblapack_idxq;
  integer *idxq; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_dsigma;
  real *dsigma; 
  VALUE rblapack_perm;
  integer *perm; 
  VALUE rblapack_givptr;
  integer givptr; 
  VALUE rblapack_givcol;
  integer *givcol; 
  VALUE rblapack_givnum;
  real *givnum; 
  VALUE rblapack_c;
  real c; 
  VALUE rblapack_s;
  real s; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_vf_out__;
  real *vf_out__;
  VALUE rblapack_vl_out__;
  real *vl_out__;
  real *zw;
  real *vfw;
  real *vlw;
  integer *idx;
  integer *idxp;

  integer n;
  integer m;
  integer ldgcol;
  integer ldgnum;

  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  k, z, dsigma, perm, givptr, givcol, givnum, c, s, info, d, vf, vl = NumRu::Lapack.slasd7( icompq, nl, nr, sqre, d, vf, vl, alpha, beta, idxq, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL, VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, C, S, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLASD7 merges the two sets of singular values together into a single\n*  sorted set. Then it tries to deflate the size of the problem. There\n*  are two ways in which deflation can occur:  when two or more singular\n*  values are close together or if there is a tiny entry in the Z\n*  vector. For each such occurrence the order of the related\n*  secular equation problem is reduced by one.\n*\n*  SLASD7 is called from SLASD6.\n*\n\n*  Arguments\n*  =========\n*\n*  ICOMPQ  (input) INTEGER\n*          Specifies whether singular vectors are to be computed\n*          in compact form, as follows:\n*          = 0: Compute singular values only.\n*          = 1: Compute singular vectors of upper\n*               bidiagonal matrix in compact form.\n*\n*  NL     (input) INTEGER\n*         The row dimension of the upper block. NL >= 1.\n*\n*  NR     (input) INTEGER\n*         The row dimension of the lower block. NR >= 1.\n*\n*  SQRE   (input) INTEGER\n*         = 0: the lower block is an NR-by-NR square matrix.\n*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n*         The bidiagonal matrix has\n*         N = NL + NR + 1 rows and\n*         M = N + SQRE >= N columns.\n*\n*  K      (output) INTEGER\n*         Contains the dimension of the non-deflated matrix, this is\n*         the order of the related secular equation. 1 <= K <=N.\n*\n*  D      (input/output) REAL array, dimension ( N )\n*         On entry D contains the singular values of the two submatrices\n*         to be combined. On exit D contains the trailing (N-K) updated\n*         singular values (those which were deflated) sorted into\n*         increasing order.\n*\n*  Z      (output) REAL array, dimension ( M )\n*         On exit Z contains the updating row vector in the secular\n*         equation.\n*\n*  ZW     (workspace) REAL array, dimension ( M )\n*         Workspace for Z.\n*\n*  VF     (input/output) REAL array, dimension ( M )\n*         On entry, VF(1:NL+1) contains the first components of all\n*         right singular vectors of the upper block; and VF(NL+2:M)\n*         contains the first components of all right singular vectors\n*         of the lower block. On exit, VF contains the first components\n*         of all right singular vectors of the bidiagonal matrix.\n*\n*  VFW    (workspace) REAL array, dimension ( M )\n*         Workspace for VF.\n*\n*  VL     (input/output) REAL array, dimension ( M )\n*         On entry, VL(1:NL+1) contains the  last components of all\n*         right singular vectors of the upper block; and VL(NL+2:M)\n*         contains the last components of all right singular vectors\n*         of the lower block. On exit, VL contains the last components\n*         of all right singular vectors of the bidiagonal matrix.\n*\n*  VLW    (workspace) REAL array, dimension ( M )\n*         Workspace for VL.\n*\n*  ALPHA  (input) REAL\n*         Contains the diagonal element associated with the added row.\n*\n*  BETA   (input) REAL\n*         Contains the off-diagonal element associated with the added\n*         row.\n*\n*  DSIGMA (output) REAL array, dimension ( N )\n*         Contains a copy of the diagonal elements (K-1 singular values\n*         and one zero) in the secular equation.\n*\n*  IDX    (workspace) INTEGER array, dimension ( N )\n*         This will contain the permutation used to sort the contents of\n*         D into ascending order.\n*\n*  IDXP   (workspace) INTEGER array, dimension ( N )\n*         This will contain the permutation used to place deflated\n*         values of D at the end of the array. On output IDXP(2:K)\n*         points to the nondeflated D-values and IDXP(K+1:N)\n*         points to the deflated singular values.\n*\n*  IDXQ   (input) INTEGER array, dimension ( N )\n*         This contains the permutation which separately sorts the two\n*         sub-problems in D into ascending order.  Note that entries in\n*         the first half of this permutation must first be moved one\n*         position backward; and entries in the second half\n*         must first have NL+1 added to their values.\n*\n*  PERM   (output) INTEGER array, dimension ( N )\n*         The permutations (from deflation and sorting) to be applied\n*         to each singular block. Not referenced if ICOMPQ = 0.\n*\n*  GIVPTR (output) INTEGER\n*         The number of Givens rotations which took place in this\n*         subproblem. Not referenced if ICOMPQ = 0.\n*\n*  GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )\n*         Each pair of numbers indicates a pair of columns to take place\n*         in a Givens rotation. Not referenced if ICOMPQ = 0.\n*\n*  LDGCOL (input) INTEGER\n*         The leading dimension of GIVCOL, must be at least N.\n*\n*  GIVNUM (output) REAL array, dimension ( LDGNUM, 2 )\n*         Each number indicates the C or S value to be used in the\n*         corresponding Givens rotation. Not referenced if ICOMPQ = 0.\n*\n*  LDGNUM (input) INTEGER\n*         The leading dimension of GIVNUM, must be at least N.\n*\n*  C      (output) REAL\n*         C contains garbage if SQRE =0 and the C-value of a Givens\n*         rotation related to the right null space if SQRE = 1.\n*\n*  S      (output) REAL\n*         S contains garbage if SQRE =0 and the S-value of a Givens\n*         rotation related to the right null space if SQRE = 1.\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*  Based on contributions by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  k, z, dsigma, perm, givptr, givcol, givnum, c, s, info, d, vf, vl = NumRu::Lapack.slasd7( icompq, nl, nr, sqre, d, vf, vl, alpha, beta, idxq, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_icompq = argv[0];
  rblapack_nl = argv[1];
  rblapack_nr = argv[2];
  rblapack_sqre = argv[3];
  rblapack_d = argv[4];
  rblapack_vf = argv[5];
  rblapack_vl = argv[6];
  rblapack_alpha = argv[7];
  rblapack_beta = argv[8];
  rblapack_idxq = argv[9];
  if (argc == 10) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  icompq = NUM2INT(rblapack_icompq);
  nr = NUM2INT(rblapack_nr);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (5th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_vl))
    rb_raise(rb_eArgError, "vl (7th argument) must be NArray");
  if (NA_RANK(rblapack_vl) != 1)
    rb_raise(rb_eArgError, "rank of vl (7th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_vl);
  if (NA_TYPE(rblapack_vl) != NA_SFLOAT)
    rblapack_vl = na_change_type(rblapack_vl, NA_SFLOAT);
  vl = NA_PTR_TYPE(rblapack_vl, real*);
  beta = (real)NUM2DBL(rblapack_beta);
  nl = NUM2INT(rblapack_nl);
  if (!NA_IsNArray(rblapack_vf))
    rb_raise(rb_eArgError, "vf (6th argument) must be NArray");
  if (NA_RANK(rblapack_vf) != 1)
    rb_raise(rb_eArgError, "rank of vf (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_vf) != m)
    rb_raise(rb_eRuntimeError, "shape 0 of vf must be the same as shape 0 of vl");
  if (NA_TYPE(rblapack_vf) != NA_SFLOAT)
    rblapack_vf = na_change_type(rblapack_vf, NA_SFLOAT);
  vf = NA_PTR_TYPE(rblapack_vf, real*);
  if (!NA_IsNArray(rblapack_idxq))
    rb_raise(rb_eArgError, "idxq (10th argument) must be NArray");
  if (NA_RANK(rblapack_idxq) != 1)
    rb_raise(rb_eArgError, "rank of idxq (10th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_idxq) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of idxq must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_idxq) != NA_LINT)
    rblapack_idxq = na_change_type(rblapack_idxq, NA_LINT);
  idxq = NA_PTR_TYPE(rblapack_idxq, integer*);
  ldgcol = n;
  sqre = NUM2INT(rblapack_sqre);
  ldgnum = n;
  alpha = (real)NUM2DBL(rblapack_alpha);
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_z = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_dsigma = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  dsigma = NA_PTR_TYPE(rblapack_dsigma, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_perm = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  perm = NA_PTR_TYPE(rblapack_perm, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldgcol;
    shape[1] = 2;
    rblapack_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
  }
  givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldgnum;
    shape[1] = 2;
    rblapack_givnum = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  givnum = NA_PTR_TYPE(rblapack_givnum, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_vf_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  vf_out__ = NA_PTR_TYPE(rblapack_vf_out__, real*);
  MEMCPY(vf_out__, vf, real, NA_TOTAL(rblapack_vf));
  rblapack_vf = rblapack_vf_out__;
  vf = vf_out__;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_vl_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, real*);
  MEMCPY(vl_out__, vl, real, NA_TOTAL(rblapack_vl));
  rblapack_vl = rblapack_vl_out__;
  vl = vl_out__;
  zw = ALLOC_N(real, (m));
  vfw = ALLOC_N(real, (m));
  vlw = ALLOC_N(real, (m));
  idx = ALLOC_N(integer, (n));
  idxp = ALLOC_N(integer, (n));

  slasd7_(&icompq, &nl, &nr, &sqre, &k, d, z, zw, vf, vfw, vl, vlw, &alpha, &beta, dsigma, idx, idxp, idxq, perm, &givptr, givcol, &ldgcol, givnum, &ldgnum, &c, &s, &info);

  free(zw);
  free(vfw);
  free(vlw);
  free(idx);
  free(idxp);
  rblapack_k = INT2NUM(k);
  rblapack_givptr = INT2NUM(givptr);
  rblapack_c = rb_float_new((double)c);
  rblapack_s = rb_float_new((double)s);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(13, rblapack_k, rblapack_z, rblapack_dsigma, rblapack_perm, rblapack_givptr, rblapack_givcol, rblapack_givnum, rblapack_c, rblapack_s, rblapack_info, rblapack_d, rblapack_vf, rblapack_vl);
}

void
init_lapack_slasd7(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slasd7", rblapack_slasd7, -1);
}
ruby-lapack-1.7.2/ext/zlaqgb.c0000644000175000017500000001505412502221025016007 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlaqgb_(integer* m, integer* n, integer* kl, integer* ku, doublecomplex* ab, integer* ldab, doublereal* r, doublereal* c, doublereal* rowcnd, doublereal* colcnd, doublereal* amax, char* equed);


static VALUE
rblapack_zlaqgb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_r;
  doublereal *r; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_rowcnd;
  doublereal rowcnd; 
  VALUE rblapack_colcnd;
  doublereal colcnd; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_ab_out__;
  doublecomplex *ab_out__;

  integer ldab;
  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  equed, ab = NumRu::Lapack.zlaqgb( kl, ku, ab, r, c, rowcnd, colcnd, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n*  Purpose\n*  =======\n*\n*  ZLAQGB equilibrates a general M by N band matrix A with KL\n*  subdiagonals and KU superdiagonals using the row and scaling factors\n*  in the vectors R and C.\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*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)\n*          On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n*          The j-th column of A is stored in the j-th column of the\n*          array AB as follows:\n*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n*          On exit, the equilibrated matrix, in the same storage format\n*          as A.  See EQUED for the form of the equilibrated matrix.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDA >= KL+KU+1.\n*\n*  R       (input) DOUBLE PRECISION array, dimension (M)\n*          The row scale factors for A.\n*\n*  C       (input) DOUBLE PRECISION array, dimension (N)\n*          The column scale factors for A.\n*\n*  ROWCND  (input) DOUBLE PRECISION\n*          Ratio of the smallest R(i) to the largest R(i).\n*\n*  COLCND  (input) DOUBLE PRECISION\n*          Ratio of the smallest C(i) to the largest C(i).\n*\n*  AMAX    (input) DOUBLE PRECISION\n*          Absolute value of largest matrix entry.\n*\n*  EQUED   (output) CHARACTER*1\n*          Specifies the form of equilibration that was done.\n*          = 'N':  No equilibration\n*          = 'R':  Row equilibration, i.e., A has been premultiplied by\n*                  diag(R).\n*          = 'C':  Column equilibration, i.e., A has been postmultiplied\n*                  by diag(C).\n*          = 'B':  Both row and column equilibration, i.e., A has been\n*                  replaced by diag(R) * A * diag(C).\n*\n*  Internal Parameters\n*  ===================\n*\n*  THRESH is a threshold value used to decide if row or column scaling\n*  should be done based on the ratio of the row or column scaling\n*  factors.  If ROWCND < THRESH, row scaling is done, and if\n*  COLCND < THRESH, column scaling is done.\n*\n*  LARGE and SMALL are threshold values used to decide if row scaling\n*  should be done based on the absolute size of the largest matrix\n*  element.  If AMAX > LARGE or AMAX < SMALL, row scaling is done.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  equed, ab = NumRu::Lapack.zlaqgb( kl, ku, ab, r, c, rowcnd, colcnd, amax, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_kl = argv[0];
  rblapack_ku = argv[1];
  rblapack_ab = argv[2];
  rblapack_r = argv[3];
  rblapack_c = argv[4];
  rblapack_rowcnd = argv[5];
  rblapack_colcnd = argv[6];
  rblapack_amax = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  colcnd = NUM2DBL(rblapack_colcnd);
  ku = NUM2INT(rblapack_ku);
  rowcnd = NUM2DBL(rblapack_rowcnd);
  if (!NA_IsNArray(rblapack_r))
    rb_raise(rb_eArgError, "r (4th argument) must be NArray");
  if (NA_RANK(rblapack_r) != 1)
    rb_raise(rb_eArgError, "rank of r (4th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_r);
  if (NA_TYPE(rblapack_r) != NA_DFLOAT)
    rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
  r = NA_PTR_TYPE(rblapack_r, doublereal*);
  amax = NUM2DBL(rblapack_amax);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
  MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  zlaqgb_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &equed);

  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(2, rblapack_equed, rblapack_ab);
}

void
init_lapack_zlaqgb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlaqgb", rblapack_zlaqgb, -1);
}
ruby-lapack-1.7.2/ext/ctptri.c0000644000175000017500000001073512502221022016032 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctptri_(char* uplo, char* diag, integer* n, complex* ap, integer* info);


static VALUE
rblapack_ctptri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  complex *ap_out__;


  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  info, ap = NumRu::Lapack.ctptri( uplo, diag, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTPTRI( UPLO, DIAG, N, AP, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTPTRI computes the inverse of a complex upper or lower triangular\n*  matrix A stored in packed format.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangular matrix A, stored\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n.\n*          See below for further details.\n*          On exit, the (triangular) inverse of the original matrix, in\n*          the same packed storage format.\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, A(i,i) is exactly zero.  The triangular\n*                matrix is singular and its inverse can not be computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  A triangular matrix A can be transferred to packed storage using one\n*  of the following program segments:\n*\n*  UPLO = 'U':                      UPLO = 'L':\n*\n*        JC = 1                           JC = 1\n*        DO 2 J = 1, N                    DO 2 J = 1, N\n*           DO 1 I = 1, J                    DO 1 I = J, N\n*              AP(JC+I-1) = A(I,J)              AP(JC+I-J) = A(I,J)\n*      1    CONTINUE                    1    CONTINUE\n*           JC = JC + J                      JC = JC + N - J + 1\n*      2 CONTINUE                       2 CONTINUE\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ap = NumRu::Lapack.ctptri( uplo, diag, n, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_diag = argv[1];
  rblapack_n = argv[2];
  rblapack_ap = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  n = NUM2INT(rblapack_n);
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
  MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  ctptri_(&uplo, &diag, &n, ap, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ap);
}

void
init_lapack_ctptri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctptri", rblapack_ctptri, -1);
}
ruby-lapack-1.7.2/ext/zlacpy.c0000644000175000017500000000712312502221015016026 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlacpy_(char* uplo, integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb);


static VALUE
rblapack_zlacpy(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 

  integer lda;
  integer n;
  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  b = NumRu::Lapack.zlacpy( uplo, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB )\n\n*  Purpose\n*  =======\n*\n*  ZLACPY copies all or part of a two-dimensional matrix A to another\n*  matrix B.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies the part of the matrix A to be copied to B.\n*          = 'U':      Upper triangular part\n*          = 'L':      Lower triangular part\n*          Otherwise:  All of the matrix A\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) COMPLEX*16 array, dimension (LDA,N)\n*          The m by n matrix A.  If UPLO = 'U', only the upper trapezium\n*          is accessed; if UPLO = 'L', only the lower trapezium is\n*          accessed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  B       (output) COMPLEX*16 array, dimension (LDB,N)\n*          On exit, B = A in the locations specified by UPLO.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,M).\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  b = NumRu::Lapack.zlacpy( uplo, m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_m = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  m = NUM2INT(rblapack_m);
  ldb = MAX(1,m);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);

  zlacpy_(&uplo, &m, &n, a, &lda, b, &ldb);

  return rblapack_b;
}

void
init_lapack_zlacpy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlacpy", rblapack_zlacpy, -1);
}
ruby-lapack-1.7.2/ext/slae2.c0000644000175000017500000000562012502221022015530 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slae2_(real* a, real* b, real* c, real* rt1, real* rt2);


static VALUE
rblapack_slae2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  real a; 
  VALUE rblapack_b;
  real b; 
  VALUE rblapack_c;
  real c; 
  VALUE rblapack_rt1;
  real rt1; 
  VALUE rblapack_rt2;
  real rt2; 


  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  rt1, rt2 = NumRu::Lapack.slae2( a, b, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAE2( A, B, C, RT1, RT2 )\n\n*  Purpose\n*  =======\n*\n*  SLAE2  computes the eigenvalues of a 2-by-2 symmetric matrix\n*     [  A   B  ]\n*     [  B   C  ].\n*  On return, RT1 is the eigenvalue of larger absolute value, and RT2\n*  is the eigenvalue of smaller absolute value.\n*\n\n*  Arguments\n*  =========\n*\n*  A       (input) REAL\n*          The (1,1) element of the 2-by-2 matrix.\n*\n*  B       (input) REAL\n*          The (1,2) and (2,1) elements of the 2-by-2 matrix.\n*\n*  C       (input) REAL\n*          The (2,2) element of the 2-by-2 matrix.\n*\n*  RT1     (output) REAL\n*          The eigenvalue of larger absolute value.\n*\n*  RT2     (output) REAL\n*          The eigenvalue of smaller absolute value.\n*\n\n*  Further Details\n*  ===============\n*\n*  RT1 is accurate to a few ulps barring over/underflow.\n*\n*  RT2 may be inaccurate if there is massive cancellation in the\n*  determinant A*C-B*B; higher precision or correctly rounded or\n*  correctly truncated arithmetic would be needed to compute RT2\n*  accurately in all cases.\n*\n*  Overflow is possible only if RT1 is within a factor of 5 of overflow.\n*  Underflow is harmless if the input data is 0 or exceeds\n*     underflow_threshold / macheps.\n*\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rt1, rt2 = NumRu::Lapack.slae2( a, b, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  rblapack_c = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  a = (real)NUM2DBL(rblapack_a);
  c = (real)NUM2DBL(rblapack_c);
  b = (real)NUM2DBL(rblapack_b);

  slae2_(&a, &b, &c, &rt1, &rt2);

  rblapack_rt1 = rb_float_new((double)rt1);
  rblapack_rt2 = rb_float_new((double)rt2);
  return rb_ary_new3(2, rblapack_rt1, rblapack_rt2);
}

void
init_lapack_slae2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slae2", rblapack_slae2, -1);
}
ruby-lapack-1.7.2/ext/clangb.c0000644000175000017500000001035112502221023015746 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real clangb_(char* norm, integer* n, integer* kl, integer* ku, complex* ab, integer* ldab, real* work);


static VALUE
rblapack_clangb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack___out__;
  real __out__; 
  real *work;

  integer ldab;
  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  __out__ = NumRu::Lapack.clangb( norm, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL             FUNCTION CLANGB( NORM, N, KL, KU, AB, LDAB, WORK )\n\n*  Purpose\n*  =======\n*\n*  CLANGB  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the element of  largest absolute value  of an\n*  n by n band matrix  A,  with kl sub-diagonals and ku super-diagonals.\n*\n*  Description\n*  ===========\n*\n*  CLANGB returns the value\n*\n*     CLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in CLANGB as described\n*          above.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, CLANGB is\n*          set to zero.\n*\n*  KL      (input) INTEGER\n*          The number of sub-diagonals of the matrix A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of super-diagonals of the matrix A.  KU >= 0.\n*\n*  AB      (input) COMPLEX array, dimension (LDAB,N)\n*          The band matrix A, stored in rows 1 to KL+KU+1.  The j-th\n*          column of A is stored in the j-th column of the array AB as\n*          follows:\n*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n*          referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.clangb( norm, kl, ku, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_norm = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  ku = NUM2INT(rblapack_ku);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  work = ALLOC_N(real, (MAX(1,lsame_(&norm,"I") ? n : 0)));

  __out__ = clangb_(&norm, &n, &kl, &ku, ab, &ldab, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_clangb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clangb", rblapack_clangb, -1);
}
ruby-lapack-1.7.2/ext/cunmql.c0000644000175000017500000001632512502221012016024 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cunmql_(char* side, char* trans, integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* c, integer* ldc, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_cunmql(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_c;
  complex *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  complex *c_out__;

  integer lda;
  integer k;
  integer ldc;
  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  work, info, c = NumRu::Lapack.cunmql( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CUNMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CUNMQL overwrites the general complex M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'C':      Q**H * C       C * Q**H\n*\n*  where Q is a complex unitary matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(k) . . . H(2) H(1)\n*\n*  as returned by CGEQLF. Q is of order M if SIDE = 'L' and of order N\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**H from the Left;\n*          = 'R': apply Q or Q**H from the Right.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'C':  Transpose, apply Q**H.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,K)\n*          The i-th column must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          CGEQLF in the last k columns of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*          If SIDE = 'L', LDA >= max(1,M);\n*          if SIDE = 'R', LDA >= max(1,N).\n*\n*  TAU     (input) COMPLEX array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by CGEQLF.\n*\n*  C       (input/output) COMPLEX array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace/output) COMPLEX 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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M).\n*          For optimum performance LWORK >= N*NB if SIDE = 'L', and\n*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n*          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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.cunmql( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_m = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 7) {
    rblapack_lwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  side = StringValueCStr(rblapack_side)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, complex*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != k)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
  MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  cunmql_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_cunmql(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cunmql", rblapack_cunmql, -1);
}
ruby-lapack-1.7.2/ext/zhpsv.c0000644000175000017500000001651512502221015015703 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhpsv_(char* uplo, integer* n, integer* nrhs, doublecomplex* ap, integer* ipiv, doublecomplex* b, integer* ldb, integer* info);


static VALUE
rblapack_zhpsv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublecomplex *ap_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer ldb;
  integer nrhs;
  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  ipiv, info, ap, b = NumRu::Lapack.zhpsv( uplo, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHPSV computes the solution to a complex system of linear equations\n*     A * X = B,\n*  where A is an N-by-N Hermitian matrix stored in packed format and X\n*  and B are N-by-NRHS matrices.\n*\n*  The diagonal pivoting method is used to factor A as\n*     A = U * D * U**H,  if UPLO = 'U', or\n*     A = L * D * L**H,  if UPLO = 'L',\n*  where U (or L) is a product of permutation and unit upper (lower)\n*  triangular matrices, D is Hermitian and block diagonal with 1-by-1\n*  and 2-by-2 diagonal blocks.  The factored form of A is then used to\n*  solve the system of equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          See below for further details.\n*\n*          On exit, the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L from the factorization\n*          A = U*D*U**H or A = L*D*L**H as computed by ZHPTRF, stored as\n*          a packed triangular matrix in the same storage format as A.\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D, as\n*          determined by ZHPTRF.  If IPIV(k) > 0, then rows and columns\n*          k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n*          diagonal block.  If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n*          then rows and columns k-1 and -IPIV(k) were interchanged and\n*          D(k-1:k,k-1:k) is a 2-by-2 diagonal block.  If UPLO = 'L' and\n*          IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n*          -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n*          diagonal block.\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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, D(i,i) is exactly zero.  The factorization\n*                has been completed, but the block diagonal matrix D is\n*                exactly singular, so the solution could not be\n*                computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  The packed storage scheme is illustrated by the following example\n*  when N = 4, UPLO = 'U':\n*\n*  Two-dimensional storage of the Hermitian matrix A:\n*\n*     a11 a12 a13 a14\n*         a22 a23 a24\n*             a33 a34     (aij = conjg(aji))\n*                 a44\n*\n*  Packed storage of the upper triangle of A:\n*\n*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n*  =====================================================================\n*\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZHPTRF, ZHPTRS\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, ap, b = NumRu::Lapack.zhpsv( uplo, ap, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_b = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  n = ldb;
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
  MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zhpsv_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ipiv, rblapack_info, rblapack_ap, rblapack_b);
}

void
init_lapack_zhpsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhpsv", rblapack_zhpsv, -1);
}
ruby-lapack-1.7.2/ext/dgsvj1.c0000644000175000017500000003201712502221023015721 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgsvj1_(char* jobv, integer* m, integer* n, integer* n1, doublereal* a, integer* lda, doublereal* d, doublereal* sva, integer* mv, doublereal* v, integer* ldv, doublereal* eps, doublereal* sfmin, doublereal* tol, integer* nsweep, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dgsvj1(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobv;
  char jobv; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_n1;
  integer n1; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_sva;
  doublereal *sva; 
  VALUE rblapack_mv;
  integer mv; 
  VALUE rblapack_v;
  doublereal *v; 
  VALUE rblapack_eps;
  doublereal eps; 
  VALUE rblapack_sfmin;
  doublereal sfmin; 
  VALUE rblapack_tol;
  doublereal tol; 
  VALUE rblapack_nsweep;
  integer nsweep; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_sva_out__;
  doublereal *sva_out__;
  VALUE rblapack_v_out__;
  doublereal *v_out__;
  doublereal *work;

  integer lda;
  integer n;
  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  info, a, d, sva, v = NumRu::Lapack.dgsvj1( jobv, m, n1, a, d, sva, mv, v, eps, sfmin, tol, nsweep, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGSVJ1 is called from SGESVJ as a pre-processor and that is its main\n*  purpose. It applies Jacobi rotations in the same way as SGESVJ does, but\n*  it targets only particular pivots and it does not check convergence\n*  (stopping criterion). Few tunning parameters (marked by [TP]) are\n*  available for the implementer.\n*\n*  Further Details\n*  ~~~~~~~~~~~~~~~\n*  DGSVJ1 applies few sweeps of Jacobi rotations in the column space of\n*  the input M-by-N matrix A. The pivot pairs are taken from the (1,2)\n*  off-diagonal block in the corresponding N-by-N Gram matrix A^T * A. The\n*  block-entries (tiles) of the (1,2) off-diagonal block are marked by the\n*  [x]'s in the following scheme:\n*\n*     | *   *   * [x] [x] [x]|\n*     | *   *   * [x] [x] [x]|    Row-cycling in the nblr-by-nblc [x] blocks.\n*     | *   *   * [x] [x] [x]|    Row-cyclic pivoting inside each [x] block.\n*     |[x] [x] [x] *   *   * |\n*     |[x] [x] [x] *   *   * |\n*     |[x] [x] [x] *   *   * |\n*\n*  In terms of the columns of A, the first N1 columns are rotated 'against'\n*  the remaining N-N1 columns, trying to increase the angle between the\n*  corresponding subspaces. The off-diagonal block is N1-by(N-N1) and it is\n*  tiled using quadratic tiles of side KBL. Here, KBL is a tunning parmeter.\n*  The number of sweeps is given in NSWEEP and the orthogonality threshold\n*  is given in TOL.\n*\n*  Contributors\n*  ~~~~~~~~~~~~\n*  Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)\n*\n\n*  Arguments\n*  =========\n*\n*  JOBV    (input) CHARACTER*1\n*          Specifies whether the output from this procedure is used\n*          to compute the matrix V:\n*          = 'V': the product of the Jacobi rotations is accumulated\n*                 by postmulyiplying the N-by-N array V.\n*                (See the description of V.)\n*          = 'A': the product of the Jacobi rotations is accumulated\n*                 by postmulyiplying the MV-by-N array V.\n*                (See the descriptions of MV and V.)\n*          = 'N': the Jacobi rotations are not accumulated.\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.\n*          M >= N >= 0.\n*\n*  N1      (input) INTEGER\n*          N1 specifies the 2 x 2 block partition, the first N1 columns are\n*          rotated 'against' the remaining N-N1 columns of A.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, M-by-N matrix A, such that A*diag(D) represents\n*          the input matrix.\n*          On exit,\n*          A_onexit * D_onexit represents the input matrix A*diag(D)\n*          post-multiplied by a sequence of Jacobi rotations, where the\n*          rotation threshold and the total number of sweeps are given in\n*          TOL and NSWEEP, respectively.\n*          (See the descriptions of N1, D, TOL and NSWEEP.)\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  D       (input/workspace/output) DOUBLE PRECISION array, dimension (N)\n*          The array D accumulates the scaling factors from the fast scaled\n*          Jacobi rotations.\n*          On entry, A*diag(D) represents the input matrix.\n*          On exit, A_onexit*diag(D_onexit) represents the input matrix\n*          post-multiplied by a sequence of Jacobi rotations, where the\n*          rotation threshold and the total number of sweeps are given in\n*          TOL and NSWEEP, respectively.\n*          (See the descriptions of N1, A, TOL and NSWEEP.)\n*\n*  SVA     (input/workspace/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, SVA contains the Euclidean norms of the columns of\n*          the matrix A*diag(D).\n*          On exit, SVA contains the Euclidean norms of the columns of\n*          the matrix onexit*diag(D_onexit).\n*\n*  MV      (input) INTEGER\n*          If JOBV .EQ. 'A', then MV rows of V are post-multipled by a\n*                           sequence of Jacobi rotations.\n*          If JOBV = 'N',   then MV is not referenced.\n*\n*  V       (input/output) DOUBLE PRECISION array, dimension (LDV,N)\n*          If JOBV .EQ. 'V' then N rows of V are post-multipled by a\n*                           sequence of Jacobi rotations.\n*          If JOBV .EQ. 'A' then MV rows of V are post-multipled by a\n*                           sequence of Jacobi rotations.\n*          If JOBV = 'N',   then V is not referenced.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V,  LDV >= 1.\n*          If JOBV = 'V', LDV .GE. N.\n*          If JOBV = 'A', LDV .GE. MV.\n*\n*  EPS     (input) DOUBLE PRECISION\n*          EPS = DLAMCH('Epsilon')\n*\n*  SFMIN   (input) DOUBLE PRECISION\n*          SFMIN = DLAMCH('Safe Minimum')\n*\n*  TOL     (input) DOUBLE PRECISION\n*          TOL is the threshold for Jacobi rotations. For a pair\n*          A(:,p), A(:,q) of pivot columns, the Jacobi rotation is\n*          applied only if DABS(COS(angle(A(:,p),A(:,q)))) .GT. TOL.\n*\n*  NSWEEP  (input) INTEGER\n*          NSWEEP is the number of sweeps of Jacobi rotations to be\n*          performed.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (LWORK)\n*\n*  LWORK   (input) INTEGER\n*          LWORK is the dimension of WORK. LWORK .GE. M.\n*\n*  INFO    (output) INTEGER\n*          = 0 : successful exit.\n*          < 0 : if INFO = -i, then the i-th argument had an illegal value\n*\n\n*  =====================================================================\n*\n*     .. Local Parameters ..\n      DOUBLE PRECISION   ZERO, HALF, ONE, TWO\n      PARAMETER          ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0,\n     +                   TWO = 2.0D0 )\n*     ..\n*     .. Local Scalars ..\n      DOUBLE PRECISION   AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,\n     +                   BIGTHETA, CS, LARGE, MXAAPQ, MXSINJ, ROOTBIG,\n     +                   ROOTEPS, ROOTSFMIN, ROOTTOL, SMALL, SN, T,\n     +                   TEMP1, THETA, THSIGN\n      INTEGER            BLSKIP, EMPTSW, i, ibr, igl, IERR, IJBLSK,\n     +                   ISWROT, jbc, jgl, KBL, MVL, NOTROT, nblc, nblr,\n     +                   p, PSKIPPED, q, ROWSKIP, SWBAND\n      LOGICAL            APPLV, ROTOK, RSVEC\n*     ..\n*     .. Local Arrays ..\n      DOUBLE PRECISION   FASTR( 5 )\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          DABS, DMAX1, DBLE, MIN0, DSIGN, DSQRT\n*     ..\n*     .. External Functions ..\n      DOUBLE PRECISION   DDOT, DNRM2\n      INTEGER            IDAMAX\n      LOGICAL            LSAME\n      EXTERNAL           IDAMAX, LSAME, DDOT, DNRM2\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DAXPY, DCOPY, DLASCL, DLASSQ, DROTM, DSWAP\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a, d, sva, v = NumRu::Lapack.dgsvj1( jobv, m, n1, a, d, sva, mv, v, eps, sfmin, tol, nsweep, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 13)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_jobv = argv[0];
  rblapack_m = argv[1];
  rblapack_n1 = argv[2];
  rblapack_a = argv[3];
  rblapack_d = argv[4];
  rblapack_sva = argv[5];
  rblapack_mv = argv[6];
  rblapack_v = argv[7];
  rblapack_eps = argv[8];
  rblapack_sfmin = argv[9];
  rblapack_tol = argv[10];
  rblapack_nsweep = argv[11];
  if (argc == 13) {
    rblapack_lwork = argv[12];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  jobv = StringValueCStr(rblapack_jobv)[0];
  n1 = NUM2INT(rblapack_n1);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (5th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  mv = NUM2INT(rblapack_mv);
  eps = NUM2DBL(rblapack_eps);
  tol = NUM2DBL(rblapack_tol);
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_sva))
    rb_raise(rb_eArgError, "sva (6th argument) must be NArray");
  if (NA_RANK(rblapack_sva) != 1)
    rb_raise(rb_eArgError, "rank of sva (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_sva) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of sva must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_sva) != NA_DFLOAT)
    rblapack_sva = na_change_type(rblapack_sva, NA_DFLOAT);
  sva = NA_PTR_TYPE(rblapack_sva, doublereal*);
  sfmin = NUM2DBL(rblapack_sfmin);
  lwork = m;
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  nsweep = NUM2INT(rblapack_nsweep);
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (8th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (8th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  if (NA_SHAPE1(rblapack_v) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of v must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_v) != NA_DFLOAT)
    rblapack_v = na_change_type(rblapack_v, NA_DFLOAT);
  v = NA_PTR_TYPE(rblapack_v, doublereal*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_sva_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  sva_out__ = NA_PTR_TYPE(rblapack_sva_out__, doublereal*);
  MEMCPY(sva_out__, sva, doublereal, NA_TOTAL(rblapack_sva));
  rblapack_sva = rblapack_sva_out__;
  sva = sva_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = n;
    rblapack_v_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  v_out__ = NA_PTR_TYPE(rblapack_v_out__, doublereal*);
  MEMCPY(v_out__, v, doublereal, NA_TOTAL(rblapack_v));
  rblapack_v = rblapack_v_out__;
  v = v_out__;
  work = ALLOC_N(doublereal, (lwork));

  dgsvj1_(&jobv, &m, &n, &n1, a, &lda, d, sva, &mv, v, &ldv, &eps, &sfmin, &tol, &nsweep, work, &lwork, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_info, rblapack_a, rblapack_d, rblapack_sva, rblapack_v);
}

void
init_lapack_dgsvj1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgsvj1", rblapack_dgsvj1, -1);
}
ruby-lapack-1.7.2/ext/slaneg.c0000644000175000017500000001115312502221017015775 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern integer slaneg_(integer* n, real* d, real* lld, real* sigma, real* pivmin, integer* r);


static VALUE
rblapack_slaneg(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_lld;
  real *lld; 
  VALUE rblapack_sigma;
  real sigma; 
  VALUE rblapack_pivmin;
  real pivmin; 
  VALUE rblapack_r;
  integer r; 
  VALUE rblapack___out__;
  integer __out__; 

  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  __out__ = NumRu::Lapack.slaneg( d, lld, sigma, pivmin, r, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      INTEGER FUNCTION SLANEG( N, D, LLD, SIGMA, PIVMIN, R )\n\n*  Purpose\n*  =======\n*\n*  SLANEG computes the Sturm count, the number of negative pivots\n*  encountered while factoring tridiagonal T - sigma I = L D L^T.\n*  This implementation works directly on the factors without forming\n*  the tridiagonal matrix T.  The Sturm count is also the number of\n*  eigenvalues of T less than sigma.\n*\n*  This routine is called from SLARRB.\n*\n*  The current routine does not use the PIVMIN parameter but rather\n*  requires IEEE-754 propagation of Infinities and NaNs.  This\n*  routine also has no input range restrictions but does require\n*  default exception handling such that x/0 produces Inf when x is\n*  non-zero, and Inf/Inf produces NaN.  For more information, see:\n*\n*    Marques, Riedy, and Voemel, \"Benefits of IEEE-754 Features in\n*    Modern Symmetric Tridiagonal Eigensolvers,\" SIAM Journal on\n*    Scientific Computing, v28, n5, 2006.  DOI 10.1137/050641624\n*    (Tech report version in LAWN 172 with the same title.)\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix.\n*\n*  D       (input) REAL             array, dimension (N)\n*          The N diagonal elements of the diagonal matrix D.\n*\n*  LLD     (input) REAL             array, dimension (N-1)\n*          The (N-1) elements L(i)*L(i)*D(i).\n*\n*  SIGMA   (input) REAL            \n*          Shift amount in T - sigma I = L D L^T.\n*\n*  PIVMIN  (input) REAL            \n*          The minimum pivot in the Sturm sequence.  May be used\n*          when zero pivots are encountered on non-IEEE-754\n*          architectures.\n*\n*  R       (input) INTEGER\n*          The twist index for the twisted factorization that is used\n*          for the negcount.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*     Jason Riedy, University of California, Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.slaneg( d, lld, sigma, pivmin, r, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_d = argv[0];
  rblapack_lld = argv[1];
  rblapack_sigma = argv[2];
  rblapack_pivmin = argv[3];
  rblapack_r = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  sigma = (real)NUM2DBL(rblapack_sigma);
  r = NUM2INT(rblapack_r);
  if (!NA_IsNArray(rblapack_lld))
    rb_raise(rb_eArgError, "lld (2th argument) must be NArray");
  if (NA_RANK(rblapack_lld) != 1)
    rb_raise(rb_eArgError, "rank of lld (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_lld) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of lld must be %d", n-1);
  if (NA_TYPE(rblapack_lld) != NA_SFLOAT)
    rblapack_lld = na_change_type(rblapack_lld, NA_SFLOAT);
  lld = NA_PTR_TYPE(rblapack_lld, real*);
  pivmin = (real)NUM2DBL(rblapack_pivmin);

  __out__ = slaneg_(&n, d, lld, &sigma, &pivmin, &r);

  rblapack___out__ = INT2NUM(__out__);
  return rblapack___out__;
}

void
init_lapack_slaneg(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaneg", rblapack_slaneg, -1);
}
ruby-lapack-1.7.2/ext/cpbrfs.c0000644000175000017500000002037012502221012015777 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cpbrfs_(char* uplo, integer* n, integer* kd, integer* nrhs, complex* ab, integer* ldab, complex* afb, integer* ldafb, complex* b, integer* ldb, complex* x, integer* ldx, real* ferr, real* berr, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cpbrfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_afb;
  complex *afb; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  complex *x_out__;
  complex *work;
  real *rwork;

  integer ldab;
  integer n;
  integer ldafb;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.cpbrfs( uplo, kd, ab, afb, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPBRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is Hermitian positive definite\n*  and banded, and provides error bounds and backward error estimates\n*  for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AB      (input) COMPLEX array, dimension (LDAB,N)\n*          The upper or lower triangle of the Hermitian band matrix A,\n*          stored in the first KD+1 rows of the array.  The j-th column\n*          of A is stored in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  AFB     (input) COMPLEX array, dimension (LDAFB,N)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**H*U or A = L*L**H of the band matrix A as computed by\n*          CPBTRF, in the same storage format as A (see AB).\n*\n*  LDAFB   (input) INTEGER\n*          The leading dimension of the array AFB.  LDAFB >= KD+1.\n*\n*  B       (input) COMPLEX array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) COMPLEX array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by CPBTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.cpbrfs( uplo, kd, ab, afb, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  rblapack_afb = argv[3];
  rblapack_b = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  kd = NUM2INT(rblapack_kd);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (4th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (4th argument) must be %d", 2);
  ldafb = NA_SHAPE0(rblapack_afb);
  if (NA_SHAPE1(rblapack_afb) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_afb) != NA_SCOMPLEX)
    rblapack_afb = na_change_type(rblapack_afb, NA_SCOMPLEX);
  afb = NA_PTR_TYPE(rblapack_afb, complex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (n));

  cpbrfs_(&uplo, &n, &kd, &nrhs, ab, &ldab, afb, &ldafb, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_cpbrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cpbrfs", rblapack_cpbrfs, -1);
}
ruby-lapack-1.7.2/ext/cgehrd.c0000644000175000017500000001545212502221020015760 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgehrd_(integer* n, integer* ilo, integer* ihi, complex* a, integer* lda, complex* tau, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_cgehrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *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.cgehrd( ilo, ihi, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGEHRD reduces a complex general matrix A to upper Hessenberg form H by\n*  an unitary similarity transformation:  Q' * A * Q = H .\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          It is assumed that A is already upper triangular in rows\n*          and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n*          set by a previous call to CGEBAL; otherwise they should be\n*          set to 1 and N respectively. See Further Details.\n*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the N-by-N general matrix to be reduced.\n*          On exit, the upper triangle and the first subdiagonal of A\n*          are overwritten with the upper Hessenberg matrix H, and the\n*          elements below the first subdiagonal, with the array TAU,\n*          represent the unitary matrix Q as a product of elementary\n*          reflectors. See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  TAU     (output) COMPLEX array, dimension (N-1)\n*          The scalar factors of the elementary reflectors (see Further\n*          Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to\n*          zero.\n*\n*  WORK    (workspace/output) COMPLEX array, dimension (LWORK)\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of the array WORK.  LWORK >= max(1,N).\n*          For optimum performance LWORK >= N*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 (ihi-ilo) elementary\n*  reflectors\n*\n*     Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - tau * v * v'\n*\n*  where tau is a complex scalar, and v is a complex vector with\n*  v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n*  exit in A(i+2:ihi,i), and tau in TAU(i).\n*\n*  The contents of A are illustrated by the following example, with\n*  n = 7, ilo = 2 and ihi = 6:\n*\n*  on entry,                        on exit,\n*\n*  ( a   a   a   a   a   a   a )    (  a   a   h   h   h   h   a )\n*  (     a   a   a   a   a   a )    (      a   h   h   h   h   a )\n*  (     a   a   a   a   a   a )    (      h   h   h   h   h   h )\n*  (     a   a   a   a   a   a )    (      v2  h   h   h   h   h )\n*  (     a   a   a   a   a   a )    (      v2  v3  h   h   h   h )\n*  (     a   a   a   a   a   a )    (      v2  v3  v4  h   h   h )\n*  (                         a )    (                          a )\n*\n*  where a denotes an element of the original matrix A, h denotes a\n*  modified element of the upper Hessenberg matrix H, and vi denotes an\n*  element of the vector defining H(i).\n*\n*  This file is a slight modification of LAPACK-3.0's DGEHRD\n*  subroutine incorporating improvements proposed by Quintana-Orti and\n*  Van de Geijn (2006). (See DLAHR2.)\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, work, info, a = NumRu::Lapack.cgehrd( ilo, ihi, a, [: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_ilo = argv[0];
  rblapack_ihi = argv[1];
  rblapack_a = 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;
  }

  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  ihi = NUM2INT(rblapack_ihi);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  cgehrd_(&n, &ilo, &ihi, 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_cgehrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgehrd", rblapack_cgehrd, -1);
}
ruby-lapack-1.7.2/ext/chetf2.c0000644000175000017500000001615012502221013015675 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chetf2_(char* uplo, integer* n, complex* a, integer* lda, integer* ipiv, integer* info);


static VALUE
rblapack_chetf2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *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  ipiv, info, a = NumRu::Lapack.chetf2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHETF2( UPLO, N, A, LDA, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHETF2 computes the factorization of a complex Hermitian matrix A\n*  using the Bunch-Kaufman diagonal pivoting method:\n*\n*     A = U*D*U'  or  A = L*D*L'\n*\n*  where U (or L) is a product of permutation and unit upper (lower)\n*  triangular matrices, U' is the conjugate transpose of U, and D is\n*  Hermitian and block diagonal with 1-by-1 and 2-by-2 diagonal blocks.\n*\n*  This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          Hermitian matrix A is stored:\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading\n*          n-by-n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n-by-n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L (see below for further details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D.\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*          > 0: if INFO = k, D(k,k) is exactly zero.  The factorization\n*               has been completed, but the block diagonal matrix D is\n*               exactly singular, and division by zero will occur if it\n*               is used to solve a system of equations.\n*\n\n*  Further Details\n*  ===============\n*\n*  09-29-06 - patch from\n*    Bobby Cheng, MathWorks\n*\n*    Replace l.210 and l.392\n*         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN\n*    by\n*         IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN\n*\n*  01-01-96 - Based on modifications by\n*    J. Lewis, Boeing Computer Services Company\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n*  If UPLO = 'U', then A = U*D*U', where\n*     U = P(n)*U(n)* ... *P(k)U(k)* ...,\n*  i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n*  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    v    0   )   k-s\n*     U(k) =  (   0    I    0   )   s\n*             (   0    0    I   )   n-k\n*                k-s   s   n-k\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n*  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n*  and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n*  If UPLO = 'L', then A = L*D*L', where\n*     L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n*  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n*  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    0     0   )  k-1\n*     L(k) =  (   0    I     0   )  s\n*             (   0    v     I   )  n-k-s+1\n*                k-1   s  n-k-s+1\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n*  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n*  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, a = NumRu::Lapack.chetf2( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  chetf2_(&uplo, &n, a, &lda, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_a);
}

void
init_lapack_chetf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chetf2", rblapack_chetf2, -1);
}
ruby-lapack-1.7.2/ext/dtrsen.c0000644000175000017500000003473312502221016016033 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtrsen_(char* job, char* compq, logical* select, integer* n, doublereal* t, integer* ldt, doublereal* q, integer* ldq, doublereal* wr, doublereal* wi, integer* m, doublereal* s, doublereal* sep, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_dtrsen(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_compq;
  char compq; 
  VALUE rblapack_select;
  logical *select; 
  VALUE rblapack_t;
  doublereal *t; 
  VALUE rblapack_q;
  doublereal *q; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_wr;
  doublereal *wr; 
  VALUE rblapack_wi;
  doublereal *wi; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_s;
  doublereal s; 
  VALUE rblapack_sep;
  doublereal sep; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_t_out__;
  doublereal *t_out__;
  VALUE rblapack_q_out__;
  doublereal *q_out__;
  integer *iwork;

  integer n;
  integer ldt;
  integer ldq;

  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  wr, wi, m, s, sep, work, info, t, q = NumRu::Lapack.dtrsen( job, compq, select, t, q, liwork, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTRSEN reorders the real Schur factorization of a real matrix\n*  A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in\n*  the leading diagonal blocks of the upper quasi-triangular matrix T,\n*  and the leading columns of Q form an orthonormal basis of the\n*  corresponding right invariant subspace.\n*\n*  Optionally the routine computes the reciprocal condition numbers of\n*  the cluster of eigenvalues and/or the invariant subspace.\n*\n*  T must be in Schur canonical form (as returned by DHSEQR), that is,\n*  block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each\n*  2-by-2 diagonal block has its diagonal elemnts equal and its\n*  off-diagonal elements of opposite sign.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies whether condition numbers are required for the\n*          cluster of eigenvalues (S) or the invariant subspace (SEP):\n*          = 'N': none;\n*          = 'E': for eigenvalues only (S);\n*          = 'V': for invariant subspace only (SEP);\n*          = 'B': for both eigenvalues and invariant subspace (S and\n*                 SEP).\n*\n*  COMPQ   (input) CHARACTER*1\n*          = 'V': update the matrix Q of Schur vectors;\n*          = 'N': do not update Q.\n*\n*  SELECT  (input) LOGICAL array, dimension (N)\n*          SELECT specifies the eigenvalues in the selected cluster. To\n*          select a real eigenvalue w(j), SELECT(j) must be set to\n*          .TRUE.. To select a complex conjugate pair of eigenvalues\n*          w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,\n*          either SELECT(j) or SELECT(j+1) or both must be set to\n*          .TRUE.; a complex conjugate pair of eigenvalues must be\n*          either both included in the cluster or both excluded.\n*\n*  N       (input) INTEGER\n*          The order of the matrix T. N >= 0.\n*\n*  T       (input/output) DOUBLE PRECISION array, dimension (LDT,N)\n*          On entry, the upper quasi-triangular matrix T, in Schur\n*          canonical form.\n*          On exit, T is overwritten by the reordered matrix T, again in\n*          Schur canonical form, with the selected eigenvalues in the\n*          leading diagonal blocks.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= max(1,N).\n*\n*  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n*          On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n*          On exit, if COMPQ = 'V', Q has been postmultiplied by the\n*          orthogonal transformation matrix which reorders T; the\n*          leading M columns of Q form an orthonormal basis for the\n*          specified invariant subspace.\n*          If COMPQ = 'N', Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.\n*          LDQ >= 1; and if COMPQ = 'V', LDQ >= N.\n*\n*  WR      (output) DOUBLE PRECISION array, dimension (N)\n*  WI      (output) DOUBLE PRECISION array, dimension (N)\n*          The real and imaginary parts, respectively, of the reordered\n*          eigenvalues of T. The eigenvalues are stored in the same\n*          order as on the diagonal of T, with WR(i) = T(i,i) and, if\n*          T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and\n*          WI(i+1) = -WI(i). Note that if a complex eigenvalue is\n*          sufficiently ill-conditioned, then its value may differ\n*          significantly from its value before reordering.\n*\n*  M       (output) INTEGER\n*          The dimension of the specified invariant subspace.\n*          0 < = M <= N.\n*\n*  S       (output) DOUBLE PRECISION\n*          If JOB = 'E' or 'B', S is a lower bound on the reciprocal\n*          condition number for the selected cluster of eigenvalues.\n*          S cannot underestimate the true reciprocal condition number\n*          by more than a factor of sqrt(N). If M = 0 or N, S = 1.\n*          If JOB = 'N' or 'V', S is not referenced.\n*\n*  SEP     (output) DOUBLE PRECISION\n*          If JOB = 'V' or 'B', SEP is the estimated reciprocal\n*          condition number of the specified invariant subspace. If\n*          M = 0 or N, SEP = norm(T).\n*          If JOB = 'N' or 'E', SEP is not referenced.\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*          If JOB = 'N', LWORK >= max(1,N);\n*          if JOB = 'E', LWORK >= max(1,M*(N-M));\n*          if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).\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*  IWORK   (workspace) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.\n*          If JOB = 'N' or 'E', LIWORK >= 1;\n*          if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)).\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal size of the IWORK array,\n*          returns this value as the first entry of the IWORK array, and\n*          no error message related to LIWORK 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*          = 1: reordering of T failed because some eigenvalues are too\n*               close to separate (the problem is very ill-conditioned);\n*               T may have been partially reordered, and WR and WI\n*               contain the eigenvalues in the same order as in T; S and\n*               SEP (if requested) are set to zero.\n*\n\n*  Further Details\n*  ===============\n*\n*  DTRSEN first collects the selected eigenvalues by computing an\n*  orthogonal transformation Z to move them to the top left corner of T.\n*  In other words, the selected eigenvalues are the eigenvalues of T11\n*  in:\n*\n*                Z'*T*Z = ( T11 T12 ) n1\n*                         (  0  T22 ) n2\n*                            n1  n2\n*\n*  where N = n1+n2 and Z' means the transpose of Z. The first n1 columns\n*  of Z span the specified invariant subspace of T.\n*\n*  If T has been obtained from the real Schur factorization of a matrix\n*  A = Q*T*Q', then the reordered real Schur factorization of A is given\n*  by A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span\n*  the corresponding invariant subspace of A.\n*\n*  The reciprocal condition number of the average of the eigenvalues of\n*  T11 may be returned in S. S lies between 0 (very badly conditioned)\n*  and 1 (very well conditioned). It is computed as follows. First we\n*  compute R so that\n*\n*                         P = ( I  R ) n1\n*                             ( 0  0 ) n2\n*                               n1 n2\n*\n*  is the projector on the invariant subspace associated with T11.\n*  R is the solution of the Sylvester equation:\n*\n*                        T11*R - R*T22 = T12.\n*\n*  Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote\n*  the two-norm of M. Then S is computed as the lower bound\n*\n*                      (1 + F-norm(R)**2)**(-1/2)\n*\n*  on the reciprocal of 2-norm(P), the true reciprocal condition number.\n*  S cannot underestimate 1 / 2-norm(P) by more than a factor of\n*  sqrt(N).\n*\n*  An approximate error bound for the computed average of the\n*  eigenvalues of T11 is\n*\n*                         EPS * norm(T) / S\n*\n*  where EPS is the machine precision.\n*\n*  The reciprocal condition number of the right invariant subspace\n*  spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.\n*  SEP is defined as the separation of T11 and T22:\n*\n*                     sep( T11, T22 ) = sigma-min( C )\n*\n*  where sigma-min(C) is the smallest singular value of the\n*  n1*n2-by-n1*n2 matrix\n*\n*     C  = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )\n*\n*  I(m) is an m by m identity matrix, and kprod denotes the Kronecker\n*  product. We estimate sigma-min(C) by the reciprocal of an estimate of\n*  the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)\n*  cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).\n*\n*  When SEP is small, small changes in T can cause large changes in\n*  the invariant subspace. An approximate bound on the maximum angular\n*  error in the computed right invariant subspace is\n*\n*                      EPS * norm(T) / SEP\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  wr, wi, m, s, sep, work, info, t, q = NumRu::Lapack.dtrsen( job, compq, select, t, q, liwork, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_job = argv[0];
  rblapack_compq = argv[1];
  rblapack_select = argv[2];
  rblapack_t = argv[3];
  rblapack_q = argv[4];
  rblapack_liwork = argv[5];
  if (argc == 7) {
    rblapack_lwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  job = StringValueCStr(rblapack_job)[0];
  if (!NA_IsNArray(rblapack_select))
    rb_raise(rb_eArgError, "select (3th argument) must be NArray");
  if (NA_RANK(rblapack_select) != 1)
    rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_select);
  if (NA_TYPE(rblapack_select) != NA_LINT)
    rblapack_select = na_change_type(rblapack_select, NA_LINT);
  select = NA_PTR_TYPE(rblapack_select, logical*);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (5th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_q) != NA_DFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
  q = NA_PTR_TYPE(rblapack_q, doublereal*);
  compq = StringValueCStr(rblapack_compq)[0];
  liwork = NUM2INT(rblapack_liwork);
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (4th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  if (NA_SHAPE1(rblapack_t) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_t) != NA_DFLOAT)
    rblapack_t = na_change_type(rblapack_t, NA_DFLOAT);
  t = NA_PTR_TYPE(rblapack_t, doublereal*);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&job,"N") ? n : lsame_(&job,"E") ? m*(n-m) : (lsame_(&job,"V")||lsame_(&job,"B")) ? 2*m*(n-m) : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  wr = NA_PTR_TYPE(rblapack_wr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  wi = NA_PTR_TYPE(rblapack_wi, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = n;
    rblapack_t_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  t_out__ = NA_PTR_TYPE(rblapack_t_out__, doublereal*);
  MEMCPY(t_out__, t, doublereal, NA_TOTAL(rblapack_t));
  rblapack_t = rblapack_t_out__;
  t = t_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
  MEMCPY(q_out__, q, doublereal, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  iwork = ALLOC_N(integer, (MAX(1,liwork)));

  dtrsen_(&job, &compq, select, &n, t, &ldt, q, &ldq, wr, wi, &m, &s, &sep, work, &lwork, iwork, &liwork, &info);

  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_s = rb_float_new((double)s);
  rblapack_sep = rb_float_new((double)sep);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_wr, rblapack_wi, rblapack_m, rblapack_s, rblapack_sep, rblapack_work, rblapack_info, rblapack_t, rblapack_q);
}

void
init_lapack_dtrsen(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtrsen", rblapack_dtrsen, -1);
}
ruby-lapack-1.7.2/ext/dpftri.c0000644000175000017500000001655212502221020016016 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dpftri_(char* transr, char* uplo, integer* n, doublereal* a, integer* info);


static VALUE
rblapack_dpftri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;


  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  info, a = NumRu::Lapack.dpftri( transr, uplo, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPFTRI( TRANSR, UPLO, N, A, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPFTRI computes the inverse of a (real) symmetric positive definite\n*  matrix A using the Cholesky factorization A = U**T*U or A = L*L**T\n*  computed by DPFTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR  (input) CHARACTER*1\n*          = 'N':  The Normal TRANSR of RFP A is stored;\n*          = 'T':  The Transpose TRANSR of RFP A is stored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 )\n*          On entry, the symmetric matrix A in RFP format. RFP format is\n*          described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n*          then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n*          (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is\n*          the transpose of RFP A as defined when\n*          TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n*          follows: If UPLO = 'U' the RFP A contains the nt elements of\n*          upper packed A. If UPLO = 'L' the RFP A contains the elements\n*          of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n*          'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n*          is odd. See the Note below for more details.\n*\n*          On exit, the symmetric inverse of the original matrix, in the\n*          same storage format.\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,i) element of the factor U or L is\n*                zero, and the inverse could not be computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  We first consider Rectangular Full Packed (RFP) Format when N is\n*  even. We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  the transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  the transpose of the last three columns of AP lower.\n*  This covers the case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        03 04 05                33 43 53\n*        13 14 15                00 44 54\n*        23 24 25                10 11 55\n*        33 34 35                20 21 22\n*        00 44 45                30 31 32\n*        01 11 55                40 41 42\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We then consider Rectangular Full Packed (RFP) Format when N is\n*  odd. We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  the transpose of the first two columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  the transpose of the last two columns of AP lower.\n*  This covers the case N odd and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        02 03 04                00 33 43\n*        12 13 14                10 11 44\n*        22 23 24                20 21 22\n*        00 33 34                30 31 32\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*           RFP A                   RFP A\n*\n*     02 12 22 00 01             00 10 20 30 40 50\n*     03 13 23 33 11             33 11 21 31 41 51\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.dpftri( transr, uplo, n, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_n = argv[2];
  rblapack_a = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  n = NUM2INT(rblapack_n);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 1)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_a_out__ = na_make_object(NA_DFLOAT, 1, 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__;

  dpftri_(&transr, &uplo, &n, a, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_dpftri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dpftri", rblapack_dpftri, -1);
}
ruby-lapack-1.7.2/ext/dlasrt.c0000644000175000017500000000615312502221025016020 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlasrt_(char* id, integer* n, doublereal* d, integer* info);


static VALUE
rblapack_dlasrt(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_id;
  char id; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;

  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  info, d = NumRu::Lapack.dlasrt( id, d, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLASRT( ID, N, D, INFO )\n\n*  Purpose\n*  =======\n*\n*  Sort the numbers in D in increasing order (if ID = 'I') or\n*  in decreasing order (if ID = 'D' ).\n*\n*  Use Quick Sort, reverting to Insertion sort on arrays of\n*  size <= 20. Dimension of STACK limits N to about 2**32.\n*\n\n*  Arguments\n*  =========\n*\n*  ID      (input) CHARACTER*1\n*          = 'I': sort D in increasing order;\n*          = 'D': sort D in decreasing order.\n*\n*  N       (input) INTEGER\n*          The length of the array D.\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the array to be sorted.\n*          On exit, D has been sorted into increasing order\n*          (D(1) <= ... <= D(N) ) or into decreasing order\n*          (D(1) >= ... >= D(N) ), depending on ID.\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d = NumRu::Lapack.dlasrt( id, d, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_id = argv[0];
  rblapack_d = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  id = StringValueCStr(rblapack_id)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;

  dlasrt_(&id, &n, d, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_d);
}

void
init_lapack_dlasrt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlasrt", rblapack_dlasrt, -1);
}
ruby-lapack-1.7.2/ext/zpttrs.c0000644000175000017500000001324712502221022016074 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zpttrs_(char* uplo, integer* n, integer* nrhs, doublereal* d, doublecomplex* e, doublecomplex* b, integer* ldb, integer* info);


static VALUE
rblapack_zpttrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublecomplex *e; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.zpttrs( uplo, d, e, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPTTRS( UPLO, N, NRHS, D, E, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPTTRS solves a tridiagonal system of the form\n*     A * X = B\n*  using the factorization A = U'*D*U or A = L*D*L' computed by ZPTTRF.\n*  D is a diagonal matrix specified in the vector D, U (or L) is a unit\n*  bidiagonal matrix whose superdiagonal (subdiagonal) is specified in\n*  the vector E, and X and B are N by NRHS matrices.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies the form of the factorization and whether the\n*          vector E is the superdiagonal of the upper bidiagonal factor\n*          U or the subdiagonal of the lower bidiagonal factor L.\n*          = 'U':  A = U'*D*U, E is the superdiagonal of U\n*          = 'L':  A = L*D*L', E is the subdiagonal of L\n*\n*  N       (input) INTEGER\n*          The order of the tridiagonal matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          The n diagonal elements of the diagonal matrix D from the\n*          factorization A = U'*D*U or A = L*D*L'.\n*\n*  E       (input) COMPLEX*16 array, dimension (N-1)\n*          If UPLO = 'U', the (n-1) superdiagonal elements of the unit\n*          bidiagonal factor U from the factorization A = U'*D*U.\n*          If UPLO = 'L', the (n-1) subdiagonal elements of the unit\n*          bidiagonal factor L from the factorization A = L*D*L'.\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the right hand side vectors B for the system of\n*          linear equations.\n*          On exit, the solution vectors, X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            UPPER\n      INTEGER            IUPLO, J, JB, NB\n*     ..\n*     .. External Functions ..\n      INTEGER            ILAENV\n      EXTERNAL           ILAENV\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZPTTS2\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.zpttrs( uplo, d, e, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DCOMPLEX)
    rblapack_e = na_change_type(rblapack_e, NA_DCOMPLEX);
  e = NA_PTR_TYPE(rblapack_e, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zpttrs_(&uplo, &n, &nrhs, d, e, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_zpttrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zpttrs", rblapack_zpttrs, -1);
}
ruby-lapack-1.7.2/ext/clantr.c0000644000175000017500000001223512502221025016010 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real clantr_(char* norm, char* uplo, char* diag, integer* m, integer* n, complex* a, integer* lda, real* work);


static VALUE
rblapack_clantr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack___out__;
  real __out__; 
  real *work;

  integer lda;
  integer n;
  integer lwork;

  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  __out__ = NumRu::Lapack.clantr( norm, uplo, diag, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL             FUNCTION CLANTR( NORM, UPLO, DIAG, M, N, A, LDA, WORK )\n\n*  Purpose\n*  =======\n*\n*  CLANTR  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  trapezoidal or triangular matrix A.\n*\n*  Description\n*  ===========\n*\n*  CLANTR returns the value\n*\n*     CLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in CLANTR as described\n*          above.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the matrix A is upper or lower trapezoidal.\n*          = 'U':  Upper trapezoidal\n*          = 'L':  Lower trapezoidal\n*          Note that A is triangular instead of trapezoidal if M = N.\n*\n*  DIAG    (input) CHARACTER*1\n*          Specifies whether or not the matrix A has unit diagonal.\n*          = 'N':  Non-unit diagonal\n*          = 'U':  Unit diagonal\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.  M >= 0, and if\n*          UPLO = 'U', M <= N.  When M = 0, CLANTR is set to zero.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.  N >= 0, and if\n*          UPLO = 'L', N <= M.  When N = 0, CLANTR is set to zero.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The trapezoidal matrix A (A is triangular if M = N).\n*          If UPLO = 'U', the leading m by n upper trapezoidal part of\n*          the array A contains the upper trapezoidal matrix, and the\n*          strictly lower triangular part of A is not referenced.\n*          If UPLO = 'L', the leading m by n lower trapezoidal part of\n*          the array A contains the lower trapezoidal matrix, and the\n*          strictly upper triangular part of A is not referenced.  Note\n*          that when DIAG = 'U', the diagonal elements of A are not\n*          referenced and are assumed to be one.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(M,1).\n*\n*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),\n*          where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n*          referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.clantr( norm, uplo, diag, m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_diag = argv[2];
  rblapack_m = argv[3];
  rblapack_a = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  m = NUM2INT(rblapack_m);
  lwork = lsame_(&norm,"I") ? m : 0;
  work = ALLOC_N(real, (MAX(1,lwork)));

  __out__ = clantr_(&norm, &uplo, &diag, &m, &n, a, &lda, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_clantr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clantr", rblapack_clantr, -1);
}
ruby-lapack-1.7.2/ext/zpbrfs.c0000644000175000017500000002072312502221024016033 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zpbrfs_(char* uplo, integer* n, integer* kd, integer* nrhs, doublecomplex* ab, integer* ldab, doublecomplex* afb, integer* ldafb, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zpbrfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_afb;
  doublecomplex *afb; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer ldab;
  integer n;
  integer ldafb;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.zpbrfs( uplo, kd, ab, afb, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPBRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is Hermitian positive definite\n*  and banded, and provides error bounds and backward error estimates\n*  for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)\n*          The upper or lower triangle of the Hermitian band matrix A,\n*          stored in the first KD+1 rows of the array.  The j-th column\n*          of A is stored in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  AFB     (input) COMPLEX*16 array, dimension (LDAFB,N)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**H*U or A = L*L**H of the band matrix A as computed by\n*          ZPBTRF, in the same storage format as A (see AB).\n*\n*  LDAFB   (input) INTEGER\n*          The leading dimension of the array AFB.  LDAFB >= KD+1.\n*\n*  B       (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) COMPLEX*16 array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by ZPBTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.zpbrfs( uplo, kd, ab, afb, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  rblapack_afb = argv[3];
  rblapack_b = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  kd = NUM2INT(rblapack_kd);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (4th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (4th argument) must be %d", 2);
  ldafb = NA_SHAPE0(rblapack_afb);
  if (NA_SHAPE1(rblapack_afb) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_afb) != NA_DCOMPLEX)
    rblapack_afb = na_change_type(rblapack_afb, NA_DCOMPLEX);
  afb = NA_PTR_TYPE(rblapack_afb, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (n));

  zpbrfs_(&uplo, &n, &kd, &nrhs, ab, &ldab, afb, &ldafb, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_zpbrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zpbrfs", rblapack_zpbrfs, -1);
}
ruby-lapack-1.7.2/ext/ctgsy2.c0000644000175000017500000003014412502221026015740 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctgsy2_(char* trans, integer* ijob, integer* m, integer* n, complex* a, integer* lda, complex* b, integer* ldb, complex* c, integer* ldc, complex* d, integer* ldd, complex* e, integer* lde, complex* f, integer* ldf, real* scale, real* rdsum, real* rdscal, integer* info);


static VALUE
rblapack_ctgsy2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_ijob;
  integer ijob; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_c;
  complex *c; 
  VALUE rblapack_d;
  complex *d; 
  VALUE rblapack_e;
  complex *e; 
  VALUE rblapack_f;
  complex *f; 
  VALUE rblapack_rdsum;
  real rdsum; 
  VALUE rblapack_rdscal;
  real rdscal; 
  VALUE rblapack_scale;
  real scale; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  complex *c_out__;
  VALUE rblapack_f_out__;
  complex *f_out__;

  integer lda;
  integer m;
  integer ldb;
  integer n;
  integer ldc;
  integer ldd;
  integer lde;
  integer ldf;

  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  scale, info, c, f, rdsum, rdscal = NumRu::Lapack.ctgsy2( trans, ijob, a, b, c, d, e, f, rdsum, rdscal, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTGSY2 solves the generalized Sylvester equation\n*\n*              A * R - L * B = scale *   C               (1)\n*              D * R - L * E = scale * F\n*\n*  using Level 1 and 2 BLAS, where R and L are unknown M-by-N matrices,\n*  (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,\n*  N-by-N and M-by-N, respectively. A, B, D and E are upper triangular\n*  (i.e., (A,D) and (B,E) in generalized Schur form).\n*\n*  The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output\n*  scaling factor chosen to avoid overflow.\n*\n*  In matrix notation solving equation (1) corresponds to solve\n*  Zx = scale * b, where Z is defined as\n*\n*         Z = [ kron(In, A)  -kron(B', Im) ]             (2)\n*             [ kron(In, D)  -kron(E', Im) ],\n*\n*  Ik is the identity matrix of size k and X' is the transpose of X.\n*  kron(X, Y) is the Kronecker product between the matrices X and Y.\n*\n*  If TRANS = 'C', y in the conjugate transposed system Z'y = scale*b\n*  is solved for, which is equivalent to solve for R and L in\n*\n*              A' * R  + D' * L   = scale *  C           (3)\n*              R  * B' + L  * E'  = scale * -F\n*\n*  This case is used to compute an estimate of Dif[(A, D), (B, E)] =\n*  = sigma_min(Z) using reverse communicaton with CLACON.\n*\n*  CTGSY2 also (IJOB >= 1) contributes to the computation in CTGSYL\n*  of an upper bound on the separation between to matrix pairs. Then\n*  the input (A, D), (B, E) are sub-pencils of two matrix pairs in\n*  CTGSYL.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N', solve the generalized Sylvester equation (1).\n*          = 'T': solve the 'transposed' system (3).\n*\n*  IJOB    (input) INTEGER\n*          Specifies what kind of functionality to be performed.\n*          =0: solve (1) only.\n*          =1: A contribution from this subsystem to a Frobenius\n*              norm-based estimate of the separation between two matrix\n*              pairs is computed. (look ahead strategy is used).\n*          =2: A contribution from this subsystem to a Frobenius\n*              norm-based estimate of the separation between two matrix\n*              pairs is computed. (SGECON on sub-systems is used.)\n*          Not referenced if TRANS = 'T'.\n*\n*  M       (input) INTEGER\n*          On entry, M specifies the order of A and D, and the row\n*          dimension of C, F, R and L.\n*\n*  N       (input) INTEGER\n*          On entry, N specifies the order of B and E, and the column\n*          dimension of C, F, R and L.\n*\n*  A       (input) COMPLEX array, dimension (LDA, M)\n*          On entry, A contains an upper triangular matrix.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the matrix A. LDA >= max(1, M).\n*\n*  B       (input) COMPLEX array, dimension (LDB, N)\n*          On entry, B contains an upper triangular matrix.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the matrix B. LDB >= max(1, N).\n*\n*  C       (input/output) COMPLEX array, dimension (LDC, N)\n*          On entry, C contains the right-hand-side of the first matrix\n*          equation in (1).\n*          On exit, if IJOB = 0, C has been overwritten by the solution\n*          R.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the matrix C. LDC >= max(1, M).\n*\n*  D       (input) COMPLEX array, dimension (LDD, M)\n*          On entry, D contains an upper triangular matrix.\n*\n*  LDD     (input) INTEGER\n*          The leading dimension of the matrix D. LDD >= max(1, M).\n*\n*  E       (input) COMPLEX array, dimension (LDE, N)\n*          On entry, E contains an upper triangular matrix.\n*\n*  LDE     (input) INTEGER\n*          The leading dimension of the matrix E. LDE >= max(1, N).\n*\n*  F       (input/output) COMPLEX array, dimension (LDF, N)\n*          On entry, F contains the right-hand-side of the second matrix\n*          equation in (1).\n*          On exit, if IJOB = 0, F has been overwritten by the solution\n*          L.\n*\n*  LDF     (input) INTEGER\n*          The leading dimension of the matrix F. LDF >= max(1, M).\n*\n*  SCALE   (output) REAL\n*          On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions\n*          R and L (C and F on entry) will hold the solutions to a\n*          slightly perturbed system but the input matrices A, B, D and\n*          E have not been changed. If SCALE = 0, R and L will hold the\n*          solutions to the homogeneous system with C = F = 0.\n*          Normally, SCALE = 1.\n*\n*  RDSUM   (input/output) REAL\n*          On entry, the sum of squares of computed contributions to\n*          the Dif-estimate under computation by CTGSYL, where the\n*          scaling factor RDSCAL (see below) has been factored out.\n*          On exit, the corresponding sum of squares updated with the\n*          contributions from the current sub-system.\n*          If TRANS = 'T' RDSUM is not touched.\n*          NOTE: RDSUM only makes sense when CTGSY2 is called by\n*          CTGSYL.\n*\n*  RDSCAL  (input/output) REAL\n*          On entry, scaling factor used to prevent overflow in RDSUM.\n*          On exit, RDSCAL is updated w.r.t. the current contributions\n*          in RDSUM.\n*          If TRANS = 'T', RDSCAL is not touched.\n*          NOTE: RDSCAL only makes sense when CTGSY2 is called by\n*          CTGSYL.\n*\n*  INFO    (output) INTEGER\n*          On exit, if INFO is set to\n*            =0: Successful exit\n*            <0: If INFO = -i, input argument number i is illegal.\n*            >0: The matrix pairs (A, D) and (B, E) have common or very\n*                close eigenvalues.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, info, c, f, rdsum, rdscal = NumRu::Lapack.ctgsy2( trans, ijob, a, b, c, d, e, f, rdsum, rdscal, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_trans = argv[0];
  rblapack_ijob = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  rblapack_c = argv[4];
  rblapack_d = argv[5];
  rblapack_e = argv[6];
  rblapack_f = argv[7];
  rblapack_rdsum = argv[8];
  rblapack_rdscal = argv[9];
  if (argc == 10) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, complex*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (7th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 2)
    rb_raise(rb_eArgError, "rank of e (7th argument) must be %d", 2);
  lde = NA_SHAPE0(rblapack_e);
  if (NA_SHAPE1(rblapack_e) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of e must be the same as shape 1 of c");
  if (NA_TYPE(rblapack_e) != NA_SCOMPLEX)
    rblapack_e = na_change_type(rblapack_e, NA_SCOMPLEX);
  e = NA_PTR_TYPE(rblapack_e, complex*);
  rdsum = (real)NUM2DBL(rblapack_rdsum);
  ijob = NUM2INT(rblapack_ijob);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (6th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 2)
    rb_raise(rb_eArgError, "rank of d (6th argument) must be %d", 2);
  ldd = NA_SHAPE0(rblapack_d);
  if (NA_SHAPE1(rblapack_d) != m)
    rb_raise(rb_eRuntimeError, "shape 1 of d must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_d) != NA_SCOMPLEX)
    rblapack_d = na_change_type(rblapack_d, NA_SCOMPLEX);
  d = NA_PTR_TYPE(rblapack_d, complex*);
  rdscal = (real)NUM2DBL(rblapack_rdscal);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of c");
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (!NA_IsNArray(rblapack_f))
    rb_raise(rb_eArgError, "f (8th argument) must be NArray");
  if (NA_RANK(rblapack_f) != 2)
    rb_raise(rb_eArgError, "rank of f (8th argument) must be %d", 2);
  ldf = NA_SHAPE0(rblapack_f);
  if (NA_SHAPE1(rblapack_f) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of f must be the same as shape 1 of c");
  if (NA_TYPE(rblapack_f) != NA_SCOMPLEX)
    rblapack_f = na_change_type(rblapack_f, NA_SCOMPLEX);
  f = NA_PTR_TYPE(rblapack_f, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
  MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldf;
    shape[1] = n;
    rblapack_f_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  f_out__ = NA_PTR_TYPE(rblapack_f_out__, complex*);
  MEMCPY(f_out__, f, complex, NA_TOTAL(rblapack_f));
  rblapack_f = rblapack_f_out__;
  f = f_out__;

  ctgsy2_(&trans, &ijob, &m, &n, a, &lda, b, &ldb, c, &ldc, d, &ldd, e, &lde, f, &ldf, &scale, &rdsum, &rdscal, &info);

  rblapack_scale = rb_float_new((double)scale);
  rblapack_info = INT2NUM(info);
  rblapack_rdsum = rb_float_new((double)rdsum);
  rblapack_rdscal = rb_float_new((double)rdscal);
  return rb_ary_new3(6, rblapack_scale, rblapack_info, rblapack_c, rblapack_f, rblapack_rdsum, rblapack_rdscal);
}

void
init_lapack_ctgsy2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctgsy2", rblapack_ctgsy2, -1);
}
ruby-lapack-1.7.2/ext/cpbtrs.c0000644000175000017500000001214212502221023016015 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cpbtrs_(char* uplo, integer* n, integer* kd, integer* nrhs, complex* ab, integer* ldab, complex* b, integer* ldb, integer* info);


static VALUE
rblapack_cpbtrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer ldab;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.cpbtrs( uplo, kd, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPBTRS solves a system of linear equations A*X = B with a Hermitian\n*  positive definite band matrix A using the Cholesky factorization\n*  A = U**H*U or A = L*L**H computed by CPBTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangular factor stored in AB;\n*          = 'L':  Lower triangular factor stored in AB.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AB      (input) COMPLEX array, dimension (LDAB,N)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**H*U or A = L*L**H of the band matrix A, stored in the\n*          first KD+1 rows of the array.  The j-th column of U or L is\n*          stored in the j-th column of the array AB as follows:\n*          if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO ='L', AB(1+i-j,j)    = L(i,j) for j<=i<=min(n,j+kd).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            UPPER\n      INTEGER            J\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CTBSV, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.cpbtrs( uplo, kd, ab, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  kd = NUM2INT(rblapack_kd);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  cpbtrs_(&uplo, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_cpbtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cpbtrs", rblapack_cpbtrs, -1);
}
ruby-lapack-1.7.2/ext/dlag2.c0000644000175000017500000001531412655767574015560 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlag2_(doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* safmin, doublereal* scale1, doublereal* scale2, doublereal* wr1, doublereal* wr2, doublereal* wi);


static VALUE
rblapack_dlag2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_safmin;
  doublereal safmin; 
  VALUE rblapack_scale1;
  doublereal scale1; 
  VALUE rblapack_scale2;
  doublereal scale2; 
  VALUE rblapack_wr1;
  doublereal wr1; 
  VALUE rblapack_wr2;
  doublereal wr2; 
  VALUE rblapack_wi;
  doublereal wi; 

  integer lda;
  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  scale1, scale2, wr1, wr2, wi = NumRu::Lapack.dlag2( a, b, safmin, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, WR2, WI )\n\n*  Purpose\n*  =======\n*\n*  DLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue\n*  problem  A - w B, with scaling as necessary to avoid over-/underflow.\n*\n*  The scaling factor \"s\" results in a modified eigenvalue equation\n*\n*      s A - w B\n*\n*  where  s  is a non-negative scaling factor chosen so that  w,  w B,\n*  and  s A  do not overflow and, if possible, do not underflow, either.\n*\n\n*  Arguments\n*  =========\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA, 2)\n*          On entry, the 2 x 2 matrix A.  It is assumed that its 1-norm\n*          is less than 1/SAFMIN.  Entries less than\n*          sqrt(SAFMIN)*norm(A) are subject to being treated as zero.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= 2.\n*\n*  B       (input) DOUBLE PRECISION array, dimension (LDB, 2)\n*          On entry, the 2 x 2 upper triangular matrix B.  It is\n*          assumed that the one-norm of B is less than 1/SAFMIN.  The\n*          diagonals should be at least sqrt(SAFMIN) times the largest\n*          element of B (in absolute value); if a diagonal is smaller\n*          than that, then  +/- sqrt(SAFMIN) will be used instead of\n*          that diagonal.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= 2.\n*\n*  SAFMIN  (input) DOUBLE PRECISION\n*          The smallest positive number s.t. 1/SAFMIN does not\n*          overflow.  (This should always be DLAMCH('S') -- it is an\n*          argument in order to avoid having to call DLAMCH frequently.)\n*\n*  SCALE1  (output) DOUBLE PRECISION\n*          A scaling factor used to avoid over-/underflow in the\n*          eigenvalue equation which defines the first eigenvalue.  If\n*          the eigenvalues are complex, then the eigenvalues are\n*          ( WR1  +/-  WI i ) / SCALE1  (which may lie outside the\n*          exponent range of the machine), SCALE1=SCALE2, and SCALE1\n*          will always be positive.  If the eigenvalues are real, then\n*          the first (real) eigenvalue is  WR1 / SCALE1 , but this may\n*          overflow or underflow, and in fact, SCALE1 may be zero or\n*          less than the underflow threshold if the exact eigenvalue\n*          is sufficiently large.\n*\n*  SCALE2  (output) DOUBLE PRECISION\n*          A scaling factor used to avoid over-/underflow in the\n*          eigenvalue equation which defines the second eigenvalue.  If\n*          the eigenvalues are complex, then SCALE2=SCALE1.  If the\n*          eigenvalues are real, then the second (real) eigenvalue is\n*          WR2 / SCALE2 , but this may overflow or underflow, and in\n*          fact, SCALE2 may be zero or less than the underflow\n*          threshold if the exact eigenvalue is sufficiently large.\n*\n*  WR1     (output) DOUBLE PRECISION\n*          If the eigenvalue is real, then WR1 is SCALE1 times the\n*          eigenvalue closest to the (2,2) element of A B**(-1).  If the\n*          eigenvalue is complex, then WR1=WR2 is SCALE1 times the real\n*          part of the eigenvalues.\n*\n*  WR2     (output) DOUBLE PRECISION\n*          If the eigenvalue is real, then WR2 is SCALE2 times the\n*          other eigenvalue.  If the eigenvalue is complex, then\n*          WR1=WR2 is SCALE1 times the real part of the eigenvalues.\n*\n*  WI      (output) DOUBLE PRECISION\n*          If the eigenvalue is real, then WI is zero.  If the\n*          eigenvalue is complex, then WI is SCALE1 times the imaginary\n*          part of the eigenvalues.  WI will always be non-negative.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale1, scale2, wr1, wr2, wi = NumRu::Lapack.dlag2( a, b, safmin, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  rblapack_safmin = argv[2];
  if (argc == 3) {
  } 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);
  if (NA_SHAPE1(rblapack_a) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", 2);
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  safmin = NUM2DBL(rblapack_safmin);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of b must be %d", 2);
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);

  dlag2_(a, &lda, b, &ldb, &safmin, &scale1, &scale2, &wr1, &wr2, &wi);

  rblapack_scale1 = rb_float_new((double)scale1);
  rblapack_scale2 = rb_float_new((double)scale2);
  rblapack_wr1 = rb_float_new((double)wr1);
  rblapack_wr2 = rb_float_new((double)wr2);
  rblapack_wi = rb_float_new((double)wi);
  return rb_ary_new3(5, rblapack_scale1, rblapack_scale2, rblapack_wr1, rblapack_wr2, rblapack_wi);
}

void
init_lapack_dlag2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlag2", rblapack_dlag2, -1);
}
ruby-lapack-1.7.2/ext/stzrqf.c0000644000175000017500000001146112502221016016056 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID stzrqf_(integer* m, integer* n, real* a, integer* lda, real* tau, integer* info);


static VALUE
rblapack_stzrqf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;

  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.stzrqf( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STZRQF( M, N, A, LDA, TAU, INFO )\n\n*  Purpose\n*  =======\n*\n*  This routine is deprecated and has been replaced by routine STZRZF.\n*\n*  STZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A\n*  to upper triangular form by means of orthogonal transformations.\n*\n*  The upper trapezoidal matrix A is factored as\n*\n*     A = ( R  0 ) * Z,\n*\n*  where Z is an N-by-N orthogonal matrix and R is an M-by-M upper\n*  triangular matrix.\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 >= M.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the leading M-by-N upper trapezoidal part of the\n*          array A must contain the matrix to be factorized.\n*          On exit, the leading M-by-M upper triangular part of A\n*          contains the upper triangular matrix R, and elements M+1 to\n*          N of the first M rows of A, with the array TAU, represent the\n*          orthogonal matrix Z as a product of M elementary reflectors.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  TAU     (output) REAL array, dimension (M)\n*          The scalar factors of the elementary reflectors.\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 factorization is obtained by Householder's method.  The kth\n*  transformation matrix, Z( k ), which is used to introduce zeros into\n*  the ( m - k + 1 )th row of A, is given in the form\n*\n*     Z( k ) = ( I     0   ),\n*              ( 0  T( k ) )\n*\n*  where\n*\n*     T( k ) = I - tau*u( k )*u( k )',   u( k ) = (   1    ),\n*                                                 (   0    )\n*                                                 ( z( k ) )\n*\n*  tau is a scalar and z( k ) is an ( n - m ) element vector.\n*  tau and z( k ) are chosen to annihilate the elements of the kth row\n*  of X.\n*\n*  The scalar tau is returned in the kth element of TAU and the vector\n*  u( k ) in the kth row of A, such that the elements of z( k ) are\n*  in  a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n*  the upper triangular part of A.\n*\n*  Z is given by\n*\n*     Z =  Z( 1 ) * Z( 2 ) * ... * Z( m ).\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.stzrqf( 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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  m = lda;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  stzrqf_(&m, &n, a, &lda, tau, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
}

void
init_lapack_stzrqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "stzrqf", rblapack_stzrqf, -1);
}
ruby-lapack-1.7.2/ext/sstev.c0000644000175000017500000001211312502221015015663 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sstev_(char* jobz, integer* n, real* d, real* e, real* z, integer* ldz, real* work, integer* info);


static VALUE
rblapack_sstev(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_e_out__;
  real *e_out__;
  real *work;

  integer n;
  integer ldz;

  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  z, info, d, e = NumRu::Lapack.sstev( jobz, d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSTEV computes all eigenvalues and, optionally, eigenvectors of a\n*  real symmetric tridiagonal matrix A.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  D       (input/output) REAL array, dimension (N)\n*          On entry, the n diagonal elements of the tridiagonal matrix\n*          A.\n*          On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n*  E       (input/output) REAL array, dimension (N-1)\n*          On entry, the (n-1) subdiagonal elements of the tridiagonal\n*          matrix A, stored in elements 1 to N-1 of E.\n*          On exit, the contents of E are destroyed.\n*\n*  Z       (output) REAL array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n*          eigenvectors of the matrix A, with the i-th column of Z\n*          holding the eigenvector associated with D(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace) REAL array, dimension (max(1,2*N-2))\n*          If JOBZ = 'N', WORK is not referenced.\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 algorithm failed to converge; i\n*                off-diagonal elements of E did not converge to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  z, info, d, e = NumRu::Lapack.sstev( jobz, d, e, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_jobz = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
  MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  work = ALLOC_N(real, (lsame_(&jobz,"N") ? 0 : MAX(1,2*n-2)));

  sstev_(&jobz, &n, d, e, z, &ldz, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_z, rblapack_info, rblapack_d, rblapack_e);
}

void
init_lapack_sstev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sstev", rblapack_sstev, -1);
}
ruby-lapack-1.7.2/ext/dlapll.c0000644000175000017500000001121312502221012015764 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlapll_(integer* n, doublereal* x, integer* incx, doublereal* y, integer* incy, doublereal* ssmin);


static VALUE
rblapack_dlapll(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_y;
  doublereal *y; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_ssmin;
  doublereal ssmin; 
  VALUE rblapack_x_out__;
  doublereal *x_out__;
  VALUE rblapack_y_out__;
  doublereal *y_out__;


  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  ssmin, x, y = NumRu::Lapack.dlapll( n, x, incx, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAPLL( N, X, INCX, Y, INCY, SSMIN )\n\n*  Purpose\n*  =======\n*\n*  Given two column vectors X and Y, let\n*\n*                       A = ( X Y ).\n*\n*  The subroutine first computes the QR factorization of A = Q*R,\n*  and then computes the SVD of the 2-by-2 upper triangular matrix R.\n*  The smaller singular value of R is returned in SSMIN, which is used\n*  as the measurement of the linear dependency of the vectors X and Y.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The length of the vectors X and Y.\n*\n*  X       (input/output) DOUBLE PRECISION array,\n*                         dimension (1+(N-1)*INCX)\n*          On entry, X contains the N-vector X.\n*          On exit, X is overwritten.\n*\n*  INCX    (input) INTEGER\n*          The increment between successive elements of X. INCX > 0.\n*\n*  Y       (input/output) DOUBLE PRECISION array,\n*                         dimension (1+(N-1)*INCY)\n*          On entry, Y contains the N-vector Y.\n*          On exit, Y is overwritten.\n*\n*  INCY    (input) INTEGER\n*          The increment between successive elements of Y. INCY > 0.\n*\n*  SSMIN   (output) DOUBLE PRECISION\n*          The smallest singular value of the N-by-2 matrix A = ( X Y ).\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ssmin, x, y = NumRu::Lapack.dlapll( n, x, incx, y, incy, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_n = argv[0];
  rblapack_x = argv[1];
  rblapack_incx = argv[2];
  rblapack_y = argv[3];
  rblapack_incy = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  incx = NUM2INT(rblapack_incx);
  incy = NUM2INT(rblapack_incy);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1+(n-1)*incx))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (4th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incy))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
  if (NA_TYPE(rblapack_y) != NA_DFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
  y = NA_PTR_TYPE(rblapack_y, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incx;
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incy;
    rblapack_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
  MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  dlapll_(&n, x, &incx, y, &incy, &ssmin);

  rblapack_ssmin = rb_float_new((double)ssmin);
  return rb_ary_new3(3, rblapack_ssmin, rblapack_x, rblapack_y);
}

void
init_lapack_dlapll(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlapll", rblapack_dlapll, -1);
}
ruby-lapack-1.7.2/ext/zgeequb.c0000644000175000017500000001274712502221024016176 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgeequb_(integer* m, integer* n, doublecomplex* a, integer* lda, doublereal* r, doublereal* c, doublereal* rowcnd, doublereal* colcnd, doublereal* amax, integer* info);


static VALUE
rblapack_zgeequb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_r;
  doublereal *r; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_rowcnd;
  doublereal rowcnd; 
  VALUE rblapack_colcnd;
  doublereal colcnd; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_info;
  integer info; 

  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  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.zgeequb( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGEEQUB computes row and column scalings intended to equilibrate an\n*  M-by-N matrix A and reduce its condition number.  R returns the row\n*  scale factors and C the column scale factors, chosen to try to make\n*  the largest element in each row and column of the matrix B with\n*  elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n*  the radix.\n*\n*  R(i) and C(j) are restricted to be a power of the radix between\n*  SMLNUM = smallest safe number and BIGNUM = largest safe number.  Use\n*  of these scaling factors is not guaranteed to reduce the condition\n*  number of A but works well in practice.\n*\n*  This routine differs from ZGEEQU by restricting the scaling factors\n*  to a power of the radix.  Baring over- and underflow, scaling by\n*  these factors introduces no additional rounding errors.  However, the\n*  scaled entries' magnitured are no longer approximately 1 but lie\n*  between sqrt(radix) and 1/sqrt(radix).\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) COMPLEX*16 array, dimension (LDA,N)\n*          The M-by-N matrix whose equilibration factors are\n*          to be computed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  R       (output) DOUBLE PRECISION array, dimension (M)\n*          If INFO = 0 or INFO > M, R contains the row scale factors\n*          for A.\n*\n*  C       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0,  C contains the column scale factors for A.\n*\n*  ROWCND  (output) DOUBLE PRECISION\n*          If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n*          smallest R(i) to the largest R(i).  If ROWCND >= 0.1 and\n*          AMAX is neither too large nor too small, it is not worth\n*          scaling by R.\n*\n*  COLCND  (output) DOUBLE PRECISION\n*          If INFO = 0, COLCND contains the ratio of the smallest\n*          C(i) to the largest C(i).  If COLCND >= 0.1, it is not\n*          worth scaling by C.\n*\n*  AMAX    (output) DOUBLE PRECISION\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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,  and i is\n*                <= M:  the i-th row of A is exactly zero\n*                >  M:  the (i-M)-th column of A is exactly zero\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.zgeequb( 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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  m = lda;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_r = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  r = NA_PTR_TYPE(rblapack_r, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  c = NA_PTR_TYPE(rblapack_c, doublereal*);

  zgeequb_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &info);

  rblapack_rowcnd = rb_float_new((double)rowcnd);
  rblapack_colcnd = rb_float_new((double)colcnd);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
}

void
init_lapack_zgeequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgeequb", rblapack_zgeequb, -1);
}
ruby-lapack-1.7.2/ext/zla_porcond_x.c0000644000175000017500000001507512502221021017367 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal zla_porcond_x_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, doublecomplex* x, integer* info, doublecomplex* work, doublereal* rwork);


static VALUE
rblapack_zla_porcond_x(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_rwork;
  doublereal *rwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack___out__;
  doublereal __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  info, __out__ = NumRu::Lapack.zla_porcond_x( uplo, a, af, x, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION ZLA_PORCOND_X( UPLO, N, A, LDA, AF, LDAF, X, INFO, WORK, RWORK )\n\n*  Purpose\n*  =======\n*\n*     ZLA_PORCOND_X Computes the infinity norm condition number of\n*     op(A) * diag(X) where X is a COMPLEX*16 vector.\n*\n\n*  Arguments\n*  =========\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     A       (input) COMPLEX*16 array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX*16 array, dimension (LDAF,N)\n*     The triangular factor U or L from the Cholesky factorization\n*     A = U**T*U or A = L*L**T, as computed by ZPOTRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     X       (input) COMPLEX*16 array, dimension (N)\n*     The vector X in the formula op(A) * diag(X).\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit.\n*     i > 0:  The ith argument is invalid.\n*\n*     WORK    (input) COMPLEX*16 array, dimension (2*N).\n*     Workspace.\n*\n*     RWORK   (input) DOUBLE PRECISION array, dimension (N).\n*     Workspace.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            KASE, I, J\n      DOUBLE PRECISION   AINVNM, ANORM, TMP\n      LOGICAL            UP\n      COMPLEX*16         ZDUM\n*     ..\n*     .. Local Arrays ..\n      INTEGER            ISAVE( 3 )\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           ZLACN2, ZPOTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX, REAL, DIMAG\n*     ..\n*     .. Statement Functions ..\n      DOUBLE PRECISION CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, __out__ = NumRu::Lapack.zla_porcond_x( uplo, a, af, x, work, rwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_x = argv[3];
  rblapack_work = argv[4];
  rblapack_rwork = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  if (!NA_IsNArray(rblapack_rwork))
    rb_raise(rb_eArgError, "rwork (6th argument) must be NArray");
  if (NA_RANK(rblapack_rwork) != 1)
    rb_raise(rb_eArgError, "rank of rwork (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_rwork) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_rwork) != NA_DFLOAT)
    rblapack_rwork = na_change_type(rblapack_rwork, NA_DFLOAT);
  rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (4th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (5th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
  if (NA_TYPE(rblapack_work) != NA_DCOMPLEX)
    rblapack_work = na_change_type(rblapack_work, NA_DCOMPLEX);
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);

  __out__ = zla_porcond_x_(&uplo, &n, a, &lda, af, &ldaf, x, &info, work, rwork);

  rblapack_info = INT2NUM(info);
  rblapack___out__ = rb_float_new((double)__out__);
  return rb_ary_new3(2, rblapack_info, rblapack___out__);
}

void
init_lapack_zla_porcond_x(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zla_porcond_x", rblapack_zla_porcond_x, -1);
}
ruby-lapack-1.7.2/ext/slasq4.c0000644000175000017500000001074012502221025015733 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slasq4_(integer* i0, integer* n0, real* z, integer* pp, integer* n0in, real* dmin, real* dmin1, real* dmin2, real* dn, real* dn1, real* dn2, real* tau, integer* ttype, real* g);


static VALUE
rblapack_slasq4(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_i0;
  integer i0; 
  VALUE rblapack_n0;
  integer n0; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_pp;
  integer pp; 
  VALUE rblapack_n0in;
  integer n0in; 
  VALUE rblapack_dmin;
  real dmin; 
  VALUE rblapack_dmin1;
  real dmin1; 
  VALUE rblapack_dmin2;
  real dmin2; 
  VALUE rblapack_dn;
  real dn; 
  VALUE rblapack_dn1;
  real dn1; 
  VALUE rblapack_dn2;
  real dn2; 
  VALUE rblapack_g;
  real g; 
  VALUE rblapack_tau;
  real tau; 
  VALUE rblapack_ttype;
  integer ttype; 


  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, ttype, g = NumRu::Lapack.slasq4( i0, n0, z, pp, n0in, dmin, dmin1, dmin2, dn, dn1, dn2, g, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1, DN2, TAU, TTYPE, G )\n\n*  Purpose\n*  =======\n*\n*  SLASQ4 computes an approximation TAU to the smallest eigenvalue\n*  using values of d from the previous transform.\n*\n\n*  I0    (input) INTEGER\n*        First index.\n*\n*  N0    (input) INTEGER\n*        Last index.\n*\n*  Z     (input) REAL array, dimension ( 4*N )\n*        Z holds the qd array.\n*\n*  PP    (input) INTEGER\n*        PP=0 for ping, PP=1 for pong.\n*\n*  NOIN  (input) INTEGER\n*        The value of N0 at start of EIGTEST.\n*\n*  DMIN  (input) REAL\n*        Minimum value of d.\n*\n*  DMIN1 (input) REAL\n*        Minimum value of d, excluding D( N0 ).\n*\n*  DMIN2 (input) REAL\n*        Minimum value of d, excluding D( N0 ) and D( N0-1 ).\n*\n*  DN    (input) REAL\n*        d(N)\n*\n*  DN1   (input) REAL\n*        d(N-1)\n*\n*  DN2   (input) REAL\n*        d(N-2)\n*\n*  TAU   (output) REAL\n*        This is the shift.\n*\n*  TTYPE (output) INTEGER\n*        Shift type.\n*\n*  G     (input/output) REAL\n*        G is passed as an argument in order to save its value between\n*        calls to SLASQ4.\n*\n\n*  Further Details\n*  ===============\n*  CNST1 = 9/16\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, ttype, g = NumRu::Lapack.slasq4( i0, n0, z, pp, n0in, dmin, dmin1, dmin2, dn, dn1, dn2, g, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_i0 = argv[0];
  rblapack_n0 = argv[1];
  rblapack_z = argv[2];
  rblapack_pp = argv[3];
  rblapack_n0in = argv[4];
  rblapack_dmin = argv[5];
  rblapack_dmin1 = argv[6];
  rblapack_dmin2 = argv[7];
  rblapack_dn = argv[8];
  rblapack_dn1 = argv[9];
  rblapack_dn2 = argv[10];
  rblapack_g = argv[11];
  if (argc == 12) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  i0 = NUM2INT(rblapack_i0);
  pp = NUM2INT(rblapack_pp);
  dmin = (real)NUM2DBL(rblapack_dmin);
  dmin2 = (real)NUM2DBL(rblapack_dmin2);
  dn1 = (real)NUM2DBL(rblapack_dn1);
  g = (real)NUM2DBL(rblapack_g);
  n0 = NUM2INT(rblapack_n0);
  n0in = NUM2INT(rblapack_n0in);
  dn = (real)NUM2DBL(rblapack_dn);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (3th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != (4*n0))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 4*n0);
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  dn2 = (real)NUM2DBL(rblapack_dn2);
  dmin1 = (real)NUM2DBL(rblapack_dmin1);

  slasq4_(&i0, &n0, z, &pp, &n0in, &dmin, &dmin1, &dmin2, &dn, &dn1, &dn2, &tau, &ttype, &g);

  rblapack_tau = rb_float_new((double)tau);
  rblapack_ttype = INT2NUM(ttype);
  rblapack_g = rb_float_new((double)g);
  return rb_ary_new3(3, rblapack_tau, rblapack_ttype, rblapack_g);
}

void
init_lapack_slasq4(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slasq4", rblapack_slasq4, -1);
}
ruby-lapack-1.7.2/ext/zhbtrd.c0000644000175000017500000001577712502221017016041 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhbtrd_(char* vect, char* uplo, integer* n, integer* kd, doublecomplex* ab, integer* ldab, doublereal* d, doublereal* e, doublecomplex* q, integer* ldq, doublecomplex* work, integer* info);


static VALUE
rblapack_zhbtrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_vect;
  char vect; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_q;
  doublecomplex *q; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublecomplex *ab_out__;
  VALUE rblapack_q_out__;
  doublecomplex *q_out__;
  doublecomplex *work;

  integer ldab;
  integer n;
  integer ldq;

  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  d, e, info, ab, q = NumRu::Lapack.zhbtrd( vect, uplo, kd, ab, q, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHBTRD reduces a complex Hermitian band matrix A to real symmetric\n*  tridiagonal form T by a unitary similarity transformation:\n*  Q**H * A * Q = T.\n*\n\n*  Arguments\n*  =========\n*\n*  VECT    (input) CHARACTER*1\n*          = 'N':  do not form Q;\n*          = 'V':  form Q;\n*          = 'U':  update a matrix X, by forming X*Q.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*          On exit, the diagonal elements of AB are overwritten by the\n*          diagonal elements of the tridiagonal matrix T; if KD > 0, the\n*          elements on the first superdiagonal (if UPLO = 'U') or the\n*          first subdiagonal (if UPLO = 'L') are overwritten by the\n*          off-diagonal elements of T; the rest of AB is overwritten by\n*          values generated during the reduction.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  D       (output) DOUBLE PRECISION array, dimension (N)\n*          The diagonal elements of the tridiagonal matrix T.\n*\n*  E       (output) DOUBLE PRECISION array, dimension (N-1)\n*          The off-diagonal elements of the tridiagonal matrix T:\n*          E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.\n*\n*  Q       (input/output) COMPLEX*16 array, dimension (LDQ,N)\n*          On entry, if VECT = 'U', then Q must contain an N-by-N\n*          matrix X; if VECT = 'N' or 'V', then Q need not be set.\n*\n*          On exit:\n*          if VECT = 'V', Q contains the N-by-N unitary matrix Q;\n*          if VECT = 'U', Q contains the product X*Q;\n*          if VECT = 'N', the array Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.\n*          LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (N)\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*  Modified by Linda Kaufman, Bell Labs.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, info, ab, q = NumRu::Lapack.zhbtrd( vect, uplo, kd, ab, q, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_vect = argv[0];
  rblapack_uplo = argv[1];
  rblapack_kd = argv[2];
  rblapack_ab = argv[3];
  rblapack_q = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  vect = StringValueCStr(rblapack_vect)[0];
  kd = NUM2INT(rblapack_kd);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (5th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  n = NA_SHAPE1(rblapack_q);
  if (NA_TYPE(rblapack_q) != NA_DCOMPLEX)
    rblapack_q = na_change_type(rblapack_q, NA_DCOMPLEX);
  q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of q");
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
  MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublecomplex*);
  MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  work = ALLOC_N(doublecomplex, (n));

  zhbtrd_(&vect, &uplo, &n, &kd, ab, &ldab, d, e, q, &ldq, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_d, rblapack_e, rblapack_info, rblapack_ab, rblapack_q);
}

void
init_lapack_zhbtrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhbtrd", rblapack_zhbtrd, -1);
}
ruby-lapack-1.7.2/ext/claset.c0000644000175000017500000001035412502221014015776 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID claset_(char* uplo, integer* m, integer* n, complex* alpha, complex* beta, complex* a, integer* lda);


static VALUE
rblapack_claset(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_alpha;
  complex alpha; 
  VALUE rblapack_beta;
  complex beta; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_a_out__;
  complex *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  a = NumRu::Lapack.claset( uplo, m, alpha, beta, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLASET( UPLO, M, N, ALPHA, BETA, A, LDA )\n\n*  Purpose\n*  =======\n*\n*  CLASET initializes a 2-D array A to BETA on the diagonal and\n*  ALPHA on the offdiagonals.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies the part of the matrix A to be set.\n*          = 'U':      Upper triangular part is set. The lower triangle\n*                      is unchanged.\n*          = 'L':      Lower triangular part is set. The upper triangle\n*                      is unchanged.\n*          Otherwise:  All of the matrix A is set.\n*\n*  M       (input) INTEGER\n*          On entry, M specifies the number of rows of A.\n*\n*  N       (input) INTEGER\n*          On entry, N specifies the number of columns of A.\n*\n*  ALPHA   (input) COMPLEX\n*          All the offdiagonal array elements are set to ALPHA.\n*\n*  BETA    (input) COMPLEX\n*          All the diagonal array elements are set to BETA.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the m by n matrix A.\n*          On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j;\n*                   A(i,i) = BETA , 1 <= i <= min(m,n)\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  a = NumRu::Lapack.claset( uplo, m, alpha, beta, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_m = argv[1];
  rblapack_alpha = argv[2];
  rblapack_beta = argv[3];
  rblapack_a = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  alpha.r = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
  alpha.i = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  m = NUM2INT(rblapack_m);
  beta.r = (real)NUM2DBL(rb_funcall(rblapack_beta, rb_intern("real"), 0));
  beta.i = (real)NUM2DBL(rb_funcall(rblapack_beta, rb_intern("imag"), 0));
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  claset_(&uplo, &m, &n, &alpha, &beta, a, &lda);

  return rblapack_a;
}

void
init_lapack_claset(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "claset", rblapack_claset, -1);
}
ruby-lapack-1.7.2/ext/dgerqf.c0000644000175000017500000001364412502221026016003 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgerqf_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dgerqf(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.dgerqf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGERQF computes an RQ factorization of a real M-by-N matrix A:\n*  A = R * 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,\n*          if m <= n, the upper triangle of the subarray\n*          A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R;\n*          if m >= n, the elements on and above the (m-n)-th subdiagonal\n*          contain the M-by-N upper trapezoidal matrix R;\n*          the remaining elements, with the array TAU, represent the\n*          orthogonal matrix Q as a product of min(m,n) elementary\n*          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\n*          the 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(1) H(2) . . . H(k), 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(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n*  A(m-k+i,1:n-k+i-1), and tau in TAU(i).\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY\n      INTEGER            I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n     $                   MU, NB, NBMIN, NU, NX\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DGERQ2, 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.dgerqf( 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;
  }

  m = NUM2INT(rblapack_m);
  if (rblapack_lwork == Qnil)
    lwork = m;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  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*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;

  dgerqf_(&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_dgerqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgerqf", rblapack_dgerqf, -1);
}
ruby-lapack-1.7.2/ext/dggbak.c0000644000175000017500000001503712502221013015744 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dggbak_(char* job, char* side, integer* n, integer* ilo, integer* ihi, doublereal* lscale, doublereal* rscale, integer* m, doublereal* v, integer* ldv, integer* info);


static VALUE
rblapack_dggbak(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_lscale;
  doublereal *lscale; 
  VALUE rblapack_rscale;
  doublereal *rscale; 
  VALUE rblapack_v;
  doublereal *v; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_v_out__;
  doublereal *v_out__;

  integer n;
  integer ldv;
  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  info, v = NumRu::Lapack.dggbak( job, side, ilo, ihi, lscale, rscale, v, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGGBAK forms the right or left eigenvectors of a real generalized\n*  eigenvalue problem A*x = lambda*B*x, by backward transformation on\n*  the computed eigenvectors of the balanced pair of matrices output by\n*  DGGBAL.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies the type of backward transformation required:\n*          = 'N':  do nothing, return immediately;\n*          = 'P':  do backward transformation for permutation only;\n*          = 'S':  do backward transformation for scaling only;\n*          = 'B':  do backward transformations for both permutation and\n*                  scaling.\n*          JOB must be the same as the argument JOB supplied to DGGBAL.\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'R':  V contains right eigenvectors;\n*          = 'L':  V contains left eigenvectors.\n*\n*  N       (input) INTEGER\n*          The number of rows of the matrix V.  N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          The integers ILO and IHI determined by DGGBAL.\n*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n*  LSCALE  (input) DOUBLE PRECISION array, dimension (N)\n*          Details of the permutations and/or scaling factors applied\n*          to the left side of A and B, as returned by DGGBAL.\n*\n*  RSCALE  (input) DOUBLE PRECISION array, dimension (N)\n*          Details of the permutations and/or scaling factors applied\n*          to the right side of A and B, as returned by DGGBAL.\n*\n*  M       (input) INTEGER\n*          The number of columns of the matrix V.  M >= 0.\n*\n*  V       (input/output) DOUBLE PRECISION array, dimension (LDV,M)\n*          On entry, the matrix of right or left eigenvectors to be\n*          transformed, as returned by DTGEVC.\n*          On exit, V is overwritten by the transformed eigenvectors.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the matrix V. LDV >= max(1,N).\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*  See R.C. Ward, Balancing the generalized eigenvalue problem,\n*                 SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LEFTV, RIGHTV\n      INTEGER            I, K\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DSCAL, DSWAP, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, v = NumRu::Lapack.dggbak( job, side, ilo, ihi, lscale, rscale, v, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_job = argv[0];
  rblapack_side = argv[1];
  rblapack_ilo = argv[2];
  rblapack_ihi = argv[3];
  rblapack_lscale = argv[4];
  rblapack_rscale = argv[5];
  rblapack_v = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  job = StringValueCStr(rblapack_job)[0];
  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_lscale))
    rb_raise(rb_eArgError, "lscale (5th argument) must be NArray");
  if (NA_RANK(rblapack_lscale) != 1)
    rb_raise(rb_eArgError, "rank of lscale (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_lscale);
  if (NA_TYPE(rblapack_lscale) != NA_DFLOAT)
    rblapack_lscale = na_change_type(rblapack_lscale, NA_DFLOAT);
  lscale = NA_PTR_TYPE(rblapack_lscale, doublereal*);
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (7th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  m = NA_SHAPE1(rblapack_v);
  if (NA_TYPE(rblapack_v) != NA_DFLOAT)
    rblapack_v = na_change_type(rblapack_v, NA_DFLOAT);
  v = NA_PTR_TYPE(rblapack_v, doublereal*);
  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_rscale))
    rb_raise(rb_eArgError, "rscale (6th argument) must be NArray");
  if (NA_RANK(rblapack_rscale) != 1)
    rb_raise(rb_eArgError, "rank of rscale (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_rscale) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of rscale must be the same as shape 0 of lscale");
  if (NA_TYPE(rblapack_rscale) != NA_DFLOAT)
    rblapack_rscale = na_change_type(rblapack_rscale, NA_DFLOAT);
  rscale = NA_PTR_TYPE(rblapack_rscale, doublereal*);
  ihi = NUM2INT(rblapack_ihi);
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = m;
    rblapack_v_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  v_out__ = NA_PTR_TYPE(rblapack_v_out__, doublereal*);
  MEMCPY(v_out__, v, doublereal, NA_TOTAL(rblapack_v));
  rblapack_v = rblapack_v_out__;
  v = v_out__;

  dggbak_(&job, &side, &n, &ilo, &ihi, lscale, rscale, &m, v, &ldv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_v);
}

void
init_lapack_dggbak(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dggbak", rblapack_dggbak, -1);
}
ruby-lapack-1.7.2/ext/dlasyf.c0000644000175000017500000001425712502221022016012 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlasyf_(char* uplo, integer* n, integer* nb, integer* kb, doublereal* a, integer* lda, integer* ipiv, doublereal* w, integer* ldw, integer* info);


static VALUE
rblapack_dlasyf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_nb;
  integer nb; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_kb;
  integer kb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  doublereal *w;

  integer lda;
  integer n;
  integer ldw;

  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  kb, ipiv, info, a = NumRu::Lapack.dlasyf( uplo, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLASYF computes a partial factorization of a real symmetric matrix A\n*  using the Bunch-Kaufman diagonal pivoting method. The partial\n*  factorization has the form:\n*\n*  A  =  ( I  U12 ) ( A11  0  ) (  I    0   )  if UPLO = 'U', or:\n*        ( 0  U22 ) (  0   D  ) ( U12' U22' )\n*\n*  A  =  ( L11  0 ) (  D   0  ) ( L11' L21' )  if UPLO = 'L'\n*        ( L21  I ) (  0  A22 ) (  0    I   )\n*\n*  where the order of D is at most NB. The actual order is returned in\n*  the argument KB, and is either NB or NB-1, or N if N <= NB.\n*\n*  DLASYF is an auxiliary routine called by DSYTRF. It uses blocked code\n*  (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or\n*  A22 (if UPLO = 'L').\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored:\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NB      (input) INTEGER\n*          The maximum number of columns of the matrix A that should be\n*          factored.  NB should be at least 2 to allow for 2-by-2 pivot\n*          blocks.\n*\n*  KB      (output) INTEGER\n*          The number of columns of A that were actually factored.\n*          KB is either NB-1 or NB, or N if N <= NB.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          n-by-n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n-by-n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*          On exit, A contains details of the partial factorization.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D.\n*          If UPLO = 'U', only the last KB elements of IPIV are set;\n*          if UPLO = 'L', only the first KB elements are set.\n*\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*  W       (workspace) DOUBLE PRECISION array, dimension (LDW,NB)\n*\n*  LDW     (input) INTEGER\n*          The leading dimension of the array W.  LDW >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          > 0: if INFO = k, D(k,k) is exactly zero.  The factorization\n*               has been completed, but the block diagonal matrix D is\n*               exactly singular.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  kb, ipiv, info, a = NumRu::Lapack.dlasyf( uplo, nb, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_nb = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  nb = NUM2INT(rblapack_nb);
  ldw = MAX(1,n);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t 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__;
  w = ALLOC_N(doublereal, (ldw)*(MAX(1,nb)));

  dlasyf_(&uplo, &n, &nb, &kb, a, &lda, ipiv, w, &ldw, &info);

  free(w);
  rblapack_kb = INT2NUM(kb);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_kb, rblapack_ipiv, rblapack_info, rblapack_a);
}

void
init_lapack_dlasyf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlasyf", rblapack_dlasyf, -1);
}
ruby-lapack-1.7.2/ext/dgbequ.c0000644000175000017500000001342112502221025015772 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgbequ_(integer* m, integer* n, integer* kl, integer* ku, doublereal* ab, integer* ldab, doublereal* r, doublereal* c, doublereal* rowcnd, doublereal* colcnd, doublereal* amax, integer* info);


static VALUE
rblapack_dgbequ(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_r;
  doublereal *r; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_rowcnd;
  doublereal rowcnd; 
  VALUE rblapack_colcnd;
  doublereal colcnd; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_info;
  integer info; 

  integer ldab;
  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  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.dgbequ( m, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGBEQU computes row and column scalings intended to equilibrate an\n*  M-by-N band matrix A and reduce its condition number.  R returns the\n*  row scale factors and C the column scale factors, chosen to try to\n*  make the largest element in each row and column of the matrix B with\n*  elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n*\n*  R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n*  number and BIGNUM = largest safe number.  Use of these scaling\n*  factors is not guaranteed to reduce the condition number of A but\n*  works well in practice.\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*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)\n*          The band matrix A, stored in rows 1 to KL+KU+1.  The j-th\n*          column of A is stored in the j-th column of the array AB as\n*          follows:\n*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*  R       (output) DOUBLE PRECISION array, dimension (M)\n*          If INFO = 0, or INFO > M, R contains the row scale factors\n*          for A.\n*\n*  C       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, C contains the column scale factors for A.\n*\n*  ROWCND  (output) DOUBLE PRECISION\n*          If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n*          smallest R(i) to the largest R(i).  If ROWCND >= 0.1 and\n*          AMAX is neither too large nor too small, it is not worth\n*          scaling by R.\n*\n*  COLCND  (output) DOUBLE PRECISION\n*          If INFO = 0, COLCND contains the ratio of the smallest\n*          C(i) to the largest C(i).  If COLCND >= 0.1, it is not\n*          worth scaling by C.\n*\n*  AMAX    (output) DOUBLE PRECISION\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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, and i is\n*                <= M:  the i-th row of A is exactly zero\n*                >  M:  the (i-M)-th column of A is exactly zero\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.dgbequ( m, kl, ku, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_m = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  ku = NUM2INT(rblapack_ku);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,m);
    rblapack_r = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  r = NA_PTR_TYPE(rblapack_r, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  c = NA_PTR_TYPE(rblapack_c, doublereal*);

  dgbequ_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &info);

  rblapack_rowcnd = rb_float_new((double)rowcnd);
  rblapack_colcnd = rb_float_new((double)colcnd);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
}

void
init_lapack_dgbequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgbequ", rblapack_dgbequ, -1);
}
ruby-lapack-1.7.2/ext/zggbal.c0000644000175000017500000001756212502221015016002 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zggbal_(char* job, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, integer* ilo, integer* ihi, doublereal* lscale, doublereal* rscale, doublereal* work, integer* info);


static VALUE
rblapack_zggbal(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_lscale;
  doublereal *lscale; 
  VALUE rblapack_rscale;
  doublereal *rscale; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  doublereal *work;

  integer lda;
  integer n;
  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  ilo, ihi, lscale, rscale, info, a, b = NumRu::Lapack.zggbal( job, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGGBAL balances a pair of general complex matrices (A,B).  This\n*  involves, first, permuting A and B by similarity transformations to\n*  isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N\n*  elements on the diagonal; and second, applying a diagonal similarity\n*  transformation to rows and columns ILO to IHI to make the rows\n*  and columns as close in norm as possible. Both steps are optional.\n*\n*  Balancing may reduce the 1-norm of the matrices, and improve the\n*  accuracy of the computed eigenvalues and/or eigenvectors in the\n*  generalized eigenvalue problem A*x = lambda*B*x.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies the operations to be performed on A and B:\n*          = 'N':  none:  simply set ILO = 1, IHI = N, LSCALE(I) = 1.0\n*                  and RSCALE(I) = 1.0 for i=1,...,N;\n*          = 'P':  permute only;\n*          = 'S':  scale only;\n*          = 'B':  both permute and scale.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the input matrix A.\n*          On exit, A is overwritten by the balanced matrix.\n*          If JOB = 'N', A is not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,N)\n*          On entry, the input matrix B.\n*          On exit, B is overwritten by the balanced matrix.\n*          If JOB = 'N', B is not referenced.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  ILO     (output) INTEGER\n*  IHI     (output) INTEGER\n*          ILO and IHI are set to integers such that on exit\n*          A(i,j) = 0 and B(i,j) = 0 if i > j and\n*          j = 1,...,ILO-1 or i = IHI+1,...,N.\n*          If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n*\n*  LSCALE  (output) DOUBLE PRECISION array, dimension (N)\n*          Details of the permutations and scaling factors applied\n*          to the left side of A and B.  If P(j) is the index of the\n*          row interchanged with row j, and D(j) is the scaling factor\n*          applied to row j, then\n*            LSCALE(j) = P(j)    for J = 1,...,ILO-1\n*                      = D(j)    for J = ILO,...,IHI\n*                      = P(j)    for J = IHI+1,...,N.\n*          The order in which the interchanges are made is N to IHI+1,\n*          then 1 to ILO-1.\n*\n*  RSCALE  (output) DOUBLE PRECISION array, dimension (N)\n*          Details of the permutations and scaling factors applied\n*          to the right side of A and B.  If P(j) is the index of the\n*          column interchanged with column j, and D(j) is the scaling\n*          factor applied to column j, then\n*            RSCALE(j) = P(j)    for J = 1,...,ILO-1\n*                      = D(j)    for J = ILO,...,IHI\n*                      = P(j)    for J = IHI+1,...,N.\n*          The order in which the interchanges are made is N to IHI+1,\n*          then 1 to ILO-1.\n*\n*  WORK    (workspace) REAL array, dimension (lwork)\n*          lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and\n*          at least 1 when JOB = 'N' or 'P'.\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*  See R.C. WARD, Balancing the generalized eigenvalue problem,\n*                 SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ilo, ihi, lscale, rscale, info, a, b = NumRu::Lapack.zggbal( job, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_job = argv[0];
  rblapack_a = argv[1];
  rblapack_b = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  job = StringValueCStr(rblapack_job)[0];
  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);
  ldb = NA_SHAPE0(rblapack_b);
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_lscale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  lscale = NA_PTR_TYPE(rblapack_lscale, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rscale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  rscale = NA_PTR_TYPE(rblapack_rscale, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(doublereal, ((lsame_(&job,"S")||lsame_(&job,"B")) ? MAX(1,6*n) : (lsame_(&job,"N")||lsame_(&job,"P")) ? 1 : 0));

  zggbal_(&job, &n, a, &lda, b, &ldb, &ilo, &ihi, lscale, rscale, work, &info);

  free(work);
  rblapack_ilo = INT2NUM(ilo);
  rblapack_ihi = INT2NUM(ihi);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_ilo, rblapack_ihi, rblapack_lscale, rblapack_rscale, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_zggbal(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zggbal", rblapack_zggbal, -1);
}
ruby-lapack-1.7.2/ext/dlaruv.c0000644000175000017500000000724712502221013016026 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaruv_(integer* iseed, integer* n, doublereal* x);


static VALUE
rblapack_dlaruv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_iseed;
  integer *iseed; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_iseed_out__;
  integer *iseed_out__;


  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  x, iseed = NumRu::Lapack.dlaruv( iseed, n, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLARUV( ISEED, N, X )\n\n*  Purpose\n*  =======\n*\n*  DLARUV returns a vector of n random real numbers from a uniform (0,1)\n*  distribution (n <= 128).\n*\n*  This is an auxiliary routine called by DLARNV and ZLARNV.\n*\n\n*  Arguments\n*  =========\n*\n*  ISEED   (input/output) INTEGER array, dimension (4)\n*          On entry, the seed of the random number generator; the array\n*          elements must be between 0 and 4095, and ISEED(4) must be\n*          odd.\n*          On exit, the seed is updated.\n*\n*  N       (input) INTEGER\n*          The number of random numbers to be generated. N <= 128.\n*\n*  X       (output) DOUBLE PRECISION array, dimension (N)\n*          The generated random numbers.\n*\n\n*  Further Details\n*  ===============\n*\n*  This routine uses a multiplicative congruential method with modulus\n*  2**48 and multiplier 33952834046453 (see G.S.Fishman,\n*  'Multiplicative congruential random number generators with modulus\n*  2**b: an exhaustive analysis for b = 32 and a partial analysis for\n*  b = 48', Math. Comp. 189, pp 331-344, 1990).\n*\n*  48-bit integers are stored in 4 integer array elements with 12 bits\n*  per element. Hence the routine is portable across machines with\n*  integers of 32 bits or more.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, iseed = NumRu::Lapack.dlaruv( iseed, n, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_iseed = argv[0];
  rblapack_n = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_iseed))
    rb_raise(rb_eArgError, "iseed (1th argument) must be NArray");
  if (NA_RANK(rblapack_iseed) != 1)
    rb_raise(rb_eArgError, "rank of iseed (1th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_iseed) != (4))
    rb_raise(rb_eRuntimeError, "shape 0 of iseed must be %d", 4);
  if (NA_TYPE(rblapack_iseed) != NA_LINT)
    rblapack_iseed = na_change_type(rblapack_iseed, NA_LINT);
  iseed = NA_PTR_TYPE(rblapack_iseed, integer*);
  n = NUM2INT(rblapack_n);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,n);
    rblapack_x = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 4;
    rblapack_iseed_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iseed_out__ = NA_PTR_TYPE(rblapack_iseed_out__, integer*);
  MEMCPY(iseed_out__, iseed, integer, NA_TOTAL(rblapack_iseed));
  rblapack_iseed = rblapack_iseed_out__;
  iseed = iseed_out__;

  dlaruv_(iseed, &n, x);

  return rb_ary_new3(2, rblapack_x, rblapack_iseed);
}

void
init_lapack_dlaruv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaruv", rblapack_dlaruv, -1);
}
ruby-lapack-1.7.2/ext/dgesc2.c0000644000175000017500000001263112502221016015674 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgesc2_(integer* n, doublereal* a, integer* lda, doublereal* rhs, integer* ipiv, integer* jpiv, doublereal* scale);


static VALUE
rblapack_dgesc2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_rhs;
  doublereal *rhs; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_jpiv;
  integer *jpiv; 
  VALUE rblapack_scale;
  doublereal scale; 
  VALUE rblapack_rhs_out__;
  doublereal *rhs_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  scale, rhs = NumRu::Lapack.dgesc2( a, rhs, ipiv, jpiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )\n\n*  Purpose\n*  =======\n*\n*  DGESC2 solves a system of linear equations\n*\n*            A * X = scale* RHS\n*\n*  with a general N-by-N matrix A using the LU factorization with\n*  complete pivoting computed by DGETC2.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the  LU part of the factorization of the n-by-n\n*          matrix A computed by DGETC2:  A = P * L * U * Q\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1, N).\n*\n*  RHS     (input/output) DOUBLE PRECISION array, dimension (N).\n*          On entry, the right hand side vector b.\n*          On exit, the solution vector X.\n*\n*  IPIV    (input) INTEGER array, dimension (N).\n*          The pivot indices; for 1 <= i <= N, row i of the\n*          matrix has been interchanged with row IPIV(i).\n*\n*  JPIV    (input) INTEGER array, dimension (N).\n*          The pivot indices; for 1 <= j <= N, column j of the\n*          matrix has been interchanged with column JPIV(j).\n*\n*  SCALE   (output) DOUBLE PRECISION\n*          On exit, SCALE contains the scale factor. SCALE is chosen\n*          0 <= SCALE <= 1 to prevent owerflow in the solution.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, rhs = NumRu::Lapack.dgesc2( a, rhs, ipiv, jpiv, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_a = argv[0];
  rblapack_rhs = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_jpiv = argv[3];
  if (argc == 4) {
  } 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*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_rhs))
    rb_raise(rb_eArgError, "rhs (2th argument) must be NArray");
  if (NA_RANK(rblapack_rhs) != 1)
    rb_raise(rb_eArgError, "rank of rhs (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_rhs) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of rhs must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_rhs) != NA_DFLOAT)
    rblapack_rhs = na_change_type(rblapack_rhs, NA_DFLOAT);
  rhs = NA_PTR_TYPE(rblapack_rhs, doublereal*);
  if (!NA_IsNArray(rblapack_jpiv))
    rb_raise(rb_eArgError, "jpiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_jpiv) != 1)
    rb_raise(rb_eArgError, "rank of jpiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_jpiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of jpiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_jpiv) != NA_LINT)
    rblapack_jpiv = na_change_type(rblapack_jpiv, NA_LINT);
  jpiv = NA_PTR_TYPE(rblapack_jpiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rhs_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  rhs_out__ = NA_PTR_TYPE(rblapack_rhs_out__, doublereal*);
  MEMCPY(rhs_out__, rhs, doublereal, NA_TOTAL(rblapack_rhs));
  rblapack_rhs = rblapack_rhs_out__;
  rhs = rhs_out__;

  dgesc2_(&n, a, &lda, rhs, ipiv, jpiv, &scale);

  rblapack_scale = rb_float_new((double)scale);
  return rb_ary_new3(2, rblapack_scale, rblapack_rhs);
}

void
init_lapack_dgesc2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgesc2", rblapack_dgesc2, -1);
}
ruby-lapack-1.7.2/ext/zpotf2.c0000644000175000017500000001013112502221024015741 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zpotf2_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* info);


static VALUE
rblapack_zpotf2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *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  info, a = NumRu::Lapack.zpotf2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPOTF2( UPLO, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPOTF2 computes the Cholesky factorization of a complex Hermitian\n*  positive definite matrix A.\n*\n*  The factorization has the form\n*     A = U' * U ,  if UPLO = 'U', or\n*     A = L  * L',  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is lower triangular.\n*\n*  This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          Hermitian matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading\n*          n by n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n by n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the factor U or L from the Cholesky\n*          factorization A = U'*U  or A = L*L'.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*          > 0: if INFO = k, the leading minor of order k is not\n*               positive definite, and the factorization could not be\n*               completed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.zpotf2( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zpotf2_(&uplo, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_zpotf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zpotf2", rblapack_zpotf2, -1);
}
ruby-lapack-1.7.2/ext/dlangt.c0000644000175000017500000001066712502221017016006 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal dlangt_(char* norm, integer* n, doublereal* dl, doublereal* d, doublereal* du);


static VALUE
rblapack_dlangt(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_dl;
  doublereal *dl; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_du;
  doublereal *du; 
  VALUE rblapack___out__;
  doublereal __out__; 

  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  __out__ = NumRu::Lapack.dlangt( norm, dl, d, du, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION DLANGT( NORM, N, DL, D, DU )\n\n*  Purpose\n*  =======\n*\n*  DLANGT  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  real tridiagonal matrix A.\n*\n*  Description\n*  ===========\n*\n*  DLANGT returns the value\n*\n*     DLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in DLANGT as described\n*          above.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, DLANGT is\n*          set to zero.\n*\n*  DL      (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (n-1) sub-diagonal elements of A.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          The diagonal elements of A.\n*\n*  DU      (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (n-1) super-diagonal elements of A.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.dlangt( norm, dl, d, du, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_norm = argv[0];
  rblapack_dl = argv[1];
  rblapack_d = argv[2];
  rblapack_du = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_DFLOAT)
    rblapack_dl = na_change_type(rblapack_dl, NA_DFLOAT);
  dl = NA_PTR_TYPE(rblapack_dl, doublereal*);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (4th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_DFLOAT)
    rblapack_du = na_change_type(rblapack_du, NA_DFLOAT);
  du = NA_PTR_TYPE(rblapack_du, doublereal*);

  __out__ = dlangt_(&norm, &n, dl, d, du);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_dlangt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlangt", rblapack_dlangt, -1);
}
ruby-lapack-1.7.2/ext/ztpttr.c0000644000175000017500000000744412502221022016077 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztpttr_(char* uplo, integer* n, doublecomplex* ap, doublecomplex* a, integer* lda, integer* info);


static VALUE
rblapack_ztpttr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_info;
  integer info; 

  integer ldap;
  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  a, info = NumRu::Lapack.ztpttr( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTPTTR( UPLO, N, AP, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTPTTR copies a triangular matrix A from standard packed format (TP)\n*  to standard full format (TR).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular.\n*          = 'L':  A is lower triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0.\n*\n*  AP      (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n*          On entry, the upper or lower triangular matrix A, packed\n*          columnwise in a linear array. The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  A       (output) COMPLEX*16 array, dimension ( LDA, N )\n*          On exit, the triangular matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  a, info = NumRu::Lapack.ztpttr( uplo, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  n = ((int)sqrtf(ldap*8-1.0f)-1)/2;
  lda = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);

  ztpttr_(&uplo, &n, ap, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_a, rblapack_info);
}

void
init_lapack_ztpttr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztpttr", rblapack_ztpttr, -1);
}
ruby-lapack-1.7.2/ext/clacrm.c0000644000175000017500000000762212502221013015767 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clacrm_(integer* m, integer* n, complex* a, integer* lda, real* b, integer* ldb, complex* c, integer* ldc, real* rwork);


static VALUE
rblapack_clacrm(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_c;
  complex *c; 
  real *rwork;

  integer lda;
  integer n;
  integer ldb;
  integer ldc;

  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  c = NumRu::Lapack.clacrm( m, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK )\n\n*  Purpose\n*  =======\n*\n*  CLACRM performs a very simple matrix-matrix multiplication:\n*           C := A * B,\n*  where A is M by N and complex; B is N by N and real;\n*  C is M by N and complex.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A and of the matrix C.\n*          M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns and rows of the matrix B and\n*          the number of columns of the matrix C.\n*          N >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA, N)\n*          A contains 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*  B       (input) REAL array, dimension (LDB, N)\n*          B contains the N by N matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >=max(1,N).\n*\n*  C       (input) COMPLEX array, dimension (LDC, N)\n*          C contains the M by N matrix C.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >=max(1,N).\n*\n*  RWORK   (workspace) REAL array, dimension (2*M*N)\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.clacrm( m, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  rblapack_b = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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);
  ldb = NA_SHAPE0(rblapack_b);
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  ldc = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  c = NA_PTR_TYPE(rblapack_c, complex*);
  rwork = ALLOC_N(real, (2*m*n));

  clacrm_(&m, &n, a, &lda, b, &ldb, c, &ldc, rwork);

  free(rwork);
  return rblapack_c;
}

void
init_lapack_clacrm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clacrm", rblapack_clacrm, -1);
}
ruby-lapack-1.7.2/ext/dla_porpvgrw.c0000644000175000017500000001160012502221026017227 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal dla_porpvgrw_(char* uplo, integer* ncols, doublereal* a, integer* lda, doublereal* af, integer* ldaf, doublereal* work);


static VALUE
rblapack_dla_porpvgrw(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ncols;
  integer ncols; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_af;
  doublereal *af; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack___out__;
  doublereal __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  __out__ = NumRu::Lapack.dla_porpvgrw( uplo, ncols, a, af, work, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION DLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF,  LDAF, WORK )\n\n*  Purpose\n*  =======\n* \n*  DLA_PORPVGRW computes the reciprocal pivot growth factor\n*  norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n*  much less than 1, the stability of the LU factorization of the\n*  (equilibrated) matrix A could be poor. This also means that the\n*  solution X, estimated condition numbers, and error bounds could be\n*  unreliable.\n*\n\n*  Arguments\n*  =========\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     NCOLS   (input) INTEGER\n*     The number of columns of the matrix A. NCOLS >= 0.\n*\n*     A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) DOUBLE PRECISION array, dimension (LDAF,N)\n*     The triangular factor U or L from the Cholesky factorization\n*     A = U**T*U or A = L*L**T, as computed by DPOTRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     WORK    (input) DOUBLE PRECISION array, dimension (2*N)\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n      DOUBLE PRECISION   AMAX, UMAX, RPVGRW\n      LOGICAL            UPPER\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX, MIN\n*     ..\n*     .. External Functions ..\n      EXTERNAL           LSAME, DLASET\n      LOGICAL            LSAME\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.dla_porpvgrw( uplo, ncols, a, af, work, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_ncols = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_work = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  ncols = NUM2INT(rblapack_ncols);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
  af = NA_PTR_TYPE(rblapack_af, doublereal*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (5th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
  if (NA_TYPE(rblapack_work) != NA_DFLOAT)
    rblapack_work = na_change_type(rblapack_work, NA_DFLOAT);
  work = NA_PTR_TYPE(rblapack_work, doublereal*);

  __out__ = dla_porpvgrw_(&uplo, &ncols, a, &lda, af, &ldaf, work);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_dla_porpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dla_porpvgrw", rblapack_dla_porpvgrw, -1);
}
ruby-lapack-1.7.2/ext/sppequ.c0000644000175000017500000001050412502221025016037 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sppequ_(char* uplo, integer* n, real* ap, real* s, real* scond, real* amax, integer* info);


static VALUE
rblapack_sppequ(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_scond;
  real scond; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_info;
  integer info; 

  integer ldap;
  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  s, scond, amax, info = NumRu::Lapack.sppequ( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPPEQU computes row and column scalings intended to equilibrate a\n*  symmetric positive definite matrix A in packed storage and reduce\n*  its condition number (with respect to the two-norm).  S contains the\n*  scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix\n*  B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.\n*  This choice of S puts the condition number of B within a factor N of\n*  the smallest possible condition number over all possible diagonal\n*  scalings.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input) REAL array, dimension (N*(N+1)/2)\n*          The upper or lower triangle of the symmetric matrix A, packed\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  S       (output) REAL array, dimension (N)\n*          If INFO = 0, S contains the scale factors for A.\n*\n*  SCOND   (output) REAL\n*          If INFO = 0, S contains the ratio of the smallest S(i) to\n*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too\n*          large nor too small, it is not worth scaling by S.\n*\n*  AMAX    (output) REAL\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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 is nonpositive.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, scond, amax, info = NumRu::Lapack.sppequ( uplo, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, real*);

  sppequ_(&uplo, &n, ap, s, &scond, &amax, &info);

  rblapack_scond = rb_float_new((double)scond);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
}

void
init_lapack_sppequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sppequ", rblapack_sppequ, -1);
}
ruby-lapack-1.7.2/ext/dgeequb.c0000644000175000017500000001274012502221024016141 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgeequb_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* r, doublereal* c, doublereal* rowcnd, doublereal* colcnd, doublereal* amax, integer* info);


static VALUE
rblapack_dgeequb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_r;
  doublereal *r; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_rowcnd;
  doublereal rowcnd; 
  VALUE rblapack_colcnd;
  doublereal colcnd; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_info;
  integer info; 

  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  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.dgeequb( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGEEQUB computes row and column scalings intended to equilibrate an\n*  M-by-N matrix A and reduce its condition number.  R returns the row\n*  scale factors and C the column scale factors, chosen to try to make\n*  the largest element in each row and column of the matrix B with\n*  elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n*  the radix.\n*\n*  R(i) and C(j) are restricted to be a power of the radix between\n*  SMLNUM = smallest safe number and BIGNUM = largest safe number.  Use\n*  of these scaling factors is not guaranteed to reduce the condition\n*  number of A but works well in practice.\n*\n*  This routine differs from DGEEQU by restricting the scaling factors\n*  to a power of the radix.  Baring over- and underflow, scaling by\n*  these factors introduces no additional rounding errors.  However, the\n*  scaled entries' magnitured are no longer approximately 1 but lie\n*  between sqrt(radix) and 1/sqrt(radix).\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) DOUBLE PRECISION array, dimension (LDA,N)\n*          The M-by-N matrix whose equilibration factors are\n*          to be computed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  R       (output) DOUBLE PRECISION array, dimension (M)\n*          If INFO = 0 or INFO > M, R contains the row scale factors\n*          for A.\n*\n*  C       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0,  C contains the column scale factors for A.\n*\n*  ROWCND  (output) DOUBLE PRECISION\n*          If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n*          smallest R(i) to the largest R(i).  If ROWCND >= 0.1 and\n*          AMAX is neither too large nor too small, it is not worth\n*          scaling by R.\n*\n*  COLCND  (output) DOUBLE PRECISION\n*          If INFO = 0, COLCND contains the ratio of the smallest\n*          C(i) to the largest C(i).  If COLCND >= 0.1, it is not\n*          worth scaling by C.\n*\n*  AMAX    (output) DOUBLE PRECISION\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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,  and i is\n*                <= M:  the i-th row of A is exactly zero\n*                >  M:  the (i-M)-th column of A is exactly zero\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.dgeequb( 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;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_r = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  r = NA_PTR_TYPE(rblapack_r, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  c = NA_PTR_TYPE(rblapack_c, doublereal*);

  dgeequb_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &info);

  rblapack_rowcnd = rb_float_new((double)rowcnd);
  rblapack_colcnd = rb_float_new((double)colcnd);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
}

void
init_lapack_dgeequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgeequb", rblapack_dgeequb, -1);
}
ruby-lapack-1.7.2/ext/slahqr.c0000644000175000017500000002260112502221023016013 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slahqr_(logical* wantt, logical* wantz, integer* n, integer* ilo, integer* ihi, real* h, integer* ldh, real* wr, real* wi, integer* iloz, integer* ihiz, real* z, integer* ldz, integer* info);


static VALUE
rblapack_slahqr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantt;
  logical wantt; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_h;
  real *h; 
  VALUE rblapack_iloz;
  integer iloz; 
  VALUE rblapack_ihiz;
  integer ihiz; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_ldz;
  integer ldz; 
  VALUE rblapack_wr;
  real *wr; 
  VALUE rblapack_wi;
  real *wi; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_h_out__;
  real *h_out__;
  VALUE rblapack_z_out__;
  real *z_out__;

  integer ldh;
  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  wr, wi, info, h, z = NumRu::Lapack.slahqr( wantt, wantz, ilo, ihi, h, iloz, ihiz, z, ldz, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILOZ, IHIZ, Z, LDZ, INFO )\n\n*     Purpose\n*     =======\n*\n*     SLAHQR is an auxiliary routine called by SHSEQR to update the\n*     eigenvalues and Schur decomposition already computed by SHSEQR, by\n*     dealing with the Hessenberg submatrix in rows and columns ILO to\n*     IHI.\n*\n\n*     Arguments\n*     =========\n*\n*     WANTT   (input) LOGICAL\n*          = .TRUE. : the full Schur form T is required;\n*          = .FALSE.: only eigenvalues are required.\n*\n*     WANTZ   (input) LOGICAL\n*          = .TRUE. : the matrix of Schur vectors Z is required;\n*          = .FALSE.: Schur vectors are not required.\n*\n*     N       (input) INTEGER\n*          The order of the matrix H.  N >= 0.\n*\n*     ILO     (input) INTEGER\n*     IHI     (input) INTEGER\n*          It is assumed that H is already upper quasi-triangular in\n*          rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless\n*          ILO = 1). SLAHQR works primarily with the Hessenberg\n*          submatrix in rows and columns ILO to IHI, but applies\n*          transformations to all of H if WANTT is .TRUE..\n*          1 <= ILO <= max(1,IHI); IHI <= N.\n*\n*     H       (input/output) REAL array, dimension (LDH,N)\n*          On entry, the upper Hessenberg matrix H.\n*          On exit, if INFO is zero and if WANTT is .TRUE., H is upper\n*          quasi-triangular in rows and columns ILO:IHI, with any\n*          2-by-2 diagonal blocks in standard form. If INFO is zero\n*          and WANTT is .FALSE., the contents of H are unspecified on\n*          exit.  The output state of H if INFO is nonzero is given\n*          below under the description of INFO.\n*\n*     LDH     (input) INTEGER\n*          The leading dimension of the array H. LDH >= max(1,N).\n*\n*     WR      (output) REAL array, dimension (N)\n*     WI      (output) REAL array, dimension (N)\n*          The real and imaginary parts, respectively, of the computed\n*          eigenvalues ILO to IHI are stored in the corresponding\n*          elements of WR and WI. If two eigenvalues are computed as a\n*          complex conjugate pair, they are stored in consecutive\n*          elements of WR and WI, say the i-th and (i+1)th, with\n*          WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the\n*          eigenvalues are stored in the same order as on the diagonal\n*          of the Schur form returned in H, with WR(i) = H(i,i), and, if\n*          H(i:i+1,i:i+1) is a 2-by-2 diagonal block,\n*          WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i).\n*\n*     ILOZ    (input) INTEGER\n*     IHIZ    (input) INTEGER\n*          Specify the rows of Z to which transformations must be\n*          applied if WANTZ is .TRUE..\n*          1 <= ILOZ <= ILO; IHI <= IHIZ <= N.\n*\n*     Z       (input/output) REAL array, dimension (LDZ,N)\n*          If WANTZ is .TRUE., on entry Z must contain the current\n*          matrix Z of transformations accumulated by SHSEQR, and on\n*          exit Z has been updated; transformations are applied only to\n*          the submatrix Z(ILOZ:IHIZ,ILO:IHI).\n*          If WANTZ is .FALSE., Z is not referenced.\n*\n*     LDZ     (input) INTEGER\n*          The leading dimension of the array Z. LDZ >= max(1,N).\n*\n*     INFO    (output) INTEGER\n*           =   0: successful exit\n*          .GT. 0: If INFO = i, SLAHQR failed to compute all the\n*                  eigenvalues ILO to IHI in a total of 30 iterations\n*                  per eigenvalue; elements i+1:ihi of WR and WI\n*                  contain those eigenvalues which have been\n*                  successfully computed.\n*\n*                  If INFO .GT. 0 and WANTT is .FALSE., then on exit,\n*                  the remaining unconverged eigenvalues are the\n*                  eigenvalues of the upper Hessenberg matrix rows\n*                  and columns ILO thorugh INFO of the final, output\n*                  value of H.\n*\n*                  If INFO .GT. 0 and WANTT is .TRUE., then on exit\n*          (*)       (initial value of H)*U  = U*(final value of H)\n*                  where U is an orthognal matrix.    The final\n*                  value of H is upper Hessenberg and triangular in\n*                  rows and columns INFO+1 through IHI.\n*\n*                  If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n*                      (final value of Z)  = (initial value of Z)*U\n*                  where U is the orthogonal matrix in (*)\n*                  (regardless of the value of WANTT.)\n*\n\n*     Further Details\n*     ===============\n*\n*     02-96 Based on modifications by\n*     David Day, Sandia National Laboratory, USA\n*\n*     12-04 Further modifications by\n*     Ralph Byers, University of Kansas, USA\n*     This is a modified version of SLAHQR from LAPACK version 3.0.\n*     It is (1) more robust against overflow and underflow and\n*     (2) adopts the more conservative Ahues & Tisseur stopping\n*     criterion (LAWN 122, 1997).\n*\n*     =========================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  wr, wi, info, h, z = NumRu::Lapack.slahqr( wantt, wantz, ilo, ihi, h, iloz, ihiz, z, ldz, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_wantt = argv[0];
  rblapack_wantz = argv[1];
  rblapack_ilo = argv[2];
  rblapack_ihi = argv[3];
  rblapack_h = argv[4];
  rblapack_iloz = argv[5];
  rblapack_ihiz = argv[6];
  rblapack_z = argv[7];
  rblapack_ldz = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  wantt = (rblapack_wantt == Qtrue);
  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (5th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_SFLOAT)
    rblapack_h = na_change_type(rblapack_h, NA_SFLOAT);
  h = NA_PTR_TYPE(rblapack_h, real*);
  ihiz = NUM2INT(rblapack_ihiz);
  ldz = NUM2INT(rblapack_ldz);
  wantz = (rblapack_wantz == Qtrue);
  iloz = NUM2INT(rblapack_iloz);
  ihi = NUM2INT(rblapack_ihi);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (8th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_z) != (wantz ? ldz : 0))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantz ? ldz : 0);
  if (NA_SHAPE1(rblapack_z) != (wantz ? n : 0))
    rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantz ? n : 0);
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  wr = NA_PTR_TYPE(rblapack_wr, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  wi = NA_PTR_TYPE(rblapack_wi, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, real*);
  MEMCPY(h_out__, h, real, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = wantz ? ldz : 0;
    shape[1] = wantz ? n : 0;
    rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
  MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  slahqr_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, wr, wi, &iloz, &ihiz, z, &ldz, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_wr, rblapack_wi, rblapack_info, rblapack_h, rblapack_z);
}

void
init_lapack_slahqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slahqr", rblapack_slahqr, -1);
}
ruby-lapack-1.7.2/ext/dlaein.c0000644000175000017500000001727612502221025015773 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaein_(logical* rightv, logical* noinit, integer* n, doublereal* h, integer* ldh, doublereal* wr, doublereal* wi, doublereal* vr, doublereal* vi, doublereal* b, integer* ldb, doublereal* work, doublereal* eps3, doublereal* smlnum, doublereal* bignum, integer* info);


static VALUE
rblapack_dlaein(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_rightv;
  logical rightv; 
  VALUE rblapack_noinit;
  logical noinit; 
  VALUE rblapack_h;
  doublereal *h; 
  VALUE rblapack_wr;
  doublereal wr; 
  VALUE rblapack_wi;
  doublereal wi; 
  VALUE rblapack_vr;
  doublereal *vr; 
  VALUE rblapack_vi;
  doublereal *vi; 
  VALUE rblapack_eps3;
  doublereal eps3; 
  VALUE rblapack_smlnum;
  doublereal smlnum; 
  VALUE rblapack_bignum;
  doublereal bignum; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_vr_out__;
  doublereal *vr_out__;
  VALUE rblapack_vi_out__;
  doublereal *vi_out__;
  doublereal *b;
  doublereal *work;

  integer ldh;
  integer n;
  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  info, vr, vi = NumRu::Lapack.dlaein( rightv, noinit, h, wr, wi, vr, vi, eps3, smlnum, bignum, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B, LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLAEIN uses inverse iteration to find a right or left eigenvector\n*  corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg\n*  matrix H.\n*\n\n*  Arguments\n*  =========\n*\n*  RIGHTV  (input) LOGICAL\n*          = .TRUE. : compute right eigenvector;\n*          = .FALSE.: compute left eigenvector.\n*\n*  NOINIT  (input) LOGICAL\n*          = .TRUE. : no initial vector supplied in (VR,VI).\n*          = .FALSE.: initial vector supplied in (VR,VI).\n*\n*  N       (input) INTEGER\n*          The order of the matrix H.  N >= 0.\n*\n*  H       (input) DOUBLE PRECISION array, dimension (LDH,N)\n*          The upper Hessenberg matrix H.\n*\n*  LDH     (input) INTEGER\n*          The leading dimension of the array H.  LDH >= max(1,N).\n*\n*  WR      (input) DOUBLE PRECISION\n*  WI      (input) DOUBLE PRECISION\n*          The real and imaginary parts of the eigenvalue of H whose\n*          corresponding right or left eigenvector is to be computed.\n*\n*  VR      (input/output) DOUBLE PRECISION array, dimension (N)\n*  VI      (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain\n*          a real starting vector for inverse iteration using the real\n*          eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI\n*          must contain the real and imaginary parts of a complex\n*          starting vector for inverse iteration using the complex\n*          eigenvalue (WR,WI); otherwise VR and VI need not be set.\n*          On exit, if WI = 0.0 (real eigenvalue), VR contains the\n*          computed real eigenvector; if WI.ne.0.0 (complex eigenvalue),\n*          VR and VI contain the real and imaginary parts of the\n*          computed complex eigenvector. The eigenvector is normalized\n*          so that the component of largest magnitude has magnitude 1;\n*          here the magnitude of a complex number (x,y) is taken to be\n*          |x| + |y|.\n*          VI is not referenced if WI = 0.0.\n*\n*  B       (workspace) DOUBLE PRECISION array, dimension (LDB,N)\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= N+1.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (N)\n*\n*  EPS3    (input) DOUBLE PRECISION\n*          A small machine-dependent value which is used to perturb\n*          close eigenvalues, and to replace zero pivots.\n*\n*  SMLNUM  (input) DOUBLE PRECISION\n*          A machine-dependent value close to the underflow threshold.\n*\n*  BIGNUM  (input) DOUBLE PRECISION\n*          A machine-dependent value close to the overflow threshold.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          = 1:  inverse iteration did not converge; VR is set to the\n*                last iterate, and so is VI if WI.ne.0.0.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, vr, vi = NumRu::Lapack.dlaein( rightv, noinit, h, wr, wi, vr, vi, eps3, smlnum, bignum, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_rightv = argv[0];
  rblapack_noinit = argv[1];
  rblapack_h = argv[2];
  rblapack_wr = argv[3];
  rblapack_wi = argv[4];
  rblapack_vr = argv[5];
  rblapack_vi = argv[6];
  rblapack_eps3 = argv[7];
  rblapack_smlnum = argv[8];
  rblapack_bignum = argv[9];
  if (argc == 10) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  rightv = (rblapack_rightv == Qtrue);
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (3th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (3th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_DFLOAT)
    rblapack_h = na_change_type(rblapack_h, NA_DFLOAT);
  h = NA_PTR_TYPE(rblapack_h, doublereal*);
  wi = NUM2DBL(rblapack_wi);
  if (!NA_IsNArray(rblapack_vi))
    rb_raise(rb_eArgError, "vi (7th argument) must be NArray");
  if (NA_RANK(rblapack_vi) != 1)
    rb_raise(rb_eArgError, "rank of vi (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_vi) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of vi must be the same as shape 1 of h");
  if (NA_TYPE(rblapack_vi) != NA_DFLOAT)
    rblapack_vi = na_change_type(rblapack_vi, NA_DFLOAT);
  vi = NA_PTR_TYPE(rblapack_vi, doublereal*);
  smlnum = NUM2DBL(rblapack_smlnum);
  noinit = (rblapack_noinit == Qtrue);
  if (!NA_IsNArray(rblapack_vr))
    rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
  if (NA_RANK(rblapack_vr) != 1)
    rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_vr) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of vr must be the same as shape 1 of h");
  if (NA_TYPE(rblapack_vr) != NA_DFLOAT)
    rblapack_vr = na_change_type(rblapack_vr, NA_DFLOAT);
  vr = NA_PTR_TYPE(rblapack_vr, doublereal*);
  bignum = NUM2DBL(rblapack_bignum);
  wr = NUM2DBL(rblapack_wr);
  ldb = n+1;
  eps3 = NUM2DBL(rblapack_eps3);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_vr_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  vr_out__ = NA_PTR_TYPE(rblapack_vr_out__, doublereal*);
  MEMCPY(vr_out__, vr, doublereal, NA_TOTAL(rblapack_vr));
  rblapack_vr = rblapack_vr_out__;
  vr = vr_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_vi_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  vi_out__ = NA_PTR_TYPE(rblapack_vi_out__, doublereal*);
  MEMCPY(vi_out__, vi, doublereal, NA_TOTAL(rblapack_vi));
  rblapack_vi = rblapack_vi_out__;
  vi = vi_out__;
  b = ALLOC_N(doublereal, (ldb)*(n));
  work = ALLOC_N(doublereal, (n));

  dlaein_(&rightv, &noinit, &n, h, &ldh, &wr, &wi, vr, vi, b, &ldb, work, &eps3, &smlnum, &bignum, &info);

  free(b);
  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_vr, rblapack_vi);
}

void
init_lapack_dlaein(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaein", rblapack_dlaein, -1);
}
ruby-lapack-1.7.2/ext/ssyevx.c0000644000175000017500000002475712502221023016100 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssyevx_(char* jobz, char* range, char* uplo, integer* n, real* a, integer* lda, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, real* z, integer* ldz, real* work, integer* lwork, integer* iwork, integer* ifail, integer* info);


static VALUE
rblapack_ssyevx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_vl;
  real vl; 
  VALUE rblapack_vu;
  real vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  real abstol; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_ifail;
  integer *ifail; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  integer *iwork;

  integer lda;
  integer n;
  integer ldz;

  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  m, w, z, work, ifail, info, a = NumRu::Lapack.ssyevx( jobz, range, uplo, a, vl, vu, il, iu, abstol, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSYEVX computes selected eigenvalues and, optionally, eigenvectors\n*  of a real symmetric matrix A.  Eigenvalues and eigenvectors can be\n*  selected by specifying either a range of values or a range of indices\n*  for the desired eigenvalues.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found.\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found.\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA, N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of A contains the\n*          upper triangular part of the matrix A.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of A contains\n*          the lower triangular part of the matrix A.\n*          On exit, the lower triangle (if UPLO='L') or the upper\n*          triangle (if UPLO='U') of A, including the diagonal, is\n*          destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  VL      (input) REAL\n*  VU      (input) REAL\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) REAL\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less than\n*          or equal to zero, then  EPS*|T|  will be used in its place,\n*          where |T| is the 1-norm of the tridiagonal matrix obtained\n*          by reducing A to tridiagonal form.\n*\n*          Eigenvalues will be computed most accurately when ABSTOL is\n*          set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n*          If this routine returns with INFO>0, indicating that some\n*          eigenvectors did not converge, try setting ABSTOL to\n*          2*SLAMCH('S').\n*\n*          See \"Computing Small Singular Values of Bidiagonal Matrices\n*          with Guaranteed High Relative Accuracy,\" by Demmel and\n*          Kahan, LAPACK Working Note #3.\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) REAL array, dimension (N)\n*          On normal exit, the first M elements contain the selected\n*          eigenvalues in ascending order.\n*\n*  Z       (output) REAL array, dimension (LDZ, max(1,M))\n*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix A\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          If an eigenvector fails to converge, then that column of Z\n*          contains the latest approximation to the eigenvector, and the\n*          index of the eigenvector is returned in IFAIL.\n*          If JOBZ = 'N', then Z is not referenced.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace/output) REAL array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of the array WORK.  LWORK >= 1, when N <= 1;\n*          otherwise 8*N.\n*          For optimal efficiency, LWORK >= (NB+3)*N,\n*          where NB is the max of the blocksize for SSYTRD and SORMTR\n*          returned by ILAENV.\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*  IWORK   (workspace) INTEGER array, dimension (5*N)\n*\n*  IFAIL   (output) INTEGER array, dimension (N)\n*          If JOBZ = 'V', then if INFO = 0, the first M elements of\n*          IFAIL are zero.  If INFO > 0, then IFAIL contains the\n*          indices of the eigenvectors that failed to converge.\n*          If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n*                Their indices are stored in array IFAIL.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, work, ifail, info, a = NumRu::Lapack.ssyevx( jobz, range, uplo, a, vl, vu, il, iu, abstol, [: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_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_uplo = argv[2];
  rblapack_a = argv[3];
  rblapack_vl = argv[4];
  rblapack_vu = argv[5];
  rblapack_il = argv[6];
  rblapack_iu = argv[7];
  rblapack_abstol = 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;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  vl = (real)NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  abstol = (real)NUM2DBL(rblapack_abstol);
  range = StringValueCStr(rblapack_range)[0];
  vu = (real)NUM2DBL(rblapack_vu);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (rblapack_lwork == Qnil)
    lwork = n<=1 ? 1 : 8*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  iu = NUM2INT(rblapack_iu);
  m = lsame_(&range,"I") ? iu-il+1 : n;
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  iwork = ALLOC_N(integer, (5*n));

  ssyevx_(&jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, &lwork, iwork, ifail, &info);

  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_m, rblapack_w, rblapack_z, rblapack_work, rblapack_ifail, rblapack_info, rblapack_a);
}

void
init_lapack_ssyevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssyevx", rblapack_ssyevx, -1);
}
ruby-lapack-1.7.2/ext/zlassq.c0000644000175000017500000000725612502221017016052 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlassq_(integer* n, doublecomplex* x, integer* incx, doublereal* scale, doublereal* sumsq);


static VALUE
rblapack_zlassq(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_scale;
  doublereal scale; 
  VALUE rblapack_sumsq;
  doublereal sumsq; 

  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  scale, sumsq = NumRu::Lapack.zlassq( x, incx, scale, sumsq, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ )\n\n*  Purpose\n*  =======\n*\n*  ZLASSQ returns the values scl and ssq such that\n*\n*     ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,\n*\n*  where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is\n*  assumed to be at least unity and the value of ssq will then satisfy\n*\n*     1.0 .le. ssq .le. ( sumsq + 2*n ).\n*\n*  scale is assumed to be non-negative and scl returns the value\n*\n*     scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ),\n*            i\n*\n*  scale and sumsq must be supplied in SCALE and SUMSQ respectively.\n*  SCALE and SUMSQ are overwritten by scl and ssq respectively.\n*\n*  The routine makes only one pass through the vector X.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of elements to be used from the vector X.\n*\n*  X       (input) COMPLEX*16 array, dimension (N)\n*          The vector x as described above.\n*             x( i )  = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.\n*\n*  INCX    (input) INTEGER\n*          The increment between successive values of the vector X.\n*          INCX > 0.\n*\n*  SCALE   (input/output) DOUBLE PRECISION\n*          On entry, the value  scale  in the equation above.\n*          On exit, SCALE is overwritten with the value  scl .\n*\n*  SUMSQ   (input/output) DOUBLE PRECISION\n*          On entry, the value  sumsq  in the equation above.\n*          On exit, SUMSQ is overwritten with the value  ssq .\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, sumsq = NumRu::Lapack.zlassq( x, incx, scale, sumsq, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_x = argv[0];
  rblapack_incx = argv[1];
  rblapack_scale = argv[2];
  rblapack_sumsq = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (1th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  scale = NUM2DBL(rblapack_scale);
  incx = NUM2INT(rblapack_incx);
  sumsq = NUM2DBL(rblapack_sumsq);

  zlassq_(&n, x, &incx, &scale, &sumsq);

  rblapack_scale = rb_float_new((double)scale);
  rblapack_sumsq = rb_float_new((double)sumsq);
  return rb_ary_new3(2, rblapack_scale, rblapack_sumsq);
}

void
init_lapack_zlassq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlassq", rblapack_zlassq, -1);
}
ruby-lapack-1.7.2/ext/zgeesx.c0000644000175000017500000002527512502221022016037 0ustar  uwabamiuwabami#include "rb_lapack.h"

static logical
rblapack_select(doublecomplex *arg0){
  VALUE rblapack_arg0;

  VALUE rblapack_ret;
  logical ret;

  rblapack_arg0 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg0->r)), rb_float_new((double)(arg0->i)));

  rblapack_ret = rb_yield_values(1, rblapack_arg0);

  ret = (rblapack_ret == Qtrue);
  return ret;
}

extern VOID zgeesx_(char* jobvs, char* sort, L_fp select, char* sense, integer* n, doublecomplex* a, integer* lda, integer* sdim, doublecomplex* w, doublecomplex* vs, integer* ldvs, doublereal* rconde, doublereal* rcondv, doublecomplex* work, integer* lwork, doublereal* rwork, logical* bwork, integer* info);


static VALUE
rblapack_zgeesx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvs;
  char jobvs; 
  VALUE rblapack_sort;
  char sort; 
  VALUE rblapack_sense;
  char sense; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_sdim;
  integer sdim; 
  VALUE rblapack_w;
  doublecomplex *w; 
  VALUE rblapack_vs;
  doublecomplex *vs; 
  VALUE rblapack_rconde;
  doublereal rconde; 
  VALUE rblapack_rcondv;
  doublereal rcondv; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  doublereal *rwork;
  logical *bwork;

  integer lda;
  integer n;
  integer ldvs;

  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  sdim, w, vs, rconde, rcondv, work, info, a = NumRu::Lapack.zgeesx( jobvs, sort, sense, a, [:lwork => lwork, :usage => usage, :help => help]){|a| ... }\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, W, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, RWORK, BWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGEESX computes for an N-by-N complex nonsymmetric matrix A, the\n*  eigenvalues, the Schur form T, and, optionally, the matrix of Schur\n*  vectors Z.  This gives the Schur factorization A = Z*T*(Z**H).\n*\n*  Optionally, it also orders the eigenvalues on the diagonal of the\n*  Schur form so that selected eigenvalues are at the top left;\n*  computes a reciprocal condition number for the average of the\n*  selected eigenvalues (RCONDE); and computes a reciprocal condition\n*  number for the right invariant subspace corresponding to the\n*  selected eigenvalues (RCONDV).  The leading columns of Z form an\n*  orthonormal basis for this invariant subspace.\n*\n*  For further explanation of the reciprocal condition numbers RCONDE\n*  and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where\n*  these quantities are called s and sep respectively).\n*\n*  A complex matrix is in Schur form if it is upper triangular.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVS   (input) CHARACTER*1\n*          = 'N': Schur vectors are not computed;\n*          = 'V': Schur vectors are computed.\n*\n*  SORT    (input) CHARACTER*1\n*          Specifies whether or not to order the eigenvalues on the\n*          diagonal of the Schur form.\n*          = 'N': Eigenvalues are not ordered;\n*          = 'S': Eigenvalues are ordered (see SELECT).\n*\n*  SELECT  (external procedure) LOGICAL FUNCTION of one COMPLEX*16 argument\n*          SELECT must be declared EXTERNAL in the calling subroutine.\n*          If SORT = 'S', SELECT is used to select eigenvalues to order\n*          to the top left of the Schur form.\n*          If SORT = 'N', SELECT is not referenced.\n*          An eigenvalue W(j) is selected if SELECT(W(j)) is true.\n*\n*  SENSE   (input) CHARACTER*1\n*          Determines which reciprocal condition numbers are computed.\n*          = 'N': None are computed;\n*          = 'E': Computed for average of selected eigenvalues only;\n*          = 'V': Computed for selected right invariant subspace only;\n*          = 'B': Computed for both.\n*          If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA, N)\n*          On entry, the N-by-N matrix A.\n*          On exit, A is overwritten by its Schur form T.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  SDIM    (output) INTEGER\n*          If SORT = 'N', SDIM = 0.\n*          If SORT = 'S', SDIM = number of eigenvalues for which\n*                         SELECT is true.\n*\n*  W       (output) COMPLEX*16 array, dimension (N)\n*          W contains the computed eigenvalues, in the same order\n*          that they appear on the diagonal of the output Schur form T.\n*\n*  VS      (output) COMPLEX*16 array, dimension (LDVS,N)\n*          If JOBVS = 'V', VS contains the unitary matrix Z of Schur\n*          vectors.\n*          If JOBVS = 'N', VS is not referenced.\n*\n*  LDVS    (input) INTEGER\n*          The leading dimension of the array VS.  LDVS >= 1, and if\n*          JOBVS = 'V', LDVS >= N.\n*\n*  RCONDE  (output) DOUBLE PRECISION\n*          If SENSE = 'E' or 'B', RCONDE contains the reciprocal\n*          condition number for the average of the selected eigenvalues.\n*          Not referenced if SENSE = 'N' or 'V'.\n*\n*  RCONDV  (output) DOUBLE PRECISION\n*          If SENSE = 'V' or 'B', RCONDV contains the reciprocal\n*          condition number for the selected right invariant subspace.\n*          Not referenced if SENSE = 'N' or 'E'.\n*\n*  WORK    (workspace/output) COMPLEX*16 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,2*N).\n*          Also, if SENSE = 'E' or 'V' or 'B', LWORK >= 2*SDIM*(N-SDIM),\n*          where SDIM is the number of selected eigenvalues computed by\n*          this routine.  Note that 2*SDIM*(N-SDIM) <= N*N/2. Note also\n*          that an error is only returned if LWORK < max(1,2*N), but if\n*          SENSE = 'E' or 'V' or 'B' this may not be large enough.\n*          For good performance, LWORK must generally be larger.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates upper bound on the optimal size of the\n*          array WORK, returns this value as the first entry of the WORK\n*          array, and no error message related to LWORK is issued by\n*          XERBLA.\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\n*\n*  BWORK   (workspace) LOGICAL array, dimension (N)\n*          Not referenced if SORT = 'N'.\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, and i is\n*             <= N: the QR algorithm failed to compute all the\n*                   eigenvalues; elements 1:ILO-1 and i+1:N of W\n*                   contain those eigenvalues which have converged; if\n*                   JOBVS = 'V', VS contains the transformation which\n*                   reduces A to its partially converged Schur form.\n*             = N+1: the eigenvalues could not be reordered because some\n*                   eigenvalues were too close to separate (the problem\n*                   is very ill-conditioned);\n*             = N+2: after reordering, roundoff changed values of some\n*                   complex eigenvalues so that leading eigenvalues in\n*                   the Schur form no longer satisfy SELECT=.TRUE.  This\n*                   could also be caused by underflow due to scaling.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sdim, w, vs, rconde, rcondv, work, info, a = NumRu::Lapack.zgeesx( jobvs, sort, sense, a, [:lwork => lwork, :usage => usage, :help => help]){|a| ... }\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_jobvs = argv[0];
  rblapack_sort = argv[1];
  rblapack_sense = argv[2];
  rblapack_a = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  jobvs = StringValueCStr(rblapack_jobvs)[0];
  sense = StringValueCStr(rblapack_sense)[0];
  sort = StringValueCStr(rblapack_sort)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  ldvs = lsame_(&jobvs,"V") ? n : 1;
  if (rblapack_lwork == Qnil)
    lwork = (lsame_(&sense,"E")||lsame_(&sense,"V")||lsame_(&sense,"B")) ? n*n/2 : 2*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvs;
    shape[1] = n;
    rblapack_vs = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  vs = NA_PTR_TYPE(rblapack_vs, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  rwork = ALLOC_N(doublereal, (n));
  bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));

  zgeesx_(&jobvs, &sort, rblapack_select, &sense, &n, a, &lda, &sdim, w, vs, &ldvs, &rconde, &rcondv, work, &lwork, rwork, bwork, &info);

  free(rwork);
  free(bwork);
  rblapack_sdim = INT2NUM(sdim);
  rblapack_rconde = rb_float_new((double)rconde);
  rblapack_rcondv = rb_float_new((double)rcondv);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_sdim, rblapack_w, rblapack_vs, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_zgeesx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgeesx", rblapack_zgeesx, -1);
}
ruby-lapack-1.7.2/ext/sgebal.c0000644000175000017500000001374612502221016015772 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgebal_(char* job, integer* n, real* a, integer* lda, integer* ilo, integer* ihi, real* scale, integer* info);


static VALUE
rblapack_sgebal(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_scale;
  real *scale; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *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  ilo, ihi, scale, info, a = NumRu::Lapack.sgebal( job, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGEBAL balances a general real matrix A.  This involves, first,\n*  permuting A by a similarity transformation to isolate eigenvalues\n*  in the first 1 to ILO-1 and last IHI+1 to N elements on the\n*  diagonal; and second, applying a diagonal similarity transformation\n*  to rows and columns ILO to IHI to make the rows and columns as\n*  close in norm as possible.  Both steps are optional.\n*\n*  Balancing may reduce the 1-norm of the matrix, and improve the\n*  accuracy of the computed eigenvalues and/or eigenvectors.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies the operations to be performed on A:\n*          = 'N':  none:  simply set ILO = 1, IHI = N, SCALE(I) = 1.0\n*                  for i = 1,...,N;\n*          = 'P':  permute only;\n*          = 'S':  scale only;\n*          = 'B':  both permute and scale.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the input matrix A.\n*          On exit,  A is overwritten by the balanced matrix.\n*          If JOB = 'N', A is not referenced.\n*          See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  ILO     (output) INTEGER\n*  IHI     (output) INTEGER\n*          ILO and IHI are set to integers such that on exit\n*          A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.\n*          If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n*\n*  SCALE   (output) REAL array, dimension (N)\n*          Details of the permutations and scaling factors applied to\n*          A.  If P(j) is the index of the row and column interchanged\n*          with row and column j and D(j) is the scaling factor\n*          applied to row and column j, then\n*          SCALE(j) = P(j)    for j = 1,...,ILO-1\n*                   = D(j)    for j = ILO,...,IHI\n*                   = P(j)    for j = IHI+1,...,N.\n*          The order in which the interchanges are made is N to IHI+1,\n*          then 1 to ILO-1.\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 permutations consist of row and column interchanges which put\n*  the matrix in the form\n*\n*             ( T1   X   Y  )\n*     P A P = (  0   B   Z  )\n*             (  0   0   T2 )\n*\n*  where T1 and T2 are upper triangular matrices whose eigenvalues lie\n*  along the diagonal.  The column indices ILO and IHI mark the starting\n*  and ending columns of the submatrix B. Balancing consists of applying\n*  a diagonal similarity transformation inv(D) * B * D to make the\n*  1-norms of each row of B and its corresponding column nearly equal.\n*  The output matrix is\n*\n*     ( T1     X*D          Y    )\n*     (  0  inv(D)*B*D  inv(D)*Z ).\n*     (  0      0           T2   )\n*\n*  Information about the permutations P and the diagonal matrix D is\n*  returned in the vector SCALE.\n*\n*  This subroutine is based on the EISPACK routine BALANC.\n*\n*  Modified by Tzu-Yi Chen, Computer Science Division, University of\n*    California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ilo, ihi, scale, info, a = NumRu::Lapack.sgebal( job, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_job = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  job = StringValueCStr(rblapack_job)[0];
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_scale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  scale = NA_PTR_TYPE(rblapack_scale, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  sgebal_(&job, &n, a, &lda, &ilo, &ihi, scale, &info);

  rblapack_ilo = INT2NUM(ilo);
  rblapack_ihi = INT2NUM(ihi);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_ilo, rblapack_ihi, rblapack_scale, rblapack_info, rblapack_a);
}

void
init_lapack_sgebal(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgebal", rblapack_sgebal, -1);
}
ruby-lapack-1.7.2/ext/dlahr2.c0000644000175000017500000001565312502221026015711 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlahr2_(integer* n, integer* k, integer* nb, doublereal* a, integer* lda, doublereal* tau, doublereal* t, integer* ldt, doublereal* y, integer* ldy);


static VALUE
rblapack_dlahr2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_nb;
  integer nb; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_t;
  doublereal *t; 
  VALUE rblapack_y;
  doublereal *y; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;

  integer lda;
  integer ldt;
  integer ldy;

  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, t, y, a = NumRu::Lapack.dlahr2( n, k, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n*  Purpose\n*  =======\n*\n*  DLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1)\n*  matrix A so that elements below the k-th subdiagonal are zero. The\n*  reduction is performed by an orthogonal similarity transformation\n*  Q' * A * Q. The routine returns the matrices V and T which determine\n*  Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n*\n*  This is an auxiliary routine called by DGEHRD.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.\n*\n*  K       (input) INTEGER\n*          The offset for the reduction. Elements below the k-th\n*          subdiagonal in the first NB columns are reduced to zero.\n*          K < N.\n*\n*  NB      (input) INTEGER\n*          The number of columns to be reduced.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N-K+1)\n*          On entry, the n-by-(n-k+1) general matrix A.\n*          On exit, the elements on and above the k-th subdiagonal in\n*          the first NB columns are overwritten with the corresponding\n*          elements of the reduced matrix; the elements below the k-th\n*          subdiagonal, with the array TAU, represent the matrix Q as a\n*          product of elementary reflectors. The other columns of A are\n*          unchanged. See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  TAU     (output) DOUBLE PRECISION array, dimension (NB)\n*          The scalar factors of the elementary reflectors. See Further\n*          Details.\n*\n*  T       (output) DOUBLE PRECISION array, dimension (LDT,NB)\n*          The upper triangular matrix T.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T.  LDT >= NB.\n*\n*  Y       (output) DOUBLE PRECISION array, dimension (LDY,NB)\n*          The n-by-nb matrix Y.\n*\n*  LDY     (input) INTEGER\n*          The leading dimension of the array Y. LDY >= N.\n*\n\n*  Further Details\n*  ===============\n*\n*  The matrix Q is represented as a product of nb elementary reflectors\n*\n*     Q = H(1) H(2) . . . H(nb).\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+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n*  A(i+k+1:n,i), and tau in TAU(i).\n*\n*  The elements of the vectors v together form the (n-k+1)-by-nb matrix\n*  V which is needed, with T and Y, to apply the transformation to the\n*  unreduced part of the matrix, using an update of the form:\n*  A := (I - V*T*V') * (A - Y*V').\n*\n*  The contents of A on exit are illustrated by the following example\n*  with n = 7, k = 3 and nb = 2:\n*\n*     ( a   a   a   a   a )\n*     ( a   a   a   a   a )\n*     ( a   a   a   a   a )\n*     ( h   h   a   a   a )\n*     ( v1  h   a   a   a )\n*     ( v1  v2  a   a   a )\n*     ( v1  v2  a   a   a )\n*\n*  where a denotes an element of the original matrix A, h denotes a\n*  modified element of the upper Hessenberg matrix H, and vi denotes an\n*  element of the vector defining H(i).\n*\n*  This subroutine is a slight modification of LAPACK-3.0's DLAHRD\n*  incorporating improvements proposed by Quintana-Orti and Van de\n*  Gejin. Note that the entries of A(1:K,2:NB) differ from those\n*  returned by the original LAPACK-3.0's DLAHRD routine. (This\n*  subroutine is not backward compatible with LAPACK-3.0's DLAHRD.)\n*\n*  References\n*  ==========\n*\n*  Gregorio Quintana-Orti and Robert van de Geijn, \"Improving the\n*  performance of reduction to Hessenberg form,\" ACM Transactions on\n*  Mathematical Software, 32(2):180-194, June 2006.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, t, y, a = NumRu::Lapack.dlahr2( n, k, nb, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_n = argv[0];
  rblapack_k = argv[1];
  rblapack_nb = argv[2];
  rblapack_a = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  nb = NUM2INT(rblapack_nb);
  ldy = n;
  k = NUM2INT(rblapack_k);
  ldt = nb;
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != (n-k+1))
    rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", n-k+1);
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,nb);
    rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = MAX(1,nb);
    rblapack_t = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  t = NA_PTR_TYPE(rblapack_t, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldy;
    shape[1] = MAX(1,nb);
    rblapack_y = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  y = NA_PTR_TYPE(rblapack_y, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n-k+1;
    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__;

  dlahr2_(&n, &k, &nb, a, &lda, tau, t, &ldt, y, &ldy);

  return rb_ary_new3(4, rblapack_tau, rblapack_t, rblapack_y, rblapack_a);
}

void
init_lapack_dlahr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlahr2", rblapack_dlahr2, -1);
}
ruby-lapack-1.7.2/ext/sgeqrf.c0000644000175000017500000001327012502221013016011 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgeqrf_(integer* m, integer* n, real* a, integer* lda, real* tau, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sgeqrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *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.sgeqrf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGEQRF computes a QR factorization of a real M-by-N matrix A:\n*  A = Q * R.\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) REAL array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, the elements on and above the diagonal of the array\n*          contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n*          upper triangular if m >= n); the elements below the diagonal,\n*          with the array TAU, represent the orthogonal matrix Q as a\n*          product of min(m,n) elementary reflectors (see Further\n*          Details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  TAU     (output) REAL array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace/output) REAL 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,N).\n*          For optimum performance LWORK >= N*NB, where NB is \n*          the 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(1) H(2) . . . H(k), 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:m) is stored on exit in A(i+1:m,i),\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           SGEQR2, SLARFB, SLARFT, 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.sgeqrf( 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;
  }

  m = NUM2INT(rblapack_m);
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  sgeqrf_(&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_sgeqrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgeqrf", rblapack_sgeqrf, -1);
}
ruby-lapack-1.7.2/ext/clantb.c0000644000175000017500000001202412502221021015760 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real clantb_(char* norm, char* uplo, char* diag, integer* n, integer* k, complex* ab, integer* ldab, real* work);


static VALUE
rblapack_clantb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack___out__;
  real __out__; 
  real *work;

  integer ldab;
  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  __out__ = NumRu::Lapack.clantb( norm, uplo, diag, k, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL             FUNCTION CLANTB( NORM, UPLO, DIAG, N, K, AB, LDAB, WORK )\n\n*  Purpose\n*  =======\n*\n*  CLANTB  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the element of  largest absolute value  of an\n*  n by n triangular band matrix A,  with ( k + 1 ) diagonals.\n*\n*  Description\n*  ===========\n*\n*  CLANTB returns the value\n*\n*     CLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in CLANTB as described\n*          above.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the matrix A is upper or lower triangular.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  DIAG    (input) CHARACTER*1\n*          Specifies whether or not the matrix A is unit triangular.\n*          = 'N':  Non-unit triangular\n*          = 'U':  Unit triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, CLANTB is\n*          set to zero.\n*\n*  K       (input) INTEGER\n*          The number of super-diagonals of the matrix A if UPLO = 'U',\n*          or the number of sub-diagonals of the matrix A if UPLO = 'L'.\n*          K >= 0.\n*\n*  AB      (input) COMPLEX array, dimension (LDAB,N)\n*          The upper or lower triangular band matrix A, stored in the\n*          first k+1 rows of AB.  The j-th column of A is stored\n*          in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)   = A(i,j) for j<=i<=min(n,j+k).\n*          Note that when DIAG = 'U', the elements of the array AB\n*          corresponding to the diagonal elements of the matrix A are\n*          not referenced, but are assumed to be one.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= K+1.\n*\n*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n*          referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.clantb( norm, uplo, diag, k, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_diag = argv[2];
  rblapack_k = argv[3];
  rblapack_ab = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  k = NUM2INT(rblapack_k);
  work = ALLOC_N(real, (MAX(1,lsame_(&norm,"I") ? n : 0)));

  __out__ = clantb_(&norm, &uplo, &diag, &n, &k, ab, &ldab, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_clantb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clantb", rblapack_clantb, -1);
}
ruby-lapack-1.7.2/ext/dla_gbrfsx_extended.c0000644000175000017500000006036012502221025020522 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dla_gbrfsx_extended_(integer* prec_type, integer* trans_type, integer* n, integer* kl, integer* ku, integer* nrhs, doublereal* ab, integer* ldab, doublereal* afb, integer* ldafb, integer* ipiv, logical* colequ, doublereal* c, doublereal* b, integer* ldb, doublereal* y, integer* ldy, doublereal* berr_out, integer* n_norms, doublereal* err_bnds_norm, doublereal* err_bnds_comp, doublereal* res, doublereal* ayb, doublereal* dy, doublereal* y_tail, doublereal* rcond, integer* ithresh, doublereal* rthresh, doublereal* dz_ub, logical* ignore_cwise, integer* info);


static VALUE
rblapack_dla_gbrfsx_extended(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_prec_type;
  integer prec_type; 
  VALUE rblapack_trans_type;
  integer trans_type; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_afb;
  doublereal *afb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_colequ;
  logical colequ; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_y;
  doublereal *y; 
  VALUE rblapack_err_bnds_norm;
  doublereal *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  doublereal *err_bnds_comp; 
  VALUE rblapack_res;
  doublereal *res; 
  VALUE rblapack_ayb;
  doublereal *ayb; 
  VALUE rblapack_dy;
  doublereal *dy; 
  VALUE rblapack_y_tail;
  doublereal *y_tail; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_ithresh;
  integer ithresh; 
  VALUE rblapack_rthresh;
  doublereal rthresh; 
  VALUE rblapack_dz_ub;
  doublereal dz_ub; 
  VALUE rblapack_ignore_cwise;
  logical ignore_cwise; 
  VALUE rblapack_berr_out;
  doublereal *berr_out; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_y_out__;
  doublereal *y_out__;
  VALUE rblapack_err_bnds_norm_out__;
  doublereal *err_bnds_norm_out__;
  VALUE rblapack_err_bnds_comp_out__;
  doublereal *err_bnds_comp_out__;

  integer ldab;
  integer n;
  integer ldafb;
  integer ldb;
  integer nrhs;
  integer ldy;
  integer n_norms;

  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  berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.dla_gbrfsx_extended( prec_type, trans_type, kl, ku, ab, afb, ipiv, colequ, c, b, y, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n*  Purpose\n*  =======\n* \n*  DLA_GBRFSX_EXTENDED improves the computed solution to a system of\n*  linear equations by performing extra-precise iterative refinement\n*  and provides error bounds and backward error estimates for the solution.\n*  This subroutine is called by DGBRFSX to perform iterative refinement.\n*  In addition to normwise error bound, the code provides maximum\n*  componentwise error bound if possible. See comments for ERR_BNDS_NORM\n*  and ERR_BNDS_COMP for details of the error bounds. Note that this\n*  subroutine is only resonsible for setting the second fields of\n*  ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n*  Arguments\n*  =========\n*\n*     PREC_TYPE      (input) INTEGER\n*     Specifies the intermediate precision to be used in refinement.\n*     The value is defined by ILAPREC(P) where P is a CHARACTER and\n*     P    = 'S':  Single\n*          = 'D':  Double\n*          = 'I':  Indigenous\n*          = 'X', 'E':  Extra\n*\n*     TRANS_TYPE     (input) INTEGER\n*     Specifies the transposition operation on A.\n*     The value is defined by ILATRANS(T) where T is a CHARACTER and\n*     T    = 'N':  No transpose\n*          = 'T':  Transpose\n*          = 'C':  Conjugate transpose\n*\n*     N              (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     KL             (input) INTEGER\n*     The number of subdiagonals within the band of A.  KL >= 0.\n*\n*     KU             (input) INTEGER\n*     The number of superdiagonals within the band of A.  KU >= 0\n*\n*     NRHS           (input) INTEGER\n*     The number of right-hand-sides, i.e., the number of columns of the\n*     matrix B.\n*\n*     A              (input) DOUBLE PRECISION array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA            (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF             (input) DOUBLE PRECISION array, dimension (LDAF,N)\n*     The factors L and U from the factorization\n*     A = P*L*U as computed by DGBTRF.\n*\n*     LDAF           (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV           (input) INTEGER array, dimension (N)\n*     The pivot indices from the factorization A = P*L*U\n*     as computed by DGBTRF; row i of the matrix was interchanged\n*     with row IPIV(i).\n*\n*     COLEQU         (input) LOGICAL\n*     If .TRUE. then column equilibration was done to A before calling\n*     this routine. This is needed to compute the solution and error\n*     bounds correctly.\n*\n*     C              (input) DOUBLE PRECISION array, dimension (N)\n*     The column scale factors for A. If COLEQU = .FALSE., C\n*     is not accessed. If C is input, each element of C should be a power\n*     of the radix to ensure a reliable solution and error estimates.\n*     Scaling by powers of the radix does not cause rounding errors unless\n*     the result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B              (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*     The right-hand-side matrix B.\n*\n*     LDB            (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     Y              (input/output) DOUBLE PRECISION array, dimension \n*                    (LDY,NRHS)\n*     On entry, the solution matrix X, as computed by DGBTRS.\n*     On exit, the improved solution matrix Y.\n*\n*     LDY            (input) INTEGER\n*     The leading dimension of the array Y.  LDY >= max(1,N).\n*\n*     BERR_OUT       (output) DOUBLE PRECISION array, dimension (NRHS)\n*     On exit, BERR_OUT(j) contains the componentwise relative backward\n*     error for right-hand-side j from the formula\n*         max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n*     where abs(Z) is the componentwise absolute value of the matrix\n*     or vector Z. This is computed by DLA_LIN_BERR.\n*\n*     N_NORMS        (input) INTEGER\n*     Determines which error bounds to return (see ERR_BNDS_NORM\n*     and ERR_BNDS_COMP).\n*     If N_NORMS >= 1 return normwise error bounds.\n*     If N_NORMS >= 2 return componentwise error bounds.\n*\n*     ERR_BNDS_NORM  (input/output) DOUBLE PRECISION array, dimension \n*                    (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (input/output) DOUBLE PRECISION array, dimension \n*                    (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     RES            (input) DOUBLE PRECISION array, dimension (N)\n*     Workspace to hold the intermediate residual.\n*\n*     AYB            (input) DOUBLE PRECISION array, dimension (N)\n*     Workspace. This can be the same workspace passed for Y_TAIL.\n*\n*     DY             (input) DOUBLE PRECISION array, dimension (N)\n*     Workspace to hold the intermediate solution.\n*\n*     Y_TAIL         (input) DOUBLE PRECISION array, dimension (N)\n*     Workspace to hold the trailing bits of the intermediate solution.\n*\n*     RCOND          (input) DOUBLE PRECISION\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     ITHRESH        (input) INTEGER\n*     The maximum number of residual computations allowed for\n*     refinement. The default is 10. For 'aggressive' set to 100 to\n*     permit convergence using approximate factorizations or\n*     factorizations other than LU. If the factorization uses a\n*     technique other than Gaussian elimination, the guarantees in\n*     ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n*     RTHRESH        (input) DOUBLE PRECISION\n*     Determines when to stop refinement if the error estimate stops\n*     decreasing. Refinement will stop when the next solution no longer\n*     satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n*     the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n*     default value is 0.5. For 'aggressive' set to 0.9 to permit\n*     convergence on extremely ill-conditioned matrices. See LAWN 165\n*     for more details.\n*\n*     DZ_UB          (input) DOUBLE PRECISION\n*     Determines when to start considering componentwise convergence.\n*     Componentwise convergence is only considered after each component\n*     of the solution Y is stable, which we definte as the relative\n*     change in each component being less than DZ_UB. The default value\n*     is 0.25, requiring the first bit to be stable. See LAWN 165 for\n*     more details.\n*\n*     IGNORE_CWISE   (input) LOGICAL\n*     If .TRUE. then ignore componentwise convergence. Default value\n*     is .FALSE..\n*\n*     INFO           (output) INTEGER\n*       = 0:  Successful exit.\n*       < 0:  if INFO = -i, the ith argument to DGBTRS had an illegal\n*             value\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      CHARACTER          TRANS\n      INTEGER            CNT, I, J, M, X_STATE, Z_STATE, Y_PREC_STATE\n      DOUBLE PRECISION   YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n     $                   DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n     $                   DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n     $                   EPS, HUGEVAL, INCR_THRESH\n      LOGICAL            INCR_PREC\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.dla_gbrfsx_extended( prec_type, trans_type, kl, ku, ab, afb, ipiv, colequ, c, b, y, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 22 && argc != 22)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 22)", argc);
  rblapack_prec_type = argv[0];
  rblapack_trans_type = argv[1];
  rblapack_kl = argv[2];
  rblapack_ku = argv[3];
  rblapack_ab = argv[4];
  rblapack_afb = argv[5];
  rblapack_ipiv = argv[6];
  rblapack_colequ = argv[7];
  rblapack_c = argv[8];
  rblapack_b = argv[9];
  rblapack_y = argv[10];
  rblapack_err_bnds_norm = argv[11];
  rblapack_err_bnds_comp = argv[12];
  rblapack_res = argv[13];
  rblapack_ayb = argv[14];
  rblapack_dy = argv[15];
  rblapack_y_tail = argv[16];
  rblapack_rcond = argv[17];
  rblapack_ithresh = argv[18];
  rblapack_rthresh = argv[19];
  rblapack_dz_ub = argv[20];
  rblapack_ignore_cwise = argv[21];
  if (argc == 22) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  prec_type = NUM2INT(rblapack_prec_type);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  ldab = n;
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  colequ = (rblapack_colequ == Qtrue);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (10th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (10th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  rcond = NUM2DBL(rblapack_rcond);
  rthresh = NUM2DBL(rblapack_rthresh);
  ignore_cwise = (rblapack_ignore_cwise == Qtrue);
  n_norms = 3;
  trans_type = NUM2INT(rblapack_trans_type);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (11th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 2)
    rb_raise(rb_eArgError, "rank of y (11th argument) must be %d", 2);
  ldy = NA_SHAPE0(rblapack_y);
  if (NA_SHAPE1(rblapack_y) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_y) != NA_DFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
  y = NA_PTR_TYPE(rblapack_y, doublereal*);
  if (!NA_IsNArray(rblapack_err_bnds_comp))
    rb_raise(rb_eArgError, "err_bnds_comp (13th argument) must be NArray");
  if (NA_RANK(rblapack_err_bnds_comp) != 2)
    rb_raise(rb_eArgError, "rank of err_bnds_comp (13th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_err_bnds_comp) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of b");
  if (NA_SHAPE1(rblapack_err_bnds_comp) != n_norms)
    rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_comp must be 3");
  if (NA_TYPE(rblapack_err_bnds_comp) != NA_DFLOAT)
    rblapack_err_bnds_comp = na_change_type(rblapack_err_bnds_comp, NA_DFLOAT);
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
  ithresh = NUM2INT(rblapack_ithresh);
  n = ldab;
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be ldab");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_err_bnds_norm))
    rb_raise(rb_eArgError, "err_bnds_norm (12th argument) must be NArray");
  if (NA_RANK(rblapack_err_bnds_norm) != 2)
    rb_raise(rb_eArgError, "rank of err_bnds_norm (12th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_err_bnds_norm) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of b");
  if (NA_SHAPE1(rblapack_err_bnds_norm) != n_norms)
    rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_norm must be 3");
  if (NA_TYPE(rblapack_err_bnds_norm) != NA_DFLOAT)
    rblapack_err_bnds_norm = na_change_type(rblapack_err_bnds_norm, NA_DFLOAT);
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
  if (!NA_IsNArray(rblapack_ayb))
    rb_raise(rb_eArgError, "ayb (15th argument) must be NArray");
  if (NA_RANK(rblapack_ayb) != 1)
    rb_raise(rb_eArgError, "rank of ayb (15th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ayb) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ayb must be ldab");
  if (NA_TYPE(rblapack_ayb) != NA_DFLOAT)
    rblapack_ayb = na_change_type(rblapack_ayb, NA_DFLOAT);
  ayb = NA_PTR_TYPE(rblapack_ayb, doublereal*);
  if (!NA_IsNArray(rblapack_y_tail))
    rb_raise(rb_eArgError, "y_tail (17th argument) must be NArray");
  if (NA_RANK(rblapack_y_tail) != 1)
    rb_raise(rb_eArgError, "rank of y_tail (17th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y_tail) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be ldab");
  if (NA_TYPE(rblapack_y_tail) != NA_DFLOAT)
    rblapack_y_tail = na_change_type(rblapack_y_tail, NA_DFLOAT);
  y_tail = NA_PTR_TYPE(rblapack_y_tail, doublereal*);
  ldafb = n;
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_afb) != ldafb)
    rb_raise(rb_eRuntimeError, "shape 0 of afb must be n");
  if (NA_SHAPE1(rblapack_afb) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of afb must be ldab");
  if (NA_TYPE(rblapack_afb) != NA_DFLOAT)
    rblapack_afb = na_change_type(rblapack_afb, NA_DFLOAT);
  afb = NA_PTR_TYPE(rblapack_afb, doublereal*);
  if (!NA_IsNArray(rblapack_res))
    rb_raise(rb_eArgError, "res (14th argument) must be NArray");
  if (NA_RANK(rblapack_res) != 1)
    rb_raise(rb_eArgError, "rank of res (14th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_res) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of res must be ldab");
  if (NA_TYPE(rblapack_res) != NA_DFLOAT)
    rblapack_res = na_change_type(rblapack_res, NA_DFLOAT);
  res = NA_PTR_TYPE(rblapack_res, doublereal*);
  dz_ub = NUM2DBL(rblapack_dz_ub);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (9th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be ldab");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_dy))
    rb_raise(rb_eArgError, "dy (16th argument) must be NArray");
  if (NA_RANK(rblapack_dy) != 1)
    rb_raise(rb_eArgError, "rank of dy (16th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dy) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of dy must be ldab");
  if (NA_TYPE(rblapack_dy) != NA_DFLOAT)
    rblapack_dy = na_change_type(rblapack_dy, NA_DFLOAT);
  dy = NA_PTR_TYPE(rblapack_dy, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr_out = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr_out = NA_PTR_TYPE(rblapack_berr_out, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldy;
    shape[1] = nrhs;
    rblapack_y_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
  MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_norms;
    rblapack_err_bnds_norm_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm_out__ = NA_PTR_TYPE(rblapack_err_bnds_norm_out__, doublereal*);
  MEMCPY(err_bnds_norm_out__, err_bnds_norm, doublereal, NA_TOTAL(rblapack_err_bnds_norm));
  rblapack_err_bnds_norm = rblapack_err_bnds_norm_out__;
  err_bnds_norm = err_bnds_norm_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_norms;
    rblapack_err_bnds_comp_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp_out__ = NA_PTR_TYPE(rblapack_err_bnds_comp_out__, doublereal*);
  MEMCPY(err_bnds_comp_out__, err_bnds_comp, doublereal, NA_TOTAL(rblapack_err_bnds_comp));
  rblapack_err_bnds_comp = rblapack_err_bnds_comp_out__;
  err_bnds_comp = err_bnds_comp_out__;

  dla_gbrfsx_extended_(&prec_type, &trans_type, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_err_bnds_norm, rblapack_err_bnds_comp);
}

void
init_lapack_dla_gbrfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dla_gbrfsx_extended", rblapack_dla_gbrfsx_extended, -1);
}
ruby-lapack-1.7.2/ext/sgebrd.c0000644000175000017500000002116312502221023015771 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgebrd_(integer* m, integer* n, real* a, integer* lda, real* d, real* e, real* tauq, real* taup, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sgebrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_tauq;
  real *tauq; 
  VALUE rblapack_taup;
  real *taup; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *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  d, e, tauq, taup, work, info, a = NumRu::Lapack.sgebrd( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGEBRD reduces a general real M-by-N matrix A to upper or lower\n*  bidiagonal form B by an orthogonal transformation: Q**T * A * P = B.\n*\n*  If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows in the matrix A.  M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns in the matrix A.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the M-by-N general matrix to be reduced.\n*          On exit,\n*          if m >= n, the diagonal and the first superdiagonal are\n*            overwritten with the upper bidiagonal matrix B; the\n*            elements below the diagonal, with the array TAUQ, represent\n*            the orthogonal matrix Q as a product of elementary\n*            reflectors, and the elements above the first superdiagonal,\n*            with the array TAUP, represent the orthogonal matrix P as\n*            a product of elementary reflectors;\n*          if m < n, the diagonal and the first subdiagonal are\n*            overwritten with the lower bidiagonal matrix B; the\n*            elements below the first subdiagonal, with the array TAUQ,\n*            represent the orthogonal matrix Q as a product of\n*            elementary reflectors, and the elements above the diagonal,\n*            with the array TAUP, represent the orthogonal matrix P as\n*            a product of elementary reflectors.\n*          See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  D       (output) REAL array, dimension (min(M,N))\n*          The diagonal elements of the bidiagonal matrix B:\n*          D(i) = A(i,i).\n*\n*  E       (output) REAL array, dimension (min(M,N)-1)\n*          The off-diagonal elements of the bidiagonal matrix B:\n*          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n*          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n*\n*  TAUQ    (output) REAL array dimension (min(M,N))\n*          The scalar factors of the elementary reflectors which\n*          represent the orthogonal matrix Q. See Further Details.\n*\n*  TAUP    (output) REAL array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors which\n*          represent the orthogonal matrix P. See Further Details.\n*\n*  WORK    (workspace/output) REAL array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of the array WORK.  LWORK >= max(1,M,N).\n*          For optimum performance LWORK >= (M+N)*NB, where NB\n*          is the 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 matrices Q and P are represented as products of elementary\n*  reflectors:\n*\n*  If m >= n,\n*\n*     Q = H(1) H(2) . . . H(n)  and  P = G(1) G(2) . . . G(n-1)\n*\n*  Each H(i) and G(i) has the form:\n*\n*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'\n*\n*  where tauq and taup are real scalars, and v and u are real vectors;\n*  v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);\n*  u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);\n*  tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n*  If m < n,\n*\n*     Q = H(1) H(2) . . . H(m-1)  and  P = G(1) G(2) . . . G(m)\n*\n*  Each H(i) and G(i) has the form:\n*\n*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'\n*\n*  where tauq and taup are real scalars, and v and u are real vectors;\n*  v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);\n*  u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);\n*  tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n*  The contents of A on exit are illustrated by the following examples:\n*\n*  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):\n*\n*    (  d   e   u1  u1  u1 )           (  d   u1  u1  u1  u1  u1 )\n*    (  v1  d   e   u2  u2 )           (  e   d   u2  u2  u2  u2 )\n*    (  v1  v2  d   e   u3 )           (  v1  e   d   u3  u3  u3 )\n*    (  v1  v2  v3  d   e  )           (  v1  v2  e   d   u4  u4 )\n*    (  v1  v2  v3  v4  d  )           (  v1  v2  v3  e   d   u5 )\n*    (  v1  v2  v3  v4  v5 )\n*\n*  where d and e denote diagonal and off-diagonal elements of B, vi\n*  denotes an element of the vector defining H(i), and ui an element of\n*  the vector defining G(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, tauq, taup, work, info, a = NumRu::Lapack.sgebrd( 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;
  }

  m = NUM2INT(rblapack_m);
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (rblapack_lwork == Qnil)
    lwork = MAX(m,n);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, real*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n)-1;
    rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tauq = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  tauq = NA_PTR_TYPE(rblapack_tauq, real*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_taup = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  taup = NA_PTR_TYPE(rblapack_taup, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  sgebrd_(&m, &n, a, &lda, d, e, tauq, taup, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_d, rblapack_e, rblapack_tauq, rblapack_taup, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_sgebrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgebrd", rblapack_sgebrd, -1);
}
ruby-lapack-1.7.2/ext/cgesc2.c0000644000175000017500000001255712502221025015702 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgesc2_(integer* n, complex* a, integer* lda, complex* rhs, integer* ipiv, integer* jpiv, real* scale);


static VALUE
rblapack_cgesc2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_rhs;
  complex *rhs; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_jpiv;
  integer *jpiv; 
  VALUE rblapack_scale;
  real scale; 
  VALUE rblapack_rhs_out__;
  complex *rhs_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  scale, rhs = NumRu::Lapack.cgesc2( a, rhs, ipiv, jpiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )\n\n*  Purpose\n*  =======\n*\n*  CGESC2 solves a system of linear equations\n*\n*            A * X = scale* RHS\n*\n*  with a general N-by-N matrix A using the LU factorization with\n*  complete pivoting computed by CGETC2.\n*\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.\n*\n*  A       (input) COMPLEX array, dimension (LDA, N)\n*          On entry, the  LU part of the factorization of the n-by-n\n*          matrix A computed by CGETC2:  A = P * L * U * Q\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1, N).\n*\n*  RHS     (input/output) COMPLEX array, dimension N.\n*          On entry, the right hand side vector b.\n*          On exit, the solution vector X.\n*\n*  IPIV    (input) INTEGER array, dimension (N).\n*          The pivot indices; for 1 <= i <= N, row i of the\n*          matrix has been interchanged with row IPIV(i).\n*\n*  JPIV    (input) INTEGER array, dimension (N).\n*          The pivot indices; for 1 <= j <= N, column j of the\n*          matrix has been interchanged with column JPIV(j).\n*\n*  SCALE    (output) REAL\n*           On exit, SCALE contains the scale factor. SCALE is chosen\n*           0 <= SCALE <= 1 to prevent owerflow in the solution.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, rhs = NumRu::Lapack.cgesc2( a, rhs, ipiv, jpiv, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_a = argv[0];
  rblapack_rhs = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_jpiv = argv[3];
  if (argc == 4) {
  } 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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_rhs))
    rb_raise(rb_eArgError, "rhs (2th argument) must be NArray");
  if (NA_RANK(rblapack_rhs) != 1)
    rb_raise(rb_eArgError, "rank of rhs (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_rhs) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of rhs must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_rhs) != NA_SCOMPLEX)
    rblapack_rhs = na_change_type(rblapack_rhs, NA_SCOMPLEX);
  rhs = NA_PTR_TYPE(rblapack_rhs, complex*);
  if (!NA_IsNArray(rblapack_jpiv))
    rb_raise(rb_eArgError, "jpiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_jpiv) != 1)
    rb_raise(rb_eArgError, "rank of jpiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_jpiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of jpiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_jpiv) != NA_LINT)
    rblapack_jpiv = na_change_type(rblapack_jpiv, NA_LINT);
  jpiv = NA_PTR_TYPE(rblapack_jpiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rhs_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  rhs_out__ = NA_PTR_TYPE(rblapack_rhs_out__, complex*);
  MEMCPY(rhs_out__, rhs, complex, NA_TOTAL(rblapack_rhs));
  rblapack_rhs = rblapack_rhs_out__;
  rhs = rhs_out__;

  cgesc2_(&n, a, &lda, rhs, ipiv, jpiv, &scale);

  rblapack_scale = rb_float_new((double)scale);
  return rb_ary_new3(2, rblapack_scale, rblapack_rhs);
}

void
init_lapack_cgesc2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgesc2", rblapack_cgesc2, -1);
}
ruby-lapack-1.7.2/ext/ilatrans.c0000644000175000017500000000404312502221021016334 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern integer ilatrans_(char* trans);


static VALUE
rblapack_ilatrans(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack___out__;
  integer __out__; 


  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  __out__ = NumRu::Lapack.ilatrans( trans, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      INTEGER FUNCTION ILATRANS( TRANS )\n\n*  Purpose\n*  =======\n*\n*  This subroutine translates from a character string specifying a\n*  transposition operation to the relevant BLAST-specified integer\n*  constant.\n*\n*  ILATRANS returns an INTEGER.  If ILATRANS < 0, then the input is not\n*  a character indicating a transposition operator.  Otherwise ILATRANS\n*  returns the constant value corresponding to TRANS.\n*\n\n*  Arguments\n*  =========\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  No transpose\n*          = 'T':  Transpose\n*          = 'C':  Conjugate transpose\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.ilatrans( trans, [: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_trans = argv[0];
  if (argc == 1) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];

  __out__ = ilatrans_(&trans);

  rblapack___out__ = INT2NUM(__out__);
  return rblapack___out__;
}

void
init_lapack_ilatrans(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ilatrans", rblapack_ilatrans, -1);
}
ruby-lapack-1.7.2/ext/zlanhf.c0000644000175000017500000002236612502221026016016 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal zlanhf_(char* norm, char* transr, char* uplo, integer* n, doublecomplex* a, doublereal* work);


static VALUE
rblapack_zlanhf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack___out__;
  doublereal __out__; 
  doublereal *work;

  integer lwork;

  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  __out__ = NumRu::Lapack.zlanhf( norm, transr, uplo, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION ZLANHF( NORM, TRANSR, UPLO, N, A, WORK )\n\n*  Purpose\n*  =======\n*\n*  ZLANHF  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  complex Hermitian matrix A in RFP format.\n*\n*  Description\n*  ===========\n*\n*  ZLANHF returns the value\n*\n*     ZLANHF = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a  matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM      (input) CHARACTER\n*            Specifies the value to be returned in ZLANHF as described\n*            above.\n*\n*  TRANSR    (input) CHARACTER\n*            Specifies whether the RFP format of A is normal or\n*            conjugate-transposed format.\n*            = 'N':  RFP format is Normal\n*            = 'C':  RFP format is Conjugate-transposed\n*\n*  UPLO      (input) CHARACTER\n*            On entry, UPLO specifies whether the RFP matrix A came from\n*            an upper or lower triangular matrix as follows:\n*\n*            UPLO = 'U' or 'u' RFP A came from an upper triangular\n*            matrix\n*\n*            UPLO = 'L' or 'l' RFP A came from a  lower triangular\n*            matrix\n*\n*  N         (input) INTEGER\n*            The order of the matrix A.  N >= 0.  When N = 0, ZLANHF is\n*            set to zero.\n*\n*   A        (input) COMPLEX*16 array, dimension ( N*(N+1)/2 );\n*            On entry, the matrix A in RFP Format.\n*            RFP Format is described by TRANSR, UPLO and N as follows:\n*            If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;\n*            K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If\n*            TRANSR = 'C' then RFP is the Conjugate-transpose of RFP A\n*            as defined when TRANSR = 'N'. The contents of RFP A are\n*            defined by UPLO as follows: If UPLO = 'U' the RFP A\n*            contains the ( N*(N+1)/2 ) elements of upper packed A\n*            either in normal or conjugate-transpose Format. If\n*            UPLO = 'L' the RFP A contains the ( N*(N+1) /2 ) elements\n*            of lower packed A either in normal or conjugate-transpose\n*            Format. The LDA of RFP A is (N+1)/2 when TRANSR = 'C'. When\n*            TRANSR is 'N' the LDA is N+1 when N is even and is N when\n*            is odd. See the Note below for more details.\n*            Unchanged on exit.\n*\n*  WORK      (workspace) DOUBLE PRECISION array, dimension (LWORK),\n*            where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n*            WORK is not referenced.\n*\n\n*  Further Details\n*  ===============\n*\n*  We first consider Standard Packed Format when N is even.\n*  We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  conjugate-transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  conjugate-transpose of the last three columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                -- -- --\n*        03 04 05                33 43 53\n*                                   -- --\n*        13 14 15                00 44 54\n*                                      --\n*        23 24 25                10 11 55\n*\n*        33 34 35                20 21 22\n*        --\n*        00 44 45                30 31 32\n*        -- --\n*        01 11 55                40 41 42\n*        -- -- --\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- -- --                -- -- -- -- -- --\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     -- -- -- -- --                -- -- -- -- --\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     -- -- -- -- -- --                -- -- -- --\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We next  consider Standard Packed Format when N is odd.\n*  We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  conjugate-transpose of the first two   columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  conjugate-transpose of the last two   columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N odd  and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                   -- --\n*        02 03 04                00 33 43\n*                                      --\n*        12 13 14                10 11 44\n*\n*        22 23 24                20 21 22\n*        --\n*        00 33 34                30 31 32\n*        -- --\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- --                   -- -- -- -- -- --\n*     02 12 22 00 01             00 10 20 30 40 50\n*     -- -- -- --                   -- -- -- -- --\n*     03 13 23 33 11             33 11 21 31 41 51\n*     -- -- -- -- --                   -- -- -- --\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.zlanhf( norm, transr, uplo, n, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_norm = argv[0];
  rblapack_transr = argv[1];
  rblapack_uplo = argv[2];
  rblapack_n = argv[3];
  rblapack_a = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  transr = StringValueCStr(rblapack_transr)[0];
  n = NUM2INT(rblapack_n);
  lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 1)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  work = ALLOC_N(doublereal, (lwork));

  __out__ = zlanhf_(&norm, &transr, &uplo, &n, a, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_zlanhf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlanhf", rblapack_zlanhf, -1);
}
ruby-lapack-1.7.2/ext/zgesvx.c0000644000175000017500000005064312502221023016056 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgesvx_(char* fact, char* trans, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, char* equed, doublereal* r, doublereal* c, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zgesvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_r;
  doublereal *r; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_rwork;
  doublereal *rwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_af_out__;
  doublecomplex *af_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  VALUE rblapack_r_out__;
  doublereal *r_out__;
  VALUE rblapack_c_out__;
  doublereal *c_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  doublecomplex *work;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;
  integer ldaf;
  integer ldx;

  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  x, rcond, ferr, berr, rwork, info, a, af, ipiv, equed, r, c, b = NumRu::Lapack.zgesvx( fact, trans, a, b, [:af => af, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGESVX uses the LU factorization to compute the solution to a complex\n*  system of linear equations\n*     A * X = B,\n*  where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'E', real scaling factors are computed to equilibrate\n*     the system:\n*        TRANS = 'N':  diag(R)*A*diag(C)     *inv(diag(C))*X = diag(R)*B\n*        TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n*        TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n*     or diag(C)*B (if TRANS = 'T' or 'C').\n*\n*  2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n*     matrix A (after equilibration if FACT = 'E') as\n*        A = P * L * U,\n*     where P is a permutation matrix, L is a unit lower triangular\n*     matrix, and U is upper triangular.\n*\n*  3. If some U(i,i)=0, so that U is exactly singular, then the routine\n*     returns with INFO = i. Otherwise, the factored form of A is used\n*     to estimate the condition number of the matrix A.  If the\n*     reciprocal of the condition number is less than machine precision,\n*     INFO = N+1 is returned as a warning, but the routine still goes on\n*     to solve for X and compute error bounds as described below.\n*\n*  4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  5. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n*  6. If equilibration was used, the matrix X is premultiplied by\n*     diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n*     that it solves the original system before equilibration.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of the matrix A is\n*          supplied on entry, and if not, whether the matrix A should be\n*          equilibrated before it is factored.\n*          = 'F':  On entry, AF and IPIV contain the factored form of A.\n*                  If EQUED is not 'N', the matrix A has been\n*                  equilibrated with scaling factors given by R and C.\n*                  A, AF, and IPIV are not modified.\n*          = 'N':  The matrix A will be copied to AF and factored.\n*          = 'E':  The matrix A will be equilibrated if necessary, then\n*                  copied to AF and factored.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose)\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the N-by-N matrix A.  If FACT = 'F' and EQUED is\n*          not 'N', then A must have been equilibrated by the scaling\n*          factors in R and/or C.  A is not modified if FACT = 'F' or\n*          'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n*          On exit, if EQUED .ne. 'N', A is scaled as follows:\n*          EQUED = 'R':  A := diag(R) * A\n*          EQUED = 'C':  A := A * diag(C)\n*          EQUED = 'B':  A := diag(R) * A * diag(C).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AF      (input or output) COMPLEX*16 array, dimension (LDAF,N)\n*          If FACT = 'F', then AF is an input argument and on entry\n*          contains the factors L and U from the factorization\n*          A = P*L*U as computed by ZGETRF.  If EQUED .ne. 'N', then\n*          AF is the factored form of the equilibrated matrix A.\n*\n*          If FACT = 'N', then AF is an output argument and on exit\n*          returns the factors L and U from the factorization A = P*L*U\n*          of the original matrix A.\n*\n*          If FACT = 'E', then AF is an output argument and on exit\n*          returns the factors L and U from the factorization A = P*L*U\n*          of the equilibrated matrix A (see the description of A for\n*          the form of the equilibrated matrix).\n*\n*  LDAF    (input) INTEGER\n*          The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*  IPIV    (input or output) INTEGER array, dimension (N)\n*          If FACT = 'F', then IPIV is an input argument and on entry\n*          contains the pivot indices from the factorization A = P*L*U\n*          as computed by ZGETRF; row i of the matrix was interchanged\n*          with row IPIV(i).\n*\n*          If FACT = 'N', then IPIV is an output argument and on exit\n*          contains the pivot indices from the factorization A = P*L*U\n*          of the original matrix A.\n*\n*          If FACT = 'E', then IPIV is an output argument and on exit\n*          contains the pivot indices from the factorization A = P*L*U\n*          of the equilibrated matrix A.\n*\n*  EQUED   (input or output) CHARACTER*1\n*          Specifies the form of equilibration that was done.\n*          = 'N':  No equilibration (always true if FACT = 'N').\n*          = 'R':  Row equilibration, i.e., A has been premultiplied by\n*                  diag(R).\n*          = 'C':  Column equilibration, i.e., A has been postmultiplied\n*                  by diag(C).\n*          = 'B':  Both row and column equilibration, i.e., A has been\n*                  replaced by diag(R) * A * diag(C).\n*          EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*          output argument.\n*\n*  R       (input or output) DOUBLE PRECISION array, dimension (N)\n*          The row scale factors for A.  If EQUED = 'R' or 'B', A is\n*          multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n*          is not accessed.  R is an input argument if FACT = 'F';\n*          otherwise, R is an output argument.  If FACT = 'F' and\n*          EQUED = 'R' or 'B', each element of R must be positive.\n*\n*  C       (input or output) DOUBLE PRECISION array, dimension (N)\n*          The column scale factors for A.  If EQUED = 'C' or 'B', A is\n*          multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n*          is not accessed.  C is an input argument if FACT = 'F';\n*          otherwise, C is an output argument.  If FACT = 'F' and\n*          EQUED = 'C' or 'B', each element of C must be positive.\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit,\n*          if EQUED = 'N', B is not modified;\n*          if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n*          diag(R)*B;\n*          if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n*          overwritten by diag(C)*B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) COMPLEX*16 array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n*          to the original system of equations.  Note that A and B are\n*          modified on exit if EQUED .ne. 'N', and the solution to the\n*          equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n*          EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n*          and EQUED = 'R' or 'B'.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The estimate of the reciprocal condition number of the matrix\n*          A after equilibration (if done).  If RCOND is less than the\n*          machine precision (in particular, if RCOND = 0), the matrix\n*          is singular to working precision.  This condition is\n*          indicated by a return code of INFO > 0.\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace/output) DOUBLE PRECISION array, dimension (2*N)\n*          On exit, RWORK(1) contains the reciprocal pivot growth\n*          factor norm(A)/norm(U). The \"max absolute element\" norm is\n*          used. If RWORK(1) is much less than 1, then the stability\n*          of the LU factorization of the (equilibrated) matrix A\n*          could be poor. This also means that the solution X, condition\n*          estimator RCOND, and forward error bound FERR could be\n*          unreliable. If factorization fails with 0 0:  if INFO = i, and i is\n*                <= N:  U(i,i) is exactly zero.  The factorization has\n*                       been completed, but the factor U is exactly\n*                       singular, so the solution and error bounds\n*                       could not be computed. RCOND = 0 is returned.\n*                = N+1: U is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, rwork, info, a, af, ipiv, equed, r, c, b = NumRu::Lapack.zgesvx( fact, trans, a, b, [:af => af, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_fact = argv[0];
  rblapack_trans = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  if (argc == 9) {
    rblapack_af = argv[4];
    rblapack_ipiv = argv[5];
    rblapack_equed = argv[6];
    rblapack_r = argv[7];
    rblapack_c = argv[8];
  } else if (rblapack_options != Qnil) {
    rblapack_af = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("af")));
    rblapack_ipiv = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("ipiv")));
    rblapack_equed = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("equed")));
    rblapack_r = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("r")));
    rblapack_c = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("c")));
  } else {
    rblapack_af = Qnil;
    rblapack_ipiv = Qnil;
    rblapack_equed = Qnil;
    rblapack_r = Qnil;
    rblapack_c = Qnil;
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (rblapack_ipiv != Qnil) {
    if (!NA_IsNArray(rblapack_ipiv))
      rb_raise(rb_eArgError, "ipiv (option) must be NArray");
    if (NA_RANK(rblapack_ipiv) != 1)
      rb_raise(rb_eArgError, "rank of ipiv (option) must be %d", 1);
    if (NA_SHAPE0(rblapack_ipiv) != n)
      rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
    if (NA_TYPE(rblapack_ipiv) != NA_LINT)
      rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
    ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  }
  if (rblapack_r != Qnil) {
    if (!NA_IsNArray(rblapack_r))
      rb_raise(rb_eArgError, "r (option) must be NArray");
    if (NA_RANK(rblapack_r) != 1)
      rb_raise(rb_eArgError, "rank of r (option) must be %d", 1);
    if (NA_SHAPE0(rblapack_r) != n)
      rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of a");
    if (NA_TYPE(rblapack_r) != NA_DFLOAT)
      rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
    r = NA_PTR_TYPE(rblapack_r, doublereal*);
  }
  ldx = n;
  trans = StringValueCStr(rblapack_trans)[0];
  if (rblapack_equed != Qnil) {
  equed = StringValueCStr(rblapack_equed)[0];
  }
  ldaf = n;
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  if (rblapack_c != Qnil) {
    if (!NA_IsNArray(rblapack_c))
      rb_raise(rb_eArgError, "c (option) must be NArray");
    if (NA_RANK(rblapack_c) != 1)
      rb_raise(rb_eArgError, "rank of c (option) must be %d", 1);
    if (NA_SHAPE0(rblapack_c) != n)
      rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
    if (NA_TYPE(rblapack_c) != NA_DFLOAT)
      rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
    c = NA_PTR_TYPE(rblapack_c, doublereal*);
  }
  if (rblapack_af != Qnil) {
    if (!NA_IsNArray(rblapack_af))
      rb_raise(rb_eArgError, "af (option) must be NArray");
    if (NA_RANK(rblapack_af) != 2)
      rb_raise(rb_eArgError, "rank of af (option) must be %d", 2);
    if (NA_SHAPE0(rblapack_af) != ldaf)
      rb_raise(rb_eRuntimeError, "shape 0 of af must be n");
    if (NA_SHAPE1(rblapack_af) != n)
      rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
    if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
      rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
    af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  }
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 2*n;
    rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldaf;
    shape[1] = n;
    rblapack_af_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  af_out__ = NA_PTR_TYPE(rblapack_af_out__, doublecomplex*);
  if (rblapack_af != Qnil) {
    MEMCPY(af_out__, af, doublecomplex, NA_TOTAL(rblapack_af));
  }
  rblapack_af = rblapack_af_out__;
  af = af_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  if (rblapack_ipiv != Qnil) {
    MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  }
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_r_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  r_out__ = NA_PTR_TYPE(rblapack_r_out__, doublereal*);
  if (rblapack_r != Qnil) {
    MEMCPY(r_out__, r, doublereal, NA_TOTAL(rblapack_r));
  }
  rblapack_r = rblapack_r_out__;
  r = r_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  if (rblapack_c != Qnil) {
    MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  }
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(doublecomplex, (2*n));

  zgesvx_(&fact, &trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);

  free(work);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(13, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_rwork, rblapack_info, rblapack_a, rblapack_af, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b);
}

void
init_lapack_zgesvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgesvx", rblapack_zgesvx, -1);
}
ruby-lapack-1.7.2/ext/dgtrfs.c0000644000175000017500000002721012502221020016010 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgtrfs_(char* trans, integer* n, integer* nrhs, doublereal* dl, doublereal* d, doublereal* du, doublereal* dlf, doublereal* df, doublereal* duf, doublereal* du2, integer* ipiv, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dgtrfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_dl;
  doublereal *dl; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_du;
  doublereal *du; 
  VALUE rblapack_dlf;
  doublereal *dlf; 
  VALUE rblapack_df;
  doublereal *df; 
  VALUE rblapack_duf;
  doublereal *duf; 
  VALUE rblapack_du2;
  doublereal *du2; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  doublereal *x_out__;
  doublereal *work;
  integer *iwork;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.dgtrfs( trans, dl, d, du, dlf, df, duf, du2, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGTRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is tridiagonal, and provides\n*  error bounds and backward error estimates for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  DL      (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (n-1) subdiagonal elements of A.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          The diagonal elements of A.\n*\n*  DU      (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (n-1) superdiagonal elements of A.\n*\n*  DLF     (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (n-1) multipliers that define the matrix L from the\n*          LU factorization of A as computed by DGTTRF.\n*\n*  DF      (input) DOUBLE PRECISION array, dimension (N)\n*          The n diagonal elements of the upper triangular matrix U from\n*          the LU factorization of A.\n*\n*  DUF     (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (n-1) elements of the first superdiagonal of U.\n*\n*  DU2     (input) DOUBLE PRECISION array, dimension (N-2)\n*          The (n-2) elements of the second superdiagonal of U.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices; for 1 <= i <= n, row i of the matrix was\n*          interchanged with row IPIV(i).  IPIV(i) will always be either\n*          i or i+1; IPIV(i) = i indicates a row interchange was not\n*          required.\n*\n*  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by DGTTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.dgtrfs( trans, dl, d, du, dlf, df, duf, du2, ipiv, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 11 && argc != 11)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
  rblapack_trans = argv[0];
  rblapack_dl = argv[1];
  rblapack_d = argv[2];
  rblapack_du = argv[3];
  rblapack_dlf = argv[4];
  rblapack_df = argv[5];
  rblapack_duf = argv[6];
  rblapack_du2 = argv[7];
  rblapack_ipiv = argv[8];
  rblapack_b = argv[9];
  rblapack_x = argv[10];
  if (argc == 11) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_df))
    rb_raise(rb_eArgError, "df (6th argument) must be NArray");
  if (NA_RANK(rblapack_df) != 1)
    rb_raise(rb_eArgError, "rank of df (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_df) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of df must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_df) != NA_DFLOAT)
    rblapack_df = na_change_type(rblapack_df, NA_DFLOAT);
  df = NA_PTR_TYPE(rblapack_df, doublereal*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (9th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (11th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (11th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_DFLOAT)
    rblapack_dl = na_change_type(rblapack_dl, NA_DFLOAT);
  dl = NA_PTR_TYPE(rblapack_dl, doublereal*);
  if (!NA_IsNArray(rblapack_dlf))
    rb_raise(rb_eArgError, "dlf (5th argument) must be NArray");
  if (NA_RANK(rblapack_dlf) != 1)
    rb_raise(rb_eArgError, "rank of dlf (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dlf) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dlf must be %d", n-1);
  if (NA_TYPE(rblapack_dlf) != NA_DFLOAT)
    rblapack_dlf = na_change_type(rblapack_dlf, NA_DFLOAT);
  dlf = NA_PTR_TYPE(rblapack_dlf, doublereal*);
  if (!NA_IsNArray(rblapack_du2))
    rb_raise(rb_eArgError, "du2 (8th argument) must be NArray");
  if (NA_RANK(rblapack_du2) != 1)
    rb_raise(rb_eArgError, "rank of du2 (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du2) != (n-2))
    rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
  if (NA_TYPE(rblapack_du2) != NA_DFLOAT)
    rblapack_du2 = na_change_type(rblapack_du2, NA_DFLOAT);
  du2 = NA_PTR_TYPE(rblapack_du2, doublereal*);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (4th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_DFLOAT)
    rblapack_du = na_change_type(rblapack_du, NA_DFLOAT);
  du = NA_PTR_TYPE(rblapack_du, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (10th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (10th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  if (!NA_IsNArray(rblapack_duf))
    rb_raise(rb_eArgError, "duf (7th argument) must be NArray");
  if (NA_RANK(rblapack_duf) != 1)
    rb_raise(rb_eArgError, "rank of duf (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_duf) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of duf must be %d", n-1);
  if (NA_TYPE(rblapack_duf) != NA_DFLOAT)
    rblapack_duf = na_change_type(rblapack_duf, NA_DFLOAT);
  duf = NA_PTR_TYPE(rblapack_duf, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(doublereal, (3*n));
  iwork = ALLOC_N(integer, (n));

  dgtrfs_(&trans, &n, &nrhs, dl, d, du, dlf, df, duf, du2, ipiv, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_dgtrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgtrfs", rblapack_dgtrfs, -1);
}
ruby-lapack-1.7.2/ext/slartv.c0000644000175000017500000001310112502221013016026 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slartv_(integer* n, real* x, integer* incx, real* y, integer* incy, real* c, real* s, integer* incc);


static VALUE
rblapack_slartv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_y;
  real *y; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_incc;
  integer incc; 
  VALUE rblapack_x_out__;
  real *x_out__;
  VALUE rblapack_y_out__;
  real *y_out__;


  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  x, y = NumRu::Lapack.slartv( n, x, incx, y, incy, c, s, incc, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLARTV( N, X, INCX, Y, INCY, C, S, INCC )\n\n*  Purpose\n*  =======\n*\n*  SLARTV applies a vector of real plane rotations to elements of the\n*  real vectors x and y. For i = 1,2,...,n\n*\n*     ( x(i) ) := (  c(i)  s(i) ) ( x(i) )\n*     ( y(i) )    ( -s(i)  c(i) ) ( y(i) )\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of plane rotations to be applied.\n*\n*  X       (input/output) REAL array,\n*                         dimension (1+(N-1)*INCX)\n*          The vector x.\n*\n*  INCX    (input) INTEGER\n*          The increment between elements of X. INCX > 0.\n*\n*  Y       (input/output) REAL array,\n*                         dimension (1+(N-1)*INCY)\n*          The vector y.\n*\n*  INCY    (input) INTEGER\n*          The increment between elements of Y. INCY > 0.\n*\n*  C       (input) REAL array, dimension (1+(N-1)*INCC)\n*          The cosines of the plane rotations.\n*\n*  S       (input) REAL array, dimension (1+(N-1)*INCC)\n*          The sines of the plane rotations.\n*\n*  INCC    (input) INTEGER\n*          The increment between elements of C and S. INCC > 0.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, IC, IX, IY\n      REAL               XI, YI\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, y = NumRu::Lapack.slartv( n, x, incx, y, incy, c, s, incc, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_n = argv[0];
  rblapack_x = argv[1];
  rblapack_incx = argv[2];
  rblapack_y = argv[3];
  rblapack_incy = argv[4];
  rblapack_c = argv[5];
  rblapack_s = argv[6];
  rblapack_incc = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  incx = NUM2INT(rblapack_incx);
  incy = NUM2INT(rblapack_incy);
  incc = NUM2INT(rblapack_incc);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1+(n-1)*incx))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != (1+(n-1)*incc))
    rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", 1+(n-1)*incc);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (4th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incy))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
  if (NA_TYPE(rblapack_y) != NA_SFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
  y = NA_PTR_TYPE(rblapack_y, real*);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (7th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != (1+(n-1)*incc))
    rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", 1+(n-1)*incc);
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incx;
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incy;
    rblapack_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
  MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  slartv_(&n, x, &incx, y, &incy, c, s, &incc);

  return rb_ary_new3(2, rblapack_x, rblapack_y);
}

void
init_lapack_slartv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slartv", rblapack_slartv, -1);
}
ruby-lapack-1.7.2/ext/zla_gerfsx_extended.c0000644000175000017500000005645512502221013020562 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zla_gerfsx_extended_(integer* prec_type, integer* trans_type, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, logical* colequ, doublereal* c, doublecomplex* b, integer* ldb, doublecomplex* y, integer* ldy, doublereal* berr_out, integer* n_norms, doublereal* errs_n, doublereal* errs_c, doublecomplex* res, doublereal* ayb, doublecomplex* dy, doublecomplex* y_tail, doublereal* rcond, integer* ithresh, doublereal* rthresh, doublereal* dz_ub, logical* ignore_cwise, integer* info);


static VALUE
rblapack_zla_gerfsx_extended(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_prec_type;
  integer prec_type; 
  VALUE rblapack_trans_type;
  integer trans_type; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_colequ;
  logical colequ; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_y;
  doublecomplex *y; 
  VALUE rblapack_errs_n;
  doublereal *errs_n; 
  VALUE rblapack_errs_c;
  doublereal *errs_c; 
  VALUE rblapack_res;
  doublecomplex *res; 
  VALUE rblapack_ayb;
  doublereal *ayb; 
  VALUE rblapack_dy;
  doublecomplex *dy; 
  VALUE rblapack_y_tail;
  doublecomplex *y_tail; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_ithresh;
  integer ithresh; 
  VALUE rblapack_rthresh;
  doublereal rthresh; 
  VALUE rblapack_dz_ub;
  doublereal dz_ub; 
  VALUE rblapack_ignore_cwise;
  logical ignore_cwise; 
  VALUE rblapack_berr_out;
  doublereal *berr_out; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_y_out__;
  doublecomplex *y_out__;
  VALUE rblapack_errs_n_out__;
  doublereal *errs_n_out__;
  VALUE rblapack_errs_c_out__;
  doublereal *errs_c_out__;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldy;
  integer n_norms;

  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  berr_out, info, y, errs_n, errs_c = NumRu::Lapack.zla_gerfsx_extended( prec_type, trans_type, a, af, ipiv, colequ, c, b, y, errs_n, errs_c, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERRS_N, ERRS_C, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZLA_GERFSX_EXTENDED improves the computed solution to a system of\n*  linear equations by performing extra-precise iterative refinement\n*  and provides error bounds and backward error estimates for the solution.\n*  This subroutine is called by ZGERFSX to perform iterative refinement.\n*  In addition to normwise error bound, the code provides maximum\n*  componentwise error bound if possible. See comments for ERR_BNDS_NORM\n*  and ERR_BNDS_COMP for details of the error bounds. Note that this\n*  subroutine is only resonsible for setting the second fields of\n*  ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n*  Arguments\n*  =========\n*\n*     PREC_TYPE      (input) INTEGER\n*     Specifies the intermediate precision to be used in refinement.\n*     The value is defined by ILAPREC(P) where P is a CHARACTER and\n*     P    = 'S':  Single\n*          = 'D':  Double\n*          = 'I':  Indigenous\n*          = 'X', 'E':  Extra\n*\n*     TRANS_TYPE     (input) INTEGER\n*     Specifies the transposition operation on A.\n*     The value is defined by ILATRANS(T) where T is a CHARACTER and\n*     T    = 'N':  No transpose\n*          = 'T':  Transpose\n*          = 'C':  Conjugate transpose\n*\n*     N              (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NRHS           (input) INTEGER\n*     The number of right-hand-sides, i.e., the number of columns of the\n*     matrix B.\n*\n*     A              (input) COMPLEX*16 array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA            (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF             (input) COMPLEX*16 array, dimension (LDAF,N)\n*     The factors L and U from the factorization\n*     A = P*L*U as computed by ZGETRF.\n*\n*     LDAF           (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV           (input) INTEGER array, dimension (N)\n*     The pivot indices from the factorization A = P*L*U\n*     as computed by ZGETRF; row i of the matrix was interchanged\n*     with row IPIV(i).\n*\n*     COLEQU         (input) LOGICAL\n*     If .TRUE. then column equilibration was done to A before calling\n*     this routine. This is needed to compute the solution and error\n*     bounds correctly.\n*\n*     C              (input) DOUBLE PRECISION array, dimension (N)\n*     The column scale factors for A. If COLEQU = .FALSE., C\n*     is not accessed. If C is input, each element of C should be a power\n*     of the radix to ensure a reliable solution and error estimates.\n*     Scaling by powers of the radix does not cause rounding errors unless\n*     the result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B              (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*     The right-hand-side matrix B.\n*\n*     LDB            (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     Y              (input/output) COMPLEX*16 array, dimension (LDY,NRHS)\n*     On entry, the solution matrix X, as computed by ZGETRS.\n*     On exit, the improved solution matrix Y.\n*\n*     LDY            (input) INTEGER\n*     The leading dimension of the array Y.  LDY >= max(1,N).\n*\n*     BERR_OUT       (output) DOUBLE PRECISION array, dimension (NRHS)\n*     On exit, BERR_OUT(j) contains the componentwise relative backward\n*     error for right-hand-side j from the formula\n*         max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n*     where abs(Z) is the componentwise absolute value of the matrix\n*     or vector Z. This is computed by ZLA_LIN_BERR.\n*\n*     N_NORMS        (input) INTEGER\n*     Determines which error bounds to return (see ERR_BNDS_NORM\n*     and ERR_BNDS_COMP).\n*     If N_NORMS >= 1 return normwise error bounds.\n*     If N_NORMS >= 2 return componentwise error bounds.\n*\n*     ERR_BNDS_NORM  (input/output) DOUBLE PRECISION array, dimension\n*                    (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (input/output) DOUBLE PRECISION array, dimension\n*                    (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     RES            (input) COMPLEX*16 array, dimension (N)\n*     Workspace to hold the intermediate residual.\n*\n*     AYB            (input) DOUBLE PRECISION array, dimension (N)\n*     Workspace.\n*\n*     DY             (input) COMPLEX*16 array, dimension (N)\n*     Workspace to hold the intermediate solution.\n*\n*     Y_TAIL         (input) COMPLEX*16 array, dimension (N)\n*     Workspace to hold the trailing bits of the intermediate solution.\n*\n*     RCOND          (input) DOUBLE PRECISION\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     ITHRESH        (input) INTEGER\n*     The maximum number of residual computations allowed for\n*     refinement. The default is 10. For 'aggressive' set to 100 to\n*     permit convergence using approximate factorizations or\n*     factorizations other than LU. If the factorization uses a\n*     technique other than Gaussian elimination, the guarantees in\n*     ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n*     RTHRESH        (input) DOUBLE PRECISION\n*     Determines when to stop refinement if the error estimate stops\n*     decreasing. Refinement will stop when the next solution no longer\n*     satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n*     the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n*     default value is 0.5. For 'aggressive' set to 0.9 to permit\n*     convergence on extremely ill-conditioned matrices. See LAWN 165\n*     for more details.\n*\n*     DZ_UB          (input) DOUBLE PRECISION\n*     Determines when to start considering componentwise convergence.\n*     Componentwise convergence is only considered after each component\n*     of the solution Y is stable, which we definte as the relative\n*     change in each component being less than DZ_UB. The default value\n*     is 0.25, requiring the first bit to be stable. See LAWN 165 for\n*     more details.\n*\n*     IGNORE_CWISE   (input) LOGICAL\n*     If .TRUE. then ignore componentwise convergence. Default value\n*     is .FALSE..\n*\n*     INFO           (output) INTEGER\n*       = 0:  Successful exit.\n*       < 0:  if INFO = -i, the ith argument to ZGETRS had an illegal\n*             value\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      CHARACTER          TRANS\n      INTEGER            CNT, I, J,  X_STATE, Z_STATE, Y_PREC_STATE\n      DOUBLE PRECISION   YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n     $                   DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n     $                   DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n     $                   EPS, HUGEVAL, INCR_THRESH\n      LOGICAL            INCR_PREC\n      COMPLEX*16         ZDUM\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  berr_out, info, y, errs_n, errs_c = NumRu::Lapack.zla_gerfsx_extended( prec_type, trans_type, a, af, ipiv, colequ, c, b, y, errs_n, errs_c, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 20 && argc != 20)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 20)", argc);
  rblapack_prec_type = argv[0];
  rblapack_trans_type = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_colequ = argv[5];
  rblapack_c = argv[6];
  rblapack_b = argv[7];
  rblapack_y = argv[8];
  rblapack_errs_n = argv[9];
  rblapack_errs_c = argv[10];
  rblapack_res = argv[11];
  rblapack_ayb = argv[12];
  rblapack_dy = argv[13];
  rblapack_y_tail = argv[14];
  rblapack_rcond = argv[15];
  rblapack_ithresh = argv[16];
  rblapack_rthresh = argv[17];
  rblapack_dz_ub = argv[18];
  rblapack_ignore_cwise = argv[19];
  if (argc == 20) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  prec_type = NUM2INT(rblapack_prec_type);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (9th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 2)
    rb_raise(rb_eArgError, "rank of y (9th argument) must be %d", 2);
  ldy = NA_SHAPE0(rblapack_y);
  nrhs = NA_SHAPE1(rblapack_y);
  if (NA_TYPE(rblapack_y) != NA_DCOMPLEX)
    rblapack_y = na_change_type(rblapack_y, NA_DCOMPLEX);
  y = NA_PTR_TYPE(rblapack_y, doublecomplex*);
  if (!NA_IsNArray(rblapack_res))
    rb_raise(rb_eArgError, "res (12th argument) must be NArray");
  if (NA_RANK(rblapack_res) != 1)
    rb_raise(rb_eArgError, "rank of res (12th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_res) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_res) != NA_DCOMPLEX)
    rblapack_res = na_change_type(rblapack_res, NA_DCOMPLEX);
  res = NA_PTR_TYPE(rblapack_res, doublecomplex*);
  if (!NA_IsNArray(rblapack_dy))
    rb_raise(rb_eArgError, "dy (14th argument) must be NArray");
  if (NA_RANK(rblapack_dy) != 1)
    rb_raise(rb_eArgError, "rank of dy (14th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dy) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_dy) != NA_DCOMPLEX)
    rblapack_dy = na_change_type(rblapack_dy, NA_DCOMPLEX);
  dy = NA_PTR_TYPE(rblapack_dy, doublecomplex*);
  rcond = NUM2DBL(rblapack_rcond);
  rthresh = NUM2DBL(rblapack_rthresh);
  ignore_cwise = (rblapack_ignore_cwise == Qtrue);
  trans_type = NUM2INT(rblapack_trans_type);
  colequ = (rblapack_colequ == Qtrue);
  if (!NA_IsNArray(rblapack_ayb))
    rb_raise(rb_eArgError, "ayb (13th argument) must be NArray");
  if (NA_RANK(rblapack_ayb) != 1)
    rb_raise(rb_eArgError, "rank of ayb (13th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ayb) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ayb) != NA_DFLOAT)
    rblapack_ayb = na_change_type(rblapack_ayb, NA_DFLOAT);
  ayb = NA_PTR_TYPE(rblapack_ayb, doublereal*);
  ithresh = NUM2INT(rblapack_ithresh);
  n_norms = 3;
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  if (!NA_IsNArray(rblapack_errs_n))
    rb_raise(rb_eArgError, "errs_n (10th argument) must be NArray");
  if (NA_RANK(rblapack_errs_n) != 2)
    rb_raise(rb_eArgError, "rank of errs_n (10th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_errs_n) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of errs_n must be the same as shape 1 of y");
  if (NA_SHAPE1(rblapack_errs_n) != n_norms)
    rb_raise(rb_eRuntimeError, "shape 1 of errs_n must be 3");
  if (NA_TYPE(rblapack_errs_n) != NA_DFLOAT)
    rblapack_errs_n = na_change_type(rblapack_errs_n, NA_DFLOAT);
  errs_n = NA_PTR_TYPE(rblapack_errs_n, doublereal*);
  if (!NA_IsNArray(rblapack_y_tail))
    rb_raise(rb_eArgError, "y_tail (15th argument) must be NArray");
  if (NA_RANK(rblapack_y_tail) != 1)
    rb_raise(rb_eArgError, "rank of y_tail (15th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y_tail) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_y_tail) != NA_DCOMPLEX)
    rblapack_y_tail = na_change_type(rblapack_y_tail, NA_DCOMPLEX);
  y_tail = NA_PTR_TYPE(rblapack_y_tail, doublecomplex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of y");
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  dz_ub = NUM2DBL(rblapack_dz_ub);
  if (!NA_IsNArray(rblapack_errs_c))
    rb_raise(rb_eArgError, "errs_c (11th argument) must be NArray");
  if (NA_RANK(rblapack_errs_c) != 2)
    rb_raise(rb_eArgError, "rank of errs_c (11th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_errs_c) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of errs_c must be the same as shape 1 of y");
  if (NA_SHAPE1(rblapack_errs_c) != n_norms)
    rb_raise(rb_eRuntimeError, "shape 1 of errs_c must be 3");
  if (NA_TYPE(rblapack_errs_c) != NA_DFLOAT)
    rblapack_errs_c = na_change_type(rblapack_errs_c, NA_DFLOAT);
  errs_c = NA_PTR_TYPE(rblapack_errs_c, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr_out = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr_out = NA_PTR_TYPE(rblapack_berr_out, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldy;
    shape[1] = nrhs;
    rblapack_y_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublecomplex*);
  MEMCPY(y_out__, y, doublecomplex, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_norms;
    rblapack_errs_n_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  errs_n_out__ = NA_PTR_TYPE(rblapack_errs_n_out__, doublereal*);
  MEMCPY(errs_n_out__, errs_n, doublereal, NA_TOTAL(rblapack_errs_n));
  rblapack_errs_n = rblapack_errs_n_out__;
  errs_n = errs_n_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_norms;
    rblapack_errs_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  errs_c_out__ = NA_PTR_TYPE(rblapack_errs_c_out__, doublereal*);
  MEMCPY(errs_c_out__, errs_c, doublereal, NA_TOTAL(rblapack_errs_c));
  rblapack_errs_c = rblapack_errs_c_out__;
  errs_c = errs_c_out__;

  zla_gerfsx_extended_(&prec_type, &trans_type, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, errs_n, errs_c, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_errs_n, rblapack_errs_c);
}

void
init_lapack_zla_gerfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zla_gerfsx_extended", rblapack_zla_gerfsx_extended, -1);
}
ruby-lapack-1.7.2/ext/csycon.c0000644000175000017500000001111712502221014016017 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID csycon_(char* uplo, integer* n, complex* a, integer* lda, integer* ipiv, real* anorm, real* rcond, complex* work, integer* info);


static VALUE
rblapack_csycon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_anorm;
  real anorm; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_info;
  integer info; 
  complex *work;

  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  rcond, info = NumRu::Lapack.csycon( uplo, a, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CSYCON estimates the reciprocal of the condition number (in the\n*  1-norm) of a complex symmetric matrix A using the factorization\n*  A = U*D*U**T or A = L*D*L**T computed by CSYTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by CSYTRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by CSYTRF.\n*\n*  ANORM   (input) REAL\n*          The 1-norm of the original matrix A.\n*\n*  RCOND   (output) REAL\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n*          estimate of the 1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.csycon( uplo, a, ipiv, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_anorm = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  anorm = (real)NUM2DBL(rblapack_anorm);
  work = ALLOC_N(complex, (2*n));

  csycon_(&uplo, &n, a, &lda, ipiv, &anorm, &rcond, work, &info);

  free(work);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_csycon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "csycon", rblapack_csycon, -1);
}
ruby-lapack-1.7.2/ext/sgeequb.c0000644000175000017500000001247612502221021016163 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgeequb_(integer* m, integer* n, real* a, integer* lda, real* r, real* c, real* rowcnd, real* colcnd, real* amax, integer* info);


static VALUE
rblapack_sgeequb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_r;
  real *r; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_rowcnd;
  real rowcnd; 
  VALUE rblapack_colcnd;
  real colcnd; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_info;
  integer info; 

  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  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.sgeequb( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGEEQUB computes row and column scalings intended to equilibrate an\n*  M-by-N matrix A and reduce its condition number.  R returns the row\n*  scale factors and C the column scale factors, chosen to try to make\n*  the largest element in each row and column of the matrix B with\n*  elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n*  the radix.\n*\n*  R(i) and C(j) are restricted to be a power of the radix between\n*  SMLNUM = smallest safe number and BIGNUM = largest safe number.  Use\n*  of these scaling factors is not guaranteed to reduce the condition\n*  number of A but works well in practice.\n*\n*  This routine differs from SGEEQU by restricting the scaling factors\n*  to a power of the radix.  Baring over- and underflow, scaling by\n*  these factors introduces no additional rounding errors.  However, the\n*  scaled entries' magnitured are no longer approximately 1 but lie\n*  between sqrt(radix) and 1/sqrt(radix).\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) REAL array, dimension (LDA,N)\n*          The M-by-N matrix whose equilibration factors are\n*          to be computed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  R       (output) REAL array, dimension (M)\n*          If INFO = 0 or INFO > M, R contains the row scale factors\n*          for A.\n*\n*  C       (output) REAL array, dimension (N)\n*          If INFO = 0,  C contains the column scale factors for A.\n*\n*  ROWCND  (output) REAL\n*          If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n*          smallest R(i) to the largest R(i).  If ROWCND >= 0.1 and\n*          AMAX is neither too large nor too small, it is not worth\n*          scaling by R.\n*\n*  COLCND  (output) REAL\n*          If INFO = 0, COLCND contains the ratio of the smallest\n*          C(i) to the largest C(i).  If COLCND >= 0.1, it is not\n*          worth scaling by C.\n*\n*  AMAX    (output) REAL\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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,  and i is\n*                <= M:  the i-th row of A is exactly zero\n*                >  M:  the (i-M)-th column of A is exactly zero\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.sgeequb( 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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  m = lda;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_r = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  r = NA_PTR_TYPE(rblapack_r, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  c = NA_PTR_TYPE(rblapack_c, real*);

  sgeequb_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &info);

  rblapack_rowcnd = rb_float_new((double)rowcnd);
  rblapack_colcnd = rb_float_new((double)colcnd);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
}

void
init_lapack_sgeequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgeequb", rblapack_sgeequb, -1);
}
ruby-lapack-1.7.2/ext/slasq2.c0000644000175000017500000001072512502221015015733 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slasq2_(integer* n, real* z, integer* info);


static VALUE
rblapack_slasq2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_z_out__;
  real *z_out__;


  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  info, z = NumRu::Lapack.slasq2( n, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASQ2( N, Z, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLASQ2 computes all the eigenvalues of the symmetric positive \n*  definite tridiagonal matrix associated with the qd array Z to high\n*  relative accuracy are computed to high relative accuracy, in the\n*  absence of denormalization, underflow and overflow.\n*\n*  To see the relation of Z to the tridiagonal matrix, let L be a\n*  unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and\n*  let U be an upper bidiagonal matrix with 1's above and diagonal\n*  Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the\n*  symmetric tridiagonal to which it is similar.\n*\n*  Note : SLASQ2 defines a logical variable, IEEE, which is true\n*  on machines which follow ieee-754 floating-point standard in their\n*  handling of infinities and NaNs, and false otherwise. This variable\n*  is passed to SLASQ3.\n*\n\n*  Arguments\n*  =========\n*\n*  N     (input) INTEGER\n*        The number of rows and columns in the matrix. N >= 0.\n*\n*  Z     (input/output) REAL array, dimension ( 4*N )\n*        On entry Z holds the qd array. On exit, entries 1 to N hold\n*        the eigenvalues in decreasing order, Z( 2*N+1 ) holds the\n*        trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If\n*        N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 )\n*        holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of\n*        shifts that failed.\n*\n*  INFO  (output) INTEGER\n*        = 0: successful exit\n*        < 0: if the i-th argument is a scalar and had an illegal\n*             value, then INFO = -i, if the i-th argument is an\n*             array and the j-entry had an illegal value, then\n*             INFO = -(i*100+j)\n*        > 0: the algorithm failed\n*              = 1, a split was marked by a positive value in E\n*              = 2, current block of Z not diagonalized after 30*N\n*                   iterations (in inner while loop)\n*              = 3, termination criterion of outer while loop not met \n*                   (program created more than N unreduced blocks)\n*\n\n*  Further Details\n*  ===============\n*  Local Variables: I0:N0 defines a current unreduced segment of Z.\n*  The shifts are accumulated in SIGMA. Iteration count is in ITER.\n*  Ping-pong is controlled by PP (alternates between 0 and 1).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, z = NumRu::Lapack.slasq2( n, z, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_n = argv[0];
  rblapack_z = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (2th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != (4*n))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 4*n);
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[1];
    shape[0] = 4*n;
    rblapack_z_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
  MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  slasq2_(&n, z, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_z);
}

void
init_lapack_slasq2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slasq2", rblapack_slasq2, -1);
}
ruby-lapack-1.7.2/ext/clar2v.c0000644000175000017500000001552112502221020015712 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clar2v_(integer* n, complex* x, complex* y, complex* z, integer* incx, real* c, complex* s, integer* incc);


static VALUE
rblapack_clar2v(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_y;
  complex *y; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_s;
  complex *s; 
  VALUE rblapack_incc;
  integer incc; 
  VALUE rblapack_x_out__;
  complex *x_out__;
  VALUE rblapack_y_out__;
  complex *y_out__;
  VALUE rblapack_z_out__;
  complex *z_out__;


  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  x, y, z = NumRu::Lapack.clar2v( n, x, y, z, incx, c, s, incc, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAR2V( N, X, Y, Z, INCX, C, S, INCC )\n\n*  Purpose\n*  =======\n*\n*  CLAR2V applies a vector of complex plane rotations with real cosines\n*  from both sides to a sequence of 2-by-2 complex Hermitian matrices,\n*  defined by the elements of the vectors x, y and z. For i = 1,2,...,n\n*\n*     (       x(i)  z(i) ) :=\n*     ( conjg(z(i)) y(i) )\n*\n*       (  c(i) conjg(s(i)) ) (       x(i)  z(i) ) ( c(i) -conjg(s(i)) )\n*       ( -s(i)       c(i)  ) ( conjg(z(i)) y(i) ) ( s(i)        c(i)  )\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of plane rotations to be applied.\n*\n*  X       (input/output) COMPLEX array, dimension (1+(N-1)*INCX)\n*          The vector x; the elements of x are assumed to be real.\n*\n*  Y       (input/output) COMPLEX array, dimension (1+(N-1)*INCX)\n*          The vector y; the elements of y are assumed to be real.\n*\n*  Z       (input/output) COMPLEX array, dimension (1+(N-1)*INCX)\n*          The vector z.\n*\n*  INCX    (input) INTEGER\n*          The increment between elements of X, Y and Z. INCX > 0.\n*\n*  C       (input) REAL array, dimension (1+(N-1)*INCC)\n*          The cosines of the plane rotations.\n*\n*  S       (input) COMPLEX array, dimension (1+(N-1)*INCC)\n*          The sines of the plane rotations.\n*\n*  INCC    (input) INTEGER\n*          The increment between elements of C and S. INCC > 0.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, IC, IX\n      REAL               CI, SII, SIR, T1I, T1R, T5, T6, XI, YI, ZII,\n     $                   ZIR\n      COMPLEX            SI, T2, T3, T4, ZI\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          AIMAG, CMPLX, CONJG, REAL\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, y, z = NumRu::Lapack.clar2v( n, x, y, z, incx, c, s, incc, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_n = argv[0];
  rblapack_x = argv[1];
  rblapack_y = argv[2];
  rblapack_z = argv[3];
  rblapack_incx = argv[4];
  rblapack_c = argv[5];
  rblapack_s = argv[6];
  rblapack_incc = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  incx = NUM2INT(rblapack_incx);
  incc = NUM2INT(rblapack_incc);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1+(n-1)*incx))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (4th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != (1+(n-1)*incx))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 1+(n-1)*incx);
  if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, complex*);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (7th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != (1+(n-1)*incc))
    rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", 1+(n-1)*incc);
  if (NA_TYPE(rblapack_s) != NA_SCOMPLEX)
    rblapack_s = na_change_type(rblapack_s, NA_SCOMPLEX);
  s = NA_PTR_TYPE(rblapack_s, complex*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (3th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incx))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incx);
  if (NA_TYPE(rblapack_y) != NA_SCOMPLEX)
    rblapack_y = na_change_type(rblapack_y, NA_SCOMPLEX);
  y = NA_PTR_TYPE(rblapack_y, complex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != (1+(n-1)*incc))
    rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", 1+(n-1)*incc);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incx;
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incx;
    rblapack_y_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, complex*);
  MEMCPY(y_out__, y, complex, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incx;
    rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
  MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  clar2v_(&n, x, y, z, &incx, c, s, &incc);

  return rb_ary_new3(3, rblapack_x, rblapack_y, rblapack_z);
}

void
init_lapack_clar2v(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clar2v", rblapack_clar2v, -1);
}
ruby-lapack-1.7.2/ext/slaev2.c0000644000175000017500000000712212502221021015714 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaev2_(real* a, real* b, real* c, real* rt1, real* rt2, real* cs1, real* sn1);


static VALUE
rblapack_slaev2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  real a; 
  VALUE rblapack_b;
  real b; 
  VALUE rblapack_c;
  real c; 
  VALUE rblapack_rt1;
  real rt1; 
  VALUE rblapack_rt2;
  real rt2; 
  VALUE rblapack_cs1;
  real cs1; 
  VALUE rblapack_sn1;
  real sn1; 


  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  rt1, rt2, cs1, sn1 = NumRu::Lapack.slaev2( a, b, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAEV2( A, B, C, RT1, RT2, CS1, SN1 )\n\n*  Purpose\n*  =======\n*\n*  SLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix\n*     [  A   B  ]\n*     [  B   C  ].\n*  On return, RT1 is the eigenvalue of larger absolute value, RT2 is the\n*  eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right\n*  eigenvector for RT1, giving the decomposition\n*\n*     [ CS1  SN1 ] [  A   B  ] [ CS1 -SN1 ]  =  [ RT1  0  ]\n*     [-SN1  CS1 ] [  B   C  ] [ SN1  CS1 ]     [  0  RT2 ].\n*\n\n*  Arguments\n*  =========\n*\n*  A       (input) REAL\n*          The (1,1) element of the 2-by-2 matrix.\n*\n*  B       (input) REAL\n*          The (1,2) element and the conjugate of the (2,1) element of\n*          the 2-by-2 matrix.\n*\n*  C       (input) REAL\n*          The (2,2) element of the 2-by-2 matrix.\n*\n*  RT1     (output) REAL\n*          The eigenvalue of larger absolute value.\n*\n*  RT2     (output) REAL\n*          The eigenvalue of smaller absolute value.\n*\n*  CS1     (output) REAL\n*  SN1     (output) REAL\n*          The vector (CS1, SN1) is a unit right eigenvector for RT1.\n*\n\n*  Further Details\n*  ===============\n*\n*  RT1 is accurate to a few ulps barring over/underflow.\n*\n*  RT2 may be inaccurate if there is massive cancellation in the\n*  determinant A*C-B*B; higher precision or correctly rounded or\n*  correctly truncated arithmetic would be needed to compute RT2\n*  accurately in all cases.\n*\n*  CS1 and SN1 are accurate to a few ulps barring over/underflow.\n*\n*  Overflow is possible only if RT1 is within a factor of 5 of overflow.\n*  Underflow is harmless if the input data is 0 or exceeds\n*     underflow_threshold / macheps.\n*\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rt1, rt2, cs1, sn1 = NumRu::Lapack.slaev2( a, b, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  rblapack_c = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  a = (real)NUM2DBL(rblapack_a);
  c = (real)NUM2DBL(rblapack_c);
  b = (real)NUM2DBL(rblapack_b);

  slaev2_(&a, &b, &c, &rt1, &rt2, &cs1, &sn1);

  rblapack_rt1 = rb_float_new((double)rt1);
  rblapack_rt2 = rb_float_new((double)rt2);
  rblapack_cs1 = rb_float_new((double)cs1);
  rblapack_sn1 = rb_float_new((double)sn1);
  return rb_ary_new3(4, rblapack_rt1, rblapack_rt2, rblapack_cs1, rblapack_sn1);
}

void
init_lapack_slaev2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaev2", rblapack_slaev2, -1);
}
ruby-lapack-1.7.2/ext/zlansp.c0000644000175000017500000001063712502221023016036 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal zlansp_(char* norm, char* uplo, integer* n, doublecomplex* ap, doublereal* work);


static VALUE
rblapack_zlansp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack___out__;
  doublereal __out__; 
  doublereal *work;

  integer lwork;

  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  __out__ = NumRu::Lapack.zlansp( norm, uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION ZLANSP( NORM, UPLO, N, AP, WORK )\n\n*  Purpose\n*  =======\n*\n*  ZLANSP  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  complex symmetric matrix A,  supplied in packed form.\n*\n*  Description\n*  ===========\n*\n*  ZLANSP returns the value\n*\n*     ZLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in ZLANSP as described\n*          above.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is supplied.\n*          = 'U':  Upper triangular part of A is supplied\n*          = 'L':  Lower triangular part of A is supplied\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, ZLANSP is\n*          set to zero.\n*\n*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          The upper or lower triangle of the symmetric matrix A, packed\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n*          WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.zlansp( norm, uplo, n, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_n = argv[2];
  rblapack_ap = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  n = NUM2INT(rblapack_n);
  lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  work = ALLOC_N(doublereal, (MAX(1,lwork)));

  __out__ = zlansp_(&norm, &uplo, &n, ap, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_zlansp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlansp", rblapack_zlansp, -1);
}
ruby-lapack-1.7.2/ext/cgels.c0000644000175000017500000002113412502221014015616 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgels_(char* trans, integer* m, integer* n, integer* nrhs, complex* a, integer* lda, complex* b, integer* ldb, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_cgels(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_b_out__;
  complex *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.cgels( trans, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGELS solves overdetermined or underdetermined complex linear systems\n*  involving an M-by-N matrix A, or its conjugate-transpose, using a QR\n*  or LQ 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 = 'C' and m >= n:  find the minimum norm solution of\n*     an undetermined system A**H * X = B.\n*\n*  4. If TRANS = 'C' and m < n:  find the least squares solution of\n*     an overdetermined system, i.e., solve the least squares problem\n*                  minimize || B - A**H * 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*          = 'C': the linear system involves A**H.\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) COMPLEX array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*            if M >= N, A is overwritten by details of its QR\n*                       factorization as returned by CGEQRF;\n*            if M <  N, A is overwritten by details of its LQ\n*                       factorization as returned by CGELQF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  B       (input/output) COMPLEX 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 = 'C'.\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 the\n*          modulus of 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 = 'C' and m >= n, rows 1 to M of B contain the\n*          minimum norm solution vectors;\n*          if TRANS = 'C' 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 the modulus 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) COMPLEX 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.cgels( 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;
  }

  trans = StringValueCStr(rblapack_trans)[0];
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  m = lda;
  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_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  ldb = MAX(m,n);
  if (rblapack_lwork == Qnil)
    lwork = MIN(m,n) + MAX(MIN(m,n),nrhs);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = MAX(m, n);
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  {
    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__;

  cgels_(&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_cgels(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgels", rblapack_cgels, -1);
}
ruby-lapack-1.7.2/ext/ctfttr.c0000644000175000017500000001720212502221013016027 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctfttr_(char* transr, char* uplo, integer* n, complex* arf, complex* a, integer* lda, integer* info);


static VALUE
rblapack_ctfttr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_arf;
  complex *arf; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_info;
  integer info; 

  integer ldarf;
  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  a, info = NumRu::Lapack.ctfttr( transr, uplo, arf, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTFTTR copies a triangular matrix A from rectangular full packed\n*  format (TF) to standard full format (TR).\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR   (input) CHARACTER*1\n*          = 'N':  ARF is in Normal format;\n*          = 'C':  ARF is in Conjugate-transpose format;\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  ARF     (input) COMPLEX array, dimension ( N*(N+1)/2 ),\n*          On entry, the upper or lower triangular matrix A stored in\n*          RFP format. For a further discussion see Notes below.\n*\n*  A       (output) COMPLEX array, dimension ( LDA, N ) \n*          On exit, the triangular matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of the array A contains\n*          the upper triangular matrix, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of the array A contains\n*          the lower triangular matrix, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\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*  We first consider Standard Packed Format when N is even.\n*  We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  conjugate-transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  conjugate-transpose of the last three columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                -- -- --\n*        03 04 05                33 43 53\n*                                   -- --\n*        13 14 15                00 44 54\n*                                      --\n*        23 24 25                10 11 55\n*\n*        33 34 35                20 21 22\n*        --\n*        00 44 45                30 31 32\n*        -- --\n*        01 11 55                40 41 42\n*        -- -- --\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- -- --                -- -- -- -- -- --\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     -- -- -- -- --                -- -- -- -- --\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     -- -- -- -- -- --                -- -- -- --\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We next  consider Standard Packed Format when N is odd.\n*  We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  conjugate-transpose of the first two   columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  conjugate-transpose of the last two   columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N odd  and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                   -- --\n*        02 03 04                00 33 43\n*                                      --\n*        12 13 14                10 11 44\n*\n*        22 23 24                20 21 22\n*        --\n*        00 33 34                30 31 32\n*        -- --\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- --                   -- -- -- -- -- --\n*     02 12 22 00 01             00 10 20 30 40 50\n*     -- -- -- --                   -- -- -- -- --\n*     03 13 23 33 11             33 11 21 31 41 51\n*     -- -- -- -- --                   -- -- -- --\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  a, info = NumRu::Lapack.ctfttr( transr, uplo, arf, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_arf = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  if (!NA_IsNArray(rblapack_arf))
    rb_raise(rb_eArgError, "arf (3th argument) must be NArray");
  if (NA_RANK(rblapack_arf) != 1)
    rb_raise(rb_eArgError, "rank of arf (3th argument) must be %d", 1);
  ldarf = NA_SHAPE0(rblapack_arf);
  if (NA_TYPE(rblapack_arf) != NA_SCOMPLEX)
    rblapack_arf = na_change_type(rblapack_arf, NA_SCOMPLEX);
  arf = NA_PTR_TYPE(rblapack_arf, complex*);
  n = ((int)sqrtf(ldarf*8+1.0f)-1)/2;
  uplo = StringValueCStr(rblapack_uplo)[0];
  lda = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a = NA_PTR_TYPE(rblapack_a, complex*);

  ctfttr_(&transr, &uplo, &n, arf, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_a, rblapack_info);
}

void
init_lapack_ctfttr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctfttr", rblapack_ctfttr, -1);
}
ruby-lapack-1.7.2/ext/chpgv.c0000644000175000017500000001760012502221025015635 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chpgv_(integer* itype, char* jobz, char* uplo, integer* n, complex* ap, complex* bp, real* w, complex* z, integer* ldz, complex* work, real* rwork, integer* info);


static VALUE
rblapack_chpgv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_bp;
  complex *bp; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  complex *ap_out__;
  VALUE rblapack_bp_out__;
  complex *bp_out__;
  complex *work;
  real *rwork;

  integer ldap;
  integer n;
  integer ldz;

  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  w, z, info, ap, bp = NumRu::Lapack.chpgv( itype, jobz, uplo, ap, bp, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHPGV computes all the eigenvalues and, optionally, the eigenvectors\n*  of a complex generalized Hermitian-definite eigenproblem, of the form\n*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.\n*  Here A and B are assumed to be Hermitian, stored in packed format,\n*  and B is also positive definite.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          Specifies the problem type to be solved:\n*          = 1:  A*x = (lambda)*B*x\n*          = 2:  A*B*x = (lambda)*x\n*          = 3:  B*A*x = (lambda)*x\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, the contents of AP are destroyed.\n*\n*  BP      (input/output) COMPLEX array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          B, packed columnwise in a linear array.  The j-th column of B\n*          is stored in the array BP as follows:\n*          if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n*          if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n*          On exit, the triangular factor U or L from the Cholesky\n*          factorization B = U**H*U or B = L*L**H, in the same storage\n*          format as B.\n*\n*  W       (output) REAL array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) COMPLEX array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n*          eigenvectors.  The eigenvectors are normalized as follows:\n*          if ITYPE = 1 or 2, Z**H*B*Z = I;\n*          if ITYPE = 3, Z**H*inv(B)*Z = I.\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace) COMPLEX array, dimension (max(1, 2*N-1))\n*\n*  RWORK   (workspace) REAL array, dimension (max(1, 3*N-2))\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  CPPTRF or CHPEV returned an error code:\n*             <= N:  if INFO = i, CHPEV failed to converge;\n*                    i off-diagonal elements of an intermediate\n*                    tridiagonal form did not convergeto zero;\n*             > N:   if INFO = N + i, for 1 <= i <= n, then the leading\n*                    minor of order i of B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            UPPER, WANTZ\n      CHARACTER          TRANS\n      INTEGER            J, NEIG\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CHPEV, CHPGST, CPPTRF, CTPMV, CTPSV, XERBLA\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, info, ap, bp = NumRu::Lapack.chpgv( itype, jobz, uplo, ap, bp, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_itype = argv[0];
  rblapack_jobz = argv[1];
  rblapack_uplo = argv[2];
  rblapack_ap = argv[3];
  rblapack_bp = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  itype = NUM2INT(rblapack_itype);
  uplo = StringValueCStr(rblapack_uplo)[0];
  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  if (!NA_IsNArray(rblapack_bp))
    rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
  if (NA_RANK(rblapack_bp) != 1)
    rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_bp) != NA_SCOMPLEX)
    rblapack_bp = na_change_type(rblapack_bp, NA_SCOMPLEX);
  bp = NA_PTR_TYPE(rblapack_bp, complex*);
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, complex*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
  MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_bp_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  bp_out__ = NA_PTR_TYPE(rblapack_bp_out__, complex*);
  MEMCPY(bp_out__, bp, complex, NA_TOTAL(rblapack_bp));
  rblapack_bp = rblapack_bp_out__;
  bp = bp_out__;
  work = ALLOC_N(complex, (MAX(1, 2*n-1)));
  rwork = ALLOC_N(real, (MAX(1, 3*n-2)));

  chpgv_(&itype, &jobz, &uplo, &n, ap, bp, w, z, &ldz, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_w, rblapack_z, rblapack_info, rblapack_ap, rblapack_bp);
}

void
init_lapack_chpgv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chpgv", rblapack_chpgv, -1);
}
ruby-lapack-1.7.2/ext/stpcon.c0000644000175000017500000001053412502221013016030 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID stpcon_(char* norm, char* uplo, char* diag, integer* n, real* ap, real* rcond, real* work, integer* iwork, integer* info);


static VALUE
rblapack_stpcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_info;
  integer info; 
  real *work;
  integer *iwork;

  integer ldap;
  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  rcond, info = NumRu::Lapack.stpcon( norm, uplo, diag, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  STPCON estimates the reciprocal of the condition number of a packed\n*  triangular matrix A, in either the 1-norm or the infinity-norm.\n*\n*  The norm of A is computed and an estimate is obtained for\n*  norm(inv(A)), then the reciprocal of the condition number is\n*  computed as\n*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies whether the 1-norm condition number or the\n*          infinity-norm condition number is required:\n*          = '1' or 'O':  1-norm;\n*          = 'I':         Infinity-norm.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input) REAL array, dimension (N*(N+1)/2)\n*          The upper or lower triangular matrix A, packed columnwise in\n*          a linear array.  The j-th column of A is stored in the array\n*          AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          If DIAG = 'U', the diagonal elements of A are not referenced\n*          and are assumed to be 1.\n*\n*  RCOND   (output) REAL\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(norm(A) * norm(inv(A))).\n*\n*  WORK    (workspace) REAL array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.stpcon( norm, uplo, diag, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_diag = argv[2];
  rblapack_ap = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  work = ALLOC_N(real, (3*n));
  iwork = ALLOC_N(integer, (n));

  stpcon_(&norm, &uplo, &diag, &n, ap, &rcond, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_stpcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "stpcon", rblapack_stpcon, -1);
}
ruby-lapack-1.7.2/ext/slasq6.c0000644000175000017500000001010012502221015015722 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slasq6_(integer* i0, integer* n0, real* z, integer* pp, real* dmin, real* dmin1, real* dmin2, real* dn, real* dnm1, real* dnm2);


static VALUE
rblapack_slasq6(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_i0;
  integer i0; 
  VALUE rblapack_n0;
  integer n0; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_pp;
  integer pp; 
  VALUE rblapack_dmin;
  real dmin; 
  VALUE rblapack_dmin1;
  real dmin1; 
  VALUE rblapack_dmin2;
  real dmin2; 
  VALUE rblapack_dn;
  real dn; 
  VALUE rblapack_dnm1;
  real dnm1; 
  VALUE rblapack_dnm2;
  real dnm2; 


  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  dmin, dmin1, dmin2, dn, dnm1, dnm2 = NumRu::Lapack.slasq6( i0, n0, z, pp, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DNM1, DNM2 )\n\n*  Purpose\n*  =======\n*\n*  SLASQ6 computes one dqd (shift equal to zero) transform in\n*  ping-pong form, with protection against underflow and overflow.\n*\n\n*  Arguments\n*  =========\n*\n*  I0    (input) INTEGER\n*        First index.\n*\n*  N0    (input) INTEGER\n*        Last index.\n*\n*  Z     (input) REAL array, dimension ( 4*N )\n*        Z holds the qd array. EMIN is stored in Z(4*N0) to avoid\n*        an extra argument.\n*\n*  PP    (input) INTEGER\n*        PP=0 for ping, PP=1 for pong.\n*\n*  DMIN  (output) REAL\n*        Minimum value of d.\n*\n*  DMIN1 (output) REAL\n*        Minimum value of d, excluding D( N0 ).\n*\n*  DMIN2 (output) REAL\n*        Minimum value of d, excluding D( N0 ) and D( N0-1 ).\n*\n*  DN    (output) REAL\n*        d(N0), the last value of d.\n*\n*  DNM1  (output) REAL\n*        d(N0-1).\n*\n*  DNM2  (output) REAL\n*        d(N0-2).\n*\n\n*  =====================================================================\n*\n*     .. Parameter ..\n      REAL               ZERO\n      PARAMETER          ( ZERO = 0.0E0 )\n*     ..\n*     .. Local Scalars ..\n      INTEGER            J4, J4P2\n      REAL               D, EMIN, SAFMIN, TEMP\n*     ..\n*     .. External Function ..\n      REAL               SLAMCH\n      EXTERNAL           SLAMCH\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  dmin, dmin1, dmin2, dn, dnm1, dnm2 = NumRu::Lapack.slasq6( i0, n0, z, pp, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_i0 = argv[0];
  rblapack_n0 = argv[1];
  rblapack_z = argv[2];
  rblapack_pp = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  i0 = NUM2INT(rblapack_i0);
  pp = NUM2INT(rblapack_pp);
  n0 = NUM2INT(rblapack_n0);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (3th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != (4*n0))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 4*n0);
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);

  slasq6_(&i0, &n0, z, &pp, &dmin, &dmin1, &dmin2, &dn, &dnm1, &dnm2);

  rblapack_dmin = rb_float_new((double)dmin);
  rblapack_dmin1 = rb_float_new((double)dmin1);
  rblapack_dmin2 = rb_float_new((double)dmin2);
  rblapack_dn = rb_float_new((double)dn);
  rblapack_dnm1 = rb_float_new((double)dnm1);
  rblapack_dnm2 = rb_float_new((double)dnm2);
  return rb_ary_new3(6, rblapack_dmin, rblapack_dmin1, rblapack_dmin2, rblapack_dn, rblapack_dnm1, rblapack_dnm2);
}

void
init_lapack_slasq6(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slasq6", rblapack_slasq6, -1);
}
ruby-lapack-1.7.2/ext/slantr.c0000644000175000017500000001221512502221017016027 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real slantr_(char* norm, char* uplo, char* diag, integer* m, integer* n, real* a, integer* lda, real* work);


static VALUE
rblapack_slantr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack___out__;
  real __out__; 
  real *work;

  integer lda;
  integer n;
  integer lwork;

  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  __out__ = NumRu::Lapack.slantr( norm, uplo, diag, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL             FUNCTION SLANTR( NORM, UPLO, DIAG, M, N, A, LDA, WORK )\n\n*  Purpose\n*  =======\n*\n*  SLANTR  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  trapezoidal or triangular matrix A.\n*\n*  Description\n*  ===========\n*\n*  SLANTR returns the value\n*\n*     SLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in SLANTR as described\n*          above.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the matrix A is upper or lower trapezoidal.\n*          = 'U':  Upper trapezoidal\n*          = 'L':  Lower trapezoidal\n*          Note that A is triangular instead of trapezoidal if M = N.\n*\n*  DIAG    (input) CHARACTER*1\n*          Specifies whether or not the matrix A has unit diagonal.\n*          = 'N':  Non-unit diagonal\n*          = 'U':  Unit diagonal\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.  M >= 0, and if\n*          UPLO = 'U', M <= N.  When M = 0, SLANTR is set to zero.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.  N >= 0, and if\n*          UPLO = 'L', N <= M.  When N = 0, SLANTR is set to zero.\n*\n*  A       (input) REAL array, dimension (LDA,N)\n*          The trapezoidal matrix A (A is triangular if M = N).\n*          If UPLO = 'U', the leading m by n upper trapezoidal part of\n*          the array A contains the upper trapezoidal matrix, and the\n*          strictly lower triangular part of A is not referenced.\n*          If UPLO = 'L', the leading m by n lower trapezoidal part of\n*          the array A contains the lower trapezoidal matrix, and the\n*          strictly upper triangular part of A is not referenced.  Note\n*          that when DIAG = 'U', the diagonal elements of A are not\n*          referenced and are assumed to be one.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(M,1).\n*\n*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),\n*          where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n*          referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.slantr( norm, uplo, diag, m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_diag = argv[2];
  rblapack_m = argv[3];
  rblapack_a = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  m = NUM2INT(rblapack_m);
  lwork = lsame_(&norm,"I") ? m : 0;
  work = ALLOC_N(real, (MAX(1,lwork)));

  __out__ = slantr_(&norm, &uplo, &diag, &m, &n, a, &lda, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_slantr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slantr", rblapack_slantr, -1);
}
ruby-lapack-1.7.2/ext/dlar2v.c0000644000175000017500000001526112502221025015721 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlar2v_(integer* n, doublereal* x, doublereal* y, doublereal* z, integer* incx, doublereal* c, doublereal* s, integer* incc);


static VALUE
rblapack_dlar2v(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_y;
  doublereal *y; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_incc;
  integer incc; 
  VALUE rblapack_x_out__;
  doublereal *x_out__;
  VALUE rblapack_y_out__;
  doublereal *y_out__;
  VALUE rblapack_z_out__;
  doublereal *z_out__;


  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  x, y, z = NumRu::Lapack.dlar2v( n, x, y, z, incx, c, s, incc, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAR2V( N, X, Y, Z, INCX, C, S, INCC )\n\n*  Purpose\n*  =======\n*\n*  DLAR2V applies a vector of real plane rotations from both sides to\n*  a sequence of 2-by-2 real symmetric matrices, defined by the elements\n*  of the vectors x, y and z. For i = 1,2,...,n\n*\n*     ( x(i)  z(i) ) := (  c(i)  s(i) ) ( x(i)  z(i) ) ( c(i) -s(i) )\n*     ( z(i)  y(i) )    ( -s(i)  c(i) ) ( z(i)  y(i) ) ( s(i)  c(i) )\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of plane rotations to be applied.\n*\n*  X       (input/output) DOUBLE PRECISION array,\n*                         dimension (1+(N-1)*INCX)\n*          The vector x.\n*\n*  Y       (input/output) DOUBLE PRECISION array,\n*                         dimension (1+(N-1)*INCX)\n*          The vector y.\n*\n*  Z       (input/output) DOUBLE PRECISION array,\n*                         dimension (1+(N-1)*INCX)\n*          The vector z.\n*\n*  INCX    (input) INTEGER\n*          The increment between elements of X, Y and Z. INCX > 0.\n*\n*  C       (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)\n*          The cosines of the plane rotations.\n*\n*  S       (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)\n*          The sines of the plane rotations.\n*\n*  INCC    (input) INTEGER\n*          The increment between elements of C and S. INCC > 0.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, IC, IX\n      DOUBLE PRECISION   CI, SI, T1, T2, T3, T4, T5, T6, XI, YI, ZI\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, y, z = NumRu::Lapack.dlar2v( n, x, y, z, incx, c, s, incc, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_n = argv[0];
  rblapack_x = argv[1];
  rblapack_y = argv[2];
  rblapack_z = argv[3];
  rblapack_incx = argv[4];
  rblapack_c = argv[5];
  rblapack_s = argv[6];
  rblapack_incc = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  incx = NUM2INT(rblapack_incx);
  incc = NUM2INT(rblapack_incc);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1+(n-1)*incx))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (4th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != (1+(n-1)*incx))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 1+(n-1)*incx);
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (7th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != (1+(n-1)*incc))
    rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", 1+(n-1)*incc);
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (3th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incx))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incx);
  if (NA_TYPE(rblapack_y) != NA_DFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
  y = NA_PTR_TYPE(rblapack_y, doublereal*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != (1+(n-1)*incc))
    rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", 1+(n-1)*incc);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incx;
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incx;
    rblapack_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
  MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incx;
    rblapack_z_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
  MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  dlar2v_(&n, x, y, z, &incx, c, s, &incc);

  return rb_ary_new3(3, rblapack_x, rblapack_y, rblapack_z);
}

void
init_lapack_dlar2v(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlar2v", rblapack_dlar2v, -1);
}
ruby-lapack-1.7.2/ext/sorcsd.c0000644000175000017500000002725212502221021016023 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sorcsd_(char* jobu1, char* jobu2, char* jobv1t, char* jobv2t, char* trans, char* signs, integer* m, integer* p, integer* q, real* x11, integer* ldx11, real* x12, integer* ldx12, real* x21, integer* ldx21, real* x22, integer* ldx22, real* theta, real* u1, integer* ldu1, real* u2, integer* ldu2, real* v1t, integer* ldv1t, real* v2t, integer* ldv2t, real* work, integer* lwork, integer* iwork, integer* info);


static VALUE
rblapack_sorcsd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobu1;
  char jobu1; 
  VALUE rblapack_jobu2;
  char jobu2; 
  VALUE rblapack_jobv1t;
  char jobv1t; 
  VALUE rblapack_jobv2t;
  char jobv2t; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_signs;
  char signs; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_x11;
  real *x11; 
  VALUE rblapack_x12;
  real *x12; 
  VALUE rblapack_x21;
  real *x21; 
  VALUE rblapack_x22;
  real *x22; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_theta;
  real *theta; 
  VALUE rblapack_u1;
  real *u1; 
  VALUE rblapack_u2;
  real *u2; 
  VALUE rblapack_v1t;
  real *v1t; 
  VALUE rblapack_v2t;
  real *v2t; 
  VALUE rblapack_info;
  integer info; 
  real *work;
  integer *iwork;

  integer ldx11;
  integer q;
  integer ldx12;
  integer ldx21;
  integer ldx22;
  integer p;
  integer ldv2t;
  integer ldv1t;
  integer ldu1;
  integer ldu2;

  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  theta, u1, u2, v1t, v2t, info = NumRu::Lapack.sorcsd( jobu1, jobu2, jobv1t, jobv2t, trans, signs, m, x11, x12, x21, x22, lwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      RECURSIVE SUBROUTINE SORCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, WORK, LWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SORCSD computes the CS decomposition of an M-by-M partitioned\n*  orthogonal matrix X:\n*\n*                                  [  I  0  0 |  0  0  0 ]\n*                                  [  0  C  0 |  0 -S  0 ]\n*      [ X11 | X12 ]   [ U1 |    ] [  0  0  0 |  0  0 -I ] [ V1 |    ]**T\n*  X = [-----------] = [---------] [---------------------] [---------]   .\n*      [ X21 | X22 ]   [    | U2 ] [  0  0  0 |  I  0  0 ] [    | V2 ]\n*                                  [  0  S  0 |  0  C  0 ]\n*                                  [  0  0  I |  0  0  0 ]\n*\n*  X11 is P-by-Q. The orthogonal matrices U1, U2, V1, and V2 are P-by-P,\n*  (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are\n*  R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in\n*  which R = MIN(P,M-P,Q,M-Q).\n*\n\n*  Arguments\n*  =========\n*\n*  JOBU1   (input) CHARACTER\n*          = 'Y':      U1 is computed;\n*          otherwise:  U1 is not computed.\n*\n*  JOBU2   (input) CHARACTER\n*          = 'Y':      U2 is computed;\n*          otherwise:  U2 is not computed.\n*\n*  JOBV1T  (input) CHARACTER\n*          = 'Y':      V1T is computed;\n*          otherwise:  V1T is not computed.\n*\n*  JOBV2T  (input) CHARACTER\n*          = 'Y':      V2T is computed;\n*          otherwise:  V2T is not computed.\n*\n*  TRANS   (input) CHARACTER\n*          = 'T':      X, U1, U2, V1T, and V2T are stored in row-major\n*                      order;\n*          otherwise:  X, U1, U2, V1T, and V2T are stored in column-\n*                      major order.\n*\n*  SIGNS   (input) CHARACTER\n*          = 'O':      The lower-left block is made nonpositive (the\n*                      \"other\" convention);\n*          otherwise:  The upper-right block is made nonpositive (the\n*                      \"default\" convention).\n*\n*  M       (input) INTEGER\n*          The number of rows and columns in X.\n*\n*  P       (input) INTEGER\n*          The number of rows in X11 and X12. 0 <= P <= M.\n*\n*  Q       (input) INTEGER\n*          The number of columns in X11 and X21. 0 <= Q <= M.\n*\n*  X       (input/workspace) REAL array, dimension (LDX,M)\n*          On entry, the orthogonal matrix whose CSD is desired.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of X. LDX >= MAX(1,M).\n*\n*  THETA   (output) REAL array, dimension (R), in which R =\n*          MIN(P,M-P,Q,M-Q).\n*          C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and\n*          S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).\n*\n*  U1      (output) REAL array, dimension (P)\n*          If JOBU1 = 'Y', U1 contains the P-by-P orthogonal matrix U1.\n*\n*  LDU1    (input) INTEGER\n*          The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=\n*          MAX(1,P).\n*\n*  U2      (output) REAL array, dimension (M-P)\n*          If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) orthogonal\n*          matrix U2.\n*\n*  LDU2    (input) INTEGER\n*          The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=\n*          MAX(1,M-P).\n*\n*  V1T     (output) REAL array, dimension (Q)\n*          If JOBV1T = 'Y', V1T contains the Q-by-Q matrix orthogonal\n*          matrix V1**T.\n*\n*  LDV1T   (input) INTEGER\n*          The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=\n*          MAX(1,Q).\n*\n*  V2T     (output) REAL array, dimension (M-Q)\n*          If JOBV2T = 'Y', V2T contains the (M-Q)-by-(M-Q) orthogonal\n*          matrix V2**T.\n*\n*  LDV2T   (input) INTEGER\n*          The leading dimension of V2T. If JOBV2T = 'Y', LDV2T >=\n*          MAX(1,M-Q).\n*\n*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*          If INFO > 0 on exit, WORK(2:R) contains the values PHI(1),\n*          ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),\n*          define the matrix in intermediate bidiagonal-block form\n*          remaining after nonconvergence. INFO specifies the number\n*          of nonzero PHI's.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK.\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*  IWORK   (workspace) INTEGER array, dimension (M-Q)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit.\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          > 0:  SBBCSD did not converge. See the description of WORK\n*                above for details.\n*\n*  Reference\n*  =========\n*\n*  [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.\n*      Algorithms, 50(1):33-65, 2009.\n*\n\n*  ===================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  theta, u1, u2, v1t, v2t, info = NumRu::Lapack.sorcsd( jobu1, jobu2, jobv1t, jobv2t, trans, signs, m, x11, x12, x21, x22, lwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_jobu1 = argv[0];
  rblapack_jobu2 = argv[1];
  rblapack_jobv1t = argv[2];
  rblapack_jobv2t = argv[3];
  rblapack_trans = argv[4];
  rblapack_signs = argv[5];
  rblapack_m = argv[6];
  rblapack_x11 = argv[7];
  rblapack_x12 = argv[8];
  rblapack_x21 = argv[9];
  rblapack_x22 = argv[10];
  rblapack_lwork = argv[11];
  if (argc == 12) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobu1 = StringValueCStr(rblapack_jobu1)[0];
  jobv1t = StringValueCStr(rblapack_jobv1t)[0];
  trans = StringValueCStr(rblapack_trans)[0];
  m = NUM2INT(rblapack_m);
  lwork = NUM2INT(rblapack_lwork);
  jobu2 = StringValueCStr(rblapack_jobu2)[0];
  signs = StringValueCStr(rblapack_signs)[0];
  jobv2t = StringValueCStr(rblapack_jobv2t)[0];
  if (!NA_IsNArray(rblapack_x11))
    rb_raise(rb_eArgError, "x11 (8th argument) must be NArray");
  if (NA_RANK(rblapack_x11) != 2)
    rb_raise(rb_eArgError, "rank of x11 (8th argument) must be %d", 2);
  ldx11 = NA_SHAPE0(rblapack_x11);
  q = NA_SHAPE1(rblapack_x11);
  if (NA_TYPE(rblapack_x11) != NA_SFLOAT)
    rblapack_x11 = na_change_type(rblapack_x11, NA_SFLOAT);
  x11 = NA_PTR_TYPE(rblapack_x11, real*);
  p = ldx11;
  ldx21 = p;
  if (!NA_IsNArray(rblapack_x21))
    rb_raise(rb_eArgError, "x21 (10th argument) must be NArray");
  if (NA_RANK(rblapack_x21) != 2)
    rb_raise(rb_eArgError, "rank of x21 (10th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_x21) != ldx21)
    rb_raise(rb_eRuntimeError, "shape 0 of x21 must be p");
  if (NA_SHAPE1(rblapack_x21) != q)
    rb_raise(rb_eRuntimeError, "shape 1 of x21 must be the same as shape 1 of x11");
  if (NA_TYPE(rblapack_x21) != NA_SFLOAT)
    rblapack_x21 = na_change_type(rblapack_x21, NA_SFLOAT);
  x21 = NA_PTR_TYPE(rblapack_x21, real*);
  ldv2t = lsame_(&jobv2t,"Y") ? MAX(1,m-q) : 0;
  ldu1 = lsame_(&jobu1,"Y") ? MAX(1,p) : 0;
  ldx12 = p;
  if (!NA_IsNArray(rblapack_x12))
    rb_raise(rb_eArgError, "x12 (9th argument) must be NArray");
  if (NA_RANK(rblapack_x12) != 2)
    rb_raise(rb_eArgError, "rank of x12 (9th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_x12) != ldx12)
    rb_raise(rb_eRuntimeError, "shape 0 of x12 must be p");
  if (NA_SHAPE1(rblapack_x12) != (m-q))
    rb_raise(rb_eRuntimeError, "shape 1 of x12 must be %d", m-q);
  if (NA_TYPE(rblapack_x12) != NA_SFLOAT)
    rblapack_x12 = na_change_type(rblapack_x12, NA_SFLOAT);
  x12 = NA_PTR_TYPE(rblapack_x12, real*);
  ldv1t = lsame_(&jobv1t,"Y") ? MAX(1,q) : 0;
  ldx22 = p;
  if (!NA_IsNArray(rblapack_x22))
    rb_raise(rb_eArgError, "x22 (11th argument) must be NArray");
  if (NA_RANK(rblapack_x22) != 2)
    rb_raise(rb_eArgError, "rank of x22 (11th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_x22) != ldx22)
    rb_raise(rb_eRuntimeError, "shape 0 of x22 must be p");
  if (NA_SHAPE1(rblapack_x22) != (m-q))
    rb_raise(rb_eRuntimeError, "shape 1 of x22 must be %d", m-q);
  if (NA_TYPE(rblapack_x22) != NA_SFLOAT)
    rblapack_x22 = na_change_type(rblapack_x22, NA_SFLOAT);
  x22 = NA_PTR_TYPE(rblapack_x22, real*);
  ldu2 = lsame_(&jobu2,"Y") ? MAX(1,m-p) : 0;
  {
    na_shape_t shape[1];
    shape[0] = MIN(MIN(MIN(p,m-p),q),m-q);
    rblapack_theta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  theta = NA_PTR_TYPE(rblapack_theta, real*);
  {
    na_shape_t shape[1];
    shape[0] = p;
    rblapack_u1 = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  u1 = NA_PTR_TYPE(rblapack_u1, real*);
  {
    na_shape_t shape[1];
    shape[0] = m-p;
    rblapack_u2 = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  u2 = NA_PTR_TYPE(rblapack_u2, real*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_v1t = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  v1t = NA_PTR_TYPE(rblapack_v1t, real*);
  {
    na_shape_t shape[1];
    shape[0] = m-q;
    rblapack_v2t = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  v2t = NA_PTR_TYPE(rblapack_v2t, real*);
  work = ALLOC_N(real, (MAX(1,lwork)));
  iwork = ALLOC_N(integer, (m-q));

  sorcsd_(&jobu1, &jobu2, &jobv1t, &jobv2t, &trans, &signs, &m, &p, &q, x11, &ldx11, x12, &ldx12, x21, &ldx21, x22, &ldx22, theta, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, v2t, &ldv2t, work, &lwork, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_theta, rblapack_u1, rblapack_u2, rblapack_v1t, rblapack_v2t, rblapack_info);
}

void
init_lapack_sorcsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sorcsd", rblapack_sorcsd, -1);
}
ruby-lapack-1.7.2/ext/zhfrk.c0000644000175000017500000001550312502221017015653 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhfrk_(char* transr, char* uplo, char* trans, integer* n, integer* k, doublereal* alpha, doublecomplex* a, integer* lda, doublereal* beta, doublecomplex* c);


static VALUE
rblapack_zhfrk(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_alpha;
  doublereal alpha; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_beta;
  doublereal beta; 
  VALUE rblapack_c;
  doublecomplex *c; 
  VALUE rblapack_c_out__;
  doublecomplex *c_out__;
  integer ldc;

  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  c = NumRu::Lapack.zhfrk( transr, uplo, trans, k, alpha, a, beta, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C )\n\n*  Purpose\n*  =======\n*\n*  Level 3 BLAS like routine for C in RFP Format.\n*\n*  ZHFRK performs one of the Hermitian rank--k operations\n*\n*     C := alpha*A*conjg( A' ) + beta*C,\n*\n*  or\n*\n*     C := alpha*conjg( A' )*A + beta*C,\n*\n*  where alpha and beta are real scalars, C is an n--by--n Hermitian\n*  matrix and A is an n--by--k matrix in the first case and a k--by--n\n*  matrix in the second case.\n*\n\n*  Arguments\n*  ==========\n*\n*  TRANSR  (input) CHARACTER*1\n*          = 'N':  The Normal Form of RFP A is stored;\n*          = 'C':  The Conjugate-transpose Form of RFP A is stored.\n*\n*  UPLO    (input) CHARACTER*1\n*           On  entry,   UPLO  specifies  whether  the  upper  or  lower\n*           triangular  part  of the  array  C  is to be  referenced  as\n*           follows:\n*\n*              UPLO = 'U' or 'u'   Only the  upper triangular part of  C\n*                                  is to be referenced.\n*\n*              UPLO = 'L' or 'l'   Only the  lower triangular part of  C\n*                                  is to be referenced.\n*\n*           Unchanged on exit.\n*\n*  TRANS   (input) CHARACTER*1\n*           On entry,  TRANS  specifies the operation to be performed as\n*           follows:\n*\n*              TRANS = 'N' or 'n'   C := alpha*A*conjg( A' ) + beta*C.\n*\n*              TRANS = 'C' or 'c'   C := alpha*conjg( A' )*A + beta*C.\n*\n*           Unchanged on exit.\n*\n*  N       (input) INTEGER\n*           On entry,  N specifies the order of the matrix C.  N must be\n*           at least zero.\n*           Unchanged on exit.\n*\n*  K       (input) INTEGER\n*           On entry with  TRANS = 'N' or 'n',  K  specifies  the number\n*           of  columns   of  the   matrix   A,   and  on   entry   with\n*           TRANS = 'C' or 'c',  K  specifies  the number of rows of the\n*           matrix A.  K must be at least zero.\n*           Unchanged on exit.\n*\n*  ALPHA   (input) DOUBLE PRECISION\n*           On entry, ALPHA specifies the scalar alpha.\n*           Unchanged on exit.\n*\n*  A       (input) COMPLEX*16 array of DIMENSION (LDA,ka)\n*           where KA\n*           is K  when TRANS = 'N' or 'n', and is N otherwise. Before\n*           entry with TRANS = 'N' or 'n', the leading N--by--K part of\n*           the array A must contain the matrix A, otherwise the leading\n*           K--by--N part of the array A must contain the matrix A.\n*           Unchanged on exit.\n*\n*  LDA     (input) INTEGER\n*           On entry, LDA specifies the first dimension of A as declared\n*           in  the  calling  (sub)  program.   When  TRANS = 'N' or 'n'\n*           then  LDA must be at least  max( 1, n ), otherwise  LDA must\n*           be at least  max( 1, k ).\n*           Unchanged on exit.\n*\n*  BETA    (input) DOUBLE PRECISION\n*           On entry, BETA specifies the scalar beta.\n*           Unchanged on exit.\n*\n*  C       (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n*           On entry, the matrix A in RFP Format. RFP Format is\n*           described by TRANSR, UPLO and N. Note that the imaginary\n*           parts of the diagonal elements need not be set, they are\n*           assumed to be zero, and on exit they are set to zero.\n*\n*  Arguments\n*  ==========\n*\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.zhfrk( transr, uplo, trans, k, alpha, a, beta, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_trans = argv[2];
  rblapack_k = argv[3];
  rblapack_alpha = argv[4];
  rblapack_a = argv[5];
  rblapack_beta = argv[6];
  rblapack_c = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  trans = StringValueCStr(rblapack_trans)[0];
  alpha = NUM2DBL(rblapack_alpha);
  beta = NUM2DBL(rblapack_beta);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (8th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 1);
  ldc = NA_SHAPE0(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
  n = ((int)sqrtf(ldc*8+1.0f)-1)/2;
  k = NUM2INT(rblapack_k);
  lda = lsame_(&trans,"N") ? MAX(1,n) : MAX(1,k);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (6th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (6th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_a) != lda)
    rb_raise(rb_eRuntimeError, "shape 0 of a must be lsame_(&trans,\"N\") ? MAX(1,n) : MAX(1,k)");
  if (NA_SHAPE1(rblapack_a) != (lsame_(&trans,"N") ? k : n))
    rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", lsame_(&trans,"N") ? k : n);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = ldc;
    rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
  MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  zhfrk_(&transr, &uplo, &trans, &n, &k, &alpha, a, &lda, &beta, c);

  return rblapack_c;
}

void
init_lapack_zhfrk(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhfrk", rblapack_zhfrk, -1);
}
ruby-lapack-1.7.2/ext/zposvxx.c0000644000175000017500000006300512502221017016270 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zposvxx_(char* fact, char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, char* equed, doublereal* s, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* rpvgrw, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zposvxx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_params;
  doublereal *params; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_rpvgrw;
  doublereal rpvgrw; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_err_bnds_norm;
  doublereal *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  doublereal *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_af_out__;
  doublecomplex *af_out__;
  VALUE rblapack_s_out__;
  doublereal *s_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  VALUE rblapack_params_out__;
  doublereal *params_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer nparams;
  integer ldx;
  integer n_err_bnds;

  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  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, equed, s, b, params = NumRu::Lapack.zposvxx( fact, uplo, a, af, equed, s, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     ZPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T\n*     to compute the solution to a complex*16 system of linear equations\n*     A * X = B, where A is an N-by-N symmetric positive definite matrix\n*     and X and B are N-by-NRHS matrices.\n*\n*     If requested, both normwise and maximum componentwise error bounds\n*     are returned. ZPOSVXX will return a solution with a tiny\n*     guaranteed error (O(eps) where eps is the working machine\n*     precision) unless the matrix is very ill-conditioned, in which\n*     case a warning is returned. Relevant condition numbers also are\n*     calculated and returned.\n*\n*     ZPOSVXX accepts user-provided factorizations and equilibration\n*     factors; see the definitions of the FACT and EQUED options.\n*     Solving with refinement and using a factorization from a previous\n*     ZPOSVXX call will also produce a solution with either O(eps)\n*     errors or warnings, but we cannot make that claim for general\n*     user-provided factorizations and equilibration factors if they\n*     differ from what ZPOSVXX would itself produce.\n*\n*     Description\n*     ===========\n*\n*     The following steps are performed:\n*\n*     1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n*     the system:\n*\n*       diag(S)*A*diag(S)     *inv(diag(S))*X = diag(S)*B\n*\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n*     2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n*     factor the matrix A (after equilibration if FACT = 'E') as\n*        A = U**T* U,  if UPLO = 'U', or\n*        A = L * L**T,  if UPLO = 'L',\n*     where U is an upper triangular matrix and L is a lower triangular\n*     matrix.\n*\n*     3. If the leading i-by-i principal minor is not positive definite,\n*     then the routine returns with INFO = i. Otherwise, the factored\n*     form of A is used to estimate the condition number of the matrix\n*     A (see argument RCOND).  If the reciprocal of the condition number\n*     is less than machine precision, the routine still goes on to solve\n*     for X and compute error bounds as described below.\n*\n*     4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*     5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n*     the routine will use iterative refinement to try to get a small\n*     error and error bounds.  Refinement calculates the residual to at\n*     least twice the working precision.\n*\n*     6. If equilibration was used, the matrix X is premultiplied by\n*     diag(S) so that it solves the original system before\n*     equilibration.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     FACT    (input) CHARACTER*1\n*     Specifies whether or not the factored form of the matrix A is\n*     supplied on entry, and if not, whether the matrix A should be\n*     equilibrated before it is factored.\n*       = 'F':  On entry, AF contains the factored form of A.\n*               If EQUED is not 'N', the matrix A has been\n*               equilibrated with scaling factors given by S.\n*               A and AF are not modified.\n*       = 'N':  The matrix A will be copied to AF and factored.\n*       = 'E':  The matrix A will be equilibrated if necessary, then\n*               copied to AF and factored.\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*     On entry, the symmetric matrix A, except if FACT = 'F' and EQUED =\n*     'Y', then A must contain the equilibrated matrix\n*     diag(S)*A*diag(S).  If UPLO = 'U', the leading N-by-N upper\n*     triangular part of A contains the upper triangular part of the\n*     matrix A, and the strictly lower triangular part of A is not\n*     referenced.  If UPLO = 'L', the leading N-by-N lower triangular\n*     part of A contains the lower triangular part of the matrix A, and\n*     the strictly upper triangular part of A is not referenced.  A is\n*     not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED =\n*     'N' on exit.\n*\n*     On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n*     diag(S)*A*diag(S).\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input or output) COMPLEX*16 array, dimension (LDAF,N)\n*     If FACT = 'F', then AF is an input argument and on entry\n*     contains the triangular factor U or L from the Cholesky\n*     factorization A = U**T*U or A = L*L**T, in the same storage\n*     format as A.  If EQUED .ne. 'N', then AF is the factored\n*     form of the equilibrated matrix diag(S)*A*diag(S).\n*\n*     If FACT = 'N', then AF is an output argument and on exit\n*     returns the triangular factor U or L from the Cholesky\n*     factorization A = U**T*U or A = L*L**T of the original\n*     matrix A.\n*\n*     If FACT = 'E', then AF is an output argument and on exit\n*     returns the triangular factor U or L from the Cholesky\n*     factorization A = U**T*U or A = L*L**T of the equilibrated\n*     matrix A (see the description of A for the form of the\n*     equilibrated matrix).\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     EQUED   (input or output) CHARACTER*1\n*     Specifies the form of equilibration that was done.\n*       = 'N':  No equilibration (always true if FACT = 'N').\n*       = 'Y':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(S) * A * diag(S).\n*     EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*     output argument.\n*\n*     S       (input or output) DOUBLE PRECISION array, dimension (N)\n*     The row scale factors for A.  If EQUED = 'Y', A is multiplied on\n*     the left and right by diag(S).  S is an input argument if FACT =\n*     'F'; otherwise, S is an output argument.  If FACT = 'F' and EQUED\n*     = 'Y', each element of S must be positive.  If S is output, each\n*     element of S is a power of the radix. If S is input, each element\n*     of S should be a power of the radix to ensure a reliable solution\n*     and error estimates. Scaling by powers of the radix does not cause\n*     rounding errors unless the result underflows or overflows.\n*     Rounding errors during scaling lead to refining with a matrix that\n*     is not equivalent to the input matrix, producing error estimates\n*     that may not be reliable.\n*\n*     B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*     On entry, the N-by-NRHS right hand side matrix B.\n*     On exit,\n*     if EQUED = 'N', B is not modified;\n*     if EQUED = 'Y', B is overwritten by diag(S)*B;\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (output) COMPLEX*16 array, dimension (LDX,NRHS)\n*     If INFO = 0, the N-by-NRHS solution matrix X to the original\n*     system of equations.  Note that A and B are modified on exit if\n*     EQUED .ne. 'N', and the solution to the equilibrated system is\n*     inv(diag(S))*X.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) DOUBLE PRECISION\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     RPVGRW  (output) DOUBLE PRECISION\n*     Reciprocal pivot growth.  On exit, this contains the reciprocal\n*     pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n*     norm is used.  If this is much less than 1, then the stability of\n*     the LU factorization of the (equilibrated) matrix A could be poor.\n*     This also means that the solution X, estimated condition numbers,\n*     and error bounds could be unreliable. If factorization fails with\n*     0 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, equed, s, b, params = NumRu::Lapack.zposvxx( fact, uplo, a, af, equed, s, b, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_equed = argv[4];
  rblapack_s = argv[5];
  rblapack_b = argv[6];
  rblapack_params = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  n_err_bnds = 3;
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (6th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  ldx = MAX(1,n);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (8th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (8th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_DFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
  params = NA_PTR_TYPE(rblapack_params, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldaf;
    shape[1] = n;
    rblapack_af_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  af_out__ = NA_PTR_TYPE(rblapack_af_out__, doublecomplex*);
  MEMCPY(af_out__, af, doublecomplex, NA_TOTAL(rblapack_af));
  rblapack_af = rblapack_af_out__;
  af = af_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
  MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
  MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (2*n));

  zposvxx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &equed, s, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_rpvgrw = rb_float_new((double)rpvgrw);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(13, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_a, rblapack_af, rblapack_equed, rblapack_s, rblapack_b, rblapack_params);
}

void
init_lapack_zposvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zposvxx", rblapack_zposvxx, -1);
}
ruby-lapack-1.7.2/ext/dlasd6.c0000644000175000017500000003700112655767573015740 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlasd6_(integer* icompq, integer* nl, integer* nr, integer* sqre, doublereal* d, doublereal* vf, doublereal* vl, doublereal* alpha, doublereal* beta, integer* idxq, integer* perm, integer* givptr, integer* givcol, integer* ldgcol, doublereal* givnum, integer* ldgnum, doublereal* poles, doublereal* difl, doublereal* difr, doublereal* z, integer* k, doublereal* c, doublereal* s, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dlasd6(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_icompq;
  integer icompq; 
  VALUE rblapack_nl;
  integer nl; 
  VALUE rblapack_nr;
  integer nr; 
  VALUE rblapack_sqre;
  integer sqre; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_vf;
  doublereal *vf; 
  VALUE rblapack_vl;
  doublereal *vl; 
  VALUE rblapack_alpha;
  doublereal alpha; 
  VALUE rblapack_beta;
  doublereal beta; 
  VALUE rblapack_idxq;
  integer *idxq; 
  VALUE rblapack_perm;
  integer *perm; 
  VALUE rblapack_givptr;
  integer givptr; 
  VALUE rblapack_givcol;
  integer *givcol; 
  VALUE rblapack_givnum;
  doublereal *givnum; 
  VALUE rblapack_poles;
  doublereal *poles; 
  VALUE rblapack_difl;
  doublereal *difl; 
  VALUE rblapack_difr;
  doublereal *difr; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_c;
  doublereal c; 
  VALUE rblapack_s;
  doublereal s; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_vf_out__;
  doublereal *vf_out__;
  VALUE rblapack_vl_out__;
  doublereal *vl_out__;
  doublereal *work;
  integer *iwork;

  integer m;
  integer n;
  integer ldgcol;
  integer ldgnum;

  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  idxq, perm, givptr, givcol, givnum, poles, difl, difr, z, k, c, s, info, d, vf, vl, alpha, beta = NumRu::Lapack.dlasd6( icompq, nl, nr, sqre, d, vf, vl, alpha, beta, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA, IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLASD6 computes the SVD of an updated upper bidiagonal matrix B\n*  obtained by merging two smaller ones by appending a row. This\n*  routine is used only for the problem which requires all singular\n*  values and optionally singular vector matrices in factored form.\n*  B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE.\n*  A related subroutine, DLASD1, handles the case in which all singular\n*  values and singular vectors of the bidiagonal matrix are desired.\n*\n*  DLASD6 computes the SVD as follows:\n*\n*                ( D1(in)  0    0     0 )\n*    B = U(in) * (   Z1'   a   Z2'    b ) * VT(in)\n*                (   0     0   D2(in) 0 )\n*\n*      = U(out) * ( D(out) 0) * VT(out)\n*\n*  where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M\n*  with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros\n*  elsewhere; and the entry b is empty if SQRE = 0.\n*\n*  The singular values of B can be computed using D1, D2, the first\n*  components of all the right singular vectors of the lower block, and\n*  the last components of all the right singular vectors of the upper\n*  block. These components are stored and updated in VF and VL,\n*  respectively, in DLASD6. Hence U and VT are not explicitly\n*  referenced.\n*\n*  The singular values are stored in D. The algorithm consists of two\n*  stages:\n*\n*        The first stage consists of deflating the size of the problem\n*        when there are multiple singular values or if there is a zero\n*        in the Z vector. For each such occurrence the dimension of the\n*        secular equation problem is reduced by one. This stage is\n*        performed by the routine DLASD7.\n*\n*        The second stage consists of calculating the updated\n*        singular values. This is done by finding the roots of the\n*        secular equation via the routine DLASD4 (as called by DLASD8).\n*        This routine also updates VF and VL and computes the distances\n*        between the updated singular values and the old singular\n*        values.\n*\n*  DLASD6 is called from DLASDA.\n*\n\n*  Arguments\n*  =========\n*\n*  ICOMPQ (input) INTEGER\n*         Specifies whether singular vectors are to be computed in\n*         factored form:\n*         = 0: Compute singular values only.\n*         = 1: Compute singular vectors in factored form as well.\n*\n*  NL     (input) INTEGER\n*         The row dimension of the upper block.  NL >= 1.\n*\n*  NR     (input) INTEGER\n*         The row dimension of the lower block.  NR >= 1.\n*\n*  SQRE   (input) INTEGER\n*         = 0: the lower block is an NR-by-NR square matrix.\n*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n*         The bidiagonal matrix has row dimension N = NL + NR + 1,\n*         and column dimension M = N + SQRE.\n*\n*  D      (input/output) DOUBLE PRECISION array, dimension ( NL+NR+1 ).\n*         On entry D(1:NL,1:NL) contains the singular values of the\n*         upper block, and D(NL+2:N) contains the singular values\n*         of the lower block. On exit D(1:N) contains the singular\n*         values of the modified matrix.\n*\n*  VF     (input/output) DOUBLE PRECISION array, dimension ( M )\n*         On entry, VF(1:NL+1) contains the first components of all\n*         right singular vectors of the upper block; and VF(NL+2:M)\n*         contains the first components of all right singular vectors\n*         of the lower block. On exit, VF contains the first components\n*         of all right singular vectors of the bidiagonal matrix.\n*\n*  VL     (input/output) DOUBLE PRECISION array, dimension ( M )\n*         On entry, VL(1:NL+1) contains the  last components of all\n*         right singular vectors of the upper block; and VL(NL+2:M)\n*         contains the last components of all right singular vectors of\n*         the lower block. On exit, VL contains the last components of\n*         all right singular vectors of the bidiagonal matrix.\n*\n*  ALPHA  (input/output) DOUBLE PRECISION\n*         Contains the diagonal element associated with the added row.\n*\n*  BETA   (input/output) DOUBLE PRECISION\n*         Contains the off-diagonal element associated with the added\n*         row.\n*\n*  IDXQ   (output) INTEGER array, dimension ( N )\n*         This contains the permutation which will reintegrate the\n*         subproblem just solved back into sorted order, i.e.\n*         D( IDXQ( I = 1, N ) ) will be in ascending order.\n*\n*  PERM   (output) INTEGER array, dimension ( N )\n*         The permutations (from deflation and sorting) to be applied\n*         to each block. Not referenced if ICOMPQ = 0.\n*\n*  GIVPTR (output) INTEGER\n*         The number of Givens rotations which took place in this\n*         subproblem. Not referenced if ICOMPQ = 0.\n*\n*  GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )\n*         Each pair of numbers indicates a pair of columns to take place\n*         in a Givens rotation. Not referenced if ICOMPQ = 0.\n*\n*  LDGCOL (input) INTEGER\n*         leading dimension of GIVCOL, must be at least N.\n*\n*  GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )\n*         Each number indicates the C or S value to be used in the\n*         corresponding Givens rotation. Not referenced if ICOMPQ = 0.\n*\n*  LDGNUM (input) INTEGER\n*         The leading dimension of GIVNUM and POLES, must be at least N.\n*\n*  POLES  (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )\n*         On exit, POLES(1,*) is an array containing the new singular\n*         values obtained from solving the secular equation, and\n*         POLES(2,*) is an array containing the poles in the secular\n*         equation. Not referenced if ICOMPQ = 0.\n*\n*  DIFL   (output) DOUBLE PRECISION array, dimension ( N )\n*         On exit, DIFL(I) is the distance between I-th updated\n*         (undeflated) singular value and the I-th (undeflated) old\n*         singular value.\n*\n*  DIFR   (output) DOUBLE PRECISION array,\n*                  dimension ( LDGNUM, 2 ) if ICOMPQ = 1 and\n*                  dimension ( N ) if ICOMPQ = 0.\n*         On exit, DIFR(I, 1) is the distance between I-th updated\n*         (undeflated) singular value and the I+1-th (undeflated) old\n*         singular value.\n*\n*         If ICOMPQ = 1, DIFR(1:K,2) is an array containing the\n*         normalizing factors for the right singular vector matrix.\n*\n*         See DLASD8 for details on DIFL and DIFR.\n*\n*  Z      (output) DOUBLE PRECISION array, dimension ( M )\n*         The first elements of this array contain the components\n*         of the deflation-adjusted updating row vector.\n*\n*  K      (output) INTEGER\n*         Contains the dimension of the non-deflated matrix,\n*         This is the order of the related secular equation. 1 <= K <=N.\n*\n*  C      (output) DOUBLE PRECISION\n*         C contains garbage if SQRE =0 and the C-value of a Givens\n*         rotation related to the right null space if SQRE = 1.\n*\n*  S      (output) DOUBLE PRECISION\n*         S contains garbage if SQRE =0 and the S-value of a Givens\n*         rotation related to the right null space if SQRE = 1.\n*\n*  WORK   (workspace) DOUBLE PRECISION array, dimension ( 4 * M )\n*\n*  IWORK  (workspace) INTEGER array, dimension ( 3 * N )\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 = 1, a singular value did not converge\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  idxq, perm, givptr, givcol, givnum, poles, difl, difr, z, k, c, s, info, d, vf, vl, alpha, beta = NumRu::Lapack.dlasd6( icompq, nl, nr, sqre, d, vf, vl, alpha, beta, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_icompq = argv[0];
  rblapack_nl = argv[1];
  rblapack_nr = argv[2];
  rblapack_sqre = argv[3];
  rblapack_d = argv[4];
  rblapack_vf = argv[5];
  rblapack_vl = argv[6];
  rblapack_alpha = argv[7];
  rblapack_beta = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  icompq = NUM2INT(rblapack_icompq);
  nr = NUM2INT(rblapack_nr);
  alpha = NUM2DBL(rblapack_alpha);
  nl = NUM2INT(rblapack_nl);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (5th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != (nl+nr+1))
    rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", nl+nr+1);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  beta = NUM2DBL(rblapack_beta);
  n = nl + nr + 1;
  ldgcol = n;
  sqre = NUM2INT(rblapack_sqre);
  m = n + sqre;
  if (!NA_IsNArray(rblapack_vf))
    rb_raise(rb_eArgError, "vf (6th argument) must be NArray");
  if (NA_RANK(rblapack_vf) != 1)
    rb_raise(rb_eArgError, "rank of vf (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_vf) != m)
    rb_raise(rb_eRuntimeError, "shape 0 of vf must be n + sqre");
  if (NA_TYPE(rblapack_vf) != NA_DFLOAT)
    rblapack_vf = na_change_type(rblapack_vf, NA_DFLOAT);
  vf = NA_PTR_TYPE(rblapack_vf, doublereal*);
  ldgnum = n;
  if (!NA_IsNArray(rblapack_vl))
    rb_raise(rb_eArgError, "vl (7th argument) must be NArray");
  if (NA_RANK(rblapack_vl) != 1)
    rb_raise(rb_eArgError, "rank of vl (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_vl) != m)
    rb_raise(rb_eRuntimeError, "shape 0 of vl must be n + sqre");
  if (NA_TYPE(rblapack_vl) != NA_DFLOAT)
    rblapack_vl = na_change_type(rblapack_vl, NA_DFLOAT);
  vl = NA_PTR_TYPE(rblapack_vl, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_idxq = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  idxq = NA_PTR_TYPE(rblapack_idxq, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_perm = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  perm = NA_PTR_TYPE(rblapack_perm, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldgcol;
    shape[1] = 2;
    rblapack_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
  }
  givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldgnum;
    shape[1] = 2;
    rblapack_givnum = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  givnum = NA_PTR_TYPE(rblapack_givnum, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldgnum;
    shape[1] = 2;
    rblapack_poles = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  poles = NA_PTR_TYPE(rblapack_poles, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_difl = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  difl = NA_PTR_TYPE(rblapack_difl, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = icompq == 1 ? ldgnum : icompq == 0 ? n : 0;
    shape[1] = icompq == 1 ? 2 : 0;
    rblapack_difr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  difr = NA_PTR_TYPE(rblapack_difr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_z = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nl+nr+1;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_vf_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  vf_out__ = NA_PTR_TYPE(rblapack_vf_out__, doublereal*);
  MEMCPY(vf_out__, vf, doublereal, NA_TOTAL(rblapack_vf));
  rblapack_vf = rblapack_vf_out__;
  vf = vf_out__;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_vl_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, doublereal*);
  MEMCPY(vl_out__, vl, doublereal, NA_TOTAL(rblapack_vl));
  rblapack_vl = rblapack_vl_out__;
  vl = vl_out__;
  work = ALLOC_N(doublereal, (4 * m));
  iwork = ALLOC_N(integer, (3 * n));

  dlasd6_(&icompq, &nl, &nr, &sqre, d, vf, vl, &alpha, &beta, idxq, perm, &givptr, givcol, &ldgcol, givnum, &ldgnum, poles, difl, difr, z, &k, &c, &s, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_givptr = INT2NUM(givptr);
  rblapack_k = INT2NUM(k);
  rblapack_c = rb_float_new((double)c);
  rblapack_s = rb_float_new((double)s);
  rblapack_info = INT2NUM(info);
  rblapack_alpha = rb_float_new((double)alpha);
  rblapack_beta = rb_float_new((double)beta);
  return rb_ary_new3(18, rblapack_idxq, rblapack_perm, rblapack_givptr, rblapack_givcol, rblapack_givnum, rblapack_poles, rblapack_difl, rblapack_difr, rblapack_z, rblapack_k, rblapack_c, rblapack_s, rblapack_info, rblapack_d, rblapack_vf, rblapack_vl, rblapack_alpha, rblapack_beta);
}

void
init_lapack_dlasd6(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlasd6", rblapack_dlasd6, -1);
}
ruby-lapack-1.7.2/ext/dgtts2.c0000644000175000017500000001546712502221015015745 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgtts2_(integer* itrans, integer* n, integer* nrhs, doublereal* dl, doublereal* d, doublereal* du, doublereal* du2, integer* ipiv, doublereal* b, integer* ldb);


static VALUE
rblapack_dgtts2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itrans;
  integer itrans; 
  VALUE rblapack_dl;
  doublereal *dl; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_du;
  doublereal *du; 
  VALUE rblapack_du2;
  doublereal *du2; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_b_out__;
  doublereal *b_out__;

  integer n;
  integer ldb;
  integer nrhs;

  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  b = NumRu::Lapack.dgtts2( itrans, dl, d, du, du2, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )\n\n*  Purpose\n*  =======\n*\n*  DGTTS2 solves one of the systems of equations\n*     A*X = B  or  A'*X = B,\n*  with a tridiagonal matrix A using the LU factorization computed\n*  by DGTTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  ITRANS  (input) INTEGER\n*          Specifies the form of the system of equations.\n*          = 0:  A * X = B  (No transpose)\n*          = 1:  A'* X = B  (Transpose)\n*          = 2:  A'* X = B  (Conjugate transpose = Transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  DL      (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (n-1) multipliers that define the matrix L from the\n*          LU factorization of A.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          The n diagonal elements of the upper triangular matrix U from\n*          the LU factorization of A.\n*\n*  DU      (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (n-1) elements of the first super-diagonal of U.\n*\n*  DU2     (input) DOUBLE PRECISION array, dimension (N-2)\n*          The (n-2) elements of the second super-diagonal of U.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices; for 1 <= i <= n, row i of the matrix was\n*          interchanged with row IPIV(i).  IPIV(i) will always be either\n*          i or i+1; IPIV(i) = i indicates a row interchange was not\n*          required.\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the matrix of right hand side vectors B.\n*          On exit, B is overwritten by the solution vectors X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, IP, J\n      DOUBLE PRECISION   TEMP\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  b = NumRu::Lapack.dgtts2( itrans, dl, d, du, du2, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_itrans = argv[0];
  rblapack_dl = argv[1];
  rblapack_d = argv[2];
  rblapack_du = argv[3];
  rblapack_du2 = argv[4];
  rblapack_ipiv = argv[5];
  rblapack_b = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  itrans = NUM2INT(rblapack_itrans);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_DFLOAT)
    rblapack_dl = na_change_type(rblapack_dl, NA_DFLOAT);
  dl = NA_PTR_TYPE(rblapack_dl, doublereal*);
  if (!NA_IsNArray(rblapack_du2))
    rb_raise(rb_eArgError, "du2 (5th argument) must be NArray");
  if (NA_RANK(rblapack_du2) != 1)
    rb_raise(rb_eArgError, "rank of du2 (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du2) != (n-2))
    rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
  if (NA_TYPE(rblapack_du2) != NA_DFLOAT)
    rblapack_du2 = na_change_type(rblapack_du2, NA_DFLOAT);
  du2 = NA_PTR_TYPE(rblapack_du2, doublereal*);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (4th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_DFLOAT)
    rblapack_du = na_change_type(rblapack_du, NA_DFLOAT);
  du = NA_PTR_TYPE(rblapack_du, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dgtts2_(&itrans, &n, &nrhs, dl, d, du, du2, ipiv, b, &ldb);

  return rblapack_b;
}

void
init_lapack_dgtts2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgtts2", rblapack_dgtts2, -1);
}
ruby-lapack-1.7.2/ext/sggsvd.c0000644000175000017500000003213212502221023016016 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sggsvd_(char* jobu, char* jobv, char* jobq, integer* m, integer* n, integer* p, integer* k, integer* l, real* a, integer* lda, real* b, integer* ldb, real* alpha, real* beta, real* u, integer* ldu, real* v, integer* ldv, real* q, integer* ldq, real* work, integer* iwork, integer* info);


static VALUE
rblapack_sggsvd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobu;
  char jobu; 
  VALUE rblapack_jobv;
  char jobv; 
  VALUE rblapack_jobq;
  char jobq; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_alpha;
  real *alpha; 
  VALUE rblapack_beta;
  real *beta; 
  VALUE rblapack_u;
  real *u; 
  VALUE rblapack_v;
  real *v; 
  VALUE rblapack_q;
  real *q; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_b_out__;
  real *b_out__;
  real *work;

  integer lda;
  integer n;
  integer ldb;
  integer ldu;
  integer m;
  integer ldv;
  integer p;
  integer ldq;

  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  k, l, alpha, beta, u, v, q, iwork, info, a, b = NumRu::Lapack.sggsvd( jobu, jobv, jobq, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGGSVD computes the generalized singular value decomposition (GSVD)\n*  of an M-by-N real matrix A and P-by-N real matrix B:\n*\n*      U'*A*Q = D1*( 0 R ),    V'*B*Q = D2*( 0 R )\n*\n*  where U, V and Q are orthogonal matrices, and Z' is the transpose\n*  of Z.  Let K+L = the effective numerical rank of the matrix (A',B')',\n*  then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and\n*  D2 are M-by-(K+L) and P-by-(K+L) \"diagonal\" matrices and of the\n*  following structures, respectively:\n*\n*  If M-K-L >= 0,\n*\n*                      K  L\n*         D1 =     K ( I  0 )\n*                  L ( 0  C )\n*              M-K-L ( 0  0 )\n*\n*                    K  L\n*         D2 =   L ( 0  S )\n*              P-L ( 0  0 )\n*\n*                  N-K-L  K    L\n*    ( 0 R ) = K (  0   R11  R12 )\n*              L (  0    0   R22 )\n*\n*  where\n*\n*    C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n*    S = diag( BETA(K+1),  ... , BETA(K+L) ),\n*    C**2 + S**2 = I.\n*\n*    R is stored in A(1:K+L,N-K-L+1:N) on exit.\n*\n*  If M-K-L < 0,\n*\n*                    K M-K K+L-M\n*         D1 =   K ( I  0    0   )\n*              M-K ( 0  C    0   )\n*\n*                      K M-K K+L-M\n*         D2 =   M-K ( 0  S    0  )\n*              K+L-M ( 0  0    I  )\n*                P-L ( 0  0    0  )\n*\n*                     N-K-L  K   M-K  K+L-M\n*    ( 0 R ) =     K ( 0    R11  R12  R13  )\n*                M-K ( 0     0   R22  R23  )\n*              K+L-M ( 0     0    0   R33  )\n*\n*  where\n*\n*    C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n*    S = diag( BETA(K+1),  ... , BETA(M) ),\n*    C**2 + S**2 = I.\n*\n*    (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored\n*    ( 0  R22 R23 )\n*    in B(M-K+1:L,N+M-K-L+1:N) on exit.\n*\n*  The routine computes C, S, R, and optionally the orthogonal\n*  transformation matrices U, V and Q.\n*\n*  In particular, if B is an N-by-N nonsingular matrix, then the GSVD of\n*  A and B implicitly gives the SVD of A*inv(B):\n*                       A*inv(B) = U*(D1*inv(D2))*V'.\n*  If ( A',B')' has orthonormal columns, then the GSVD of A and B is\n*  also equal to the CS decomposition of A and B. Furthermore, the GSVD\n*  can be used to derive the solution of the eigenvalue problem:\n*                       A'*A x = lambda* B'*B x.\n*  In some literature, the GSVD of A and B is presented in the form\n*                   U'*A*X = ( 0 D1 ),   V'*B*X = ( 0 D2 )\n*  where U and V are orthogonal and X is nonsingular, D1 and D2 are\n*  ``diagonal''.  The former GSVD form can be converted to the latter\n*  form by taking the nonsingular matrix X as\n*\n*                       X = Q*( I   0    )\n*                             ( 0 inv(R) ).\n*\n\n*  Arguments\n*  =========\n*\n*  JOBU    (input) CHARACTER*1\n*          = 'U':  Orthogonal matrix U is computed;\n*          = 'N':  U is not computed.\n*\n*  JOBV    (input) CHARACTER*1\n*          = 'V':  Orthogonal matrix V is computed;\n*          = 'N':  V is not computed.\n*\n*  JOBQ    (input) CHARACTER*1\n*          = 'Q':  Orthogonal matrix Q is computed;\n*          = 'N':  Q is not computed.\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 matrices A and B.  N >= 0.\n*\n*  P       (input) INTEGER\n*          The number of rows of the matrix B.  P >= 0.\n*\n*  K       (output) INTEGER\n*  L       (output) INTEGER\n*          On exit, K and L specify the dimension of the subblocks\n*          described in the Purpose section.\n*          K + L = effective numerical rank of (A',B')'.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, A contains the triangular matrix R, or part of R.\n*          See Purpose for details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  B       (input/output) REAL array, dimension (LDB,N)\n*          On entry, the P-by-N matrix B.\n*          On exit, B contains the triangular matrix R if M-K-L < 0.\n*          See Purpose for details.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,P).\n*\n*  ALPHA   (output) REAL array, dimension (N)\n*  BETA    (output) REAL array, dimension (N)\n*          On exit, ALPHA and BETA contain the generalized singular\n*          value pairs of A and B;\n*            ALPHA(1:K) = 1,\n*            BETA(1:K)  = 0,\n*          and if M-K-L >= 0,\n*            ALPHA(K+1:K+L) = C,\n*            BETA(K+1:K+L)  = S,\n*          or if M-K-L < 0,\n*            ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0\n*            BETA(K+1:M) =S, BETA(M+1:K+L) =1\n*          and\n*            ALPHA(K+L+1:N) = 0\n*            BETA(K+L+1:N)  = 0\n*\n*  U       (output) REAL array, dimension (LDU,M)\n*          If JOBU = 'U', U contains the M-by-M orthogonal matrix U.\n*          If JOBU = 'N', U is not referenced.\n*\n*  LDU     (input) INTEGER\n*          The leading dimension of the array U. LDU >= max(1,M) if\n*          JOBU = 'U'; LDU >= 1 otherwise.\n*\n*  V       (output) REAL array, dimension (LDV,P)\n*          If JOBV = 'V', V contains the P-by-P orthogonal matrix V.\n*          If JOBV = 'N', V is not referenced.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V. LDV >= max(1,P) if\n*          JOBV = 'V'; LDV >= 1 otherwise.\n*\n*  Q       (output) REAL array, dimension (LDQ,N)\n*          If JOBQ = 'Q', Q contains the N-by-N orthogonal matrix Q.\n*          If JOBQ = 'N', Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q. LDQ >= max(1,N) if\n*          JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n*  WORK    (workspace) REAL array,\n*                      dimension (max(3*N,M,P)+N)\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (N)\n*          On exit, IWORK stores the sorting information. More\n*          precisely, the following loop will sort ALPHA\n*             for I = K+1, min(M,K+L)\n*                 swap ALPHA(I) and ALPHA(IWORK(I))\n*             endfor\n*          such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N).\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 = 1, the Jacobi-type procedure failed to\n*                converge.  For further details, see subroutine STGSJA.\n*\n*  Internal Parameters\n*  ===================\n*\n*  TOLA    REAL\n*  TOLB    REAL\n*          TOLA and TOLB are the thresholds to determine the effective\n*          rank of (A',B')'. Generally, they are set to\n*                   TOLA = MAX(M,N)*norm(A)*MACHEPS,\n*                   TOLB = MAX(P,N)*norm(B)*MACHEPS.\n*          The size of TOLA and TOLB may affect the size of backward\n*          errors of the decomposition.\n*\n\n*  Further Details\n*  ===============\n*\n*  2-96 Based on modifications by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            WANTQ, WANTU, WANTV\n      INTEGER            I, IBND, ISUB, J, NCYCLE\n      REAL               ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      REAL               SLAMCH, SLANGE\n      EXTERNAL           LSAME, SLAMCH, SLANGE\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SCOPY, SGGSVP, STGSJA, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  k, l, alpha, beta, u, v, q, iwork, info, a, b = NumRu::Lapack.sggsvd( jobu, jobv, jobq, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_jobu = argv[0];
  rblapack_jobv = argv[1];
  rblapack_jobq = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobu = StringValueCStr(rblapack_jobu)[0];
  jobq = StringValueCStr(rblapack_jobq)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  p = ldb;
  jobv = StringValueCStr(rblapack_jobv)[0];
  ldv = lsame_(&jobv,"V") ? MAX(1,p) : 1;
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  ldq = lsame_(&jobq,"Q") ? MAX(1,n) : 1;
  m = lda;
  ldu = lsame_(&jobu,"U") ? MAX(1,m) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alpha = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  alpha = NA_PTR_TYPE(rblapack_alpha, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = m;
    rblapack_u = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  u = NA_PTR_TYPE(rblapack_u, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = p;
    rblapack_v = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  v = NA_PTR_TYPE(rblapack_v, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  q = NA_PTR_TYPE(rblapack_q, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(real, (MAX(3*n,m)*(p)+n));

  sggsvd_(&jobu, &jobv, &jobq, &m, &n, &p, &k, &l, a, &lda, b, &ldb, alpha, beta, u, &ldu, v, &ldv, q, &ldq, work, iwork, &info);

  free(work);
  rblapack_k = INT2NUM(k);
  rblapack_l = INT2NUM(l);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(11, rblapack_k, rblapack_l, rblapack_alpha, rblapack_beta, rblapack_u, rblapack_v, rblapack_q, rblapack_iwork, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_sggsvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sggsvd", rblapack_sggsvd, -1);
}
ruby-lapack-1.7.2/ext/dgeqrfp.c0000644000175000017500000001345612502221022016160 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgeqrfp_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dgeqrfp(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.dgeqrfp( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGEQRFP computes a QR factorization of a real M-by-N matrix A:\n*  A = Q * R.\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 above the diagonal of the array\n*          contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n*          upper triangular if m >= n); the elements below the diagonal,\n*          with the array TAU, represent the orthogonal matrix Q as a\n*          product of min(m,n) elementary reflectors (see Further\n*          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,N).\n*          For optimum performance LWORK >= N*NB, where NB is\n*          the 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(1) H(2) . . . H(k), 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:m) is stored on exit in A(i+1:m,i),\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           DGEQR2P, 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.dgeqrfp( 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;
  }

  m = NUM2INT(rblapack_m);
  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*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;

  dgeqrfp_(&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_dgeqrfp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgeqrfp", rblapack_dgeqrfp, -1);
}
ruby-lapack-1.7.2/ext/spttrs.c0000644000175000017500000001167212502221024016067 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID spttrs_(integer* n, integer* nrhs, real* d, real* e, real* b, integer* ldb, integer* info);


static VALUE
rblapack_spttrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  real *b_out__;

  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.spttrs( d, e, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPTTRS( N, NRHS, D, E, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPTTRS solves a tridiagonal system of the form\n*     A * X = B\n*  using the L*D*L' factorization of A computed by SPTTRF.  D is a\n*  diagonal matrix specified in the vector D, L is a unit bidiagonal\n*  matrix whose subdiagonal is specified in the vector E, and X and B\n*  are N by NRHS matrices.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the tridiagonal matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  D       (input) REAL array, dimension (N)\n*          The n diagonal elements of the diagonal matrix D from the\n*          L*D*L' factorization of A.\n*\n*  E       (input) REAL array, dimension (N-1)\n*          The (n-1) subdiagonal elements of the unit bidiagonal factor\n*          L from the L*D*L' factorization of A.  E can also be regarded\n*          as the superdiagonal of the unit bidiagonal factor U from the\n*          factorization A = U'*D*U.\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the right hand side vectors B for the system of\n*          linear equations.\n*          On exit, the solution vectors, X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            J, JB, NB\n*     ..\n*     .. External Functions ..\n      INTEGER            ILAENV\n      EXTERNAL           ILAENV\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SPTTS2, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.spttrs( d, e, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_d = argv[0];
  rblapack_e = argv[1];
  rblapack_b = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  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);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (2th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  spttrs_(&n, &nrhs, d, e, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_spttrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "spttrs", rblapack_spttrs, -1);
}
ruby-lapack-1.7.2/ext/zheevr.c0000644000175000017500000004106112502221021016023 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zheevr_(char* jobz, char* range, char* uplo, integer* n, doublecomplex* a, integer* lda, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublecomplex* z, integer* ldz, integer* isuppz, doublecomplex* work, integer* lwork, doublereal* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_zheevr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_vl;
  doublereal vl; 
  VALUE rblapack_vu;
  doublereal vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  doublereal abstol; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_lrwork;
  integer lrwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_isuppz;
  integer *isuppz; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_rwork;
  doublereal *rwork; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;

  integer lda;
  integer n;
  integer ldz;

  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  m, w, z, isuppz, work, rwork, iwork, info, a = NumRu::Lapack.zheevr( jobz, range, uplo, a, vl, vu, il, iu, abstol, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHEEVR computes selected eigenvalues and, optionally, eigenvectors\n*  of a complex Hermitian matrix A.  Eigenvalues and eigenvectors can\n*  be selected by specifying either a range of values or a range of\n*  indices for the desired eigenvalues.\n*\n*  ZHEEVR first reduces the matrix A to tridiagonal form T with a call\n*  to ZHETRD.  Then, whenever possible, ZHEEVR calls ZSTEMR to compute\n*  eigenspectrum using Relatively Robust Representations.  ZSTEMR\n*  computes eigenvalues by the dqds algorithm, while orthogonal\n*  eigenvectors are computed from various \"good\" L D L^T representations\n*  (also known as Relatively Robust Representations). Gram-Schmidt\n*  orthogonalization is avoided as far as possible. More specifically,\n*  the various steps of the algorithm are as follows.\n*\n*  For each unreduced block (submatrix) of T,\n*     (a) Compute T - sigma I  = L D L^T, so that L and D\n*         define all the wanted eigenvalues to high relative accuracy.\n*         This means that small relative changes in the entries of D and L\n*         cause only small relative changes in the eigenvalues and\n*         eigenvectors. The standard (unfactored) representation of the\n*         tridiagonal matrix T does not have this property in general.\n*     (b) Compute the eigenvalues to suitable accuracy.\n*         If the eigenvectors are desired, the algorithm attains full\n*         accuracy of the computed eigenvalues only right before\n*         the corresponding vectors have to be computed, see steps c) and d).\n*     (c) For each cluster of close eigenvalues, select a new\n*         shift close to the cluster, find a new factorization, and refine\n*         the shifted eigenvalues to suitable accuracy.\n*     (d) For each eigenvalue with a large enough relative separation compute\n*         the corresponding eigenvector by forming a rank revealing twisted\n*         factorization. Go back to (c) for any clusters that remain.\n*\n*  The desired accuracy of the output can be specified by the input\n*  parameter ABSTOL.\n*\n*  For more details, see DSTEMR's documentation and:\n*  - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n*    to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n*    Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n*  - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n*    Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n*    2004.  Also LAPACK Working Note 154.\n*  - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n*    tridiagonal eigenvalue/eigenvector problem\",\n*    Computer Science Division Technical Report No. UCB/CSD-97-971,\n*    UC Berkeley, May 1997.\n*\n*\n*  Note 1 : ZHEEVR calls ZSTEMR when the full spectrum is requested\n*  on machines which conform to the ieee-754 floating point standard.\n*  ZHEEVR calls DSTEBZ and ZSTEIN on non-ieee machines and\n*  when partial spectrum requests are made.\n*\n*  Normal execution of ZSTEMR may create NaNs and infinities and\n*  hence may abort due to a floating point exception in environments\n*  which do not handle NaNs and infinities in the ieee standard default\n*  manner.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found.\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found.\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n********** For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and\n********** ZSTEIN are called\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA, N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of A contains the\n*          upper triangular part of the matrix A.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of A contains\n*          the lower triangular part of the matrix A.\n*          On exit, the lower triangle (if UPLO='L') or the upper\n*          triangle (if UPLO='U') of A, including the diagonal, is\n*          destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  VL      (input) DOUBLE PRECISION\n*  VU      (input) DOUBLE PRECISION\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) DOUBLE PRECISION\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less than\n*          or equal to zero, then  EPS*|T|  will be used in its place,\n*          where |T| is the 1-norm of the tridiagonal matrix obtained\n*          by reducing A to tridiagonal form.\n*\n*          See \"Computing Small Singular Values of Bidiagonal Matrices\n*          with Guaranteed High Relative Accuracy,\" by Demmel and\n*          Kahan, LAPACK Working Note #3.\n*\n*          If high relative accuracy is important, set ABSTOL to\n*          DLAMCH( 'Safe minimum' ).  Doing so will guarantee that\n*          eigenvalues are computed to high relative accuracy when\n*          possible in future releases.  The current code does not\n*          make any guarantees about high relative accuracy, but\n*          furutre releases will. See J. Barlow and J. Demmel,\n*          \"Computing Accurate Eigensystems of Scaled Diagonally\n*          Dominant Matrices\", LAPACK Working Note #7, for a discussion\n*          of which matrices define their eigenvalues to high relative\n*          accuracy.\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          The first M elements contain the selected eigenvalues in\n*          ascending order.\n*\n*  Z       (output) COMPLEX*16 array, dimension (LDZ, max(1,M))\n*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix A\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  ISUPPZ  (output) INTEGER array, dimension ( 2*max(1,M) )\n*          The support of the eigenvectors in Z, i.e., the indices\n*          indicating the nonzero elements in Z. The i-th eigenvector\n*          is nonzero only in elements ISUPPZ( 2*i-1 ) through\n*          ISUPPZ( 2*i ).\n********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1\n*\n*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of the array WORK.  LWORK >= max(1,2*N).\n*          For optimal efficiency, LWORK >= (NB+1)*N,\n*          where NB is the max of the blocksize for ZHETRD and for\n*          ZUNMTR as returned by ILAENV.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal sizes of the WORK, RWORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  RWORK   (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))\n*          On exit, if INFO = 0, RWORK(1) returns the optimal\n*          (and minimal) LRWORK.\n*\n* LRWORK   (input) INTEGER\n*          The length of the array RWORK.  LRWORK >= max(1,24*N).\n*\n*          If LRWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal\n*          (and minimal) LIWORK.\n*\n* LIWORK   (input) INTEGER\n*          The dimension of the array IWORK.  LIWORK >= max(1,10*N).\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK 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:  Internal error\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Inderjit Dhillon, IBM Almaden, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Ken Stanley, Computer Science Division, University of\n*       California at Berkeley, USA\n*     Jason Riedy, Computer Science Division, University of\n*       California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, isuppz, work, rwork, iwork, info, a = NumRu::Lapack.zheevr( jobz, range, uplo, a, vl, vu, il, iu, abstol, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_uplo = argv[2];
  rblapack_a = argv[3];
  rblapack_vl = argv[4];
  rblapack_vu = argv[5];
  rblapack_il = argv[6];
  rblapack_iu = argv[7];
  rblapack_abstol = argv[8];
  if (argc == 12) {
    rblapack_lwork = argv[9];
    rblapack_lrwork = argv[10];
    rblapack_liwork = argv[11];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_lrwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  vl = NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  abstol = NUM2DBL(rblapack_abstol);
  range = StringValueCStr(rblapack_range)[0];
  vu = NUM2DBL(rblapack_vu);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (rblapack_lwork == Qnil)
    lwork = 2*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (rblapack_liwork == Qnil)
    liwork = 10*n;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  iu = NUM2INT(rblapack_iu);
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  if (rblapack_lrwork == Qnil)
    lrwork = 24*n;
  else {
    lrwork = NUM2INT(rblapack_lrwork);
  }
  m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = 2*MAX(1,m);
    rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lrwork);
    rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zheevr_(&jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, isuppz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);

  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_m, rblapack_w, rblapack_z, rblapack_isuppz, rblapack_work, rblapack_rwork, rblapack_iwork, rblapack_info, rblapack_a);
}

void
init_lapack_zheevr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zheevr", rblapack_zheevr, -1);
}
ruby-lapack-1.7.2/ext/zpoequ.c0000644000175000017500000001012212502221014016037 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zpoequ_(integer* n, doublecomplex* a, integer* lda, doublereal* s, doublereal* scond, doublereal* amax, integer* info);


static VALUE
rblapack_zpoequ(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_scond;
  doublereal scond; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_info;
  integer info; 

  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  s, scond, amax, info = NumRu::Lapack.zpoequ( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPOEQU computes row and column scalings intended to equilibrate a\n*  Hermitian positive definite matrix A and reduce its condition number\n*  (with respect to the two-norm).  S contains the scale factors,\n*  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n*  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This\n*  choice of S puts the condition number of B within a factor N of the\n*  smallest possible condition number over all possible diagonal\n*  scalings.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          The N-by-N Hermitian positive definite matrix whose scaling\n*          factors are to be computed.  Only the diagonal elements of A\n*          are referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  S       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, S contains the scale factors for A.\n*\n*  SCOND   (output) DOUBLE PRECISION\n*          If INFO = 0, S contains the ratio of the smallest S(i) to\n*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too\n*          large nor too small, it is not worth scaling by S.\n*\n*  AMAX    (output) DOUBLE PRECISION\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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 is nonpositive.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, scond, amax, info = NumRu::Lapack.zpoequ( 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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, doublereal*);

  zpoequ_(&n, a, &lda, s, &scond, &amax, &info);

  rblapack_scond = rb_float_new((double)scond);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
}

void
init_lapack_zpoequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zpoequ", rblapack_zpoequ, -1);
}
ruby-lapack-1.7.2/ext/cunmrq.c0000644000175000017500000001611412502221022016027 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cunmrq_(char* side, char* trans, integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* c, integer* ldc, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_cunmrq(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_c;
  complex *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  complex *c_out__;

  integer lda;
  integer m;
  integer k;
  integer ldc;
  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  work, info, c = NumRu::Lapack.cunmrq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CUNMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CUNMRQ overwrites the general complex M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'C':      Q**H * C       C * Q**H\n*\n*  where Q is a complex unitary matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(1)' H(2)' . . . H(k)'\n*\n*  as returned by CGERQF. Q is of order M if SIDE = 'L' and of order N\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**H from the Left;\n*          = 'R': apply Q or Q**H from the Right.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'C':  Transpose, apply Q**H.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) COMPLEX array, dimension\n*                               (LDA,M) if SIDE = 'L',\n*                               (LDA,N) if SIDE = 'R'\n*          The i-th row must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          CGERQF in the last k rows of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,K).\n*\n*  TAU     (input) COMPLEX array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by CGERQF.\n*\n*  C       (input/output) COMPLEX array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace/output) COMPLEX 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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M).\n*          For optimum performance LWORK >= N*NB if SIDE = 'L', and\n*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n*          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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.cunmrq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_a = argv[2];
  rblapack_tau = argv[3];
  rblapack_c = argv[4];
  if (argc == 6) {
    rblapack_lwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, complex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
  MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  cunmrq_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_cunmrq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cunmrq", rblapack_cunmrq, -1);
}
ruby-lapack-1.7.2/ext/dla_wwaddw.c0000644000175000017500000001031112502221022016630 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dla_wwaddw_(integer* n, doublereal* x, doublereal* y, doublereal* w);


static VALUE
rblapack_dla_wwaddw(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_y;
  doublereal *y; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_x_out__;
  doublereal *x_out__;
  VALUE rblapack_y_out__;
  doublereal *y_out__;

  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  x, y = NumRu::Lapack.dla_wwaddw( x, y, w, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLA_WWADDW( N, X, Y, W )\n\n*     Purpose\n*     =======\n*\n*     DLA_WWADDW adds a vector W into a doubled-single vector (X, Y).\n*\n*     This works for all extant IBM's hex and binary floating point\n*     arithmetics, but not for decimal.\n*\n\n*     Arguments\n*     =========\n*\n*     N      (input) INTEGER\n*            The length of vectors X, Y, and W.\n*\n*     X      (input/output) DOUBLE PRECISION array, dimension (N)\n*            The first part of the doubled-single accumulation vector.\n*\n*     Y      (input/output) DOUBLE PRECISION array, dimension (N)\n*            The second part of the doubled-single accumulation vector.\n*\n*     W      (input) DOUBLE PRECISION array, dimension (N)\n*            The vector to be added.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      DOUBLE PRECISION   S\n      INTEGER            I\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, y = NumRu::Lapack.dla_wwaddw( x, y, w, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_x = argv[0];
  rblapack_y = argv[1];
  rblapack_w = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (1th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  if (!NA_IsNArray(rblapack_w))
    rb_raise(rb_eArgError, "w (3th argument) must be NArray");
  if (NA_RANK(rblapack_w) != 1)
    rb_raise(rb_eArgError, "rank of w (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_w) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of x");
  if (NA_TYPE(rblapack_w) != NA_DFLOAT)
    rblapack_w = na_change_type(rblapack_w, NA_DFLOAT);
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (2th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of y must be the same as shape 0 of x");
  if (NA_TYPE(rblapack_y) != NA_DFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
  y = NA_PTR_TYPE(rblapack_y, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
  MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  dla_wwaddw_(&n, x, y, w);

  return rb_ary_new3(2, rblapack_x, rblapack_y);
}

void
init_lapack_dla_wwaddw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dla_wwaddw", rblapack_dla_wwaddw, -1);
}
ruby-lapack-1.7.2/ext/clarnv.c0000644000175000017500000000762412502221021016014 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clarnv_(integer* idist, integer* iseed, integer* n, complex* x);


static VALUE
rblapack_clarnv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_idist;
  integer idist; 
  VALUE rblapack_iseed;
  integer *iseed; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_iseed_out__;
  integer *iseed_out__;


  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  x, iseed = NumRu::Lapack.clarnv( idist, iseed, n, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLARNV( IDIST, ISEED, N, X )\n\n*  Purpose\n*  =======\n*\n*  CLARNV returns a vector of n random complex numbers from a uniform or\n*  normal distribution.\n*\n\n*  Arguments\n*  =========\n*\n*  IDIST   (input) INTEGER\n*          Specifies the distribution of the random numbers:\n*          = 1:  real and imaginary parts each uniform (0,1)\n*          = 2:  real and imaginary parts each uniform (-1,1)\n*          = 3:  real and imaginary parts each normal (0,1)\n*          = 4:  uniformly distributed on the disc abs(z) < 1\n*          = 5:  uniformly distributed on the circle abs(z) = 1\n*\n*  ISEED   (input/output) INTEGER array, dimension (4)\n*          On entry, the seed of the random number generator; the array\n*          elements must be between 0 and 4095, and ISEED(4) must be\n*          odd.\n*          On exit, the seed is updated.\n*\n*  N       (input) INTEGER\n*          The number of random numbers to be generated.\n*\n*  X       (output) COMPLEX array, dimension (N)\n*          The generated random numbers.\n*\n\n*  Further Details\n*  ===============\n*\n*  This routine calls the auxiliary routine SLARUV to generate random\n*  real numbers from a uniform (0,1) distribution, in batches of up to\n*  128 using vectorisable code. The Box-Muller method is used to\n*  transform numbers from a uniform to a normal distribution.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, iseed = NumRu::Lapack.clarnv( idist, iseed, n, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_idist = argv[0];
  rblapack_iseed = argv[1];
  rblapack_n = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  idist = NUM2INT(rblapack_idist);
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_iseed))
    rb_raise(rb_eArgError, "iseed (2th argument) must be NArray");
  if (NA_RANK(rblapack_iseed) != 1)
    rb_raise(rb_eArgError, "rank of iseed (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_iseed) != (4))
    rb_raise(rb_eRuntimeError, "shape 0 of iseed must be %d", 4);
  if (NA_TYPE(rblapack_iseed) != NA_LINT)
    rblapack_iseed = na_change_type(rblapack_iseed, NA_LINT);
  iseed = NA_PTR_TYPE(rblapack_iseed, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,n);
    rblapack_x = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[1];
    shape[0] = 4;
    rblapack_iseed_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iseed_out__ = NA_PTR_TYPE(rblapack_iseed_out__, integer*);
  MEMCPY(iseed_out__, iseed, integer, NA_TOTAL(rblapack_iseed));
  rblapack_iseed = rblapack_iseed_out__;
  iseed = iseed_out__;

  clarnv_(&idist, iseed, &n, x);

  return rb_ary_new3(2, rblapack_x, rblapack_iseed);
}

void
init_lapack_clarnv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clarnv", rblapack_clarnv, -1);
}
ruby-lapack-1.7.2/ext/cung2l.c0000644000175000017500000001041412502221015015713 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cung2l_(integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* work, integer* info);


static VALUE
rblapack_cung2l(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  complex *work;

  integer lda;
  integer n;
  integer k;

  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  info, a = NumRu::Lapack.cung2l( m, a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CUNG2L( M, N, K, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CUNG2L generates an m by n complex matrix Q with orthonormal columns,\n*  which is defined as the last n columns of a product of k elementary\n*  reflectors of order m\n*\n*        Q  =  H(k) . . . H(2) H(1)\n*\n*  as returned by CGEQLF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. M >= N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. N >= K >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the (n-k+i)-th column must contain the vector which\n*          defines the elementary reflector H(i), for i = 1,2,...,k, as\n*          returned by CGEQLF in the last k columns of its array\n*          argument A.\n*          On exit, the m-by-n matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) COMPLEX array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by CGEQLF.\n*\n*  WORK    (workspace) COMPLEX array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -i, the i-th argument has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.cung2l( m, a, tau, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  rblapack_tau = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(complex, (n));

  cung2l_(&m, &n, &k, a, &lda, tau, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_cung2l(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cung2l", rblapack_cung2l, -1);
}
ruby-lapack-1.7.2/ext/ilaver.c0000644000175000017500000000455512502221012016011 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ilaver_(integer* vers_major, integer* vers_minor, integer* vers_patch);


static VALUE
rblapack_ilaver(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_vers_major;
  integer vers_major; 
  VALUE rblapack_vers_minor;
  integer vers_minor; 
  VALUE rblapack_vers_patch;
  integer vers_patch; 


  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  vers_major, vers_minor, vers_patch = NumRu::Lapack.ilaver( , [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH )\n\n*  Purpose\n*  =======\n*\n*  This subroutine return the Lapack version.\n*\n\n*  Arguments\n*  =========\n*  VERS_MAJOR   (output) INTEGER\n*      return the lapack major version\n*  VERS_MINOR   (output) INTEGER\n*      return the lapack minor version from the major version\n*  VERS_PATCH   (output) INTEGER\n*      return the lapack patch version from the minor version\n\n*  =====================================================================\n*\n      INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH\n*  =====================================================================\n      VERS_MAJOR = 3\n      VERS_MINOR = 3\n      VERS_PATCH = 0\n*  =====================================================================\n*\n      RETURN\n      END\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  vers_major, vers_minor, vers_patch = NumRu::Lapack.ilaver( , [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 0 && argc != 0)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 0)", argc);
  if (argc == 0) {
  } else if (rblapack_options != Qnil) {
  } else {
  }


  ilaver_(&vers_major, &vers_minor, &vers_patch);

  rblapack_vers_major = INT2NUM(vers_major);
  rblapack_vers_minor = INT2NUM(vers_minor);
  rblapack_vers_patch = INT2NUM(vers_patch);
  return rb_ary_new3(3, rblapack_vers_major, rblapack_vers_minor, rblapack_vers_patch);
}

void
init_lapack_ilaver(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ilaver", rblapack_ilaver, -1);
}
ruby-lapack-1.7.2/ext/zgbbrd.c0000644000175000017500000002012412502221020015766 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgbbrd_(char* vect, integer* m, integer* n, integer* ncc, integer* kl, integer* ku, doublecomplex* ab, integer* ldab, doublereal* d, doublereal* e, doublecomplex* q, integer* ldq, doublecomplex* pt, integer* ldpt, doublecomplex* c, integer* ldc, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zgbbrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_vect;
  char vect; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_c;
  doublecomplex *c; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_q;
  doublecomplex *q; 
  VALUE rblapack_pt;
  doublecomplex *pt; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublecomplex *ab_out__;
  VALUE rblapack_c_out__;
  doublecomplex *c_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer ldab;
  integer n;
  integer ldc;
  integer ncc;
  integer ldq;
  integer m;
  integer ldpt;

  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  d, e, q, pt, info, ab, c = NumRu::Lapack.zgbbrd( vect, kl, ku, ab, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, LDQ, PT, LDPT, C, LDC, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGBBRD reduces a complex general m-by-n band matrix A to real upper\n*  bidiagonal form B by a unitary transformation: Q' * A * P = B.\n*\n*  The routine computes B, and optionally forms Q or P', or computes\n*  Q'*C for a given matrix C.\n*\n\n*  Arguments\n*  =========\n*\n*  VECT    (input) CHARACTER*1\n*          Specifies whether or not the matrices Q and P' are to be\n*          formed.\n*          = 'N': do not form Q or P';\n*          = 'Q': form Q only;\n*          = 'P': form P' only;\n*          = 'B': form both.\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*  NCC     (input) INTEGER\n*          The number of columns of the matrix C.  NCC >= 0.\n*\n*  KL      (input) INTEGER\n*          The number of subdiagonals of the matrix A. KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals of the matrix A. KU >= 0.\n*\n*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)\n*          On entry, the m-by-n band matrix A, stored in rows 1 to\n*          KL+KU+1. The j-th column of A is stored in the j-th column of\n*          the array AB as follows:\n*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n*          On exit, A is overwritten by values generated during the\n*          reduction.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array A. LDAB >= KL+KU+1.\n*\n*  D       (output) DOUBLE PRECISION array, dimension (min(M,N))\n*          The diagonal elements of the bidiagonal matrix B.\n*\n*  E       (output) DOUBLE PRECISION array, dimension (min(M,N)-1)\n*          The superdiagonal elements of the bidiagonal matrix B.\n*\n*  Q       (output) COMPLEX*16 array, dimension (LDQ,M)\n*          If VECT = 'Q' or 'B', the m-by-m unitary matrix Q.\n*          If VECT = 'N' or 'P', the array Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.\n*          LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.\n*\n*  PT      (output) COMPLEX*16 array, dimension (LDPT,N)\n*          If VECT = 'P' or 'B', the n-by-n unitary matrix P'.\n*          If VECT = 'N' or 'Q', the array PT is not referenced.\n*\n*  LDPT    (input) INTEGER\n*          The leading dimension of the array PT.\n*          LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.\n*\n*  C       (input/output) COMPLEX*16 array, dimension (LDC,NCC)\n*          On entry, an m-by-ncc matrix C.\n*          On exit, C is overwritten by Q'*C.\n*          C is not referenced if NCC = 0.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C.\n*          LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (max(M,N))\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (max(M,N))\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, q, pt, info, ab, c = NumRu::Lapack.zgbbrd( vect, kl, ku, ab, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_vect = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  rblapack_c = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  vect = StringValueCStr(rblapack_vect)[0];
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  ncc = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  ldpt = ((lsame_(&vect,"P")) || (lsame_(&vect,"B"))) ? MAX(1,n) : 1;
  m = ldab;
  ldq = ((lsame_(&vect,"Q")) || (lsame_(&vect,"B"))) ? MAX(1,m) : 1;
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n)-1;
    rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = m;
    rblapack_q = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldpt;
    shape[1] = n;
    rblapack_pt = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  pt = NA_PTR_TYPE(rblapack_pt, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
  MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = ncc;
    rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
  MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(doublecomplex, (MAX(m,n)));
  rwork = ALLOC_N(doublereal, (MAX(m,n)));

  zgbbrd_(&vect, &m, &n, &ncc, &kl, &ku, ab, &ldab, d, e, q, &ldq, pt, &ldpt, c, &ldc, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_d, rblapack_e, rblapack_q, rblapack_pt, rblapack_info, rblapack_ab, rblapack_c);
}

void
init_lapack_zgbbrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgbbrd", rblapack_zgbbrd, -1);
}
ruby-lapack-1.7.2/ext/zgbrfs.c0000644000175000017500000002266212502221021016023 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgbrfs_(char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, doublecomplex* ab, integer* ldab, doublecomplex* afb, integer* ldafb, integer* ipiv, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zgbrfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_afb;
  doublecomplex *afb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer ldab;
  integer n;
  integer ldafb;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.zgbrfs( trans, kl, ku, ab, afb, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGBRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is banded, and provides\n*  error bounds and backward error estimates for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)\n*          The original band matrix A, stored in rows 1 to KL+KU+1.\n*          The j-th column of A is stored in the j-th column of the\n*          array AB as follows:\n*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*  AFB     (input) COMPLEX*16 array, dimension (LDAFB,N)\n*          Details of the LU factorization of the band matrix A, as\n*          computed by ZGBTRF.  U is stored as an upper triangular band\n*          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n*          the multipliers used during the factorization are stored in\n*          rows KL+KU+2 to 2*KL+KU+1.\n*\n*  LDAFB   (input) INTEGER\n*          The leading dimension of the array AFB.  LDAFB >= 2*KL*KU+1.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices from ZGBTRF; for 1<=i<=N, row i of the\n*          matrix was interchanged with row IPIV(i).\n*\n*  B       (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) COMPLEX*16 array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by ZGBTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.zgbrfs( trans, kl, ku, ab, afb, ipiv, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_trans = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  rblapack_afb = argv[4];
  rblapack_ipiv = argv[5];
  rblapack_b = argv[6];
  rblapack_x = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
  ldafb = NA_SHAPE0(rblapack_afb);
  n = NA_SHAPE1(rblapack_afb);
  if (NA_TYPE(rblapack_afb) != NA_DCOMPLEX)
    rblapack_afb = na_change_type(rblapack_afb, NA_DCOMPLEX);
  afb = NA_PTR_TYPE(rblapack_afb, doublecomplex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (8th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (8th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (n));

  zgbrfs_(&trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_zgbrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgbrfs", rblapack_zgbrfs, -1);
}
ruby-lapack-1.7.2/ext/chptrd.c0000644000175000017500000001362112502221021016005 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chptrd_(char* uplo, integer* n, complex* ap, real* d, real* e, complex* tau, integer* info);


static VALUE
rblapack_chptrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  complex *ap_out__;

  integer ldap;
  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  d, e, tau, info, ap = NumRu::Lapack.chptrd( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHPTRD( UPLO, N, AP, D, E, TAU, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHPTRD reduces a complex Hermitian matrix A stored in packed form to\n*  real symmetric tridiagonal form T by a unitary similarity\n*  transformation: Q**H * A * Q = T.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*          On exit, if UPLO = 'U', the diagonal and first superdiagonal\n*          of A are overwritten by the corresponding elements of the\n*          tridiagonal matrix T, and the elements above the first\n*          superdiagonal, with the array TAU, represent the unitary\n*          matrix Q as a product of elementary reflectors; if UPLO\n*          = 'L', the diagonal and first subdiagonal of A are over-\n*          written by the corresponding elements of the tridiagonal\n*          matrix T, and the elements below the first subdiagonal, with\n*          the array TAU, represent the unitary matrix Q as a product\n*          of elementary reflectors. See Further Details.\n*\n*  D       (output) REAL array, dimension (N)\n*          The diagonal elements of the tridiagonal matrix T:\n*          D(i) = A(i,i).\n*\n*  E       (output) REAL array, dimension (N-1)\n*          The off-diagonal elements of the tridiagonal matrix T:\n*          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n*  TAU     (output) COMPLEX array, dimension (N-1)\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\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*  If UPLO = 'U', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(n-1) . . . H(2) H(1).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - tau * v * v'\n*\n*  where tau is a complex scalar, and v is a complex vector with\n*  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,\n*  overwriting A(1:i-1,i+1), and tau is stored in TAU(i).\n*\n*  If UPLO = 'L', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(1) H(2) . . . H(n-1).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - tau * v * v'\n*\n*  where tau is a complex scalar, and v is a complex vector with\n*  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,\n*  overwriting A(i+2:n,i), and tau is stored in TAU(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, tau, info, ap = NumRu::Lapack.chptrd( uplo, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, real*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
  MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  chptrd_(&uplo, &n, ap, d, e, tau, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_d, rblapack_e, rblapack_tau, rblapack_info, rblapack_ap);
}

void
init_lapack_chptrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chptrd", rblapack_chptrd, -1);
}
ruby-lapack-1.7.2/ext/cheev.c0000644000175000017500000001337212502221013015617 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cheev_(char* jobz, char* uplo, integer* n, complex* a, integer* lda, real* w, complex* work, integer* lwork, real* rwork, integer* info);


static VALUE
rblapack_cheev(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  real *rwork;

  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  w, work, info, a = NumRu::Lapack.cheev( jobz, uplo, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHEEV computes all eigenvalues and, optionally, eigenvectors of a\n*  complex Hermitian matrix A.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA, N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of A contains the\n*          upper triangular part of the matrix A.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of A contains\n*          the lower triangular part of the matrix A.\n*          On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n*          orthonormal eigenvectors of the matrix A.\n*          If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n*          or the upper triangle (if UPLO='U') of A, including the\n*          diagonal, is destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  W       (output) REAL array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  WORK    (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of the array WORK.  LWORK >= max(1,2*N-1).\n*          For optimal efficiency, LWORK >= (NB+1)*N,\n*          where NB is the blocksize for CHETRD returned by ILAENV.\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*  RWORK   (workspace) REAL array, dimension (max(1, 3*N-2))\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 algorithm failed to converge; i\n*                off-diagonal elements of an intermediate tridiagonal\n*                form did not converge to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, work, info, a = NumRu::Lapack.cheev( jobz, uplo, a, [: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_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = 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;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (rblapack_lwork == Qnil)
    lwork = 2*n-1;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  rwork = ALLOC_N(real, (MAX(1, 3*n-2)));

  cheev_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, rwork, &info);

  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_w, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_cheev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cheev", rblapack_cheev, -1);
}
ruby-lapack-1.7.2/ext/dlanhs.c0000644000175000017500000000732612502221015016002 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal dlanhs_(char* norm, integer* n, doublereal* a, integer* lda, doublereal* work);


static VALUE
rblapack_dlanhs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack___out__;
  doublereal __out__; 
  doublereal *work;

  integer lda;
  integer n;
  integer lwork;

  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  __out__ = NumRu::Lapack.dlanhs( norm, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK )\n\n*  Purpose\n*  =======\n*\n*  DLANHS  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  Hessenberg matrix A.\n*\n*  Description\n*  ===========\n*\n*  DLANHS returns the value\n*\n*     DLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in DLANHS as described\n*          above.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, DLANHS is\n*          set to zero.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*          The n by n upper Hessenberg matrix A; the part of A below the\n*          first sub-diagonal is not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(N,1).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n*          referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.dlanhs( norm, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_norm = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  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*);
  lwork = lsame_(&norm,"I") ? n : 0;
  work = ALLOC_N(doublereal, (MAX(1,lwork)));

  __out__ = dlanhs_(&norm, &n, a, &lda, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_dlanhs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlanhs", rblapack_dlanhs, -1);
}
ruby-lapack-1.7.2/ext/dgbcon.c0000644000175000017500000001270012502221023015754 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgbcon_(char* norm, integer* n, integer* kl, integer* ku, doublereal* ab, integer* ldab, integer* ipiv, doublereal* anorm, doublereal* rcond, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dgbcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_anorm;
  doublereal anorm; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_info;
  integer info; 
  doublereal *work;
  integer *iwork;

  integer ldab;
  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  rcond, info = NumRu::Lapack.dgbcon( norm, kl, ku, ab, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGBCON estimates the reciprocal of the condition number of a real\n*  general band matrix A, in either the 1-norm or the infinity-norm,\n*  using the LU factorization computed by DGBTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as\n*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies whether the 1-norm condition number or the\n*          infinity-norm condition number is required:\n*          = '1' or 'O':  1-norm;\n*          = 'I':         Infinity-norm.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)\n*          Details of the LU factorization of the band matrix A, as\n*          computed by DGBTRF.  U is stored as an upper triangular band\n*          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n*          the multipliers used during the factorization are stored in\n*          rows KL+KU+2 to 2*KL+KU+1.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices; for 1 <= i <= N, row i of the matrix was\n*          interchanged with row IPIV(i).\n*\n*  ANORM   (input) DOUBLE PRECISION\n*          If NORM = '1' or 'O', the 1-norm of the original matrix A.\n*          If NORM = 'I', the infinity-norm of the original matrix A.\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(norm(A) * norm(inv(A))).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.dgbcon( norm, kl, ku, ab, ipiv, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_norm = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_anorm = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  kl = NUM2INT(rblapack_kl);
  anorm = NUM2DBL(rblapack_anorm);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  work = ALLOC_N(doublereal, (3*n));
  iwork = ALLOC_N(integer, (n));

  dgbcon_(&norm, &n, &kl, &ku, ab, &ldab, ipiv, &anorm, &rcond, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_dgbcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgbcon", rblapack_dgbcon, -1);
}
ruby-lapack-1.7.2/ext/sla_gbamv.c0000644000175000017500000002006612502221016016461 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sla_gbamv_(integer* trans, integer* m, integer* n, integer* kl, integer* ku, real* alpha, real* ab, integer* ldab, real* x, integer* incx, real* beta, real* y, integer* incy);


static VALUE
rblapack_sla_gbamv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  integer trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_alpha;
  real alpha; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_beta;
  real beta; 
  VALUE rblapack_y;
  real *y; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_y_out__;
  real *y_out__;

  integer ldab;
  integer lda;

  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  y = NumRu::Lapack.sla_gbamv( trans, m, n, kl, ku, alpha, ab, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, INCX, BETA, Y, INCY )\n\n*  Purpose\n*  =======\n*\n*  SLA_GBAMV  performs one of the matrix-vector operations\n*\n*          y := alpha*abs(A)*abs(x) + beta*abs(y),\n*     or   y := alpha*abs(A)'*abs(x) + beta*abs(y),\n*\n*  where alpha and beta are scalars, x and y are vectors and A is an\n*  m by n matrix.\n*\n*  This function is primarily used in calculating error bounds.\n*  To protect against underflow during evaluation, components in\n*  the resulting vector are perturbed away from zero by (N+1)\n*  times the underflow threshold.  To prevent unnecessarily large\n*  errors for block-structure embedded in general matrices,\n*  \"symbolically\" zero components are not perturbed.  A zero\n*  entry is considered \"symbolic\" if all multiplications involved\n*  in computing that entry have at least one zero multiplicand.\n*\n\n*  Arguments\n*  ==========\n*\n*  TRANS   (input) INTEGER\n*           On entry, TRANS specifies the operation to be performed as\n*           follows:\n*\n*             BLAS_NO_TRANS      y := alpha*abs(A)*abs(x) + beta*abs(y)\n*             BLAS_TRANS         y := alpha*abs(A')*abs(x) + beta*abs(y)\n*             BLAS_CONJ_TRANS    y := alpha*abs(A')*abs(x) + beta*abs(y)\n*\n*           Unchanged on exit.\n*\n*  M       (input) INTEGER\n*           On entry, M specifies the number of rows of the matrix A.\n*           M must be at least zero.\n*           Unchanged on exit.\n*\n*  N       (input) INTEGER\n*           On entry, N specifies the number of columns of the matrix A.\n*           N must be at least zero.\n*           Unchanged on exit.\n*\n*  KL      (input) INTEGER\n*           The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*           The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  ALPHA   (input) REAL\n*           On entry, ALPHA specifies the scalar alpha.\n*           Unchanged on exit.\n*\n*  A      - REAL             array of DIMENSION ( LDA, n )\n*           Before entry, the leading m by n part of the array A must\n*           contain the matrix of coefficients.\n*           Unchanged on exit.\n*\n*  LDA     (input) INTEGER\n*           On entry, LDA specifies the first dimension of A as declared\n*           in the calling (sub) program. LDA must be at least\n*           max( 1, m ).\n*           Unchanged on exit.\n*\n*  X       (input) REAL array, dimension\n*           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n*           and at least\n*           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n*           Before entry, the incremented array X must contain the\n*           vector x.\n*           Unchanged on exit.\n*\n*  INCX    (input) INTEGER\n*           On entry, INCX specifies the increment for the elements of\n*           X. INCX must not be zero.\n*           Unchanged on exit.\n*\n*  BETA    (input) REAL\n*           On entry, BETA specifies the scalar beta. When BETA is\n*           supplied as zero then Y need not be set on input.\n*           Unchanged on exit.\n*\n*  Y       (input/output) REAL array, dimension\n*           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n*           and at least\n*           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n*           Before entry with BETA non-zero, the incremented array Y\n*           must contain the vector y. On exit, Y is overwritten by the\n*           updated vector y.\n*\n*  INCY    (input) INTEGER\n*           On entry, INCY specifies the increment for the elements of\n*           Y. INCY must not be zero.\n*           Unchanged on exit.\n*\n*\n*  Level 2 Blas routine.\n*\n\n*  =====================================================================\n\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  y = NumRu::Lapack.sla_gbamv( trans, m, n, kl, ku, alpha, ab, x, incx, beta, y, incy, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_trans = argv[0];
  rblapack_m = argv[1];
  rblapack_n = argv[2];
  rblapack_kl = argv[3];
  rblapack_ku = argv[4];
  rblapack_alpha = argv[5];
  rblapack_ab = argv[6];
  rblapack_x = argv[7];
  rblapack_incx = argv[8];
  rblapack_beta = argv[9];
  rblapack_y = argv[10];
  rblapack_incy = argv[11];
  if (argc == 12) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = NUM2INT(rblapack_trans);
  n = NUM2INT(rblapack_n);
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (7th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 1)
    rb_raise(rb_eArgError, "rank of ab (7th argument) must be %d", 1);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  incx = NUM2INT(rblapack_incx);
  incy = NUM2INT(rblapack_incy);
  m = NUM2INT(rblapack_m);
  alpha = (real)NUM2DBL(rblapack_alpha);
  beta = (real)NUM2DBL(rblapack_beta);
  lda = MAX(1,m);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (11th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (11th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy ));
  if (NA_TYPE(rblapack_y) != NA_SFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
  y = NA_PTR_TYPE(rblapack_y, real*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (8th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (trans == ilatrans_("N") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", trans == ilatrans_("N") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx ));
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[1];
    shape[0] = trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy );
    rblapack_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
  MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  sla_gbamv_(&trans, &m, &n, &kl, &ku, &alpha, ab, &ldab, x, &incx, &beta, y, &incy);

  return rblapack_y;
}

void
init_lapack_sla_gbamv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sla_gbamv", rblapack_sla_gbamv, -1);
}
ruby-lapack-1.7.2/ext/ctrrfs.c0000644000175000017500000001652212502221020016026 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctrrfs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, complex* a, integer* lda, complex* b, integer* ldb, complex* x, integer* ldx, real* ferr, real* berr, complex* work, real* rwork, integer* info);


static VALUE
rblapack_ctrrfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  complex *work;
  real *rwork;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info = NumRu::Lapack.ctrrfs( uplo, trans, diag, a, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTRRFS provides error bounds and backward error estimates for the\n*  solution to a system of linear equations with a triangular\n*  coefficient matrix.\n*\n*  The solution matrix X must be computed by CTRTRS or some other\n*  means before entering this routine.  CTRRFS does not do iterative\n*  refinement because doing so cannot improve the backward error.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The triangular matrix A.  If UPLO = 'U', the leading N-by-N\n*          upper triangular part of the array A contains the upper\n*          triangular matrix, and the strictly lower triangular part of\n*          A is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*          triangular part of the array A contains the lower triangular\n*          matrix, and the strictly upper triangular part of A is not\n*          referenced.  If DIAG = 'U', the diagonal elements of A are\n*          also not referenced and are assumed to be 1.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input) COMPLEX array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input) COMPLEX array, dimension (LDX,NRHS)\n*          The solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info = NumRu::Lapack.ctrrfs( uplo, trans, diag, a, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (n));

  ctrrfs_(&uplo, &trans, &diag, &n, &nrhs, a, &lda, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ferr, rblapack_berr, rblapack_info);
}

void
init_lapack_ctrrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctrrfs", rblapack_ctrrfs, -1);
}
ruby-lapack-1.7.2/ext/cunmqr.c0000644000175000017500000001634012502221025016033 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cunmqr_(char* side, char* trans, integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* c, integer* ldc, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_cunmqr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_c;
  complex *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  complex *c_out__;

  integer lda;
  integer k;
  integer ldc;
  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  work, info, c = NumRu::Lapack.cunmqr( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CUNMQR overwrites the general complex M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'C':      Q**H * C       C * Q**H\n*\n*  where Q is a complex unitary matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(1) H(2) . . . H(k)\n*\n*  as returned by CGEQRF. Q is of order M if SIDE = 'L' and of order N\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**H from the Left;\n*          = 'R': apply Q or Q**H from the Right.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'C':  Conjugate transpose, apply Q**H.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,K)\n*          The i-th column must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          CGEQRF in the first k columns of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*          If SIDE = 'L', LDA >= max(1,M);\n*          if SIDE = 'R', LDA >= max(1,N).\n*\n*  TAU     (input) COMPLEX array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by CGEQRF.\n*\n*  C       (input/output) COMPLEX array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace/output) COMPLEX 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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M).\n*          For optimum performance LWORK >= N*NB if SIDE = 'L', and\n*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n*          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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.cunmqr( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_m = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 7) {
    rblapack_lwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  side = StringValueCStr(rblapack_side)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, complex*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != k)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
  MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  cunmqr_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_cunmqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cunmqr", rblapack_cunmqr, -1);
}
ruby-lapack-1.7.2/ext/dsbgvd.c0000644000175000017500000002621412502221013015775 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsbgvd_(char* jobz, char* uplo, integer* n, integer* ka, integer* kb, doublereal* ab, integer* ldab, doublereal* bb, integer* ldbb, doublereal* w, doublereal* z, integer* ldz, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_dsbgvd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ka;
  integer ka; 
  VALUE rblapack_kb;
  integer kb; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_bb;
  doublereal *bb; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublereal *ab_out__;
  VALUE rblapack_bb_out__;
  doublereal *bb_out__;

  integer ldab;
  integer n;
  integer ldbb;
  integer ldz;

  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  w, z, work, iwork, info, ab, bb = NumRu::Lapack.dsbgvd( jobz, uplo, ka, kb, ab, bb, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSBGVD computes all the eigenvalues, and optionally, the eigenvectors\n*  of a real generalized symmetric-definite banded eigenproblem, of the\n*  form A*x=(lambda)*B*x.  Here A and B are assumed to be symmetric and\n*  banded, and B is also positive definite.  If eigenvectors are\n*  desired, it uses a divide and conquer algorithm.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  KA      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KA >= 0.\n*\n*  KB      (input) INTEGER\n*          The number of superdiagonals of the matrix B if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KB >= 0.\n*\n*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB, N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first ka+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).\n*\n*          On exit, the contents of AB are destroyed.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KA+1.\n*\n*  BB      (input/output) DOUBLE PRECISION array, dimension (LDBB, N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix B, stored in the first kb+1 rows of the array.  The\n*          j-th column of B is stored in the j-th column of the array BB\n*          as follows:\n*          if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n*          if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb).\n*\n*          On exit, the factor S from the split Cholesky factorization\n*          B = S**T*S, as returned by DPBSTF.\n*\n*  LDBB    (input) INTEGER\n*          The leading dimension of the array BB.  LDBB >= KB+1.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n*          eigenvectors, with the i-th column of Z holding the\n*          eigenvector associated with W(i).  The eigenvectors are\n*          normalized so Z**T*B*Z = I.\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,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*          If N <= 1,               LWORK >= 1.\n*          If JOBZ = 'N' and N > 1, LWORK >= 3*N.\n*          If JOBZ = 'V' and N > 1, LWORK >= 1 + 5*N + 2*N**2.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal sizes of the WORK and IWORK\n*          arrays, returns these values as the first entries of the WORK\n*          and IWORK arrays, and no error message related to LWORK or\n*          LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.\n*          If JOBZ  = 'N' or N <= 1, LIWORK >= 1.\n*          If JOBZ  = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK and IWORK arrays, and no error message related to\n*          LWORK or LIWORK 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, and i is:\n*             <= N:  the algorithm failed to converge:\n*                    i off-diagonal elements of an intermediate\n*                    tridiagonal form did not converge to zero;\n*             > N:   if INFO = N + i, for 1 <= i <= N, then DPBSTF\n*                    returned INFO = i: B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, work, iwork, info, ab, bb = NumRu::Lapack.dsbgvd( jobz, uplo, ka, kb, ab, bb, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_ka = argv[2];
  rblapack_kb = argv[3];
  rblapack_ab = argv[4];
  rblapack_bb = argv[5];
  if (argc == 8) {
    rblapack_lwork = argv[6];
    rblapack_liwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  ka = NUM2INT(rblapack_ka);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_bb))
    rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
  if (NA_RANK(rblapack_bb) != 2)
    rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
  ldbb = NA_SHAPE0(rblapack_bb);
  if (NA_SHAPE1(rblapack_bb) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of bb must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_bb) != NA_DFLOAT)
    rblapack_bb = na_change_type(rblapack_bb, NA_DFLOAT);
  bb = NA_PTR_TYPE(rblapack_bb, doublereal*);
  if (rblapack_liwork == Qnil)
    liwork = (lsame_(&jobz,"N")||n<=0) ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  kb = NUM2INT(rblapack_kb);
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  if (rblapack_lwork == Qnil)
    lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 3*n : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
  MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldbb;
    shape[1] = n;
    rblapack_bb_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  bb_out__ = NA_PTR_TYPE(rblapack_bb_out__, doublereal*);
  MEMCPY(bb_out__, bb, doublereal, NA_TOTAL(rblapack_bb));
  rblapack_bb = rblapack_bb_out__;
  bb = bb_out__;

  dsbgvd_(&jobz, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, w, z, &ldz, work, &lwork, iwork, &liwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_w, rblapack_z, rblapack_work, rblapack_iwork, rblapack_info, rblapack_ab, rblapack_bb);
}

void
init_lapack_dsbgvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsbgvd", rblapack_dsbgvd, -1);
}
ruby-lapack-1.7.2/ext/dpftrs.c0000644000175000017500000001710212502221026016026 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dpftrs_(char* transr, char* uplo, integer* n, integer* nrhs, doublereal* a, doublereal* b, integer* ldb, integer* info);


static VALUE
rblapack_dpftrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublereal *b_out__;

  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.dpftrs( transr, uplo, n, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPFTRS solves a system of linear equations A*X = B with a symmetric\n*  positive definite matrix A using the Cholesky factorization\n*  A = U**T*U or A = L*L**T computed by DPFTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR  (input) CHARACTER*1\n*          = 'N':  The Normal TRANSR of RFP A is stored;\n*          = 'T':  The Transpose TRANSR of RFP A is stored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of RFP A is stored;\n*          = 'L':  Lower triangle of RFP A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ).\n*          The triangular factor U or L from the Cholesky factorization\n*          of RFP A = U**T*U or RFP A = L*L**T, as computed by DPFTRF.\n*          See note below for more details about RFP A.\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  We first consider Rectangular Full Packed (RFP) Format when N is\n*  even. We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  the transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  the transpose of the last three columns of AP lower.\n*  This covers the case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        03 04 05                33 43 53\n*        13 14 15                00 44 54\n*        23 24 25                10 11 55\n*        33 34 35                20 21 22\n*        00 44 45                30 31 32\n*        01 11 55                40 41 42\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We then consider Rectangular Full Packed (RFP) Format when N is\n*  odd. We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  the transpose of the first two columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  the transpose of the last two columns of AP lower.\n*  This covers the case N odd and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        02 03 04                00 33 43\n*        12 13 14                10 11 44\n*        22 23 24                20 21 22\n*        00 33 34                30 31 32\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*           RFP A                   RFP A\n*\n*     02 12 22 00 01             00 10 20 30 40 50\n*     03 13 23 33 11             33 11 21 31 41 51\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.dpftrs( transr, uplo, n, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_n = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 1)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dpftrs_(&transr, &uplo, &n, &nrhs, a, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_dpftrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dpftrs", rblapack_dpftrs, -1);
}
ruby-lapack-1.7.2/ext/zlaqge.c0000644000175000017500000001345212502221023016010 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlaqge_(integer* m, integer* n, doublecomplex* a, integer* lda, doublereal* r, doublereal* c, doublereal* rowcnd, doublereal* colcnd, doublereal* amax, char* equed);


static VALUE
rblapack_zlaqge(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_r;
  doublereal *r; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_rowcnd;
  doublereal rowcnd; 
  VALUE rblapack_colcnd;
  doublereal colcnd; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;

  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  equed, a = NumRu::Lapack.zlaqge( a, r, c, rowcnd, colcnd, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n*  Purpose\n*  =======\n*\n*  ZLAQGE equilibrates a general M by N matrix A using the row and\n*  column scaling factors in the vectors R and C.\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) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the M by N matrix A.\n*          On exit, the equilibrated matrix.  See EQUED for the form of\n*          the equilibrated matrix.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(M,1).\n*\n*  R       (input) DOUBLE PRECISION array, dimension (M)\n*          The row scale factors for A.\n*\n*  C       (input) DOUBLE PRECISION array, dimension (N)\n*          The column scale factors for A.\n*\n*  ROWCND  (input) DOUBLE PRECISION\n*          Ratio of the smallest R(i) to the largest R(i).\n*\n*  COLCND  (input) DOUBLE PRECISION\n*          Ratio of the smallest C(i) to the largest C(i).\n*\n*  AMAX    (input) DOUBLE PRECISION\n*          Absolute value of largest matrix entry.\n*\n*  EQUED   (output) CHARACTER*1\n*          Specifies the form of equilibration that was done.\n*          = 'N':  No equilibration\n*          = 'R':  Row equilibration, i.e., A has been premultiplied by\n*                  diag(R).\n*          = 'C':  Column equilibration, i.e., A has been postmultiplied\n*                  by diag(C).\n*          = 'B':  Both row and column equilibration, i.e., A has been\n*                  replaced by diag(R) * A * diag(C).\n*\n*  Internal Parameters\n*  ===================\n*\n*  THRESH is a threshold value used to decide if row or column scaling\n*  should be done based on the ratio of the row or column scaling\n*  factors.  If ROWCND < THRESH, row scaling is done, and if\n*  COLCND < THRESH, column scaling is done.\n*\n*  LARGE and SMALL are threshold values used to decide if row scaling\n*  should be done based on the absolute size of the largest matrix\n*  element.  If AMAX > LARGE or AMAX < SMALL, row scaling is done.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  equed, a = NumRu::Lapack.zlaqge( a, r, c, rowcnd, colcnd, amax, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_a = argv[0];
  rblapack_r = argv[1];
  rblapack_c = argv[2];
  rblapack_rowcnd = argv[3];
  rblapack_colcnd = argv[4];
  rblapack_amax = argv[5];
  if (argc == 6) {
  } 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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (3th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  colcnd = NUM2DBL(rblapack_colcnd);
  if (!NA_IsNArray(rblapack_r))
    rb_raise(rb_eArgError, "r (2th argument) must be NArray");
  if (NA_RANK(rblapack_r) != 1)
    rb_raise(rb_eArgError, "rank of r (2th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_r);
  if (NA_TYPE(rblapack_r) != NA_DFLOAT)
    rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
  r = NA_PTR_TYPE(rblapack_r, doublereal*);
  amax = NUM2DBL(rblapack_amax);
  rowcnd = NUM2DBL(rblapack_rowcnd);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zlaqge_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &equed);

  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(2, rblapack_equed, rblapack_a);
}

void
init_lapack_zlaqge(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlaqge", rblapack_zlaqge, -1);
}
ruby-lapack-1.7.2/ext/cunmrz.c0000644000175000017500000001706512502221024016050 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cunmrz_(char* side, char* trans, integer* m, integer* n, integer* k, integer* l, complex* a, integer* lda, complex* tau, complex* c, integer* ldc, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_cunmrz(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_c;
  complex *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  complex *c_out__;

  integer lda;
  integer m;
  integer k;
  integer ldc;
  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  work, info, c = NumRu::Lapack.cunmrz( side, trans, l, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CUNMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CUNMRZ overwrites the general complex M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'C':      Q**H * C       C * Q**H\n*\n*  where Q is a complex unitary matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(1) H(2) . . . H(k)\n*\n*  as returned by CTZRZF. Q is of order M if SIDE = 'L' and of order N\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**H from the Left;\n*          = 'R': apply Q or Q**H from the Right.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'C':  Conjugate transpose, apply Q**H.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  L       (input) INTEGER\n*          The number of columns of the matrix A containing\n*          the meaningful part of the Householder reflectors.\n*          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n*  A       (input) COMPLEX array, dimension\n*                               (LDA,M) if SIDE = 'L',\n*                               (LDA,N) if SIDE = 'R'\n*          The i-th row must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          CTZRZF in the last k rows of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,K).\n*\n*  TAU     (input) COMPLEX array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by CTZRZF.\n*\n*  C       (input/output) COMPLEX array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace/output) COMPLEX 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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M).\n*          For optimum performance LWORK >= N*NB if SIDE = 'L', and\n*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n*          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*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.cunmrz( side, trans, l, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_l = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 7) {
    rblapack_lwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  side = StringValueCStr(rblapack_side)[0];
  l = NUM2INT(rblapack_l);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, complex*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
  MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  cunmrz_(&side, &trans, &m, &n, &k, &l, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_cunmrz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cunmrz", rblapack_cunmrz, -1);
}
ruby-lapack-1.7.2/ext/clatrz.c0000644000175000017500000001174112502221013016022 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clatrz_(integer* m, integer* n, integer* l, complex* a, integer* lda, complex* tau, complex* work);


static VALUE
rblapack_clatrz(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  complex *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, a = NumRu::Lapack.clatrz( l, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLATRZ( M, N, L, A, LDA, TAU, WORK )\n\n*  Purpose\n*  =======\n*\n*  CLATRZ factors the M-by-(M+L) complex upper trapezoidal matrix\n*  [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R  0 ) * Z by means\n*  of unitary transformations, where  Z is an (M+L)-by-(M+L) unitary\n*  matrix and, R and A1 are M-by-M upper triangular matrices.\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*  L       (input) INTEGER\n*          The number of columns of the matrix A containing the\n*          meaningful part of the Householder vectors. N-M >= L >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the leading M-by-N upper trapezoidal part of the\n*          array A must contain the matrix to be factorized.\n*          On exit, the leading M-by-M upper triangular part of A\n*          contains the upper triangular matrix R, and elements N-L+1 to\n*          N of the first M rows of A, with the array TAU, represent the\n*          unitary matrix Z as a product of M elementary reflectors.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  TAU     (output) COMPLEX array, dimension (M)\n*          The scalar factors of the elementary reflectors.\n*\n*  WORK    (workspace) COMPLEX array, dimension (M)\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n*  The factorization is obtained by Householder's method.  The kth\n*  transformation matrix, Z( k ), which is used to introduce zeros into\n*  the ( m - k + 1 )th row of A, is given in the form\n*\n*     Z( k ) = ( I     0   ),\n*              ( 0  T( k ) )\n*\n*  where\n*\n*     T( k ) = I - tau*u( k )*u( k )',   u( k ) = (   1    ),\n*                                                 (   0    )\n*                                                 ( z( k ) )\n*\n*  tau is a scalar and z( k ) is an l element vector. tau and z( k )\n*  are chosen to annihilate the elements of the kth row of A2.\n*\n*  The scalar tau is returned in the kth element of TAU and the vector\n*  u( k ) in the kth row of A2, such that the elements of z( k ) are\n*  in  a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in\n*  the upper triangular part of A1.\n*\n*  Z is given by\n*\n*     Z =  Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, a = NumRu::Lapack.clatrz( l, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_l = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  l = NUM2INT(rblapack_l);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  m = lda;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(complex, (m));

  clatrz_(&m, &n, &l, a, &lda, tau, work);

  free(work);
  return rb_ary_new3(2, rblapack_tau, rblapack_a);
}

void
init_lapack_clatrz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clatrz", rblapack_clatrz, -1);
}
ruby-lapack-1.7.2/ext/slapmt.c0000644000175000017500000001061112502221014016017 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slapmt_(logical* forwrd, integer* m, integer* n, real* x, integer* ldx, integer* k);


static VALUE
rblapack_slapmt(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_forwrd;
  logical forwrd; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_k;
  integer *k; 
  VALUE rblapack_x_out__;
  real *x_out__;
  VALUE rblapack_k_out__;
  integer *k_out__;

  integer ldx;
  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  x, k = NumRu::Lapack.slapmt( forwrd, m, x, k, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAPMT( FORWRD, M, N, X, LDX, K )\n\n*  Purpose\n*  =======\n*\n*  SLAPMT rearranges the columns of the M by N matrix X as specified\n*  by the permutation K(1),K(2),...,K(N) of the integers 1,...,N.\n*  If FORWRD = .TRUE.,  forward permutation:\n*\n*       X(*,K(J)) is moved X(*,J) for J = 1,2,...,N.\n*\n*  If FORWRD = .FALSE., backward permutation:\n*\n*       X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N.\n*\n\n*  Arguments\n*  =========\n*\n*  FORWRD  (input) LOGICAL\n*          = .TRUE., forward permutation\n*          = .FALSE., backward permutation\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix X. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix X. N >= 0.\n*\n*  X       (input/output) REAL array, dimension (LDX,N)\n*          On entry, the M by N matrix X.\n*          On exit, X contains the permuted matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X, LDX >= MAX(1,M).\n*\n*  K       (input/output) INTEGER array, dimension (N)\n*          On entry, K contains the permutation vector. K is used as\n*          internal workspace, but reset to its original value on\n*          output.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, II, J, IN\n      REAL               TEMP\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, k = NumRu::Lapack.slapmt( forwrd, m, x, k, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_forwrd = argv[0];
  rblapack_m = argv[1];
  rblapack_x = argv[2];
  rblapack_k = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  forwrd = (rblapack_forwrd == Qtrue);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (3th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  n = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_k))
    rb_raise(rb_eArgError, "k (4th argument) must be NArray");
  if (NA_RANK(rblapack_k) != 1)
    rb_raise(rb_eArgError, "rank of k (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_k) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of k must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_k) != NA_LINT)
    rblapack_k = na_change_type(rblapack_k, NA_LINT);
  k = NA_PTR_TYPE(rblapack_k, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = n;
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_k_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  k_out__ = NA_PTR_TYPE(rblapack_k_out__, integer*);
  MEMCPY(k_out__, k, integer, NA_TOTAL(rblapack_k));
  rblapack_k = rblapack_k_out__;
  k = k_out__;

  slapmt_(&forwrd, &m, &n, x, &ldx, k);

  return rb_ary_new3(2, rblapack_x, rblapack_k);
}

void
init_lapack_slapmt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slapmt", rblapack_slapmt, -1);
}
ruby-lapack-1.7.2/ext/sgglse.c0000644000175000017500000002204412502221014016006 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgglse_(integer* m, integer* n, integer* p, real* a, integer* lda, real* b, integer* ldb, real* c, real* d, real* x, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sgglse(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_b_out__;
  real *b_out__;
  VALUE rblapack_c_out__;
  real *c_out__;
  VALUE rblapack_d_out__;
  real *d_out__;

  integer lda;
  integer n;
  integer ldb;
  integer m;
  integer p;

  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  x, work, info, a, b, c, d = NumRu::Lapack.sgglse( a, b, c, d, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGGLSE solves the linear equality-constrained least squares (LSE)\n*  problem:\n*\n*          minimize || c - A*x ||_2   subject to   B*x = d\n*\n*  where A is an M-by-N matrix, B is a P-by-N matrix, c is a given\n*  M-vector, and d is a given P-vector. It is assumed that\n*  P <= N <= M+P, and\n*\n*           rank(B) = P and  rank( (A) ) = N.\n*                                ( (B) )\n*\n*  These conditions ensure that the LSE problem has a unique solution,\n*  which is obtained using a generalized RQ factorization of the\n*  matrices (B, A) given by\n*\n*     B = (0 R)*Q,   A = Z*T*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 matrices A and B. N >= 0.\n*\n*  P       (input) INTEGER\n*          The number of rows of the matrix B. 0 <= P <= N <= M+P.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, the elements on and above the diagonal of the array\n*          contain the min(M,N)-by-N upper trapezoidal matrix T.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  B       (input/output) REAL array, dimension (LDB,N)\n*          On entry, the P-by-N matrix B.\n*          On exit, the upper triangle of the subarray B(1:P,N-P+1:N)\n*          contains the P-by-P upper triangular matrix R.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,P).\n*\n*  C       (input/output) REAL array, dimension (M)\n*          On entry, C contains the right hand side vector for the\n*          least squares part of the LSE problem.\n*          On exit, the residual sum of squares for the solution\n*          is given by the sum of squares of elements N-P+1 to M of\n*          vector C.\n*\n*  D       (input/output) REAL array, dimension (P)\n*          On entry, D contains the right hand side vector for the\n*          constrained equation.\n*          On exit, D is destroyed.\n*\n*  X       (output) REAL array, dimension (N)\n*          On exit, X is the solution of the LSE problem.\n*\n*  WORK    (workspace/output) REAL 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+P).\n*          For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,\n*          where NB is an upper bound for the optimal blocksizes for\n*          SGEQRF, SGERQF, SORMQR and SORMRQ.\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*          = 1:  the upper triangular factor R associated with B in the\n*                generalized RQ factorization of the pair (B, A) is\n*                singular, so that rank(B) < P; the least squares\n*                solution could not be computed.\n*          = 2:  the (N-P) by (N-P) part of the upper trapezoidal factor\n*                T associated with A in the generalized RQ factorization\n*                of the pair (B, A) is singular, so that\n*                rank( (A) ) < N; the least squares solution could not\n*                    ( (B) )\n*                be computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, work, info, a, b, c, d = NumRu::Lapack.sgglse( a, b, c, d, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  rblapack_c = argv[2];
  rblapack_d = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } 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 (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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (3th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (3th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  p = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (rblapack_lwork == Qnil)
    lwork = m+n+p;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_x = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[1];
    shape[0] = p;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;

  sgglse_(&m, &n, &p, a, &lda, b, &ldb, c, d, x, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_x, rblapack_work, rblapack_info, rblapack_a, rblapack_b, rblapack_c, rblapack_d);
}

void
init_lapack_sgglse(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgglse", rblapack_sgglse, -1);
}
ruby-lapack-1.7.2/ext/ztbrfs.c0000644000175000017500000001730112502221023016034 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztbrfs_(char* uplo, char* trans, char* diag, integer* n, integer* kd, integer* nrhs, doublecomplex* ab, integer* ldab, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_ztbrfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  doublecomplex *work;
  doublereal *rwork;

  integer ldab;
  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info = NumRu::Lapack.ztbrfs( uplo, trans, diag, kd, ab, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTBRFS provides error bounds and backward error estimates for the\n*  solution to a system of linear equations with a triangular band\n*  coefficient matrix.\n*\n*  The solution matrix X must be computed by ZTBTRS or some other\n*  means before entering this routine.  ZTBRFS does not do iterative\n*  refinement because doing so cannot improve the backward error.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals or subdiagonals of the\n*          triangular band matrix A.  KD >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)\n*          The upper or lower triangular band matrix A, stored in the\n*          first kd+1 rows of the array. The j-th column of A is stored\n*          in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*          If DIAG = 'U', the diagonal elements of A are not referenced\n*          and are assumed to be 1.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  B       (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input) COMPLEX*16 array, dimension (LDX,NRHS)\n*          The solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info = NumRu::Lapack.ztbrfs( uplo, trans, diag, kd, ab, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_kd = argv[3];
  rblapack_ab = argv[4];
  rblapack_b = argv[5];
  rblapack_x = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (7th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  kd = NUM2INT(rblapack_kd);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (n));

  ztbrfs_(&uplo, &trans, &diag, &n, &kd, &nrhs, ab, &ldab, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ferr, rblapack_berr, rblapack_info);
}

void
init_lapack_ztbrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztbrfs", rblapack_ztbrfs, -1);
}
ruby-lapack-1.7.2/ext/slatzm.c0000644000175000017500000001576512502221023016050 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slatzm_(char* side, integer* m, integer* n, real* v, integer* incv, real* tau, real* c1, real* c2, integer* ldc, real* work);


static VALUE
rblapack_slatzm(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_v;
  real *v; 
  VALUE rblapack_incv;
  integer incv; 
  VALUE rblapack_tau;
  real tau; 
  VALUE rblapack_c1;
  real *c1; 
  VALUE rblapack_c2;
  real *c2; 
  VALUE rblapack_c1_out__;
  real *c1_out__;
  VALUE rblapack_c2_out__;
  real *c2_out__;
  real *work;

  integer ldc;

  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  c1, c2 = NumRu::Lapack.slatzm( side, m, n, v, incv, tau, c1, c2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK )\n\n*  Purpose\n*  =======\n*\n*  This routine is deprecated and has been replaced by routine SORMRZ.\n*\n*  SLATZM applies a Householder matrix generated by STZRQF to a matrix.\n*\n*  Let P = I - tau*u*u',   u = ( 1 ),\n*                              ( v )\n*  where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if\n*  SIDE = 'R'.\n*\n*  If SIDE equals 'L', let\n*         C = [ C1 ] 1\n*             [ C2 ] m-1\n*               n\n*  Then C is overwritten by P*C.\n*\n*  If SIDE equals 'R', let\n*         C = [ C1, C2 ] m\n*                1  n-1\n*  Then C is overwritten by C*P.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': form P * C\n*          = 'R': form C * P\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C.\n*\n*  V       (input) REAL array, dimension\n*                  (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n*                  (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n*          The vector v in the representation of P. V is not used\n*          if TAU = 0.\n*\n*  INCV    (input) INTEGER\n*          The increment between elements of v. INCV <> 0\n*\n*  TAU     (input) REAL\n*          The value tau in the representation of P.\n*\n*  C1      (input/output) REAL array, dimension\n*                         (LDC,N) if SIDE = 'L'\n*                         (M,1)   if SIDE = 'R'\n*          On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1\n*          if SIDE = 'R'.\n*\n*          On exit, the first row of P*C if SIDE = 'L', or the first\n*          column of C*P if SIDE = 'R'.\n*\n*  C2      (input/output) REAL array, dimension\n*                         (LDC, N)   if SIDE = 'L'\n*                         (LDC, N-1) if SIDE = 'R'\n*          On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the\n*          m x (n - 1) matrix C2 if SIDE = 'R'.\n*\n*          On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P\n*          if SIDE = 'R'.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the arrays C1 and C2. LDC >= (1,M).\n*\n*  WORK    (workspace) REAL array, dimension\n*                      (N) if SIDE = 'L'\n*                      (M) if SIDE = 'R'\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c1, c2 = NumRu::Lapack.slatzm( side, m, n, v, incv, tau, c1, c2, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_side = argv[0];
  rblapack_m = argv[1];
  rblapack_n = argv[2];
  rblapack_v = argv[3];
  rblapack_incv = argv[4];
  rblapack_tau = argv[5];
  rblapack_c1 = argv[6];
  rblapack_c2 = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  n = NUM2INT(rblapack_n);
  incv = NUM2INT(rblapack_incv);
  if (!NA_IsNArray(rblapack_c2))
    rb_raise(rb_eArgError, "c2 (8th argument) must be NArray");
  if (NA_RANK(rblapack_c2) != 2)
    rb_raise(rb_eArgError, "rank of c2 (8th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c2);
  if (NA_SHAPE1(rblapack_c2) != (lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0))
    rb_raise(rb_eRuntimeError, "shape 1 of c2 must be %d", lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0);
  if (NA_TYPE(rblapack_c2) != NA_SFLOAT)
    rblapack_c2 = na_change_type(rblapack_c2, NA_SFLOAT);
  c2 = NA_PTR_TYPE(rblapack_c2, real*);
  m = NUM2INT(rblapack_m);
  tau = (real)NUM2DBL(rblapack_tau);
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (4th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 1)
    rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_v) != (1 + (m-1)*abs(incv)))
    rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1 + (m-1)*abs(incv));
  if (NA_TYPE(rblapack_v) != NA_SFLOAT)
    rblapack_v = na_change_type(rblapack_v, NA_SFLOAT);
  v = NA_PTR_TYPE(rblapack_v, real*);
  if (!NA_IsNArray(rblapack_c1))
    rb_raise(rb_eArgError, "c1 (7th argument) must be NArray");
  if (NA_RANK(rblapack_c1) != 2)
    rb_raise(rb_eArgError, "rank of c1 (7th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_c1) != (lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0))
    rb_raise(rb_eRuntimeError, "shape 0 of c1 must be %d", lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0);
  if (NA_SHAPE1(rblapack_c1) != (lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0))
    rb_raise(rb_eRuntimeError, "shape 1 of c1 must be %d", lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0);
  if (NA_TYPE(rblapack_c1) != NA_SFLOAT)
    rblapack_c1 = na_change_type(rblapack_c1, NA_SFLOAT);
  c1 = NA_PTR_TYPE(rblapack_c1, real*);
  {
    na_shape_t shape[2];
    shape[0] = lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0;
    shape[1] = lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0;
    rblapack_c1_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  c1_out__ = NA_PTR_TYPE(rblapack_c1_out__, real*);
  MEMCPY(c1_out__, c1, real, NA_TOTAL(rblapack_c1));
  rblapack_c1 = rblapack_c1_out__;
  c1 = c1_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0;
    rblapack_c2_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  c2_out__ = NA_PTR_TYPE(rblapack_c2_out__, real*);
  MEMCPY(c2_out__, c2, real, NA_TOTAL(rblapack_c2));
  rblapack_c2 = rblapack_c2_out__;
  c2 = c2_out__;
  work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  slatzm_(&side, &m, &n, v, &incv, &tau, c1, c2, &ldc, work);

  free(work);
  return rb_ary_new3(2, rblapack_c1, rblapack_c2);
}

void
init_lapack_slatzm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slatzm", rblapack_slatzm, -1);
}
ruby-lapack-1.7.2/ext/dlahrd.c0000644000175000017500000001470612502221024015767 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlahrd_(integer* n, integer* k, integer* nb, doublereal* a, integer* lda, doublereal* tau, doublereal* t, integer* ldt, doublereal* y, integer* ldy);


static VALUE
rblapack_dlahrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_nb;
  integer nb; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_t;
  doublereal *t; 
  VALUE rblapack_y;
  doublereal *y; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;

  integer lda;
  integer ldt;
  integer ldy;

  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, t, y, a = NumRu::Lapack.dlahrd( n, k, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n*  Purpose\n*  =======\n*\n*  DLAHRD reduces the first NB columns of a real general n-by-(n-k+1)\n*  matrix A so that elements below the k-th subdiagonal are zero. The\n*  reduction is performed by an orthogonal similarity transformation\n*  Q' * A * Q. The routine returns the matrices V and T which determine\n*  Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n*\n*  This is an OBSOLETE auxiliary routine. \n*  This routine will be 'deprecated' in a  future release.\n*  Please use the new routine DLAHR2 instead.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.\n*\n*  K       (input) INTEGER\n*          The offset for the reduction. Elements below the k-th\n*          subdiagonal in the first NB columns are reduced to zero.\n*\n*  NB      (input) INTEGER\n*          The number of columns to be reduced.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N-K+1)\n*          On entry, the n-by-(n-k+1) general matrix A.\n*          On exit, the elements on and above the k-th subdiagonal in\n*          the first NB columns are overwritten with the corresponding\n*          elements of the reduced matrix; the elements below the k-th\n*          subdiagonal, with the array TAU, represent the matrix Q as a\n*          product of elementary reflectors. The other columns of A are\n*          unchanged. See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  TAU     (output) DOUBLE PRECISION array, dimension (NB)\n*          The scalar factors of the elementary reflectors. See Further\n*          Details.\n*\n*  T       (output) DOUBLE PRECISION array, dimension (LDT,NB)\n*          The upper triangular matrix T.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T.  LDT >= NB.\n*\n*  Y       (output) DOUBLE PRECISION array, dimension (LDY,NB)\n*          The n-by-nb matrix Y.\n*\n*  LDY     (input) INTEGER\n*          The leading dimension of the array Y. LDY >= N.\n*\n\n*  Further Details\n*  ===============\n*\n*  The matrix Q is represented as a product of nb elementary reflectors\n*\n*     Q = H(1) H(2) . . . H(nb).\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+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n*  A(i+k+1:n,i), and tau in TAU(i).\n*\n*  The elements of the vectors v together form the (n-k+1)-by-nb matrix\n*  V which is needed, with T and Y, to apply the transformation to the\n*  unreduced part of the matrix, using an update of the form:\n*  A := (I - V*T*V') * (A - Y*V').\n*\n*  The contents of A on exit are illustrated by the following example\n*  with n = 7, k = 3 and nb = 2:\n*\n*     ( a   h   a   a   a )\n*     ( a   h   a   a   a )\n*     ( a   h   a   a   a )\n*     ( h   h   a   a   a )\n*     ( v1  h   a   a   a )\n*     ( v1  v2  a   a   a )\n*     ( v1  v2  a   a   a )\n*\n*  where a denotes an element of the original matrix A, h denotes a\n*  modified element of the upper Hessenberg matrix H, and vi denotes an\n*  element of the vector defining H(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, t, y, a = NumRu::Lapack.dlahrd( n, k, nb, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_n = argv[0];
  rblapack_k = argv[1];
  rblapack_nb = argv[2];
  rblapack_a = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  nb = NUM2INT(rblapack_nb);
  ldy = n;
  k = NUM2INT(rblapack_k);
  ldt = nb;
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != (n-k+1))
    rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", n-k+1);
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,nb);
    rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = MAX(1,nb);
    rblapack_t = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  t = NA_PTR_TYPE(rblapack_t, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldy;
    shape[1] = MAX(1,nb);
    rblapack_y = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  y = NA_PTR_TYPE(rblapack_y, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n-k+1;
    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__;

  dlahrd_(&n, &k, &nb, a, &lda, tau, t, &ldt, y, &ldy);

  return rb_ary_new3(4, rblapack_tau, rblapack_t, rblapack_y, rblapack_a);
}

void
init_lapack_dlahrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlahrd", rblapack_dlahrd, -1);
}
ruby-lapack-1.7.2/ext/zlaqp2.c0000644000175000017500000001751712502221016015746 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlaqp2_(integer* m, integer* n, integer* offset, doublecomplex* a, integer* lda, integer* jpvt, doublecomplex* tau, doublereal* vn1, doublereal* vn2, doublecomplex* work);


static VALUE
rblapack_zlaqp2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_offset;
  integer offset; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_jpvt;
  integer *jpvt; 
  VALUE rblapack_vn1;
  doublereal *vn1; 
  VALUE rblapack_vn2;
  doublereal *vn2; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_jpvt_out__;
  integer *jpvt_out__;
  VALUE rblapack_vn1_out__;
  doublereal *vn1_out__;
  VALUE rblapack_vn2_out__;
  doublereal *vn2_out__;
  doublecomplex *work;

  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, a, jpvt, vn1, vn2 = NumRu::Lapack.zlaqp2( m, offset, a, jpvt, vn1, vn2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, WORK )\n\n*  Purpose\n*  =======\n*\n*  ZLAQP2 computes a QR factorization with column pivoting of\n*  the block A(OFFSET+1:M,1:N).\n*  The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\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*  OFFSET  (input) INTEGER\n*          The number of rows of the matrix A that must be pivoted\n*          but no factorized. OFFSET >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, the upper triangle of block A(OFFSET+1:M,1:N) is\n*          the triangular factor obtained; the elements in block\n*          A(OFFSET+1:M,1:N) below the diagonal, together with the\n*          array TAU, represent the orthogonal matrix Q as a product of\n*          elementary reflectors. Block A(1:OFFSET,1:N) has been\n*          accordingly pivoted, but no factorized.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  JPVT    (input/output) INTEGER array, dimension (N)\n*          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n*          to the front of A*P (a leading column); if JPVT(i) = 0,\n*          the i-th column of A is a free column.\n*          On exit, if JPVT(i) = k, then the i-th column of A*P\n*          was the k-th column of A.\n*\n*  TAU     (output) COMPLEX*16 array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors.\n*\n*  VN1     (input/output) DOUBLE PRECISION array, dimension (N)\n*          The vector with the partial column norms.\n*\n*  VN2     (input/output) DOUBLE PRECISION array, dimension (N)\n*          The vector with the exact column norms.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (N)\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n*    X. Sun, Computer Science Dept., Duke University, USA\n*\n*  Partial column norm updating strategy modified by\n*    Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n*    University of Zagreb, Croatia.\n*     June 2010\n*  For more details see LAPACK Working Note 176.\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, a, jpvt, vn1, vn2 = NumRu::Lapack.zlaqp2( m, offset, a, jpvt, vn1, vn2, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_m = argv[0];
  rblapack_offset = argv[1];
  rblapack_a = argv[2];
  rblapack_jpvt = argv[3];
  rblapack_vn1 = argv[4];
  rblapack_vn2 = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_vn1))
    rb_raise(rb_eArgError, "vn1 (5th argument) must be NArray");
  if (NA_RANK(rblapack_vn1) != 1)
    rb_raise(rb_eArgError, "rank of vn1 (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_vn1) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of vn1 must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_vn1) != NA_DFLOAT)
    rblapack_vn1 = na_change_type(rblapack_vn1, NA_DFLOAT);
  vn1 = NA_PTR_TYPE(rblapack_vn1, doublereal*);
  offset = NUM2INT(rblapack_offset);
  if (!NA_IsNArray(rblapack_vn2))
    rb_raise(rb_eArgError, "vn2 (6th argument) must be NArray");
  if (NA_RANK(rblapack_vn2) != 1)
    rb_raise(rb_eArgError, "rank of vn2 (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_vn2) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of vn2 must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_vn2) != NA_DFLOAT)
    rblapack_vn2 = na_change_type(rblapack_vn2, NA_DFLOAT);
  vn2 = NA_PTR_TYPE(rblapack_vn2, doublereal*);
  if (!NA_IsNArray(rblapack_jpvt))
    rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
  if (NA_RANK(rblapack_jpvt) != 1)
    rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_jpvt) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_jpvt) != NA_LINT)
    rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
  jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
  MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
  rblapack_jpvt = rblapack_jpvt_out__;
  jpvt = jpvt_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_vn1_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  vn1_out__ = NA_PTR_TYPE(rblapack_vn1_out__, doublereal*);
  MEMCPY(vn1_out__, vn1, doublereal, NA_TOTAL(rblapack_vn1));
  rblapack_vn1 = rblapack_vn1_out__;
  vn1 = vn1_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_vn2_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  vn2_out__ = NA_PTR_TYPE(rblapack_vn2_out__, doublereal*);
  MEMCPY(vn2_out__, vn2, doublereal, NA_TOTAL(rblapack_vn2));
  rblapack_vn2 = rblapack_vn2_out__;
  vn2 = vn2_out__;
  work = ALLOC_N(doublecomplex, (n));

  zlaqp2_(&m, &n, &offset, a, &lda, jpvt, tau, vn1, vn2, work);

  free(work);
  return rb_ary_new3(5, rblapack_tau, rblapack_a, rblapack_jpvt, rblapack_vn1, rblapack_vn2);
}

void
init_lapack_zlaqp2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlaqp2", rblapack_zlaqp2, -1);
}
ruby-lapack-1.7.2/ext/slapmr.c0000644000175000017500000001034212502221014016016 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slapmr_(logical* forwrd, integer* m, integer* n, real* x, integer* ldx, integer* k);


static VALUE
rblapack_slapmr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_forwrd;
  logical forwrd; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_k;
  integer *k; 
  VALUE rblapack_x_out__;
  real *x_out__;
  VALUE rblapack_k_out__;
  integer *k_out__;

  integer ldx;
  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  x, k = NumRu::Lapack.slapmr( forwrd, x, k, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAPMR( FORWRD, M, N, X, LDX, K )\n\n*  Purpose\n*  =======\n*\n*  SLAPMR rearranges the rows of the M by N matrix X as specified\n*  by the permutation K(1),K(2),...,K(M) of the integers 1,...,M.\n*  If FORWRD = .TRUE.,  forward permutation:\n*\n*       X(K(I),*) is moved X(I,*) for I = 1,2,...,M.\n*\n*  If FORWRD = .FALSE., backward permutation:\n*\n*       X(I,*) is moved to X(K(I),*) for I = 1,2,...,M.\n*\n\n*  Arguments\n*  =========\n*\n*  FORWRD  (input) LOGICAL\n*          = .TRUE., forward permutation\n*          = .FALSE., backward permutation\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix X. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix X. N >= 0.\n*\n*  X       (input/output) REAL array, dimension (LDX,N)\n*          On entry, the M by N matrix X.\n*          On exit, X contains the permuted matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X, LDX >= MAX(1,M).\n*\n*  K       (input/output) INTEGER array, dimension (M)\n*          On entry, K contains the permutation vector. K is used as\n*          internal workspace, but reset to its original value on\n*          output.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, IN, J, JJ\n      REAL               TEMP\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, k = NumRu::Lapack.slapmr( forwrd, x, k, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_forwrd = argv[0];
  rblapack_x = argv[1];
  rblapack_k = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  forwrd = (rblapack_forwrd == Qtrue);
  if (!NA_IsNArray(rblapack_k))
    rb_raise(rb_eArgError, "k (3th argument) must be NArray");
  if (NA_RANK(rblapack_k) != 1)
    rb_raise(rb_eArgError, "rank of k (3th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_k);
  if (NA_TYPE(rblapack_k) != NA_LINT)
    rblapack_k = na_change_type(rblapack_k, NA_LINT);
  k = NA_PTR_TYPE(rblapack_k, integer*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  n = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = n;
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_k_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  k_out__ = NA_PTR_TYPE(rblapack_k_out__, integer*);
  MEMCPY(k_out__, k, integer, NA_TOTAL(rblapack_k));
  rblapack_k = rblapack_k_out__;
  k = k_out__;

  slapmr_(&forwrd, &m, &n, x, &ldx, k);

  return rb_ary_new3(2, rblapack_x, rblapack_k);
}

void
init_lapack_slapmr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slapmr", rblapack_slapmr, -1);
}
ruby-lapack-1.7.2/ext/dlagtf.c0000644000175000017500000001761412502221024015773 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlagtf_(integer* n, doublereal* a, doublereal* lambda, doublereal* b, doublereal* c, doublereal* tol, doublereal* d, integer* in, integer* info);


static VALUE
rblapack_dlagtf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_lambda;
  doublereal lambda; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_tol;
  doublereal tol; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_in;
  integer *in; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;
  VALUE rblapack_c_out__;
  doublereal *c_out__;

  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  d, in, info, a, b, c = NumRu::Lapack.dlagtf( a, lambda, b, c, tol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLAGTF factorizes the matrix (T - lambda*I), where T is an n by n\n*  tridiagonal matrix and lambda is a scalar, as\n*\n*     T - lambda*I = PLU,\n*\n*  where P is a permutation matrix, L is a unit lower tridiagonal matrix\n*  with at most one non-zero sub-diagonal elements per column and U is\n*  an upper triangular matrix with at most two non-zero super-diagonal\n*  elements per column.\n*\n*  The factorization is obtained by Gaussian elimination with partial\n*  pivoting and implicit row scaling.\n*\n*  The parameter LAMBDA is included in the routine so that DLAGTF may\n*  be used, in conjunction with DLAGTS, to obtain eigenvectors of T by\n*  inverse iteration.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix T.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, A must contain the diagonal elements of T.\n*\n*          On exit, A is overwritten by the n diagonal elements of the\n*          upper triangular matrix U of the factorization of T.\n*\n*  LAMBDA  (input) DOUBLE PRECISION\n*          On entry, the scalar lambda.\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (N-1)\n*          On entry, B must contain the (n-1) super-diagonal elements of\n*          T.\n*\n*          On exit, B is overwritten by the (n-1) super-diagonal\n*          elements of the matrix U of the factorization of T.\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (N-1)\n*          On entry, C must contain the (n-1) sub-diagonal elements of\n*          T.\n*\n*          On exit, C is overwritten by the (n-1) sub-diagonal elements\n*          of the matrix L of the factorization of T.\n*\n*  TOL     (input) DOUBLE PRECISION\n*          On entry, a relative tolerance used to indicate whether or\n*          not the matrix (T - lambda*I) is nearly singular. TOL should\n*          normally be chose as approximately the largest relative error\n*          in the elements of T. For example, if the elements of T are\n*          correct to about 4 significant figures, then TOL should be\n*          set to about 5*10**(-4). If TOL is supplied as less than eps,\n*          where eps is the relative machine precision, then the value\n*          eps is used in place of TOL.\n*\n*  D       (output) DOUBLE PRECISION array, dimension (N-2)\n*          On exit, D is overwritten by the (n-2) second super-diagonal\n*          elements of the matrix U of the factorization of T.\n*\n*  IN      (output) INTEGER array, dimension (N)\n*          On exit, IN contains details of the permutation matrix P. If\n*          an interchange occurred at the kth step of the elimination,\n*          then IN(k) = 1, otherwise IN(k) = 0. The element IN(n)\n*          returns the smallest positive integer j such that\n*\n*             abs( u(j,j) ).le. norm( (T - lambda*I)(j) )*TOL,\n*\n*          where norm( A(j) ) denotes the sum of the absolute values of\n*          the jth row of the matrix A. If no such j exists then IN(n)\n*          is returned as zero. If IN(n) is returned as positive, then a\n*          diagonal element of U is small, indicating that\n*          (T - lambda*I) is singular or nearly singular,\n*\n*  INFO    (output) INTEGER\n*          = 0   : successful exit\n*          .lt. 0: if INFO = -k, the kth argument had an illegal value\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, in, info, a, b, c = NumRu::Lapack.dlagtf( a, lambda, b, c, tol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_a = argv[0];
  rblapack_lambda = argv[1];
  rblapack_b = argv[2];
  rblapack_c = argv[3];
  rblapack_tol = argv[4];
  if (argc == 5) {
  } 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) != 1)
    rb_raise(rb_eArgError, "rank of a (1th argument) must be %d", 1);
  n = NA_SHAPE0(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*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (3th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 1)
    rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_b) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of b must be %d", n-1);
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  tol = NUM2DBL(rblapack_tol);
  lambda = NUM2DBL(rblapack_lambda);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (4th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", n-1);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n-2;
    rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_in = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  in = NA_PTR_TYPE(rblapack_in, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_a_out__ = na_make_object(NA_DFLOAT, 1, 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__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  dlagtf_(&n, a, &lambda, b, c, &tol, d, in, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_d, rblapack_in, rblapack_info, rblapack_a, rblapack_b, rblapack_c);
}

void
init_lapack_dlagtf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlagtf", rblapack_dlagtf, -1);
}
ruby-lapack-1.7.2/ext/iparmq.c0000644000175000017500000002164112502221025016017 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern integer iparmq_(integer* ispec, char* name, char* opts, integer* n, integer* ilo, integer* ihi, integer* lwork);


static VALUE
rblapack_iparmq(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ispec;
  integer ispec; 
  VALUE rblapack_name;
  char name; 
  VALUE rblapack_opts;
  char opts; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack___out__;
  integer __out__; 


  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  __out__ = NumRu::Lapack.iparmq( ispec, name, opts, n, ilo, ihi, lwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK )\n\n*  Purpose\n*  =======\n*\n*       This program sets problem and machine dependent parameters\n*       useful for xHSEQR and its subroutines. It is called whenever \n*       ILAENV is called with 12 <= ISPEC <= 16\n*\n\n*  Arguments\n*  =========\n*\n*       ISPEC  (input) integer scalar\n*              ISPEC specifies which tunable parameter IPARMQ should\n*              return.\n*\n*              ISPEC=12: (INMIN)  Matrices of order nmin or less\n*                        are sent directly to xLAHQR, the implicit\n*                        double shift QR algorithm.  NMIN must be\n*                        at least 11.\n*\n*              ISPEC=13: (INWIN)  Size of the deflation window.\n*                        This is best set greater than or equal to\n*                        the number of simultaneous shifts NS.\n*                        Larger matrices benefit from larger deflation\n*                        windows.\n*\n*              ISPEC=14: (INIBL) Determines when to stop nibbling and\n*                        invest in an (expensive) multi-shift QR sweep.\n*                        If the aggressive early deflation subroutine\n*                        finds LD converged eigenvalues from an order\n*                        NW deflation window and LD.GT.(NW*NIBBLE)/100,\n*                        then the next QR sweep is skipped and early\n*                        deflation is applied immediately to the\n*                        remaining active diagonal block.  Setting\n*                        IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a\n*                        multi-shift QR sweep whenever early deflation\n*                        finds a converged eigenvalue.  Setting\n*                        IPARMQ(ISPEC=14) greater than or equal to 100\n*                        prevents TTQRE from skipping a multi-shift\n*                        QR sweep.\n*\n*              ISPEC=15: (NSHFTS) The number of simultaneous shifts in\n*                        a multi-shift QR iteration.\n*\n*              ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the\n*                        following meanings.\n*                        0:  During the multi-shift QR sweep,\n*                            xLAQR5 does not accumulate reflections and\n*                            does not use matrix-matrix multiply to\n*                            update the far-from-diagonal matrix\n*                            entries.\n*                        1:  During the multi-shift QR sweep,\n*                            xLAQR5 and/or xLAQRaccumulates reflections and uses\n*                            matrix-matrix multiply to update the\n*                            far-from-diagonal matrix entries.\n*                        2:  During the multi-shift QR sweep.\n*                            xLAQR5 accumulates reflections and takes\n*                            advantage of 2-by-2 block structure during\n*                            matrix-matrix multiplies.\n*                        (If xTRMM is slower than xGEMM, then\n*                        IPARMQ(ISPEC=16)=1 may be more efficient than\n*                        IPARMQ(ISPEC=16)=2 despite the greater level of\n*                        arithmetic work implied by the latter choice.)\n*\n*       NAME    (input) character string\n*               Name of the calling subroutine\n*\n*       OPTS    (input) character string\n*               This is a concatenation of the string arguments to\n*               TTQRE.\n*\n*       N       (input) integer scalar\n*               N is the order of the Hessenberg matrix H.\n*\n*       ILO     (input) INTEGER\n*       IHI     (input) INTEGER\n*               It is assumed that H is already upper triangular\n*               in rows and columns 1:ILO-1 and IHI+1:N.\n*\n*       LWORK   (input) integer scalar\n*               The amount of workspace available.\n*\n\n*  Further Details\n*  ===============\n*\n*       Little is known about how best to choose these parameters.\n*       It is possible to use different values of the parameters\n*       for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR.\n*\n*       It is probably best to choose different parameters for\n*       different matrices and different parameters at different\n*       times during the iteration, but this has not been\n*       implemented --- yet.\n*\n*\n*       The best choices of most of the parameters depend\n*       in an ill-understood way on the relative execution\n*       rate of xLAQR3 and xLAQR5 and on the nature of each\n*       particular eigenvalue problem.  Experiment may be the\n*       only practical way to determine which choices are most\n*       effective.\n*\n*       Following is a list of default values supplied by IPARMQ.\n*       These defaults may be adjusted in order to attain better\n*       performance in any particular computational environment.\n*\n*       IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point.\n*                        Default: 75. (Must be at least 11.)\n*\n*       IPARMQ(ISPEC=13) Recommended deflation window size.\n*                        This depends on ILO, IHI and NS, the\n*                        number of simultaneous shifts returned\n*                        by IPARMQ(ISPEC=15).  The default for\n*                        (IHI-ILO+1).LE.500 is NS.  The default\n*                        for (IHI-ILO+1).GT.500 is 3*NS/2.\n*\n*       IPARMQ(ISPEC=14) Nibble crossover point.  Default: 14.\n*\n*       IPARMQ(ISPEC=15) Number of simultaneous shifts, NS.\n*                        a multi-shift QR iteration.\n*\n*                        If IHI-ILO+1 is ...\n*\n*                        greater than      ...but less    ... the\n*                        or equal to ...      than        default is\n*\n*                                0               30       NS =   2+\n*                               30               60       NS =   4+\n*                               60              150       NS =  10\n*                              150              590       NS =  **\n*                              590             3000       NS =  64\n*                             3000             6000       NS = 128\n*                             6000             infinity   NS = 256\n*\n*                    (+)  By default matrices of this order are\n*                         passed to the implicit double shift routine\n*                         xLAHQR.  See IPARMQ(ISPEC=12) above.   These\n*                         values of NS are used only in case of a rare\n*                         xLAHQR failure.\n*\n*                    (**) The asterisks (**) indicate an ad-hoc\n*                         function increasing from 10 to 64.\n*\n*       IPARMQ(ISPEC=16) Select structured matrix multiply.\n*                        (See ISPEC=16 above for details.)\n*                        Default: 3.\n*\n*     ================================================================\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.iparmq( ispec, name, opts, n, ilo, ihi, lwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_ispec = argv[0];
  rblapack_name = argv[1];
  rblapack_opts = argv[2];
  rblapack_n = argv[3];
  rblapack_ilo = argv[4];
  rblapack_ihi = argv[5];
  rblapack_lwork = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  ispec = NUM2INT(rblapack_ispec);
  opts = StringValueCStr(rblapack_opts)[0];
  ilo = NUM2INT(rblapack_ilo);
  lwork = NUM2INT(rblapack_lwork);
  name = StringValueCStr(rblapack_name)[0];
  ihi = NUM2INT(rblapack_ihi);
  n = NUM2INT(rblapack_n);

  __out__ = iparmq_(&ispec, &name, &opts, &n, &ilo, &ihi, &lwork);

  rblapack___out__ = INT2NUM(__out__);
  return rblapack___out__;
}

void
init_lapack_iparmq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "iparmq", rblapack_iparmq, -1);
}
ruby-lapack-1.7.2/ext/zgeqp3.c0000644000175000017500000001564612502221013015744 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgeqp3_(integer* m, integer* n, doublecomplex* a, integer* lda, integer* jpvt, doublecomplex* tau, doublecomplex* work, integer* lwork, doublereal* rwork, integer* info);


static VALUE
rblapack_zgeqp3(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_jpvt;
  integer *jpvt; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_jpvt_out__;
  integer *jpvt_out__;
  doublereal *rwork;

  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, jpvt = NumRu::Lapack.zgeqp3( m, a, jpvt, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGEQP3 computes a QR factorization with column pivoting of a\n*  matrix A:  A*P = Q*R  using Level 3 BLAS.\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) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, the upper triangle of the array contains the\n*          min(M,N)-by-N upper trapezoidal matrix R; the elements below\n*          the diagonal, together with the array TAU, represent the\n*          unitary matrix Q as a product of min(M,N) elementary\n*          reflectors.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  JPVT    (input/output) INTEGER array, dimension (N)\n*          On entry, if JPVT(J).ne.0, the J-th column of A is permuted\n*          to the front of A*P (a leading column); if JPVT(J)=0,\n*          the J-th column of A is a free column.\n*          On exit, if JPVT(J)=K, then the J-th column of A*P was the\n*          the K-th column of A.\n*\n*  TAU     (output) COMPLEX*16 array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors.\n*\n*  WORK    (workspace/output) COMPLEX*16 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 >= N+1.\n*          For optimal performance LWORK >= ( N+1 )*NB, where NB\n*          is the 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*  RWORK   (workspace) DOUBLE PRECISION array, dimension (2*N)\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(1) H(2) . . . H(k), 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/complex scalar, and v is a real/complex vector\n*  with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in\n*  A(i+1:m,i), and tau in TAU(i).\n*\n*  Based on contributions by\n*    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n*    X. Sun, Computer Science Dept., Duke University, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, work, info, a, jpvt = NumRu::Lapack.zgeqp3( m, a, jpvt, [: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_m = argv[0];
  rblapack_a = argv[1];
  rblapack_jpvt = 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;
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_jpvt))
    rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
  if (NA_RANK(rblapack_jpvt) != 1)
    rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_jpvt);
  if (NA_TYPE(rblapack_jpvt) != NA_LINT)
    rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
  jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of jpvt");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (rblapack_lwork == Qnil)
    lwork = n+1;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
  MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
  rblapack_jpvt = rblapack_jpvt_out__;
  jpvt = jpvt_out__;
  rwork = ALLOC_N(doublereal, (2*n));

  zgeqp3_(&m, &n, a, &lda, jpvt, tau, work, &lwork, rwork, &info);

  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_tau, rblapack_work, rblapack_info, rblapack_a, rblapack_jpvt);
}

void
init_lapack_zgeqp3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgeqp3", rblapack_zgeqp3, -1);
}
ruby-lapack-1.7.2/ext/zla_gbrcond_x.c0000644000175000017500000002044612502221021017337 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal zla_gbrcond_x_(char* trans, integer* n, integer* kl, integer* ku, doublecomplex* ab, integer* ldab, doublecomplex* afb, integer* ldafb, integer* ipiv, doublecomplex* x, integer* info, doublecomplex* work, doublereal* rwork);


static VALUE
rblapack_zla_gbrcond_x(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_afb;
  doublecomplex *afb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_rwork;
  doublereal *rwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack___out__;
  doublereal __out__; 

  integer ldab;
  integer n;
  integer ldafb;

  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  info, __out__ = NumRu::Lapack.zla_gbrcond_x( trans, kl, ku, ab, afb, ipiv, x, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION ZLA_GBRCOND_X( TRANS, N, KL, KU, AB, LDAB, AFB, LDAFB, IPIV, X, INFO, WORK, RWORK )\n\n*  Purpose\n*  =======\n*\n*     ZLA_GBRCOND_X Computes the infinity norm condition number of\n*     op(A) * diag(X) where X is a COMPLEX*16 vector.\n*\n\n*  Arguments\n*  =========\n*\n*     TRANS   (input) CHARACTER*1\n*     Specifies the form of the system of equations:\n*       = 'N':  A * X = B     (No transpose)\n*       = 'T':  A**T * X = B  (Transpose)\n*       = 'C':  A**H * X = B  (Conjugate Transpose = Transpose)\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     KL      (input) INTEGER\n*     The number of subdiagonals within the band of A.  KL >= 0.\n*\n*     KU      (input) INTEGER\n*     The number of superdiagonals within the band of A.  KU >= 0.\n*\n*     AB      (input) COMPLEX*16 array, dimension (LDAB,N)\n*     On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n*     The j-th column of A is stored in the j-th column of the\n*     array AB as follows:\n*     AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n*     LDAB    (input) INTEGER\n*     The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*     AFB     (input) COMPLEX*16 array, dimension (LDAFB,N)\n*     Details of the LU factorization of the band matrix A, as\n*     computed by ZGBTRF.  U is stored as an upper triangular\n*     band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n*     and the multipliers used during the factorization are stored\n*     in rows KL+KU+2 to 2*KL+KU+1.\n*\n*     LDAFB   (input) INTEGER\n*     The leading dimension of the array AFB.  LDAFB >= 2*KL+KU+1.\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     The pivot indices from the factorization A = P*L*U\n*     as computed by ZGBTRF; row i of the matrix was interchanged\n*     with row IPIV(i).\n*\n*     X       (input) COMPLEX*16 array, dimension (N)\n*     The vector X in the formula op(A) * diag(X).\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit.\n*     i > 0:  The ith argument is invalid.\n*\n*     WORK    (input) COMPLEX*16 array, dimension (2*N).\n*     Workspace.\n*\n*     RWORK   (input) DOUBLE PRECISION array, dimension (N).\n*     Workspace.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            NOTRANS\n      INTEGER            KASE, I, J\n      DOUBLE PRECISION   AINVNM, ANORM, TMP\n      COMPLEX*16         ZDUM\n*     ..\n*     .. Local Arrays ..\n      INTEGER            ISAVE( 3 )\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           ZLACN2, ZGBTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX\n*     ..\n*     .. Statement Functions ..\n      DOUBLE PRECISION   CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, __out__ = NumRu::Lapack.zla_gbrcond_x( trans, kl, ku, ab, afb, ipiv, x, work, rwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_trans = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  rblapack_afb = argv[4];
  rblapack_ipiv = argv[5];
  rblapack_x = argv[6];
  rblapack_work = argv[7];
  rblapack_rwork = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
  ldafb = NA_SHAPE0(rblapack_afb);
  n = NA_SHAPE1(rblapack_afb);
  if (NA_TYPE(rblapack_afb) != NA_DCOMPLEX)
    rblapack_afb = na_change_type(rblapack_afb, NA_DCOMPLEX);
  afb = NA_PTR_TYPE(rblapack_afb, doublecomplex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (7th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  if (!NA_IsNArray(rblapack_rwork))
    rb_raise(rb_eArgError, "rwork (9th argument) must be NArray");
  if (NA_RANK(rblapack_rwork) != 1)
    rb_raise(rb_eArgError, "rank of rwork (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_rwork) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_rwork) != NA_DFLOAT)
    rblapack_rwork = na_change_type(rblapack_rwork, NA_DFLOAT);
  rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (8th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
  if (NA_TYPE(rblapack_work) != NA_DCOMPLEX)
    rblapack_work = na_change_type(rblapack_work, NA_DCOMPLEX);
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);

  __out__ = zla_gbrcond_x_(&trans, &n, &kl, &ku, ab, &ldab, afb, &ldafb, ipiv, x, &info, work, rwork);

  rblapack_info = INT2NUM(info);
  rblapack___out__ = rb_float_new((double)__out__);
  return rb_ary_new3(2, rblapack_info, rblapack___out__);
}

void
init_lapack_zla_gbrcond_x(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zla_gbrcond_x", rblapack_zla_gbrcond_x, -1);
}
ruby-lapack-1.7.2/ext/spftrf.c0000644000175000017500000001707212502221013016032 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID spftrf_(char* transr, char* uplo, integer* n, real* a, integer* info);


static VALUE
rblapack_spftrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;


  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  info, a = NumRu::Lapack.spftrf( transr, uplo, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPFTRF( TRANSR, UPLO, N, A, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPFTRF computes the Cholesky factorization of a real symmetric\n*  positive definite matrix A.\n*\n*  The factorization has the form\n*     A = U**T * U,  if UPLO = 'U', or\n*     A = L  * L**T,  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is lower triangular.\n*\n*  This is the block version of the algorithm, calling Level 3 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR    (input) CHARACTER*1\n*          = 'N':  The Normal TRANSR of RFP A is stored;\n*          = 'T':  The Transpose TRANSR of RFP A is stored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of RFP A is stored;\n*          = 'L':  Lower triangle of RFP A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension ( N*(N+1)/2 );\n*          On entry, the symmetric matrix A in RFP format. RFP format is\n*          described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n*          then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n*          (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is\n*          the transpose of RFP A as defined when\n*          TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n*          follows: If UPLO = 'U' the RFP A contains the NT elements of\n*          upper packed A. If UPLO = 'L' the RFP A contains the elements\n*          of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n*          'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n*          is odd. See the Note below for more details.\n*\n*          On exit, if INFO = 0, the factor U or L from the Cholesky\n*          factorization RFP A = U**T*U or RFP A = L*L**T.\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 leading minor of order i is not\n*                positive definite, and the factorization could not be\n*                completed.\n*\n\n*  Further Details\n*  ===============\n*\n*  We first consider Rectangular Full Packed (RFP) Format when N is\n*  even. We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  the transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  the transpose of the last three columns of AP lower.\n*  This covers the case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        03 04 05                33 43 53\n*        13 14 15                00 44 54\n*        23 24 25                10 11 55\n*        33 34 35                20 21 22\n*        00 44 45                30 31 32\n*        01 11 55                40 41 42\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We then consider Rectangular Full Packed (RFP) Format when N is\n*  odd. We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  the transpose of the first two columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  the transpose of the last two columns of AP lower.\n*  This covers the case N odd and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        02 03 04                00 33 43\n*        12 13 14                10 11 44\n*        22 23 24                20 21 22\n*        00 33 34                30 31 32\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*           RFP A                   RFP A\n*\n*     02 12 22 00 01             00 10 20 30 40 50\n*     03 13 23 33 11             33 11 21 31 41 51\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.spftrf( transr, uplo, n, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_n = argv[2];
  rblapack_a = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  n = NUM2INT(rblapack_n);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 1)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  spftrf_(&transr, &uplo, &n, a, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_spftrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "spftrf", rblapack_spftrf, -1);
}
ruby-lapack-1.7.2/ext/dgesvd.c0000644000175000017500000002335112502221020015775 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgesvd_(char* jobu, char* jobvt, integer* m, integer* n, doublereal* a, integer* lda, doublereal* s, doublereal* u, integer* ldu, doublereal* vt, integer* ldvt, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dgesvd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobu;
  char jobu; 
  VALUE rblapack_jobvt;
  char jobvt; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_u;
  doublereal *u; 
  VALUE rblapack_vt;
  doublereal *vt; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;

  integer lda;
  integer n;
  integer ldu;
  integer ldvt;
  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  s, u, vt, work, info, a = NumRu::Lapack.dgesvd( jobu, jobvt, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGESVD computes the singular value decomposition (SVD) of a real\n*  M-by-N matrix A, optionally computing the left and/or right singular\n*  vectors. The SVD is written\n*\n*       A = U * SIGMA * transpose(V)\n*\n*  where SIGMA is an M-by-N matrix which is zero except for its\n*  min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and\n*  V is an N-by-N orthogonal matrix.  The diagonal elements of SIGMA\n*  are the singular values of A; they are real and non-negative, and\n*  are returned in descending order.  The first min(m,n) columns of\n*  U and V are the left and right singular vectors of A.\n*\n*  Note that the routine returns V**T, not V.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBU    (input) CHARACTER*1\n*          Specifies options for computing all or part of the matrix U:\n*          = 'A':  all M columns of U are returned in array U:\n*          = 'S':  the first min(m,n) columns of U (the left singular\n*                  vectors) are returned in the array U;\n*          = 'O':  the first min(m,n) columns of U (the left singular\n*                  vectors) are overwritten on the array A;\n*          = 'N':  no columns of U (no left singular vectors) are\n*                  computed.\n*\n*  JOBVT   (input) CHARACTER*1\n*          Specifies options for computing all or part of the matrix\n*          V**T:\n*          = 'A':  all N rows of V**T are returned in the array VT;\n*          = 'S':  the first min(m,n) rows of V**T (the right singular\n*                  vectors) are returned in the array VT;\n*          = 'O':  the first min(m,n) rows of V**T (the right singular\n*                  vectors) are overwritten on the array A;\n*          = 'N':  no rows of V**T (no right singular vectors) are\n*                  computed.\n*\n*          JOBVT and JOBU cannot both be 'O'.\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.  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,\n*          if JOBU = 'O',  A is overwritten with the first min(m,n)\n*                          columns of U (the left singular vectors,\n*                          stored columnwise);\n*          if JOBVT = 'O', A is overwritten with the first min(m,n)\n*                          rows of V**T (the right singular vectors,\n*                          stored rowwise);\n*          if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A\n*                          are destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  S       (output) DOUBLE PRECISION array, dimension (min(M,N))\n*          The singular values of A, sorted so that S(i) >= S(i+1).\n*\n*  U       (output) DOUBLE PRECISION array, dimension (LDU,UCOL)\n*          (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.\n*          If JOBU = 'A', U contains the M-by-M orthogonal matrix U;\n*          if JOBU = 'S', U contains the first min(m,n) columns of U\n*          (the left singular vectors, stored columnwise);\n*          if JOBU = 'N' or 'O', U is not referenced.\n*\n*  LDU     (input) INTEGER\n*          The leading dimension of the array U.  LDU >= 1; if\n*          JOBU = 'S' or 'A', LDU >= M.\n*\n*  VT      (output) DOUBLE PRECISION array, dimension (LDVT,N)\n*          If JOBVT = 'A', VT contains the N-by-N orthogonal matrix\n*          V**T;\n*          if JOBVT = 'S', VT contains the first min(m,n) rows of\n*          V**T (the right singular vectors, stored rowwise);\n*          if JOBVT = 'N' or 'O', VT is not referenced.\n*\n*  LDVT    (input) INTEGER\n*          The leading dimension of the array VT.  LDVT >= 1; if\n*          JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(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*          if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged\n*          superdiagonal elements of an upper bidiagonal matrix B\n*          whose diagonal is in S (not necessarily sorted). B\n*          satisfies A = U * B * VT, so it has the same singular values\n*          as A, and singular vectors related by U and VT.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK.\n*          LWORK >= MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)).\n*          For good performance, LWORK should generally be larger.\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 DBDSQR did not converge, INFO specifies how many\n*                superdiagonals of an intermediate bidiagonal form B\n*                did not converge to zero. See the description of WORK\n*                above for details.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, u, vt, work, info, a = NumRu::Lapack.dgesvd( jobu, jobvt, a, [: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_jobu = argv[0];
  rblapack_jobvt = argv[1];
  rblapack_a = 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;
  }

  jobu = StringValueCStr(rblapack_jobu)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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;
  ldu = ((lsame_(&jobu,"S")) || (lsame_(&jobu,"A"))) ? m : 1;
  jobvt = StringValueCStr(rblapack_jobvt)[0];
  ldvt = lsame_(&jobvt,"A") ? n : lsame_(&jobvt,"S") ? MIN(m,n) : 1;
  if (rblapack_lwork == Qnil)
    lwork = MAX(MAX(1, 3*MIN(m,n)+MAX(m,n)), 5*MIN(m,n));
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = lsame_(&jobu,"A") ? m : lsame_(&jobu,"S") ? MIN(m,n) : 0;
    rblapack_u = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  u = NA_PTR_TYPE(rblapack_u, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldvt;
    shape[1] = n;
    rblapack_vt = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vt = NA_PTR_TYPE(rblapack_vt, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = MAX(n, MIN(m,n));
    rblapack_a_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublereal*);
  {
    VALUE __shape__[3];
    __shape__[0] = Qtrue;
    __shape__[1] = n < MIN(m,n) ? rb_range_new(rblapack_ZERO, INT2NUM(n), Qtrue) : Qtrue;
    __shape__[2] = rblapack_a;
    na_aset(3, __shape__, rblapack_a_out__);
  }
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  dgesvd_(&jobu, &jobvt, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  {
    VALUE __shape__[2];
    __shape__[0] = Qtrue;
    __shape__[1] = n < MIN(m,n) ? Qtrue : rb_range_new(rblapack_ZERO, INT2NUM(MIN(m,n)), Qtrue);
    rblapack_a = na_aref(2, __shape__, rblapack_a);
  }
  return rb_ary_new3(6, rblapack_s, rblapack_u, rblapack_vt, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_dgesvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgesvd", rblapack_dgesvd, -1);
}
ruby-lapack-1.7.2/ext/cpttrf.c0000644000175000017500000001037312502221020016023 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cpttrf_(integer* n, real* d, complex* e, integer* info);


static VALUE
rblapack_cpttrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  complex *e; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_e_out__;
  complex *e_out__;

  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  info, d, e = NumRu::Lapack.cpttrf( d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPTTRF( N, D, E, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPTTRF computes the L*D*L' factorization of a complex Hermitian\n*  positive definite tridiagonal matrix A.  The factorization may also\n*  be regarded as having the form A = U'*D*U.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  D       (input/output) REAL array, dimension (N)\n*          On entry, the n diagonal elements of the tridiagonal matrix\n*          A.  On exit, the n diagonal elements of the diagonal matrix\n*          D from the L*D*L' factorization of A.\n*\n*  E       (input/output) COMPLEX array, dimension (N-1)\n*          On entry, the (n-1) subdiagonal elements of the tridiagonal\n*          matrix A.  On exit, the (n-1) subdiagonal elements of the\n*          unit bidiagonal factor L from the L*D*L' factorization of A.\n*          E can also be regarded as the superdiagonal of the unit\n*          bidiagonal factor U from the U'*D*U factorization of A.\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*          > 0: if INFO = k, the leading minor of order k is not\n*               positive definite; if k < N, the factorization could not\n*               be completed, while if k = N, the factorization was\n*               completed, but D(N) <= 0.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, e = NumRu::Lapack.cpttrf( d, e, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_d = argv[0];
  rblapack_e = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (2th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SCOMPLEX)
    rblapack_e = na_change_type(rblapack_e, NA_SCOMPLEX);
  e = NA_PTR_TYPE(rblapack_e, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, complex*);
  MEMCPY(e_out__, e, complex, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;

  cpttrf_(&n, d, e, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_d, rblapack_e);
}

void
init_lapack_cpttrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cpttrf", rblapack_cpttrf, -1);
}
ruby-lapack-1.7.2/ext/rb_lapack.h0000644000175000017500000000115112655767577016507 0ustar  uwabamiuwabami#include 
#include 
#include "ruby.h"
#include "narray.h"
#include "f2c_minimal.h"

#define MAX(a,b) ((a) > (b) ? (a) : (b))
#define MIN(a,b) ((a) < (b) ? (a) : (b))
#define LG(n) ((int)ceil(log((double)(n))/log(2.0)))

extern logical lsame_(char *ca, char *cb);
extern integer ilatrans_(char* trans);
extern integer ilaenv_(integer* ispec, char* name, char* opts, integer* n1, integer* n2, integer* n3, integer* n4);


static VALUE sHelp, sUsage;
static VALUE rblapack_ZERO;

/* for compatibility for NArray and NArray with bigmem patch */
#ifndef NARRAY_BIGMEM
typedef int    na_shape_t;
#endif


ruby-lapack-1.7.2/ext/dlaqr4.c0000644000175000017500000002765012502221014015721 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaqr4_(logical* wantt, logical* wantz, integer* n, integer* ilo, integer* ihi, doublereal* h, integer* ldh, doublereal* wr, doublereal* wi, integer* iloz, integer* ihiz, doublereal* z, integer* ldz, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dlaqr4(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantt;
  logical wantt; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_h;
  doublereal *h; 
  VALUE rblapack_iloz;
  integer iloz; 
  VALUE rblapack_ihiz;
  integer ihiz; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_wr;
  doublereal *wr; 
  VALUE rblapack_wi;
  doublereal *wi; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_h_out__;
  doublereal *h_out__;
  VALUE rblapack_z_out__;
  doublereal *z_out__;

  integer ldh;
  integer n;
  integer ldz;
  integer ihi;

  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  wr, wi, work, info, h, z = NumRu::Lapack.dlaqr4( wantt, wantz, ilo, h, iloz, ihiz, z, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     DLAQR4 computes the eigenvalues of a Hessenberg matrix H\n*     and, optionally, the matrices T and Z from the Schur decomposition\n*     H = Z T Z**T, where T is an upper quasi-triangular matrix (the\n*     Schur form), and Z is the orthogonal matrix of Schur vectors.\n*\n*     Optionally Z may be postmultiplied into an input orthogonal\n*     matrix Q so that this routine can give the Schur factorization\n*     of a matrix A which has been reduced to the Hessenberg form H\n*     by the orthogonal matrix Q:  A = Q*H*Q**T = (QZ)*T*(QZ)**T.\n*\n\n*     Arguments\n*     =========\n*\n*     WANTT   (input) LOGICAL\n*          = .TRUE. : the full Schur form T is required;\n*          = .FALSE.: only eigenvalues are required.\n*\n*     WANTZ   (input) LOGICAL\n*          = .TRUE. : the matrix of Schur vectors Z is required;\n*          = .FALSE.: Schur vectors are not required.\n*\n*     N     (input) INTEGER\n*           The order of the matrix H.  N .GE. 0.\n*\n*     ILO   (input) INTEGER\n*     IHI   (input) INTEGER\n*           It is assumed that H is already upper triangular in rows\n*           and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n*           H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n*           previous call to DGEBAL, and then passed to DGEHRD when the\n*           matrix output by DGEBAL is reduced to Hessenberg form.\n*           Otherwise, ILO and IHI should be set to 1 and N,\n*           respectively.  If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n*           If N = 0, then ILO = 1 and IHI = 0.\n*\n*     H     (input/output) DOUBLE PRECISION array, dimension (LDH,N)\n*           On entry, the upper Hessenberg matrix H.\n*           On exit, if INFO = 0 and WANTT is .TRUE., then H contains\n*           the upper quasi-triangular matrix T from the Schur\n*           decomposition (the Schur form); 2-by-2 diagonal blocks\n*           (corresponding to complex conjugate pairs of eigenvalues)\n*           are returned in standard form, with H(i,i) = H(i+1,i+1)\n*           and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is\n*           .FALSE., then the contents of H are unspecified on exit.\n*           (The output value of H when INFO.GT.0 is given under the\n*           description of INFO below.)\n*\n*           This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n*           j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n*\n*     LDH   (input) INTEGER\n*           The leading dimension of the array H. LDH .GE. max(1,N).\n*\n*     WR    (output) DOUBLE PRECISION array, dimension (IHI)\n*     WI    (output) DOUBLE PRECISION array, dimension (IHI)\n*           The real and imaginary parts, respectively, of the computed\n*           eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI)\n*           and WI(ILO:IHI). If two eigenvalues are computed as a\n*           complex conjugate pair, they are stored in consecutive\n*           elements of WR and WI, say the i-th and (i+1)th, with\n*           WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then\n*           the eigenvalues are stored in the same order as on the\n*           diagonal of the Schur form returned in H, with\n*           WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal\n*           block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and\n*           WI(i+1) = -WI(i).\n*\n*     ILOZ     (input) INTEGER\n*     IHIZ     (input) INTEGER\n*           Specify the rows of Z to which transformations must be\n*           applied if WANTZ is .TRUE..\n*           1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.\n*\n*     Z     (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI)\n*           If WANTZ is .FALSE., then Z is not referenced.\n*           If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n*           replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n*           orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n*           (The output value of Z when INFO.GT.0 is given under\n*           the description of INFO below.)\n*\n*     LDZ   (input) INTEGER\n*           The leading dimension of the array Z.  if WANTZ is .TRUE.\n*           then LDZ.GE.MAX(1,IHIZ).  Otherwize, LDZ.GE.1.\n*\n*     WORK  (workspace/output) DOUBLE PRECISION array, dimension LWORK\n*           On exit, if LWORK = -1, WORK(1) returns an estimate of\n*           the optimal value for LWORK.\n*\n*     LWORK (input) INTEGER\n*           The dimension of the array WORK.  LWORK .GE. max(1,N)\n*           is sufficient, but LWORK typically as large as 6*N may\n*           be required for optimal performance.  A workspace query\n*           to determine the optimal workspace size is recommended.\n*\n*           If LWORK = -1, then DLAQR4 does a workspace query.\n*           In this case, DLAQR4 checks the input parameters and\n*           estimates the optimal workspace size for the given\n*           values of N, ILO and IHI.  The estimate is returned\n*           in WORK(1).  No error message related to LWORK is\n*           issued by XERBLA.  Neither H nor Z are accessed.\n*\n*\n*     INFO  (output) INTEGER\n*             =  0:  successful exit\n*           .GT. 0:  if INFO = i, DLAQR4 failed to compute all of\n*                the eigenvalues.  Elements 1:ilo-1 and i+1:n of WR\n*                and WI contain those eigenvalues which have been\n*                successfully computed.  (Failures are rare.)\n*\n*                If INFO .GT. 0 and WANT is .FALSE., then on exit,\n*                the remaining unconverged eigenvalues are the eigen-\n*                values of the upper Hessenberg matrix rows and\n*                columns ILO through INFO of the final, output\n*                value of H.\n*\n*                If INFO .GT. 0 and WANTT is .TRUE., then on exit\n*\n*           (*)  (initial value of H)*U  = U*(final value of H)\n*\n*                where U is an orthogonal matrix.  The final\n*                value of H is upper Hessenberg and quasi-triangular\n*                in rows and columns INFO+1 through IHI.\n*\n*                If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n*\n*                  (final value of Z(ILO:IHI,ILOZ:IHIZ)\n*                   =  (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n*\n*                where U is the orthogonal matrix in (*) (regard-\n*                less of the value of WANTT.)\n*\n*                If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n*                accessed.\n*\n\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n*     References:\n*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n*       Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n*       Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n*       929--947, 2002.\n*\n*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n*       Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n*       of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n*     ================================================================\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  wr, wi, work, info, h, z = NumRu::Lapack.dlaqr4( wantt, wantz, ilo, h, iloz, ihiz, z, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_wantt = argv[0];
  rblapack_wantz = argv[1];
  rblapack_ilo = argv[2];
  rblapack_h = argv[3];
  rblapack_iloz = argv[4];
  rblapack_ihiz = argv[5];
  rblapack_z = argv[6];
  if (argc == 8) {
    rblapack_lwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  wantt = (rblapack_wantt == Qtrue);
  ilo = NUM2INT(rblapack_ilo);
  iloz = NUM2INT(rblapack_iloz);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (7th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  ihi = NA_SHAPE1(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  wantz = (rblapack_wantz == Qtrue);
  ihiz = NUM2INT(rblapack_ihiz);
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (4th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (4th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_DFLOAT)
    rblapack_h = na_change_type(rblapack_h, NA_DFLOAT);
  h = NA_PTR_TYPE(rblapack_h, doublereal*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = ihi;
    rblapack_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  wr = NA_PTR_TYPE(rblapack_wr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = ihi;
    rblapack_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  wi = NA_PTR_TYPE(rblapack_wi, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublereal*);
  MEMCPY(h_out__, h, doublereal, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = ihi;
    rblapack_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
  MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  dlaqr4_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, wr, wi, &iloz, &ihiz, z, &ldz, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_wr, rblapack_wi, rblapack_work, rblapack_info, rblapack_h, rblapack_z);
}

void
init_lapack_dlaqr4(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaqr4", rblapack_dlaqr4, -1);
}
ruby-lapack-1.7.2/ext/dlaed9.c0000644000175000017500000001462512502221015015673 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaed9_(integer* k, integer* kstart, integer* kstop, integer* n, doublereal* d, doublereal* q, integer* ldq, doublereal* rho, doublereal* dlamda, doublereal* w, doublereal* s, integer* lds, integer* info);


static VALUE
rblapack_dlaed9(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_kstart;
  integer kstart; 
  VALUE rblapack_kstop;
  integer kstop; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_rho;
  doublereal rho; 
  VALUE rblapack_dlamda;
  doublereal *dlamda; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_info;
  integer info; 
  doublereal *q;

  integer k;
  integer lds;
  integer ldq;

  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  d, s, info = NumRu::Lapack.dlaed9( kstart, kstop, n, rho, dlamda, w, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W, S, LDS, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLAED9 finds the roots of the secular equation, as defined by the\n*  values in D, Z, and RHO, between KSTART and KSTOP.  It makes the\n*  appropriate calls to DLAED4 and then stores the new matrix of\n*  eigenvectors for use in calculating the next level of Z vectors.\n*\n\n*  Arguments\n*  =========\n*\n*  K       (input) INTEGER\n*          The number of terms in the rational function to be solved by\n*          DLAED4.  K >= 0.\n*\n*  KSTART  (input) INTEGER\n*  KSTOP   (input) INTEGER\n*          The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP\n*          are to be computed.  1 <= KSTART <= KSTOP <= K.\n*\n*  N       (input) INTEGER\n*          The number of rows and columns in the Q matrix.\n*          N >= K (delation may result in N > K).\n*\n*  D       (output) DOUBLE PRECISION array, dimension (N)\n*          D(I) contains the updated eigenvalues\n*          for KSTART <= I <= KSTOP.\n*\n*  Q       (workspace) DOUBLE PRECISION array, dimension (LDQ,N)\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.  LDQ >= max( 1, N ).\n*\n*  RHO     (input) DOUBLE PRECISION\n*          The value of the parameter in the rank one update equation.\n*          RHO >= 0 required.\n*\n*  DLAMDA  (input) DOUBLE PRECISION array, dimension (K)\n*          The first K elements of this array contain the old roots\n*          of the deflated updating problem.  These are the poles\n*          of the secular equation.\n*\n*  W       (input) DOUBLE PRECISION array, dimension (K)\n*          The first K elements of this array contain the components\n*          of the deflation-adjusted updating vector.\n*\n*  S       (output) DOUBLE PRECISION array, dimension (LDS, K)\n*          Will contain the eigenvectors of the repaired matrix which\n*          will be stored for subsequent Z vector calculation and\n*          multiplied by the previously accumulated eigenvectors\n*          to update the system.\n*\n*  LDS     (input) INTEGER\n*          The leading dimension of S.  LDS >= max( 1, K ).\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 = 1, an eigenvalue did not converge\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Jeff Rutter, Computer Science Division, University of California\n*     at Berkeley, USA\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n      DOUBLE PRECISION   TEMP\n*     ..\n*     .. External Functions ..\n      DOUBLE PRECISION   DLAMC3, DNRM2\n      EXTERNAL           DLAMC3, DNRM2\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DCOPY, DLAED4, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, SIGN, SQRT\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, s, info = NumRu::Lapack.dlaed9( kstart, kstop, n, rho, dlamda, w, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_kstart = argv[0];
  rblapack_kstop = argv[1];
  rblapack_n = argv[2];
  rblapack_rho = argv[3];
  rblapack_dlamda = argv[4];
  rblapack_w = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  kstart = NUM2INT(rblapack_kstart);
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_dlamda))
    rb_raise(rb_eArgError, "dlamda (5th argument) must be NArray");
  if (NA_RANK(rblapack_dlamda) != 1)
    rb_raise(rb_eArgError, "rank of dlamda (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_dlamda);
  if (NA_TYPE(rblapack_dlamda) != NA_DFLOAT)
    rblapack_dlamda = na_change_type(rblapack_dlamda, NA_DFLOAT);
  dlamda = NA_PTR_TYPE(rblapack_dlamda, doublereal*);
  ldq = MAX( 1, n );
  kstop = NUM2INT(rblapack_kstop);
  if (!NA_IsNArray(rblapack_w))
    rb_raise(rb_eArgError, "w (6th argument) must be NArray");
  if (NA_RANK(rblapack_w) != 1)
    rb_raise(rb_eArgError, "rank of w (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_w) != k)
    rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of dlamda");
  if (NA_TYPE(rblapack_w) != NA_DFLOAT)
    rblapack_w = na_change_type(rblapack_w, NA_DFLOAT);
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  rho = NUM2DBL(rblapack_rho);
  lds = MAX( 1, k );
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,n);
    rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = lds;
    shape[1] = k;
    rblapack_s = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  q = ALLOC_N(doublereal, (ldq)*(MAX(1,n)));

  dlaed9_(&k, &kstart, &kstop, &n, d, q, &ldq, &rho, dlamda, w, s, &lds, &info);

  free(q);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_d, rblapack_s, rblapack_info);
}

void
init_lapack_dlaed9(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaed9", rblapack_dlaed9, -1);
}
ruby-lapack-1.7.2/ext/zpftri.c0000644000175000017500000002017712502221020016042 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zpftri_(char* transr, char* uplo, integer* n, doublecomplex* a, integer* info);


static VALUE
rblapack_zpftri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;


  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  info, a = NumRu::Lapack.zpftri( transr, uplo, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPFTRI( TRANSR, UPLO, N, A, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPFTRI computes the inverse of a complex Hermitian positive definite\n*  matrix A using the Cholesky factorization A = U**H*U or A = L*L**H\n*  computed by ZPFTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR    (input) CHARACTER*1\n*          = 'N':  The Normal TRANSR of RFP A is stored;\n*          = 'C':  The Conjugate-transpose TRANSR of RFP A is stored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension ( N*(N+1)/2 );\n*          On entry, the Hermitian matrix A in RFP format. RFP format is\n*          described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n*          then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n*          (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is\n*          the Conjugate-transpose of RFP A as defined when\n*          TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n*          follows: If UPLO = 'U' the RFP A contains the nt elements of\n*          upper packed A. If UPLO = 'L' the RFP A contains the elements\n*          of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n*          'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n*          is odd. See the Note below for more details.\n*\n*          On exit, the Hermitian inverse of the original matrix, in the\n*          same storage format.\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,i) element of the factor U or L is\n*                zero, and the inverse could not be computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  We first consider Standard Packed Format when N is even.\n*  We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  conjugate-transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  conjugate-transpose of the last three columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                -- -- --\n*        03 04 05                33 43 53\n*                                   -- --\n*        13 14 15                00 44 54\n*                                      --\n*        23 24 25                10 11 55\n*\n*        33 34 35                20 21 22\n*        --\n*        00 44 45                30 31 32\n*        -- --\n*        01 11 55                40 41 42\n*        -- -- --\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- -- --                -- -- -- -- -- --\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     -- -- -- -- --                -- -- -- -- --\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     -- -- -- -- -- --                -- -- -- --\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We next  consider Standard Packed Format when N is odd.\n*  We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  conjugate-transpose of the first two   columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  conjugate-transpose of the last two   columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N odd  and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                   -- --\n*        02 03 04                00 33 43\n*                                      --\n*        12 13 14                10 11 44\n*\n*        22 23 24                20 21 22\n*        --\n*        00 33 34                30 31 32\n*        -- --\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- --                   -- -- -- -- -- --\n*     02 12 22 00 01             00 10 20 30 40 50\n*     -- -- -- --                   -- -- -- -- --\n*     03 13 23 33 11             33 11 21 31 41 51\n*     -- -- -- -- --                   -- -- -- --\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.zpftri( transr, uplo, n, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_n = argv[2];
  rblapack_a = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  n = NUM2INT(rblapack_n);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 1)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zpftri_(&transr, &uplo, &n, a, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_zpftri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zpftri", rblapack_zpftri, -1);
}
ruby-lapack-1.7.2/ext/ztgevc.c0000644000175000017500000002474712502221014016040 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztgevc_(char* side, char* howmny, logical* select, integer* n, doublecomplex* s, integer* lds, doublecomplex* p, integer* ldp, doublecomplex* vl, integer* ldvl, doublecomplex* vr, integer* ldvr, integer* mm, integer* m, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_ztgevc(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_howmny;
  char howmny; 
  VALUE rblapack_select;
  logical *select; 
  VALUE rblapack_s;
  doublecomplex *s; 
  VALUE rblapack_p;
  doublecomplex *p; 
  VALUE rblapack_vl;
  doublecomplex *vl; 
  VALUE rblapack_vr;
  doublecomplex *vr; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_vl_out__;
  doublecomplex *vl_out__;
  VALUE rblapack_vr_out__;
  doublecomplex *vr_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer n;
  integer lds;
  integer ldp;
  integer ldvl;
  integer mm;
  integer ldvr;

  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  m, info, vl, vr = NumRu::Lapack.ztgevc( side, howmny, select, s, p, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTGEVC computes some or all of the right and/or left eigenvectors of\n*  a pair of complex matrices (S,P), where S and P are upper triangular.\n*  Matrix pairs of this type are produced by the generalized Schur\n*  factorization of a complex matrix pair (A,B):\n*  \n*     A = Q*S*Z**H,  B = Q*P*Z**H\n*  \n*  as computed by ZGGHRD + ZHGEQZ.\n*  \n*  The right eigenvector x and the left eigenvector y of (S,P)\n*  corresponding to an eigenvalue w are defined by:\n*  \n*     S*x = w*P*x,  (y**H)*S = w*(y**H)*P,\n*  \n*  where y**H denotes the conjugate tranpose of y.\n*  The eigenvalues are not input to this routine, but are computed\n*  directly from the diagonal elements of S and P.\n*  \n*  This routine returns the matrices X and/or Y of right and left\n*  eigenvectors of (S,P), or the products Z*X and/or Q*Y,\n*  where Z and Q are input matrices.\n*  If Q and Z are the unitary factors from the generalized Schur\n*  factorization of a matrix pair (A,B), then Z*X and Q*Y\n*  are the matrices of right and left eigenvectors of (A,B).\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'R': compute right eigenvectors only;\n*          = 'L': compute left eigenvectors only;\n*          = 'B': compute both right and left eigenvectors.\n*\n*  HOWMNY  (input) CHARACTER*1\n*          = 'A': compute all right and/or left eigenvectors;\n*          = 'B': compute all right and/or left eigenvectors,\n*                 backtransformed by the matrices in VR and/or VL;\n*          = 'S': compute selected right and/or left eigenvectors,\n*                 specified by the logical array SELECT.\n*\n*  SELECT  (input) LOGICAL array, dimension (N)\n*          If HOWMNY='S', SELECT specifies the eigenvectors to be\n*          computed.  The eigenvector corresponding to the j-th\n*          eigenvalue is computed if SELECT(j) = .TRUE..\n*          Not referenced if HOWMNY = 'A' or 'B'.\n*\n*  N       (input) INTEGER\n*          The order of the matrices S and P.  N >= 0.\n*\n*  S       (input) COMPLEX*16 array, dimension (LDS,N)\n*          The upper triangular matrix S from a generalized Schur\n*          factorization, as computed by ZHGEQZ.\n*\n*  LDS     (input) INTEGER\n*          The leading dimension of array S.  LDS >= max(1,N).\n*\n*  P       (input) COMPLEX*16 array, dimension (LDP,N)\n*          The upper triangular matrix P from a generalized Schur\n*          factorization, as computed by ZHGEQZ.  P must have real\n*          diagonal elements.\n*\n*  LDP     (input) INTEGER\n*          The leading dimension of array P.  LDP >= max(1,N).\n*\n*  VL      (input/output) COMPLEX*16 array, dimension (LDVL,MM)\n*          On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n*          contain an N-by-N matrix Q (usually the unitary matrix Q\n*          of left Schur vectors returned by ZHGEQZ).\n*          On exit, if SIDE = 'L' or 'B', VL contains:\n*          if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);\n*          if HOWMNY = 'B', the matrix Q*Y;\n*          if HOWMNY = 'S', the left eigenvectors of (S,P) specified by\n*                      SELECT, stored consecutively in the columns of\n*                      VL, in the same order as their eigenvalues.\n*          Not referenced if SIDE = 'R'.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of array VL.  LDVL >= 1, and if\n*          SIDE = 'L' or 'l' or 'B' or 'b', LDVL >= N.\n*\n*  VR      (input/output) COMPLEX*16 array, dimension (LDVR,MM)\n*          On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n*          contain an N-by-N matrix Q (usually the unitary matrix Z\n*          of right Schur vectors returned by ZHGEQZ).\n*          On exit, if SIDE = 'R' or 'B', VR contains:\n*          if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);\n*          if HOWMNY = 'B', the matrix Z*X;\n*          if HOWMNY = 'S', the right eigenvectors of (S,P) specified by\n*                      SELECT, stored consecutively in the columns of\n*                      VR, in the same order as their eigenvalues.\n*          Not referenced if SIDE = 'L'.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the array VR.  LDVR >= 1, and if\n*          SIDE = 'R' or 'B', LDVR >= N.\n*\n*  MM      (input) INTEGER\n*          The number of columns in the arrays VL and/or VR. MM >= M.\n*\n*  M       (output) INTEGER\n*          The number of columns in the arrays VL and/or VR actually\n*          used to store the eigenvectors.  If HOWMNY = 'A' or 'B', M\n*          is set to N.  Each selected eigenvector occupies one column.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (2*N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, info, vl, vr = NumRu::Lapack.ztgevc( side, howmny, select, s, p, vl, vr, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_side = argv[0];
  rblapack_howmny = argv[1];
  rblapack_select = argv[2];
  rblapack_s = argv[3];
  rblapack_p = argv[4];
  rblapack_vl = argv[5];
  rblapack_vr = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_select))
    rb_raise(rb_eArgError, "select (3th argument) must be NArray");
  if (NA_RANK(rblapack_select) != 1)
    rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_select);
  if (NA_TYPE(rblapack_select) != NA_LINT)
    rblapack_select = na_change_type(rblapack_select, NA_LINT);
  select = NA_PTR_TYPE(rblapack_select, logical*);
  if (!NA_IsNArray(rblapack_p))
    rb_raise(rb_eArgError, "p (5th argument) must be NArray");
  if (NA_RANK(rblapack_p) != 2)
    rb_raise(rb_eArgError, "rank of p (5th argument) must be %d", 2);
  ldp = NA_SHAPE0(rblapack_p);
  if (NA_SHAPE1(rblapack_p) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of p must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_p) != NA_DCOMPLEX)
    rblapack_p = na_change_type(rblapack_p, NA_DCOMPLEX);
  p = NA_PTR_TYPE(rblapack_p, doublecomplex*);
  if (!NA_IsNArray(rblapack_vr))
    rb_raise(rb_eArgError, "vr (7th argument) must be NArray");
  if (NA_RANK(rblapack_vr) != 2)
    rb_raise(rb_eArgError, "rank of vr (7th argument) must be %d", 2);
  ldvr = NA_SHAPE0(rblapack_vr);
  mm = NA_SHAPE1(rblapack_vr);
  if (NA_TYPE(rblapack_vr) != NA_DCOMPLEX)
    rblapack_vr = na_change_type(rblapack_vr, NA_DCOMPLEX);
  vr = NA_PTR_TYPE(rblapack_vr, doublecomplex*);
  howmny = StringValueCStr(rblapack_howmny)[0];
  if (!NA_IsNArray(rblapack_vl))
    rb_raise(rb_eArgError, "vl (6th argument) must be NArray");
  if (NA_RANK(rblapack_vl) != 2)
    rb_raise(rb_eArgError, "rank of vl (6th argument) must be %d", 2);
  ldvl = NA_SHAPE0(rblapack_vl);
  if (NA_SHAPE1(rblapack_vl) != mm)
    rb_raise(rb_eRuntimeError, "shape 1 of vl must be the same as shape 1 of vr");
  if (NA_TYPE(rblapack_vl) != NA_DCOMPLEX)
    rblapack_vl = na_change_type(rblapack_vl, NA_DCOMPLEX);
  vl = NA_PTR_TYPE(rblapack_vl, doublecomplex*);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (4th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 2)
    rb_raise(rb_eArgError, "rank of s (4th argument) must be %d", 2);
  lds = NA_SHAPE0(rblapack_s);
  if (NA_SHAPE1(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of s must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_s) != NA_DCOMPLEX)
    rblapack_s = na_change_type(rblapack_s, NA_DCOMPLEX);
  s = NA_PTR_TYPE(rblapack_s, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = mm;
    rblapack_vl_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, doublecomplex*);
  MEMCPY(vl_out__, vl, doublecomplex, NA_TOTAL(rblapack_vl));
  rblapack_vl = rblapack_vl_out__;
  vl = vl_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = mm;
    rblapack_vr_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  vr_out__ = NA_PTR_TYPE(rblapack_vr_out__, doublecomplex*);
  MEMCPY(vr_out__, vr, doublecomplex, NA_TOTAL(rblapack_vr));
  rblapack_vr = rblapack_vr_out__;
  vr = vr_out__;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (2*n));

  ztgevc_(&side, &howmny, select, &n, s, &lds, p, &ldp, vl, &ldvl, vr, &ldvr, &mm, &m, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_m, rblapack_info, rblapack_vl, rblapack_vr);
}

void
init_lapack_ztgevc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztgevc", rblapack_ztgevc, -1);
}
ruby-lapack-1.7.2/ext/dlasq4.c0000644000175000017500000001120212502221025015706 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlasq4_(integer* i0, integer* n0, doublereal* z, integer* pp, integer* n0in, doublereal* dmin, doublereal* dmin1, doublereal* dmin2, doublereal* dn, doublereal* dn1, doublereal* dn2, doublereal* tau, integer* ttype, real* g);


static VALUE
rblapack_dlasq4(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_i0;
  integer i0; 
  VALUE rblapack_n0;
  integer n0; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_pp;
  integer pp; 
  VALUE rblapack_n0in;
  integer n0in; 
  VALUE rblapack_dmin;
  doublereal dmin; 
  VALUE rblapack_dmin1;
  doublereal dmin1; 
  VALUE rblapack_dmin2;
  doublereal dmin2; 
  VALUE rblapack_dn;
  doublereal dn; 
  VALUE rblapack_dn1;
  doublereal dn1; 
  VALUE rblapack_dn2;
  doublereal dn2; 
  VALUE rblapack_g;
  real g; 
  VALUE rblapack_tau;
  doublereal tau; 
  VALUE rblapack_ttype;
  integer ttype; 


  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, ttype, g = NumRu::Lapack.dlasq4( i0, n0, z, pp, n0in, dmin, dmin1, dmin2, dn, dn1, dn2, g, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1, DN2, TAU, TTYPE, G )\n\n*  Purpose\n*  =======\n*\n*  DLASQ4 computes an approximation TAU to the smallest eigenvalue\n*  using values of d from the previous transform.\n*\n\n*  I0    (input) INTEGER\n*        First index.\n*\n*  N0    (input) INTEGER\n*        Last index.\n*\n*  Z     (input) DOUBLE PRECISION array, dimension ( 4*N )\n*        Z holds the qd array.\n*\n*  PP    (input) INTEGER\n*        PP=0 for ping, PP=1 for pong.\n*\n*  NOIN  (input) INTEGER\n*        The value of N0 at start of EIGTEST.\n*\n*  DMIN  (input) DOUBLE PRECISION\n*        Minimum value of d.\n*\n*  DMIN1 (input) DOUBLE PRECISION\n*        Minimum value of d, excluding D( N0 ).\n*\n*  DMIN2 (input) DOUBLE PRECISION\n*        Minimum value of d, excluding D( N0 ) and D( N0-1 ).\n*\n*  DN    (input) DOUBLE PRECISION\n*        d(N)\n*\n*  DN1   (input) DOUBLE PRECISION\n*        d(N-1)\n*\n*  DN2   (input) DOUBLE PRECISION\n*        d(N-2)\n*\n*  TAU   (output) DOUBLE PRECISION\n*        This is the shift.\n*\n*  TTYPE (output) INTEGER\n*        Shift type.\n*\n*  G     (input/output) REAL\n*        G is passed as an argument in order to save its value between\n*        calls to DLASQ4.\n*\n\n*  Further Details\n*  ===============\n*  CNST1 = 9/16\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, ttype, g = NumRu::Lapack.dlasq4( i0, n0, z, pp, n0in, dmin, dmin1, dmin2, dn, dn1, dn2, g, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_i0 = argv[0];
  rblapack_n0 = argv[1];
  rblapack_z = argv[2];
  rblapack_pp = argv[3];
  rblapack_n0in = argv[4];
  rblapack_dmin = argv[5];
  rblapack_dmin1 = argv[6];
  rblapack_dmin2 = argv[7];
  rblapack_dn = argv[8];
  rblapack_dn1 = argv[9];
  rblapack_dn2 = argv[10];
  rblapack_g = argv[11];
  if (argc == 12) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  i0 = NUM2INT(rblapack_i0);
  pp = NUM2INT(rblapack_pp);
  dmin = NUM2DBL(rblapack_dmin);
  dmin2 = NUM2DBL(rblapack_dmin2);
  dn1 = NUM2DBL(rblapack_dn1);
  g = (real)NUM2DBL(rblapack_g);
  n0 = NUM2INT(rblapack_n0);
  n0in = NUM2INT(rblapack_n0in);
  dn = NUM2DBL(rblapack_dn);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (3th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != (4*n0))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 4*n0);
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  dn2 = NUM2DBL(rblapack_dn2);
  dmin1 = NUM2DBL(rblapack_dmin1);

  dlasq4_(&i0, &n0, z, &pp, &n0in, &dmin, &dmin1, &dmin2, &dn, &dn1, &dn2, &tau, &ttype, &g);

  rblapack_tau = rb_float_new((double)tau);
  rblapack_ttype = INT2NUM(ttype);
  rblapack_g = rb_float_new((double)g);
  return rb_ary_new3(3, rblapack_tau, rblapack_ttype, rblapack_g);
}

void
init_lapack_dlasq4(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlasq4", rblapack_dlasq4, -1);
}
ruby-lapack-1.7.2/ext/dlaqsp.c0000644000175000017500000001200412502221025016003 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaqsp_(char* uplo, integer* n, doublereal* ap, doublereal* s, doublereal* scond, doublereal* amax, char* equed);


static VALUE
rblapack_dlaqsp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_scond;
  doublereal scond; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_ap_out__;
  doublereal *ap_out__;

  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  equed, ap = NumRu::Lapack.dlaqsp( uplo, ap, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )\n\n*  Purpose\n*  =======\n*\n*  DLAQSP equilibrates a symmetric matrix A using the scaling factors\n*  in the vector S.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, the equilibrated matrix:  diag(S) * A * diag(S), in\n*          the same storage format as A.\n*\n*  S       (input) DOUBLE PRECISION array, dimension (N)\n*          The scale factors for A.\n*\n*  SCOND   (input) DOUBLE PRECISION\n*          Ratio of the smallest S(i) to the largest S(i).\n*\n*  AMAX    (input) DOUBLE PRECISION\n*          Absolute value of largest matrix entry.\n*\n*  EQUED   (output) CHARACTER*1\n*          Specifies whether or not equilibration was done.\n*          = 'N':  No equilibration.\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*\n*  Internal Parameters\n*  ===================\n*\n*  THRESH is a threshold value used to decide if scaling should be done\n*  based on the ratio of the scaling factors.  If SCOND < THRESH,\n*  scaling is done.\n*\n*  LARGE and SMALL are threshold values used to decide if scaling should\n*  be done based on the absolute size of the largest matrix element.\n*  If AMAX > LARGE or AMAX < SMALL, scaling is done.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  equed, ap = NumRu::Lapack.dlaqsp( uplo, ap, s, scond, amax, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_s = argv[2];
  rblapack_scond = argv[3];
  rblapack_amax = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (3th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_s);
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  amax = NUM2DBL(rblapack_amax);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  scond = NUM2DBL(rblapack_scond);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
  MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  dlaqsp_(&uplo, &n, ap, s, &scond, &amax, &equed);

  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(2, rblapack_equed, rblapack_ap);
}

void
init_lapack_dlaqsp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaqsp", rblapack_dlaqsp, -1);
}
ruby-lapack-1.7.2/ext/cunmbr.c0000644000175000017500000002226512502221021016013 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cunmbr_(char* vect, char* side, char* trans, integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* c, integer* ldc, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_cunmbr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_vect;
  char vect; 
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_c;
  complex *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  complex *c_out__;
  integer nq;

  integer lda;
  integer ldc;
  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  work, info, c = NumRu::Lapack.cunmbr( vect, side, trans, m, k, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  If VECT = 'Q', CUNMBR overwrites the general complex M-by-N matrix C\n*  with\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'C':      Q**H * C       C * Q**H\n*\n*  If VECT = 'P', CUNMBR overwrites the general complex M-by-N matrix C\n*  with\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      P * C          C * P\n*  TRANS = 'C':      P**H * C       C * P**H\n*\n*  Here Q and P**H are the unitary matrices determined by CGEBRD when\n*  reducing a complex matrix A to bidiagonal form: A = Q * B * P**H. Q\n*  and P**H are defined as products of elementary reflectors H(i) and\n*  G(i) respectively.\n*\n*  Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the\n*  order of the unitary matrix Q or P**H that is applied.\n*\n*  If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:\n*  if nq >= k, Q = H(1) H(2) . . . H(k);\n*  if nq < k, Q = H(1) H(2) . . . H(nq-1).\n*\n*  If VECT = 'P', A is assumed to have been a K-by-NQ matrix:\n*  if k < nq, P = G(1) G(2) . . . G(k);\n*  if k >= nq, P = G(1) G(2) . . . G(nq-1).\n*\n\n*  Arguments\n*  =========\n*\n*  VECT    (input) CHARACTER*1\n*          = 'Q': apply Q or Q**H;\n*          = 'P': apply P or P**H.\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q, Q**H, P or P**H from the Left;\n*          = 'R': apply Q, Q**H, P or P**H from the Right.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q or P;\n*          = 'C':  Conjugate transpose, apply Q**H or P**H.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          If VECT = 'Q', the number of columns in the original\n*          matrix reduced by CGEBRD.\n*          If VECT = 'P', the number of rows in the original\n*          matrix reduced by CGEBRD.\n*          K >= 0.\n*\n*  A       (input) COMPLEX array, dimension\n*                                (LDA,min(nq,K)) if VECT = 'Q'\n*                                (LDA,nq)        if VECT = 'P'\n*          The vectors which define the elementary reflectors H(i) and\n*          G(i), whose products determine the matrices Q and P, as\n*          returned by CGEBRD.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*          If VECT = 'Q', LDA >= max(1,nq);\n*          if VECT = 'P', LDA >= max(1,min(nq,K)).\n*\n*  TAU     (input) COMPLEX array, dimension (min(nq,K))\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i) or G(i) which determines Q or P, as returned\n*          by CGEBRD in the array argument TAUQ or TAUP.\n*\n*  C       (input/output) COMPLEX array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q\n*          or P*C or P**H*C or C*P or C*P**H.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace/output) COMPLEX 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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M);\n*          if N = 0 or M = 0, LWORK >= 1.\n*          For optimum performance LWORK >= max(1,N*NB) if SIDE = 'L',\n*          and LWORK >= max(1,M*NB) if SIDE = 'R', where NB is the\n*          optimal blocksize. (NB = 0 if M = 0 or N = 0.)\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*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            APPLYQ, LEFT, LQUERY, NOTRAN\n      CHARACTER          TRANST\n      INTEGER            I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            ILAENV\n      EXTERNAL           ILAENV, LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CUNMLQ, CUNMQR, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.cunmbr( vect, side, trans, m, k, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_vect = argv[0];
  rblapack_side = argv[1];
  rblapack_trans = argv[2];
  rblapack_m = argv[3];
  rblapack_k = argv[4];
  rblapack_a = argv[5];
  rblapack_tau = argv[6];
  rblapack_c = argv[7];
  if (argc == 9) {
    rblapack_lwork = argv[8];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  vect = StringValueCStr(rblapack_vect)[0];
  trans = StringValueCStr(rblapack_trans)[0];
  k = NUM2INT(rblapack_k);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (8th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, complex*);
  side = StringValueCStr(rblapack_side)[0];
  m = NUM2INT(rblapack_m);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  nq = lsame_(&side,"L") ? m : lsame_(&side,"R") ? n : 0;
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (6th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (6th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != (MIN(nq,k)))
    rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", MIN(nq,k));
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (7th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_tau) != (MIN(nq,k)))
    rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", MIN(nq,k));
  if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
  MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  cunmbr_(&vect, &side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_cunmbr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cunmbr", rblapack_cunmbr, -1);
}
ruby-lapack-1.7.2/ext/cunmr2.c0000644000175000017500000001407612502221014015736 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cunmr2_(char* side, char* trans, integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* c, integer* ldc, complex* work, integer* info);


static VALUE
rblapack_cunmr2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_c;
  complex *c; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  complex *c_out__;
  complex *work;

  integer lda;
  integer m;
  integer k;
  integer ldc;
  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  info, c = NumRu::Lapack.cunmr2( side, trans, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CUNMR2 overwrites the general complex m-by-n matrix C with\n*\n*        Q * C  if SIDE = 'L' and TRANS = 'N', or\n*\n*        Q'* C  if SIDE = 'L' and TRANS = 'C', or\n*\n*        C * Q  if SIDE = 'R' and TRANS = 'N', or\n*\n*        C * Q' if SIDE = 'R' and TRANS = 'C',\n*\n*  where Q is a complex unitary matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(1)' H(2)' . . . H(k)'\n*\n*  as returned by CGERQF. Q is of order m if SIDE = 'L' and of order n\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q' from the Left\n*          = 'R': apply Q or Q' from the Right\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': apply Q  (No transpose)\n*          = 'C': apply Q' (Conjugate transpose)\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) COMPLEX array, dimension\n*                               (LDA,M) if SIDE = 'L',\n*                               (LDA,N) if SIDE = 'R'\n*          The i-th row must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          CGERQF in the last k rows of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,K).\n*\n*  TAU     (input) COMPLEX array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by CGERQF.\n*\n*  C       (input/output) COMPLEX array, dimension (LDC,N)\n*          On entry, the m-by-n matrix C.\n*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) COMPLEX array, dimension\n*                                   (N) if SIDE = 'L',\n*                                   (M) if SIDE = 'R'\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, c = NumRu::Lapack.cunmr2( side, trans, a, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_a = argv[2];
  rblapack_tau = argv[3];
  rblapack_c = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, complex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
  MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(complex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  cunmr2_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_c);
}

void
init_lapack_cunmr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cunmr2", rblapack_cunmr2, -1);
}
ruby-lapack-1.7.2/ext/zlaic1.c0000644000175000017500000001201312502221015015701 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlaic1_(integer* job, integer* j, doublecomplex* x, doublereal* sest, doublecomplex* w, doublecomplex* gamma, doublereal* sestpr, doublecomplex* s, doublecomplex* c);


static VALUE
rblapack_zlaic1(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  integer job; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_sest;
  doublereal sest; 
  VALUE rblapack_w;
  doublecomplex *w; 
  VALUE rblapack_gamma;
  doublecomplex gamma; 
  VALUE rblapack_sestpr;
  doublereal sestpr; 
  VALUE rblapack_s;
  doublecomplex s; 
  VALUE rblapack_c;
  doublecomplex c; 

  integer j;

  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  sestpr, s, c = NumRu::Lapack.zlaic1( job, x, sest, w, gamma, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C )\n\n*  Purpose\n*  =======\n*\n*  ZLAIC1 applies one step of incremental condition estimation in\n*  its simplest version:\n*\n*  Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j\n*  lower triangular matrix L, such that\n*           twonorm(L*x) = sest\n*  Then ZLAIC1 computes sestpr, s, c such that\n*  the vector\n*                  [ s*x ]\n*           xhat = [  c  ]\n*  is an approximate singular vector of\n*                  [ L     0  ]\n*           Lhat = [ w' gamma ]\n*  in the sense that\n*           twonorm(Lhat*xhat) = sestpr.\n*\n*  Depending on JOB, an estimate for the largest or smallest singular\n*  value is computed.\n*\n*  Note that [s c]' and sestpr**2 is an eigenpair of the system\n*\n*      diag(sest*sest, 0) + [alpha  gamma] * [ conjg(alpha) ]\n*                                            [ conjg(gamma) ]\n*\n*  where  alpha =  conjg(x)'*w.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) INTEGER\n*          = 1: an estimate for the largest singular value is computed.\n*          = 2: an estimate for the smallest singular value is computed.\n*\n*  J       (input) INTEGER\n*          Length of X and W\n*\n*  X       (input) COMPLEX*16 array, dimension (J)\n*          The j-vector x.\n*\n*  SEST    (input) DOUBLE PRECISION\n*          Estimated singular value of j by j matrix L\n*\n*  W       (input) COMPLEX*16 array, dimension (J)\n*          The j-vector w.\n*\n*  GAMMA   (input) COMPLEX*16\n*          The diagonal element gamma.\n*\n*  SESTPR  (output) DOUBLE PRECISION\n*          Estimated singular value of (j+1) by (j+1) matrix Lhat.\n*\n*  S       (output) COMPLEX*16\n*          Sine needed in forming xhat.\n*\n*  C       (output) COMPLEX*16\n*          Cosine needed in forming xhat.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sestpr, s, c = NumRu::Lapack.zlaic1( job, x, sest, w, gamma, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_job = argv[0];
  rblapack_x = argv[1];
  rblapack_sest = argv[2];
  rblapack_w = argv[3];
  rblapack_gamma = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  job = NUM2INT(rblapack_job);
  sest = NUM2DBL(rblapack_sest);
  gamma.r = NUM2DBL(rb_funcall(rblapack_gamma, rb_intern("real"), 0));
  gamma.i = NUM2DBL(rb_funcall(rblapack_gamma, rb_intern("imag"), 0));
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
  j = NA_SHAPE0(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  if (!NA_IsNArray(rblapack_w))
    rb_raise(rb_eArgError, "w (4th argument) must be NArray");
  if (NA_RANK(rblapack_w) != 1)
    rb_raise(rb_eArgError, "rank of w (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_w) != j)
    rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of x");
  if (NA_TYPE(rblapack_w) != NA_DCOMPLEX)
    rblapack_w = na_change_type(rblapack_w, NA_DCOMPLEX);
  w = NA_PTR_TYPE(rblapack_w, doublecomplex*);

  zlaic1_(&job, &j, x, &sest, w, &gamma, &sestpr, &s, &c);

  rblapack_sestpr = rb_float_new((double)sestpr);
  rblapack_s = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(s.r)), rb_float_new((double)(s.i)));
  rblapack_c = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(c.r)), rb_float_new((double)(c.i)));
  return rb_ary_new3(3, rblapack_sestpr, rblapack_s, rblapack_c);
}

void
init_lapack_zlaic1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlaic1", rblapack_zlaic1, -1);
}
ruby-lapack-1.7.2/ext/ctrcon.c0000644000175000017500000001111212502221021016002 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctrcon_(char* norm, char* uplo, char* diag, integer* n, complex* a, integer* lda, real* rcond, complex* work, real* rwork, integer* info);


static VALUE
rblapack_ctrcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_info;
  integer info; 
  complex *work;
  real *rwork;

  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  rcond, info = NumRu::Lapack.ctrcon( norm, uplo, diag, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTRCON estimates the reciprocal of the condition number of a\n*  triangular matrix A, in either the 1-norm or the infinity-norm.\n*\n*  The norm of A is computed and an estimate is obtained for\n*  norm(inv(A)), then the reciprocal of the condition number is\n*  computed as\n*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies whether the 1-norm condition number or the\n*          infinity-norm condition number is required:\n*          = '1' or 'O':  1-norm;\n*          = 'I':         Infinity-norm.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The triangular matrix A.  If UPLO = 'U', the leading N-by-N\n*          upper triangular part of the array A contains the upper\n*          triangular matrix, and the strictly lower triangular part of\n*          A is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*          triangular part of the array A contains the lower triangular\n*          matrix, and the strictly upper triangular part of A is not\n*          referenced.  If DIAG = 'U', the diagonal elements of A are\n*          also not referenced and are assumed to be 1.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  RCOND   (output) REAL\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(norm(A) * norm(inv(A))).\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.ctrcon( norm, uplo, diag, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_diag = argv[2];
  rblapack_a = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (n));

  ctrcon_(&norm, &uplo, &diag, &n, a, &lda, &rcond, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_ctrcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctrcon", rblapack_ctrcon, -1);
}
ruby-lapack-1.7.2/ext/dgeqr2.c0000644000175000017500000001040512502221013015703 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgeqr2_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* info);


static VALUE
rblapack_dgeqr2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  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;

  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.dgeqr2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGEQR2 computes a QR factorization of a real m by n matrix A:\n*  A = Q * R.\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 above the diagonal of the array\n*          contain the min(m,n) by n upper trapezoidal matrix R (R is\n*          upper triangular if m >= n); the elements below 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 (N)\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(1) H(2) . . . H(k), 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:m) is stored on exit in A(i+1:m,i),\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.dgeqr2( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t 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, (n));

  dgeqr2_(&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_dgeqr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgeqr2", rblapack_dgeqr2, -1);
}
ruby-lapack-1.7.2/ext/zgehrd.c0000644000175000017500000001557312502221016016020 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgehrd_(integer* n, integer* ilo, integer* ihi, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zgehrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *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.zgehrd( ilo, ihi, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGEHRD reduces a complex general matrix A to upper Hessenberg form H by\n*  an unitary similarity transformation:  Q' * A * Q = H .\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          It is assumed that A is already upper triangular in rows\n*          and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n*          set by a previous call to ZGEBAL; otherwise they should be\n*          set to 1 and N respectively. See Further Details.\n*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the N-by-N general matrix to be reduced.\n*          On exit, the upper triangle and the first subdiagonal of A\n*          are overwritten with the upper Hessenberg matrix H, and the\n*          elements below the first subdiagonal, with the array TAU,\n*          represent the unitary matrix Q as a product of elementary\n*          reflectors. See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  TAU     (output) COMPLEX*16 array, dimension (N-1)\n*          The scalar factors of the elementary reflectors (see Further\n*          Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to\n*          zero.\n*\n*  WORK    (workspace/output) COMPLEX*16 array, dimension (LWORK)\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of the array WORK.  LWORK >= max(1,N).\n*          For optimum performance LWORK >= N*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 (ihi-ilo) elementary\n*  reflectors\n*\n*     Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - tau * v * v'\n*\n*  where tau is a complex scalar, and v is a complex vector with\n*  v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n*  exit in A(i+2:ihi,i), and tau in TAU(i).\n*\n*  The contents of A are illustrated by the following example, with\n*  n = 7, ilo = 2 and ihi = 6:\n*\n*  on entry,                        on exit,\n*\n*  ( a   a   a   a   a   a   a )    (  a   a   h   h   h   h   a )\n*  (     a   a   a   a   a   a )    (      a   h   h   h   h   a )\n*  (     a   a   a   a   a   a )    (      h   h   h   h   h   h )\n*  (     a   a   a   a   a   a )    (      v2  h   h   h   h   h )\n*  (     a   a   a   a   a   a )    (      v2  v3  h   h   h   h )\n*  (     a   a   a   a   a   a )    (      v2  v3  v4  h   h   h )\n*  (                         a )    (                          a )\n*\n*  where a denotes an element of the original matrix A, h denotes a\n*  modified element of the upper Hessenberg matrix H, and vi denotes an\n*  element of the vector defining H(i).\n*\n*  This file is a slight modification of LAPACK-3.0's DGEHRD\n*  subroutine incorporating improvements proposed by Quintana-Orti and\n*  Van de Geijn (2006). (See DLAHR2.)\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, work, info, a = NumRu::Lapack.zgehrd( ilo, ihi, a, [: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_ilo = argv[0];
  rblapack_ihi = argv[1];
  rblapack_a = 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;
  }

  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  ihi = NUM2INT(rblapack_ihi);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zgehrd_(&n, &ilo, &ihi, 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_zgehrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgehrd", rblapack_zgehrd, -1);
}
ruby-lapack-1.7.2/ext/zpptrs.c0000644000175000017500000001147612502221015016074 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zpptrs_(char* uplo, integer* n, integer* nrhs, doublecomplex* ap, doublecomplex* b, integer* ldb, integer* info);


static VALUE
rblapack_zpptrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.zpptrs( uplo, n, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPPTRS solves a system of linear equations A*X = B with a Hermitian\n*  positive definite matrix A in packed storage using the Cholesky\n*  factorization A = U**H*U or A = L*L**H computed by ZPPTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**H*U or A = L*L**H, packed columnwise in a linear\n*          array.  The j-th column of U or L is stored in the array AP\n*          as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            UPPER\n      INTEGER            I\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZTPSV\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.zpptrs( uplo, n, ap, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_n = argv[1];
  rblapack_ap = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zpptrs_(&uplo, &n, &nrhs, ap, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_zpptrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zpptrs", rblapack_zpptrs, -1);
}
ruby-lapack-1.7.2/ext/dsfrk.c0000644000175000017500000001471712502221023015643 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsfrk_(char* transr, char* uplo, char* trans, integer* n, integer* k, doublereal* alpha, doublereal* a, integer* lda, doublereal* beta, doublereal* c);


static VALUE
rblapack_dsfrk(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_alpha;
  doublereal alpha; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_beta;
  doublereal beta; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_c_out__;
  doublereal *c_out__;

  integer lda;
  integer nt;

  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  c = NumRu::Lapack.dsfrk( transr, uplo, trans, n, k, alpha, a, beta, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, C )\n\n*  Purpose\n*  =======\n*\n*  Level 3 BLAS like routine for C in RFP Format.\n*\n*  DSFRK performs one of the symmetric rank--k operations\n*\n*     C := alpha*A*A' + beta*C,\n*\n*  or\n*\n*     C := alpha*A'*A + beta*C,\n*\n*  where alpha and beta are real scalars, C is an n--by--n symmetric\n*  matrix and A is an n--by--k matrix in the first case and a k--by--n\n*  matrix in the second case.\n*\n\n*  Arguments\n*  ==========\n*\n*  TRANSR  (input) CHARACTER*1\n*          = 'N':  The Normal Form of RFP A is stored;\n*          = 'T':  The Transpose Form of RFP A is stored.\n*\n*  UPLO    (input) CHARACTER*1\n*           On  entry, UPLO specifies whether the upper or lower\n*           triangular part of the array C is to be referenced as\n*           follows:\n*\n*              UPLO = 'U' or 'u'   Only the upper triangular part of C\n*                                  is to be referenced.\n*\n*              UPLO = 'L' or 'l'   Only the lower triangular part of C\n*                                  is to be referenced.\n*\n*           Unchanged on exit.\n*\n*  TRANS   (input) CHARACTER*1\n*           On entry, TRANS specifies the operation to be performed as\n*           follows:\n*\n*              TRANS = 'N' or 'n'   C := alpha*A*A' + beta*C.\n*\n*              TRANS = 'T' or 't'   C := alpha*A'*A + beta*C.\n*\n*           Unchanged on exit.\n*\n*  N       (input) INTEGER\n*           On entry, N specifies the order of the matrix C. N must be\n*           at least zero.\n*           Unchanged on exit.\n*\n*  K       (input) INTEGER\n*           On entry with TRANS = 'N' or 'n', K specifies the number\n*           of  columns of the matrix A, and on entry with TRANS = 'T'\n*           or 't', K specifies the number of rows of the matrix A. K\n*           must be at least zero.\n*           Unchanged on exit.\n*\n*  ALPHA   (input) DOUBLE PRECISION\n*           On entry, ALPHA specifies the scalar alpha.\n*           Unchanged on exit.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,ka)\n*           where KA\n*           is K  when TRANS = 'N' or 'n', and is N otherwise. Before\n*           entry with TRANS = 'N' or 'n', the leading N--by--K part of\n*           the array A must contain the matrix A, otherwise the leading\n*           K--by--N part of the array A must contain the matrix A.\n*           Unchanged on exit.\n*\n*  LDA     (input) INTEGER\n*           On entry, LDA specifies the first dimension of A as declared\n*           in  the  calling  (sub)  program.   When  TRANS = 'N' or 'n'\n*           then  LDA must be at least  max( 1, n ), otherwise  LDA must\n*           be at least  max( 1, k ).\n*           Unchanged on exit.\n*\n*  BETA    (input) DOUBLE PRECISION\n*           On entry, BETA specifies the scalar beta.\n*           Unchanged on exit.\n*\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (NT)\n*           NT = N*(N+1)/2. On entry, the symmetric matrix C in RFP\n*           Format. RFP Format is described by TRANSR, UPLO and N.\n*\n*  Arguments\n*  ==========\n*\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.dsfrk( transr, uplo, trans, n, k, alpha, a, beta, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_trans = argv[2];
  rblapack_n = argv[3];
  rblapack_k = argv[4];
  rblapack_alpha = argv[5];
  rblapack_a = argv[6];
  rblapack_beta = argv[7];
  rblapack_c = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  trans = StringValueCStr(rblapack_trans)[0];
  k = NUM2INT(rblapack_k);
  beta = NUM2DBL(rblapack_beta);
  uplo = StringValueCStr(rblapack_uplo)[0];
  alpha = NUM2DBL(rblapack_alpha);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (9th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 1);
  nt = NA_SHAPE0(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (7th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (7th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != (lsame_(&trans,"N") ? k : n))
    rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", lsame_(&trans,"N") ? k : n);
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nt;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  dsfrk_(&transr, &uplo, &trans, &n, &k, &alpha, a, &lda, &beta, c);

  return rblapack_c;
}

void
init_lapack_dsfrk(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsfrk", rblapack_dsfrk, -1);
}
ruby-lapack-1.7.2/ext/ssyevd.c0000644000175000017500000002051612502221023016041 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssyevd_(char* jobz, char* uplo, integer* n, real* a, integer* lda, real* w, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_ssyevd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *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  w, work, iwork, info, a = NumRu::Lapack.ssyevd( jobz, uplo, a, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSYEVD computes all eigenvalues and, optionally, eigenvectors of a\n*  real symmetric matrix A. If eigenvectors are desired, it uses a\n*  divide and conquer algorithm.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n*  Because of large use of BLAS of level 3, SSYEVD needs N**2 more\n*  workspace than SSYEVX.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA, N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of A contains the\n*          upper triangular part of the matrix A.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of A contains\n*          the lower triangular part of the matrix A.\n*          On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n*          orthonormal eigenvectors of the matrix A.\n*          If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n*          or the upper triangle (if UPLO='U') of A, including the\n*          diagonal, is destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  W       (output) REAL array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  WORK    (workspace/output) REAL array,\n*                                         dimension (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*          If N <= 1,               LWORK must be at least 1.\n*          If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1.\n*          If JOBZ = 'V' and N > 1, LWORK must be at least \n*                                                1 + 6*N + 2*N**2.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal sizes of the WORK and IWORK\n*          arrays, returns these values as the first entries of the WORK\n*          and IWORK arrays, and no error message related to LWORK or\n*          LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.\n*          If N <= 1,                LIWORK must be at least 1.\n*          If JOBZ  = 'N' and N > 1, LIWORK must be at least 1.\n*          If JOBZ  = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK and IWORK arrays, and no error message related to\n*          LWORK or LIWORK 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 and JOBZ = 'N', then the algorithm failed\n*                to converge; i off-diagonal elements of an intermediate\n*                tridiagonal form did not converge to zero;\n*                if INFO = i and JOBZ = 'V', then the algorithm failed\n*                to compute an eigenvalue while working on the submatrix\n*                lying in rows and columns INFO/(N+1) through\n*                mod(INFO,N+1).\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Jeff Rutter, Computer Science Division, University of California\n*     at Berkeley, USA\n*  Modified by Francoise Tisseur, University of Tennessee.\n*\n*  Modified description of INFO. Sven, 16 Feb 05.\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, work, iwork, info, a = NumRu::Lapack.ssyevd( jobz, uplo, a, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  if (argc == 5) {
    rblapack_lwork = argv[3];
    rblapack_liwork = argv[4];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (rblapack_liwork == Qnil)
    liwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (rblapack_lwork == Qnil)
    lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 2*n+1 : lsame_(&jobz,"V") ? 1+6*n+2*n*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  ssyevd_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, iwork, &liwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_w, rblapack_work, rblapack_iwork, rblapack_info, rblapack_a);
}

void
init_lapack_ssyevd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssyevd", rblapack_ssyevd, -1);
}
ruby-lapack-1.7.2/ext/dlanv2.c0000644000175000017500000001015412502221013015706 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlanv2_(doublereal* a, doublereal* b, doublereal* c, doublereal* d, doublereal* rt1r, doublereal* rt1i, doublereal* rt2r, doublereal* rt2i, doublereal* cs, doublereal* sn);


static VALUE
rblapack_dlanv2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublereal a; 
  VALUE rblapack_b;
  doublereal b; 
  VALUE rblapack_c;
  doublereal c; 
  VALUE rblapack_d;
  doublereal d; 
  VALUE rblapack_rt1r;
  doublereal rt1r; 
  VALUE rblapack_rt1i;
  doublereal rt1i; 
  VALUE rblapack_rt2r;
  doublereal rt2r; 
  VALUE rblapack_rt2i;
  doublereal rt2i; 
  VALUE rblapack_cs;
  doublereal cs; 
  VALUE rblapack_sn;
  doublereal sn; 


  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  rt1r, rt1i, rt2r, rt2i, cs, sn, a, b, c, d = NumRu::Lapack.dlanv2( a, b, c, d, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN )\n\n*  Purpose\n*  =======\n*\n*  DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric\n*  matrix in standard form:\n*\n*       [ A  B ] = [ CS -SN ] [ AA  BB ] [ CS  SN ]\n*       [ C  D ]   [ SN  CS ] [ CC  DD ] [-SN  CS ]\n*\n*  where either\n*  1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or\n*  2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex\n*  conjugate eigenvalues.\n*\n\n*  Arguments\n*  =========\n*\n*  A       (input/output) DOUBLE PRECISION\n*  B       (input/output) DOUBLE PRECISION\n*  C       (input/output) DOUBLE PRECISION\n*  D       (input/output) DOUBLE PRECISION\n*          On entry, the elements of the input matrix.\n*          On exit, they are overwritten by the elements of the\n*          standardised Schur form.\n*\n*  RT1R    (output) DOUBLE PRECISION\n*  RT1I    (output) DOUBLE PRECISION\n*  RT2R    (output) DOUBLE PRECISION\n*  RT2I    (output) DOUBLE PRECISION\n*          The real and imaginary parts of the eigenvalues. If the\n*          eigenvalues are a complex conjugate pair, RT1I > 0.\n*\n*  CS      (output) DOUBLE PRECISION\n*  SN      (output) DOUBLE PRECISION\n*          Parameters of the rotation matrix.\n*\n\n*  Further Details\n*  ===============\n*\n*  Modified by V. Sima, Research Institute for Informatics, Bucharest,\n*  Romania, to reduce the risk of cancellation errors,\n*  when computing real eigenvalues, and to ensure, if possible, that\n*  abs(RT1R) >= abs(RT2R).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rt1r, rt1i, rt2r, rt2i, cs, sn, a, b, c, d = NumRu::Lapack.dlanv2( a, b, c, d, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  rblapack_c = argv[2];
  rblapack_d = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  a = NUM2DBL(rblapack_a);
  c = NUM2DBL(rblapack_c);
  b = NUM2DBL(rblapack_b);
  d = NUM2DBL(rblapack_d);

  dlanv2_(&a, &b, &c, &d, &rt1r, &rt1i, &rt2r, &rt2i, &cs, &sn);

  rblapack_rt1r = rb_float_new((double)rt1r);
  rblapack_rt1i = rb_float_new((double)rt1i);
  rblapack_rt2r = rb_float_new((double)rt2r);
  rblapack_rt2i = rb_float_new((double)rt2i);
  rblapack_cs = rb_float_new((double)cs);
  rblapack_sn = rb_float_new((double)sn);
  rblapack_a = rb_float_new((double)a);
  rblapack_b = rb_float_new((double)b);
  rblapack_c = rb_float_new((double)c);
  rblapack_d = rb_float_new((double)d);
  return rb_ary_new3(10, rblapack_rt1r, rblapack_rt1i, rblapack_rt2r, rblapack_rt2i, rblapack_cs, rblapack_sn, rblapack_a, rblapack_b, rblapack_c, rblapack_d);
}

void
init_lapack_dlanv2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlanv2", rblapack_dlanv2, -1);
}
ruby-lapack-1.7.2/ext/ztfsm.c0000644000175000017500000002655512502221025015702 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztfsm_(char* transr, char* side, char* uplo, char* trans, char* diag, integer* m, integer* n, doublecomplex* alpha, doublecomplex* a, doublecomplex* b, integer* ldb);


static VALUE
rblapack_ztfsm(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_alpha;
  doublecomplex alpha; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer ldb;
  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  b = NumRu::Lapack.ztfsm( transr, side, uplo, trans, diag, m, alpha, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, B, LDB )\n\n*  Purpose\n*  =======\n*\n*  Level 3 BLAS like routine for A in RFP Format.\n*\n*  ZTFSM  solves the matrix equation\n*\n*     op( A )*X = alpha*B  or  X*op( A ) = alpha*B\n*\n*  where alpha is a scalar, X and B are m by n matrices, A is a unit, or\n*  non-unit,  upper or lower triangular matrix  and  op( A )  is one  of\n*\n*     op( A ) = A   or   op( A ) = conjg( A' ).\n*\n*  A is in Rectangular Full Packed (RFP) Format.\n*\n*  The matrix X is overwritten on B.\n*\n\n*  Arguments\n*  ==========\n*\n*  TRANSR  (input) CHARACTER*1\n*          = 'N':  The Normal Form of RFP A is stored;\n*          = 'C':  The Conjugate-transpose Form of RFP A is stored.\n*\n*  SIDE    (input) CHARACTER*1\n*           On entry, SIDE specifies whether op( A ) appears on the left\n*           or right of X as follows:\n*\n*              SIDE = 'L' or 'l'   op( A )*X = alpha*B.\n*\n*              SIDE = 'R' or 'r'   X*op( A ) = alpha*B.\n*\n*           Unchanged on exit.\n*\n*  UPLO    (input) CHARACTER*1\n*           On entry, UPLO specifies whether the RFP matrix A came from\n*           an upper or lower triangular matrix as follows:\n*           UPLO = 'U' or 'u' RFP A came from an upper triangular matrix\n*           UPLO = 'L' or 'l' RFP A came from a  lower triangular matrix\n*\n*           Unchanged on exit.\n*\n*  TRANS   (input) CHARACTER*1\n*           On entry, TRANS  specifies the form of op( A ) to be used\n*           in the matrix multiplication as follows:\n*\n*              TRANS  = 'N' or 'n'   op( A ) = A.\n*\n*              TRANS  = 'C' or 'c'   op( A ) = conjg( A' ).\n*\n*           Unchanged on exit.\n*\n*  DIAG    (input) CHARACTER*1\n*           On entry, DIAG specifies whether or not RFP A is unit\n*           triangular as follows:\n*\n*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.\n*\n*              DIAG = 'N' or 'n'   A is not assumed to be unit\n*                                  triangular.\n*\n*           Unchanged on exit.\n*\n*  M       (input) INTEGER\n*           On entry, M specifies the number of rows of B. M must be at\n*           least zero.\n*           Unchanged on exit.\n*\n*  N       (input) INTEGER\n*           On entry, N specifies the number of columns of B.  N must be\n*           at least zero.\n*           Unchanged on exit.\n*\n*  ALPHA   (input) COMPLEX*16\n*           On entry,  ALPHA specifies the scalar  alpha. When  alpha is\n*           zero then  A is not referenced and  B need not be set before\n*           entry.\n*           Unchanged on exit.\n*\n*  A       (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n*           NT = N*(N+1)/2. On entry, the matrix A in RFP Format.\n*           RFP Format is described by TRANSR, UPLO and N as follows:\n*           If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;\n*           K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If\n*           TRANSR = 'C' then RFP is the Conjugate-transpose of RFP A as\n*           defined when TRANSR = 'N'. The contents of RFP A are defined\n*           by UPLO as follows: If UPLO = 'U' the RFP A contains the NT\n*           elements of upper packed A either in normal or\n*           conjugate-transpose Format. If UPLO = 'L' the RFP A contains\n*           the NT elements of lower packed A either in normal or\n*           conjugate-transpose Format. The LDA of RFP A is (N+1)/2 when\n*           TRANSR = 'C'. When TRANSR is 'N' the LDA is N+1 when N is\n*           even and is N when is odd.\n*           See the Note below for more details. Unchanged on exit.\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,N)\n*           Before entry,  the leading  m by n part of the array  B must\n*           contain  the  right-hand  side  matrix  B,  and  on exit  is\n*           overwritten by the solution matrix  X.\n*\n*  LDB     (input) INTEGER\n*           On entry, LDB specifies the first dimension of B as declared\n*           in  the  calling  (sub)  program.   LDB  must  be  at  least\n*           max( 1, m ).\n*           Unchanged on exit.\n*\n\n*  Further Details\n*  ===============\n*\n*  We first consider Standard Packed Format when N is even.\n*  We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  conjugate-transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  conjugate-transpose of the last three columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                -- -- --\n*        03 04 05                33 43 53\n*                                   -- --\n*        13 14 15                00 44 54\n*                                      --\n*        23 24 25                10 11 55\n*\n*        33 34 35                20 21 22\n*        --\n*        00 44 45                30 31 32\n*        -- --\n*        01 11 55                40 41 42\n*        -- -- --\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- -- --                -- -- -- -- -- --\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     -- -- -- -- --                -- -- -- -- --\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     -- -- -- -- -- --                -- -- -- --\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We next  consider Standard Packed Format when N is odd.\n*  We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  conjugate-transpose of the first two   columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  conjugate-transpose of the last two   columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N odd  and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                   -- --\n*        02 03 04                00 33 43\n*                                      --\n*        12 13 14                10 11 44\n*\n*        22 23 24                20 21 22\n*        --\n*        00 33 34                30 31 32\n*        -- --\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- --                   -- -- -- -- -- --\n*     02 12 22 00 01             00 10 20 30 40 50\n*     -- -- -- --                   -- -- -- -- --\n*     03 13 23 33 11             33 11 21 31 41 51\n*     -- -- -- -- --                   -- -- -- --\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  b = NumRu::Lapack.ztfsm( transr, side, uplo, trans, diag, m, alpha, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_transr = argv[0];
  rblapack_side = argv[1];
  rblapack_uplo = argv[2];
  rblapack_trans = argv[3];
  rblapack_diag = argv[4];
  rblapack_m = argv[5];
  rblapack_alpha = argv[6];
  rblapack_a = argv[7];
  rblapack_b = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  alpha.r = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
  alpha.i = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (9th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (9th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  side = StringValueCStr(rblapack_side)[0];
  m = NUM2INT(rblapack_m);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (8th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 1)
    rb_raise(rb_eArgError, "rank of a (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  ztfsm_(&transr, &side, &uplo, &trans, &diag, &m, &n, &alpha, a, b, &ldb);

  return rblapack_b;
}

void
init_lapack_ztfsm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztfsm", rblapack_ztfsm, -1);
}
ruby-lapack-1.7.2/ext/dtrsna.c0000644000175000017500000002641412502221022016021 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtrsna_(char* job, char* howmny, logical* select, integer* n, doublereal* t, integer* ldt, doublereal* vl, integer* ldvl, doublereal* vr, integer* ldvr, doublereal* s, doublereal* sep, integer* mm, integer* m, doublereal* work, integer* ldwork, integer* iwork, integer* info);


static VALUE
rblapack_dtrsna(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_howmny;
  char howmny; 
  VALUE rblapack_select;
  logical *select; 
  VALUE rblapack_t;
  doublereal *t; 
  VALUE rblapack_vl;
  doublereal *vl; 
  VALUE rblapack_vr;
  doublereal *vr; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_sep;
  doublereal *sep; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_info;
  integer info; 
  doublereal *work;
  integer *iwork;

  integer n;
  integer ldt;
  integer ldvl;
  integer ldvr;
  integer mm;
  integer ldwork;

  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  s, sep, m, info = NumRu::Lapack.dtrsna( job, howmny, select, t, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTRSNA estimates reciprocal condition numbers for specified\n*  eigenvalues and/or right eigenvectors of a real upper\n*  quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q\n*  orthogonal).\n*\n*  T must be in Schur canonical form (as returned by DHSEQR), that is,\n*  block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each\n*  2-by-2 diagonal block has its diagonal elements equal and its\n*  off-diagonal elements of opposite sign.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies whether condition numbers are required for\n*          eigenvalues (S) or eigenvectors (SEP):\n*          = 'E': for eigenvalues only (S);\n*          = 'V': for eigenvectors only (SEP);\n*          = 'B': for both eigenvalues and eigenvectors (S and SEP).\n*\n*  HOWMNY  (input) CHARACTER*1\n*          = 'A': compute condition numbers for all eigenpairs;\n*          = 'S': compute condition numbers for selected eigenpairs\n*                 specified by the array SELECT.\n*\n*  SELECT  (input) LOGICAL array, dimension (N)\n*          If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n*          condition numbers are required. To select condition numbers\n*          for the eigenpair corresponding to a real eigenvalue w(j),\n*          SELECT(j) must be set to .TRUE.. To select condition numbers\n*          corresponding to a complex conjugate pair of eigenvalues w(j)\n*          and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be\n*          set to .TRUE..\n*          If HOWMNY = 'A', SELECT is not referenced.\n*\n*  N       (input) INTEGER\n*          The order of the matrix T. N >= 0.\n*\n*  T       (input) DOUBLE PRECISION array, dimension (LDT,N)\n*          The upper quasi-triangular matrix T, in Schur canonical form.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= max(1,N).\n*\n*  VL      (input) DOUBLE PRECISION array, dimension (LDVL,M)\n*          If JOB = 'E' or 'B', VL must contain left eigenvectors of T\n*          (or of any Q*T*Q**T with Q orthogonal), corresponding to the\n*          eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n*          must be stored in consecutive columns of VL, as returned by\n*          DHSEIN or DTREVC.\n*          If JOB = 'V', VL is not referenced.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the array VL.\n*          LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.\n*\n*  VR      (input) DOUBLE PRECISION array, dimension (LDVR,M)\n*          If JOB = 'E' or 'B', VR must contain right eigenvectors of T\n*          (or of any Q*T*Q**T with Q orthogonal), corresponding to the\n*          eigenpairs specified by HOWMNY and SELECT. The eigenvectors\n*          must be stored in consecutive columns of VR, as returned by\n*          DHSEIN or DTREVC.\n*          If JOB = 'V', VR is not referenced.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the array VR.\n*          LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.\n*\n*  S       (output) DOUBLE PRECISION array, dimension (MM)\n*          If JOB = 'E' or 'B', the reciprocal condition numbers of the\n*          selected eigenvalues, stored in consecutive elements of the\n*          array. For a complex conjugate pair of eigenvalues two\n*          consecutive elements of S are set to the same value. Thus\n*          S(j), SEP(j), and the j-th columns of VL and VR all\n*          correspond to the same eigenpair (but not in general the\n*          j-th eigenpair, unless all eigenpairs are selected).\n*          If JOB = 'V', S is not referenced.\n*\n*  SEP     (output) DOUBLE PRECISION array, dimension (MM)\n*          If JOB = 'V' or 'B', the estimated reciprocal condition\n*          numbers of the selected eigenvectors, stored in consecutive\n*          elements of the array. For a complex eigenvector two\n*          consecutive elements of SEP are set to the same value. If\n*          the eigenvalues cannot be reordered to compute SEP(j), SEP(j)\n*          is set to 0; this can only occur when the true value would be\n*          very small anyway.\n*          If JOB = 'E', SEP is not referenced.\n*\n*  MM      (input) INTEGER\n*          The number of elements in the arrays S (if JOB = 'E' or 'B')\n*           and/or SEP (if JOB = 'V' or 'B'). MM >= M.\n*\n*  M       (output) INTEGER\n*          The number of elements of the arrays S and/or SEP actually\n*          used to store the estimated condition numbers.\n*          If HOWMNY = 'A', M is set to N.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (LDWORK,N+6)\n*          If JOB = 'E', WORK is not referenced.\n*\n*  LDWORK  (input) INTEGER\n*          The leading dimension of the array WORK.\n*          LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.\n*\n*  IWORK   (workspace) INTEGER array, dimension (2*(N-1))\n*          If JOB = 'E', IWORK is not referenced.\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 reciprocal of the condition number of an eigenvalue lambda is\n*  defined as\n*\n*          S(lambda) = |v'*u| / (norm(u)*norm(v))\n*\n*  where u and v are the right and left eigenvectors of T corresponding\n*  to lambda; v' denotes the conjugate-transpose of v, and norm(u)\n*  denotes the Euclidean norm. These reciprocal condition numbers always\n*  lie between zero (very badly conditioned) and one (very well\n*  conditioned). If n = 1, S(lambda) is defined to be 1.\n*\n*  An approximate error bound for a computed eigenvalue W(i) is given by\n*\n*                      EPS * norm(T) / S(i)\n*\n*  where EPS is the machine precision.\n*\n*  The reciprocal of the condition number of the right eigenvector u\n*  corresponding to lambda is defined as follows. Suppose\n*\n*              T = ( lambda  c  )\n*                  (   0    T22 )\n*\n*  Then the reciprocal condition number is\n*\n*          SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )\n*\n*  where sigma-min denotes the smallest singular value. We approximate\n*  the smallest singular value by the reciprocal of an estimate of the\n*  one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is\n*  defined to be abs(T(1,1)).\n*\n*  An approximate error bound for a computed right eigenvector VR(i)\n*  is given by\n*\n*                      EPS * norm(T) / SEP(i)\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, sep, m, info = NumRu::Lapack.dtrsna( job, howmny, select, t, vl, vr, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_job = argv[0];
  rblapack_howmny = argv[1];
  rblapack_select = argv[2];
  rblapack_t = argv[3];
  rblapack_vl = argv[4];
  rblapack_vr = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  job = StringValueCStr(rblapack_job)[0];
  if (!NA_IsNArray(rblapack_select))
    rb_raise(rb_eArgError, "select (3th argument) must be NArray");
  if (NA_RANK(rblapack_select) != 1)
    rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_select);
  if (NA_TYPE(rblapack_select) != NA_LINT)
    rblapack_select = na_change_type(rblapack_select, NA_LINT);
  select = NA_PTR_TYPE(rblapack_select, logical*);
  if (!NA_IsNArray(rblapack_vl))
    rb_raise(rb_eArgError, "vl (5th argument) must be NArray");
  if (NA_RANK(rblapack_vl) != 2)
    rb_raise(rb_eArgError, "rank of vl (5th argument) must be %d", 2);
  ldvl = NA_SHAPE0(rblapack_vl);
  m = NA_SHAPE1(rblapack_vl);
  if (NA_TYPE(rblapack_vl) != NA_DFLOAT)
    rblapack_vl = na_change_type(rblapack_vl, NA_DFLOAT);
  vl = NA_PTR_TYPE(rblapack_vl, doublereal*);
  howmny = StringValueCStr(rblapack_howmny)[0];
  if (!NA_IsNArray(rblapack_vr))
    rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
  if (NA_RANK(rblapack_vr) != 2)
    rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 2);
  ldvr = NA_SHAPE0(rblapack_vr);
  if (NA_SHAPE1(rblapack_vr) != m)
    rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
  if (NA_TYPE(rblapack_vr) != NA_DFLOAT)
    rblapack_vr = na_change_type(rblapack_vr, NA_DFLOAT);
  vr = NA_PTR_TYPE(rblapack_vr, doublereal*);
  mm = m;
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (4th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  if (NA_SHAPE1(rblapack_t) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_t) != NA_DFLOAT)
    rblapack_t = na_change_type(rblapack_t, NA_DFLOAT);
  t = NA_PTR_TYPE(rblapack_t, doublereal*);
  ldwork = ((lsame_(&job,"V")) || (lsame_(&job,"B"))) ? n : 1;
  {
    na_shape_t shape[1];
    shape[0] = mm;
    rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = mm;
    rblapack_sep = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  sep = NA_PTR_TYPE(rblapack_sep, doublereal*);
  work = ALLOC_N(doublereal, (lsame_(&job,"E") ? 0 : ldwork)*(lsame_(&job,"E") ? 0 : n+6));
  iwork = ALLOC_N(integer, (lsame_(&job,"E") ? 0 : 2*(n-1)));

  dtrsna_(&job, &howmny, select, &n, t, &ldt, vl, &ldvl, vr, &ldvr, s, sep, &mm, &m, work, &ldwork, iwork, &info);

  free(work);
  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_s, rblapack_sep, rblapack_m, rblapack_info);
}

void
init_lapack_dtrsna(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtrsna", rblapack_dtrsna, -1);
}
ruby-lapack-1.7.2/ext/sstevd.c0000644000175000017500000002011412502221017016031 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sstevd_(char* jobz, integer* n, real* d, real* e, real* z, integer* ldz, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_sstevd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_e_out__;
  real *e_out__;

  integer n;
  integer ldz;

  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  z, work, iwork, info, d, e = NumRu::Lapack.sstevd( jobz, d, e, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSTEVD computes all eigenvalues and, optionally, eigenvectors of a\n*  real symmetric tridiagonal matrix. If eigenvectors are desired, it\n*  uses a divide and conquer algorithm.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  D       (input/output) REAL array, dimension (N)\n*          On entry, the n diagonal elements of the tridiagonal matrix\n*          A.\n*          On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n*  E       (input/output) REAL array, dimension (N-1)\n*          On entry, the (n-1) subdiagonal elements of the tridiagonal\n*          matrix A, stored in elements 1 to N-1 of E.\n*          On exit, the contents of E are destroyed.\n*\n*  Z       (output) REAL array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n*          eigenvectors of the matrix A, with the i-th column of Z\n*          holding the eigenvector associated with D(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace/output) REAL array,\n*                                         dimension (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*          If JOBZ  = 'N' or N <= 1 then LWORK must be at least 1.\n*          If JOBZ  = 'V' and N > 1 then LWORK must be at least\n*                         ( 1 + 4*N + N**2 ).\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal sizes of the WORK and IWORK\n*          arrays, returns these values as the first entries of the WORK\n*          and IWORK arrays, and no error message related to LWORK or\n*          LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.\n*          If JOBZ  = 'N' or N <= 1 then LIWORK must be at least 1.\n*          If JOBZ  = 'V' and N > 1 then LIWORK must be at least 3+5*N.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK and IWORK arrays, and no error message related to\n*          LWORK or LIWORK 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 algorithm failed to converge; i\n*                off-diagonal elements of E did not converge to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  z, work, iwork, info, d, e = NumRu::Lapack.sstevd( jobz, d, e, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_jobz = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  if (argc == 5) {
    rblapack_lwork = argv[3];
    rblapack_liwork = argv[4];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (rblapack_lwork == Qnil)
    lwork = (lsame_(&jobz,"N")||n<=1) ? 1 : lsame_(&jobz,"V") ? 1+4*n+n*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  if (rblapack_liwork == Qnil)
    liwork = (lsame_(&jobz,"N")||n<=1) ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
  MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;

  sstevd_(&jobz, &n, d, e, z, &ldz, work, &lwork, iwork, &liwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_z, rblapack_work, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e);
}

void
init_lapack_sstevd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sstevd", rblapack_sstevd, -1);
}
ruby-lapack-1.7.2/ext/dsygst.c0000644000175000017500000001220012502221020016025 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsygst_(integer* itype, char* uplo, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, integer* info);


static VALUE
rblapack_dsygst(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;

  integer lda;
  integer n;
  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  info, a = NumRu::Lapack.dsygst( itype, uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSYGST reduces a real symmetric-definite generalized eigenproblem\n*  to standard form.\n*\n*  If ITYPE = 1, the problem is A*x = lambda*B*x,\n*  and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)\n*\n*  If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n*  B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.\n*\n*  B must have been previously factorized as U**T*U or L*L**T by DPOTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);\n*          = 2 or 3: compute U*A*U**T or L**T*A*L.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored and B is factored as\n*                  U**T*U;\n*          = 'L':  Lower triangle of A is stored and B is factored as\n*                  L*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the transformed matrix, stored in the\n*          same format as A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input) DOUBLE PRECISION array, dimension (LDB,N)\n*          The triangular factor from the Cholesky factorization of B,\n*          as returned by DPOTRF.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.dsygst( itype, uplo, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_itype = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  itype = NUM2INT(rblapack_itype);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  {
    na_shape_t 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__;

  dsygst_(&itype, &uplo, &n, a, &lda, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_dsygst(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsygst", rblapack_dsygst, -1);
}
ruby-lapack-1.7.2/ext/ssptrf.c0000644000175000017500000001472012502221015016046 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssptrf_(char* uplo, integer* n, real* ap, integer* ipiv, integer* info);


static VALUE
rblapack_ssptrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  real *ap_out__;

  integer ldap;
  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  ipiv, info, ap = NumRu::Lapack.ssptrf( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSPTRF( UPLO, N, AP, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSPTRF computes the factorization of a real symmetric matrix A stored\n*  in packed format using the Bunch-Kaufman diagonal pivoting method:\n*\n*     A = U*D*U**T  or  A = L*D*L**T\n*\n*  where U (or L) is a product of permutation and unit upper (lower)\n*  triangular matrices, and D is symmetric and block diagonal with\n*  1-by-1 and 2-by-2 diagonal blocks.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) REAL array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L, stored as a packed triangular\n*          matrix overwriting A (see below for further details).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D.\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\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, D(i,i) is exactly zero.  The factorization\n*               has been completed, but the block diagonal matrix D is\n*               exactly singular, and division by zero will occur if it\n*               is used to solve a system of equations.\n*\n\n*  Further Details\n*  ===============\n*\n*  5-96 - Based on modifications by J. Lewis, Boeing Computer Services\n*         Company\n*\n*  If UPLO = 'U', then A = U*D*U', where\n*     U = P(n)*U(n)* ... *P(k)U(k)* ...,\n*  i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n*  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    v    0   )   k-s\n*     U(k) =  (   0    I    0   )   s\n*             (   0    0    I   )   n-k\n*                k-s   s   n-k\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n*  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n*  and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n*  If UPLO = 'L', then A = L*D*L', where\n*     L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n*  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n*  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    0     0   )  k-1\n*     L(k) =  (   0    I     0   )  s\n*             (   0    v     I   )  n-k-s+1\n*                k-1   s  n-k-s+1\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n*  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n*  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, ap = NumRu::Lapack.ssptrf( uplo, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, real*);
  MEMCPY(ap_out__, ap, real, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  ssptrf_(&uplo, &n, ap, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_ap);
}

void
init_lapack_ssptrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssptrf", rblapack_ssptrf, -1);
}
ruby-lapack-1.7.2/ext/sporfs.c0000644000175000017500000001754512502221013016047 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sporfs_(char* uplo, integer* n, integer* nrhs, real* a, integer* lda, real* af, integer* ldaf, real* b, integer* ldb, real* x, integer* ldx, real* ferr, real* berr, real* work, integer* iwork, integer* info);


static VALUE
rblapack_sporfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_af;
  real *af; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  real *x_out__;
  real *work;
  integer *iwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.sporfs( uplo, a, af, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPORFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is symmetric positive definite,\n*  and provides error bounds and backward error estimates for the\n*  solution.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input) REAL array, dimension (LDA,N)\n*          The symmetric matrix A.  If UPLO = 'U', the leading N-by-N\n*          upper triangular part of A contains the upper triangular part\n*          of the matrix A, and the strictly lower triangular part of A\n*          is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*          triangular part of A contains the lower triangular part of\n*          the matrix A, and the strictly upper triangular part of A is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AF      (input) REAL array, dimension (LDAF,N)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**T*U or A = L*L**T, as computed by SPOTRF.\n*\n*  LDAF    (input) INTEGER\n*          The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*  B       (input) REAL array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) REAL array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by SPOTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) REAL array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.sporfs( uplo, a, af, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_b = argv[3];
  rblapack_x = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_SFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
  af = NA_PTR_TYPE(rblapack_af, real*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (5th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(real, (3*n));
  iwork = ALLOC_N(integer, (n));

  sporfs_(&uplo, &n, &nrhs, a, &lda, af, &ldaf, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_sporfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sporfs", rblapack_sporfs, -1);
}
ruby-lapack-1.7.2/ext/zlaqsy.c0000644000175000017500000001243412502221016016051 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlaqsy_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublereal* s, doublereal* scond, doublereal* amax, char* equed);


static VALUE
rblapack_zlaqsy(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_scond;
  doublereal scond; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_a_out__;
  doublecomplex *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  equed, a = NumRu::Lapack.zlaqsy( uplo, a, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )\n\n*  Purpose\n*  =======\n*\n*  ZLAQSY equilibrates a symmetric matrix A using the scaling factors\n*  in the vector S.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          n by n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n by n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if EQUED = 'Y', the equilibrated matrix:\n*          diag(S) * A * diag(S).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(N,1).\n*\n*  S       (input) DOUBLE PRECISION array, dimension (N)\n*          The scale factors for A.\n*\n*  SCOND   (input) DOUBLE PRECISION\n*          Ratio of the smallest S(i) to the largest S(i).\n*\n*  AMAX    (input) DOUBLE PRECISION\n*          Absolute value of largest matrix entry.\n*\n*  EQUED   (output) CHARACTER*1\n*          Specifies whether or not equilibration was done.\n*          = 'N':  No equilibration.\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*\n*  Internal Parameters\n*  ===================\n*\n*  THRESH is a threshold value used to decide if scaling should be done\n*  based on the ratio of the scaling factors.  If SCOND < THRESH,\n*  scaling is done.\n*\n*  LARGE and SMALL are threshold values used to decide if scaling should\n*  be done based on the absolute size of the largest matrix element.\n*  If AMAX > LARGE or AMAX < SMALL, scaling is done.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  equed, a = NumRu::Lapack.zlaqsy( uplo, a, s, scond, amax, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_s = argv[2];
  rblapack_scond = argv[3];
  rblapack_amax = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (3th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_s);
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  amax = NUM2DBL(rblapack_amax);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of s");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  scond = NUM2DBL(rblapack_scond);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zlaqsy_(&uplo, &n, a, &lda, s, &scond, &amax, &equed);

  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(2, rblapack_equed, rblapack_a);
}

void
init_lapack_zlaqsy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlaqsy", rblapack_zlaqsy, -1);
}
ruby-lapack-1.7.2/ext/strti2.c0000644000175000017500000001002412502221016015746 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID strti2_(char* uplo, char* diag, integer* n, real* a, integer* lda, integer* info);


static VALUE
rblapack_strti2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *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  info, a = NumRu::Lapack.strti2( uplo, diag, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STRTI2( UPLO, DIAG, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  STRTI2 computes the inverse of a real upper or lower triangular\n*  matrix.\n*\n*  This is the Level 2 BLAS version of the algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the matrix A is upper or lower triangular.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  DIAG    (input) CHARACTER*1\n*          Specifies whether or not the matrix A is unit triangular.\n*          = 'N':  Non-unit triangular\n*          = 'U':  Unit triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the triangular matrix A.  If UPLO = 'U', the\n*          leading n by n upper triangular part of the array A contains\n*          the upper triangular matrix, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n by n lower triangular part of the array A contains\n*          the lower triangular matrix, and the strictly upper\n*          triangular part of A is not referenced.  If DIAG = 'U', the\n*          diagonal elements of A are also not referenced and are\n*          assumed to be 1.\n*\n*          On exit, the (triangular) inverse of the original matrix, in\n*          the same storage format.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.strti2( uplo, diag, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_diag = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  diag = StringValueCStr(rblapack_diag)[0];
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  strti2_(&uplo, &diag, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_strti2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "strti2", rblapack_strti2, -1);
}
ruby-lapack-1.7.2/ext/dtpttf.c0000644000175000017500000001540712502221025016036 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtpttf_(char* transr, char* uplo, integer* n, doublereal* ap, doublereal* arf, integer* info);


static VALUE
rblapack_dtpttf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_arf;
  doublereal *arf; 
  VALUE rblapack_info;
  integer info; 


  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  arf, info = NumRu::Lapack.dtpttf( transr, uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTPTTF( TRANSR, UPLO, N, AP, ARF, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTPTTF copies a triangular matrix A from standard packed format (TP)\n*  to rectangular full packed format (TF).\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR  (input) CHARACTER*1\n*          = 'N':  ARF in Normal format is wanted;\n*          = 'T':  ARF in Conjugate-transpose format is wanted.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ),\n*          On entry, the upper or lower triangular matrix A, packed\n*          columnwise in a linear array. The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  ARF     (output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ),\n*          On exit, the upper or lower triangular matrix A stored in\n*          RFP format. For a further discussion see Notes below.\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*  We first consider Rectangular Full Packed (RFP) Format when N is\n*  even. We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  the transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  the transpose of the last three columns of AP lower.\n*  This covers the case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        03 04 05                33 43 53\n*        13 14 15                00 44 54\n*        23 24 25                10 11 55\n*        33 34 35                20 21 22\n*        00 44 45                30 31 32\n*        01 11 55                40 41 42\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We then consider Rectangular Full Packed (RFP) Format when N is\n*  odd. We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  the transpose of the first two columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  the transpose of the last two columns of AP lower.\n*  This covers the case N odd and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        02 03 04                00 33 43\n*        12 13 14                10 11 44\n*        22 23 24                20 21 22\n*        00 33 34                30 31 32\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*           RFP A                   RFP A\n*\n*     02 12 22 00 01             00 10 20 30 40 50\n*     03 13 23 33 11             33 11 21 31 41 51\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  arf, info = NumRu::Lapack.dtpttf( transr, uplo, n, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_n = argv[2];
  rblapack_ap = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  n = NUM2INT(rblapack_n);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (( n*(n+1)/2 )))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", ( n*(n+1)/2 ));
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = ( n*(n+1)/2 );
    rblapack_arf = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  arf = NA_PTR_TYPE(rblapack_arf, doublereal*);

  dtpttf_(&transr, &uplo, &n, ap, arf, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_arf, rblapack_info);
}

void
init_lapack_dtpttf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtpttf", rblapack_dtpttf, -1);
}
ruby-lapack-1.7.2/ext/xerbla_array.c0000644000175000017500000000624612502221013017202 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID xerbla_array_(char* srname_array, integer* srname_len, integer* info);


static VALUE
rblapack_xerbla_array(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_srname_array;
  char *srname_array; 
  VALUE rblapack_info;
  integer info; 

  integer srname_len;

  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   = NumRu::Lapack.xerbla_array( srname_array, info, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE XERBLA_ARRAY( SRNAME_ARRAY, SRNAME_LEN, INFO)\n\n*  Purpose\n*  =======\n*\n*  XERBLA_ARRAY assists other languages in calling XERBLA, the LAPACK\n*  and BLAS error handler.  Rather than taking a Fortran string argument\n*  as the function's name, XERBLA_ARRAY takes an array of single\n*  characters along with the array's length.  XERBLA_ARRAY then copies\n*  up to 32 characters of that array into a Fortran string and passes\n*  that to XERBLA.  If called with a non-positive SRNAME_LEN,\n*  XERBLA_ARRAY will call XERBLA with a string of all blank characters.\n*\n*  Say some macro or other device makes XERBLA_ARRAY available to C99\n*  by a name lapack_xerbla and with a common Fortran calling convention.\n*  Then a C99 program could invoke XERBLA via:\n*     {\n*       int flen = strlen(__func__);\n*       lapack_xerbla(__func__, &flen, &info);\n*     }\n*\n*  Providing XERBLA_ARRAY is not necessary for intercepting LAPACK\n*  errors.  XERBLA_ARRAY calls XERBLA.\n*\n\n*  Arguments\n*  =========\n*\n*  SRNAME_ARRAY (input) CHARACTER(1) array, dimension (SRNAME_LEN)\n*          The name of the routine which called XERBLA_ARRAY.\n*\n*  SRNAME_LEN (input) INTEGER\n*          The length of the name in SRNAME_ARRAY.\n*\n*  INFO    (input) INTEGER\n*          The position of the invalid parameter in the parameter list\n*          of the calling routine.\n*\n\n* =====================================================================\n*\n*     ..\n*     .. Local Scalars ..\n      INTEGER I\n*     ..\n*     .. Local Arrays ..\n      CHARACTER*32 SRNAME\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC MIN, LEN\n*     ..\n*     .. External Functions ..\n      EXTERNAL XERBLA\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n   = NumRu::Lapack.xerbla_array( srname_array, info, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_srname_array = argv[0];
  rblapack_info = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  srname_array = StringValueCStr(rblapack_srname_array);
  info = NUM2INT(rblapack_info);

  xerbla_array_(srname_array, &srname_len, &info);

  return Qnil;
}

void
init_lapack_xerbla_array(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "xerbla_array", rblapack_xerbla_array, -1);
}
ruby-lapack-1.7.2/ext/dppcon.c0000644000175000017500000001020712502221023016003 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dppcon_(char* uplo, integer* n, doublereal* ap, doublereal* anorm, doublereal* rcond, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dppcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_anorm;
  doublereal anorm; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_info;
  integer info; 
  doublereal *work;
  integer *iwork;

  integer ldap;
  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  rcond, info = NumRu::Lapack.dppcon( uplo, ap, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPPCON( UPLO, N, AP, ANORM, RCOND, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPPCON estimates the reciprocal of the condition number (in the\n*  1-norm) of a real symmetric positive definite packed matrix using\n*  the Cholesky factorization A = U**T*U or A = L*L**T computed by\n*  DPPTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**T*U or A = L*L**T, packed columnwise in a linear\n*          array.  The j-th column of U or L is stored in the array AP\n*          as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n*  ANORM   (input) DOUBLE PRECISION\n*          The 1-norm (or infinity-norm) of the symmetric matrix A.\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n*          estimate of the 1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.dppcon( uplo, ap, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_anorm = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  anorm = NUM2DBL(rblapack_anorm);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  work = ALLOC_N(doublereal, (3*n));
  iwork = ALLOC_N(integer, (n));

  dppcon_(&uplo, &n, ap, &anorm, &rcond, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_dppcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dppcon", rblapack_dppcon, -1);
}
ruby-lapack-1.7.2/ext/zunmlq.c0000644000175000017500000001627312502221020016054 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zunmlq_(char* side, char* trans, integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zunmlq(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_c;
  doublecomplex *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublecomplex *c_out__;

  integer lda;
  integer m;
  integer k;
  integer ldc;
  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  work, info, c = NumRu::Lapack.zunmlq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZUNMLQ overwrites the general complex M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'C':      Q**H * C       C * Q**H\n*\n*  where Q is a complex unitary matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(k)' . . . H(2)' H(1)'\n*\n*  as returned by ZGELQF. Q is of order M if SIDE = 'L' and of order N\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**H from the Left;\n*          = 'R': apply Q or Q**H from the Right.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'C':  Conjugate transpose, apply Q**H.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension\n*                               (LDA,M) if SIDE = 'L',\n*                               (LDA,N) if SIDE = 'R'\n*          The i-th row must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          ZGELQF in the first k rows of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,K).\n*\n*  TAU     (input) COMPLEX*16 array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by ZGELQF.\n*\n*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace/output) COMPLEX*16 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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M).\n*          For optimum performance LWORK >= N*NB if SIDE 'L', and\n*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n*          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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.zunmlq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_a = argv[2];
  rblapack_tau = argv[3];
  rblapack_c = argv[4];
  if (argc == 6) {
    rblapack_lwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
  MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  zunmlq_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_zunmlq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zunmlq", rblapack_zunmlq, -1);
}
ruby-lapack-1.7.2/ext/dgtsvx.c0000644000175000017500000004166312502221013016050 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgtsvx_(char* fact, char* trans, integer* n, integer* nrhs, doublereal* dl, doublereal* d, doublereal* du, doublereal* dlf, doublereal* df, doublereal* duf, doublereal* du2, integer* ipiv, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dgtsvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_dl;
  doublereal *dl; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_du;
  doublereal *du; 
  VALUE rblapack_dlf;
  doublereal *dlf; 
  VALUE rblapack_df;
  doublereal *df; 
  VALUE rblapack_duf;
  doublereal *duf; 
  VALUE rblapack_du2;
  doublereal *du2; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_dlf_out__;
  doublereal *dlf_out__;
  VALUE rblapack_df_out__;
  doublereal *df_out__;
  VALUE rblapack_duf_out__;
  doublereal *duf_out__;
  VALUE rblapack_du2_out__;
  doublereal *du2_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  doublereal *work;
  integer *iwork;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, info, dlf, df, duf, du2, ipiv = NumRu::Lapack.dgtsvx( fact, trans, dl, d, du, dlf, df, duf, du2, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGTSVX uses the LU factorization to compute the solution to a real\n*  system of linear equations A * X = B or A**T * X = B,\n*  where A is a tridiagonal matrix of order N and X and B are N-by-NRHS\n*  matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'N', the LU decomposition is used to factor the matrix A\n*     as A = L * U, where L is a product of permutation and unit lower\n*     bidiagonal matrices and U is upper triangular with nonzeros in\n*     only the main diagonal and first two superdiagonals.\n*\n*  2. If some U(i,i)=0, so that U is exactly singular, then the routine\n*     returns with INFO = i. Otherwise, the factored form of A is used\n*     to estimate the condition number of the matrix A.  If the\n*     reciprocal of the condition number is less than machine precision,\n*     INFO = N+1 is returned as a warning, but the routine still goes on\n*     to solve for X and compute error bounds as described below.\n*\n*  3. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  4. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of A has been\n*          supplied on entry.\n*          = 'F':  DLF, DF, DUF, DU2, and IPIV contain the factored\n*                  form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV\n*                  will not be modified.\n*          = 'N':  The matrix will be copied to DLF, DF, and DUF\n*                  and factored.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  DL      (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (n-1) subdiagonal elements of A.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          The n diagonal elements of A.\n*\n*  DU      (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (n-1) superdiagonal elements of A.\n*\n*  DLF     (input or output) DOUBLE PRECISION array, dimension (N-1)\n*          If FACT = 'F', then DLF is an input argument and on entry\n*          contains the (n-1) multipliers that define the matrix L from\n*          the LU factorization of A as computed by DGTTRF.\n*\n*          If FACT = 'N', then DLF is an output argument and on exit\n*          contains the (n-1) multipliers that define the matrix L from\n*          the LU factorization of A.\n*\n*  DF      (input or output) DOUBLE PRECISION array, dimension (N)\n*          If FACT = 'F', then DF is an input argument and on entry\n*          contains the n diagonal elements of the upper triangular\n*          matrix U from the LU factorization of A.\n*\n*          If FACT = 'N', then DF is an output argument and on exit\n*          contains the n diagonal elements of the upper triangular\n*          matrix U from the LU factorization of A.\n*\n*  DUF     (input or output) DOUBLE PRECISION array, dimension (N-1)\n*          If FACT = 'F', then DUF is an input argument and on entry\n*          contains the (n-1) elements of the first superdiagonal of U.\n*\n*          If FACT = 'N', then DUF is an output argument and on exit\n*          contains the (n-1) elements of the first superdiagonal of U.\n*\n*  DU2     (input or output) DOUBLE PRECISION array, dimension (N-2)\n*          If FACT = 'F', then DU2 is an input argument and on entry\n*          contains the (n-2) elements of the second superdiagonal of\n*          U.\n*\n*          If FACT = 'N', then DU2 is an output argument and on exit\n*          contains the (n-2) elements of the second superdiagonal of\n*          U.\n*\n*  IPIV    (input or output) INTEGER array, dimension (N)\n*          If FACT = 'F', then IPIV is an input argument and on entry\n*          contains the pivot indices from the LU factorization of A as\n*          computed by DGTTRF.\n*\n*          If FACT = 'N', then IPIV is an output argument and on exit\n*          contains the pivot indices from the LU factorization of A;\n*          row i of the matrix was interchanged with row IPIV(i).\n*          IPIV(i) will always be either i or i+1; IPIV(i) = i indicates\n*          a row interchange was not required.\n*\n*  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          The N-by-NRHS right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The estimate of the reciprocal condition number of the matrix\n*          A.  If RCOND is less than the machine precision (in\n*          particular, if RCOND = 0), the matrix is singular to working\n*          precision.  This condition is indicated by a return code of\n*          INFO > 0.\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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, and i is\n*                <= N:  U(i,i) is exactly zero.  The factorization\n*                       has not been completed unless i = N, but the\n*                       factor U is exactly singular, so the solution\n*                       and error bounds could not be computed.\n*                       RCOND = 0 is returned.\n*                = N+1: U is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, info, dlf, df, duf, du2, ipiv = NumRu::Lapack.dgtsvx( fact, trans, dl, d, du, dlf, df, duf, du2, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 11 && argc != 11)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
  rblapack_fact = argv[0];
  rblapack_trans = argv[1];
  rblapack_dl = argv[2];
  rblapack_d = argv[3];
  rblapack_du = argv[4];
  rblapack_dlf = argv[5];
  rblapack_df = argv[6];
  rblapack_duf = argv[7];
  rblapack_du2 = argv[8];
  rblapack_ipiv = argv[9];
  rblapack_b = argv[10];
  if (argc == 11) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_df))
    rb_raise(rb_eArgError, "df (7th argument) must be NArray");
  if (NA_RANK(rblapack_df) != 1)
    rb_raise(rb_eArgError, "rank of df (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_df) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of df must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_df) != NA_DFLOAT)
    rblapack_df = na_change_type(rblapack_df, NA_DFLOAT);
  df = NA_PTR_TYPE(rblapack_df, doublereal*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (10th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (10th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  ldx = MAX(1,n);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (5th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_DFLOAT)
    rblapack_du = na_change_type(rblapack_du, NA_DFLOAT);
  du = NA_PTR_TYPE(rblapack_du, doublereal*);
  if (!NA_IsNArray(rblapack_duf))
    rb_raise(rb_eArgError, "duf (8th argument) must be NArray");
  if (NA_RANK(rblapack_duf) != 1)
    rb_raise(rb_eArgError, "rank of duf (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_duf) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of duf must be %d", n-1);
  if (NA_TYPE(rblapack_duf) != NA_DFLOAT)
    rblapack_duf = na_change_type(rblapack_duf, NA_DFLOAT);
  duf = NA_PTR_TYPE(rblapack_duf, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (11th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (11th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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 (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (3th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_DFLOAT)
    rblapack_dl = na_change_type(rblapack_dl, NA_DFLOAT);
  dl = NA_PTR_TYPE(rblapack_dl, doublereal*);
  if (!NA_IsNArray(rblapack_du2))
    rb_raise(rb_eArgError, "du2 (9th argument) must be NArray");
  if (NA_RANK(rblapack_du2) != 1)
    rb_raise(rb_eArgError, "rank of du2 (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du2) != (n-2))
    rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
  if (NA_TYPE(rblapack_du2) != NA_DFLOAT)
    rblapack_du2 = na_change_type(rblapack_du2, NA_DFLOAT);
  du2 = NA_PTR_TYPE(rblapack_du2, doublereal*);
  if (!NA_IsNArray(rblapack_dlf))
    rb_raise(rb_eArgError, "dlf (6th argument) must be NArray");
  if (NA_RANK(rblapack_dlf) != 1)
    rb_raise(rb_eArgError, "rank of dlf (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dlf) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dlf must be %d", n-1);
  if (NA_TYPE(rblapack_dlf) != NA_DFLOAT)
    rblapack_dlf = na_change_type(rblapack_dlf, NA_DFLOAT);
  dlf = NA_PTR_TYPE(rblapack_dlf, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_dlf_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  dlf_out__ = NA_PTR_TYPE(rblapack_dlf_out__, doublereal*);
  MEMCPY(dlf_out__, dlf, doublereal, NA_TOTAL(rblapack_dlf));
  rblapack_dlf = rblapack_dlf_out__;
  dlf = dlf_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_df_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  df_out__ = NA_PTR_TYPE(rblapack_df_out__, doublereal*);
  MEMCPY(df_out__, df, doublereal, NA_TOTAL(rblapack_df));
  rblapack_df = rblapack_df_out__;
  df = df_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_duf_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  duf_out__ = NA_PTR_TYPE(rblapack_duf_out__, doublereal*);
  MEMCPY(duf_out__, duf, doublereal, NA_TOTAL(rblapack_duf));
  rblapack_duf = rblapack_duf_out__;
  duf = duf_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-2;
    rblapack_du2_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  du2_out__ = NA_PTR_TYPE(rblapack_du2_out__, doublereal*);
  MEMCPY(du2_out__, du2, doublereal, NA_TOTAL(rblapack_du2));
  rblapack_du2 = rblapack_du2_out__;
  du2 = du2_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  work = ALLOC_N(doublereal, (3*n));
  iwork = ALLOC_N(integer, (n));

  dgtsvx_(&fact, &trans, &n, &nrhs, dl, d, du, dlf, df, duf, du2, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_dlf, rblapack_df, rblapack_duf, rblapack_du2, rblapack_ipiv);
}

void
init_lapack_dgtsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgtsvx", rblapack_dgtsvx, -1);
}
ruby-lapack-1.7.2/ext/zsytrf.c0000644000175000017500000002023612502221026016067 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zsytrf_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zsytrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *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  ipiv, work, info, a = NumRu::Lapack.zsytrf( uplo, a, lwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZSYTRF computes the factorization of a complex symmetric matrix A\n*  using the Bunch-Kaufman diagonal pivoting method.  The form of the\n*  factorization is\n*\n*     A = U*D*U**T  or  A = L*D*L**T\n*\n*  where U (or L) is a product of permutation and unit upper (lower)\n*  triangular matrices, and D is symmetric and block diagonal with\n*  with 1-by-1 and 2-by-2 diagonal blocks.\n*\n*  This is the blocked version of the algorithm, calling Level 3 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L (see below for further details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D.\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of WORK.  LWORK >=1.  For best performance\n*          LWORK >= N*NB, where NB is the block size returned by ILAENV.\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, D(i,i) is exactly zero.  The factorization\n*                has been completed, but the block diagonal matrix D is\n*                exactly singular, and division by zero will occur if it\n*                is used to solve a system of equations.\n*\n\n*  Further Details\n*  ===============\n*\n*  If UPLO = 'U', then A = U*D*U', where\n*     U = P(n)*U(n)* ... *P(k)U(k)* ...,\n*  i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n*  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    v    0   )   k-s\n*     U(k) =  (   0    I    0   )   s\n*             (   0    0    I   )   n-k\n*                k-s   s   n-k\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n*  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n*  and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n*  If UPLO = 'L', then A = L*D*L', where\n*     L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n*  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n*  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    0     0   )  k-1\n*     L(k) =  (   0    I     0   )  s\n*             (   0    v     I   )  n-k-s+1\n*                k-1   s  n-k-s+1\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n*  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n*  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY, UPPER\n      INTEGER            IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            ILAENV\n      EXTERNAL           LSAME, ILAENV\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZLASYF, ZSYTF2\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, work, info, a = NumRu::Lapack.zsytrf( uplo, a, lwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_lwork = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  lwork = NUM2INT(rblapack_lwork);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zsytrf_(&uplo, &n, a, &lda, ipiv, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ipiv, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_zsytrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zsytrf", rblapack_zsytrf, -1);
}
ruby-lapack-1.7.2/ext/slaed6.c0000644000175000017500000001211512502221012015674 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaed6_(integer* kniter, logical* orgati, real* rho, real* d, real* z, real* finit, real* tau, integer* info);


static VALUE
rblapack_slaed6(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_kniter;
  integer kniter; 
  VALUE rblapack_orgati;
  logical orgati; 
  VALUE rblapack_rho;
  real rho; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_finit;
  real finit; 
  VALUE rblapack_tau;
  real tau; 
  VALUE rblapack_info;
  integer info; 


  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 = NumRu::Lapack.slaed6( kniter, orgati, rho, d, z, finit, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLAED6 computes the positive or negative root (closest to the origin)\n*  of\n*                   z(1)        z(2)        z(3)\n*  f(x) =   rho + --------- + ---------- + ---------\n*                  d(1)-x      d(2)-x      d(3)-x\n*\n*  It is assumed that\n*\n*        if ORGATI = .true. the root is between d(2) and d(3);\n*        otherwise it is between d(1) and d(2)\n*\n*  This routine will be called by SLAED4 when necessary. In most cases,\n*  the root sought is the smallest in magnitude, though it might not be\n*  in some extremely rare situations.\n*\n\n*  Arguments\n*  =========\n*\n*  KNITER       (input) INTEGER\n*               Refer to SLAED4 for its significance.\n*\n*  ORGATI       (input) LOGICAL\n*               If ORGATI is true, the needed root is between d(2) and\n*               d(3); otherwise it is between d(1) and d(2).  See\n*               SLAED4 for further details.\n*\n*  RHO          (input) REAL            \n*               Refer to the equation f(x) above.\n*\n*  D            (input) REAL array, dimension (3)\n*               D satisfies d(1) < d(2) < d(3).\n*\n*  Z            (input) REAL array, dimension (3)\n*               Each of the elements in z must be positive.\n*\n*  FINIT        (input) REAL            \n*               The value of f at 0. It is more accurate than the one\n*               evaluated inside this routine (if someone wants to do\n*               so).\n*\n*  TAU          (output) REAL            \n*               The root of the equation f(x).\n*\n*  INFO         (output) INTEGER\n*               = 0: successful exit\n*               > 0: if INFO = 1, failure to converge\n*\n\n*  Further Details\n*  ===============\n*\n*  30/06/99: Based on contributions by\n*     Ren-Cang Li, Computer Science Division, University of California\n*     at Berkeley, USA\n*\n*  10/02/03: This version has a few statements commented out for thread safety\n*     (machine parameters are computed on each entry). SJH.\n*\n*  05/10/06: Modified from a new version of Ren-Cang Li, use\n*     Gragg-Thornton-Warner cubic convergent scheme for better stability.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, info = NumRu::Lapack.slaed6( kniter, orgati, rho, d, z, finit, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_kniter = argv[0];
  rblapack_orgati = argv[1];
  rblapack_rho = argv[2];
  rblapack_d = argv[3];
  rblapack_z = argv[4];
  rblapack_finit = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  kniter = NUM2INT(rblapack_kniter);
  rho = (real)NUM2DBL(rblapack_rho);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (5th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != (3))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 3);
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  orgati = (rblapack_orgati == Qtrue);
  finit = (real)NUM2DBL(rblapack_finit);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != (3))
    rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", 3);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);

  slaed6_(&kniter, &orgati, &rho, d, z, &finit, &tau, &info);

  rblapack_tau = rb_float_new((double)tau);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_tau, rblapack_info);
}

void
init_lapack_slaed6(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaed6", rblapack_slaed6, -1);
}
ruby-lapack-1.7.2/ext/sgesvx.c0000644000175000017500000004767212502221012016055 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgesvx_(char* fact, char* trans, integer* n, integer* nrhs, real* a, integer* lda, real* af, integer* ldaf, integer* ipiv, char* equed, real* r, real* c, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* ferr, real* berr, real* work, integer* iwork, integer* info);


static VALUE
rblapack_sgesvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_af;
  real *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_r;
  real *r; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_af_out__;
  real *af_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  VALUE rblapack_r_out__;
  real *r_out__;
  VALUE rblapack_c_out__;
  real *c_out__;
  VALUE rblapack_b_out__;
  real *b_out__;
  integer *iwork;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;
  integer ldaf;
  integer ldx;

  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  x, rcond, ferr, berr, work, info, a, af, ipiv, equed, r, c, b = NumRu::Lapack.sgesvx( fact, trans, a, b, [:af => af, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGESVX uses the LU factorization to compute the solution to a real\n*  system of linear equations\n*     A * X = B,\n*  where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'E', real scaling factors are computed to equilibrate\n*     the system:\n*        TRANS = 'N':  diag(R)*A*diag(C)     *inv(diag(C))*X = diag(R)*B\n*        TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n*        TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n*     or diag(C)*B (if TRANS = 'T' or 'C').\n*\n*  2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n*     matrix A (after equilibration if FACT = 'E') as\n*        A = P * L * U,\n*     where P is a permutation matrix, L is a unit lower triangular\n*     matrix, and U is upper triangular.\n*\n*  3. If some U(i,i)=0, so that U is exactly singular, then the routine\n*     returns with INFO = i. Otherwise, the factored form of A is used\n*     to estimate the condition number of the matrix A.  If the\n*     reciprocal of the condition number is less than machine precision,\n*     INFO = N+1 is returned as a warning, but the routine still goes on\n*     to solve for X and compute error bounds as described below.\n*\n*  4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  5. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n*  6. If equilibration was used, the matrix X is premultiplied by\n*     diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n*     that it solves the original system before equilibration.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of the matrix A is\n*          supplied on entry, and if not, whether the matrix A should be\n*          equilibrated before it is factored.\n*          = 'F':  On entry, AF and IPIV contain the factored form of A.\n*                  If EQUED is not 'N', the matrix A has been\n*                  equilibrated with scaling factors given by R and C.\n*                  A, AF, and IPIV are not modified.\n*          = 'N':  The matrix A will be copied to AF and factored.\n*          = 'E':  The matrix A will be equilibrated if necessary, then\n*                  copied to AF and factored.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Transpose)\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the N-by-N matrix A.  If FACT = 'F' and EQUED is\n*          not 'N', then A must have been equilibrated by the scaling\n*          factors in R and/or C.  A is not modified if FACT = 'F' or\n*          'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n*          On exit, if EQUED .ne. 'N', A is scaled as follows:\n*          EQUED = 'R':  A := diag(R) * A\n*          EQUED = 'C':  A := A * diag(C)\n*          EQUED = 'B':  A := diag(R) * A * diag(C).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AF      (input or output) REAL array, dimension (LDAF,N)\n*          If FACT = 'F', then AF is an input argument and on entry\n*          contains the factors L and U from the factorization\n*          A = P*L*U as computed by SGETRF.  If EQUED .ne. 'N', then\n*          AF is the factored form of the equilibrated matrix A.\n*\n*          If FACT = 'N', then AF is an output argument and on exit\n*          returns the factors L and U from the factorization A = P*L*U\n*          of the original matrix A.\n*\n*          If FACT = 'E', then AF is an output argument and on exit\n*          returns the factors L and U from the factorization A = P*L*U\n*          of the equilibrated matrix A (see the description of A for\n*          the form of the equilibrated matrix).\n*\n*  LDAF    (input) INTEGER\n*          The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*  IPIV    (input or output) INTEGER array, dimension (N)\n*          If FACT = 'F', then IPIV is an input argument and on entry\n*          contains the pivot indices from the factorization A = P*L*U\n*          as computed by SGETRF; row i of the matrix was interchanged\n*          with row IPIV(i).\n*\n*          If FACT = 'N', then IPIV is an output argument and on exit\n*          contains the pivot indices from the factorization A = P*L*U\n*          of the original matrix A.\n*\n*          If FACT = 'E', then IPIV is an output argument and on exit\n*          contains the pivot indices from the factorization A = P*L*U\n*          of the equilibrated matrix A.\n*\n*  EQUED   (input or output) CHARACTER*1\n*          Specifies the form of equilibration that was done.\n*          = 'N':  No equilibration (always true if FACT = 'N').\n*          = 'R':  Row equilibration, i.e., A has been premultiplied by\n*                  diag(R).\n*          = 'C':  Column equilibration, i.e., A has been postmultiplied\n*                  by diag(C).\n*          = 'B':  Both row and column equilibration, i.e., A has been\n*                  replaced by diag(R) * A * diag(C).\n*          EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*          output argument.\n*\n*  R       (input or output) REAL array, dimension (N)\n*          The row scale factors for A.  If EQUED = 'R' or 'B', A is\n*          multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n*          is not accessed.  R is an input argument if FACT = 'F';\n*          otherwise, R is an output argument.  If FACT = 'F' and\n*          EQUED = 'R' or 'B', each element of R must be positive.\n*\n*  C       (input or output) REAL array, dimension (N)\n*          The column scale factors for A.  If EQUED = 'C' or 'B', A is\n*          multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n*          is not accessed.  C is an input argument if FACT = 'F';\n*          otherwise, C is an output argument.  If FACT = 'F' and\n*          EQUED = 'C' or 'B', each element of C must be positive.\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit,\n*          if EQUED = 'N', B is not modified;\n*          if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n*          diag(R)*B;\n*          if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n*          overwritten by diag(C)*B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) REAL array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n*          to the original system of equations.  Note that A and B are\n*          modified on exit if EQUED .ne. 'N', and the solution to the\n*          equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n*          EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n*          and EQUED = 'R' or 'B'.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) REAL\n*          The estimate of the reciprocal condition number of the matrix\n*          A after equilibration (if done).  If RCOND is less than the\n*          machine precision (in particular, if RCOND = 0), the matrix\n*          is singular to working precision.  This condition is\n*          indicated by a return code of INFO > 0.\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace/output) REAL array, dimension (4*N)\n*          On exit, WORK(1) contains the reciprocal pivot growth\n*          factor norm(A)/norm(U). The \"max absolute element\" norm is\n*          used. If WORK(1) is much less than 1, then the stability\n*          of the LU factorization of the (equilibrated) matrix A\n*          could be poor. This also means that the solution X, condition\n*          estimator RCOND, and forward error bound FERR could be\n*          unreliable. If factorization fails with 0 0:  if INFO = i, and i is\n*                <= N:  U(i,i) is exactly zero.  The factorization has\n*                       been completed, but the factor U is exactly\n*                       singular, so the solution and error bounds\n*                       could not be computed. RCOND = 0 is returned.\n*                = N+1: U is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, work, info, a, af, ipiv, equed, r, c, b = NumRu::Lapack.sgesvx( fact, trans, a, b, [:af => af, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_fact = argv[0];
  rblapack_trans = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  if (argc == 9) {
    rblapack_af = argv[4];
    rblapack_ipiv = argv[5];
    rblapack_equed = argv[6];
    rblapack_r = argv[7];
    rblapack_c = argv[8];
  } else if (rblapack_options != Qnil) {
    rblapack_af = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("af")));
    rblapack_ipiv = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("ipiv")));
    rblapack_equed = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("equed")));
    rblapack_r = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("r")));
    rblapack_c = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("c")));
  } else {
    rblapack_af = Qnil;
    rblapack_ipiv = Qnil;
    rblapack_equed = Qnil;
    rblapack_r = Qnil;
    rblapack_c = Qnil;
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (rblapack_ipiv != Qnil) {
    if (!NA_IsNArray(rblapack_ipiv))
      rb_raise(rb_eArgError, "ipiv (option) must be NArray");
    if (NA_RANK(rblapack_ipiv) != 1)
      rb_raise(rb_eArgError, "rank of ipiv (option) must be %d", 1);
    if (NA_SHAPE0(rblapack_ipiv) != n)
      rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
    if (NA_TYPE(rblapack_ipiv) != NA_LINT)
      rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
    ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  }
  if (rblapack_r != Qnil) {
    if (!NA_IsNArray(rblapack_r))
      rb_raise(rb_eArgError, "r (option) must be NArray");
    if (NA_RANK(rblapack_r) != 1)
      rb_raise(rb_eArgError, "rank of r (option) must be %d", 1);
    if (NA_SHAPE0(rblapack_r) != n)
      rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of a");
    if (NA_TYPE(rblapack_r) != NA_SFLOAT)
      rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
    r = NA_PTR_TYPE(rblapack_r, real*);
  }
  ldx = n;
  trans = StringValueCStr(rblapack_trans)[0];
  if (rblapack_equed != Qnil) {
  equed = StringValueCStr(rblapack_equed)[0];
  }
  ldaf = n;
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (rblapack_c != Qnil) {
    if (!NA_IsNArray(rblapack_c))
      rb_raise(rb_eArgError, "c (option) must be NArray");
    if (NA_RANK(rblapack_c) != 1)
      rb_raise(rb_eArgError, "rank of c (option) must be %d", 1);
    if (NA_SHAPE0(rblapack_c) != n)
      rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
    if (NA_TYPE(rblapack_c) != NA_SFLOAT)
      rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
    c = NA_PTR_TYPE(rblapack_c, real*);
  }
  if (rblapack_af != Qnil) {
    if (!NA_IsNArray(rblapack_af))
      rb_raise(rb_eArgError, "af (option) must be NArray");
    if (NA_RANK(rblapack_af) != 2)
      rb_raise(rb_eArgError, "rank of af (option) must be %d", 2);
    if (NA_SHAPE0(rblapack_af) != ldaf)
      rb_raise(rb_eRuntimeError, "shape 0 of af must be n");
    if (NA_SHAPE1(rblapack_af) != n)
      rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
    if (NA_TYPE(rblapack_af) != NA_SFLOAT)
      rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
    af = NA_PTR_TYPE(rblapack_af, real*);
  }
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[1];
    shape[0] = 4*n;
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldaf;
    shape[1] = n;
    rblapack_af_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  af_out__ = NA_PTR_TYPE(rblapack_af_out__, real*);
  if (rblapack_af != Qnil) {
    MEMCPY(af_out__, af, real, NA_TOTAL(rblapack_af));
  }
  rblapack_af = rblapack_af_out__;
  af = af_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  if (rblapack_ipiv != Qnil) {
    MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  }
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_r_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  r_out__ = NA_PTR_TYPE(rblapack_r_out__, real*);
  if (rblapack_r != Qnil) {
    MEMCPY(r_out__, r, real, NA_TOTAL(rblapack_r));
  }
  rblapack_r = rblapack_r_out__;
  r = r_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  if (rblapack_c != Qnil) {
    MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  }
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  iwork = ALLOC_N(integer, (n));

  sgesvx_(&fact, &trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);

  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(13, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_work, rblapack_info, rblapack_a, rblapack_af, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b);
}

void
init_lapack_sgesvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgesvx", rblapack_sgesvx, -1);
}
ruby-lapack-1.7.2/ext/clapmr.c0000644000175000017500000001037512502221017016007 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clapmr_(logical* forwrd, integer* m, integer* n, complex* x, integer* ldx, integer* k);


static VALUE
rblapack_clapmr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_forwrd;
  logical forwrd; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_k;
  integer *k; 
  VALUE rblapack_x_out__;
  complex *x_out__;
  VALUE rblapack_k_out__;
  integer *k_out__;

  integer ldx;
  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  x, k = NumRu::Lapack.clapmr( forwrd, x, k, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAPMR( FORWRD, M, N, X, LDX, K )\n\n*  Purpose\n*  =======\n*\n*  CLAPMR rearranges the rows of the M by N matrix X as specified\n*  by the permutation K(1),K(2),...,K(M) of the integers 1,...,M.\n*  If FORWRD = .TRUE.,  forward permutation:\n*\n*       X(K(I),*) is moved X(I,*) for I = 1,2,...,M.\n*\n*  If FORWRD = .FALSE., backward permutation:\n*\n*       X(I,*) is moved to X(K(I),*) for I = 1,2,...,M.\n*\n\n*  Arguments\n*  =========\n*\n*  FORWRD  (input) LOGICAL\n*          = .TRUE., forward permutation\n*          = .FALSE., backward permutation\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix X. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix X. N >= 0.\n*\n*  X       (input/output) COMPLEX array, dimension (LDX,N)\n*          On entry, the M by N matrix X.\n*          On exit, X contains the permuted matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X, LDX >= MAX(1,M).\n*\n*  K       (input/output) INTEGER array, dimension (M)\n*          On entry, K contains the permutation vector. K is used as\n*          internal workspace, but reset to its original value on\n*          output.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, IN, J, JJ\n      COMPLEX            TEMP\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, k = NumRu::Lapack.clapmr( forwrd, x, k, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_forwrd = argv[0];
  rblapack_x = argv[1];
  rblapack_k = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  forwrd = (rblapack_forwrd == Qtrue);
  if (!NA_IsNArray(rblapack_k))
    rb_raise(rb_eArgError, "k (3th argument) must be NArray");
  if (NA_RANK(rblapack_k) != 1)
    rb_raise(rb_eArgError, "rank of k (3th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_k);
  if (NA_TYPE(rblapack_k) != NA_LINT)
    rblapack_k = na_change_type(rblapack_k, NA_LINT);
  k = NA_PTR_TYPE(rblapack_k, integer*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  n = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = n;
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_k_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  k_out__ = NA_PTR_TYPE(rblapack_k_out__, integer*);
  MEMCPY(k_out__, k, integer, NA_TOTAL(rblapack_k));
  rblapack_k = rblapack_k_out__;
  k = k_out__;

  clapmr_(&forwrd, &m, &n, x, &ldx, k);

  return rb_ary_new3(2, rblapack_x, rblapack_k);
}

void
init_lapack_clapmr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clapmr", rblapack_clapmr, -1);
}
ruby-lapack-1.7.2/ext/ctfsm.c0000644000175000017500000002645612502221025015653 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctfsm_(char* transr, char* side, char* uplo, char* trans, char* diag, integer* m, integer* n, complex* alpha, complex* a, complex* b, integer* ldb);


static VALUE
rblapack_ctfsm(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_alpha;
  complex alpha; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer ldb;
  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  b = NumRu::Lapack.ctfsm( transr, side, uplo, trans, diag, m, alpha, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, B, LDB )\n\n*  Purpose\n*  =======\n*\n*  Level 3 BLAS like routine for A in RFP Format.\n*\n*  CTFSM solves the matrix equation\n*\n*     op( A )*X = alpha*B  or  X*op( A ) = alpha*B\n*\n*  where alpha is a scalar, X and B are m by n matrices, A is a unit, or\n*  non-unit,  upper or lower triangular matrix  and  op( A )  is one  of\n*\n*     op( A ) = A   or   op( A ) = conjg( A' ).\n*\n*  A is in Rectangular Full Packed (RFP) Format.\n*\n*  The matrix X is overwritten on B.\n*\n\n*  Arguments\n*  ==========\n*\n*  TRANSR  (input) CHARACTER*1\n*          = 'N':  The Normal Form of RFP A is stored;\n*          = 'C':  The Conjugate-transpose Form of RFP A is stored.\n*\n*  SIDE    (input) CHARACTER*1\n*           On entry, SIDE specifies whether op( A ) appears on the left\n*           or right of X as follows:\n*\n*              SIDE = 'L' or 'l'   op( A )*X = alpha*B.\n*\n*              SIDE = 'R' or 'r'   X*op( A ) = alpha*B.\n*\n*           Unchanged on exit.\n*\n*  UPLO    (input) CHARACTER*1\n*           On entry, UPLO specifies whether the RFP matrix A came from\n*           an upper or lower triangular matrix as follows:\n*           UPLO = 'U' or 'u' RFP A came from an upper triangular matrix\n*           UPLO = 'L' or 'l' RFP A came from a  lower triangular matrix\n*\n*           Unchanged on exit.\n*\n*  TRANS   (input) CHARACTER*1\n*           On entry, TRANS  specifies the form of op( A ) to be used\n*           in the matrix multiplication as follows:\n*\n*              TRANS  = 'N' or 'n'   op( A ) = A.\n*\n*              TRANS  = 'C' or 'c'   op( A ) = conjg( A' ).\n*\n*           Unchanged on exit.\n*\n*  DIAG    (input) CHARACTER*1\n*           On entry, DIAG specifies whether or not RFP A is unit\n*           triangular as follows:\n*\n*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.\n*\n*              DIAG = 'N' or 'n'   A is not assumed to be unit\n*                                  triangular.\n*\n*           Unchanged on exit.\n*\n*  M       (input) INTEGER\n*           On entry, M specifies the number of rows of B. M must be at\n*           least zero.\n*           Unchanged on exit.\n*\n*  N       (input) INTEGER\n*           On entry, N specifies the number of columns of B.  N must be\n*           at least zero.\n*           Unchanged on exit.\n*\n*  ALPHA   (input) COMPLEX\n*           On entry,  ALPHA specifies the scalar  alpha. When  alpha is\n*           zero then  A is not referenced and  B need not be set before\n*           entry.\n*           Unchanged on exit.\n*\n*  A       (input) COMPLEX array, dimension (N*(N+1)/2)\n*           NT = N*(N+1)/2. On entry, the matrix A in RFP Format.\n*           RFP Format is described by TRANSR, UPLO and N as follows:\n*           If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;\n*           K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If\n*           TRANSR = 'C' then RFP is the Conjugate-transpose of RFP A as\n*           defined when TRANSR = 'N'. The contents of RFP A are defined\n*           by UPLO as follows: If UPLO = 'U' the RFP A contains the NT\n*           elements of upper packed A either in normal or\n*           conjugate-transpose Format. If UPLO = 'L' the RFP A contains\n*           the NT elements of lower packed A either in normal or\n*           conjugate-transpose Format. The LDA of RFP A is (N+1)/2 when\n*           TRANSR = 'C'. When TRANSR is 'N' the LDA is N+1 when N is\n*           even and is N when is odd.\n*           See the Note below for more details. Unchanged on exit.\n*\n*  B       (input/output) COMPLEX array,  dimension (LDB,N)\n*           Before entry,  the leading  m by n part of the array  B must\n*           contain  the  right-hand  side  matrix  B,  and  on exit  is\n*           overwritten by the solution matrix  X.\n*\n*  LDB     (input) INTEGER\n*           On entry, LDB specifies the first dimension of B as declared\n*           in  the  calling  (sub)  program.   LDB  must  be  at  least\n*           max( 1, m ).\n*           Unchanged on exit.\n*\n\n*  Further Details\n*  ===============\n*\n*  We first consider Standard Packed Format when N is even.\n*  We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  conjugate-transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  conjugate-transpose of the last three columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                -- -- --\n*        03 04 05                33 43 53\n*                                   -- --\n*        13 14 15                00 44 54\n*                                      --\n*        23 24 25                10 11 55\n*\n*        33 34 35                20 21 22\n*        --\n*        00 44 45                30 31 32\n*        -- --\n*        01 11 55                40 41 42\n*        -- -- --\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- -- --                -- -- -- -- -- --\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     -- -- -- -- --                -- -- -- -- --\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     -- -- -- -- -- --                -- -- -- --\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We next  consider Standard Packed Format when N is odd.\n*  We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  conjugate-transpose of the first two   columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  conjugate-transpose of the last two   columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N odd  and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                   -- --\n*        02 03 04                00 33 43\n*                                      --\n*        12 13 14                10 11 44\n*\n*        22 23 24                20 21 22\n*        --\n*        00 33 34                30 31 32\n*        -- --\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- --                   -- -- -- -- -- --\n*     02 12 22 00 01             00 10 20 30 40 50\n*     -- -- -- --                   -- -- -- -- --\n*     03 13 23 33 11             33 11 21 31 41 51\n*     -- -- -- -- --                   -- -- -- --\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  b = NumRu::Lapack.ctfsm( transr, side, uplo, trans, diag, m, alpha, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_transr = argv[0];
  rblapack_side = argv[1];
  rblapack_uplo = argv[2];
  rblapack_trans = argv[3];
  rblapack_diag = argv[4];
  rblapack_m = argv[5];
  rblapack_alpha = argv[6];
  rblapack_a = argv[7];
  rblapack_b = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  alpha.r = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
  alpha.i = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (9th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (9th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  side = StringValueCStr(rblapack_side)[0];
  m = NUM2INT(rblapack_m);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (8th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 1)
    rb_raise(rb_eArgError, "rank of a (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  ctfsm_(&transr, &side, &uplo, &trans, &diag, &m, &n, &alpha, a, b, &ldb);

  return rblapack_b;
}

void
init_lapack_ctfsm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctfsm", rblapack_ctfsm, -1);
}
ruby-lapack-1.7.2/ext/zlarfg.c0000644000175000017500000001037212502221026016013 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlarfg_(integer* n, doublecomplex* alpha, doublecomplex* x, integer* incx, doublecomplex* tau);


static VALUE
rblapack_zlarfg(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_alpha;
  doublecomplex alpha; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_tau;
  doublecomplex tau; 
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;


  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, alpha, x = NumRu::Lapack.zlarfg( n, alpha, x, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )\n\n*  Purpose\n*  =======\n*\n*  ZLARFG generates a complex elementary reflector H of order n, such\n*  that\n*\n*        H' * ( alpha ) = ( beta ),   H' * H = I.\n*             (   x   )   (   0  )\n*\n*  where alpha and beta are scalars, with beta real, and x is an\n*  (n-1)-element complex vector. H is represented in the form\n*\n*        H = I - tau * ( 1 ) * ( 1 v' ) ,\n*                      ( v )\n*\n*  where tau is a complex scalar and v is a complex (n-1)-element\n*  vector. Note that H is not hermitian.\n*\n*  If the elements of x are all zero and alpha is real, then tau = 0\n*  and H is taken to be the unit matrix.\n*\n*  Otherwise  1 <= real(tau) <= 2  and  abs(tau-1) <= 1 .\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the elementary reflector.\n*\n*  ALPHA   (input/output) COMPLEX*16\n*          On entry, the value alpha.\n*          On exit, it is overwritten with the value beta.\n*\n*  X       (input/output) COMPLEX*16 array, dimension\n*                         (1+(N-2)*abs(INCX))\n*          On entry, the vector x.\n*          On exit, it is overwritten with the vector v.\n*\n*  INCX    (input) INTEGER\n*          The increment between elements of X. INCX > 0.\n*\n*  TAU     (output) COMPLEX*16\n*          The value tau.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, alpha, x = NumRu::Lapack.zlarfg( n, alpha, x, incx, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_n = argv[0];
  rblapack_alpha = argv[1];
  rblapack_x = argv[2];
  rblapack_incx = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  incx = NUM2INT(rblapack_incx);
  alpha.r = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
  alpha.i = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (3th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1+(n-2)*abs(incx)))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-2)*abs(incx));
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-2)*abs(incx);
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;

  zlarfg_(&n, &alpha, x, &incx, &tau);

  rblapack_tau = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(tau.r)), rb_float_new((double)(tau.i)));
  rblapack_alpha = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(alpha.r)), rb_float_new((double)(alpha.i)));
  return rb_ary_new3(3, rblapack_tau, rblapack_alpha, rblapack_x);
}

void
init_lapack_zlarfg(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlarfg", rblapack_zlarfg, -1);
}
ruby-lapack-1.7.2/ext/clahr2.c0000644000175000017500000001555412502221016015707 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clahr2_(integer* n, integer* k, integer* nb, complex* a, integer* lda, complex* tau, complex* t, integer* ldt, complex* y, integer* ldy);


static VALUE
rblapack_clahr2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_nb;
  integer nb; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_t;
  complex *t; 
  VALUE rblapack_y;
  complex *y; 
  VALUE rblapack_a_out__;
  complex *a_out__;

  integer lda;
  integer ldt;
  integer ldy;

  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, t, y, a = NumRu::Lapack.clahr2( n, k, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n*  Purpose\n*  =======\n*\n*  CLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1)\n*  matrix A so that elements below the k-th subdiagonal are zero. The\n*  reduction is performed by an unitary similarity transformation\n*  Q' * A * Q. The routine returns the matrices V and T which determine\n*  Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n*\n*  This is an auxiliary routine called by CGEHRD.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.\n*\n*  K       (input) INTEGER\n*          The offset for the reduction. Elements below the k-th\n*          subdiagonal in the first NB columns are reduced to zero.\n*          K < N.\n*\n*  NB      (input) INTEGER\n*          The number of columns to be reduced.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N-K+1)\n*          On entry, the n-by-(n-k+1) general matrix A.\n*          On exit, the elements on and above the k-th subdiagonal in\n*          the first NB columns are overwritten with the corresponding\n*          elements of the reduced matrix; the elements below the k-th\n*          subdiagonal, with the array TAU, represent the matrix Q as a\n*          product of elementary reflectors. The other columns of A are\n*          unchanged. See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  TAU     (output) COMPLEX array, dimension (NB)\n*          The scalar factors of the elementary reflectors. See Further\n*          Details.\n*\n*  T       (output) COMPLEX array, dimension (LDT,NB)\n*          The upper triangular matrix T.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T.  LDT >= NB.\n*\n*  Y       (output) COMPLEX array, dimension (LDY,NB)\n*          The n-by-nb matrix Y.\n*\n*  LDY     (input) INTEGER\n*          The leading dimension of the array Y. LDY >= N.\n*\n\n*  Further Details\n*  ===============\n*\n*  The matrix Q is represented as a product of nb elementary reflectors\n*\n*     Q = H(1) H(2) . . . H(nb).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - tau * v * v'\n*\n*  where tau is a complex scalar, and v is a complex vector with\n*  v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n*  A(i+k+1:n,i), and tau in TAU(i).\n*\n*  The elements of the vectors v together form the (n-k+1)-by-nb matrix\n*  V which is needed, with T and Y, to apply the transformation to the\n*  unreduced part of the matrix, using an update of the form:\n*  A := (I - V*T*V') * (A - Y*V').\n*\n*  The contents of A on exit are illustrated by the following example\n*  with n = 7, k = 3 and nb = 2:\n*\n*     ( a   a   a   a   a )\n*     ( a   a   a   a   a )\n*     ( a   a   a   a   a )\n*     ( h   h   a   a   a )\n*     ( v1  h   a   a   a )\n*     ( v1  v2  a   a   a )\n*     ( v1  v2  a   a   a )\n*\n*  where a denotes an element of the original matrix A, h denotes a\n*  modified element of the upper Hessenberg matrix H, and vi denotes an\n*  element of the vector defining H(i).\n*\n*  This subroutine is a slight modification of LAPACK-3.0's DLAHRD\n*  incorporating improvements proposed by Quintana-Orti and Van de\n*  Gejin. Note that the entries of A(1:K,2:NB) differ from those\n*  returned by the original LAPACK-3.0's DLAHRD routine. (This\n*  subroutine is not backward compatible with LAPACK-3.0's DLAHRD.)\n*\n*  References\n*  ==========\n*\n*  Gregorio Quintana-Orti and Robert van de Geijn, \"Improving the\n*  performance of reduction to Hessenberg form,\" ACM Transactions on\n*  Mathematical Software, 32(2):180-194, June 2006.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, t, y, a = NumRu::Lapack.clahr2( n, k, nb, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_n = argv[0];
  rblapack_k = argv[1];
  rblapack_nb = argv[2];
  rblapack_a = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  nb = NUM2INT(rblapack_nb);
  ldy = n;
  k = NUM2INT(rblapack_k);
  ldt = nb;
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != (n-k+1))
    rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", n-k+1);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,nb);
    rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = MAX(1,nb);
    rblapack_t = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  t = NA_PTR_TYPE(rblapack_t, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldy;
    shape[1] = MAX(1,nb);
    rblapack_y = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  y = NA_PTR_TYPE(rblapack_y, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n-k+1;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  clahr2_(&n, &k, &nb, a, &lda, tau, t, &ldt, y, &ldy);

  return rb_ary_new3(4, rblapack_tau, rblapack_t, rblapack_y, rblapack_a);
}

void
init_lapack_clahr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clahr2", rblapack_clahr2, -1);
}
ruby-lapack-1.7.2/ext/sorbdb.c0000644000175000017500000003426312502221021016001 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sorbdb_(char* trans, char* signs, integer* m, integer* p, integer* q, real* x11, integer* ldx11, real* x12, integer* ldx12, real* x21, integer* ldx21, real* x22, integer* ldx22, real* theta, real* phi, real* taup1, real* taup2, real* tauq1, real* tauq2, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sorbdb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_signs;
  char signs; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_x11;
  real *x11; 
  VALUE rblapack_x12;
  real *x12; 
  VALUE rblapack_x21;
  real *x21; 
  VALUE rblapack_x22;
  real *x22; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_theta;
  real *theta; 
  VALUE rblapack_phi;
  real *phi; 
  VALUE rblapack_taup1;
  real *taup1; 
  VALUE rblapack_taup2;
  real *taup2; 
  VALUE rblapack_tauq1;
  real *tauq1; 
  VALUE rblapack_tauq2;
  real *tauq2; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x11_out__;
  real *x11_out__;
  VALUE rblapack_x12_out__;
  real *x12_out__;
  VALUE rblapack_x21_out__;
  real *x21_out__;
  VALUE rblapack_x22_out__;
  real *x22_out__;
  real *work;

  integer ldx11;
  integer q;
  integer ldx12;
  integer ldx21;
  integer ldx22;
  integer p;

  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  theta, phi, taup1, taup2, tauq1, tauq2, info, x11, x12, x21, x22 = NumRu::Lapack.sorbdb( trans, signs, m, x11, x12, x21, x22, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SORBDB simultaneously bidiagonalizes the blocks of an M-by-M\n*  partitioned orthogonal matrix X:\n*\n*                                  [ B11 | B12 0  0 ]\n*      [ X11 | X12 ]   [ P1 |    ] [  0  |  0 -I  0 ] [ Q1 |    ]**T\n*  X = [-----------] = [---------] [----------------] [---------]   .\n*      [ X21 | X22 ]   [    | P2 ] [ B21 | B22 0  0 ] [    | Q2 ]\n*                                  [  0  |  0  0  I ]\n*\n*  X11 is P-by-Q. Q must be no larger than P, M-P, or M-Q. (If this is\n*  not the case, then X must be transposed and/or permuted. This can be\n*  done in constant time using the TRANS and SIGNS options. See SORCSD\n*  for details.)\n*\n*  The orthogonal matrices P1, P2, Q1, and Q2 are P-by-P, (M-P)-by-\n*  (M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. They are\n*  represented implicitly by Householder vectors.\n*\n*  B11, B12, B21, and B22 are Q-by-Q bidiagonal matrices represented\n*  implicitly by angles THETA, PHI.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER\n*          = 'T':      X, U1, U2, V1T, and V2T are stored in row-major\n*                      order;\n*          otherwise:  X, U1, U2, V1T, and V2T are stored in column-\n*                      major order.\n*\n*  SIGNS   (input) CHARACTER\n*          = 'O':      The lower-left block is made nonpositive (the\n*                      \"other\" convention);\n*          otherwise:  The upper-right block is made nonpositive (the\n*                      \"default\" convention).\n*\n*  M       (input) INTEGER\n*          The number of rows and columns in X.\n*\n*  P       (input) INTEGER\n*          The number of rows in X11 and X12. 0 <= P <= M.\n*\n*  Q       (input) INTEGER\n*          The number of columns in X11 and X21. 0 <= Q <=\n*          MIN(P,M-P,M-Q).\n*\n*  X11     (input/output) REAL array, dimension (LDX11,Q)\n*          On entry, the top-left block of the orthogonal matrix to be\n*          reduced. On exit, the form depends on TRANS:\n*          If TRANS = 'N', then\n*             the columns of tril(X11) specify reflectors for P1,\n*             the rows of triu(X11,1) specify reflectors for Q1;\n*          else TRANS = 'T', and\n*             the rows of triu(X11) specify reflectors for P1,\n*             the columns of tril(X11,-1) specify reflectors for Q1.\n*\n*  LDX11   (input) INTEGER\n*          The leading dimension of X11. If TRANS = 'N', then LDX11 >=\n*          P; else LDX11 >= Q.\n*\n*  X12     (input/output) REAL array, dimension (LDX12,M-Q)\n*          On entry, the top-right block of the orthogonal matrix to\n*          be reduced. On exit, the form depends on TRANS:\n*          If TRANS = 'N', then\n*             the rows of triu(X12) specify the first P reflectors for\n*             Q2;\n*          else TRANS = 'T', and\n*             the columns of tril(X12) specify the first P reflectors\n*             for Q2.\n*\n*  LDX12   (input) INTEGER\n*          The leading dimension of X12. If TRANS = 'N', then LDX12 >=\n*          P; else LDX11 >= M-Q.\n*\n*  X21     (input/output) REAL array, dimension (LDX21,Q)\n*          On entry, the bottom-left block of the orthogonal matrix to\n*          be reduced. On exit, the form depends on TRANS:\n*          If TRANS = 'N', then\n*             the columns of tril(X21) specify reflectors for P2;\n*          else TRANS = 'T', and\n*             the rows of triu(X21) specify reflectors for P2.\n*\n*  LDX21   (input) INTEGER\n*          The leading dimension of X21. If TRANS = 'N', then LDX21 >=\n*          M-P; else LDX21 >= Q.\n*\n*  X22     (input/output) REAL array, dimension (LDX22,M-Q)\n*          On entry, the bottom-right block of the orthogonal matrix to\n*          be reduced. On exit, the form depends on TRANS:\n*          If TRANS = 'N', then\n*             the rows of triu(X22(Q+1:M-P,P+1:M-Q)) specify the last\n*             M-P-Q reflectors for Q2,\n*          else TRANS = 'T', and\n*             the columns of tril(X22(P+1:M-Q,Q+1:M-P)) specify the last\n*             M-P-Q reflectors for P2.\n*\n*  LDX22   (input) INTEGER\n*          The leading dimension of X22. If TRANS = 'N', then LDX22 >=\n*          M-P; else LDX22 >= M-Q.\n*\n*  THETA   (output) REAL array, dimension (Q)\n*          The entries of the bidiagonal blocks B11, B12, B21, B22 can\n*          be computed from the angles THETA and PHI. See Further\n*          Details.\n*\n*  PHI     (output) REAL array, dimension (Q-1)\n*          The entries of the bidiagonal blocks B11, B12, B21, B22 can\n*          be computed from the angles THETA and PHI. See Further\n*          Details.\n*\n*  TAUP1   (output) REAL array, dimension (P)\n*          The scalar factors of the elementary reflectors that define\n*          P1.\n*\n*  TAUP2   (output) REAL array, dimension (M-P)\n*          The scalar factors of the elementary reflectors that define\n*          P2.\n*\n*  TAUQ1   (output) REAL array, dimension (Q)\n*          The scalar factors of the elementary reflectors that define\n*          Q1.\n*\n*  TAUQ2   (output) REAL array, dimension (M-Q)\n*          The scalar factors of the elementary reflectors that define\n*          Q2.\n*\n*  WORK    (workspace) REAL array, dimension (LWORK)\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK. LWORK >= M-Q.\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 bidiagonal blocks B11, B12, B21, and B22 are represented\n*  implicitly by angles THETA(1), ..., THETA(Q) and PHI(1), ...,\n*  PHI(Q-1). B11 and B21 are upper bidiagonal, while B21 and B22 are\n*  lower bidiagonal. Every entry in each bidiagonal band is a product\n*  of a sine or cosine of a THETA with a sine or cosine of a PHI. See\n*  [1] or SORCSD for details.\n*\n*  P1, P2, Q1, and Q2 are represented as products of elementary\n*  reflectors. See SORCSD for details on generating P1, P2, Q1, and Q2\n*  using SORGQR and SORGLQ.\n*\n*  Reference\n*  =========\n*\n*  [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.\n*      Algorithms, 50(1):33-65, 2009.\n*\n*  ====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  theta, phi, taup1, taup2, tauq1, tauq2, info, x11, x12, x21, x22 = NumRu::Lapack.sorbdb( trans, signs, m, x11, x12, x21, x22, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_trans = argv[0];
  rblapack_signs = argv[1];
  rblapack_m = argv[2];
  rblapack_x11 = argv[3];
  rblapack_x12 = argv[4];
  rblapack_x21 = argv[5];
  rblapack_x22 = argv[6];
  if (argc == 8) {
    rblapack_lwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  trans = StringValueCStr(rblapack_trans)[0];
  m = NUM2INT(rblapack_m);
  signs = StringValueCStr(rblapack_signs)[0];
  if (!NA_IsNArray(rblapack_x11))
    rb_raise(rb_eArgError, "x11 (4th argument) must be NArray");
  if (NA_RANK(rblapack_x11) != 2)
    rb_raise(rb_eArgError, "rank of x11 (4th argument) must be %d", 2);
  ldx11 = NA_SHAPE0(rblapack_x11);
  q = NA_SHAPE1(rblapack_x11);
  if (NA_TYPE(rblapack_x11) != NA_SFLOAT)
    rblapack_x11 = na_change_type(rblapack_x11, NA_SFLOAT);
  x11 = NA_PTR_TYPE(rblapack_x11, real*);
  p = ldx11;
  ldx21 = p;
  if (!NA_IsNArray(rblapack_x21))
    rb_raise(rb_eArgError, "x21 (6th argument) must be NArray");
  if (NA_RANK(rblapack_x21) != 2)
    rb_raise(rb_eArgError, "rank of x21 (6th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_x21) != ldx21)
    rb_raise(rb_eRuntimeError, "shape 0 of x21 must be p");
  if (NA_SHAPE1(rblapack_x21) != q)
    rb_raise(rb_eRuntimeError, "shape 1 of x21 must be the same as shape 1 of x11");
  if (NA_TYPE(rblapack_x21) != NA_SFLOAT)
    rblapack_x21 = na_change_type(rblapack_x21, NA_SFLOAT);
  x21 = NA_PTR_TYPE(rblapack_x21, real*);
  if (rblapack_lwork == Qnil)
    lwork = m-q;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldx22 = p;
  if (!NA_IsNArray(rblapack_x22))
    rb_raise(rb_eArgError, "x22 (7th argument) must be NArray");
  if (NA_RANK(rblapack_x22) != 2)
    rb_raise(rb_eArgError, "rank of x22 (7th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_x22) != ldx22)
    rb_raise(rb_eRuntimeError, "shape 0 of x22 must be p");
  if (NA_SHAPE1(rblapack_x22) != (m-q))
    rb_raise(rb_eRuntimeError, "shape 1 of x22 must be %d", m-q);
  if (NA_TYPE(rblapack_x22) != NA_SFLOAT)
    rblapack_x22 = na_change_type(rblapack_x22, NA_SFLOAT);
  x22 = NA_PTR_TYPE(rblapack_x22, real*);
  ldx12 = p;
  if (!NA_IsNArray(rblapack_x12))
    rb_raise(rb_eArgError, "x12 (5th argument) must be NArray");
  if (NA_RANK(rblapack_x12) != 2)
    rb_raise(rb_eArgError, "rank of x12 (5th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_x12) != ldx12)
    rb_raise(rb_eRuntimeError, "shape 0 of x12 must be p");
  if (NA_SHAPE1(rblapack_x12) != (m-q))
    rb_raise(rb_eRuntimeError, "shape 1 of x12 must be %d", m-q);
  if (NA_TYPE(rblapack_x12) != NA_SFLOAT)
    rblapack_x12 = na_change_type(rblapack_x12, NA_SFLOAT);
  x12 = NA_PTR_TYPE(rblapack_x12, real*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_theta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  theta = NA_PTR_TYPE(rblapack_theta, real*);
  {
    na_shape_t shape[1];
    shape[0] = q-1;
    rblapack_phi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  phi = NA_PTR_TYPE(rblapack_phi, real*);
  {
    na_shape_t shape[1];
    shape[0] = p;
    rblapack_taup1 = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  taup1 = NA_PTR_TYPE(rblapack_taup1, real*);
  {
    na_shape_t shape[1];
    shape[0] = m-p;
    rblapack_taup2 = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  taup2 = NA_PTR_TYPE(rblapack_taup2, real*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_tauq1 = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  tauq1 = NA_PTR_TYPE(rblapack_tauq1, real*);
  {
    na_shape_t shape[1];
    shape[0] = m-q;
    rblapack_tauq2 = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  tauq2 = NA_PTR_TYPE(rblapack_tauq2, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx11;
    shape[1] = q;
    rblapack_x11_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x11_out__ = NA_PTR_TYPE(rblapack_x11_out__, real*);
  MEMCPY(x11_out__, x11, real, NA_TOTAL(rblapack_x11));
  rblapack_x11 = rblapack_x11_out__;
  x11 = x11_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldx12;
    shape[1] = m-q;
    rblapack_x12_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x12_out__ = NA_PTR_TYPE(rblapack_x12_out__, real*);
  MEMCPY(x12_out__, x12, real, NA_TOTAL(rblapack_x12));
  rblapack_x12 = rblapack_x12_out__;
  x12 = x12_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldx21;
    shape[1] = q;
    rblapack_x21_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x21_out__ = NA_PTR_TYPE(rblapack_x21_out__, real*);
  MEMCPY(x21_out__, x21, real, NA_TOTAL(rblapack_x21));
  rblapack_x21 = rblapack_x21_out__;
  x21 = x21_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldx22;
    shape[1] = m-q;
    rblapack_x22_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x22_out__ = NA_PTR_TYPE(rblapack_x22_out__, real*);
  MEMCPY(x22_out__, x22, real, NA_TOTAL(rblapack_x22));
  rblapack_x22 = rblapack_x22_out__;
  x22 = x22_out__;
  work = ALLOC_N(real, (MAX(1,lwork)));

  sorbdb_(&trans, &signs, &m, &p, &q, x11, &ldx11, x12, &ldx12, x21, &ldx21, x22, &ldx22, theta, phi, taup1, taup2, tauq1, tauq2, work, &lwork, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(11, rblapack_theta, rblapack_phi, rblapack_taup1, rblapack_taup2, rblapack_tauq1, rblapack_tauq2, rblapack_info, rblapack_x11, rblapack_x12, rblapack_x21, rblapack_x22);
}

void
init_lapack_sorbdb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sorbdb", rblapack_sorbdb, -1);
}
ruby-lapack-1.7.2/ext/zlaset.c0000644000175000017500000001043112502221012016017 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlaset_(char* uplo, integer* m, integer* n, doublecomplex* alpha, doublecomplex* beta, doublecomplex* a, integer* lda);


static VALUE
rblapack_zlaset(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_alpha;
  doublecomplex alpha; 
  VALUE rblapack_beta;
  doublecomplex beta; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_a_out__;
  doublecomplex *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  a = NumRu::Lapack.zlaset( uplo, m, alpha, beta, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA )\n\n*  Purpose\n*  =======\n*\n*  ZLASET initializes a 2-D array A to BETA on the diagonal and\n*  ALPHA on the offdiagonals.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies the part of the matrix A to be set.\n*          = 'U':      Upper triangular part is set. The lower triangle\n*                      is unchanged.\n*          = 'L':      Lower triangular part is set. The upper triangle\n*                      is unchanged.\n*          Otherwise:  All of the matrix A is set.\n*\n*  M       (input) INTEGER\n*          On entry, M specifies the number of rows of A.\n*\n*  N       (input) INTEGER\n*          On entry, N specifies the number of columns of A.\n*\n*  ALPHA   (input) COMPLEX*16\n*          All the offdiagonal array elements are set to ALPHA.\n*\n*  BETA    (input) COMPLEX*16\n*          All the diagonal array elements are set to BETA.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the m by n matrix A.\n*          On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j;\n*                   A(i,i) = BETA , 1 <= i <= min(m,n)\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  a = NumRu::Lapack.zlaset( uplo, m, alpha, beta, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_m = argv[1];
  rblapack_alpha = argv[2];
  rblapack_beta = argv[3];
  rblapack_a = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  alpha.r = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
  alpha.i = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  m = NUM2INT(rblapack_m);
  beta.r = NUM2DBL(rb_funcall(rblapack_beta, rb_intern("real"), 0));
  beta.i = NUM2DBL(rb_funcall(rblapack_beta, rb_intern("imag"), 0));
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zlaset_(&uplo, &m, &n, &alpha, &beta, a, &lda);

  return rblapack_a;
}

void
init_lapack_zlaset(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlaset", rblapack_zlaset, -1);
}
ruby-lapack-1.7.2/ext/dlantr.c0000644000175000017500000001232512502221014016007 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal dlantr_(char* norm, char* uplo, char* diag, integer* m, integer* n, doublereal* a, integer* lda, doublereal* work);


static VALUE
rblapack_dlantr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack___out__;
  doublereal __out__; 
  doublereal *work;

  integer lda;
  integer n;
  integer lwork;

  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  __out__ = NumRu::Lapack.dlantr( norm, uplo, diag, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, LDA, WORK )\n\n*  Purpose\n*  =======\n*\n*  DLANTR  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  trapezoidal or triangular matrix A.\n*\n*  Description\n*  ===========\n*\n*  DLANTR returns the value\n*\n*     DLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in DLANTR as described\n*          above.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the matrix A is upper or lower trapezoidal.\n*          = 'U':  Upper trapezoidal\n*          = 'L':  Lower trapezoidal\n*          Note that A is triangular instead of trapezoidal if M = N.\n*\n*  DIAG    (input) CHARACTER*1\n*          Specifies whether or not the matrix A has unit diagonal.\n*          = 'N':  Non-unit diagonal\n*          = 'U':  Unit diagonal\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.  M >= 0, and if\n*          UPLO = 'U', M <= N.  When M = 0, DLANTR is set to zero.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.  N >= 0, and if\n*          UPLO = 'L', N <= M.  When N = 0, DLANTR is set to zero.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*          The trapezoidal matrix A (A is triangular if M = N).\n*          If UPLO = 'U', the leading m by n upper trapezoidal part of\n*          the array A contains the upper trapezoidal matrix, and the\n*          strictly lower triangular part of A is not referenced.\n*          If UPLO = 'L', the leading m by n lower trapezoidal part of\n*          the array A contains the lower trapezoidal matrix, and the\n*          strictly upper triangular part of A is not referenced.  Note\n*          that when DIAG = 'U', the diagonal elements of A are not\n*          referenced and are assumed to be one.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(M,1).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n*          where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n*          referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.dlantr( norm, uplo, diag, m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_diag = argv[2];
  rblapack_m = argv[3];
  rblapack_a = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th 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*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  m = NUM2INT(rblapack_m);
  lwork = lsame_(&norm,"I") ? m : 0;
  work = ALLOC_N(doublereal, (MAX(1,lwork)));

  __out__ = dlantr_(&norm, &uplo, &diag, &m, &n, a, &lda, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_dlantr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlantr", rblapack_dlantr, -1);
}
ruby-lapack-1.7.2/ext/clarft.c0000644000175000017500000001536512502221023016005 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clarft_(char* direct, char* storev, integer* n, integer* k, complex* v, integer* ldv, complex* tau, complex* t, integer* ldt);


static VALUE
rblapack_clarft(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_direct;
  char direct; 
  VALUE rblapack_storev;
  char storev; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_v;
  complex *v; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_t;
  complex *t; 
  VALUE rblapack_v_out__;
  complex *v_out__;

  integer ldv;
  integer k;
  integer ldt;

  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  t, v = NumRu::Lapack.clarft( direct, storev, n, v, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n*  Purpose\n*  =======\n*\n*  CLARFT forms the triangular factor T of a complex block reflector H\n*  of order n, which is defined as a product of k elementary reflectors.\n*\n*  If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n*\n*  If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n*\n*  If STOREV = 'C', the vector which defines the elementary reflector\n*  H(i) is stored in the i-th column of the array V, and\n*\n*     H  =  I - V * T * V'\n*\n*  If STOREV = 'R', the vector which defines the elementary reflector\n*  H(i) is stored in the i-th row of the array V, and\n*\n*     H  =  I - V' * T * V\n*\n\n*  Arguments\n*  =========\n*\n*  DIRECT  (input) CHARACTER*1\n*          Specifies the order in which the elementary reflectors are\n*          multiplied to form the block reflector:\n*          = 'F': H = H(1) H(2) . . . H(k) (Forward)\n*          = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n*  STOREV  (input) CHARACTER*1\n*          Specifies how the vectors which define the elementary\n*          reflectors are stored (see also Further Details):\n*          = 'C': columnwise\n*          = 'R': rowwise\n*\n*  N       (input) INTEGER\n*          The order of the block reflector H. N >= 0.\n*\n*  K       (input) INTEGER\n*          The order of the triangular factor T (= the number of\n*          elementary reflectors). K >= 1.\n*\n*  V       (input/output) COMPLEX array, dimension\n*                               (LDV,K) if STOREV = 'C'\n*                               (LDV,N) if STOREV = 'R'\n*          The matrix V. See further details.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V.\n*          If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n*\n*  TAU     (input) COMPLEX array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i).\n*\n*  T       (output) COMPLEX array, dimension (LDT,K)\n*          The k by k triangular factor T of the block reflector.\n*          If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n*          lower triangular. The rest of the array is not used.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= K.\n*\n\n*  Further Details\n*  ===============\n*\n*  The shape of the matrix V and the storage of the vectors which define\n*  the H(i) is best illustrated by the following example with n = 5 and\n*  k = 3. The elements equal to 1 are not stored; the corresponding\n*  array elements are modified but restored on exit. The rest of the\n*  array is not used.\n*\n*  DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R':\n*\n*               V = (  1       )                 V = (  1 v1 v1 v1 v1 )\n*                   ( v1  1    )                     (     1 v2 v2 v2 )\n*                   ( v1 v2  1 )                     (        1 v3 v3 )\n*                   ( v1 v2 v3 )\n*                   ( v1 v2 v3 )\n*\n*  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R':\n*\n*               V = ( v1 v2 v3 )                 V = ( v1 v1  1       )\n*                   ( v1 v2 v3 )                     ( v2 v2 v2  1    )\n*                   (  1 v2 v3 )                     ( v3 v3 v3 v3  1 )\n*                   (     1 v3 )\n*                   (        1 )\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  t, v = NumRu::Lapack.clarft( direct, storev, n, v, tau, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_direct = argv[0];
  rblapack_storev = argv[1];
  rblapack_n = argv[2];
  rblapack_v = argv[3];
  rblapack_tau = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  direct = StringValueCStr(rblapack_direct)[0];
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  storev = StringValueCStr(rblapack_storev)[0];
  ldt = k;
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (4th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  if (NA_SHAPE1(rblapack_v) != (lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0))
    rb_raise(rb_eRuntimeError, "shape 1 of v must be %d", lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0);
  if (NA_TYPE(rblapack_v) != NA_SCOMPLEX)
    rblapack_v = na_change_type(rblapack_v, NA_SCOMPLEX);
  v = NA_PTR_TYPE(rblapack_v, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = k;
    rblapack_t = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  t = NA_PTR_TYPE(rblapack_t, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0;
    rblapack_v_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  v_out__ = NA_PTR_TYPE(rblapack_v_out__, complex*);
  MEMCPY(v_out__, v, complex, NA_TOTAL(rblapack_v));
  rblapack_v = rblapack_v_out__;
  v = v_out__;

  clarft_(&direct, &storev, &n, &k, v, &ldv, tau, t, &ldt);

  return rb_ary_new3(2, rblapack_t, rblapack_v);
}

void
init_lapack_clarft(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clarft", rblapack_clarft, -1);
}
ruby-lapack-1.7.2/ext/ssytd2.c0000644000175000017500000001526112502221013015754 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssytd2_(char* uplo, integer* n, real* a, integer* lda, real* d, real* e, real* tau, integer* info);


static VALUE
rblapack_ssytd2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *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  d, e, tau, info, a = NumRu::Lapack.ssytd2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal\n*  form T by an orthogonal similarity transformation: Q' * A * Q = T.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored:\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          n-by-n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n-by-n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*          On exit, if UPLO = 'U', the diagonal and first superdiagonal\n*          of A are overwritten by the corresponding elements of the\n*          tridiagonal matrix T, and the elements above the first\n*          superdiagonal, with the array TAU, represent the orthogonal\n*          matrix Q as a product of elementary reflectors; if UPLO\n*          = 'L', the diagonal and first subdiagonal of A are over-\n*          written by the corresponding elements of the tridiagonal\n*          matrix T, and the elements below the first subdiagonal, with\n*          the array TAU, represent the orthogonal matrix Q as a product\n*          of elementary reflectors. See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  D       (output) REAL array, dimension (N)\n*          The diagonal elements of the tridiagonal matrix T:\n*          D(i) = A(i,i).\n*\n*  E       (output) REAL array, dimension (N-1)\n*          The off-diagonal elements of the tridiagonal matrix T:\n*          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n*  TAU     (output) REAL array, dimension (N-1)\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\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*  If UPLO = 'U', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(n-1) . . . H(2) H(1).\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(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n*  A(1:i-1,i+1), and tau in TAU(i).\n*\n*  If UPLO = 'L', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(1) H(2) . . . H(n-1).\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) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n*  and tau in TAU(i).\n*\n*  The contents of A on exit are illustrated by the following examples\n*  with n = 5:\n*\n*  if UPLO = 'U':                       if UPLO = 'L':\n*\n*    (  d   e   v2  v3  v4 )              (  d                  )\n*    (      d   e   v3  v4 )              (  e   d              )\n*    (          d   e   v4 )              (  v1  e   d          )\n*    (              d   e  )              (  v1  v2  e   d      )\n*    (                  d  )              (  v1  v2  v3  e   d  )\n*\n*  where d and e denote diagonal and off-diagonal elements of T, and vi\n*  denotes an element of the vector defining H(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, tau, info, a = NumRu::Lapack.ssytd2( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, real*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  ssytd2_(&uplo, &n, a, &lda, d, e, tau, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_d, rblapack_e, rblapack_tau, rblapack_info, rblapack_a);
}

void
init_lapack_ssytd2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssytd2", rblapack_ssytd2, -1);
}
ruby-lapack-1.7.2/ext/dgeqr2p.c0000644000175000017500000001041612502221013016065 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgeqr2p_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* info);


static VALUE
rblapack_dgeqr2p(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  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;

  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.dgeqr2p( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGEQR2P( M, N, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGEQR2 computes a QR factorization of a real m by n matrix A:\n*  A = Q * R.\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 above the diagonal of the array\n*          contain the min(m,n) by n upper trapezoidal matrix R (R is\n*          upper triangular if m >= n); the elements below 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 (N)\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(1) H(2) . . . H(k), 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:m) is stored on exit in A(i+1:m,i),\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.dgeqr2p( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t 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, (n));

  dgeqr2p_(&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_dgeqr2p(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgeqr2p", rblapack_dgeqr2p, -1);
}
ruby-lapack-1.7.2/ext/slantb.c0000644000175000017500000001204612502221020016003 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real slantb_(char* norm, char* uplo, char* diag, integer* n, integer* k, real* ab, integer* ldab, real* work);


static VALUE
rblapack_slantb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack___out__;
  real __out__; 
  real *work;

  integer ldab;
  integer n;
  integer lwork;

  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  __out__ = NumRu::Lapack.slantb( norm, uplo, diag, k, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL             FUNCTION SLANTB( NORM, UPLO, DIAG, N, K, AB, LDAB, WORK )\n\n*  Purpose\n*  =======\n*\n*  SLANTB  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the element of  largest absolute value  of an\n*  n by n triangular band matrix A,  with ( k + 1 ) diagonals.\n*\n*  Description\n*  ===========\n*\n*  SLANTB returns the value\n*\n*     SLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in SLANTB as described\n*          above.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the matrix A is upper or lower triangular.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  DIAG    (input) CHARACTER*1\n*          Specifies whether or not the matrix A is unit triangular.\n*          = 'N':  Non-unit triangular\n*          = 'U':  Unit triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, SLANTB is\n*          set to zero.\n*\n*  K       (input) INTEGER\n*          The number of super-diagonals of the matrix A if UPLO = 'U',\n*          or the number of sub-diagonals of the matrix A if UPLO = 'L'.\n*          K >= 0.\n*\n*  AB      (input) REAL array, dimension (LDAB,N)\n*          The upper or lower triangular band matrix A, stored in the\n*          first k+1 rows of AB.  The j-th column of A is stored\n*          in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)   = A(i,j) for j<=i<=min(n,j+k).\n*          Note that when DIAG = 'U', the elements of the array AB\n*          corresponding to the diagonal elements of the matrix A are\n*          not referenced, but are assumed to be one.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= K+1.\n*\n*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n*          referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.slantb( norm, uplo, diag, k, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_diag = argv[2];
  rblapack_k = argv[3];
  rblapack_ab = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  lwork = lsame_(&norm,"I") ? n : 0;
  k = NUM2INT(rblapack_k);
  work = ALLOC_N(real, (MAX(1,lwork)));

  __out__ = slantb_(&norm, &uplo, &diag, &n, &k, ab, &ldab, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_slantb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slantb", rblapack_slantb, -1);
}
ruby-lapack-1.7.2/ext/sggqrf.c0000644000175000017500000002276512502221026016030 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sggqrf_(integer* n, integer* m, integer* p, real* a, integer* lda, real* taua, real* b, integer* ldb, real* taub, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sggqrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_taua;
  real *taua; 
  VALUE rblapack_taub;
  real *taub; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_b_out__;
  real *b_out__;

  integer lda;
  integer m;
  integer ldb;
  integer p;

  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  taua, taub, work, info, a, b = NumRu::Lapack.sggqrf( n, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGGQRF computes a generalized QR factorization of an N-by-M matrix A\n*  and an N-by-P matrix B:\n*\n*              A = Q*R,        B = Q*T*Z,\n*\n*  where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal\n*  matrix, and R and T assume one of the forms:\n*\n*  if N >= M,  R = ( R11 ) M  ,   or if N < M,  R = ( R11  R12 ) N,\n*                  (  0  ) N-M                         N   M-N\n*                     M\n*\n*  where R11 is upper triangular, and\n*\n*  if N <= P,  T = ( 0  T12 ) N,   or if N > P,  T = ( T11 ) N-P,\n*                   P-N  N                           ( T21 ) P\n*                                                       P\n*\n*  where T12 or T21 is upper triangular.\n*\n*  In particular, if B is square and nonsingular, the GQR factorization\n*  of A and B implicitly gives the QR factorization of inv(B)*A:\n*\n*               inv(B)*A = Z'*(inv(T)*R)\n*\n*  where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n*  transpose of the matrix Z.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of rows of the matrices A and B. N >= 0.\n*\n*  M       (input) INTEGER\n*          The number of columns of the matrix A.  M >= 0.\n*\n*  P       (input) INTEGER\n*          The number of columns of the matrix B.  P >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,M)\n*          On entry, the N-by-M matrix A.\n*          On exit, the elements on and above the diagonal of the array\n*          contain the min(N,M)-by-M upper trapezoidal matrix R (R is\n*          upper triangular if N >= M); the elements below the diagonal,\n*          with the array TAUA, represent the orthogonal matrix Q as a\n*          product of min(N,M) elementary reflectors (see Further\n*          Details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  TAUA    (output) REAL array, dimension (min(N,M))\n*          The scalar factors of the elementary reflectors which\n*          represent the orthogonal matrix Q (see Further Details).\n*\n*  B       (input/output) REAL array, dimension (LDB,P)\n*          On entry, the N-by-P matrix B.\n*          On exit, if N <= P, the upper triangle of the subarray\n*          B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n*          if N > P, the elements on and above the (N-P)-th subdiagonal\n*          contain the N-by-P upper trapezoidal matrix T; the remaining\n*          elements, with the array TAUB, represent the orthogonal\n*          matrix Z as a product of elementary reflectors (see Further\n*          Details).\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  TAUB    (output) REAL array, dimension (min(N,P))\n*          The scalar factors of the elementary reflectors which\n*          represent the orthogonal matrix Z (see Further Details).\n*\n*  WORK    (workspace/output) REAL 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,N,M,P).\n*          For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n*          where NB1 is the optimal blocksize for the QR factorization\n*          of an N-by-M matrix, NB2 is the optimal blocksize for the\n*          RQ factorization of an N-by-P matrix, and NB3 is the optimal\n*          blocksize for a call of SORMQR.\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(1) H(2) . . . H(k), where k = min(n,m).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - taua * v * v'\n*\n*  where taua 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+1:n,i),\n*  and taua in TAUA(i).\n*  To form Q explicitly, use LAPACK subroutine SORGQR.\n*  To use Q to update another matrix, use LAPACK subroutine SORMQR.\n*\n*  The matrix Z is represented as a product of elementary reflectors\n*\n*     Z = H(1) H(2) . . . H(k), where k = min(n,p).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - taub * v * v'\n*\n*  where taub is a real scalar, and v is a real vector with\n*  v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in\n*  B(n-k+i,1:p-k+i-1), and taub in TAUB(i).\n*  To form Z explicitly, use LAPACK subroutine SORGRQ.\n*  To use Z to update another matrix, use LAPACK subroutine SORMRQ.\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY\n      INTEGER            LOPT, LWKOPT, NB, NB1, NB2, NB3\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SGEQRF, SGERQF, SORMQR, XERBLA\n*     ..\n*     .. External Functions ..\n      INTEGER            ILAENV\n      EXTERNAL           ILAENV \n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          INT, MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  taua, taub, work, info, a, b = NumRu::Lapack.sggqrf( n, 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_n = 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;
  }

  n = NUM2INT(rblapack_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);
  ldb = NA_SHAPE0(rblapack_b);
  p = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  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);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (rblapack_lwork == Qnil)
    lwork = MAX(MAX(n,m),p);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(n,m);
    rblapack_taua = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  taua = NA_PTR_TYPE(rblapack_taua, real*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(n,p);
    rblapack_taub = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  taub = NA_PTR_TYPE(rblapack_taub, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = m;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = p;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  sggqrf_(&n, &m, &p, a, &lda, taua, b, &ldb, taub, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_taua, rblapack_taub, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_sggqrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sggqrf", rblapack_sggqrf, -1);
}
ruby-lapack-1.7.2/ext/zherfs.c0000644000175000017500000002173012502221013016023 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zherfs_(char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zherfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.zherfs( uplo, a, af, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHERFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHERFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is Hermitian indefinite, and\n*  provides error bounds and backward error estimates for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          The Hermitian matrix A.  If UPLO = 'U', the leading N-by-N\n*          upper triangular part of A contains the upper triangular part\n*          of the matrix A, and the strictly lower triangular part of A\n*          is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*          triangular part of A contains the lower triangular part of\n*          the matrix A, and the strictly upper triangular part of A is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AF      (input) COMPLEX*16 array, dimension (LDAF,N)\n*          The factored form of the matrix A.  AF contains the block\n*          diagonal matrix D and the multipliers used to obtain the\n*          factor U or L from the factorization A = U*D*U**H or\n*          A = L*D*L**H as computed by ZHETRF.\n*\n*  LDAF    (input) INTEGER\n*          The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by ZHETRF.\n*\n*  B       (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) COMPLEX*16 array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by ZHETRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.zherfs( uplo, a, af, ipiv, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_b = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (n));

  zherfs_(&uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_zherfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zherfs", rblapack_zherfs, -1);
}
ruby-lapack-1.7.2/ext/dormr3.c0000644000175000017500000001574612502221014015743 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dormr3_(char* side, char* trans, integer* m, integer* n, integer* k, integer* l, doublereal* a, integer* lda, doublereal* tau, doublereal* c, integer* ldc, doublereal* work, integer* info);


static VALUE
rblapack_dormr3(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublereal *c_out__;
  doublereal *work;

  integer lda;
  integer m;
  integer k;
  integer ldc;
  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  info, c = NumRu::Lapack.dormr3( side, trans, l, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DORMR3 overwrites the general real m by n matrix C with\n*\n*        Q * C  if SIDE = 'L' and TRANS = 'N', or\n*\n*        Q'* C  if SIDE = 'L' and TRANS = 'T', or\n*\n*        C * Q  if SIDE = 'R' and TRANS = 'N', or\n*\n*        C * Q' if SIDE = 'R' and TRANS = 'T',\n*\n*  where Q is a real orthogonal matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(1) H(2) . . . H(k)\n*\n*  as returned by DTZRZF. Q is of order m if SIDE = 'L' and of order n\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q' from the Left\n*          = 'R': apply Q or Q' from the Right\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': apply Q  (No transpose)\n*          = 'T': apply Q' (Transpose)\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  L       (input) INTEGER\n*          The number of columns of the matrix A containing\n*          the meaningful part of the Householder reflectors.\n*          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension\n*                               (LDA,M) if SIDE = 'L',\n*                               (LDA,N) if SIDE = 'R'\n*          The i-th row must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          DTZRZF in the last k rows of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,K).\n*\n*  TAU     (input) DOUBLE PRECISION array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by DTZRZF.\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n*          On entry, the m-by-n matrix C.\n*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension\n*                                   (N) if SIDE = 'L',\n*                                   (M) if SIDE = 'R'\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*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LEFT, NOTRAN\n      INTEGER            I, I1, I2, I3, IC, JA, JC, MI, NI, NQ\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DLARZ, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, c = NumRu::Lapack.dormr3( side, trans, l, a, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_l = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  l = NUM2INT(rblapack_l);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = 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*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  dormr3_(&side, &trans, &m, &n, &k, &l, a, &lda, tau, c, &ldc, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_c);
}

void
init_lapack_dormr3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dormr3", rblapack_dormr3, -1);
}
ruby-lapack-1.7.2/ext/cgesvd.c0000644000175000017500000002343212502221024016000 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgesvd_(char* jobu, char* jobvt, integer* m, integer* n, complex* a, integer* lda, real* s, complex* u, integer* ldu, complex* vt, integer* ldvt, complex* work, integer* lwork, real* rwork, integer* info);


static VALUE
rblapack_cgesvd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobu;
  char jobu; 
  VALUE rblapack_jobvt;
  char jobvt; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_u;
  complex *u; 
  VALUE rblapack_vt;
  complex *vt; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  real *rwork;

  integer lda;
  integer n;
  integer ldu;
  integer ldvt;
  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  s, u, vt, work, info, a = NumRu::Lapack.cgesvd( jobu, jobvt, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGESVD computes the singular value decomposition (SVD) of a complex\n*  M-by-N matrix A, optionally computing the left and/or right singular\n*  vectors. The SVD is written\n*\n*       A = U * SIGMA * conjugate-transpose(V)\n*\n*  where SIGMA is an M-by-N matrix which is zero except for its\n*  min(m,n) diagonal elements, U is an M-by-M unitary matrix, and\n*  V is an N-by-N unitary matrix.  The diagonal elements of SIGMA\n*  are the singular values of A; they are real and non-negative, and\n*  are returned in descending order.  The first min(m,n) columns of\n*  U and V are the left and right singular vectors of A.\n*\n*  Note that the routine returns V**H, not V.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBU    (input) CHARACTER*1\n*          Specifies options for computing all or part of the matrix U:\n*          = 'A':  all M columns of U are returned in array U:\n*          = 'S':  the first min(m,n) columns of U (the left singular\n*                  vectors) are returned in the array U;\n*          = 'O':  the first min(m,n) columns of U (the left singular\n*                  vectors) are overwritten on the array A;\n*          = 'N':  no columns of U (no left singular vectors) are\n*                  computed.\n*\n*  JOBVT   (input) CHARACTER*1\n*          Specifies options for computing all or part of the matrix\n*          V**H:\n*          = 'A':  all N rows of V**H are returned in the array VT;\n*          = 'S':  the first min(m,n) rows of V**H (the right singular\n*                  vectors) are returned in the array VT;\n*          = 'O':  the first min(m,n) rows of V**H (the right singular\n*                  vectors) are overwritten on the array A;\n*          = 'N':  no rows of V**H (no right singular vectors) are\n*                  computed.\n*\n*          JOBVT and JOBU cannot both be 'O'.\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.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit,\n*          if JOBU = 'O',  A is overwritten with the first min(m,n)\n*                          columns of U (the left singular vectors,\n*                          stored columnwise);\n*          if JOBVT = 'O', A is overwritten with the first min(m,n)\n*                          rows of V**H (the right singular vectors,\n*                          stored rowwise);\n*          if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A\n*                          are destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  S       (output) REAL array, dimension (min(M,N))\n*          The singular values of A, sorted so that S(i) >= S(i+1).\n*\n*  U       (output) COMPLEX array, dimension (LDU,UCOL)\n*          (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.\n*          If JOBU = 'A', U contains the M-by-M unitary matrix U;\n*          if JOBU = 'S', U contains the first min(m,n) columns of U\n*          (the left singular vectors, stored columnwise);\n*          if JOBU = 'N' or 'O', U is not referenced.\n*\n*  LDU     (input) INTEGER\n*          The leading dimension of the array U.  LDU >= 1; if\n*          JOBU = 'S' or 'A', LDU >= M.\n*\n*  VT      (output) COMPLEX array, dimension (LDVT,N)\n*          If JOBVT = 'A', VT contains the N-by-N unitary matrix\n*          V**H;\n*          if JOBVT = 'S', VT contains the first min(m,n) rows of\n*          V**H (the right singular vectors, stored rowwise);\n*          if JOBVT = 'N' or 'O', VT is not referenced.\n*\n*  LDVT    (input) INTEGER\n*          The leading dimension of the array VT.  LDVT >= 1; if\n*          JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).\n*\n*  WORK    (workspace/output) COMPLEX 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,2*MIN(M,N)+MAX(M,N)).\n*          For good performance, LWORK should generally be larger.\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*  RWORK   (workspace) REAL array, dimension (5*min(M,N))\n*          On exit, if INFO > 0, RWORK(1:MIN(M,N)-1) contains the\n*          unconverged superdiagonal elements of an upper bidiagonal\n*          matrix B whose diagonal is in S (not necessarily sorted).\n*          B satisfies A = U * B * VT, so it has the same singular\n*          values as A, and singular vectors related by U and VT.\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 CBDSQR did not converge, INFO specifies how many\n*                superdiagonals of an intermediate bidiagonal form B\n*                did not converge to zero. See the description of RWORK\n*                above for details.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, u, vt, work, info, a = NumRu::Lapack.cgesvd( jobu, jobvt, a, [: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_jobu = argv[0];
  rblapack_jobvt = argv[1];
  rblapack_a = 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;
  }

  jobu = StringValueCStr(rblapack_jobu)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  m = lda;
  ldu = ((lsame_(&jobu,"S")) || (lsame_(&jobu,"A"))) ? m : 1;
  jobvt = StringValueCStr(rblapack_jobvt)[0];
  ldvt = lsame_(&jobvt,"A") ? n : lsame_(&jobvt,"S") ? MIN(m,n) : 1;
  if (rblapack_lwork == Qnil)
    lwork = MAX(1, 2*MIN(m,n)+MAX(m,n));
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = lsame_(&jobu,"A") ? m : lsame_(&jobu,"S") ? MIN(m,n) : 0;
    rblapack_u = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  u = NA_PTR_TYPE(rblapack_u, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvt;
    shape[1] = n;
    rblapack_vt = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  vt = NA_PTR_TYPE(rblapack_vt, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = MAX(n, MIN(m,n));
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  {
    VALUE __shape__[3];
    __shape__[0] = Qtrue;
    __shape__[1] = n < MIN(m,n) ? rb_range_new(rblapack_ZERO, INT2NUM(n), Qtrue) : Qtrue;
    __shape__[2] = rblapack_a;
    na_aset(3, __shape__, rblapack_a_out__);
  }
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  rwork = ALLOC_N(real, (5*MIN(m,n)));

  cgesvd_(&jobu, &jobvt, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, rwork, &info);

  free(rwork);
  rblapack_info = INT2NUM(info);
  {
    VALUE __shape__[2];
    __shape__[0] = Qtrue;
    __shape__[1] = n < MIN(m,n) ? Qtrue : rb_range_new(rblapack_ZERO, INT2NUM(MIN(m,n)), Qtrue);
    rblapack_a = na_aref(2, __shape__, rblapack_a);
  }
  return rb_ary_new3(6, rblapack_s, rblapack_u, rblapack_vt, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_cgesvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgesvd", rblapack_cgesvd, -1);
}
ruby-lapack-1.7.2/ext/dstev.c0000644000175000017500000001234712502221013015653 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dstev_(char* jobz, integer* n, doublereal* d, doublereal* e, doublereal* z, integer* ldz, doublereal* work, integer* info);


static VALUE
rblapack_dstev(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_e_out__;
  doublereal *e_out__;
  doublereal *work;

  integer n;
  integer ldz;

  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  z, info, d, e = NumRu::Lapack.dstev( jobz, d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSTEV computes all eigenvalues and, optionally, eigenvectors of a\n*  real symmetric tridiagonal matrix A.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the n diagonal elements of the tridiagonal matrix\n*          A.\n*          On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n*  E       (input/output) DOUBLE PRECISION array, dimension (N-1)\n*          On entry, the (n-1) subdiagonal elements of the tridiagonal\n*          matrix A, stored in elements 1 to N-1 of E.\n*          On exit, the contents of E are destroyed.\n*\n*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n*          eigenvectors of the matrix A, with the i-th column of Z\n*          holding the eigenvector associated with D(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))\n*          If JOBZ = 'N', WORK is not referenced.\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 algorithm failed to converge; i\n*                off-diagonal elements of E did not converge to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  z, info, d, e = NumRu::Lapack.dstev( jobz, d, e, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_jobz = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
  MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  work = ALLOC_N(doublereal, (lsame_(&jobz,"N") ? 0 : MAX(1,2*n-2)));

  dstev_(&jobz, &n, d, e, z, &ldz, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_z, rblapack_info, rblapack_d, rblapack_e);
}

void
init_lapack_dstev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dstev", rblapack_dstev, -1);
}
ruby-lapack-1.7.2/ext/zlaqr2.c0000644000175000017500000002645312502221024015746 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlaqr2_(logical* wantt, logical* wantz, integer* n, integer* ktop, integer* kbot, integer* nw, doublecomplex* h, integer* ldh, integer* iloz, integer* ihiz, doublecomplex* z, integer* ldz, integer* ns, integer* nd, doublecomplex* sh, doublecomplex* v, integer* ldv, integer* nh, doublecomplex* t, integer* ldt, integer* nv, doublecomplex* wv, integer* ldwv, doublecomplex* work, integer* lwork);


static VALUE
rblapack_zlaqr2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantt;
  logical wantt; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_ktop;
  integer ktop; 
  VALUE rblapack_kbot;
  integer kbot; 
  VALUE rblapack_nw;
  integer nw; 
  VALUE rblapack_h;
  doublecomplex *h; 
  VALUE rblapack_iloz;
  integer iloz; 
  VALUE rblapack_ihiz;
  integer ihiz; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_nh;
  integer nh; 
  VALUE rblapack_nv;
  integer nv; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_ns;
  integer ns; 
  VALUE rblapack_nd;
  integer nd; 
  VALUE rblapack_sh;
  doublecomplex *sh; 
  VALUE rblapack_h_out__;
  doublecomplex *h_out__;
  VALUE rblapack_z_out__;
  doublecomplex *z_out__;
  doublecomplex *v;
  doublecomplex *t;
  doublecomplex *wv;
  doublecomplex *work;

  integer ldh;
  integer n;
  integer ldz;
  integer ldv;
  integer ldwv;
  integer ldt;

  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  ns, nd, sh, h, z = NumRu::Lapack.zlaqr2( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n*     This subroutine is identical to ZLAQR3 except that it avoids\n*     recursion by calling ZLAHQR instead of ZLAQR4.\n*\n*\n*     ******************************************************************\n*     Aggressive early deflation:\n*\n*     This subroutine accepts as input an upper Hessenberg matrix\n*     H and performs an unitary similarity transformation\n*     designed to detect and deflate fully converged eigenvalues from\n*     a trailing principal submatrix.  On output H has been over-\n*     written by a new Hessenberg matrix that is a perturbation of\n*     an unitary similarity transformation of H.  It is to be\n*     hoped that the final version of H has many zero subdiagonal\n*     entries.\n*\n*     ******************************************************************\n\n*     WANTT   (input) LOGICAL\n*          If .TRUE., then the Hessenberg matrix H is fully updated\n*          so that the triangular Schur factor may be\n*          computed (in cooperation with the calling subroutine).\n*          If .FALSE., then only enough of H is updated to preserve\n*          the eigenvalues.\n*\n*     WANTZ   (input) LOGICAL\n*          If .TRUE., then the unitary matrix Z is updated so\n*          so that the unitary Schur factor may be computed\n*          (in cooperation with the calling subroutine).\n*          If .FALSE., then Z is not referenced.\n*\n*     N       (input) INTEGER\n*          The order of the matrix H and (if WANTZ is .TRUE.) the\n*          order of the unitary matrix Z.\n*\n*     KTOP    (input) INTEGER\n*          It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n*          KBOT and KTOP together determine an isolated block\n*          along the diagonal of the Hessenberg matrix.\n*\n*     KBOT    (input) INTEGER\n*          It is assumed without a check that either\n*          KBOT = N or H(KBOT+1,KBOT)=0.  KBOT and KTOP together\n*          determine an isolated block along the diagonal of the\n*          Hessenberg matrix.\n*\n*     NW      (input) INTEGER\n*          Deflation window size.  1 .LE. NW .LE. (KBOT-KTOP+1).\n*\n*     H       (input/output) COMPLEX*16 array, dimension (LDH,N)\n*          On input the initial N-by-N section of H stores the\n*          Hessenberg matrix undergoing aggressive early deflation.\n*          On output H has been transformed by a unitary\n*          similarity transformation, perturbed, and the returned\n*          to Hessenberg form that (it is to be hoped) has some\n*          zero subdiagonal entries.\n*\n*     LDH     (input) integer\n*          Leading dimension of H just as declared in the calling\n*          subroutine.  N .LE. LDH\n*\n*     ILOZ    (input) INTEGER\n*     IHIZ    (input) INTEGER\n*          Specify the rows of Z to which transformations must be\n*          applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n*\n*     Z       (input/output) COMPLEX*16 array, dimension (LDZ,N)\n*          IF WANTZ is .TRUE., then on output, the unitary\n*          similarity transformation mentioned above has been\n*          accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n*          If WANTZ is .FALSE., then Z is unreferenced.\n*\n*     LDZ     (input) integer\n*          The leading dimension of Z just as declared in the\n*          calling subroutine.  1 .LE. LDZ.\n*\n*     NS      (output) integer\n*          The number of unconverged (ie approximate) eigenvalues\n*          returned in SR and SI that may be used as shifts by the\n*          calling subroutine.\n*\n*     ND      (output) integer\n*          The number of converged eigenvalues uncovered by this\n*          subroutine.\n*\n*     SH      (output) COMPLEX*16 array, dimension KBOT\n*          On output, approximate eigenvalues that may\n*          be used for shifts are stored in SH(KBOT-ND-NS+1)\n*          through SR(KBOT-ND).  Converged eigenvalues are\n*          stored in SH(KBOT-ND+1) through SH(KBOT).\n*\n*     V       (workspace) COMPLEX*16 array, dimension (LDV,NW)\n*          An NW-by-NW work array.\n*\n*     LDV     (input) integer scalar\n*          The leading dimension of V just as declared in the\n*          calling subroutine.  NW .LE. LDV\n*\n*     NH      (input) integer scalar\n*          The number of columns of T.  NH.GE.NW.\n*\n*     T       (workspace) COMPLEX*16 array, dimension (LDT,NW)\n*\n*     LDT     (input) integer\n*          The leading dimension of T just as declared in the\n*          calling subroutine.  NW .LE. LDT\n*\n*     NV      (input) integer\n*          The number of rows of work array WV available for\n*          workspace.  NV.GE.NW.\n*\n*     WV      (workspace) COMPLEX*16 array, dimension (LDWV,NW)\n*\n*     LDWV    (input) integer\n*          The leading dimension of W just as declared in the\n*          calling subroutine.  NW .LE. LDV\n*\n*     WORK    (workspace) COMPLEX*16 array, dimension LWORK.\n*          On exit, WORK(1) is set to an estimate of the optimal value\n*          of LWORK for the given values of N, NW, KTOP and KBOT.\n*\n*     LWORK   (input) integer\n*          The dimension of the work array WORK.  LWORK = 2*NW\n*          suffices, but greater efficiency may result from larger\n*          values of LWORK.\n*\n*          If LWORK = -1, then a workspace query is assumed; ZLAQR2\n*          only estimates the optimal workspace size for the given\n*          values of N, NW, KTOP and KBOT.  The estimate is returned\n*          in WORK(1).  No error message related to LWORK is issued\n*          by XERBLA.  Neither H nor Z are accessed.\n*\n\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ns, nd, sh, h, z = NumRu::Lapack.zlaqr2( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 11 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
  rblapack_wantt = argv[0];
  rblapack_wantz = argv[1];
  rblapack_ktop = argv[2];
  rblapack_kbot = argv[3];
  rblapack_nw = argv[4];
  rblapack_h = argv[5];
  rblapack_iloz = argv[6];
  rblapack_ihiz = argv[7];
  rblapack_z = argv[8];
  rblapack_nh = argv[9];
  rblapack_nv = argv[10];
  if (argc == 12) {
    rblapack_lwork = argv[11];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  wantt = (rblapack_wantt == Qtrue);
  ktop = NUM2INT(rblapack_ktop);
  nw = NUM2INT(rblapack_nw);
  iloz = NUM2INT(rblapack_iloz);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (9th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  n = NA_SHAPE1(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_DCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  nv = NUM2INT(rblapack_nv);
  ldwv = nw;
  ldv = nw;
  wantz = (rblapack_wantz == Qtrue);
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (6th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  if (NA_SHAPE1(rblapack_h) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of z");
  if (NA_TYPE(rblapack_h) != NA_DCOMPLEX)
    rblapack_h = na_change_type(rblapack_h, NA_DCOMPLEX);
  h = NA_PTR_TYPE(rblapack_h, doublecomplex*);
  nh = NUM2INT(rblapack_nh);
  ldt = nw;
  kbot = NUM2INT(rblapack_kbot);
  if (rblapack_lwork == Qnil)
    lwork = 2*nw;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ihiz = NUM2INT(rblapack_ihiz);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,kbot);
    rblapack_sh = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  sh = NA_PTR_TYPE(rblapack_sh, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublecomplex*);
  MEMCPY(h_out__, h, doublecomplex, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublecomplex*);
  MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  v = ALLOC_N(doublecomplex, (ldv)*(MAX(1,nw)));
  t = ALLOC_N(doublecomplex, (ldv)*(MAX(1,nw)));
  wv = ALLOC_N(doublecomplex, (ldv)*(MAX(1,nw)));
  work = ALLOC_N(doublecomplex, (MAX(1,lwork)));

  zlaqr2_(&wantt, &wantz, &n, &ktop, &kbot, &nw, h, &ldh, &iloz, &ihiz, z, &ldz, &ns, &nd, sh, v, &ldv, &nh, t, &ldt, &nv, wv, &ldwv, work, &lwork);

  free(v);
  free(t);
  free(wv);
  free(work);
  rblapack_ns = INT2NUM(ns);
  rblapack_nd = INT2NUM(nd);
  return rb_ary_new3(5, rblapack_ns, rblapack_nd, rblapack_sh, rblapack_h, rblapack_z);
}

void
init_lapack_zlaqr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlaqr2", rblapack_zlaqr2, -1);
}
ruby-lapack-1.7.2/ext/zlascl.c0000644000175000017500000001233112502221024016011 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlascl_(char* type, integer* kl, integer* ku, doublereal* cfrom, doublereal* cto, integer* m, integer* n, doublecomplex* a, integer* lda, integer* info);


static VALUE
rblapack_zlascl(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_type;
  char type; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_cfrom;
  doublereal cfrom; 
  VALUE rblapack_cto;
  doublereal cto; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *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  info, a = NumRu::Lapack.zlascl( type, kl, ku, cfrom, cto, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZLASCL multiplies the M by N complex matrix A by the real scalar\n*  CTO/CFROM.  This is done without over/underflow as long as the final\n*  result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that\n*  A may be full, upper triangular, lower triangular, upper Hessenberg,\n*  or banded.\n*\n\n*  Arguments\n*  =========\n*\n*  TYPE    (input) CHARACTER*1\n*          TYPE indices the storage type of the input matrix.\n*          = 'G':  A is a full matrix.\n*          = 'L':  A is a lower triangular matrix.\n*          = 'U':  A is an upper triangular matrix.\n*          = 'H':  A is an upper Hessenberg matrix.\n*          = 'B':  A is a symmetric band matrix with lower bandwidth KL\n*                  and upper bandwidth KU and with the only the lower\n*                  half stored.\n*          = 'Q':  A is a symmetric band matrix with lower bandwidth KL\n*                  and upper bandwidth KU and with the only the upper\n*                  half stored.\n*          = 'Z':  A is a band matrix with lower bandwidth KL and upper\n*                  bandwidth KU. See ZGBTRF for storage details.\n*\n*  KL      (input) INTEGER\n*          The lower bandwidth of A.  Referenced only if TYPE = 'B',\n*          'Q' or 'Z'.\n*\n*  KU      (input) INTEGER\n*          The upper bandwidth of A.  Referenced only if TYPE = 'B',\n*          'Q' or 'Z'.\n*\n*  CFROM   (input) DOUBLE PRECISION\n*  CTO     (input) DOUBLE PRECISION\n*          The matrix A is multiplied by CTO/CFROM. A(I,J) is computed\n*          without over/underflow if the final result CTO*A(I,J)/CFROM\n*          can be represented without over/underflow.  CFROM must be\n*          nonzero.\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) COMPLEX*16 array, dimension (LDA,N)\n*          The matrix to be multiplied by CTO/CFROM.  See TYPE for the\n*          storage type.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.zlascl( type, kl, ku, cfrom, cto, m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_type = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_cfrom = argv[3];
  rblapack_cto = argv[4];
  rblapack_m = argv[5];
  rblapack_a = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  type = StringValueCStr(rblapack_type)[0];
  ku = NUM2INT(rblapack_ku);
  cto = NUM2DBL(rblapack_cto);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (7th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (7th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  kl = NUM2INT(rblapack_kl);
  m = NUM2INT(rblapack_m);
  cfrom = NUM2DBL(rblapack_cfrom);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zlascl_(&type, &kl, &ku, &cfrom, &cto, &m, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_zlascl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlascl", rblapack_zlascl, -1);
}
ruby-lapack-1.7.2/ext/chbevd.c0000644000175000017500000002456412502221017015771 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chbevd_(char* jobz, char* uplo, integer* n, integer* kd, complex* ab, integer* ldab, real* w, complex* z, integer* ldz, complex* work, integer* lwork, real* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_chbevd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_lrwork;
  integer lrwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_rwork;
  real *rwork; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  complex *ab_out__;

  integer ldab;
  integer n;
  integer ldz;

  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  w, z, work, rwork, iwork, info, ab = NumRu::Lapack.chbevd( jobz, uplo, kd, ab, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHBEVD computes all the eigenvalues and, optionally, eigenvectors of\n*  a complex Hermitian band matrix A.  If eigenvectors are desired, it\n*  uses a divide and conquer algorithm.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) COMPLEX array, dimension (LDAB, N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*          On exit, AB is overwritten by values generated during the\n*          reduction to tridiagonal form.  If UPLO = 'U', the first\n*          superdiagonal and the diagonal of the tridiagonal matrix T\n*          are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n*          the diagonal and first subdiagonal of T are returned in the\n*          first two rows of AB.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD + 1.\n*\n*  W       (output) REAL array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) COMPLEX array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n*          eigenvectors of the matrix A, with the i-th column of Z\n*          holding the eigenvector associated with W(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace/output) COMPLEX 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*          If N <= 1,               LWORK must be at least 1.\n*          If JOBZ = 'N' and N > 1, LWORK must be at least N.\n*          If JOBZ = 'V' and N > 1, LWORK must be at least 2*N**2.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal sizes of the WORK, RWORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  RWORK   (workspace/output) REAL array,\n*                                         dimension (LRWORK)\n*          On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n*\n*  LRWORK  (input) INTEGER\n*          The dimension of array RWORK.\n*          If N <= 1,               LRWORK must be at least 1.\n*          If JOBZ = 'N' and N > 1, LRWORK must be at least N.\n*          If JOBZ = 'V' and N > 1, LRWORK must be at least\n*                        1 + 5*N + 2*N**2.\n*\n*          If LRWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of array IWORK.\n*          If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.\n*          If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N .\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK 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 algorithm failed to converge; i\n*                off-diagonal elements of an intermediate tridiagonal\n*                form did not converge to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, work, rwork, iwork, info, ab = NumRu::Lapack.chbevd( jobz, uplo, kd, ab, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_kd = argv[2];
  rblapack_ab = argv[3];
  if (argc == 7) {
    rblapack_lwork = argv[4];
    rblapack_lrwork = argv[5];
    rblapack_liwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_lrwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  kd = NUM2INT(rblapack_kd);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  if (rblapack_lrwork == Qnil)
    lrwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
  else {
    lrwork = NUM2INT(rblapack_lrwork);
  }
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  if (rblapack_lwork == Qnil)
    lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 2*n*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (rblapack_liwork == Qnil)
    liwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lrwork);
    rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  rwork = NA_PTR_TYPE(rblapack_rwork, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
  MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  chbevd_(&jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_w, rblapack_z, rblapack_work, rblapack_rwork, rblapack_iwork, rblapack_info, rblapack_ab);
}

void
init_lapack_chbevd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chbevd", rblapack_chbevd, -1);
}
ruby-lapack-1.7.2/ext/ssyev.c0000644000175000017500000001305212502221014015672 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssyev_(char* jobz, char* uplo, integer* n, real* a, integer* lda, real* w, real* work, integer* lwork, integer* info);


static VALUE
rblapack_ssyev(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *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  w, work, info, a = NumRu::Lapack.ssyev( jobz, uplo, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSYEV computes all eigenvalues and, optionally, eigenvectors of a\n*  real symmetric matrix A.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA, N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of A contains the\n*          upper triangular part of the matrix A.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of A contains\n*          the lower triangular part of the matrix A.\n*          On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n*          orthonormal eigenvectors of the matrix A.\n*          If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n*          or the upper triangle (if UPLO='U') of A, including the\n*          diagonal, is destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  W       (output) REAL array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  WORK    (workspace/output) REAL array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of the array WORK.  LWORK >= max(1,3*N-1).\n*          For optimal efficiency, LWORK >= (NB+2)*N,\n*          where NB is the blocksize for SSYTRD returned by ILAENV.\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 algorithm failed to converge; i\n*                off-diagonal elements of an intermediate tridiagonal\n*                form did not converge to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, work, info, a = NumRu::Lapack.ssyev( jobz, uplo, a, [: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_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = 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;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (rblapack_lwork == Qnil)
    lwork = 3*n-1;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  ssyev_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_w, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_ssyev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssyev", rblapack_ssyev, -1);
}
ruby-lapack-1.7.2/ext/zgegs.c0000644000175000017500000002500412502221014015640 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgegs_(char* jobvsl, char* jobvsr, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* alpha, doublecomplex* beta, doublecomplex* vsl, integer* ldvsl, doublecomplex* vsr, integer* ldvsr, doublecomplex* work, integer* lwork, doublereal* rwork, integer* info);


static VALUE
rblapack_zgegs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvsl;
  char jobvsl; 
  VALUE rblapack_jobvsr;
  char jobvsr; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_alpha;
  doublecomplex *alpha; 
  VALUE rblapack_beta;
  doublecomplex *beta; 
  VALUE rblapack_vsl;
  doublecomplex *vsl; 
  VALUE rblapack_vsr;
  doublecomplex *vsr; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  doublereal *rwork;

  integer lda;
  integer n;
  integer ldb;
  integer ldvsl;
  integer ldvsr;

  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  alpha, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.zgegs( jobvsl, jobvsr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  This routine is deprecated and has been replaced by routine ZGGES.\n*\n*  ZGEGS computes the eigenvalues, Schur form, and, optionally, the\n*  left and or/right Schur vectors of a complex matrix pair (A,B).\n*  Given two square matrices A and B, the generalized Schur\n*  factorization has the form\n*  \n*     A = Q*S*Z**H,  B = Q*T*Z**H\n*  \n*  where Q and Z are unitary matrices and S and T are upper triangular.\n*  The columns of Q are the left Schur vectors\n*  and the columns of Z are the right Schur vectors.\n*  \n*  If only the eigenvalues of (A,B) are needed, the driver routine\n*  ZGEGV should be used instead.  See ZGEGV for a description of the\n*  eigenvalues of the generalized nonsymmetric eigenvalue problem\n*  (GNEP).\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVSL   (input) CHARACTER*1\n*          = 'N':  do not compute the left Schur vectors;\n*          = 'V':  compute the left Schur vectors (returned in VSL).\n*\n*  JOBVSR   (input) CHARACTER*1\n*          = 'N':  do not compute the right Schur vectors;\n*          = 'V':  compute the right Schur vectors (returned in VSR).\n*\n*  N       (input) INTEGER\n*          The order of the matrices A, B, VSL, and VSR.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA, N)\n*          On entry, the matrix A.\n*          On exit, the upper triangular matrix S from the generalized\n*          Schur factorization.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of A.  LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB, N)\n*          On entry, the matrix B.\n*          On exit, the upper triangular matrix T from the generalized\n*          Schur factorization.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of B.  LDB >= max(1,N).\n*\n*  ALPHA   (output) COMPLEX*16 array, dimension (N)\n*          The complex scalars alpha that define the eigenvalues of\n*          GNEP.  ALPHA(j) = S(j,j), the diagonal element of the Schur\n*          form of A.\n*\n*  BETA    (output) COMPLEX*16 array, dimension (N)\n*          The non-negative real scalars beta that define the\n*          eigenvalues of GNEP.  BETA(j) = T(j,j), the diagonal element\n*          of the triangular factor T.\n*\n*          Together, the quantities alpha = ALPHA(j) and beta = BETA(j)\n*          represent the j-th eigenvalue of the matrix pair (A,B), in\n*          one of the forms lambda = alpha/beta or mu = beta/alpha.\n*          Since either lambda or mu may overflow, they should not,\n*          in general, be computed.\n*\n*\n*  VSL     (output) COMPLEX*16 array, dimension (LDVSL,N)\n*          If JOBVSL = 'V', the matrix of left Schur vectors Q.\n*          Not referenced if JOBVSL = 'N'.\n*\n*  LDVSL   (input) INTEGER\n*          The leading dimension of the matrix VSL. LDVSL >= 1, and\n*          if JOBVSL = 'V', LDVSL >= N.\n*\n*  VSR     (output) COMPLEX*16 array, dimension (LDVSR,N)\n*          If JOBVSR = 'V', the matrix of right Schur vectors Z.\n*          Not referenced if JOBVSR = 'N'.\n*\n*  LDVSR   (input) INTEGER\n*          The leading dimension of the matrix VSR. LDVSR >= 1, and\n*          if JOBVSR = 'V', LDVSR >= N.\n*\n*  WORK    (workspace/output) COMPLEX*16 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,2*N).\n*          For good performance, LWORK must generally be larger.\n*          To compute the optimal value of LWORK, call ILAENV to get\n*          blocksizes (for ZGEQRF, ZUNMQR, and CUNGQR.)  Then compute:\n*          NB  -- MAX of the blocksizes for ZGEQRF, ZUNMQR, and CUNGQR;\n*          the optimal LWORK is N*(NB+1).\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*  RWORK   (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          =1,...,N:\n*                The QZ iteration failed.  (A,B) are not in Schur\n*                form, but ALPHA(j) and BETA(j) should be correct for\n*                j=INFO+1,...,N.\n*          > N:  errors that usually indicate LAPACK problems:\n*                =N+1: error return from ZGGBAL\n*                =N+2: error return from ZGEQRF\n*                =N+3: error return from ZUNMQR\n*                =N+4: error return from ZUNGQR\n*                =N+5: error return from ZGGHRD\n*                =N+6: error return from ZHGEQZ (other than failed\n*                                               iteration)\n*                =N+7: error return from ZGGBAK (computing VSL)\n*                =N+8: error return from ZGGBAK (computing VSR)\n*                =N+9: error return from ZLASCL (various places)\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  alpha, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.zgegs( jobvsl, jobvsr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_jobvsl = argv[0];
  rblapack_jobvsr = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  jobvsl = StringValueCStr(rblapack_jobvsl)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  jobvsr = StringValueCStr(rblapack_jobvsr)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  ldvsl = lsame_(&jobvsl,"V") ? n : 1;
  if (rblapack_lwork == Qnil)
    lwork = 2*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldvsr = lsame_(&jobvsr,"V") ? n : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  alpha = NA_PTR_TYPE(rblapack_alpha, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvsl;
    shape[1] = n;
    rblapack_vsl = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  vsl = NA_PTR_TYPE(rblapack_vsl, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvsr;
    shape[1] = n;
    rblapack_vsr = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  vsr = NA_PTR_TYPE(rblapack_vsr, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  rwork = ALLOC_N(doublereal, (3*n));

  zgegs_(&jobvsl, &jobvsr, &n, a, &lda, b, &ldb, alpha, beta, vsl, &ldvsl, vsr, &ldvsr, work, &lwork, rwork, &info);

  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_alpha, rblapack_beta, rblapack_vsl, rblapack_vsr, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_zgegs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgegs", rblapack_zgegs, -1);
}
ruby-lapack-1.7.2/ext/cpbtrf.c0000644000175000017500000001212712502221016016005 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cpbtrf_(char* uplo, integer* n, integer* kd, complex* ab, integer* ldab, integer* info);


static VALUE
rblapack_cpbtrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  complex *ab_out__;

  integer ldab;
  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  info, ab = NumRu::Lapack.cpbtrf( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPBTRF( UPLO, N, KD, AB, LDAB, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPBTRF computes the Cholesky factorization of a complex Hermitian\n*  positive definite band matrix A.\n*\n*  The factorization has the form\n*     A = U**H * U,  if UPLO = 'U', or\n*     A = L  * L**H,  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is lower triangular.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) COMPLEX array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*          On exit, if INFO = 0, the triangular factor U or L from the\n*          Cholesky factorization A = U**H*U or A = L*L**H of the band\n*          matrix A, in the same storage format as A.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\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 leading minor of order i is not\n*                positive definite, and the factorization could not be\n*                completed.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  N = 6, KD = 2, and UPLO = 'U':\n*\n*  On entry:                       On exit:\n*\n*      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46\n*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56\n*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66\n*\n*  Similarly, if UPLO = 'L' the format of A is as follows:\n*\n*  On entry:                       On exit:\n*\n*     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66\n*     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *\n*     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *\n*\n*  Array elements marked * are not used by the routine.\n*\n*  Contributed by\n*  Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ab = NumRu::Lapack.cpbtrf( uplo, kd, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  kd = NUM2INT(rblapack_kd);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
  MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  cpbtrf_(&uplo, &n, &kd, ab, &ldab, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ab);
}

void
init_lapack_cpbtrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cpbtrf", rblapack_cpbtrf, -1);
}
ruby-lapack-1.7.2/ext/zla_syrcond_x.c0000644000175000017500000001644612502221014017411 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal zla_syrcond_x_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublecomplex* x, integer* info, doublecomplex* work, doublereal* rwork);


static VALUE
rblapack_zla_syrcond_x(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_rwork;
  doublereal *rwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack___out__;
  doublereal __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  info, __out__ = NumRu::Lapack.zla_syrcond_x( uplo, a, af, ipiv, x, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION ZLA_SYRCOND_X( UPLO, N, A, LDA, AF, LDAF, IPIV, X, INFO, WORK, RWORK )\n\n*  Purpose\n*  =======\n*\n*     ZLA_SYRCOND_X Computes the infinity norm condition number of\n*     op(A) * diag(X) where X is a COMPLEX*16 vector.\n*\n\n*  Arguments\n*  =========\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     A       (input) COMPLEX*16 array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX*16 array, dimension (LDAF,N)\n*     The block diagonal matrix D and the multipliers used to\n*     obtain the factor U or L as computed by ZSYTRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     Details of the interchanges and the block structure of D\n*     as determined by ZSYTRF.\n*\n*     X       (input) COMPLEX*16 array, dimension (N)\n*     The vector X in the formula op(A) * diag(X).\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit.\n*     i > 0:  The ith argument is invalid.\n*\n*     WORK    (input) COMPLEX*16 array, dimension (2*N).\n*     Workspace.\n*\n*     RWORK   (input) DOUBLE PRECISION array, dimension (N).\n*     Workspace.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            KASE\n      DOUBLE PRECISION   AINVNM, ANORM, TMP\n      INTEGER            I, J\n      LOGICAL            UP\n      COMPLEX*16         ZDUM\n*     ..\n*     .. Local Arrays ..\n      INTEGER            ISAVE( 3 )\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           ZLACN2, ZSYTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX\n*     ..\n*     .. Statement Functions ..\n      DOUBLE PRECISION   CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, __out__ = NumRu::Lapack.zla_syrcond_x( uplo, a, af, ipiv, x, work, rwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_x = argv[4];
  rblapack_work = argv[5];
  rblapack_rwork = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (5th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  if (!NA_IsNArray(rblapack_rwork))
    rb_raise(rb_eArgError, "rwork (7th argument) must be NArray");
  if (NA_RANK(rblapack_rwork) != 1)
    rb_raise(rb_eArgError, "rank of rwork (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_rwork) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_rwork) != NA_DFLOAT)
    rblapack_rwork = na_change_type(rblapack_rwork, NA_DFLOAT);
  rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (6th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
  if (NA_TYPE(rblapack_work) != NA_DCOMPLEX)
    rblapack_work = na_change_type(rblapack_work, NA_DCOMPLEX);
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);

  __out__ = zla_syrcond_x_(&uplo, &n, a, &lda, af, &ldaf, ipiv, x, &info, work, rwork);

  rblapack_info = INT2NUM(info);
  rblapack___out__ = rb_float_new((double)__out__);
  return rb_ary_new3(2, rblapack_info, rblapack___out__);
}

void
init_lapack_zla_syrcond_x(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zla_syrcond_x", rblapack_zla_syrcond_x, -1);
}
ruby-lapack-1.7.2/ext/spbrfs.c0000644000175000017500000002025512502221013016022 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID spbrfs_(char* uplo, integer* n, integer* kd, integer* nrhs, real* ab, integer* ldab, real* afb, integer* ldafb, real* b, integer* ldb, real* x, integer* ldx, real* ferr, real* berr, real* work, integer* iwork, integer* info);


static VALUE
rblapack_spbrfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_afb;
  real *afb; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  real *x_out__;
  real *work;
  integer *iwork;

  integer ldab;
  integer n;
  integer ldafb;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.spbrfs( uplo, kd, ab, afb, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPBRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is symmetric positive definite\n*  and banded, and provides error bounds and backward error estimates\n*  for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AB      (input) REAL array, dimension (LDAB,N)\n*          The upper or lower triangle of the symmetric band matrix A,\n*          stored in the first KD+1 rows of the array.  The j-th column\n*          of A is stored in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  AFB     (input) REAL array, dimension (LDAFB,N)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**T*U or A = L*L**T of the band matrix A as computed by\n*          SPBTRF, in the same storage format as A (see AB).\n*\n*  LDAFB   (input) INTEGER\n*          The leading dimension of the array AFB.  LDAFB >= KD+1.\n*\n*  B       (input) REAL array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) REAL array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by SPBTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) REAL array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.spbrfs( uplo, kd, ab, afb, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  rblapack_afb = argv[3];
  rblapack_b = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  kd = NUM2INT(rblapack_kd);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (4th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (4th argument) must be %d", 2);
  ldafb = NA_SHAPE0(rblapack_afb);
  if (NA_SHAPE1(rblapack_afb) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_afb) != NA_SFLOAT)
    rblapack_afb = na_change_type(rblapack_afb, NA_SFLOAT);
  afb = NA_PTR_TYPE(rblapack_afb, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(real, (3*n));
  iwork = ALLOC_N(integer, (n));

  spbrfs_(&uplo, &n, &kd, &nrhs, ab, &ldab, afb, &ldafb, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_spbrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "spbrfs", rblapack_spbrfs, -1);
}
ruby-lapack-1.7.2/ext/claqge.c0000644000175000017500000001322112502221014015753 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID claqge_(integer* m, integer* n, complex* a, integer* lda, real* r, real* c, real* rowcnd, real* colcnd, real* amax, char* equed);


static VALUE
rblapack_claqge(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_r;
  real *r; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_rowcnd;
  real rowcnd; 
  VALUE rblapack_colcnd;
  real colcnd; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_a_out__;
  complex *a_out__;

  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  equed, a = NumRu::Lapack.claqge( a, r, c, rowcnd, colcnd, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n*  Purpose\n*  =======\n*\n*  CLAQGE equilibrates a general M by N matrix A using the row and\n*  column scaling factors in the vectors R and C.\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) COMPLEX array, dimension (LDA,N)\n*          On entry, the M by N matrix A.\n*          On exit, the equilibrated matrix.  See EQUED for the form of\n*          the equilibrated matrix.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(M,1).\n*\n*  R       (input) REAL array, dimension (M)\n*          The row scale factors for A.\n*\n*  C       (input) REAL array, dimension (N)\n*          The column scale factors for A.\n*\n*  ROWCND  (input) REAL\n*          Ratio of the smallest R(i) to the largest R(i).\n*\n*  COLCND  (input) REAL\n*          Ratio of the smallest C(i) to the largest C(i).\n*\n*  AMAX    (input) REAL\n*          Absolute value of largest matrix entry.\n*\n*  EQUED   (output) CHARACTER*1\n*          Specifies the form of equilibration that was done.\n*          = 'N':  No equilibration\n*          = 'R':  Row equilibration, i.e., A has been premultiplied by\n*                  diag(R).\n*          = 'C':  Column equilibration, i.e., A has been postmultiplied\n*                  by diag(C).\n*          = 'B':  Both row and column equilibration, i.e., A has been\n*                  replaced by diag(R) * A * diag(C).\n*\n*  Internal Parameters\n*  ===================\n*\n*  THRESH is a threshold value used to decide if row or column scaling\n*  should be done based on the ratio of the row or column scaling\n*  factors.  If ROWCND < THRESH, row scaling is done, and if\n*  COLCND < THRESH, column scaling is done.\n*\n*  LARGE and SMALL are threshold values used to decide if row scaling\n*  should be done based on the absolute size of the largest matrix\n*  element.  If AMAX > LARGE or AMAX < SMALL, row scaling is done.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  equed, a = NumRu::Lapack.claqge( a, r, c, rowcnd, colcnd, amax, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_a = argv[0];
  rblapack_r = argv[1];
  rblapack_c = argv[2];
  rblapack_rowcnd = argv[3];
  rblapack_colcnd = argv[4];
  rblapack_amax = argv[5];
  if (argc == 6) {
  } 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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (3th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  colcnd = (real)NUM2DBL(rblapack_colcnd);
  if (!NA_IsNArray(rblapack_r))
    rb_raise(rb_eArgError, "r (2th argument) must be NArray");
  if (NA_RANK(rblapack_r) != 1)
    rb_raise(rb_eArgError, "rank of r (2th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_r);
  if (NA_TYPE(rblapack_r) != NA_SFLOAT)
    rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
  r = NA_PTR_TYPE(rblapack_r, real*);
  amax = (real)NUM2DBL(rblapack_amax);
  rowcnd = (real)NUM2DBL(rblapack_rowcnd);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  claqge_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &equed);

  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(2, rblapack_equed, rblapack_a);
}

void
init_lapack_claqge(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "claqge", rblapack_claqge, -1);
}
ruby-lapack-1.7.2/ext/slasda.c0000644000175000017500000003221012502221017015770 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slasda_(integer* icompq, integer* smlsiz, integer* n, integer* sqre, real* d, real* e, real* u, integer* ldu, real* vt, integer* k, real* difl, real* difr, real* z, real* poles, integer* givptr, integer* givcol, integer* ldgcol, integer* perm, real* givnum, real* c, real* s, real* work, integer* iwork, integer* info);


static VALUE
rblapack_slasda(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_icompq;
  integer icompq; 
  VALUE rblapack_smlsiz;
  integer smlsiz; 
  VALUE rblapack_sqre;
  integer sqre; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_u;
  real *u; 
  VALUE rblapack_vt;
  real *vt; 
  VALUE rblapack_k;
  integer *k; 
  VALUE rblapack_difl;
  real *difl; 
  VALUE rblapack_difr;
  real *difr; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_poles;
  real *poles; 
  VALUE rblapack_givptr;
  integer *givptr; 
  VALUE rblapack_givcol;
  integer *givcol; 
  VALUE rblapack_perm;
  integer *perm; 
  VALUE rblapack_givnum;
  real *givnum; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  real *work;
  integer *iwork;

  integer n;
  integer ldu;
  integer nlvl;
  integer ldgcol;
  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  u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s, info, d = NumRu::Lapack.slasda( icompq, smlsiz, sqre, d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  Using a divide and conquer approach, SLASDA computes the singular\n*  value decomposition (SVD) of a real upper bidiagonal N-by-M matrix\n*  B with diagonal D and offdiagonal E, where M = N + SQRE. The\n*  algorithm computes the singular values in the SVD B = U * S * VT.\n*  The orthogonal matrices U and VT are optionally computed in\n*  compact form.\n*\n*  A related subroutine, SLASD0, computes the singular values and\n*  the singular vectors in explicit form.\n*\n\n*  Arguments\n*  =========\n*\n*  ICOMPQ (input) INTEGER\n*         Specifies whether singular vectors are to be computed\n*         in compact form, as follows\n*         = 0: Compute singular values only.\n*         = 1: Compute singular vectors of upper bidiagonal\n*              matrix in compact form.\n*\n*  SMLSIZ (input) INTEGER\n*         The maximum size of the subproblems at the bottom of the\n*         computation tree.\n*\n*  N      (input) INTEGER\n*         The row dimension of the upper bidiagonal matrix. This is\n*         also the dimension of the main diagonal array D.\n*\n*  SQRE   (input) INTEGER\n*         Specifies the column dimension of the bidiagonal matrix.\n*         = 0: The bidiagonal matrix has column dimension M = N;\n*         = 1: The bidiagonal matrix has column dimension M = N + 1.\n*\n*  D      (input/output) REAL array, dimension ( N )\n*         On entry D contains the main diagonal of the bidiagonal\n*         matrix. On exit D, if INFO = 0, contains its singular values.\n*\n*  E      (input) REAL array, dimension ( M-1 )\n*         Contains the subdiagonal entries of the bidiagonal matrix.\n*         On exit, E has been destroyed.\n*\n*  U      (output) REAL array,\n*         dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced\n*         if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left\n*         singular vector matrices of all subproblems at the bottom\n*         level.\n*\n*  LDU    (input) INTEGER, LDU = > N.\n*         The leading dimension of arrays U, VT, DIFL, DIFR, POLES,\n*         GIVNUM, and Z.\n*\n*  VT     (output) REAL array,\n*         dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced\n*         if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT' contains the right\n*         singular vector matrices of all subproblems at the bottom\n*         level.\n*\n*  K      (output) INTEGER array, dimension ( N ) \n*         if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0.\n*         If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th\n*         secular equation on the computation tree.\n*\n*  DIFL   (output) REAL array, dimension ( LDU, NLVL ),\n*         where NLVL = floor(log_2 (N/SMLSIZ))).\n*\n*  DIFR   (output) REAL array,\n*                  dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and\n*                  dimension ( N ) if ICOMPQ = 0.\n*         If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1)\n*         record distances between singular values on the I-th\n*         level and singular values on the (I -1)-th level, and\n*         DIFR(1:N, 2 * I ) contains the normalizing factors for\n*         the right singular vector matrix. See SLASD8 for details.\n*\n*  Z      (output) REAL array,\n*                  dimension ( LDU, NLVL ) if ICOMPQ = 1 and\n*                  dimension ( N ) if ICOMPQ = 0.\n*         The first K elements of Z(1, I) contain the components of\n*         the deflation-adjusted updating row vector for subproblems\n*         on the I-th level.\n*\n*  POLES  (output) REAL array,\n*         dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced\n*         if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and\n*         POLES(1, 2*I) contain  the new and old singular values\n*         involved in the secular equations on the I-th level.\n*\n*  GIVPTR (output) INTEGER array,\n*         dimension ( N ) if ICOMPQ = 1, and not referenced if\n*         ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records\n*         the number of Givens rotations performed on the I-th\n*         problem on the computation tree.\n*\n*  GIVCOL (output) INTEGER array,\n*         dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not\n*         referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,\n*         GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations\n*         of Givens rotations performed on the I-th level on the\n*         computation tree.\n*\n*  LDGCOL (input) INTEGER, LDGCOL = > N.\n*         The leading dimension of arrays GIVCOL and PERM.\n*\n*  PERM   (output) INTEGER array, dimension ( LDGCOL, NLVL ) \n*         if ICOMPQ = 1, and not referenced\n*         if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records\n*         permutations done on the I-th level of the computation tree.\n*\n*  GIVNUM (output) REAL array,\n*         dimension ( LDU,  2 * NLVL ) if ICOMPQ = 1, and not\n*         referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,\n*         GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S-\n*         values of Givens rotations performed on the I-th level on\n*         the computation tree.\n*\n*  C      (output) REAL array,\n*         dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0.\n*         If ICOMPQ = 1 and the I-th subproblem is not square, on exit,\n*         C( I ) contains the C-value of a Givens rotation related to\n*         the right null space of the I-th subproblem.\n*\n*  S      (output) REAL array, dimension ( N ) if\n*         ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1\n*         and the I-th subproblem is not square, on exit, S( I )\n*         contains the S-value of a Givens rotation related to\n*         the right null space of the I-th subproblem.\n*\n*  WORK   (workspace) REAL array, dimension\n*         (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)).\n*\n*  IWORK  (workspace) INTEGER array, dimension (7*N).\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 = 1, a singular value did not converge\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s, info, d = NumRu::Lapack.slasda( icompq, smlsiz, sqre, d, e, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_icompq = argv[0];
  rblapack_smlsiz = argv[1];
  rblapack_sqre = argv[2];
  rblapack_d = argv[3];
  rblapack_e = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  icompq = NUM2INT(rblapack_icompq);
  sqre = NUM2INT(rblapack_sqre);
  smlsiz = NUM2INT(rblapack_smlsiz);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  m = sqre == 0 ? n : sqre == 1 ? n+1 : 0;
  nlvl = floor(1.0/log(2.0)*log((double)n/smlsiz));
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (5th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (m-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", m-1);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  ldgcol = n;
  ldu = n;
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = MAX(1,smlsiz);
    rblapack_u = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  u = NA_PTR_TYPE(rblapack_u, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = smlsiz+1;
    rblapack_vt = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vt = NA_PTR_TYPE(rblapack_vt, real*);
  {
    na_shape_t shape[1];
    shape[0] = icompq == 1 ? n : icompq == 0 ? 1 : 0;
    rblapack_k = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  k = NA_PTR_TYPE(rblapack_k, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = nlvl;
    rblapack_difl = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  difl = NA_PTR_TYPE(rblapack_difl, real*);
  {
    na_shape_t shape[2];
    shape[0] = icompq == 1 ? ldu : icompq == 0 ? n : 0;
    shape[1] = icompq == 1 ? 2 * nlvl : 0;
    rblapack_difr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  difr = NA_PTR_TYPE(rblapack_difr, real*);
  {
    na_shape_t shape[2];
    shape[0] = icompq == 1 ? ldu : icompq == 0 ? n : 0;
    shape[1] = icompq == 1 ? nlvl : 0;
    rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = 2 * nlvl;
    rblapack_poles = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  poles = NA_PTR_TYPE(rblapack_poles, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_givptr = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  givptr = NA_PTR_TYPE(rblapack_givptr, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldgcol;
    shape[1] = 2 * nlvl;
    rblapack_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
  }
  givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldgcol;
    shape[1] = nlvl;
    rblapack_perm = na_make_object(NA_LINT, 2, shape, cNArray);
  }
  perm = NA_PTR_TYPE(rblapack_perm, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = 2 * nlvl;
    rblapack_givnum = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  givnum = NA_PTR_TYPE(rblapack_givnum, real*);
  {
    na_shape_t shape[1];
    shape[0] = icompq == 1 ? n : icompq == 0 ? 1 : 0;
    rblapack_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  c = NA_PTR_TYPE(rblapack_c, real*);
  {
    na_shape_t shape[1];
    shape[0] = icompq==1 ? n : icompq==0 ? 1 : 0;
    rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  work = ALLOC_N(real, (6 * n + (smlsiz + 1)*(smlsiz + 1)));
  iwork = ALLOC_N(integer, (7*n));

  slasda_(&icompq, &smlsiz, &n, &sqre, d, e, u, &ldu, vt, k, difl, difr, z, poles, givptr, givcol, &ldgcol, perm, givnum, c, s, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(15, rblapack_u, rblapack_vt, rblapack_k, rblapack_difl, rblapack_difr, rblapack_z, rblapack_poles, rblapack_givptr, rblapack_givcol, rblapack_perm, rblapack_givnum, rblapack_c, rblapack_s, rblapack_info, rblapack_d);
}

void
init_lapack_slasda(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slasda", rblapack_slasda, -1);
}
ruby-lapack-1.7.2/ext/zgtts2.c0000644000175000017500000001570012502221016015762 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgtts2_(integer* itrans, integer* n, integer* nrhs, doublecomplex* dl, doublecomplex* d, doublecomplex* du, doublecomplex* du2, integer* ipiv, doublecomplex* b, integer* ldb);


static VALUE
rblapack_zgtts2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itrans;
  integer itrans; 
  VALUE rblapack_dl;
  doublecomplex *dl; 
  VALUE rblapack_d;
  doublecomplex *d; 
  VALUE rblapack_du;
  doublecomplex *du; 
  VALUE rblapack_du2;
  doublecomplex *du2; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer n;
  integer ldb;
  integer nrhs;

  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  b = NumRu::Lapack.zgtts2( itrans, dl, d, du, du2, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )\n\n*  Purpose\n*  =======\n*\n*  ZGTTS2 solves one of the systems of equations\n*     A * X = B,  A**T * X = B,  or  A**H * X = B,\n*  with a tridiagonal matrix A using the LU factorization computed\n*  by ZGTTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  ITRANS  (input) INTEGER\n*          Specifies the form of the system of equations.\n*          = 0:  A * X = B     (No transpose)\n*          = 1:  A**T * X = B  (Transpose)\n*          = 2:  A**H * X = B  (Conjugate transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  DL      (input) COMPLEX*16 array, dimension (N-1)\n*          The (n-1) multipliers that define the matrix L from the\n*          LU factorization of A.\n*\n*  D       (input) COMPLEX*16 array, dimension (N)\n*          The n diagonal elements of the upper triangular matrix U from\n*          the LU factorization of A.\n*\n*  DU      (input) COMPLEX*16 array, dimension (N-1)\n*          The (n-1) elements of the first super-diagonal of U.\n*\n*  DU2     (input) COMPLEX*16 array, dimension (N-2)\n*          The (n-2) elements of the second super-diagonal of U.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices; for 1 <= i <= n, row i of the matrix was\n*          interchanged with row IPIV(i).  IPIV(i) will always be either\n*          i or i+1; IPIV(i) = i indicates a row interchange was not\n*          required.\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the matrix of right hand side vectors B.\n*          On exit, B is overwritten by the solution vectors X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n      COMPLEX*16         TEMP\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          DCONJG\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  b = NumRu::Lapack.zgtts2( itrans, dl, d, du, du2, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_itrans = argv[0];
  rblapack_dl = argv[1];
  rblapack_d = argv[2];
  rblapack_du = argv[3];
  rblapack_du2 = argv[4];
  rblapack_ipiv = argv[5];
  rblapack_b = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  itrans = NUM2INT(rblapack_itrans);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DCOMPLEX)
    rblapack_d = na_change_type(rblapack_d, NA_DCOMPLEX);
  d = NA_PTR_TYPE(rblapack_d, doublecomplex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_DCOMPLEX)
    rblapack_dl = na_change_type(rblapack_dl, NA_DCOMPLEX);
  dl = NA_PTR_TYPE(rblapack_dl, doublecomplex*);
  if (!NA_IsNArray(rblapack_du2))
    rb_raise(rb_eArgError, "du2 (5th argument) must be NArray");
  if (NA_RANK(rblapack_du2) != 1)
    rb_raise(rb_eArgError, "rank of du2 (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du2) != (n-2))
    rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
  if (NA_TYPE(rblapack_du2) != NA_DCOMPLEX)
    rblapack_du2 = na_change_type(rblapack_du2, NA_DCOMPLEX);
  du2 = NA_PTR_TYPE(rblapack_du2, doublecomplex*);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (4th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_DCOMPLEX)
    rblapack_du = na_change_type(rblapack_du, NA_DCOMPLEX);
  du = NA_PTR_TYPE(rblapack_du, doublecomplex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zgtts2_(&itrans, &n, &nrhs, dl, d, du, du2, ipiv, b, &ldb);

  return rblapack_b;
}

void
init_lapack_zgtts2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgtts2", rblapack_zgtts2, -1);
}
ruby-lapack-1.7.2/ext/zpteqr.c0000644000175000017500000001666612502221016016066 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zpteqr_(char* compz, integer* n, doublereal* d, doublereal* e, doublecomplex* z, integer* ldz, doublereal* work, integer* info);


static VALUE
rblapack_zpteqr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_compz;
  char compz; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_e_out__;
  doublereal *e_out__;
  VALUE rblapack_z_out__;
  doublecomplex *z_out__;
  doublereal *work;

  integer n;
  integer ldz;

  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  info, d, e, z = NumRu::Lapack.zpteqr( compz, d, e, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPTEQR computes all eigenvalues and, optionally, eigenvectors of a\n*  symmetric positive definite tridiagonal matrix by first factoring the\n*  matrix using DPTTRF and then calling ZBDSQR to compute the singular\n*  values of the bidiagonal factor.\n*\n*  This routine computes the eigenvalues of the positive definite\n*  tridiagonal matrix to high relative accuracy.  This means that if the\n*  eigenvalues range over many orders of magnitude in size, then the\n*  small eigenvalues and corresponding eigenvectors will be computed\n*  more accurately than, for example, with the standard QR method.\n*\n*  The eigenvectors of a full or band positive definite Hermitian matrix\n*  can also be found if ZHETRD, ZHPTRD, or ZHBTRD has been used to\n*  reduce this matrix to tridiagonal form.  (The reduction to\n*  tridiagonal form, however, may preclude the possibility of obtaining\n*  high relative accuracy in the small eigenvalues of the original\n*  matrix, if these eigenvalues range over many orders of magnitude.)\n*\n\n*  Arguments\n*  =========\n*\n*  COMPZ   (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only.\n*          = 'V':  Compute eigenvectors of original Hermitian\n*                  matrix also.  Array Z contains the unitary matrix\n*                  used to reduce the original matrix to tridiagonal\n*                  form.\n*          = 'I':  Compute eigenvectors of tridiagonal matrix also.\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the n diagonal elements of the tridiagonal matrix.\n*          On normal exit, D contains the eigenvalues, in descending\n*          order.\n*\n*  E       (input/output) DOUBLE PRECISION array, dimension (N-1)\n*          On entry, the (n-1) subdiagonal elements of the tridiagonal\n*          matrix.\n*          On exit, E has been destroyed.\n*\n*  Z       (input/output) COMPLEX*16 array, dimension (LDZ, N)\n*          On entry, if COMPZ = 'V', the unitary matrix used in the\n*          reduction to tridiagonal form.\n*          On exit, if COMPZ = 'V', the orthonormal eigenvectors of the\n*          original Hermitian matrix;\n*          if COMPZ = 'I', the orthonormal eigenvectors of the\n*          tridiagonal matrix.\n*          If INFO > 0 on exit, Z contains the eigenvectors associated\n*          with only the stored eigenvalues.\n*          If  COMPZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          COMPZ = 'V' or 'I', LDZ >= max(1,N).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (4*N)\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, and i is:\n*                <= N  the Cholesky factorization of the matrix could\n*                      not be performed because the i-th principal minor\n*                      was not positive definite.\n*                > N   the SVD algorithm failed to converge;\n*                      if INFO = N+i, i off-diagonal elements of the\n*                      bidiagonal factor did not converge to zero.\n*\n\n*  ====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, e, z = NumRu::Lapack.zpteqr( compz, d, e, z, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_compz = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  rblapack_z = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  compz = StringValueCStr(rblapack_compz)[0];
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (4th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  n = NA_SHAPE1(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_DCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of z");
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
  MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublecomplex*);
  MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  work = ALLOC_N(doublereal, (4*n));

  zpteqr_(&compz, &n, d, e, z, &ldz, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_e, rblapack_z);
}

void
init_lapack_zpteqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zpteqr", rblapack_zpteqr, -1);
}
ruby-lapack-1.7.2/ext/zptsvx.c0000644000175000017500000002707412502221021016106 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zptsvx_(char* fact, integer* n, integer* nrhs, doublereal* d, doublecomplex* e, doublereal* df, doublecomplex* ef, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zptsvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublecomplex *e; 
  VALUE rblapack_df;
  doublereal *df; 
  VALUE rblapack_ef;
  doublecomplex *ef; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_df_out__;
  doublereal *df_out__;
  VALUE rblapack_ef_out__;
  doublecomplex *ef_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, info, df, ef = NumRu::Lapack.zptsvx( fact, d, e, df, ef, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPTSVX uses the factorization A = L*D*L**H to compute the solution\n*  to a complex system of linear equations A*X = B, where A is an\n*  N-by-N Hermitian positive definite tridiagonal matrix and X and B\n*  are N-by-NRHS matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'N', the matrix A is factored as A = L*D*L**H, where L\n*     is a unit lower bidiagonal matrix and D is diagonal.  The\n*     factorization can also be regarded as having the form\n*     A = U**H*D*U.\n*\n*  2. If the leading i-by-i principal minor is not positive definite,\n*     then the routine returns with INFO = i. Otherwise, the factored\n*     form of A is used to estimate the condition number of the matrix\n*     A.  If the reciprocal of the condition number is less than machine\n*     precision, INFO = N+1 is returned as a warning, but the routine\n*     still goes on to solve for X and compute error bounds as\n*     described below.\n*\n*  3. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  4. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of the matrix\n*          A is supplied on entry.\n*          = 'F':  On entry, DF and EF contain the factored form of A.\n*                  D, E, DF, and EF will not be modified.\n*          = 'N':  The matrix A will be copied to DF and EF and\n*                  factored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          The n diagonal elements of the tridiagonal matrix A.\n*\n*  E       (input) COMPLEX*16 array, dimension (N-1)\n*          The (n-1) subdiagonal elements of the tridiagonal matrix A.\n*\n*  DF      (input or output) DOUBLE PRECISION array, dimension (N)\n*          If FACT = 'F', then DF is an input argument and on entry\n*          contains the n diagonal elements of the diagonal matrix D\n*          from the L*D*L**H factorization of A.\n*          If FACT = 'N', then DF is an output argument and on exit\n*          contains the n diagonal elements of the diagonal matrix D\n*          from the L*D*L**H factorization of A.\n*\n*  EF      (input or output) COMPLEX*16 array, dimension (N-1)\n*          If FACT = 'F', then EF is an input argument and on entry\n*          contains the (n-1) subdiagonal elements of the unit\n*          bidiagonal factor L from the L*D*L**H factorization of A.\n*          If FACT = 'N', then EF is an output argument and on exit\n*          contains the (n-1) subdiagonal elements of the unit\n*          bidiagonal factor L from the L*D*L**H factorization of A.\n*\n*  B       (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*          The N-by-NRHS right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) COMPLEX*16 array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The reciprocal condition number of the matrix A.  If RCOND\n*          is less than the machine precision (in particular, if\n*          RCOND = 0), the matrix is singular to working precision.\n*          This condition is indicated by a return code of INFO > 0.\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in any\n*          element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\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, and i is\n*                <= N:  the leading minor of order i of A is\n*                       not positive definite, so the factorization\n*                       could not be completed, and the solution has not\n*                       been computed. RCOND = 0 is returned.\n*                = N+1: U is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, info, df, ef = NumRu::Lapack.zptsvx( fact, d, e, df, ef, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_fact = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  rblapack_df = argv[3];
  rblapack_ef = argv[4];
  rblapack_b = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_df))
    rb_raise(rb_eArgError, "df (4th argument) must be NArray");
  if (NA_RANK(rblapack_df) != 1)
    rb_raise(rb_eArgError, "rank of df (4th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_df);
  if (NA_TYPE(rblapack_df) != NA_DFLOAT)
    rblapack_df = na_change_type(rblapack_df, NA_DFLOAT);
  df = NA_PTR_TYPE(rblapack_df, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of df");
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_ef))
    rb_raise(rb_eArgError, "ef (5th argument) must be NArray");
  if (NA_RANK(rblapack_ef) != 1)
    rb_raise(rb_eArgError, "rank of ef (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ef) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of ef must be %d", n-1);
  if (NA_TYPE(rblapack_ef) != NA_DCOMPLEX)
    rblapack_ef = na_change_type(rblapack_ef, NA_DCOMPLEX);
  ef = NA_PTR_TYPE(rblapack_ef, doublecomplex*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DCOMPLEX)
    rblapack_e = na_change_type(rblapack_e, NA_DCOMPLEX);
  e = NA_PTR_TYPE(rblapack_e, doublecomplex*);
  ldx = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_df_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  df_out__ = NA_PTR_TYPE(rblapack_df_out__, doublereal*);
  MEMCPY(df_out__, df, doublereal, NA_TOTAL(rblapack_df));
  rblapack_df = rblapack_df_out__;
  df = df_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_ef_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  ef_out__ = NA_PTR_TYPE(rblapack_ef_out__, doublecomplex*);
  MEMCPY(ef_out__, ef, doublecomplex, NA_TOTAL(rblapack_ef));
  rblapack_ef = rblapack_ef_out__;
  ef = ef_out__;
  work = ALLOC_N(doublecomplex, (n));
  rwork = ALLOC_N(doublereal, (n));

  zptsvx_(&fact, &n, &nrhs, d, e, df, ef, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_df, rblapack_ef);
}

void
init_lapack_zptsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zptsvx", rblapack_zptsvx, -1);
}
ruby-lapack-1.7.2/ext/ctrtrs.c0000644000175000017500000001267012502221020016044 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctrtrs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, complex* a, integer* lda, complex* b, integer* ldb, integer* info);


static VALUE
rblapack_ctrtrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.ctrtrs( uplo, trans, diag, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTRTRS solves a triangular system of the form\n*\n*     A * X = B,  A**T * X = B,  or  A**H * X = B,\n*\n*  where A is a triangular matrix of order N, and B is an N-by-NRHS\n*  matrix.  A check is made to verify that A is nonsingular.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The triangular matrix A.  If UPLO = 'U', the leading N-by-N\n*          upper triangular part of the array A contains the upper\n*          triangular matrix, and the strictly lower triangular part of\n*          A is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*          triangular part of the array A contains the lower triangular\n*          matrix, and the strictly upper triangular part of A is not\n*          referenced.  If DIAG = 'U', the diagonal elements of A are\n*          also not referenced and are assumed to be 1.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, if INFO = 0, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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 A is zero,\n*               indicating that the matrix is singular and the solutions\n*               X have not been computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.ctrtrs( uplo, trans, diag, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  ctrtrs_(&uplo, &trans, &diag, &n, &nrhs, a, &lda, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_ctrtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctrtrs", rblapack_ctrtrs, -1);
}
ruby-lapack-1.7.2/ext/dporfsx.c0000644000175000017500000005046512502221022016216 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dporfsx_(char* uplo, char* equed, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* af, integer* ldaf, doublereal* s, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dporfsx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_af;
  doublereal *af; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_params;
  doublereal *params; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_err_bnds_norm;
  doublereal *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  doublereal *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_s_out__;
  doublereal *s_out__;
  VALUE rblapack_x_out__;
  doublereal *x_out__;
  VALUE rblapack_params_out__;
  doublereal *params_out__;
  doublereal *work;
  integer *iwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;
  integer nparams;
  integer n_err_bnds;

  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  rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.dporfsx( uplo, equed, a, af, s, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     DPORFSX improves the computed solution to a system of linear\n*     equations when the coefficient matrix is symmetric positive\n*     definite, and provides error bounds and backward error estimates\n*     for the solution.  In addition to normwise error bound, the code\n*     provides maximum componentwise error bound if possible.  See\n*     comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n*     error bounds.\n*\n*     The original system of linear equations may have been equilibrated\n*     before calling this routine, as described by arguments EQUED and S\n*     below. In this case, the solution and error bounds returned are\n*     for the original unequilibrated system.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     EQUED   (input) CHARACTER*1\n*     Specifies the form of equilibration that was done to A\n*     before calling this routine. This is needed to compute\n*     the solution and error bounds correctly.\n*       = 'N':  No equilibration\n*       = 'Y':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(S) * A * diag(S).\n*               The right hand side B has been changed accordingly.\n*\n*     N       (input) INTEGER\n*     The order of the matrix A.  N >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*     The symmetric matrix A.  If UPLO = 'U', the leading N-by-N\n*     upper triangular part of A contains the upper triangular part\n*     of the matrix A, and the strictly lower triangular part of A\n*     is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*     triangular part of A contains the lower triangular part of\n*     the matrix A, and the strictly upper triangular part of A is\n*     not referenced.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) DOUBLE PRECISION array, dimension (LDAF,N)\n*     The triangular factor U or L from the Cholesky factorization\n*     A = U**T*U or A = L*L**T, as computed by DPOTRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     S       (input or output) DOUBLE PRECISION array, dimension (N)\n*     The row scale factors for A.  If EQUED = 'Y', A is multiplied on\n*     the left and right by diag(S).  S is an input argument if FACT =\n*     'F'; otherwise, S is an output argument.  If FACT = 'F' and EQUED\n*     = 'Y', each element of S must be positive.  If S is output, each\n*     element of S is a power of the radix. If S is input, each element\n*     of S should be a power of the radix to ensure a reliable solution\n*     and error estimates. Scaling by powers of the radix does not cause\n*     rounding errors unless the result underflows or overflows.\n*     Rounding errors during scaling lead to refining with a matrix that\n*     is not equivalent to the input matrix, producing error estimates\n*     that may not be reliable.\n*\n*     B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*     The right hand side matrix B.\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*     On entry, the solution matrix X, as computed by DGETRS.\n*     On exit, the improved solution matrix X.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) DOUBLE PRECISION\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*     Componentwise relative backward error.  This is the\n*     componentwise relative backward error of each solution vector X(j)\n*     (i.e., the smallest relative change in any element of A or B that\n*     makes X(j) an exact solution).\n*\n*     N_ERR_BNDS (input) INTEGER\n*     Number of error bounds to return for each right hand side\n*     and each type (normwise or componentwise).  See ERR_BNDS_NORM and\n*     ERR_BNDS_COMP below.\n*\n*     ERR_BNDS_NORM  (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * dlamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * dlamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * dlamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * dlamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * dlamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * dlamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     NPARAMS (input) INTEGER\n*     Specifies the number of parameters set in PARAMS.  If .LE. 0, the\n*     PARAMS array is never referenced and default values are used.\n*\n*     PARAMS  (input / output) DOUBLE PRECISION array, dimension (NPARAMS)\n*     Specifies algorithm parameters.  If an entry is .LT. 0.0, then\n*     that entry will be filled with default value used for that\n*     parameter.  Only positions up to NPARAMS are accessed; defaults\n*     are used for higher-numbered parameters.\n*\n*       PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n*            refinement or not.\n*         Default: 1.0D+0\n*            = 0.0 : No refinement is performed, and no error bounds are\n*                    computed.\n*            = 1.0 : Use the double-precision refinement algorithm,\n*                    possibly with doubled-single computations if the\n*                    compilation environment does not support DOUBLE\n*                    PRECISION.\n*              (other values are reserved for future use)\n*\n*       PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n*            computations allowed for refinement.\n*         Default: 10\n*         Aggressive: Set to 100 to permit convergence using approximate\n*                     factorizations or factorizations other than LU. If\n*                     the factorization uses a technique other than\n*                     Gaussian elimination, the guarantees in\n*                     err_bnds_norm and err_bnds_comp may no longer be\n*                     trustworthy.\n*\n*       PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n*            will attempt to find a solution with small componentwise\n*            relative error in the double-precision algorithm.  Positive\n*            is true, 0.0 is false.\n*         Default: 1.0 (attempt componentwise convergence)\n*\n*     WORK    (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n*     IWORK   (workspace) INTEGER array, dimension (N)\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit. The solution to every right-hand side is\n*         guaranteed.\n*       < 0:  If INFO = -i, the i-th argument had an illegal value\n*       > 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.dporfsx( uplo, equed, a, af, s, b, x, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_uplo = argv[0];
  rblapack_equed = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_s = argv[4];
  rblapack_b = argv[5];
  rblapack_x = argv[6];
  rblapack_params = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (5th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (7th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  n_err_bnds = 3;
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
  af = NA_PTR_TYPE(rblapack_af, doublereal*);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (8th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (8th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_DFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
  params = NA_PTR_TYPE(rblapack_params, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
  MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
  MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(doublereal, (4*n));
  iwork = ALLOC_N(integer, (n));

  dporfsx_(&uplo, &equed, &n, &nrhs, a, &lda, af, &ldaf, s, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_s, rblapack_x, rblapack_params);
}

void
init_lapack_dporfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dporfsx", rblapack_dporfsx, -1);
}
ruby-lapack-1.7.2/ext/spbtrs.c0000644000175000017500000001206712502221015016044 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID spbtrs_(char* uplo, integer* n, integer* kd, integer* nrhs, real* ab, integer* ldab, real* b, integer* ldb, integer* info);


static VALUE
rblapack_spbtrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  real *b_out__;

  integer ldab;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.spbtrs( uplo, kd, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPBTRS solves a system of linear equations A*X = B with a symmetric\n*  positive definite band matrix A using the Cholesky factorization\n*  A = U**T*U or A = L*L**T computed by SPBTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangular factor stored in AB;\n*          = 'L':  Lower triangular factor stored in AB.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AB      (input) REAL array, dimension (LDAB,N)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**T*U or A = L*L**T of the band matrix A, stored in the\n*          first KD+1 rows of the array.  The j-th column of U or L is\n*          stored in the j-th column of the array AB as follows:\n*          if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO ='L', AB(1+i-j,j)    = L(i,j) for j<=i<=min(n,j+kd).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            UPPER\n      INTEGER            J\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           STBSV, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.spbtrs( uplo, kd, ab, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  kd = NUM2INT(rblapack_kd);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  spbtrs_(&uplo, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_spbtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "spbtrs", rblapack_spbtrs, -1);
}
ruby-lapack-1.7.2/ext/dsytd2.c0000644000175000017500000001547312502221025015745 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsytd2_(char* uplo, integer* n, doublereal* a, integer* lda, doublereal* d, doublereal* e, doublereal* tau, integer* info);


static VALUE
rblapack_dsytd2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_tau;
  doublereal *tau; 
  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  d, e, tau, info, a = NumRu::Lapack.dsytd2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal\n*  form T by an orthogonal similarity transformation: Q' * A * Q = T.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored:\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          n-by-n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n-by-n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*          On exit, if UPLO = 'U', the diagonal and first superdiagonal\n*          of A are overwritten by the corresponding elements of the\n*          tridiagonal matrix T, and the elements above the first\n*          superdiagonal, with the array TAU, represent the orthogonal\n*          matrix Q as a product of elementary reflectors; if UPLO\n*          = 'L', the diagonal and first subdiagonal of A are over-\n*          written by the corresponding elements of the tridiagonal\n*          matrix T, and the elements below the first subdiagonal, with\n*          the array TAU, represent the orthogonal matrix Q as a product\n*          of elementary reflectors. See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  D       (output) DOUBLE PRECISION array, dimension (N)\n*          The diagonal elements of the tridiagonal matrix T:\n*          D(i) = A(i,i).\n*\n*  E       (output) DOUBLE PRECISION array, dimension (N-1)\n*          The off-diagonal elements of the tridiagonal matrix T:\n*          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n*  TAU     (output) DOUBLE PRECISION array, dimension (N-1)\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\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*  If UPLO = 'U', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(n-1) . . . H(2) H(1).\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(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n*  A(1:i-1,i+1), and tau in TAU(i).\n*\n*  If UPLO = 'L', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(1) H(2) . . . H(n-1).\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) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n*  and tau in TAU(i).\n*\n*  The contents of A on exit are illustrated by the following examples\n*  with n = 5:\n*\n*  if UPLO = 'U':                       if UPLO = 'L':\n*\n*    (  d   e   v2  v3  v4 )              (  d                  )\n*    (      d   e   v3  v4 )              (  e   d              )\n*    (          d   e   v4 )              (  v1  e   d          )\n*    (              d   e  )              (  v1  v2  e   d      )\n*    (                  d  )              (  v1  v2  v3  e   d  )\n*\n*  where d and e denote diagonal and off-diagonal elements of T, and vi\n*  denotes an element of the vector defining H(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, tau, info, a = NumRu::Lapack.dsytd2( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t 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__;

  dsytd2_(&uplo, &n, a, &lda, d, e, tau, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_d, rblapack_e, rblapack_tau, rblapack_info, rblapack_a);
}

void
init_lapack_dsytd2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsytd2", rblapack_dsytd2, -1);
}
ruby-lapack-1.7.2/ext/dlarfb.c0000644000175000017500000001513612502221015015761 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlarfb_(char* side, char* trans, char* direct, char* storev, integer* m, integer* n, integer* k, doublereal* v, integer* ldv, doublereal* t, integer* ldt, doublereal* c, integer* ldc, doublereal* work, integer* ldwork);


static VALUE
rblapack_dlarfb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_direct;
  char direct; 
  VALUE rblapack_storev;
  char storev; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_v;
  doublereal *v; 
  VALUE rblapack_t;
  doublereal *t; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_c_out__;
  doublereal *c_out__;
  doublereal *work;

  integer ldv;
  integer k;
  integer ldt;
  integer ldc;
  integer n;
  integer ldwork;

  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  c = NumRu::Lapack.dlarfb( side, trans, direct, storev, m, v, t, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n*  Purpose\n*  =======\n*\n*  DLARFB applies a real block reflector H or its transpose H' to a\n*  real m by n matrix C, from either the left or the right.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply H or H' from the Left\n*          = 'R': apply H or H' from the Right\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': apply H (No transpose)\n*          = 'T': apply H' (Transpose)\n*\n*  DIRECT  (input) CHARACTER*1\n*          Indicates how H is formed from a product of elementary\n*          reflectors\n*          = 'F': H = H(1) H(2) . . . H(k) (Forward)\n*          = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n*  STOREV  (input) CHARACTER*1\n*          Indicates how the vectors which define the elementary\n*          reflectors are stored:\n*          = 'C': Columnwise\n*          = 'R': Rowwise\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C.\n*\n*  K       (input) INTEGER\n*          The order of the matrix T (= the number of elementary\n*          reflectors whose product defines the block reflector).\n*\n*  V       (input) DOUBLE PRECISION array, dimension\n*                                (LDV,K) if STOREV = 'C'\n*                                (LDV,M) if STOREV = 'R' and SIDE = 'L'\n*                                (LDV,N) if STOREV = 'R' and SIDE = 'R'\n*          The matrix V. See further details.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V.\n*          If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);\n*          if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);\n*          if STOREV = 'R', LDV >= K.\n*\n*  T       (input) DOUBLE PRECISION array, dimension (LDT,K)\n*          The triangular k by k matrix T in the representation of the\n*          block reflector.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= K.\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n*          On entry, the m by n matrix C.\n*          On exit, C is overwritten by H*C or H'*C or C*H or C*H'.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDA >= max(1,M).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (LDWORK,K)\n*\n*  LDWORK  (input) INTEGER\n*          The leading dimension of the array WORK.\n*          If SIDE = 'L', LDWORK >= max(1,N);\n*          if SIDE = 'R', LDWORK >= max(1,M).\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.dlarfb( side, trans, direct, storev, m, v, t, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_direct = argv[2];
  rblapack_storev = argv[3];
  rblapack_m = argv[4];
  rblapack_v = argv[5];
  rblapack_t = argv[6];
  rblapack_c = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  direct = StringValueCStr(rblapack_direct)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (7th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (7th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  k = NA_SHAPE1(rblapack_t);
  if (NA_TYPE(rblapack_t) != NA_DFLOAT)
    rblapack_t = na_change_type(rblapack_t, NA_DFLOAT);
  t = NA_PTR_TYPE(rblapack_t, doublereal*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (6th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (6th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  if (NA_SHAPE1(rblapack_v) != k)
    rb_raise(rb_eRuntimeError, "shape 1 of v must be the same as shape 1 of t");
  if (NA_TYPE(rblapack_v) != NA_DFLOAT)
    rblapack_v = na_change_type(rblapack_v, NA_DFLOAT);
  v = NA_PTR_TYPE(rblapack_v, doublereal*);
  storev = StringValueCStr(rblapack_storev)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (8th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  ldwork = MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0;
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(doublereal, (ldwork)*(k));

  dlarfb_(&side, &trans, &direct, &storev, &m, &n, &k, v, &ldv, t, &ldt, c, &ldc, work, &ldwork);

  free(work);
  return rblapack_c;
}

void
init_lapack_dlarfb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlarfb", rblapack_dlarfb, -1);
}
ruby-lapack-1.7.2/ext/zsytri2.c0000644000175000017500000001401712502221017016154 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zsytri2_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zsytri2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  integer c__1;
  integer c__m1;
  integer nb;
  doublecomplex *work;

  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  info, a = NumRu::Lapack.zsytri2( uplo, a, ipiv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZSYTRI2 computes the inverse of a complex symmetric indefinite matrix\n*  A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n*  ZSYTRF. ZSYTRI2 sets the LEADING DIMENSION of the workspace\n*  before calling ZSYTRI2X that actually computes the inverse.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE COMPLEX array, dimension (LDA,N)\n*          On entry, the NB diagonal matrix D and the multipliers\n*          used to obtain the factor U or L as computed by ZSYTRF.\n*\n*          On exit, if INFO = 0, the (symmetric) inverse of the original\n*          matrix.  If UPLO = 'U', the upper triangular part of the\n*          inverse is formed and the part of A below the diagonal is not\n*          referenced; if UPLO = 'L' the lower triangular part of the\n*          inverse is formed and the part of A above the diagonal is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the NB structure of D\n*          as determined by ZSYTRF.\n*\n*  WORK    (workspace) DOUBLE COMPLEX array, dimension (N+NB+1)*(NB+3)\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK.\n*          WORK is size >= (N+NB+1)*(NB+3)\n*          If LDWORK = -1, then a workspace query is assumed; the routine\n*           calculates:\n*              - the optimal size of the WORK array, returns\n*          this value as the first entry of the WORK array,\n*              - and no error message related to LDWORK 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, D(i,i) = 0; the matrix is singular and its\n*               inverse could not be computed.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            UPPER, LQUERY\n      INTEGER            MINSIZE, NBMAX\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            ILAENV\n      EXTERNAL           LSAME, ILAENV\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           ZSYTRI2X\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.zsytri2( uplo, a, ipiv, [: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_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = 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;
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  c__1 = 1;
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  c__m1 = -1;
  nb = ilaenv_(&c__1, "ZSYTRF", &uplo, &n, &c__m1, &c__m1, &c__m1);
  lwork = (n+nb+1)*(nb+3);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(doublecomplex, (lwork));

  zsytri2_(&uplo, &n, a, &lda, ipiv, work, &lwork, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_zsytri2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zsytri2", rblapack_zsytri2, -1);
}
ruby-lapack-1.7.2/ext/dsyevx.c0000644000175000017500000002525712502221022016054 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsyevx_(char* jobz, char* range, char* uplo, integer* n, doublereal* a, integer* lda, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublereal* z, integer* ldz, doublereal* work, integer* lwork, integer* iwork, integer* ifail, integer* info);


static VALUE
rblapack_dsyevx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_vl;
  doublereal vl; 
  VALUE rblapack_vu;
  doublereal vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  doublereal abstol; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_ifail;
  integer *ifail; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  integer *iwork;

  integer lda;
  integer n;
  integer ldz;

  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  m, w, z, work, ifail, info, a = NumRu::Lapack.dsyevx( jobz, range, uplo, a, vl, vu, il, iu, abstol, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSYEVX computes selected eigenvalues and, optionally, eigenvectors\n*  of a real symmetric matrix A.  Eigenvalues and eigenvectors can be\n*  selected by specifying either a range of values or a range of indices\n*  for the desired eigenvalues.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found.\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found.\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of A contains the\n*          upper triangular part of the matrix A.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of A contains\n*          the lower triangular part of the matrix A.\n*          On exit, the lower triangle (if UPLO='L') or the upper\n*          triangle (if UPLO='U') of A, including the diagonal, is\n*          destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  VL      (input) DOUBLE PRECISION\n*  VU      (input) DOUBLE PRECISION\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) DOUBLE PRECISION\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less than\n*          or equal to zero, then  EPS*|T|  will be used in its place,\n*          where |T| is the 1-norm of the tridiagonal matrix obtained\n*          by reducing A to tridiagonal form.\n*\n*          Eigenvalues will be computed most accurately when ABSTOL is\n*          set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n*          If this routine returns with INFO>0, indicating that some\n*          eigenvectors did not converge, try setting ABSTOL to\n*          2*DLAMCH('S').\n*\n*          See \"Computing Small Singular Values of Bidiagonal Matrices\n*          with Guaranteed High Relative Accuracy,\" by Demmel and\n*          Kahan, LAPACK Working Note #3.\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          On normal exit, the first M elements contain the selected\n*          eigenvalues in ascending order.\n*\n*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))\n*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix A\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          If an eigenvector fails to converge, then that column of Z\n*          contains the latest approximation to the eigenvector, and the\n*          index of the eigenvector is returned in IFAIL.\n*          If JOBZ = 'N', then Z is not referenced.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,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 length of the array WORK.  LWORK >= 1, when N <= 1;\n*          otherwise 8*N.\n*          For optimal efficiency, LWORK >= (NB+3)*N,\n*          where NB is the max of the blocksize for DSYTRD and DORMTR\n*          returned by ILAENV.\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*  IWORK   (workspace) INTEGER array, dimension (5*N)\n*\n*  IFAIL   (output) INTEGER array, dimension (N)\n*          If JOBZ = 'V', then if INFO = 0, the first M elements of\n*          IFAIL are zero.  If INFO > 0, then IFAIL contains the\n*          indices of the eigenvectors that failed to converge.\n*          If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n*                Their indices are stored in array IFAIL.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, work, ifail, info, a = NumRu::Lapack.dsyevx( jobz, range, uplo, a, vl, vu, il, iu, abstol, [: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_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_uplo = argv[2];
  rblapack_a = argv[3];
  rblapack_vl = argv[4];
  rblapack_vu = argv[5];
  rblapack_il = argv[6];
  rblapack_iu = argv[7];
  rblapack_abstol = 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;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  vl = NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  abstol = NUM2DBL(rblapack_abstol);
  range = StringValueCStr(rblapack_range)[0];
  vu = NUM2DBL(rblapack_vu);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th 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*);
  if (rblapack_lwork == Qnil)
    lwork = n<=1 ? 1 : 8*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  iu = NUM2INT(rblapack_iu);
  m = lsame_(&range,"I") ? iu-il+1 : n;
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
  {
    na_shape_t 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__;
  iwork = ALLOC_N(integer, (5*n));

  dsyevx_(&jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, &lwork, iwork, ifail, &info);

  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_m, rblapack_w, rblapack_z, rblapack_work, rblapack_ifail, rblapack_info, rblapack_a);
}

void
init_lapack_dsyevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsyevx", rblapack_dsyevx, -1);
}
ruby-lapack-1.7.2/ext/clarfx.c0000644000175000017500000001070212502221025016001 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clarfx_(char* side, integer* m, integer* n, complex* v, complex* tau, complex* c, integer* ldc, complex* work);


static VALUE
rblapack_clarfx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_v;
  complex *v; 
  VALUE rblapack_tau;
  complex tau; 
  VALUE rblapack_c;
  complex *c; 
  VALUE rblapack_c_out__;
  complex *c_out__;
  complex *work;

  integer m;
  integer ldc;
  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  c = NumRu::Lapack.clarfx( side, v, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )\n\n*  Purpose\n*  =======\n*\n*  CLARFX applies a complex elementary reflector H to a complex m by n\n*  matrix C, from either the left or the right. H is represented in the\n*  form\n*\n*        H = I - tau * v * v'\n*\n*  where tau is a complex scalar and v is a complex vector.\n*\n*  If tau = 0, then H is taken to be the unit matrix\n*\n*  This version uses inline code if H has order < 11.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': form  H * C\n*          = 'R': form  C * H\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C.\n*\n*  V       (input) COMPLEX array, dimension (M) if SIDE = 'L'\n*                                        or (N) if SIDE = 'R'\n*          The vector v in the representation of H.\n*\n*  TAU     (input) COMPLEX\n*          The value tau in the representation of H.\n*\n*  C       (input/output) COMPLEX array, dimension (LDC,N)\n*          On entry, the m by n matrix C.\n*          On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n*          or C * H if SIDE = 'R'.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDA >= max(1,M).\n*\n*  WORK    (workspace) COMPLEX array, dimension (N) if SIDE = 'L'\n*                                            or (M) if SIDE = 'R'\n*          WORK is not referenced if H has order < 11.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.clarfx( side, v, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_side = argv[0];
  rblapack_v = argv[1];
  rblapack_tau = argv[2];
  rblapack_c = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  tau.r = (real)NUM2DBL(rb_funcall(rblapack_tau, rb_intern("real"), 0));
  tau.i = (real)NUM2DBL(rb_funcall(rblapack_tau, rb_intern("imag"), 0));
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (2th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 1)
    rb_raise(rb_eArgError, "rank of v (2th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_v);
  if (NA_TYPE(rblapack_v) != NA_SCOMPLEX)
    rblapack_v = na_change_type(rblapack_v, NA_SCOMPLEX);
  v = NA_PTR_TYPE(rblapack_v, complex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (4th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (4th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
  MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(complex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  clarfx_(&side, &m, &n, v, &tau, c, &ldc, work);

  free(work);
  return rblapack_c;
}

void
init_lapack_clarfx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clarfx", rblapack_clarfx, -1);
}
ruby-lapack-1.7.2/ext/cgbtf2.c0000644000175000017500000001314512502221024015674 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgbtf2_(integer* m, integer* n, integer* kl, integer* ku, complex* ab, integer* ldab, integer* ipiv, integer* info);


static VALUE
rblapack_cgbtf2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  complex *ab_out__;

  integer ldab;
  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  ipiv, info, ab = NumRu::Lapack.cgbtf2( m, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGBTF2 computes an LU factorization of a complex m-by-n band matrix\n*  A using partial pivoting with row interchanges.\n*\n*  This is the unblocked version of the algorithm, calling Level 2 BLAS.\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*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  AB      (input/output) COMPLEX array, dimension (LDAB,N)\n*          On entry, the matrix A in band storage, in rows KL+1 to\n*          2*KL+KU+1; rows 1 to KL of the array need not be set.\n*          The j-th column of A is stored in the j-th column of the\n*          array AB as follows:\n*          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n*          On exit, details of the factorization: U is stored as an\n*          upper triangular band matrix with KL+KU superdiagonals in\n*          rows 1 to KL+KU+1, and the multipliers used during the\n*          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n*          See below for further details.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.\n*\n*  IPIV    (output) INTEGER array, dimension (min(M,N))\n*          The pivot indices; for 1 <= i <= min(M,N), row i of the\n*          matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n*               has been completed, but the factor U is exactly\n*               singular, and division by zero will occur if it is used\n*               to solve a system of equations.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  M = N = 6, KL = 2, KU = 1:\n*\n*  On entry:                       On exit:\n*\n*      *    *    *    +    +    +       *    *    *   u14  u25  u36\n*      *    *    +    +    +    +       *    *   u13  u24  u35  u46\n*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56\n*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66\n*     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *\n*     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *\n*\n*  Array elements marked * are not used by the routine; elements marked\n*  + need not be set on entry, but are required by the routine to store\n*  elements of U, because of fill-in resulting from the row\n*  interchanges.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, ab = NumRu::Lapack.cgbtf2( m, kl, ku, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_m = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  ku = NUM2INT(rblapack_ku);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
  MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  cgbtf2_(&m, &n, &kl, &ku, ab, &ldab, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_ab);
}

void
init_lapack_cgbtf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgbtf2", rblapack_cgbtf2, -1);
}
ruby-lapack-1.7.2/ext/slags2.c0000644000175000017500000001062612502221021015716 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slags2_(logical* upper, real* a1, real* a2, real* a3, real* b1, real* b2, real* b3, real* csu, real* snu, real* csv, real* snv, real* csq, real* snq);


static VALUE
rblapack_slags2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_upper;
  logical upper; 
  VALUE rblapack_a1;
  real a1; 
  VALUE rblapack_a2;
  real a2; 
  VALUE rblapack_a3;
  real a3; 
  VALUE rblapack_b1;
  real b1; 
  VALUE rblapack_b2;
  real b2; 
  VALUE rblapack_b3;
  real b3; 
  VALUE rblapack_csu;
  real csu; 
  VALUE rblapack_snu;
  real snu; 
  VALUE rblapack_csv;
  real csv; 
  VALUE rblapack_snv;
  real snv; 
  VALUE rblapack_csq;
  real csq; 
  VALUE rblapack_snq;
  real snq; 


  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  csu, snu, csv, snv, csq, snq = NumRu::Lapack.slags2( upper, a1, a2, a3, b1, b2, b3, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, SNV, CSQ, SNQ )\n\n*  Purpose\n*  =======\n*\n*  SLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such\n*  that if ( UPPER ) then\n*\n*            U'*A*Q = U'*( A1 A2 )*Q = ( x  0  )\n*                        ( 0  A3 )     ( x  x  )\n*  and\n*            V'*B*Q = V'*( B1 B2 )*Q = ( x  0  )\n*                        ( 0  B3 )     ( x  x  )\n*\n*  or if ( .NOT.UPPER ) then\n*\n*            U'*A*Q = U'*( A1 0  )*Q = ( x  x  )\n*                        ( A2 A3 )     ( 0  x  )\n*  and\n*            V'*B*Q = V'*( B1 0  )*Q = ( x  x  )\n*                        ( B2 B3 )     ( 0  x  )\n*\n*  The rows of the transformed A and B are parallel, where\n*\n*    U = (  CSU  SNU ), V = (  CSV SNV ), Q = (  CSQ   SNQ )\n*        ( -SNU  CSU )      ( -SNV CSV )      ( -SNQ   CSQ )\n*\n*  Z' denotes the transpose of Z.\n*\n*\n\n*  Arguments\n*  =========\n*\n*  UPPER   (input) LOGICAL\n*          = .TRUE.: the input matrices A and B are upper triangular.\n*          = .FALSE.: the input matrices A and B are lower triangular.\n*\n*  A1      (input) REAL\n*  A2      (input) REAL\n*  A3      (input) REAL\n*          On entry, A1, A2 and A3 are elements of the input 2-by-2\n*          upper (lower) triangular matrix A.\n*\n*  B1      (input) REAL\n*  B2      (input) REAL\n*  B3      (input) REAL\n*          On entry, B1, B2 and B3 are elements of the input 2-by-2\n*          upper (lower) triangular matrix B.\n*\n*  CSU     (output) REAL\n*  SNU     (output) REAL\n*          The desired orthogonal matrix U.\n*\n*  CSV     (output) REAL\n*  SNV     (output) REAL\n*          The desired orthogonal matrix V.\n*\n*  CSQ     (output) REAL\n*  SNQ     (output) REAL\n*          The desired orthogonal matrix Q.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  csu, snu, csv, snv, csq, snq = NumRu::Lapack.slags2( upper, a1, a2, a3, b1, b2, b3, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_upper = argv[0];
  rblapack_a1 = argv[1];
  rblapack_a2 = argv[2];
  rblapack_a3 = argv[3];
  rblapack_b1 = argv[4];
  rblapack_b2 = argv[5];
  rblapack_b3 = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  upper = (rblapack_upper == Qtrue);
  a2 = (real)NUM2DBL(rblapack_a2);
  b1 = (real)NUM2DBL(rblapack_b1);
  b3 = (real)NUM2DBL(rblapack_b3);
  a1 = (real)NUM2DBL(rblapack_a1);
  b2 = (real)NUM2DBL(rblapack_b2);
  a3 = (real)NUM2DBL(rblapack_a3);

  slags2_(&upper, &a1, &a2, &a3, &b1, &b2, &b3, &csu, &snu, &csv, &snv, &csq, &snq);

  rblapack_csu = rb_float_new((double)csu);
  rblapack_snu = rb_float_new((double)snu);
  rblapack_csv = rb_float_new((double)csv);
  rblapack_snv = rb_float_new((double)snv);
  rblapack_csq = rb_float_new((double)csq);
  rblapack_snq = rb_float_new((double)snq);
  return rb_ary_new3(6, rblapack_csu, rblapack_snu, rblapack_csv, rblapack_snv, rblapack_csq, rblapack_snq);
}

void
init_lapack_slags2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slags2", rblapack_slags2, -1);
}
ruby-lapack-1.7.2/ext/zunglq.c0000644000175000017500000001257512502221024016053 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zunglq_(integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zunglq(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;

  integer lda;
  integer n;
  integer k;

  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 = NumRu::Lapack.zunglq( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZUNGLQ generates an M-by-N complex matrix Q with orthonormal rows,\n*  which is defined as the first M rows of a product of K elementary\n*  reflectors of order N\n*\n*        Q  =  H(k)' . . . H(2)' H(1)'\n*\n*  as returned by ZGELQF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. N >= M.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. M >= K >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the i-th row must contain the vector which defines\n*          the elementary reflector H(i), for i = 1,2,...,k, as returned\n*          by ZGELQF in the first k rows of its array argument A.\n*          On exit, the M-by-N matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) COMPLEX*16 array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by ZGELQF.\n*\n*  WORK    (workspace/output) COMPLEX*16 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\n*          the 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 has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, a = NumRu::Lapack.zunglq( m, a, tau, [: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_m = argv[0];
  rblapack_a = argv[1];
  rblapack_tau = 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;
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (rblapack_lwork == Qnil)
    lwork = m;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zunglq_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_zunglq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zunglq", rblapack_zunglq, -1);
}
ruby-lapack-1.7.2/ext/cgesvxx.c0000644000175000017500000007160212502221017016220 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgesvxx_(char* fact, char* trans, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, char* equed, real* r, real* c, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* rpvgrw, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cgesvxx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_r;
  real *r; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_params;
  real *params; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_rpvgrw;
  real rpvgrw; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_err_bnds_norm;
  real *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  real *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_af_out__;
  complex *af_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  VALUE rblapack_r_out__;
  real *r_out__;
  VALUE rblapack_c_out__;
  real *c_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;
  VALUE rblapack_params_out__;
  real *params_out__;
  complex *work;
  real *rwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer nparams;
  integer ldx;
  integer n_err_bnds;

  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  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, r, c, b, params = NumRu::Lapack.cgesvxx( fact, trans, a, af, ipiv, equed, r, c, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     CGESVXX uses the LU factorization to compute the solution to a\n*     complex system of linear equations  A * X = B,  where A is an\n*     N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n*     If requested, both normwise and maximum componentwise error bounds\n*     are returned. CGESVXX will return a solution with a tiny\n*     guaranteed error (O(eps) where eps is the working machine\n*     precision) unless the matrix is very ill-conditioned, in which\n*     case a warning is returned. Relevant condition numbers also are\n*     calculated and returned.\n*\n*     CGESVXX accepts user-provided factorizations and equilibration\n*     factors; see the definitions of the FACT and EQUED options.\n*     Solving with refinement and using a factorization from a previous\n*     CGESVXX call will also produce a solution with either O(eps)\n*     errors or warnings, but we cannot make that claim for general\n*     user-provided factorizations and equilibration factors if they\n*     differ from what CGESVXX would itself produce.\n*\n*     Description\n*     ===========\n*\n*     The following steps are performed:\n*\n*     1. If FACT = 'E', real scaling factors are computed to equilibrate\n*     the system:\n*\n*       TRANS = 'N':  diag(R)*A*diag(C)     *inv(diag(C))*X = diag(R)*B\n*       TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n*       TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n*     or diag(C)*B (if TRANS = 'T' or 'C').\n*\n*     2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n*     the matrix A (after equilibration if FACT = 'E') as\n*\n*       A = P * L * U,\n*\n*     where P is a permutation matrix, L is a unit lower triangular\n*     matrix, and U is upper triangular.\n*\n*     3. If some U(i,i)=0, so that U is exactly singular, then the\n*     routine returns with INFO = i. Otherwise, the factored form of A\n*     is used to estimate the condition number of the matrix A (see\n*     argument RCOND). If the reciprocal of the condition number is less\n*     than machine precision, the routine still goes on to solve for X\n*     and compute error bounds as described below.\n*\n*     4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*     5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n*     the routine will use iterative refinement to try to get a small\n*     error and error bounds.  Refinement calculates the residual to at\n*     least twice the working precision.\n*\n*     6. If equilibration was used, the matrix X is premultiplied by\n*     diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n*     that it solves the original system before equilibration.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     FACT    (input) CHARACTER*1\n*     Specifies whether or not the factored form of the matrix A is\n*     supplied on entry, and if not, whether the matrix A should be\n*     equilibrated before it is factored.\n*       = 'F':  On entry, AF and IPIV contain the factored form of A.\n*               If EQUED is not 'N', the matrix A has been\n*               equilibrated with scaling factors given by R and C.\n*               A, AF, and IPIV are not modified.\n*       = 'N':  The matrix A will be copied to AF and factored.\n*       = 'E':  The matrix A will be equilibrated if necessary, then\n*               copied to AF and factored.\n*\n*     TRANS   (input) CHARACTER*1\n*     Specifies the form of the system of equations:\n*       = 'N':  A * X = B     (No transpose)\n*       = 'T':  A**T * X = B  (Transpose)\n*       = 'C':  A**H * X = B  (Conjugate Transpose)\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     A       (input/output) COMPLEX array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.  If FACT = 'F' and EQUED is\n*     not 'N', then A must have been equilibrated by the scaling\n*     factors in R and/or C.  A is not modified if FACT = 'F' or\n*     'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n*     On exit, if EQUED .ne. 'N', A is scaled as follows:\n*     EQUED = 'R':  A := diag(R) * A\n*     EQUED = 'C':  A := A * diag(C)\n*     EQUED = 'B':  A := diag(R) * A * diag(C).\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input or output) COMPLEX array, dimension (LDAF,N)\n*     If FACT = 'F', then AF is an input argument and on entry\n*     contains the factors L and U from the factorization\n*     A = P*L*U as computed by CGETRF.  If EQUED .ne. 'N', then\n*     AF is the factored form of the equilibrated matrix A.\n*\n*     If FACT = 'N', then AF is an output argument and on exit\n*     returns the factors L and U from the factorization A = P*L*U\n*     of the original matrix A.\n*\n*     If FACT = 'E', then AF is an output argument and on exit\n*     returns the factors L and U from the factorization A = P*L*U\n*     of the equilibrated matrix A (see the description of A for\n*     the form of the equilibrated matrix).\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input or output) INTEGER array, dimension (N)\n*     If FACT = 'F', then IPIV is an input argument and on entry\n*     contains the pivot indices from the factorization A = P*L*U\n*     as computed by CGETRF; row i of the matrix was interchanged\n*     with row IPIV(i).\n*\n*     If FACT = 'N', then IPIV is an output argument and on exit\n*     contains the pivot indices from the factorization A = P*L*U\n*     of the original matrix A.\n*\n*     If FACT = 'E', then IPIV is an output argument and on exit\n*     contains the pivot indices from the factorization A = P*L*U\n*     of the equilibrated matrix A.\n*\n*     EQUED   (input or output) CHARACTER*1\n*     Specifies the form of equilibration that was done.\n*       = 'N':  No equilibration (always true if FACT = 'N').\n*       = 'R':  Row equilibration, i.e., A has been premultiplied by\n*               diag(R).\n*       = 'C':  Column equilibration, i.e., A has been postmultiplied\n*               by diag(C).\n*       = 'B':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(R) * A * diag(C).\n*     EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*     output argument.\n*\n*     R       (input or output) REAL array, dimension (N)\n*     The row scale factors for A.  If EQUED = 'R' or 'B', A is\n*     multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n*     is not accessed.  R is an input argument if FACT = 'F';\n*     otherwise, R is an output argument.  If FACT = 'F' and\n*     EQUED = 'R' or 'B', each element of R must be positive.\n*     If R is output, each element of R is a power of the radix.\n*     If R is input, each element of R should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     C       (input or output) REAL array, dimension (N)\n*     The column scale factors for A.  If EQUED = 'C' or 'B', A is\n*     multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n*     is not accessed.  C is an input argument if FACT = 'F';\n*     otherwise, C is an output argument.  If FACT = 'F' and\n*     EQUED = 'C' or 'B', each element of C must be positive.\n*     If C is output, each element of C is a power of the radix.\n*     If C is input, each element of C should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*     On entry, the N-by-NRHS right hand side matrix B.\n*     On exit,\n*     if EQUED = 'N', B is not modified;\n*     if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n*        diag(R)*B;\n*     if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n*        overwritten by diag(C)*B.\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (output) COMPLEX array, dimension (LDX,NRHS)\n*     If INFO = 0, the N-by-NRHS solution matrix X to the original\n*     system of equations.  Note that A and B are modified on exit\n*     if EQUED .ne. 'N', and the solution to the equilibrated system is\n*     inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n*     inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) REAL\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     RPVGRW  (output) REAL\n*     Reciprocal pivot growth.  On exit, this contains the reciprocal\n*     pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n*     norm is used.  If this is much less than 1, then the stability of\n*     the LU factorization of the (equilibrated) matrix A could be poor.\n*     This also means that the solution X, estimated condition numbers,\n*     and error bounds could be unreliable. If factorization fails with\n*     0 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, r, c, b, params = NumRu::Lapack.cgesvxx( fact, trans, a, af, ipiv, equed, r, c, b, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_fact = argv[0];
  rblapack_trans = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_equed = argv[5];
  rblapack_r = argv[6];
  rblapack_c = argv[7];
  rblapack_b = argv[8];
  rblapack_params = argv[9];
  if (argc == 10) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_r))
    rb_raise(rb_eArgError, "r (7th argument) must be NArray");
  if (NA_RANK(rblapack_r) != 1)
    rb_raise(rb_eArgError, "rank of r (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_r) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_r) != NA_SFLOAT)
    rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
  r = NA_PTR_TYPE(rblapack_r, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (9th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (9th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  n_err_bnds = 3;
  trans = StringValueCStr(rblapack_trans)[0];
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (10th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (10th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_SFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
  params = NA_PTR_TYPE(rblapack_params, real*);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (8th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  ldx = n;
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldaf;
    shape[1] = n;
    rblapack_af_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  af_out__ = NA_PTR_TYPE(rblapack_af_out__, complex*);
  MEMCPY(af_out__, af, complex, NA_TOTAL(rblapack_af));
  rblapack_af = rblapack_af_out__;
  af = af_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_r_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  r_out__ = NA_PTR_TYPE(rblapack_r_out__, real*);
  MEMCPY(r_out__, r, real, NA_TOTAL(rblapack_r));
  rblapack_r = rblapack_r_out__;
  r = r_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
  MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (2*n));

  cgesvxx_(&fact, &trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_rpvgrw = rb_float_new((double)rpvgrw);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(15, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_a, rblapack_af, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b, rblapack_params);
}

void
init_lapack_cgesvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgesvxx", rblapack_cgesvxx, -1);
}
ruby-lapack-1.7.2/ext/sgecon.c0000644000175000017500000000765312502221026016014 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgecon_(char* norm, integer* n, real* a, integer* lda, real* anorm, real* rcond, real* work, integer* iwork, integer* info);


static VALUE
rblapack_sgecon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_anorm;
  real anorm; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_info;
  integer info; 
  real *work;
  integer *iwork;

  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  rcond, info = NumRu::Lapack.sgecon( norm, a, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGECON estimates the reciprocal of the condition number of a general\n*  real matrix A, in either the 1-norm or the infinity-norm, using\n*  the LU factorization computed by SGETRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as\n*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies whether the 1-norm condition number or the\n*          infinity-norm condition number is required:\n*          = '1' or 'O':  1-norm;\n*          = 'I':         Infinity-norm.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) REAL array, dimension (LDA,N)\n*          The factors L and U from the factorization A = P*L*U\n*          as computed by SGETRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  ANORM   (input) REAL\n*          If NORM = '1' or 'O', the 1-norm of the original matrix A.\n*          If NORM = 'I', the infinity-norm of the original matrix A.\n*\n*  RCOND   (output) REAL\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(norm(A) * norm(inv(A))).\n*\n*  WORK    (workspace) REAL array, dimension (4*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.sgecon( norm, a, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_norm = argv[0];
  rblapack_a = argv[1];
  rblapack_anorm = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  anorm = (real)NUM2DBL(rblapack_anorm);
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  work = ALLOC_N(real, (4*n));
  iwork = ALLOC_N(integer, (n));

  sgecon_(&norm, &n, a, &lda, &anorm, &rcond, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_sgecon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgecon", rblapack_sgecon, -1);
}
ruby-lapack-1.7.2/ext/zhsein.c0000644000175000017500000003016312502221017016026 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhsein_(char* side, char* eigsrc, char* initv, logical* select, integer* n, doublecomplex* h, integer* ldh, doublecomplex* w, doublecomplex* vl, integer* ldvl, doublecomplex* vr, integer* ldvr, integer* mm, integer* m, doublecomplex* work, doublereal* rwork, integer* ifaill, integer* ifailr, integer* info);


static VALUE
rblapack_zhsein(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_eigsrc;
  char eigsrc; 
  VALUE rblapack_initv;
  char initv; 
  VALUE rblapack_select;
  logical *select; 
  VALUE rblapack_h;
  doublecomplex *h; 
  VALUE rblapack_w;
  doublecomplex *w; 
  VALUE rblapack_vl;
  doublecomplex *vl; 
  VALUE rblapack_vr;
  doublecomplex *vr; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_ifaill;
  integer *ifaill; 
  VALUE rblapack_ifailr;
  integer *ifailr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_w_out__;
  doublecomplex *w_out__;
  VALUE rblapack_vl_out__;
  doublecomplex *vl_out__;
  VALUE rblapack_vr_out__;
  doublecomplex *vr_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer n;
  integer ldh;
  integer ldvl;
  integer mm;
  integer ldvr;

  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  m, ifaill, ifailr, info, w, vl, vr = NumRu::Lapack.zhsein( side, eigsrc, initv, select, h, w, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, W, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, IFAILL, IFAILR, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHSEIN uses inverse iteration to find specified right and/or left\n*  eigenvectors of a complex upper Hessenberg matrix H.\n*\n*  The right eigenvector x and the left eigenvector y of the matrix H\n*  corresponding to an eigenvalue w are defined by:\n*\n*               H * x = w * x,     y**h * H = w * y**h\n*\n*  where y**h denotes the conjugate transpose of the vector y.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'R': compute right eigenvectors only;\n*          = 'L': compute left eigenvectors only;\n*          = 'B': compute both right and left eigenvectors.\n*\n*  EIGSRC  (input) CHARACTER*1\n*          Specifies the source of eigenvalues supplied in W:\n*          = 'Q': the eigenvalues were found using ZHSEQR; thus, if\n*                 H has zero subdiagonal elements, and so is\n*                 block-triangular, then the j-th eigenvalue can be\n*                 assumed to be an eigenvalue of the block containing\n*                 the j-th row/column.  This property allows ZHSEIN to\n*                 perform inverse iteration on just one diagonal block.\n*          = 'N': no assumptions are made on the correspondence\n*                 between eigenvalues and diagonal blocks.  In this\n*                 case, ZHSEIN must always perform inverse iteration\n*                 using the whole matrix H.\n*\n*  INITV   (input) CHARACTER*1\n*          = 'N': no initial vectors are supplied;\n*          = 'U': user-supplied initial vectors are stored in the arrays\n*                 VL and/or VR.\n*\n*  SELECT  (input) LOGICAL array, dimension (N)\n*          Specifies the eigenvectors to be computed. To select the\n*          eigenvector corresponding to the eigenvalue W(j),\n*          SELECT(j) must be set to .TRUE..\n*\n*  N       (input) INTEGER\n*          The order of the matrix H.  N >= 0.\n*\n*  H       (input) COMPLEX*16 array, dimension (LDH,N)\n*          The upper Hessenberg matrix H.\n*\n*  LDH     (input) INTEGER\n*          The leading dimension of the array H.  LDH >= max(1,N).\n*\n*  W       (input/output) COMPLEX*16 array, dimension (N)\n*          On entry, the eigenvalues of H.\n*          On exit, the real parts of W may have been altered since\n*          close eigenvalues are perturbed slightly in searching for\n*          independent eigenvectors.\n*\n*  VL      (input/output) COMPLEX*16 array, dimension (LDVL,MM)\n*          On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must\n*          contain starting vectors for the inverse iteration for the\n*          left eigenvectors; the starting vector for each eigenvector\n*          must be in the same column in which the eigenvector will be\n*          stored.\n*          On exit, if SIDE = 'L' or 'B', the left eigenvectors\n*          specified by SELECT will be stored consecutively in the\n*          columns of VL, in the same order as their eigenvalues.\n*          If SIDE = 'R', VL is not referenced.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the array VL.\n*          LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.\n*\n*  VR      (input/output) COMPLEX*16 array, dimension (LDVR,MM)\n*          On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must\n*          contain starting vectors for the inverse iteration for the\n*          right eigenvectors; the starting vector for each eigenvector\n*          must be in the same column in which the eigenvector will be\n*          stored.\n*          On exit, if SIDE = 'R' or 'B', the right eigenvectors\n*          specified by SELECT will be stored consecutively in the\n*          columns of VR, in the same order as their eigenvalues.\n*          If SIDE = 'L', VR is not referenced.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the array VR.\n*          LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.\n*\n*  MM      (input) INTEGER\n*          The number of columns in the arrays VL and/or VR. MM >= M.\n*\n*  M       (output) INTEGER\n*          The number of columns in the arrays VL and/or VR required to\n*          store the eigenvectors (= the number of .TRUE. elements in\n*          SELECT).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (N*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\n*\n*  IFAILL  (output) INTEGER array, dimension (MM)\n*          If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left\n*          eigenvector in the i-th column of VL (corresponding to the\n*          eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the\n*          eigenvector converged satisfactorily.\n*          If SIDE = 'R', IFAILL is not referenced.\n*\n*  IFAILR  (output) INTEGER array, dimension (MM)\n*          If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right\n*          eigenvector in the i-th column of VR (corresponding to the\n*          eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the\n*          eigenvector converged satisfactorily.\n*          If SIDE = 'L', IFAILR is not referenced.\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, i is the number of eigenvectors which\n*                failed to converge; see IFAILL and IFAILR for further\n*                details.\n*\n\n*  Further Details\n*  ===============\n*\n*  Each eigenvector is normalized so that the element of largest\n*  magnitude has magnitude 1; here the magnitude of a complex number\n*  (x,y) is taken to be |x|+|y|.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, ifaill, ifailr, info, w, vl, vr = NumRu::Lapack.zhsein( side, eigsrc, initv, select, h, w, vl, vr, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_side = argv[0];
  rblapack_eigsrc = argv[1];
  rblapack_initv = argv[2];
  rblapack_select = argv[3];
  rblapack_h = argv[4];
  rblapack_w = argv[5];
  rblapack_vl = argv[6];
  rblapack_vr = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  initv = StringValueCStr(rblapack_initv)[0];
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (5th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_DCOMPLEX)
    rblapack_h = na_change_type(rblapack_h, NA_DCOMPLEX);
  h = NA_PTR_TYPE(rblapack_h, doublecomplex*);
  if (!NA_IsNArray(rblapack_vl))
    rb_raise(rb_eArgError, "vl (7th argument) must be NArray");
  if (NA_RANK(rblapack_vl) != 2)
    rb_raise(rb_eArgError, "rank of vl (7th argument) must be %d", 2);
  ldvl = NA_SHAPE0(rblapack_vl);
  mm = NA_SHAPE1(rblapack_vl);
  if (NA_TYPE(rblapack_vl) != NA_DCOMPLEX)
    rblapack_vl = na_change_type(rblapack_vl, NA_DCOMPLEX);
  vl = NA_PTR_TYPE(rblapack_vl, doublecomplex*);
  eigsrc = StringValueCStr(rblapack_eigsrc)[0];
  if (!NA_IsNArray(rblapack_w))
    rb_raise(rb_eArgError, "w (6th argument) must be NArray");
  if (NA_RANK(rblapack_w) != 1)
    rb_raise(rb_eArgError, "rank of w (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_w) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 1 of h");
  if (NA_TYPE(rblapack_w) != NA_DCOMPLEX)
    rblapack_w = na_change_type(rblapack_w, NA_DCOMPLEX);
  w = NA_PTR_TYPE(rblapack_w, doublecomplex*);
  if (!NA_IsNArray(rblapack_select))
    rb_raise(rb_eArgError, "select (4th argument) must be NArray");
  if (NA_RANK(rblapack_select) != 1)
    rb_raise(rb_eArgError, "rank of select (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_select) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of h");
  if (NA_TYPE(rblapack_select) != NA_LINT)
    rblapack_select = na_change_type(rblapack_select, NA_LINT);
  select = NA_PTR_TYPE(rblapack_select, logical*);
  if (!NA_IsNArray(rblapack_vr))
    rb_raise(rb_eArgError, "vr (8th argument) must be NArray");
  if (NA_RANK(rblapack_vr) != 2)
    rb_raise(rb_eArgError, "rank of vr (8th argument) must be %d", 2);
  ldvr = NA_SHAPE0(rblapack_vr);
  if (NA_SHAPE1(rblapack_vr) != mm)
    rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
  if (NA_TYPE(rblapack_vr) != NA_DCOMPLEX)
    rblapack_vr = na_change_type(rblapack_vr, NA_DCOMPLEX);
  vr = NA_PTR_TYPE(rblapack_vr, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = mm;
    rblapack_ifaill = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifaill = NA_PTR_TYPE(rblapack_ifaill, integer*);
  {
    na_shape_t shape[1];
    shape[0] = mm;
    rblapack_ifailr = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifailr = NA_PTR_TYPE(rblapack_ifailr, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  w_out__ = NA_PTR_TYPE(rblapack_w_out__, doublecomplex*);
  MEMCPY(w_out__, w, doublecomplex, NA_TOTAL(rblapack_w));
  rblapack_w = rblapack_w_out__;
  w = w_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = mm;
    rblapack_vl_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, doublecomplex*);
  MEMCPY(vl_out__, vl, doublecomplex, NA_TOTAL(rblapack_vl));
  rblapack_vl = rblapack_vl_out__;
  vl = vl_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = mm;
    rblapack_vr_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  vr_out__ = NA_PTR_TYPE(rblapack_vr_out__, doublecomplex*);
  MEMCPY(vr_out__, vr, doublecomplex, NA_TOTAL(rblapack_vr));
  rblapack_vr = rblapack_vr_out__;
  vr = vr_out__;
  work = ALLOC_N(doublecomplex, (n*n));
  rwork = ALLOC_N(doublereal, (n));

  zhsein_(&side, &eigsrc, &initv, select, &n, h, &ldh, w, vl, &ldvl, vr, &ldvr, &mm, &m, work, rwork, ifaill, ifailr, &info);

  free(work);
  free(rwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_m, rblapack_ifaill, rblapack_ifailr, rblapack_info, rblapack_w, rblapack_vl, rblapack_vr);
}

void
init_lapack_zhsein(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhsein", rblapack_zhsein, -1);
}
ruby-lapack-1.7.2/ext/dposv.c0000644000175000017500000001351212502221026015660 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dposv_(char* uplo, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* b, integer* ldb, integer* info);


static VALUE
rblapack_dposv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, a, b = NumRu::Lapack.dposv( uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPOSV computes the solution to a real system of linear equations\n*     A * X = B,\n*  where A is an N-by-N symmetric positive definite matrix and X and B\n*  are N-by-NRHS matrices.\n*\n*  The Cholesky decomposition is used to factor A as\n*     A = U**T* U,  if UPLO = 'U', or\n*     A = L * L**T,  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is a lower triangular\n*  matrix.  The factored form of A is then used to solve the system of\n*  equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the factor U or L from the Cholesky\n*          factorization A = U**T*U or A = L*L**T.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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 leading minor of order i of A is not\n*                positive definite, so the factorization could not be\n*                completed, and the solution has not been computed.\n*\n\n*  =====================================================================\n*\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DPOTRF, DPOTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a, b = NumRu::Lapack.dposv( uplo, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_b = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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);
  ldb = NA_SHAPE0(rblapack_b);
  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 (!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*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dposv_(&uplo, &n, &nrhs, a, &lda, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_dposv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dposv", rblapack_dposv, -1);
}
ruby-lapack-1.7.2/ext/dlamrg.c0000644000175000017500000000731012502221023015767 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlamrg_(integer* n1, integer* n2, doublereal* a, integer* dtrd1, integer* dtrd2, integer* index);


static VALUE
rblapack_dlamrg(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n1;
  integer n1; 
  VALUE rblapack_n2;
  integer n2; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_dtrd1;
  integer dtrd1; 
  VALUE rblapack_dtrd2;
  integer dtrd2; 
  VALUE rblapack_index;
  integer *index; 


  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  index = NumRu::Lapack.dlamrg( n1, n2, a, dtrd1, dtrd2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX )\n\n*  Purpose\n*  =======\n*\n*  DLAMRG will create a permutation list which will merge the elements\n*  of A (which is composed of two independently sorted sets) into a\n*  single set which is sorted in ascending order.\n*\n\n*  Arguments\n*  =========\n*\n*  N1     (input) INTEGER\n*  N2     (input) INTEGER\n*         These arguements contain the respective lengths of the two\n*         sorted lists to be merged.\n*\n*  A      (input) DOUBLE PRECISION array, dimension (N1+N2)\n*         The first N1 elements of A contain a list of numbers which\n*         are sorted in either ascending or descending order.  Likewise\n*         for the final N2 elements.\n*\n*  DTRD1  (input) INTEGER\n*  DTRD2  (input) INTEGER\n*         These are the strides to be taken through the array A.\n*         Allowable strides are 1 and -1.  They indicate whether a\n*         subset of A is sorted in ascending (DTRDx = 1) or descending\n*         (DTRDx = -1) order.\n*\n*  INDEX  (output) INTEGER array, dimension (N1+N2)\n*         On exit this array will contain a permutation such that\n*         if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be\n*         sorted in ascending order.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, IND1, IND2, N1SV, N2SV\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  index = NumRu::Lapack.dlamrg( n1, n2, a, dtrd1, dtrd2, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_n1 = argv[0];
  rblapack_n2 = argv[1];
  rblapack_a = argv[2];
  rblapack_dtrd1 = argv[3];
  rblapack_dtrd2 = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n1 = NUM2INT(rblapack_n1);
  dtrd1 = NUM2INT(rblapack_dtrd1);
  n2 = NUM2INT(rblapack_n2);
  dtrd2 = NUM2INT(rblapack_dtrd2);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 1)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_a) != (n1+n2))
    rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n1+n2);
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n1+n2;
    rblapack_index = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  index = NA_PTR_TYPE(rblapack_index, integer*);

  dlamrg_(&n1, &n2, a, &dtrd1, &dtrd2, index);

  return rblapack_index;
}

void
init_lapack_dlamrg(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlamrg", rblapack_dlamrg, -1);
}
ruby-lapack-1.7.2/ext/slasy2.c0000644000175000017500000001540412502221026015744 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slasy2_(logical* ltranl, logical* ltranr, integer* isgn, integer* n1, integer* n2, real* tl, integer* ldtl, real* tr, integer* ldtr, real* b, integer* ldb, real* scale, real* x, integer* ldx, real* xnorm, integer* info);


static VALUE
rblapack_slasy2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ltranl;
  logical ltranl; 
  VALUE rblapack_ltranr;
  logical ltranr; 
  VALUE rblapack_isgn;
  integer isgn; 
  VALUE rblapack_n1;
  integer n1; 
  VALUE rblapack_n2;
  integer n2; 
  VALUE rblapack_tl;
  real *tl; 
  VALUE rblapack_tr;
  real *tr; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_scale;
  real scale; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_xnorm;
  real xnorm; 
  VALUE rblapack_info;
  integer info; 

  integer ldtl;
  integer ldtr;
  integer ldb;
  integer ldx;

  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  scale, x, xnorm, info = NumRu::Lapack.slasy2( ltranl, ltranr, isgn, n1, n2, tl, tr, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in\n*\n*         op(TL)*X + ISGN*X*op(TR) = SCALE*B,\n*\n*  where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or\n*  -1.  op(T) = T or T', where T' denotes the transpose of T.\n*\n\n*  Arguments\n*  =========\n*\n*  LTRANL  (input) LOGICAL\n*          On entry, LTRANL specifies the op(TL):\n*             = .FALSE., op(TL) = TL,\n*             = .TRUE., op(TL) = TL'.\n*\n*  LTRANR  (input) LOGICAL\n*          On entry, LTRANR specifies the op(TR):\n*            = .FALSE., op(TR) = TR,\n*            = .TRUE., op(TR) = TR'.\n*\n*  ISGN    (input) INTEGER\n*          On entry, ISGN specifies the sign of the equation\n*          as described before. ISGN may only be 1 or -1.\n*\n*  N1      (input) INTEGER\n*          On entry, N1 specifies the order of matrix TL.\n*          N1 may only be 0, 1 or 2.\n*\n*  N2      (input) INTEGER\n*          On entry, N2 specifies the order of matrix TR.\n*          N2 may only be 0, 1 or 2.\n*\n*  TL      (input) REAL array, dimension (LDTL,2)\n*          On entry, TL contains an N1 by N1 matrix.\n*\n*  LDTL    (input) INTEGER\n*          The leading dimension of the matrix TL. LDTL >= max(1,N1).\n*\n*  TR      (input) REAL array, dimension (LDTR,2)\n*          On entry, TR contains an N2 by N2 matrix.\n*\n*  LDTR    (input) INTEGER\n*          The leading dimension of the matrix TR. LDTR >= max(1,N2).\n*\n*  B       (input) REAL array, dimension (LDB,2)\n*          On entry, the N1 by N2 matrix B contains the right-hand\n*          side of the equation.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the matrix B. LDB >= max(1,N1).\n*\n*  SCALE   (output) REAL\n*          On exit, SCALE contains the scale factor. SCALE is chosen\n*          less than or equal to 1 to prevent the solution overflowing.\n*\n*  X       (output) REAL array, dimension (LDX,2)\n*          On exit, X contains the N1 by N2 solution.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the matrix X. LDX >= max(1,N1).\n*\n*  XNORM   (output) REAL\n*          On exit, XNORM is the infinity-norm of the solution.\n*\n*  INFO    (output) INTEGER\n*          On exit, INFO is set to\n*             0: successful exit.\n*             1: TL and TR have too close eigenvalues, so TL or\n*                TR is perturbed to get a nonsingular equation.\n*          NOTE: In the interests of speed, this routine does not\n*                check the inputs for errors.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, x, xnorm, info = NumRu::Lapack.slasy2( ltranl, ltranr, isgn, n1, n2, tl, tr, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_ltranl = argv[0];
  rblapack_ltranr = argv[1];
  rblapack_isgn = argv[2];
  rblapack_n1 = argv[3];
  rblapack_n2 = argv[4];
  rblapack_tl = argv[5];
  rblapack_tr = argv[6];
  rblapack_b = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  ltranl = (rblapack_ltranl == Qtrue);
  isgn = NUM2INT(rblapack_isgn);
  n2 = NUM2INT(rblapack_n2);
  if (!NA_IsNArray(rblapack_tr))
    rb_raise(rb_eArgError, "tr (7th argument) must be NArray");
  if (NA_RANK(rblapack_tr) != 2)
    rb_raise(rb_eArgError, "rank of tr (7th argument) must be %d", 2);
  ldtr = NA_SHAPE0(rblapack_tr);
  if (NA_SHAPE1(rblapack_tr) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of tr must be %d", 2);
  if (NA_TYPE(rblapack_tr) != NA_SFLOAT)
    rblapack_tr = na_change_type(rblapack_tr, NA_SFLOAT);
  tr = NA_PTR_TYPE(rblapack_tr, real*);
  ltranr = (rblapack_ltranr == Qtrue);
  if (!NA_IsNArray(rblapack_tl))
    rb_raise(rb_eArgError, "tl (6th argument) must be NArray");
  if (NA_RANK(rblapack_tl) != 2)
    rb_raise(rb_eArgError, "rank of tl (6th argument) must be %d", 2);
  ldtl = NA_SHAPE0(rblapack_tl);
  if (NA_SHAPE1(rblapack_tl) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of tl must be %d", 2);
  if (NA_TYPE(rblapack_tl) != NA_SFLOAT)
    rblapack_tl = na_change_type(rblapack_tl, NA_SFLOAT);
  tl = NA_PTR_TYPE(rblapack_tl, real*);
  n1 = NUM2INT(rblapack_n1);
  ldx = MAX(1,n1);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of b must be %d", 2);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = 2;
    rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, real*);

  slasy2_(<ranl, <ranr, &isgn, &n1, &n2, tl, &ldtl, tr, &ldtr, b, &ldb, &scale, x, &ldx, &xnorm, &info);

  rblapack_scale = rb_float_new((double)scale);
  rblapack_xnorm = rb_float_new((double)xnorm);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_scale, rblapack_x, rblapack_xnorm, rblapack_info);
}

void
init_lapack_slasy2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slasy2", rblapack_slasy2, -1);
}
ruby-lapack-1.7.2/ext/sgtsvx.c0000644000175000017500000004075312502221026016072 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgtsvx_(char* fact, char* trans, integer* n, integer* nrhs, real* dl, real* d, real* du, real* dlf, real* df, real* duf, real* du2, integer* ipiv, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* ferr, real* berr, real* work, integer* iwork, integer* info);


static VALUE
rblapack_sgtsvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_dl;
  real *dl; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_du;
  real *du; 
  VALUE rblapack_dlf;
  real *dlf; 
  VALUE rblapack_df;
  real *df; 
  VALUE rblapack_duf;
  real *duf; 
  VALUE rblapack_du2;
  real *du2; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_dlf_out__;
  real *dlf_out__;
  VALUE rblapack_df_out__;
  real *df_out__;
  VALUE rblapack_duf_out__;
  real *duf_out__;
  VALUE rblapack_du2_out__;
  real *du2_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  real *work;
  integer *iwork;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, info, dlf, df, duf, du2, ipiv = NumRu::Lapack.sgtsvx( fact, trans, dl, d, du, dlf, df, duf, du2, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGTSVX uses the LU factorization to compute the solution to a real\n*  system of linear equations A * X = B or A**T * X = B,\n*  where A is a tridiagonal matrix of order N and X and B are N-by-NRHS\n*  matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'N', the LU decomposition is used to factor the matrix A\n*     as A = L * U, where L is a product of permutation and unit lower\n*     bidiagonal matrices and U is upper triangular with nonzeros in\n*     only the main diagonal and first two superdiagonals.\n*\n*  2. If some U(i,i)=0, so that U is exactly singular, then the routine\n*     returns with INFO = i. Otherwise, the factored form of A is used\n*     to estimate the condition number of the matrix A.  If the\n*     reciprocal of the condition number is less than machine precision,\n*     INFO = N+1 is returned as a warning, but the routine still goes on\n*     to solve for X and compute error bounds as described below.\n*\n*  3. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  4. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of A has been\n*          supplied on entry.\n*          = 'F':  DLF, DF, DUF, DU2, and IPIV contain the factored\n*                  form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV\n*                  will not be modified.\n*          = 'N':  The matrix will be copied to DLF, DF, and DUF\n*                  and factored.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  DL      (input) REAL array, dimension (N-1)\n*          The (n-1) subdiagonal elements of A.\n*\n*  D       (input) REAL array, dimension (N)\n*          The n diagonal elements of A.\n*\n*  DU      (input) REAL array, dimension (N-1)\n*          The (n-1) superdiagonal elements of A.\n*\n*  DLF     (input or output) REAL array, dimension (N-1)\n*          If FACT = 'F', then DLF is an input argument and on entry\n*          contains the (n-1) multipliers that define the matrix L from\n*          the LU factorization of A as computed by SGTTRF.\n*\n*          If FACT = 'N', then DLF is an output argument and on exit\n*          contains the (n-1) multipliers that define the matrix L from\n*          the LU factorization of A.\n*\n*  DF      (input or output) REAL array, dimension (N)\n*          If FACT = 'F', then DF is an input argument and on entry\n*          contains the n diagonal elements of the upper triangular\n*          matrix U from the LU factorization of A.\n*\n*          If FACT = 'N', then DF is an output argument and on exit\n*          contains the n diagonal elements of the upper triangular\n*          matrix U from the LU factorization of A.\n*\n*  DUF     (input or output) REAL array, dimension (N-1)\n*          If FACT = 'F', then DUF is an input argument and on entry\n*          contains the (n-1) elements of the first superdiagonal of U.\n*\n*          If FACT = 'N', then DUF is an output argument and on exit\n*          contains the (n-1) elements of the first superdiagonal of U.\n*\n*  DU2     (input or output) REAL array, dimension (N-2)\n*          If FACT = 'F', then DU2 is an input argument and on entry\n*          contains the (n-2) elements of the second superdiagonal of\n*          U.\n*\n*          If FACT = 'N', then DU2 is an output argument and on exit\n*          contains the (n-2) elements of the second superdiagonal of\n*          U.\n*\n*  IPIV    (input or output) INTEGER array, dimension (N)\n*          If FACT = 'F', then IPIV is an input argument and on entry\n*          contains the pivot indices from the LU factorization of A as\n*          computed by SGTTRF.\n*\n*          If FACT = 'N', then IPIV is an output argument and on exit\n*          contains the pivot indices from the LU factorization of A;\n*          row i of the matrix was interchanged with row IPIV(i).\n*          IPIV(i) will always be either i or i+1; IPIV(i) = i indicates\n*          a row interchange was not required.\n*\n*  B       (input) REAL array, dimension (LDB,NRHS)\n*          The N-by-NRHS right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) REAL array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) REAL\n*          The estimate of the reciprocal condition number of the matrix\n*          A.  If RCOND is less than the machine precision (in\n*          particular, if RCOND = 0), the matrix is singular to working\n*          precision.  This condition is indicated by a return code of\n*          INFO > 0.\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) REAL array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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, and i is\n*                <= N:  U(i,i) is exactly zero.  The factorization\n*                       has not been completed unless i = N, but the\n*                       factor U is exactly singular, so the solution\n*                       and error bounds could not be computed.\n*                       RCOND = 0 is returned.\n*                = N+1: U is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, info, dlf, df, duf, du2, ipiv = NumRu::Lapack.sgtsvx( fact, trans, dl, d, du, dlf, df, duf, du2, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 11 && argc != 11)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
  rblapack_fact = argv[0];
  rblapack_trans = argv[1];
  rblapack_dl = argv[2];
  rblapack_d = argv[3];
  rblapack_du = argv[4];
  rblapack_dlf = argv[5];
  rblapack_df = argv[6];
  rblapack_duf = argv[7];
  rblapack_du2 = argv[8];
  rblapack_ipiv = argv[9];
  rblapack_b = argv[10];
  if (argc == 11) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_df))
    rb_raise(rb_eArgError, "df (7th argument) must be NArray");
  if (NA_RANK(rblapack_df) != 1)
    rb_raise(rb_eArgError, "rank of df (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_df) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of df must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_df) != NA_SFLOAT)
    rblapack_df = na_change_type(rblapack_df, NA_SFLOAT);
  df = NA_PTR_TYPE(rblapack_df, real*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (10th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (10th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  ldx = MAX(1,n);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (5th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_SFLOAT)
    rblapack_du = na_change_type(rblapack_du, NA_SFLOAT);
  du = NA_PTR_TYPE(rblapack_du, real*);
  if (!NA_IsNArray(rblapack_duf))
    rb_raise(rb_eArgError, "duf (8th argument) must be NArray");
  if (NA_RANK(rblapack_duf) != 1)
    rb_raise(rb_eArgError, "rank of duf (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_duf) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of duf must be %d", n-1);
  if (NA_TYPE(rblapack_duf) != NA_SFLOAT)
    rblapack_duf = na_change_type(rblapack_duf, NA_SFLOAT);
  duf = NA_PTR_TYPE(rblapack_duf, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (11th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (11th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (3th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_SFLOAT)
    rblapack_dl = na_change_type(rblapack_dl, NA_SFLOAT);
  dl = NA_PTR_TYPE(rblapack_dl, real*);
  if (!NA_IsNArray(rblapack_du2))
    rb_raise(rb_eArgError, "du2 (9th argument) must be NArray");
  if (NA_RANK(rblapack_du2) != 1)
    rb_raise(rb_eArgError, "rank of du2 (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du2) != (n-2))
    rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
  if (NA_TYPE(rblapack_du2) != NA_SFLOAT)
    rblapack_du2 = na_change_type(rblapack_du2, NA_SFLOAT);
  du2 = NA_PTR_TYPE(rblapack_du2, real*);
  if (!NA_IsNArray(rblapack_dlf))
    rb_raise(rb_eArgError, "dlf (6th argument) must be NArray");
  if (NA_RANK(rblapack_dlf) != 1)
    rb_raise(rb_eArgError, "rank of dlf (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dlf) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dlf must be %d", n-1);
  if (NA_TYPE(rblapack_dlf) != NA_SFLOAT)
    rblapack_dlf = na_change_type(rblapack_dlf, NA_SFLOAT);
  dlf = NA_PTR_TYPE(rblapack_dlf, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_dlf_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  dlf_out__ = NA_PTR_TYPE(rblapack_dlf_out__, real*);
  MEMCPY(dlf_out__, dlf, real, NA_TOTAL(rblapack_dlf));
  rblapack_dlf = rblapack_dlf_out__;
  dlf = dlf_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_df_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  df_out__ = NA_PTR_TYPE(rblapack_df_out__, real*);
  MEMCPY(df_out__, df, real, NA_TOTAL(rblapack_df));
  rblapack_df = rblapack_df_out__;
  df = df_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_duf_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  duf_out__ = NA_PTR_TYPE(rblapack_duf_out__, real*);
  MEMCPY(duf_out__, duf, real, NA_TOTAL(rblapack_duf));
  rblapack_duf = rblapack_duf_out__;
  duf = duf_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-2;
    rblapack_du2_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  du2_out__ = NA_PTR_TYPE(rblapack_du2_out__, real*);
  MEMCPY(du2_out__, du2, real, NA_TOTAL(rblapack_du2));
  rblapack_du2 = rblapack_du2_out__;
  du2 = du2_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  work = ALLOC_N(real, (3*n));
  iwork = ALLOC_N(integer, (n));

  sgtsvx_(&fact, &trans, &n, &nrhs, dl, d, du, dlf, df, duf, du2, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_dlf, rblapack_df, rblapack_duf, rblapack_du2, rblapack_ipiv);
}

void
init_lapack_sgtsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgtsvx", rblapack_sgtsvx, -1);
}
ruby-lapack-1.7.2/ext/iladiag.c0000644000175000017500000000372012502221020016111 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern integer iladiag_(char* diag);


static VALUE
rblapack_iladiag(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack___out__;
  integer __out__; 


  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  __out__ = NumRu::Lapack.iladiag( diag, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      INTEGER FUNCTION ILADIAG( DIAG )\n\n*  Purpose\n*  =======\n*\n*  This subroutine translated from a character string specifying if a\n*  matrix has unit diagonal or not to the relevant BLAST-specified\n*  integer constant.\n*\n*  ILADIAG returns an INTEGER.  If ILADIAG < 0, then the input is not a\n*  character indicating a unit or non-unit diagonal.  Otherwise ILADIAG\n*  returns the constant value corresponding to DIAG.\n*\n\n*  Arguments\n*  =========\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.iladiag( diag, [: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_diag = argv[0];
  if (argc == 1) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  diag = StringValueCStr(rblapack_diag)[0];

  __out__ = iladiag_(&diag);

  rblapack___out__ = INT2NUM(__out__);
  return rblapack___out__;
}

void
init_lapack_iladiag(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "iladiag", rblapack_iladiag, -1);
}
ruby-lapack-1.7.2/ext/chesv.c0000644000175000017500000002003112502221014015624 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chesv_(char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, integer* ipiv, complex* b, integer* ldb, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_chesv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  ipiv, work, info, a, b = NumRu::Lapack.chesv( uplo, a, b, lwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHESV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHESV computes the solution to a complex system of linear equations\n*     A * X = B,\n*  where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS\n*  matrices.\n*\n*  The diagonal pivoting method is used to factor A as\n*     A = U * D * U**H,  if UPLO = 'U', or\n*     A = L * D * L**H,  if UPLO = 'L',\n*  where U (or L) is a product of permutation and unit upper (lower)\n*  triangular matrices, and D is Hermitian and block diagonal with \n*  1-by-1 and 2-by-2 diagonal blocks.  The factored form of A is then\n*  used to solve the system of equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the block diagonal matrix D and the\n*          multipliers used to obtain the factor U or L from the\n*          factorization A = U*D*U**H or A = L*D*L**H as computed by\n*          CHETRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D, as\n*          determined by CHETRF.  If IPIV(k) > 0, then rows and columns\n*          k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n*          diagonal block.  If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n*          then rows and columns k-1 and -IPIV(k) were interchanged and\n*          D(k-1:k,k-1:k) is a 2-by-2 diagonal block.  If UPLO = 'L' and\n*          IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n*          -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n*          diagonal block.\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  WORK    (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of WORK.  LWORK >= 1, and for best performance\n*          LWORK >= max(1,N*NB), where NB is the optimal blocksize for\n*          CHETRF.\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, D(i,i) is exactly zero.  The factorization\n*               has been completed, but the block diagonal matrix D is\n*               exactly singular, so the solution could not be computed.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY\n      INTEGER            LWKOPT, NB\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            ILAENV\n      EXTERNAL           ILAENV, LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CHETRF, CHETRS2, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, work, info, a, b = NumRu::Lapack.chesv( uplo, a, b, lwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_b = argv[2];
  rblapack_lwork = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  lwork = NUM2INT(rblapack_lwork);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  chesv_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_ipiv, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_chesv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chesv", rblapack_chesv, -1);
}
ruby-lapack-1.7.2/ext/zunmr2.c0000644000175000017500000001424412502221016015764 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zunmr2_(char* side, char* trans, integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work, integer* info);


static VALUE
rblapack_zunmr2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_c;
  doublecomplex *c; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublecomplex *c_out__;
  doublecomplex *work;

  integer lda;
  integer m;
  integer k;
  integer ldc;
  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  info, c = NumRu::Lapack.zunmr2( side, trans, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZUNMR2 overwrites the general complex m-by-n matrix C with\n*\n*        Q * C  if SIDE = 'L' and TRANS = 'N', or\n*\n*        Q'* C  if SIDE = 'L' and TRANS = 'C', or\n*\n*        C * Q  if SIDE = 'R' and TRANS = 'N', or\n*\n*        C * Q' if SIDE = 'R' and TRANS = 'C',\n*\n*  where Q is a complex unitary matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(1)' H(2)' . . . H(k)'\n*\n*  as returned by ZGERQF. Q is of order m if SIDE = 'L' and of order n\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q' from the Left\n*          = 'R': apply Q or Q' from the Right\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': apply Q  (No transpose)\n*          = 'C': apply Q' (Conjugate transpose)\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension\n*                               (LDA,M) if SIDE = 'L',\n*                               (LDA,N) if SIDE = 'R'\n*          The i-th row must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          ZGERQF in the last k rows of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,K).\n*\n*  TAU     (input) COMPLEX*16 array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by ZGERQF.\n*\n*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)\n*          On entry, the m-by-n matrix C.\n*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension\n*                                   (N) if SIDE = 'L',\n*                                   (M) if SIDE = 'R'\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, c = NumRu::Lapack.zunmr2( side, trans, a, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_a = argv[2];
  rblapack_tau = argv[3];
  rblapack_c = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
  MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(doublecomplex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  zunmr2_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_c);
}

void
init_lapack_zunmr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zunmr2", rblapack_zunmr2, -1);
}
ruby-lapack-1.7.2/ext/slasq1.c0000644000175000017500000001125412502221014015727 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slasq1_(integer* n, real* d, real* e, real* work, integer* info);


static VALUE
rblapack_slasq1(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_e_out__;
  real *e_out__;
  real *work;

  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  info, d, e = NumRu::Lapack.slasq1( d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASQ1( N, D, E, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLASQ1 computes the singular values of a real N-by-N bidiagonal\n*  matrix with diagonal D and off-diagonal E. The singular values\n*  are computed to high relative accuracy, in the absence of\n*  denormalization, underflow and overflow. The algorithm was first\n*  presented in\n*\n*  \"Accurate singular values and differential qd algorithms\" by K. V.\n*  Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230,\n*  1994,\n*\n*  and the present implementation is described in \"An implementation of\n*  the dqds Algorithm (Positive Case)\", LAPACK Working Note.\n*\n\n*  Arguments\n*  =========\n*\n*  N     (input) INTEGER\n*        The number of rows and columns in the matrix. N >= 0.\n*\n*  D     (input/output) REAL array, dimension (N)\n*        On entry, D contains the diagonal elements of the\n*        bidiagonal matrix whose SVD is desired. On normal exit,\n*        D contains the singular values in decreasing order.\n*\n*  E     (input/output) REAL array, dimension (N)\n*        On entry, elements E(1:N-1) contain the off-diagonal elements\n*        of the bidiagonal matrix whose SVD is desired.\n*        On exit, E is overwritten.\n*\n*  WORK  (workspace) REAL array, dimension (4*N)\n*\n*  INFO  (output) INTEGER\n*        = 0: successful exit\n*        < 0: if INFO = -i, the i-th argument had an illegal value\n*        > 0: the algorithm failed\n*             = 1, a split was marked by a positive value in E\n*             = 2, current block of Z not diagonalized after 30*N\n*                  iterations (in inner while loop)\n*             = 3, termination criterion of outer while loop not met \n*                  (program created more than N unreduced blocks)\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, e = NumRu::Lapack.slasq1( d, e, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_d = argv[0];
  rblapack_e = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (2th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
  MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  work = ALLOC_N(real, (4*n));

  slasq1_(&n, d, e, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_d, rblapack_e);
}

void
init_lapack_slasq1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slasq1", rblapack_slasq1, -1);
}
ruby-lapack-1.7.2/ext/zgetc2.c0000644000175000017500000001066612502221020015724 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgetc2_(integer* n, doublecomplex* a, integer* lda, integer* ipiv, integer* jpiv, integer* info);


static VALUE
rblapack_zgetc2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_jpiv;
  integer *jpiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *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  ipiv, jpiv, info, a = NumRu::Lapack.zgetc2( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGETC2( N, A, LDA, IPIV, JPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGETC2 computes an LU factorization, using complete pivoting, of the\n*  n-by-n matrix A. The factorization has the form A = P * L * U * Q,\n*  where P and Q are permutation matrices, L is lower triangular with\n*  unit diagonal elements and U is upper triangular.\n*\n*  This is a level 1 BLAS version of the algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA, N)\n*          On entry, the n-by-n matrix to be factored.\n*          On exit, the factors L and U from the factorization\n*          A = P*L*U*Q; the unit diagonal elements of L are not stored.\n*          If U(k, k) appears to be less than SMIN, U(k, k) is given the\n*          value of SMIN, giving a nonsingular perturbed system.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1, N).\n*\n*  IPIV    (output) INTEGER array, dimension (N).\n*          The pivot indices; for 1 <= i <= N, row i of the\n*          matrix has been interchanged with row IPIV(i).\n*\n*  JPIV    (output) INTEGER array, dimension (N).\n*          The pivot indices; for 1 <= j <= N, column j of the\n*          matrix has been interchanged with column JPIV(j).\n*\n*  INFO    (output) INTEGER\n*           = 0: successful exit\n*           > 0: if INFO = k, U(k, k) is likely to produce overflow if\n*                one tries to solve for x in Ax = b. So U is perturbed\n*                to avoid the overflow.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, jpiv, info, a = NumRu::Lapack.zgetc2( 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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_jpiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  jpiv = NA_PTR_TYPE(rblapack_jpiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zgetc2_(&n, a, &lda, ipiv, jpiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ipiv, rblapack_jpiv, rblapack_info, rblapack_a);
}

void
init_lapack_zgetc2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgetc2", rblapack_zgetc2, -1);
}
ruby-lapack-1.7.2/ext/clacon.c0000644000175000017500000001011212502221015015753 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clacon_(integer* n, complex* v, complex* x, real* est, integer* kase);


static VALUE
rblapack_clacon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_est;
  real est; 
  VALUE rblapack_kase;
  integer kase; 
  VALUE rblapack_x_out__;
  complex *x_out__;
  complex *v;

  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  x, est, kase = NumRu::Lapack.clacon( x, est, kase, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLACON( N, V, X, EST, KASE )\n\n*  Purpose\n*  =======\n*\n*  CLACON estimates the 1-norm of a square, complex matrix A.\n*  Reverse communication is used for evaluating matrix-vector products.\n*\n\n*  Arguments\n*  =========\n*\n*  N      (input) INTEGER\n*         The order of the matrix.  N >= 1.\n*\n*  V      (workspace) COMPLEX array, dimension (N)\n*         On the final return, V = A*W,  where  EST = norm(V)/norm(W)\n*         (W is not returned).\n*\n*  X      (input/output) COMPLEX array, dimension (N)\n*         On an intermediate return, X should be overwritten by\n*               A * X,   if KASE=1,\n*               A' * X,  if KASE=2,\n*         where A' is the conjugate transpose of A, and CLACON must be\n*         re-called with all the other parameters unchanged.\n*\n*  EST    (input/output) REAL\n*         On entry with KASE = 1 or 2 and JUMP = 3, EST should be\n*         unchanged from the previous call to CLACON.\n*         On exit, EST is an estimate (a lower bound) for norm(A). \n*\n*  KASE   (input/output) INTEGER\n*         On the initial call to CLACON, KASE should be 0.\n*         On an intermediate return, KASE will be 1 or 2, indicating\n*         whether X should be overwritten by A * X  or A' * X.\n*         On the final return from CLACON, KASE will again be 0.\n*\n\n*  Further Details\n*  ======= =======\n*\n*  Contributed by Nick Higham, University of Manchester.\n*  Originally named CONEST, dated March 16, 1988.\n*\n*  Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n*  a real or complex matrix, with applications to condition estimation\",\n*  ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n*\n*  Last modified:  April, 1999\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, est, kase = NumRu::Lapack.clacon( x, est, kase, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_x = argv[0];
  rblapack_est = argv[1];
  rblapack_kase = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (1th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  kase = NUM2INT(rblapack_kase);
  est = (real)NUM2DBL(rblapack_est);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  v = ALLOC_N(complex, (n));

  clacon_(&n, v, x, &est, &kase);

  free(v);
  rblapack_est = rb_float_new((double)est);
  rblapack_kase = INT2NUM(kase);
  return rb_ary_new3(3, rblapack_x, rblapack_est, rblapack_kase);
}

void
init_lapack_clacon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clacon", rblapack_clacon, -1);
}
ruby-lapack-1.7.2/ext/sla_gbrcond.c0000644000175000017500000002105512502221026017003 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real sla_gbrcond_(char* trans, integer* n, integer* kl, integer* ku, real* ab, integer* ldab, real* afb, integer* ldafb, integer* ipiv, integer* cmode, real* c, integer* info, real* work, integer* iwork);


static VALUE
rblapack_sla_gbrcond(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_afb;
  real *afb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_cmode;
  integer cmode; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack___out__;
  real __out__; 

  integer ldab;
  integer n;
  integer ldafb;

  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  info, __out__ = NumRu::Lapack.sla_gbrcond( trans, kl, ku, ab, afb, ipiv, cmode, c, work, iwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL FUNCTION SLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, AFB, LDAFB, IPIV, CMODE, C, INFO, WORK, IWORK )\n\n*  Purpose\n*  =======\n*\n*     SLA_GBRCOND Estimates the Skeel condition number of  op(A) * op2(C)\n*     where op2 is determined by CMODE as follows\n*     CMODE =  1    op2(C) = C\n*     CMODE =  0    op2(C) = I\n*     CMODE = -1    op2(C) = inv(C)\n*     The Skeel condition number  cond(A) = norminf( |inv(A)||A| )\n*     is computed by computing scaling factors R such that\n*     diag(R)*A*op2(C) is row equilibrated and computing the standard\n*     infinity-norm condition number.\n*\n\n*  Arguments\n*  ==========\n*\n*     TRANS   (input) CHARACTER*1\n*     Specifies the form of the system of equations:\n*       = 'N':  A * X = B     (No transpose)\n*       = 'T':  A**T * X = B  (Transpose)\n*       = 'C':  A**H * X = B  (Conjugate Transpose = Transpose)\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     KL      (input) INTEGER\n*     The number of subdiagonals within the band of A.  KL >= 0.\n*\n*     KU      (input) INTEGER\n*     The number of superdiagonals within the band of A.  KU >= 0.\n*\n*     AB      (input) REAL array, dimension (LDAB,N)\n*     On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n*     The j-th column of A is stored in the j-th column of the\n*     array AB as follows:\n*     AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n*     LDAB    (input) INTEGER\n*     The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*     AFB     (input) REAL array, dimension (LDAFB,N)\n*     Details of the LU factorization of the band matrix A, as\n*     computed by SGBTRF.  U is stored as an upper triangular\n*     band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n*     and the multipliers used during the factorization are stored\n*     in rows KL+KU+2 to 2*KL+KU+1.\n*\n*     LDAFB   (input) INTEGER\n*     The leading dimension of the array AFB.  LDAFB >= 2*KL+KU+1.\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     The pivot indices from the factorization A = P*L*U\n*     as computed by SGBTRF; row i of the matrix was interchanged\n*     with row IPIV(i).\n*\n*     CMODE   (input) INTEGER\n*     Determines op2(C) in the formula op(A) * op2(C) as follows:\n*     CMODE =  1    op2(C) = C\n*     CMODE =  0    op2(C) = I\n*     CMODE = -1    op2(C) = inv(C)\n*\n*     C       (input) REAL array, dimension (N)\n*     The vector C in the formula op(A) * op2(C).\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit.\n*     i > 0:  The ith argument is invalid.\n*\n*     WORK    (input) REAL array, dimension (5*N).\n*     Workspace.\n*\n*     IWORK   (input) INTEGER array, dimension (N).\n*     Workspace.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            NOTRANS\n      INTEGER            KASE, I, J, KD, KE\n      REAL               AINVNM, TMP\n*     ..\n*     .. Local Arrays ..\n      INTEGER            ISAVE( 3 )\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SLACN2, SGBTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, __out__ = NumRu::Lapack.sla_gbrcond( trans, kl, ku, ab, afb, ipiv, cmode, c, work, iwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_trans = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  rblapack_afb = argv[4];
  rblapack_ipiv = argv[5];
  rblapack_cmode = argv[6];
  rblapack_c = argv[7];
  rblapack_work = argv[8];
  rblapack_iwork = argv[9];
  if (argc == 10) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
  ldafb = NA_SHAPE0(rblapack_afb);
  n = NA_SHAPE1(rblapack_afb);
  if (NA_TYPE(rblapack_afb) != NA_SFLOAT)
    rblapack_afb = na_change_type(rblapack_afb, NA_SFLOAT);
  afb = NA_PTR_TYPE(rblapack_afb, real*);
  cmode = NUM2INT(rblapack_cmode);
  if (!NA_IsNArray(rblapack_iwork))
    rb_raise(rb_eArgError, "iwork (10th argument) must be NArray");
  if (NA_RANK(rblapack_iwork) != 1)
    rb_raise(rb_eArgError, "rank of iwork (10th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_iwork) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of iwork must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_iwork) != NA_LINT)
    rblapack_iwork = na_change_type(rblapack_iwork, NA_LINT);
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (8th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  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);
  if (NA_SHAPE0(rblapack_work) != (5*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 5*n);
  if (NA_TYPE(rblapack_work) != NA_SFLOAT)
    rblapack_work = na_change_type(rblapack_work, NA_SFLOAT);
  work = NA_PTR_TYPE(rblapack_work, real*);

  __out__ = sla_gbrcond_(&trans, &n, &kl, &ku, ab, &ldab, afb, &ldafb, ipiv, &cmode, c, &info, work, iwork);

  rblapack_info = INT2NUM(info);
  rblapack___out__ = rb_float_new((double)__out__);
  return rb_ary_new3(2, rblapack_info, rblapack___out__);
}

void
init_lapack_sla_gbrcond(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sla_gbrcond", rblapack_sla_gbrcond, -1);
}
ruby-lapack-1.7.2/ext/slaruv.c0000644000175000017500000000721112502221023016035 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaruv_(integer* iseed, integer* n, real* x);


static VALUE
rblapack_slaruv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_iseed;
  integer *iseed; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_iseed_out__;
  integer *iseed_out__;


  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  x, iseed = NumRu::Lapack.slaruv( iseed, n, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLARUV( ISEED, N, X )\n\n*  Purpose\n*  =======\n*\n*  SLARUV returns a vector of n random real numbers from a uniform (0,1)\n*  distribution (n <= 128).\n*\n*  This is an auxiliary routine called by SLARNV and CLARNV.\n*\n\n*  Arguments\n*  =========\n*\n*  ISEED   (input/output) INTEGER array, dimension (4)\n*          On entry, the seed of the random number generator; the array\n*          elements must be between 0 and 4095, and ISEED(4) must be\n*          odd.\n*          On exit, the seed is updated.\n*\n*  N       (input) INTEGER\n*          The number of random numbers to be generated. N <= 128.\n*\n*  X       (output) REAL array, dimension (N)\n*          The generated random numbers.\n*\n\n*  Further Details\n*  ===============\n*\n*  This routine uses a multiplicative congruential method with modulus\n*  2**48 and multiplier 33952834046453 (see G.S.Fishman,\n*  'Multiplicative congruential random number generators with modulus\n*  2**b: an exhaustive analysis for b = 32 and a partial analysis for\n*  b = 48', Math. Comp. 189, pp 331-344, 1990).\n*\n*  48-bit integers are stored in 4 integer array elements with 12 bits\n*  per element. Hence the routine is portable across machines with\n*  integers of 32 bits or more.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, iseed = NumRu::Lapack.slaruv( iseed, n, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_iseed = argv[0];
  rblapack_n = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_iseed))
    rb_raise(rb_eArgError, "iseed (1th argument) must be NArray");
  if (NA_RANK(rblapack_iseed) != 1)
    rb_raise(rb_eArgError, "rank of iseed (1th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_iseed) != (4))
    rb_raise(rb_eRuntimeError, "shape 0 of iseed must be %d", 4);
  if (NA_TYPE(rblapack_iseed) != NA_LINT)
    rblapack_iseed = na_change_type(rblapack_iseed, NA_LINT);
  iseed = NA_PTR_TYPE(rblapack_iseed, integer*);
  n = NUM2INT(rblapack_n);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,n);
    rblapack_x = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[1];
    shape[0] = 4;
    rblapack_iseed_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iseed_out__ = NA_PTR_TYPE(rblapack_iseed_out__, integer*);
  MEMCPY(iseed_out__, iseed, integer, NA_TOTAL(rblapack_iseed));
  rblapack_iseed = rblapack_iseed_out__;
  iseed = iseed_out__;

  slaruv_(iseed, &n, x);

  return rb_ary_new3(2, rblapack_x, rblapack_iseed);
}

void
init_lapack_slaruv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaruv", rblapack_slaruv, -1);
}
ruby-lapack-1.7.2/ext/chbgst.c0000644000175000017500000001474612502221025016010 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chbgst_(char* vect, char* uplo, integer* n, integer* ka, integer* kb, complex* ab, integer* ldab, complex* bb, integer* ldbb, complex* x, integer* ldx, complex* work, real* rwork, integer* info);


static VALUE
rblapack_chbgst(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_vect;
  char vect; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ka;
  integer ka; 
  VALUE rblapack_kb;
  integer kb; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_bb;
  complex *bb; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  complex *ab_out__;
  complex *work;
  real *rwork;

  integer ldab;
  integer n;
  integer ldbb;
  integer ldx;

  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  x, info, ab = NumRu::Lapack.chbgst( vect, uplo, ka, kb, ab, bb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, LDX, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHBGST reduces a complex Hermitian-definite banded generalized\n*  eigenproblem  A*x = lambda*B*x  to standard form  C*y = lambda*y,\n*  such that C has the same bandwidth as A.\n*\n*  B must have been previously factorized as S**H*S by CPBSTF, using a\n*  split Cholesky factorization. A is overwritten by C = X**H*A*X, where\n*  X = S**(-1)*Q and Q is a unitary matrix chosen to preserve the\n*  bandwidth of A.\n*\n\n*  Arguments\n*  =========\n*\n*  VECT    (input) CHARACTER*1\n*          = 'N':  do not form the transformation matrix X;\n*          = 'V':  form X.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  KA      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KA >= 0.\n*\n*  KB      (input) INTEGER\n*          The number of superdiagonals of the matrix B if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KA >= KB >= 0.\n*\n*  AB      (input/output) COMPLEX array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix A, stored in the first ka+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).\n*\n*          On exit, the transformed matrix X**H*A*X, stored in the same\n*          format as A.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KA+1.\n*\n*  BB      (input) COMPLEX array, dimension (LDBB,N)\n*          The banded factor S from the split Cholesky factorization of\n*          B, as returned by CPBSTF, stored in the first kb+1 rows of\n*          the array.\n*\n*  LDBB    (input) INTEGER\n*          The leading dimension of the array BB.  LDBB >= KB+1.\n*\n*  X       (output) COMPLEX array, dimension (LDX,N)\n*          If VECT = 'V', the n-by-n matrix X.\n*          If VECT = 'N', the array X is not referenced.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.\n*          LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.\n*\n*  WORK    (workspace) COMPLEX array, dimension (N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, info, ab = NumRu::Lapack.chbgst( vect, uplo, ka, kb, ab, bb, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_vect = argv[0];
  rblapack_uplo = argv[1];
  rblapack_ka = argv[2];
  rblapack_kb = argv[3];
  rblapack_ab = argv[4];
  rblapack_bb = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  vect = StringValueCStr(rblapack_vect)[0];
  ka = NUM2INT(rblapack_ka);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_bb))
    rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
  if (NA_RANK(rblapack_bb) != 2)
    rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
  ldbb = NA_SHAPE0(rblapack_bb);
  if (NA_SHAPE1(rblapack_bb) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of bb must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_bb) != NA_SCOMPLEX)
    rblapack_bb = na_change_type(rblapack_bb, NA_SCOMPLEX);
  bb = NA_PTR_TYPE(rblapack_bb, complex*);
  kb = NUM2INT(rblapack_kb);
  ldx = lsame_(&vect,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = n;
    rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
  MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  work = ALLOC_N(complex, (n));
  rwork = ALLOC_N(real, (n));

  chbgst_(&vect, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, x, &ldx, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_x, rblapack_info, rblapack_ab);
}

void
init_lapack_chbgst(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chbgst", rblapack_chbgst, -1);
}
ruby-lapack-1.7.2/ext/zlar2v.c0000644000175000017500000001577312502221025015757 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlar2v_(integer* n, doublecomplex* x, doublecomplex* y, doublecomplex* z, integer* incx, doublereal* c, doublecomplex* s, integer* incc);


static VALUE
rblapack_zlar2v(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_y;
  doublecomplex *y; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_s;
  doublecomplex *s; 
  VALUE rblapack_incc;
  integer incc; 
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;
  VALUE rblapack_y_out__;
  doublecomplex *y_out__;
  VALUE rblapack_z_out__;
  doublecomplex *z_out__;


  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  x, y, z = NumRu::Lapack.zlar2v( n, x, y, z, incx, c, s, incc, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAR2V( N, X, Y, Z, INCX, C, S, INCC )\n\n*  Purpose\n*  =======\n*\n*  ZLAR2V applies a vector of complex plane rotations with real cosines\n*  from both sides to a sequence of 2-by-2 complex Hermitian matrices,\n*  defined by the elements of the vectors x, y and z. For i = 1,2,...,n\n*\n*     (       x(i)  z(i) ) :=\n*     ( conjg(z(i)) y(i) )\n*\n*       (  c(i) conjg(s(i)) ) (       x(i)  z(i) ) ( c(i) -conjg(s(i)) )\n*       ( -s(i)       c(i)  ) ( conjg(z(i)) y(i) ) ( s(i)        c(i)  )\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of plane rotations to be applied.\n*\n*  X       (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX)\n*          The vector x; the elements of x are assumed to be real.\n*\n*  Y       (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX)\n*          The vector y; the elements of y are assumed to be real.\n*\n*  Z       (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX)\n*          The vector z.\n*\n*  INCX    (input) INTEGER\n*          The increment between elements of X, Y and Z. INCX > 0.\n*\n*  C       (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)\n*          The cosines of the plane rotations.\n*\n*  S       (input) COMPLEX*16 array, dimension (1+(N-1)*INCC)\n*          The sines of the plane rotations.\n*\n*  INCC    (input) INTEGER\n*          The increment between elements of C and S. INCC > 0.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, IC, IX\n      DOUBLE PRECISION   CI, SII, SIR, T1I, T1R, T5, T6, XI, YI, ZII,\n     $                   ZIR\n      COMPLEX*16         SI, T2, T3, T4, ZI\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          DBLE, DCMPLX, DCONJG, DIMAG\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, y, z = NumRu::Lapack.zlar2v( n, x, y, z, incx, c, s, incc, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_n = argv[0];
  rblapack_x = argv[1];
  rblapack_y = argv[2];
  rblapack_z = argv[3];
  rblapack_incx = argv[4];
  rblapack_c = argv[5];
  rblapack_s = argv[6];
  rblapack_incc = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  incx = NUM2INT(rblapack_incx);
  incc = NUM2INT(rblapack_incc);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1+(n-1)*incx))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (4th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != (1+(n-1)*incx))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 1+(n-1)*incx);
  if (NA_TYPE(rblapack_z) != NA_DCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (7th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != (1+(n-1)*incc))
    rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", 1+(n-1)*incc);
  if (NA_TYPE(rblapack_s) != NA_DCOMPLEX)
    rblapack_s = na_change_type(rblapack_s, NA_DCOMPLEX);
  s = NA_PTR_TYPE(rblapack_s, doublecomplex*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (3th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incx))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incx);
  if (NA_TYPE(rblapack_y) != NA_DCOMPLEX)
    rblapack_y = na_change_type(rblapack_y, NA_DCOMPLEX);
  y = NA_PTR_TYPE(rblapack_y, doublecomplex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != (1+(n-1)*incc))
    rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", 1+(n-1)*incc);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incx;
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incx;
    rblapack_y_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublecomplex*);
  MEMCPY(y_out__, y, doublecomplex, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incx;
    rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublecomplex*);
  MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  zlar2v_(&n, x, y, z, &incx, c, s, &incc);

  return rb_ary_new3(3, rblapack_x, rblapack_y, rblapack_z);
}

void
init_lapack_zlar2v(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlar2v", rblapack_zlar2v, -1);
}
ruby-lapack-1.7.2/ext/strtri.c0000644000175000017500000001005312502221023016046 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID strtri_(char* uplo, char* diag, integer* n, real* a, integer* lda, integer* info);


static VALUE
rblapack_strtri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *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  info, a = NumRu::Lapack.strtri( uplo, diag, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STRTRI( UPLO, DIAG, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  STRTRI computes the inverse of a real upper or lower triangular\n*  matrix A.\n*\n*  This is the Level 3 BLAS version of the algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the triangular matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of the array A contains\n*          the upper triangular matrix, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of the array A contains\n*          the lower triangular matrix, and the strictly upper\n*          triangular part of A is not referenced.  If DIAG = 'U', the\n*          diagonal elements of A are also not referenced and are\n*          assumed to be 1.\n*          On exit, the (triangular) inverse of the original matrix, in\n*          the same storage format.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\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, A(i,i) is exactly zero.  The triangular\n*               matrix is singular and its inverse can not be computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.strtri( uplo, diag, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_diag = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  diag = StringValueCStr(rblapack_diag)[0];
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  strtri_(&uplo, &diag, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_strtri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "strtri", rblapack_strtri, -1);
}
ruby-lapack-1.7.2/ext/dtgevc.c0000644000175000017500000003270412502221012016000 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtgevc_(char* side, char* howmny, logical* select, integer* n, doublereal* s, integer* lds, doublereal* p, integer* ldp, doublereal* vl, integer* ldvl, doublereal* vr, integer* ldvr, integer* mm, integer* m, doublereal* work, integer* info);


static VALUE
rblapack_dtgevc(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_howmny;
  char howmny; 
  VALUE rblapack_select;
  logical *select; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_p;
  doublereal *p; 
  VALUE rblapack_vl;
  doublereal *vl; 
  VALUE rblapack_vr;
  doublereal *vr; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_vl_out__;
  doublereal *vl_out__;
  VALUE rblapack_vr_out__;
  doublereal *vr_out__;
  doublereal *work;

  integer n;
  integer lds;
  integer ldp;
  integer ldvl;
  integer mm;
  integer ldvr;

  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  m, info, vl, vr = NumRu::Lapack.dtgevc( side, howmny, select, s, p, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTGEVC computes some or all of the right and/or left eigenvectors of\n*  a pair of real matrices (S,P), where S is a quasi-triangular matrix\n*  and P is upper triangular.  Matrix pairs of this type are produced by\n*  the generalized Schur factorization of a matrix pair (A,B):\n*\n*     A = Q*S*Z**T,  B = Q*P*Z**T\n*\n*  as computed by DGGHRD + DHGEQZ.\n*\n*  The right eigenvector x and the left eigenvector y of (S,P)\n*  corresponding to an eigenvalue w are defined by:\n*  \n*     S*x = w*P*x,  (y**H)*S = w*(y**H)*P,\n*  \n*  where y**H denotes the conjugate tranpose of y.\n*  The eigenvalues are not input to this routine, but are computed\n*  directly from the diagonal blocks of S and P.\n*  \n*  This routine returns the matrices X and/or Y of right and left\n*  eigenvectors of (S,P), or the products Z*X and/or Q*Y,\n*  where Z and Q are input matrices.\n*  If Q and Z are the orthogonal factors from the generalized Schur\n*  factorization of a matrix pair (A,B), then Z*X and Q*Y\n*  are the matrices of right and left eigenvectors of (A,B).\n* \n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'R': compute right eigenvectors only;\n*          = 'L': compute left eigenvectors only;\n*          = 'B': compute both right and left eigenvectors.\n*\n*  HOWMNY  (input) CHARACTER*1\n*          = 'A': compute all right and/or left eigenvectors;\n*          = 'B': compute all right and/or left eigenvectors,\n*                 backtransformed by the matrices in VR and/or VL;\n*          = 'S': compute selected right and/or left eigenvectors,\n*                 specified by the logical array SELECT.\n*\n*  SELECT  (input) LOGICAL array, dimension (N)\n*          If HOWMNY='S', SELECT specifies the eigenvectors to be\n*          computed.  If w(j) is a real eigenvalue, the corresponding\n*          real eigenvector is computed if SELECT(j) is .TRUE..\n*          If w(j) and w(j+1) are the real and imaginary parts of a\n*          complex eigenvalue, the corresponding complex eigenvector\n*          is computed if either SELECT(j) or SELECT(j+1) is .TRUE.,\n*          and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is\n*          set to .FALSE..\n*          Not referenced if HOWMNY = 'A' or 'B'.\n*\n*  N       (input) INTEGER\n*          The order of the matrices S and P.  N >= 0.\n*\n*  S       (input) DOUBLE PRECISION array, dimension (LDS,N)\n*          The upper quasi-triangular matrix S from a generalized Schur\n*          factorization, as computed by DHGEQZ.\n*\n*  LDS     (input) INTEGER\n*          The leading dimension of array S.  LDS >= max(1,N).\n*\n*  P       (input) DOUBLE PRECISION array, dimension (LDP,N)\n*          The upper triangular matrix P from a generalized Schur\n*          factorization, as computed by DHGEQZ.\n*          2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks\n*          of S must be in positive diagonal form.\n*\n*  LDP     (input) INTEGER\n*          The leading dimension of array P.  LDP >= max(1,N).\n*\n*  VL      (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)\n*          On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n*          contain an N-by-N matrix Q (usually the orthogonal matrix Q\n*          of left Schur vectors returned by DHGEQZ).\n*          On exit, if SIDE = 'L' or 'B', VL contains:\n*          if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);\n*          if HOWMNY = 'B', the matrix Q*Y;\n*          if HOWMNY = 'S', the left eigenvectors of (S,P) specified by\n*                      SELECT, stored consecutively in the columns of\n*                      VL, in the same order as their eigenvalues.\n*\n*          A complex eigenvector corresponding to a complex eigenvalue\n*          is stored in two consecutive columns, the first holding the\n*          real part, and the second the imaginary part.\n*\n*          Not referenced if SIDE = 'R'.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of array VL.  LDVL >= 1, and if\n*          SIDE = 'L' or 'B', LDVL >= N.\n*\n*  VR      (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)\n*          On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n*          contain an N-by-N matrix Z (usually the orthogonal matrix Z\n*          of right Schur vectors returned by DHGEQZ).\n*\n*          On exit, if SIDE = 'R' or 'B', VR contains:\n*          if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);\n*          if HOWMNY = 'B' or 'b', the matrix Z*X;\n*          if HOWMNY = 'S' or 's', the right eigenvectors of (S,P)\n*                      specified by SELECT, stored consecutively in the\n*                      columns of VR, in the same order as their\n*                      eigenvalues.\n*\n*          A complex eigenvector corresponding to a complex eigenvalue\n*          is stored in two consecutive columns, the first holding the\n*          real part and the second the imaginary part.\n*          \n*          Not referenced if SIDE = 'L'.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the array VR.  LDVR >= 1, and if\n*          SIDE = 'R' or 'B', LDVR >= N.\n*\n*  MM      (input) INTEGER\n*          The number of columns in the arrays VL and/or VR. MM >= M.\n*\n*  M       (output) INTEGER\n*          The number of columns in the arrays VL and/or VR actually\n*          used to store the eigenvectors.  If HOWMNY = 'A' or 'B', M\n*          is set to N.  Each selected real eigenvector occupies one\n*          column and each selected complex eigenvector occupies two\n*          columns.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (6*N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit.\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          > 0:  the 2-by-2 block (INFO:INFO+1) does not have a complex\n*                eigenvalue.\n*\n\n*  Further Details\n*  ===============\n*\n*  Allocation of workspace:\n*  ---------- -- ---------\n*\n*     WORK( j ) = 1-norm of j-th column of A, above the diagonal\n*     WORK( N+j ) = 1-norm of j-th column of B, above the diagonal\n*     WORK( 2*N+1:3*N ) = real part of eigenvector\n*     WORK( 3*N+1:4*N ) = imaginary part of eigenvector\n*     WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector\n*     WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector\n*\n*  Rowwise vs. columnwise solution methods:\n*  ------- --  ---------- -------- -------\n*\n*  Finding a generalized eigenvector consists basically of solving the\n*  singular triangular system\n*\n*   (A - w B) x = 0     (for right) or:   (A - w B)**H y = 0  (for left)\n*\n*  Consider finding the i-th right eigenvector (assume all eigenvalues\n*  are real). The equation to be solved is:\n*       n                   i\n*  0 = sum  C(j,k) v(k)  = sum  C(j,k) v(k)     for j = i,. . .,1\n*      k=j                 k=j\n*\n*  where  C = (A - w B)  (The components v(i+1:n) are 0.)\n*\n*  The \"rowwise\" method is:\n*\n*  (1)  v(i) := 1\n*  for j = i-1,. . .,1:\n*                          i\n*      (2) compute  s = - sum C(j,k) v(k)   and\n*                        k=j+1\n*\n*      (3) v(j) := s / C(j,j)\n*\n*  Step 2 is sometimes called the \"dot product\" step, since it is an\n*  inner product between the j-th row and the portion of the eigenvector\n*  that has been computed so far.\n*\n*  The \"columnwise\" method consists basically in doing the sums\n*  for all the rows in parallel.  As each v(j) is computed, the\n*  contribution of v(j) times the j-th column of C is added to the\n*  partial sums.  Since FORTRAN arrays are stored columnwise, this has\n*  the advantage that at each step, the elements of C that are accessed\n*  are adjacent to one another, whereas with the rowwise method, the\n*  elements accessed at a step are spaced LDS (and LDP) words apart.\n*\n*  When finding left eigenvectors, the matrix in question is the\n*  transpose of the one in storage, so the rowwise method then\n*  actually accesses columns of A and B at each step, and so is the\n*  preferred method.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, info, vl, vr = NumRu::Lapack.dtgevc( side, howmny, select, s, p, vl, vr, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_side = argv[0];
  rblapack_howmny = argv[1];
  rblapack_select = argv[2];
  rblapack_s = argv[3];
  rblapack_p = argv[4];
  rblapack_vl = argv[5];
  rblapack_vr = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_select))
    rb_raise(rb_eArgError, "select (3th argument) must be NArray");
  if (NA_RANK(rblapack_select) != 1)
    rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_select);
  if (NA_TYPE(rblapack_select) != NA_LINT)
    rblapack_select = na_change_type(rblapack_select, NA_LINT);
  select = NA_PTR_TYPE(rblapack_select, logical*);
  if (!NA_IsNArray(rblapack_p))
    rb_raise(rb_eArgError, "p (5th argument) must be NArray");
  if (NA_RANK(rblapack_p) != 2)
    rb_raise(rb_eArgError, "rank of p (5th argument) must be %d", 2);
  ldp = NA_SHAPE0(rblapack_p);
  if (NA_SHAPE1(rblapack_p) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of p must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_p) != NA_DFLOAT)
    rblapack_p = na_change_type(rblapack_p, NA_DFLOAT);
  p = NA_PTR_TYPE(rblapack_p, doublereal*);
  if (!NA_IsNArray(rblapack_vr))
    rb_raise(rb_eArgError, "vr (7th argument) must be NArray");
  if (NA_RANK(rblapack_vr) != 2)
    rb_raise(rb_eArgError, "rank of vr (7th argument) must be %d", 2);
  ldvr = NA_SHAPE0(rblapack_vr);
  mm = NA_SHAPE1(rblapack_vr);
  if (NA_TYPE(rblapack_vr) != NA_DFLOAT)
    rblapack_vr = na_change_type(rblapack_vr, NA_DFLOAT);
  vr = NA_PTR_TYPE(rblapack_vr, doublereal*);
  howmny = StringValueCStr(rblapack_howmny)[0];
  if (!NA_IsNArray(rblapack_vl))
    rb_raise(rb_eArgError, "vl (6th argument) must be NArray");
  if (NA_RANK(rblapack_vl) != 2)
    rb_raise(rb_eArgError, "rank of vl (6th argument) must be %d", 2);
  ldvl = NA_SHAPE0(rblapack_vl);
  if (NA_SHAPE1(rblapack_vl) != mm)
    rb_raise(rb_eRuntimeError, "shape 1 of vl must be the same as shape 1 of vr");
  if (NA_TYPE(rblapack_vl) != NA_DFLOAT)
    rblapack_vl = na_change_type(rblapack_vl, NA_DFLOAT);
  vl = NA_PTR_TYPE(rblapack_vl, doublereal*);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (4th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 2)
    rb_raise(rb_eArgError, "rank of s (4th argument) must be %d", 2);
  lds = NA_SHAPE0(rblapack_s);
  if (NA_SHAPE1(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of s must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = mm;
    rblapack_vl_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, doublereal*);
  MEMCPY(vl_out__, vl, doublereal, NA_TOTAL(rblapack_vl));
  rblapack_vl = rblapack_vl_out__;
  vl = vl_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = mm;
    rblapack_vr_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vr_out__ = NA_PTR_TYPE(rblapack_vr_out__, doublereal*);
  MEMCPY(vr_out__, vr, doublereal, NA_TOTAL(rblapack_vr));
  rblapack_vr = rblapack_vr_out__;
  vr = vr_out__;
  work = ALLOC_N(doublereal, (6*n));

  dtgevc_(&side, &howmny, select, &n, s, &lds, p, &ldp, vl, &ldvl, vr, &ldvr, &mm, &m, work, &info);

  free(work);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_m, rblapack_info, rblapack_vl, rblapack_vr);
}

void
init_lapack_dtgevc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtgevc", rblapack_dtgevc, -1);
}
ruby-lapack-1.7.2/ext/dgebrd.c0000644000175000017500000002147012502221013015752 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgebrd_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* d, doublereal* e, doublereal* tauq, doublereal* taup, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dgebrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_tauq;
  doublereal *tauq; 
  VALUE rblapack_taup;
  doublereal *taup; 
  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  d, e, tauq, taup, work, info, a = NumRu::Lapack.dgebrd( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGEBRD reduces a general real M-by-N matrix A to upper or lower\n*  bidiagonal form B by an orthogonal transformation: Q**T * A * P = B.\n*\n*  If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows in the matrix A.  M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns in the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the M-by-N general matrix to be reduced.\n*          On exit,\n*          if m >= n, the diagonal and the first superdiagonal are\n*            overwritten with the upper bidiagonal matrix B; the\n*            elements below the diagonal, with the array TAUQ, represent\n*            the orthogonal matrix Q as a product of elementary\n*            reflectors, and the elements above the first superdiagonal,\n*            with the array TAUP, represent the orthogonal matrix P as\n*            a product of elementary reflectors;\n*          if m < n, the diagonal and the first subdiagonal are\n*            overwritten with the lower bidiagonal matrix B; the\n*            elements below the first subdiagonal, with the array TAUQ,\n*            represent the orthogonal matrix Q as a product of\n*            elementary reflectors, and the elements above the diagonal,\n*            with the array TAUP, represent the orthogonal matrix P as\n*            a product of elementary reflectors.\n*          See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  D       (output) DOUBLE PRECISION array, dimension (min(M,N))\n*          The diagonal elements of the bidiagonal matrix B:\n*          D(i) = A(i,i).\n*\n*  E       (output) DOUBLE PRECISION array, dimension (min(M,N)-1)\n*          The off-diagonal elements of the bidiagonal matrix B:\n*          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n*          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n*\n*  TAUQ    (output) DOUBLE PRECISION array dimension (min(M,N))\n*          The scalar factors of the elementary reflectors which\n*          represent the orthogonal matrix Q. See Further Details.\n*\n*  TAUP    (output) DOUBLE PRECISION array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors which\n*          represent the orthogonal matrix P. See Further 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 length of the array WORK.  LWORK >= max(1,M,N).\n*          For optimum performance LWORK >= (M+N)*NB, where NB\n*          is the 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 matrices Q and P are represented as products of elementary\n*  reflectors:\n*\n*  If m >= n,\n*\n*     Q = H(1) H(2) . . . H(n)  and  P = G(1) G(2) . . . G(n-1)\n*\n*  Each H(i) and G(i) has the form:\n*\n*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'\n*\n*  where tauq and taup are real scalars, and v and u are real vectors;\n*  v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);\n*  u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);\n*  tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n*  If m < n,\n*\n*     Q = H(1) H(2) . . . H(m-1)  and  P = G(1) G(2) . . . G(m)\n*\n*  Each H(i) and G(i) has the form:\n*\n*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'\n*\n*  where tauq and taup are real scalars, and v and u are real vectors;\n*  v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);\n*  u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);\n*  tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n*  The contents of A on exit are illustrated by the following examples:\n*\n*  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):\n*\n*    (  d   e   u1  u1  u1 )           (  d   u1  u1  u1  u1  u1 )\n*    (  v1  d   e   u2  u2 )           (  e   d   u2  u2  u2  u2 )\n*    (  v1  v2  d   e   u3 )           (  v1  e   d   u3  u3  u3 )\n*    (  v1  v2  v3  d   e  )           (  v1  v2  e   d   u4  u4 )\n*    (  v1  v2  v3  v4  d  )           (  v1  v2  v3  e   d   u5 )\n*    (  v1  v2  v3  v4  v5 )\n*\n*  where d and e denote diagonal and off-diagonal elements of B, vi\n*  denotes an element of the vector defining H(i), and ui an element of\n*  the vector defining G(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, tauq, taup, work, info, a = NumRu::Lapack.dgebrd( 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;
  }

  m = NUM2INT(rblapack_m);
  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*);
  if (rblapack_lwork == Qnil)
    lwork = MAX(m,n);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n)-1;
    rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tauq = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  tauq = NA_PTR_TYPE(rblapack_tauq, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_taup = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  taup = NA_PTR_TYPE(rblapack_taup, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;

  dgebrd_(&m, &n, a, &lda, d, e, tauq, taup, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_d, rblapack_e, rblapack_tauq, rblapack_taup, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_dgebrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgebrd", rblapack_dgebrd, -1);
}
ruby-lapack-1.7.2/ext/zgetri.c0000644000175000017500000001220612502221013016024 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgetri_(integer* n, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zgetri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *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  work, info, a = NumRu::Lapack.zgetri( a, ipiv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGETRI computes the inverse of a matrix using the LU factorization\n*  computed by ZGETRF.\n*\n*  This method inverts U and then computes inv(A) by solving the system\n*  inv(A)*L = inv(U) for inv(A).\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the factors L and U from the factorization\n*          A = P*L*U as computed by ZGETRF.\n*          On exit, if INFO = 0, the inverse of the original matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices from ZGETRF; for 1<=i<=N, row i of the\n*          matrix was interchanged with row IPIV(i).\n*\n*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n*          On exit, if INFO=0, then WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK.  LWORK >= max(1,N).\n*          For optimal performance LWORK >= N*NB, where NB is\n*          the optimal blocksize returned by ILAENV.\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, U(i,i) is exactly zero; the matrix is\n*                singular and its inverse could not be 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 = NumRu::Lapack.zgetri( a, ipiv, [: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_a = argv[0];
  rblapack_ipiv = 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 (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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (2th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zgetri_(&n, a, &lda, ipiv, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_zgetri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgetri", rblapack_zgetri, -1);
}
ruby-lapack-1.7.2/ext/zgels.c0000644000175000017500000002127112502221020015644 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgels_(char* trans, integer* m, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zgels(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_b_out__;
  doublecomplex *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.zgels( trans, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGELS solves overdetermined or underdetermined complex linear systems\n*  involving an M-by-N matrix A, or its conjugate-transpose, using a QR\n*  or LQ 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 = 'C' and m >= n:  find the minimum norm solution of\n*     an undetermined system A**H * X = B.\n*\n*  4. If TRANS = 'C' and m < n:  find the least squares solution of\n*     an overdetermined system, i.e., solve the least squares problem\n*                  minimize || B - A**H * 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*          = 'C': the linear system involves A**H.\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) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*            if M >= N, A is overwritten by details of its QR\n*                       factorization as returned by ZGEQRF;\n*            if M <  N, A is overwritten by details of its LQ\n*                       factorization as returned by ZGELQF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  B       (input/output) COMPLEX*16 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 = 'C'.\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 the\n*          modulus of 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 = 'C' and m >= n, rows 1 to M of B contain the\n*          minimum norm solution vectors;\n*          if TRANS = 'C' 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 the modulus 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) COMPLEX*16 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.zgels( 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;
  }

  trans = StringValueCStr(rblapack_trans)[0];
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  m = lda;
  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_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  ldb = MAX(m,n);
  if (rblapack_lwork == Qnil)
    lwork = MIN(m,n) + MAX(MIN(m,n),nrhs);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = MAX(m, n);
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  {
    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__;

  zgels_(&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_zgels(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgels", rblapack_zgels, -1);
}
ruby-lapack-1.7.2/ext/ssbevd.c0000644000175000017500000002154112502221013016010 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssbevd_(char* jobz, char* uplo, integer* n, integer* kd, real* ab, integer* ldab, real* w, real* z, integer* ldz, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_ssbevd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  real *ab_out__;

  integer ldab;
  integer n;
  integer ldz;

  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  w, z, work, iwork, info, ab = NumRu::Lapack.ssbevd( jobz, uplo, kd, ab, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSBEVD computes all the eigenvalues and, optionally, eigenvectors of\n*  a real symmetric band matrix A. If eigenvectors are desired, it uses\n*  a divide and conquer algorithm.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) REAL array, dimension (LDAB, N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*          On exit, AB is overwritten by values generated during the\n*          reduction to tridiagonal form.  If UPLO = 'U', the first\n*          superdiagonal and the diagonal of the tridiagonal matrix T\n*          are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n*          the diagonal and first subdiagonal of T are returned in the\n*          first two rows of AB.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD + 1.\n*\n*  W       (output) REAL array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) REAL array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n*          eigenvectors of the matrix A, with the i-th column of Z\n*          holding the eigenvector associated with W(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace/output) REAL array,\n*                                         dimension (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*          IF N <= 1,                LWORK must be at least 1.\n*          If JOBZ  = 'N' and N > 2, LWORK must be at least 2*N.\n*          If JOBZ  = 'V' and N > 2, LWORK must be at least\n*                         ( 1 + 5*N + 2*N**2 ).\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal sizes of the WORK and IWORK\n*          arrays, returns these values as the first entries of the WORK\n*          and IWORK arrays, and no error message related to LWORK or\n*          LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array LIWORK.\n*          If JOBZ  = 'N' or N <= 1, LIWORK must be at least 1.\n*          If JOBZ  = 'V' and N > 2, LIWORK must be at least 3 + 5*N.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK and IWORK arrays, and no error message related to\n*          LWORK or LIWORK 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 algorithm failed to converge; i\n*                off-diagonal elements of an intermediate tridiagonal\n*                form did not converge to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, work, iwork, info, ab = NumRu::Lapack.ssbevd( jobz, uplo, kd, ab, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_kd = argv[2];
  rblapack_ab = argv[3];
  if (argc == 6) {
    rblapack_lwork = argv[4];
    rblapack_liwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  kd = NUM2INT(rblapack_kd);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  if (rblapack_liwork == Qnil)
    liwork = (lsame_(&jobz,"N")||n<=0) ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  if (rblapack_lwork == Qnil)
    lwork = n<=0 ? 1 : lsame_(&jobz,"N") ? 2*n : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
  MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  ssbevd_(&jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, &lwork, iwork, &liwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_w, rblapack_z, rblapack_work, rblapack_iwork, rblapack_info, rblapack_ab);
}

void
init_lapack_ssbevd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssbevd", rblapack_ssbevd, -1);
}
ruby-lapack-1.7.2/ext/slaed5.c0000644000175000017500000000775012502221024015707 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaed5_(integer* i, real* d, real* z, real* delta, real* rho, real* dlam);


static VALUE
rblapack_slaed5(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_i;
  integer i; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_rho;
  real rho; 
  VALUE rblapack_delta;
  real *delta; 
  VALUE rblapack_dlam;
  real dlam; 


  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  delta, dlam = NumRu::Lapack.slaed5( i, d, z, rho, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAED5( I, D, Z, DELTA, RHO, DLAM )\n\n*  Purpose\n*  =======\n*\n*  This subroutine computes the I-th eigenvalue of a symmetric rank-one\n*  modification of a 2-by-2 diagonal matrix\n*\n*             diag( D )  +  RHO *  Z * transpose(Z) .\n*\n*  The diagonal elements in the array D are assumed to satisfy\n*\n*             D(i) < D(j)  for  i < j .\n*\n*  We also assume RHO > 0 and that the Euclidean norm of the vector\n*  Z is one.\n*\n\n*  Arguments\n*  =========\n*\n*  I      (input) INTEGER\n*         The index of the eigenvalue to be computed.  I = 1 or I = 2.\n*\n*  D      (input) REAL array, dimension (2)\n*         The original eigenvalues.  We assume D(1) < D(2).\n*\n*  Z      (input) REAL array, dimension (2)\n*         The components of the updating vector.\n*\n*  DELTA  (output) REAL array, dimension (2)\n*         The vector DELTA contains the information necessary\n*         to construct the eigenvectors.\n*\n*  RHO    (input) REAL\n*         The scalar in the symmetric updating formula.\n*\n*  DLAM   (output) REAL\n*         The computed lambda_I, the I-th updated eigenvalue.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ren-Cang Li, Computer Science Division, University of California\n*     at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  delta, dlam = NumRu::Lapack.slaed5( i, d, z, rho, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_i = argv[0];
  rblapack_d = argv[1];
  rblapack_z = argv[2];
  rblapack_rho = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  i = NUM2INT(rblapack_i);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (3th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != (2))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 2);
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != (2))
    rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", 2);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  rho = (real)NUM2DBL(rblapack_rho);
  {
    na_shape_t shape[1];
    shape[0] = 2;
    rblapack_delta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  delta = NA_PTR_TYPE(rblapack_delta, real*);

  slaed5_(&i, d, z, delta, &rho, &dlam);

  rblapack_dlam = rb_float_new((double)dlam);
  return rb_ary_new3(2, rblapack_delta, rblapack_dlam);
}

void
init_lapack_slaed5(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaed5", rblapack_slaed5, -1);
}
ruby-lapack-1.7.2/ext/zspsv.c0000644000175000017500000001650612502221025015717 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zspsv_(char* uplo, integer* n, integer* nrhs, doublecomplex* ap, integer* ipiv, doublecomplex* b, integer* ldb, integer* info);


static VALUE
rblapack_zspsv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublecomplex *ap_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer ldb;
  integer nrhs;
  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  ipiv, info, ap, b = NumRu::Lapack.zspsv( uplo, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZSPSV computes the solution to a complex system of linear equations\n*     A * X = B,\n*  where A is an N-by-N symmetric matrix stored in packed format and X\n*  and B are N-by-NRHS matrices.\n*\n*  The diagonal pivoting method is used to factor A as\n*     A = U * D * U**T,  if UPLO = 'U', or\n*     A = L * D * L**T,  if UPLO = 'L',\n*  where U (or L) is a product of permutation and unit upper (lower)\n*  triangular matrices, D is symmetric and block diagonal with 1-by-1\n*  and 2-by-2 diagonal blocks.  The factored form of A is then used to\n*  solve the system of equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          See below for further details.\n*\n*          On exit, the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L from the factorization\n*          A = U*D*U**T or A = L*D*L**T as computed by ZSPTRF, stored as\n*          a packed triangular matrix in the same storage format as A.\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D, as\n*          determined by ZSPTRF.  If IPIV(k) > 0, then rows and columns\n*          k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n*          diagonal block.  If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n*          then rows and columns k-1 and -IPIV(k) were interchanged and\n*          D(k-1:k,k-1:k) is a 2-by-2 diagonal block.  If UPLO = 'L' and\n*          IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n*          -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n*          diagonal block.\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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, D(i,i) is exactly zero.  The factorization\n*                has been completed, but the block diagonal matrix D is\n*                exactly singular, so the solution could not be\n*                computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  The packed storage scheme is illustrated by the following example\n*  when N = 4, UPLO = 'U':\n*\n*  Two-dimensional storage of the symmetric matrix A:\n*\n*     a11 a12 a13 a14\n*         a22 a23 a24\n*             a33 a34     (aij = aji)\n*                 a44\n*\n*  Packed storage of the upper triangle of A:\n*\n*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n*  =====================================================================\n*\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZSPTRF, ZSPTRS\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, ap, b = NumRu::Lapack.zspsv( uplo, ap, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_b = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  n = ldb;
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
  MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zspsv_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ipiv, rblapack_info, rblapack_ap, rblapack_b);
}

void
init_lapack_zspsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zspsv", rblapack_zspsv, -1);
}
ruby-lapack-1.7.2/ext/dlasq5.c0000644000175000017500000001103112502221015015706 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlasq5_(integer* i0, integer* n0, doublereal* z, integer* pp, doublereal* tau, doublereal* dmin, doublereal* dmin1, doublereal* dmin2, doublereal* dn, doublereal* dnm1, doublereal* dnm2, logical* ieee);


static VALUE
rblapack_dlasq5(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_i0;
  integer i0; 
  VALUE rblapack_n0;
  integer n0; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_pp;
  integer pp; 
  VALUE rblapack_tau;
  doublereal tau; 
  VALUE rblapack_ieee;
  logical ieee; 
  VALUE rblapack_dmin;
  doublereal dmin; 
  VALUE rblapack_dmin1;
  doublereal dmin1; 
  VALUE rblapack_dmin2;
  doublereal dmin2; 
  VALUE rblapack_dn;
  doublereal dn; 
  VALUE rblapack_dnm1;
  doublereal dnm1; 
  VALUE rblapack_dnm2;
  doublereal dnm2; 


  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  dmin, dmin1, dmin2, dn, dnm1, dnm2 = NumRu::Lapack.dlasq5( i0, n0, z, pp, tau, ieee, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, IEEE )\n\n*  Purpose\n*  =======\n*\n*  DLASQ5 computes one dqds transform in ping-pong form, one\n*  version for IEEE machines another for non IEEE machines.\n*\n\n*  Arguments\n*  =========\n*\n*  I0    (input) INTEGER\n*        First index.\n*\n*  N0    (input) INTEGER\n*        Last index.\n*\n*  Z     (input) DOUBLE PRECISION array, dimension ( 4*N )\n*        Z holds the qd array. EMIN is stored in Z(4*N0) to avoid\n*        an extra argument.\n*\n*  PP    (input) INTEGER\n*        PP=0 for ping, PP=1 for pong.\n*\n*  TAU   (input) DOUBLE PRECISION\n*        This is the shift.\n*\n*  DMIN  (output) DOUBLE PRECISION\n*        Minimum value of d.\n*\n*  DMIN1 (output) DOUBLE PRECISION\n*        Minimum value of d, excluding D( N0 ).\n*\n*  DMIN2 (output) DOUBLE PRECISION\n*        Minimum value of d, excluding D( N0 ) and D( N0-1 ).\n*\n*  DN    (output) DOUBLE PRECISION\n*        d(N0), the last value of d.\n*\n*  DNM1  (output) DOUBLE PRECISION\n*        d(N0-1).\n*\n*  DNM2  (output) DOUBLE PRECISION\n*        d(N0-2).\n*\n*  IEEE  (input) LOGICAL\n*        Flag for IEEE or non IEEE arithmetic.\n*\n\n*  =====================================================================\n*\n*     .. Parameter ..\n      DOUBLE PRECISION   ZERO\n      PARAMETER          ( ZERO = 0.0D0 )\n*     ..\n*     .. Local Scalars ..\n      INTEGER            J4, J4P2\n      DOUBLE PRECISION   D, EMIN, TEMP\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  dmin, dmin1, dmin2, dn, dnm1, dnm2 = NumRu::Lapack.dlasq5( i0, n0, z, pp, tau, ieee, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_i0 = argv[0];
  rblapack_n0 = argv[1];
  rblapack_z = argv[2];
  rblapack_pp = argv[3];
  rblapack_tau = argv[4];
  rblapack_ieee = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  i0 = NUM2INT(rblapack_i0);
  pp = NUM2INT(rblapack_pp);
  ieee = (rblapack_ieee == Qtrue);
  n0 = NUM2INT(rblapack_n0);
  tau = NUM2DBL(rblapack_tau);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (3th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != (4*n0))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 4*n0);
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);

  dlasq5_(&i0, &n0, z, &pp, &tau, &dmin, &dmin1, &dmin2, &dn, &dnm1, &dnm2, &ieee);

  rblapack_dmin = rb_float_new((double)dmin);
  rblapack_dmin1 = rb_float_new((double)dmin1);
  rblapack_dmin2 = rb_float_new((double)dmin2);
  rblapack_dn = rb_float_new((double)dn);
  rblapack_dnm1 = rb_float_new((double)dnm1);
  rblapack_dnm2 = rb_float_new((double)dnm2);
  return rb_ary_new3(6, rblapack_dmin, rblapack_dmin1, rblapack_dmin2, rblapack_dn, rblapack_dnm1, rblapack_dnm2);
}

void
init_lapack_dlasq5(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlasq5", rblapack_dlasq5, -1);
}
ruby-lapack-1.7.2/ext/dggrqf.c0000644000175000017500000002346712502221022016005 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dggrqf_(integer* m, integer* p, integer* n, doublereal* a, integer* lda, doublereal* taua, doublereal* b, integer* ldb, doublereal* taub, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dggrqf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_p;
  integer p; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_taua;
  doublereal *taua; 
  VALUE rblapack_taub;
  doublereal *taub; 
  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 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  taua, taub, work, info, a, b = NumRu::Lapack.dggrqf( m, p, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGGRQF computes a generalized RQ factorization of an M-by-N matrix A\n*  and a P-by-N matrix B:\n*\n*              A = R*Q,        B = Z*T*Q,\n*\n*  where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal\n*  matrix, and R and T assume one of the forms:\n*\n*  if M <= N,  R = ( 0  R12 ) M,   or if M > N,  R = ( R11 ) M-N,\n*                   N-M  M                           ( R21 ) N\n*                                                       N\n*\n*  where R12 or R21 is upper triangular, and\n*\n*  if P >= N,  T = ( T11 ) N  ,   or if P < N,  T = ( T11  T12 ) P,\n*                  (  0  ) P-N                         P   N-P\n*                     N\n*\n*  where T11 is upper triangular.\n*\n*  In particular, if B is square and nonsingular, the GRQ factorization\n*  of A and B implicitly gives the RQ factorization of A*inv(B):\n*\n*               A*inv(B) = (R*inv(T))*Z'\n*\n*  where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n*  transpose of the matrix Z.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.  M >= 0.\n*\n*  P       (input) INTEGER\n*          The number of rows of the matrix B.  P >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrices A and B. 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, if M <= N, the upper triangle of the subarray\n*          A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;\n*          if M > N, the elements on and above the (M-N)-th subdiagonal\n*          contain the M-by-N upper trapezoidal matrix R; the remaining\n*          elements, with the array TAUA, represent the orthogonal\n*          matrix Q as a product of elementary reflectors (see Further\n*          Details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  TAUA    (output) DOUBLE PRECISION array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors which\n*          represent the orthogonal matrix Q (see Further Details).\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)\n*          On entry, the P-by-N matrix B.\n*          On exit, the elements on and above the diagonal of the array\n*          contain the min(P,N)-by-N upper trapezoidal matrix T (T is\n*          upper triangular if P >= N); the elements below the diagonal,\n*          with the array TAUB, represent the orthogonal matrix Z as a\n*          product of elementary reflectors (see Further Details).\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,P).\n*\n*  TAUB    (output) DOUBLE PRECISION array, dimension (min(P,N))\n*          The scalar factors of the elementary reflectors which\n*          represent the orthogonal matrix Z (see Further 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,N,M,P).\n*          For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n*          where NB1 is the optimal blocksize for the RQ factorization\n*          of an M-by-N matrix, NB2 is the optimal blocksize for the\n*          QR factorization of a P-by-N matrix, and NB3 is the optimal\n*          blocksize for a call of DORMRQ.\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 INF0= -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(1) H(2) . . . H(k), where k = min(m,n).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - taua * v * v'\n*\n*  where taua is a real scalar, and v is a real vector with\n*  v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n*  A(m-k+i,1:n-k+i-1), and taua in TAUA(i).\n*  To form Q explicitly, use LAPACK subroutine DORGRQ.\n*  To use Q to update another matrix, use LAPACK subroutine DORMRQ.\n*\n*  The matrix Z is represented as a product of elementary reflectors\n*\n*     Z = H(1) H(2) . . . H(k), where k = min(p,n).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - taub * v * v'\n*\n*  where taub is a real scalar, and v is a real vector with\n*  v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),\n*  and taub in TAUB(i).\n*  To form Z explicitly, use LAPACK subroutine DORGQR.\n*  To use Z to update another matrix, use LAPACK subroutine DORMQR.\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY\n      INTEGER            LOPT, LWKOPT, NB, NB1, NB2, NB3\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DGEQRF, DGERQF, DORMRQ, XERBLA\n*     ..\n*     .. External Functions ..\n      INTEGER            ILAENV\n      EXTERNAL           ILAENV\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          INT, MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  taua, taub, work, info, a, b = NumRu::Lapack.dggrqf( m, p, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_m = argv[0];
  rblapack_p = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  p = NUM2INT(rblapack_p);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  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 = MAX(MAX(n,m),p);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_taua = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  taua = NA_PTR_TYPE(rblapack_taua, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(p,n);
    rblapack_taub = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  taub = NA_PTR_TYPE(rblapack_taub, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dggrqf_(&m, &p, &n, a, &lda, taua, b, &ldb, taub, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_taua, rblapack_taub, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_dggrqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dggrqf", rblapack_dggrqf, -1);
}
ruby-lapack-1.7.2/ext/spbsvx.c0000644000175000017500000003775012502221023016061 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID spbsvx_(char* fact, char* uplo, integer* n, integer* kd, integer* nrhs, real* ab, integer* ldab, real* afb, integer* ldafb, char* equed, real* s, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* ferr, real* berr, real* work, integer* iwork, integer* info);


static VALUE
rblapack_spbsvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_afb;
  real *afb; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  real *ab_out__;
  VALUE rblapack_afb_out__;
  real *afb_out__;
  VALUE rblapack_s_out__;
  real *s_out__;
  VALUE rblapack_b_out__;
  real *b_out__;
  real *work;
  integer *iwork;

  integer ldab;
  integer n;
  integer ldafb;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, info, ab, afb, equed, s, b = NumRu::Lapack.spbsvx( fact, uplo, kd, ab, afb, equed, s, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPBSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to\n*  compute the solution to a real system of linear equations\n*     A * X = B,\n*  where A is an N-by-N symmetric positive definite band matrix and X\n*  and B are N-by-NRHS matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'E', real scaling factors are computed to equilibrate\n*     the system:\n*        diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n*  2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n*     factor the matrix A (after equilibration if FACT = 'E') as\n*        A = U**T * U,  if UPLO = 'U', or\n*        A = L * L**T,  if UPLO = 'L',\n*     where U is an upper triangular band matrix, and L is a lower\n*     triangular band matrix.\n*\n*  3. If the leading i-by-i principal minor is not positive definite,\n*     then the routine returns with INFO = i. Otherwise, the factored\n*     form of A is used to estimate the condition number of the matrix\n*     A.  If the reciprocal of the condition number is less than machine\n*     precision, INFO = N+1 is returned as a warning, but the routine\n*     still goes on to solve for X and compute error bounds as\n*     described below.\n*\n*  4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  5. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n*  6. If equilibration was used, the matrix X is premultiplied by\n*     diag(S) so that it solves the original system before\n*     equilibration.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of the matrix A is\n*          supplied on entry, and if not, whether the matrix A should be\n*          equilibrated before it is factored.\n*          = 'F':  On entry, AFB contains the factored form of A.\n*                  If EQUED = 'Y', the matrix A has been equilibrated\n*                  with scaling factors given by S.  AB and AFB will not\n*                  be modified.\n*          = 'N':  The matrix A will be copied to AFB and factored.\n*          = 'E':  The matrix A will be equilibrated if necessary, then\n*                  copied to AFB and factored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right-hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AB      (input/output) REAL array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first KD+1 rows of the array, except\n*          if FACT = 'F' and EQUED = 'Y', then A must contain the\n*          equilibrated matrix diag(S)*A*diag(S).  The j-th column of A\n*          is stored in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(N,j+KD).\n*          See below for further details.\n*\n*          On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n*          diag(S)*A*diag(S).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array A.  LDAB >= KD+1.\n*\n*  AFB     (input or output) REAL array, dimension (LDAFB,N)\n*          If FACT = 'F', then AFB is an input argument and on entry\n*          contains the triangular factor U or L from the Cholesky\n*          factorization A = U**T*U or A = L*L**T of the band matrix\n*          A, in the same storage format as A (see AB).  If EQUED = 'Y',\n*          then AFB is the factored form of the equilibrated matrix A.\n*\n*          If FACT = 'N', then AFB is an output argument and on exit\n*          returns the triangular factor U or L from the Cholesky\n*          factorization A = U**T*U or A = L*L**T.\n*\n*          If FACT = 'E', then AFB is an output argument and on exit\n*          returns the triangular factor U or L from the Cholesky\n*          factorization A = U**T*U or A = L*L**T of the equilibrated\n*          matrix A (see the description of A for the form of the\n*          equilibrated matrix).\n*\n*  LDAFB   (input) INTEGER\n*          The leading dimension of the array AFB.  LDAFB >= KD+1.\n*\n*  EQUED   (input or output) CHARACTER*1\n*          Specifies the form of equilibration that was done.\n*          = 'N':  No equilibration (always true if FACT = 'N').\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*          EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*          output argument.\n*\n*  S       (input or output) REAL array, dimension (N)\n*          The scale factors for A; not accessed if EQUED = 'N'.  S is\n*          an input argument if FACT = 'F'; otherwise, S is an output\n*          argument.  If FACT = 'F' and EQUED = 'Y', each element of S\n*          must be positive.\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n*          B is overwritten by diag(S) * B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) REAL array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n*          the original system of equations.  Note that if EQUED = 'Y',\n*          A and B are modified on exit, and the solution to the\n*          equilibrated system is inv(diag(S))*X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) REAL\n*          The estimate of the reciprocal condition number of the matrix\n*          A after equilibration (if done).  If RCOND is less than the\n*          machine precision (in particular, if RCOND = 0), the matrix\n*          is singular to working precision.  This condition is\n*          indicated by a return code of INFO > 0.\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) REAL array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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, and i is\n*                <= N:  the leading minor of order i of A is\n*                       not positive definite, so the factorization\n*                       could not be completed, and the solution has not\n*                       been computed. RCOND = 0 is returned.\n*                = N+1: U is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  N = 6, KD = 2, and UPLO = 'U':\n*\n*  Two-dimensional storage of the symmetric matrix A:\n*\n*     a11  a12  a13\n*          a22  a23  a24\n*               a33  a34  a35\n*                    a44  a45  a46\n*                         a55  a56\n*     (aij=conjg(aji))         a66\n*\n*  Band storage of the upper triangle of A:\n*\n*      *    *   a13  a24  a35  a46\n*      *   a12  a23  a34  a45  a56\n*     a11  a22  a33  a44  a55  a66\n*\n*  Similarly, if UPLO = 'L' the format of A is as follows:\n*\n*     a11  a22  a33  a44  a55  a66\n*     a21  a32  a43  a54  a65   *\n*     a31  a42  a53  a64   *    *\n*\n*  Array elements marked * are not used by the routine.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, info, ab, afb, equed, s, b = NumRu::Lapack.spbsvx( fact, uplo, kd, ab, afb, equed, s, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_kd = argv[2];
  rblapack_ab = argv[3];
  rblapack_afb = argv[4];
  rblapack_equed = argv[5];
  rblapack_s = argv[6];
  rblapack_b = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  kd = NUM2INT(rblapack_kd);
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
  ldafb = NA_SHAPE0(rblapack_afb);
  n = NA_SHAPE1(rblapack_afb);
  if (NA_TYPE(rblapack_afb) != NA_SFLOAT)
    rblapack_afb = na_change_type(rblapack_afb, NA_SFLOAT);
  afb = NA_PTR_TYPE(rblapack_afb, real*);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (7th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  ldx = MAX(1,n);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
  MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldafb;
    shape[1] = n;
    rblapack_afb_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  afb_out__ = NA_PTR_TYPE(rblapack_afb_out__, real*);
  MEMCPY(afb_out__, afb, real, NA_TOTAL(rblapack_afb));
  rblapack_afb = rblapack_afb_out__;
  afb = afb_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
  MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(real, (3*n));
  iwork = ALLOC_N(integer, (n));

  spbsvx_(&fact, &uplo, &n, &kd, &nrhs, ab, &ldab, afb, &ldafb, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_ab, rblapack_afb, rblapack_equed, rblapack_s, rblapack_b);
}

void
init_lapack_spbsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "spbsvx", rblapack_spbsvx, -1);
}
ruby-lapack-1.7.2/ext/clarfgp.c0000644000175000017500000001023512502221017016142 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clarfgp_(integer* n, complex* alpha, complex* x, integer* incx, complex* tau);


static VALUE
rblapack_clarfgp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_alpha;
  complex alpha; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_tau;
  complex tau; 
  VALUE rblapack_x_out__;
  complex *x_out__;


  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, alpha, x = NumRu::Lapack.clarfgp( n, alpha, x, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLARFGP( N, ALPHA, X, INCX, TAU )\n\n*  Purpose\n*  =======\n*\n*  CLARFGP generates a complex elementary reflector H of order n, such\n*  that\n*\n*        H' * ( alpha ) = ( beta ),   H' * H = I.\n*             (   x   )   (   0  )\n*\n*  where alpha and beta are scalars, beta is real and non-negative, and\n*  x is an (n-1)-element complex vector.  H is represented in the form\n*\n*        H = I - tau * ( 1 ) * ( 1 v' ) ,\n*                      ( v )\n*\n*  where tau is a complex scalar and v is a complex (n-1)-element\n*  vector. Note that H is not hermitian.\n*\n*  If the elements of x are all zero and alpha is real, then tau = 0\n*  and H is taken to be the unit matrix.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the elementary reflector.\n*\n*  ALPHA   (input/output) COMPLEX\n*          On entry, the value alpha.\n*          On exit, it is overwritten with the value beta.\n*\n*  X       (input/output) COMPLEX array, dimension\n*                         (1+(N-2)*abs(INCX))\n*          On entry, the vector x.\n*          On exit, it is overwritten with the vector v.\n*\n*  INCX    (input) INTEGER\n*          The increment between elements of X. INCX > 0.\n*\n*  TAU     (output) COMPLEX\n*          The value tau.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, alpha, x = NumRu::Lapack.clarfgp( n, alpha, x, incx, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_n = argv[0];
  rblapack_alpha = argv[1];
  rblapack_x = argv[2];
  rblapack_incx = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  incx = NUM2INT(rblapack_incx);
  alpha.r = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
  alpha.i = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (3th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1+(n-2)*abs(incx)))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-2)*abs(incx));
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-2)*abs(incx);
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;

  clarfgp_(&n, &alpha, x, &incx, &tau);

  rblapack_tau = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(tau.r)), rb_float_new((double)(tau.i)));
  rblapack_alpha = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(alpha.r)), rb_float_new((double)(alpha.i)));
  return rb_ary_new3(3, rblapack_tau, rblapack_alpha, rblapack_x);
}

void
init_lapack_clarfgp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clarfgp", rblapack_clarfgp, -1);
}
ruby-lapack-1.7.2/ext/ilaclr.c0000644000175000017500000000457712502221015016004 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern integer ilaclr_(integer* m, integer* n, complex* a, integer* lda);


static VALUE
rblapack_ilaclr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack___out__;
  integer __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  __out__ = NumRu::Lapack.ilaclr( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      INTEGER FUNCTION ILACLR( M, N, A, LDA )\n\n*  Purpose\n*  =======\n*\n*  ILACLR scans A for its last non-zero row.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.\n*\n*  A       (input) COMPLEX          array, dimension (LDA,N)\n*          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\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.ilaclr( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);

  __out__ = ilaclr_(&m, &n, a, &lda);

  rblapack___out__ = INT2NUM(__out__);
  return rblapack___out__;
}

void
init_lapack_ilaclr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ilaclr", rblapack_ilaclr, -1);
}
ruby-lapack-1.7.2/ext/ilaslc.c0000644000175000017500000000455112502221026015777 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern integer ilaslc_(integer* m, integer* n, real* a, integer* lda);


static VALUE
rblapack_ilaslc(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack___out__;
  integer __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  __out__ = NumRu::Lapack.ilaslc( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      INTEGER FUNCTION ILASLC( M, N, A, LDA )\n\n*  Purpose\n*  =======\n*\n*  ILASLC scans A for its last non-zero column.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.\n*\n*  A       (input) REAL array, dimension (LDA,N)\n*          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\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.ilaslc( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);

  __out__ = ilaslc_(&m, &n, a, &lda);

  rblapack___out__ = INT2NUM(__out__);
  return rblapack___out__;
}

void
init_lapack_ilaslc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ilaslc", rblapack_ilaslc, -1);
}
ruby-lapack-1.7.2/ext/cpoequb.c0000644000175000017500000000777112502221025016174 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cpoequb_(integer* n, complex* a, integer* lda, real* s, real* scond, real* amax, integer* info);


static VALUE
rblapack_cpoequb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_scond;
  real scond; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_info;
  integer info; 

  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  s, scond, amax, info = NumRu::Lapack.cpoequb( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPOEQUB computes row and column scalings intended to equilibrate a\n*  symmetric positive definite matrix A and reduce its condition number\n*  (with respect to the two-norm).  S contains the scale factors,\n*  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n*  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This\n*  choice of S puts the condition number of B within a factor N of the\n*  smallest possible condition number over all possible diagonal\n*  scalings.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The N-by-N symmetric positive definite matrix whose scaling\n*          factors are to be computed.  Only the diagonal elements of A\n*          are referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  S       (output) REAL array, dimension (N)\n*          If INFO = 0, S contains the scale factors for A.\n*\n*  SCOND   (output) REAL\n*          If INFO = 0, S contains the ratio of the smallest S(i) to\n*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too\n*          large nor too small, it is not worth scaling by S.\n*\n*  AMAX    (output) REAL\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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 is nonpositive.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, scond, amax, info = NumRu::Lapack.cpoequb( 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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, real*);

  cpoequb_(&n, a, &lda, s, &scond, &amax, &info);

  rblapack_scond = rb_float_new((double)scond);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
}

void
init_lapack_cpoequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cpoequb", rblapack_cpoequb, -1);
}
ruby-lapack-1.7.2/ext/csteqr.c0000644000175000017500000001526212502221022016026 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID csteqr_(char* compz, integer* n, real* d, real* e, complex* z, integer* ldz, real* work, integer* info);


static VALUE
rblapack_csteqr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_compz;
  char compz; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_e_out__;
  real *e_out__;
  VALUE rblapack_z_out__;
  complex *z_out__;
  real *work;

  integer n;
  integer ldz;

  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  info, d, e, z = NumRu::Lapack.csteqr( compz, d, e, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CSTEQR computes all eigenvalues and, optionally, eigenvectors of a\n*  symmetric tridiagonal matrix using the implicit QL or QR method.\n*  The eigenvectors of a full or band complex Hermitian matrix can also\n*  be found if CHETRD or CHPTRD or CHBTRD has been used to reduce this\n*  matrix to tridiagonal form.\n*\n\n*  Arguments\n*  =========\n*\n*  COMPZ   (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only.\n*          = 'V':  Compute eigenvalues and eigenvectors of the original\n*                  Hermitian matrix.  On entry, Z must contain the\n*                  unitary matrix used to reduce the original matrix\n*                  to tridiagonal form.\n*          = 'I':  Compute eigenvalues and eigenvectors of the\n*                  tridiagonal matrix.  Z is initialized to the identity\n*                  matrix.\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  D       (input/output) REAL array, dimension (N)\n*          On entry, the diagonal elements of the tridiagonal matrix.\n*          On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n*  E       (input/output) REAL array, dimension (N-1)\n*          On entry, the (n-1) subdiagonal elements of the tridiagonal\n*          matrix.\n*          On exit, E has been destroyed.\n*\n*  Z       (input/output) COMPLEX array, dimension (LDZ, N)\n*          On entry, if  COMPZ = 'V', then Z contains the unitary\n*          matrix used in the reduction to tridiagonal form.\n*          On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n*          orthonormal eigenvectors of the original Hermitian matrix,\n*          and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n*          of the symmetric tridiagonal matrix.\n*          If COMPZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          eigenvectors are desired, then  LDZ >= max(1,N).\n*\n*  WORK    (workspace) REAL array, dimension (max(1,2*N-2))\n*          If COMPZ = 'N', then WORK is not referenced.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  the algorithm has failed to find all the eigenvalues in\n*                a total of 30*N iterations; if INFO = i, then i\n*                elements of E have not converged to zero; on exit, D\n*                and E contain the elements of a symmetric tridiagonal\n*                matrix which is unitarily similar to the original\n*                matrix.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, e, z = NumRu::Lapack.csteqr( compz, d, e, z, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_compz = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  rblapack_z = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  compz = StringValueCStr(rblapack_compz)[0];
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (4th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  n = NA_SHAPE1(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, complex*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of z");
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
  MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
  MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  work = ALLOC_N(real, (lsame_(&compz,"N") ? 0 : MAX(1,2*n-2)));

  csteqr_(&compz, &n, d, e, z, &ldz, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_e, rblapack_z);
}

void
init_lapack_csteqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "csteqr", rblapack_csteqr, -1);
}
ruby-lapack-1.7.2/ext/sppsvx.c0000644000175000017500000003606212502221012016070 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sppsvx_(char* fact, char* uplo, integer* n, integer* nrhs, real* ap, real* afp, char* equed, real* s, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* ferr, real* berr, real* work, integer* iwork, integer* info);


static VALUE
rblapack_sppsvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_afp;
  real *afp; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  real *ap_out__;
  VALUE rblapack_afp_out__;
  real *afp_out__;
  VALUE rblapack_s_out__;
  real *s_out__;
  VALUE rblapack_b_out__;
  real *b_out__;
  real *work;
  integer *iwork;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, info, ap, afp, equed, s, b = NumRu::Lapack.sppsvx( fact, uplo, ap, afp, equed, s, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPPSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to\n*  compute the solution to a real system of linear equations\n*     A * X = B,\n*  where A is an N-by-N symmetric positive definite matrix stored in\n*  packed format and X and B are N-by-NRHS matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'E', real scaling factors are computed to equilibrate\n*     the system:\n*        diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n*  2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n*     factor the matrix A (after equilibration if FACT = 'E') as\n*        A = U**T* U,  if UPLO = 'U', or\n*        A = L * L**T,  if UPLO = 'L',\n*     where U is an upper triangular matrix and L is a lower triangular\n*     matrix.\n*\n*  3. If the leading i-by-i principal minor is not positive definite,\n*     then the routine returns with INFO = i. Otherwise, the factored\n*     form of A is used to estimate the condition number of the matrix\n*     A.  If the reciprocal of the condition number is less than machine\n*     precision, INFO = N+1 is returned as a warning, but the routine\n*     still goes on to solve for X and compute error bounds as\n*     described below.\n*\n*  4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  5. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n*  6. If equilibration was used, the matrix X is premultiplied by\n*     diag(S) so that it solves the original system before\n*     equilibration.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of the matrix A is\n*          supplied on entry, and if not, whether the matrix A should be\n*          equilibrated before it is factored.\n*          = 'F':  On entry, AFP contains the factored form of A.\n*                  If EQUED = 'Y', the matrix A has been equilibrated\n*                  with scaling factors given by S.  AP and AFP will not\n*                  be modified.\n*          = 'N':  The matrix A will be copied to AFP and factored.\n*          = 'E':  The matrix A will be equilibrated if necessary, then\n*                  copied to AFP and factored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AP      (input/output) REAL array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array, except if FACT = 'F'\n*          and EQUED = 'Y', then A must contain the equilibrated matrix\n*          diag(S)*A*diag(S).  The j-th column of A is stored in the\n*          array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          See below for further details.  A is not modified if\n*          FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n*          On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n*          diag(S)*A*diag(S).\n*\n*  AFP     (input or output) REAL array, dimension\n*                            (N*(N+1)/2)\n*          If FACT = 'F', then AFP is an input argument and on entry\n*          contains the triangular factor U or L from the Cholesky\n*          factorization A = U'*U or A = L*L', in the same storage\n*          format as A.  If EQUED .ne. 'N', then AFP is the factored\n*          form of the equilibrated matrix A.\n*\n*          If FACT = 'N', then AFP is an output argument and on exit\n*          returns the triangular factor U or L from the Cholesky\n*          factorization A = U'*U or A = L*L' of the original matrix A.\n*\n*          If FACT = 'E', then AFP is an output argument and on exit\n*          returns the triangular factor U or L from the Cholesky\n*          factorization A = U'*U or A = L*L' of the equilibrated\n*          matrix A (see the description of AP for the form of the\n*          equilibrated matrix).\n*\n*  EQUED   (input or output) CHARACTER*1\n*          Specifies the form of equilibration that was done.\n*          = 'N':  No equilibration (always true if FACT = 'N').\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*          EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*          output argument.\n*\n*  S       (input or output) REAL array, dimension (N)\n*          The scale factors for A; not accessed if EQUED = 'N'.  S is\n*          an input argument if FACT = 'F'; otherwise, S is an output\n*          argument.  If FACT = 'F' and EQUED = 'Y', each element of S\n*          must be positive.\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n*          B is overwritten by diag(S) * B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) REAL array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n*          the original system of equations.  Note that if EQUED = 'Y',\n*          A and B are modified on exit, and the solution to the\n*          equilibrated system is inv(diag(S))*X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) REAL\n*          The estimate of the reciprocal condition number of the matrix\n*          A after equilibration (if done).  If RCOND is less than the\n*          machine precision (in particular, if RCOND = 0), the matrix\n*          is singular to working precision.  This condition is\n*          indicated by a return code of INFO > 0.\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) REAL array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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, and i is\n*                <= N:  the leading minor of order i of A is\n*                       not positive definite, so the factorization\n*                       could not be completed, and the solution has not\n*                       been computed. RCOND = 0 is returned.\n*                = N+1: U is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  Further Details\n*  ===============\n*\n*  The packed storage scheme is illustrated by the following example\n*  when N = 4, UPLO = 'U':\n*\n*  Two-dimensional storage of the symmetric matrix A:\n*\n*     a11 a12 a13 a14\n*         a22 a23 a24\n*             a33 a34     (aij = conjg(aji))\n*                 a44\n*\n*  Packed storage of the upper triangle of A:\n*\n*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, info, ap, afp, equed, s, b = NumRu::Lapack.sppsvx( fact, uplo, ap, afp, equed, s, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_ap = argv[2];
  rblapack_afp = argv[3];
  rblapack_equed = argv[4];
  rblapack_s = argv[5];
  rblapack_b = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (6th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_s);
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  ldx = MAX(1,n);
  if (!NA_IsNArray(rblapack_afp))
    rb_raise(rb_eArgError, "afp (4th argument) must be NArray");
  if (NA_RANK(rblapack_afp) != 1)
    rb_raise(rb_eArgError, "rank of afp (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_afp) != NA_SFLOAT)
    rblapack_afp = na_change_type(rblapack_afp, NA_SFLOAT);
  afp = NA_PTR_TYPE(rblapack_afp, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, real*);
  MEMCPY(ap_out__, ap, real, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_afp_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  afp_out__ = NA_PTR_TYPE(rblapack_afp_out__, real*);
  MEMCPY(afp_out__, afp, real, NA_TOTAL(rblapack_afp));
  rblapack_afp = rblapack_afp_out__;
  afp = afp_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
  MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(real, (3*n));
  iwork = ALLOC_N(integer, (n));

  sppsvx_(&fact, &uplo, &n, &nrhs, ap, afp, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_ap, rblapack_afp, rblapack_equed, rblapack_s, rblapack_b);
}

void
init_lapack_sppsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sppsvx", rblapack_sppsvx, -1);
}
ruby-lapack-1.7.2/ext/zunmrz.c0000644000175000017500000001723312502221020016070 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zunmrz_(char* side, char* trans, integer* m, integer* n, integer* k, integer* l, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zunmrz(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_c;
  doublecomplex *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublecomplex *c_out__;

  integer lda;
  integer m;
  integer k;
  integer ldc;
  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  work, info, c = NumRu::Lapack.zunmrz( side, trans, l, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZUNMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZUNMRZ overwrites the general complex M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'C':      Q**H * C       C * Q**H\n*\n*  where Q is a complex unitary matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(1) H(2) . . . H(k)\n*\n*  as returned by ZTZRZF. Q is of order M if SIDE = 'L' and of order N\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**H from the Left;\n*          = 'R': apply Q or Q**H from the Right.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'C':  Conjugate transpose, apply Q**H.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  L       (input) INTEGER\n*          The number of columns of the matrix A containing\n*          the meaningful part of the Householder reflectors.\n*          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension\n*                               (LDA,M) if SIDE = 'L',\n*                               (LDA,N) if SIDE = 'R'\n*          The i-th row must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          ZTZRZF in the last k rows of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,K).\n*\n*  TAU     (input) COMPLEX*16 array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by ZTZRZF.\n*\n*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace/output) COMPLEX*16 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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M).\n*          For optimum performance LWORK >= N*NB if SIDE = 'L', and\n*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n*          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*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.zunmrz( side, trans, l, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_l = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 7) {
    rblapack_lwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  side = StringValueCStr(rblapack_side)[0];
  l = NUM2INT(rblapack_l);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
  MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  zunmrz_(&side, &trans, &m, &n, &k, &l, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_zunmrz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zunmrz", rblapack_zunmrz, -1);
}
ruby-lapack-1.7.2/ext/dsysv.c0000644000175000017500000002041512502221013015671 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsysv_(char* uplo, integer* n, integer* nrhs, doublereal* a, integer* lda, integer* ipiv, doublereal* b, integer* ldb, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dsysv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  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 ldb;
  integer nrhs;

  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  ipiv, work, info, a, b = NumRu::Lapack.dsysv( uplo, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSYSV computes the solution to a real system of linear equations\n*     A * X = B,\n*  where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n*  matrices.\n*\n*  The diagonal pivoting method is used to factor A as\n*     A = U * D * U**T,  if UPLO = 'U', or\n*     A = L * D * L**T,  if UPLO = 'L',\n*  where U (or L) is a product of permutation and unit upper (lower)\n*  triangular matrices, and D is symmetric and block diagonal with\n*  1-by-1 and 2-by-2 diagonal blocks.  The factored form of A is then\n*  used to solve the system of equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the block diagonal matrix D and the\n*          multipliers used to obtain the factor U or L from the\n*          factorization A = U*D*U**T or A = L*D*L**T as computed by\n*          DSYTRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D, as\n*          determined by DSYTRF.  If IPIV(k) > 0, then rows and columns\n*          k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n*          diagonal block.  If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n*          then rows and columns k-1 and -IPIV(k) were interchanged and\n*          D(k-1:k,k-1:k) is a 2-by-2 diagonal block.  If UPLO = 'L' and\n*          IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n*          -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n*          diagonal block.\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,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 length of WORK.  LWORK >= 1, and for best performance\n*          LWORK >= max(1,N*NB), where NB is the optimal blocksize for\n*          DSYTRF.\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, D(i,i) is exactly zero.  The factorization\n*               has been completed, but the block diagonal matrix D is\n*               exactly singular, so the solution could not be computed.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY\n      INTEGER            LWKOPT, NB\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            ILAENV\n      EXTERNAL           LSAME, ILAENV\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DSYTRF, DSYTRS2, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, work, info, a, b = NumRu::Lapack.dsysv( uplo, 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_uplo = 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;
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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);
  ldb = NA_SHAPE0(rblapack_b);
  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 (!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*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dsysv_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_ipiv, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_dsysv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsysv", rblapack_dsysv, -1);
}
ruby-lapack-1.7.2/ext/dhsein.c0000644000175000017500000003422712502221017016005 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dhsein_(char* side, char* eigsrc, char* initv, logical* select, integer* n, doublereal* h, integer* ldh, doublereal* wr, doublereal* wi, doublereal* vl, integer* ldvl, doublereal* vr, integer* ldvr, integer* mm, integer* m, doublereal* work, integer* ifaill, integer* ifailr, integer* info);


static VALUE
rblapack_dhsein(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_eigsrc;
  char eigsrc; 
  VALUE rblapack_initv;
  char initv; 
  VALUE rblapack_select;
  logical *select; 
  VALUE rblapack_h;
  doublereal *h; 
  VALUE rblapack_wr;
  doublereal *wr; 
  VALUE rblapack_wi;
  doublereal *wi; 
  VALUE rblapack_vl;
  doublereal *vl; 
  VALUE rblapack_vr;
  doublereal *vr; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_ifaill;
  integer *ifaill; 
  VALUE rblapack_ifailr;
  integer *ifailr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_select_out__;
  logical *select_out__;
  VALUE rblapack_wr_out__;
  doublereal *wr_out__;
  VALUE rblapack_vl_out__;
  doublereal *vl_out__;
  VALUE rblapack_vr_out__;
  doublereal *vr_out__;
  doublereal *work;

  integer n;
  integer ldh;
  integer ldvl;
  integer mm;
  integer ldvr;

  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  m, ifaill, ifailr, info, select, wr, vl, vr = NumRu::Lapack.dhsein( side, eigsrc, initv, select, h, wr, wi, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI, VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL, IFAILR, INFO )\n\n*  Purpose\n*  =======\n*\n*  DHSEIN uses inverse iteration to find specified right and/or left\n*  eigenvectors of a real upper Hessenberg matrix H.\n*\n*  The right eigenvector x and the left eigenvector y of the matrix H\n*  corresponding to an eigenvalue w are defined by:\n*\n*               H * x = w * x,     y**h * H = w * y**h\n*\n*  where y**h denotes the conjugate transpose of the vector y.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'R': compute right eigenvectors only;\n*          = 'L': compute left eigenvectors only;\n*          = 'B': compute both right and left eigenvectors.\n*\n*  EIGSRC  (input) CHARACTER*1\n*          Specifies the source of eigenvalues supplied in (WR,WI):\n*          = 'Q': the eigenvalues were found using DHSEQR; thus, if\n*                 H has zero subdiagonal elements, and so is\n*                 block-triangular, then the j-th eigenvalue can be\n*                 assumed to be an eigenvalue of the block containing\n*                 the j-th row/column.  This property allows DHSEIN to\n*                 perform inverse iteration on just one diagonal block.\n*          = 'N': no assumptions are made on the correspondence\n*                 between eigenvalues and diagonal blocks.  In this\n*                 case, DHSEIN must always perform inverse iteration\n*                 using the whole matrix H.\n*\n*  INITV   (input) CHARACTER*1\n*          = 'N': no initial vectors are supplied;\n*          = 'U': user-supplied initial vectors are stored in the arrays\n*                 VL and/or VR.\n*\n*  SELECT  (input/output) LOGICAL array, dimension (N)\n*          Specifies the eigenvectors to be computed. To select the\n*          real eigenvector corresponding to a real eigenvalue WR(j),\n*          SELECT(j) must be set to .TRUE.. To select the complex\n*          eigenvector corresponding to a complex eigenvalue\n*          (WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)),\n*          either SELECT(j) or SELECT(j+1) or both must be set to\n*          .TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is\n*          .FALSE..\n*\n*  N       (input) INTEGER\n*          The order of the matrix H.  N >= 0.\n*\n*  H       (input) DOUBLE PRECISION array, dimension (LDH,N)\n*          The upper Hessenberg matrix H.\n*\n*  LDH     (input) INTEGER\n*          The leading dimension of the array H.  LDH >= max(1,N).\n*\n*  WR      (input/output) DOUBLE PRECISION array, dimension (N)\n*  WI      (input) DOUBLE PRECISION array, dimension (N)\n*          On entry, the real and imaginary parts of the eigenvalues of\n*          H; a complex conjugate pair of eigenvalues must be stored in\n*          consecutive elements of WR and WI.\n*          On exit, WR may have been altered since close eigenvalues\n*          are perturbed slightly in searching for independent\n*          eigenvectors.\n*\n*  VL      (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)\n*          On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must\n*          contain starting vectors for the inverse iteration for the\n*          left eigenvectors; the starting vector for each eigenvector\n*          must be in the same column(s) in which the eigenvector will\n*          be stored.\n*          On exit, if SIDE = 'L' or 'B', the left eigenvectors\n*          specified by SELECT will be stored consecutively in the\n*          columns of VL, in the same order as their eigenvalues. A\n*          complex eigenvector corresponding to a complex eigenvalue is\n*          stored in two consecutive columns, the first holding the real\n*          part and the second the imaginary part.\n*          If SIDE = 'R', VL is not referenced.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the array VL.\n*          LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.\n*\n*  VR      (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)\n*          On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must\n*          contain starting vectors for the inverse iteration for the\n*          right eigenvectors; the starting vector for each eigenvector\n*          must be in the same column(s) in which the eigenvector will\n*          be stored.\n*          On exit, if SIDE = 'R' or 'B', the right eigenvectors\n*          specified by SELECT will be stored consecutively in the\n*          columns of VR, in the same order as their eigenvalues. A\n*          complex eigenvector corresponding to a complex eigenvalue is\n*          stored in two consecutive columns, the first holding the real\n*          part and the second the imaginary part.\n*          If SIDE = 'L', VR is not referenced.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the array VR.\n*          LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.\n*\n*  MM      (input) INTEGER\n*          The number of columns in the arrays VL and/or VR. MM >= M.\n*\n*  M       (output) INTEGER\n*          The number of columns in the arrays VL and/or VR required to\n*          store the eigenvectors; each selected real eigenvector\n*          occupies one column and each selected complex eigenvector\n*          occupies two columns.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension ((N+2)*N)\n*\n*  IFAILL  (output) INTEGER array, dimension (MM)\n*          If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left\n*          eigenvector in the i-th column of VL (corresponding to the\n*          eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the\n*          eigenvector converged satisfactorily. If the i-th and (i+1)th\n*          columns of VL hold a complex eigenvector, then IFAILL(i) and\n*          IFAILL(i+1) are set to the same value.\n*          If SIDE = 'R', IFAILL is not referenced.\n*\n*  IFAILR  (output) INTEGER array, dimension (MM)\n*          If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right\n*          eigenvector in the i-th column of VR (corresponding to the\n*          eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the\n*          eigenvector converged satisfactorily. If the i-th and (i+1)th\n*          columns of VR hold a complex eigenvector, then IFAILR(i) and\n*          IFAILR(i+1) are set to the same value.\n*          If SIDE = 'L', IFAILR is not referenced.\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, i is the number of eigenvectors which\n*                failed to converge; see IFAILL and IFAILR for further\n*                details.\n*\n\n*  Further Details\n*  ===============\n*\n*  Each eigenvector is normalized so that the element of largest\n*  magnitude has magnitude 1; here the magnitude of a complex number\n*  (x,y) is taken to be |x|+|y|.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, ifaill, ifailr, info, select, wr, vl, vr = NumRu::Lapack.dhsein( side, eigsrc, initv, select, h, wr, wi, vl, vr, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_side = argv[0];
  rblapack_eigsrc = argv[1];
  rblapack_initv = argv[2];
  rblapack_select = argv[3];
  rblapack_h = argv[4];
  rblapack_wr = argv[5];
  rblapack_wi = argv[6];
  rblapack_vl = argv[7];
  rblapack_vr = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  initv = StringValueCStr(rblapack_initv)[0];
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (5th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_DFLOAT)
    rblapack_h = na_change_type(rblapack_h, NA_DFLOAT);
  h = NA_PTR_TYPE(rblapack_h, doublereal*);
  if (!NA_IsNArray(rblapack_wi))
    rb_raise(rb_eArgError, "wi (7th argument) must be NArray");
  if (NA_RANK(rblapack_wi) != 1)
    rb_raise(rb_eArgError, "rank of wi (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_wi) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of wi must be the same as shape 1 of h");
  if (NA_TYPE(rblapack_wi) != NA_DFLOAT)
    rblapack_wi = na_change_type(rblapack_wi, NA_DFLOAT);
  wi = NA_PTR_TYPE(rblapack_wi, doublereal*);
  if (!NA_IsNArray(rblapack_vr))
    rb_raise(rb_eArgError, "vr (9th argument) must be NArray");
  if (NA_RANK(rblapack_vr) != 2)
    rb_raise(rb_eArgError, "rank of vr (9th argument) must be %d", 2);
  ldvr = NA_SHAPE0(rblapack_vr);
  mm = NA_SHAPE1(rblapack_vr);
  if (NA_TYPE(rblapack_vr) != NA_DFLOAT)
    rblapack_vr = na_change_type(rblapack_vr, NA_DFLOAT);
  vr = NA_PTR_TYPE(rblapack_vr, doublereal*);
  eigsrc = StringValueCStr(rblapack_eigsrc)[0];
  if (!NA_IsNArray(rblapack_wr))
    rb_raise(rb_eArgError, "wr (6th argument) must be NArray");
  if (NA_RANK(rblapack_wr) != 1)
    rb_raise(rb_eArgError, "rank of wr (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_wr) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of wr must be the same as shape 1 of h");
  if (NA_TYPE(rblapack_wr) != NA_DFLOAT)
    rblapack_wr = na_change_type(rblapack_wr, NA_DFLOAT);
  wr = NA_PTR_TYPE(rblapack_wr, doublereal*);
  if (!NA_IsNArray(rblapack_select))
    rb_raise(rb_eArgError, "select (4th argument) must be NArray");
  if (NA_RANK(rblapack_select) != 1)
    rb_raise(rb_eArgError, "rank of select (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_select) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of h");
  if (NA_TYPE(rblapack_select) != NA_LINT)
    rblapack_select = na_change_type(rblapack_select, NA_LINT);
  select = NA_PTR_TYPE(rblapack_select, logical*);
  if (!NA_IsNArray(rblapack_vl))
    rb_raise(rb_eArgError, "vl (8th argument) must be NArray");
  if (NA_RANK(rblapack_vl) != 2)
    rb_raise(rb_eArgError, "rank of vl (8th argument) must be %d", 2);
  ldvl = NA_SHAPE0(rblapack_vl);
  if (NA_SHAPE1(rblapack_vl) != mm)
    rb_raise(rb_eRuntimeError, "shape 1 of vl must be the same as shape 1 of vr");
  if (NA_TYPE(rblapack_vl) != NA_DFLOAT)
    rblapack_vl = na_change_type(rblapack_vl, NA_DFLOAT);
  vl = NA_PTR_TYPE(rblapack_vl, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = mm;
    rblapack_ifaill = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifaill = NA_PTR_TYPE(rblapack_ifaill, integer*);
  {
    na_shape_t shape[1];
    shape[0] = mm;
    rblapack_ifailr = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifailr = NA_PTR_TYPE(rblapack_ifailr, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_select_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  select_out__ = NA_PTR_TYPE(rblapack_select_out__, logical*);
  MEMCPY(select_out__, select, logical, NA_TOTAL(rblapack_select));
  rblapack_select = rblapack_select_out__;
  select = select_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wr_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  wr_out__ = NA_PTR_TYPE(rblapack_wr_out__, doublereal*);
  MEMCPY(wr_out__, wr, doublereal, NA_TOTAL(rblapack_wr));
  rblapack_wr = rblapack_wr_out__;
  wr = wr_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = mm;
    rblapack_vl_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, doublereal*);
  MEMCPY(vl_out__, vl, doublereal, NA_TOTAL(rblapack_vl));
  rblapack_vl = rblapack_vl_out__;
  vl = vl_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = mm;
    rblapack_vr_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vr_out__ = NA_PTR_TYPE(rblapack_vr_out__, doublereal*);
  MEMCPY(vr_out__, vr, doublereal, NA_TOTAL(rblapack_vr));
  rblapack_vr = rblapack_vr_out__;
  vr = vr_out__;
  work = ALLOC_N(doublereal, ((n+2)*n));

  dhsein_(&side, &eigsrc, &initv, select, &n, h, &ldh, wr, wi, vl, &ldvl, vr, &ldvr, &mm, &m, work, ifaill, ifailr, &info);

  free(work);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_m, rblapack_ifaill, rblapack_ifailr, rblapack_info, rblapack_select, rblapack_wr, rblapack_vl, rblapack_vr);
}

void
init_lapack_dhsein(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dhsein", rblapack_dhsein, -1);
}
ruby-lapack-1.7.2/ext/zpftrs.c0000644000175000017500000002052212502221026016054 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zpftrs_(char* transr, char* uplo, integer* n, integer* nrhs, doublecomplex* a, doublecomplex* b, integer* ldb, integer* info);


static VALUE
rblapack_zpftrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.zpftrs( transr, uplo, n, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPFTRS solves a system of linear equations A*X = B with a Hermitian\n*  positive definite matrix A using the Cholesky factorization\n*  A = U**H*U or A = L*L**H computed by ZPFTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR    (input) CHARACTER*1\n*          = 'N':  The Normal TRANSR of RFP A is stored;\n*          = 'C':  The Conjugate-transpose TRANSR of RFP A is stored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of RFP A is stored;\n*          = 'L':  Lower triangle of RFP A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension ( N*(N+1)/2 );\n*          The triangular factor U or L from the Cholesky factorization\n*          of RFP A = U**H*U or RFP A = L*L**H, as computed by ZPFTRF.\n*          See note below for more details about RFP A.\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  We first consider Standard Packed Format when N is even.\n*  We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  conjugate-transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  conjugate-transpose of the last three columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                -- -- --\n*        03 04 05                33 43 53\n*                                   -- --\n*        13 14 15                00 44 54\n*                                      --\n*        23 24 25                10 11 55\n*\n*        33 34 35                20 21 22\n*        --\n*        00 44 45                30 31 32\n*        -- --\n*        01 11 55                40 41 42\n*        -- -- --\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- -- --                -- -- -- -- -- --\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     -- -- -- -- --                -- -- -- -- --\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     -- -- -- -- -- --                -- -- -- --\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We next  consider Standard Packed Format when N is odd.\n*  We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  conjugate-transpose of the first two   columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  conjugate-transpose of the last two   columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N odd  and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                   -- --\n*        02 03 04                00 33 43\n*                                      --\n*        12 13 14                10 11 44\n*\n*        22 23 24                20 21 22\n*        --\n*        00 33 34                30 31 32\n*        -- --\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- --                   -- -- -- -- -- --\n*     02 12 22 00 01             00 10 20 30 40 50\n*     -- -- -- --                   -- -- -- -- --\n*     03 13 23 33 11             33 11 21 31 41 51\n*     -- -- -- -- --                   -- -- -- --\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.zpftrs( transr, uplo, n, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_n = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 1)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zpftrs_(&transr, &uplo, &n, &nrhs, a, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_zpftrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zpftrs", rblapack_zpftrs, -1);
}
ruby-lapack-1.7.2/ext/dlasq2.c0000644000175000017500000001100512502221026015706 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlasq2_(integer* n, doublereal* z, integer* info);


static VALUE
rblapack_dlasq2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_z_out__;
  doublereal *z_out__;


  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  info, z = NumRu::Lapack.dlasq2( n, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLASQ2( N, Z, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLASQ2 computes all the eigenvalues of the symmetric positive \n*  definite tridiagonal matrix associated with the qd array Z to high\n*  relative accuracy are computed to high relative accuracy, in the\n*  absence of denormalization, underflow and overflow.\n*\n*  To see the relation of Z to the tridiagonal matrix, let L be a\n*  unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and\n*  let U be an upper bidiagonal matrix with 1's above and diagonal\n*  Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the\n*  symmetric tridiagonal to which it is similar.\n*\n*  Note : DLASQ2 defines a logical variable, IEEE, which is true\n*  on machines which follow ieee-754 floating-point standard in their\n*  handling of infinities and NaNs, and false otherwise. This variable\n*  is passed to DLASQ3.\n*\n\n*  Arguments\n*  =========\n*\n*  N     (input) INTEGER\n*        The number of rows and columns in the matrix. N >= 0.\n*\n*  Z     (input/output) DOUBLE PRECISION array, dimension ( 4*N )\n*        On entry Z holds the qd array. On exit, entries 1 to N hold\n*        the eigenvalues in decreasing order, Z( 2*N+1 ) holds the\n*        trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If\n*        N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 )\n*        holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of\n*        shifts that failed.\n*\n*  INFO  (output) INTEGER\n*        = 0: successful exit\n*        < 0: if the i-th argument is a scalar and had an illegal\n*             value, then INFO = -i, if the i-th argument is an\n*             array and the j-entry had an illegal value, then\n*             INFO = -(i*100+j)\n*        > 0: the algorithm failed\n*              = 1, a split was marked by a positive value in E\n*              = 2, current block of Z not diagonalized after 30*N\n*                   iterations (in inner while loop)\n*              = 3, termination criterion of outer while loop not met \n*                   (program created more than N unreduced blocks)\n*\n\n*  Further Details\n*  ===============\n*  Local Variables: I0:N0 defines a current unreduced segment of Z.\n*  The shifts are accumulated in SIGMA. Iteration count is in ITER.\n*  Ping-pong is controlled by PP (alternates between 0 and 1).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, z = NumRu::Lapack.dlasq2( n, z, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_n = argv[0];
  rblapack_z = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (2th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != (4*n))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 4*n);
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 4*n;
    rblapack_z_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
  MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  dlasq2_(&n, z, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_z);
}

void
init_lapack_dlasq2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlasq2", rblapack_dlasq2, -1);
}
ruby-lapack-1.7.2/ext/zheevd.c0000644000175000017500000002345712502221024016021 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zheevd_(char* jobz, char* uplo, integer* n, doublecomplex* a, integer* lda, doublereal* w, doublecomplex* work, integer* lwork, doublereal* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_zheevd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_lrwork;
  integer lrwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_rwork;
  doublereal *rwork; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *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  w, work, rwork, iwork, info, a = NumRu::Lapack.zheevd( jobz, uplo, a, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHEEVD computes all eigenvalues and, optionally, eigenvectors of a\n*  complex Hermitian matrix A.  If eigenvectors are desired, it uses a\n*  divide and conquer algorithm.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA, N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of A contains the\n*          upper triangular part of the matrix A.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of A contains\n*          the lower triangular part of the matrix A.\n*          On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n*          orthonormal eigenvectors of the matrix A.\n*          If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n*          or the upper triangle (if UPLO='U') of A, including the\n*          diagonal, is destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of the array WORK.\n*          If N <= 1,                LWORK must be at least 1.\n*          If JOBZ  = 'N' and N > 1, LWORK must be at least N + 1.\n*          If JOBZ  = 'V' and N > 1, LWORK must be at least 2*N + N**2.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal sizes of the WORK, RWORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  RWORK   (workspace/output) DOUBLE PRECISION array,\n*                                         dimension (LRWORK)\n*          On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n*\n*  LRWORK  (input) INTEGER\n*          The dimension of the array RWORK.\n*          If N <= 1,                LRWORK must be at least 1.\n*          If JOBZ  = 'N' and N > 1, LRWORK must be at least N.\n*          If JOBZ  = 'V' and N > 1, LRWORK must be at least\n*                         1 + 5*N + 2*N**2.\n*\n*          If LRWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.\n*          If N <= 1,                LIWORK must be at least 1.\n*          If JOBZ  = 'N' and N > 1, LIWORK must be at least 1.\n*          If JOBZ  = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK 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 and JOBZ = 'N', then the algorithm failed\n*                to converge; i off-diagonal elements of an intermediate\n*                tridiagonal form did not converge to zero;\n*                if INFO = i and JOBZ = 'V', then the algorithm failed\n*                to compute an eigenvalue while working on the submatrix\n*                lying in rows and columns INFO/(N+1) through\n*                mod(INFO,N+1).\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Jeff Rutter, Computer Science Division, University of California\n*     at Berkeley, USA\n*\n*  Modified description of INFO. Sven, 16 Feb 05.\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, work, rwork, iwork, info, a = NumRu::Lapack.zheevd( jobz, uplo, a, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  if (argc == 6) {
    rblapack_lwork = argv[3];
    rblapack_lrwork = argv[4];
    rblapack_liwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_lrwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (rblapack_lrwork == Qnil)
    lrwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n+1 : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
  else {
    lrwork = NUM2INT(rblapack_lrwork);
  }
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (rblapack_liwork == Qnil)
    liwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  if (rblapack_lwork == Qnil)
    lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n+1 : lsame_(&jobz,"V") ? 2*n+n*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lrwork);
    rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zheevd_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_w, rblapack_work, rblapack_rwork, rblapack_iwork, rblapack_info, rblapack_a);
}

void
init_lapack_zheevd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zheevd", rblapack_zheevd, -1);
}
ruby-lapack-1.7.2/ext/ztfttr.c0000644000175000017500000001725412502221016016070 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztfttr_(char* transr, char* uplo, integer* n, doublecomplex* arf, doublecomplex* a, integer* lda, integer* info);


static VALUE
rblapack_ztfttr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_arf;
  doublecomplex *arf; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_info;
  integer info; 

  integer ldarf;
  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  a, info = NumRu::Lapack.ztfttr( transr, uplo, arf, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTFTTR copies a triangular matrix A from rectangular full packed\n*  format (TF) to standard full format (TR).\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR   (input) CHARACTER*1\n*          = 'N':  ARF is in Normal format;\n*          = 'C':  ARF is in Conjugate-transpose format;\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  ARF     (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n*          On entry, the upper or lower triangular matrix A stored in\n*          RFP format. For a further discussion see Notes below.\n*\n*  A       (output) COMPLEX*16 array, dimension ( LDA, N ) \n*          On exit, the triangular matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of the array A contains\n*          the upper triangular matrix, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of the array A contains\n*          the lower triangular matrix, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\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*  We first consider Standard Packed Format when N is even.\n*  We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  conjugate-transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  conjugate-transpose of the last three columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                -- -- --\n*        03 04 05                33 43 53\n*                                   -- --\n*        13 14 15                00 44 54\n*                                      --\n*        23 24 25                10 11 55\n*\n*        33 34 35                20 21 22\n*        --\n*        00 44 45                30 31 32\n*        -- --\n*        01 11 55                40 41 42\n*        -- -- --\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- -- --                -- -- -- -- -- --\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     -- -- -- -- --                -- -- -- -- --\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     -- -- -- -- -- --                -- -- -- --\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We next  consider Standard Packed Format when N is odd.\n*  We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  conjugate-transpose of the first two   columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  conjugate-transpose of the last two   columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N odd  and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                   -- --\n*        02 03 04                00 33 43\n*                                      --\n*        12 13 14                10 11 44\n*\n*        22 23 24                20 21 22\n*        --\n*        00 33 34                30 31 32\n*        -- --\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- --                   -- -- -- -- -- --\n*     02 12 22 00 01             00 10 20 30 40 50\n*     -- -- -- --                   -- -- -- -- --\n*     03 13 23 33 11             33 11 21 31 41 51\n*     -- -- -- -- --                   -- -- -- --\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  a, info = NumRu::Lapack.ztfttr( transr, uplo, arf, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_arf = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  if (!NA_IsNArray(rblapack_arf))
    rb_raise(rb_eArgError, "arf (3th argument) must be NArray");
  if (NA_RANK(rblapack_arf) != 1)
    rb_raise(rb_eArgError, "rank of arf (3th argument) must be %d", 1);
  ldarf = NA_SHAPE0(rblapack_arf);
  if (NA_TYPE(rblapack_arf) != NA_DCOMPLEX)
    rblapack_arf = na_change_type(rblapack_arf, NA_DCOMPLEX);
  arf = NA_PTR_TYPE(rblapack_arf, doublecomplex*);
  n = ((int)sqrtf(8*ldarf+1.0f)-1)/2;
  uplo = StringValueCStr(rblapack_uplo)[0];
  lda = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);

  ztfttr_(&transr, &uplo, &n, arf, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_a, rblapack_info);
}

void
init_lapack_ztfttr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztfttr", rblapack_ztfttr, -1);
}
ruby-lapack-1.7.2/ext/dtrttf.c0000644000175000017500000001637412502221014016042 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtrttf_(char* transr, char* uplo, integer* n, doublereal* a, integer* lda, doublereal* arf, integer* info);


static VALUE
rblapack_dtrttf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_arf;
  doublereal *arf; 
  VALUE rblapack_info;
  integer info; 

  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  arf, info = NumRu::Lapack.dtrttf( transr, uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTRTTF copies a triangular matrix A from standard full format (TR)\n*  to rectangular full packed format (TF) .\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR  (input) CHARACTER*1\n*          = 'N':  ARF in Normal form is wanted;\n*          = 'T':  ARF in Transpose form is wanted.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N).\n*          On entry, the triangular matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of the array A contains\n*          the upper triangular matrix, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of the array A contains\n*          the lower triangular matrix, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the matrix A. LDA >= max(1,N).\n*\n*  ARF     (output) DOUBLE PRECISION array, dimension (NT).\n*          NT=N*(N+1)/2. On exit, the triangular matrix A in RFP format.\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*  We first consider Rectangular Full Packed (RFP) Format when N is\n*  even. We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  the transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  the transpose of the last three columns of AP lower.\n*  This covers the case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        03 04 05                33 43 53\n*        13 14 15                00 44 54\n*        23 24 25                10 11 55\n*        33 34 35                20 21 22\n*        00 44 45                30 31 32\n*        01 11 55                40 41 42\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We then consider Rectangular Full Packed (RFP) Format when N is\n*  odd. We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  the transpose of the first two columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  the transpose of the last two columns of AP lower.\n*  This covers the case N odd and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        02 03 04                00 33 43\n*        12 13 14                10 11 44\n*        22 23 24                20 21 22\n*        00 33 34                30 31 32\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*           RFP A                   RFP A\n*\n*     02 12 22 00 01             00 10 20 30 40 50\n*     03 13 23 33 11             33 11 21 31 41 51\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  Reference\n*  =========\n*\n*  =====================================================================\n*\n*     ..\n*     .. Local Scalars ..\n      LOGICAL            LOWER, NISODD, NORMALTRANSR\n      INTEGER            I, IJ, J, K, L, N1, N2, NT, NX2, NP1X2\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MOD\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  arf, info = NumRu::Lapack.dtrttf( transr, uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_arf = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  arf = NA_PTR_TYPE(rblapack_arf, doublereal*);

  dtrttf_(&transr, &uplo, &n, a, &lda, arf, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_arf, rblapack_info);
}

void
init_lapack_dtrttf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtrttf", rblapack_dtrttf, -1);
}
ruby-lapack-1.7.2/ext/zlaed0.c0000644000175000017500000001576012502221025015712 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlaed0_(integer* qsiz, integer* n, doublereal* d, doublereal* e, doublecomplex* q, integer* ldq, doublecomplex* qstore, integer* ldqs, doublereal* rwork, integer* iwork, integer* info);


static VALUE
rblapack_zlaed0(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_qsiz;
  integer qsiz; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_q;
  doublecomplex *q; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_e_out__;
  doublereal *e_out__;
  VALUE rblapack_q_out__;
  doublecomplex *q_out__;
  doublecomplex *qstore;
  doublereal *rwork;
  integer *iwork;

  integer n;
  integer ldq;
  integer ldqs;

  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  info, d, e, q = NumRu::Lapack.zlaed0( qsiz, d, e, q, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  Using the divide and conquer method, ZLAED0 computes all eigenvalues\n*  of a symmetric tridiagonal matrix which is one diagonal block of\n*  those from reducing a dense or band Hermitian matrix and\n*  corresponding eigenvectors of the dense or band matrix.\n*\n\n*  Arguments\n*  =========\n*\n*  QSIZ   (input) INTEGER\n*         The dimension of the unitary matrix used to reduce\n*         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.\n*\n*  N      (input) INTEGER\n*         The dimension of the symmetric tridiagonal matrix.  N >= 0.\n*\n*  D      (input/output) DOUBLE PRECISION array, dimension (N)\n*         On entry, the diagonal elements of the tridiagonal matrix.\n*         On exit, the eigenvalues in ascending order.\n*\n*  E      (input/output) DOUBLE PRECISION array, dimension (N-1)\n*         On entry, the off-diagonal elements of the tridiagonal matrix.\n*         On exit, E has been destroyed.\n*\n*  Q      (input/output) COMPLEX*16 array, dimension (LDQ,N)\n*         On entry, Q must contain an QSIZ x N matrix whose columns\n*         unitarily orthonormal. It is a part of the unitary matrix\n*         that reduces the full dense Hermitian matrix to a\n*         (reducible) symmetric tridiagonal matrix.\n*\n*  LDQ    (input) INTEGER\n*         The leading dimension of the array Q.  LDQ >= max(1,N).\n*\n*  IWORK  (workspace) INTEGER array,\n*         the dimension of IWORK must be at least\n*                      6 + 6*N + 5*N*lg N\n*                      ( lg( N ) = smallest integer k\n*                                  such that 2^k >= N )\n*\n*  RWORK  (workspace) DOUBLE PRECISION array,\n*                               dimension (1 + 3*N + 2*N*lg N + 3*N**2)\n*                        ( lg( N ) = smallest integer k\n*                                    such that 2^k >= N )\n*\n*  QSTORE (workspace) COMPLEX*16 array, dimension (LDQS, N)\n*         Used to store parts of\n*         the eigenvector matrix when the updating matrix multiplies\n*         take place.\n*\n*  LDQS   (input) INTEGER\n*         The leading dimension of the array QSTORE.\n*         LDQS >= max(1,N).\n*\n*  INFO   (output) INTEGER\n*          = 0:  successful exit.\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          > 0:  The algorithm failed to compute an eigenvalue while\n*                working on the submatrix lying in rows and columns\n*                INFO/(N+1) through mod(INFO,N+1).\n*\n\n*  =====================================================================\n*\n*  Warning:      N could be as big as QSIZ!\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, e, q = NumRu::Lapack.zlaed0( qsiz, d, e, q, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_qsiz = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  rblapack_q = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  qsiz = NUM2INT(rblapack_qsiz);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (4th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (4th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  n = NA_SHAPE1(rblapack_q);
  if (NA_TYPE(rblapack_q) != NA_DCOMPLEX)
    rblapack_q = na_change_type(rblapack_q, NA_DCOMPLEX);
  q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of q");
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  ldqs = MAX(1,n);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
  MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublecomplex*);
  MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  qstore = ALLOC_N(doublecomplex, (ldqs)*(n));
  rwork = ALLOC_N(doublereal, (1 + 3*n + 2*n*LG(n) + 3*pow(n,2)));
  iwork = ALLOC_N(integer, (6 + 6*n + 5*n*LG(n)));

  zlaed0_(&qsiz, &n, d, e, q, &ldq, qstore, &ldqs, rwork, iwork, &info);

  free(qstore);
  free(rwork);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_e, rblapack_q);
}

void
init_lapack_zlaed0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlaed0", rblapack_zlaed0, -1);
}
ruby-lapack-1.7.2/ext/dtzrqf.c0000644000175000017500000001157712502221013016044 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtzrqf_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* tau, integer* info);


static VALUE
rblapack_dtzrqf(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__;

  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.dtzrqf( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTZRQF( M, N, A, LDA, TAU, INFO )\n\n*  Purpose\n*  =======\n*\n*  This routine is deprecated and has been replaced by routine DTZRZF.\n*\n*  DTZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A\n*  to upper triangular form by means of orthogonal transformations.\n*\n*  The upper trapezoidal matrix A is factored as\n*\n*     A = ( R  0 ) * Z,\n*\n*  where Z is an N-by-N orthogonal matrix and R is an M-by-M upper\n*  triangular matrix.\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 >= M.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the leading M-by-N upper trapezoidal part of the\n*          array A must contain the matrix to be factorized.\n*          On exit, the leading M-by-M upper triangular part of A\n*          contains the upper triangular matrix R, and elements M+1 to\n*          N of the first M rows of A, with the array TAU, represent the\n*          orthogonal matrix Z as a product of M elementary reflectors.\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 (M)\n*          The scalar factors of the elementary reflectors.\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 factorization is obtained by Householder's method.  The kth\n*  transformation matrix, Z( k ), which is used to introduce zeros into\n*  the ( m - k + 1 )th row of A, is given in the form\n*\n*     Z( k ) = ( I     0   ),\n*              ( 0  T( k ) )\n*\n*  where\n*\n*     T( k ) = I - tau*u( k )*u( k )',   u( k ) = (   1    ),\n*                                                 (   0    )\n*                                                 ( z( k ) )\n*\n*  tau is a scalar and z( k ) is an ( n - m ) element vector.\n*  tau and z( k ) are chosen to annihilate the elements of the kth row\n*  of X.\n*\n*  The scalar tau is returned in the kth element of TAU and the vector\n*  u( k ) in the kth row of A, such that the elements of z( k ) are\n*  in  a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n*  the upper triangular part of A.\n*\n*  Z is given by\n*\n*     Z =  Z( 1 ) * Z( 2 ) * ... * Z( m ).\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.dtzrqf( 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;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t 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__;

  dtzrqf_(&m, &n, a, &lda, tau, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
}

void
init_lapack_dtzrqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtzrqf", rblapack_dtzrqf, -1);
}
ruby-lapack-1.7.2/ext/slas2.c0000644000175000017500000000615612502221014015554 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slas2_(real* f, real* g, real* h, real* ssmin, real* ssmax);


static VALUE
rblapack_slas2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_f;
  real f; 
  VALUE rblapack_g;
  real g; 
  VALUE rblapack_h;
  real h; 
  VALUE rblapack_ssmin;
  real ssmin; 
  VALUE rblapack_ssmax;
  real ssmax; 


  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  ssmin, ssmax = NumRu::Lapack.slas2( f, g, h, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAS2( F, G, H, SSMIN, SSMAX )\n\n*  Purpose\n*  =======\n*\n*  SLAS2  computes the singular values of the 2-by-2 matrix\n*     [  F   G  ]\n*     [  0   H  ].\n*  On return, SSMIN is the smaller singular value and SSMAX is the\n*  larger singular value.\n*\n\n*  Arguments\n*  =========\n*\n*  F       (input) REAL\n*          The (1,1) element of the 2-by-2 matrix.\n*\n*  G       (input) REAL\n*          The (1,2) element of the 2-by-2 matrix.\n*\n*  H       (input) REAL\n*          The (2,2) element of the 2-by-2 matrix.\n*\n*  SSMIN   (output) REAL\n*          The smaller singular value.\n*\n*  SSMAX   (output) REAL\n*          The larger singular value.\n*\n\n*  Further Details\n*  ===============\n*\n*  Barring over/underflow, all output quantities are correct to within\n*  a few units in the last place (ulps), even in the absence of a guard\n*  digit in addition/subtraction.\n*\n*  In IEEE arithmetic, the code works correctly if one matrix element is\n*  infinite.\n*\n*  Overflow will not occur unless the largest singular value itself\n*  overflows, or is within a few ulps of overflow. (On machines with\n*  partial overflow, like the Cray, overflow may occur if the largest\n*  singular value is within a factor of 2 of overflow.)\n*\n*  Underflow is harmless if underflow is gradual. Otherwise, results\n*  may correspond to a matrix modified by perturbations of size near\n*  the underflow threshold.\n*\n*  ====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ssmin, ssmax = NumRu::Lapack.slas2( f, g, h, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_f = argv[0];
  rblapack_g = argv[1];
  rblapack_h = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  f = (real)NUM2DBL(rblapack_f);
  h = (real)NUM2DBL(rblapack_h);
  g = (real)NUM2DBL(rblapack_g);

  slas2_(&f, &g, &h, &ssmin, &ssmax);

  rblapack_ssmin = rb_float_new((double)ssmin);
  rblapack_ssmax = rb_float_new((double)ssmax);
  return rb_ary_new3(2, rblapack_ssmin, rblapack_ssmax);
}

void
init_lapack_slas2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slas2", rblapack_slas2, -1);
}
ruby-lapack-1.7.2/ext/sposvxx.c0000644000175000017500000006222712502221024016264 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sposvxx_(char* fact, char* uplo, integer* n, integer* nrhs, real* a, integer* lda, real* af, integer* ldaf, char* equed, real* s, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* rpvgrw, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, real* work, integer* iwork, integer* info);


static VALUE
rblapack_sposvxx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_af;
  real *af; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_params;
  real *params; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_rpvgrw;
  real rpvgrw; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_err_bnds_norm;
  real *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  real *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_af_out__;
  real *af_out__;
  VALUE rblapack_s_out__;
  real *s_out__;
  VALUE rblapack_b_out__;
  real *b_out__;
  VALUE rblapack_params_out__;
  real *params_out__;
  real *work;
  integer *iwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer nparams;
  integer ldx;
  integer n_err_bnds;

  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  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, equed, s, b, params = NumRu::Lapack.sposvxx( fact, uplo, a, af, equed, s, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     SPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T\n*     to compute the solution to a real system of linear equations\n*     A * X = B, where A is an N-by-N symmetric positive definite matrix\n*     and X and B are N-by-NRHS matrices.\n*\n*     If requested, both normwise and maximum componentwise error bounds\n*     are returned. SPOSVXX will return a solution with a tiny\n*     guaranteed error (O(eps) where eps is the working machine\n*     precision) unless the matrix is very ill-conditioned, in which\n*     case a warning is returned. Relevant condition numbers also are\n*     calculated and returned.\n*\n*     SPOSVXX accepts user-provided factorizations and equilibration\n*     factors; see the definitions of the FACT and EQUED options.\n*     Solving with refinement and using a factorization from a previous\n*     SPOSVXX call will also produce a solution with either O(eps)\n*     errors or warnings, but we cannot make that claim for general\n*     user-provided factorizations and equilibration factors if they\n*     differ from what SPOSVXX would itself produce.\n*\n*     Description\n*     ===========\n*\n*     The following steps are performed:\n*\n*     1. If FACT = 'E', real scaling factors are computed to equilibrate\n*     the system:\n*\n*       diag(S)*A*diag(S)     *inv(diag(S))*X = diag(S)*B\n*\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n*     2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n*     factor the matrix A (after equilibration if FACT = 'E') as\n*        A = U**T* U,  if UPLO = 'U', or\n*        A = L * L**T,  if UPLO = 'L',\n*     where U is an upper triangular matrix and L is a lower triangular\n*     matrix.\n*\n*     3. If the leading i-by-i principal minor is not positive definite,\n*     then the routine returns with INFO = i. Otherwise, the factored\n*     form of A is used to estimate the condition number of the matrix\n*     A (see argument RCOND).  If the reciprocal of the condition number\n*     is less than machine precision, the routine still goes on to solve\n*     for X and compute error bounds as described below.\n*\n*     4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*     5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n*     the routine will use iterative refinement to try to get a small\n*     error and error bounds.  Refinement calculates the residual to at\n*     least twice the working precision.\n*\n*     6. If equilibration was used, the matrix X is premultiplied by\n*     diag(S) so that it solves the original system before\n*     equilibration.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     FACT    (input) CHARACTER*1\n*     Specifies whether or not the factored form of the matrix A is\n*     supplied on entry, and if not, whether the matrix A should be\n*     equilibrated before it is factored.\n*       = 'F':  On entry, AF contains the factored form of A.\n*               If EQUED is not 'N', the matrix A has been\n*               equilibrated with scaling factors given by S.\n*               A and AF are not modified.\n*       = 'N':  The matrix A will be copied to AF and factored.\n*       = 'E':  The matrix A will be equilibrated if necessary, then\n*               copied to AF and factored.\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     A       (input/output) REAL array, dimension (LDA,N)\n*     On entry, the symmetric matrix A, except if FACT = 'F' and EQUED =\n*     'Y', then A must contain the equilibrated matrix\n*     diag(S)*A*diag(S).  If UPLO = 'U', the leading N-by-N upper\n*     triangular part of A contains the upper triangular part of the\n*     matrix A, and the strictly lower triangular part of A is not\n*     referenced.  If UPLO = 'L', the leading N-by-N lower triangular\n*     part of A contains the lower triangular part of the matrix A, and\n*     the strictly upper triangular part of A is not referenced.  A is\n*     not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED =\n*     'N' on exit.\n*\n*     On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n*     diag(S)*A*diag(S).\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input or output) REAL array, dimension (LDAF,N)\n*     If FACT = 'F', then AF is an input argument and on entry\n*     contains the triangular factor U or L from the Cholesky\n*     factorization A = U**T*U or A = L*L**T, in the same storage\n*     format as A.  If EQUED .ne. 'N', then AF is the factored\n*     form of the equilibrated matrix diag(S)*A*diag(S).\n*\n*     If FACT = 'N', then AF is an output argument and on exit\n*     returns the triangular factor U or L from the Cholesky\n*     factorization A = U**T*U or A = L*L**T of the original\n*     matrix A.\n*\n*     If FACT = 'E', then AF is an output argument and on exit\n*     returns the triangular factor U or L from the Cholesky\n*     factorization A = U**T*U or A = L*L**T of the equilibrated\n*     matrix A (see the description of A for the form of the\n*     equilibrated matrix).\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     EQUED   (input or output) CHARACTER*1\n*     Specifies the form of equilibration that was done.\n*       = 'N':  No equilibration (always true if FACT = 'N').\n*       = 'Y':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(S) * A * diag(S).\n*     EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*     output argument.\n*\n*     S       (input or output) REAL array, dimension (N)\n*     The row scale factors for A.  If EQUED = 'Y', A is multiplied on\n*     the left and right by diag(S).  S is an input argument if FACT =\n*     'F'; otherwise, S is an output argument.  If FACT = 'F' and EQUED\n*     = 'Y', each element of S must be positive.  If S is output, each\n*     element of S is a power of the radix. If S is input, each element\n*     of S should be a power of the radix to ensure a reliable solution\n*     and error estimates. Scaling by powers of the radix does not cause\n*     rounding errors unless the result underflows or overflows.\n*     Rounding errors during scaling lead to refining with a matrix that\n*     is not equivalent to the input matrix, producing error estimates\n*     that may not be reliable.\n*\n*     B       (input/output) REAL array, dimension (LDB,NRHS)\n*     On entry, the N-by-NRHS right hand side matrix B.\n*     On exit,\n*     if EQUED = 'N', B is not modified;\n*     if EQUED = 'Y', B is overwritten by diag(S)*B;\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (output) REAL array, dimension (LDX,NRHS)\n*     If INFO = 0, the N-by-NRHS solution matrix X to the original\n*     system of equations.  Note that A and B are modified on exit if\n*     EQUED .ne. 'N', and the solution to the equilibrated system is\n*     inv(diag(S))*X.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) REAL\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     RPVGRW  (output) REAL\n*     Reciprocal pivot growth.  On exit, this contains the reciprocal\n*     pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n*     norm is used.  If this is much less than 1, then the stability of\n*     the LU factorization of the (equilibrated) matrix A could be poor.\n*     This also means that the solution X, estimated condition numbers,\n*     and error bounds could be unreliable. If factorization fails with\n*     0 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, equed, s, b, params = NumRu::Lapack.sposvxx( fact, uplo, a, af, equed, s, b, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_equed = argv[4];
  rblapack_s = argv[5];
  rblapack_b = argv[6];
  rblapack_params = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  n_err_bnds = 3;
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (6th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
  af = NA_PTR_TYPE(rblapack_af, real*);
  ldx = MAX(1,n);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (8th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (8th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_SFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
  params = NA_PTR_TYPE(rblapack_params, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldaf;
    shape[1] = n;
    rblapack_af_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  af_out__ = NA_PTR_TYPE(rblapack_af_out__, real*);
  MEMCPY(af_out__, af, real, NA_TOTAL(rblapack_af));
  rblapack_af = rblapack_af_out__;
  af = af_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
  MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
  MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(real, (4*n));
  iwork = ALLOC_N(integer, (n));

  sposvxx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &equed, s, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_rpvgrw = rb_float_new((double)rpvgrw);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(13, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_a, rblapack_af, rblapack_equed, rblapack_s, rblapack_b, rblapack_params);
}

void
init_lapack_sposvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sposvxx", rblapack_sposvxx, -1);
}
ruby-lapack-1.7.2/ext/sspsv.c0000644000175000017500000001627712502221017015716 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sspsv_(char* uplo, integer* n, integer* nrhs, real* ap, integer* ipiv, real* b, integer* ldb, integer* info);


static VALUE
rblapack_sspsv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  real *ap_out__;
  VALUE rblapack_b_out__;
  real *b_out__;

  integer ldb;
  integer nrhs;
  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  ipiv, info, ap, b = NumRu::Lapack.sspsv( uplo, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSPSV computes the solution to a real system of linear equations\n*     A * X = B,\n*  where A is an N-by-N symmetric matrix stored in packed format and X\n*  and B are N-by-NRHS matrices.\n*\n*  The diagonal pivoting method is used to factor A as\n*     A = U * D * U**T,  if UPLO = 'U', or\n*     A = L * D * L**T,  if UPLO = 'L',\n*  where U (or L) is a product of permutation and unit upper (lower)\n*  triangular matrices, D is symmetric and block diagonal with 1-by-1\n*  and 2-by-2 diagonal blocks.  The factored form of A is then used to\n*  solve the system of equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AP      (input/output) REAL array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          See below for further details.\n*\n*          On exit, the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L from the factorization\n*          A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as\n*          a packed triangular matrix in the same storage format as A.\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D, as\n*          determined by SSPTRF.  If IPIV(k) > 0, then rows and columns\n*          k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n*          diagonal block.  If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n*          then rows and columns k-1 and -IPIV(k) were interchanged and\n*          D(k-1:k,k-1:k) is a 2-by-2 diagonal block.  If UPLO = 'L' and\n*          IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n*          -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n*          diagonal block.\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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, D(i,i) is exactly zero.  The factorization\n*                has been completed, but the block diagonal matrix D is\n*                exactly singular, so the solution could not be\n*                computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  The packed storage scheme is illustrated by the following example\n*  when N = 4, UPLO = 'U':\n*\n*  Two-dimensional storage of the symmetric matrix A:\n*\n*     a11 a12 a13 a14\n*         a22 a23 a24\n*             a33 a34     (aij = aji)\n*                 a44\n*\n*  Packed storage of the upper triangle of A:\n*\n*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n*  =====================================================================\n*\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SSPTRF, SSPTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, ap, b = NumRu::Lapack.sspsv( uplo, ap, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_b = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  n = ldb;
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, real*);
  MEMCPY(ap_out__, ap, real, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  sspsv_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ipiv, rblapack_info, rblapack_ap, rblapack_b);
}

void
init_lapack_sspsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sspsv", rblapack_sspsv, -1);
}
ruby-lapack-1.7.2/ext/dsygv.c0000644000175000017500000002047712502221017015671 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsygv_(integer* itype, char* jobz, char* uplo, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* w, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dsygv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_w;
  doublereal *w; 
  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 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  w, work, info, a, b = NumRu::Lapack.dsygv( itype, jobz, uplo, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSYGV computes all the eigenvalues, and optionally, the eigenvectors\n*  of a real generalized symmetric-definite eigenproblem, of the form\n*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.\n*  Here A and B are assumed to be symmetric and B is also\n*  positive definite.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          Specifies the problem type to be solved:\n*          = 1:  A*x = (lambda)*B*x\n*          = 2:  A*B*x = (lambda)*x\n*          = 3:  B*A*x = (lambda)*x\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of A contains the\n*          upper triangular part of the matrix A.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of A contains\n*          the lower triangular part of the matrix A.\n*\n*          On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n*          matrix Z of eigenvectors.  The eigenvectors are normalized\n*          as follows:\n*          if ITYPE = 1 or 2, Z**T*B*Z = I;\n*          if ITYPE = 3, Z**T*inv(B)*Z = I.\n*          If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n*          or the lower triangle (if UPLO='L') of A, including the\n*          diagonal, is destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n*          On entry, the symmetric positive definite matrix B.\n*          If UPLO = 'U', the leading N-by-N upper triangular part of B\n*          contains the upper triangular part of the matrix B.\n*          If UPLO = 'L', the leading N-by-N lower triangular part of B\n*          contains the lower triangular part of the matrix B.\n*\n*          On exit, if INFO <= N, the part of B containing the matrix is\n*          overwritten by the triangular factor U or L from the Cholesky\n*          factorization B = U**T*U or B = L*L**T.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\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 length of the array WORK.  LWORK >= max(1,3*N-1).\n*          For optimal efficiency, LWORK >= (NB+2)*N,\n*          where NB is the blocksize for DSYTRD returned by ILAENV.\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:  DPOTRF or DSYEV returned an error code:\n*             <= N:  if INFO = i, DSYEV failed to converge;\n*                    i off-diagonal elements of an intermediate\n*                    tridiagonal form did not converge to zero;\n*             > N:   if INFO = N + i, for 1 <= i <= N, then the leading\n*                    minor of order i of B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, work, info, a, b = NumRu::Lapack.dsygv( itype, jobz, uplo, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_itype = argv[0];
  rblapack_jobz = argv[1];
  rblapack_uplo = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  if (argc == 6) {
    rblapack_lwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  itype = NUM2INT(rblapack_itype);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = 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*);
  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  if (rblapack_lwork == Qnil)
    lwork = 3*n-1;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dsygv_(&itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_w, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_dsygv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsygv", rblapack_dsygv, -1);
}
ruby-lapack-1.7.2/ext/dgetf2.c0000644000175000017500000001017012502221020015667 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgetf2_(integer* m, integer* n, doublereal* a, integer* lda, integer* ipiv, integer* info);


static VALUE
rblapack_dgetf2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  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  ipiv, info, a = NumRu::Lapack.dgetf2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGETF2 computes an LU factorization of a general m-by-n matrix A\n*  using partial pivoting with row interchanges.\n*\n*  The factorization has the form\n*     A = P * L * U\n*  where P is a permutation matrix, L is lower triangular with unit\n*  diagonal elements (lower trapezoidal if m > n), and U is upper\n*  triangular (upper trapezoidal if m < n).\n*\n*  This is the right-looking Level 2 BLAS version of the algorithm.\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 to be factored.\n*          On exit, the factors L and U from the factorization\n*          A = P*L*U; the unit diagonal elements of L are not stored.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  IPIV    (output) INTEGER array, dimension (min(M,N))\n*          The pivot indices; for 1 <= i <= min(M,N), row i of the\n*          matrix was interchanged with row IPIV(i).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*          > 0: if INFO = k, U(k,k) is exactly zero. The factorization\n*               has been completed, but the factor U is exactly\n*               singular, and division by zero will occur if it is used\n*               to solve a system of equations.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, a = NumRu::Lapack.dgetf2( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t 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__;

  dgetf2_(&m, &n, a, &lda, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_a);
}

void
init_lapack_dgetf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgetf2", rblapack_dgetf2, -1);
}
ruby-lapack-1.7.2/ext/zgeqpf.c0000644000175000017500000001406312502221026016023 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgeqpf_(integer* m, integer* n, doublecomplex* a, integer* lda, integer* jpvt, doublecomplex* tau, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zgeqpf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_jpvt;
  integer *jpvt; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_jpvt_out__;
  integer *jpvt_out__;
  doublecomplex *work;
  doublereal *rwork;

  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, info, a, jpvt = NumRu::Lapack.zgeqpf( m, a, jpvt, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  This routine is deprecated and has been replaced by routine ZGEQP3.\n*\n*  ZGEQPF computes a QR factorization with column pivoting of a\n*  complex M-by-N matrix A: A*P = Q*R.\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) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, the upper triangle of the array contains the\n*          min(M,N)-by-N upper triangular matrix R; the elements\n*          below the diagonal, together with the array TAU,\n*          represent the unitary matrix Q as a product of\n*          min(m,n) elementary reflectors.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  JPVT    (input/output) INTEGER array, dimension (N)\n*          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n*          to the front of A*P (a leading column); if JPVT(i) = 0,\n*          the i-th column of A is a free column.\n*          On exit, if JPVT(i) = k, then the i-th column of A*P\n*          was the k-th column of A.\n*\n*  TAU     (output) COMPLEX*16 array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (2*N)\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(1) H(2) . . . H(n)\n*\n*  Each H(i) has the form\n*\n*     H = I - tau * v * v'\n*\n*  where tau is a complex scalar, and v is a complex vector with\n*  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).\n*\n*  The matrix P is represented in jpvt as follows: If\n*     jpvt(j) = i\n*  then the jth column of P is the ith canonical unit vector.\n*\n*  Partial column norm updating strategy modified by\n*    Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n*    University of Zagreb, Croatia.\n*     June 2010\n*  For more details see LAPACK Working Note 176.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, info, a, jpvt = NumRu::Lapack.zgeqpf( m, a, jpvt, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  rblapack_jpvt = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_jpvt))
    rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
  if (NA_RANK(rblapack_jpvt) != 1)
    rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_jpvt);
  if (NA_TYPE(rblapack_jpvt) != NA_LINT)
    rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
  jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of jpvt");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
  MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
  rblapack_jpvt = rblapack_jpvt_out__;
  jpvt = jpvt_out__;
  work = ALLOC_N(doublecomplex, (n));
  rwork = ALLOC_N(doublereal, (2*n));

  zgeqpf_(&m, &n, a, &lda, jpvt, tau, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_tau, rblapack_info, rblapack_a, rblapack_jpvt);
}

void
init_lapack_zgeqpf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgeqpf", rblapack_zgeqpf, -1);
}
ruby-lapack-1.7.2/ext/cungqr.c0000644000175000017500000001250512502221024016023 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cungqr_(integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_cungqr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;

  integer lda;
  integer n;
  integer k;

  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 = NumRu::Lapack.cungqr( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CUNGQR generates an M-by-N complex matrix Q with orthonormal columns,\n*  which is defined as the first N columns of a product of K elementary\n*  reflectors of order M\n*\n*        Q  =  H(1) H(2) . . . H(k)\n*\n*  as returned by CGEQRF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. M >= N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. N >= K >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the i-th column must contain the vector which\n*          defines the elementary reflector H(i), for i = 1,2,...,k, as\n*          returned by CGEQRF in the first k columns of its array\n*          argument A.\n*          On exit, the M-by-N matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) COMPLEX array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by CGEQRF.\n*\n*  WORK    (workspace/output) COMPLEX 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,N).\n*          For optimum performance LWORK >= N*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 has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, a = NumRu::Lapack.cungqr( m, a, tau, [: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_m = argv[0];
  rblapack_a = argv[1];
  rblapack_tau = 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;
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  cungqr_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_cungqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cungqr", rblapack_cungqr, -1);
}
ruby-lapack-1.7.2/ext/cgelss.c0000644000175000017500000002023312502221021015776 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgelss_(integer* m, integer* n, integer* nrhs, complex* a, integer* lda, complex* b, integer* ldb, real* s, real* rcond, integer* rank, complex* work, integer* lwork, real* rwork, integer* info);


static VALUE
rblapack_cgelss(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_rank;
  integer rank; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;
  real *rwork;

  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  s, rank, work, info, a, b = NumRu::Lapack.cgelss( a, b, rcond, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGELSS computes the minimum norm solution to a complex linear\n*  least squares problem:\n*\n*  Minimize 2-norm(| b - A*x |).\n*\n*  using the singular value decomposition (SVD) of A. A is an M-by-N\n*  matrix which may be rank-deficient.\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 matrix\n*  X.\n*\n*  The effective rank of A is determined by treating as zero those\n*  singular values which are less than RCOND times the largest singular\n*  value.\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*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X. NRHS >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, the first min(m,n) rows of A are overwritten with\n*          its right singular vectors, stored rowwise.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the M-by-NRHS right hand side matrix B.\n*          On exit, B is overwritten by the N-by-NRHS solution matrix X.\n*          If m >= n and RANK = n, the residual sum-of-squares for\n*          the solution in the i-th column is given by the sum of\n*          squares of the modulus of elements n+1:m in that column.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,M,N).\n*\n*  S       (output) REAL array, dimension (min(M,N))\n*          The singular values of A in decreasing order.\n*          The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n*\n*  RCOND   (input) REAL\n*          RCOND is used to determine the effective rank of A.\n*          Singular values S(i) <= RCOND*S(1) are treated as zero.\n*          If RCOND < 0, machine precision is used instead.\n*\n*  RANK    (output) INTEGER\n*          The effective rank of A, i.e., the number of singular values\n*          which are greater than RCOND*S(1).\n*\n*  WORK    (workspace/output) COMPLEX 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 >= 1, and also:\n*          LWORK >=  2*min(M,N) + max(M,N,NRHS)\n*          For good performance, LWORK should generally be larger.\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*  RWORK   (workspace) REAL array, dimension (5*min(M,N))\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          > 0:  the algorithm for computing the SVD failed to converge;\n*                if INFO = i, i off-diagonal elements of an intermediate\n*                bidiagonal form did not converge to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, rank, work, info, a, b = NumRu::Lapack.cgelss( a, b, rcond, [: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_a = argv[0];
  rblapack_b = argv[1];
  rblapack_rcond = 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 (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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  rcond = (real)NUM2DBL(rblapack_rcond);
  m = lda;
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th 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_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  ldb = MAX(m, n);
  if (rblapack_lwork == Qnil)
    lwork = 3*MIN(m,n) + MAX(MAX(2*MIN(m,n),MAX(m,n)),nrhs);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = MAX(m, n);
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  {
    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__;
  rwork = ALLOC_N(real, (5*MIN(m,n)));

  cgelss_(&m, &n, &nrhs, a, &lda, b, &ldb, s, &rcond, &rank, work, &lwork, rwork, &info);

  free(rwork);
  rblapack_rank = INT2NUM(rank);
  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(6, rblapack_s, rblapack_rank, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_cgelss(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgelss", rblapack_cgelss, -1);
}
ruby-lapack-1.7.2/ext/dlasdt.c0000644000175000017500000000676612502221021016010 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlasdt_(integer* n, integer* lvl, integer* nd, integer* inode, integer* ndiml, integer* ndimr, integer* msub);


static VALUE
rblapack_dlasdt(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_msub;
  integer msub; 
  VALUE rblapack_lvl;
  integer lvl; 
  VALUE rblapack_nd;
  integer nd; 
  VALUE rblapack_inode;
  integer *inode; 
  VALUE rblapack_ndiml;
  integer *ndiml; 
  VALUE rblapack_ndimr;
  integer *ndimr; 


  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  lvl, nd, inode, ndiml, ndimr = NumRu::Lapack.dlasdt( n, msub, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB )\n\n*  Purpose\n*  =======\n*\n*  DLASDT creates a tree of subproblems for bidiagonal divide and\n*  conquer.\n*\n\n*  Arguments\n*  =========\n*\n*   N      (input) INTEGER\n*          On entry, the number of diagonal elements of the\n*          bidiagonal matrix.\n*\n*   LVL    (output) INTEGER\n*          On exit, the number of levels on the computation tree.\n*\n*   ND     (output) INTEGER\n*          On exit, the number of nodes on the tree.\n*\n*   INODE  (output) INTEGER array, dimension ( N )\n*          On exit, centers of subproblems.\n*\n*   NDIML  (output) INTEGER array, dimension ( N )\n*          On exit, row dimensions of left children.\n*\n*   NDIMR  (output) INTEGER array, dimension ( N )\n*          On exit, row dimensions of right children.\n*\n*   MSUB   (input) INTEGER\n*          On entry, the maximum row dimension each subproblem at the\n*          bottom of the tree can be of.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  lvl, nd, inode, ndiml, ndimr = NumRu::Lapack.dlasdt( n, msub, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_n = argv[0];
  rblapack_msub = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  msub = NUM2INT(rblapack_msub);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,n);
    rblapack_inode = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  inode = NA_PTR_TYPE(rblapack_inode, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,n);
    rblapack_ndiml = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ndiml = NA_PTR_TYPE(rblapack_ndiml, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,n);
    rblapack_ndimr = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ndimr = NA_PTR_TYPE(rblapack_ndimr, integer*);

  dlasdt_(&n, &lvl, &nd, inode, ndiml, ndimr, &msub);

  rblapack_lvl = INT2NUM(lvl);
  rblapack_nd = INT2NUM(nd);
  return rb_ary_new3(5, rblapack_lvl, rblapack_nd, rblapack_inode, rblapack_ndiml, rblapack_ndimr);
}

void
init_lapack_dlasdt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlasdt", rblapack_dlasdt, -1);
}
ruby-lapack-1.7.2/ext/zptts2.c0000644000175000017500000001235112502221014015770 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zptts2_(integer* iuplo, integer* n, integer* nrhs, doublereal* d, doublecomplex* e, doublecomplex* b, integer* ldb);


static VALUE
rblapack_zptts2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_iuplo;
  integer iuplo; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublecomplex *e; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer n;
  integer ldb;
  integer nrhs;

  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  b = NumRu::Lapack.zptts2( iuplo, d, e, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPTTS2( IUPLO, N, NRHS, D, E, B, LDB )\n\n*  Purpose\n*  =======\n*\n*  ZPTTS2 solves a tridiagonal system of the form\n*     A * X = B\n*  using the factorization A = U'*D*U or A = L*D*L' computed by ZPTTRF.\n*  D is a diagonal matrix specified in the vector D, U (or L) is a unit\n*  bidiagonal matrix whose superdiagonal (subdiagonal) is specified in\n*  the vector E, and X and B are N by NRHS matrices.\n*\n\n*  Arguments\n*  =========\n*\n*  IUPLO   (input) INTEGER\n*          Specifies the form of the factorization and whether the\n*          vector E is the superdiagonal of the upper bidiagonal factor\n*          U or the subdiagonal of the lower bidiagonal factor L.\n*          = 1:  A = U'*D*U, E is the superdiagonal of U\n*          = 0:  A = L*D*L', E is the subdiagonal of L\n*\n*  N       (input) INTEGER\n*          The order of the tridiagonal matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          The n diagonal elements of the diagonal matrix D from the\n*          factorization A = U'*D*U or A = L*D*L'.\n*\n*  E       (input) COMPLEX*16 array, dimension (N-1)\n*          If IUPLO = 1, the (n-1) superdiagonal elements of the unit\n*          bidiagonal factor U from the factorization A = U'*D*U.\n*          If IUPLO = 0, the (n-1) subdiagonal elements of the unit\n*          bidiagonal factor L from the factorization A = L*D*L'.\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the right hand side vectors B for the system of\n*          linear equations.\n*          On exit, the solution vectors, X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           ZDSCAL\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          DCONJG\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  b = NumRu::Lapack.zptts2( iuplo, d, e, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_iuplo = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  iuplo = NUM2INT(rblapack_iuplo);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DCOMPLEX)
    rblapack_e = na_change_type(rblapack_e, NA_DCOMPLEX);
  e = NA_PTR_TYPE(rblapack_e, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zptts2_(&iuplo, &n, &nrhs, d, e, b, &ldb);

  return rblapack_b;
}

void
init_lapack_zptts2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zptts2", rblapack_zptts2, -1);
}
ruby-lapack-1.7.2/ext/cheevr.c0000644000175000017500000004056212502221014016003 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cheevr_(char* jobz, char* range, char* uplo, integer* n, complex* a, integer* lda, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, complex* z, integer* ldz, integer* isuppz, complex* work, integer* lwork, real* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_cheevr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_vl;
  real vl; 
  VALUE rblapack_vu;
  real vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  real abstol; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_lrwork;
  integer lrwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_isuppz;
  integer *isuppz; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_rwork;
  real *rwork; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;

  integer lda;
  integer n;
  integer ldz;

  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  m, w, z, isuppz, work, rwork, iwork, info, a = NumRu::Lapack.cheevr( jobz, range, uplo, a, vl, vu, il, iu, abstol, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHEEVR computes selected eigenvalues and, optionally, eigenvectors\n*  of a complex Hermitian matrix A.  Eigenvalues and eigenvectors can\n*  be selected by specifying either a range of values or a range of\n*  indices for the desired eigenvalues.\n*\n*  CHEEVR first reduces the matrix A to tridiagonal form T with a call\n*  to CHETRD.  Then, whenever possible, CHEEVR calls CSTEMR to compute\n*  the eigenspectrum using Relatively Robust Representations.  CSTEMR\n*  computes eigenvalues by the dqds algorithm, while orthogonal\n*  eigenvectors are computed from various \"good\" L D L^T representations\n*  (also known as Relatively Robust Representations). Gram-Schmidt\n*  orthogonalization is avoided as far as possible. More specifically,\n*  the various steps of the algorithm are as follows.\n*\n*  For each unreduced block (submatrix) of T,\n*     (a) Compute T - sigma I  = L D L^T, so that L and D\n*         define all the wanted eigenvalues to high relative accuracy.\n*         This means that small relative changes in the entries of D and L\n*         cause only small relative changes in the eigenvalues and\n*         eigenvectors. The standard (unfactored) representation of the\n*         tridiagonal matrix T does not have this property in general.\n*     (b) Compute the eigenvalues to suitable accuracy.\n*         If the eigenvectors are desired, the algorithm attains full\n*         accuracy of the computed eigenvalues only right before\n*         the corresponding vectors have to be computed, see steps c) and d).\n*     (c) For each cluster of close eigenvalues, select a new\n*         shift close to the cluster, find a new factorization, and refine\n*         the shifted eigenvalues to suitable accuracy.\n*     (d) For each eigenvalue with a large enough relative separation compute\n*         the corresponding eigenvector by forming a rank revealing twisted\n*         factorization. Go back to (c) for any clusters that remain.\n*\n*  The desired accuracy of the output can be specified by the input\n*  parameter ABSTOL.\n*\n*  For more details, see DSTEMR's documentation and:\n*  - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n*    to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n*    Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n*  - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n*    Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n*    2004.  Also LAPACK Working Note 154.\n*  - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n*    tridiagonal eigenvalue/eigenvector problem\",\n*    Computer Science Division Technical Report No. UCB/CSD-97-971,\n*    UC Berkeley, May 1997.\n*\n*\n*  Note 1 : CHEEVR calls CSTEMR when the full spectrum is requested\n*  on machines which conform to the ieee-754 floating point standard.\n*  CHEEVR calls SSTEBZ and CSTEIN on non-ieee machines and\n*  when partial spectrum requests are made.\n*\n*  Normal execution of CSTEMR may create NaNs and infinities and\n*  hence may abort due to a floating point exception in environments\n*  which do not handle NaNs and infinities in the ieee standard default\n*  manner.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found.\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found.\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n********** For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and\n********** CSTEIN are called\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA, N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of A contains the\n*          upper triangular part of the matrix A.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of A contains\n*          the lower triangular part of the matrix A.\n*          On exit, the lower triangle (if UPLO='L') or the upper\n*          triangle (if UPLO='U') of A, including the diagonal, is\n*          destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  VL      (input) REAL\n*  VU      (input) REAL\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) REAL\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less than\n*          or equal to zero, then  EPS*|T|  will be used in its place,\n*          where |T| is the 1-norm of the tridiagonal matrix obtained\n*          by reducing A to tridiagonal form.\n*\n*          See \"Computing Small Singular Values of Bidiagonal Matrices\n*          with Guaranteed High Relative Accuracy,\" by Demmel and\n*          Kahan, LAPACK Working Note #3.\n*\n*          If high relative accuracy is important, set ABSTOL to\n*          SLAMCH( 'Safe minimum' ).  Doing so will guarantee that\n*          eigenvalues are computed to high relative accuracy when\n*          possible in future releases.  The current code does not\n*          make any guarantees about high relative accuracy, but\n*          furutre releases will. See J. Barlow and J. Demmel,\n*          \"Computing Accurate Eigensystems of Scaled Diagonally\n*          Dominant Matrices\", LAPACK Working Note #7, for a discussion\n*          of which matrices define their eigenvalues to high relative\n*          accuracy.\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) REAL array, dimension (N)\n*          The first M elements contain the selected eigenvalues in\n*          ascending order.\n*\n*  Z       (output) COMPLEX array, dimension (LDZ, max(1,M))\n*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix A\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  ISUPPZ  (output) INTEGER array, dimension ( 2*max(1,M) )\n*          The support of the eigenvectors in Z, i.e., the indices\n*          indicating the nonzero elements in Z. The i-th eigenvector\n*          is nonzero only in elements ISUPPZ( 2*i-1 ) through\n*          ISUPPZ( 2*i ).\n********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1\n*\n*  WORK    (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of the array WORK.  LWORK >= max(1,2*N).\n*          For optimal efficiency, LWORK >= (NB+1)*N,\n*          where NB is the max of the blocksize for CHETRD and for\n*          CUNMTR as returned by ILAENV.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal sizes of the WORK, RWORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  RWORK   (workspace/output) REAL array, dimension (MAX(1,LRWORK))\n*          On exit, if INFO = 0, RWORK(1) returns the optimal\n*          (and minimal) LRWORK.\n*\n* LRWORK   (input) INTEGER\n*          The length of the array RWORK.  LRWORK >= max(1,24*N).\n*\n*          If LRWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal\n*          (and minimal) LIWORK.\n*\n* LIWORK   (input) INTEGER\n*          The dimension of the array IWORK.  LIWORK >= max(1,10*N).\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK 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:  Internal error\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Inderjit Dhillon, IBM Almaden, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Ken Stanley, Computer Science Division, University of\n*       California at Berkeley, USA\n*     Jason Riedy, Computer Science Division, University of\n*       California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, isuppz, work, rwork, iwork, info, a = NumRu::Lapack.cheevr( jobz, range, uplo, a, vl, vu, il, iu, abstol, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_uplo = argv[2];
  rblapack_a = argv[3];
  rblapack_vl = argv[4];
  rblapack_vu = argv[5];
  rblapack_il = argv[6];
  rblapack_iu = argv[7];
  rblapack_abstol = argv[8];
  if (argc == 12) {
    rblapack_lwork = argv[9];
    rblapack_lrwork = argv[10];
    rblapack_liwork = argv[11];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_lrwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  vl = (real)NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  abstol = (real)NUM2DBL(rblapack_abstol);
  range = StringValueCStr(rblapack_range)[0];
  vu = (real)NUM2DBL(rblapack_vu);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (rblapack_lwork == Qnil)
    lwork = 2*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (rblapack_liwork == Qnil)
    liwork = 10*n;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  iu = NUM2INT(rblapack_iu);
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  if (rblapack_lrwork == Qnil)
    lrwork = 24*n;
  else {
    lrwork = NUM2INT(rblapack_lrwork);
  }
  m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, complex*);
  {
    na_shape_t shape[1];
    shape[0] = 2*MAX(1,m);
    rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lrwork);
    rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  rwork = NA_PTR_TYPE(rblapack_rwork, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  cheevr_(&jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, isuppz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);

  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_m, rblapack_w, rblapack_z, rblapack_isuppz, rblapack_work, rblapack_rwork, rblapack_iwork, rblapack_info, rblapack_a);
}

void
init_lapack_cheevr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cheevr", rblapack_cheevr, -1);
}
ruby-lapack-1.7.2/ext/cla_syamv.c0000644000175000017500000001632212502221020016477 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cla_syamv_(integer* uplo, integer* n, real* alpha, real* a, integer* lda, complex* x, integer* incx, real* beta, real* y, integer* incy);


static VALUE
rblapack_cla_syamv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  integer uplo; 
  VALUE rblapack_alpha;
  real alpha; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_beta;
  real beta; 
  VALUE rblapack_y;
  real *y; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_y_out__;
  real *y_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  y = NumRu::Lapack.cla_syamv( uplo, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n*  Purpose\n*  =======\n*\n*  CLA_SYAMV  performs the matrix-vector operation\n*\n*          y := alpha*abs(A)*abs(x) + beta*abs(y),\n*\n*  where alpha and beta are scalars, x and y are vectors and A is an\n*  n by n symmetric matrix.\n*\n*  This function is primarily used in calculating error bounds.\n*  To protect against underflow during evaluation, components in\n*  the resulting vector are perturbed away from zero by (N+1)\n*  times the underflow threshold.  To prevent unnecessarily large\n*  errors for block-structure embedded in general matrices,\n*  \"symbolically\" zero components are not perturbed.  A zero\n*  entry is considered \"symbolic\" if all multiplications involved\n*  in computing that entry have at least one zero multiplicand.\n*\n\n*  Arguments\n*  ==========\n*\n*  UPLO    (input) INTEGER\n*           On entry, UPLO specifies whether the upper or lower\n*           triangular part of the array A is to be referenced as\n*           follows:\n*\n*              UPLO = BLAS_UPPER   Only the upper triangular part of A\n*                                  is to be referenced.\n*\n*              UPLO = BLAS_LOWER   Only the lower triangular part of A\n*                                  is to be referenced.\n*\n*           Unchanged on exit.\n*\n*  N       (input) INTEGER\n*           On entry, N specifies the number of columns of the matrix A.\n*           N must be at least zero.\n*           Unchanged on exit.\n*\n*  ALPHA   (input) REAL            .\n*           On entry, ALPHA specifies the scalar alpha.\n*           Unchanged on exit.\n*\n*  A      - COMPLEX             array of DIMENSION ( LDA, n ).\n*           Before entry, the leading m by n part of the array A must\n*           contain the matrix of coefficients.\n*           Unchanged on exit.\n*\n*  LDA     (input) INTEGER\n*           On entry, LDA specifies the first dimension of A as declared\n*           in the calling (sub) program. LDA must be at least\n*           max( 1, n ).\n*           Unchanged on exit.\n*\n*  X       (input) COMPLEX array, dimension\n*           ( 1 + ( n - 1 )*abs( INCX ) )\n*           Before entry, the incremented array X must contain the\n*           vector x.\n*           Unchanged on exit.\n*\n*  INCX    (input) INTEGER\n*           On entry, INCX specifies the increment for the elements of\n*           X. INCX must not be zero.\n*           Unchanged on exit.\n*\n*  BETA    (input) REAL            .\n*           On entry, BETA specifies the scalar beta. When BETA is\n*           supplied as zero then Y need not be set on input.\n*           Unchanged on exit.\n*\n*  Y       (input/output) REAL array, dimension\n*           ( 1 + ( n - 1 )*abs( INCY ) )\n*           Before entry with BETA non-zero, the incremented array Y\n*           must contain the vector y. On exit, Y is overwritten by the\n*           updated vector y.\n*\n*  INCY    (input) INTEGER\n*           On entry, INCY specifies the increment for the elements of\n*           Y. INCY must not be zero.\n*           Unchanged on exit.\n*\n\n*  Further Details\n*  ===============\n*\n*  Level 2 Blas routine.\n*\n*  -- Written on 22-October-1986.\n*     Jack Dongarra, Argonne National Lab.\n*     Jeremy Du Croz, Nag Central Office.\n*     Sven Hammarling, Nag Central Office.\n*     Richard Hanson, Sandia National Labs.\n*  -- Modified for the absolute-value product, April 2006\n*     Jason Riedy, UC Berkeley\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  y = NumRu::Lapack.cla_syamv( uplo, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_uplo = argv[0];
  rblapack_alpha = argv[1];
  rblapack_a = argv[2];
  rblapack_x = argv[3];
  rblapack_incx = argv[4];
  rblapack_beta = argv[5];
  rblapack_y = argv[6];
  rblapack_incy = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = NUM2INT(rblapack_uplo);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  lda = n;
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  incx = NUM2INT(rblapack_incx);
  incy = NUM2INT(rblapack_incy);
  alpha = (real)NUM2DBL(rblapack_alpha);
  beta = (real)NUM2DBL(rblapack_beta);
  n = lda;
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (4th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1 + ( n - 1 )*abs( incx )))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (7th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (1 + ( n - 1 )*abs( incy )))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1 + ( n - 1 )*abs( incy ));
  if (NA_TYPE(rblapack_y) != NA_SFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
  y = NA_PTR_TYPE(rblapack_y, real*);
  {
    na_shape_t shape[1];
    shape[0] = 1 + ( n - 1 )*abs( incy );
    rblapack_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
  MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  cla_syamv_(&uplo, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);

  return rblapack_y;
}

void
init_lapack_cla_syamv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cla_syamv", rblapack_cla_syamv, -1);
}
ruby-lapack-1.7.2/ext/sgeql2.c0000644000175000017500000001041312502221023015714 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgeql2_(integer* m, integer* n, real* a, integer* lda, real* tau, real* work, integer* info);


static VALUE
rblapack_sgeql2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  real *work;

  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, info, a = NumRu::Lapack.sgeql2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGEQL2( M, N, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGEQL2 computes a QL factorization of a real m by n matrix A:\n*  A = Q * L.\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) REAL array, dimension (LDA,N)\n*          On entry, the m by n matrix A.\n*          On exit, if m >= n, the lower triangle of the subarray\n*          A(m-n+1:m,1:n) contains the n by n lower triangular matrix L;\n*          if m <= n, the elements on and below the (n-m)-th\n*          superdiagonal contain the m by n lower trapezoidal matrix L;\n*          the remaining elements, with the array TAU, represent the\n*          orthogonal matrix Q as a product of elementary reflectors\n*          (see Further Details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  TAU     (output) REAL array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace) REAL array, dimension (N)\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(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n*  A(1:m-k+i-1,n-k+i), 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.sgeql2( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(real, (n));

  sgeql2_(&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_sgeql2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgeql2", rblapack_sgeql2, -1);
}
ruby-lapack-1.7.2/ext/dorm2r.c0000644000175000017500000001437612502221020015735 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dorm2r_(char* side, char* trans, integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* c, integer* ldc, doublereal* work, integer* info);


static VALUE
rblapack_dorm2r(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublereal *c_out__;
  doublereal *work;

  integer lda;
  integer k;
  integer ldc;
  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  info, c = NumRu::Lapack.dorm2r( side, trans, m, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DORM2R overwrites the general real m by n matrix C with\n*\n*        Q * C  if SIDE = 'L' and TRANS = 'N', or\n*\n*        Q'* C  if SIDE = 'L' and TRANS = 'T', or\n*\n*        C * Q  if SIDE = 'R' and TRANS = 'N', or\n*\n*        C * Q' if SIDE = 'R' and TRANS = 'T',\n*\n*  where Q is a real orthogonal matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(1) H(2) . . . H(k)\n*\n*  as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q' from the Left\n*          = 'R': apply Q or Q' from the Right\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': apply Q  (No transpose)\n*          = 'T': apply Q' (Transpose)\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,K)\n*          The i-th column must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          DGEQRF in the first k columns of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*          If SIDE = 'L', LDA >= max(1,M);\n*          if SIDE = 'R', LDA >= max(1,N).\n*\n*  TAU     (input) DOUBLE PRECISION array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by DGEQRF.\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n*          On entry, the m by n matrix C.\n*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension\n*                                   (N) if SIDE = 'L',\n*                                   (M) if SIDE = 'R'\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, c = NumRu::Lapack.dorm2r( side, trans, m, a, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_m = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != k)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  dorm2r_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_c);
}

void
init_lapack_dorm2r(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dorm2r", rblapack_dorm2r, -1);
}
ruby-lapack-1.7.2/ext/cgtsv.c0000644000175000017500000001524012502221026015653 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgtsv_(integer* n, integer* nrhs, complex* dl, complex* d, complex* du, complex* b, integer* ldb, integer* info);


static VALUE
rblapack_cgtsv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_dl;
  complex *dl; 
  VALUE rblapack_d;
  complex *d; 
  VALUE rblapack_du;
  complex *du; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_dl_out__;
  complex *dl_out__;
  VALUE rblapack_d_out__;
  complex *d_out__;
  VALUE rblapack_du_out__;
  complex *du_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer n;
  integer ldb;
  integer nrhs;

  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  info, dl, d, du, b = NumRu::Lapack.cgtsv( dl, d, du, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGTSV  solves the equation\n*\n*     A*X = B,\n*\n*  where A is an N-by-N tridiagonal matrix, by Gaussian elimination with\n*  partial pivoting.\n*\n*  Note that the equation  A'*X = B  may be solved by interchanging the\n*  order of the arguments DU and DL.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  DL      (input/output) COMPLEX array, dimension (N-1)\n*          On entry, DL must contain the (n-1) subdiagonal elements of\n*          A.\n*          On exit, DL is overwritten by the (n-2) elements of the\n*          second superdiagonal of the upper triangular matrix U from\n*          the LU factorization of A, in DL(1), ..., DL(n-2).\n*\n*  D       (input/output) COMPLEX array, dimension (N)\n*          On entry, D must contain the diagonal elements of A.\n*          On exit, D is overwritten by the n diagonal elements of U.\n*\n*  DU      (input/output) COMPLEX array, dimension (N-1)\n*          On entry, DU must contain the (n-1) superdiagonal elements\n*          of A.\n*          On exit, DU is overwritten by the (n-1) elements of the first\n*          superdiagonal of U.\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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, U(i,i) is exactly zero, and the solution\n*                has not been computed.  The factorization has not been\n*                completed unless i = N.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, dl, d, du, b = NumRu::Lapack.cgtsv( dl, d, du, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_dl = argv[0];
  rblapack_d = argv[1];
  rblapack_du = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SCOMPLEX)
    rblapack_d = na_change_type(rblapack_d, NA_SCOMPLEX);
  d = NA_PTR_TYPE(rblapack_d, complex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (1th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (1th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_SCOMPLEX)
    rblapack_dl = na_change_type(rblapack_dl, NA_SCOMPLEX);
  dl = NA_PTR_TYPE(rblapack_dl, complex*);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (3th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_SCOMPLEX)
    rblapack_du = na_change_type(rblapack_du, NA_SCOMPLEX);
  du = NA_PTR_TYPE(rblapack_du, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_dl_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  dl_out__ = NA_PTR_TYPE(rblapack_dl_out__, complex*);
  MEMCPY(dl_out__, dl, complex, NA_TOTAL(rblapack_dl));
  rblapack_dl = rblapack_dl_out__;
  dl = dl_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, complex*);
  MEMCPY(d_out__, d, complex, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_du_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  du_out__ = NA_PTR_TYPE(rblapack_du_out__, complex*);
  MEMCPY(du_out__, du, complex, NA_TOTAL(rblapack_du));
  rblapack_du = rblapack_du_out__;
  du = du_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  cgtsv_(&n, &nrhs, dl, d, du, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_info, rblapack_dl, rblapack_d, rblapack_du, rblapack_b);
}

void
init_lapack_cgtsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgtsv", rblapack_cgtsv, -1);
}
ruby-lapack-1.7.2/ext/csyrfsx.c0000644000175000017500000005147712502221015016240 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID csyrfsx_(char* uplo, char* equed, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, real* s, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, complex* work, real* rwork, integer* info);


static VALUE
rblapack_csyrfsx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_params;
  real *params; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_err_bnds_norm;
  real *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  real *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_s_out__;
  real *s_out__;
  VALUE rblapack_x_out__;
  complex *x_out__;
  VALUE rblapack_params_out__;
  real *params_out__;
  complex *work;
  real *rwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;
  integer nparams;
  integer n_err_bnds;

  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  rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.csyrfsx( uplo, equed, a, af, ipiv, s, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     CSYRFSX improves the computed solution to a system of linear\n*     equations when the coefficient matrix is symmetric indefinite, and\n*     provides error bounds and backward error estimates for the\n*     solution.  In addition to normwise error bound, the code provides\n*     maximum componentwise error bound if possible.  See comments for\n*     ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.\n*\n*     The original system of linear equations may have been equilibrated\n*     before calling this routine, as described by arguments EQUED and S\n*     below. In this case, the solution and error bounds returned are\n*     for the original unequilibrated system.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     EQUED   (input) CHARACTER*1\n*     Specifies the form of equilibration that was done to A\n*     before calling this routine. This is needed to compute\n*     the solution and error bounds correctly.\n*       = 'N':  No equilibration\n*       = 'Y':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(S) * A * diag(S).\n*               The right hand side B has been changed accordingly.\n*\n*     N       (input) INTEGER\n*     The order of the matrix A.  N >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     A       (input) COMPLEX array, dimension (LDA,N)\n*     The symmetric matrix A.  If UPLO = 'U', the leading N-by-N\n*     upper triangular part of A contains the upper triangular\n*     part of the matrix A, and the strictly lower triangular\n*     part of A is not referenced.  If UPLO = 'L', the leading\n*     N-by-N lower triangular part of A contains the lower\n*     triangular part of the matrix A, and the strictly upper\n*     triangular part of A is not referenced.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX array, dimension (LDAF,N)\n*     The factored form of the matrix A.  AF contains the block\n*     diagonal matrix D and the multipliers used to obtain the\n*     factor U or L from the factorization A = U*D*U**T or A =\n*     L*D*L**T as computed by SSYTRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     Details of the interchanges and the block structure of D\n*     as determined by SSYTRF.\n*\n*     S       (input or output) REAL array, dimension (N)\n*     The scale factors for A.  If EQUED = 'Y', A is multiplied on\n*     the left and right by diag(S).  S is an input argument if FACT =\n*     'F'; otherwise, S is an output argument.  If FACT = 'F' and EQUED\n*     = 'Y', each element of S must be positive.  If S is output, each\n*     element of S is a power of the radix. If S is input, each element\n*     of S should be a power of the radix to ensure a reliable solution\n*     and error estimates. Scaling by powers of the radix does not cause\n*     rounding errors unless the result underflows or overflows.\n*     Rounding errors during scaling lead to refining with a matrix that\n*     is not equivalent to the input matrix, producing error estimates\n*     that may not be reliable.\n*\n*     B       (input) COMPLEX array, dimension (LDB,NRHS)\n*     The right hand side matrix B.\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (input/output) COMPLEX array, dimension (LDX,NRHS)\n*     On entry, the solution matrix X, as computed by SGETRS.\n*     On exit, the improved solution matrix X.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) REAL\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     BERR    (output) REAL array, dimension (NRHS)\n*     Componentwise relative backward error.  This is the\n*     componentwise relative backward error of each solution vector X(j)\n*     (i.e., the smallest relative change in any element of A or B that\n*     makes X(j) an exact solution).\n*\n*     N_ERR_BNDS (input) INTEGER\n*     Number of error bounds to return for each right hand side\n*     and each type (normwise or componentwise).  See ERR_BNDS_NORM and\n*     ERR_BNDS_COMP below.\n*\n*     ERR_BNDS_NORM  (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     NPARAMS (input) INTEGER\n*     Specifies the number of parameters set in PARAMS.  If .LE. 0, the\n*     PARAMS array is never referenced and default values are used.\n*\n*     PARAMS  (input / output) REAL array, dimension NPARAMS\n*     Specifies algorithm parameters.  If an entry is .LT. 0.0, then\n*     that entry will be filled with default value used for that\n*     parameter.  Only positions up to NPARAMS are accessed; defaults\n*     are used for higher-numbered parameters.\n*\n*       PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n*            refinement or not.\n*         Default: 1.0\n*            = 0.0 : No refinement is performed, and no error bounds are\n*                    computed.\n*            = 1.0 : Use the double-precision refinement algorithm,\n*                    possibly with doubled-single computations if the\n*                    compilation environment does not support DOUBLE\n*                    PRECISION.\n*              (other values are reserved for future use)\n*\n*       PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n*            computations allowed for refinement.\n*         Default: 10\n*         Aggressive: Set to 100 to permit convergence using approximate\n*                     factorizations or factorizations other than LU. If\n*                     the factorization uses a technique other than\n*                     Gaussian elimination, the guarantees in\n*                     err_bnds_norm and err_bnds_comp may no longer be\n*                     trustworthy.\n*\n*       PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n*            will attempt to find a solution with small componentwise\n*            relative error in the double-precision algorithm.  Positive\n*            is true, 0.0 is false.\n*         Default: 1.0 (attempt componentwise convergence)\n*\n*     WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*     RWORK   (workspace) REAL array, dimension (2*N)\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit. The solution to every right-hand side is\n*         guaranteed.\n*       < 0:  If INFO = -i, the i-th argument had an illegal value\n*       > 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.csyrfsx( uplo, equed, a, af, ipiv, s, b, x, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_uplo = argv[0];
  rblapack_equed = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_s = argv[5];
  rblapack_b = argv[6];
  rblapack_x = argv[7];
  rblapack_params = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (9th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_SFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
  params = NA_PTR_TYPE(rblapack_params, real*);
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (6th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  n_err_bnds = 3;
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (8th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (8th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
  MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
  MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (2*n));

  csyrfsx_(&uplo, &equed, &n, &nrhs, a, &lda, af, &ldaf, ipiv, s, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_s, rblapack_x, rblapack_params);
}

void
init_lapack_csyrfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "csyrfsx", rblapack_csyrfsx, -1);
}
ruby-lapack-1.7.2/ext/cunmlq.c0000644000175000017500000001612512502221021016022 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cunmlq_(char* side, char* trans, integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* c, integer* ldc, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_cunmlq(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_c;
  complex *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  complex *c_out__;

  integer lda;
  integer m;
  integer k;
  integer ldc;
  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  work, info, c = NumRu::Lapack.cunmlq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CUNMLQ overwrites the general complex M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'C':      Q**H * C       C * Q**H\n*\n*  where Q is a complex unitary matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(k)' . . . H(2)' H(1)'\n*\n*  as returned by CGELQF. Q is of order M if SIDE = 'L' and of order N\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**H from the Left;\n*          = 'R': apply Q or Q**H from the Right.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'C':  Conjugate transpose, apply Q**H.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) COMPLEX array, dimension\n*                               (LDA,M) if SIDE = 'L',\n*                               (LDA,N) if SIDE = 'R'\n*          The i-th row must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          CGELQF in the first k rows of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,K).\n*\n*  TAU     (input) COMPLEX array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by CGELQF.\n*\n*  C       (input/output) COMPLEX array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace/output) COMPLEX 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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M).\n*          For optimum performance LWORK >= N*NB if SIDE 'L', and\n*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n*          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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.cunmlq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_a = argv[2];
  rblapack_tau = argv[3];
  rblapack_c = argv[4];
  if (argc == 6) {
    rblapack_lwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, complex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
  MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  cunmlq_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_cunmlq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cunmlq", rblapack_cunmlq, -1);
}
ruby-lapack-1.7.2/ext/dgelss.c0000644000175000017500000002015212502221022016000 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgelss_(integer* m, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* s, doublereal* rcond, integer* rank, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dgelss(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_rank;
  integer rank; 
  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  s, rank, work, info, a, b = NumRu::Lapack.dgelss( a, b, rcond, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGELSS computes the minimum norm solution to a real linear least\n*  squares problem:\n*\n*  Minimize 2-norm(| b - A*x |).\n*\n*  using the singular value decomposition (SVD) of A. A is an M-by-N\n*  matrix which may be rank-deficient.\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 matrix\n*  X.\n*\n*  The effective rank of A is determined by treating as zero those\n*  singular values which are less than RCOND times the largest singular\n*  value.\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*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          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, the first min(m,n) rows of A are overwritten with\n*          its right singular vectors, stored rowwise.\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 M-by-NRHS right hand side matrix B.\n*          On exit, B is overwritten by the N-by-NRHS solution\n*          matrix X.  If m >= n and RANK = n, the residual\n*          sum-of-squares for the solution in the i-th column is given\n*          by the sum of squares of elements n+1:m in that column.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,max(M,N)).\n*\n*  S       (output) DOUBLE PRECISION array, dimension (min(M,N))\n*          The singular values of A in decreasing order.\n*          The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n*\n*  RCOND   (input) DOUBLE PRECISION\n*          RCOND is used to determine the effective rank of A.\n*          Singular values S(i) <= RCOND*S(1) are treated as zero.\n*          If RCOND < 0, machine precision is used instead.\n*\n*  RANK    (output) INTEGER\n*          The effective rank of A, i.e., the number of singular values\n*          which are greater than RCOND*S(1).\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 >= 1, and also:\n*          LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS )\n*          For good performance, LWORK should generally be larger.\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:  the algorithm for computing the SVD failed to converge;\n*                if INFO = i, i off-diagonal elements of an intermediate\n*                bidiagonal form did not converge to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, rank, work, info, a, b = NumRu::Lapack.dgelss( a, b, rcond, [: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_a = argv[0];
  rblapack_b = argv[1];
  rblapack_rcond = 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 (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*);
  rcond = NUM2DBL(rblapack_rcond);
  m = lda;
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th 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*);
  ldb = MAX(m,n);
  if (rblapack_lwork == Qnil)
    lwork = 3*MIN(m,n) + MAX(MAX(2*MIN(m,n),MAX(m,n)),nrhs);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;
  {
    na_shape_t 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__;

  dgelss_(&m, &n, &nrhs, a, &lda, b, &ldb, s, &rcond, &rank, work, &lwork, &info);

  rblapack_rank = INT2NUM(rank);
  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(6, rblapack_s, rblapack_rank, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_dgelss(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgelss", rblapack_dgelss, -1);
}
ruby-lapack-1.7.2/ext/sptts2.c0000644000175000017500000001073312502221013015762 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sptts2_(integer* n, integer* nrhs, real* d, real* e, real* b, integer* ldb);


static VALUE
rblapack_sptts2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_b_out__;
  real *b_out__;

  integer n;
  integer ldb;
  integer nrhs;

  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  b = NumRu::Lapack.sptts2( d, e, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPTTS2( N, NRHS, D, E, B, LDB )\n\n*  Purpose\n*  =======\n*\n*  SPTTS2 solves a tridiagonal system of the form\n*     A * X = B\n*  using the L*D*L' factorization of A computed by SPTTRF.  D is a\n*  diagonal matrix specified in the vector D, L is a unit bidiagonal\n*  matrix whose subdiagonal is specified in the vector E, and X and B\n*  are N by NRHS matrices.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the tridiagonal matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  D       (input) REAL array, dimension (N)\n*          The n diagonal elements of the diagonal matrix D from the\n*          L*D*L' factorization of A.\n*\n*  E       (input) REAL array, dimension (N-1)\n*          The (n-1) subdiagonal elements of the unit bidiagonal factor\n*          L from the L*D*L' factorization of A.  E can also be regarded\n*          as the superdiagonal of the unit bidiagonal factor U from the\n*          factorization A = U'*D*U.\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the right hand side vectors B for the system of\n*          linear equations.\n*          On exit, the solution vectors, X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SSCAL\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  b = NumRu::Lapack.sptts2( d, e, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_d = argv[0];
  rblapack_e = argv[1];
  rblapack_b = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  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);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (2th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  sptts2_(&n, &nrhs, d, e, b, &ldb);

  return rblapack_b;
}

void
init_lapack_sptts2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sptts2", rblapack_sptts2, -1);
}
ruby-lapack-1.7.2/ext/ctgevc.c0000644000175000017500000002447412502221022016005 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctgevc_(char* side, char* howmny, logical* select, integer* n, complex* s, integer* lds, complex* p, integer* ldp, complex* vl, integer* ldvl, complex* vr, integer* ldvr, integer* mm, integer* m, complex* work, real* rwork, integer* info);


static VALUE
rblapack_ctgevc(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_howmny;
  char howmny; 
  VALUE rblapack_select;
  logical *select; 
  VALUE rblapack_s;
  complex *s; 
  VALUE rblapack_p;
  complex *p; 
  VALUE rblapack_vl;
  complex *vl; 
  VALUE rblapack_vr;
  complex *vr; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_vl_out__;
  complex *vl_out__;
  VALUE rblapack_vr_out__;
  complex *vr_out__;
  complex *work;
  real *rwork;

  integer n;
  integer lds;
  integer ldp;
  integer ldvl;
  integer mm;
  integer ldvr;

  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  m, info, vl, vr = NumRu::Lapack.ctgevc( side, howmny, select, s, p, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTGEVC computes some or all of the right and/or left eigenvectors of\n*  a pair of complex matrices (S,P), where S and P are upper triangular.\n*  Matrix pairs of this type are produced by the generalized Schur\n*  factorization of a complex matrix pair (A,B):\n*  \n*     A = Q*S*Z**H,  B = Q*P*Z**H\n*  \n*  as computed by CGGHRD + CHGEQZ.\n*  \n*  The right eigenvector x and the left eigenvector y of (S,P)\n*  corresponding to an eigenvalue w are defined by:\n*  \n*     S*x = w*P*x,  (y**H)*S = w*(y**H)*P,\n*  \n*  where y**H denotes the conjugate tranpose of y.\n*  The eigenvalues are not input to this routine, but are computed\n*  directly from the diagonal elements of S and P.\n*  \n*  This routine returns the matrices X and/or Y of right and left\n*  eigenvectors of (S,P), or the products Z*X and/or Q*Y,\n*  where Z and Q are input matrices.\n*  If Q and Z are the unitary factors from the generalized Schur\n*  factorization of a matrix pair (A,B), then Z*X and Q*Y\n*  are the matrices of right and left eigenvectors of (A,B).\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'R': compute right eigenvectors only;\n*          = 'L': compute left eigenvectors only;\n*          = 'B': compute both right and left eigenvectors.\n*\n*  HOWMNY  (input) CHARACTER*1\n*          = 'A': compute all right and/or left eigenvectors;\n*          = 'B': compute all right and/or left eigenvectors,\n*                 backtransformed by the matrices in VR and/or VL;\n*          = 'S': compute selected right and/or left eigenvectors,\n*                 specified by the logical array SELECT.\n*\n*  SELECT  (input) LOGICAL array, dimension (N)\n*          If HOWMNY='S', SELECT specifies the eigenvectors to be\n*          computed.  The eigenvector corresponding to the j-th\n*          eigenvalue is computed if SELECT(j) = .TRUE..\n*          Not referenced if HOWMNY = 'A' or 'B'.\n*\n*  N       (input) INTEGER\n*          The order of the matrices S and P.  N >= 0.\n*\n*  S       (input) COMPLEX array, dimension (LDS,N)\n*          The upper triangular matrix S from a generalized Schur\n*          factorization, as computed by CHGEQZ.\n*\n*  LDS     (input) INTEGER\n*          The leading dimension of array S.  LDS >= max(1,N).\n*\n*  P       (input) COMPLEX array, dimension (LDP,N)\n*          The upper triangular matrix P from a generalized Schur\n*          factorization, as computed by CHGEQZ.  P must have real\n*          diagonal elements.\n*\n*  LDP     (input) INTEGER\n*          The leading dimension of array P.  LDP >= max(1,N).\n*\n*  VL      (input/output) COMPLEX array, dimension (LDVL,MM)\n*          On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n*          contain an N-by-N matrix Q (usually the unitary matrix Q\n*          of left Schur vectors returned by CHGEQZ).\n*          On exit, if SIDE = 'L' or 'B', VL contains:\n*          if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);\n*          if HOWMNY = 'B', the matrix Q*Y;\n*          if HOWMNY = 'S', the left eigenvectors of (S,P) specified by\n*                      SELECT, stored consecutively in the columns of\n*                      VL, in the same order as their eigenvalues.\n*          Not referenced if SIDE = 'R'.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of array VL.  LDVL >= 1, and if\n*          SIDE = 'L' or 'l' or 'B' or 'b', LDVL >= N.\n*\n*  VR      (input/output) COMPLEX array, dimension (LDVR,MM)\n*          On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n*          contain an N-by-N matrix Q (usually the unitary matrix Z\n*          of right Schur vectors returned by CHGEQZ).\n*          On exit, if SIDE = 'R' or 'B', VR contains:\n*          if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);\n*          if HOWMNY = 'B', the matrix Z*X;\n*          if HOWMNY = 'S', the right eigenvectors of (S,P) specified by\n*                      SELECT, stored consecutively in the columns of\n*                      VR, in the same order as their eigenvalues.\n*          Not referenced if SIDE = 'L'.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the array VR.  LDVR >= 1, and if\n*          SIDE = 'R' or 'B', LDVR >= N.\n*\n*  MM      (input) INTEGER\n*          The number of columns in the arrays VL and/or VR. MM >= M.\n*\n*  M       (output) INTEGER\n*          The number of columns in the arrays VL and/or VR actually\n*          used to store the eigenvectors.  If HOWMNY = 'A' or 'B', M\n*          is set to N.  Each selected eigenvector occupies one column.\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (2*N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, info, vl, vr = NumRu::Lapack.ctgevc( side, howmny, select, s, p, vl, vr, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_side = argv[0];
  rblapack_howmny = argv[1];
  rblapack_select = argv[2];
  rblapack_s = argv[3];
  rblapack_p = argv[4];
  rblapack_vl = argv[5];
  rblapack_vr = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_select))
    rb_raise(rb_eArgError, "select (3th argument) must be NArray");
  if (NA_RANK(rblapack_select) != 1)
    rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_select);
  if (NA_TYPE(rblapack_select) != NA_LINT)
    rblapack_select = na_change_type(rblapack_select, NA_LINT);
  select = NA_PTR_TYPE(rblapack_select, logical*);
  if (!NA_IsNArray(rblapack_p))
    rb_raise(rb_eArgError, "p (5th argument) must be NArray");
  if (NA_RANK(rblapack_p) != 2)
    rb_raise(rb_eArgError, "rank of p (5th argument) must be %d", 2);
  ldp = NA_SHAPE0(rblapack_p);
  if (NA_SHAPE1(rblapack_p) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of p must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_p) != NA_SCOMPLEX)
    rblapack_p = na_change_type(rblapack_p, NA_SCOMPLEX);
  p = NA_PTR_TYPE(rblapack_p, complex*);
  if (!NA_IsNArray(rblapack_vr))
    rb_raise(rb_eArgError, "vr (7th argument) must be NArray");
  if (NA_RANK(rblapack_vr) != 2)
    rb_raise(rb_eArgError, "rank of vr (7th argument) must be %d", 2);
  ldvr = NA_SHAPE0(rblapack_vr);
  mm = NA_SHAPE1(rblapack_vr);
  if (NA_TYPE(rblapack_vr) != NA_SCOMPLEX)
    rblapack_vr = na_change_type(rblapack_vr, NA_SCOMPLEX);
  vr = NA_PTR_TYPE(rblapack_vr, complex*);
  howmny = StringValueCStr(rblapack_howmny)[0];
  if (!NA_IsNArray(rblapack_vl))
    rb_raise(rb_eArgError, "vl (6th argument) must be NArray");
  if (NA_RANK(rblapack_vl) != 2)
    rb_raise(rb_eArgError, "rank of vl (6th argument) must be %d", 2);
  ldvl = NA_SHAPE0(rblapack_vl);
  if (NA_SHAPE1(rblapack_vl) != mm)
    rb_raise(rb_eRuntimeError, "shape 1 of vl must be the same as shape 1 of vr");
  if (NA_TYPE(rblapack_vl) != NA_SCOMPLEX)
    rblapack_vl = na_change_type(rblapack_vl, NA_SCOMPLEX);
  vl = NA_PTR_TYPE(rblapack_vl, complex*);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (4th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 2)
    rb_raise(rb_eArgError, "rank of s (4th argument) must be %d", 2);
  lds = NA_SHAPE0(rblapack_s);
  if (NA_SHAPE1(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of s must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_s) != NA_SCOMPLEX)
    rblapack_s = na_change_type(rblapack_s, NA_SCOMPLEX);
  s = NA_PTR_TYPE(rblapack_s, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = mm;
    rblapack_vl_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, complex*);
  MEMCPY(vl_out__, vl, complex, NA_TOTAL(rblapack_vl));
  rblapack_vl = rblapack_vl_out__;
  vl = vl_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = mm;
    rblapack_vr_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  vr_out__ = NA_PTR_TYPE(rblapack_vr_out__, complex*);
  MEMCPY(vr_out__, vr, complex, NA_TOTAL(rblapack_vr));
  rblapack_vr = rblapack_vr_out__;
  vr = vr_out__;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (2*n));

  ctgevc_(&side, &howmny, select, &n, s, &lds, p, &ldp, vl, &ldvl, vr, &ldvr, &mm, &m, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_m, rblapack_info, rblapack_vl, rblapack_vr);
}

void
init_lapack_ctgevc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctgevc", rblapack_ctgevc, -1);
}
ruby-lapack-1.7.2/ext/clatps.c0000644000175000017500000002416512502221020016013 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clatps_(char* uplo, char* trans, char* diag, char* normin, integer* n, complex* ap, complex* x, real* scale, real* cnorm, integer* info);


static VALUE
rblapack_clatps(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_normin;
  char normin; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_cnorm;
  real *cnorm; 
  VALUE rblapack_scale;
  real scale; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  complex *x_out__;
  VALUE rblapack_cnorm_out__;
  real *cnorm_out__;

  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  scale, info, x, cnorm = NumRu::Lapack.clatps( uplo, trans, diag, normin, ap, x, cnorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, CNORM, INFO )\n\n*  Purpose\n*  =======\n*\n*  CLATPS solves one of the triangular systems\n*\n*     A * x = s*b,  A**T * x = s*b,  or  A**H * x = s*b,\n*\n*  with scaling to prevent overflow, where A is an upper or lower\n*  triangular matrix stored in packed form.  Here A**T denotes the\n*  transpose of A, A**H denotes the conjugate transpose of A, x and b\n*  are n-element vectors, and s is a scaling factor, usually less than\n*  or equal to 1, chosen so that the components of x will be less than\n*  the overflow threshold.  If the unscaled problem will not cause\n*  overflow, the Level 2 BLAS routine CTPSV is called. If the matrix A\n*  is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n*  non-trivial solution to A*x = 0 is returned.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the matrix A is upper or lower triangular.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the operation applied to A.\n*          = 'N':  Solve A * x = s*b     (No transpose)\n*          = 'T':  Solve A**T * x = s*b  (Transpose)\n*          = 'C':  Solve A**H * x = s*b  (Conjugate transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          Specifies whether or not the matrix A is unit triangular.\n*          = 'N':  Non-unit triangular\n*          = 'U':  Unit triangular\n*\n*  NORMIN  (input) CHARACTER*1\n*          Specifies whether CNORM has been set or not.\n*          = 'Y':  CNORM contains the column norms on entry\n*          = 'N':  CNORM is not set on entry.  On exit, the norms will\n*                  be computed and stored in CNORM.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)\n*          The upper or lower triangular matrix A, packed columnwise in\n*          a linear array.  The j-th column of A is stored in the array\n*          AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  X       (input/output) COMPLEX array, dimension (N)\n*          On entry, the right hand side b of the triangular system.\n*          On exit, X is overwritten by the solution vector x.\n*\n*  SCALE   (output) REAL\n*          The scaling factor s for the triangular system\n*             A * x = s*b,  A**T * x = s*b,  or  A**H * x = s*b.\n*          If SCALE = 0, the matrix A is singular or badly scaled, and\n*          the vector x is an exact or approximate solution to A*x = 0.\n*\n*  CNORM   (input or output) REAL array, dimension (N)\n*\n*          If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n*          contains the norm of the off-diagonal part of the j-th column\n*          of A.  If TRANS = 'N', CNORM(j) must be greater than or equal\n*          to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n*          must be greater than or equal to the 1-norm.\n*\n*          If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n*          returns the 1-norm of the offdiagonal part of the j-th column\n*          of A.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -k, the k-th argument had an illegal value\n*\n\n*  Further Details\n*  ======= =======\n*\n*  A rough bound on x is computed; if that is less than overflow, CTPSV\n*  is called, otherwise, specific code is used which checks for possible\n*  overflow or divide-by-zero at every operation.\n*\n*  A columnwise scheme is used for solving A*x = b.  The basic algorithm\n*  if A is lower triangular is\n*\n*       x[1:n] := b[1:n]\n*       for j = 1, ..., n\n*            x(j) := x(j) / A(j,j)\n*            x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n*       end\n*\n*  Define bounds on the components of x after j iterations of the loop:\n*     M(j) = bound on x[1:j]\n*     G(j) = bound on x[j+1:n]\n*  Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n*  Then for iteration j+1 we have\n*     M(j+1) <= G(j) / | A(j+1,j+1) |\n*     G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n*            <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n*  where CNORM(j+1) is greater than or equal to the infinity-norm of\n*  column j+1 of A, not counting the diagonal.  Hence\n*\n*     G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n*                  1<=i<=j\n*  and\n*\n*     |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n*                                   1<=i< j\n*\n*  Since |x(j)| <= M(j), we use the Level 2 BLAS routine CTPSV if the\n*  reciprocal of the largest M(j), j=1,..,n, is larger than\n*  max(underflow, 1/overflow).\n*\n*  The bound on x(j) is also used to determine when a step in the\n*  columnwise method can be performed without fear of overflow.  If\n*  the computed bound is greater than a large constant, x is scaled to\n*  prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n*  1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n*  Similarly, a row-wise scheme is used to solve A**T *x = b  or\n*  A**H *x = b.  The basic algorithm for A upper triangular is\n*\n*       for j = 1, ..., n\n*            x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n*       end\n*\n*  We simultaneously compute two bounds\n*       G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n*       M(j) = bound on x(i), 1<=i<=j\n*\n*  The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n*  add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n*  Then the bound on x(j) is\n*\n*       M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n*            <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n*                      1<=i<=j\n*\n*  and we can safely call CTPSV if 1/M(n) and 1/G(n) are both greater\n*  than max(underflow, 1/overflow).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, info, x, cnorm = NumRu::Lapack.clatps( uplo, trans, diag, normin, ap, x, cnorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_normin = argv[3];
  rblapack_ap = argv[4];
  rblapack_x = argv[5];
  rblapack_cnorm = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_cnorm))
    rb_raise(rb_eArgError, "cnorm (7th argument) must be NArray");
  if (NA_RANK(rblapack_cnorm) != 1)
    rb_raise(rb_eArgError, "rank of cnorm (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_cnorm) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of cnorm must be the same as shape 0 of x");
  if (NA_TYPE(rblapack_cnorm) != NA_SFLOAT)
    rblapack_cnorm = na_change_type(rblapack_cnorm, NA_SFLOAT);
  cnorm = NA_PTR_TYPE(rblapack_cnorm, real*);
  normin = StringValueCStr(rblapack_normin)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_cnorm_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  cnorm_out__ = NA_PTR_TYPE(rblapack_cnorm_out__, real*);
  MEMCPY(cnorm_out__, cnorm, real, NA_TOTAL(rblapack_cnorm));
  rblapack_cnorm = rblapack_cnorm_out__;
  cnorm = cnorm_out__;

  clatps_(&uplo, &trans, &diag, &normin, &n, ap, x, &scale, cnorm, &info);

  rblapack_scale = rb_float_new((double)scale);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_scale, rblapack_info, rblapack_x, rblapack_cnorm);
}

void
init_lapack_clatps(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clatps", rblapack_clatps, -1);
}
ruby-lapack-1.7.2/ext/dorgr2.c0000644000175000017500000001035212502221017015723 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dorgr2_(integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* info);


static VALUE
rblapack_dorgr2(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 k;
  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  info, a = NumRu::Lapack.dorgr2( a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DORGR2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DORGR2 generates an m by n real matrix Q with orthonormal rows,\n*  which is defined as the last m rows of a product of k elementary\n*  reflectors of order n\n*\n*        Q  =  H(1) H(2) . . . H(k)\n*\n*  as returned by DGERQF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. N >= M.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. M >= K >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the (m-k+i)-th row must contain the vector which\n*          defines the elementary reflector H(i), for i = 1,2,...,k, as\n*          returned by DGERQF in the last k rows of its array argument\n*          A.\n*          On exit, the m by n matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) DOUBLE PRECISION array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by DGERQF.\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 has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.dorgr2( a, tau, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_a = argv[0];
  rblapack_tau = argv[1];
  if (argc == 2) {
  } 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;
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (2th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (2th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t 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));

  dorgr2_(&m, &n, &k, a, &lda, tau, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_dorgr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dorgr2", rblapack_dorgr2, -1);
}
ruby-lapack-1.7.2/ext/zgtsvx.c0000644000175000017500000004206712502221015016077 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgtsvx_(char* fact, char* trans, integer* n, integer* nrhs, doublecomplex* dl, doublecomplex* d, doublecomplex* du, doublecomplex* dlf, doublecomplex* df, doublecomplex* duf, doublecomplex* du2, integer* ipiv, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zgtsvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_dl;
  doublecomplex *dl; 
  VALUE rblapack_d;
  doublecomplex *d; 
  VALUE rblapack_du;
  doublecomplex *du; 
  VALUE rblapack_dlf;
  doublecomplex *dlf; 
  VALUE rblapack_df;
  doublecomplex *df; 
  VALUE rblapack_duf;
  doublecomplex *duf; 
  VALUE rblapack_du2;
  doublecomplex *du2; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_dlf_out__;
  doublecomplex *dlf_out__;
  VALUE rblapack_df_out__;
  doublecomplex *df_out__;
  VALUE rblapack_duf_out__;
  doublecomplex *duf_out__;
  VALUE rblapack_du2_out__;
  doublecomplex *du2_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, info, dlf, df, duf, du2, ipiv = NumRu::Lapack.zgtsvx( fact, trans, dl, d, du, dlf, df, duf, du2, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGTSVX uses the LU factorization to compute the solution to a complex\n*  system of linear equations A * X = B, A**T * X = B, or A**H * X = B,\n*  where A is a tridiagonal matrix of order N and X and B are N-by-NRHS\n*  matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'N', the LU decomposition is used to factor the matrix A\n*     as A = L * U, where L is a product of permutation and unit lower\n*     bidiagonal matrices and U is upper triangular with nonzeros in\n*     only the main diagonal and first two superdiagonals.\n*\n*  2. If some U(i,i)=0, so that U is exactly singular, then the routine\n*     returns with INFO = i. Otherwise, the factored form of A is used\n*     to estimate the condition number of the matrix A.  If the\n*     reciprocal of the condition number is less than machine precision,\n*     INFO = N+1 is returned as a warning, but the routine still goes on\n*     to solve for X and compute error bounds as described below.\n*\n*  3. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  4. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of A has been\n*          supplied on entry.\n*          = 'F':  DLF, DF, DUF, DU2, and IPIV contain the factored form\n*                  of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV will not\n*                  be modified.\n*          = 'N':  The matrix will be copied to DLF, DF, and DUF\n*                  and factored.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  DL      (input) COMPLEX*16 array, dimension (N-1)\n*          The (n-1) subdiagonal elements of A.\n*\n*  D       (input) COMPLEX*16 array, dimension (N)\n*          The n diagonal elements of A.\n*\n*  DU      (input) COMPLEX*16 array, dimension (N-1)\n*          The (n-1) superdiagonal elements of A.\n*\n*  DLF     (input or output) COMPLEX*16 array, dimension (N-1)\n*          If FACT = 'F', then DLF is an input argument and on entry\n*          contains the (n-1) multipliers that define the matrix L from\n*          the LU factorization of A as computed by ZGTTRF.\n*\n*          If FACT = 'N', then DLF is an output argument and on exit\n*          contains the (n-1) multipliers that define the matrix L from\n*          the LU factorization of A.\n*\n*  DF      (input or output) COMPLEX*16 array, dimension (N)\n*          If FACT = 'F', then DF is an input argument and on entry\n*          contains the n diagonal elements of the upper triangular\n*          matrix U from the LU factorization of A.\n*\n*          If FACT = 'N', then DF is an output argument and on exit\n*          contains the n diagonal elements of the upper triangular\n*          matrix U from the LU factorization of A.\n*\n*  DUF     (input or output) COMPLEX*16 array, dimension (N-1)\n*          If FACT = 'F', then DUF is an input argument and on entry\n*          contains the (n-1) elements of the first superdiagonal of U.\n*\n*          If FACT = 'N', then DUF is an output argument and on exit\n*          contains the (n-1) elements of the first superdiagonal of U.\n*\n*  DU2     (input or output) COMPLEX*16 array, dimension (N-2)\n*          If FACT = 'F', then DU2 is an input argument and on entry\n*          contains the (n-2) elements of the second superdiagonal of\n*          U.\n*\n*          If FACT = 'N', then DU2 is an output argument and on exit\n*          contains the (n-2) elements of the second superdiagonal of\n*          U.\n*\n*  IPIV    (input or output) INTEGER array, dimension (N)\n*          If FACT = 'F', then IPIV is an input argument and on entry\n*          contains the pivot indices from the LU factorization of A as\n*          computed by ZGTTRF.\n*\n*          If FACT = 'N', then IPIV is an output argument and on exit\n*          contains the pivot indices from the LU factorization of A;\n*          row i of the matrix was interchanged with row IPIV(i).\n*          IPIV(i) will always be either i or i+1; IPIV(i) = i indicates\n*          a row interchange was not required.\n*\n*  B       (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*          The N-by-NRHS right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) COMPLEX*16 array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The estimate of the reciprocal condition number of the matrix\n*          A.  If RCOND is less than the machine precision (in\n*          particular, if RCOND = 0), the matrix is singular to working\n*          precision.  This condition is indicated by a return code of\n*          INFO > 0.\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\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, and i is\n*                <= N:  U(i,i) is exactly zero.  The factorization\n*                       has not been completed unless i = N, but the\n*                       factor U is exactly singular, so the solution\n*                       and error bounds could not be computed.\n*                       RCOND = 0 is returned.\n*                = N+1: U is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, info, dlf, df, duf, du2, ipiv = NumRu::Lapack.zgtsvx( fact, trans, dl, d, du, dlf, df, duf, du2, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 11 && argc != 11)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
  rblapack_fact = argv[0];
  rblapack_trans = argv[1];
  rblapack_dl = argv[2];
  rblapack_d = argv[3];
  rblapack_du = argv[4];
  rblapack_dlf = argv[5];
  rblapack_df = argv[6];
  rblapack_duf = argv[7];
  rblapack_du2 = argv[8];
  rblapack_ipiv = argv[9];
  rblapack_b = argv[10];
  if (argc == 11) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DCOMPLEX)
    rblapack_d = na_change_type(rblapack_d, NA_DCOMPLEX);
  d = NA_PTR_TYPE(rblapack_d, doublecomplex*);
  if (!NA_IsNArray(rblapack_df))
    rb_raise(rb_eArgError, "df (7th argument) must be NArray");
  if (NA_RANK(rblapack_df) != 1)
    rb_raise(rb_eArgError, "rank of df (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_df) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of df must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_df) != NA_DCOMPLEX)
    rblapack_df = na_change_type(rblapack_df, NA_DCOMPLEX);
  df = NA_PTR_TYPE(rblapack_df, doublecomplex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (10th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (10th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  ldx = MAX(1,n);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (5th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_DCOMPLEX)
    rblapack_du = na_change_type(rblapack_du, NA_DCOMPLEX);
  du = NA_PTR_TYPE(rblapack_du, doublecomplex*);
  if (!NA_IsNArray(rblapack_duf))
    rb_raise(rb_eArgError, "duf (8th argument) must be NArray");
  if (NA_RANK(rblapack_duf) != 1)
    rb_raise(rb_eArgError, "rank of duf (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_duf) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of duf must be %d", n-1);
  if (NA_TYPE(rblapack_duf) != NA_DCOMPLEX)
    rblapack_duf = na_change_type(rblapack_duf, NA_DCOMPLEX);
  duf = NA_PTR_TYPE(rblapack_duf, doublecomplex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (11th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (11th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (3th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_DCOMPLEX)
    rblapack_dl = na_change_type(rblapack_dl, NA_DCOMPLEX);
  dl = NA_PTR_TYPE(rblapack_dl, doublecomplex*);
  if (!NA_IsNArray(rblapack_du2))
    rb_raise(rb_eArgError, "du2 (9th argument) must be NArray");
  if (NA_RANK(rblapack_du2) != 1)
    rb_raise(rb_eArgError, "rank of du2 (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du2) != (n-2))
    rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
  if (NA_TYPE(rblapack_du2) != NA_DCOMPLEX)
    rblapack_du2 = na_change_type(rblapack_du2, NA_DCOMPLEX);
  du2 = NA_PTR_TYPE(rblapack_du2, doublecomplex*);
  if (!NA_IsNArray(rblapack_dlf))
    rb_raise(rb_eArgError, "dlf (6th argument) must be NArray");
  if (NA_RANK(rblapack_dlf) != 1)
    rb_raise(rb_eArgError, "rank of dlf (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dlf) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dlf must be %d", n-1);
  if (NA_TYPE(rblapack_dlf) != NA_DCOMPLEX)
    rblapack_dlf = na_change_type(rblapack_dlf, NA_DCOMPLEX);
  dlf = NA_PTR_TYPE(rblapack_dlf, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_dlf_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  dlf_out__ = NA_PTR_TYPE(rblapack_dlf_out__, doublecomplex*);
  MEMCPY(dlf_out__, dlf, doublecomplex, NA_TOTAL(rblapack_dlf));
  rblapack_dlf = rblapack_dlf_out__;
  dlf = dlf_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_df_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  df_out__ = NA_PTR_TYPE(rblapack_df_out__, doublecomplex*);
  MEMCPY(df_out__, df, doublecomplex, NA_TOTAL(rblapack_df));
  rblapack_df = rblapack_df_out__;
  df = df_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_duf_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  duf_out__ = NA_PTR_TYPE(rblapack_duf_out__, doublecomplex*);
  MEMCPY(duf_out__, duf, doublecomplex, NA_TOTAL(rblapack_duf));
  rblapack_duf = rblapack_duf_out__;
  duf = duf_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-2;
    rblapack_du2_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  du2_out__ = NA_PTR_TYPE(rblapack_du2_out__, doublecomplex*);
  MEMCPY(du2_out__, du2, doublecomplex, NA_TOTAL(rblapack_du2));
  rblapack_du2 = rblapack_du2_out__;
  du2 = du2_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (n));

  zgtsvx_(&fact, &trans, &n, &nrhs, dl, d, du, dlf, df, duf, du2, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_dlf, rblapack_df, rblapack_duf, rblapack_du2, rblapack_ipiv);
}

void
init_lapack_zgtsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgtsvx", rblapack_zgtsvx, -1);
}
ruby-lapack-1.7.2/ext/cbbcsd.c0000644000175000017500000004036412502221021015745 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cbbcsd_(char* jobu1, char* jobu2, char* jobv1t, char* jobv2t, char* trans, integer* m, integer* p, integer* q, real* theta, real* phi, complex* u1, integer* ldu1, complex* u2, integer* ldu2, complex* v1t, integer* ldv1t, complex* v2t, integer* ldv2t, real* b11d, real* b11e, real* b12d, real* b12e, real* b21d, real* b21e, real* b22d, real* b22e, real* rwork, integer* lrwork, integer* info);


static VALUE
rblapack_cbbcsd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobu1;
  char jobu1; 
  VALUE rblapack_jobu2;
  char jobu2; 
  VALUE rblapack_jobv1t;
  char jobv1t; 
  VALUE rblapack_jobv2t;
  char jobv2t; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_theta;
  real *theta; 
  VALUE rblapack_phi;
  real *phi; 
  VALUE rblapack_u1;
  complex *u1; 
  VALUE rblapack_u2;
  complex *u2; 
  VALUE rblapack_v1t;
  complex *v1t; 
  VALUE rblapack_v2t;
  complex *v2t; 
  VALUE rblapack_lrwork;
  integer lrwork; 
  VALUE rblapack_b11d;
  real *b11d; 
  VALUE rblapack_b11e;
  real *b11e; 
  VALUE rblapack_b12d;
  real *b12d; 
  VALUE rblapack_b12e;
  real *b12e; 
  VALUE rblapack_b21d;
  real *b21d; 
  VALUE rblapack_b21e;
  real *b21e; 
  VALUE rblapack_b22d;
  real *b22d; 
  VALUE rblapack_b22e;
  real *b22e; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_theta_out__;
  real *theta_out__;
  VALUE rblapack_u1_out__;
  complex *u1_out__;
  VALUE rblapack_u2_out__;
  complex *u2_out__;
  VALUE rblapack_v1t_out__;
  complex *v1t_out__;
  VALUE rblapack_v2t_out__;
  complex *v2t_out__;
  real *rwork;

  integer q;
  integer ldu1;
  integer p;
  integer ldu2;
  integer ldv1t;
  integer ldv2t;

  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  b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, info, theta, u1, u2, v1t, v2t = NumRu::Lapack.cbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, theta, phi, u1, u2, v1t, v2t, [:lrwork => lrwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, THETA, PHI, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, B22D, B22E, RWORK, LRWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CBBCSD computes the CS decomposition of a unitary matrix in\n*  bidiagonal-block form,\n*\n*\n*      [ B11 | B12 0  0 ]\n*      [  0  |  0 -I  0 ]\n*  X = [----------------]\n*      [ B21 | B22 0  0 ]\n*      [  0  |  0  0  I ]\n*\n*                                [  C | -S  0  0 ]\n*                    [ U1 |    ] [  0 |  0 -I  0 ] [ V1 |    ]**H\n*                  = [---------] [---------------] [---------]   .\n*                    [    | U2 ] [  S |  C  0  0 ] [    | V2 ]\n*                                [  0 |  0  0  I ]\n*\n*  X is M-by-M, its top-left block is P-by-Q, and Q must be no larger\n*  than P, M-P, or M-Q. (If Q is not the smallest index, then X must be\n*  transposed and/or permuted. This can be done in constant time using\n*  the TRANS and SIGNS options. See CUNCSD for details.)\n*\n*  The bidiagonal matrices B11, B12, B21, and B22 are represented\n*  implicitly by angles THETA(1:Q) and PHI(1:Q-1).\n*\n*  The unitary matrices U1, U2, V1T, and V2T are input/output.\n*  The input matrices are pre- or post-multiplied by the appropriate\n*  singular vector matrices.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBU1   (input) CHARACTER\n*          = 'Y':      U1 is updated;\n*          otherwise:  U1 is not updated.\n*\n*  JOBU2   (input) CHARACTER\n*          = 'Y':      U2 is updated;\n*          otherwise:  U2 is not updated.\n*\n*  JOBV1T  (input) CHARACTER\n*          = 'Y':      V1T is updated;\n*          otherwise:  V1T is not updated.\n*\n*  JOBV2T  (input) CHARACTER\n*          = 'Y':      V2T is updated;\n*          otherwise:  V2T is not updated.\n*\n*  TRANS   (input) CHARACTER\n*          = 'T':      X, U1, U2, V1T, and V2T are stored in row-major\n*                      order;\n*          otherwise:  X, U1, U2, V1T, and V2T are stored in column-\n*                      major order.\n*\n*  M       (input) INTEGER\n*          The number of rows and columns in X, the unitary matrix in\n*          bidiagonal-block form.\n*\n*  P       (input) INTEGER\n*          The number of rows in the top-left block of X. 0 <= P <= M.\n*\n*  Q       (input) INTEGER\n*          The number of columns in the top-left block of X.\n*          0 <= Q <= MIN(P,M-P,M-Q).\n*\n*  THETA   (input/output) REAL array, dimension (Q)\n*          On entry, the angles THETA(1),...,THETA(Q) that, along with\n*          PHI(1), ...,PHI(Q-1), define the matrix in bidiagonal-block\n*          form. On exit, the angles whose cosines and sines define the\n*          diagonal blocks in the CS decomposition.\n*\n*  PHI     (input/workspace) REAL array, dimension (Q-1)\n*          The angles PHI(1),...,PHI(Q-1) that, along with THETA(1),...,\n*          THETA(Q), define the matrix in bidiagonal-block form.\n*\n*  U1      (input/output) COMPLEX array, dimension (LDU1,P)\n*          On entry, an LDU1-by-P matrix. On exit, U1 is postmultiplied\n*          by the left singular vector matrix common to [ B11 ; 0 ] and\n*          [ B12 0 0 ; 0 -I 0 0 ].\n*\n*  LDU1    (input) INTEGER\n*          The leading dimension of the array U1.\n*\n*  U2      (input/output) COMPLEX array, dimension (LDU2,M-P)\n*          On entry, an LDU2-by-(M-P) matrix. On exit, U2 is\n*          postmultiplied by the left singular vector matrix common to\n*          [ B21 ; 0 ] and [ B22 0 0 ; 0 0 I ].\n*\n*  LDU2    (input) INTEGER\n*          The leading dimension of the array U2.\n*\n*  V1T     (input/output) COMPLEX array, dimension (LDV1T,Q)\n*          On entry, a LDV1T-by-Q matrix. On exit, V1T is premultiplied\n*          by the conjugate transpose of the right singular vector\n*          matrix common to [ B11 ; 0 ] and [ B21 ; 0 ].\n*\n*  LDV1T   (input) INTEGER\n*          The leading dimension of the array V1T.\n*\n*  V2T     (input/output) COMPLEX array, dimenison (LDV2T,M-Q)\n*          On entry, a LDV2T-by-(M-Q) matrix. On exit, V2T is\n*          premultiplied by the conjugate transpose of the right\n*          singular vector matrix common to [ B12 0 0 ; 0 -I 0 ] and\n*          [ B22 0 0 ; 0 0 I ].\n*\n*  LDV2T   (input) INTEGER\n*          The leading dimension of the array V2T.\n*\n*  B11D    (output) REAL array, dimension (Q)\n*          When CBBCSD converges, B11D contains the cosines of THETA(1),\n*          ..., THETA(Q). If CBBCSD fails to converge, then B11D\n*          contains the diagonal of the partially reduced top-left\n*          block.\n*\n*  B11E    (output) REAL array, dimension (Q-1)\n*          When CBBCSD converges, B11E contains zeros. If CBBCSD fails\n*          to converge, then B11E contains the superdiagonal of the\n*          partially reduced top-left block.\n*\n*  B12D    (output) REAL array, dimension (Q)\n*          When CBBCSD converges, B12D contains the negative sines of\n*          THETA(1), ..., THETA(Q). If CBBCSD fails to converge, then\n*          B12D contains the diagonal of the partially reduced top-right\n*          block.\n*\n*  B12E    (output) REAL array, dimension (Q-1)\n*          When CBBCSD converges, B12E contains zeros. If CBBCSD fails\n*          to converge, then B12E contains the subdiagonal of the\n*          partially reduced top-right block.\n*\n*  RWORK   (workspace) REAL array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LRWORK  (input) INTEGER\n*          The dimension of the array RWORK. LRWORK >= MAX(1,8*Q).\n*\n*          If LRWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal size of the RWORK array,\n*          returns this value as the first entry of the work array, and\n*          no error message related to LRWORK 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 CBBCSD did not converge, INFO specifies the number\n*                of nonzero entries in PHI, and B11D, B11E, etc.,\n*                contain the partially reduced matrix.\n*\n*  Reference\n*  =========\n*\n*  [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.\n*      Algorithms, 50(1):33-65, 2009.\n*\n*  Internal Parameters\n*  ===================\n*\n*  TOLMUL  REAL, default = MAX(10,MIN(100,EPS**(-1/8)))\n*          TOLMUL controls the convergence criterion of the QR loop.\n*          Angles THETA(i), PHI(i) are rounded to 0 or PI/2 when they\n*          are within TOLMUL*EPS of either bound.\n*\n\n*  ===================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, info, theta, u1, u2, v1t, v2t = NumRu::Lapack.cbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, theta, phi, u1, u2, v1t, v2t, [:lrwork => lrwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 13)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_jobu1 = argv[0];
  rblapack_jobu2 = argv[1];
  rblapack_jobv1t = argv[2];
  rblapack_jobv2t = argv[3];
  rblapack_trans = argv[4];
  rblapack_m = argv[5];
  rblapack_theta = argv[6];
  rblapack_phi = argv[7];
  rblapack_u1 = argv[8];
  rblapack_u2 = argv[9];
  rblapack_v1t = argv[10];
  rblapack_v2t = argv[11];
  if (argc == 13) {
    rblapack_lrwork = argv[12];
  } else if (rblapack_options != Qnil) {
    rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
  } else {
    rblapack_lrwork = Qnil;
  }

  jobu1 = StringValueCStr(rblapack_jobu1)[0];
  jobv1t = StringValueCStr(rblapack_jobv1t)[0];
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_theta))
    rb_raise(rb_eArgError, "theta (7th argument) must be NArray");
  if (NA_RANK(rblapack_theta) != 1)
    rb_raise(rb_eArgError, "rank of theta (7th argument) must be %d", 1);
  q = NA_SHAPE0(rblapack_theta);
  if (NA_TYPE(rblapack_theta) != NA_SFLOAT)
    rblapack_theta = na_change_type(rblapack_theta, NA_SFLOAT);
  theta = NA_PTR_TYPE(rblapack_theta, real*);
  if (!NA_IsNArray(rblapack_u1))
    rb_raise(rb_eArgError, "u1 (9th argument) must be NArray");
  if (NA_RANK(rblapack_u1) != 2)
    rb_raise(rb_eArgError, "rank of u1 (9th argument) must be %d", 2);
  ldu1 = NA_SHAPE0(rblapack_u1);
  p = NA_SHAPE1(rblapack_u1);
  if (NA_TYPE(rblapack_u1) != NA_SCOMPLEX)
    rblapack_u1 = na_change_type(rblapack_u1, NA_SCOMPLEX);
  u1 = NA_PTR_TYPE(rblapack_u1, complex*);
  if (!NA_IsNArray(rblapack_v1t))
    rb_raise(rb_eArgError, "v1t (11th argument) must be NArray");
  if (NA_RANK(rblapack_v1t) != 2)
    rb_raise(rb_eArgError, "rank of v1t (11th argument) must be %d", 2);
  ldv1t = NA_SHAPE0(rblapack_v1t);
  if (NA_SHAPE1(rblapack_v1t) != q)
    rb_raise(rb_eRuntimeError, "shape 1 of v1t must be the same as shape 0 of theta");
  if (NA_TYPE(rblapack_v1t) != NA_SCOMPLEX)
    rblapack_v1t = na_change_type(rblapack_v1t, NA_SCOMPLEX);
  v1t = NA_PTR_TYPE(rblapack_v1t, complex*);
  lrwork = MAX(1,8*q);
  jobu2 = StringValueCStr(rblapack_jobu2)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_u2))
    rb_raise(rb_eArgError, "u2 (10th argument) must be NArray");
  if (NA_RANK(rblapack_u2) != 2)
    rb_raise(rb_eArgError, "rank of u2 (10th argument) must be %d", 2);
  ldu2 = NA_SHAPE0(rblapack_u2);
  if (NA_SHAPE1(rblapack_u2) != (m-p))
    rb_raise(rb_eRuntimeError, "shape 1 of u2 must be %d", m-p);
  if (NA_TYPE(rblapack_u2) != NA_SCOMPLEX)
    rblapack_u2 = na_change_type(rblapack_u2, NA_SCOMPLEX);
  u2 = NA_PTR_TYPE(rblapack_u2, complex*);
  jobv2t = StringValueCStr(rblapack_jobv2t)[0];
  if (!NA_IsNArray(rblapack_v2t))
    rb_raise(rb_eArgError, "v2t (12th argument) must be NArray");
  if (NA_RANK(rblapack_v2t) != 2)
    rb_raise(rb_eArgError, "rank of v2t (12th argument) must be %d", 2);
  ldv2t = NA_SHAPE0(rblapack_v2t);
  if (NA_SHAPE1(rblapack_v2t) != (m-q))
    rb_raise(rb_eRuntimeError, "shape 1 of v2t must be %d", m-q);
  if (NA_TYPE(rblapack_v2t) != NA_SCOMPLEX)
    rblapack_v2t = na_change_type(rblapack_v2t, NA_SCOMPLEX);
  v2t = NA_PTR_TYPE(rblapack_v2t, complex*);
  if (!NA_IsNArray(rblapack_phi))
    rb_raise(rb_eArgError, "phi (8th argument) must be NArray");
  if (NA_RANK(rblapack_phi) != 1)
    rb_raise(rb_eArgError, "rank of phi (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_phi) != (q-1))
    rb_raise(rb_eRuntimeError, "shape 0 of phi must be %d", q-1);
  if (NA_TYPE(rblapack_phi) != NA_SFLOAT)
    rblapack_phi = na_change_type(rblapack_phi, NA_SFLOAT);
  phi = NA_PTR_TYPE(rblapack_phi, real*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_b11d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  b11d = NA_PTR_TYPE(rblapack_b11d, real*);
  {
    na_shape_t shape[1];
    shape[0] = q-1;
    rblapack_b11e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  b11e = NA_PTR_TYPE(rblapack_b11e, real*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_b12d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  b12d = NA_PTR_TYPE(rblapack_b12d, real*);
  {
    na_shape_t shape[1];
    shape[0] = q-1;
    rblapack_b12e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  b12e = NA_PTR_TYPE(rblapack_b12e, real*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_b21d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  b21d = NA_PTR_TYPE(rblapack_b21d, real*);
  {
    na_shape_t shape[1];
    shape[0] = q-1;
    rblapack_b21e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  b21e = NA_PTR_TYPE(rblapack_b21e, real*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_b22d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  b22d = NA_PTR_TYPE(rblapack_b22d, real*);
  {
    na_shape_t shape[1];
    shape[0] = q-1;
    rblapack_b22e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  b22e = NA_PTR_TYPE(rblapack_b22e, real*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_theta_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  theta_out__ = NA_PTR_TYPE(rblapack_theta_out__, real*);
  MEMCPY(theta_out__, theta, real, NA_TOTAL(rblapack_theta));
  rblapack_theta = rblapack_theta_out__;
  theta = theta_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldu1;
    shape[1] = p;
    rblapack_u1_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  u1_out__ = NA_PTR_TYPE(rblapack_u1_out__, complex*);
  MEMCPY(u1_out__, u1, complex, NA_TOTAL(rblapack_u1));
  rblapack_u1 = rblapack_u1_out__;
  u1 = u1_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldu2;
    shape[1] = m-p;
    rblapack_u2_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  u2_out__ = NA_PTR_TYPE(rblapack_u2_out__, complex*);
  MEMCPY(u2_out__, u2, complex, NA_TOTAL(rblapack_u2));
  rblapack_u2 = rblapack_u2_out__;
  u2 = u2_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldv1t;
    shape[1] = q;
    rblapack_v1t_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  v1t_out__ = NA_PTR_TYPE(rblapack_v1t_out__, complex*);
  MEMCPY(v1t_out__, v1t, complex, NA_TOTAL(rblapack_v1t));
  rblapack_v1t = rblapack_v1t_out__;
  v1t = v1t_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldv2t;
    shape[1] = m-q;
    rblapack_v2t_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  v2t_out__ = NA_PTR_TYPE(rblapack_v2t_out__, complex*);
  MEMCPY(v2t_out__, v2t, complex, NA_TOTAL(rblapack_v2t));
  rblapack_v2t = rblapack_v2t_out__;
  v2t = v2t_out__;
  rwork = ALLOC_N(real, (MAX(1,lrwork)));

  cbbcsd_(&jobu1, &jobu2, &jobv1t, &jobv2t, &trans, &m, &p, &q, theta, phi, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, v2t, &ldv2t, b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, rwork, &lrwork, &info);

  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(14, rblapack_b11d, rblapack_b11e, rblapack_b12d, rblapack_b12e, rblapack_b21d, rblapack_b21e, rblapack_b22d, rblapack_b22e, rblapack_info, rblapack_theta, rblapack_u1, rblapack_u2, rblapack_v1t, rblapack_v2t);
}

void
init_lapack_cbbcsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cbbcsd", rblapack_cbbcsd, -1);
}
ruby-lapack-1.7.2/ext/cla_porpvgrw.c0000644000175000017500000001205412502221012017225 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real cla_porpvgrw_(char* uplo, integer* ncols, complex* a, integer* lda, complex* af, integer* ldaf, complex* work);


static VALUE
rblapack_cla_porpvgrw(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ncols;
  integer ncols; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack___out__;
  real __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  __out__ = NumRu::Lapack.cla_porpvgrw( uplo, ncols, a, af, work, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL FUNCTION CLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, LDAF, WORK )\n\n*  Purpose\n*  =======\n* \n*  CLA_PORPVGRW computes the reciprocal pivot growth factor\n*  norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n*  much less than 1, the stability of the LU factorization of the\n*  (equilibrated) matrix A could be poor. This also means that the\n*  solution X, estimated condition numbers, and error bounds could be\n*  unreliable.\n*\n\n*  Arguments\n*  =========\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     NCOLS   (input) INTEGER\n*     The number of columns of the matrix A. NCOLS >= 0.\n*\n*     A       (input) COMPLEX array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX array, dimension (LDAF,N)\n*     The triangular factor U or L from the Cholesky factorization\n*     A = U**T*U or A = L*L**T, as computed by CPOTRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     WORK    (input) COMPLEX array, dimension (2*N)\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n      REAL               AMAX, UMAX, RPVGRW\n      LOGICAL            UPPER\n      COMPLEX            ZDUM\n*     ..\n*     .. External Functions ..\n      EXTERNAL           LSAME, CLASET\n      LOGICAL            LSAME\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX, MIN, REAL, AIMAG\n*     ..\n*     .. Statement Functions ..\n      REAL               CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.cla_porpvgrw( uplo, ncols, a, af, work, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_ncols = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_work = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  ncols = NUM2INT(rblapack_ncols);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (5th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
  if (NA_TYPE(rblapack_work) != NA_SCOMPLEX)
    rblapack_work = na_change_type(rblapack_work, NA_SCOMPLEX);
  work = NA_PTR_TYPE(rblapack_work, complex*);

  __out__ = cla_porpvgrw_(&uplo, &ncols, a, &lda, af, &ldaf, work);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_cla_porpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cla_porpvgrw", rblapack_cla_porpvgrw, -1);
}
ruby-lapack-1.7.2/ext/dsyconv.c0000644000175000017500000001067612502221015016220 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsyconv_(char* uplo, char* way, integer* n, doublereal* a, integer* lda, integer* ipiv, doublereal* work, integer* info);


static VALUE
rblapack_dsyconv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_way;
  char way; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  doublereal *work;

  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  info = NumRu::Lapack.dsyconv( uplo, way, a, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSYCONV( UPLO, WAY, N, A, LDA, IPIV, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSYCONV convert A given by TRF into L and D and vice-versa.\n*  Get Non-diag elements of D (returned in workspace) and \n*  apply or reverse permutation done in TRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n* \n*  WAY     (input) CHARACTER*1\n*          = 'C': Convert \n*          = 'R': Revert\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by DSYTRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by DSYTRF.\n*\n* WORK     (workspace) DOUBLE PRECISION array, dimension (N)\n*\n* LWORK    (input) INTEGER\n*          The length of WORK.  LWORK >=1. \n*          LWORK = N\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info = NumRu::Lapack.dsyconv( uplo, way, a, ipiv, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_way = argv[1];
  rblapack_a = argv[2];
  rblapack_ipiv = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  way = StringValueCStr(rblapack_way)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  work = ALLOC_N(doublereal, (MAX(1,n)));

  dsyconv_(&uplo, &way, &n, a, &lda, ipiv, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rblapack_info;
}

void
init_lapack_dsyconv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsyconv", rblapack_dsyconv, -1);
}
ruby-lapack-1.7.2/ext/sgeqr2.c0000644000175000017500000001023112502221026015723 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgeqr2_(integer* m, integer* n, real* a, integer* lda, real* tau, real* work, integer* info);


static VALUE
rblapack_sgeqr2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  real *work;

  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, info, a = NumRu::Lapack.sgeqr2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGEQR2( M, N, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGEQR2 computes a QR factorization of a real m by n matrix A:\n*  A = Q * R.\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) REAL array, dimension (LDA,N)\n*          On entry, the m by n matrix A.\n*          On exit, the elements on and above the diagonal of the array\n*          contain the min(m,n) by n upper trapezoidal matrix R (R is\n*          upper triangular if m >= n); the elements below 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) REAL array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace) REAL array, dimension (N)\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(1) H(2) . . . H(k), 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:m) is stored on exit in A(i+1:m,i),\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.sgeqr2( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(real, (n));

  sgeqr2_(&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_sgeqr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgeqr2", rblapack_sgeqr2, -1);
}
ruby-lapack-1.7.2/ext/dgerq2.c0000644000175000017500000001046312502221021015706 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgerq2_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* info);


static VALUE
rblapack_dgerq2(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.dgerq2( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGERQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGERQ2 computes an RQ factorization of a real m by n matrix A:\n*  A = R * 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, if m <= n, the upper triangle of the subarray\n*          A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;\n*          if m >= n, the elements on and above the (m-n)-th subdiagonal\n*          contain the m by n upper trapezoidal matrix R; the remaining\n*          elements, with the array TAU, represent the orthogonal matrix\n*          Q as a product of elementary reflectors (see Further\n*          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(1) H(2) . . . H(k), 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(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n*  A(m-k+i,1:n-k+i-1), 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.dgerq2( 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;
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t 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));

  dgerq2_(&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_dgerq2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgerq2", rblapack_dgerq2, -1);
}
ruby-lapack-1.7.2/ext/slasdt.c0000644000175000017500000000676612502221016016033 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slasdt_(integer* n, integer* lvl, integer* nd, integer* inode, integer* ndiml, integer* ndimr, integer* msub);


static VALUE
rblapack_slasdt(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_msub;
  integer msub; 
  VALUE rblapack_lvl;
  integer lvl; 
  VALUE rblapack_nd;
  integer nd; 
  VALUE rblapack_inode;
  integer *inode; 
  VALUE rblapack_ndiml;
  integer *ndiml; 
  VALUE rblapack_ndimr;
  integer *ndimr; 


  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  lvl, nd, inode, ndiml, ndimr = NumRu::Lapack.slasdt( n, msub, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB )\n\n*  Purpose\n*  =======\n*\n*  SLASDT creates a tree of subproblems for bidiagonal divide and\n*  conquer.\n*\n\n*  Arguments\n*  =========\n*\n*   N      (input) INTEGER\n*          On entry, the number of diagonal elements of the\n*          bidiagonal matrix.\n*\n*   LVL    (output) INTEGER\n*          On exit, the number of levels on the computation tree.\n*\n*   ND     (output) INTEGER\n*          On exit, the number of nodes on the tree.\n*\n*   INODE  (output) INTEGER array, dimension ( N )\n*          On exit, centers of subproblems.\n*\n*   NDIML  (output) INTEGER array, dimension ( N )\n*          On exit, row dimensions of left children.\n*\n*   NDIMR  (output) INTEGER array, dimension ( N )\n*          On exit, row dimensions of right children.\n*\n*   MSUB   (input) INTEGER\n*          On entry, the maximum row dimension each subproblem at the\n*          bottom of the tree can be of.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  lvl, nd, inode, ndiml, ndimr = NumRu::Lapack.slasdt( n, msub, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_n = argv[0];
  rblapack_msub = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  msub = NUM2INT(rblapack_msub);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,n);
    rblapack_inode = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  inode = NA_PTR_TYPE(rblapack_inode, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,n);
    rblapack_ndiml = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ndiml = NA_PTR_TYPE(rblapack_ndiml, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,n);
    rblapack_ndimr = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ndimr = NA_PTR_TYPE(rblapack_ndimr, integer*);

  slasdt_(&n, &lvl, &nd, inode, ndiml, ndimr, &msub);

  rblapack_lvl = INT2NUM(lvl);
  rblapack_nd = INT2NUM(nd);
  return rb_ary_new3(5, rblapack_lvl, rblapack_nd, rblapack_inode, rblapack_ndiml, rblapack_ndimr);
}

void
init_lapack_slasdt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slasdt", rblapack_slasdt, -1);
}
ruby-lapack-1.7.2/ext/zgeevx.c0000644000175000017500000003163312502221022016035 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgeevx_(char* balanc, char* jobvl, char* jobvr, char* sense, integer* n, doublecomplex* a, integer* lda, doublecomplex* w, doublecomplex* vl, integer* ldvl, doublecomplex* vr, integer* ldvr, integer* ilo, integer* ihi, doublereal* scale, doublereal* abnrm, doublereal* rconde, doublereal* rcondv, doublecomplex* work, integer* lwork, doublereal* rwork, integer* info);


static VALUE
rblapack_zgeevx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_balanc;
  char balanc; 
  VALUE rblapack_jobvl;
  char jobvl; 
  VALUE rblapack_jobvr;
  char jobvr; 
  VALUE rblapack_sense;
  char sense; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_w;
  doublecomplex *w; 
  VALUE rblapack_vl;
  doublecomplex *vl; 
  VALUE rblapack_vr;
  doublecomplex *vr; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_scale;
  doublereal *scale; 
  VALUE rblapack_abnrm;
  doublereal abnrm; 
  VALUE rblapack_rconde;
  doublereal *rconde; 
  VALUE rblapack_rcondv;
  doublereal *rcondv; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  doublereal *rwork;

  integer lda;
  integer n;
  integer ldvl;
  integer ldvr;

  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  w, vl, vr, ilo, ihi, scale, abnrm, rconde, rcondv, work, info, a = NumRu::Lapack.zgeevx( balanc, jobvl, jobvr, sense, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, WORK, LWORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGEEVX computes for an N-by-N complex nonsymmetric matrix A, the\n*  eigenvalues and, optionally, the left and/or right eigenvectors.\n*\n*  Optionally also, it computes a balancing transformation to improve\n*  the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n*  SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues\n*  (RCONDE), and reciprocal condition numbers for the right\n*  eigenvectors (RCONDV).\n*\n*  The right eigenvector v(j) of A satisfies\n*                   A * v(j) = lambda(j) * v(j)\n*  where lambda(j) is its eigenvalue.\n*  The left eigenvector u(j) of A satisfies\n*                u(j)**H * A = lambda(j) * u(j)**H\n*  where u(j)**H denotes the conjugate transpose of u(j).\n*\n*  The computed eigenvectors are normalized to have Euclidean norm\n*  equal to 1 and largest component real.\n*\n*  Balancing a matrix means permuting the rows and columns to make it\n*  more nearly upper triangular, and applying a diagonal similarity\n*  transformation D * A * D**(-1), where D is a diagonal matrix, to\n*  make its rows and columns closer in norm and the condition numbers\n*  of its eigenvalues and eigenvectors smaller.  The computed\n*  reciprocal condition numbers correspond to the balanced matrix.\n*  Permuting rows and columns will not change the condition numbers\n*  (in exact arithmetic) but diagonal scaling will.  For further\n*  explanation of balancing, see section 4.10.2 of the LAPACK\n*  Users' Guide.\n*\n\n*  Arguments\n*  =========\n*\n*  BALANC  (input) CHARACTER*1\n*          Indicates how the input matrix should be diagonally scaled\n*          and/or permuted to improve the conditioning of its\n*          eigenvalues.\n*          = 'N': Do not diagonally scale or permute;\n*          = 'P': Perform permutations to make the matrix more nearly\n*                 upper triangular. Do not diagonally scale;\n*          = 'S': Diagonally scale the matrix, ie. replace A by\n*                 D*A*D**(-1), where D is a diagonal matrix chosen\n*                 to make the rows and columns of A more equal in\n*                 norm. Do not permute;\n*          = 'B': Both diagonally scale and permute A.\n*\n*          Computed reciprocal condition numbers will be for the matrix\n*          after balancing and/or permuting. Permuting does not change\n*          condition numbers (in exact arithmetic), but balancing does.\n*\n*  JOBVL   (input) CHARACTER*1\n*          = 'N': left eigenvectors of A are not computed;\n*          = 'V': left eigenvectors of A are computed.\n*          If SENSE = 'E' or 'B', JOBVL must = 'V'.\n*\n*  JOBVR   (input) CHARACTER*1\n*          = 'N': right eigenvectors of A are not computed;\n*          = 'V': right eigenvectors of A are computed.\n*          If SENSE = 'E' or 'B', JOBVR must = 'V'.\n*\n*  SENSE   (input) CHARACTER*1\n*          Determines which reciprocal condition numbers are computed.\n*          = 'N': None are computed;\n*          = 'E': Computed for eigenvalues only;\n*          = 'V': Computed for right eigenvectors only;\n*          = 'B': Computed for eigenvalues and right eigenvectors.\n*\n*          If SENSE = 'E' or 'B', both left and right eigenvectors\n*          must also be computed (JOBVL = 'V' and JOBVR = 'V').\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the N-by-N matrix A.\n*          On exit, A has been overwritten.  If JOBVL = 'V' or\n*          JOBVR = 'V', A contains the Schur form of the balanced\n*          version of the matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  W       (output) COMPLEX*16 array, dimension (N)\n*          W contains the computed eigenvalues.\n*\n*  VL      (output) COMPLEX*16 array, dimension (LDVL,N)\n*          If JOBVL = 'V', the left eigenvectors u(j) are stored one\n*          after another in the columns of VL, in the same order\n*          as their eigenvalues.\n*          If JOBVL = 'N', VL is not referenced.\n*          u(j) = VL(:,j), the j-th column of VL.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the array VL.  LDVL >= 1; if\n*          JOBVL = 'V', LDVL >= N.\n*\n*  VR      (output) COMPLEX*16 array, dimension (LDVR,N)\n*          If JOBVR = 'V', the right eigenvectors v(j) are stored one\n*          after another in the columns of VR, in the same order\n*          as their eigenvalues.\n*          If JOBVR = 'N', VR is not referenced.\n*          v(j) = VR(:,j), the j-th column of VR.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the array VR.  LDVR >= 1; if\n*          JOBVR = 'V', LDVR >= N.\n*\n*  ILO     (output) INTEGER\n*  IHI     (output) INTEGER\n*          ILO and IHI are integer values determined when A was\n*          balanced.  The balanced A(i,j) = 0 if I > J and\n*          J = 1,...,ILO-1 or I = IHI+1,...,N.\n*\n*  SCALE   (output) DOUBLE PRECISION array, dimension (N)\n*          Details of the permutations and scaling factors applied\n*          when balancing A.  If P(j) is the index of the row and column\n*          interchanged with row and column j, and D(j) is the scaling\n*          factor applied to row and column j, then\n*          SCALE(J) = P(J),    for J = 1,...,ILO-1\n*                   = D(J),    for J = ILO,...,IHI\n*                   = P(J)     for J = IHI+1,...,N.\n*          The order in which the interchanges are made is N to IHI+1,\n*          then 1 to ILO-1.\n*\n*  ABNRM   (output) DOUBLE PRECISION\n*          The one-norm of the balanced matrix (the maximum\n*          of the sum of absolute values of elements of any column).\n*\n*  RCONDE  (output) DOUBLE PRECISION array, dimension (N)\n*          RCONDE(j) is the reciprocal condition number of the j-th\n*          eigenvalue.\n*\n*  RCONDV  (output) DOUBLE PRECISION array, dimension (N)\n*          RCONDV(j) is the reciprocal condition number of the j-th\n*          right eigenvector.\n*\n*  WORK    (workspace/output) COMPLEX*16 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.  If SENSE = 'N' or 'E',\n*          LWORK >= max(1,2*N), and if SENSE = 'V' or 'B',\n*          LWORK >= N*N+2*N.\n*          For good performance, LWORK must generally be larger.\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*  RWORK   (workspace) DOUBLE PRECISION array, dimension (2*N)\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 QR algorithm failed to compute all the\n*                eigenvalues, and no eigenvectors or condition numbers\n*                have been computed; elements 1:ILO-1 and i+1:N of W\n*                contain eigenvalues which have converged.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, vl, vr, ilo, ihi, scale, abnrm, rconde, rcondv, work, info, a = NumRu::Lapack.zgeevx( balanc, jobvl, jobvr, sense, a, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_balanc = argv[0];
  rblapack_jobvl = argv[1];
  rblapack_jobvr = argv[2];
  rblapack_sense = argv[3];
  rblapack_a = argv[4];
  if (argc == 6) {
    rblapack_lwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  balanc = StringValueCStr(rblapack_balanc)[0];
  jobvr = StringValueCStr(rblapack_jobvr)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  ldvr = lsame_(&jobvr,"V") ? n : 1;
  jobvl = StringValueCStr(rblapack_jobvl)[0];
  ldvl = lsame_(&jobvl,"V") ? n : 1;
  sense = StringValueCStr(rblapack_sense)[0];
  if (rblapack_lwork == Qnil)
    lwork = (lsame_(&sense,"N")||lsame_(&sense,"E")) ? 2*n : (lsame_(&sense,"V")||lsame_(&sense,"B")) ? n*n+2*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = n;
    rblapack_vl = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  vl = NA_PTR_TYPE(rblapack_vl, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = n;
    rblapack_vr = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  vr = NA_PTR_TYPE(rblapack_vr, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_scale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  scale = NA_PTR_TYPE(rblapack_scale, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rconde = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  rconde = NA_PTR_TYPE(rblapack_rconde, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rcondv = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  rcondv = NA_PTR_TYPE(rblapack_rcondv, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  rwork = ALLOC_N(doublereal, (2*n));

  zgeevx_(&balanc, &jobvl, &jobvr, &sense, &n, a, &lda, w, vl, &ldvl, vr, &ldvr, &ilo, &ihi, scale, &abnrm, rconde, rcondv, work, &lwork, rwork, &info);

  free(rwork);
  rblapack_ilo = INT2NUM(ilo);
  rblapack_ihi = INT2NUM(ihi);
  rblapack_abnrm = rb_float_new((double)abnrm);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(12, rblapack_w, rblapack_vl, rblapack_vr, rblapack_ilo, rblapack_ihi, rblapack_scale, rblapack_abnrm, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_zgeevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgeevx", rblapack_zgeevx, -1);
}
ruby-lapack-1.7.2/ext/dsytrd.c0000644000175000017500000001741012502221025016036 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsytrd_(char* uplo, integer* n, doublereal* a, integer* lda, doublereal* d, doublereal* e, doublereal* tau, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dsytrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  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  d, e, tau, work, info, a = NumRu::Lapack.dsytrd( uplo, a, lwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSYTRD reduces a real symmetric matrix A to real symmetric\n*  tridiagonal form T by an orthogonal similarity transformation:\n*  Q**T * A * Q = T.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*          On exit, if UPLO = 'U', the diagonal and first superdiagonal\n*          of A are overwritten by the corresponding elements of the\n*          tridiagonal matrix T, and the elements above the first\n*          superdiagonal, with the array TAU, represent the orthogonal\n*          matrix Q as a product of elementary reflectors; if UPLO\n*          = 'L', the diagonal and first subdiagonal of A are over-\n*          written by the corresponding elements of the tridiagonal\n*          matrix T, and the elements below the first subdiagonal, with\n*          the array TAU, represent the orthogonal matrix Q as a product\n*          of elementary reflectors. See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  D       (output) DOUBLE PRECISION array, dimension (N)\n*          The diagonal elements of the tridiagonal matrix T:\n*          D(i) = A(i,i).\n*\n*  E       (output) DOUBLE PRECISION array, dimension (N-1)\n*          The off-diagonal elements of the tridiagonal matrix T:\n*          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n*  TAU     (output) DOUBLE PRECISION array, dimension (N-1)\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 >= 1.\n*          For optimum performance LWORK >= N*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*  If UPLO = 'U', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(n-1) . . . H(2) H(1).\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(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n*  A(1:i-1,i+1), and tau in TAU(i).\n*\n*  If UPLO = 'L', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(1) H(2) . . . H(n-1).\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) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n*  and tau in TAU(i).\n*\n*  The contents of A on exit are illustrated by the following examples\n*  with n = 5:\n*\n*  if UPLO = 'U':                       if UPLO = 'L':\n*\n*    (  d   e   v2  v3  v4 )              (  d                  )\n*    (      d   e   v3  v4 )              (  e   d              )\n*    (          d   e   v4 )              (  v1  e   d          )\n*    (              d   e  )              (  v1  v2  e   d      )\n*    (                  d  )              (  v1  v2  v3  e   d  )\n*\n*  where d and e denote diagonal and off-diagonal elements of T, and vi\n*  denotes an element of the vector defining H(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, tau, work, info, a = NumRu::Lapack.dsytrd( uplo, a, lwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_lwork = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  lwork = NUM2INT(rblapack_lwork);
  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*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;

  dsytrd_(&uplo, &n, a, &lda, d, e, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_d, rblapack_e, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_dsytrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsytrd", rblapack_dsytrd, -1);
}
ruby-lapack-1.7.2/ext/dspcon.c0000644000175000017500000001132012502221016016005 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dspcon_(char* uplo, integer* n, doublereal* ap, integer* ipiv, doublereal* anorm, doublereal* rcond, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dspcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_anorm;
  doublereal anorm; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_info;
  integer info; 
  doublereal *work;
  integer *iwork;

  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  rcond, info = NumRu::Lapack.dspcon( uplo, ap, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSPCON estimates the reciprocal of the condition number (in the\n*  1-norm) of a real symmetric packed matrix A using the factorization\n*  A = U*D*U**T or A = L*D*L**T computed by DSPTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by DSPTRF, stored as a\n*          packed triangular matrix.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by DSPTRF.\n*\n*  ANORM   (input) DOUBLE PRECISION\n*          The 1-norm of the original matrix A.\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n*          estimate of the 1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.dspcon( uplo, ap, ipiv, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_anorm = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  anorm = NUM2DBL(rblapack_anorm);
  work = ALLOC_N(doublereal, (2*n));
  iwork = ALLOC_N(integer, (n));

  dspcon_(&uplo, &n, ap, ipiv, &anorm, &rcond, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_dspcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dspcon", rblapack_dspcon, -1);
}
ruby-lapack-1.7.2/ext/cptts2.c0000644000175000017500000001220512502221022015736 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cptts2_(integer* iuplo, integer* n, integer* nrhs, real* d, complex* e, complex* b, integer* ldb);


static VALUE
rblapack_cptts2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_iuplo;
  integer iuplo; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  complex *e; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer n;
  integer ldb;
  integer nrhs;

  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  b = NumRu::Lapack.cptts2( iuplo, d, e, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPTTS2( IUPLO, N, NRHS, D, E, B, LDB )\n\n*  Purpose\n*  =======\n*\n*  CPTTS2 solves a tridiagonal system of the form\n*     A * X = B\n*  using the factorization A = U'*D*U or A = L*D*L' computed by CPTTRF.\n*  D is a diagonal matrix specified in the vector D, U (or L) is a unit\n*  bidiagonal matrix whose superdiagonal (subdiagonal) is specified in\n*  the vector E, and X and B are N by NRHS matrices.\n*\n\n*  Arguments\n*  =========\n*\n*  IUPLO   (input) INTEGER\n*          Specifies the form of the factorization and whether the\n*          vector E is the superdiagonal of the upper bidiagonal factor\n*          U or the subdiagonal of the lower bidiagonal factor L.\n*          = 1:  A = U'*D*U, E is the superdiagonal of U\n*          = 0:  A = L*D*L', E is the subdiagonal of L\n*\n*  N       (input) INTEGER\n*          The order of the tridiagonal matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  D       (input) REAL array, dimension (N)\n*          The n diagonal elements of the diagonal matrix D from the\n*          factorization A = U'*D*U or A = L*D*L'.\n*\n*  E       (input) COMPLEX array, dimension (N-1)\n*          If IUPLO = 1, the (n-1) superdiagonal elements of the unit\n*          bidiagonal factor U from the factorization A = U'*D*U.\n*          If IUPLO = 0, the (n-1) subdiagonal elements of the unit\n*          bidiagonal factor L from the factorization A = L*D*L'.\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the right hand side vectors B for the system of\n*          linear equations.\n*          On exit, the solution vectors, X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CSSCAL\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          CONJG\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  b = NumRu::Lapack.cptts2( iuplo, d, e, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_iuplo = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  iuplo = NUM2INT(rblapack_iuplo);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SCOMPLEX)
    rblapack_e = na_change_type(rblapack_e, NA_SCOMPLEX);
  e = NA_PTR_TYPE(rblapack_e, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  cptts2_(&iuplo, &n, &nrhs, d, e, b, &ldb);

  return rblapack_b;
}

void
init_lapack_cptts2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cptts2", rblapack_cptts2, -1);
}
ruby-lapack-1.7.2/ext/cgetri.c0000644000175000017500000001211212502221025015774 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgetri_(integer* n, complex* a, integer* lda, integer* ipiv, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_cgetri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *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  work, info, a = NumRu::Lapack.cgetri( a, ipiv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGETRI computes the inverse of a matrix using the LU factorization\n*  computed by CGETRF.\n*\n*  This method inverts U and then computes inv(A) by solving the system\n*  inv(A)*L = inv(U) for inv(A).\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the factors L and U from the factorization\n*          A = P*L*U as computed by CGETRF.\n*          On exit, if INFO = 0, the inverse of the original matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices from CGETRF; for 1<=i<=N, row i of the\n*          matrix was interchanged with row IPIV(i).\n*\n*  WORK    (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n*          On exit, if INFO=0, then WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK.  LWORK >= max(1,N).\n*          For optimal performance LWORK >= N*NB, where NB is\n*          the optimal blocksize returned by ILAENV.\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, U(i,i) is exactly zero; the matrix is\n*                singular and its inverse could not be 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 = NumRu::Lapack.cgetri( a, ipiv, [: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_a = argv[0];
  rblapack_ipiv = 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 (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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (2th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  cgetri_(&n, a, &lda, ipiv, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_cgetri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgetri", rblapack_cgetri, -1);
}
ruby-lapack-1.7.2/ext/chegv.c0000644000175000017500000002061612502221020015616 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chegv_(integer* itype, char* jobz, char* uplo, integer* n, complex* a, integer* lda, complex* b, integer* ldb, real* w, complex* work, integer* lwork, real* rwork, integer* info);


static VALUE
rblapack_chegv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;
  real *rwork;

  integer lda;
  integer n;
  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  w, work, info, a, b = NumRu::Lapack.chegv( itype, jobz, uplo, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHEGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHEGV computes all the eigenvalues, and optionally, the eigenvectors\n*  of a complex generalized Hermitian-definite eigenproblem, of the form\n*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.\n*  Here A and B are assumed to be Hermitian and B is also\n*  positive definite.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          Specifies the problem type to be solved:\n*          = 1:  A*x = (lambda)*B*x\n*          = 2:  A*B*x = (lambda)*x\n*          = 3:  B*A*x = (lambda)*x\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA, N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of A contains the\n*          upper triangular part of the matrix A.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of A contains\n*          the lower triangular part of the matrix A.\n*\n*          On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n*          matrix Z of eigenvectors.  The eigenvectors are normalized\n*          as follows:\n*          if ITYPE = 1 or 2, Z**H*B*Z = I;\n*          if ITYPE = 3, Z**H*inv(B)*Z = I.\n*          If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n*          or the lower triangle (if UPLO='L') of A, including the\n*          diagonal, is destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX array, dimension (LDB, N)\n*          On entry, the Hermitian positive definite matrix B.\n*          If UPLO = 'U', the leading N-by-N upper triangular part of B\n*          contains the upper triangular part of the matrix B.\n*          If UPLO = 'L', the leading N-by-N lower triangular part of B\n*          contains the lower triangular part of the matrix B.\n*\n*          On exit, if INFO <= N, the part of B containing the matrix is\n*          overwritten by the triangular factor U or L from the Cholesky\n*          factorization B = U**H*U or B = L*L**H.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  W       (output) REAL array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  WORK    (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of the array WORK.  LWORK >= max(1,2*N-1).\n*          For optimal efficiency, LWORK >= (NB+1)*N,\n*          where NB is the blocksize for CHETRD returned by ILAENV.\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*  RWORK   (workspace) REAL array, dimension (max(1, 3*N-2))\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  CPOTRF or CHEEV returned an error code:\n*             <= N:  if INFO = i, CHEEV failed to converge;\n*                    i off-diagonal elements of an intermediate\n*                    tridiagonal form did not converge to zero;\n*             > N:   if INFO = N + i, for 1 <= i <= N, then the leading\n*                    minor of order i of B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, work, info, a, b = NumRu::Lapack.chegv( itype, jobz, uplo, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_itype = argv[0];
  rblapack_jobz = argv[1];
  rblapack_uplo = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  if (argc == 6) {
    rblapack_lwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  itype = NUM2INT(rblapack_itype);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (rblapack_lwork == Qnil)
    lwork = 2*n-1;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  rwork = ALLOC_N(real, (MAX(1, 3*n-2)));

  chegv_(&itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, work, &lwork, rwork, &info);

  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_w, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_chegv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chegv", rblapack_chegv, -1);
}
ruby-lapack-1.7.2/ext/sgebak.c0000644000175000017500000001177412502221016015770 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgebak_(char* job, char* side, integer* n, integer* ilo, integer* ihi, real* scale, integer* m, real* v, integer* ldv, integer* info);


static VALUE
rblapack_sgebak(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_scale;
  real *scale; 
  VALUE rblapack_v;
  real *v; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_v_out__;
  real *v_out__;

  integer n;
  integer ldv;
  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  info, v = NumRu::Lapack.sgebak( job, side, ilo, ihi, scale, v, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGEBAK forms the right or left eigenvectors of a real general matrix\n*  by backward transformation on the computed eigenvectors of the\n*  balanced matrix output by SGEBAL.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies the type of backward transformation required:\n*          = 'N', do nothing, return immediately;\n*          = 'P', do backward transformation for permutation only;\n*          = 'S', do backward transformation for scaling only;\n*          = 'B', do backward transformations for both permutation and\n*                 scaling.\n*          JOB must be the same as the argument JOB supplied to SGEBAL.\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'R':  V contains right eigenvectors;\n*          = 'L':  V contains left eigenvectors.\n*\n*  N       (input) INTEGER\n*          The number of rows of the matrix V.  N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          The integers ILO and IHI determined by SGEBAL.\n*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n*  SCALE   (input) REAL array, dimension (N)\n*          Details of the permutation and scaling factors, as returned\n*          by SGEBAL.\n*\n*  M       (input) INTEGER\n*          The number of columns of the matrix V.  M >= 0.\n*\n*  V       (input/output) REAL array, dimension (LDV,M)\n*          On entry, the matrix of right or left eigenvectors to be\n*          transformed, as returned by SHSEIN or STREVC.\n*          On exit, V is overwritten by the transformed eigenvectors.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V. LDV >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, v = NumRu::Lapack.sgebak( job, side, ilo, ihi, scale, v, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_job = argv[0];
  rblapack_side = argv[1];
  rblapack_ilo = argv[2];
  rblapack_ihi = argv[3];
  rblapack_scale = argv[4];
  rblapack_v = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  job = StringValueCStr(rblapack_job)[0];
  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_scale))
    rb_raise(rb_eArgError, "scale (5th argument) must be NArray");
  if (NA_RANK(rblapack_scale) != 1)
    rb_raise(rb_eArgError, "rank of scale (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_scale);
  if (NA_TYPE(rblapack_scale) != NA_SFLOAT)
    rblapack_scale = na_change_type(rblapack_scale, NA_SFLOAT);
  scale = NA_PTR_TYPE(rblapack_scale, real*);
  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (6th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (6th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  m = NA_SHAPE1(rblapack_v);
  if (NA_TYPE(rblapack_v) != NA_SFLOAT)
    rblapack_v = na_change_type(rblapack_v, NA_SFLOAT);
  v = NA_PTR_TYPE(rblapack_v, real*);
  ihi = NUM2INT(rblapack_ihi);
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = m;
    rblapack_v_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  v_out__ = NA_PTR_TYPE(rblapack_v_out__, real*);
  MEMCPY(v_out__, v, real, NA_TOTAL(rblapack_v));
  rblapack_v = rblapack_v_out__;
  v = v_out__;

  sgebak_(&job, &side, &n, &ilo, &ihi, scale, &m, v, &ldv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_v);
}

void
init_lapack_sgebak(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgebak", rblapack_sgebak, -1);
}
ruby-lapack-1.7.2/ext/cgeqrf.c0000644000175000017500000001336412502221024015777 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgeqrf_(integer* m, integer* n, complex* a, integer* lda, complex* tau, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_cgeqrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *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.cgeqrf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGEQRF computes a QR factorization of a complex M-by-N matrix A:\n*  A = Q * R.\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) COMPLEX array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, the elements on and above the diagonal of the array\n*          contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n*          upper triangular if m >= n); the elements below the diagonal,\n*          with the array TAU, represent the unitary matrix Q as a\n*          product of min(m,n) elementary reflectors (see Further\n*          Details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  TAU     (output) COMPLEX array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace/output) COMPLEX 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,N).\n*          For optimum performance LWORK >= N*NB, where NB is\n*          the 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(1) H(2) . . . H(k), 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 complex scalar, and v is a complex vector with\n*  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\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           CGEQR2, CLARFB, CLARFT, 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.cgeqrf( 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;
  }

  m = NUM2INT(rblapack_m);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  cgeqrf_(&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_cgeqrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgeqrf", rblapack_cgeqrf, -1);
}
ruby-lapack-1.7.2/ext/sgbrfsx.c0000644000175000017500000005630012502221022016201 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgbrfsx_(char* trans, char* equed, integer* n, integer* kl, integer* ku, integer* nrhs, doublereal* ab, integer* ldab, doublereal* afb, integer* ldafb, integer* ipiv, real* r, real* c, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, real* work, integer* iwork, integer* info);


static VALUE
rblapack_sgbrfsx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_afb;
  doublereal *afb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_r;
  real *r; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_params;
  real *params; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_err_bnds_norm;
  real *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  real *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_r_out__;
  real *r_out__;
  VALUE rblapack_c_out__;
  real *c_out__;
  VALUE rblapack_x_out__;
  real *x_out__;
  VALUE rblapack_params_out__;
  real *params_out__;
  real *work;
  integer *iwork;

  integer ldab;
  integer n;
  integer ldafb;
  integer ldb;
  integer nrhs;
  integer ldx;
  integer nparams;
  integer n_err_bnds;

  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  rcond, berr, err_bnds_norm, err_bnds_comp, info, r, c, x, params = NumRu::Lapack.sgbrfsx( trans, equed, kl, ku, ab, afb, ipiv, r, c, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     SGBRFSX improves the computed solution to a system of linear\n*     equations and provides error bounds and backward error estimates\n*     for the solution.  In addition to normwise error bound, the code\n*     provides maximum componentwise error bound if possible.  See\n*     comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n*     error bounds.\n*\n*     The original system of linear equations may have been equilibrated\n*     before calling this routine, as described by arguments EQUED, R\n*     and C below. In this case, the solution and error bounds returned\n*     are for the original unequilibrated system.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     TRANS   (input) CHARACTER*1\n*     Specifies the form of the system of equations:\n*       = 'N':  A * X = B     (No transpose)\n*       = 'T':  A**T * X = B  (Transpose)\n*       = 'C':  A**H * X = B  (Conjugate transpose = Transpose)\n*\n*     EQUED   (input) CHARACTER*1\n*     Specifies the form of equilibration that was done to A\n*     before calling this routine. This is needed to compute\n*     the solution and error bounds correctly.\n*       = 'N':  No equilibration\n*       = 'R':  Row equilibration, i.e., A has been premultiplied by\n*               diag(R).\n*       = 'C':  Column equilibration, i.e., A has been postmultiplied\n*               by diag(C).\n*       = 'B':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(R) * A * diag(C).\n*               The right hand side B has been changed accordingly.\n*\n*     N       (input) INTEGER\n*     The order of the matrix A.  N >= 0.\n*\n*     KL      (input) INTEGER\n*     The number of subdiagonals within the band of A.  KL >= 0.\n*\n*     KU      (input) INTEGER\n*     The number of superdiagonals within the band of A.  KU >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)\n*     The original band matrix A, stored in rows 1 to KL+KU+1.\n*     The j-th column of A is stored in the j-th column of the\n*     array AB as follows:\n*     AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n*     LDAB    (input) INTEGER\n*     The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*     AFB     (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n*     Details of the LU factorization of the band matrix A, as\n*     computed by DGBTRF.  U is stored as an upper triangular band\n*     matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n*     the multipliers used during the factorization are stored in\n*     rows KL+KU+2 to 2*KL+KU+1.\n*\n*     LDAFB   (input) INTEGER\n*     The leading dimension of the array AFB.  LDAFB >= 2*KL*KU+1.\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     The pivot indices from SGETRF; for 1<=i<=N, row i of the\n*     matrix was interchanged with row IPIV(i).\n*\n*     R       (input or output) REAL array, dimension (N)\n*     The row scale factors for A.  If EQUED = 'R' or 'B', A is\n*     multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n*     is not accessed.  R is an input argument if FACT = 'F';\n*     otherwise, R is an output argument.  If FACT = 'F' and\n*     EQUED = 'R' or 'B', each element of R must be positive.\n*     If R is output, each element of R is a power of the radix.\n*     If R is input, each element of R should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     C       (input or output) REAL array, dimension (N)\n*     The column scale factors for A.  If EQUED = 'C' or 'B', A is\n*     multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n*     is not accessed.  C is an input argument if FACT = 'F';\n*     otherwise, C is an output argument.  If FACT = 'F' and\n*     EQUED = 'C' or 'B', each element of C must be positive.\n*     If C is output, each element of C is a power of the radix.\n*     If C is input, each element of C should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B       (input) REAL array, dimension (LDB,NRHS)\n*     The right hand side matrix B.\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (input/output) REAL array, dimension (LDX,NRHS)\n*     On entry, the solution matrix X, as computed by SGETRS.\n*     On exit, the improved solution matrix X.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) REAL\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     BERR    (output) REAL array, dimension (NRHS)\n*     Componentwise relative backward error.  This is the\n*     componentwise relative backward error of each solution vector X(j)\n*     (i.e., the smallest relative change in any element of A or B that\n*     makes X(j) an exact solution).\n*\n*     N_ERR_BNDS (input) INTEGER\n*     Number of error bounds to return for each right hand side\n*     and each type (normwise or componentwise).  See ERR_BNDS_NORM and\n*     ERR_BNDS_COMP below.\n*\n*     ERR_BNDS_NORM  (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     NPARAMS (input) INTEGER\n*     Specifies the number of parameters set in PARAMS.  If .LE. 0, the\n*     PARAMS array is never referenced and default values are used.\n*\n*     PARAMS  (input / output) REAL array, dimension NPARAMS\n*     Specifies algorithm parameters.  If an entry is .LT. 0.0, then\n*     that entry will be filled with default value used for that\n*     parameter.  Only positions up to NPARAMS are accessed; defaults\n*     are used for higher-numbered parameters.\n*\n*       PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n*            refinement or not.\n*         Default: 1.0\n*            = 0.0 : No refinement is performed, and no error bounds are\n*                    computed.\n*            = 1.0 : Use the double-precision refinement algorithm,\n*                    possibly with doubled-single computations if the\n*                    compilation environment does not support DOUBLE\n*                    PRECISION.\n*              (other values are reserved for future use)\n*\n*       PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n*            computations allowed for refinement.\n*         Default: 10\n*         Aggressive: Set to 100 to permit convergence using approximate\n*                     factorizations or factorizations other than LU. If\n*                     the factorization uses a technique other than\n*                     Gaussian elimination, the guarantees in\n*                     err_bnds_norm and err_bnds_comp may no longer be\n*                     trustworthy.\n*\n*       PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n*            will attempt to find a solution with small componentwise\n*            relative error in the double-precision algorithm.  Positive\n*            is true, 0.0 is false.\n*         Default: 1.0 (attempt componentwise convergence)\n*\n*     WORK    (workspace) REAL array, dimension (4*N)\n*\n*     IWORK   (workspace) INTEGER array, dimension (N)\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit. The solution to every right-hand side is\n*         guaranteed.\n*       < 0:  If INFO = -i, the i-th argument had an illegal value\n*       > 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, berr, err_bnds_norm, err_bnds_comp, info, r, c, x, params = NumRu::Lapack.sgbrfsx( trans, equed, kl, ku, ab, afb, ipiv, r, c, b, x, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_trans = argv[0];
  rblapack_equed = argv[1];
  rblapack_kl = argv[2];
  rblapack_ku = argv[3];
  rblapack_ab = argv[4];
  rblapack_afb = argv[5];
  rblapack_ipiv = argv[6];
  rblapack_r = argv[7];
  rblapack_c = argv[8];
  rblapack_b = argv[9];
  rblapack_x = argv[10];
  rblapack_params = argv[11];
  if (argc == 12) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (9th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (11th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (11th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  n_err_bnds = 3;
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
  ldafb = NA_SHAPE0(rblapack_afb);
  if (NA_SHAPE1(rblapack_afb) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_afb) != NA_DFLOAT)
    rblapack_afb = na_change_type(rblapack_afb, NA_DFLOAT);
  afb = NA_PTR_TYPE(rblapack_afb, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (10th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (10th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (12th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (12th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_SFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
  params = NA_PTR_TYPE(rblapack_params, real*);
  if (!NA_IsNArray(rblapack_r))
    rb_raise(rb_eArgError, "r (8th argument) must be NArray");
  if (NA_RANK(rblapack_r) != 1)
    rb_raise(rb_eArgError, "rank of r (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_r) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_r) != NA_SFLOAT)
    rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
  r = NA_PTR_TYPE(rblapack_r, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_r_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  r_out__ = NA_PTR_TYPE(rblapack_r_out__, real*);
  MEMCPY(r_out__, r, real, NA_TOTAL(rblapack_r));
  rblapack_r = rblapack_r_out__;
  r = r_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
  MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(real, (4*n));
  iwork = ALLOC_N(integer, (n));

  sgbrfsx_(&trans, &equed, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, r, c, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_r, rblapack_c, rblapack_x, rblapack_params);
}

void
init_lapack_sgbrfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgbrfsx", rblapack_sgbrfsx, -1);
}
ruby-lapack-1.7.2/ext/stfsm.c0000644000175000017500000002473412502221014015666 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID stfsm_(char* transr, char* side, char* uplo, char* trans, char* diag, integer* m, integer* n, real* alpha, real* a, real* b, integer* ldb);


static VALUE
rblapack_stfsm(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_alpha;
  real alpha; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_b_out__;
  real *b_out__;

  integer nt;
  integer ldb;
  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  b = NumRu::Lapack.stfsm( transr, side, uplo, trans, diag, m, alpha, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, B, LDB )\n\n*  Purpose\n*  =======\n*\n*  Level 3 BLAS like routine for A in RFP Format.\n*\n*  STFSM  solves the matrix equation\n*\n*     op( A )*X = alpha*B  or  X*op( A ) = alpha*B\n*\n*  where alpha is a scalar, X and B are m by n matrices, A is a unit, or\n*  non-unit,  upper or lower triangular matrix  and  op( A )  is one  of\n*\n*     op( A ) = A   or   op( A ) = A'.\n*\n*  A is in Rectangular Full Packed (RFP) Format.\n*\n*  The matrix X is overwritten on B.\n*\n\n*  Arguments\n*  ==========\n*\n*  TRANSR  (input) CHARACTER*1\n*          = 'N':  The Normal Form of RFP A is stored;\n*          = 'T':  The Transpose Form of RFP A is stored.\n*\n*  SIDE    (input) CHARACTER*1\n*           On entry, SIDE specifies whether op( A ) appears on the left\n*           or right of X as follows:\n*\n*              SIDE = 'L' or 'l'   op( A )*X = alpha*B.\n*\n*              SIDE = 'R' or 'r'   X*op( A ) = alpha*B.\n*\n*           Unchanged on exit.\n*\n*  UPLO    (input) CHARACTER*1\n*           On entry, UPLO specifies whether the RFP matrix A came from\n*           an upper or lower triangular matrix as follows:\n*           UPLO = 'U' or 'u' RFP A came from an upper triangular matrix\n*           UPLO = 'L' or 'l' RFP A came from a  lower triangular matrix\n*\n*           Unchanged on exit.\n*\n*  TRANS   (input) CHARACTER*1\n*           On entry, TRANS  specifies the form of op( A ) to be used\n*           in the matrix multiplication as follows:\n*\n*              TRANS  = 'N' or 'n'   op( A ) = A.\n*\n*              TRANS  = 'T' or 't'   op( A ) = A'.\n*\n*           Unchanged on exit.\n*\n*  DIAG    (input) CHARACTER*1\n*           On entry, DIAG specifies whether or not RFP A is unit\n*           triangular as follows:\n*\n*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.\n*\n*              DIAG = 'N' or 'n'   A is not assumed to be unit\n*                                  triangular.\n*\n*           Unchanged on exit.\n*\n*  M       (input) INTEGER\n*           On entry, M specifies the number of rows of B. M must be at\n*           least zero.\n*           Unchanged on exit.\n*\n*  N       (input) INTEGER\n*           On entry, N specifies the number of columns of B.  N must be\n*           at least zero.\n*           Unchanged on exit.\n*\n*  ALPHA   (input) REAL\n*           On entry,  ALPHA specifies the scalar  alpha. When  alpha is\n*           zero then  A is not referenced and  B need not be set before\n*           entry.\n*           Unchanged on exit.\n*\n*  A       (input) REAL array, dimension (NT)\n*           NT = N*(N+1)/2. On entry, the matrix A in RFP Format.\n*           RFP Format is described by TRANSR, UPLO and N as follows:\n*           If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;\n*           K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If\n*           TRANSR = 'T' then RFP is the transpose of RFP A as\n*           defined when TRANSR = 'N'. The contents of RFP A are defined\n*           by UPLO as follows: If UPLO = 'U' the RFP A contains the NT\n*           elements of upper packed A either in normal or\n*           transpose Format. If UPLO = 'L' the RFP A contains\n*           the NT elements of lower packed A either in normal or\n*           transpose Format. The LDA of RFP A is (N+1)/2 when\n*           TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is\n*           even and is N when is odd.\n*           See the Note below for more details. Unchanged on exit.\n*\n*  B       (input/output) REAL array,  DIMENSION (LDB,N)\n*           Before entry,  the leading  m by n part of the array  B must\n*           contain  the  right-hand  side  matrix  B,  and  on exit  is\n*           overwritten by the solution matrix  X.\n*\n*  LDB     (input) INTEGER\n*           On entry, LDB specifies the first dimension of B as declared\n*           in  the  calling  (sub)  program.   LDB  must  be  at  least\n*           max( 1, m ).\n*           Unchanged on exit.\n*\n\n*  Further Details\n*  ===============\n*\n*  We first consider Rectangular Full Packed (RFP) Format when N is\n*  even. We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  the transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  the transpose of the last three columns of AP lower.\n*  This covers the case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        03 04 05                33 43 53\n*        13 14 15                00 44 54\n*        23 24 25                10 11 55\n*        33 34 35                20 21 22\n*        00 44 45                30 31 32\n*        01 11 55                40 41 42\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We then consider Rectangular Full Packed (RFP) Format when N is\n*  odd. We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  the transpose of the first two columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  the transpose of the last two columns of AP lower.\n*  This covers the case N odd and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        02 03 04                00 33 43\n*        12 13 14                10 11 44\n*        22 23 24                20 21 22\n*        00 33 34                30 31 32\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*           RFP A                   RFP A\n*\n*     02 12 22 00 01             00 10 20 30 40 50\n*     03 13 23 33 11             33 11 21 31 41 51\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  Reference\n*  =========\n*\n*  =====================================================================\n*\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  b = NumRu::Lapack.stfsm( transr, side, uplo, trans, diag, m, alpha, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_transr = argv[0];
  rblapack_side = argv[1];
  rblapack_uplo = argv[2];
  rblapack_trans = argv[3];
  rblapack_diag = argv[4];
  rblapack_m = argv[5];
  rblapack_alpha = argv[6];
  rblapack_a = argv[7];
  rblapack_b = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  alpha = (real)NUM2DBL(rblapack_alpha);
  side = StringValueCStr(rblapack_side)[0];
  m = NUM2INT(rblapack_m);
  ldb = MAX(1,m);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (9th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (9th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_b) != ldb)
    rb_raise(rb_eRuntimeError, "shape 0 of b must be MAX(1,m)");
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (8th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 1)
    rb_raise(rb_eArgError, "rank of a (8th argument) must be %d", 1);
  nt = NA_SHAPE0(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  stfsm_(&transr, &side, &uplo, &trans, &diag, &m, &n, &alpha, a, b, &ldb);

  return rblapack_b;
}

void
init_lapack_stfsm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "stfsm", rblapack_stfsm, -1);
}
ruby-lapack-1.7.2/ext/sspgvd.c0000644000175000017500000002466512502221023016043 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sspgvd_(integer* itype, char* jobz, char* uplo, integer* n, real* ap, real* bp, real* w, real* z, integer* ldz, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_sspgvd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_bp;
  real *bp; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  real *ap_out__;
  VALUE rblapack_bp_out__;
  real *bp_out__;

  integer ldap;
  integer n;
  integer ldz;

  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  w, z, work, iwork, info, ap, bp = NumRu::Lapack.sspgvd( itype, jobz, uplo, ap, bp, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSPGVD computes all the eigenvalues, and optionally, the eigenvectors\n*  of a real generalized symmetric-definite eigenproblem, of the form\n*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A and\n*  B are assumed to be symmetric, stored in packed format, and B is also\n*  positive definite.\n*  If eigenvectors are desired, it uses a divide and conquer algorithm.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          Specifies the problem type to be solved:\n*          = 1:  A*x = (lambda)*B*x\n*          = 2:  A*B*x = (lambda)*x\n*          = 3:  B*A*x = (lambda)*x\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  AP      (input/output) REAL array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, the contents of AP are destroyed.\n*\n*  BP      (input/output) REAL array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          B, packed columnwise in a linear array.  The j-th column of B\n*          is stored in the array BP as follows:\n*          if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n*          if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n*          On exit, the triangular factor U or L from the Cholesky\n*          factorization B = U**T*U or B = L*L**T, in the same storage\n*          format as B.\n*\n*  W       (output) REAL array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) REAL array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n*          eigenvectors.  The eigenvectors are normalized as follows:\n*          if ITYPE = 1 or 2, Z**T*B*Z = I;\n*          if ITYPE = 3, Z**T*inv(B)*Z = I.\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace/output) REAL array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the required LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK.\n*          If N <= 1,               LWORK >= 1.\n*          If JOBZ = 'N' and N > 1, LWORK >= 2*N.\n*          If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the required sizes of the WORK and IWORK\n*          arrays, returns these values as the first entries of the WORK\n*          and IWORK arrays, and no error message related to LWORK or\n*          LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.\n*          If JOBZ  = 'N' or N <= 1, LIWORK >= 1.\n*          If JOBZ  = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the required sizes of the WORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK and IWORK arrays, and no error message related to\n*          LWORK or LIWORK 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:  SPPTRF or SSPEVD returned an error code:\n*             <= N:  if INFO = i, SSPEVD failed to converge;\n*                    i off-diagonal elements of an intermediate\n*                    tridiagonal form did not converge to zero;\n*             > N:   if INFO = N + i, for 1 <= i <= N, then the leading\n*                    minor of order i of B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, work, iwork, info, ap, bp = NumRu::Lapack.sspgvd( itype, jobz, uplo, ap, bp, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_itype = argv[0];
  rblapack_jobz = argv[1];
  rblapack_uplo = argv[2];
  rblapack_ap = argv[3];
  rblapack_bp = argv[4];
  if (argc == 7) {
    rblapack_lwork = argv[5];
    rblapack_liwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  itype = NUM2INT(rblapack_itype);
  uplo = StringValueCStr(rblapack_uplo)[0];
  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  if (!NA_IsNArray(rblapack_bp))
    rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
  if (NA_RANK(rblapack_bp) != 1)
    rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_bp) != NA_SFLOAT)
    rblapack_bp = na_change_type(rblapack_bp, NA_SFLOAT);
  bp = NA_PTR_TYPE(rblapack_bp, real*);
  if (rblapack_liwork == Qnil)
    liwork = (lsame_(&jobz,"N")||n<=1) ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  if (rblapack_lwork == Qnil)
    lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 2*n : lsame_(&jobz,"V") ? 1+6*n+2*n*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, real*);
  MEMCPY(ap_out__, ap, real, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_bp_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  bp_out__ = NA_PTR_TYPE(rblapack_bp_out__, real*);
  MEMCPY(bp_out__, bp, real, NA_TOTAL(rblapack_bp));
  rblapack_bp = rblapack_bp_out__;
  bp = bp_out__;

  sspgvd_(&itype, &jobz, &uplo, &n, ap, bp, w, z, &ldz, work, &lwork, iwork, &liwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_w, rblapack_z, rblapack_work, rblapack_iwork, rblapack_info, rblapack_ap, rblapack_bp);
}

void
init_lapack_sspgvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sspgvd", rblapack_sspgvd, -1);
}
ruby-lapack-1.7.2/ext/stptrs.c0000644000175000017500000001230012502221023016053 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID stptrs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, real* ap, real* b, integer* ldb, integer* info);


static VALUE
rblapack_stptrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  real *b_out__;

  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.stptrs( uplo, trans, diag, n, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  STPTRS solves a triangular system of the form\n*\n*     A * X = B  or  A**T * X = B,\n*\n*  where A is a triangular matrix of order N stored in packed format,\n*  and B is an N-by-NRHS matrix.  A check is made to verify that A is\n*  nonsingular.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B  (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AP      (input) REAL array, dimension (N*(N+1)/2)\n*          The upper or lower triangular matrix A, packed columnwise in\n*          a linear array.  The j-th column of A is stored in the array\n*          AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, if INFO = 0, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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 A is zero,\n*                indicating that the matrix is singular and the\n*                solutions X have not been computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.stptrs( uplo, trans, diag, n, ap, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_n = argv[3];
  rblapack_ap = argv[4];
  rblapack_b = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  trans = StringValueCStr(rblapack_trans)[0];
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  stptrs_(&uplo, &trans, &diag, &n, &nrhs, ap, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_stptrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "stptrs", rblapack_stptrs, -1);
}
ruby-lapack-1.7.2/ext/dla_gbamv.c0000644000175000017500000002026212502221015016437 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dla_gbamv_(integer* trans, integer* m, integer* n, integer* kl, integer* ku, doublereal* alpha, doublereal* ab, integer* ldab, doublereal* x, integer* incx, doublereal* beta, doublereal* y, integer* incy);


static VALUE
rblapack_dla_gbamv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  integer trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_alpha;
  doublereal alpha; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_beta;
  doublereal beta; 
  VALUE rblapack_y;
  doublereal *y; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_y_out__;
  doublereal *y_out__;

  integer ldab;
  integer lda;

  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  y = NumRu::Lapack.dla_gbamv( trans, m, n, kl, ku, alpha, ab, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, INCX, BETA, Y, INCY )\n\n*  Purpose\n*  =======\n*\n*  DLA_GBAMV  performs one of the matrix-vector operations\n*\n*          y := alpha*abs(A)*abs(x) + beta*abs(y),\n*     or   y := alpha*abs(A)'*abs(x) + beta*abs(y),\n*\n*  where alpha and beta are scalars, x and y are vectors and A is an\n*  m by n matrix.\n*\n*  This function is primarily used in calculating error bounds.\n*  To protect against underflow during evaluation, components in\n*  the resulting vector are perturbed away from zero by (N+1)\n*  times the underflow threshold.  To prevent unnecessarily large\n*  errors for block-structure embedded in general matrices,\n*  \"symbolically\" zero components are not perturbed.  A zero\n*  entry is considered \"symbolic\" if all multiplications involved\n*  in computing that entry have at least one zero multiplicand.\n*\n\n*  Arguments\n*  ==========\n*\n*  TRANS   (input) INTEGER\n*           On entry, TRANS specifies the operation to be performed as\n*           follows:\n*\n*             BLAS_NO_TRANS      y := alpha*abs(A)*abs(x) + beta*abs(y)\n*             BLAS_TRANS         y := alpha*abs(A')*abs(x) + beta*abs(y)\n*             BLAS_CONJ_TRANS    y := alpha*abs(A')*abs(x) + beta*abs(y)\n*\n*           Unchanged on exit.\n*\n*  M       (input) INTEGER\n*           On entry, M specifies the number of rows of the matrix A.\n*           M must be at least zero.\n*           Unchanged on exit.\n*\n*  N       (input) INTEGER\n*           On entry, N specifies the number of columns of the matrix A.\n*           N must be at least zero.\n*           Unchanged on exit.\n*\n*  KL      (input) INTEGER\n*           The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*           The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  ALPHA  - DOUBLE PRECISION\n*           On entry, ALPHA specifies the scalar alpha.\n*           Unchanged on exit.\n*\n*  A      - DOUBLE PRECISION   array of DIMENSION ( LDA, n )\n*           Before entry, the leading m by n part of the array A must\n*           contain the matrix of coefficients.\n*           Unchanged on exit.\n*\n*  LDA     (input) INTEGER\n*           On entry, LDA specifies the first dimension of A as declared\n*           in the calling (sub) program. LDA must be at least\n*           max( 1, m ).\n*           Unchanged on exit.\n*\n*  X       (input) DOUBLE PRECISION array, dimension\n*           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n*           and at least\n*           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n*           Before entry, the incremented array X must contain the\n*           vector x.\n*           Unchanged on exit.\n*\n*  INCX    (input) INTEGER\n*           On entry, INCX specifies the increment for the elements of\n*           X. INCX must not be zero.\n*           Unchanged on exit.\n*\n*  BETA   - DOUBLE PRECISION\n*           On entry, BETA specifies the scalar beta. When BETA is\n*           supplied as zero then Y need not be set on input.\n*           Unchanged on exit.\n*\n*  Y       (input/output) DOUBLE PRECISION  array, dimension\n*           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n*           and at least\n*           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n*           Before entry with BETA non-zero, the incremented array Y\n*           must contain the vector y. On exit, Y is overwritten by the\n*           updated vector y.\n*\n*  INCY    (input) INTEGER\n*           On entry, INCY specifies the increment for the elements of\n*           Y. INCY must not be zero.\n*           Unchanged on exit.\n*\n*\n*  Level 2 Blas routine.\n*\n\n*  =====================================================================\n\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  y = NumRu::Lapack.dla_gbamv( trans, m, n, kl, ku, alpha, ab, x, incx, beta, y, incy, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_trans = argv[0];
  rblapack_m = argv[1];
  rblapack_n = argv[2];
  rblapack_kl = argv[3];
  rblapack_ku = argv[4];
  rblapack_alpha = argv[5];
  rblapack_ab = argv[6];
  rblapack_x = argv[7];
  rblapack_incx = argv[8];
  rblapack_beta = argv[9];
  rblapack_y = argv[10];
  rblapack_incy = argv[11];
  if (argc == 12) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = NUM2INT(rblapack_trans);
  n = NUM2INT(rblapack_n);
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (7th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 1)
    rb_raise(rb_eArgError, "rank of ab (7th argument) must be %d", 1);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  incx = NUM2INT(rblapack_incx);
  incy = NUM2INT(rblapack_incy);
  m = NUM2INT(rblapack_m);
  alpha = NUM2DBL(rblapack_alpha);
  beta = NUM2DBL(rblapack_beta);
  lda = MAX( 1, m );
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (11th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (11th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy ));
  if (NA_TYPE(rblapack_y) != NA_DFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
  y = NA_PTR_TYPE(rblapack_y, doublereal*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (8th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (trans == ilatrans_("N") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", trans == ilatrans_("N") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx ));
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy );
    rblapack_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
  MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  dla_gbamv_(&trans, &m, &n, &kl, &ku, &alpha, ab, &ldab, x, &incx, &beta, y, &incy);

  return rblapack_y;
}

void
init_lapack_dla_gbamv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dla_gbamv", rblapack_dla_gbamv, -1);
}
ruby-lapack-1.7.2/ext/cgebak.c0000644000175000017500000001203212502221021015730 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgebak_(char* job, char* side, integer* n, integer* ilo, integer* ihi, real* scale, integer* m, complex* v, integer* ldv, integer* info);


static VALUE
rblapack_cgebak(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_scale;
  real *scale; 
  VALUE rblapack_v;
  complex *v; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_v_out__;
  complex *v_out__;

  integer n;
  integer ldv;
  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  info, v = NumRu::Lapack.cgebak( job, side, ilo, ihi, scale, v, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGEBAK forms the right or left eigenvectors of a complex general\n*  matrix by backward transformation on the computed eigenvectors of the\n*  balanced matrix output by CGEBAL.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies the type of backward transformation required:\n*          = 'N', do nothing, return immediately;\n*          = 'P', do backward transformation for permutation only;\n*          = 'S', do backward transformation for scaling only;\n*          = 'B', do backward transformations for both permutation and\n*                 scaling.\n*          JOB must be the same as the argument JOB supplied to CGEBAL.\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'R':  V contains right eigenvectors;\n*          = 'L':  V contains left eigenvectors.\n*\n*  N       (input) INTEGER\n*          The number of rows of the matrix V.  N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          The integers ILO and IHI determined by CGEBAL.\n*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n*  SCALE   (input) REAL array, dimension (N)\n*          Details of the permutation and scaling factors, as returned\n*          by CGEBAL.\n*\n*  M       (input) INTEGER\n*          The number of columns of the matrix V.  M >= 0.\n*\n*  V       (input/output) COMPLEX array, dimension (LDV,M)\n*          On entry, the matrix of right or left eigenvectors to be\n*          transformed, as returned by CHSEIN or CTREVC.\n*          On exit, V is overwritten by the transformed eigenvectors.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V. LDV >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, v = NumRu::Lapack.cgebak( job, side, ilo, ihi, scale, v, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_job = argv[0];
  rblapack_side = argv[1];
  rblapack_ilo = argv[2];
  rblapack_ihi = argv[3];
  rblapack_scale = argv[4];
  rblapack_v = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  job = StringValueCStr(rblapack_job)[0];
  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_scale))
    rb_raise(rb_eArgError, "scale (5th argument) must be NArray");
  if (NA_RANK(rblapack_scale) != 1)
    rb_raise(rb_eArgError, "rank of scale (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_scale);
  if (NA_TYPE(rblapack_scale) != NA_SFLOAT)
    rblapack_scale = na_change_type(rblapack_scale, NA_SFLOAT);
  scale = NA_PTR_TYPE(rblapack_scale, real*);
  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (6th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (6th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  m = NA_SHAPE1(rblapack_v);
  if (NA_TYPE(rblapack_v) != NA_SCOMPLEX)
    rblapack_v = na_change_type(rblapack_v, NA_SCOMPLEX);
  v = NA_PTR_TYPE(rblapack_v, complex*);
  ihi = NUM2INT(rblapack_ihi);
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = m;
    rblapack_v_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  v_out__ = NA_PTR_TYPE(rblapack_v_out__, complex*);
  MEMCPY(v_out__, v, complex, NA_TOTAL(rblapack_v));
  rblapack_v = rblapack_v_out__;
  v = v_out__;

  cgebak_(&job, &side, &n, &ilo, &ihi, scale, &m, v, &ldv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_v);
}

void
init_lapack_cgebak(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgebak", rblapack_cgebak, -1);
}
ruby-lapack-1.7.2/ext/slarra.c0000644000175000017500000001462712502221020016013 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slarra_(integer* n, real* d, real* e, real* e2, real* spltol, real* tnrm, integer* nsplit, integer* isplit, integer* info);


static VALUE
rblapack_slarra(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_e2;
  real *e2; 
  VALUE rblapack_spltol;
  real spltol; 
  VALUE rblapack_tnrm;
  real tnrm; 
  VALUE rblapack_nsplit;
  integer nsplit; 
  VALUE rblapack_isplit;
  integer *isplit; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_e_out__;
  real *e_out__;
  VALUE rblapack_e2_out__;
  real *e2_out__;

  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  nsplit, isplit, info, e, e2 = NumRu::Lapack.slarra( d, e, e2, spltol, tnrm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLARRA( N, D, E, E2, SPLTOL, TNRM, NSPLIT, ISPLIT, INFO )\n\n*  Purpose\n*  =======\n*\n*  Compute the splitting points with threshold SPLTOL.\n*  SLARRA sets any \"small\" off-diagonal elements to zero.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix. N > 0.\n*\n*  D       (input) REAL             array, dimension (N)\n*          On entry, the N diagonal elements of the tridiagonal\n*          matrix T.\n*\n*  E       (input/output) REAL             array, dimension (N)\n*          On entry, the first (N-1) entries contain the subdiagonal\n*          elements of the tridiagonal matrix T; E(N) need not be set.\n*          On exit, the entries E( ISPLIT( I ) ), 1 <= I <= NSPLIT,\n*          are set to zero, the other entries of E are untouched.\n*\n*  E2      (input/output) REAL             array, dimension (N)\n*          On entry, the first (N-1) entries contain the SQUARES of the\n*          subdiagonal elements of the tridiagonal matrix T;\n*          E2(N) need not be set.\n*          On exit, the entries E2( ISPLIT( I ) ),\n*          1 <= I <= NSPLIT, have been set to zero\n*\n*  SPLTOL (input) REAL            \n*          The threshold for splitting. Two criteria can be used:\n*          SPLTOL<0 : criterion based on absolute off-diagonal value\n*          SPLTOL>0 : criterion that preserves relative accuracy\n*\n*  TNRM (input) REAL            \n*          The norm of the matrix.\n*\n*  NSPLIT  (output) INTEGER\n*          The number of blocks T splits into. 1 <= NSPLIT <= N.\n*\n*  ISPLIT  (output) INTEGER array, dimension (N)\n*          The splitting points, at which T breaks up into blocks.\n*          The first block consists of rows/columns 1 to ISPLIT(1),\n*          the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n*          etc., and the NSPLIT-th consists of rows/columns\n*          ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n*\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Beresford Parlett, University of California, Berkeley, USA\n*     Jim Demmel, University of California, Berkeley, USA\n*     Inderjit Dhillon, University of Texas, Austin, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  nsplit, isplit, info, e, e2 = NumRu::Lapack.slarra( d, e, e2, spltol, tnrm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_d = argv[0];
  rblapack_e = argv[1];
  rblapack_e2 = argv[2];
  rblapack_spltol = argv[3];
  rblapack_tnrm = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_e2))
    rb_raise(rb_eArgError, "e2 (3th argument) must be NArray");
  if (NA_RANK(rblapack_e2) != 1)
    rb_raise(rb_eArgError, "rank of e2 (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e2) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of e2 must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_e2) != NA_SFLOAT)
    rblapack_e2 = na_change_type(rblapack_e2, NA_SFLOAT);
  e2 = NA_PTR_TYPE(rblapack_e2, real*);
  tnrm = (real)NUM2DBL(rblapack_tnrm);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (2th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  spltol = (real)NUM2DBL(rblapack_spltol);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_isplit = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
  MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_e2_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e2_out__ = NA_PTR_TYPE(rblapack_e2_out__, real*);
  MEMCPY(e2_out__, e2, real, NA_TOTAL(rblapack_e2));
  rblapack_e2 = rblapack_e2_out__;
  e2 = e2_out__;

  slarra_(&n, d, e, e2, &spltol, &tnrm, &nsplit, isplit, &info);

  rblapack_nsplit = INT2NUM(nsplit);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_nsplit, rblapack_isplit, rblapack_info, rblapack_e, rblapack_e2);
}

void
init_lapack_slarra(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slarra", rblapack_slarra, -1);
}
ruby-lapack-1.7.2/ext/sbbcsd.c0000644000175000017500000004025712502221022015767 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sbbcsd_(char* jobu1, char* jobu2, char* jobv1t, char* jobv2t, char* trans, integer* m, integer* p, integer* q, real* theta, real* phi, real* u1, integer* ldu1, real* u2, integer* ldu2, real* v1t, integer* ldv1t, real* v2t, integer* ldv2t, real* b11d, real* b11e, real* b12d, real* b12e, real* b21d, real* b21e, real* b22d, real* b22e, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sbbcsd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobu1;
  char jobu1; 
  VALUE rblapack_jobu2;
  char jobu2; 
  VALUE rblapack_jobv1t;
  char jobv1t; 
  VALUE rblapack_jobv2t;
  char jobv2t; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_theta;
  real *theta; 
  VALUE rblapack_phi;
  real *phi; 
  VALUE rblapack_u1;
  real *u1; 
  VALUE rblapack_u2;
  real *u2; 
  VALUE rblapack_v1t;
  real *v1t; 
  VALUE rblapack_v2t;
  real *v2t; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_b11d;
  real *b11d; 
  VALUE rblapack_b11e;
  real *b11e; 
  VALUE rblapack_b12d;
  real *b12d; 
  VALUE rblapack_b12e;
  real *b12e; 
  VALUE rblapack_b21d;
  real *b21d; 
  VALUE rblapack_b21e;
  real *b21e; 
  VALUE rblapack_b22d;
  real *b22d; 
  VALUE rblapack_b22e;
  real *b22e; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_theta_out__;
  real *theta_out__;
  VALUE rblapack_u1_out__;
  real *u1_out__;
  VALUE rblapack_u2_out__;
  real *u2_out__;
  VALUE rblapack_v1t_out__;
  real *v1t_out__;
  VALUE rblapack_v2t_out__;
  real *v2t_out__;
  real *work;

  integer q;
  integer ldu1;
  integer p;
  integer ldu2;
  integer ldv1t;
  integer ldv2t;

  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  b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, info, theta, u1, u2, v1t, v2t = NumRu::Lapack.sbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, theta, phi, u1, u2, v1t, v2t, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, THETA, PHI, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, B22D, B22E, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SBBCSD computes the CS decomposition of an orthogonal matrix in\n*  bidiagonal-block form,\n*\n*\n*      [ B11 | B12 0  0 ]\n*      [  0  |  0 -I  0 ]\n*  X = [----------------]\n*      [ B21 | B22 0  0 ]\n*      [  0  |  0  0  I ]\n*\n*                                [  C | -S  0  0 ]\n*                    [ U1 |    ] [  0 |  0 -I  0 ] [ V1 |    ]**T\n*                  = [---------] [---------------] [---------]   .\n*                    [    | U2 ] [  S |  C  0  0 ] [    | V2 ]\n*                                [  0 |  0  0  I ]\n*\n*  X is M-by-M, its top-left block is P-by-Q, and Q must be no larger\n*  than P, M-P, or M-Q. (If Q is not the smallest index, then X must be\n*  transposed and/or permuted. This can be done in constant time using\n*  the TRANS and SIGNS options. See SORCSD for details.)\n*\n*  The bidiagonal matrices B11, B12, B21, and B22 are represented\n*  implicitly by angles THETA(1:Q) and PHI(1:Q-1).\n*\n*  The orthogonal matrices U1, U2, V1T, and V2T are input/output.\n*  The input matrices are pre- or post-multiplied by the appropriate\n*  singular vector matrices.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBU1   (input) CHARACTER\n*          = 'Y':      U1 is updated;\n*          otherwise:  U1 is not updated.\n*\n*  JOBU2   (input) CHARACTER\n*          = 'Y':      U2 is updated;\n*          otherwise:  U2 is not updated.\n*\n*  JOBV1T  (input) CHARACTER\n*          = 'Y':      V1T is updated;\n*          otherwise:  V1T is not updated.\n*\n*  JOBV2T  (input) CHARACTER\n*          = 'Y':      V2T is updated;\n*          otherwise:  V2T is not updated.\n*\n*  TRANS   (input) CHARACTER\n*          = 'T':      X, U1, U2, V1T, and V2T are stored in row-major\n*                      order;\n*          otherwise:  X, U1, U2, V1T, and V2T are stored in column-\n*                      major order.\n*\n*  M       (input) INTEGER\n*          The number of rows and columns in X, the orthogonal matrix in\n*          bidiagonal-block form.\n*\n*  P       (input) INTEGER\n*          The number of rows in the top-left block of X. 0 <= P <= M.\n*\n*  Q       (input) INTEGER\n*          The number of columns in the top-left block of X.\n*          0 <= Q <= MIN(P,M-P,M-Q).\n*\n*  THETA   (input/output) REAL array, dimension (Q)\n*          On entry, the angles THETA(1),...,THETA(Q) that, along with\n*          PHI(1), ...,PHI(Q-1), define the matrix in bidiagonal-block\n*          form. On exit, the angles whose cosines and sines define the\n*          diagonal blocks in the CS decomposition.\n*\n*  PHI     (input/workspace) REAL array, dimension (Q-1)\n*          The angles PHI(1),...,PHI(Q-1) that, along with THETA(1),...,\n*          THETA(Q), define the matrix in bidiagonal-block form.\n*\n*  U1      (input/output) REAL array, dimension (LDU1,P)\n*          On entry, an LDU1-by-P matrix. On exit, U1 is postmultiplied\n*          by the left singular vector matrix common to [ B11 ; 0 ] and\n*          [ B12 0 0 ; 0 -I 0 0 ].\n*\n*  LDU1    (input) INTEGER\n*          The leading dimension of the array U1.\n*\n*  U2      (input/output) REAL array, dimension (LDU2,M-P)\n*          On entry, an LDU2-by-(M-P) matrix. On exit, U2 is\n*          postmultiplied by the left singular vector matrix common to\n*          [ B21 ; 0 ] and [ B22 0 0 ; 0 0 I ].\n*\n*  LDU2    (input) INTEGER\n*          The leading dimension of the array U2.\n*\n*  V1T     (input/output) REAL array, dimension (LDV1T,Q)\n*          On entry, a LDV1T-by-Q matrix. On exit, V1T is premultiplied\n*          by the transpose of the right singular vector\n*          matrix common to [ B11 ; 0 ] and [ B21 ; 0 ].\n*\n*  LDV1T   (input) INTEGER\n*          The leading dimension of the array V1T.\n*\n*  V2T     (input/output) REAL array, dimenison (LDV2T,M-Q)\n*          On entry, a LDV2T-by-(M-Q) matrix. On exit, V2T is\n*          premultiplied by the transpose of the right\n*          singular vector matrix common to [ B12 0 0 ; 0 -I 0 ] and\n*          [ B22 0 0 ; 0 0 I ].\n*\n*  LDV2T   (input) INTEGER\n*          The leading dimension of the array V2T.\n*\n*  B11D    (output) REAL array, dimension (Q)\n*          When SBBCSD converges, B11D contains the cosines of THETA(1),\n*          ..., THETA(Q). If SBBCSD fails to converge, then B11D\n*          contains the diagonal of the partially reduced top-left\n*          block.\n*\n*  B11E    (output) REAL array, dimension (Q-1)\n*          When SBBCSD converges, B11E contains zeros. If SBBCSD fails\n*          to converge, then B11E contains the superdiagonal of the\n*          partially reduced top-left block.\n*\n*  B12D    (output) REAL array, dimension (Q)\n*          When SBBCSD converges, B12D contains the negative sines of\n*          THETA(1), ..., THETA(Q). If SBBCSD fails to converge, then\n*          B12D contains the diagonal of the partially reduced top-right\n*          block.\n*\n*  B12E    (output) REAL array, dimension (Q-1)\n*          When SBBCSD converges, B12E contains zeros. If SBBCSD fails\n*          to converge, then B12E contains the subdiagonal of the\n*          partially reduced top-right block.\n*\n*  WORK    (workspace) REAL 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,8*Q).\n*\n*          If LWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal size of the WORK array,\n*          returns this value as the first entry of the work array, and\n*          no error 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 SBBCSD did not converge, INFO specifies the number\n*                of nonzero entries in PHI, and B11D, B11E, etc.,\n*                contain the partially reduced matrix.\n*\n*  Reference\n*  =========\n*\n*  [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.\n*      Algorithms, 50(1):33-65, 2009.\n*\n*  Internal Parameters\n*  ===================\n*\n*  TOLMUL  REAL, default = MAX(10,MIN(100,EPS**(-1/8)))\n*          TOLMUL controls the convergence criterion of the QR loop.\n*          Angles THETA(i), PHI(i) are rounded to 0 or PI/2 when they\n*          are within TOLMUL*EPS of either bound.\n*\n\n*  ===================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, info, theta, u1, u2, v1t, v2t = NumRu::Lapack.sbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, theta, phi, u1, u2, v1t, v2t, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 13)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_jobu1 = argv[0];
  rblapack_jobu2 = argv[1];
  rblapack_jobv1t = argv[2];
  rblapack_jobv2t = argv[3];
  rblapack_trans = argv[4];
  rblapack_m = argv[5];
  rblapack_theta = argv[6];
  rblapack_phi = argv[7];
  rblapack_u1 = argv[8];
  rblapack_u2 = argv[9];
  rblapack_v1t = argv[10];
  rblapack_v2t = argv[11];
  if (argc == 13) {
    rblapack_lwork = argv[12];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  jobu1 = StringValueCStr(rblapack_jobu1)[0];
  jobv1t = StringValueCStr(rblapack_jobv1t)[0];
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_theta))
    rb_raise(rb_eArgError, "theta (7th argument) must be NArray");
  if (NA_RANK(rblapack_theta) != 1)
    rb_raise(rb_eArgError, "rank of theta (7th argument) must be %d", 1);
  q = NA_SHAPE0(rblapack_theta);
  if (NA_TYPE(rblapack_theta) != NA_SFLOAT)
    rblapack_theta = na_change_type(rblapack_theta, NA_SFLOAT);
  theta = NA_PTR_TYPE(rblapack_theta, real*);
  if (!NA_IsNArray(rblapack_u1))
    rb_raise(rb_eArgError, "u1 (9th argument) must be NArray");
  if (NA_RANK(rblapack_u1) != 2)
    rb_raise(rb_eArgError, "rank of u1 (9th argument) must be %d", 2);
  ldu1 = NA_SHAPE0(rblapack_u1);
  p = NA_SHAPE1(rblapack_u1);
  if (NA_TYPE(rblapack_u1) != NA_SFLOAT)
    rblapack_u1 = na_change_type(rblapack_u1, NA_SFLOAT);
  u1 = NA_PTR_TYPE(rblapack_u1, real*);
  if (!NA_IsNArray(rblapack_v1t))
    rb_raise(rb_eArgError, "v1t (11th argument) must be NArray");
  if (NA_RANK(rblapack_v1t) != 2)
    rb_raise(rb_eArgError, "rank of v1t (11th argument) must be %d", 2);
  ldv1t = NA_SHAPE0(rblapack_v1t);
  if (NA_SHAPE1(rblapack_v1t) != q)
    rb_raise(rb_eRuntimeError, "shape 1 of v1t must be the same as shape 0 of theta");
  if (NA_TYPE(rblapack_v1t) != NA_SFLOAT)
    rblapack_v1t = na_change_type(rblapack_v1t, NA_SFLOAT);
  v1t = NA_PTR_TYPE(rblapack_v1t, real*);
  if (rblapack_lwork == Qnil)
    lwork = 8*q;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  jobu2 = StringValueCStr(rblapack_jobu2)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_u2))
    rb_raise(rb_eArgError, "u2 (10th argument) must be NArray");
  if (NA_RANK(rblapack_u2) != 2)
    rb_raise(rb_eArgError, "rank of u2 (10th argument) must be %d", 2);
  ldu2 = NA_SHAPE0(rblapack_u2);
  if (NA_SHAPE1(rblapack_u2) != (m-p))
    rb_raise(rb_eRuntimeError, "shape 1 of u2 must be %d", m-p);
  if (NA_TYPE(rblapack_u2) != NA_SFLOAT)
    rblapack_u2 = na_change_type(rblapack_u2, NA_SFLOAT);
  u2 = NA_PTR_TYPE(rblapack_u2, real*);
  jobv2t = StringValueCStr(rblapack_jobv2t)[0];
  if (!NA_IsNArray(rblapack_v2t))
    rb_raise(rb_eArgError, "v2t (12th argument) must be NArray");
  if (NA_RANK(rblapack_v2t) != 2)
    rb_raise(rb_eArgError, "rank of v2t (12th argument) must be %d", 2);
  ldv2t = NA_SHAPE0(rblapack_v2t);
  if (NA_SHAPE1(rblapack_v2t) != (m-q))
    rb_raise(rb_eRuntimeError, "shape 1 of v2t must be %d", m-q);
  if (NA_TYPE(rblapack_v2t) != NA_SFLOAT)
    rblapack_v2t = na_change_type(rblapack_v2t, NA_SFLOAT);
  v2t = NA_PTR_TYPE(rblapack_v2t, real*);
  if (!NA_IsNArray(rblapack_phi))
    rb_raise(rb_eArgError, "phi (8th argument) must be NArray");
  if (NA_RANK(rblapack_phi) != 1)
    rb_raise(rb_eArgError, "rank of phi (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_phi) != (q-1))
    rb_raise(rb_eRuntimeError, "shape 0 of phi must be %d", q-1);
  if (NA_TYPE(rblapack_phi) != NA_SFLOAT)
    rblapack_phi = na_change_type(rblapack_phi, NA_SFLOAT);
  phi = NA_PTR_TYPE(rblapack_phi, real*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_b11d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  b11d = NA_PTR_TYPE(rblapack_b11d, real*);
  {
    na_shape_t shape[1];
    shape[0] = q-1;
    rblapack_b11e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  b11e = NA_PTR_TYPE(rblapack_b11e, real*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_b12d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  b12d = NA_PTR_TYPE(rblapack_b12d, real*);
  {
    na_shape_t shape[1];
    shape[0] = q-1;
    rblapack_b12e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  b12e = NA_PTR_TYPE(rblapack_b12e, real*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_b21d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  b21d = NA_PTR_TYPE(rblapack_b21d, real*);
  {
    na_shape_t shape[1];
    shape[0] = q-1;
    rblapack_b21e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  b21e = NA_PTR_TYPE(rblapack_b21e, real*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_b22d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  b22d = NA_PTR_TYPE(rblapack_b22d, real*);
  {
    na_shape_t shape[1];
    shape[0] = q-1;
    rblapack_b22e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  b22e = NA_PTR_TYPE(rblapack_b22e, real*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_theta_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  theta_out__ = NA_PTR_TYPE(rblapack_theta_out__, real*);
  MEMCPY(theta_out__, theta, real, NA_TOTAL(rblapack_theta));
  rblapack_theta = rblapack_theta_out__;
  theta = theta_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldu1;
    shape[1] = p;
    rblapack_u1_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  u1_out__ = NA_PTR_TYPE(rblapack_u1_out__, real*);
  MEMCPY(u1_out__, u1, real, NA_TOTAL(rblapack_u1));
  rblapack_u1 = rblapack_u1_out__;
  u1 = u1_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldu2;
    shape[1] = m-p;
    rblapack_u2_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  u2_out__ = NA_PTR_TYPE(rblapack_u2_out__, real*);
  MEMCPY(u2_out__, u2, real, NA_TOTAL(rblapack_u2));
  rblapack_u2 = rblapack_u2_out__;
  u2 = u2_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldv1t;
    shape[1] = q;
    rblapack_v1t_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  v1t_out__ = NA_PTR_TYPE(rblapack_v1t_out__, real*);
  MEMCPY(v1t_out__, v1t, real, NA_TOTAL(rblapack_v1t));
  rblapack_v1t = rblapack_v1t_out__;
  v1t = v1t_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldv2t;
    shape[1] = m-q;
    rblapack_v2t_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  v2t_out__ = NA_PTR_TYPE(rblapack_v2t_out__, real*);
  MEMCPY(v2t_out__, v2t, real, NA_TOTAL(rblapack_v2t));
  rblapack_v2t = rblapack_v2t_out__;
  v2t = v2t_out__;
  work = ALLOC_N(real, (MAX(1,lwork)));

  sbbcsd_(&jobu1, &jobu2, &jobv1t, &jobv2t, &trans, &m, &p, &q, theta, phi, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, v2t, &ldv2t, b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, work, &lwork, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(14, rblapack_b11d, rblapack_b11e, rblapack_b12d, rblapack_b12e, rblapack_b21d, rblapack_b21e, rblapack_b22d, rblapack_b22e, rblapack_info, rblapack_theta, rblapack_u1, rblapack_u2, rblapack_v1t, rblapack_v2t);
}

void
init_lapack_sbbcsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sbbcsd", rblapack_sbbcsd, -1);
}
ruby-lapack-1.7.2/ext/csysvxx.c0000644000175000017500000006511212502221022016253 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID csysvxx_(char* fact, char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, char* equed, real* s, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* rpvgrw, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, complex* work, real* rwork, integer* info);


static VALUE
rblapack_csysvxx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_params;
  real *params; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_rpvgrw;
  real rpvgrw; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_err_bnds_norm;
  real *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  real *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_af_out__;
  complex *af_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  VALUE rblapack_s_out__;
  real *s_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;
  VALUE rblapack_params_out__;
  real *params_out__;
  complex *work;
  real *rwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer nparams;
  integer ldx;
  integer n_err_bnds;

  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  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.csysvxx( fact, uplo, a, af, ipiv, equed, s, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     CSYSVXX uses the diagonal pivoting factorization to compute the\n*     solution to a complex system of linear equations A * X = B, where\n*     A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n*     matrices.\n*\n*     If requested, both normwise and maximum componentwise error bounds\n*     are returned. CSYSVXX will return a solution with a tiny\n*     guaranteed error (O(eps) where eps is the working machine\n*     precision) unless the matrix is very ill-conditioned, in which\n*     case a warning is returned. Relevant condition numbers also are\n*     calculated and returned.\n*\n*     CSYSVXX accepts user-provided factorizations and equilibration\n*     factors; see the definitions of the FACT and EQUED options.\n*     Solving with refinement and using a factorization from a previous\n*     CSYSVXX call will also produce a solution with either O(eps)\n*     errors or warnings, but we cannot make that claim for general\n*     user-provided factorizations and equilibration factors if they\n*     differ from what CSYSVXX would itself produce.\n*\n*     Description\n*     ===========\n*\n*     The following steps are performed:\n*\n*     1. If FACT = 'E', real scaling factors are computed to equilibrate\n*     the system:\n*\n*       diag(S)*A*diag(S)     *inv(diag(S))*X = diag(S)*B\n*\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n*     2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n*     the matrix A (after equilibration if FACT = 'E') as\n*\n*        A = U * D * U**T,  if UPLO = 'U', or\n*        A = L * D * L**T,  if UPLO = 'L',\n*\n*     where U (or L) is a product of permutation and unit upper (lower)\n*     triangular matrices, and D is symmetric and block diagonal with\n*     1-by-1 and 2-by-2 diagonal blocks.\n*\n*     3. If some D(i,i)=0, so that D is exactly singular, then the\n*     routine returns with INFO = i. Otherwise, the factored form of A\n*     is used to estimate the condition number of the matrix A (see\n*     argument RCOND).  If the reciprocal of the condition number is\n*     less than machine precision, the routine still goes on to solve\n*     for X and compute error bounds as described below.\n*\n*     4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*     5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n*     the routine will use iterative refinement to try to get a small\n*     error and error bounds.  Refinement calculates the residual to at\n*     least twice the working precision.\n*\n*     6. If equilibration was used, the matrix X is premultiplied by\n*     diag(R) so that it solves the original system before\n*     equilibration.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     FACT    (input) CHARACTER*1\n*     Specifies whether or not the factored form of the matrix A is\n*     supplied on entry, and if not, whether the matrix A should be\n*     equilibrated before it is factored.\n*       = 'F':  On entry, AF and IPIV contain the factored form of A.\n*               If EQUED is not 'N', the matrix A has been\n*               equilibrated with scaling factors given by S.\n*               A, AF, and IPIV are not modified.\n*       = 'N':  The matrix A will be copied to AF and factored.\n*       = 'E':  The matrix A will be equilibrated if necessary, then\n*               copied to AF and factored.\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     A       (input/output) COMPLEX array, dimension (LDA,N)\n*     The symmetric matrix A.  If UPLO = 'U', the leading N-by-N\n*     upper triangular part of A contains the upper triangular\n*     part of the matrix A, and the strictly lower triangular\n*     part of A is not referenced.  If UPLO = 'L', the leading\n*     N-by-N lower triangular part of A contains the lower\n*     triangular part of the matrix A, and the strictly upper\n*     triangular part of A is not referenced.\n*\n*     On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n*     diag(S)*A*diag(S).\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input or output) COMPLEX array, dimension (LDAF,N)\n*     If FACT = 'F', then AF is an input argument and on entry\n*     contains the block diagonal matrix D and the multipliers\n*     used to obtain the factor U or L from the factorization A =\n*     U*D*U**T or A = L*D*L**T as computed by SSYTRF.\n*\n*     If FACT = 'N', then AF is an output argument and on exit\n*     returns the block diagonal matrix D and the multipliers\n*     used to obtain the factor U or L from the factorization A =\n*     U*D*U**T or A = L*D*L**T.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input or output) INTEGER array, dimension (N)\n*     If FACT = 'F', then IPIV is an input argument and on entry\n*     contains details of the interchanges and the block\n*     structure of D, as determined by SSYTRF.  If IPIV(k) > 0,\n*     then rows and columns k and IPIV(k) were interchanged and\n*     D(k,k) is a 1-by-1 diagonal block.  If UPLO = 'U' and\n*     IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and\n*     -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2\n*     diagonal block.  If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0,\n*     then rows and columns k+1 and -IPIV(k) were interchanged\n*     and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*     If FACT = 'N', then IPIV is an output argument and on exit\n*     contains details of the interchanges and the block\n*     structure of D, as determined by SSYTRF.\n*\n*     EQUED   (input or output) CHARACTER*1\n*     Specifies the form of equilibration that was done.\n*       = 'N':  No equilibration (always true if FACT = 'N').\n*       = 'Y':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(S) * A * diag(S).\n*     EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*     output argument.\n*\n*     S       (input or output) REAL array, dimension (N)\n*     The scale factors for A.  If EQUED = 'Y', A is multiplied on\n*     the left and right by diag(S).  S is an input argument if FACT =\n*     'F'; otherwise, S is an output argument.  If FACT = 'F' and EQUED\n*     = 'Y', each element of S must be positive.  If S is output, each\n*     element of S is a power of the radix. If S is input, each element\n*     of S should be a power of the radix to ensure a reliable solution\n*     and error estimates. Scaling by powers of the radix does not cause\n*     rounding errors unless the result underflows or overflows.\n*     Rounding errors during scaling lead to refining with a matrix that\n*     is not equivalent to the input matrix, producing error estimates\n*     that may not be reliable.\n*\n*     B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*     On entry, the N-by-NRHS right hand side matrix B.\n*     On exit,\n*     if EQUED = 'N', B is not modified;\n*     if EQUED = 'Y', B is overwritten by diag(S)*B;\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (output) COMPLEX array, dimension (LDX,NRHS)\n*     If INFO = 0, the N-by-NRHS solution matrix X to the original\n*     system of equations.  Note that A and B are modified on exit if\n*     EQUED .ne. 'N', and the solution to the equilibrated system is\n*     inv(diag(S))*X.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) REAL\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     RPVGRW  (output) REAL\n*     Reciprocal pivot growth.  On exit, this contains the reciprocal\n*     pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n*     norm is used.  If this is much less than 1, then the stability of\n*     the LU factorization of the (equilibrated) matrix A could be poor.\n*     This also means that the solution X, estimated condition numbers,\n*     and error bounds could be unreliable. If factorization fails with\n*     0 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.csysvxx( fact, uplo, a, af, ipiv, equed, s, b, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_equed = argv[5];
  rblapack_s = argv[6];
  rblapack_b = argv[7];
  rblapack_params = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (7th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (9th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_SFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
  params = NA_PTR_TYPE(rblapack_params, real*);
  n_err_bnds = 3;
  uplo = StringValueCStr(rblapack_uplo)[0];
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  ldx = MAX(1,n);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldaf;
    shape[1] = n;
    rblapack_af_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  af_out__ = NA_PTR_TYPE(rblapack_af_out__, complex*);
  MEMCPY(af_out__, af, complex, NA_TOTAL(rblapack_af));
  rblapack_af = rblapack_af_out__;
  af = af_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
  MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
  MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (2*n));

  csysvxx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, s, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_rpvgrw = rb_float_new((double)rpvgrw);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(14, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_a, rblapack_af, rblapack_ipiv, rblapack_equed, rblapack_s, rblapack_b, rblapack_params);
}

void
init_lapack_csysvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "csysvxx", rblapack_csysvxx, -1);
}
ruby-lapack-1.7.2/ext/csptrs.c0000644000175000017500000001163212502221022016040 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID csptrs_(char* uplo, integer* n, integer* nrhs, complex* ap, integer* ipiv, complex* b, integer* ldb, integer* info);


static VALUE
rblapack_csptrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.csptrs( uplo, ap, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  CSPTRS solves a system of linear equations A*X = B with a complex\n*  symmetric matrix A stored in packed format using the factorization\n*  A = U*D*U**T or A = L*D*L**T computed by CSPTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by CSPTRF, stored as a\n*          packed triangular matrix.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by CSPTRF.\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.csptrs( uplo, ap, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  csptrs_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_csptrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "csptrs", rblapack_csptrs, -1);
}
ruby-lapack-1.7.2/ext/clarcm.c0000644000175000017500000000735312502221016015773 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clarcm_(integer* m, integer* n, real* a, integer* lda, complex* b, integer* ldb, complex* c, integer* ldc, real* rwork);


static VALUE
rblapack_clarcm(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_c;
  complex *c; 
  real *rwork;

  integer lda;
  integer m;
  integer ldb;
  integer n;
  integer ldc;

  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  c = NumRu::Lapack.clarcm( a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLARCM( M, N, A, LDA, B, LDB, C, LDC, RWORK )\n\n*  Purpose\n*  =======\n*\n*  CLARCM performs a very simple matrix-matrix multiplication:\n*           C := A * B,\n*  where A is M by M and real; B is M by N and complex;\n*  C is M by N and complex.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A and of the matrix C.\n*          M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns and rows of the matrix B and\n*          the number of columns of the matrix C.\n*          N >= 0.\n*\n*  A       (input) REAL array, dimension (LDA, M)\n*          A contains the M by M matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >=max(1,M).\n*\n*  B       (input) REAL array, dimension (LDB, N)\n*          B contains the M by N matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >=max(1,M).\n*\n*  C       (input) COMPLEX array, dimension (LDC, N)\n*          C contains the M by N matrix C.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >=max(1,M).\n*\n*  RWORK   (workspace) REAL array, dimension (2*M*N)\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.clarcm( a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  if (argc == 2) {
  } 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);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  ldc = MAX(1,m);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  c = NA_PTR_TYPE(rblapack_c, complex*);
  rwork = ALLOC_N(real, (2*m*n));

  clarcm_(&m, &n, a, &lda, b, &ldb, c, &ldc, rwork);

  free(rwork);
  return rblapack_c;
}

void
init_lapack_clarcm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clarcm", rblapack_clarcm, -1);
}
ruby-lapack-1.7.2/ext/slaed1.c0000644000175000017500000002017512655767574015741 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaed1_(integer* n, real* d, real* q, integer* ldq, integer* indxq, real* rho, integer* cutpnt, real* work, integer* iwork, integer* info);


static VALUE
rblapack_slaed1(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_q;
  real *q; 
  VALUE rblapack_indxq;
  integer *indxq; 
  VALUE rblapack_rho;
  real rho; 
  VALUE rblapack_cutpnt;
  integer cutpnt; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_q_out__;
  real *q_out__;
  VALUE rblapack_indxq_out__;
  integer *indxq_out__;
  real *work;
  integer *iwork;

  integer n;
  integer ldq;

  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  info, d, q, indxq = NumRu::Lapack.slaed1( d, q, indxq, rho, cutpnt, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLAED1 computes the updated eigensystem of a diagonal\n*  matrix after modification by a rank-one symmetric matrix.  This\n*  routine is used only for the eigenproblem which requires all\n*  eigenvalues and eigenvectors of a tridiagonal matrix.  SLAED7 handles\n*  the case in which eigenvalues only or eigenvalues and eigenvectors\n*  of a full symmetric matrix (which was reduced to tridiagonal form)\n*  are desired.\n*\n*    T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)\n*\n*     where Z = Q'u, u is a vector of length N with ones in the\n*     CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.\n*\n*     The eigenvectors of the original matrix are stored in Q, and the\n*     eigenvalues are in D.  The algorithm consists of three stages:\n*\n*        The first stage consists of deflating the size of the problem\n*        when there are multiple eigenvalues or if there is a zero in\n*        the Z vector.  For each such occurrence the dimension of the\n*        secular equation problem is reduced by one.  This stage is\n*        performed by the routine SLAED2.\n*\n*        The second stage consists of calculating the updated\n*        eigenvalues. This is done by finding the roots of the secular\n*        equation via the routine SLAED4 (as called by SLAED3).\n*        This routine also calculates the eigenvectors of the current\n*        problem.\n*\n*        The final stage consists of computing the updated eigenvectors\n*        directly using the updated eigenvalues.  The eigenvectors for\n*        the current problem are multiplied with the eigenvectors from\n*        the overall problem.\n*\n\n*  Arguments\n*  =========\n*\n*  N      (input) INTEGER\n*         The dimension of the symmetric tridiagonal matrix.  N >= 0.\n*\n*  D      (input/output) REAL array, dimension (N)\n*         On entry, the eigenvalues of the rank-1-perturbed matrix.\n*         On exit, the eigenvalues of the repaired matrix.\n*\n*  Q      (input/output) REAL array, dimension (LDQ,N)\n*         On entry, the eigenvectors of the rank-1-perturbed matrix.\n*         On exit, the eigenvectors of the repaired tridiagonal matrix.\n*\n*  LDQ    (input) INTEGER\n*         The leading dimension of the array Q.  LDQ >= max(1,N).\n*\n*  INDXQ  (input/output) INTEGER array, dimension (N)\n*         On entry, the permutation which separately sorts the two\n*         subproblems in D into ascending order.\n*         On exit, the permutation which will reintegrate the\n*         subproblems back into sorted order,\n*         i.e. D( INDXQ( I = 1, N ) ) will be in ascending order.\n*\n*  RHO    (input) REAL\n*         The subdiagonal entry used to create the rank-1 modification.\n*\n*  CUTPNT (input) INTEGER\n*         The location of the last eigenvalue in the leading sub-matrix.\n*         min(1,N) <= CUTPNT <= N/2.\n*\n*  WORK   (workspace) REAL array, dimension (4*N + N**2)\n*\n*  IWORK  (workspace) INTEGER array, dimension (4*N)\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 = 1, an eigenvalue did not converge\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Jeff Rutter, Computer Science Division, University of California\n*     at Berkeley, USA\n*  Modified by Francoise Tisseur, University of Tennessee.\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            COLTYP, CPP1, I, IDLMDA, INDX, INDXC, INDXP,\n     $                   IQ2, IS, IW, IZ, K, N1, N2\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SCOPY, SLAED2, SLAED3, SLAMRG, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, q, indxq = NumRu::Lapack.slaed1( d, q, indxq, rho, cutpnt, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_d = argv[0];
  rblapack_q = argv[1];
  rblapack_indxq = argv[2];
  rblapack_rho = argv[3];
  rblapack_cutpnt = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_indxq))
    rb_raise(rb_eArgError, "indxq (3th argument) must be NArray");
  if (NA_RANK(rblapack_indxq) != 1)
    rb_raise(rb_eArgError, "rank of indxq (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_indxq) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of indxq must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_indxq) != NA_LINT)
    rblapack_indxq = na_change_type(rblapack_indxq, NA_LINT);
  indxq = NA_PTR_TYPE(rblapack_indxq, integer*);
  cutpnt = NUM2INT(rblapack_cutpnt);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (2th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (2th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_q) != NA_SFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
  q = NA_PTR_TYPE(rblapack_q, real*);
  rho = (real)NUM2DBL(rblapack_rho);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
  MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_indxq_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  indxq_out__ = NA_PTR_TYPE(rblapack_indxq_out__, integer*);
  MEMCPY(indxq_out__, indxq, integer, NA_TOTAL(rblapack_indxq));
  rblapack_indxq = rblapack_indxq_out__;
  indxq = indxq_out__;
  work = ALLOC_N(real, (4*n + pow(n,2)));
  iwork = ALLOC_N(integer, (4*n));

  slaed1_(&n, d, q, &ldq, indxq, &rho, &cutpnt, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_q, rblapack_indxq);
}

void
init_lapack_slaed1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaed1", rblapack_slaed1, -1);
}
ruby-lapack-1.7.2/ext/sorm2r.c0000644000175000017500000001416412502221017015755 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sorm2r_(char* side, char* trans, integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* c, integer* ldc, real* work, integer* info);


static VALUE
rblapack_sorm2r(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  real *c_out__;
  real *work;

  integer lda;
  integer k;
  integer ldc;
  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  info, c = NumRu::Lapack.sorm2r( side, trans, m, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SORM2R overwrites the general real m by n matrix C with\n*\n*        Q * C  if SIDE = 'L' and TRANS = 'N', or\n*\n*        Q'* C  if SIDE = 'L' and TRANS = 'T', or\n*\n*        C * Q  if SIDE = 'R' and TRANS = 'N', or\n*\n*        C * Q' if SIDE = 'R' and TRANS = 'T',\n*\n*  where Q is a real orthogonal matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(1) H(2) . . . H(k)\n*\n*  as returned by SGEQRF. Q is of order m if SIDE = 'L' and of order n\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q' from the Left\n*          = 'R': apply Q or Q' from the Right\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': apply Q  (No transpose)\n*          = 'T': apply Q' (Transpose)\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) REAL array, dimension (LDA,K)\n*          The i-th column must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          SGEQRF in the first k columns of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*          If SIDE = 'L', LDA >= max(1,M);\n*          if SIDE = 'R', LDA >= max(1,N).\n*\n*  TAU     (input) REAL array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by SGEQRF.\n*\n*  C       (input/output) REAL array, dimension (LDC,N)\n*          On entry, the m by n matrix C.\n*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) REAL array, dimension\n*                                   (N) if SIDE = 'L',\n*                                   (M) if SIDE = 'R'\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, c = NumRu::Lapack.sorm2r( side, trans, m, a, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_m = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != k)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  sorm2r_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_c);
}

void
init_lapack_sorm2r(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sorm2r", rblapack_sorm2r, -1);
}
ruby-lapack-1.7.2/ext/slacon.c0000644000175000017500000001014412502221013015776 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slacon_(integer* n, real* v, real* x, integer* isgn, real* est, integer* kase);


static VALUE
rblapack_slacon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_est;
  real est; 
  VALUE rblapack_kase;
  integer kase; 
  VALUE rblapack_x_out__;
  real *x_out__;
  real *v;
  integer *isgn;

  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  x, est, kase = NumRu::Lapack.slacon( x, est, kase, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLACON( N, V, X, ISGN, EST, KASE )\n\n*  Purpose\n*  =======\n*\n*  SLACON estimates the 1-norm of a square, real matrix A.\n*  Reverse communication is used for evaluating matrix-vector products.\n*\n\n*  Arguments\n*  =========\n*\n*  N      (input) INTEGER\n*         The order of the matrix.  N >= 1.\n*\n*  V      (workspace) REAL array, dimension (N)\n*         On the final return, V = A*W,  where  EST = norm(V)/norm(W)\n*         (W is not returned).\n*\n*  X      (input/output) REAL array, dimension (N)\n*         On an intermediate return, X should be overwritten by\n*               A * X,   if KASE=1,\n*               A' * X,  if KASE=2,\n*         and SLACON must be re-called with all the other parameters\n*         unchanged.\n*\n*  ISGN   (workspace) INTEGER array, dimension (N)\n*\n*  EST    (input/output) REAL\n*         On entry with KASE = 1 or 2 and JUMP = 3, EST should be\n*         unchanged from the previous call to SLACON.\n*         On exit, EST is an estimate (a lower bound) for norm(A). \n*\n*  KASE   (input/output) INTEGER\n*         On the initial call to SLACON, KASE should be 0.\n*         On an intermediate return, KASE will be 1 or 2, indicating\n*         whether X should be overwritten by A * X  or A' * X.\n*         On the final return from SLACON, KASE will again be 0.\n*\n\n*  Further Details\n*  ======= =======\n*\n*  Contributed by Nick Higham, University of Manchester.\n*  Originally named SONEST, dated March 16, 1988.\n*\n*  Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n*  a real or complex matrix, with applications to condition estimation\",\n*  ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, est, kase = NumRu::Lapack.slacon( x, est, kase, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_x = argv[0];
  rblapack_est = argv[1];
  rblapack_kase = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (1th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  kase = NUM2INT(rblapack_kase);
  est = (real)NUM2DBL(rblapack_est);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  v = ALLOC_N(real, (n));
  isgn = ALLOC_N(integer, (n));

  slacon_(&n, v, x, isgn, &est, &kase);

  free(v);
  free(isgn);
  rblapack_est = rb_float_new((double)est);
  rblapack_kase = INT2NUM(kase);
  return rb_ary_new3(3, rblapack_x, rblapack_est, rblapack_kase);
}

void
init_lapack_slacon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slacon", rblapack_slacon, -1);
}
ruby-lapack-1.7.2/ext/claein.c0000644000175000017500000001322112502221022015751 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID claein_(logical* rightv, logical* noinit, integer* n, complex* h, integer* ldh, complex* w, complex* v, complex* b, integer* ldb, real* rwork, real* eps3, real* smlnum, integer* info);


static VALUE
rblapack_claein(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_rightv;
  logical rightv; 
  VALUE rblapack_noinit;
  logical noinit; 
  VALUE rblapack_h;
  complex *h; 
  VALUE rblapack_w;
  complex w; 
  VALUE rblapack_v;
  complex *v; 
  VALUE rblapack_eps3;
  real eps3; 
  VALUE rblapack_smlnum;
  real smlnum; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_v_out__;
  complex *v_out__;
  complex *b;
  real *rwork;

  integer ldh;
  integer n;
  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  info, v = NumRu::Lapack.claein( rightv, noinit, h, w, v, eps3, smlnum, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAEIN( RIGHTV, NOINIT, N, H, LDH, W, V, B, LDB, RWORK, EPS3, SMLNUM, INFO )\n\n*  Purpose\n*  =======\n*\n*  CLAEIN uses inverse iteration to find a right or left eigenvector\n*  corresponding to the eigenvalue W of a complex upper Hessenberg\n*  matrix H.\n*\n\n*  Arguments\n*  =========\n*\n*  RIGHTV   (input) LOGICAL\n*          = .TRUE. : compute right eigenvector;\n*          = .FALSE.: compute left eigenvector.\n*\n*  NOINIT   (input) LOGICAL\n*          = .TRUE. : no initial vector supplied in V\n*          = .FALSE.: initial vector supplied in V.\n*\n*  N       (input) INTEGER\n*          The order of the matrix H.  N >= 0.\n*\n*  H       (input) COMPLEX array, dimension (LDH,N)\n*          The upper Hessenberg matrix H.\n*\n*  LDH     (input) INTEGER\n*          The leading dimension of the array H.  LDH >= max(1,N).\n*\n*  W       (input) COMPLEX\n*          The eigenvalue of H whose corresponding right or left\n*          eigenvector is to be computed.\n*\n*  V       (input/output) COMPLEX array, dimension (N)\n*          On entry, if NOINIT = .FALSE., V must contain a starting\n*          vector for inverse iteration; otherwise V need not be set.\n*          On exit, V contains the computed eigenvector, normalized so\n*          that the component of largest magnitude has magnitude 1; here\n*          the magnitude of a complex number (x,y) is taken to be\n*          |x| + |y|.\n*\n*  B       (workspace) COMPLEX array, dimension (LDB,N)\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  RWORK   (workspace) REAL array, dimension (N)\n*\n*  EPS3    (input) REAL\n*          A small machine-dependent value which is used to perturb\n*          close eigenvalues, and to replace zero pivots.\n*\n*  SMLNUM  (input) REAL\n*          A machine-dependent value close to the underflow threshold.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          = 1:  inverse iteration did not converge; V is set to the\n*                last iterate.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, v = NumRu::Lapack.claein( rightv, noinit, h, w, v, eps3, smlnum, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_rightv = argv[0];
  rblapack_noinit = argv[1];
  rblapack_h = argv[2];
  rblapack_w = argv[3];
  rblapack_v = argv[4];
  rblapack_eps3 = argv[5];
  rblapack_smlnum = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  rightv = (rblapack_rightv == Qtrue);
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (3th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (3th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_SCOMPLEX)
    rblapack_h = na_change_type(rblapack_h, NA_SCOMPLEX);
  h = NA_PTR_TYPE(rblapack_h, complex*);
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (5th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 1)
    rb_raise(rb_eArgError, "rank of v (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_v) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of v must be the same as shape 1 of h");
  if (NA_TYPE(rblapack_v) != NA_SCOMPLEX)
    rblapack_v = na_change_type(rblapack_v, NA_SCOMPLEX);
  v = NA_PTR_TYPE(rblapack_v, complex*);
  smlnum = (real)NUM2DBL(rblapack_smlnum);
  noinit = (rblapack_noinit == Qtrue);
  eps3 = (real)NUM2DBL(rblapack_eps3);
  w.r = (real)NUM2DBL(rb_funcall(rblapack_w, rb_intern("real"), 0));
  w.i = (real)NUM2DBL(rb_funcall(rblapack_w, rb_intern("imag"), 0));
  ldb = MAX(1,n);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_v_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  v_out__ = NA_PTR_TYPE(rblapack_v_out__, complex*);
  MEMCPY(v_out__, v, complex, NA_TOTAL(rblapack_v));
  rblapack_v = rblapack_v_out__;
  v = v_out__;
  b = ALLOC_N(complex, (ldb)*(n));
  rwork = ALLOC_N(real, (n));

  claein_(&rightv, &noinit, &n, h, &ldh, &w, v, b, &ldb, rwork, &eps3, &smlnum, &info);

  free(b);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_v);
}

void
init_lapack_claein(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "claein", rblapack_claein, -1);
}
ruby-lapack-1.7.2/ext/sgttrs.c0000644000175000017500000001630712502221025016057 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgttrs_(char* trans, integer* n, integer* nrhs, real* dl, real* d, real* du, real* du2, integer* ipiv, real* b, integer* ldb, integer* info);


static VALUE
rblapack_sgttrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_dl;
  real *dl; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_du;
  real *du; 
  VALUE rblapack_du2;
  real *du2; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  real *b_out__;

  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.sgttrs( trans, dl, d, du, du2, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGTTRS solves one of the systems of equations\n*     A*X = B  or  A'*X = B,\n*  with a tridiagonal matrix A using the LU factorization computed\n*  by SGTTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations.\n*          = 'N':  A * X = B  (No transpose)\n*          = 'T':  A'* X = B  (Transpose)\n*          = 'C':  A'* X = B  (Conjugate transpose = Transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  DL      (input) REAL array, dimension (N-1)\n*          The (n-1) multipliers that define the matrix L from the\n*          LU factorization of A.\n*\n*  D       (input) REAL array, dimension (N)\n*          The n diagonal elements of the upper triangular matrix U from\n*          the LU factorization of A.\n*\n*  DU      (input) REAL array, dimension (N-1)\n*          The (n-1) elements of the first super-diagonal of U.\n*\n*  DU2     (input) REAL array, dimension (N-2)\n*          The (n-2) elements of the second super-diagonal of U.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices; for 1 <= i <= n, row i of the matrix was\n*          interchanged with row IPIV(i).  IPIV(i) will always be either\n*          i or i+1; IPIV(i) = i indicates a row interchange was not\n*          required.\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the matrix of right hand side vectors B.\n*          On exit, B is overwritten by the solution vectors X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            NOTRAN\n      INTEGER            ITRANS, J, JB, NB\n*     ..\n*     .. External Functions ..\n      INTEGER            ILAENV\n      EXTERNAL           ILAENV\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SGTTS2, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.sgttrs( trans, dl, d, du, du2, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_trans = argv[0];
  rblapack_dl = argv[1];
  rblapack_d = argv[2];
  rblapack_du = argv[3];
  rblapack_du2 = argv[4];
  rblapack_ipiv = argv[5];
  rblapack_b = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_SFLOAT)
    rblapack_dl = na_change_type(rblapack_dl, NA_SFLOAT);
  dl = NA_PTR_TYPE(rblapack_dl, real*);
  if (!NA_IsNArray(rblapack_du2))
    rb_raise(rb_eArgError, "du2 (5th argument) must be NArray");
  if (NA_RANK(rblapack_du2) != 1)
    rb_raise(rb_eArgError, "rank of du2 (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du2) != (n-2))
    rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
  if (NA_TYPE(rblapack_du2) != NA_SFLOAT)
    rblapack_du2 = na_change_type(rblapack_du2, NA_SFLOAT);
  du2 = NA_PTR_TYPE(rblapack_du2, real*);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (4th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_SFLOAT)
    rblapack_du = na_change_type(rblapack_du, NA_SFLOAT);
  du = NA_PTR_TYPE(rblapack_du, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  sgttrs_(&trans, &n, &nrhs, dl, d, du, du2, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_sgttrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgttrs", rblapack_sgttrs, -1);
}
ruby-lapack-1.7.2/ext/dpttrf.c0000644000175000017500000001047512502221012016030 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dpttrf_(integer* n, doublereal* d, doublereal* e, integer* info);


static VALUE
rblapack_dpttrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_e_out__;
  doublereal *e_out__;

  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  info, d, e = NumRu::Lapack.dpttrf( d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPTTRF( N, D, E, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPTTRF computes the L*D*L' factorization of a real symmetric\n*  positive definite tridiagonal matrix A.  The factorization may also\n*  be regarded as having the form A = U'*D*U.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the n diagonal elements of the tridiagonal matrix\n*          A.  On exit, the n diagonal elements of the diagonal matrix\n*          D from the L*D*L' factorization of A.\n*\n*  E       (input/output) DOUBLE PRECISION array, dimension (N-1)\n*          On entry, the (n-1) subdiagonal elements of the tridiagonal\n*          matrix A.  On exit, the (n-1) subdiagonal elements of the\n*          unit bidiagonal factor L from the L*D*L' factorization of A.\n*          E can also be regarded as the superdiagonal of the unit\n*          bidiagonal factor U from the U'*D*U factorization of A.\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*          > 0: if INFO = k, the leading minor of order k is not\n*               positive definite; if k < N, the factorization could not\n*               be completed, while if k = N, the factorization was\n*               completed, but D(N) <= 0.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, e = NumRu::Lapack.dpttrf( d, e, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_d = argv[0];
  rblapack_e = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (2th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
  MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;

  dpttrf_(&n, d, e, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_d, rblapack_e);
}

void
init_lapack_dpttrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dpttrf", rblapack_dpttrf, -1);
}
ruby-lapack-1.7.2/ext/dlacon.c0000644000175000017500000001030412502221015015757 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlacon_(integer* n, doublereal* v, doublereal* x, integer* isgn, doublereal* est, integer* kase);


static VALUE
rblapack_dlacon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_est;
  doublereal est; 
  VALUE rblapack_kase;
  integer kase; 
  VALUE rblapack_x_out__;
  doublereal *x_out__;
  doublereal *v;
  integer *isgn;

  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  x, est, kase = NumRu::Lapack.dlacon( x, est, kase, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE )\n\n*  Purpose\n*  =======\n*\n*  DLACON estimates the 1-norm of a square, real matrix A.\n*  Reverse communication is used for evaluating matrix-vector products.\n*\n\n*  Arguments\n*  =========\n*\n*  N      (input) INTEGER\n*         The order of the matrix.  N >= 1.\n*\n*  V      (workspace) DOUBLE PRECISION array, dimension (N)\n*         On the final return, V = A*W,  where  EST = norm(V)/norm(W)\n*         (W is not returned).\n*\n*  X      (input/output) DOUBLE PRECISION array, dimension (N)\n*         On an intermediate return, X should be overwritten by\n*               A * X,   if KASE=1,\n*               A' * X,  if KASE=2,\n*         and DLACON must be re-called with all the other parameters\n*         unchanged.\n*\n*  ISGN   (workspace) INTEGER array, dimension (N)\n*\n*  EST    (input/output) DOUBLE PRECISION\n*         On entry with KASE = 1 or 2 and JUMP = 3, EST should be\n*         unchanged from the previous call to DLACON.\n*         On exit, EST is an estimate (a lower bound) for norm(A). \n*\n*  KASE   (input/output) INTEGER\n*         On the initial call to DLACON, KASE should be 0.\n*         On an intermediate return, KASE will be 1 or 2, indicating\n*         whether X should be overwritten by A * X  or A' * X.\n*         On the final return from DLACON, KASE will again be 0.\n*\n\n*  Further Details\n*  ======= =======\n*\n*  Contributed by Nick Higham, University of Manchester.\n*  Originally named SONEST, dated March 16, 1988.\n*\n*  Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n*  a real or complex matrix, with applications to condition estimation\",\n*  ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, est, kase = NumRu::Lapack.dlacon( x, est, kase, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_x = argv[0];
  rblapack_est = argv[1];
  rblapack_kase = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (1th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  kase = NUM2INT(rblapack_kase);
  est = NUM2DBL(rblapack_est);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  v = ALLOC_N(doublereal, (n));
  isgn = ALLOC_N(integer, (n));

  dlacon_(&n, v, x, isgn, &est, &kase);

  free(v);
  free(isgn);
  rblapack_est = rb_float_new((double)est);
  rblapack_kase = INT2NUM(kase);
  return rb_ary_new3(3, rblapack_x, rblapack_est, rblapack_kase);
}

void
init_lapack_dlacon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlacon", rblapack_dlacon, -1);
}
ruby-lapack-1.7.2/ext/dggsvp.c0000644000175000017500000002351112502221015016015 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dggsvp_(char* jobu, char* jobv, char* jobq, integer* m, integer* p, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* tola, doublereal* tolb, integer* k, integer* l, doublereal* u, integer* ldu, doublereal* v, integer* ldv, doublereal* q, integer* ldq, integer* iwork, doublereal* tau, doublereal* work, integer* info);


static VALUE
rblapack_dggsvp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobu;
  char jobu; 
  VALUE rblapack_jobv;
  char jobv; 
  VALUE rblapack_jobq;
  char jobq; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_tola;
  doublereal tola; 
  VALUE rblapack_tolb;
  doublereal tolb; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_u;
  doublereal *u; 
  VALUE rblapack_v;
  doublereal *v; 
  VALUE rblapack_q;
  doublereal *q; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;
  integer *iwork;
  doublereal *tau;
  doublereal *work;

  integer lda;
  integer n;
  integer ldb;
  integer ldu;
  integer m;
  integer ldv;
  integer p;
  integer ldq;

  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  k, l, u, v, q, info, a, b = NumRu::Lapack.dggsvp( jobu, jobv, jobq, a, b, tola, tolb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGGSVP computes orthogonal matrices U, V and Q such that\n*\n*                   N-K-L  K    L\n*   U'*A*Q =     K ( 0    A12  A13 )  if M-K-L >= 0;\n*                L ( 0     0   A23 )\n*            M-K-L ( 0     0    0  )\n*\n*                   N-K-L  K    L\n*          =     K ( 0    A12  A13 )  if M-K-L < 0;\n*              M-K ( 0     0   A23 )\n*\n*                 N-K-L  K    L\n*   V'*B*Q =   L ( 0     0   B13 )\n*            P-L ( 0     0    0  )\n*\n*  where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n*  upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n*  otherwise A23 is (M-K)-by-L upper trapezoidal.  K+L = the effective\n*  numerical rank of the (M+P)-by-N matrix (A',B')'.  Z' denotes the\n*  transpose of Z.\n*\n*  This decomposition is the preprocessing step for computing the\n*  Generalized Singular Value Decomposition (GSVD), see subroutine\n*  DGGSVD.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBU    (input) CHARACTER*1\n*          = 'U':  Orthogonal matrix U is computed;\n*          = 'N':  U is not computed.\n*\n*  JOBV    (input) CHARACTER*1\n*          = 'V':  Orthogonal matrix V is computed;\n*          = 'N':  V is not computed.\n*\n*  JOBQ    (input) CHARACTER*1\n*          = 'Q':  Orthogonal matrix Q is computed;\n*          = 'N':  Q is not computed.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.  M >= 0.\n*\n*  P       (input) INTEGER\n*          The number of rows of the matrix B.  P >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrices A and B.  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, A contains the triangular (or trapezoidal) matrix\n*          described in the Purpose section.\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,N)\n*          On entry, the P-by-N matrix B.\n*          On exit, B contains the triangular matrix described in\n*          the Purpose section.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,P).\n*\n*  TOLA    (input) DOUBLE PRECISION\n*  TOLB    (input) DOUBLE PRECISION\n*          TOLA and TOLB are the thresholds to determine the effective\n*          numerical rank of matrix B and a subblock of A. Generally,\n*          they are set to\n*             TOLA = MAX(M,N)*norm(A)*MAZHEPS,\n*             TOLB = MAX(P,N)*norm(B)*MAZHEPS.\n*          The size of TOLA and TOLB may affect the size of backward\n*          errors of the decomposition.\n*\n*  K       (output) INTEGER\n*  L       (output) INTEGER\n*          On exit, K and L specify the dimension of the subblocks\n*          described in Purpose.\n*          K + L = effective numerical rank of (A',B')'.\n*\n*  U       (output) DOUBLE PRECISION array, dimension (LDU,M)\n*          If JOBU = 'U', U contains the orthogonal matrix U.\n*          If JOBU = 'N', U is not referenced.\n*\n*  LDU     (input) INTEGER\n*          The leading dimension of the array U. LDU >= max(1,M) if\n*          JOBU = 'U'; LDU >= 1 otherwise.\n*\n*  V       (output) DOUBLE PRECISION array, dimension (LDV,P)\n*          If JOBV = 'V', V contains the orthogonal matrix V.\n*          If JOBV = 'N', V is not referenced.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V. LDV >= max(1,P) if\n*          JOBV = 'V'; LDV >= 1 otherwise.\n*\n*  Q       (output) DOUBLE PRECISION array, dimension (LDQ,N)\n*          If JOBQ = 'Q', Q contains the orthogonal matrix Q.\n*          If JOBQ = 'N', Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q. LDQ >= max(1,N) if\n*          JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\n*\n*  TAU     (workspace) DOUBLE PRECISION array, dimension (N)\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (max(3*N,M,P))\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\n*  Further Details\n*  ===============\n*\n*  The subroutine uses LAPACK subroutine DGEQPF for the QR factorization\n*  with column pivoting to detect the effective numerical rank of the\n*  a matrix. It may be replaced by a better rank determination strategy.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  k, l, u, v, q, info, a, b = NumRu::Lapack.dggsvp( jobu, jobv, jobq, a, b, tola, tolb, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_jobu = argv[0];
  rblapack_jobv = argv[1];
  rblapack_jobq = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  rblapack_tola = argv[5];
  rblapack_tolb = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobu = StringValueCStr(rblapack_jobu)[0];
  jobq = StringValueCStr(rblapack_jobq)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = 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*);
  tolb = NUM2DBL(rblapack_tolb);
  p = ldb;
  jobv = StringValueCStr(rblapack_jobv)[0];
  tola = NUM2DBL(rblapack_tola);
  ldv = lsame_(&jobv,"V") ? MAX(1,p) : 1;
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  ldq = lsame_(&jobq,"Q") ? MAX(1,n) : 1;
  m = lda;
  ldu = lsame_(&jobu,"U") ? MAX(1,m) : 1;
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = m;
    rblapack_u = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  u = NA_PTR_TYPE(rblapack_u, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = p;
    rblapack_v = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  v = NA_PTR_TYPE(rblapack_v, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  q = NA_PTR_TYPE(rblapack_q, doublereal*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  iwork = ALLOC_N(integer, (n));
  tau = ALLOC_N(doublereal, (n));
  work = ALLOC_N(doublereal, (MAX(MAX(3*n,m),p)));

  dggsvp_(&jobu, &jobv, &jobq, &m, &p, &n, a, &lda, b, &ldb, &tola, &tolb, &k, &l, u, &ldu, v, &ldv, q, &ldq, iwork, tau, work, &info);

  free(iwork);
  free(tau);
  free(work);
  rblapack_k = INT2NUM(k);
  rblapack_l = INT2NUM(l);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_k, rblapack_l, rblapack_u, rblapack_v, rblapack_q, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_dggsvp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dggsvp", rblapack_dggsvp, -1);
}
ruby-lapack-1.7.2/ext/dorgqr.c0000644000175000017500000001256512502221020016024 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dorgqr_(integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dorgqr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;

  integer lda;
  integer n;
  integer k;

  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 = NumRu::Lapack.dorgqr( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DORGQR generates an M-by-N real matrix Q with orthonormal columns,\n*  which is defined as the first N columns of a product of K elementary\n*  reflectors of order M\n*\n*        Q  =  H(1) H(2) . . . H(k)\n*\n*  as returned by DGEQRF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. M >= N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. N >= K >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the i-th column must contain the vector which\n*          defines the elementary reflector H(i), for i = 1,2,...,k, as\n*          returned by DGEQRF in the first k columns of its array\n*          argument A.\n*          On exit, the M-by-N matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) DOUBLE PRECISION array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by DGEQRF.\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,N).\n*          For optimum performance LWORK >= N*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 has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, a = NumRu::Lapack.dorgqr( m, a, tau, [: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_m = argv[0];
  rblapack_a = argv[1];
  rblapack_tau = 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;
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  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*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;

  dorgqr_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_dorgqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dorgqr", rblapack_dorgqr, -1);
}
ruby-lapack-1.7.2/ext/spstf2.c0000644000175000017500000001247012502221026015750 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID spstf2_(char* uplo, integer* n, real* a, integer* lda, integer* piv, integer* rank, real* tol, real* work, integer* info);


static VALUE
rblapack_spstf2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tol;
  real tol; 
  VALUE rblapack_piv;
  integer *piv; 
  VALUE rblapack_rank;
  integer rank; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  real *work;

  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  piv, rank, info, a = NumRu::Lapack.spstf2( uplo, a, tol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPSTF2 computes the Cholesky factorization with complete\n*  pivoting of a real symmetric positive semidefinite matrix A.\n*\n*  The factorization has the form\n*     P' * A * P = U' * U ,  if UPLO = 'U',\n*     P' * A * P = L  * L',  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is lower triangular, and\n*  P is stored as vector PIV.\n*\n*  This algorithm does not attempt to check that A is positive\n*  semidefinite. This version of the algorithm calls level 2 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          n by n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n by n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the factor U or L from the Cholesky\n*          factorization as above.\n*\n*  PIV     (output) INTEGER array, dimension (N)\n*          PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n*\n*  RANK    (output) INTEGER\n*          The rank of A given by the number of steps the algorithm\n*          completed.\n*\n*  TOL     (input) REAL\n*          User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) )\n*          will be used. The algorithm terminates at the (K-1)st step\n*          if the pivot <= TOL.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  WORK    (workspace) REAL array, dimension (2*N)\n*          Work space.\n*\n*  INFO    (output) INTEGER\n*          < 0: If INFO = -K, the K-th argument had an illegal value,\n*          = 0: algorithm completed successfully, and\n*          > 0: the matrix A is either rank deficient with computed rank\n*               as returned in RANK, or is indefinite.  See Section 7 of\n*               LAPACK Working Note #161 for further information.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  piv, rank, info, a = NumRu::Lapack.spstf2( uplo, a, tol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_tol = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  tol = (real)NUM2DBL(rblapack_tol);
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_piv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  piv = NA_PTR_TYPE(rblapack_piv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(real, (2*n));

  spstf2_(&uplo, &n, a, &lda, piv, &rank, &tol, work, &info);

  free(work);
  rblapack_rank = INT2NUM(rank);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_piv, rblapack_rank, rblapack_info, rblapack_a);
}

void
init_lapack_spstf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "spstf2", rblapack_spstf2, -1);
}
ruby-lapack-1.7.2/ext/dlarfg.c0000644000175000017500000000753412502221016015772 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlarfg_(integer* n, doublereal* alpha, doublereal* x, integer* incx, doublereal* tau);


static VALUE
rblapack_dlarfg(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_alpha;
  doublereal alpha; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_tau;
  doublereal tau; 
  VALUE rblapack_x_out__;
  doublereal *x_out__;


  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, alpha, x = NumRu::Lapack.dlarfg( n, alpha, x, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )\n\n*  Purpose\n*  =======\n*\n*  DLARFG generates a real elementary reflector H of order n, such\n*  that\n*\n*        H * ( alpha ) = ( beta ),   H' * H = I.\n*            (   x   )   (   0  )\n*\n*  where alpha and beta are scalars, and x is an (n-1)-element real\n*  vector. H is represented in the form\n*\n*        H = I - tau * ( 1 ) * ( 1 v' ) ,\n*                      ( v )\n*\n*  where tau is a real scalar and v is a real (n-1)-element\n*  vector.\n*\n*  If the elements of x are all zero, then tau = 0 and H is taken to be\n*  the unit matrix.\n*\n*  Otherwise  1 <= tau <= 2.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the elementary reflector.\n*\n*  ALPHA   (input/output) DOUBLE PRECISION\n*          On entry, the value alpha.\n*          On exit, it is overwritten with the value beta.\n*\n*  X       (input/output) DOUBLE PRECISION array, dimension\n*                         (1+(N-2)*abs(INCX))\n*          On entry, the vector x.\n*          On exit, it is overwritten with the vector v.\n*\n*  INCX    (input) INTEGER\n*          The increment between elements of X. INCX > 0.\n*\n*  TAU     (output) DOUBLE PRECISION\n*          The value tau.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, alpha, x = NumRu::Lapack.dlarfg( n, alpha, x, incx, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_n = argv[0];
  rblapack_alpha = argv[1];
  rblapack_x = argv[2];
  rblapack_incx = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  incx = NUM2INT(rblapack_incx);
  alpha = NUM2DBL(rblapack_alpha);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (3th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1+(n-2)*abs(incx)))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-2)*abs(incx));
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-2)*abs(incx);
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;

  dlarfg_(&n, &alpha, x, &incx, &tau);

  rblapack_tau = rb_float_new((double)tau);
  rblapack_alpha = rb_float_new((double)alpha);
  return rb_ary_new3(3, rblapack_tau, rblapack_alpha, rblapack_x);
}

void
init_lapack_dlarfg(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlarfg", rblapack_dlarfg, -1);
}
ruby-lapack-1.7.2/ext/dgeevx.c0000644000175000017500000003403612502221020016005 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgeevx_(char* balanc, char* jobvl, char* jobvr, char* sense, integer* n, doublereal* a, integer* lda, doublereal* wr, doublereal* wi, doublereal* vl, integer* ldvl, doublereal* vr, integer* ldvr, integer* ilo, integer* ihi, doublereal* scale, doublereal* abnrm, doublereal* rconde, doublereal* rcondv, doublereal* work, integer* lwork, integer* iwork, integer* info);


static VALUE
rblapack_dgeevx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_balanc;
  char balanc; 
  VALUE rblapack_jobvl;
  char jobvl; 
  VALUE rblapack_jobvr;
  char jobvr; 
  VALUE rblapack_sense;
  char sense; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_wr;
  doublereal *wr; 
  VALUE rblapack_wi;
  doublereal *wi; 
  VALUE rblapack_vl;
  doublereal *vl; 
  VALUE rblapack_vr;
  doublereal *vr; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_scale;
  doublereal *scale; 
  VALUE rblapack_abnrm;
  doublereal abnrm; 
  VALUE rblapack_rconde;
  doublereal *rconde; 
  VALUE rblapack_rcondv;
  doublereal *rcondv; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  integer *iwork;

  integer lda;
  integer n;
  integer ldvl;
  integer ldvr;

  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  wr, wi, vl, vr, ilo, ihi, scale, abnrm, rconde, rcondv, work, info, a = NumRu::Lapack.dgeevx( balanc, jobvl, jobvr, sense, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, WORK, LWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGEEVX computes for an N-by-N real nonsymmetric matrix A, the\n*  eigenvalues and, optionally, the left and/or right eigenvectors.\n*\n*  Optionally also, it computes a balancing transformation to improve\n*  the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n*  SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues\n*  (RCONDE), and reciprocal condition numbers for the right\n*  eigenvectors (RCONDV).\n*\n*  The right eigenvector v(j) of A satisfies\n*                   A * v(j) = lambda(j) * v(j)\n*  where lambda(j) is its eigenvalue.\n*  The left eigenvector u(j) of A satisfies\n*                u(j)**H * A = lambda(j) * u(j)**H\n*  where u(j)**H denotes the conjugate transpose of u(j).\n*\n*  The computed eigenvectors are normalized to have Euclidean norm\n*  equal to 1 and largest component real.\n*\n*  Balancing a matrix means permuting the rows and columns to make it\n*  more nearly upper triangular, and applying a diagonal similarity\n*  transformation D * A * D**(-1), where D is a diagonal matrix, to\n*  make its rows and columns closer in norm and the condition numbers\n*  of its eigenvalues and eigenvectors smaller.  The computed\n*  reciprocal condition numbers correspond to the balanced matrix.\n*  Permuting rows and columns will not change the condition numbers\n*  (in exact arithmetic) but diagonal scaling will.  For further\n*  explanation of balancing, see section 4.10.2 of the LAPACK\n*  Users' Guide.\n*\n\n*  Arguments\n*  =========\n*\n*  BALANC  (input) CHARACTER*1\n*          Indicates how the input matrix should be diagonally scaled\n*          and/or permuted to improve the conditioning of its\n*          eigenvalues.\n*          = 'N': Do not diagonally scale or permute;\n*          = 'P': Perform permutations to make the matrix more nearly\n*                 upper triangular. Do not diagonally scale;\n*          = 'S': Diagonally scale the matrix, i.e. replace A by\n*                 D*A*D**(-1), where D is a diagonal matrix chosen\n*                 to make the rows and columns of A more equal in\n*                 norm. Do not permute;\n*          = 'B': Both diagonally scale and permute A.\n*\n*          Computed reciprocal condition numbers will be for the matrix\n*          after balancing and/or permuting. Permuting does not change\n*          condition numbers (in exact arithmetic), but balancing does.\n*\n*  JOBVL   (input) CHARACTER*1\n*          = 'N': left eigenvectors of A are not computed;\n*          = 'V': left eigenvectors of A are computed.\n*          If SENSE = 'E' or 'B', JOBVL must = 'V'.\n*\n*  JOBVR   (input) CHARACTER*1\n*          = 'N': right eigenvectors of A are not computed;\n*          = 'V': right eigenvectors of A are computed.\n*          If SENSE = 'E' or 'B', JOBVR must = 'V'.\n*\n*  SENSE   (input) CHARACTER*1\n*          Determines which reciprocal condition numbers are computed.\n*          = 'N': None are computed;\n*          = 'E': Computed for eigenvalues only;\n*          = 'V': Computed for right eigenvectors only;\n*          = 'B': Computed for eigenvalues and right eigenvectors.\n*\n*          If SENSE = 'E' or 'B', both left and right eigenvectors\n*          must also be computed (JOBVL = 'V' and JOBVR = 'V').\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the N-by-N matrix A.\n*          On exit, A has been overwritten.  If JOBVL = 'V' or\n*          JOBVR = 'V', A contains the real Schur form of the balanced\n*          version of the input matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  WR      (output) DOUBLE PRECISION array, dimension (N)\n*  WI      (output) DOUBLE PRECISION array, dimension (N)\n*          WR and WI contain the real and imaginary parts,\n*          respectively, of the computed eigenvalues.  Complex\n*          conjugate pairs of eigenvalues will appear consecutively\n*          with the eigenvalue having the positive imaginary part\n*          first.\n*\n*  VL      (output) DOUBLE PRECISION array, dimension (LDVL,N)\n*          If JOBVL = 'V', the left eigenvectors u(j) are stored one\n*          after another in the columns of VL, in the same order\n*          as their eigenvalues.\n*          If JOBVL = 'N', VL is not referenced.\n*          If the j-th eigenvalue is real, then u(j) = VL(:,j),\n*          the j-th column of VL.\n*          If the j-th and (j+1)-st eigenvalues form a complex\n*          conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and\n*          u(j+1) = VL(:,j) - i*VL(:,j+1).\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the array VL.  LDVL >= 1; if\n*          JOBVL = 'V', LDVL >= N.\n*\n*  VR      (output) DOUBLE PRECISION array, dimension (LDVR,N)\n*          If JOBVR = 'V', the right eigenvectors v(j) are stored one\n*          after another in the columns of VR, in the same order\n*          as their eigenvalues.\n*          If JOBVR = 'N', VR is not referenced.\n*          If the j-th eigenvalue is real, then v(j) = VR(:,j),\n*          the j-th column of VR.\n*          If the j-th and (j+1)-st eigenvalues form a complex\n*          conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and\n*          v(j+1) = VR(:,j) - i*VR(:,j+1).\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the array VR.  LDVR >= 1, and if\n*          JOBVR = 'V', LDVR >= N.\n*\n*  ILO     (output) INTEGER\n*  IHI     (output) INTEGER\n*          ILO and IHI are integer values determined when A was\n*          balanced.  The balanced A(i,j) = 0 if I > J and\n*          J = 1,...,ILO-1 or I = IHI+1,...,N.\n*\n*  SCALE   (output) DOUBLE PRECISION array, dimension (N)\n*          Details of the permutations and scaling factors applied\n*          when balancing A.  If P(j) is the index of the row and column\n*          interchanged with row and column j, and D(j) is the scaling\n*          factor applied to row and column j, then\n*          SCALE(J) = P(J),    for J = 1,...,ILO-1\n*                   = D(J),    for J = ILO,...,IHI\n*                   = P(J)     for J = IHI+1,...,N.\n*          The order in which the interchanges are made is N to IHI+1,\n*          then 1 to ILO-1.\n*\n*  ABNRM   (output) DOUBLE PRECISION\n*          The one-norm of the balanced matrix (the maximum\n*          of the sum of absolute values of elements of any column).\n*\n*  RCONDE  (output) DOUBLE PRECISION array, dimension (N)\n*          RCONDE(j) is the reciprocal condition number of the j-th\n*          eigenvalue.\n*\n*  RCONDV  (output) DOUBLE PRECISION array, dimension (N)\n*          RCONDV(j) is the reciprocal condition number of the j-th\n*          right eigenvector.\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.   If SENSE = 'N' or 'E',\n*          LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V',\n*          LWORK >= 3*N.  If SENSE = 'V' or 'B', LWORK >= N*(N+6).\n*          For good performance, LWORK must generally be larger.\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*  IWORK   (workspace) INTEGER array, dimension (2*N-2)\n*          If SENSE = 'N' or 'E', not referenced.\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 QR algorithm failed to compute all the\n*                eigenvalues, and no eigenvectors or condition numbers\n*                have been computed; elements 1:ILO-1 and i+1:N of WR\n*                and WI contain eigenvalues which have converged.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  wr, wi, vl, vr, ilo, ihi, scale, abnrm, rconde, rcondv, work, info, a = NumRu::Lapack.dgeevx( balanc, jobvl, jobvr, sense, a, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_balanc = argv[0];
  rblapack_jobvl = argv[1];
  rblapack_jobvr = argv[2];
  rblapack_sense = argv[3];
  rblapack_a = argv[4];
  if (argc == 6) {
    rblapack_lwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  balanc = StringValueCStr(rblapack_balanc)[0];
  jobvr = StringValueCStr(rblapack_jobvr)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th 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*);
  ldvr = lsame_(&jobvr,"V") ? n : 1;
  jobvl = StringValueCStr(rblapack_jobvl)[0];
  ldvl = lsame_(&jobvl,"V") ? n : 1;
  sense = StringValueCStr(rblapack_sense)[0];
  if (rblapack_lwork == Qnil)
    lwork = (lsame_(&sense,"N")||lsame_(&sense,"E")) ? 2*n : (lsame_(&jobvl,"V")||lsame_(&jobvr,"V")) ? 3*n : (lsame_(&sense,"V")||lsame_(&sense,"B")) ? n*(n+6) : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  wr = NA_PTR_TYPE(rblapack_wr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  wi = NA_PTR_TYPE(rblapack_wi, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = n;
    rblapack_vl = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vl = NA_PTR_TYPE(rblapack_vl, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = n;
    rblapack_vr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vr = NA_PTR_TYPE(rblapack_vr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_scale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  scale = NA_PTR_TYPE(rblapack_scale, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rconde = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  rconde = NA_PTR_TYPE(rblapack_rconde, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rcondv = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  rcondv = NA_PTR_TYPE(rblapack_rcondv, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;
  iwork = ALLOC_N(integer, ((lsame_(&sense,"N")||lsame_(&sense,"E")) ? 0 : 2*n-2));

  dgeevx_(&balanc, &jobvl, &jobvr, &sense, &n, a, &lda, wr, wi, vl, &ldvl, vr, &ldvr, &ilo, &ihi, scale, &abnrm, rconde, rcondv, work, &lwork, iwork, &info);

  free(iwork);
  rblapack_ilo = INT2NUM(ilo);
  rblapack_ihi = INT2NUM(ihi);
  rblapack_abnrm = rb_float_new((double)abnrm);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(13, rblapack_wr, rblapack_wi, rblapack_vl, rblapack_vr, rblapack_ilo, rblapack_ihi, rblapack_scale, rblapack_abnrm, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_dgeevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgeevx", rblapack_dgeevx, -1);
}
ruby-lapack-1.7.2/ext/dlauum.c0000644000175000017500000000736212502221024016020 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlauum_(char* uplo, integer* n, doublereal* a, integer* lda, integer* info);


static VALUE
rblapack_dlauum(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  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  info, a = NumRu::Lapack.dlauum( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAUUM( UPLO, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLAUUM computes the product U * U' or L' * L, where the triangular\n*  factor U or L is stored in the upper or lower triangular part of\n*  the array A.\n*\n*  If UPLO = 'U' or 'u' then the upper triangle of the result is stored,\n*  overwriting the factor U in A.\n*  If UPLO = 'L' or 'l' then the lower triangle of the result is stored,\n*  overwriting the factor L in A.\n*\n*  This is the blocked form of the algorithm, calling Level 3 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the triangular factor stored in the array A\n*          is upper or lower triangular:\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the triangular factor U or L.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the triangular factor U or L.\n*          On exit, if UPLO = 'U', the upper triangle of A is\n*          overwritten with the upper triangle of the product U * U';\n*          if UPLO = 'L', the lower triangle of A is overwritten with\n*          the lower triangle of the product L' * L.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.dlauum( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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*);
  {
    na_shape_t 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__;

  dlauum_(&uplo, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_dlauum(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlauum", rblapack_dlauum, -1);
}
ruby-lapack-1.7.2/ext/dgbbrd.c0000644000175000017500000001756112502221013015755 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgbbrd_(char* vect, integer* m, integer* n, integer* ncc, integer* kl, integer* ku, doublereal* ab, integer* ldab, doublereal* d, doublereal* e, doublereal* q, integer* ldq, doublereal* pt, integer* ldpt, doublereal* c, integer* ldc, doublereal* work, integer* info);


static VALUE
rblapack_dgbbrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_vect;
  char vect; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_q;
  doublereal *q; 
  VALUE rblapack_pt;
  doublereal *pt; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublereal *ab_out__;
  VALUE rblapack_c_out__;
  doublereal *c_out__;
  doublereal *work;

  integer ldab;
  integer n;
  integer ldc;
  integer ncc;
  integer ldq;
  integer m;
  integer ldpt;

  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  d, e, q, pt, info, ab, c = NumRu::Lapack.dgbbrd( vect, kl, ku, ab, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, LDQ, PT, LDPT, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGBBRD reduces a real general m-by-n band matrix A to upper\n*  bidiagonal form B by an orthogonal transformation: Q' * A * P = B.\n*\n*  The routine computes B, and optionally forms Q or P', or computes\n*  Q'*C for a given matrix C.\n*\n\n*  Arguments\n*  =========\n*\n*  VECT    (input) CHARACTER*1\n*          Specifies whether or not the matrices Q and P' are to be\n*          formed.\n*          = 'N': do not form Q or P';\n*          = 'Q': form Q only;\n*          = 'P': form P' only;\n*          = 'B': form both.\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*  NCC     (input) INTEGER\n*          The number of columns of the matrix C.  NCC >= 0.\n*\n*  KL      (input) INTEGER\n*          The number of subdiagonals of the matrix A. KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals of the matrix A. KU >= 0.\n*\n*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n*          On entry, the m-by-n band matrix A, stored in rows 1 to\n*          KL+KU+1. The j-th column of A is stored in the j-th column of\n*          the array AB as follows:\n*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n*          On exit, A is overwritten by values generated during the\n*          reduction.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array A. LDAB >= KL+KU+1.\n*\n*  D       (output) DOUBLE PRECISION array, dimension (min(M,N))\n*          The diagonal elements of the bidiagonal matrix B.\n*\n*  E       (output) DOUBLE PRECISION array, dimension (min(M,N)-1)\n*          The superdiagonal elements of the bidiagonal matrix B.\n*\n*  Q       (output) DOUBLE PRECISION array, dimension (LDQ,M)\n*          If VECT = 'Q' or 'B', the m-by-m orthogonal matrix Q.\n*          If VECT = 'N' or 'P', the array Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.\n*          LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.\n*\n*  PT      (output) DOUBLE PRECISION array, dimension (LDPT,N)\n*          If VECT = 'P' or 'B', the n-by-n orthogonal matrix P'.\n*          If VECT = 'N' or 'Q', the array PT is not referenced.\n*\n*  LDPT    (input) INTEGER\n*          The leading dimension of the array PT.\n*          LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,NCC)\n*          On entry, an m-by-ncc matrix C.\n*          On exit, C is overwritten by Q'*C.\n*          C is not referenced if NCC = 0.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C.\n*          LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (2*max(M,N))\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, q, pt, info, ab, c = NumRu::Lapack.dgbbrd( vect, kl, ku, ab, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_vect = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  rblapack_c = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  vect = StringValueCStr(rblapack_vect)[0];
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  ncc = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  ldpt = ((lsame_(&vect,"P")) || (lsame_(&vect,"B"))) ? MAX(1,n) : 1;
  m = ldab;
  ldq = ((lsame_(&vect,"Q")) || (lsame_(&vect,"B"))) ? MAX(1,m) : 1;
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n)-1;
    rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = m;
    rblapack_q = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  q = NA_PTR_TYPE(rblapack_q, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldpt;
    shape[1] = n;
    rblapack_pt = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  pt = NA_PTR_TYPE(rblapack_pt, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
  MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = ncc;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(doublereal, (2*MAX(m,n)));

  dgbbrd_(&vect, &m, &n, &ncc, &kl, &ku, ab, &ldab, d, e, q, &ldq, pt, &ldpt, c, &ldc, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_d, rblapack_e, rblapack_q, rblapack_pt, rblapack_info, rblapack_ab, rblapack_c);
}

void
init_lapack_dgbbrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgbbrd", rblapack_dgbbrd, -1);
}
ruby-lapack-1.7.2/ext/sgetc2.c0000644000175000017500000001054612502221015015716 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgetc2_(integer* n, real* a, integer* lda, integer* ipiv, integer* jpiv, integer* info);


static VALUE
rblapack_sgetc2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_jpiv;
  integer *jpiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *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  ipiv, jpiv, info, a = NumRu::Lapack.sgetc2( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGETC2( N, A, LDA, IPIV, JPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGETC2 computes an LU factorization with complete pivoting of the\n*  n-by-n matrix A. The factorization has the form A = P * L * U * Q,\n*  where P and Q are permutation matrices, L is lower triangular with\n*  unit diagonal elements and U is upper triangular.\n*\n*  This is the Level 2 BLAS algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA, N)\n*          On entry, the n-by-n matrix A to be factored.\n*          On exit, the factors L and U from the factorization\n*          A = P*L*U*Q; the unit diagonal elements of L are not stored.\n*          If U(k, k) appears to be less than SMIN, U(k, k) is given the\n*          value of SMIN, i.e., giving a nonsingular perturbed system.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension(N).\n*          The pivot indices; for 1 <= i <= N, row i of the\n*          matrix has been interchanged with row IPIV(i).\n*\n*  JPIV    (output) INTEGER array, dimension(N).\n*          The pivot indices; for 1 <= j <= N, column j of the\n*          matrix has been interchanged with column JPIV(j).\n*\n*  INFO    (output) INTEGER\n*           = 0: successful exit\n*           > 0: if INFO = k, U(k, k) is likely to produce owerflow if\n*                we try to solve for x in Ax = b. So U is perturbed to\n*                avoid the overflow.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, jpiv, info, a = NumRu::Lapack.sgetc2( 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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_jpiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  jpiv = NA_PTR_TYPE(rblapack_jpiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  sgetc2_(&n, a, &lda, ipiv, jpiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ipiv, rblapack_jpiv, rblapack_info, rblapack_a);
}

void
init_lapack_sgetc2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgetc2", rblapack_sgetc2, -1);
}
ruby-lapack-1.7.2/ext/xerbla.c0000644000175000017500000000416112502221020015774 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID xerbla_(char* srname, integer* info);


static VALUE
rblapack_xerbla(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_srname;
  char *srname; 
  VALUE rblapack_info;
  integer info; 


  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   = NumRu::Lapack.xerbla( srname, info, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE XERBLA( SRNAME, INFO )\n\n*  Purpose\n*  =======\n*\n*  XERBLA  is an error handler for the LAPACK routines.\n*  It is called by an LAPACK routine if an input parameter has an\n*  invalid value.  A message is printed and execution stops.\n*\n*  Installers may consider modifying the STOP statement in order to\n*  call system-specific exception-handling facilities.\n*\n\n*  Arguments\n*  =========\n*\n*  SRNAME  (input) CHARACTER*(*)\n*          The name of the routine which called XERBLA.\n*\n*  INFO    (input) INTEGER\n*          The position of the invalid parameter in the parameter list\n*          of the calling routine.\n*\n\n* =====================================================================\n*\n*     .. Intrinsic Functions ..\n      INTRINSIC          LEN_TRIM\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n   = NumRu::Lapack.xerbla( srname, info, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_srname = argv[0];
  rblapack_info = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  srname = StringValueCStr(rblapack_srname);
  info = NUM2INT(rblapack_info);

  xerbla_(srname, &info);

  return Qnil;
}

void
init_lapack_xerbla(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "xerbla", rblapack_xerbla, -1);
}
ruby-lapack-1.7.2/ext/clanhe.c0000644000175000017500000001104412502221020015747 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real clanhe_(char* norm, char* uplo, integer* n, complex* a, integer* lda, real* work);


static VALUE
rblapack_clanhe(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack___out__;
  real __out__; 
  real *work;

  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  __out__ = NumRu::Lapack.clanhe( norm, uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL             FUNCTION CLANHE( NORM, UPLO, N, A, LDA, WORK )\n\n*  Purpose\n*  =======\n*\n*  CLANHE  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  complex hermitian matrix A.\n*\n*  Description\n*  ===========\n*\n*  CLANHE returns the value\n*\n*     CLANHE = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in CLANHE as described\n*          above.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          hermitian matrix A is to be referenced.\n*          = 'U':  Upper triangular part of A is referenced\n*          = 'L':  Lower triangular part of A is referenced\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, CLANHE is\n*          set to zero.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The hermitian matrix A.  If UPLO = 'U', the leading n by n\n*          upper triangular part of A contains the upper triangular part\n*          of the matrix A, and the strictly lower triangular part of A\n*          is not referenced.  If UPLO = 'L', the leading n by n lower\n*          triangular part of A contains the lower triangular part of\n*          the matrix A, and the strictly upper triangular part of A is\n*          not referenced. Note that the imaginary parts of the diagonal\n*          elements need not be set and are assumed to be zero.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(N,1).\n*\n*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n*          WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.clanhe( norm, uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  work = ALLOC_N(real, (MAX(1,(lsame_(&norm,"I")||lsame_(&norm,"1")||lsame_(&norm,"o")) ? n : 0)));

  __out__ = clanhe_(&norm, &uplo, &n, a, &lda, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_clanhe(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clanhe", rblapack_clanhe, -1);
}
ruby-lapack-1.7.2/ext/cpftrf.c0000644000175000017500000002056312502221013016011 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cpftrf_(char* transr, char* uplo, integer* n, complex* a, integer* info);


static VALUE
rblapack_cpftrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;


  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  info, a = NumRu::Lapack.cpftrf( transr, uplo, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPFTRF( TRANSR, UPLO, N, A, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPFTRF computes the Cholesky factorization of a complex Hermitian\n*  positive definite matrix A.\n*\n*  The factorization has the form\n*     A = U**H * U,  if UPLO = 'U', or\n*     A = L  * L**H,  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is lower triangular.\n*\n*  This is the block version of the algorithm, calling Level 3 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR    (input) CHARACTER*1\n*          = 'N':  The Normal TRANSR of RFP A is stored;\n*          = 'C':  The Conjugate-transpose TRANSR of RFP A is stored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of RFP A is stored;\n*          = 'L':  Lower triangle of RFP A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension ( N*(N+1)/2 );\n*          On entry, the Hermitian matrix A in RFP format. RFP format is\n*          described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n*          then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n*          (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is\n*          the Conjugate-transpose of RFP A as defined when\n*          TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n*          follows: If UPLO = 'U' the RFP A contains the nt elements of\n*          upper packed A. If UPLO = 'L' the RFP A contains the elements\n*          of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n*          'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n*          is odd. See the Note below for more details.\n*\n*          On exit, if INFO = 0, the factor U or L from the Cholesky\n*          factorization RFP A = U**H*U or RFP A = L*L**H.\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 leading minor of order i is not\n*                positive definite, and the factorization could not be\n*                completed.\n*\n*  Further Notes on RFP Format:\n*  ============================\n*\n*\n*  We first consider Standard Packed Format when N is even.\n*  We give an example where N = 6.\n*\n*     AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  conjugate-transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  conjugate-transpose of the last three columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                -- -- --\n*        03 04 05                33 43 53\n*                                   -- --\n*        13 14 15                00 44 54\n*                                      --\n*        23 24 25                10 11 55\n*\n*        33 34 35                20 21 22\n*        --\n*        00 44 45                30 31 32\n*        -- --\n*        01 11 55                40 41 42\n*        -- -- --\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- -- --                -- -- -- -- -- --\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     -- -- -- -- --                -- -- -- -- --\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     -- -- -- -- -- --                -- -- -- --\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We next  consider Standard Packed Format when N is odd.\n*  We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  conjugate-transpose of the first two   columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  conjugate-transpose of the last two   columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N odd  and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                   -- --\n*        02 03 04                00 33 43\n*                                      --\n*        12 13 14                10 11 44\n*\n*        22 23 24                20 21 22\n*        --\n*        00 33 34                30 31 32\n*        -- --\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- --                   -- -- -- -- -- --\n*     02 12 22 00 01             00 10 20 30 40 50\n*     -- -- -- --                   -- -- -- -- --\n*     03 13 23 33 11             33 11 21 31 41 51\n*     -- -- -- -- --                   -- -- -- --\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.cpftrf( transr, uplo, n, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_n = argv[2];
  rblapack_a = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  n = NUM2INT(rblapack_n);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 1)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  cpftrf_(&transr, &uplo, &n, a, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_cpftrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cpftrf", rblapack_cpftrf, -1);
}
ruby-lapack-1.7.2/ext/dlapmt.c0000644000175000017500000001067112502221024016007 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlapmt_(logical* forwrd, integer* m, integer* n, doublereal* x, integer* ldx, integer* k);


static VALUE
rblapack_dlapmt(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_forwrd;
  logical forwrd; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_k;
  integer *k; 
  VALUE rblapack_x_out__;
  doublereal *x_out__;
  VALUE rblapack_k_out__;
  integer *k_out__;

  integer ldx;
  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  x, k = NumRu::Lapack.dlapmt( forwrd, m, x, k, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAPMT( FORWRD, M, N, X, LDX, K )\n\n*  Purpose\n*  =======\n*\n*  DLAPMT rearranges the columns of the M by N matrix X as specified\n*  by the permutation K(1),K(2),...,K(N) of the integers 1,...,N.\n*  If FORWRD = .TRUE.,  forward permutation:\n*\n*       X(*,K(J)) is moved X(*,J) for J = 1,2,...,N.\n*\n*  If FORWRD = .FALSE., backward permutation:\n*\n*       X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N.\n*\n\n*  Arguments\n*  =========\n*\n*  FORWRD  (input) LOGICAL\n*          = .TRUE., forward permutation\n*          = .FALSE., backward permutation\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix X. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix X. N >= 0.\n*\n*  X       (input/output) DOUBLE PRECISION array, dimension (LDX,N)\n*          On entry, the M by N matrix X.\n*          On exit, X contains the permuted matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X, LDX >= MAX(1,M).\n*\n*  K       (input/output) INTEGER array, dimension (N)\n*          On entry, K contains the permutation vector. K is used as\n*          internal workspace, but reset to its original value on\n*          output.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, II, IN, J\n      DOUBLE PRECISION   TEMP\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, k = NumRu::Lapack.dlapmt( forwrd, m, x, k, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_forwrd = argv[0];
  rblapack_m = argv[1];
  rblapack_x = argv[2];
  rblapack_k = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  forwrd = (rblapack_forwrd == Qtrue);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (3th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  n = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_k))
    rb_raise(rb_eArgError, "k (4th argument) must be NArray");
  if (NA_RANK(rblapack_k) != 1)
    rb_raise(rb_eArgError, "rank of k (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_k) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of k must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_k) != NA_LINT)
    rblapack_k = na_change_type(rblapack_k, NA_LINT);
  k = NA_PTR_TYPE(rblapack_k, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = n;
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_k_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  k_out__ = NA_PTR_TYPE(rblapack_k_out__, integer*);
  MEMCPY(k_out__, k, integer, NA_TOTAL(rblapack_k));
  rblapack_k = rblapack_k_out__;
  k = k_out__;

  dlapmt_(&forwrd, &m, &n, x, &ldx, k);

  return rb_ary_new3(2, rblapack_x, rblapack_k);
}

void
init_lapack_dlapmt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlapmt", rblapack_dlapmt, -1);
}
ruby-lapack-1.7.2/ext/cgelqf.c0000644000175000017500000001335212502221020015762 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgelqf_(integer* m, integer* n, complex* a, integer* lda, complex* tau, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_cgelqf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *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.cgelqf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGELQF computes an LQ factorization of a complex 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) COMPLEX 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 unitary 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) COMPLEX array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace/output) COMPLEX 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 complex scalar, and v is a complex vector with\n*  v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in\n*  A(i,i+1: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           CGELQ2, CLARFB, CLARFT, 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.cgelqf( 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;
  }

  m = NUM2INT(rblapack_m);
  if (rblapack_lwork == Qnil)
    lwork = m;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  cgelqf_(&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_cgelqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgelqf", rblapack_cgelqf, -1);
}
ruby-lapack-1.7.2/ext/sormrq.c0000644000175000017500000001577512502221021016060 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sormrq_(char* side, char* trans, integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* c, integer* ldc, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sormrq(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  real *c_out__;

  integer lda;
  integer m;
  integer k;
  integer ldc;
  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  work, info, c = NumRu::Lapack.sormrq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SORMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SORMRQ overwrites the general real M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'T':      Q**T * C       C * Q**T\n*\n*  where Q is a real orthogonal matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(1) H(2) . . . H(k)\n*\n*  as returned by SGERQF. Q is of order M if SIDE = 'L' and of order N\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**T from the Left;\n*          = 'R': apply Q or Q**T from the Right.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'T':  Transpose, apply Q**T.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) REAL array, dimension\n*                               (LDA,M) if SIDE = 'L',\n*                               (LDA,N) if SIDE = 'R'\n*          The i-th row must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          SGERQF in the last k rows of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,K).\n*\n*  TAU     (input) REAL array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by SGERQF.\n*\n*  C       (input/output) REAL array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace/output) REAL 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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M).\n*          For optimum performance LWORK >= N*NB if SIDE = 'L', and\n*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n*          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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.sormrq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_a = argv[2];
  rblapack_tau = argv[3];
  rblapack_c = argv[4];
  if (argc == 6) {
    rblapack_lwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  sormrq_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_sormrq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sormrq", rblapack_sormrq, -1);
}
ruby-lapack-1.7.2/ext/cla_syrpvgrw.c0000644000175000017500000001404612502221016017251 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real cla_syrpvgrw_(char* uplo, integer* n, integer* info, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, complex* work);


static VALUE
rblapack_cla_syrpvgrw(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack___out__;
  real __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  __out__ = NumRu::Lapack.cla_syrpvgrw( uplo, info, a, af, ipiv, work, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL FUNCTION CLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, WORK )\n\n*  Purpose\n*  =======\n* \n*  CLA_SYRPVGRW computes the reciprocal pivot growth factor\n*  norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n*  much less than 1, the stability of the LU factorization of the\n*  (equilibrated) matrix A could be poor. This also means that the\n*  solution X, estimated condition numbers, and error bounds could be\n*  unreliable.\n*\n\n*  Arguments\n*  =========\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     INFO    (input) INTEGER\n*     The value of INFO returned from CSYTRF, .i.e., the pivot in\n*     column INFO is exactly 0.\n*\n*     NCOLS   (input) INTEGER\n*     The number of columns of the matrix A. NCOLS >= 0.\n*\n*     A       (input) COMPLEX array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX array, dimension (LDAF,N)\n*     The block diagonal matrix D and the multipliers used to\n*     obtain the factor U or L as computed by CSYTRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     Details of the interchanges and the block structure of D\n*     as determined by CSYTRF.\n*\n*     WORK    (input) COMPLEX array, dimension (2*N)\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            NCOLS, I, J, K, KP\n      REAL               AMAX, UMAX, RPVGRW, TMP\n      LOGICAL            UPPER\n      COMPLEX            ZDUM\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, REAL, AIMAG, MAX, MIN\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           LSAME, CLASET\n      LOGICAL            LSAME\n*     ..\n*     .. Statement Functions ..\n      REAL               CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( ZDUM ) = ABS( REAL ( ZDUM ) ) + ABS( AIMAG ( ZDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.cla_syrpvgrw( uplo, info, a, af, ipiv, work, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_info = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_work = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  info = NUM2INT(rblapack_info);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (6th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
  if (NA_TYPE(rblapack_work) != NA_SCOMPLEX)
    rblapack_work = na_change_type(rblapack_work, NA_SCOMPLEX);
  work = NA_PTR_TYPE(rblapack_work, complex*);

  __out__ = cla_syrpvgrw_(&uplo, &n, &info, a, &lda, af, &ldaf, ipiv, work);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_cla_syrpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cla_syrpvgrw", rblapack_cla_syrpvgrw, -1);
}
ruby-lapack-1.7.2/ext/zlagtm.c0000644000175000017500000001517712502221025016033 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlagtm_(char* trans, integer* n, integer* nrhs, doublereal* alpha, doublecomplex* dl, doublecomplex* d, doublecomplex* du, doublecomplex* x, integer* ldx, doublereal* beta, doublecomplex* b, integer* ldb);


static VALUE
rblapack_zlagtm(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_alpha;
  doublereal alpha; 
  VALUE rblapack_dl;
  doublecomplex *dl; 
  VALUE rblapack_d;
  doublecomplex *d; 
  VALUE rblapack_du;
  doublecomplex *du; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_beta;
  doublereal beta; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer n;
  integer ldx;
  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  b = NumRu::Lapack.zlagtm( trans, alpha, dl, d, du, x, beta, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, B, LDB )\n\n*  Purpose\n*  =======\n*\n*  ZLAGTM performs a matrix-vector product of the form\n*\n*     B := alpha * A * X + beta * B\n*\n*  where A is a tridiagonal matrix of order N, B and X are N by NRHS\n*  matrices, and alpha and beta are real scalars, each of which may be\n*  0., 1., or -1.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the operation applied to A.\n*          = 'N':  No transpose, B := alpha * A * X + beta * B\n*          = 'T':  Transpose,    B := alpha * A**T * X + beta * B\n*          = 'C':  Conjugate transpose, B := alpha * A**H * X + beta * B\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices X and B.\n*\n*  ALPHA   (input) DOUBLE PRECISION\n*          The scalar alpha.  ALPHA must be 0., 1., or -1.; otherwise,\n*          it is assumed to be 0.\n*\n*  DL      (input) COMPLEX*16 array, dimension (N-1)\n*          The (n-1) sub-diagonal elements of T.\n*\n*  D       (input) COMPLEX*16 array, dimension (N)\n*          The diagonal elements of T.\n*\n*  DU      (input) COMPLEX*16 array, dimension (N-1)\n*          The (n-1) super-diagonal elements of T.\n*\n*  X       (input) COMPLEX*16 array, dimension (LDX,NRHS)\n*          The N by NRHS matrix X.\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(N,1).\n*\n*  BETA    (input) DOUBLE PRECISION\n*          The scalar beta.  BETA must be 0., 1., or -1.; otherwise,\n*          it is assumed to be 1.\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the N by NRHS matrix B.\n*          On exit, B is overwritten by the matrix expression\n*          B := alpha * A * X + beta * B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(N,1).\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  b = NumRu::Lapack.zlagtm( trans, alpha, dl, d, du, x, beta, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_trans = argv[0];
  rblapack_alpha = argv[1];
  rblapack_dl = argv[2];
  rblapack_d = argv[3];
  rblapack_du = argv[4];
  rblapack_x = argv[5];
  rblapack_beta = argv[6];
  rblapack_b = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DCOMPLEX)
    rblapack_d = na_change_type(rblapack_d, NA_DCOMPLEX);
  d = NA_PTR_TYPE(rblapack_d, doublecomplex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  alpha = NUM2DBL(rblapack_alpha);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (5th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_DCOMPLEX)
    rblapack_du = na_change_type(rblapack_du, NA_DCOMPLEX);
  du = NA_PTR_TYPE(rblapack_du, doublecomplex*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (3th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_DCOMPLEX)
    rblapack_dl = na_change_type(rblapack_dl, NA_DCOMPLEX);
  dl = NA_PTR_TYPE(rblapack_dl, doublecomplex*);
  beta = NUM2DBL(rblapack_beta);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zlagtm_(&trans, &n, &nrhs, &alpha, dl, d, du, x, &ldx, &beta, b, &ldb);

  return rblapack_b;
}

void
init_lapack_zlagtm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlagtm", rblapack_zlagtm, -1);
}
ruby-lapack-1.7.2/ext/spbequ.c0000644000175000017500000001137612502221016016031 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID spbequ_(char* uplo, integer* n, integer* kd, real* ab, integer* ldab, real* s, real* scond, real* amax, integer* info);


static VALUE
rblapack_spbequ(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_scond;
  real scond; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_info;
  integer info; 

  integer ldab;
  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  s, scond, amax, info = NumRu::Lapack.spbequ( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPBEQU computes row and column scalings intended to equilibrate a\n*  symmetric positive definite band matrix A and reduce its condition\n*  number (with respect to the two-norm).  S contains the scale factors,\n*  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n*  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This\n*  choice of S puts the condition number of B within a factor N of the\n*  smallest possible condition number over all possible diagonal\n*  scalings.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangular of A is stored;\n*          = 'L':  Lower triangular of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input) REAL array, dimension (LDAB,N)\n*          The upper or lower triangle of the symmetric band matrix A,\n*          stored in the first KD+1 rows of the array.  The j-th column\n*          of A is stored in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*  LDAB     (input) INTEGER\n*          The leading dimension of the array A.  LDAB >= KD+1.\n*\n*  S       (output) REAL array, dimension (N)\n*          If INFO = 0, S contains the scale factors for A.\n*\n*  SCOND   (output) REAL\n*          If INFO = 0, S contains the ratio of the smallest S(i) to\n*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too\n*          large nor too small, it is not worth scaling by S.\n*\n*  AMAX    (output) REAL\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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 is nonpositive.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, scond, amax, info = NumRu::Lapack.spbequ( uplo, kd, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  kd = NUM2INT(rblapack_kd);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, real*);

  spbequ_(&uplo, &n, &kd, ab, &ldab, s, &scond, &amax, &info);

  rblapack_scond = rb_float_new((double)scond);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
}

void
init_lapack_spbequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "spbequ", rblapack_spbequ, -1);
}
ruby-lapack-1.7.2/ext/slansy.c0000644000175000017500000001066612502221013016041 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real slansy_(char* norm, char* uplo, integer* n, real* a, integer* lda, real* work);


static VALUE
rblapack_slansy(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack___out__;
  real __out__; 
  real *work;

  integer lda;
  integer n;
  integer lwork;

  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  __out__ = NumRu::Lapack.slansy( norm, uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL             FUNCTION SLANSY( NORM, UPLO, N, A, LDA, WORK )\n\n*  Purpose\n*  =======\n*\n*  SLANSY  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  real symmetric matrix A.\n*\n*  Description\n*  ===========\n*\n*  SLANSY returns the value\n*\n*     SLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in SLANSY as described\n*          above.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is to be referenced.\n*          = 'U':  Upper triangular part of A is referenced\n*          = 'L':  Lower triangular part of A is referenced\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, SLANSY is\n*          set to zero.\n*\n*  A       (input) REAL array, dimension (LDA,N)\n*          The symmetric matrix A.  If UPLO = 'U', the leading n by n\n*          upper triangular part of A contains the upper triangular part\n*          of the matrix A, and the strictly lower triangular part of A\n*          is not referenced.  If UPLO = 'L', the leading n by n lower\n*          triangular part of A contains the lower triangular part of\n*          the matrix A, and the strictly upper triangular part of A is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(N,1).\n*\n*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n*          WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.slansy( norm, uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
  work = ALLOC_N(real, (MAX(1,lwork)));

  __out__ = slansy_(&norm, &uplo, &n, a, &lda, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_slansy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slansy", rblapack_slansy, -1);
}
ruby-lapack-1.7.2/ext/cgebal.c0000644000175000017500000001400212502221023015732 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgebal_(char* job, integer* n, complex* a, integer* lda, integer* ilo, integer* ihi, real* scale, integer* info);


static VALUE
rblapack_cgebal(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_scale;
  real *scale; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *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  ilo, ihi, scale, info, a = NumRu::Lapack.cgebal( job, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGEBAL balances a general complex matrix A.  This involves, first,\n*  permuting A by a similarity transformation to isolate eigenvalues\n*  in the first 1 to ILO-1 and last IHI+1 to N elements on the\n*  diagonal; and second, applying a diagonal similarity transformation\n*  to rows and columns ILO to IHI to make the rows and columns as\n*  close in norm as possible.  Both steps are optional.\n*\n*  Balancing may reduce the 1-norm of the matrix, and improve the\n*  accuracy of the computed eigenvalues and/or eigenvectors.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies the operations to be performed on A:\n*          = 'N':  none:  simply set ILO = 1, IHI = N, SCALE(I) = 1.0\n*                  for i = 1,...,N;\n*          = 'P':  permute only;\n*          = 'S':  scale only;\n*          = 'B':  both permute and scale.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the input matrix A.\n*          On exit,  A is overwritten by the balanced matrix.\n*          If JOB = 'N', A is not referenced.\n*          See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  ILO     (output) INTEGER\n*  IHI     (output) INTEGER\n*          ILO and IHI are set to integers such that on exit\n*          A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.\n*          If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n*\n*  SCALE   (output) REAL array, dimension (N)\n*          Details of the permutations and scaling factors applied to\n*          A.  If P(j) is the index of the row and column interchanged\n*          with row and column j and D(j) is the scaling factor\n*          applied to row and column j, then\n*          SCALE(j) = P(j)    for j = 1,...,ILO-1\n*                   = D(j)    for j = ILO,...,IHI\n*                   = P(j)    for j = IHI+1,...,N.\n*          The order in which the interchanges are made is N to IHI+1,\n*          then 1 to ILO-1.\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 permutations consist of row and column interchanges which put\n*  the matrix in the form\n*\n*             ( T1   X   Y  )\n*     P A P = (  0   B   Z  )\n*             (  0   0   T2 )\n*\n*  where T1 and T2 are upper triangular matrices whose eigenvalues lie\n*  along the diagonal.  The column indices ILO and IHI mark the starting\n*  and ending columns of the submatrix B. Balancing consists of applying\n*  a diagonal similarity transformation inv(D) * B * D to make the\n*  1-norms of each row of B and its corresponding column nearly equal.\n*  The output matrix is\n*\n*     ( T1     X*D          Y    )\n*     (  0  inv(D)*B*D  inv(D)*Z ).\n*     (  0      0           T2   )\n*\n*  Information about the permutations P and the diagonal matrix D is\n*  returned in the vector SCALE.\n*\n*  This subroutine is based on the EISPACK routine CBAL.\n*\n*  Modified by Tzu-Yi Chen, Computer Science Division, University of\n*    California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ilo, ihi, scale, info, a = NumRu::Lapack.cgebal( job, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_job = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  job = StringValueCStr(rblapack_job)[0];
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_scale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  scale = NA_PTR_TYPE(rblapack_scale, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  cgebal_(&job, &n, a, &lda, &ilo, &ihi, scale, &info);

  rblapack_ilo = INT2NUM(ilo);
  rblapack_ihi = INT2NUM(ihi);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_ilo, rblapack_ihi, rblapack_scale, rblapack_info, rblapack_a);
}

void
init_lapack_cgebal(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgebal", rblapack_cgebal, -1);
}
ruby-lapack-1.7.2/ext/stgevc.c0000644000175000017500000003241212502221021016013 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID stgevc_(char* side, char* howmny, logical* select, integer* n, real* s, integer* lds, real* p, integer* ldp, real* vl, integer* ldvl, real* vr, integer* ldvr, integer* mm, integer* m, real* work, integer* info);


static VALUE
rblapack_stgevc(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_howmny;
  char howmny; 
  VALUE rblapack_select;
  logical *select; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_p;
  real *p; 
  VALUE rblapack_vl;
  real *vl; 
  VALUE rblapack_vr;
  real *vr; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_vl_out__;
  real *vl_out__;
  VALUE rblapack_vr_out__;
  real *vr_out__;
  real *work;

  integer n;
  integer lds;
  integer ldp;
  integer ldvl;
  integer mm;
  integer ldvr;

  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  m, info, vl, vr = NumRu::Lapack.stgevc( side, howmny, select, s, p, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, LDVL, VR, LDVR, MM, M, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  STGEVC computes some or all of the right and/or left eigenvectors of\n*  a pair of real matrices (S,P), where S is a quasi-triangular matrix\n*  and P is upper triangular.  Matrix pairs of this type are produced by\n*  the generalized Schur factorization of a matrix pair (A,B):\n*\n*     A = Q*S*Z**T,  B = Q*P*Z**T\n*\n*  as computed by SGGHRD + SHGEQZ.\n*\n*  The right eigenvector x and the left eigenvector y of (S,P)\n*  corresponding to an eigenvalue w are defined by:\n*  \n*     S*x = w*P*x,  (y**H)*S = w*(y**H)*P,\n*  \n*  where y**H denotes the conjugate tranpose of y.\n*  The eigenvalues are not input to this routine, but are computed\n*  directly from the diagonal blocks of S and P.\n*  \n*  This routine returns the matrices X and/or Y of right and left\n*  eigenvectors of (S,P), or the products Z*X and/or Q*Y,\n*  where Z and Q are input matrices.\n*  If Q and Z are the orthogonal factors from the generalized Schur\n*  factorization of a matrix pair (A,B), then Z*X and Q*Y\n*  are the matrices of right and left eigenvectors of (A,B).\n* \n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'R': compute right eigenvectors only;\n*          = 'L': compute left eigenvectors only;\n*          = 'B': compute both right and left eigenvectors.\n*\n*  HOWMNY  (input) CHARACTER*1\n*          = 'A': compute all right and/or left eigenvectors;\n*          = 'B': compute all right and/or left eigenvectors,\n*                 backtransformed by the matrices in VR and/or VL;\n*          = 'S': compute selected right and/or left eigenvectors,\n*                 specified by the logical array SELECT.\n*\n*  SELECT  (input) LOGICAL array, dimension (N)\n*          If HOWMNY='S', SELECT specifies the eigenvectors to be\n*          computed.  If w(j) is a real eigenvalue, the corresponding\n*          real eigenvector is computed if SELECT(j) is .TRUE..\n*          If w(j) and w(j+1) are the real and imaginary parts of a\n*          complex eigenvalue, the corresponding complex eigenvector\n*          is computed if either SELECT(j) or SELECT(j+1) is .TRUE.,\n*          and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is\n*          set to .FALSE..\n*          Not referenced if HOWMNY = 'A' or 'B'.\n*\n*  N       (input) INTEGER\n*          The order of the matrices S and P.  N >= 0.\n*\n*  S       (input) REAL array, dimension (LDS,N)\n*          The upper quasi-triangular matrix S from a generalized Schur\n*          factorization, as computed by SHGEQZ.\n*\n*  LDS     (input) INTEGER\n*          The leading dimension of array S.  LDS >= max(1,N).\n*\n*  P       (input) REAL array, dimension (LDP,N)\n*          The upper triangular matrix P from a generalized Schur\n*          factorization, as computed by SHGEQZ.\n*          2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks\n*          of S must be in positive diagonal form.\n*\n*  LDP     (input) INTEGER\n*          The leading dimension of array P.  LDP >= max(1,N).\n*\n*  VL      (input/output) REAL array, dimension (LDVL,MM)\n*          On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n*          contain an N-by-N matrix Q (usually the orthogonal matrix Q\n*          of left Schur vectors returned by SHGEQZ).\n*          On exit, if SIDE = 'L' or 'B', VL contains:\n*          if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);\n*          if HOWMNY = 'B', the matrix Q*Y;\n*          if HOWMNY = 'S', the left eigenvectors of (S,P) specified by\n*                      SELECT, stored consecutively in the columns of\n*                      VL, in the same order as their eigenvalues.\n*\n*          A complex eigenvector corresponding to a complex eigenvalue\n*          is stored in two consecutive columns, the first holding the\n*          real part, and the second the imaginary part.\n*\n*          Not referenced if SIDE = 'R'.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of array VL.  LDVL >= 1, and if\n*          SIDE = 'L' or 'B', LDVL >= N.\n*\n*  VR      (input/output) REAL array, dimension (LDVR,MM)\n*          On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n*          contain an N-by-N matrix Z (usually the orthogonal matrix Z\n*          of right Schur vectors returned by SHGEQZ).\n*\n*          On exit, if SIDE = 'R' or 'B', VR contains:\n*          if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);\n*          if HOWMNY = 'B' or 'b', the matrix Z*X;\n*          if HOWMNY = 'S' or 's', the right eigenvectors of (S,P)\n*                      specified by SELECT, stored consecutively in the\n*                      columns of VR, in the same order as their\n*                      eigenvalues.\n*\n*          A complex eigenvector corresponding to a complex eigenvalue\n*          is stored in two consecutive columns, the first holding the\n*          real part and the second the imaginary part.\n*          \n*          Not referenced if SIDE = 'L'.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the array VR.  LDVR >= 1, and if\n*          SIDE = 'R' or 'B', LDVR >= N.\n*\n*  MM      (input) INTEGER\n*          The number of columns in the arrays VL and/or VR. MM >= M.\n*\n*  M       (output) INTEGER\n*          The number of columns in the arrays VL and/or VR actually\n*          used to store the eigenvectors.  If HOWMNY = 'A' or 'B', M\n*          is set to N.  Each selected real eigenvector occupies one\n*          column and each selected complex eigenvector occupies two\n*          columns.\n*\n*  WORK    (workspace) REAL array, dimension (6*N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit.\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          > 0:  the 2-by-2 block (INFO:INFO+1) does not have a complex\n*                eigenvalue.\n*\n\n*  Further Details\n*  ===============\n*\n*  Allocation of workspace:\n*  ---------- -- ---------\n*\n*     WORK( j ) = 1-norm of j-th column of A, above the diagonal\n*     WORK( N+j ) = 1-norm of j-th column of B, above the diagonal\n*     WORK( 2*N+1:3*N ) = real part of eigenvector\n*     WORK( 3*N+1:4*N ) = imaginary part of eigenvector\n*     WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector\n*     WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector\n*\n*  Rowwise vs. columnwise solution methods:\n*  ------- --  ---------- -------- -------\n*\n*  Finding a generalized eigenvector consists basically of solving the\n*  singular triangular system\n*\n*   (A - w B) x = 0     (for right) or:   (A - w B)**H y = 0  (for left)\n*\n*  Consider finding the i-th right eigenvector (assume all eigenvalues\n*  are real). The equation to be solved is:\n*       n                   i\n*  0 = sum  C(j,k) v(k)  = sum  C(j,k) v(k)     for j = i,. . .,1\n*      k=j                 k=j\n*\n*  where  C = (A - w B)  (The components v(i+1:n) are 0.)\n*\n*  The \"rowwise\" method is:\n*\n*  (1)  v(i) := 1\n*  for j = i-1,. . .,1:\n*                          i\n*      (2) compute  s = - sum C(j,k) v(k)   and\n*                        k=j+1\n*\n*      (3) v(j) := s / C(j,j)\n*\n*  Step 2 is sometimes called the \"dot product\" step, since it is an\n*  inner product between the j-th row and the portion of the eigenvector\n*  that has been computed so far.\n*\n*  The \"columnwise\" method consists basically in doing the sums\n*  for all the rows in parallel.  As each v(j) is computed, the\n*  contribution of v(j) times the j-th column of C is added to the\n*  partial sums.  Since FORTRAN arrays are stored columnwise, this has\n*  the advantage that at each step, the elements of C that are accessed\n*  are adjacent to one another, whereas with the rowwise method, the\n*  elements accessed at a step are spaced LDS (and LDP) words apart.\n*\n*  When finding left eigenvectors, the matrix in question is the\n*  transpose of the one in storage, so the rowwise method then\n*  actually accesses columns of A and B at each step, and so is the\n*  preferred method.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, info, vl, vr = NumRu::Lapack.stgevc( side, howmny, select, s, p, vl, vr, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_side = argv[0];
  rblapack_howmny = argv[1];
  rblapack_select = argv[2];
  rblapack_s = argv[3];
  rblapack_p = argv[4];
  rblapack_vl = argv[5];
  rblapack_vr = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_select))
    rb_raise(rb_eArgError, "select (3th argument) must be NArray");
  if (NA_RANK(rblapack_select) != 1)
    rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_select);
  if (NA_TYPE(rblapack_select) != NA_LINT)
    rblapack_select = na_change_type(rblapack_select, NA_LINT);
  select = NA_PTR_TYPE(rblapack_select, logical*);
  if (!NA_IsNArray(rblapack_p))
    rb_raise(rb_eArgError, "p (5th argument) must be NArray");
  if (NA_RANK(rblapack_p) != 2)
    rb_raise(rb_eArgError, "rank of p (5th argument) must be %d", 2);
  ldp = NA_SHAPE0(rblapack_p);
  if (NA_SHAPE1(rblapack_p) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of p must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_p) != NA_SFLOAT)
    rblapack_p = na_change_type(rblapack_p, NA_SFLOAT);
  p = NA_PTR_TYPE(rblapack_p, real*);
  if (!NA_IsNArray(rblapack_vr))
    rb_raise(rb_eArgError, "vr (7th argument) must be NArray");
  if (NA_RANK(rblapack_vr) != 2)
    rb_raise(rb_eArgError, "rank of vr (7th argument) must be %d", 2);
  ldvr = NA_SHAPE0(rblapack_vr);
  mm = NA_SHAPE1(rblapack_vr);
  if (NA_TYPE(rblapack_vr) != NA_SFLOAT)
    rblapack_vr = na_change_type(rblapack_vr, NA_SFLOAT);
  vr = NA_PTR_TYPE(rblapack_vr, real*);
  howmny = StringValueCStr(rblapack_howmny)[0];
  if (!NA_IsNArray(rblapack_vl))
    rb_raise(rb_eArgError, "vl (6th argument) must be NArray");
  if (NA_RANK(rblapack_vl) != 2)
    rb_raise(rb_eArgError, "rank of vl (6th argument) must be %d", 2);
  ldvl = NA_SHAPE0(rblapack_vl);
  if (NA_SHAPE1(rblapack_vl) != mm)
    rb_raise(rb_eRuntimeError, "shape 1 of vl must be the same as shape 1 of vr");
  if (NA_TYPE(rblapack_vl) != NA_SFLOAT)
    rblapack_vl = na_change_type(rblapack_vl, NA_SFLOAT);
  vl = NA_PTR_TYPE(rblapack_vl, real*);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (4th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 2)
    rb_raise(rb_eArgError, "rank of s (4th argument) must be %d", 2);
  lds = NA_SHAPE0(rblapack_s);
  if (NA_SHAPE1(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of s must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = mm;
    rblapack_vl_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, real*);
  MEMCPY(vl_out__, vl, real, NA_TOTAL(rblapack_vl));
  rblapack_vl = rblapack_vl_out__;
  vl = vl_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = mm;
    rblapack_vr_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vr_out__ = NA_PTR_TYPE(rblapack_vr_out__, real*);
  MEMCPY(vr_out__, vr, real, NA_TOTAL(rblapack_vr));
  rblapack_vr = rblapack_vr_out__;
  vr = vr_out__;
  work = ALLOC_N(real, (6*n));

  stgevc_(&side, &howmny, select, &n, s, &lds, p, &ldp, vl, &ldvl, vr, &ldvr, &mm, &m, work, &info);

  free(work);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_m, rblapack_info, rblapack_vl, rblapack_vr);
}

void
init_lapack_stgevc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "stgevc", rblapack_stgevc, -1);
}
ruby-lapack-1.7.2/ext/dormrq.c0000644000175000017500000001620712502221017016035 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dormrq_(char* side, char* trans, integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* c, integer* ldc, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dormrq(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublereal *c_out__;

  integer lda;
  integer m;
  integer k;
  integer ldc;
  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  work, info, c = NumRu::Lapack.dormrq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DORMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DORMRQ overwrites the general real M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'T':      Q**T * C       C * Q**T\n*\n*  where Q is a real orthogonal matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(1) H(2) . . . H(k)\n*\n*  as returned by DGERQF. Q is of order M if SIDE = 'L' and of order N\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**T from the Left;\n*          = 'R': apply Q or Q**T from the Right.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'T':  Transpose, apply Q**T.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension\n*                               (LDA,M) if SIDE = 'L',\n*                               (LDA,N) if SIDE = 'R'\n*          The i-th row must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          DGERQF in the last k rows of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,K).\n*\n*  TAU     (input) DOUBLE PRECISION array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by DGERQF.\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M).\n*          For optimum performance LWORK >= N*NB if SIDE = 'L', and\n*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n*          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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.dormrq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_a = argv[2];
  rblapack_tau = argv[3];
  rblapack_c = argv[4];
  if (argc == 6) {
    rblapack_lwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = 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*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  dormrq_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_dormrq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dormrq", rblapack_dormrq, -1);
}
ruby-lapack-1.7.2/ext/chbgvx.c0000644000175000017500000003066712502221024016016 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chbgvx_(char* jobz, char* range, char* uplo, integer* n, integer* ka, integer* kb, complex* ab, integer* ldab, complex* bb, integer* ldbb, complex* q, integer* ldq, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, complex* z, integer* ldz, complex* work, real* rwork, integer* iwork, integer* ifail, integer* info);


static VALUE
rblapack_chbgvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ka;
  integer ka; 
  VALUE rblapack_kb;
  integer kb; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_bb;
  complex *bb; 
  VALUE rblapack_vl;
  real vl; 
  VALUE rblapack_vu;
  real vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  real abstol; 
  VALUE rblapack_q;
  complex *q; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_ifail;
  integer *ifail; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  complex *ab_out__;
  VALUE rblapack_bb_out__;
  complex *bb_out__;
  complex *work;
  real *rwork;
  integer *iwork;

  integer ldab;
  integer n;
  integer ldbb;
  integer ldq;
  integer ldz;

  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  q, m, w, z, ifail, info, ab, bb = NumRu::Lapack.chbgvx( jobz, range, uplo, ka, kb, ab, bb, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHBGVX computes all the eigenvalues, and optionally, the eigenvectors\n*  of a complex generalized Hermitian-definite banded eigenproblem, of\n*  the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian\n*  and banded, and B is also positive definite.  Eigenvalues and\n*  eigenvectors can be selected by specifying either all eigenvalues,\n*  a range of values or a range of indices for the desired eigenvalues.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found;\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found;\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  KA      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n*  KB      (input) INTEGER\n*          The number of superdiagonals of the matrix B if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n*  AB      (input/output) COMPLEX array, dimension (LDAB, N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix A, stored in the first ka+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).\n*\n*          On exit, the contents of AB are destroyed.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KA+1.\n*\n*  BB      (input/output) COMPLEX array, dimension (LDBB, N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix B, stored in the first kb+1 rows of the array.  The\n*          j-th column of B is stored in the j-th column of the array BB\n*          as follows:\n*          if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n*          if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb).\n*\n*          On exit, the factor S from the split Cholesky factorization\n*          B = S**H*S, as returned by CPBSTF.\n*\n*  LDBB    (input) INTEGER\n*          The leading dimension of the array BB.  LDBB >= KB+1.\n*\n*  Q       (output) COMPLEX array, dimension (LDQ, N)\n*          If JOBZ = 'V', the n-by-n matrix used in the reduction of\n*          A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x,\n*          and consequently C to tridiagonal form.\n*          If JOBZ = 'N', the array Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.  If JOBZ = 'N',\n*          LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N).\n*\n*  VL      (input) REAL\n*  VU      (input) REAL\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) REAL\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less than\n*          or equal to zero, then  EPS*|T|  will be used in its place,\n*          where |T| is the 1-norm of the tridiagonal matrix obtained\n*          by reducing AP to tridiagonal form.\n*\n*          Eigenvalues will be computed most accurately when ABSTOL is\n*          set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n*          If this routine returns with INFO>0, indicating that some\n*          eigenvectors did not converge, try setting ABSTOL to\n*          2*SLAMCH('S').\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) REAL array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) COMPLEX array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n*          eigenvectors, with the i-th column of Z holding the\n*          eigenvector associated with W(i). The eigenvectors are\n*          normalized so that Z**H*B*Z = I.\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= N.\n*\n*  WORK    (workspace) COMPLEX array, dimension (N)\n*\n*  RWORK   (workspace) REAL array, dimension (7*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (5*N)\n*\n*  IFAIL   (output) INTEGER array, dimension (N)\n*          If JOBZ = 'V', then if INFO = 0, the first M elements of\n*          IFAIL are zero.  If INFO > 0, then IFAIL contains the\n*          indices of the eigenvectors that failed to converge.\n*          If JOBZ = 'N', then IFAIL is not referenced.\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, and i is:\n*             <= N:  then i eigenvectors failed to converge.  Their\n*                    indices are stored in array IFAIL.\n*             > N:   if INFO = N + i, for 1 <= i <= N, then CPBSTF\n*                    returned INFO = i: B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  q, m, w, z, ifail, info, ab, bb = NumRu::Lapack.chbgvx( jobz, range, uplo, ka, kb, ab, bb, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_uplo = argv[2];
  rblapack_ka = argv[3];
  rblapack_kb = argv[4];
  rblapack_ab = argv[5];
  rblapack_bb = argv[6];
  rblapack_vl = argv[7];
  rblapack_vu = argv[8];
  rblapack_il = argv[9];
  rblapack_iu = argv[10];
  rblapack_abstol = argv[11];
  if (argc == 12) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  kb = NUM2INT(rblapack_kb);
  if (!NA_IsNArray(rblapack_bb))
    rb_raise(rb_eArgError, "bb (7th argument) must be NArray");
  if (NA_RANK(rblapack_bb) != 2)
    rb_raise(rb_eArgError, "rank of bb (7th argument) must be %d", 2);
  ldbb = NA_SHAPE0(rblapack_bb);
  n = NA_SHAPE1(rblapack_bb);
  if (NA_TYPE(rblapack_bb) != NA_SCOMPLEX)
    rblapack_bb = na_change_type(rblapack_bb, NA_SCOMPLEX);
  bb = NA_PTR_TYPE(rblapack_bb, complex*);
  vu = (real)NUM2DBL(rblapack_vu);
  iu = NUM2INT(rblapack_iu);
  range = StringValueCStr(rblapack_range)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (6th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (6th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of bb");
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  il = NUM2INT(rblapack_il);
  ldz = lsame_(&jobz,"V") ? n : 1;
  ka = NUM2INT(rblapack_ka);
  abstol = (real)NUM2DBL(rblapack_abstol);
  vl = (real)NUM2DBL(rblapack_vl);
  ldq = 1 ? jobz = 'n' : MAX(1,n) ? jobz = 'v' : 0;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  q = NA_PTR_TYPE(rblapack_q, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
  MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldbb;
    shape[1] = n;
    rblapack_bb_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  bb_out__ = NA_PTR_TYPE(rblapack_bb_out__, complex*);
  MEMCPY(bb_out__, bb, complex, NA_TOTAL(rblapack_bb));
  rblapack_bb = rblapack_bb_out__;
  bb = bb_out__;
  work = ALLOC_N(complex, (n));
  rwork = ALLOC_N(real, (7*n));
  iwork = ALLOC_N(integer, (5*n));

  chbgvx_(&jobz, &range, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, q, &ldq, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, rwork, iwork, ifail, &info);

  free(work);
  free(rwork);
  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_q, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_ab, rblapack_bb);
}

void
init_lapack_chbgvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chbgvx", rblapack_chbgvx, -1);
}
ruby-lapack-1.7.2/ext/chgeqz.c0000644000175000017500000003372212502221024016011 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chgeqz_(char* job, char* compq, char* compz, integer* n, integer* ilo, integer* ihi, complex* h, integer* ldh, complex* t, integer* ldt, complex* alpha, complex* beta, complex* q, integer* ldq, complex* z, integer* ldz, complex* work, integer* lwork, real* rwork, integer* info);


static VALUE
rblapack_chgeqz(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_compq;
  char compq; 
  VALUE rblapack_compz;
  char compz; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_h;
  complex *h; 
  VALUE rblapack_t;
  complex *t; 
  VALUE rblapack_q;
  complex *q; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_alpha;
  complex *alpha; 
  VALUE rblapack_beta;
  complex *beta; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_h_out__;
  complex *h_out__;
  VALUE rblapack_t_out__;
  complex *t_out__;
  VALUE rblapack_q_out__;
  complex *q_out__;
  VALUE rblapack_z_out__;
  complex *z_out__;
  real *rwork;

  integer ldh;
  integer n;
  integer ldt;
  integer ldq;
  integer ldz;

  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  alpha, beta, work, info, h, t, q, z = NumRu::Lapack.chgeqz( job, compq, compz, ilo, ihi, h, t, q, z, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHGEQZ computes the eigenvalues of a complex matrix pair (H,T),\n*  where H is an upper Hessenberg matrix and T is upper triangular,\n*  using the single-shift QZ method.\n*  Matrix pairs of this type are produced by the reduction to\n*  generalized upper Hessenberg form of a complex matrix pair (A,B):\n*  \n*     A = Q1*H*Z1**H,  B = Q1*T*Z1**H,\n*  \n*  as computed by CGGHRD.\n*  \n*  If JOB='S', then the Hessenberg-triangular pair (H,T) is\n*  also reduced to generalized Schur form,\n*  \n*     H = Q*S*Z**H,  T = Q*P*Z**H,\n*  \n*  where Q and Z are unitary matrices and S and P are upper triangular.\n*  \n*  Optionally, the unitary matrix Q from the generalized Schur\n*  factorization may be postmultiplied into an input matrix Q1, and the\n*  unitary matrix Z may be postmultiplied into an input matrix Z1.\n*  If Q1 and Z1 are the unitary matrices from CGGHRD that reduced\n*  the matrix pair (A,B) to generalized Hessenberg form, then the output\n*  matrices Q1*Q and Z1*Z are the unitary factors from the generalized\n*  Schur factorization of (A,B):\n*  \n*     A = (Q1*Q)*S*(Z1*Z)**H,  B = (Q1*Q)*P*(Z1*Z)**H.\n*  \n*  To avoid overflow, eigenvalues of the matrix pair (H,T)\n*  (equivalently, of (A,B)) are computed as a pair of complex values\n*  (alpha,beta).  If beta is nonzero, lambda = alpha / beta is an\n*  eigenvalue of the generalized nonsymmetric eigenvalue problem (GNEP)\n*     A*x = lambda*B*x\n*  and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the\n*  alternate form of the GNEP\n*     mu*A*y = B*y.\n*  The values of alpha and beta for the i-th eigenvalue can be read\n*  directly from the generalized Schur form:  alpha = S(i,i),\n*  beta = P(i,i).\n*\n*  Ref: C.B. Moler & G.W. Stewart, \"An Algorithm for Generalized Matrix\n*       Eigenvalue Problems\", SIAM J. Numer. Anal., 10(1973),\n*       pp. 241--256.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          = 'E': Compute eigenvalues only;\n*          = 'S': Computer eigenvalues and the Schur form.\n*\n*  COMPQ   (input) CHARACTER*1\n*          = 'N': Left Schur vectors (Q) are not computed;\n*          = 'I': Q is initialized to the unit matrix and the matrix Q\n*                 of left Schur vectors of (H,T) is returned;\n*          = 'V': Q must contain a unitary matrix Q1 on entry and\n*                 the product Q1*Q is returned.\n*\n*  COMPZ   (input) CHARACTER*1\n*          = 'N': Right Schur vectors (Z) are not computed;\n*          = 'I': Q is initialized to the unit matrix and the matrix Z\n*                 of right Schur vectors of (H,T) is returned;\n*          = 'V': Z must contain a unitary matrix Z1 on entry and\n*                 the product Z1*Z is returned.\n*\n*  N       (input) INTEGER\n*          The order of the matrices H, T, Q, and Z.  N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          ILO and IHI mark the rows and columns of H which are in\n*          Hessenberg form.  It is assumed that A is already upper\n*          triangular in rows and columns 1:ILO-1 and IHI+1:N.\n*          If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.\n*\n*  H       (input/output) COMPLEX array, dimension (LDH, N)\n*          On entry, the N-by-N upper Hessenberg matrix H.\n*          On exit, if JOB = 'S', H contains the upper triangular\n*          matrix S from the generalized Schur factorization.\n*          If JOB = 'E', the diagonal of H matches that of S, but\n*          the rest of H is unspecified.\n*\n*  LDH     (input) INTEGER\n*          The leading dimension of the array H.  LDH >= max( 1, N ).\n*\n*  T       (input/output) COMPLEX array, dimension (LDT, N)\n*          On entry, the N-by-N upper triangular matrix T.\n*          On exit, if JOB = 'S', T contains the upper triangular\n*          matrix P from the generalized Schur factorization.\n*          If JOB = 'E', the diagonal of T matches that of P, but\n*          the rest of T is unspecified.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T.  LDT >= max( 1, N ).\n*\n*  ALPHA   (output) COMPLEX array, dimension (N)\n*          The complex scalars alpha that define the eigenvalues of\n*          GNEP.  ALPHA(i) = S(i,i) in the generalized Schur\n*          factorization.\n*\n*  BETA    (output) COMPLEX array, dimension (N)\n*          The real non-negative scalars beta that define the\n*          eigenvalues of GNEP.  BETA(i) = P(i,i) in the generalized\n*          Schur factorization.\n*\n*          Together, the quantities alpha = ALPHA(j) and beta = BETA(j)\n*          represent the j-th eigenvalue of the matrix pair (A,B), in\n*          one of the forms lambda = alpha/beta or mu = beta/alpha.\n*          Since either lambda or mu may overflow, they should not,\n*          in general, be computed.\n*\n*  Q       (input/output) COMPLEX array, dimension (LDQ, N)\n*          On entry, if COMPZ = 'V', the unitary matrix Q1 used in the\n*          reduction of (A,B) to generalized Hessenberg form.\n*          On exit, if COMPZ = 'I', the unitary matrix of left Schur\n*          vectors of (H,T), and if COMPZ = 'V', the unitary matrix of\n*          left Schur vectors of (A,B).\n*          Not referenced if COMPZ = 'N'.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.  LDQ >= 1.\n*          If COMPQ='V' or 'I', then LDQ >= N.\n*\n*  Z       (input/output) COMPLEX array, dimension (LDZ, N)\n*          On entry, if COMPZ = 'V', the unitary matrix Z1 used in the\n*          reduction of (A,B) to generalized Hessenberg form.\n*          On exit, if COMPZ = 'I', the unitary matrix of right Schur\n*          vectors of (H,T), and if COMPZ = 'V', the unitary matrix of\n*          right Schur vectors of (A,B).\n*          Not referenced if COMPZ = 'N'.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1.\n*          If COMPZ='V' or 'I', then LDZ >= N.\n*\n*  WORK    (workspace/output) COMPLEX 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,N).\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*  RWORK   (workspace) REAL array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -i, the i-th argument had an illegal value\n*          = 1,...,N: the QZ iteration did not converge.  (H,T) is not\n*                     in Schur form, but ALPHA(i) and BETA(i),\n*                     i=INFO+1,...,N should be correct.\n*          = N+1,...,2*N: the shift calculation failed.  (H,T) is not\n*                     in Schur form, but ALPHA(i) and BETA(i),\n*                     i=INFO-N+1,...,N should be correct.\n*\n\n*  Further Details\n*  ===============\n*\n*  We assume that complex ABS works as long as its value is less than\n*  overflow.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  alpha, beta, work, info, h, t, q, z = NumRu::Lapack.chgeqz( job, compq, compz, ilo, ihi, h, t, q, z, [: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_job = argv[0];
  rblapack_compq = argv[1];
  rblapack_compz = argv[2];
  rblapack_ilo = argv[3];
  rblapack_ihi = argv[4];
  rblapack_h = argv[5];
  rblapack_t = argv[6];
  rblapack_q = argv[7];
  rblapack_z = 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;
  }

  job = StringValueCStr(rblapack_job)[0];
  compz = StringValueCStr(rblapack_compz)[0];
  ihi = NUM2INT(rblapack_ihi);
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (7th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (7th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  n = NA_SHAPE1(rblapack_t);
  if (NA_TYPE(rblapack_t) != NA_SCOMPLEX)
    rblapack_t = na_change_type(rblapack_t, NA_SCOMPLEX);
  t = NA_PTR_TYPE(rblapack_t, complex*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (9th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  if (NA_SHAPE1(rblapack_z) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of t");
  if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, complex*);
  compq = StringValueCStr(rblapack_compq)[0];
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (6th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  if (NA_SHAPE1(rblapack_h) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of t");
  if (NA_TYPE(rblapack_h) != NA_SCOMPLEX)
    rblapack_h = na_change_type(rblapack_h, NA_SCOMPLEX);
  h = NA_PTR_TYPE(rblapack_h, complex*);
  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (8th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (8th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of t");
  if (NA_TYPE(rblapack_q) != NA_SCOMPLEX)
    rblapack_q = na_change_type(rblapack_q, NA_SCOMPLEX);
  q = NA_PTR_TYPE(rblapack_q, complex*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  alpha = NA_PTR_TYPE(rblapack_alpha, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, complex*);
  MEMCPY(h_out__, h, complex, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = n;
    rblapack_t_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  t_out__ = NA_PTR_TYPE(rblapack_t_out__, complex*);
  MEMCPY(t_out__, t, complex, NA_TOTAL(rblapack_t));
  rblapack_t = rblapack_t_out__;
  t = t_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, complex*);
  MEMCPY(q_out__, q, complex, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
  MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  rwork = ALLOC_N(real, (n));

  chgeqz_(&job, &compq, &compz, &n, &ilo, &ihi, h, &ldh, t, &ldt, alpha, beta, q, &ldq, z, &ldz, work, &lwork, rwork, &info);

  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_alpha, rblapack_beta, rblapack_work, rblapack_info, rblapack_h, rblapack_t, rblapack_q, rblapack_z);
}

void
init_lapack_chgeqz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chgeqz", rblapack_chgeqz, -1);
}
ruby-lapack-1.7.2/ext/zpocon.c0000644000175000017500000001000512502221013016023 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zpocon_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublereal* anorm, doublereal* rcond, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zpocon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_anorm;
  doublereal anorm; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_info;
  integer info; 
  doublecomplex *work;
  doublereal *rwork;

  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  rcond, info = NumRu::Lapack.zpocon( uplo, a, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPOCON estimates the reciprocal of the condition number (in the\n*  1-norm) of a complex Hermitian positive definite matrix using the\n*  Cholesky factorization A = U**H*U or A = L*L**H computed by ZPOTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**H*U or A = L*L**H, as computed by ZPOTRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  ANORM   (input) DOUBLE PRECISION\n*          The 1-norm (or infinity-norm) of the Hermitian matrix A.\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n*          estimate of the 1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.zpocon( uplo, a, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_anorm = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  anorm = NUM2DBL(rblapack_anorm);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (n));

  zpocon_(&uplo, &n, a, &lda, &anorm, &rcond, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_zpocon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zpocon", rblapack_zpocon, -1);
}
ruby-lapack-1.7.2/ext/slascl.c0000644000175000017500000001216012502221021015777 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slascl_(char* type, integer* kl, integer* ku, real* cfrom, real* cto, integer* m, integer* n, real* a, integer* lda, integer* info);


static VALUE
rblapack_slascl(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_type;
  char type; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_cfrom;
  real cfrom; 
  VALUE rblapack_cto;
  real cto; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *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  info, a = NumRu::Lapack.slascl( type, kl, ku, cfrom, cto, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLASCL multiplies the M by N real matrix A by the real scalar\n*  CTO/CFROM.  This is done without over/underflow as long as the final\n*  result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that\n*  A may be full, upper triangular, lower triangular, upper Hessenberg,\n*  or banded.\n*\n\n*  Arguments\n*  =========\n*\n*  TYPE    (input) CHARACTER*1\n*          TYPE indices the storage type of the input matrix.\n*          = 'G':  A is a full matrix.\n*          = 'L':  A is a lower triangular matrix.\n*          = 'U':  A is an upper triangular matrix.\n*          = 'H':  A is an upper Hessenberg matrix.\n*          = 'B':  A is a symmetric band matrix with lower bandwidth KL\n*                  and upper bandwidth KU and with the only the lower\n*                  half stored.\n*          = 'Q':  A is a symmetric band matrix with lower bandwidth KL\n*                  and upper bandwidth KU and with the only the upper\n*                  half stored.\n*          = 'Z':  A is a band matrix with lower bandwidth KL and upper\n*                  bandwidth KU. See SGBTRF for storage details.\n*\n*  KL      (input) INTEGER\n*          The lower bandwidth of A.  Referenced only if TYPE = 'B',\n*          'Q' or 'Z'.\n*\n*  KU      (input) INTEGER\n*          The upper bandwidth of A.  Referenced only if TYPE = 'B',\n*          'Q' or 'Z'.\n*\n*  CFROM   (input) REAL\n*  CTO     (input) REAL\n*          The matrix A is multiplied by CTO/CFROM. A(I,J) is computed\n*          without over/underflow if the final result CTO*A(I,J)/CFROM\n*          can be represented without over/underflow.  CFROM must be\n*          nonzero.\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) REAL array, dimension (LDA,N)\n*          The matrix to be multiplied by CTO/CFROM.  See TYPE for the\n*          storage type.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.slascl( type, kl, ku, cfrom, cto, m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_type = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_cfrom = argv[3];
  rblapack_cto = argv[4];
  rblapack_m = argv[5];
  rblapack_a = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  type = StringValueCStr(rblapack_type)[0];
  ku = NUM2INT(rblapack_ku);
  cto = (real)NUM2DBL(rblapack_cto);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (7th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (7th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  kl = NUM2INT(rblapack_kl);
  m = NUM2INT(rblapack_m);
  cfrom = (real)NUM2DBL(rblapack_cfrom);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  slascl_(&type, &kl, &ku, &cfrom, &cto, &m, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_slascl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slascl", rblapack_slascl, -1);
}
ruby-lapack-1.7.2/ext/dspevd.c0000644000175000017500000002105412502221024016010 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dspevd_(char* jobz, char* uplo, integer* n, doublereal* ap, doublereal* w, doublereal* z, integer* ldz, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_dspevd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublereal *ap_out__;

  integer ldap;
  integer n;
  integer ldz;

  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  w, z, work, iwork, info, ap = NumRu::Lapack.dspevd( jobz, uplo, ap, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSPEVD computes all the eigenvalues and, optionally, eigenvectors\n*  of a real symmetric matrix A in packed storage. If eigenvectors are\n*  desired, it uses a divide and conquer algorithm.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, AP is overwritten by values generated during the\n*          reduction to tridiagonal form.  If UPLO = 'U', the diagonal\n*          and first superdiagonal of the tridiagonal matrix T overwrite\n*          the corresponding elements of A, and if UPLO = 'L', the\n*          diagonal and first subdiagonal of T overwrite the\n*          corresponding elements of A.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n*          eigenvectors of the matrix A, with the i-th column of Z\n*          holding the eigenvector associated with W(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace/output) DOUBLE PRECISION array,\n*                                         dimension (LWORK)\n*          On exit, if INFO = 0, WORK(1) returns the required LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK.\n*          If N <= 1,               LWORK must be at least 1.\n*          If JOBZ = 'N' and N > 1, LWORK must be at least 2*N.\n*          If JOBZ = 'V' and N > 1, LWORK must be at least\n*                                                 1 + 6*N + N**2.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the required sizes of the WORK and IWORK\n*          arrays, returns these values as the first entries of the WORK\n*          and IWORK arrays, and no error message related to LWORK or\n*          LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.\n*          If JOBZ  = 'N' or N <= 1, LIWORK must be at least 1.\n*          If JOBZ  = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the required sizes of the WORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK and IWORK arrays, and no error message related to\n*          LWORK or LIWORK 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 algorithm failed to converge; i\n*                off-diagonal elements of an intermediate tridiagonal\n*                form did not converge to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, work, iwork, info, ap = NumRu::Lapack.dspevd( jobz, uplo, ap, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_ap = argv[2];
  if (argc == 5) {
    rblapack_lwork = argv[3];
    rblapack_liwork = argv[4];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (rblapack_liwork == Qnil)
    liwork = (lsame_(&jobz,"N")||n<=1) ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  if (rblapack_lwork == Qnil)
    lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 2*n : lsame_(&jobz,"V") ? 1+6*n+n*n : 2;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
  MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  dspevd_(&jobz, &uplo, &n, ap, w, z, &ldz, work, &lwork, iwork, &liwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_w, rblapack_z, rblapack_work, rblapack_iwork, rblapack_info, rblapack_ap);
}

void
init_lapack_dspevd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dspevd", rblapack_dspevd, -1);
}
ruby-lapack-1.7.2/ext/sgetrf.c0000644000175000017500000001011612502221026016014 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgetrf_(integer* m, integer* n, real* a, integer* lda, integer* ipiv, integer* info);


static VALUE
rblapack_sgetrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *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  ipiv, info, a = NumRu::Lapack.sgetrf( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGETRF( M, N, A, LDA, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGETRF computes an LU factorization of a general M-by-N matrix A\n*  using partial pivoting with row interchanges.\n*\n*  The factorization has the form\n*     A = P * L * U\n*  where P is a permutation matrix, L is lower triangular with unit\n*  diagonal elements (lower trapezoidal if m > n), and U is upper\n*  triangular (upper trapezoidal if m < n).\n*\n*  This is the right-looking Level 3 BLAS version of the algorithm.\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) REAL array, dimension (LDA,N)\n*          On entry, the M-by-N matrix to be factored.\n*          On exit, the factors L and U from the factorization\n*          A = P*L*U; the unit diagonal elements of L are not stored.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  IPIV    (output) INTEGER array, dimension (min(M,N))\n*          The pivot indices; for 1 <= i <= min(M,N), row i of the\n*          matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n*                has been completed, but the factor U is exactly\n*                singular, and division by zero will occur if it is used\n*                to solve a system of equations.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, a = NumRu::Lapack.sgetrf( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  sgetrf_(&m, &n, a, &lda, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_a);
}

void
init_lapack_sgetrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgetrf", rblapack_sgetrf, -1);
}
ruby-lapack-1.7.2/ext/dporfs.c0000644000175000017500000002011112502221025016012 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dporfs_(char* uplo, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* af, integer* ldaf, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dporfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_af;
  doublereal *af; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  doublereal *x_out__;
  doublereal *work;
  integer *iwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.dporfs( uplo, a, af, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPORFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is symmetric positive definite,\n*  and provides error bounds and backward error estimates for the\n*  solution.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*          The symmetric matrix A.  If UPLO = 'U', the leading N-by-N\n*          upper triangular part of A contains the upper triangular part\n*          of the matrix A, and the strictly lower triangular part of A\n*          is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*          triangular part of A contains the lower triangular part of\n*          the matrix A, and the strictly upper triangular part of A is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AF      (input) DOUBLE PRECISION array, dimension (LDAF,N)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**T*U or A = L*L**T, as computed by DPOTRF.\n*\n*  LDAF    (input) INTEGER\n*          The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by DPOTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.dporfs( uplo, a, af, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_b = argv[3];
  rblapack_x = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_DFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
  af = NA_PTR_TYPE(rblapack_af, doublereal*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (5th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(doublereal, (3*n));
  iwork = ALLOC_N(integer, (n));

  dporfs_(&uplo, &n, &nrhs, a, &lda, af, &ldaf, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_dporfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dporfs", rblapack_dporfs, -1);
}
ruby-lapack-1.7.2/ext/slaswp.c0000644000175000017500000001067012502221012016033 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaswp_(integer* n, real* a, integer* lda, integer* k1, integer* k2, integer* ipiv, integer* incx);


static VALUE
rblapack_slaswp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_k1;
  integer k1; 
  VALUE rblapack_k2;
  integer k2; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_a_out__;
  real *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  a = NumRu::Lapack.slaswp( a, k1, k2, ipiv, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASWP( N, A, LDA, K1, K2, IPIV, INCX )\n\n*  Purpose\n*  =======\n*\n*  SLASWP performs a series of row interchanges on the matrix A.\n*  One row interchange is initiated for each of rows K1 through K2 of A.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the matrix of column dimension N to which the row\n*          interchanges will be applied.\n*          On exit, the permuted matrix.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*\n*  K1      (input) INTEGER\n*          The first element of IPIV for which a row interchange will\n*          be done.\n*\n*  K2      (input) INTEGER\n*          The last element of IPIV for which a row interchange will\n*          be done.\n*\n*  IPIV    (input) INTEGER array, dimension (K2*abs(INCX))\n*          The vector of pivot indices.  Only the elements in positions\n*          K1 through K2 of IPIV are accessed.\n*          IPIV(K) = L implies rows K and L are to be interchanged.\n*\n*  INCX    (input) INTEGER\n*          The increment between successive values of IPIV.  If IPIV\n*          is negative, the pivots are applied in reverse order.\n*\n\n*  Further Details\n*  ===============\n*\n*  Modified by\n*   R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, I1, I2, INC, IP, IX, IX0, J, K, N32\n      REAL               TEMP\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  a = NumRu::Lapack.slaswp( a, k1, k2, ipiv, incx, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_a = argv[0];
  rblapack_k1 = argv[1];
  rblapack_k2 = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_incx = argv[4];
  if (argc == 5) {
  } 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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  k2 = NUM2INT(rblapack_k2);
  incx = NUM2INT(rblapack_incx);
  k1 = NUM2INT(rblapack_k1);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != (k2*abs(incx)))
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be %d", k2*abs(incx));
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  slaswp_(&n, a, &lda, &k1, &k2, ipiv, &incx);

  return rblapack_a;
}

void
init_lapack_slaswp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaswp", rblapack_slaswp, -1);
}
ruby-lapack-1.7.2/ext/sorml2.c0000644000175000017500000001375012502221014015744 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sorml2_(char* side, char* trans, integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* c, integer* ldc, real* work, integer* info);


static VALUE
rblapack_sorml2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  real *c_out__;
  real *work;

  integer lda;
  integer m;
  integer k;
  integer ldc;
  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  info, c = NumRu::Lapack.sorml2( side, trans, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SORML2 overwrites the general real m by n matrix C with\n*\n*        Q * C  if SIDE = 'L' and TRANS = 'N', or\n*\n*        Q'* C  if SIDE = 'L' and TRANS = 'T', or\n*\n*        C * Q  if SIDE = 'R' and TRANS = 'N', or\n*\n*        C * Q' if SIDE = 'R' and TRANS = 'T',\n*\n*  where Q is a real orthogonal matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(k) . . . H(2) H(1)\n*\n*  as returned by SGELQF. Q is of order m if SIDE = 'L' and of order n\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q' from the Left\n*          = 'R': apply Q or Q' from the Right\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': apply Q  (No transpose)\n*          = 'T': apply Q' (Transpose)\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) REAL array, dimension\n*                               (LDA,M) if SIDE = 'L',\n*                               (LDA,N) if SIDE = 'R'\n*          The i-th row must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          SGELQF in the first k rows of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,K).\n*\n*  TAU     (input) REAL array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by SGELQF.\n*\n*  C       (input/output) REAL array, dimension (LDC,N)\n*          On entry, the m by n matrix C.\n*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) REAL array, dimension\n*                                   (N) if SIDE = 'L',\n*                                   (M) if SIDE = 'R'\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, c = NumRu::Lapack.sorml2( side, trans, a, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_a = argv[2];
  rblapack_tau = argv[3];
  rblapack_c = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  sorml2_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_c);
}

void
init_lapack_sorml2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sorml2", rblapack_sorml2, -1);
}
ruby-lapack-1.7.2/ext/sstemr.c0000644000175000017500000003700512502221021016040 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sstemr_(char* jobz, char* range, integer* n, real* d, real* e, real* vl, real* vu, integer* il, integer* iu, integer* m, real* w, real* z, integer* ldz, integer* nzc, integer* isuppz, logical* tryrac, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_sstemr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_vl;
  real vl; 
  VALUE rblapack_vu;
  real vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_nzc;
  integer nzc; 
  VALUE rblapack_tryrac;
  logical tryrac; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_isuppz;
  integer *isuppz; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_e_out__;
  real *e_out__;

  integer n;
  integer ldz;

  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  m, w, z, isuppz, work, iwork, info, d, e, tryrac = NumRu::Lapack.sstemr( jobz, range, d, e, vl, vu, il, iu, nzc, tryrac, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSTEMR computes selected eigenvalues and, optionally, eigenvectors\n*  of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n*  a well defined set of pairwise different real eigenvalues, the corresponding\n*  real eigenvectors are pairwise orthogonal.\n*\n*  The spectrum may be computed either completely or partially by specifying\n*  either an interval (VL,VU] or a range of indices IL:IU for the desired\n*  eigenvalues.\n*\n*  Depending on the number of desired eigenvalues, these are computed either\n*  by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are\n*  computed by the use of various suitable L D L^T factorizations near clusters\n*  of close eigenvalues (referred to as RRRs, Relatively Robust\n*  Representations). An informal sketch of the algorithm follows.\n*\n*  For each unreduced block (submatrix) of T,\n*     (a) Compute T - sigma I  = L D L^T, so that L and D\n*         define all the wanted eigenvalues to high relative accuracy.\n*         This means that small relative changes in the entries of D and L\n*         cause only small relative changes in the eigenvalues and\n*         eigenvectors. The standard (unfactored) representation of the\n*         tridiagonal matrix T does not have this property in general.\n*     (b) Compute the eigenvalues to suitable accuracy.\n*         If the eigenvectors are desired, the algorithm attains full\n*         accuracy of the computed eigenvalues only right before\n*         the corresponding vectors have to be computed, see steps c) and d).\n*     (c) For each cluster of close eigenvalues, select a new\n*         shift close to the cluster, find a new factorization, and refine\n*         the shifted eigenvalues to suitable accuracy.\n*     (d) For each eigenvalue with a large enough relative separation compute\n*         the corresponding eigenvector by forming a rank revealing twisted\n*         factorization. Go back to (c) for any clusters that remain.\n*\n*  For more details, see:\n*  - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n*    to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n*    Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n*  - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n*    Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n*    2004.  Also LAPACK Working Note 154.\n*  - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n*    tridiagonal eigenvalue/eigenvector problem\",\n*    Computer Science Division Technical Report No. UCB/CSD-97-971,\n*    UC Berkeley, May 1997.\n*\n*  Further Details\n*  1.SSTEMR works only on machines which follow IEEE-754\n*  floating-point standard in their handling of infinities and NaNs.\n*  This permits the use of efficient inner loops avoiding a check for\n*  zero divisors.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found.\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found.\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  D       (input/output) REAL array, dimension (N)\n*          On entry, the N diagonal elements of the tridiagonal matrix\n*          T. On exit, D is overwritten.\n*\n*  E       (input/output) REAL array, dimension (N)\n*          On entry, the (N-1) subdiagonal elements of the tridiagonal\n*          matrix T in elements 1 to N-1 of E. E(N) need not be set on\n*          input, but is used internally as workspace.\n*          On exit, E is overwritten.\n*\n*  VL      (input) REAL\n*  VU      (input) REAL\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) REAL array, dimension (N)\n*          The first M elements contain the selected eigenvalues in\n*          ascending order.\n*\n*  Z       (output) REAL array, dimension (LDZ, max(1,M) )\n*          If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix T\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and can be computed with a workspace\n*          query by setting NZC = -1, see below.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', then LDZ >= max(1,N).\n*\n*  NZC     (input) INTEGER\n*          The number of eigenvectors to be held in the array Z.\n*          If RANGE = 'A', then NZC >= max(1,N).\n*          If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].\n*          If RANGE = 'I', then NZC >= IU-IL+1.\n*          If NZC = -1, then a workspace query is assumed; the\n*          routine calculates the number of columns of the array Z that\n*          are needed to hold the eigenvectors.\n*          This value is returned as the first entry of the Z array, and\n*          no error message related to NZC is issued by XERBLA.\n*\n*  ISUPPZ  (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n*          The support of the eigenvectors in Z, i.e., the indices\n*          indicating the nonzero elements in Z. The i-th computed eigenvector\n*          is nonzero only in elements ISUPPZ( 2*i-1 ) through\n*          ISUPPZ( 2*i ). This is relevant in the case when the matrix\n*          is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n*\n*  TRYRAC  (input/output) LOGICAL\n*          If TRYRAC.EQ..TRUE., indicates that the code should check whether\n*          the tridiagonal matrix defines its eigenvalues to high relative\n*          accuracy.  If so, the code uses relative-accuracy preserving\n*          algorithms that might be (a bit) slower depending on the matrix.\n*          If the matrix does not define its eigenvalues to high relative\n*          accuracy, the code can uses possibly faster algorithms.\n*          If TRYRAC.EQ..FALSE., the code is not required to guarantee\n*          relatively accurate eigenvalues and can use the fastest possible\n*          techniques.\n*          On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix\n*          does not define its eigenvalues to high relative accuracy.\n*\n*  WORK    (workspace/output) REAL array, dimension (LWORK)\n*          On exit, if INFO = 0, WORK(1) returns the optimal\n*          (and minimal) LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK. LWORK >= max(1,18*N)\n*          if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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*  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.  LIWORK >= max(1,10*N)\n*          if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n*          if only the eigenvalues are to be computed.\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal size of the IWORK array,\n*          returns this value as the first entry of the IWORK array, and\n*          no error message related to LIWORK is issued by XERBLA.\n*\n*  INFO    (output) INTEGER\n*          On exit, INFO\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  if INFO = 1X, internal error in SLARRE,\n*                if INFO = 2X, internal error in SLARRV.\n*                Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n*                the nonzero error code returned by SLARRE or\n*                SLARRV, respectively.\n*\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Beresford Parlett, University of California, Berkeley, USA\n*     Jim Demmel, University of California, Berkeley, USA\n*     Inderjit Dhillon, University of Texas, Austin, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, isuppz, work, iwork, info, d, e, tryrac = NumRu::Lapack.sstemr( jobz, range, d, e, vl, vu, il, iu, nzc, tryrac, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_d = argv[2];
  rblapack_e = argv[3];
  rblapack_vl = argv[4];
  rblapack_vu = argv[5];
  rblapack_il = argv[6];
  rblapack_iu = argv[7];
  rblapack_nzc = argv[8];
  rblapack_tryrac = argv[9];
  if (argc == 12) {
    rblapack_lwork = argv[10];
    rblapack_liwork = argv[11];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  vl = (real)NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  nzc = NUM2INT(rblapack_nzc);
  range = StringValueCStr(rblapack_range)[0];
  vu = (real)NUM2DBL(rblapack_vu);
  tryrac = (rblapack_tryrac == Qtrue);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (4th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&jobz,"V") ? 18*n : lsame_(&jobz,"N") ? 12*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  iu = NUM2INT(rblapack_iu);
  m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
  if (rblapack_liwork == Qnil)
    liwork = lsame_(&jobz,"V") ? 10*n : lsame_(&jobz,"N") ? 8*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[1];
    shape[0] = 2*MAX(1,m);
    rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
  MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;

  sstemr_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &m, w, z, &ldz, &nzc, isuppz, &tryrac, work, &lwork, iwork, &liwork, &info);

  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  rblapack_tryrac = tryrac ? Qtrue : Qfalse;
  return rb_ary_new3(10, rblapack_m, rblapack_w, rblapack_z, rblapack_isuppz, rblapack_work, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e, rblapack_tryrac);
}

void
init_lapack_sstemr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sstemr", rblapack_sstemr, -1);
}
ruby-lapack-1.7.2/ext/ztgsja.c0000644000175000017500000004012112502221026016023 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztgsja_(char* jobu, char* jobv, char* jobq, integer* m, integer* p, integer* n, integer* k, integer* l, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublereal* tola, doublereal* tolb, doublereal* alpha, doublereal* beta, doublecomplex* u, integer* ldu, doublecomplex* v, integer* ldv, doublecomplex* q, integer* ldq, doublecomplex* work, integer* ncycle, integer* info);


static VALUE
rblapack_ztgsja(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobu;
  char jobu; 
  VALUE rblapack_jobv;
  char jobv; 
  VALUE rblapack_jobq;
  char jobq; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_tola;
  doublereal tola; 
  VALUE rblapack_tolb;
  doublereal tolb; 
  VALUE rblapack_u;
  doublecomplex *u; 
  VALUE rblapack_v;
  doublecomplex *v; 
  VALUE rblapack_q;
  doublecomplex *q; 
  VALUE rblapack_alpha;
  doublereal *alpha; 
  VALUE rblapack_beta;
  doublereal *beta; 
  VALUE rblapack_ncycle;
  integer ncycle; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  VALUE rblapack_u_out__;
  doublecomplex *u_out__;
  VALUE rblapack_v_out__;
  doublecomplex *v_out__;
  VALUE rblapack_q_out__;
  doublecomplex *q_out__;
  doublecomplex *work;

  integer lda;
  integer n;
  integer ldb;
  integer ldu;
  integer m;
  integer ldv;
  integer p;
  integer ldq;

  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  alpha, beta, ncycle, info, a, b, u, v, q = NumRu::Lapack.ztgsja( jobu, jobv, jobq, k, l, a, b, tola, tolb, u, v, q, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, NCYCLE, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTGSJA computes the generalized singular value decomposition (GSVD)\n*  of two complex upper triangular (or trapezoidal) matrices A and B.\n*\n*  On entry, it is assumed that matrices A and B have the following\n*  forms, which may be obtained by the preprocessing subroutine ZGGSVP\n*  from a general M-by-N matrix A and P-by-N matrix B:\n*\n*               N-K-L  K    L\n*     A =    K ( 0    A12  A13 ) if M-K-L >= 0;\n*            L ( 0     0   A23 )\n*        M-K-L ( 0     0    0  )\n*\n*             N-K-L  K    L\n*     A =  K ( 0    A12  A13 ) if M-K-L < 0;\n*        M-K ( 0     0   A23 )\n*\n*             N-K-L  K    L\n*     B =  L ( 0     0   B13 )\n*        P-L ( 0     0    0  )\n*\n*  where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n*  upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n*  otherwise A23 is (M-K)-by-L upper trapezoidal.\n*\n*  On exit,\n*\n*         U'*A*Q = D1*( 0 R ),    V'*B*Q = D2*( 0 R ),\n*\n*  where U, V and Q are unitary matrices, Z' denotes the conjugate\n*  transpose of Z, R is a nonsingular upper triangular matrix, and D1\n*  and D2 are ``diagonal'' matrices, which are of the following\n*  structures:\n*\n*  If M-K-L >= 0,\n*\n*                      K  L\n*         D1 =     K ( I  0 )\n*                  L ( 0  C )\n*              M-K-L ( 0  0 )\n*\n*                     K  L\n*         D2 = L   ( 0  S )\n*              P-L ( 0  0 )\n*\n*                 N-K-L  K    L\n*    ( 0 R ) = K (  0   R11  R12 ) K\n*              L (  0    0   R22 ) L\n*\n*  where\n*\n*    C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n*    S = diag( BETA(K+1),  ... , BETA(K+L) ),\n*    C**2 + S**2 = I.\n*\n*    R is stored in A(1:K+L,N-K-L+1:N) on exit.\n*\n*  If M-K-L < 0,\n*\n*                 K M-K K+L-M\n*      D1 =   K ( I  0    0   )\n*           M-K ( 0  C    0   )\n*\n*                   K M-K K+L-M\n*      D2 =   M-K ( 0  S    0   )\n*           K+L-M ( 0  0    I   )\n*             P-L ( 0  0    0   )\n*\n*                 N-K-L  K   M-K  K+L-M\n* ( 0 R ) =    K ( 0    R11  R12  R13  )\n*            M-K ( 0     0   R22  R23  )\n*          K+L-M ( 0     0    0   R33  )\n*\n*  where\n*  C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n*  S = diag( BETA(K+1),  ... , BETA(M) ),\n*  C**2 + S**2 = I.\n*\n*  R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored\n*      (  0  R22 R23 )\n*  in B(M-K+1:L,N+M-K-L+1:N) on exit.\n*\n*  The computation of the unitary transformation matrices U, V or Q\n*  is optional.  These matrices may either be formed explicitly, or they\n*  may be postmultiplied into input matrices U1, V1, or Q1.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBU    (input) CHARACTER*1\n*          = 'U':  U must contain a unitary matrix U1 on entry, and\n*                  the product U1*U is returned;\n*          = 'I':  U is initialized to the unit matrix, and the\n*                  unitary matrix U is returned;\n*          = 'N':  U is not computed.\n*\n*  JOBV    (input) CHARACTER*1\n*          = 'V':  V must contain a unitary matrix V1 on entry, and\n*                  the product V1*V is returned;\n*          = 'I':  V is initialized to the unit matrix, and the\n*                  unitary matrix V is returned;\n*          = 'N':  V is not computed.\n*\n*  JOBQ    (input) CHARACTER*1\n*          = 'Q':  Q must contain a unitary matrix Q1 on entry, and\n*                  the product Q1*Q is returned;\n*          = 'I':  Q is initialized to the unit matrix, and the\n*                  unitary matrix Q is returned;\n*          = 'N':  Q is not computed.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.  M >= 0.\n*\n*  P       (input) INTEGER\n*          The number of rows of the matrix B.  P >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrices A and B.  N >= 0.\n*\n*  K       (input) INTEGER\n*  L       (input) INTEGER\n*          K and L specify the subblocks in the input matrices A and B:\n*          A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,,N-L+1:N)\n*          of A and B, whose GSVD is going to be computed by ZTGSJA.\n*          See Further Details.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular\n*          matrix R or part of R.  See Purpose for details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,N)\n*          On entry, the P-by-N matrix B.\n*          On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains\n*          a part of R.  See Purpose for details.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,P).\n*\n*  TOLA    (input) DOUBLE PRECISION\n*  TOLB    (input) DOUBLE PRECISION\n*          TOLA and TOLB are the convergence criteria for the Jacobi-\n*          Kogbetliantz iteration procedure. Generally, they are the\n*          same as used in the preprocessing step, say\n*              TOLA = MAX(M,N)*norm(A)*MAZHEPS,\n*              TOLB = MAX(P,N)*norm(B)*MAZHEPS.\n*\n*  ALPHA   (output) DOUBLE PRECISION array, dimension (N)\n*  BETA    (output) DOUBLE PRECISION array, dimension (N)\n*          On exit, ALPHA and BETA contain the generalized singular\n*          value pairs of A and B;\n*            ALPHA(1:K) = 1,\n*            BETA(1:K)  = 0,\n*          and if M-K-L >= 0,\n*            ALPHA(K+1:K+L) = diag(C),\n*            BETA(K+1:K+L)  = diag(S),\n*          or if M-K-L < 0,\n*            ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0\n*            BETA(K+1:M) = S, BETA(M+1:K+L) = 1.\n*          Furthermore, if K+L < N,\n*            ALPHA(K+L+1:N) = 0\n*            BETA(K+L+1:N)  = 0.\n*\n*  U       (input/output) COMPLEX*16 array, dimension (LDU,M)\n*          On entry, if JOBU = 'U', U must contain a matrix U1 (usually\n*          the unitary matrix returned by ZGGSVP).\n*          On exit,\n*          if JOBU = 'I', U contains the unitary matrix U;\n*          if JOBU = 'U', U contains the product U1*U.\n*          If JOBU = 'N', U is not referenced.\n*\n*  LDU     (input) INTEGER\n*          The leading dimension of the array U. LDU >= max(1,M) if\n*          JOBU = 'U'; LDU >= 1 otherwise.\n*\n*  V       (input/output) COMPLEX*16 array, dimension (LDV,P)\n*          On entry, if JOBV = 'V', V must contain a matrix V1 (usually\n*          the unitary matrix returned by ZGGSVP).\n*          On exit,\n*          if JOBV = 'I', V contains the unitary matrix V;\n*          if JOBV = 'V', V contains the product V1*V.\n*          If JOBV = 'N', V is not referenced.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V. LDV >= max(1,P) if\n*          JOBV = 'V'; LDV >= 1 otherwise.\n*\n*  Q       (input/output) COMPLEX*16 array, dimension (LDQ,N)\n*          On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually\n*          the unitary matrix returned by ZGGSVP).\n*          On exit,\n*          if JOBQ = 'I', Q contains the unitary matrix Q;\n*          if JOBQ = 'Q', Q contains the product Q1*Q.\n*          If JOBQ = 'N', Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q. LDQ >= max(1,N) if\n*          JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  NCYCLE  (output) INTEGER\n*          The number of cycles required for convergence.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          = 1:  the procedure does not converge after MAXIT cycles.\n*\n*  Internal Parameters\n*  ===================\n*\n*  MAXIT   INTEGER\n*          MAXIT specifies the total loops that the iterative procedure\n*          may take. If after MAXIT cycles, the routine fails to\n*          converge, we return INFO = 1.\n*\n\n*  Further Details\n*  ===============\n*\n*  ZTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce\n*  min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L\n*  matrix B13 to the form:\n*\n*           U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1,\n*\n*  where U1, V1 and Q1 are unitary matrix, and Z' is the conjugate\n*  transpose of Z.  C1 and S1 are diagonal matrices satisfying\n*\n*                C1**2 + S1**2 = I,\n*\n*  and R1 is an L-by-L nonsingular upper triangular matrix.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  alpha, beta, ncycle, info, a, b, u, v, q = NumRu::Lapack.ztgsja( jobu, jobv, jobq, k, l, a, b, tola, tolb, u, v, q, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_jobu = argv[0];
  rblapack_jobv = argv[1];
  rblapack_jobq = argv[2];
  rblapack_k = argv[3];
  rblapack_l = argv[4];
  rblapack_a = argv[5];
  rblapack_b = argv[6];
  rblapack_tola = argv[7];
  rblapack_tolb = argv[8];
  rblapack_u = argv[9];
  rblapack_v = argv[10];
  rblapack_q = argv[11];
  if (argc == 12) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobu = StringValueCStr(rblapack_jobu)[0];
  jobq = StringValueCStr(rblapack_jobq)[0];
  l = NUM2INT(rblapack_l);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  tolb = NUM2DBL(rblapack_tolb);
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (11th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (11th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  p = NA_SHAPE1(rblapack_v);
  if (NA_TYPE(rblapack_v) != NA_DCOMPLEX)
    rblapack_v = na_change_type(rblapack_v, NA_DCOMPLEX);
  v = NA_PTR_TYPE(rblapack_v, doublecomplex*);
  jobv = StringValueCStr(rblapack_jobv)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (6th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (6th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_u))
    rb_raise(rb_eArgError, "u (10th argument) must be NArray");
  if (NA_RANK(rblapack_u) != 2)
    rb_raise(rb_eArgError, "rank of u (10th argument) must be %d", 2);
  ldu = NA_SHAPE0(rblapack_u);
  m = NA_SHAPE1(rblapack_u);
  if (NA_TYPE(rblapack_u) != NA_DCOMPLEX)
    rblapack_u = na_change_type(rblapack_u, NA_DCOMPLEX);
  u = NA_PTR_TYPE(rblapack_u, doublecomplex*);
  k = NUM2INT(rblapack_k);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (12th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (12th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_q) != NA_DCOMPLEX)
    rblapack_q = na_change_type(rblapack_q, NA_DCOMPLEX);
  q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
  tola = NUM2DBL(rblapack_tola);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alpha = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  alpha = NA_PTR_TYPE(rblapack_alpha, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = m;
    rblapack_u_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  u_out__ = NA_PTR_TYPE(rblapack_u_out__, doublecomplex*);
  MEMCPY(u_out__, u, doublecomplex, NA_TOTAL(rblapack_u));
  rblapack_u = rblapack_u_out__;
  u = u_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = p;
    rblapack_v_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  v_out__ = NA_PTR_TYPE(rblapack_v_out__, doublecomplex*);
  MEMCPY(v_out__, v, doublecomplex, NA_TOTAL(rblapack_v));
  rblapack_v = rblapack_v_out__;
  v = v_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublecomplex*);
  MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  work = ALLOC_N(doublecomplex, (2*n));

  ztgsja_(&jobu, &jobv, &jobq, &m, &p, &n, &k, &l, a, &lda, b, &ldb, &tola, &tolb, alpha, beta, u, &ldu, v, &ldv, q, &ldq, work, &ncycle, &info);

  free(work);
  rblapack_ncycle = INT2NUM(ncycle);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_alpha, rblapack_beta, rblapack_ncycle, rblapack_info, rblapack_a, rblapack_b, rblapack_u, rblapack_v, rblapack_q);
}

void
init_lapack_ztgsja(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztgsja", rblapack_ztgsja, -1);
}
ruby-lapack-1.7.2/ext/slarfg.c0000644000175000017500000000740212502221013016000 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slarfg_(integer* n, real* alpha, real* x, integer* incx, real* tau);


static VALUE
rblapack_slarfg(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_alpha;
  real alpha; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_tau;
  real tau; 
  VALUE rblapack_x_out__;
  real *x_out__;


  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, alpha, x = NumRu::Lapack.slarfg( n, alpha, x, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLARFG( N, ALPHA, X, INCX, TAU )\n\n*  Purpose\n*  =======\n*\n*  SLARFG generates a real elementary reflector H of order n, such\n*  that\n*\n*        H * ( alpha ) = ( beta ),   H' * H = I.\n*            (   x   )   (   0  )\n*\n*  where alpha and beta are scalars, and x is an (n-1)-element real\n*  vector. H is represented in the form\n*\n*        H = I - tau * ( 1 ) * ( 1 v' ) ,\n*                      ( v )\n*\n*  where tau is a real scalar and v is a real (n-1)-element\n*  vector.\n*\n*  If the elements of x are all zero, then tau = 0 and H is taken to be\n*  the unit matrix.\n*\n*  Otherwise  1 <= tau <= 2.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the elementary reflector.\n*\n*  ALPHA   (input/output) REAL\n*          On entry, the value alpha.\n*          On exit, it is overwritten with the value beta.\n*\n*  X       (input/output) REAL array, dimension\n*                         (1+(N-2)*abs(INCX))\n*          On entry, the vector x.\n*          On exit, it is overwritten with the vector v.\n*\n*  INCX    (input) INTEGER\n*          The increment between elements of X. INCX > 0.\n*\n*  TAU     (output) REAL\n*          The value tau.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, alpha, x = NumRu::Lapack.slarfg( n, alpha, x, incx, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_n = argv[0];
  rblapack_alpha = argv[1];
  rblapack_x = argv[2];
  rblapack_incx = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  incx = NUM2INT(rblapack_incx);
  alpha = (real)NUM2DBL(rblapack_alpha);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (3th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1+(n-2)*abs(incx)))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-2)*abs(incx));
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-2)*abs(incx);
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;

  slarfg_(&n, &alpha, x, &incx, &tau);

  rblapack_tau = rb_float_new((double)tau);
  rblapack_alpha = rb_float_new((double)alpha);
  return rb_ary_new3(3, rblapack_tau, rblapack_alpha, rblapack_x);
}

void
init_lapack_slarfg(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slarfg", rblapack_slarfg, -1);
}
ruby-lapack-1.7.2/ext/clabrd.c0000644000175000017500000002120412502221016015750 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clabrd_(integer* m, integer* n, integer* nb, complex* a, integer* lda, real* d, real* e, complex* tauq, complex* taup, complex* x, integer* ldx, complex* y, integer* ldy);


static VALUE
rblapack_clabrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_nb;
  integer nb; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_tauq;
  complex *tauq; 
  VALUE rblapack_taup;
  complex *taup; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_y;
  complex *y; 
  VALUE rblapack_a_out__;
  complex *a_out__;

  integer lda;
  integer n;
  integer ldx;
  integer ldy;

  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  d, e, tauq, taup, x, y, a = NumRu::Lapack.clabrd( m, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, LDY )\n\n*  Purpose\n*  =======\n*\n*  CLABRD reduces the first NB rows and columns of a complex general\n*  m by n matrix A to upper or lower real bidiagonal form by a unitary\n*  transformation Q' * A * P, and returns the matrices X and Y which\n*  are needed to apply the transformation to the unreduced part of A.\n*\n*  If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower\n*  bidiagonal form.\n*\n*  This is an auxiliary routine called by CGEBRD\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows in the matrix A.\n*\n*  N       (input) INTEGER\n*          The number of columns in the matrix A.\n*\n*  NB      (input) INTEGER\n*          The number of leading rows and columns of A to be reduced.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the m by n general matrix to be reduced.\n*          On exit, the first NB rows and columns of the matrix are\n*          overwritten; the rest of the array is unchanged.\n*          If m >= n, elements on and below the diagonal in the first NB\n*            columns, with the array TAUQ, represent the unitary\n*            matrix Q as a product of elementary reflectors; and\n*            elements above the diagonal in the first NB rows, with the\n*            array TAUP, represent the unitary matrix P as a product\n*            of elementary reflectors.\n*          If m < n, elements below the diagonal in the first NB\n*            columns, with the array TAUQ, represent the unitary\n*            matrix Q as a product of elementary reflectors, and\n*            elements on and above the diagonal in the first NB rows,\n*            with the array TAUP, represent the unitary matrix P as\n*            a product of elementary reflectors.\n*          See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  D       (output) REAL array, dimension (NB)\n*          The diagonal elements of the first NB rows and columns of\n*          the reduced matrix.  D(i) = A(i,i).\n*\n*  E       (output) REAL array, dimension (NB)\n*          The off-diagonal elements of the first NB rows and columns of\n*          the reduced matrix.\n*\n*  TAUQ    (output) COMPLEX array dimension (NB)\n*          The scalar factors of the elementary reflectors which\n*          represent the unitary matrix Q. See Further Details.\n*\n*  TAUP    (output) COMPLEX array, dimension (NB)\n*          The scalar factors of the elementary reflectors which\n*          represent the unitary matrix P. See Further Details.\n*\n*  X       (output) COMPLEX array, dimension (LDX,NB)\n*          The m-by-nb matrix X required to update the unreduced part\n*          of A.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X. LDX >= max(1,M).\n*\n*  Y       (output) COMPLEX array, dimension (LDY,NB)\n*          The n-by-nb matrix Y required to update the unreduced part\n*          of A.\n*\n*  LDY     (input) INTEGER\n*          The leading dimension of the array Y. LDY >= max(1,N).\n*\n\n*  Further Details\n*  ===============\n*\n*  The matrices Q and P are represented as products of elementary\n*  reflectors:\n*\n*     Q = H(1) H(2) . . . H(nb)  and  P = G(1) G(2) . . . G(nb)\n*\n*  Each H(i) and G(i) has the form:\n*\n*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'\n*\n*  where tauq and taup are complex scalars, and v and u are complex\n*  vectors.\n*\n*  If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in\n*  A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in\n*  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n*  If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in\n*  A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in\n*  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n*  The elements of the vectors v and u together form the m-by-nb matrix\n*  V and the nb-by-n matrix U' which are needed, with X and Y, to apply\n*  the transformation to the unreduced part of the matrix, using a block\n*  update of the form:  A := A - V*Y' - X*U'.\n*\n*  The contents of A on exit are illustrated by the following examples\n*  with nb = 2:\n*\n*  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):\n*\n*    (  1   1   u1  u1  u1 )           (  1   u1  u1  u1  u1  u1 )\n*    (  v1  1   1   u2  u2 )           (  1   1   u2  u2  u2  u2 )\n*    (  v1  v2  a   a   a  )           (  v1  1   a   a   a   a  )\n*    (  v1  v2  a   a   a  )           (  v1  v2  a   a   a   a  )\n*    (  v1  v2  a   a   a  )           (  v1  v2  a   a   a   a  )\n*    (  v1  v2  a   a   a  )\n*\n*  where a denotes an element of the original matrix which is unchanged,\n*  vi denotes an element of the vector defining H(i), and ui an element\n*  of the vector defining G(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, tauq, taup, x, y, a = NumRu::Lapack.clabrd( m, nb, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_m = argv[0];
  rblapack_nb = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  ldy = MAX(1,n);
  nb = NUM2INT(rblapack_nb);
  ldx = MAX(1,m);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,nb);
    rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,nb);
    rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,nb);
    rblapack_tauq = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  tauq = NA_PTR_TYPE(rblapack_tauq, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,nb);
    rblapack_taup = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  taup = NA_PTR_TYPE(rblapack_taup, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = MAX(1,nb);
    rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldy;
    shape[1] = MAX(1,nb);
    rblapack_y = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  y = NA_PTR_TYPE(rblapack_y, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  clabrd_(&m, &n, &nb, a, &lda, d, e, tauq, taup, x, &ldx, y, &ldy);

  return rb_ary_new3(7, rblapack_d, rblapack_e, rblapack_tauq, rblapack_taup, rblapack_x, rblapack_y, rblapack_a);
}

void
init_lapack_clabrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clabrd", rblapack_clabrd, -1);
}
ruby-lapack-1.7.2/ext/zhbevd.c0000644000175000017500000002500112502221024016001 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhbevd_(char* jobz, char* uplo, integer* n, integer* kd, doublecomplex* ab, integer* ldab, doublereal* w, doublecomplex* z, integer* ldz, doublecomplex* work, integer* lwork, doublereal* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_zhbevd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_lrwork;
  integer lrwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_rwork;
  doublereal *rwork; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublecomplex *ab_out__;

  integer ldab;
  integer n;
  integer ldz;

  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  w, z, work, rwork, iwork, info, ab = NumRu::Lapack.zhbevd( jobz, uplo, kd, ab, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHBEVD computes all the eigenvalues and, optionally, eigenvectors of\n*  a complex Hermitian band matrix A.  If eigenvectors are desired, it\n*  uses a divide and conquer algorithm.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) COMPLEX*16 array, dimension (LDAB, N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*          On exit, AB is overwritten by values generated during the\n*          reduction to tridiagonal form.  If UPLO = 'U', the first\n*          superdiagonal and the diagonal of the tridiagonal matrix T\n*          are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n*          the diagonal and first subdiagonal of T are returned in the\n*          first two rows of AB.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD + 1.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) COMPLEX*16 array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n*          eigenvectors of the matrix A, with the i-th column of Z\n*          holding the eigenvector associated with W(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace/output) COMPLEX*16 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*          If N <= 1,               LWORK must be at least 1.\n*          If JOBZ = 'N' and N > 1, LWORK must be at least N.\n*          If JOBZ = 'V' and N > 1, LWORK must be at least 2*N**2.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal sizes of the WORK, RWORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  RWORK   (workspace/output) DOUBLE PRECISION array,\n*                                         dimension (LRWORK)\n*          On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n*\n*  LRWORK  (input) INTEGER\n*          The dimension of array RWORK.\n*          If N <= 1,               LRWORK must be at least 1.\n*          If JOBZ = 'N' and N > 1, LRWORK must be at least N.\n*          If JOBZ = 'V' and N > 1, LRWORK must be at least\n*                        1 + 5*N + 2*N**2.\n*\n*          If LRWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of array IWORK.\n*          If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.\n*          If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N .\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK 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 algorithm failed to converge; i\n*                off-diagonal elements of an intermediate tridiagonal\n*                form did not converge to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, work, rwork, iwork, info, ab = NumRu::Lapack.zhbevd( jobz, uplo, kd, ab, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_kd = argv[2];
  rblapack_ab = argv[3];
  if (argc == 7) {
    rblapack_lwork = argv[4];
    rblapack_lrwork = argv[5];
    rblapack_liwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_lrwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  kd = NUM2INT(rblapack_kd);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  if (rblapack_lrwork == Qnil)
    lrwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
  else {
    lrwork = NUM2INT(rblapack_lrwork);
  }
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  if (rblapack_lwork == Qnil)
    lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 2*n*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (rblapack_liwork == Qnil)
    liwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lrwork);
    rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
  MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  zhbevd_(&jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_w, rblapack_z, rblapack_work, rblapack_rwork, rblapack_iwork, rblapack_info, rblapack_ab);
}

void
init_lapack_zhbevd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhbevd", rblapack_zhbevd, -1);
}
ruby-lapack-1.7.2/ext/claic1.c0000644000175000017500000001162612502221013015661 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID claic1_(integer* job, integer* j, complex* x, real* sest, complex* w, complex* gamma, real* sestpr, complex* s, complex* c);


static VALUE
rblapack_claic1(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  integer job; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_sest;
  real sest; 
  VALUE rblapack_w;
  complex *w; 
  VALUE rblapack_gamma;
  complex gamma; 
  VALUE rblapack_sestpr;
  real sestpr; 
  VALUE rblapack_s;
  complex s; 
  VALUE rblapack_c;
  complex c; 

  integer j;

  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  sestpr, s, c = NumRu::Lapack.claic1( job, x, sest, w, gamma, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C )\n\n*  Purpose\n*  =======\n*\n*  CLAIC1 applies one step of incremental condition estimation in\n*  its simplest version:\n*\n*  Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j\n*  lower triangular matrix L, such that\n*           twonorm(L*x) = sest\n*  Then CLAIC1 computes sestpr, s, c such that\n*  the vector\n*                  [ s*x ]\n*           xhat = [  c  ]\n*  is an approximate singular vector of\n*                  [ L     0  ]\n*           Lhat = [ w' gamma ]\n*  in the sense that\n*           twonorm(Lhat*xhat) = sestpr.\n*\n*  Depending on JOB, an estimate for the largest or smallest singular\n*  value is computed.\n*\n*  Note that [s c]' and sestpr**2 is an eigenpair of the system\n*\n*      diag(sest*sest, 0) + [alpha  gamma] * [ conjg(alpha) ]\n*                                            [ conjg(gamma) ]\n*\n*  where  alpha =  conjg(x)'*w.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) INTEGER\n*          = 1: an estimate for the largest singular value is computed.\n*          = 2: an estimate for the smallest singular value is computed.\n*\n*  J       (input) INTEGER\n*          Length of X and W\n*\n*  X       (input) COMPLEX array, dimension (J)\n*          The j-vector x.\n*\n*  SEST    (input) REAL\n*          Estimated singular value of j by j matrix L\n*\n*  W       (input) COMPLEX array, dimension (J)\n*          The j-vector w.\n*\n*  GAMMA   (input) COMPLEX\n*          The diagonal element gamma.\n*\n*  SESTPR  (output) REAL\n*          Estimated singular value of (j+1) by (j+1) matrix Lhat.\n*\n*  S       (output) COMPLEX\n*          Sine needed in forming xhat.\n*\n*  C       (output) COMPLEX\n*          Cosine needed in forming xhat.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sestpr, s, c = NumRu::Lapack.claic1( job, x, sest, w, gamma, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_job = argv[0];
  rblapack_x = argv[1];
  rblapack_sest = argv[2];
  rblapack_w = argv[3];
  rblapack_gamma = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  job = NUM2INT(rblapack_job);
  sest = (real)NUM2DBL(rblapack_sest);
  gamma.r = (real)NUM2DBL(rb_funcall(rblapack_gamma, rb_intern("real"), 0));
  gamma.i = (real)NUM2DBL(rb_funcall(rblapack_gamma, rb_intern("imag"), 0));
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
  j = NA_SHAPE0(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  if (!NA_IsNArray(rblapack_w))
    rb_raise(rb_eArgError, "w (4th argument) must be NArray");
  if (NA_RANK(rblapack_w) != 1)
    rb_raise(rb_eArgError, "rank of w (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_w) != j)
    rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of x");
  if (NA_TYPE(rblapack_w) != NA_SCOMPLEX)
    rblapack_w = na_change_type(rblapack_w, NA_SCOMPLEX);
  w = NA_PTR_TYPE(rblapack_w, complex*);

  claic1_(&job, &j, x, &sest, w, &gamma, &sestpr, &s, &c);

  rblapack_sestpr = rb_float_new((double)sestpr);
  rblapack_s = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(s.r)), rb_float_new((double)(s.i)));
  rblapack_c = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(c.r)), rb_float_new((double)(c.i)));
  return rb_ary_new3(3, rblapack_sestpr, rblapack_s, rblapack_c);
}

void
init_lapack_claic1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "claic1", rblapack_claic1, -1);
}
ruby-lapack-1.7.2/ext/stprfs.c0000644000175000017500000001616712502221023016054 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID stprfs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, real* ap, real* b, integer* ldb, real* x, integer* ldx, real* ferr, real* berr, real* work, integer* iwork, integer* info);


static VALUE
rblapack_stprfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  real *work;
  integer *iwork;

  integer ldb;
  integer nrhs;
  integer ldx;
  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  ferr, berr, info = NumRu::Lapack.stprfs( uplo, trans, diag, ap, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  STPRFS provides error bounds and backward error estimates for the\n*  solution to a system of linear equations with a triangular packed\n*  coefficient matrix.\n*\n*  The solution matrix X must be computed by STPTRS or some other\n*  means before entering this routine.  STPRFS does not do iterative\n*  refinement because doing so cannot improve the backward error.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B  (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AP      (input) REAL array, dimension (N*(N+1)/2)\n*          The upper or lower triangular matrix A, packed columnwise in\n*          a linear array.  The j-th column of A is stored in the array\n*          AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*          If DIAG = 'U', the diagonal elements of A are not referenced\n*          and are assumed to be 1.\n*\n*  B       (input) REAL array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input) REAL array, dimension (LDX,NRHS)\n*          The solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) REAL array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info = NumRu::Lapack.stprfs( uplo, trans, diag, ap, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_ap = argv[3];
  rblapack_b = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  n = ldb;
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  work = ALLOC_N(real, (3*n));
  iwork = ALLOC_N(integer, (n));

  stprfs_(&uplo, &trans, &diag, &n, &nrhs, ap, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ferr, rblapack_berr, rblapack_info);
}

void
init_lapack_stprfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "stprfs", rblapack_stprfs, -1);
}
ruby-lapack-1.7.2/ext/zlacrm.c0000644000175000017500000000777012502221026016026 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlacrm_(integer* m, integer* n, doublecomplex* a, integer* lda, doublereal* b, integer* ldb, doublecomplex* c, integer* ldc, doublereal* rwork);


static VALUE
rblapack_zlacrm(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_c;
  doublecomplex *c; 
  doublereal *rwork;

  integer lda;
  integer n;
  integer ldb;
  integer ldc;

  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  c = NumRu::Lapack.zlacrm( m, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK )\n\n*  Purpose\n*  =======\n*\n*  ZLACRM performs a very simple matrix-matrix multiplication:\n*           C := A * B,\n*  where A is M by N and complex; B is N by N and real;\n*  C is M by N and complex.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A and of the matrix C.\n*          M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns and rows of the matrix B and\n*          the number of columns of the matrix C.\n*          N >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA, N)\n*          A contains 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*  B       (input) DOUBLE PRECISION array, dimension (LDB, N)\n*          B contains the N by N matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >=max(1,N).\n*\n*  C       (input) COMPLEX*16 array, dimension (LDC, N)\n*          C contains the M by N matrix C.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >=max(1,N).\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (2*M*N)\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.zlacrm( m, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  rblapack_b = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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);
  ldb = NA_SHAPE0(rblapack_b);
  n = 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 (!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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  ldc = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
  rwork = ALLOC_N(doublereal, (2*m*n));

  zlacrm_(&m, &n, a, &lda, b, &ldb, c, &ldc, rwork);

  free(rwork);
  return rblapack_c;
}

void
init_lapack_zlacrm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlacrm", rblapack_zlacrm, -1);
}
ruby-lapack-1.7.2/ext/zsycon.c0000644000175000017500000001124312502221021016044 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zsycon_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* ipiv, doublereal* anorm, doublereal* rcond, doublecomplex* work, integer* info);


static VALUE
rblapack_zsycon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_anorm;
  doublereal anorm; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_info;
  integer info; 
  doublecomplex *work;

  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  rcond, info = NumRu::Lapack.zsycon( uplo, a, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZSYCON estimates the reciprocal of the condition number (in the\n*  1-norm) of a complex symmetric matrix A using the factorization\n*  A = U*D*U**T or A = L*D*L**T computed by ZSYTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by ZSYTRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by ZSYTRF.\n*\n*  ANORM   (input) DOUBLE PRECISION\n*          The 1-norm of the original matrix A.\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n*          estimate of the 1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.zsycon( uplo, a, ipiv, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_anorm = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  anorm = NUM2DBL(rblapack_anorm);
  work = ALLOC_N(doublecomplex, (2*n));

  zsycon_(&uplo, &n, a, &lda, ipiv, &anorm, &rcond, work, &info);

  free(work);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_zsycon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zsycon", rblapack_zsycon, -1);
}
ruby-lapack-1.7.2/ext/zla_syrfsx_extended.c0000644000175000017500000005730512502221023020616 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zla_syrfsx_extended_(integer* prec_type, char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, logical* colequ, doublereal* c, doublecomplex* b, integer* ldb, doublecomplex* y, integer* ldy, doublereal* berr_out, integer* n_norms, doublereal* err_bnds_norm, doublereal* err_bnds_comp, doublecomplex* res, doublereal* ayb, doublecomplex* dy, doublecomplex* y_tail, doublereal* rcond, integer* ithresh, doublereal* rthresh, doublereal* dz_ub, logical* ignore_cwise, integer* info);


static VALUE
rblapack_zla_syrfsx_extended(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_prec_type;
  integer prec_type; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_colequ;
  logical colequ; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_y;
  doublecomplex *y; 
  VALUE rblapack_n_norms;
  integer n_norms; 
  VALUE rblapack_err_bnds_norm;
  doublereal *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  doublereal *err_bnds_comp; 
  VALUE rblapack_res;
  doublecomplex *res; 
  VALUE rblapack_ayb;
  doublereal *ayb; 
  VALUE rblapack_dy;
  doublecomplex *dy; 
  VALUE rblapack_y_tail;
  doublecomplex *y_tail; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_ithresh;
  integer ithresh; 
  VALUE rblapack_rthresh;
  doublereal rthresh; 
  VALUE rblapack_dz_ub;
  doublereal dz_ub; 
  VALUE rblapack_ignore_cwise;
  logical ignore_cwise; 
  VALUE rblapack_berr_out;
  doublereal *berr_out; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_y_out__;
  doublecomplex *y_out__;
  VALUE rblapack_err_bnds_norm_out__;
  doublereal *err_bnds_norm_out__;
  VALUE rblapack_err_bnds_comp_out__;
  doublereal *err_bnds_comp_out__;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldy;
  integer n_err_bnds;

  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  berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.zla_syrfsx_extended( prec_type, uplo, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZLA_SYRFSX_EXTENDED improves the computed solution to a system of\n*  linear equations by performing extra-precise iterative refinement\n*  and provides error bounds and backward error estimates for the solution.\n*  This subroutine is called by ZSYRFSX to perform iterative refinement.\n*  In addition to normwise error bound, the code provides maximum\n*  componentwise error bound if possible. See comments for ERR_BNDS_NORM\n*  and ERR_BNDS_COMP for details of the error bounds. Note that this\n*  subroutine is only resonsible for setting the second fields of\n*  ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n*  Arguments\n*  =========\n*\n*     PREC_TYPE      (input) INTEGER\n*     Specifies the intermediate precision to be used in refinement.\n*     The value is defined by ILAPREC(P) where P is a CHARACTER and\n*     P    = 'S':  Single\n*          = 'D':  Double\n*          = 'I':  Indigenous\n*          = 'X', 'E':  Extra\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N              (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NRHS           (input) INTEGER\n*     The number of right-hand-sides, i.e., the number of columns of the\n*     matrix B.\n*\n*     A              (input) COMPLEX*16 array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA            (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF             (input) COMPLEX*16 array, dimension (LDAF,N)\n*     The block diagonal matrix D and the multipliers used to\n*     obtain the factor U or L as computed by ZSYTRF.\n*\n*     LDAF           (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV           (input) INTEGER array, dimension (N)\n*     Details of the interchanges and the block structure of D\n*     as determined by ZSYTRF.\n*\n*     COLEQU         (input) LOGICAL\n*     If .TRUE. then column equilibration was done to A before calling\n*     this routine. This is needed to compute the solution and error\n*     bounds correctly.\n*\n*     C              (input) DOUBLE PRECISION array, dimension (N)\n*     The column scale factors for A. If COLEQU = .FALSE., C\n*     is not accessed. If C is input, each element of C should be a power\n*     of the radix to ensure a reliable solution and error estimates.\n*     Scaling by powers of the radix does not cause rounding errors unless\n*     the result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B              (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*     The right-hand-side matrix B.\n*\n*     LDB            (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     Y              (input/output) COMPLEX*16 array, dimension\n*                    (LDY,NRHS)\n*     On entry, the solution matrix X, as computed by ZSYTRS.\n*     On exit, the improved solution matrix Y.\n*\n*     LDY            (input) INTEGER\n*     The leading dimension of the array Y.  LDY >= max(1,N).\n*\n*     BERR_OUT       (output) DOUBLE PRECISION array, dimension (NRHS)\n*     On exit, BERR_OUT(j) contains the componentwise relative backward\n*     error for right-hand-side j from the formula\n*         max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n*     where abs(Z) is the componentwise absolute value of the matrix\n*     or vector Z. This is computed by ZLA_LIN_BERR.\n*\n*     N_NORMS        (input) INTEGER\n*     Determines which error bounds to return (see ERR_BNDS_NORM\n*     and ERR_BNDS_COMP).\n*     If N_NORMS >= 1 return normwise error bounds.\n*     If N_NORMS >= 2 return componentwise error bounds.\n*\n*     ERR_BNDS_NORM  (input/output) DOUBLE PRECISION array, dimension\n*                    (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (input/output) DOUBLE PRECISION array, dimension\n*                    (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     RES            (input) COMPLEX*16 array, dimension (N)\n*     Workspace to hold the intermediate residual.\n*\n*     AYB            (input) DOUBLE PRECISION array, dimension (N)\n*     Workspace.\n*\n*     DY             (input) COMPLEX*16 array, dimension (N)\n*     Workspace to hold the intermediate solution.\n*\n*     Y_TAIL         (input) COMPLEX*16 array, dimension (N)\n*     Workspace to hold the trailing bits of the intermediate solution.\n*\n*     RCOND          (input) DOUBLE PRECISION\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     ITHRESH        (input) INTEGER\n*     The maximum number of residual computations allowed for\n*     refinement. The default is 10. For 'aggressive' set to 100 to\n*     permit convergence using approximate factorizations or\n*     factorizations other than LU. If the factorization uses a\n*     technique other than Gaussian elimination, the guarantees in\n*     ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n*     RTHRESH        (input) DOUBLE PRECISION\n*     Determines when to stop refinement if the error estimate stops\n*     decreasing. Refinement will stop when the next solution no longer\n*     satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n*     the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n*     default value is 0.5. For 'aggressive' set to 0.9 to permit\n*     convergence on extremely ill-conditioned matrices. See LAWN 165\n*     for more details.\n*\n*     DZ_UB          (input) DOUBLE PRECISION\n*     Determines when to start considering componentwise convergence.\n*     Componentwise convergence is only considered after each component\n*     of the solution Y is stable, which we definte as the relative\n*     change in each component being less than DZ_UB. The default value\n*     is 0.25, requiring the first bit to be stable. See LAWN 165 for\n*     more details.\n*\n*     IGNORE_CWISE   (input) LOGICAL\n*     If .TRUE. then ignore componentwise convergence. Default value\n*     is .FALSE..\n*\n*     INFO           (output) INTEGER\n*       = 0:  Successful exit.\n*       < 0:  if INFO = -i, the ith argument to ZSYTRS had an illegal\n*             value\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            UPLO2, CNT, I, J, X_STATE, Z_STATE,\n     $                   Y_PREC_STATE\n      DOUBLE PRECISION   YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n     $                   DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n     $                   DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n     $                   EPS, HUGEVAL, INCR_THRESH\n      LOGICAL            INCR_PREC\n      COMPLEX*16         ZDUM\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.zla_syrfsx_extended( prec_type, uplo, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 21 && argc != 21)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 21)", argc);
  rblapack_prec_type = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_colequ = argv[5];
  rblapack_c = argv[6];
  rblapack_b = argv[7];
  rblapack_y = argv[8];
  rblapack_n_norms = argv[9];
  rblapack_err_bnds_norm = argv[10];
  rblapack_err_bnds_comp = argv[11];
  rblapack_res = argv[12];
  rblapack_ayb = argv[13];
  rblapack_dy = argv[14];
  rblapack_y_tail = argv[15];
  rblapack_rcond = argv[16];
  rblapack_ithresh = argv[17];
  rblapack_rthresh = argv[18];
  rblapack_dz_ub = argv[19];
  rblapack_ignore_cwise = argv[20];
  if (argc == 21) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  prec_type = NUM2INT(rblapack_prec_type);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (9th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 2)
    rb_raise(rb_eArgError, "rank of y (9th argument) must be %d", 2);
  ldy = NA_SHAPE0(rblapack_y);
  nrhs = NA_SHAPE1(rblapack_y);
  if (NA_TYPE(rblapack_y) != NA_DCOMPLEX)
    rblapack_y = na_change_type(rblapack_y, NA_DCOMPLEX);
  y = NA_PTR_TYPE(rblapack_y, doublecomplex*);
  if (!NA_IsNArray(rblapack_err_bnds_norm))
    rb_raise(rb_eArgError, "err_bnds_norm (11th argument) must be NArray");
  if (NA_RANK(rblapack_err_bnds_norm) != 2)
    rb_raise(rb_eArgError, "rank of err_bnds_norm (11th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_err_bnds_norm) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of y");
  n_err_bnds = NA_SHAPE1(rblapack_err_bnds_norm);
  if (NA_TYPE(rblapack_err_bnds_norm) != NA_DFLOAT)
    rblapack_err_bnds_norm = na_change_type(rblapack_err_bnds_norm, NA_DFLOAT);
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
  if (!NA_IsNArray(rblapack_res))
    rb_raise(rb_eArgError, "res (13th argument) must be NArray");
  if (NA_RANK(rblapack_res) != 1)
    rb_raise(rb_eArgError, "rank of res (13th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_res) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_res) != NA_DCOMPLEX)
    rblapack_res = na_change_type(rblapack_res, NA_DCOMPLEX);
  res = NA_PTR_TYPE(rblapack_res, doublecomplex*);
  if (!NA_IsNArray(rblapack_dy))
    rb_raise(rb_eArgError, "dy (15th argument) must be NArray");
  if (NA_RANK(rblapack_dy) != 1)
    rb_raise(rb_eArgError, "rank of dy (15th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dy) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_dy) != NA_DCOMPLEX)
    rblapack_dy = na_change_type(rblapack_dy, NA_DCOMPLEX);
  dy = NA_PTR_TYPE(rblapack_dy, doublecomplex*);
  rcond = NUM2DBL(rblapack_rcond);
  rthresh = NUM2DBL(rblapack_rthresh);
  ignore_cwise = (rblapack_ignore_cwise == Qtrue);
  uplo = StringValueCStr(rblapack_uplo)[0];
  colequ = (rblapack_colequ == Qtrue);
  n_norms = NUM2INT(rblapack_n_norms);
  if (!NA_IsNArray(rblapack_ayb))
    rb_raise(rb_eArgError, "ayb (14th argument) must be NArray");
  if (NA_RANK(rblapack_ayb) != 1)
    rb_raise(rb_eArgError, "rank of ayb (14th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ayb) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ayb) != NA_DFLOAT)
    rblapack_ayb = na_change_type(rblapack_ayb, NA_DFLOAT);
  ayb = NA_PTR_TYPE(rblapack_ayb, doublereal*);
  ithresh = NUM2INT(rblapack_ithresh);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  if (!NA_IsNArray(rblapack_err_bnds_comp))
    rb_raise(rb_eArgError, "err_bnds_comp (12th argument) must be NArray");
  if (NA_RANK(rblapack_err_bnds_comp) != 2)
    rb_raise(rb_eArgError, "rank of err_bnds_comp (12th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_err_bnds_comp) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of y");
  if (NA_SHAPE1(rblapack_err_bnds_comp) != n_err_bnds)
    rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_comp must be the same as shape 1 of err_bnds_norm");
  if (NA_TYPE(rblapack_err_bnds_comp) != NA_DFLOAT)
    rblapack_err_bnds_comp = na_change_type(rblapack_err_bnds_comp, NA_DFLOAT);
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
  dz_ub = NUM2DBL(rblapack_dz_ub);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of y");
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  if (!NA_IsNArray(rblapack_y_tail))
    rb_raise(rb_eArgError, "y_tail (16th argument) must be NArray");
  if (NA_RANK(rblapack_y_tail) != 1)
    rb_raise(rb_eArgError, "rank of y_tail (16th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y_tail) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_y_tail) != NA_DCOMPLEX)
    rblapack_y_tail = na_change_type(rblapack_y_tail, NA_DCOMPLEX);
  y_tail = NA_PTR_TYPE(rblapack_y_tail, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr_out = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr_out = NA_PTR_TYPE(rblapack_berr_out, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldy;
    shape[1] = nrhs;
    rblapack_y_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublecomplex*);
  MEMCPY(y_out__, y, doublecomplex, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm_out__ = NA_PTR_TYPE(rblapack_err_bnds_norm_out__, doublereal*);
  MEMCPY(err_bnds_norm_out__, err_bnds_norm, doublereal, NA_TOTAL(rblapack_err_bnds_norm));
  rblapack_err_bnds_norm = rblapack_err_bnds_norm_out__;
  err_bnds_norm = err_bnds_norm_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp_out__ = NA_PTR_TYPE(rblapack_err_bnds_comp_out__, doublereal*);
  MEMCPY(err_bnds_comp_out__, err_bnds_comp, doublereal, NA_TOTAL(rblapack_err_bnds_comp));
  rblapack_err_bnds_comp = rblapack_err_bnds_comp_out__;
  err_bnds_comp = err_bnds_comp_out__;

  zla_syrfsx_extended_(&prec_type, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_err_bnds_norm, rblapack_err_bnds_comp);
}

void
init_lapack_zla_syrfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zla_syrfsx_extended", rblapack_zla_syrfsx_extended, -1);
}
ruby-lapack-1.7.2/ext/zunghr.c0000644000175000017500000001302012502221021016027 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zunghr_(integer* n, integer* ilo, integer* ihi, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zunghr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *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  work, info, a = NumRu::Lapack.zunghr( ilo, ihi, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZUNGHR generates a complex unitary matrix Q which is defined as the\n*  product of IHI-ILO elementary reflectors of order N, as returned by\n*  ZGEHRD:\n*\n*  Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix Q. N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          ILO and IHI must have the same values as in the previous call\n*          of ZGEHRD. Q is equal to the unit matrix except in the\n*          submatrix Q(ilo+1:ihi,ilo+1:ihi).\n*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the vectors which define the elementary reflectors,\n*          as returned by ZGEHRD.\n*          On exit, the N-by-N unitary matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  TAU     (input) COMPLEX*16 array, dimension (N-1)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by ZGEHRD.\n*\n*  WORK    (workspace/output) COMPLEX*16 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 >= IHI-ILO.\n*          For optimum performance LWORK >= (IHI-ILO)*NB, where NB is\n*          the 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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, a = NumRu::Lapack.zunghr( ilo, ihi, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_ilo = argv[0];
  rblapack_ihi = argv[1];
  rblapack_a = argv[2];
  rblapack_tau = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  ihi = NUM2INT(rblapack_ihi);
  if (rblapack_lwork == Qnil)
    lwork = ihi-ilo;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_tau) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", n-1);
  if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zunghr_(&n, &ilo, &ihi, a, &lda, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_zunghr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zunghr", rblapack_zunghr, -1);
}
ruby-lapack-1.7.2/ext/zgttrs.c0000644000175000017500000001666012502221017016071 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgttrs_(char* trans, integer* n, integer* nrhs, doublecomplex* dl, doublecomplex* d, doublecomplex* du, doublecomplex* du2, integer* ipiv, doublecomplex* b, integer* ldb, integer* info);


static VALUE
rblapack_zgttrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_dl;
  doublecomplex *dl; 
  VALUE rblapack_d;
  doublecomplex *d; 
  VALUE rblapack_du;
  doublecomplex *du; 
  VALUE rblapack_du2;
  doublecomplex *du2; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.zgttrs( trans, dl, d, du, du2, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGTTRS solves one of the systems of equations\n*     A * X = B,  A**T * X = B,  or  A**H * X = B,\n*  with a tridiagonal matrix A using the LU factorization computed\n*  by ZGTTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations.\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  DL      (input) COMPLEX*16 array, dimension (N-1)\n*          The (n-1) multipliers that define the matrix L from the\n*          LU factorization of A.\n*\n*  D       (input) COMPLEX*16 array, dimension (N)\n*          The n diagonal elements of the upper triangular matrix U from\n*          the LU factorization of A.\n*\n*  DU      (input) COMPLEX*16 array, dimension (N-1)\n*          The (n-1) elements of the first super-diagonal of U.\n*\n*  DU2     (input) COMPLEX*16 array, dimension (N-2)\n*          The (n-2) elements of the second super-diagonal of U.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices; for 1 <= i <= n, row i of the matrix was\n*          interchanged with row IPIV(i).  IPIV(i) will always be either\n*          i or i+1; IPIV(i) = i indicates a row interchange was not\n*          required.\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the matrix of right hand side vectors B.\n*          On exit, B is overwritten by the solution vectors X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -k, the k-th argument had an illegal value\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            NOTRAN\n      INTEGER            ITRANS, J, JB, NB\n*     ..\n*     .. External Functions ..\n      INTEGER            ILAENV\n      EXTERNAL           ILAENV\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZGTTS2\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.zgttrs( trans, dl, d, du, du2, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_trans = argv[0];
  rblapack_dl = argv[1];
  rblapack_d = argv[2];
  rblapack_du = argv[3];
  rblapack_du2 = argv[4];
  rblapack_ipiv = argv[5];
  rblapack_b = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DCOMPLEX)
    rblapack_d = na_change_type(rblapack_d, NA_DCOMPLEX);
  d = NA_PTR_TYPE(rblapack_d, doublecomplex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_DCOMPLEX)
    rblapack_dl = na_change_type(rblapack_dl, NA_DCOMPLEX);
  dl = NA_PTR_TYPE(rblapack_dl, doublecomplex*);
  if (!NA_IsNArray(rblapack_du2))
    rb_raise(rb_eArgError, "du2 (5th argument) must be NArray");
  if (NA_RANK(rblapack_du2) != 1)
    rb_raise(rb_eArgError, "rank of du2 (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du2) != (n-2))
    rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
  if (NA_TYPE(rblapack_du2) != NA_DCOMPLEX)
    rblapack_du2 = na_change_type(rblapack_du2, NA_DCOMPLEX);
  du2 = NA_PTR_TYPE(rblapack_du2, doublecomplex*);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (4th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_DCOMPLEX)
    rblapack_du = na_change_type(rblapack_du, NA_DCOMPLEX);
  du = NA_PTR_TYPE(rblapack_du, doublecomplex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zgttrs_(&trans, &n, &nrhs, dl, d, du, du2, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_zgttrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgttrs", rblapack_zgttrs, -1);
}
ruby-lapack-1.7.2/ext/zlarfgp.c0000644000175000017500000001032612502221014016167 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlarfgp_(integer* n, doublecomplex* alpha, doublecomplex* x, integer* incx, doublecomplex* tau);


static VALUE
rblapack_zlarfgp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_alpha;
  doublecomplex alpha; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_tau;
  doublecomplex tau; 
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;


  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, alpha, x = NumRu::Lapack.zlarfgp( n, alpha, x, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLARFGP( N, ALPHA, X, INCX, TAU )\n\n*  Purpose\n*  =======\n*\n*  ZLARFGP generates a complex elementary reflector H of order n, such\n*  that\n*\n*        H' * ( alpha ) = ( beta ),   H' * H = I.\n*             (   x   )   (   0  )\n*\n*  where alpha and beta are scalars, beta is real and non-negative, and\n*  x is an (n-1)-element complex vector.  H is represented in the form\n*\n*        H = I - tau * ( 1 ) * ( 1 v' ) ,\n*                      ( v )\n*\n*  where tau is a complex scalar and v is a complex (n-1)-element\n*  vector. Note that H is not hermitian.\n*\n*  If the elements of x are all zero and alpha is real, then tau = 0\n*  and H is taken to be the unit matrix.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the elementary reflector.\n*\n*  ALPHA   (input/output) COMPLEX*16\n*          On entry, the value alpha.\n*          On exit, it is overwritten with the value beta.\n*\n*  X       (input/output) COMPLEX*16 array, dimension\n*                         (1+(N-2)*abs(INCX))\n*          On entry, the vector x.\n*          On exit, it is overwritten with the vector v.\n*\n*  INCX    (input) INTEGER\n*          The increment between elements of X. INCX > 0.\n*\n*  TAU     (output) COMPLEX*16\n*          The value tau.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, alpha, x = NumRu::Lapack.zlarfgp( n, alpha, x, incx, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_n = argv[0];
  rblapack_alpha = argv[1];
  rblapack_x = argv[2];
  rblapack_incx = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  incx = NUM2INT(rblapack_incx);
  alpha.r = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
  alpha.i = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (3th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1+(n-2)*abs(incx)))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-2)*abs(incx));
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-2)*abs(incx);
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;

  zlarfgp_(&n, &alpha, x, &incx, &tau);

  rblapack_tau = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(tau.r)), rb_float_new((double)(tau.i)));
  rblapack_alpha = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(alpha.r)), rb_float_new((double)(alpha.i)));
  return rb_ary_new3(3, rblapack_tau, rblapack_alpha, rblapack_x);
}

void
init_lapack_zlarfgp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlarfgp", rblapack_zlarfgp, -1);
}
ruby-lapack-1.7.2/ext/dpotri.c0000644000175000017500000000735712502221012016033 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dpotri_(char* uplo, integer* n, doublereal* a, integer* lda, integer* info);


static VALUE
rblapack_dpotri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  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  info, a = NumRu::Lapack.dpotri( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPOTRI( UPLO, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPOTRI computes the inverse of a real symmetric positive definite\n*  matrix A using the Cholesky factorization A = U**T*U or A = L*L**T\n*  computed by DPOTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the triangular factor U or L from the Cholesky\n*          factorization A = U**T*U or A = L*L**T, as computed by\n*          DPOTRF.\n*          On exit, the upper or lower triangle of the (symmetric)\n*          inverse of A, overwriting the input factor U or L.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\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,i) element of the factor U or L is\n*                zero, and the inverse could not be computed.\n*\n\n*  =====================================================================\n*\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DLAUUM, DTRTRI, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.dpotri( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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*);
  {
    na_shape_t 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__;

  dpotri_(&uplo, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_dpotri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dpotri", rblapack_dpotri, -1);
}
ruby-lapack-1.7.2/ext/zla_lin_berr.c0000644000175000017500000001131312502221017017164 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zla_lin_berr_(integer* n, integer* nz, integer* nrhs, doublereal* res, doublereal* ayb, doublecomplex* berr);


static VALUE
rblapack_zla_lin_berr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_nz;
  integer nz; 
  VALUE rblapack_res;
  doublereal *res; 
  VALUE rblapack_ayb;
  doublereal *ayb; 
  VALUE rblapack_berr;
  doublecomplex *berr; 

  integer n;
  integer nrhs;

  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  berr = NumRu::Lapack.zla_lin_berr( nz, res, ayb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR )\n\n*  Purpose\n*  =======\n*\n*     ZLA_LIN_BERR computes componentwise relative backward error from\n*     the formula\n*         max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n*     where abs(Z) is the componentwise absolute value of the matrix\n*     or vector Z.\n*\n\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NZ      (input) INTEGER\n*     We add (NZ+1)*SLAMCH( 'Safe minimum' ) to R(i) in the numerator to\n*     guard against spuriously zero residuals. Default value is N.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices AYB, RES, and BERR.  NRHS >= 0.\n*\n*     RES    (input) DOUBLE PRECISION array, dimension (N,NRHS)\n*     The residual matrix, i.e., the matrix R in the relative backward\n*     error formula above.\n*\n*     AYB    (input) DOUBLE PRECISION array, dimension (N, NRHS)\n*     The denominator in the relative backward error formula above, i.e.,\n*     the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B\n*     are from iterative refinement (see zla_gerfsx_extended.f).\n*     \n*     BERR   (output) COMPLEX*16 array, dimension (NRHS)\n*     The componentwise relative backward error from the formula above.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      DOUBLE PRECISION   TMP\n      INTEGER            I, J\n      COMPLEX*16         CDUM\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, REAL, DIMAG, MAX\n*     ..\n*     .. External Functions ..\n      EXTERNAL           DLAMCH\n      DOUBLE PRECISION   DLAMCH\n      DOUBLE PRECISION   SAFE1\n*     ..\n*     .. Statement Functions ..\n      COMPLEX*16         CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  berr = NumRu::Lapack.zla_lin_berr( nz, res, ayb, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_nz = argv[0];
  rblapack_res = argv[1];
  rblapack_ayb = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  nz = NUM2INT(rblapack_nz);
  if (!NA_IsNArray(rblapack_ayb))
    rb_raise(rb_eArgError, "ayb (3th argument) must be NArray");
  if (NA_RANK(rblapack_ayb) != 2)
    rb_raise(rb_eArgError, "rank of ayb (3th argument) must be %d", 2);
  n = NA_SHAPE0(rblapack_ayb);
  nrhs = NA_SHAPE1(rblapack_ayb);
  if (NA_TYPE(rblapack_ayb) != NA_DFLOAT)
    rblapack_ayb = na_change_type(rblapack_ayb, NA_DFLOAT);
  ayb = NA_PTR_TYPE(rblapack_ayb, doublereal*);
  if (!NA_IsNArray(rblapack_res))
    rb_raise(rb_eArgError, "res (2th argument) must be NArray");
  if (NA_RANK(rblapack_res) != 2)
    rb_raise(rb_eArgError, "rank of res (2th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_res) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 0 of ayb");
  if (NA_SHAPE1(rblapack_res) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of res must be the same as shape 1 of ayb");
  if (NA_TYPE(rblapack_res) != NA_DFLOAT)
    rblapack_res = na_change_type(rblapack_res, NA_DFLOAT);
  res = NA_PTR_TYPE(rblapack_res, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublecomplex*);

  zla_lin_berr_(&n, &nz, &nrhs, res, ayb, berr);

  return rblapack_berr;
}

void
init_lapack_zla_lin_berr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zla_lin_berr", rblapack_zla_lin_berr, -1);
}
ruby-lapack-1.7.2/ext/ssyrfs.c0000644000175000017500000002127012502221024016054 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssyrfs_(char* uplo, integer* n, integer* nrhs, real* a, integer* lda, real* af, integer* ldaf, integer* ipiv, real* b, integer* ldb, real* x, integer* ldx, real* ferr, real* berr, real* work, integer* iwork, integer* info);


static VALUE
rblapack_ssyrfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_af;
  real *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  real *x_out__;
  real *work;
  integer *iwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.ssyrfs( uplo, a, af, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSYRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is symmetric indefinite, and\n*  provides error bounds and backward error estimates for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input) REAL array, dimension (LDA,N)\n*          The symmetric matrix A.  If UPLO = 'U', the leading N-by-N\n*          upper triangular part of A contains the upper triangular part\n*          of the matrix A, and the strictly lower triangular part of A\n*          is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*          triangular part of A contains the lower triangular part of\n*          the matrix A, and the strictly upper triangular part of A is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AF      (input) REAL array, dimension (LDAF,N)\n*          The factored form of the matrix A.  AF contains the block\n*          diagonal matrix D and the multipliers used to obtain the\n*          factor U or L from the factorization A = U*D*U**T or\n*          A = L*D*L**T as computed by SSYTRF.\n*\n*  LDAF    (input) INTEGER\n*          The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by SSYTRF.\n*\n*  B       (input) REAL array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) REAL array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by SSYTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) REAL array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.ssyrfs( uplo, a, af, ipiv, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_b = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_SFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
  af = NA_PTR_TYPE(rblapack_af, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(real, (3*n));
  iwork = ALLOC_N(integer, (n));

  ssyrfs_(&uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_ssyrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssyrfs", rblapack_ssyrfs, -1);
}
ruby-lapack-1.7.2/ext/cptsv.c0000644000175000017500000001354412502221025015670 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cptsv_(integer* n, integer* nrhs, real* d, complex* e, complex* b, integer* ldb, integer* info);


static VALUE
rblapack_cptsv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  complex *e; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_e_out__;
  complex *e_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer n;
  integer ldb;
  integer nrhs;

  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  info, d, e, b = NumRu::Lapack.cptsv( d, e, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPTSV( N, NRHS, D, E, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPTSV computes the solution to a complex system of linear equations\n*  A*X = B, where A is an N-by-N Hermitian positive definite tridiagonal\n*  matrix, and X and B are N-by-NRHS matrices.\n*\n*  A is factored as A = L*D*L**H, and the factored form of A is then\n*  used to solve the system of equations.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  D       (input/output) REAL array, dimension (N)\n*          On entry, the n diagonal elements of the tridiagonal matrix\n*          A.  On exit, the n diagonal elements of the diagonal matrix\n*          D from the factorization A = L*D*L**H.\n*\n*  E       (input/output) COMPLEX array, dimension (N-1)\n*          On entry, the (n-1) subdiagonal elements of the tridiagonal\n*          matrix A.  On exit, the (n-1) subdiagonal elements of the\n*          unit bidiagonal factor L from the L*D*L**H factorization of\n*          A.  E can also be regarded as the superdiagonal of the unit\n*          bidiagonal factor U from the U**H*D*U factorization of A.\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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 leading minor of order i is not\n*                positive definite, and the solution has not been\n*                computed.  The factorization has not been completed\n*                unless i = N.\n*\n\n*  =====================================================================\n*\n*     .. External Subroutines ..\n      EXTERNAL           CPTTRF, CPTTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, e, b = NumRu::Lapack.cptsv( d, e, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_d = argv[0];
  rblapack_e = argv[1];
  rblapack_b = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  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);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (2th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SCOMPLEX)
    rblapack_e = na_change_type(rblapack_e, NA_SCOMPLEX);
  e = NA_PTR_TYPE(rblapack_e, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, complex*);
  MEMCPY(e_out__, e, complex, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  cptsv_(&n, &nrhs, d, e, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_e, rblapack_b);
}

void
init_lapack_cptsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cptsv", rblapack_cptsv, -1);
}
ruby-lapack-1.7.2/ext/zsyconv.c0000644000175000017500000001072612502221015016242 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zsyconv_(char* uplo, char* way, integer* n, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* work, integer* info);


static VALUE
rblapack_zsyconv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_way;
  char way; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  doublecomplex *work;

  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  info = NumRu::Lapack.zsyconv( uplo, way, a, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSYCONV( UPLO, WAY, N, A, LDA, IPIV, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZSYCONV converts A given by ZHETRF into L and D or vice-versa.\n*  Get nondiagonal elements of D (returned in workspace) and \n*  apply or reverse permutation done in TRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n* \n*  WAY     (input) CHARACTER*1\n*          = 'C': Convert \n*          = 'R': Revert\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) DOUBLE COMPLEX array, dimension (LDA,N)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by ZSYTRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by ZSYTRF.\n*\n* WORK     (workspace) DOUBLE COMPLEX array, dimension (N)\n*\n* LWORK    (input) INTEGER\n*          The length of WORK.  LWORK >=1. \n*          LWORK = N\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info = NumRu::Lapack.zsyconv( uplo, way, a, ipiv, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_way = argv[1];
  rblapack_a = argv[2];
  rblapack_ipiv = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  way = StringValueCStr(rblapack_way)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  work = ALLOC_N(doublecomplex, (MAX(1,n)));

  zsyconv_(&uplo, &way, &n, a, &lda, ipiv, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rblapack_info;
}

void
init_lapack_zsyconv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zsyconv", rblapack_zsyconv, -1);
}
ruby-lapack-1.7.2/ext/zlaqhb.c0000644000175000017500000001251212502221021016000 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlaqhb_(char* uplo, integer* n, integer* kd, doublecomplex* ab, integer* ldab, doublereal* s, doublereal* scond, doublereal* amax, char* equed);


static VALUE
rblapack_zlaqhb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_scond;
  doublereal scond; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_ab_out__;
  doublecomplex *ab_out__;

  integer ldab;
  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  s, equed, ab = NumRu::Lapack.zlaqhb( uplo, kd, ab, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAQHB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )\n\n*  Purpose\n*  =======\n*\n*  ZLAQHB equilibrates a symmetric band matrix A using the scaling\n*  factors in the vector S.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of super-diagonals of the matrix A if UPLO = 'U',\n*          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*          On exit, if INFO = 0, the triangular factor U or L from the\n*          Cholesky factorization A = U'*U or A = L*L' of the band\n*          matrix A, in the same storage format as A.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  S       (output) DOUBLE PRECISION array, dimension (N)\n*          The scale factors for A.\n*\n*  SCOND   (input) DOUBLE PRECISION\n*          Ratio of the smallest S(i) to the largest S(i).\n*\n*  AMAX    (input) DOUBLE PRECISION\n*          Absolute value of largest matrix entry.\n*\n*  EQUED   (output) CHARACTER*1\n*          Specifies whether or not equilibration was done.\n*          = 'N':  No equilibration.\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*\n*  Internal Parameters\n*  ===================\n*\n*  THRESH is a threshold value used to decide if scaling should be done\n*  based on the ratio of the scaling factors.  If SCOND < THRESH,\n*  scaling is done.\n*\n*  LARGE and SMALL are threshold values used to decide if scaling should\n*  be done based on the absolute size of the largest matrix element.\n*  If AMAX > LARGE or AMAX < SMALL, scaling is done.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, equed, ab = NumRu::Lapack.zlaqhb( uplo, kd, ab, scond, amax, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  rblapack_scond = argv[3];
  rblapack_amax = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  amax = NUM2DBL(rblapack_amax);
  kd = NUM2INT(rblapack_kd);
  scond = NUM2DBL(rblapack_scond);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
  MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  zlaqhb_(&uplo, &n, &kd, ab, &ldab, s, &scond, &amax, &equed);

  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(3, rblapack_s, rblapack_equed, rblapack_ab);
}

void
init_lapack_zlaqhb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlaqhb", rblapack_zlaqhb, -1);
}
ruby-lapack-1.7.2/ext/csyconv.c0000644000175000017500000001063612502221025016214 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID csyconv_(char* uplo, char* way, integer* n, complex* a, integer* lda, integer* ipiv, complex* work, integer* info);


static VALUE
rblapack_csyconv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_way;
  char way; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  complex *work;

  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  info = NumRu::Lapack.csyconv( uplo, way, a, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSYCONV( UPLO, WAY, N, A, LDA, IPIV, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CSYCONV convert A given by TRF into L and D and vice-versa.\n*  Get Non-diag elements of D (returned in workspace) and \n*  apply or reverse permutation done in TRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n* \n*  WAY     (input) CHARACTER*1\n*          = 'C': Convert \n*          = 'R': Revert\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by CSYTRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by CSYTRF.\n*\n* WORK     (workspace) COMPLEX array, dimension (N)\n*\n* LWORK    (input) INTEGER\n*          The length of WORK.  LWORK >=1. \n*          LWORK = N\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info = NumRu::Lapack.csyconv( uplo, way, a, ipiv, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_way = argv[1];
  rblapack_a = argv[2];
  rblapack_ipiv = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  way = StringValueCStr(rblapack_way)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  work = ALLOC_N(complex, (MAX(1,n)));

  csyconv_(&uplo, &way, &n, a, &lda, ipiv, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rblapack_info;
}

void
init_lapack_csyconv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "csyconv", rblapack_csyconv, -1);
}
ruby-lapack-1.7.2/ext/clarf.c0000644000175000017500000001161312502221024015612 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clarf_(char* side, integer* m, integer* n, complex* v, integer* incv, complex* tau, complex* c, integer* ldc, complex* work);


static VALUE
rblapack_clarf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_v;
  complex *v; 
  VALUE rblapack_incv;
  integer incv; 
  VALUE rblapack_tau;
  complex tau; 
  VALUE rblapack_c;
  complex *c; 
  VALUE rblapack_c_out__;
  complex *c_out__;
  complex *work;

  integer ldc;
  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  c = NumRu::Lapack.clarf( side, m, v, incv, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )\n\n*  Purpose\n*  =======\n*\n*  CLARF applies a complex elementary reflector H to a complex M-by-N\n*  matrix C, from either the left or the right. H is represented in the\n*  form\n*\n*        H = I - tau * v * v'\n*\n*  where tau is a complex scalar and v is a complex vector.\n*\n*  If tau = 0, then H is taken to be the unit matrix.\n*\n*  To apply H' (the conjugate transpose of H), supply conjg(tau) instead\n*  tau.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': form  H * C\n*          = 'R': form  C * H\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C.\n*\n*  V       (input) COMPLEX array, dimension\n*                     (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n*                  or (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n*          The vector v in the representation of H. V is not used if\n*          TAU = 0.\n*\n*  INCV    (input) INTEGER\n*          The increment between elements of v. INCV <> 0.\n*\n*  TAU     (input) COMPLEX\n*          The value tau in the representation of H.\n*\n*  C       (input/output) COMPLEX array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n*          or C * H if SIDE = 'R'.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) COMPLEX array, dimension\n*                         (N) if SIDE = 'L'\n*                      or (M) if SIDE = 'R'\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.clarf( side, m, v, incv, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_m = argv[1];
  rblapack_v = argv[2];
  rblapack_incv = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  incv = NUM2INT(rblapack_incv);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, complex*);
  m = NUM2INT(rblapack_m);
  tau.r = (real)NUM2DBL(rb_funcall(rblapack_tau, rb_intern("real"), 0));
  tau.i = (real)NUM2DBL(rb_funcall(rblapack_tau, rb_intern("imag"), 0));
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (3th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 1)
    rb_raise(rb_eArgError, "rank of v (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_v) != (1 + (m-1)*abs(incv)))
    rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1 + (m-1)*abs(incv));
  if (NA_TYPE(rblapack_v) != NA_SCOMPLEX)
    rblapack_v = na_change_type(rblapack_v, NA_SCOMPLEX);
  v = NA_PTR_TYPE(rblapack_v, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
  MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(complex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  clarf_(&side, &m, &n, v, &incv, &tau, c, &ldc, work);

  free(work);
  return rblapack_c;
}

void
init_lapack_clarf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clarf", rblapack_clarf, -1);
}
ruby-lapack-1.7.2/ext/sgejsv.c0000644000175000017500000022117312502221021016025 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgejsv_(char* joba, char* jobu, char* jobv, char* jobr, char* jobt, char* jobp, integer* m, integer* n, real* a, integer* lda, real* sva, real* u, integer* ldu, real* v, integer* ldv, real* work, integer* lwork, integer* iwork, integer* info);


static VALUE
rblapack_sgejsv(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;
  real *a; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_sva;
  real *sva; 
  VALUE rblapack_u;
  real *u; 
  VALUE rblapack_v;
  real *v; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_work_out__;
  real *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.sgejsv( joba, jobu, jobv, jobr, jobt, jobp, m, a, work, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, M, N, A, LDA, SVA, U, LDU, V, LDV, WORK, LWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*  SGEJSV 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 SQRT(BIG), BIG=SLAMCH('O'), then JOBR issues\n*         the licence to kill columns of A whose norm in c*A is less than\n*         SQRT(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 SGESVJ.\n*       = 'R': RESTRICTED range for sigma(c*A) is [SQRT(SFMIN), SQRT(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 SGESVJ.\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) REAL 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) REAL 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) REAL 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) REAL 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) REAL 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 SQRT(||(R^t * R)^(-1)||_1).\n*                    It is computed using SPOCON. 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 :  SGEJSV  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*  SGEJSV 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 SGEJSV 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 (SGEJSV) 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 (SGESVJ) 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 SGEJSV 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 SGEJSV 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      REAL        ZERO,         ONE\n      PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )\n*     ..\n*     .. Local Scalars ..\n      REAL    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 ABS,  ALOG, AMAX1, AMIN1, FLOAT,\n     &          MAX0, MIN0, NINT,  SIGN,  SQRT\n*     ..\n*     .. External Functions ..\n      REAL      SLAMCH, SNRM2\n      INTEGER   ISAMAX\n      LOGICAL   LSAME\n      EXTERNAL  ISAMAX, LSAME, SLAMCH, SNRM2\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL  SCOPY,  SGELQF, SGEQP3, SGEQRF, SLACPY, SLASCL,\n     &          SLASET, SLASSQ, SLASWP, SORGQR, SORMLQ,\n     &          SORMQR, SPOCON, SSCAL,  SSWAP,  STRSM,  XERBLA\n*\n      EXTERNAL  SGESVJ\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( 'SGEJSV', - 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 SLAMCH() does not fail on the target architecture.\n*\n      EPSLN = SLAMCH('Epsilon')\n      SFMIN = SLAMCH('SafeMinimum')\n      SMALL = SFMIN / EPSLN\n      BIG   = SLAMCH('O')\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 / SQRT(FLOAT(M)*FLOAT(N))\n      NOSCAL  = .TRUE.\n      GOSCAL  = .TRUE.\n      DO 1874 p = 1, N\n         AAPP = ZERO\n         AAQQ = ONE\n         CALL SLASSQ( M, A(1,p), 1, AAPP, AAQQ )\n         IF ( AAPP .GT. BIG ) THEN\n            INFO = - 9\n            CALL XERBLA( 'SGEJSV', -INFO )\n            RETURN\n         END IF\n         AAQQ = SQRT(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 SSCAL( 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 = AMAX1( AAPP, SVA(p) )\n         IF ( SVA(p) .NE. ZERO ) AAQQ = AMIN1( 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 SLASET( 'G', M, N1, ZERO, ONE, U, LDU )\n         IF ( RSVEC ) CALL SLASET( '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 SLASCL( 'G',0,0,SVA(1),SCALEM, M,1,A(1,1),LDA,IERR )\n            CALL SLACPY( '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 SGEQRF( M, N, U,LDU, WORK, WORK(N+1),LWORK-N,IERR )\n               CALL SORGQR( M,N1,1, U,LDU,WORK,WORK(N+1),LWORK-N,IERR )\n               CALL SCOPY( 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 SLASSQ( N, A(p,1), LDA, XSC, TEMP1 )\n*              SLASSQ 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*SQRT(TEMP1))\n               AATMAX = AMAX1( AATMAX, WORK(N+p) )\n               IF (WORK(N+p) .NE. ZERO) AATMIN = AMIN1(AATMIN,WORK(N+p))\n 1950       CONTINUE\n         ELSE\n            DO 1904 p = 1, M\n               WORK(M+N+p) = SCALEM*ABS( A(p,ISAMAX(N,A(p,1),LDA)) )\n               AATMAX = AMAX1( AATMAX, WORK(M+N+p) )\n               AATMIN = AMIN1( 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 SLASSQ( 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 * ALOG(BIG1)\n 1113    CONTINUE\n         ENTRA = - ENTRA / ALOG(FLOAT(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 * ALOG(BIG1)\n 1114    CONTINUE\n         ENTRAT = - ENTRAT / ALOG(FLOAT(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 SQRT(BIG) -- the matrix is scaled so that its maximal column\n*     has Euclidean norm equal to SQRT(BIG/N). The only reason to keep\n*     SQRT(BIG) instead of BIG is the fact that SGEJSV 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 SGESVJ will compute them. So, in that case,\n*     one should use SGESVJ instead of SGEJSV.\n*\n      BIG1   = SQRT( BIG )\n      TEMP1  = SQRT( BIG / FLOAT(N) )\n*\n      CALL SLASCL( '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 SLASCL( '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. SQRT(BIG)/SQRT(SFMIN).\n         XSC = SQRT( 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. SQRT(BIG/N) * EPSLN / SFMIN,\n*        as a precaution measure, the full SVD is computed using SGESVJ\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.SQRT(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 SLASET( '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 = ISAMAX( 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 SLASWP( 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 SGEQP3 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 SGEQP3 improves overal performance of SGEJSV.\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 SGEQP3( 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 SGEJSV 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 = SQRT(FLOAT(N))*EPSLN\n         DO 3001 p = 2, N\n            IF ( ABS(A(p,p)) .GE. (TEMP1*ABS(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 = SQRT(SFMIN)\n         DO 3401 p = 2, N\n            IF ( ( ABS(A(p,p)) .LT. (EPSLN*ABS(A(p-1,p-1))) ) .OR.\n     &           ( ABS(A(p,p)) .LT. SMALL ) .OR.\n     &           ( L2KILL .AND. (ABS(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  = SQRT(SFMIN)\n         DO 3301 p = 2, N\n            IF ( ( ABS(A(p,p)) .LT. SMALL ) .OR.\n     &           ( L2KILL .AND. (ABS(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  = ABS(A(p,p)) / SVA(IWORK(p))\n            MAXPRJ = AMIN1( MAXPRJ, TEMP1 )\n 3051    CONTINUE\n         IF ( MAXPRJ**2 .GE. ONE - FLOAT(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 SLACPY( 'U', N, N, A, LDA, V, LDV )\n               DO 3053 p = 1, N\n                  TEMP1 = SVA(IWORK(p))\n                  CALL SSCAL( p, ONE/TEMP1, V(1,p), 1 )\n 3053          CONTINUE\n               CALL SPOCON( '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 SLACPY( 'U', N, N, A, LDA, U, LDU )\n               DO 3054 p = 1, N\n                  TEMP1 = SVA(IWORK(p))\n                  CALL SSCAL( p, ONE/TEMP1, U(1,p), 1 )\n 3054          CONTINUE\n               CALL SPOCON( 'U', N, U, LDU, ONE, TEMP1,\n     &              WORK(N+1), IWORK(2*N+M+1), IERR )\n            ELSE\n               CALL SLACPY( 'U', N, N, A, LDA, WORK(N+1), N )\n               DO 3052 p = 1, N\n                  TEMP1 = SVA(IWORK(p))\n                  CALL SSCAL( 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 SPOCON( '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 / SQRT(TEMP1)\n*           SCONDA is an estimate of SQRT(||(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. ( ABS( A(1,1)/A(NR,NR) ) .GT. SQRT(BIG1) )\n*     If there is no violent scaling, artificial perturbation is not needed.\n*\n*     Phase 3:\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 SCOPY( 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 = SQRT(SMALL)\n               XSC = EPSLN / FLOAT(N)\n               DO 4947 q = 1, NR\n                  TEMP1 = XSC*ABS(A(q,q))\n                  DO 4949 p = 1, N\n                     IF ( ( (p.GT.q) .AND. (ABS(A(p,q)).LE.TEMP1) )\n     &                    .OR. ( p .LT. q ) )\n     &                     A(p,q) = SIGN( TEMP1, A(p,q) )\n 4949             CONTINUE\n 4947          CONTINUE\n            ELSE\n               CALL SLASET( '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 SGEQRF( 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 SCOPY( 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 = SQRT(SMALL)\n               XSC = EPSLN / FLOAT(N)\n               DO 1947 q = 1, NR\n                  TEMP1 = XSC*ABS(A(q,q))\n                  DO 1949 p = 1, NR\n                     IF ( ( (p.GT.q) .AND. (ABS(A(p,q)).LE.TEMP1) )\n     &                       .OR. ( p .LT. q ) )\n     &                   A(p,q) = SIGN( TEMP1, A(p,q) )\n 1949             CONTINUE\n 1947          CONTINUE\n            ELSE\n               CALL SLASET( '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 SGESVJ( 'L', 'NoU', 'NoV', NR, NR, A, LDA, SVA,\n     &                      N, V, LDV, WORK, LWORK, INFO )\n*\n            SCALEM  = WORK(1)\n            NUMRANK = NINT(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 SCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 )\n 1998       CONTINUE\n            CALL SLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n*\n            CALL SGESVJ( 'L','U','N', N, NR, V,LDV, SVA, NR, A,LDA,\n     &                  WORK, LWORK, INFO )\n            SCALEM  = WORK(1)\n            NUMRANK = NINT(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 SLASET( 'Lower', NR-1, NR-1, ZERO, ZERO, A(2,1), LDA )\n            CALL SGELQF( NR, N, A, LDA, WORK, WORK(N+1), LWORK-N, IERR)\n            CALL SLACPY( 'Lower', NR, NR, A, LDA, V, LDV )\n            CALL SLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n            CALL SGEQRF( NR, NR, V, LDV, WORK(N+1), WORK(2*N+1),\n     &                   LWORK-2*N, IERR )\n            DO 8998 p = 1, NR\n               CALL SCOPY( NR-p+1, V(p,p), LDV, V(p,p), 1 )\n 8998       CONTINUE\n            CALL SLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n*\n            CALL SGESVJ( 'Lower', 'U','N', NR, NR, V,LDV, SVA, NR, U,\n     &                  LDU, WORK(N+1), LWORK, INFO )\n            SCALEM  = WORK(N+1)\n            NUMRANK = NINT(WORK(N+2))\n            IF ( NR .LT. N ) THEN\n               CALL SLASET( 'A',N-NR, NR, ZERO,ZERO, V(NR+1,1),   LDV )\n               CALL SLASET( 'A',NR, N-NR, ZERO,ZERO, V(1,NR+1),   LDV )\n               CALL SLASET( 'A',N-NR,N-NR,ZERO,ONE, V(NR+1,NR+1), LDV )\n            END IF\n*\n         CALL SORMLQ( '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 SCOPY( N, V(p,1), LDV, A(IWORK(p),1), LDA )\n 8991    CONTINUE\n         CALL SLACPY( 'All', N, N, A, LDA, V, LDV )\n*\n         IF ( TRANSP ) THEN\n            CALL SLACPY( '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 SCOPY( N-p+1, A(p,p), LDA, U(p,p), 1 )\n 1965    CONTINUE\n         CALL SLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU )\n*\n         CALL SGEQRF( 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 SCOPY( NR-p, U(p,p+1), LDU, U(p+1,p), 1 )\n 1967    CONTINUE\n         CALL SLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU )\n*\n         CALL SGESVJ( '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 = NINT(WORK(N+2))\n*\n         IF ( NR .LT. M ) THEN\n            CALL SLASET( 'A',  M-NR, NR,ZERO, ZERO, U(NR+1,1), LDU )\n            IF ( NR .LT. N1 ) THEN\n               CALL SLASET( 'A',NR, N1-NR, ZERO, ZERO, U(1,NR+1), LDU )\n               CALL SLASET( 'A',M-NR,N1-NR,ZERO,ONE,U(NR+1,NR+1), LDU )\n            END IF\n         END IF\n*\n         CALL SORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U,\n     &               LDU, WORK(N+1), LWORK-N, IERR )\n*\n         IF ( ROWPIV )\n     &       CALL SLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 )\n*\n         DO 1974 p = 1, N1\n            XSC = ONE / SNRM2( M, U(1,p), 1 )\n            CALL SSCAL( M, XSC, U(1,p), 1 )\n 1974    CONTINUE\n*\n         IF ( TRANSP ) THEN\n            CALL SLACPY( '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 SGEJSV.\n*\n            DO 1968 p = 1, NR\n               CALL SCOPY( 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 = SQRT(SMALL)\n               DO 2969 q = 1, NR\n                  TEMP1 = XSC*ABS( V(q,q) )\n                  DO 2968 p = 1, N\n                     IF ( ( p .GT. q ) .AND. ( ABS(V(p,q)) .LE. TEMP1 )\n     &                   .OR. ( p .LT. q ) )\n     &                   V(p,q) = SIGN( 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 SLASET( '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 SLACPY( 'L', NR, NR, V, LDV, WORK(2*N+1), NR )\n            DO 3950 p = 1, NR\n               TEMP1 = SNRM2(NR-p+1,WORK(2*N+(p-1)*NR+p),1)\n               CALL SSCAL(NR-p+1,ONE/TEMP1,WORK(2*N+(p-1)*NR+p),1)\n 3950       CONTINUE\n            CALL SPOCON('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 / SQRT(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. FLOAT(N)\n*           more conservative    <=> CONDR1 .LT. SQRT(FLOAT(N))\n*\n            COND_OK = SQRT(FLOAT(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 SGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1),\n     &              LWORK-2*N, IERR )\n*\n               IF ( L2PERT ) THEN\n                  XSC = SQRT(SMALL)/EPSLN\n                  DO 3959 p = 2, NR\n                     DO 3958 q = 1, p - 1\n                        TEMP1 = XSC * AMIN1(ABS(V(p,p)),ABS(V(q,q)))\n                        IF ( ABS(V(q,p)) .LE. TEMP1 )\n     &                     V(q,p) = SIGN( TEMP1, V(q,p) )\n 3958                CONTINUE\n 3959             CONTINUE\n               END IF\n*\n               IF ( NR .NE. N )\n*              .. save ...\n     &         CALL SLACPY( '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 SCOPY( 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 SGEQP3\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 SGEQP3( N, NR, V, LDV, IWORK(N+1), WORK(N+1),\n     &                  WORK(2*N+1), LWORK-2*N, IERR )\n**               CALL SGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1),\n**     &              LWORK-2*N, IERR )\n               IF ( L2PERT ) THEN\n                  XSC = SQRT(SMALL)\n                  DO 3969 p = 2, NR\n                     DO 3968 q = 1, p - 1\n                        TEMP1 = XSC * AMIN1(ABS(V(p,p)),ABS(V(q,q)))\n                        IF ( ABS(V(q,p)) .LE. TEMP1 )\n     &                     V(q,p) = SIGN( TEMP1, V(q,p) )\n 3968                CONTINUE\n 3969             CONTINUE\n               END IF\n*\n               CALL SLACPY( 'A', N, NR, V, LDV, WORK(2*N+1), N )\n*\n               IF ( L2PERT ) THEN\n                  XSC = SQRT(SMALL)\n                  DO 8970 p = 2, NR\n                     DO 8971 q = 1, p - 1\n                        TEMP1 = XSC * AMIN1(ABS(V(p,p)),ABS(V(q,q)))\n                        V(p,q) = - SIGN( TEMP1, V(q,p) )\n 8971                CONTINUE\n 8970             CONTINUE\n               ELSE\n                  CALL SLASET( '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 SGELQF( 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 SLACPY( 'L',NR,NR,V,LDV,WORK(2*N+N*NR+NR+1),NR )\n               DO 4950 p = 1, NR\n                  TEMP1 = SNRM2( p, WORK(2*N+N*NR+NR+p), NR )\n                  CALL SSCAL( p, ONE/TEMP1, WORK(2*N+N*NR+NR+p), NR )\n 4950          CONTINUE\n               CALL SPOCON( '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 / SQRT(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 SLACPY( '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 = SQRT(SMALL)\n               DO 4968 q = 2, NR\n                  TEMP1 = XSC * V(q,q)\n                  DO 4969 p = 1, q - 1\n*                    V(p,q) = - SIGN( TEMP1, V(q,p) )\n                     V(p,q) = - SIGN( TEMP1, V(p,q) )\n 4969             CONTINUE\n 4968          CONTINUE\n            ELSE\n               CALL SLASET( '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 SGESVJ( '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 = NINT(WORK(2*N+N*NR+NR+2))\n               DO 3970 p = 1, NR\n                  CALL SCOPY( NR, V(1,p), 1, U(1,p), 1 )\n                  CALL SSCAL( 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 SGESVJ, premultiplied with the orthogonal matrix\n*                 from the second QR factorization.\n                  CALL STRSM( '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 SGESVJ. The Q-factor from the second QR\n*                 factorization is then built in explicitly.\n                  CALL STRSM('L','U','T','N',NR,NR,ONE,WORK(2*N+1),\n     &                 N,V,LDV)\n                  IF ( NR .LT. N ) THEN\n                    CALL SLASET('A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV)\n                    CALL SLASET('A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV)\n                    CALL SLASET('A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV)\n                  END IF\n                  CALL SORMQR('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 SGESVJ( '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 = NINT(WORK(2*N+N*NR+NR+2))\n               DO 3870 p = 1, NR\n                  CALL SCOPY( NR, V(1,p), 1, U(1,p), 1 )\n                  CALL SSCAL( NR, SVA(p),    U(1,p), 1 )\n 3870          CONTINUE\n               CALL STRSM('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 SLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV )\n                  CALL SLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV )\n                  CALL SLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV )\n               END IF\n               CALL SORMQR( '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 SGEJSV completes the task.\n*              Compute the full SVD of L3 using SGESVJ with explicit\n*              accumulation of Jacobi rotations.\n               CALL SGESVJ( '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 = NINT(WORK(2*N+N*NR+NR+2))\n               IF ( NR .LT. N ) THEN\n                  CALL SLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV )\n                  CALL SLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV )\n                  CALL SLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV )\n               END IF\n               CALL SORMQR( '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 SORMLQ( '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 = SQRT(FLOAT(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 / SNRM2( N, V(1,q), 1 )\n               IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n     &           CALL SSCAL( 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 SLASET( 'A', M-NR, NR, ZERO, ZERO, U(NR+1,1), LDU )\n               IF ( NR .LT. N1 ) THEN\n                  CALL SLASET('A',NR,N1-NR,ZERO,ZERO,U(1,NR+1),LDU)\n                  CALL SLASET('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 SORMQR( '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 = SQRT(FLOAT(M)) * EPSLN\n            DO 1973 p = 1, NR\n               XSC = ONE / SNRM2( M, U(1,p), 1 )\n               IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n     &          CALL SSCAL( 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 SLASWP( 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 SLACPY( 'Upper', N, N, A, LDA, WORK(N+1), N )\n            IF ( L2PERT ) THEN\n               XSC = SQRT(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)=-SIGN(TEMP1,WORK(N+(p-1)*N+q))\n 5971             CONTINUE\n 5970          CONTINUE\n            ELSE\n               CALL SLASET( 'Lower',N-1,N-1,ZERO,ZERO,WORK(N+2),N )\n            END IF\n*\n            CALL SGESVJ( '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 = NINT(WORK(N+N*N+2))\n            DO 6970 p = 1, N\n               CALL SCOPY( N, WORK(N+(p-1)*N+1), 1, U(1,p), 1 )\n               CALL SSCAL( N, SVA(p), WORK(N+(p-1)*N+1), 1 )\n 6970       CONTINUE\n*\n            CALL STRSM( 'Left', 'Upper', 'NoTrans', 'No UD', N, N,\n     &           ONE, A, LDA, WORK(N+1), N )\n            DO 6972 p = 1, N\n               CALL SCOPY( N, WORK(N+p), N, V(IWORK(p),1), LDV )\n 6972       CONTINUE\n            TEMP1 = SQRT(FLOAT(N))*EPSLN\n            DO 6971 p = 1, N\n               XSC = ONE / SNRM2( N, V(1,p), 1 )\n               IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n     &            CALL SSCAL( 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 SLASET( 'A',  M-N, N, ZERO, ZERO, U(N+1,1), LDU )\n               IF ( N .LT. N1 ) THEN\n                  CALL SLASET( 'A',N,  N1-N, ZERO, ZERO,  U(1,N+1),LDU )\n                  CALL SLASET( 'A',M-N,N1-N, ZERO, ONE,U(N+1,N+1),LDU )\n               END IF\n            END IF\n            CALL SORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U,\n     &           LDU, WORK(N+1), LWORK-N, IERR )\n            TEMP1 = SQRT(FLOAT(M))*EPSLN\n            DO 6973 p = 1, N1\n               XSC = ONE / SNRM2( M, U(1,p), 1 )\n               IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n     &            CALL SSCAL( M, XSC, U(1,p), 1 )\n 6973       CONTINUE\n*\n            IF ( ROWPIV )\n     &         CALL SLASWP( 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 SCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 )\n 7968    CONTINUE\n*\n         IF ( L2PERT ) THEN\n            XSC = SQRT(SMALL/EPSLN)\n            DO 5969 q = 1, NR\n               TEMP1 = XSC*ABS( V(q,q) )\n               DO 5968 p = 1, N\n                  IF ( ( p .GT. q ) .AND. ( ABS(V(p,q)) .LE. TEMP1 )\n     &                .OR. ( p .LT. q ) )\n     &                V(p,q) = SIGN( 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 SLASET( 'U', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV )\n         END IF\n\n         CALL SGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1),\n     &        LWORK-2*N, IERR )\n         CALL SLACPY( 'L', N, NR, V, LDV, WORK(2*N+1), N )\n*\n         DO 7969 p = 1, NR\n            CALL SCOPY( NR-p+1, V(p,p), LDV, U(p,p), 1 )\n 7969    CONTINUE\n\n         IF ( L2PERT ) THEN\n            XSC = SQRT(SMALL/EPSLN)\n            DO 9970 q = 2, NR\n               DO 9971 p = 1, q - 1\n                  TEMP1 = XSC * AMIN1(ABS(U(p,p)),ABS(U(q,q)))\n                  U(p,q) = - SIGN( TEMP1, U(q,p) )\n 9971          CONTINUE\n 9970       CONTINUE\n         ELSE\n            CALL SLASET('U', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU )\n         END IF\n\n         CALL SGESVJ( 'L', '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 = NINT(WORK(2*N+N*NR+2))\n\n         IF ( NR .LT. N ) THEN\n            CALL SLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV )\n            CALL SLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV )\n            CALL SLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV )\n         END IF\n\n         CALL SORMQR( '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 = SQRT(FLOAT(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 / SNRM2( N, V(1,q), 1 )\n               IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) )\n     &           CALL SSCAL( 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 SLASET( 'A',  M-NR, NR, ZERO, ZERO, U(NR+1,1), LDU )\n            IF ( NR .LT. N1 ) THEN\n               CALL SLASET( 'A',NR,  N1-NR, ZERO, ZERO,  U(1,NR+1),LDU )\n               CALL SLASET( 'A',M-NR,N1-NR, ZERO, ONE,U(NR+1,NR+1),LDU )\n            END IF\n         END IF\n*\n         CALL SORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U,\n     &        LDU, WORK(N+1), LWORK-N, IERR )\n*\n            IF ( ROWPIV )\n     &         CALL SLASWP( 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 SSWAP( 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 SLASCL( '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 SGEJSV\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.sgejsv( 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;
  }

  joba = StringValueCStr(rblapack_joba)[0];
  jobv = StringValueCStr(rblapack_jobv)[0];
  jobt = StringValueCStr(rblapack_jobt)[0];
  m = NUM2INT(rblapack_m);
  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_SFLOAT)
    rblapack_work = na_change_type(rblapack_work, NA_SFLOAT);
  work = NA_PTR_TYPE(rblapack_work, real*);
  jobu = StringValueCStr(rblapack_jobu)[0];
  jobp = StringValueCStr(rblapack_jobp)[0];
  ldu = (lsame_(&jobu,"U")||lsame_(&jobu,"F")||lsame_(&jobu,"W")) ? m : 1;
  jobr = StringValueCStr(rblapack_jobr)[0];
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  ldv = (lsame_(&jobu,"U")||lsame_(&jobu,"F")||lsame_(&jobu,"W")) ? n : 1;
  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);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_sva = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  sva = NA_PTR_TYPE(rblapack_sva, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = n;
    rblapack_u = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  u = NA_PTR_TYPE(rblapack_u, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = n;
    rblapack_v = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  v = NA_PTR_TYPE(rblapack_v, real*);
  {
    na_shape_t shape[1];
    shape[0] = m+3*n;
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[1];
    shape[0] = lwork;
    rblapack_work_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work_out__ = NA_PTR_TYPE(rblapack_work_out__, real*);
  MEMCPY(work_out__, work, real, NA_TOTAL(rblapack_work));
  rblapack_work = rblapack_work_out__;
  work = work_out__;

  sgejsv_(&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_sgejsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgejsv", rblapack_sgejsv, -1);
}
ruby-lapack-1.7.2/ext/ctrti2.c0000644000175000017500000001006212502221026015731 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctrti2_(char* uplo, char* diag, integer* n, complex* a, integer* lda, integer* info);


static VALUE
rblapack_ctrti2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *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  info, a = NumRu::Lapack.ctrti2( uplo, diag, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTRTI2( UPLO, DIAG, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTRTI2 computes the inverse of a complex upper or lower triangular\n*  matrix.\n*\n*  This is the Level 2 BLAS version of the algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the matrix A is upper or lower triangular.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  DIAG    (input) CHARACTER*1\n*          Specifies whether or not the matrix A is unit triangular.\n*          = 'N':  Non-unit triangular\n*          = 'U':  Unit triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the triangular matrix A.  If UPLO = 'U', the\n*          leading n by n upper triangular part of the array A contains\n*          the upper triangular matrix, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n by n lower triangular part of the array A contains\n*          the lower triangular matrix, and the strictly upper\n*          triangular part of A is not referenced.  If DIAG = 'U', the\n*          diagonal elements of A are also not referenced and are\n*          assumed to be 1.\n*\n*          On exit, the (triangular) inverse of the original matrix, in\n*          the same storage format.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.ctrti2( uplo, diag, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_diag = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  diag = StringValueCStr(rblapack_diag)[0];
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  ctrti2_(&uplo, &diag, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_ctrti2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctrti2", rblapack_ctrti2, -1);
}
ruby-lapack-1.7.2/ext/cgelsd.c0000644000175000017500000002500512502221016015765 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgelsd_(integer* m, integer* n, integer* nrhs, complex* a, integer* lda, complex* b, integer* ldb, real* s, real* rcond, integer* rank, complex* work, integer* lwork, real* rwork, integer* iwork, integer* info);


static VALUE
rblapack_cgelsd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_rank;
  integer rank; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  complex *b_out__;
  real *rwork;
  integer *iwork;

  integer lda;
  integer n;
  integer m;
  integer nrhs;
  integer ldb;
  integer c__9;
  integer c__0;
  integer liwork;
  integer lrwork;
  integer nlvl;
  integer smlsiz;

  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  s, rank, work, info, b = NumRu::Lapack.cgelsd( a, b, rcond, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, RWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGELSD computes the minimum-norm solution to a real linear least\n*  squares problem:\n*      minimize 2-norm(| b - A*x |)\n*  using the singular value decomposition (SVD) of A. A is an M-by-N\n*  matrix which may be rank-deficient.\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*  The problem is solved in three steps:\n*  (1) Reduce the coefficient matrix A to bidiagonal form with\n*      Householder tranformations, reducing the original problem\n*      into a \"bidiagonal least squares problem\" (BLS)\n*  (2) Solve the BLS using a divide and conquer approach.\n*  (3) Apply back all the Householder tranformations to solve\n*      the original least squares problem.\n*\n*  The effective rank of A is determined by treating as zero those\n*  singular values which are less than RCOND times the largest singular\n*  value.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\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*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X. NRHS >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, A has been destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the M-by-NRHS right hand side matrix B.\n*          On exit, B is overwritten by the N-by-NRHS solution matrix X.\n*          If m >= n and RANK = n, the residual sum-of-squares for\n*          the solution in the i-th column is given by the sum of\n*          squares of the modulus of elements n+1:m in that column.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,M,N).\n*\n*  S       (output) REAL array, dimension (min(M,N))\n*          The singular values of A in decreasing order.\n*          The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n*\n*  RCOND   (input) REAL\n*          RCOND is used to determine the effective rank of A.\n*          Singular values S(i) <= RCOND*S(1) are treated as zero.\n*          If RCOND < 0, machine precision is used instead.\n*\n*  RANK    (output) INTEGER\n*          The effective rank of A, i.e., the number of singular values\n*          which are greater than RCOND*S(1).\n*\n*  WORK    (workspace/output) COMPLEX 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 must be at least 1.\n*          The exact minimum amount of workspace needed depends on M,\n*          N and NRHS. As long as LWORK is at least\n*              2 * N + N * NRHS\n*          if M is greater than or equal to N or\n*              2 * M + M * NRHS\n*          if M is less than N, the code will execute correctly.\n*          For good performance, LWORK should generally be larger.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal size of the array WORK and the\n*          minimum sizes of the arrays RWORK and IWORK, and returns\n*          these values as the first entries of the WORK, RWORK and\n*          IWORK arrays, and no error message related to LWORK is issued\n*          by XERBLA.\n*\n*  RWORK   (workspace) REAL array, dimension (MAX(1,LRWORK))\n*          LRWORK >=\n*             10*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS +\n*             MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS )\n*          if M is greater than or equal to N or\n*             10*M + 2*M*SMLSIZ + 8*M*NLVL + 3*SMLSIZ*NRHS +\n*             MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS )\n*          if M is less than N, the code will execute correctly.\n*          SMLSIZ is returned by ILAENV and is equal to the maximum\n*          size of the subproblems at the bottom of the computation\n*          tree (usually about 25), and\n*             NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )\n*          On exit, if INFO = 0, RWORK(1) returns the minimum LRWORK.\n*\n*  IWORK   (workspace) INTEGER array, dimension (MAX(1,LIWORK))\n*          LIWORK >= max(1, 3*MINMN*NLVL + 11*MINMN),\n*          where MINMN = MIN( M,N ).\n*          On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -i, the i-th argument had an illegal value.\n*          > 0:  the algorithm for computing the SVD failed to converge;\n*                if INFO = i, i off-diagonal elements of an intermediate\n*                bidiagonal form did not converge to zero.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Ren-Cang Li, Computer Science Division, University of\n*       California at Berkeley, USA\n*     Osni Marques, LBNL/NERSC, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, rank, work, info, b = NumRu::Lapack.cgelsd( a, b, rcond, [: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_a = argv[0];
  rblapack_b = argv[1];
  rblapack_rcond = 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 (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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  rcond = (real)NUM2DBL(rblapack_rcond);
  m = lda;
  c__9 = 9;
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th 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_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  ldb = MAX(m,n);
  if (rblapack_lwork == Qnil)
    lwork = m>=n ? 2*n+n*nrhs : 2*m+m*nrhs;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  c__0 = 0;
  smlsiz = ilaenv_(&c__9,"CGELSD"," ",&c__0,&c__0,&c__0,&c__0);
  nlvl = MAX(0,(int)(log(1.0*MIN(m,n)/(smlsiz+1))/log(2.0)));
  liwork = MAX(1,3*(MIN(m,n))*nlvl+11*(MIN(m,n)));
  lrwork = m>=n ? 10*n+2*n*smlsiz+8*n*nlvl+3*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1) : 10*m+2*m*smlsiz+8*m*nlvl+2*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = MAX(m, n);
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  {
    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__;
  rwork = ALLOC_N(real, (MAX(1,lrwork)));
  iwork = ALLOC_N(integer, (MAX(1,liwork)));

  cgelsd_(&m, &n, &nrhs, a, &lda, b, &ldb, s, &rcond, &rank, work, &lwork, rwork, iwork, &info);

  free(rwork);
  free(iwork);
  rblapack_rank = INT2NUM(rank);
  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(5, rblapack_s, rblapack_rank, rblapack_work, rblapack_info, rblapack_b);
}

void
init_lapack_cgelsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgelsd", rblapack_cgelsd, -1);
}
ruby-lapack-1.7.2/ext/dpptrs.c0000644000175000017500000001144512502221022016040 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dpptrs_(char* uplo, integer* n, integer* nrhs, doublereal* ap, doublereal* b, integer* ldb, integer* info);


static VALUE
rblapack_dpptrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublereal *b_out__;

  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.dpptrs( uplo, n, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPPTRS solves a system of linear equations A*X = B with a symmetric\n*  positive definite matrix A in packed storage using the Cholesky\n*  factorization A = U**T*U or A = L*L**T computed by DPPTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**T*U or A = L*L**T, packed columnwise in a linear\n*          array.  The j-th column of U or L is stored in the array AP\n*          as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            UPPER\n      INTEGER            I\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DTPSV, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.dpptrs( uplo, n, ap, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_n = argv[1];
  rblapack_ap = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dpptrs_(&uplo, &n, &nrhs, ap, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_dpptrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dpptrs", rblapack_dpptrs, -1);
}
ruby-lapack-1.7.2/ext/slarft.c0000644000175000017500000001527112502221014016021 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slarft_(char* direct, char* storev, integer* n, integer* k, real* v, integer* ldv, real* tau, real* t, integer* ldt);


static VALUE
rblapack_slarft(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_direct;
  char direct; 
  VALUE rblapack_storev;
  char storev; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_v;
  real *v; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_t;
  real *t; 
  VALUE rblapack_v_out__;
  real *v_out__;

  integer ldv;
  integer k;
  integer ldt;

  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  t, v = NumRu::Lapack.slarft( direct, storev, n, v, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n*  Purpose\n*  =======\n*\n*  SLARFT forms the triangular factor T of a real block reflector H\n*  of order n, which is defined as a product of k elementary reflectors.\n*\n*  If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n*\n*  If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n*\n*  If STOREV = 'C', the vector which defines the elementary reflector\n*  H(i) is stored in the i-th column of the array V, and\n*\n*     H  =  I - V * T * V'\n*\n*  If STOREV = 'R', the vector which defines the elementary reflector\n*  H(i) is stored in the i-th row of the array V, and\n*\n*     H  =  I - V' * T * V\n*\n\n*  Arguments\n*  =========\n*\n*  DIRECT  (input) CHARACTER*1\n*          Specifies the order in which the elementary reflectors are\n*          multiplied to form the block reflector:\n*          = 'F': H = H(1) H(2) . . . H(k) (Forward)\n*          = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n*  STOREV  (input) CHARACTER*1\n*          Specifies how the vectors which define the elementary\n*          reflectors are stored (see also Further Details):\n*          = 'C': columnwise\n*          = 'R': rowwise\n*\n*  N       (input) INTEGER\n*          The order of the block reflector H. N >= 0.\n*\n*  K       (input) INTEGER\n*          The order of the triangular factor T (= the number of\n*          elementary reflectors). K >= 1.\n*\n*  V       (input/output) REAL array, dimension\n*                               (LDV,K) if STOREV = 'C'\n*                               (LDV,N) if STOREV = 'R'\n*          The matrix V. See further details.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V.\n*          If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n*\n*  TAU     (input) REAL array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i).\n*\n*  T       (output) REAL array, dimension (LDT,K)\n*          The k by k triangular factor T of the block reflector.\n*          If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n*          lower triangular. The rest of the array is not used.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= K.\n*\n\n*  Further Details\n*  ===============\n*\n*  The shape of the matrix V and the storage of the vectors which define\n*  the H(i) is best illustrated by the following example with n = 5 and\n*  k = 3. The elements equal to 1 are not stored; the corresponding\n*  array elements are modified but restored on exit. The rest of the\n*  array is not used.\n*\n*  DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R':\n*\n*               V = (  1       )                 V = (  1 v1 v1 v1 v1 )\n*                   ( v1  1    )                     (     1 v2 v2 v2 )\n*                   ( v1 v2  1 )                     (        1 v3 v3 )\n*                   ( v1 v2 v3 )\n*                   ( v1 v2 v3 )\n*\n*  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R':\n*\n*               V = ( v1 v2 v3 )                 V = ( v1 v1  1       )\n*                   ( v1 v2 v3 )                     ( v2 v2 v2  1    )\n*                   (  1 v2 v3 )                     ( v3 v3 v3 v3  1 )\n*                   (     1 v3 )\n*                   (        1 )\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  t, v = NumRu::Lapack.slarft( direct, storev, n, v, tau, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_direct = argv[0];
  rblapack_storev = argv[1];
  rblapack_n = argv[2];
  rblapack_v = argv[3];
  rblapack_tau = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  direct = StringValueCStr(rblapack_direct)[0];
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  storev = StringValueCStr(rblapack_storev)[0];
  ldt = k;
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (4th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  if (NA_SHAPE1(rblapack_v) != (lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0))
    rb_raise(rb_eRuntimeError, "shape 1 of v must be %d", lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0);
  if (NA_TYPE(rblapack_v) != NA_SFLOAT)
    rblapack_v = na_change_type(rblapack_v, NA_SFLOAT);
  v = NA_PTR_TYPE(rblapack_v, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = k;
    rblapack_t = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  t = NA_PTR_TYPE(rblapack_t, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0;
    rblapack_v_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  v_out__ = NA_PTR_TYPE(rblapack_v_out__, real*);
  MEMCPY(v_out__, v, real, NA_TOTAL(rblapack_v));
  rblapack_v = rblapack_v_out__;
  v = v_out__;

  slarft_(&direct, &storev, &n, &k, v, &ldv, tau, t, &ldt);

  return rb_ary_new3(2, rblapack_t, rblapack_v);
}

void
init_lapack_slarft(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slarft", rblapack_slarft, -1);
}
ruby-lapack-1.7.2/ext/zhprfs.c0000644000175000017500000002113712502221024016041 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhprfs_(char* uplo, integer* n, integer* nrhs, doublecomplex* ap, doublecomplex* afp, integer* ipiv, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zhprfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_afp;
  doublecomplex *afp; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.zhprfs( uplo, ap, afp, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHPRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is Hermitian indefinite\n*  and packed, and provides error bounds and backward error estimates\n*  for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          The upper or lower triangle of the Hermitian matrix A, packed\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  AFP     (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          The factored form of the matrix A.  AFP contains the block\n*          diagonal matrix D and the multipliers used to obtain the\n*          factor U or L from the factorization A = U*D*U**H or\n*          A = L*D*L**H as computed by ZHPTRF, stored as a packed\n*          triangular matrix.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by ZHPTRF.\n*\n*  B       (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) COMPLEX*16 array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by ZHPTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.zhprfs( uplo, ap, afp, ipiv, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_afp = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_b = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  if (!NA_IsNArray(rblapack_afp))
    rb_raise(rb_eArgError, "afp (3th argument) must be NArray");
  if (NA_RANK(rblapack_afp) != 1)
    rb_raise(rb_eArgError, "rank of afp (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_afp) != NA_DCOMPLEX)
    rblapack_afp = na_change_type(rblapack_afp, NA_DCOMPLEX);
  afp = NA_PTR_TYPE(rblapack_afp, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (n));

  zhprfs_(&uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_zhprfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhprfs", rblapack_zhprfs, -1);
}
ruby-lapack-1.7.2/ext/slaein.c0000644000175000017500000001665312502221016016010 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaein_(logical* rightv, logical* noinit, integer* n, real* h, integer* ldh, real* wr, real* wi, real* vr, real* vi, real* b, integer* ldb, real* work, real* eps3, real* smlnum, real* bignum, integer* info);


static VALUE
rblapack_slaein(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_rightv;
  logical rightv; 
  VALUE rblapack_noinit;
  logical noinit; 
  VALUE rblapack_h;
  real *h; 
  VALUE rblapack_wr;
  real wr; 
  VALUE rblapack_wi;
  real wi; 
  VALUE rblapack_vr;
  real *vr; 
  VALUE rblapack_vi;
  real *vi; 
  VALUE rblapack_eps3;
  real eps3; 
  VALUE rblapack_smlnum;
  real smlnum; 
  VALUE rblapack_bignum;
  real bignum; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_vr_out__;
  real *vr_out__;
  VALUE rblapack_vi_out__;
  real *vi_out__;
  real *b;
  real *work;

  integer ldh;
  integer n;
  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  info, vr, vi = NumRu::Lapack.slaein( rightv, noinit, h, wr, wi, vr, vi, eps3, smlnum, bignum, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B, LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLAEIN uses inverse iteration to find a right or left eigenvector\n*  corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg\n*  matrix H.\n*\n\n*  Arguments\n*  =========\n*\n*  RIGHTV   (input) LOGICAL\n*          = .TRUE. : compute right eigenvector;\n*          = .FALSE.: compute left eigenvector.\n*\n*  NOINIT   (input) LOGICAL\n*          = .TRUE. : no initial vector supplied in (VR,VI).\n*          = .FALSE.: initial vector supplied in (VR,VI).\n*\n*  N       (input) INTEGER\n*          The order of the matrix H.  N >= 0.\n*\n*  H       (input) REAL array, dimension (LDH,N)\n*          The upper Hessenberg matrix H.\n*\n*  LDH     (input) INTEGER\n*          The leading dimension of the array H.  LDH >= max(1,N).\n*\n*  WR      (input) REAL\n*  WI      (input) REAL\n*          The real and imaginary parts of the eigenvalue of H whose\n*          corresponding right or left eigenvector is to be computed.\n*\n*  VR      (input/output) REAL array, dimension (N)\n*  VI      (input/output) REAL array, dimension (N)\n*          On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain\n*          a real starting vector for inverse iteration using the real\n*          eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI\n*          must contain the real and imaginary parts of a complex\n*          starting vector for inverse iteration using the complex\n*          eigenvalue (WR,WI); otherwise VR and VI need not be set.\n*          On exit, if WI = 0.0 (real eigenvalue), VR contains the\n*          computed real eigenvector; if WI.ne.0.0 (complex eigenvalue),\n*          VR and VI contain the real and imaginary parts of the\n*          computed complex eigenvector. The eigenvector is normalized\n*          so that the component of largest magnitude has magnitude 1;\n*          here the magnitude of a complex number (x,y) is taken to be\n*          |x| + |y|.\n*          VI is not referenced if WI = 0.0.\n*\n*  B       (workspace) REAL array, dimension (LDB,N)\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= N+1.\n*\n*  WORK   (workspace) REAL array, dimension (N)\n*\n*  EPS3    (input) REAL\n*          A small machine-dependent value which is used to perturb\n*          close eigenvalues, and to replace zero pivots.\n*\n*  SMLNUM  (input) REAL\n*          A machine-dependent value close to the underflow threshold.\n*\n*  BIGNUM  (input) REAL\n*          A machine-dependent value close to the overflow threshold.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          = 1:  inverse iteration did not converge; VR is set to the\n*                last iterate, and so is VI if WI.ne.0.0.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, vr, vi = NumRu::Lapack.slaein( rightv, noinit, h, wr, wi, vr, vi, eps3, smlnum, bignum, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_rightv = argv[0];
  rblapack_noinit = argv[1];
  rblapack_h = argv[2];
  rblapack_wr = argv[3];
  rblapack_wi = argv[4];
  rblapack_vr = argv[5];
  rblapack_vi = argv[6];
  rblapack_eps3 = argv[7];
  rblapack_smlnum = argv[8];
  rblapack_bignum = argv[9];
  if (argc == 10) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  rightv = (rblapack_rightv == Qtrue);
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (3th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (3th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_SFLOAT)
    rblapack_h = na_change_type(rblapack_h, NA_SFLOAT);
  h = NA_PTR_TYPE(rblapack_h, real*);
  wi = (real)NUM2DBL(rblapack_wi);
  if (!NA_IsNArray(rblapack_vi))
    rb_raise(rb_eArgError, "vi (7th argument) must be NArray");
  if (NA_RANK(rblapack_vi) != 1)
    rb_raise(rb_eArgError, "rank of vi (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_vi) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of vi must be the same as shape 1 of h");
  if (NA_TYPE(rblapack_vi) != NA_SFLOAT)
    rblapack_vi = na_change_type(rblapack_vi, NA_SFLOAT);
  vi = NA_PTR_TYPE(rblapack_vi, real*);
  smlnum = (real)NUM2DBL(rblapack_smlnum);
  noinit = (rblapack_noinit == Qtrue);
  if (!NA_IsNArray(rblapack_vr))
    rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
  if (NA_RANK(rblapack_vr) != 1)
    rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_vr) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of vr must be the same as shape 1 of h");
  if (NA_TYPE(rblapack_vr) != NA_SFLOAT)
    rblapack_vr = na_change_type(rblapack_vr, NA_SFLOAT);
  vr = NA_PTR_TYPE(rblapack_vr, real*);
  bignum = (real)NUM2DBL(rblapack_bignum);
  wr = (real)NUM2DBL(rblapack_wr);
  ldb = n+1;
  eps3 = (real)NUM2DBL(rblapack_eps3);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_vr_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  vr_out__ = NA_PTR_TYPE(rblapack_vr_out__, real*);
  MEMCPY(vr_out__, vr, real, NA_TOTAL(rblapack_vr));
  rblapack_vr = rblapack_vr_out__;
  vr = vr_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_vi_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  vi_out__ = NA_PTR_TYPE(rblapack_vi_out__, real*);
  MEMCPY(vi_out__, vi, real, NA_TOTAL(rblapack_vi));
  rblapack_vi = rblapack_vi_out__;
  vi = vi_out__;
  b = ALLOC_N(real, (ldb)*(n));
  work = ALLOC_N(real, (n));

  slaein_(&rightv, &noinit, &n, h, &ldh, &wr, &wi, vr, vi, b, &ldb, work, &eps3, &smlnum, &bignum, &info);

  free(b);
  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_vr, rblapack_vi);
}

void
init_lapack_slaein(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaein", rblapack_slaein, -1);
}
ruby-lapack-1.7.2/ext/cgeequb.c0000644000175000017500000001251612502221021016136 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgeequb_(integer* m, integer* n, complex* a, integer* lda, real* r, real* c, real* rowcnd, real* colcnd, real* amax, integer* info);


static VALUE
rblapack_cgeequb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_r;
  real *r; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_rowcnd;
  real rowcnd; 
  VALUE rblapack_colcnd;
  real colcnd; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_info;
  integer info; 

  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  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.cgeequb( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGEEQUB computes row and column scalings intended to equilibrate an\n*  M-by-N matrix A and reduce its condition number.  R returns the row\n*  scale factors and C the column scale factors, chosen to try to make\n*  the largest element in each row and column of the matrix B with\n*  elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n*  the radix.\n*\n*  R(i) and C(j) are restricted to be a power of the radix between\n*  SMLNUM = smallest safe number and BIGNUM = largest safe number.  Use\n*  of these scaling factors is not guaranteed to reduce the condition\n*  number of A but works well in practice.\n*\n*  This routine differs from CGEEQU by restricting the scaling factors\n*  to a power of the radix.  Baring over- and underflow, scaling by\n*  these factors introduces no additional rounding errors.  However, the\n*  scaled entries' magnitured are no longer approximately 1 but lie\n*  between sqrt(radix) and 1/sqrt(radix).\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) COMPLEX array, dimension (LDA,N)\n*          The M-by-N matrix whose equilibration factors are\n*          to be computed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  R       (output) REAL array, dimension (M)\n*          If INFO = 0 or INFO > M, R contains the row scale factors\n*          for A.\n*\n*  C       (output) REAL array, dimension (N)\n*          If INFO = 0,  C contains the column scale factors for A.\n*\n*  ROWCND  (output) REAL\n*          If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n*          smallest R(i) to the largest R(i).  If ROWCND >= 0.1 and\n*          AMAX is neither too large nor too small, it is not worth\n*          scaling by R.\n*\n*  COLCND  (output) REAL\n*          If INFO = 0, COLCND contains the ratio of the smallest\n*          C(i) to the largest C(i).  If COLCND >= 0.1, it is not\n*          worth scaling by C.\n*\n*  AMAX    (output) REAL\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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,  and i is\n*                <= M:  the i-th row of A is exactly zero\n*                >  M:  the (i-M)-th column of A is exactly zero\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.cgeequb( 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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  m = lda;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_r = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  r = NA_PTR_TYPE(rblapack_r, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  c = NA_PTR_TYPE(rblapack_c, real*);

  cgeequb_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &info);

  rblapack_rowcnd = rb_float_new((double)rowcnd);
  rblapack_colcnd = rb_float_new((double)colcnd);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
}

void
init_lapack_cgeequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgeequb", rblapack_cgeequb, -1);
}
ruby-lapack-1.7.2/ext/slarrk.c0000644000175000017500000001233412502221015016022 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slarrk_(integer* n, integer* iw, real* gl, real* gu, real* d, real* e2, real* pivmin, real* reltol, real* w, real* werr, integer* info);


static VALUE
rblapack_slarrk(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_iw;
  integer iw; 
  VALUE rblapack_gl;
  real gl; 
  VALUE rblapack_gu;
  real gu; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e2;
  real *e2; 
  VALUE rblapack_pivmin;
  real pivmin; 
  VALUE rblapack_reltol;
  real reltol; 
  VALUE rblapack_w;
  real w; 
  VALUE rblapack_werr;
  real werr; 
  VALUE rblapack_info;
  integer info; 

  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  w, werr, info = NumRu::Lapack.slarrk( iw, gl, gu, d, e2, pivmin, reltol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLARRK( N, IW, GL, GU, D, E2, PIVMIN, RELTOL, W, WERR, INFO)\n\n*  Purpose\n*  =======\n*\n*  SLARRK computes one eigenvalue of a symmetric tridiagonal\n*  matrix T to suitable accuracy. This is an auxiliary code to be\n*  called from SSTEMR.\n*\n*  To avoid overflow, the matrix must be scaled so that its\n*  largest element is no greater than overflow**(1/2) *\n*  underflow**(1/4) in absolute value, and for greatest\n*  accuracy, it should not be much smaller than that.\n*\n*  See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n*  Matrix\", Report CS41, Computer Science Dept., Stanford\n*  University, July 21, 1966.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the tridiagonal matrix T.  N >= 0.\n*\n*  IW      (input) INTEGER\n*          The index of the eigenvalues to be returned.\n*\n*  GL      (input) REAL            \n*  GU      (input) REAL            \n*          An upper and a lower bound on the eigenvalue.\n*\n*  D       (input) REAL             array, dimension (N)\n*          The n diagonal elements of the tridiagonal matrix T.\n*\n*  E2      (input) REAL             array, dimension (N-1)\n*          The (n-1) squared off-diagonal elements of the tridiagonal matrix T.\n*\n*  PIVMIN  (input) REAL            \n*          The minimum pivot allowed in the Sturm sequence for T.\n*\n*  RELTOL  (input) REAL            \n*          The minimum relative width of an interval.  When an interval\n*          is narrower than RELTOL times the larger (in\n*          magnitude) endpoint, then it is considered to be\n*          sufficiently small, i.e., converged.  Note: this should\n*          always be at least radix*machine epsilon.\n*\n*  W       (output) REAL            \n*\n*  WERR    (output) REAL            \n*          The error bound on the corresponding eigenvalue approximation\n*          in W.\n*\n*  INFO    (output) INTEGER\n*          = 0:       Eigenvalue converged\n*          = -1:      Eigenvalue did NOT converge\n*\n*  Internal Parameters\n*  ===================\n*\n*  FUDGE   REAL            , default = 2\n*          A \"fudge factor\" to widen the Gershgorin intervals.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, werr, info = NumRu::Lapack.slarrk( iw, gl, gu, d, e2, pivmin, reltol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_iw = argv[0];
  rblapack_gl = argv[1];
  rblapack_gu = argv[2];
  rblapack_d = argv[3];
  rblapack_e2 = argv[4];
  rblapack_pivmin = argv[5];
  rblapack_reltol = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  iw = NUM2INT(rblapack_iw);
  gu = (real)NUM2DBL(rblapack_gu);
  pivmin = (real)NUM2DBL(rblapack_pivmin);
  gl = (real)NUM2DBL(rblapack_gl);
  reltol = (real)NUM2DBL(rblapack_reltol);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_e2))
    rb_raise(rb_eArgError, "e2 (5th argument) must be NArray");
  if (NA_RANK(rblapack_e2) != 1)
    rb_raise(rb_eArgError, "rank of e2 (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e2) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e2 must be %d", n-1);
  if (NA_TYPE(rblapack_e2) != NA_SFLOAT)
    rblapack_e2 = na_change_type(rblapack_e2, NA_SFLOAT);
  e2 = NA_PTR_TYPE(rblapack_e2, real*);

  slarrk_(&n, &iw, &gl, &gu, d, e2, &pivmin, &reltol, &w, &werr, &info);

  rblapack_w = rb_float_new((double)w);
  rblapack_werr = rb_float_new((double)werr);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_w, rblapack_werr, rblapack_info);
}

void
init_lapack_slarrk(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slarrk", rblapack_slarrk, -1);
}
ruby-lapack-1.7.2/ext/slauum.c0000644000175000017500000000730212502221020016025 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slauum_(char* uplo, integer* n, real* a, integer* lda, integer* info);


static VALUE
rblapack_slauum(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *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  info, a = NumRu::Lapack.slauum( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAUUM( UPLO, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLAUUM computes the product U * U' or L' * L, where the triangular\n*  factor U or L is stored in the upper or lower triangular part of\n*  the array A.\n*\n*  If UPLO = 'U' or 'u' then the upper triangle of the result is stored,\n*  overwriting the factor U in A.\n*  If UPLO = 'L' or 'l' then the lower triangle of the result is stored,\n*  overwriting the factor L in A.\n*\n*  This is the blocked form of the algorithm, calling Level 3 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the triangular factor stored in the array A\n*          is upper or lower triangular:\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the triangular factor U or L.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the triangular factor U or L.\n*          On exit, if UPLO = 'U', the upper triangle of A is\n*          overwritten with the upper triangle of the product U * U';\n*          if UPLO = 'L', the lower triangle of A is overwritten with\n*          the lower triangle of the product L' * L.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.slauum( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  slauum_(&uplo, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_slauum(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slauum", rblapack_slauum, -1);
}
ruby-lapack-1.7.2/ext/zpptrf.c0000644000175000017500000001057312502221021016051 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zpptrf_(char* uplo, integer* n, doublecomplex* ap, integer* info);


static VALUE
rblapack_zpptrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublecomplex *ap_out__;


  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  info, ap = NumRu::Lapack.zpptrf( uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPPTRF( UPLO, N, AP, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPPTRF computes the Cholesky factorization of a complex Hermitian\n*  positive definite matrix A stored in packed format.\n*\n*  The factorization has the form\n*     A = U**H * U,  if UPLO = 'U', or\n*     A = L  * L**H,  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is lower triangular.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          See below for further details.\n*\n*          On exit, if INFO = 0, the triangular factor U or L from the\n*          Cholesky factorization A = U**H*U or A = L*L**H, in the same\n*          storage format as A.\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 leading minor of order i is not\n*                positive definite, and the factorization could not be\n*                completed.\n*\n\n*  Further Details\n*  ===============\n*\n*  The packed storage scheme is illustrated by the following example\n*  when N = 4, UPLO = 'U':\n*\n*  Two-dimensional storage of the Hermitian matrix A:\n*\n*     a11 a12 a13 a14\n*         a22 a23 a24\n*             a33 a34     (aij = conjg(aji))\n*                 a44\n*\n*  Packed storage of the upper triangle of A:\n*\n*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ap = NumRu::Lapack.zpptrf( uplo, n, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_n = argv[1];
  rblapack_ap = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
  MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  zpptrf_(&uplo, &n, ap, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ap);
}

void
init_lapack_zpptrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zpptrf", rblapack_zpptrf, -1);
}
ruby-lapack-1.7.2/ext/zbbcsd.c0000644000175000017500000004131012502221016015770 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zbbcsd_(char* jobu1, char* jobu2, char* jobv1t, char* jobv2t, char* trans, integer* m, integer* p, integer* q, doublereal* theta, doublereal* phi, doublecomplex* u1, integer* ldu1, doublecomplex* u2, integer* ldu2, doublecomplex* v1t, integer* ldv1t, doublecomplex* v2t, integer* ldv2t, doublereal* b11d, doublereal* b11e, doublereal* b12d, doublereal* b12e, doublereal* b21d, doublereal* b21e, doublereal* b22d, doublereal* b22e, doublereal* rwork, integer* lrwork, integer* info);


static VALUE
rblapack_zbbcsd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobu1;
  char jobu1; 
  VALUE rblapack_jobu2;
  char jobu2; 
  VALUE rblapack_jobv1t;
  char jobv1t; 
  VALUE rblapack_jobv2t;
  char jobv2t; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_theta;
  doublereal *theta; 
  VALUE rblapack_phi;
  doublereal *phi; 
  VALUE rblapack_u1;
  doublecomplex *u1; 
  VALUE rblapack_u2;
  doublecomplex *u2; 
  VALUE rblapack_v1t;
  doublecomplex *v1t; 
  VALUE rblapack_v2t;
  doublecomplex *v2t; 
  VALUE rblapack_lrwork;
  integer lrwork; 
  VALUE rblapack_b11d;
  doublereal *b11d; 
  VALUE rblapack_b11e;
  doublereal *b11e; 
  VALUE rblapack_b12d;
  doublereal *b12d; 
  VALUE rblapack_b12e;
  doublereal *b12e; 
  VALUE rblapack_b21d;
  doublereal *b21d; 
  VALUE rblapack_b21e;
  doublereal *b21e; 
  VALUE rblapack_b22d;
  doublereal *b22d; 
  VALUE rblapack_b22e;
  doublereal *b22e; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_theta_out__;
  doublereal *theta_out__;
  VALUE rblapack_u1_out__;
  doublecomplex *u1_out__;
  VALUE rblapack_u2_out__;
  doublecomplex *u2_out__;
  VALUE rblapack_v1t_out__;
  doublecomplex *v1t_out__;
  VALUE rblapack_v2t_out__;
  doublecomplex *v2t_out__;
  doublereal *rwork;

  integer q;
  integer ldu1;
  integer p;
  integer ldu2;
  integer ldv1t;
  integer ldv2t;

  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  b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, info, theta, u1, u2, v1t, v2t = NumRu::Lapack.zbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, theta, phi, u1, u2, v1t, v2t, [:lrwork => lrwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, THETA, PHI, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, B22D, B22E, RWORK, LRWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZBBCSD computes the CS decomposition of a unitary matrix in\n*  bidiagonal-block form,\n*\n*\n*      [ B11 | B12 0  0 ]\n*      [  0  |  0 -I  0 ]\n*  X = [----------------]\n*      [ B21 | B22 0  0 ]\n*      [  0  |  0  0  I ]\n*\n*                                [  C | -S  0  0 ]\n*                    [ U1 |    ] [  0 |  0 -I  0 ] [ V1 |    ]**H\n*                  = [---------] [---------------] [---------]   .\n*                    [    | U2 ] [  S |  C  0  0 ] [    | V2 ]\n*                                [  0 |  0  0  I ]\n*\n*  X is M-by-M, its top-left block is P-by-Q, and Q must be no larger\n*  than P, M-P, or M-Q. (If Q is not the smallest index, then X must be\n*  transposed and/or permuted. This can be done in constant time using\n*  the TRANS and SIGNS options. See ZUNCSD for details.)\n*\n*  The bidiagonal matrices B11, B12, B21, and B22 are represented\n*  implicitly by angles THETA(1:Q) and PHI(1:Q-1).\n*\n*  The unitary matrices U1, U2, V1T, and V2T are input/output.\n*  The input matrices are pre- or post-multiplied by the appropriate\n*  singular vector matrices.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBU1   (input) CHARACTER\n*          = 'Y':      U1 is updated;\n*          otherwise:  U1 is not updated.\n*\n*  JOBU2   (input) CHARACTER\n*          = 'Y':      U2 is updated;\n*          otherwise:  U2 is not updated.\n*\n*  JOBV1T  (input) CHARACTER\n*          = 'Y':      V1T is updated;\n*          otherwise:  V1T is not updated.\n*\n*  JOBV2T  (input) CHARACTER\n*          = 'Y':      V2T is updated;\n*          otherwise:  V2T is not updated.\n*\n*  TRANS   (input) CHARACTER\n*          = 'T':      X, U1, U2, V1T, and V2T are stored in row-major\n*                      order;\n*          otherwise:  X, U1, U2, V1T, and V2T are stored in column-\n*                      major order.\n*\n*  M       (input) INTEGER\n*          The number of rows and columns in X, the unitary matrix in\n*          bidiagonal-block form.\n*\n*  P       (input) INTEGER\n*          The number of rows in the top-left block of X. 0 <= P <= M.\n*\n*  Q       (input) INTEGER\n*          The number of columns in the top-left block of X.\n*          0 <= Q <= MIN(P,M-P,M-Q).\n*\n*  THETA   (input/output) DOUBLE PRECISION array, dimension (Q)\n*          On entry, the angles THETA(1),...,THETA(Q) that, along with\n*          PHI(1), ...,PHI(Q-1), define the matrix in bidiagonal-block\n*          form. On exit, the angles whose cosines and sines define the\n*          diagonal blocks in the CS decomposition.\n*\n*  PHI     (input/workspace) DOUBLE PRECISION array, dimension (Q-1)\n*          The angles PHI(1),...,PHI(Q-1) that, along with THETA(1),...,\n*          THETA(Q), define the matrix in bidiagonal-block form.\n*\n*  U1      (input/output) COMPLEX*16 array, dimension (LDU1,P)\n*          On entry, an LDU1-by-P matrix. On exit, U1 is postmultiplied\n*          by the left singular vector matrix common to [ B11 ; 0 ] and\n*          [ B12 0 0 ; 0 -I 0 0 ].\n*\n*  LDU1    (input) INTEGER\n*          The leading dimension of the array U1.\n*\n*  U2      (input/output) COMPLEX*16 array, dimension (LDU2,M-P)\n*          On entry, an LDU2-by-(M-P) matrix. On exit, U2 is\n*          postmultiplied by the left singular vector matrix common to\n*          [ B21 ; 0 ] and [ B22 0 0 ; 0 0 I ].\n*\n*  LDU2    (input) INTEGER\n*          The leading dimension of the array U2.\n*\n*  V1T     (input/output) COMPLEX*16 array, dimension (LDV1T,Q)\n*          On entry, a LDV1T-by-Q matrix. On exit, V1T is premultiplied\n*          by the conjugate transpose of the right singular vector\n*          matrix common to [ B11 ; 0 ] and [ B21 ; 0 ].\n*\n*  LDV1T   (input) INTEGER\n*          The leading dimension of the array V1T.\n*\n*  V2T     (input/output) COMPLEX*16 array, dimenison (LDV2T,M-Q)\n*          On entry, a LDV2T-by-(M-Q) matrix. On exit, V2T is\n*          premultiplied by the conjugate transpose of the right\n*          singular vector matrix common to [ B12 0 0 ; 0 -I 0 ] and\n*          [ B22 0 0 ; 0 0 I ].\n*\n*  LDV2T   (input) INTEGER\n*          The leading dimension of the array V2T.\n*\n*  B11D    (output) DOUBLE PRECISION array, dimension (Q)\n*          When ZBBCSD converges, B11D contains the cosines of THETA(1),\n*          ..., THETA(Q). If ZBBCSD fails to converge, then B11D\n*          contains the diagonal of the partially reduced top-left\n*          block.\n*\n*  B11E    (output) DOUBLE PRECISION array, dimension (Q-1)\n*          When ZBBCSD converges, B11E contains zeros. If ZBBCSD fails\n*          to converge, then B11E contains the superdiagonal of the\n*          partially reduced top-left block.\n*\n*  B12D    (output) DOUBLE PRECISION array, dimension (Q)\n*          When ZBBCSD converges, B12D contains the negative sines of\n*          THETA(1), ..., THETA(Q). If ZBBCSD fails to converge, then\n*          B12D contains the diagonal of the partially reduced top-right\n*          block.\n*\n*  B12E    (output) DOUBLE PRECISION array, dimension (Q-1)\n*          When ZBBCSD converges, B12E contains zeros. If ZBBCSD fails\n*          to converge, then B12E contains the subdiagonal of the\n*          partially reduced top-right block.\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LRWORK  (input) INTEGER\n*          The dimension of the array RWORK. LRWORK >= MAX(1,8*Q).\n*\n*          If LRWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal size of the RWORK array,\n*          returns this value as the first entry of the work array, and\n*          no error message related to LRWORK 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 ZBBCSD did not converge, INFO specifies the number\n*                of nonzero entries in PHI, and B11D, B11E, etc.,\n*                contain the partially reduced matrix.\n*\n*  Reference\n*  =========\n*\n*  [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.\n*      Algorithms, 50(1):33-65, 2009.\n*\n*  Internal Parameters\n*  ===================\n*\n*  TOLMUL  DOUBLE PRECISION, default = MAX(10,MIN(100,EPS**(-1/8)))\n*          TOLMUL controls the convergence criterion of the QR loop.\n*          Angles THETA(i), PHI(i) are rounded to 0 or PI/2 when they\n*          are within TOLMUL*EPS of either bound.\n*\n\n*  ===================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, info, theta, u1, u2, v1t, v2t = NumRu::Lapack.zbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, theta, phi, u1, u2, v1t, v2t, [:lrwork => lrwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 13)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_jobu1 = argv[0];
  rblapack_jobu2 = argv[1];
  rblapack_jobv1t = argv[2];
  rblapack_jobv2t = argv[3];
  rblapack_trans = argv[4];
  rblapack_m = argv[5];
  rblapack_theta = argv[6];
  rblapack_phi = argv[7];
  rblapack_u1 = argv[8];
  rblapack_u2 = argv[9];
  rblapack_v1t = argv[10];
  rblapack_v2t = argv[11];
  if (argc == 13) {
    rblapack_lrwork = argv[12];
  } else if (rblapack_options != Qnil) {
    rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
  } else {
    rblapack_lrwork = Qnil;
  }

  jobu1 = StringValueCStr(rblapack_jobu1)[0];
  jobv1t = StringValueCStr(rblapack_jobv1t)[0];
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_theta))
    rb_raise(rb_eArgError, "theta (7th argument) must be NArray");
  if (NA_RANK(rblapack_theta) != 1)
    rb_raise(rb_eArgError, "rank of theta (7th argument) must be %d", 1);
  q = NA_SHAPE0(rblapack_theta);
  if (NA_TYPE(rblapack_theta) != NA_DFLOAT)
    rblapack_theta = na_change_type(rblapack_theta, NA_DFLOAT);
  theta = NA_PTR_TYPE(rblapack_theta, doublereal*);
  if (!NA_IsNArray(rblapack_u1))
    rb_raise(rb_eArgError, "u1 (9th argument) must be NArray");
  if (NA_RANK(rblapack_u1) != 2)
    rb_raise(rb_eArgError, "rank of u1 (9th argument) must be %d", 2);
  ldu1 = NA_SHAPE0(rblapack_u1);
  p = NA_SHAPE1(rblapack_u1);
  if (NA_TYPE(rblapack_u1) != NA_DCOMPLEX)
    rblapack_u1 = na_change_type(rblapack_u1, NA_DCOMPLEX);
  u1 = NA_PTR_TYPE(rblapack_u1, doublecomplex*);
  if (!NA_IsNArray(rblapack_v1t))
    rb_raise(rb_eArgError, "v1t (11th argument) must be NArray");
  if (NA_RANK(rblapack_v1t) != 2)
    rb_raise(rb_eArgError, "rank of v1t (11th argument) must be %d", 2);
  ldv1t = NA_SHAPE0(rblapack_v1t);
  if (NA_SHAPE1(rblapack_v1t) != q)
    rb_raise(rb_eRuntimeError, "shape 1 of v1t must be the same as shape 0 of theta");
  if (NA_TYPE(rblapack_v1t) != NA_DCOMPLEX)
    rblapack_v1t = na_change_type(rblapack_v1t, NA_DCOMPLEX);
  v1t = NA_PTR_TYPE(rblapack_v1t, doublecomplex*);
  lrwork = MAX(1,8*q);
  jobu2 = StringValueCStr(rblapack_jobu2)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_u2))
    rb_raise(rb_eArgError, "u2 (10th argument) must be NArray");
  if (NA_RANK(rblapack_u2) != 2)
    rb_raise(rb_eArgError, "rank of u2 (10th argument) must be %d", 2);
  ldu2 = NA_SHAPE0(rblapack_u2);
  if (NA_SHAPE1(rblapack_u2) != (m-p))
    rb_raise(rb_eRuntimeError, "shape 1 of u2 must be %d", m-p);
  if (NA_TYPE(rblapack_u2) != NA_DCOMPLEX)
    rblapack_u2 = na_change_type(rblapack_u2, NA_DCOMPLEX);
  u2 = NA_PTR_TYPE(rblapack_u2, doublecomplex*);
  jobv2t = StringValueCStr(rblapack_jobv2t)[0];
  if (!NA_IsNArray(rblapack_v2t))
    rb_raise(rb_eArgError, "v2t (12th argument) must be NArray");
  if (NA_RANK(rblapack_v2t) != 2)
    rb_raise(rb_eArgError, "rank of v2t (12th argument) must be %d", 2);
  ldv2t = NA_SHAPE0(rblapack_v2t);
  if (NA_SHAPE1(rblapack_v2t) != (m-q))
    rb_raise(rb_eRuntimeError, "shape 1 of v2t must be %d", m-q);
  if (NA_TYPE(rblapack_v2t) != NA_DCOMPLEX)
    rblapack_v2t = na_change_type(rblapack_v2t, NA_DCOMPLEX);
  v2t = NA_PTR_TYPE(rblapack_v2t, doublecomplex*);
  if (!NA_IsNArray(rblapack_phi))
    rb_raise(rb_eArgError, "phi (8th argument) must be NArray");
  if (NA_RANK(rblapack_phi) != 1)
    rb_raise(rb_eArgError, "rank of phi (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_phi) != (q-1))
    rb_raise(rb_eRuntimeError, "shape 0 of phi must be %d", q-1);
  if (NA_TYPE(rblapack_phi) != NA_DFLOAT)
    rblapack_phi = na_change_type(rblapack_phi, NA_DFLOAT);
  phi = NA_PTR_TYPE(rblapack_phi, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_b11d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  b11d = NA_PTR_TYPE(rblapack_b11d, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = q-1;
    rblapack_b11e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  b11e = NA_PTR_TYPE(rblapack_b11e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_b12d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  b12d = NA_PTR_TYPE(rblapack_b12d, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = q-1;
    rblapack_b12e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  b12e = NA_PTR_TYPE(rblapack_b12e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_b21d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  b21d = NA_PTR_TYPE(rblapack_b21d, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = q-1;
    rblapack_b21e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  b21e = NA_PTR_TYPE(rblapack_b21e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_b22d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  b22d = NA_PTR_TYPE(rblapack_b22d, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = q-1;
    rblapack_b22e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  b22e = NA_PTR_TYPE(rblapack_b22e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_theta_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  theta_out__ = NA_PTR_TYPE(rblapack_theta_out__, doublereal*);
  MEMCPY(theta_out__, theta, doublereal, NA_TOTAL(rblapack_theta));
  rblapack_theta = rblapack_theta_out__;
  theta = theta_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldu1;
    shape[1] = p;
    rblapack_u1_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  u1_out__ = NA_PTR_TYPE(rblapack_u1_out__, doublecomplex*);
  MEMCPY(u1_out__, u1, doublecomplex, NA_TOTAL(rblapack_u1));
  rblapack_u1 = rblapack_u1_out__;
  u1 = u1_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldu2;
    shape[1] = m-p;
    rblapack_u2_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  u2_out__ = NA_PTR_TYPE(rblapack_u2_out__, doublecomplex*);
  MEMCPY(u2_out__, u2, doublecomplex, NA_TOTAL(rblapack_u2));
  rblapack_u2 = rblapack_u2_out__;
  u2 = u2_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldv1t;
    shape[1] = q;
    rblapack_v1t_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  v1t_out__ = NA_PTR_TYPE(rblapack_v1t_out__, doublecomplex*);
  MEMCPY(v1t_out__, v1t, doublecomplex, NA_TOTAL(rblapack_v1t));
  rblapack_v1t = rblapack_v1t_out__;
  v1t = v1t_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldv2t;
    shape[1] = m-q;
    rblapack_v2t_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  v2t_out__ = NA_PTR_TYPE(rblapack_v2t_out__, doublecomplex*);
  MEMCPY(v2t_out__, v2t, doublecomplex, NA_TOTAL(rblapack_v2t));
  rblapack_v2t = rblapack_v2t_out__;
  v2t = v2t_out__;
  rwork = ALLOC_N(doublereal, (MAX(1,lrwork)));

  zbbcsd_(&jobu1, &jobu2, &jobv1t, &jobv2t, &trans, &m, &p, &q, theta, phi, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, v2t, &ldv2t, b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, rwork, &lrwork, &info);

  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(14, rblapack_b11d, rblapack_b11e, rblapack_b12d, rblapack_b12e, rblapack_b21d, rblapack_b21e, rblapack_b22d, rblapack_b22e, rblapack_info, rblapack_theta, rblapack_u1, rblapack_u2, rblapack_v1t, rblapack_v2t);
}

void
init_lapack_zbbcsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zbbcsd", rblapack_zbbcsd, -1);
}
ruby-lapack-1.7.2/ext/zpftrf.c0000644000175000017500000002056012502221023016036 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zpftrf_(char* transr, char* uplo, integer* n, complex* a, integer* info);


static VALUE
rblapack_zpftrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;


  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  info, a = NumRu::Lapack.zpftrf( transr, uplo, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPFTRF( TRANSR, UPLO, N, A, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPFTRF computes the Cholesky factorization of a complex Hermitian\n*  positive definite matrix A.\n*\n*  The factorization has the form\n*     A = U**H * U,  if UPLO = 'U', or\n*     A = L  * L**H,  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is lower triangular.\n*\n*  This is the block version of the algorithm, calling Level 3 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR    (input) CHARACTER*1\n*          = 'N':  The Normal TRANSR of RFP A is stored;\n*          = 'C':  The Conjugate-transpose TRANSR of RFP A is stored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of RFP A is stored;\n*          = 'L':  Lower triangle of RFP A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension ( N*(N+1)/2 );\n*          On entry, the Hermitian matrix A in RFP format. RFP format is\n*          described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n*          then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n*          (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is\n*          the Conjugate-transpose of RFP A as defined when\n*          TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n*          follows: If UPLO = 'U' the RFP A contains the nt elements of\n*          upper packed A. If UPLO = 'L' the RFP A contains the elements\n*          of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n*          'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n*          is odd. See the Note below for more details.\n*\n*          On exit, if INFO = 0, the factor U or L from the Cholesky\n*          factorization RFP A = U**H*U or RFP A = L*L**H.\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 leading minor of order i is not\n*                positive definite, and the factorization could not be\n*                completed.\n*\n*  Further Notes on RFP Format:\n*  ============================\n*\n*  We first consider Standard Packed Format when N is even.\n*  We give an example where N = 6.\n*\n*     AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  conjugate-transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  conjugate-transpose of the last three columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                -- -- --\n*        03 04 05                33 43 53\n*                                   -- --\n*        13 14 15                00 44 54\n*                                      --\n*        23 24 25                10 11 55\n*\n*        33 34 35                20 21 22\n*        --\n*        00 44 45                30 31 32\n*        -- --\n*        01 11 55                40 41 42\n*        -- -- --\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- -- --                -- -- -- -- -- --\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     -- -- -- -- --                -- -- -- -- --\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     -- -- -- -- -- --                -- -- -- --\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We next  consider Standard Packed Format when N is odd.\n*  We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  conjugate-transpose of the first two   columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  conjugate-transpose of the last two   columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N odd  and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                   -- --\n*        02 03 04                00 33 43\n*                                      --\n*        12 13 14                10 11 44\n*\n*        22 23 24                20 21 22\n*        --\n*        00 33 34                30 31 32\n*        -- --\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- --                   -- -- -- -- -- --\n*     02 12 22 00 01             00 10 20 30 40 50\n*     -- -- -- --                   -- -- -- -- --\n*     03 13 23 33 11             33 11 21 31 41 51\n*     -- -- -- -- --                   -- -- -- --\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.zpftrf( transr, uplo, n, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_n = argv[2];
  rblapack_a = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  n = NUM2INT(rblapack_n);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 1)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zpftrf_(&transr, &uplo, &n, a, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_zpftrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zpftrf", rblapack_zpftrf, -1);
}
ruby-lapack-1.7.2/ext/zla_wwaddw.c0000644000175000017500000001036412502221024016670 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zla_wwaddw_(integer* n, doublecomplex* x, doublecomplex* y, doublecomplex* w);


static VALUE
rblapack_zla_wwaddw(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_y;
  doublecomplex *y; 
  VALUE rblapack_w;
  doublecomplex *w; 
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;
  VALUE rblapack_y_out__;
  doublecomplex *y_out__;

  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  x, y = NumRu::Lapack.zla_wwaddw( x, y, w, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLA_WWADDW( N, X, Y, W )\n\n*     Purpose\n*     =======\n*\n*     ZLA_WWADDW adds a vector W into a doubled-single vector (X, Y).\n*\n*     This works for all extant IBM's hex and binary floating point\n*     arithmetics, but not for decimal.\n*\n\n*     Arguments\n*     =========\n*\n*     N      (input) INTEGER\n*            The length of vectors X, Y, and W.\n*\n*     X      (input/output) COMPLEX*16 array, dimension (N)\n*            The first part of the doubled-single accumulation vector.\n*\n*     Y      (input/output) COMPLEX*16 array, dimension (N)\n*            The second part of the doubled-single accumulation vector.\n*\n*     W      (input) COMPLEX*16 array, dimension (N)\n*            The vector to be added.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      COMPLEX*16         S\n      INTEGER            I\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, y = NumRu::Lapack.zla_wwaddw( x, y, w, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_x = argv[0];
  rblapack_y = argv[1];
  rblapack_w = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (1th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  if (!NA_IsNArray(rblapack_w))
    rb_raise(rb_eArgError, "w (3th argument) must be NArray");
  if (NA_RANK(rblapack_w) != 1)
    rb_raise(rb_eArgError, "rank of w (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_w) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of x");
  if (NA_TYPE(rblapack_w) != NA_DCOMPLEX)
    rblapack_w = na_change_type(rblapack_w, NA_DCOMPLEX);
  w = NA_PTR_TYPE(rblapack_w, doublecomplex*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (2th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of y must be the same as shape 0 of x");
  if (NA_TYPE(rblapack_y) != NA_DCOMPLEX)
    rblapack_y = na_change_type(rblapack_y, NA_DCOMPLEX);
  y = NA_PTR_TYPE(rblapack_y, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_y_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublecomplex*);
  MEMCPY(y_out__, y, doublecomplex, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  zla_wwaddw_(&n, x, y, w);

  return rb_ary_new3(2, rblapack_x, rblapack_y);
}

void
init_lapack_zla_wwaddw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zla_wwaddw", rblapack_zla_wwaddw, -1);
}
ruby-lapack-1.7.2/ext/zlalsa.c0000644000175000017500000004123112502221022016006 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlalsa_(integer* icompq, integer* smlsiz, integer* n, integer* nrhs, doublecomplex* b, integer* ldb, doublecomplex* bx, integer* ldbx, doublereal* u, integer* ldu, doublereal* vt, integer* k, doublereal* difl, doublereal* difr, doublereal* z, doublereal* poles, integer* givptr, integer* givcol, integer* ldgcol, integer* perm, doublereal* givnum, doublereal* c, doublereal* s, doublereal* rwork, integer* iwork, integer* info);


static VALUE
rblapack_zlalsa(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_icompq;
  integer icompq; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_u;
  doublereal *u; 
  VALUE rblapack_vt;
  doublereal *vt; 
  VALUE rblapack_k;
  integer *k; 
  VALUE rblapack_difl;
  doublereal *difl; 
  VALUE rblapack_difr;
  doublereal *difr; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_poles;
  doublereal *poles; 
  VALUE rblapack_givptr;
  integer *givptr; 
  VALUE rblapack_givcol;
  integer *givcol; 
  VALUE rblapack_perm;
  integer *perm; 
  VALUE rblapack_givnum;
  doublereal *givnum; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_bx;
  doublecomplex *bx; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  doublereal *rwork;
  integer *iwork;

  integer ldb;
  integer nrhs;
  integer ldu;
  integer smlsiz;
  integer n;
  integer nlvl;
  integer ldgcol;
  integer ldbx;

  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  bx, info, b = NumRu::Lapack.zlalsa( icompq, b, u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, PERM, GIVNUM, C, S, RWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZLALSA is an itermediate step in solving the least squares problem\n*  by computing the SVD of the coefficient matrix in compact form (The\n*  singular vectors are computed as products of simple orthorgonal\n*  matrices.).\n*\n*  If ICOMPQ = 0, ZLALSA applies the inverse of the left singular vector\n*  matrix of an upper bidiagonal matrix to the right hand side; and if\n*  ICOMPQ = 1, ZLALSA applies the right singular vector matrix to the\n*  right hand side. The singular vector matrices were generated in\n*  compact form by ZLALSA.\n*\n\n*  Arguments\n*  =========\n*\n*  ICOMPQ (input) INTEGER\n*         Specifies whether the left or the right singular vector\n*         matrix is involved.\n*         = 0: Left singular vector matrix\n*         = 1: Right singular vector matrix\n*\n*  SMLSIZ (input) INTEGER\n*         The maximum size of the subproblems at the bottom of the\n*         computation tree.\n*\n*  N      (input) INTEGER\n*         The row and column dimensions of the upper bidiagonal matrix.\n*\n*  NRHS   (input) INTEGER\n*         The number of columns of B and BX. NRHS must be at least 1.\n*\n*  B      (input/output) COMPLEX*16 array, dimension ( LDB, NRHS )\n*         On input, B contains the right hand sides of the least\n*         squares problem in rows 1 through M.\n*         On output, B contains the solution X in rows 1 through N.\n*\n*  LDB    (input) INTEGER\n*         The leading dimension of B in the calling subprogram.\n*         LDB must be at least max(1,MAX( M, N ) ).\n*\n*  BX     (output) COMPLEX*16 array, dimension ( LDBX, NRHS )\n*         On exit, the result of applying the left or right singular\n*         vector matrix to B.\n*\n*  LDBX   (input) INTEGER\n*         The leading dimension of BX.\n*\n*  U      (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ).\n*         On entry, U contains the left singular vector matrices of all\n*         subproblems at the bottom level.\n*\n*  LDU    (input) INTEGER, LDU = > N.\n*         The leading dimension of arrays U, VT, DIFL, DIFR,\n*         POLES, GIVNUM, and Z.\n*\n*  VT     (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ).\n*         On entry, VT' contains the right singular vector matrices of\n*         all subproblems at the bottom level.\n*\n*  K      (input) INTEGER array, dimension ( N ).\n*\n*  DIFL   (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).\n*         where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.\n*\n*  DIFR   (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).\n*         On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record\n*         distances between singular values on the I-th level and\n*         singular values on the (I -1)-th level, and DIFR(*, 2 * I)\n*         record the normalizing factors of the right singular vectors\n*         matrices of subproblems on I-th level.\n*\n*  Z      (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).\n*         On entry, Z(1, I) contains the components of the deflation-\n*         adjusted updating row vector for subproblems on the I-th\n*         level.\n*\n*  POLES  (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).\n*         On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old\n*         singular values involved in the secular equations on the I-th\n*         level.\n*\n*  GIVPTR (input) INTEGER array, dimension ( N ).\n*         On entry, GIVPTR( I ) records the number of Givens\n*         rotations performed on the I-th problem on the computation\n*         tree.\n*\n*  GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ).\n*         On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the\n*         locations of Givens rotations performed on the I-th level on\n*         the computation tree.\n*\n*  LDGCOL (input) INTEGER, LDGCOL = > N.\n*         The leading dimension of arrays GIVCOL and PERM.\n*\n*  PERM   (input) INTEGER array, dimension ( LDGCOL, NLVL ).\n*         On entry, PERM(*, I) records permutations done on the I-th\n*         level of the computation tree.\n*\n*  GIVNUM (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).\n*         On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-\n*         values of Givens rotations performed on the I-th level on the\n*         computation tree.\n*\n*  C      (input) DOUBLE PRECISION array, dimension ( N ).\n*         On entry, if the I-th subproblem is not square,\n*         C( I ) contains the C-value of a Givens rotation related to\n*         the right null space of the I-th subproblem.\n*\n*  S      (input) DOUBLE PRECISION array, dimension ( N ).\n*         On entry, if the I-th subproblem is not square,\n*         S( I ) contains the S-value of a Givens rotation related to\n*         the right null space of the I-th subproblem.\n*\n*  RWORK  (workspace) DOUBLE PRECISION array, dimension at least\n*         MAX( (SMLSZ+1)*NRHS*3, N*(1+NRHS) + 2*NRHS ).\n*\n*  IWORK  (workspace) INTEGER array.\n*         The dimension must be at least 3 * N\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*  Based on contributions by\n*     Ming Gu and Ren-Cang Li, Computer Science Division, University of\n*       California at Berkeley, USA\n*     Osni Marques, LBNL/NERSC, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  bx, info, b = NumRu::Lapack.zlalsa( icompq, b, u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 15 && argc != 15)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
  rblapack_icompq = argv[0];
  rblapack_b = argv[1];
  rblapack_u = argv[2];
  rblapack_vt = argv[3];
  rblapack_k = argv[4];
  rblapack_difl = argv[5];
  rblapack_difr = argv[6];
  rblapack_z = argv[7];
  rblapack_poles = argv[8];
  rblapack_givptr = argv[9];
  rblapack_givcol = argv[10];
  rblapack_perm = argv[11];
  rblapack_givnum = argv[12];
  rblapack_c = argv[13];
  rblapack_s = argv[14];
  if (argc == 15) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  icompq = NUM2INT(rblapack_icompq);
  if (!NA_IsNArray(rblapack_u))
    rb_raise(rb_eArgError, "u (3th argument) must be NArray");
  if (NA_RANK(rblapack_u) != 2)
    rb_raise(rb_eArgError, "rank of u (3th argument) must be %d", 2);
  ldu = NA_SHAPE0(rblapack_u);
  smlsiz = NA_SHAPE1(rblapack_u);
  if (NA_TYPE(rblapack_u) != NA_DFLOAT)
    rblapack_u = na_change_type(rblapack_u, NA_DFLOAT);
  u = NA_PTR_TYPE(rblapack_u, doublereal*);
  if (!NA_IsNArray(rblapack_k))
    rb_raise(rb_eArgError, "k (5th argument) must be NArray");
  if (NA_RANK(rblapack_k) != 1)
    rb_raise(rb_eArgError, "rank of k (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_k);
  if (NA_TYPE(rblapack_k) != NA_LINT)
    rblapack_k = na_change_type(rblapack_k, NA_LINT);
  k = NA_PTR_TYPE(rblapack_k, integer*);
  if (!NA_IsNArray(rblapack_givptr))
    rb_raise(rb_eArgError, "givptr (10th argument) must be NArray");
  if (NA_RANK(rblapack_givptr) != 1)
    rb_raise(rb_eArgError, "rank of givptr (10th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_givptr) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of givptr must be the same as shape 0 of k");
  if (NA_TYPE(rblapack_givptr) != NA_LINT)
    rblapack_givptr = na_change_type(rblapack_givptr, NA_LINT);
  givptr = NA_PTR_TYPE(rblapack_givptr, integer*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (14th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (14th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of k");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (15th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (15th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 0 of k");
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  nlvl = (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1;
  if (!NA_IsNArray(rblapack_vt))
    rb_raise(rb_eArgError, "vt (4th argument) must be NArray");
  if (NA_RANK(rblapack_vt) != 2)
    rb_raise(rb_eArgError, "rank of vt (4th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_vt) != ldu)
    rb_raise(rb_eRuntimeError, "shape 0 of vt must be the same as shape 0 of u");
  if (NA_SHAPE1(rblapack_vt) != (smlsiz+1))
    rb_raise(rb_eRuntimeError, "shape 1 of vt must be %d", smlsiz+1);
  if (NA_TYPE(rblapack_vt) != NA_DFLOAT)
    rblapack_vt = na_change_type(rblapack_vt, NA_DFLOAT);
  vt = NA_PTR_TYPE(rblapack_vt, doublereal*);
  if (!NA_IsNArray(rblapack_difr))
    rb_raise(rb_eArgError, "difr (7th argument) must be NArray");
  if (NA_RANK(rblapack_difr) != 2)
    rb_raise(rb_eArgError, "rank of difr (7th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_difr) != ldu)
    rb_raise(rb_eRuntimeError, "shape 0 of difr must be the same as shape 0 of u");
  if (NA_SHAPE1(rblapack_difr) != (2 * nlvl))
    rb_raise(rb_eRuntimeError, "shape 1 of difr must be %d", 2 * nlvl);
  if (NA_TYPE(rblapack_difr) != NA_DFLOAT)
    rblapack_difr = na_change_type(rblapack_difr, NA_DFLOAT);
  difr = NA_PTR_TYPE(rblapack_difr, doublereal*);
  if (!NA_IsNArray(rblapack_poles))
    rb_raise(rb_eArgError, "poles (9th argument) must be NArray");
  if (NA_RANK(rblapack_poles) != 2)
    rb_raise(rb_eArgError, "rank of poles (9th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_poles) != ldu)
    rb_raise(rb_eRuntimeError, "shape 0 of poles must be the same as shape 0 of u");
  if (NA_SHAPE1(rblapack_poles) != (2 * nlvl))
    rb_raise(rb_eRuntimeError, "shape 1 of poles must be %d", 2 * nlvl);
  if (NA_TYPE(rblapack_poles) != NA_DFLOAT)
    rblapack_poles = na_change_type(rblapack_poles, NA_DFLOAT);
  poles = NA_PTR_TYPE(rblapack_poles, doublereal*);
  if (!NA_IsNArray(rblapack_perm))
    rb_raise(rb_eArgError, "perm (12th argument) must be NArray");
  if (NA_RANK(rblapack_perm) != 2)
    rb_raise(rb_eArgError, "rank of perm (12th argument) must be %d", 2);
  ldgcol = NA_SHAPE0(rblapack_perm);
  if (NA_SHAPE1(rblapack_perm) != nlvl)
    rb_raise(rb_eRuntimeError, "shape 1 of perm must be (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1");
  if (NA_TYPE(rblapack_perm) != NA_LINT)
    rblapack_perm = na_change_type(rblapack_perm, NA_LINT);
  perm = NA_PTR_TYPE(rblapack_perm, integer*);
  ldbx = n;
  if (!NA_IsNArray(rblapack_difl))
    rb_raise(rb_eArgError, "difl (6th argument) must be NArray");
  if (NA_RANK(rblapack_difl) != 2)
    rb_raise(rb_eArgError, "rank of difl (6th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_difl) != ldu)
    rb_raise(rb_eRuntimeError, "shape 0 of difl must be the same as shape 0 of u");
  if (NA_SHAPE1(rblapack_difl) != nlvl)
    rb_raise(rb_eRuntimeError, "shape 1 of difl must be (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1");
  if (NA_TYPE(rblapack_difl) != NA_DFLOAT)
    rblapack_difl = na_change_type(rblapack_difl, NA_DFLOAT);
  difl = NA_PTR_TYPE(rblapack_difl, doublereal*);
  if (!NA_IsNArray(rblapack_givcol))
    rb_raise(rb_eArgError, "givcol (11th argument) must be NArray");
  if (NA_RANK(rblapack_givcol) != 2)
    rb_raise(rb_eArgError, "rank of givcol (11th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_givcol) != ldgcol)
    rb_raise(rb_eRuntimeError, "shape 0 of givcol must be the same as shape 0 of perm");
  if (NA_SHAPE1(rblapack_givcol) != (2 * nlvl))
    rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", 2 * nlvl);
  if (NA_TYPE(rblapack_givcol) != NA_LINT)
    rblapack_givcol = na_change_type(rblapack_givcol, NA_LINT);
  givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (8th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_z) != ldu)
    rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of u");
  if (NA_SHAPE1(rblapack_z) != nlvl)
    rb_raise(rb_eRuntimeError, "shape 1 of z must be (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1");
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  if (!NA_IsNArray(rblapack_givnum))
    rb_raise(rb_eArgError, "givnum (13th argument) must be NArray");
  if (NA_RANK(rblapack_givnum) != 2)
    rb_raise(rb_eArgError, "rank of givnum (13th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_givnum) != ldu)
    rb_raise(rb_eRuntimeError, "shape 0 of givnum must be the same as shape 0 of u");
  if (NA_SHAPE1(rblapack_givnum) != (2 * nlvl))
    rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", 2 * nlvl);
  if (NA_TYPE(rblapack_givnum) != NA_DFLOAT)
    rblapack_givnum = na_change_type(rblapack_givnum, NA_DFLOAT);
  givnum = NA_PTR_TYPE(rblapack_givnum, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldbx;
    shape[1] = nrhs;
    rblapack_bx = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  bx = NA_PTR_TYPE(rblapack_bx, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  rwork = ALLOC_N(doublereal, (MAX(n,(smlsiz+1)*nrhs*3)));
  iwork = ALLOC_N(integer, (3 * n));

  zlalsa_(&icompq, &smlsiz, &n, &nrhs, b, &ldb, bx, &ldbx, u, &ldu, vt, k, difl, difr, z, poles, givptr, givcol, &ldgcol, perm, givnum, c, s, rwork, iwork, &info);

  free(rwork);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_bx, rblapack_info, rblapack_b);
}

void
init_lapack_zlalsa(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlalsa", rblapack_zlalsa, -1);
}
ruby-lapack-1.7.2/ext/zungql.c0000644000175000017500000001263212502221021016042 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zungql_(integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zungql(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;

  integer lda;
  integer n;
  integer k;

  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 = NumRu::Lapack.zungql( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZUNGQL generates an M-by-N complex matrix Q with orthonormal columns,\n*  which is defined as the last N columns of a product of K elementary\n*  reflectors of order M\n*\n*        Q  =  H(k) . . . H(2) H(1)\n*\n*  as returned by ZGEQLF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. M >= N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. N >= K >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the (n-k+i)-th column must contain the vector which\n*          defines the elementary reflector H(i), for i = 1,2,...,k, as\n*          returned by ZGEQLF in the last k columns of its array\n*          argument A.\n*          On exit, the M-by-N matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) COMPLEX*16 array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by ZGEQLF.\n*\n*  WORK    (workspace/output) COMPLEX*16 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,N).\n*          For optimum performance LWORK >= N*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 has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, a = NumRu::Lapack.zungql( m, a, tau, [: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_m = argv[0];
  rblapack_a = argv[1];
  rblapack_tau = 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;
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zungql_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_zungql(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zungql", rblapack_zungql, -1);
}
ruby-lapack-1.7.2/ext/dopmtr.c0000644000175000017500000001455612502221017016043 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dopmtr_(char* side, char* uplo, char* trans, integer* m, integer* n, doublereal* ap, doublereal* tau, doublereal* c, integer* ldc, doublereal* work, integer* info);


static VALUE
rblapack_dopmtr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublereal *c_out__;
  doublereal *work;

  integer ldc;
  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  info, c = NumRu::Lapack.dopmtr( side, uplo, trans, m, ap, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DOPMTR overwrites the general real M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'T':      Q**T * C       C * Q**T\n*\n*  where Q is a real orthogonal matrix of order nq, with nq = m if\n*  SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of\n*  nq-1 elementary reflectors, as returned by DSPTRD using packed\n*  storage:\n*\n*  if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);\n*\n*  if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**T from the Left;\n*          = 'R': apply Q or Q**T from the Right.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U': Upper triangular packed storage used in previous\n*                 call to DSPTRD;\n*          = 'L': Lower triangular packed storage used in previous\n*                 call to DSPTRD.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'T':  Transpose, apply Q**T.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  AP      (input) DOUBLE PRECISION array, dimension\n*                               (M*(M+1)/2) if SIDE = 'L'\n*                               (N*(N+1)/2) if SIDE = 'R'\n*          The vectors which define the elementary reflectors, as\n*          returned by DSPTRD.  AP is modified by the routine but\n*          restored on exit.\n*\n*  TAU     (input) DOUBLE PRECISION array, dimension (M-1) if SIDE = 'L'\n*                                     or (N-1) if SIDE = 'R'\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by DSPTRD.\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension\n*                                   (N) if SIDE = 'L'\n*                                   (M) if SIDE = 'R'\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, c = NumRu::Lapack.dopmtr( side, uplo, trans, m, ap, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_side = argv[0];
  rblapack_uplo = argv[1];
  rblapack_trans = argv[2];
  rblapack_m = argv[3];
  rblapack_ap = argv[4];
  rblapack_tau = argv[5];
  rblapack_c = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (6th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_tau) != (m-1))
    rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", m-1);
  if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (m*(m+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", m*(m+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  dopmtr_(&side, &uplo, &trans, &m, &n, ap, tau, c, &ldc, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_c);
}

void
init_lapack_dopmtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dopmtr", rblapack_dopmtr, -1);
}
ruby-lapack-1.7.2/ext/dlaqr2.c0000644000175000017500000002744212502221022015715 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaqr2_(logical* wantt, logical* wantz, integer* n, integer* ktop, integer* kbot, integer* nw, doublereal* h, integer* ldh, integer* iloz, integer* ihiz, doublereal* z, integer* ldz, integer* ns, integer* nd, doublereal* sr, doublereal* si, doublereal* v, integer* ldv, integer* nh, doublereal* t, integer* ldt, integer* nv, doublereal* wv, integer* ldwv, doublereal* work, integer* lwork);


static VALUE
rblapack_dlaqr2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantt;
  logical wantt; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_ktop;
  integer ktop; 
  VALUE rblapack_kbot;
  integer kbot; 
  VALUE rblapack_nw;
  integer nw; 
  VALUE rblapack_h;
  doublereal *h; 
  VALUE rblapack_iloz;
  integer iloz; 
  VALUE rblapack_ihiz;
  integer ihiz; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_nh;
  integer nh; 
  VALUE rblapack_nv;
  integer nv; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_ns;
  integer ns; 
  VALUE rblapack_nd;
  integer nd; 
  VALUE rblapack_sr;
  doublereal *sr; 
  VALUE rblapack_si;
  doublereal *si; 
  VALUE rblapack_h_out__;
  doublereal *h_out__;
  VALUE rblapack_z_out__;
  doublereal *z_out__;
  doublereal *v;
  doublereal *t;
  doublereal *wv;
  doublereal *work;

  integer ldh;
  integer n;
  integer ldz;
  integer ldv;
  integer ldt;
  integer ldwv;

  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  ns, nd, sr, si, h, z = NumRu::Lapack.dlaqr2( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n*     This subroutine is identical to DLAQR3 except that it avoids\n*     recursion by calling DLAHQR instead of DLAQR4.\n*\n*\n*     ******************************************************************\n*     Aggressive early deflation:\n*\n*     This subroutine accepts as input an upper Hessenberg matrix\n*     H and performs an orthogonal similarity transformation\n*     designed to detect and deflate fully converged eigenvalues from\n*     a trailing principal submatrix.  On output H has been over-\n*     written by a new Hessenberg matrix that is a perturbation of\n*     an orthogonal similarity transformation of H.  It is to be\n*     hoped that the final version of H has many zero subdiagonal\n*     entries.\n*\n*     ******************************************************************\n\n*     WANTT   (input) LOGICAL\n*          If .TRUE., then the Hessenberg matrix H is fully updated\n*          so that the quasi-triangular Schur factor may be\n*          computed (in cooperation with the calling subroutine).\n*          If .FALSE., then only enough of H is updated to preserve\n*          the eigenvalues.\n*\n*     WANTZ   (input) LOGICAL\n*          If .TRUE., then the orthogonal matrix Z is updated so\n*          so that the orthogonal Schur factor may be computed\n*          (in cooperation with the calling subroutine).\n*          If .FALSE., then Z is not referenced.\n*\n*     N       (input) INTEGER\n*          The order of the matrix H and (if WANTZ is .TRUE.) the\n*          order of the orthogonal matrix Z.\n*\n*     KTOP    (input) INTEGER\n*          It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n*          KBOT and KTOP together determine an isolated block\n*          along the diagonal of the Hessenberg matrix.\n*\n*     KBOT    (input) INTEGER\n*          It is assumed without a check that either\n*          KBOT = N or H(KBOT+1,KBOT)=0.  KBOT and KTOP together\n*          determine an isolated block along the diagonal of the\n*          Hessenberg matrix.\n*\n*     NW      (input) INTEGER\n*          Deflation window size.  1 .LE. NW .LE. (KBOT-KTOP+1).\n*\n*     H       (input/output) DOUBLE PRECISION array, dimension (LDH,N)\n*          On input the initial N-by-N section of H stores the\n*          Hessenberg matrix undergoing aggressive early deflation.\n*          On output H has been transformed by an orthogonal\n*          similarity transformation, perturbed, and the returned\n*          to Hessenberg form that (it is to be hoped) has some\n*          zero subdiagonal entries.\n*\n*     LDH     (input) integer\n*          Leading dimension of H just as declared in the calling\n*          subroutine.  N .LE. LDH\n*\n*     ILOZ    (input) INTEGER\n*     IHIZ    (input) INTEGER\n*          Specify the rows of Z to which transformations must be\n*          applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n*\n*     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n*          IF WANTZ is .TRUE., then on output, the orthogonal\n*          similarity transformation mentioned above has been\n*          accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n*          If WANTZ is .FALSE., then Z is unreferenced.\n*\n*     LDZ     (input) integer\n*          The leading dimension of Z just as declared in the\n*          calling subroutine.  1 .LE. LDZ.\n*\n*     NS      (output) integer\n*          The number of unconverged (ie approximate) eigenvalues\n*          returned in SR and SI that may be used as shifts by the\n*          calling subroutine.\n*\n*     ND      (output) integer\n*          The number of converged eigenvalues uncovered by this\n*          subroutine.\n*\n*     SR      (output) DOUBLE PRECISION array, dimension (KBOT)\n*     SI      (output) DOUBLE PRECISION array, dimension (KBOT)\n*          On output, the real and imaginary parts of approximate\n*          eigenvalues that may be used for shifts are stored in\n*          SR(KBOT-ND-NS+1) through SR(KBOT-ND) and\n*          SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.\n*          The real and imaginary parts of converged eigenvalues\n*          are stored in SR(KBOT-ND+1) through SR(KBOT) and\n*          SI(KBOT-ND+1) through SI(KBOT), respectively.\n*\n*     V       (workspace) DOUBLE PRECISION array, dimension (LDV,NW)\n*          An NW-by-NW work array.\n*\n*     LDV     (input) integer scalar\n*          The leading dimension of V just as declared in the\n*          calling subroutine.  NW .LE. LDV\n*\n*     NH      (input) integer scalar\n*          The number of columns of T.  NH.GE.NW.\n*\n*     T       (workspace) DOUBLE PRECISION array, dimension (LDT,NW)\n*\n*     LDT     (input) integer\n*          The leading dimension of T just as declared in the\n*          calling subroutine.  NW .LE. LDT\n*\n*     NV      (input) integer\n*          The number of rows of work array WV available for\n*          workspace.  NV.GE.NW.\n*\n*     WV      (workspace) DOUBLE PRECISION array, dimension (LDWV,NW)\n*\n*     LDWV    (input) integer\n*          The leading dimension of W just as declared in the\n*          calling subroutine.  NW .LE. LDV\n*\n*     WORK    (workspace) DOUBLE PRECISION array, dimension (LWORK)\n*          On exit, WORK(1) is set to an estimate of the optimal value\n*          of LWORK for the given values of N, NW, KTOP and KBOT.\n*\n*     LWORK   (input) integer\n*          The dimension of the work array WORK.  LWORK = 2*NW\n*          suffices, but greater efficiency may result from larger\n*          values of LWORK.\n*\n*          If LWORK = -1, then a workspace query is assumed; DLAQR2\n*          only estimates the optimal workspace size for the given\n*          values of N, NW, KTOP and KBOT.  The estimate is returned\n*          in WORK(1).  No error message related to LWORK is issued\n*          by XERBLA.  Neither H nor Z are accessed.\n*\n\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ns, nd, sr, si, h, z = NumRu::Lapack.dlaqr2( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 11 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
  rblapack_wantt = argv[0];
  rblapack_wantz = argv[1];
  rblapack_ktop = argv[2];
  rblapack_kbot = argv[3];
  rblapack_nw = argv[4];
  rblapack_h = argv[5];
  rblapack_iloz = argv[6];
  rblapack_ihiz = argv[7];
  rblapack_z = argv[8];
  rblapack_nh = argv[9];
  rblapack_nv = argv[10];
  if (argc == 12) {
    rblapack_lwork = argv[11];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  wantt = (rblapack_wantt == Qtrue);
  ktop = NUM2INT(rblapack_ktop);
  nw = NUM2INT(rblapack_nw);
  iloz = NUM2INT(rblapack_iloz);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (9th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  n = NA_SHAPE1(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  nv = NUM2INT(rblapack_nv);
  ldwv = nw;
  ldv = nw;
  wantz = (rblapack_wantz == Qtrue);
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (6th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  if (NA_SHAPE1(rblapack_h) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of z");
  if (NA_TYPE(rblapack_h) != NA_DFLOAT)
    rblapack_h = na_change_type(rblapack_h, NA_DFLOAT);
  h = NA_PTR_TYPE(rblapack_h, doublereal*);
  nh = NUM2INT(rblapack_nh);
  ldt = nw;
  kbot = NUM2INT(rblapack_kbot);
  if (rblapack_lwork == Qnil)
    lwork = 2*nw;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ihiz = NUM2INT(rblapack_ihiz);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,kbot);
    rblapack_sr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  sr = NA_PTR_TYPE(rblapack_sr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,kbot);
    rblapack_si = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  si = NA_PTR_TYPE(rblapack_si, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublereal*);
  MEMCPY(h_out__, h, doublereal, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
  MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  v = ALLOC_N(doublereal, (ldv)*(MAX(1,nw)));
  t = ALLOC_N(doublereal, (ldt)*(MAX(1,nw)));
  wv = ALLOC_N(doublereal, (ldwv)*(MAX(1,nw)));
  work = ALLOC_N(doublereal, (MAX(1,lwork)));

  dlaqr2_(&wantt, &wantz, &n, &ktop, &kbot, &nw, h, &ldh, &iloz, &ihiz, z, &ldz, &ns, &nd, sr, si, v, &ldv, &nh, t, &ldt, &nv, wv, &ldwv, work, &lwork);

  free(v);
  free(t);
  free(wv);
  free(work);
  rblapack_ns = INT2NUM(ns);
  rblapack_nd = INT2NUM(nd);
  return rb_ary_new3(6, rblapack_ns, rblapack_nd, rblapack_sr, rblapack_si, rblapack_h, rblapack_z);
}

void
init_lapack_dlaqr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaqr2", rblapack_dlaqr2, -1);
}
ruby-lapack-1.7.2/ext/zla_herfsx_extended.c0000644000175000017500000005730512502221014020557 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zla_herfsx_extended_(integer* prec_type, char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, logical* colequ, doublereal* c, doublecomplex* b, integer* ldb, doublecomplex* y, integer* ldy, doublereal* berr_out, integer* n_norms, doublereal* err_bnds_norm, doublereal* err_bnds_comp, doublecomplex* res, doublereal* ayb, doublecomplex* dy, doublecomplex* y_tail, doublereal* rcond, integer* ithresh, doublereal* rthresh, doublereal* dz_ub, logical* ignore_cwise, integer* info);


static VALUE
rblapack_zla_herfsx_extended(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_prec_type;
  integer prec_type; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_colequ;
  logical colequ; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_y;
  doublecomplex *y; 
  VALUE rblapack_n_norms;
  integer n_norms; 
  VALUE rblapack_err_bnds_norm;
  doublereal *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  doublereal *err_bnds_comp; 
  VALUE rblapack_res;
  doublecomplex *res; 
  VALUE rblapack_ayb;
  doublereal *ayb; 
  VALUE rblapack_dy;
  doublecomplex *dy; 
  VALUE rblapack_y_tail;
  doublecomplex *y_tail; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_ithresh;
  integer ithresh; 
  VALUE rblapack_rthresh;
  doublereal rthresh; 
  VALUE rblapack_dz_ub;
  doublereal dz_ub; 
  VALUE rblapack_ignore_cwise;
  logical ignore_cwise; 
  VALUE rblapack_berr_out;
  doublereal *berr_out; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_y_out__;
  doublecomplex *y_out__;
  VALUE rblapack_err_bnds_norm_out__;
  doublereal *err_bnds_norm_out__;
  VALUE rblapack_err_bnds_comp_out__;
  doublereal *err_bnds_comp_out__;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldy;
  integer n_err_bnds;

  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  berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.zla_herfsx_extended( prec_type, uplo, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLA_HERFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZLA_HERFSX_EXTENDED improves the computed solution to a system of\n*  linear equations by performing extra-precise iterative refinement\n*  and provides error bounds and backward error estimates for the solution.\n*  This subroutine is called by ZHERFSX to perform iterative refinement.\n*  In addition to normwise error bound, the code provides maximum\n*  componentwise error bound if possible. See comments for ERR_BNDS_NORM\n*  and ERR_BNDS_COMP for details of the error bounds. Note that this\n*  subroutine is only resonsible for setting the second fields of\n*  ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n*  Arguments\n*  =========\n*\n*     PREC_TYPE      (input) INTEGER\n*     Specifies the intermediate precision to be used in refinement.\n*     The value is defined by ILAPREC(P) where P is a CHARACTER and\n*     P    = 'S':  Single\n*          = 'D':  Double\n*          = 'I':  Indigenous\n*          = 'X', 'E':  Extra\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N              (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NRHS           (input) INTEGER\n*     The number of right-hand-sides, i.e., the number of columns of the\n*     matrix B.\n*\n*     A              (input) COMPLEX*16 array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA            (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF             (input) COMPLEX*16 array, dimension (LDAF,N)\n*     The block diagonal matrix D and the multipliers used to\n*     obtain the factor U or L as computed by ZHETRF.\n*\n*     LDAF           (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV           (input) INTEGER array, dimension (N)\n*     Details of the interchanges and the block structure of D\n*     as determined by ZHETRF.\n*\n*     COLEQU         (input) LOGICAL\n*     If .TRUE. then column equilibration was done to A before calling\n*     this routine. This is needed to compute the solution and error\n*     bounds correctly.\n*\n*     C              (input) DOUBLE PRECISION array, dimension (N)\n*     The column scale factors for A. If COLEQU = .FALSE., C\n*     is not accessed. If C is input, each element of C should be a power\n*     of the radix to ensure a reliable solution and error estimates.\n*     Scaling by powers of the radix does not cause rounding errors unless\n*     the result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B              (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*     The right-hand-side matrix B.\n*\n*     LDB            (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     Y              (input/output) COMPLEX*16 array, dimension\n*                    (LDY,NRHS)\n*     On entry, the solution matrix X, as computed by ZHETRS.\n*     On exit, the improved solution matrix Y.\n*\n*     LDY            (input) INTEGER\n*     The leading dimension of the array Y.  LDY >= max(1,N).\n*\n*     BERR_OUT       (output) DOUBLE PRECISION array, dimension (NRHS)\n*     On exit, BERR_OUT(j) contains the componentwise relative backward\n*     error for right-hand-side j from the formula\n*         max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n*     where abs(Z) is the componentwise absolute value of the matrix\n*     or vector Z. This is computed by ZLA_LIN_BERR.\n*\n*     N_NORMS        (input) INTEGER\n*     Determines which error bounds to return (see ERR_BNDS_NORM\n*     and ERR_BNDS_COMP).\n*     If N_NORMS >= 1 return normwise error bounds.\n*     If N_NORMS >= 2 return componentwise error bounds.\n*\n*     ERR_BNDS_NORM  (input/output) DOUBLE PRECISION array, dimension\n*                    (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (input/output) DOUBLE PRECISION array, dimension\n*                    (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     RES            (input) COMPLEX*16 array, dimension (N)\n*     Workspace to hold the intermediate residual.\n*\n*     AYB            (input) DOUBLE PRECISION array, dimension (N)\n*     Workspace.\n*\n*     DY             (input) COMPLEX*16 array, dimension (N)\n*     Workspace to hold the intermediate solution.\n*\n*     Y_TAIL         (input) COMPLEX*16 array, dimension (N)\n*     Workspace to hold the trailing bits of the intermediate solution.\n*\n*     RCOND          (input) DOUBLE PRECISION\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     ITHRESH        (input) INTEGER\n*     The maximum number of residual computations allowed for\n*     refinement. The default is 10. For 'aggressive' set to 100 to\n*     permit convergence using approximate factorizations or\n*     factorizations other than LU. If the factorization uses a\n*     technique other than Gaussian elimination, the guarantees in\n*     ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n*     RTHRESH        (input) DOUBLE PRECISION\n*     Determines when to stop refinement if the error estimate stops\n*     decreasing. Refinement will stop when the next solution no longer\n*     satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n*     the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n*     default value is 0.5. For 'aggressive' set to 0.9 to permit\n*     convergence on extremely ill-conditioned matrices. See LAWN 165\n*     for more details.\n*\n*     DZ_UB          (input) DOUBLE PRECISION\n*     Determines when to start considering componentwise convergence.\n*     Componentwise convergence is only considered after each component\n*     of the solution Y is stable, which we definte as the relative\n*     change in each component being less than DZ_UB. The default value\n*     is 0.25, requiring the first bit to be stable. See LAWN 165 for\n*     more details.\n*\n*     IGNORE_CWISE   (input) LOGICAL\n*     If .TRUE. then ignore componentwise convergence. Default value\n*     is .FALSE..\n*\n*     INFO           (output) INTEGER\n*       = 0:  Successful exit.\n*       < 0:  if INFO = -i, the ith argument to ZHETRS had an illegal\n*             value\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            UPLO2, CNT, I, J, X_STATE, Z_STATE,\n     $                   Y_PREC_STATE\n      DOUBLE PRECISION   YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n     $                   DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n     $                   DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n     $                   EPS, HUGEVAL, INCR_THRESH\n      LOGICAL            INCR_PREC\n      COMPLEX*16         ZDUM\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.zla_herfsx_extended( prec_type, uplo, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 21 && argc != 21)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 21)", argc);
  rblapack_prec_type = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_colequ = argv[5];
  rblapack_c = argv[6];
  rblapack_b = argv[7];
  rblapack_y = argv[8];
  rblapack_n_norms = argv[9];
  rblapack_err_bnds_norm = argv[10];
  rblapack_err_bnds_comp = argv[11];
  rblapack_res = argv[12];
  rblapack_ayb = argv[13];
  rblapack_dy = argv[14];
  rblapack_y_tail = argv[15];
  rblapack_rcond = argv[16];
  rblapack_ithresh = argv[17];
  rblapack_rthresh = argv[18];
  rblapack_dz_ub = argv[19];
  rblapack_ignore_cwise = argv[20];
  if (argc == 21) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  prec_type = NUM2INT(rblapack_prec_type);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (9th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 2)
    rb_raise(rb_eArgError, "rank of y (9th argument) must be %d", 2);
  ldy = NA_SHAPE0(rblapack_y);
  nrhs = NA_SHAPE1(rblapack_y);
  if (NA_TYPE(rblapack_y) != NA_DCOMPLEX)
    rblapack_y = na_change_type(rblapack_y, NA_DCOMPLEX);
  y = NA_PTR_TYPE(rblapack_y, doublecomplex*);
  if (!NA_IsNArray(rblapack_err_bnds_norm))
    rb_raise(rb_eArgError, "err_bnds_norm (11th argument) must be NArray");
  if (NA_RANK(rblapack_err_bnds_norm) != 2)
    rb_raise(rb_eArgError, "rank of err_bnds_norm (11th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_err_bnds_norm) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of y");
  n_err_bnds = NA_SHAPE1(rblapack_err_bnds_norm);
  if (NA_TYPE(rblapack_err_bnds_norm) != NA_DFLOAT)
    rblapack_err_bnds_norm = na_change_type(rblapack_err_bnds_norm, NA_DFLOAT);
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
  if (!NA_IsNArray(rblapack_res))
    rb_raise(rb_eArgError, "res (13th argument) must be NArray");
  if (NA_RANK(rblapack_res) != 1)
    rb_raise(rb_eArgError, "rank of res (13th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_res) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_res) != NA_DCOMPLEX)
    rblapack_res = na_change_type(rblapack_res, NA_DCOMPLEX);
  res = NA_PTR_TYPE(rblapack_res, doublecomplex*);
  if (!NA_IsNArray(rblapack_dy))
    rb_raise(rb_eArgError, "dy (15th argument) must be NArray");
  if (NA_RANK(rblapack_dy) != 1)
    rb_raise(rb_eArgError, "rank of dy (15th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dy) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_dy) != NA_DCOMPLEX)
    rblapack_dy = na_change_type(rblapack_dy, NA_DCOMPLEX);
  dy = NA_PTR_TYPE(rblapack_dy, doublecomplex*);
  rcond = NUM2DBL(rblapack_rcond);
  rthresh = NUM2DBL(rblapack_rthresh);
  ignore_cwise = (rblapack_ignore_cwise == Qtrue);
  uplo = StringValueCStr(rblapack_uplo)[0];
  colequ = (rblapack_colequ == Qtrue);
  n_norms = NUM2INT(rblapack_n_norms);
  if (!NA_IsNArray(rblapack_ayb))
    rb_raise(rb_eArgError, "ayb (14th argument) must be NArray");
  if (NA_RANK(rblapack_ayb) != 1)
    rb_raise(rb_eArgError, "rank of ayb (14th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ayb) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ayb) != NA_DFLOAT)
    rblapack_ayb = na_change_type(rblapack_ayb, NA_DFLOAT);
  ayb = NA_PTR_TYPE(rblapack_ayb, doublereal*);
  ithresh = NUM2INT(rblapack_ithresh);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  if (!NA_IsNArray(rblapack_err_bnds_comp))
    rb_raise(rb_eArgError, "err_bnds_comp (12th argument) must be NArray");
  if (NA_RANK(rblapack_err_bnds_comp) != 2)
    rb_raise(rb_eArgError, "rank of err_bnds_comp (12th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_err_bnds_comp) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of y");
  if (NA_SHAPE1(rblapack_err_bnds_comp) != n_err_bnds)
    rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_comp must be the same as shape 1 of err_bnds_norm");
  if (NA_TYPE(rblapack_err_bnds_comp) != NA_DFLOAT)
    rblapack_err_bnds_comp = na_change_type(rblapack_err_bnds_comp, NA_DFLOAT);
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
  dz_ub = NUM2DBL(rblapack_dz_ub);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of y");
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  if (!NA_IsNArray(rblapack_y_tail))
    rb_raise(rb_eArgError, "y_tail (16th argument) must be NArray");
  if (NA_RANK(rblapack_y_tail) != 1)
    rb_raise(rb_eArgError, "rank of y_tail (16th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y_tail) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_y_tail) != NA_DCOMPLEX)
    rblapack_y_tail = na_change_type(rblapack_y_tail, NA_DCOMPLEX);
  y_tail = NA_PTR_TYPE(rblapack_y_tail, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr_out = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr_out = NA_PTR_TYPE(rblapack_berr_out, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldy;
    shape[1] = nrhs;
    rblapack_y_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublecomplex*);
  MEMCPY(y_out__, y, doublecomplex, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm_out__ = NA_PTR_TYPE(rblapack_err_bnds_norm_out__, doublereal*);
  MEMCPY(err_bnds_norm_out__, err_bnds_norm, doublereal, NA_TOTAL(rblapack_err_bnds_norm));
  rblapack_err_bnds_norm = rblapack_err_bnds_norm_out__;
  err_bnds_norm = err_bnds_norm_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp_out__ = NA_PTR_TYPE(rblapack_err_bnds_comp_out__, doublereal*);
  MEMCPY(err_bnds_comp_out__, err_bnds_comp, doublereal, NA_TOTAL(rblapack_err_bnds_comp));
  rblapack_err_bnds_comp = rblapack_err_bnds_comp_out__;
  err_bnds_comp = err_bnds_comp_out__;

  zla_herfsx_extended_(&prec_type, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_err_bnds_norm, rblapack_err_bnds_comp);
}

void
init_lapack_zla_herfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zla_herfsx_extended", rblapack_zla_herfsx_extended, -1);
}
ruby-lapack-1.7.2/ext/claqsy.c0000644000175000017500000001226312502221024016021 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID claqsy_(char* uplo, integer* n, complex* a, integer* lda, real* s, real* scond, real* amax, char* equed);


static VALUE
rblapack_claqsy(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_scond;
  real scond; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_a_out__;
  complex *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  equed, a = NumRu::Lapack.claqsy( uplo, a, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )\n\n*  Purpose\n*  =======\n*\n*  CLAQSY equilibrates a symmetric matrix A using the scaling factors\n*  in the vector S.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          n by n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n by n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if EQUED = 'Y', the equilibrated matrix:\n*          diag(S) * A * diag(S).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(N,1).\n*\n*  S       (input) REAL array, dimension (N)\n*          The scale factors for A.\n*\n*  SCOND   (input) REAL\n*          Ratio of the smallest S(i) to the largest S(i).\n*\n*  AMAX    (input) REAL\n*          Absolute value of largest matrix entry.\n*\n*  EQUED   (output) CHARACTER*1\n*          Specifies whether or not equilibration was done.\n*          = 'N':  No equilibration.\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*\n*  Internal Parameters\n*  ===================\n*\n*  THRESH is a threshold value used to decide if scaling should be done\n*  based on the ratio of the scaling factors.  If SCOND < THRESH,\n*  scaling is done.\n*\n*  LARGE and SMALL are threshold values used to decide if scaling should\n*  be done based on the absolute size of the largest matrix element.\n*  If AMAX > LARGE or AMAX < SMALL, scaling is done.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  equed, a = NumRu::Lapack.claqsy( uplo, a, s, scond, amax, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_s = argv[2];
  rblapack_scond = argv[3];
  rblapack_amax = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (3th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_s);
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  amax = (real)NUM2DBL(rblapack_amax);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of s");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  scond = (real)NUM2DBL(rblapack_scond);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  claqsy_(&uplo, &n, a, &lda, s, &scond, &amax, &equed);

  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(2, rblapack_equed, rblapack_a);
}

void
init_lapack_claqsy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "claqsy", rblapack_claqsy, -1);
}
ruby-lapack-1.7.2/ext/sormr3.c0000644000175000017500000001553412502221016015757 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sormr3_(char* side, char* trans, integer* m, integer* n, integer* k, integer* l, real* a, integer* lda, real* tau, real* c, integer* ldc, real* work, integer* info);


static VALUE
rblapack_sormr3(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  real *c_out__;
  real *work;

  integer lda;
  integer m;
  integer k;
  integer ldc;
  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  info, c = NumRu::Lapack.sormr3( side, trans, l, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SORMR3 overwrites the general real m by n matrix C with\n*\n*        Q * C  if SIDE = 'L' and TRANS = 'N', or\n*\n*        Q'* C  if SIDE = 'L' and TRANS = 'T', or\n*\n*        C * Q  if SIDE = 'R' and TRANS = 'N', or\n*\n*        C * Q' if SIDE = 'R' and TRANS = 'T',\n*\n*  where Q is a real orthogonal matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(1) H(2) . . . H(k)\n*\n*  as returned by STZRZF. Q is of order m if SIDE = 'L' and of order n\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q' from the Left\n*          = 'R': apply Q or Q' from the Right\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': apply Q  (No transpose)\n*          = 'T': apply Q' (Transpose)\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  L       (input) INTEGER\n*          The number of columns of the matrix A containing\n*          the meaningful part of the Householder reflectors.\n*          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n*  A       (input) REAL array, dimension\n*                               (LDA,M) if SIDE = 'L',\n*                               (LDA,N) if SIDE = 'R'\n*          The i-th row must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          STZRZF in the last k rows of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,K).\n*\n*  TAU     (input) REAL array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by STZRZF.\n*\n*  C       (input/output) REAL array, dimension (LDC,N)\n*          On entry, the m-by-n matrix C.\n*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) REAL array, dimension\n*                                   (N) if SIDE = 'L',\n*                                   (M) if SIDE = 'R'\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*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LEFT, NOTRAN\n      INTEGER            I, I1, I2, I3, IC, JA, JC, MI, NI, NQ\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SLARZ, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, c = NumRu::Lapack.sormr3( side, trans, l, a, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_l = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  l = NUM2INT(rblapack_l);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  sormr3_(&side, &trans, &m, &n, &k, &l, a, &lda, tau, c, &ldc, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_c);
}

void
init_lapack_sormr3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sormr3", rblapack_sormr3, -1);
}
ruby-lapack-1.7.2/ext/dlaqr5.c0000644000175000017500000002763512502221025015727 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaqr5_(logical* wantt, logical* wantz, integer* kacc22, integer* n, integer* ktop, integer* kbot, integer* nshfts, doublereal* sr, doublereal* si, doublereal* h, integer* ldh, integer* iloz, integer* ihiz, doublereal* z, integer* ldz, doublereal* v, integer* ldv, doublereal* u, integer* ldu, integer* nv, doublereal* wv, integer* ldwv, integer* nh, doublereal* wh, integer* ldwh);


static VALUE
rblapack_dlaqr5(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantt;
  logical wantt; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_kacc22;
  integer kacc22; 
  VALUE rblapack_ktop;
  integer ktop; 
  VALUE rblapack_kbot;
  integer kbot; 
  VALUE rblapack_sr;
  doublereal *sr; 
  VALUE rblapack_si;
  doublereal *si; 
  VALUE rblapack_h;
  doublereal *h; 
  VALUE rblapack_iloz;
  integer iloz; 
  VALUE rblapack_ihiz;
  integer ihiz; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_nv;
  integer nv; 
  VALUE rblapack_nh;
  integer nh; 
  VALUE rblapack_sr_out__;
  doublereal *sr_out__;
  VALUE rblapack_si_out__;
  doublereal *si_out__;
  VALUE rblapack_h_out__;
  doublereal *h_out__;
  VALUE rblapack_z_out__;
  doublereal *z_out__;
  doublereal *v;
  doublereal *u;
  doublereal *wv;
  doublereal *wh;

  integer nshfts;
  integer ldh;
  integer n;
  integer ldv;
  integer ldu;
  integer ldwv;
  integer ldwh;
  integer ldz;

  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  sr, si, h, z = NumRu::Lapack.dlaqr5( wantt, wantz, kacc22, ktop, kbot, sr, si, h, iloz, ihiz, z, nv, nh, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, SR, SI, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, WV, LDWV, NH, WH, LDWH )\n\n*     This auxiliary subroutine called by DLAQR0 performs a\n*     single small-bulge multi-shift QR sweep.\n*\n\n*      WANTT  (input) logical scalar\n*             WANTT = .true. if the quasi-triangular Schur factor\n*             is being computed.  WANTT is set to .false. otherwise.\n*\n*      WANTZ  (input) logical scalar\n*             WANTZ = .true. if the orthogonal Schur factor is being\n*             computed.  WANTZ is set to .false. otherwise.\n*\n*      KACC22 (input) integer with value 0, 1, or 2.\n*             Specifies the computation mode of far-from-diagonal\n*             orthogonal updates.\n*        = 0: DLAQR5 does not accumulate reflections and does not\n*             use matrix-matrix multiply to update far-from-diagonal\n*             matrix entries.\n*        = 1: DLAQR5 accumulates reflections and uses matrix-matrix\n*             multiply to update the far-from-diagonal matrix entries.\n*        = 2: DLAQR5 accumulates reflections, uses matrix-matrix\n*             multiply to update the far-from-diagonal matrix entries,\n*             and takes advantage of 2-by-2 block structure during\n*             matrix multiplies.\n*\n*      N      (input) integer scalar\n*             N is the order of the Hessenberg matrix H upon which this\n*             subroutine operates.\n*\n*      KTOP   (input) integer scalar\n*      KBOT   (input) integer scalar\n*             These are the first and last rows and columns of an\n*             isolated diagonal block upon which the QR sweep is to be\n*             applied. It is assumed without a check that\n*                       either KTOP = 1  or   H(KTOP,KTOP-1) = 0\n*             and\n*                       either KBOT = N  or   H(KBOT+1,KBOT) = 0.\n*\n*      NSHFTS (input) integer scalar\n*             NSHFTS gives the number of simultaneous shifts.  NSHFTS\n*             must be positive and even.\n*\n*      SR     (input/output) DOUBLE PRECISION array of size (NSHFTS)\n*      SI     (input/output) DOUBLE PRECISION array of size (NSHFTS)\n*             SR contains the real parts and SI contains the imaginary\n*             parts of the NSHFTS shifts of origin that define the\n*             multi-shift QR sweep.  On output SR and SI may be\n*             reordered.\n*\n*      H      (input/output) DOUBLE PRECISION array of size (LDH,N)\n*             On input H contains a Hessenberg matrix.  On output a\n*             multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied\n*             to the isolated diagonal block in rows and columns KTOP\n*             through KBOT.\n*\n*      LDH    (input) integer scalar\n*             LDH is the leading dimension of H just as declared in the\n*             calling procedure.  LDH.GE.MAX(1,N).\n*\n*      ILOZ   (input) INTEGER\n*      IHIZ   (input) INTEGER\n*             Specify the rows of Z to which transformations must be\n*             applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N\n*\n*      Z      (input/output) DOUBLE PRECISION array of size (LDZ,IHI)\n*             If WANTZ = .TRUE., then the QR Sweep orthogonal\n*             similarity transformation is accumulated into\n*             Z(ILOZ:IHIZ,ILO:IHI) from the right.\n*             If WANTZ = .FALSE., then Z is unreferenced.\n*\n*      LDZ    (input) integer scalar\n*             LDA is the leading dimension of Z just as declared in\n*             the calling procedure. LDZ.GE.N.\n*\n*      V      (workspace) DOUBLE PRECISION array of size (LDV,NSHFTS/2)\n*\n*      LDV    (input) integer scalar\n*             LDV is the leading dimension of V as declared in the\n*             calling procedure.  LDV.GE.3.\n*\n*      U      (workspace) DOUBLE PRECISION array of size\n*             (LDU,3*NSHFTS-3)\n*\n*      LDU    (input) integer scalar\n*             LDU is the leading dimension of U just as declared in the\n*             in the calling subroutine.  LDU.GE.3*NSHFTS-3.\n*\n*      NH     (input) integer scalar\n*             NH is the number of columns in array WH available for\n*             workspace. NH.GE.1.\n*\n*      WH     (workspace) DOUBLE PRECISION array of size (LDWH,NH)\n*\n*      LDWH   (input) integer scalar\n*             Leading dimension of WH just as declared in the\n*             calling procedure.  LDWH.GE.3*NSHFTS-3.\n*\n*      NV     (input) integer scalar\n*             NV is the number of rows in WV agailable for workspace.\n*             NV.GE.1.\n*\n*      WV     (workspace) DOUBLE PRECISION array of size\n*             (LDWV,3*NSHFTS-3)\n*\n*      LDWV   (input) integer scalar\n*             LDWV is the leading dimension of WV as declared in the\n*             in the calling subroutine.  LDWV.GE.NV.\n*\n\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n*     Reference:\n*\n*     K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n*     Algorithm Part I: Maintaining Well Focused Shifts, and\n*     Level 3 Performance, SIAM Journal of Matrix Analysis,\n*     volume 23, pages 929--947, 2002.\n*\n*     ================================================================\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sr, si, h, z = NumRu::Lapack.dlaqr5( wantt, wantz, kacc22, ktop, kbot, sr, si, h, iloz, ihiz, z, nv, nh, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 13 && argc != 13)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 13)", argc);
  rblapack_wantt = argv[0];
  rblapack_wantz = argv[1];
  rblapack_kacc22 = argv[2];
  rblapack_ktop = argv[3];
  rblapack_kbot = argv[4];
  rblapack_sr = argv[5];
  rblapack_si = argv[6];
  rblapack_h = argv[7];
  rblapack_iloz = argv[8];
  rblapack_ihiz = argv[9];
  rblapack_z = argv[10];
  rblapack_nv = argv[11];
  rblapack_nh = argv[12];
  if (argc == 13) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  wantt = (rblapack_wantt == Qtrue);
  kacc22 = NUM2INT(rblapack_kacc22);
  kbot = NUM2INT(rblapack_kbot);
  if (!NA_IsNArray(rblapack_si))
    rb_raise(rb_eArgError, "si (7th argument) must be NArray");
  if (NA_RANK(rblapack_si) != 1)
    rb_raise(rb_eArgError, "rank of si (7th argument) must be %d", 1);
  nshfts = NA_SHAPE0(rblapack_si);
  if (NA_TYPE(rblapack_si) != NA_DFLOAT)
    rblapack_si = na_change_type(rblapack_si, NA_DFLOAT);
  si = NA_PTR_TYPE(rblapack_si, doublereal*);
  iloz = NUM2INT(rblapack_iloz);
  nv = NUM2INT(rblapack_nv);
  ldwv = nv;
  ldv = 3;
  wantz = (rblapack_wantz == Qtrue);
  if (!NA_IsNArray(rblapack_sr))
    rb_raise(rb_eArgError, "sr (6th argument) must be NArray");
  if (NA_RANK(rblapack_sr) != 1)
    rb_raise(rb_eArgError, "rank of sr (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_sr) != nshfts)
    rb_raise(rb_eRuntimeError, "shape 0 of sr must be the same as shape 0 of si");
  if (NA_TYPE(rblapack_sr) != NA_DFLOAT)
    rblapack_sr = na_change_type(rblapack_sr, NA_DFLOAT);
  sr = NA_PTR_TYPE(rblapack_sr, doublereal*);
  ihiz = NUM2INT(rblapack_ihiz);
  nh = NUM2INT(rblapack_nh);
  ldu = 3*nshfts-3;
  ktop = NUM2INT(rblapack_ktop);
  ldwh = 3*nshfts-3;
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (8th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (8th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_DFLOAT)
    rblapack_h = na_change_type(rblapack_h, NA_DFLOAT);
  h = NA_PTR_TYPE(rblapack_h, doublereal*);
  ldz = n;
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (11th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (11th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_z) != (wantz ? ldz : 0))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantz ? ldz : 0);
  if (NA_SHAPE1(rblapack_z) != (wantz ? ihiz : 0))
    rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantz ? ihiz : 0);
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nshfts;
    rblapack_sr_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  sr_out__ = NA_PTR_TYPE(rblapack_sr_out__, doublereal*);
  MEMCPY(sr_out__, sr, doublereal, NA_TOTAL(rblapack_sr));
  rblapack_sr = rblapack_sr_out__;
  sr = sr_out__;
  {
    na_shape_t shape[1];
    shape[0] = nshfts;
    rblapack_si_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  si_out__ = NA_PTR_TYPE(rblapack_si_out__, doublereal*);
  MEMCPY(si_out__, si, doublereal, NA_TOTAL(rblapack_si));
  rblapack_si = rblapack_si_out__;
  si = si_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublereal*);
  MEMCPY(h_out__, h, doublereal, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = wantz ? ldz : 0;
    shape[1] = wantz ? ihiz : 0;
    rblapack_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
  MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  v = ALLOC_N(doublereal, (ldv)*(nshfts/2));
  u = ALLOC_N(doublereal, (ldu)*(3*nshfts-3));
  wv = ALLOC_N(doublereal, (ldwv)*(3*nshfts-3));
  wh = ALLOC_N(doublereal, (ldwh)*(MAX(1,nh)));

  dlaqr5_(&wantt, &wantz, &kacc22, &n, &ktop, &kbot, &nshfts, sr, si, h, &ldh, &iloz, &ihiz, z, &ldz, v, &ldv, u, &ldu, &nv, wv, &ldwv, &nh, wh, &ldwh);

  free(v);
  free(u);
  free(wv);
  free(wh);
  return rb_ary_new3(4, rblapack_sr, rblapack_si, rblapack_h, rblapack_z);
}

void
init_lapack_dlaqr5(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaqr5", rblapack_dlaqr5, -1);
}
ruby-lapack-1.7.2/ext/dorml2.c0000644000175000017500000001416212502221014015723 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dorml2_(char* side, char* trans, integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* c, integer* ldc, doublereal* work, integer* info);


static VALUE
rblapack_dorml2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublereal *c_out__;
  doublereal *work;

  integer lda;
  integer m;
  integer k;
  integer ldc;
  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  info, c = NumRu::Lapack.dorml2( side, trans, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DORML2 overwrites the general real m by n matrix C with\n*\n*        Q * C  if SIDE = 'L' and TRANS = 'N', or\n*\n*        Q'* C  if SIDE = 'L' and TRANS = 'T', or\n*\n*        C * Q  if SIDE = 'R' and TRANS = 'N', or\n*\n*        C * Q' if SIDE = 'R' and TRANS = 'T',\n*\n*  where Q is a real orthogonal matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(k) . . . H(2) H(1)\n*\n*  as returned by DGELQF. Q is of order m if SIDE = 'L' and of order n\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q' from the Left\n*          = 'R': apply Q or Q' from the Right\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': apply Q  (No transpose)\n*          = 'T': apply Q' (Transpose)\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension\n*                               (LDA,M) if SIDE = 'L',\n*                               (LDA,N) if SIDE = 'R'\n*          The i-th row must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          DGELQF in the first k rows of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,K).\n*\n*  TAU     (input) DOUBLE PRECISION array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by DGELQF.\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n*          On entry, the m by n matrix C.\n*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension\n*                                   (N) if SIDE = 'L',\n*                                   (M) if SIDE = 'R'\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, c = NumRu::Lapack.dorml2( side, trans, a, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_a = argv[2];
  rblapack_tau = argv[3];
  rblapack_c = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = 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*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  dorml2_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_c);
}

void
init_lapack_dorml2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dorml2", rblapack_dorml2, -1);
}
ruby-lapack-1.7.2/ext/sladiv.c0000644000175000017500000000505112502221016016005 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sladiv_(real* a, real* b, real* c, real* d, real* p, real* q);


static VALUE
rblapack_sladiv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  real a; 
  VALUE rblapack_b;
  real b; 
  VALUE rblapack_c;
  real c; 
  VALUE rblapack_d;
  real d; 
  VALUE rblapack_p;
  real p; 
  VALUE rblapack_q;
  real q; 


  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  p, q = NumRu::Lapack.sladiv( a, b, c, d, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLADIV( A, B, C, D, P, Q )\n\n*  Purpose\n*  =======\n*\n*  SLADIV performs complex division in  real arithmetic\n*\n*                        a + i*b\n*             p + i*q = ---------\n*                        c + i*d\n*\n*  The algorithm is due to Robert L. Smith and can be found\n*  in D. Knuth, The art of Computer Programming, Vol.2, p.195\n*\n\n*  Arguments\n*  =========\n*\n*  A       (input) REAL\n*  B       (input) REAL\n*  C       (input) REAL\n*  D       (input) REAL\n*          The scalars a, b, c, and d in the above expression.\n*\n*  P       (output) REAL\n*  Q       (output) REAL\n*          The scalars p and q in the above expression.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      REAL               E, F\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  p, q = NumRu::Lapack.sladiv( a, b, c, d, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  rblapack_c = argv[2];
  rblapack_d = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  a = (real)NUM2DBL(rblapack_a);
  c = (real)NUM2DBL(rblapack_c);
  b = (real)NUM2DBL(rblapack_b);
  d = (real)NUM2DBL(rblapack_d);

  sladiv_(&a, &b, &c, &d, &p, &q);

  rblapack_p = rb_float_new((double)p);
  rblapack_q = rb_float_new((double)q);
  return rb_ary_new3(2, rblapack_p, rblapack_q);
}

void
init_lapack_sladiv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sladiv", rblapack_sladiv, -1);
}
ruby-lapack-1.7.2/ext/zhptrd.c0000644000175000017500000001401112502221023016030 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhptrd_(char* uplo, integer* n, doublecomplex* ap, doublereal* d, doublereal* e, doublecomplex* tau, integer* info);


static VALUE
rblapack_zhptrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublecomplex *ap_out__;

  integer ldap;
  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  d, e, tau, info, ap = NumRu::Lapack.zhptrd( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHPTRD( UPLO, N, AP, D, E, TAU, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHPTRD reduces a complex Hermitian matrix A stored in packed form to\n*  real symmetric tridiagonal form T by a unitary similarity\n*  transformation: Q**H * A * Q = T.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*          On exit, if UPLO = 'U', the diagonal and first superdiagonal\n*          of A are overwritten by the corresponding elements of the\n*          tridiagonal matrix T, and the elements above the first\n*          superdiagonal, with the array TAU, represent the unitary\n*          matrix Q as a product of elementary reflectors; if UPLO\n*          = 'L', the diagonal and first subdiagonal of A are over-\n*          written by the corresponding elements of the tridiagonal\n*          matrix T, and the elements below the first subdiagonal, with\n*          the array TAU, represent the unitary matrix Q as a product\n*          of elementary reflectors. See Further Details.\n*\n*  D       (output) DOUBLE PRECISION array, dimension (N)\n*          The diagonal elements of the tridiagonal matrix T:\n*          D(i) = A(i,i).\n*\n*  E       (output) DOUBLE PRECISION array, dimension (N-1)\n*          The off-diagonal elements of the tridiagonal matrix T:\n*          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n*  TAU     (output) COMPLEX*16 array, dimension (N-1)\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\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*  If UPLO = 'U', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(n-1) . . . H(2) H(1).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - tau * v * v'\n*\n*  where tau is a complex scalar, and v is a complex vector with\n*  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,\n*  overwriting A(1:i-1,i+1), and tau is stored in TAU(i).\n*\n*  If UPLO = 'L', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(1) H(2) . . . H(n-1).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - tau * v * v'\n*\n*  where tau is a complex scalar, and v is a complex vector with\n*  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,\n*  overwriting A(i+2:n,i), and tau is stored in TAU(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, tau, info, ap = NumRu::Lapack.zhptrd( uplo, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
  MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  zhptrd_(&uplo, &n, ap, d, e, tau, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_d, rblapack_e, rblapack_tau, rblapack_info, rblapack_ap);
}

void
init_lapack_zhptrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhptrd", rblapack_zhptrd, -1);
}
ruby-lapack-1.7.2/ext/zungqr.c0000644000175000017500000001262612502221025016057 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zungqr_(integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zungqr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;

  integer lda;
  integer n;
  integer k;

  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 = NumRu::Lapack.zungqr( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZUNGQR generates an M-by-N complex matrix Q with orthonormal columns,\n*  which is defined as the first N columns of a product of K elementary\n*  reflectors of order M\n*\n*        Q  =  H(1) H(2) . . . H(k)\n*\n*  as returned by ZGEQRF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. M >= N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. N >= K >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the i-th column must contain the vector which\n*          defines the elementary reflector H(i), for i = 1,2,...,k, as\n*          returned by ZGEQRF in the first k columns of its array\n*          argument A.\n*          On exit, the M-by-N matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) COMPLEX*16 array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by ZGEQRF.\n*\n*  WORK    (workspace/output) COMPLEX*16 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,N).\n*          For optimum performance LWORK >= N*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 has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, a = NumRu::Lapack.zungqr( m, a, tau, [: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_m = argv[0];
  rblapack_a = argv[1];
  rblapack_tau = 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;
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zungqr_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_zungqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zungqr", rblapack_zungqr, -1);
}
ruby-lapack-1.7.2/ext/ztrrfs.c0000644000175000017500000001700012502221021016046 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztrrfs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_ztrrfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  doublecomplex *work;
  doublereal *rwork;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info = NumRu::Lapack.ztrrfs( uplo, trans, diag, a, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTRRFS provides error bounds and backward error estimates for the\n*  solution to a system of linear equations with a triangular\n*  coefficient matrix.\n*\n*  The solution matrix X must be computed by ZTRTRS or some other\n*  means before entering this routine.  ZTRRFS does not do iterative\n*  refinement because doing so cannot improve the backward error.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          The triangular matrix A.  If UPLO = 'U', the leading N-by-N\n*          upper triangular part of the array A contains the upper\n*          triangular matrix, and the strictly lower triangular part of\n*          A is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*          triangular part of the array A contains the lower triangular\n*          matrix, and the strictly upper triangular part of A is not\n*          referenced.  If DIAG = 'U', the diagonal elements of A are\n*          also not referenced and are assumed to be 1.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input) COMPLEX*16 array, dimension (LDX,NRHS)\n*          The solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info = NumRu::Lapack.ztrrfs( uplo, trans, diag, a, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (n));

  ztrrfs_(&uplo, &trans, &diag, &n, &nrhs, a, &lda, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ferr, rblapack_berr, rblapack_info);
}

void
init_lapack_ztrrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztrrfs", rblapack_ztrrfs, -1);
}
ruby-lapack-1.7.2/ext/clarfg.c0000644000175000017500000001030112502221020015746 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clarfg_(integer* n, complex* alpha, complex* x, integer* incx, complex* tau);


static VALUE
rblapack_clarfg(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_alpha;
  complex alpha; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_tau;
  complex tau; 
  VALUE rblapack_x_out__;
  complex *x_out__;


  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, alpha, x = NumRu::Lapack.clarfg( n, alpha, x, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLARFG( N, ALPHA, X, INCX, TAU )\n\n*  Purpose\n*  =======\n*\n*  CLARFG generates a complex elementary reflector H of order n, such\n*  that\n*\n*        H' * ( alpha ) = ( beta ),   H' * H = I.\n*             (   x   )   (   0  )\n*\n*  where alpha and beta are scalars, with beta real, and x is an\n*  (n-1)-element complex vector. H is represented in the form\n*\n*        H = I - tau * ( 1 ) * ( 1 v' ) ,\n*                      ( v )\n*\n*  where tau is a complex scalar and v is a complex (n-1)-element\n*  vector. Note that H is not hermitian.\n*\n*  If the elements of x are all zero and alpha is real, then tau = 0\n*  and H is taken to be the unit matrix.\n*\n*  Otherwise  1 <= real(tau) <= 2  and  abs(tau-1) <= 1 .\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the elementary reflector.\n*\n*  ALPHA   (input/output) COMPLEX\n*          On entry, the value alpha.\n*          On exit, it is overwritten with the value beta.\n*\n*  X       (input/output) COMPLEX array, dimension\n*                         (1+(N-2)*abs(INCX))\n*          On entry, the vector x.\n*          On exit, it is overwritten with the vector v.\n*\n*  INCX    (input) INTEGER\n*          The increment between elements of X. INCX > 0.\n*\n*  TAU     (output) COMPLEX\n*          The value tau.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, alpha, x = NumRu::Lapack.clarfg( n, alpha, x, incx, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_n = argv[0];
  rblapack_alpha = argv[1];
  rblapack_x = argv[2];
  rblapack_incx = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  incx = NUM2INT(rblapack_incx);
  alpha.r = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
  alpha.i = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (3th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1+(n-2)*abs(incx)))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-2)*abs(incx));
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-2)*abs(incx);
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;

  clarfg_(&n, &alpha, x, &incx, &tau);

  rblapack_tau = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(tau.r)), rb_float_new((double)(tau.i)));
  rblapack_alpha = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(alpha.r)), rb_float_new((double)(alpha.i)));
  return rb_ary_new3(3, rblapack_tau, rblapack_alpha, rblapack_x);
}

void
init_lapack_clarfg(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clarfg", rblapack_clarfg, -1);
}
ruby-lapack-1.7.2/ext/clange.c0000644000175000017500000000750212502221017015760 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real clange_(char* norm, integer* m, integer* n, complex* a, integer* lda, real* work);


static VALUE
rblapack_clange(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack___out__;
  real __out__; 
  real *work;

  integer lda;
  integer n;
  integer lwork;

  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  __out__ = NumRu::Lapack.clange( norm, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL             FUNCTION CLANGE( NORM, M, N, A, LDA, WORK )\n\n*  Purpose\n*  =======\n*\n*  CLANGE  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  complex matrix A.\n*\n*  Description\n*  ===========\n*\n*  CLANGE returns the value\n*\n*     CLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in CLANGE as described\n*          above.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.  M >= 0.  When M = 0,\n*          CLANGE is set to zero.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.  N >= 0.  When N = 0,\n*          CLANGE is set to zero.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The m by n matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(M,1).\n*\n*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),\n*          where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n*          referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.clange( norm, m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_norm = argv[0];
  rblapack_m = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  m = NUM2INT(rblapack_m);
  lwork = lsame_(&norm,"I") ? m : 0;
  work = ALLOC_N(real, (MAX(1,lwork)));

  __out__ = clange_(&norm, &m, &n, a, &lda, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_clange(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clange", rblapack_clange, -1);
}
ruby-lapack-1.7.2/ext/chptrf.c0000644000175000017500000001473512502221015016021 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chptrf_(char* uplo, integer* n, complex* ap, integer* ipiv, integer* info);


static VALUE
rblapack_chptrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  complex *ap_out__;

  integer ldap;
  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  ipiv, info, ap = NumRu::Lapack.chptrf( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHPTRF( UPLO, N, AP, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHPTRF computes the factorization of a complex Hermitian packed\n*  matrix A using the Bunch-Kaufman diagonal pivoting method:\n*\n*     A = U*D*U**H  or  A = L*D*L**H\n*\n*  where U (or L) is a product of permutation and unit upper (lower)\n*  triangular matrices, and D is Hermitian and block diagonal with\n*  1-by-1 and 2-by-2 diagonal blocks.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L, stored as a packed triangular\n*          matrix overwriting A (see below for further details).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D.\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\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, D(i,i) is exactly zero.  The factorization\n*               has been completed, but the block diagonal matrix D is\n*               exactly singular, and division by zero will occur if it\n*               is used to solve a system of equations.\n*\n\n*  Further Details\n*  ===============\n*\n*  5-96 - Based on modifications by J. Lewis, Boeing Computer Services\n*         Company\n*\n*  If UPLO = 'U', then A = U*D*U', where\n*     U = P(n)*U(n)* ... *P(k)U(k)* ...,\n*  i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n*  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    v    0   )   k-s\n*     U(k) =  (   0    I    0   )   s\n*             (   0    0    I   )   n-k\n*                k-s   s   n-k\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n*  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n*  and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n*  If UPLO = 'L', then A = L*D*L', where\n*     L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n*  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n*  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    0     0   )  k-1\n*     L(k) =  (   0    I     0   )  s\n*             (   0    v     I   )  n-k-s+1\n*                k-1   s  n-k-s+1\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n*  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n*  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, ap = NumRu::Lapack.chptrf( uplo, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
  MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  chptrf_(&uplo, &n, ap, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_ap);
}

void
init_lapack_chptrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chptrf", rblapack_chptrf, -1);
}
ruby-lapack-1.7.2/ext/dlarrj.c0000644000175000017500000001762412502221023016010 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlarrj_(integer* n, doublereal* d, doublereal* e2, integer* ifirst, integer* ilast, doublereal* rtol, integer* offset, doublereal* w, doublereal* werr, doublereal* work, integer* iwork, doublereal* pivmin, doublereal* spdiam, integer* info);


static VALUE
rblapack_dlarrj(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e2;
  doublereal *e2; 
  VALUE rblapack_ifirst;
  integer ifirst; 
  VALUE rblapack_ilast;
  integer ilast; 
  VALUE rblapack_rtol;
  doublereal rtol; 
  VALUE rblapack_offset;
  integer offset; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_werr;
  doublereal *werr; 
  VALUE rblapack_pivmin;
  doublereal pivmin; 
  VALUE rblapack_spdiam;
  doublereal spdiam; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_w_out__;
  doublereal *w_out__;
  VALUE rblapack_werr_out__;
  doublereal *werr_out__;
  doublereal *work;
  integer *iwork;

  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  info, w, werr = NumRu::Lapack.dlarrj( d, e2, ifirst, ilast, rtol, offset, w, werr, pivmin, spdiam, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLARRJ( N, D, E2, IFIRST, ILAST, RTOL, OFFSET, W, WERR, WORK, IWORK, PIVMIN, SPDIAM, INFO )\n\n*  Purpose\n*  =======\n*\n*  Given the initial eigenvalue approximations of T, DLARRJ\n*  does  bisection to refine the eigenvalues of T,\n*  W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial\n*  guesses for these eigenvalues are input in W, the corresponding estimate\n*  of the error in these guesses in WERR. During bisection, intervals\n*  [left, right] are maintained by storing their mid-points and\n*  semi-widths in the arrays W and WERR respectively.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          The N diagonal elements of T.\n*\n*  E2      (input) DOUBLE PRECISION array, dimension (N-1)\n*          The Squares of the (N-1) subdiagonal elements of T.\n*\n*  IFIRST  (input) INTEGER\n*          The index of the first eigenvalue to be computed.\n*\n*  ILAST   (input) INTEGER\n*          The index of the last eigenvalue to be computed.\n*\n*  RTOL    (input) DOUBLE PRECISION\n*          Tolerance for the convergence of the bisection intervals.\n*          An interval [LEFT,RIGHT] has converged if\n*          RIGHT-LEFT.LT.RTOL*MAX(|LEFT|,|RIGHT|).\n*\n*  OFFSET  (input) INTEGER\n*          Offset for the arrays W and WERR, i.e., the IFIRST-OFFSET\n*          through ILAST-OFFSET elements of these arrays are to be used.\n*\n*  W       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are\n*          estimates of the eigenvalues of L D L^T indexed IFIRST through\n*          ILAST.\n*          On output, these estimates are refined.\n*\n*  WERR    (input/output) DOUBLE PRECISION array, dimension (N)\n*          On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are\n*          the errors in the estimates of the corresponding elements in W.\n*          On output, these errors are refined.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N)\n*          Workspace.\n*\n*  IWORK   (workspace) INTEGER array, dimension (2*N)\n*          Workspace.\n*\n*  PIVMIN  (input) DOUBLE PRECISION\n*          The minimum pivot in the Sturm sequence for T.\n*\n*  SPDIAM  (input) DOUBLE PRECISION\n*          The spectral diameter of T.\n*\n*  INFO    (output) INTEGER\n*          Error flag.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Beresford Parlett, University of California, Berkeley, USA\n*     Jim Demmel, University of California, Berkeley, USA\n*     Inderjit Dhillon, University of Texas, Austin, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, w, werr = NumRu::Lapack.dlarrj( d, e2, ifirst, ilast, rtol, offset, w, werr, pivmin, spdiam, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_d = argv[0];
  rblapack_e2 = argv[1];
  rblapack_ifirst = argv[2];
  rblapack_ilast = argv[3];
  rblapack_rtol = argv[4];
  rblapack_offset = argv[5];
  rblapack_w = argv[6];
  rblapack_werr = argv[7];
  rblapack_pivmin = argv[8];
  rblapack_spdiam = argv[9];
  if (argc == 10) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  ifirst = NUM2INT(rblapack_ifirst);
  rtol = NUM2DBL(rblapack_rtol);
  if (!NA_IsNArray(rblapack_w))
    rb_raise(rb_eArgError, "w (7th argument) must be NArray");
  if (NA_RANK(rblapack_w) != 1)
    rb_raise(rb_eArgError, "rank of w (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_w) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_w) != NA_DFLOAT)
    rblapack_w = na_change_type(rblapack_w, NA_DFLOAT);
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  pivmin = NUM2DBL(rblapack_pivmin);
  ilast = NUM2INT(rblapack_ilast);
  if (!NA_IsNArray(rblapack_werr))
    rb_raise(rb_eArgError, "werr (8th argument) must be NArray");
  if (NA_RANK(rblapack_werr) != 1)
    rb_raise(rb_eArgError, "rank of werr (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_werr) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of werr must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_werr) != NA_DFLOAT)
    rblapack_werr = na_change_type(rblapack_werr, NA_DFLOAT);
  werr = NA_PTR_TYPE(rblapack_werr, doublereal*);
  if (!NA_IsNArray(rblapack_e2))
    rb_raise(rb_eArgError, "e2 (2th argument) must be NArray");
  if (NA_RANK(rblapack_e2) != 1)
    rb_raise(rb_eArgError, "rank of e2 (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e2) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e2 must be %d", n-1);
  if (NA_TYPE(rblapack_e2) != NA_DFLOAT)
    rblapack_e2 = na_change_type(rblapack_e2, NA_DFLOAT);
  e2 = NA_PTR_TYPE(rblapack_e2, doublereal*);
  spdiam = NUM2DBL(rblapack_spdiam);
  offset = NUM2INT(rblapack_offset);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w_out__ = NA_PTR_TYPE(rblapack_w_out__, doublereal*);
  MEMCPY(w_out__, w, doublereal, NA_TOTAL(rblapack_w));
  rblapack_w = rblapack_w_out__;
  w = w_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_werr_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  werr_out__ = NA_PTR_TYPE(rblapack_werr_out__, doublereal*);
  MEMCPY(werr_out__, werr, doublereal, NA_TOTAL(rblapack_werr));
  rblapack_werr = rblapack_werr_out__;
  werr = werr_out__;
  work = ALLOC_N(doublereal, (2*n));
  iwork = ALLOC_N(integer, (2*n));

  dlarrj_(&n, d, e2, &ifirst, &ilast, &rtol, &offset, w, werr, work, iwork, &pivmin, &spdiam, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_w, rblapack_werr);
}

void
init_lapack_dlarrj(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlarrj", rblapack_dlarrj, -1);
}
ruby-lapack-1.7.2/ext/ssptrd.c0000644000175000017500000001353612502221016016051 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssptrd_(char* uplo, integer* n, real* ap, real* d, real* e, real* tau, integer* info);


static VALUE
rblapack_ssptrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  real *ap_out__;

  integer ldap;
  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  d, e, tau, info, ap = NumRu::Lapack.ssptrd( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSPTRD( UPLO, N, AP, D, E, TAU, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSPTRD reduces a real symmetric matrix A stored in packed form to\n*  symmetric tridiagonal form T by an orthogonal similarity\n*  transformation: Q**T * A * Q = T.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) REAL array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*          On exit, if UPLO = 'U', the diagonal and first superdiagonal\n*          of A are overwritten by the corresponding elements of the\n*          tridiagonal matrix T, and the elements above the first\n*          superdiagonal, with the array TAU, represent the orthogonal\n*          matrix Q as a product of elementary reflectors; if UPLO\n*          = 'L', the diagonal and first subdiagonal of A are over-\n*          written by the corresponding elements of the tridiagonal\n*          matrix T, and the elements below the first subdiagonal, with\n*          the array TAU, represent the orthogonal matrix Q as a product\n*          of elementary reflectors. See Further Details.\n*\n*  D       (output) REAL array, dimension (N)\n*          The diagonal elements of the tridiagonal matrix T:\n*          D(i) = A(i,i).\n*\n*  E       (output) REAL array, dimension (N-1)\n*          The off-diagonal elements of the tridiagonal matrix T:\n*          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n*  TAU     (output) REAL array, dimension (N-1)\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\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*  If UPLO = 'U', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(n-1) . . . H(2) H(1).\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(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,\n*  overwriting A(1:i-1,i+1), and tau is stored in TAU(i).\n*\n*  If UPLO = 'L', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(1) H(2) . . . H(n-1).\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) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,\n*  overwriting A(i+2:n,i), and tau is stored in TAU(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, tau, info, ap = NumRu::Lapack.ssptrd( uplo, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, real*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, real*);
  MEMCPY(ap_out__, ap, real, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  ssptrd_(&uplo, &n, ap, d, e, tau, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_d, rblapack_e, rblapack_tau, rblapack_info, rblapack_ap);
}

void
init_lapack_ssptrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssptrd", rblapack_ssptrd, -1);
}
ruby-lapack-1.7.2/ext/dlange.c0000644000175000017500000000756712502221022015770 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal dlange_(char* norm, integer* m, integer* n, doublereal* a, integer* lda, doublereal* work);


static VALUE
rblapack_dlange(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack___out__;
  doublereal __out__; 
  doublereal *work;

  integer lda;
  integer n;
  integer lwork;

  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  __out__ = NumRu::Lapack.dlange( norm, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK )\n\n*  Purpose\n*  =======\n*\n*  DLANGE  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  real matrix A.\n*\n*  Description\n*  ===========\n*\n*  DLANGE returns the value\n*\n*     DLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in DLANGE as described\n*          above.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.  M >= 0.  When M = 0,\n*          DLANGE is set to zero.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.  N >= 0.  When N = 0,\n*          DLANGE is set to zero.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*          The m by n matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(M,1).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n*          where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n*          referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.dlange( norm, m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_norm = argv[0];
  rblapack_m = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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);
  lwork = lsame_(&norm,"I") ? m : 0;
  work = ALLOC_N(doublereal, (MAX(1,lwork)));

  __out__ = dlange_(&norm, &m, &n, a, &lda, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_dlange(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlange", rblapack_dlange, -1);
}
ruby-lapack-1.7.2/ext/ztrevc.c0000644000175000017500000002434612502221020016043 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztrevc_(char* side, char* howmny, logical* select, integer* n, doublecomplex* t, integer* ldt, doublecomplex* vl, integer* ldvl, doublecomplex* vr, integer* ldvr, integer* mm, integer* m, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_ztrevc(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_howmny;
  char howmny; 
  VALUE rblapack_select;
  logical *select; 
  VALUE rblapack_t;
  doublecomplex *t; 
  VALUE rblapack_vl;
  doublecomplex *vl; 
  VALUE rblapack_vr;
  doublecomplex *vr; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_t_out__;
  doublecomplex *t_out__;
  VALUE rblapack_vl_out__;
  doublecomplex *vl_out__;
  VALUE rblapack_vr_out__;
  doublecomplex *vr_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer n;
  integer ldt;
  integer ldvl;
  integer mm;
  integer ldvr;

  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  m, info, t, vl, vr = NumRu::Lapack.ztrevc( side, howmny, select, t, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTREVC computes some or all of the right and/or left eigenvectors of\n*  a complex upper triangular matrix T.\n*  Matrices of this type are produced by the Schur factorization of\n*  a complex general matrix:  A = Q*T*Q**H, as computed by ZHSEQR.\n*  \n*  The right eigenvector x and the left eigenvector y of T corresponding\n*  to an eigenvalue w are defined by:\n*  \n*               T*x = w*x,     (y**H)*T = w*(y**H)\n*  \n*  where y**H denotes the conjugate transpose of the vector y.\n*  The eigenvalues are not input to this routine, but are read directly\n*  from the diagonal of T.\n*  \n*  This routine returns the matrices X and/or Y of right and left\n*  eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an\n*  input matrix.  If Q is the unitary factor that reduces a matrix A to\n*  Schur form T, then Q*X and Q*Y are the matrices of right and left\n*  eigenvectors of A.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'R':  compute right eigenvectors only;\n*          = 'L':  compute left eigenvectors only;\n*          = 'B':  compute both right and left eigenvectors.\n*\n*  HOWMNY  (input) CHARACTER*1\n*          = 'A':  compute all right and/or left eigenvectors;\n*          = 'B':  compute all right and/or left eigenvectors,\n*                  backtransformed using the matrices supplied in\n*                  VR and/or VL;\n*          = 'S':  compute selected right and/or left eigenvectors,\n*                  as indicated by the logical array SELECT.\n*\n*  SELECT  (input) LOGICAL array, dimension (N)\n*          If HOWMNY = 'S', SELECT specifies the eigenvectors to be\n*          computed.\n*          The eigenvector corresponding to the j-th eigenvalue is\n*          computed if SELECT(j) = .TRUE..\n*          Not referenced if HOWMNY = 'A' or 'B'.\n*\n*  N       (input) INTEGER\n*          The order of the matrix T. N >= 0.\n*\n*  T       (input/output) COMPLEX*16 array, dimension (LDT,N)\n*          The upper triangular matrix T.  T is modified, but restored\n*          on exit.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= max(1,N).\n*\n*  VL      (input/output) COMPLEX*16 array, dimension (LDVL,MM)\n*          On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n*          contain an N-by-N matrix Q (usually the unitary matrix Q of\n*          Schur vectors returned by ZHSEQR).\n*          On exit, if SIDE = 'L' or 'B', VL contains:\n*          if HOWMNY = 'A', the matrix Y of left eigenvectors of T;\n*          if HOWMNY = 'B', the matrix Q*Y;\n*          if HOWMNY = 'S', the left eigenvectors of T specified by\n*                           SELECT, stored consecutively in the columns\n*                           of VL, in the same order as their\n*                           eigenvalues.\n*          Not referenced if SIDE = 'R'.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the array VL.  LDVL >= 1, and if\n*          SIDE = 'L' or 'B', LDVL >= N.\n*\n*  VR      (input/output) COMPLEX*16 array, dimension (LDVR,MM)\n*          On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n*          contain an N-by-N matrix Q (usually the unitary matrix Q of\n*          Schur vectors returned by ZHSEQR).\n*          On exit, if SIDE = 'R' or 'B', VR contains:\n*          if HOWMNY = 'A', the matrix X of right eigenvectors of T;\n*          if HOWMNY = 'B', the matrix Q*X;\n*          if HOWMNY = 'S', the right eigenvectors of T specified by\n*                           SELECT, stored consecutively in the columns\n*                           of VR, in the same order as their\n*                           eigenvalues.\n*          Not referenced if SIDE = 'L'.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the array VR.  LDVR >= 1, and if\n*          SIDE = 'R' or 'B'; LDVR >= N.\n*\n*  MM      (input) INTEGER\n*          The number of columns in the arrays VL and/or VR. MM >= M.\n*\n*  M       (output) INTEGER\n*          The number of columns in the arrays VL and/or VR actually\n*          used to store the eigenvectors.  If HOWMNY = 'A' or 'B', M\n*          is set to N.  Each selected eigenvector occupies one\n*          column.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\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 algorithm used in this program is basically backward (forward)\n*  substitution, with scaling to make the the code robust against\n*  possible overflow.\n*\n*  Each eigenvector is normalized so that the element of largest\n*  magnitude has magnitude 1; here the magnitude of a complex number\n*  (x,y) is taken to be |x| + |y|.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, info, t, vl, vr = NumRu::Lapack.ztrevc( side, howmny, select, t, vl, vr, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_howmny = argv[1];
  rblapack_select = argv[2];
  rblapack_t = argv[3];
  rblapack_vl = argv[4];
  rblapack_vr = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_select))
    rb_raise(rb_eArgError, "select (3th argument) must be NArray");
  if (NA_RANK(rblapack_select) != 1)
    rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_select);
  if (NA_TYPE(rblapack_select) != NA_LINT)
    rblapack_select = na_change_type(rblapack_select, NA_LINT);
  select = NA_PTR_TYPE(rblapack_select, logical*);
  if (!NA_IsNArray(rblapack_vl))
    rb_raise(rb_eArgError, "vl (5th argument) must be NArray");
  if (NA_RANK(rblapack_vl) != 2)
    rb_raise(rb_eArgError, "rank of vl (5th argument) must be %d", 2);
  ldvl = NA_SHAPE0(rblapack_vl);
  mm = NA_SHAPE1(rblapack_vl);
  if (NA_TYPE(rblapack_vl) != NA_DCOMPLEX)
    rblapack_vl = na_change_type(rblapack_vl, NA_DCOMPLEX);
  vl = NA_PTR_TYPE(rblapack_vl, doublecomplex*);
  howmny = StringValueCStr(rblapack_howmny)[0];
  if (!NA_IsNArray(rblapack_vr))
    rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
  if (NA_RANK(rblapack_vr) != 2)
    rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 2);
  ldvr = NA_SHAPE0(rblapack_vr);
  if (NA_SHAPE1(rblapack_vr) != mm)
    rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
  if (NA_TYPE(rblapack_vr) != NA_DCOMPLEX)
    rblapack_vr = na_change_type(rblapack_vr, NA_DCOMPLEX);
  vr = NA_PTR_TYPE(rblapack_vr, doublecomplex*);
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (4th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  if (NA_SHAPE1(rblapack_t) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_t) != NA_DCOMPLEX)
    rblapack_t = na_change_type(rblapack_t, NA_DCOMPLEX);
  t = NA_PTR_TYPE(rblapack_t, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = n;
    rblapack_t_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  t_out__ = NA_PTR_TYPE(rblapack_t_out__, doublecomplex*);
  MEMCPY(t_out__, t, doublecomplex, NA_TOTAL(rblapack_t));
  rblapack_t = rblapack_t_out__;
  t = t_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = mm;
    rblapack_vl_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, doublecomplex*);
  MEMCPY(vl_out__, vl, doublecomplex, NA_TOTAL(rblapack_vl));
  rblapack_vl = rblapack_vl_out__;
  vl = vl_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = mm;
    rblapack_vr_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  vr_out__ = NA_PTR_TYPE(rblapack_vr_out__, doublecomplex*);
  MEMCPY(vr_out__, vr, doublecomplex, NA_TOTAL(rblapack_vr));
  rblapack_vr = rblapack_vr_out__;
  vr = vr_out__;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (n));

  ztrevc_(&side, &howmny, select, &n, t, &ldt, vl, &ldvl, vr, &ldvr, &mm, &m, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_m, rblapack_info, rblapack_t, rblapack_vl, rblapack_vr);
}

void
init_lapack_ztrevc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztrevc", rblapack_ztrevc, -1);
}
ruby-lapack-1.7.2/ext/cla_gerfsx_extended.c0000644000175000017500000005553012502221025020527 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cla_gerfsx_extended_(integer* prec_type, integer* trans_type, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, logical* colequ, real* c, complex* b, integer* ldb, complex* y, integer* ldy, real* berr_out, integer* n_norms, real* errs_n, real* errs_c, complex* res, real* ayb, complex* dy, complex* y_tail, real* rcond, integer* ithresh, real* rthresh, real* dz_ub, logical* ignore_cwise, integer* info);


static VALUE
rblapack_cla_gerfsx_extended(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_prec_type;
  integer prec_type; 
  VALUE rblapack_trans_type;
  integer trans_type; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_colequ;
  logical colequ; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_y;
  complex *y; 
  VALUE rblapack_errs_n;
  real *errs_n; 
  VALUE rblapack_errs_c;
  real *errs_c; 
  VALUE rblapack_res;
  complex *res; 
  VALUE rblapack_ayb;
  real *ayb; 
  VALUE rblapack_dy;
  complex *dy; 
  VALUE rblapack_y_tail;
  complex *y_tail; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_ithresh;
  integer ithresh; 
  VALUE rblapack_rthresh;
  real rthresh; 
  VALUE rblapack_dz_ub;
  real dz_ub; 
  VALUE rblapack_ignore_cwise;
  logical ignore_cwise; 
  VALUE rblapack_berr_out;
  real *berr_out; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_y_out__;
  complex *y_out__;
  VALUE rblapack_errs_n_out__;
  real *errs_n_out__;
  VALUE rblapack_errs_c_out__;
  real *errs_c_out__;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldy;
  integer n_norms;
  integer n_norsm;

  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  berr_out, info, y, errs_n, errs_c = NumRu::Lapack.cla_gerfsx_extended( prec_type, trans_type, a, af, ipiv, colequ, c, b, y, errs_n, errs_c, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERRS_N, ERRS_C, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n*  Purpose\n*  =======\n* \n*  CLA_GERFSX_EXTENDED improves the computed solution to a system of\n*  linear equations by performing extra-precise iterative refinement\n*  and provides error bounds and backward error estimates for the solution.\n*  This subroutine is called by CGERFSX to perform iterative refinement.\n*  In addition to normwise error bound, the code provides maximum\n*  componentwise error bound if possible. See comments for ERR_BNDS_NORM\n*  and ERR_BNDS_COMP for details of the error bounds. Note that this\n*  subroutine is only resonsible for setting the second fields of\n*  ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n*  Arguments\n*  =========\n*\n*     PREC_TYPE      (input) INTEGER\n*     Specifies the intermediate precision to be used in refinement.\n*     The value is defined by ILAPREC(P) where P is a CHARACTER and\n*     P    = 'S':  Single\n*          = 'D':  Double\n*          = 'I':  Indigenous\n*          = 'X', 'E':  Extra\n*\n*     TRANS_TYPE     (input) INTEGER\n*     Specifies the transposition operation on A.\n*     The value is defined by ILATRANS(T) where T is a CHARACTER and\n*     T    = 'N':  No transpose\n*          = 'T':  Transpose\n*          = 'C':  Conjugate transpose\n*\n*     N              (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NRHS           (input) INTEGER\n*     The number of right-hand-sides, i.e., the number of columns of the\n*     matrix B.\n*\n*     A              (input) COMPLEX array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA            (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF             (input) COMPLEX array, dimension (LDAF,N)\n*     The factors L and U from the factorization\n*     A = P*L*U as computed by CGETRF.\n*\n*     LDAF           (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV           (input) INTEGER array, dimension (N)\n*     The pivot indices from the factorization A = P*L*U\n*     as computed by CGETRF; row i of the matrix was interchanged\n*     with row IPIV(i).\n*\n*     COLEQU         (input) LOGICAL\n*     If .TRUE. then column equilibration was done to A before calling\n*     this routine. This is needed to compute the solution and error\n*     bounds correctly.\n*\n*     C              (input) REAL array, dimension (N)\n*     The column scale factors for A. If COLEQU = .FALSE., C\n*     is not accessed. If C is input, each element of C should be a power\n*     of the radix to ensure a reliable solution and error estimates.\n*     Scaling by powers of the radix does not cause rounding errors unless\n*     the result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B              (input) COMPLEX array, dimension (LDB,NRHS)\n*     The right-hand-side matrix B.\n*\n*     LDB            (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     Y              (input/output) COMPLEX array, dimension (LDY,NRHS)\n*     On entry, the solution matrix X, as computed by CGETRS.\n*     On exit, the improved solution matrix Y.\n*\n*     LDY            (input) INTEGER\n*     The leading dimension of the array Y.  LDY >= max(1,N).\n*\n*     BERR_OUT       (output) REAL array, dimension (NRHS)\n*     On exit, BERR_OUT(j) contains the componentwise relative backward\n*     error for right-hand-side j from the formula\n*         max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n*     where abs(Z) is the componentwise absolute value of the matrix\n*     or vector Z. This is computed by CLA_LIN_BERR.\n*\n*     N_NORMS        (input) INTEGER\n*     Determines which error bounds to return (see ERR_BNDS_NORM\n*     and ERR_BNDS_COMP).\n*     If N_NORMS >= 1 return normwise error bounds.\n*     If N_NORMS >= 2 return componentwise error bounds.\n*\n*     ERR_BNDS_NORM  (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     RES            (input) COMPLEX array, dimension (N)\n*     Workspace to hold the intermediate residual.\n*\n*     AYB            (input) REAL array, dimension (N)\n*     Workspace.\n*\n*     DY             (input) COMPLEX array, dimension (N)\n*     Workspace to hold the intermediate solution.\n*\n*     Y_TAIL         (input) COMPLEX array, dimension (N)\n*     Workspace to hold the trailing bits of the intermediate solution.\n*\n*     RCOND          (input) REAL\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     ITHRESH        (input) INTEGER\n*     The maximum number of residual computations allowed for\n*     refinement. The default is 10. For 'aggressive' set to 100 to\n*     permit convergence using approximate factorizations or\n*     factorizations other than LU. If the factorization uses a\n*     technique other than Gaussian elimination, the guarantees in\n*     ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n*     RTHRESH        (input) REAL\n*     Determines when to stop refinement if the error estimate stops\n*     decreasing. Refinement will stop when the next solution no longer\n*     satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n*     the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n*     default value is 0.5. For 'aggressive' set to 0.9 to permit\n*     convergence on extremely ill-conditioned matrices. See LAWN 165\n*     for more details.\n*\n*     DZ_UB          (input) REAL\n*     Determines when to start considering componentwise convergence.\n*     Componentwise convergence is only considered after each component\n*     of the solution Y is stable, which we definte as the relative\n*     change in each component being less than DZ_UB. The default value\n*     is 0.25, requiring the first bit to be stable. See LAWN 165 for\n*     more details.\n*\n*     IGNORE_CWISE   (input) LOGICAL\n*     If .TRUE. then ignore componentwise convergence. Default value\n*     is .FALSE..\n*\n*     INFO           (output) INTEGER\n*       = 0:  Successful exit.\n*       < 0:  if INFO = -i, the ith argument to CGETRS had an illegal\n*             value\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      CHARACTER          TRANS\n      INTEGER            CNT, I, J,  X_STATE, Z_STATE, Y_PREC_STATE\n      REAL               YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n     $                   DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n     $                   DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n     $                   EPS, HUGEVAL, INCR_THRESH\n      LOGICAL            INCR_PREC\n      COMPLEX            ZDUM\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  berr_out, info, y, errs_n, errs_c = NumRu::Lapack.cla_gerfsx_extended( prec_type, trans_type, a, af, ipiv, colequ, c, b, y, errs_n, errs_c, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 20 && argc != 20)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 20)", argc);
  rblapack_prec_type = argv[0];
  rblapack_trans_type = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_colequ = argv[5];
  rblapack_c = argv[6];
  rblapack_b = argv[7];
  rblapack_y = argv[8];
  rblapack_errs_n = argv[9];
  rblapack_errs_c = argv[10];
  rblapack_res = argv[11];
  rblapack_ayb = argv[12];
  rblapack_dy = argv[13];
  rblapack_y_tail = argv[14];
  rblapack_rcond = argv[15];
  rblapack_ithresh = argv[16];
  rblapack_rthresh = argv[17];
  rblapack_dz_ub = argv[18];
  rblapack_ignore_cwise = argv[19];
  if (argc == 20) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  prec_type = NUM2INT(rblapack_prec_type);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (9th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 2)
    rb_raise(rb_eArgError, "rank of y (9th argument) must be %d", 2);
  ldy = NA_SHAPE0(rblapack_y);
  nrhs = NA_SHAPE1(rblapack_y);
  if (NA_TYPE(rblapack_y) != NA_SCOMPLEX)
    rblapack_y = na_change_type(rblapack_y, NA_SCOMPLEX);
  y = NA_PTR_TYPE(rblapack_y, complex*);
  if (!NA_IsNArray(rblapack_errs_c))
    rb_raise(rb_eArgError, "errs_c (11th argument) must be NArray");
  if (NA_RANK(rblapack_errs_c) != 2)
    rb_raise(rb_eArgError, "rank of errs_c (11th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_errs_c) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of errs_c must be the same as shape 1 of y");
  n_norms = NA_SHAPE1(rblapack_errs_c);
  if (NA_TYPE(rblapack_errs_c) != NA_SFLOAT)
    rblapack_errs_c = na_change_type(rblapack_errs_c, NA_SFLOAT);
  errs_c = NA_PTR_TYPE(rblapack_errs_c, real*);
  if (!NA_IsNArray(rblapack_ayb))
    rb_raise(rb_eArgError, "ayb (13th argument) must be NArray");
  if (NA_RANK(rblapack_ayb) != 1)
    rb_raise(rb_eArgError, "rank of ayb (13th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ayb) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ayb) != NA_SFLOAT)
    rblapack_ayb = na_change_type(rblapack_ayb, NA_SFLOAT);
  ayb = NA_PTR_TYPE(rblapack_ayb, real*);
  if (!NA_IsNArray(rblapack_y_tail))
    rb_raise(rb_eArgError, "y_tail (15th argument) must be NArray");
  if (NA_RANK(rblapack_y_tail) != 1)
    rb_raise(rb_eArgError, "rank of y_tail (15th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y_tail) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_y_tail) != NA_SCOMPLEX)
    rblapack_y_tail = na_change_type(rblapack_y_tail, NA_SCOMPLEX);
  y_tail = NA_PTR_TYPE(rblapack_y_tail, complex*);
  ithresh = NUM2INT(rblapack_ithresh);
  dz_ub = (real)NUM2DBL(rblapack_dz_ub);
  n_norsm = 3;
  trans_type = NUM2INT(rblapack_trans_type);
  colequ = (rblapack_colequ == Qtrue);
  if (!NA_IsNArray(rblapack_errs_n))
    rb_raise(rb_eArgError, "errs_n (10th argument) must be NArray");
  if (NA_RANK(rblapack_errs_n) != 2)
    rb_raise(rb_eArgError, "rank of errs_n (10th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_errs_n) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of errs_n must be the same as shape 1 of y");
  if (NA_SHAPE1(rblapack_errs_n) != n_norms)
    rb_raise(rb_eRuntimeError, "shape 1 of errs_n must be the same as shape 1 of errs_c");
  if (NA_TYPE(rblapack_errs_n) != NA_SFLOAT)
    rblapack_errs_n = na_change_type(rblapack_errs_n, NA_SFLOAT);
  errs_n = NA_PTR_TYPE(rblapack_errs_n, real*);
  if (!NA_IsNArray(rblapack_dy))
    rb_raise(rb_eArgError, "dy (14th argument) must be NArray");
  if (NA_RANK(rblapack_dy) != 1)
    rb_raise(rb_eArgError, "rank of dy (14th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dy) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_dy) != NA_SCOMPLEX)
    rblapack_dy = na_change_type(rblapack_dy, NA_SCOMPLEX);
  dy = NA_PTR_TYPE(rblapack_dy, complex*);
  rthresh = (real)NUM2DBL(rblapack_rthresh);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  if (!NA_IsNArray(rblapack_res))
    rb_raise(rb_eArgError, "res (12th argument) must be NArray");
  if (NA_RANK(rblapack_res) != 1)
    rb_raise(rb_eArgError, "rank of res (12th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_res) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_res) != NA_SCOMPLEX)
    rblapack_res = na_change_type(rblapack_res, NA_SCOMPLEX);
  res = NA_PTR_TYPE(rblapack_res, complex*);
  ignore_cwise = (rblapack_ignore_cwise == Qtrue);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of y");
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  rcond = (real)NUM2DBL(rblapack_rcond);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr_out = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr_out = NA_PTR_TYPE(rblapack_berr_out, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldy;
    shape[1] = nrhs;
    rblapack_y_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, complex*);
  MEMCPY(y_out__, y, complex, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_norms;
    rblapack_errs_n_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  errs_n_out__ = NA_PTR_TYPE(rblapack_errs_n_out__, real*);
  MEMCPY(errs_n_out__, errs_n, real, NA_TOTAL(rblapack_errs_n));
  rblapack_errs_n = rblapack_errs_n_out__;
  errs_n = errs_n_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_norms;
    rblapack_errs_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  errs_c_out__ = NA_PTR_TYPE(rblapack_errs_c_out__, real*);
  MEMCPY(errs_c_out__, errs_c, real, NA_TOTAL(rblapack_errs_c));
  rblapack_errs_c = rblapack_errs_c_out__;
  errs_c = errs_c_out__;

  cla_gerfsx_extended_(&prec_type, &trans_type, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, errs_n, errs_c, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_errs_n, rblapack_errs_c);
}

void
init_lapack_cla_gerfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cla_gerfsx_extended", rblapack_cla_gerfsx_extended, -1);
}
ruby-lapack-1.7.2/ext/zlangb.c0000644000175000017500000001045012502221023015775 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal zlangb_(char* norm, integer* n, integer* kl, integer* ku, doublecomplex* ab, integer* ldab, doublereal* work);


static VALUE
rblapack_zlangb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack___out__;
  doublereal __out__; 
  doublereal *work;

  integer ldab;
  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  __out__ = NumRu::Lapack.zlangb( norm, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION ZLANGB( NORM, N, KL, KU, AB, LDAB, WORK )\n\n*  Purpose\n*  =======\n*\n*  ZLANGB  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the element of  largest absolute value  of an\n*  n by n band matrix  A,  with kl sub-diagonals and ku super-diagonals.\n*\n*  Description\n*  ===========\n*\n*  ZLANGB returns the value\n*\n*     ZLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in ZLANGB as described\n*          above.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, ZLANGB is\n*          set to zero.\n*\n*  KL      (input) INTEGER\n*          The number of sub-diagonals of the matrix A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of super-diagonals of the matrix A.  KU >= 0.\n*\n*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)\n*          The band matrix A, stored in rows 1 to KL+KU+1.  The j-th\n*          column of A is stored in the j-th column of the array AB as\n*          follows:\n*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n*          referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.zlangb( norm, kl, ku, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_norm = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  ku = NUM2INT(rblapack_ku);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  work = ALLOC_N(doublereal, (MAX(1,lsame_(&norm,"I") ? n : 0)));

  __out__ = zlangb_(&norm, &n, &kl, &ku, ab, &ldab, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_zlangb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlangb", rblapack_zlangb, -1);
}
ruby-lapack-1.7.2/ext/sormr2.c0000644000175000017500000001374712502221017015763 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sormr2_(char* side, char* trans, integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* c, integer* ldc, real* work, integer* info);


static VALUE
rblapack_sormr2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  real *c_out__;
  real *work;

  integer lda;
  integer m;
  integer k;
  integer ldc;
  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  info, c = NumRu::Lapack.sormr2( side, trans, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SORMR2 overwrites the general real m by n matrix C with\n*\n*        Q * C  if SIDE = 'L' and TRANS = 'N', or\n*\n*        Q'* C  if SIDE = 'L' and TRANS = 'T', or\n*\n*        C * Q  if SIDE = 'R' and TRANS = 'N', or\n*\n*        C * Q' if SIDE = 'R' and TRANS = 'T',\n*\n*  where Q is a real orthogonal matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(1) H(2) . . . H(k)\n*\n*  as returned by SGERQF. Q is of order m if SIDE = 'L' and of order n\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q' from the Left\n*          = 'R': apply Q or Q' from the Right\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': apply Q  (No transpose)\n*          = 'T': apply Q' (Transpose)\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) REAL array, dimension\n*                               (LDA,M) if SIDE = 'L',\n*                               (LDA,N) if SIDE = 'R'\n*          The i-th row must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          SGERQF in the last k rows of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,K).\n*\n*  TAU     (input) REAL array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by SGERQF.\n*\n*  C       (input/output) REAL array, dimension (LDC,N)\n*          On entry, the m by n matrix C.\n*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) REAL array, dimension\n*                                   (N) if SIDE = 'L',\n*                                   (M) if SIDE = 'R'\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, c = NumRu::Lapack.sormr2( side, trans, a, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_a = argv[2];
  rblapack_tau = argv[3];
  rblapack_c = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  sormr2_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_c);
}

void
init_lapack_sormr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sormr2", rblapack_sormr2, -1);
}
ruby-lapack-1.7.2/ext/cla_syrfsx_extended.c0000644000175000017500000005646012502221024020571 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cla_syrfsx_extended_(integer* prec_type, char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, logical* colequ, real* c, complex* b, integer* ldb, complex* y, integer* ldy, real* berr_out, integer* n_norms, real* err_bnds_norm, real* err_bnds_comp, complex* res, real* ayb, complex* dy, complex* y_tail, real* rcond, integer* ithresh, real* rthresh, real* dz_ub, logical* ignore_cwise, integer* info);


static VALUE
rblapack_cla_syrfsx_extended(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_prec_type;
  integer prec_type; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_colequ;
  logical colequ; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_y;
  complex *y; 
  VALUE rblapack_n_norms;
  integer n_norms; 
  VALUE rblapack_err_bnds_norm;
  real *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  real *err_bnds_comp; 
  VALUE rblapack_res;
  complex *res; 
  VALUE rblapack_ayb;
  real *ayb; 
  VALUE rblapack_dy;
  complex *dy; 
  VALUE rblapack_y_tail;
  complex *y_tail; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_ithresh;
  integer ithresh; 
  VALUE rblapack_rthresh;
  real rthresh; 
  VALUE rblapack_dz_ub;
  real dz_ub; 
  VALUE rblapack_ignore_cwise;
  logical ignore_cwise; 
  VALUE rblapack_berr_out;
  real *berr_out; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_y_out__;
  complex *y_out__;
  VALUE rblapack_err_bnds_norm_out__;
  real *err_bnds_norm_out__;
  VALUE rblapack_err_bnds_comp_out__;
  real *err_bnds_comp_out__;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldy;
  integer n_err_bnds;

  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  berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.cla_syrfsx_extended( prec_type, uplo, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n*  Purpose\n*  =======\n*\n*  CLA_SYRFSX_EXTENDED improves the computed solution to a system of\n*  linear equations by performing extra-precise iterative refinement\n*  and provides error bounds and backward error estimates for the solution.\n*  This subroutine is called by CSYRFSX to perform iterative refinement.\n*  In addition to normwise error bound, the code provides maximum\n*  componentwise error bound if possible. See comments for ERR_BNDS_NORM\n*  and ERR_BNDS_COMP for details of the error bounds. Note that this\n*  subroutine is only resonsible for setting the second fields of\n*  ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n*  Arguments\n*  =========\n*\n*     PREC_TYPE      (input) INTEGER\n*     Specifies the intermediate precision to be used in refinement.\n*     The value is defined by ILAPREC(P) where P is a CHARACTER and\n*     P    = 'S':  Single\n*          = 'D':  Double\n*          = 'I':  Indigenous\n*          = 'X', 'E':  Extra\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N              (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NRHS           (input) INTEGER\n*     The number of right-hand-sides, i.e., the number of columns of the\n*     matrix B.\n*\n*     A              (input) COMPLEX array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA            (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF             (input) COMPLEX array, dimension (LDAF,N)\n*     The block diagonal matrix D and the multipliers used to\n*     obtain the factor U or L as computed by CSYTRF.\n*\n*     LDAF           (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV           (input) INTEGER array, dimension (N)\n*     Details of the interchanges and the block structure of D\n*     as determined by CSYTRF.\n*\n*     COLEQU         (input) LOGICAL\n*     If .TRUE. then column equilibration was done to A before calling\n*     this routine. This is needed to compute the solution and error\n*     bounds correctly.\n*\n*     C              (input) REAL array, dimension (N)\n*     The column scale factors for A. If COLEQU = .FALSE., C\n*     is not accessed. If C is input, each element of C should be a power\n*     of the radix to ensure a reliable solution and error estimates.\n*     Scaling by powers of the radix does not cause rounding errors unless\n*     the result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B              (input) COMPLEX array, dimension (LDB,NRHS)\n*     The right-hand-side matrix B.\n*\n*     LDB            (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     Y              (input/output) COMPLEX array, dimension\n*                    (LDY,NRHS)\n*     On entry, the solution matrix X, as computed by CSYTRS.\n*     On exit, the improved solution matrix Y.\n*\n*     LDY            (input) INTEGER\n*     The leading dimension of the array Y.  LDY >= max(1,N).\n*\n*     BERR_OUT       (output) REAL array, dimension (NRHS)\n*     On exit, BERR_OUT(j) contains the componentwise relative backward\n*     error for right-hand-side j from the formula\n*         max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n*     where abs(Z) is the componentwise absolute value of the matrix\n*     or vector Z. This is computed by CLA_LIN_BERR.\n*\n*     N_NORMS        (input) INTEGER\n*     Determines which error bounds to return (see ERR_BNDS_NORM\n*     and ERR_BNDS_COMP).\n*     If N_NORMS >= 1 return normwise error bounds.\n*     If N_NORMS >= 2 return componentwise error bounds.\n*\n*     ERR_BNDS_NORM  (input/output) REAL array, dimension\n*                    (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (input/output) REAL array, dimension\n*                    (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     RES            (input) COMPLEX array, dimension (N)\n*     Workspace to hold the intermediate residual.\n*\n*     AYB            (input) REAL array, dimension (N)\n*     Workspace.\n*\n*     DY             (input) COMPLEX array, dimension (N)\n*     Workspace to hold the intermediate solution.\n*\n*     Y_TAIL         (input) COMPLEX array, dimension (N)\n*     Workspace to hold the trailing bits of the intermediate solution.\n*\n*     RCOND          (input) REAL\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     ITHRESH        (input) INTEGER\n*     The maximum number of residual computations allowed for\n*     refinement. The default is 10. For 'aggressive' set to 100 to\n*     permit convergence using approximate factorizations or\n*     factorizations other than LU. If the factorization uses a\n*     technique other than Gaussian elimination, the guarantees in\n*     ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n*     RTHRESH        (input) REAL\n*     Determines when to stop refinement if the error estimate stops\n*     decreasing. Refinement will stop when the next solution no longer\n*     satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n*     the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n*     default value is 0.5. For 'aggressive' set to 0.9 to permit\n*     convergence on extremely ill-conditioned matrices. See LAWN 165\n*     for more details.\n*\n*     DZ_UB          (input) REAL\n*     Determines when to start considering componentwise convergence.\n*     Componentwise convergence is only considered after each component\n*     of the solution Y is stable, which we definte as the relative\n*     change in each component being less than DZ_UB. The default value\n*     is 0.25, requiring the first bit to be stable. See LAWN 165 for\n*     more details.\n*\n*     IGNORE_CWISE   (input) LOGICAL\n*     If .TRUE. then ignore componentwise convergence. Default value\n*     is .FALSE..\n*\n*     INFO           (output) INTEGER\n*       = 0:  Successful exit.\n*       < 0:  if INFO = -i, the ith argument to CSYTRS had an illegal\n*             value\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            UPLO2, CNT, I, J, X_STATE, Z_STATE,\n     $                   Y_PREC_STATE\n      REAL               YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n     $                   DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n     $                   DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n     $                   EPS, HUGEVAL, INCR_THRESH\n      LOGICAL            INCR_PREC\n      COMPLEX            ZDUM\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.cla_syrfsx_extended( prec_type, uplo, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 21 && argc != 21)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 21)", argc);
  rblapack_prec_type = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_colequ = argv[5];
  rblapack_c = argv[6];
  rblapack_b = argv[7];
  rblapack_y = argv[8];
  rblapack_n_norms = argv[9];
  rblapack_err_bnds_norm = argv[10];
  rblapack_err_bnds_comp = argv[11];
  rblapack_res = argv[12];
  rblapack_ayb = argv[13];
  rblapack_dy = argv[14];
  rblapack_y_tail = argv[15];
  rblapack_rcond = argv[16];
  rblapack_ithresh = argv[17];
  rblapack_rthresh = argv[18];
  rblapack_dz_ub = argv[19];
  rblapack_ignore_cwise = argv[20];
  if (argc == 21) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  prec_type = NUM2INT(rblapack_prec_type);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (9th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 2)
    rb_raise(rb_eArgError, "rank of y (9th argument) must be %d", 2);
  ldy = NA_SHAPE0(rblapack_y);
  nrhs = NA_SHAPE1(rblapack_y);
  if (NA_TYPE(rblapack_y) != NA_SCOMPLEX)
    rblapack_y = na_change_type(rblapack_y, NA_SCOMPLEX);
  y = NA_PTR_TYPE(rblapack_y, complex*);
  if (!NA_IsNArray(rblapack_err_bnds_norm))
    rb_raise(rb_eArgError, "err_bnds_norm (11th argument) must be NArray");
  if (NA_RANK(rblapack_err_bnds_norm) != 2)
    rb_raise(rb_eArgError, "rank of err_bnds_norm (11th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_err_bnds_norm) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of y");
  n_err_bnds = NA_SHAPE1(rblapack_err_bnds_norm);
  if (NA_TYPE(rblapack_err_bnds_norm) != NA_SFLOAT)
    rblapack_err_bnds_norm = na_change_type(rblapack_err_bnds_norm, NA_SFLOAT);
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
  if (!NA_IsNArray(rblapack_res))
    rb_raise(rb_eArgError, "res (13th argument) must be NArray");
  if (NA_RANK(rblapack_res) != 1)
    rb_raise(rb_eArgError, "rank of res (13th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_res) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_res) != NA_SCOMPLEX)
    rblapack_res = na_change_type(rblapack_res, NA_SCOMPLEX);
  res = NA_PTR_TYPE(rblapack_res, complex*);
  if (!NA_IsNArray(rblapack_dy))
    rb_raise(rb_eArgError, "dy (15th argument) must be NArray");
  if (NA_RANK(rblapack_dy) != 1)
    rb_raise(rb_eArgError, "rank of dy (15th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dy) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_dy) != NA_SCOMPLEX)
    rblapack_dy = na_change_type(rblapack_dy, NA_SCOMPLEX);
  dy = NA_PTR_TYPE(rblapack_dy, complex*);
  rcond = (real)NUM2DBL(rblapack_rcond);
  rthresh = (real)NUM2DBL(rblapack_rthresh);
  ignore_cwise = (rblapack_ignore_cwise == Qtrue);
  uplo = StringValueCStr(rblapack_uplo)[0];
  colequ = (rblapack_colequ == Qtrue);
  n_norms = NUM2INT(rblapack_n_norms);
  if (!NA_IsNArray(rblapack_ayb))
    rb_raise(rb_eArgError, "ayb (14th argument) must be NArray");
  if (NA_RANK(rblapack_ayb) != 1)
    rb_raise(rb_eArgError, "rank of ayb (14th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ayb) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ayb) != NA_SFLOAT)
    rblapack_ayb = na_change_type(rblapack_ayb, NA_SFLOAT);
  ayb = NA_PTR_TYPE(rblapack_ayb, real*);
  ithresh = NUM2INT(rblapack_ithresh);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  if (!NA_IsNArray(rblapack_err_bnds_comp))
    rb_raise(rb_eArgError, "err_bnds_comp (12th argument) must be NArray");
  if (NA_RANK(rblapack_err_bnds_comp) != 2)
    rb_raise(rb_eArgError, "rank of err_bnds_comp (12th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_err_bnds_comp) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of y");
  if (NA_SHAPE1(rblapack_err_bnds_comp) != n_err_bnds)
    rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_comp must be the same as shape 1 of err_bnds_norm");
  if (NA_TYPE(rblapack_err_bnds_comp) != NA_SFLOAT)
    rblapack_err_bnds_comp = na_change_type(rblapack_err_bnds_comp, NA_SFLOAT);
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
  dz_ub = (real)NUM2DBL(rblapack_dz_ub);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of y");
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (!NA_IsNArray(rblapack_y_tail))
    rb_raise(rb_eArgError, "y_tail (16th argument) must be NArray");
  if (NA_RANK(rblapack_y_tail) != 1)
    rb_raise(rb_eArgError, "rank of y_tail (16th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y_tail) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_y_tail) != NA_SCOMPLEX)
    rblapack_y_tail = na_change_type(rblapack_y_tail, NA_SCOMPLEX);
  y_tail = NA_PTR_TYPE(rblapack_y_tail, complex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr_out = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr_out = NA_PTR_TYPE(rblapack_berr_out, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldy;
    shape[1] = nrhs;
    rblapack_y_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, complex*);
  MEMCPY(y_out__, y, complex, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm_out__ = NA_PTR_TYPE(rblapack_err_bnds_norm_out__, real*);
  MEMCPY(err_bnds_norm_out__, err_bnds_norm, real, NA_TOTAL(rblapack_err_bnds_norm));
  rblapack_err_bnds_norm = rblapack_err_bnds_norm_out__;
  err_bnds_norm = err_bnds_norm_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp_out__ = NA_PTR_TYPE(rblapack_err_bnds_comp_out__, real*);
  MEMCPY(err_bnds_comp_out__, err_bnds_comp, real, NA_TOTAL(rblapack_err_bnds_comp));
  rblapack_err_bnds_comp = rblapack_err_bnds_comp_out__;
  err_bnds_comp = err_bnds_comp_out__;

  cla_syrfsx_extended_(&prec_type, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_err_bnds_norm, rblapack_err_bnds_comp);
}

void
init_lapack_cla_syrfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cla_syrfsx_extended", rblapack_cla_syrfsx_extended, -1);
}
ruby-lapack-1.7.2/ext/stptri.c0000644000175000017500000001067712502221022016057 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID stptri_(char* uplo, char* diag, integer* n, real* ap, integer* info);


static VALUE
rblapack_stptri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  real *ap_out__;


  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  info, ap = NumRu::Lapack.stptri( uplo, diag, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STPTRI( UPLO, DIAG, N, AP, INFO )\n\n*  Purpose\n*  =======\n*\n*  STPTRI computes the inverse of a real upper or lower triangular\n*  matrix A stored in packed format.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) REAL array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangular matrix A, stored\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n.\n*          See below for further details.\n*          On exit, the (triangular) inverse of the original matrix, in\n*          the same packed storage format.\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, A(i,i) is exactly zero.  The triangular\n*                matrix is singular and its inverse can not be computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  A triangular matrix A can be transferred to packed storage using one\n*  of the following program segments:\n*\n*  UPLO = 'U':                      UPLO = 'L':\n*\n*        JC = 1                           JC = 1\n*        DO 2 J = 1, N                    DO 2 J = 1, N\n*           DO 1 I = 1, J                    DO 1 I = J, N\n*              AP(JC+I-1) = A(I,J)              AP(JC+I-J) = A(I,J)\n*      1    CONTINUE                    1    CONTINUE\n*           JC = JC + J                      JC = JC + N - J + 1\n*      2 CONTINUE                       2 CONTINUE\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ap = NumRu::Lapack.stptri( uplo, diag, n, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_diag = argv[1];
  rblapack_n = argv[2];
  rblapack_ap = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  n = NUM2INT(rblapack_n);
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, real*);
  MEMCPY(ap_out__, ap, real, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  stptri_(&uplo, &diag, &n, ap, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ap);
}

void
init_lapack_stptri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "stptri", rblapack_stptri, -1);
}
ruby-lapack-1.7.2/ext/cpoequ.c0000644000175000017500000000775712502221024016035 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cpoequ_(integer* n, complex* a, integer* lda, real* s, real* scond, real* amax, integer* info);


static VALUE
rblapack_cpoequ(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_scond;
  real scond; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_info;
  integer info; 

  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  s, scond, amax, info = NumRu::Lapack.cpoequ( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPOEQU computes row and column scalings intended to equilibrate a\n*  Hermitian positive definite matrix A and reduce its condition number\n*  (with respect to the two-norm).  S contains the scale factors,\n*  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n*  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This\n*  choice of S puts the condition number of B within a factor N of the\n*  smallest possible condition number over all possible diagonal\n*  scalings.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The N-by-N Hermitian positive definite matrix whose scaling\n*          factors are to be computed.  Only the diagonal elements of A\n*          are referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  S       (output) REAL array, dimension (N)\n*          If INFO = 0, S contains the scale factors for A.\n*\n*  SCOND   (output) REAL\n*          If INFO = 0, S contains the ratio of the smallest S(i) to\n*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too\n*          large nor too small, it is not worth scaling by S.\n*\n*  AMAX    (output) REAL\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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 is nonpositive.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, scond, amax, info = NumRu::Lapack.cpoequ( 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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, real*);

  cpoequ_(&n, a, &lda, s, &scond, &amax, &info);

  rblapack_scond = rb_float_new((double)scond);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
}

void
init_lapack_cpoequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cpoequ", rblapack_cpoequ, -1);
}
ruby-lapack-1.7.2/ext/strexc.c0000644000175000017500000001454012502221015016035 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID strexc_(char* compq, integer* n, real* t, integer* ldt, real* q, integer* ldq, integer* ifst, integer* ilst, real* work, integer* info);


static VALUE
rblapack_strexc(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_compq;
  char compq; 
  VALUE rblapack_t;
  real *t; 
  VALUE rblapack_q;
  real *q; 
  VALUE rblapack_ifst;
  integer ifst; 
  VALUE rblapack_ilst;
  integer ilst; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_t_out__;
  real *t_out__;
  VALUE rblapack_q_out__;
  real *q_out__;
  real *work;

  integer ldt;
  integer n;
  integer ldq;

  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  info, t, q, ifst, ilst = NumRu::Lapack.strexc( compq, t, q, ifst, ilst, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  STREXC reorders the real Schur factorization of a real matrix\n*  A = Q*T*Q**T, so that the diagonal block of T with row index IFST is\n*  moved to row ILST.\n*\n*  The real Schur form T is reordered by an orthogonal similarity\n*  transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors\n*  is updated by postmultiplying it with Z.\n*\n*  T must be in Schur canonical form (as returned by SHSEQR), that is,\n*  block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each\n*  2-by-2 diagonal block has its diagonal elements equal and its\n*  off-diagonal elements of opposite sign.\n*\n\n*  Arguments\n*  =========\n*\n*  COMPQ   (input) CHARACTER*1\n*          = 'V':  update the matrix Q of Schur vectors;\n*          = 'N':  do not update Q.\n*\n*  N       (input) INTEGER\n*          The order of the matrix T. N >= 0.\n*\n*  T       (input/output) REAL array, dimension (LDT,N)\n*          On entry, the upper quasi-triangular matrix T, in Schur\n*          Schur canonical form.\n*          On exit, the reordered upper quasi-triangular matrix, again\n*          in Schur canonical form.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= max(1,N).\n*\n*  Q       (input/output) REAL array, dimension (LDQ,N)\n*          On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n*          On exit, if COMPQ = 'V', Q has been postmultiplied by the\n*          orthogonal transformation matrix Z which reorders T.\n*          If COMPQ = 'N', Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.  LDQ >= max(1,N).\n*\n*  IFST    (input/output) INTEGER\n*  ILST    (input/output) INTEGER\n*          Specify the reordering of the diagonal blocks of T.\n*          The block with row index IFST is moved to row ILST, by a\n*          sequence of transpositions between adjacent blocks.\n*          On exit, if IFST pointed on entry to the second row of a\n*          2-by-2 block, it is changed to point to the first row; ILST\n*          always points to the first row of the block in its final\n*          position (which may differ from its input value by +1 or -1).\n*          1 <= IFST <= N; 1 <= ILST <= N.\n*\n*  WORK    (workspace) REAL array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          = 1:  two adjacent blocks were too close to swap (the problem\n*                is very ill-conditioned); T may have been partially\n*                reordered, and ILST points to the first row of the\n*                current position of the block being moved.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, t, q, ifst, ilst = NumRu::Lapack.strexc( compq, t, q, ifst, ilst, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_compq = argv[0];
  rblapack_t = argv[1];
  rblapack_q = argv[2];
  rblapack_ifst = argv[3];
  rblapack_ilst = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  compq = StringValueCStr(rblapack_compq)[0];
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (3th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (3th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  n = NA_SHAPE1(rblapack_q);
  if (NA_TYPE(rblapack_q) != NA_SFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
  q = NA_PTR_TYPE(rblapack_q, real*);
  ilst = NUM2INT(rblapack_ilst);
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (2th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (2th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  if (NA_SHAPE1(rblapack_t) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of q");
  if (NA_TYPE(rblapack_t) != NA_SFLOAT)
    rblapack_t = na_change_type(rblapack_t, NA_SFLOAT);
  t = NA_PTR_TYPE(rblapack_t, real*);
  ifst = NUM2INT(rblapack_ifst);
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = n;
    rblapack_t_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  t_out__ = NA_PTR_TYPE(rblapack_t_out__, real*);
  MEMCPY(t_out__, t, real, NA_TOTAL(rblapack_t));
  rblapack_t = rblapack_t_out__;
  t = t_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
  MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  work = ALLOC_N(real, (n));

  strexc_(&compq, &n, t, &ldt, q, &ldq, &ifst, &ilst, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  rblapack_ifst = INT2NUM(ifst);
  rblapack_ilst = INT2NUM(ilst);
  return rb_ary_new3(5, rblapack_info, rblapack_t, rblapack_q, rblapack_ifst, rblapack_ilst);
}

void
init_lapack_strexc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "strexc", rblapack_strexc, -1);
}
ruby-lapack-1.7.2/ext/dlarre.c0000644000175000017500000003440512502221013015776 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlarre_(char* range, integer* n, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* d, doublereal* e, doublereal* e2, doublereal* rtol1, doublereal* rtol2, doublereal* spltol, integer* nsplit, integer* isplit, integer* m, doublereal* w, doublereal* werr, doublereal* wgap, integer* iblock, integer* indexw, doublereal* gers, doublereal* pivmin, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dlarre(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_vl;
  doublereal vl; 
  VALUE rblapack_vu;
  doublereal vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_e2;
  doublereal *e2; 
  VALUE rblapack_rtol1;
  doublereal rtol1; 
  VALUE rblapack_rtol2;
  doublereal rtol2; 
  VALUE rblapack_spltol;
  doublereal spltol; 
  VALUE rblapack_nsplit;
  integer nsplit; 
  VALUE rblapack_isplit;
  integer *isplit; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_werr;
  doublereal *werr; 
  VALUE rblapack_wgap;
  doublereal *wgap; 
  VALUE rblapack_iblock;
  integer *iblock; 
  VALUE rblapack_indexw;
  integer *indexw; 
  VALUE rblapack_gers;
  doublereal *gers; 
  VALUE rblapack_pivmin;
  doublereal pivmin; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_e_out__;
  doublereal *e_out__;
  VALUE rblapack_e2_out__;
  doublereal *e2_out__;
  doublereal *work;
  integer *iwork;

  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  nsplit, isplit, m, w, werr, wgap, iblock, indexw, gers, pivmin, info, vl, vu, d, e, e2 = NumRu::Lapack.dlarre( range, vl, vu, il, iu, d, e, e2, rtol1, rtol2, spltol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLARRE( RANGE, N, VL, VU, IL, IU, D, E, E2, RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT, M, W, WERR, WGAP, IBLOCK, INDEXW, GERS, PIVMIN, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  To find the desired eigenvalues of a given real symmetric\n*  tridiagonal matrix T, DLARRE sets any \"small\" off-diagonal\n*  elements to zero, and for each unreduced block T_i, it finds\n*  (a) a suitable shift at one end of the block's spectrum,\n*  (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and\n*  (c) eigenvalues of each L_i D_i L_i^T.\n*  The representations and eigenvalues found are then used by\n*  DSTEMR to compute the eigenvectors of T.\n*  The accuracy varies depending on whether bisection is used to\n*  find a few eigenvalues or the dqds algorithm (subroutine DLASQ2) to\n*  conpute all and then discard any unwanted one.\n*  As an added benefit, DLARRE also outputs the n\n*  Gerschgorin intervals for the matrices L_i D_i L_i^T.\n*\n\n*  Arguments\n*  =========\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': (\"All\")   all eigenvalues will be found.\n*          = 'V': (\"Value\") all eigenvalues in the half-open interval\n*                           (VL, VU] will be found.\n*          = 'I': (\"Index\") the IL-th through IU-th eigenvalues (of the\n*                           entire matrix) will be found.\n*\n*  N       (input) INTEGER\n*          The order of the matrix. N > 0.\n*\n*  VL      (input/output) DOUBLE PRECISION\n*  VU      (input/output) DOUBLE PRECISION\n*          If RANGE='V', the lower and upper bounds for the eigenvalues.\n*          Eigenvalues less than or equal to VL, or greater than VU,\n*          will not be returned.  VL < VU.\n*          If RANGE='I' or ='A', DLARRE computes bounds on the desired\n*          part of the spectrum.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N.\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the N diagonal elements of the tridiagonal\n*          matrix T.\n*          On exit, the N diagonal elements of the diagonal\n*          matrices D_i.\n*\n*  E       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the first (N-1) entries contain the subdiagonal\n*          elements of the tridiagonal matrix T; E(N) need not be set.\n*          On exit, E contains the subdiagonal elements of the unit\n*          bidiagonal matrices L_i. The entries E( ISPLIT( I ) ),\n*          1 <= I <= NSPLIT, contain the base points sigma_i on output.\n*\n*  E2      (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the first (N-1) entries contain the SQUARES of the\n*          subdiagonal elements of the tridiagonal matrix T;\n*          E2(N) need not be set.\n*          On exit, the entries E2( ISPLIT( I ) ),\n*          1 <= I <= NSPLIT, have been set to zero\n*\n*  RTOL1   (input) DOUBLE PRECISION\n*  RTOL2   (input) DOUBLE PRECISION\n*           Parameters for bisection.\n*           An interval [LEFT,RIGHT] has converged if\n*           RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n*\n*  SPLTOL  (input) DOUBLE PRECISION\n*          The threshold for splitting.\n*\n*  NSPLIT  (output) INTEGER\n*          The number of blocks T splits into. 1 <= NSPLIT <= N.\n*\n*  ISPLIT  (output) INTEGER array, dimension (N)\n*          The splitting points, at which T breaks up into blocks.\n*          The first block consists of rows/columns 1 to ISPLIT(1),\n*          the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n*          etc., and the NSPLIT-th consists of rows/columns\n*          ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues (of all L_i D_i L_i^T)\n*          found.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          The first M elements contain the eigenvalues. The\n*          eigenvalues of each of the blocks, L_i D_i L_i^T, are\n*          sorted in ascending order ( DLARRE may use the\n*          remaining N-M elements as workspace).\n*\n*  WERR    (output) DOUBLE PRECISION array, dimension (N)\n*          The error bound on the corresponding eigenvalue in W.\n*\n*  WGAP    (output) DOUBLE PRECISION array, dimension (N)\n*          The separation from the right neighbor eigenvalue in W.\n*          The gap is only with respect to the eigenvalues of the same block\n*          as each block has its own representation tree.\n*          Exception: at the right end of a block we store the left gap\n*\n*  IBLOCK  (output) INTEGER array, dimension (N)\n*          The indices of the blocks (submatrices) associated with the\n*          corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue\n*          W(i) belongs to the first block from the top, =2 if W(i)\n*          belongs to the second block, etc.\n*\n*  INDEXW  (output) INTEGER array, dimension (N)\n*          The indices of the eigenvalues within each block (submatrix);\n*          for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the\n*          i-th eigenvalue W(i) is the 10-th eigenvalue in block 2\n*\n*  GERS    (output) DOUBLE PRECISION array, dimension (2*N)\n*          The N Gerschgorin intervals (the i-th Gerschgorin interval\n*          is (GERS(2*i-1), GERS(2*i)).\n*\n*  PIVMIN  (output) DOUBLE PRECISION\n*          The minimum pivot in the Sturm sequence for T.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (6*N)\n*          Workspace.\n*\n*  IWORK   (workspace) INTEGER array, dimension (5*N)\n*          Workspace.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          > 0:  A problem occured in DLARRE.\n*          < 0:  One of the called subroutines signaled an internal problem.\n*                Needs inspection of the corresponding parameter IINFO\n*                for further information.\n*\n*          =-1:  Problem in DLARRD.\n*          = 2:  No base representation could be found in MAXTRY iterations.\n*                Increasing MAXTRY and recompilation might be a remedy.\n*          =-3:  Problem in DLARRB when computing the refined root\n*                representation for DLASQ2.\n*          =-4:  Problem in DLARRB when preforming bisection on the\n*                desired part of the spectrum.\n*          =-5:  Problem in DLASQ2.\n*          =-6:  Problem in DLASQ2.\n*\n\n*  Further Details\n*  The base representations are required to suffer very little\n*  element growth and consequently define all their eigenvalues to\n*  high relative accuracy.\n*  ===============\n*\n*  Based on contributions by\n*     Beresford Parlett, University of California, Berkeley, USA\n*     Jim Demmel, University of California, Berkeley, USA\n*     Inderjit Dhillon, University of Texas, Austin, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  nsplit, isplit, m, w, werr, wgap, iblock, indexw, gers, pivmin, info, vl, vu, d, e, e2 = NumRu::Lapack.dlarre( range, vl, vu, il, iu, d, e, e2, rtol1, rtol2, spltol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 11 && argc != 11)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
  rblapack_range = argv[0];
  rblapack_vl = argv[1];
  rblapack_vu = argv[2];
  rblapack_il = argv[3];
  rblapack_iu = argv[4];
  rblapack_d = argv[5];
  rblapack_e = argv[6];
  rblapack_e2 = argv[7];
  rblapack_rtol1 = argv[8];
  rblapack_rtol2 = argv[9];
  rblapack_spltol = argv[10];
  if (argc == 11) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  range = StringValueCStr(rblapack_range)[0];
  vu = NUM2DBL(rblapack_vu);
  iu = NUM2INT(rblapack_iu);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (7th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (7th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_e);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  rtol1 = NUM2DBL(rblapack_rtol1);
  spltol = NUM2DBL(rblapack_spltol);
  vl = NUM2DBL(rblapack_vl);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (6th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of e");
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  rtol2 = NUM2DBL(rblapack_rtol2);
  il = NUM2INT(rblapack_il);
  if (!NA_IsNArray(rblapack_e2))
    rb_raise(rb_eArgError, "e2 (8th argument) must be NArray");
  if (NA_RANK(rblapack_e2) != 1)
    rb_raise(rb_eArgError, "rank of e2 (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e2) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of e2 must be the same as shape 0 of e");
  if (NA_TYPE(rblapack_e2) != NA_DFLOAT)
    rblapack_e2 = na_change_type(rblapack_e2, NA_DFLOAT);
  e2 = NA_PTR_TYPE(rblapack_e2, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_isplit = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_werr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  werr = NA_PTR_TYPE(rblapack_werr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wgap = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  wgap = NA_PTR_TYPE(rblapack_wgap, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_iblock = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iblock = NA_PTR_TYPE(rblapack_iblock, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_indexw = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  indexw = NA_PTR_TYPE(rblapack_indexw, integer*);
  {
    na_shape_t shape[1];
    shape[0] = 2*n;
    rblapack_gers = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  gers = NA_PTR_TYPE(rblapack_gers, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
  MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_e2_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e2_out__ = NA_PTR_TYPE(rblapack_e2_out__, doublereal*);
  MEMCPY(e2_out__, e2, doublereal, NA_TOTAL(rblapack_e2));
  rblapack_e2 = rblapack_e2_out__;
  e2 = e2_out__;
  work = ALLOC_N(doublereal, (6*n));
  iwork = ALLOC_N(integer, (5*n));

  dlarre_(&range, &n, &vl, &vu, &il, &iu, d, e, e2, &rtol1, &rtol2, &spltol, &nsplit, isplit, &m, w, werr, wgap, iblock, indexw, gers, &pivmin, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_nsplit = INT2NUM(nsplit);
  rblapack_m = INT2NUM(m);
  rblapack_pivmin = rb_float_new((double)pivmin);
  rblapack_info = INT2NUM(info);
  rblapack_vl = rb_float_new((double)vl);
  rblapack_vu = rb_float_new((double)vu);
  return rb_ary_new3(16, rblapack_nsplit, rblapack_isplit, rblapack_m, rblapack_w, rblapack_werr, rblapack_wgap, rblapack_iblock, rblapack_indexw, rblapack_gers, rblapack_pivmin, rblapack_info, rblapack_vl, rblapack_vu, rblapack_d, rblapack_e, rblapack_e2);
}

void
init_lapack_dlarre(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlarre", rblapack_dlarre, -1);
}
ruby-lapack-1.7.2/ext/dtrevc.c0000644000175000017500000002542312502221017016020 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtrevc_(char* side, char* howmny, logical* select, integer* n, doublereal* t, integer* ldt, doublereal* vl, integer* ldvl, doublereal* vr, integer* ldvr, integer* mm, integer* m, doublereal* work, integer* info);


static VALUE
rblapack_dtrevc(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_howmny;
  char howmny; 
  VALUE rblapack_select;
  logical *select; 
  VALUE rblapack_t;
  doublereal *t; 
  VALUE rblapack_vl;
  doublereal *vl; 
  VALUE rblapack_vr;
  doublereal *vr; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_select_out__;
  logical *select_out__;
  VALUE rblapack_vl_out__;
  doublereal *vl_out__;
  VALUE rblapack_vr_out__;
  doublereal *vr_out__;
  doublereal *work;

  integer n;
  integer ldt;
  integer ldvl;
  integer mm;
  integer ldvr;

  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  m, info, select, vl, vr = NumRu::Lapack.dtrevc( side, howmny, select, t, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTREVC computes some or all of the right and/or left eigenvectors of\n*  a real upper quasi-triangular matrix T.\n*  Matrices of this type are produced by the Schur factorization of\n*  a real general matrix:  A = Q*T*Q**T, as computed by DHSEQR.\n*  \n*  The right eigenvector x and the left eigenvector y of T corresponding\n*  to an eigenvalue w are defined by:\n*  \n*     T*x = w*x,     (y**H)*T = w*(y**H)\n*  \n*  where y**H denotes the conjugate transpose of y.\n*  The eigenvalues are not input to this routine, but are read directly\n*  from the diagonal blocks of T.\n*  \n*  This routine returns the matrices X and/or Y of right and left\n*  eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an\n*  input matrix.  If Q is the orthogonal factor that reduces a matrix\n*  A to Schur form T, then Q*X and Q*Y are the matrices of right and\n*  left eigenvectors of A.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'R':  compute right eigenvectors only;\n*          = 'L':  compute left eigenvectors only;\n*          = 'B':  compute both right and left eigenvectors.\n*\n*  HOWMNY  (input) CHARACTER*1\n*          = 'A':  compute all right and/or left eigenvectors;\n*          = 'B':  compute all right and/or left eigenvectors,\n*                  backtransformed by the matrices in VR and/or VL;\n*          = 'S':  compute selected right and/or left eigenvectors,\n*                  as indicated by the logical array SELECT.\n*\n*  SELECT  (input/output) LOGICAL array, dimension (N)\n*          If HOWMNY = 'S', SELECT specifies the eigenvectors to be\n*          computed.\n*          If w(j) is a real eigenvalue, the corresponding real\n*          eigenvector is computed if SELECT(j) is .TRUE..\n*          If w(j) and w(j+1) are the real and imaginary parts of a\n*          complex eigenvalue, the corresponding complex eigenvector is\n*          computed if either SELECT(j) or SELECT(j+1) is .TRUE., and\n*          on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to\n*          .FALSE..\n*          Not referenced if HOWMNY = 'A' or 'B'.\n*\n*  N       (input) INTEGER\n*          The order of the matrix T. N >= 0.\n*\n*  T       (input) DOUBLE PRECISION array, dimension (LDT,N)\n*          The upper quasi-triangular matrix T in Schur canonical form.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= max(1,N).\n*\n*  VL      (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)\n*          On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n*          contain an N-by-N matrix Q (usually the orthogonal matrix Q\n*          of Schur vectors returned by DHSEQR).\n*          On exit, if SIDE = 'L' or 'B', VL contains:\n*          if HOWMNY = 'A', the matrix Y of left eigenvectors of T;\n*          if HOWMNY = 'B', the matrix Q*Y;\n*          if HOWMNY = 'S', the left eigenvectors of T specified by\n*                           SELECT, stored consecutively in the columns\n*                           of VL, in the same order as their\n*                           eigenvalues.\n*          A complex eigenvector corresponding to a complex eigenvalue\n*          is stored in two consecutive columns, the first holding the\n*          real part, and the second the imaginary part.\n*          Not referenced if SIDE = 'R'.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the array VL.  LDVL >= 1, and if\n*          SIDE = 'L' or 'B', LDVL >= N.\n*\n*  VR      (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)\n*          On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n*          contain an N-by-N matrix Q (usually the orthogonal matrix Q\n*          of Schur vectors returned by DHSEQR).\n*          On exit, if SIDE = 'R' or 'B', VR contains:\n*          if HOWMNY = 'A', the matrix X of right eigenvectors of T;\n*          if HOWMNY = 'B', the matrix Q*X;\n*          if HOWMNY = 'S', the right eigenvectors of T specified by\n*                           SELECT, stored consecutively in the columns\n*                           of VR, in the same order as their\n*                           eigenvalues.\n*          A complex eigenvector corresponding to a complex eigenvalue\n*          is stored in two consecutive columns, the first holding the\n*          real part and the second the imaginary part.\n*          Not referenced if SIDE = 'L'.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the array VR.  LDVR >= 1, and if\n*          SIDE = 'R' or 'B', LDVR >= N.\n*\n*  MM      (input) INTEGER\n*          The number of columns in the arrays VL and/or VR. MM >= M.\n*\n*  M       (output) INTEGER\n*          The number of columns in the arrays VL and/or VR actually\n*          used to store the eigenvectors.\n*          If HOWMNY = 'A' or 'B', M is set to N.\n*          Each selected real eigenvector occupies one column and each\n*          selected complex eigenvector occupies two columns.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)\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 algorithm used in this program is basically backward (forward)\n*  substitution, with scaling to make the the code robust against\n*  possible overflow.\n*\n*  Each eigenvector is normalized so that the element of largest\n*  magnitude has magnitude 1; here the magnitude of a complex number\n*  (x,y) is taken to be |x| + |y|.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, info, select, vl, vr = NumRu::Lapack.dtrevc( side, howmny, select, t, vl, vr, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_howmny = argv[1];
  rblapack_select = argv[2];
  rblapack_t = argv[3];
  rblapack_vl = argv[4];
  rblapack_vr = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_select))
    rb_raise(rb_eArgError, "select (3th argument) must be NArray");
  if (NA_RANK(rblapack_select) != 1)
    rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_select);
  if (NA_TYPE(rblapack_select) != NA_LINT)
    rblapack_select = na_change_type(rblapack_select, NA_LINT);
  select = NA_PTR_TYPE(rblapack_select, logical*);
  if (!NA_IsNArray(rblapack_vl))
    rb_raise(rb_eArgError, "vl (5th argument) must be NArray");
  if (NA_RANK(rblapack_vl) != 2)
    rb_raise(rb_eArgError, "rank of vl (5th argument) must be %d", 2);
  ldvl = NA_SHAPE0(rblapack_vl);
  mm = NA_SHAPE1(rblapack_vl);
  if (NA_TYPE(rblapack_vl) != NA_DFLOAT)
    rblapack_vl = na_change_type(rblapack_vl, NA_DFLOAT);
  vl = NA_PTR_TYPE(rblapack_vl, doublereal*);
  howmny = StringValueCStr(rblapack_howmny)[0];
  if (!NA_IsNArray(rblapack_vr))
    rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
  if (NA_RANK(rblapack_vr) != 2)
    rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 2);
  ldvr = NA_SHAPE0(rblapack_vr);
  if (NA_SHAPE1(rblapack_vr) != mm)
    rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
  if (NA_TYPE(rblapack_vr) != NA_DFLOAT)
    rblapack_vr = na_change_type(rblapack_vr, NA_DFLOAT);
  vr = NA_PTR_TYPE(rblapack_vr, doublereal*);
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (4th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  if (NA_SHAPE1(rblapack_t) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_t) != NA_DFLOAT)
    rblapack_t = na_change_type(rblapack_t, NA_DFLOAT);
  t = NA_PTR_TYPE(rblapack_t, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_select_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  select_out__ = NA_PTR_TYPE(rblapack_select_out__, logical*);
  MEMCPY(select_out__, select, logical, NA_TOTAL(rblapack_select));
  rblapack_select = rblapack_select_out__;
  select = select_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = mm;
    rblapack_vl_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, doublereal*);
  MEMCPY(vl_out__, vl, doublereal, NA_TOTAL(rblapack_vl));
  rblapack_vl = rblapack_vl_out__;
  vl = vl_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = mm;
    rblapack_vr_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vr_out__ = NA_PTR_TYPE(rblapack_vr_out__, doublereal*);
  MEMCPY(vr_out__, vr, doublereal, NA_TOTAL(rblapack_vr));
  rblapack_vr = rblapack_vr_out__;
  vr = vr_out__;
  work = ALLOC_N(doublereal, (3*n));

  dtrevc_(&side, &howmny, select, &n, t, &ldt, vl, &ldvl, vr, &ldvr, &mm, &m, work, &info);

  free(work);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_m, rblapack_info, rblapack_select, rblapack_vl, rblapack_vr);
}

void
init_lapack_dtrevc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtrevc", rblapack_dtrevc, -1);
}
ruby-lapack-1.7.2/ext/dptcon.c0000644000175000017500000001052112502221024016007 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dptcon_(integer* n, doublereal* d, doublereal* e, doublereal* anorm, doublereal* rcond, doublereal* work, integer* info);


static VALUE
rblapack_dptcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_anorm;
  doublereal anorm; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_info;
  integer info; 
  doublereal *work;

  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  rcond, info = NumRu::Lapack.dptcon( d, e, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPTCON( N, D, E, ANORM, RCOND, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPTCON computes the reciprocal of the condition number (in the\n*  1-norm) of a real symmetric positive definite tridiagonal matrix\n*  using the factorization A = L*D*L**T or A = U**T*D*U computed by\n*  DPTTRF.\n*\n*  Norm(inv(A)) is computed by a direct method, and the reciprocal of\n*  the condition number is computed as\n*               RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          The n diagonal elements of the diagonal matrix D from the\n*          factorization of A, as computed by DPTTRF.\n*\n*  E       (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (n-1) off-diagonal elements of the unit bidiagonal factor\n*          U or L from the factorization of A,  as computed by DPTTRF.\n*\n*  ANORM   (input) DOUBLE PRECISION\n*          The 1-norm of the original matrix A.\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the\n*          1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (N)\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 method used is described in Nicholas J. Higham, \"Efficient\n*  Algorithms for Computing the Condition Number of a Tridiagonal\n*  Matrix\", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.dptcon( d, e, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_d = argv[0];
  rblapack_e = argv[1];
  rblapack_anorm = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  anorm = NUM2DBL(rblapack_anorm);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (2th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  work = ALLOC_N(doublereal, (n));

  dptcon_(&n, d, e, &anorm, &rcond, work, &info);

  free(work);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_dptcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dptcon", rblapack_dptcon, -1);
}
ruby-lapack-1.7.2/ext/dpteqr.c0000644000175000017500000001666712502221016016041 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dpteqr_(char* compz, integer* n, doublereal* d, doublereal* e, doublereal* z, integer* ldz, doublereal* work, integer* info);


static VALUE
rblapack_dpteqr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_compz;
  char compz; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_e_out__;
  doublereal *e_out__;
  VALUE rblapack_z_out__;
  doublereal *z_out__;
  doublereal *work;

  integer n;
  integer ldz;

  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  info, d, e, z = NumRu::Lapack.dpteqr( compz, d, e, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPTEQR computes all eigenvalues and, optionally, eigenvectors of a\n*  symmetric positive definite tridiagonal matrix by first factoring the\n*  matrix using DPTTRF, and then calling DBDSQR to compute the singular\n*  values of the bidiagonal factor.\n*\n*  This routine computes the eigenvalues of the positive definite\n*  tridiagonal matrix to high relative accuracy.  This means that if the\n*  eigenvalues range over many orders of magnitude in size, then the\n*  small eigenvalues and corresponding eigenvectors will be computed\n*  more accurately than, for example, with the standard QR method.\n*\n*  The eigenvectors of a full or band symmetric positive definite matrix\n*  can also be found if DSYTRD, DSPTRD, or DSBTRD has been used to\n*  reduce this matrix to tridiagonal form. (The reduction to tridiagonal\n*  form, however, may preclude the possibility of obtaining high\n*  relative accuracy in the small eigenvalues of the original matrix, if\n*  these eigenvalues range over many orders of magnitude.)\n*\n\n*  Arguments\n*  =========\n*\n*  COMPZ   (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only.\n*          = 'V':  Compute eigenvectors of original symmetric\n*                  matrix also.  Array Z contains the orthogonal\n*                  matrix used to reduce the original matrix to\n*                  tridiagonal form.\n*          = 'I':  Compute eigenvectors of tridiagonal matrix also.\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the n diagonal elements of the tridiagonal\n*          matrix.\n*          On normal exit, D contains the eigenvalues, in descending\n*          order.\n*\n*  E       (input/output) DOUBLE PRECISION array, dimension (N-1)\n*          On entry, the (n-1) subdiagonal elements of the tridiagonal\n*          matrix.\n*          On exit, E has been destroyed.\n*\n*  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ, N)\n*          On entry, if COMPZ = 'V', the orthogonal matrix used in the\n*          reduction to tridiagonal form.\n*          On exit, if COMPZ = 'V', the orthonormal eigenvectors of the\n*          original symmetric matrix;\n*          if COMPZ = 'I', the orthonormal eigenvectors of the\n*          tridiagonal matrix.\n*          If INFO > 0 on exit, Z contains the eigenvectors associated\n*          with only the stored eigenvalues.\n*          If  COMPZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          COMPZ = 'V' or 'I', LDZ >= max(1,N).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (4*N)\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, and i is:\n*                <= N  the Cholesky factorization of the matrix could\n*                      not be performed because the i-th principal minor\n*                      was not positive definite.\n*                > N   the SVD algorithm failed to converge;\n*                      if INFO = N+i, i off-diagonal elements of the\n*                      bidiagonal factor did not converge to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, e, z = NumRu::Lapack.dpteqr( compz, d, e, z, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_compz = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  rblapack_z = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  compz = StringValueCStr(rblapack_compz)[0];
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (4th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  n = NA_SHAPE1(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of z");
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
  MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
  MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  work = ALLOC_N(doublereal, (4*n));

  dpteqr_(&compz, &n, d, e, z, &ldz, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_e, rblapack_z);
}

void
init_lapack_dpteqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dpteqr", rblapack_dpteqr, -1);
}
ruby-lapack-1.7.2/ext/ieeeck.c0000644000175000017500000000526312502221021015751 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern integer ieeeck_(integer* ispec, real* zero, real* one);


static VALUE
rblapack_ieeeck(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ispec;
  integer ispec; 
  VALUE rblapack_zero;
  real zero; 
  VALUE rblapack_one;
  real one; 
  VALUE rblapack___out__;
  integer __out__; 


  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  __out__ = NumRu::Lapack.ieeeck( ispec, zero, one, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      INTEGER          FUNCTION IEEECK( ISPEC, ZERO, ONE )\n\n*  Purpose\n*  =======\n*\n*  IEEECK is called from the ILAENV to verify that Infinity and\n*  possibly NaN arithmetic is safe (i.e. will not trap).\n*\n\n*  Arguments\n*  =========\n*\n*  ISPEC   (input) INTEGER\n*          Specifies whether to test just for inifinity arithmetic\n*          or whether to test for infinity and NaN arithmetic.\n*          = 0: Verify infinity arithmetic only.\n*          = 1: Verify infinity and NaN arithmetic.\n*\n*  ZERO    (input) REAL\n*          Must contain the value 0.0\n*          This is passed to prevent the compiler from optimizing\n*          away this code.\n*\n*  ONE     (input) REAL\n*          Must contain the value 1.0\n*          This is passed to prevent the compiler from optimizing\n*          away this code.\n*\n*  RETURN VALUE:  INTEGER\n*          = 0:  Arithmetic failed to produce the correct answers\n*          = 1:  Arithmetic produced the correct answers\n*\n*     .. Local Scalars ..\n      REAL               NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF,\n     $                   NEGZRO, NEWZRO, POSINF\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.ieeeck( ispec, zero, one, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_ispec = argv[0];
  rblapack_zero = argv[1];
  rblapack_one = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  ispec = NUM2INT(rblapack_ispec);
  one = (real)NUM2DBL(rblapack_one);
  zero = (real)NUM2DBL(rblapack_zero);

  __out__ = ieeeck_(&ispec, &zero, &one);

  rblapack___out__ = INT2NUM(__out__);
  return rblapack___out__;
}

void
init_lapack_ieeeck(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ieeeck", rblapack_ieeeck, -1);
}
ruby-lapack-1.7.2/ext/sla_gbrpvgrw.c0000644000175000017500000001134312502221022017220 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real sla_gbrpvgrw_(integer* n, integer* kl, integer* ku, integer* ncols, real* ab, integer* ldab, real* afb, integer* ldafb);


static VALUE
rblapack_sla_gbrpvgrw(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ncols;
  integer ncols; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_afb;
  real *afb; 
  VALUE rblapack___out__;
  real __out__; 

  integer ldab;
  integer n;
  integer ldafb;

  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  __out__ = NumRu::Lapack.sla_gbrpvgrw( kl, ku, ncols, ab, afb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL FUNCTION SLA_GBRPVGRW( N, KL, KU, NCOLS, AB, LDAB, AFB, LDAFB )\n\n*  Purpose\n*  =======\n*\n*  SLA_GBRPVGRW computes the reciprocal pivot growth factor\n*  norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n*  much less than 1, the stability of the LU factorization of the\n*  (equilibrated) matrix A could be poor. This also means that the\n*  solution X, estimated condition numbers, and error bounds could be\n*  unreliable.\n*\n\n*  Arguments\n*  =========\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     KL      (input) INTEGER\n*     The number of subdiagonals within the band of A.  KL >= 0.\n*\n*     KU      (input) INTEGER\n*     The number of superdiagonals within the band of A.  KU >= 0.\n*\n*     NCOLS   (input) INTEGER\n*     The number of columns of the matrix A.  NCOLS >= 0.\n*\n*     AB      (input) REAL array, dimension (LDAB,N)\n*     On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n*     The j-th column of A is stored in the j-th column of the\n*     array AB as follows:\n*     AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n*     LDAB    (input) INTEGER\n*     The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*     AFB     (input) REAL array, dimension (LDAFB,N)\n*     Details of the LU factorization of the band matrix A, as\n*     computed by SGBTRF.  U is stored as an upper triangular\n*     band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n*     and the multipliers used during the factorization are stored\n*     in rows KL+KU+2 to 2*KL+KU+1.\n*\n*     LDAFB   (input) INTEGER\n*     The leading dimension of the array AFB.  LDAFB >= 2*KL+KU+1.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J, KD\n      REAL               AMAX, UMAX, RPVGRW\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.sla_gbrpvgrw( kl, ku, ncols, ab, afb, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_kl = argv[0];
  rblapack_ku = argv[1];
  rblapack_ncols = argv[2];
  rblapack_ab = argv[3];
  rblapack_afb = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  kl = NUM2INT(rblapack_kl);
  ncols = NUM2INT(rblapack_ncols);
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
  ldafb = NA_SHAPE0(rblapack_afb);
  n = NA_SHAPE1(rblapack_afb);
  if (NA_TYPE(rblapack_afb) != NA_SFLOAT)
    rblapack_afb = na_change_type(rblapack_afb, NA_SFLOAT);
  afb = NA_PTR_TYPE(rblapack_afb, real*);
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);

  __out__ = sla_gbrpvgrw_(&n, &kl, &ku, &ncols, ab, &ldab, afb, &ldafb);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_sla_gbrpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sla_gbrpvgrw", rblapack_sla_gbrpvgrw, -1);
}
ruby-lapack-1.7.2/ext/sorg2r.c0000644000175000017500000001031612502221024015740 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sorg2r_(integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* work, integer* info);


static VALUE
rblapack_sorg2r(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  real *work;

  integer lda;
  integer n;
  integer k;

  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  info, a = NumRu::Lapack.sorg2r( m, a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SORG2R( M, N, K, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SORG2R generates an m by n real matrix Q with orthonormal columns,\n*  which is defined as the first n columns of a product of k elementary\n*  reflectors of order m\n*\n*        Q  =  H(1) H(2) . . . H(k)\n*\n*  as returned by SGEQRF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. M >= N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. N >= K >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the i-th column must contain the vector which\n*          defines the elementary reflector H(i), for i = 1,2,...,k, as\n*          returned by SGEQRF in the first k columns of its array\n*          argument A.\n*          On exit, the m-by-n matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) REAL array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by SGEQRF.\n*\n*  WORK    (workspace) REAL array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -i, the i-th argument has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.sorg2r( m, a, tau, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  rblapack_tau = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(real, (n));

  sorg2r_(&m, &n, &k, a, &lda, tau, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_sorg2r(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sorg2r", rblapack_sorg2r, -1);
}
ruby-lapack-1.7.2/ext/chetrd.c0000644000175000017500000001723412502221022015777 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chetrd_(char* uplo, integer* n, complex* a, integer* lda, real* d, real* e, complex* tau, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_chetrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *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  d, e, tau, work, info, a = NumRu::Lapack.chetrd( uplo, a, lwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHETRD reduces a complex Hermitian matrix A to real symmetric\n*  tridiagonal form T by a unitary similarity transformation:\n*  Q**H * A * Q = T.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*          On exit, if UPLO = 'U', the diagonal and first superdiagonal\n*          of A are overwritten by the corresponding elements of the\n*          tridiagonal matrix T, and the elements above the first\n*          superdiagonal, with the array TAU, represent the unitary\n*          matrix Q as a product of elementary reflectors; if UPLO\n*          = 'L', the diagonal and first subdiagonal of A are over-\n*          written by the corresponding elements of the tridiagonal\n*          matrix T, and the elements below the first subdiagonal, with\n*          the array TAU, represent the unitary matrix Q as a product\n*          of elementary reflectors. See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  D       (output) REAL array, dimension (N)\n*          The diagonal elements of the tridiagonal matrix T:\n*          D(i) = A(i,i).\n*\n*  E       (output) REAL array, dimension (N-1)\n*          The off-diagonal elements of the tridiagonal matrix T:\n*          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n*  TAU     (output) COMPLEX array, dimension (N-1)\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace/output) COMPLEX 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 >= 1.\n*          For optimum performance LWORK >= N*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*  If UPLO = 'U', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(n-1) . . . H(2) H(1).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - tau * v * v'\n*\n*  where tau is a complex scalar, and v is a complex vector with\n*  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n*  A(1:i-1,i+1), and tau in TAU(i).\n*\n*  If UPLO = 'L', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(1) H(2) . . . H(n-1).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - tau * v * v'\n*\n*  where tau is a complex scalar, and v is a complex vector with\n*  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n*  and tau in TAU(i).\n*\n*  The contents of A on exit are illustrated by the following examples\n*  with n = 5:\n*\n*  if UPLO = 'U':                       if UPLO = 'L':\n*\n*    (  d   e   v2  v3  v4 )              (  d                  )\n*    (      d   e   v3  v4 )              (  e   d              )\n*    (          d   e   v4 )              (  v1  e   d          )\n*    (              d   e  )              (  v1  v2  e   d      )\n*    (                  d  )              (  v1  v2  v3  e   d  )\n*\n*  where d and e denote diagonal and off-diagonal elements of T, and vi\n*  denotes an element of the vector defining H(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, tau, work, info, a = NumRu::Lapack.chetrd( uplo, a, lwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_lwork = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  lwork = NUM2INT(rblapack_lwork);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, real*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  chetrd_(&uplo, &n, a, &lda, d, e, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_d, rblapack_e, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_chetrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chetrd", rblapack_chetrd, -1);
}
ruby-lapack-1.7.2/ext/zggglm.c0000644000175000017500000002147012502221015016014 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zggglm_(integer* n, integer* m, integer* p, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* d, doublecomplex* x, doublecomplex* y, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zggglm(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_d;
  doublecomplex *d; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_y;
  doublecomplex *y; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  VALUE rblapack_d_out__;
  doublecomplex *d_out__;

  integer lda;
  integer m;
  integer ldb;
  integer p;
  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  x, y, work, info, a, b, d = NumRu::Lapack.zggglm( a, b, d, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGGGLM solves a general Gauss-Markov linear model (GLM) problem:\n*\n*          minimize || y ||_2   subject to   d = A*x + B*y\n*              x\n*\n*  where A is an N-by-M matrix, B is an N-by-P matrix, and d is a\n*  given N-vector. It is assumed that M <= N <= M+P, and\n*\n*             rank(A) = M    and    rank( A B ) = N.\n*\n*  Under these assumptions, the constrained equation is always\n*  consistent, and there is a unique solution x and a minimal 2-norm\n*  solution y, which is obtained using a generalized QR factorization\n*  of the matrices (A, B) given by\n*\n*     A = Q*(R),   B = Q*T*Z.\n*           (0)\n*\n*  In particular, if matrix B is square nonsingular, then the problem\n*  GLM is equivalent to the following weighted linear least squares\n*  problem\n*\n*               minimize || inv(B)*(d-A*x) ||_2\n*                   x\n*\n*  where inv(B) denotes the inverse of B.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of rows of the matrices A and B.  N >= 0.\n*\n*  M       (input) INTEGER\n*          The number of columns of the matrix A.  0 <= M <= N.\n*\n*  P       (input) INTEGER\n*          The number of columns of the matrix B.  P >= N-M.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,M)\n*          On entry, the N-by-M matrix A.\n*          On exit, the upper triangular part of the array A contains\n*          the M-by-M upper triangular matrix R.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,P)\n*          On entry, the N-by-P matrix B.\n*          On exit, if N <= P, the upper triangle of the subarray\n*          B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n*          if N > P, the elements on and above the (N-P)th subdiagonal\n*          contain the N-by-P upper trapezoidal matrix T.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  D       (input/output) COMPLEX*16 array, dimension (N)\n*          On entry, D is the left hand side of the GLM equation.\n*          On exit, D is destroyed.\n*\n*  X       (output) COMPLEX*16 array, dimension (M)\n*  Y       (output) COMPLEX*16 array, dimension (P)\n*          On exit, X and Y are the solutions of the GLM problem.\n*\n*  WORK    (workspace/output) COMPLEX*16 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,N+M+P).\n*          For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,\n*          where NB is an upper bound for the optimal blocksizes for\n*          ZGEQRF, ZGERQF, ZUNMQR and ZUNMRQ.\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*          = 1:  the upper triangular factor R associated with A in the\n*                generalized QR factorization of the pair (A, B) is\n*                singular, so that rank(A) < M; the least squares\n*                solution could not be computed.\n*          = 2:  the bottom (N-M) by (N-M) part of the upper trapezoidal\n*                factor T associated with B in the generalized QR\n*                factorization of the pair (A, B) is singular, so that\n*                rank( A B ) < N; the least squares solution could not\n*                be computed.\n*\n\n*  ===================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, y, work, info, a, b, d = NumRu::Lapack.zggglm( a, b, d, [: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_a = argv[0];
  rblapack_b = argv[1];
  rblapack_d = 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 (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);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DCOMPLEX)
    rblapack_d = na_change_type(rblapack_d, NA_DCOMPLEX);
  d = NA_PTR_TYPE(rblapack_d, doublecomplex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  p = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  if (rblapack_lwork == Qnil)
    lwork = m+n+p;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_x = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = p;
    rblapack_y = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  y = NA_PTR_TYPE(rblapack_y, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = m;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = p;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublecomplex*);
  MEMCPY(d_out__, d, doublecomplex, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;

  zggglm_(&n, &m, &p, a, &lda, b, &ldb, d, x, y, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_x, rblapack_y, rblapack_work, rblapack_info, rblapack_a, rblapack_b, rblapack_d);
}

void
init_lapack_zggglm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zggglm", rblapack_zggglm, -1);
}
ruby-lapack-1.7.2/ext/slarf.c0000644000175000017500000001117012502221013015626 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slarf_(char* side, integer* m, integer* n, real* v, integer* incv, real* tau, real* c, integer* ldc, real* work);


static VALUE
rblapack_slarf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_v;
  real *v; 
  VALUE rblapack_incv;
  integer incv; 
  VALUE rblapack_tau;
  real tau; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_c_out__;
  real *c_out__;
  real *work;

  integer ldc;
  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  c = NumRu::Lapack.slarf( side, m, v, incv, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )\n\n*  Purpose\n*  =======\n*\n*  SLARF applies a real elementary reflector H to a real m by n matrix\n*  C, from either the left or the right. H is represented in the form\n*\n*        H = I - tau * v * v'\n*\n*  where tau is a real scalar and v is a real vector.\n*\n*  If tau = 0, then H is taken to be the unit matrix.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': form  H * C\n*          = 'R': form  C * H\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C.\n*\n*  V       (input) REAL array, dimension\n*                     (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n*                  or (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n*          The vector v in the representation of H. V is not used if\n*          TAU = 0.\n*\n*  INCV    (input) INTEGER\n*          The increment between elements of v. INCV <> 0.\n*\n*  TAU     (input) REAL\n*          The value tau in the representation of H.\n*\n*  C       (input/output) REAL array, dimension (LDC,N)\n*          On entry, the m by n matrix C.\n*          On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n*          or C * H if SIDE = 'R'.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) REAL array, dimension\n*                         (N) if SIDE = 'L'\n*                      or (M) if SIDE = 'R'\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.slarf( side, m, v, incv, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_m = argv[1];
  rblapack_v = argv[2];
  rblapack_incv = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  incv = NUM2INT(rblapack_incv);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  m = NUM2INT(rblapack_m);
  tau = (real)NUM2DBL(rblapack_tau);
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (3th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 1)
    rb_raise(rb_eArgError, "rank of v (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_v) != (1 + (m-1)*abs(incv)))
    rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1 + (m-1)*abs(incv));
  if (NA_TYPE(rblapack_v) != NA_SFLOAT)
    rblapack_v = na_change_type(rblapack_v, NA_SFLOAT);
  v = NA_PTR_TYPE(rblapack_v, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  slarf_(&side, &m, &n, v, &incv, &tau, c, &ldc, work);

  free(work);
  return rblapack_c;
}

void
init_lapack_slarf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slarf", rblapack_slarf, -1);
}
ruby-lapack-1.7.2/ext/zungbr.c0000644000175000017500000001562312502221013016035 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zungbr_(char* vect, integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zungbr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_vect;
  char vect; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *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  work, info, a = NumRu::Lapack.zungbr( vect, m, k, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZUNGBR generates one of the complex unitary matrices Q or P**H\n*  determined by ZGEBRD when reducing a complex matrix A to bidiagonal\n*  form: A = Q * B * P**H.  Q and P**H are defined as products of\n*  elementary reflectors H(i) or G(i) respectively.\n*\n*  If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q\n*  is of order M:\n*  if m >= k, Q = H(1) H(2) . . . H(k) and ZUNGBR returns the first n\n*  columns of Q, where m >= n >= k;\n*  if m < k, Q = H(1) H(2) . . . H(m-1) and ZUNGBR returns Q as an\n*  M-by-M matrix.\n*\n*  If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**H\n*  is of order N:\n*  if k < n, P**H = G(k) . . . G(2) G(1) and ZUNGBR returns the first m\n*  rows of P**H, where n >= m >= k;\n*  if k >= n, P**H = G(n-1) . . . G(2) G(1) and ZUNGBR returns P**H as\n*  an N-by-N matrix.\n*\n\n*  Arguments\n*  =========\n*\n*  VECT    (input) CHARACTER*1\n*          Specifies whether the matrix Q or the matrix P**H is\n*          required, as defined in the transformation applied by ZGEBRD:\n*          = 'Q':  generate Q;\n*          = 'P':  generate P**H.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q or P**H to be returned.\n*          M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q or P**H to be returned.\n*          N >= 0.\n*          If VECT = 'Q', M >= N >= min(M,K);\n*          if VECT = 'P', N >= M >= min(N,K).\n*\n*  K       (input) INTEGER\n*          If VECT = 'Q', the number of columns in the original M-by-K\n*          matrix reduced by ZGEBRD.\n*          If VECT = 'P', the number of rows in the original K-by-N\n*          matrix reduced by ZGEBRD.\n*          K >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the vectors which define the elementary reflectors,\n*          as returned by ZGEBRD.\n*          On exit, the M-by-N matrix Q or P**H.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= M.\n*\n*  TAU     (input) COMPLEX*16 array, dimension\n*                                (min(M,K)) if VECT = 'Q'\n*                                (min(N,K)) if VECT = 'P'\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i) or G(i), which determines Q or P**H, as\n*          returned by ZGEBRD in its array argument TAUQ or TAUP.\n*\n*  WORK    (workspace/output) COMPLEX*16 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,min(M,N)).\n*          For optimum performance LWORK >= min(M,N)*NB, where NB\n*          is the 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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, a = NumRu::Lapack.zungbr( vect, m, k, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_vect = argv[0];
  rblapack_m = argv[1];
  rblapack_k = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  if (argc == 6) {
    rblapack_lwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  vect = StringValueCStr(rblapack_vect)[0];
  k = NUM2INT(rblapack_k);
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_tau) != (MIN(m,k)))
    rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", MIN(m,k));
  if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (rblapack_lwork == Qnil)
    lwork = MIN(m,n);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zungbr_(&vect, &m, &n, &k, a, &lda, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_zungbr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zungbr", rblapack_zungbr, -1);
}
ruby-lapack-1.7.2/ext/zpttrf.c0000644000175000017500000001052212502221014016051 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zpttrf_(integer* n, doublereal* d, doublecomplex* e, integer* info);


static VALUE
rblapack_zpttrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublecomplex *e; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_e_out__;
  doublecomplex *e_out__;

  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  info, d, e = NumRu::Lapack.zpttrf( d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPTTRF( N, D, E, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPTTRF computes the L*D*L' factorization of a complex Hermitian\n*  positive definite tridiagonal matrix A.  The factorization may also\n*  be regarded as having the form A = U'*D*U.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the n diagonal elements of the tridiagonal matrix\n*          A.  On exit, the n diagonal elements of the diagonal matrix\n*          D from the L*D*L' factorization of A.\n*\n*  E       (input/output) COMPLEX*16 array, dimension (N-1)\n*          On entry, the (n-1) subdiagonal elements of the tridiagonal\n*          matrix A.  On exit, the (n-1) subdiagonal elements of the\n*          unit bidiagonal factor L from the L*D*L' factorization of A.\n*          E can also be regarded as the superdiagonal of the unit\n*          bidiagonal factor U from the U'*D*U factorization of A.\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*          > 0: if INFO = k, the leading minor of order k is not\n*               positive definite; if k < N, the factorization could not\n*               be completed, while if k = N, the factorization was\n*               completed, but D(N) <= 0.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, e = NumRu::Lapack.zpttrf( d, e, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_d = argv[0];
  rblapack_e = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (2th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DCOMPLEX)
    rblapack_e = na_change_type(rblapack_e, NA_DCOMPLEX);
  e = NA_PTR_TYPE(rblapack_e, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublecomplex*);
  MEMCPY(e_out__, e, doublecomplex, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;

  zpttrf_(&n, d, e, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_d, rblapack_e);
}

void
init_lapack_zpttrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zpttrf", rblapack_zpttrf, -1);
}
ruby-lapack-1.7.2/ext/dgesdd.c0000644000175000017500000002350112502221022015752 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgesdd_(char* jobz, integer* m, integer* n, doublereal* a, integer* lda, doublereal* s, doublereal* u, integer* ldu, doublereal* vt, integer* ldvt, doublereal* work, integer* lwork, integer* iwork, integer* info);


static VALUE
rblapack_dgesdd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_u;
  doublereal *u; 
  VALUE rblapack_vt;
  doublereal *vt; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  integer *iwork;

  integer lda;
  integer n;
  integer ldu;
  integer ucol;
  integer ldvt;
  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  s, u, vt, work, info, a = NumRu::Lapack.dgesdd( jobz, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGESDD computes the singular value decomposition (SVD) of a real\n*  M-by-N matrix A, optionally computing the left and right singular\n*  vectors.  If singular vectors are desired, it uses a\n*  divide-and-conquer algorithm.\n*\n*  The SVD is written\n*\n*       A = U * SIGMA * transpose(V)\n*\n*  where SIGMA is an M-by-N matrix which is zero except for its\n*  min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and\n*  V is an N-by-N orthogonal matrix.  The diagonal elements of SIGMA\n*  are the singular values of A; they are real and non-negative, and\n*  are returned in descending order.  The first min(m,n) columns of\n*  U and V are the left and right singular vectors of A.\n*\n*  Note that the routine returns VT = V**T, not V.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          Specifies options for computing all or part of the matrix U:\n*          = 'A':  all M columns of U and all N rows of V**T are\n*                  returned in the arrays U and VT;\n*          = 'S':  the first min(M,N) columns of U and the first\n*                  min(M,N) rows of V**T are returned in the arrays U\n*                  and VT;\n*          = 'O':  If M >= N, the first N columns of U are overwritten\n*                  on the array A and all rows of V**T are returned in\n*                  the array VT;\n*                  otherwise, all columns of U are returned in the\n*                  array U and the first M rows of V**T are overwritten\n*                  in the array A;\n*          = 'N':  no columns of U or rows of V**T are computed.\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.  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,\n*          if JOBZ = 'O',  A is overwritten with the first N columns\n*                          of U (the left singular vectors, stored\n*                          columnwise) if M >= N;\n*                          A is overwritten with the first M rows\n*                          of V**T (the right singular vectors, stored\n*                          rowwise) otherwise.\n*          if JOBZ .ne. 'O', the contents of A are destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  S       (output) DOUBLE PRECISION array, dimension (min(M,N))\n*          The singular values of A, sorted so that S(i) >= S(i+1).\n*\n*  U       (output) DOUBLE PRECISION array, dimension (LDU,UCOL)\n*          UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;\n*          UCOL = min(M,N) if JOBZ = 'S'.\n*          If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M\n*          orthogonal matrix U;\n*          if JOBZ = 'S', U contains the first min(M,N) columns of U\n*          (the left singular vectors, stored columnwise);\n*          if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.\n*\n*  LDU     (input) INTEGER\n*          The leading dimension of the array U.  LDU >= 1; if\n*          JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.\n*\n*  VT      (output) DOUBLE PRECISION array, dimension (LDVT,N)\n*          If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the\n*          N-by-N orthogonal matrix V**T;\n*          if JOBZ = 'S', VT contains the first min(M,N) rows of\n*          V**T (the right singular vectors, stored rowwise);\n*          if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.\n*\n*  LDVT    (input) INTEGER\n*          The leading dimension of the array VT.  LDVT >= 1; if\n*          JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;\n*          if JOBZ = 'S', LDVT >= min(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. LWORK >= 1.\n*          If JOBZ = 'N',\n*            LWORK >= 3*min(M,N) + max(max(M,N),7*min(M,N)).\n*          If JOBZ = 'O',\n*            LWORK >= 3*min(M,N) + \n*                     max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)).\n*          If JOBZ = 'S' or 'A'\n*            LWORK >= 3*min(M,N) +\n*                     max(max(M,N),4*min(M,N)*min(M,N)+4*min(M,N)).\n*          For good performance, LWORK should generally be larger.\n*          If LWORK = -1 but other input arguments are legal, WORK(1)\n*          returns the optimal LWORK.\n*\n*  IWORK   (workspace) INTEGER array, dimension (8*min(M,N))\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit.\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          > 0:  DBDSDC did not converge, updating process failed.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, u, vt, work, info, a = NumRu::Lapack.dgesdd( jobz, 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_jobz = 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;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  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 = lda;
  ldvt = ((lsame_(&jobz,"A")) || (((lsame_(&jobz,"O")) && (m >= n)))) ? n : lsame_(&jobz,"S") ? MIN(m,n) : 1;
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&jobz,"N") ? 3*MIN(m,n)+MAX(MAX(m,n),7*MIN(m,n)) : lsame_(&jobz,"O") ? 3*MIN(m,n)+MAX(MAX(m,n),5*MIN(m,n)*MIN(m,n)+4*MIN(m,n)) : (lsame_(&jobz,"S")||lsame_(&jobz,"A")) ? 3*MIN(m,n)+MAX(MAX(m,n),4*MIN(m,n)*MIN(m,n)+4*MIN(m,n)) : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldu = (lsame_(&jobz,"S") || lsame_(&jobz,"A") || (lsame_(&jobz,"O") && m < n)) ? m : 1;
  ucol = ((lsame_(&jobz,"A")) || (((lsame_(&jobz,"O")) && (m < n)))) ? m : lsame_(&jobz,"S") ? MIN(m,n) : 0;
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = ucol;
    rblapack_u = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  u = NA_PTR_TYPE(rblapack_u, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldvt;
    shape[1] = n;
    rblapack_vt = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vt = NA_PTR_TYPE(rblapack_vt, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;
  iwork = ALLOC_N(integer, (8*MIN(m,n)));

  dgesdd_(&jobz, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, iwork, &info);

  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_s, rblapack_u, rblapack_vt, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_dgesdd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgesdd", rblapack_dgesdd, -1);
}
ruby-lapack-1.7.2/ext/dgttrf.c0000644000175000017500000001504012502221024016013 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgttrf_(integer* n, doublereal* dl, doublereal* d, doublereal* du, doublereal* du2, integer* ipiv, integer* info);


static VALUE
rblapack_dgttrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_dl;
  doublereal *dl; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_du;
  doublereal *du; 
  VALUE rblapack_du2;
  doublereal *du2; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_dl_out__;
  doublereal *dl_out__;
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_du_out__;
  doublereal *du_out__;

  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  du2, ipiv, info, dl, d, du = NumRu::Lapack.dgttrf( dl, d, du, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGTTRF( N, DL, D, DU, DU2, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGTTRF computes an LU factorization of a real tridiagonal matrix A\n*  using elimination with partial pivoting and row interchanges.\n*\n*  The factorization has the form\n*     A = L * U\n*  where L is a product of permutation and unit lower bidiagonal\n*  matrices and U is upper triangular with nonzeros in only the main\n*  diagonal and first two superdiagonals.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.\n*\n*  DL      (input/output) DOUBLE PRECISION array, dimension (N-1)\n*          On entry, DL must contain the (n-1) sub-diagonal elements of\n*          A.\n*\n*          On exit, DL is overwritten by the (n-1) multipliers that\n*          define the matrix L from the LU factorization of A.\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, D must contain the diagonal elements of A.\n*\n*          On exit, D is overwritten by the n diagonal elements of the\n*          upper triangular matrix U from the LU factorization of A.\n*\n*  DU      (input/output) DOUBLE PRECISION array, dimension (N-1)\n*          On entry, DU must contain the (n-1) super-diagonal elements\n*          of A.\n*\n*          On exit, DU is overwritten by the (n-1) elements of the first\n*          super-diagonal of U.\n*\n*  DU2     (output) DOUBLE PRECISION array, dimension (N-2)\n*          On exit, DU2 is overwritten by the (n-2) elements of the\n*          second super-diagonal of U.\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          The pivot indices; for 1 <= i <= n, row i of the matrix was\n*          interchanged with row IPIV(i).  IPIV(i) will always be either\n*          i or i+1; IPIV(i) = i indicates a row interchange was not\n*          required.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -k, the k-th argument had an illegal value\n*          > 0:  if INFO = k, U(k,k) is exactly zero. The factorization\n*                has been completed, but the factor U is exactly\n*                singular, and division by zero will occur if it is used\n*                to solve a system of equations.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  du2, ipiv, info, dl, d, du = NumRu::Lapack.dgttrf( dl, d, du, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_dl = argv[0];
  rblapack_d = argv[1];
  rblapack_du = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (1th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (1th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_DFLOAT)
    rblapack_dl = na_change_type(rblapack_dl, NA_DFLOAT);
  dl = NA_PTR_TYPE(rblapack_dl, doublereal*);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (3th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_DFLOAT)
    rblapack_du = na_change_type(rblapack_du, NA_DFLOAT);
  du = NA_PTR_TYPE(rblapack_du, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n-2;
    rblapack_du2 = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  du2 = NA_PTR_TYPE(rblapack_du2, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_dl_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  dl_out__ = NA_PTR_TYPE(rblapack_dl_out__, doublereal*);
  MEMCPY(dl_out__, dl, doublereal, NA_TOTAL(rblapack_dl));
  rblapack_dl = rblapack_dl_out__;
  dl = dl_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_du_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  du_out__ = NA_PTR_TYPE(rblapack_du_out__, doublereal*);
  MEMCPY(du_out__, du, doublereal, NA_TOTAL(rblapack_du));
  rblapack_du = rblapack_du_out__;
  du = du_out__;

  dgttrf_(&n, dl, d, du, du2, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_du2, rblapack_ipiv, rblapack_info, rblapack_dl, rblapack_d, rblapack_du);
}

void
init_lapack_dgttrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgttrf", rblapack_dgttrf, -1);
}
ruby-lapack-1.7.2/ext/zlarfx.c0000644000175000017500000001102612502221024016027 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlarfx_(char* side, integer* m, integer* n, doublecomplex* v, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work);


static VALUE
rblapack_zlarfx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_v;
  doublecomplex *v; 
  VALUE rblapack_tau;
  doublecomplex tau; 
  VALUE rblapack_c;
  doublecomplex *c; 
  VALUE rblapack_c_out__;
  doublecomplex *c_out__;
  doublecomplex *work;

  integer m;
  integer ldc;
  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  c = NumRu::Lapack.zlarfx( side, v, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )\n\n*  Purpose\n*  =======\n*\n*  ZLARFX applies a complex elementary reflector H to a complex m by n\n*  matrix C, from either the left or the right. H is represented in the\n*  form\n*\n*        H = I - tau * v * v'\n*\n*  where tau is a complex scalar and v is a complex vector.\n*\n*  If tau = 0, then H is taken to be the unit matrix\n*\n*  This version uses inline code if H has order < 11.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': form  H * C\n*          = 'R': form  C * H\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C.\n*\n*  V       (input) COMPLEX*16 array, dimension (M) if SIDE = 'L'\n*                                        or (N) if SIDE = 'R'\n*          The vector v in the representation of H.\n*\n*  TAU     (input) COMPLEX*16\n*          The value tau in the representation of H.\n*\n*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)\n*          On entry, the m by n matrix C.\n*          On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n*          or C * H if SIDE = 'R'.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDA >= max(1,M).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (N) if SIDE = 'L'\n*                                            or (M) if SIDE = 'R'\n*          WORK is not referenced if H has order < 11.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.zlarfx( side, v, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_side = argv[0];
  rblapack_v = argv[1];
  rblapack_tau = argv[2];
  rblapack_c = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  tau.r = NUM2DBL(rb_funcall(rblapack_tau, rb_intern("real"), 0));
  tau.i = NUM2DBL(rb_funcall(rblapack_tau, rb_intern("imag"), 0));
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (2th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 1)
    rb_raise(rb_eArgError, "rank of v (2th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_v);
  if (NA_TYPE(rblapack_v) != NA_DCOMPLEX)
    rblapack_v = na_change_type(rblapack_v, NA_DCOMPLEX);
  v = NA_PTR_TYPE(rblapack_v, doublecomplex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (4th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (4th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
  MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(doublecomplex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  zlarfx_(&side, &m, &n, v, &tau, c, &ldc, work);

  free(work);
  return rblapack_c;
}

void
init_lapack_zlarfx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlarfx", rblapack_zlarfx, -1);
}
ruby-lapack-1.7.2/ext/dlasr.c0000644000175000017500000002066512502221024015637 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlasr_(char* side, char* pivot, char* direct, integer* m, integer* n, doublereal* c, doublereal* s, doublereal* a, integer* lda);


static VALUE
rblapack_dlasr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_pivot;
  char pivot; 
  VALUE rblapack_direct;
  char direct; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_a;
  doublereal *a; 
  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  a = NumRu::Lapack.dlasr( side, pivot, direct, m, c, s, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )\n\n*  Purpose\n*  =======\n*\n*  DLASR applies a sequence of plane rotations to a real matrix A,\n*  from either the left or the right.\n*  \n*  When SIDE = 'L', the transformation takes the form\n*  \n*     A := P*A\n*  \n*  and when SIDE = 'R', the transformation takes the form\n*  \n*     A := A*P**T\n*  \n*  where P is an orthogonal matrix consisting of a sequence of z plane\n*  rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',\n*  and P**T is the transpose of P.\n*  \n*  When DIRECT = 'F' (Forward sequence), then\n*  \n*     P = P(z-1) * ... * P(2) * P(1)\n*  \n*  and when DIRECT = 'B' (Backward sequence), then\n*  \n*     P = P(1) * P(2) * ... * P(z-1)\n*  \n*  where P(k) is a plane rotation matrix defined by the 2-by-2 rotation\n*  \n*     R(k) = (  c(k)  s(k) )\n*          = ( -s(k)  c(k) ).\n*  \n*  When PIVOT = 'V' (Variable pivot), the rotation is performed\n*  for the plane (k,k+1), i.e., P(k) has the form\n*  \n*     P(k) = (  1                                            )\n*            (       ...                                     )\n*            (              1                                )\n*            (                   c(k)  s(k)                  )\n*            (                  -s(k)  c(k)                  )\n*            (                                1              )\n*            (                                     ...       )\n*            (                                            1  )\n*  \n*  where R(k) appears as a rank-2 modification to the identity matrix in\n*  rows and columns k and k+1.\n*  \n*  When PIVOT = 'T' (Top pivot), the rotation is performed for the\n*  plane (1,k+1), so P(k) has the form\n*  \n*     P(k) = (  c(k)                    s(k)                 )\n*            (         1                                     )\n*            (              ...                              )\n*            (                     1                         )\n*            ( -s(k)                    c(k)                 )\n*            (                                 1             )\n*            (                                      ...      )\n*            (                                             1 )\n*  \n*  where R(k) appears in rows and columns 1 and k+1.\n*  \n*  Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is\n*  performed for the plane (k,z), giving P(k) the form\n*  \n*     P(k) = ( 1                                             )\n*            (      ...                                      )\n*            (             1                                 )\n*            (                  c(k)                    s(k) )\n*            (                         1                     )\n*            (                              ...              )\n*            (                                     1         )\n*            (                 -s(k)                    c(k) )\n*  \n*  where R(k) appears in rows and columns k and z.  The rotations are\n*  performed without ever forming P(k) explicitly.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          Specifies whether the plane rotation matrix P is applied to\n*          A on the left or the right.\n*          = 'L':  Left, compute A := P*A\n*          = 'R':  Right, compute A:= A*P**T\n*\n*  PIVOT   (input) CHARACTER*1\n*          Specifies the plane for which P(k) is a plane rotation\n*          matrix.\n*          = 'V':  Variable pivot, the plane (k,k+1)\n*          = 'T':  Top pivot, the plane (1,k+1)\n*          = 'B':  Bottom pivot, the plane (k,z)\n*\n*  DIRECT  (input) CHARACTER*1\n*          Specifies whether P is a forward or backward sequence of\n*          plane rotations.\n*          = 'F':  Forward, P = P(z-1)*...*P(2)*P(1)\n*          = 'B':  Backward, P = P(1)*P(2)*...*P(z-1)\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.  If m <= 1, an immediate\n*          return is effected.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.  If n <= 1, an\n*          immediate return is effected.\n*\n*  C       (input) DOUBLE PRECISION array, dimension\n*                  (M-1) if SIDE = 'L'\n*                  (N-1) if SIDE = 'R'\n*          The cosines c(k) of the plane rotations.\n*\n*  S       (input) DOUBLE PRECISION array, dimension\n*                  (M-1) if SIDE = 'L'\n*                  (N-1) if SIDE = 'R'\n*          The sines s(k) of the plane rotations.  The 2-by-2 plane\n*          rotation part of the matrix P(k), R(k), has the form\n*          R(k) = (  c(k)  s(k) )\n*                 ( -s(k)  c(k) ).\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          The M-by-N matrix A.  On exit, A is overwritten by P*A if\n*          SIDE = 'R' or by A*P**T if SIDE = 'L'.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  a = NumRu::Lapack.dlasr( side, pivot, direct, m, c, s, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_side = argv[0];
  rblapack_pivot = argv[1];
  rblapack_direct = argv[2];
  rblapack_m = argv[3];
  rblapack_c = argv[4];
  rblapack_s = argv[5];
  rblapack_a = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  direct = StringValueCStr(rblapack_direct)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (7th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (7th 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*);
  pivot = StringValueCStr(rblapack_pivot)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (6th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != (m-1))
    rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", m-1);
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != (m-1))
    rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", m-1);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  {
    na_shape_t 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__;

  dlasr_(&side, &pivot, &direct, &m, &n, c, s, a, &lda);

  return rblapack_a;
}

void
init_lapack_dlasr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlasr", rblapack_dlasr, -1);
}
ruby-lapack-1.7.2/ext/extconf.rb0000644000175000017500000000510012655774547016404 0ustar  uwabamiuwabamirequire "rubygems"
require "mkmf"


def header_not_found(name)
  warn < 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  w, m, s, sep, work, info, t, q = NumRu::Lapack.ztrsen( job, compq, select, t, q, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S, SEP, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTRSEN reorders the Schur factorization of a complex matrix\n*  A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in\n*  the leading positions on the diagonal of the upper triangular matrix\n*  T, and the leading columns of Q form an orthonormal basis of the\n*  corresponding right invariant subspace.\n*\n*  Optionally the routine computes the reciprocal condition numbers of\n*  the cluster of eigenvalues and/or the invariant subspace.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies whether condition numbers are required for the\n*          cluster of eigenvalues (S) or the invariant subspace (SEP):\n*          = 'N': none;\n*          = 'E': for eigenvalues only (S);\n*          = 'V': for invariant subspace only (SEP);\n*          = 'B': for both eigenvalues and invariant subspace (S and\n*                 SEP).\n*\n*  COMPQ   (input) CHARACTER*1\n*          = 'V': update the matrix Q of Schur vectors;\n*          = 'N': do not update Q.\n*\n*  SELECT  (input) LOGICAL array, dimension (N)\n*          SELECT specifies the eigenvalues in the selected cluster. To\n*          select the j-th eigenvalue, SELECT(j) must be set to .TRUE..\n*\n*  N       (input) INTEGER\n*          The order of the matrix T. N >= 0.\n*\n*  T       (input/output) COMPLEX*16 array, dimension (LDT,N)\n*          On entry, the upper triangular matrix T.\n*          On exit, T is overwritten by the reordered matrix T, with the\n*          selected eigenvalues as the leading diagonal elements.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= max(1,N).\n*\n*  Q       (input/output) COMPLEX*16 array, dimension (LDQ,N)\n*          On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n*          On exit, if COMPQ = 'V', Q has been postmultiplied by the\n*          unitary transformation matrix which reorders T; the leading M\n*          columns of Q form an orthonormal basis for the specified\n*          invariant subspace.\n*          If COMPQ = 'N', Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.\n*          LDQ >= 1; and if COMPQ = 'V', LDQ >= N.\n*\n*  W       (output) COMPLEX*16 array, dimension (N)\n*          The reordered eigenvalues of T, in the same order as they\n*          appear on the diagonal of T.\n*\n*  M       (output) INTEGER\n*          The dimension of the specified invariant subspace.\n*          0 <= M <= N.\n*\n*  S       (output) DOUBLE PRECISION\n*          If JOB = 'E' or 'B', S is a lower bound on the reciprocal\n*          condition number for the selected cluster of eigenvalues.\n*          S cannot underestimate the true reciprocal condition number\n*          by more than a factor of sqrt(N). If M = 0 or N, S = 1.\n*          If JOB = 'N' or 'V', S is not referenced.\n*\n*  SEP     (output) DOUBLE PRECISION\n*          If JOB = 'V' or 'B', SEP is the estimated reciprocal\n*          condition number of the specified invariant subspace. If\n*          M = 0 or N, SEP = norm(T).\n*          If JOB = 'N' or 'E', SEP is not referenced.\n*\n*  WORK    (workspace/output) COMPLEX*16 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*          If JOB = 'N', LWORK >= 1;\n*          if JOB = 'E', LWORK = max(1,M*(N-M));\n*          if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).\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*  ZTRSEN first collects the selected eigenvalues by computing a unitary\n*  transformation Z to move them to the top left corner of T. In other\n*  words, the selected eigenvalues are the eigenvalues of T11 in:\n*\n*                Z'*T*Z = ( T11 T12 ) n1\n*                         (  0  T22 ) n2\n*                            n1  n2\n*\n*  where N = n1+n2 and Z' means the conjugate transpose of Z. The first\n*  n1 columns of Z span the specified invariant subspace of T.\n*\n*  If T has been obtained from the Schur factorization of a matrix\n*  A = Q*T*Q', then the reordered Schur factorization of A is given by\n*  A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span the\n*  corresponding invariant subspace of A.\n*\n*  The reciprocal condition number of the average of the eigenvalues of\n*  T11 may be returned in S. S lies between 0 (very badly conditioned)\n*  and 1 (very well conditioned). It is computed as follows. First we\n*  compute R so that\n*\n*                         P = ( I  R ) n1\n*                             ( 0  0 ) n2\n*                               n1 n2\n*\n*  is the projector on the invariant subspace associated with T11.\n*  R is the solution of the Sylvester equation:\n*\n*                        T11*R - R*T22 = T12.\n*\n*  Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote\n*  the two-norm of M. Then S is computed as the lower bound\n*\n*                      (1 + F-norm(R)**2)**(-1/2)\n*\n*  on the reciprocal of 2-norm(P), the true reciprocal condition number.\n*  S cannot underestimate 1 / 2-norm(P) by more than a factor of\n*  sqrt(N).\n*\n*  An approximate error bound for the computed average of the\n*  eigenvalues of T11 is\n*\n*                         EPS * norm(T) / S\n*\n*  where EPS is the machine precision.\n*\n*  The reciprocal condition number of the right invariant subspace\n*  spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.\n*  SEP is defined as the separation of T11 and T22:\n*\n*                     sep( T11, T22 ) = sigma-min( C )\n*\n*  where sigma-min(C) is the smallest singular value of the\n*  n1*n2-by-n1*n2 matrix\n*\n*     C  = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )\n*\n*  I(m) is an m by m identity matrix, and kprod denotes the Kronecker\n*  product. We estimate sigma-min(C) by the reciprocal of an estimate of\n*  the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)\n*  cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).\n*\n*  When SEP is small, small changes in T can cause large changes in\n*  the invariant subspace. An approximate bound on the maximum angular\n*  error in the computed right invariant subspace is\n*\n*                      EPS * norm(T) / SEP\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, m, s, sep, work, info, t, q = NumRu::Lapack.ztrsen( job, compq, select, t, q, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_job = argv[0];
  rblapack_compq = argv[1];
  rblapack_select = argv[2];
  rblapack_t = argv[3];
  rblapack_q = argv[4];
  if (argc == 6) {
    rblapack_lwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  job = StringValueCStr(rblapack_job)[0];
  if (!NA_IsNArray(rblapack_select))
    rb_raise(rb_eArgError, "select (3th argument) must be NArray");
  if (NA_RANK(rblapack_select) != 1)
    rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_select);
  if (NA_TYPE(rblapack_select) != NA_LINT)
    rblapack_select = na_change_type(rblapack_select, NA_LINT);
  select = NA_PTR_TYPE(rblapack_select, logical*);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (5th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_q) != NA_DCOMPLEX)
    rblapack_q = na_change_type(rblapack_q, NA_DCOMPLEX);
  q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
  compq = StringValueCStr(rblapack_compq)[0];
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (4th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  if (NA_SHAPE1(rblapack_t) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_t) != NA_DCOMPLEX)
    rblapack_t = na_change_type(rblapack_t, NA_DCOMPLEX);
  t = NA_PTR_TYPE(rblapack_t, doublecomplex*);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&job,"N") ? n : lsame_(&job,"E") ? m*(n-m) : (lsame_(&job,"V")||lsame_(&job,"B")) ? 2*m*(n-m) : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = n;
    rblapack_t_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  t_out__ = NA_PTR_TYPE(rblapack_t_out__, doublecomplex*);
  MEMCPY(t_out__, t, doublecomplex, NA_TOTAL(rblapack_t));
  rblapack_t = rblapack_t_out__;
  t = t_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublecomplex*);
  MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;

  ztrsen_(&job, &compq, select, &n, t, &ldt, q, &ldq, w, &m, &s, &sep, work, &lwork, &info);

  rblapack_m = INT2NUM(m);
  rblapack_s = rb_float_new((double)s);
  rblapack_sep = rb_float_new((double)sep);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_w, rblapack_m, rblapack_s, rblapack_sep, rblapack_work, rblapack_info, rblapack_t, rblapack_q);
}

void
init_lapack_ztrsen(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztrsen", rblapack_ztrsen, -1);
}
ruby-lapack-1.7.2/ext/zlascl2.c0000644000175000017500000000664312502221026016106 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlascl2_(integer* m, integer* n, doublereal* d, doublecomplex* x, integer* ldx);


static VALUE
rblapack_zlascl2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;

  integer m;
  integer ldx;
  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  x = NumRu::Lapack.zlascl2( d, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLASCL2 ( M, N, D, X, LDX )\n\n*  Purpose\n*  =======\n*\n*  ZLASCL2 performs a diagonal scaling on a vector:\n*    x <-- D * x\n*  where the DOUBLE PRECISION diagonal matrix D is stored as a vector.\n*\n*  Eventually to be replaced by BLAS_zge_diag_scale in the new BLAS\n*  standard.\n*\n\n*  Arguments\n*  =========\n*\n*     M       (input) INTEGER\n*     The number of rows of D and X. M >= 0.\n*\n*     N       (input) INTEGER\n*     The number of columns of D and X. N >= 0.\n*\n*     D       (input) DOUBLE PRECISION array, length M\n*     Diagonal matrix D, stored as a vector of length M.\n*\n*     X       (input/output) COMPLEX*16 array, dimension (LDX,N)\n*     On entry, the vector X to be scaled by D.\n*     On exit, the scaled vector.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the vector X. LDX >= 0.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x = NumRu::Lapack.zlascl2( d, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_d = argv[0];
  rblapack_x = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  n = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = n;
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;

  zlascl2_(&m, &n, d, x, &ldx);

  return rblapack_x;
}

void
init_lapack_zlascl2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlascl2", rblapack_zlascl2, -1);
}
ruby-lapack-1.7.2/ext/cpotf2.c0000644000175000017500000001006212502221013015713 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cpotf2_(char* uplo, integer* n, complex* a, integer* lda, integer* info);


static VALUE
rblapack_cpotf2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *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  info, a = NumRu::Lapack.cpotf2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPOTF2( UPLO, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPOTF2 computes the Cholesky factorization of a complex Hermitian\n*  positive definite matrix A.\n*\n*  The factorization has the form\n*     A = U' * U ,  if UPLO = 'U', or\n*     A = L  * L',  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is lower triangular.\n*\n*  This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          Hermitian matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading\n*          n by n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n by n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the factor U or L from the Cholesky\n*          factorization A = U'*U  or A = L*L'.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*          > 0: if INFO = k, the leading minor of order k is not\n*               positive definite, and the factorization could not be\n*               completed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.cpotf2( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  cpotf2_(&uplo, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_cpotf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cpotf2", rblapack_cpotf2, -1);
}
ruby-lapack-1.7.2/ext/slange.c0000644000175000017500000000745712502221025016010 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real slange_(char* norm, integer* m, integer* n, real* a, integer* lda, real* work);


static VALUE
rblapack_slange(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack___out__;
  real __out__; 
  real *work;

  integer lda;
  integer n;
  integer lwork;

  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  __out__ = NumRu::Lapack.slange( norm, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL             FUNCTION SLANGE( NORM, M, N, A, LDA, WORK )\n\n*  Purpose\n*  =======\n*\n*  SLANGE  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  real matrix A.\n*\n*  Description\n*  ===========\n*\n*  SLANGE returns the value\n*\n*     SLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in SLANGE as described\n*          above.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.  M >= 0.  When M = 0,\n*          SLANGE is set to zero.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.  N >= 0.  When N = 0,\n*          SLANGE is set to zero.\n*\n*  A       (input) REAL array, dimension (LDA,N)\n*          The m by n matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(M,1).\n*\n*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),\n*          where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n*          referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.slange( norm, m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_norm = argv[0];
  rblapack_m = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  m = NUM2INT(rblapack_m);
  lwork = lsame_(&norm,"I") ? m : 0;
  work = ALLOC_N(real, (MAX(1,lwork)));

  __out__ = slange_(&norm, &m, &n, a, &lda, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_slange(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slange", rblapack_slange, -1);
}
ruby-lapack-1.7.2/ext/zlarscl2.c0000644000175000017500000000667612502221017016276 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlarscl2_(integer* m, integer* n, doublereal* d, doublecomplex* x, integer* ldx);


static VALUE
rblapack_zlarscl2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;

  integer m;
  integer ldx;
  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  x = NumRu::Lapack.zlarscl2( d, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLARSCL2 ( M, N, D, X, LDX )\n\n*  Purpose\n*  =======\n*\n*  ZLARSCL2 performs a reciprocal diagonal scaling on an vector:\n*    x <-- inv(D) * x\n*  where the DOUBLE PRECISION diagonal matrix D is stored as a vector.\n*\n*  Eventually to be replaced by BLAS_zge_diag_scale in the new BLAS\n*  standard.\n*\n\n*  Arguments\n*  =========\n*\n*     M       (input) INTEGER\n*     The number of rows of D and X. M >= 0.\n*\n*     N       (input) INTEGER\n*     The number of columns of D and X. N >= 0.\n*\n*     D       (input) DOUBLE PRECISION array, length M\n*     Diagonal matrix D, stored as a vector of length M.\n*\n*     X       (input/output) COMPLEX*16 array, dimension (LDX,N)\n*     On entry, the vector X to be scaled by D.\n*     On exit, the scaled vector.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the vector X. LDX >= 0.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x = NumRu::Lapack.zlarscl2( d, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_d = argv[0];
  rblapack_x = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  n = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = n;
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;

  zlarscl2_(&m, &n, d, x, &ldx);

  return rblapack_x;
}

void
init_lapack_zlarscl2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlarscl2", rblapack_zlarscl2, -1);
}
ruby-lapack-1.7.2/ext/zhbgvx.c0000644000175000017500000003126612502221014016040 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhbgvx_(char* jobz, char* range, char* uplo, integer* n, integer* ka, integer* kb, doublecomplex* ab, integer* ldab, doublecomplex* bb, integer* ldbb, doublecomplex* q, integer* ldq, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublecomplex* z, integer* ldz, doublecomplex* work, doublereal* rwork, integer* iwork, integer* ifail, integer* info);


static VALUE
rblapack_zhbgvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ka;
  integer ka; 
  VALUE rblapack_kb;
  integer kb; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_bb;
  doublecomplex *bb; 
  VALUE rblapack_vl;
  doublereal vl; 
  VALUE rblapack_vu;
  doublereal vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  doublereal abstol; 
  VALUE rblapack_q;
  doublecomplex *q; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_ifail;
  integer *ifail; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublecomplex *ab_out__;
  VALUE rblapack_bb_out__;
  doublecomplex *bb_out__;
  doublecomplex *work;
  doublereal *rwork;
  integer *iwork;

  integer ldab;
  integer n;
  integer ldbb;
  integer ldq;
  integer ldz;

  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  q, m, w, z, ifail, info, ab, bb = NumRu::Lapack.zhbgvx( jobz, range, uplo, ka, kb, ab, bb, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHBGVX computes all the eigenvalues, and optionally, the eigenvectors\n*  of a complex generalized Hermitian-definite banded eigenproblem, of\n*  the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian\n*  and banded, and B is also positive definite.  Eigenvalues and\n*  eigenvectors can be selected by specifying either all eigenvalues,\n*  a range of values or a range of indices for the desired eigenvalues.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found;\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found;\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  KA      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n*  KB      (input) INTEGER\n*          The number of superdiagonals of the matrix B if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n*  AB      (input/output) COMPLEX*16 array, dimension (LDAB, N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix A, stored in the first ka+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).\n*\n*          On exit, the contents of AB are destroyed.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KA+1.\n*\n*  BB      (input/output) COMPLEX*16 array, dimension (LDBB, N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix B, stored in the first kb+1 rows of the array.  The\n*          j-th column of B is stored in the j-th column of the array BB\n*          as follows:\n*          if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n*          if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb).\n*\n*          On exit, the factor S from the split Cholesky factorization\n*          B = S**H*S, as returned by ZPBSTF.\n*\n*  LDBB    (input) INTEGER\n*          The leading dimension of the array BB.  LDBB >= KB+1.\n*\n*  Q       (output) COMPLEX*16 array, dimension (LDQ, N)\n*          If JOBZ = 'V', the n-by-n matrix used in the reduction of\n*          A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x,\n*          and consequently C to tridiagonal form.\n*          If JOBZ = 'N', the array Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.  If JOBZ = 'N',\n*          LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N).\n*\n*  VL      (input) DOUBLE PRECISION\n*  VU      (input) DOUBLE PRECISION\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) DOUBLE PRECISION\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less than\n*          or equal to zero, then  EPS*|T|  will be used in its place,\n*          where |T| is the 1-norm of the tridiagonal matrix obtained\n*          by reducing AP to tridiagonal form.\n*\n*          Eigenvalues will be computed most accurately when ABSTOL is\n*          set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n*          If this routine returns with INFO>0, indicating that some\n*          eigenvectors did not converge, try setting ABSTOL to\n*          2*DLAMCH('S').\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) COMPLEX*16 array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n*          eigenvectors, with the i-th column of Z holding the\n*          eigenvector associated with W(i). The eigenvectors are\n*          normalized so that Z**H*B*Z = I.\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= N.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (7*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (5*N)\n*\n*  IFAIL   (output) INTEGER array, dimension (N)\n*          If JOBZ = 'V', then if INFO = 0, the first M elements of\n*          IFAIL are zero.  If INFO > 0, then IFAIL contains the\n*          indices of the eigenvectors that failed to converge.\n*          If JOBZ = 'N', then IFAIL is not referenced.\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, and i is:\n*             <= N:  then i eigenvectors failed to converge.  Their\n*                    indices are stored in array IFAIL.\n*             > N:   if INFO = N + i, for 1 <= i <= N, then ZPBSTF\n*                    returned INFO = i: B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  q, m, w, z, ifail, info, ab, bb = NumRu::Lapack.zhbgvx( jobz, range, uplo, ka, kb, ab, bb, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_uplo = argv[2];
  rblapack_ka = argv[3];
  rblapack_kb = argv[4];
  rblapack_ab = argv[5];
  rblapack_bb = argv[6];
  rblapack_vl = argv[7];
  rblapack_vu = argv[8];
  rblapack_il = argv[9];
  rblapack_iu = argv[10];
  rblapack_abstol = argv[11];
  if (argc == 12) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  kb = NUM2INT(rblapack_kb);
  if (!NA_IsNArray(rblapack_bb))
    rb_raise(rb_eArgError, "bb (7th argument) must be NArray");
  if (NA_RANK(rblapack_bb) != 2)
    rb_raise(rb_eArgError, "rank of bb (7th argument) must be %d", 2);
  ldbb = NA_SHAPE0(rblapack_bb);
  n = NA_SHAPE1(rblapack_bb);
  if (NA_TYPE(rblapack_bb) != NA_DCOMPLEX)
    rblapack_bb = na_change_type(rblapack_bb, NA_DCOMPLEX);
  bb = NA_PTR_TYPE(rblapack_bb, doublecomplex*);
  vu = NUM2DBL(rblapack_vu);
  iu = NUM2INT(rblapack_iu);
  range = StringValueCStr(rblapack_range)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (6th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (6th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of bb");
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  il = NUM2INT(rblapack_il);
  ldz = lsame_(&jobz,"V") ? n : 1;
  ka = NUM2INT(rblapack_ka);
  abstol = NUM2DBL(rblapack_abstol);
  vl = NUM2DBL(rblapack_vl);
  ldq = 1 ? jobz = 'n' : MAX(1,n) ? jobz = 'v' : 0;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
  MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldbb;
    shape[1] = n;
    rblapack_bb_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  bb_out__ = NA_PTR_TYPE(rblapack_bb_out__, doublecomplex*);
  MEMCPY(bb_out__, bb, doublecomplex, NA_TOTAL(rblapack_bb));
  rblapack_bb = rblapack_bb_out__;
  bb = bb_out__;
  work = ALLOC_N(doublecomplex, (n));
  rwork = ALLOC_N(doublereal, (7*n));
  iwork = ALLOC_N(integer, (5*n));

  zhbgvx_(&jobz, &range, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, q, &ldq, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, rwork, iwork, ifail, &info);

  free(work);
  free(rwork);
  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_q, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_ab, rblapack_bb);
}

void
init_lapack_zhbgvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhbgvx", rblapack_zhbgvx, -1);
}
ruby-lapack-1.7.2/ext/zggbak.c0000644000175000017500000001506512502221024015775 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zggbak_(char* job, char* side, integer* n, integer* ilo, integer* ihi, doublereal* lscale, doublereal* rscale, integer* m, doublecomplex* v, integer* ldv, integer* info);


static VALUE
rblapack_zggbak(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_lscale;
  doublereal *lscale; 
  VALUE rblapack_rscale;
  doublereal *rscale; 
  VALUE rblapack_v;
  doublecomplex *v; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_v_out__;
  doublecomplex *v_out__;

  integer n;
  integer ldv;
  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  info, v = NumRu::Lapack.zggbak( job, side, ilo, ihi, lscale, rscale, v, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGGBAK forms the right or left eigenvectors of a complex generalized\n*  eigenvalue problem A*x = lambda*B*x, by backward transformation on\n*  the computed eigenvectors of the balanced pair of matrices output by\n*  ZGGBAL.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies the type of backward transformation required:\n*          = 'N':  do nothing, return immediately;\n*          = 'P':  do backward transformation for permutation only;\n*          = 'S':  do backward transformation for scaling only;\n*          = 'B':  do backward transformations for both permutation and\n*                  scaling.\n*          JOB must be the same as the argument JOB supplied to ZGGBAL.\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'R':  V contains right eigenvectors;\n*          = 'L':  V contains left eigenvectors.\n*\n*  N       (input) INTEGER\n*          The number of rows of the matrix V.  N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          The integers ILO and IHI determined by ZGGBAL.\n*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n*  LSCALE  (input) DOUBLE PRECISION array, dimension (N)\n*          Details of the permutations and/or scaling factors applied\n*          to the left side of A and B, as returned by ZGGBAL.\n*\n*  RSCALE  (input) DOUBLE PRECISION array, dimension (N)\n*          Details of the permutations and/or scaling factors applied\n*          to the right side of A and B, as returned by ZGGBAL.\n*\n*  M       (input) INTEGER\n*          The number of columns of the matrix V.  M >= 0.\n*\n*  V       (input/output) COMPLEX*16 array, dimension (LDV,M)\n*          On entry, the matrix of right or left eigenvectors to be\n*          transformed, as returned by ZTGEVC.\n*          On exit, V is overwritten by the transformed eigenvectors.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the matrix V. LDV >= max(1,N).\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*  See R.C. Ward, Balancing the generalized eigenvalue problem,\n*                 SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LEFTV, RIGHTV\n      INTEGER            I, K\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZDSCAL, ZSWAP\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, v = NumRu::Lapack.zggbak( job, side, ilo, ihi, lscale, rscale, v, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_job = argv[0];
  rblapack_side = argv[1];
  rblapack_ilo = argv[2];
  rblapack_ihi = argv[3];
  rblapack_lscale = argv[4];
  rblapack_rscale = argv[5];
  rblapack_v = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  job = StringValueCStr(rblapack_job)[0];
  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_lscale))
    rb_raise(rb_eArgError, "lscale (5th argument) must be NArray");
  if (NA_RANK(rblapack_lscale) != 1)
    rb_raise(rb_eArgError, "rank of lscale (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_lscale);
  if (NA_TYPE(rblapack_lscale) != NA_DFLOAT)
    rblapack_lscale = na_change_type(rblapack_lscale, NA_DFLOAT);
  lscale = NA_PTR_TYPE(rblapack_lscale, doublereal*);
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (7th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  m = NA_SHAPE1(rblapack_v);
  if (NA_TYPE(rblapack_v) != NA_DCOMPLEX)
    rblapack_v = na_change_type(rblapack_v, NA_DCOMPLEX);
  v = NA_PTR_TYPE(rblapack_v, doublecomplex*);
  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_rscale))
    rb_raise(rb_eArgError, "rscale (6th argument) must be NArray");
  if (NA_RANK(rblapack_rscale) != 1)
    rb_raise(rb_eArgError, "rank of rscale (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_rscale) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of rscale must be the same as shape 0 of lscale");
  if (NA_TYPE(rblapack_rscale) != NA_DFLOAT)
    rblapack_rscale = na_change_type(rblapack_rscale, NA_DFLOAT);
  rscale = NA_PTR_TYPE(rblapack_rscale, doublereal*);
  ihi = NUM2INT(rblapack_ihi);
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = m;
    rblapack_v_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  v_out__ = NA_PTR_TYPE(rblapack_v_out__, doublecomplex*);
  MEMCPY(v_out__, v, doublecomplex, NA_TOTAL(rblapack_v));
  rblapack_v = rblapack_v_out__;
  v = v_out__;

  zggbak_(&job, &side, &n, &ilo, &ihi, lscale, rscale, &m, v, &ldv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_v);
}

void
init_lapack_zggbak(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zggbak", rblapack_zggbak, -1);
}
ruby-lapack-1.7.2/ext/ztrsyl.c0000644000175000017500000001443112502221017016075 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztrsyl_(char* trana, char* tranb, integer* isgn, integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* c, integer* ldc, doublereal* scale, integer* info);


static VALUE
rblapack_ztrsyl(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trana;
  char trana; 
  VALUE rblapack_tranb;
  char tranb; 
  VALUE rblapack_isgn;
  integer isgn; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_c;
  doublecomplex *c; 
  VALUE rblapack_scale;
  doublereal scale; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublecomplex *c_out__;

  integer lda;
  integer m;
  integer ldb;
  integer n;
  integer ldc;

  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  scale, info, c = NumRu::Lapack.ztrsyl( trana, tranb, isgn, a, b, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, SCALE, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTRSYL solves the complex Sylvester matrix equation:\n*\n*     op(A)*X + X*op(B) = scale*C or\n*     op(A)*X - X*op(B) = scale*C,\n*\n*  where op(A) = A or A**H, and A and B are both upper triangular. A is\n*  M-by-M and B is N-by-N; the right hand side C and the solution X are\n*  M-by-N; and scale is an output scale factor, set <= 1 to avoid\n*  overflow in X.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANA   (input) CHARACTER*1\n*          Specifies the option op(A):\n*          = 'N': op(A) = A    (No transpose)\n*          = 'C': op(A) = A**H (Conjugate transpose)\n*\n*  TRANB   (input) CHARACTER*1\n*          Specifies the option op(B):\n*          = 'N': op(B) = B    (No transpose)\n*          = 'C': op(B) = B**H (Conjugate transpose)\n*\n*  ISGN    (input) INTEGER\n*          Specifies the sign in the equation:\n*          = +1: solve op(A)*X + X*op(B) = scale*C\n*          = -1: solve op(A)*X - X*op(B) = scale*C\n*\n*  M       (input) INTEGER\n*          The order of the matrix A, and the number of rows in the\n*          matrices X and C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The order of the matrix B, and the number of columns in the\n*          matrices X and C. N >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,M)\n*          The upper triangular matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  B       (input) COMPLEX*16 array, dimension (LDB,N)\n*          The upper triangular matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)\n*          On entry, the M-by-N right hand side matrix C.\n*          On exit, C is overwritten by the solution matrix X.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M)\n*\n*  SCALE   (output) DOUBLE PRECISION\n*          The scale factor, scale, set <= 1 to avoid overflow in X.\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -i, the i-th argument had an illegal value\n*          = 1: A and B have common or very close eigenvalues; perturbed\n*               values were used to solve the equation (but the matrices\n*               A and B are unchanged).\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, info, c = NumRu::Lapack.ztrsyl( trana, tranb, isgn, a, b, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_trana = argv[0];
  rblapack_tranb = argv[1];
  rblapack_isgn = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  rblapack_c = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trana = StringValueCStr(rblapack_trana)[0];
  isgn = NUM2INT(rblapack_isgn);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  tranb = StringValueCStr(rblapack_tranb)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  if (NA_SHAPE1(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of c must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
  MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  ztrsyl_(&trana, &tranb, &isgn, &m, &n, a, &lda, b, &ldb, c, &ldc, &scale, &info);

  rblapack_scale = rb_float_new((double)scale);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_scale, rblapack_info, rblapack_c);
}

void
init_lapack_ztrsyl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztrsyl", rblapack_ztrsyl, -1);
}
ruby-lapack-1.7.2/ext/cgelsy.c0000644000175000017500000002432512502221022016013 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgelsy_(integer* m, integer* n, integer* nrhs, complex* a, integer* lda, complex* b, integer* ldb, integer* jpvt, real* rcond, integer* rank, complex* work, integer* lwork, real* rwork, integer* info);


static VALUE
rblapack_cgelsy(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_jpvt;
  integer *jpvt; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_rank;
  integer rank; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;
  VALUE rblapack_jpvt_out__;
  integer *jpvt_out__;
  real *rwork;

  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  rank, work, info, a, b, jpvt = NumRu::Lapack.cgelsy( a, b, jpvt, rcond, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGELSY computes the minimum-norm solution to a complex linear least\n*  squares problem:\n*      minimize || A * X - B ||\n*  using a complete orthogonal factorization of A.  A is an M-by-N\n*  matrix which may be rank-deficient.\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*  The routine first computes a QR factorization with column pivoting:\n*      A * P = Q * [ R11 R12 ]\n*                  [  0  R22 ]\n*  with R11 defined as the largest leading submatrix whose estimated\n*  condition number is less than 1/RCOND.  The order of R11, RANK,\n*  is the effective rank of A.\n*\n*  Then, R22 is considered to be negligible, and R12 is annihilated\n*  by unitary transformations from the right, arriving at the\n*  complete orthogonal factorization:\n*     A * P = Q * [ T11 0 ] * Z\n*                 [  0  0 ]\n*  The minimum-norm solution is then\n*     X = P * Z' [ inv(T11)*Q1'*B ]\n*                [        0       ]\n*  where Q1 consists of the first RANK columns of Q.\n*\n*  This routine is basically identical to the original xGELSX except\n*  three differences:\n*    o The permutation of matrix B (the right hand side) is faster and\n*      more simple.\n*    o The call to the subroutine xGEQPF has been substituted by the\n*      the call to the subroutine xGEQP3. This subroutine is a Blas-3\n*      version of the QR factorization with column pivoting.\n*    o Matrix B (the right hand side) is updated with Blas-3.\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*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of\n*          columns of matrices B and X. NRHS >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, A has been overwritten by details of its\n*          complete orthogonal factorization.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the M-by-NRHS right hand side matrix B.\n*          On exit, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,M,N).\n*\n*  JPVT    (input/output) INTEGER array, dimension (N)\n*          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n*          to the front of AP, otherwise column i is a free column.\n*          On exit, if JPVT(i) = k, then the i-th column of A*P\n*          was the k-th column of A.\n*\n*  RCOND   (input) REAL\n*          RCOND is used to determine the effective rank of A, which\n*          is defined as the order of the largest leading triangular\n*          submatrix R11 in the QR factorization with pivoting of A,\n*          whose estimated condition number < 1/RCOND.\n*\n*  RANK    (output) INTEGER\n*          The effective rank of A, i.e., the order of the submatrix\n*          R11.  This is the same as the order of the submatrix T11\n*          in the complete orthogonal factorization of A.\n*\n*  WORK    (workspace/output) COMPLEX 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*          The unblocked strategy requires that:\n*            LWORK >= MN + MAX( 2*MN, N+1, MN+NRHS )\n*          where MN = min(M,N).\n*          The block algorithm requires that:\n*            LWORK >= MN + MAX( 2*MN, NB*(N+1), MN+MN*NB, MN+NB*NRHS )\n*          where NB is an upper bound on the blocksize returned\n*          by ILAENV for the routines CGEQP3, CTZRZF, CTZRQF, CUNMQR,\n*          and CUNMRZ.\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*  RWORK   (workspace) REAL array, dimension (2*N)\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*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*    E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n*    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rank, work, info, a, b, jpvt = NumRu::Lapack.cgelsy( a, b, jpvt, rcond, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  rblapack_jpvt = argv[2];
  rblapack_rcond = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } 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 (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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_jpvt))
    rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
  if (NA_RANK(rblapack_jpvt) != 1)
    rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_jpvt) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_jpvt) != NA_LINT)
    rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
  jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
  m = lda;
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th 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_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (rblapack_lwork == Qnil)
    lwork = MAX(MIN(m,n)+3*n+1, 2*MIN(m,n)+nrhs);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  rcond = (real)NUM2DBL(rblapack_rcond);
  ldb = MAX(m,n);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = MAX(m, n);
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  {
    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__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
  MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
  rblapack_jpvt = rblapack_jpvt_out__;
  jpvt = jpvt_out__;
  rwork = ALLOC_N(real, (2*n));

  cgelsy_(&m, &n, &nrhs, a, &lda, b, &ldb, jpvt, &rcond, &rank, work, &lwork, rwork, &info);

  free(rwork);
  rblapack_rank = INT2NUM(rank);
  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(6, rblapack_rank, rblapack_work, rblapack_info, rblapack_a, rblapack_b, rblapack_jpvt);
}

void
init_lapack_cgelsy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgelsy", rblapack_cgelsy, -1);
}
ruby-lapack-1.7.2/ext/zhetrs2.c0000644000175000017500000001232312502221025016124 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhetrs2_(char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* b, integer* ldb, real* work, integer* info);


static VALUE
rblapack_zhetrs2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  real *work;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.zhetrs2( uplo, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,  WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHETRS2 solves a system of linear equations A*X = B with a real\n*  Hermitian matrix A using the factorization A = U*D*U**T or\n*  A = L*D*L**T computed by ZSYTRF and converted by ZSYCONV.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**H;\n*          = 'L':  Lower triangular, form is A = L*D*L**H.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input) DOUBLE COMPLEX array, dimension (LDA,N)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by ZHETRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by ZHETRF.\n*\n*  B       (input/output) DOUBLE COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  WORK    (workspace) REAL array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.zhetrs2( uplo, a, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(real, (n));

  zhetrs2_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_zhetrs2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhetrs2", rblapack_zhetrs2, -1);
}
ruby-lapack-1.7.2/ext/dsbgvx.c0000644000175000017500000003161112502221016016021 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsbgvx_(char* jobz, char* range, char* uplo, integer* n, integer* ka, integer* kb, doublereal* ab, integer* ldab, doublereal* bb, integer* ldbb, doublereal* q, integer* ldq, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublereal* z, integer* ldz, doublereal* work, integer* iwork, integer* ifail, integer* info);


static VALUE
rblapack_dsbgvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ka;
  integer ka; 
  VALUE rblapack_kb;
  integer kb; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_bb;
  doublereal *bb; 
  VALUE rblapack_vl;
  doublereal vl; 
  VALUE rblapack_vu;
  doublereal vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  doublereal abstol; 
  VALUE rblapack_q;
  doublereal *q; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_ifail;
  integer *ifail; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublereal *ab_out__;
  VALUE rblapack_bb_out__;
  doublereal *bb_out__;

  integer ldab;
  integer n;
  integer ldbb;
  integer ldq;
  integer ldz;

  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  q, m, w, z, work, iwork, ifail, info, ab, bb = NumRu::Lapack.dsbgvx( jobz, range, uplo, ka, kb, ab, bb, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSBGVX computes selected eigenvalues, and optionally, eigenvectors\n*  of a real generalized symmetric-definite banded eigenproblem, of\n*  the form A*x=(lambda)*B*x.  Here A and B are assumed to be symmetric\n*  and banded, and B is also positive definite.  Eigenvalues and\n*  eigenvectors can be selected by specifying either all eigenvalues,\n*  a range of values or a range of indices for the desired eigenvalues.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found.\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found.\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  KA      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KA >= 0.\n*\n*  KB      (input) INTEGER\n*          The number of superdiagonals of the matrix B if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KB >= 0.\n*\n*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB, N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first ka+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).\n*\n*          On exit, the contents of AB are destroyed.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KA+1.\n*\n*  BB      (input/output) DOUBLE PRECISION array, dimension (LDBB, N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix B, stored in the first kb+1 rows of the array.  The\n*          j-th column of B is stored in the j-th column of the array BB\n*          as follows:\n*          if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n*          if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb).\n*\n*          On exit, the factor S from the split Cholesky factorization\n*          B = S**T*S, as returned by DPBSTF.\n*\n*  LDBB    (input) INTEGER\n*          The leading dimension of the array BB.  LDBB >= KB+1.\n*\n*  Q       (output) DOUBLE PRECISION array, dimension (LDQ, N)\n*          If JOBZ = 'V', the n-by-n matrix used in the reduction of\n*          A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x,\n*          and consequently C to tridiagonal form.\n*          If JOBZ = 'N', the array Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.  If JOBZ = 'N',\n*          LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N).\n*\n*  VL      (input) DOUBLE PRECISION\n*  VU      (input) DOUBLE PRECISION\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) DOUBLE PRECISION\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less than\n*          or equal to zero, then  EPS*|T|  will be used in its place,\n*          where |T| is the 1-norm of the tridiagonal matrix obtained\n*          by reducing A to tridiagonal form.\n*\n*          Eigenvalues will be computed most accurately when ABSTOL is\n*          set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n*          If this routine returns with INFO>0, indicating that some\n*          eigenvectors did not converge, try setting ABSTOL to\n*          2*DLAMCH('S').\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n*          eigenvectors, with the i-th column of Z holding the\n*          eigenvector associated with W(i).  The eigenvectors are\n*          normalized so Z**T*B*Z = I.\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (7*N)\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (5*N)\n*\n*  IFAIL   (output) INTEGER array, dimension (M)\n*          If JOBZ = 'V', then if INFO = 0, the first M elements of\n*          IFAIL are zero.  If INFO > 0, then IFAIL contains the\n*          indices of the eigenvalues that failed to converge.\n*          If JOBZ = 'N', then IFAIL is not referenced.\n*\n*  INFO    (output) INTEGER\n*          = 0 : successful exit\n*          < 0 : if INFO = -i, the i-th argument had an illegal value\n*          <= N: if INFO = i, then i eigenvectors failed to converge.\n*                  Their indices are stored in IFAIL.\n*          > N : DPBSTF returned an error code; i.e.,\n*                if INFO = N + i, for 1 <= i <= N, then the leading\n*                minor of order i of B is not positive definite.\n*                The factorization of B could not be completed and\n*                no eigenvalues or eigenvectors were computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  q, m, w, z, work, iwork, ifail, info, ab, bb = NumRu::Lapack.dsbgvx( jobz, range, uplo, ka, kb, ab, bb, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_uplo = argv[2];
  rblapack_ka = argv[3];
  rblapack_kb = argv[4];
  rblapack_ab = argv[5];
  rblapack_bb = argv[6];
  rblapack_vl = argv[7];
  rblapack_vu = argv[8];
  rblapack_il = argv[9];
  rblapack_iu = argv[10];
  rblapack_abstol = argv[11];
  if (argc == 12) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  kb = NUM2INT(rblapack_kb);
  if (!NA_IsNArray(rblapack_bb))
    rb_raise(rb_eArgError, "bb (7th argument) must be NArray");
  if (NA_RANK(rblapack_bb) != 2)
    rb_raise(rb_eArgError, "rank of bb (7th argument) must be %d", 2);
  ldbb = NA_SHAPE0(rblapack_bb);
  n = NA_SHAPE1(rblapack_bb);
  if (NA_TYPE(rblapack_bb) != NA_DFLOAT)
    rblapack_bb = na_change_type(rblapack_bb, NA_DFLOAT);
  bb = NA_PTR_TYPE(rblapack_bb, doublereal*);
  vu = NUM2DBL(rblapack_vu);
  iu = NUM2INT(rblapack_iu);
  range = StringValueCStr(rblapack_range)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (6th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (6th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of bb");
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  il = NUM2INT(rblapack_il);
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  ldq = 1 ? jobz = 'n' : MAX(1,n) ? jobz = 'v' : 0;
  ka = NUM2INT(rblapack_ka);
  abstol = NUM2DBL(rblapack_abstol);
  vl = NUM2DBL(rblapack_vl);
  m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  q = NA_PTR_TYPE(rblapack_q, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 7*n;
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 5*n;
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
  MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldbb;
    shape[1] = n;
    rblapack_bb_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  bb_out__ = NA_PTR_TYPE(rblapack_bb_out__, doublereal*);
  MEMCPY(bb_out__, bb, doublereal, NA_TOTAL(rblapack_bb));
  rblapack_bb = rblapack_bb_out__;
  bb = bb_out__;

  dsbgvx_(&jobz, &range, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, q, &ldq, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, iwork, ifail, &info);

  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(10, rblapack_q, rblapack_m, rblapack_w, rblapack_z, rblapack_work, rblapack_iwork, rblapack_ifail, rblapack_info, rblapack_ab, rblapack_bb);
}

void
init_lapack_dsbgvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsbgvx", rblapack_dsbgvx, -1);
}
ruby-lapack-1.7.2/ext/cpprfs.c0000644000175000017500000001731012502221021016015 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cpprfs_(char* uplo, integer* n, integer* nrhs, complex* ap, complex* afp, complex* b, integer* ldb, complex* x, integer* ldx, real* ferr, real* berr, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cpprfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_afp;
  complex *afp; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  complex *x_out__;
  complex *work;
  real *rwork;

  integer ldb;
  integer nrhs;
  integer ldx;
  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  ferr, berr, info, x = NumRu::Lapack.cpprfs( uplo, ap, afp, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPPRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is Hermitian positive definite\n*  and packed, and provides error bounds and backward error estimates\n*  for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)\n*          The upper or lower triangle of the Hermitian matrix A, packed\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  AFP     (input) COMPLEX array, dimension (N*(N+1)/2)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**H*U or A = L*L**H, as computed by SPPTRF/CPPTRF,\n*          packed columnwise in a linear array in the same format as A\n*          (see AP).\n*\n*  B       (input) COMPLEX array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) COMPLEX array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by CPPTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  ====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.cpprfs( uplo, ap, afp, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_afp = argv[2];
  rblapack_b = argv[3];
  rblapack_x = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  n = ldb;
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (5th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  if (!NA_IsNArray(rblapack_afp))
    rb_raise(rb_eArgError, "afp (3th argument) must be NArray");
  if (NA_RANK(rblapack_afp) != 1)
    rb_raise(rb_eArgError, "rank of afp (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_afp) != NA_SCOMPLEX)
    rblapack_afp = na_change_type(rblapack_afp, NA_SCOMPLEX);
  afp = NA_PTR_TYPE(rblapack_afp, complex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (n));

  cpprfs_(&uplo, &n, &nrhs, ap, afp, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_cpprfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cpprfs", rblapack_cpprfs, -1);
}
ruby-lapack-1.7.2/ext/sgesdd.c0000644000175000017500000002323112502221014015772 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgesdd_(char* jobz, integer* m, integer* n, real* a, integer* lda, real* s, real* u, integer* ldu, real* vt, integer* ldvt, real* work, integer* lwork, integer* iwork, integer* info);


static VALUE
rblapack_sgesdd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_u;
  real *u; 
  VALUE rblapack_vt;
  real *vt; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  integer *iwork;

  integer lda;
  integer n;
  integer ldu;
  integer ucol;
  integer ldvt;
  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  s, u, vt, work, info, a = NumRu::Lapack.sgesdd( jobz, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGESDD computes the singular value decomposition (SVD) of a real\n*  M-by-N matrix A, optionally computing the left and right singular\n*  vectors.  If singular vectors are desired, it uses a\n*  divide-and-conquer algorithm.\n*\n*  The SVD is written\n*\n*       A = U * SIGMA * transpose(V)\n*\n*  where SIGMA is an M-by-N matrix which is zero except for its\n*  min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and\n*  V is an N-by-N orthogonal matrix.  The diagonal elements of SIGMA\n*  are the singular values of A; they are real and non-negative, and\n*  are returned in descending order.  The first min(m,n) columns of\n*  U and V are the left and right singular vectors of A.\n*\n*  Note that the routine returns VT = V**T, not V.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          Specifies options for computing all or part of the matrix U:\n*          = 'A':  all M columns of U and all N rows of V**T are\n*                  returned in the arrays U and VT;\n*          = 'S':  the first min(M,N) columns of U and the first\n*                  min(M,N) rows of V**T are returned in the arrays U\n*                  and VT;\n*          = 'O':  If M >= N, the first N columns of U are overwritten\n*                  on the array A and all rows of V**T are returned in\n*                  the array VT;\n*                  otherwise, all columns of U are returned in the\n*                  array U and the first M rows of V**T are overwritten\n*                  in the array A;\n*          = 'N':  no columns of U or rows of V**T are computed.\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.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit,\n*          if JOBZ = 'O',  A is overwritten with the first N columns\n*                          of U (the left singular vectors, stored\n*                          columnwise) if M >= N;\n*                          A is overwritten with the first M rows\n*                          of V**T (the right singular vectors, stored\n*                          rowwise) otherwise.\n*          if JOBZ .ne. 'O', the contents of A are destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  S       (output) REAL array, dimension (min(M,N))\n*          The singular values of A, sorted so that S(i) >= S(i+1).\n*\n*  U       (output) REAL array, dimension (LDU,UCOL)\n*          UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;\n*          UCOL = min(M,N) if JOBZ = 'S'.\n*          If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M\n*          orthogonal matrix U;\n*          if JOBZ = 'S', U contains the first min(M,N) columns of U\n*          (the left singular vectors, stored columnwise);\n*          if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.\n*\n*  LDU     (input) INTEGER\n*          The leading dimension of the array U.  LDU >= 1; if\n*          JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.\n*\n*  VT      (output) REAL array, dimension (LDVT,N)\n*          If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the\n*          N-by-N orthogonal matrix V**T;\n*          if JOBZ = 'S', VT contains the first min(M,N) rows of\n*          V**T (the right singular vectors, stored rowwise);\n*          if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.\n*\n*  LDVT    (input) INTEGER\n*          The leading dimension of the array VT.  LDVT >= 1; if\n*          JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;\n*          if JOBZ = 'S', LDVT >= min(M,N).\n*\n*  WORK    (workspace/output) REAL 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 >= 1.\n*          If JOBZ = 'N',\n*            LWORK >= 3*min(M,N) + max(max(M,N),6*min(M,N)).\n*          If JOBZ = 'O',\n*            LWORK >= 3*min(M,N) + \n*                     max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)).\n*          If JOBZ = 'S' or 'A'\n*            LWORK >= 3*min(M,N) +\n*                     max(max(M,N),4*min(M,N)*min(M,N)+4*min(M,N)).\n*          For good performance, LWORK should generally be larger.\n*          If LWORK = -1 but other input arguments are legal, WORK(1)\n*          returns the optimal LWORK.\n*\n*  IWORK   (workspace) INTEGER array, dimension (8*min(M,N))\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit.\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          > 0:  SBDSDC did not converge, updating process failed.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, u, vt, work, info, a = NumRu::Lapack.sgesdd( jobz, 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_jobz = 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;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  m = lda;
  ldvt = ((lsame_(&jobz,"A")) || (((lsame_(&jobz,"O")) && (m >= n)))) ? n : lsame_(&jobz,"S") ? MIN(m,n) : 1;
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&jobz,"N") ? 3*MIN(m,n)+MAX(MAX(m,n),7*MIN(m,n)) : lsame_(&jobz,"O") ? 3*MIN(m,n)+MAX(MAX(m,n),5*MIN(m,n)*MIN(m,n)+4*MIN(m,n)) : (lsame_(&jobz,"S")||lsame_(&jobz,"A")) ? 3*MIN(m,n)+MAX(MAX(m,n),4*MIN(m,n)*MIN(m,n)+4*MIN(m,n)) : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldu = (lsame_(&jobz,"S") || lsame_(&jobz,"A") || (lsame_(&jobz,"O") && m < n)) ? m : 1;
  ucol = ((lsame_(&jobz,"A")) || (((lsame_(&jobz,"O")) && (m < n)))) ? m : lsame_(&jobz,"S") ? MIN(m,n) : 0;
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = ucol;
    rblapack_u = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  u = NA_PTR_TYPE(rblapack_u, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldvt;
    shape[1] = n;
    rblapack_vt = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vt = NA_PTR_TYPE(rblapack_vt, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  iwork = ALLOC_N(integer, (8*MIN(m,n)));

  sgesdd_(&jobz, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, iwork, &info);

  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_s, rblapack_u, rblapack_vt, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_sgesdd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgesdd", rblapack_sgesdd, -1);
}
ruby-lapack-1.7.2/ext/zpptri.c0000644000175000017500000000740412502221026016060 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zpptri_(char* uplo, integer* n, doublecomplex* ap, integer* info);


static VALUE
rblapack_zpptri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublecomplex *ap_out__;


  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  info, ap = NumRu::Lapack.zpptri( uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPPTRI( UPLO, N, AP, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPPTRI computes the inverse of a complex Hermitian positive definite\n*  matrix A using the Cholesky factorization A = U**H*U or A = L*L**H\n*  computed by ZPPTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangular factor is stored in AP;\n*          = 'L':  Lower triangular factor is stored in AP.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          On entry, the triangular factor U or L from the Cholesky\n*          factorization A = U**H*U or A = L*L**H, packed columnwise as\n*          a linear array.  The j-th column of U or L is stored in the\n*          array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n*          On exit, the upper or lower triangle of the (Hermitian)\n*          inverse of A, overwriting the input factor U or L.\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,i) element of the factor U or L is\n*                zero, and the inverse could not be computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ap = NumRu::Lapack.zpptri( uplo, n, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_n = argv[1];
  rblapack_ap = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
  MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  zpptri_(&uplo, &n, ap, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ap);
}

void
init_lapack_zpptri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zpptri", rblapack_zpptri, -1);
}
ruby-lapack-1.7.2/ext/dgges.c0000644000175000017500000003346612502221012015623 0ustar  uwabamiuwabami#include "rb_lapack.h"

static logical
rblapack_selctg(doublereal *arg0, doublereal *arg1, doublereal *arg2){
  VALUE rblapack_arg0, rblapack_arg1, rblapack_arg2;

  VALUE rblapack_ret;
  logical ret;

  rblapack_arg0 = rb_float_new((double)(*arg0));
  rblapack_arg1 = rb_float_new((double)(*arg1));
  rblapack_arg2 = rb_float_new((double)(*arg2));

  rblapack_ret = rb_yield_values(3, rblapack_arg0, rblapack_arg1, rblapack_arg2);

  ret = (rblapack_ret == Qtrue);
  return ret;
}

extern VOID dgges_(char* jobvsl, char* jobvsr, char* sort, L_fp selctg, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, integer* sdim, doublereal* alphar, doublereal* alphai, doublereal* beta, doublereal* vsl, integer* ldvsl, doublereal* vsr, integer* ldvsr, doublereal* work, integer* lwork, logical* bwork, integer* info);


static VALUE
rblapack_dgges(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvsl;
  char jobvsl; 
  VALUE rblapack_jobvsr;
  char jobvsr; 
  VALUE rblapack_sort;
  char sort; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_sdim;
  integer sdim; 
  VALUE rblapack_alphar;
  doublereal *alphar; 
  VALUE rblapack_alphai;
  doublereal *alphai; 
  VALUE rblapack_beta;
  doublereal *beta; 
  VALUE rblapack_vsl;
  doublereal *vsl; 
  VALUE rblapack_vsr;
  doublereal *vsr; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;
  logical *bwork;

  integer lda;
  integer n;
  integer ldb;
  integer ldvsl;
  integer ldvsr;

  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  sdim, alphar, alphai, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.dgges( jobvsl, jobvsr, sort, a, b, [:lwork => lwork, :usage => usage, :help => help]){|a,b,c| ... }\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, BWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGGES computes for a pair of N-by-N real nonsymmetric matrices (A,B),\n*  the generalized eigenvalues, the generalized real Schur form (S,T),\n*  optionally, the left and/or right matrices of Schur vectors (VSL and\n*  VSR). This gives the generalized Schur factorization\n*\n*           (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T )\n*\n*  Optionally, it also orders the eigenvalues so that a selected cluster\n*  of eigenvalues appears in the leading diagonal blocks of the upper\n*  quasi-triangular matrix S and the upper triangular matrix T.The\n*  leading columns of VSL and VSR then form an orthonormal basis for the\n*  corresponding left and right eigenspaces (deflating subspaces).\n*\n*  (If only the generalized eigenvalues are needed, use the driver\n*  DGGEV instead, which is faster.)\n*\n*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n*  or a ratio alpha/beta = w, such that  A - w*B is singular.  It is\n*  usually represented as the pair (alpha,beta), as there is a\n*  reasonable interpretation for beta=0 or both being zero.\n*\n*  A pair of matrices (S,T) is in generalized real Schur form if T is\n*  upper triangular with non-negative diagonal and S is block upper\n*  triangular with 1-by-1 and 2-by-2 blocks.  1-by-1 blocks correspond\n*  to real generalized eigenvalues, while 2-by-2 blocks of S will be\n*  \"standardized\" by making the corresponding elements of T have the\n*  form:\n*          [  a  0  ]\n*          [  0  b  ]\n*\n*  and the pair of corresponding 2-by-2 blocks in S and T will have a\n*  complex conjugate pair of generalized eigenvalues.\n*\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVSL  (input) CHARACTER*1\n*          = 'N':  do not compute the left Schur vectors;\n*          = 'V':  compute the left Schur vectors.\n*\n*  JOBVSR  (input) CHARACTER*1\n*          = 'N':  do not compute the right Schur vectors;\n*          = 'V':  compute the right Schur vectors.\n*\n*  SORT    (input) CHARACTER*1\n*          Specifies whether or not to order the eigenvalues on the\n*          diagonal of the generalized Schur form.\n*          = 'N':  Eigenvalues are not ordered;\n*          = 'S':  Eigenvalues are ordered (see SELCTG);\n*\n*  SELCTG  (external procedure) LOGICAL FUNCTION of three DOUBLE PRECISION arguments\n*          SELCTG must be declared EXTERNAL in the calling subroutine.\n*          If SORT = 'N', SELCTG is not referenced.\n*          If SORT = 'S', SELCTG is used to select eigenvalues to sort\n*          to the top left of the Schur form.\n*          An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if\n*          SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either\n*          one of a complex conjugate pair of eigenvalues is selected,\n*          then both complex eigenvalues are selected.\n*\n*          Note that in the ill-conditioned case, a selected complex\n*          eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j),\n*          BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2\n*          in this case.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A, B, VSL, and VSR.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n*          On entry, the first of the pair of matrices.\n*          On exit, A has been overwritten by its generalized Schur\n*          form S.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of A.  LDA >= max(1,N).\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n*          On entry, the second of the pair of matrices.\n*          On exit, B has been overwritten by its generalized Schur\n*          form T.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of B.  LDB >= max(1,N).\n*\n*  SDIM    (output) INTEGER\n*          If SORT = 'N', SDIM = 0.\n*          If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n*          for which SELCTG is true.  (Complex conjugate pairs for which\n*          SELCTG is true for either eigenvalue count as 2.)\n*\n*  ALPHAR  (output) DOUBLE PRECISION array, dimension (N)\n*  ALPHAI  (output) DOUBLE PRECISION array, dimension (N)\n*  BETA    (output) DOUBLE PRECISION array, dimension (N)\n*          On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n*          be the generalized eigenvalues.  ALPHAR(j) + ALPHAI(j)*i,\n*          and  BETA(j),j=1,...,N are the diagonals of the complex Schur\n*          form (S,T) that would result if the 2-by-2 diagonal blocks of\n*          the real Schur form of (A,B) were further reduced to\n*          triangular form using 2-by-2 complex unitary transformations.\n*          If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n*          positive, then the j-th and (j+1)-st eigenvalues are a\n*          complex conjugate pair, with ALPHAI(j+1) negative.\n*\n*          Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n*          may easily over- or underflow, and BETA(j) may even be zero.\n*          Thus, the user should avoid naively computing the ratio.\n*          However, ALPHAR and ALPHAI will be always less than and\n*          usually comparable with norm(A) in magnitude, and BETA always\n*          less than and usually comparable with norm(B).\n*\n*  VSL     (output) DOUBLE PRECISION array, dimension (LDVSL,N)\n*          If JOBVSL = 'V', VSL will contain the left Schur vectors.\n*          Not referenced if JOBVSL = 'N'.\n*\n*  LDVSL   (input) INTEGER\n*          The leading dimension of the matrix VSL. LDVSL >=1, and\n*          if JOBVSL = 'V', LDVSL >= N.\n*\n*  VSR     (output) DOUBLE PRECISION array, dimension (LDVSR,N)\n*          If JOBVSR = 'V', VSR will contain the right Schur vectors.\n*          Not referenced if JOBVSR = 'N'.\n*\n*  LDVSR   (input) INTEGER\n*          The leading dimension of the matrix VSR. LDVSR >= 1, and\n*          if JOBVSR = 'V', LDVSR >= 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*          If N = 0, LWORK >= 1, else LWORK >= 8*N+16.\n*          For good performance , LWORK must generally be larger.\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*  BWORK   (workspace) LOGICAL array, dimension (N)\n*          Not referenced if SORT = 'N'.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          = 1,...,N:\n*                The QZ iteration failed.  (A,B) are not in Schur\n*                form, but ALPHAR(j), ALPHAI(j), and BETA(j) should\n*                be correct for j=INFO+1,...,N.\n*          > N:  =N+1: other than QZ iteration failed in DHGEQZ.\n*                =N+2: after reordering, roundoff changed values of\n*                      some complex eigenvalues so that leading\n*                      eigenvalues in the Generalized Schur form no\n*                      longer satisfy SELCTG=.TRUE.  This could also\n*                      be caused due to scaling.\n*                =N+3: reordering failed in DTGSEN.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sdim, alphar, alphai, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.dgges( jobvsl, jobvsr, sort, a, b, [:lwork => lwork, :usage => usage, :help => help]){|a,b,c| ... }\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_jobvsl = argv[0];
  rblapack_jobvsr = argv[1];
  rblapack_sort = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  if (argc == 6) {
    rblapack_lwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  jobvsl = StringValueCStr(rblapack_jobvsl)[0];
  sort = StringValueCStr(rblapack_sort)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = 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*);
  jobvsr = StringValueCStr(rblapack_jobvsr)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  ldvsl = lsame_(&jobvsl,"V") ? n : 1;
  if (rblapack_lwork == Qnil)
    lwork = MAX(8*n,6*n+16);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldvsr = lsame_(&jobvsr,"V") ? n : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  alphar = NA_PTR_TYPE(rblapack_alphar, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  alphai = NA_PTR_TYPE(rblapack_alphai, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldvsl;
    shape[1] = n;
    rblapack_vsl = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vsl = NA_PTR_TYPE(rblapack_vsl, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldvsr;
    shape[1] = n;
    rblapack_vsr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vsr = NA_PTR_TYPE(rblapack_vsr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));

  dgges_(&jobvsl, &jobvsr, &sort, rblapack_selctg, &n, a, &lda, b, &ldb, &sdim, alphar, alphai, beta, vsl, &ldvsl, vsr, &ldvsr, work, &lwork, bwork, &info);

  free(bwork);
  rblapack_sdim = INT2NUM(sdim);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(10, rblapack_sdim, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_vsl, rblapack_vsr, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_dgges(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgges", rblapack_dgges, -1);
}
ruby-lapack-1.7.2/ext/dlacpy.c0000644000175000017500000000713712502221025016006 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlacpy_(char* uplo, integer* m, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb);


static VALUE
rblapack_dlacpy(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 

  integer lda;
  integer n;
  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  b = NumRu::Lapack.dlacpy( uplo, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB )\n\n*  Purpose\n*  =======\n*\n*  DLACPY copies all or part of a two-dimensional matrix A to another\n*  matrix B.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies the part of the matrix A to be copied to B.\n*          = 'U':      Upper triangular part\n*          = 'L':      Lower triangular part\n*          Otherwise:  All of the matrix A\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) DOUBLE PRECISION array, dimension (LDA,N)\n*          The m by n matrix A.  If UPLO = 'U', only the upper triangle\n*          or trapezoid is accessed; if UPLO = 'L', only the lower\n*          triangle or trapezoid is accessed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  B       (output) DOUBLE PRECISION array, dimension (LDB,N)\n*          On exit, B = A in the locations specified by UPLO.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,M).\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  b = NumRu::Lapack.dlacpy( uplo, m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_m = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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);
  ldb = MAX(1,m);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b = NA_PTR_TYPE(rblapack_b, doublereal*);

  dlacpy_(&uplo, &m, &n, a, &lda, b, &ldb);

  return rblapack_b;
}

void
init_lapack_dlacpy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlacpy", rblapack_dlacpy, -1);
}
ruby-lapack-1.7.2/ext/dgeqp3.c0000644000175000017500000001534712502221024015716 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgeqp3_(integer* m, integer* n, doublereal* a, integer* lda, integer* jpvt, doublereal* tau, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dgeqp3(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_jpvt;
  integer *jpvt; 
  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__;
  VALUE rblapack_jpvt_out__;
  integer *jpvt_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, jpvt = NumRu::Lapack.dgeqp3( m, a, jpvt, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGEQP3 computes a QR factorization with column pivoting of a\n*  matrix A:  A*P = Q*R  using Level 3 BLAS.\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 upper triangle of the array contains the\n*          min(M,N)-by-N upper trapezoidal matrix R; the elements below\n*          the diagonal, together with the array TAU, represent the\n*          orthogonal matrix Q as a product of min(M,N) elementary\n*          reflectors.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  JPVT    (input/output) INTEGER array, dimension (N)\n*          On entry, if JPVT(J).ne.0, the J-th column of A is permuted\n*          to the front of A*P (a leading column); if JPVT(J)=0,\n*          the J-th column of A is a free column.\n*          On exit, if JPVT(J)=K, then the J-th column of A*P was the\n*          the K-th column of A.\n*\n*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors.\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 >= 3*N+1.\n*          For optimal performance LWORK >= 2*N+( N+1 )*NB, where NB\n*          is the 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(1) H(2) . . . H(k), 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/complex scalar, and v is a real/complex vector\n*  with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in\n*  A(i+1:m,i), and tau in TAU(i).\n*\n*  Based on contributions by\n*    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n*    X. Sun, Computer Science Dept., Duke University, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, work, info, a, jpvt = NumRu::Lapack.dgeqp3( m, a, jpvt, [: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_m = argv[0];
  rblapack_a = argv[1];
  rblapack_jpvt = 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;
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_jpvt))
    rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
  if (NA_RANK(rblapack_jpvt) != 1)
    rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_jpvt);
  if (NA_TYPE(rblapack_jpvt) != NA_LINT)
    rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
  jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of jpvt");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  if (rblapack_lwork == Qnil)
    lwork = 3*n+1;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
  MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
  rblapack_jpvt = rblapack_jpvt_out__;
  jpvt = jpvt_out__;

  dgeqp3_(&m, &n, a, &lda, jpvt, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_tau, rblapack_work, rblapack_info, rblapack_a, rblapack_jpvt);
}

void
init_lapack_dgeqp3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgeqp3", rblapack_dgeqp3, -1);
}
ruby-lapack-1.7.2/ext/zlaed8.c0000644000175000017500000002673712502221014015726 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlaed8_(integer* k, integer* n, integer* qsiz, doublecomplex* q, integer* ldq, doublereal* d, doublereal* rho, integer* cutpnt, doublereal* z, doublereal* dlamda, doublecomplex* q2, integer* ldq2, doublereal* w, integer* indxp, integer* indx, integer* indxq, integer* perm, integer* givptr, integer* givcol, doublereal* givnum, integer* info);


static VALUE
rblapack_zlaed8(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_qsiz;
  integer qsiz; 
  VALUE rblapack_q;
  doublecomplex *q; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_rho;
  doublereal rho; 
  VALUE rblapack_cutpnt;
  integer cutpnt; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_indxq;
  integer *indxq; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_dlamda;
  doublereal *dlamda; 
  VALUE rblapack_q2;
  doublecomplex *q2; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_perm;
  integer *perm; 
  VALUE rblapack_givptr;
  integer givptr; 
  VALUE rblapack_givcol;
  integer *givcol; 
  VALUE rblapack_givnum;
  doublereal *givnum; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_q_out__;
  doublecomplex *q_out__;
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  integer *indxp;
  integer *indx;

  integer ldq;
  integer n;
  integer ldq2;

  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  k, dlamda, q2, w, perm, givptr, givcol, givnum, info, q, d, rho = NumRu::Lapack.zlaed8( qsiz, q, d, rho, cutpnt, z, indxq, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA, Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR, GIVCOL, GIVNUM, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZLAED8 merges the two sets of eigenvalues together into a single\n*  sorted set.  Then it tries to deflate the size of the problem.\n*  There are two ways in which deflation can occur:  when two or more\n*  eigenvalues are close together or if there is a tiny element in the\n*  Z vector.  For each such occurrence the order of the related secular\n*  equation problem is reduced by one.\n*\n\n*  Arguments\n*  =========\n*\n*  K      (output) INTEGER\n*         Contains the number of non-deflated eigenvalues.\n*         This is the order of the related secular equation.\n*\n*  N      (input) INTEGER\n*         The dimension of the symmetric tridiagonal matrix.  N >= 0.\n*\n*  QSIZ   (input) INTEGER\n*         The dimension of the unitary matrix used to reduce\n*         the dense or band matrix to tridiagonal form.\n*         QSIZ >= N if ICOMPQ = 1.\n*\n*  Q      (input/output) COMPLEX*16 array, dimension (LDQ,N)\n*         On entry, Q contains the eigenvectors of the partially solved\n*         system which has been previously updated in matrix\n*         multiplies with other partially solved eigensystems.\n*         On exit, Q contains the trailing (N-K) updated eigenvectors\n*         (those which were deflated) in its last N-K columns.\n*\n*  LDQ    (input) INTEGER\n*         The leading dimension of the array Q.  LDQ >= max( 1, N ).\n*\n*  D      (input/output) DOUBLE PRECISION array, dimension (N)\n*         On entry, D contains the eigenvalues of the two submatrices to\n*         be combined.  On exit, D contains the trailing (N-K) updated\n*         eigenvalues (those which were deflated) sorted into increasing\n*         order.\n*\n*  RHO    (input/output) DOUBLE PRECISION\n*         Contains the off diagonal element associated with the rank-1\n*         cut which originally split the two submatrices which are now\n*         being recombined. RHO is modified during the computation to\n*         the value required by DLAED3.\n*\n*  CUTPNT (input) INTEGER\n*         Contains the location of the last eigenvalue in the leading\n*         sub-matrix.  MIN(1,N) <= CUTPNT <= N.\n*\n*  Z      (input) DOUBLE PRECISION array, dimension (N)\n*         On input this vector contains the updating vector (the last\n*         row of the first sub-eigenvector matrix and the first row of\n*         the second sub-eigenvector matrix).  The contents of Z are\n*         destroyed during the updating process.\n*\n*  DLAMDA (output) DOUBLE PRECISION array, dimension (N)\n*         Contains a copy of the first K eigenvalues which will be used\n*         by DLAED3 to form the secular equation.\n*\n*  Q2     (output) COMPLEX*16 array, dimension (LDQ2,N)\n*         If ICOMPQ = 0, Q2 is not referenced.  Otherwise,\n*         Contains a copy of the first K eigenvectors which will be used\n*         by DLAED7 in a matrix multiply (DGEMM) to update the new\n*         eigenvectors.\n*\n*  LDQ2   (input) INTEGER\n*         The leading dimension of the array Q2.  LDQ2 >= max( 1, N ).\n*\n*  W      (output) DOUBLE PRECISION array, dimension (N)\n*         This will hold the first k values of the final\n*         deflation-altered z-vector and will be passed to DLAED3.\n*\n*  INDXP  (workspace) INTEGER array, dimension (N)\n*         This will contain the permutation used to place deflated\n*         values of D at the end of the array. On output INDXP(1:K)\n*         points to the nondeflated D-values and INDXP(K+1:N)\n*         points to the deflated eigenvalues.\n*\n*  INDX   (workspace) INTEGER array, dimension (N)\n*         This will contain the permutation used to sort the contents of\n*         D into ascending order.\n*\n*  INDXQ  (input) INTEGER array, dimension (N)\n*         This contains the permutation which separately sorts the two\n*         sub-problems in D into ascending order.  Note that elements in\n*         the second half of this permutation must first have CUTPNT\n*         added to their values in order to be accurate.\n*\n*  PERM   (output) INTEGER array, dimension (N)\n*         Contains the permutations (from deflation and sorting) to be\n*         applied to each eigenblock.\n*\n*  GIVPTR (output) INTEGER\n*         Contains the number of Givens rotations which took place in\n*         this subproblem.\n*\n*  GIVCOL (output) INTEGER array, dimension (2, N)\n*         Each pair of numbers indicates a pair of columns to take place\n*         in a Givens rotation.\n*\n*  GIVNUM (output) DOUBLE PRECISION array, dimension (2, N)\n*         Each number indicates the S value to be used in the\n*         corresponding Givens rotation.\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  k, dlamda, q2, w, perm, givptr, givcol, givnum, info, q, d, rho = NumRu::Lapack.zlaed8( qsiz, q, d, rho, cutpnt, z, indxq, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_qsiz = argv[0];
  rblapack_q = argv[1];
  rblapack_d = argv[2];
  rblapack_rho = argv[3];
  rblapack_cutpnt = argv[4];
  rblapack_z = argv[5];
  rblapack_indxq = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  qsiz = NUM2INT(rblapack_qsiz);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  cutpnt = NUM2INT(rblapack_cutpnt);
  if (!NA_IsNArray(rblapack_indxq))
    rb_raise(rb_eArgError, "indxq (7th argument) must be NArray");
  if (NA_RANK(rblapack_indxq) != 1)
    rb_raise(rb_eArgError, "rank of indxq (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_indxq) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of indxq must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_indxq) != NA_LINT)
    rblapack_indxq = na_change_type(rblapack_indxq, NA_LINT);
  indxq = NA_PTR_TYPE(rblapack_indxq, integer*);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (2th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (2th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_q) != NA_DCOMPLEX)
    rblapack_q = na_change_type(rblapack_q, NA_DCOMPLEX);
  q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (6th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  rho = NUM2DBL(rblapack_rho);
  ldq2 = MAX( 1, n );
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_dlamda = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  dlamda = NA_PTR_TYPE(rblapack_dlamda, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldq2;
    shape[1] = n;
    rblapack_q2 = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  q2 = NA_PTR_TYPE(rblapack_q2, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_perm = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  perm = NA_PTR_TYPE(rblapack_perm, integer*);
  {
    na_shape_t shape[2];
    shape[0] = 2;
    shape[1] = n;
    rblapack_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
  }
  givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
  {
    na_shape_t shape[2];
    shape[0] = 2;
    shape[1] = n;
    rblapack_givnum = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  givnum = NA_PTR_TYPE(rblapack_givnum, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublecomplex*);
  MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  indxp = ALLOC_N(integer, (n));
  indx = ALLOC_N(integer, (n));

  zlaed8_(&k, &n, &qsiz, q, &ldq, d, &rho, &cutpnt, z, dlamda, q2, &ldq2, w, indxp, indx, indxq, perm, &givptr, givcol, givnum, &info);

  free(indxp);
  free(indx);
  rblapack_k = INT2NUM(k);
  rblapack_givptr = INT2NUM(givptr);
  rblapack_info = INT2NUM(info);
  rblapack_rho = rb_float_new((double)rho);
  return rb_ary_new3(12, rblapack_k, rblapack_dlamda, rblapack_q2, rblapack_w, rblapack_perm, rblapack_givptr, rblapack_givcol, rblapack_givnum, rblapack_info, rblapack_q, rblapack_d, rblapack_rho);
}

void
init_lapack_zlaed8(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlaed8", rblapack_zlaed8, -1);
}
ruby-lapack-1.7.2/ext/zlat2c.c0000644000175000017500000001005212502221023015715 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlat2c_(char* uplo, integer* n, doublecomplex* a, integer* lda, complex* sa, integer* ldsa, integer* info);


static VALUE
rblapack_zlat2c(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_sa;
  complex *sa; 
  VALUE rblapack_info;
  integer info; 

  integer lda;
  integer n;
  integer ldsa;

  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  sa, info = NumRu::Lapack.zlat2c( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAT2C( UPLO, N, A, LDA, SA, LDSA, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZLAT2C converts a COMPLEX*16 triangular matrix, SA, to a COMPLEX\n*  triangular matrix, A.\n*\n*  RMAX is the overflow for the SINGLE PRECISION arithmetic\n*  ZLAT2C checks that all the entries of A are between -RMAX and\n*  RMAX. If not the convertion is aborted and a flag is raised.\n*\n*  This is an auxiliary routine so there is no argument checking.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  N       (input) INTEGER\n*          The number of rows and columns of the matrix A.  N >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the N-by-N triangular coefficient matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  SA      (output) COMPLEX array, dimension (LDSA,N)\n*          Only the UPLO part of SA is referenced.  On exit, if INFO=0,\n*          the N-by-N coefficient matrix SA; if INFO>0, the content of\n*          the UPLO part of SA is unspecified.\n*\n*  LDSA    (input) INTEGER\n*          The leading dimension of the array SA.  LDSA >= max(1,M).\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit.\n*          = 1:  an entry of the matrix A is greater than the SINGLE\n*                PRECISION overflow threshold, in this case, the content\n*                of the UPLO part of SA in exit is unspecified.\n*\n*  =========\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n      DOUBLE PRECISION   RMAX\n      LOGICAL            UPPER\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          DBLE, DIMAG\n*     ..\n*     .. External Functions ..\n      REAL               SLAMCH\n      LOGICAL            LSAME\n      EXTERNAL           SLAMCH, LSAME\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sa, info = NumRu::Lapack.zlat2c( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  ldsa = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = ldsa;
    shape[1] = n;
    rblapack_sa = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  sa = NA_PTR_TYPE(rblapack_sa, complex*);

  zlat2c_(&uplo, &n, a, &lda, sa, &ldsa, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_sa, rblapack_info);
}

void
init_lapack_zlat2c(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlat2c", rblapack_zlat2c, -1);
}
ruby-lapack-1.7.2/ext/slatdf.c0000644000175000017500000001773512502221015016013 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slatdf_(integer* ijob, integer* n, real* z, integer* ldz, real* rhs, real* rdsum, real* rdscal, integer* ipiv, integer* jpiv);


static VALUE
rblapack_slatdf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ijob;
  integer ijob; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_rhs;
  real *rhs; 
  VALUE rblapack_rdsum;
  real rdsum; 
  VALUE rblapack_rdscal;
  real rdscal; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_jpiv;
  integer *jpiv; 
  VALUE rblapack_rhs_out__;
  real *rhs_out__;

  integer ldz;
  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  rhs, rdsum, rdscal = NumRu::Lapack.slatdf( ijob, z, rhs, rdsum, rdscal, ipiv, jpiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, JPIV )\n\n*  Purpose\n*  =======\n*\n*  SLATDF uses the LU factorization of the n-by-n matrix Z computed by\n*  SGETC2 and computes a contribution to the reciprocal Dif-estimate\n*  by solving Z * x = b for x, and choosing the r.h.s. b such that\n*  the norm of x is as large as possible. On entry RHS = b holds the\n*  contribution from earlier solved sub-systems, and on return RHS = x.\n*\n*  The factorization of Z returned by SGETC2 has the form Z = P*L*U*Q,\n*  where P and Q are permutation matrices. L is lower triangular with\n*  unit diagonal elements and U is upper triangular.\n*\n\n*  Arguments\n*  =========\n*\n*  IJOB    (input) INTEGER\n*          IJOB = 2: First compute an approximative null-vector e\n*              of Z using SGECON, e is normalized and solve for\n*              Zx = +-e - f with the sign giving the greater value\n*              of 2-norm(x). About 5 times as expensive as Default.\n*          IJOB .ne. 2: Local look ahead strategy where all entries of\n*              the r.h.s. b is choosen as either +1 or -1 (Default).\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Z.\n*\n*  Z       (input) REAL array, dimension (LDZ, N)\n*          On entry, the LU part of the factorization of the n-by-n\n*          matrix Z computed by SGETC2:  Z = P * L * U * Q\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDA >= max(1, N).\n*\n*  RHS     (input/output) REAL array, dimension N.\n*          On entry, RHS contains contributions from other subsystems.\n*          On exit, RHS contains the solution of the subsystem with\n*          entries acoording to the value of IJOB (see above).\n*\n*  RDSUM   (input/output) REAL\n*          On entry, the sum of squares of computed contributions to\n*          the Dif-estimate under computation by STGSYL, where the\n*          scaling factor RDSCAL (see below) has been factored out.\n*          On exit, the corresponding sum of squares updated with the\n*          contributions from the current sub-system.\n*          If TRANS = 'T' RDSUM is not touched.\n*          NOTE: RDSUM only makes sense when STGSY2 is called by STGSYL.\n*\n*  RDSCAL  (input/output) REAL\n*          On entry, scaling factor used to prevent overflow in RDSUM.\n*          On exit, RDSCAL is updated w.r.t. the current contributions\n*          in RDSUM.\n*          If TRANS = 'T', RDSCAL is not touched.\n*          NOTE: RDSCAL only makes sense when STGSY2 is called by\n*                STGSYL.\n*\n*  IPIV    (input) INTEGER array, dimension (N).\n*          The pivot indices; for 1 <= i <= N, row i of the\n*          matrix has been interchanged with row IPIV(i).\n*\n*  JPIV    (input) INTEGER array, dimension (N).\n*          The pivot indices; for 1 <= j <= N, column j of the\n*          matrix has been interchanged with column JPIV(j).\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  This routine is a further developed implementation of algorithm\n*  BSOLVE in [1] using complete pivoting in the LU factorization.\n*\n*  [1] Bo Kagstrom and Lars Westin,\n*      Generalized Schur Methods with Condition Estimators for\n*      Solving the Generalized Sylvester Equation, IEEE Transactions\n*      on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.\n*\n*  [2] Peter Poromaa,\n*      On Efficient and Robust Estimators for the Separation\n*      between two Regular Matrix Pairs with Applications in\n*      Condition Estimation. Report IMINF-95.05, Departement of\n*      Computing Science, Umea University, S-901 87 Umea, Sweden, 1995.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rhs, rdsum, rdscal = NumRu::Lapack.slatdf( ijob, z, rhs, rdsum, rdscal, ipiv, jpiv, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_ijob = argv[0];
  rblapack_z = argv[1];
  rblapack_rhs = argv[2];
  rblapack_rdsum = argv[3];
  rblapack_rdscal = argv[4];
  rblapack_ipiv = argv[5];
  rblapack_jpiv = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  ijob = NUM2INT(rblapack_ijob);
  if (!NA_IsNArray(rblapack_rhs))
    rb_raise(rb_eArgError, "rhs (3th argument) must be NArray");
  if (NA_RANK(rblapack_rhs) != 1)
    rb_raise(rb_eArgError, "rank of rhs (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_rhs);
  if (NA_TYPE(rblapack_rhs) != NA_SFLOAT)
    rblapack_rhs = na_change_type(rblapack_rhs, NA_SFLOAT);
  rhs = NA_PTR_TYPE(rblapack_rhs, real*);
  rdscal = (real)NUM2DBL(rblapack_rdscal);
  if (!NA_IsNArray(rblapack_jpiv))
    rb_raise(rb_eArgError, "jpiv (7th argument) must be NArray");
  if (NA_RANK(rblapack_jpiv) != 1)
    rb_raise(rb_eArgError, "rank of jpiv (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_jpiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of jpiv must be the same as shape 0 of rhs");
  if (NA_TYPE(rblapack_jpiv) != NA_LINT)
    rblapack_jpiv = na_change_type(rblapack_jpiv, NA_LINT);
  jpiv = NA_PTR_TYPE(rblapack_jpiv, integer*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (2th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (2th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  if (NA_SHAPE1(rblapack_z) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 0 of rhs");
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of rhs");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  rdsum = (real)NUM2DBL(rblapack_rdsum);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rhs_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  rhs_out__ = NA_PTR_TYPE(rblapack_rhs_out__, real*);
  MEMCPY(rhs_out__, rhs, real, NA_TOTAL(rblapack_rhs));
  rblapack_rhs = rblapack_rhs_out__;
  rhs = rhs_out__;

  slatdf_(&ijob, &n, z, &ldz, rhs, &rdsum, &rdscal, ipiv, jpiv);

  rblapack_rdsum = rb_float_new((double)rdsum);
  rblapack_rdscal = rb_float_new((double)rdscal);
  return rb_ary_new3(3, rblapack_rhs, rblapack_rdsum, rblapack_rdscal);
}

void
init_lapack_slatdf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slatdf", rblapack_slatdf, -1);
}
ruby-lapack-1.7.2/ext/dlartv.c0000644000175000017500000001333512502221020016016 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlartv_(integer* n, doublereal* x, integer* incx, doublereal* y, integer* incy, doublereal* c, doublereal* s, integer* incc);


static VALUE
rblapack_dlartv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_y;
  doublereal *y; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_incc;
  integer incc; 
  VALUE rblapack_x_out__;
  doublereal *x_out__;
  VALUE rblapack_y_out__;
  doublereal *y_out__;


  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  x, y = NumRu::Lapack.dlartv( n, x, incx, y, incy, c, s, incc, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLARTV( N, X, INCX, Y, INCY, C, S, INCC )\n\n*  Purpose\n*  =======\n*\n*  DLARTV applies a vector of real plane rotations to elements of the\n*  real vectors x and y. For i = 1,2,...,n\n*\n*     ( x(i) ) := (  c(i)  s(i) ) ( x(i) )\n*     ( y(i) )    ( -s(i)  c(i) ) ( y(i) )\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of plane rotations to be applied.\n*\n*  X       (input/output) DOUBLE PRECISION array,\n*                         dimension (1+(N-1)*INCX)\n*          The vector x.\n*\n*  INCX    (input) INTEGER\n*          The increment between elements of X. INCX > 0.\n*\n*  Y       (input/output) DOUBLE PRECISION array,\n*                         dimension (1+(N-1)*INCY)\n*          The vector y.\n*\n*  INCY    (input) INTEGER\n*          The increment between elements of Y. INCY > 0.\n*\n*  C       (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)\n*          The cosines of the plane rotations.\n*\n*  S       (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)\n*          The sines of the plane rotations.\n*\n*  INCC    (input) INTEGER\n*          The increment between elements of C and S. INCC > 0.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, IC, IX, IY\n      DOUBLE PRECISION   XI, YI\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, y = NumRu::Lapack.dlartv( n, x, incx, y, incy, c, s, incc, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_n = argv[0];
  rblapack_x = argv[1];
  rblapack_incx = argv[2];
  rblapack_y = argv[3];
  rblapack_incy = argv[4];
  rblapack_c = argv[5];
  rblapack_s = argv[6];
  rblapack_incc = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  incx = NUM2INT(rblapack_incx);
  incy = NUM2INT(rblapack_incy);
  incc = NUM2INT(rblapack_incc);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1+(n-1)*incx))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != (1+(n-1)*incc))
    rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", 1+(n-1)*incc);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (4th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incy))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
  if (NA_TYPE(rblapack_y) != NA_DFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
  y = NA_PTR_TYPE(rblapack_y, doublereal*);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (7th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != (1+(n-1)*incc))
    rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", 1+(n-1)*incc);
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incx;
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incy;
    rblapack_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
  MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  dlartv_(&n, x, &incx, y, &incy, c, s, &incc);

  return rb_ary_new3(2, rblapack_x, rblapack_y);
}

void
init_lapack_dlartv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlartv", rblapack_dlartv, -1);
}
ruby-lapack-1.7.2/ext/dstein.c0000644000175000017500000002014012502221023016003 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dstein_(integer* n, doublereal* d, doublereal* e, integer* m, doublereal* w, integer* iblock, integer* isplit, doublereal* z, integer* ldz, doublereal* work, integer* iwork, integer* ifail, integer* info);


static VALUE
rblapack_dstein(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_iblock;
  integer *iblock; 
  VALUE rblapack_isplit;
  integer *isplit; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_ifail;
  integer *ifail; 
  VALUE rblapack_info;
  integer info; 
  doublereal *work;
  integer *iwork;

  integer n;
  integer ldz;
  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  z, ifail, info = NumRu::Lapack.dstein( d, e, w, iblock, isplit, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSTEIN computes the eigenvectors of a real symmetric tridiagonal\n*  matrix T corresponding to specified eigenvalues, using inverse\n*  iteration.\n*\n*  The maximum number of iterations allowed for each eigenvector is\n*  specified by an internal parameter MAXITS (currently set to 5).\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          The n diagonal elements of the tridiagonal matrix T.\n*\n*  E       (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (n-1) subdiagonal elements of the tridiagonal matrix\n*          T, in elements 1 to N-1.\n*\n*  M       (input) INTEGER\n*          The number of eigenvectors to be found.  0 <= M <= N.\n*\n*  W       (input) DOUBLE PRECISION array, dimension (N)\n*          The first M elements of W contain the eigenvalues for\n*          which eigenvectors are to be computed.  The eigenvalues\n*          should be grouped by split-off block and ordered from\n*          smallest to largest within the block.  ( The output array\n*          W from DSTEBZ with ORDER = 'B' is expected here. )\n*\n*  IBLOCK  (input) INTEGER array, dimension (N)\n*          The submatrix indices associated with the corresponding\n*          eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to\n*          the first submatrix from the top, =2 if W(i) belongs to\n*          the second submatrix, etc.  ( The output array IBLOCK\n*          from DSTEBZ is expected here. )\n*\n*  ISPLIT  (input) INTEGER array, dimension (N)\n*          The splitting points, at which T breaks up into submatrices.\n*          The first submatrix consists of rows/columns 1 to\n*          ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n*          through ISPLIT( 2 ), etc.\n*          ( The output array ISPLIT from DSTEBZ is expected here. )\n*\n*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, M)\n*          The computed eigenvectors.  The eigenvector associated\n*          with the eigenvalue W(i) is stored in the i-th column of\n*          Z.  Any vector which fails to converge is set to its current\n*          iterate after MAXITS iterations.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= max(1,N).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (5*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\n*\n*  IFAIL   (output) INTEGER array, dimension (M)\n*          On normal exit, all elements of IFAIL are zero.\n*          If one or more eigenvectors fail to converge after\n*          MAXITS iterations, then their indices are stored in\n*          array IFAIL.\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, then i eigenvectors failed to converge\n*               in MAXITS iterations.  Their indices are stored in\n*               array IFAIL.\n*\n*  Internal Parameters\n*  ===================\n*\n*  MAXITS  INTEGER, default = 5\n*          The maximum number of iterations performed.\n*\n*  EXTRA   INTEGER, default = 2\n*          The number of iterations performed after norm growth\n*          criterion is satisfied, should be at least 1.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  z, ifail, info = NumRu::Lapack.dstein( d, e, w, iblock, isplit, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_d = argv[0];
  rblapack_e = argv[1];
  rblapack_w = argv[2];
  rblapack_iblock = argv[3];
  rblapack_isplit = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_w))
    rb_raise(rb_eArgError, "w (3th argument) must be NArray");
  if (NA_RANK(rblapack_w) != 1)
    rb_raise(rb_eArgError, "rank of w (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_w) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_w) != NA_DFLOAT)
    rblapack_w = na_change_type(rblapack_w, NA_DFLOAT);
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  if (!NA_IsNArray(rblapack_isplit))
    rb_raise(rb_eArgError, "isplit (5th argument) must be NArray");
  if (NA_RANK(rblapack_isplit) != 1)
    rb_raise(rb_eArgError, "rank of isplit (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_isplit) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of isplit must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_isplit) != NA_LINT)
    rblapack_isplit = na_change_type(rblapack_isplit, NA_LINT);
  isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
  if (!NA_IsNArray(rblapack_iblock))
    rb_raise(rb_eArgError, "iblock (4th argument) must be NArray");
  if (NA_RANK(rblapack_iblock) != 1)
    rb_raise(rb_eArgError, "rank of iblock (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_iblock) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of iblock must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_iblock) != NA_LINT)
    rblapack_iblock = na_change_type(rblapack_iblock, NA_LINT);
  iblock = NA_PTR_TYPE(rblapack_iblock, integer*);
  m = n;
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (2th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  ldz = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = m;
    rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
  work = ALLOC_N(doublereal, (5*n));
  iwork = ALLOC_N(integer, (n));

  dstein_(&n, d, e, &m, w, iblock, isplit, z, &ldz, work, iwork, ifail, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_z, rblapack_ifail, rblapack_info);
}

void
init_lapack_dstein(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dstein", rblapack_dstein, -1);
}
ruby-lapack-1.7.2/ext/sstebz.c0000644000175000017500000002640612502221013016041 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sstebz_(char* range, char* order, integer* n, real* vl, real* vu, integer* il, integer* iu, real* abstol, real* d, real* e, integer* m, integer* nsplit, real* w, integer* iblock, integer* isplit, real* work, integer* iwork, integer* info);


static VALUE
rblapack_sstebz(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_order;
  char order; 
  VALUE rblapack_vl;
  real vl; 
  VALUE rblapack_vu;
  real vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  real abstol; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_nsplit;
  integer nsplit; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_iblock;
  integer *iblock; 
  VALUE rblapack_isplit;
  integer *isplit; 
  VALUE rblapack_info;
  integer info; 
  real *work;
  integer *iwork;

  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  m, nsplit, w, iblock, isplit, info = NumRu::Lapack.sstebz( range, order, vl, vu, il, iu, abstol, d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSTEBZ computes the eigenvalues of a symmetric tridiagonal\n*  matrix T.  The user may ask for all eigenvalues, all eigenvalues\n*  in the half-open interval (VL, VU], or the IL-th through IU-th\n*  eigenvalues.\n*\n*  To avoid overflow, the matrix must be scaled so that its\n*  largest element is no greater than overflow**(1/2) *\n*  underflow**(1/4) in absolute value, and for greatest\n*  accuracy, it should not be much smaller than that.\n*\n*  See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n*  Matrix\", Report CS41, Computer Science Dept., Stanford\n*  University, July 21, 1966.\n*\n\n*  Arguments\n*  =========\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': (\"All\")   all eigenvalues will be found.\n*          = 'V': (\"Value\") all eigenvalues in the half-open interval\n*                           (VL, VU] will be found.\n*          = 'I': (\"Index\") the IL-th through IU-th eigenvalues (of the\n*                           entire matrix) will be found.\n*\n*  ORDER   (input) CHARACTER*1\n*          = 'B': (\"By Block\") the eigenvalues will be grouped by\n*                              split-off block (see IBLOCK, ISPLIT) and\n*                              ordered from smallest to largest within\n*                              the block.\n*          = 'E': (\"Entire matrix\")\n*                              the eigenvalues for the entire matrix\n*                              will be ordered from smallest to\n*                              largest.\n*\n*  N       (input) INTEGER\n*          The order of the tridiagonal matrix T.  N >= 0.\n*\n*  VL      (input) REAL\n*  VU      (input) REAL\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues.  Eigenvalues less than or equal\n*          to VL, or greater than VU, will not be returned.  VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) REAL\n*          The absolute tolerance for the eigenvalues.  An eigenvalue\n*          (or cluster) is considered to be located if it has been\n*          determined to lie in an interval whose width is ABSTOL or\n*          less.  If ABSTOL is less than or equal to zero, then ULP*|T|\n*          will be used, where |T| means the 1-norm of T.\n*\n*          Eigenvalues will be computed most accurately when ABSTOL is\n*          set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n*\n*  D       (input) REAL array, dimension (N)\n*          The n diagonal elements of the tridiagonal matrix T.\n*\n*  E       (input) REAL array, dimension (N-1)\n*          The (n-1) off-diagonal elements of the tridiagonal matrix T.\n*\n*  M       (output) INTEGER\n*          The actual number of eigenvalues found. 0 <= M <= N.\n*          (See also the description of INFO=2,3.)\n*\n*  NSPLIT  (output) INTEGER\n*          The number of diagonal blocks in the matrix T.\n*          1 <= NSPLIT <= N.\n*\n*  W       (output) REAL array, dimension (N)\n*          On exit, the first M elements of W will contain the\n*          eigenvalues.  (SSTEBZ may use the remaining N-M elements as\n*          workspace.)\n*\n*  IBLOCK  (output) INTEGER array, dimension (N)\n*          At each row/column j where E(j) is zero or small, the\n*          matrix T is considered to split into a block diagonal\n*          matrix.  On exit, if INFO = 0, IBLOCK(i) specifies to which\n*          block (from 1 to the number of blocks) the eigenvalue W(i)\n*          belongs.  (SSTEBZ may use the remaining N-M elements as\n*          workspace.)\n*\n*  ISPLIT  (output) INTEGER array, dimension (N)\n*          The splitting points, at which T breaks up into submatrices.\n*          The first submatrix consists of rows/columns 1 to ISPLIT(1),\n*          the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n*          etc., and the NSPLIT-th consists of rows/columns\n*          ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n*          (Only the first NSPLIT elements will actually be used, but\n*          since the user cannot know a priori what value NSPLIT will\n*          have, N words must be reserved for ISPLIT.)\n*\n*  WORK    (workspace) REAL array, dimension (4*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (3*N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  some or all of the eigenvalues failed to converge or\n*                were not computed:\n*                =1 or 3: Bisection failed to converge for some\n*                        eigenvalues; these eigenvalues are flagged by a\n*                        negative block number.  The effect is that the\n*                        eigenvalues may not be as accurate as the\n*                        absolute and relative tolerances.  This is\n*                        generally caused by unexpectedly inaccurate\n*                        arithmetic.\n*                =2 or 3: RANGE='I' only: Not all of the eigenvalues\n*                        IL:IU were found.\n*                        Effect: M < IU+1-IL\n*                        Cause:  non-monotonic arithmetic, causing the\n*                                Sturm sequence to be non-monotonic.\n*                        Cure:   recalculate, using RANGE='A', and pick\n*                                out eigenvalues IL:IU.  In some cases,\n*                                increasing the PARAMETER \"FUDGE\" may\n*                                make things work.\n*                = 4:    RANGE='I', and the Gershgorin interval\n*                        initially used was too small.  No eigenvalues\n*                        were computed.\n*                        Probable cause: your machine has sloppy\n*                                        floating-point arithmetic.\n*                        Cure: Increase the PARAMETER \"FUDGE\",\n*                              recompile, and try again.\n*\n*  Internal Parameters\n*  ===================\n*\n*  RELFAC  REAL, default = 2.0e0\n*          The relative tolerance.  An interval (a,b] lies within\n*          \"relative tolerance\" if  b-a < RELFAC*ulp*max(|a|,|b|),\n*          where \"ulp\" is the machine precision (distance from 1 to\n*          the next larger floating point number.)\n*\n*  FUDGE   REAL, default = 2\n*          A \"fudge factor\" to widen the Gershgorin intervals.  Ideally,\n*          a value of 1 should work, but on machines with sloppy\n*          arithmetic, this needs to be larger.  The default for\n*          publicly released versions should be large enough to handle\n*          the worst machine around.  Note that this has no effect\n*          on accuracy of the solution.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, nsplit, w, iblock, isplit, info = NumRu::Lapack.sstebz( range, order, vl, vu, il, iu, abstol, d, e, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_range = argv[0];
  rblapack_order = argv[1];
  rblapack_vl = argv[2];
  rblapack_vu = argv[3];
  rblapack_il = argv[4];
  rblapack_iu = argv[5];
  rblapack_abstol = argv[6];
  rblapack_d = argv[7];
  rblapack_e = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  range = StringValueCStr(rblapack_range)[0];
  vl = (real)NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  abstol = (real)NUM2DBL(rblapack_abstol);
  order = StringValueCStr(rblapack_order)[0];
  iu = NUM2INT(rblapack_iu);
  vu = (real)NUM2DBL(rblapack_vu);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (8th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (8th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (9th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_iblock = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iblock = NA_PTR_TYPE(rblapack_iblock, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_isplit = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
  work = ALLOC_N(real, (4*n));
  iwork = ALLOC_N(integer, (3*n));

  sstebz_(&range, &order, &n, &vl, &vu, &il, &iu, &abstol, d, e, &m, &nsplit, w, iblock, isplit, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_nsplit = INT2NUM(nsplit);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_m, rblapack_nsplit, rblapack_w, rblapack_iblock, rblapack_isplit, rblapack_info);
}

void
init_lapack_sstebz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sstebz", rblapack_sstebz, -1);
}
ruby-lapack-1.7.2/ext/dzsum1.c0000644000175000017500000000534312502221017015753 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal dzsum1_(integer* n, doublecomplex* cx, integer* incx);


static VALUE
rblapack_dzsum1(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_cx;
  doublecomplex *cx; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack___out__;
  doublereal __out__; 

  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  __out__ = NumRu::Lapack.dzsum1( cx, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION DZSUM1( N, CX, INCX )\n\n*  Purpose\n*  =======\n*\n*  DZSUM1 takes the sum of the absolute values of a complex\n*  vector and returns a double precision result.\n*\n*  Based on DZASUM from the Level 1 BLAS.\n*  The change is to use the 'genuine' absolute value.\n*\n*  Contributed by Nick Higham for use with ZLACON.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of elements in the vector CX.\n*\n*  CX      (input) COMPLEX*16 array, dimension (N)\n*          The vector whose elements will be summed.\n*\n*  INCX    (input) INTEGER\n*          The spacing between successive values of CX.  INCX > 0.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, NINCX\n      DOUBLE PRECISION   STEMP\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.dzsum1( cx, incx, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_cx = argv[0];
  rblapack_incx = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_cx))
    rb_raise(rb_eArgError, "cx (1th argument) must be NArray");
  if (NA_RANK(rblapack_cx) != 1)
    rb_raise(rb_eArgError, "rank of cx (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_cx);
  if (NA_TYPE(rblapack_cx) != NA_DCOMPLEX)
    rblapack_cx = na_change_type(rblapack_cx, NA_DCOMPLEX);
  cx = NA_PTR_TYPE(rblapack_cx, doublecomplex*);
  incx = NUM2INT(rblapack_incx);

  __out__ = dzsum1_(&n, cx, &incx);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_dzsum1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dzsum1", rblapack_dzsum1, -1);
}
ruby-lapack-1.7.2/ext/cgtsvx.c0000644000175000017500000004125312502221012016041 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgtsvx_(char* fact, char* trans, integer* n, integer* nrhs, complex* dl, complex* d, complex* du, complex* dlf, complex* df, complex* duf, complex* du2, integer* ipiv, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* ferr, real* berr, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cgtsvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_dl;
  complex *dl; 
  VALUE rblapack_d;
  complex *d; 
  VALUE rblapack_du;
  complex *du; 
  VALUE rblapack_dlf;
  complex *dlf; 
  VALUE rblapack_df;
  complex *df; 
  VALUE rblapack_duf;
  complex *duf; 
  VALUE rblapack_du2;
  complex *du2; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_dlf_out__;
  complex *dlf_out__;
  VALUE rblapack_df_out__;
  complex *df_out__;
  VALUE rblapack_duf_out__;
  complex *duf_out__;
  VALUE rblapack_du2_out__;
  complex *du2_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  complex *work;
  real *rwork;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, info, dlf, df, duf, du2, ipiv = NumRu::Lapack.cgtsvx( fact, trans, dl, d, du, dlf, df, duf, du2, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGTSVX uses the LU factorization to compute the solution to a complex\n*  system of linear equations A * X = B, A**T * X = B, or A**H * X = B,\n*  where A is a tridiagonal matrix of order N and X and B are N-by-NRHS\n*  matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'N', the LU decomposition is used to factor the matrix A\n*     as A = L * U, where L is a product of permutation and unit lower\n*     bidiagonal matrices and U is upper triangular with nonzeros in\n*     only the main diagonal and first two superdiagonals.\n*\n*  2. If some U(i,i)=0, so that U is exactly singular, then the routine\n*     returns with INFO = i. Otherwise, the factored form of A is used\n*     to estimate the condition number of the matrix A.  If the\n*     reciprocal of the condition number is less than machine precision,\n*     INFO = N+1 is returned as a warning, but the routine still goes on\n*     to solve for X and compute error bounds as described below.\n*\n*  3. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  4. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of A has been\n*          supplied on entry.\n*          = 'F':  DLF, DF, DUF, DU2, and IPIV contain the factored form\n*                  of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV will not\n*                  be modified.\n*          = 'N':  The matrix will be copied to DLF, DF, and DUF\n*                  and factored.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  DL      (input) COMPLEX array, dimension (N-1)\n*          The (n-1) subdiagonal elements of A.\n*\n*  D       (input) COMPLEX array, dimension (N)\n*          The n diagonal elements of A.\n*\n*  DU      (input) COMPLEX array, dimension (N-1)\n*          The (n-1) superdiagonal elements of A.\n*\n*  DLF     (input or output) COMPLEX array, dimension (N-1)\n*          If FACT = 'F', then DLF is an input argument and on entry\n*          contains the (n-1) multipliers that define the matrix L from\n*          the LU factorization of A as computed by CGTTRF.\n*\n*          If FACT = 'N', then DLF is an output argument and on exit\n*          contains the (n-1) multipliers that define the matrix L from\n*          the LU factorization of A.\n*\n*  DF      (input or output) COMPLEX array, dimension (N)\n*          If FACT = 'F', then DF is an input argument and on entry\n*          contains the n diagonal elements of the upper triangular\n*          matrix U from the LU factorization of A.\n*\n*          If FACT = 'N', then DF is an output argument and on exit\n*          contains the n diagonal elements of the upper triangular\n*          matrix U from the LU factorization of A.\n*\n*  DUF     (input or output) COMPLEX array, dimension (N-1)\n*          If FACT = 'F', then DUF is an input argument and on entry\n*          contains the (n-1) elements of the first superdiagonal of U.\n*\n*          If FACT = 'N', then DUF is an output argument and on exit\n*          contains the (n-1) elements of the first superdiagonal of U.\n*\n*  DU2     (input or output) COMPLEX array, dimension (N-2)\n*          If FACT = 'F', then DU2 is an input argument and on entry\n*          contains the (n-2) elements of the second superdiagonal of\n*          U.\n*\n*          If FACT = 'N', then DU2 is an output argument and on exit\n*          contains the (n-2) elements of the second superdiagonal of\n*          U.\n*\n*  IPIV    (input or output) INTEGER array, dimension (N)\n*          If FACT = 'F', then IPIV is an input argument and on entry\n*          contains the pivot indices from the LU factorization of A as\n*          computed by CGTTRF.\n*\n*          If FACT = 'N', then IPIV is an output argument and on exit\n*          contains the pivot indices from the LU factorization of A;\n*          row i of the matrix was interchanged with row IPIV(i).\n*          IPIV(i) will always be either i or i+1; IPIV(i) = i indicates\n*          a row interchange was not required.\n*\n*  B       (input) COMPLEX array, dimension (LDB,NRHS)\n*          The N-by-NRHS right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) COMPLEX array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) REAL\n*          The estimate of the reciprocal condition number of the matrix\n*          A.  If RCOND is less than the machine precision (in\n*          particular, if RCOND = 0), the matrix is singular to working\n*          precision.  This condition is indicated by a return code of\n*          INFO > 0.\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\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, and i is\n*                <= N:  U(i,i) is exactly zero.  The factorization\n*                       has not been completed unless i = N, but the\n*                       factor U is exactly singular, so the solution\n*                       and error bounds could not be computed.\n*                       RCOND = 0 is returned.\n*                = N+1: U is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, info, dlf, df, duf, du2, ipiv = NumRu::Lapack.cgtsvx( fact, trans, dl, d, du, dlf, df, duf, du2, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 11 && argc != 11)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
  rblapack_fact = argv[0];
  rblapack_trans = argv[1];
  rblapack_dl = argv[2];
  rblapack_d = argv[3];
  rblapack_du = argv[4];
  rblapack_dlf = argv[5];
  rblapack_df = argv[6];
  rblapack_duf = argv[7];
  rblapack_du2 = argv[8];
  rblapack_ipiv = argv[9];
  rblapack_b = argv[10];
  if (argc == 11) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SCOMPLEX)
    rblapack_d = na_change_type(rblapack_d, NA_SCOMPLEX);
  d = NA_PTR_TYPE(rblapack_d, complex*);
  if (!NA_IsNArray(rblapack_df))
    rb_raise(rb_eArgError, "df (7th argument) must be NArray");
  if (NA_RANK(rblapack_df) != 1)
    rb_raise(rb_eArgError, "rank of df (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_df) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of df must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_df) != NA_SCOMPLEX)
    rblapack_df = na_change_type(rblapack_df, NA_SCOMPLEX);
  df = NA_PTR_TYPE(rblapack_df, complex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (10th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (10th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  ldx = MAX(1,n);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (5th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_SCOMPLEX)
    rblapack_du = na_change_type(rblapack_du, NA_SCOMPLEX);
  du = NA_PTR_TYPE(rblapack_du, complex*);
  if (!NA_IsNArray(rblapack_duf))
    rb_raise(rb_eArgError, "duf (8th argument) must be NArray");
  if (NA_RANK(rblapack_duf) != 1)
    rb_raise(rb_eArgError, "rank of duf (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_duf) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of duf must be %d", n-1);
  if (NA_TYPE(rblapack_duf) != NA_SCOMPLEX)
    rblapack_duf = na_change_type(rblapack_duf, NA_SCOMPLEX);
  duf = NA_PTR_TYPE(rblapack_duf, complex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (11th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (11th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (3th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_SCOMPLEX)
    rblapack_dl = na_change_type(rblapack_dl, NA_SCOMPLEX);
  dl = NA_PTR_TYPE(rblapack_dl, complex*);
  if (!NA_IsNArray(rblapack_du2))
    rb_raise(rb_eArgError, "du2 (9th argument) must be NArray");
  if (NA_RANK(rblapack_du2) != 1)
    rb_raise(rb_eArgError, "rank of du2 (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du2) != (n-2))
    rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
  if (NA_TYPE(rblapack_du2) != NA_SCOMPLEX)
    rblapack_du2 = na_change_type(rblapack_du2, NA_SCOMPLEX);
  du2 = NA_PTR_TYPE(rblapack_du2, complex*);
  if (!NA_IsNArray(rblapack_dlf))
    rb_raise(rb_eArgError, "dlf (6th argument) must be NArray");
  if (NA_RANK(rblapack_dlf) != 1)
    rb_raise(rb_eArgError, "rank of dlf (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dlf) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dlf must be %d", n-1);
  if (NA_TYPE(rblapack_dlf) != NA_SCOMPLEX)
    rblapack_dlf = na_change_type(rblapack_dlf, NA_SCOMPLEX);
  dlf = NA_PTR_TYPE(rblapack_dlf, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_dlf_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  dlf_out__ = NA_PTR_TYPE(rblapack_dlf_out__, complex*);
  MEMCPY(dlf_out__, dlf, complex, NA_TOTAL(rblapack_dlf));
  rblapack_dlf = rblapack_dlf_out__;
  dlf = dlf_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_df_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  df_out__ = NA_PTR_TYPE(rblapack_df_out__, complex*);
  MEMCPY(df_out__, df, complex, NA_TOTAL(rblapack_df));
  rblapack_df = rblapack_df_out__;
  df = df_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_duf_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  duf_out__ = NA_PTR_TYPE(rblapack_duf_out__, complex*);
  MEMCPY(duf_out__, duf, complex, NA_TOTAL(rblapack_duf));
  rblapack_duf = rblapack_duf_out__;
  duf = duf_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-2;
    rblapack_du2_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  du2_out__ = NA_PTR_TYPE(rblapack_du2_out__, complex*);
  MEMCPY(du2_out__, du2, complex, NA_TOTAL(rblapack_du2));
  rblapack_du2 = rblapack_du2_out__;
  du2 = du2_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (n));

  cgtsvx_(&fact, &trans, &n, &nrhs, dl, d, du, dlf, df, duf, du2, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_dlf, rblapack_df, rblapack_duf, rblapack_du2, rblapack_ipiv);
}

void
init_lapack_cgtsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgtsvx", rblapack_cgtsvx, -1);
}
ruby-lapack-1.7.2/ext/cgetrs.c0000644000175000017500000001172112502221013016010 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgetrs_(char* trans, integer* n, integer* nrhs, complex* a, integer* lda, integer* ipiv, complex* b, integer* ldb, integer* info);


static VALUE
rblapack_cgetrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.cgetrs( trans, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGETRS solves a system of linear equations\n*     A * X = B,  A**T * X = B,  or  A**H * X = B\n*  with a general N-by-N matrix A using the LU factorization computed\n*  by CGETRF.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The factors L and U from the factorization A = P*L*U\n*          as computed by CGETRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices from CGETRF; for 1<=i<=N, row i of the\n*          matrix was interchanged with row IPIV(i).\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.cgetrs( trans, a, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_trans = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  cgetrs_(&trans, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_cgetrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgetrs", rblapack_cgetrs, -1);
}
ruby-lapack-1.7.2/ext/dtpcon.c0000644000175000017500000001066012502221021016010 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtpcon_(char* norm, char* uplo, char* diag, integer* n, doublereal* ap, doublereal* rcond, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dtpcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_info;
  integer info; 
  doublereal *work;
  integer *iwork;

  integer ldap;
  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  rcond, info = NumRu::Lapack.dtpcon( norm, uplo, diag, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTPCON estimates the reciprocal of the condition number of a packed\n*  triangular matrix A, in either the 1-norm or the infinity-norm.\n*\n*  The norm of A is computed and an estimate is obtained for\n*  norm(inv(A)), then the reciprocal of the condition number is\n*  computed as\n*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies whether the 1-norm condition number or the\n*          infinity-norm condition number is required:\n*          = '1' or 'O':  1-norm;\n*          = 'I':         Infinity-norm.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          The upper or lower triangular matrix A, packed columnwise in\n*          a linear array.  The j-th column of A is stored in the array\n*          AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          If DIAG = 'U', the diagonal elements of A are not referenced\n*          and are assumed to be 1.\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(norm(A) * norm(inv(A))).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.dtpcon( norm, uplo, diag, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_diag = argv[2];
  rblapack_ap = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  work = ALLOC_N(doublereal, (3*n));
  iwork = ALLOC_N(integer, (n));

  dtpcon_(&norm, &uplo, &diag, &n, ap, &rcond, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_dtpcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtpcon", rblapack_dtpcon, -1);
}
ruby-lapack-1.7.2/ext/clacn2.c0000644000175000017500000001260512502221022015665 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clacn2_(integer* n, complex* v, complex* x, real* est, integer* kase, integer* isave);


static VALUE
rblapack_clacn2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_est;
  real est; 
  VALUE rblapack_kase;
  integer kase; 
  VALUE rblapack_isave;
  integer *isave; 
  VALUE rblapack_x_out__;
  complex *x_out__;
  VALUE rblapack_isave_out__;
  integer *isave_out__;
  complex *v;

  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  x, est, kase, isave = NumRu::Lapack.clacn2( x, est, kase, isave, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLACN2( N, V, X, EST, KASE, ISAVE )\n\n*  Purpose\n*  =======\n*\n*  CLACN2 estimates the 1-norm of a square, complex matrix A.\n*  Reverse communication is used for evaluating matrix-vector products.\n*\n\n*  Arguments\n*  =========\n*\n*  N      (input) INTEGER\n*         The order of the matrix.  N >= 1.\n*\n*  V      (workspace) COMPLEX array, dimension (N)\n*         On the final return, V = A*W,  where  EST = norm(V)/norm(W)\n*         (W is not returned).\n*\n*  X      (input/output) COMPLEX array, dimension (N)\n*         On an intermediate return, X should be overwritten by\n*               A * X,   if KASE=1,\n*               A' * X,  if KASE=2,\n*         where A' is the conjugate transpose of A, and CLACN2 must be\n*         re-called with all the other parameters unchanged.\n*\n*  EST    (input/output) REAL\n*         On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be\n*         unchanged from the previous call to CLACN2.\n*         On exit, EST is an estimate (a lower bound) for norm(A). \n*\n*  KASE   (input/output) INTEGER\n*         On the initial call to CLACN2, KASE should be 0.\n*         On an intermediate return, KASE will be 1 or 2, indicating\n*         whether X should be overwritten by A * X  or A' * X.\n*         On the final return from CLACN2, KASE will again be 0.\n*\n*  ISAVE  (input/output) INTEGER array, dimension (3)\n*         ISAVE is used to save variables between calls to SLACN2\n*\n\n*  Further Details\n*  ======= =======\n*\n*  Contributed by Nick Higham, University of Manchester.\n*  Originally named CONEST, dated March 16, 1988.\n*\n*  Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n*  a real or complex matrix, with applications to condition estimation\",\n*  ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n*\n*  Last modified:  April, 1999\n*\n*  This is a thread safe version of CLACON, which uses the array ISAVE\n*  in place of a SAVE statement, as follows:\n*\n*     CLACON     CLACN2\n*      JUMP     ISAVE(1)\n*      J        ISAVE(2)\n*      ITER     ISAVE(3)\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, est, kase, isave = NumRu::Lapack.clacn2( x, est, kase, isave, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_x = argv[0];
  rblapack_est = argv[1];
  rblapack_kase = argv[2];
  rblapack_isave = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (1th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  kase = NUM2INT(rblapack_kase);
  est = (real)NUM2DBL(rblapack_est);
  if (!NA_IsNArray(rblapack_isave))
    rb_raise(rb_eArgError, "isave (4th argument) must be NArray");
  if (NA_RANK(rblapack_isave) != 1)
    rb_raise(rb_eArgError, "rank of isave (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_isave) != (3))
    rb_raise(rb_eRuntimeError, "shape 0 of isave must be %d", 3);
  if (NA_TYPE(rblapack_isave) != NA_LINT)
    rblapack_isave = na_change_type(rblapack_isave, NA_LINT);
  isave = NA_PTR_TYPE(rblapack_isave, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = 3;
    rblapack_isave_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isave_out__ = NA_PTR_TYPE(rblapack_isave_out__, integer*);
  MEMCPY(isave_out__, isave, integer, NA_TOTAL(rblapack_isave));
  rblapack_isave = rblapack_isave_out__;
  isave = isave_out__;
  v = ALLOC_N(complex, (n));

  clacn2_(&n, v, x, &est, &kase, isave);

  free(v);
  rblapack_est = rb_float_new((double)est);
  rblapack_kase = INT2NUM(kase);
  return rb_ary_new3(4, rblapack_x, rblapack_est, rblapack_kase, rblapack_isave);
}

void
init_lapack_clacn2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clacn2", rblapack_clacn2, -1);
}
ruby-lapack-1.7.2/ext/slaqsp.c0000644000175000017500000001162212502221021016023 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaqsp_(char* uplo, integer* n, real* ap, real* s, real* scond, real* amax, char* equed);


static VALUE
rblapack_slaqsp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_scond;
  real scond; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_ap_out__;
  real *ap_out__;

  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  equed, ap = NumRu::Lapack.slaqsp( uplo, ap, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )\n\n*  Purpose\n*  =======\n*\n*  SLAQSP equilibrates a symmetric matrix A using the scaling factors\n*  in the vector S.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) REAL array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, the equilibrated matrix:  diag(S) * A * diag(S), in\n*          the same storage format as A.\n*\n*  S       (input) REAL array, dimension (N)\n*          The scale factors for A.\n*\n*  SCOND   (input) REAL\n*          Ratio of the smallest S(i) to the largest S(i).\n*\n*  AMAX    (input) REAL\n*          Absolute value of largest matrix entry.\n*\n*  EQUED   (output) CHARACTER*1\n*          Specifies whether or not equilibration was done.\n*          = 'N':  No equilibration.\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*\n*  Internal Parameters\n*  ===================\n*\n*  THRESH is a threshold value used to decide if scaling should be done\n*  based on the ratio of the scaling factors.  If SCOND < THRESH,\n*  scaling is done.\n*\n*  LARGE and SMALL are threshold values used to decide if scaling should\n*  be done based on the absolute size of the largest matrix element.\n*  If AMAX > LARGE or AMAX < SMALL, scaling is done.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  equed, ap = NumRu::Lapack.slaqsp( uplo, ap, s, scond, amax, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_s = argv[2];
  rblapack_scond = argv[3];
  rblapack_amax = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (3th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_s);
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  amax = (real)NUM2DBL(rblapack_amax);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  scond = (real)NUM2DBL(rblapack_scond);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, real*);
  MEMCPY(ap_out__, ap, real, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  slaqsp_(&uplo, &n, ap, s, &scond, &amax, &equed);

  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(2, rblapack_equed, rblapack_ap);
}

void
init_lapack_slaqsp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaqsp", rblapack_slaqsp, -1);
}
ruby-lapack-1.7.2/ext/csytri.c0000644000175000017500000001125512502221015016042 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID csytri_(char* uplo, integer* n, complex* a, integer* lda, integer* ipiv, complex* work, integer* info);


static VALUE
rblapack_csytri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  complex *work;

  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  info, a = NumRu::Lapack.csytri( uplo, a, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CSYTRI computes the inverse of a complex symmetric indefinite matrix\n*  A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n*  CSYTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the block diagonal matrix D and the multipliers\n*          used to obtain the factor U or L as computed by CSYTRF.\n*\n*          On exit, if INFO = 0, the (symmetric) inverse of the original\n*          matrix.  If UPLO = 'U', the upper triangular part of the\n*          inverse is formed and the part of A below the diagonal is not\n*          referenced; if UPLO = 'L' the lower triangular part of the\n*          inverse is formed and the part of A above the diagonal is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by CSYTRF.\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\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, D(i,i) = 0; the matrix is singular and its\n*               inverse could not be computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.csytri( uplo, a, ipiv, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(complex, (2*n));

  csytri_(&uplo, &n, a, &lda, ipiv, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_csytri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "csytri", rblapack_csytri, -1);
}
ruby-lapack-1.7.2/ext/zggevx.c0000644000175000017500000004306212502221023016037 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zggevx_(char* balanc, char* jobvl, char* jobvr, char* sense, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* alpha, doublecomplex* beta, doublecomplex* vl, integer* ldvl, doublecomplex* vr, integer* ldvr, integer* ilo, integer* ihi, doublereal* lscale, doublereal* rscale, doublereal* abnrm, doublereal* bbnrm, doublereal* rconde, doublereal* rcondv, doublecomplex* work, integer* lwork, doublereal* rwork, integer* iwork, logical* bwork, integer* info);


static VALUE
rblapack_zggevx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_balanc;
  char balanc; 
  VALUE rblapack_jobvl;
  char jobvl; 
  VALUE rblapack_jobvr;
  char jobvr; 
  VALUE rblapack_sense;
  char sense; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_alpha;
  doublecomplex *alpha; 
  VALUE rblapack_beta;
  doublecomplex *beta; 
  VALUE rblapack_vl;
  doublecomplex *vl; 
  VALUE rblapack_vr;
  doublecomplex *vr; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_lscale;
  doublereal *lscale; 
  VALUE rblapack_rscale;
  doublereal *rscale; 
  VALUE rblapack_abnrm;
  doublereal abnrm; 
  VALUE rblapack_bbnrm;
  doublereal bbnrm; 
  VALUE rblapack_rconde;
  doublereal *rconde; 
  VALUE rblapack_rcondv;
  doublereal *rcondv; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  doublereal *rwork;
  integer *iwork;
  logical *bwork;

  integer lda;
  integer n;
  integer ldb;
  integer ldvl;
  integer ldvr;
  integer lrwork;

  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  alpha, beta, vl, vr, ilo, ihi, lscale, rscale, abnrm, bbnrm, rconde, rcondv, work, info, a, b = NumRu::Lapack.zggevx( balanc, jobvl, jobvr, sense, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, ILO, IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, WORK, LWORK, RWORK, IWORK, BWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGGEVX computes for a pair of N-by-N complex nonsymmetric matrices\n*  (A,B) the generalized eigenvalues, and optionally, the left and/or\n*  right generalized eigenvectors.\n*\n*  Optionally, it also computes a balancing transformation to improve\n*  the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n*  LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for\n*  the eigenvalues (RCONDE), and reciprocal condition numbers for the\n*  right eigenvectors (RCONDV).\n*\n*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n*  lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n*  singular. It is usually represented as the pair (alpha,beta), as\n*  there is a reasonable interpretation for beta=0, and even for both\n*  being zero.\n*\n*  The right eigenvector v(j) corresponding to the eigenvalue lambda(j)\n*  of (A,B) satisfies\n*                   A * v(j) = lambda(j) * B * v(j) .\n*  The left eigenvector u(j) corresponding to the eigenvalue lambda(j)\n*  of (A,B) satisfies\n*                   u(j)**H * A  = lambda(j) * u(j)**H * B.\n*  where u(j)**H is the conjugate-transpose of u(j).\n*\n*\n\n*  Arguments\n*  =========\n*\n*  BALANC  (input) CHARACTER*1\n*          Specifies the balance option to be performed:\n*          = 'N':  do not diagonally scale or permute;\n*          = 'P':  permute only;\n*          = 'S':  scale only;\n*          = 'B':  both permute and scale.\n*          Computed reciprocal condition numbers will be for the\n*          matrices after permuting and/or balancing. Permuting does\n*          not change condition numbers (in exact arithmetic), but\n*          balancing does.\n*\n*  JOBVL   (input) CHARACTER*1\n*          = 'N':  do not compute the left generalized eigenvectors;\n*          = 'V':  compute the left generalized eigenvectors.\n*\n*  JOBVR   (input) CHARACTER*1\n*          = 'N':  do not compute the right generalized eigenvectors;\n*          = 'V':  compute the right generalized eigenvectors.\n*\n*  SENSE   (input) CHARACTER*1\n*          Determines which reciprocal condition numbers are computed.\n*          = 'N': none are computed;\n*          = 'E': computed for eigenvalues only;\n*          = 'V': computed for eigenvectors only;\n*          = 'B': computed for eigenvalues and eigenvectors.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A, B, VL, and VR.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA, N)\n*          On entry, the matrix A in the pair (A,B).\n*          On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'\n*          or both, then A contains the first part of the complex Schur\n*          form of the \"balanced\" versions of the input A and B.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of A.  LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB, N)\n*          On entry, the matrix B in the pair (A,B).\n*          On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'\n*          or both, then B contains the second part of the complex\n*          Schur form of the \"balanced\" versions of the input A and B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of B.  LDB >= max(1,N).\n*\n*  ALPHA   (output) COMPLEX*16 array, dimension (N)\n*  BETA    (output) COMPLEX*16 array, dimension (N)\n*          On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the generalized\n*          eigenvalues.\n*\n*          Note: the quotient ALPHA(j)/BETA(j) ) may easily over- or\n*          underflow, and BETA(j) may even be zero.  Thus, the user\n*          should avoid naively computing the ratio ALPHA/BETA.\n*          However, ALPHA will be always less than and usually\n*          comparable with norm(A) in magnitude, and BETA always less\n*          than and usually comparable with norm(B).\n*\n*  VL      (output) COMPLEX*16 array, dimension (LDVL,N)\n*          If JOBVL = 'V', the left generalized eigenvectors u(j) are\n*          stored one after another in the columns of VL, in the same\n*          order as their eigenvalues.\n*          Each eigenvector will be scaled so the largest component\n*          will have abs(real part) + abs(imag. part) = 1.\n*          Not referenced if JOBVL = 'N'.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the matrix VL. LDVL >= 1, and\n*          if JOBVL = 'V', LDVL >= N.\n*\n*  VR      (output) COMPLEX*16 array, dimension (LDVR,N)\n*          If JOBVR = 'V', the right generalized eigenvectors v(j) are\n*          stored one after another in the columns of VR, in the same\n*          order as their eigenvalues.\n*          Each eigenvector will be scaled so the largest component\n*          will have abs(real part) + abs(imag. part) = 1.\n*          Not referenced if JOBVR = 'N'.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the matrix VR. LDVR >= 1, and\n*          if JOBVR = 'V', LDVR >= N.\n*\n*  ILO     (output) INTEGER\n*  IHI     (output) INTEGER\n*          ILO and IHI are integer values such that on exit\n*          A(i,j) = 0 and B(i,j) = 0 if i > j and\n*          j = 1,...,ILO-1 or i = IHI+1,...,N.\n*          If BALANC = 'N' or 'S', ILO = 1 and IHI = N.\n*\n*  LSCALE  (output) DOUBLE PRECISION array, dimension (N)\n*          Details of the permutations and scaling factors applied\n*          to the left side of A and B.  If PL(j) is the index of the\n*          row interchanged with row j, and DL(j) is the scaling\n*          factor applied to row j, then\n*            LSCALE(j) = PL(j)  for j = 1,...,ILO-1\n*                      = DL(j)  for j = ILO,...,IHI\n*                      = PL(j)  for j = IHI+1,...,N.\n*          The order in which the interchanges are made is N to IHI+1,\n*          then 1 to ILO-1.\n*\n*  RSCALE  (output) DOUBLE PRECISION array, dimension (N)\n*          Details of the permutations and scaling factors applied\n*          to the right side of A and B.  If PR(j) is the index of the\n*          column interchanged with column j, and DR(j) is the scaling\n*          factor applied to column j, then\n*            RSCALE(j) = PR(j)  for j = 1,...,ILO-1\n*                      = DR(j)  for j = ILO,...,IHI\n*                      = PR(j)  for j = IHI+1,...,N\n*          The order in which the interchanges are made is N to IHI+1,\n*          then 1 to ILO-1.\n*\n*  ABNRM   (output) DOUBLE PRECISION\n*          The one-norm of the balanced matrix A.\n*\n*  BBNRM   (output) DOUBLE PRECISION\n*          The one-norm of the balanced matrix B.\n*\n*  RCONDE  (output) DOUBLE PRECISION array, dimension (N)\n*          If SENSE = 'E' or 'B', the reciprocal condition numbers of\n*          the eigenvalues, stored in consecutive elements of the array.\n*          If SENSE = 'N' or 'V', RCONDE is not referenced.\n*\n*  RCONDV  (output) DOUBLE PRECISION array, dimension (N)\n*          If JOB = 'V' or 'B', the estimated reciprocal condition\n*          numbers of the eigenvectors, stored in consecutive elements\n*          of the array. If the eigenvalues cannot be reordered to\n*          compute RCONDV(j), RCONDV(j) is set to 0; this can only occur\n*          when the true value would be very small anyway.\n*          If SENSE = 'N' or 'E', RCONDV is not referenced.\n*\n*  WORK    (workspace/output) COMPLEX*16 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,2*N).\n*          If SENSE = 'E', LWORK >= max(1,4*N).\n*          If SENSE = 'V' or 'B', LWORK >= max(1,2*N*N+2*N).\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*  RWORK   (workspace) REAL array, dimension (lrwork)\n*          lrwork must be at least max(1,6*N) if BALANC = 'S' or 'B',\n*          and at least max(1,2*N) otherwise.\n*          Real workspace.\n*\n*  IWORK   (workspace) INTEGER array, dimension (N+2)\n*          If SENSE = 'E', IWORK is not referenced.\n*\n*  BWORK   (workspace) LOGICAL array, dimension (N)\n*          If SENSE = 'N', BWORK is not referenced.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          = 1,...,N:\n*                The QZ iteration failed.  No eigenvectors have been\n*                calculated, but ALPHA(j) and BETA(j) should be correct\n*                for j=INFO+1,...,N.\n*          > N:  =N+1: other than QZ iteration failed in ZHGEQZ.\n*                =N+2: error return from ZTGEVC.\n*\n\n*  Further Details\n*  ===============\n*\n*  Balancing a matrix pair (A,B) includes, first, permuting rows and\n*  columns to isolate eigenvalues, second, applying diagonal similarity\n*  transformation to the rows and columns to make the rows and columns\n*  as close in norm as possible. The computed reciprocal condition\n*  numbers correspond to the balanced matrix. Permuting rows and columns\n*  will not change the condition numbers (in exact arithmetic) but\n*  diagonal scaling will.  For further explanation of balancing, see\n*  section 4.11.1.2 of LAPACK Users' Guide.\n*\n*  An approximate error bound on the chordal distance between the i-th\n*  computed generalized eigenvalue w and the corresponding exact\n*  eigenvalue lambda is\n*\n*       chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)\n*\n*  An approximate error bound for the angle between the i-th computed\n*  eigenvector VL(i) or VR(i) is given by\n*\n*       EPS * norm(ABNRM, BBNRM) / DIF(i).\n*\n*  For further explanation of the reciprocal condition numbers RCONDE\n*  and RCONDV, see section 4.11 of LAPACK User's Guide.\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  alpha, beta, vl, vr, ilo, ihi, lscale, rscale, abnrm, bbnrm, rconde, rcondv, work, info, a, b = NumRu::Lapack.zggevx( balanc, jobvl, jobvr, sense, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_balanc = argv[0];
  rblapack_jobvl = argv[1];
  rblapack_jobvr = argv[2];
  rblapack_sense = argv[3];
  rblapack_a = argv[4];
  rblapack_b = argv[5];
  if (argc == 7) {
    rblapack_lwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  balanc = StringValueCStr(rblapack_balanc)[0];
  jobvr = StringValueCStr(rblapack_jobvr)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  jobvl = StringValueCStr(rblapack_jobvl)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  ldvr = lsame_(&jobvr,"V") ? n : 1;
  ldvl = lsame_(&jobvl,"V") ? n : 1;
  sense = StringValueCStr(rblapack_sense)[0];
  lrwork = ((lsame_(&balanc,"S")) || (lsame_(&balanc,"B"))) ? MAX(1,6*n) : MAX(1,2*n);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&sense,"E") ? 4*n : (lsame_(&sense,"V")||lsame_(&sense,"B")) ? 2*n*n+2*n : 2*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  alpha = NA_PTR_TYPE(rblapack_alpha, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = n;
    rblapack_vl = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  vl = NA_PTR_TYPE(rblapack_vl, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = n;
    rblapack_vr = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  vr = NA_PTR_TYPE(rblapack_vr, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_lscale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  lscale = NA_PTR_TYPE(rblapack_lscale, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rscale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  rscale = NA_PTR_TYPE(rblapack_rscale, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rconde = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  rconde = NA_PTR_TYPE(rblapack_rconde, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rcondv = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  rcondv = NA_PTR_TYPE(rblapack_rcondv, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  rwork = ALLOC_N(doublereal, (lrwork));
  iwork = ALLOC_N(integer, (lsame_(&sense,"E") ? 0 : n+2));
  bwork = ALLOC_N(logical, (lsame_(&sense,"N") ? 0 : n));

  zggevx_(&balanc, &jobvl, &jobvr, &sense, &n, a, &lda, b, &ldb, alpha, beta, vl, &ldvl, vr, &ldvr, &ilo, &ihi, lscale, rscale, &abnrm, &bbnrm, rconde, rcondv, work, &lwork, rwork, iwork, bwork, &info);

  free(rwork);
  free(iwork);
  free(bwork);
  rblapack_ilo = INT2NUM(ilo);
  rblapack_ihi = INT2NUM(ihi);
  rblapack_abnrm = rb_float_new((double)abnrm);
  rblapack_bbnrm = rb_float_new((double)bbnrm);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(16, rblapack_alpha, rblapack_beta, rblapack_vl, rblapack_vr, rblapack_ilo, rblapack_ihi, rblapack_lscale, rblapack_rscale, rblapack_abnrm, rblapack_bbnrm, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_zggevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zggevx", rblapack_zggevx, -1);
}
ruby-lapack-1.7.2/ext/dpbtf2.c0000644000175000017500000001230412502221025015703 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dpbtf2_(char* uplo, integer* n, integer* kd, doublereal* ab, integer* ldab, integer* info);


static VALUE
rblapack_dpbtf2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublereal *ab_out__;

  integer ldab;
  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  info, ab = NumRu::Lapack.dpbtf2( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPBTF2( UPLO, N, KD, AB, LDAB, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPBTF2 computes the Cholesky factorization of a real symmetric\n*  positive definite band matrix A.\n*\n*  The factorization has the form\n*     A = U' * U ,  if UPLO = 'U', or\n*     A = L  * L',  if UPLO = 'L',\n*  where U is an upper triangular matrix, U' is the transpose of U, and\n*  L is lower triangular.\n*\n*  This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored:\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of super-diagonals of the matrix A if UPLO = 'U',\n*          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*          On exit, if INFO = 0, the triangular factor U or L from the\n*          Cholesky factorization A = U'*U or A = L*L' of the band\n*          matrix A, in the same storage format as A.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*          > 0: if INFO = k, the leading minor of order k is not\n*               positive definite, and the factorization could not be\n*               completed.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  N = 6, KD = 2, and UPLO = 'U':\n*\n*  On entry:                       On exit:\n*\n*      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46\n*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56\n*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66\n*\n*  Similarly, if UPLO = 'L' the format of A is as follows:\n*\n*  On entry:                       On exit:\n*\n*     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66\n*     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *\n*     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *\n*\n*  Array elements marked * are not used by the routine.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ab = NumRu::Lapack.dpbtf2( uplo, kd, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  kd = NUM2INT(rblapack_kd);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
  MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  dpbtf2_(&uplo, &n, &kd, ab, &ldab, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ab);
}

void
init_lapack_dpbtf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dpbtf2", rblapack_dpbtf2, -1);
}
ruby-lapack-1.7.2/ext/dgerfs.c0000644000175000017500000002067612502221020016002 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgerfs_(char* trans, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* af, integer* ldaf, integer* ipiv, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dgerfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_af;
  doublereal *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  doublereal *x_out__;
  doublereal *work;
  integer *iwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.dgerfs( trans, a, af, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGERFS improves the computed solution to a system of linear\n*  equations and provides error bounds and backward error estimates for\n*  the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*          The original N-by-N matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AF      (input) DOUBLE PRECISION array, dimension (LDAF,N)\n*          The factors L and U from the factorization A = P*L*U\n*          as computed by DGETRF.\n*\n*  LDAF    (input) INTEGER\n*          The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices from DGETRF; for 1<=i<=N, row i of the\n*          matrix was interchanged with row IPIV(i).\n*\n*  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by DGETRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.dgerfs( trans, a, af, ipiv, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_trans = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_b = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_DFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
  af = NA_PTR_TYPE(rblapack_af, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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 (!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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(doublereal, (3*n));
  iwork = ALLOC_N(integer, (n));

  dgerfs_(&trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_dgerfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgerfs", rblapack_dgerfs, -1);
}
ruby-lapack-1.7.2/ext/ssytrs.c0000644000175000017500000001167212502221016016100 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssytrs_(char* uplo, integer* n, integer* nrhs, real* a, integer* lda, integer* ipiv, real* b, integer* ldb, integer* info);


static VALUE
rblapack_ssytrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  real *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.ssytrs( uplo, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSYTRS solves a system of linear equations A*X = B with a real\n*  symmetric matrix A using the factorization A = U*D*U**T or\n*  A = L*D*L**T computed by SSYTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input) REAL array, dimension (LDA,N)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by SSYTRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by SSYTRF.\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.ssytrs( uplo, a, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  ssytrs_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_ssytrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssytrs", rblapack_ssytrs, -1);
}
ruby-lapack-1.7.2/ext/dtrcon.c0000644000175000017500000001121612502221024016013 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtrcon_(char* norm, char* uplo, char* diag, integer* n, doublereal* a, integer* lda, doublereal* rcond, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dtrcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_info;
  integer info; 
  doublereal *work;
  integer *iwork;

  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  rcond, info = NumRu::Lapack.dtrcon( norm, uplo, diag, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTRCON estimates the reciprocal of the condition number of a\n*  triangular matrix A, in either the 1-norm or the infinity-norm.\n*\n*  The norm of A is computed and an estimate is obtained for\n*  norm(inv(A)), then the reciprocal of the condition number is\n*  computed as\n*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies whether the 1-norm condition number or the\n*          infinity-norm condition number is required:\n*          = '1' or 'O':  1-norm;\n*          = 'I':         Infinity-norm.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*          The triangular matrix A.  If UPLO = 'U', the leading N-by-N\n*          upper triangular part of the array A contains the upper\n*          triangular matrix, and the strictly lower triangular part of\n*          A is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*          triangular part of the array A contains the lower triangular\n*          matrix, and the strictly upper triangular part of A is not\n*          referenced.  If DIAG = 'U', the diagonal elements of A are\n*          also not referenced and are assumed to be 1.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(norm(A) * norm(inv(A))).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.dtrcon( norm, uplo, diag, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_diag = argv[2];
  rblapack_a = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th 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*);
  work = ALLOC_N(doublereal, (3*n));
  iwork = ALLOC_N(integer, (n));

  dtrcon_(&norm, &uplo, &diag, &n, a, &lda, &rcond, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_dtrcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtrcon", rblapack_dtrcon, -1);
}
ruby-lapack-1.7.2/ext/dgetri.c0000644000175000017500000001215712502221021016002 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgetri_(integer* n, doublereal* a, integer* lda, integer* ipiv, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dgetri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_lwork;
  integer lwork; 
  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  work, info, a = NumRu::Lapack.dgetri( a, ipiv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGETRI computes the inverse of a matrix using the LU factorization\n*  computed by DGETRF.\n*\n*  This method inverts U and then computes inv(A) by solving the system\n*  inv(A)*L = inv(U) for inv(A).\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the factors L and U from the factorization\n*          A = P*L*U as computed by DGETRF.\n*          On exit, if INFO = 0, the inverse of the original matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices from DGETRF; for 1<=i<=N, row i of the\n*          matrix was interchanged with row IPIV(i).\n*\n*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n*          On exit, if INFO=0, then WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK.  LWORK >= max(1,N).\n*          For optimal performance LWORK >= N*NB, where NB is\n*          the optimal blocksize returned by ILAENV.\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, U(i,i) is exactly zero; the matrix is\n*                singular and its inverse could not be 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 = NumRu::Lapack.dgetri( a, ipiv, [: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_a = argv[0];
  rblapack_ipiv = 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 (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*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (2th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;

  dgetri_(&n, a, &lda, ipiv, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_dgetri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgetri", rblapack_dgetri, -1);
}
ruby-lapack-1.7.2/ext/cgeequ.c0000644000175000017500000001171312502221025015776 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgeequ_(integer* m, integer* n, complex* a, integer* lda, real* r, real* c, real* rowcnd, real* colcnd, real* amax, integer* info);


static VALUE
rblapack_cgeequ(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_r;
  real *r; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_rowcnd;
  real rowcnd; 
  VALUE rblapack_colcnd;
  real colcnd; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_info;
  integer info; 

  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  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.cgeequ( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGEEQU computes row and column scalings intended to equilibrate an\n*  M-by-N matrix A and reduce its condition number.  R returns the row\n*  scale factors and C the column scale factors, chosen to try to make\n*  the largest element in each row and column of the matrix B with\n*  elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n*\n*  R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n*  number and BIGNUM = largest safe number.  Use of these scaling\n*  factors is not guaranteed to reduce the condition number of A but\n*  works well in practice.\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) COMPLEX array, dimension (LDA,N)\n*          The M-by-N matrix whose equilibration factors are\n*          to be computed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  R       (output) REAL array, dimension (M)\n*          If INFO = 0 or INFO > M, R contains the row scale factors\n*          for A.\n*\n*  C       (output) REAL array, dimension (N)\n*          If INFO = 0,  C contains the column scale factors for A.\n*\n*  ROWCND  (output) REAL\n*          If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n*          smallest R(i) to the largest R(i).  If ROWCND >= 0.1 and\n*          AMAX is neither too large nor too small, it is not worth\n*          scaling by R.\n*\n*  COLCND  (output) REAL\n*          If INFO = 0, COLCND contains the ratio of the smallest\n*          C(i) to the largest C(i).  If COLCND >= 0.1, it is not\n*          worth scaling by C.\n*\n*  AMAX    (output) REAL\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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,  and i is\n*                <= M:  the i-th row of A is exactly zero\n*                >  M:  the (i-M)-th column of A is exactly zero\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.cgeequ( 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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  m = lda;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_r = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  r = NA_PTR_TYPE(rblapack_r, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  c = NA_PTR_TYPE(rblapack_c, real*);

  cgeequ_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &info);

  rblapack_rowcnd = rb_float_new((double)rowcnd);
  rblapack_colcnd = rb_float_new((double)colcnd);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
}

void
init_lapack_cgeequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgeequ", rblapack_cgeequ, -1);
}
ruby-lapack-1.7.2/ext/dgeev.c0000644000175000017500000002042312502221026015616 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgeev_(char* jobvl, char* jobvr, integer* n, doublereal* a, integer* lda, doublereal* wr, doublereal* wi, doublereal* vl, integer* ldvl, doublereal* vr, integer* ldvr, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dgeev(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvl;
  char jobvl; 
  VALUE rblapack_jobvr;
  char jobvr; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_wr;
  doublereal *wr; 
  VALUE rblapack_wi;
  doublereal *wi; 
  VALUE rblapack_vl;
  doublereal *vl; 
  VALUE rblapack_vr;
  doublereal *vr; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;

  integer lda;
  integer n;
  integer ldvl;
  integer ldvr;

  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  wr, wi, vl, vr, work, info, a = NumRu::Lapack.dgeev( jobvl, jobvr, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGEEV computes for an N-by-N real nonsymmetric matrix A, the\n*  eigenvalues and, optionally, the left and/or right eigenvectors.\n*\n*  The right eigenvector v(j) of A satisfies\n*                   A * v(j) = lambda(j) * v(j)\n*  where lambda(j) is its eigenvalue.\n*  The left eigenvector u(j) of A satisfies\n*                u(j)**H * A = lambda(j) * u(j)**H\n*  where u(j)**H denotes the conjugate transpose of u(j).\n*\n*  The computed eigenvectors are normalized to have Euclidean norm\n*  equal to 1 and largest component real.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVL   (input) CHARACTER*1\n*          = 'N': left eigenvectors of A are not computed;\n*          = 'V': left eigenvectors of A are computed.\n*\n*  JOBVR   (input) CHARACTER*1\n*          = 'N': right eigenvectors of A are not computed;\n*          = 'V': right eigenvectors of A are computed.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the N-by-N matrix A.\n*          On exit, A has been overwritten.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  WR      (output) DOUBLE PRECISION array, dimension (N)\n*  WI      (output) DOUBLE PRECISION array, dimension (N)\n*          WR and WI contain the real and imaginary parts,\n*          respectively, of the computed eigenvalues.  Complex\n*          conjugate pairs of eigenvalues appear consecutively\n*          with the eigenvalue having the positive imaginary part\n*          first.\n*\n*  VL      (output) DOUBLE PRECISION array, dimension (LDVL,N)\n*          If JOBVL = 'V', the left eigenvectors u(j) are stored one\n*          after another in the columns of VL, in the same order\n*          as their eigenvalues.\n*          If JOBVL = 'N', VL is not referenced.\n*          If the j-th eigenvalue is real, then u(j) = VL(:,j),\n*          the j-th column of VL.\n*          If the j-th and (j+1)-st eigenvalues form a complex\n*          conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and\n*          u(j+1) = VL(:,j) - i*VL(:,j+1).\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the array VL.  LDVL >= 1; if\n*          JOBVL = 'V', LDVL >= N.\n*\n*  VR      (output) DOUBLE PRECISION array, dimension (LDVR,N)\n*          If JOBVR = 'V', the right eigenvectors v(j) are stored one\n*          after another in the columns of VR, in the same order\n*          as their eigenvalues.\n*          If JOBVR = 'N', VR is not referenced.\n*          If the j-th eigenvalue is real, then v(j) = VR(:,j),\n*          the j-th column of VR.\n*          If the j-th and (j+1)-st eigenvalues form a complex\n*          conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and\n*          v(j+1) = VR(:,j) - i*VR(:,j+1).\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the array VR.  LDVR >= 1; if\n*          JOBVR = 'V', LDVR >= 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.  LWORK >= max(1,3*N), and\n*          if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N.  For good\n*          performance, LWORK must generally be larger.\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 QR algorithm failed to compute all the\n*                eigenvalues, and no eigenvectors have been computed;\n*                elements i+1:N of WR and WI contain eigenvalues which\n*                have converged.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  wr, wi, vl, vr, work, info, a = NumRu::Lapack.dgeev( jobvl, jobvr, a, [: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_jobvl = argv[0];
  rblapack_jobvr = argv[1];
  rblapack_a = 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;
  }

  jobvl = StringValueCStr(rblapack_jobvl)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  ldvl = lsame_(&jobvl,"V") ? n : 1;
  jobvr = StringValueCStr(rblapack_jobvr)[0];
  ldvr = lsame_(&jobvr,"V") ? n : 1;
  if (rblapack_lwork == Qnil)
    lwork = (lsame_(&jobvl,"V")||lsame_(&jobvr,"V")) ? 4*n : 3*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  wr = NA_PTR_TYPE(rblapack_wr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  wi = NA_PTR_TYPE(rblapack_wi, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = n;
    rblapack_vl = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vl = NA_PTR_TYPE(rblapack_vl, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = n;
    rblapack_vr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vr = NA_PTR_TYPE(rblapack_vr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;

  dgeev_(&jobvl, &jobvr, &n, a, &lda, wr, wi, vl, &ldvl, vr, &ldvr, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_wr, rblapack_wi, rblapack_vl, rblapack_vr, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_dgeev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgeev", rblapack_dgeev, -1);
}
ruby-lapack-1.7.2/ext/dlansy.c0000644000175000017500000001077612502221012016023 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal dlansy_(char* norm, char* uplo, integer* n, doublereal* a, integer* lda, doublereal* work);


static VALUE
rblapack_dlansy(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack___out__;
  doublereal __out__; 
  doublereal *work;

  integer lda;
  integer n;
  integer lwork;

  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  __out__ = NumRu::Lapack.dlansy( norm, uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK )\n\n*  Purpose\n*  =======\n*\n*  DLANSY  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  real symmetric matrix A.\n*\n*  Description\n*  ===========\n*\n*  DLANSY returns the value\n*\n*     DLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in DLANSY as described\n*          above.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is to be referenced.\n*          = 'U':  Upper triangular part of A is referenced\n*          = 'L':  Lower triangular part of A is referenced\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, DLANSY is\n*          set to zero.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*          The symmetric matrix A.  If UPLO = 'U', the leading n by n\n*          upper triangular part of A contains the upper triangular part\n*          of the matrix A, and the strictly lower triangular part of A\n*          is not referenced.  If UPLO = 'L', the leading n by n lower\n*          triangular part of A contains the lower triangular part of\n*          the matrix A, and the strictly upper triangular part of A is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(N,1).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n*          WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.dlansy( norm, uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
  work = ALLOC_N(doublereal, (MAX(1,lwork)));

  __out__ = dlansy_(&norm, &uplo, &n, a, &lda, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_dlansy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlansy", rblapack_dlansy, -1);
}
ruby-lapack-1.7.2/ext/zsyswapr.c0000644000175000017500000000774412502221015016437 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zsyswapr_(char* uplo, integer* n, doublecomplex* a, integer* i1, integer* i2);


static VALUE
rblapack_zsyswapr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_i1;
  integer i1; 
  VALUE rblapack_i2;
  integer i2; 
  VALUE rblapack_a_out__;
  doublecomplex *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  a = NumRu::Lapack.zsyswapr( uplo, a, i1, i2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSYSWAPR( UPLO, N, A, I1, I2)\n\n*  Purpose\n*  =======\n*\n*  ZSYSWAPR applies an elementary permutation on the rows and the columns of\n*  a symmetric matrix.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE COMPLEX array, dimension (LDA,N)\n*          On entry, the NB diagonal matrix D and the multipliers\n*          used to obtain the factor U or L as computed by ZSYTRF.\n*\n*          On exit, if INFO = 0, the (symmetric) inverse of the original\n*          matrix.  If UPLO = 'U', the upper triangular part of the\n*          inverse is formed and the part of A below the diagonal is not\n*          referenced; if UPLO = 'L' the lower triangular part of the\n*          inverse is formed and the part of A above the diagonal is\n*          not referenced.\n*\n*  I1      (input) INTEGER\n*          Index of the first row to swap\n*\n*  I2      (input) INTEGER\n*          Index of the second row to swap\n*\n\n*  =====================================================================\n*\n*     ..\n*     .. Local Scalars ..\n      LOGICAL            UPPER\n      INTEGER            I\n      DOUBLE COMPLEX     TMP\n*\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           ZSWAP\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  a = NumRu::Lapack.zsyswapr( uplo, a, i1, i2, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_i1 = argv[2];
  rblapack_i2 = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  i1 = NUM2INT(rblapack_i1);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  i2 = NUM2INT(rblapack_i2);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zsyswapr_(&uplo, &n, a, &i1, &i2);

  return rblapack_a;
}

void
init_lapack_zsyswapr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zsyswapr", rblapack_zsyswapr, -1);
}
ruby-lapack-1.7.2/ext/sgerfsx.c0000644000175000017500000005223012502221026016206 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgerfsx_(char* trans, char* equed, integer* n, integer* nrhs, real* a, integer* lda, real* af, integer* ldaf, integer* ipiv, real* r, real* c, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, real* work, integer* iwork, integer* info);


static VALUE
rblapack_sgerfsx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_af;
  real *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_r;
  real *r; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_params;
  real *params; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_err_bnds_norm;
  real *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  real *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  real *x_out__;
  VALUE rblapack_params_out__;
  real *params_out__;
  real *work;
  integer *iwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;
  integer nparams;
  integer n_err_bnds;

  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  rcond, berr, err_bnds_norm, err_bnds_comp, info, x, params = NumRu::Lapack.sgerfsx( trans, equed, a, af, ipiv, r, c, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     SGERFSX improves the computed solution to a system of linear\n*     equations and provides error bounds and backward error estimates\n*     for the solution.  In addition to normwise error bound, the code\n*     provides maximum componentwise error bound if possible.  See\n*     comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n*     error bounds.\n*\n*     The original system of linear equations may have been equilibrated\n*     before calling this routine, as described by arguments EQUED, R\n*     and C below. In this case, the solution and error bounds returned\n*     are for the original unequilibrated system.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     TRANS   (input) CHARACTER*1\n*     Specifies the form of the system of equations:\n*       = 'N':  A * X = B     (No transpose)\n*       = 'T':  A**T * X = B  (Transpose)\n*       = 'C':  A**H * X = B  (Conjugate transpose = Transpose)\n*\n*     EQUED   (input) CHARACTER*1\n*     Specifies the form of equilibration that was done to A\n*     before calling this routine. This is needed to compute\n*     the solution and error bounds correctly.\n*       = 'N':  No equilibration\n*       = 'R':  Row equilibration, i.e., A has been premultiplied by\n*               diag(R).\n*       = 'C':  Column equilibration, i.e., A has been postmultiplied\n*               by diag(C).\n*       = 'B':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(R) * A * diag(C).\n*               The right hand side B has been changed accordingly.\n*\n*     N       (input) INTEGER\n*     The order of the matrix A.  N >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     A       (input) REAL array, dimension (LDA,N)\n*     The original N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) REAL array, dimension (LDAF,N)\n*     The factors L and U from the factorization A = P*L*U\n*     as computed by SGETRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     The pivot indices from SGETRF; for 1<=i<=N, row i of the\n*     matrix was interchanged with row IPIV(i).\n*\n*     R       (input) REAL array, dimension (N)\n*     The row scale factors for A.  If EQUED = 'R' or 'B', A is\n*     multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n*     is not accessed.  \n*     If R is accessed, each element of R should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     C       (input) REAL array, dimension (N)\n*     The column scale factors for A.  If EQUED = 'C' or 'B', A is\n*     multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n*     is not accessed. \n*     If C is accessed, each element of C should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B       (input) REAL array, dimension (LDB,NRHS)\n*     The right hand side matrix B.\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (input/output) REAL array, dimension (LDX,NRHS)\n*     On entry, the solution matrix X, as computed by SGETRS.\n*     On exit, the improved solution matrix X.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) REAL\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     BERR    (output) REAL array, dimension (NRHS)\n*     Componentwise relative backward error.  This is the\n*     componentwise relative backward error of each solution vector X(j)\n*     (i.e., the smallest relative change in any element of A or B that\n*     makes X(j) an exact solution).\n*\n*     N_ERR_BNDS (input) INTEGER\n*     Number of error bounds to return for each right hand side\n*     and each type (normwise or componentwise).  See ERR_BNDS_NORM and\n*     ERR_BNDS_COMP below.\n*\n*     ERR_BNDS_NORM  (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     NPARAMS (input) INTEGER\n*     Specifies the number of parameters set in PARAMS.  If .LE. 0, the\n*     PARAMS array is never referenced and default values are used.\n*\n*     PARAMS  (input / output) REAL array, dimension NPARAMS\n*     Specifies algorithm parameters.  If an entry is .LT. 0.0, then\n*     that entry will be filled with default value used for that\n*     parameter.  Only positions up to NPARAMS are accessed; defaults\n*     are used for higher-numbered parameters.\n*\n*       PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n*            refinement or not.\n*         Default: 1.0\n*            = 0.0 : No refinement is performed, and no error bounds are\n*                    computed.\n*            = 1.0 : Use the double-precision refinement algorithm,\n*                    possibly with doubled-single computations if the\n*                    compilation environment does not support DOUBLE\n*                    PRECISION.\n*              (other values are reserved for future use)\n*\n*       PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n*            computations allowed for refinement.\n*         Default: 10\n*         Aggressive: Set to 100 to permit convergence using approximate\n*                     factorizations or factorizations other than LU. If\n*                     the factorization uses a technique other than\n*                     Gaussian elimination, the guarantees in\n*                     err_bnds_norm and err_bnds_comp may no longer be\n*                     trustworthy.\n*\n*       PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n*            will attempt to find a solution with small componentwise\n*            relative error in the double-precision algorithm.  Positive\n*            is true, 0.0 is false.\n*         Default: 1.0 (attempt componentwise convergence)\n*\n*     WORK    (workspace) REAL array, dimension (4*N)\n*\n*     IWORK   (workspace) INTEGER array, dimension (N)\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit. The solution to every right-hand side is\n*         guaranteed.\n*       < 0:  If INFO = -i, the i-th argument had an illegal value\n*       > 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, berr, err_bnds_norm, err_bnds_comp, info, x, params = NumRu::Lapack.sgerfsx( trans, equed, a, af, ipiv, r, c, b, x, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_trans = argv[0];
  rblapack_equed = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_r = argv[5];
  rblapack_c = argv[6];
  rblapack_b = argv[7];
  rblapack_x = argv[8];
  rblapack_params = argv[9];
  if (argc == 10) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (9th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (9th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  n_err_bnds = 3;
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_r))
    rb_raise(rb_eArgError, "r (6th argument) must be NArray");
  if (NA_RANK(rblapack_r) != 1)
    rb_raise(rb_eArgError, "rank of r (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_r) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_r) != NA_SFLOAT)
    rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
  r = NA_PTR_TYPE(rblapack_r, real*);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (10th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (10th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_SFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
  params = NA_PTR_TYPE(rblapack_params, real*);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
  af = NA_PTR_TYPE(rblapack_af, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
  MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(real, (4*n));
  iwork = ALLOC_N(integer, (n));

  sgerfsx_(&trans, &equed, &n, &nrhs, a, &lda, af, &ldaf, ipiv, r, c, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_x, rblapack_params);
}

void
init_lapack_sgerfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgerfsx", rblapack_sgerfsx, -1);
}
ruby-lapack-1.7.2/ext/dlagv2.c0000644000175000017500000001553112502221024015705 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlagv2_(doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* alphar, doublereal* alphai, doublereal* beta, doublereal* csl, doublereal* snl, doublereal* csr, doublereal* snr);


static VALUE
rblapack_dlagv2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_alphar;
  doublereal *alphar; 
  VALUE rblapack_alphai;
  doublereal *alphai; 
  VALUE rblapack_beta;
  doublereal *beta; 
  VALUE rblapack_csl;
  doublereal csl; 
  VALUE rblapack_snl;
  doublereal snl; 
  VALUE rblapack_csr;
  doublereal csr; 
  VALUE rblapack_snr;
  doublereal snr; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;

  integer lda;
  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  alphar, alphai, beta, csl, snl, csr, snr, a, b = NumRu::Lapack.dlagv2( a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, CSR, SNR )\n\n*  Purpose\n*  =======\n*\n*  DLAGV2 computes the Generalized Schur factorization of a real 2-by-2\n*  matrix pencil (A,B) where B is upper triangular. This routine\n*  computes orthogonal (rotation) matrices given by CSL, SNL and CSR,\n*  SNR such that\n*\n*  1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0\n*     types), then\n*\n*     [ a11 a12 ] := [  CSL  SNL ] [ a11 a12 ] [  CSR -SNR ]\n*     [  0  a22 ]    [ -SNL  CSL ] [ a21 a22 ] [  SNR  CSR ]\n*\n*     [ b11 b12 ] := [  CSL  SNL ] [ b11 b12 ] [  CSR -SNR ]\n*     [  0  b22 ]    [ -SNL  CSL ] [  0  b22 ] [  SNR  CSR ],\n*\n*  2) if the pencil (A,B) has a pair of complex conjugate eigenvalues,\n*     then\n*\n*     [ a11 a12 ] := [  CSL  SNL ] [ a11 a12 ] [  CSR -SNR ]\n*     [ a21 a22 ]    [ -SNL  CSL ] [ a21 a22 ] [  SNR  CSR ]\n*\n*     [ b11  0  ] := [  CSL  SNL ] [ b11 b12 ] [  CSR -SNR ]\n*     [  0  b22 ]    [ -SNL  CSL ] [  0  b22 ] [  SNR  CSR ]\n*\n*     where b11 >= b22 > 0.\n*\n*\n\n*  Arguments\n*  =========\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA, 2)\n*          On entry, the 2 x 2 matrix A.\n*          On exit, A is overwritten by the ``A-part'' of the\n*          generalized Schur form.\n*\n*  LDA     (input) INTEGER\n*          THe leading dimension of the array A.  LDA >= 2.\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB, 2)\n*          On entry, the upper triangular 2 x 2 matrix B.\n*          On exit, B is overwritten by the ``B-part'' of the\n*          generalized Schur form.\n*\n*  LDB     (input) INTEGER\n*          THe leading dimension of the array B.  LDB >= 2.\n*\n*  ALPHAR  (output) DOUBLE PRECISION array, dimension (2)\n*  ALPHAI  (output) DOUBLE PRECISION array, dimension (2)\n*  BETA    (output) DOUBLE PRECISION array, dimension (2)\n*          (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the\n*          pencil (A,B), k=1,2, i = sqrt(-1).  Note that BETA(k) may\n*          be zero.\n*\n*  CSL     (output) DOUBLE PRECISION\n*          The cosine of the left rotation matrix.\n*\n*  SNL     (output) DOUBLE PRECISION\n*          The sine of the left rotation matrix.\n*\n*  CSR     (output) DOUBLE PRECISION\n*          The cosine of the right rotation matrix.\n*\n*  SNR     (output) DOUBLE PRECISION\n*          The sine of the right rotation matrix.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  alphar, alphai, beta, csl, snl, csr, snr, a, b = NumRu::Lapack.dlagv2( a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  if (argc == 2) {
  } 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);
  if (NA_SHAPE1(rblapack_a) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", 2);
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of b must be %d", 2);
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 2;
    rblapack_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  alphar = NA_PTR_TYPE(rblapack_alphar, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 2;
    rblapack_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  alphai = NA_PTR_TYPE(rblapack_alphai, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 2;
    rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = 2;
    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__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = 2;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dlagv2_(a, &lda, b, &ldb, alphar, alphai, beta, &csl, &snl, &csr, &snr);

  rblapack_csl = rb_float_new((double)csl);
  rblapack_snl = rb_float_new((double)snl);
  rblapack_csr = rb_float_new((double)csr);
  rblapack_snr = rb_float_new((double)snr);
  return rb_ary_new3(9, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_csl, rblapack_snl, rblapack_csr, rblapack_snr, rblapack_a, rblapack_b);
}

void
init_lapack_dlagv2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlagv2", rblapack_dlagv2, -1);
}
ruby-lapack-1.7.2/ext/cgetf2.c0000644000175000017500000001014312502221014015671 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgetf2_(integer* m, integer* n, complex* a, integer* lda, integer* ipiv, integer* info);


static VALUE
rblapack_cgetf2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *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  ipiv, info, a = NumRu::Lapack.cgetf2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGETF2( M, N, A, LDA, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGETF2 computes an LU factorization of a general m-by-n matrix A\n*  using partial pivoting with row interchanges.\n*\n*  The factorization has the form\n*     A = P * L * U\n*  where P is a permutation matrix, L is lower triangular with unit\n*  diagonal elements (lower trapezoidal if m > n), and U is upper\n*  triangular (upper trapezoidal if m < n).\n*\n*  This is the right-looking Level 2 BLAS version of the algorithm.\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) COMPLEX array, dimension (LDA,N)\n*          On entry, the m by n matrix to be factored.\n*          On exit, the factors L and U from the factorization\n*          A = P*L*U; the unit diagonal elements of L are not stored.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  IPIV    (output) INTEGER array, dimension (min(M,N))\n*          The pivot indices; for 1 <= i <= min(M,N), row i of the\n*          matrix was interchanged with row IPIV(i).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*          > 0: if INFO = k, U(k,k) is exactly zero. The factorization\n*               has been completed, but the factor U is exactly\n*               singular, and division by zero will occur if it is used\n*               to solve a system of equations.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, a = NumRu::Lapack.cgetf2( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  cgetf2_(&m, &n, a, &lda, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_a);
}

void
init_lapack_cgetf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgetf2", rblapack_cgetf2, -1);
}
ruby-lapack-1.7.2/ext/dsyequb.c0000644000175000017500000001166412502221017016207 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsyequb_(char* uplo, integer* n, doublereal* a, integer* lda, doublereal* s, doublereal* scond, doublereal* amax, doublereal* work, integer* info);


static VALUE
rblapack_dsyequb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_scond;
  doublereal scond; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_info;
  integer info; 
  doublereal *work;

  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  s, scond, amax, info = NumRu::Lapack.dsyequb( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSYEQUB computes row and column scalings intended to equilibrate a\n*  symmetric matrix A and reduce its condition number\n*  (with respect to the two-norm).  S contains the scale factors,\n*  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n*  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This\n*  choice of S puts the condition number of B within a factor N of the\n*  smallest possible condition number over all possible diagonal\n*  scalings.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*          The N-by-N symmetric matrix whose scaling\n*          factors are to be computed.  Only the diagonal elements of A\n*          are referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  S       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, S contains the scale factors for A.\n*\n*  SCOND   (output) DOUBLE PRECISION\n*          If INFO = 0, S contains the ratio of the smallest S(i) to\n*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too\n*          large nor too small, it is not worth scaling by S.\n*\n*  AMAX    (output) DOUBLE PRECISION\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)\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 is nonpositive.\n*\n\n*  Further Details\n*  ======= =======\n*\n*  Reference: Livne, O.E. and Golub, G.H., \"Scaling by Binormalization\",\n*  Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004.\n*  DOI 10.1023/B:NUMA.0000016606.32820.69\n*  Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, scond, amax, info = NumRu::Lapack.dsyequb( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  work = ALLOC_N(doublereal, (3*n));

  dsyequb_(&uplo, &n, a, &lda, s, &scond, &amax, work, &info);

  free(work);
  rblapack_scond = rb_float_new((double)scond);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
}

void
init_lapack_dsyequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsyequb", rblapack_dsyequb, -1);
}
ruby-lapack-1.7.2/ext/clangt.c0000644000175000017500000001060412502221025015773 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real clangt_(char* norm, integer* n, complex* dl, complex* d, complex* du);


static VALUE
rblapack_clangt(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_dl;
  complex *dl; 
  VALUE rblapack_d;
  complex *d; 
  VALUE rblapack_du;
  complex *du; 
  VALUE rblapack___out__;
  real __out__; 

  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  __out__ = NumRu::Lapack.clangt( norm, dl, d, du, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL             FUNCTION CLANGT( NORM, N, DL, D, DU )\n\n*  Purpose\n*  =======\n*\n*  CLANGT  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  complex tridiagonal matrix A.\n*\n*  Description\n*  ===========\n*\n*  CLANGT returns the value\n*\n*     CLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in CLANGT as described\n*          above.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, CLANGT is\n*          set to zero.\n*\n*  DL      (input) COMPLEX array, dimension (N-1)\n*          The (n-1) sub-diagonal elements of A.\n*\n*  D       (input) COMPLEX array, dimension (N)\n*          The diagonal elements of A.\n*\n*  DU      (input) COMPLEX array, dimension (N-1)\n*          The (n-1) super-diagonal elements of A.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.clangt( norm, dl, d, du, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_norm = argv[0];
  rblapack_dl = argv[1];
  rblapack_d = argv[2];
  rblapack_du = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SCOMPLEX)
    rblapack_d = na_change_type(rblapack_d, NA_SCOMPLEX);
  d = NA_PTR_TYPE(rblapack_d, complex*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_SCOMPLEX)
    rblapack_dl = na_change_type(rblapack_dl, NA_SCOMPLEX);
  dl = NA_PTR_TYPE(rblapack_dl, complex*);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (4th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_SCOMPLEX)
    rblapack_du = na_change_type(rblapack_du, NA_SCOMPLEX);
  du = NA_PTR_TYPE(rblapack_du, complex*);

  __out__ = clangt_(&norm, &n, dl, d, du);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_clangt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clangt", rblapack_clangt, -1);
}
ruby-lapack-1.7.2/ext/cporfsx.c0000644000175000017500000005000512502221013016203 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cporfsx_(char* uplo, char* equed, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, real* s, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cporfsx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_params;
  real *params; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_err_bnds_norm;
  real *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  real *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_s_out__;
  real *s_out__;
  VALUE rblapack_x_out__;
  complex *x_out__;
  VALUE rblapack_params_out__;
  real *params_out__;
  complex *work;
  real *rwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;
  integer nparams;
  integer n_err_bnds;

  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  rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.cporfsx( uplo, equed, a, af, s, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     CPORFSX improves the computed solution to a system of linear\n*     equations when the coefficient matrix is symmetric positive\n*     definite, and provides error bounds and backward error estimates\n*     for the solution.  In addition to normwise error bound, the code\n*     provides maximum componentwise error bound if possible.  See\n*     comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n*     error bounds.\n*\n*     The original system of linear equations may have been equilibrated\n*     before calling this routine, as described by arguments EQUED and S\n*     below. In this case, the solution and error bounds returned are\n*     for the original unequilibrated system.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     EQUED   (input) CHARACTER*1\n*     Specifies the form of equilibration that was done to A\n*     before calling this routine. This is needed to compute\n*     the solution and error bounds correctly.\n*       = 'N':  No equilibration\n*       = 'Y':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(S) * A * diag(S).\n*               The right hand side B has been changed accordingly.\n*\n*     N       (input) INTEGER\n*     The order of the matrix A.  N >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     A       (input) COMPLEX array, dimension (LDA,N)\n*     The symmetric matrix A.  If UPLO = 'U', the leading N-by-N\n*     upper triangular part of A contains the upper triangular part\n*     of the matrix A, and the strictly lower triangular part of A\n*     is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*     triangular part of A contains the lower triangular part of\n*     the matrix A, and the strictly upper triangular part of A is\n*     not referenced.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX array, dimension (LDAF,N)\n*     The triangular factor U or L from the Cholesky factorization\n*     A = U**T*U or A = L*L**T, as computed by SPOTRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     S       (input or output) REAL array, dimension (N)\n*     The row scale factors for A.  If EQUED = 'Y', A is multiplied on\n*     the left and right by diag(S).  S is an input argument if FACT =\n*     'F'; otherwise, S is an output argument.  If FACT = 'F' and EQUED\n*     = 'Y', each element of S must be positive.  If S is output, each\n*     element of S is a power of the radix. If S is input, each element\n*     of S should be a power of the radix to ensure a reliable solution\n*     and error estimates. Scaling by powers of the radix does not cause\n*     rounding errors unless the result underflows or overflows.\n*     Rounding errors during scaling lead to refining with a matrix that\n*     is not equivalent to the input matrix, producing error estimates\n*     that may not be reliable.\n*\n*     B       (input) COMPLEX array, dimension (LDB,NRHS)\n*     The right hand side matrix B.\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (input/output) COMPLEX array, dimension (LDX,NRHS)\n*     On entry, the solution matrix X, as computed by SGETRS.\n*     On exit, the improved solution matrix X.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) REAL\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     BERR    (output) REAL array, dimension (NRHS)\n*     Componentwise relative backward error.  This is the\n*     componentwise relative backward error of each solution vector X(j)\n*     (i.e., the smallest relative change in any element of A or B that\n*     makes X(j) an exact solution).\n*\n*     N_ERR_BNDS (input) INTEGER\n*     Number of error bounds to return for each right hand side\n*     and each type (normwise or componentwise).  See ERR_BNDS_NORM and\n*     ERR_BNDS_COMP below.\n*\n*     ERR_BNDS_NORM  (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     NPARAMS (input) INTEGER\n*     Specifies the number of parameters set in PARAMS.  If .LE. 0, the\n*     PARAMS array is never referenced and default values are used.\n*\n*     PARAMS  (input / output) REAL array, dimension NPARAMS\n*     Specifies algorithm parameters.  If an entry is .LT. 0.0, then\n*     that entry will be filled with default value used for that\n*     parameter.  Only positions up to NPARAMS are accessed; defaults\n*     are used for higher-numbered parameters.\n*\n*       PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n*            refinement or not.\n*         Default: 1.0\n*            = 0.0 : No refinement is performed, and no error bounds are\n*                    computed.\n*            = 1.0 : Use the double-precision refinement algorithm,\n*                    possibly with doubled-single computations if the\n*                    compilation environment does not support DOUBLE\n*                    PRECISION.\n*              (other values are reserved for future use)\n*\n*       PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n*            computations allowed for refinement.\n*         Default: 10\n*         Aggressive: Set to 100 to permit convergence using approximate\n*                     factorizations or factorizations other than LU. If\n*                     the factorization uses a technique other than\n*                     Gaussian elimination, the guarantees in\n*                     err_bnds_norm and err_bnds_comp may no longer be\n*                     trustworthy.\n*\n*       PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n*            will attempt to find a solution with small componentwise\n*            relative error in the double-precision algorithm.  Positive\n*            is true, 0.0 is false.\n*         Default: 1.0 (attempt componentwise convergence)\n*\n*     WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*     RWORK   (workspace) REAL array, dimension (2*N)\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit. The solution to every right-hand side is\n*         guaranteed.\n*       < 0:  If INFO = -i, the i-th argument had an illegal value\n*       > 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.cporfsx( uplo, equed, a, af, s, b, x, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_uplo = argv[0];
  rblapack_equed = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_s = argv[4];
  rblapack_b = argv[5];
  rblapack_x = argv[6];
  rblapack_params = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (5th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (7th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  n_err_bnds = 3;
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (8th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (8th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_SFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
  params = NA_PTR_TYPE(rblapack_params, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
  MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
  MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (2*n));

  cporfsx_(&uplo, &equed, &n, &nrhs, a, &lda, af, &ldaf, s, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_s, rblapack_x, rblapack_params);
}

void
init_lapack_cporfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cporfsx", rblapack_cporfsx, -1);
}
ruby-lapack-1.7.2/ext/zlasyf.c0000644000175000017500000001436412502221014016040 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlasyf_(char* uplo, integer* n, integer* nb, integer* kb, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* w, integer* ldw, integer* info);


static VALUE
rblapack_zlasyf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_nb;
  integer nb; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_kb;
  integer kb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  doublecomplex *w;

  integer lda;
  integer n;
  integer ldw;

  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  kb, ipiv, info, a = NumRu::Lapack.zlasyf( uplo, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZLASYF computes a partial factorization of a complex symmetric matrix\n*  A using the Bunch-Kaufman diagonal pivoting method. The partial\n*  factorization has the form:\n*\n*  A  =  ( I  U12 ) ( A11  0  ) (  I    0   )  if UPLO = 'U', or:\n*        ( 0  U22 ) (  0   D  ) ( U12' U22' )\n*\n*  A  =  ( L11  0 ) ( D    0  ) ( L11' L21' )  if UPLO = 'L'\n*        ( L21  I ) ( 0   A22 ) (  0    I   )\n*\n*  where the order of D is at most NB. The actual order is returned in\n*  the argument KB, and is either NB or NB-1, or N if N <= NB.\n*  Note that U' denotes the transpose of U.\n*\n*  ZLASYF is an auxiliary routine called by ZSYTRF. It uses blocked code\n*  (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or\n*  A22 (if UPLO = 'L').\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored:\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NB      (input) INTEGER\n*          The maximum number of columns of the matrix A that should be\n*          factored.  NB should be at least 2 to allow for 2-by-2 pivot\n*          blocks.\n*\n*  KB      (output) INTEGER\n*          The number of columns of A that were actually factored.\n*          KB is either NB-1 or NB, or N if N <= NB.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          n-by-n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n-by-n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*          On exit, A contains details of the partial factorization.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D.\n*          If UPLO = 'U', only the last KB elements of IPIV are set;\n*          if UPLO = 'L', only the first KB elements are set.\n*\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*  W       (workspace) COMPLEX*16 array, dimension (LDW,NB)\n*\n*  LDW     (input) INTEGER\n*          The leading dimension of the array W.  LDW >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          > 0: if INFO = k, D(k,k) is exactly zero.  The factorization\n*               has been completed, but the block diagonal matrix D is\n*               exactly singular.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  kb, ipiv, info, a = NumRu::Lapack.zlasyf( uplo, nb, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_nb = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  nb = NUM2INT(rblapack_nb);
  ldw = MAX(1,n);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  w = ALLOC_N(doublecomplex, (ldw)*(MAX(1,nb)));

  zlasyf_(&uplo, &n, &nb, &kb, a, &lda, ipiv, w, &ldw, &info);

  free(w);
  rblapack_kb = INT2NUM(kb);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_kb, rblapack_ipiv, rblapack_info, rblapack_a);
}

void
init_lapack_zlasyf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlasyf", rblapack_zlasyf, -1);
}
ruby-lapack-1.7.2/ext/zlatps.c0000644000175000017500000002437112502221013016043 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlatps_(char* uplo, char* trans, char* diag, char* normin, integer* n, doublecomplex* ap, doublecomplex* x, doublereal* scale, doublereal* cnorm, integer* info);


static VALUE
rblapack_zlatps(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_normin;
  char normin; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_cnorm;
  doublereal *cnorm; 
  VALUE rblapack_scale;
  doublereal scale; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;
  VALUE rblapack_cnorm_out__;
  doublereal *cnorm_out__;

  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  scale, info, x, cnorm = NumRu::Lapack.zlatps( uplo, trans, diag, normin, ap, x, cnorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, CNORM, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZLATPS solves one of the triangular systems\n*\n*     A * x = s*b,  A**T * x = s*b,  or  A**H * x = s*b,\n*\n*  with scaling to prevent overflow, where A is an upper or lower\n*  triangular matrix stored in packed form.  Here A**T denotes the\n*  transpose of A, A**H denotes the conjugate transpose of A, x and b\n*  are n-element vectors, and s is a scaling factor, usually less than\n*  or equal to 1, chosen so that the components of x will be less than\n*  the overflow threshold.  If the unscaled problem will not cause\n*  overflow, the Level 2 BLAS routine ZTPSV is called. If the matrix A\n*  is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n*  non-trivial solution to A*x = 0 is returned.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the matrix A is upper or lower triangular.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the operation applied to A.\n*          = 'N':  Solve A * x = s*b     (No transpose)\n*          = 'T':  Solve A**T * x = s*b  (Transpose)\n*          = 'C':  Solve A**H * x = s*b  (Conjugate transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          Specifies whether or not the matrix A is unit triangular.\n*          = 'N':  Non-unit triangular\n*          = 'U':  Unit triangular\n*\n*  NORMIN  (input) CHARACTER*1\n*          Specifies whether CNORM has been set or not.\n*          = 'Y':  CNORM contains the column norms on entry\n*          = 'N':  CNORM is not set on entry.  On exit, the norms will\n*                  be computed and stored in CNORM.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          The upper or lower triangular matrix A, packed columnwise in\n*          a linear array.  The j-th column of A is stored in the array\n*          AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  X       (input/output) COMPLEX*16 array, dimension (N)\n*          On entry, the right hand side b of the triangular system.\n*          On exit, X is overwritten by the solution vector x.\n*\n*  SCALE   (output) DOUBLE PRECISION\n*          The scaling factor s for the triangular system\n*             A * x = s*b,  A**T * x = s*b,  or  A**H * x = s*b.\n*          If SCALE = 0, the matrix A is singular or badly scaled, and\n*          the vector x is an exact or approximate solution to A*x = 0.\n*\n*  CNORM   (input or output) DOUBLE PRECISION array, dimension (N)\n*\n*          If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n*          contains the norm of the off-diagonal part of the j-th column\n*          of A.  If TRANS = 'N', CNORM(j) must be greater than or equal\n*          to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n*          must be greater than or equal to the 1-norm.\n*\n*          If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n*          returns the 1-norm of the offdiagonal part of the j-th column\n*          of A.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -k, the k-th argument had an illegal value\n*\n\n*  Further Details\n*  ======= =======\n*\n*  A rough bound on x is computed; if that is less than overflow, ZTPSV\n*  is called, otherwise, specific code is used which checks for possible\n*  overflow or divide-by-zero at every operation.\n*\n*  A columnwise scheme is used for solving A*x = b.  The basic algorithm\n*  if A is lower triangular is\n*\n*       x[1:n] := b[1:n]\n*       for j = 1, ..., n\n*            x(j) := x(j) / A(j,j)\n*            x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n*       end\n*\n*  Define bounds on the components of x after j iterations of the loop:\n*     M(j) = bound on x[1:j]\n*     G(j) = bound on x[j+1:n]\n*  Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n*  Then for iteration j+1 we have\n*     M(j+1) <= G(j) / | A(j+1,j+1) |\n*     G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n*            <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n*  where CNORM(j+1) is greater than or equal to the infinity-norm of\n*  column j+1 of A, not counting the diagonal.  Hence\n*\n*     G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n*                  1<=i<=j\n*  and\n*\n*     |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n*                                   1<=i< j\n*\n*  Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTPSV if the\n*  reciprocal of the largest M(j), j=1,..,n, is larger than\n*  max(underflow, 1/overflow).\n*\n*  The bound on x(j) is also used to determine when a step in the\n*  columnwise method can be performed without fear of overflow.  If\n*  the computed bound is greater than a large constant, x is scaled to\n*  prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n*  1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n*  Similarly, a row-wise scheme is used to solve A**T *x = b  or\n*  A**H *x = b.  The basic algorithm for A upper triangular is\n*\n*       for j = 1, ..., n\n*            x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n*       end\n*\n*  We simultaneously compute two bounds\n*       G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n*       M(j) = bound on x(i), 1<=i<=j\n*\n*  The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n*  add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n*  Then the bound on x(j) is\n*\n*       M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n*            <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n*                      1<=i<=j\n*\n*  and we can safely call ZTPSV if 1/M(n) and 1/G(n) are both greater\n*  than max(underflow, 1/overflow).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, info, x, cnorm = NumRu::Lapack.zlatps( uplo, trans, diag, normin, ap, x, cnorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_normin = argv[3];
  rblapack_ap = argv[4];
  rblapack_x = argv[5];
  rblapack_cnorm = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_cnorm))
    rb_raise(rb_eArgError, "cnorm (7th argument) must be NArray");
  if (NA_RANK(rblapack_cnorm) != 1)
    rb_raise(rb_eArgError, "rank of cnorm (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_cnorm) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of cnorm must be the same as shape 0 of x");
  if (NA_TYPE(rblapack_cnorm) != NA_DFLOAT)
    rblapack_cnorm = na_change_type(rblapack_cnorm, NA_DFLOAT);
  cnorm = NA_PTR_TYPE(rblapack_cnorm, doublereal*);
  normin = StringValueCStr(rblapack_normin)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_cnorm_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  cnorm_out__ = NA_PTR_TYPE(rblapack_cnorm_out__, doublereal*);
  MEMCPY(cnorm_out__, cnorm, doublereal, NA_TOTAL(rblapack_cnorm));
  rblapack_cnorm = rblapack_cnorm_out__;
  cnorm = cnorm_out__;

  zlatps_(&uplo, &trans, &diag, &normin, &n, ap, x, &scale, cnorm, &info);

  rblapack_scale = rb_float_new((double)scale);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_scale, rblapack_info, rblapack_x, rblapack_cnorm);
}

void
init_lapack_zlatps(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlatps", rblapack_zlatps, -1);
}
ruby-lapack-1.7.2/ext/sptcon.c0000644000175000017500000001031512502221015016027 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sptcon_(integer* n, real* d, real* e, real* anorm, real* rcond, real* work, integer* info);


static VALUE
rblapack_sptcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_anorm;
  real anorm; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_info;
  integer info; 
  real *work;

  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  rcond, info = NumRu::Lapack.sptcon( d, e, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPTCON( N, D, E, ANORM, RCOND, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPTCON computes the reciprocal of the condition number (in the\n*  1-norm) of a real symmetric positive definite tridiagonal matrix\n*  using the factorization A = L*D*L**T or A = U**T*D*U computed by\n*  SPTTRF.\n*\n*  Norm(inv(A)) is computed by a direct method, and the reciprocal of\n*  the condition number is computed as\n*               RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  D       (input) REAL array, dimension (N)\n*          The n diagonal elements of the diagonal matrix D from the\n*          factorization of A, as computed by SPTTRF.\n*\n*  E       (input) REAL array, dimension (N-1)\n*          The (n-1) off-diagonal elements of the unit bidiagonal factor\n*          U or L from the factorization of A,  as computed by SPTTRF.\n*\n*  ANORM   (input) REAL\n*          The 1-norm of the original matrix A.\n*\n*  RCOND   (output) REAL\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the\n*          1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) REAL array, dimension (N)\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 method used is described in Nicholas J. Higham, \"Efficient\n*  Algorithms for Computing the Condition Number of a Tridiagonal\n*  Matrix\", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.sptcon( d, e, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_d = argv[0];
  rblapack_e = argv[1];
  rblapack_anorm = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  anorm = (real)NUM2DBL(rblapack_anorm);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (2th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  work = ALLOC_N(real, (n));

  sptcon_(&n, d, e, &anorm, &rcond, work, &info);

  free(work);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_sptcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sptcon", rblapack_sptcon, -1);
}
ruby-lapack-1.7.2/ext/ztrttp.c0000644000175000017500000000735012502221025016076 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztrttp_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublecomplex* ap, integer* info);


static VALUE
rblapack_ztrttp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_info;
  integer info; 

  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  ap, info = NumRu::Lapack.ztrttp( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTRTTP( UPLO, N, A, LDA, AP, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTRTTP copies a triangular matrix A from full format (TR) to standard\n*  packed format (TP).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrices AP and A.  N >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the triangular matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AP      (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n*          On exit, the upper or lower triangular matrix A, packed\n*          columnwise in a linear array. The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ap, info = NumRu::Lapack.ztrttp( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = ( n*(n+1)/2 );
    rblapack_ap = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);

  ztrttp_(&uplo, &n, a, &lda, ap, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_ap, rblapack_info);
}

void
init_lapack_ztrttp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztrttp", rblapack_ztrttp, -1);
}
ruby-lapack-1.7.2/ext/slarrf.c0000644000175000017500000002260412655767576016062 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slarrf_(integer* n, real* d, real* l, real* ld, integer* clstrt, integer* clend, real* w, real* wgap, real* werr, real* spdiam, real* clgapl, real* clgapr, real* pivmin, real* sigma, real* dplus, real* lplus, real* work, integer* info);


static VALUE
rblapack_slarrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_l;
  real *l; 
  VALUE rblapack_ld;
  real *ld; 
  VALUE rblapack_clstrt;
  integer clstrt; 
  VALUE rblapack_clend;
  integer clend; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_wgap;
  real *wgap; 
  VALUE rblapack_werr;
  real *werr; 
  VALUE rblapack_spdiam;
  real spdiam; 
  VALUE rblapack_clgapl;
  real clgapl; 
  VALUE rblapack_clgapr;
  real clgapr; 
  VALUE rblapack_pivmin;
  real pivmin; 
  VALUE rblapack_sigma;
  real sigma; 
  VALUE rblapack_dplus;
  real *dplus; 
  VALUE rblapack_lplus;
  real *lplus; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_wgap_out__;
  real *wgap_out__;
  real *work;

  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  sigma, dplus, lplus, info, wgap = NumRu::Lapack.slarrf( d, l, ld, clstrt, clend, w, wgap, werr, spdiam, clgapl, clgapr, pivmin, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLARRF( N, D, L, LD, CLSTRT, CLEND, W, WGAP, WERR, SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA, DPLUS, LPLUS, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  Given the initial representation L D L^T and its cluster of close\n*  eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ...\n*  W( CLEND ), SLARRF finds a new relatively robust representation\n*  L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the\n*  eigenvalues of L(+) D(+) L(+)^T is relatively isolated.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix (subblock, if the matrix split).\n*\n*  D       (input) REAL array, dimension (N)\n*          The N diagonal elements of the diagonal matrix D.\n*\n*  L       (input) REAL array, dimension (N-1)\n*          The (N-1) subdiagonal elements of the unit bidiagonal\n*          matrix L.\n*\n*  LD      (input) REAL array, dimension (N-1)\n*          The (N-1) elements L(i)*D(i).\n*\n*  CLSTRT  (input) INTEGER\n*          The index of the first eigenvalue in the cluster.\n*\n*  CLEND   (input) INTEGER\n*          The index of the last eigenvalue in the cluster.\n*\n*  W       (input) REAL array, dimension\n*          dimension is >=  (CLEND-CLSTRT+1)\n*          The eigenvalue APPROXIMATIONS of L D L^T in ascending order.\n*          W( CLSTRT ) through W( CLEND ) form the cluster of relatively\n*          close eigenalues.\n*\n*  WGAP    (input/output) REAL array, dimension\n*          dimension is >=  (CLEND-CLSTRT+1)\n*          The separation from the right neighbor eigenvalue in W.\n*\n*  WERR    (input) REAL array, dimension\n*          dimension is >=  (CLEND-CLSTRT+1)\n*          WERR contain the semiwidth of the uncertainty\n*          interval of the corresponding eigenvalue APPROXIMATION in W\n*\n*  SPDIAM  (input) REAL\n*          estimate of the spectral diameter obtained from the\n*          Gerschgorin intervals\n*\n*  CLGAPL  (input) REAL\n*\n*  CLGAPR  (input) REAL\n*          absolute gap on each end of the cluster.\n*          Set by the calling routine to protect against shifts too close\n*          to eigenvalues outside the cluster.\n*\n*  PIVMIN  (input) REAL\n*          The minimum pivot allowed in the Sturm sequence.\n*\n*  SIGMA   (output) REAL            \n*          The shift used to form L(+) D(+) L(+)^T.\n*\n*  DPLUS   (output) REAL             array, dimension (N)\n*          The N diagonal elements of the diagonal matrix D(+).\n*\n*  LPLUS   (output) REAL             array, dimension (N-1)\n*          The first (N-1) elements of LPLUS contain the subdiagonal\n*          elements of the unit bidiagonal matrix L(+).\n*\n*  WORK    (workspace) REAL array, dimension (2*N)\n*          Workspace.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Beresford Parlett, University of California, Berkeley, USA\n*     Jim Demmel, University of California, Berkeley, USA\n*     Inderjit Dhillon, University of Texas, Austin, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sigma, dplus, lplus, info, wgap = NumRu::Lapack.slarrf( d, l, ld, clstrt, clend, w, wgap, werr, spdiam, clgapl, clgapr, pivmin, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_d = argv[0];
  rblapack_l = argv[1];
  rblapack_ld = argv[2];
  rblapack_clstrt = argv[3];
  rblapack_clend = argv[4];
  rblapack_w = argv[5];
  rblapack_wgap = argv[6];
  rblapack_werr = argv[7];
  rblapack_spdiam = argv[8];
  rblapack_clgapl = argv[9];
  rblapack_clgapr = argv[10];
  rblapack_pivmin = argv[11];
  if (argc == 12) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_ld))
    rb_raise(rb_eArgError, "ld (3th argument) must be NArray");
  if (NA_RANK(rblapack_ld) != 1)
    rb_raise(rb_eArgError, "rank of ld (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ld) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of ld must be %d", n-1);
  if (NA_TYPE(rblapack_ld) != NA_SFLOAT)
    rblapack_ld = na_change_type(rblapack_ld, NA_SFLOAT);
  ld = NA_PTR_TYPE(rblapack_ld, real*);
  clend = NUM2INT(rblapack_clend);
  spdiam = (real)NUM2DBL(rblapack_spdiam);
  clgapr = (real)NUM2DBL(rblapack_clgapr);
  if (!NA_IsNArray(rblapack_l))
    rb_raise(rb_eArgError, "l (2th argument) must be NArray");
  if (NA_RANK(rblapack_l) != 1)
    rb_raise(rb_eArgError, "rank of l (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_l) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of l must be %d", n-1);
  if (NA_TYPE(rblapack_l) != NA_SFLOAT)
    rblapack_l = na_change_type(rblapack_l, NA_SFLOAT);
  l = NA_PTR_TYPE(rblapack_l, real*);
  clgapl = (real)NUM2DBL(rblapack_clgapl);
  clstrt = NUM2INT(rblapack_clstrt);
  if (!NA_IsNArray(rblapack_wgap))
    rb_raise(rb_eArgError, "wgap (7th argument) must be NArray");
  if (NA_RANK(rblapack_wgap) != 1)
    rb_raise(rb_eArgError, "rank of wgap (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_wgap) != (clend-clstrt+1))
    rb_raise(rb_eRuntimeError, "shape 0 of wgap must be %d", clend-clstrt+1);
  if (NA_TYPE(rblapack_wgap) != NA_SFLOAT)
    rblapack_wgap = na_change_type(rblapack_wgap, NA_SFLOAT);
  wgap = NA_PTR_TYPE(rblapack_wgap, real*);
  pivmin = (real)NUM2DBL(rblapack_pivmin);
  if (!NA_IsNArray(rblapack_w))
    rb_raise(rb_eArgError, "w (6th argument) must be NArray");
  if (NA_RANK(rblapack_w) != 1)
    rb_raise(rb_eArgError, "rank of w (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_w) != (clend-clstrt+1))
    rb_raise(rb_eRuntimeError, "shape 0 of w must be %d", clend-clstrt+1);
  if (NA_TYPE(rblapack_w) != NA_SFLOAT)
    rblapack_w = na_change_type(rblapack_w, NA_SFLOAT);
  w = NA_PTR_TYPE(rblapack_w, real*);
  if (!NA_IsNArray(rblapack_werr))
    rb_raise(rb_eArgError, "werr (8th argument) must be NArray");
  if (NA_RANK(rblapack_werr) != 1)
    rb_raise(rb_eArgError, "rank of werr (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_werr) != (clend-clstrt+1))
    rb_raise(rb_eRuntimeError, "shape 0 of werr must be %d", clend-clstrt+1);
  if (NA_TYPE(rblapack_werr) != NA_SFLOAT)
    rblapack_werr = na_change_type(rblapack_werr, NA_SFLOAT);
  werr = NA_PTR_TYPE(rblapack_werr, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_dplus = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  dplus = NA_PTR_TYPE(rblapack_dplus, real*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_lplus = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  lplus = NA_PTR_TYPE(rblapack_lplus, real*);
  {
    na_shape_t shape[1];
    shape[0] = clend-clstrt+1;
    rblapack_wgap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  wgap_out__ = NA_PTR_TYPE(rblapack_wgap_out__, real*);
  MEMCPY(wgap_out__, wgap, real, NA_TOTAL(rblapack_wgap));
  rblapack_wgap = rblapack_wgap_out__;
  wgap = wgap_out__;
  work = ALLOC_N(real, (2*n));

  slarrf_(&n, d, l, ld, &clstrt, &clend, w, wgap, werr, &spdiam, &clgapl, &clgapr, &pivmin, &sigma, dplus, lplus, work, &info);

  free(work);
  rblapack_sigma = rb_float_new((double)sigma);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_sigma, rblapack_dplus, rblapack_lplus, rblapack_info, rblapack_wgap);
}

void
init_lapack_slarrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slarrf", rblapack_slarrf, -1);
}
ruby-lapack-1.7.2/ext/cunml2.c0000644000175000017500000001407712502221025015733 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cunml2_(char* side, char* trans, integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* c, integer* ldc, complex* work, integer* info);


static VALUE
rblapack_cunml2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_c;
  complex *c; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  complex *c_out__;
  complex *work;

  integer lda;
  integer m;
  integer k;
  integer ldc;
  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  info, c = NumRu::Lapack.cunml2( side, trans, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CUNML2 overwrites the general complex m-by-n matrix C with\n*\n*        Q * C  if SIDE = 'L' and TRANS = 'N', or\n*\n*        Q'* C  if SIDE = 'L' and TRANS = 'C', or\n*\n*        C * Q  if SIDE = 'R' and TRANS = 'N', or\n*\n*        C * Q' if SIDE = 'R' and TRANS = 'C',\n*\n*  where Q is a complex unitary matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(k)' . . . H(2)' H(1)'\n*\n*  as returned by CGELQF. Q is of order m if SIDE = 'L' and of order n\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q' from the Left\n*          = 'R': apply Q or Q' from the Right\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': apply Q  (No transpose)\n*          = 'C': apply Q' (Conjugate transpose)\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) COMPLEX array, dimension\n*                               (LDA,M) if SIDE = 'L',\n*                               (LDA,N) if SIDE = 'R'\n*          The i-th row must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          CGELQF in the first k rows of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,K).\n*\n*  TAU     (input) COMPLEX array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by CGELQF.\n*\n*  C       (input/output) COMPLEX array, dimension (LDC,N)\n*          On entry, the m-by-n matrix C.\n*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) COMPLEX array, dimension\n*                                   (N) if SIDE = 'L',\n*                                   (M) if SIDE = 'R'\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, c = NumRu::Lapack.cunml2( side, trans, a, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_a = argv[2];
  rblapack_tau = argv[3];
  rblapack_c = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, complex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
  MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(complex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  cunml2_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_c);
}

void
init_lapack_cunml2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cunml2", rblapack_cunml2, -1);
}
ruby-lapack-1.7.2/ext/cgerqf.c0000644000175000017500000001357712502221013016003 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgerqf_(integer* m, integer* n, complex* a, integer* lda, complex* tau, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_cgerqf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *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.cgerqf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGERQF computes an RQ factorization of a complex M-by-N matrix A:\n*  A = R * 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) COMPLEX array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit,\n*          if m <= n, the upper triangle of the subarray\n*          A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R;\n*          if m >= n, the elements on and above the (m-n)-th subdiagonal\n*          contain the M-by-N upper trapezoidal matrix R;\n*          the remaining elements, with the array TAU, represent the\n*          unitary matrix Q as a product of min(m,n) elementary\n*          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) COMPLEX array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace/output) COMPLEX 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\n*          the 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(1)' H(2)' . . . H(k)', 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 complex scalar, and v is a complex vector with\n*  v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on\n*  exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i).\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY\n      INTEGER            I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n     $                   MU, NB, NBMIN, NU, NX\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CGERQ2, CLARFB, CLARFT, 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.cgerqf( 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;
  }

  m = NUM2INT(rblapack_m);
  if (rblapack_lwork == Qnil)
    lwork = m;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  cgerqf_(&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_cgerqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgerqf", rblapack_cgerqf, -1);
}
ruby-lapack-1.7.2/ext/ctzrqf.c0000644000175000017500000001154412502221025016040 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctzrqf_(integer* m, integer* n, complex* a, integer* lda, complex* tau, integer* info);


static VALUE
rblapack_ctzrqf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;

  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.ctzrqf( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTZRQF( M, N, A, LDA, TAU, INFO )\n\n*  Purpose\n*  =======\n*\n*  This routine is deprecated and has been replaced by routine CTZRZF.\n*\n*  CTZRQF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A\n*  to upper triangular form by means of unitary transformations.\n*\n*  The upper trapezoidal matrix A is factored as\n*\n*     A = ( R  0 ) * Z,\n*\n*  where Z is an N-by-N unitary matrix and R is an M-by-M upper\n*  triangular matrix.\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 >= M.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the leading M-by-N upper trapezoidal part of the\n*          array A must contain the matrix to be factorized.\n*          On exit, the leading M-by-M upper triangular part of A\n*          contains the upper triangular matrix R, and elements M+1 to\n*          N of the first M rows of A, with the array TAU, represent the\n*          unitary matrix Z as a product of M elementary reflectors.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  TAU     (output) COMPLEX array, dimension (M)\n*          The scalar factors of the elementary reflectors.\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  factorization is obtained by Householder's method.  The kth\n*  transformation matrix, Z( k ), whose conjugate transpose is used to\n*  introduce zeros into the (m - k + 1)th row of A, is given in the form\n*\n*     Z( k ) = ( I     0   ),\n*              ( 0  T( k ) )\n*\n*  where\n*\n*     T( k ) = I - tau*u( k )*u( k )',   u( k ) = (   1    ),\n*                                                 (   0    )\n*                                                 ( z( k ) )\n*\n*  tau is a scalar and z( k ) is an ( n - m ) element vector.\n*  tau and z( k ) are chosen to annihilate the elements of the kth row\n*  of X.\n*\n*  The scalar tau is returned in the kth element of TAU and the vector\n*  u( k ) in the kth row of A, such that the elements of z( k ) are\n*  in  a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n*  the upper triangular part of A.\n*\n*  Z is given by\n*\n*     Z =  Z( 1 ) * Z( 2 ) * ... * Z( m ).\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.ctzrqf( 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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  m = lda;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  ctzrqf_(&m, &n, a, &lda, tau, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_tau, rblapack_info, rblapack_a);
}

void
init_lapack_ctzrqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctzrqf", rblapack_ctzrqf, -1);
}
ruby-lapack-1.7.2/ext/slascl2.c0000644000175000017500000000646212502221017016076 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slascl2_(integer* m, integer* n, real* d, real* x, integer* ldx);


static VALUE
rblapack_slascl2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_x_out__;
  real *x_out__;

  integer m;
  integer ldx;
  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  x = NumRu::Lapack.slascl2( d, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASCL2 ( M, N, D, X, LDX )\n\n*  Purpose\n*  =======\n*\n*  SLASCL2 performs a diagonal scaling on a vector:\n*    x <-- D * x\n*  where the diagonal matrix D is stored as a vector.\n*\n*  Eventually to be replaced by BLAS_sge_diag_scale in the new BLAS\n*  standard.\n*\n\n*  Arguments\n*  =========\n*\n*     M       (input) INTEGER\n*     The number of rows of D and X. M >= 0.\n*\n*     N       (input) INTEGER\n*     The number of columns of D and X. N >= 0.\n*\n*     D       (input) REAL array, length M\n*     Diagonal matrix D, stored as a vector of length M.\n*\n*     X       (input/output) REAL array, dimension (LDX,N)\n*     On entry, the vector X to be scaled by D.\n*     On exit, the scaled vector.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the vector X. LDX >= 0.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x = NumRu::Lapack.slascl2( d, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_d = argv[0];
  rblapack_x = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  n = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = n;
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;

  slascl2_(&m, &n, d, x, &ldx);

  return rblapack_x;
}

void
init_lapack_slascl2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slascl2", rblapack_slascl2, -1);
}
ruby-lapack-1.7.2/ext/dpbequ.c0000644000175000017500000001155112502221022016002 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dpbequ_(char* uplo, integer* n, integer* kd, doublereal* ab, integer* ldab, doublereal* s, doublereal* scond, doublereal* amax, integer* info);


static VALUE
rblapack_dpbequ(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_scond;
  doublereal scond; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_info;
  integer info; 

  integer ldab;
  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  s, scond, amax, info = NumRu::Lapack.dpbequ( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPBEQU computes row and column scalings intended to equilibrate a\n*  symmetric positive definite band matrix A and reduce its condition\n*  number (with respect to the two-norm).  S contains the scale factors,\n*  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n*  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This\n*  choice of S puts the condition number of B within a factor N of the\n*  smallest possible condition number over all possible diagonal\n*  scalings.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangular of A is stored;\n*          = 'L':  Lower triangular of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)\n*          The upper or lower triangle of the symmetric band matrix A,\n*          stored in the first KD+1 rows of the array.  The j-th column\n*          of A is stored in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array A.  LDAB >= KD+1.\n*\n*  S       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, S contains the scale factors for A.\n*\n*  SCOND   (output) DOUBLE PRECISION\n*          If INFO = 0, S contains the ratio of the smallest S(i) to\n*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too\n*          large nor too small, it is not worth scaling by S.\n*\n*  AMAX    (output) DOUBLE PRECISION\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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 is nonpositive.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, scond, amax, info = NumRu::Lapack.dpbequ( uplo, kd, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  kd = NUM2INT(rblapack_kd);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, doublereal*);

  dpbequ_(&uplo, &n, &kd, ab, &ldab, s, &scond, &amax, &info);

  rblapack_scond = rb_float_new((double)scond);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
}

void
init_lapack_dpbequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dpbequ", rblapack_dpbequ, -1);
}
ruby-lapack-1.7.2/ext/zdrscl.c0000644000175000017500000000642312502221016016030 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zdrscl_(integer* n, doublereal* sa, doublecomplex* sx, integer* incx);


static VALUE
rblapack_zdrscl(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_sa;
  doublereal sa; 
  VALUE rblapack_sx;
  doublecomplex *sx; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_sx_out__;
  doublecomplex *sx_out__;


  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  sx = NumRu::Lapack.zdrscl( n, sa, sx, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZDRSCL( N, SA, SX, INCX )\n\n*  Purpose\n*  =======\n*\n*  ZDRSCL multiplies an n-element complex vector x by the real scalar\n*  1/a.  This is done without overflow or underflow as long as\n*  the final result x/a does not overflow or underflow.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of components of the vector x.\n*\n*  SA      (input) DOUBLE PRECISION\n*          The scalar a which is used to divide each component of x.\n*          SA must be >= 0, or the subroutine will divide by zero.\n*\n*  SX      (input/output) COMPLEX*16 array, dimension\n*                         (1+(N-1)*abs(INCX))\n*          The n-element vector x.\n*\n*  INCX    (input) INTEGER\n*          The increment between successive values of the vector SX.\n*          > 0:  SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i),     1< i<= n\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sx = NumRu::Lapack.zdrscl( n, sa, sx, incx, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_n = argv[0];
  rblapack_sa = argv[1];
  rblapack_sx = argv[2];
  rblapack_incx = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  incx = NUM2INT(rblapack_incx);
  sa = NUM2DBL(rblapack_sa);
  if (!NA_IsNArray(rblapack_sx))
    rb_raise(rb_eArgError, "sx (3th argument) must be NArray");
  if (NA_RANK(rblapack_sx) != 1)
    rb_raise(rb_eArgError, "rank of sx (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_sx) != (1+(n-1)*abs(incx)))
    rb_raise(rb_eRuntimeError, "shape 0 of sx must be %d", 1+(n-1)*abs(incx));
  if (NA_TYPE(rblapack_sx) != NA_DCOMPLEX)
    rblapack_sx = na_change_type(rblapack_sx, NA_DCOMPLEX);
  sx = NA_PTR_TYPE(rblapack_sx, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*abs(incx);
    rblapack_sx_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  sx_out__ = NA_PTR_TYPE(rblapack_sx_out__, doublecomplex*);
  MEMCPY(sx_out__, sx, doublecomplex, NA_TOTAL(rblapack_sx));
  rblapack_sx = rblapack_sx_out__;
  sx = sx_out__;

  zdrscl_(&n, &sa, sx, &incx);

  return rblapack_sx;
}

void
init_lapack_zdrscl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zdrscl", rblapack_zdrscl, -1);
}
ruby-lapack-1.7.2/ext/cpteqr.c0000644000175000017500000001642112502221017016025 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cpteqr_(char* compz, integer* n, real* d, real* e, complex* z, integer* ldz, real* work, integer* info);


static VALUE
rblapack_cpteqr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_compz;
  char compz; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_e_out__;
  real *e_out__;
  VALUE rblapack_z_out__;
  complex *z_out__;
  real *work;

  integer n;
  integer ldz;

  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  info, d, e, z = NumRu::Lapack.cpteqr( compz, d, e, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPTEQR computes all eigenvalues and, optionally, eigenvectors of a\n*  symmetric positive definite tridiagonal matrix by first factoring the\n*  matrix using SPTTRF and then calling CBDSQR to compute the singular\n*  values of the bidiagonal factor.\n*\n*  This routine computes the eigenvalues of the positive definite\n*  tridiagonal matrix to high relative accuracy.  This means that if the\n*  eigenvalues range over many orders of magnitude in size, then the\n*  small eigenvalues and corresponding eigenvectors will be computed\n*  more accurately than, for example, with the standard QR method.\n*\n*  The eigenvectors of a full or band positive definite Hermitian matrix\n*  can also be found if CHETRD, CHPTRD, or CHBTRD has been used to\n*  reduce this matrix to tridiagonal form.  (The reduction to\n*  tridiagonal form, however, may preclude the possibility of obtaining\n*  high relative accuracy in the small eigenvalues of the original\n*  matrix, if these eigenvalues range over many orders of magnitude.)\n*\n\n*  Arguments\n*  =========\n*\n*  COMPZ   (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only.\n*          = 'V':  Compute eigenvectors of original Hermitian\n*                  matrix also.  Array Z contains the unitary matrix\n*                  used to reduce the original matrix to tridiagonal\n*                  form.\n*          = 'I':  Compute eigenvectors of tridiagonal matrix also.\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  D       (input/output) REAL array, dimension (N)\n*          On entry, the n diagonal elements of the tridiagonal matrix.\n*          On normal exit, D contains the eigenvalues, in descending\n*          order.\n*\n*  E       (input/output) REAL array, dimension (N-1)\n*          On entry, the (n-1) subdiagonal elements of the tridiagonal\n*          matrix.\n*          On exit, E has been destroyed.\n*\n*  Z       (input/output) COMPLEX array, dimension (LDZ, N)\n*          On entry, if COMPZ = 'V', the unitary matrix used in the\n*          reduction to tridiagonal form.\n*          On exit, if COMPZ = 'V', the orthonormal eigenvectors of the\n*          original Hermitian matrix;\n*          if COMPZ = 'I', the orthonormal eigenvectors of the\n*          tridiagonal matrix.\n*          If INFO > 0 on exit, Z contains the eigenvectors associated\n*          with only the stored eigenvalues.\n*          If  COMPZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          COMPZ = 'V' or 'I', LDZ >= max(1,N).\n*\n*  WORK    (workspace) REAL array, dimension (4*N)\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, and i is:\n*                <= N  the Cholesky factorization of the matrix could\n*                      not be performed because the i-th principal minor\n*                      was not positive definite.\n*                > N   the SVD algorithm failed to converge;\n*                      if INFO = N+i, i off-diagonal elements of the\n*                      bidiagonal factor did not converge to zero.\n*\n\n*  ====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, e, z = NumRu::Lapack.cpteqr( compz, d, e, z, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_compz = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  rblapack_z = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  compz = StringValueCStr(rblapack_compz)[0];
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (4th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  n = NA_SHAPE1(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, complex*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of z");
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
  MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
  MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  work = ALLOC_N(real, (4*n));

  cpteqr_(&compz, &n, d, e, z, &ldz, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_e, rblapack_z);
}

void
init_lapack_cpteqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cpteqr", rblapack_cpteqr, -1);
}
ruby-lapack-1.7.2/ext/chetrf.c0000644000175000017500000001750512502221014016003 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chetrf_(char* uplo, integer* n, complex* a, integer* lda, integer* ipiv, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_chetrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *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  ipiv, work, info, a = NumRu::Lapack.chetrf( uplo, a, lwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHETRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHETRF computes the factorization of a complex Hermitian matrix A\n*  using the Bunch-Kaufman diagonal pivoting method.  The form of the\n*  factorization is\n*\n*     A = U*D*U**H  or  A = L*D*L**H\n*\n*  where U (or L) is a product of permutation and unit upper (lower)\n*  triangular matrices, and D is Hermitian and block diagonal with \n*  1-by-1 and 2-by-2 diagonal blocks.\n*\n*  This is the blocked version of the algorithm, calling Level 3 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L (see below for further details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D.\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*  WORK    (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of WORK.  LWORK >=1.  For best performance\n*          LWORK >= N*NB, where NB is the block size returned by ILAENV.\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, D(i,i) is exactly zero.  The factorization\n*                has been completed, but the block diagonal matrix D is\n*                exactly singular, and division by zero will occur if it\n*                is used to solve a system of equations.\n*\n\n*  Further Details\n*  ===============\n*\n*  If UPLO = 'U', then A = U*D*U', where\n*     U = P(n)*U(n)* ... *P(k)U(k)* ...,\n*  i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n*  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    v    0   )   k-s\n*     U(k) =  (   0    I    0   )   s\n*             (   0    0    I   )   n-k\n*                k-s   s   n-k\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n*  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n*  and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n*  If UPLO = 'L', then A = L*D*L', where\n*     L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n*  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n*  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    0     0   )  k-1\n*     L(k) =  (   0    I     0   )  s\n*             (   0    v     I   )  n-k-s+1\n*                k-1   s  n-k-s+1\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n*  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n*  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY, UPPER\n      INTEGER            IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            ILAENV\n      EXTERNAL           LSAME, ILAENV\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CHETF2, CLAHEF, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, work, info, a = NumRu::Lapack.chetrf( uplo, a, lwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_lwork = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  lwork = NUM2INT(rblapack_lwork);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  chetrf_(&uplo, &n, a, &lda, ipiv, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ipiv, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_chetrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chetrf", rblapack_chetrf, -1);
}
ruby-lapack-1.7.2/ext/spbtrf.c0000644000175000017500000001207112502221024016022 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID spbtrf_(char* uplo, integer* n, integer* kd, real* ab, integer* ldab, integer* info);


static VALUE
rblapack_spbtrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  real *ab_out__;

  integer ldab;
  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  info, ab = NumRu::Lapack.spbtrf( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPBTRF( UPLO, N, KD, AB, LDAB, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPBTRF computes the Cholesky factorization of a real symmetric\n*  positive definite band matrix A.\n*\n*  The factorization has the form\n*     A = U**T * U,  if UPLO = 'U', or\n*     A = L  * L**T,  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is lower triangular.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) REAL array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*          On exit, if INFO = 0, the triangular factor U or L from the\n*          Cholesky factorization A = U**T*U or A = L*L**T of the band\n*          matrix A, in the same storage format as A.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\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 leading minor of order i is not\n*                positive definite, and the factorization could not be\n*                completed.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  N = 6, KD = 2, and UPLO = 'U':\n*\n*  On entry:                       On exit:\n*\n*      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46\n*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56\n*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66\n*\n*  Similarly, if UPLO = 'L' the format of A is as follows:\n*\n*  On entry:                       On exit:\n*\n*     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66\n*     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *\n*     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *\n*\n*  Array elements marked * are not used by the routine.\n*\n*  Contributed by\n*  Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ab = NumRu::Lapack.spbtrf( uplo, kd, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  kd = NUM2INT(rblapack_kd);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
  MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  spbtrf_(&uplo, &n, &kd, ab, &ldab, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ab);
}

void
init_lapack_spbtrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "spbtrf", rblapack_spbtrf, -1);
}
ruby-lapack-1.7.2/ext/cgesv.c0000644000175000017500000001265312502221020015633 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgesv_(integer* n, integer* nrhs, complex* a, integer* lda, integer* ipiv, complex* b, integer* ldb, integer* info);


static VALUE
rblapack_cgesv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  ipiv, info, a, b = NumRu::Lapack.cgesv( a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGESV computes the solution to a complex system of linear equations\n*     A * X = B,\n*  where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n*  The LU decomposition with partial pivoting and row interchanges is\n*  used to factor A as\n*     A = P * L * U,\n*  where P is a permutation matrix, L is unit lower triangular, and U is\n*  upper triangular.  The factored form of A is then used to solve the\n*  system of equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the N-by-N coefficient matrix A.\n*          On exit, the factors L and U from the factorization\n*          A = P*L*U; the unit diagonal elements of L are not stored.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          The pivot indices that define the permutation matrix P;\n*          row i of the matrix was interchanged with row IPIV(i).\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS matrix of right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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, U(i,i) is exactly zero.  The factorization\n*                has been completed, but the factor U is exactly\n*                singular, so the solution could not be computed.\n*\n\n*  =====================================================================\n*\n*     .. External Subroutines ..\n      EXTERNAL           CGETRF, CGETRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, a, b = NumRu::Lapack.cgesv( a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  if (argc == 2) {
  } 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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  cgesv_(&n, &nrhs, a, &lda, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ipiv, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_cgesv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgesv", rblapack_cgesv, -1);
}
ruby-lapack-1.7.2/ext/dlas2.c0000644000175000017500000000632412502221025015534 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlas2_(doublereal* f, doublereal* g, doublereal* h, doublereal* ssmin, doublereal* ssmax);


static VALUE
rblapack_dlas2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_f;
  doublereal f; 
  VALUE rblapack_g;
  doublereal g; 
  VALUE rblapack_h;
  doublereal h; 
  VALUE rblapack_ssmin;
  doublereal ssmin; 
  VALUE rblapack_ssmax;
  doublereal ssmax; 


  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  ssmin, ssmax = NumRu::Lapack.dlas2( f, g, h, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX )\n\n*  Purpose\n*  =======\n*\n*  DLAS2  computes the singular values of the 2-by-2 matrix\n*     [  F   G  ]\n*     [  0   H  ].\n*  On return, SSMIN is the smaller singular value and SSMAX is the\n*  larger singular value.\n*\n\n*  Arguments\n*  =========\n*\n*  F       (input) DOUBLE PRECISION\n*          The (1,1) element of the 2-by-2 matrix.\n*\n*  G       (input) DOUBLE PRECISION\n*          The (1,2) element of the 2-by-2 matrix.\n*\n*  H       (input) DOUBLE PRECISION\n*          The (2,2) element of the 2-by-2 matrix.\n*\n*  SSMIN   (output) DOUBLE PRECISION\n*          The smaller singular value.\n*\n*  SSMAX   (output) DOUBLE PRECISION\n*          The larger singular value.\n*\n\n*  Further Details\n*  ===============\n*\n*  Barring over/underflow, all output quantities are correct to within\n*  a few units in the last place (ulps), even in the absence of a guard\n*  digit in addition/subtraction.\n*\n*  In IEEE arithmetic, the code works correctly if one matrix element is\n*  infinite.\n*\n*  Overflow will not occur unless the largest singular value itself\n*  overflows, or is within a few ulps of overflow. (On machines with\n*  partial overflow, like the Cray, overflow may occur if the largest\n*  singular value is within a factor of 2 of overflow.)\n*\n*  Underflow is harmless if underflow is gradual. Otherwise, results\n*  may correspond to a matrix modified by perturbations of size near\n*  the underflow threshold.\n*\n*  ====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ssmin, ssmax = NumRu::Lapack.dlas2( f, g, h, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_f = argv[0];
  rblapack_g = argv[1];
  rblapack_h = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  f = NUM2DBL(rblapack_f);
  h = NUM2DBL(rblapack_h);
  g = NUM2DBL(rblapack_g);

  dlas2_(&f, &g, &h, &ssmin, &ssmax);

  rblapack_ssmin = rb_float_new((double)ssmin);
  rblapack_ssmax = rb_float_new((double)ssmax);
  return rb_ary_new3(2, rblapack_ssmin, rblapack_ssmax);
}

void
init_lapack_dlas2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlas2", rblapack_dlas2, -1);
}
ruby-lapack-1.7.2/ext/slasd3.c0000644000175000017500000002662312502221020015717 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slasd3_(integer* nl, integer* nr, integer* sqre, integer* k, real* d, real* q, integer* ldq, real* dsigma, real* u, integer* ldu, real* u2, integer* ldu2, real* vt, integer* ldvt, real* vt2, integer* ldvt2, integer* idxc, integer* ctot, real* z, integer* info);


static VALUE
rblapack_slasd3(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_nl;
  integer nl; 
  VALUE rblapack_nr;
  integer nr; 
  VALUE rblapack_sqre;
  integer sqre; 
  VALUE rblapack_dsigma;
  real *dsigma; 
  VALUE rblapack_u2;
  real *u2; 
  VALUE rblapack_vt2;
  real *vt2; 
  VALUE rblapack_idxc;
  integer *idxc; 
  VALUE rblapack_ctot;
  integer *ctot; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_u;
  real *u; 
  VALUE rblapack_vt;
  real *vt; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_dsigma_out__;
  real *dsigma_out__;
  VALUE rblapack_vt2_out__;
  real *vt2_out__;
  VALUE rblapack_z_out__;
  real *z_out__;
  real *q;

  integer k;
  integer ldu2;
  integer n;
  integer ldvt2;
  integer ldu;
  integer ldvt;
  integer m;
  integer ldq;

  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  d, u, vt, info, dsigma, vt2, z = NumRu::Lapack.slasd3( nl, nr, sqre, dsigma, u2, vt2, idxc, ctot, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASD3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2, LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLASD3 finds all the square roots of the roots of the secular\n*  equation, as defined by the values in D and Z.  It makes the\n*  appropriate calls to SLASD4 and then updates the singular\n*  vectors by matrix multiplication.\n*\n*  This code makes very mild assumptions about floating point\n*  arithmetic. It will work on machines with a guard digit in\n*  add/subtract, or on those binary machines without guard digits\n*  which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.\n*  It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n*  SLASD3 is called from SLASD1.\n*\n\n*  Arguments\n*  =========\n*\n*  NL     (input) INTEGER\n*         The row dimension of the upper block.  NL >= 1.\n*\n*  NR     (input) INTEGER\n*         The row dimension of the lower block.  NR >= 1.\n*\n*  SQRE   (input) INTEGER\n*         = 0: the lower block is an NR-by-NR square matrix.\n*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n*         The bidiagonal matrix has N = NL + NR + 1 rows and\n*         M = N + SQRE >= N columns.\n*\n*  K      (input) INTEGER\n*         The size of the secular equation, 1 =< K = < N.\n*\n*  D      (output) REAL array, dimension(K)\n*         On exit the square roots of the roots of the secular equation,\n*         in ascending order.\n*\n*  Q      (workspace) REAL array,\n*                     dimension at least (LDQ,K).\n*\n*  LDQ    (input) INTEGER\n*         The leading dimension of the array Q.  LDQ >= K.\n*\n*  DSIGMA (input/output) REAL array, dimension(K)\n*         The first K elements of this array contain the old roots\n*         of the deflated updating problem.  These are the poles\n*         of the secular equation.\n*\n*  U      (output) REAL array, dimension (LDU, N)\n*         The last N - K columns of this matrix contain the deflated\n*         left singular vectors.\n*\n*  LDU    (input) INTEGER\n*         The leading dimension of the array U.  LDU >= N.\n*\n*  U2     (input) REAL array, dimension (LDU2, N)\n*         The first K columns of this matrix contain the non-deflated\n*         left singular vectors for the split problem.\n*\n*  LDU2   (input) INTEGER\n*         The leading dimension of the array U2.  LDU2 >= N.\n*\n*  VT     (output) REAL array, dimension (LDVT, M)\n*         The last M - K columns of VT' contain the deflated\n*         right singular vectors.\n*\n*  LDVT   (input) INTEGER\n*         The leading dimension of the array VT.  LDVT >= N.\n*\n*  VT2    (input/output) REAL array, dimension (LDVT2, N)\n*         The first K columns of VT2' contain the non-deflated\n*         right singular vectors for the split problem.\n*\n*  LDVT2  (input) INTEGER\n*         The leading dimension of the array VT2.  LDVT2 >= N.\n*\n*  IDXC   (input) INTEGER array, dimension (N)\n*         The permutation used to arrange the columns of U (and rows of\n*         VT) into three groups:  the first group contains non-zero\n*         entries only at and above (or before) NL +1; the second\n*         contains non-zero entries only at and below (or after) NL+2;\n*         and the third is dense. The first column of U and the row of\n*         VT are treated separately, however.\n*\n*         The rows of the singular vectors found by SLASD4\n*         must be likewise permuted before the matrix multiplies can\n*         take place.\n*\n*  CTOT   (input) INTEGER array, dimension (4)\n*         A count of the total number of the various types of columns\n*         in U (or rows in VT), as described in IDXC. The fourth column\n*         type is any column which has been deflated.\n*\n*  Z      (input/output) REAL array, dimension (K)\n*         The first K elements of this array contain the components\n*         of the deflation-adjusted updating row vector.\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 = 1, a singular value did not converge\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, u, vt, info, dsigma, vt2, z = NumRu::Lapack.slasd3( nl, nr, sqre, dsigma, u2, vt2, idxc, ctot, z, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_nl = argv[0];
  rblapack_nr = argv[1];
  rblapack_sqre = argv[2];
  rblapack_dsigma = argv[3];
  rblapack_u2 = argv[4];
  rblapack_vt2 = argv[5];
  rblapack_idxc = argv[6];
  rblapack_ctot = argv[7];
  rblapack_z = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  nl = NUM2INT(rblapack_nl);
  sqre = NUM2INT(rblapack_sqre);
  if (!NA_IsNArray(rblapack_ctot))
    rb_raise(rb_eArgError, "ctot (8th argument) must be NArray");
  if (NA_RANK(rblapack_ctot) != 1)
    rb_raise(rb_eArgError, "rank of ctot (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ctot) != (4))
    rb_raise(rb_eRuntimeError, "shape 0 of ctot must be %d", 4);
  if (NA_TYPE(rblapack_ctot) != NA_LINT)
    rblapack_ctot = na_change_type(rblapack_ctot, NA_LINT);
  ctot = NA_PTR_TYPE(rblapack_ctot, integer*);
  nr = NUM2INT(rblapack_nr);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (9th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  n = nl + nr + 1;
  ldvt = n;
  ldu = n;
  if (!NA_IsNArray(rblapack_dsigma))
    rb_raise(rb_eArgError, "dsigma (4th argument) must be NArray");
  if (NA_RANK(rblapack_dsigma) != 1)
    rb_raise(rb_eArgError, "rank of dsigma (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dsigma) != k)
    rb_raise(rb_eRuntimeError, "shape 0 of dsigma must be the same as shape 0 of z");
  if (NA_TYPE(rblapack_dsigma) != NA_SFLOAT)
    rblapack_dsigma = na_change_type(rblapack_dsigma, NA_SFLOAT);
  dsigma = NA_PTR_TYPE(rblapack_dsigma, real*);
  if (!NA_IsNArray(rblapack_idxc))
    rb_raise(rb_eArgError, "idxc (7th argument) must be NArray");
  if (NA_RANK(rblapack_idxc) != 1)
    rb_raise(rb_eArgError, "rank of idxc (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_idxc) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of idxc must be nl + nr + 1");
  if (NA_TYPE(rblapack_idxc) != NA_LINT)
    rblapack_idxc = na_change_type(rblapack_idxc, NA_LINT);
  idxc = NA_PTR_TYPE(rblapack_idxc, integer*);
  ldq = k;
  ldvt2 = n;
  if (!NA_IsNArray(rblapack_vt2))
    rb_raise(rb_eArgError, "vt2 (6th argument) must be NArray");
  if (NA_RANK(rblapack_vt2) != 2)
    rb_raise(rb_eArgError, "rank of vt2 (6th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_vt2) != ldvt2)
    rb_raise(rb_eRuntimeError, "shape 0 of vt2 must be n");
  if (NA_SHAPE1(rblapack_vt2) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of vt2 must be nl + nr + 1");
  if (NA_TYPE(rblapack_vt2) != NA_SFLOAT)
    rblapack_vt2 = na_change_type(rblapack_vt2, NA_SFLOAT);
  vt2 = NA_PTR_TYPE(rblapack_vt2, real*);
  ldu2 = n;
  if (!NA_IsNArray(rblapack_u2))
    rb_raise(rb_eArgError, "u2 (5th argument) must be NArray");
  if (NA_RANK(rblapack_u2) != 2)
    rb_raise(rb_eArgError, "rank of u2 (5th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_u2) != ldu2)
    rb_raise(rb_eRuntimeError, "shape 0 of u2 must be n");
  if (NA_SHAPE1(rblapack_u2) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of u2 must be nl + nr + 1");
  if (NA_TYPE(rblapack_u2) != NA_SFLOAT)
    rblapack_u2 = na_change_type(rblapack_u2, NA_SFLOAT);
  u2 = NA_PTR_TYPE(rblapack_u2, real*);
  m = n+sqre;
  {
    na_shape_t shape[1];
    shape[0] = k;
    rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = n;
    rblapack_u = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  u = NA_PTR_TYPE(rblapack_u, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldvt;
    shape[1] = m;
    rblapack_vt = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vt = NA_PTR_TYPE(rblapack_vt, real*);
  {
    na_shape_t shape[1];
    shape[0] = k;
    rblapack_dsigma_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  dsigma_out__ = NA_PTR_TYPE(rblapack_dsigma_out__, real*);
  MEMCPY(dsigma_out__, dsigma, real, NA_TOTAL(rblapack_dsigma));
  rblapack_dsigma = rblapack_dsigma_out__;
  dsigma = dsigma_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvt2;
    shape[1] = n;
    rblapack_vt2_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vt2_out__ = NA_PTR_TYPE(rblapack_vt2_out__, real*);
  MEMCPY(vt2_out__, vt2, real, NA_TOTAL(rblapack_vt2));
  rblapack_vt2 = rblapack_vt2_out__;
  vt2 = vt2_out__;
  {
    na_shape_t shape[1];
    shape[0] = k;
    rblapack_z_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
  MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  q = ALLOC_N(real, (ldq)*(k));

  slasd3_(&nl, &nr, &sqre, &k, d, q, &ldq, dsigma, u, &ldu, u2, &ldu2, vt, &ldvt, vt2, &ldvt2, idxc, ctot, z, &info);

  free(q);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_d, rblapack_u, rblapack_vt, rblapack_info, rblapack_dsigma, rblapack_vt2, rblapack_z);
}

void
init_lapack_slasd3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slasd3", rblapack_slasd3, -1);
}
ruby-lapack-1.7.2/ext/chpgvx.c0000644000175000017500000003046512502221020016024 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chpgvx_(integer* itype, char* jobz, char* range, char* uplo, integer* n, complex* ap, complex* bp, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, complex* z, integer* ldz, complex* work, real* rwork, integer* iwork, integer* ifail, integer* info);


static VALUE
rblapack_chpgvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_bp;
  complex *bp; 
  VALUE rblapack_vl;
  real vl; 
  VALUE rblapack_vu;
  real vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  real abstol; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_ifail;
  integer *ifail; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  complex *ap_out__;
  VALUE rblapack_bp_out__;
  complex *bp_out__;
  complex *work;
  real *rwork;
  integer *iwork;

  integer ldap;
  integer n;
  integer ldz;

  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  m, w, z, ifail, info, ap, bp = NumRu::Lapack.chpgvx( itype, jobz, range, uplo, ap, bp, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHPGVX computes selected eigenvalues and, optionally, eigenvectors\n*  of a complex generalized Hermitian-definite eigenproblem, of the form\n*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A and\n*  B are assumed to be Hermitian, stored in packed format, and B is also\n*  positive definite.  Eigenvalues and eigenvectors can be selected by\n*  specifying either a range of values or a range of indices for the\n*  desired eigenvalues.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          Specifies the problem type to be solved:\n*          = 1:  A*x = (lambda)*B*x\n*          = 2:  A*B*x = (lambda)*x\n*          = 3:  B*A*x = (lambda)*x\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found;\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found;\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, the contents of AP are destroyed.\n*\n*  BP      (input/output) COMPLEX array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          B, packed columnwise in a linear array.  The j-th column of B\n*          is stored in the array BP as follows:\n*          if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n*          if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n*          On exit, the triangular factor U or L from the Cholesky\n*          factorization B = U**H*U or B = L*L**H, in the same storage\n*          format as B.\n*\n*  VL      (input) REAL\n*  VU      (input) REAL\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) REAL\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less than\n*          or equal to zero, then  EPS*|T|  will be used in its place,\n*          where |T| is the 1-norm of the tridiagonal matrix obtained\n*          by reducing AP to tridiagonal form.\n*\n*          Eigenvalues will be computed most accurately when ABSTOL is\n*          set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n*          If this routine returns with INFO>0, indicating that some\n*          eigenvectors did not converge, try setting ABSTOL to\n*          2*SLAMCH('S').\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) REAL array, dimension (N)\n*          On normal exit, the first M elements contain the selected\n*          eigenvalues in ascending order.\n*\n*  Z       (output) COMPLEX array, dimension (LDZ, N)\n*          If JOBZ = 'N', then Z is not referenced.\n*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix A\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          The eigenvectors are normalized as follows:\n*          if ITYPE = 1 or 2, Z**H*B*Z = I;\n*          if ITYPE = 3, Z**H*inv(B)*Z = I.\n*\n*          If an eigenvector fails to converge, then that column of Z\n*          contains the latest approximation to the eigenvector, and the\n*          index of the eigenvector is returned in IFAIL.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (7*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (5*N)\n*\n*  IFAIL   (output) INTEGER array, dimension (N)\n*          If JOBZ = 'V', then if INFO = 0, the first M elements of\n*          IFAIL are zero.  If INFO > 0, then IFAIL contains the\n*          indices of the eigenvectors that failed to converge.\n*          If JOBZ = 'N', then IFAIL is not referenced.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  CPPTRF or CHPEVX returned an error code:\n*             <= N:  if INFO = i, CHPEVX failed to converge;\n*                    i eigenvectors failed to converge.  Their indices\n*                    are stored in array IFAIL.\n*             > N:   if INFO = N + i, for 1 <= i <= n, then the leading\n*                    minor of order i of B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            ALLEIG, INDEIG, UPPER, VALEIG, WANTZ\n      CHARACTER          TRANS\n      INTEGER            J\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CHPEVX, CHPGST, CPPTRF, CTPMV, CTPSV, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, ifail, info, ap, bp = NumRu::Lapack.chpgvx( itype, jobz, range, uplo, ap, bp, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 11 && argc != 11)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
  rblapack_itype = argv[0];
  rblapack_jobz = argv[1];
  rblapack_range = argv[2];
  rblapack_uplo = argv[3];
  rblapack_ap = argv[4];
  rblapack_bp = argv[5];
  rblapack_vl = argv[6];
  rblapack_vu = argv[7];
  rblapack_il = argv[8];
  rblapack_iu = argv[9];
  rblapack_abstol = argv[10];
  if (argc == 11) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  itype = NUM2INT(rblapack_itype);
  range = StringValueCStr(rblapack_range)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  vl = (real)NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  abstol = (real)NUM2DBL(rblapack_abstol);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_bp))
    rb_raise(rb_eArgError, "bp (6th argument) must be NArray");
  if (NA_RANK(rblapack_bp) != 1)
    rb_raise(rb_eArgError, "rank of bp (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_bp) != NA_SCOMPLEX)
    rblapack_bp = na_change_type(rblapack_bp, NA_SCOMPLEX);
  bp = NA_PTR_TYPE(rblapack_bp, complex*);
  iu = NUM2INT(rblapack_iu);
  uplo = StringValueCStr(rblapack_uplo)[0];
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  vu = (real)NUM2DBL(rblapack_vu);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = lsame_(&jobz,"N") ? 0 : ldz;
    shape[1] = lsame_(&jobz,"N") ? 0 : n;
    rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
  MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_bp_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  bp_out__ = NA_PTR_TYPE(rblapack_bp_out__, complex*);
  MEMCPY(bp_out__, bp, complex, NA_TOTAL(rblapack_bp));
  rblapack_bp = rblapack_bp_out__;
  bp = bp_out__;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (7*n));
  iwork = ALLOC_N(integer, (5*n));

  chpgvx_(&itype, &jobz, &range, &uplo, &n, ap, bp, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, rwork, iwork, ifail, &info);

  free(work);
  free(rwork);
  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_ap, rblapack_bp);
}

void
init_lapack_chpgvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chpgvx", rblapack_chpgvx, -1);
}
ruby-lapack-1.7.2/ext/clanhs.c0000644000175000017500000000723612502221013015777 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real clanhs_(char* norm, integer* n, complex* a, integer* lda, real* work);


static VALUE
rblapack_clanhs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack___out__;
  real __out__; 
  real *work;

  integer lda;
  integer n;
  integer lwork;

  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  __out__ = NumRu::Lapack.clanhs( norm, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL             FUNCTION CLANHS( NORM, N, A, LDA, WORK )\n\n*  Purpose\n*  =======\n*\n*  CLANHS  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  Hessenberg matrix A.\n*\n*  Description\n*  ===========\n*\n*  CLANHS returns the value\n*\n*     CLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in CLANHS as described\n*          above.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, CLANHS is\n*          set to zero.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The n by n upper Hessenberg matrix A; the part of A below the\n*          first sub-diagonal is not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(N,1).\n*\n*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n*          referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.clanhs( norm, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_norm = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  lwork = lsame_(&norm,"I") ? n : 0;
  work = ALLOC_N(real, (MAX(1,lwork)));

  __out__ = clanhs_(&norm, &n, a, &lda, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_clanhs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clanhs", rblapack_clanhs, -1);
}
ruby-lapack-1.7.2/ext/zcposv.c0000644000175000017500000002074012502221015016050 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zcposv_(char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublecomplex* work, complex* swork, doublereal* rwork, integer* iter, integer* info);


static VALUE
rblapack_zcposv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_iter;
  integer iter; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  doublecomplex *work;
  complex *swork;
  doublereal *rwork;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, iter, info, a = NumRu::Lapack.zcposv( uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZCPOSV( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, WORK, SWORK, RWORK, ITER, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZCPOSV computes the solution to a complex system of linear equations\n*     A * X = B,\n*  where A is an N-by-N Hermitian positive definite matrix and X and B\n*  are N-by-NRHS matrices.\n*\n*  ZCPOSV first attempts to factorize the matrix in COMPLEX and use this\n*  factorization within an iterative refinement procedure to produce a\n*  solution with COMPLEX*16 normwise backward error quality (see below).\n*  If the approach fails the method switches to a COMPLEX*16\n*  factorization and solve.\n*\n*  The iterative refinement is not going to be a winning strategy if\n*  the ratio COMPLEX performance over COMPLEX*16 performance is too\n*  small. A reasonable strategy should take the number of right-hand\n*  sides and the size of the matrix into account. This might be done\n*  with a call to ILAENV in the future. Up to now, we always try\n*  iterative refinement.\n*\n*  The iterative refinement process is stopped if\n*      ITER > ITERMAX\n*  or for all the RHS we have:\n*      RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX\n*  where\n*      o ITER is the number of the current iteration in the iterative\n*        refinement process\n*      o RNRM is the infinity-norm of the residual\n*      o XNRM is the infinity-norm of the solution\n*      o ANRM is the infinity-operator-norm of the matrix A\n*      o EPS is the machine epsilon returned by DLAMCH('Epsilon')\n*  The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00\n*  respectively.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input/output) COMPLEX*16 array,\n*          dimension (LDA,N)\n*          On entry, the Hermitian matrix A. If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          Note that the imaginary parts of the diagonal\n*          elements need not be set and are assumed to be zero.\n*\n*          On exit, if iterative refinement has been successfully used\n*          (INFO.EQ.0 and ITER.GE.0, see description below), then A is\n*          unchanged, if double precision factorization has been used\n*          (INFO.EQ.0 and ITER.LT.0, see description below), then the\n*          array A contains the factor U or L from the Cholesky\n*          factorization A = U**H*U or A = L*L**H.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*          The N-by-NRHS right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) COMPLEX*16 array, dimension (LDX,NRHS)\n*          If INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (N*NRHS)\n*          This array is used to hold the residual vectors.\n*\n*  SWORK   (workspace) COMPLEX array, dimension (N*(N+NRHS))\n*          This array is used to use the single precision matrix and the\n*          right-hand sides or solutions in single precision.\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\n*\n*  ITER    (output) INTEGER\n*          < 0: iterative refinement has failed, COMPLEX*16\n*               factorization has been performed\n*               -1 : the routine fell back to full precision for\n*                    implementation- or machine-specific reasons\n*               -2 : narrowing the precision induced an overflow,\n*                    the routine fell back to full precision\n*               -3 : failure of CPOTRF\n*               -31: stop the iterative refinement after the 30th\n*                    iterations\n*          > 0: iterative refinement has been sucessfully used.\n*               Returns the number of iterations\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 leading minor of order i of\n*                (COMPLEX*16) A is not positive definite, so the\n*                factorization could not be completed, and the solution\n*                has not been computed.\n*\n*  =========\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, iter, info, a = NumRu::Lapack.zcposv( uplo, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_b = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  ldx = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(doublecomplex, (n*nrhs));
  swork = ALLOC_N(complex, (n*(n+nrhs)));
  rwork = ALLOC_N(doublereal, (n));

  zcposv_(&uplo, &n, &nrhs, a, &lda, b, &ldb, x, &ldx, work, swork, rwork, &iter, &info);

  free(work);
  free(swork);
  free(rwork);
  rblapack_iter = INT2NUM(iter);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_x, rblapack_iter, rblapack_info, rblapack_a);
}

void
init_lapack_zcposv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zcposv", rblapack_zcposv, -1);
}
ruby-lapack-1.7.2/ext/sormlq.c0000644000175000017500000001577612502221016016057 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sormlq_(char* side, char* trans, integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* c, integer* ldc, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sormlq(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  real *c_out__;

  integer lda;
  integer m;
  integer k;
  integer ldc;
  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  work, info, c = NumRu::Lapack.sormlq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SORMLQ overwrites the general real M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'T':      Q**T * C       C * Q**T\n*\n*  where Q is a real orthogonal matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(k) . . . H(2) H(1)\n*\n*  as returned by SGELQF. Q is of order M if SIDE = 'L' and of order N\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**T from the Left;\n*          = 'R': apply Q or Q**T from the Right.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'T':  Transpose, apply Q**T.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) REAL array, dimension\n*                               (LDA,M) if SIDE = 'L',\n*                               (LDA,N) if SIDE = 'R'\n*          The i-th row must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          SGELQF in the first k rows of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,K).\n*\n*  TAU     (input) REAL array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by SGELQF.\n*\n*  C       (input/output) REAL array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace/output) REAL 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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M).\n*          For optimum performance LWORK >= N*NB if SIDE = 'L', and\n*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n*          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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.sormlq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_a = argv[2];
  rblapack_tau = argv[3];
  rblapack_c = argv[4];
  if (argc == 6) {
    rblapack_lwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  sormlq_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_sormlq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sormlq", rblapack_sormlq, -1);
}
ruby-lapack-1.7.2/ext/slabrd.c0000644000175000017500000002103112502221012015762 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slabrd_(integer* m, integer* n, integer* nb, real* a, integer* lda, real* d, real* e, real* tauq, real* taup, real* x, integer* ldx, real* y, integer* ldy);


static VALUE
rblapack_slabrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_nb;
  integer nb; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_tauq;
  real *tauq; 
  VALUE rblapack_taup;
  real *taup; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_y;
  real *y; 
  VALUE rblapack_a_out__;
  real *a_out__;

  integer lda;
  integer n;
  integer ldx;
  integer ldy;

  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  d, e, tauq, taup, x, y, a = NumRu::Lapack.slabrd( m, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, LDY )\n\n*  Purpose\n*  =======\n*\n*  SLABRD reduces the first NB rows and columns of a real general\n*  m by n matrix A to upper or lower bidiagonal form by an orthogonal\n*  transformation Q' * A * P, and returns the matrices X and Y which\n*  are needed to apply the transformation to the unreduced part of A.\n*\n*  If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower\n*  bidiagonal form.\n*\n*  This is an auxiliary routine called by SGEBRD\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows in the matrix A.\n*\n*  N       (input) INTEGER\n*          The number of columns in the matrix A.\n*\n*  NB      (input) INTEGER\n*          The number of leading rows and columns of A to be reduced.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the m by n general matrix to be reduced.\n*          On exit, the first NB rows and columns of the matrix are\n*          overwritten; the rest of the array is unchanged.\n*          If m >= n, elements on and below the diagonal in the first NB\n*            columns, with the array TAUQ, represent the orthogonal\n*            matrix Q as a product of elementary reflectors; and\n*            elements above the diagonal in the first NB rows, with the\n*            array TAUP, represent the orthogonal matrix P as a product\n*            of elementary reflectors.\n*          If m < n, elements below the diagonal in the first NB\n*            columns, with the array TAUQ, represent the orthogonal\n*            matrix Q as a product of elementary reflectors, and\n*            elements on and above the diagonal in the first NB rows,\n*            with the array TAUP, represent the orthogonal matrix P as\n*            a product of elementary reflectors.\n*          See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  D       (output) REAL array, dimension (NB)\n*          The diagonal elements of the first NB rows and columns of\n*          the reduced matrix.  D(i) = A(i,i).\n*\n*  E       (output) REAL array, dimension (NB)\n*          The off-diagonal elements of the first NB rows and columns of\n*          the reduced matrix.\n*\n*  TAUQ    (output) REAL array dimension (NB)\n*          The scalar factors of the elementary reflectors which\n*          represent the orthogonal matrix Q. See Further Details.\n*\n*  TAUP    (output) REAL array, dimension (NB)\n*          The scalar factors of the elementary reflectors which\n*          represent the orthogonal matrix P. See Further Details.\n*\n*  X       (output) REAL array, dimension (LDX,NB)\n*          The m-by-nb matrix X required to update the unreduced part\n*          of A.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X. LDX >= M.\n*\n*  Y       (output) REAL array, dimension (LDY,NB)\n*          The n-by-nb matrix Y required to update the unreduced part\n*          of A.\n*\n*  LDY     (input) INTEGER\n*          The leading dimension of the array Y. LDY >= N.\n*\n\n*  Further Details\n*  ===============\n*\n*  The matrices Q and P are represented as products of elementary\n*  reflectors:\n*\n*     Q = H(1) H(2) . . . H(nb)  and  P = G(1) G(2) . . . G(nb)\n*\n*  Each H(i) and G(i) has the form:\n*\n*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'\n*\n*  where tauq and taup are real scalars, and v and u are real vectors.\n*\n*  If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in\n*  A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in\n*  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n*  If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in\n*  A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in\n*  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n*  The elements of the vectors v and u together form the m-by-nb matrix\n*  V and the nb-by-n matrix U' which are needed, with X and Y, to apply\n*  the transformation to the unreduced part of the matrix, using a block\n*  update of the form:  A := A - V*Y' - X*U'.\n*\n*  The contents of A on exit are illustrated by the following examples\n*  with nb = 2:\n*\n*  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):\n*\n*    (  1   1   u1  u1  u1 )           (  1   u1  u1  u1  u1  u1 )\n*    (  v1  1   1   u2  u2 )           (  1   1   u2  u2  u2  u2 )\n*    (  v1  v2  a   a   a  )           (  v1  1   a   a   a   a  )\n*    (  v1  v2  a   a   a  )           (  v1  v2  a   a   a   a  )\n*    (  v1  v2  a   a   a  )           (  v1  v2  a   a   a   a  )\n*    (  v1  v2  a   a   a  )\n*\n*  where a denotes an element of the original matrix which is unchanged,\n*  vi denotes an element of the vector defining H(i), and ui an element\n*  of the vector defining G(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, tauq, taup, x, y, a = NumRu::Lapack.slabrd( m, nb, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_m = argv[0];
  rblapack_nb = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  ldy = n;
  nb = NUM2INT(rblapack_nb);
  ldx = m;
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,nb);
    rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,nb);
    rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,nb);
    rblapack_tauq = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  tauq = NA_PTR_TYPE(rblapack_tauq, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,nb);
    rblapack_taup = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  taup = NA_PTR_TYPE(rblapack_taup, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = MAX(1,nb);
    rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldy;
    shape[1] = MAX(1,nb);
    rblapack_y = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  y = NA_PTR_TYPE(rblapack_y, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  slabrd_(&m, &n, &nb, a, &lda, d, e, tauq, taup, x, &ldx, y, &ldy);

  return rb_ary_new3(7, rblapack_d, rblapack_e, rblapack_tauq, rblapack_taup, rblapack_x, rblapack_y, rblapack_a);
}

void
init_lapack_slabrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slabrd", rblapack_slabrd, -1);
}
ruby-lapack-1.7.2/ext/dlantb.c0000644000175000017500000001215612502221017015774 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal dlantb_(char* norm, char* uplo, char* diag, integer* n, integer* k, doublereal* ab, integer* ldab, doublereal* work);


static VALUE
rblapack_dlantb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack___out__;
  doublereal __out__; 
  doublereal *work;

  integer ldab;
  integer n;
  integer lwork;

  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  __out__ = NumRu::Lapack.dlantb( norm, uplo, diag, k, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION DLANTB( NORM, UPLO, DIAG, N, K, AB, LDAB, WORK )\n\n*  Purpose\n*  =======\n*\n*  DLANTB  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the element of  largest absolute value  of an\n*  n by n triangular band matrix A,  with ( k + 1 ) diagonals.\n*\n*  Description\n*  ===========\n*\n*  DLANTB returns the value\n*\n*     DLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in DLANTB as described\n*          above.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the matrix A is upper or lower triangular.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  DIAG    (input) CHARACTER*1\n*          Specifies whether or not the matrix A is unit triangular.\n*          = 'N':  Non-unit triangular\n*          = 'U':  Unit triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, DLANTB is\n*          set to zero.\n*\n*  K       (input) INTEGER\n*          The number of super-diagonals of the matrix A if UPLO = 'U',\n*          or the number of sub-diagonals of the matrix A if UPLO = 'L'.\n*          K >= 0.\n*\n*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)\n*          The upper or lower triangular band matrix A, stored in the\n*          first k+1 rows of AB.  The j-th column of A is stored\n*          in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)   = A(i,j) for j<=i<=min(n,j+k).\n*          Note that when DIAG = 'U', the elements of the array AB\n*          corresponding to the diagonal elements of the matrix A are\n*          not referenced, but are assumed to be one.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= K+1.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n*          referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.dlantb( norm, uplo, diag, k, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_diag = argv[2];
  rblapack_k = argv[3];
  rblapack_ab = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  lwork = lsame_(&norm,"I") ? n : 0;
  k = NUM2INT(rblapack_k);
  work = ALLOC_N(doublereal, (MAX(1,lwork)));

  __out__ = dlantb_(&norm, &uplo, &diag, &n, &k, ab, &ldab, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_dlantb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlantb", rblapack_dlantb, -1);
}
ruby-lapack-1.7.2/ext/zlaev2.c0000644000175000017500000001020112502221020015712 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlaev2_(doublecomplex* a, doublecomplex* b, doublecomplex* c, doublereal* rt1, doublereal* rt2, doublereal* cs1, doublecomplex* sn1);


static VALUE
rblapack_zlaev2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublecomplex a; 
  VALUE rblapack_b;
  doublecomplex b; 
  VALUE rblapack_c;
  doublecomplex c; 
  VALUE rblapack_rt1;
  doublereal rt1; 
  VALUE rblapack_rt2;
  doublereal rt2; 
  VALUE rblapack_cs1;
  doublereal cs1; 
  VALUE rblapack_sn1;
  doublecomplex sn1; 


  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  rt1, rt2, cs1, sn1 = NumRu::Lapack.zlaev2( a, b, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAEV2( A, B, C, RT1, RT2, CS1, SN1 )\n\n*  Purpose\n*  =======\n*\n*  ZLAEV2 computes the eigendecomposition of a 2-by-2 Hermitian matrix\n*     [  A         B  ]\n*     [  CONJG(B)  C  ].\n*  On return, RT1 is the eigenvalue of larger absolute value, RT2 is the\n*  eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right\n*  eigenvector for RT1, giving the decomposition\n*\n*  [ CS1  CONJG(SN1) ] [    A     B ] [ CS1 -CONJG(SN1) ] = [ RT1  0  ]\n*  [-SN1     CS1     ] [ CONJG(B) C ] [ SN1     CS1     ]   [  0  RT2 ].\n*\n\n*  Arguments\n*  =========\n*\n*  A      (input) COMPLEX*16\n*         The (1,1) element of the 2-by-2 matrix.\n*\n*  B      (input) COMPLEX*16\n*         The (1,2) element and the conjugate of the (2,1) element of\n*         the 2-by-2 matrix.\n*\n*  C      (input) COMPLEX*16\n*         The (2,2) element of the 2-by-2 matrix.\n*\n*  RT1    (output) DOUBLE PRECISION\n*         The eigenvalue of larger absolute value.\n*\n*  RT2    (output) DOUBLE PRECISION\n*         The eigenvalue of smaller absolute value.\n*\n*  CS1    (output) DOUBLE PRECISION\n*  SN1    (output) COMPLEX*16\n*         The vector (CS1, SN1) is a unit right eigenvector for RT1.\n*\n\n*  Further Details\n*  ===============\n*\n*  RT1 is accurate to a few ulps barring over/underflow.\n*\n*  RT2 may be inaccurate if there is massive cancellation in the\n*  determinant A*C-B*B; higher precision or correctly rounded or\n*  correctly truncated arithmetic would be needed to compute RT2\n*  accurately in all cases.\n*\n*  CS1 and SN1 are accurate to a few ulps barring over/underflow.\n*\n*  Overflow is possible only if RT1 is within a factor of 5 of overflow.\n*  Underflow is harmless if the input data is 0 or exceeds\n*     underflow_threshold / macheps.\n*\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rt1, rt2, cs1, sn1 = NumRu::Lapack.zlaev2( a, b, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  rblapack_c = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  a.r = NUM2DBL(rb_funcall(rblapack_a, rb_intern("real"), 0));
  a.i = NUM2DBL(rb_funcall(rblapack_a, rb_intern("imag"), 0));
  c.r = NUM2DBL(rb_funcall(rblapack_c, rb_intern("real"), 0));
  c.i = NUM2DBL(rb_funcall(rblapack_c, rb_intern("imag"), 0));
  b.r = NUM2DBL(rb_funcall(rblapack_b, rb_intern("real"), 0));
  b.i = NUM2DBL(rb_funcall(rblapack_b, rb_intern("imag"), 0));

  zlaev2_(&a, &b, &c, &rt1, &rt2, &cs1, &sn1);

  rblapack_rt1 = rb_float_new((double)rt1);
  rblapack_rt2 = rb_float_new((double)rt2);
  rblapack_cs1 = rb_float_new((double)cs1);
  rblapack_sn1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(sn1.r)), rb_float_new((double)(sn1.i)));
  return rb_ary_new3(4, rblapack_rt1, rblapack_rt2, rblapack_cs1, rblapack_sn1);
}

void
init_lapack_zlaev2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlaev2", rblapack_zlaev2, -1);
}
ruby-lapack-1.7.2/ext/slarrj.c0000644000175000017500000001735312502221020016023 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slarrj_(integer* n, real* d, real* e2, integer* ifirst, integer* ilast, real* rtol, integer* offset, real* w, real* werr, real* work, integer* iwork, real* pivmin, real* spdiam, integer* info);


static VALUE
rblapack_slarrj(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e2;
  real *e2; 
  VALUE rblapack_ifirst;
  integer ifirst; 
  VALUE rblapack_ilast;
  integer ilast; 
  VALUE rblapack_rtol;
  real rtol; 
  VALUE rblapack_offset;
  integer offset; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_werr;
  real *werr; 
  VALUE rblapack_pivmin;
  real pivmin; 
  VALUE rblapack_spdiam;
  real spdiam; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_w_out__;
  real *w_out__;
  VALUE rblapack_werr_out__;
  real *werr_out__;
  real *work;
  integer *iwork;

  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  info, w, werr = NumRu::Lapack.slarrj( d, e2, ifirst, ilast, rtol, offset, w, werr, pivmin, spdiam, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLARRJ( N, D, E2, IFIRST, ILAST, RTOL, OFFSET, W, WERR, WORK, IWORK, PIVMIN, SPDIAM, INFO )\n\n*  Purpose\n*  =======\n*\n*  Given the initial eigenvalue approximations of T, SLARRJ\n*  does  bisection to refine the eigenvalues of T,\n*  W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial\n*  guesses for these eigenvalues are input in W, the corresponding estimate\n*  of the error in these guesses in WERR. During bisection, intervals\n*  [left, right] are maintained by storing their mid-points and\n*  semi-widths in the arrays W and WERR respectively.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix.\n*\n*  D       (input) REAL             array, dimension (N)\n*          The N diagonal elements of T.\n*\n*  E2      (input) REAL             array, dimension (N-1)\n*          The Squares of the (N-1) subdiagonal elements of T.\n*\n*  IFIRST  (input) INTEGER\n*          The index of the first eigenvalue to be computed.\n*\n*  ILAST   (input) INTEGER\n*          The index of the last eigenvalue to be computed.\n*\n*  RTOL   (input) REAL            \n*          Tolerance for the convergence of the bisection intervals.\n*          An interval [LEFT,RIGHT] has converged if\n*          RIGHT-LEFT.LT.RTOL*MAX(|LEFT|,|RIGHT|).\n*\n*  OFFSET  (input) INTEGER\n*          Offset for the arrays W and WERR, i.e., the IFIRST-OFFSET\n*          through ILAST-OFFSET elements of these arrays are to be used.\n*\n*  W       (input/output) REAL             array, dimension (N)\n*          On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are\n*          estimates of the eigenvalues of L D L^T indexed IFIRST through\n*          ILAST.\n*          On output, these estimates are refined.\n*\n*  WERR    (input/output) REAL             array, dimension (N)\n*          On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are\n*          the errors in the estimates of the corresponding elements in W.\n*          On output, these errors are refined.\n*\n*  WORK    (workspace) REAL             array, dimension (2*N)\n*          Workspace.\n*\n*  IWORK   (workspace) INTEGER array, dimension (2*N)\n*          Workspace.\n*\n*  PIVMIN  (input) REAL\n*          The minimum pivot in the Sturm sequence for T.\n*\n*  SPDIAM  (input) REAL\n*          The spectral diameter of T.\n*\n*  INFO    (output) INTEGER\n*          Error flag.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Beresford Parlett, University of California, Berkeley, USA\n*     Jim Demmel, University of California, Berkeley, USA\n*     Inderjit Dhillon, University of Texas, Austin, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, w, werr = NumRu::Lapack.slarrj( d, e2, ifirst, ilast, rtol, offset, w, werr, pivmin, spdiam, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_d = argv[0];
  rblapack_e2 = argv[1];
  rblapack_ifirst = argv[2];
  rblapack_ilast = argv[3];
  rblapack_rtol = argv[4];
  rblapack_offset = argv[5];
  rblapack_w = argv[6];
  rblapack_werr = argv[7];
  rblapack_pivmin = argv[8];
  rblapack_spdiam = argv[9];
  if (argc == 10) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  ifirst = NUM2INT(rblapack_ifirst);
  rtol = (real)NUM2DBL(rblapack_rtol);
  if (!NA_IsNArray(rblapack_w))
    rb_raise(rb_eArgError, "w (7th argument) must be NArray");
  if (NA_RANK(rblapack_w) != 1)
    rb_raise(rb_eArgError, "rank of w (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_w) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_w) != NA_SFLOAT)
    rblapack_w = na_change_type(rblapack_w, NA_SFLOAT);
  w = NA_PTR_TYPE(rblapack_w, real*);
  pivmin = (real)NUM2DBL(rblapack_pivmin);
  ilast = NUM2INT(rblapack_ilast);
  if (!NA_IsNArray(rblapack_werr))
    rb_raise(rb_eArgError, "werr (8th argument) must be NArray");
  if (NA_RANK(rblapack_werr) != 1)
    rb_raise(rb_eArgError, "rank of werr (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_werr) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of werr must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_werr) != NA_SFLOAT)
    rblapack_werr = na_change_type(rblapack_werr, NA_SFLOAT);
  werr = NA_PTR_TYPE(rblapack_werr, real*);
  if (!NA_IsNArray(rblapack_e2))
    rb_raise(rb_eArgError, "e2 (2th argument) must be NArray");
  if (NA_RANK(rblapack_e2) != 1)
    rb_raise(rb_eArgError, "rank of e2 (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e2) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e2 must be %d", n-1);
  if (NA_TYPE(rblapack_e2) != NA_SFLOAT)
    rblapack_e2 = na_change_type(rblapack_e2, NA_SFLOAT);
  e2 = NA_PTR_TYPE(rblapack_e2, real*);
  spdiam = (real)NUM2DBL(rblapack_spdiam);
  offset = NUM2INT(rblapack_offset);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w_out__ = NA_PTR_TYPE(rblapack_w_out__, real*);
  MEMCPY(w_out__, w, real, NA_TOTAL(rblapack_w));
  rblapack_w = rblapack_w_out__;
  w = w_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_werr_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  werr_out__ = NA_PTR_TYPE(rblapack_werr_out__, real*);
  MEMCPY(werr_out__, werr, real, NA_TOTAL(rblapack_werr));
  rblapack_werr = rblapack_werr_out__;
  werr = werr_out__;
  work = ALLOC_N(real, (2*n));
  iwork = ALLOC_N(integer, (2*n));

  slarrj_(&n, d, e2, &ifirst, &ilast, &rtol, &offset, w, werr, work, iwork, &pivmin, &spdiam, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_w, rblapack_werr);
}

void
init_lapack_slarrj(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slarrj", rblapack_slarrj, -1);
}
ruby-lapack-1.7.2/ext/sgges.c0000644000175000017500000003301512502221023015632 0ustar  uwabamiuwabami#include "rb_lapack.h"

static logical
rblapack_selctg(real *arg0, real *arg1, real *arg2){
  VALUE rblapack_arg0, rblapack_arg1, rblapack_arg2;

  VALUE rblapack_ret;
  logical ret;

  rblapack_arg0 = rb_float_new((double)(*arg0));
  rblapack_arg1 = rb_float_new((double)(*arg1));
  rblapack_arg2 = rb_float_new((double)(*arg2));

  rblapack_ret = rb_yield_values(3, rblapack_arg0, rblapack_arg1, rblapack_arg2);

  ret = (rblapack_ret == Qtrue);
  return ret;
}

extern VOID sgges_(char* jobvsl, char* jobvsr, char* sort, L_fp selctg, integer* n, real* a, integer* lda, real* b, integer* ldb, integer* sdim, real* alphar, real* alphai, real* beta, real* vsl, integer* ldvsl, real* vsr, integer* ldvsr, real* work, integer* lwork, logical* bwork, integer* info);


static VALUE
rblapack_sgges(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvsl;
  char jobvsl; 
  VALUE rblapack_jobvsr;
  char jobvsr; 
  VALUE rblapack_sort;
  char sort; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_sdim;
  integer sdim; 
  VALUE rblapack_alphar;
  real *alphar; 
  VALUE rblapack_alphai;
  real *alphai; 
  VALUE rblapack_beta;
  real *beta; 
  VALUE rblapack_vsl;
  real *vsl; 
  VALUE rblapack_vsr;
  real *vsr; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_b_out__;
  real *b_out__;
  logical *bwork;

  integer lda;
  integer n;
  integer ldb;
  integer ldvsl;
  integer ldvsr;

  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  sdim, alphar, alphai, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.sgges( jobvsl, jobvsr, sort, a, b, [:lwork => lwork, :usage => usage, :help => help]){|a,b,c| ... }\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, BWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGGES computes for a pair of N-by-N real nonsymmetric matrices (A,B),\n*  the generalized eigenvalues, the generalized real Schur form (S,T),\n*  optionally, the left and/or right matrices of Schur vectors (VSL and\n*  VSR). This gives the generalized Schur factorization\n*\n*           (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T )\n*\n*  Optionally, it also orders the eigenvalues so that a selected cluster\n*  of eigenvalues appears in the leading diagonal blocks of the upper\n*  quasi-triangular matrix S and the upper triangular matrix T.The\n*  leading columns of VSL and VSR then form an orthonormal basis for the\n*  corresponding left and right eigenspaces (deflating subspaces).\n*\n*  (If only the generalized eigenvalues are needed, use the driver\n*  SGGEV instead, which is faster.)\n*\n*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n*  or a ratio alpha/beta = w, such that  A - w*B is singular.  It is\n*  usually represented as the pair (alpha,beta), as there is a\n*  reasonable interpretation for beta=0 or both being zero.\n*\n*  A pair of matrices (S,T) is in generalized real Schur form if T is\n*  upper triangular with non-negative diagonal and S is block upper\n*  triangular with 1-by-1 and 2-by-2 blocks.  1-by-1 blocks correspond\n*  to real generalized eigenvalues, while 2-by-2 blocks of S will be\n*  \"standardized\" by making the corresponding elements of T have the\n*  form:\n*          [  a  0  ]\n*          [  0  b  ]\n*\n*  and the pair of corresponding 2-by-2 blocks in S and T will have a\n*  complex conjugate pair of generalized eigenvalues.\n*\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVSL  (input) CHARACTER*1\n*          = 'N':  do not compute the left Schur vectors;\n*          = 'V':  compute the left Schur vectors.\n*\n*  JOBVSR  (input) CHARACTER*1\n*          = 'N':  do not compute the right Schur vectors;\n*          = 'V':  compute the right Schur vectors.\n*\n*  SORT    (input) CHARACTER*1\n*          Specifies whether or not to order the eigenvalues on the\n*          diagonal of the generalized Schur form.\n*          = 'N':  Eigenvalues are not ordered;\n*          = 'S':  Eigenvalues are ordered (see SELCTG);\n*\n*  SELCTG  (external procedure) LOGICAL FUNCTION of three REAL arguments\n*          SELCTG must be declared EXTERNAL in the calling subroutine.\n*          If SORT = 'N', SELCTG is not referenced.\n*          If SORT = 'S', SELCTG is used to select eigenvalues to sort\n*          to the top left of the Schur form.\n*          An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if\n*          SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either\n*          one of a complex conjugate pair of eigenvalues is selected,\n*          then both complex eigenvalues are selected.\n*\n*          Note that in the ill-conditioned case, a selected complex\n*          eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j),\n*          BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2\n*          in this case.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A, B, VSL, and VSR.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA, N)\n*          On entry, the first of the pair of matrices.\n*          On exit, A has been overwritten by its generalized Schur\n*          form S.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of A.  LDA >= max(1,N).\n*\n*  B       (input/output) REAL array, dimension (LDB, N)\n*          On entry, the second of the pair of matrices.\n*          On exit, B has been overwritten by its generalized Schur\n*          form T.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of B.  LDB >= max(1,N).\n*\n*  SDIM    (output) INTEGER\n*          If SORT = 'N', SDIM = 0.\n*          If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n*          for which SELCTG is true.  (Complex conjugate pairs for which\n*          SELCTG is true for either eigenvalue count as 2.)\n*\n*  ALPHAR  (output) REAL array, dimension (N)\n*  ALPHAI  (output) REAL array, dimension (N)\n*  BETA    (output) REAL array, dimension (N)\n*          On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n*          be the generalized eigenvalues.  ALPHAR(j) + ALPHAI(j)*i,\n*          and  BETA(j),j=1,...,N are the diagonals of the complex Schur\n*          form (S,T) that would result if the 2-by-2 diagonal blocks of\n*          the real Schur form of (A,B) were further reduced to\n*          triangular form using 2-by-2 complex unitary transformations.\n*          If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n*          positive, then the j-th and (j+1)-st eigenvalues are a\n*          complex conjugate pair, with ALPHAI(j+1) negative.\n*\n*          Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n*          may easily over- or underflow, and BETA(j) may even be zero.\n*          Thus, the user should avoid naively computing the ratio.\n*          However, ALPHAR and ALPHAI will be always less than and\n*          usually comparable with norm(A) in magnitude, and BETA always\n*          less than and usually comparable with norm(B).\n*\n*  VSL     (output) REAL array, dimension (LDVSL,N)\n*          If JOBVSL = 'V', VSL will contain the left Schur vectors.\n*          Not referenced if JOBVSL = 'N'.\n*\n*  LDVSL   (input) INTEGER\n*          The leading dimension of the matrix VSL. LDVSL >=1, and\n*          if JOBVSL = 'V', LDVSL >= N.\n*\n*  VSR     (output) REAL array, dimension (LDVSR,N)\n*          If JOBVSR = 'V', VSR will contain the right Schur vectors.\n*          Not referenced if JOBVSR = 'N'.\n*\n*  LDVSR   (input) INTEGER\n*          The leading dimension of the matrix VSR. LDVSR >= 1, and\n*          if JOBVSR = 'V', LDVSR >= N.\n*\n*  WORK    (workspace/output) REAL 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*          If N = 0, LWORK >= 1, else LWORK >= max(8*N,6*N+16).\n*          For good performance , LWORK must generally be larger.\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*  BWORK   (workspace) LOGICAL array, dimension (N)\n*          Not referenced if SORT = 'N'.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          = 1,...,N:\n*                The QZ iteration failed.  (A,B) are not in Schur\n*                form, but ALPHAR(j), ALPHAI(j), and BETA(j) should\n*                be correct for j=INFO+1,...,N.\n*          > N:  =N+1: other than QZ iteration failed in SHGEQZ.\n*                =N+2: after reordering, roundoff changed values of\n*                      some complex eigenvalues so that leading\n*                      eigenvalues in the Generalized Schur form no\n*                      longer satisfy SELCTG=.TRUE.  This could also\n*                      be caused due to scaling.\n*                =N+3: reordering failed in STGSEN.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sdim, alphar, alphai, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.sgges( jobvsl, jobvsr, sort, a, b, [:lwork => lwork, :usage => usage, :help => help]){|a,b,c| ... }\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_jobvsl = argv[0];
  rblapack_jobvsr = argv[1];
  rblapack_sort = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  if (argc == 6) {
    rblapack_lwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  jobvsl = StringValueCStr(rblapack_jobvsl)[0];
  sort = StringValueCStr(rblapack_sort)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  jobvsr = StringValueCStr(rblapack_jobvsr)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  ldvsl = lsame_(&jobvsl,"V") ? n : 1;
  if (rblapack_lwork == Qnil)
    lwork = MAX(8*n,6*n+16);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldvsr = lsame_(&jobvsr,"V") ? n : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  alphar = NA_PTR_TYPE(rblapack_alphar, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  alphai = NA_PTR_TYPE(rblapack_alphai, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldvsl;
    shape[1] = n;
    rblapack_vsl = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vsl = NA_PTR_TYPE(rblapack_vsl, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldvsr;
    shape[1] = n;
    rblapack_vsr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vsr = NA_PTR_TYPE(rblapack_vsr, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));

  sgges_(&jobvsl, &jobvsr, &sort, rblapack_selctg, &n, a, &lda, b, &ldb, &sdim, alphar, alphai, beta, vsl, &ldvsl, vsr, &ldvsr, work, &lwork, bwork, &info);

  free(bwork);
  rblapack_sdim = INT2NUM(sdim);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(10, rblapack_sdim, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_vsl, rblapack_vsr, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_sgges(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgges", rblapack_sgges, -1);
}
ruby-lapack-1.7.2/ext/clahef.c0000644000175000017500000001430212502221022015741 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clahef_(char* uplo, integer* n, integer* nb, integer* kb, complex* a, integer* lda, integer* ipiv, complex* w, integer* ldw, integer* info);


static VALUE
rblapack_clahef(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_nb;
  integer nb; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_kb;
  integer kb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  complex *w;

  integer lda;
  integer n;
  integer ldw;

  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  kb, ipiv, info, a = NumRu::Lapack.clahef( uplo, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )\n\n*  Purpose\n*  =======\n*\n*  CLAHEF computes a partial factorization of a complex Hermitian\n*  matrix A using the Bunch-Kaufman diagonal pivoting method. The\n*  partial factorization has the form:\n*\n*  A  =  ( I  U12 ) ( A11  0  ) (  I    0   )  if UPLO = 'U', or:\n*        ( 0  U22 ) (  0   D  ) ( U12' U22' )\n*\n*  A  =  ( L11  0 ) (  D   0  ) ( L11' L21' )  if UPLO = 'L'\n*        ( L21  I ) (  0  A22 ) (  0    I   )\n*\n*  where the order of D is at most NB. The actual order is returned in\n*  the argument KB, and is either NB or NB-1, or N if N <= NB.\n*  Note that U' denotes the conjugate transpose of U.\n*\n*  CLAHEF is an auxiliary routine called by CHETRF. It uses blocked code\n*  (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or\n*  A22 (if UPLO = 'L').\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          Hermitian matrix A is stored:\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NB      (input) INTEGER\n*          The maximum number of columns of the matrix A that should be\n*          factored.  NB should be at least 2 to allow for 2-by-2 pivot\n*          blocks.\n*\n*  KB      (output) INTEGER\n*          The number of columns of A that were actually factored.\n*          KB is either NB-1 or NB, or N if N <= NB.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading\n*          n-by-n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n-by-n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*          On exit, A contains details of the partial factorization.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D.\n*          If UPLO = 'U', only the last KB elements of IPIV are set;\n*          if UPLO = 'L', only the first KB elements are set.\n*\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*  W       (workspace) COMPLEX array, dimension (LDW,NB)\n*\n*  LDW     (input) INTEGER\n*          The leading dimension of the array W.  LDW >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          > 0: if INFO = k, D(k,k) is exactly zero.  The factorization\n*               has been completed, but the block diagonal matrix D is\n*               exactly singular.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  kb, ipiv, info, a = NumRu::Lapack.clahef( uplo, nb, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_nb = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  nb = NUM2INT(rblapack_nb);
  ldw = MAX(1,n);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  w = ALLOC_N(complex, (ldw)*(MAX(n,nb)));

  clahef_(&uplo, &n, &nb, &kb, a, &lda, ipiv, w, &ldw, &info);

  free(w);
  rblapack_kb = INT2NUM(kb);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_kb, rblapack_ipiv, rblapack_info, rblapack_a);
}

void
init_lapack_clahef(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clahef", rblapack_clahef, -1);
}
ruby-lapack-1.7.2/ext/slasr.c0000644000175000017500000002051112502221025015645 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slasr_(char* side, char* pivot, char* direct, integer* m, integer* n, real* c, real* s, real* a, integer* lda);


static VALUE
rblapack_slasr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_pivot;
  char pivot; 
  VALUE rblapack_direct;
  char direct; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_a_out__;
  real *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  a = NumRu::Lapack.slasr( side, pivot, direct, m, c, s, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )\n\n*  Purpose\n*  =======\n*\n*  SLASR applies a sequence of plane rotations to a real matrix A,\n*  from either the left or the right.\n*  \n*  When SIDE = 'L', the transformation takes the form\n*  \n*     A := P*A\n*  \n*  and when SIDE = 'R', the transformation takes the form\n*  \n*     A := A*P**T\n*  \n*  where P is an orthogonal matrix consisting of a sequence of z plane\n*  rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',\n*  and P**T is the transpose of P.\n*  \n*  When DIRECT = 'F' (Forward sequence), then\n*  \n*     P = P(z-1) * ... * P(2) * P(1)\n*  \n*  and when DIRECT = 'B' (Backward sequence), then\n*  \n*     P = P(1) * P(2) * ... * P(z-1)\n*  \n*  where P(k) is a plane rotation matrix defined by the 2-by-2 rotation\n*  \n*     R(k) = (  c(k)  s(k) )\n*          = ( -s(k)  c(k) ).\n*  \n*  When PIVOT = 'V' (Variable pivot), the rotation is performed\n*  for the plane (k,k+1), i.e., P(k) has the form\n*  \n*     P(k) = (  1                                            )\n*            (       ...                                     )\n*            (              1                                )\n*            (                   c(k)  s(k)                  )\n*            (                  -s(k)  c(k)                  )\n*            (                                1              )\n*            (                                     ...       )\n*            (                                            1  )\n*  \n*  where R(k) appears as a rank-2 modification to the identity matrix in\n*  rows and columns k and k+1.\n*  \n*  When PIVOT = 'T' (Top pivot), the rotation is performed for the\n*  plane (1,k+1), so P(k) has the form\n*  \n*     P(k) = (  c(k)                    s(k)                 )\n*            (         1                                     )\n*            (              ...                              )\n*            (                     1                         )\n*            ( -s(k)                    c(k)                 )\n*            (                                 1             )\n*            (                                      ...      )\n*            (                                             1 )\n*  \n*  where R(k) appears in rows and columns 1 and k+1.\n*  \n*  Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is\n*  performed for the plane (k,z), giving P(k) the form\n*  \n*     P(k) = ( 1                                             )\n*            (      ...                                      )\n*            (             1                                 )\n*            (                  c(k)                    s(k) )\n*            (                         1                     )\n*            (                              ...              )\n*            (                                     1         )\n*            (                 -s(k)                    c(k) )\n*  \n*  where R(k) appears in rows and columns k and z.  The rotations are\n*  performed without ever forming P(k) explicitly.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          Specifies whether the plane rotation matrix P is applied to\n*          A on the left or the right.\n*          = 'L':  Left, compute A := P*A\n*          = 'R':  Right, compute A:= A*P**T\n*\n*  PIVOT   (input) CHARACTER*1\n*          Specifies the plane for which P(k) is a plane rotation\n*          matrix.\n*          = 'V':  Variable pivot, the plane (k,k+1)\n*          = 'T':  Top pivot, the plane (1,k+1)\n*          = 'B':  Bottom pivot, the plane (k,z)\n*\n*  DIRECT  (input) CHARACTER*1\n*          Specifies whether P is a forward or backward sequence of\n*          plane rotations.\n*          = 'F':  Forward, P = P(z-1)*...*P(2)*P(1)\n*          = 'B':  Backward, P = P(1)*P(2)*...*P(z-1)\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.  If m <= 1, an immediate\n*          return is effected.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.  If n <= 1, an\n*          immediate return is effected.\n*\n*  C       (input) REAL array, dimension\n*                  (M-1) if SIDE = 'L'\n*                  (N-1) if SIDE = 'R'\n*          The cosines c(k) of the plane rotations.\n*\n*  S       (input) REAL array, dimension\n*                  (M-1) if SIDE = 'L'\n*                  (N-1) if SIDE = 'R'\n*          The sines s(k) of the plane rotations.  The 2-by-2 plane\n*          rotation part of the matrix P(k), R(k), has the form\n*          R(k) = (  c(k)  s(k) )\n*                 ( -s(k)  c(k) ).\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          The M-by-N matrix A.  On exit, A is overwritten by P*A if\n*          SIDE = 'R' or by A*P**T if SIDE = 'L'.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  a = NumRu::Lapack.slasr( side, pivot, direct, m, c, s, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_side = argv[0];
  rblapack_pivot = argv[1];
  rblapack_direct = argv[2];
  rblapack_m = argv[3];
  rblapack_c = argv[4];
  rblapack_s = argv[5];
  rblapack_a = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  direct = StringValueCStr(rblapack_direct)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (7th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (7th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  pivot = StringValueCStr(rblapack_pivot)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (6th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != (m-1))
    rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", m-1);
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != (m-1))
    rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", m-1);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  slasr_(&side, &pivot, &direct, &m, &n, c, s, a, &lda);

  return rblapack_a;
}

void
init_lapack_slasr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slasr", rblapack_slasr, -1);
}
ruby-lapack-1.7.2/ext/sorgtr.c0000644000175000017500000001237212502221021016043 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sorgtr_(char* uplo, integer* n, real* a, integer* lda, real* tau, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sorgtr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *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  work, info, a = NumRu::Lapack.sorgtr( uplo, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SORGTR generates a real orthogonal matrix Q which is defined as the\n*  product of n-1 elementary reflectors of order N, as returned by\n*  SSYTRD:\n*\n*  if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),\n*\n*  if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U': Upper triangle of A contains elementary reflectors\n*                 from SSYTRD;\n*          = 'L': Lower triangle of A contains elementary reflectors\n*                 from SSYTRD.\n*\n*  N       (input) INTEGER\n*          The order of the matrix Q. N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the vectors which define the elementary reflectors,\n*          as returned by SSYTRD.\n*          On exit, the N-by-N orthogonal matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  TAU     (input) REAL array, dimension (N-1)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by SSYTRD.\n*\n*  WORK    (workspace/output) REAL 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,N-1).\n*          For optimum performance LWORK >= (N-1)*NB, where NB is\n*          the 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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, a = NumRu::Lapack.sorgtr( uplo, a, tau, [: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_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_tau = 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;
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (rblapack_lwork == Qnil)
    lwork = n-1;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_tau) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", n-1);
  if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  sorgtr_(&uplo, &n, a, &lda, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_sorgtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sorgtr", rblapack_sorgtr, -1);
}
ruby-lapack-1.7.2/ext/sgeev.c0000644000175000017500000002011512502221025015632 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgeev_(char* jobvl, char* jobvr, integer* n, real* a, integer* lda, real* wr, real* wi, real* vl, integer* ldvl, real* vr, integer* ldvr, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sgeev(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvl;
  char jobvl; 
  VALUE rblapack_jobvr;
  char jobvr; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_wr;
  real *wr; 
  VALUE rblapack_wi;
  real *wi; 
  VALUE rblapack_vl;
  real *vl; 
  VALUE rblapack_vr;
  real *vr; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;

  integer lda;
  integer n;
  integer ldvl;
  integer ldvr;

  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  wr, wi, vl, vr, work, info, a = NumRu::Lapack.sgeev( jobvl, jobvr, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGEEV computes for an N-by-N real nonsymmetric matrix A, the\n*  eigenvalues and, optionally, the left and/or right eigenvectors.\n*\n*  The right eigenvector v(j) of A satisfies\n*                   A * v(j) = lambda(j) * v(j)\n*  where lambda(j) is its eigenvalue.\n*  The left eigenvector u(j) of A satisfies\n*                u(j)**H * A = lambda(j) * u(j)**H\n*  where u(j)**H denotes the conjugate transpose of u(j).\n*\n*  The computed eigenvectors are normalized to have Euclidean norm\n*  equal to 1 and largest component real.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVL   (input) CHARACTER*1\n*          = 'N': left eigenvectors of A are not computed;\n*          = 'V': left eigenvectors of A are computed.\n*\n*  JOBVR   (input) CHARACTER*1\n*          = 'N': right eigenvectors of A are not computed;\n*          = 'V': right eigenvectors of A are computed.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the N-by-N matrix A.\n*          On exit, A has been overwritten.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  WR      (output) REAL array, dimension (N)\n*  WI      (output) REAL array, dimension (N)\n*          WR and WI contain the real and imaginary parts,\n*          respectively, of the computed eigenvalues.  Complex\n*          conjugate pairs of eigenvalues appear consecutively\n*          with the eigenvalue having the positive imaginary part\n*          first.\n*\n*  VL      (output) REAL array, dimension (LDVL,N)\n*          If JOBVL = 'V', the left eigenvectors u(j) are stored one\n*          after another in the columns of VL, in the same order\n*          as their eigenvalues.\n*          If JOBVL = 'N', VL is not referenced.\n*          If the j-th eigenvalue is real, then u(j) = VL(:,j),\n*          the j-th column of VL.\n*          If the j-th and (j+1)-st eigenvalues form a complex\n*          conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and\n*          u(j+1) = VL(:,j) - i*VL(:,j+1).\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the array VL.  LDVL >= 1; if\n*          JOBVL = 'V', LDVL >= N.\n*\n*  VR      (output) REAL array, dimension (LDVR,N)\n*          If JOBVR = 'V', the right eigenvectors v(j) are stored one\n*          after another in the columns of VR, in the same order\n*          as their eigenvalues.\n*          If JOBVR = 'N', VR is not referenced.\n*          If the j-th eigenvalue is real, then v(j) = VR(:,j),\n*          the j-th column of VR.\n*          If the j-th and (j+1)-st eigenvalues form a complex\n*          conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and\n*          v(j+1) = VR(:,j) - i*VR(:,j+1).\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the array VR.  LDVR >= 1; if\n*          JOBVR = 'V', LDVR >= N.\n*\n*  WORK    (workspace/output) REAL 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,3*N), and\n*          if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N.  For good\n*          performance, LWORK must generally be larger.\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 QR algorithm failed to compute all the\n*                eigenvalues, and no eigenvectors have been computed;\n*                elements i+1:N of WR and WI contain eigenvalues which\n*                have converged.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  wr, wi, vl, vr, work, info, a = NumRu::Lapack.sgeev( jobvl, jobvr, a, [: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_jobvl = argv[0];
  rblapack_jobvr = argv[1];
  rblapack_a = 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;
  }

  jobvl = StringValueCStr(rblapack_jobvl)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  ldvl = lsame_(&jobvl,"V") ? n : 1;
  jobvr = StringValueCStr(rblapack_jobvr)[0];
  ldvr = lsame_(&jobvr,"V") ? n : 1;
  if (rblapack_lwork == Qnil)
    lwork = (lsame_(&jobvl,"V")||lsame_(&jobvr,"V")) ? 4*n : 3*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  wr = NA_PTR_TYPE(rblapack_wr, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  wi = NA_PTR_TYPE(rblapack_wi, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = n;
    rblapack_vl = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vl = NA_PTR_TYPE(rblapack_vl, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = n;
    rblapack_vr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vr = NA_PTR_TYPE(rblapack_vr, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  sgeev_(&jobvl, &jobvr, &n, a, &lda, wr, wi, vl, &ldvl, vr, &ldvr, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_wr, rblapack_wi, rblapack_vl, rblapack_vr, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_sgeev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgeev", rblapack_sgeev, -1);
}
ruby-lapack-1.7.2/ext/cspr.c0000644000175000017500000001350512502221021015471 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cspr_(char* uplo, integer* n, complex* alpha, complex* x, integer* incx, complex* ap);


static VALUE
rblapack_cspr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_alpha;
  complex alpha; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_ap_out__;
  complex *ap_out__;


  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  ap = NumRu::Lapack.cspr( uplo, n, alpha, x, incx, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSPR( UPLO, N, ALPHA, X, INCX, AP )\n\n*  Purpose\n*  =======\n*\n*  CSPR    performs the symmetric rank 1 operation\n*\n*     A := alpha*x*conjg( x' ) + A,\n*\n*  where alpha is a complex scalar, x is an n element vector and A is an\n*  n by n symmetric matrix, supplied in packed form.\n*\n\n*  Arguments\n*  ==========\n*\n*  UPLO     (input) CHARACTER*1\n*           On entry, UPLO specifies whether the upper or lower\n*           triangular part of the matrix A is supplied in the packed\n*           array AP as follows:\n*\n*              UPLO = 'U' or 'u'   The upper triangular part of A is\n*                                  supplied in AP.\n*\n*              UPLO = 'L' or 'l'   The lower triangular part of A is\n*                                  supplied in AP.\n*\n*           Unchanged on exit.\n*\n*  N        (input) INTEGER\n*           On entry, N specifies the order of the matrix A.\n*           N must be at least zero.\n*           Unchanged on exit.\n*\n*  ALPHA    (input) COMPLEX\n*           On entry, ALPHA specifies the scalar alpha.\n*           Unchanged on exit.\n*\n*  X        (input) COMPLEX array, dimension at least\n*           ( 1 + ( N - 1 )*abs( INCX ) ).\n*           Before entry, the incremented array X must contain the N-\n*           element vector x.\n*           Unchanged on exit.\n*\n*  INCX     (input) INTEGER\n*           On entry, INCX specifies the increment for the elements of\n*           X. INCX must not be zero.\n*           Unchanged on exit.\n*\n*  AP       (input/output) COMPLEX array, dimension at least\n*           ( ( N*( N + 1 ) )/2 ).\n*           Before entry, with  UPLO = 'U' or 'u', the array AP must\n*           contain the upper triangular part of the symmetric matrix\n*           packed sequentially, column by column, so that AP( 1 )\n*           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )\n*           and a( 2, 2 ) respectively, and so on. On exit, the array\n*           AP is overwritten by the upper triangular part of the\n*           updated matrix.\n*           Before entry, with UPLO = 'L' or 'l', the array AP must\n*           contain the lower triangular part of the symmetric matrix\n*           packed sequentially, column by column, so that AP( 1 )\n*           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )\n*           and a( 3, 1 ) respectively, and so on. On exit, the array\n*           AP is overwritten by the lower triangular part of the\n*           updated matrix.\n*           Note that the imaginary parts of the diagonal elements need\n*           not be set, they are assumed to be zero, and on exit they\n*           are set to zero.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ap = NumRu::Lapack.cspr( uplo, n, alpha, x, incx, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_n = argv[1];
  rblapack_alpha = argv[2];
  rblapack_x = argv[3];
  rblapack_incx = argv[4];
  rblapack_ap = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  alpha.r = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
  alpha.i = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
  incx = NUM2INT(rblapack_incx);
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (6th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (( n*( n + 1 ) )/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", ( n*( n + 1 ) )/2);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (4th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1 + ( n - 1 )*abs( incx )))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[1];
    shape[0] = ( n*( n + 1 ) )/2;
    rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
  MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  cspr_(&uplo, &n, &alpha, x, &incx, ap);

  return rblapack_ap;
}

void
init_lapack_cspr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cspr", rblapack_cspr, -1);
}
ruby-lapack-1.7.2/ext/zgeev.c0000644000175000017500000001663212502221015015651 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgeev_(char* jobvl, char* jobvr, integer* n, doublecomplex* a, integer* lda, doublecomplex* w, doublecomplex* vl, integer* ldvl, doublecomplex* vr, integer* ldvr, doublecomplex* work, integer* lwork, doublereal* rwork, integer* info);


static VALUE
rblapack_zgeev(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvl;
  char jobvl; 
  VALUE rblapack_jobvr;
  char jobvr; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_w;
  doublecomplex *w; 
  VALUE rblapack_vl;
  doublecomplex *vl; 
  VALUE rblapack_vr;
  doublecomplex *vr; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  doublereal *rwork;

  integer lda;
  integer n;
  integer ldvl;
  integer ldvr;

  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  w, vl, vr, work, info, a = NumRu::Lapack.zgeev( jobvl, jobvr, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGEEV computes for an N-by-N complex nonsymmetric matrix A, the\n*  eigenvalues and, optionally, the left and/or right eigenvectors.\n*\n*  The right eigenvector v(j) of A satisfies\n*                   A * v(j) = lambda(j) * v(j)\n*  where lambda(j) is its eigenvalue.\n*  The left eigenvector u(j) of A satisfies\n*                u(j)**H * A = lambda(j) * u(j)**H\n*  where u(j)**H denotes the conjugate transpose of u(j).\n*\n*  The computed eigenvectors are normalized to have Euclidean norm\n*  equal to 1 and largest component real.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVL   (input) CHARACTER*1\n*          = 'N': left eigenvectors of A are not computed;\n*          = 'V': left eigenvectors of are computed.\n*\n*  JOBVR   (input) CHARACTER*1\n*          = 'N': right eigenvectors of A are not computed;\n*          = 'V': right eigenvectors of A are computed.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the N-by-N matrix A.\n*          On exit, A has been overwritten.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  W       (output) COMPLEX*16 array, dimension (N)\n*          W contains the computed eigenvalues.\n*\n*  VL      (output) COMPLEX*16 array, dimension (LDVL,N)\n*          If JOBVL = 'V', the left eigenvectors u(j) are stored one\n*          after another in the columns of VL, in the same order\n*          as their eigenvalues.\n*          If JOBVL = 'N', VL is not referenced.\n*          u(j) = VL(:,j), the j-th column of VL.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the array VL.  LDVL >= 1; if\n*          JOBVL = 'V', LDVL >= N.\n*\n*  VR      (output) COMPLEX*16 array, dimension (LDVR,N)\n*          If JOBVR = 'V', the right eigenvectors v(j) are stored one\n*          after another in the columns of VR, in the same order\n*          as their eigenvalues.\n*          If JOBVR = 'N', VR is not referenced.\n*          v(j) = VR(:,j), the j-th column of VR.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the array VR.  LDVR >= 1; if\n*          JOBVR = 'V', LDVR >= N.\n*\n*  WORK    (workspace/output) COMPLEX*16 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,2*N).\n*          For good performance, LWORK must generally be larger.\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*  RWORK   (workspace) DOUBLE PRECISION array, dimension (2*N)\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 QR algorithm failed to compute all the\n*                eigenvalues, and no eigenvectors have been computed;\n*                elements and i+1:N of W contain eigenvalues which have\n*                converged.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, vl, vr, work, info, a = NumRu::Lapack.zgeev( jobvl, jobvr, a, [: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_jobvl = argv[0];
  rblapack_jobvr = argv[1];
  rblapack_a = 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;
  }

  jobvl = StringValueCStr(rblapack_jobvl)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  ldvl = lsame_(&jobvl,"V") ? n : 1;
  jobvr = StringValueCStr(rblapack_jobvr)[0];
  ldvr = lsame_(&jobvr,"V") ? n : 1;
  if (rblapack_lwork == Qnil)
    lwork = 2*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = n;
    rblapack_vl = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  vl = NA_PTR_TYPE(rblapack_vl, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = n;
    rblapack_vr = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  vr = NA_PTR_TYPE(rblapack_vr, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  rwork = ALLOC_N(doublereal, (2*n));

  zgeev_(&jobvl, &jobvr, &n, a, &lda, w, vl, &ldvl, vr, &ldvr, work, &lwork, rwork, &info);

  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_w, rblapack_vl, rblapack_vr, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_zgeev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgeev", rblapack_zgeev, -1);
}
ruby-lapack-1.7.2/ext/zggrqf.c0000644000175000017500000002355512502221026016035 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zggrqf_(integer* m, integer* p, integer* n, doublecomplex* a, integer* lda, doublecomplex* taua, doublecomplex* b, integer* ldb, doublecomplex* taub, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zggrqf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_p;
  integer p; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_taua;
  doublecomplex *taua; 
  VALUE rblapack_taub;
  doublecomplex *taub; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer lda;
  integer n;
  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  taua, taub, work, info, a, b = NumRu::Lapack.zggrqf( m, p, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGGRQF computes a generalized RQ factorization of an M-by-N matrix A\n*  and a P-by-N matrix B:\n*\n*              A = R*Q,        B = Z*T*Q,\n*\n*  where Q is an N-by-N unitary matrix, Z is a P-by-P unitary\n*  matrix, and R and T assume one of the forms:\n*\n*  if M <= N,  R = ( 0  R12 ) M,   or if M > N,  R = ( R11 ) M-N,\n*                   N-M  M                           ( R21 ) N\n*                                                       N\n*\n*  where R12 or R21 is upper triangular, and\n*\n*  if P >= N,  T = ( T11 ) N  ,   or if P < N,  T = ( T11  T12 ) P,\n*                  (  0  ) P-N                         P   N-P\n*                     N\n*\n*  where T11 is upper triangular.\n*\n*  In particular, if B is square and nonsingular, the GRQ factorization\n*  of A and B implicitly gives the RQ factorization of A*inv(B):\n*\n*               A*inv(B) = (R*inv(T))*Z'\n*\n*  where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n*  conjugate transpose of the matrix Z.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.  M >= 0.\n*\n*  P       (input) INTEGER\n*          The number of rows of the matrix B.  P >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrices A and B. N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, if M <= N, the upper triangle of the subarray\n*          A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;\n*          if M > N, the elements on and above the (M-N)-th subdiagonal\n*          contain the M-by-N upper trapezoidal matrix R; the remaining\n*          elements, with the array TAUA, represent the unitary\n*          matrix Q as a product of elementary reflectors (see Further\n*          Details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  TAUA    (output) COMPLEX*16 array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors which\n*          represent the unitary matrix Q (see Further Details).\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,N)\n*          On entry, the P-by-N matrix B.\n*          On exit, the elements on and above the diagonal of the array\n*          contain the min(P,N)-by-N upper trapezoidal matrix T (T is\n*          upper triangular if P >= N); the elements below the diagonal,\n*          with the array TAUB, represent the unitary matrix Z as a\n*          product of elementary reflectors (see Further Details).\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,P).\n*\n*  TAUB    (output) COMPLEX*16 array, dimension (min(P,N))\n*          The scalar factors of the elementary reflectors which\n*          represent the unitary matrix Z (see Further Details).\n*\n*  WORK    (workspace/output) COMPLEX*16 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,N,M,P).\n*          For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n*          where NB1 is the optimal blocksize for the RQ factorization\n*          of an M-by-N matrix, NB2 is the optimal blocksize for the\n*          QR factorization of a P-by-N matrix, and NB3 is the optimal\n*          blocksize for a call of ZUNMRQ.\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(1) H(2) . . . H(k), where k = min(m,n).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - taua * v * v'\n*\n*  where taua is a complex scalar, and v is a complex vector with\n*  v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n*  A(m-k+i,1:n-k+i-1), and taua in TAUA(i).\n*  To form Q explicitly, use LAPACK subroutine ZUNGRQ.\n*  To use Q to update another matrix, use LAPACK subroutine ZUNMRQ.\n*\n*  The matrix Z is represented as a product of elementary reflectors\n*\n*     Z = H(1) H(2) . . . H(k), where k = min(p,n).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - taub * v * v'\n*\n*  where taub is a complex scalar, and v is a complex vector with\n*  v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),\n*  and taub in TAUB(i).\n*  To form Z explicitly, use LAPACK subroutine ZUNGQR.\n*  To use Z to update another matrix, use LAPACK subroutine ZUNMQR.\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY\n      INTEGER            LOPT, LWKOPT, NB, NB1, NB2, NB3\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZGEQRF, ZGERQF, ZUNMRQ\n*     ..\n*     .. External Functions ..\n      INTEGER            ILAENV\n      EXTERNAL           ILAENV\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          INT, MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  taua, taub, work, info, a, b = NumRu::Lapack.zggrqf( m, p, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_m = argv[0];
  rblapack_p = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  p = NUM2INT(rblapack_p);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  if (rblapack_lwork == Qnil)
    lwork = MAX(MAX(n,m),p);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_taua = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  taua = NA_PTR_TYPE(rblapack_taua, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(p,n);
    rblapack_taub = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  taub = NA_PTR_TYPE(rblapack_taub, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zggrqf_(&m, &p, &n, a, &lda, taua, b, &ldb, taub, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_taua, rblapack_taub, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_zggrqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zggrqf", rblapack_zggrqf, -1);
}
ruby-lapack-1.7.2/ext/cgeqlf.c0000644000175000017500000001355512502221020015767 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgeqlf_(integer* m, integer* n, complex* a, integer* lda, complex* tau, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_cgeqlf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *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.cgeqlf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGEQLF computes a QL factorization of a complex M-by-N matrix A:\n*  A = Q * L.\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) COMPLEX array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit,\n*          if m >= n, the lower triangle of the subarray\n*          A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L;\n*          if m <= n, the elements on and below the (n-m)-th\n*          superdiagonal contain the M-by-N lower trapezoidal matrix L;\n*          the remaining elements, with the array TAU, represent the\n*          unitary matrix Q as a product of elementary reflectors\n*          (see Further Details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  TAU     (output) COMPLEX array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace/output) COMPLEX 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,N).\n*          For optimum performance LWORK >= N*NB, where NB is\n*          the 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 complex scalar, and v is a complex vector with\n*  v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n*  A(1:m-k+i-1,n-k+i), and tau in TAU(i).\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY\n      INTEGER            I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n     $                   MU, NB, NBMIN, NU, NX\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CGEQL2, CLARFB, CLARFT, 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.cgeqlf( 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;
  }

  m = NUM2INT(rblapack_m);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  cgeqlf_(&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_cgeqlf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgeqlf", rblapack_cgeqlf, -1);
}
ruby-lapack-1.7.2/ext/zpbtrf.c0000644000175000017500000001217612502221021016034 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zpbtrf_(char* uplo, integer* n, integer* kd, doublecomplex* ab, integer* ldab, integer* info);


static VALUE
rblapack_zpbtrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublecomplex *ab_out__;

  integer ldab;
  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  info, ab = NumRu::Lapack.zpbtrf( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPBTRF( UPLO, N, KD, AB, LDAB, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPBTRF computes the Cholesky factorization of a complex Hermitian\n*  positive definite band matrix A.\n*\n*  The factorization has the form\n*     A = U**H * U,  if UPLO = 'U', or\n*     A = L  * L**H,  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is lower triangular.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*          On exit, if INFO = 0, the triangular factor U or L from the\n*          Cholesky factorization A = U**H*U or A = L*L**H of the band\n*          matrix A, in the same storage format as A.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\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 leading minor of order i is not\n*                positive definite, and the factorization could not be\n*                completed.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  N = 6, KD = 2, and UPLO = 'U':\n*\n*  On entry:                       On exit:\n*\n*      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46\n*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56\n*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66\n*\n*  Similarly, if UPLO = 'L' the format of A is as follows:\n*\n*  On entry:                       On exit:\n*\n*     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66\n*     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *\n*     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *\n*\n*  Array elements marked * are not used by the routine.\n*\n*  Contributed by\n*  Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ab = NumRu::Lapack.zpbtrf( uplo, kd, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  kd = NUM2INT(rblapack_kd);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
  MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  zpbtrf_(&uplo, &n, &kd, ab, &ldab, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ab);
}

void
init_lapack_zpbtrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zpbtrf", rblapack_zpbtrf, -1);
}
ruby-lapack-1.7.2/ext/sspsvx.c0000644000175000017500000003156012502221013016072 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sspsvx_(char* fact, char* uplo, integer* n, integer* nrhs, real* ap, real* afp, integer* ipiv, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* ferr, real* berr, real* work, integer* iwork, integer* info);


static VALUE
rblapack_sspsvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_afp;
  real *afp; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_afp_out__;
  real *afp_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  real *work;
  integer *iwork;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.sspsvx( fact, uplo, ap, afp, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSPSVX uses the diagonal pivoting factorization A = U*D*U**T or\n*  A = L*D*L**T to compute the solution to a real system of linear\n*  equations A * X = B, where A is an N-by-N symmetric matrix stored\n*  in packed format and X and B are N-by-NRHS matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'N', the diagonal pivoting method is used to factor A as\n*        A = U * D * U**T,  if UPLO = 'U', or\n*        A = L * D * L**T,  if UPLO = 'L',\n*     where U (or L) is a product of permutation and unit upper (lower)\n*     triangular matrices and D is symmetric and block diagonal with\n*     1-by-1 and 2-by-2 diagonal blocks.\n*\n*  2. If some D(i,i)=0, so that D is exactly singular, then the routine\n*     returns with INFO = i. Otherwise, the factored form of A is used\n*     to estimate the condition number of the matrix A.  If the\n*     reciprocal of the condition number is less than machine precision,\n*     INFO = N+1 is returned as a warning, but the routine still goes on\n*     to solve for X and compute error bounds as described below.\n*\n*  3. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  4. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of A has been\n*          supplied on entry.\n*          = 'F':  On entry, AFP and IPIV contain the factored form of\n*                  A.  AP, AFP and IPIV will not be modified.\n*          = 'N':  The matrix A will be copied to AFP and factored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AP      (input) REAL array, dimension (N*(N+1)/2)\n*          The upper or lower triangle of the symmetric matrix A, packed\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*          See below for further details.\n*\n*  AFP     (input or output) REAL array, dimension\n*                            (N*(N+1)/2)\n*          If FACT = 'F', then AFP is an input argument and on entry\n*          contains the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L from the factorization\n*          A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as\n*          a packed triangular matrix in the same storage format as A.\n*\n*          If FACT = 'N', then AFP is an output argument and on exit\n*          contains the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L from the factorization\n*          A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as\n*          a packed triangular matrix in the same storage format as A.\n*\n*  IPIV    (input or output) INTEGER array, dimension (N)\n*          If FACT = 'F', then IPIV is an input argument and on entry\n*          contains details of the interchanges and the block structure\n*          of D, as determined by SSPTRF.\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*          If FACT = 'N', then IPIV is an output argument and on exit\n*          contains details of the interchanges and the block structure\n*          of D, as determined by SSPTRF.\n*\n*  B       (input) REAL array, dimension (LDB,NRHS)\n*          The N-by-NRHS right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) REAL array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) REAL\n*          The estimate of the reciprocal condition number of the matrix\n*          A.  If RCOND is less than the machine precision (in\n*          particular, if RCOND = 0), the matrix is singular to working\n*          precision.  This condition is indicated by a return code of\n*          INFO > 0.\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) REAL array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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, and i is\n*                <= N:  D(i,i) is exactly zero.  The factorization\n*                       has been completed but the factor D is exactly\n*                       singular, so the solution and error bounds could\n*                       not be computed. RCOND = 0 is returned.\n*                = N+1: D is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  Further Details\n*  ===============\n*\n*  The packed storage scheme is illustrated by the following example\n*  when N = 4, UPLO = 'U':\n*\n*  Two-dimensional storage of the symmetric matrix A:\n*\n*     a11 a12 a13 a14\n*         a22 a23 a24\n*             a33 a34     (aij = aji)\n*                 a44\n*\n*  Packed storage of the upper triangle of A:\n*\n*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.sspsvx( fact, uplo, ap, afp, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_ap = argv[2];
  rblapack_afp = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_b = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  ldx = MAX(1,n);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_afp))
    rb_raise(rb_eArgError, "afp (4th argument) must be NArray");
  if (NA_RANK(rblapack_afp) != 1)
    rb_raise(rb_eArgError, "rank of afp (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_afp) != NA_SFLOAT)
    rblapack_afp = na_change_type(rblapack_afp, NA_SFLOAT);
  afp = NA_PTR_TYPE(rblapack_afp, real*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_afp_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  afp_out__ = NA_PTR_TYPE(rblapack_afp_out__, real*);
  MEMCPY(afp_out__, afp, real, NA_TOTAL(rblapack_afp));
  rblapack_afp = rblapack_afp_out__;
  afp = afp_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  work = ALLOC_N(real, (3*n));
  iwork = ALLOC_N(integer, (n));

  sspsvx_(&fact, &uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_afp, rblapack_ipiv);
}

void
init_lapack_sspsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sspsvx", rblapack_sspsvx, -1);
}
ruby-lapack-1.7.2/ext/cppcon.c0000644000175000017500000001006512502221017016007 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cppcon_(char* uplo, integer* n, complex* ap, real* anorm, real* rcond, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cppcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_anorm;
  real anorm; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_info;
  integer info; 
  complex *work;
  real *rwork;

  integer ldap;
  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  rcond, info = NumRu::Lapack.cppcon( uplo, ap, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPPCON( UPLO, N, AP, ANORM, RCOND, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPPCON estimates the reciprocal of the condition number (in the \n*  1-norm) of a complex Hermitian positive definite packed matrix using\n*  the Cholesky factorization A = U**H*U or A = L*L**H computed by\n*  CPPTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**H*U or A = L*L**H, packed columnwise in a linear\n*          array.  The j-th column of U or L is stored in the array AP\n*          as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n*  ANORM   (input) REAL\n*          The 1-norm (or infinity-norm) of the Hermitian matrix A.\n*\n*  RCOND   (output) REAL\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n*          estimate of the 1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.cppcon( uplo, ap, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_anorm = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  anorm = (real)NUM2DBL(rblapack_anorm);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (n));

  cppcon_(&uplo, &n, ap, &anorm, &rcond, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_cppcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cppcon", rblapack_cppcon, -1);
}
ruby-lapack-1.7.2/ext/zlargv.c0000644000175000017500000001256112502221012016030 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlargv_(integer* n, doublecomplex* x, integer* incx, doublecomplex* y, integer* incy, doublereal* c, integer* incc);


static VALUE
rblapack_zlargv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_y;
  doublecomplex *y; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_incc;
  integer incc; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;
  VALUE rblapack_y_out__;
  doublecomplex *y_out__;


  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  c, x, y = NumRu::Lapack.zlargv( n, x, incx, y, incy, incc, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLARGV( N, X, INCX, Y, INCY, C, INCC )\n\n*  Purpose\n*  =======\n*\n*  ZLARGV generates a vector of complex plane rotations with real\n*  cosines, determined by elements of the complex vectors x and y.\n*  For i = 1,2,...,n\n*\n*     (        c(i)   s(i) ) ( x(i) ) = ( r(i) )\n*     ( -conjg(s(i))  c(i) ) ( y(i) ) = (   0  )\n*\n*     where c(i)**2 + ABS(s(i))**2 = 1\n*\n*  The following conventions are used (these are the same as in ZLARTG,\n*  but differ from the BLAS1 routine ZROTG):\n*     If y(i)=0, then c(i)=1 and s(i)=0.\n*     If x(i)=0, then c(i)=0 and s(i) is chosen so that r(i) is real.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of plane rotations to be generated.\n*\n*  X       (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX)\n*          On entry, the vector x.\n*          On exit, x(i) is overwritten by r(i), for i = 1,...,n.\n*\n*  INCX    (input) INTEGER\n*          The increment between elements of X. INCX > 0.\n*\n*  Y       (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCY)\n*          On entry, the vector y.\n*          On exit, the sines of the plane rotations.\n*\n*  INCY    (input) INTEGER\n*          The increment between elements of Y. INCY > 0.\n*\n*  C       (output) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)\n*          The cosines of the plane rotations.\n*\n*  INCC    (input) INTEGER\n*          The increment between elements of C. INCC > 0.\n*\n\n*  Further Details\n*  ======= =======\n*\n*  6-6-96 - Modified with a new algorithm by W. Kahan and J. Demmel\n*\n*  This version has a few statements commented out for thread safety\n*  (machine parameters are computed on each entry). 10 feb 03, SJH.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c, x, y = NumRu::Lapack.zlargv( n, x, incx, y, incy, incc, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_n = argv[0];
  rblapack_x = argv[1];
  rblapack_incx = argv[2];
  rblapack_y = argv[3];
  rblapack_incy = argv[4];
  rblapack_incc = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  incx = NUM2INT(rblapack_incx);
  incy = NUM2INT(rblapack_incy);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1+(n-1)*incx))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  incc = NUM2INT(rblapack_incc);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (4th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incy))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
  if (NA_TYPE(rblapack_y) != NA_DCOMPLEX)
    rblapack_y = na_change_type(rblapack_y, NA_DCOMPLEX);
  y = NA_PTR_TYPE(rblapack_y, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incc;
    rblapack_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incx;
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incy;
    rblapack_y_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublecomplex*);
  MEMCPY(y_out__, y, doublecomplex, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  zlargv_(&n, x, &incx, y, &incy, c, &incc);

  return rb_ary_new3(3, rblapack_c, rblapack_x, rblapack_y);
}

void
init_lapack_zlargv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlargv", rblapack_zlargv, -1);
}
ruby-lapack-1.7.2/ext/cpttrs.c0000644000175000017500000001310412502221022016035 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cpttrs_(char* uplo, integer* n, integer* nrhs, real* d, complex* e, complex* b, integer* ldb, integer* info);


static VALUE
rblapack_cpttrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  complex *e; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.cpttrs( uplo, d, e, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPTTRS( UPLO, N, NRHS, D, E, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPTTRS solves a tridiagonal system of the form\n*     A * X = B\n*  using the factorization A = U'*D*U or A = L*D*L' computed by CPTTRF.\n*  D is a diagonal matrix specified in the vector D, U (or L) is a unit\n*  bidiagonal matrix whose superdiagonal (subdiagonal) is specified in\n*  the vector E, and X and B are N by NRHS matrices.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies the form of the factorization and whether the\n*          vector E is the superdiagonal of the upper bidiagonal factor\n*          U or the subdiagonal of the lower bidiagonal factor L.\n*          = 'U':  A = U'*D*U, E is the superdiagonal of U\n*          = 'L':  A = L*D*L', E is the subdiagonal of L\n*\n*  N       (input) INTEGER\n*          The order of the tridiagonal matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  D       (input) REAL array, dimension (N)\n*          The n diagonal elements of the diagonal matrix D from the\n*          factorization A = U'*D*U or A = L*D*L'.\n*\n*  E       (input) COMPLEX array, dimension (N-1)\n*          If UPLO = 'U', the (n-1) superdiagonal elements of the unit\n*          bidiagonal factor U from the factorization A = U'*D*U.\n*          If UPLO = 'L', the (n-1) subdiagonal elements of the unit\n*          bidiagonal factor L from the factorization A = L*D*L'.\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the right hand side vectors B for the system of\n*          linear equations.\n*          On exit, the solution vectors, X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            UPPER\n      INTEGER            IUPLO, J, JB, NB\n*     ..\n*     .. External Functions ..\n      INTEGER            ILAENV\n      EXTERNAL           ILAENV\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CPTTS2, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.cpttrs( uplo, d, e, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SCOMPLEX)
    rblapack_e = na_change_type(rblapack_e, NA_SCOMPLEX);
  e = NA_PTR_TYPE(rblapack_e, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  cpttrs_(&uplo, &n, &nrhs, d, e, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_cpttrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cpttrs", rblapack_cpttrs, -1);
}
ruby-lapack-1.7.2/ext/ssbev.c0000644000175000017500000001332512502221024015647 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssbev_(char* jobz, char* uplo, integer* n, integer* kd, real* ab, integer* ldab, real* w, real* z, integer* ldz, real* work, integer* info);


static VALUE
rblapack_ssbev(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  real *ab_out__;
  real *work;

  integer ldab;
  integer n;
  integer ldz;

  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  w, z, info, ab = NumRu::Lapack.ssbev( jobz, uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSBEV computes all the eigenvalues and, optionally, eigenvectors of\n*  a real symmetric band matrix A.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) REAL array, dimension (LDAB, N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*          On exit, AB is overwritten by values generated during the\n*          reduction to tridiagonal form.  If UPLO = 'U', the first\n*          superdiagonal and the diagonal of the tridiagonal matrix T\n*          are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n*          the diagonal and first subdiagonal of T are returned in the\n*          first two rows of AB.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD + 1.\n*\n*  W       (output) REAL array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) REAL array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n*          eigenvectors of the matrix A, with the i-th column of Z\n*          holding the eigenvector associated with W(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace) REAL array, dimension (max(1,3*N-2))\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 algorithm failed to converge; i\n*                off-diagonal elements of an intermediate tridiagonal\n*                form did not converge to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, info, ab = NumRu::Lapack.ssbev( jobz, uplo, kd, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_kd = argv[2];
  rblapack_ab = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  kd = NUM2INT(rblapack_kd);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
  MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  work = ALLOC_N(real, (MAX(1,3*n-2)));

  ssbev_(&jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_w, rblapack_z, rblapack_info, rblapack_ab);
}

void
init_lapack_ssbev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssbev", rblapack_ssbev, -1);
}
ruby-lapack-1.7.2/ext/cposvx.c0000644000175000017500000003611512502221020016045 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cposvx_(char* fact, char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, char* equed, real* s, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* ferr, real* berr, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cposvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_af_out__;
  complex *af_out__;
  VALUE rblapack_s_out__;
  real *s_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;
  complex *work;
  real *rwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, info, a, af, equed, s, b = NumRu::Lapack.cposvx( fact, uplo, a, af, equed, s, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPOSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to\n*  compute the solution to a complex system of linear equations\n*     A * X = B,\n*  where A is an N-by-N Hermitian positive definite matrix and X and B\n*  are N-by-NRHS matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'E', real scaling factors are computed to equilibrate\n*     the system:\n*        diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n*  2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n*     factor the matrix A (after equilibration if FACT = 'E') as\n*        A = U**H* U,  if UPLO = 'U', or\n*        A = L * L**H,  if UPLO = 'L',\n*     where U is an upper triangular matrix and L is a lower triangular\n*     matrix.\n*\n*  3. If the leading i-by-i principal minor is not positive definite,\n*     then the routine returns with INFO = i. Otherwise, the factored\n*     form of A is used to estimate the condition number of the matrix\n*     A.  If the reciprocal of the condition number is less than machine\n*     precision, INFO = N+1 is returned as a warning, but the routine\n*     still goes on to solve for X and compute error bounds as\n*     described below.\n*\n*  4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  5. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n*  6. If equilibration was used, the matrix X is premultiplied by\n*     diag(S) so that it solves the original system before\n*     equilibration.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of the matrix A is\n*          supplied on entry, and if not, whether the matrix A should be\n*          equilibrated before it is factored.\n*          = 'F':  On entry, AF contains the factored form of A.\n*                  If EQUED = 'Y', the matrix A has been equilibrated\n*                  with scaling factors given by S.  A and AF will not\n*                  be modified.\n*          = 'N':  The matrix A will be copied to AF and factored.\n*          = 'E':  The matrix A will be equilibrated if necessary, then\n*                  copied to AF and factored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the Hermitian matrix A, except if FACT = 'F' and\n*          EQUED = 'Y', then A must contain the equilibrated matrix\n*          diag(S)*A*diag(S).  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.  A is not modified if\n*          FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n*          On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n*          diag(S)*A*diag(S).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AF      (input or output) COMPLEX array, dimension (LDAF,N)\n*          If FACT = 'F', then AF is an input argument and on entry\n*          contains the triangular factor U or L from the Cholesky\n*          factorization A = U**H*U or A = L*L**H, in the same storage\n*          format as A.  If EQUED .ne. 'N', then AF is the factored form\n*          of the equilibrated matrix diag(S)*A*diag(S).\n*\n*          If FACT = 'N', then AF is an output argument and on exit\n*          returns the triangular factor U or L from the Cholesky\n*          factorization A = U**H*U or A = L*L**H of the original\n*          matrix A.\n*\n*          If FACT = 'E', then AF is an output argument and on exit\n*          returns the triangular factor U or L from the Cholesky\n*          factorization A = U**H*U or A = L*L**H of the equilibrated\n*          matrix A (see the description of A for the form of the\n*          equilibrated matrix).\n*\n*  LDAF    (input) INTEGER\n*          The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*  EQUED   (input or output) CHARACTER*1\n*          Specifies the form of equilibration that was done.\n*          = 'N':  No equilibration (always true if FACT = 'N').\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*          EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*          output argument.\n*\n*  S       (input or output) REAL array, dimension (N)\n*          The scale factors for A; not accessed if EQUED = 'N'.  S is\n*          an input argument if FACT = 'F'; otherwise, S is an output\n*          argument.  If FACT = 'F' and EQUED = 'Y', each element of S\n*          must be positive.\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS righthand side matrix B.\n*          On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n*          B is overwritten by diag(S) * B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) COMPLEX array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n*          the original system of equations.  Note that if EQUED = 'Y',\n*          A and B are modified on exit, and the solution to the\n*          equilibrated system is inv(diag(S))*X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) REAL\n*          The estimate of the reciprocal condition number of the matrix\n*          A after equilibration (if done).  If RCOND is less than the\n*          machine precision (in particular, if RCOND = 0), the matrix\n*          is singular to working precision.  This condition is\n*          indicated by a return code of INFO > 0.\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\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, and i is\n*                <= N:  the leading minor of order i of A is\n*                       not positive definite, so the factorization\n*                       could not be completed, and the solution has not\n*                       been computed. RCOND = 0 is returned.\n*                = N+1: U is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, info, a, af, equed, s, b = NumRu::Lapack.cposvx( fact, uplo, a, af, equed, s, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_equed = argv[4];
  rblapack_s = argv[5];
  rblapack_b = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (6th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  ldx = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldaf;
    shape[1] = n;
    rblapack_af_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  af_out__ = NA_PTR_TYPE(rblapack_af_out__, complex*);
  MEMCPY(af_out__, af, complex, NA_TOTAL(rblapack_af));
  rblapack_af = rblapack_af_out__;
  af = af_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
  MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (n));

  cposvx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_a, rblapack_af, rblapack_equed, rblapack_s, rblapack_b);
}

void
init_lapack_cposvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cposvx", rblapack_cposvx, -1);
}
ruby-lapack-1.7.2/ext/cgeqr2p.c0000644000175000017500000001033612502221013016065 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgeqr2p_(integer* m, integer* n, complex* a, integer* lda, complex* tau, complex* work, integer* info);


static VALUE
rblapack_cgeqr2p(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  complex *work;

  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, info, a = NumRu::Lapack.cgeqr2p( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGEQR2P( M, N, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGEQR2P computes a QR factorization of a complex m by n matrix A:\n*  A = Q * R.\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) COMPLEX array, dimension (LDA,N)\n*          On entry, the m by n matrix A.\n*          On exit, the elements on and above the diagonal of the array\n*          contain the min(m,n) by n upper trapezoidal matrix R (R is\n*          upper triangular if m >= n); the elements below the diagonal,\n*          with the array TAU, represent the unitary 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) COMPLEX array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace) COMPLEX array, dimension (N)\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(1) H(2) . . . H(k), 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 complex scalar, and v is a complex vector with\n*  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\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.cgeqr2p( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(complex, (n));

  cgeqr2p_(&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_cgeqr2p(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgeqr2p", rblapack_cgeqr2p, -1);
}
ruby-lapack-1.7.2/ext/sspevx.c0000644000175000017500000002274112502221015016057 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sspevx_(char* jobz, char* range, char* uplo, integer* n, real* ap, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, real* z, integer* ldz, real* work, integer* iwork, integer* ifail, integer* info);


static VALUE
rblapack_sspevx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_vl;
  real vl; 
  VALUE rblapack_vu;
  real vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  real abstol; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_ifail;
  integer *ifail; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  real *ap_out__;
  real *work;
  integer *iwork;

  integer ldap;
  integer n;
  integer ldz;

  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  m, w, z, ifail, info, ap = NumRu::Lapack.sspevx( jobz, range, uplo, ap, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSPEVX computes selected eigenvalues and, optionally, eigenvectors\n*  of a real symmetric matrix A in packed storage.  Eigenvalues/vectors\n*  can be selected by specifying either a range of values or a range of\n*  indices for the desired eigenvalues.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found;\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found;\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) REAL array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, AP is overwritten by values generated during the\n*          reduction to tridiagonal form.  If UPLO = 'U', the diagonal\n*          and first superdiagonal of the tridiagonal matrix T overwrite\n*          the corresponding elements of A, and if UPLO = 'L', the\n*          diagonal and first subdiagonal of T overwrite the\n*          corresponding elements of A.\n*\n*  VL      (input) REAL\n*  VU      (input) REAL\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) REAL\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less than\n*          or equal to zero, then  EPS*|T|  will be used in its place,\n*          where |T| is the 1-norm of the tridiagonal matrix obtained\n*          by reducing AP to tridiagonal form.\n*\n*          Eigenvalues will be computed most accurately when ABSTOL is\n*          set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n*          If this routine returns with INFO>0, indicating that some\n*          eigenvectors did not converge, try setting ABSTOL to\n*          2*SLAMCH('S').\n*\n*          See \"Computing Small Singular Values of Bidiagonal Matrices\n*          with Guaranteed High Relative Accuracy,\" by Demmel and\n*          Kahan, LAPACK Working Note #3.\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) REAL array, dimension (N)\n*          If INFO = 0, the selected eigenvalues in ascending order.\n*\n*  Z       (output) REAL array, dimension (LDZ, max(1,M))\n*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix A\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          If an eigenvector fails to converge, then that column of Z\n*          contains the latest approximation to the eigenvector, and the\n*          index of the eigenvector is returned in IFAIL.\n*          If JOBZ = 'N', then Z is not referenced.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace) REAL array, dimension (8*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (5*N)\n*\n*  IFAIL   (output) INTEGER array, dimension (N)\n*          If JOBZ = 'V', then if INFO = 0, the first M elements of\n*          IFAIL are zero.  If INFO > 0, then IFAIL contains the\n*          indices of the eigenvectors that failed to converge.\n*          If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n*                Their indices are stored in array IFAIL.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, ifail, info, ap = NumRu::Lapack.sspevx( jobz, range, uplo, ap, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_uplo = argv[2];
  rblapack_ap = argv[3];
  rblapack_vl = argv[4];
  rblapack_vu = argv[5];
  rblapack_il = argv[6];
  rblapack_iu = argv[7];
  rblapack_abstol = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  vl = (real)NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  abstol = (real)NUM2DBL(rblapack_abstol);
  range = StringValueCStr(rblapack_range)[0];
  vu = (real)NUM2DBL(rblapack_vu);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  iu = NUM2INT(rblapack_iu);
  m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, real*);
  MEMCPY(ap_out__, ap, real, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  work = ALLOC_N(real, (8*n));
  iwork = ALLOC_N(integer, (5*n));

  sspevx_(&jobz, &range, &uplo, &n, ap, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, iwork, ifail, &info);

  free(work);
  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_ap);
}

void
init_lapack_sspevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sspevx", rblapack_sspevx, -1);
}
ruby-lapack-1.7.2/ext/zspsvx.c0000644000175000017500000003221312502221023016076 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zspsvx_(char* fact, char* uplo, integer* n, integer* nrhs, doublecomplex* ap, doublecomplex* afp, integer* ipiv, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zspsvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_afp;
  doublecomplex *afp; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_afp_out__;
  doublecomplex *afp_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.zspsvx( fact, uplo, ap, afp, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZSPSVX uses the diagonal pivoting factorization A = U*D*U**T or\n*  A = L*D*L**T to compute the solution to a complex system of linear\n*  equations A * X = B, where A is an N-by-N symmetric matrix stored\n*  in packed format and X and B are N-by-NRHS matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'N', the diagonal pivoting method is used to factor A as\n*        A = U * D * U**T,  if UPLO = 'U', or\n*        A = L * D * L**T,  if UPLO = 'L',\n*     where U (or L) is a product of permutation and unit upper (lower)\n*     triangular matrices and D is symmetric and block diagonal with\n*     1-by-1 and 2-by-2 diagonal blocks.\n*\n*  2. If some D(i,i)=0, so that D is exactly singular, then the routine\n*     returns with INFO = i. Otherwise, the factored form of A is used\n*     to estimate the condition number of the matrix A.  If the\n*     reciprocal of the condition number is less than machine precision,\n*     INFO = N+1 is returned as a warning, but the routine still goes on\n*     to solve for X and compute error bounds as described below.\n*\n*  3. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  4. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of A has been\n*          supplied on entry.\n*          = 'F':  On entry, AFP and IPIV contain the factored form\n*                  of A.  AP, AFP and IPIV will not be modified.\n*          = 'N':  The matrix A will be copied to AFP and factored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          The upper or lower triangle of the symmetric matrix A, packed\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*          See below for further details.\n*\n*  AFP     (input or output) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          If FACT = 'F', then AFP is an input argument and on entry\n*          contains the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L from the factorization\n*          A = U*D*U**T or A = L*D*L**T as computed by ZSPTRF, stored as\n*          a packed triangular matrix in the same storage format as A.\n*\n*          If FACT = 'N', then AFP is an output argument and on exit\n*          contains the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L from the factorization\n*          A = U*D*U**T or A = L*D*L**T as computed by ZSPTRF, stored as\n*          a packed triangular matrix in the same storage format as A.\n*\n*  IPIV    (input or output) INTEGER array, dimension (N)\n*          If FACT = 'F', then IPIV is an input argument and on entry\n*          contains details of the interchanges and the block structure\n*          of D, as determined by ZSPTRF.\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*          If FACT = 'N', then IPIV is an output argument and on exit\n*          contains details of the interchanges and the block structure\n*          of D, as determined by ZSPTRF.\n*\n*  B       (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*          The N-by-NRHS right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) COMPLEX*16 array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The estimate of the reciprocal condition number of the matrix\n*          A.  If RCOND is less than the machine precision (in\n*          particular, if RCOND = 0), the matrix is singular to working\n*          precision.  This condition is indicated by a return code of\n*          INFO > 0.\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\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, and i is\n*                <= N:  D(i,i) is exactly zero.  The factorization\n*                       has been completed but the factor D is exactly\n*                       singular, so the solution and error bounds could\n*                       not be computed. RCOND = 0 is returned.\n*                = N+1: D is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  Further Details\n*  ===============\n*\n*  The packed storage scheme is illustrated by the following example\n*  when N = 4, UPLO = 'U':\n*\n*  Two-dimensional storage of the symmetric matrix A:\n*\n*     a11 a12 a13 a14\n*         a22 a23 a24\n*             a33 a34     (aij = aji)\n*                 a44\n*\n*  Packed storage of the upper triangle of A:\n*\n*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.zspsvx( fact, uplo, ap, afp, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_ap = argv[2];
  rblapack_afp = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_b = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  ldx = MAX(1,n);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_afp))
    rb_raise(rb_eArgError, "afp (4th argument) must be NArray");
  if (NA_RANK(rblapack_afp) != 1)
    rb_raise(rb_eArgError, "rank of afp (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_afp) != NA_DCOMPLEX)
    rblapack_afp = na_change_type(rblapack_afp, NA_DCOMPLEX);
  afp = NA_PTR_TYPE(rblapack_afp, doublecomplex*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_afp_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  afp_out__ = NA_PTR_TYPE(rblapack_afp_out__, doublecomplex*);
  MEMCPY(afp_out__, afp, doublecomplex, NA_TOTAL(rblapack_afp));
  rblapack_afp = rblapack_afp_out__;
  afp = afp_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (n));

  zspsvx_(&fact, &uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_afp, rblapack_ipiv);
}

void
init_lapack_zspsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zspsvx", rblapack_zspsvx, -1);
}
ruby-lapack-1.7.2/ext/ssyequb.c0000644000175000017500000001145212502221016016220 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssyequb_(char* uplo, integer* n, real* a, integer* lda, real* s, real* scond, real* amax, real* work, integer* info);


static VALUE
rblapack_ssyequb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_scond;
  real scond; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_info;
  integer info; 
  real *work;

  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  s, scond, amax, info = NumRu::Lapack.ssyequb( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSYEQUB computes row and column scalings intended to equilibrate a\n*  symmetric matrix A and reduce its condition number\n*  (with respect to the two-norm).  S contains the scale factors,\n*  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n*  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This\n*  choice of S puts the condition number of B within a factor N of the\n*  smallest possible condition number over all possible diagonal\n*  scalings.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) REAL array, dimension (LDA,N)\n*          The N-by-N symmetric matrix whose scaling\n*          factors are to be computed.  Only the diagonal elements of A\n*          are referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  S       (output) REAL array, dimension (N)\n*          If INFO = 0, S contains the scale factors for A.\n*\n*  SCOND   (output) REAL\n*          If INFO = 0, S contains the ratio of the smallest S(i) to\n*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too\n*          large nor too small, it is not worth scaling by S.\n*\n*  AMAX    (output) REAL\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\n*\n*  WORK    (workspace) REAL array, dimension (3*N)\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 is nonpositive.\n*\n\n*  Further Details\n*  ======= =======\n*\n*  Reference: Livne, O.E. and Golub, G.H., \"Scaling by Binormalization\",\n*  Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004.\n*  DOI 10.1023/B:NUMA.0000016606.32820.69\n*  Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, scond, amax, info = NumRu::Lapack.ssyequb( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, real*);
  work = ALLOC_N(real, (3*n));

  ssyequb_(&uplo, &n, a, &lda, s, &scond, &amax, work, &info);

  free(work);
  rblapack_scond = rb_float_new((double)scond);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
}

void
init_lapack_ssyequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssyequb", rblapack_ssyequb, -1);
}
ruby-lapack-1.7.2/ext/zptcon.c0000644000175000017500000001054412502221021016037 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zptcon_(integer* n, doublereal* d, doublecomplex* e, doublereal* anorm, doublereal* rcond, doublereal* rwork, integer* info);


static VALUE
rblapack_zptcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublecomplex *e; 
  VALUE rblapack_anorm;
  doublereal anorm; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_info;
  integer info; 
  doublereal *rwork;

  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  rcond, info = NumRu::Lapack.zptcon( d, e, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPTCON( N, D, E, ANORM, RCOND, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPTCON computes the reciprocal of the condition number (in the\n*  1-norm) of a complex Hermitian positive definite tridiagonal matrix\n*  using the factorization A = L*D*L**H or A = U**H*D*U computed by\n*  ZPTTRF.\n*\n*  Norm(inv(A)) is computed by a direct method, and the reciprocal of\n*  the condition number is computed as\n*                   RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          The n diagonal elements of the diagonal matrix D from the\n*          factorization of A, as computed by ZPTTRF.\n*\n*  E       (input) COMPLEX*16 array, dimension (N-1)\n*          The (n-1) off-diagonal elements of the unit bidiagonal factor\n*          U or L from the factorization of A, as computed by ZPTTRF.\n*\n*  ANORM   (input) DOUBLE PRECISION\n*          The 1-norm of the original matrix A.\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the\n*          1-norm of inv(A) computed in this routine.\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\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 method used is described in Nicholas J. Higham, \"Efficient\n*  Algorithms for Computing the Condition Number of a Tridiagonal\n*  Matrix\", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.zptcon( d, e, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_d = argv[0];
  rblapack_e = argv[1];
  rblapack_anorm = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  anorm = NUM2DBL(rblapack_anorm);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (2th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DCOMPLEX)
    rblapack_e = na_change_type(rblapack_e, NA_DCOMPLEX);
  e = NA_PTR_TYPE(rblapack_e, doublecomplex*);
  rwork = ALLOC_N(doublereal, (n));

  zptcon_(&n, d, e, &anorm, &rcond, rwork, &info);

  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_zptcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zptcon", rblapack_zptcon, -1);
}
ruby-lapack-1.7.2/ext/zgeequ.c0000644000175000017500000001214412502221022016021 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgeequ_(integer* m, integer* n, doublecomplex* a, integer* lda, doublereal* r, doublereal* c, doublereal* rowcnd, doublereal* colcnd, doublereal* amax, integer* info);


static VALUE
rblapack_zgeequ(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_r;
  doublereal *r; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_rowcnd;
  doublereal rowcnd; 
  VALUE rblapack_colcnd;
  doublereal colcnd; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_info;
  integer info; 

  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  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.zgeequ( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGEEQU computes row and column scalings intended to equilibrate an\n*  M-by-N matrix A and reduce its condition number.  R returns the row\n*  scale factors and C the column scale factors, chosen to try to make\n*  the largest element in each row and column of the matrix B with\n*  elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n*\n*  R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n*  number and BIGNUM = largest safe number.  Use of these scaling\n*  factors is not guaranteed to reduce the condition number of A but\n*  works well in practice.\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) COMPLEX*16 array, dimension (LDA,N)\n*          The M-by-N matrix whose equilibration factors are\n*          to be computed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  R       (output) DOUBLE PRECISION array, dimension (M)\n*          If INFO = 0 or INFO > M, R contains the row scale factors\n*          for A.\n*\n*  C       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0,  C contains the column scale factors for A.\n*\n*  ROWCND  (output) DOUBLE PRECISION\n*          If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n*          smallest R(i) to the largest R(i).  If ROWCND >= 0.1 and\n*          AMAX is neither too large nor too small, it is not worth\n*          scaling by R.\n*\n*  COLCND  (output) DOUBLE PRECISION\n*          If INFO = 0, COLCND contains the ratio of the smallest\n*          C(i) to the largest C(i).  If COLCND >= 0.1, it is not\n*          worth scaling by C.\n*\n*  AMAX    (output) DOUBLE PRECISION\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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,  and i is\n*                <= M:  the i-th row of A is exactly zero\n*                >  M:  the (i-M)-th column of A is exactly zero\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.zgeequ( 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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  m = lda;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_r = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  r = NA_PTR_TYPE(rblapack_r, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  c = NA_PTR_TYPE(rblapack_c, doublereal*);

  zgeequ_(&m, &n, a, &lda, r, c, &rowcnd, &colcnd, &amax, &info);

  rblapack_rowcnd = rb_float_new((double)rowcnd);
  rblapack_colcnd = rb_float_new((double)colcnd);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
}

void
init_lapack_zgeequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgeequ", rblapack_zgeequ, -1);
}
ruby-lapack-1.7.2/ext/dtbcon.c0000644000175000017500000001151712502221015015777 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtbcon_(char* norm, char* uplo, char* diag, integer* n, integer* kd, doublereal* ab, integer* ldab, doublereal* rcond, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dtbcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_info;
  integer info; 
  doublereal *work;
  integer *iwork;

  integer ldab;
  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  rcond, info = NumRu::Lapack.dtbcon( norm, uplo, diag, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTBCON estimates the reciprocal of the condition number of a\n*  triangular band matrix A, in either the 1-norm or the infinity-norm.\n*\n*  The norm of A is computed and an estimate is obtained for\n*  norm(inv(A)), then the reciprocal of the condition number is\n*  computed as\n*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies whether the 1-norm condition number or the\n*          infinity-norm condition number is required:\n*          = '1' or 'O':  1-norm;\n*          = 'I':         Infinity-norm.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals or subdiagonals of the\n*          triangular band matrix A.  KD >= 0.\n*\n*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)\n*          The upper or lower triangular band matrix A, stored in the\n*          first kd+1 rows of the array. The j-th column of A is stored\n*          in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*          If DIAG = 'U', the diagonal elements of A are not referenced\n*          and are assumed to be 1.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(norm(A) * norm(inv(A))).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.dtbcon( norm, uplo, diag, kd, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_diag = argv[2];
  rblapack_kd = argv[3];
  rblapack_ab = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  kd = NUM2INT(rblapack_kd);
  work = ALLOC_N(doublereal, (3*n));
  iwork = ALLOC_N(integer, (n));

  dtbcon_(&norm, &uplo, &diag, &n, &kd, ab, &ldab, &rcond, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_dtbcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtbcon", rblapack_dtbcon, -1);
}
ruby-lapack-1.7.2/ext/spftrs.c0000644000175000017500000001676512502221024016061 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID spftrs_(char* transr, char* uplo, integer* n, integer* nrhs, real* a, real* b, integer* ldb, integer* info);


static VALUE
rblapack_spftrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  real *b_out__;

  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.spftrs( transr, uplo, n, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPFTRS solves a system of linear equations A*X = B with a symmetric\n*  positive definite matrix A using the Cholesky factorization\n*  A = U**T*U or A = L*L**T computed by SPFTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR    (input) CHARACTER*1\n*          = 'N':  The Normal TRANSR of RFP A is stored;\n*          = 'T':  The Transpose TRANSR of RFP A is stored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of RFP A is stored;\n*          = 'L':  Lower triangle of RFP A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input) REAL array, dimension ( N*(N+1)/2 )\n*          The triangular factor U or L from the Cholesky factorization\n*          of RFP A = U**H*U or RFP A = L*L**T, as computed by SPFTRF.\n*          See note below for more details about RFP A.\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  We first consider Rectangular Full Packed (RFP) Format when N is\n*  even. We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  the transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  the transpose of the last three columns of AP lower.\n*  This covers the case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        03 04 05                33 43 53\n*        13 14 15                00 44 54\n*        23 24 25                10 11 55\n*        33 34 35                20 21 22\n*        00 44 45                30 31 32\n*        01 11 55                40 41 42\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We then consider Rectangular Full Packed (RFP) Format when N is\n*  odd. We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  the transpose of the first two columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  the transpose of the last two columns of AP lower.\n*  This covers the case N odd and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        02 03 04                00 33 43\n*        12 13 14                10 11 44\n*        22 23 24                20 21 22\n*        00 33 34                30 31 32\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*           RFP A                   RFP A\n*\n*     02 12 22 00 01             00 10 20 30 40 50\n*     03 13 23 33 11             33 11 21 31 41 51\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.spftrs( transr, uplo, n, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_n = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 1)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  spftrs_(&transr, &uplo, &n, &nrhs, a, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_spftrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "spftrs", rblapack_spftrs, -1);
}
ruby-lapack-1.7.2/ext/clansb.c0000644000175000017500000001115112502221022015760 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real clansb_(char* norm, char* uplo, integer* n, integer* k, complex* ab, integer* ldab, real* work);


static VALUE
rblapack_clansb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack___out__;
  real __out__; 
  real *work;

  integer ldab;
  integer n;
  integer lwork;

  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  __out__ = NumRu::Lapack.clansb( norm, uplo, k, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL             FUNCTION CLANSB( NORM, UPLO, N, K, AB, LDAB, WORK )\n\n*  Purpose\n*  =======\n*\n*  CLANSB  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the element of  largest absolute value  of an\n*  n by n symmetric band matrix A,  with k super-diagonals.\n*\n*  Description\n*  ===========\n*\n*  CLANSB returns the value\n*\n*     CLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in CLANSB as described\n*          above.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          band matrix A is supplied.\n*          = 'U':  Upper triangular part is supplied\n*          = 'L':  Lower triangular part is supplied\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, CLANSB is\n*          set to zero.\n*\n*  K       (input) INTEGER\n*          The number of super-diagonals or sub-diagonals of the\n*          band matrix A.  K >= 0.\n*\n*  AB      (input) COMPLEX array, dimension (LDAB,N)\n*          The upper or lower triangle of the symmetric band matrix A,\n*          stored in the first K+1 rows of AB.  The j-th column of A is\n*          stored in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)   = A(i,j) for j<=i<=min(n,j+k).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= K+1.\n*\n*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n*          WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.clansb( norm, uplo, k, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_k = argv[2];
  rblapack_ab = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  k = NUM2INT(rblapack_k);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
  work = ALLOC_N(real, (MAX(1,lwork)));

  __out__ = clansb_(&norm, &uplo, &n, &k, ab, &ldab, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_clansb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clansb", rblapack_clansb, -1);
}
ruby-lapack-1.7.2/ext/dlartg.c0000644000175000017500000000571112502221021015777 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlartg_(doublereal* f, doublereal* g, doublereal* cs, doublereal* sn, doublereal* r);


static VALUE
rblapack_dlartg(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_f;
  doublereal f; 
  VALUE rblapack_g;
  doublereal g; 
  VALUE rblapack_cs;
  doublereal cs; 
  VALUE rblapack_sn;
  doublereal sn; 
  VALUE rblapack_r;
  doublereal r; 


  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  cs, sn, r = NumRu::Lapack.dlartg( f, g, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLARTG( F, G, CS, SN, R )\n\n*  Purpose\n*  =======\n*\n*  DLARTG generate a plane rotation so that\n*\n*     [  CS  SN  ]  .  [ F ]  =  [ R ]   where CS**2 + SN**2 = 1.\n*     [ -SN  CS  ]     [ G ]     [ 0 ]\n*\n*  This is a slower, more accurate version of the BLAS1 routine DROTG,\n*  with the following other differences:\n*     F and G are unchanged on return.\n*     If G=0, then CS=1 and SN=0.\n*     If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any\n*        floating point operations (saves work in DBDSQR when\n*        there are zeros on the diagonal).\n*\n*  If F exceeds G in magnitude, CS will be positive.\n*\n\n*  Arguments\n*  =========\n*\n*  F       (input) DOUBLE PRECISION\n*          The first component of vector to be rotated.\n*\n*  G       (input) DOUBLE PRECISION\n*          The second component of vector to be rotated.\n*\n*  CS      (output) DOUBLE PRECISION\n*          The cosine of the rotation.\n*\n*  SN      (output) DOUBLE PRECISION\n*          The sine of the rotation.\n*\n*  R       (output) DOUBLE PRECISION\n*          The nonzero component of the rotated vector.\n*\n*  This version has a few statements commented out for thread safety\n*  (machine parameters are computed on each entry). 10 feb 03, SJH.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  cs, sn, r = NumRu::Lapack.dlartg( f, g, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_f = argv[0];
  rblapack_g = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  f = NUM2DBL(rblapack_f);
  g = NUM2DBL(rblapack_g);

  dlartg_(&f, &g, &cs, &sn, &r);

  rblapack_cs = rb_float_new((double)cs);
  rblapack_sn = rb_float_new((double)sn);
  rblapack_r = rb_float_new((double)r);
  return rb_ary_new3(3, rblapack_cs, rblapack_sn, rblapack_r);
}

void
init_lapack_dlartg(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlartg", rblapack_dlartg, -1);
}
ruby-lapack-1.7.2/ext/stbrfs.c0000644000175000017500000001675412502221024016041 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID stbrfs_(char* uplo, char* trans, char* diag, integer* n, integer* kd, integer* nrhs, real* ab, integer* ldab, real* b, integer* ldb, real* x, integer* ldx, real* ferr, real* berr, real* work, integer* iwork, integer* info);


static VALUE
rblapack_stbrfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  real *work;
  integer *iwork;

  integer ldab;
  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info = NumRu::Lapack.stbrfs( uplo, trans, diag, kd, ab, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  STBRFS provides error bounds and backward error estimates for the\n*  solution to a system of linear equations with a triangular band\n*  coefficient matrix.\n*\n*  The solution matrix X must be computed by STBTRS or some other\n*  means before entering this routine.  STBRFS does not do iterative\n*  refinement because doing so cannot improve the backward error.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B  (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals or subdiagonals of the\n*          triangular band matrix A.  KD >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AB      (input) REAL array, dimension (LDAB,N)\n*          The upper or lower triangular band matrix A, stored in the\n*          first kd+1 rows of the array. The j-th column of A is stored\n*          in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*          If DIAG = 'U', the diagonal elements of A are not referenced\n*          and are assumed to be 1.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  B       (input) REAL array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input) REAL array, dimension (LDX,NRHS)\n*          The solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) REAL array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info = NumRu::Lapack.stbrfs( uplo, trans, diag, kd, ab, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_kd = argv[3];
  rblapack_ab = argv[4];
  rblapack_b = argv[5];
  rblapack_x = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (7th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  kd = NUM2INT(rblapack_kd);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  work = ALLOC_N(real, (3*n));
  iwork = ALLOC_N(integer, (n));

  stbrfs_(&uplo, &trans, &diag, &n, &kd, &nrhs, ab, &ldab, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ferr, rblapack_berr, rblapack_info);
}

void
init_lapack_stbrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "stbrfs", rblapack_stbrfs, -1);
}
ruby-lapack-1.7.2/ext/slarre.c0000644000175000017500000003401012502221015016007 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slarre_(char* range, integer* n, real* vl, real* vu, integer* il, integer* iu, real* d, real* e, real* e2, real* rtol1, real* rtol2, real* spltol, integer* nsplit, integer* isplit, integer* m, real* w, real* werr, real* wgap, integer* iblock, integer* indexw, real* gers, real* pivmin, real* work, integer* iwork, integer* info);


static VALUE
rblapack_slarre(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_vl;
  real vl; 
  VALUE rblapack_vu;
  real vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_e2;
  real *e2; 
  VALUE rblapack_rtol1;
  real rtol1; 
  VALUE rblapack_rtol2;
  real rtol2; 
  VALUE rblapack_spltol;
  real spltol; 
  VALUE rblapack_nsplit;
  integer nsplit; 
  VALUE rblapack_isplit;
  integer *isplit; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_werr;
  real *werr; 
  VALUE rblapack_wgap;
  real *wgap; 
  VALUE rblapack_iblock;
  integer *iblock; 
  VALUE rblapack_indexw;
  integer *indexw; 
  VALUE rblapack_gers;
  real *gers; 
  VALUE rblapack_pivmin;
  real pivmin; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_e_out__;
  real *e_out__;
  VALUE rblapack_e2_out__;
  real *e2_out__;
  real *work;
  integer *iwork;

  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  nsplit, isplit, m, w, werr, wgap, iblock, indexw, gers, pivmin, info, vl, vu, d, e, e2 = NumRu::Lapack.slarre( range, vl, vu, il, iu, d, e, e2, rtol1, rtol2, spltol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLARRE( RANGE, N, VL, VU, IL, IU, D, E, E2, RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT, M, W, WERR, WGAP, IBLOCK, INDEXW, GERS, PIVMIN, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  To find the desired eigenvalues of a given real symmetric\n*  tridiagonal matrix T, SLARRE sets any \"small\" off-diagonal\n*  elements to zero, and for each unreduced block T_i, it finds\n*  (a) a suitable shift at one end of the block's spectrum,\n*  (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and\n*  (c) eigenvalues of each L_i D_i L_i^T.\n*  The representations and eigenvalues found are then used by\n*  SSTEMR to compute the eigenvectors of T.\n*  The accuracy varies depending on whether bisection is used to\n*  find a few eigenvalues or the dqds algorithm (subroutine SLASQ2) to\n*  conpute all and then discard any unwanted one.\n*  As an added benefit, SLARRE also outputs the n\n*  Gerschgorin intervals for the matrices L_i D_i L_i^T.\n*\n\n*  Arguments\n*  =========\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': (\"All\")   all eigenvalues will be found.\n*          = 'V': (\"Value\") all eigenvalues in the half-open interval\n*                           (VL, VU] will be found.\n*          = 'I': (\"Index\") the IL-th through IU-th eigenvalues (of the\n*                           entire matrix) will be found.\n*\n*  N       (input) INTEGER\n*          The order of the matrix. N > 0.\n*\n*  VL      (input/output) REAL            \n*  VU      (input/output) REAL            \n*          If RANGE='V', the lower and upper bounds for the eigenvalues.\n*          Eigenvalues less than or equal to VL, or greater than VU,\n*          will not be returned.  VL < VU.\n*          If RANGE='I' or ='A', SLARRE computes bounds on the desired\n*          part of the spectrum.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N.\n*\n*  D       (input/output) REAL             array, dimension (N)\n*          On entry, the N diagonal elements of the tridiagonal\n*          matrix T.\n*          On exit, the N diagonal elements of the diagonal\n*          matrices D_i.\n*\n*  E       (input/output) REAL             array, dimension (N)\n*          On entry, the first (N-1) entries contain the subdiagonal\n*          elements of the tridiagonal matrix T; E(N) need not be set.\n*          On exit, E contains the subdiagonal elements of the unit\n*          bidiagonal matrices L_i. The entries E( ISPLIT( I ) ),\n*          1 <= I <= NSPLIT, contain the base points sigma_i on output.\n*\n*  E2      (input/output) REAL             array, dimension (N)\n*          On entry, the first (N-1) entries contain the SQUARES of the\n*          subdiagonal elements of the tridiagonal matrix T;\n*          E2(N) need not be set.\n*          On exit, the entries E2( ISPLIT( I ) ),\n*          1 <= I <= NSPLIT, have been set to zero\n*\n*  RTOL1   (input) REAL            \n*  RTOL2   (input) REAL            \n*           Parameters for bisection.\n*           An interval [LEFT,RIGHT] has converged if\n*           RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n*\n*  SPLTOL (input) REAL            \n*          The threshold for splitting.\n*\n*  NSPLIT  (output) INTEGER\n*          The number of blocks T splits into. 1 <= NSPLIT <= N.\n*\n*  ISPLIT  (output) INTEGER array, dimension (N)\n*          The splitting points, at which T breaks up into blocks.\n*          The first block consists of rows/columns 1 to ISPLIT(1),\n*          the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n*          etc., and the NSPLIT-th consists of rows/columns\n*          ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues (of all L_i D_i L_i^T)\n*          found.\n*\n*  W       (output) REAL             array, dimension (N)\n*          The first M elements contain the eigenvalues. The\n*          eigenvalues of each of the blocks, L_i D_i L_i^T, are\n*          sorted in ascending order ( SLARRE may use the\n*          remaining N-M elements as workspace).\n*\n*  WERR    (output) REAL             array, dimension (N)\n*          The error bound on the corresponding eigenvalue in W.\n*\n*  WGAP    (output) REAL             array, dimension (N)\n*          The separation from the right neighbor eigenvalue in W.\n*          The gap is only with respect to the eigenvalues of the same block\n*          as each block has its own representation tree.\n*          Exception: at the right end of a block we store the left gap\n*\n*  IBLOCK  (output) INTEGER array, dimension (N)\n*          The indices of the blocks (submatrices) associated with the\n*          corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue\n*          W(i) belongs to the first block from the top, =2 if W(i)\n*          belongs to the second block, etc.\n*\n*  INDEXW  (output) INTEGER array, dimension (N)\n*          The indices of the eigenvalues within each block (submatrix);\n*          for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the\n*          i-th eigenvalue W(i) is the 10-th eigenvalue in block 2\n*\n*  GERS    (output) REAL             array, dimension (2*N)\n*          The N Gerschgorin intervals (the i-th Gerschgorin interval\n*          is (GERS(2*i-1), GERS(2*i)).\n*\n*  PIVMIN  (output) REAL\n*          The minimum pivot in the Sturm sequence for T.\n*\n*  WORK    (workspace) REAL             array, dimension (6*N)\n*          Workspace.\n*\n*  IWORK   (workspace) INTEGER array, dimension (5*N)\n*          Workspace.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          > 0:  A problem occured in SLARRE.\n*          < 0:  One of the called subroutines signaled an internal problem.\n*                Needs inspection of the corresponding parameter IINFO\n*                for further information.\n*\n*          =-1:  Problem in SLARRD.\n*          = 2:  No base representation could be found in MAXTRY iterations.\n*                Increasing MAXTRY and recompilation might be a remedy.\n*          =-3:  Problem in SLARRB when computing the refined root\n*                representation for SLASQ2.\n*          =-4:  Problem in SLARRB when preforming bisection on the\n*                desired part of the spectrum.\n*          =-5:  Problem in SLASQ2.\n*          =-6:  Problem in SLASQ2.\n*\n\n*  Further Details\n*  The base representations are required to suffer very little\n*  element growth and consequently define all their eigenvalues to\n*  high relative accuracy.\n*  ===============\n*\n*  Based on contributions by\n*     Beresford Parlett, University of California, Berkeley, USA\n*     Jim Demmel, University of California, Berkeley, USA\n*     Inderjit Dhillon, University of Texas, Austin, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  nsplit, isplit, m, w, werr, wgap, iblock, indexw, gers, pivmin, info, vl, vu, d, e, e2 = NumRu::Lapack.slarre( range, vl, vu, il, iu, d, e, e2, rtol1, rtol2, spltol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 11 && argc != 11)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
  rblapack_range = argv[0];
  rblapack_vl = argv[1];
  rblapack_vu = argv[2];
  rblapack_il = argv[3];
  rblapack_iu = argv[4];
  rblapack_d = argv[5];
  rblapack_e = argv[6];
  rblapack_e2 = argv[7];
  rblapack_rtol1 = argv[8];
  rblapack_rtol2 = argv[9];
  rblapack_spltol = argv[10];
  if (argc == 11) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  range = StringValueCStr(rblapack_range)[0];
  vu = (real)NUM2DBL(rblapack_vu);
  iu = NUM2INT(rblapack_iu);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (7th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (7th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_e);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  rtol1 = (real)NUM2DBL(rblapack_rtol1);
  spltol = (real)NUM2DBL(rblapack_spltol);
  vl = (real)NUM2DBL(rblapack_vl);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (6th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of e");
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  rtol2 = (real)NUM2DBL(rblapack_rtol2);
  il = NUM2INT(rblapack_il);
  if (!NA_IsNArray(rblapack_e2))
    rb_raise(rb_eArgError, "e2 (8th argument) must be NArray");
  if (NA_RANK(rblapack_e2) != 1)
    rb_raise(rb_eArgError, "rank of e2 (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e2) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of e2 must be the same as shape 0 of e");
  if (NA_TYPE(rblapack_e2) != NA_SFLOAT)
    rblapack_e2 = na_change_type(rblapack_e2, NA_SFLOAT);
  e2 = NA_PTR_TYPE(rblapack_e2, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_isplit = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_werr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  werr = NA_PTR_TYPE(rblapack_werr, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wgap = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  wgap = NA_PTR_TYPE(rblapack_wgap, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_iblock = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iblock = NA_PTR_TYPE(rblapack_iblock, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_indexw = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  indexw = NA_PTR_TYPE(rblapack_indexw, integer*);
  {
    na_shape_t shape[1];
    shape[0] = 2*n;
    rblapack_gers = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  gers = NA_PTR_TYPE(rblapack_gers, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
  MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_e2_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e2_out__ = NA_PTR_TYPE(rblapack_e2_out__, real*);
  MEMCPY(e2_out__, e2, real, NA_TOTAL(rblapack_e2));
  rblapack_e2 = rblapack_e2_out__;
  e2 = e2_out__;
  work = ALLOC_N(real, (6*n));
  iwork = ALLOC_N(integer, (5*n));

  slarre_(&range, &n, &vl, &vu, &il, &iu, d, e, e2, &rtol1, &rtol2, &spltol, &nsplit, isplit, &m, w, werr, wgap, iblock, indexw, gers, &pivmin, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_nsplit = INT2NUM(nsplit);
  rblapack_m = INT2NUM(m);
  rblapack_pivmin = rb_float_new((double)pivmin);
  rblapack_info = INT2NUM(info);
  rblapack_vl = rb_float_new((double)vl);
  rblapack_vu = rb_float_new((double)vu);
  return rb_ary_new3(16, rblapack_nsplit, rblapack_isplit, rblapack_m, rblapack_w, rblapack_werr, rblapack_wgap, rblapack_iblock, rblapack_indexw, rblapack_gers, rblapack_pivmin, rblapack_info, rblapack_vl, rblapack_vu, rblapack_d, rblapack_e, rblapack_e2);
}

void
init_lapack_slarre(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slarre", rblapack_slarre, -1);
}
ruby-lapack-1.7.2/ext/clasr.c0000644000175000017500000002054212502221022015626 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clasr_(char* side, char* pivot, char* direct, integer* m, integer* n, real* c, real* s, complex* a, integer* lda);


static VALUE
rblapack_clasr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_pivot;
  char pivot; 
  VALUE rblapack_direct;
  char direct; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_a_out__;
  complex *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  a = NumRu::Lapack.clasr( side, pivot, direct, m, c, s, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )\n\n*  Purpose\n*  =======\n*\n*  CLASR applies a sequence of real plane rotations to a complex matrix\n*  A, from either the left or the right.\n*\n*  When SIDE = 'L', the transformation takes the form\n*\n*     A := P*A\n*\n*  and when SIDE = 'R', the transformation takes the form\n*\n*     A := A*P**T\n*\n*  where P is an orthogonal matrix consisting of a sequence of z plane\n*  rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',\n*  and P**T is the transpose of P.\n*  \n*  When DIRECT = 'F' (Forward sequence), then\n*  \n*     P = P(z-1) * ... * P(2) * P(1)\n*  \n*  and when DIRECT = 'B' (Backward sequence), then\n*  \n*     P = P(1) * P(2) * ... * P(z-1)\n*  \n*  where P(k) is a plane rotation matrix defined by the 2-by-2 rotation\n*  \n*     R(k) = (  c(k)  s(k) )\n*          = ( -s(k)  c(k) ).\n*  \n*  When PIVOT = 'V' (Variable pivot), the rotation is performed\n*  for the plane (k,k+1), i.e., P(k) has the form\n*  \n*     P(k) = (  1                                            )\n*            (       ...                                     )\n*            (              1                                )\n*            (                   c(k)  s(k)                  )\n*            (                  -s(k)  c(k)                  )\n*            (                                1              )\n*            (                                     ...       )\n*            (                                            1  )\n*  \n*  where R(k) appears as a rank-2 modification to the identity matrix in\n*  rows and columns k and k+1.\n*  \n*  When PIVOT = 'T' (Top pivot), the rotation is performed for the\n*  plane (1,k+1), so P(k) has the form\n*  \n*     P(k) = (  c(k)                    s(k)                 )\n*            (         1                                     )\n*            (              ...                              )\n*            (                     1                         )\n*            ( -s(k)                    c(k)                 )\n*            (                                 1             )\n*            (                                      ...      )\n*            (                                             1 )\n*  \n*  where R(k) appears in rows and columns 1 and k+1.\n*  \n*  Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is\n*  performed for the plane (k,z), giving P(k) the form\n*  \n*     P(k) = ( 1                                             )\n*            (      ...                                      )\n*            (             1                                 )\n*            (                  c(k)                    s(k) )\n*            (                         1                     )\n*            (                              ...              )\n*            (                                     1         )\n*            (                 -s(k)                    c(k) )\n*  \n*  where R(k) appears in rows and columns k and z.  The rotations are\n*  performed without ever forming P(k) explicitly.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          Specifies whether the plane rotation matrix P is applied to\n*          A on the left or the right.\n*          = 'L':  Left, compute A := P*A\n*          = 'R':  Right, compute A:= A*P**T\n*\n*  PIVOT   (input) CHARACTER*1\n*          Specifies the plane for which P(k) is a plane rotation\n*          matrix.\n*          = 'V':  Variable pivot, the plane (k,k+1)\n*          = 'T':  Top pivot, the plane (1,k+1)\n*          = 'B':  Bottom pivot, the plane (k,z)\n*\n*  DIRECT  (input) CHARACTER*1\n*          Specifies whether P is a forward or backward sequence of\n*          plane rotations.\n*          = 'F':  Forward, P = P(z-1)*...*P(2)*P(1)\n*          = 'B':  Backward, P = P(1)*P(2)*...*P(z-1)\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.  If m <= 1, an immediate\n*          return is effected.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.  If n <= 1, an\n*          immediate return is effected.\n*\n*  C       (input) REAL array, dimension\n*                  (M-1) if SIDE = 'L'\n*                  (N-1) if SIDE = 'R'\n*          The cosines c(k) of the plane rotations.\n*\n*  S       (input) REAL array, dimension\n*                  (M-1) if SIDE = 'L'\n*                  (N-1) if SIDE = 'R'\n*          The sines s(k) of the plane rotations.  The 2-by-2 plane\n*          rotation part of the matrix P(k), R(k), has the form\n*          R(k) = (  c(k)  s(k) )\n*                 ( -s(k)  c(k) ).\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          The M-by-N matrix A.  On exit, A is overwritten by P*A if\n*          SIDE = 'R' or by A*P**T if SIDE = 'L'.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  a = NumRu::Lapack.clasr( side, pivot, direct, m, c, s, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_side = argv[0];
  rblapack_pivot = argv[1];
  rblapack_direct = argv[2];
  rblapack_m = argv[3];
  rblapack_c = argv[4];
  rblapack_s = argv[5];
  rblapack_a = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  direct = StringValueCStr(rblapack_direct)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (7th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (7th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  pivot = StringValueCStr(rblapack_pivot)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (6th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != (m-1))
    rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", m-1);
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != (m-1))
    rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", m-1);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  clasr_(&side, &pivot, &direct, &m, &n, c, s, a, &lda);

  return rblapack_a;
}

void
init_lapack_clasr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clasr", rblapack_clasr, -1);
}
ruby-lapack-1.7.2/ext/zgbequ.c0000644000175000017500000001343012502221023016016 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgbequ_(integer* m, integer* n, integer* kl, integer* ku, doublecomplex* ab, integer* ldab, doublereal* r, doublereal* c, doublereal* rowcnd, doublereal* colcnd, doublereal* amax, integer* info);


static VALUE
rblapack_zgbequ(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_r;
  doublereal *r; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_rowcnd;
  doublereal rowcnd; 
  VALUE rblapack_colcnd;
  doublereal colcnd; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_info;
  integer info; 

  integer ldab;
  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  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.zgbequ( m, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGBEQU computes row and column scalings intended to equilibrate an\n*  M-by-N band matrix A and reduce its condition number.  R returns the\n*  row scale factors and C the column scale factors, chosen to try to\n*  make the largest element in each row and column of the matrix B with\n*  elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n*\n*  R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n*  number and BIGNUM = largest safe number.  Use of these scaling\n*  factors is not guaranteed to reduce the condition number of A but\n*  works well in practice.\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*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)\n*          The band matrix A, stored in rows 1 to KL+KU+1.  The j-th\n*          column of A is stored in the j-th column of the array AB as\n*          follows:\n*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*  R       (output) DOUBLE PRECISION array, dimension (M)\n*          If INFO = 0, or INFO > M, R contains the row scale factors\n*          for A.\n*\n*  C       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, C contains the column scale factors for A.\n*\n*  ROWCND  (output) DOUBLE PRECISION\n*          If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n*          smallest R(i) to the largest R(i).  If ROWCND >= 0.1 and\n*          AMAX is neither too large nor too small, it is not worth\n*          scaling by R.\n*\n*  COLCND  (output) DOUBLE PRECISION\n*          If INFO = 0, COLCND contains the ratio of the smallest\n*          C(i) to the largest C(i).  If COLCND >= 0.1, it is not\n*          worth scaling by C.\n*\n*  AMAX    (output) DOUBLE PRECISION\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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, and i is\n*                <= M:  the i-th row of A is exactly zero\n*                >  M:  the (i-M)-th column of A is exactly zero\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.zgbequ( m, kl, ku, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_m = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  ku = NUM2INT(rblapack_ku);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,m);
    rblapack_r = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  r = NA_PTR_TYPE(rblapack_r, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  c = NA_PTR_TYPE(rblapack_c, doublereal*);

  zgbequ_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &info);

  rblapack_rowcnd = rb_float_new((double)rowcnd);
  rblapack_colcnd = rb_float_new((double)colcnd);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
}

void
init_lapack_zgbequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgbequ", rblapack_zgbequ, -1);
}
ruby-lapack-1.7.2/ext/dstegr.c0000644000175000017500000003064012502221020016010 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dstegr_(char* jobz, char* range, integer* n, doublereal* d, doublereal* e, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublereal* z, integer* ldz, integer* isuppz, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_dstegr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_vl;
  doublereal vl; 
  VALUE rblapack_vu;
  doublereal vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  doublereal abstol; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_isuppz;
  integer *isuppz; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_e_out__;
  doublereal *e_out__;

  integer n;
  integer ldz;

  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  m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.dstegr( jobz, range, d, e, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSTEGR computes selected eigenvalues and, optionally, eigenvectors\n*  of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n*  a well defined set of pairwise different real eigenvalues, the corresponding\n*  real eigenvectors are pairwise orthogonal.\n*\n*  The spectrum may be computed either completely or partially by specifying\n*  either an interval (VL,VU] or a range of indices IL:IU for the desired\n*  eigenvalues.\n*\n*  DSTEGR is a compatability wrapper around the improved DSTEMR routine.\n*  See DSTEMR for further details.\n*\n*  One important change is that the ABSTOL parameter no longer provides any\n*  benefit and hence is no longer used.\n*\n*  Note : DSTEGR and DSTEMR work only on machines which follow\n*  IEEE-754 floating-point standard in their handling of infinities and\n*  NaNs.  Normal execution may create these exceptiona values and hence\n*  may abort due to a floating point exception in environments which\n*  do not conform to the IEEE-754 standard.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found.\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found.\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the N diagonal elements of the tridiagonal matrix\n*          T. On exit, D is overwritten.\n*\n*  E       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the (N-1) subdiagonal elements of the tridiagonal\n*          matrix T in elements 1 to N-1 of E. E(N) need not be set on\n*          input, but is used internally as workspace.\n*          On exit, E is overwritten.\n*\n*  VL      (input) DOUBLE PRECISION\n*  VU      (input) DOUBLE PRECISION\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) DOUBLE PRECISION\n*          Unused.  Was the absolute error tolerance for the\n*          eigenvalues/eigenvectors in previous versions.\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          The first M elements contain the selected eigenvalues in\n*          ascending order.\n*\n*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )\n*          If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix T\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*          Supplying N columns is always safe.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', then LDZ >= max(1,N).\n*\n*  ISUPPZ  (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n*          The support of the eigenvectors in Z, i.e., the indices\n*          indicating the nonzero elements in Z. The i-th computed eigenvector\n*          is nonzero only in elements ISUPPZ( 2*i-1 ) through\n*          ISUPPZ( 2*i ). This is relevant in the case when the matrix\n*          is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n*\n*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)\n*          On exit, if INFO = 0, WORK(1) returns the optimal\n*          (and minimal) LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK. LWORK >= max(1,18*N)\n*          if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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*  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.  LIWORK >= max(1,10*N)\n*          if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n*          if only the eigenvalues are to be computed.\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal size of the IWORK array,\n*          returns this value as the first entry of the IWORK array, and\n*          no error message related to LIWORK is issued by XERBLA.\n*\n*  INFO    (output) INTEGER\n*          On exit, INFO\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  if INFO = 1X, internal error in DLARRE,\n*                if INFO = 2X, internal error in DLARRV.\n*                Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n*                the nonzero error code returned by DLARRE or\n*                DLARRV, respectively.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Inderjit Dhillon, IBM Almaden, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, LBNL/NERSC, USA\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL TRYRAC\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL DSTEMR\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.dstegr( jobz, range, d, e, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 11)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_d = argv[2];
  rblapack_e = argv[3];
  rblapack_vl = argv[4];
  rblapack_vu = argv[5];
  rblapack_il = argv[6];
  rblapack_iu = argv[7];
  rblapack_abstol = argv[8];
  if (argc == 11) {
    rblapack_lwork = argv[9];
    rblapack_liwork = argv[10];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  vl = NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  abstol = NUM2DBL(rblapack_abstol);
  range = StringValueCStr(rblapack_range)[0];
  vu = NUM2DBL(rblapack_vu);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (4th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&jobz,"V") ? 18*n : lsame_(&jobz,"N") ? 12*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  iu = NUM2INT(rblapack_iu);
  m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
  if (rblapack_liwork == Qnil)
    liwork = lsame_(&jobz,"V") ? 10*n : lsame_(&jobz,"N") ? 8*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 2*MAX(1,m);
    rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
  MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;

  dstegr_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, isuppz, work, &lwork, iwork, &liwork, &info);

  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_m, rblapack_w, rblapack_z, rblapack_isuppz, rblapack_work, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e);
}

void
init_lapack_dstegr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dstegr", rblapack_dstegr, -1);
}
ruby-lapack-1.7.2/ext/zlanhs.c0000644000175000017500000000733512502221014016027 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal zlanhs_(char* norm, integer* n, doublecomplex* a, integer* lda, doublereal* work);


static VALUE
rblapack_zlanhs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack___out__;
  doublereal __out__; 
  doublereal *work;

  integer lda;
  integer n;
  integer lwork;

  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  __out__ = NumRu::Lapack.zlanhs( norm, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK )\n\n*  Purpose\n*  =======\n*\n*  ZLANHS  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  Hessenberg matrix A.\n*\n*  Description\n*  ===========\n*\n*  ZLANHS returns the value\n*\n*     ZLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in ZLANHS as described\n*          above.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, ZLANHS is\n*          set to zero.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          The n by n upper Hessenberg matrix A; the part of A below the\n*          first sub-diagonal is not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(N,1).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n*          referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.zlanhs( norm, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_norm = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  lwork = lsame_(&norm,"I") ? n : 0;
  work = ALLOC_N(doublereal, (MAX(1,lwork)));

  __out__ = zlanhs_(&norm, &n, a, &lda, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_zlanhs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlanhs", rblapack_zlanhs, -1);
}
ruby-lapack-1.7.2/ext/dlatdf.c0000644000175000017500000002012012502221025015753 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlatdf_(integer* ijob, integer* n, doublereal* z, integer* ldz, doublereal* rhs, doublereal* rdsum, doublereal* rdscal, integer* ipiv, integer* jpiv);


static VALUE
rblapack_dlatdf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ijob;
  integer ijob; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_rhs;
  doublereal *rhs; 
  VALUE rblapack_rdsum;
  doublereal rdsum; 
  VALUE rblapack_rdscal;
  doublereal rdscal; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_jpiv;
  integer *jpiv; 
  VALUE rblapack_rhs_out__;
  doublereal *rhs_out__;

  integer ldz;
  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  rhs, rdsum, rdscal = NumRu::Lapack.dlatdf( ijob, z, rhs, rdsum, rdscal, ipiv, jpiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, JPIV )\n\n*  Purpose\n*  =======\n*\n*  DLATDF uses the LU factorization of the n-by-n matrix Z computed by\n*  DGETC2 and computes a contribution to the reciprocal Dif-estimate\n*  by solving Z * x = b for x, and choosing the r.h.s. b such that\n*  the norm of x is as large as possible. On entry RHS = b holds the\n*  contribution from earlier solved sub-systems, and on return RHS = x.\n*\n*  The factorization of Z returned by DGETC2 has the form Z = P*L*U*Q,\n*  where P and Q are permutation matrices. L is lower triangular with\n*  unit diagonal elements and U is upper triangular.\n*\n\n*  Arguments\n*  =========\n*\n*  IJOB    (input) INTEGER\n*          IJOB = 2: First compute an approximative null-vector e\n*              of Z using DGECON, e is normalized and solve for\n*              Zx = +-e - f with the sign giving the greater value\n*              of 2-norm(x). About 5 times as expensive as Default.\n*          IJOB .ne. 2: Local look ahead strategy where all entries of\n*              the r.h.s. b is choosen as either +1 or -1 (Default).\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Z.\n*\n*  Z       (input) DOUBLE PRECISION array, dimension (LDZ, N)\n*          On entry, the LU part of the factorization of the n-by-n\n*          matrix Z computed by DGETC2:  Z = P * L * U * Q\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDA >= max(1, N).\n*\n*  RHS     (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, RHS contains contributions from other subsystems.\n*          On exit, RHS contains the solution of the subsystem with\n*          entries acoording to the value of IJOB (see above).\n*\n*  RDSUM   (input/output) DOUBLE PRECISION\n*          On entry, the sum of squares of computed contributions to\n*          the Dif-estimate under computation by DTGSYL, where the\n*          scaling factor RDSCAL (see below) has been factored out.\n*          On exit, the corresponding sum of squares updated with the\n*          contributions from the current sub-system.\n*          If TRANS = 'T' RDSUM is not touched.\n*          NOTE: RDSUM only makes sense when DTGSY2 is called by STGSYL.\n*\n*  RDSCAL  (input/output) DOUBLE PRECISION\n*          On entry, scaling factor used to prevent overflow in RDSUM.\n*          On exit, RDSCAL is updated w.r.t. the current contributions\n*          in RDSUM.\n*          If TRANS = 'T', RDSCAL is not touched.\n*          NOTE: RDSCAL only makes sense when DTGSY2 is called by\n*                DTGSYL.\n*\n*  IPIV    (input) INTEGER array, dimension (N).\n*          The pivot indices; for 1 <= i <= N, row i of the\n*          matrix has been interchanged with row IPIV(i).\n*\n*  JPIV    (input) INTEGER array, dimension (N).\n*          The pivot indices; for 1 <= j <= N, column j of the\n*          matrix has been interchanged with column JPIV(j).\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  This routine is a further developed implementation of algorithm\n*  BSOLVE in [1] using complete pivoting in the LU factorization.\n*\n*  [1] Bo Kagstrom and Lars Westin,\n*      Generalized Schur Methods with Condition Estimators for\n*      Solving the Generalized Sylvester Equation, IEEE Transactions\n*      on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.\n*\n*  [2] Peter Poromaa,\n*      On Efficient and Robust Estimators for the Separation\n*      between two Regular Matrix Pairs with Applications in\n*      Condition Estimation. Report IMINF-95.05, Departement of\n*      Computing Science, Umea University, S-901 87 Umea, Sweden, 1995.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rhs, rdsum, rdscal = NumRu::Lapack.dlatdf( ijob, z, rhs, rdsum, rdscal, ipiv, jpiv, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_ijob = argv[0];
  rblapack_z = argv[1];
  rblapack_rhs = argv[2];
  rblapack_rdsum = argv[3];
  rblapack_rdscal = argv[4];
  rblapack_ipiv = argv[5];
  rblapack_jpiv = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  ijob = NUM2INT(rblapack_ijob);
  if (!NA_IsNArray(rblapack_rhs))
    rb_raise(rb_eArgError, "rhs (3th argument) must be NArray");
  if (NA_RANK(rblapack_rhs) != 1)
    rb_raise(rb_eArgError, "rank of rhs (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_rhs);
  if (NA_TYPE(rblapack_rhs) != NA_DFLOAT)
    rblapack_rhs = na_change_type(rblapack_rhs, NA_DFLOAT);
  rhs = NA_PTR_TYPE(rblapack_rhs, doublereal*);
  rdscal = NUM2DBL(rblapack_rdscal);
  if (!NA_IsNArray(rblapack_jpiv))
    rb_raise(rb_eArgError, "jpiv (7th argument) must be NArray");
  if (NA_RANK(rblapack_jpiv) != 1)
    rb_raise(rb_eArgError, "rank of jpiv (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_jpiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of jpiv must be the same as shape 0 of rhs");
  if (NA_TYPE(rblapack_jpiv) != NA_LINT)
    rblapack_jpiv = na_change_type(rblapack_jpiv, NA_LINT);
  jpiv = NA_PTR_TYPE(rblapack_jpiv, integer*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (2th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (2th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  if (NA_SHAPE1(rblapack_z) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 0 of rhs");
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of rhs");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  rdsum = NUM2DBL(rblapack_rdsum);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rhs_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  rhs_out__ = NA_PTR_TYPE(rblapack_rhs_out__, doublereal*);
  MEMCPY(rhs_out__, rhs, doublereal, NA_TOTAL(rblapack_rhs));
  rblapack_rhs = rblapack_rhs_out__;
  rhs = rhs_out__;

  dlatdf_(&ijob, &n, z, &ldz, rhs, &rdsum, &rdscal, ipiv, jpiv);

  rblapack_rdsum = rb_float_new((double)rdsum);
  rblapack_rdscal = rb_float_new((double)rdscal);
  return rb_ary_new3(3, rblapack_rhs, rblapack_rdsum, rblapack_rdscal);
}

void
init_lapack_dlatdf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlatdf", rblapack_dlatdf, -1);
}
ruby-lapack-1.7.2/ext/zlarnv.c0000644000175000017500000000765112502221025016047 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlarnv_(integer* idist, integer* iseed, integer* n, doublecomplex* x);


static VALUE
rblapack_zlarnv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_idist;
  integer idist; 
  VALUE rblapack_iseed;
  integer *iseed; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_iseed_out__;
  integer *iseed_out__;


  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  x, iseed = NumRu::Lapack.zlarnv( idist, iseed, n, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLARNV( IDIST, ISEED, N, X )\n\n*  Purpose\n*  =======\n*\n*  ZLARNV returns a vector of n random complex numbers from a uniform or\n*  normal distribution.\n*\n\n*  Arguments\n*  =========\n*\n*  IDIST   (input) INTEGER\n*          Specifies the distribution of the random numbers:\n*          = 1:  real and imaginary parts each uniform (0,1)\n*          = 2:  real and imaginary parts each uniform (-1,1)\n*          = 3:  real and imaginary parts each normal (0,1)\n*          = 4:  uniformly distributed on the disc abs(z) < 1\n*          = 5:  uniformly distributed on the circle abs(z) = 1\n*\n*  ISEED   (input/output) INTEGER array, dimension (4)\n*          On entry, the seed of the random number generator; the array\n*          elements must be between 0 and 4095, and ISEED(4) must be\n*          odd.\n*          On exit, the seed is updated.\n*\n*  N       (input) INTEGER\n*          The number of random numbers to be generated.\n*\n*  X       (output) COMPLEX*16 array, dimension (N)\n*          The generated random numbers.\n*\n\n*  Further Details\n*  ===============\n*\n*  This routine calls the auxiliary routine DLARUV to generate random\n*  real numbers from a uniform (0,1) distribution, in batches of up to\n*  128 using vectorisable code. The Box-Muller method is used to\n*  transform numbers from a uniform to a normal distribution.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, iseed = NumRu::Lapack.zlarnv( idist, iseed, n, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_idist = argv[0];
  rblapack_iseed = argv[1];
  rblapack_n = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  idist = NUM2INT(rblapack_idist);
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_iseed))
    rb_raise(rb_eArgError, "iseed (2th argument) must be NArray");
  if (NA_RANK(rblapack_iseed) != 1)
    rb_raise(rb_eArgError, "rank of iseed (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_iseed) != (4))
    rb_raise(rb_eRuntimeError, "shape 0 of iseed must be %d", 4);
  if (NA_TYPE(rblapack_iseed) != NA_LINT)
    rblapack_iseed = na_change_type(rblapack_iseed, NA_LINT);
  iseed = NA_PTR_TYPE(rblapack_iseed, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,n);
    rblapack_x = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = 4;
    rblapack_iseed_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iseed_out__ = NA_PTR_TYPE(rblapack_iseed_out__, integer*);
  MEMCPY(iseed_out__, iseed, integer, NA_TOTAL(rblapack_iseed));
  rblapack_iseed = rblapack_iseed_out__;
  iseed = iseed_out__;

  zlarnv_(&idist, iseed, &n, x);

  return rb_ary_new3(2, rblapack_x, rblapack_iseed);
}

void
init_lapack_zlarnv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlarnv", rblapack_zlarnv, -1);
}
ruby-lapack-1.7.2/ext/sgbcon.c0000644000175000017500000001253212502221023015776 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgbcon_(char* norm, integer* n, integer* kl, integer* ku, real* ab, integer* ldab, integer* ipiv, real* anorm, real* rcond, real* work, integer* iwork, integer* info);


static VALUE
rblapack_sgbcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_anorm;
  real anorm; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_info;
  integer info; 
  real *work;
  integer *iwork;

  integer ldab;
  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  rcond, info = NumRu::Lapack.sgbcon( norm, kl, ku, ab, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGBCON estimates the reciprocal of the condition number of a real\n*  general band matrix A, in either the 1-norm or the infinity-norm,\n*  using the LU factorization computed by SGBTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as\n*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies whether the 1-norm condition number or the\n*          infinity-norm condition number is required:\n*          = '1' or 'O':  1-norm;\n*          = 'I':         Infinity-norm.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  AB      (input) REAL array, dimension (LDAB,N)\n*          Details of the LU factorization of the band matrix A, as\n*          computed by SGBTRF.  U is stored as an upper triangular band\n*          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n*          the multipliers used during the factorization are stored in\n*          rows KL+KU+2 to 2*KL+KU+1.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices; for 1 <= i <= N, row i of the matrix was\n*          interchanged with row IPIV(i).\n*\n*  ANORM   (input) REAL\n*          If NORM = '1' or 'O', the 1-norm of the original matrix A.\n*          If NORM = 'I', the infinity-norm of the original matrix A.\n*\n*  RCOND   (output) REAL\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(norm(A) * norm(inv(A))).\n*\n*  WORK    (workspace) REAL array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.sgbcon( norm, kl, ku, ab, ipiv, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_norm = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_anorm = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  kl = NUM2INT(rblapack_kl);
  anorm = (real)NUM2DBL(rblapack_anorm);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  work = ALLOC_N(real, (3*n));
  iwork = ALLOC_N(integer, (n));

  sgbcon_(&norm, &n, &kl, &ku, ab, &ldab, ipiv, &anorm, &rcond, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_sgbcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgbcon", rblapack_sgbcon, -1);
}
ruby-lapack-1.7.2/ext/zposv.c0000644000175000017500000001356212502221016015712 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zposv_(char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, integer* info);


static VALUE
rblapack_zposv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, a, b = NumRu::Lapack.zposv( uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPOSV computes the solution to a complex system of linear equations\n*     A * X = B,\n*  where A is an N-by-N Hermitian positive definite matrix and X and B\n*  are N-by-NRHS matrices.\n*\n*  The Cholesky decomposition is used to factor A as\n*     A = U**H* U,  if UPLO = 'U', or\n*     A = L * L**H,  if UPLO = 'L',\n*  where U is an upper triangular matrix and  L is a lower triangular\n*  matrix.  The factored form of A is then used to solve the system of\n*  equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the factor U or L from the Cholesky\n*          factorization A = U**H*U or A = L*L**H.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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 leading minor of order i of A is not\n*                positive definite, so the factorization could not be\n*                completed, and the solution has not been computed.\n*\n\n*  =====================================================================\n*\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZPOTRF, ZPOTRS\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a, b = NumRu::Lapack.zposv( uplo, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_b = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zposv_(&uplo, &n, &nrhs, a, &lda, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_zposv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zposv", rblapack_zposv, -1);
}
ruby-lapack-1.7.2/ext/stftri.c0000644000175000017500000001714212502221016016042 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID stftri_(char* transr, char* uplo, char* diag, integer* n, real* a, integer* info);


static VALUE
rblapack_stftri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;


  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  info, a = NumRu::Lapack.stftri( transr, uplo, diag, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STFTRI( TRANSR, UPLO, DIAG, N, A, INFO )\n\n*  Purpose\n*  =======\n*\n*  STFTRI computes the inverse of a triangular matrix A stored in RFP\n*  format.\n*\n*  This is a Level 3 BLAS version of the algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR    (input) CHARACTER*1\n*          = 'N':  The Normal TRANSR of RFP A is stored;\n*          = 'T':  The Transpose TRANSR of RFP A is stored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (NT);\n*          NT=N*(N+1)/2. On entry, the triangular factor of a Hermitian\n*          Positive Definite matrix A in RFP format. RFP format is\n*          described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n*          then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n*          (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is\n*          the transpose of RFP A as defined when\n*          TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n*          follows: If UPLO = 'U' the RFP A contains the nt elements of\n*          upper packed A; If UPLO = 'L' the RFP A contains the nt\n*          elements of lower packed A. The LDA of RFP A is (N+1)/2 when\n*          TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is\n*          even and N is odd. See the Note below for more details.\n*\n*          On exit, the (triangular) inverse of the original matrix, in\n*          the same storage format.\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, A(i,i) is exactly zero.  The triangular\n*               matrix is singular and its inverse can not be computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  We first consider Rectangular Full Packed (RFP) Format when N is\n*  even. We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  the transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  the transpose of the last three columns of AP lower.\n*  This covers the case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        03 04 05                33 43 53\n*        13 14 15                00 44 54\n*        23 24 25                10 11 55\n*        33 34 35                20 21 22\n*        00 44 45                30 31 32\n*        01 11 55                40 41 42\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We then consider Rectangular Full Packed (RFP) Format when N is\n*  odd. We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  the transpose of the first two columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  the transpose of the last two columns of AP lower.\n*  This covers the case N odd and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        02 03 04                00 33 43\n*        12 13 14                10 11 44\n*        22 23 24                20 21 22\n*        00 33 34                30 31 32\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*           RFP A                   RFP A\n*\n*     02 12 22 00 01             00 10 20 30 40 50\n*     03 13 23 33 11             33 11 21 31 41 51\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.stftri( transr, uplo, diag, n, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_diag = argv[2];
  rblapack_n = argv[3];
  rblapack_a = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 1)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  stftri_(&transr, &uplo, &diag, &n, a, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_stftri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "stftri", rblapack_stftri, -1);
}
ruby-lapack-1.7.2/ext/dsygvx.c0000644000175000017500000003253012502221014016047 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsygvx_(integer* itype, char* jobz, char* range, char* uplo, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublereal* z, integer* ldz, doublereal* work, integer* lwork, integer* iwork, integer* ifail, integer* info);


static VALUE
rblapack_dsygvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_vl;
  doublereal vl; 
  VALUE rblapack_vu;
  doublereal vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  doublereal abstol; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_ifail;
  integer *ifail; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;
  integer *iwork;

  integer lda;
  integer n;
  integer ldb;
  integer ldz;

  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  m, w, z, work, ifail, info, a, b = NumRu::Lapack.dsygvx( itype, jobz, range, uplo, a, b, vl, vu, il, iu, abstol, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSYGVX computes selected eigenvalues, and optionally, eigenvectors\n*  of a real generalized symmetric-definite eigenproblem, of the form\n*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A\n*  and B are assumed to be symmetric and B is also positive definite.\n*  Eigenvalues and eigenvectors can be selected by specifying either a\n*  range of values or a range of indices for the desired eigenvalues.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          Specifies the problem type to be solved:\n*          = 1:  A*x = (lambda)*B*x\n*          = 2:  A*B*x = (lambda)*x\n*          = 3:  B*A*x = (lambda)*x\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found.\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found.\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A and B are stored;\n*          = 'L':  Lower triangle of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix pencil (A,B).  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of A contains the\n*          upper triangular part of the matrix A.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of A contains\n*          the lower triangular part of the matrix A.\n*\n*          On exit, the lower triangle (if UPLO='L') or the upper\n*          triangle (if UPLO='U') of A, including the diagonal, is\n*          destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n*          On entry, the symmetric matrix B.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of B contains the\n*          upper triangular part of the matrix B.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of B contains\n*          the lower triangular part of the matrix B.\n*\n*          On exit, if INFO <= N, the part of B containing the matrix is\n*          overwritten by the triangular factor U or L from the Cholesky\n*          factorization B = U**T*U or B = L*L**T.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  VL      (input) DOUBLE PRECISION\n*  VU      (input) DOUBLE PRECISION\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) DOUBLE PRECISION\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less than\n*          or equal to zero, then  EPS*|T|  will be used in its place,\n*          where |T| is the 1-norm of the tridiagonal matrix obtained\n*          by reducing A to tridiagonal form.\n*\n*          Eigenvalues will be computed most accurately when ABSTOL is\n*          set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n*          If this routine returns with INFO>0, indicating that some\n*          eigenvectors did not converge, try setting ABSTOL to\n*          2*DLAMCH('S').\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          On normal exit, the first M elements contain the selected\n*          eigenvalues in ascending order.\n*\n*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))\n*          If JOBZ = 'N', then Z is not referenced.\n*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix A\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          The eigenvectors are normalized as follows:\n*          if ITYPE = 1 or 2, Z**T*B*Z = I;\n*          if ITYPE = 3, Z**T*inv(B)*Z = I.\n*\n*          If an eigenvector fails to converge, then that column of Z\n*          contains the latest approximation to the eigenvector, and the\n*          index of the eigenvector is returned in IFAIL.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,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 length of the array WORK.  LWORK >= max(1,8*N).\n*          For optimal efficiency, LWORK >= (NB+3)*N,\n*          where NB is the blocksize for DSYTRD returned by ILAENV.\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*  IWORK   (workspace) INTEGER array, dimension (5*N)\n*\n*  IFAIL   (output) INTEGER array, dimension (N)\n*          If JOBZ = 'V', then if INFO = 0, the first M elements of\n*          IFAIL are zero.  If INFO > 0, then IFAIL contains the\n*          indices of the eigenvectors that failed to converge.\n*          If JOBZ = 'N', then IFAIL is not referenced.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  DPOTRF or DSYEVX returned an error code:\n*             <= N:  if INFO = i, DSYEVX failed to converge;\n*                    i eigenvectors failed to converge.  Their indices\n*                    are stored in array IFAIL.\n*             > N:   if INFO = N + i, for 1 <= i <= N, then the leading\n*                    minor of order i of B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, work, ifail, info, a, b = NumRu::Lapack.dsygvx( itype, jobz, range, uplo, a, b, vl, vu, il, iu, abstol, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 11 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
  rblapack_itype = argv[0];
  rblapack_jobz = argv[1];
  rblapack_range = argv[2];
  rblapack_uplo = argv[3];
  rblapack_a = argv[4];
  rblapack_b = argv[5];
  rblapack_vl = argv[6];
  rblapack_vu = argv[7];
  rblapack_il = argv[8];
  rblapack_iu = argv[9];
  rblapack_abstol = argv[10];
  if (argc == 12) {
    rblapack_lwork = argv[11];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  itype = NUM2INT(rblapack_itype);
  range = StringValueCStr(rblapack_range)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th 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*);
  vl = NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  abstol = NUM2DBL(rblapack_abstol);
  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  iu = NUM2INT(rblapack_iu);
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (rblapack_lwork == Qnil)
    lwork = 8*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  vu = NUM2DBL(rblapack_vu);
  m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = lsame_(&jobz,"N") ? 0 : ldz;
    shape[1] = lsame_(&jobz,"N") ? 0 : MAX(1,m);
    rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  iwork = ALLOC_N(integer, (5*n));

  dsygvx_(&itype, &jobz, &range, &uplo, &n, a, &lda, b, &ldb, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, &lwork, iwork, ifail, &info);

  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_m, rblapack_w, rblapack_z, rblapack_work, rblapack_ifail, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_dsygvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsygvx", rblapack_dsygvx, -1);
}
ruby-lapack-1.7.2/ext/dgbequb.c0000644000175000017500000001412312502221016016134 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgbequb_(integer* m, integer* n, integer* kl, integer* ku, doublereal* ab, integer* ldab, doublereal* r, doublereal* c, doublereal* rowcnd, doublereal* colcnd, doublereal* amax, integer* info);


static VALUE
rblapack_dgbequb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_r;
  doublereal *r; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_rowcnd;
  doublereal rowcnd; 
  VALUE rblapack_colcnd;
  doublereal colcnd; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_info;
  integer info; 

  integer ldab;
  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  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.dgbequb( kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGBEQUB computes row and column scalings intended to equilibrate an\n*  M-by-N matrix A and reduce its condition number.  R returns the row\n*  scale factors and C the column scale factors, chosen to try to make\n*  the largest element in each row and column of the matrix B with\n*  elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n*  the radix.\n*\n*  R(i) and C(j) are restricted to be a power of the radix between\n*  SMLNUM = smallest safe number and BIGNUM = largest safe number.  Use\n*  of these scaling factors is not guaranteed to reduce the condition\n*  number of A but works well in practice.\n*\n*  This routine differs from DGEEQU by restricting the scaling factors\n*  to a power of the radix.  Baring over- and underflow, scaling by\n*  these factors introduces no additional rounding errors.  However, the\n*  scaled entries' magnitured are no longer approximately 1 but lie\n*  between sqrt(radix) and 1/sqrt(radix).\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*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)\n*          On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n*          The j-th column of A is stored in the j-th column of the\n*          array AB as follows:\n*          AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array A.  LDAB >= max(1,M).\n*\n*  R       (output) DOUBLE PRECISION array, dimension (M)\n*          If INFO = 0 or INFO > M, R contains the row scale factors\n*          for A.\n*\n*  C       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0,  C contains the column scale factors for A.\n*\n*  ROWCND  (output) DOUBLE PRECISION\n*          If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n*          smallest R(i) to the largest R(i).  If ROWCND >= 0.1 and\n*          AMAX is neither too large nor too small, it is not worth\n*          scaling by R.\n*\n*  COLCND  (output) DOUBLE PRECISION\n*          If INFO = 0, COLCND contains the ratio of the smallest\n*          C(i) to the largest C(i).  If COLCND >= 0.1, it is not\n*          worth scaling by C.\n*\n*  AMAX    (output) DOUBLE PRECISION\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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,  and i is\n*                <= M:  the i-th row of A is exactly zero\n*                >  M:  the (i-M)-th column of A is exactly zero\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.dgbequb( kl, ku, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_kl = argv[0];
  rblapack_ku = argv[1];
  rblapack_ab = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  ku = NUM2INT(rblapack_ku);
  m = ldab;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_r = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  r = NA_PTR_TYPE(rblapack_r, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  c = NA_PTR_TYPE(rblapack_c, doublereal*);

  dgbequb_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &info);

  rblapack_rowcnd = rb_float_new((double)rowcnd);
  rblapack_colcnd = rb_float_new((double)colcnd);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
}

void
init_lapack_dgbequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgbequb", rblapack_dgbequb, -1);
}
ruby-lapack-1.7.2/ext/sspgvx.c0000644000175000017500000003024112502221025016054 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sspgvx_(integer* itype, char* jobz, char* range, char* uplo, integer* n, real* ap, real* bp, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, real* z, integer* ldz, real* work, integer* iwork, integer* ifail, integer* info);


static VALUE
rblapack_sspgvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_bp;
  real *bp; 
  VALUE rblapack_vl;
  real vl; 
  VALUE rblapack_vu;
  real vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  real abstol; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_ifail;
  integer *ifail; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  real *ap_out__;
  VALUE rblapack_bp_out__;
  real *bp_out__;
  real *work;
  integer *iwork;

  integer ldap;
  integer n;
  integer ldz;

  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  m, w, z, ifail, info, ap, bp = NumRu::Lapack.sspgvx( itype, jobz, range, uplo, ap, bp, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSPGVX computes selected eigenvalues, and optionally, eigenvectors\n*  of a real generalized symmetric-definite eigenproblem, of the form\n*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A\n*  and B are assumed to be symmetric, stored in packed storage, and B\n*  is also positive definite.  Eigenvalues and eigenvectors can be\n*  selected by specifying either a range of values or a range of indices\n*  for the desired eigenvalues.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          Specifies the problem type to be solved:\n*          = 1:  A*x = (lambda)*B*x\n*          = 2:  A*B*x = (lambda)*x\n*          = 3:  B*A*x = (lambda)*x\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found.\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found.\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A and B are stored;\n*          = 'L':  Lower triangle of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix pencil (A,B).  N >= 0.\n*\n*  AP      (input/output) REAL array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, the contents of AP are destroyed.\n*\n*  BP      (input/output) REAL array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          B, packed columnwise in a linear array.  The j-th column of B\n*          is stored in the array BP as follows:\n*          if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n*          if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n*          On exit, the triangular factor U or L from the Cholesky\n*          factorization B = U**T*U or B = L*L**T, in the same storage\n*          format as B.\n*\n*  VL      (input) REAL\n*  VU      (input) REAL\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) REAL\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less than\n*          or equal to zero, then  EPS*|T|  will be used in its place,\n*          where |T| is the 1-norm of the tridiagonal matrix obtained\n*          by reducing A to tridiagonal form.\n*\n*          Eigenvalues will be computed most accurately when ABSTOL is\n*          set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n*          If this routine returns with INFO>0, indicating that some\n*          eigenvectors did not converge, try setting ABSTOL to\n*          2*SLAMCH('S').\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) REAL array, dimension (N)\n*          On normal exit, the first M elements contain the selected\n*          eigenvalues in ascending order.\n*\n*  Z       (output) REAL array, dimension (LDZ, max(1,M))\n*          If JOBZ = 'N', then Z is not referenced.\n*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix A\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          The eigenvectors are normalized as follows:\n*          if ITYPE = 1 or 2, Z**T*B*Z = I;\n*          if ITYPE = 3, Z**T*inv(B)*Z = I.\n*\n*          If an eigenvector fails to converge, then that column of Z\n*          contains the latest approximation to the eigenvector, and the\n*          index of the eigenvector is returned in IFAIL.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace) REAL array, dimension (8*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (5*N)\n*\n*  IFAIL   (output) INTEGER array, dimension (N)\n*          If JOBZ = 'V', then if INFO = 0, the first M elements of\n*          IFAIL are zero.  If INFO > 0, then IFAIL contains the\n*          indices of the eigenvectors that failed to converge.\n*          If JOBZ = 'N', then IFAIL is not referenced.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  SPPTRF or SSPEVX returned an error code:\n*             <= N:  if INFO = i, SSPEVX failed to converge;\n*                    i eigenvectors failed to converge.  Their indices\n*                    are stored in array IFAIL.\n*             > N:   if INFO = N + i, for 1 <= i <= N, then the leading\n*                    minor of order i of B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            ALLEIG, INDEIG, UPPER, VALEIG, WANTZ\n      CHARACTER          TRANS\n      INTEGER            J\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SPPTRF, SSPEVX, SSPGST, STPMV, STPSV, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, ifail, info, ap, bp = NumRu::Lapack.sspgvx( itype, jobz, range, uplo, ap, bp, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 11 && argc != 11)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
  rblapack_itype = argv[0];
  rblapack_jobz = argv[1];
  rblapack_range = argv[2];
  rblapack_uplo = argv[3];
  rblapack_ap = argv[4];
  rblapack_bp = argv[5];
  rblapack_vl = argv[6];
  rblapack_vu = argv[7];
  rblapack_il = argv[8];
  rblapack_iu = argv[9];
  rblapack_abstol = argv[10];
  if (argc == 11) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  itype = NUM2INT(rblapack_itype);
  range = StringValueCStr(rblapack_range)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  vl = (real)NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  abstol = (real)NUM2DBL(rblapack_abstol);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_bp))
    rb_raise(rb_eArgError, "bp (6th argument) must be NArray");
  if (NA_RANK(rblapack_bp) != 1)
    rb_raise(rb_eArgError, "rank of bp (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_bp) != NA_SFLOAT)
    rblapack_bp = na_change_type(rblapack_bp, NA_SFLOAT);
  bp = NA_PTR_TYPE(rblapack_bp, real*);
  iu = NUM2INT(rblapack_iu);
  m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
  uplo = StringValueCStr(rblapack_uplo)[0];
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  vu = (real)NUM2DBL(rblapack_vu);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = lsame_(&jobz,"N") ? 0 : ldz;
    shape[1] = lsame_(&jobz,"N") ? 0 : MAX(1,m);
    rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, real*);
  MEMCPY(ap_out__, ap, real, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_bp_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  bp_out__ = NA_PTR_TYPE(rblapack_bp_out__, real*);
  MEMCPY(bp_out__, bp, real, NA_TOTAL(rblapack_bp));
  rblapack_bp = rblapack_bp_out__;
  bp = bp_out__;
  work = ALLOC_N(real, (8*n));
  iwork = ALLOC_N(integer, (5*n));

  sspgvx_(&itype, &jobz, &range, &uplo, &n, ap, bp, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, iwork, ifail, &info);

  free(work);
  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_ap, rblapack_bp);
}

void
init_lapack_sspgvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sspgvx", rblapack_sspgvx, -1);
}
ruby-lapack-1.7.2/ext/zhpgvd.c0000644000175000017500000003033312502221016016026 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhpgvd_(integer* itype, char* jobz, char* uplo, integer* n, doublecomplex* ap, doublecomplex* bp, doublereal* w, doublecomplex* z, integer* ldz, doublecomplex* work, integer* lwork, doublereal* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_zhpgvd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_bp;
  doublecomplex *bp; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_lrwork;
  integer lrwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublecomplex *ap_out__;
  VALUE rblapack_bp_out__;
  doublecomplex *bp_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer ldap;
  integer n;
  integer ldz;

  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  w, z, iwork, info, ap, bp = NumRu::Lapack.zhpgvd( itype, jobz, uplo, ap, bp, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHPGVD computes all the eigenvalues and, optionally, the eigenvectors\n*  of a complex generalized Hermitian-definite eigenproblem, of the form\n*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A and\n*  B are assumed to be Hermitian, stored in packed format, and B is also\n*  positive definite.\n*  If eigenvectors are desired, it uses a divide and conquer algorithm.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          Specifies the problem type to be solved:\n*          = 1:  A*x = (lambda)*B*x\n*          = 2:  A*B*x = (lambda)*x\n*          = 3:  B*A*x = (lambda)*x\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, the contents of AP are destroyed.\n*\n*  BP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          B, packed columnwise in a linear array.  The j-th column of B\n*          is stored in the array BP as follows:\n*          if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n*          if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n*          On exit, the triangular factor U or L from the Cholesky\n*          factorization B = U**H*U or B = L*L**H, in the same storage\n*          format as B.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) COMPLEX*16 array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n*          eigenvectors.  The eigenvectors are normalized as follows:\n*          if ITYPE = 1 or 2, Z**H*B*Z = I;\n*          if ITYPE = 3, Z**H*inv(B)*Z = I.\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the required LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of array WORK.\n*          If N <= 1,               LWORK >= 1.\n*          If JOBZ = 'N' and N > 1, LWORK >= N.\n*          If JOBZ = 'V' and N > 1, LWORK >= 2*N.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the required sizes of the WORK, RWORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))\n*          On exit, if INFO = 0, RWORK(1) returns the required LRWORK.\n*\n*  LRWORK  (input) INTEGER\n*          The dimension of array RWORK.\n*          If N <= 1,               LRWORK >= 1.\n*          If JOBZ = 'N' and N > 1, LRWORK >= N.\n*          If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.\n*\n*          If LRWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the required sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of array IWORK.\n*          If JOBZ  = 'N' or N <= 1, LIWORK >= 1.\n*          If JOBZ  = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the required sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK 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:  ZPPTRF or ZHPEVD returned an error code:\n*             <= N:  if INFO = i, ZHPEVD failed to converge;\n*                    i off-diagonal elements of an intermediate\n*                    tridiagonal form did not convergeto zero;\n*             > N:   if INFO = N + i, for 1 <= i <= n, then the leading\n*                    minor of order i of B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY, UPPER, WANTZ\n      CHARACTER          TRANS\n      INTEGER            J, LIWMIN, LRWMIN, LWMIN, NEIG\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZHPEVD, ZHPGST, ZPPTRF, ZTPMV, ZTPSV\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          DBLE, MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, iwork, info, ap, bp = NumRu::Lapack.zhpgvd( itype, jobz, uplo, ap, bp, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_itype = argv[0];
  rblapack_jobz = argv[1];
  rblapack_uplo = argv[2];
  rblapack_ap = argv[3];
  rblapack_bp = argv[4];
  if (argc == 8) {
    rblapack_lwork = argv[5];
    rblapack_lrwork = argv[6];
    rblapack_liwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_lrwork = Qnil;
    rblapack_liwork = Qnil;
  }

  itype = NUM2INT(rblapack_itype);
  uplo = StringValueCStr(rblapack_uplo)[0];
  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  if (!NA_IsNArray(rblapack_bp))
    rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
  if (NA_RANK(rblapack_bp) != 1)
    rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_bp) != NA_DCOMPLEX)
    rblapack_bp = na_change_type(rblapack_bp, NA_DCOMPLEX);
  bp = NA_PTR_TYPE(rblapack_bp, doublecomplex*);
  if (rblapack_lrwork == Qnil)
    lrwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
  else {
    lrwork = NUM2INT(rblapack_lrwork);
  }
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  if (rblapack_lwork == Qnil)
    lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 2*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (rblapack_liwork == Qnil)
    liwork = (lsame_(&jobz,"N")||n<=1) ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
  MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_bp_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  bp_out__ = NA_PTR_TYPE(rblapack_bp_out__, doublecomplex*);
  MEMCPY(bp_out__, bp, doublecomplex, NA_TOTAL(rblapack_bp));
  rblapack_bp = rblapack_bp_out__;
  bp = bp_out__;
  work = ALLOC_N(doublecomplex, (MAX(1,lwork)));
  rwork = ALLOC_N(doublereal, (MAX(1,lrwork)));

  zhpgvd_(&itype, &jobz, &uplo, &n, ap, bp, w, z, &ldz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_w, rblapack_z, rblapack_iwork, rblapack_info, rblapack_ap, rblapack_bp);
}

void
init_lapack_zhpgvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhpgvd", rblapack_zhpgvd, -1);
}
ruby-lapack-1.7.2/ext/clatrs.c0000644000175000017500000002474112502221022016017 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clatrs_(char* uplo, char* trans, char* diag, char* normin, integer* n, complex* a, integer* lda, complex* x, real* scale, real* cnorm, integer* info);


static VALUE
rblapack_clatrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_normin;
  char normin; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_cnorm;
  real *cnorm; 
  VALUE rblapack_scale;
  real scale; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  complex *x_out__;
  VALUE rblapack_cnorm_out__;
  real *cnorm_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  scale, info, x, cnorm = NumRu::Lapack.clatrs( uplo, trans, diag, normin, a, x, cnorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, CNORM, INFO )\n\n*  Purpose\n*  =======\n*\n*  CLATRS solves one of the triangular systems\n*\n*     A * x = s*b,  A**T * x = s*b,  or  A**H * x = s*b,\n*\n*  with scaling to prevent overflow.  Here A is an upper or lower\n*  triangular matrix, A**T denotes the transpose of A, A**H denotes the\n*  conjugate transpose of A, x and b are n-element vectors, and s is a\n*  scaling factor, usually less than or equal to 1, chosen so that the\n*  components of x will be less than the overflow threshold.  If the\n*  unscaled problem will not cause overflow, the Level 2 BLAS routine\n*  CTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j),\n*  then s is set to 0 and a non-trivial solution to A*x = 0 is returned.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the matrix A is upper or lower triangular.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the operation applied to A.\n*          = 'N':  Solve A * x = s*b     (No transpose)\n*          = 'T':  Solve A**T * x = s*b  (Transpose)\n*          = 'C':  Solve A**H * x = s*b  (Conjugate transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          Specifies whether or not the matrix A is unit triangular.\n*          = 'N':  Non-unit triangular\n*          = 'U':  Unit triangular\n*\n*  NORMIN  (input) CHARACTER*1\n*          Specifies whether CNORM has been set or not.\n*          = 'Y':  CNORM contains the column norms on entry\n*          = 'N':  CNORM is not set on entry.  On exit, the norms will\n*                  be computed and stored in CNORM.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The triangular matrix A.  If UPLO = 'U', the leading n by n\n*          upper triangular part of the array A contains the upper\n*          triangular matrix, and the strictly lower triangular part of\n*          A is not referenced.  If UPLO = 'L', the leading n by n lower\n*          triangular part of the array A contains the lower triangular\n*          matrix, and the strictly upper triangular part of A is not\n*          referenced.  If DIAG = 'U', the diagonal elements of A are\n*          also not referenced and are assumed to be 1.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max (1,N).\n*\n*  X       (input/output) COMPLEX array, dimension (N)\n*          On entry, the right hand side b of the triangular system.\n*          On exit, X is overwritten by the solution vector x.\n*\n*  SCALE   (output) REAL\n*          The scaling factor s for the triangular system\n*             A * x = s*b,  A**T * x = s*b,  or  A**H * x = s*b.\n*          If SCALE = 0, the matrix A is singular or badly scaled, and\n*          the vector x is an exact or approximate solution to A*x = 0.\n*\n*  CNORM   (input or output) REAL array, dimension (N)\n*\n*          If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n*          contains the norm of the off-diagonal part of the j-th column\n*          of A.  If TRANS = 'N', CNORM(j) must be greater than or equal\n*          to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n*          must be greater than or equal to the 1-norm.\n*\n*          If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n*          returns the 1-norm of the offdiagonal part of the j-th column\n*          of A.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -k, the k-th argument had an illegal value\n*\n\n*  Further Details\n*  ======= =======\n*\n*  A rough bound on x is computed; if that is less than overflow, CTRSV\n*  is called, otherwise, specific code is used which checks for possible\n*  overflow or divide-by-zero at every operation.\n*\n*  A columnwise scheme is used for solving A*x = b.  The basic algorithm\n*  if A is lower triangular is\n*\n*       x[1:n] := b[1:n]\n*       for j = 1, ..., n\n*            x(j) := x(j) / A(j,j)\n*            x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n*       end\n*\n*  Define bounds on the components of x after j iterations of the loop:\n*     M(j) = bound on x[1:j]\n*     G(j) = bound on x[j+1:n]\n*  Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n*  Then for iteration j+1 we have\n*     M(j+1) <= G(j) / | A(j+1,j+1) |\n*     G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n*            <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n*  where CNORM(j+1) is greater than or equal to the infinity-norm of\n*  column j+1 of A, not counting the diagonal.  Hence\n*\n*     G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n*                  1<=i<=j\n*  and\n*\n*     |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n*                                   1<=i< j\n*\n*  Since |x(j)| <= M(j), we use the Level 2 BLAS routine CTRSV if the\n*  reciprocal of the largest M(j), j=1,..,n, is larger than\n*  max(underflow, 1/overflow).\n*\n*  The bound on x(j) is also used to determine when a step in the\n*  columnwise method can be performed without fear of overflow.  If\n*  the computed bound is greater than a large constant, x is scaled to\n*  prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n*  1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n*  Similarly, a row-wise scheme is used to solve A**T *x = b  or\n*  A**H *x = b.  The basic algorithm for A upper triangular is\n*\n*       for j = 1, ..., n\n*            x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n*       end\n*\n*  We simultaneously compute two bounds\n*       G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n*       M(j) = bound on x(i), 1<=i<=j\n*\n*  The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n*  add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n*  Then the bound on x(j) is\n*\n*       M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n*            <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n*                      1<=i<=j\n*\n*  and we can safely call CTRSV if 1/M(n) and 1/G(n) are both greater\n*  than max(underflow, 1/overflow).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, info, x, cnorm = NumRu::Lapack.clatrs( uplo, trans, diag, normin, a, x, cnorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_normin = argv[3];
  rblapack_a = argv[4];
  rblapack_x = argv[5];
  rblapack_cnorm = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_cnorm))
    rb_raise(rb_eArgError, "cnorm (7th argument) must be NArray");
  if (NA_RANK(rblapack_cnorm) != 1)
    rb_raise(rb_eArgError, "rank of cnorm (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_cnorm) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of cnorm must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_cnorm) != NA_SFLOAT)
    rblapack_cnorm = na_change_type(rblapack_cnorm, NA_SFLOAT);
  cnorm = NA_PTR_TYPE(rblapack_cnorm, real*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  normin = StringValueCStr(rblapack_normin)[0];
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_cnorm_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  cnorm_out__ = NA_PTR_TYPE(rblapack_cnorm_out__, real*);
  MEMCPY(cnorm_out__, cnorm, real, NA_TOTAL(rblapack_cnorm));
  rblapack_cnorm = rblapack_cnorm_out__;
  cnorm = cnorm_out__;

  clatrs_(&uplo, &trans, &diag, &normin, &n, a, &lda, x, &scale, cnorm, &info);

  rblapack_scale = rb_float_new((double)scale);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_scale, rblapack_info, rblapack_x, rblapack_cnorm);
}

void
init_lapack_clatrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clatrs", rblapack_clatrs, -1);
}
ruby-lapack-1.7.2/ext/cgebd2.c0000644000175000017500000001716612502221013015660 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgebd2_(integer* m, integer* n, complex* a, integer* lda, real* d, real* e, complex* tauq, complex* taup, complex* work, integer* info);


static VALUE
rblapack_cgebd2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_tauq;
  complex *tauq; 
  VALUE rblapack_taup;
  complex *taup; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  complex *work;

  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  d, e, tauq, taup, info, a = NumRu::Lapack.cgebd2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGEBD2 reduces a complex general m by n matrix A to upper or lower\n*  real bidiagonal form B by a unitary transformation: Q' * A * P = B.\n*\n*  If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows in the matrix A.  M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns in the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the m by n general matrix to be reduced.\n*          On exit,\n*          if m >= n, the diagonal and the first superdiagonal are\n*            overwritten with the upper bidiagonal matrix B; the\n*            elements below the diagonal, with the array TAUQ, represent\n*            the unitary matrix Q as a product of elementary\n*            reflectors, and the elements above the first superdiagonal,\n*            with the array TAUP, represent the unitary matrix P as\n*            a product of elementary reflectors;\n*          if m < n, the diagonal and the first subdiagonal are\n*            overwritten with the lower bidiagonal matrix B; the\n*            elements below the first subdiagonal, with the array TAUQ,\n*            represent the unitary matrix Q as a product of\n*            elementary reflectors, and the elements above the diagonal,\n*            with the array TAUP, represent the unitary matrix P as\n*            a product of elementary reflectors.\n*          See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  D       (output) REAL array, dimension (min(M,N))\n*          The diagonal elements of the bidiagonal matrix B:\n*          D(i) = A(i,i).\n*\n*  E       (output) REAL array, dimension (min(M,N)-1)\n*          The off-diagonal elements of the bidiagonal matrix B:\n*          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n*          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n*\n*  TAUQ    (output) COMPLEX array dimension (min(M,N))\n*          The scalar factors of the elementary reflectors which\n*          represent the unitary matrix Q. See Further Details.\n*\n*  TAUP    (output) COMPLEX array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors which\n*          represent the unitary matrix P. See Further Details.\n*\n*  WORK    (workspace) COMPLEX array, dimension (max(M,N))\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 matrices Q and P are represented as products of elementary\n*  reflectors:\n*\n*  If m >= n,\n*\n*     Q = H(1) H(2) . . . H(n)  and  P = G(1) G(2) . . . G(n-1)\n*\n*  Each H(i) and G(i) has the form:\n*\n*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'\n*\n*  where tauq and taup are complex scalars, and v and u are complex\n*  vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in\n*  A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in\n*  A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n*  If m < n,\n*\n*     Q = H(1) H(2) . . . H(m-1)  and  P = G(1) G(2) . . . G(m)\n*\n*  Each H(i) and G(i) has the form:\n*\n*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'\n*\n*  where tauq and taup are complex scalars, v and u are complex vectors;\n*  v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);\n*  u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);\n*  tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n*  The contents of A on exit are illustrated by the following examples:\n*\n*  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):\n*\n*    (  d   e   u1  u1  u1 )           (  d   u1  u1  u1  u1  u1 )\n*    (  v1  d   e   u2  u2 )           (  e   d   u2  u2  u2  u2 )\n*    (  v1  v2  d   e   u3 )           (  v1  e   d   u3  u3  u3 )\n*    (  v1  v2  v3  d   e  )           (  v1  v2  e   d   u4  u4 )\n*    (  v1  v2  v3  v4  d  )           (  v1  v2  v3  e   d   u5 )\n*    (  v1  v2  v3  v4  v5 )\n*\n*  where d and e denote diagonal and off-diagonal elements of B, vi\n*  denotes an element of the vector defining H(i), and ui an element of\n*  the vector defining G(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, tauq, taup, info, a = NumRu::Lapack.cgebd2( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, real*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n)-1;
    rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tauq = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  tauq = NA_PTR_TYPE(rblapack_tauq, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_taup = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  taup = NA_PTR_TYPE(rblapack_taup, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(complex, (MAX(m,n)));

  cgebd2_(&m, &n, a, &lda, d, e, tauq, taup, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_d, rblapack_e, rblapack_tauq, rblapack_taup, rblapack_info, rblapack_a);
}

void
init_lapack_cgebd2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgebd2", rblapack_cgebd2, -1);
}
ruby-lapack-1.7.2/ext/zgebal.c0000644000175000017500000001410712502221025015771 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgebal_(char* job, integer* n, doublecomplex* a, integer* lda, integer* ilo, integer* ihi, doublereal* scale, integer* info);


static VALUE
rblapack_zgebal(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_scale;
  doublereal *scale; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *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  ilo, ihi, scale, info, a = NumRu::Lapack.zgebal( job, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGEBAL balances a general complex matrix A.  This involves, first,\n*  permuting A by a similarity transformation to isolate eigenvalues\n*  in the first 1 to ILO-1 and last IHI+1 to N elements on the\n*  diagonal; and second, applying a diagonal similarity transformation\n*  to rows and columns ILO to IHI to make the rows and columns as\n*  close in norm as possible.  Both steps are optional.\n*\n*  Balancing may reduce the 1-norm of the matrix, and improve the\n*  accuracy of the computed eigenvalues and/or eigenvectors.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies the operations to be performed on A:\n*          = 'N':  none:  simply set ILO = 1, IHI = N, SCALE(I) = 1.0\n*                  for i = 1,...,N;\n*          = 'P':  permute only;\n*          = 'S':  scale only;\n*          = 'B':  both permute and scale.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the input matrix A.\n*          On exit,  A is overwritten by the balanced matrix.\n*          If JOB = 'N', A is not referenced.\n*          See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  ILO     (output) INTEGER\n*  IHI     (output) INTEGER\n*          ILO and IHI are set to integers such that on exit\n*          A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.\n*          If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n*\n*  SCALE   (output) DOUBLE PRECISION array, dimension (N)\n*          Details of the permutations and scaling factors applied to\n*          A.  If P(j) is the index of the row and column interchanged\n*          with row and column j and D(j) is the scaling factor\n*          applied to row and column j, then\n*          SCALE(j) = P(j)    for j = 1,...,ILO-1\n*                   = D(j)    for j = ILO,...,IHI\n*                   = P(j)    for j = IHI+1,...,N.\n*          The order in which the interchanges are made is N to IHI+1,\n*          then 1 to ILO-1.\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 permutations consist of row and column interchanges which put\n*  the matrix in the form\n*\n*             ( T1   X   Y  )\n*     P A P = (  0   B   Z  )\n*             (  0   0   T2 )\n*\n*  where T1 and T2 are upper triangular matrices whose eigenvalues lie\n*  along the diagonal.  The column indices ILO and IHI mark the starting\n*  and ending columns of the submatrix B. Balancing consists of applying\n*  a diagonal similarity transformation inv(D) * B * D to make the\n*  1-norms of each row of B and its corresponding column nearly equal.\n*  The output matrix is\n*\n*     ( T1     X*D          Y    )\n*     (  0  inv(D)*B*D  inv(D)*Z ).\n*     (  0      0           T2   )\n*\n*  Information about the permutations P and the diagonal matrix D is\n*  returned in the vector SCALE.\n*\n*  This subroutine is based on the EISPACK routine CBAL.\n*\n*  Modified by Tzu-Yi Chen, Computer Science Division, University of\n*    California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ilo, ihi, scale, info, a = NumRu::Lapack.zgebal( job, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_job = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  job = StringValueCStr(rblapack_job)[0];
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_scale = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  scale = NA_PTR_TYPE(rblapack_scale, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zgebal_(&job, &n, a, &lda, &ilo, &ihi, scale, &info);

  rblapack_ilo = INT2NUM(ilo);
  rblapack_ihi = INT2NUM(ihi);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_ilo, rblapack_ihi, rblapack_scale, rblapack_info, rblapack_a);
}

void
init_lapack_zgebal(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgebal", rblapack_zgebal, -1);
}
ruby-lapack-1.7.2/ext/zhbevx.c0000644000175000017500000002544112502221015016035 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhbevx_(char* jobz, char* range, char* uplo, integer* n, integer* kd, doublecomplex* ab, integer* ldab, doublecomplex* q, integer* ldq, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublecomplex* z, integer* ldz, doublecomplex* work, doublereal* rwork, integer* iwork, integer* ifail, integer* info);


static VALUE
rblapack_zhbevx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_vl;
  doublereal vl; 
  VALUE rblapack_vu;
  doublereal vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  doublereal abstol; 
  VALUE rblapack_q;
  doublecomplex *q; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_ifail;
  integer *ifail; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublecomplex *ab_out__;
  doublecomplex *work;
  doublereal *rwork;
  integer *iwork;

  integer ldab;
  integer n;
  integer ldq;
  integer ldz;

  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  q, m, w, z, ifail, info, ab = NumRu::Lapack.zhbevx( jobz, range, uplo, kd, ab, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHBEVX computes selected eigenvalues and, optionally, eigenvectors\n*  of a complex Hermitian band matrix A.  Eigenvalues and eigenvectors\n*  can be selected by specifying either a range of values or a range of\n*  indices for the desired eigenvalues.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found;\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found;\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) COMPLEX*16 array, dimension (LDAB, N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*          On exit, AB is overwritten by values generated during the\n*          reduction to tridiagonal form.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD + 1.\n*\n*  Q       (output) COMPLEX*16 array, dimension (LDQ, N)\n*          If JOBZ = 'V', the N-by-N unitary matrix used in the\n*                          reduction to tridiagonal form.\n*          If JOBZ = 'N', the array Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.  If JOBZ = 'V', then\n*          LDQ >= max(1,N).\n*\n*  VL      (input) DOUBLE PRECISION\n*  VU      (input) DOUBLE PRECISION\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) DOUBLE PRECISION\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less than\n*          or equal to zero, then  EPS*|T|  will be used in its place,\n*          where |T| is the 1-norm of the tridiagonal matrix obtained\n*          by reducing AB to tridiagonal form.\n*\n*          Eigenvalues will be computed most accurately when ABSTOL is\n*          set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n*          If this routine returns with INFO>0, indicating that some\n*          eigenvectors did not converge, try setting ABSTOL to\n*          2*DLAMCH('S').\n*\n*          See \"Computing Small Singular Values of Bidiagonal Matrices\n*          with Guaranteed High Relative Accuracy,\" by Demmel and\n*          Kahan, LAPACK Working Note #3.\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          The first M elements contain the selected eigenvalues in\n*          ascending order.\n*\n*  Z       (output) COMPLEX*16 array, dimension (LDZ, max(1,M))\n*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix A\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          If an eigenvector fails to converge, then that column of Z\n*          contains the latest approximation to the eigenvector, and the\n*          index of the eigenvector is returned in IFAIL.\n*          If JOBZ = 'N', then Z is not referenced.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (7*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (5*N)\n*\n*  IFAIL   (output) INTEGER array, dimension (N)\n*          If JOBZ = 'V', then if INFO = 0, the first M elements of\n*          IFAIL are zero.  If INFO > 0, then IFAIL contains the\n*          indices of the eigenvectors that failed to converge.\n*          If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n*                Their indices are stored in array IFAIL.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  q, m, w, z, ifail, info, ab = NumRu::Lapack.zhbevx( jobz, range, uplo, kd, ab, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_uplo = argv[2];
  rblapack_kd = argv[3];
  rblapack_ab = argv[4];
  rblapack_vl = argv[5];
  rblapack_vu = argv[6];
  rblapack_il = argv[7];
  rblapack_iu = argv[8];
  rblapack_abstol = argv[9];
  if (argc == 10) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  vu = NUM2DBL(rblapack_vu);
  iu = NUM2INT(rblapack_iu);
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  ldq = lsame_(&jobz,"V") ? MAX(1,n) : 0;
  range = StringValueCStr(rblapack_range)[0];
  vl = NUM2DBL(rblapack_vl);
  abstol = NUM2DBL(rblapack_abstol);
  kd = NUM2INT(rblapack_kd);
  il = NUM2INT(rblapack_il);
  m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
  MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  work = ALLOC_N(doublecomplex, (n));
  rwork = ALLOC_N(doublereal, (7*n));
  iwork = ALLOC_N(integer, (5*n));

  zhbevx_(&jobz, &range, &uplo, &n, &kd, ab, &ldab, q, &ldq, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, rwork, iwork, ifail, &info);

  free(work);
  free(rwork);
  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_q, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_ab);
}

void
init_lapack_zhbevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhbevx", rblapack_zhbevx, -1);
}
ruby-lapack-1.7.2/ext/ztgsy2.c0000644000175000017500000003050212502221022015761 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztgsy2_(char* trans, integer* ijob, integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* c, integer* ldc, doublecomplex* d, integer* ldd, doublecomplex* e, integer* lde, doublecomplex* f, integer* ldf, doublereal* scale, doublereal* rdsum, doublereal* rdscal, integer* info);


static VALUE
rblapack_ztgsy2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_ijob;
  integer ijob; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_c;
  doublecomplex *c; 
  VALUE rblapack_d;
  doublecomplex *d; 
  VALUE rblapack_e;
  doublecomplex *e; 
  VALUE rblapack_f;
  doublecomplex *f; 
  VALUE rblapack_rdsum;
  doublereal rdsum; 
  VALUE rblapack_rdscal;
  doublereal rdscal; 
  VALUE rblapack_scale;
  doublereal scale; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublecomplex *c_out__;
  VALUE rblapack_f_out__;
  doublecomplex *f_out__;

  integer lda;
  integer m;
  integer ldb;
  integer n;
  integer ldc;
  integer ldd;
  integer lde;
  integer ldf;

  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  scale, info, c, f, rdsum, rdscal = NumRu::Lapack.ztgsy2( trans, ijob, a, b, c, d, e, f, rdsum, rdscal, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTGSY2 solves the generalized Sylvester equation\n*\n*              A * R - L * B = scale *   C               (1)\n*              D * R - L * E = scale * F\n*\n*  using Level 1 and 2 BLAS, where R and L are unknown M-by-N matrices,\n*  (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,\n*  N-by-N and M-by-N, respectively. A, B, D and E are upper triangular\n*  (i.e., (A,D) and (B,E) in generalized Schur form).\n*\n*  The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output\n*  scaling factor chosen to avoid overflow.\n*\n*  In matrix notation solving equation (1) corresponds to solve\n*  Zx = scale * b, where Z is defined as\n*\n*         Z = [ kron(In, A)  -kron(B', Im) ]             (2)\n*             [ kron(In, D)  -kron(E', Im) ],\n*\n*  Ik is the identity matrix of size k and X' is the transpose of X.\n*  kron(X, Y) is the Kronecker product between the matrices X and Y.\n*\n*  If TRANS = 'C', y in the conjugate transposed system Z'y = scale*b\n*  is solved for, which is equivalent to solve for R and L in\n*\n*              A' * R  + D' * L   = scale *  C           (3)\n*              R  * B' + L  * E'  = scale * -F\n*\n*  This case is used to compute an estimate of Dif[(A, D), (B, E)] =\n*  = sigma_min(Z) using reverse communicaton with ZLACON.\n*\n*  ZTGSY2 also (IJOB >= 1) contributes to the computation in ZTGSYL\n*  of an upper bound on the separation between to matrix pairs. Then\n*  the input (A, D), (B, E) are sub-pencils of two matrix pairs in\n*  ZTGSYL.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N', solve the generalized Sylvester equation (1).\n*          = 'T': solve the 'transposed' system (3).\n*\n*  IJOB    (input) INTEGER\n*          Specifies what kind of functionality to be performed.\n*          =0: solve (1) only.\n*          =1: A contribution from this subsystem to a Frobenius\n*              norm-based estimate of the separation between two matrix\n*              pairs is computed. (look ahead strategy is used).\n*          =2: A contribution from this subsystem to a Frobenius\n*              norm-based estimate of the separation between two matrix\n*              pairs is computed. (DGECON on sub-systems is used.)\n*          Not referenced if TRANS = 'T'.\n*\n*  M       (input) INTEGER\n*          On entry, M specifies the order of A and D, and the row\n*          dimension of C, F, R and L.\n*\n*  N       (input) INTEGER\n*          On entry, N specifies the order of B and E, and the column\n*          dimension of C, F, R and L.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA, M)\n*          On entry, A contains an upper triangular matrix.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the matrix A. LDA >= max(1, M).\n*\n*  B       (input) COMPLEX*16 array, dimension (LDB, N)\n*          On entry, B contains an upper triangular matrix.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the matrix B. LDB >= max(1, N).\n*\n*  C       (input/output) COMPLEX*16 array, dimension (LDC, N)\n*          On entry, C contains the right-hand-side of the first matrix\n*          equation in (1).\n*          On exit, if IJOB = 0, C has been overwritten by the solution\n*          R.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the matrix C. LDC >= max(1, M).\n*\n*  D       (input) COMPLEX*16 array, dimension (LDD, M)\n*          On entry, D contains an upper triangular matrix.\n*\n*  LDD     (input) INTEGER\n*          The leading dimension of the matrix D. LDD >= max(1, M).\n*\n*  E       (input) COMPLEX*16 array, dimension (LDE, N)\n*          On entry, E contains an upper triangular matrix.\n*\n*  LDE     (input) INTEGER\n*          The leading dimension of the matrix E. LDE >= max(1, N).\n*\n*  F       (input/output) COMPLEX*16 array, dimension (LDF, N)\n*          On entry, F contains the right-hand-side of the second matrix\n*          equation in (1).\n*          On exit, if IJOB = 0, F has been overwritten by the solution\n*          L.\n*\n*  LDF     (input) INTEGER\n*          The leading dimension of the matrix F. LDF >= max(1, M).\n*\n*  SCALE   (output) DOUBLE PRECISION\n*          On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions\n*          R and L (C and F on entry) will hold the solutions to a\n*          slightly perturbed system but the input matrices A, B, D and\n*          E have not been changed. If SCALE = 0, R and L will hold the\n*          solutions to the homogeneous system with C = F = 0.\n*          Normally, SCALE = 1.\n*\n*  RDSUM   (input/output) DOUBLE PRECISION\n*          On entry, the sum of squares of computed contributions to\n*          the Dif-estimate under computation by ZTGSYL, where the\n*          scaling factor RDSCAL (see below) has been factored out.\n*          On exit, the corresponding sum of squares updated with the\n*          contributions from the current sub-system.\n*          If TRANS = 'T' RDSUM is not touched.\n*          NOTE: RDSUM only makes sense when ZTGSY2 is called by\n*          ZTGSYL.\n*\n*  RDSCAL  (input/output) DOUBLE PRECISION\n*          On entry, scaling factor used to prevent overflow in RDSUM.\n*          On exit, RDSCAL is updated w.r.t. the current contributions\n*          in RDSUM.\n*          If TRANS = 'T', RDSCAL is not touched.\n*          NOTE: RDSCAL only makes sense when ZTGSY2 is called by\n*          ZTGSYL.\n*\n*  INFO    (output) INTEGER\n*          On exit, if INFO is set to\n*            =0: Successful exit\n*            <0: If INFO = -i, input argument number i is illegal.\n*            >0: The matrix pairs (A, D) and (B, E) have common or very\n*                close eigenvalues.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, info, c, f, rdsum, rdscal = NumRu::Lapack.ztgsy2( trans, ijob, a, b, c, d, e, f, rdsum, rdscal, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_trans = argv[0];
  rblapack_ijob = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  rblapack_c = argv[4];
  rblapack_d = argv[5];
  rblapack_e = argv[6];
  rblapack_f = argv[7];
  rblapack_rdsum = argv[8];
  rblapack_rdscal = argv[9];
  if (argc == 10) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (7th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 2)
    rb_raise(rb_eArgError, "rank of e (7th argument) must be %d", 2);
  lde = NA_SHAPE0(rblapack_e);
  if (NA_SHAPE1(rblapack_e) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of e must be the same as shape 1 of c");
  if (NA_TYPE(rblapack_e) != NA_DCOMPLEX)
    rblapack_e = na_change_type(rblapack_e, NA_DCOMPLEX);
  e = NA_PTR_TYPE(rblapack_e, doublecomplex*);
  rdsum = NUM2DBL(rblapack_rdsum);
  ijob = NUM2INT(rblapack_ijob);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (6th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 2)
    rb_raise(rb_eArgError, "rank of d (6th argument) must be %d", 2);
  ldd = NA_SHAPE0(rblapack_d);
  if (NA_SHAPE1(rblapack_d) != m)
    rb_raise(rb_eRuntimeError, "shape 1 of d must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_d) != NA_DCOMPLEX)
    rblapack_d = na_change_type(rblapack_d, NA_DCOMPLEX);
  d = NA_PTR_TYPE(rblapack_d, doublecomplex*);
  rdscal = NUM2DBL(rblapack_rdscal);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of c");
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  if (!NA_IsNArray(rblapack_f))
    rb_raise(rb_eArgError, "f (8th argument) must be NArray");
  if (NA_RANK(rblapack_f) != 2)
    rb_raise(rb_eArgError, "rank of f (8th argument) must be %d", 2);
  ldf = NA_SHAPE0(rblapack_f);
  if (NA_SHAPE1(rblapack_f) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of f must be the same as shape 1 of c");
  if (NA_TYPE(rblapack_f) != NA_DCOMPLEX)
    rblapack_f = na_change_type(rblapack_f, NA_DCOMPLEX);
  f = NA_PTR_TYPE(rblapack_f, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
  MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldf;
    shape[1] = n;
    rblapack_f_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  f_out__ = NA_PTR_TYPE(rblapack_f_out__, doublecomplex*);
  MEMCPY(f_out__, f, doublecomplex, NA_TOTAL(rblapack_f));
  rblapack_f = rblapack_f_out__;
  f = f_out__;

  ztgsy2_(&trans, &ijob, &m, &n, a, &lda, b, &ldb, c, &ldc, d, &ldd, e, &lde, f, &ldf, &scale, &rdsum, &rdscal, &info);

  rblapack_scale = rb_float_new((double)scale);
  rblapack_info = INT2NUM(info);
  rblapack_rdsum = rb_float_new((double)rdsum);
  rblapack_rdscal = rb_float_new((double)rdscal);
  return rb_ary_new3(6, rblapack_scale, rblapack_info, rblapack_c, rblapack_f, rblapack_rdsum, rblapack_rdscal);
}

void
init_lapack_ztgsy2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztgsy2", rblapack_ztgsy2, -1);
}
ruby-lapack-1.7.2/ext/spotri.c0000644000175000017500000000727712502221015016056 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID spotri_(char* uplo, integer* n, real* a, integer* lda, integer* info);


static VALUE
rblapack_spotri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *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  info, a = NumRu::Lapack.spotri( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPOTRI( UPLO, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPOTRI computes the inverse of a real symmetric positive definite\n*  matrix A using the Cholesky factorization A = U**T*U or A = L*L**T\n*  computed by SPOTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the triangular factor U or L from the Cholesky\n*          factorization A = U**T*U or A = L*L**T, as computed by\n*          SPOTRF.\n*          On exit, the upper or lower triangle of the (symmetric)\n*          inverse of A, overwriting the input factor U or L.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\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,i) element of the factor U or L is\n*                zero, and the inverse could not be computed.\n*\n\n*  =====================================================================\n*\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SLAUUM, STRTRI, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.spotri( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  spotri_(&uplo, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_spotri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "spotri", rblapack_spotri, -1);
}
ruby-lapack-1.7.2/ext/spttrf.c0000644000175000017500000001033512502221013016043 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID spttrf_(integer* n, real* d, real* e, integer* info);


static VALUE
rblapack_spttrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_e_out__;
  real *e_out__;

  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  info, d, e = NumRu::Lapack.spttrf( d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPTTRF( N, D, E, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPTTRF computes the L*D*L' factorization of a real symmetric\n*  positive definite tridiagonal matrix A.  The factorization may also\n*  be regarded as having the form A = U'*D*U.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  D       (input/output) REAL array, dimension (N)\n*          On entry, the n diagonal elements of the tridiagonal matrix\n*          A.  On exit, the n diagonal elements of the diagonal matrix\n*          D from the L*D*L' factorization of A.\n*\n*  E       (input/output) REAL array, dimension (N-1)\n*          On entry, the (n-1) subdiagonal elements of the tridiagonal\n*          matrix A.  On exit, the (n-1) subdiagonal elements of the\n*          unit bidiagonal factor L from the L*D*L' factorization of A.\n*          E can also be regarded as the superdiagonal of the unit\n*          bidiagonal factor U from the U'*D*U factorization of A.\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*          > 0: if INFO = k, the leading minor of order k is not\n*               positive definite; if k < N, the factorization could not\n*               be completed, while if k = N, the factorization was\n*               completed, but D(N) <= 0.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, e = NumRu::Lapack.spttrf( d, e, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_d = argv[0];
  rblapack_e = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (2th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
  MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;

  spttrf_(&n, d, e, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_d, rblapack_e);
}

void
init_lapack_spttrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "spttrf", rblapack_spttrf, -1);
}
ruby-lapack-1.7.2/ext/slangb.c0000644000175000017500000001037612502221020015772 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real slangb_(char* norm, integer* n, integer* kl, integer* ku, real* ab, integer* ldab, real* work);


static VALUE
rblapack_slangb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack___out__;
  real __out__; 
  real *work;

  integer ldab;
  integer n;
  integer lwork;

  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  __out__ = NumRu::Lapack.slangb( norm, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL             FUNCTION SLANGB( NORM, N, KL, KU, AB, LDAB, WORK )\n\n*  Purpose\n*  =======\n*\n*  SLANGB  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the element of  largest absolute value  of an\n*  n by n band matrix  A,  with kl sub-diagonals and ku super-diagonals.\n*\n*  Description\n*  ===========\n*\n*  SLANGB returns the value\n*\n*     SLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in SLANGB as described\n*          above.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, SLANGB is\n*          set to zero.\n*\n*  KL      (input) INTEGER\n*          The number of sub-diagonals of the matrix A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of super-diagonals of the matrix A.  KU >= 0.\n*\n*  AB      (input) REAL array, dimension (LDAB,N)\n*          The band matrix A, stored in rows 1 to KL+KU+1.  The j-th\n*          column of A is stored in the j-th column of the array AB as\n*          follows:\n*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n*          referenced.\n*\n\n* =====================================================================\n*\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.slangb( norm, kl, ku, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_norm = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  ku = NUM2INT(rblapack_ku);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  lwork = lsame_(&norm,"I") ? n : 0;
  work = ALLOC_N(real, (MAX(1,lwork)));

  __out__ = slangb_(&norm, &n, &kl, &ku, ab, &ldab, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_slangb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slangb", rblapack_slangb, -1);
}
ruby-lapack-1.7.2/ext/sgbequb.c0000644000175000017500000001371712502221013016160 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgbequb_(integer* m, integer* n, integer* kl, integer* ku, doublereal* ab, integer* ldab, real* r, real* c, real* rowcnd, real* colcnd, real* amax, integer* info);


static VALUE
rblapack_sgbequb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_r;
  real *r; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_rowcnd;
  real rowcnd; 
  VALUE rblapack_colcnd;
  real colcnd; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_info;
  integer info; 

  integer ldab;
  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  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.sgbequb( kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGBEQUB computes row and column scalings intended to equilibrate an\n*  M-by-N matrix A and reduce its condition number.  R returns the row\n*  scale factors and C the column scale factors, chosen to try to make\n*  the largest element in each row and column of the matrix B with\n*  elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n*  the radix.\n*\n*  R(i) and C(j) are restricted to be a power of the radix between\n*  SMLNUM = smallest safe number and BIGNUM = largest safe number.  Use\n*  of these scaling factors is not guaranteed to reduce the condition\n*  number of A but works well in practice.\n*\n*  This routine differs from SGEEQU by restricting the scaling factors\n*  to a power of the radix.  Baring over- and underflow, scaling by\n*  these factors introduces no additional rounding errors.  However, the\n*  scaled entries' magnitured are no longer approximately 1 but lie\n*  between sqrt(radix) and 1/sqrt(radix).\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*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)\n*          On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n*          The j-th column of A is stored in the j-th column of the\n*          array AB as follows:\n*          AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array A.  LDAB >= max(1,M).\n*\n*  R       (output) REAL array, dimension (M)\n*          If INFO = 0 or INFO > M, R contains the row scale factors\n*          for A.\n*\n*  C       (output) REAL array, dimension (N)\n*          If INFO = 0,  C contains the column scale factors for A.\n*\n*  ROWCND  (output) REAL\n*          If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n*          smallest R(i) to the largest R(i).  If ROWCND >= 0.1 and\n*          AMAX is neither too large nor too small, it is not worth\n*          scaling by R.\n*\n*  COLCND  (output) REAL\n*          If INFO = 0, COLCND contains the ratio of the smallest\n*          C(i) to the largest C(i).  If COLCND >= 0.1, it is not\n*          worth scaling by C.\n*\n*  AMAX    (output) REAL\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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,  and i is\n*                <= M:  the i-th row of A is exactly zero\n*                >  M:  the (i-M)-th column of A is exactly zero\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.sgbequb( kl, ku, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_kl = argv[0];
  rblapack_ku = argv[1];
  rblapack_ab = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  ku = NUM2INT(rblapack_ku);
  m = ldab;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_r = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  r = NA_PTR_TYPE(rblapack_r, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  c = NA_PTR_TYPE(rblapack_c, real*);

  sgbequb_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &info);

  rblapack_rowcnd = rb_float_new((double)rowcnd);
  rblapack_colcnd = rb_float_new((double)colcnd);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
}

void
init_lapack_sgbequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgbequb", rblapack_sgbequb, -1);
}
ruby-lapack-1.7.2/ext/dpptrf.c0000644000175000017500000001053712502221024016026 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dpptrf_(char* uplo, integer* n, doublereal* ap, integer* info);


static VALUE
rblapack_dpptrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublereal *ap_out__;


  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  info, ap = NumRu::Lapack.dpptrf( uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPPTRF( UPLO, N, AP, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPPTRF computes the Cholesky factorization of a real symmetric\n*  positive definite matrix A stored in packed format.\n*\n*  The factorization has the form\n*     A = U**T * U,  if UPLO = 'U', or\n*     A = L  * L**T,  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is lower triangular.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          See below for further details.\n*\n*          On exit, if INFO = 0, the triangular factor U or L from the\n*          Cholesky factorization A = U**T*U or A = L*L**T, in the same\n*          storage format as A.\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 leading minor of order i is not\n*                positive definite, and the factorization could not be\n*                completed.\n*\n\n*  Further Details\n*  ======= =======\n*\n*  The packed storage scheme is illustrated by the following example\n*  when N = 4, UPLO = 'U':\n*\n*  Two-dimensional storage of the symmetric matrix A:\n*\n*     a11 a12 a13 a14\n*         a22 a23 a24\n*             a33 a34     (aij = aji)\n*                 a44\n*\n*  Packed storage of the upper triangle of A:\n*\n*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ap = NumRu::Lapack.dpptrf( uplo, n, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_n = argv[1];
  rblapack_ap = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
  MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  dpptrf_(&uplo, &n, ap, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ap);
}

void
init_lapack_dpptrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dpptrf", rblapack_dpptrf, -1);
}
ruby-lapack-1.7.2/ext/dlasq6.c0000644000175000017500000001035612502221021015715 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlasq6_(integer* i0, integer* n0, doublereal* z, integer* pp, doublereal* dmin, doublereal* dmin1, doublereal* dmin2, doublereal* dn, doublereal* dnm1, doublereal* dnm2);


static VALUE
rblapack_dlasq6(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_i0;
  integer i0; 
  VALUE rblapack_n0;
  integer n0; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_pp;
  integer pp; 
  VALUE rblapack_dmin;
  doublereal dmin; 
  VALUE rblapack_dmin1;
  doublereal dmin1; 
  VALUE rblapack_dmin2;
  doublereal dmin2; 
  VALUE rblapack_dn;
  doublereal dn; 
  VALUE rblapack_dnm1;
  doublereal dnm1; 
  VALUE rblapack_dnm2;
  doublereal dnm2; 


  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  dmin, dmin1, dmin2, dn, dnm1, dnm2 = NumRu::Lapack.dlasq6( i0, n0, z, pp, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DNM1, DNM2 )\n\n*  Purpose\n*  =======\n*\n*  DLASQ6 computes one dqd (shift equal to zero) transform in\n*  ping-pong form, with protection against underflow and overflow.\n*\n\n*  Arguments\n*  =========\n*\n*  I0    (input) INTEGER\n*        First index.\n*\n*  N0    (input) INTEGER\n*        Last index.\n*\n*  Z     (input) DOUBLE PRECISION array, dimension ( 4*N )\n*        Z holds the qd array. EMIN is stored in Z(4*N0) to avoid\n*        an extra argument.\n*\n*  PP    (input) INTEGER\n*        PP=0 for ping, PP=1 for pong.\n*\n*  DMIN  (output) DOUBLE PRECISION\n*        Minimum value of d.\n*\n*  DMIN1 (output) DOUBLE PRECISION\n*        Minimum value of d, excluding D( N0 ).\n*\n*  DMIN2 (output) DOUBLE PRECISION\n*        Minimum value of d, excluding D( N0 ) and D( N0-1 ).\n*\n*  DN    (output) DOUBLE PRECISION\n*        d(N0), the last value of d.\n*\n*  DNM1  (output) DOUBLE PRECISION\n*        d(N0-1).\n*\n*  DNM2  (output) DOUBLE PRECISION\n*        d(N0-2).\n*\n\n*  =====================================================================\n*\n*     .. Parameter ..\n      DOUBLE PRECISION   ZERO\n      PARAMETER          ( ZERO = 0.0D0 )\n*     ..\n*     .. Local Scalars ..\n      INTEGER            J4, J4P2\n      DOUBLE PRECISION   D, EMIN, SAFMIN, TEMP\n*     ..\n*     .. External Function ..\n      DOUBLE PRECISION   DLAMCH\n      EXTERNAL           DLAMCH\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  dmin, dmin1, dmin2, dn, dnm1, dnm2 = NumRu::Lapack.dlasq6( i0, n0, z, pp, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_i0 = argv[0];
  rblapack_n0 = argv[1];
  rblapack_z = argv[2];
  rblapack_pp = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  i0 = NUM2INT(rblapack_i0);
  pp = NUM2INT(rblapack_pp);
  n0 = NUM2INT(rblapack_n0);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (3th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != (4*n0))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 4*n0);
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);

  dlasq6_(&i0, &n0, z, &pp, &dmin, &dmin1, &dmin2, &dn, &dnm1, &dnm2);

  rblapack_dmin = rb_float_new((double)dmin);
  rblapack_dmin1 = rb_float_new((double)dmin1);
  rblapack_dmin2 = rb_float_new((double)dmin2);
  rblapack_dn = rb_float_new((double)dn);
  rblapack_dnm1 = rb_float_new((double)dnm1);
  rblapack_dnm2 = rb_float_new((double)dnm2);
  return rb_ary_new3(6, rblapack_dmin, rblapack_dmin1, rblapack_dmin2, rblapack_dn, rblapack_dnm1, rblapack_dnm2);
}

void
init_lapack_dlasq6(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlasq6", rblapack_dlasq6, -1);
}
ruby-lapack-1.7.2/ext/dsytri2.c0000644000175000017500000001410112502221021016113 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsytri2_(char* uplo, integer* n, doublereal* a, integer* lda, integer* ipiv, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dsytri2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  integer c__1;
  integer c__m1;
  integer nb;
  doublereal *work;

  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  info, a = NumRu::Lapack.dsytri2( uplo, a, ipiv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSYTRI2 computes the inverse of a real symmetric indefinite matrix\n*  A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n*  DSYTRF. DSYTRI2 sets the LEADING DIMENSION of the workspace\n*  before calling DSYTRI2X that actually computes the inverse.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the NB diagonal matrix D and the multipliers\n*          used to obtain the factor U or L as computed by DSYTRF.\n*\n*          On exit, if INFO = 0, the (symmetric) inverse of the original\n*          matrix.  If UPLO = 'U', the upper triangular part of the\n*          inverse is formed and the part of A below the diagonal is not\n*          referenced; if UPLO = 'L' the lower triangular part of the\n*          inverse is formed and the part of A above the diagonal is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the NB structure of D\n*          as determined by DSYTRF.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (N+NB+1)*(NB+3)\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK.\n*          WORK is size >= (N+NB+1)*(NB+3)\n*          If LDWORK = -1, then a workspace query is assumed; the routine\n*           calculates:\n*              - the optimal size of the WORK array, returns\n*          this value as the first entry of the WORK array,\n*              - and no error message related to LDWORK 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, D(i,i) = 0; the matrix is singular and its\n*               inverse could not be computed.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            UPPER, LQUERY\n      INTEGER            MINSIZE, NBMAX\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            ILAENV\n      EXTERNAL           LSAME, ILAENV\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DSYTRI2X\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.dsytri2( uplo, a, ipiv, [: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_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = 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;
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  c__1 = 1;
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  c__m1 = -1;
  nb = ilaenv_(&c__1, "DSYTRF", &uplo, &n, &c__m1, &c__m1, &c__m1);
  if (rblapack_lwork == Qnil)
    lwork = (n+nb+1)*(nb+3);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t 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, (lwork));

  dsytri2_(&uplo, &n, a, &lda, ipiv, work, &lwork, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_dsytri2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsytri2", rblapack_dsytri2, -1);
}
ruby-lapack-1.7.2/ext/dpbrfs.c0000644000175000017500000002062112502221020015776 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dpbrfs_(char* uplo, integer* n, integer* kd, integer* nrhs, doublereal* ab, integer* ldab, doublereal* afb, integer* ldafb, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dpbrfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_afb;
  doublereal *afb; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  doublereal *x_out__;
  doublereal *work;
  integer *iwork;

  integer ldab;
  integer n;
  integer ldafb;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.dpbrfs( uplo, kd, ab, afb, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPBRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is symmetric positive definite\n*  and banded, and provides error bounds and backward error estimates\n*  for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)\n*          The upper or lower triangle of the symmetric band matrix A,\n*          stored in the first KD+1 rows of the array.  The j-th column\n*          of A is stored in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  AFB     (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**T*U or A = L*L**T of the band matrix A as computed by\n*          DPBTRF, in the same storage format as A (see AB).\n*\n*  LDAFB   (input) INTEGER\n*          The leading dimension of the array AFB.  LDAFB >= KD+1.\n*\n*  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by DPBTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.dpbrfs( uplo, kd, ab, afb, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  rblapack_afb = argv[3];
  rblapack_b = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  kd = NUM2INT(rblapack_kd);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (4th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (4th argument) must be %d", 2);
  ldafb = NA_SHAPE0(rblapack_afb);
  if (NA_SHAPE1(rblapack_afb) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_afb) != NA_DFLOAT)
    rblapack_afb = na_change_type(rblapack_afb, NA_DFLOAT);
  afb = NA_PTR_TYPE(rblapack_afb, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(doublereal, (3*n));
  iwork = ALLOC_N(integer, (n));

  dpbrfs_(&uplo, &n, &kd, &nrhs, ab, &ldab, afb, &ldafb, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_dpbrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dpbrfs", rblapack_dpbrfs, -1);
}
ruby-lapack-1.7.2/ext/slar1v.c0000644000175000017500000002523212502221022015733 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slar1v_(integer* n, integer* b1, integer* bn, real* lambda, real* d, real* l, real* ld, real* lld, real* pivmin, real* gaptol, real* z, logical* wantnc, integer* negcnt, real* ztz, real* mingma, integer* r, integer* isuppz, real* nrminv, real* resid, real* rqcorr, real* work);


static VALUE
rblapack_slar1v(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_b1;
  integer b1; 
  VALUE rblapack_bn;
  integer bn; 
  VALUE rblapack_lambda;
  real lambda; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_l;
  real *l; 
  VALUE rblapack_ld;
  real *ld; 
  VALUE rblapack_lld;
  real *lld; 
  VALUE rblapack_pivmin;
  real pivmin; 
  VALUE rblapack_gaptol;
  real gaptol; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_wantnc;
  logical wantnc; 
  VALUE rblapack_r;
  integer r; 
  VALUE rblapack_negcnt;
  integer negcnt; 
  VALUE rblapack_ztz;
  real ztz; 
  VALUE rblapack_mingma;
  real mingma; 
  VALUE rblapack_isuppz;
  integer *isuppz; 
  VALUE rblapack_nrminv;
  real nrminv; 
  VALUE rblapack_resid;
  real resid; 
  VALUE rblapack_rqcorr;
  real rqcorr; 
  VALUE rblapack_z_out__;
  real *z_out__;
  real *work;

  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  negcnt, ztz, mingma, isuppz, nrminv, resid, rqcorr, z, r = NumRu::Lapack.slar1v( b1, bn, lambda, d, l, ld, lld, pivmin, gaptol, z, wantnc, r, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD, PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, R, ISUPPZ, NRMINV, RESID, RQCORR, WORK )\n\n*  Purpose\n*  =======\n*\n*  SLAR1V computes the (scaled) r-th column of the inverse of\n*  the sumbmatrix in rows B1 through BN of the tridiagonal matrix\n*  L D L^T - sigma I. When sigma is close to an eigenvalue, the\n*  computed vector is an accurate eigenvector. Usually, r corresponds\n*  to the index where the eigenvector is largest in magnitude.\n*  The following steps accomplish this computation :\n*  (a) Stationary qd transform,  L D L^T - sigma I = L(+) D(+) L(+)^T,\n*  (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T,\n*  (c) Computation of the diagonal elements of the inverse of\n*      L D L^T - sigma I by combining the above transforms, and choosing\n*      r as the index where the diagonal of the inverse is (one of the)\n*      largest in magnitude.\n*  (d) Computation of the (scaled) r-th column of the inverse using the\n*      twisted factorization obtained by combining the top part of the\n*      the stationary and the bottom part of the progressive transform.\n*\n\n*  Arguments\n*  =========\n*\n*  N        (input) INTEGER\n*           The order of the matrix L D L^T.\n*\n*  B1       (input) INTEGER\n*           First index of the submatrix of L D L^T.\n*\n*  BN       (input) INTEGER\n*           Last index of the submatrix of L D L^T.\n*\n*  LAMBDA    (input) REAL            \n*           The shift. In order to compute an accurate eigenvector,\n*           LAMBDA should be a good approximation to an eigenvalue\n*           of L D L^T.\n*\n*  L        (input) REAL             array, dimension (N-1)\n*           The (n-1) subdiagonal elements of the unit bidiagonal matrix\n*           L, in elements 1 to N-1.\n*\n*  D        (input) REAL             array, dimension (N)\n*           The n diagonal elements of the diagonal matrix D.\n*\n*  LD       (input) REAL             array, dimension (N-1)\n*           The n-1 elements L(i)*D(i).\n*\n*  LLD      (input) REAL             array, dimension (N-1)\n*           The n-1 elements L(i)*L(i)*D(i).\n*\n*  PIVMIN   (input) REAL            \n*           The minimum pivot in the Sturm sequence.\n*\n*  GAPTOL   (input) REAL            \n*           Tolerance that indicates when eigenvector entries are negligible\n*           w.r.t. their contribution to the residual.\n*\n*  Z        (input/output) REAL             array, dimension (N)\n*           On input, all entries of Z must be set to 0.\n*           On output, Z contains the (scaled) r-th column of the\n*           inverse. The scaling is such that Z(R) equals 1.\n*\n*  WANTNC   (input) LOGICAL\n*           Specifies whether NEGCNT has to be computed.\n*\n*  NEGCNT   (output) INTEGER\n*           If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin\n*           in the  matrix factorization L D L^T, and NEGCNT = -1 otherwise.\n*\n*  ZTZ      (output) REAL            \n*           The square of the 2-norm of Z.\n*\n*  MINGMA   (output) REAL            \n*           The reciprocal of the largest (in magnitude) diagonal\n*           element of the inverse of L D L^T - sigma I.\n*\n*  R        (input/output) INTEGER\n*           The twist index for the twisted factorization used to\n*           compute Z.\n*           On input, 0 <= R <= N. If R is input as 0, R is set to\n*           the index where (L D L^T - sigma I)^{-1} is largest\n*           in magnitude. If 1 <= R <= N, R is unchanged.\n*           On output, R contains the twist index used to compute Z.\n*           Ideally, R designates the position of the maximum entry in the\n*           eigenvector.\n*\n*  ISUPPZ   (output) INTEGER array, dimension (2)\n*           The support of the vector in Z, i.e., the vector Z is\n*           nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ).\n*\n*  NRMINV   (output) REAL            \n*           NRMINV = 1/SQRT( ZTZ )\n*\n*  RESID    (output) REAL            \n*           The residual of the FP vector.\n*           RESID = ABS( MINGMA )/SQRT( ZTZ )\n*\n*  RQCORR   (output) REAL            \n*           The Rayleigh Quotient correction to LAMBDA.\n*           RQCORR = MINGMA*TMP\n*\n*  WORK     (workspace) REAL             array, dimension (4*N)\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Beresford Parlett, University of California, Berkeley, USA\n*     Jim Demmel, University of California, Berkeley, USA\n*     Inderjit Dhillon, University of Texas, Austin, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  negcnt, ztz, mingma, isuppz, nrminv, resid, rqcorr, z, r = NumRu::Lapack.slar1v( b1, bn, lambda, d, l, ld, lld, pivmin, gaptol, z, wantnc, r, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_b1 = argv[0];
  rblapack_bn = argv[1];
  rblapack_lambda = argv[2];
  rblapack_d = argv[3];
  rblapack_l = argv[4];
  rblapack_ld = argv[5];
  rblapack_lld = argv[6];
  rblapack_pivmin = argv[7];
  rblapack_gaptol = argv[8];
  rblapack_z = argv[9];
  rblapack_wantnc = argv[10];
  rblapack_r = argv[11];
  if (argc == 12) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  b1 = NUM2INT(rblapack_b1);
  lambda = (real)NUM2DBL(rblapack_lambda);
  pivmin = (real)NUM2DBL(rblapack_pivmin);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (10th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (10th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  r = NUM2INT(rblapack_r);
  bn = NUM2INT(rblapack_bn);
  gaptol = (real)NUM2DBL(rblapack_gaptol);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of z");
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_ld))
    rb_raise(rb_eArgError, "ld (6th argument) must be NArray");
  if (NA_RANK(rblapack_ld) != 1)
    rb_raise(rb_eArgError, "rank of ld (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ld) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of ld must be %d", n-1);
  if (NA_TYPE(rblapack_ld) != NA_SFLOAT)
    rblapack_ld = na_change_type(rblapack_ld, NA_SFLOAT);
  ld = NA_PTR_TYPE(rblapack_ld, real*);
  wantnc = (rblapack_wantnc == Qtrue);
  if (!NA_IsNArray(rblapack_l))
    rb_raise(rb_eArgError, "l (5th argument) must be NArray");
  if (NA_RANK(rblapack_l) != 1)
    rb_raise(rb_eArgError, "rank of l (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_l) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of l must be %d", n-1);
  if (NA_TYPE(rblapack_l) != NA_SFLOAT)
    rblapack_l = na_change_type(rblapack_l, NA_SFLOAT);
  l = NA_PTR_TYPE(rblapack_l, real*);
  if (!NA_IsNArray(rblapack_lld))
    rb_raise(rb_eArgError, "lld (7th argument) must be NArray");
  if (NA_RANK(rblapack_lld) != 1)
    rb_raise(rb_eArgError, "rank of lld (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_lld) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of lld must be %d", n-1);
  if (NA_TYPE(rblapack_lld) != NA_SFLOAT)
    rblapack_lld = na_change_type(rblapack_lld, NA_SFLOAT);
  lld = NA_PTR_TYPE(rblapack_lld, real*);
  {
    na_shape_t shape[1];
    shape[0] = 2;
    rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_z_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
  MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  work = ALLOC_N(real, (4*n));

  slar1v_(&n, &b1, &bn, &lambda, d, l, ld, lld, &pivmin, &gaptol, z, &wantnc, &negcnt, &ztz, &mingma, &r, isuppz, &nrminv, &resid, &rqcorr, work);

  free(work);
  rblapack_negcnt = INT2NUM(negcnt);
  rblapack_ztz = rb_float_new((double)ztz);
  rblapack_mingma = rb_float_new((double)mingma);
  rblapack_nrminv = rb_float_new((double)nrminv);
  rblapack_resid = rb_float_new((double)resid);
  rblapack_rqcorr = rb_float_new((double)rqcorr);
  rblapack_r = INT2NUM(r);
  return rb_ary_new3(9, rblapack_negcnt, rblapack_ztz, rblapack_mingma, rblapack_isuppz, rblapack_nrminv, rblapack_resid, rblapack_rqcorr, rblapack_z, rblapack_r);
}

void
init_lapack_slar1v(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slar1v", rblapack_slar1v, -1);
}
ruby-lapack-1.7.2/ext/zhesv.c0000644000175000017500000002017312502221023015662 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhesv_(char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* b, integer* ldb, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zhesv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  ipiv, work, info, a, b = NumRu::Lapack.zhesv( uplo, a, b, lwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHESV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHESV computes the solution to a complex system of linear equations\n*     A * X = B,\n*  where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS\n*  matrices.\n*\n*  The diagonal pivoting method is used to factor A as\n*     A = U * D * U**H,  if UPLO = 'U', or\n*     A = L * D * L**H,  if UPLO = 'L',\n*  where U (or L) is a product of permutation and unit upper (lower)\n*  triangular matrices, and D is Hermitian and block diagonal with\n*  1-by-1 and 2-by-2 diagonal blocks.  The factored form of A is then\n*  used to solve the system of equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the block diagonal matrix D and the\n*          multipliers used to obtain the factor U or L from the\n*          factorization A = U*D*U**H or A = L*D*L**H as computed by\n*          ZHETRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D, as\n*          determined by ZHETRF.  If IPIV(k) > 0, then rows and columns\n*          k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n*          diagonal block.  If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n*          then rows and columns k-1 and -IPIV(k) were interchanged and\n*          D(k-1:k,k-1:k) is a 2-by-2 diagonal block.  If UPLO = 'L' and\n*          IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n*          -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n*          diagonal block.\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of WORK.  LWORK >= 1, and for best performance\n*          LWORK >= max(1,N*NB), where NB is the optimal blocksize for\n*          ZHETRF.\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, D(i,i) is exactly zero.  The factorization\n*               has been completed, but the block diagonal matrix D is\n*               exactly singular, so the solution could not be computed.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY\n      INTEGER            LWKOPT, NB\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            ILAENV\n      EXTERNAL           LSAME, ILAENV\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZHETRF, ZHETRS2\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, work, info, a, b = NumRu::Lapack.zhesv( uplo, a, b, lwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_b = argv[2];
  rblapack_lwork = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  lwork = NUM2INT(rblapack_lwork);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zhesv_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_ipiv, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_zhesv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhesv", rblapack_zhesv, -1);
}
ruby-lapack-1.7.2/ext/sgtts2.c0000644000175000017500000001521712502221020015751 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgtts2_(integer* itrans, integer* n, integer* nrhs, real* dl, real* d, real* du, real* du2, integer* ipiv, real* b, integer* ldb);


static VALUE
rblapack_sgtts2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itrans;
  integer itrans; 
  VALUE rblapack_dl;
  real *dl; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_du;
  real *du; 
  VALUE rblapack_du2;
  real *du2; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_b_out__;
  real *b_out__;

  integer n;
  integer ldb;
  integer nrhs;

  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  b = NumRu::Lapack.sgtts2( itrans, dl, d, du, du2, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )\n\n*  Purpose\n*  =======\n*\n*  SGTTS2 solves one of the systems of equations\n*     A*X = B  or  A'*X = B,\n*  with a tridiagonal matrix A using the LU factorization computed\n*  by SGTTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  ITRANS  (input) INTEGER\n*          Specifies the form of the system of equations.\n*          = 0:  A * X = B  (No transpose)\n*          = 1:  A'* X = B  (Transpose)\n*          = 2:  A'* X = B  (Conjugate transpose = Transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  DL      (input) REAL array, dimension (N-1)\n*          The (n-1) multipliers that define the matrix L from the\n*          LU factorization of A.\n*\n*  D       (input) REAL array, dimension (N)\n*          The n diagonal elements of the upper triangular matrix U from\n*          the LU factorization of A.\n*\n*  DU      (input) REAL array, dimension (N-1)\n*          The (n-1) elements of the first super-diagonal of U.\n*\n*  DU2     (input) REAL array, dimension (N-2)\n*          The (n-2) elements of the second super-diagonal of U.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices; for 1 <= i <= n, row i of the matrix was\n*          interchanged with row IPIV(i).  IPIV(i) will always be either\n*          i or i+1; IPIV(i) = i indicates a row interchange was not\n*          required.\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the matrix of right hand side vectors B.\n*          On exit, B is overwritten by the solution vectors X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, IP, J\n      REAL               TEMP\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  b = NumRu::Lapack.sgtts2( itrans, dl, d, du, du2, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_itrans = argv[0];
  rblapack_dl = argv[1];
  rblapack_d = argv[2];
  rblapack_du = argv[3];
  rblapack_du2 = argv[4];
  rblapack_ipiv = argv[5];
  rblapack_b = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  itrans = NUM2INT(rblapack_itrans);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_SFLOAT)
    rblapack_dl = na_change_type(rblapack_dl, NA_SFLOAT);
  dl = NA_PTR_TYPE(rblapack_dl, real*);
  if (!NA_IsNArray(rblapack_du2))
    rb_raise(rb_eArgError, "du2 (5th argument) must be NArray");
  if (NA_RANK(rblapack_du2) != 1)
    rb_raise(rb_eArgError, "rank of du2 (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du2) != (n-2))
    rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
  if (NA_TYPE(rblapack_du2) != NA_SFLOAT)
    rblapack_du2 = na_change_type(rblapack_du2, NA_SFLOAT);
  du2 = NA_PTR_TYPE(rblapack_du2, real*);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (4th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_SFLOAT)
    rblapack_du = na_change_type(rblapack_du, NA_SFLOAT);
  du = NA_PTR_TYPE(rblapack_du, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  sgtts2_(&itrans, &n, &nrhs, dl, d, du, du2, ipiv, b, &ldb);

  return rblapack_b;
}

void
init_lapack_sgtts2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgtts2", rblapack_sgtts2, -1);
}
ruby-lapack-1.7.2/ext/dlagtm.c0000644000175000017500000001507012502221026015776 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlagtm_(char* trans, integer* n, integer* nrhs, doublereal* alpha, doublereal* dl, doublereal* d, doublereal* du, doublereal* x, integer* ldx, doublereal* beta, doublereal* b, integer* ldb);


static VALUE
rblapack_dlagtm(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_alpha;
  doublereal alpha; 
  VALUE rblapack_dl;
  doublereal *dl; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_du;
  doublereal *du; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_beta;
  doublereal beta; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_b_out__;
  doublereal *b_out__;

  integer n;
  integer ldx;
  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  b = NumRu::Lapack.dlagtm( trans, alpha, dl, d, du, x, beta, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, B, LDB )\n\n*  Purpose\n*  =======\n*\n*  DLAGTM performs a matrix-vector product of the form\n*\n*     B := alpha * A * X + beta * B\n*\n*  where A is a tridiagonal matrix of order N, B and X are N by NRHS\n*  matrices, and alpha and beta are real scalars, each of which may be\n*  0., 1., or -1.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the operation applied to A.\n*          = 'N':  No transpose, B := alpha * A * X + beta * B\n*          = 'T':  Transpose,    B := alpha * A'* X + beta * B\n*          = 'C':  Conjugate transpose = Transpose\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices X and B.\n*\n*  ALPHA   (input) DOUBLE PRECISION\n*          The scalar alpha.  ALPHA must be 0., 1., or -1.; otherwise,\n*          it is assumed to be 0.\n*\n*  DL      (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (n-1) sub-diagonal elements of T.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          The diagonal elements of T.\n*\n*  DU      (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (n-1) super-diagonal elements of T.\n*\n*  X       (input) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*          The N by NRHS matrix X.\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(N,1).\n*\n*  BETA    (input) DOUBLE PRECISION\n*          The scalar beta.  BETA must be 0., 1., or -1.; otherwise,\n*          it is assumed to be 1.\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the N by NRHS matrix B.\n*          On exit, B is overwritten by the matrix expression\n*          B := alpha * A * X + beta * B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(N,1).\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  b = NumRu::Lapack.dlagtm( trans, alpha, dl, d, du, x, beta, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_trans = argv[0];
  rblapack_alpha = argv[1];
  rblapack_dl = argv[2];
  rblapack_d = argv[3];
  rblapack_du = argv[4];
  rblapack_x = argv[5];
  rblapack_beta = argv[6];
  rblapack_b = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  alpha = NUM2DBL(rblapack_alpha);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (5th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_DFLOAT)
    rblapack_du = na_change_type(rblapack_du, NA_DFLOAT);
  du = NA_PTR_TYPE(rblapack_du, doublereal*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (3th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_DFLOAT)
    rblapack_dl = na_change_type(rblapack_dl, NA_DFLOAT);
  dl = NA_PTR_TYPE(rblapack_dl, doublereal*);
  beta = NUM2DBL(rblapack_beta);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dlagtm_(&trans, &n, &nrhs, &alpha, dl, d, du, x, &ldx, &beta, b, &ldb);

  return rblapack_b;
}

void
init_lapack_dlagtm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlagtm", rblapack_dlagtm, -1);
}
ruby-lapack-1.7.2/ext/zspcon.c0000644000175000017500000001110512502221023016032 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zspcon_(char* uplo, integer* n, doublecomplex* ap, integer* ipiv, doublereal* anorm, doublereal* rcond, doublecomplex* work, integer* info);


static VALUE
rblapack_zspcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_anorm;
  doublereal anorm; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_info;
  integer info; 
  doublecomplex *work;

  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  rcond, info = NumRu::Lapack.zspcon( uplo, ap, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZSPCON estimates the reciprocal of the condition number (in the\n*  1-norm) of a complex symmetric packed matrix A using the\n*  factorization A = U*D*U**T or A = L*D*L**T computed by ZSPTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by ZSPTRF, stored as a\n*          packed triangular matrix.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by ZSPTRF.\n*\n*  ANORM   (input) DOUBLE PRECISION\n*          The 1-norm of the original matrix A.\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n*          estimate of the 1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.zspcon( uplo, ap, ipiv, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_anorm = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  anorm = NUM2DBL(rblapack_anorm);
  work = ALLOC_N(doublecomplex, (2*n));

  zspcon_(&uplo, &n, ap, ipiv, &anorm, &rcond, work, &info);

  free(work);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_zspcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zspcon", rblapack_zspcon, -1);
}
ruby-lapack-1.7.2/ext/zunmr3.c0000644000175000017500000001607512502221015015770 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zunmr3_(char* side, char* trans, integer* m, integer* n, integer* k, integer* l, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work, integer* info);


static VALUE
rblapack_zunmr3(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_c;
  doublecomplex *c; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublecomplex *c_out__;
  doublecomplex *work;

  integer lda;
  integer m;
  integer k;
  integer ldc;
  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  info, c = NumRu::Lapack.zunmr3( side, trans, l, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZUNMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZUNMR3 overwrites the general complex m by n matrix C with\n*\n*        Q * C  if SIDE = 'L' and TRANS = 'N', or\n*\n*        Q'* C  if SIDE = 'L' and TRANS = 'C', or\n*\n*        C * Q  if SIDE = 'R' and TRANS = 'N', or\n*\n*        C * Q' if SIDE = 'R' and TRANS = 'C',\n*\n*  where Q is a complex unitary matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(1) H(2) . . . H(k)\n*\n*  as returned by ZTZRZF. Q is of order m if SIDE = 'L' and of order n\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q' from the Left\n*          = 'R': apply Q or Q' from the Right\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': apply Q  (No transpose)\n*          = 'C': apply Q' (Conjugate transpose)\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  L       (input) INTEGER\n*          The number of columns of the matrix A containing\n*          the meaningful part of the Householder reflectors.\n*          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension\n*                               (LDA,M) if SIDE = 'L',\n*                               (LDA,N) if SIDE = 'R'\n*          The i-th row must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          ZTZRZF in the last k rows of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,K).\n*\n*  TAU     (input) COMPLEX*16 array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by ZTZRZF.\n*\n*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)\n*          On entry, the m-by-n matrix C.\n*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension\n*                                   (N) if SIDE = 'L',\n*                                   (M) if SIDE = 'R'\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*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LEFT, NOTRAN\n      INTEGER            I, I1, I2, I3, IC, JA, JC, MI, NI, NQ\n      COMPLEX*16         TAUI\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZLARZ\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          DCONJG, MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, c = NumRu::Lapack.zunmr3( side, trans, l, a, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_l = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  l = NUM2INT(rblapack_l);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
  MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(doublecomplex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  zunmr3_(&side, &trans, &m, &n, &k, &l, a, &lda, tau, c, &ldc, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_c);
}

void
init_lapack_zunmr3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zunmr3", rblapack_zunmr3, -1);
}
ruby-lapack-1.7.2/ext/stgsy2.c0000644000175000017500000003125712502221016015765 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID stgsy2_(char* trans, integer* ijob, integer* m, integer* n, real* a, integer* lda, real* b, integer* ldb, real* c, integer* ldc, real* d, integer* ldd, real* e, integer* lde, real* f, integer* ldf, real* scale, real* rdsum, real* rdscal, integer* iwork, integer* pq, integer* info);


static VALUE
rblapack_stgsy2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_ijob;
  integer ijob; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_f;
  real *f; 
  VALUE rblapack_rdsum;
  real rdsum; 
  VALUE rblapack_rdscal;
  real rdscal; 
  VALUE rblapack_scale;
  real scale; 
  VALUE rblapack_pq;
  integer pq; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  real *c_out__;
  VALUE rblapack_f_out__;
  real *f_out__;
  integer *iwork;

  integer lda;
  integer m;
  integer ldb;
  integer n;
  integer ldc;
  integer ldd;
  integer lde;
  integer ldf;

  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  scale, pq, info, c, f, rdsum, rdscal = NumRu::Lapack.stgsy2( trans, ijob, a, b, c, d, e, f, rdsum, rdscal, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, IWORK, PQ, INFO )\n\n*  Purpose\n*  =======\n*\n*  STGSY2 solves the generalized Sylvester equation:\n*\n*              A * R - L * B = scale * C                (1)\n*              D * R - L * E = scale * F,\n*\n*  using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices,\n*  (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,\n*  N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E)\n*  must be in generalized Schur canonical form, i.e. A, B are upper\n*  quasi triangular and D, E are upper triangular. The solution (R, L)\n*  overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor\n*  chosen to avoid overflow.\n*\n*  In matrix notation solving equation (1) corresponds to solve\n*  Z*x = scale*b, where Z is defined as\n*\n*         Z = [ kron(In, A)  -kron(B', Im) ]             (2)\n*             [ kron(In, D)  -kron(E', Im) ],\n*\n*  Ik is the identity matrix of size k and X' is the transpose of X.\n*  kron(X, Y) is the Kronecker product between the matrices X and Y.\n*  In the process of solving (1), we solve a number of such systems\n*  where Dim(In), Dim(In) = 1 or 2.\n*\n*  If TRANS = 'T', solve the transposed system Z'*y = scale*b for y,\n*  which is equivalent to solve for R and L in\n*\n*              A' * R  + D' * L   = scale *  C           (3)\n*              R  * B' + L  * E'  = scale * -F\n*\n*  This case is used to compute an estimate of Dif[(A, D), (B, E)] =\n*  sigma_min(Z) using reverse communicaton with SLACON.\n*\n*  STGSY2 also (IJOB >= 1) contributes to the computation in STGSYL\n*  of an upper bound on the separation between to matrix pairs. Then\n*  the input (A, D), (B, E) are sub-pencils of the matrix pair in\n*  STGSYL. See STGSYL for details.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N', solve the generalized Sylvester equation (1).\n*          = 'T': solve the 'transposed' system (3).\n*\n*  IJOB    (input) INTEGER\n*          Specifies what kind of functionality to be performed.\n*          = 0: solve (1) only.\n*          = 1: A contribution from this subsystem to a Frobenius\n*               norm-based estimate of the separation between two matrix\n*               pairs is computed. (look ahead strategy is used).\n*          = 2: A contribution from this subsystem to a Frobenius\n*               norm-based estimate of the separation between two matrix\n*               pairs is computed. (SGECON on sub-systems is used.)\n*          Not referenced if TRANS = 'T'.\n*\n*  M       (input) INTEGER\n*          On entry, M specifies the order of A and D, and the row\n*          dimension of C, F, R and L.\n*\n*  N       (input) INTEGER\n*          On entry, N specifies the order of B and E, and the column\n*          dimension of C, F, R and L.\n*\n*  A       (input) REAL array, dimension (LDA, M)\n*          On entry, A contains an upper quasi triangular matrix.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the matrix A. LDA >= max(1, M).\n*\n*  B       (input) REAL array, dimension (LDB, N)\n*          On entry, B contains an upper quasi triangular matrix.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the matrix B. LDB >= max(1, N).\n*\n*  C       (input/output) REAL array, dimension (LDC, N)\n*          On entry, C contains the right-hand-side of the first matrix\n*          equation in (1).\n*          On exit, if IJOB = 0, C has been overwritten by the\n*          solution R.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the matrix C. LDC >= max(1, M).\n*\n*  D       (input) REAL array, dimension (LDD, M)\n*          On entry, D contains an upper triangular matrix.\n*\n*  LDD     (input) INTEGER\n*          The leading dimension of the matrix D. LDD >= max(1, M).\n*\n*  E       (input) REAL array, dimension (LDE, N)\n*          On entry, E contains an upper triangular matrix.\n*\n*  LDE     (input) INTEGER\n*          The leading dimension of the matrix E. LDE >= max(1, N).\n*\n*  F       (input/output) REAL array, dimension (LDF, N)\n*          On entry, F contains the right-hand-side of the second matrix\n*          equation in (1).\n*          On exit, if IJOB = 0, F has been overwritten by the\n*          solution L.\n*\n*  LDF     (input) INTEGER\n*          The leading dimension of the matrix F. LDF >= max(1, M).\n*\n*  SCALE   (output) REAL\n*          On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions\n*          R and L (C and F on entry) will hold the solutions to a\n*          slightly perturbed system but the input matrices A, B, D and\n*          E have not been changed. If SCALE = 0, R and L will hold the\n*          solutions to the homogeneous system with C = F = 0. Normally,\n*          SCALE = 1.\n*\n*  RDSUM   (input/output) REAL\n*          On entry, the sum of squares of computed contributions to\n*          the Dif-estimate under computation by STGSYL, where the\n*          scaling factor RDSCAL (see below) has been factored out.\n*          On exit, the corresponding sum of squares updated with the\n*          contributions from the current sub-system.\n*          If TRANS = 'T' RDSUM is not touched.\n*          NOTE: RDSUM only makes sense when STGSY2 is called by STGSYL.\n*\n*  RDSCAL  (input/output) REAL\n*          On entry, scaling factor used to prevent overflow in RDSUM.\n*          On exit, RDSCAL is updated w.r.t. the current contributions\n*          in RDSUM.\n*          If TRANS = 'T', RDSCAL is not touched.\n*          NOTE: RDSCAL only makes sense when STGSY2 is called by\n*                STGSYL.\n*\n*  IWORK   (workspace) INTEGER array, dimension (M+N+2)\n*\n*  PQ      (output) INTEGER\n*          On exit, the number of subsystems (of size 2-by-2, 4-by-4 and\n*          8-by-8) solved by this routine.\n*\n*  INFO    (output) INTEGER\n*          On exit, if INFO is set to\n*            =0: Successful exit\n*            <0: If INFO = -i, the i-th argument had an illegal value.\n*            >0: The matrix pairs (A, D) and (B, E) have common or very\n*                close eigenvalues.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  =====================================================================\n*  Replaced various illegal calls to SCOPY by calls to SLASET.\n*  Sven Hammarling, 27/5/02.\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, pq, info, c, f, rdsum, rdscal = NumRu::Lapack.stgsy2( trans, ijob, a, b, c, d, e, f, rdsum, rdscal, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_trans = argv[0];
  rblapack_ijob = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  rblapack_c = argv[4];
  rblapack_d = argv[5];
  rblapack_e = argv[6];
  rblapack_f = argv[7];
  rblapack_rdsum = argv[8];
  rblapack_rdscal = argv[9];
  if (argc == 10) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (7th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 2)
    rb_raise(rb_eArgError, "rank of e (7th argument) must be %d", 2);
  lde = NA_SHAPE0(rblapack_e);
  if (NA_SHAPE1(rblapack_e) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of e must be the same as shape 1 of c");
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  rdsum = (real)NUM2DBL(rblapack_rdsum);
  ijob = NUM2INT(rblapack_ijob);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (6th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 2)
    rb_raise(rb_eArgError, "rank of d (6th argument) must be %d", 2);
  ldd = NA_SHAPE0(rblapack_d);
  if (NA_SHAPE1(rblapack_d) != m)
    rb_raise(rb_eRuntimeError, "shape 1 of d must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  rdscal = (real)NUM2DBL(rblapack_rdscal);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of c");
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (!NA_IsNArray(rblapack_f))
    rb_raise(rb_eArgError, "f (8th argument) must be NArray");
  if (NA_RANK(rblapack_f) != 2)
    rb_raise(rb_eArgError, "rank of f (8th argument) must be %d", 2);
  ldf = NA_SHAPE0(rblapack_f);
  if (NA_SHAPE1(rblapack_f) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of f must be the same as shape 1 of c");
  if (NA_TYPE(rblapack_f) != NA_SFLOAT)
    rblapack_f = na_change_type(rblapack_f, NA_SFLOAT);
  f = NA_PTR_TYPE(rblapack_f, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldf;
    shape[1] = n;
    rblapack_f_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  f_out__ = NA_PTR_TYPE(rblapack_f_out__, real*);
  MEMCPY(f_out__, f, real, NA_TOTAL(rblapack_f));
  rblapack_f = rblapack_f_out__;
  f = f_out__;
  iwork = ALLOC_N(integer, (m+n+2));

  stgsy2_(&trans, &ijob, &m, &n, a, &lda, b, &ldb, c, &ldc, d, &ldd, e, &lde, f, &ldf, &scale, &rdsum, &rdscal, iwork, &pq, &info);

  free(iwork);
  rblapack_scale = rb_float_new((double)scale);
  rblapack_pq = INT2NUM(pq);
  rblapack_info = INT2NUM(info);
  rblapack_rdsum = rb_float_new((double)rdsum);
  rblapack_rdscal = rb_float_new((double)rdscal);
  return rb_ary_new3(7, rblapack_scale, rblapack_pq, rblapack_info, rblapack_c, rblapack_f, rblapack_rdsum, rblapack_rdscal);
}

void
init_lapack_stgsy2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "stgsy2", rblapack_stgsy2, -1);
}
ruby-lapack-1.7.2/ext/dlatrz.c0000644000175000017500000001203112502221020016012 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlatrz_(integer* m, integer* n, integer* l, doublereal* a, integer* lda, doublereal* tau, doublereal* work);


static VALUE
rblapack_dlatrz(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_tau;
  doublereal *tau; 
  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, a = NumRu::Lapack.dlatrz( l, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLATRZ( M, N, L, A, LDA, TAU, WORK )\n\n*  Purpose\n*  =======\n*\n*  DLATRZ factors the M-by-(M+L) real upper trapezoidal matrix\n*  [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R  0 ) * Z, by means\n*  of orthogonal transformations.  Z is an (M+L)-by-(M+L) orthogonal\n*  matrix and, R and A1 are M-by-M upper triangular matrices.\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*  L       (input) INTEGER\n*          The number of columns of the matrix A containing the\n*          meaningful part of the Householder vectors. N-M >= L >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the leading M-by-N upper trapezoidal part of the\n*          array A must contain the matrix to be factorized.\n*          On exit, the leading M-by-M upper triangular part of A\n*          contains the upper triangular matrix R, and elements N-L+1 to\n*          N of the first M rows of A, with the array TAU, represent the\n*          orthogonal matrix Z as a product of M elementary reflectors.\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 (M)\n*          The scalar factors of the elementary reflectors.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (M)\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n*  The factorization is obtained by Householder's method.  The kth\n*  transformation matrix, Z( k ), which is used to introduce zeros into\n*  the ( m - k + 1 )th row of A, is given in the form\n*\n*     Z( k ) = ( I     0   ),\n*              ( 0  T( k ) )\n*\n*  where\n*\n*     T( k ) = I - tau*u( k )*u( k )',   u( k ) = (   1    ),\n*                                                 (   0    )\n*                                                 ( z( k ) )\n*\n*  tau is a scalar and z( k ) is an l element vector. tau and z( k )\n*  are chosen to annihilate the elements of the kth row of A2.\n*\n*  The scalar tau is returned in the kth element of TAU and the vector\n*  u( k ) in the kth row of A2, such that the elements of z( k ) are\n*  in  a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in\n*  the upper triangular part of A1.\n*\n*  Z is given by\n*\n*     Z =  Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, a = NumRu::Lapack.dlatrz( l, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_l = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  l = NUM2INT(rblapack_l);
  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 = lda;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t 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));

  dlatrz_(&m, &n, &l, a, &lda, tau, work);

  free(work);
  return rb_ary_new3(2, rblapack_tau, rblapack_a);
}

void
init_lapack_dlatrz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlatrz", rblapack_dlatrz, -1);
}
ruby-lapack-1.7.2/ext/cungrq.c0000644000175000017500000001247312502221023016026 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cungrq_(integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_cungrq(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;

  integer lda;
  integer n;
  integer k;

  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 = NumRu::Lapack.cungrq( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CUNGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CUNGRQ generates an M-by-N complex matrix Q with orthonormal rows,\n*  which is defined as the last M rows of a product of K elementary\n*  reflectors of order N\n*\n*        Q  =  H(1)' H(2)' . . . H(k)'\n*\n*  as returned by CGERQF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. N >= M.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. M >= K >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the (m-k+i)-th row must contain the vector which\n*          defines the elementary reflector H(i), for i = 1,2,...,k, as\n*          returned by CGERQF in the last k rows of its array argument\n*          A.\n*          On exit, the M-by-N matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) COMPLEX array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by CGERQF.\n*\n*  WORK    (workspace/output) COMPLEX 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 has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, a = NumRu::Lapack.cungrq( m, a, tau, [: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_m = argv[0];
  rblapack_a = argv[1];
  rblapack_tau = 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;
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (rblapack_lwork == Qnil)
    lwork = m;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  cungrq_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_cungrq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cungrq", rblapack_cungrq, -1);
}
ruby-lapack-1.7.2/ext/sgeqr2p.c0000644000175000017500000001024312502221022016102 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgeqr2p_(integer* m, integer* n, real* a, integer* lda, real* tau, real* work, integer* info);


static VALUE
rblapack_sgeqr2p(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  real *work;

  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, info, a = NumRu::Lapack.sgeqr2p( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGEQR2P( M, N, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGEQR2P computes a QR factorization of a real m by n matrix A:\n*  A = Q * R.\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) REAL array, dimension (LDA,N)\n*          On entry, the m by n matrix A.\n*          On exit, the elements on and above the diagonal of the array\n*          contain the min(m,n) by n upper trapezoidal matrix R (R is\n*          upper triangular if m >= n); the elements below 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) REAL array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace) REAL array, dimension (N)\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(1) H(2) . . . H(k), 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:m) is stored on exit in A(i+1:m,i),\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.sgeqr2p( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(real, (n));

  sgeqr2p_(&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_sgeqr2p(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgeqr2p", rblapack_sgeqr2p, -1);
}
ruby-lapack-1.7.2/ext/zlacn2.c0000644000175000017500000001272312502221015015717 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlacn2_(integer* n, doublecomplex* v, doublecomplex* x, doublereal* est, integer* kase, integer* isave);


static VALUE
rblapack_zlacn2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_est;
  doublereal est; 
  VALUE rblapack_kase;
  integer kase; 
  VALUE rblapack_isave;
  integer *isave; 
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;
  VALUE rblapack_isave_out__;
  integer *isave_out__;
  doublecomplex *v;

  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  x, est, kase, isave = NumRu::Lapack.zlacn2( x, est, kase, isave, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLACN2( N, V, X, EST, KASE, ISAVE )\n\n*  Purpose\n*  =======\n*\n*  ZLACN2 estimates the 1-norm of a square, complex matrix A.\n*  Reverse communication is used for evaluating matrix-vector products.\n*\n\n*  Arguments\n*  =========\n*\n*  N      (input) INTEGER\n*         The order of the matrix.  N >= 1.\n*\n*  V      (workspace) COMPLEX*16 array, dimension (N)\n*         On the final return, V = A*W,  where  EST = norm(V)/norm(W)\n*         (W is not returned).\n*\n*  X      (input/output) COMPLEX*16 array, dimension (N)\n*         On an intermediate return, X should be overwritten by\n*               A * X,   if KASE=1,\n*               A' * X,  if KASE=2,\n*         where A' is the conjugate transpose of A, and ZLACN2 must be\n*         re-called with all the other parameters unchanged.\n*\n*  EST    (input/output) DOUBLE PRECISION\n*         On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be\n*         unchanged from the previous call to ZLACN2.\n*         On exit, EST is an estimate (a lower bound) for norm(A). \n*\n*  KASE   (input/output) INTEGER\n*         On the initial call to ZLACN2, KASE should be 0.\n*         On an intermediate return, KASE will be 1 or 2, indicating\n*         whether X should be overwritten by A * X  or A' * X.\n*         On the final return from ZLACN2, KASE will again be 0.\n*\n*  ISAVE  (input/output) INTEGER array, dimension (3)\n*         ISAVE is used to save variables between calls to ZLACN2\n*\n\n*  Further Details\n*  ======= =======\n*\n*  Contributed by Nick Higham, University of Manchester.\n*  Originally named CONEST, dated March 16, 1988.\n*\n*  Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n*  a real or complex matrix, with applications to condition estimation\",\n*  ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n*\n*  Last modified:  April, 1999\n*\n*  This is a thread safe version of ZLACON, which uses the array ISAVE\n*  in place of a SAVE statement, as follows:\n*\n*     ZLACON     ZLACN2\n*      JUMP     ISAVE(1)\n*      J        ISAVE(2)\n*      ITER     ISAVE(3)\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, est, kase, isave = NumRu::Lapack.zlacn2( x, est, kase, isave, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_x = argv[0];
  rblapack_est = argv[1];
  rblapack_kase = argv[2];
  rblapack_isave = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (1th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  kase = NUM2INT(rblapack_kase);
  est = NUM2DBL(rblapack_est);
  if (!NA_IsNArray(rblapack_isave))
    rb_raise(rb_eArgError, "isave (4th argument) must be NArray");
  if (NA_RANK(rblapack_isave) != 1)
    rb_raise(rb_eArgError, "rank of isave (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_isave) != (3))
    rb_raise(rb_eRuntimeError, "shape 0 of isave must be %d", 3);
  if (NA_TYPE(rblapack_isave) != NA_LINT)
    rblapack_isave = na_change_type(rblapack_isave, NA_LINT);
  isave = NA_PTR_TYPE(rblapack_isave, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = 3;
    rblapack_isave_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isave_out__ = NA_PTR_TYPE(rblapack_isave_out__, integer*);
  MEMCPY(isave_out__, isave, integer, NA_TOTAL(rblapack_isave));
  rblapack_isave = rblapack_isave_out__;
  isave = isave_out__;
  v = ALLOC_N(doublecomplex, (n));

  zlacn2_(&n, v, x, &est, &kase, isave);

  free(v);
  rblapack_est = rb_float_new((double)est);
  rblapack_kase = INT2NUM(kase);
  return rb_ary_new3(4, rblapack_x, rblapack_est, rblapack_kase, rblapack_isave);
}

void
init_lapack_zlacn2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlacn2", rblapack_zlacn2, -1);
}
ruby-lapack-1.7.2/ext/sgsvj0.c0000644000175000017500000002733612502221013015746 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgsvj0_(char* jobv, integer* m, integer* n, real* a, integer* lda, real* d, real* sva, integer* mv, real* v, integer* ldv, integer* eps, integer* sfmin, real* tol, integer* nsweep, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sgsvj0(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobv;
  char jobv; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_sva;
  real *sva; 
  VALUE rblapack_mv;
  integer mv; 
  VALUE rblapack_v;
  real *v; 
  VALUE rblapack_eps;
  integer eps; 
  VALUE rblapack_sfmin;
  integer sfmin; 
  VALUE rblapack_tol;
  real tol; 
  VALUE rblapack_nsweep;
  integer nsweep; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_sva_out__;
  real *sva_out__;
  VALUE rblapack_v_out__;
  real *v_out__;
  real *work;

  integer lda;
  integer n;
  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  info, a, d, sva, v = NumRu::Lapack.sgsvj0( jobv, m, a, d, sva, mv, v, eps, sfmin, tol, nsweep, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGSVJ0 is called from SGESVJ as a pre-processor and that is its main\n*  purpose. It applies Jacobi rotations in the same way as SGESVJ does, but\n*  it does not check convergence (stopping criterion). Few tuning\n*  parameters (marked by [TP]) are available for the implementer.\n*\n*  Further Details\n*  ~~~~~~~~~~~~~~~\n*  SGSVJ0 is used just to enable SGESVJ to call a simplified version of\n*  itself to work on a submatrix of the original matrix.\n*\n*  Contributors\n*  ~~~~~~~~~~~~\n*  Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)\n*\n*  Bugs, Examples and Comments\n*  ~~~~~~~~~~~~~~~~~~~~~~~~~~~\n*  Please report all bugs and send interesting test examples and comments to\n*  drmac@math.hr. Thank you.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBV    (input) CHARACTER*1\n*          Specifies whether the output from this procedure is used\n*          to compute the matrix V:\n*          = 'V': the product of the Jacobi rotations is accumulated\n*                 by postmulyiplying the N-by-N array V.\n*                (See the description of V.)\n*          = 'A': the product of the Jacobi rotations is accumulated\n*                 by postmulyiplying the MV-by-N array V.\n*                (See the descriptions of MV and V.)\n*          = 'N': the Jacobi rotations are not accumulated.\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.\n*          M >= N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, M-by-N matrix A, such that A*diag(D) represents\n*          the input matrix.\n*          On exit,\n*          A_onexit * D_onexit represents the input matrix A*diag(D)\n*          post-multiplied by a sequence of Jacobi rotations, where the\n*          rotation threshold and the total number of sweeps are given in\n*          TOL and NSWEEP, respectively.\n*          (See the descriptions of D, TOL and NSWEEP.)\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  D       (input/workspace/output) REAL array, dimension (N)\n*          The array D accumulates the scaling factors from the fast scaled\n*          Jacobi rotations.\n*          On entry, A*diag(D) represents the input matrix.\n*          On exit, A_onexit*diag(D_onexit) represents the input matrix\n*          post-multiplied by a sequence of Jacobi rotations, where the\n*          rotation threshold and the total number of sweeps are given in\n*          TOL and NSWEEP, respectively.\n*          (See the descriptions of A, TOL and NSWEEP.)\n*\n*  SVA     (input/workspace/output) REAL array, dimension (N)\n*          On entry, SVA contains the Euclidean norms of the columns of\n*          the matrix A*diag(D).\n*          On exit, SVA contains the Euclidean norms of the columns of\n*          the matrix onexit*diag(D_onexit).\n*\n*  MV      (input) INTEGER\n*          If JOBV .EQ. 'A', then MV rows of V are post-multipled by a\n*                           sequence of Jacobi rotations.\n*          If JOBV = 'N',   then MV is not referenced.\n*\n*  V       (input/output) REAL array, dimension (LDV,N)\n*          If JOBV .EQ. 'V' then N rows of V are post-multipled by a\n*                           sequence of Jacobi rotations.\n*          If JOBV .EQ. 'A' then MV rows of V are post-multipled by a\n*                           sequence of Jacobi rotations.\n*          If JOBV = 'N',   then V is not referenced.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V,  LDV >= 1.\n*          If JOBV = 'V', LDV .GE. N.\n*          If JOBV = 'A', LDV .GE. MV.\n*\n*  EPS     (input) INTEGER\n*          EPS = SLAMCH('Epsilon')\n*\n*  SFMIN   (input) INTEGER\n*          SFMIN = SLAMCH('Safe Minimum')\n*\n*  TOL     (input) REAL\n*          TOL is the threshold for Jacobi rotations. For a pair\n*          A(:,p), A(:,q) of pivot columns, the Jacobi rotation is\n*          applied only if ABS(COS(angle(A(:,p),A(:,q)))) .GT. TOL.\n*\n*  NSWEEP  (input) INTEGER\n*          NSWEEP is the number of sweeps of Jacobi rotations to be\n*          performed.\n*\n*  WORK    (workspace) REAL array, dimension LWORK.\n*\n*  LWORK   (input) INTEGER\n*          LWORK is the dimension of WORK. LWORK .GE. M.\n*\n*  INFO    (output) INTEGER\n*          = 0 : successful exit.\n*          < 0 : if INFO = -i, then the i-th argument had an illegal value\n*\n\n*  =====================================================================\n*\n*     .. Local Parameters ..\n      REAL               ZERO, HALF, ONE, TWO\n      PARAMETER          ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0,\n     +                   TWO = 2.0E0 )\n*     ..\n*     .. Local Scalars ..\n      REAL               AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,\n     +                   BIGTHETA, CS, MXAAPQ, MXSINJ, ROOTBIG, ROOTEPS,\n     +                   ROOTSFMIN, ROOTTOL, SMALL, SN, T, TEMP1, THETA,\n     +                   THSIGN\n      INTEGER            BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1,\n     +                   ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, NBL,\n     +                   NOTROT, p, PSKIPPED, q, ROWSKIP, SWBAND\n      LOGICAL            APPLV, ROTOK, RSVEC\n*     ..\n*     .. Local Arrays ..\n      REAL               FASTR( 5 )\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, AMAX1, AMIN1, FLOAT, MIN0, SIGN, SQRT\n*     ..\n*     .. External Functions ..\n      REAL               SDOT, SNRM2\n      INTEGER            ISAMAX\n      LOGICAL            LSAME\n      EXTERNAL           ISAMAX, LSAME, SDOT, SNRM2\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SAXPY, SCOPY, SLASCL, SLASSQ, SROTM, SSWAP\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a, d, sva, v = NumRu::Lapack.sgsvj0( jobv, m, a, d, sva, mv, v, eps, sfmin, tol, nsweep, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 11 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
  rblapack_jobv = argv[0];
  rblapack_m = argv[1];
  rblapack_a = argv[2];
  rblapack_d = argv[3];
  rblapack_sva = argv[4];
  rblapack_mv = argv[5];
  rblapack_v = argv[6];
  rblapack_eps = argv[7];
  rblapack_sfmin = argv[8];
  rblapack_tol = argv[9];
  rblapack_nsweep = argv[10];
  if (argc == 12) {
    rblapack_lwork = argv[11];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  jobv = StringValueCStr(rblapack_jobv)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_sva))
    rb_raise(rb_eArgError, "sva (5th argument) must be NArray");
  if (NA_RANK(rblapack_sva) != 1)
    rb_raise(rb_eArgError, "rank of sva (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_sva) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of sva must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_sva) != NA_SFLOAT)
    rblapack_sva = na_change_type(rblapack_sva, NA_SFLOAT);
  sva = NA_PTR_TYPE(rblapack_sva, real*);
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (7th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  if (NA_SHAPE1(rblapack_v) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of v must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_v) != NA_SFLOAT)
    rblapack_v = na_change_type(rblapack_v, NA_SFLOAT);
  v = NA_PTR_TYPE(rblapack_v, real*);
  sfmin = NUM2INT(rblapack_sfmin);
  nsweep = NUM2INT(rblapack_nsweep);
  m = NUM2INT(rblapack_m);
  mv = NUM2INT(rblapack_mv);
  tol = (real)NUM2DBL(rblapack_tol);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  lwork = m;
  eps = NUM2INT(rblapack_eps);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_sva_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  sva_out__ = NA_PTR_TYPE(rblapack_sva_out__, real*);
  MEMCPY(sva_out__, sva, real, NA_TOTAL(rblapack_sva));
  rblapack_sva = rblapack_sva_out__;
  sva = sva_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = n;
    rblapack_v_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  v_out__ = NA_PTR_TYPE(rblapack_v_out__, real*);
  MEMCPY(v_out__, v, real, NA_TOTAL(rblapack_v));
  rblapack_v = rblapack_v_out__;
  v = v_out__;
  work = ALLOC_N(real, (lwork));

  sgsvj0_(&jobv, &m, &n, a, &lda, d, sva, &mv, v, &ldv, &eps, &sfmin, &tol, &nsweep, work, &lwork, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_info, rblapack_a, rblapack_d, rblapack_sva, rblapack_v);
}

void
init_lapack_sgsvj0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgsvj0", rblapack_sgsvj0, -1);
}
ruby-lapack-1.7.2/ext/cungql.c0000644000175000017500000001251112502221023016011 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cungql_(integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_cungql(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;

  integer lda;
  integer n;
  integer k;

  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 = NumRu::Lapack.cungql( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CUNGQL generates an M-by-N complex matrix Q with orthonormal columns,\n*  which is defined as the last N columns of a product of K elementary\n*  reflectors of order M\n*\n*        Q  =  H(k) . . . H(2) H(1)\n*\n*  as returned by CGEQLF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. M >= N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. N >= K >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the (n-k+i)-th column must contain the vector which\n*          defines the elementary reflector H(i), for i = 1,2,...,k, as\n*          returned by CGEQLF in the last k columns of its array\n*          argument A.\n*          On exit, the M-by-N matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) COMPLEX array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by CGEQLF.\n*\n*  WORK    (workspace/output) COMPLEX 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,N).\n*          For optimum performance LWORK >= N*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 has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, a = NumRu::Lapack.cungql( m, a, tau, [: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_m = argv[0];
  rblapack_a = argv[1];
  rblapack_tau = 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;
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  cungql_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_cungql(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cungql", rblapack_cungql, -1);
}
ruby-lapack-1.7.2/ext/slarnv.c0000644000175000017500000000725112502221024016033 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slarnv_(integer* idist, integer* iseed, integer* n, real* x);


static VALUE
rblapack_slarnv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_idist;
  integer idist; 
  VALUE rblapack_iseed;
  integer *iseed; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_iseed_out__;
  integer *iseed_out__;


  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  x, iseed = NumRu::Lapack.slarnv( idist, iseed, n, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLARNV( IDIST, ISEED, N, X )\n\n*  Purpose\n*  =======\n*\n*  SLARNV returns a vector of n random real numbers from a uniform or\n*  normal distribution.\n*\n\n*  Arguments\n*  =========\n*\n*  IDIST   (input) INTEGER\n*          Specifies the distribution of the random numbers:\n*          = 1:  uniform (0,1)\n*          = 2:  uniform (-1,1)\n*          = 3:  normal (0,1)\n*\n*  ISEED   (input/output) INTEGER array, dimension (4)\n*          On entry, the seed of the random number generator; the array\n*          elements must be between 0 and 4095, and ISEED(4) must be\n*          odd.\n*          On exit, the seed is updated.\n*\n*  N       (input) INTEGER\n*          The number of random numbers to be generated.\n*\n*  X       (output) REAL array, dimension (N)\n*          The generated random numbers.\n*\n\n*  Further Details\n*  ===============\n*\n*  This routine calls the auxiliary routine SLARUV to generate random\n*  real numbers from a uniform (0,1) distribution, in batches of up to\n*  128 using vectorisable code. The Box-Muller method is used to\n*  transform numbers from a uniform to a normal distribution.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, iseed = NumRu::Lapack.slarnv( idist, iseed, n, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_idist = argv[0];
  rblapack_iseed = argv[1];
  rblapack_n = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  idist = NUM2INT(rblapack_idist);
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_iseed))
    rb_raise(rb_eArgError, "iseed (2th argument) must be NArray");
  if (NA_RANK(rblapack_iseed) != 1)
    rb_raise(rb_eArgError, "rank of iseed (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_iseed) != (4))
    rb_raise(rb_eRuntimeError, "shape 0 of iseed must be %d", 4);
  if (NA_TYPE(rblapack_iseed) != NA_LINT)
    rblapack_iseed = na_change_type(rblapack_iseed, NA_LINT);
  iseed = NA_PTR_TYPE(rblapack_iseed, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,n);
    rblapack_x = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[1];
    shape[0] = 4;
    rblapack_iseed_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iseed_out__ = NA_PTR_TYPE(rblapack_iseed_out__, integer*);
  MEMCPY(iseed_out__, iseed, integer, NA_TOTAL(rblapack_iseed));
  rblapack_iseed = rblapack_iseed_out__;
  iseed = iseed_out__;

  slarnv_(&idist, iseed, &n, x);

  return rb_ary_new3(2, rblapack_x, rblapack_iseed);
}

void
init_lapack_slarnv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slarnv", rblapack_slarnv, -1);
}
ruby-lapack-1.7.2/ext/zgehd2.c0000644000175000017500000001307312502221013015706 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgehd2_(integer* n, integer* ilo, integer* ihi, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* info);


static VALUE
rblapack_zgehd2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  doublecomplex *work;

  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, info, a = NumRu::Lapack.zgehd2( ilo, ihi, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGEHD2 reduces a complex general matrix A to upper Hessenberg form H\n*  by a unitary similarity transformation:  Q' * A * Q = H .\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          It is assumed that A is already upper triangular in rows\n*          and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n*          set by a previous call to ZGEBAL; otherwise they should be\n*          set to 1 and N respectively. See Further Details.\n*          1 <= ILO <= IHI <= max(1,N).\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the n by n general matrix to be reduced.\n*          On exit, the upper triangle and the first subdiagonal of A\n*          are overwritten with the upper Hessenberg matrix H, and the\n*          elements below the first subdiagonal, with the array TAU,\n*          represent the unitary matrix Q as a product of elementary\n*          reflectors. See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  TAU     (output) COMPLEX*16 array, dimension (N-1)\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (N)\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 (ihi-ilo) elementary\n*  reflectors\n*\n*     Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - tau * v * v'\n*\n*  where tau is a complex scalar, and v is a complex vector with\n*  v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n*  exit in A(i+2:ihi,i), and tau in TAU(i).\n*\n*  The contents of A are illustrated by the following example, with\n*  n = 7, ilo = 2 and ihi = 6:\n*\n*  on entry,                        on exit,\n*\n*  ( a   a   a   a   a   a   a )    (  a   a   h   h   h   h   a )\n*  (     a   a   a   a   a   a )    (      a   h   h   h   h   a )\n*  (     a   a   a   a   a   a )    (      h   h   h   h   h   h )\n*  (     a   a   a   a   a   a )    (      v2  h   h   h   h   h )\n*  (     a   a   a   a   a   a )    (      v2  v3  h   h   h   h )\n*  (     a   a   a   a   a   a )    (      v2  v3  v4  h   h   h )\n*  (                         a )    (                          a )\n*\n*  where a denotes an element of the original matrix A, h denotes a\n*  modified element of the upper Hessenberg matrix H, and vi denotes an\n*  element of the vector defining H(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.zgehd2( ilo, ihi, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_ilo = argv[0];
  rblapack_ihi = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  ihi = NUM2INT(rblapack_ihi);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(doublecomplex, (n));

  zgehd2_(&n, &ilo, &ihi, 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_zgehd2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgehd2", rblapack_zgehd2, -1);
}
ruby-lapack-1.7.2/ext/csytrf.c0000644000175000017500000002014212502221013016030 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID csytrf_(char* uplo, integer* n, complex* a, integer* lda, integer* ipiv, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_csytrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *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  ipiv, work, info, a = NumRu::Lapack.csytrf( uplo, a, lwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CSYTRF computes the factorization of a complex symmetric matrix A\n*  using the Bunch-Kaufman diagonal pivoting method.  The form of the\n*  factorization is\n*\n*     A = U*D*U**T  or  A = L*D*L**T\n*\n*  where U (or L) is a product of permutation and unit upper (lower)\n*  triangular matrices, and D is symmetric and block diagonal with\n*  with 1-by-1 and 2-by-2 diagonal blocks.\n*\n*  This is the blocked version of the algorithm, calling Level 3 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L (see below for further details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D.\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*  WORK    (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of WORK.  LWORK >=1.  For best performance\n*          LWORK >= N*NB, where NB is the block size returned by ILAENV.\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, D(i,i) is exactly zero.  The factorization\n*                has been completed, but the block diagonal matrix D is\n*                exactly singular, and division by zero will occur if it\n*                is used to solve a system of equations.\n*\n\n*  Further Details\n*  ===============\n*\n*  If UPLO = 'U', then A = U*D*U', where\n*     U = P(n)*U(n)* ... *P(k)U(k)* ...,\n*  i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n*  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    v    0   )   k-s\n*     U(k) =  (   0    I    0   )   s\n*             (   0    0    I   )   n-k\n*                k-s   s   n-k\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n*  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n*  and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n*  If UPLO = 'L', then A = L*D*L', where\n*     L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n*  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n*  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    0     0   )  k-1\n*     L(k) =  (   0    I     0   )  s\n*             (   0    v     I   )  n-k-s+1\n*                k-1   s  n-k-s+1\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n*  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n*  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY, UPPER\n      INTEGER            IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            ILAENV\n      EXTERNAL           LSAME, ILAENV\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CLASYF, CSYTF2, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, work, info, a = NumRu::Lapack.csytrf( uplo, a, lwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_lwork = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  lwork = NUM2INT(rblapack_lwork);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  csytrf_(&uplo, &n, a, &lda, ipiv, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ipiv, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_csytrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "csytrf", rblapack_csytrf, -1);
}
ruby-lapack-1.7.2/ext/zlarcm.c0000644000175000017500000000753212502221026016022 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlarcm_(integer* m, integer* n, doublereal* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* c, integer* ldc, doublereal* rwork);


static VALUE
rblapack_zlarcm(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_c;
  doublecomplex *c; 
  doublereal *rwork;

  integer lda;
  integer m;
  integer ldb;
  integer n;
  integer ldc;

  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  c = NumRu::Lapack.zlarcm( a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLARCM( M, N, A, LDA, B, LDB, C, LDC, RWORK )\n\n*  Purpose\n*  =======\n*\n*  ZLARCM performs a very simple matrix-matrix multiplication:\n*           C := A * B,\n*  where A is M by M and real; B is M by N and complex;\n*  C is M by N and complex.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A and of the matrix C.\n*          M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns and rows of the matrix B and\n*          the number of columns of the matrix C.\n*          N >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA, M)\n*          A contains the M by M matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >=max(1,M).\n*\n*  B       (input) DOUBLE PRECISION array, dimension (LDB, N)\n*          B contains the M by N matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >=max(1,M).\n*\n*  C       (input) COMPLEX*16 array, dimension (LDC, N)\n*          C contains the M by N matrix C.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >=max(1,M).\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (2*M*N)\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.zlarcm( a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  if (argc == 2) {
  } 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);
  m = 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*);
  ldc = MAX(1,m);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
  rwork = ALLOC_N(doublereal, (2*m*n));

  zlarcm_(&m, &n, a, &lda, b, &ldb, c, &ldc, rwork);

  free(rwork);
  return rblapack_c;
}

void
init_lapack_zlarcm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlarcm", rblapack_zlarcm, -1);
}
ruby-lapack-1.7.2/ext/ztgex2.c0000644000175000017500000002270212502221024015747 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztgex2_(logical* wantq, logical* wantz, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* q, integer* ldq, doublecomplex* z, integer* ldz, integer* j1, integer* info);


static VALUE
rblapack_ztgex2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantq;
  logical wantq; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_q;
  doublecomplex *q; 
  VALUE rblapack_ldq;
  integer ldq; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_ldz;
  integer ldz; 
  VALUE rblapack_j1;
  integer j1; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  VALUE rblapack_q_out__;
  doublecomplex *q_out__;
  VALUE rblapack_z_out__;
  doublecomplex *z_out__;

  integer lda;
  integer n;
  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  info, a, b, q, z = NumRu::Lapack.ztgex2( wantq, wantz, a, b, q, ldq, z, ldz, j1, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, J1, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTGEX2 swaps adjacent diagonal 1 by 1 blocks (A11,B11) and (A22,B22)\n*  in an upper triangular matrix pair (A, B) by an unitary equivalence\n*  transformation.\n*\n*  (A, B) must be in generalized Schur canonical form, that is, A and\n*  B are both upper triangular.\n*\n*  Optionally, the matrices Q and Z of generalized Schur vectors are\n*  updated.\n*\n*         Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n*         Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n*\n*\n\n*  Arguments\n*  =========\n*\n*  WANTQ   (input) LOGICAL\n*          .TRUE. : update the left transformation matrix Q;\n*          .FALSE.: do not update Q.\n*\n*  WANTZ   (input) LOGICAL\n*          .TRUE. : update the right transformation matrix Z;\n*          .FALSE.: do not update Z.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B. N >= 0.\n*\n*  A       (input/output) COMPLEX*16 arrays, dimensions (LDA,N)\n*          On entry, the matrix A in the pair (A, B).\n*          On exit, the updated matrix A.\n*\n*  LDA     (input)  INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX*16 arrays, dimensions (LDB,N)\n*          On entry, the matrix B in the pair (A, B).\n*          On exit, the updated matrix B.\n*\n*  LDB     (input)  INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  Q       (input/output) COMPLEX*16 array, dimension (LDZ,N)\n*          If WANTQ = .TRUE, on entry, the unitary matrix Q. On exit,\n*          the updated matrix Q.\n*          Not referenced if WANTQ = .FALSE..\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q. LDQ >= 1;\n*          If WANTQ = .TRUE., LDQ >= N.\n*\n*  Z       (input/output) COMPLEX*16 array, dimension (LDZ,N)\n*          If WANTZ = .TRUE, on entry, the unitary matrix Z. On exit,\n*          the updated matrix Z.\n*          Not referenced if WANTZ = .FALSE..\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z. LDZ >= 1;\n*          If WANTZ = .TRUE., LDZ >= N.\n*\n*  J1      (input) INTEGER\n*          The index to the first block (A11, B11).\n*\n*  INFO    (output) INTEGER\n*           =0:  Successful exit.\n*           =1:  The transformed matrix pair (A, B) would be too far\n*                from generalized Schur form; the problem is ill-\n*                conditioned. \n*\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  In the current code both weak and strong stability tests are\n*  performed. The user can omit the strong stability test by changing\n*  the internal logical parameter WANDS to .FALSE.. See ref. [2] for\n*  details.\n*\n*  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n*      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n*      M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n*      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n*  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n*      Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n*      Estimation: Theory, Algorithms and Software, Report UMINF-94.04,\n*      Department of Computing Science, Umea University, S-901 87 Umea,\n*      Sweden, 1994. Also as LAPACK Working Note 87. To appear in\n*      Numerical Algorithms, 1996.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a, b, q, z = NumRu::Lapack.ztgex2( wantq, wantz, a, b, q, ldq, z, ldz, j1, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_wantq = argv[0];
  rblapack_wantz = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  rblapack_q = argv[4];
  rblapack_ldq = argv[5];
  rblapack_z = argv[6];
  rblapack_ldz = argv[7];
  rblapack_j1 = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  wantq = (rblapack_wantq == Qtrue);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  ldq = NUM2INT(rblapack_ldq);
  ldz = NUM2INT(rblapack_ldz);
  wantz = (rblapack_wantz == Qtrue);
  j1 = NUM2INT(rblapack_j1);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (7th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_z) != (wantq ? ldz : 0))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantq ? ldz : 0);
  if (NA_SHAPE1(rblapack_z) != (wantq ? n : 0))
    rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantq ? n : 0);
  if (NA_TYPE(rblapack_z) != NA_DCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (5th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_q) != (wantq ? ldq : 0))
    rb_raise(rb_eRuntimeError, "shape 0 of q must be %d", wantq ? ldq : 0);
  if (NA_SHAPE1(rblapack_q) != (wantq ? n : 0))
    rb_raise(rb_eRuntimeError, "shape 1 of q must be %d", wantq ? n : 0);
  if (NA_TYPE(rblapack_q) != NA_DCOMPLEX)
    rblapack_q = na_change_type(rblapack_q, NA_DCOMPLEX);
  q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[2];
    shape[0] = wantq ? ldq : 0;
    shape[1] = wantq ? n : 0;
    rblapack_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublecomplex*);
  MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  {
    na_shape_t shape[2];
    shape[0] = wantq ? ldz : 0;
    shape[1] = wantq ? n : 0;
    rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublecomplex*);
  MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  ztgex2_(&wantq, &wantz, &n, a, &lda, b, &ldb, q, &ldq, z, &ldz, &j1, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z);
}

void
init_lapack_ztgex2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztgex2", rblapack_ztgex2, -1);
}
ruby-lapack-1.7.2/ext/dopgtr.c0000644000175000017500000001036212502221022016020 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dopgtr_(char* uplo, integer* n, doublereal* ap, doublereal* tau, doublereal* q, integer* ldq, doublereal* work, integer* info);


static VALUE
rblapack_dopgtr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_q;
  doublereal *q; 
  VALUE rblapack_info;
  integer info; 
  doublereal *work;

  integer ldap;
  integer ldtau;
  integer ldq;
  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  q, info = NumRu::Lapack.dopgtr( uplo, ap, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DOPGTR generates a real orthogonal matrix Q which is defined as the\n*  product of n-1 elementary reflectors H(i) of order n, as returned by\n*  DSPTRD using packed storage:\n*\n*  if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),\n*\n*  if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U': Upper triangular packed storage used in previous\n*                 call to DSPTRD;\n*          = 'L': Lower triangular packed storage used in previous\n*                 call to DSPTRD.\n*\n*  N       (input) INTEGER\n*          The order of the matrix Q. N >= 0.\n*\n*  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          The vectors which define the elementary reflectors, as\n*          returned by DSPTRD.\n*\n*  TAU     (input) DOUBLE PRECISION array, dimension (N-1)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by DSPTRD.\n*\n*  Q       (output) DOUBLE PRECISION array, dimension (LDQ,N)\n*          The N-by-N orthogonal matrix Q.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q. LDQ >= max(1,N).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (N-1)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  q, info = NumRu::Lapack.dopgtr( uplo, ap, tau, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_tau = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  ldtau = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  n = ldtau+1;
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  ldq = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  q = NA_PTR_TYPE(rblapack_q, doublereal*);
  work = ALLOC_N(doublereal, (n-1));

  dopgtr_(&uplo, &n, ap, tau, q, &ldq, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_q, rblapack_info);
}

void
init_lapack_dopgtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dopgtr", rblapack_dopgtr, -1);
}
ruby-lapack-1.7.2/ext/dlarrr.c0000644000175000017500000000761112502221021016011 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlarrr_(integer* n, doublereal* d, doublereal* e, integer* info);


static VALUE
rblapack_dlarrr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_e_out__;
  doublereal *e_out__;

  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  info, e = NumRu::Lapack.dlarrr( d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLARRR( N, D, E, INFO )\n\n*  Purpose\n*  =======\n*\n*  Perform tests to decide whether the symmetric tridiagonal matrix T\n*  warrants expensive computations which guarantee high relative accuracy\n*  in the eigenvalues.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix. N > 0.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          The N diagonal elements of the tridiagonal matrix T.\n*\n*  E       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the first (N-1) entries contain the subdiagonal\n*          elements of the tridiagonal matrix T; E(N) is set to ZERO.\n*\n*  INFO    (output) INTEGER\n*          INFO = 0(default) : the matrix warrants computations preserving\n*                              relative accuracy.\n*          INFO = 1          : the matrix warrants computations guaranteeing\n*                              only absolute accuracy.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Beresford Parlett, University of California, Berkeley, USA\n*     Jim Demmel, University of California, Berkeley, USA\n*     Inderjit Dhillon, University of Texas, Austin, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, e = NumRu::Lapack.dlarrr( d, e, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_d = argv[0];
  rblapack_e = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (2th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
  MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;

  dlarrr_(&n, d, e, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_e);
}

void
init_lapack_dlarrr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlarrr", rblapack_dlarrr, -1);
}
ruby-lapack-1.7.2/ext/dgejsv.c0000644000175000017500000022153312502221016016012 0ustar  uwabamiuwabami#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;
  }

  joba = StringValueCStr(rblapack_joba)[0];
  jobv = StringValueCStr(rblapack_jobv)[0];
  jobt = StringValueCStr(rblapack_jobt)[0];
  m = NUM2INT(rblapack_m);
  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*);
  jobu = StringValueCStr(rblapack_jobu)[0];
  jobp = StringValueCStr(rblapack_jobp)[0];
  ldu = (lsame_(&jobu,"U")||lsame_(&jobu,"F")||lsame_(&jobu,"W")) ? m : 1;
  jobr = StringValueCStr(rblapack_jobr)[0];
  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*);
  ldv = (lsame_(&jobu,"U")||lsame_(&jobu,"F")||lsame_(&jobu,"W")) ? n : 1;
  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);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_sva = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  sva = NA_PTR_TYPE(rblapack_sva, doublereal*);
  {
    na_shape_t 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*);
  {
    na_shape_t 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*);
  {
    na_shape_t shape[1];
    shape[0] = m+3*n;
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t 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, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgejsv", rblapack_dgejsv, -1);
}
ruby-lapack-1.7.2/ext/dsgesv.c0000644000175000017500000002016712502221026016024 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsgesv_(integer* n, integer* nrhs, doublereal* a, integer* lda, integer* ipiv, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* work, real* swork, integer* iter, integer* info);


static VALUE
rblapack_dsgesv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_iter;
  integer iter; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  doublereal *work;
  real *swork;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ipiv, x, iter, info, a = NumRu::Lapack.dsgesv( a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSGESV( N, NRHS, A, LDA, IPIV, B, LDB, X, LDX, WORK, SWORK, ITER, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSGESV computes the solution to a real system of linear equations\n*     A * X = B,\n*  where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n*  DSGESV first attempts to factorize the matrix in SINGLE PRECISION\n*  and use this factorization within an iterative refinement procedure\n*  to produce a solution with DOUBLE PRECISION normwise backward error\n*  quality (see below). If the approach fails the method switches to a\n*  DOUBLE PRECISION factorization and solve.\n*\n*  The iterative refinement is not going to be a winning strategy if\n*  the ratio SINGLE PRECISION performance over DOUBLE PRECISION\n*  performance is too small. A reasonable strategy should take the\n*  number of right-hand sides and the size of the matrix into account.\n*  This might be done with a call to ILAENV in the future. Up to now, we\n*  always try iterative refinement.\n*\n*  The iterative refinement process is stopped if\n*      ITER > ITERMAX\n*  or for all the RHS we have:\n*      RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX\n*  where\n*      o ITER is the number of the current iteration in the iterative\n*        refinement process\n*      o RNRM is the infinity-norm of the residual\n*      o XNRM is the infinity-norm of the solution\n*      o ANRM is the infinity-operator-norm of the matrix A\n*      o EPS is the machine epsilon returned by DLAMCH('Epsilon')\n*  The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00\n*  respectively.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array,\n*          dimension (LDA,N)\n*          On entry, the N-by-N coefficient matrix A.\n*          On exit, if iterative refinement has been successfully used\n*          (INFO.EQ.0 and ITER.GE.0, see description below), then A is\n*          unchanged, if double precision factorization has been used\n*          (INFO.EQ.0 and ITER.LT.0, see description below), then the\n*          array A contains the factors L and U from the factorization\n*          A = P*L*U; the unit diagonal elements of L are not stored.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          The pivot indices that define the permutation matrix P;\n*          row i of the matrix was interchanged with row IPIV(i).\n*          Corresponds either to the single precision factorization\n*          (if INFO.EQ.0 and ITER.GE.0) or the double precision\n*          factorization (if INFO.EQ.0 and ITER.LT.0).\n*\n*  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          The N-by-NRHS right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*          If INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (N,NRHS)\n*          This array is used to hold the residual vectors.\n*\n*  SWORK   (workspace) REAL array, dimension (N*(N+NRHS))\n*          This array is used to use the single precision matrix and the\n*          right-hand sides or solutions in single precision.\n*\n*  ITER    (output) INTEGER\n*          < 0: iterative refinement has failed, double precision\n*               factorization has been performed\n*               -1 : the routine fell back to full precision for\n*                    implementation- or machine-specific reasons\n*               -2 : narrowing the precision induced an overflow,\n*                    the routine fell back to full precision\n*               -3 : failure of SGETRF\n*               -31: stop the iterative refinement after the 30th\n*                    iterations\n*          > 0: iterative refinement has been sucessfully used.\n*               Returns the number of iterations\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, U(i,i) computed in DOUBLE PRECISION is\n*                exactly zero.  The factorization has been completed,\n*                but the factor U is exactly singular, so the solution\n*                could not be computed.\n*\n*  =========\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, x, iter, info, a = NumRu::Lapack.dsgesv( a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  if (argc == 2) {
  } 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*);
  ldx = MAX(1,n);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t 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, (n)*(nrhs));
  swork = ALLOC_N(real, (n*(n+nrhs)));

  dsgesv_(&n, &nrhs, a, &lda, ipiv, b, &ldb, x, &ldx, work, swork, &iter, &info);

  free(work);
  free(swork);
  rblapack_iter = INT2NUM(iter);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_ipiv, rblapack_x, rblapack_iter, rblapack_info, rblapack_a);
}

void
init_lapack_dsgesv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsgesv", rblapack_dsgesv, -1);
}
ruby-lapack-1.7.2/ext/cspcon.c0000644000175000017500000001076112502221026016015 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cspcon_(char* uplo, integer* n, complex* ap, integer* ipiv, real* anorm, real* rcond, complex* work, integer* info);


static VALUE
rblapack_cspcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_anorm;
  real anorm; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_info;
  integer info; 
  complex *work;

  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  rcond, info = NumRu::Lapack.cspcon( uplo, ap, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CSPCON estimates the reciprocal of the condition number (in the\n*  1-norm) of a complex symmetric packed matrix A using the\n*  factorization A = U*D*U**T or A = L*D*L**T computed by CSPTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by CSPTRF, stored as a\n*          packed triangular matrix.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by CSPTRF.\n*\n*  ANORM   (input) REAL\n*          The 1-norm of the original matrix A.\n*\n*  RCOND   (output) REAL\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n*          estimate of the 1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.cspcon( uplo, ap, ipiv, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_anorm = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  anorm = (real)NUM2DBL(rblapack_anorm);
  work = ALLOC_N(complex, (2*n));

  cspcon_(&uplo, &n, ap, ipiv, &anorm, &rcond, work, &info);

  free(work);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_cspcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cspcon", rblapack_cspcon, -1);
}
ruby-lapack-1.7.2/ext/zheev.c0000644000175000017500000001356212502221025015652 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zheev_(char* jobz, char* uplo, integer* n, doublecomplex* a, integer* lda, doublereal* w, doublecomplex* work, integer* lwork, doublereal* rwork, integer* info);


static VALUE
rblapack_zheev(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  doublereal *rwork;

  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  w, work, info, a = NumRu::Lapack.zheev( jobz, uplo, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHEEV computes all eigenvalues and, optionally, eigenvectors of a\n*  complex Hermitian matrix A.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA, N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of A contains the\n*          upper triangular part of the matrix A.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of A contains\n*          the lower triangular part of the matrix A.\n*          On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n*          orthonormal eigenvectors of the matrix A.\n*          If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n*          or the upper triangle (if UPLO='U') of A, including the\n*          diagonal, is destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of the array WORK.  LWORK >= max(1,2*N-1).\n*          For optimal efficiency, LWORK >= (NB+1)*N,\n*          where NB is the blocksize for ZHETRD returned by ILAENV.\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*  RWORK   (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2))\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 algorithm failed to converge; i\n*                off-diagonal elements of an intermediate tridiagonal\n*                form did not converge to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, work, info, a = NumRu::Lapack.zheev( jobz, uplo, a, [: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_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = 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;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (rblapack_lwork == Qnil)
    lwork = 2*n-1;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  rwork = ALLOC_N(doublereal, (MAX(1, 3*n-2)));

  zheev_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, rwork, &info);

  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_w, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_zheev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zheev", rblapack_zheev, -1);
}
ruby-lapack-1.7.2/ext/slaed9.c0000644000175000017500000001435512502221024015712 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaed9_(integer* k, integer* kstart, integer* kstop, integer* n, real* d, real* q, integer* ldq, real* rho, real* dlamda, real* w, real* s, integer* lds, integer* info);


static VALUE
rblapack_slaed9(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_kstart;
  integer kstart; 
  VALUE rblapack_kstop;
  integer kstop; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_rho;
  real rho; 
  VALUE rblapack_dlamda;
  real *dlamda; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_info;
  integer info; 
  real *q;

  integer k;
  integer lds;
  integer ldq;

  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  d, s, info = NumRu::Lapack.slaed9( kstart, kstop, n, rho, dlamda, w, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W, S, LDS, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLAED9 finds the roots of the secular equation, as defined by the\n*  values in D, Z, and RHO, between KSTART and KSTOP.  It makes the\n*  appropriate calls to SLAED4 and then stores the new matrix of\n*  eigenvectors for use in calculating the next level of Z vectors.\n*\n\n*  Arguments\n*  =========\n*\n*  K       (input) INTEGER\n*          The number of terms in the rational function to be solved by\n*          SLAED4.  K >= 0.\n*\n*  KSTART  (input) INTEGER\n*  KSTOP   (input) INTEGER\n*          The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP\n*          are to be computed.  1 <= KSTART <= KSTOP <= K.\n*\n*  N       (input) INTEGER\n*          The number of rows and columns in the Q matrix.\n*          N >= K (delation may result in N > K).\n*\n*  D       (output) REAL array, dimension (N)\n*          D(I) contains the updated eigenvalues\n*          for KSTART <= I <= KSTOP.\n*\n*  Q       (workspace) REAL array, dimension (LDQ,N)\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.  LDQ >= max( 1, N ).\n*\n*  RHO     (input) REAL\n*          The value of the parameter in the rank one update equation.\n*          RHO >= 0 required.\n*\n*  DLAMDA  (input) REAL array, dimension (K)\n*          The first K elements of this array contain the old roots\n*          of the deflated updating problem.  These are the poles\n*          of the secular equation.\n*\n*  W       (input) REAL array, dimension (K)\n*          The first K elements of this array contain the components\n*          of the deflation-adjusted updating vector.\n*\n*  S       (output) REAL array, dimension (LDS, K)\n*          Will contain the eigenvectors of the repaired matrix which\n*          will be stored for subsequent Z vector calculation and\n*          multiplied by the previously accumulated eigenvectors\n*          to update the system.\n*\n*  LDS     (input) INTEGER\n*          The leading dimension of S.  LDS >= max( 1, K ).\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 = 1, an eigenvalue did not converge\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Jeff Rutter, Computer Science Division, University of California\n*     at Berkeley, USA\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n      REAL               TEMP\n*     ..\n*     .. External Functions ..\n      REAL               SLAMC3, SNRM2\n      EXTERNAL           SLAMC3, SNRM2\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SCOPY, SLAED4, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, SIGN, SQRT\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, s, info = NumRu::Lapack.slaed9( kstart, kstop, n, rho, dlamda, w, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_kstart = argv[0];
  rblapack_kstop = argv[1];
  rblapack_n = argv[2];
  rblapack_rho = argv[3];
  rblapack_dlamda = argv[4];
  rblapack_w = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  kstart = NUM2INT(rblapack_kstart);
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_dlamda))
    rb_raise(rb_eArgError, "dlamda (5th argument) must be NArray");
  if (NA_RANK(rblapack_dlamda) != 1)
    rb_raise(rb_eArgError, "rank of dlamda (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_dlamda);
  if (NA_TYPE(rblapack_dlamda) != NA_SFLOAT)
    rblapack_dlamda = na_change_type(rblapack_dlamda, NA_SFLOAT);
  dlamda = NA_PTR_TYPE(rblapack_dlamda, real*);
  ldq = MAX( 1, n );
  kstop = NUM2INT(rblapack_kstop);
  if (!NA_IsNArray(rblapack_w))
    rb_raise(rb_eArgError, "w (6th argument) must be NArray");
  if (NA_RANK(rblapack_w) != 1)
    rb_raise(rb_eArgError, "rank of w (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_w) != k)
    rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of dlamda");
  if (NA_TYPE(rblapack_w) != NA_SFLOAT)
    rblapack_w = na_change_type(rblapack_w, NA_SFLOAT);
  w = NA_PTR_TYPE(rblapack_w, real*);
  rho = (real)NUM2DBL(rblapack_rho);
  lds = MAX( 1, k );
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,n);
    rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, real*);
  {
    na_shape_t shape[2];
    shape[0] = lds;
    shape[1] = k;
    rblapack_s = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, real*);
  q = ALLOC_N(real, (ldq)*(MAX(1,n)));

  slaed9_(&k, &kstart, &kstop, &n, d, q, &ldq, &rho, dlamda, w, s, &lds, &info);

  free(q);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_d, rblapack_s, rblapack_info);
}

void
init_lapack_slaed9(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaed9", rblapack_slaed9, -1);
}
ruby-lapack-1.7.2/ext/stzrzf.c0000644000175000017500000001402012502221023016057 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID stzrzf_(integer* m, integer* n, real* a, integer* lda, real* tau, real* work, integer* lwork, integer* info);


static VALUE
rblapack_stzrzf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;

  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, work, info, a = NumRu::Lapack.stzrzf( a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  STZRZF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A\n*  to upper triangular form by means of orthogonal transformations.\n*\n*  The upper trapezoidal matrix A is factored as\n*\n*     A = ( R  0 ) * Z,\n*\n*  where Z is an N-by-N orthogonal matrix and R is an M-by-M upper\n*  triangular matrix.\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 >= M.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the leading M-by-N upper trapezoidal part of the\n*          array A must contain the matrix to be factorized.\n*          On exit, the leading M-by-M upper triangular part of A\n*          contains the upper triangular matrix R, and elements M+1 to\n*          N of the first M rows of A, with the array TAU, represent the\n*          orthogonal matrix Z as a product of M elementary reflectors.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  TAU     (output) REAL array, dimension (M)\n*          The scalar factors of the elementary reflectors.\n*\n*  WORK    (workspace/output) REAL 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\n*          the 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*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n*  The factorization is obtained by Householder's method.  The kth\n*  transformation matrix, Z( k ), which is used to introduce zeros into\n*  the ( m - k + 1 )th row of A, is given in the form\n*\n*     Z( k ) = ( I     0   ),\n*              ( 0  T( k ) )\n*\n*  where\n*\n*     T( k ) = I - tau*u( k )*u( k )',   u( k ) = (   1    ),\n*                                                 (   0    )\n*                                                 ( z( k ) )\n*\n*  tau is a scalar and z( k ) is an ( n - m ) element vector.\n*  tau and z( k ) are chosen to annihilate the elements of the kth row\n*  of X.\n*\n*  The scalar tau is returned in the kth element of TAU and the vector\n*  u( k ) in the kth row of A, such that the elements of z( k ) are\n*  in  a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n*  the upper triangular part of A.\n*\n*  Z is given by\n*\n*     Z =  Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, work, info, a = NumRu::Lapack.stzrzf( a, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 1 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
  rblapack_a = argv[0];
  if (argc == 2) {
    rblapack_lwork = argv[1];
  } 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 (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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  m = lda;
  if (rblapack_lwork == Qnil)
    lwork = m;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  stzrzf_(&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_stzrzf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "stzrzf", rblapack_stzrzf, -1);
}
ruby-lapack-1.7.2/ext/dorghr.c0000644000175000017500000001276512502221022016017 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dorghr_(integer* n, integer* ilo, integer* ihi, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dorghr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_lwork;
  integer lwork; 
  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  work, info, a = NumRu::Lapack.dorghr( ilo, ihi, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DORGHR generates a real orthogonal matrix Q which is defined as the\n*  product of IHI-ILO elementary reflectors of order N, as returned by\n*  DGEHRD:\n*\n*  Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix Q. N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          ILO and IHI must have the same values as in the previous call\n*          of DGEHRD. Q is equal to the unit matrix except in the\n*          submatrix Q(ilo+1:ihi,ilo+1:ihi).\n*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the vectors which define the elementary reflectors,\n*          as returned by DGEHRD.\n*          On exit, the N-by-N orthogonal matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  TAU     (input) DOUBLE PRECISION array, dimension (N-1)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by DGEHRD.\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 >= IHI-ILO.\n*          For optimum performance LWORK >= (IHI-ILO)*NB, where NB is\n*          the 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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, a = NumRu::Lapack.dorghr( ilo, ihi, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_ilo = argv[0];
  rblapack_ihi = argv[1];
  rblapack_a = argv[2];
  rblapack_tau = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  ihi = NUM2INT(rblapack_ihi);
  if (rblapack_lwork == Qnil)
    lwork = ihi-ilo;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_tau) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", n-1);
  if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;

  dorghr_(&n, &ilo, &ihi, a, &lda, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_dorghr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dorghr", rblapack_dorghr, -1);
}
ruby-lapack-1.7.2/ext/cspsvx.c0000644000175000017500000003163612502221013016056 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cspsvx_(char* fact, char* uplo, integer* n, integer* nrhs, complex* ap, complex* afp, integer* ipiv, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* ferr, real* berr, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cspsvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_afp;
  complex *afp; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_afp_out__;
  complex *afp_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  complex *work;
  real *rwork;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.cspsvx( fact, uplo, ap, afp, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CSPSVX uses the diagonal pivoting factorization A = U*D*U**T or\n*  A = L*D*L**T to compute the solution to a complex system of linear\n*  equations A * X = B, where A is an N-by-N symmetric matrix stored\n*  in packed format and X and B are N-by-NRHS matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'N', the diagonal pivoting method is used to factor A as\n*        A = U * D * U**T,  if UPLO = 'U', or\n*        A = L * D * L**T,  if UPLO = 'L',\n*     where U (or L) is a product of permutation and unit upper (lower)\n*     triangular matrices and D is symmetric and block diagonal with\n*     1-by-1 and 2-by-2 diagonal blocks.\n*\n*  2. If some D(i,i)=0, so that D is exactly singular, then the routine\n*     returns with INFO = i. Otherwise, the factored form of A is used\n*     to estimate the condition number of the matrix A.  If the\n*     reciprocal of the condition number is less than machine precision,\n*     INFO = N+1 is returned as a warning, but the routine still goes on\n*     to solve for X and compute error bounds as described below.\n*\n*  3. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  4. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of A has been\n*          supplied on entry.\n*          = 'F':  On entry, AFP and IPIV contain the factored form\n*                  of A.  AP, AFP and IPIV will not be modified.\n*          = 'N':  The matrix A will be copied to AFP and factored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)\n*          The upper or lower triangle of the symmetric matrix A, packed\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*          See below for further details.\n*\n*  AFP     (input or output) COMPLEX array, dimension (N*(N+1)/2)\n*          If FACT = 'F', then AFP is an input argument and on entry\n*          contains the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L from the factorization\n*          A = U*D*U**T or A = L*D*L**T as computed by CSPTRF, stored as\n*          a packed triangular matrix in the same storage format as A.\n*\n*          If FACT = 'N', then AFP is an output argument and on exit\n*          contains the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L from the factorization\n*          A = U*D*U**T or A = L*D*L**T as computed by CSPTRF, stored as\n*          a packed triangular matrix in the same storage format as A.\n*\n*  IPIV    (input or output) INTEGER array, dimension (N)\n*          If FACT = 'F', then IPIV is an input argument and on entry\n*          contains details of the interchanges and the block structure\n*          of D, as determined by CSPTRF.\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*          If FACT = 'N', then IPIV is an output argument and on exit\n*          contains details of the interchanges and the block structure\n*          of D, as determined by CSPTRF.\n*\n*  B       (input) COMPLEX array, dimension (LDB,NRHS)\n*          The N-by-NRHS right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) COMPLEX array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) REAL\n*          The estimate of the reciprocal condition number of the matrix\n*          A.  If RCOND is less than the machine precision (in\n*          particular, if RCOND = 0), the matrix is singular to working\n*          precision.  This condition is indicated by a return code of\n*          INFO > 0.\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\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, and i is\n*                <= N:  D(i,i) is exactly zero.  The factorization\n*                       has been completed but the factor D is exactly\n*                       singular, so the solution and error bounds could\n*                       not be computed. RCOND = 0 is returned.\n*                = N+1: D is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  Further Details\n*  ===============\n*\n*  The packed storage scheme is illustrated by the following example\n*  when N = 4, UPLO = 'U':\n*\n*  Two-dimensional storage of the symmetric matrix A:\n*\n*     a11 a12 a13 a14\n*         a22 a23 a24\n*             a33 a34     (aij = aji)\n*                 a44\n*\n*  Packed storage of the upper triangle of A:\n*\n*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.cspsvx( fact, uplo, ap, afp, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_ap = argv[2];
  rblapack_afp = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_b = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  ldx = MAX(1,n);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_afp))
    rb_raise(rb_eArgError, "afp (4th argument) must be NArray");
  if (NA_RANK(rblapack_afp) != 1)
    rb_raise(rb_eArgError, "rank of afp (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_afp) != NA_SCOMPLEX)
    rblapack_afp = na_change_type(rblapack_afp, NA_SCOMPLEX);
  afp = NA_PTR_TYPE(rblapack_afp, complex*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_afp_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  afp_out__ = NA_PTR_TYPE(rblapack_afp_out__, complex*);
  MEMCPY(afp_out__, afp, complex, NA_TOTAL(rblapack_afp));
  rblapack_afp = rblapack_afp_out__;
  afp = afp_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (n));

  cspsvx_(&fact, &uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_afp, rblapack_ipiv);
}

void
init_lapack_cspsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cspsvx", rblapack_cspsvx, -1);
}
ruby-lapack-1.7.2/ext/sggglm.c0000644000175000017500000002101112502221016015775 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sggglm_(integer* n, integer* m, integer* p, real* a, integer* lda, real* b, integer* ldb, real* d, real* x, real* y, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sggglm(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_y;
  real *y; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_b_out__;
  real *b_out__;
  VALUE rblapack_d_out__;
  real *d_out__;

  integer lda;
  integer m;
  integer ldb;
  integer p;
  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  x, y, work, info, a, b, d = NumRu::Lapack.sggglm( a, b, d, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGGGLM solves a general Gauss-Markov linear model (GLM) problem:\n*\n*          minimize || y ||_2   subject to   d = A*x + B*y\n*              x\n*\n*  where A is an N-by-M matrix, B is an N-by-P matrix, and d is a\n*  given N-vector. It is assumed that M <= N <= M+P, and\n*\n*             rank(A) = M    and    rank( A B ) = N.\n*\n*  Under these assumptions, the constrained equation is always\n*  consistent, and there is a unique solution x and a minimal 2-norm\n*  solution y, which is obtained using a generalized QR factorization\n*  of the matrices (A, B) given by\n*\n*     A = Q*(R),   B = Q*T*Z.\n*           (0)\n*\n*  In particular, if matrix B is square nonsingular, then the problem\n*  GLM is equivalent to the following weighted linear least squares\n*  problem\n*\n*               minimize || inv(B)*(d-A*x) ||_2\n*                   x\n*\n*  where inv(B) denotes the inverse of B.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of rows of the matrices A and B.  N >= 0.\n*\n*  M       (input) INTEGER\n*          The number of columns of the matrix A.  0 <= M <= N.\n*\n*  P       (input) INTEGER\n*          The number of columns of the matrix B.  P >= N-M.\n*\n*  A       (input/output) REAL array, dimension (LDA,M)\n*          On entry, the N-by-M matrix A.\n*          On exit, the upper triangular part of the array A contains\n*          the M-by-M upper triangular matrix R.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  B       (input/output) REAL array, dimension (LDB,P)\n*          On entry, the N-by-P matrix B.\n*          On exit, if N <= P, the upper triangle of the subarray\n*          B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n*          if N > P, the elements on and above the (N-P)th subdiagonal\n*          contain the N-by-P upper trapezoidal matrix T.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  D       (input/output) REAL array, dimension (N)\n*          On entry, D is the left hand side of the GLM equation.\n*          On exit, D is destroyed.\n*\n*  X       (output) REAL array, dimension (M)\n*  Y       (output) REAL array, dimension (P)\n*          On exit, X and Y are the solutions of the GLM problem.\n*\n*  WORK    (workspace/output) REAL 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,N+M+P).\n*          For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,\n*          where NB is an upper bound for the optimal blocksizes for\n*          SGEQRF, SGERQF, SORMQR and SORMRQ.\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*          = 1:  the upper triangular factor R associated with A in the\n*                generalized QR factorization of the pair (A, B) is\n*                singular, so that rank(A) < M; the least squares\n*                solution could not be computed.\n*          = 2:  the bottom (N-M) by (N-M) part of the upper trapezoidal\n*                factor T associated with B in the generalized QR\n*                factorization of the pair (A, B) is singular, so that\n*                rank( A B ) < N; the least squares solution could not\n*                be computed.\n*\n\n*  ===================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, y, work, info, a, b, d = NumRu::Lapack.sggglm( a, b, d, [: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_a = argv[0];
  rblapack_b = argv[1];
  rblapack_d = 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 (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);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  p = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (rblapack_lwork == Qnil)
    lwork = m+n+p;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_x = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[1];
    shape[0] = p;
    rblapack_y = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  y = NA_PTR_TYPE(rblapack_y, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = m;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = p;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;

  sggglm_(&n, &m, &p, a, &lda, b, &ldb, d, x, y, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_x, rblapack_y, rblapack_work, rblapack_info, rblapack_a, rblapack_b, rblapack_d);
}

void
init_lapack_sggglm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sggglm", rblapack_sggglm, -1);
}
ruby-lapack-1.7.2/ext/dlarzt.c0000644000175000017500000001666512502221022016035 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlarzt_(char* direct, char* storev, integer* n, integer* k, doublereal* v, integer* ldv, doublereal* tau, doublereal* t, integer* ldt);


static VALUE
rblapack_dlarzt(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_direct;
  char direct; 
  VALUE rblapack_storev;
  char storev; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_v;
  doublereal *v; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_t;
  doublereal *t; 
  VALUE rblapack_v_out__;
  doublereal *v_out__;

  integer ldv;
  integer k;
  integer ldt;

  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  t, v = NumRu::Lapack.dlarzt( direct, storev, n, v, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n*  Purpose\n*  =======\n*\n*  DLARZT forms the triangular factor T of a real block reflector\n*  H of order > n, which is defined as a product of k elementary\n*  reflectors.\n*\n*  If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n*\n*  If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n*\n*  If STOREV = 'C', the vector which defines the elementary reflector\n*  H(i) is stored in the i-th column of the array V, and\n*\n*     H  =  I - V * T * V'\n*\n*  If STOREV = 'R', the vector which defines the elementary reflector\n*  H(i) is stored in the i-th row of the array V, and\n*\n*     H  =  I - V' * T * V\n*\n*  Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n*\n\n*  Arguments\n*  =========\n*\n*  DIRECT  (input) CHARACTER*1\n*          Specifies the order in which the elementary reflectors are\n*          multiplied to form the block reflector:\n*          = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n*          = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n*  STOREV  (input) CHARACTER*1\n*          Specifies how the vectors which define the elementary\n*          reflectors are stored (see also Further Details):\n*          = 'C': columnwise                        (not supported yet)\n*          = 'R': rowwise\n*\n*  N       (input) INTEGER\n*          The order of the block reflector H. N >= 0.\n*\n*  K       (input) INTEGER\n*          The order of the triangular factor T (= the number of\n*          elementary reflectors). K >= 1.\n*\n*  V       (input/output) DOUBLE PRECISION array, dimension\n*                               (LDV,K) if STOREV = 'C'\n*                               (LDV,N) if STOREV = 'R'\n*          The matrix V. See further details.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V.\n*          If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n*\n*  TAU     (input) DOUBLE PRECISION array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i).\n*\n*  T       (output) DOUBLE PRECISION array, dimension (LDT,K)\n*          The k by k triangular factor T of the block reflector.\n*          If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n*          lower triangular. The rest of the array is not used.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= K.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n*  The shape of the matrix V and the storage of the vectors which define\n*  the H(i) is best illustrated by the following example with n = 5 and\n*  k = 3. The elements equal to 1 are not stored; the corresponding\n*  array elements are modified but restored on exit. The rest of the\n*  array is not used.\n*\n*  DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R':\n*\n*                                              ______V_____\n*         ( v1 v2 v3 )                        /            \\\n*         ( v1 v2 v3 )                      ( v1 v1 v1 v1 v1 . . . . 1 )\n*     V = ( v1 v2 v3 )                      ( v2 v2 v2 v2 v2 . . . 1   )\n*         ( v1 v2 v3 )                      ( v3 v3 v3 v3 v3 . . 1     )\n*         ( v1 v2 v3 )\n*            .  .  .\n*            .  .  .\n*            1  .  .\n*               1  .\n*                  1\n*\n*  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R':\n*\n*                                                        ______V_____\n*            1                                          /            \\\n*            .  1                           ( 1 . . . . v1 v1 v1 v1 v1 )\n*            .  .  1                        ( . 1 . . . v2 v2 v2 v2 v2 )\n*            .  .  .                        ( . . 1 . . v3 v3 v3 v3 v3 )\n*            .  .  .\n*         ( v1 v2 v3 )\n*         ( v1 v2 v3 )\n*     V = ( v1 v2 v3 )\n*         ( v1 v2 v3 )\n*         ( v1 v2 v3 )\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  t, v = NumRu::Lapack.dlarzt( direct, storev, n, v, tau, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_direct = argv[0];
  rblapack_storev = argv[1];
  rblapack_n = argv[2];
  rblapack_v = argv[3];
  rblapack_tau = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  direct = StringValueCStr(rblapack_direct)[0];
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  storev = StringValueCStr(rblapack_storev)[0];
  ldt = k;
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (4th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  if (NA_SHAPE1(rblapack_v) != (lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0))
    rb_raise(rb_eRuntimeError, "shape 1 of v must be %d", lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0);
  if (NA_TYPE(rblapack_v) != NA_DFLOAT)
    rblapack_v = na_change_type(rblapack_v, NA_DFLOAT);
  v = NA_PTR_TYPE(rblapack_v, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = k;
    rblapack_t = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  t = NA_PTR_TYPE(rblapack_t, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0;
    rblapack_v_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  v_out__ = NA_PTR_TYPE(rblapack_v_out__, doublereal*);
  MEMCPY(v_out__, v, doublereal, NA_TOTAL(rblapack_v));
  rblapack_v = rblapack_v_out__;
  v = v_out__;

  dlarzt_(&direct, &storev, &n, &k, v, &ldv, tau, t, &ldt);

  return rb_ary_new3(2, rblapack_t, rblapack_v);
}

void
init_lapack_dlarzt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlarzt", rblapack_dlarzt, -1);
}
ruby-lapack-1.7.2/ext/dggesx.c0000644000175000017500000004330712502221023016010 0ustar  uwabamiuwabami#include "rb_lapack.h"

static logical
rblapack_selctg(doublereal *arg0, doublereal *arg1, doublereal *arg2){
  VALUE rblapack_arg0, rblapack_arg1, rblapack_arg2;

  VALUE rblapack_ret;
  logical ret;

  rblapack_arg0 = rb_float_new((double)(*arg0));
  rblapack_arg1 = rb_float_new((double)(*arg1));
  rblapack_arg2 = rb_float_new((double)(*arg2));

  rblapack_ret = rb_yield_values(3, rblapack_arg0, rblapack_arg1, rblapack_arg2);

  ret = (rblapack_ret == Qtrue);
  return ret;
}

extern VOID dggesx_(char* jobvsl, char* jobvsr, char* sort, L_fp selctg, char* sense, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, integer* sdim, doublereal* alphar, doublereal* alphai, doublereal* beta, doublereal* vsl, integer* ldvsl, doublereal* vsr, integer* ldvsr, doublereal* rconde, doublereal* rcondv, doublereal* work, integer* lwork, integer* iwork, integer* liwork, logical* bwork, integer* info);


static VALUE
rblapack_dggesx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvsl;
  char jobvsl; 
  VALUE rblapack_jobvsr;
  char jobvsr; 
  VALUE rblapack_sort;
  char sort; 
  VALUE rblapack_sense;
  char sense; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_sdim;
  integer sdim; 
  VALUE rblapack_alphar;
  doublereal *alphar; 
  VALUE rblapack_alphai;
  doublereal *alphai; 
  VALUE rblapack_beta;
  doublereal *beta; 
  VALUE rblapack_vsl;
  doublereal *vsl; 
  VALUE rblapack_vsr;
  doublereal *vsr; 
  VALUE rblapack_rconde;
  doublereal *rconde; 
  VALUE rblapack_rcondv;
  doublereal *rcondv; 
  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 *iwork;
  logical *bwork;

  integer lda;
  integer n;
  integer ldb;
  integer ldvsl;
  integer ldvsr;

  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  sdim, alphar, alphai, beta, vsl, vsr, rconde, rcondv, work, info, a, b = NumRu::Lapack.dggesx( jobvsl, jobvsr, sort, sense, a, b, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help]){|a,b,c| ... }\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, IWORK, LIWORK, BWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGGESX computes for a pair of N-by-N real nonsymmetric matrices\n*  (A,B), the generalized eigenvalues, the real Schur form (S,T), and,\n*  optionally, the left and/or right matrices of Schur vectors (VSL and\n*  VSR).  This gives the generalized Schur factorization\n*\n*       (A,B) = ( (VSL) S (VSR)**T, (VSL) T (VSR)**T )\n*\n*  Optionally, it also orders the eigenvalues so that a selected cluster\n*  of eigenvalues appears in the leading diagonal blocks of the upper\n*  quasi-triangular matrix S and the upper triangular matrix T; computes\n*  a reciprocal condition number for the average of the selected\n*  eigenvalues (RCONDE); and computes a reciprocal condition number for\n*  the right and left deflating subspaces corresponding to the selected\n*  eigenvalues (RCONDV). The leading columns of VSL and VSR then form\n*  an orthonormal basis for the corresponding left and right eigenspaces\n*  (deflating subspaces).\n*\n*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n*  or a ratio alpha/beta = w, such that  A - w*B is singular.  It is\n*  usually represented as the pair (alpha,beta), as there is a\n*  reasonable interpretation for beta=0 or for both being zero.\n*\n*  A pair of matrices (S,T) is in generalized real Schur form if T is\n*  upper triangular with non-negative diagonal and S is block upper\n*  triangular with 1-by-1 and 2-by-2 blocks.  1-by-1 blocks correspond\n*  to real generalized eigenvalues, while 2-by-2 blocks of S will be\n*  \"standardized\" by making the corresponding elements of T have the\n*  form:\n*          [  a  0  ]\n*          [  0  b  ]\n*\n*  and the pair of corresponding 2-by-2 blocks in S and T will have a\n*  complex conjugate pair of generalized eigenvalues.\n*\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVSL  (input) CHARACTER*1\n*          = 'N':  do not compute the left Schur vectors;\n*          = 'V':  compute the left Schur vectors.\n*\n*  JOBVSR  (input) CHARACTER*1\n*          = 'N':  do not compute the right Schur vectors;\n*          = 'V':  compute the right Schur vectors.\n*\n*  SORT    (input) CHARACTER*1\n*          Specifies whether or not to order the eigenvalues on the\n*          diagonal of the generalized Schur form.\n*          = 'N':  Eigenvalues are not ordered;\n*          = 'S':  Eigenvalues are ordered (see SELCTG).\n*\n*  SELCTG  (external procedure) LOGICAL FUNCTION of three DOUBLE PRECISION arguments\n*          SELCTG must be declared EXTERNAL in the calling subroutine.\n*          If SORT = 'N', SELCTG is not referenced.\n*          If SORT = 'S', SELCTG is used to select eigenvalues to sort\n*          to the top left of the Schur form.\n*          An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if\n*          SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either\n*          one of a complex conjugate pair of eigenvalues is selected,\n*          then both complex eigenvalues are selected.\n*          Note that a selected complex eigenvalue may no longer satisfy\n*          SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) = .TRUE. after ordering,\n*          since ordering may change the value of complex eigenvalues\n*          (especially if the eigenvalue is ill-conditioned), in this\n*          case INFO is set to N+3.\n*\n*  SENSE   (input) CHARACTER*1\n*          Determines which reciprocal condition numbers are computed.\n*          = 'N' : None are computed;\n*          = 'E' : Computed for average of selected eigenvalues only;\n*          = 'V' : Computed for selected deflating subspaces only;\n*          = 'B' : Computed for both.\n*          If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A, B, VSL, and VSR.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n*          On entry, the first of the pair of matrices.\n*          On exit, A has been overwritten by its generalized Schur\n*          form S.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of A.  LDA >= max(1,N).\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n*          On entry, the second of the pair of matrices.\n*          On exit, B has been overwritten by its generalized Schur\n*          form T.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of B.  LDB >= max(1,N).\n*\n*  SDIM    (output) INTEGER\n*          If SORT = 'N', SDIM = 0.\n*          If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n*          for which SELCTG is true.  (Complex conjugate pairs for which\n*          SELCTG is true for either eigenvalue count as 2.)\n*\n*  ALPHAR  (output) DOUBLE PRECISION array, dimension (N)\n*  ALPHAI  (output) DOUBLE PRECISION array, dimension (N)\n*  BETA    (output) DOUBLE PRECISION array, dimension (N)\n*          On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n*          be the generalized eigenvalues.  ALPHAR(j) + ALPHAI(j)*i\n*          and BETA(j),j=1,...,N  are the diagonals of the complex Schur\n*          form (S,T) that would result if the 2-by-2 diagonal blocks of\n*          the real Schur form of (A,B) were further reduced to\n*          triangular form using 2-by-2 complex unitary transformations.\n*          If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n*          positive, then the j-th and (j+1)-st eigenvalues are a\n*          complex conjugate pair, with ALPHAI(j+1) negative.\n*\n*          Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n*          may easily over- or underflow, and BETA(j) may even be zero.\n*          Thus, the user should avoid naively computing the ratio.\n*          However, ALPHAR and ALPHAI will be always less than and\n*          usually comparable with norm(A) in magnitude, and BETA always\n*          less than and usually comparable with norm(B).\n*\n*  VSL     (output) DOUBLE PRECISION array, dimension (LDVSL,N)\n*          If JOBVSL = 'V', VSL will contain the left Schur vectors.\n*          Not referenced if JOBVSL = 'N'.\n*\n*  LDVSL   (input) INTEGER\n*          The leading dimension of the matrix VSL. LDVSL >=1, and\n*          if JOBVSL = 'V', LDVSL >= N.\n*\n*  VSR     (output) DOUBLE PRECISION array, dimension (LDVSR,N)\n*          If JOBVSR = 'V', VSR will contain the right Schur vectors.\n*          Not referenced if JOBVSR = 'N'.\n*\n*  LDVSR   (input) INTEGER\n*          The leading dimension of the matrix VSR. LDVSR >= 1, and\n*          if JOBVSR = 'V', LDVSR >= N.\n*\n*  RCONDE  (output) DOUBLE PRECISION array, dimension ( 2 )\n*          If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the\n*          reciprocal condition numbers for the average of the selected\n*          eigenvalues.\n*          Not referenced if SENSE = 'N' or 'V'.\n*\n*  RCONDV  (output) DOUBLE PRECISION array, dimension ( 2 )\n*          If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the\n*          reciprocal condition numbers for the selected deflating\n*          subspaces.\n*          Not referenced if SENSE = 'N' or 'E'.\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*          If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B',\n*          LWORK >= max( 8*N, 6*N+16, 2*SDIM*(N-SDIM) ), else\n*          LWORK >= max( 8*N, 6*N+16 ).\n*          Note that 2*SDIM*(N-SDIM) <= N*N/2.\n*          Note also that an error is only returned if\n*          LWORK < max( 8*N, 6*N+16), but if SENSE = 'E' or 'V' or 'B'\n*          this may not be large enough.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the bound on the optimal size of the WORK\n*          array and the minimum size of the IWORK array, returns these\n*          values as the first entries of the WORK and IWORK arrays, and\n*          no error message related to LWORK or LIWORK is issued by\n*          XERBLA.\n*\n*  IWORK   (workspace) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.\n*          If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise\n*          LIWORK >= N+6.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the bound on the optimal size of the\n*          WORK array and the minimum size of the IWORK array, returns\n*          these values as the first entries of the WORK and IWORK\n*          arrays, and no error message related to LWORK or LIWORK is\n*          issued by XERBLA.\n*\n*  BWORK   (workspace) LOGICAL array, dimension (N)\n*          Not referenced if SORT = 'N'.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          = 1,...,N:\n*                The QZ iteration failed.  (A,B) are not in Schur\n*                form, but ALPHAR(j), ALPHAI(j), and BETA(j) should\n*                be correct for j=INFO+1,...,N.\n*          > N:  =N+1: other than QZ iteration failed in DHGEQZ\n*                =N+2: after reordering, roundoff changed values of\n*                      some complex eigenvalues so that leading\n*                      eigenvalues in the Generalized Schur form no\n*                      longer satisfy SELCTG=.TRUE.  This could also\n*                      be caused due to scaling.\n*                =N+3: reordering failed in DTGSEN.\n*\n\n*  Further Details\n*  ===============\n*\n*  An approximate (asymptotic) bound on the average absolute error of\n*  the selected eigenvalues is\n*\n*       EPS * norm((A, B)) / RCONDE( 1 ).\n*\n*  An approximate (asymptotic) bound on the maximum angular error in\n*  the computed deflating subspaces is\n*\n*       EPS * norm((A, B)) / RCONDV( 2 ).\n*\n*  See LAPACK User's Guide, section 4.11 for more information.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sdim, alphar, alphai, beta, vsl, vsr, rconde, rcondv, work, info, a, b = NumRu::Lapack.dggesx( jobvsl, jobvsr, sort, sense, a, b, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help]){|a,b,c| ... }\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_jobvsl = argv[0];
  rblapack_jobvsr = argv[1];
  rblapack_sort = argv[2];
  rblapack_sense = argv[3];
  rblapack_a = argv[4];
  rblapack_b = argv[5];
  if (argc == 8) {
    rblapack_lwork = argv[6];
    rblapack_liwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobvsl = StringValueCStr(rblapack_jobvsl)[0];
  sort = StringValueCStr(rblapack_sort)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th 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*);
  jobvsr = StringValueCStr(rblapack_jobvsr)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  ldvsl = lsame_(&jobvsl,"V") ? n : 1;
  sense = StringValueCStr(rblapack_sense)[0];
  if (rblapack_liwork == Qnil)
    liwork = (lsame_(&sense,"N")||n==0) ? 1 : n+6;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  if (rblapack_lwork == Qnil)
    lwork = n==0 ? 1 : (lsame_(&sense,"E")||lsame_(&sense,"V")||lsame_(&sense,"B")) ? MAX(MAX(8*n,6*n+16),n*n/2) : MAX(8*n,6*n+16);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldvsr = lsame_(&jobvsr,"V") ? n : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  alphar = NA_PTR_TYPE(rblapack_alphar, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  alphai = NA_PTR_TYPE(rblapack_alphai, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldvsl;
    shape[1] = n;
    rblapack_vsl = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vsl = NA_PTR_TYPE(rblapack_vsl, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldvsr;
    shape[1] = n;
    rblapack_vsr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vsr = NA_PTR_TYPE(rblapack_vsr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 2;
    rblapack_rconde = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  rconde = NA_PTR_TYPE(rblapack_rconde, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 2;
    rblapack_rcondv = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  rcondv = NA_PTR_TYPE(rblapack_rcondv, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  iwork = ALLOC_N(integer, (MAX(1,liwork)));
  bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));

  dggesx_(&jobvsl, &jobvsr, &sort, rblapack_selctg, &sense, &n, a, &lda, b, &ldb, &sdim, alphar, alphai, beta, vsl, &ldvsl, vsr, &ldvsr, rconde, rcondv, work, &lwork, iwork, &liwork, bwork, &info);

  free(iwork);
  free(bwork);
  rblapack_sdim = INT2NUM(sdim);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(12, rblapack_sdim, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_vsl, rblapack_vsr, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_dggesx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dggesx", rblapack_dggesx, -1);
}
ruby-lapack-1.7.2/ext/dggev.c0000644000175000017500000002554012502221024015623 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dggev_(char* jobvl, char* jobvr, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* alphar, doublereal* alphai, doublereal* beta, doublereal* vl, integer* ldvl, doublereal* vr, integer* ldvr, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dggev(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvl;
  char jobvl; 
  VALUE rblapack_jobvr;
  char jobvr; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_alphar;
  doublereal *alphar; 
  VALUE rblapack_alphai;
  doublereal *alphai; 
  VALUE rblapack_beta;
  doublereal *beta; 
  VALUE rblapack_vl;
  doublereal *vl; 
  VALUE rblapack_vr;
  doublereal *vr; 
  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 ldb;
  integer ldvl;
  integer ldvr;

  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  alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.dggev( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B)\n*  the generalized eigenvalues, and optionally, the left and/or right\n*  generalized eigenvectors.\n*\n*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n*  lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n*  singular. It is usually represented as the pair (alpha,beta), as\n*  there is a reasonable interpretation for beta=0, and even for both\n*  being zero.\n*\n*  The right eigenvector v(j) corresponding to the eigenvalue lambda(j)\n*  of (A,B) satisfies\n*\n*                   A * v(j) = lambda(j) * B * v(j).\n*\n*  The left eigenvector u(j) corresponding to the eigenvalue lambda(j)\n*  of (A,B) satisfies\n*\n*                   u(j)**H * A  = lambda(j) * u(j)**H * B .\n*\n*  where u(j)**H is the conjugate-transpose of u(j).\n*\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVL   (input) CHARACTER*1\n*          = 'N':  do not compute the left generalized eigenvectors;\n*          = 'V':  compute the left generalized eigenvectors.\n*\n*  JOBVR   (input) CHARACTER*1\n*          = 'N':  do not compute the right generalized eigenvectors;\n*          = 'V':  compute the right generalized eigenvectors.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A, B, VL, and VR.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n*          On entry, the matrix A in the pair (A,B).\n*          On exit, A has been overwritten.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of A.  LDA >= max(1,N).\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n*          On entry, the matrix B in the pair (A,B).\n*          On exit, B has been overwritten.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of B.  LDB >= max(1,N).\n*\n*  ALPHAR  (output) DOUBLE PRECISION array, dimension (N)\n*  ALPHAI  (output) DOUBLE PRECISION array, dimension (N)\n*  BETA    (output) DOUBLE PRECISION array, dimension (N)\n*          On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n*          be the generalized eigenvalues.  If ALPHAI(j) is zero, then\n*          the j-th eigenvalue is real; if positive, then the j-th and\n*          (j+1)-st eigenvalues are a complex conjugate pair, with\n*          ALPHAI(j+1) negative.\n*\n*          Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n*          may easily over- or underflow, and BETA(j) may even be zero.\n*          Thus, the user should avoid naively computing the ratio\n*          alpha/beta.  However, ALPHAR and ALPHAI will be always less\n*          than and usually comparable with norm(A) in magnitude, and\n*          BETA always less than and usually comparable with norm(B).\n*\n*  VL      (output) DOUBLE PRECISION array, dimension (LDVL,N)\n*          If JOBVL = 'V', the left eigenvectors u(j) are stored one\n*          after another in the columns of VL, in the same order as\n*          their eigenvalues. If the j-th eigenvalue is real, then\n*          u(j) = VL(:,j), the j-th column of VL. If the j-th and\n*          (j+1)-th eigenvalues form a complex conjugate pair, then\n*          u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).\n*          Each eigenvector is scaled so the largest component has\n*          abs(real part)+abs(imag. part)=1.\n*          Not referenced if JOBVL = 'N'.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the matrix VL. LDVL >= 1, and\n*          if JOBVL = 'V', LDVL >= N.\n*\n*  VR      (output) DOUBLE PRECISION array, dimension (LDVR,N)\n*          If JOBVR = 'V', the right eigenvectors v(j) are stored one\n*          after another in the columns of VR, in the same order as\n*          their eigenvalues. If the j-th eigenvalue is real, then\n*          v(j) = VR(:,j), the j-th column of VR. If the j-th and\n*          (j+1)-th eigenvalues form a complex conjugate pair, then\n*          v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).\n*          Each eigenvector is scaled so the largest component has\n*          abs(real part)+abs(imag. part)=1.\n*          Not referenced if JOBVR = 'N'.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the matrix VR. LDVR >= 1, and\n*          if JOBVR = 'V', LDVR >= 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.  LWORK >= max(1,8*N).\n*          For good performance, LWORK must generally be larger.\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*          = 1,...,N:\n*                The QZ iteration failed.  No eigenvectors have been\n*                calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)\n*                should be correct for j=INFO+1,...,N.\n*          > N:  =N+1: other than QZ iteration failed in DHGEQZ.\n*                =N+2: error return from DTGEVC.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.dggev( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_jobvl = argv[0];
  rblapack_jobvr = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  jobvl = StringValueCStr(rblapack_jobvl)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  jobvr = StringValueCStr(rblapack_jobvr)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  ldvr = lsame_(&jobvr,"V") ? n : 1;
  if (rblapack_lwork == Qnil)
    lwork = MAX(1,8*n);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldvl = lsame_(&jobvl,"V") ? n : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  alphar = NA_PTR_TYPE(rblapack_alphar, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  alphai = NA_PTR_TYPE(rblapack_alphai, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = n;
    rblapack_vl = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vl = NA_PTR_TYPE(rblapack_vl, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = n;
    rblapack_vr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vr = NA_PTR_TYPE(rblapack_vr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dggev_(&jobvl, &jobvr, &n, a, &lda, b, &ldb, alphar, alphai, beta, vl, &ldvl, vr, &ldvr, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_vl, rblapack_vr, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_dggev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dggev", rblapack_dggev, -1);
}
ruby-lapack-1.7.2/ext/sla_porfsx_extended.c0000644000175000017500000005457412502221014020577 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sla_porfsx_extended_(integer* prec_type, char* uplo, integer* n, integer* nrhs, real* a, integer* lda, real* af, integer* ldaf, logical* colequ, real* c, real* b, integer* ldb, real* y, integer* ldy, real* berr_out, integer* n_norms, real* err_bnds_norm, real* err_bnds_comp, real* res, real* ayb, real* dy, real* y_tail, real* rcond, integer* ithresh, real* rthresh, real* dz_ub, logical* ignore_cwise, integer* info);


static VALUE
rblapack_sla_porfsx_extended(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_prec_type;
  integer prec_type; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_af;
  real *af; 
  VALUE rblapack_colequ;
  logical colequ; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_y;
  real *y; 
  VALUE rblapack_n_norms;
  integer n_norms; 
  VALUE rblapack_err_bnds_norm;
  real *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  real *err_bnds_comp; 
  VALUE rblapack_res;
  real *res; 
  VALUE rblapack_ayb;
  real *ayb; 
  VALUE rblapack_dy;
  real *dy; 
  VALUE rblapack_y_tail;
  real *y_tail; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_ithresh;
  integer ithresh; 
  VALUE rblapack_rthresh;
  real rthresh; 
  VALUE rblapack_dz_ub;
  real dz_ub; 
  VALUE rblapack_ignore_cwise;
  logical ignore_cwise; 
  VALUE rblapack_berr_out;
  real *berr_out; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_y_out__;
  real *y_out__;
  VALUE rblapack_err_bnds_norm_out__;
  real *err_bnds_norm_out__;
  VALUE rblapack_err_bnds_comp_out__;
  real *err_bnds_comp_out__;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldy;
  integer n_err_bnds;

  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  berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.sla_porfsx_extended( prec_type, uplo, a, af, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLA_PORFSX_EXTENDED improves the computed solution to a system of\n*  linear equations by performing extra-precise iterative refinement\n*  and provides error bounds and backward error estimates for the solution.\n*  This subroutine is called by SPORFSX to perform iterative refinement.\n*  In addition to normwise error bound, the code provides maximum\n*  componentwise error bound if possible. See comments for ERR_BNDS_NORM\n*  and ERR_BNDS_COMP for details of the error bounds. Note that this\n*  subroutine is only resonsible for setting the second fields of\n*  ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n*  Arguments\n*  =========\n*\n*     PREC_TYPE      (input) INTEGER\n*     Specifies the intermediate precision to be used in refinement.\n*     The value is defined by ILAPREC(P) where P is a CHARACTER and\n*     P    = 'S':  Single\n*          = 'D':  Double\n*          = 'I':  Indigenous\n*          = 'X', 'E':  Extra\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N              (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NRHS           (input) INTEGER\n*     The number of right-hand-sides, i.e., the number of columns of the\n*     matrix B.\n*\n*     A              (input) REAL array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA            (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF             (input) REAL array, dimension (LDAF,N)\n*     The triangular factor U or L from the Cholesky factorization\n*     A = U**T*U or A = L*L**T, as computed by SPOTRF.\n*\n*     LDAF           (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     COLEQU         (input) LOGICAL\n*     If .TRUE. then column equilibration was done to A before calling\n*     this routine. This is needed to compute the solution and error\n*     bounds correctly.\n*\n*     C              (input) REAL array, dimension (N)\n*     The column scale factors for A. If COLEQU = .FALSE., C\n*     is not accessed. If C is input, each element of C should be a power\n*     of the radix to ensure a reliable solution and error estimates.\n*     Scaling by powers of the radix does not cause rounding errors unless\n*     the result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B              (input) REAL array, dimension (LDB,NRHS)\n*     The right-hand-side matrix B.\n*\n*     LDB            (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     Y              (input/output) REAL array, dimension (LDY,NRHS)\n*     On entry, the solution matrix X, as computed by SPOTRS.\n*     On exit, the improved solution matrix Y.\n*\n*     LDY            (input) INTEGER\n*     The leading dimension of the array Y.  LDY >= max(1,N).\n*\n*     BERR_OUT       (output) REAL array, dimension (NRHS)\n*     On exit, BERR_OUT(j) contains the componentwise relative backward\n*     error for right-hand-side j from the formula\n*         max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n*     where abs(Z) is the componentwise absolute value of the matrix\n*     or vector Z. This is computed by SLA_LIN_BERR.\n*\n*     N_NORMS        (input) INTEGER\n*     Determines which error bounds to return (see ERR_BNDS_NORM\n*     and ERR_BNDS_COMP).\n*     If N_NORMS >= 1 return normwise error bounds.\n*     If N_NORMS >= 2 return componentwise error bounds.\n*\n*     ERR_BNDS_NORM  (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     RES            (input) REAL array, dimension (N)\n*     Workspace to hold the intermediate residual.\n*\n*     AYB            (input) REAL array, dimension (N)\n*     Workspace. This can be the same workspace passed for Y_TAIL.\n*\n*     DY             (input) REAL array, dimension (N)\n*     Workspace to hold the intermediate solution.\n*\n*     Y_TAIL         (input) REAL array, dimension (N)\n*     Workspace to hold the trailing bits of the intermediate solution.\n*\n*     RCOND          (input) REAL\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     ITHRESH        (input) INTEGER\n*     The maximum number of residual computations allowed for\n*     refinement. The default is 10. For 'aggressive' set to 100 to\n*     permit convergence using approximate factorizations or\n*     factorizations other than LU. If the factorization uses a\n*     technique other than Gaussian elimination, the guarantees in\n*     ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n*     RTHRESH        (input) REAL\n*     Determines when to stop refinement if the error estimate stops\n*     decreasing. Refinement will stop when the next solution no longer\n*     satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n*     the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n*     default value is 0.5. For 'aggressive' set to 0.9 to permit\n*     convergence on extremely ill-conditioned matrices. See LAWN 165\n*     for more details.\n*\n*     DZ_UB          (input) REAL\n*     Determines when to start considering componentwise convergence.\n*     Componentwise convergence is only considered after each component\n*     of the solution Y is stable, which we definte as the relative\n*     change in each component being less than DZ_UB. The default value\n*     is 0.25, requiring the first bit to be stable. See LAWN 165 for\n*     more details.\n*\n*     IGNORE_CWISE   (input) LOGICAL\n*     If .TRUE. then ignore componentwise convergence. Default value\n*     is .FALSE..\n*\n*     INFO           (output) INTEGER\n*       = 0:  Successful exit.\n*       < 0:  if INFO = -i, the ith argument to SPOTRS had an illegal\n*             value\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            UPLO2, CNT, I, J, X_STATE, Z_STATE\n      REAL               YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n     $                   DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n     $                   DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n     $                   EPS, HUGEVAL, INCR_THRESH\n      LOGICAL            INCR_PREC\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.sla_porfsx_extended( prec_type, uplo, a, af, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 20 && argc != 20)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 20)", argc);
  rblapack_prec_type = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_colequ = argv[4];
  rblapack_c = argv[5];
  rblapack_b = argv[6];
  rblapack_y = argv[7];
  rblapack_n_norms = argv[8];
  rblapack_err_bnds_norm = argv[9];
  rblapack_err_bnds_comp = argv[10];
  rblapack_res = argv[11];
  rblapack_ayb = argv[12];
  rblapack_dy = argv[13];
  rblapack_y_tail = argv[14];
  rblapack_rcond = argv[15];
  rblapack_ithresh = argv[16];
  rblapack_rthresh = argv[17];
  rblapack_dz_ub = argv[18];
  rblapack_ignore_cwise = argv[19];
  if (argc == 20) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  prec_type = NUM2INT(rblapack_prec_type);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  colequ = (rblapack_colequ == Qtrue);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  n_norms = NUM2INT(rblapack_n_norms);
  if (!NA_IsNArray(rblapack_err_bnds_comp))
    rb_raise(rb_eArgError, "err_bnds_comp (11th argument) must be NArray");
  if (NA_RANK(rblapack_err_bnds_comp) != 2)
    rb_raise(rb_eArgError, "rank of err_bnds_comp (11th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_err_bnds_comp) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of b");
  n_err_bnds = NA_SHAPE1(rblapack_err_bnds_comp);
  if (NA_TYPE(rblapack_err_bnds_comp) != NA_SFLOAT)
    rblapack_err_bnds_comp = na_change_type(rblapack_err_bnds_comp, NA_SFLOAT);
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
  if (!NA_IsNArray(rblapack_ayb))
    rb_raise(rb_eArgError, "ayb (13th argument) must be NArray");
  if (NA_RANK(rblapack_ayb) != 1)
    rb_raise(rb_eArgError, "rank of ayb (13th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ayb) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ayb) != NA_SFLOAT)
    rblapack_ayb = na_change_type(rblapack_ayb, NA_SFLOAT);
  ayb = NA_PTR_TYPE(rblapack_ayb, real*);
  if (!NA_IsNArray(rblapack_y_tail))
    rb_raise(rb_eArgError, "y_tail (15th argument) must be NArray");
  if (NA_RANK(rblapack_y_tail) != 1)
    rb_raise(rb_eArgError, "rank of y_tail (15th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y_tail) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_y_tail) != NA_SFLOAT)
    rblapack_y_tail = na_change_type(rblapack_y_tail, NA_SFLOAT);
  y_tail = NA_PTR_TYPE(rblapack_y_tail, real*);
  ithresh = NUM2INT(rblapack_ithresh);
  dz_ub = (real)NUM2DBL(rblapack_dz_ub);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_err_bnds_norm))
    rb_raise(rb_eArgError, "err_bnds_norm (10th argument) must be NArray");
  if (NA_RANK(rblapack_err_bnds_norm) != 2)
    rb_raise(rb_eArgError, "rank of err_bnds_norm (10th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_err_bnds_norm) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of b");
  if (NA_SHAPE1(rblapack_err_bnds_norm) != n_err_bnds)
    rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_norm must be the same as shape 1 of err_bnds_comp");
  if (NA_TYPE(rblapack_err_bnds_norm) != NA_SFLOAT)
    rblapack_err_bnds_norm = na_change_type(rblapack_err_bnds_norm, NA_SFLOAT);
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
  if (!NA_IsNArray(rblapack_dy))
    rb_raise(rb_eArgError, "dy (14th argument) must be NArray");
  if (NA_RANK(rblapack_dy) != 1)
    rb_raise(rb_eArgError, "rank of dy (14th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dy) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_dy) != NA_SFLOAT)
    rblapack_dy = na_change_type(rblapack_dy, NA_SFLOAT);
  dy = NA_PTR_TYPE(rblapack_dy, real*);
  rthresh = (real)NUM2DBL(rblapack_rthresh);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
  af = NA_PTR_TYPE(rblapack_af, real*);
  if (!NA_IsNArray(rblapack_res))
    rb_raise(rb_eArgError, "res (12th argument) must be NArray");
  if (NA_RANK(rblapack_res) != 1)
    rb_raise(rb_eArgError, "rank of res (12th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_res) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_res) != NA_SFLOAT)
    rblapack_res = na_change_type(rblapack_res, NA_SFLOAT);
  res = NA_PTR_TYPE(rblapack_res, real*);
  ignore_cwise = (rblapack_ignore_cwise == Qtrue);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (8th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 2)
    rb_raise(rb_eArgError, "rank of y (8th argument) must be %d", 2);
  ldy = NA_SHAPE0(rblapack_y);
  if (NA_SHAPE1(rblapack_y) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_y) != NA_SFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
  y = NA_PTR_TYPE(rblapack_y, real*);
  rcond = (real)NUM2DBL(rblapack_rcond);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr_out = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr_out = NA_PTR_TYPE(rblapack_berr_out, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldy;
    shape[1] = nrhs;
    rblapack_y_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
  MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm_out__ = NA_PTR_TYPE(rblapack_err_bnds_norm_out__, real*);
  MEMCPY(err_bnds_norm_out__, err_bnds_norm, real, NA_TOTAL(rblapack_err_bnds_norm));
  rblapack_err_bnds_norm = rblapack_err_bnds_norm_out__;
  err_bnds_norm = err_bnds_norm_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp_out__ = NA_PTR_TYPE(rblapack_err_bnds_comp_out__, real*);
  MEMCPY(err_bnds_comp_out__, err_bnds_comp, real, NA_TOTAL(rblapack_err_bnds_comp));
  rblapack_err_bnds_comp = rblapack_err_bnds_comp_out__;
  err_bnds_comp = err_bnds_comp_out__;

  sla_porfsx_extended_(&prec_type, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_err_bnds_norm, rblapack_err_bnds_comp);
}

void
init_lapack_sla_porfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sla_porfsx_extended", rblapack_sla_porfsx_extended, -1);
}
ruby-lapack-1.7.2/ext/zgerqf.c0000644000175000017500000001372012502221023016021 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgerqf_(integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zgerqf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *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.zgerqf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGERQF computes an RQ factorization of a complex M-by-N matrix A:\n*  A = R * 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) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit,\n*          if m <= n, the upper triangle of the subarray\n*          A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R;\n*          if m >= n, the elements on and above the (m-n)-th subdiagonal\n*          contain the M-by-N upper trapezoidal matrix R;\n*          the remaining elements, with the array TAU, represent the\n*          unitary matrix Q as a product of min(m,n) elementary\n*          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) COMPLEX*16 array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace/output) COMPLEX*16 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\n*          the 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(1)' H(2)' . . . H(k)', 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 complex scalar, and v is a complex vector with\n*  v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on\n*  exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i).\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY\n      INTEGER            I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n     $                   MU, NB, NBMIN, NU, NX\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZGERQ2, ZLARFB, ZLARFT\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.zgerqf( 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;
  }

  m = NUM2INT(rblapack_m);
  if (rblapack_lwork == Qnil)
    lwork = m;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zgerqf_(&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_zgerqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgerqf", rblapack_zgerqf, -1);
}
ruby-lapack-1.7.2/ext/cggev.c0000644000175000017500000002402212502221012015611 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cggev_(char* jobvl, char* jobvr, integer* n, complex* a, integer* lda, complex* b, integer* ldb, complex* alpha, complex* beta, complex* vl, integer* ldvl, complex* vr, integer* ldvr, complex* work, integer* lwork, real* rwork, integer* info);


static VALUE
rblapack_cggev(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvl;
  char jobvl; 
  VALUE rblapack_jobvr;
  char jobvr; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_alpha;
  complex *alpha; 
  VALUE rblapack_beta;
  complex *beta; 
  VALUE rblapack_vl;
  complex *vl; 
  VALUE rblapack_vr;
  complex *vr; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_rwork;
  real *rwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer ldvl;
  integer ldvr;

  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  alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.cggev( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGGEV computes for a pair of N-by-N complex nonsymmetric matrices\n*  (A,B), the generalized eigenvalues, and optionally, the left and/or\n*  right generalized eigenvectors.\n*\n*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n*  lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n*  singular. It is usually represented as the pair (alpha,beta), as\n*  there is a reasonable interpretation for beta=0, and even for both\n*  being zero.\n*\n*  The right generalized eigenvector v(j) corresponding to the\n*  generalized eigenvalue lambda(j) of (A,B) satisfies\n*\n*               A * v(j) = lambda(j) * B * v(j).\n*\n*  The left generalized eigenvector u(j) corresponding to the\n*  generalized eigenvalues lambda(j) of (A,B) satisfies\n*\n*               u(j)**H * A = lambda(j) * u(j)**H * B\n*\n*  where u(j)**H is the conjugate-transpose of u(j).\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVL   (input) CHARACTER*1\n*          = 'N':  do not compute the left generalized eigenvectors;\n*          = 'V':  compute the left generalized eigenvectors.\n*\n*  JOBVR   (input) CHARACTER*1\n*          = 'N':  do not compute the right generalized eigenvectors;\n*          = 'V':  compute the right generalized eigenvectors.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A, B, VL, and VR.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA, N)\n*          On entry, the matrix A in the pair (A,B).\n*          On exit, A has been overwritten.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of A.  LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX array, dimension (LDB, N)\n*          On entry, the matrix B in the pair (A,B).\n*          On exit, B has been overwritten.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of B.  LDB >= max(1,N).\n*\n*  ALPHA   (output) COMPLEX array, dimension (N)\n*  BETA    (output) COMPLEX array, dimension (N)\n*          On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the\n*          generalized eigenvalues.\n*\n*          Note: the quotients ALPHA(j)/BETA(j) may easily over- or\n*          underflow, and BETA(j) may even be zero.  Thus, the user\n*          should avoid naively computing the ratio alpha/beta.\n*          However, ALPHA will be always less than and usually\n*          comparable with norm(A) in magnitude, and BETA always less\n*          than and usually comparable with norm(B).\n*\n*  VL      (output) COMPLEX array, dimension (LDVL,N)\n*          If JOBVL = 'V', the left generalized eigenvectors u(j) are\n*          stored one after another in the columns of VL, in the same\n*          order as their eigenvalues.\n*          Each eigenvector is scaled so the largest component has\n*          abs(real part) + abs(imag. part) = 1.\n*          Not referenced if JOBVL = 'N'.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the matrix VL. LDVL >= 1, and\n*          if JOBVL = 'V', LDVL >= N.\n*\n*  VR      (output) COMPLEX array, dimension (LDVR,N)\n*          If JOBVR = 'V', the right generalized eigenvectors v(j) are\n*          stored one after another in the columns of VR, in the same\n*          order as their eigenvalues.\n*          Each eigenvector is scaled so the largest component has\n*          abs(real part) + abs(imag. part) = 1.\n*          Not referenced if JOBVR = 'N'.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the matrix VR. LDVR >= 1, and\n*          if JOBVR = 'V', LDVR >= N.\n*\n*  WORK    (workspace/output) COMPLEX 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,2*N).\n*          For good performance, LWORK must generally be larger.\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*  RWORK   (workspace/output) REAL array, dimension (8*N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          =1,...,N:\n*                The QZ iteration failed.  No eigenvectors have been\n*                calculated, but ALPHA(j) and BETA(j) should be\n*                correct for j=INFO+1,...,N.\n*          > N:  =N+1: other then QZ iteration failed in SHGEQZ,\n*                =N+2: error return from STGEVC.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.cggev( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_jobvl = argv[0];
  rblapack_jobvr = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  jobvl = StringValueCStr(rblapack_jobvl)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  jobvr = StringValueCStr(rblapack_jobvr)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  ldvr = lsame_(&jobvr,"V") ? n : 1;
  if (rblapack_lwork == Qnil)
    lwork = MAX(1,2*n);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldvl = lsame_(&jobvl,"V") ? n : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  alpha = NA_PTR_TYPE(rblapack_alpha, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = n;
    rblapack_vl = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  vl = NA_PTR_TYPE(rblapack_vl, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = n;
    rblapack_vr = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  vr = NA_PTR_TYPE(rblapack_vr, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[1];
    shape[0] = 8*n;
    rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  rwork = NA_PTR_TYPE(rblapack_rwork, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  cggev_(&jobvl, &jobvr, &n, a, &lda, b, &ldb, alpha, beta, vl, &ldvl, vr, &ldvr, work, &lwork, rwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_alpha, rblapack_beta, rblapack_vl, rblapack_vr, rblapack_work, rblapack_rwork, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_cggev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cggev", rblapack_cggev, -1);
}
ruby-lapack-1.7.2/ext/cggrqf.c0000644000175000017500000002334112502221025015776 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cggrqf_(integer* m, integer* p, integer* n, complex* a, integer* lda, complex* taua, complex* b, integer* ldb, complex* taub, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_cggrqf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_p;
  integer p; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_taua;
  complex *taua; 
  VALUE rblapack_taub;
  complex *taub; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer lda;
  integer n;
  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  taua, taub, work, info, a, b = NumRu::Lapack.cggrqf( m, p, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGGRQF computes a generalized RQ factorization of an M-by-N matrix A\n*  and a P-by-N matrix B:\n*\n*              A = R*Q,        B = Z*T*Q,\n*\n*  where Q is an N-by-N unitary matrix, Z is a P-by-P unitary\n*  matrix, and R and T assume one of the forms:\n*\n*  if M <= N,  R = ( 0  R12 ) M,   or if M > N,  R = ( R11 ) M-N,\n*                   N-M  M                           ( R21 ) N\n*                                                       N\n*\n*  where R12 or R21 is upper triangular, and\n*\n*  if P >= N,  T = ( T11 ) N  ,   or if P < N,  T = ( T11  T12 ) P,\n*                  (  0  ) P-N                         P   N-P\n*                     N\n*\n*  where T11 is upper triangular.\n*\n*  In particular, if B is square and nonsingular, the GRQ factorization\n*  of A and B implicitly gives the RQ factorization of A*inv(B):\n*\n*               A*inv(B) = (R*inv(T))*Z'\n*\n*  where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n*  conjugate transpose of the matrix Z.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.  M >= 0.\n*\n*  P       (input) INTEGER\n*          The number of rows of the matrix B.  P >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrices A and B. N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, if M <= N, the upper triangle of the subarray\n*          A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;\n*          if M > N, the elements on and above the (M-N)-th subdiagonal\n*          contain the M-by-N upper trapezoidal matrix R; the remaining\n*          elements, with the array TAUA, represent the unitary\n*          matrix Q as a product of elementary reflectors (see Further\n*          Details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  TAUA    (output) COMPLEX array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors which\n*          represent the unitary matrix Q (see Further Details).\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,N)\n*          On entry, the P-by-N matrix B.\n*          On exit, the elements on and above the diagonal of the array\n*          contain the min(P,N)-by-N upper trapezoidal matrix T (T is\n*          upper triangular if P >= N); the elements below the diagonal,\n*          with the array TAUB, represent the unitary matrix Z as a\n*          product of elementary reflectors (see Further Details).\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,P).\n*\n*  TAUB    (output) COMPLEX array, dimension (min(P,N))\n*          The scalar factors of the elementary reflectors which\n*          represent the unitary matrix Z (see Further Details).\n*\n*  WORK    (workspace/output) COMPLEX 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,N,M,P).\n*          For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n*          where NB1 is the optimal blocksize for the RQ factorization\n*          of an M-by-N matrix, NB2 is the optimal blocksize for the\n*          QR factorization of a P-by-N matrix, and NB3 is the optimal\n*          blocksize for a call of CUNMRQ.\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(1) H(2) . . . H(k), where k = min(m,n).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - taua * v * v'\n*\n*  where taua is a complex scalar, and v is a complex vector with\n*  v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n*  A(m-k+i,1:n-k+i-1), and taua in TAUA(i).\n*  To form Q explicitly, use LAPACK subroutine CUNGRQ.\n*  To use Q to update another matrix, use LAPACK subroutine CUNMRQ.\n*\n*  The matrix Z is represented as a product of elementary reflectors\n*\n*     Z = H(1) H(2) . . . H(k), where k = min(p,n).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - taub * v * v'\n*\n*  where taub is a complex scalar, and v is a complex vector with\n*  v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),\n*  and taub in TAUB(i).\n*  To form Z explicitly, use LAPACK subroutine CUNGQR.\n*  To use Z to update another matrix, use LAPACK subroutine CUNMQR.\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY\n      INTEGER            LOPT, LWKOPT, NB, NB1, NB2, NB3\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CGEQRF, CGERQF, CUNMRQ, XERBLA\n*     ..\n*     .. External Functions ..\n      INTEGER            ILAENV \n      EXTERNAL           ILAENV\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          INT, MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  taua, taub, work, info, a, b = NumRu::Lapack.cggrqf( m, p, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_m = argv[0];
  rblapack_p = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  p = NUM2INT(rblapack_p);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (rblapack_lwork == Qnil)
    lwork = MAX(MAX(n,m),p);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_taua = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  taua = NA_PTR_TYPE(rblapack_taua, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(p,n);
    rblapack_taub = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  taub = NA_PTR_TYPE(rblapack_taub, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  cggrqf_(&m, &p, &n, a, &lda, taua, b, &ldb, taub, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_taua, rblapack_taub, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_cggrqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cggrqf", rblapack_cggrqf, -1);
}
ruby-lapack-1.7.2/ext/cporfs.c0000644000175000017500000001765712502221025016036 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cporfs_(char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, complex* b, integer* ldb, complex* x, integer* ldx, real* ferr, real* berr, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cporfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  complex *x_out__;
  complex *work;
  real *rwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.cporfs( uplo, a, af, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPORFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is Hermitian positive definite,\n*  and provides error bounds and backward error estimates for the\n*  solution.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The Hermitian matrix A.  If UPLO = 'U', the leading N-by-N\n*          upper triangular part of A contains the upper triangular part\n*          of the matrix A, and the strictly lower triangular part of A\n*          is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*          triangular part of A contains the lower triangular part of\n*          the matrix A, and the strictly upper triangular part of A is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AF      (input) COMPLEX array, dimension (LDAF,N)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**H*U or A = L*L**H, as computed by CPOTRF.\n*\n*  LDAF    (input) INTEGER\n*          The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*  B       (input) COMPLEX array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) COMPLEX array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by CPOTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  ====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.cporfs( uplo, a, af, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_b = argv[3];
  rblapack_x = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (5th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (n));

  cporfs_(&uplo, &n, &nrhs, a, &lda, af, &ldaf, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_cporfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cporfs", rblapack_cporfs, -1);
}
ruby-lapack-1.7.2/ext/dtgexc.c0000644000175000017500000002565512502221017016016 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtgexc_(logical* wantq, logical* wantz, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* q, integer* ldq, doublereal* z, integer* ldz, integer* ifst, integer* ilst, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dtgexc(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantq;
  logical wantq; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_q;
  doublereal *q; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_ifst;
  integer ifst; 
  VALUE rblapack_ilst;
  integer ilst; 
  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__;
  VALUE rblapack_q_out__;
  doublereal *q_out__;
  VALUE rblapack_z_out__;
  doublereal *z_out__;

  integer lda;
  integer n;
  integer ldb;
  integer ldq;
  integer ldz;

  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, q, z, ifst, ilst = NumRu::Lapack.dtgexc( wantq, wantz, a, b, q, z, ifst, ilst, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, IFST, ILST, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTGEXC reorders the generalized real Schur decomposition of a real\n*  matrix pair (A,B) using an orthogonal equivalence transformation\n*\n*                 (A, B) = Q * (A, B) * Z',\n*\n*  so that the diagonal block of (A, B) with row index IFST is moved\n*  to row ILST.\n*\n*  (A, B) must be in generalized real Schur canonical form (as returned\n*  by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2\n*  diagonal blocks. B is upper triangular.\n*\n*  Optionally, the matrices Q and Z of generalized Schur vectors are\n*  updated.\n*\n*         Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n*         Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n*\n*\n\n*  Arguments\n*  =========\n*\n*  WANTQ   (input) LOGICAL\n*          .TRUE. : update the left transformation matrix Q;\n*          .FALSE.: do not update Q.\n*\n*  WANTZ   (input) LOGICAL\n*          .TRUE. : update the right transformation matrix Z;\n*          .FALSE.: do not update Z.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B. N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the matrix A in generalized real Schur canonical\n*          form.\n*          On exit, the updated matrix A, again in generalized\n*          real Schur canonical form.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)\n*          On entry, the matrix B in generalized real Schur canonical\n*          form (A,B).\n*          On exit, the updated matrix B, again in generalized\n*          real Schur canonical form (A,B).\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n*          On entry, if WANTQ = .TRUE., the orthogonal matrix Q.\n*          On exit, the updated matrix Q.\n*          If WANTQ = .FALSE., Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q. LDQ >= 1.\n*          If WANTQ = .TRUE., LDQ >= N.\n*\n*  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n*          On entry, if WANTZ = .TRUE., the orthogonal matrix Z.\n*          On exit, the updated matrix Z.\n*          If WANTZ = .FALSE., Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z. LDZ >= 1.\n*          If WANTZ = .TRUE., LDZ >= N.\n*\n*  IFST    (input/output) INTEGER\n*  ILST    (input/output) INTEGER\n*          Specify the reordering of the diagonal blocks of (A, B).\n*          The block with row index IFST is moved to row ILST, by a\n*          sequence of swapping between adjacent blocks.\n*          On exit, if IFST pointed on entry to the second row of\n*          a 2-by-2 block, it is changed to point to the first row;\n*          ILST always points to the first row of the block in its\n*          final position (which may differ from its input value by\n*          +1 or -1). 1 <= IFST, ILST <= 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 >= 1 when N <= 1, otherwise LWORK >= 4*N + 16.\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*           =1:  The transformed matrix pair (A, B) would be too far\n*                from generalized Schur form; the problem is ill-\n*                conditioned. (A, B) may have been partially reordered,\n*                and ILST points to the first row of the current\n*                position of the block being moved.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n*      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n*      M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n*      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, a, b, q, z, ifst, ilst = NumRu::Lapack.dtgexc( wantq, wantz, a, b, q, z, ifst, ilst, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_wantq = argv[0];
  rblapack_wantz = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  rblapack_q = argv[4];
  rblapack_z = argv[5];
  rblapack_ifst = argv[6];
  rblapack_ilst = argv[7];
  if (argc == 9) {
    rblapack_lwork = argv[8];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  wantq = (rblapack_wantq == Qtrue);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (5th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_q) != NA_DFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
  q = NA_PTR_TYPE(rblapack_q, doublereal*);
  ifst = NUM2INT(rblapack_ifst);
  wantz = (rblapack_wantz == Qtrue);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (6th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (6th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  if (NA_SHAPE1(rblapack_z) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  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 = n<=1 ? 1 : 4*n+16;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ilst = NUM2INT(rblapack_ilst);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
  MEMCPY(q_out__, q, doublereal, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
  MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  dtgexc_(&wantq, &wantz, &n, a, &lda, b, &ldb, q, &ldq, z, &ldz, &ifst, &ilst, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  rblapack_ifst = INT2NUM(ifst);
  rblapack_ilst = INT2NUM(ilst);
  return rb_ary_new3(8, rblapack_work, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z, rblapack_ifst, rblapack_ilst);
}

void
init_lapack_dtgexc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtgexc", rblapack_dtgexc, -1);
}
ruby-lapack-1.7.2/ext/spoequb.c0000644000175000017500000000775012502221024016210 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID spoequb_(integer* n, real* a, integer* lda, real* s, real* scond, real* amax, integer* info);


static VALUE
rblapack_spoequb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_scond;
  real scond; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_info;
  integer info; 

  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  s, scond, amax, info = NumRu::Lapack.spoequb( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPOEQU computes row and column scalings intended to equilibrate a\n*  symmetric positive definite matrix A and reduce its condition number\n*  (with respect to the two-norm).  S contains the scale factors,\n*  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n*  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This\n*  choice of S puts the condition number of B within a factor N of the\n*  smallest possible condition number over all possible diagonal\n*  scalings.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) REAL array, dimension (LDA,N)\n*          The N-by-N symmetric positive definite matrix whose scaling\n*          factors are to be computed.  Only the diagonal elements of A\n*          are referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  S       (output) REAL array, dimension (N)\n*          If INFO = 0, S contains the scale factors for A.\n*\n*  SCOND   (output) REAL\n*          If INFO = 0, S contains the ratio of the smallest S(i) to\n*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too\n*          large nor too small, it is not worth scaling by S.\n*\n*  AMAX    (output) REAL\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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 is nonpositive.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, scond, amax, info = NumRu::Lapack.spoequb( 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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, real*);

  spoequb_(&n, a, &lda, s, &scond, &amax, &info);

  rblapack_scond = rb_float_new((double)scond);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
}

void
init_lapack_spoequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "spoequb", rblapack_spoequb, -1);
}
ruby-lapack-1.7.2/ext/cuncsd.c0000644000175000017500000003110312502221025015777 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cuncsd_(char* jobu1, char* jobu2, char* jobv1t, char* jobv2t, char* trans, char* signs, integer* m, integer* p, integer* q, complex* x11, integer* ldx11, complex* x12, integer* ldx12, complex* x21, integer* ldx21, complex* x22, integer* ldx22, real* theta, complex* u1, integer* ldu1, complex* u2, integer* ldu2, complex* v1t, integer* ldv1t, complex* v2t, integer* ldv2t, complex* work, integer* lwork, real* rwork, integer* lrwork, integer* iwork, integer* info);


static VALUE
rblapack_cuncsd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobu1;
  char jobu1; 
  VALUE rblapack_jobu2;
  char jobu2; 
  VALUE rblapack_jobv1t;
  char jobv1t; 
  VALUE rblapack_jobv2t;
  char jobv2t; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_signs;
  char signs; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_x11;
  complex *x11; 
  VALUE rblapack_x12;
  complex *x12; 
  VALUE rblapack_x21;
  complex *x21; 
  VALUE rblapack_x22;
  complex *x22; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_lrwork;
  integer lrwork; 
  VALUE rblapack_theta;
  real *theta; 
  VALUE rblapack_u1;
  complex *u1; 
  VALUE rblapack_u2;
  complex *u2; 
  VALUE rblapack_v1t;
  complex *v1t; 
  VALUE rblapack_v2t;
  complex *v2t; 
  VALUE rblapack_info;
  integer info; 
  complex *work;
  real *rwork;
  integer *iwork;

  integer p;
  integer q;
  integer ldv2t;
  integer ldv1t;
  integer ldu1;
  integer ldu2;
  integer ldx11;
  integer ldx12;
  integer ldx21;
  integer ldx22;

  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  theta, u1, u2, v1t, v2t, info = NumRu::Lapack.cuncsd( jobu1, jobu2, jobv1t, jobv2t, trans, signs, m, x11, x12, x21, x22, lwork, lrwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      RECURSIVE SUBROUTINE CUNCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, WORK, LWORK, RWORK, LRWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CUNCSD computes the CS decomposition of an M-by-M partitioned\n*  unitary matrix X:\n*\n*                                  [  I  0  0 |  0  0  0 ]\n*                                  [  0  C  0 |  0 -S  0 ]\n*      [ X11 | X12 ]   [ U1 |    ] [  0  0  0 |  0  0 -I ] [ V1 |    ]**H\n*  X = [-----------] = [---------] [---------------------] [---------]   .\n*      [ X21 | X22 ]   [    | U2 ] [  0  0  0 |  I  0  0 ] [    | V2 ]\n*                                  [  0  S  0 |  0  C  0 ]\n*                                  [  0  0  I |  0  0  0 ]\n*\n*  X11 is P-by-Q. The unitary matrices U1, U2, V1, and V2 are P-by-P,\n*  (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are\n*  R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in\n*  which R = MIN(P,M-P,Q,M-Q).\n*\n\n*  Arguments\n*  =========\n*\n*  JOBU1   (input) CHARACTER\n*          = 'Y':      U1 is computed;\n*          otherwise:  U1 is not computed.\n*\n*  JOBU2   (input) CHARACTER\n*          = 'Y':      U2 is computed;\n*          otherwise:  U2 is not computed.\n*\n*  JOBV1T  (input) CHARACTER\n*          = 'Y':      V1T is computed;\n*          otherwise:  V1T is not computed.\n*\n*  JOBV2T  (input) CHARACTER\n*          = 'Y':      V2T is computed;\n*          otherwise:  V2T is not computed.\n*\n*  TRANS   (input) CHARACTER\n*          = 'T':      X, U1, U2, V1T, and V2T are stored in row-major\n*                      order;\n*          otherwise:  X, U1, U2, V1T, and V2T are stored in column-\n*                      major order.\n*\n*  SIGNS   (input) CHARACTER\n*          = 'O':      The lower-left block is made nonpositive (the\n*                      \"other\" convention);\n*          otherwise:  The upper-right block is made nonpositive (the\n*                      \"default\" convention).\n*\n*  M       (input) INTEGER\n*          The number of rows and columns in X.\n*\n*  P       (input) INTEGER\n*          The number of rows in X11 and X12. 0 <= P <= M.\n*\n*  Q       (input) INTEGER\n*          The number of columns in X11 and X21. 0 <= Q <= M.\n*\n*  X       (input/workspace) COMPLEX array, dimension (LDX,M)\n*          On entry, the unitary matrix whose CSD is desired.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of X. LDX >= MAX(1,M).\n*\n*  THETA   (output) REAL array, dimension (R), in which R =\n*          MIN(P,M-P,Q,M-Q).\n*          C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and\n*          S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).\n*\n*  U1      (output) COMPLEX array, dimension (P)\n*          If JOBU1 = 'Y', U1 contains the P-by-P unitary matrix U1.\n*\n*  LDU1    (input) INTEGER\n*          The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=\n*          MAX(1,P).\n*\n*  U2      (output) COMPLEX array, dimension (M-P)\n*          If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) unitary\n*          matrix U2.\n*\n*  LDU2    (input) INTEGER\n*          The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=\n*          MAX(1,M-P).\n*\n*  V1T     (output) COMPLEX array, dimension (Q)\n*          If JOBV1T = 'Y', V1T contains the Q-by-Q matrix unitary\n*          matrix V1**H.\n*\n*  LDV1T   (input) INTEGER\n*          The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=\n*          MAX(1,Q).\n*\n*  V2T     (output) COMPLEX array, dimension (M-Q)\n*          If JOBV2T = 'Y', V2T contains the (M-Q)-by-(M-Q) unitary\n*          matrix V2**H.\n*\n*  LDV2T   (input) INTEGER\n*          The leading dimension of V2T. If JOBV2T = 'Y', LDV2T >=\n*          MAX(1,M-Q).\n*\n*  WORK    (workspace) COMPLEX 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*\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*  RWORK   (workspace) REAL array, dimension MAX(1,LRWORK)\n*          On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n*          If INFO > 0 on exit, RWORK(2:R) contains the values PHI(1),\n*          ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),\n*          define the matrix in intermediate bidiagonal-block form\n*          remaining after nonconvergence. INFO specifies the number\n*          of nonzero PHI's.\n*\n*  LRWORK  (input) INTEGER\n*          The dimension of the array RWORK.\n*\n*          If LRWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal size of the RWORK array, returns\n*          this value as the first entry of the work array, and no error\n*          message related to LRWORK is issued by XERBLA.\n*\n*  IWORK   (workspace) INTEGER array, dimension (M-Q)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit.\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          > 0:  CBBCSD did not converge. See the description of RWORK\n*                above for details.\n*\n*  Reference\n*  =========\n*\n*  [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.\n*      Algorithms, 50(1):33-65, 2009.\n*\n\n*  ===================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  theta, u1, u2, v1t, v2t, info = NumRu::Lapack.cuncsd( jobu1, jobu2, jobv1t, jobv2t, trans, signs, m, x11, x12, x21, x22, lwork, lrwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 13 && argc != 13)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 13)", argc);
  rblapack_jobu1 = argv[0];
  rblapack_jobu2 = argv[1];
  rblapack_jobv1t = argv[2];
  rblapack_jobv2t = argv[3];
  rblapack_trans = argv[4];
  rblapack_signs = argv[5];
  rblapack_m = argv[6];
  rblapack_x11 = argv[7];
  rblapack_x12 = argv[8];
  rblapack_x21 = argv[9];
  rblapack_x22 = argv[10];
  rblapack_lwork = argv[11];
  rblapack_lrwork = argv[12];
  if (argc == 13) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobu1 = StringValueCStr(rblapack_jobu1)[0];
  jobv1t = StringValueCStr(rblapack_jobv1t)[0];
  trans = StringValueCStr(rblapack_trans)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_x21))
    rb_raise(rb_eArgError, "x21 (10th argument) must be NArray");
  if (NA_RANK(rblapack_x21) != 2)
    rb_raise(rb_eArgError, "rank of x21 (10th argument) must be %d", 2);
  p = NA_SHAPE0(rblapack_x21);
  q = NA_SHAPE1(rblapack_x21);
  if (NA_TYPE(rblapack_x21) != NA_SCOMPLEX)
    rblapack_x21 = na_change_type(rblapack_x21, NA_SCOMPLEX);
  x21 = NA_PTR_TYPE(rblapack_x21, complex*);
  lwork = NUM2INT(rblapack_lwork);
  jobu2 = StringValueCStr(rblapack_jobu2)[0];
  signs = StringValueCStr(rblapack_signs)[0];
  lrwork = NUM2INT(rblapack_lrwork);
  jobv2t = StringValueCStr(rblapack_jobv2t)[0];
  if (!NA_IsNArray(rblapack_x11))
    rb_raise(rb_eArgError, "x11 (8th argument) must be NArray");
  if (NA_RANK(rblapack_x11) != 2)
    rb_raise(rb_eArgError, "rank of x11 (8th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_x11) != p)
    rb_raise(rb_eRuntimeError, "shape 0 of x11 must be the same as shape 0 of x21");
  if (NA_SHAPE1(rblapack_x11) != q)
    rb_raise(rb_eRuntimeError, "shape 1 of x11 must be the same as shape 1 of x21");
  if (NA_TYPE(rblapack_x11) != NA_SCOMPLEX)
    rblapack_x11 = na_change_type(rblapack_x11, NA_SCOMPLEX);
  x11 = NA_PTR_TYPE(rblapack_x11, complex*);
  if (!NA_IsNArray(rblapack_x22))
    rb_raise(rb_eArgError, "x22 (11th argument) must be NArray");
  if (NA_RANK(rblapack_x22) != 2)
    rb_raise(rb_eArgError, "rank of x22 (11th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_x22) != p)
    rb_raise(rb_eRuntimeError, "shape 0 of x22 must be the same as shape 0 of x21");
  if (NA_SHAPE1(rblapack_x22) != (m-q))
    rb_raise(rb_eRuntimeError, "shape 1 of x22 must be %d", m-q);
  if (NA_TYPE(rblapack_x22) != NA_SCOMPLEX)
    rblapack_x22 = na_change_type(rblapack_x22, NA_SCOMPLEX);
  x22 = NA_PTR_TYPE(rblapack_x22, complex*);
  ldv1t = lsame_(&jobv1t,"Y") ? MAX(1,q) : 0;
  if (!NA_IsNArray(rblapack_x12))
    rb_raise(rb_eArgError, "x12 (9th argument) must be NArray");
  if (NA_RANK(rblapack_x12) != 2)
    rb_raise(rb_eArgError, "rank of x12 (9th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_x12) != p)
    rb_raise(rb_eRuntimeError, "shape 0 of x12 must be the same as shape 0 of x21");
  if (NA_SHAPE1(rblapack_x12) != (m-q))
    rb_raise(rb_eRuntimeError, "shape 1 of x12 must be %d", m-q);
  if (NA_TYPE(rblapack_x12) != NA_SCOMPLEX)
    rblapack_x12 = na_change_type(rblapack_x12, NA_SCOMPLEX);
  x12 = NA_PTR_TYPE(rblapack_x12, complex*);
  ldu1 = lsame_(&jobu1,"Y") ?   MAX(1,p) : 0;
  ldx11 = p;
  ldx21 = p;
  ldv2t = lsame_(&jobv2t,"Y") ? MAX(1,m-q) : 0;
  ldx12 = p;
  ldu2 = lsame_(&jobu2,"Y") ?  MAX(1,m-p) : 0;
  ldx22 = p;
  {
    na_shape_t shape[1];
    shape[0] = MIN(MIN(MIN(p,m-p),q),m-q);
    rblapack_theta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  theta = NA_PTR_TYPE(rblapack_theta, real*);
  {
    na_shape_t shape[1];
    shape[0] = p;
    rblapack_u1 = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  u1 = NA_PTR_TYPE(rblapack_u1, complex*);
  {
    na_shape_t shape[1];
    shape[0] = m-p;
    rblapack_u2 = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  u2 = NA_PTR_TYPE(rblapack_u2, complex*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_v1t = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  v1t = NA_PTR_TYPE(rblapack_v1t, complex*);
  {
    na_shape_t shape[1];
    shape[0] = m-q;
    rblapack_v2t = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  v2t = NA_PTR_TYPE(rblapack_v2t, complex*);
  work = ALLOC_N(complex, (MAX(1,lwork)));
  rwork = ALLOC_N(real, (MAX(1,lrwork)));
  iwork = ALLOC_N(integer, (m-q));

  cuncsd_(&jobu1, &jobu2, &jobv1t, &jobv2t, &trans, &signs, &m, &p, &q, x11, &ldx11, x12, &ldx12, x21, &ldx21, x22, &ldx22, theta, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, v2t, &ldv2t, work, &lwork, rwork, &lrwork, iwork, &info);

  free(work);
  free(rwork);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_theta, rblapack_u1, rblapack_u2, rblapack_v1t, rblapack_v2t, rblapack_info);
}

void
init_lapack_cuncsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cuncsd", rblapack_cuncsd, -1);
}
ruby-lapack-1.7.2/ext/ssysvx.c0000644000175000017500000003326612502221020016106 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssysvx_(char* fact, char* uplo, integer* n, integer* nrhs, real* a, integer* lda, real* af, integer* ldaf, integer* ipiv, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* ferr, real* berr, real* work, integer* lwork, integer* iwork, integer* info);


static VALUE
rblapack_ssysvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_af;
  real *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_af_out__;
  real *af_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  integer *iwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.ssysvx( fact, uplo, a, af, ipiv, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSYSVX uses the diagonal pivoting factorization to compute the\n*  solution to a real system of linear equations A * X = B,\n*  where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n*  matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'N', the diagonal pivoting method is used to factor A.\n*     The form of the factorization is\n*        A = U * D * U**T,  if UPLO = 'U', or\n*        A = L * D * L**T,  if UPLO = 'L',\n*     where U (or L) is a product of permutation and unit upper (lower)\n*     triangular matrices, and D is symmetric and block diagonal with\n*     1-by-1 and 2-by-2 diagonal blocks.\n*\n*  2. If some D(i,i)=0, so that D is exactly singular, then the routine\n*     returns with INFO = i. Otherwise, the factored form of A is used\n*     to estimate the condition number of the matrix A.  If the\n*     reciprocal of the condition number is less than machine precision,\n*     INFO = N+1 is returned as a warning, but the routine still goes on\n*     to solve for X and compute error bounds as described below.\n*\n*  3. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  4. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of A has been\n*          supplied on entry.\n*          = 'F':  On entry, AF and IPIV contain the factored form of\n*                  A.  AF and IPIV will not be modified.\n*          = 'N':  The matrix A will be copied to AF and factored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input) REAL array, dimension (LDA,N)\n*          The symmetric matrix A.  If UPLO = 'U', the leading N-by-N\n*          upper triangular part of A contains the upper triangular part\n*          of the matrix A, and the strictly lower triangular part of A\n*          is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*          triangular part of A contains the lower triangular part of\n*          the matrix A, and the strictly upper triangular part of A is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AF      (input or output) REAL array, dimension (LDAF,N)\n*          If FACT = 'F', then AF is an input argument and on entry\n*          contains the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L from the factorization\n*          A = U*D*U**T or A = L*D*L**T as computed by SSYTRF.\n*\n*          If FACT = 'N', then AF is an output argument and on exit\n*          returns the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L from the factorization\n*          A = U*D*U**T or A = L*D*L**T.\n*\n*  LDAF    (input) INTEGER\n*          The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*  IPIV    (input or output) INTEGER array, dimension (N)\n*          If FACT = 'F', then IPIV is an input argument and on entry\n*          contains details of the interchanges and the block structure\n*          of D, as determined by SSYTRF.\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*          If FACT = 'N', then IPIV is an output argument and on exit\n*          contains details of the interchanges and the block structure\n*          of D, as determined by SSYTRF.\n*\n*  B       (input) REAL array, dimension (LDB,NRHS)\n*          The N-by-NRHS right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) REAL array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) REAL\n*          The estimate of the reciprocal condition number of the matrix\n*          A.  If RCOND is less than the machine precision (in\n*          particular, if RCOND = 0), the matrix is singular to working\n*          precision.  This condition is indicated by a return code of\n*          INFO > 0.\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace/output) REAL array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of WORK.  LWORK >= max(1,3*N), and for best\n*          performance, when FACT = 'N', LWORK >= max(1,3*N,N*NB), where\n*          NB is the optimal blocksize for SSYTRF.\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*  IWORK   (workspace) INTEGER array, dimension (N)\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, and i is\n*                <= N:  D(i,i) is exactly zero.  The factorization\n*                       has been completed but the factor D is exactly\n*                       singular, so the solution and error bounds could\n*                       not be computed. RCOND = 0 is returned.\n*                = N+1: D is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.ssysvx( fact, uplo, a, af, ipiv, b, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_b = argv[5];
  if (argc == 7) {
    rblapack_lwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
  af = NA_PTR_TYPE(rblapack_af, real*);
  ldx = MAX(1,n);
  if (rblapack_lwork == Qnil)
    lwork = 3*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldaf;
    shape[1] = n;
    rblapack_af_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  af_out__ = NA_PTR_TYPE(rblapack_af_out__, real*);
  MEMCPY(af_out__, af, real, NA_TOTAL(rblapack_af));
  rblapack_af = rblapack_af_out__;
  af = af_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  iwork = ALLOC_N(integer, (n));

  ssysvx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, &lwork, iwork, &info);

  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_work, rblapack_info, rblapack_af, rblapack_ipiv);
}

void
init_lapack_ssysvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssysvx", rblapack_ssysvx, -1);
}
ruby-lapack-1.7.2/ext/sdisna.c0000644000175000017500000001055512502221020016004 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sdisna_(char* job, integer* m, integer* n, real* d, real* sep, integer* info);


static VALUE
rblapack_sdisna(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_sep;
  real *sep; 
  VALUE rblapack_info;
  integer info; 

  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  sep, info = NumRu::Lapack.sdisna( job, n, d, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SDISNA( JOB, M, N, D, SEP, INFO )\n\n*  Purpose\n*  =======\n*\n*  SDISNA computes the reciprocal condition numbers for the eigenvectors\n*  of a real symmetric or complex Hermitian matrix or for the left or\n*  right singular vectors of a general m-by-n matrix. The reciprocal\n*  condition number is the 'gap' between the corresponding eigenvalue or\n*  singular value and the nearest other one.\n*\n*  The bound on the error, measured by angle in radians, in the I-th\n*  computed vector is given by\n*\n*         SLAMCH( 'E' ) * ( ANORM / SEP( I ) )\n*\n*  where ANORM = 2-norm(A) = max( abs( D(j) ) ).  SEP(I) is not allowed\n*  to be smaller than SLAMCH( 'E' )*ANORM in order to limit the size of\n*  the error bound.\n*\n*  SDISNA may also be used to compute error bounds for eigenvectors of\n*  the generalized symmetric definite eigenproblem.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies for which problem the reciprocal condition numbers\n*          should be computed:\n*          = 'E':  the eigenvectors of a symmetric/Hermitian matrix;\n*          = 'L':  the left singular vectors of a general matrix;\n*          = 'R':  the right singular vectors of a general matrix.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix. M >= 0.\n*\n*  N       (input) INTEGER\n*          If JOB = 'L' or 'R', the number of columns of the matrix,\n*          in which case N >= 0. Ignored if JOB = 'E'.\n*\n*  D       (input) REAL array, dimension (M) if JOB = 'E'\n*                              dimension (min(M,N)) if JOB = 'L' or 'R'\n*          The eigenvalues (if JOB = 'E') or singular values (if JOB =\n*          'L' or 'R') of the matrix, in either increasing or decreasing\n*          order. If singular values, they must be non-negative.\n*\n*  SEP     (output) REAL array, dimension (M) if JOB = 'E'\n*                               dimension (min(M,N)) if JOB = 'L' or 'R'\n*          The reciprocal condition numbers of the vectors.\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sep, info = NumRu::Lapack.sdisna( job, n, d, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_job = argv[0];
  rblapack_n = argv[1];
  rblapack_d = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  job = StringValueCStr(rblapack_job)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  n = NUM2INT(rblapack_n);
  {
    na_shape_t shape[1];
    shape[0] = lsame_(&job,"E") ? m : ((lsame_(&job,"L")) || (lsame_(&job,"R"))) ? MIN(m,n) : 0;
    rblapack_sep = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  sep = NA_PTR_TYPE(rblapack_sep, real*);

  sdisna_(&job, &m, &n, d, sep, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_sep, rblapack_info);
}

void
init_lapack_sdisna(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sdisna", rblapack_sdisna, -1);
}
ruby-lapack-1.7.2/ext/dorm2l.c0000644000175000017500000001437512502221015015732 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dorm2l_(char* side, char* trans, integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* c, integer* ldc, doublereal* work, integer* info);


static VALUE
rblapack_dorm2l(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublereal *c_out__;
  doublereal *work;

  integer lda;
  integer k;
  integer ldc;
  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  info, c = NumRu::Lapack.dorm2l( side, trans, m, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DORM2L overwrites the general real m by n matrix C with\n*\n*        Q * C  if SIDE = 'L' and TRANS = 'N', or\n*\n*        Q'* C  if SIDE = 'L' and TRANS = 'T', or\n*\n*        C * Q  if SIDE = 'R' and TRANS = 'N', or\n*\n*        C * Q' if SIDE = 'R' and TRANS = 'T',\n*\n*  where Q is a real orthogonal matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(k) . . . H(2) H(1)\n*\n*  as returned by DGEQLF. Q is of order m if SIDE = 'L' and of order n\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q' from the Left\n*          = 'R': apply Q or Q' from the Right\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': apply Q  (No transpose)\n*          = 'T': apply Q' (Transpose)\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,K)\n*          The i-th column must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          DGEQLF in the last k columns of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*          If SIDE = 'L', LDA >= max(1,M);\n*          if SIDE = 'R', LDA >= max(1,N).\n*\n*  TAU     (input) DOUBLE PRECISION array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by DGEQLF.\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n*          On entry, the m by n matrix C.\n*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension\n*                                   (N) if SIDE = 'L',\n*                                   (M) if SIDE = 'R'\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, c = NumRu::Lapack.dorm2l( side, trans, m, a, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_m = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != k)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  dorm2l_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_c);
}

void
init_lapack_dorm2l(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dorm2l", rblapack_dorm2l, -1);
}
ruby-lapack-1.7.2/ext/iladlr.c0000644000175000017500000000460412502221022015772 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern integer iladlr_(integer* m, integer* n, doublereal* a, integer* lda);


static VALUE
rblapack_iladlr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack___out__;
  integer __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  __out__ = NumRu::Lapack.iladlr( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      INTEGER FUNCTION ILADLR( M, N, A, LDA )\n\n*  Purpose\n*  =======\n*\n*  ILADLR scans A for its last non-zero row.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*          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\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.iladlr( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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*);

  __out__ = iladlr_(&m, &n, a, &lda);

  rblapack___out__ = INT2NUM(__out__);
  return rblapack___out__;
}

void
init_lapack_iladlr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "iladlr", rblapack_iladlr, -1);
}
ruby-lapack-1.7.2/ext/cptcon.c0000644000175000017500000001035112502221024016007 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cptcon_(integer* n, real* d, complex* e, real* anorm, real* rcond, real* rwork, integer* info);


static VALUE
rblapack_cptcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  complex *e; 
  VALUE rblapack_anorm;
  real anorm; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_info;
  integer info; 
  real *rwork;

  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  rcond, info = NumRu::Lapack.cptcon( d, e, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPTCON( N, D, E, ANORM, RCOND, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPTCON computes the reciprocal of the condition number (in the\n*  1-norm) of a complex Hermitian positive definite tridiagonal matrix\n*  using the factorization A = L*D*L**H or A = U**H*D*U computed by\n*  CPTTRF.\n*\n*  Norm(inv(A)) is computed by a direct method, and the reciprocal of\n*  the condition number is computed as\n*                   RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  D       (input) REAL array, dimension (N)\n*          The n diagonal elements of the diagonal matrix D from the\n*          factorization of A, as computed by CPTTRF.\n*\n*  E       (input) COMPLEX array, dimension (N-1)\n*          The (n-1) off-diagonal elements of the unit bidiagonal factor\n*          U or L from the factorization of A, as computed by CPTTRF.\n*\n*  ANORM   (input) REAL\n*          The 1-norm of the original matrix A.\n*\n*  RCOND   (output) REAL\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the\n*          1-norm of inv(A) computed in this routine.\n*\n*  RWORK   (workspace) REAL array, dimension (N)\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 method used is described in Nicholas J. Higham, \"Efficient\n*  Algorithms for Computing the Condition Number of a Tridiagonal\n*  Matrix\", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.cptcon( d, e, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_d = argv[0];
  rblapack_e = argv[1];
  rblapack_anorm = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  anorm = (real)NUM2DBL(rblapack_anorm);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (2th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SCOMPLEX)
    rblapack_e = na_change_type(rblapack_e, NA_SCOMPLEX);
  e = NA_PTR_TYPE(rblapack_e, complex*);
  rwork = ALLOC_N(real, (n));

  cptcon_(&n, d, e, &anorm, &rcond, rwork, &info);

  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_cptcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cptcon", rblapack_cptcon, -1);
}
ruby-lapack-1.7.2/ext/zunbdb.c0000644000175000017500000003522212502221024016011 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zunbdb_(char* trans, char* signs, integer* m, integer* p, integer* q, doublecomplex* x11, integer* ldx11, doublecomplex* x12, integer* ldx12, doublecomplex* x21, integer* ldx21, doublecomplex* x22, integer* ldx22, doublereal* theta, doublereal* phi, doublecomplex* taup1, doublecomplex* taup2, doublecomplex* tauq1, doublecomplex* tauq2, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zunbdb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_signs;
  char signs; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_x11;
  doublecomplex *x11; 
  VALUE rblapack_x12;
  doublecomplex *x12; 
  VALUE rblapack_x21;
  doublecomplex *x21; 
  VALUE rblapack_x22;
  doublecomplex *x22; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_theta;
  doublereal *theta; 
  VALUE rblapack_phi;
  doublereal *phi; 
  VALUE rblapack_taup1;
  doublecomplex *taup1; 
  VALUE rblapack_taup2;
  doublecomplex *taup2; 
  VALUE rblapack_tauq1;
  doublecomplex *tauq1; 
  VALUE rblapack_tauq2;
  doublecomplex *tauq2; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x11_out__;
  doublecomplex *x11_out__;
  VALUE rblapack_x12_out__;
  doublecomplex *x12_out__;
  VALUE rblapack_x21_out__;
  doublecomplex *x21_out__;
  VALUE rblapack_x22_out__;
  doublecomplex *x22_out__;
  doublecomplex *work;

  integer ldx11;
  integer q;
  integer ldx12;
  integer ldx21;
  integer ldx22;
  integer p;

  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  theta, phi, taup1, taup2, tauq1, tauq2, info, x11, x12, x21, x22 = NumRu::Lapack.zunbdb( trans, signs, m, x11, x12, x21, x22, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZUNBDB simultaneously bidiagonalizes the blocks of an M-by-M\n*  partitioned unitary matrix X:\n*\n*                                  [ B11 | B12 0  0 ]\n*      [ X11 | X12 ]   [ P1 |    ] [  0  |  0 -I  0 ] [ Q1 |    ]**H\n*  X = [-----------] = [---------] [----------------] [---------]   .\n*      [ X21 | X22 ]   [    | P2 ] [ B21 | B22 0  0 ] [    | Q2 ]\n*                                  [  0  |  0  0  I ]\n*\n*  X11 is P-by-Q. Q must be no larger than P, M-P, or M-Q. (If this is\n*  not the case, then X must be transposed and/or permuted. This can be\n*  done in constant time using the TRANS and SIGNS options. See ZUNCSD\n*  for details.)\n*\n*  The unitary matrices P1, P2, Q1, and Q2 are P-by-P, (M-P)-by-\n*  (M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. They are\n*  represented implicitly by Householder vectors.\n*\n*  B11, B12, B21, and B22 are Q-by-Q bidiagonal matrices represented\n*  implicitly by angles THETA, PHI.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER\n*          = 'T':      X, U1, U2, V1T, and V2T are stored in row-major\n*                      order;\n*          otherwise:  X, U1, U2, V1T, and V2T are stored in column-\n*                      major order.\n*\n*  SIGNS   (input) CHARACTER\n*          = 'O':      The lower-left block is made nonpositive (the\n*                      \"other\" convention);\n*          otherwise:  The upper-right block is made nonpositive (the\n*                      \"default\" convention).\n*\n*  M       (input) INTEGER\n*          The number of rows and columns in X.\n*\n*  P       (input) INTEGER\n*          The number of rows in X11 and X12. 0 <= P <= M.\n*\n*  Q       (input) INTEGER\n*          The number of columns in X11 and X21. 0 <= Q <=\n*          MIN(P,M-P,M-Q).\n*\n*  X11     (input/output) COMPLEX*16 array, dimension (LDX11,Q)\n*          On entry, the top-left block of the unitary matrix to be\n*          reduced. On exit, the form depends on TRANS:\n*          If TRANS = 'N', then\n*             the columns of tril(X11) specify reflectors for P1,\n*             the rows of triu(X11,1) specify reflectors for Q1;\n*          else TRANS = 'T', and\n*             the rows of triu(X11) specify reflectors for P1,\n*             the columns of tril(X11,-1) specify reflectors for Q1.\n*\n*  LDX11   (input) INTEGER\n*          The leading dimension of X11. If TRANS = 'N', then LDX11 >=\n*          P; else LDX11 >= Q.\n*\n*  X12     (input/output) COMPLEX*16 array, dimension (LDX12,M-Q)\n*          On entry, the top-right block of the unitary matrix to\n*          be reduced. On exit, the form depends on TRANS:\n*          If TRANS = 'N', then\n*             the rows of triu(X12) specify the first P reflectors for\n*             Q2;\n*          else TRANS = 'T', and\n*             the columns of tril(X12) specify the first P reflectors\n*             for Q2.\n*\n*  LDX12   (input) INTEGER\n*          The leading dimension of X12. If TRANS = 'N', then LDX12 >=\n*          P; else LDX11 >= M-Q.\n*\n*  X21     (input/output) COMPLEX*16 array, dimension (LDX21,Q)\n*          On entry, the bottom-left block of the unitary matrix to\n*          be reduced. On exit, the form depends on TRANS:\n*          If TRANS = 'N', then\n*             the columns of tril(X21) specify reflectors for P2;\n*          else TRANS = 'T', and\n*             the rows of triu(X21) specify reflectors for P2.\n*\n*  LDX21   (input) INTEGER\n*          The leading dimension of X21. If TRANS = 'N', then LDX21 >=\n*          M-P; else LDX21 >= Q.\n*\n*  X22     (input/output) COMPLEX*16 array, dimension (LDX22,M-Q)\n*          On entry, the bottom-right block of the unitary matrix to\n*          be reduced. On exit, the form depends on TRANS:\n*          If TRANS = 'N', then\n*             the rows of triu(X22(Q+1:M-P,P+1:M-Q)) specify the last\n*             M-P-Q reflectors for Q2,\n*          else TRANS = 'T', and\n*             the columns of tril(X22(P+1:M-Q,Q+1:M-P)) specify the last\n*             M-P-Q reflectors for P2.\n*\n*  LDX22   (input) INTEGER\n*          The leading dimension of X22. If TRANS = 'N', then LDX22 >=\n*          M-P; else LDX22 >= M-Q.\n*\n*  THETA   (output) DOUBLE PRECISION array, dimension (Q)\n*          The entries of the bidiagonal blocks B11, B12, B21, B22 can\n*          be computed from the angles THETA and PHI. See Further\n*          Details.\n*\n*  PHI     (output) DOUBLE PRECISION array, dimension (Q-1)\n*          The entries of the bidiagonal blocks B11, B12, B21, B22 can\n*          be computed from the angles THETA and PHI. See Further\n*          Details.\n*\n*  TAUP1   (output) COMPLEX*16 array, dimension (P)\n*          The scalar factors of the elementary reflectors that define\n*          P1.\n*\n*  TAUP2   (output) COMPLEX*16 array, dimension (M-P)\n*          The scalar factors of the elementary reflectors that define\n*          P2.\n*\n*  TAUQ1   (output) COMPLEX*16 array, dimension (Q)\n*          The scalar factors of the elementary reflectors that define\n*          Q1.\n*\n*  TAUQ2   (output) COMPLEX*16 array, dimension (M-Q)\n*          The scalar factors of the elementary reflectors that define\n*          Q2.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (LWORK)\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK. LWORK >= M-Q.\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 bidiagonal blocks B11, B12, B21, and B22 are represented\n*  implicitly by angles THETA(1), ..., THETA(Q) and PHI(1), ...,\n*  PHI(Q-1). B11 and B21 are upper bidiagonal, while B21 and B22 are\n*  lower bidiagonal. Every entry in each bidiagonal band is a product\n*  of a sine or cosine of a THETA with a sine or cosine of a PHI. See\n*  [1] or ZUNCSD for details.\n*\n*  P1, P2, Q1, and Q2 are represented as products of elementary\n*  reflectors. See ZUNCSD for details on generating P1, P2, Q1, and Q2\n*  using ZUNGQR and ZUNGLQ.\n*\n*  Reference\n*  =========\n*\n*  [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.\n*      Algorithms, 50(1):33-65, 2009.\n*\n*  ====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  theta, phi, taup1, taup2, tauq1, tauq2, info, x11, x12, x21, x22 = NumRu::Lapack.zunbdb( trans, signs, m, x11, x12, x21, x22, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_trans = argv[0];
  rblapack_signs = argv[1];
  rblapack_m = argv[2];
  rblapack_x11 = argv[3];
  rblapack_x12 = argv[4];
  rblapack_x21 = argv[5];
  rblapack_x22 = argv[6];
  if (argc == 8) {
    rblapack_lwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  trans = StringValueCStr(rblapack_trans)[0];
  m = NUM2INT(rblapack_m);
  signs = StringValueCStr(rblapack_signs)[0];
  if (!NA_IsNArray(rblapack_x11))
    rb_raise(rb_eArgError, "x11 (4th argument) must be NArray");
  if (NA_RANK(rblapack_x11) != 2)
    rb_raise(rb_eArgError, "rank of x11 (4th argument) must be %d", 2);
  ldx11 = NA_SHAPE0(rblapack_x11);
  q = NA_SHAPE1(rblapack_x11);
  if (NA_TYPE(rblapack_x11) != NA_DCOMPLEX)
    rblapack_x11 = na_change_type(rblapack_x11, NA_DCOMPLEX);
  x11 = NA_PTR_TYPE(rblapack_x11, doublecomplex*);
  p = ldx11;
  ldx21 = p;
  if (!NA_IsNArray(rblapack_x21))
    rb_raise(rb_eArgError, "x21 (6th argument) must be NArray");
  if (NA_RANK(rblapack_x21) != 2)
    rb_raise(rb_eArgError, "rank of x21 (6th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_x21) != ldx21)
    rb_raise(rb_eRuntimeError, "shape 0 of x21 must be p");
  if (NA_SHAPE1(rblapack_x21) != q)
    rb_raise(rb_eRuntimeError, "shape 1 of x21 must be the same as shape 1 of x11");
  if (NA_TYPE(rblapack_x21) != NA_DCOMPLEX)
    rblapack_x21 = na_change_type(rblapack_x21, NA_DCOMPLEX);
  x21 = NA_PTR_TYPE(rblapack_x21, doublecomplex*);
  if (rblapack_lwork == Qnil)
    lwork = m-q;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldx22 = p;
  if (!NA_IsNArray(rblapack_x22))
    rb_raise(rb_eArgError, "x22 (7th argument) must be NArray");
  if (NA_RANK(rblapack_x22) != 2)
    rb_raise(rb_eArgError, "rank of x22 (7th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_x22) != ldx22)
    rb_raise(rb_eRuntimeError, "shape 0 of x22 must be p");
  if (NA_SHAPE1(rblapack_x22) != (m-q))
    rb_raise(rb_eRuntimeError, "shape 1 of x22 must be %d", m-q);
  if (NA_TYPE(rblapack_x22) != NA_DCOMPLEX)
    rblapack_x22 = na_change_type(rblapack_x22, NA_DCOMPLEX);
  x22 = NA_PTR_TYPE(rblapack_x22, doublecomplex*);
  ldx12 = p;
  if (!NA_IsNArray(rblapack_x12))
    rb_raise(rb_eArgError, "x12 (5th argument) must be NArray");
  if (NA_RANK(rblapack_x12) != 2)
    rb_raise(rb_eArgError, "rank of x12 (5th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_x12) != ldx12)
    rb_raise(rb_eRuntimeError, "shape 0 of x12 must be p");
  if (NA_SHAPE1(rblapack_x12) != (m-q))
    rb_raise(rb_eRuntimeError, "shape 1 of x12 must be %d", m-q);
  if (NA_TYPE(rblapack_x12) != NA_DCOMPLEX)
    rblapack_x12 = na_change_type(rblapack_x12, NA_DCOMPLEX);
  x12 = NA_PTR_TYPE(rblapack_x12, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_theta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  theta = NA_PTR_TYPE(rblapack_theta, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = q-1;
    rblapack_phi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  phi = NA_PTR_TYPE(rblapack_phi, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = p;
    rblapack_taup1 = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  taup1 = NA_PTR_TYPE(rblapack_taup1, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = m-p;
    rblapack_taup2 = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  taup2 = NA_PTR_TYPE(rblapack_taup2, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_tauq1 = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  tauq1 = NA_PTR_TYPE(rblapack_tauq1, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = m-q;
    rblapack_tauq2 = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  tauq2 = NA_PTR_TYPE(rblapack_tauq2, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldx11;
    shape[1] = q;
    rblapack_x11_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x11_out__ = NA_PTR_TYPE(rblapack_x11_out__, doublecomplex*);
  MEMCPY(x11_out__, x11, doublecomplex, NA_TOTAL(rblapack_x11));
  rblapack_x11 = rblapack_x11_out__;
  x11 = x11_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldx12;
    shape[1] = m-q;
    rblapack_x12_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x12_out__ = NA_PTR_TYPE(rblapack_x12_out__, doublecomplex*);
  MEMCPY(x12_out__, x12, doublecomplex, NA_TOTAL(rblapack_x12));
  rblapack_x12 = rblapack_x12_out__;
  x12 = x12_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldx21;
    shape[1] = q;
    rblapack_x21_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x21_out__ = NA_PTR_TYPE(rblapack_x21_out__, doublecomplex*);
  MEMCPY(x21_out__, x21, doublecomplex, NA_TOTAL(rblapack_x21));
  rblapack_x21 = rblapack_x21_out__;
  x21 = x21_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldx22;
    shape[1] = m-q;
    rblapack_x22_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x22_out__ = NA_PTR_TYPE(rblapack_x22_out__, doublecomplex*);
  MEMCPY(x22_out__, x22, doublecomplex, NA_TOTAL(rblapack_x22));
  rblapack_x22 = rblapack_x22_out__;
  x22 = x22_out__;
  work = ALLOC_N(doublecomplex, (MAX(1,lwork)));

  zunbdb_(&trans, &signs, &m, &p, &q, x11, &ldx11, x12, &ldx12, x21, &ldx21, x22, &ldx22, theta, phi, taup1, taup2, tauq1, tauq2, work, &lwork, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(11, rblapack_theta, rblapack_phi, rblapack_taup1, rblapack_taup2, rblapack_tauq1, rblapack_tauq2, rblapack_info, rblapack_x11, rblapack_x12, rblapack_x21, rblapack_x22);
}

void
init_lapack_zunbdb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zunbdb", rblapack_zunbdb, -1);
}
ruby-lapack-1.7.2/ext/csytrs2.c0000644000175000017500000001223612502221022016134 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID csytrs2_(char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, integer* ipiv, complex* b, integer* ldb, complex* work, integer* info);


static VALUE
rblapack_csytrs2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  complex *b_out__;
  complex *work;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.csytrs2( uplo, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,  WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CSYTRS2 solves a system of linear equations A*X = B with a COMPLEX\n*  symmetric matrix A using the factorization A = U*D*U**T or\n*  A = L*D*L**T computed by CSYTRF and converted by CSYCONV.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by CSYTRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by CSYTRF.\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  WORK    (workspace) COMPLEX array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.csytrs2( uplo, a, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(complex, (n));

  csytrs2_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_csytrs2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "csytrs2", rblapack_csytrs2, -1);
}
ruby-lapack-1.7.2/ext/zlapll.c0000644000175000017500000001117112502221022016016 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlapll_(integer* n, doublecomplex* x, integer* incx, doublecomplex* y, integer* incy, doublereal* ssmin);


static VALUE
rblapack_zlapll(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_y;
  doublecomplex *y; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_ssmin;
  doublereal ssmin; 
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;
  VALUE rblapack_y_out__;
  doublecomplex *y_out__;


  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  ssmin, x, y = NumRu::Lapack.zlapll( n, x, incx, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAPLL( N, X, INCX, Y, INCY, SSMIN )\n\n*  Purpose\n*  =======\n*\n*  Given two column vectors X and Y, let\n*\n*                       A = ( X Y ).\n*\n*  The subroutine first computes the QR factorization of A = Q*R,\n*  and then computes the SVD of the 2-by-2 upper triangular matrix R.\n*  The smaller singular value of R is returned in SSMIN, which is used\n*  as the measurement of the linear dependency of the vectors X and Y.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The length of the vectors X and Y.\n*\n*  X       (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX)\n*          On entry, X contains the N-vector X.\n*          On exit, X is overwritten.\n*\n*  INCX    (input) INTEGER\n*          The increment between successive elements of X. INCX > 0.\n*\n*  Y       (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCY)\n*          On entry, Y contains the N-vector Y.\n*          On exit, Y is overwritten.\n*\n*  INCY    (input) INTEGER\n*          The increment between successive elements of Y. INCY > 0.\n*\n*  SSMIN   (output) DOUBLE PRECISION\n*          The smallest singular value of the N-by-2 matrix A = ( X Y ).\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ssmin, x, y = NumRu::Lapack.zlapll( n, x, incx, y, incy, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_n = argv[0];
  rblapack_x = argv[1];
  rblapack_incx = argv[2];
  rblapack_y = argv[3];
  rblapack_incy = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  incx = NUM2INT(rblapack_incx);
  incy = NUM2INT(rblapack_incy);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1+(n-1)*incx))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (4th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incy))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
  if (NA_TYPE(rblapack_y) != NA_DCOMPLEX)
    rblapack_y = na_change_type(rblapack_y, NA_DCOMPLEX);
  y = NA_PTR_TYPE(rblapack_y, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incx;
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incy;
    rblapack_y_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublecomplex*);
  MEMCPY(y_out__, y, doublecomplex, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  zlapll_(&n, x, &incx, y, &incy, &ssmin);

  rblapack_ssmin = rb_float_new((double)ssmin);
  return rb_ary_new3(3, rblapack_ssmin, rblapack_x, rblapack_y);
}

void
init_lapack_zlapll(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlapll", rblapack_zlapll, -1);
}
ruby-lapack-1.7.2/ext/zgbsv.c0000644000175000017500000001646012502221024015663 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgbsv_(integer* n, integer* kl, integer* ku, integer* nrhs, doublecomplex* ab, integer* ldab, integer* ipiv, doublecomplex* b, integer* ldb, integer* info);


static VALUE
rblapack_zgbsv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublecomplex *ab_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer ldab;
  integer n;
  integer ldb;
  integer nrhs;

  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  ipiv, info, ab, b = NumRu::Lapack.zgbsv( kl, ku, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGBSV computes the solution to a complex system of linear equations\n*  A * X = B, where A is a band matrix of order N with KL subdiagonals\n*  and KU superdiagonals, and X and B are N-by-NRHS matrices.\n*\n*  The LU decomposition with partial pivoting and row interchanges is\n*  used to factor A as A = L * U, where L is a product of permutation\n*  and unit lower triangular matrices with KL subdiagonals, and U is\n*  upper triangular with KL+KU superdiagonals.  The factored form of A\n*  is then used to solve the system of equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)\n*          On entry, the matrix A in band storage, in rows KL+1 to\n*          2*KL+KU+1; rows 1 to KL of the array need not be set.\n*          The j-th column of A is stored in the j-th column of the\n*          array AB as follows:\n*          AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)\n*          On exit, details of the factorization: U is stored as an\n*          upper triangular band matrix with KL+KU superdiagonals in\n*          rows 1 to KL+KU+1, and the multipliers used during the\n*          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n*          See below for further details.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          The pivot indices that define the permutation matrix P;\n*          row i of the matrix was interchanged with row IPIV(i).\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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, U(i,i) is exactly zero.  The factorization\n*                has been completed, but the factor U is exactly\n*                singular, and the solution has not been computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  M = N = 6, KL = 2, KU = 1:\n*\n*  On entry:                       On exit:\n*\n*      *    *    *    +    +    +       *    *    *   u14  u25  u36\n*      *    *    +    +    +    +       *    *   u13  u24  u35  u46\n*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56\n*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66\n*     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *\n*     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *\n*\n*  Array elements marked * are not used by the routine; elements marked\n*  + need not be set on entry, but are required by the routine to store\n*  elements of U because of fill-in resulting from the row interchanges.\n*\n*  =====================================================================\n*\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZGBTRF, ZGBTRS\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, ab, b = NumRu::Lapack.zgbsv( kl, ku, ab, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_kl = argv[0];
  rblapack_ku = argv[1];
  rblapack_ab = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
  MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zgbsv_(&n, &kl, &ku, &nrhs, ab, &ldab, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ipiv, rblapack_info, rblapack_ab, rblapack_b);
}

void
init_lapack_zgbsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgbsv", rblapack_zgbsv, -1);
}
ruby-lapack-1.7.2/ext/stgsna.c0000644000175000017500000004107112502221015016023 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID stgsna_(char* job, char* howmny, logical* select, integer* n, real* a, integer* lda, real* b, integer* ldb, real* vl, integer* ldvl, real* vr, integer* ldvr, real* s, real* dif, integer* mm, integer* m, real* work, integer* lwork, integer* iwork, integer* info);


static VALUE
rblapack_stgsna(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_howmny;
  char howmny; 
  VALUE rblapack_select;
  logical *select; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_vl;
  real *vl; 
  VALUE rblapack_vr;
  real *vr; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_dif;
  real *dif; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  integer *iwork;

  integer n;
  integer lda;
  integer ldb;
  integer ldvl;
  integer ldvr;
  integer mm;

  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  s, dif, m, work, info = NumRu::Lapack.stgsna( job, howmny, select, a, b, vl, vr, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  STGSNA estimates reciprocal condition numbers for specified\n*  eigenvalues and/or eigenvectors of a matrix pair (A, B) in\n*  generalized real Schur canonical form (or of any matrix pair\n*  (Q*A*Z', Q*B*Z') with orthogonal matrices Q and Z, where\n*  Z' denotes the transpose of Z.\n*\n*  (A, B) must be in generalized real Schur form (as returned by SGGES),\n*  i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal\n*  blocks. B is upper triangular.\n*\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies whether condition numbers are required for\n*          eigenvalues (S) or eigenvectors (DIF):\n*          = 'E': for eigenvalues only (S);\n*          = 'V': for eigenvectors only (DIF);\n*          = 'B': for both eigenvalues and eigenvectors (S and DIF).\n*\n*  HOWMNY  (input) CHARACTER*1\n*          = 'A': compute condition numbers for all eigenpairs;\n*          = 'S': compute condition numbers for selected eigenpairs\n*                 specified by the array SELECT.\n*\n*  SELECT  (input) LOGICAL array, dimension (N)\n*          If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n*          condition numbers are required. To select condition numbers\n*          for the eigenpair corresponding to a real eigenvalue w(j),\n*          SELECT(j) must be set to .TRUE.. To select condition numbers\n*          corresponding to a complex conjugate pair of eigenvalues w(j)\n*          and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be\n*          set to .TRUE..\n*          If HOWMNY = 'A', SELECT is not referenced.\n*\n*  N       (input) INTEGER\n*          The order of the square matrix pair (A, B). N >= 0.\n*\n*  A       (input) REAL array, dimension (LDA,N)\n*          The upper quasi-triangular matrix A in the pair (A,B).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  B       (input) REAL array, dimension (LDB,N)\n*          The upper triangular matrix B in the pair (A,B).\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  VL      (input) REAL array, dimension (LDVL,M)\n*          If JOB = 'E' or 'B', VL must contain left eigenvectors of\n*          (A, B), corresponding to the eigenpairs specified by HOWMNY\n*          and SELECT. The eigenvectors must be stored in consecutive\n*          columns of VL, as returned by STGEVC.\n*          If JOB = 'V', VL is not referenced.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the array VL. LDVL >= 1.\n*          If JOB = 'E' or 'B', LDVL >= N.\n*\n*  VR      (input) REAL array, dimension (LDVR,M)\n*          If JOB = 'E' or 'B', VR must contain right eigenvectors of\n*          (A, B), corresponding to the eigenpairs specified by HOWMNY\n*          and SELECT. The eigenvectors must be stored in consecutive\n*          columns ov VR, as returned by STGEVC.\n*          If JOB = 'V', VR is not referenced.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the array VR. LDVR >= 1.\n*          If JOB = 'E' or 'B', LDVR >= N.\n*\n*  S       (output) REAL array, dimension (MM)\n*          If JOB = 'E' or 'B', the reciprocal condition numbers of the\n*          selected eigenvalues, stored in consecutive elements of the\n*          array. For a complex conjugate pair of eigenvalues two\n*          consecutive elements of S are set to the same value. Thus\n*          S(j), DIF(j), and the j-th columns of VL and VR all\n*          correspond to the same eigenpair (but not in general the\n*          j-th eigenpair, unless all eigenpairs are selected).\n*          If JOB = 'V', S is not referenced.\n*\n*  DIF     (output) REAL array, dimension (MM)\n*          If JOB = 'V' or 'B', the estimated reciprocal condition\n*          numbers of the selected eigenvectors, stored in consecutive\n*          elements of the array. For a complex eigenvector two\n*          consecutive elements of DIF are set to the same value. If\n*          the eigenvalues cannot be reordered to compute DIF(j), DIF(j)\n*          is set to 0; this can only occur when the true value would be\n*          very small anyway.\n*          If JOB = 'E', DIF is not referenced.\n*\n*  MM      (input) INTEGER\n*          The number of elements in the arrays S and DIF. MM >= M.\n*\n*  M       (output) INTEGER\n*          The number of elements of the arrays S and DIF used to store\n*          the specified condition numbers; for each selected real\n*          eigenvalue one element is used, and for each selected complex\n*          conjugate pair of eigenvalues, two elements are used.\n*          If HOWMNY = 'A', M is set to N.\n*\n*  WORK    (workspace/output) REAL 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,N).\n*          If JOB = 'V' or 'B' LWORK >= 2*N*(N+2)+16.\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*  IWORK   (workspace) INTEGER array, dimension (N + 6)\n*          If JOB = 'E', IWORK is not referenced.\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\n*  Further Details\n*  ===============\n*\n*  The reciprocal of the condition number of a generalized eigenvalue\n*  w = (a, b) is defined as\n*\n*       S(w) = (|u'Av|**2 + |u'Bv|**2)**(1/2) / (norm(u)*norm(v))\n*\n*  where u and v are the left and right eigenvectors of (A, B)\n*  corresponding to w; |z| denotes the absolute value of the complex\n*  number, and norm(u) denotes the 2-norm of the vector u.\n*  The pair (a, b) corresponds to an eigenvalue w = a/b (= u'Av/u'Bv)\n*  of the matrix pair (A, B). If both a and b equal zero, then (A B) is\n*  singular and S(I) = -1 is returned.\n*\n*  An approximate error bound on the chordal distance between the i-th\n*  computed generalized eigenvalue w and the corresponding exact\n*  eigenvalue lambda is\n*\n*       chord(w, lambda) <= EPS * norm(A, B) / S(I)\n*\n*  where EPS is the machine precision.\n*\n*  The reciprocal of the condition number DIF(i) of right eigenvector u\n*  and left eigenvector v corresponding to the generalized eigenvalue w\n*  is defined as follows:\n*\n*  a) If the i-th eigenvalue w = (a,b) is real\n*\n*     Suppose U and V are orthogonal transformations such that\n*\n*                U'*(A, B)*V  = (S, T) = ( a   *  ) ( b  *  )  1\n*                                        ( 0  S22 ),( 0 T22 )  n-1\n*                                          1  n-1     1 n-1\n*\n*     Then the reciprocal condition number DIF(i) is\n*\n*                Difl((a, b), (S22, T22)) = sigma-min( Zl ),\n*\n*     where sigma-min(Zl) denotes the smallest singular value of the\n*     2(n-1)-by-2(n-1) matrix\n*\n*         Zl = [ kron(a, In-1)  -kron(1, S22) ]\n*              [ kron(b, In-1)  -kron(1, T22) ] .\n*\n*     Here In-1 is the identity matrix of size n-1. kron(X, Y) is the\n*     Kronecker product between the matrices X and Y.\n*\n*     Note that if the default method for computing DIF(i) is wanted\n*     (see SLATDF), then the parameter DIFDRI (see below) should be\n*     changed from 3 to 4 (routine SLATDF(IJOB = 2 will be used)).\n*     See STGSYL for more details.\n*\n*  b) If the i-th and (i+1)-th eigenvalues are complex conjugate pair,\n*\n*     Suppose U and V are orthogonal transformations such that\n*\n*                U'*(A, B)*V = (S, T) = ( S11  *   ) ( T11  *  )  2\n*                                       ( 0    S22 ),( 0    T22) n-2\n*                                         2    n-2     2    n-2\n*\n*     and (S11, T11) corresponds to the complex conjugate eigenvalue\n*     pair (w, conjg(w)). There exist unitary matrices U1 and V1 such\n*     that\n*\n*         U1'*S11*V1 = ( s11 s12 )   and U1'*T11*V1 = ( t11 t12 )\n*                      (  0  s22 )                    (  0  t22 )\n*\n*     where the generalized eigenvalues w = s11/t11 and\n*     conjg(w) = s22/t22.\n*\n*     Then the reciprocal condition number DIF(i) is bounded by\n*\n*         min( d1, max( 1, |real(s11)/real(s22)| )*d2 )\n*\n*     where, d1 = Difl((s11, t11), (s22, t22)) = sigma-min(Z1), where\n*     Z1 is the complex 2-by-2 matrix\n*\n*              Z1 =  [ s11  -s22 ]\n*                    [ t11  -t22 ],\n*\n*     This is done by computing (using real arithmetic) the\n*     roots of the characteristical polynomial det(Z1' * Z1 - lambda I),\n*     where Z1' denotes the conjugate transpose of Z1 and det(X) denotes\n*     the determinant of X.\n*\n*     and d2 is an upper bound on Difl((S11, T11), (S22, T22)), i.e. an\n*     upper bound on sigma-min(Z2), where Z2 is (2n-2)-by-(2n-2)\n*\n*              Z2 = [ kron(S11', In-2)  -kron(I2, S22) ]\n*                   [ kron(T11', In-2)  -kron(I2, T22) ]\n*\n*     Note that if the default method for computing DIF is wanted (see\n*     SLATDF), then the parameter DIFDRI (see below) should be changed\n*     from 3 to 4 (routine SLATDF(IJOB = 2 will be used)). See STGSYL\n*     for more details.\n*\n*  For each eigenvalue/vector specified by SELECT, DIF stores a\n*  Frobenius norm-based estimate of Difl.\n*\n*  An approximate error bound for the i-th computed eigenvector VL(i) or\n*  VR(i) is given by\n*\n*             EPS * norm(A, B) / DIF(i).\n*\n*  See ref. [2-3] for more details and further references.\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  References\n*  ==========\n*\n*  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n*      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n*      M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n*      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n*  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n*      Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n*      Estimation: Theory, Algorithms and Software,\n*      Report UMINF - 94.04, Department of Computing Science, Umea\n*      University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working\n*      Note 87. To appear in Numerical Algorithms, 1996.\n*\n*  [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n*      for Solving the Generalized Sylvester Equation and Estimating the\n*      Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n*      Department of Computing Science, Umea University, S-901 87 Umea,\n*      Sweden, December 1993, Revised April 1994, Also as LAPACK Working\n*      Note 75.  To appear in ACM Trans. on Math. Software, Vol 22,\n*      No 1, 1996.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, dif, m, work, info = NumRu::Lapack.stgsna( job, howmny, select, a, b, vl, vr, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_job = argv[0];
  rblapack_howmny = argv[1];
  rblapack_select = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  rblapack_vl = argv[5];
  rblapack_vr = argv[6];
  if (argc == 8) {
    rblapack_lwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  job = StringValueCStr(rblapack_job)[0];
  if (!NA_IsNArray(rblapack_select))
    rb_raise(rb_eArgError, "select (3th argument) must be NArray");
  if (NA_RANK(rblapack_select) != 1)
    rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_select);
  if (NA_TYPE(rblapack_select) != NA_LINT)
    rblapack_select = na_change_type(rblapack_select, NA_LINT);
  select = NA_PTR_TYPE(rblapack_select, logical*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (!NA_IsNArray(rblapack_vr))
    rb_raise(rb_eArgError, "vr (7th argument) must be NArray");
  if (NA_RANK(rblapack_vr) != 2)
    rb_raise(rb_eArgError, "rank of vr (7th argument) must be %d", 2);
  ldvr = NA_SHAPE0(rblapack_vr);
  m = NA_SHAPE1(rblapack_vr);
  if (NA_TYPE(rblapack_vr) != NA_SFLOAT)
    rblapack_vr = na_change_type(rblapack_vr, NA_SFLOAT);
  vr = NA_PTR_TYPE(rblapack_vr, real*);
  howmny = StringValueCStr(rblapack_howmny)[0];
  if (!NA_IsNArray(rblapack_vl))
    rb_raise(rb_eArgError, "vl (6th argument) must be NArray");
  if (NA_RANK(rblapack_vl) != 2)
    rb_raise(rb_eArgError, "rank of vl (6th argument) must be %d", 2);
  ldvl = NA_SHAPE0(rblapack_vl);
  if (NA_SHAPE1(rblapack_vl) != m)
    rb_raise(rb_eRuntimeError, "shape 1 of vl must be the same as shape 1 of vr");
  if (NA_TYPE(rblapack_vl) != NA_SFLOAT)
    rblapack_vl = na_change_type(rblapack_vl, NA_SFLOAT);
  vl = NA_PTR_TYPE(rblapack_vl, real*);
  mm = m;
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (rblapack_lwork == Qnil)
    lwork = (lsame_(&job,"V")||lsame_(&job,"B")) ? 2*n*n : n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = mm;
    rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, real*);
  {
    na_shape_t shape[1];
    shape[0] = mm;
    rblapack_dif = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  dif = NA_PTR_TYPE(rblapack_dif, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  iwork = ALLOC_N(integer, (lsame_(&job,"E") ? 0 : n + 6));

  stgsna_(&job, &howmny, select, &n, a, &lda, b, &ldb, vl, &ldvl, vr, &ldvr, s, dif, &mm, &m, work, &lwork, iwork, &info);

  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_s, rblapack_dif, rblapack_m, rblapack_work, rblapack_info);
}

void
init_lapack_stgsna(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "stgsna", rblapack_stgsna, -1);
}
ruby-lapack-1.7.2/ext/zhegvd.c0000644000175000017500000003102012502221023016003 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhegvd_(integer* itype, char* jobz, char* uplo, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublereal* w, doublecomplex* work, integer* lwork, doublereal* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_zhegvd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_lrwork;
  integer lrwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_rwork;
  doublereal *rwork; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer lda;
  integer n;
  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  w, work, rwork, iwork, info, a, b = NumRu::Lapack.zhegvd( itype, jobz, uplo, a, b, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHEGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHEGVD computes all the eigenvalues, and optionally, the eigenvectors\n*  of a complex generalized Hermitian-definite eigenproblem, of the form\n*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A and\n*  B are assumed to be Hermitian and B is also positive definite.\n*  If eigenvectors are desired, it uses a divide and conquer algorithm.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          Specifies the problem type to be solved:\n*          = 1:  A*x = (lambda)*B*x\n*          = 2:  A*B*x = (lambda)*x\n*          = 3:  B*A*x = (lambda)*x\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA, N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of A contains the\n*          upper triangular part of the matrix A.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of A contains\n*          the lower triangular part of the matrix A.\n*\n*          On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n*          matrix Z of eigenvectors.  The eigenvectors are normalized\n*          as follows:\n*          if ITYPE = 1 or 2, Z**H*B*Z = I;\n*          if ITYPE = 3, Z**H*inv(B)*Z = I.\n*          If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n*          or the lower triangle (if UPLO='L') of A, including the\n*          diagonal, is destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB, N)\n*          On entry, the Hermitian matrix B.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of B contains the\n*          upper triangular part of the matrix B.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of B contains\n*          the lower triangular part of the matrix B.\n*\n*          On exit, if INFO <= N, the part of B containing the matrix is\n*          overwritten by the triangular factor U or L from the Cholesky\n*          factorization B = U**H*U or B = L*L**H.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of the array WORK.\n*          If N <= 1,                LWORK >= 1.\n*          If JOBZ  = 'N' and N > 1, LWORK >= N + 1.\n*          If JOBZ  = 'V' and N > 1, LWORK >= 2*N + N**2.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal sizes of the WORK, RWORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  RWORK   (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))\n*          On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n*\n*  LRWORK  (input) INTEGER\n*          The dimension of the array RWORK.\n*          If N <= 1,                LRWORK >= 1.\n*          If JOBZ  = 'N' and N > 1, LRWORK >= N.\n*          If JOBZ  = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.\n*\n*          If LRWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.\n*          If N <= 1,                LIWORK >= 1.\n*          If JOBZ  = 'N' and N > 1, LIWORK >= 1.\n*          If JOBZ  = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK 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:  ZPOTRF or ZHEEVD returned an error code:\n*             <= N:  if INFO = i and JOBZ = 'N', then the algorithm\n*                    failed to converge; i off-diagonal elements of an\n*                    intermediate tridiagonal form did not converge to\n*                    zero;\n*                    if INFO = i and JOBZ = 'V', then the algorithm\n*                    failed to compute an eigenvalue while working on\n*                    the submatrix lying in rows and columns INFO/(N+1)\n*                    through mod(INFO,N+1);\n*             > N:   if INFO = N + i, for 1 <= i <= N, then the leading\n*                    minor of order i of B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n*  Modified so that no backsubstitution is performed if ZHEEVD fails to\n*  converge (NEIG in old code could be greater than N causing out of\n*  bounds reference to A - reported by Ralf Meyer).  Also corrected the\n*  description of INFO and the test on ITYPE. Sven, 16 Feb 05.\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, work, rwork, iwork, info, a, b = NumRu::Lapack.zhegvd( itype, jobz, uplo, a, b, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_itype = argv[0];
  rblapack_jobz = argv[1];
  rblapack_uplo = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  if (argc == 8) {
    rblapack_lwork = argv[5];
    rblapack_lrwork = argv[6];
    rblapack_liwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_lrwork = Qnil;
    rblapack_liwork = Qnil;
  }

  itype = NUM2INT(rblapack_itype);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (rblapack_lrwork == Qnil)
    lrwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
  else {
    lrwork = NUM2INT(rblapack_lrwork);
  }
  if (rblapack_lwork == Qnil)
    lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n+1 : lsame_(&jobz,"V") ? 2*n+n*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (rblapack_liwork == Qnil)
    liwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lrwork);
    rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zhegvd_(&itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_w, rblapack_work, rblapack_rwork, rblapack_iwork, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_zhegvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhegvd", rblapack_zhegvd, -1);
}
ruby-lapack-1.7.2/ext/cgeqrfp.c0000644000175000017500000001337712502221015016163 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgeqrfp_(integer* m, integer* n, complex* a, integer* lda, complex* tau, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_cgeqrfp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *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.cgeqrfp( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGEQRFP computes a QR factorization of a complex M-by-N matrix A:\n*  A = Q * R.\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) COMPLEX array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, the elements on and above the diagonal of the array\n*          contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n*          upper triangular if m >= n); the elements below the diagonal,\n*          with the array TAU, represent the unitary matrix Q as a\n*          product of min(m,n) elementary reflectors (see Further\n*          Details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  TAU     (output) COMPLEX array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace/output) COMPLEX 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,N).\n*          For optimum performance LWORK >= N*NB, where NB is\n*          the 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(1) H(2) . . . H(k), 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 complex scalar, and v is a complex vector with\n*  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\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           CGEQR2P, CLARFB, CLARFT, 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.cgeqrfp( 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;
  }

  m = NUM2INT(rblapack_m);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  cgeqrfp_(&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_cgeqrfp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgeqrfp", rblapack_cgeqrfp, -1);
}
ruby-lapack-1.7.2/ext/cla_hercond_c.c0000644000175000017500000001657212502221021017274 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real cla_hercond_c_(char* uplo, integer* n, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, real* c, logical* capply, integer* info, complex* work, real* rwork);


static VALUE
rblapack_cla_hercond_c(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_capply;
  logical capply; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_rwork;
  real *rwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack___out__;
  real __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  info, __out__ = NumRu::Lapack.cla_hercond_c( uplo, a, af, ipiv, c, capply, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL FUNCTION CLA_HERCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n*  Purpose\n*  =======\n*\n*     CLA_HERCOND_C computes the infinity norm condition number of\n*     op(A) * inv(diag(C)) where C is a REAL vector.\n*\n\n*  Arguments\n*  =========\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     A       (input) COMPLEX array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX array, dimension (LDAF,N)\n*     The block diagonal matrix D and the multipliers used to\n*     obtain the factor U or L as computed by CHETRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     Details of the interchanges and the block structure of D\n*     as determined by CHETRF.\n*\n*     C       (input) REAL array, dimension (N)\n*     The vector C in the formula op(A) * inv(diag(C)).\n*\n*     CAPPLY  (input) LOGICAL\n*     If .TRUE. then access the vector C in the formula above.\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit.\n*     i > 0:  The ith argument is invalid.\n*\n*     WORK    (input) COMPLEX array, dimension (2*N).\n*     Workspace.\n*\n*     RWORK   (input) REAL array, dimension (N).\n*     Workspace.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            KASE, I, J\n      REAL               AINVNM, ANORM, TMP\n      LOGICAL            UP\n      COMPLEX            ZDUM\n*     ..\n*     .. Local Arrays ..\n      INTEGER            ISAVE( 3 )\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CLACN2, CHETRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX\n*     ..\n*     .. Statement Functions ..\n      REAL               CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, __out__ = NumRu::Lapack.cla_hercond_c( uplo, a, af, ipiv, c, capply, work, rwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_c = argv[4];
  rblapack_capply = argv[5];
  rblapack_work = argv[6];
  rblapack_rwork = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_rwork))
    rb_raise(rb_eArgError, "rwork (8th argument) must be NArray");
  if (NA_RANK(rblapack_rwork) != 1)
    rb_raise(rb_eArgError, "rank of rwork (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_rwork) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_rwork) != NA_SFLOAT)
    rblapack_rwork = na_change_type(rblapack_rwork, NA_SFLOAT);
  rwork = NA_PTR_TYPE(rblapack_rwork, real*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  capply = (rblapack_capply == Qtrue);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (7th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
  if (NA_TYPE(rblapack_work) != NA_SCOMPLEX)
    rblapack_work = na_change_type(rblapack_work, NA_SCOMPLEX);
  work = NA_PTR_TYPE(rblapack_work, complex*);

  __out__ = cla_hercond_c_(&uplo, &n, a, &lda, af, &ldaf, ipiv, c, &capply, &info, work, rwork);

  rblapack_info = INT2NUM(info);
  rblapack___out__ = rb_float_new((double)__out__);
  return rb_ary_new3(2, rblapack_info, rblapack___out__);
}

void
init_lapack_cla_hercond_c(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cla_hercond_c", rblapack_cla_hercond_c, -1);
}
ruby-lapack-1.7.2/ext/zgelsy.c0000644000175000017500000002454212502221013016043 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgelsy_(integer* m, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, integer* jpvt, doublereal* rcond, integer* rank, doublecomplex* work, integer* lwork, doublereal* rwork, integer* info);


static VALUE
rblapack_zgelsy(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_jpvt;
  integer *jpvt; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_rank;
  integer rank; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  VALUE rblapack_jpvt_out__;
  integer *jpvt_out__;
  doublereal *rwork;

  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  rank, work, info, a, b, jpvt = NumRu::Lapack.zgelsy( a, b, jpvt, rcond, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGELSY computes the minimum-norm solution to a complex linear least\n*  squares problem:\n*      minimize || A * X - B ||\n*  using a complete orthogonal factorization of A.  A is an M-by-N\n*  matrix which may be rank-deficient.\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*  The routine first computes a QR factorization with column pivoting:\n*      A * P = Q * [ R11 R12 ]\n*                  [  0  R22 ]\n*  with R11 defined as the largest leading submatrix whose estimated\n*  condition number is less than 1/RCOND.  The order of R11, RANK,\n*  is the effective rank of A.\n*\n*  Then, R22 is considered to be negligible, and R12 is annihilated\n*  by unitary transformations from the right, arriving at the\n*  complete orthogonal factorization:\n*     A * P = Q * [ T11 0 ] * Z\n*                 [  0  0 ]\n*  The minimum-norm solution is then\n*     X = P * Z' [ inv(T11)*Q1'*B ]\n*                [        0       ]\n*  where Q1 consists of the first RANK columns of Q.\n*\n*  This routine is basically identical to the original xGELSX except\n*  three differences:\n*    o The permutation of matrix B (the right hand side) is faster and\n*      more simple.\n*    o The call to the subroutine xGEQPF has been substituted by the\n*      the call to the subroutine xGEQP3. This subroutine is a Blas-3\n*      version of the QR factorization with column pivoting.\n*    o Matrix B (the right hand side) is updated with Blas-3.\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*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of\n*          columns of matrices B and X. NRHS >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, A has been overwritten by details of its\n*          complete orthogonal factorization.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the M-by-NRHS right hand side matrix B.\n*          On exit, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,M,N).\n*\n*  JPVT    (input/output) INTEGER array, dimension (N)\n*          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n*          to the front of AP, otherwise column i is a free column.\n*          On exit, if JPVT(i) = k, then the i-th column of A*P\n*          was the k-th column of A.\n*\n*  RCOND   (input) DOUBLE PRECISION\n*          RCOND is used to determine the effective rank of A, which\n*          is defined as the order of the largest leading triangular\n*          submatrix R11 in the QR factorization with pivoting of A,\n*          whose estimated condition number < 1/RCOND.\n*\n*  RANK    (output) INTEGER\n*          The effective rank of A, i.e., the order of the submatrix\n*          R11.  This is the same as the order of the submatrix T11\n*          in the complete orthogonal factorization of A.\n*\n*  WORK    (workspace/output) COMPLEX*16 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*          The unblocked strategy requires that:\n*            LWORK >= MN + MAX( 2*MN, N+1, MN+NRHS )\n*          where MN = min(M,N).\n*          The block algorithm requires that:\n*            LWORK >= MN + MAX( 2*MN, NB*(N+1), MN+MN*NB, MN+NB*NRHS )\n*          where NB is an upper bound on the blocksize returned\n*          by ILAENV for the routines ZGEQP3, ZTZRZF, CTZRQF, ZUNMQR,\n*          and ZUNMRZ.\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*  RWORK   (workspace) DOUBLE PRECISION array, dimension (2*N)\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*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*    E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n*    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rank, work, info, a, b, jpvt = NumRu::Lapack.zgelsy( a, b, jpvt, rcond, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  rblapack_jpvt = argv[2];
  rblapack_rcond = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } 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 (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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_jpvt))
    rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
  if (NA_RANK(rblapack_jpvt) != 1)
    rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_jpvt) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_jpvt) != NA_LINT)
    rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
  jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
  m = lda;
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th 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_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  if (rblapack_lwork == Qnil)
    lwork = MAX(MIN(m,n)+3*n+1, 2*MIN(m,n)+nrhs);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  rcond = NUM2DBL(rblapack_rcond);
  ldb = MAX(m,n);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = MAX(m, n);
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  {
    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__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
  MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
  rblapack_jpvt = rblapack_jpvt_out__;
  jpvt = jpvt_out__;
  rwork = ALLOC_N(doublereal, (2*n));

  zgelsy_(&m, &n, &nrhs, a, &lda, b, &ldb, jpvt, &rcond, &rank, work, &lwork, rwork, &info);

  free(rwork);
  rblapack_rank = INT2NUM(rank);
  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(6, rblapack_rank, rblapack_work, rblapack_info, rblapack_a, rblapack_b, rblapack_jpvt);
}

void
init_lapack_zgelsy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgelsy", rblapack_zgelsy, -1);
}
ruby-lapack-1.7.2/ext/zgetrf.c0000644000175000017500000001022012502221020016011 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgetrf_(integer* m, integer* n, doublecomplex* a, integer* lda, integer* ipiv, integer* info);


static VALUE
rblapack_zgetrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *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  ipiv, info, a = NumRu::Lapack.zgetrf( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGETRF computes an LU factorization of a general M-by-N matrix A\n*  using partial pivoting with row interchanges.\n*\n*  The factorization has the form\n*     A = P * L * U\n*  where P is a permutation matrix, L is lower triangular with unit\n*  diagonal elements (lower trapezoidal if m > n), and U is upper\n*  triangular (upper trapezoidal if m < n).\n*\n*  This is the right-looking Level 3 BLAS version of the algorithm.\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) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the M-by-N matrix to be factored.\n*          On exit, the factors L and U from the factorization\n*          A = P*L*U; the unit diagonal elements of L are not stored.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  IPIV    (output) INTEGER array, dimension (min(M,N))\n*          The pivot indices; for 1 <= i <= min(M,N), row i of the\n*          matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n*                has been completed, but the factor U is exactly\n*                singular, and division by zero will occur if it is used\n*                to solve a system of equations.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, a = NumRu::Lapack.zgetrf( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zgetrf_(&m, &n, a, &lda, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_a);
}

void
init_lapack_zgetrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgetrf", rblapack_zgetrf, -1);
}
ruby-lapack-1.7.2/ext/ctbrfs.c0000644000175000017500000001702312502221026016011 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctbrfs_(char* uplo, char* trans, char* diag, integer* n, integer* kd, integer* nrhs, complex* ab, integer* ldab, complex* b, integer* ldb, complex* x, integer* ldx, real* ferr, real* berr, complex* work, real* rwork, integer* info);


static VALUE
rblapack_ctbrfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  complex *work;
  real *rwork;

  integer ldab;
  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info = NumRu::Lapack.ctbrfs( uplo, trans, diag, kd, ab, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTBRFS provides error bounds and backward error estimates for the\n*  solution to a system of linear equations with a triangular band\n*  coefficient matrix.\n*\n*  The solution matrix X must be computed by CTBTRS or some other\n*  means before entering this routine.  CTBRFS does not do iterative\n*  refinement because doing so cannot improve the backward error.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals or subdiagonals of the\n*          triangular band matrix A.  KD >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AB      (input) COMPLEX array, dimension (LDAB,N)\n*          The upper or lower triangular band matrix A, stored in the\n*          first kd+1 rows of the array. The j-th column of A is stored\n*          in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*          If DIAG = 'U', the diagonal elements of A are not referenced\n*          and are assumed to be 1.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  B       (input) COMPLEX array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input) COMPLEX array, dimension (LDX,NRHS)\n*          The solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info = NumRu::Lapack.ctbrfs( uplo, trans, diag, kd, ab, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_kd = argv[3];
  rblapack_ab = argv[4];
  rblapack_b = argv[5];
  rblapack_x = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (7th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  kd = NUM2INT(rblapack_kd);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (n));

  ctbrfs_(&uplo, &trans, &diag, &n, &kd, &nrhs, ab, &ldab, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ferr, rblapack_berr, rblapack_info);
}

void
init_lapack_ctbrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctbrfs", rblapack_ctbrfs, -1);
}
ruby-lapack-1.7.2/ext/ssptrs.c0000644000175000017500000001155412502221015016065 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssptrs_(char* uplo, integer* n, integer* nrhs, real* ap, integer* ipiv, real* b, integer* ldb, integer* info);


static VALUE
rblapack_ssptrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  real *b_out__;

  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.ssptrs( uplo, ap, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSPTRS solves a system of linear equations A*X = B with a real\n*  symmetric matrix A stored in packed format using the factorization\n*  A = U*D*U**T or A = L*D*L**T computed by SSPTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AP      (input) REAL array, dimension (N*(N+1)/2)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by SSPTRF, stored as a\n*          packed triangular matrix.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by SSPTRF.\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.ssptrs( uplo, ap, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  ssptrs_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_ssptrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssptrs", rblapack_ssptrs, -1);
}
ruby-lapack-1.7.2/ext/dpprfs.c0000644000175000017500000001754212502221025016031 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dpprfs_(char* uplo, integer* n, integer* nrhs, doublereal* ap, doublereal* afp, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dpprfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_afp;
  doublereal *afp; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  doublereal *x_out__;
  doublereal *work;
  integer *iwork;

  integer ldb;
  integer nrhs;
  integer ldx;
  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  ferr, berr, info, x = NumRu::Lapack.dpprfs( uplo, ap, afp, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPPRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is symmetric positive definite\n*  and packed, and provides error bounds and backward error estimates\n*  for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          The upper or lower triangle of the symmetric matrix A, packed\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  AFP     (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**T*U or A = L*L**T, as computed by DPPTRF/ZPPTRF,\n*          packed columnwise in a linear array in the same format as A\n*          (see AP).\n*\n*  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by DPPTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.dpprfs( uplo, ap, afp, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_afp = argv[2];
  rblapack_b = argv[3];
  rblapack_x = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  n = ldb;
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (5th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  if (!NA_IsNArray(rblapack_afp))
    rb_raise(rb_eArgError, "afp (3th argument) must be NArray");
  if (NA_RANK(rblapack_afp) != 1)
    rb_raise(rb_eArgError, "rank of afp (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_afp) != NA_DFLOAT)
    rblapack_afp = na_change_type(rblapack_afp, NA_DFLOAT);
  afp = NA_PTR_TYPE(rblapack_afp, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(doublereal, (3*n));
  iwork = ALLOC_N(integer, (n));

  dpprfs_(&uplo, &n, &nrhs, ap, afp, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_dpprfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dpprfs", rblapack_dpprfs, -1);
}
ruby-lapack-1.7.2/ext/dlasq1.c0000644000175000017500000001145212502221024015711 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlasq1_(integer* n, doublereal* d, doublereal* e, doublereal* work, integer* info);


static VALUE
rblapack_dlasq1(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_e_out__;
  doublereal *e_out__;
  doublereal *work;

  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  info, d, e = NumRu::Lapack.dlasq1( d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLASQ1( N, D, E, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLASQ1 computes the singular values of a real N-by-N bidiagonal\n*  matrix with diagonal D and off-diagonal E. The singular values\n*  are computed to high relative accuracy, in the absence of\n*  denormalization, underflow and overflow. The algorithm was first\n*  presented in\n*\n*  \"Accurate singular values and differential qd algorithms\" by K. V.\n*  Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230,\n*  1994,\n*\n*  and the present implementation is described in \"An implementation of\n*  the dqds Algorithm (Positive Case)\", LAPACK Working Note.\n*\n\n*  Arguments\n*  =========\n*\n*  N     (input) INTEGER\n*        The number of rows and columns in the matrix. N >= 0.\n*\n*  D     (input/output) DOUBLE PRECISION array, dimension (N)\n*        On entry, D contains the diagonal elements of the\n*        bidiagonal matrix whose SVD is desired. On normal exit,\n*        D contains the singular values in decreasing order.\n*\n*  E     (input/output) DOUBLE PRECISION array, dimension (N)\n*        On entry, elements E(1:N-1) contain the off-diagonal elements\n*        of the bidiagonal matrix whose SVD is desired.\n*        On exit, E is overwritten.\n*\n*  WORK  (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n*  INFO  (output) INTEGER\n*        = 0: successful exit\n*        < 0: if INFO = -i, the i-th argument had an illegal value\n*        > 0: the algorithm failed\n*             = 1, a split was marked by a positive value in E\n*             = 2, current block of Z not diagonalized after 30*N\n*                  iterations (in inner while loop)\n*             = 3, termination criterion of outer while loop not met \n*                  (program created more than N unreduced blocks)\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, e = NumRu::Lapack.dlasq1( d, e, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_d = argv[0];
  rblapack_e = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (2th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
  MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  work = ALLOC_N(doublereal, (4*n));

  dlasq1_(&n, d, e, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_d, rblapack_e);
}

void
init_lapack_dlasq1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlasq1", rblapack_dlasq1, -1);
}
ruby-lapack-1.7.2/ext/ztgsna.c0000644000175000017500000003306612502221022016035 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztgsna_(char* job, char* howmny, logical* select, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* vl, integer* ldvl, doublecomplex* vr, integer* ldvr, doublereal* s, doublereal* dif, integer* mm, integer* m, doublecomplex* work, integer* lwork, integer* iwork, integer* info);


static VALUE
rblapack_ztgsna(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_howmny;
  char howmny; 
  VALUE rblapack_select;
  logical *select; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_vl;
  doublecomplex *vl; 
  VALUE rblapack_vr;
  doublecomplex *vr; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_dif;
  doublereal *dif; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  integer *iwork;

  integer n;
  integer lda;
  integer ldb;
  integer ldvl;
  integer ldvr;
  integer mm;

  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  s, dif, m, work, info = NumRu::Lapack.ztgsna( job, howmny, select, a, b, vl, vr, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTGSNA estimates reciprocal condition numbers for specified\n*  eigenvalues and/or eigenvectors of a matrix pair (A, B).\n*\n*  (A, B) must be in generalized Schur canonical form, that is, A and\n*  B are both upper triangular.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies whether condition numbers are required for\n*          eigenvalues (S) or eigenvectors (DIF):\n*          = 'E': for eigenvalues only (S);\n*          = 'V': for eigenvectors only (DIF);\n*          = 'B': for both eigenvalues and eigenvectors (S and DIF).\n*\n*  HOWMNY  (input) CHARACTER*1\n*          = 'A': compute condition numbers for all eigenpairs;\n*          = 'S': compute condition numbers for selected eigenpairs\n*                 specified by the array SELECT.\n*\n*  SELECT  (input) LOGICAL array, dimension (N)\n*          If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n*          condition numbers are required. To select condition numbers\n*          for the corresponding j-th eigenvalue and/or eigenvector,\n*          SELECT(j) must be set to .TRUE..\n*          If HOWMNY = 'A', SELECT is not referenced.\n*\n*  N       (input) INTEGER\n*          The order of the square matrix pair (A, B). N >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          The upper triangular matrix A in the pair (A,B).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  B       (input) COMPLEX*16 array, dimension (LDB,N)\n*          The upper triangular matrix B in the pair (A, B).\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  VL      (input) COMPLEX*16 array, dimension (LDVL,M)\n*          IF JOB = 'E' or 'B', VL must contain left eigenvectors of\n*          (A, B), corresponding to the eigenpairs specified by HOWMNY\n*          and SELECT.  The eigenvectors must be stored in consecutive\n*          columns of VL, as returned by ZTGEVC.\n*          If JOB = 'V', VL is not referenced.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the array VL. LDVL >= 1; and\n*          If JOB = 'E' or 'B', LDVL >= N.\n*\n*  VR      (input) COMPLEX*16 array, dimension (LDVR,M)\n*          IF JOB = 'E' or 'B', VR must contain right eigenvectors of\n*          (A, B), corresponding to the eigenpairs specified by HOWMNY\n*          and SELECT.  The eigenvectors must be stored in consecutive\n*          columns of VR, as returned by ZTGEVC.\n*          If JOB = 'V', VR is not referenced.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the array VR. LDVR >= 1;\n*          If JOB = 'E' or 'B', LDVR >= N.\n*\n*  S       (output) DOUBLE PRECISION array, dimension (MM)\n*          If JOB = 'E' or 'B', the reciprocal condition numbers of the\n*          selected eigenvalues, stored in consecutive elements of the\n*          array.\n*          If JOB = 'V', S is not referenced.\n*\n*  DIF     (output) DOUBLE PRECISION array, dimension (MM)\n*          If JOB = 'V' or 'B', the estimated reciprocal condition\n*          numbers of the selected eigenvectors, stored in consecutive\n*          elements of the array.\n*          If the eigenvalues cannot be reordered to compute DIF(j),\n*          DIF(j) is set to 0; this can only occur when the true value\n*          would be very small anyway.\n*          For each eigenvalue/vector specified by SELECT, DIF stores\n*          a Frobenius norm-based estimate of Difl.\n*          If JOB = 'E', DIF is not referenced.\n*\n*  MM      (input) INTEGER\n*          The number of elements in the arrays S and DIF. MM >= M.\n*\n*  M       (output) INTEGER\n*          The number of elements of the arrays S and DIF used to store\n*          the specified condition numbers; for each selected eigenvalue\n*          one element is used. If HOWMNY = 'A', M is set to N.\n*\n*  WORK    (workspace/output) COMPLEX*16 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,N).\n*          If JOB = 'V' or 'B', LWORK >= max(1,2*N*N).\n*\n*  IWORK   (workspace) INTEGER array, dimension (N+2)\n*          If JOB = 'E', IWORK is not referenced.\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 reciprocal of the condition number of the i-th generalized\n*  eigenvalue w = (a, b) is defined as\n*\n*          S(I) = (|v'Au|**2 + |v'Bu|**2)**(1/2) / (norm(u)*norm(v))\n*\n*  where u and v are the right and left eigenvectors of (A, B)\n*  corresponding to w; |z| denotes the absolute value of the complex\n*  number, and norm(u) denotes the 2-norm of the vector u. The pair\n*  (a, b) corresponds to an eigenvalue w = a/b (= v'Au/v'Bu) of the\n*  matrix pair (A, B). If both a and b equal zero, then (A,B) is\n*  singular and S(I) = -1 is returned.\n*\n*  An approximate error bound on the chordal distance between the i-th\n*  computed generalized eigenvalue w and the corresponding exact\n*  eigenvalue lambda is\n*\n*          chord(w, lambda) <=   EPS * norm(A, B) / S(I),\n*\n*  where EPS is the machine precision.\n*\n*  The reciprocal of the condition number of the right eigenvector u\n*  and left eigenvector v corresponding to the generalized eigenvalue w\n*  is defined as follows. Suppose\n*\n*                   (A, B) = ( a   *  ) ( b  *  )  1\n*                            ( 0  A22 ),( 0 B22 )  n-1\n*                              1  n-1     1 n-1\n*\n*  Then the reciprocal condition number DIF(I) is\n*\n*          Difl[(a, b), (A22, B22)]  = sigma-min( Zl )\n*\n*  where sigma-min(Zl) denotes the smallest singular value of\n*\n*         Zl = [ kron(a, In-1) -kron(1, A22) ]\n*              [ kron(b, In-1) -kron(1, B22) ].\n*\n*  Here In-1 is the identity matrix of size n-1 and X' is the conjugate\n*  transpose of X. kron(X, Y) is the Kronecker product between the\n*  matrices X and Y.\n*\n*  We approximate the smallest singular value of Zl with an upper\n*  bound. This is done by ZLATDF.\n*\n*  An approximate error bound for a computed eigenvector VL(i) or\n*  VR(i) is given by\n*\n*                      EPS * norm(A, B) / DIF(i).\n*\n*  See ref. [2-3] for more details and further references.\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  References\n*  ==========\n*\n*  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n*      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n*      M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n*      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n*  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n*      Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n*      Estimation: Theory, Algorithms and Software, Report\n*      UMINF - 94.04, Department of Computing Science, Umea University,\n*      S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.\n*      To appear in Numerical Algorithms, 1996.\n*\n*  [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n*      for Solving the Generalized Sylvester Equation and Estimating the\n*      Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n*      Department of Computing Science, Umea University, S-901 87 Umea,\n*      Sweden, December 1993, Revised April 1994, Also as LAPACK Working\n*      Note 75.\n*      To appear in ACM Trans. on Math. Software, Vol 22, No 1, 1996.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, dif, m, work, info = NumRu::Lapack.ztgsna( job, howmny, select, a, b, vl, vr, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_job = argv[0];
  rblapack_howmny = argv[1];
  rblapack_select = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  rblapack_vl = argv[5];
  rblapack_vr = argv[6];
  if (argc == 8) {
    rblapack_lwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  job = StringValueCStr(rblapack_job)[0];
  if (!NA_IsNArray(rblapack_select))
    rb_raise(rb_eArgError, "select (3th argument) must be NArray");
  if (NA_RANK(rblapack_select) != 1)
    rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_select);
  if (NA_TYPE(rblapack_select) != NA_LINT)
    rblapack_select = na_change_type(rblapack_select, NA_LINT);
  select = NA_PTR_TYPE(rblapack_select, logical*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  if (!NA_IsNArray(rblapack_vr))
    rb_raise(rb_eArgError, "vr (7th argument) must be NArray");
  if (NA_RANK(rblapack_vr) != 2)
    rb_raise(rb_eArgError, "rank of vr (7th argument) must be %d", 2);
  ldvr = NA_SHAPE0(rblapack_vr);
  m = NA_SHAPE1(rblapack_vr);
  if (NA_TYPE(rblapack_vr) != NA_DCOMPLEX)
    rblapack_vr = na_change_type(rblapack_vr, NA_DCOMPLEX);
  vr = NA_PTR_TYPE(rblapack_vr, doublecomplex*);
  howmny = StringValueCStr(rblapack_howmny)[0];
  if (!NA_IsNArray(rblapack_vl))
    rb_raise(rb_eArgError, "vl (6th argument) must be NArray");
  if (NA_RANK(rblapack_vl) != 2)
    rb_raise(rb_eArgError, "rank of vl (6th argument) must be %d", 2);
  ldvl = NA_SHAPE0(rblapack_vl);
  if (NA_SHAPE1(rblapack_vl) != m)
    rb_raise(rb_eRuntimeError, "shape 1 of vl must be the same as shape 1 of vr");
  if (NA_TYPE(rblapack_vl) != NA_DCOMPLEX)
    rblapack_vl = na_change_type(rblapack_vl, NA_DCOMPLEX);
  vl = NA_PTR_TYPE(rblapack_vl, doublecomplex*);
  mm = m;
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (rblapack_lwork == Qnil)
    lwork = (lsame_(&job,"V")||lsame_(&job,"B")) ? 2*n*n : n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = mm;
    rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = mm;
    rblapack_dif = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  dif = NA_PTR_TYPE(rblapack_dif, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  iwork = ALLOC_N(integer, (lsame_(&job,"E") ? 0 : n+2));

  ztgsna_(&job, &howmny, select, &n, a, &lda, b, &ldb, vl, &ldvl, vr, &ldvr, s, dif, &mm, &m, work, &lwork, iwork, &info);

  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_s, rblapack_dif, rblapack_m, rblapack_work, rblapack_info);
}

void
init_lapack_ztgsna(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztgsna", rblapack_ztgsna, -1);
}
ruby-lapack-1.7.2/ext/ssytri2.c0000644000175000017500000001540712502221026016151 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssytri2_(char* uplo, integer* n, real* a, integer* lda, integer* ipiv, real* work, integer* lwork, integer* info);


static VALUE
rblapack_ssytri2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_work_out__;
  real *work_out__;
  integer c__1;
  integer c__m1;
  integer nb;

  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  info, a, work = NumRu::Lapack.ssytri2( uplo, a, ipiv, work, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSYTRI2 computes the inverse of a real symmetric indefinite matrix\n*  A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n*  SSYTRF. SSYTRI2 sets the LEADING DIMENSION of the workspace\n*  before calling SSYTRI2X that actually computes the inverse.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the NB diagonal matrix D and the multipliers\n*          used to obtain the factor U or L as computed by SSYTRF.\n*\n*          On exit, if INFO = 0, the (symmetric) inverse of the original\n*          matrix.  If UPLO = 'U', the upper triangular part of the\n*          inverse is formed and the part of A below the diagonal is not\n*          referenced; if UPLO = 'L' the lower triangular part of the\n*          inverse is formed and the part of A above the diagonal is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the NB structure of D\n*          as determined by SSYTRF.\n*\n*  WORK    (workspace) REAL array, dimension (N+NB+1)*(NB+3)\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK.\n*          WORK is size >= (N+NB+1)*(NB+3)\n*          If LDWORK = -1, then a workspace query is assumed; the routine\n*           calculates:\n*              - the optimal size of the WORK array, returns\n*          this value as the first entry of the WORK array,\n*              - and no error message related to LDWORK 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, D(i,i) = 0; the matrix is singular and its\n*               inverse could not be computed.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            UPPER, LQUERY\n      INTEGER            MINSIZE, NBMAX\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            ILAENV\n      EXTERNAL           LSAME, ILAENV\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SSYTRI2X\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a, work = NumRu::Lapack.ssytri2( uplo, a, ipiv, work, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_work = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  c__1 = 1;
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  c__m1 = -1;
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (4th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (4th argument) must be %d", 1);
  lwork = NA_SHAPE0(rblapack_work);
  if (NA_TYPE(rblapack_work) != NA_SFLOAT)
    rblapack_work = na_change_type(rblapack_work, NA_SFLOAT);
  work = NA_PTR_TYPE(rblapack_work, real*);
  nb = ilaenv_(&c__1, "SSYTRF", &uplo, &n, &c__m1, &c__m1, &c__m1);
  if (rblapack_lwork == Qnil)
    lwork = (n+nb+1)*(nb+3);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[1];
    shape[0] = lwork;
    rblapack_work_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work_out__ = NA_PTR_TYPE(rblapack_work_out__, real*);
  MEMCPY(work_out__, work, real, NA_TOTAL(rblapack_work));
  rblapack_work = rblapack_work_out__;
  work = work_out__;

  ssytri2_(&uplo, &n, a, &lda, ipiv, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_a, rblapack_work);
}

void
init_lapack_ssytri2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssytri2", rblapack_ssytri2, -1);
}
ruby-lapack-1.7.2/ext/zla_syrcond_c.c0000644000175000017500000001706012502221025017357 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal zla_syrcond_c_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublereal* c, logical* capply, integer* info, doublecomplex* work, doublereal* rwork);


static VALUE
rblapack_zla_syrcond_c(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_capply;
  logical capply; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_rwork;
  doublereal *rwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack___out__;
  doublereal __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  info, __out__ = NumRu::Lapack.zla_syrcond_c( uplo, a, af, ipiv, c, capply, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION ZLA_SYRCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n*  Purpose\n*  =======\n*\n*     ZLA_SYRCOND_C Computes the infinity norm condition number of\n*     op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector.\n*\n\n*  Arguments\n*  =========\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     A       (input) COMPLEX*16 array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX*16 array, dimension (LDAF,N)\n*     The block diagonal matrix D and the multipliers used to\n*     obtain the factor U or L as computed by ZSYTRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     Details of the interchanges and the block structure of D\n*     as determined by ZSYTRF.\n*\n*     C       (input) DOUBLE PRECISION array, dimension (N)\n*     The vector C in the formula op(A) * inv(diag(C)).\n*\n*     CAPPLY  (input) LOGICAL\n*     If .TRUE. then access the vector C in the formula above.\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit.\n*     i > 0:  The ith argument is invalid.\n*\n*     WORK    (input) COMPLEX*16 array, dimension (2*N).\n*     Workspace.\n*\n*     RWORK   (input) DOUBLE PRECISION array, dimension (N).\n*     Workspace.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            KASE\n      DOUBLE PRECISION   AINVNM, ANORM, TMP\n      INTEGER            I, J\n      LOGICAL            UP\n      COMPLEX*16         ZDUM\n*     ..\n*     .. Local Arrays ..\n      INTEGER            ISAVE( 3 )\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           ZLACN2, ZSYTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX\n*     ..\n*     .. Statement Functions ..\n      DOUBLE PRECISION CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, __out__ = NumRu::Lapack.zla_syrcond_c( uplo, a, af, ipiv, c, capply, work, rwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_c = argv[4];
  rblapack_capply = argv[5];
  rblapack_work = argv[6];
  rblapack_rwork = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_rwork))
    rb_raise(rb_eArgError, "rwork (8th argument) must be NArray");
  if (NA_RANK(rblapack_rwork) != 1)
    rb_raise(rb_eArgError, "rank of rwork (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_rwork) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_rwork) != NA_DFLOAT)
    rblapack_rwork = na_change_type(rblapack_rwork, NA_DFLOAT);
  rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  capply = (rblapack_capply == Qtrue);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (7th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
  if (NA_TYPE(rblapack_work) != NA_DCOMPLEX)
    rblapack_work = na_change_type(rblapack_work, NA_DCOMPLEX);
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);

  __out__ = zla_syrcond_c_(&uplo, &n, a, &lda, af, &ldaf, ipiv, c, &capply, &info, work, rwork);

  rblapack_info = INT2NUM(info);
  rblapack___out__ = rb_float_new((double)__out__);
  return rb_ary_new3(2, rblapack_info, rblapack___out__);
}

void
init_lapack_zla_syrcond_c(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zla_syrcond_c", rblapack_zla_syrcond_c, -1);
}
ruby-lapack-1.7.2/ext/dsptrs.c0000644000175000017500000001167212502221014016046 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsptrs_(char* uplo, integer* n, integer* nrhs, doublereal* ap, integer* ipiv, doublereal* b, integer* ldb, integer* info);


static VALUE
rblapack_dsptrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublereal *b_out__;

  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.dsptrs( uplo, ap, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSPTRS solves a system of linear equations A*X = B with a real\n*  symmetric matrix A stored in packed format using the factorization\n*  A = U*D*U**T or A = L*D*L**T computed by DSPTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by DSPTRF, stored as a\n*          packed triangular matrix.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by DSPTRF.\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.dsptrs( uplo, ap, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dsptrs_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_dsptrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsptrs", rblapack_dsptrs, -1);
}
ruby-lapack-1.7.2/ext/sstein.c0000644000175000017500000001771212502221017016040 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sstein_(integer* n, real* d, real* e, integer* m, real* w, integer* iblock, integer* isplit, real* z, integer* ldz, real* work, integer* iwork, integer* ifail, integer* info);


static VALUE
rblapack_sstein(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_iblock;
  integer *iblock; 
  VALUE rblapack_isplit;
  integer *isplit; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_ifail;
  integer *ifail; 
  VALUE rblapack_info;
  integer info; 
  real *work;
  integer *iwork;

  integer n;
  integer ldz;
  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  z, ifail, info = NumRu::Lapack.sstein( d, e, w, iblock, isplit, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSTEIN computes the eigenvectors of a real symmetric tridiagonal\n*  matrix T corresponding to specified eigenvalues, using inverse\n*  iteration.\n*\n*  The maximum number of iterations allowed for each eigenvector is\n*  specified by an internal parameter MAXITS (currently set to 5).\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  D       (input) REAL array, dimension (N)\n*          The n diagonal elements of the tridiagonal matrix T.\n*\n*  E       (input) REAL array, dimension (N-1)\n*          The (n-1) subdiagonal elements of the tridiagonal matrix\n*          T, in elements 1 to N-1.\n*\n*  M       (input) INTEGER\n*          The number of eigenvectors to be found.  0 <= M <= N.\n*\n*  W       (input) REAL array, dimension (N)\n*          The first M elements of W contain the eigenvalues for\n*          which eigenvectors are to be computed.  The eigenvalues\n*          should be grouped by split-off block and ordered from\n*          smallest to largest within the block.  ( The output array\n*          W from SSTEBZ with ORDER = 'B' is expected here. )\n*\n*  IBLOCK  (input) INTEGER array, dimension (N)\n*          The submatrix indices associated with the corresponding\n*          eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to\n*          the first submatrix from the top, =2 if W(i) belongs to\n*          the second submatrix, etc.  ( The output array IBLOCK\n*          from SSTEBZ is expected here. )\n*\n*  ISPLIT  (input) INTEGER array, dimension (N)\n*          The splitting points, at which T breaks up into submatrices.\n*          The first submatrix consists of rows/columns 1 to\n*          ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n*          through ISPLIT( 2 ), etc.\n*          ( The output array ISPLIT from SSTEBZ is expected here. )\n*\n*  Z       (output) REAL array, dimension (LDZ, M)\n*          The computed eigenvectors.  The eigenvector associated\n*          with the eigenvalue W(i) is stored in the i-th column of\n*          Z.  Any vector which fails to converge is set to its current\n*          iterate after MAXITS iterations.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= max(1,N).\n*\n*  WORK    (workspace) REAL array, dimension (5*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\n*\n*  IFAIL   (output) INTEGER array, dimension (M)\n*          On normal exit, all elements of IFAIL are zero.\n*          If one or more eigenvectors fail to converge after\n*          MAXITS iterations, then their indices are stored in\n*          array IFAIL.\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, then i eigenvectors failed to converge\n*               in MAXITS iterations.  Their indices are stored in\n*               array IFAIL.\n*\n*  Internal Parameters\n*  ===================\n*\n*  MAXITS  INTEGER, default = 5\n*          The maximum number of iterations performed.\n*\n*  EXTRA   INTEGER, default = 2\n*          The number of iterations performed after norm growth\n*          criterion is satisfied, should be at least 1.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  z, ifail, info = NumRu::Lapack.sstein( d, e, w, iblock, isplit, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_d = argv[0];
  rblapack_e = argv[1];
  rblapack_w = argv[2];
  rblapack_iblock = argv[3];
  rblapack_isplit = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_w))
    rb_raise(rb_eArgError, "w (3th argument) must be NArray");
  if (NA_RANK(rblapack_w) != 1)
    rb_raise(rb_eArgError, "rank of w (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_w) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_w) != NA_SFLOAT)
    rblapack_w = na_change_type(rblapack_w, NA_SFLOAT);
  w = NA_PTR_TYPE(rblapack_w, real*);
  if (!NA_IsNArray(rblapack_isplit))
    rb_raise(rb_eArgError, "isplit (5th argument) must be NArray");
  if (NA_RANK(rblapack_isplit) != 1)
    rb_raise(rb_eArgError, "rank of isplit (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_isplit) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of isplit must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_isplit) != NA_LINT)
    rblapack_isplit = na_change_type(rblapack_isplit, NA_LINT);
  isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
  if (!NA_IsNArray(rblapack_iblock))
    rb_raise(rb_eArgError, "iblock (4th argument) must be NArray");
  if (NA_RANK(rblapack_iblock) != 1)
    rb_raise(rb_eArgError, "rank of iblock (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_iblock) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of iblock must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_iblock) != NA_LINT)
    rblapack_iblock = na_change_type(rblapack_iblock, NA_LINT);
  iblock = NA_PTR_TYPE(rblapack_iblock, integer*);
  m = n;
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (2th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  ldz = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = m;
    rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
  work = ALLOC_N(real, (5*n));
  iwork = ALLOC_N(integer, (n));

  sstein_(&n, d, e, &m, w, iblock, isplit, z, &ldz, work, iwork, ifail, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_z, rblapack_ifail, rblapack_info);
}

void
init_lapack_sstein(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sstein", rblapack_sstein, -1);
}
ruby-lapack-1.7.2/ext/slasyf.c0000644000175000017500000001414112502221021016020 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slasyf_(char* uplo, integer* n, integer* nb, integer* kb, real* a, integer* lda, integer* ipiv, real* w, integer* ldw, integer* info);


static VALUE
rblapack_slasyf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_nb;
  integer nb; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_kb;
  integer kb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  real *w;

  integer lda;
  integer n;
  integer ldw;

  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  kb, ipiv, info, a = NumRu::Lapack.slasyf( uplo, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLASYF computes a partial factorization of a real symmetric matrix A\n*  using the Bunch-Kaufman diagonal pivoting method. The partial\n*  factorization has the form:\n*\n*  A  =  ( I  U12 ) ( A11  0  ) (  I    0   )  if UPLO = 'U', or:\n*        ( 0  U22 ) (  0   D  ) ( U12' U22' )\n*\n*  A  =  ( L11  0 ) (  D   0  ) ( L11' L21' )  if UPLO = 'L'\n*        ( L21  I ) (  0  A22 ) (  0    I   )\n*\n*  where the order of D is at most NB. The actual order is returned in\n*  the argument KB, and is either NB or NB-1, or N if N <= NB.\n*\n*  SLASYF is an auxiliary routine called by SSYTRF. It uses blocked code\n*  (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or\n*  A22 (if UPLO = 'L').\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored:\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NB      (input) INTEGER\n*          The maximum number of columns of the matrix A that should be\n*          factored.  NB should be at least 2 to allow for 2-by-2 pivot\n*          blocks.\n*\n*  KB      (output) INTEGER\n*          The number of columns of A that were actually factored.\n*          KB is either NB-1 or NB, or N if N <= NB.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          n-by-n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n-by-n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*          On exit, A contains details of the partial factorization.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D.\n*          If UPLO = 'U', only the last KB elements of IPIV are set;\n*          if UPLO = 'L', only the first KB elements are set.\n*\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*  W       (workspace) REAL array, dimension (LDW,NB)\n*\n*  LDW     (input) INTEGER\n*          The leading dimension of the array W.  LDW >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          > 0: if INFO = k, D(k,k) is exactly zero.  The factorization\n*               has been completed, but the block diagonal matrix D is\n*               exactly singular.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  kb, ipiv, info, a = NumRu::Lapack.slasyf( uplo, nb, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_nb = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  nb = NUM2INT(rblapack_nb);
  ldw = MAX(1,n);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  w = ALLOC_N(real, (ldw)*(MAX(1,nb)));

  slasyf_(&uplo, &n, &nb, &kb, a, &lda, ipiv, w, &ldw, &info);

  free(w);
  rblapack_kb = INT2NUM(kb);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_kb, rblapack_ipiv, rblapack_info, rblapack_a);
}

void
init_lapack_slasyf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slasyf", rblapack_slasyf, -1);
}
ruby-lapack-1.7.2/ext/dgeqrf.c0000644000175000017500000001344312502221014015775 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgeqrf_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dgeqrf(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.dgeqrf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGEQRF computes a QR factorization of a real M-by-N matrix A:\n*  A = Q * R.\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 above the diagonal of the array\n*          contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n*          upper triangular if m >= n); the elements below the diagonal,\n*          with the array TAU, represent the orthogonal matrix Q as a\n*          product of min(m,n) elementary reflectors (see Further\n*          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,N).\n*          For optimum performance LWORK >= N*NB, where NB is\n*          the 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(1) H(2) . . . H(k), 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:m) is stored on exit in A(i+1:m,i),\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           DGEQR2, 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.dgeqrf( 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;
  }

  m = NUM2INT(rblapack_m);
  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*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;

  dgeqrf_(&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_dgeqrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgeqrf", rblapack_dgeqrf, -1);
}
ruby-lapack-1.7.2/ext/slasd8.c0000644000175000017500000002200612502221020015713 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slasd8_(integer* icompq, integer* k, real* d, real* z, real* vf, real* vl, real* difl, real* difr, integer* lddifr, real* dsigma, real* work, integer* info);


static VALUE
rblapack_slasd8(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_icompq;
  integer icompq; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_vf;
  real *vf; 
  VALUE rblapack_vl;
  real *vl; 
  VALUE rblapack_dsigma;
  real *dsigma; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_difl;
  real *difl; 
  VALUE rblapack_difr;
  real *difr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_z_out__;
  real *z_out__;
  VALUE rblapack_vf_out__;
  real *vf_out__;
  VALUE rblapack_vl_out__;
  real *vl_out__;
  VALUE rblapack_dsigma_out__;
  real *dsigma_out__;
  real *work;

  integer k;
  integer lddifr;

  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  d, difl, difr, info, z, vf, vl, dsigma = NumRu::Lapack.slasd8( icompq, z, vf, vl, dsigma, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, DSIGMA, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLASD8 finds the square roots of the roots of the secular equation,\n*  as defined by the values in DSIGMA and Z. It makes the appropriate\n*  calls to SLASD4, and stores, for each  element in D, the distance\n*  to its two nearest poles (elements in DSIGMA). It also updates\n*  the arrays VF and VL, the first and last components of all the\n*  right singular vectors of the original bidiagonal matrix.\n*\n*  SLASD8 is called from SLASD6.\n*\n\n*  Arguments\n*  =========\n*\n*  ICOMPQ  (input) INTEGER\n*          Specifies whether singular vectors are to be computed in\n*          factored form in the calling routine:\n*          = 0: Compute singular values only.\n*          = 1: Compute singular vectors in factored form as well.\n*\n*  K       (input) INTEGER\n*          The number of terms in the rational function to be solved\n*          by SLASD4.  K >= 1.\n*\n*  D       (output) REAL array, dimension ( K )\n*          On output, D contains the updated singular values.\n*\n*  Z       (input/output) REAL array, dimension ( K )\n*          On entry, the first K elements of this array contain the\n*          components of the deflation-adjusted updating row vector.\n*          On exit, Z is updated.\n*\n*  VF      (input/output) REAL array, dimension ( K )\n*          On entry, VF contains  information passed through DBEDE8.\n*          On exit, VF contains the first K components of the first\n*          components of all right singular vectors of the bidiagonal\n*          matrix.\n*\n*  VL      (input/output) REAL array, dimension ( K )\n*          On entry, VL contains  information passed through DBEDE8.\n*          On exit, VL contains the first K components of the last\n*          components of all right singular vectors of the bidiagonal\n*          matrix.\n*\n*  DIFL    (output) REAL array, dimension ( K )\n*          On exit, DIFL(I) = D(I) - DSIGMA(I).\n*\n*  DIFR    (output) REAL array,\n*                   dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and\n*                   dimension ( K ) if ICOMPQ = 0.\n*          On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not\n*          defined and will not be referenced.\n*\n*          If ICOMPQ = 1, DIFR(1:K,2) is an array containing the\n*          normalizing factors for the right singular vector matrix.\n*\n*  LDDIFR  (input) INTEGER\n*          The leading dimension of DIFR, must be at least K.\n*\n*  DSIGMA  (input/output) REAL array, dimension ( K )\n*          On entry, the first K elements of this array contain the old\n*          roots of the deflated updating problem.  These are the poles\n*          of the secular equation.\n*          On exit, the elements of DSIGMA may be very slightly altered\n*          in value.\n*\n*  WORK    (workspace) REAL array, dimension at least 3 * K\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 = 1, a singular value did not converge\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, difl, difr, info, z, vf, vl, dsigma = NumRu::Lapack.slasd8( icompq, z, vf, vl, dsigma, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_icompq = argv[0];
  rblapack_z = argv[1];
  rblapack_vf = argv[2];
  rblapack_vl = argv[3];
  rblapack_dsigma = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  icompq = NUM2INT(rblapack_icompq);
  if (!NA_IsNArray(rblapack_vf))
    rb_raise(rb_eArgError, "vf (3th argument) must be NArray");
  if (NA_RANK(rblapack_vf) != 1)
    rb_raise(rb_eArgError, "rank of vf (3th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_vf);
  if (NA_TYPE(rblapack_vf) != NA_SFLOAT)
    rblapack_vf = na_change_type(rblapack_vf, NA_SFLOAT);
  vf = NA_PTR_TYPE(rblapack_vf, real*);
  if (!NA_IsNArray(rblapack_dsigma))
    rb_raise(rb_eArgError, "dsigma (5th argument) must be NArray");
  if (NA_RANK(rblapack_dsigma) != 1)
    rb_raise(rb_eArgError, "rank of dsigma (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dsigma) != k)
    rb_raise(rb_eRuntimeError, "shape 0 of dsigma must be the same as shape 0 of vf");
  if (NA_TYPE(rblapack_dsigma) != NA_SFLOAT)
    rblapack_dsigma = na_change_type(rblapack_dsigma, NA_SFLOAT);
  dsigma = NA_PTR_TYPE(rblapack_dsigma, real*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (2th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != k)
    rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of vf");
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  if (!NA_IsNArray(rblapack_vl))
    rb_raise(rb_eArgError, "vl (4th argument) must be NArray");
  if (NA_RANK(rblapack_vl) != 1)
    rb_raise(rb_eArgError, "rank of vl (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_vl) != k)
    rb_raise(rb_eRuntimeError, "shape 0 of vl must be the same as shape 0 of vf");
  if (NA_TYPE(rblapack_vl) != NA_SFLOAT)
    rblapack_vl = na_change_type(rblapack_vl, NA_SFLOAT);
  vl = NA_PTR_TYPE(rblapack_vl, real*);
  lddifr = k;
  {
    na_shape_t shape[1];
    shape[0] = k;
    rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, real*);
  {
    na_shape_t shape[1];
    shape[0] = k;
    rblapack_difl = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  difl = NA_PTR_TYPE(rblapack_difl, real*);
  {
    na_shape_t shape[2];
    shape[0] = icompq == 1 ? lddifr : icompq == 0 ? k : 0;
    shape[1] = icompq == 1 ? 2 : 0;
    rblapack_difr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  difr = NA_PTR_TYPE(rblapack_difr, real*);
  {
    na_shape_t shape[1];
    shape[0] = k;
    rblapack_z_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
  MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  {
    na_shape_t shape[1];
    shape[0] = k;
    rblapack_vf_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  vf_out__ = NA_PTR_TYPE(rblapack_vf_out__, real*);
  MEMCPY(vf_out__, vf, real, NA_TOTAL(rblapack_vf));
  rblapack_vf = rblapack_vf_out__;
  vf = vf_out__;
  {
    na_shape_t shape[1];
    shape[0] = k;
    rblapack_vl_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, real*);
  MEMCPY(vl_out__, vl, real, NA_TOTAL(rblapack_vl));
  rblapack_vl = rblapack_vl_out__;
  vl = vl_out__;
  {
    na_shape_t shape[1];
    shape[0] = k;
    rblapack_dsigma_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  dsigma_out__ = NA_PTR_TYPE(rblapack_dsigma_out__, real*);
  MEMCPY(dsigma_out__, dsigma, real, NA_TOTAL(rblapack_dsigma));
  rblapack_dsigma = rblapack_dsigma_out__;
  dsigma = dsigma_out__;
  work = ALLOC_N(real, (3 * k));

  slasd8_(&icompq, &k, d, z, vf, vl, difl, difr, &lddifr, dsigma, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_d, rblapack_difl, rblapack_difr, rblapack_info, rblapack_z, rblapack_vf, rblapack_vl, rblapack_dsigma);
}

void
init_lapack_slasd8(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slasd8", rblapack_slasd8, -1);
}
ruby-lapack-1.7.2/ext/dormqr.c0000644000175000017500000001642412502221024016034 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dormqr_(char* side, char* trans, integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* c, integer* ldc, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dormqr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublereal *c_out__;

  integer lda;
  integer k;
  integer ldc;
  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  work, info, c = NumRu::Lapack.dormqr( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DORMQR overwrites the general real M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'T':      Q**T * C       C * Q**T\n*\n*  where Q is a real orthogonal matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(1) H(2) . . . H(k)\n*\n*  as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**T from the Left;\n*          = 'R': apply Q or Q**T from the Right.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'T':  Transpose, apply Q**T.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,K)\n*          The i-th column must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          DGEQRF in the first k columns of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*          If SIDE = 'L', LDA >= max(1,M);\n*          if SIDE = 'R', LDA >= max(1,N).\n*\n*  TAU     (input) DOUBLE PRECISION array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by DGEQRF.\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M).\n*          For optimum performance LWORK >= N*NB if SIDE = 'L', and\n*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n*          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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.dormqr( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_m = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 7) {
    rblapack_lwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  side = StringValueCStr(rblapack_side)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != k)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  dormqr_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_dormqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dormqr", rblapack_dormqr, -1);
}
ruby-lapack-1.7.2/ext/ztprfs.c0000644000175000017500000001651312502221023016056 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztprfs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, doublecomplex* ap, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_ztprfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  doublecomplex *work;
  doublereal *rwork;

  integer ldb;
  integer nrhs;
  integer ldx;
  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  ferr, berr, info = NumRu::Lapack.ztprfs( uplo, trans, diag, ap, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTPRFS provides error bounds and backward error estimates for the\n*  solution to a system of linear equations with a triangular packed\n*  coefficient matrix.\n*\n*  The solution matrix X must be computed by ZTPTRS or some other\n*  means before entering this routine.  ZTPRFS does not do iterative\n*  refinement because doing so cannot improve the backward error.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          The upper or lower triangular matrix A, packed columnwise in\n*          a linear array.  The j-th column of A is stored in the array\n*          AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          If DIAG = 'U', the diagonal elements of A are not referenced\n*          and are assumed to be 1.\n*\n*  B       (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input) COMPLEX*16 array, dimension (LDX,NRHS)\n*          The solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info = NumRu::Lapack.ztprfs( uplo, trans, diag, ap, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_ap = argv[3];
  rblapack_b = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  n = ldb;
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (n));

  ztprfs_(&uplo, &trans, &diag, &n, &nrhs, ap, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ferr, rblapack_berr, rblapack_info);
}

void
init_lapack_ztprfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztprfs", rblapack_ztprfs, -1);
}
ruby-lapack-1.7.2/ext/cpstrf.c0000644000175000017500000001252412502221026016030 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cpstrf_(char* uplo, integer* n, complex* a, integer* lda, integer* piv, integer* rank, real* tol, real* work, integer* info);


static VALUE
rblapack_cpstrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tol;
  real tol; 
  VALUE rblapack_piv;
  integer *piv; 
  VALUE rblapack_rank;
  integer rank; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  real *work;

  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  piv, rank, info, a = NumRu::Lapack.cpstrf( uplo, a, tol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPSTRF computes the Cholesky factorization with complete\n*  pivoting of a complex Hermitian positive semidefinite matrix A.\n*\n*  The factorization has the form\n*     P' * A * P = U' * U ,  if UPLO = 'U',\n*     P' * A * P = L  * L',  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is lower triangular, and\n*  P is stored as vector PIV.\n*\n*  This algorithm does not attempt to check that A is positive\n*  semidefinite. This version of the algorithm calls level 3 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          n by n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n by n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the factor U or L from the Cholesky\n*          factorization as above.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  PIV     (output) INTEGER array, dimension (N)\n*          PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n*\n*  RANK    (output) INTEGER\n*          The rank of A given by the number of steps the algorithm\n*          completed.\n*\n*  TOL     (input) REAL\n*          User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) )\n*          will be used. The algorithm terminates at the (K-1)st step\n*          if the pivot <= TOL.\n*\n*  WORK    (workspace) REAL array, dimension (2*N)\n*          Work space.\n*\n*  INFO    (output) INTEGER\n*          < 0: If INFO = -K, the K-th argument had an illegal value,\n*          = 0: algorithm completed successfully, and\n*          > 0: the matrix A is either rank deficient with computed rank\n*               as returned in RANK, or is indefinite.  See Section 7 of\n*               LAPACK Working Note #161 for further information.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  piv, rank, info, a = NumRu::Lapack.cpstrf( uplo, a, tol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_tol = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  tol = (real)NUM2DBL(rblapack_tol);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_piv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  piv = NA_PTR_TYPE(rblapack_piv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(real, (2*n));

  cpstrf_(&uplo, &n, a, &lda, piv, &rank, &tol, work, &info);

  free(work);
  rblapack_rank = INT2NUM(rank);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_piv, rblapack_rank, rblapack_info, rblapack_a);
}

void
init_lapack_cpstrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cpstrf", rblapack_cpstrf, -1);
}
ruby-lapack-1.7.2/ext/zptrfs.c0000644000175000017500000002163512502221024016060 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zptrfs_(char* uplo, integer* n, integer* nrhs, doublereal* d, doublecomplex* e, doublereal* df, doublecomplex* ef, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zptrfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublecomplex *e; 
  VALUE rblapack_df;
  doublereal *df; 
  VALUE rblapack_ef;
  doublecomplex *ef; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.zptrfs( uplo, d, e, df, ef, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPTRFS( UPLO, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPTRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is Hermitian positive definite\n*  and tridiagonal, and provides error bounds and backward error\n*  estimates for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the superdiagonal or the subdiagonal of the\n*          tridiagonal matrix A is stored and the form of the\n*          factorization:\n*          = 'U':  E is the superdiagonal of A, and A = U**H*D*U;\n*          = 'L':  E is the subdiagonal of A, and A = L*D*L**H.\n*          (The two forms are equivalent if A is real.)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          The n real diagonal elements of the tridiagonal matrix A.\n*\n*  E       (input) COMPLEX*16 array, dimension (N-1)\n*          The (n-1) off-diagonal elements of the tridiagonal matrix A\n*          (see UPLO).\n*\n*  DF      (input) DOUBLE PRECISION array, dimension (N)\n*          The n diagonal elements of the diagonal matrix D from\n*          the factorization computed by ZPTTRF.\n*\n*  EF      (input) COMPLEX*16 array, dimension (N-1)\n*          The (n-1) off-diagonal elements of the unit bidiagonal\n*          factor U or L from the factorization computed by ZPTTRF\n*          (see UPLO).\n*\n*  B       (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) COMPLEX*16 array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by ZPTTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.zptrfs( uplo, d, e, df, ef, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_uplo = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  rblapack_df = argv[3];
  rblapack_ef = argv[4];
  rblapack_b = argv[5];
  rblapack_x = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_df))
    rb_raise(rb_eArgError, "df (4th argument) must be NArray");
  if (NA_RANK(rblapack_df) != 1)
    rb_raise(rb_eArgError, "rank of df (4th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_df);
  if (NA_TYPE(rblapack_df) != NA_DFLOAT)
    rblapack_df = na_change_type(rblapack_df, NA_DFLOAT);
  df = NA_PTR_TYPE(rblapack_df, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of df");
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_ef))
    rb_raise(rb_eArgError, "ef (5th argument) must be NArray");
  if (NA_RANK(rblapack_ef) != 1)
    rb_raise(rb_eArgError, "rank of ef (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ef) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of ef must be %d", n-1);
  if (NA_TYPE(rblapack_ef) != NA_DCOMPLEX)
    rblapack_ef = na_change_type(rblapack_ef, NA_DCOMPLEX);
  ef = NA_PTR_TYPE(rblapack_ef, doublecomplex*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DCOMPLEX)
    rblapack_e = na_change_type(rblapack_e, NA_DCOMPLEX);
  e = NA_PTR_TYPE(rblapack_e, doublecomplex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (7th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(doublecomplex, (n));
  rwork = ALLOC_N(doublereal, (n));

  zptrfs_(&uplo, &n, &nrhs, d, e, df, ef, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_zptrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zptrfs", rblapack_zptrfs, -1);
}
ruby-lapack-1.7.2/ext/ctgexc.c0000644000175000017500000002435012502221013016000 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctgexc_(logical* wantq, logical* wantz, integer* n, complex* a, integer* lda, complex* b, integer* ldb, complex* q, integer* ldq, complex* z, integer* ldz, integer* ifst, integer* ilst, integer* info);


static VALUE
rblapack_ctgexc(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantq;
  logical wantq; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_q;
  complex *q; 
  VALUE rblapack_ldq;
  integer ldq; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_ifst;
  integer ifst; 
  VALUE rblapack_ilst;
  integer ilst; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;
  VALUE rblapack_q_out__;
  complex *q_out__;
  VALUE rblapack_z_out__;
  complex *z_out__;

  integer lda;
  integer n;
  integer ldb;
  integer ldz;

  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  info, a, b, q, z, ilst = NumRu::Lapack.ctgexc( wantq, wantz, a, b, q, ldq, z, ifst, ilst, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, IFST, ILST, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTGEXC reorders the generalized Schur decomposition of a complex\n*  matrix pair (A,B), using an unitary equivalence transformation\n*  (A, B) := Q * (A, B) * Z', so that the diagonal block of (A, B) with\n*  row index IFST is moved to row ILST.\n*\n*  (A, B) must be in generalized Schur canonical form, that is, A and\n*  B are both upper triangular.\n*\n*  Optionally, the matrices Q and Z of generalized Schur vectors are\n*  updated.\n*\n*         Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n*         Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n*\n\n*  Arguments\n*  =========\n*\n*  WANTQ   (input) LOGICAL\n*          .TRUE. : update the left transformation matrix Q;\n*          .FALSE.: do not update Q.\n*\n*  WANTZ   (input) LOGICAL\n*          .TRUE. : update the right transformation matrix Z;\n*          .FALSE.: do not update Z.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B. N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the upper triangular matrix A in the pair (A, B).\n*          On exit, the updated matrix A.\n*\n*  LDA     (input)  INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,N)\n*          On entry, the upper triangular matrix B in the pair (A, B).\n*          On exit, the updated matrix B.\n*\n*  LDB     (input)  INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  Q       (input/output) COMPLEX array, dimension (LDZ,N)\n*          On entry, if WANTQ = .TRUE., the unitary matrix Q.\n*          On exit, the updated matrix Q.\n*          If WANTQ = .FALSE., Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q. LDQ >= 1;\n*          If WANTQ = .TRUE., LDQ >= N.\n*\n*  Z       (input/output) COMPLEX array, dimension (LDZ,N)\n*          On entry, if WANTZ = .TRUE., the unitary matrix Z.\n*          On exit, the updated matrix Z.\n*          If WANTZ = .FALSE., Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z. LDZ >= 1;\n*          If WANTZ = .TRUE., LDZ >= N.\n*\n*  IFST    (input) INTEGER\n*  ILST    (input/output) INTEGER\n*          Specify the reordering of the diagonal blocks of (A, B).\n*          The block with row index IFST is moved to row ILST, by a\n*          sequence of swapping between adjacent blocks.\n*\n*  INFO    (output) INTEGER\n*           =0:  Successful exit.\n*           <0:  if INFO = -i, the i-th argument had an illegal value.\n*           =1:  The transformed matrix pair (A, B) would be too far\n*                from generalized Schur form; the problem is ill-\n*                conditioned. (A, B) may have been partially reordered,\n*                and ILST points to the first row of the current\n*                position of the block being moved.\n*\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n*      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n*      M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n*      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n*  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n*      Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n*      Estimation: Theory, Algorithms and Software, Report\n*      UMINF - 94.04, Department of Computing Science, Umea University,\n*      S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.\n*      To appear in Numerical Algorithms, 1996.\n*\n*  [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n*      for Solving the Generalized Sylvester Equation and Estimating the\n*      Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n*      Department of Computing Science, Umea University, S-901 87 Umea,\n*      Sweden, December 1993, Revised April 1994, Also as LAPACK working\n*      Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,\n*      1996.\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            HERE\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CTGEX2, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a, b, q, z, ilst = NumRu::Lapack.ctgexc( wantq, wantz, a, b, q, ldq, z, ifst, ilst, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_wantq = argv[0];
  rblapack_wantz = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  rblapack_q = argv[4];
  rblapack_ldq = argv[5];
  rblapack_z = argv[6];
  rblapack_ifst = argv[7];
  rblapack_ilst = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  wantq = (rblapack_wantq == Qtrue);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (5th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_q) != NA_SCOMPLEX)
    rblapack_q = na_change_type(rblapack_q, NA_SCOMPLEX);
  q = NA_PTR_TYPE(rblapack_q, complex*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (7th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_z) != ldz)
    rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of q");
  if (NA_SHAPE1(rblapack_z) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, complex*);
  ilst = NUM2INT(rblapack_ilst);
  wantz = (rblapack_wantz == Qtrue);
  ldq = NUM2INT(rblapack_ldq);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  ifst = NUM2INT(rblapack_ifst);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, complex*);
  MEMCPY(q_out__, q, complex, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
  MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  ctgexc_(&wantq, &wantz, &n, a, &lda, b, &ldb, q, &ldq, z, &ldz, &ifst, &ilst, &info);

  rblapack_info = INT2NUM(info);
  rblapack_ilst = INT2NUM(ilst);
  return rb_ary_new3(6, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z, rblapack_ilst);
}

void
init_lapack_ctgexc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctgexc", rblapack_ctgexc, -1);
}
ruby-lapack-1.7.2/ext/cppsv.c0000644000175000017500000001432412502221020015654 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cppsv_(char* uplo, integer* n, integer* nrhs, complex* ap, complex* b, integer* ldb, integer* info);


static VALUE
rblapack_cppsv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  complex *ap_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer ldb;
  integer nrhs;

  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  info, ap, b = NumRu::Lapack.cppsv( uplo, n, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPPSV( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPPSV computes the solution to a complex system of linear equations\n*     A * X = B,\n*  where A is an N-by-N Hermitian positive definite matrix stored in\n*  packed format and X and B are N-by-NRHS matrices.\n*\n*  The Cholesky decomposition is used to factor A as\n*     A = U**H* U,  if UPLO = 'U', or\n*     A = L * L**H,  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is a lower triangular\n*  matrix.  The factored form of A is then used to solve the system of\n*  equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          See below for further details.  \n*\n*          On exit, if INFO = 0, the factor U or L from the Cholesky\n*          factorization A = U**H*U or A = L*L**H, in the same storage\n*          format as A.\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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 leading minor of order i of A is not\n*                positive definite, so the factorization could not be\n*                completed, and the solution has not been computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  The packed storage scheme is illustrated by the following example\n*  when N = 4, UPLO = 'U':\n*\n*  Two-dimensional storage of the Hermitian matrix A:\n*\n*     a11 a12 a13 a14\n*         a22 a23 a24\n*             a33 a34     (aij = conjg(aji))\n*                 a44\n*\n*  Packed storage of the upper triangle of A:\n*\n*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n*  =====================================================================\n*\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CPPTRF, CPPTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ap, b = NumRu::Lapack.cppsv( uplo, n, ap, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_n = argv[1];
  rblapack_ap = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
  MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  cppsv_(&uplo, &n, &nrhs, ap, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_ap, rblapack_b);
}

void
init_lapack_cppsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cppsv", rblapack_cppsv, -1);
}
ruby-lapack-1.7.2/ext/ilaclc.c0000644000175000017500000000457112502221022015755 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern integer ilaclc_(integer* m, integer* n, complex* a, integer* lda);


static VALUE
rblapack_ilaclc(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack___out__;
  integer __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  __out__ = NumRu::Lapack.ilaclc( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      INTEGER FUNCTION ILACLC( M, N, A, LDA )\n\n*  Purpose\n*  =======\n*\n*  ILACLC scans A for its last non-zero column.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          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\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.ilaclc( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);

  __out__ = ilaclc_(&m, &n, a, &lda);

  rblapack___out__ = INT2NUM(__out__);
  return rblapack___out__;
}

void
init_lapack_ilaclc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ilaclc", rblapack_ilaclc, -1);
}
ruby-lapack-1.7.2/ext/zlapmt.c0000644000175000017500000001071312502221020016026 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlapmt_(logical* forwrd, integer* m, integer* n, doublecomplex* x, integer* ldx, integer* k);


static VALUE
rblapack_zlapmt(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_forwrd;
  logical forwrd; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_k;
  integer *k; 
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;
  VALUE rblapack_k_out__;
  integer *k_out__;

  integer ldx;
  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  x, k = NumRu::Lapack.zlapmt( forwrd, m, x, k, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAPMT( FORWRD, M, N, X, LDX, K )\n\n*  Purpose\n*  =======\n*\n*  ZLAPMT rearranges the columns of the M by N matrix X as specified\n*  by the permutation K(1),K(2),...,K(N) of the integers 1,...,N.\n*  If FORWRD = .TRUE.,  forward permutation:\n*\n*       X(*,K(J)) is moved X(*,J) for J = 1,2,...,N.\n*\n*  If FORWRD = .FALSE., backward permutation:\n*\n*       X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N.\n*\n\n*  Arguments\n*  =========\n*\n*  FORWRD  (input) LOGICAL\n*          = .TRUE., forward permutation\n*          = .FALSE., backward permutation\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix X. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix X. N >= 0.\n*\n*  X       (input/output) COMPLEX*16 array, dimension (LDX,N)\n*          On entry, the M by N matrix X.\n*          On exit, X contains the permuted matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X, LDX >= MAX(1,M).\n*\n*  K       (input/output) INTEGER array, dimension (N)\n*          On entry, K contains the permutation vector. K is used as\n*          internal workspace, but reset to its original value on\n*          output.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, II, IN, J\n      COMPLEX*16         TEMP\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, k = NumRu::Lapack.zlapmt( forwrd, m, x, k, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_forwrd = argv[0];
  rblapack_m = argv[1];
  rblapack_x = argv[2];
  rblapack_k = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  forwrd = (rblapack_forwrd == Qtrue);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (3th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  n = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_k))
    rb_raise(rb_eArgError, "k (4th argument) must be NArray");
  if (NA_RANK(rblapack_k) != 1)
    rb_raise(rb_eArgError, "rank of k (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_k) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of k must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_k) != NA_LINT)
    rblapack_k = na_change_type(rblapack_k, NA_LINT);
  k = NA_PTR_TYPE(rblapack_k, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = n;
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_k_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  k_out__ = NA_PTR_TYPE(rblapack_k_out__, integer*);
  MEMCPY(k_out__, k, integer, NA_TOTAL(rblapack_k));
  rblapack_k = rblapack_k_out__;
  k = k_out__;

  zlapmt_(&forwrd, &m, &n, x, &ldx, k);

  return rb_ary_new3(2, rblapack_x, rblapack_k);
}

void
init_lapack_zlapmt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlapmt", rblapack_zlapmt, -1);
}
ruby-lapack-1.7.2/ext/sopmtr.c0000644000175000017500000001434412502221017016055 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sopmtr_(char* side, char* uplo, char* trans, integer* m, integer* n, real* ap, real* tau, real* c, integer* ldc, real* work, integer* info);


static VALUE
rblapack_sopmtr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  real *c_out__;
  real *work;

  integer ldc;
  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  info, c = NumRu::Lapack.sopmtr( side, uplo, trans, m, ap, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SOPMTR overwrites the general real M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'T':      Q**T * C       C * Q**T\n*\n*  where Q is a real orthogonal matrix of order nq, with nq = m if\n*  SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of\n*  nq-1 elementary reflectors, as returned by SSPTRD using packed\n*  storage:\n*\n*  if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);\n*\n*  if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**T from the Left;\n*          = 'R': apply Q or Q**T from the Right.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U': Upper triangular packed storage used in previous\n*                 call to SSPTRD;\n*          = 'L': Lower triangular packed storage used in previous\n*                 call to SSPTRD.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'T':  Transpose, apply Q**T.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  AP      (input) REAL array, dimension\n*                               (M*(M+1)/2) if SIDE = 'L'\n*                               (N*(N+1)/2) if SIDE = 'R'\n*          The vectors which define the elementary reflectors, as\n*          returned by SSPTRD.  AP is modified by the routine but\n*          restored on exit.\n*\n*  TAU     (input) REAL array, dimension (M-1) if SIDE = 'L'\n*                                     or (N-1) if SIDE = 'R'\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by SSPTRD.\n*\n*  C       (input/output) REAL array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) REAL array, dimension\n*                                   (N) if SIDE = 'L'\n*                                   (M) if SIDE = 'R'\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, c = NumRu::Lapack.sopmtr( side, uplo, trans, m, ap, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_side = argv[0];
  rblapack_uplo = argv[1];
  rblapack_trans = argv[2];
  rblapack_m = argv[3];
  rblapack_ap = argv[4];
  rblapack_tau = argv[5];
  rblapack_c = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (6th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_tau) != (m-1))
    rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", m-1);
  if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (m*(m+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", m*(m+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  sopmtr_(&side, &uplo, &trans, &m, &n, ap, tau, c, &ldc, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_c);
}

void
init_lapack_sopmtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sopmtr", rblapack_sopmtr, -1);
}
ruby-lapack-1.7.2/ext/dtrrfs.c0000644000175000017500000001673712502221013016041 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtrrfs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dtrrfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  doublereal *work;
  integer *iwork;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info = NumRu::Lapack.dtrrfs( uplo, trans, diag, a, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTRRFS provides error bounds and backward error estimates for the\n*  solution to a system of linear equations with a triangular\n*  coefficient matrix.\n*\n*  The solution matrix X must be computed by DTRTRS or some other\n*  means before entering this routine.  DTRRFS does not do iterative\n*  refinement because doing so cannot improve the backward error.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B  (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*          The triangular matrix A.  If UPLO = 'U', the leading N-by-N\n*          upper triangular part of the array A contains the upper\n*          triangular matrix, and the strictly lower triangular part of\n*          A is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*          triangular part of the array A contains the lower triangular\n*          matrix, and the strictly upper triangular part of A is not\n*          referenced.  If DIAG = 'U', the diagonal elements of A are\n*          also not referenced and are assumed to be 1.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*          The solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info = NumRu::Lapack.dtrrfs( uplo, trans, diag, a, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th 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*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  work = ALLOC_N(doublereal, (3*n));
  iwork = ALLOC_N(integer, (n));

  dtrrfs_(&uplo, &trans, &diag, &n, &nrhs, a, &lda, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ferr, rblapack_berr, rblapack_info);
}

void
init_lapack_dtrrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtrrfs", rblapack_dtrrfs, -1);
}
ruby-lapack-1.7.2/ext/cpstf2.c0000644000175000017500000001252612502221014015727 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cpstf2_(char* uplo, integer* n, complex* a, integer* lda, integer* piv, integer* rank, real* tol, real* work, integer* info);


static VALUE
rblapack_cpstf2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tol;
  real tol; 
  VALUE rblapack_piv;
  integer *piv; 
  VALUE rblapack_rank;
  integer rank; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  real *work;

  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  piv, rank, info, a = NumRu::Lapack.cpstf2( uplo, a, tol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPSTF2 computes the Cholesky factorization with complete\n*  pivoting of a complex Hermitian positive semidefinite matrix A.\n*\n*  The factorization has the form\n*     P' * A * P = U' * U ,  if UPLO = 'U',\n*     P' * A * P = L  * L',  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is lower triangular, and\n*  P is stored as vector PIV.\n*\n*  This algorithm does not attempt to check that A is positive\n*  semidefinite. This version of the algorithm calls level 2 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          n by n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n by n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the factor U or L from the Cholesky\n*          factorization as above.\n*\n*  PIV     (output) INTEGER array, dimension (N)\n*          PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n*\n*  RANK    (output) INTEGER\n*          The rank of A given by the number of steps the algorithm\n*          completed.\n*\n*  TOL     (input) REAL\n*          User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) )\n*          will be used. The algorithm terminates at the (K-1)st step\n*          if the pivot <= TOL.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  WORK    (workspace) REAL array, dimension (2*N)\n*          Work space.\n*\n*  INFO    (output) INTEGER\n*          < 0: If INFO = -K, the K-th argument had an illegal value,\n*          = 0: algorithm completed successfully, and\n*          > 0: the matrix A is either rank deficient with computed rank\n*               as returned in RANK, or is indefinite.  See Section 7 of\n*               LAPACK Working Note #161 for further information.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  piv, rank, info, a = NumRu::Lapack.cpstf2( uplo, a, tol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_tol = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  tol = (real)NUM2DBL(rblapack_tol);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_piv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  piv = NA_PTR_TYPE(rblapack_piv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(real, (2*n));

  cpstf2_(&uplo, &n, a, &lda, piv, &rank, &tol, work, &info);

  free(work);
  rblapack_rank = INT2NUM(rank);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_piv, rblapack_rank, rblapack_info, rblapack_a);
}

void
init_lapack_cpstf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cpstf2", rblapack_cpstf2, -1);
}
ruby-lapack-1.7.2/ext/zupgtr.c0000644000175000017500000001040512502221023016053 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zupgtr_(char* uplo, integer* n, doublecomplex* ap, doublecomplex* tau, doublecomplex* q, integer* ldq, doublecomplex* work, integer* info);


static VALUE
rblapack_zupgtr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_q;
  doublecomplex *q; 
  VALUE rblapack_info;
  integer info; 
  doublecomplex *work;

  integer ldap;
  integer ldtau;
  integer ldq;
  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  q, info = NumRu::Lapack.zupgtr( uplo, ap, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZUPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZUPGTR generates a complex unitary matrix Q which is defined as the\n*  product of n-1 elementary reflectors H(i) of order n, as returned by\n*  ZHPTRD using packed storage:\n*\n*  if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),\n*\n*  if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U': Upper triangular packed storage used in previous\n*                 call to ZHPTRD;\n*          = 'L': Lower triangular packed storage used in previous\n*                 call to ZHPTRD.\n*\n*  N       (input) INTEGER\n*          The order of the matrix Q. N >= 0.\n*\n*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          The vectors which define the elementary reflectors, as\n*          returned by ZHPTRD.\n*\n*  TAU     (input) COMPLEX*16 array, dimension (N-1)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by ZHPTRD.\n*\n*  Q       (output) COMPLEX*16 array, dimension (LDQ,N)\n*          The N-by-N unitary matrix Q.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q. LDQ >= max(1,N).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (N-1)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  q, info = NumRu::Lapack.zupgtr( uplo, ap, tau, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_tau = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  ldtau = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  n = ldtau+1;
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  ldq = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
  work = ALLOC_N(doublecomplex, (n-1));

  zupgtr_(&uplo, &n, ap, tau, q, &ldq, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_q, rblapack_info);
}

void
init_lapack_zupgtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zupgtr", rblapack_zupgtr, -1);
}
ruby-lapack-1.7.2/ext/clartv.c0000644000175000017500000001330212502221013016011 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clartv_(integer* n, complex* x, integer* incx, complex* y, integer* incy, real* c, complex* s, integer* incc);


static VALUE
rblapack_clartv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_y;
  complex *y; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_s;
  complex *s; 
  VALUE rblapack_incc;
  integer incc; 
  VALUE rblapack_x_out__;
  complex *x_out__;
  VALUE rblapack_y_out__;
  complex *y_out__;


  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  x, y = NumRu::Lapack.clartv( n, x, incx, y, incy, c, s, incc, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLARTV( N, X, INCX, Y, INCY, C, S, INCC )\n\n*  Purpose\n*  =======\n*\n*  CLARTV applies a vector of complex plane rotations with real cosines\n*  to elements of the complex vectors x and y. For i = 1,2,...,n\n*\n*     ( x(i) ) := (        c(i)   s(i) ) ( x(i) )\n*     ( y(i) )    ( -conjg(s(i))  c(i) ) ( y(i) )\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of plane rotations to be applied.\n*\n*  X       (input/output) COMPLEX array, dimension (1+(N-1)*INCX)\n*          The vector x.\n*\n*  INCX    (input) INTEGER\n*          The increment between elements of X. INCX > 0.\n*\n*  Y       (input/output) COMPLEX array, dimension (1+(N-1)*INCY)\n*          The vector y.\n*\n*  INCY    (input) INTEGER\n*          The increment between elements of Y. INCY > 0.\n*\n*  C       (input) REAL array, dimension (1+(N-1)*INCC)\n*          The cosines of the plane rotations.\n*\n*  S       (input) COMPLEX array, dimension (1+(N-1)*INCC)\n*          The sines of the plane rotations.\n*\n*  INCC    (input) INTEGER\n*          The increment between elements of C and S. INCC > 0.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, IC, IX, IY\n      COMPLEX            XI, YI\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          CONJG\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, y = NumRu::Lapack.clartv( n, x, incx, y, incy, c, s, incc, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_n = argv[0];
  rblapack_x = argv[1];
  rblapack_incx = argv[2];
  rblapack_y = argv[3];
  rblapack_incy = argv[4];
  rblapack_c = argv[5];
  rblapack_s = argv[6];
  rblapack_incc = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  incx = NUM2INT(rblapack_incx);
  incy = NUM2INT(rblapack_incy);
  incc = NUM2INT(rblapack_incc);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1+(n-1)*incx))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != (1+(n-1)*incc))
    rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", 1+(n-1)*incc);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (4th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incy))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
  if (NA_TYPE(rblapack_y) != NA_SCOMPLEX)
    rblapack_y = na_change_type(rblapack_y, NA_SCOMPLEX);
  y = NA_PTR_TYPE(rblapack_y, complex*);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (7th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != (1+(n-1)*incc))
    rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", 1+(n-1)*incc);
  if (NA_TYPE(rblapack_s) != NA_SCOMPLEX)
    rblapack_s = na_change_type(rblapack_s, NA_SCOMPLEX);
  s = NA_PTR_TYPE(rblapack_s, complex*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incx;
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incy;
    rblapack_y_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, complex*);
  MEMCPY(y_out__, y, complex, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  clartv_(&n, x, &incx, y, &incy, c, s, &incc);

  return rb_ary_new3(2, rblapack_x, rblapack_y);
}

void
init_lapack_clartv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clartv", rblapack_clartv, -1);
}
ruby-lapack-1.7.2/ext/csytri2.c0000644000175000017500000001403512502221013016121 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID csytri2_(char* uplo, integer* n, complex* a, integer* lda, integer* ipiv, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_csytri2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  integer c__1;
  integer c__m1;
  integer nb;
  complex *work;

  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  info, a = NumRu::Lapack.csytri2( uplo, a, ipiv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CSYTRI2 computes the inverse of a complex symmetric indefinite matrix\n*  A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n*  CSYTRF. CSYTRI2 sets the LEADING DIMENSION of the workspace\n*  before calling CSYTRI2X that actually computes the inverse.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the NB diagonal matrix D and the multipliers\n*          used to obtain the factor U or L as computed by CSYTRF.\n*\n*          On exit, if INFO = 0, the (symmetric) inverse of the original\n*          matrix.  If UPLO = 'U', the upper triangular part of the\n*          inverse is formed and the part of A below the diagonal is not\n*          referenced; if UPLO = 'L' the lower triangular part of the\n*          inverse is formed and the part of A above the diagonal is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the NB structure of D\n*          as determined by CSYTRF.\n*\n*  WORK    (workspace) COMPLEX array, dimension (N+NB+1)*(NB+3)\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK.\n*          WORK is size >= (N+NB+1)*(NB+3)\n*          If LDWORK = -1, then a workspace query is assumed; the routine\n*           calculates:\n*              - the optimal size of the WORK array, returns\n*          this value as the first entry of the WORK array,\n*              - and no error message related to LDWORK 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, D(i,i) = 0; the matrix is singular and its\n*               inverse could not be computed.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            UPPER, LQUERY\n      INTEGER            MINSIZE, NBMAX\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            ILAENV\n      EXTERNAL           LSAME, ILAENV\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CSYTRI2X\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.csytri2( uplo, a, ipiv, [: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_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = 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;
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  c__1 = 1;
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  c__m1 = -1;
  nb = ilaenv_(&c__1, "CSYTRF", &uplo, &n, &c__m1, &c__m1, &c__m1);
  if (rblapack_lwork == Qnil)
    lwork = (n+nb+1)*(nb+3);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(complex, (lwork));

  csytri2_(&uplo, &n, a, &lda, ipiv, work, &lwork, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_csytri2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "csytri2", rblapack_csytri2, -1);
}
ruby-lapack-1.7.2/ext/ssbgv.c0000644000175000017500000002023012502221017015644 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssbgv_(char* jobz, char* uplo, integer* n, integer* ka, integer* kb, real* ab, integer* ldab, real* bb, integer* ldbb, real* w, real* z, integer* ldz, real* work, integer* info);


static VALUE
rblapack_ssbgv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ka;
  integer ka; 
  VALUE rblapack_kb;
  integer kb; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_bb;
  real *bb; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  real *ab_out__;
  VALUE rblapack_bb_out__;
  real *bb_out__;
  real *work;

  integer ldab;
  integer n;
  integer ldbb;
  integer ldz;

  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  w, z, info, ab, bb = NumRu::Lapack.ssbgv( jobz, uplo, ka, kb, ab, bb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSBGV computes all the eigenvalues, and optionally, the eigenvectors\n*  of a real generalized symmetric-definite banded eigenproblem, of\n*  the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric\n*  and banded, and B is also positive definite.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  KA      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n*  KB      (input) INTEGER\n*          The number of superdiagonals of the matrix B if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n*  AB      (input/output) REAL array, dimension (LDAB, N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first ka+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).\n*\n*          On exit, the contents of AB are destroyed.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KA+1.\n*\n*  BB      (input/output) REAL array, dimension (LDBB, N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix B, stored in the first kb+1 rows of the array.  The\n*          j-th column of B is stored in the j-th column of the array BB\n*          as follows:\n*          if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n*          if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb).\n*\n*          On exit, the factor S from the split Cholesky factorization\n*          B = S**T*S, as returned by SPBSTF.\n*\n*  LDBB    (input) INTEGER\n*          The leading dimension of the array BB.  LDBB >= KB+1.\n*\n*  W       (output) REAL array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) REAL array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n*          eigenvectors, with the i-th column of Z holding the\n*          eigenvector associated with W(i). The eigenvectors are\n*          normalized so that Z**T*B*Z = I.\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= N.\n*\n*  WORK    (workspace) REAL array, dimension (3*N)\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, and i is:\n*             <= N:  the algorithm failed to converge:\n*                    i off-diagonal elements of an intermediate\n*                    tridiagonal form did not converge to zero;\n*             > N:   if INFO = N + i, for 1 <= i <= N, then SPBSTF\n*                    returned INFO = i: B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            UPPER, WANTZ\n      CHARACTER          VECT\n      INTEGER            IINFO, INDE, INDWRK\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SPBSTF, SSBGST, SSBTRD, SSTEQR, SSTERF, XERBLA\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, info, ab, bb = NumRu::Lapack.ssbgv( jobz, uplo, ka, kb, ab, bb, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_ka = argv[2];
  rblapack_kb = argv[3];
  rblapack_ab = argv[4];
  rblapack_bb = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  ka = NUM2INT(rblapack_ka);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_bb))
    rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
  if (NA_RANK(rblapack_bb) != 2)
    rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
  ldbb = NA_SHAPE0(rblapack_bb);
  if (NA_SHAPE1(rblapack_bb) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of bb must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_bb) != NA_SFLOAT)
    rblapack_bb = na_change_type(rblapack_bb, NA_SFLOAT);
  bb = NA_PTR_TYPE(rblapack_bb, real*);
  kb = NUM2INT(rblapack_kb);
  ldz = lsame_(&jobz,"V") ? n : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
  MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldbb;
    shape[1] = n;
    rblapack_bb_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  bb_out__ = NA_PTR_TYPE(rblapack_bb_out__, real*);
  MEMCPY(bb_out__, bb, real, NA_TOTAL(rblapack_bb));
  rblapack_bb = rblapack_bb_out__;
  bb = bb_out__;
  work = ALLOC_N(real, (3*n));

  ssbgv_(&jobz, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, w, z, &ldz, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_w, rblapack_z, rblapack_info, rblapack_ab, rblapack_bb);
}

void
init_lapack_ssbgv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssbgv", rblapack_ssbgv, -1);
}
ruby-lapack-1.7.2/ext/chetri.c0000644000175000017500000001125112502221017016001 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chetri_(char* uplo, integer* n, complex* a, integer* lda, integer* ipiv, complex* work, integer* info);


static VALUE
rblapack_chetri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  complex *work;

  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  info, a = NumRu::Lapack.chetri( uplo, a, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHETRI( UPLO, N, A, LDA, IPIV, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHETRI computes the inverse of a complex Hermitian indefinite matrix\n*  A using the factorization A = U*D*U**H or A = L*D*L**H computed by\n*  CHETRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**H;\n*          = 'L':  Lower triangular, form is A = L*D*L**H.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the block diagonal matrix D and the multipliers\n*          used to obtain the factor U or L as computed by CHETRF.\n*\n*          On exit, if INFO = 0, the (Hermitian) inverse of the original\n*          matrix.  If UPLO = 'U', the upper triangular part of the\n*          inverse is formed and the part of A below the diagonal is not\n*          referenced; if UPLO = 'L' the lower triangular part of the\n*          inverse is formed and the part of A above the diagonal is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by CHETRF.\n*\n*  WORK    (workspace) COMPLEX array, dimension (N)\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, D(i,i) = 0; the matrix is singular and its\n*               inverse could not be computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.chetri( uplo, a, ipiv, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(complex, (n));

  chetri_(&uplo, &n, a, &lda, ipiv, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_chetri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chetri", rblapack_chetri, -1);
}
ruby-lapack-1.7.2/ext/zlange.c0000644000175000017500000000760112502221022016003 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal zlange_(char* norm, integer* m, integer* n, doublecomplex* a, integer* lda, doublereal* work);


static VALUE
rblapack_zlange(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack___out__;
  doublereal __out__; 
  doublereal *work;

  integer lda;
  integer n;
  integer lwork;

  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  __out__ = NumRu::Lapack.zlange( norm, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK )\n\n*  Purpose\n*  =======\n*\n*  ZLANGE  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  complex matrix A.\n*\n*  Description\n*  ===========\n*\n*  ZLANGE returns the value\n*\n*     ZLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in ZLANGE as described\n*          above.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.  M >= 0.  When M = 0,\n*          ZLANGE is set to zero.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.  N >= 0.  When N = 0,\n*          ZLANGE is set to zero.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          The m by n matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(M,1).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n*          where LWORK >= M when NORM = 'I'; otherwise, WORK is not\n*          referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.zlange( norm, m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_norm = argv[0];
  rblapack_m = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  m = NUM2INT(rblapack_m);
  lwork = lsame_(&norm,"I") ? m : 0;
  work = ALLOC_N(doublereal, (MAX(1,lwork)));

  __out__ = zlange_(&norm, &m, &n, a, &lda, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_zlange(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlange", rblapack_zlange, -1);
}
ruby-lapack-1.7.2/ext/zgelss.c0000644000175000017500000002050612502221021016030 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgelss_(integer* m, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublereal* s, doublereal* rcond, integer* rank, doublecomplex* work, integer* lwork, doublereal* rwork, integer* info);


static VALUE
rblapack_zgelss(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_rank;
  integer rank; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  doublereal *rwork;

  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  s, rank, work, info, a, b = NumRu::Lapack.zgelss( a, b, rcond, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGELSS computes the minimum norm solution to a complex linear\n*  least squares problem:\n*\n*  Minimize 2-norm(| b - A*x |).\n*\n*  using the singular value decomposition (SVD) of A. A is an M-by-N\n*  matrix which may be rank-deficient.\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 matrix\n*  X.\n*\n*  The effective rank of A is determined by treating as zero those\n*  singular values which are less than RCOND times the largest singular\n*  value.\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*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X. NRHS >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, the first min(m,n) rows of A are overwritten with\n*          its right singular vectors, stored rowwise.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the M-by-NRHS right hand side matrix B.\n*          On exit, B is overwritten by the N-by-NRHS solution matrix X.\n*          If m >= n and RANK = n, the residual sum-of-squares for\n*          the solution in the i-th column is given by the sum of\n*          squares of the modulus of elements n+1:m in that column.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,M,N).\n*\n*  S       (output) DOUBLE PRECISION array, dimension (min(M,N))\n*          The singular values of A in decreasing order.\n*          The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n*\n*  RCOND   (input) DOUBLE PRECISION\n*          RCOND is used to determine the effective rank of A.\n*          Singular values S(i) <= RCOND*S(1) are treated as zero.\n*          If RCOND < 0, machine precision is used instead.\n*\n*  RANK    (output) INTEGER\n*          The effective rank of A, i.e., the number of singular values\n*          which are greater than RCOND*S(1).\n*\n*  WORK    (workspace/output) COMPLEX*16 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 >= 1, and also:\n*          LWORK >=  2*min(M,N) + max(M,N,NRHS)\n*          For good performance, LWORK should generally be larger.\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*  RWORK   (workspace) DOUBLE PRECISION array, dimension (5*min(M,N))\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          > 0:  the algorithm for computing the SVD failed to converge;\n*                if INFO = i, i off-diagonal elements of an intermediate\n*                bidiagonal form did not converge to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, rank, work, info, a, b = NumRu::Lapack.zgelss( a, b, rcond, [: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_a = argv[0];
  rblapack_b = argv[1];
  rblapack_rcond = 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 (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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  rcond = NUM2DBL(rblapack_rcond);
  m = lda;
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th 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_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  ldb = MAX(m, n);
  if (rblapack_lwork == Qnil)
    lwork = 3*MIN(m,n) + MAX(MAX(2*MIN(m,n),MAX(m,n)),nrhs);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = MAX(m, n);
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  {
    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__;
  rwork = ALLOC_N(doublereal, (5*MIN(m,n)));

  zgelss_(&m, &n, &nrhs, a, &lda, b, &ldb, s, &rcond, &rank, work, &lwork, rwork, &info);

  free(rwork);
  rblapack_rank = INT2NUM(rank);
  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(6, rblapack_s, rblapack_rank, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_zgelss(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgelss", rblapack_zgelss, -1);
}
ruby-lapack-1.7.2/ext/dla_rpvgrw.c0000644000175000017500000000764212502221024016701 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal dla_rpvgrw_(integer* n, integer* ncols, doublereal* a, integer* lda, doublereal* af, integer* ldaf);


static VALUE
rblapack_dla_rpvgrw(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ncols;
  integer ncols; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_af;
  doublereal *af; 
  VALUE rblapack___out__;
  doublereal __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  __out__ = NumRu::Lapack.dla_rpvgrw( ncols, a, af, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION DLA_RPVGRW( N, NCOLS, A, LDA, AF, LDAF )\n\n*  Purpose\n*  =======\n* \n*  DLA_RPVGRW computes the reciprocal pivot growth factor\n*  norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n*  much less than 1, the stability of the LU factorization of the\n*  (equilibrated) matrix A could be poor. This also means that the\n*  solution X, estimated condition numbers, and error bounds could be\n*  unreliable.\n*\n\n*  Arguments\n*  =========\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NCOLS   (input) INTEGER\n*     The number of columns of the matrix A. NCOLS >= 0.\n*\n*     A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) DOUBLE PRECISION array, dimension (LDAF,N)\n*     The factors L and U from the factorization\n*     A = P*L*U as computed by DGETRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n      DOUBLE PRECISION   AMAX, UMAX, RPVGRW\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.dla_rpvgrw( ncols, a, af, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_ncols = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  ncols = NUM2INT(rblapack_ncols);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_DFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
  af = NA_PTR_TYPE(rblapack_af, doublereal*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);

  __out__ = dla_rpvgrw_(&n, &ncols, a, &lda, af, &ldaf);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_dla_rpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dla_rpvgrw", rblapack_dla_rpvgrw, -1);
}
ruby-lapack-1.7.2/ext/sgelsx.c0000644000175000017500000002013512502221024016027 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgelsx_(integer* m, integer* n, integer* nrhs, real* a, integer* lda, real* b, integer* ldb, integer* jpvt, real* rcond, integer* rank, real* work, integer* info);


static VALUE
rblapack_sgelsx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_jpvt;
  integer *jpvt; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_rank;
  integer rank; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_b_out__;
  real *b_out__;
  VALUE rblapack_jpvt_out__;
  integer *jpvt_out__;
  real *work;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  rank, info, a, b, jpvt = NumRu::Lapack.sgelsx( m, a, b, jpvt, rcond, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  This routine is deprecated and has been replaced by routine SGELSY.\n*\n*  SGELSX computes the minimum-norm solution to a real linear least\n*  squares problem:\n*      minimize || A * X - B ||\n*  using a complete orthogonal factorization of A.  A is an M-by-N\n*  matrix which may be rank-deficient.\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*  The routine first computes a QR factorization with column pivoting:\n*      A * P = Q * [ R11 R12 ]\n*                  [  0  R22 ]\n*  with R11 defined as the largest leading submatrix whose estimated\n*  condition number is less than 1/RCOND.  The order of R11, RANK,\n*  is the effective rank of A.\n*\n*  Then, R22 is considered to be negligible, and R12 is annihilated\n*  by orthogonal transformations from the right, arriving at the\n*  complete orthogonal factorization:\n*     A * P = Q * [ T11 0 ] * Z\n*                 [  0  0 ]\n*  The minimum-norm solution is then\n*     X = P * Z' [ inv(T11)*Q1'*B ]\n*                [        0       ]\n*  where Q1 consists of the first RANK columns of 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*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of\n*          columns of matrices B and X. NRHS >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, A has been overwritten by details of its\n*          complete orthogonal factorization.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the M-by-NRHS right hand side matrix B.\n*          On exit, the N-by-NRHS solution matrix X.\n*          If m >= n and RANK = n, the residual sum-of-squares for\n*          the solution in the i-th column is given by the sum of\n*          squares of elements N+1:M in that column.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,M,N).\n*\n*  JPVT    (input/output) INTEGER array, dimension (N)\n*          On entry, if JPVT(i) .ne. 0, the i-th column of A is an\n*          initial column, otherwise it is a free column.  Before\n*          the QR factorization of A, all initial columns are\n*          permuted to the leading positions; only the remaining\n*          free columns are moved as a result of column pivoting\n*          during the factorization.\n*          On exit, if JPVT(i) = k, then the i-th column of A*P\n*          was the k-th column of A.\n*\n*  RCOND   (input) REAL\n*          RCOND is used to determine the effective rank of A, which\n*          is defined as the order of the largest leading triangular\n*          submatrix R11 in the QR factorization with pivoting of A,\n*          whose estimated condition number < 1/RCOND.\n*\n*  RANK    (output) INTEGER\n*          The effective rank of A, i.e., the order of the submatrix\n*          R11.  This is the same as the order of the submatrix T11\n*          in the complete orthogonal factorization of A.\n*\n*  WORK    (workspace) REAL array, dimension\n*                      (max( min(M,N)+3*N, 2*min(M,N)+NRHS )),\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rank, info, a, b, jpvt = NumRu::Lapack.sgelsx( m, a, b, jpvt, rcond, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  rblapack_b = argv[2];
  rblapack_jpvt = argv[3];
  rblapack_rcond = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  rcond = (real)NUM2DBL(rblapack_rcond);
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_jpvt))
    rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
  if (NA_RANK(rblapack_jpvt) != 1)
    rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_jpvt) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_jpvt) != NA_LINT)
    rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
  jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
  MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
  rblapack_jpvt = rblapack_jpvt_out__;
  jpvt = jpvt_out__;
  work = ALLOC_N(real, (MAX((MIN(m,n))+3*n,2*(MIN(m,n))*nrhs)));

  sgelsx_(&m, &n, &nrhs, a, &lda, b, &ldb, jpvt, &rcond, &rank, work, &info);

  free(work);
  rblapack_rank = INT2NUM(rank);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_rank, rblapack_info, rblapack_a, rblapack_b, rblapack_jpvt);
}

void
init_lapack_sgelsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgelsx", rblapack_sgelsx, -1);
}
ruby-lapack-1.7.2/ext/stpttr.c0000644000175000017500000000733412502221017016072 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID stpttr_(char* uplo, integer* n, real* ap, real* a, integer* lda, integer* info);


static VALUE
rblapack_stpttr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_info;
  integer info; 

  integer ldap;
  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  a, info = NumRu::Lapack.stpttr( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STPTTR( UPLO, N, AP, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  STPTTR copies a triangular matrix A from standard packed format (TP)\n*  to standard full format (TR).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular.\n*          = 'L':  A is lower triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0.\n*\n*  AP      (input) REAL array, dimension ( N*(N+1)/2 ),\n*          On entry, the upper or lower triangular matrix A, packed\n*          columnwise in a linear array. The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  A       (output) REAL array, dimension ( LDA, N )\n*          On exit, the triangular matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  a, info = NumRu::Lapack.stpttr( uplo, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  lda = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a = NA_PTR_TYPE(rblapack_a, real*);

  stpttr_(&uplo, &n, ap, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_a, rblapack_info);
}

void
init_lapack_stpttr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "stpttr", rblapack_stpttr, -1);
}
ruby-lapack-1.7.2/ext/sstevr.c0000644000175000017500000003423312502221025016055 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sstevr_(char* jobz, char* range, integer* n, real* d, real* e, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, real* z, integer* ldz, integer* isuppz, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_sstevr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_vl;
  real vl; 
  VALUE rblapack_vu;
  real vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  real abstol; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_isuppz;
  integer *isuppz; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_e_out__;
  real *e_out__;

  integer n;
  integer ldz;

  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  m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.sstevr( jobz, range, d, e, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSTEVR computes selected eigenvalues and, optionally, eigenvectors\n*  of a real symmetric tridiagonal matrix T.  Eigenvalues and\n*  eigenvectors can be selected by specifying either a range of values\n*  or a range of indices for the desired eigenvalues.\n*\n*  Whenever possible, SSTEVR calls SSTEMR to compute the\n*  eigenspectrum using Relatively Robust Representations.  SSTEMR\n*  computes eigenvalues by the dqds algorithm, while orthogonal\n*  eigenvectors are computed from various \"good\" L D L^T representations\n*  (also known as Relatively Robust Representations). Gram-Schmidt\n*  orthogonalization is avoided as far as possible. More specifically,\n*  the various steps of the algorithm are as follows. For the i-th\n*  unreduced block of T,\n*     (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T\n*          is a relatively robust representation,\n*     (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high\n*         relative accuracy by the dqds algorithm,\n*     (c) If there is a cluster of close eigenvalues, \"choose\" sigma_i\n*         close to the cluster, and go to step (a),\n*     (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T,\n*         compute the corresponding eigenvector by forming a\n*         rank-revealing twisted factorization.\n*  The desired accuracy of the output can be specified by the input\n*  parameter ABSTOL.\n*\n*  For more details, see \"A new O(n^2) algorithm for the symmetric\n*  tridiagonal eigenvalue/eigenvector problem\", by Inderjit Dhillon,\n*  Computer Science Division Technical Report No. UCB//CSD-97-971,\n*  UC Berkeley, May 1997.\n*\n*\n*  Note 1 : SSTEVR calls SSTEMR when the full spectrum is requested\n*  on machines which conform to the ieee-754 floating point standard.\n*  SSTEVR calls SSTEBZ and SSTEIN on non-ieee machines and\n*  when partial spectrum requests are made.\n*\n*  Normal execution of SSTEMR may create NaNs and infinities and\n*  hence may abort due to a floating point exception in environments\n*  which do not handle NaNs and infinities in the ieee standard default\n*  manner.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found.\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found.\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n********** For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and\n********** SSTEIN are called\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  D       (input/output) REAL array, dimension (N)\n*          On entry, the n diagonal elements of the tridiagonal matrix\n*          A.\n*          On exit, D may be multiplied by a constant factor chosen\n*          to avoid over/underflow in computing the eigenvalues.\n*\n*  E       (input/output) REAL array, dimension (max(1,N-1))\n*          On entry, the (n-1) subdiagonal elements of the tridiagonal\n*          matrix A in elements 1 to N-1 of E.\n*          On exit, E may be multiplied by a constant factor chosen\n*          to avoid over/underflow in computing the eigenvalues.\n*\n*  VL      (input) REAL\n*  VU      (input) REAL\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) REAL\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less than\n*          or equal to zero, then  EPS*|T|  will be used in its place,\n*          where |T| is the 1-norm of the tridiagonal matrix obtained\n*          by reducing A to tridiagonal form.\n*\n*          See \"Computing Small Singular Values of Bidiagonal Matrices\n*          with Guaranteed High Relative Accuracy,\" by Demmel and\n*          Kahan, LAPACK Working Note #3.\n*\n*          If high relative accuracy is important, set ABSTOL to\n*          SLAMCH( 'Safe minimum' ).  Doing so will guarantee that\n*          eigenvalues are computed to high relative accuracy when\n*          possible in future releases.  The current code does not\n*          make any guarantees about high relative accuracy, but\n*          future releases will. See J. Barlow and J. Demmel,\n*          \"Computing Accurate Eigensystems of Scaled Diagonally\n*          Dominant Matrices\", LAPACK Working Note #7, for a discussion\n*          of which matrices define their eigenvalues to high relative\n*          accuracy.\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) REAL array, dimension (N)\n*          The first M elements contain the selected eigenvalues in\n*          ascending order.\n*\n*  Z       (output) REAL array, dimension (LDZ, max(1,M) )\n*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix A\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  ISUPPZ  (output) INTEGER array, dimension ( 2*max(1,M) )\n*          The support of the eigenvectors in Z, i.e., the indices\n*          indicating the nonzero elements in Z. The i-th eigenvector\n*          is nonzero only in elements ISUPPZ( 2*i-1 ) through\n*          ISUPPZ( 2*i ).\n********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1\n*\n*  WORK    (workspace/output) REAL array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal (and\n*          minimal) LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK.  LWORK >= 20*N.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal sizes of the WORK and IWORK\n*          arrays, returns these values as the first entries of the WORK\n*          and IWORK arrays, and no error message related to LWORK or\n*          LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal (and\n*          minimal) LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.  LIWORK >= 10*N.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK and IWORK arrays, and no error message related to\n*          LWORK or LIWORK 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:  Internal error\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Inderjit Dhillon, IBM Almaden, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Ken Stanley, Computer Science Division, University of\n*       California at Berkeley, USA\n*     Jason Riedy, Computer Science Division, University of\n*       California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.sstevr( jobz, range, d, e, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 11)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_d = argv[2];
  rblapack_e = argv[3];
  rblapack_vl = argv[4];
  rblapack_vu = argv[5];
  rblapack_il = argv[6];
  rblapack_iu = argv[7];
  rblapack_abstol = argv[8];
  if (argc == 11) {
    rblapack_lwork = argv[9];
    rblapack_liwork = argv[10];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  vl = (real)NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  abstol = (real)NUM2DBL(rblapack_abstol);
  if (rblapack_liwork == Qnil)
    liwork = 10*n;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  range = StringValueCStr(rblapack_range)[0];
  vu = (real)NUM2DBL(rblapack_vu);
  if (rblapack_lwork == Qnil)
    lwork = 20*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (4th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (MAX(1,n-1)))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", MAX(1,n-1));
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  iu = NUM2INT(rblapack_iu);
  m = lsame_(&range,"I") ? iu-il+1 : n;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[1];
    shape[0] = 2*MAX(1,m);
    rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,n-1);
    rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
  MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;

  sstevr_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, isuppz, work, &lwork, iwork, &liwork, &info);

  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_m, rblapack_w, rblapack_z, rblapack_isuppz, rblapack_work, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e);
}

void
init_lapack_sstevr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sstevr", rblapack_sstevr, -1);
}
ruby-lapack-1.7.2/ext/slaed2.c0000644000175000017500000002550012502221014015674 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaed2_(integer* k, integer* n, integer* n1, real* d, real* q, integer* ldq, integer* indxq, real* rho, real* z, real* dlamda, real* w, real* q2, integer* indx, integer* indxc, integer* indxp, integer* coltyp, integer* info);


static VALUE
rblapack_slaed2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n1;
  integer n1; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_q;
  real *q; 
  VALUE rblapack_indxq;
  integer *indxq; 
  VALUE rblapack_rho;
  real rho; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_dlamda;
  real *dlamda; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_q2;
  real *q2; 
  VALUE rblapack_indxc;
  integer *indxc; 
  VALUE rblapack_coltyp;
  integer *coltyp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_q_out__;
  real *q_out__;
  VALUE rblapack_indxq_out__;
  integer *indxq_out__;
  integer *indx;
  integer *indxp;

  integer n;
  integer ldq;

  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  k, dlamda, w, q2, indxc, coltyp, info, d, q, indxq, rho = NumRu::Lapack.slaed2( n1, d, q, indxq, rho, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, Q2, INDX, INDXC, INDXP, COLTYP, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLAED2 merges the two sets of eigenvalues together into a single\n*  sorted set.  Then it tries to deflate the size of the problem.\n*  There are two ways in which deflation can occur:  when two or more\n*  eigenvalues are close together or if there is a tiny entry in the\n*  Z vector.  For each such occurrence the order of the related secular\n*  equation problem is reduced by one.\n*\n\n*  Arguments\n*  =========\n*\n*  K      (output) INTEGER\n*         The number of non-deflated eigenvalues, and the order of the\n*         related secular equation. 0 <= K <=N.\n*\n*  N      (input) INTEGER\n*         The dimension of the symmetric tridiagonal matrix.  N >= 0.\n*\n*  N1     (input) INTEGER\n*         The location of the last eigenvalue in the leading sub-matrix.\n*         min(1,N) <= N1 <= N/2.\n*\n*  D      (input/output) REAL array, dimension (N)\n*         On entry, D contains the eigenvalues of the two submatrices to\n*         be combined.\n*         On exit, D contains the trailing (N-K) updated eigenvalues\n*         (those which were deflated) sorted into increasing order.\n*\n*  Q      (input/output) REAL array, dimension (LDQ, N)\n*         On entry, Q contains the eigenvectors of two submatrices in\n*         the two square blocks with corners at (1,1), (N1,N1)\n*         and (N1+1, N1+1), (N,N).\n*         On exit, Q contains the trailing (N-K) updated eigenvectors\n*         (those which were deflated) in its last N-K columns.\n*\n*  LDQ    (input) INTEGER\n*         The leading dimension of the array Q.  LDQ >= max(1,N).\n*\n*  INDXQ  (input/output) INTEGER array, dimension (N)\n*         The permutation which separately sorts the two sub-problems\n*         in D into ascending order.  Note that elements in the second\n*         half of this permutation must first have N1 added to their\n*         values. Destroyed on exit.\n*\n*  RHO    (input/output) REAL\n*         On entry, the off-diagonal element associated with the rank-1\n*         cut which originally split the two submatrices which are now\n*         being recombined.\n*         On exit, RHO has been modified to the value required by\n*         SLAED3.\n*\n*  Z      (input) REAL array, dimension (N)\n*         On entry, Z contains the updating vector (the last\n*         row of the first sub-eigenvector matrix and the first row of\n*         the second sub-eigenvector matrix).\n*         On exit, the contents of Z have been destroyed by the updating\n*         process.\n*\n*  DLAMDA (output) REAL array, dimension (N)\n*         A copy of the first K eigenvalues which will be used by\n*         SLAED3 to form the secular equation.\n*\n*  W      (output) REAL array, dimension (N)\n*         The first k values of the final deflation-altered z-vector\n*         which will be passed to SLAED3.\n*\n*  Q2     (output) REAL array, dimension (N1**2+(N-N1)**2)\n*         A copy of the first K eigenvectors which will be used by\n*         SLAED3 in a matrix multiply (SGEMM) to solve for the new\n*         eigenvectors.\n*\n*  INDX   (workspace) INTEGER array, dimension (N)\n*         The permutation used to sort the contents of DLAMDA into\n*         ascending order.\n*\n*  INDXC  (output) INTEGER array, dimension (N)\n*         The permutation used to arrange the columns of the deflated\n*         Q matrix into three groups:  the first group contains non-zero\n*         elements only at and above N1, the second contains\n*         non-zero elements only below N1, and the third is dense.\n*\n*  INDXP  (workspace) INTEGER array, dimension (N)\n*         The permutation used to place deflated values of D at the end\n*         of the array.  INDXP(1:K) points to the nondeflated D-values\n*         and INDXP(K+1:N) points to the deflated eigenvalues.\n*\n*  COLTYP (workspace/output) INTEGER array, dimension (N)\n*         During execution, a label which will indicate which of the\n*         following types a column in the Q2 matrix is:\n*         1 : non-zero in the upper half only;\n*         2 : dense;\n*         3 : non-zero in the lower half only;\n*         4 : deflated.\n*         On exit, COLTYP(i) is the number of columns of type i,\n*         for i=1 to 4 only.\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*  Based on contributions by\n*     Jeff Rutter, Computer Science Division, University of California\n*     at Berkeley, USA\n*  Modified by Francoise Tisseur, University of Tennessee.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  k, dlamda, w, q2, indxc, coltyp, info, d, q, indxq, rho = NumRu::Lapack.slaed2( n1, d, q, indxq, rho, z, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_n1 = argv[0];
  rblapack_d = argv[1];
  rblapack_q = argv[2];
  rblapack_indxq = argv[3];
  rblapack_rho = argv[4];
  rblapack_z = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n1 = NUM2INT(rblapack_n1);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (3th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (3th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  n = NA_SHAPE1(rblapack_q);
  if (NA_TYPE(rblapack_q) != NA_SFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
  q = NA_PTR_TYPE(rblapack_q, real*);
  rho = (real)NUM2DBL(rblapack_rho);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of q");
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (6th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 1 of q");
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  if (!NA_IsNArray(rblapack_indxq))
    rb_raise(rb_eArgError, "indxq (4th argument) must be NArray");
  if (NA_RANK(rblapack_indxq) != 1)
    rb_raise(rb_eArgError, "rank of indxq (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_indxq) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of indxq must be the same as shape 1 of q");
  if (NA_TYPE(rblapack_indxq) != NA_LINT)
    rblapack_indxq = na_change_type(rblapack_indxq, NA_LINT);
  indxq = NA_PTR_TYPE(rblapack_indxq, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_dlamda = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  dlamda = NA_PTR_TYPE(rblapack_dlamda, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[1];
    shape[0] = pow(n1,2)+pow(n-n1,2);
    rblapack_q2 = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  q2 = NA_PTR_TYPE(rblapack_q2, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_indxc = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  indxc = NA_PTR_TYPE(rblapack_indxc, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_coltyp = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  coltyp = NA_PTR_TYPE(rblapack_coltyp, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
  MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_indxq_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  indxq_out__ = NA_PTR_TYPE(rblapack_indxq_out__, integer*);
  MEMCPY(indxq_out__, indxq, integer, NA_TOTAL(rblapack_indxq));
  rblapack_indxq = rblapack_indxq_out__;
  indxq = indxq_out__;
  indx = ALLOC_N(integer, (n));
  indxp = ALLOC_N(integer, (n));

  slaed2_(&k, &n, &n1, d, q, &ldq, indxq, &rho, z, dlamda, w, q2, indx, indxc, indxp, coltyp, &info);

  free(indx);
  free(indxp);
  rblapack_k = INT2NUM(k);
  rblapack_info = INT2NUM(info);
  rblapack_rho = rb_float_new((double)rho);
  return rb_ary_new3(11, rblapack_k, rblapack_dlamda, rblapack_w, rblapack_q2, rblapack_indxc, rblapack_coltyp, rblapack_info, rblapack_d, rblapack_q, rblapack_indxq, rblapack_rho);
}

void
init_lapack_slaed2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaed2", rblapack_slaed2, -1);
}
ruby-lapack-1.7.2/ext/dgesvj.c0000644000175000017500000004530212502221016016010 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgesvj_(char* joba, char* jobu, char* jobv, integer* m, integer* n, doublereal* a, integer* lda, doublereal* sva, integer* mv, doublereal* v, integer* ldv, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dgesvj(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_joba;
  char joba; 
  VALUE rblapack_jobu;
  char jobu; 
  VALUE rblapack_jobv;
  char jobv; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_mv;
  integer mv; 
  VALUE rblapack_v;
  doublereal *v; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_sva;
  doublereal *sva; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  VALUE rblapack_v_out__;
  doublereal *v_out__;
  VALUE rblapack_work_out__;
  doublereal *work_out__;

  integer lda;
  integer n;
  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, info, a, v, work = NumRu::Lapack.dgesvj( joba, jobu, jobv, m, a, mv, v, work, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V, LDV, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGESVJ computes the singular value decomposition (SVD) of a real\n*  M-by-N matrix A, where M >= N. The SVD of A is written as\n*                                     [++]   [xx]   [x0]   [xx]\n*               A = U * SIGMA * V^t,  [++] = [xx] * [ox] * [xx]\n*                                     [++]   [xx]\n*  where SIGMA is an N-by-N diagonal matrix, U is an M-by-N orthonormal\n*  matrix, and V is an N-by-N orthogonal matrix. The diagonal elements\n*  of SIGMA are the singular values of A. The columns of U and V are the\n*  left and the right singular vectors of A, respectively.\n*\n*  Further Details\n*  ~~~~~~~~~~~~~~~\n*  The orthogonal N-by-N matrix V is obtained as a product of Jacobi plane\n*  rotations. The rotations are implemented as fast scaled rotations of\n*  Anda and Park [1]. In the case of underflow of the Jacobi angle, a\n*  modified Jacobi transformation of Drmac [4] is used. Pivot strategy uses\n*  column interchanges of de Rijk [2]. The relative accuracy of the computed\n*  singular values and the accuracy of the computed singular vectors (in\n*  angle metric) is as guaranteed by the theory of Demmel and Veselic [3].\n*  The condition number that determines the accuracy in the full rank case\n*  is essentially min_{D=diag} kappa(A*D), where kappa(.) is the\n*  spectral condition number. The best performance of this Jacobi SVD\n*  procedure is achieved if used in an  accelerated version of Drmac and\n*  Veselic [5,6], and it is the kernel routine in the SIGMA library [7].\n*  Some tunning parameters (marked with [TP]) are available for the\n*  implementer.\n*  The computational range for the nonzero singular values is the  machine\n*  number interval ( UNDERFLOW , OVERFLOW ). In extreme cases, even\n*  denormalized singular values can be computed with the corresponding\n*  gradual loss of accurate digits.\n*\n*  Contributors\n*  ~~~~~~~~~~~~\n*  Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)\n*\n*  References\n*  ~~~~~~~~~~\n* [1] A. A. Anda and H. Park: Fast plane rotations with dynamic scaling.\n*     SIAM J. matrix Anal. Appl., Vol. 15 (1994), pp. 162-174.\n* [2] P. P. M. De Rijk: A one-sided Jacobi algorithm for computing the\n*     singular value decomposition on a vector computer.\n*     SIAM J. Sci. Stat. Comp., Vol. 10 (1998), pp. 359-371.\n* [3] J. Demmel and K. Veselic: Jacobi method is more accurate than QR.\n* [4] Z. Drmac: Implementation of Jacobi rotations for accurate singular\n*     value computation in floating point arithmetic.\n*     SIAM J. Sci. Comp., Vol. 18 (1997), pp. 1200-1222.\n* [5] 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* [6] 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* [7] 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 test examples and comments to\n*  drmac@math.hr. Thank you.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBA    (input) CHARACTER* 1\n*          Specifies the structure of A.\n*          = 'L': The input matrix A is lower triangular;\n*          = 'U': The input matrix A is upper triangular;\n*          = 'G': The input matrix A is general M-by-N matrix, M >= N.\n*\n*  JOBU    (input) CHARACTER*1\n*          Specifies whether to compute the left singular vectors\n*          (columns of U):\n*          = 'U': The left singular vectors corresponding to the nonzero\n*                 singular values are computed and returned in the leading\n*                 columns of A. See more details in the description of A.\n*                 The default numerical orthogonality threshold is set to\n*                 approximately TOL=CTOL*EPS, CTOL=DSQRT(M), EPS=DLAMCH('E').\n*          = 'C': Analogous to JOBU='U', except that user can control the\n*                 level of numerical orthogonality of the computed left\n*                 singular vectors. TOL can be set to TOL = CTOL*EPS, where\n*                 CTOL is given on input in the array WORK.\n*                 No CTOL smaller than ONE is allowed. CTOL greater\n*                 than 1 / EPS is meaningless. The option 'C'\n*                 can be used if M*EPS is satisfactory orthogonality\n*                 of the computed left singular vectors, so CTOL=M could\n*                 save few sweeps of Jacobi rotations.\n*                 See the descriptions of A and WORK(1).\n*          = 'N': The matrix U is not computed. However, see the\n*                 description of A.\n*\n*  JOBV    (input) CHARACTER*1\n*          Specifies whether to compute the right singular vectors, that\n*          is, the matrix V:\n*          = 'V' : the matrix V is computed and returned in the array V\n*          = 'A' : the Jacobi rotations are applied to the MV-by-N\n*                  array V. In other words, the right singular vector\n*                  matrix V is not computed explicitly, instead it is\n*                  applied to an MV-by-N matrix initially stored in the\n*                  first MV rows of V.\n*          = 'N' : the matrix V is not computed and the array V is not\n*                  referenced\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.\n*          M >= 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 :\n*          If JOBU .EQ. 'U' .OR. JOBU .EQ. 'C' :\n*                 If INFO .EQ. 0 :\n*                 RANKA orthonormal columns of U are returned in the\n*                 leading RANKA columns of the array A. Here RANKA <= N\n*                 is the number of computed singular values of A that are\n*                 above the underflow threshold DLAMCH('S'). The singular\n*                 vectors corresponding to underflowed or zero singular\n*                 values are not computed. The value of RANKA is returned\n*                 in the array WORK as RANKA=NINT(WORK(2)). Also see the\n*                 descriptions of SVA and WORK. The computed columns of U\n*                 are mutually numerically orthogonal up to approximately\n*                 TOL=DSQRT(M)*EPS (default); or TOL=CTOL*EPS (JOBU.EQ.'C'),\n*                 see the description of JOBU.\n*                 If INFO .GT. 0 :\n*                 the procedure DGESVJ did not converge in the given number\n*                 of iterations (sweeps). In that case, the computed\n*                 columns of U may not be orthogonal up to TOL. The output\n*                 U (stored in A), SIGMA (given by the computed singular\n*                 values in SVA(1:N)) and V is still a decomposition of the\n*                 input matrix A in the sense that the residual\n*                 ||A-SCALE*U*SIGMA*V^T||_2 / ||A||_2 is small.\n*\n*          If JOBU .EQ. 'N' :\n*                 If INFO .EQ. 0 :\n*                 Note that the left singular vectors are 'for free' in the\n*                 one-sided Jacobi SVD algorithm. However, if only the\n*                 singular values are needed, the level of numerical\n*                 orthogonality of U is not an issue and iterations are\n*                 stopped when the columns of the iterated matrix are\n*                 numerically orthogonal up to approximately M*EPS. Thus,\n*                 on exit, A contains the columns of U scaled with the\n*                 corresponding singular values.\n*                 If INFO .GT. 0 :\n*                 the procedure DGESVJ did not converge in the given number\n*                 of iterations (sweeps).\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*          If INFO .EQ. 0 :\n*          depending on the value SCALE = WORK(1), we have:\n*                 If SCALE .EQ. ONE :\n*                 SVA(1:N) contains the computed singular values of A.\n*                 During the computation SVA contains the Euclidean column\n*                 norms of the iterated matrices in the array A.\n*                 If SCALE .NE. ONE :\n*                 The singular values of A are SCALE*SVA(1:N), and this\n*                 factored representation is due to the fact that some of the\n*                 singular values of A might underflow or overflow.\n*          If INFO .GT. 0 :\n*          the procedure DGESVJ did not converge in the given number of\n*          iterations (sweeps) and SCALE*SVA(1:N) may not be accurate.\n*\n*  MV      (input) INTEGER\n*          If JOBV .EQ. 'A', then the product of Jacobi rotations in DGESVJ\n*          is applied to the first MV rows of V. See the description of JOBV.\n*\n*  V       (input/output) DOUBLE PRECISION array, dimension (LDV,N)\n*          If JOBV = 'V', then V contains on exit the N-by-N matrix of\n*                         the right singular vectors;\n*          If JOBV = 'A', then V contains the product of the computed right\n*                         singular vector matrix and the initial matrix in\n*                         the array V.\n*          If JOBV = 'N', then V is not referenced.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V, LDV .GE. 1.\n*          If JOBV .EQ. 'V', then LDV .GE. max(1,N).\n*          If JOBV .EQ. 'A', then LDV .GE. max(1,MV) .\n*\n*  WORK    (input/workspace/output) DOUBLE PRECISION array, dimension max(4,M+N).\n*          On entry :\n*          If JOBU .EQ. 'C' :\n*          WORK(1) = CTOL, where CTOL defines the threshold for convergence.\n*                    The process stops if all columns of A are mutually\n*                    orthogonal up to CTOL*EPS, EPS=DLAMCH('E').\n*                    It is required that CTOL >= ONE, i.e. it is not\n*                    allowed to force the routine to obtain orthogonality\n*                    below EPS.\n*          On exit :\n*          WORK(1) = SCALE is the scaling factor such that SCALE*SVA(1:N)\n*                    are the computed singular values of A.\n*                    (See description of SVA().)\n*          WORK(2) = NINT(WORK(2)) is the number of the computed nonzero\n*                    singular values.\n*          WORK(3) = NINT(WORK(3)) is the number of the computed singular\n*                    values that are larger than the underflow threshold.\n*          WORK(4) = NINT(WORK(4)) is the number of sweeps of Jacobi\n*                    rotations needed for numerical convergence.\n*          WORK(5) = max_{i.NE.j} |COS(A(:,i),A(:,j))| in the last sweep.\n*                    This is useful information in cases when DGESVJ did\n*                    not converge, as it can be used to estimate whether\n*                    the output is stil useful and for post festum analysis.\n*          WORK(6) = the largest absolute value over all sines of the\n*                    Jacobi rotation angles in the last sweep. It can be\n*                    useful for a post festum analysis.\n*\n*  LWORK   (input) INTEGER\n*          length of WORK, WORK >= MAX(6,M+N)\n*\n*  INFO    (output) INTEGER\n*          = 0 : successful exit.\n*          < 0 : if INFO = -i, then the i-th argument had an illegal value\n*          > 0 : DGESVJ did not converge in the maximal allowed number (30)\n*                of sweeps. The output may still be useful. See the\n*                description of WORK.\n*\n\n*  =====================================================================\n*\n*     .. Local Parameters ..\n      DOUBLE PRECISION   ZERO, HALF, ONE, TWO\n      PARAMETER          ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0,\n     +                   TWO = 2.0D0 )\n      INTEGER            NSWEEP\n      PARAMETER          ( NSWEEP = 30 )\n*     ..\n*     .. Local Scalars ..\n      DOUBLE PRECISION   AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,\n     +                   BIGTHETA, CS, CTOL, EPSLN, LARGE, MXAAPQ,\n     +                   MXSINJ, ROOTBIG, ROOTEPS, ROOTSFMIN, ROOTTOL,\n     +                   SKL, SFMIN, SMALL, SN, T, TEMP1, THETA,\n     +                   THSIGN, TOL\n      INTEGER            BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1,\n     +                   ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, N2, N34,\n     +                   N4, NBL, NOTROT, p, PSKIPPED, q, ROWSKIP,\n     +                   SWBAND\n      LOGICAL            APPLV, GOSCALE, LOWER, LSVEC, NOSCALE, ROTOK,\n     +                   RSVEC, UCTOL, UPPER\n*     ..\n*     .. Local Arrays ..\n      DOUBLE PRECISION   FASTR( 5 )\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          DABS, DMAX1, DMIN1, DBLE, MIN0, DSIGN, DSQRT\n*     ..\n*     .. External Functions ..\n*     ..\n*     from BLAS\n      DOUBLE PRECISION   DDOT, DNRM2\n      EXTERNAL           DDOT, DNRM2\n      INTEGER            IDAMAX\n      EXTERNAL           IDAMAX\n*     from LAPACK\n      DOUBLE PRECISION   DLAMCH\n      EXTERNAL           DLAMCH\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n*     ..\n*     from BLAS\n      EXTERNAL           DAXPY, DCOPY, DROTM, DSCAL, DSWAP\n*     from LAPACK\n      EXTERNAL           DLASCL, DLASET, DLASSQ, XERBLA\n*\n      EXTERNAL           DGSVJ0, DGSVJ1\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sva, info, a, v, work = NumRu::Lapack.dgesvj( joba, jobu, jobv, m, a, mv, v, work, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_joba = argv[0];
  rblapack_jobu = argv[1];
  rblapack_jobv = argv[2];
  rblapack_m = argv[3];
  rblapack_a = argv[4];
  rblapack_mv = argv[5];
  rblapack_v = argv[6];
  rblapack_work = argv[7];
  if (argc == 9) {
    rblapack_lwork = argv[8];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  joba = StringValueCStr(rblapack_joba)[0];
  jobv = StringValueCStr(rblapack_jobv)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th 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*);
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (7th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  if (NA_SHAPE1(rblapack_v) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of v must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_v) != NA_DFLOAT)
    rblapack_v = na_change_type(rblapack_v, NA_DFLOAT);
  v = NA_PTR_TYPE(rblapack_v, doublereal*);
  jobu = StringValueCStr(rblapack_jobu)[0];
  mv = NUM2INT(rblapack_mv);
  m = NUM2INT(rblapack_m);
  lwork = MAX(4,m+n);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (8th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != lwork)
    rb_raise(rb_eRuntimeError, "shape 0 of work must be MAX(4,m+n)");
  if (NA_TYPE(rblapack_work) != NA_DFLOAT)
    rblapack_work = na_change_type(rblapack_work, NA_DFLOAT);
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_sva = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  sva = NA_PTR_TYPE(rblapack_sva, doublereal*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = n;
    rblapack_v_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  v_out__ = NA_PTR_TYPE(rblapack_v_out__, doublereal*);
  MEMCPY(v_out__, v, doublereal, NA_TOTAL(rblapack_v));
  rblapack_v = rblapack_v_out__;
  v = v_out__;
  {
    na_shape_t 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__;

  dgesvj_(&joba, &jobu, &jobv, &m, &n, a, &lda, sva, &mv, v, &ldv, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_sva, rblapack_info, rblapack_a, rblapack_v, rblapack_work);
}

void
init_lapack_dgesvj(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgesvj", rblapack_dgesvj, -1);
}
ruby-lapack-1.7.2/ext/zspmv.c0000644000175000017500000001614712502221025015712 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zspmv_(char* uplo, integer* n, doublecomplex* alpha, doublecomplex* ap, doublecomplex* x, integer* incx, doublecomplex* beta, doublecomplex* y, integer* incy);


static VALUE
rblapack_zspmv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_alpha;
  doublecomplex alpha; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_beta;
  doublecomplex beta; 
  VALUE rblapack_y;
  doublecomplex *y; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_y_out__;
  doublecomplex *y_out__;


  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  y = NumRu::Lapack.zspmv( uplo, n, alpha, ap, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSPMV( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )\n\n*  Purpose\n*  =======\n*\n*  ZSPMV  performs the matrix-vector operation\n*\n*     y := alpha*A*x + beta*y,\n*\n*  where alpha and beta are scalars, x and y are n element vectors and\n*  A is an n by n symmetric matrix, supplied in packed form.\n*\n\n*  Arguments\n*  ==========\n*\n*  UPLO     (input) CHARACTER*1\n*           On entry, UPLO specifies whether the upper or lower\n*           triangular part of the matrix A is supplied in the packed\n*           array AP as follows:\n*\n*              UPLO = 'U' or 'u'   The upper triangular part of A is\n*                                  supplied in AP.\n*\n*              UPLO = 'L' or 'l'   The lower triangular part of A is\n*                                  supplied in AP.\n*\n*           Unchanged on exit.\n*\n*  N        (input) INTEGER\n*           On entry, N specifies the order of the matrix A.\n*           N must be at least zero.\n*           Unchanged on exit.\n*\n*  ALPHA    (input) COMPLEX*16\n*           On entry, ALPHA specifies the scalar alpha.\n*           Unchanged on exit.\n*\n*  AP       (input) COMPLEX*16 array, dimension at least\n*           ( ( N*( N + 1 ) )/2 ).\n*           Before entry, with UPLO = 'U' or 'u', the array AP must\n*           contain the upper triangular part of the symmetric matrix\n*           packed sequentially, column by column, so that AP( 1 )\n*           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )\n*           and a( 2, 2 ) respectively, and so on.\n*           Before entry, with UPLO = 'L' or 'l', the array AP must\n*           contain the lower triangular part of the symmetric matrix\n*           packed sequentially, column by column, so that AP( 1 )\n*           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )\n*           and a( 3, 1 ) respectively, and so on.\n*           Unchanged on exit.\n*\n*  X        (input) COMPLEX*16 array, dimension at least\n*           ( 1 + ( N - 1 )*abs( INCX ) ).\n*           Before entry, the incremented array X must contain the N-\n*           element vector x.\n*           Unchanged on exit.\n*\n*  INCX     (input) INTEGER\n*           On entry, INCX specifies the increment for the elements of\n*           X. INCX must not be zero.\n*           Unchanged on exit.\n*\n*  BETA     (input) COMPLEX*16\n*           On entry, BETA specifies the scalar beta. When BETA is\n*           supplied as zero then Y need not be set on input.\n*           Unchanged on exit.\n*\n*  Y        (input/output) COMPLEX*16 array, dimension at least\n*           ( 1 + ( N - 1 )*abs( INCY ) ).\n*           Before entry, the incremented array Y must contain the n\n*           element vector y. On exit, Y is overwritten by the updated\n*           vector y.\n*\n*  INCY     (input) INTEGER\n*           On entry, INCY specifies the increment for the elements of\n*           Y. INCY must not be zero.\n*           Unchanged on exit.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  y = NumRu::Lapack.zspmv( uplo, n, alpha, ap, x, incx, beta, y, incy, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_uplo = argv[0];
  rblapack_n = argv[1];
  rblapack_alpha = argv[2];
  rblapack_ap = argv[3];
  rblapack_x = argv[4];
  rblapack_incx = argv[5];
  rblapack_beta = argv[6];
  rblapack_y = argv[7];
  rblapack_incy = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  alpha.r = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
  alpha.i = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
  incx = NUM2INT(rblapack_incx);
  incy = NUM2INT(rblapack_incy);
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (5th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1 + ( n - 1 )*abs( incx )))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (8th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (1 + ( n - 1 )*abs( incy )))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1 + ( n - 1 )*abs( incy ));
  if (NA_TYPE(rblapack_y) != NA_DCOMPLEX)
    rblapack_y = na_change_type(rblapack_y, NA_DCOMPLEX);
  y = NA_PTR_TYPE(rblapack_y, doublecomplex*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (( n*( n + 1 ) )/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", ( n*( n + 1 ) )/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  beta.r = NUM2DBL(rb_funcall(rblapack_beta, rb_intern("real"), 0));
  beta.i = NUM2DBL(rb_funcall(rblapack_beta, rb_intern("imag"), 0));
  {
    na_shape_t shape[1];
    shape[0] = 1 + ( n - 1 )*abs( incy );
    rblapack_y_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublecomplex*);
  MEMCPY(y_out__, y, doublecomplex, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  zspmv_(&uplo, &n, &alpha, ap, x, &incx, &beta, y, &incy);

  return rblapack_y;
}

void
init_lapack_zspmv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zspmv", rblapack_zspmv, -1);
}
ruby-lapack-1.7.2/ext/zlarzt.c0000644000175000017500000001672612502221017016065 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlarzt_(char* direct, char* storev, integer* n, integer* k, doublecomplex* v, integer* ldv, doublecomplex* tau, doublecomplex* t, integer* ldt);


static VALUE
rblapack_zlarzt(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_direct;
  char direct; 
  VALUE rblapack_storev;
  char storev; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_v;
  doublecomplex *v; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_t;
  doublecomplex *t; 
  VALUE rblapack_v_out__;
  doublecomplex *v_out__;

  integer ldv;
  integer k;
  integer ldt;

  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  t, v = NumRu::Lapack.zlarzt( direct, storev, n, v, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n*  Purpose\n*  =======\n*\n*  ZLARZT forms the triangular factor T of a complex block reflector\n*  H of order > n, which is defined as a product of k elementary\n*  reflectors.\n*\n*  If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n*\n*  If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n*\n*  If STOREV = 'C', the vector which defines the elementary reflector\n*  H(i) is stored in the i-th column of the array V, and\n*\n*     H  =  I - V * T * V'\n*\n*  If STOREV = 'R', the vector which defines the elementary reflector\n*  H(i) is stored in the i-th row of the array V, and\n*\n*     H  =  I - V' * T * V\n*\n*  Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n*\n\n*  Arguments\n*  =========\n*\n*  DIRECT  (input) CHARACTER*1\n*          Specifies the order in which the elementary reflectors are\n*          multiplied to form the block reflector:\n*          = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n*          = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n*  STOREV  (input) CHARACTER*1\n*          Specifies how the vectors which define the elementary\n*          reflectors are stored (see also Further Details):\n*          = 'C': columnwise                        (not supported yet)\n*          = 'R': rowwise\n*\n*  N       (input) INTEGER\n*          The order of the block reflector H. N >= 0.\n*\n*  K       (input) INTEGER\n*          The order of the triangular factor T (= the number of\n*          elementary reflectors). K >= 1.\n*\n*  V       (input/output) COMPLEX*16 array, dimension\n*                               (LDV,K) if STOREV = 'C'\n*                               (LDV,N) if STOREV = 'R'\n*          The matrix V. See further details.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V.\n*          If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n*\n*  TAU     (input) COMPLEX*16 array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i).\n*\n*  T       (output) COMPLEX*16 array, dimension (LDT,K)\n*          The k by k triangular factor T of the block reflector.\n*          If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n*          lower triangular. The rest of the array is not used.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= K.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n*  The shape of the matrix V and the storage of the vectors which define\n*  the H(i) is best illustrated by the following example with n = 5 and\n*  k = 3. The elements equal to 1 are not stored; the corresponding\n*  array elements are modified but restored on exit. The rest of the\n*  array is not used.\n*\n*  DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R':\n*\n*                                              ______V_____\n*         ( v1 v2 v3 )                        /            \\\n*         ( v1 v2 v3 )                      ( v1 v1 v1 v1 v1 . . . . 1 )\n*     V = ( v1 v2 v3 )                      ( v2 v2 v2 v2 v2 . . . 1   )\n*         ( v1 v2 v3 )                      ( v3 v3 v3 v3 v3 . . 1     )\n*         ( v1 v2 v3 )\n*            .  .  .\n*            .  .  .\n*            1  .  .\n*               1  .\n*                  1\n*\n*  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R':\n*\n*                                                        ______V_____\n*            1                                          /            \\\n*            .  1                           ( 1 . . . . v1 v1 v1 v1 v1 )\n*            .  .  1                        ( . 1 . . . v2 v2 v2 v2 v2 )\n*            .  .  .                        ( . . 1 . . v3 v3 v3 v3 v3 )\n*            .  .  .\n*         ( v1 v2 v3 )\n*         ( v1 v2 v3 )\n*     V = ( v1 v2 v3 )\n*         ( v1 v2 v3 )\n*         ( v1 v2 v3 )\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  t, v = NumRu::Lapack.zlarzt( direct, storev, n, v, tau, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_direct = argv[0];
  rblapack_storev = argv[1];
  rblapack_n = argv[2];
  rblapack_v = argv[3];
  rblapack_tau = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  direct = StringValueCStr(rblapack_direct)[0];
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  storev = StringValueCStr(rblapack_storev)[0];
  ldt = k;
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (4th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  if (NA_SHAPE1(rblapack_v) != (lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0))
    rb_raise(rb_eRuntimeError, "shape 1 of v must be %d", lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0);
  if (NA_TYPE(rblapack_v) != NA_DCOMPLEX)
    rblapack_v = na_change_type(rblapack_v, NA_DCOMPLEX);
  v = NA_PTR_TYPE(rblapack_v, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = k;
    rblapack_t = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  t = NA_PTR_TYPE(rblapack_t, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0;
    rblapack_v_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  v_out__ = NA_PTR_TYPE(rblapack_v_out__, doublecomplex*);
  MEMCPY(v_out__, v, doublecomplex, NA_TOTAL(rblapack_v));
  rblapack_v = rblapack_v_out__;
  v = v_out__;

  zlarzt_(&direct, &storev, &n, &k, v, &ldv, tau, t, &ldt);

  return rb_ary_new3(2, rblapack_t, rblapack_v);
}

void
init_lapack_zlarzt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlarzt", rblapack_zlarzt, -1);
}
ruby-lapack-1.7.2/ext/ctftri.c0000644000175000017500000002050312502221026016016 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctftri_(char* transr, char* uplo, char* diag, integer* n, complex* a, integer* info);


static VALUE
rblapack_ctftri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;


  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  info, a = NumRu::Lapack.ctftri( transr, uplo, diag, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTFTRI( TRANSR, UPLO, DIAG, N, A, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTFTRI computes the inverse of a triangular matrix A stored in RFP\n*  format.\n*\n*  This is a Level 3 BLAS version of the algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR    (input) CHARACTER*1\n*          = 'N':  The Normal TRANSR of RFP A is stored;\n*          = 'C':  The Conjugate-transpose TRANSR of RFP A is stored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension ( N*(N+1)/2 );\n*          On entry, the triangular matrix A in RFP format. RFP format\n*          is described by TRANSR, UPLO, and N as follows: If TRANSR =\n*          'N' then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n*          (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is\n*          the Conjugate-transpose of RFP A as defined when\n*          TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n*          follows: If UPLO = 'U' the RFP A contains the nt elements of\n*          upper packed A; If UPLO = 'L' the RFP A contains the nt\n*          elements of lower packed A. The LDA of RFP A is (N+1)/2 when\n*          TRANSR = 'C'. When TRANSR is 'N' the LDA is N+1 when N is\n*          even and N is odd. See the Note below for more details.\n*\n*          On exit, the (triangular) inverse of the original matrix, in\n*          the same storage format.\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, A(i,i) is exactly zero.  The triangular\n*               matrix is singular and its inverse can not be computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  We first consider Standard Packed Format when N is even.\n*  We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  conjugate-transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  conjugate-transpose of the last three columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                -- -- --\n*        03 04 05                33 43 53\n*                                   -- --\n*        13 14 15                00 44 54\n*                                      --\n*        23 24 25                10 11 55\n*\n*        33 34 35                20 21 22\n*        --\n*        00 44 45                30 31 32\n*        -- --\n*        01 11 55                40 41 42\n*        -- -- --\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- -- --                -- -- -- -- -- --\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     -- -- -- -- --                -- -- -- -- --\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     -- -- -- -- -- --                -- -- -- --\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We next  consider Standard Packed Format when N is odd.\n*  We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  conjugate-transpose of the first two   columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  conjugate-transpose of the last two   columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N odd  and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                   -- --\n*        02 03 04                00 33 43\n*                                      --\n*        12 13 14                10 11 44\n*\n*        22 23 24                20 21 22\n*        --\n*        00 33 34                30 31 32\n*        -- --\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- --                   -- -- -- -- -- --\n*     02 12 22 00 01             00 10 20 30 40 50\n*     -- -- -- --                   -- -- -- -- --\n*     03 13 23 33 11             33 11 21 31 41 51\n*     -- -- -- -- --                   -- -- -- --\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.ctftri( transr, uplo, diag, n, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_diag = argv[2];
  rblapack_n = argv[3];
  rblapack_a = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 1)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  ctftri_(&transr, &uplo, &diag, &n, a, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_ctftri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctftri", rblapack_ctftri, -1);
}
ruby-lapack-1.7.2/ext/dlantp.c0000644000175000017500000001141212502221016016003 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal dlantp_(char* norm, char* uplo, char* diag, integer* n, doublereal* ap, doublereal* work);


static VALUE
rblapack_dlantp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack___out__;
  doublereal __out__; 
  doublereal *work;

  integer lwork;

  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  __out__ = NumRu::Lapack.dlantp( norm, uplo, diag, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION DLANTP( NORM, UPLO, DIAG, N, AP, WORK )\n\n*  Purpose\n*  =======\n*\n*  DLANTP  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  triangular matrix A, supplied in packed form.\n*\n*  Description\n*  ===========\n*\n*  DLANTP returns the value\n*\n*     DLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in DLANTP as described\n*          above.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the matrix A is upper or lower triangular.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  DIAG    (input) CHARACTER*1\n*          Specifies whether or not the matrix A is unit triangular.\n*          = 'N':  Non-unit triangular\n*          = 'U':  Unit triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, DLANTP is\n*          set to zero.\n*\n*  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          The upper or lower triangular matrix A, packed columnwise in\n*          a linear array.  The j-th column of A is stored in the array\n*          AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          Note that when DIAG = 'U', the elements of the array AP\n*          corresponding to the diagonal elements of the matrix A are\n*          not referenced, but are assumed to be one.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n*          referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.dlantp( norm, uplo, diag, n, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_diag = argv[2];
  rblapack_n = argv[3];
  rblapack_ap = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  n = NUM2INT(rblapack_n);
  lwork = lsame_(&norm,"I") ? n : 0;
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  work = ALLOC_N(doublereal, (MAX(1,lwork)));

  __out__ = dlantp_(&norm, &uplo, &diag, &n, ap, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_dlantp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlantp", rblapack_dlantp, -1);
}
ruby-lapack-1.7.2/ext/zppsv.c0000644000175000017500000001444012502221021015703 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zppsv_(char* uplo, integer* n, integer* nrhs, doublecomplex* ap, doublecomplex* b, integer* ldb, integer* info);


static VALUE
rblapack_zppsv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublecomplex *ap_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer ldb;
  integer nrhs;

  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  info, ap, b = NumRu::Lapack.zppsv( uplo, n, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPPSV( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPPSV computes the solution to a complex system of linear equations\n*     A * X = B,\n*  where A is an N-by-N Hermitian positive definite matrix stored in\n*  packed format and X and B are N-by-NRHS matrices.\n*\n*  The Cholesky decomposition is used to factor A as\n*     A = U**H* U,  if UPLO = 'U', or\n*     A = L * L**H,  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is a lower triangular\n*  matrix.  The factored form of A is then used to solve the system of\n*  equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          See below for further details.\n*\n*          On exit, if INFO = 0, the factor U or L from the Cholesky\n*          factorization A = U**H*U or A = L*L**H, in the same storage\n*          format as A.\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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 leading minor of order i of A is not\n*                positive definite, so the factorization could not be\n*                completed, and the solution has not been computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  The packed storage scheme is illustrated by the following example\n*  when N = 4, UPLO = 'U':\n*\n*  Two-dimensional storage of the Hermitian matrix A:\n*\n*     a11 a12 a13 a14\n*         a22 a23 a24\n*             a33 a34     (aij = conjg(aji))\n*                 a44\n*\n*  Packed storage of the upper triangle of A:\n*\n*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n*  =====================================================================\n*\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZPPTRF, ZPPTRS\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ap, b = NumRu::Lapack.zppsv( uplo, n, ap, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_n = argv[1];
  rblapack_ap = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
  MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zppsv_(&uplo, &n, &nrhs, ap, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_ap, rblapack_b);
}

void
init_lapack_zppsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zppsv", rblapack_zppsv, -1);
}
ruby-lapack-1.7.2/ext/sgetri.c0000644000175000017500000001204112502221014016013 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgetri_(integer* n, real* a, integer* lda, integer* ipiv, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sgetri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *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  work, info, a = NumRu::Lapack.sgetri( a, ipiv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGETRI computes the inverse of a matrix using the LU factorization\n*  computed by SGETRF.\n*\n*  This method inverts U and then computes inv(A) by solving the system\n*  inv(A)*L = inv(U) for inv(A).\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the factors L and U from the factorization\n*          A = P*L*U as computed by SGETRF.\n*          On exit, if INFO = 0, the inverse of the original matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices from SGETRF; for 1<=i<=N, row i of the\n*          matrix was interchanged with row IPIV(i).\n*\n*  WORK    (workspace/output) REAL array, dimension (MAX(1,LWORK))\n*          On exit, if INFO=0, then WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK.  LWORK >= max(1,N).\n*          For optimal performance LWORK >= N*NB, where NB is\n*          the optimal blocksize returned by ILAENV.\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, U(i,i) is exactly zero; the matrix is\n*                singular and its inverse could not be 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 = NumRu::Lapack.sgetri( a, ipiv, [: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_a = argv[0];
  rblapack_ipiv = 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 (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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (2th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  sgetri_(&n, a, &lda, ipiv, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_sgetri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgetri", rblapack_sgetri, -1);
}
ruby-lapack-1.7.2/ext/cla_heamv.c0000644000175000017500000001642112502221022016442 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cla_heamv_(integer* uplo, integer* n, real* alpha, real* a, integer* lda, complex* x, integer* incx, real* beta, real* y, integer* incy);


static VALUE
rblapack_cla_heamv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  integer uplo; 
  VALUE rblapack_alpha;
  real alpha; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_beta;
  real beta; 
  VALUE rblapack_y;
  real *y; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_y_out__;
  real *y_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  y = NumRu::Lapack.cla_heamv( uplo, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLA_HEAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n*  Purpose\n*  =======\n*\n*  CLA_SYAMV  performs the matrix-vector operation\n*\n*          y := alpha*abs(A)*abs(x) + beta*abs(y),\n*\n*  where alpha and beta are scalars, x and y are vectors and A is an\n*  n by n symmetric matrix.\n*\n*  This function is primarily used in calculating error bounds.\n*  To protect against underflow during evaluation, components in\n*  the resulting vector are perturbed away from zero by (N+1)\n*  times the underflow threshold.  To prevent unnecessarily large\n*  errors for block-structure embedded in general matrices,\n*  \"symbolically\" zero components are not perturbed.  A zero\n*  entry is considered \"symbolic\" if all multiplications involved\n*  in computing that entry have at least one zero multiplicand.\n*\n\n*  Arguments\n*  ==========\n*\n*  UPLO    (input) INTEGER\n*           On entry, UPLO specifies whether the upper or lower\n*           triangular part of the array A is to be referenced as\n*           follows:\n*\n*              UPLO = BLAS_UPPER   Only the upper triangular part of A\n*                                  is to be referenced.\n*\n*              UPLO = BLAS_LOWER   Only the lower triangular part of A\n*                                  is to be referenced.\n*\n*           Unchanged on exit.\n*\n*  N       (input) INTEGER\n*           On entry, N specifies the number of columns of the matrix A.\n*           N must be at least zero.\n*           Unchanged on exit.\n*\n*  ALPHA   (input) REAL            .\n*           On entry, ALPHA specifies the scalar alpha.\n*           Unchanged on exit.\n*\n*  A      - COMPLEX             array of DIMENSION ( LDA, n ).\n*           Before entry, the leading m by n part of the array A must\n*           contain the matrix of coefficients.\n*           Unchanged on exit.\n*\n*  LDA     (input) INTEGER\n*           On entry, LDA specifies the first dimension of A as declared\n*           in the calling (sub) program. LDA must be at least\n*           max( 1, n ).\n*           Unchanged on exit.\n*\n*  X       (input) COMPLEX array, dimension\n*           ( 1 + ( n - 1 )*abs( INCX ) )\n*           Before entry, the incremented array X must contain the\n*           vector x.\n*           Unchanged on exit.\n*\n*  INCX    (input) INTEGER\n*           On entry, INCX specifies the increment for the elements of\n*           X. INCX must not be zero.\n*           Unchanged on exit.\n*\n*  BETA    (input) REAL            .\n*           On entry, BETA specifies the scalar beta. When BETA is\n*           supplied as zero then Y need not be set on input.\n*           Unchanged on exit.\n*\n*  Y       (input/output) REAL array, dimension\n*           ( 1 + ( n - 1 )*abs( INCY ) )\n*           Before entry with BETA non-zero, the incremented array Y\n*           must contain the vector y. On exit, Y is overwritten by the\n*           updated vector y.\n*\n*  INCY    (input) INTEGER\n*           On entry, INCY specifies the increment for the elements of\n*           Y. INCY must not be zero.\n*           Unchanged on exit.\n*\n\n*  Further Details\n*  ===============\n*\n*  Level 2 Blas routine.\n*\n*  -- Written on 22-October-1986.\n*     Jack Dongarra, Argonne National Lab.\n*     Jeremy Du Croz, Nag Central Office.\n*     Sven Hammarling, Nag Central Office.\n*     Richard Hanson, Sandia National Labs.\n*  -- Modified for the absolute-value product, April 2006\n*     Jason Riedy, UC Berkeley\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  y = NumRu::Lapack.cla_heamv( uplo, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_uplo = argv[0];
  rblapack_alpha = argv[1];
  rblapack_a = argv[2];
  rblapack_x = argv[3];
  rblapack_incx = argv[4];
  rblapack_beta = argv[5];
  rblapack_y = argv[6];
  rblapack_incy = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = NUM2INT(rblapack_uplo);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = lda;
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be n");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  incx = NUM2INT(rblapack_incx);
  incy = NUM2INT(rblapack_incy);
  alpha = (real)NUM2DBL(rblapack_alpha);
  beta = (real)NUM2DBL(rblapack_beta);
  lda = n;
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (4th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1 + ( n - 1 )*abs( incx )))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (7th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (1 + ( n - 1 )*abs( incy )))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1 + ( n - 1 )*abs( incy ));
  if (NA_TYPE(rblapack_y) != NA_SFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
  y = NA_PTR_TYPE(rblapack_y, real*);
  {
    na_shape_t shape[1];
    shape[0] = 1 + ( n - 1 )*abs( incy );
    rblapack_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
  MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  cla_heamv_(&uplo, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);

  return rblapack_y;
}

void
init_lapack_cla_heamv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cla_heamv", rblapack_cla_heamv, -1);
}
ruby-lapack-1.7.2/ext/dlag2s.c0000644000175000017500000000731012655767575015741 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlag2s_(integer* m, integer* n, doublereal* a, integer* lda, real* sa, integer* ldsa, integer* info);


static VALUE
rblapack_dlag2s(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_sa;
  real *sa; 
  VALUE rblapack_info;
  integer info; 

  integer lda;
  integer n;
  integer ldsa;

  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  sa, info = NumRu::Lapack.dlag2s( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAG2S( M, N, A, LDA, SA, LDSA, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLAG2S converts a DOUBLE PRECISION matrix, SA, to a SINGLE\n*  PRECISION matrix, A.\n*\n*  RMAX is the overflow for the SINGLE PRECISION arithmetic\n*  DLAG2S checks that all the entries of A are between -RMAX and\n*  RMAX. If not the conversion is aborted and a flag is raised.\n*\n*  This is an auxiliary routine so there is no argument checking.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of lines 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) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the M-by-N coefficient matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  SA      (output) REAL array, dimension (LDSA,N)\n*          On exit, if INFO=0, the M-by-N coefficient matrix SA; if\n*          INFO>0, the content of SA is unspecified.\n*\n*  LDSA    (input) INTEGER\n*          The leading dimension of the array SA.  LDSA >= max(1,M).\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit.\n*          = 1:  an entry of the matrix A is greater than the SINGLE\n*                PRECISION overflow threshold, in this case, the content\n*                of SA in exit is unspecified.\n*\n*  =========\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n      DOUBLE PRECISION   RMAX\n*     ..\n*     .. External Functions ..\n      REAL               SLAMCH\n      EXTERNAL           SLAMCH\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sa, info = NumRu::Lapack.dlag2s( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  ldsa = MAX(1,m);
  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*);
  {
    na_shape_t shape[2];
    shape[0] = ldsa;
    shape[1] = n;
    rblapack_sa = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  sa = NA_PTR_TYPE(rblapack_sa, real*);

  dlag2s_(&m, &n, a, &lda, sa, &ldsa, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_sa, rblapack_info);
}

void
init_lapack_dlag2s(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlag2s", rblapack_dlag2s, -1);
}
ruby-lapack-1.7.2/ext/clacgv.c0000644000175000017500000000562612502221012015766 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clacgv_(integer* n, complex* x, integer* incx);


static VALUE
rblapack_clacgv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_x_out__;
  complex *x_out__;


  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  x = NumRu::Lapack.clacgv( n, x, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLACGV( N, X, INCX )\n\n*  Purpose\n*  =======\n*\n*  CLACGV conjugates a complex vector of length N.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The length of the vector X.  N >= 0.\n*\n*  X       (input/output) COMPLEX array, dimension\n*                         (1+(N-1)*abs(INCX))\n*          On entry, the vector of length N to be conjugated.\n*          On exit, X is overwritten with conjg(X).\n*\n*  INCX    (input) INTEGER\n*          The spacing between successive elements of X.\n*\n\n* =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, IOFF\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          CONJG\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x = NumRu::Lapack.clacgv( n, x, incx, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_n = argv[0];
  rblapack_x = argv[1];
  rblapack_incx = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  incx = NUM2INT(rblapack_incx);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1+(n-1)*abs(incx)))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*abs(incx));
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*abs(incx);
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;

  clacgv_(&n, x, &incx);

  return rblapack_x;
}

void
init_lapack_clacgv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clacgv", rblapack_clacgv, -1);
}
ruby-lapack-1.7.2/ext/sgeqpf.c0000644000175000017500000001337512502221024016017 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgeqpf_(integer* m, integer* n, real* a, integer* lda, integer* jpvt, real* tau, real* work, integer* info);


static VALUE
rblapack_sgeqpf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_jpvt;
  integer *jpvt; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_jpvt_out__;
  integer *jpvt_out__;
  real *work;

  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, info, a, jpvt = NumRu::Lapack.sgeqpf( m, a, jpvt, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  This routine is deprecated and has been replaced by routine SGEQP3.\n*\n*  SGEQPF computes a QR factorization with column pivoting of a\n*  real M-by-N matrix A: A*P = Q*R.\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) REAL array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, the upper triangle of the array contains the\n*          min(M,N)-by-N upper triangular matrix R; the elements\n*          below the diagonal, together with the array TAU,\n*          represent the orthogonal matrix Q as a product of\n*          min(m,n) elementary reflectors.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  JPVT    (input/output) INTEGER array, dimension (N)\n*          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n*          to the front of A*P (a leading column); if JPVT(i) = 0,\n*          the i-th column of A is a free column.\n*          On exit, if JPVT(i) = k, then the i-th column of A*P\n*          was the k-th column of A.\n*\n*  TAU     (output) REAL array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors.\n*\n*  WORK    (workspace) REAL array, dimension (3*N)\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(1) H(2) . . . H(n)\n*\n*  Each H(i) has the form\n*\n*     H = 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:m) is stored on exit in A(i+1:m,i).\n*\n*  The matrix P is represented in jpvt as follows: If\n*     jpvt(j) = i\n*  then the jth column of P is the ith canonical unit vector.\n*\n*  Partial column norm updating strategy modified by\n*    Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n*    University of Zagreb, Croatia.\n*     June 2010\n*  For more details see LAPACK Working Note 176.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, info, a, jpvt = NumRu::Lapack.sgeqpf( m, a, jpvt, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  rblapack_jpvt = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_jpvt))
    rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
  if (NA_RANK(rblapack_jpvt) != 1)
    rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_jpvt);
  if (NA_TYPE(rblapack_jpvt) != NA_LINT)
    rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
  jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of jpvt");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
  MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
  rblapack_jpvt = rblapack_jpvt_out__;
  jpvt = jpvt_out__;
  work = ALLOC_N(real, (3*n));

  sgeqpf_(&m, &n, a, &lda, jpvt, tau, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_tau, rblapack_info, rblapack_a, rblapack_jpvt);
}

void
init_lapack_sgeqpf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgeqpf", rblapack_sgeqpf, -1);
}
ruby-lapack-1.7.2/ext/dlasv2.c0000644000175000017500000001074412502221014015721 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlasv2_(doublereal* f, doublereal* g, doublereal* h, doublereal* ssmin, doublereal* ssmax, doublereal* snr, doublereal* csr, doublereal* snl, doublereal* csl);


static VALUE
rblapack_dlasv2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_f;
  doublereal f; 
  VALUE rblapack_g;
  doublereal g; 
  VALUE rblapack_h;
  doublereal h; 
  VALUE rblapack_ssmin;
  doublereal ssmin; 
  VALUE rblapack_ssmax;
  doublereal ssmax; 
  VALUE rblapack_snr;
  doublereal snr; 
  VALUE rblapack_csr;
  doublereal csr; 
  VALUE rblapack_snl;
  doublereal snl; 
  VALUE rblapack_csl;
  doublereal csl; 


  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  ssmin, ssmax, snr, csr, snl, csl = NumRu::Lapack.dlasv2( f, g, h, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL )\n\n*  Purpose\n*  =======\n*\n*  DLASV2 computes the singular value decomposition of a 2-by-2\n*  triangular matrix\n*     [  F   G  ]\n*     [  0   H  ].\n*  On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the\n*  smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and\n*  right singular vectors for abs(SSMAX), giving the decomposition\n*\n*     [ CSL  SNL ] [  F   G  ] [ CSR -SNR ]  =  [ SSMAX   0   ]\n*     [-SNL  CSL ] [  0   H  ] [ SNR  CSR ]     [  0    SSMIN ].\n*\n\n*  Arguments\n*  =========\n*\n*  F       (input) DOUBLE PRECISION\n*          The (1,1) element of the 2-by-2 matrix.\n*\n*  G       (input) DOUBLE PRECISION\n*          The (1,2) element of the 2-by-2 matrix.\n*\n*  H       (input) DOUBLE PRECISION\n*          The (2,2) element of the 2-by-2 matrix.\n*\n*  SSMIN   (output) DOUBLE PRECISION\n*          abs(SSMIN) is the smaller singular value.\n*\n*  SSMAX   (output) DOUBLE PRECISION\n*          abs(SSMAX) is the larger singular value.\n*\n*  SNL     (output) DOUBLE PRECISION\n*  CSL     (output) DOUBLE PRECISION\n*          The vector (CSL, SNL) is a unit left singular vector for the\n*          singular value abs(SSMAX).\n*\n*  SNR     (output) DOUBLE PRECISION\n*  CSR     (output) DOUBLE PRECISION\n*          The vector (CSR, SNR) is a unit right singular vector for the\n*          singular value abs(SSMAX).\n*\n\n*  Further Details\n*  ===============\n*\n*  Any input parameter may be aliased with any output parameter.\n*\n*  Barring over/underflow and assuming a guard digit in subtraction, all\n*  output quantities are correct to within a few units in the last\n*  place (ulps).\n*\n*  In IEEE arithmetic, the code works correctly if one matrix element is\n*  infinite.\n*\n*  Overflow will not occur unless the largest singular value itself\n*  overflows or is within a few ulps of overflow. (On machines with\n*  partial overflow, like the Cray, overflow may occur if the largest\n*  singular value is within a factor of 2 of overflow.)\n*\n*  Underflow is harmless if underflow is gradual. Otherwise, results\n*  may correspond to a matrix modified by perturbations of size near\n*  the underflow threshold.\n*\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ssmin, ssmax, snr, csr, snl, csl = NumRu::Lapack.dlasv2( f, g, h, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_f = argv[0];
  rblapack_g = argv[1];
  rblapack_h = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  f = NUM2DBL(rblapack_f);
  h = NUM2DBL(rblapack_h);
  g = NUM2DBL(rblapack_g);

  dlasv2_(&f, &g, &h, &ssmin, &ssmax, &snr, &csr, &snl, &csl);

  rblapack_ssmin = rb_float_new((double)ssmin);
  rblapack_ssmax = rb_float_new((double)ssmax);
  rblapack_snr = rb_float_new((double)snr);
  rblapack_csr = rb_float_new((double)csr);
  rblapack_snl = rb_float_new((double)snl);
  rblapack_csl = rb_float_new((double)csl);
  return rb_ary_new3(6, rblapack_ssmin, rblapack_ssmax, rblapack_snr, rblapack_csr, rblapack_snl, rblapack_csl);
}

void
init_lapack_dlasv2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlasv2", rblapack_dlasv2, -1);
}
ruby-lapack-1.7.2/ext/clarzb.c0000644000175000017500000001546612502221024016012 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clarzb_(char* side, char* trans, char* direct, char* storev, integer* m, integer* n, integer* k, integer* l, complex* v, integer* ldv, complex* t, integer* ldt, complex* c, integer* ldc, complex* work, integer* ldwork);


static VALUE
rblapack_clarzb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_direct;
  char direct; 
  VALUE rblapack_storev;
  char storev; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_v;
  complex *v; 
  VALUE rblapack_t;
  complex *t; 
  VALUE rblapack_c;
  complex *c; 
  VALUE rblapack_c_out__;
  complex *c_out__;
  complex *work;

  integer ldv;
  integer nv;
  integer ldt;
  integer k;
  integer ldc;
  integer n;
  integer ldwork;

  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  c = NumRu::Lapack.clarzb( side, trans, direct, storev, m, l, v, t, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n*  Purpose\n*  =======\n*\n*  CLARZB applies a complex block reflector H or its transpose H**H\n*  to a complex distributed M-by-N  C from the left or the right.\n*\n*  Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply H or H' from the Left\n*          = 'R': apply H or H' from the Right\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': apply H (No transpose)\n*          = 'C': apply H' (Conjugate transpose)\n*\n*  DIRECT  (input) CHARACTER*1\n*          Indicates how H is formed from a product of elementary\n*          reflectors\n*          = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n*          = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n*  STOREV  (input) CHARACTER*1\n*          Indicates how the vectors which define the elementary\n*          reflectors are stored:\n*          = 'C': Columnwise                        (not supported yet)\n*          = 'R': Rowwise\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C.\n*\n*  K       (input) INTEGER\n*          The order of the matrix T (= the number of elementary\n*          reflectors whose product defines the block reflector).\n*\n*  L       (input) INTEGER\n*          The number of columns of the matrix V containing the\n*          meaningful part of the Householder reflectors.\n*          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n*  V       (input) COMPLEX array, dimension (LDV,NV).\n*          If STOREV = 'C', NV = K; if STOREV = 'R', NV = L.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V.\n*          If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K.\n*\n*  T       (input) COMPLEX array, dimension (LDT,K)\n*          The triangular K-by-K matrix T in the representation of the\n*          block reflector.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= K.\n*\n*  C       (input/output) COMPLEX array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by H*C or H'*C or C*H or C*H'.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) COMPLEX array, dimension (LDWORK,K)\n*\n*  LDWORK  (input) INTEGER\n*          The leading dimension of the array WORK.\n*          If SIDE = 'L', LDWORK >= max(1,N);\n*          if SIDE = 'R', LDWORK >= max(1,M).\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.clarzb( side, trans, direct, storev, m, l, v, t, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_direct = argv[2];
  rblapack_storev = argv[3];
  rblapack_m = argv[4];
  rblapack_l = argv[5];
  rblapack_v = argv[6];
  rblapack_t = argv[7];
  rblapack_c = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  direct = StringValueCStr(rblapack_direct)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (7th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  nv = NA_SHAPE1(rblapack_v);
  if (NA_TYPE(rblapack_v) != NA_SCOMPLEX)
    rblapack_v = na_change_type(rblapack_v, NA_SCOMPLEX);
  v = NA_PTR_TYPE(rblapack_v, complex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (9th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, complex*);
  trans = StringValueCStr(rblapack_trans)[0];
  l = NUM2INT(rblapack_l);
  ldwork = MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0;
  storev = StringValueCStr(rblapack_storev)[0];
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (8th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (8th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  k = NA_SHAPE1(rblapack_t);
  if (NA_TYPE(rblapack_t) != NA_SCOMPLEX)
    rblapack_t = na_change_type(rblapack_t, NA_SCOMPLEX);
  t = NA_PTR_TYPE(rblapack_t, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
  MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(complex, (ldwork)*(k));

  clarzb_(&side, &trans, &direct, &storev, &m, &n, &k, &l, v, &ldv, t, &ldt, c, &ldc, work, &ldwork);

  free(work);
  return rblapack_c;
}

void
init_lapack_clarzb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clarzb", rblapack_clarzb, -1);
}
ruby-lapack-1.7.2/ext/dlapmr.c0000644000175000017500000001042212502221024015777 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlapmr_(logical* forwrd, integer* m, integer* n, doublereal* x, integer* ldx, integer* k);


static VALUE
rblapack_dlapmr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_forwrd;
  logical forwrd; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_k;
  integer *k; 
  VALUE rblapack_x_out__;
  doublereal *x_out__;
  VALUE rblapack_k_out__;
  integer *k_out__;

  integer ldx;
  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  x, k = NumRu::Lapack.dlapmr( forwrd, x, k, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAPMR( FORWRD, M, N, X, LDX, K )\n\n*  Purpose\n*  =======\n*\n*  DLAPMR rearranges the rows of the M by N matrix X as specified\n*  by the permutation K(1),K(2),...,K(M) of the integers 1,...,M.\n*  If FORWRD = .TRUE.,  forward permutation:\n*\n*       X(K(I),*) is moved X(I,*) for I = 1,2,...,M.\n*\n*  If FORWRD = .FALSE., backward permutation:\n*\n*       X(I,*) is moved to X(K(I),*) for I = 1,2,...,M.\n*\n\n*  Arguments\n*  =========\n*\n*  FORWRD  (input) LOGICAL\n*          = .TRUE., forward permutation\n*          = .FALSE., backward permutation\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix X. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix X. N >= 0.\n*\n*  X       (input/output) DOUBLE PRECISION array, dimension (LDX,N)\n*          On entry, the M by N matrix X.\n*          On exit, X contains the permuted matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X, LDX >= MAX(1,M).\n*\n*  K       (input/output) INTEGER array, dimension (M)\n*          On entry, K contains the permutation vector. K is used as\n*          internal workspace, but reset to its original value on\n*          output.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, IN, J, JJ\n      DOUBLE PRECISION   TEMP\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, k = NumRu::Lapack.dlapmr( forwrd, x, k, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_forwrd = argv[0];
  rblapack_x = argv[1];
  rblapack_k = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  forwrd = (rblapack_forwrd == Qtrue);
  if (!NA_IsNArray(rblapack_k))
    rb_raise(rb_eArgError, "k (3th argument) must be NArray");
  if (NA_RANK(rblapack_k) != 1)
    rb_raise(rb_eArgError, "rank of k (3th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_k);
  if (NA_TYPE(rblapack_k) != NA_LINT)
    rblapack_k = na_change_type(rblapack_k, NA_LINT);
  k = NA_PTR_TYPE(rblapack_k, integer*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  n = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = n;
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_k_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  k_out__ = NA_PTR_TYPE(rblapack_k_out__, integer*);
  MEMCPY(k_out__, k, integer, NA_TOTAL(rblapack_k));
  rblapack_k = rblapack_k_out__;
  k = k_out__;

  dlapmr_(&forwrd, &m, &n, x, &ldx, k);

  return rb_ary_new3(2, rblapack_x, rblapack_k);
}

void
init_lapack_dlapmr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlapmr", rblapack_dlapmr, -1);
}
ruby-lapack-1.7.2/ext/ctptrs.c0000644000175000017500000001236212502221024016044 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctptrs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, complex* ap, complex* b, integer* ldb, integer* info);


static VALUE
rblapack_ctptrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.ctptrs( uplo, trans, diag, n, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTPTRS solves a triangular system of the form\n*\n*     A * X = B,  A**T * X = B,  or  A**H * X = B,\n*\n*  where A is a triangular matrix of order N stored in packed format,\n*  and B is an N-by-NRHS matrix.  A check is made to verify that A is\n*  nonsingular.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)\n*          The upper or lower triangular matrix A, packed columnwise in\n*          a linear array.  The j-th column of A is stored in the array\n*          AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, if INFO = 0, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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 A is zero,\n*                indicating that the matrix is singular and the\n*                solutions X have not been computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.ctptrs( uplo, trans, diag, n, ap, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_n = argv[3];
  rblapack_ap = argv[4];
  rblapack_b = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  trans = StringValueCStr(rblapack_trans)[0];
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  ctptrs_(&uplo, &trans, &diag, &n, &nrhs, ap, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_ctptrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctptrs", rblapack_ctptrs, -1);
}
ruby-lapack-1.7.2/ext/dsyevd.c0000644000175000017500000002067112502221015016025 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsyevd_(char* jobz, char* uplo, integer* n, doublereal* a, integer* lda, doublereal* w, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_dsyevd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  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  w, work, iwork, info, a = NumRu::Lapack.dsyevd( jobz, uplo, a, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSYEVD computes all eigenvalues and, optionally, eigenvectors of a\n*  real symmetric matrix A. If eigenvectors are desired, it uses a\n*  divide and conquer algorithm.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n*  Because of large use of BLAS of level 3, DSYEVD needs N**2 more\n*  workspace than DSYEVX.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of A contains the\n*          upper triangular part of the matrix A.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of A contains\n*          the lower triangular part of the matrix A.\n*          On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n*          orthonormal eigenvectors of the matrix A.\n*          If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n*          or the upper triangle (if UPLO='U') of A, including the\n*          diagonal, is destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  WORK    (workspace/output) DOUBLE PRECISION array,\n*                                         dimension (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*          If N <= 1,               LWORK must be at least 1.\n*          If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1.\n*          If JOBZ = 'V' and N > 1, LWORK must be at least\n*                                                1 + 6*N + 2*N**2.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal sizes of the WORK and IWORK\n*          arrays, returns these values as the first entries of the WORK\n*          and IWORK arrays, and no error message related to LWORK or\n*          LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.\n*          If N <= 1,                LIWORK must be at least 1.\n*          If JOBZ  = 'N' and N > 1, LIWORK must be at least 1.\n*          If JOBZ  = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK and IWORK arrays, and no error message related to\n*          LWORK or LIWORK 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 and JOBZ = 'N', then the algorithm failed\n*                to converge; i off-diagonal elements of an intermediate\n*                tridiagonal form did not converge to zero;\n*                if INFO = i and JOBZ = 'V', then the algorithm failed\n*                to compute an eigenvalue while working on the submatrix\n*                lying in rows and columns INFO/(N+1) through\n*                mod(INFO,N+1).\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Jeff Rutter, Computer Science Division, University of California\n*     at Berkeley, USA\n*  Modified by Francoise Tisseur, University of Tennessee.\n*\n*  Modified description of INFO. Sven, 16 Feb 05.\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, work, iwork, info, a = NumRu::Lapack.dsyevd( jobz, uplo, a, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  if (argc == 5) {
    rblapack_lwork = argv[3];
    rblapack_liwork = argv[4];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  if (rblapack_liwork == Qnil)
    liwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (rblapack_lwork == Qnil)
    lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 2*n+1 : lsame_(&jobz,"V") ? 1+6*n+2*n*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t 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__;

  dsyevd_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, iwork, &liwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_w, rblapack_work, rblapack_iwork, rblapack_info, rblapack_a);
}

void
init_lapack_dsyevd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsyevd", rblapack_dsyevd, -1);
}
ruby-lapack-1.7.2/ext/slaqtr.c0000644000175000017500000001520412502221022016027 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaqtr_(logical* ltran, logical* lreal, integer* n, real* t, integer* ldt, real* b, real* w, real* scale, real* x, real* work, integer* info);


static VALUE
rblapack_slaqtr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ltran;
  logical ltran; 
  VALUE rblapack_lreal;
  logical lreal; 
  VALUE rblapack_t;
  real *t; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_w;
  real w; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_scale;
  real scale; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  real *x_out__;
  real *work;

  integer ldt;
  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  scale, info, x = NumRu::Lapack.slaqtr( ltran, lreal, t, b, w, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLAQTR solves the real quasi-triangular system\n*\n*               op(T)*p = scale*c,               if LREAL = .TRUE.\n*\n*  or the complex quasi-triangular systems\n*\n*             op(T + iB)*(p+iq) = scale*(c+id),  if LREAL = .FALSE.\n*\n*  in real arithmetic, where T is upper quasi-triangular.\n*  If LREAL = .FALSE., then the first diagonal block of T must be\n*  1 by 1, B is the specially structured matrix\n*\n*                 B = [ b(1) b(2) ... b(n) ]\n*                     [       w            ]\n*                     [           w        ]\n*                     [              .     ]\n*                     [                 w  ]\n*\n*  op(A) = A or A', A' denotes the conjugate transpose of\n*  matrix A.\n*\n*  On input, X = [ c ].  On output, X = [ p ].\n*                [ d ]                  [ q ]\n*\n*  This subroutine is designed for the condition number estimation\n*  in routine STRSNA.\n*\n\n*  Arguments\n*  =========\n*\n*  LTRAN   (input) LOGICAL\n*          On entry, LTRAN specifies the option of conjugate transpose:\n*             = .FALSE.,    op(T+i*B) = T+i*B,\n*             = .TRUE.,     op(T+i*B) = (T+i*B)'.\n*\n*  LREAL   (input) LOGICAL\n*          On entry, LREAL specifies the input matrix structure:\n*             = .FALSE.,    the input is complex\n*             = .TRUE.,     the input is real\n*\n*  N       (input) INTEGER\n*          On entry, N specifies the order of T+i*B. N >= 0.\n*\n*  T       (input) REAL array, dimension (LDT,N)\n*          On entry, T contains a matrix in Schur canonical form.\n*          If LREAL = .FALSE., then the first diagonal block of T must\n*          be 1 by 1.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the matrix T. LDT >= max(1,N).\n*\n*  B       (input) REAL array, dimension (N)\n*          On entry, B contains the elements to form the matrix\n*          B as described above.\n*          If LREAL = .TRUE., B is not referenced.\n*\n*  W       (input) REAL\n*          On entry, W is the diagonal element of the matrix B.\n*          If LREAL = .TRUE., W is not referenced.\n*\n*  SCALE   (output) REAL\n*          On exit, SCALE is the scale factor.\n*\n*  X       (input/output) REAL array, dimension (2*N)\n*          On entry, X contains the right hand side of the system.\n*          On exit, X is overwritten by the solution.\n*\n*  WORK    (workspace) REAL array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          On exit, INFO is set to\n*             0: successful exit.\n*               1: the some diagonal 1 by 1 block has been perturbed by\n*                  a small number SMIN to keep nonsingularity.\n*               2: the some diagonal 2 by 2 block has been perturbed by\n*                  a small number in SLALN2 to keep nonsingularity.\n*          NOTE: In the interests of speed, this routine does not\n*                check the inputs for errors.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, info, x = NumRu::Lapack.slaqtr( ltran, lreal, t, b, w, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_ltran = argv[0];
  rblapack_lreal = argv[1];
  rblapack_t = argv[2];
  rblapack_b = argv[3];
  rblapack_w = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  ltran = (rblapack_ltran == Qtrue);
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (3th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (3th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  n = NA_SHAPE1(rblapack_t);
  if (NA_TYPE(rblapack_t) != NA_SFLOAT)
    rblapack_t = na_change_type(rblapack_t, NA_SFLOAT);
  t = NA_PTR_TYPE(rblapack_t, real*);
  w = (real)NUM2DBL(rblapack_w);
  lreal = (rblapack_lreal == Qtrue);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 1)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of b must be the same as shape 1 of t");
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 2*n);
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[1];
    shape[0] = 2*n;
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(real, (n));

  slaqtr_(<ran, &lreal, &n, t, &ldt, b, &w, &scale, x, work, &info);

  free(work);
  rblapack_scale = rb_float_new((double)scale);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_scale, rblapack_info, rblapack_x);
}

void
init_lapack_slaqtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaqtr", rblapack_slaqtr, -1);
}
ruby-lapack-1.7.2/ext/dgbtf2.c0000644000175000017500000001316712502221025015702 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgbtf2_(integer* m, integer* n, integer* kl, integer* ku, doublereal* ab, integer* ldab, integer* ipiv, integer* info);


static VALUE
rblapack_dgbtf2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublereal *ab_out__;

  integer ldab;
  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  ipiv, info, ab = NumRu::Lapack.dgbtf2( m, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGBTF2 computes an LU factorization of a real m-by-n band matrix A\n*  using partial pivoting with row interchanges.\n*\n*  This is the unblocked version of the algorithm, calling Level 2 BLAS.\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*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n*          On entry, the matrix A in band storage, in rows KL+1 to\n*          2*KL+KU+1; rows 1 to KL of the array need not be set.\n*          The j-th column of A is stored in the j-th column of the\n*          array AB as follows:\n*          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n*          On exit, details of the factorization: U is stored as an\n*          upper triangular band matrix with KL+KU superdiagonals in\n*          rows 1 to KL+KU+1, and the multipliers used during the\n*          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n*          See below for further details.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.\n*\n*  IPIV    (output) INTEGER array, dimension (min(M,N))\n*          The pivot indices; for 1 <= i <= min(M,N), row i of the\n*          matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n*               has been completed, but the factor U is exactly\n*               singular, and division by zero will occur if it is used\n*               to solve a system of equations.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  M = N = 6, KL = 2, KU = 1:\n*\n*  On entry:                       On exit:\n*\n*      *    *    *    +    +    +       *    *    *   u14  u25  u36\n*      *    *    +    +    +    +       *    *   u13  u24  u35  u46\n*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56\n*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66\n*     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *\n*     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *\n*\n*  Array elements marked * are not used by the routine; elements marked\n*  + need not be set on entry, but are required by the routine to store\n*  elements of U, because of fill-in resulting from the row\n*  interchanges.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, ab = NumRu::Lapack.dgbtf2( m, kl, ku, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_m = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  ku = NUM2INT(rblapack_ku);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
  MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  dgbtf2_(&m, &n, &kl, &ku, ab, &ldab, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_ab);
}

void
init_lapack_dgbtf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgbtf2", rblapack_dgbtf2, -1);
}
ruby-lapack-1.7.2/ext/clanht.c0000644000175000017500000000736512502221016016006 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real clanht_(char* norm, integer* n, real* d, complex* e);


static VALUE
rblapack_clanht(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  complex *e; 
  VALUE rblapack___out__;
  real __out__; 

  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  __out__ = NumRu::Lapack.clanht( norm, d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL             FUNCTION CLANHT( NORM, N, D, E )\n\n*  Purpose\n*  =======\n*\n*  CLANHT  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  complex Hermitian tridiagonal matrix A.\n*\n*  Description\n*  ===========\n*\n*  CLANHT returns the value\n*\n*     CLANHT = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in CLANHT as described\n*          above.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, CLANHT is\n*          set to zero.\n*\n*  D       (input) REAL array, dimension (N)\n*          The diagonal elements of A.\n*\n*  E       (input) COMPLEX array, dimension (N-1)\n*          The (n-1) sub-diagonal or super-diagonal elements of A.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.clanht( norm, d, e, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_norm = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SCOMPLEX)
    rblapack_e = na_change_type(rblapack_e, NA_SCOMPLEX);
  e = NA_PTR_TYPE(rblapack_e, complex*);

  __out__ = clanht_(&norm, &n, d, e);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_clanht(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clanht", rblapack_clanht, -1);
}
ruby-lapack-1.7.2/ext/cgetrf.c0000644000175000017500000001015112502221014015770 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgetrf_(integer* m, integer* n, complex* a, integer* lda, integer* ipiv, integer* info);


static VALUE
rblapack_cgetrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *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  ipiv, info, a = NumRu::Lapack.cgetrf( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGETRF( M, N, A, LDA, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGETRF computes an LU factorization of a general M-by-N matrix A\n*  using partial pivoting with row interchanges.\n*\n*  The factorization has the form\n*     A = P * L * U\n*  where P is a permutation matrix, L is lower triangular with unit\n*  diagonal elements (lower trapezoidal if m > n), and U is upper\n*  triangular (upper trapezoidal if m < n).\n*\n*  This is the right-looking Level 3 BLAS version of the algorithm.\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) COMPLEX array, dimension (LDA,N)\n*          On entry, the M-by-N matrix to be factored.\n*          On exit, the factors L and U from the factorization\n*          A = P*L*U; the unit diagonal elements of L are not stored.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  IPIV    (output) INTEGER array, dimension (min(M,N))\n*          The pivot indices; for 1 <= i <= min(M,N), row i of the\n*          matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n*                has been completed, but the factor U is exactly\n*                singular, and division by zero will occur if it is used\n*                to solve a system of equations.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, a = NumRu::Lapack.cgetrf( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  cgetrf_(&m, &n, a, &lda, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_a);
}

void
init_lapack_cgetrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgetrf", rblapack_cgetrf, -1);
}
ruby-lapack-1.7.2/ext/dlapy3.c0000644000175000017500000000372112502221013015716 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal dlapy3_(doublereal* x, doublereal* y, doublereal* z);


static VALUE
rblapack_dlapy3(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_x;
  doublereal x; 
  VALUE rblapack_y;
  doublereal y; 
  VALUE rblapack_z;
  doublereal z; 
  VALUE rblapack___out__;
  doublereal __out__; 


  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  __out__ = NumRu::Lapack.dlapy3( x, y, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z )\n\n*  Purpose\n*  =======\n*\n*  DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause\n*  unnecessary overflow.\n*\n\n*  Arguments\n*  =========\n*\n*  X       (input) DOUBLE PRECISION\n*  Y       (input) DOUBLE PRECISION\n*  Z       (input) DOUBLE PRECISION\n*          X, Y and Z specify the values x, y and z.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.dlapy3( x, y, z, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_x = argv[0];
  rblapack_y = argv[1];
  rblapack_z = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  x = NUM2DBL(rblapack_x);
  z = NUM2DBL(rblapack_z);
  y = NUM2DBL(rblapack_y);

  __out__ = dlapy3_(&x, &y, &z);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_dlapy3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlapy3", rblapack_dlapy3, -1);
}
ruby-lapack-1.7.2/ext/ctrttf.c0000644000175000017500000001713712502221021016035 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctrttf_(char* transr, char* uplo, integer* n, complex* a, integer* lda, doublecomplex* arf, integer* info);


static VALUE
rblapack_ctrttf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_arf;
  doublecomplex *arf; 
  VALUE rblapack_info;
  integer info; 

  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  arf, info = NumRu::Lapack.ctrttf( transr, uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTRTTF copies a triangular matrix A from standard full format (TR)\n*  to rectangular full packed format (TF) .\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR   (input) CHARACTER*1\n*          = 'N':  ARF in Normal mode is wanted;\n*          = 'C':  ARF in Conjugate Transpose mode is wanted;\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) COMPLEX array, dimension ( LDA, N ) \n*          On entry, the triangular matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of the array A contains\n*          the upper triangular matrix, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of the array A contains\n*          the lower triangular matrix, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the matrix A.  LDA >= max(1,N).\n*\n*  ARF     (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n*          On exit, the upper or lower triangular matrix A stored in\n*          RFP format. For a further discussion see Notes below.\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*  We first consider Standard Packed Format when N is even.\n*  We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = `N'. RFP holds AP as follows:\n*  For UPLO = `U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  conjugate-transpose of the first three columns of AP upper.\n*  For UPLO = `L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  conjugate-transpose of the last three columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N even and TRANSR = `N'.\n*\n*         RFP A                   RFP A\n*\n*                                -- -- --\n*        03 04 05                33 43 53\n*                                   -- --\n*        13 14 15                00 44 54\n*                                      --\n*        23 24 25                10 11 55\n*\n*        33 34 35                20 21 22\n*        --\n*        00 44 45                30 31 32\n*        -- --\n*        01 11 55                40 41 42\n*        -- -- --\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = `C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- -- --                -- -- -- -- -- --\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     -- -- -- -- --                -- -- -- -- --\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     -- -- -- -- -- --                -- -- -- --\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We next  consider Standard Packed Format when N is odd.\n*  We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = `N'. RFP holds AP as follows:\n*  For UPLO = `U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  conjugate-transpose of the first two   columns of AP upper.\n*  For UPLO = `L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  conjugate-transpose of the last two   columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N odd  and TRANSR = `N'.\n*\n*         RFP A                   RFP A\n*\n*                                   -- --\n*        02 03 04                00 33 43\n*                                      --\n*        12 13 14                10 11 44\n*\n*        22 23 24                20 21 22\n*        --\n*        00 33 34                30 31 32\n*        -- --\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = `C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- --                   -- -- -- -- -- --\n*     02 12 22 00 01             00 10 20 30 40 50\n*     -- -- -- --                   -- -- -- -- --\n*     03 13 23 33 11             33 11 21 31 41 51\n*     -- -- -- -- --                   -- -- -- --\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  arf, info = NumRu::Lapack.ctrttf( transr, uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  {
    na_shape_t shape[1];
    shape[0] = ( n*(n+1)/2 );
    rblapack_arf = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  arf = NA_PTR_TYPE(rblapack_arf, doublecomplex*);

  ctrttf_(&transr, &uplo, &n, a, &lda, arf, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_arf, rblapack_info);
}

void
init_lapack_ctrttf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctrttf", rblapack_ctrttf, -1);
}
ruby-lapack-1.7.2/ext/sgelqf.c0000644000175000017500000001324312502221026016007 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgelqf_(integer* m, integer* n, real* a, integer* lda, real* tau, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sgelqf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *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.sgelqf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGELQF 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) REAL 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) REAL array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace/output) REAL 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           SGELQ2, SLARFB, SLARFT, 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.sgelqf( 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;
  }

  m = NUM2INT(rblapack_m);
  if (rblapack_lwork == Qnil)
    lwork = m;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  sgelqf_(&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_sgelqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgelqf", rblapack_sgelqf, -1);
}
ruby-lapack-1.7.2/ext/sgbequ.c0000644000175000017500000001315712502221024016016 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgbequ_(integer* m, integer* n, integer* kl, integer* ku, real* ab, integer* ldab, real* r, real* c, real* rowcnd, real* colcnd, real* amax, integer* info);


static VALUE
rblapack_sgbequ(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_r;
  real *r; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_rowcnd;
  real rowcnd; 
  VALUE rblapack_colcnd;
  real colcnd; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_info;
  integer info; 

  integer ldab;
  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  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.sgbequ( m, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGBEQU computes row and column scalings intended to equilibrate an\n*  M-by-N band matrix A and reduce its condition number.  R returns the\n*  row scale factors and C the column scale factors, chosen to try to\n*  make the largest element in each row and column of the matrix B with\n*  elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.\n*\n*  R(i) and C(j) are restricted to be between SMLNUM = smallest safe\n*  number and BIGNUM = largest safe number.  Use of these scaling\n*  factors is not guaranteed to reduce the condition number of A but\n*  works well in practice.\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*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  AB      (input) REAL array, dimension (LDAB,N)\n*          The band matrix A, stored in rows 1 to KL+KU+1.  The j-th\n*          column of A is stored in the j-th column of the array AB as\n*          follows:\n*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*  R       (output) REAL array, dimension (M)\n*          If INFO = 0, or INFO > M, R contains the row scale factors\n*          for A.\n*\n*  C       (output) REAL array, dimension (N)\n*          If INFO = 0, C contains the column scale factors for A.\n*\n*  ROWCND  (output) REAL\n*          If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n*          smallest R(i) to the largest R(i).  If ROWCND >= 0.1 and\n*          AMAX is neither too large nor too small, it is not worth\n*          scaling by R.\n*\n*  COLCND  (output) REAL\n*          If INFO = 0, COLCND contains the ratio of the smallest\n*          C(i) to the largest C(i).  If COLCND >= 0.1, it is not\n*          worth scaling by C.\n*\n*  AMAX    (output) REAL\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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, and i is\n*                <= M:  the i-th row of A is exactly zero\n*                >  M:  the (i-M)-th column of A is exactly zero\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.sgbequ( m, kl, ku, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_m = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  ku = NUM2INT(rblapack_ku);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,m);
    rblapack_r = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  r = NA_PTR_TYPE(rblapack_r, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  c = NA_PTR_TYPE(rblapack_c, real*);

  sgbequ_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &info);

  rblapack_rowcnd = rb_float_new((double)rowcnd);
  rblapack_colcnd = rb_float_new((double)colcnd);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
}

void
init_lapack_sgbequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgbequ", rblapack_sgbequ, -1);
}
ruby-lapack-1.7.2/ext/dgelqf.c0000644000175000017500000001341712502221020015765 0ustar  uwabamiuwabami#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;
  }

  m = NUM2INT(rblapack_m);
  if (rblapack_lwork == Qnil)
    lwork = m;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  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*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgelqf", rblapack_dgelqf, -1);
}
ruby-lapack-1.7.2/ext/slahr2.c0000644000175000017500000001544112502221016015722 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slahr2_(integer* n, integer* k, integer* nb, real* a, integer* lda, real* tau, real* t, integer* ldt, real* y, integer* ldy);


static VALUE
rblapack_slahr2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_nb;
  integer nb; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_t;
  real *t; 
  VALUE rblapack_y;
  real *y; 
  VALUE rblapack_a_out__;
  real *a_out__;

  integer lda;
  integer ldt;
  integer ldy;

  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, t, y, a = NumRu::Lapack.slahr2( n, k, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n*  Purpose\n*  =======\n*\n*  SLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1)\n*  matrix A so that elements below the k-th subdiagonal are zero. The\n*  reduction is performed by an orthogonal similarity transformation\n*  Q' * A * Q. The routine returns the matrices V and T which determine\n*  Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n*\n*  This is an auxiliary routine called by SGEHRD.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.\n*\n*  K       (input) INTEGER\n*          The offset for the reduction. Elements below the k-th\n*          subdiagonal in the first NB columns are reduced to zero.\n*          K < N.\n*\n*  NB      (input) INTEGER\n*          The number of columns to be reduced.\n*\n*  A       (input/output) REAL array, dimension (LDA,N-K+1)\n*          On entry, the n-by-(n-k+1) general matrix A.\n*          On exit, the elements on and above the k-th subdiagonal in\n*          the first NB columns are overwritten with the corresponding\n*          elements of the reduced matrix; the elements below the k-th\n*          subdiagonal, with the array TAU, represent the matrix Q as a\n*          product of elementary reflectors. The other columns of A are\n*          unchanged. See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  TAU     (output) REAL array, dimension (NB)\n*          The scalar factors of the elementary reflectors. See Further\n*          Details.\n*\n*  T       (output) REAL array, dimension (LDT,NB)\n*          The upper triangular matrix T.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T.  LDT >= NB.\n*\n*  Y       (output) REAL array, dimension (LDY,NB)\n*          The n-by-nb matrix Y.\n*\n*  LDY     (input) INTEGER\n*          The leading dimension of the array Y. LDY >= N.\n*\n\n*  Further Details\n*  ===============\n*\n*  The matrix Q is represented as a product of nb elementary reflectors\n*\n*     Q = H(1) H(2) . . . H(nb).\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+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n*  A(i+k+1:n,i), and tau in TAU(i).\n*\n*  The elements of the vectors v together form the (n-k+1)-by-nb matrix\n*  V which is needed, with T and Y, to apply the transformation to the\n*  unreduced part of the matrix, using an update of the form:\n*  A := (I - V*T*V') * (A - Y*V').\n*\n*  The contents of A on exit are illustrated by the following example\n*  with n = 7, k = 3 and nb = 2:\n*\n*     ( a   a   a   a   a )\n*     ( a   a   a   a   a )\n*     ( a   a   a   a   a )\n*     ( h   h   a   a   a )\n*     ( v1  h   a   a   a )\n*     ( v1  v2  a   a   a )\n*     ( v1  v2  a   a   a )\n*\n*  where a denotes an element of the original matrix A, h denotes a\n*  modified element of the upper Hessenberg matrix H, and vi denotes an\n*  element of the vector defining H(i).\n*\n*  This subroutine is a slight modification of LAPACK-3.0's DLAHRD\n*  incorporating improvements proposed by Quintana-Orti and Van de\n*  Gejin. Note that the entries of A(1:K,2:NB) differ from those\n*  returned by the original LAPACK-3.0's DLAHRD routine. (This\n*  subroutine is not backward compatible with LAPACK-3.0's DLAHRD.)\n*\n*  References\n*  ==========\n*\n*  Gregorio Quintana-Orti and Robert van de Geijn, \"Improving the\n*  performance of reduction to Hessenberg form,\" ACM Transactions on\n*  Mathematical Software, 32(2):180-194, June 2006.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, t, y, a = NumRu::Lapack.slahr2( n, k, nb, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_n = argv[0];
  rblapack_k = argv[1];
  rblapack_nb = argv[2];
  rblapack_a = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  nb = NUM2INT(rblapack_nb);
  ldy = n;
  k = NUM2INT(rblapack_k);
  ldt = nb;
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != (n-k+1))
    rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", n-k+1);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,nb);
    rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = MAX(1,nb);
    rblapack_t = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  t = NA_PTR_TYPE(rblapack_t, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldy;
    shape[1] = MAX(1,nb);
    rblapack_y = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  y = NA_PTR_TYPE(rblapack_y, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n-k+1;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  slahr2_(&n, &k, &nb, a, &lda, tau, t, &ldt, y, &ldy);

  return rb_ary_new3(4, rblapack_tau, rblapack_t, rblapack_y, rblapack_a);
}

void
init_lapack_slahr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slahr2", rblapack_slahr2, -1);
}
ruby-lapack-1.7.2/ext/dsptrd.c0000644000175000017500000001375012502221012016024 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsptrd_(char* uplo, integer* n, doublereal* ap, doublereal* d, doublereal* e, doublereal* tau, integer* info);


static VALUE
rblapack_dsptrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublereal *ap_out__;

  integer ldap;
  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  d, e, tau, info, ap = NumRu::Lapack.dsptrd( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSPTRD( UPLO, N, AP, D, E, TAU, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSPTRD reduces a real symmetric matrix A stored in packed form to\n*  symmetric tridiagonal form T by an orthogonal similarity\n*  transformation: Q**T * A * Q = T.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*          On exit, if UPLO = 'U', the diagonal and first superdiagonal\n*          of A are overwritten by the corresponding elements of the\n*          tridiagonal matrix T, and the elements above the first\n*          superdiagonal, with the array TAU, represent the orthogonal\n*          matrix Q as a product of elementary reflectors; if UPLO\n*          = 'L', the diagonal and first subdiagonal of A are over-\n*          written by the corresponding elements of the tridiagonal\n*          matrix T, and the elements below the first subdiagonal, with\n*          the array TAU, represent the orthogonal matrix Q as a product\n*          of elementary reflectors. See Further Details.\n*\n*  D       (output) DOUBLE PRECISION array, dimension (N)\n*          The diagonal elements of the tridiagonal matrix T:\n*          D(i) = A(i,i).\n*\n*  E       (output) DOUBLE PRECISION array, dimension (N-1)\n*          The off-diagonal elements of the tridiagonal matrix T:\n*          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n*  TAU     (output) DOUBLE PRECISION array, dimension (N-1)\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\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*  If UPLO = 'U', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(n-1) . . . H(2) H(1).\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(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,\n*  overwriting A(1:i-1,i+1), and tau is stored in TAU(i).\n*\n*  If UPLO = 'L', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(1) H(2) . . . H(n-1).\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) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,\n*  overwriting A(i+2:n,i), and tau is stored in TAU(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, tau, info, ap = NumRu::Lapack.dsptrd( uplo, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
  MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  dsptrd_(&uplo, &n, ap, d, e, tau, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_d, rblapack_e, rblapack_tau, rblapack_info, rblapack_ap);
}

void
init_lapack_dsptrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsptrd", rblapack_dsptrd, -1);
}
ruby-lapack-1.7.2/ext/sggbak.c0000644000175000017500000001466312502221025015772 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sggbak_(char* job, char* side, integer* n, integer* ilo, integer* ihi, real* lscale, real* rscale, integer* m, real* v, integer* ldv, integer* info);


static VALUE
rblapack_sggbak(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_lscale;
  real *lscale; 
  VALUE rblapack_rscale;
  real *rscale; 
  VALUE rblapack_v;
  real *v; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_v_out__;
  real *v_out__;

  integer n;
  integer ldv;
  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  info, v = NumRu::Lapack.sggbak( job, side, ilo, ihi, lscale, rscale, v, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGGBAK forms the right or left eigenvectors of a real generalized\n*  eigenvalue problem A*x = lambda*B*x, by backward transformation on\n*  the computed eigenvectors of the balanced pair of matrices output by\n*  SGGBAL.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies the type of backward transformation required:\n*          = 'N':  do nothing, return immediately;\n*          = 'P':  do backward transformation for permutation only;\n*          = 'S':  do backward transformation for scaling only;\n*          = 'B':  do backward transformations for both permutation and\n*                  scaling.\n*          JOB must be the same as the argument JOB supplied to SGGBAL.\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'R':  V contains right eigenvectors;\n*          = 'L':  V contains left eigenvectors.\n*\n*  N       (input) INTEGER\n*          The number of rows of the matrix V.  N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          The integers ILO and IHI determined by SGGBAL.\n*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n*  LSCALE  (input) REAL array, dimension (N)\n*          Details of the permutations and/or scaling factors applied\n*          to the left side of A and B, as returned by SGGBAL.\n*\n*  RSCALE  (input) REAL array, dimension (N)\n*          Details of the permutations and/or scaling factors applied\n*          to the right side of A and B, as returned by SGGBAL.\n*\n*  M       (input) INTEGER\n*          The number of columns of the matrix V.  M >= 0.\n*\n*  V       (input/output) REAL array, dimension (LDV,M)\n*          On entry, the matrix of right or left eigenvectors to be\n*          transformed, as returned by STGEVC.\n*          On exit, V is overwritten by the transformed eigenvectors.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the matrix V. LDV >= max(1,N).\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*  See R.C. Ward, Balancing the generalized eigenvalue problem,\n*                 SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LEFTV, RIGHTV\n      INTEGER            I, K\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SSCAL, SSWAP, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, v = NumRu::Lapack.sggbak( job, side, ilo, ihi, lscale, rscale, v, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_job = argv[0];
  rblapack_side = argv[1];
  rblapack_ilo = argv[2];
  rblapack_ihi = argv[3];
  rblapack_lscale = argv[4];
  rblapack_rscale = argv[5];
  rblapack_v = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  job = StringValueCStr(rblapack_job)[0];
  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_lscale))
    rb_raise(rb_eArgError, "lscale (5th argument) must be NArray");
  if (NA_RANK(rblapack_lscale) != 1)
    rb_raise(rb_eArgError, "rank of lscale (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_lscale);
  if (NA_TYPE(rblapack_lscale) != NA_SFLOAT)
    rblapack_lscale = na_change_type(rblapack_lscale, NA_SFLOAT);
  lscale = NA_PTR_TYPE(rblapack_lscale, real*);
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (7th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  m = NA_SHAPE1(rblapack_v);
  if (NA_TYPE(rblapack_v) != NA_SFLOAT)
    rblapack_v = na_change_type(rblapack_v, NA_SFLOAT);
  v = NA_PTR_TYPE(rblapack_v, real*);
  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_rscale))
    rb_raise(rb_eArgError, "rscale (6th argument) must be NArray");
  if (NA_RANK(rblapack_rscale) != 1)
    rb_raise(rb_eArgError, "rank of rscale (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_rscale) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of rscale must be the same as shape 0 of lscale");
  if (NA_TYPE(rblapack_rscale) != NA_SFLOAT)
    rblapack_rscale = na_change_type(rblapack_rscale, NA_SFLOAT);
  rscale = NA_PTR_TYPE(rblapack_rscale, real*);
  ihi = NUM2INT(rblapack_ihi);
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = m;
    rblapack_v_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  v_out__ = NA_PTR_TYPE(rblapack_v_out__, real*);
  MEMCPY(v_out__, v, real, NA_TOTAL(rblapack_v));
  rblapack_v = rblapack_v_out__;
  v = v_out__;

  sggbak_(&job, &side, &n, &ilo, &ihi, lscale, rscale, &m, v, &ldv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_v);
}

void
init_lapack_sggbak(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sggbak", rblapack_sggbak, -1);
}
ruby-lapack-1.7.2/ext/spocon.c0000644000175000017500000000760112502221022016024 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID spocon_(char* uplo, integer* n, real* a, integer* lda, real* anorm, real* rcond, real* work, integer* iwork, integer* info);


static VALUE
rblapack_spocon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_anorm;
  real anorm; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_info;
  integer info; 
  real *work;
  integer *iwork;

  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  rcond, info = NumRu::Lapack.spocon( uplo, a, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPOCON estimates the reciprocal of the condition number (in the \n*  1-norm) of a real symmetric positive definite matrix using the\n*  Cholesky factorization A = U**T*U or A = L*L**T computed by SPOTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) REAL array, dimension (LDA,N)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**T*U or A = L*L**T, as computed by SPOTRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  ANORM   (input) REAL\n*          The 1-norm (or infinity-norm) of the symmetric matrix A.\n*\n*  RCOND   (output) REAL\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n*          estimate of the 1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) REAL array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.spocon( uplo, a, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_anorm = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  anorm = (real)NUM2DBL(rblapack_anorm);
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  work = ALLOC_N(real, (3*n));
  iwork = ALLOC_N(integer, (n));

  spocon_(&uplo, &n, a, &lda, &anorm, &rcond, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_spocon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "spocon", rblapack_spocon, -1);
}
ruby-lapack-1.7.2/ext/sgelsd.c0000644000175000017500000002350012502221016016003 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgelsd_(integer* m, integer* n, integer* nrhs, real* a, integer* lda, real* b, integer* ldb, real* s, real* rcond, integer* rank, real* work, integer* lwork, integer* iwork, integer* info);


static VALUE
rblapack_sgelsd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_rank;
  integer rank; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  real *b_out__;
  integer *iwork;

  integer lda;
  integer n;
  integer m;
  integer nrhs;
  integer ldb;
  integer c__9;
  integer c__0;
  integer liwork;
  integer nlvl;
  integer smlsiz;

  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  s, rank, work, info, b = NumRu::Lapack.sgelsd( a, b, rcond, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGELSD computes the minimum-norm solution to a real linear least\n*  squares problem:\n*      minimize 2-norm(| b - A*x |)\n*  using the singular value decomposition (SVD) of A. A is an M-by-N\n*  matrix which may be rank-deficient.\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*  The problem is solved in three steps:\n*  (1) Reduce the coefficient matrix A to bidiagonal form with\n*      Householder transformations, reducing the original problem\n*      into a \"bidiagonal least squares problem\" (BLS)\n*  (2) Solve the BLS using a divide and conquer approach.\n*  (3) Apply back all the Householder tranformations to solve\n*      the original least squares problem.\n*\n*  The effective rank of A is determined by treating as zero those\n*  singular values which are less than RCOND times the largest singular\n*  value.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of A. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of A. N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X. NRHS >= 0.\n*\n*  A       (input) REAL array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, A has been destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the M-by-NRHS right hand side matrix B.\n*          On exit, B is overwritten by the N-by-NRHS solution\n*          matrix X.  If m >= n and RANK = n, the residual\n*          sum-of-squares for the solution in the i-th column is given\n*          by the sum of squares of elements n+1:m in that column.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,max(M,N)).\n*\n*  S       (output) REAL array, dimension (min(M,N))\n*          The singular values of A in decreasing order.\n*          The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n*\n*  RCOND   (input) REAL\n*          RCOND is used to determine the effective rank of A.\n*          Singular values S(i) <= RCOND*S(1) are treated as zero.\n*          If RCOND < 0, machine precision is used instead.\n*\n*  RANK    (output) INTEGER\n*          The effective rank of A, i.e., the number of singular values\n*          which are greater than RCOND*S(1).\n*\n*  WORK    (workspace/output) REAL 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 must be at least 1.\n*          The exact minimum amount of workspace needed depends on M,\n*          N and NRHS. As long as LWORK is at least\n*              12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2,\n*          if M is greater than or equal to N or\n*              12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2,\n*          if M is less than N, the code will execute correctly.\n*          SMLSIZ is returned by ILAENV and is equal to the maximum\n*          size of the subproblems at the bottom of the computation\n*          tree (usually about 25), and\n*             NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )\n*          For good performance, LWORK should generally be larger.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal size of the array WORK and the\n*          minimum size of the array IWORK, and returns these values as\n*          the first entries of the WORK and IWORK arrays, and no error\n*          message related to LWORK is issued by XERBLA.\n*\n*  IWORK   (workspace) INTEGER array, dimension (MAX(1,LIWORK))\n*          LIWORK >= max(1, 3*MINMN*NLVL + 11*MINMN),\n*          where MINMN = MIN( M,N ).\n*          On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          > 0:  the algorithm for computing the SVD failed to converge;\n*                if INFO = i, i off-diagonal elements of an intermediate\n*                bidiagonal form did not converge to zero.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Ren-Cang Li, Computer Science Division, University of\n*       California at Berkeley, USA\n*     Osni Marques, LBNL/NERSC, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, rank, work, info, b = NumRu::Lapack.sgelsd( a, b, rcond, [: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_a = argv[0];
  rblapack_b = argv[1];
  rblapack_rcond = 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 (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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  rcond = (real)NUM2DBL(rblapack_rcond);
  m = lda;
  c__9 = 9;
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th 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_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  ldb = MAX(m,n);
  c__0 = 0;
  smlsiz = ilaenv_(&c__9,"SGELSD"," ",&c__0,&c__0,&c__0,&c__0);
  nlvl = MAX(0,((int)(log(((double)(MIN(m,n)))/(smlsiz+1))/log(2.0))+1));
  if (rblapack_lwork == Qnil)
    lwork = m>=n ? 12*n + 2*n*smlsiz + 8*n*nlvl + n*nrhs + (smlsiz+1)*(smlsiz+1) : 12*m + 2*m*smlsiz + 8*m*nlvl + m*nrhs + (smlsiz+1)*(smlsiz+1);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  liwork = 3*(MIN(m,n))*nlvl+11*(MIN(m,n));
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = MAX(m, n);
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  {
    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__;
  iwork = ALLOC_N(integer, (MAX(1,liwork)));

  sgelsd_(&m, &n, &nrhs, a, &lda, b, &ldb, s, &rcond, &rank, work, &lwork, iwork, &info);

  free(iwork);
  rblapack_rank = INT2NUM(rank);
  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(5, rblapack_s, rblapack_rank, rblapack_work, rblapack_info, rblapack_b);
}

void
init_lapack_sgelsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgelsd", rblapack_sgelsd, -1);
}
ruby-lapack-1.7.2/ext/zlacgv.c0000644000175000017500000000567612502221022016023 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlacgv_(integer* n, doublecomplex* x, integer* incx);


static VALUE
rblapack_zlacgv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;


  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  x = NumRu::Lapack.zlacgv( n, x, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLACGV( N, X, INCX )\n\n*  Purpose\n*  =======\n*\n*  ZLACGV conjugates a complex vector of length N.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The length of the vector X.  N >= 0.\n*\n*  X       (input/output) COMPLEX*16 array, dimension\n*                         (1+(N-1)*abs(INCX))\n*          On entry, the vector of length N to be conjugated.\n*          On exit, X is overwritten with conjg(X).\n*\n*  INCX    (input) INTEGER\n*          The spacing between successive elements of X.\n*\n\n* =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, IOFF\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          DCONJG\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x = NumRu::Lapack.zlacgv( n, x, incx, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_n = argv[0];
  rblapack_x = argv[1];
  rblapack_incx = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  incx = NUM2INT(rblapack_incx);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1+(n-1)*abs(incx)))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*abs(incx));
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*abs(incx);
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;

  zlacgv_(&n, x, &incx);

  return rblapack_x;
}

void
init_lapack_zlacgv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlacgv", rblapack_zlacgv, -1);
}
ruby-lapack-1.7.2/ext/zgesdd.c0000644000175000017500000002424212502221020016001 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgesdd_(char* jobz, integer* m, integer* n, doublecomplex* a, integer* lda, doublereal* s, doublecomplex* u, integer* ldu, doublecomplex* vt, integer* ldvt, doublecomplex* work, integer* lwork, doublereal* rwork, integer* iwork, integer* info);


static VALUE
rblapack_zgesdd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_u;
  doublecomplex *u; 
  VALUE rblapack_vt;
  doublecomplex *vt; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  doublereal *rwork;
  integer *iwork;

  integer lda;
  integer n;
  integer ldu;
  integer ucol;
  integer ldvt;
  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  s, u, vt, work, info, a = NumRu::Lapack.zgesdd( jobz, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGESDD computes the singular value decomposition (SVD) of a complex\n*  M-by-N matrix A, optionally computing the left and/or right singular\n*  vectors, by using divide-and-conquer method. The SVD is written\n*\n*       A = U * SIGMA * conjugate-transpose(V)\n*\n*  where SIGMA is an M-by-N matrix which is zero except for its\n*  min(m,n) diagonal elements, U is an M-by-M unitary matrix, and\n*  V is an N-by-N unitary matrix.  The diagonal elements of SIGMA\n*  are the singular values of A; they are real and non-negative, and\n*  are returned in descending order.  The first min(m,n) columns of\n*  U and V are the left and right singular vectors of A.\n*\n*  Note that the routine returns VT = V**H, not V.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          Specifies options for computing all or part of the matrix U:\n*          = 'A':  all M columns of U and all N rows of V**H are\n*                  returned in the arrays U and VT;\n*          = 'S':  the first min(M,N) columns of U and the first\n*                  min(M,N) rows of V**H are returned in the arrays U\n*                  and VT;\n*          = 'O':  If M >= N, the first N columns of U are overwritten\n*                  in the array A and all rows of V**H are returned in\n*                  the array VT;\n*                  otherwise, all columns of U are returned in the\n*                  array U and the first M rows of V**H are overwritten\n*                  in the array A;\n*          = 'N':  no columns of U or rows of V**H are computed.\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.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit,\n*          if JOBZ = 'O',  A is overwritten with the first N columns\n*                          of U (the left singular vectors, stored\n*                          columnwise) if M >= N;\n*                          A is overwritten with the first M rows\n*                          of V**H (the right singular vectors, stored\n*                          rowwise) otherwise.\n*          if JOBZ .ne. 'O', the contents of A are destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  S       (output) DOUBLE PRECISION array, dimension (min(M,N))\n*          The singular values of A, sorted so that S(i) >= S(i+1).\n*\n*  U       (output) COMPLEX*16 array, dimension (LDU,UCOL)\n*          UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;\n*          UCOL = min(M,N) if JOBZ = 'S'.\n*          If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M\n*          unitary matrix U;\n*          if JOBZ = 'S', U contains the first min(M,N) columns of U\n*          (the left singular vectors, stored columnwise);\n*          if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.\n*\n*  LDU     (input) INTEGER\n*          The leading dimension of the array U.  LDU >= 1; if\n*          JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.\n*\n*  VT      (output) COMPLEX*16 array, dimension (LDVT,N)\n*          If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the\n*          N-by-N unitary matrix V**H;\n*          if JOBZ = 'S', VT contains the first min(M,N) rows of\n*          V**H (the right singular vectors, stored rowwise);\n*          if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.\n*\n*  LDVT    (input) INTEGER\n*          The leading dimension of the array VT.  LDVT >= 1; if\n*          JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;\n*          if JOBZ = 'S', LDVT >= min(M,N).\n*\n*  WORK    (workspace/output) COMPLEX*16 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 >= 1.\n*          if JOBZ = 'N', LWORK >= 2*min(M,N)+max(M,N).\n*          if JOBZ = 'O',\n*                LWORK >= 2*min(M,N)*min(M,N)+2*min(M,N)+max(M,N).\n*          if JOBZ = 'S' or 'A',\n*                LWORK >= min(M,N)*min(M,N)+2*min(M,N)+max(M,N).\n*          For good performance, LWORK should generally be larger.\n*\n*          If LWORK = -1, a workspace query is assumed.  The optimal\n*          size for the WORK array is calculated and stored in WORK(1),\n*          and no other work except argument checking is performed.\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))\n*          If JOBZ = 'N', LRWORK >= 5*min(M,N).\n*          Otherwise,\n*          LRWORK >= min(M,N)*max(5*min(M,N)+7,2*max(M,N)+2*min(M,N)+1)\n*\n*  IWORK   (workspace) INTEGER array, dimension (8*min(M,N))\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit.\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          > 0:  The updating process of DBDSDC did not converge.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, u, vt, work, info, a = NumRu::Lapack.zgesdd( jobz, 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_jobz = 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;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  m = lda;
  ldvt = ((lsame_(&jobz,"A")) || (((lsame_(&jobz,"O")) && (m >= n)))) ? n : lsame_(&jobz,"S") ? MIN(m,n) : 1;
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&jobz,"N") ? 2*MIN(m,n)+MAX(m,n) : lsame_(&jobz,"O") ? 2*MIN(m,n)*MIN(m,n)+2*MIN(m,n)+MAX(m,n) : (lsame_(&jobz,"S")||lsame_(&jobz,"A")) ? MIN(m,n)*MIN(m,n)+2*MIN(m,n)+MAX(m,n) : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldu = (lsame_(&jobz,"S") || lsame_(&jobz,"A") || (lsame_(&jobz,"O") && m < n)) ? m : 1;
  ucol = ((lsame_(&jobz,"A")) || (((lsame_(&jobz,"O")) && (m < n)))) ? m : lsame_(&jobz,"S") ? MIN(m,n) : 0;
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = ucol;
    rblapack_u = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  u = NA_PTR_TYPE(rblapack_u, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvt;
    shape[1] = n;
    rblapack_vt = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  vt = NA_PTR_TYPE(rblapack_vt, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  rwork = ALLOC_N(doublereal, (MAX(1, (lsame_(&jobz,"N") ? 5*MIN(m,n) : MIN(m,n)*MAX(5*MIN(m,n)+7,2*MAX(m,n)+2*MIN(m,n)+1)))));
  iwork = ALLOC_N(integer, (8*MIN(m,n)));

  zgesdd_(&jobz, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, rwork, iwork, &info);

  free(rwork);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_s, rblapack_u, rblapack_vt, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_zgesdd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgesdd", rblapack_zgesdd, -1);
}
ruby-lapack-1.7.2/ext/zlarf.c0000644000175000017500000001173712502221013015646 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlarf_(char* side, integer* m, integer* n, doublecomplex* v, integer* incv, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work);


static VALUE
rblapack_zlarf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_v;
  doublecomplex *v; 
  VALUE rblapack_incv;
  integer incv; 
  VALUE rblapack_tau;
  doublecomplex tau; 
  VALUE rblapack_c;
  doublecomplex *c; 
  VALUE rblapack_c_out__;
  doublecomplex *c_out__;
  doublecomplex *work;

  integer ldc;
  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  c = NumRu::Lapack.zlarf( side, m, v, incv, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )\n\n*  Purpose\n*  =======\n*\n*  ZLARF applies a complex elementary reflector H to a complex M-by-N\n*  matrix C, from either the left or the right. H is represented in the\n*  form\n*\n*        H = I - tau * v * v'\n*\n*  where tau is a complex scalar and v is a complex vector.\n*\n*  If tau = 0, then H is taken to be the unit matrix.\n*\n*  To apply H' (the conjugate transpose of H), supply conjg(tau) instead\n*  tau.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': form  H * C\n*          = 'R': form  C * H\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C.\n*\n*  V       (input) COMPLEX*16 array, dimension\n*                     (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n*                  or (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n*          The vector v in the representation of H. V is not used if\n*          TAU = 0.\n*\n*  INCV    (input) INTEGER\n*          The increment between elements of v. INCV <> 0.\n*\n*  TAU     (input) COMPLEX*16\n*          The value tau in the representation of H.\n*\n*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n*          or C * H if SIDE = 'R'.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension\n*                         (N) if SIDE = 'L'\n*                      or (M) if SIDE = 'R'\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.zlarf( side, m, v, incv, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_m = argv[1];
  rblapack_v = argv[2];
  rblapack_incv = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  incv = NUM2INT(rblapack_incv);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
  m = NUM2INT(rblapack_m);
  tau.r = NUM2DBL(rb_funcall(rblapack_tau, rb_intern("real"), 0));
  tau.i = NUM2DBL(rb_funcall(rblapack_tau, rb_intern("imag"), 0));
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (3th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 1)
    rb_raise(rb_eArgError, "rank of v (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_v) != (1 + (m-1)*abs(incv)))
    rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1 + (m-1)*abs(incv));
  if (NA_TYPE(rblapack_v) != NA_DCOMPLEX)
    rblapack_v = na_change_type(rblapack_v, NA_DCOMPLEX);
  v = NA_PTR_TYPE(rblapack_v, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
  MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(doublecomplex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  zlarf_(&side, &m, &n, v, &incv, &tau, c, &ldc, work);

  free(work);
  return rblapack_c;
}

void
init_lapack_zlarf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlarf", rblapack_zlarf, -1);
}
ruby-lapack-1.7.2/ext/slalsa.c0000644000175000017500000004031712502221025016006 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slalsa_(integer* icompq, integer* smlsiz, integer* n, integer* nrhs, real* b, integer* ldb, real* bx, integer* ldbx, real* u, integer* ldu, real* vt, integer* k, real* difl, real* difr, real* z, real* poles, integer* givptr, integer* givcol, integer* ldgcol, integer* perm, real* givnum, real* c, real* s, real* work, integer* iwork, integer* info);


static VALUE
rblapack_slalsa(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_icompq;
  integer icompq; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_u;
  real *u; 
  VALUE rblapack_vt;
  real *vt; 
  VALUE rblapack_k;
  integer *k; 
  VALUE rblapack_difl;
  real *difl; 
  VALUE rblapack_difr;
  real *difr; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_poles;
  real *poles; 
  VALUE rblapack_givptr;
  integer *givptr; 
  VALUE rblapack_givcol;
  integer *givcol; 
  VALUE rblapack_perm;
  integer *perm; 
  VALUE rblapack_givnum;
  real *givnum; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_bx;
  real *bx; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  real *b_out__;
  real *work;
  integer *iwork;

  integer ldb;
  integer nrhs;
  integer ldu;
  integer smlsiz;
  integer n;
  integer nlvl;
  integer ldgcol;
  integer ldbx;

  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  bx, info, b = NumRu::Lapack.slalsa( icompq, b, u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLALSA is an itermediate step in solving the least squares problem\n*  by computing the SVD of the coefficient matrix in compact form (The\n*  singular vectors are computed as products of simple orthorgonal\n*  matrices.).\n*\n*  If ICOMPQ = 0, SLALSA applies the inverse of the left singular vector\n*  matrix of an upper bidiagonal matrix to the right hand side; and if\n*  ICOMPQ = 1, SLALSA applies the right singular vector matrix to the\n*  right hand side. The singular vector matrices were generated in\n*  compact form by SLALSA.\n*\n\n*  Arguments\n*  =========\n*\n*\n*  ICOMPQ (input) INTEGER\n*         Specifies whether the left or the right singular vector\n*         matrix is involved.\n*         = 0: Left singular vector matrix\n*         = 1: Right singular vector matrix\n*\n*  SMLSIZ (input) INTEGER\n*         The maximum size of the subproblems at the bottom of the\n*         computation tree.\n*\n*  N      (input) INTEGER\n*         The row and column dimensions of the upper bidiagonal matrix.\n*\n*  NRHS   (input) INTEGER\n*         The number of columns of B and BX. NRHS must be at least 1.\n*\n*  B      (input/output) REAL array, dimension ( LDB, NRHS )\n*         On input, B contains the right hand sides of the least\n*         squares problem in rows 1 through M.\n*         On output, B contains the solution X in rows 1 through N.\n*\n*  LDB    (input) INTEGER\n*         The leading dimension of B in the calling subprogram.\n*         LDB must be at least max(1,MAX( M, N ) ).\n*\n*  BX     (output) REAL array, dimension ( LDBX, NRHS )\n*         On exit, the result of applying the left or right singular\n*         vector matrix to B.\n*\n*  LDBX   (input) INTEGER\n*         The leading dimension of BX.\n*\n*  U      (input) REAL array, dimension ( LDU, SMLSIZ ).\n*         On entry, U contains the left singular vector matrices of all\n*         subproblems at the bottom level.\n*\n*  LDU    (input) INTEGER, LDU = > N.\n*         The leading dimension of arrays U, VT, DIFL, DIFR,\n*         POLES, GIVNUM, and Z.\n*\n*  VT     (input) REAL array, dimension ( LDU, SMLSIZ+1 ).\n*         On entry, VT' contains the right singular vector matrices of\n*         all subproblems at the bottom level.\n*\n*  K      (input) INTEGER array, dimension ( N ).\n*\n*  DIFL   (input) REAL array, dimension ( LDU, NLVL ).\n*         where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.\n*\n*  DIFR   (input) REAL array, dimension ( LDU, 2 * NLVL ).\n*         On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record\n*         distances between singular values on the I-th level and\n*         singular values on the (I -1)-th level, and DIFR(*, 2 * I)\n*         record the normalizing factors of the right singular vectors\n*         matrices of subproblems on I-th level.\n*\n*  Z      (input) REAL array, dimension ( LDU, NLVL ).\n*         On entry, Z(1, I) contains the components of the deflation-\n*         adjusted updating row vector for subproblems on the I-th\n*         level.\n*\n*  POLES  (input) REAL array, dimension ( LDU, 2 * NLVL ).\n*         On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old\n*         singular values involved in the secular equations on the I-th\n*         level.\n*\n*  GIVPTR (input) INTEGER array, dimension ( N ).\n*         On entry, GIVPTR( I ) records the number of Givens\n*         rotations performed on the I-th problem on the computation\n*         tree.\n*\n*  GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ).\n*         On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the\n*         locations of Givens rotations performed on the I-th level on\n*         the computation tree.\n*\n*  LDGCOL (input) INTEGER, LDGCOL = > N.\n*         The leading dimension of arrays GIVCOL and PERM.\n*\n*  PERM   (input) INTEGER array, dimension ( LDGCOL, NLVL ).\n*         On entry, PERM(*, I) records permutations done on the I-th\n*         level of the computation tree.\n*\n*  GIVNUM (input) REAL array, dimension ( LDU, 2 * NLVL ).\n*         On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-\n*         values of Givens rotations performed on the I-th level on the\n*         computation tree.\n*\n*  C      (input) REAL array, dimension ( N ).\n*         On entry, if the I-th subproblem is not square,\n*         C( I ) contains the C-value of a Givens rotation related to\n*         the right null space of the I-th subproblem.\n*\n*  S      (input) REAL array, dimension ( N ).\n*         On entry, if the I-th subproblem is not square,\n*         S( I ) contains the S-value of a Givens rotation related to\n*         the right null space of the I-th subproblem.\n*\n*  WORK   (workspace) REAL array.\n*         The dimension must be at least N.\n*\n*  IWORK  (workspace) INTEGER array.\n*         The dimension must be at least 3 * N\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*  Based on contributions by\n*     Ming Gu and Ren-Cang Li, Computer Science Division, University of\n*       California at Berkeley, USA\n*     Osni Marques, LBNL/NERSC, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  bx, info, b = NumRu::Lapack.slalsa( icompq, b, u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 15 && argc != 15)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
  rblapack_icompq = argv[0];
  rblapack_b = argv[1];
  rblapack_u = argv[2];
  rblapack_vt = argv[3];
  rblapack_k = argv[4];
  rblapack_difl = argv[5];
  rblapack_difr = argv[6];
  rblapack_z = argv[7];
  rblapack_poles = argv[8];
  rblapack_givptr = argv[9];
  rblapack_givcol = argv[10];
  rblapack_perm = argv[11];
  rblapack_givnum = argv[12];
  rblapack_c = argv[13];
  rblapack_s = argv[14];
  if (argc == 15) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  icompq = NUM2INT(rblapack_icompq);
  if (!NA_IsNArray(rblapack_u))
    rb_raise(rb_eArgError, "u (3th argument) must be NArray");
  if (NA_RANK(rblapack_u) != 2)
    rb_raise(rb_eArgError, "rank of u (3th argument) must be %d", 2);
  ldu = NA_SHAPE0(rblapack_u);
  smlsiz = NA_SHAPE1(rblapack_u);
  if (NA_TYPE(rblapack_u) != NA_SFLOAT)
    rblapack_u = na_change_type(rblapack_u, NA_SFLOAT);
  u = NA_PTR_TYPE(rblapack_u, real*);
  if (!NA_IsNArray(rblapack_k))
    rb_raise(rb_eArgError, "k (5th argument) must be NArray");
  if (NA_RANK(rblapack_k) != 1)
    rb_raise(rb_eArgError, "rank of k (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_k);
  if (NA_TYPE(rblapack_k) != NA_LINT)
    rblapack_k = na_change_type(rblapack_k, NA_LINT);
  k = NA_PTR_TYPE(rblapack_k, integer*);
  if (!NA_IsNArray(rblapack_givptr))
    rb_raise(rb_eArgError, "givptr (10th argument) must be NArray");
  if (NA_RANK(rblapack_givptr) != 1)
    rb_raise(rb_eArgError, "rank of givptr (10th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_givptr) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of givptr must be the same as shape 0 of k");
  if (NA_TYPE(rblapack_givptr) != NA_LINT)
    rblapack_givptr = na_change_type(rblapack_givptr, NA_LINT);
  givptr = NA_PTR_TYPE(rblapack_givptr, integer*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (14th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (14th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of k");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (15th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (15th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 0 of k");
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  nlvl = (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1;
  if (!NA_IsNArray(rblapack_vt))
    rb_raise(rb_eArgError, "vt (4th argument) must be NArray");
  if (NA_RANK(rblapack_vt) != 2)
    rb_raise(rb_eArgError, "rank of vt (4th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_vt) != ldu)
    rb_raise(rb_eRuntimeError, "shape 0 of vt must be the same as shape 0 of u");
  if (NA_SHAPE1(rblapack_vt) != (smlsiz+1))
    rb_raise(rb_eRuntimeError, "shape 1 of vt must be %d", smlsiz+1);
  if (NA_TYPE(rblapack_vt) != NA_SFLOAT)
    rblapack_vt = na_change_type(rblapack_vt, NA_SFLOAT);
  vt = NA_PTR_TYPE(rblapack_vt, real*);
  if (!NA_IsNArray(rblapack_difr))
    rb_raise(rb_eArgError, "difr (7th argument) must be NArray");
  if (NA_RANK(rblapack_difr) != 2)
    rb_raise(rb_eArgError, "rank of difr (7th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_difr) != ldu)
    rb_raise(rb_eRuntimeError, "shape 0 of difr must be the same as shape 0 of u");
  if (NA_SHAPE1(rblapack_difr) != (2 * nlvl))
    rb_raise(rb_eRuntimeError, "shape 1 of difr must be %d", 2 * nlvl);
  if (NA_TYPE(rblapack_difr) != NA_SFLOAT)
    rblapack_difr = na_change_type(rblapack_difr, NA_SFLOAT);
  difr = NA_PTR_TYPE(rblapack_difr, real*);
  if (!NA_IsNArray(rblapack_poles))
    rb_raise(rb_eArgError, "poles (9th argument) must be NArray");
  if (NA_RANK(rblapack_poles) != 2)
    rb_raise(rb_eArgError, "rank of poles (9th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_poles) != ldu)
    rb_raise(rb_eRuntimeError, "shape 0 of poles must be the same as shape 0 of u");
  if (NA_SHAPE1(rblapack_poles) != (2 * nlvl))
    rb_raise(rb_eRuntimeError, "shape 1 of poles must be %d", 2 * nlvl);
  if (NA_TYPE(rblapack_poles) != NA_SFLOAT)
    rblapack_poles = na_change_type(rblapack_poles, NA_SFLOAT);
  poles = NA_PTR_TYPE(rblapack_poles, real*);
  if (!NA_IsNArray(rblapack_perm))
    rb_raise(rb_eArgError, "perm (12th argument) must be NArray");
  if (NA_RANK(rblapack_perm) != 2)
    rb_raise(rb_eArgError, "rank of perm (12th argument) must be %d", 2);
  ldgcol = NA_SHAPE0(rblapack_perm);
  if (NA_SHAPE1(rblapack_perm) != nlvl)
    rb_raise(rb_eRuntimeError, "shape 1 of perm must be (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1");
  if (NA_TYPE(rblapack_perm) != NA_LINT)
    rblapack_perm = na_change_type(rblapack_perm, NA_LINT);
  perm = NA_PTR_TYPE(rblapack_perm, integer*);
  ldbx = n;
  if (!NA_IsNArray(rblapack_difl))
    rb_raise(rb_eArgError, "difl (6th argument) must be NArray");
  if (NA_RANK(rblapack_difl) != 2)
    rb_raise(rb_eArgError, "rank of difl (6th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_difl) != ldu)
    rb_raise(rb_eRuntimeError, "shape 0 of difl must be the same as shape 0 of u");
  if (NA_SHAPE1(rblapack_difl) != nlvl)
    rb_raise(rb_eRuntimeError, "shape 1 of difl must be (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1");
  if (NA_TYPE(rblapack_difl) != NA_SFLOAT)
    rblapack_difl = na_change_type(rblapack_difl, NA_SFLOAT);
  difl = NA_PTR_TYPE(rblapack_difl, real*);
  if (!NA_IsNArray(rblapack_givcol))
    rb_raise(rb_eArgError, "givcol (11th argument) must be NArray");
  if (NA_RANK(rblapack_givcol) != 2)
    rb_raise(rb_eArgError, "rank of givcol (11th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_givcol) != ldgcol)
    rb_raise(rb_eRuntimeError, "shape 0 of givcol must be the same as shape 0 of perm");
  if (NA_SHAPE1(rblapack_givcol) != (2 * nlvl))
    rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", 2 * nlvl);
  if (NA_TYPE(rblapack_givcol) != NA_LINT)
    rblapack_givcol = na_change_type(rblapack_givcol, NA_LINT);
  givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (8th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_z) != ldu)
    rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of u");
  if (NA_SHAPE1(rblapack_z) != nlvl)
    rb_raise(rb_eRuntimeError, "shape 1 of z must be (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1");
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  if (!NA_IsNArray(rblapack_givnum))
    rb_raise(rb_eArgError, "givnum (13th argument) must be NArray");
  if (NA_RANK(rblapack_givnum) != 2)
    rb_raise(rb_eArgError, "rank of givnum (13th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_givnum) != ldu)
    rb_raise(rb_eRuntimeError, "shape 0 of givnum must be the same as shape 0 of u");
  if (NA_SHAPE1(rblapack_givnum) != (2 * nlvl))
    rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", 2 * nlvl);
  if (NA_TYPE(rblapack_givnum) != NA_SFLOAT)
    rblapack_givnum = na_change_type(rblapack_givnum, NA_SFLOAT);
  givnum = NA_PTR_TYPE(rblapack_givnum, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldbx;
    shape[1] = nrhs;
    rblapack_bx = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  bx = NA_PTR_TYPE(rblapack_bx, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(real, (n));
  iwork = ALLOC_N(integer, (3 * n));

  slalsa_(&icompq, &smlsiz, &n, &nrhs, b, &ldb, bx, &ldbx, u, &ldu, vt, k, difl, difr, z, poles, givptr, givcol, &ldgcol, perm, givnum, c, s, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_bx, rblapack_info, rblapack_b);
}

void
init_lapack_slalsa(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slalsa", rblapack_slalsa, -1);
}
ruby-lapack-1.7.2/ext/dptts2.c0000644000175000017500000001110712502221023015740 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dptts2_(integer* n, integer* nrhs, doublereal* d, doublereal* e, doublereal* b, integer* ldb);


static VALUE
rblapack_dptts2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_b_out__;
  doublereal *b_out__;

  integer n;
  integer ldb;
  integer nrhs;

  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  b = NumRu::Lapack.dptts2( d, e, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPTTS2( N, NRHS, D, E, B, LDB )\n\n*  Purpose\n*  =======\n*\n*  DPTTS2 solves a tridiagonal system of the form\n*     A * X = B\n*  using the L*D*L' factorization of A computed by DPTTRF.  D is a\n*  diagonal matrix specified in the vector D, L is a unit bidiagonal\n*  matrix whose subdiagonal is specified in the vector E, and X and B\n*  are N by NRHS matrices.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the tridiagonal matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          The n diagonal elements of the diagonal matrix D from the\n*          L*D*L' factorization of A.\n*\n*  E       (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (n-1) subdiagonal elements of the unit bidiagonal factor\n*          L from the L*D*L' factorization of A.  E can also be regarded\n*          as the superdiagonal of the unit bidiagonal factor U from the\n*          factorization A = U'*D*U.\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the right hand side vectors B for the system of\n*          linear equations.\n*          On exit, the solution vectors, X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DSCAL\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  b = NumRu::Lapack.dptts2( d, e, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_d = argv[0];
  rblapack_e = argv[1];
  rblapack_b = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  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);
  ldb = NA_SHAPE0(rblapack_b);
  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 (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (2th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dptts2_(&n, &nrhs, d, e, b, &ldb);

  return rblapack_b;
}

void
init_lapack_dptts2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dptts2", rblapack_dptts2, -1);
}
ruby-lapack-1.7.2/ext/sstevx.c0000644000175000017500000002331512502221022016057 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sstevx_(char* jobz, char* range, integer* n, real* d, real* e, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, real* z, integer* ldz, real* work, integer* iwork, integer* ifail, integer* info);


static VALUE
rblapack_sstevx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_vl;
  real vl; 
  VALUE rblapack_vu;
  real vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  real abstol; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_ifail;
  integer *ifail; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_e_out__;
  real *e_out__;
  real *work;
  integer *iwork;

  integer n;
  integer ldz;

  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  m, w, z, ifail, info, d, e = NumRu::Lapack.sstevx( jobz, range, d, e, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSTEVX computes selected eigenvalues and, optionally, eigenvectors\n*  of a real symmetric tridiagonal matrix A.  Eigenvalues and\n*  eigenvectors can be selected by specifying either a range of values\n*  or a range of indices for the desired eigenvalues.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found.\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found.\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  D       (input/output) REAL array, dimension (N)\n*          On entry, the n diagonal elements of the tridiagonal matrix\n*          A.\n*          On exit, D may be multiplied by a constant factor chosen\n*          to avoid over/underflow in computing the eigenvalues.\n*\n*  E       (input/output) REAL array, dimension (max(1,N-1))\n*          On entry, the (n-1) subdiagonal elements of the tridiagonal\n*          matrix A in elements 1 to N-1 of E.\n*          On exit, E may be multiplied by a constant factor chosen\n*          to avoid over/underflow in computing the eigenvalues.\n*\n*  VL      (input) REAL\n*  VU      (input) REAL\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) REAL\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less\n*          than or equal to zero, then  EPS*|T|  will be used in\n*          its place, where |T| is the 1-norm of the tridiagonal\n*          matrix.\n*\n*          Eigenvalues will be computed most accurately when ABSTOL is\n*          set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n*          If this routine returns with INFO>0, indicating that some\n*          eigenvectors did not converge, try setting ABSTOL to\n*          2*SLAMCH('S').\n*\n*          See \"Computing Small Singular Values of Bidiagonal Matrices\n*          with Guaranteed High Relative Accuracy,\" by Demmel and\n*          Kahan, LAPACK Working Note #3.\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) REAL array, dimension (N)\n*          The first M elements contain the selected eigenvalues in\n*          ascending order.\n*\n*  Z       (output) REAL array, dimension (LDZ, max(1,M) )\n*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix A\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          If an eigenvector fails to converge (INFO > 0), then that\n*          column of Z contains the latest approximation to the\n*          eigenvector, and the index of the eigenvector is returned\n*          in IFAIL.  If JOBZ = 'N', then Z is not referenced.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace) REAL array, dimension (5*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (5*N)\n*\n*  IFAIL   (output) INTEGER array, dimension (N)\n*          If JOBZ = 'V', then if INFO = 0, the first M elements of\n*          IFAIL are zero.  If INFO > 0, then IFAIL contains the\n*          indices of the eigenvectors that failed to converge.\n*          If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n*                Their indices are stored in array IFAIL.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, ifail, info, d, e = NumRu::Lapack.sstevx( jobz, range, d, e, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_d = argv[2];
  rblapack_e = argv[3];
  rblapack_vl = argv[4];
  rblapack_vu = argv[5];
  rblapack_il = argv[6];
  rblapack_iu = argv[7];
  rblapack_abstol = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  vl = (real)NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  abstol = (real)NUM2DBL(rblapack_abstol);
  m = n;
  range = StringValueCStr(rblapack_range)[0];
  vu = (real)NUM2DBL(rblapack_vu);
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (4th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (MAX(1,n-1)))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", MAX(1,n-1));
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  iu = NUM2INT(rblapack_iu);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,n-1);
    rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
  MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  work = ALLOC_N(real, (5*n));
  iwork = ALLOC_N(integer, (5*n));

  sstevx_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, iwork, ifail, &info);

  free(work);
  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_d, rblapack_e);
}

void
init_lapack_sstevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sstevx", rblapack_sstevx, -1);
}
ruby-lapack-1.7.2/ext/dlasd8.c0000644000175000017500000002247612502221013015711 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlasd8_(integer* icompq, integer* k, doublereal* d, doublereal* z, doublereal* vf, doublereal* vl, doublereal* difl, doublereal* difr, integer* lddifr, doublereal* dsigma, doublereal* work, integer* info);


static VALUE
rblapack_dlasd8(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_icompq;
  integer icompq; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_vf;
  doublereal *vf; 
  VALUE rblapack_vl;
  doublereal *vl; 
  VALUE rblapack_dsigma;
  doublereal *dsigma; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_difl;
  doublereal *difl; 
  VALUE rblapack_difr;
  doublereal *difr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_z_out__;
  doublereal *z_out__;
  VALUE rblapack_vf_out__;
  doublereal *vf_out__;
  VALUE rblapack_vl_out__;
  doublereal *vl_out__;
  VALUE rblapack_dsigma_out__;
  doublereal *dsigma_out__;
  doublereal *work;

  integer k;
  integer lddifr;

  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  d, difl, difr, info, z, vf, vl, dsigma = NumRu::Lapack.dlasd8( icompq, z, vf, vl, dsigma, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, DSIGMA, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLASD8 finds the square roots of the roots of the secular equation,\n*  as defined by the values in DSIGMA and Z. It makes the appropriate\n*  calls to DLASD4, and stores, for each  element in D, the distance\n*  to its two nearest poles (elements in DSIGMA). It also updates\n*  the arrays VF and VL, the first and last components of all the\n*  right singular vectors of the original bidiagonal matrix.\n*\n*  DLASD8 is called from DLASD6.\n*\n\n*  Arguments\n*  =========\n*\n*  ICOMPQ  (input) INTEGER\n*          Specifies whether singular vectors are to be computed in\n*          factored form in the calling routine:\n*          = 0: Compute singular values only.\n*          = 1: Compute singular vectors in factored form as well.\n*\n*  K       (input) INTEGER\n*          The number of terms in the rational function to be solved\n*          by DLASD4.  K >= 1.\n*\n*  D       (output) DOUBLE PRECISION array, dimension ( K )\n*          On output, D contains the updated singular values.\n*\n*  Z       (input/output) DOUBLE PRECISION array, dimension ( K )\n*          On entry, the first K elements of this array contain the\n*          components of the deflation-adjusted updating row vector.\n*          On exit, Z is updated.\n*\n*  VF      (input/output) DOUBLE PRECISION array, dimension ( K )\n*          On entry, VF contains  information passed through DBEDE8.\n*          On exit, VF contains the first K components of the first\n*          components of all right singular vectors of the bidiagonal\n*          matrix.\n*\n*  VL      (input/output) DOUBLE PRECISION array, dimension ( K )\n*          On entry, VL contains  information passed through DBEDE8.\n*          On exit, VL contains the first K components of the last\n*          components of all right singular vectors of the bidiagonal\n*          matrix.\n*\n*  DIFL    (output) DOUBLE PRECISION array, dimension ( K )\n*          On exit, DIFL(I) = D(I) - DSIGMA(I).\n*\n*  DIFR    (output) DOUBLE PRECISION array,\n*                   dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and\n*                   dimension ( K ) if ICOMPQ = 0.\n*          On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not\n*          defined and will not be referenced.\n*\n*          If ICOMPQ = 1, DIFR(1:K,2) is an array containing the\n*          normalizing factors for the right singular vector matrix.\n*\n*  LDDIFR  (input) INTEGER\n*          The leading dimension of DIFR, must be at least K.\n*\n*  DSIGMA  (input/output) DOUBLE PRECISION array, dimension ( K )\n*          On entry, the first K elements of this array contain the old\n*          roots of the deflated updating problem.  These are the poles\n*          of the secular equation.\n*          On exit, the elements of DSIGMA may be very slightly altered\n*          in value.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension at least 3 * K\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 = 1, a singular value did not converge\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, difl, difr, info, z, vf, vl, dsigma = NumRu::Lapack.dlasd8( icompq, z, vf, vl, dsigma, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_icompq = argv[0];
  rblapack_z = argv[1];
  rblapack_vf = argv[2];
  rblapack_vl = argv[3];
  rblapack_dsigma = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  icompq = NUM2INT(rblapack_icompq);
  if (!NA_IsNArray(rblapack_vf))
    rb_raise(rb_eArgError, "vf (3th argument) must be NArray");
  if (NA_RANK(rblapack_vf) != 1)
    rb_raise(rb_eArgError, "rank of vf (3th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_vf);
  if (NA_TYPE(rblapack_vf) != NA_DFLOAT)
    rblapack_vf = na_change_type(rblapack_vf, NA_DFLOAT);
  vf = NA_PTR_TYPE(rblapack_vf, doublereal*);
  if (!NA_IsNArray(rblapack_dsigma))
    rb_raise(rb_eArgError, "dsigma (5th argument) must be NArray");
  if (NA_RANK(rblapack_dsigma) != 1)
    rb_raise(rb_eArgError, "rank of dsigma (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dsigma) != k)
    rb_raise(rb_eRuntimeError, "shape 0 of dsigma must be the same as shape 0 of vf");
  if (NA_TYPE(rblapack_dsigma) != NA_DFLOAT)
    rblapack_dsigma = na_change_type(rblapack_dsigma, NA_DFLOAT);
  dsigma = NA_PTR_TYPE(rblapack_dsigma, doublereal*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (2th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != k)
    rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of vf");
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  if (!NA_IsNArray(rblapack_vl))
    rb_raise(rb_eArgError, "vl (4th argument) must be NArray");
  if (NA_RANK(rblapack_vl) != 1)
    rb_raise(rb_eArgError, "rank of vl (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_vl) != k)
    rb_raise(rb_eRuntimeError, "shape 0 of vl must be the same as shape 0 of vf");
  if (NA_TYPE(rblapack_vl) != NA_DFLOAT)
    rblapack_vl = na_change_type(rblapack_vl, NA_DFLOAT);
  vl = NA_PTR_TYPE(rblapack_vl, doublereal*);
  lddifr = k;
  {
    na_shape_t shape[1];
    shape[0] = k;
    rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = k;
    rblapack_difl = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  difl = NA_PTR_TYPE(rblapack_difl, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = icompq == 1 ? lddifr : icompq == 0 ? k : 0;
    shape[1] = icompq == 1 ? 2 : 0;
    rblapack_difr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  difr = NA_PTR_TYPE(rblapack_difr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = k;
    rblapack_z_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
  MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  {
    na_shape_t shape[1];
    shape[0] = k;
    rblapack_vf_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  vf_out__ = NA_PTR_TYPE(rblapack_vf_out__, doublereal*);
  MEMCPY(vf_out__, vf, doublereal, NA_TOTAL(rblapack_vf));
  rblapack_vf = rblapack_vf_out__;
  vf = vf_out__;
  {
    na_shape_t shape[1];
    shape[0] = k;
    rblapack_vl_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, doublereal*);
  MEMCPY(vl_out__, vl, doublereal, NA_TOTAL(rblapack_vl));
  rblapack_vl = rblapack_vl_out__;
  vl = vl_out__;
  {
    na_shape_t shape[1];
    shape[0] = k;
    rblapack_dsigma_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  dsigma_out__ = NA_PTR_TYPE(rblapack_dsigma_out__, doublereal*);
  MEMCPY(dsigma_out__, dsigma, doublereal, NA_TOTAL(rblapack_dsigma));
  rblapack_dsigma = rblapack_dsigma_out__;
  dsigma = dsigma_out__;
  work = ALLOC_N(doublereal, (3 * k));

  dlasd8_(&icompq, &k, d, z, vf, vl, difl, difr, &lddifr, dsigma, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_d, rblapack_difl, rblapack_difr, rblapack_info, rblapack_z, rblapack_vf, rblapack_vl, rblapack_dsigma);
}

void
init_lapack_dlasd8(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlasd8", rblapack_dlasd8, -1);
}
ruby-lapack-1.7.2/ext/cla_gercond_c.c0000644000175000017500000001704112502221022017264 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real cla_gercond_c_(char* trans, integer* n, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, real* c, logical* capply, integer* info, complex* work, real* rwork);


static VALUE
rblapack_cla_gercond_c(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_capply;
  logical capply; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_rwork;
  real *rwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack___out__;
  real __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  info, __out__ = NumRu::Lapack.cla_gercond_c( trans, a, af, ipiv, c, capply, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL FUNCTION CLA_GERCOND_C( TRANS, N, A, LDA, AF, LDAF, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n*  Purpose\n*  =======\n* \n*     CLA_GERCOND_C computes the infinity norm condition number of\n*     op(A) * inv(diag(C)) where C is a REAL vector.\n*\n\n*  Arguments\n*  =========\n*\n*     TRANS   (input) CHARACTER*1\n*     Specifies the form of the system of equations:\n*       = 'N':  A * X = B     (No transpose)\n*       = 'T':  A**T * X = B  (Transpose)\n*       = 'C':  A**H * X = B  (Conjugate Transpose = Transpose)\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     A       (input) COMPLEX array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX array, dimension (LDAF,N)\n*     The factors L and U from the factorization\n*     A = P*L*U as computed by CGETRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     The pivot indices from the factorization A = P*L*U\n*     as computed by CGETRF; row i of the matrix was interchanged\n*     with row IPIV(i).\n*\n*     C       (input) REAL array, dimension (N)\n*     The vector C in the formula op(A) * inv(diag(C)).\n*\n*     CAPPLY  (input) LOGICAL\n*     If .TRUE. then access the vector C in the formula above.\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit.\n*     i > 0:  The ith argument is invalid.\n*\n*     WORK    (input) COMPLEX array, dimension (2*N).\n*     Workspace.\n*\n*     RWORK   (input) REAL array, dimension (N).\n*     Workspace.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            NOTRANS\n      INTEGER            KASE, I, J\n      REAL               AINVNM, ANORM, TMP\n      COMPLEX            ZDUM\n*     ..\n*     .. Local Arrays ..\n      INTEGER            ISAVE( 3 )\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CLACN2, CGETRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX, REAL, AIMAG\n*     ..\n*     .. Statement Functions ..\n      REAL               CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, __out__ = NumRu::Lapack.cla_gercond_c( trans, a, af, ipiv, c, capply, work, rwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_trans = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_c = argv[4];
  rblapack_capply = argv[5];
  rblapack_work = argv[6];
  rblapack_rwork = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_rwork))
    rb_raise(rb_eArgError, "rwork (8th argument) must be NArray");
  if (NA_RANK(rblapack_rwork) != 1)
    rb_raise(rb_eArgError, "rank of rwork (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_rwork) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_rwork) != NA_SFLOAT)
    rblapack_rwork = na_change_type(rblapack_rwork, NA_SFLOAT);
  rwork = NA_PTR_TYPE(rblapack_rwork, real*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  capply = (rblapack_capply == Qtrue);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (7th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
  if (NA_TYPE(rblapack_work) != NA_SCOMPLEX)
    rblapack_work = na_change_type(rblapack_work, NA_SCOMPLEX);
  work = NA_PTR_TYPE(rblapack_work, complex*);

  __out__ = cla_gercond_c_(&trans, &n, a, &lda, af, &ldaf, ipiv, c, &capply, &info, work, rwork);

  rblapack_info = INT2NUM(info);
  rblapack___out__ = rb_float_new((double)__out__);
  return rb_ary_new3(2, rblapack_info, rblapack___out__);
}

void
init_lapack_cla_gercond_c(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cla_gercond_c", rblapack_cla_gercond_c, -1);
}
ruby-lapack-1.7.2/ext/dlaqr3.c0000644000175000017500000002713012502221016015713 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaqr3_(logical* wantt, logical* wantz, integer* n, integer* ktop, integer* kbot, integer* nw, doublereal* h, integer* ldh, integer* iloz, integer* ihiz, doublereal* z, integer* ldz, integer* ns, integer* nd, doublereal* sr, doublereal* si, doublereal* v, integer* ldv, integer* nh, doublereal* t, integer* ldt, integer* nv, doublereal* wv, integer* ldwv, doublereal* work, integer* lwork);


static VALUE
rblapack_dlaqr3(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantt;
  logical wantt; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_ktop;
  integer ktop; 
  VALUE rblapack_kbot;
  integer kbot; 
  VALUE rblapack_nw;
  integer nw; 
  VALUE rblapack_h;
  doublereal *h; 
  VALUE rblapack_iloz;
  integer iloz; 
  VALUE rblapack_ihiz;
  integer ihiz; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_nh;
  integer nh; 
  VALUE rblapack_nv;
  integer nv; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_ns;
  integer ns; 
  VALUE rblapack_nd;
  integer nd; 
  VALUE rblapack_sr;
  doublereal *sr; 
  VALUE rblapack_si;
  doublereal *si; 
  VALUE rblapack_h_out__;
  doublereal *h_out__;
  VALUE rblapack_z_out__;
  doublereal *z_out__;
  doublereal *v;
  doublereal *t;
  doublereal *wv;
  doublereal *work;

  integer ldh;
  integer n;
  integer ldz;
  integer ldv;
  integer ldt;
  integer ldwv;

  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  ns, nd, sr, si, h, z = NumRu::Lapack.dlaqr3( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n*     Aggressive early deflation:\n*\n*     This subroutine accepts as input an upper Hessenberg matrix\n*     H and performs an orthogonal similarity transformation\n*     designed to detect and deflate fully converged eigenvalues from\n*     a trailing principal submatrix.  On output H has been over-\n*     written by a new Hessenberg matrix that is a perturbation of\n*     an orthogonal similarity transformation of H.  It is to be\n*     hoped that the final version of H has many zero subdiagonal\n*     entries.\n*\n*     ******************************************************************\n\n*     WANTT   (input) LOGICAL\n*          If .TRUE., then the Hessenberg matrix H is fully updated\n*          so that the quasi-triangular Schur factor may be\n*          computed (in cooperation with the calling subroutine).\n*          If .FALSE., then only enough of H is updated to preserve\n*          the eigenvalues.\n*\n*     WANTZ   (input) LOGICAL\n*          If .TRUE., then the orthogonal matrix Z is updated so\n*          so that the orthogonal Schur factor may be computed\n*          (in cooperation with the calling subroutine).\n*          If .FALSE., then Z is not referenced.\n*\n*     N       (input) INTEGER\n*          The order of the matrix H and (if WANTZ is .TRUE.) the\n*          order of the orthogonal matrix Z.\n*\n*     KTOP    (input) INTEGER\n*          It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n*          KBOT and KTOP together determine an isolated block\n*          along the diagonal of the Hessenberg matrix.\n*\n*     KBOT    (input) INTEGER\n*          It is assumed without a check that either\n*          KBOT = N or H(KBOT+1,KBOT)=0.  KBOT and KTOP together\n*          determine an isolated block along the diagonal of the\n*          Hessenberg matrix.\n*\n*     NW      (input) INTEGER\n*          Deflation window size.  1 .LE. NW .LE. (KBOT-KTOP+1).\n*\n*     H       (input/output) DOUBLE PRECISION array, dimension (LDH,N)\n*          On input the initial N-by-N section of H stores the\n*          Hessenberg matrix undergoing aggressive early deflation.\n*          On output H has been transformed by an orthogonal\n*          similarity transformation, perturbed, and the returned\n*          to Hessenberg form that (it is to be hoped) has some\n*          zero subdiagonal entries.\n*\n*     LDH     (input) integer\n*          Leading dimension of H just as declared in the calling\n*          subroutine.  N .LE. LDH\n*\n*     ILOZ    (input) INTEGER\n*     IHIZ    (input) INTEGER\n*          Specify the rows of Z to which transformations must be\n*          applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n*\n*     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n*          IF WANTZ is .TRUE., then on output, the orthogonal\n*          similarity transformation mentioned above has been\n*          accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n*          If WANTZ is .FALSE., then Z is unreferenced.\n*\n*     LDZ     (input) integer\n*          The leading dimension of Z just as declared in the\n*          calling subroutine.  1 .LE. LDZ.\n*\n*     NS      (output) integer\n*          The number of unconverged (ie approximate) eigenvalues\n*          returned in SR and SI that may be used as shifts by the\n*          calling subroutine.\n*\n*     ND      (output) integer\n*          The number of converged eigenvalues uncovered by this\n*          subroutine.\n*\n*     SR      (output) DOUBLE PRECISION array, dimension (KBOT)\n*     SI      (output) DOUBLE PRECISION array, dimension (KBOT)\n*          On output, the real and imaginary parts of approximate\n*          eigenvalues that may be used for shifts are stored in\n*          SR(KBOT-ND-NS+1) through SR(KBOT-ND) and\n*          SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.\n*          The real and imaginary parts of converged eigenvalues\n*          are stored in SR(KBOT-ND+1) through SR(KBOT) and\n*          SI(KBOT-ND+1) through SI(KBOT), respectively.\n*\n*     V       (workspace) DOUBLE PRECISION array, dimension (LDV,NW)\n*          An NW-by-NW work array.\n*\n*     LDV     (input) integer scalar\n*          The leading dimension of V just as declared in the\n*          calling subroutine.  NW .LE. LDV\n*\n*     NH      (input) integer scalar\n*          The number of columns of T.  NH.GE.NW.\n*\n*     T       (workspace) DOUBLE PRECISION array, dimension (LDT,NW)\n*\n*     LDT     (input) integer\n*          The leading dimension of T just as declared in the\n*          calling subroutine.  NW .LE. LDT\n*\n*     NV      (input) integer\n*          The number of rows of work array WV available for\n*          workspace.  NV.GE.NW.\n*\n*     WV      (workspace) DOUBLE PRECISION array, dimension (LDWV,NW)\n*\n*     LDWV    (input) integer\n*          The leading dimension of W just as declared in the\n*          calling subroutine.  NW .LE. LDV\n*\n*     WORK    (workspace) DOUBLE PRECISION array, dimension (LWORK)\n*          On exit, WORK(1) is set to an estimate of the optimal value\n*          of LWORK for the given values of N, NW, KTOP and KBOT.\n*\n*     LWORK   (input) integer\n*          The dimension of the work array WORK.  LWORK = 2*NW\n*          suffices, but greater efficiency may result from larger\n*          values of LWORK.\n*\n*          If LWORK = -1, then a workspace query is assumed; DLAQR3\n*          only estimates the optimal workspace size for the given\n*          values of N, NW, KTOP and KBOT.  The estimate is returned\n*          in WORK(1).  No error message related to LWORK is issued\n*          by XERBLA.  Neither H nor Z are accessed.\n*\n\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ns, nd, sr, si, h, z = NumRu::Lapack.dlaqr3( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 11 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
  rblapack_wantt = argv[0];
  rblapack_wantz = argv[1];
  rblapack_ktop = argv[2];
  rblapack_kbot = argv[3];
  rblapack_nw = argv[4];
  rblapack_h = argv[5];
  rblapack_iloz = argv[6];
  rblapack_ihiz = argv[7];
  rblapack_z = argv[8];
  rblapack_nh = argv[9];
  rblapack_nv = argv[10];
  if (argc == 12) {
    rblapack_lwork = argv[11];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  wantt = (rblapack_wantt == Qtrue);
  ktop = NUM2INT(rblapack_ktop);
  nw = NUM2INT(rblapack_nw);
  iloz = NUM2INT(rblapack_iloz);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (9th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  n = NA_SHAPE1(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  nv = NUM2INT(rblapack_nv);
  ldwv = nw;
  ldv = nw;
  wantz = (rblapack_wantz == Qtrue);
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (6th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  if (NA_SHAPE1(rblapack_h) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of z");
  if (NA_TYPE(rblapack_h) != NA_DFLOAT)
    rblapack_h = na_change_type(rblapack_h, NA_DFLOAT);
  h = NA_PTR_TYPE(rblapack_h, doublereal*);
  nh = NUM2INT(rblapack_nh);
  ldt = nw;
  kbot = NUM2INT(rblapack_kbot);
  if (rblapack_lwork == Qnil)
    lwork = 2*nw;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ihiz = NUM2INT(rblapack_ihiz);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,kbot);
    rblapack_sr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  sr = NA_PTR_TYPE(rblapack_sr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,kbot);
    rblapack_si = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  si = NA_PTR_TYPE(rblapack_si, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublereal*);
  MEMCPY(h_out__, h, doublereal, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
  MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  v = ALLOC_N(doublereal, (ldv)*(MAX(1,nw)));
  t = ALLOC_N(doublereal, (ldt)*(MAX(1,nw)));
  wv = ALLOC_N(doublereal, (ldwv)*(MAX(1,nw)));
  work = ALLOC_N(doublereal, (MAX(1,lwork)));

  dlaqr3_(&wantt, &wantz, &n, &ktop, &kbot, &nw, h, &ldh, &iloz, &ihiz, z, &ldz, &ns, &nd, sr, si, v, &ldv, &nh, t, &ldt, &nv, wv, &ldwv, work, &lwork);

  free(v);
  free(t);
  free(wv);
  free(work);
  rblapack_ns = INT2NUM(ns);
  rblapack_nd = INT2NUM(nd);
  return rb_ary_new3(6, rblapack_ns, rblapack_nd, rblapack_sr, rblapack_si, rblapack_h, rblapack_z);
}

void
init_lapack_dlaqr3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaqr3", rblapack_dlaqr3, -1);
}
ruby-lapack-1.7.2/ext/cheevd.c0000644000175000017500000002326712502221016015772 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cheevd_(char* jobz, char* uplo, integer* n, complex* a, integer* lda, real* w, complex* work, integer* lwork, real* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_cheevd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_lrwork;
  integer lrwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_rwork;
  real *rwork; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *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  w, work, rwork, iwork, info, a = NumRu::Lapack.cheevd( jobz, uplo, a, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHEEVD computes all eigenvalues and, optionally, eigenvectors of a\n*  complex Hermitian matrix A.  If eigenvectors are desired, it uses a\n*  divide and conquer algorithm.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA, N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of A contains the\n*          upper triangular part of the matrix A.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of A contains\n*          the lower triangular part of the matrix A.\n*          On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n*          orthonormal eigenvectors of the matrix A.\n*          If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n*          or the upper triangle (if UPLO='U') of A, including the\n*          diagonal, is destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  W       (output) REAL array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  WORK    (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of the array WORK.\n*          If N <= 1,                LWORK must be at least 1.\n*          If JOBZ  = 'N' and N > 1, LWORK must be at least N + 1.\n*          If JOBZ  = 'V' and N > 1, LWORK must be at least 2*N + N**2.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal sizes of the WORK, RWORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  RWORK   (workspace/output) REAL array,\n*                                         dimension (LRWORK)\n*          On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n*\n*  LRWORK  (input) INTEGER\n*          The dimension of the array RWORK.\n*          If N <= 1,                LRWORK must be at least 1.\n*          If JOBZ  = 'N' and N > 1, LRWORK must be at least N.\n*          If JOBZ  = 'V' and N > 1, LRWORK must be at least\n*                         1 + 5*N + 2*N**2.\n*\n*          If LRWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.\n*          If N <= 1,                LIWORK must be at least 1.\n*          If JOBZ  = 'N' and N > 1, LIWORK must be at least 1.\n*          If JOBZ  = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK 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 and JOBZ = 'N', then the algorithm failed\n*                to converge; i off-diagonal elements of an intermediate\n*                tridiagonal form did not converge to zero;\n*                if INFO = i and JOBZ = 'V', then the algorithm failed\n*                to compute an eigenvalue while working on the submatrix\n*                lying in rows and columns INFO/(N+1) through\n*                mod(INFO,N+1).\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Jeff Rutter, Computer Science Division, University of California\n*     at Berkeley, USA\n*\n*  Modified description of INFO. Sven, 16 Feb 05.\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, work, rwork, iwork, info, a = NumRu::Lapack.cheevd( jobz, uplo, a, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  if (argc == 6) {
    rblapack_lwork = argv[3];
    rblapack_lrwork = argv[4];
    rblapack_liwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_lrwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (rblapack_lrwork == Qnil)
    lrwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n+1 : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
  else {
    lrwork = NUM2INT(rblapack_lrwork);
  }
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (rblapack_liwork == Qnil)
    liwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  if (rblapack_lwork == Qnil)
    lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n+1 : lsame_(&jobz,"V") ? 2*n+n*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lrwork);
    rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  rwork = NA_PTR_TYPE(rblapack_rwork, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  cheevd_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_w, rblapack_work, rblapack_rwork, rblapack_iwork, rblapack_info, rblapack_a);
}

void
init_lapack_cheevd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cheevd", rblapack_cheevd, -1);
}
ruby-lapack-1.7.2/ext/zunmhr.c0000644000175000017500000002027412502221021016046 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zunmhr_(char* side, char* trans, integer* m, integer* n, integer* ilo, integer* ihi, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zunmhr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_c;
  doublecomplex *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublecomplex *c_out__;

  integer lda;
  integer m;
  integer ldc;
  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  work, info, c = NumRu::Lapack.zunmhr( side, trans, ilo, ihi, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZUNMHR overwrites the general complex M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'C':      Q**H * C       C * Q**H\n*\n*  where Q is a complex unitary matrix of order nq, with nq = m if\n*  SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of\n*  IHI-ILO elementary reflectors, as returned by ZGEHRD:\n*\n*  Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**H from the Left;\n*          = 'R': apply Q or Q**H from the Right.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': apply Q  (No transpose)\n*          = 'C': apply Q**H (Conjugate transpose)\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          ILO and IHI must have the same values as in the previous call\n*          of ZGEHRD. Q is equal to the unit matrix except in the\n*          submatrix Q(ilo+1:ihi,ilo+1:ihi).\n*          If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and\n*          ILO = 1 and IHI = 0, if M = 0;\n*          if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and\n*          ILO = 1 and IHI = 0, if N = 0.\n*\n*  A       (input) COMPLEX*16 array, dimension\n*                               (LDA,M) if SIDE = 'L'\n*                               (LDA,N) if SIDE = 'R'\n*          The vectors which define the elementary reflectors, as\n*          returned by ZGEHRD.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*          LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n*\n*  TAU     (input) COMPLEX*16 array, dimension\n*                               (M-1) if SIDE = 'L'\n*                               (N-1) if SIDE = 'R'\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by ZGEHRD.\n*\n*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace/output) COMPLEX*16 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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M).\n*          For optimum performance LWORK >= N*NB if SIDE = 'L', and\n*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n*          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*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LEFT, LQUERY\n      INTEGER            I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            ILAENV\n      EXTERNAL           LSAME, ILAENV\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZUNMQR\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.zunmhr( side, trans, ilo, ihi, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_ilo = argv[2];
  rblapack_ihi = argv[3];
  rblapack_a = argv[4];
  rblapack_tau = argv[5];
  rblapack_c = argv[6];
  if (argc == 8) {
    rblapack_lwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  side = StringValueCStr(rblapack_side)[0];
  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (6th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_tau) != (m-1))
    rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", m-1);
  if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  ihi = NUM2INT(rblapack_ihi);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
  MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  zunmhr_(&side, &trans, &m, &n, &ilo, &ihi, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_zunmhr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zunmhr", rblapack_zunmhr, -1);
}
ruby-lapack-1.7.2/ext/dlaqr0.c0000644000175000017500000002765012502221023015715 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaqr0_(logical* wantt, logical* wantz, integer* n, integer* ilo, integer* ihi, doublereal* h, integer* ldh, doublereal* wr, doublereal* wi, integer* iloz, integer* ihiz, doublereal* z, integer* ldz, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dlaqr0(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantt;
  logical wantt; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_h;
  doublereal *h; 
  VALUE rblapack_iloz;
  integer iloz; 
  VALUE rblapack_ihiz;
  integer ihiz; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_wr;
  doublereal *wr; 
  VALUE rblapack_wi;
  doublereal *wi; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_h_out__;
  doublereal *h_out__;
  VALUE rblapack_z_out__;
  doublereal *z_out__;

  integer ldh;
  integer n;
  integer ldz;
  integer ihi;

  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  wr, wi, work, info, h, z = NumRu::Lapack.dlaqr0( wantt, wantz, ilo, h, iloz, ihiz, z, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     DLAQR0 computes the eigenvalues of a Hessenberg matrix H\n*     and, optionally, the matrices T and Z from the Schur decomposition\n*     H = Z T Z**T, where T is an upper quasi-triangular matrix (the\n*     Schur form), and Z is the orthogonal matrix of Schur vectors.\n*\n*     Optionally Z may be postmultiplied into an input orthogonal\n*     matrix Q so that this routine can give the Schur factorization\n*     of a matrix A which has been reduced to the Hessenberg form H\n*     by the orthogonal matrix Q:  A = Q*H*Q**T = (QZ)*T*(QZ)**T.\n*\n\n*     Arguments\n*     =========\n*\n*     WANTT   (input) LOGICAL\n*          = .TRUE. : the full Schur form T is required;\n*          = .FALSE.: only eigenvalues are required.\n*\n*     WANTZ   (input) LOGICAL\n*          = .TRUE. : the matrix of Schur vectors Z is required;\n*          = .FALSE.: Schur vectors are not required.\n*\n*     N     (input) INTEGER\n*           The order of the matrix H.  N .GE. 0.\n*\n*     ILO   (input) INTEGER\n*     IHI   (input) INTEGER\n*           It is assumed that H is already upper triangular in rows\n*           and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n*           H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n*           previous call to DGEBAL, and then passed to DGEHRD when the\n*           matrix output by DGEBAL is reduced to Hessenberg form.\n*           Otherwise, ILO and IHI should be set to 1 and N,\n*           respectively.  If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n*           If N = 0, then ILO = 1 and IHI = 0.\n*\n*     H     (input/output) DOUBLE PRECISION array, dimension (LDH,N)\n*           On entry, the upper Hessenberg matrix H.\n*           On exit, if INFO = 0 and WANTT is .TRUE., then H contains\n*           the upper quasi-triangular matrix T from the Schur\n*           decomposition (the Schur form); 2-by-2 diagonal blocks\n*           (corresponding to complex conjugate pairs of eigenvalues)\n*           are returned in standard form, with H(i,i) = H(i+1,i+1)\n*           and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is\n*           .FALSE., then the contents of H are unspecified on exit.\n*           (The output value of H when INFO.GT.0 is given under the\n*           description of INFO below.)\n*\n*           This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n*           j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n*\n*     LDH   (input) INTEGER\n*           The leading dimension of the array H. LDH .GE. max(1,N).\n*\n*     WR    (output) DOUBLE PRECISION array, dimension (IHI)\n*     WI    (output) DOUBLE PRECISION array, dimension (IHI)\n*           The real and imaginary parts, respectively, of the computed\n*           eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI)\n*           and WI(ILO:IHI). If two eigenvalues are computed as a\n*           complex conjugate pair, they are stored in consecutive\n*           elements of WR and WI, say the i-th and (i+1)th, with\n*           WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then\n*           the eigenvalues are stored in the same order as on the\n*           diagonal of the Schur form returned in H, with\n*           WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal\n*           block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and\n*           WI(i+1) = -WI(i).\n*\n*     ILOZ     (input) INTEGER\n*     IHIZ     (input) INTEGER\n*           Specify the rows of Z to which transformations must be\n*           applied if WANTZ is .TRUE..\n*           1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.\n*\n*     Z     (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI)\n*           If WANTZ is .FALSE., then Z is not referenced.\n*           If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n*           replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n*           orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n*           (The output value of Z when INFO.GT.0 is given under\n*           the description of INFO below.)\n*\n*     LDZ   (input) INTEGER\n*           The leading dimension of the array Z.  if WANTZ is .TRUE.\n*           then LDZ.GE.MAX(1,IHIZ).  Otherwize, LDZ.GE.1.\n*\n*     WORK  (workspace/output) DOUBLE PRECISION array, dimension LWORK\n*           On exit, if LWORK = -1, WORK(1) returns an estimate of\n*           the optimal value for LWORK.\n*\n*     LWORK (input) INTEGER\n*           The dimension of the array WORK.  LWORK .GE. max(1,N)\n*           is sufficient, but LWORK typically as large as 6*N may\n*           be required for optimal performance.  A workspace query\n*           to determine the optimal workspace size is recommended.\n*\n*           If LWORK = -1, then DLAQR0 does a workspace query.\n*           In this case, DLAQR0 checks the input parameters and\n*           estimates the optimal workspace size for the given\n*           values of N, ILO and IHI.  The estimate is returned\n*           in WORK(1).  No error message related to LWORK is\n*           issued by XERBLA.  Neither H nor Z are accessed.\n*\n*\n*     INFO  (output) INTEGER\n*             =  0:  successful exit\n*           .GT. 0:  if INFO = i, DLAQR0 failed to compute all of\n*                the eigenvalues.  Elements 1:ilo-1 and i+1:n of WR\n*                and WI contain those eigenvalues which have been\n*                successfully computed.  (Failures are rare.)\n*\n*                If INFO .GT. 0 and WANT is .FALSE., then on exit,\n*                the remaining unconverged eigenvalues are the eigen-\n*                values of the upper Hessenberg matrix rows and\n*                columns ILO through INFO of the final, output\n*                value of H.\n*\n*                If INFO .GT. 0 and WANTT is .TRUE., then on exit\n*\n*           (*)  (initial value of H)*U  = U*(final value of H)\n*\n*                where U is an orthogonal matrix.  The final\n*                value of H is upper Hessenberg and quasi-triangular\n*                in rows and columns INFO+1 through IHI.\n*\n*                If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n*\n*                  (final value of Z(ILO:IHI,ILOZ:IHIZ)\n*                   =  (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n*\n*                where U is the orthogonal matrix in (*) (regard-\n*                less of the value of WANTT.)\n*\n*                If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n*                accessed.\n*\n\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n*     References:\n*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n*       Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n*       Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n*       929--947, 2002.\n*\n*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n*       Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n*       of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n*     ================================================================\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  wr, wi, work, info, h, z = NumRu::Lapack.dlaqr0( wantt, wantz, ilo, h, iloz, ihiz, z, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_wantt = argv[0];
  rblapack_wantz = argv[1];
  rblapack_ilo = argv[2];
  rblapack_h = argv[3];
  rblapack_iloz = argv[4];
  rblapack_ihiz = argv[5];
  rblapack_z = argv[6];
  if (argc == 8) {
    rblapack_lwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  wantt = (rblapack_wantt == Qtrue);
  ilo = NUM2INT(rblapack_ilo);
  iloz = NUM2INT(rblapack_iloz);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (7th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  ihi = NA_SHAPE1(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  wantz = (rblapack_wantz == Qtrue);
  ihiz = NUM2INT(rblapack_ihiz);
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (4th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (4th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_DFLOAT)
    rblapack_h = na_change_type(rblapack_h, NA_DFLOAT);
  h = NA_PTR_TYPE(rblapack_h, doublereal*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = ihi;
    rblapack_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  wr = NA_PTR_TYPE(rblapack_wr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = ihi;
    rblapack_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  wi = NA_PTR_TYPE(rblapack_wi, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublereal*);
  MEMCPY(h_out__, h, doublereal, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = ihi;
    rblapack_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
  MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  dlaqr0_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, wr, wi, &iloz, &ihiz, z, &ldz, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_wr, rblapack_wi, rblapack_work, rblapack_info, rblapack_h, rblapack_z);
}

void
init_lapack_dlaqr0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaqr0", rblapack_dlaqr0, -1);
}
ruby-lapack-1.7.2/ext/dtrexc.c0000644000175000017500000001473612502221021016022 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtrexc_(char* compq, integer* n, doublereal* t, integer* ldt, doublereal* q, integer* ldq, integer* ifst, integer* ilst, doublereal* work, integer* info);


static VALUE
rblapack_dtrexc(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_compq;
  char compq; 
  VALUE rblapack_t;
  doublereal *t; 
  VALUE rblapack_q;
  doublereal *q; 
  VALUE rblapack_ifst;
  integer ifst; 
  VALUE rblapack_ilst;
  integer ilst; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_t_out__;
  doublereal *t_out__;
  VALUE rblapack_q_out__;
  doublereal *q_out__;
  doublereal *work;

  integer ldt;
  integer n;
  integer ldq;

  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  info, t, q, ifst, ilst = NumRu::Lapack.dtrexc( compq, t, q, ifst, ilst, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTREXC reorders the real Schur factorization of a real matrix\n*  A = Q*T*Q**T, so that the diagonal block of T with row index IFST is\n*  moved to row ILST.\n*\n*  The real Schur form T is reordered by an orthogonal similarity\n*  transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors\n*  is updated by postmultiplying it with Z.\n*\n*  T must be in Schur canonical form (as returned by DHSEQR), that is,\n*  block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each\n*  2-by-2 diagonal block has its diagonal elements equal and its\n*  off-diagonal elements of opposite sign.\n*\n\n*  Arguments\n*  =========\n*\n*  COMPQ   (input) CHARACTER*1\n*          = 'V':  update the matrix Q of Schur vectors;\n*          = 'N':  do not update Q.\n*\n*  N       (input) INTEGER\n*          The order of the matrix T. N >= 0.\n*\n*  T       (input/output) DOUBLE PRECISION array, dimension (LDT,N)\n*          On entry, the upper quasi-triangular matrix T, in Schur\n*          Schur canonical form.\n*          On exit, the reordered upper quasi-triangular matrix, again\n*          in Schur canonical form.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= max(1,N).\n*\n*  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n*          On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n*          On exit, if COMPQ = 'V', Q has been postmultiplied by the\n*          orthogonal transformation matrix Z which reorders T.\n*          If COMPQ = 'N', Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.  LDQ >= max(1,N).\n*\n*  IFST    (input/output) INTEGER\n*  ILST    (input/output) INTEGER\n*          Specify the reordering of the diagonal blocks of T.\n*          The block with row index IFST is moved to row ILST, by a\n*          sequence of transpositions between adjacent blocks.\n*          On exit, if IFST pointed on entry to the second row of a\n*          2-by-2 block, it is changed to point to the first row; ILST\n*          always points to the first row of the block in its final\n*          position (which may differ from its input value by +1 or -1).\n*          1 <= IFST <= N; 1 <= ILST <= N.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          = 1:  two adjacent blocks were too close to swap (the problem\n*                is very ill-conditioned); T may have been partially\n*                reordered, and ILST points to the first row of the\n*                current position of the block being moved.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, t, q, ifst, ilst = NumRu::Lapack.dtrexc( compq, t, q, ifst, ilst, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_compq = argv[0];
  rblapack_t = argv[1];
  rblapack_q = argv[2];
  rblapack_ifst = argv[3];
  rblapack_ilst = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  compq = StringValueCStr(rblapack_compq)[0];
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (3th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (3th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  n = NA_SHAPE1(rblapack_q);
  if (NA_TYPE(rblapack_q) != NA_DFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
  q = NA_PTR_TYPE(rblapack_q, doublereal*);
  ilst = NUM2INT(rblapack_ilst);
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (2th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (2th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  if (NA_SHAPE1(rblapack_t) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of q");
  if (NA_TYPE(rblapack_t) != NA_DFLOAT)
    rblapack_t = na_change_type(rblapack_t, NA_DFLOAT);
  t = NA_PTR_TYPE(rblapack_t, doublereal*);
  ifst = NUM2INT(rblapack_ifst);
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = n;
    rblapack_t_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  t_out__ = NA_PTR_TYPE(rblapack_t_out__, doublereal*);
  MEMCPY(t_out__, t, doublereal, NA_TOTAL(rblapack_t));
  rblapack_t = rblapack_t_out__;
  t = t_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
  MEMCPY(q_out__, q, doublereal, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  work = ALLOC_N(doublereal, (n));

  dtrexc_(&compq, &n, t, &ldt, q, &ldq, &ifst, &ilst, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  rblapack_ifst = INT2NUM(ifst);
  rblapack_ilst = INT2NUM(ilst);
  return rb_ary_new3(5, rblapack_info, rblapack_t, rblapack_q, rblapack_ifst, rblapack_ilst);
}

void
init_lapack_dtrexc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtrexc", rblapack_dtrexc, -1);
}
ruby-lapack-1.7.2/ext/ztgexc.c0000644000175000017500000002460412502221016016034 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztgexc_(logical* wantq, logical* wantz, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* q, integer* ldq, doublecomplex* z, integer* ldz, integer* ifst, integer* ilst, integer* info);


static VALUE
rblapack_ztgexc(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantq;
  logical wantq; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_q;
  doublecomplex *q; 
  VALUE rblapack_ldq;
  integer ldq; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_ifst;
  integer ifst; 
  VALUE rblapack_ilst;
  integer ilst; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  VALUE rblapack_q_out__;
  doublecomplex *q_out__;
  VALUE rblapack_z_out__;
  doublecomplex *z_out__;

  integer lda;
  integer n;
  integer ldb;
  integer ldz;

  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  info, a, b, q, z, ilst = NumRu::Lapack.ztgexc( wantq, wantz, a, b, q, ldq, z, ifst, ilst, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, IFST, ILST, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTGEXC reorders the generalized Schur decomposition of a complex\n*  matrix pair (A,B), using an unitary equivalence transformation\n*  (A, B) := Q * (A, B) * Z', so that the diagonal block of (A, B) with\n*  row index IFST is moved to row ILST.\n*\n*  (A, B) must be in generalized Schur canonical form, that is, A and\n*  B are both upper triangular.\n*\n*  Optionally, the matrices Q and Z of generalized Schur vectors are\n*  updated.\n*\n*         Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n*         Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n*\n\n*  Arguments\n*  =========\n*\n*  WANTQ   (input) LOGICAL\n*          .TRUE. : update the left transformation matrix Q;\n*          .FALSE.: do not update Q.\n*\n*  WANTZ   (input) LOGICAL\n*          .TRUE. : update the right transformation matrix Z;\n*          .FALSE.: do not update Z.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B. N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the upper triangular matrix A in the pair (A, B).\n*          On exit, the updated matrix A.\n*\n*  LDA     (input)  INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,N)\n*          On entry, the upper triangular matrix B in the pair (A, B).\n*          On exit, the updated matrix B.\n*\n*  LDB     (input)  INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  Q       (input/output) COMPLEX*16 array, dimension (LDZ,N)\n*          On entry, if WANTQ = .TRUE., the unitary matrix Q.\n*          On exit, the updated matrix Q.\n*          If WANTQ = .FALSE., Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q. LDQ >= 1;\n*          If WANTQ = .TRUE., LDQ >= N.\n*\n*  Z       (input/output) COMPLEX*16 array, dimension (LDZ,N)\n*          On entry, if WANTZ = .TRUE., the unitary matrix Z.\n*          On exit, the updated matrix Z.\n*          If WANTZ = .FALSE., Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z. LDZ >= 1;\n*          If WANTZ = .TRUE., LDZ >= N.\n*\n*  IFST    (input) INTEGER\n*  ILST    (input/output) INTEGER\n*          Specify the reordering of the diagonal blocks of (A, B).\n*          The block with row index IFST is moved to row ILST, by a\n*          sequence of swapping between adjacent blocks.\n*\n*  INFO    (output) INTEGER\n*           =0:  Successful exit.\n*           <0:  if INFO = -i, the i-th argument had an illegal value.\n*           =1:  The transformed matrix pair (A, B) would be too far\n*                from generalized Schur form; the problem is ill-\n*                conditioned. (A, B) may have been partially reordered,\n*                and ILST points to the first row of the current\n*                position of the block being moved.\n*\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n*      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n*      M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n*      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n*  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n*      Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n*      Estimation: Theory, Algorithms and Software, Report\n*      UMINF - 94.04, Department of Computing Science, Umea University,\n*      S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.\n*      To appear in Numerical Algorithms, 1996.\n*\n*  [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n*      for Solving the Generalized Sylvester Equation and Estimating the\n*      Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n*      Department of Computing Science, Umea University, S-901 87 Umea,\n*      Sweden, December 1993, Revised April 1994, Also as LAPACK working\n*      Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,\n*      1996.\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            HERE\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZTGEX2\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a, b, q, z, ilst = NumRu::Lapack.ztgexc( wantq, wantz, a, b, q, ldq, z, ifst, ilst, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_wantq = argv[0];
  rblapack_wantz = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  rblapack_q = argv[4];
  rblapack_ldq = argv[5];
  rblapack_z = argv[6];
  rblapack_ifst = argv[7];
  rblapack_ilst = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  wantq = (rblapack_wantq == Qtrue);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (5th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_q) != NA_DCOMPLEX)
    rblapack_q = na_change_type(rblapack_q, NA_DCOMPLEX);
  q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (7th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_z) != ldz)
    rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of q");
  if (NA_SHAPE1(rblapack_z) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_z) != NA_DCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  ilst = NUM2INT(rblapack_ilst);
  wantz = (rblapack_wantz == Qtrue);
  ldq = NUM2INT(rblapack_ldq);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  ifst = NUM2INT(rblapack_ifst);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublecomplex*);
  MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublecomplex*);
  MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  ztgexc_(&wantq, &wantz, &n, a, &lda, b, &ldb, q, &ldq, z, &ldz, &ifst, &ilst, &info);

  rblapack_info = INT2NUM(info);
  rblapack_ilst = INT2NUM(ilst);
  return rb_ary_new3(6, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z, rblapack_ilst);
}

void
init_lapack_ztgexc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztgexc", rblapack_ztgexc, -1);
}
ruby-lapack-1.7.2/ext/sgegv.c0000644000175000017500000003375412502221023015647 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgegv_(char* jobvl, char* jobvr, integer* n, real* a, integer* lda, real* b, integer* ldb, real* alphar, real* alphai, real* beta, real* vl, integer* ldvl, real* vr, integer* ldvr, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sgegv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvl;
  char jobvl; 
  VALUE rblapack_jobvr;
  char jobvr; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_alphar;
  real *alphar; 
  VALUE rblapack_alphai;
  real *alphai; 
  VALUE rblapack_beta;
  real *beta; 
  VALUE rblapack_vl;
  real *vl; 
  VALUE rblapack_vr;
  real *vr; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_b_out__;
  real *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer ldvl;
  integer ldvr;

  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  alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.sgegv( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  This routine is deprecated and has been replaced by routine SGGEV.\n*\n*  SGEGV computes the eigenvalues and, optionally, the left and/or right\n*  eigenvectors of a real matrix pair (A,B).\n*  Given two square matrices A and B,\n*  the generalized nonsymmetric eigenvalue problem (GNEP) is to find the\n*  eigenvalues lambda and corresponding (non-zero) eigenvectors x such\n*  that\n*\n*     A*x = lambda*B*x.\n*\n*  An alternate form is to find the eigenvalues mu and corresponding\n*  eigenvectors y such that\n*\n*     mu*A*y = B*y.\n*\n*  These two forms are equivalent with mu = 1/lambda and x = y if\n*  neither lambda nor mu is zero.  In order to deal with the case that\n*  lambda or mu is zero or small, two values alpha and beta are returned\n*  for each eigenvalue, such that lambda = alpha/beta and\n*  mu = beta/alpha.\n*\n*  The vectors x and y in the above equations are right eigenvectors of\n*  the matrix pair (A,B).  Vectors u and v satisfying\n*\n*     u**H*A = lambda*u**H*B  or  mu*v**H*A = v**H*B\n*\n*  are left eigenvectors of (A,B).\n*\n*  Note: this routine performs \"full balancing\" on A and B -- see\n*  \"Further Details\", below.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVL   (input) CHARACTER*1\n*          = 'N':  do not compute the left generalized eigenvectors;\n*          = 'V':  compute the left generalized eigenvectors (returned\n*                  in VL).\n*\n*  JOBVR   (input) CHARACTER*1\n*          = 'N':  do not compute the right generalized eigenvectors;\n*          = 'V':  compute the right generalized eigenvectors (returned\n*                  in VR).\n*\n*  N       (input) INTEGER\n*          The order of the matrices A, B, VL, and VR.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA, N)\n*          On entry, the matrix A.\n*          If JOBVL = 'V' or JOBVR = 'V', then on exit A\n*          contains the real Schur form of A from the generalized Schur\n*          factorization of the pair (A,B) after balancing.\n*          If no eigenvectors were computed, then only the diagonal\n*          blocks from the Schur form will be correct.  See SGGHRD and\n*          SHGEQZ for details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of A.  LDA >= max(1,N).\n*\n*  B       (input/output) REAL array, dimension (LDB, N)\n*          On entry, the matrix B.\n*          If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the\n*          upper triangular matrix obtained from B in the generalized\n*          Schur factorization of the pair (A,B) after balancing.\n*          If no eigenvectors were computed, then only those elements of\n*          B corresponding to the diagonal blocks from the Schur form of\n*          A will be correct.  See SGGHRD and SHGEQZ for details.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of B.  LDB >= max(1,N).\n*\n*  ALPHAR  (output) REAL array, dimension (N)\n*          The real parts of each scalar alpha defining an eigenvalue of\n*          GNEP.\n*\n*  ALPHAI  (output) REAL array, dimension (N)\n*          The imaginary parts of each scalar alpha defining an\n*          eigenvalue of GNEP.  If ALPHAI(j) is zero, then the j-th\n*          eigenvalue is real; if positive, then the j-th and\n*          (j+1)-st eigenvalues are a complex conjugate pair, with\n*          ALPHAI(j+1) = -ALPHAI(j).\n*\n*  BETA    (output) REAL array, dimension (N)\n*          The scalars beta that define the eigenvalues of GNEP.\n*          \n*          Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and\n*          beta = BETA(j) represent the j-th eigenvalue of the matrix\n*          pair (A,B), in one of the forms lambda = alpha/beta or\n*          mu = beta/alpha.  Since either lambda or mu may overflow,\n*          they should not, in general, be computed.\n*\n*  VL      (output) REAL array, dimension (LDVL,N)\n*          If JOBVL = 'V', the left eigenvectors u(j) are stored\n*          in the columns of VL, in the same order as their eigenvalues.\n*          If the j-th eigenvalue is real, then u(j) = VL(:,j).\n*          If the j-th and (j+1)-st eigenvalues form a complex conjugate\n*          pair, then\n*             u(j) = VL(:,j) + i*VL(:,j+1)\n*          and\n*            u(j+1) = VL(:,j) - i*VL(:,j+1).\n*\n*          Each eigenvector is scaled so that its largest component has\n*          abs(real part) + abs(imag. part) = 1, except for eigenvectors\n*          corresponding to an eigenvalue with alpha = beta = 0, which\n*          are set to zero.\n*          Not referenced if JOBVL = 'N'.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the matrix VL. LDVL >= 1, and\n*          if JOBVL = 'V', LDVL >= N.\n*\n*  VR      (output) REAL array, dimension (LDVR,N)\n*          If JOBVR = 'V', the right eigenvectors x(j) are stored\n*          in the columns of VR, in the same order as their eigenvalues.\n*          If the j-th eigenvalue is real, then x(j) = VR(:,j).\n*          If the j-th and (j+1)-st eigenvalues form a complex conjugate\n*          pair, then\n*            x(j) = VR(:,j) + i*VR(:,j+1)\n*          and\n*            x(j+1) = VR(:,j) - i*VR(:,j+1).\n*\n*          Each eigenvector is scaled so that its largest component has\n*          abs(real part) + abs(imag. part) = 1, except for eigenvalues\n*          corresponding to an eigenvalue with alpha = beta = 0, which\n*          are set to zero.\n*          Not referenced if JOBVR = 'N'.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the matrix VR. LDVR >= 1, and\n*          if JOBVR = 'V', LDVR >= N.\n*\n*  WORK    (workspace/output) REAL 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,8*N).\n*          For good performance, LWORK must generally be larger.\n*          To compute the optimal value of LWORK, call ILAENV to get\n*          blocksizes (for SGEQRF, SORMQR, and SORGQR.)  Then compute:\n*          NB  -- MAX of the blocksizes for SGEQRF, SORMQR, and SORGQR;\n*          The optimal LWORK is:\n*              2*N + MAX( 6*N, N*(NB+1) ).\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*          = 1,...,N:\n*                The QZ iteration failed.  No eigenvectors have been\n*                calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)\n*                should be correct for j=INFO+1,...,N.\n*          > N:  errors that usually indicate LAPACK problems:\n*                =N+1: error return from SGGBAL\n*                =N+2: error return from SGEQRF\n*                =N+3: error return from SORMQR\n*                =N+4: error return from SORGQR\n*                =N+5: error return from SGGHRD\n*                =N+6: error return from SHGEQZ (other than failed\n*                                                iteration)\n*                =N+7: error return from STGEVC\n*                =N+8: error return from SGGBAK (computing VL)\n*                =N+9: error return from SGGBAK (computing VR)\n*                =N+10: error return from SLASCL (various calls)\n*\n\n*  Further Details\n*  ===============\n*\n*  Balancing\n*  ---------\n*\n*  This driver calls SGGBAL to both permute and scale rows and columns\n*  of A and B.  The permutations PL and PR are chosen so that PL*A*PR\n*  and PL*B*R will be upper triangular except for the diagonal blocks\n*  A(i:j,i:j) and B(i:j,i:j), with i and j as close together as\n*  possible.  The diagonal scaling matrices DL and DR are chosen so\n*  that the pair  DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to\n*  one (except for the elements that start out zero.)\n*\n*  After the eigenvalues and eigenvectors of the balanced matrices\n*  have been computed, SGGBAK transforms the eigenvectors back to what\n*  they would have been (in perfect arithmetic) if they had not been\n*  balanced.\n*\n*  Contents of A and B on Exit\n*  -------- -- - --- - -- ----\n*\n*  If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or\n*  both), then on exit the arrays A and B will contain the real Schur\n*  form[*] of the \"balanced\" versions of A and B.  If no eigenvectors\n*  are computed, then only the diagonal blocks will be correct.\n*\n*  [*] See SHGEQZ, SGEGS, or read the book \"Matrix Computations\",\n*      by Golub & van Loan, pub. by Johns Hopkins U. Press.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.sgegv( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_jobvl = argv[0];
  rblapack_jobvr = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  jobvl = StringValueCStr(rblapack_jobvl)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  jobvr = StringValueCStr(rblapack_jobvr)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  ldvr = lsame_(&jobvr,"V") ? n : 1;
  if (rblapack_lwork == Qnil)
    lwork = 8*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldvl = lsame_(&jobvl,"V") ? n : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  alphar = NA_PTR_TYPE(rblapack_alphar, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  alphai = NA_PTR_TYPE(rblapack_alphai, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = n;
    rblapack_vl = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vl = NA_PTR_TYPE(rblapack_vl, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = n;
    rblapack_vr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vr = NA_PTR_TYPE(rblapack_vr, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  sgegv_(&jobvl, &jobvr, &n, a, &lda, b, &ldb, alphar, alphai, beta, vl, &ldvl, vr, &ldvr, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_vl, rblapack_vr, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_sgegv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgegv", rblapack_sgegv, -1);
}
ruby-lapack-1.7.2/ext/cggglm.c0000644000175000017500000002120412502221014015757 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cggglm_(integer* n, integer* m, integer* p, complex* a, integer* lda, complex* b, integer* ldb, complex* d, complex* x, complex* y, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_cggglm(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_d;
  complex *d; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_y;
  complex *y; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;
  VALUE rblapack_d_out__;
  complex *d_out__;

  integer lda;
  integer m;
  integer ldb;
  integer p;
  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  x, y, work, info, a, b, d = NumRu::Lapack.cggglm( a, b, d, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGGGLM solves a general Gauss-Markov linear model (GLM) problem:\n*\n*          minimize || y ||_2   subject to   d = A*x + B*y\n*              x\n*\n*  where A is an N-by-M matrix, B is an N-by-P matrix, and d is a\n*  given N-vector. It is assumed that M <= N <= M+P, and\n*\n*             rank(A) = M    and    rank( A B ) = N.\n*\n*  Under these assumptions, the constrained equation is always\n*  consistent, and there is a unique solution x and a minimal 2-norm\n*  solution y, which is obtained using a generalized QR factorization\n*  of the matrices (A, B) given by\n*\n*     A = Q*(R),   B = Q*T*Z.\n*           (0)\n*\n*  In particular, if matrix B is square nonsingular, then the problem\n*  GLM is equivalent to the following weighted linear least squares\n*  problem\n*\n*               minimize || inv(B)*(d-A*x) ||_2\n*                   x\n*\n*  where inv(B) denotes the inverse of B.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of rows of the matrices A and B.  N >= 0.\n*\n*  M       (input) INTEGER\n*          The number of columns of the matrix A.  0 <= M <= N.\n*\n*  P       (input) INTEGER\n*          The number of columns of the matrix B.  P >= N-M.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,M)\n*          On entry, the N-by-M matrix A.\n*          On exit, the upper triangular part of the array A contains\n*          the M-by-M upper triangular matrix R.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,P)\n*          On entry, the N-by-P matrix B.\n*          On exit, if N <= P, the upper triangle of the subarray\n*          B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;\n*          if N > P, the elements on and above the (N-P)th subdiagonal\n*          contain the N-by-P upper trapezoidal matrix T.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  D       (input/output) COMPLEX array, dimension (N)\n*          On entry, D is the left hand side of the GLM equation.\n*          On exit, D is destroyed.\n*\n*  X       (output) COMPLEX array, dimension (M)\n*  Y       (output) COMPLEX array, dimension (P)\n*          On exit, X and Y are the solutions of the GLM problem.\n*\n*  WORK    (workspace/output) COMPLEX 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,N+M+P).\n*          For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,\n*          where NB is an upper bound for the optimal blocksizes for\n*          CGEQRF, CGERQF, CUNMQR and CUNMRQ.\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*          = 1:  the upper triangular factor R associated with A in the\n*                generalized QR factorization of the pair (A, B) is\n*                singular, so that rank(A) < M; the least squares\n*                solution could not be computed.\n*          = 2:  the bottom (N-M) by (N-M) part of the upper trapezoidal\n*                factor T associated with B in the generalized QR\n*                factorization of the pair (A, B) is singular, so that\n*                rank( A B ) < N; the least squares solution could not\n*                be computed.\n*\n\n*  ===================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, y, work, info, a, b, d = NumRu::Lapack.cggglm( a, b, d, [: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_a = argv[0];
  rblapack_b = argv[1];
  rblapack_d = 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 (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);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SCOMPLEX)
    rblapack_d = na_change_type(rblapack_d, NA_SCOMPLEX);
  d = NA_PTR_TYPE(rblapack_d, complex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  p = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (rblapack_lwork == Qnil)
    lwork = m+n+p;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_x = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[1];
    shape[0] = p;
    rblapack_y = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  y = NA_PTR_TYPE(rblapack_y, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = m;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = p;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, complex*);
  MEMCPY(d_out__, d, complex, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;

  cggglm_(&n, &m, &p, a, &lda, b, &ldb, d, x, y, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_x, rblapack_y, rblapack_work, rblapack_info, rblapack_a, rblapack_b, rblapack_d);
}

void
init_lapack_cggglm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cggglm", rblapack_cggglm, -1);
}
ruby-lapack-1.7.2/ext/zgegv.c0000644000175000017500000003244612502221016015655 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgegv_(char* jobvl, char* jobvr, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* alpha, doublecomplex* beta, doublecomplex* vl, integer* ldvl, doublecomplex* vr, integer* ldvr, doublecomplex* work, integer* lwork, doublereal* rwork, integer* info);


static VALUE
rblapack_zgegv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvl;
  char jobvl; 
  VALUE rblapack_jobvr;
  char jobvr; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_alpha;
  doublecomplex *alpha; 
  VALUE rblapack_beta;
  doublecomplex *beta; 
  VALUE rblapack_vl;
  doublecomplex *vl; 
  VALUE rblapack_vr;
  doublecomplex *vr; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_rwork;
  doublereal *rwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer ldvl;
  integer ldvr;

  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  alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.zgegv( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  This routine is deprecated and has been replaced by routine ZGGEV.\n*\n*  ZGEGV computes the eigenvalues and, optionally, the left and/or right\n*  eigenvectors of a complex matrix pair (A,B).\n*  Given two square matrices A and B,\n*  the generalized nonsymmetric eigenvalue problem (GNEP) is to find the\n*  eigenvalues lambda and corresponding (non-zero) eigenvectors x such\n*  that\n*     A*x = lambda*B*x.\n*\n*  An alternate form is to find the eigenvalues mu and corresponding\n*  eigenvectors y such that\n*     mu*A*y = B*y.\n*\n*  These two forms are equivalent with mu = 1/lambda and x = y if\n*  neither lambda nor mu is zero.  In order to deal with the case that\n*  lambda or mu is zero or small, two values alpha and beta are returned\n*  for each eigenvalue, such that lambda = alpha/beta and\n*  mu = beta/alpha.\n*\n*  The vectors x and y in the above equations are right eigenvectors of\n*  the matrix pair (A,B).  Vectors u and v satisfying\n*     u**H*A = lambda*u**H*B  or  mu*v**H*A = v**H*B\n*  are left eigenvectors of (A,B).\n*\n*  Note: this routine performs \"full balancing\" on A and B -- see\n*  \"Further Details\", below.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVL   (input) CHARACTER*1\n*          = 'N':  do not compute the left generalized eigenvectors;\n*          = 'V':  compute the left generalized eigenvectors (returned\n*                  in VL).\n*\n*  JOBVR   (input) CHARACTER*1\n*          = 'N':  do not compute the right generalized eigenvectors;\n*          = 'V':  compute the right generalized eigenvectors (returned\n*                  in VR).\n*\n*  N       (input) INTEGER\n*          The order of the matrices A, B, VL, and VR.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA, N)\n*          On entry, the matrix A.\n*          If JOBVL = 'V' or JOBVR = 'V', then on exit A\n*          contains the Schur form of A from the generalized Schur\n*          factorization of the pair (A,B) after balancing.  If no\n*          eigenvectors were computed, then only the diagonal elements\n*          of the Schur form will be correct.  See ZGGHRD and ZHGEQZ\n*          for details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of A.  LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB, N)\n*          On entry, the matrix B.\n*          If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the\n*          upper triangular matrix obtained from B in the generalized\n*          Schur factorization of the pair (A,B) after balancing.\n*          If no eigenvectors were computed, then only the diagonal\n*          elements of B will be correct.  See ZGGHRD and ZHGEQZ for\n*          details.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of B.  LDB >= max(1,N).\n*\n*  ALPHA   (output) COMPLEX*16 array, dimension (N)\n*          The complex scalars alpha that define the eigenvalues of\n*          GNEP.\n*\n*  BETA    (output) COMPLEX*16 array, dimension (N)\n*          The complex scalars beta that define the eigenvalues of GNEP.\n*          \n*          Together, the quantities alpha = ALPHA(j) and beta = BETA(j)\n*          represent the j-th eigenvalue of the matrix pair (A,B), in\n*          one of the forms lambda = alpha/beta or mu = beta/alpha.\n*          Since either lambda or mu may overflow, they should not,\n*          in general, be computed.\n*\n*  VL      (output) COMPLEX*16 array, dimension (LDVL,N)\n*          If JOBVL = 'V', the left eigenvectors u(j) are stored\n*          in the columns of VL, in the same order as their eigenvalues.\n*          Each eigenvector is scaled so that its largest component has\n*          abs(real part) + abs(imag. part) = 1, except for eigenvectors\n*          corresponding to an eigenvalue with alpha = beta = 0, which\n*          are set to zero.\n*          Not referenced if JOBVL = 'N'.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the matrix VL. LDVL >= 1, and\n*          if JOBVL = 'V', LDVL >= N.\n*\n*  VR      (output) COMPLEX*16 array, dimension (LDVR,N)\n*          If JOBVR = 'V', the right eigenvectors x(j) are stored\n*          in the columns of VR, in the same order as their eigenvalues.\n*          Each eigenvector is scaled so that its largest component has\n*          abs(real part) + abs(imag. part) = 1, except for eigenvectors\n*          corresponding to an eigenvalue with alpha = beta = 0, which\n*          are set to zero.\n*          Not referenced if JOBVR = 'N'.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the matrix VR. LDVR >= 1, and\n*          if JOBVR = 'V', LDVR >= N.\n*\n*  WORK    (workspace/output) COMPLEX*16 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,2*N).\n*          For good performance, LWORK must generally be larger.\n*          To compute the optimal value of LWORK, call ILAENV to get\n*          blocksizes (for ZGEQRF, ZUNMQR, and ZUNGQR.)  Then compute:\n*          NB  -- MAX of the blocksizes for ZGEQRF, ZUNMQR, and ZUNGQR;\n*          The optimal LWORK is  MAX( 2*N, N*(NB+1) ).\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*  RWORK   (workspace/output) DOUBLE PRECISION array, dimension (8*N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          =1,...,N:\n*                The QZ iteration failed.  No eigenvectors have been\n*                calculated, but ALPHA(j) and BETA(j) should be\n*                correct for j=INFO+1,...,N.\n*          > N:  errors that usually indicate LAPACK problems:\n*                =N+1: error return from ZGGBAL\n*                =N+2: error return from ZGEQRF\n*                =N+3: error return from ZUNMQR\n*                =N+4: error return from ZUNGQR\n*                =N+5: error return from ZGGHRD\n*                =N+6: error return from ZHGEQZ (other than failed\n*                                               iteration)\n*                =N+7: error return from ZTGEVC\n*                =N+8: error return from ZGGBAK (computing VL)\n*                =N+9: error return from ZGGBAK (computing VR)\n*                =N+10: error return from ZLASCL (various calls)\n*\n\n*  Further Details\n*  ===============\n*\n*  Balancing\n*  ---------\n*\n*  This driver calls ZGGBAL to both permute and scale rows and columns\n*  of A and B.  The permutations PL and PR are chosen so that PL*A*PR\n*  and PL*B*R will be upper triangular except for the diagonal blocks\n*  A(i:j,i:j) and B(i:j,i:j), with i and j as close together as\n*  possible.  The diagonal scaling matrices DL and DR are chosen so\n*  that the pair  DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to\n*  one (except for the elements that start out zero.)\n*\n*  After the eigenvalues and eigenvectors of the balanced matrices\n*  have been computed, ZGGBAK transforms the eigenvectors back to what\n*  they would have been (in perfect arithmetic) if they had not been\n*  balanced.\n*\n*  Contents of A and B on Exit\n*  -------- -- - --- - -- ----\n*\n*  If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or\n*  both), then on exit the arrays A and B will contain the complex Schur\n*  form[*] of the \"balanced\" versions of A and B.  If no eigenvectors\n*  are computed, then only the diagonal blocks will be correct.\n*\n*  [*] In other words, upper triangular form.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.zgegv( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_jobvl = argv[0];
  rblapack_jobvr = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  jobvl = StringValueCStr(rblapack_jobvl)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  jobvr = StringValueCStr(rblapack_jobvr)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  ldvr = lsame_(&jobvr,"V") ? n : 1;
  if (rblapack_lwork == Qnil)
    lwork = 2*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldvl = lsame_(&jobvl,"V") ? n : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  alpha = NA_PTR_TYPE(rblapack_alpha, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = n;
    rblapack_vl = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  vl = NA_PTR_TYPE(rblapack_vl, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = n;
    rblapack_vr = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  vr = NA_PTR_TYPE(rblapack_vr, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = 8*n;
    rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zgegv_(&jobvl, &jobvr, &n, a, &lda, b, &ldb, alpha, beta, vl, &ldvl, vr, &ldvr, work, &lwork, rwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_alpha, rblapack_beta, rblapack_vl, rblapack_vr, rblapack_work, rblapack_rwork, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_zgegv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgegv", rblapack_zgegv, -1);
}
ruby-lapack-1.7.2/ext/dsbtrd.c0000644000175000017500000001572712502221026016021 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsbtrd_(char* vect, char* uplo, integer* n, integer* kd, doublereal* ab, integer* ldab, doublereal* d, doublereal* e, doublereal* q, integer* ldq, doublereal* work, integer* info);


static VALUE
rblapack_dsbtrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_vect;
  char vect; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_q;
  doublereal *q; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublereal *ab_out__;
  VALUE rblapack_q_out__;
  doublereal *q_out__;
  doublereal *work;

  integer ldab;
  integer n;
  integer ldq;

  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  d, e, info, ab, q = NumRu::Lapack.dsbtrd( vect, uplo, kd, ab, q, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSBTRD reduces a real symmetric band matrix A to symmetric\n*  tridiagonal form T by an orthogonal similarity transformation:\n*  Q**T * A * Q = T.\n*\n\n*  Arguments\n*  =========\n*\n*  VECT    (input) CHARACTER*1\n*          = 'N':  do not form Q;\n*          = 'V':  form Q;\n*          = 'U':  update a matrix X, by forming X*Q.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*          On exit, the diagonal elements of AB are overwritten by the\n*          diagonal elements of the tridiagonal matrix T; if KD > 0, the\n*          elements on the first superdiagonal (if UPLO = 'U') or the\n*          first subdiagonal (if UPLO = 'L') are overwritten by the\n*          off-diagonal elements of T; the rest of AB is overwritten by\n*          values generated during the reduction.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  D       (output) DOUBLE PRECISION array, dimension (N)\n*          The diagonal elements of the tridiagonal matrix T.\n*\n*  E       (output) DOUBLE PRECISION array, dimension (N-1)\n*          The off-diagonal elements of the tridiagonal matrix T:\n*          E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.\n*\n*  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n*          On entry, if VECT = 'U', then Q must contain an N-by-N\n*          matrix X; if VECT = 'N' or 'V', then Q need not be set.\n*\n*          On exit:\n*          if VECT = 'V', Q contains the N-by-N orthogonal matrix Q;\n*          if VECT = 'U', Q contains the product X*Q;\n*          if VECT = 'N', the array Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.\n*          LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (N)\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*  Modified by Linda Kaufman, Bell Labs.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, info, ab, q = NumRu::Lapack.dsbtrd( vect, uplo, kd, ab, q, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_vect = argv[0];
  rblapack_uplo = argv[1];
  rblapack_kd = argv[2];
  rblapack_ab = argv[3];
  rblapack_q = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  vect = StringValueCStr(rblapack_vect)[0];
  kd = NUM2INT(rblapack_kd);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (5th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  n = NA_SHAPE1(rblapack_q);
  if (NA_TYPE(rblapack_q) != NA_DFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
  q = NA_PTR_TYPE(rblapack_q, doublereal*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of q");
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
  MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
  MEMCPY(q_out__, q, doublereal, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  work = ALLOC_N(doublereal, (n));

  dsbtrd_(&vect, &uplo, &n, &kd, ab, &ldab, d, e, q, &ldq, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_d, rblapack_e, rblapack_info, rblapack_ab, rblapack_q);
}

void
init_lapack_dsbtrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsbtrd", rblapack_dsbtrd, -1);
}
ruby-lapack-1.7.2/ext/ilaenv.c0000644000175000017500000001541212502221023016001 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern integer ilaenv_(integer* ispec, char* name, char* opts, integer* n1, integer* n2, integer* n3, integer* n4);


static VALUE
rblapack_ilaenv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ispec;
  integer ispec; 
  VALUE rblapack_name;
  char *name; 
  VALUE rblapack_opts;
  char *opts; 
  VALUE rblapack_n1;
  integer n1; 
  VALUE rblapack_n2;
  integer n2; 
  VALUE rblapack_n3;
  integer n3; 
  VALUE rblapack_n4;
  integer n4; 
  VALUE rblapack___out__;
  integer __out__; 


  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  __out__ = NumRu::Lapack.ilaenv( ispec, name, opts, n1, n2, n3, n4, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 )\n\n*  Purpose\n*  =======\n*\n*  ILAENV is called from the LAPACK routines to choose problem-dependent\n*  parameters for the local environment.  See ISPEC for a description of\n*  the parameters.\n*\n*  ILAENV returns an INTEGER\n*  if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC\n*  if ILAENV < 0:  if ILAENV = -k, the k-th argument had an illegal value.\n*\n*  This version provides a set of parameters which should give good,\n*  but not optimal, performance on many of the currently available\n*  computers.  Users are encouraged to modify this subroutine to set\n*  the tuning parameters for their particular machine using the option\n*  and problem size information in the arguments.\n*\n*  This routine will not function correctly if it is converted to all\n*  lower case.  Converting it to all upper case is allowed.\n*\n\n*  Arguments\n*  =========\n*\n*  ISPEC   (input) INTEGER\n*          Specifies the parameter to be returned as the value of\n*          ILAENV.\n*          = 1: the optimal blocksize; if this value is 1, an unblocked\n*               algorithm will give the best performance.\n*          = 2: the minimum block size for which the block routine\n*               should be used; if the usable block size is less than\n*               this value, an unblocked routine should be used.\n*          = 3: the crossover point (in a block routine, for N less\n*               than this value, an unblocked routine should be used)\n*          = 4: the number of shifts, used in the nonsymmetric\n*               eigenvalue routines (DEPRECATED)\n*          = 5: the minimum column dimension for blocking to be used;\n*               rectangular blocks must have dimension at least k by m,\n*               where k is given by ILAENV(2,...) and m by ILAENV(5,...)\n*          = 6: the crossover point for the SVD (when reducing an m by n\n*               matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds\n*               this value, a QR factorization is used first to reduce\n*               the matrix to a triangular form.)\n*          = 7: the number of processors\n*          = 8: the crossover point for the multishift QR method\n*               for nonsymmetric eigenvalue problems (DEPRECATED)\n*          = 9: maximum size of the subproblems at the bottom of the\n*               computation tree in the divide-and-conquer algorithm\n*               (used by xGELSD and xGESDD)\n*          =10: ieee NaN arithmetic can be trusted not to trap\n*          =11: infinity arithmetic can be trusted not to trap\n*          12 <= ISPEC <= 16:\n*               xHSEQR or one of its subroutines,\n*               see IPARMQ for detailed explanation\n*\n*  NAME    (input) CHARACTER*(*)\n*          The name of the calling subroutine, in either upper case or\n*          lower case.\n*\n*  OPTS    (input) CHARACTER*(*)\n*          The character options to the subroutine NAME, concatenated\n*          into a single character string.  For example, UPLO = 'U',\n*          TRANS = 'T', and DIAG = 'N' for a triangular routine would\n*          be specified as OPTS = 'UTN'.\n*\n*  N1      (input) INTEGER\n*  N2      (input) INTEGER\n*  N3      (input) INTEGER\n*  N4      (input) INTEGER\n*          Problem dimensions for the subroutine NAME; these may not all\n*          be required.\n*\n\n*  Further Details\n*  ===============\n*\n*  The following conventions have been used when calling ILAENV from the\n*  LAPACK routines:\n*  1)  OPTS is a concatenation of all of the character options to\n*      subroutine NAME, in the same order that they appear in the\n*      argument list for NAME, even if they are not used in determining\n*      the value of the parameter specified by ISPEC.\n*  2)  The problem dimensions N1, N2, N3, N4 are specified in the order\n*      that they appear in the argument list for NAME.  N1 is used\n*      first, N2 second, and so on, and unused problem dimensions are\n*      passed a value of -1.\n*  3)  The parameter value returned by ILAENV is checked for validity in\n*      the calling subroutine.  For example, ILAENV is used to retrieve\n*      the optimal blocksize for STRTRI as follows:\n*\n*      NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )\n*      IF( NB.LE.1 ) NB = MAX( 1, N )\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, IC, IZ, NB, NBMIN, NX\n      LOGICAL            CNAME, SNAME\n      CHARACTER          C1*1, C2*2, C4*2, C3*3, SUBNAM*6\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          CHAR, ICHAR, INT, MIN, REAL\n*     ..\n*     .. External Functions ..\n      INTEGER            IEEECK, IPARMQ\n      EXTERNAL           IEEECK, IPARMQ\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.ilaenv( ispec, name, opts, n1, n2, n3, n4, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_ispec = argv[0];
  rblapack_name = argv[1];
  rblapack_opts = argv[2];
  rblapack_n1 = argv[3];
  rblapack_n2 = argv[4];
  rblapack_n3 = argv[5];
  rblapack_n4 = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  ispec = NUM2INT(rblapack_ispec);
  opts = StringValueCStr(rblapack_opts);
  n2 = NUM2INT(rblapack_n2);
  n4 = NUM2INT(rblapack_n4);
  name = StringValueCStr(rblapack_name);
  n3 = NUM2INT(rblapack_n3);
  n1 = NUM2INT(rblapack_n1);

  __out__ = ilaenv_(&ispec, name, opts, &n1, &n2, &n3, &n4);

  rblapack___out__ = INT2NUM(__out__);
  return rblapack___out__;
}

void
init_lapack_ilaenv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ilaenv", rblapack_ilaenv, -1);
}
ruby-lapack-1.7.2/ext/sla_syamv.c0000644000175000017500000001643412502221025016530 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sla_syamv_(integer* uplo, integer* n, real* alpha, real* a, integer* lda, real* x, integer* incx, real* beta, real* y, integer* incy);


static VALUE
rblapack_sla_syamv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  integer uplo; 
  VALUE rblapack_alpha;
  real alpha; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_beta;
  real beta; 
  VALUE rblapack_y;
  real *y; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_y_out__;
  real *y_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  y = NumRu::Lapack.sla_syamv( uplo, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n*  Purpose\n*  =======\n*\n*  SLA_SYAMV  performs the matrix-vector operation\n*\n*          y := alpha*abs(A)*abs(x) + beta*abs(y),\n*\n*  where alpha and beta are scalars, x and y are vectors and A is an\n*  n by n symmetric matrix.\n*\n*  This function is primarily used in calculating error bounds.\n*  To protect against underflow during evaluation, components in\n*  the resulting vector are perturbed away from zero by (N+1)\n*  times the underflow threshold.  To prevent unnecessarily large\n*  errors for block-structure embedded in general matrices,\n*  \"symbolically\" zero components are not perturbed.  A zero\n*  entry is considered \"symbolic\" if all multiplications involved\n*  in computing that entry have at least one zero multiplicand.\n*\n\n*  Arguments\n*  ==========\n*\n*  UPLO    (input) INTEGER\n*           On entry, UPLO specifies whether the upper or lower\n*           triangular part of the array A is to be referenced as\n*           follows:\n*\n*              UPLO = BLAS_UPPER   Only the upper triangular part of A\n*                                  is to be referenced.\n*\n*              UPLO = BLAS_LOWER   Only the lower triangular part of A\n*                                  is to be referenced.\n*\n*           Unchanged on exit.\n*\n*  N       (input) INTEGER\n*           On entry, N specifies the number of columns of the matrix A.\n*           N must be at least zero.\n*           Unchanged on exit.\n*\n*  ALPHA   (input) REAL            .\n*           On entry, ALPHA specifies the scalar alpha.\n*           Unchanged on exit.\n*\n*  A      - REAL             array of DIMENSION ( LDA, n ).\n*           Before entry, the leading m by n part of the array A must\n*           contain the matrix of coefficients.\n*           Unchanged on exit.\n*\n*  LDA     (input) INTEGER\n*           On entry, LDA specifies the first dimension of A as declared\n*           in the calling (sub) program. LDA must be at least\n*           max( 1, n ).\n*           Unchanged on exit.\n*\n*  X       (input) REAL array, dimension\n*           ( 1 + ( n - 1 )*abs( INCX ) )\n*           Before entry, the incremented array X must contain the\n*           vector x.\n*           Unchanged on exit.\n*\n*  INCX    (input) INTEGER\n*           On entry, INCX specifies the increment for the elements of\n*           X. INCX must not be zero.\n*           Unchanged on exit.\n*\n*  BETA    (input) REAL            .\n*           On entry, BETA specifies the scalar beta. When BETA is\n*           supplied as zero then Y need not be set on input.\n*           Unchanged on exit.\n*\n*  Y       (input/output) REAL array, dimension\n*           ( 1 + ( n - 1 )*abs( INCY ) )\n*           Before entry with BETA non-zero, the incremented array Y\n*           must contain the vector y. On exit, Y is overwritten by the\n*           updated vector y.\n*\n*  INCY    (input) INTEGER\n*           On entry, INCY specifies the increment for the elements of\n*           Y. INCY must not be zero.\n*           Unchanged on exit.\n*\n\n*  Further Details\n*  ===============\n*\n*  Level 2 Blas routine.\n*\n*  -- Written on 22-October-1986.\n*     Jack Dongarra, Argonne National Lab.\n*     Jeremy Du Croz, Nag Central Office.\n*     Sven Hammarling, Nag Central Office.\n*     Richard Hanson, Sandia National Labs.\n*  -- Modified for the absolute-value product, April 2006\n*     Jason Riedy, UC Berkeley\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  y = NumRu::Lapack.sla_syamv( uplo, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_uplo = argv[0];
  rblapack_alpha = argv[1];
  rblapack_a = argv[2];
  rblapack_x = argv[3];
  rblapack_incx = argv[4];
  rblapack_beta = argv[5];
  rblapack_y = argv[6];
  rblapack_incy = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = NUM2INT(rblapack_uplo);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (lda != (MAX(1, n)))
    rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", MAX(1, n));
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  incx = NUM2INT(rblapack_incx);
  incy = NUM2INT(rblapack_incy);
  alpha = (real)NUM2DBL(rblapack_alpha);
  beta = (real)NUM2DBL(rblapack_beta);
  lda = MAX(1, n);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (4th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1 + ( n - 1 )*abs( incx )))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (7th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (1 + ( n - 1 )*abs( incy )))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1 + ( n - 1 )*abs( incy ));
  if (NA_TYPE(rblapack_y) != NA_SFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
  y = NA_PTR_TYPE(rblapack_y, real*);
  {
    na_shape_t shape[1];
    shape[0] = 1 + ( n - 1 )*abs( incy );
    rblapack_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
  MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  sla_syamv_(&uplo, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);

  return rblapack_y;
}

void
init_lapack_sla_syamv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sla_syamv", rblapack_sla_syamv, -1);
}
ruby-lapack-1.7.2/ext/claqhb.c0000644000175000017500000001234212502221023015754 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID claqhb_(char* uplo, integer* n, integer* kd, complex* ab, integer* ldab, real* s, real* scond, real* amax, char* equed);


static VALUE
rblapack_claqhb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_scond;
  real scond; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_ab_out__;
  complex *ab_out__;

  integer ldab;
  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  s, equed, ab = NumRu::Lapack.claqhb( uplo, kd, ab, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAQHB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )\n\n*  Purpose\n*  =======\n*\n*  CLAQHB equilibrates an Hermitian band matrix A using the scaling\n*  factors in the vector S.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of super-diagonals of the matrix A if UPLO = 'U',\n*          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) COMPLEX array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*          On exit, if INFO = 0, the triangular factor U or L from the\n*          Cholesky factorization A = U'*U or A = L*L' of the band\n*          matrix A, in the same storage format as A.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  S       (output) REAL array, dimension (N)\n*          The scale factors for A.\n*\n*  SCOND   (input) REAL\n*          Ratio of the smallest S(i) to the largest S(i).\n*\n*  AMAX    (input) REAL\n*          Absolute value of largest matrix entry.\n*\n*  EQUED   (output) CHARACTER*1\n*          Specifies whether or not equilibration was done.\n*          = 'N':  No equilibration.\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*\n*  Internal Parameters\n*  ===================\n*\n*  THRESH is a threshold value used to decide if scaling should be done\n*  based on the ratio of the scaling factors.  If SCOND < THRESH,\n*  scaling is done.\n*\n*  LARGE and SMALL are threshold values used to decide if scaling should\n*  be done based on the absolute size of the largest matrix element.\n*  If AMAX > LARGE or AMAX < SMALL, scaling is done.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, equed, ab = NumRu::Lapack.claqhb( uplo, kd, ab, scond, amax, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  rblapack_scond = argv[3];
  rblapack_amax = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  amax = (real)NUM2DBL(rblapack_amax);
  kd = NUM2INT(rblapack_kd);
  scond = (real)NUM2DBL(rblapack_scond);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
  MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  claqhb_(&uplo, &n, &kd, ab, &ldab, s, &scond, &amax, &equed);

  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(3, rblapack_s, rblapack_equed, rblapack_ab);
}

void
init_lapack_claqhb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "claqhb", rblapack_claqhb, -1);
}
ruby-lapack-1.7.2/ext/slaqr0.c0000644000175000017500000002735612502221017015742 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaqr0_(logical* wantt, logical* wantz, integer* n, integer* ilo, integer* ihi, real* h, integer* ldh, real* wr, real* wi, integer* iloz, integer* ihiz, real* z, integer* ldz, real* work, integer* lwork, integer* info);


static VALUE
rblapack_slaqr0(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantt;
  logical wantt; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_h;
  real *h; 
  VALUE rblapack_iloz;
  integer iloz; 
  VALUE rblapack_ihiz;
  integer ihiz; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_wr;
  real *wr; 
  VALUE rblapack_wi;
  real *wi; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_h_out__;
  real *h_out__;
  VALUE rblapack_z_out__;
  real *z_out__;

  integer ldh;
  integer n;
  integer ldz;
  integer ihi;

  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  wr, wi, work, info, h, z = NumRu::Lapack.slaqr0( wantt, wantz, ilo, h, iloz, ihiz, z, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     SLAQR0 computes the eigenvalues of a Hessenberg matrix H\n*     and, optionally, the matrices T and Z from the Schur decomposition\n*     H = Z T Z**T, where T is an upper quasi-triangular matrix (the\n*     Schur form), and Z is the orthogonal matrix of Schur vectors.\n*\n*     Optionally Z may be postmultiplied into an input orthogonal\n*     matrix Q so that this routine can give the Schur factorization\n*     of a matrix A which has been reduced to the Hessenberg form H\n*     by the orthogonal matrix Q:  A = Q*H*Q**T = (QZ)*T*(QZ)**T.\n*\n\n*     Arguments\n*     =========\n*\n*     WANTT   (input) LOGICAL\n*          = .TRUE. : the full Schur form T is required;\n*          = .FALSE.: only eigenvalues are required.\n*\n*     WANTZ   (input) LOGICAL\n*          = .TRUE. : the matrix of Schur vectors Z is required;\n*          = .FALSE.: Schur vectors are not required.\n*\n*     N     (input) INTEGER\n*           The order of the matrix H.  N .GE. 0.\n*\n*     ILO   (input) INTEGER\n*     IHI   (input) INTEGER\n*           It is assumed that H is already upper triangular in rows\n*           and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n*           H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n*           previous call to SGEBAL, and then passed to SGEHRD when the\n*           matrix output by SGEBAL is reduced to Hessenberg form.\n*           Otherwise, ILO and IHI should be set to 1 and N,\n*           respectively.  If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n*           If N = 0, then ILO = 1 and IHI = 0.\n*\n*     H     (input/output) REAL array, dimension (LDH,N)\n*           On entry, the upper Hessenberg matrix H.\n*           On exit, if INFO = 0 and WANTT is .TRUE., then H contains\n*           the upper quasi-triangular matrix T from the Schur\n*           decomposition (the Schur form); 2-by-2 diagonal blocks\n*           (corresponding to complex conjugate pairs of eigenvalues)\n*           are returned in standard form, with H(i,i) = H(i+1,i+1)\n*           and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is\n*           .FALSE., then the contents of H are unspecified on exit.\n*           (The output value of H when INFO.GT.0 is given under the\n*           description of INFO below.)\n*\n*           This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n*           j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n*\n*     LDH   (input) INTEGER\n*           The leading dimension of the array H. LDH .GE. max(1,N).\n*\n*     WR    (output) REAL array, dimension (IHI)\n*     WI    (output) REAL array, dimension (IHI)\n*           The real and imaginary parts, respectively, of the computed\n*           eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI)\n*           and WI(ILO:IHI). If two eigenvalues are computed as a\n*           complex conjugate pair, they are stored in consecutive\n*           elements of WR and WI, say the i-th and (i+1)th, with\n*           WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then\n*           the eigenvalues are stored in the same order as on the\n*           diagonal of the Schur form returned in H, with\n*           WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal\n*           block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and\n*           WI(i+1) = -WI(i).\n*\n*     ILOZ     (input) INTEGER\n*     IHIZ     (input) INTEGER\n*           Specify the rows of Z to which transformations must be\n*           applied if WANTZ is .TRUE..\n*           1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.\n*\n*     Z     (input/output) REAL array, dimension (LDZ,IHI)\n*           If WANTZ is .FALSE., then Z is not referenced.\n*           If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n*           replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n*           orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n*           (The output value of Z when INFO.GT.0 is given under\n*           the description of INFO below.)\n*\n*     LDZ   (input) INTEGER\n*           The leading dimension of the array Z.  if WANTZ is .TRUE.\n*           then LDZ.GE.MAX(1,IHIZ).  Otherwize, LDZ.GE.1.\n*\n*     WORK  (workspace/output) REAL array, dimension LWORK\n*           On exit, if LWORK = -1, WORK(1) returns an estimate of\n*           the optimal value for LWORK.\n*\n*     LWORK (input) INTEGER\n*           The dimension of the array WORK.  LWORK .GE. max(1,N)\n*           is sufficient, but LWORK typically as large as 6*N may\n*           be required for optimal performance.  A workspace query\n*           to determine the optimal workspace size is recommended.\n*\n*           If LWORK = -1, then SLAQR0 does a workspace query.\n*           In this case, SLAQR0 checks the input parameters and\n*           estimates the optimal workspace size for the given\n*           values of N, ILO and IHI.  The estimate is returned\n*           in WORK(1).  No error message related to LWORK is\n*           issued by XERBLA.  Neither H nor Z are accessed.\n*\n*\n*     INFO  (output) INTEGER\n*             =  0:  successful exit\n*           .GT. 0:  if INFO = i, SLAQR0 failed to compute all of\n*                the eigenvalues.  Elements 1:ilo-1 and i+1:n of WR\n*                and WI contain those eigenvalues which have been\n*                successfully computed.  (Failures are rare.)\n*\n*                If INFO .GT. 0 and WANT is .FALSE., then on exit,\n*                the remaining unconverged eigenvalues are the eigen-\n*                values of the upper Hessenberg matrix rows and\n*                columns ILO through INFO of the final, output\n*                value of H.\n*\n*                If INFO .GT. 0 and WANTT is .TRUE., then on exit\n*\n*           (*)  (initial value of H)*U  = U*(final value of H)\n*\n*                where U is an orthogonal matrix.  The final\n*                value of H is upper Hessenberg and quasi-triangular\n*                in rows and columns INFO+1 through IHI.\n*\n*                If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n*\n*                  (final value of Z(ILO:IHI,ILOZ:IHIZ)\n*                   =  (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n*\n*                where U is the orthogonal matrix in (*) (regard-\n*                less of the value of WANTT.)\n*\n*                If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n*                accessed.\n*\n\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n*     References:\n*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n*       Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n*       Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n*       929--947, 2002.\n*\n*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n*       Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n*       of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n*     ================================================================\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  wr, wi, work, info, h, z = NumRu::Lapack.slaqr0( wantt, wantz, ilo, h, iloz, ihiz, z, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_wantt = argv[0];
  rblapack_wantz = argv[1];
  rblapack_ilo = argv[2];
  rblapack_h = argv[3];
  rblapack_iloz = argv[4];
  rblapack_ihiz = argv[5];
  rblapack_z = argv[6];
  if (argc == 8) {
    rblapack_lwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  wantt = (rblapack_wantt == Qtrue);
  ilo = NUM2INT(rblapack_ilo);
  iloz = NUM2INT(rblapack_iloz);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (7th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  ihi = NA_SHAPE1(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  wantz = (rblapack_wantz == Qtrue);
  ihiz = NUM2INT(rblapack_ihiz);
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (4th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (4th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_SFLOAT)
    rblapack_h = na_change_type(rblapack_h, NA_SFLOAT);
  h = NA_PTR_TYPE(rblapack_h, real*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = ihi;
    rblapack_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  wr = NA_PTR_TYPE(rblapack_wr, real*);
  {
    na_shape_t shape[1];
    shape[0] = ihi;
    rblapack_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  wi = NA_PTR_TYPE(rblapack_wi, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, real*);
  MEMCPY(h_out__, h, real, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = ihi;
    rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
  MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  slaqr0_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, wr, wi, &iloz, &ihiz, z, &ldz, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_wr, rblapack_wi, rblapack_work, rblapack_info, rblapack_h, rblapack_z);
}

void
init_lapack_slaqr0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaqr0", rblapack_slaqr0, -1);
}
ruby-lapack-1.7.2/ext/zlantb.c0000644000175000017500000001216512502221024016020 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal zlantb_(char* norm, char* uplo, char* diag, integer* n, integer* k, doublecomplex* ab, integer* ldab, doublereal* work);


static VALUE
rblapack_zlantb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack___out__;
  doublereal __out__; 
  doublereal *work;

  integer ldab;
  integer n;
  integer lwork;

  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  __out__ = NumRu::Lapack.zlantb( norm, uplo, diag, k, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION ZLANTB( NORM, UPLO, DIAG, N, K, AB, LDAB, WORK )\n\n*  Purpose\n*  =======\n*\n*  ZLANTB  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the element of  largest absolute value  of an\n*  n by n triangular band matrix A,  with ( k + 1 ) diagonals.\n*\n*  Description\n*  ===========\n*\n*  ZLANTB returns the value\n*\n*     ZLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in ZLANTB as described\n*          above.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the matrix A is upper or lower triangular.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  DIAG    (input) CHARACTER*1\n*          Specifies whether or not the matrix A is unit triangular.\n*          = 'N':  Non-unit triangular\n*          = 'U':  Unit triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, ZLANTB is\n*          set to zero.\n*\n*  K       (input) INTEGER\n*          The number of super-diagonals of the matrix A if UPLO = 'U',\n*          or the number of sub-diagonals of the matrix A if UPLO = 'L'.\n*          K >= 0.\n*\n*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)\n*          The upper or lower triangular band matrix A, stored in the\n*          first k+1 rows of AB.  The j-th column of A is stored\n*          in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)   = A(i,j) for j<=i<=min(n,j+k).\n*          Note that when DIAG = 'U', the elements of the array AB\n*          corresponding to the diagonal elements of the matrix A are\n*          not referenced, but are assumed to be one.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= K+1.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n*          referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.zlantb( norm, uplo, diag, k, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_diag = argv[2];
  rblapack_k = argv[3];
  rblapack_ab = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  lwork = lsame_(&norm,"I") ? n : 0;
  k = NUM2INT(rblapack_k);
  work = ALLOC_N(doublereal, (MAX(1,lwork)));

  __out__ = zlantb_(&norm, &uplo, &diag, &n, &k, ab, &ldab, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_zlantb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlantb", rblapack_zlantb, -1);
}
ruby-lapack-1.7.2/ext/stgexc.c0000644000175000017500000002560312502221025016025 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID stgexc_(logical* wantq, logical* wantz, integer* n, real* a, integer* lda, real* b, integer* ldb, real* q, integer* ldq, real* z, integer* ldz, integer* ifst, integer* ilst, real* work, integer* lwork, integer* info);


static VALUE
rblapack_stgexc(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantq;
  logical wantq; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_q;
  real *q; 
  VALUE rblapack_ldq;
  integer ldq; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_ifst;
  integer ifst; 
  VALUE rblapack_ilst;
  integer ilst; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_b_out__;
  real *b_out__;
  VALUE rblapack_q_out__;
  real *q_out__;
  VALUE rblapack_z_out__;
  real *z_out__;

  integer lda;
  integer n;
  integer ldb;
  integer ldz;

  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, q, z, ifst, ilst = NumRu::Lapack.stgexc( wantq, wantz, a, b, q, ldq, z, ifst, ilst, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, IFST, ILST, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  STGEXC reorders the generalized real Schur decomposition of a real\n*  matrix pair (A,B) using an orthogonal equivalence transformation\n*\n*                 (A, B) = Q * (A, B) * Z',\n*\n*  so that the diagonal block of (A, B) with row index IFST is moved\n*  to row ILST.\n*\n*  (A, B) must be in generalized real Schur canonical form (as returned\n*  by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2\n*  diagonal blocks. B is upper triangular.\n*\n*  Optionally, the matrices Q and Z of generalized Schur vectors are\n*  updated.\n*\n*         Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n*         Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n*\n*\n\n*  Arguments\n*  =========\n*\n*  WANTQ   (input) LOGICAL\n*          .TRUE. : update the left transformation matrix Q;\n*          .FALSE.: do not update Q.\n*\n*  WANTZ   (input) LOGICAL\n*          .TRUE. : update the right transformation matrix Z;\n*          .FALSE.: do not update Z.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B. N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the matrix A in generalized real Schur canonical\n*          form.\n*          On exit, the updated matrix A, again in generalized\n*          real Schur canonical form.\n*\n*  LDA     (input)  INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  B       (input/output) REAL array, dimension (LDB,N)\n*          On entry, the matrix B in generalized real Schur canonical\n*          form (A,B).\n*          On exit, the updated matrix B, again in generalized\n*          real Schur canonical form (A,B).\n*\n*  LDB     (input)  INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  Q       (input/output) REAL array, dimension (LDZ,N)\n*          On entry, if WANTQ = .TRUE., the orthogonal matrix Q.\n*          On exit, the updated matrix Q.\n*          If WANTQ = .FALSE., Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q. LDQ >= 1.\n*          If WANTQ = .TRUE., LDQ >= N.\n*\n*  Z       (input/output) REAL array, dimension (LDZ,N)\n*          On entry, if WANTZ = .TRUE., the orthogonal matrix Z.\n*          On exit, the updated matrix Z.\n*          If WANTZ = .FALSE., Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z. LDZ >= 1.\n*          If WANTZ = .TRUE., LDZ >= N.\n*\n*  IFST    (input/output) INTEGER\n*  ILST    (input/output) INTEGER\n*          Specify the reordering of the diagonal blocks of (A, B).\n*          The block with row index IFST is moved to row ILST, by a\n*          sequence of swapping between adjacent blocks.\n*          On exit, if IFST pointed on entry to the second row of\n*          a 2-by-2 block, it is changed to point to the first row;\n*          ILST always points to the first row of the block in its\n*          final position (which may differ from its input value by\n*          +1 or -1). 1 <= IFST, ILST <= N.\n*\n*  WORK    (workspace/output) REAL 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 >= 1 when N <= 1, otherwise LWORK >= 4*N + 16.\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*           =1:  The transformed matrix pair (A, B) would be too far\n*                from generalized Schur form; the problem is ill-\n*                conditioned. (A, B) may have been partially reordered,\n*                and ILST points to the first row of the current\n*                position of the block being moved.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n*      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n*      M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n*      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, a, b, q, z, ifst, ilst = NumRu::Lapack.stgexc( wantq, wantz, a, b, q, ldq, z, ifst, ilst, [: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_wantq = argv[0];
  rblapack_wantz = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  rblapack_q = argv[4];
  rblapack_ldq = argv[5];
  rblapack_z = argv[6];
  rblapack_ifst = argv[7];
  rblapack_ilst = 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;
  }

  wantq = (rblapack_wantq == Qtrue);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (5th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_q) != NA_SFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
  q = NA_PTR_TYPE(rblapack_q, real*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (7th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_z) != ldz)
    rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of q");
  if (NA_SHAPE1(rblapack_z) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  ilst = NUM2INT(rblapack_ilst);
  wantz = (rblapack_wantz == Qtrue);
  ldq = NUM2INT(rblapack_ldq);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (rblapack_lwork == Qnil)
    lwork = n<=1 ? 1 : 4*n+16;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ifst = NUM2INT(rblapack_ifst);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
  MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
  MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  stgexc_(&wantq, &wantz, &n, a, &lda, b, &ldb, q, &ldq, z, &ldz, &ifst, &ilst, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  rblapack_ifst = INT2NUM(ifst);
  rblapack_ilst = INT2NUM(ilst);
  return rb_ary_new3(8, rblapack_work, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z, rblapack_ifst, rblapack_ilst);
}

void
init_lapack_stgexc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "stgexc", rblapack_stgexc, -1);
}
ruby-lapack-1.7.2/ext/iladlc.c0000644000175000017500000000460712502221015015760 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern integer iladlc_(integer* m, integer* n, doublereal* a, integer* lda);


static VALUE
rblapack_iladlc(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack___out__;
  integer __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  __out__ = NumRu::Lapack.iladlc( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      INTEGER FUNCTION ILADLC( M, N, A, LDA )\n\n*  Purpose\n*  =======\n*\n*  ILADLC scans A for its last non-zero column.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*          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\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.iladlc( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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*);

  __out__ = iladlc_(&m, &n, a, &lda);

  rblapack___out__ = INT2NUM(__out__);
  return rblapack___out__;
}

void
init_lapack_iladlc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "iladlc", rblapack_iladlc, -1);
}
ruby-lapack-1.7.2/ext/slagtm.c0000644000175000017500000001455412502221024016021 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slagtm_(char* trans, integer* n, integer* nrhs, real* alpha, real* dl, real* d, real* du, real* x, integer* ldx, real* beta, real* b, integer* ldb);


static VALUE
rblapack_slagtm(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_alpha;
  real alpha; 
  VALUE rblapack_dl;
  real *dl; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_du;
  real *du; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_beta;
  real beta; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_b_out__;
  real *b_out__;

  integer n;
  integer ldx;
  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  b = NumRu::Lapack.slagtm( trans, alpha, dl, d, du, x, beta, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, B, LDB )\n\n*  Purpose\n*  =======\n*\n*  SLAGTM performs a matrix-vector product of the form\n*\n*     B := alpha * A * X + beta * B\n*\n*  where A is a tridiagonal matrix of order N, B and X are N by NRHS\n*  matrices, and alpha and beta are real scalars, each of which may be\n*  0., 1., or -1.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the operation applied to A.\n*          = 'N':  No transpose, B := alpha * A * X + beta * B\n*          = 'T':  Transpose,    B := alpha * A'* X + beta * B\n*          = 'C':  Conjugate transpose = Transpose\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices X and B.\n*\n*  ALPHA   (input) REAL\n*          The scalar alpha.  ALPHA must be 0., 1., or -1.; otherwise,\n*          it is assumed to be 0.\n*\n*  DL      (input) REAL array, dimension (N-1)\n*          The (n-1) sub-diagonal elements of T.\n*\n*  D       (input) REAL array, dimension (N)\n*          The diagonal elements of T.\n*\n*  DU      (input) REAL array, dimension (N-1)\n*          The (n-1) super-diagonal elements of T.\n*\n*  X       (input) REAL array, dimension (LDX,NRHS)\n*          The N by NRHS matrix X.\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(N,1).\n*\n*  BETA    (input) REAL\n*          The scalar beta.  BETA must be 0., 1., or -1.; otherwise,\n*          it is assumed to be 1.\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the N by NRHS matrix B.\n*          On exit, B is overwritten by the matrix expression\n*          B := alpha * A * X + beta * B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(N,1).\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  b = NumRu::Lapack.slagtm( trans, alpha, dl, d, du, x, beta, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_trans = argv[0];
  rblapack_alpha = argv[1];
  rblapack_dl = argv[2];
  rblapack_d = argv[3];
  rblapack_du = argv[4];
  rblapack_x = argv[5];
  rblapack_beta = argv[6];
  rblapack_b = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  alpha = (real)NUM2DBL(rblapack_alpha);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (5th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_SFLOAT)
    rblapack_du = na_change_type(rblapack_du, NA_SFLOAT);
  du = NA_PTR_TYPE(rblapack_du, real*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (3th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_SFLOAT)
    rblapack_dl = na_change_type(rblapack_dl, NA_SFLOAT);
  dl = NA_PTR_TYPE(rblapack_dl, real*);
  beta = (real)NUM2DBL(rblapack_beta);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  slagtm_(&trans, &n, &nrhs, &alpha, dl, d, du, x, &ldx, &beta, b, &ldb);

  return rblapack_b;
}

void
init_lapack_slagtm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slagtm", rblapack_slagtm, -1);
}
ruby-lapack-1.7.2/ext/dlansp.c0000644000175000017500000001062512502221020016002 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal dlansp_(char* norm, char* uplo, integer* n, doublereal* ap, doublereal* work);


static VALUE
rblapack_dlansp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack___out__;
  doublereal __out__; 
  doublereal *work;

  integer lwork;

  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  __out__ = NumRu::Lapack.dlansp( norm, uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK )\n\n*  Purpose\n*  =======\n*\n*  DLANSP  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  real symmetric matrix A,  supplied in packed form.\n*\n*  Description\n*  ===========\n*\n*  DLANSP returns the value\n*\n*     DLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in DLANSP as described\n*          above.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is supplied.\n*          = 'U':  Upper triangular part of A is supplied\n*          = 'L':  Lower triangular part of A is supplied\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, DLANSP is\n*          set to zero.\n*\n*  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          The upper or lower triangle of the symmetric matrix A, packed\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n*          WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.dlansp( norm, uplo, n, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_n = argv[2];
  rblapack_ap = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  n = NUM2INT(rblapack_n);
  lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  work = ALLOC_N(doublereal, (MAX(1,lwork)));

  __out__ = dlansp_(&norm, &uplo, &n, ap, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_dlansp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlansp", rblapack_dlansp, -1);
}
ruby-lapack-1.7.2/ext/zlapmr.c0000644000175000017500000001044412502221015016031 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlapmr_(logical* forwrd, integer* m, integer* n, doublecomplex* x, integer* ldx, integer* k);


static VALUE
rblapack_zlapmr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_forwrd;
  logical forwrd; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_k;
  integer *k; 
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;
  VALUE rblapack_k_out__;
  integer *k_out__;

  integer ldx;
  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  x, k = NumRu::Lapack.zlapmr( forwrd, x, k, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAPMR( FORWRD, M, N, X, LDX, K )\n\n*  Purpose\n*  =======\n*\n*  ZLAPMR rearranges the rows of the M by N matrix X as specified\n*  by the permutation K(1),K(2),...,K(M) of the integers 1,...,M.\n*  If FORWRD = .TRUE.,  forward permutation:\n*\n*       X(K(I),*) is moved X(I,*) for I = 1,2,...,M.\n*\n*  If FORWRD = .FALSE., backward permutation:\n*\n*       X(I,*) is moved to X(K(I),*) for I = 1,2,...,M.\n*\n\n*  Arguments\n*  =========\n*\n*  FORWRD  (input) LOGICAL\n*          = .TRUE., forward permutation\n*          = .FALSE., backward permutation\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix X. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix X. N >= 0.\n*\n*  X       (input/output) COMPLEX*16 array, dimension (LDX,N)\n*          On entry, the M by N matrix X.\n*          On exit, X contains the permuted matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X, LDX >= MAX(1,M).\n*\n*  K       (input/output) INTEGER array, dimension (M)\n*          On entry, K contains the permutation vector. K is used as\n*          internal workspace, but reset to its original value on\n*          output.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, IN, J, JJ\n      COMPLEX*16         TEMP\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, k = NumRu::Lapack.zlapmr( forwrd, x, k, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_forwrd = argv[0];
  rblapack_x = argv[1];
  rblapack_k = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  forwrd = (rblapack_forwrd == Qtrue);
  if (!NA_IsNArray(rblapack_k))
    rb_raise(rb_eArgError, "k (3th argument) must be NArray");
  if (NA_RANK(rblapack_k) != 1)
    rb_raise(rb_eArgError, "rank of k (3th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_k);
  if (NA_TYPE(rblapack_k) != NA_LINT)
    rblapack_k = na_change_type(rblapack_k, NA_LINT);
  k = NA_PTR_TYPE(rblapack_k, integer*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  n = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = n;
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_k_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  k_out__ = NA_PTR_TYPE(rblapack_k_out__, integer*);
  MEMCPY(k_out__, k, integer, NA_TOTAL(rblapack_k));
  rblapack_k = rblapack_k_out__;
  k = k_out__;

  zlapmr_(&forwrd, &m, &n, x, &ldx, k);

  return rb_ary_new3(2, rblapack_x, rblapack_k);
}

void
init_lapack_zlapmr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlapmr", rblapack_zlapmr, -1);
}
ruby-lapack-1.7.2/ext/zla_hercond_x.c0000644000175000017500000001641312502221016017346 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal zla_hercond_x_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublecomplex* x, integer* info, doublecomplex* work, doublereal* rwork);


static VALUE
rblapack_zla_hercond_x(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_rwork;
  doublereal *rwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack___out__;
  doublereal __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  info, __out__ = NumRu::Lapack.zla_hercond_x( uplo, a, af, ipiv, x, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION ZLA_HERCOND_X( UPLO, N, A, LDA, AF, LDAF, IPIV, X, INFO, WORK, RWORK )\n\n*  Purpose\n*  =======\n*\n*     ZLA_HERCOND_X computes the infinity norm condition number of\n*     op(A) * diag(X) where X is a COMPLEX*16 vector.\n*\n\n*  Arguments\n*  =========\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     A       (input) COMPLEX*16 array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX*16 array, dimension (LDAF,N)\n*     The block diagonal matrix D and the multipliers used to\n*     obtain the factor U or L as computed by ZHETRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     Details of the interchanges and the block structure of D\n*     as determined by CHETRF.\n*\n*     X       (input) COMPLEX*16 array, dimension (N)\n*     The vector X in the formula op(A) * diag(X).\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit.\n*     i > 0:  The ith argument is invalid.\n*\n*     WORK    (input) COMPLEX*16 array, dimension (2*N).\n*     Workspace.\n*\n*     RWORK   (input) DOUBLE PRECISION array, dimension (N).\n*     Workspace.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            KASE, I, J\n      DOUBLE PRECISION   AINVNM, ANORM, TMP\n      LOGICAL            UP\n      COMPLEX*16         ZDUM\n*     ..\n*     .. Local Arrays ..\n      INTEGER            ISAVE( 3 )\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           ZLACN2, ZHETRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX\n*     ..\n*     .. Statement Functions ..\n      DOUBLE PRECISION CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, __out__ = NumRu::Lapack.zla_hercond_x( uplo, a, af, ipiv, x, work, rwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_x = argv[4];
  rblapack_work = argv[5];
  rblapack_rwork = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (5th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  if (!NA_IsNArray(rblapack_rwork))
    rb_raise(rb_eArgError, "rwork (7th argument) must be NArray");
  if (NA_RANK(rblapack_rwork) != 1)
    rb_raise(rb_eArgError, "rank of rwork (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_rwork) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_rwork) != NA_DFLOAT)
    rblapack_rwork = na_change_type(rblapack_rwork, NA_DFLOAT);
  rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (6th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
  if (NA_TYPE(rblapack_work) != NA_DCOMPLEX)
    rblapack_work = na_change_type(rblapack_work, NA_DCOMPLEX);
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);

  __out__ = zla_hercond_x_(&uplo, &n, a, &lda, af, &ldaf, ipiv, x, &info, work, rwork);

  rblapack_info = INT2NUM(info);
  rblapack___out__ = rb_float_new((double)__out__);
  return rb_ary_new3(2, rblapack_info, rblapack___out__);
}

void
init_lapack_zla_hercond_x(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zla_hercond_x", rblapack_zla_hercond_x, -1);
}
ruby-lapack-1.7.2/ext/dtzrzf.c0000644000175000017500000001417412502221024016053 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtzrzf_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dtzrzf(int argc, VALUE *argv, VALUE self){
  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;
  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, work, info, a = NumRu::Lapack.dtzrzf( a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTZRZF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A\n*  to upper triangular form by means of orthogonal transformations.\n*\n*  The upper trapezoidal matrix A is factored as\n*\n*     A = ( R  0 ) * Z,\n*\n*  where Z is an N-by-N orthogonal matrix and R is an M-by-M upper\n*  triangular matrix.\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 >= M.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the leading M-by-N upper trapezoidal part of the\n*          array A must contain the matrix to be factorized.\n*          On exit, the leading M-by-M upper triangular part of A\n*          contains the upper triangular matrix R, and elements M+1 to\n*          N of the first M rows of A, with the array TAU, represent the\n*          orthogonal matrix Z as a product of M elementary reflectors.\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 (M)\n*          The scalar factors of the elementary reflectors.\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\n*          the 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*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n*  The factorization is obtained by Householder's method.  The kth\n*  transformation matrix, Z( k ), which is used to introduce zeros into\n*  the ( m - k + 1 )th row of A, is given in the form\n*\n*     Z( k ) = ( I     0   ),\n*              ( 0  T( k ) )\n*\n*  where\n*\n*     T( k ) = I - tau*u( k )*u( k )',   u( k ) = (   1    ),\n*                                                 (   0    )\n*                                                 ( z( k ) )\n*\n*  tau is a scalar and z( k ) is an ( n - m ) element vector.\n*  tau and z( k ) are chosen to annihilate the elements of the kth row\n*  of X.\n*\n*  The scalar tau is returned in the kth element of TAU and the vector\n*  u( k ) in the kth row of A, such that the elements of z( k ) are\n*  in  a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n*  the upper triangular part of A.\n*\n*  Z is given by\n*\n*     Z =  Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, work, info, a = NumRu::Lapack.dtzrzf( a, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 1 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
  rblapack_a = argv[0];
  if (argc == 2) {
    rblapack_lwork = argv[1];
  } 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 (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;
  if (rblapack_lwork == Qnil)
    lwork = m;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;

  dtzrzf_(&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_dtzrzf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtzrzf", rblapack_dtzrzf, -1);
}
ruby-lapack-1.7.2/ext/sorm2l.c0000644000175000017500000001416312502221021015741 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sorm2l_(char* side, char* trans, integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* c, integer* ldc, real* work, integer* info);


static VALUE
rblapack_sorm2l(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  real *c_out__;
  real *work;

  integer lda;
  integer k;
  integer ldc;
  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  info, c = NumRu::Lapack.sorm2l( side, trans, m, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SORM2L overwrites the general real m by n matrix C with\n*\n*        Q * C  if SIDE = 'L' and TRANS = 'N', or\n*\n*        Q'* C  if SIDE = 'L' and TRANS = 'T', or\n*\n*        C * Q  if SIDE = 'R' and TRANS = 'N', or\n*\n*        C * Q' if SIDE = 'R' and TRANS = 'T',\n*\n*  where Q is a real orthogonal matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(k) . . . H(2) H(1)\n*\n*  as returned by SGEQLF. Q is of order m if SIDE = 'L' and of order n\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q' from the Left\n*          = 'R': apply Q or Q' from the Right\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': apply Q  (No transpose)\n*          = 'T': apply Q' (Transpose)\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) REAL array, dimension (LDA,K)\n*          The i-th column must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          SGEQLF in the last k columns of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*          If SIDE = 'L', LDA >= max(1,M);\n*          if SIDE = 'R', LDA >= max(1,N).\n*\n*  TAU     (input) REAL array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by SGEQLF.\n*\n*  C       (input/output) REAL array, dimension (LDC,N)\n*          On entry, the m by n matrix C.\n*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) REAL array, dimension\n*                                   (N) if SIDE = 'L',\n*                                   (M) if SIDE = 'R'\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, c = NumRu::Lapack.sorm2l( side, trans, m, a, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_m = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != k)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  sorm2l_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_c);
}

void
init_lapack_sorm2l(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sorm2l", rblapack_sorm2l, -1);
}
ruby-lapack-1.7.2/ext/zpbsvx.c0000644000175000017500000004061012502221017016060 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zpbsvx_(char* fact, char* uplo, integer* n, integer* kd, integer* nrhs, doublecomplex* ab, integer* ldab, doublecomplex* afb, integer* ldafb, char* equed, doublereal* s, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zpbsvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_afb;
  doublecomplex *afb; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublecomplex *ab_out__;
  VALUE rblapack_afb_out__;
  doublecomplex *afb_out__;
  VALUE rblapack_s_out__;
  doublereal *s_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer ldab;
  integer n;
  integer ldafb;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, info, ab, afb, equed, s, b = NumRu::Lapack.zpbsvx( fact, uplo, kd, ab, afb, equed, s, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPBSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to\n*  compute the solution to a complex system of linear equations\n*     A * X = B,\n*  where A is an N-by-N Hermitian positive definite band matrix and X\n*  and B are N-by-NRHS matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'E', real scaling factors are computed to equilibrate\n*     the system:\n*        diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n*  2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n*     factor the matrix A (after equilibration if FACT = 'E') as\n*        A = U**H * U,  if UPLO = 'U', or\n*        A = L * L**H,  if UPLO = 'L',\n*     where U is an upper triangular band matrix, and L is a lower\n*     triangular band matrix.\n*\n*  3. If the leading i-by-i principal minor is not positive definite,\n*     then the routine returns with INFO = i. Otherwise, the factored\n*     form of A is used to estimate the condition number of the matrix\n*     A.  If the reciprocal of the condition number is less than machine\n*     precision, INFO = N+1 is returned as a warning, but the routine\n*     still goes on to solve for X and compute error bounds as\n*     described below.\n*\n*  4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  5. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n*  6. If equilibration was used, the matrix X is premultiplied by\n*     diag(S) so that it solves the original system before\n*     equilibration.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of the matrix A is\n*          supplied on entry, and if not, whether the matrix A should be\n*          equilibrated before it is factored.\n*          = 'F':  On entry, AFB contains the factored form of A.\n*                  If EQUED = 'Y', the matrix A has been equilibrated\n*                  with scaling factors given by S.  AB and AFB will not\n*                  be modified.\n*          = 'N':  The matrix A will be copied to AFB and factored.\n*          = 'E':  The matrix A will be equilibrated if necessary, then\n*                  copied to AFB and factored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right-hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix A, stored in the first KD+1 rows of the array, except\n*          if FACT = 'F' and EQUED = 'Y', then A must contain the\n*          equilibrated matrix diag(S)*A*diag(S).  The j-th column of A\n*          is stored in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(N,j+KD).\n*          See below for further details.\n*\n*          On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n*          diag(S)*A*diag(S).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array A.  LDAB >= KD+1.\n*\n*  AFB     (input or output) COMPLEX*16 array, dimension (LDAFB,N)\n*          If FACT = 'F', then AFB is an input argument and on entry\n*          contains the triangular factor U or L from the Cholesky\n*          factorization A = U**H*U or A = L*L**H of the band matrix\n*          A, in the same storage format as A (see AB).  If EQUED = 'Y',\n*          then AFB is the factored form of the equilibrated matrix A.\n*\n*          If FACT = 'N', then AFB is an output argument and on exit\n*          returns the triangular factor U or L from the Cholesky\n*          factorization A = U**H*U or A = L*L**H.\n*\n*          If FACT = 'E', then AFB is an output argument and on exit\n*          returns the triangular factor U or L from the Cholesky\n*          factorization A = U**H*U or A = L*L**H of the equilibrated\n*          matrix A (see the description of A for the form of the\n*          equilibrated matrix).\n*\n*  LDAFB   (input) INTEGER\n*          The leading dimension of the array AFB.  LDAFB >= KD+1.\n*\n*  EQUED   (input or output) CHARACTER*1\n*          Specifies the form of equilibration that was done.\n*          = 'N':  No equilibration (always true if FACT = 'N').\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*          EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*          output argument.\n*\n*  S       (input or output) DOUBLE PRECISION array, dimension (N)\n*          The scale factors for A; not accessed if EQUED = 'N'.  S is\n*          an input argument if FACT = 'F'; otherwise, S is an output\n*          argument.  If FACT = 'F' and EQUED = 'Y', each element of S\n*          must be positive.\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n*          B is overwritten by diag(S) * B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) COMPLEX*16 array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n*          the original system of equations.  Note that if EQUED = 'Y',\n*          A and B are modified on exit, and the solution to the\n*          equilibrated system is inv(diag(S))*X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The estimate of the reciprocal condition number of the matrix\n*          A after equilibration (if done).  If RCOND is less than the\n*          machine precision (in particular, if RCOND = 0), the matrix\n*          is singular to working precision.  This condition is\n*          indicated by a return code of INFO > 0.\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\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, and i is\n*                <= N:  the leading minor of order i of A is\n*                       not positive definite, so the factorization\n*                       could not be completed, and the solution has not\n*                       been computed. RCOND = 0 is returned.\n*                = N+1: U is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  N = 6, KD = 2, and UPLO = 'U':\n*\n*  Two-dimensional storage of the Hermitian matrix A:\n*\n*     a11  a12  a13\n*          a22  a23  a24\n*               a33  a34  a35\n*                    a44  a45  a46\n*                         a55  a56\n*     (aij=conjg(aji))         a66\n*\n*  Band storage of the upper triangle of A:\n*\n*      *    *   a13  a24  a35  a46\n*      *   a12  a23  a34  a45  a56\n*     a11  a22  a33  a44  a55  a66\n*\n*  Similarly, if UPLO = 'L' the format of A is as follows:\n*\n*     a11  a22  a33  a44  a55  a66\n*     a21  a32  a43  a54  a65   *\n*     a31  a42  a53  a64   *    *\n*\n*  Array elements marked * are not used by the routine.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, info, ab, afb, equed, s, b = NumRu::Lapack.zpbsvx( fact, uplo, kd, ab, afb, equed, s, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_kd = argv[2];
  rblapack_ab = argv[3];
  rblapack_afb = argv[4];
  rblapack_equed = argv[5];
  rblapack_s = argv[6];
  rblapack_b = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  kd = NUM2INT(rblapack_kd);
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
  ldafb = NA_SHAPE0(rblapack_afb);
  n = NA_SHAPE1(rblapack_afb);
  if (NA_TYPE(rblapack_afb) != NA_DCOMPLEX)
    rblapack_afb = na_change_type(rblapack_afb, NA_DCOMPLEX);
  afb = NA_PTR_TYPE(rblapack_afb, doublecomplex*);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (7th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  ldx = MAX(1,n);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
  MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldafb;
    shape[1] = n;
    rblapack_afb_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  afb_out__ = NA_PTR_TYPE(rblapack_afb_out__, doublecomplex*);
  MEMCPY(afb_out__, afb, doublecomplex, NA_TOTAL(rblapack_afb));
  rblapack_afb = rblapack_afb_out__;
  afb = afb_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
  MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (n));

  zpbsvx_(&fact, &uplo, &n, &kd, &nrhs, ab, &ldab, afb, &ldafb, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_ab, rblapack_afb, rblapack_equed, rblapack_s, rblapack_b);
}

void
init_lapack_zpbsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zpbsvx", rblapack_zpbsvx, -1);
}
ruby-lapack-1.7.2/ext/dlar1v.c0000644000175000017500000002554612502221014015725 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlar1v_(integer* n, integer* b1, integer* bn, doublereal* lambda, doublereal* d, doublereal* l, doublereal* ld, doublereal* lld, doublereal* pivmin, doublereal* gaptol, doublereal* z, logical* wantnc, integer* negcnt, doublereal* ztz, doublereal* mingma, integer* r, integer* isuppz, doublereal* nrminv, doublereal* resid, doublereal* rqcorr, doublereal* work);


static VALUE
rblapack_dlar1v(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_b1;
  integer b1; 
  VALUE rblapack_bn;
  integer bn; 
  VALUE rblapack_lambda;
  doublereal lambda; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_l;
  doublereal *l; 
  VALUE rblapack_ld;
  doublereal *ld; 
  VALUE rblapack_lld;
  doublereal *lld; 
  VALUE rblapack_pivmin;
  doublereal pivmin; 
  VALUE rblapack_gaptol;
  doublereal gaptol; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_wantnc;
  logical wantnc; 
  VALUE rblapack_r;
  integer r; 
  VALUE rblapack_negcnt;
  integer negcnt; 
  VALUE rblapack_ztz;
  doublereal ztz; 
  VALUE rblapack_mingma;
  doublereal mingma; 
  VALUE rblapack_isuppz;
  integer *isuppz; 
  VALUE rblapack_nrminv;
  doublereal nrminv; 
  VALUE rblapack_resid;
  doublereal resid; 
  VALUE rblapack_rqcorr;
  doublereal rqcorr; 
  VALUE rblapack_z_out__;
  doublereal *z_out__;
  doublereal *work;

  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  negcnt, ztz, mingma, isuppz, nrminv, resid, rqcorr, z, r = NumRu::Lapack.dlar1v( b1, bn, lambda, d, l, ld, lld, pivmin, gaptol, z, wantnc, r, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD, PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, R, ISUPPZ, NRMINV, RESID, RQCORR, WORK )\n\n*  Purpose\n*  =======\n*\n*  DLAR1V computes the (scaled) r-th column of the inverse of\n*  the sumbmatrix in rows B1 through BN of the tridiagonal matrix\n*  L D L^T - sigma I. When sigma is close to an eigenvalue, the\n*  computed vector is an accurate eigenvector. Usually, r corresponds\n*  to the index where the eigenvector is largest in magnitude.\n*  The following steps accomplish this computation :\n*  (a) Stationary qd transform,  L D L^T - sigma I = L(+) D(+) L(+)^T,\n*  (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T,\n*  (c) Computation of the diagonal elements of the inverse of\n*      L D L^T - sigma I by combining the above transforms, and choosing\n*      r as the index where the diagonal of the inverse is (one of the)\n*      largest in magnitude.\n*  (d) Computation of the (scaled) r-th column of the inverse using the\n*      twisted factorization obtained by combining the top part of the\n*      the stationary and the bottom part of the progressive transform.\n*\n\n*  Arguments\n*  =========\n*\n*  N        (input) INTEGER\n*           The order of the matrix L D L^T.\n*\n*  B1       (input) INTEGER\n*           First index of the submatrix of L D L^T.\n*\n*  BN       (input) INTEGER\n*           Last index of the submatrix of L D L^T.\n*\n*  LAMBDA    (input) DOUBLE PRECISION\n*           The shift. In order to compute an accurate eigenvector,\n*           LAMBDA should be a good approximation to an eigenvalue\n*           of L D L^T.\n*\n*  L        (input) DOUBLE PRECISION array, dimension (N-1)\n*           The (n-1) subdiagonal elements of the unit bidiagonal matrix\n*           L, in elements 1 to N-1.\n*\n*  D        (input) DOUBLE PRECISION array, dimension (N)\n*           The n diagonal elements of the diagonal matrix D.\n*\n*  LD       (input) DOUBLE PRECISION array, dimension (N-1)\n*           The n-1 elements L(i)*D(i).\n*\n*  LLD      (input) DOUBLE PRECISION array, dimension (N-1)\n*           The n-1 elements L(i)*L(i)*D(i).\n*\n*  PIVMIN   (input) DOUBLE PRECISION\n*           The minimum pivot in the Sturm sequence.\n*\n*  GAPTOL   (input) DOUBLE PRECISION\n*           Tolerance that indicates when eigenvector entries are negligible\n*           w.r.t. their contribution to the residual.\n*\n*  Z        (input/output) DOUBLE PRECISION array, dimension (N)\n*           On input, all entries of Z must be set to 0.\n*           On output, Z contains the (scaled) r-th column of the\n*           inverse. The scaling is such that Z(R) equals 1.\n*\n*  WANTNC   (input) LOGICAL\n*           Specifies whether NEGCNT has to be computed.\n*\n*  NEGCNT   (output) INTEGER\n*           If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin\n*           in the  matrix factorization L D L^T, and NEGCNT = -1 otherwise.\n*\n*  ZTZ      (output) DOUBLE PRECISION\n*           The square of the 2-norm of Z.\n*\n*  MINGMA   (output) DOUBLE PRECISION\n*           The reciprocal of the largest (in magnitude) diagonal\n*           element of the inverse of L D L^T - sigma I.\n*\n*  R        (input/output) INTEGER\n*           The twist index for the twisted factorization used to\n*           compute Z.\n*           On input, 0 <= R <= N. If R is input as 0, R is set to\n*           the index where (L D L^T - sigma I)^{-1} is largest\n*           in magnitude. If 1 <= R <= N, R is unchanged.\n*           On output, R contains the twist index used to compute Z.\n*           Ideally, R designates the position of the maximum entry in the\n*           eigenvector.\n*\n*  ISUPPZ   (output) INTEGER array, dimension (2)\n*           The support of the vector in Z, i.e., the vector Z is\n*           nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ).\n*\n*  NRMINV   (output) DOUBLE PRECISION\n*           NRMINV = 1/SQRT( ZTZ )\n*\n*  RESID    (output) DOUBLE PRECISION\n*           The residual of the FP vector.\n*           RESID = ABS( MINGMA )/SQRT( ZTZ )\n*\n*  RQCORR   (output) DOUBLE PRECISION\n*           The Rayleigh Quotient correction to LAMBDA.\n*           RQCORR = MINGMA*TMP\n*\n*  WORK     (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Beresford Parlett, University of California, Berkeley, USA\n*     Jim Demmel, University of California, Berkeley, USA\n*     Inderjit Dhillon, University of Texas, Austin, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  negcnt, ztz, mingma, isuppz, nrminv, resid, rqcorr, z, r = NumRu::Lapack.dlar1v( b1, bn, lambda, d, l, ld, lld, pivmin, gaptol, z, wantnc, r, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_b1 = argv[0];
  rblapack_bn = argv[1];
  rblapack_lambda = argv[2];
  rblapack_d = argv[3];
  rblapack_l = argv[4];
  rblapack_ld = argv[5];
  rblapack_lld = argv[6];
  rblapack_pivmin = argv[7];
  rblapack_gaptol = argv[8];
  rblapack_z = argv[9];
  rblapack_wantnc = argv[10];
  rblapack_r = argv[11];
  if (argc == 12) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  b1 = NUM2INT(rblapack_b1);
  lambda = NUM2DBL(rblapack_lambda);
  pivmin = NUM2DBL(rblapack_pivmin);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (10th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (10th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  r = NUM2INT(rblapack_r);
  bn = NUM2INT(rblapack_bn);
  gaptol = NUM2DBL(rblapack_gaptol);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of z");
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_ld))
    rb_raise(rb_eArgError, "ld (6th argument) must be NArray");
  if (NA_RANK(rblapack_ld) != 1)
    rb_raise(rb_eArgError, "rank of ld (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ld) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of ld must be %d", n-1);
  if (NA_TYPE(rblapack_ld) != NA_DFLOAT)
    rblapack_ld = na_change_type(rblapack_ld, NA_DFLOAT);
  ld = NA_PTR_TYPE(rblapack_ld, doublereal*);
  wantnc = (rblapack_wantnc == Qtrue);
  if (!NA_IsNArray(rblapack_l))
    rb_raise(rb_eArgError, "l (5th argument) must be NArray");
  if (NA_RANK(rblapack_l) != 1)
    rb_raise(rb_eArgError, "rank of l (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_l) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of l must be %d", n-1);
  if (NA_TYPE(rblapack_l) != NA_DFLOAT)
    rblapack_l = na_change_type(rblapack_l, NA_DFLOAT);
  l = NA_PTR_TYPE(rblapack_l, doublereal*);
  if (!NA_IsNArray(rblapack_lld))
    rb_raise(rb_eArgError, "lld (7th argument) must be NArray");
  if (NA_RANK(rblapack_lld) != 1)
    rb_raise(rb_eArgError, "rank of lld (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_lld) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of lld must be %d", n-1);
  if (NA_TYPE(rblapack_lld) != NA_DFLOAT)
    rblapack_lld = na_change_type(rblapack_lld, NA_DFLOAT);
  lld = NA_PTR_TYPE(rblapack_lld, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 2;
    rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_z_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
  MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  work = ALLOC_N(doublereal, (4*n));

  dlar1v_(&n, &b1, &bn, &lambda, d, l, ld, lld, &pivmin, &gaptol, z, &wantnc, &negcnt, &ztz, &mingma, &r, isuppz, &nrminv, &resid, &rqcorr, work);

  free(work);
  rblapack_negcnt = INT2NUM(negcnt);
  rblapack_ztz = rb_float_new((double)ztz);
  rblapack_mingma = rb_float_new((double)mingma);
  rblapack_nrminv = rb_float_new((double)nrminv);
  rblapack_resid = rb_float_new((double)resid);
  rblapack_rqcorr = rb_float_new((double)rqcorr);
  rblapack_r = INT2NUM(r);
  return rb_ary_new3(9, rblapack_negcnt, rblapack_ztz, rblapack_mingma, rblapack_isuppz, rblapack_nrminv, rblapack_resid, rblapack_rqcorr, rblapack_z, rblapack_r);
}

void
init_lapack_dlar1v(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlar1v", rblapack_dlar1v, -1);
}
ruby-lapack-1.7.2/ext/zgtrfs.c0000644000175000017500000002733312502221021016045 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgtrfs_(char* trans, integer* n, integer* nrhs, doublecomplex* dl, doublecomplex* d, doublecomplex* du, doublecomplex* dlf, doublecomplex* df, doublecomplex* duf, doublecomplex* du2, integer* ipiv, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zgtrfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_dl;
  doublecomplex *dl; 
  VALUE rblapack_d;
  doublecomplex *d; 
  VALUE rblapack_du;
  doublecomplex *du; 
  VALUE rblapack_dlf;
  doublecomplex *dlf; 
  VALUE rblapack_df;
  doublecomplex *df; 
  VALUE rblapack_duf;
  doublecomplex *duf; 
  VALUE rblapack_du2;
  doublecomplex *du2; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.zgtrfs( trans, dl, d, du, dlf, df, duf, du2, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGTRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is tridiagonal, and provides\n*  error bounds and backward error estimates for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  DL      (input) COMPLEX*16 array, dimension (N-1)\n*          The (n-1) subdiagonal elements of A.\n*\n*  D       (input) COMPLEX*16 array, dimension (N)\n*          The diagonal elements of A.\n*\n*  DU      (input) COMPLEX*16 array, dimension (N-1)\n*          The (n-1) superdiagonal elements of A.\n*\n*  DLF     (input) COMPLEX*16 array, dimension (N-1)\n*          The (n-1) multipliers that define the matrix L from the\n*          LU factorization of A as computed by ZGTTRF.\n*\n*  DF      (input) COMPLEX*16 array, dimension (N)\n*          The n diagonal elements of the upper triangular matrix U from\n*          the LU factorization of A.\n*\n*  DUF     (input) COMPLEX*16 array, dimension (N-1)\n*          The (n-1) elements of the first superdiagonal of U.\n*\n*  DU2     (input) COMPLEX*16 array, dimension (N-2)\n*          The (n-2) elements of the second superdiagonal of U.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices; for 1 <= i <= n, row i of the matrix was\n*          interchanged with row IPIV(i).  IPIV(i) will always be either\n*          i or i+1; IPIV(i) = i indicates a row interchange was not\n*          required.\n*\n*  B       (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) COMPLEX*16 array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by ZGTTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.zgtrfs( trans, dl, d, du, dlf, df, duf, du2, ipiv, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 11 && argc != 11)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
  rblapack_trans = argv[0];
  rblapack_dl = argv[1];
  rblapack_d = argv[2];
  rblapack_du = argv[3];
  rblapack_dlf = argv[4];
  rblapack_df = argv[5];
  rblapack_duf = argv[6];
  rblapack_du2 = argv[7];
  rblapack_ipiv = argv[8];
  rblapack_b = argv[9];
  rblapack_x = argv[10];
  if (argc == 11) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DCOMPLEX)
    rblapack_d = na_change_type(rblapack_d, NA_DCOMPLEX);
  d = NA_PTR_TYPE(rblapack_d, doublecomplex*);
  if (!NA_IsNArray(rblapack_df))
    rb_raise(rb_eArgError, "df (6th argument) must be NArray");
  if (NA_RANK(rblapack_df) != 1)
    rb_raise(rb_eArgError, "rank of df (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_df) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of df must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_df) != NA_DCOMPLEX)
    rblapack_df = na_change_type(rblapack_df, NA_DCOMPLEX);
  df = NA_PTR_TYPE(rblapack_df, doublecomplex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (9th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (11th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (11th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_DCOMPLEX)
    rblapack_dl = na_change_type(rblapack_dl, NA_DCOMPLEX);
  dl = NA_PTR_TYPE(rblapack_dl, doublecomplex*);
  if (!NA_IsNArray(rblapack_dlf))
    rb_raise(rb_eArgError, "dlf (5th argument) must be NArray");
  if (NA_RANK(rblapack_dlf) != 1)
    rb_raise(rb_eArgError, "rank of dlf (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dlf) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dlf must be %d", n-1);
  if (NA_TYPE(rblapack_dlf) != NA_DCOMPLEX)
    rblapack_dlf = na_change_type(rblapack_dlf, NA_DCOMPLEX);
  dlf = NA_PTR_TYPE(rblapack_dlf, doublecomplex*);
  if (!NA_IsNArray(rblapack_du2))
    rb_raise(rb_eArgError, "du2 (8th argument) must be NArray");
  if (NA_RANK(rblapack_du2) != 1)
    rb_raise(rb_eArgError, "rank of du2 (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du2) != (n-2))
    rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
  if (NA_TYPE(rblapack_du2) != NA_DCOMPLEX)
    rblapack_du2 = na_change_type(rblapack_du2, NA_DCOMPLEX);
  du2 = NA_PTR_TYPE(rblapack_du2, doublecomplex*);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (4th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_DCOMPLEX)
    rblapack_du = na_change_type(rblapack_du, NA_DCOMPLEX);
  du = NA_PTR_TYPE(rblapack_du, doublecomplex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (10th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (10th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  if (!NA_IsNArray(rblapack_duf))
    rb_raise(rb_eArgError, "duf (7th argument) must be NArray");
  if (NA_RANK(rblapack_duf) != 1)
    rb_raise(rb_eArgError, "rank of duf (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_duf) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of duf must be %d", n-1);
  if (NA_TYPE(rblapack_duf) != NA_DCOMPLEX)
    rblapack_duf = na_change_type(rblapack_duf, NA_DCOMPLEX);
  duf = NA_PTR_TYPE(rblapack_duf, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (n));

  zgtrfs_(&trans, &n, &nrhs, dl, d, du, dlf, df, duf, du2, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_zgtrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgtrfs", rblapack_zgtrfs, -1);
}
ruby-lapack-1.7.2/ext/sgsvj1.c0000644000175000017500000003137512502221023015746 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgsvj1_(char* jobv, integer* m, integer* n, integer* n1, real* a, integer* lda, real* d, real* sva, integer* mv, real* v, integer* ldv, integer* eps, integer* sfmin, real* tol, integer* nsweep, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sgsvj1(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobv;
  char jobv; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_n1;
  integer n1; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_sva;
  real *sva; 
  VALUE rblapack_mv;
  integer mv; 
  VALUE rblapack_v;
  real *v; 
  VALUE rblapack_eps;
  integer eps; 
  VALUE rblapack_sfmin;
  integer sfmin; 
  VALUE rblapack_tol;
  real tol; 
  VALUE rblapack_nsweep;
  integer nsweep; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_sva_out__;
  real *sva_out__;
  VALUE rblapack_v_out__;
  real *v_out__;
  real *work;

  integer lda;
  integer n;
  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  info, a, d, sva, v = NumRu::Lapack.sgsvj1( jobv, m, n1, a, d, sva, mv, v, eps, sfmin, tol, nsweep, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGSVJ1 is called from SGESVJ as a pre-processor and that is its main\n*  purpose. It applies Jacobi rotations in the same way as SGESVJ does, but\n*  it targets only particular pivots and it does not check convergence\n*  (stopping criterion). Few tunning parameters (marked by [TP]) are\n*  available for the implementer.\n*\n*  Further Details\n*  ~~~~~~~~~~~~~~~\n*  SGSVJ1 applies few sweeps of Jacobi rotations in the column space of\n*  the input M-by-N matrix A. The pivot pairs are taken from the (1,2)\n*  off-diagonal block in the corresponding N-by-N Gram matrix A^T * A. The\n*  block-entries (tiles) of the (1,2) off-diagonal block are marked by the\n*  [x]'s in the following scheme:\n*\n*     | *   *   * [x] [x] [x]|\n*     | *   *   * [x] [x] [x]|    Row-cycling in the nblr-by-nblc [x] blocks.\n*     | *   *   * [x] [x] [x]|    Row-cyclic pivoting inside each [x] block.\n*     |[x] [x] [x] *   *   * |\n*     |[x] [x] [x] *   *   * |\n*     |[x] [x] [x] *   *   * |\n*\n*  In terms of the columns of A, the first N1 columns are rotated 'against'\n*  the remaining N-N1 columns, trying to increase the angle between the\n*  corresponding subspaces. The off-diagonal block is N1-by(N-N1) and it is\n*  tiled using quadratic tiles of side KBL. Here, KBL is a tunning parmeter.\n*  The number of sweeps is given in NSWEEP and the orthogonality threshold\n*  is given in TOL.\n*\n*  Contributors\n*  ~~~~~~~~~~~~\n*  Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)\n*\n\n*  Arguments\n*  =========\n*\n*  JOBV    (input) CHARACTER*1\n*          Specifies whether the output from this procedure is used\n*          to compute the matrix V:\n*          = 'V': the product of the Jacobi rotations is accumulated\n*                 by postmulyiplying the N-by-N array V.\n*                (See the description of V.)\n*          = 'A': the product of the Jacobi rotations is accumulated\n*                 by postmulyiplying the MV-by-N array V.\n*                (See the descriptions of MV and V.)\n*          = 'N': the Jacobi rotations are not accumulated.\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.\n*          M >= N >= 0.\n*\n*  N1      (input) INTEGER\n*          N1 specifies the 2 x 2 block partition, the first N1 columns are\n*          rotated 'against' the remaining N-N1 columns of A.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, M-by-N matrix A, such that A*diag(D) represents\n*          the input matrix.\n*          On exit,\n*          A_onexit * D_onexit represents the input matrix A*diag(D)\n*          post-multiplied by a sequence of Jacobi rotations, where the\n*          rotation threshold and the total number of sweeps are given in\n*          TOL and NSWEEP, respectively.\n*          (See the descriptions of N1, D, TOL and NSWEEP.)\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  D       (input/workspace/output) REAL array, dimension (N)\n*          The array D accumulates the scaling factors from the fast scaled\n*          Jacobi rotations.\n*          On entry, A*diag(D) represents the input matrix.\n*          On exit, A_onexit*diag(D_onexit) represents the input matrix\n*          post-multiplied by a sequence of Jacobi rotations, where the\n*          rotation threshold and the total number of sweeps are given in\n*          TOL and NSWEEP, respectively.\n*          (See the descriptions of N1, A, TOL and NSWEEP.)\n*\n*  SVA     (input/workspace/output) REAL array, dimension (N)\n*          On entry, SVA contains the Euclidean norms of the columns of\n*          the matrix A*diag(D).\n*          On exit, SVA contains the Euclidean norms of the columns of\n*          the matrix onexit*diag(D_onexit).\n*\n*  MV      (input) INTEGER\n*          If JOBV .EQ. 'A', then MV rows of V are post-multipled by a\n*                           sequence of Jacobi rotations.\n*          If JOBV = 'N',   then MV is not referenced.\n*\n*  V       (input/output) REAL array, dimension (LDV,N)\n*          If JOBV .EQ. 'V' then N rows of V are post-multipled by a\n*                           sequence of Jacobi rotations.\n*          If JOBV .EQ. 'A' then MV rows of V are post-multipled by a\n*                           sequence of Jacobi rotations.\n*          If JOBV = 'N',   then V is not referenced.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V,  LDV >= 1.\n*          If JOBV = 'V', LDV .GE. N.\n*          If JOBV = 'A', LDV .GE. MV.\n*\n*  EPS     (input) INTEGER\n*          EPS = SLAMCH('Epsilon')\n*\n*  SFMIN   (input) INTEGER\n*          SFMIN = SLAMCH('Safe Minimum')\n*\n*  TOL     (input) REAL\n*          TOL is the threshold for Jacobi rotations. For a pair\n*          A(:,p), A(:,q) of pivot columns, the Jacobi rotation is\n*          applied only if ABS(COS(angle(A(:,p),A(:,q)))) .GT. TOL.\n*\n*  NSWEEP  (input) INTEGER\n*          NSWEEP is the number of sweeps of Jacobi rotations to be\n*          performed.\n*\n*  WORK    (workspace) REAL array, dimension LWORK.\n*\n*  LWORK   (input) INTEGER\n*          LWORK is the dimension of WORK. LWORK .GE. M.\n*\n*  INFO    (output) INTEGER\n*          = 0 : successful exit.\n*          < 0 : if INFO = -i, then the i-th argument had an illegal value\n*\n\n*  =====================================================================\n*\n*     .. Local Parameters ..\n      REAL               ZERO, HALF, ONE, TWO\n      PARAMETER          ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0,\n     +                   TWO = 2.0E0 )\n*     ..\n*     .. Local Scalars ..\n      REAL               AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,\n     +                   BIGTHETA, CS, LARGE, MXAAPQ, MXSINJ, ROOTBIG,\n     +                   ROOTEPS, ROOTSFMIN, ROOTTOL, SMALL, SN, T,\n     +                   TEMP1, THETA, THSIGN\n      INTEGER            BLSKIP, EMPTSW, i, ibr, igl, IERR, IJBLSK,\n     +                   ISWROT, jbc, jgl, KBL, MVL, NOTROT, nblc, nblr,\n     +                   p, PSKIPPED, q, ROWSKIP, SWBAND\n      LOGICAL            APPLV, ROTOK, RSVEC\n*     ..\n*     .. Local Arrays ..\n      REAL               FASTR( 5 )\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, AMAX1, FLOAT, MIN0, SIGN, SQRT\n*     ..\n*     .. External Functions ..\n      REAL               SDOT, SNRM2\n      INTEGER            ISAMAX\n      LOGICAL            LSAME\n      EXTERNAL           ISAMAX, LSAME, SDOT, SNRM2\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SAXPY, SCOPY, SLASCL, SLASSQ, SROTM, SSWAP\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a, d, sva, v = NumRu::Lapack.sgsvj1( jobv, m, n1, a, d, sva, mv, v, eps, sfmin, tol, nsweep, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 13)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_jobv = argv[0];
  rblapack_m = argv[1];
  rblapack_n1 = argv[2];
  rblapack_a = argv[3];
  rblapack_d = argv[4];
  rblapack_sva = argv[5];
  rblapack_mv = argv[6];
  rblapack_v = argv[7];
  rblapack_eps = argv[8];
  rblapack_sfmin = argv[9];
  rblapack_tol = argv[10];
  rblapack_nsweep = argv[11];
  if (argc == 13) {
    rblapack_lwork = argv[12];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  jobv = StringValueCStr(rblapack_jobv)[0];
  n1 = NUM2INT(rblapack_n1);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (5th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  mv = NUM2INT(rblapack_mv);
  eps = NUM2INT(rblapack_eps);
  tol = (real)NUM2DBL(rblapack_tol);
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_sva))
    rb_raise(rb_eArgError, "sva (6th argument) must be NArray");
  if (NA_RANK(rblapack_sva) != 1)
    rb_raise(rb_eArgError, "rank of sva (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_sva) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of sva must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_sva) != NA_SFLOAT)
    rblapack_sva = na_change_type(rblapack_sva, NA_SFLOAT);
  sva = NA_PTR_TYPE(rblapack_sva, real*);
  sfmin = NUM2INT(rblapack_sfmin);
  lwork = m;
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  nsweep = NUM2INT(rblapack_nsweep);
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (8th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (8th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  if (NA_SHAPE1(rblapack_v) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of v must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_v) != NA_SFLOAT)
    rblapack_v = na_change_type(rblapack_v, NA_SFLOAT);
  v = NA_PTR_TYPE(rblapack_v, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_sva_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  sva_out__ = NA_PTR_TYPE(rblapack_sva_out__, real*);
  MEMCPY(sva_out__, sva, real, NA_TOTAL(rblapack_sva));
  rblapack_sva = rblapack_sva_out__;
  sva = sva_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = n;
    rblapack_v_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  v_out__ = NA_PTR_TYPE(rblapack_v_out__, real*);
  MEMCPY(v_out__, v, real, NA_TOTAL(rblapack_v));
  rblapack_v = rblapack_v_out__;
  v = v_out__;
  work = ALLOC_N(real, (lwork));

  sgsvj1_(&jobv, &m, &n, &n1, a, &lda, d, sva, &mv, v, &ldv, &eps, &sfmin, &tol, &nsweep, work, &lwork, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_info, rblapack_a, rblapack_d, rblapack_sva, rblapack_v);
}

void
init_lapack_sgsvj1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgsvj1", rblapack_sgsvj1, -1);
}
ruby-lapack-1.7.2/ext/slaed3.c0000644000175000017500000002260412502221020015674 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaed3_(integer* k, integer* n, integer* n1, real* d, real* q, integer* ldq, real* rho, real* dlamda, real* q2, integer* indx, integer* ctot, real* w, real* s, integer* info);


static VALUE
rblapack_slaed3(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n1;
  integer n1; 
  VALUE rblapack_rho;
  real rho; 
  VALUE rblapack_dlamda;
  real *dlamda; 
  VALUE rblapack_q2;
  real *q2; 
  VALUE rblapack_indx;
  integer *indx; 
  VALUE rblapack_ctot;
  integer *ctot; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_q;
  real *q; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_dlamda_out__;
  real *dlamda_out__;
  VALUE rblapack_w_out__;
  real *w_out__;
  real *s;

  integer k;
  integer n;
  integer ldq;

  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  d, q, info, dlamda, w = NumRu::Lapack.slaed3( n1, rho, dlamda, q2, indx, ctot, w, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX, CTOT, W, S, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLAED3 finds the roots of the secular equation, as defined by the\n*  values in D, W, and RHO, between 1 and K.  It makes the\n*  appropriate calls to SLAED4 and then updates the eigenvectors by\n*  multiplying the matrix of eigenvectors of the pair of eigensystems\n*  being combined by the matrix of eigenvectors of the K-by-K system\n*  which is solved here.\n*\n*  This code makes very mild assumptions about floating point\n*  arithmetic. It will work on machines with a guard digit in\n*  add/subtract, or on those binary machines without guard digits\n*  which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n*  It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  K       (input) INTEGER\n*          The number of terms in the rational function to be solved by\n*          SLAED4.  K >= 0.\n*\n*  N       (input) INTEGER\n*          The number of rows and columns in the Q matrix.\n*          N >= K (deflation may result in N>K).\n*\n*  N1      (input) INTEGER\n*          The location of the last eigenvalue in the leading submatrix.\n*          min(1,N) <= N1 <= N/2.\n*\n*  D       (output) REAL array, dimension (N)\n*          D(I) contains the updated eigenvalues for\n*          1 <= I <= K.\n*\n*  Q       (output) REAL array, dimension (LDQ,N)\n*          Initially the first K columns are used as workspace.\n*          On output the columns 1 to K contain\n*          the updated eigenvectors.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.  LDQ >= max(1,N).\n*\n*  RHO     (input) REAL\n*          The value of the parameter in the rank one update equation.\n*          RHO >= 0 required.\n*\n*  DLAMDA  (input/output) REAL array, dimension (K)\n*          The first K elements of this array contain the old roots\n*          of the deflated updating problem.  These are the poles\n*          of the secular equation. May be changed on output by\n*          having lowest order bit set to zero on Cray X-MP, Cray Y-MP,\n*          Cray-2, or Cray C-90, as described above.\n*\n*  Q2      (input) REAL array, dimension (LDQ2, N)\n*          The first K columns of this matrix contain the non-deflated\n*          eigenvectors for the split problem.\n*\n*  INDX    (input) INTEGER array, dimension (N)\n*          The permutation used to arrange the columns of the deflated\n*          Q matrix into three groups (see SLAED2).\n*          The rows of the eigenvectors found by SLAED4 must be likewise\n*          permuted before the matrix multiply can take place.\n*\n*  CTOT    (input) INTEGER array, dimension (4)\n*          A count of the total number of the various types of columns\n*          in Q, as described in INDX.  The fourth column type is any\n*          column which has been deflated.\n*\n*  W       (input/output) REAL array, dimension (K)\n*          The first K elements of this array contain the components\n*          of the deflation-adjusted updating vector. Destroyed on\n*          output.\n*\n*  S       (workspace) REAL array, dimension (N1 + 1)*K\n*          Will contain the eigenvectors of the repaired matrix which\n*          will be multiplied by the previously accumulated eigenvectors\n*          to update the system.\n*\n*  LDS     (input) INTEGER\n*          The leading dimension of S.  LDS >= max(1,K).\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 = 1, an eigenvalue did not converge\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Jeff Rutter, Computer Science Division, University of California\n*     at Berkeley, USA\n*  Modified by Francoise Tisseur, University of Tennessee.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, q, info, dlamda, w = NumRu::Lapack.slaed3( n1, rho, dlamda, q2, indx, ctot, w, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_n1 = argv[0];
  rblapack_rho = argv[1];
  rblapack_dlamda = argv[2];
  rblapack_q2 = argv[3];
  rblapack_indx = argv[4];
  rblapack_ctot = argv[5];
  rblapack_w = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n1 = NUM2INT(rblapack_n1);
  if (!NA_IsNArray(rblapack_dlamda))
    rb_raise(rb_eArgError, "dlamda (3th argument) must be NArray");
  if (NA_RANK(rblapack_dlamda) != 1)
    rb_raise(rb_eArgError, "rank of dlamda (3th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_dlamda);
  if (NA_TYPE(rblapack_dlamda) != NA_SFLOAT)
    rblapack_dlamda = na_change_type(rblapack_dlamda, NA_SFLOAT);
  dlamda = NA_PTR_TYPE(rblapack_dlamda, real*);
  if (!NA_IsNArray(rblapack_indx))
    rb_raise(rb_eArgError, "indx (5th argument) must be NArray");
  if (NA_RANK(rblapack_indx) != 1)
    rb_raise(rb_eArgError, "rank of indx (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_indx);
  if (NA_TYPE(rblapack_indx) != NA_LINT)
    rblapack_indx = na_change_type(rblapack_indx, NA_LINT);
  indx = NA_PTR_TYPE(rblapack_indx, integer*);
  if (!NA_IsNArray(rblapack_w))
    rb_raise(rb_eArgError, "w (7th argument) must be NArray");
  if (NA_RANK(rblapack_w) != 1)
    rb_raise(rb_eArgError, "rank of w (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_w) != k)
    rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of dlamda");
  if (NA_TYPE(rblapack_w) != NA_SFLOAT)
    rblapack_w = na_change_type(rblapack_w, NA_SFLOAT);
  w = NA_PTR_TYPE(rblapack_w, real*);
  rho = (real)NUM2DBL(rblapack_rho);
  if (!NA_IsNArray(rblapack_ctot))
    rb_raise(rb_eArgError, "ctot (6th argument) must be NArray");
  if (NA_RANK(rblapack_ctot) != 1)
    rb_raise(rb_eArgError, "rank of ctot (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ctot) != (4))
    rb_raise(rb_eRuntimeError, "shape 0 of ctot must be %d", 4);
  if (NA_TYPE(rblapack_ctot) != NA_LINT)
    rblapack_ctot = na_change_type(rblapack_ctot, NA_LINT);
  ctot = NA_PTR_TYPE(rblapack_ctot, integer*);
  if (!NA_IsNArray(rblapack_q2))
    rb_raise(rb_eArgError, "q2 (4th argument) must be NArray");
  if (NA_RANK(rblapack_q2) != 2)
    rb_raise(rb_eArgError, "rank of q2 (4th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_q2) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of q2 must be the same as shape 0 of indx");
  if (NA_SHAPE1(rblapack_q2) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q2 must be the same as shape 0 of indx");
  if (NA_TYPE(rblapack_q2) != NA_SFLOAT)
    rblapack_q2 = na_change_type(rblapack_q2, NA_SFLOAT);
  q2 = NA_PTR_TYPE(rblapack_q2, real*);
  ldq = MAX(1,n);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  q = NA_PTR_TYPE(rblapack_q, real*);
  {
    na_shape_t shape[1];
    shape[0] = k;
    rblapack_dlamda_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  dlamda_out__ = NA_PTR_TYPE(rblapack_dlamda_out__, real*);
  MEMCPY(dlamda_out__, dlamda, real, NA_TOTAL(rblapack_dlamda));
  rblapack_dlamda = rblapack_dlamda_out__;
  dlamda = dlamda_out__;
  {
    na_shape_t shape[1];
    shape[0] = k;
    rblapack_w_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w_out__ = NA_PTR_TYPE(rblapack_w_out__, real*);
  MEMCPY(w_out__, w, real, NA_TOTAL(rblapack_w));
  rblapack_w = rblapack_w_out__;
  w = w_out__;
  s = ALLOC_N(real, (MAX(1,k))*(n1 + 1));

  slaed3_(&k, &n, &n1, d, q, &ldq, &rho, dlamda, q2, indx, ctot, w, s, &info);

  free(s);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_d, rblapack_q, rblapack_info, rblapack_dlamda, rblapack_w);
}

void
init_lapack_slaed3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaed3", rblapack_slaed3, -1);
}
ruby-lapack-1.7.2/ext/zladiv.c0000644000175000017500000000461412502221014016016 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zladiv_(doublecomplex *__out__, doublecomplex* x, doublecomplex* y);


static VALUE
rblapack_zladiv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_x;
  doublecomplex x; 
  VALUE rblapack_y;
  doublecomplex y; 
  VALUE rblapack___out__;
  doublecomplex __out__; 


  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  __out__ = NumRu::Lapack.zladiv( x, y, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      COMPLEX*16     FUNCTION ZLADIV( X, Y )\n\n*  Purpose\n*  =======\n*\n*  ZLADIV := X / Y, where X and Y are complex.  The computation of X / Y\n*  will not overflow on an intermediary step unless the results\n*  overflows.\n*\n\n*  Arguments\n*  =========\n*\n*  X       (input) COMPLEX*16\n*  Y       (input) COMPLEX*16\n*          The complex scalars X and Y.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      DOUBLE PRECISION   ZI, ZR\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DLADIV\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          DBLE, DCMPLX, DIMAG\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.zladiv( x, y, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_x = argv[0];
  rblapack_y = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  x.r = NUM2DBL(rb_funcall(rblapack_x, rb_intern("real"), 0));
  x.i = NUM2DBL(rb_funcall(rblapack_x, rb_intern("imag"), 0));
  y.r = NUM2DBL(rb_funcall(rblapack_y, rb_intern("real"), 0));
  y.i = NUM2DBL(rb_funcall(rblapack_y, rb_intern("imag"), 0));

  zladiv_(&__out__, &x, &y);

  rblapack___out__ = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(__out__.r)), rb_float_new((double)(__out__.i)));
  return rblapack___out__;
}

void
init_lapack_zladiv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zladiv", rblapack_zladiv, -1);
}
ruby-lapack-1.7.2/ext/sgehd2.c0000644000175000017500000001266412502221021015703 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgehd2_(integer* n, integer* ilo, integer* ihi, real* a, integer* lda, real* tau, real* work, integer* info);


static VALUE
rblapack_sgehd2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  real *work;

  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, info, a = NumRu::Lapack.sgehd2( ilo, ihi, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGEHD2 reduces a real general matrix A to upper Hessenberg form H by\n*  an orthogonal similarity transformation:  Q' * A * Q = H .\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          It is assumed that A is already upper triangular in rows\n*          and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n*          set by a previous call to SGEBAL; otherwise they should be\n*          set to 1 and N respectively. See Further Details.\n*          1 <= ILO <= IHI <= max(1,N).\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the n by n general matrix to be reduced.\n*          On exit, the upper triangle and the first subdiagonal of A\n*          are overwritten with the upper Hessenberg matrix H, and the\n*          elements below the first subdiagonal, with the array TAU,\n*          represent the orthogonal matrix Q as a product of elementary\n*          reflectors. See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  TAU     (output) REAL array, dimension (N-1)\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace) REAL array, dimension (N)\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 (ihi-ilo) elementary\n*  reflectors\n*\n*     Q = H(ilo) H(ilo+1) . . . H(ihi-1).\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) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n*  exit in A(i+2:ihi,i), and tau in TAU(i).\n*\n*  The contents of A are illustrated by the following example, with\n*  n = 7, ilo = 2 and ihi = 6:\n*\n*  on entry,                        on exit,\n*\n*  ( a   a   a   a   a   a   a )    (  a   a   h   h   h   h   a )\n*  (     a   a   a   a   a   a )    (      a   h   h   h   h   a )\n*  (     a   a   a   a   a   a )    (      h   h   h   h   h   h )\n*  (     a   a   a   a   a   a )    (      v2  h   h   h   h   h )\n*  (     a   a   a   a   a   a )    (      v2  v3  h   h   h   h )\n*  (     a   a   a   a   a   a )    (      v2  v3  v4  h   h   h )\n*  (                         a )    (                          a )\n*\n*  where a denotes an element of the original matrix A, h denotes a\n*  modified element of the upper Hessenberg matrix H, and vi denotes an\n*  element of the vector defining H(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.sgehd2( ilo, ihi, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_ilo = argv[0];
  rblapack_ihi = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  ihi = NUM2INT(rblapack_ihi);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(real, (n));

  sgehd2_(&n, &ilo, &ihi, 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_sgehd2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgehd2", rblapack_sgehd2, -1);
}
ruby-lapack-1.7.2/ext/dtftri.c0000644000175000017500000001722512502221014016023 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtftri_(char* transr, char* uplo, char* diag, integer* n, doublereal* a, integer* info);


static VALUE
rblapack_dtftri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;


  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  info, a = NumRu::Lapack.dtftri( transr, uplo, diag, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTFTRI( TRANSR, UPLO, DIAG, N, A, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTFTRI computes the inverse of a triangular matrix A stored in RFP\n*  format.\n*\n*  This is a Level 3 BLAS version of the algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR  (input) CHARACTER*1\n*          = 'N':  The Normal TRANSR of RFP A is stored;\n*          = 'T':  The Transpose TRANSR of RFP A is stored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION  array, dimension (0:nt-1);\n*          nt=N*(N+1)/2. On entry, the triangular factor of a Hermitian\n*          Positive Definite matrix A in RFP format. RFP format is\n*          described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n*          then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n*          (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is\n*          the transpose of RFP A as defined when\n*          TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n*          follows: If UPLO = 'U' the RFP A contains the nt elements of\n*          upper packed A; If UPLO = 'L' the RFP A contains the nt\n*          elements of lower packed A. The LDA of RFP A is (N+1)/2 when\n*          TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is\n*          even and N is odd. See the Note below for more details.\n*\n*          On exit, the (triangular) inverse of the original matrix, in\n*          the same storage format.\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, A(i,i) is exactly zero.  The triangular\n*               matrix is singular and its inverse can not be computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  We first consider Rectangular Full Packed (RFP) Format when N is\n*  even. We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  the transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  the transpose of the last three columns of AP lower.\n*  This covers the case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        03 04 05                33 43 53\n*        13 14 15                00 44 54\n*        23 24 25                10 11 55\n*        33 34 35                20 21 22\n*        00 44 45                30 31 32\n*        01 11 55                40 41 42\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We then consider Rectangular Full Packed (RFP) Format when N is\n*  odd. We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  the transpose of the first two columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  the transpose of the last two columns of AP lower.\n*  This covers the case N odd and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        02 03 04                00 33 43\n*        12 13 14                10 11 44\n*        22 23 24                20 21 22\n*        00 33 34                30 31 32\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*           RFP A                   RFP A\n*\n*     02 12 22 00 01             00 10 20 30 40 50\n*     03 13 23 33 11             33 11 21 31 41 51\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.dtftri( transr, uplo, diag, n, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_diag = argv[2];
  rblapack_n = argv[3];
  rblapack_a = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 1)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_a_out__ = na_make_object(NA_DFLOAT, 1, 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__;

  dtftri_(&transr, &uplo, &diag, &n, a, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_dtftri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtftri", rblapack_dtftri, -1);
}
ruby-lapack-1.7.2/ext/dorg2r.c0000644000175000017500000001047212502221014015723 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dorg2r_(integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* info);


static VALUE
rblapack_dorg2r(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  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 k;

  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  info, a = NumRu::Lapack.dorg2r( m, a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DORG2R generates an m by n real matrix Q with orthonormal columns,\n*  which is defined as the first n columns of a product of k elementary\n*  reflectors of order m\n*\n*        Q  =  H(1) H(2) . . . H(k)\n*\n*  as returned by DGEQRF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. M >= N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. N >= K >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the i-th column must contain the vector which\n*          defines the elementary reflector H(i), for i = 1,2,...,k, as\n*          returned by DGEQRF in the first k columns of its array\n*          argument A.\n*          On exit, the m-by-n matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) DOUBLE PRECISION array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by DGEQRF.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -i, the i-th argument has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.dorg2r( m, a, tau, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  rblapack_tau = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  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*);
  {
    na_shape_t 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, (n));

  dorg2r_(&m, &n, &k, a, &lda, tau, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_dorg2r(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dorg2r", rblapack_dorg2r, -1);
}
ruby-lapack-1.7.2/ext/zlaqr5.c0000644000175000017500000002566312502221015015753 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlaqr5_(logical* wantt, logical* wantz, integer* kacc22, integer* n, integer* ktop, integer* kbot, integer* nshfts, doublecomplex* s, doublecomplex* h, integer* ldh, integer* iloz, integer* ihiz, doublecomplex* z, integer* ldz, doublecomplex* v, integer* ldv, doublecomplex* u, integer* ldu, integer* nv, doublecomplex* wv, integer* ldwv, integer* nh, doublecomplex* wh, integer* ldwh);


static VALUE
rblapack_zlaqr5(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantt;
  logical wantt; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_kacc22;
  integer kacc22; 
  VALUE rblapack_ktop;
  integer ktop; 
  VALUE rblapack_kbot;
  integer kbot; 
  VALUE rblapack_s;
  doublecomplex *s; 
  VALUE rblapack_h;
  doublecomplex *h; 
  VALUE rblapack_iloz;
  integer iloz; 
  VALUE rblapack_ihiz;
  integer ihiz; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_ldz;
  integer ldz; 
  VALUE rblapack_nv;
  integer nv; 
  VALUE rblapack_nh;
  integer nh; 
  VALUE rblapack_s_out__;
  doublecomplex *s_out__;
  VALUE rblapack_h_out__;
  doublecomplex *h_out__;
  VALUE rblapack_z_out__;
  doublecomplex *z_out__;
  doublecomplex *v;
  doublecomplex *u;
  doublecomplex *wv;
  doublecomplex *wh;

  integer nshfts;
  integer ldh;
  integer n;
  integer ldv;
  integer ldu;
  integer ldwv;
  integer ldwh;

  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  s, h, z = NumRu::Lapack.zlaqr5( wantt, wantz, kacc22, ktop, kbot, s, h, iloz, ihiz, z, ldz, nv, nh, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, WV, LDWV, NH, WH, LDWH )\n\n*     This auxiliary subroutine called by ZLAQR0 performs a\n*     single small-bulge multi-shift QR sweep.\n*\n\n*      WANTT  (input) logical scalar\n*             WANTT = .true. if the triangular Schur factor\n*             is being computed.  WANTT is set to .false. otherwise.\n*\n*      WANTZ  (input) logical scalar\n*             WANTZ = .true. if the unitary Schur factor is being\n*             computed.  WANTZ is set to .false. otherwise.\n*\n*      KACC22 (input) integer with value 0, 1, or 2.\n*             Specifies the computation mode of far-from-diagonal\n*             orthogonal updates.\n*        = 0: ZLAQR5 does not accumulate reflections and does not\n*             use matrix-matrix multiply to update far-from-diagonal\n*             matrix entries.\n*        = 1: ZLAQR5 accumulates reflections and uses matrix-matrix\n*             multiply to update the far-from-diagonal matrix entries.\n*        = 2: ZLAQR5 accumulates reflections, uses matrix-matrix\n*             multiply to update the far-from-diagonal matrix entries,\n*             and takes advantage of 2-by-2 block structure during\n*             matrix multiplies.\n*\n*      N      (input) integer scalar\n*             N is the order of the Hessenberg matrix H upon which this\n*             subroutine operates.\n*\n*      KTOP   (input) integer scalar\n*      KBOT   (input) integer scalar\n*             These are the first and last rows and columns of an\n*             isolated diagonal block upon which the QR sweep is to be\n*             applied. It is assumed without a check that\n*                       either KTOP = 1  or   H(KTOP,KTOP-1) = 0\n*             and\n*                       either KBOT = N  or   H(KBOT+1,KBOT) = 0.\n*\n*      NSHFTS (input) integer scalar\n*             NSHFTS gives the number of simultaneous shifts.  NSHFTS\n*             must be positive and even.\n*\n*      S      (input/output) COMPLEX*16 array of size (NSHFTS)\n*             S contains the shifts of origin that define the multi-\n*             shift QR sweep.  On output S may be reordered.\n*\n*      H      (input/output) COMPLEX*16 array of size (LDH,N)\n*             On input H contains a Hessenberg matrix.  On output a\n*             multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied\n*             to the isolated diagonal block in rows and columns KTOP\n*             through KBOT.\n*\n*      LDH    (input) integer scalar\n*             LDH is the leading dimension of H just as declared in the\n*             calling procedure.  LDH.GE.MAX(1,N).\n*\n*      ILOZ   (input) INTEGER\n*      IHIZ   (input) INTEGER\n*             Specify the rows of Z to which transformations must be\n*             applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N\n*\n*      Z      (input/output) COMPLEX*16 array of size (LDZ,IHI)\n*             If WANTZ = .TRUE., then the QR Sweep unitary\n*             similarity transformation is accumulated into\n*             Z(ILOZ:IHIZ,ILO:IHI) from the right.\n*             If WANTZ = .FALSE., then Z is unreferenced.\n*\n*      LDZ    (input) integer scalar\n*             LDA is the leading dimension of Z just as declared in\n*             the calling procedure. LDZ.GE.N.\n*\n*      V      (workspace) COMPLEX*16 array of size (LDV,NSHFTS/2)\n*\n*      LDV    (input) integer scalar\n*             LDV is the leading dimension of V as declared in the\n*             calling procedure.  LDV.GE.3.\n*\n*      U      (workspace) COMPLEX*16 array of size\n*             (LDU,3*NSHFTS-3)\n*\n*      LDU    (input) integer scalar\n*             LDU is the leading dimension of U just as declared in the\n*             in the calling subroutine.  LDU.GE.3*NSHFTS-3.\n*\n*      NH     (input) integer scalar\n*             NH is the number of columns in array WH available for\n*             workspace. NH.GE.1.\n*\n*      WH     (workspace) COMPLEX*16 array of size (LDWH,NH)\n*\n*      LDWH   (input) integer scalar\n*             Leading dimension of WH just as declared in the\n*             calling procedure.  LDWH.GE.3*NSHFTS-3.\n*\n*      NV     (input) integer scalar\n*             NV is the number of rows in WV agailable for workspace.\n*             NV.GE.1.\n*\n*      WV     (workspace) COMPLEX*16 array of size\n*             (LDWV,3*NSHFTS-3)\n*\n*      LDWV   (input) integer scalar\n*             LDWV is the leading dimension of WV as declared in the\n*             in the calling subroutine.  LDWV.GE.NV.\n*\n\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n*     Reference:\n*\n*     K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n*     Algorithm Part I: Maintaining Well Focused Shifts, and\n*     Level 3 Performance, SIAM Journal of Matrix Analysis,\n*     volume 23, pages 929--947, 2002.\n*\n*     ================================================================\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, h, z = NumRu::Lapack.zlaqr5( wantt, wantz, kacc22, ktop, kbot, s, h, iloz, ihiz, z, ldz, nv, nh, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 13 && argc != 13)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 13)", argc);
  rblapack_wantt = argv[0];
  rblapack_wantz = argv[1];
  rblapack_kacc22 = argv[2];
  rblapack_ktop = argv[3];
  rblapack_kbot = argv[4];
  rblapack_s = argv[5];
  rblapack_h = argv[6];
  rblapack_iloz = argv[7];
  rblapack_ihiz = argv[8];
  rblapack_z = argv[9];
  rblapack_ldz = argv[10];
  rblapack_nv = argv[11];
  rblapack_nh = argv[12];
  if (argc == 13) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  wantt = (rblapack_wantt == Qtrue);
  kacc22 = NUM2INT(rblapack_kacc22);
  kbot = NUM2INT(rblapack_kbot);
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (7th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (7th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_DCOMPLEX)
    rblapack_h = na_change_type(rblapack_h, NA_DCOMPLEX);
  h = NA_PTR_TYPE(rblapack_h, doublecomplex*);
  ihiz = NUM2INT(rblapack_ihiz);
  ldz = NUM2INT(rblapack_ldz);
  nh = NUM2INT(rblapack_nh);
  ldv = 3;
  wantz = (rblapack_wantz == Qtrue);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (6th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
  nshfts = NA_SHAPE0(rblapack_s);
  if (NA_TYPE(rblapack_s) != NA_DCOMPLEX)
    rblapack_s = na_change_type(rblapack_s, NA_DCOMPLEX);
  s = NA_PTR_TYPE(rblapack_s, doublecomplex*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (10th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (10th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_z) != (wantz ? ldz : 0))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantz ? ldz : 0);
  if (NA_SHAPE1(rblapack_z) != (wantz ? ihiz : 0))
    rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantz ? ihiz : 0);
  if (NA_TYPE(rblapack_z) != NA_DCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  ldwh = 3*nshfts-3;
  ldu = 3*nshfts-3;
  ktop = NUM2INT(rblapack_ktop);
  nv = NUM2INT(rblapack_nv);
  iloz = NUM2INT(rblapack_iloz);
  ldwv = nv;
  {
    na_shape_t shape[1];
    shape[0] = nshfts;
    rblapack_s_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublecomplex*);
  MEMCPY(s_out__, s, doublecomplex, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublecomplex*);
  MEMCPY(h_out__, h, doublecomplex, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = wantz ? ldz : 0;
    shape[1] = wantz ? ihiz : 0;
    rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublecomplex*);
  MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  v = ALLOC_N(doublecomplex, (ldv)*(nshfts/2));
  u = ALLOC_N(doublecomplex, (ldu)*(3*nshfts-3));
  wv = ALLOC_N(doublecomplex, (ldwv)*(3*nshfts-3));
  wh = ALLOC_N(doublecomplex, (ldwh)*(MAX(1,nh)));

  zlaqr5_(&wantt, &wantz, &kacc22, &n, &ktop, &kbot, &nshfts, s, h, &ldh, &iloz, &ihiz, z, &ldz, v, &ldv, u, &ldu, &nv, wv, &ldwv, &nh, wh, &ldwh);

  free(v);
  free(u);
  free(wv);
  free(wh);
  return rb_ary_new3(3, rblapack_s, rblapack_h, rblapack_z);
}

void
init_lapack_zlaqr5(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlaqr5", rblapack_zlaqr5, -1);
}
ruby-lapack-1.7.2/ext/ctrsyl.c0000644000175000017500000001426012502221017016046 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctrsyl_(char* trana, char* tranb, integer* isgn, integer* m, integer* n, complex* a, integer* lda, complex* b, integer* ldb, complex* c, integer* ldc, real* scale, integer* info);


static VALUE
rblapack_ctrsyl(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trana;
  char trana; 
  VALUE rblapack_tranb;
  char tranb; 
  VALUE rblapack_isgn;
  integer isgn; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_c;
  complex *c; 
  VALUE rblapack_scale;
  real scale; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  complex *c_out__;

  integer lda;
  integer m;
  integer ldb;
  integer n;
  integer ldc;

  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  scale, info, c = NumRu::Lapack.ctrsyl( trana, tranb, isgn, a, b, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, LDC, SCALE, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTRSYL solves the complex Sylvester matrix equation:\n*\n*     op(A)*X + X*op(B) = scale*C or\n*     op(A)*X - X*op(B) = scale*C,\n*\n*  where op(A) = A or A**H, and A and B are both upper triangular. A is\n*  M-by-M and B is N-by-N; the right hand side C and the solution X are\n*  M-by-N; and scale is an output scale factor, set <= 1 to avoid\n*  overflow in X.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANA   (input) CHARACTER*1\n*          Specifies the option op(A):\n*          = 'N': op(A) = A    (No transpose)\n*          = 'C': op(A) = A**H (Conjugate transpose)\n*\n*  TRANB   (input) CHARACTER*1\n*          Specifies the option op(B):\n*          = 'N': op(B) = B    (No transpose)\n*          = 'C': op(B) = B**H (Conjugate transpose)\n*\n*  ISGN    (input) INTEGER\n*          Specifies the sign in the equation:\n*          = +1: solve op(A)*X + X*op(B) = scale*C\n*          = -1: solve op(A)*X - X*op(B) = scale*C\n*\n*  M       (input) INTEGER\n*          The order of the matrix A, and the number of rows in the\n*          matrices X and C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The order of the matrix B, and the number of columns in the\n*          matrices X and C. N >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,M)\n*          The upper triangular matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  B       (input) COMPLEX array, dimension (LDB,N)\n*          The upper triangular matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  C       (input/output) COMPLEX array, dimension (LDC,N)\n*          On entry, the M-by-N right hand side matrix C.\n*          On exit, C is overwritten by the solution matrix X.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M)\n*\n*  SCALE   (output) REAL\n*          The scale factor, scale, set <= 1 to avoid overflow in X.\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -i, the i-th argument had an illegal value\n*          = 1: A and B have common or very close eigenvalues; perturbed\n*               values were used to solve the equation (but the matrices\n*               A and B are unchanged).\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, info, c = NumRu::Lapack.ctrsyl( trana, tranb, isgn, a, b, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_trana = argv[0];
  rblapack_tranb = argv[1];
  rblapack_isgn = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  rblapack_c = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trana = StringValueCStr(rblapack_trana)[0];
  isgn = NUM2INT(rblapack_isgn);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  tranb = StringValueCStr(rblapack_tranb)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  if (NA_SHAPE1(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of c must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, complex*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
  MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  ctrsyl_(&trana, &tranb, &isgn, &m, &n, a, &lda, b, &ldb, c, &ldc, &scale, &info);

  rblapack_scale = rb_float_new((double)scale);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_scale, rblapack_info, rblapack_c);
}

void
init_lapack_ctrsyl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctrsyl", rblapack_ctrsyl, -1);
}
ruby-lapack-1.7.2/ext/claqgb.c0000644000175000017500000001462312502221015015760 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID claqgb_(integer* m, integer* n, integer* kl, integer* ku, complex* ab, integer* ldab, real* r, real* c, real* rowcnd, real* colcnd, real* amax, char* equed);


static VALUE
rblapack_claqgb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_r;
  real *r; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_rowcnd;
  real rowcnd; 
  VALUE rblapack_colcnd;
  real colcnd; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_ab_out__;
  complex *ab_out__;

  integer ldab;
  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  equed, ab = NumRu::Lapack.claqgb( kl, ku, ab, r, c, rowcnd, colcnd, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n*  Purpose\n*  =======\n*\n*  CLAQGB equilibrates a general M by N band matrix A with KL\n*  subdiagonals and KU superdiagonals using the row and scaling factors\n*  in the vectors R and C.\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*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  AB      (input/output) COMPLEX array, dimension (LDAB,N)\n*          On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n*          The j-th column of A is stored in the j-th column of the\n*          array AB as follows:\n*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n*          On exit, the equilibrated matrix, in the same storage format\n*          as A.  See EQUED for the form of the equilibrated matrix.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDA >= KL+KU+1.\n*\n*  R       (input) REAL array, dimension (M)\n*          The row scale factors for A.\n*\n*  C       (input) REAL array, dimension (N)\n*          The column scale factors for A.\n*\n*  ROWCND  (input) REAL\n*          Ratio of the smallest R(i) to the largest R(i).\n*\n*  COLCND  (input) REAL\n*          Ratio of the smallest C(i) to the largest C(i).\n*\n*  AMAX    (input) REAL\n*          Absolute value of largest matrix entry.\n*\n*  EQUED   (output) CHARACTER*1\n*          Specifies the form of equilibration that was done.\n*          = 'N':  No equilibration\n*          = 'R':  Row equilibration, i.e., A has been premultiplied by\n*                  diag(R).\n*          = 'C':  Column equilibration, i.e., A has been postmultiplied\n*                  by diag(C).\n*          = 'B':  Both row and column equilibration, i.e., A has been\n*                  replaced by diag(R) * A * diag(C).\n*\n*  Internal Parameters\n*  ===================\n*\n*  THRESH is a threshold value used to decide if row or column scaling\n*  should be done based on the ratio of the row or column scaling\n*  factors.  If ROWCND < THRESH, row scaling is done, and if\n*  COLCND < THRESH, column scaling is done.\n*\n*  LARGE and SMALL are threshold values used to decide if row scaling\n*  should be done based on the absolute size of the largest matrix\n*  element.  If AMAX > LARGE or AMAX < SMALL, row scaling is done.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  equed, ab = NumRu::Lapack.claqgb( kl, ku, ab, r, c, rowcnd, colcnd, amax, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_kl = argv[0];
  rblapack_ku = argv[1];
  rblapack_ab = argv[2];
  rblapack_r = argv[3];
  rblapack_c = argv[4];
  rblapack_rowcnd = argv[5];
  rblapack_colcnd = argv[6];
  rblapack_amax = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  colcnd = (real)NUM2DBL(rblapack_colcnd);
  ku = NUM2INT(rblapack_ku);
  rowcnd = (real)NUM2DBL(rblapack_rowcnd);
  if (!NA_IsNArray(rblapack_r))
    rb_raise(rb_eArgError, "r (4th argument) must be NArray");
  if (NA_RANK(rblapack_r) != 1)
    rb_raise(rb_eArgError, "rank of r (4th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_r);
  if (NA_TYPE(rblapack_r) != NA_SFLOAT)
    rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
  r = NA_PTR_TYPE(rblapack_r, real*);
  amax = (real)NUM2DBL(rblapack_amax);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
  MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  claqgb_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &equed);

  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(2, rblapack_equed, rblapack_ab);
}

void
init_lapack_claqgb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "claqgb", rblapack_claqgb, -1);
}
ruby-lapack-1.7.2/ext/csrscl.c0000644000175000017500000000633212502221016016017 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID csrscl_(integer* n, real* sa, complex* sx, integer* incx);


static VALUE
rblapack_csrscl(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_sa;
  real sa; 
  VALUE rblapack_sx;
  complex *sx; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_sx_out__;
  complex *sx_out__;


  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  sx = NumRu::Lapack.csrscl( n, sa, sx, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSRSCL( N, SA, SX, INCX )\n\n*  Purpose\n*  =======\n*\n*  CSRSCL multiplies an n-element complex vector x by the real scalar\n*  1/a.  This is done without overflow or underflow as long as\n*  the final result x/a does not overflow or underflow.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of components of the vector x.\n*\n*  SA      (input) REAL\n*          The scalar a which is used to divide each component of x.\n*          SA must be >= 0, or the subroutine will divide by zero.\n*\n*  SX      (input/output) COMPLEX array, dimension\n*                         (1+(N-1)*abs(INCX))\n*          The n-element vector x.\n*\n*  INCX    (input) INTEGER\n*          The increment between successive values of the vector SX.\n*          > 0:  SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i),     1< i<= n\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sx = NumRu::Lapack.csrscl( n, sa, sx, incx, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_n = argv[0];
  rblapack_sa = argv[1];
  rblapack_sx = argv[2];
  rblapack_incx = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  incx = NUM2INT(rblapack_incx);
  sa = (real)NUM2DBL(rblapack_sa);
  if (!NA_IsNArray(rblapack_sx))
    rb_raise(rb_eArgError, "sx (3th argument) must be NArray");
  if (NA_RANK(rblapack_sx) != 1)
    rb_raise(rb_eArgError, "rank of sx (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_sx) != (1+(n-1)*abs(incx)))
    rb_raise(rb_eRuntimeError, "shape 0 of sx must be %d", 1+(n-1)*abs(incx));
  if (NA_TYPE(rblapack_sx) != NA_SCOMPLEX)
    rblapack_sx = na_change_type(rblapack_sx, NA_SCOMPLEX);
  sx = NA_PTR_TYPE(rblapack_sx, complex*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*abs(incx);
    rblapack_sx_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  sx_out__ = NA_PTR_TYPE(rblapack_sx_out__, complex*);
  MEMCPY(sx_out__, sx, complex, NA_TOTAL(rblapack_sx));
  rblapack_sx = rblapack_sx_out__;
  sx = sx_out__;

  csrscl_(&n, &sa, sx, &incx);

  return rblapack_sx;
}

void
init_lapack_csrscl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "csrscl", rblapack_csrscl, -1);
}
ruby-lapack-1.7.2/ext/dptsv.c0000644000175000017500000001367512502221012015672 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dptsv_(integer* n, integer* nrhs, doublereal* d, doublereal* e, doublereal* b, integer* ldb, integer* info);


static VALUE
rblapack_dptsv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_e_out__;
  doublereal *e_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;

  integer n;
  integer ldb;
  integer nrhs;

  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  info, d, e, b = NumRu::Lapack.dptsv( d, e, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPTSV( N, NRHS, D, E, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPTSV computes the solution to a real system of linear equations\n*  A*X = B, where A is an N-by-N symmetric positive definite tridiagonal\n*  matrix, and X and B are N-by-NRHS matrices.\n*\n*  A is factored as A = L*D*L**T, and the factored form of A is then\n*  used to solve the system of equations.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the n diagonal elements of the tridiagonal matrix\n*          A.  On exit, the n diagonal elements of the diagonal matrix\n*          D from the factorization A = L*D*L**T.\n*\n*  E       (input/output) DOUBLE PRECISION array, dimension (N-1)\n*          On entry, the (n-1) subdiagonal elements of the tridiagonal\n*          matrix A.  On exit, the (n-1) subdiagonal elements of the\n*          unit bidiagonal factor L from the L*D*L**T factorization of\n*          A.  (E can also be regarded as the superdiagonal of the unit\n*          bidiagonal factor U from the U**T*D*U factorization of A.)\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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 leading minor of order i is not\n*                positive definite, and the solution has not been\n*                computed.  The factorization has not been completed\n*                unless i = N.\n*\n\n*  =====================================================================\n*\n*     .. External Subroutines ..\n      EXTERNAL           DPTTRF, DPTTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, e, b = NumRu::Lapack.dptsv( d, e, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_d = argv[0];
  rblapack_e = argv[1];
  rblapack_b = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  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);
  ldb = NA_SHAPE0(rblapack_b);
  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 (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (2th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
  MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dptsv_(&n, &nrhs, d, e, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_e, rblapack_b);
}

void
init_lapack_dptsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dptsv", rblapack_dptsv, -1);
}
ruby-lapack-1.7.2/ext/ztbcon.c0000644000175000017500000001155312502221025016026 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztbcon_(char* norm, char* uplo, char* diag, integer* n, integer* kd, doublecomplex* ab, integer* ldab, doublereal* rcond, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_ztbcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_info;
  integer info; 
  doublecomplex *work;
  doublereal *rwork;

  integer ldab;
  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  rcond, info = NumRu::Lapack.ztbcon( norm, uplo, diag, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTBCON estimates the reciprocal of the condition number of a\n*  triangular band matrix A, in either the 1-norm or the infinity-norm.\n*\n*  The norm of A is computed and an estimate is obtained for\n*  norm(inv(A)), then the reciprocal of the condition number is\n*  computed as\n*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies whether the 1-norm condition number or the\n*          infinity-norm condition number is required:\n*          = '1' or 'O':  1-norm;\n*          = 'I':         Infinity-norm.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals or subdiagonals of the\n*          triangular band matrix A.  KD >= 0.\n*\n*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)\n*          The upper or lower triangular band matrix A, stored in the\n*          first kd+1 rows of the array. The j-th column of A is stored\n*          in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*          If DIAG = 'U', the diagonal elements of A are not referenced\n*          and are assumed to be 1.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(norm(A) * norm(inv(A))).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.ztbcon( norm, uplo, diag, kd, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_diag = argv[2];
  rblapack_kd = argv[3];
  rblapack_ab = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  kd = NUM2INT(rblapack_kd);
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (n));

  ztbcon_(&norm, &uplo, &diag, &n, &kd, ab, &ldab, &rcond, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_ztbcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztbcon", rblapack_ztbcon, -1);
}
ruby-lapack-1.7.2/ext/zhetf2.c0000644000175000017500000001621712502221021015727 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhetf2_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* ipiv, integer* info);


static VALUE
rblapack_zhetf2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *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  ipiv, info, a = NumRu::Lapack.zhetf2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHETF2( UPLO, N, A, LDA, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHETF2 computes the factorization of a complex Hermitian matrix A\n*  using the Bunch-Kaufman diagonal pivoting method:\n*\n*     A = U*D*U'  or  A = L*D*L'\n*\n*  where U (or L) is a product of permutation and unit upper (lower)\n*  triangular matrices, U' is the conjugate transpose of U, and D is\n*  Hermitian and block diagonal with 1-by-1 and 2-by-2 diagonal blocks.\n*\n*  This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          Hermitian matrix A is stored:\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading\n*          n-by-n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n-by-n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L (see below for further details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D.\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*          > 0: if INFO = k, D(k,k) is exactly zero.  The factorization\n*               has been completed, but the block diagonal matrix D is\n*               exactly singular, and division by zero will occur if it\n*               is used to solve a system of equations.\n*\n\n*  Further Details\n*  ===============\n*\n*  09-29-06 - patch from\n*    Bobby Cheng, MathWorks\n*\n*    Replace l.210 and l.393\n*         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN\n*    by\n*         IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN\n*\n*  01-01-96 - Based on modifications by\n*    J. Lewis, Boeing Computer Services Company\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n*  If UPLO = 'U', then A = U*D*U', where\n*     U = P(n)*U(n)* ... *P(k)U(k)* ...,\n*  i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n*  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    v    0   )   k-s\n*     U(k) =  (   0    I    0   )   s\n*             (   0    0    I   )   n-k\n*                k-s   s   n-k\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n*  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n*  and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n*  If UPLO = 'L', then A = L*D*L', where\n*     L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n*  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n*  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    0     0   )  k-1\n*     L(k) =  (   0    I     0   )  s\n*             (   0    v     I   )  n-k-s+1\n*                k-1   s  n-k-s+1\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n*  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n*  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, a = NumRu::Lapack.zhetf2( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zhetf2_(&uplo, &n, a, &lda, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_a);
}

void
init_lapack_zhetf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhetf2", rblapack_zhetf2, -1);
}
ruby-lapack-1.7.2/ext/claed7.c0000644000175000017500000003610712655767574015731 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID claed7_(integer* n, integer* cutpnt, integer* qsiz, integer* tlvls, integer* curlvl, integer* curpbm, real* d, complex* q, integer* ldq, real* rho, integer* indxq, real* qstore, integer* qptr, integer* prmptr, integer* perm, integer* givptr, integer* givcol, real* givnum, complex* work, real* rwork, integer* iwork, integer* info);


static VALUE
rblapack_claed7(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_cutpnt;
  integer cutpnt; 
  VALUE rblapack_qsiz;
  integer qsiz; 
  VALUE rblapack_tlvls;
  integer tlvls; 
  VALUE rblapack_curlvl;
  integer curlvl; 
  VALUE rblapack_curpbm;
  integer curpbm; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_q;
  complex *q; 
  VALUE rblapack_rho;
  real rho; 
  VALUE rblapack_qstore;
  real *qstore; 
  VALUE rblapack_qptr;
  integer *qptr; 
  VALUE rblapack_prmptr;
  integer *prmptr; 
  VALUE rblapack_perm;
  integer *perm; 
  VALUE rblapack_givptr;
  integer *givptr; 
  VALUE rblapack_givcol;
  integer *givcol; 
  VALUE rblapack_givnum;
  real *givnum; 
  VALUE rblapack_indxq;
  integer *indxq; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_q_out__;
  complex *q_out__;
  VALUE rblapack_qstore_out__;
  real *qstore_out__;
  VALUE rblapack_qptr_out__;
  integer *qptr_out__;
  complex *work;
  real *rwork;
  integer *iwork;

  integer n;
  integer ldq;

  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  indxq, info, d, q, qstore, qptr = NumRu::Lapack.claed7( cutpnt, qsiz, tlvls, curlvl, curpbm, d, q, rho, qstore, qptr, prmptr, perm, givptr, givcol, givnum, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAED7( N, CUTPNT, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, LDQ, RHO, INDXQ, QSTORE, QPTR, PRMPTR, PERM, GIVPTR, GIVCOL, GIVNUM, WORK, RWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CLAED7 computes the updated eigensystem of a diagonal\n*  matrix after modification by a rank-one symmetric matrix. This\n*  routine is used only for the eigenproblem which requires all\n*  eigenvalues and optionally eigenvectors of a dense or banded\n*  Hermitian matrix that has been reduced to tridiagonal form.\n*\n*    T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)\n*\n*    where Z = Q'u, u is a vector of length N with ones in the\n*    CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.\n*\n*     The eigenvectors of the original matrix are stored in Q, and the\n*     eigenvalues are in D.  The algorithm consists of three stages:\n*\n*        The first stage consists of deflating the size of the problem\n*        when there are multiple eigenvalues or if there is a zero in\n*        the Z vector.  For each such occurrence the dimension of the\n*        secular equation problem is reduced by one.  This stage is\n*        performed by the routine SLAED2.\n*\n*        The second stage consists of calculating the updated\n*        eigenvalues. This is done by finding the roots of the secular\n*        equation via the routine SLAED4 (as called by SLAED3).\n*        This routine also calculates the eigenvectors of the current\n*        problem.\n*\n*        The final stage consists of computing the updated eigenvectors\n*        directly using the updated eigenvalues.  The eigenvectors for\n*        the current problem are multiplied with the eigenvectors from\n*        the overall problem.\n*\n\n*  Arguments\n*  =========\n*\n*  N      (input) INTEGER\n*         The dimension of the symmetric tridiagonal matrix.  N >= 0.\n*\n*  CUTPNT (input) INTEGER\n*         Contains the location of the last eigenvalue in the leading\n*         sub-matrix.  min(1,N) <= CUTPNT <= N.\n*\n*  QSIZ   (input) INTEGER\n*         The dimension of the unitary matrix used to reduce\n*         the full matrix to tridiagonal form.  QSIZ >= N.\n*\n*  TLVLS  (input) INTEGER\n*         The total number of merging levels in the overall divide and\n*         conquer tree.\n*\n*  CURLVL (input) INTEGER\n*         The current level in the overall merge routine,\n*         0 <= curlvl <= tlvls.\n*\n*  CURPBM (input) INTEGER\n*         The current problem in the current level in the overall\n*         merge routine (counting from upper left to lower right).\n*\n*  D      (input/output) REAL array, dimension (N)\n*         On entry, the eigenvalues of the rank-1-perturbed matrix.\n*         On exit, the eigenvalues of the repaired matrix.\n*\n*  Q      (input/output) COMPLEX array, dimension (LDQ,N)\n*         On entry, the eigenvectors of the rank-1-perturbed matrix.\n*         On exit, the eigenvectors of the repaired tridiagonal matrix.\n*\n*  LDQ    (input) INTEGER\n*         The leading dimension of the array Q.  LDQ >= max(1,N).\n*\n*  RHO    (input) REAL\n*         Contains the subdiagonal element used to create the rank-1\n*         modification.\n*\n*  INDXQ  (output) INTEGER array, dimension (N)\n*         This contains the permutation which will reintegrate the\n*         subproblem just solved back into sorted order,\n*         ie. D( INDXQ( I = 1, N ) ) will be in ascending order.\n*\n*  IWORK  (workspace) INTEGER array, dimension (4*N)\n*\n*  RWORK  (workspace) REAL array,\n*                                 dimension (3*N+2*QSIZ*N)\n*\n*  WORK   (workspace) COMPLEX array, dimension (QSIZ*N)\n*\n*  QSTORE (input/output) REAL array, dimension (N**2+1)\n*         Stores eigenvectors of submatrices encountered during\n*         divide and conquer, packed together. QPTR points to\n*         beginning of the submatrices.\n*\n*  QPTR   (input/output) INTEGER array, dimension (N+2)\n*         List of indices pointing to beginning of submatrices stored\n*         in QSTORE. The submatrices are numbered starting at the\n*         bottom left of the divide and conquer tree, from left to\n*         right and bottom to top.\n*\n*  PRMPTR (input) INTEGER array, dimension (N lg N)\n*         Contains a list of pointers which indicate where in PERM a\n*         level's permutation is stored.  PRMPTR(i+1) - PRMPTR(i)\n*         indicates the size of the permutation and also the size of\n*         the full, non-deflated problem.\n*\n*  PERM   (input) INTEGER array, dimension (N lg N)\n*         Contains the permutations (from deflation and sorting) to be\n*         applied to each eigenblock.\n*\n*  GIVPTR (input) INTEGER array, dimension (N lg N)\n*         Contains a list of pointers which indicate where in GIVCOL a\n*         level's Givens rotations are stored.  GIVPTR(i+1) - GIVPTR(i)\n*         indicates the number of Givens rotations.\n*\n*  GIVCOL (input) INTEGER array, dimension (2, N lg N)\n*         Each pair of numbers indicates a pair of columns to take place\n*         in a Givens rotation.\n*\n*  GIVNUM (input) REAL array, dimension (2, N lg N)\n*         Each number indicates the S value to be used in the\n*         corresponding Givens rotation.\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 = 1, an eigenvalue did not converge\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            COLTYP, CURR, I, IDLMDA, INDX,\n     $                   INDXC, INDXP, IQ, IW, IZ, K, N1, N2, PTR\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CLACRM, CLAED8, SLAED9, SLAEDA, SLAMRG, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  indxq, info, d, q, qstore, qptr = NumRu::Lapack.claed7( cutpnt, qsiz, tlvls, curlvl, curpbm, d, q, rho, qstore, qptr, prmptr, perm, givptr, givcol, givnum, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 15 && argc != 15)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
  rblapack_cutpnt = argv[0];
  rblapack_qsiz = argv[1];
  rblapack_tlvls = argv[2];
  rblapack_curlvl = argv[3];
  rblapack_curpbm = argv[4];
  rblapack_d = argv[5];
  rblapack_q = argv[6];
  rblapack_rho = argv[7];
  rblapack_qstore = argv[8];
  rblapack_qptr = argv[9];
  rblapack_prmptr = argv[10];
  rblapack_perm = argv[11];
  rblapack_givptr = argv[12];
  rblapack_givcol = argv[13];
  rblapack_givnum = argv[14];
  if (argc == 15) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  cutpnt = NUM2INT(rblapack_cutpnt);
  tlvls = NUM2INT(rblapack_tlvls);
  curpbm = NUM2INT(rblapack_curpbm);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (7th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  n = NA_SHAPE1(rblapack_q);
  if (NA_TYPE(rblapack_q) != NA_SCOMPLEX)
    rblapack_q = na_change_type(rblapack_q, NA_SCOMPLEX);
  q = NA_PTR_TYPE(rblapack_q, complex*);
  qsiz = NUM2INT(rblapack_qsiz);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (6th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of q");
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_qstore))
    rb_raise(rb_eArgError, "qstore (9th argument) must be NArray");
  if (NA_RANK(rblapack_qstore) != 1)
    rb_raise(rb_eArgError, "rank of qstore (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_qstore) != (pow(n,2)+1))
    rb_raise(rb_eRuntimeError, "shape 0 of qstore must be %d", pow(n,2)+1);
  if (NA_TYPE(rblapack_qstore) != NA_SFLOAT)
    rblapack_qstore = na_change_type(rblapack_qstore, NA_SFLOAT);
  qstore = NA_PTR_TYPE(rblapack_qstore, real*);
  if (!NA_IsNArray(rblapack_prmptr))
    rb_raise(rb_eArgError, "prmptr (11th argument) must be NArray");
  if (NA_RANK(rblapack_prmptr) != 1)
    rb_raise(rb_eArgError, "rank of prmptr (11th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_prmptr) != (n*LG(n)))
    rb_raise(rb_eRuntimeError, "shape 0 of prmptr must be %d", n*LG(n));
  if (NA_TYPE(rblapack_prmptr) != NA_LINT)
    rblapack_prmptr = na_change_type(rblapack_prmptr, NA_LINT);
  prmptr = NA_PTR_TYPE(rblapack_prmptr, integer*);
  if (!NA_IsNArray(rblapack_givptr))
    rb_raise(rb_eArgError, "givptr (13th argument) must be NArray");
  if (NA_RANK(rblapack_givptr) != 1)
    rb_raise(rb_eArgError, "rank of givptr (13th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_givptr) != (n*LG(n)))
    rb_raise(rb_eRuntimeError, "shape 0 of givptr must be %d", n*LG(n));
  if (NA_TYPE(rblapack_givptr) != NA_LINT)
    rblapack_givptr = na_change_type(rblapack_givptr, NA_LINT);
  givptr = NA_PTR_TYPE(rblapack_givptr, integer*);
  if (!NA_IsNArray(rblapack_givnum))
    rb_raise(rb_eArgError, "givnum (15th argument) must be NArray");
  if (NA_RANK(rblapack_givnum) != 2)
    rb_raise(rb_eArgError, "rank of givnum (15th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_givnum) != (2))
    rb_raise(rb_eRuntimeError, "shape 0 of givnum must be %d", 2);
  if (NA_SHAPE1(rblapack_givnum) != (n*LG(n)))
    rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", n*LG(n));
  if (NA_TYPE(rblapack_givnum) != NA_SFLOAT)
    rblapack_givnum = na_change_type(rblapack_givnum, NA_SFLOAT);
  givnum = NA_PTR_TYPE(rblapack_givnum, real*);
  curlvl = NUM2INT(rblapack_curlvl);
  if (!NA_IsNArray(rblapack_qptr))
    rb_raise(rb_eArgError, "qptr (10th argument) must be NArray");
  if (NA_RANK(rblapack_qptr) != 1)
    rb_raise(rb_eArgError, "rank of qptr (10th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_qptr) != (n+2))
    rb_raise(rb_eRuntimeError, "shape 0 of qptr must be %d", n+2);
  if (NA_TYPE(rblapack_qptr) != NA_LINT)
    rblapack_qptr = na_change_type(rblapack_qptr, NA_LINT);
  qptr = NA_PTR_TYPE(rblapack_qptr, integer*);
  if (!NA_IsNArray(rblapack_givcol))
    rb_raise(rb_eArgError, "givcol (14th argument) must be NArray");
  if (NA_RANK(rblapack_givcol) != 2)
    rb_raise(rb_eArgError, "rank of givcol (14th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_givcol) != (2))
    rb_raise(rb_eRuntimeError, "shape 0 of givcol must be %d", 2);
  if (NA_SHAPE1(rblapack_givcol) != (n*LG(n)))
    rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", n*LG(n));
  if (NA_TYPE(rblapack_givcol) != NA_LINT)
    rblapack_givcol = na_change_type(rblapack_givcol, NA_LINT);
  givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
  rho = (real)NUM2DBL(rblapack_rho);
  if (!NA_IsNArray(rblapack_perm))
    rb_raise(rb_eArgError, "perm (12th argument) must be NArray");
  if (NA_RANK(rblapack_perm) != 1)
    rb_raise(rb_eArgError, "rank of perm (12th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_perm) != (n*LG(n)))
    rb_raise(rb_eRuntimeError, "shape 0 of perm must be %d", n*LG(n));
  if (NA_TYPE(rblapack_perm) != NA_LINT)
    rblapack_perm = na_change_type(rblapack_perm, NA_LINT);
  perm = NA_PTR_TYPE(rblapack_perm, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_indxq = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  indxq = NA_PTR_TYPE(rblapack_indxq, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, complex*);
  MEMCPY(q_out__, q, complex, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  {
    na_shape_t shape[1];
    shape[0] = pow(n,2)+1;
    rblapack_qstore_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  qstore_out__ = NA_PTR_TYPE(rblapack_qstore_out__, real*);
  MEMCPY(qstore_out__, qstore, real, NA_TOTAL(rblapack_qstore));
  rblapack_qstore = rblapack_qstore_out__;
  qstore = qstore_out__;
  {
    na_shape_t shape[1];
    shape[0] = n+2;
    rblapack_qptr_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  qptr_out__ = NA_PTR_TYPE(rblapack_qptr_out__, integer*);
  MEMCPY(qptr_out__, qptr, integer, NA_TOTAL(rblapack_qptr));
  rblapack_qptr = rblapack_qptr_out__;
  qptr = qptr_out__;
  work = ALLOC_N(complex, (qsiz*n));
  rwork = ALLOC_N(real, (3*n+2*qsiz*n));
  iwork = ALLOC_N(integer, (4*n));

  claed7_(&n, &cutpnt, &qsiz, &tlvls, &curlvl, &curpbm, d, q, &ldq, &rho, indxq, qstore, qptr, prmptr, perm, givptr, givcol, givnum, work, rwork, iwork, &info);

  free(work);
  free(rwork);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_indxq, rblapack_info, rblapack_d, rblapack_q, rblapack_qstore, rblapack_qptr);
}

void
init_lapack_claed7(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "claed7", rblapack_claed7, -1);
}
ruby-lapack-1.7.2/ext/dlaswp.c0000644000175000017500000001075012502221025016017 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaswp_(integer* n, doublereal* a, integer* lda, integer* k1, integer* k2, integer* ipiv, integer* incx);


static VALUE
rblapack_dlaswp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_k1;
  integer k1; 
  VALUE rblapack_k2;
  integer k2; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_incx;
  integer incx; 
  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  a = NumRu::Lapack.dlaswp( a, k1, k2, ipiv, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX )\n\n*  Purpose\n*  =======\n*\n*  DLASWP performs a series of row interchanges on the matrix A.\n*  One row interchange is initiated for each of rows K1 through K2 of A.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the matrix of column dimension N to which the row\n*          interchanges will be applied.\n*          On exit, the permuted matrix.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*\n*  K1      (input) INTEGER\n*          The first element of IPIV for which a row interchange will\n*          be done.\n*\n*  K2      (input) INTEGER\n*          The last element of IPIV for which a row interchange will\n*          be done.\n*\n*  IPIV    (input) INTEGER array, dimension (K2*abs(INCX))\n*          The vector of pivot indices.  Only the elements in positions\n*          K1 through K2 of IPIV are accessed.\n*          IPIV(K) = L implies rows K and L are to be interchanged.\n*\n*  INCX    (input) INTEGER\n*          The increment between successive values of IPIV.  If IPIV\n*          is negative, the pivots are applied in reverse order.\n*\n\n*  Further Details\n*  ===============\n*\n*  Modified by\n*   R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, I1, I2, INC, IP, IX, IX0, J, K, N32\n      DOUBLE PRECISION   TEMP\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  a = NumRu::Lapack.dlaswp( a, k1, k2, ipiv, incx, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_a = argv[0];
  rblapack_k1 = argv[1];
  rblapack_k2 = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_incx = argv[4];
  if (argc == 5) {
  } 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*);
  k2 = NUM2INT(rblapack_k2);
  incx = NUM2INT(rblapack_incx);
  k1 = NUM2INT(rblapack_k1);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != (k2*abs(incx)))
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be %d", k2*abs(incx));
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t 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__;

  dlaswp_(&n, a, &lda, &k1, &k2, ipiv, &incx);

  return rblapack_a;
}

void
init_lapack_dlaswp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaswp", rblapack_dlaswp, -1);
}
ruby-lapack-1.7.2/ext/sorgqr.c0000644000175000017500000001241112502221013016033 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sorgqr_(integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sorgqr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;

  integer lda;
  integer n;
  integer k;

  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 = NumRu::Lapack.sorgqr( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SORGQR generates an M-by-N real matrix Q with orthonormal columns,\n*  which is defined as the first N columns of a product of K elementary\n*  reflectors of order M\n*\n*        Q  =  H(1) H(2) . . . H(k)\n*\n*  as returned by SGEQRF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. M >= N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. N >= K >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the i-th column must contain the vector which\n*          defines the elementary reflector H(i), for i = 1,2,...,k, as\n*          returned by SGEQRF in the first k columns of its array\n*          argument A.\n*          On exit, the M-by-N matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) REAL array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by SGEQRF.\n*\n*  WORK    (workspace/output) REAL 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,N).\n*          For optimum performance LWORK >= N*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 has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, a = NumRu::Lapack.sorgqr( m, a, tau, [: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_m = argv[0];
  rblapack_a = argv[1];
  rblapack_tau = 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;
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  sorgqr_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_sorgqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sorgqr", rblapack_sorgqr, -1);
}
ruby-lapack-1.7.2/ext/zgesv.c0000644000175000017500000001277112502221024015667 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgesv_(integer* n, integer* nrhs, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* b, integer* ldb, integer* info);


static VALUE
rblapack_zgesv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  ipiv, info, a, b = NumRu::Lapack.zgesv( a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGESV computes the solution to a complex system of linear equations\n*     A * X = B,\n*  where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n*  The LU decomposition with partial pivoting and row interchanges is\n*  used to factor A as\n*     A = P * L * U,\n*  where P is a permutation matrix, L is unit lower triangular, and U is\n*  upper triangular.  The factored form of A is then used to solve the\n*  system of equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the N-by-N coefficient matrix A.\n*          On exit, the factors L and U from the factorization\n*          A = P*L*U; the unit diagonal elements of L are not stored.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          The pivot indices that define the permutation matrix P;\n*          row i of the matrix was interchanged with row IPIV(i).\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS matrix of right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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, U(i,i) is exactly zero.  The factorization\n*                has been completed, but the factor U is exactly\n*                singular, so the solution could not be computed.\n*\n\n*  =====================================================================\n*\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZGETRF, ZGETRS\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, a, b = NumRu::Lapack.zgesv( a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  if (argc == 2) {
  } 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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zgesv_(&n, &nrhs, a, &lda, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ipiv, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_zgesv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgesv", rblapack_zgesv, -1);
}
ruby-lapack-1.7.2/ext/ssyevr.c0000644000175000017500000003603112502221025016060 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssyevr_(char* jobz, char* range, char* uplo, integer* n, real* a, integer* lda, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, real* z, integer* ldz, integer* isuppz, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_ssyevr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_vl;
  real vl; 
  VALUE rblapack_vu;
  real vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  real abstol; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_isuppz;
  integer *isuppz; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;

  integer lda;
  integer n;
  integer ldz;

  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  m, w, z, isuppz, work, iwork, info, a = NumRu::Lapack.ssyevr( jobz, range, uplo, a, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSYEVR computes selected eigenvalues and, optionally, eigenvectors\n*  of a real symmetric matrix A.  Eigenvalues and eigenvectors can be\n*  selected by specifying either a range of values or a range of\n*  indices for the desired eigenvalues.\n*\n*  SSYEVR first reduces the matrix A to tridiagonal form T with a call\n*  to SSYTRD.  Then, whenever possible, SSYEVR calls SSTEMR to compute\n*  the eigenspectrum using Relatively Robust Representations.  SSTEMR\n*  computes eigenvalues by the dqds algorithm, while orthogonal\n*  eigenvectors are computed from various \"good\" L D L^T representations\n*  (also known as Relatively Robust Representations). Gram-Schmidt\n*  orthogonalization is avoided as far as possible. More specifically,\n*  the various steps of the algorithm are as follows.\n*\n*  For each unreduced block (submatrix) of T,\n*     (a) Compute T - sigma I  = L D L^T, so that L and D\n*         define all the wanted eigenvalues to high relative accuracy.\n*         This means that small relative changes in the entries of D and L\n*         cause only small relative changes in the eigenvalues and\n*         eigenvectors. The standard (unfactored) representation of the\n*         tridiagonal matrix T does not have this property in general.\n*     (b) Compute the eigenvalues to suitable accuracy.\n*         If the eigenvectors are desired, the algorithm attains full\n*         accuracy of the computed eigenvalues only right before\n*         the corresponding vectors have to be computed, see steps c) and d).\n*     (c) For each cluster of close eigenvalues, select a new\n*         shift close to the cluster, find a new factorization, and refine\n*         the shifted eigenvalues to suitable accuracy.\n*     (d) For each eigenvalue with a large enough relative separation compute\n*         the corresponding eigenvector by forming a rank revealing twisted\n*         factorization. Go back to (c) for any clusters that remain.\n*\n*  The desired accuracy of the output can be specified by the input\n*  parameter ABSTOL.\n*\n*  For more details, see SSTEMR's documentation and:\n*  - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n*    to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n*    Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n*  - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n*    Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n*    2004.  Also LAPACK Working Note 154.\n*  - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n*    tridiagonal eigenvalue/eigenvector problem\",\n*    Computer Science Division Technical Report No. UCB/CSD-97-971,\n*    UC Berkeley, May 1997.\n*\n*\n*  Note 1 : SSYEVR calls SSTEMR when the full spectrum is requested\n*  on machines which conform to the ieee-754 floating point standard.\n*  SSYEVR calls SSTEBZ and SSTEIN on non-ieee machines and\n*  when partial spectrum requests are made.\n*\n*  Normal execution of SSTEMR may create NaNs and infinities and\n*  hence may abort due to a floating point exception in environments\n*  which do not handle NaNs and infinities in the ieee standard default\n*  manner.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found.\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found.\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n********** For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and\n********** SSTEIN are called\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA, N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of A contains the\n*          upper triangular part of the matrix A.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of A contains\n*          the lower triangular part of the matrix A.\n*          On exit, the lower triangle (if UPLO='L') or the upper\n*          triangle (if UPLO='U') of A, including the diagonal, is\n*          destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  VL      (input) REAL\n*  VU      (input) REAL\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) REAL\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less than\n*          or equal to zero, then  EPS*|T|  will be used in its place,\n*          where |T| is the 1-norm of the tridiagonal matrix obtained\n*          by reducing A to tridiagonal form.\n*\n*          See \"Computing Small Singular Values of Bidiagonal Matrices\n*          with Guaranteed High Relative Accuracy,\" by Demmel and\n*          Kahan, LAPACK Working Note #3.\n*\n*          If high relative accuracy is important, set ABSTOL to\n*          SLAMCH( 'Safe minimum' ).  Doing so will guarantee that\n*          eigenvalues are computed to high relative accuracy when\n*          possible in future releases.  The current code does not\n*          make any guarantees about high relative accuracy, but\n*          future releases will. See J. Barlow and J. Demmel,\n*          \"Computing Accurate Eigensystems of Scaled Diagonally\n*          Dominant Matrices\", LAPACK Working Note #7, for a discussion\n*          of which matrices define their eigenvalues to high relative\n*          accuracy.\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) REAL array, dimension (N)\n*          The first M elements contain the selected eigenvalues in\n*          ascending order.\n*\n*  Z       (output) REAL array, dimension (LDZ, max(1,M))\n*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix A\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*          Supplying N columns is always safe.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  ISUPPZ  (output) INTEGER array, dimension ( 2*max(1,M) )\n*          The support of the eigenvectors in Z, i.e., the indices\n*          indicating the nonzero elements in Z. The i-th eigenvector\n*          is nonzero only in elements ISUPPZ( 2*i-1 ) through\n*          ISUPPZ( 2*i ).\n********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1\n*\n*  WORK    (workspace/output) REAL 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,26*N).\n*          For optimal efficiency, LWORK >= (NB+6)*N,\n*          where NB is the max of the blocksize for SSYTRD and SORMTR\n*          returned by ILAENV.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal sizes of the WORK and IWORK\n*          arrays, returns these values as the first entries of the WORK\n*          and IWORK arrays, and no error message related to LWORK or\n*          LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.  LIWORK >= max(1,10*N).\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK and IWORK arrays, and no error message related to\n*          LWORK or LIWORK 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:  Internal error\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Inderjit Dhillon, IBM Almaden, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Ken Stanley, Computer Science Division, University of\n*       California at Berkeley, USA\n*     Jason Riedy, Computer Science Division, University of\n*       California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, isuppz, work, iwork, info, a = NumRu::Lapack.ssyevr( jobz, range, uplo, a, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 11)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_uplo = argv[2];
  rblapack_a = argv[3];
  rblapack_vl = argv[4];
  rblapack_vu = argv[5];
  rblapack_il = argv[6];
  rblapack_iu = argv[7];
  rblapack_abstol = argv[8];
  if (argc == 11) {
    rblapack_lwork = argv[9];
    rblapack_liwork = argv[10];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  vl = (real)NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  abstol = (real)NUM2DBL(rblapack_abstol);
  range = StringValueCStr(rblapack_range)[0];
  vu = (real)NUM2DBL(rblapack_vu);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (rblapack_lwork == Qnil)
    lwork = 26*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  iu = NUM2INT(rblapack_iu);
  m = lsame_(&range,"I") ? iu-il+1 : n;
  if (rblapack_liwork == Qnil)
    liwork = 10*n;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[1];
    shape[0] = 2*MAX(1,m);
    rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  ssyevr_(&jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, isuppz, work, &lwork, iwork, &liwork, &info);

  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_m, rblapack_w, rblapack_z, rblapack_isuppz, rblapack_work, rblapack_iwork, rblapack_info, rblapack_a);
}

void
init_lapack_ssyevr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssyevr", rblapack_ssyevr, -1);
}
ruby-lapack-1.7.2/ext/zbdsqr.c0000644000175000017500000002712312502221021016030 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zbdsqr_(char* uplo, integer* n, integer* ncvt, integer* nru, integer* ncc, doublereal* d, doublereal* e, doublecomplex* vt, integer* ldvt, doublecomplex* u, integer* ldu, doublecomplex* c, integer* ldc, doublereal* rwork, integer* info);


static VALUE
rblapack_zbdsqr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_nru;
  integer nru; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_vt;
  doublecomplex *vt; 
  VALUE rblapack_u;
  doublecomplex *u; 
  VALUE rblapack_c;
  doublecomplex *c; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_e_out__;
  doublereal *e_out__;
  VALUE rblapack_vt_out__;
  doublecomplex *vt_out__;
  VALUE rblapack_u_out__;
  doublecomplex *u_out__;
  VALUE rblapack_c_out__;
  doublecomplex *c_out__;
  doublereal *rwork;

  integer n;
  integer ldvt;
  integer ncvt;
  integer ldu;
  integer ldc;
  integer ncc;

  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  info, d, e, vt, u, c = NumRu::Lapack.zbdsqr( uplo, nru, d, e, vt, u, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZBDSQR computes the singular values and, optionally, the right and/or\n*  left singular vectors from the singular value decomposition (SVD) of\n*  a real N-by-N (upper or lower) bidiagonal matrix B using the implicit\n*  zero-shift QR algorithm.  The SVD of B has the form\n* \n*     B = Q * S * P**H\n* \n*  where S is the diagonal matrix of singular values, Q is an orthogonal\n*  matrix of left singular vectors, and P is an orthogonal matrix of\n*  right singular vectors.  If left singular vectors are requested, this\n*  subroutine actually returns U*Q instead of Q, and, if right singular\n*  vectors are requested, this subroutine returns P**H*VT instead of\n*  P**H, for given complex input matrices U and VT.  When U and VT are\n*  the unitary matrices that reduce a general matrix A to bidiagonal\n*  form: A = U*B*VT, as computed by ZGEBRD, then\n* \n*     A = (U*Q) * S * (P**H*VT)\n* \n*  is the SVD of A.  Optionally, the subroutine may also compute Q**H*C\n*  for a given complex input matrix C.\n*\n*  See \"Computing  Small Singular Values of Bidiagonal Matrices With\n*  Guaranteed High Relative Accuracy,\" by J. Demmel and W. Kahan,\n*  LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,\n*  no. 5, pp. 873-912, Sept 1990) and\n*  \"Accurate singular values and differential qd algorithms,\" by\n*  B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics\n*  Department, University of California at Berkeley, July 1992\n*  for a detailed description of the algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  B is upper bidiagonal;\n*          = 'L':  B is lower bidiagonal.\n*\n*  N       (input) INTEGER\n*          The order of the matrix B.  N >= 0.\n*\n*  NCVT    (input) INTEGER\n*          The number of columns of the matrix VT. NCVT >= 0.\n*\n*  NRU     (input) INTEGER\n*          The number of rows of the matrix U. NRU >= 0.\n*\n*  NCC     (input) INTEGER\n*          The number of columns of the matrix C. NCC >= 0.\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the n diagonal elements of the bidiagonal matrix B.\n*          On exit, if INFO=0, the singular values of B in decreasing\n*          order.\n*\n*  E       (input/output) DOUBLE PRECISION array, dimension (N-1)\n*          On entry, the N-1 offdiagonal elements of the bidiagonal\n*          matrix B.\n*          On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E\n*          will contain the diagonal and superdiagonal elements of a\n*          bidiagonal matrix orthogonally equivalent to the one given\n*          as input.\n*\n*  VT      (input/output) COMPLEX*16 array, dimension (LDVT, NCVT)\n*          On entry, an N-by-NCVT matrix VT.\n*          On exit, VT is overwritten by P**H * VT.\n*          Not referenced if NCVT = 0.\n*\n*  LDVT    (input) INTEGER\n*          The leading dimension of the array VT.\n*          LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.\n*\n*  U       (input/output) COMPLEX*16 array, dimension (LDU, N)\n*          On entry, an NRU-by-N matrix U.\n*          On exit, U is overwritten by U * Q.\n*          Not referenced if NRU = 0.\n*\n*  LDU     (input) INTEGER\n*          The leading dimension of the array U.  LDU >= max(1,NRU).\n*\n*  C       (input/output) COMPLEX*16 array, dimension (LDC, NCC)\n*          On entry, an N-by-NCC matrix C.\n*          On exit, C is overwritten by Q**H * C.\n*          Not referenced if NCC = 0.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C.\n*          LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (2*N)\n*          if NCVT = NRU = NCC = 0, (max(1, 4*N-4)) otherwise\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  If INFO = -i, the i-th argument had an illegal value\n*          > 0:  the algorithm did not converge; D and E contain the\n*                elements of a bidiagonal matrix which is orthogonally\n*                similar to the input matrix B;  if INFO = i, i\n*                elements of E have not converged to zero.\n*\n*  Internal Parameters\n*  ===================\n*\n*  TOLMUL  DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8)))\n*          TOLMUL controls the convergence criterion of the QR loop.\n*          If it is positive, TOLMUL*EPS is the desired relative\n*             precision in the computed singular values.\n*          If it is negative, abs(TOLMUL*EPS*sigma_max) is the\n*             desired absolute accuracy in the computed singular\n*             values (corresponds to relative accuracy\n*             abs(TOLMUL*EPS) in the largest singular value.\n*          abs(TOLMUL) should be between 1 and 1/EPS, and preferably\n*             between 10 (for fast convergence) and .1/EPS\n*             (for there to be some accuracy in the results).\n*          Default is to lose at either one eighth or 2 of the\n*             available decimal digits in each computed singular value\n*             (whichever is smaller).\n*\n*  MAXITR  INTEGER, default = 6\n*          MAXITR controls the maximum number of passes of the\n*          algorithm through its inner loop. The algorithms stops\n*          (and so fails to converge) if the number of passes\n*          through the inner loop exceeds MAXITR*N**2.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, e, vt, u, c = NumRu::Lapack.zbdsqr( uplo, nru, d, e, vt, u, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_uplo = argv[0];
  rblapack_nru = argv[1];
  rblapack_d = argv[2];
  rblapack_e = argv[3];
  rblapack_vt = argv[4];
  rblapack_u = argv[5];
  rblapack_c = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_vt))
    rb_raise(rb_eArgError, "vt (5th argument) must be NArray");
  if (NA_RANK(rblapack_vt) != 2)
    rb_raise(rb_eArgError, "rank of vt (5th argument) must be %d", 2);
  ldvt = NA_SHAPE0(rblapack_vt);
  ncvt = NA_SHAPE1(rblapack_vt);
  if (NA_TYPE(rblapack_vt) != NA_DCOMPLEX)
    rblapack_vt = na_change_type(rblapack_vt, NA_DCOMPLEX);
  vt = NA_PTR_TYPE(rblapack_vt, doublecomplex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  ncc = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
  nru = NUM2INT(rblapack_nru);
  if (!NA_IsNArray(rblapack_u))
    rb_raise(rb_eArgError, "u (6th argument) must be NArray");
  if (NA_RANK(rblapack_u) != 2)
    rb_raise(rb_eArgError, "rank of u (6th argument) must be %d", 2);
  ldu = NA_SHAPE0(rblapack_u);
  if (NA_SHAPE1(rblapack_u) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of u must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_u) != NA_DCOMPLEX)
    rblapack_u = na_change_type(rblapack_u, NA_DCOMPLEX);
  u = NA_PTR_TYPE(rblapack_u, doublecomplex*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (4th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
  MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvt;
    shape[1] = ncvt;
    rblapack_vt_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  vt_out__ = NA_PTR_TYPE(rblapack_vt_out__, doublecomplex*);
  MEMCPY(vt_out__, vt, doublecomplex, NA_TOTAL(rblapack_vt));
  rblapack_vt = rblapack_vt_out__;
  vt = vt_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = n;
    rblapack_u_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  u_out__ = NA_PTR_TYPE(rblapack_u_out__, doublecomplex*);
  MEMCPY(u_out__, u, doublecomplex, NA_TOTAL(rblapack_u));
  rblapack_u = rblapack_u_out__;
  u = u_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = ncc;
    rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
  MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  rwork = ALLOC_N(doublereal, ((ncvt==nru)&&(nru==ncc)&&(ncc==0) ? 2*n : MAX(1, 4*n-4)));

  zbdsqr_(&uplo, &n, &ncvt, &nru, &ncc, d, e, vt, &ldvt, u, &ldu, c, &ldc, rwork, &info);

  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_info, rblapack_d, rblapack_e, rblapack_vt, rblapack_u, rblapack_c);
}

void
init_lapack_zbdsqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zbdsqr", rblapack_zbdsqr, -1);
}
ruby-lapack-1.7.2/ext/dorgql.c0000644000175000017500000001257112502221022016015 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dorgql_(integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dorgql(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;

  integer lda;
  integer n;
  integer k;

  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 = NumRu::Lapack.dorgql( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DORGQL generates an M-by-N real matrix Q with orthonormal columns,\n*  which is defined as the last N columns of a product of K elementary\n*  reflectors of order M\n*\n*        Q  =  H(k) . . . H(2) H(1)\n*\n*  as returned by DGEQLF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. M >= N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. N >= K >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the (n-k+i)-th column must contain the vector which\n*          defines the elementary reflector H(i), for i = 1,2,...,k, as\n*          returned by DGEQLF in the last k columns of its array\n*          argument A.\n*          On exit, the M-by-N matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) DOUBLE PRECISION array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by DGEQLF.\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,N).\n*          For optimum performance LWORK >= N*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 has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, a = NumRu::Lapack.dorgql( m, a, tau, [: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_m = argv[0];
  rblapack_a = argv[1];
  rblapack_tau = 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;
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  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*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;

  dorgql_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_dorgql(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dorgql", rblapack_dorgql, -1);
}
ruby-lapack-1.7.2/ext/cgeqp3.c0000644000175000017500000001546712502221023015717 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgeqp3_(integer* m, integer* n, complex* a, integer* lda, integer* jpvt, complex* tau, complex* work, integer* lwork, real* rwork, integer* info);


static VALUE
rblapack_cgeqp3(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_jpvt;
  integer *jpvt; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_jpvt_out__;
  integer *jpvt_out__;
  real *rwork;

  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, jpvt = NumRu::Lapack.cgeqp3( m, a, jpvt, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGEQP3 computes a QR factorization with column pivoting of a\n*  matrix A:  A*P = Q*R  using Level 3 BLAS.\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) COMPLEX array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, the upper triangle of the array contains the\n*          min(M,N)-by-N upper trapezoidal matrix R; the elements below\n*          the diagonal, together with the array TAU, represent the\n*          unitary matrix Q as a product of min(M,N) elementary\n*          reflectors.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  JPVT    (input/output) INTEGER array, dimension (N)\n*          On entry, if JPVT(J).ne.0, the J-th column of A is permuted\n*          to the front of A*P (a leading column); if JPVT(J)=0,\n*          the J-th column of A is a free column.\n*          On exit, if JPVT(J)=K, then the J-th column of A*P was the\n*          the K-th column of A.\n*\n*  TAU     (output) COMPLEX array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors.\n*\n*  WORK    (workspace/output) COMPLEX 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 >= N+1.\n*          For optimal performance LWORK >= ( N+1 )*NB, where NB\n*          is the 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*  RWORK   (workspace) REAL array, dimension (2*N)\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(1) H(2) . . . H(k), 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/complex scalar, and v is a real/complex vector\n*  with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in\n*  A(i+1:m,i), and tau in TAU(i).\n*\n*  Based on contributions by\n*    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n*    X. Sun, Computer Science Dept., Duke University, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, work, info, a, jpvt = NumRu::Lapack.cgeqp3( m, a, jpvt, [: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_m = argv[0];
  rblapack_a = argv[1];
  rblapack_jpvt = 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;
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_jpvt))
    rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
  if (NA_RANK(rblapack_jpvt) != 1)
    rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_jpvt);
  if (NA_TYPE(rblapack_jpvt) != NA_LINT)
    rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
  jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of jpvt");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (rblapack_lwork == Qnil)
    lwork = n+1;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
  MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
  rblapack_jpvt = rblapack_jpvt_out__;
  jpvt = jpvt_out__;
  rwork = ALLOC_N(real, (2*n));

  cgeqp3_(&m, &n, a, &lda, jpvt, tau, work, &lwork, rwork, &info);

  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_tau, rblapack_work, rblapack_info, rblapack_a, rblapack_jpvt);
}

void
init_lapack_cgeqp3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgeqp3", rblapack_cgeqp3, -1);
}
ruby-lapack-1.7.2/ext/cgeqr2.c0000644000175000017500000001032412502221020015700 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgeqr2_(integer* m, integer* n, complex* a, integer* lda, complex* tau, complex* work, integer* info);


static VALUE
rblapack_cgeqr2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  complex *work;

  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, info, a = NumRu::Lapack.cgeqr2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGEQR2( M, N, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGEQR2 computes a QR factorization of a complex m by n matrix A:\n*  A = Q * R.\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) COMPLEX array, dimension (LDA,N)\n*          On entry, the m by n matrix A.\n*          On exit, the elements on and above the diagonal of the array\n*          contain the min(m,n) by n upper trapezoidal matrix R (R is\n*          upper triangular if m >= n); the elements below the diagonal,\n*          with the array TAU, represent the unitary 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) COMPLEX array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace) COMPLEX array, dimension (N)\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(1) H(2) . . . H(k), 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 complex scalar, and v is a complex vector with\n*  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\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.cgeqr2( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(complex, (n));

  cgeqr2_(&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_cgeqr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgeqr2", rblapack_cgeqr2, -1);
}
ruby-lapack-1.7.2/ext/dlarrb.c0000644000175000017500000002421312502221021015766 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlarrb_(integer* n, doublereal* d, doublereal* lld, integer* ifirst, integer* ilast, doublereal* rtol1, doublereal* rtol2, integer* offset, doublereal* w, doublereal* wgap, doublereal* werr, doublereal* work, integer* iwork, doublereal* pivmin, doublereal* spdiam, integer* twist, integer* info);


static VALUE
rblapack_dlarrb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_lld;
  doublereal *lld; 
  VALUE rblapack_ifirst;
  integer ifirst; 
  VALUE rblapack_ilast;
  integer ilast; 
  VALUE rblapack_rtol1;
  doublereal rtol1; 
  VALUE rblapack_rtol2;
  doublereal rtol2; 
  VALUE rblapack_offset;
  integer offset; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_wgap;
  doublereal *wgap; 
  VALUE rblapack_werr;
  doublereal *werr; 
  VALUE rblapack_pivmin;
  doublereal pivmin; 
  VALUE rblapack_spdiam;
  doublereal spdiam; 
  VALUE rblapack_twist;
  integer twist; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_w_out__;
  doublereal *w_out__;
  VALUE rblapack_wgap_out__;
  doublereal *wgap_out__;
  VALUE rblapack_werr_out__;
  doublereal *werr_out__;
  doublereal *work;
  integer *iwork;

  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  info, w, wgap, werr = NumRu::Lapack.dlarrb( d, lld, ifirst, ilast, rtol1, rtol2, offset, w, wgap, werr, pivmin, spdiam, twist, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLARRB( N, D, LLD, IFIRST, ILAST, RTOL1, RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK, PIVMIN, SPDIAM, TWIST, INFO )\n\n*  Purpose\n*  =======\n*\n*  Given the relatively robust representation(RRR) L D L^T, DLARRB\n*  does \"limited\" bisection to refine the eigenvalues of L D L^T,\n*  W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial\n*  guesses for these eigenvalues are input in W, the corresponding estimate\n*  of the error in these guesses and their gaps are input in WERR\n*  and WGAP, respectively. During bisection, intervals\n*  [left, right] are maintained by storing their mid-points and\n*  semi-widths in the arrays W and WERR respectively.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          The N diagonal elements of the diagonal matrix D.\n*\n*  LLD     (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (N-1) elements L(i)*L(i)*D(i).\n*\n*  IFIRST  (input) INTEGER\n*          The index of the first eigenvalue to be computed.\n*\n*  ILAST   (input) INTEGER\n*          The index of the last eigenvalue to be computed.\n*\n*  RTOL1   (input) DOUBLE PRECISION\n*  RTOL2   (input) DOUBLE PRECISION\n*          Tolerance for the convergence of the bisection intervals.\n*          An interval [LEFT,RIGHT] has converged if\n*          RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n*          where GAP is the (estimated) distance to the nearest\n*          eigenvalue.\n*\n*  OFFSET  (input) INTEGER\n*          Offset for the arrays W, WGAP and WERR, i.e., the IFIRST-OFFSET\n*          through ILAST-OFFSET elements of these arrays are to be used.\n*\n*  W       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are\n*          estimates of the eigenvalues of L D L^T indexed IFIRST throug\n*          ILAST.\n*          On output, these estimates are refined.\n*\n*  WGAP    (input/output) DOUBLE PRECISION array, dimension (N-1)\n*          On input, the (estimated) gaps between consecutive\n*          eigenvalues of L D L^T, i.e., WGAP(I-OFFSET) is the gap between\n*          eigenvalues I and I+1. Note that if IFIRST.EQ.ILAST\n*          then WGAP(IFIRST-OFFSET) must be set to ZERO.\n*          On output, these gaps are refined.\n*\n*  WERR    (input/output) DOUBLE PRECISION array, dimension (N)\n*          On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are\n*          the errors in the estimates of the corresponding elements in W.\n*          On output, these errors are refined.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N)\n*          Workspace.\n*\n*  IWORK   (workspace) INTEGER array, dimension (2*N)\n*          Workspace.\n*\n*  PIVMIN  (input) DOUBLE PRECISION\n*          The minimum pivot in the Sturm sequence.\n*\n*  SPDIAM  (input) DOUBLE PRECISION\n*          The spectral diameter of the matrix.\n*\n*  TWIST   (input) INTEGER\n*          The twist index for the twisted factorization that is used\n*          for the negcount.\n*          TWIST = N: Compute negcount from L D L^T - LAMBDA I = L+ D+ L+^T\n*          TWIST = 1: Compute negcount from L D L^T - LAMBDA I = U- D- U-^T\n*          TWIST = R: Compute negcount from L D L^T - LAMBDA I = N(r) D(r) N(r)\n*\n*  INFO    (output) INTEGER\n*          Error flag.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Beresford Parlett, University of California, Berkeley, USA\n*     Jim Demmel, University of California, Berkeley, USA\n*     Inderjit Dhillon, University of Texas, Austin, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, w, wgap, werr = NumRu::Lapack.dlarrb( d, lld, ifirst, ilast, rtol1, rtol2, offset, w, wgap, werr, pivmin, spdiam, twist, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 13 && argc != 13)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 13)", argc);
  rblapack_d = argv[0];
  rblapack_lld = argv[1];
  rblapack_ifirst = argv[2];
  rblapack_ilast = argv[3];
  rblapack_rtol1 = argv[4];
  rblapack_rtol2 = argv[5];
  rblapack_offset = argv[6];
  rblapack_w = argv[7];
  rblapack_wgap = argv[8];
  rblapack_werr = argv[9];
  rblapack_pivmin = argv[10];
  rblapack_spdiam = argv[11];
  rblapack_twist = argv[12];
  if (argc == 13) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  ifirst = NUM2INT(rblapack_ifirst);
  rtol1 = NUM2DBL(rblapack_rtol1);
  offset = NUM2INT(rblapack_offset);
  if (!NA_IsNArray(rblapack_werr))
    rb_raise(rb_eArgError, "werr (10th argument) must be NArray");
  if (NA_RANK(rblapack_werr) != 1)
    rb_raise(rb_eArgError, "rank of werr (10th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_werr) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of werr must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_werr) != NA_DFLOAT)
    rblapack_werr = na_change_type(rblapack_werr, NA_DFLOAT);
  werr = NA_PTR_TYPE(rblapack_werr, doublereal*);
  spdiam = NUM2DBL(rblapack_spdiam);
  ilast = NUM2INT(rblapack_ilast);
  if (!NA_IsNArray(rblapack_w))
    rb_raise(rb_eArgError, "w (8th argument) must be NArray");
  if (NA_RANK(rblapack_w) != 1)
    rb_raise(rb_eArgError, "rank of w (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_w) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_w) != NA_DFLOAT)
    rblapack_w = na_change_type(rblapack_w, NA_DFLOAT);
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  pivmin = NUM2DBL(rblapack_pivmin);
  if (!NA_IsNArray(rblapack_lld))
    rb_raise(rb_eArgError, "lld (2th argument) must be NArray");
  if (NA_RANK(rblapack_lld) != 1)
    rb_raise(rb_eArgError, "rank of lld (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_lld) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of lld must be %d", n-1);
  if (NA_TYPE(rblapack_lld) != NA_DFLOAT)
    rblapack_lld = na_change_type(rblapack_lld, NA_DFLOAT);
  lld = NA_PTR_TYPE(rblapack_lld, doublereal*);
  if (!NA_IsNArray(rblapack_wgap))
    rb_raise(rb_eArgError, "wgap (9th argument) must be NArray");
  if (NA_RANK(rblapack_wgap) != 1)
    rb_raise(rb_eArgError, "rank of wgap (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_wgap) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of wgap must be %d", n-1);
  if (NA_TYPE(rblapack_wgap) != NA_DFLOAT)
    rblapack_wgap = na_change_type(rblapack_wgap, NA_DFLOAT);
  wgap = NA_PTR_TYPE(rblapack_wgap, doublereal*);
  rtol2 = NUM2DBL(rblapack_rtol2);
  twist = NUM2INT(rblapack_twist);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w_out__ = NA_PTR_TYPE(rblapack_w_out__, doublereal*);
  MEMCPY(w_out__, w, doublereal, NA_TOTAL(rblapack_w));
  rblapack_w = rblapack_w_out__;
  w = w_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_wgap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  wgap_out__ = NA_PTR_TYPE(rblapack_wgap_out__, doublereal*);
  MEMCPY(wgap_out__, wgap, doublereal, NA_TOTAL(rblapack_wgap));
  rblapack_wgap = rblapack_wgap_out__;
  wgap = wgap_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_werr_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  werr_out__ = NA_PTR_TYPE(rblapack_werr_out__, doublereal*);
  MEMCPY(werr_out__, werr, doublereal, NA_TOTAL(rblapack_werr));
  rblapack_werr = rblapack_werr_out__;
  werr = werr_out__;
  work = ALLOC_N(doublereal, (2*n));
  iwork = ALLOC_N(integer, (2*n));

  dlarrb_(&n, d, lld, &ifirst, &ilast, &rtol1, &rtol2, &offset, w, wgap, werr, work, iwork, &pivmin, &spdiam, &twist, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_info, rblapack_w, rblapack_wgap, rblapack_werr);
}

void
init_lapack_dlarrb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlarrb", rblapack_dlarrb, -1);
}
ruby-lapack-1.7.2/ext/dtrti2.c0000644000175000017500000001010412502221024015725 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtrti2_(char* uplo, char* diag, integer* n, doublereal* a, integer* lda, integer* info);


static VALUE
rblapack_dtrti2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_a;
  doublereal *a; 
  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  info, a = NumRu::Lapack.dtrti2( uplo, diag, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTRTI2 computes the inverse of a real upper or lower triangular\n*  matrix.\n*\n*  This is the Level 2 BLAS version of the algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the matrix A is upper or lower triangular.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  DIAG    (input) CHARACTER*1\n*          Specifies whether or not the matrix A is unit triangular.\n*          = 'N':  Non-unit triangular\n*          = 'U':  Unit triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the triangular matrix A.  If UPLO = 'U', the\n*          leading n by n upper triangular part of the array A contains\n*          the upper triangular matrix, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n by n lower triangular part of the array A contains\n*          the lower triangular matrix, and the strictly upper\n*          triangular part of A is not referenced.  If DIAG = 'U', the\n*          diagonal elements of A are also not referenced and are\n*          assumed to be 1.\n*\n*          On exit, the (triangular) inverse of the original matrix, in\n*          the same storage format.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.dtrti2( uplo, diag, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_diag = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  diag = StringValueCStr(rblapack_diag)[0];
  {
    na_shape_t 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__;

  dtrti2_(&uplo, &diag, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_dtrti2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtrti2", rblapack_dtrti2, -1);
}
ruby-lapack-1.7.2/ext/cgbtrs.c0000644000175000017500000001320212502221012016000 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgbtrs_(char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, complex* ab, integer* ldab, integer* ipiv, complex* b, integer* ldb, integer* info);


static VALUE
rblapack_cgbtrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer ldab;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.cgbtrs( trans, kl, ku, ab, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGBTRS solves a system of linear equations\n*     A * X = B,  A**T * X = B,  or  A**H * X = B\n*  with a general band matrix A using the LU factorization computed\n*  by CGBTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations.\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AB      (input) COMPLEX array, dimension (LDAB,N)\n*          Details of the LU factorization of the band matrix A, as\n*          computed by CGBTRF.  U is stored as an upper triangular band\n*          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n*          the multipliers used during the factorization are stored in\n*          rows KL+KU+2 to 2*KL+KU+1.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices; for 1 <= i <= N, row i of the matrix was\n*          interchanged with row IPIV(i).\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.cgbtrs( trans, kl, ku, ab, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_trans = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_b = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  cgbtrs_(&trans, &n, &kl, &ku, &nrhs, ab, &ldab, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_cgbtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgbtrs", rblapack_cgbtrs, -1);
}
ruby-lapack-1.7.2/ext/cla_rpvgrw.c0000644000175000017500000001013512502221021016664 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real cla_rpvgrw_(integer* n, integer* ncols, complex* a, integer* lda, complex* af, integer* ldaf);


static VALUE
rblapack_cla_rpvgrw(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ncols;
  integer ncols; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack___out__;
  real __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  __out__ = NumRu::Lapack.cla_rpvgrw( ncols, a, af, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL FUNCTION CLA_RPVGRW( N, NCOLS, A, LDA, AF, LDAF )\n\n*  Purpose\n*  =======\n* \n*  CLA_RPVGRW computes the reciprocal pivot growth factor\n*  norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n*  much less than 1, the stability of the LU factorization of the\n*  (equilibrated) matrix A could be poor. This also means that the\n*  solution X, estimated condition numbers, and error bounds could be\n*  unreliable.\n*\n\n*  Arguments\n*  =========\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NCOLS   (input) INTEGER\n*     The number of columns of the matrix A. NCOLS >= 0.\n*\n*     A       (input) COMPLEX array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX array, dimension (LDAF,N)\n*     The factors L and U from the factorization\n*     A = P*L*U as computed by CGETRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n      REAL               AMAX, UMAX, RPVGRW\n      COMPLEX            ZDUM\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MIN, ABS, REAL, AIMAG\n*     ..\n*     .. Statement Functions ..\n      REAL               CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.cla_rpvgrw( ncols, a, af, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_ncols = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  ncols = NUM2INT(rblapack_ncols);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);

  __out__ = cla_rpvgrw_(&n, &ncols, a, &lda, af, &ldaf);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_cla_rpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cla_rpvgrw", rblapack_cla_rpvgrw, -1);
}
ruby-lapack-1.7.2/ext/dla_syrcond.c0000644000175000017500000001744012502221025017031 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal dla_syrcond_(char* uplo, integer* n, doublereal* a, integer* lda, doublereal* af, integer* ldaf, integer* ipiv, integer* cmode, doublereal* c, integer* info, doublereal* work, integer* iwork);


static VALUE
rblapack_dla_syrcond(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_af;
  doublereal *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_cmode;
  integer cmode; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack___out__;
  doublereal __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  info, __out__ = NumRu::Lapack.dla_syrcond( uplo, a, af, ipiv, cmode, c, work, iwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION DLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF,  IPIV, CMODE, C, INFO, WORK, IWORK )\n\n*  Purpose\n*  =======\n*\n*     DLA_SYRCOND estimates the Skeel condition number of  op(A) * op2(C)\n*     where op2 is determined by CMODE as follows\n*     CMODE =  1    op2(C) = C\n*     CMODE =  0    op2(C) = I\n*     CMODE = -1    op2(C) = inv(C)\n*     The Skeel condition number cond(A) = norminf( |inv(A)||A| )\n*     is computed by computing scaling factors R such that\n*     diag(R)*A*op2(C) is row equilibrated and computing the standard\n*     infinity-norm condition number.\n*\n\n*  Arguments\n*  ==========\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) DOUBLE PRECISION array, dimension (LDAF,N)\n*     The block diagonal matrix D and the multipliers used to\n*     obtain the factor U or L as computed by DSYTRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     Details of the interchanges and the block structure of D\n*     as determined by DSYTRF.\n*\n*     CMODE   (input) INTEGER\n*     Determines op2(C) in the formula op(A) * op2(C) as follows:\n*     CMODE =  1    op2(C) = C\n*     CMODE =  0    op2(C) = I\n*     CMODE = -1    op2(C) = inv(C)\n*\n*     C       (input) DOUBLE PRECISION array, dimension (N)\n*     The vector C in the formula op(A) * op2(C).\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit.\n*     i > 0:  The ith argument is invalid.\n*\n*     WORK    (input) DOUBLE PRECISION array, dimension (3*N).\n*     Workspace.\n*\n*     IWORK   (input) INTEGER array, dimension (N).\n*     Workspace.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      CHARACTER          NORMIN\n      INTEGER            KASE, I, J\n      DOUBLE PRECISION   AINVNM, SMLNUM, TMP\n      LOGICAL            UP\n*     ..\n*     .. Local Arrays ..\n      INTEGER            ISAVE( 3 )\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            IDAMAX\n      DOUBLE PRECISION   DLAMCH\n      EXTERNAL           LSAME, IDAMAX, DLAMCH\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DLACN2, DLATRS, DRSCL, XERBLA, DSYTRS\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, __out__ = NumRu::Lapack.dla_syrcond( uplo, a, af, ipiv, cmode, c, work, iwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_cmode = argv[4];
  rblapack_c = argv[5];
  rblapack_work = argv[6];
  rblapack_iwork = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_DFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
  af = NA_PTR_TYPE(rblapack_af, doublereal*);
  cmode = NUM2INT(rblapack_cmode);
  if (!NA_IsNArray(rblapack_iwork))
    rb_raise(rb_eArgError, "iwork (8th argument) must be NArray");
  if (NA_RANK(rblapack_iwork) != 1)
    rb_raise(rb_eArgError, "rank of iwork (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_iwork) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of iwork must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_iwork) != NA_LINT)
    rblapack_iwork = na_change_type(rblapack_iwork, NA_LINT);
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (7th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (3*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 3*n);
  if (NA_TYPE(rblapack_work) != NA_DFLOAT)
    rblapack_work = na_change_type(rblapack_work, NA_DFLOAT);
  work = NA_PTR_TYPE(rblapack_work, doublereal*);

  __out__ = dla_syrcond_(&uplo, &n, a, &lda, af, &ldaf, ipiv, &cmode, c, &info, work, iwork);

  rblapack_info = INT2NUM(info);
  rblapack___out__ = rb_float_new((double)__out__);
  return rb_ary_new3(2, rblapack_info, rblapack___out__);
}

void
init_lapack_dla_syrcond(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dla_syrcond", rblapack_dla_syrcond, -1);
}
ruby-lapack-1.7.2/ext/zlacon.c0000644000175000017500000001023012502221014016002 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlacon_(integer* n, doublecomplex* v, doublecomplex* x, doublereal* est, integer* kase);


static VALUE
rblapack_zlacon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_est;
  doublereal est; 
  VALUE rblapack_kase;
  integer kase; 
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;
  doublecomplex *v;

  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  x, est, kase = NumRu::Lapack.zlacon( x, est, kase, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLACON( N, V, X, EST, KASE )\n\n*  Purpose\n*  =======\n*\n*  ZLACON estimates the 1-norm of a square, complex matrix A.\n*  Reverse communication is used for evaluating matrix-vector products.\n*\n\n*  Arguments\n*  =========\n*\n*  N      (input) INTEGER\n*         The order of the matrix.  N >= 1.\n*\n*  V      (workspace) COMPLEX*16 array, dimension (N)\n*         On the final return, V = A*W,  where  EST = norm(V)/norm(W)\n*         (W is not returned).\n*\n*  X      (input/output) COMPLEX*16 array, dimension (N)\n*         On an intermediate return, X should be overwritten by\n*               A * X,   if KASE=1,\n*               A' * X,  if KASE=2,\n*         where A' is the conjugate transpose of A, and ZLACON must be\n*         re-called with all the other parameters unchanged.\n*\n*  EST    (input/output) DOUBLE PRECISION\n*         On entry with KASE = 1 or 2 and JUMP = 3, EST should be\n*         unchanged from the previous call to ZLACON.\n*         On exit, EST is an estimate (a lower bound) for norm(A). \n*\n*  KASE   (input/output) INTEGER\n*         On the initial call to ZLACON, KASE should be 0.\n*         On an intermediate return, KASE will be 1 or 2, indicating\n*         whether X should be overwritten by A * X  or A' * X.\n*         On the final return from ZLACON, KASE will again be 0.\n*\n\n*  Further Details\n*  ======= =======\n*\n*  Contributed by Nick Higham, University of Manchester.\n*  Originally named CONEST, dated March 16, 1988.\n*\n*  Reference: N.J. Higham, \"FORTRAN codes for estimating the one-norm of\n*  a real or complex matrix, with applications to condition estimation\",\n*  ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.\n*\n*  Last modified:  April, 1999\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, est, kase = NumRu::Lapack.zlacon( x, est, kase, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_x = argv[0];
  rblapack_est = argv[1];
  rblapack_kase = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (1th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  kase = NUM2INT(rblapack_kase);
  est = NUM2DBL(rblapack_est);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  v = ALLOC_N(doublecomplex, (n));

  zlacon_(&n, v, x, &est, &kase);

  free(v);
  rblapack_est = rb_float_new((double)est);
  rblapack_kase = INT2NUM(kase);
  return rb_ary_new3(3, rblapack_x, rblapack_est, rblapack_kase);
}

void
init_lapack_zlacon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlacon", rblapack_zlacon, -1);
}
ruby-lapack-1.7.2/ext/cpbstf.c0000644000175000017500000001304212502221023016001 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cpbstf_(char* uplo, integer* n, integer* kd, complex* ab, integer* ldab, integer* info);


static VALUE
rblapack_cpbstf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  complex *ab_out__;

  integer ldab;
  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  info, ab = NumRu::Lapack.cpbstf( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPBSTF( UPLO, N, KD, AB, LDAB, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPBSTF computes a split Cholesky factorization of a complex\n*  Hermitian positive definite band matrix A.\n*\n*  This routine is designed to be used in conjunction with CHBGST.\n*\n*  The factorization has the form  A = S**H*S  where S is a band matrix\n*  of the same bandwidth as A and the following structure:\n*\n*    S = ( U    )\n*        ( M  L )\n*\n*  where U is upper triangular of order m = (n+kd)/2, and L is lower\n*  triangular of order n-m.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) COMPLEX array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix A, stored in the first kd+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*          On exit, if INFO = 0, the factor S from the split Cholesky\n*          factorization A = S**H*S. See Further Details.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\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 factorization could not be completed,\n*               because the updated element a(i,i) was negative; the\n*               matrix A is not positive definite.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  N = 7, KD = 2:\n*\n*  S = ( s11  s12  s13                     )\n*      (      s22  s23  s24                )\n*      (           s33  s34                )\n*      (                s44                )\n*      (           s53  s54  s55           )\n*      (                s64  s65  s66      )\n*      (                     s75  s76  s77 )\n*\n*  If UPLO = 'U', the array AB holds:\n*\n*  on entry:                          on exit:\n*\n*   *    *   a13  a24  a35  a46  a57   *    *   s13  s24  s53' s64' s75'\n*   *   a12  a23  a34  a45  a56  a67   *   s12  s23  s34  s54' s65' s76'\n*  a11  a22  a33  a44  a55  a66  a77  s11  s22  s33  s44  s55  s66  s77\n*\n*  If UPLO = 'L', the array AB holds:\n*\n*  on entry:                          on exit:\n*\n*  a11  a22  a33  a44  a55  a66  a77  s11  s22  s33  s44  s55  s66  s77\n*  a21  a32  a43  a54  a65  a76   *   s12' s23' s34' s54  s65  s76   *\n*  a31  a42  a53  a64  a64   *    *   s13' s24' s53  s64  s75   *    *\n*\n*  Array elements marked * are not used by the routine; s12' denotes\n*  conjg(s12); the diagonal elements of S are real.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ab = NumRu::Lapack.cpbstf( uplo, kd, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  kd = NUM2INT(rblapack_kd);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
  MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  cpbstf_(&uplo, &n, &kd, ab, &ldab, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ab);
}

void
init_lapack_cpbstf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cpbstf", rblapack_cpbstf, -1);
}
ruby-lapack-1.7.2/ext/cla_hercond_x.c0000644000175000017500000001616212502221024017317 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real cla_hercond_x_(char* uplo, integer* n, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, complex* x, integer* info, complex* work, real* rwork);


static VALUE
rblapack_cla_hercond_x(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_rwork;
  real *rwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack___out__;
  real __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  info, __out__ = NumRu::Lapack.cla_hercond_x( uplo, a, af, ipiv, x, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL FUNCTION CLA_HERCOND_X( UPLO, N, A, LDA, AF, LDAF, IPIV, X, INFO, WORK, RWORK )\n\n*  Purpose\n*  =======\n*\n*     CLA_HERCOND_X computes the infinity norm condition number of\n*     op(A) * diag(X) where X is a COMPLEX vector.\n*\n\n*  Arguments\n*  =========\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     A       (input) COMPLEX array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX array, dimension (LDAF,N)\n*     The block diagonal matrix D and the multipliers used to\n*     obtain the factor U or L as computed by CHETRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     Details of the interchanges and the block structure of D\n*     as determined by CHETRF.\n*\n*     X       (input) COMPLEX array, dimension (N)\n*     The vector X in the formula op(A) * diag(X).\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit.\n*     i > 0:  The ith argument is invalid.\n*\n*     WORK    (input) COMPLEX array, dimension (2*N).\n*     Workspace.\n*\n*     RWORK   (input) REAL array, dimension (N).\n*     Workspace.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            KASE, I, J\n      REAL               AINVNM, ANORM, TMP\n      LOGICAL            UP\n      COMPLEX            ZDUM\n*     ..\n*     .. Local Arrays ..\n      INTEGER            ISAVE( 3 )\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CLACN2, CHETRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX\n*     ..\n*     .. Statement Functions ..\n      REAL CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, __out__ = NumRu::Lapack.cla_hercond_x( uplo, a, af, ipiv, x, work, rwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_x = argv[4];
  rblapack_work = argv[5];
  rblapack_rwork = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (5th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  if (!NA_IsNArray(rblapack_rwork))
    rb_raise(rb_eArgError, "rwork (7th argument) must be NArray");
  if (NA_RANK(rblapack_rwork) != 1)
    rb_raise(rb_eArgError, "rank of rwork (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_rwork) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_rwork) != NA_SFLOAT)
    rblapack_rwork = na_change_type(rblapack_rwork, NA_SFLOAT);
  rwork = NA_PTR_TYPE(rblapack_rwork, real*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (6th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
  if (NA_TYPE(rblapack_work) != NA_SCOMPLEX)
    rblapack_work = na_change_type(rblapack_work, NA_SCOMPLEX);
  work = NA_PTR_TYPE(rblapack_work, complex*);

  __out__ = cla_hercond_x_(&uplo, &n, a, &lda, af, &ldaf, ipiv, x, &info, work, rwork);

  rblapack_info = INT2NUM(info);
  rblapack___out__ = rb_float_new((double)__out__);
  return rb_ary_new3(2, rblapack_info, rblapack___out__);
}

void
init_lapack_cla_hercond_x(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cla_hercond_x", rblapack_cla_hercond_x, -1);
}
ruby-lapack-1.7.2/ext/chegst.c0000644000175000017500000001214012502221025015775 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chegst_(integer* itype, char* uplo, integer* n, complex* a, integer* lda, complex* b, integer* ldb, integer* info);


static VALUE
rblapack_chegst(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;

  integer lda;
  integer n;
  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  info, a = NumRu::Lapack.chegst( itype, uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHEGST reduces a complex Hermitian-definite generalized\n*  eigenproblem to standard form.\n*\n*  If ITYPE = 1, the problem is A*x = lambda*B*x,\n*  and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)\n*\n*  If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n*  B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L.\n*\n*  B must have been previously factorized as U**H*U or L*L**H by CPOTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);\n*          = 2 or 3: compute U*A*U**H or L**H*A*L.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored and B is factored as\n*                  U**H*U;\n*          = 'L':  Lower triangle of A is stored and B is factored as\n*                  L*L**H.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the transformed matrix, stored in the\n*          same format as A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input) COMPLEX array, dimension (LDB,N)\n*          The triangular factor from the Cholesky factorization of B,\n*          as returned by CPOTRF.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.chegst( itype, uplo, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_itype = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  itype = NUM2INT(rblapack_itype);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  chegst_(&itype, &uplo, &n, a, &lda, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_chegst(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chegst", rblapack_chegst, -1);
}
ruby-lapack-1.7.2/ext/sgebd2.c0000644000175000017500000001707112502221013015673 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgebd2_(integer* m, integer* n, real* a, integer* lda, real* d, real* e, real* tauq, real* taup, real* work, integer* info);


static VALUE
rblapack_sgebd2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_tauq;
  real *tauq; 
  VALUE rblapack_taup;
  real *taup; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  real *work;

  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  d, e, tauq, taup, info, a = NumRu::Lapack.sgebd2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGEBD2 reduces a real general m by n matrix A to upper or lower\n*  bidiagonal form B by an orthogonal transformation: Q' * A * P = B.\n*\n*  If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows in the matrix A.  M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns in the matrix A.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the m by n general matrix to be reduced.\n*          On exit,\n*          if m >= n, the diagonal and the first superdiagonal are\n*            overwritten with the upper bidiagonal matrix B; the\n*            elements below the diagonal, with the array TAUQ, represent\n*            the orthogonal matrix Q as a product of elementary\n*            reflectors, and the elements above the first superdiagonal,\n*            with the array TAUP, represent the orthogonal matrix P as\n*            a product of elementary reflectors;\n*          if m < n, the diagonal and the first subdiagonal are\n*            overwritten with the lower bidiagonal matrix B; the\n*            elements below the first subdiagonal, with the array TAUQ,\n*            represent the orthogonal matrix Q as a product of\n*            elementary reflectors, and the elements above the diagonal,\n*            with the array TAUP, represent the orthogonal matrix P as\n*            a product of elementary reflectors.\n*          See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  D       (output) REAL array, dimension (min(M,N))\n*          The diagonal elements of the bidiagonal matrix B:\n*          D(i) = A(i,i).\n*\n*  E       (output) REAL array, dimension (min(M,N)-1)\n*          The off-diagonal elements of the bidiagonal matrix B:\n*          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n*          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n*\n*  TAUQ    (output) REAL array dimension (min(M,N))\n*          The scalar factors of the elementary reflectors which\n*          represent the orthogonal matrix Q. See Further Details.\n*\n*  TAUP    (output) REAL array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors which\n*          represent the orthogonal matrix P. See Further Details.\n*\n*  WORK    (workspace) REAL array, dimension (max(M,N))\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 matrices Q and P are represented as products of elementary\n*  reflectors:\n*\n*  If m >= n,\n*\n*     Q = H(1) H(2) . . . H(n)  and  P = G(1) G(2) . . . G(n-1)\n*\n*  Each H(i) and G(i) has the form:\n*\n*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'\n*\n*  where tauq and taup are real scalars, and v and u are real vectors;\n*  v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);\n*  u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);\n*  tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n*  If m < n,\n*\n*     Q = H(1) H(2) . . . H(m-1)  and  P = G(1) G(2) . . . G(m)\n*\n*  Each H(i) and G(i) has the form:\n*\n*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'\n*\n*  where tauq and taup are real scalars, and v and u are real vectors;\n*  v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);\n*  u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);\n*  tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n*  The contents of A on exit are illustrated by the following examples:\n*\n*  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):\n*\n*    (  d   e   u1  u1  u1 )           (  d   u1  u1  u1  u1  u1 )\n*    (  v1  d   e   u2  u2 )           (  e   d   u2  u2  u2  u2 )\n*    (  v1  v2  d   e   u3 )           (  v1  e   d   u3  u3  u3 )\n*    (  v1  v2  v3  d   e  )           (  v1  v2  e   d   u4  u4 )\n*    (  v1  v2  v3  v4  d  )           (  v1  v2  v3  e   d   u5 )\n*    (  v1  v2  v3  v4  v5 )\n*\n*  where d and e denote diagonal and off-diagonal elements of B, vi\n*  denotes an element of the vector defining H(i), and ui an element of\n*  the vector defining G(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, tauq, taup, info, a = NumRu::Lapack.sgebd2( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, real*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n)-1;
    rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tauq = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  tauq = NA_PTR_TYPE(rblapack_tauq, real*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_taup = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  taup = NA_PTR_TYPE(rblapack_taup, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(real, (MAX(m,n)));

  sgebd2_(&m, &n, a, &lda, d, e, tauq, taup, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_d, rblapack_e, rblapack_tauq, rblapack_taup, rblapack_info, rblapack_a);
}

void
init_lapack_sgebd2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgebd2", rblapack_sgebd2, -1);
}
ruby-lapack-1.7.2/ext/zungr2.c0000644000175000017500000001041412502221023015747 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zungr2_(integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* info);


static VALUE
rblapack_zungr2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  doublecomplex *work;

  integer lda;
  integer n;
  integer k;
  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  info, a = NumRu::Lapack.zungr2( a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZUNGR2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZUNGR2 generates an m by n complex matrix Q with orthonormal rows,\n*  which is defined as the last m rows of a product of k elementary\n*  reflectors of order n\n*\n*        Q  =  H(1)' H(2)' . . . H(k)'\n*\n*  as returned by ZGERQF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. N >= M.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. M >= K >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the (m-k+i)-th row must contain the vector which\n*          defines the elementary reflector H(i), for i = 1,2,...,k, as\n*          returned by ZGERQF in the last k rows of its array argument\n*          A.\n*          On exit, the m-by-n matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) COMPLEX*16 array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by ZGERQF.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (M)\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -i, the i-th argument has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.zungr2( a, tau, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_a = argv[0];
  rblapack_tau = argv[1];
  if (argc == 2) {
  } 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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  m = lda;
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (2th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (2th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(doublecomplex, (m));

  zungr2_(&m, &n, &k, a, &lda, tau, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_zungr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zungr2", rblapack_zungr2, -1);
}
ruby-lapack-1.7.2/ext/slapll.c0000644000175000017500000001102312502221023016004 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slapll_(integer* n, real* x, integer* incx, real* y, integer* incy, real* ssmin);


static VALUE
rblapack_slapll(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_y;
  real *y; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_ssmin;
  real ssmin; 
  VALUE rblapack_x_out__;
  real *x_out__;
  VALUE rblapack_y_out__;
  real *y_out__;


  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  ssmin, x, y = NumRu::Lapack.slapll( n, x, incx, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAPLL( N, X, INCX, Y, INCY, SSMIN )\n\n*  Purpose\n*  =======\n*\n*  Given two column vectors X and Y, let\n*\n*                       A = ( X Y ).\n*\n*  The subroutine first computes the QR factorization of A = Q*R,\n*  and then computes the SVD of the 2-by-2 upper triangular matrix R.\n*  The smaller singular value of R is returned in SSMIN, which is used\n*  as the measurement of the linear dependency of the vectors X and Y.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The length of the vectors X and Y.\n*\n*  X       (input/output) REAL array,\n*                         dimension (1+(N-1)*INCX)\n*          On entry, X contains the N-vector X.\n*          On exit, X is overwritten.\n*\n*  INCX    (input) INTEGER\n*          The increment between successive elements of X. INCX > 0.\n*\n*  Y       (input/output) REAL array,\n*                         dimension (1+(N-1)*INCY)\n*          On entry, Y contains the N-vector Y.\n*          On exit, Y is overwritten.\n*\n*  INCY    (input) INTEGER\n*          The increment between successive elements of Y. INCY > 0.\n*\n*  SSMIN   (output) REAL\n*          The smallest singular value of the N-by-2 matrix A = ( X Y ).\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ssmin, x, y = NumRu::Lapack.slapll( n, x, incx, y, incy, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_n = argv[0];
  rblapack_x = argv[1];
  rblapack_incx = argv[2];
  rblapack_y = argv[3];
  rblapack_incy = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  incx = NUM2INT(rblapack_incx);
  incy = NUM2INT(rblapack_incy);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1+(n-1)*incx))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (4th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incy))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
  if (NA_TYPE(rblapack_y) != NA_SFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
  y = NA_PTR_TYPE(rblapack_y, real*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incx;
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incy;
    rblapack_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
  MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  slapll_(&n, x, &incx, y, &incy, &ssmin);

  rblapack_ssmin = rb_float_new((double)ssmin);
  return rb_ary_new3(3, rblapack_ssmin, rblapack_x, rblapack_y);
}

void
init_lapack_slapll(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slapll", rblapack_slapll, -1);
}
ruby-lapack-1.7.2/ext/zgerfs.c0000644000175000017500000002075612502221012016030 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgerfs_(char* trans, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zgerfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.zgerfs( trans, a, af, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGERFS improves the computed solution to a system of linear\n*  equations and provides error bounds and backward error estimates for\n*  the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          The original N-by-N matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AF      (input) COMPLEX*16 array, dimension (LDAF,N)\n*          The factors L and U from the factorization A = P*L*U\n*          as computed by ZGETRF.\n*\n*  LDAF    (input) INTEGER\n*          The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices from ZGETRF; for 1<=i<=N, row i of the\n*          matrix was interchanged with row IPIV(i).\n*\n*  B       (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) COMPLEX*16 array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by ZGETRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.zgerfs( trans, a, af, ipiv, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_trans = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_b = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (n));

  zgerfs_(&trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_zgerfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgerfs", rblapack_zgerfs, -1);
}
ruby-lapack-1.7.2/ext/sstegr.c0000644000175000017500000003026012502221025016032 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sstegr_(char* jobz, char* range, integer* n, real* d, real* e, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, real* z, integer* ldz, integer* isuppz, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_sstegr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_vl;
  real vl; 
  VALUE rblapack_vu;
  real vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  real abstol; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_isuppz;
  integer *isuppz; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_e_out__;
  real *e_out__;

  integer n;
  integer ldz;

  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  m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.sstegr( jobz, range, d, e, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSTEGR computes selected eigenvalues and, optionally, eigenvectors\n*  of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n*  a well defined set of pairwise different real eigenvalues, the corresponding\n*  real eigenvectors are pairwise orthogonal.\n*\n*  The spectrum may be computed either completely or partially by specifying\n*  either an interval (VL,VU] or a range of indices IL:IU for the desired\n*  eigenvalues.\n*\n*  SSTEGR is a compatability wrapper around the improved SSTEMR routine.\n*  See SSTEMR for further details.\n*\n*  One important change is that the ABSTOL parameter no longer provides any\n*  benefit and hence is no longer used.\n*\n*  Note : SSTEGR and SSTEMR work only on machines which follow\n*  IEEE-754 floating-point standard in their handling of infinities and\n*  NaNs.  Normal execution may create these exceptiona values and hence\n*  may abort due to a floating point exception in environments which\n*  do not conform to the IEEE-754 standard.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found.\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found.\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  D       (input/output) REAL array, dimension (N)\n*          On entry, the N diagonal elements of the tridiagonal matrix\n*          T. On exit, D is overwritten.\n*\n*  E       (input/output) REAL array, dimension (N)\n*          On entry, the (N-1) subdiagonal elements of the tridiagonal\n*          matrix T in elements 1 to N-1 of E. E(N) need not be set on\n*          input, but is used internally as workspace.\n*          On exit, E is overwritten.\n*\n*  VL      (input) REAL\n*  VU      (input) REAL\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) REAL\n*          Unused.  Was the absolute error tolerance for the\n*          eigenvalues/eigenvectors in previous versions.\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) REAL array, dimension (N)\n*          The first M elements contain the selected eigenvalues in\n*          ascending order.\n*\n*  Z       (output) REAL array, dimension (LDZ, max(1,M) )\n*          If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix T\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*          Supplying N columns is always safe.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', then LDZ >= max(1,N).\n*\n*  ISUPPZ  (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n*          The support of the eigenvectors in Z, i.e., the indices\n*          indicating the nonzero elements in Z. The i-th computed eigenvector\n*          is nonzero only in elements ISUPPZ( 2*i-1 ) through\n*          ISUPPZ( 2*i ). This is relevant in the case when the matrix\n*          is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n*\n*  WORK    (workspace/output) REAL array, dimension (LWORK)\n*          On exit, if INFO = 0, WORK(1) returns the optimal\n*          (and minimal) LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK. LWORK >= max(1,18*N)\n*          if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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*  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.  LIWORK >= max(1,10*N)\n*          if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n*          if only the eigenvalues are to be computed.\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal size of the IWORK array,\n*          returns this value as the first entry of the IWORK array, and\n*          no error message related to LIWORK is issued by XERBLA.\n*\n*  INFO    (output) INTEGER\n*          On exit, INFO\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  if INFO = 1X, internal error in SLARRE,\n*                if INFO = 2X, internal error in SLARRV.\n*                Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n*                the nonzero error code returned by SLARRE or\n*                SLARRV, respectively.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Inderjit Dhillon, IBM Almaden, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, LBNL/NERSC, USA\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL TRYRAC\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL SSTEMR\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.sstegr( jobz, range, d, e, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 11)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_d = argv[2];
  rblapack_e = argv[3];
  rblapack_vl = argv[4];
  rblapack_vu = argv[5];
  rblapack_il = argv[6];
  rblapack_iu = argv[7];
  rblapack_abstol = argv[8];
  if (argc == 11) {
    rblapack_lwork = argv[9];
    rblapack_liwork = argv[10];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  vl = (real)NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  abstol = (real)NUM2DBL(rblapack_abstol);
  range = StringValueCStr(rblapack_range)[0];
  vu = (real)NUM2DBL(rblapack_vu);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (4th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&jobz,"V") ? 18*n : lsame_(&jobz,"N") ? 12*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  iu = NUM2INT(rblapack_iu);
  m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
  if (rblapack_liwork == Qnil)
    liwork = lsame_(&jobz,"V") ? 10*n : lsame_(&jobz,"N") ? 8*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[1];
    shape[0] = 2*MAX(1,m);
    rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
  MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;

  sstegr_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, isuppz, work, &lwork, iwork, &liwork, &info);

  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_m, rblapack_w, rblapack_z, rblapack_isuppz, rblapack_work, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e);
}

void
init_lapack_sstegr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sstegr", rblapack_sstegr, -1);
}
ruby-lapack-1.7.2/ext/clar1v.c0000644000175000017500000002526212502221014015717 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clar1v_(integer* n, integer* b1, integer* bn, real* lambda, real* d, real* l, real* ld, real* lld, real* pivmin, real* gaptol, complex* z, logical* wantnc, integer* negcnt, real* ztz, real* mingma, integer* r, integer* isuppz, real* nrminv, real* resid, real* rqcorr, real* work);


static VALUE
rblapack_clar1v(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_b1;
  integer b1; 
  VALUE rblapack_bn;
  integer bn; 
  VALUE rblapack_lambda;
  real lambda; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_l;
  real *l; 
  VALUE rblapack_ld;
  real *ld; 
  VALUE rblapack_lld;
  real *lld; 
  VALUE rblapack_pivmin;
  real pivmin; 
  VALUE rblapack_gaptol;
  real gaptol; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_wantnc;
  logical wantnc; 
  VALUE rblapack_r;
  integer r; 
  VALUE rblapack_negcnt;
  integer negcnt; 
  VALUE rblapack_ztz;
  real ztz; 
  VALUE rblapack_mingma;
  real mingma; 
  VALUE rblapack_isuppz;
  integer *isuppz; 
  VALUE rblapack_nrminv;
  real nrminv; 
  VALUE rblapack_resid;
  real resid; 
  VALUE rblapack_rqcorr;
  real rqcorr; 
  VALUE rblapack_z_out__;
  complex *z_out__;
  real *work;

  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  negcnt, ztz, mingma, isuppz, nrminv, resid, rqcorr, z, r = NumRu::Lapack.clar1v( b1, bn, lambda, d, l, ld, lld, pivmin, gaptol, z, wantnc, r, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD, PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, R, ISUPPZ, NRMINV, RESID, RQCORR, WORK )\n\n*  Purpose\n*  =======\n*\n*  CLAR1V computes the (scaled) r-th column of the inverse of\n*  the sumbmatrix in rows B1 through BN of the tridiagonal matrix\n*  L D L^T - sigma I. When sigma is close to an eigenvalue, the\n*  computed vector is an accurate eigenvector. Usually, r corresponds\n*  to the index where the eigenvector is largest in magnitude.\n*  The following steps accomplish this computation :\n*  (a) Stationary qd transform,  L D L^T - sigma I = L(+) D(+) L(+)^T,\n*  (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T,\n*  (c) Computation of the diagonal elements of the inverse of\n*      L D L^T - sigma I by combining the above transforms, and choosing\n*      r as the index where the diagonal of the inverse is (one of the)\n*      largest in magnitude.\n*  (d) Computation of the (scaled) r-th column of the inverse using the\n*      twisted factorization obtained by combining the top part of the\n*      the stationary and the bottom part of the progressive transform.\n*\n\n*  Arguments\n*  =========\n*\n*  N        (input) INTEGER\n*           The order of the matrix L D L^T.\n*\n*  B1       (input) INTEGER\n*           First index of the submatrix of L D L^T.\n*\n*  BN       (input) INTEGER\n*           Last index of the submatrix of L D L^T.\n*\n*  LAMBDA    (input) REAL            \n*           The shift. In order to compute an accurate eigenvector,\n*           LAMBDA should be a good approximation to an eigenvalue\n*           of L D L^T.\n*\n*  L        (input) REAL             array, dimension (N-1)\n*           The (n-1) subdiagonal elements of the unit bidiagonal matrix\n*           L, in elements 1 to N-1.\n*\n*  D        (input) REAL             array, dimension (N)\n*           The n diagonal elements of the diagonal matrix D.\n*\n*  LD       (input) REAL             array, dimension (N-1)\n*           The n-1 elements L(i)*D(i).\n*\n*  LLD      (input) REAL             array, dimension (N-1)\n*           The n-1 elements L(i)*L(i)*D(i).\n*\n*  PIVMIN   (input) REAL            \n*           The minimum pivot in the Sturm sequence.\n*\n*  GAPTOL   (input) REAL            \n*           Tolerance that indicates when eigenvector entries are negligible\n*           w.r.t. their contribution to the residual.\n*\n*  Z        (input/output) COMPLEX          array, dimension (N)\n*           On input, all entries of Z must be set to 0.\n*           On output, Z contains the (scaled) r-th column of the\n*           inverse. The scaling is such that Z(R) equals 1.\n*\n*  WANTNC   (input) LOGICAL\n*           Specifies whether NEGCNT has to be computed.\n*\n*  NEGCNT   (output) INTEGER\n*           If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin\n*           in the  matrix factorization L D L^T, and NEGCNT = -1 otherwise.\n*\n*  ZTZ      (output) REAL            \n*           The square of the 2-norm of Z.\n*\n*  MINGMA   (output) REAL            \n*           The reciprocal of the largest (in magnitude) diagonal\n*           element of the inverse of L D L^T - sigma I.\n*\n*  R        (input/output) INTEGER\n*           The twist index for the twisted factorization used to\n*           compute Z.\n*           On input, 0 <= R <= N. If R is input as 0, R is set to\n*           the index where (L D L^T - sigma I)^{-1} is largest\n*           in magnitude. If 1 <= R <= N, R is unchanged.\n*           On output, R contains the twist index used to compute Z.\n*           Ideally, R designates the position of the maximum entry in the\n*           eigenvector.\n*\n*  ISUPPZ   (output) INTEGER array, dimension (2)\n*           The support of the vector in Z, i.e., the vector Z is\n*           nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ).\n*\n*  NRMINV   (output) REAL            \n*           NRMINV = 1/SQRT( ZTZ )\n*\n*  RESID    (output) REAL            \n*           The residual of the FP vector.\n*           RESID = ABS( MINGMA )/SQRT( ZTZ )\n*\n*  RQCORR   (output) REAL            \n*           The Rayleigh Quotient correction to LAMBDA.\n*           RQCORR = MINGMA*TMP\n*\n*  WORK     (workspace) REAL             array, dimension (4*N)\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Beresford Parlett, University of California, Berkeley, USA\n*     Jim Demmel, University of California, Berkeley, USA\n*     Inderjit Dhillon, University of Texas, Austin, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  negcnt, ztz, mingma, isuppz, nrminv, resid, rqcorr, z, r = NumRu::Lapack.clar1v( b1, bn, lambda, d, l, ld, lld, pivmin, gaptol, z, wantnc, r, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_b1 = argv[0];
  rblapack_bn = argv[1];
  rblapack_lambda = argv[2];
  rblapack_d = argv[3];
  rblapack_l = argv[4];
  rblapack_ld = argv[5];
  rblapack_lld = argv[6];
  rblapack_pivmin = argv[7];
  rblapack_gaptol = argv[8];
  rblapack_z = argv[9];
  rblapack_wantnc = argv[10];
  rblapack_r = argv[11];
  if (argc == 12) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  b1 = NUM2INT(rblapack_b1);
  lambda = (real)NUM2DBL(rblapack_lambda);
  pivmin = (real)NUM2DBL(rblapack_pivmin);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (10th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (10th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, complex*);
  r = NUM2INT(rblapack_r);
  bn = NUM2INT(rblapack_bn);
  gaptol = (real)NUM2DBL(rblapack_gaptol);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of z");
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_ld))
    rb_raise(rb_eArgError, "ld (6th argument) must be NArray");
  if (NA_RANK(rblapack_ld) != 1)
    rb_raise(rb_eArgError, "rank of ld (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ld) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of ld must be %d", n-1);
  if (NA_TYPE(rblapack_ld) != NA_SFLOAT)
    rblapack_ld = na_change_type(rblapack_ld, NA_SFLOAT);
  ld = NA_PTR_TYPE(rblapack_ld, real*);
  wantnc = (rblapack_wantnc == Qtrue);
  if (!NA_IsNArray(rblapack_l))
    rb_raise(rb_eArgError, "l (5th argument) must be NArray");
  if (NA_RANK(rblapack_l) != 1)
    rb_raise(rb_eArgError, "rank of l (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_l) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of l must be %d", n-1);
  if (NA_TYPE(rblapack_l) != NA_SFLOAT)
    rblapack_l = na_change_type(rblapack_l, NA_SFLOAT);
  l = NA_PTR_TYPE(rblapack_l, real*);
  if (!NA_IsNArray(rblapack_lld))
    rb_raise(rb_eArgError, "lld (7th argument) must be NArray");
  if (NA_RANK(rblapack_lld) != 1)
    rb_raise(rb_eArgError, "rank of lld (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_lld) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of lld must be %d", n-1);
  if (NA_TYPE(rblapack_lld) != NA_SFLOAT)
    rblapack_lld = na_change_type(rblapack_lld, NA_SFLOAT);
  lld = NA_PTR_TYPE(rblapack_lld, real*);
  {
    na_shape_t shape[1];
    shape[0] = 2;
    rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
  MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  work = ALLOC_N(real, (4*n));

  clar1v_(&n, &b1, &bn, &lambda, d, l, ld, lld, &pivmin, &gaptol, z, &wantnc, &negcnt, &ztz, &mingma, &r, isuppz, &nrminv, &resid, &rqcorr, work);

  free(work);
  rblapack_negcnt = INT2NUM(negcnt);
  rblapack_ztz = rb_float_new((double)ztz);
  rblapack_mingma = rb_float_new((double)mingma);
  rblapack_nrminv = rb_float_new((double)nrminv);
  rblapack_resid = rb_float_new((double)resid);
  rblapack_rqcorr = rb_float_new((double)rqcorr);
  rblapack_r = INT2NUM(r);
  return rb_ary_new3(9, rblapack_negcnt, rblapack_ztz, rblapack_mingma, rblapack_isuppz, rblapack_nrminv, rblapack_resid, rblapack_rqcorr, rblapack_z, rblapack_r);
}

void
init_lapack_clar1v(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clar1v", rblapack_clar1v, -1);
}
ruby-lapack-1.7.2/ext/zggev.c0000644000175000017500000002434712502221026015657 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zggev_(char* jobvl, char* jobvr, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* alpha, doublecomplex* beta, doublecomplex* vl, integer* ldvl, doublecomplex* vr, integer* ldvr, doublecomplex* work, integer* lwork, doublereal* rwork, integer* info);


static VALUE
rblapack_zggev(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvl;
  char jobvl; 
  VALUE rblapack_jobvr;
  char jobvr; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_alpha;
  doublecomplex *alpha; 
  VALUE rblapack_beta;
  doublecomplex *beta; 
  VALUE rblapack_vl;
  doublecomplex *vl; 
  VALUE rblapack_vr;
  doublecomplex *vr; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_rwork;
  doublereal *rwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer ldvl;
  integer ldvr;

  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  alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.zggev( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGGEV computes for a pair of N-by-N complex nonsymmetric matrices\n*  (A,B), the generalized eigenvalues, and optionally, the left and/or\n*  right generalized eigenvectors.\n*\n*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n*  lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n*  singular. It is usually represented as the pair (alpha,beta), as\n*  there is a reasonable interpretation for beta=0, and even for both\n*  being zero.\n*\n*  The right generalized eigenvector v(j) corresponding to the\n*  generalized eigenvalue lambda(j) of (A,B) satisfies\n*\n*               A * v(j) = lambda(j) * B * v(j).\n*\n*  The left generalized eigenvector u(j) corresponding to the\n*  generalized eigenvalues lambda(j) of (A,B) satisfies\n*\n*               u(j)**H * A = lambda(j) * u(j)**H * B\n*\n*  where u(j)**H is the conjugate-transpose of u(j).\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVL   (input) CHARACTER*1\n*          = 'N':  do not compute the left generalized eigenvectors;\n*          = 'V':  compute the left generalized eigenvectors.\n*\n*  JOBVR   (input) CHARACTER*1\n*          = 'N':  do not compute the right generalized eigenvectors;\n*          = 'V':  compute the right generalized eigenvectors.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A, B, VL, and VR.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA, N)\n*          On entry, the matrix A in the pair (A,B).\n*          On exit, A has been overwritten.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of A.  LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB, N)\n*          On entry, the matrix B in the pair (A,B).\n*          On exit, B has been overwritten.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of B.  LDB >= max(1,N).\n*\n*  ALPHA   (output) COMPLEX*16 array, dimension (N)\n*  BETA    (output) COMPLEX*16 array, dimension (N)\n*          On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the\n*          generalized eigenvalues.\n*\n*          Note: the quotients ALPHA(j)/BETA(j) may easily over- or\n*          underflow, and BETA(j) may even be zero.  Thus, the user\n*          should avoid naively computing the ratio alpha/beta.\n*          However, ALPHA will be always less than and usually\n*          comparable with norm(A) in magnitude, and BETA always less\n*          than and usually comparable with norm(B).\n*\n*  VL      (output) COMPLEX*16 array, dimension (LDVL,N)\n*          If JOBVL = 'V', the left generalized eigenvectors u(j) are\n*          stored one after another in the columns of VL, in the same\n*          order as their eigenvalues.\n*          Each eigenvector is scaled so the largest component has\n*          abs(real part) + abs(imag. part) = 1.\n*          Not referenced if JOBVL = 'N'.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the matrix VL. LDVL >= 1, and\n*          if JOBVL = 'V', LDVL >= N.\n*\n*  VR      (output) COMPLEX*16 array, dimension (LDVR,N)\n*          If JOBVR = 'V', the right generalized eigenvectors v(j) are\n*          stored one after another in the columns of VR, in the same\n*          order as their eigenvalues.\n*          Each eigenvector is scaled so the largest component has\n*          abs(real part) + abs(imag. part) = 1.\n*          Not referenced if JOBVR = 'N'.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the matrix VR. LDVR >= 1, and\n*          if JOBVR = 'V', LDVR >= N.\n*\n*  WORK    (workspace/output) COMPLEX*16 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,2*N).\n*          For good performance, LWORK must generally be larger.\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*  RWORK   (workspace/output) DOUBLE PRECISION array, dimension (8*N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          =1,...,N:\n*                The QZ iteration failed.  No eigenvectors have been\n*                calculated, but ALPHA(j) and BETA(j) should be\n*                correct for j=INFO+1,...,N.\n*          > N:  =N+1: other then QZ iteration failed in DHGEQZ,\n*                =N+2: error return from DTGEVC.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.zggev( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_jobvl = argv[0];
  rblapack_jobvr = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  jobvl = StringValueCStr(rblapack_jobvl)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  jobvr = StringValueCStr(rblapack_jobvr)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  ldvr = lsame_(&jobvr,"V") ? n : 1;
  if (rblapack_lwork == Qnil)
    lwork = MAX(1,2*n);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldvl = lsame_(&jobvl,"V") ? n : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  alpha = NA_PTR_TYPE(rblapack_alpha, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = n;
    rblapack_vl = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  vl = NA_PTR_TYPE(rblapack_vl, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = n;
    rblapack_vr = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  vr = NA_PTR_TYPE(rblapack_vr, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = 8*n;
    rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zggev_(&jobvl, &jobvr, &n, a, &lda, b, &ldb, alpha, beta, vl, &ldvl, vr, &ldvr, work, &lwork, rwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_alpha, rblapack_beta, rblapack_vl, rblapack_vr, rblapack_work, rblapack_rwork, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_zggev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zggev", rblapack_zggev, -1);
}
ruby-lapack-1.7.2/ext/zlaqsp.c0000644000175000017500000001202612502221023016033 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlaqsp_(char* uplo, integer* n, doublecomplex* ap, doublereal* s, doublereal* scond, doublereal* amax, char* equed);


static VALUE
rblapack_zlaqsp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_scond;
  doublereal scond; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_ap_out__;
  doublecomplex *ap_out__;

  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  equed, ap = NumRu::Lapack.zlaqsp( uplo, ap, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )\n\n*  Purpose\n*  =======\n*\n*  ZLAQSP equilibrates a symmetric matrix A using the scaling factors\n*  in the vector S.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, the equilibrated matrix:  diag(S) * A * diag(S), in\n*          the same storage format as A.\n*\n*  S       (input) DOUBLE PRECISION array, dimension (N)\n*          The scale factors for A.\n*\n*  SCOND   (input) DOUBLE PRECISION\n*          Ratio of the smallest S(i) to the largest S(i).\n*\n*  AMAX    (input) DOUBLE PRECISION\n*          Absolute value of largest matrix entry.\n*\n*  EQUED   (output) CHARACTER*1\n*          Specifies whether or not equilibration was done.\n*          = 'N':  No equilibration.\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*\n*  Internal Parameters\n*  ===================\n*\n*  THRESH is a threshold value used to decide if scaling should be done\n*  based on the ratio of the scaling factors.  If SCOND < THRESH,\n*  scaling is done.\n*\n*  LARGE and SMALL are threshold values used to decide if scaling should\n*  be done based on the absolute size of the largest matrix element.\n*  If AMAX > LARGE or AMAX < SMALL, scaling is done.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  equed, ap = NumRu::Lapack.zlaqsp( uplo, ap, s, scond, amax, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_s = argv[2];
  rblapack_scond = argv[3];
  rblapack_amax = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (3th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_s);
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  amax = NUM2DBL(rblapack_amax);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  scond = NUM2DBL(rblapack_scond);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
  MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  zlaqsp_(&uplo, &n, ap, s, &scond, &amax, &equed);

  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(2, rblapack_equed, rblapack_ap);
}

void
init_lapack_zlaqsp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlaqsp", rblapack_zlaqsp, -1);
}
ruby-lapack-1.7.2/ext/dpftrf.c0000644000175000017500000001715212502221017016016 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dpftrf_(char* transr, char* uplo, integer* n, doublereal* a, integer* info);


static VALUE
rblapack_dpftrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;


  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  info, a = NumRu::Lapack.dpftrf( transr, uplo, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPFTRF( TRANSR, UPLO, N, A, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPFTRF computes the Cholesky factorization of a real symmetric\n*  positive definite matrix A.\n*\n*  The factorization has the form\n*     A = U**T * U,  if UPLO = 'U', or\n*     A = L  * L**T,  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is lower triangular.\n*\n*  This is the block version of the algorithm, calling Level 3 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR    (input) CHARACTER*1\n*          = 'N':  The Normal TRANSR of RFP A is stored;\n*          = 'T':  The Transpose TRANSR of RFP A is stored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of RFP A is stored;\n*          = 'L':  Lower triangle of RFP A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 );\n*          On entry, the symmetric matrix A in RFP format. RFP format is\n*          described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n*          then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n*          (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is\n*          the transpose of RFP A as defined when\n*          TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n*          follows: If UPLO = 'U' the RFP A contains the NT elements of\n*          upper packed A. If UPLO = 'L' the RFP A contains the elements\n*          of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n*          'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n*          is odd. See the Note below for more details.\n*\n*          On exit, if INFO = 0, the factor U or L from the Cholesky\n*          factorization RFP A = U**T*U or RFP A = L*L**T.\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 leading minor of order i is not\n*                positive definite, and the factorization could not be\n*                completed.\n*\n\n*  Further Details\n*  ===============\n*\n*  We first consider Rectangular Full Packed (RFP) Format when N is\n*  even. We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  the transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  the transpose of the last three columns of AP lower.\n*  This covers the case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        03 04 05                33 43 53\n*        13 14 15                00 44 54\n*        23 24 25                10 11 55\n*        33 34 35                20 21 22\n*        00 44 45                30 31 32\n*        01 11 55                40 41 42\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We then consider Rectangular Full Packed (RFP) Format when N is\n*  odd. We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  the transpose of the first two columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  the transpose of the last two columns of AP lower.\n*  This covers the case N odd and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        02 03 04                00 33 43\n*        12 13 14                10 11 44\n*        22 23 24                20 21 22\n*        00 33 34                30 31 32\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*           RFP A                   RFP A\n*\n*     02 12 22 00 01             00 10 20 30 40 50\n*     03 13 23 33 11             33 11 21 31 41 51\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.dpftrf( transr, uplo, n, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_n = argv[2];
  rblapack_a = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  n = NUM2INT(rblapack_n);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 1)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_a_out__ = na_make_object(NA_DFLOAT, 1, 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__;

  dpftrf_(&transr, &uplo, &n, a, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_dpftrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dpftrf", rblapack_dpftrf, -1);
}
ruby-lapack-1.7.2/ext/claqps.c0000644000175000017500000002362712502221014016015 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID claqps_(integer* m, integer* n, integer* offset, integer* nb, integer* kb, complex* a, integer* lda, integer* jpvt, complex* tau, real* vn1, real* vn2, complex* auxv, complex* f, integer* ldf);


static VALUE
rblapack_claqps(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_offset;
  integer offset; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_jpvt;
  integer *jpvt; 
  VALUE rblapack_vn1;
  real *vn1; 
  VALUE rblapack_vn2;
  real *vn2; 
  VALUE rblapack_auxv;
  complex *auxv; 
  VALUE rblapack_f;
  complex *f; 
  VALUE rblapack_kb;
  integer kb; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_jpvt_out__;
  integer *jpvt_out__;
  VALUE rblapack_vn1_out__;
  real *vn1_out__;
  VALUE rblapack_vn2_out__;
  real *vn2_out__;
  VALUE rblapack_auxv_out__;
  complex *auxv_out__;
  VALUE rblapack_f_out__;
  complex *f_out__;

  integer lda;
  integer n;
  integer nb;
  integer ldf;

  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  kb, tau, a, jpvt, vn1, vn2, auxv, f = NumRu::Lapack.claqps( m, offset, a, jpvt, vn1, vn2, auxv, f, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, VN2, AUXV, F, LDF )\n\n*  Purpose\n*  =======\n*\n*  CLAQPS computes a step of QR factorization with column pivoting\n*  of a complex M-by-N matrix A by using Blas-3.  It tries to factorize\n*  NB columns from A starting from the row OFFSET+1, and updates all\n*  of the matrix with Blas-3 xGEMM.\n*\n*  In some cases, due to catastrophic cancellations, it cannot\n*  factorize NB columns.  Hence, the actual number of factorized\n*  columns is returned in KB.\n*\n*  Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\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*  OFFSET  (input) INTEGER\n*          The number of rows of A that have been factorized in\n*          previous steps.\n*\n*  NB      (input) INTEGER\n*          The number of columns to factorize.\n*\n*  KB      (output) INTEGER\n*          The number of columns actually factorized.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, block A(OFFSET+1:M,1:KB) is the triangular\n*          factor obtained and block A(1:OFFSET,1:N) has been\n*          accordingly pivoted, but no factorized.\n*          The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has\n*          been updated.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  JPVT    (input/output) INTEGER array, dimension (N)\n*          JPVT(I) = K <==> Column K of the full matrix A has been\n*          permuted into position I in AP.\n*\n*  TAU     (output) COMPLEX array, dimension (KB)\n*          The scalar factors of the elementary reflectors.\n*\n*  VN1     (input/output) REAL array, dimension (N)\n*          The vector with the partial column norms.\n*\n*  VN2     (input/output) REAL array, dimension (N)\n*          The vector with the exact column norms.\n*\n*  AUXV    (input/output) COMPLEX array, dimension (NB)\n*          Auxiliar vector.\n*\n*  F       (input/output) COMPLEX array, dimension (LDF,NB)\n*          Matrix F' = L*Y'*A.\n*\n*  LDF     (input) INTEGER\n*          The leading dimension of the array F. LDF >= max(1,N).\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n*    X. Sun, Computer Science Dept., Duke University, USA\n*\n*  Partial column norm updating strategy modified by\n*    Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n*    University of Zagreb, Croatia.\n*     June 2010\n*  For more details see LAPACK Working Note 176.\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  kb, tau, a, jpvt, vn1, vn2, auxv, f = NumRu::Lapack.claqps( m, offset, a, jpvt, vn1, vn2, auxv, f, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_m = argv[0];
  rblapack_offset = argv[1];
  rblapack_a = argv[2];
  rblapack_jpvt = argv[3];
  rblapack_vn1 = argv[4];
  rblapack_vn2 = argv[5];
  rblapack_auxv = argv[6];
  rblapack_f = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_vn1))
    rb_raise(rb_eArgError, "vn1 (5th argument) must be NArray");
  if (NA_RANK(rblapack_vn1) != 1)
    rb_raise(rb_eArgError, "rank of vn1 (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_vn1) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of vn1 must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_vn1) != NA_SFLOAT)
    rblapack_vn1 = na_change_type(rblapack_vn1, NA_SFLOAT);
  vn1 = NA_PTR_TYPE(rblapack_vn1, real*);
  if (!NA_IsNArray(rblapack_auxv))
    rb_raise(rb_eArgError, "auxv (7th argument) must be NArray");
  if (NA_RANK(rblapack_auxv) != 1)
    rb_raise(rb_eArgError, "rank of auxv (7th argument) must be %d", 1);
  nb = NA_SHAPE0(rblapack_auxv);
  if (NA_TYPE(rblapack_auxv) != NA_SCOMPLEX)
    rblapack_auxv = na_change_type(rblapack_auxv, NA_SCOMPLEX);
  auxv = NA_PTR_TYPE(rblapack_auxv, complex*);
  offset = NUM2INT(rblapack_offset);
  if (!NA_IsNArray(rblapack_vn2))
    rb_raise(rb_eArgError, "vn2 (6th argument) must be NArray");
  if (NA_RANK(rblapack_vn2) != 1)
    rb_raise(rb_eArgError, "rank of vn2 (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_vn2) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of vn2 must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_vn2) != NA_SFLOAT)
    rblapack_vn2 = na_change_type(rblapack_vn2, NA_SFLOAT);
  vn2 = NA_PTR_TYPE(rblapack_vn2, real*);
  if (!NA_IsNArray(rblapack_jpvt))
    rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
  if (NA_RANK(rblapack_jpvt) != 1)
    rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_jpvt) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_jpvt) != NA_LINT)
    rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
  jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
  if (!NA_IsNArray(rblapack_f))
    rb_raise(rb_eArgError, "f (8th argument) must be NArray");
  if (NA_RANK(rblapack_f) != 2)
    rb_raise(rb_eArgError, "rank of f (8th argument) must be %d", 2);
  ldf = NA_SHAPE0(rblapack_f);
  if (NA_SHAPE1(rblapack_f) != nb)
    rb_raise(rb_eRuntimeError, "shape 1 of f must be the same as shape 0 of auxv");
  if (NA_TYPE(rblapack_f) != NA_SCOMPLEX)
    rblapack_f = na_change_type(rblapack_f, NA_SCOMPLEX);
  f = NA_PTR_TYPE(rblapack_f, complex*);
  kb = nb;
  {
    na_shape_t shape[1];
    shape[0] = kb;
    rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
  MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
  rblapack_jpvt = rblapack_jpvt_out__;
  jpvt = jpvt_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_vn1_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  vn1_out__ = NA_PTR_TYPE(rblapack_vn1_out__, real*);
  MEMCPY(vn1_out__, vn1, real, NA_TOTAL(rblapack_vn1));
  rblapack_vn1 = rblapack_vn1_out__;
  vn1 = vn1_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_vn2_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  vn2_out__ = NA_PTR_TYPE(rblapack_vn2_out__, real*);
  MEMCPY(vn2_out__, vn2, real, NA_TOTAL(rblapack_vn2));
  rblapack_vn2 = rblapack_vn2_out__;
  vn2 = vn2_out__;
  {
    na_shape_t shape[1];
    shape[0] = nb;
    rblapack_auxv_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  auxv_out__ = NA_PTR_TYPE(rblapack_auxv_out__, complex*);
  MEMCPY(auxv_out__, auxv, complex, NA_TOTAL(rblapack_auxv));
  rblapack_auxv = rblapack_auxv_out__;
  auxv = auxv_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldf;
    shape[1] = nb;
    rblapack_f_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  f_out__ = NA_PTR_TYPE(rblapack_f_out__, complex*);
  MEMCPY(f_out__, f, complex, NA_TOTAL(rblapack_f));
  rblapack_f = rblapack_f_out__;
  f = f_out__;

  claqps_(&m, &n, &offset, &nb, &kb, a, &lda, jpvt, tau, vn1, vn2, auxv, f, &ldf);

  rblapack_kb = INT2NUM(kb);
  return rb_ary_new3(8, rblapack_kb, rblapack_tau, rblapack_a, rblapack_jpvt, rblapack_vn1, rblapack_vn2, rblapack_auxv, rblapack_f);
}

void
init_lapack_claqps(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "claqps", rblapack_claqps, -1);
}
ruby-lapack-1.7.2/ext/dlatps.c0000644000175000017500000002416212502221022016013 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlatps_(char* uplo, char* trans, char* diag, char* normin, integer* n, doublereal* ap, doublereal* x, doublereal* scale, doublereal* cnorm, integer* info);


static VALUE
rblapack_dlatps(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_normin;
  char normin; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_cnorm;
  doublereal *cnorm; 
  VALUE rblapack_scale;
  doublereal scale; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  doublereal *x_out__;
  VALUE rblapack_cnorm_out__;
  doublereal *cnorm_out__;

  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  scale, info, x, cnorm = NumRu::Lapack.dlatps( uplo, trans, diag, normin, ap, x, cnorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, CNORM, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLATPS solves one of the triangular systems\n*\n*     A *x = s*b  or  A'*x = s*b\n*\n*  with scaling to prevent overflow, where A is an upper or lower\n*  triangular matrix stored in packed form.  Here A' denotes the\n*  transpose of A, x and b are n-element vectors, and s is a scaling\n*  factor, usually less than or equal to 1, chosen so that the\n*  components of x will be less than the overflow threshold.  If the\n*  unscaled problem will not cause overflow, the Level 2 BLAS routine\n*  DTPSV is called. If the matrix A is singular (A(j,j) = 0 for some j),\n*  then s is set to 0 and a non-trivial solution to A*x = 0 is returned.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the matrix A is upper or lower triangular.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the operation applied to A.\n*          = 'N':  Solve A * x = s*b  (No transpose)\n*          = 'T':  Solve A'* x = s*b  (Transpose)\n*          = 'C':  Solve A'* x = s*b  (Conjugate transpose = Transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          Specifies whether or not the matrix A is unit triangular.\n*          = 'N':  Non-unit triangular\n*          = 'U':  Unit triangular\n*\n*  NORMIN  (input) CHARACTER*1\n*          Specifies whether CNORM has been set or not.\n*          = 'Y':  CNORM contains the column norms on entry\n*          = 'N':  CNORM is not set on entry.  On exit, the norms will\n*                  be computed and stored in CNORM.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          The upper or lower triangular matrix A, packed columnwise in\n*          a linear array.  The j-th column of A is stored in the array\n*          AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  X       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the right hand side b of the triangular system.\n*          On exit, X is overwritten by the solution vector x.\n*\n*  SCALE   (output) DOUBLE PRECISION\n*          The scaling factor s for the triangular system\n*             A * x = s*b  or  A'* x = s*b.\n*          If SCALE = 0, the matrix A is singular or badly scaled, and\n*          the vector x is an exact or approximate solution to A*x = 0.\n*\n*  CNORM   (input or output) DOUBLE PRECISION array, dimension (N)\n*\n*          If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n*          contains the norm of the off-diagonal part of the j-th column\n*          of A.  If TRANS = 'N', CNORM(j) must be greater than or equal\n*          to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n*          must be greater than or equal to the 1-norm.\n*\n*          If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n*          returns the 1-norm of the offdiagonal part of the j-th column\n*          of A.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -k, the k-th argument had an illegal value\n*\n\n*  Further Details\n*  ======= =======\n*\n*  A rough bound on x is computed; if that is less than overflow, DTPSV\n*  is called, otherwise, specific code is used which checks for possible\n*  overflow or divide-by-zero at every operation.\n*\n*  A columnwise scheme is used for solving A*x = b.  The basic algorithm\n*  if A is lower triangular is\n*\n*       x[1:n] := b[1:n]\n*       for j = 1, ..., n\n*            x(j) := x(j) / A(j,j)\n*            x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n*       end\n*\n*  Define bounds on the components of x after j iterations of the loop:\n*     M(j) = bound on x[1:j]\n*     G(j) = bound on x[j+1:n]\n*  Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n*  Then for iteration j+1 we have\n*     M(j+1) <= G(j) / | A(j+1,j+1) |\n*     G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n*            <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n*  where CNORM(j+1) is greater than or equal to the infinity-norm of\n*  column j+1 of A, not counting the diagonal.  Hence\n*\n*     G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n*                  1<=i<=j\n*  and\n*\n*     |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n*                                   1<=i< j\n*\n*  Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTPSV if the\n*  reciprocal of the largest M(j), j=1,..,n, is larger than\n*  max(underflow, 1/overflow).\n*\n*  The bound on x(j) is also used to determine when a step in the\n*  columnwise method can be performed without fear of overflow.  If\n*  the computed bound is greater than a large constant, x is scaled to\n*  prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n*  1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n*  Similarly, a row-wise scheme is used to solve A'*x = b.  The basic\n*  algorithm for A upper triangular is\n*\n*       for j = 1, ..., n\n*            x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n*       end\n*\n*  We simultaneously compute two bounds\n*       G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n*       M(j) = bound on x(i), 1<=i<=j\n*\n*  The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n*  add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n*  Then the bound on x(j) is\n*\n*       M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n*            <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n*                      1<=i<=j\n*\n*  and we can safely call DTPSV if 1/M(n) and 1/G(n) are both greater\n*  than max(underflow, 1/overflow).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, info, x, cnorm = NumRu::Lapack.dlatps( uplo, trans, diag, normin, ap, x, cnorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_normin = argv[3];
  rblapack_ap = argv[4];
  rblapack_x = argv[5];
  rblapack_cnorm = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_cnorm))
    rb_raise(rb_eArgError, "cnorm (7th argument) must be NArray");
  if (NA_RANK(rblapack_cnorm) != 1)
    rb_raise(rb_eArgError, "rank of cnorm (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_cnorm) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of cnorm must be the same as shape 0 of x");
  if (NA_TYPE(rblapack_cnorm) != NA_DFLOAT)
    rblapack_cnorm = na_change_type(rblapack_cnorm, NA_DFLOAT);
  cnorm = NA_PTR_TYPE(rblapack_cnorm, doublereal*);
  normin = StringValueCStr(rblapack_normin)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_cnorm_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  cnorm_out__ = NA_PTR_TYPE(rblapack_cnorm_out__, doublereal*);
  MEMCPY(cnorm_out__, cnorm, doublereal, NA_TOTAL(rblapack_cnorm));
  rblapack_cnorm = rblapack_cnorm_out__;
  cnorm = cnorm_out__;

  dlatps_(&uplo, &trans, &diag, &normin, &n, ap, x, &scale, cnorm, &info);

  rblapack_scale = rb_float_new((double)scale);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_scale, rblapack_info, rblapack_x, rblapack_cnorm);
}

void
init_lapack_dlatps(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlatps", rblapack_dlatps, -1);
}
ruby-lapack-1.7.2/ext/dstevx.c0000644000175000017500000002367512502221021016050 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dstevx_(char* jobz, char* range, integer* n, doublereal* d, doublereal* e, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublereal* z, integer* ldz, doublereal* work, integer* iwork, integer* ifail, integer* info);


static VALUE
rblapack_dstevx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_vl;
  doublereal vl; 
  VALUE rblapack_vu;
  doublereal vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  doublereal abstol; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_ifail;
  integer *ifail; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_e_out__;
  doublereal *e_out__;
  doublereal *work;
  integer *iwork;

  integer n;
  integer ldz;

  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  m, w, z, ifail, info, d, e = NumRu::Lapack.dstevx( jobz, range, d, e, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSTEVX computes selected eigenvalues and, optionally, eigenvectors\n*  of a real symmetric tridiagonal matrix A.  Eigenvalues and\n*  eigenvectors can be selected by specifying either a range of values\n*  or a range of indices for the desired eigenvalues.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found.\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found.\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the n diagonal elements of the tridiagonal matrix\n*          A.\n*          On exit, D may be multiplied by a constant factor chosen\n*          to avoid over/underflow in computing the eigenvalues.\n*\n*  E       (input/output) DOUBLE PRECISION array, dimension (max(1,N-1))\n*          On entry, the (n-1) subdiagonal elements of the tridiagonal\n*          matrix A in elements 1 to N-1 of E.\n*          On exit, E may be multiplied by a constant factor chosen\n*          to avoid over/underflow in computing the eigenvalues.\n*\n*  VL      (input) DOUBLE PRECISION\n*  VU      (input) DOUBLE PRECISION\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) DOUBLE PRECISION\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less\n*          than or equal to zero, then  EPS*|T|  will be used in\n*          its place, where |T| is the 1-norm of the tridiagonal\n*          matrix.\n*\n*          Eigenvalues will be computed most accurately when ABSTOL is\n*          set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n*          If this routine returns with INFO>0, indicating that some\n*          eigenvectors did not converge, try setting ABSTOL to\n*          2*DLAMCH('S').\n*\n*          See \"Computing Small Singular Values of Bidiagonal Matrices\n*          with Guaranteed High Relative Accuracy,\" by Demmel and\n*          Kahan, LAPACK Working Note #3.\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          The first M elements contain the selected eigenvalues in\n*          ascending order.\n*\n*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )\n*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix A\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          If an eigenvector fails to converge (INFO > 0), then that\n*          column of Z contains the latest approximation to the\n*          eigenvector, and the index of the eigenvector is returned\n*          in IFAIL.  If JOBZ = 'N', then Z is not referenced.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (5*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (5*N)\n*\n*  IFAIL   (output) INTEGER array, dimension (N)\n*          If JOBZ = 'V', then if INFO = 0, the first M elements of\n*          IFAIL are zero.  If INFO > 0, then IFAIL contains the\n*          indices of the eigenvectors that failed to converge.\n*          If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n*                Their indices are stored in array IFAIL.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, ifail, info, d, e = NumRu::Lapack.dstevx( jobz, range, d, e, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_d = argv[2];
  rblapack_e = argv[3];
  rblapack_vl = argv[4];
  rblapack_vu = argv[5];
  rblapack_il = argv[6];
  rblapack_iu = argv[7];
  rblapack_abstol = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  vl = NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  abstol = NUM2DBL(rblapack_abstol);
  m = n;
  range = StringValueCStr(rblapack_range)[0];
  vu = NUM2DBL(rblapack_vu);
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (4th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (MAX(1,n-1)))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", MAX(1,n-1));
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  iu = NUM2INT(rblapack_iu);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,n-1);
    rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
  MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  work = ALLOC_N(doublereal, (5*n));
  iwork = ALLOC_N(integer, (5*n));

  dstevx_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, iwork, ifail, &info);

  free(work);
  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_d, rblapack_e);
}

void
init_lapack_dstevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dstevx", rblapack_dstevx, -1);
}
ruby-lapack-1.7.2/ext/sormql.c0000644000175000017500000001621112502221021016034 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sormql_(char* side, char* trans, integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* c, integer* ldc, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sormql(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  real *c_out__;

  integer lda;
  integer k;
  integer ldc;
  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  work, info, c = NumRu::Lapack.sormql( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SORMQL overwrites the general real M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'T':      Q**T * C       C * Q**T\n*\n*  where Q is a real orthogonal matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(k) . . . H(2) H(1)\n*\n*  as returned by SGEQLF. Q is of order M if SIDE = 'L' and of order N\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**T from the Left;\n*          = 'R': apply Q or Q**T from the Right.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'T':  Transpose, apply Q**T.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) REAL array, dimension (LDA,K)\n*          The i-th column must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          SGEQLF in the last k columns of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*          If SIDE = 'L', LDA >= max(1,M);\n*          if SIDE = 'R', LDA >= max(1,N).\n*\n*  TAU     (input) REAL array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by SGEQLF.\n*\n*  C       (input/output) REAL array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace/output) REAL 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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M).\n*          For optimum performance LWORK >= N*NB if SIDE = 'L', and\n*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n*          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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.sormql( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_m = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 7) {
    rblapack_lwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  side = StringValueCStr(rblapack_side)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != k)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  sormql_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_sormql(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sormql", rblapack_sormql, -1);
}
ruby-lapack-1.7.2/ext/slaic1.c0000644000175000017500000001104512502221013015674 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaic1_(integer* job, integer* j, real* x, real* sest, real* w, real* gamma, real* sestpr, real* s, real* c);


static VALUE
rblapack_slaic1(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  integer job; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_sest;
  real sest; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_gamma;
  real gamma; 
  VALUE rblapack_sestpr;
  real sestpr; 
  VALUE rblapack_s;
  real s; 
  VALUE rblapack_c;
  real c; 

  integer j;

  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  sestpr, s, c = NumRu::Lapack.slaic1( job, x, sest, w, gamma, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C )\n\n*  Purpose\n*  =======\n*\n*  SLAIC1 applies one step of incremental condition estimation in\n*  its simplest version:\n*\n*  Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j\n*  lower triangular matrix L, such that\n*           twonorm(L*x) = sest\n*  Then SLAIC1 computes sestpr, s, c such that\n*  the vector\n*                  [ s*x ]\n*           xhat = [  c  ]\n*  is an approximate singular vector of\n*                  [ L     0  ]\n*           Lhat = [ w' gamma ]\n*  in the sense that\n*           twonorm(Lhat*xhat) = sestpr.\n*\n*  Depending on JOB, an estimate for the largest or smallest singular\n*  value is computed.\n*\n*  Note that [s c]' and sestpr**2 is an eigenpair of the system\n*\n*      diag(sest*sest, 0) + [alpha  gamma] * [ alpha ]\n*                                            [ gamma ]\n*\n*  where  alpha =  x'*w.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) INTEGER\n*          = 1: an estimate for the largest singular value is computed.\n*          = 2: an estimate for the smallest singular value is computed.\n*\n*  J       (input) INTEGER\n*          Length of X and W\n*\n*  X       (input) REAL array, dimension (J)\n*          The j-vector x.\n*\n*  SEST    (input) REAL\n*          Estimated singular value of j by j matrix L\n*\n*  W       (input) REAL array, dimension (J)\n*          The j-vector w.\n*\n*  GAMMA   (input) REAL\n*          The diagonal element gamma.\n*\n*  SESTPR  (output) REAL\n*          Estimated singular value of (j+1) by (j+1) matrix Lhat.\n*\n*  S       (output) REAL\n*          Sine needed in forming xhat.\n*\n*  C       (output) REAL\n*          Cosine needed in forming xhat.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sestpr, s, c = NumRu::Lapack.slaic1( job, x, sest, w, gamma, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_job = argv[0];
  rblapack_x = argv[1];
  rblapack_sest = argv[2];
  rblapack_w = argv[3];
  rblapack_gamma = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  job = NUM2INT(rblapack_job);
  sest = (real)NUM2DBL(rblapack_sest);
  gamma = (real)NUM2DBL(rblapack_gamma);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
  j = NA_SHAPE0(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  if (!NA_IsNArray(rblapack_w))
    rb_raise(rb_eArgError, "w (4th argument) must be NArray");
  if (NA_RANK(rblapack_w) != 1)
    rb_raise(rb_eArgError, "rank of w (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_w) != j)
    rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of x");
  if (NA_TYPE(rblapack_w) != NA_SFLOAT)
    rblapack_w = na_change_type(rblapack_w, NA_SFLOAT);
  w = NA_PTR_TYPE(rblapack_w, real*);

  slaic1_(&job, &j, x, &sest, w, &gamma, &sestpr, &s, &c);

  rblapack_sestpr = rb_float_new((double)sestpr);
  rblapack_s = rb_float_new((double)s);
  rblapack_c = rb_float_new((double)c);
  return rb_ary_new3(3, rblapack_sestpr, rblapack_s, rblapack_c);
}

void
init_lapack_slaic1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaic1", rblapack_slaic1, -1);
}
ruby-lapack-1.7.2/ext/ztgsen.c0000644000175000017500000005263512502221021016043 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztgsen_(integer* ijob, logical* wantq, logical* wantz, logical* select, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* alpha, doublecomplex* beta, doublecomplex* q, integer* ldq, doublecomplex* z, integer* ldz, integer* m, doublereal* pl, doublereal* pr, doublereal* dif, doublecomplex* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_ztgsen(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ijob;
  integer ijob; 
  VALUE rblapack_wantq;
  logical wantq; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_select;
  logical *select; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_q;
  doublecomplex *q; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_alpha;
  doublecomplex *alpha; 
  VALUE rblapack_beta;
  doublecomplex *beta; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_pl;
  doublereal pl; 
  VALUE rblapack_pr;
  doublereal pr; 
  VALUE rblapack_dif;
  doublereal *dif; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  VALUE rblapack_q_out__;
  doublecomplex *q_out__;
  VALUE rblapack_z_out__;
  doublecomplex *z_out__;

  integer n;
  integer lda;
  integer ldb;
  integer ldq;
  integer ldz;

  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  alpha, beta, m, pl, pr, dif, work, iwork, info, a, b, q, z = NumRu::Lapack.ztgsen( ijob, wantq, wantz, select, a, b, q, z, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTGSEN reorders the generalized Schur decomposition of a complex\n*  matrix pair (A, B) (in terms of an unitary equivalence trans-\n*  formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues\n*  appears in the leading diagonal blocks of the pair (A,B). The leading\n*  columns of Q and Z form unitary bases of the corresponding left and\n*  right eigenspaces (deflating subspaces). (A, B) must be in\n*  generalized Schur canonical form, that is, A and B are both upper\n*  triangular.\n*\n*  ZTGSEN also computes the generalized eigenvalues\n*\n*           w(j)= ALPHA(j) / BETA(j)\n*\n*  of the reordered matrix pair (A, B).\n*\n*  Optionally, the routine computes estimates of reciprocal condition\n*  numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),\n*  (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)\n*  between the matrix pairs (A11, B11) and (A22,B22) that correspond to\n*  the selected cluster and the eigenvalues outside the cluster, resp.,\n*  and norms of \"projections\" onto left and right eigenspaces w.r.t.\n*  the selected cluster in the (1,1)-block.\n*\n*\n\n*  Arguments\n*  =========\n*\n*  IJOB    (input) integer\n*          Specifies whether condition numbers are required for the\n*          cluster of eigenvalues (PL and PR) or the deflating subspaces\n*          (Difu and Difl):\n*           =0: Only reorder w.r.t. SELECT. No extras.\n*           =1: Reciprocal of norms of \"projections\" onto left and right\n*               eigenspaces w.r.t. the selected cluster (PL and PR).\n*           =2: Upper bounds on Difu and Difl. F-norm-based estimate\n*               (DIF(1:2)).\n*           =3: Estimate of Difu and Difl. 1-norm-based estimate\n*               (DIF(1:2)).\n*               About 5 times as expensive as IJOB = 2.\n*           =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic\n*               version to get it all.\n*           =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)\n*\n*  WANTQ   (input) LOGICAL\n*          .TRUE. : update the left transformation matrix Q;\n*          .FALSE.: do not update Q.\n*\n*  WANTZ   (input) LOGICAL\n*          .TRUE. : update the right transformation matrix Z;\n*          .FALSE.: do not update Z.\n*\n*  SELECT  (input) LOGICAL array, dimension (N)\n*          SELECT specifies the eigenvalues in the selected cluster. To\n*          select an eigenvalue w(j), SELECT(j) must be set to\n*          .TRUE..\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B. N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension(LDA,N)\n*          On entry, the upper triangular matrix A, in generalized\n*          Schur canonical form.\n*          On exit, A is overwritten by the reordered matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX*16 array, dimension(LDB,N)\n*          On entry, the upper triangular matrix B, in generalized\n*          Schur canonical form.\n*          On exit, B is overwritten by the reordered matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  ALPHA   (output) COMPLEX*16 array, dimension (N)\n*  BETA    (output) COMPLEX*16 array, dimension (N)\n*          The diagonal elements of A and B, respectively,\n*          when the pair (A,B) has been reduced to generalized Schur\n*          form.  ALPHA(i)/BETA(i) i=1,...,N are the generalized\n*          eigenvalues.\n*\n*  Q       (input/output) COMPLEX*16 array, dimension (LDQ,N)\n*          On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.\n*          On exit, Q has been postmultiplied by the left unitary\n*          transformation matrix which reorder (A, B); The leading M\n*          columns of Q form orthonormal bases for the specified pair of\n*          left eigenspaces (deflating subspaces).\n*          If WANTQ = .FALSE., Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q. LDQ >= 1.\n*          If WANTQ = .TRUE., LDQ >= N.\n*\n*  Z       (input/output) COMPLEX*16 array, dimension (LDZ,N)\n*          On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.\n*          On exit, Z has been postmultiplied by the left unitary\n*          transformation matrix which reorder (A, B); The leading M\n*          columns of Z form orthonormal bases for the specified pair of\n*          left eigenspaces (deflating subspaces).\n*          If WANTZ = .FALSE., Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z. LDZ >= 1.\n*          If WANTZ = .TRUE., LDZ >= N.\n*\n*  M       (output) INTEGER\n*          The dimension of the specified pair of left and right\n*          eigenspaces, (deflating subspaces) 0 <= M <= N.\n*\n*  PL      (output) DOUBLE PRECISION\n*  PR      (output) DOUBLE PRECISION\n*          If IJOB = 1, 4 or 5, PL, PR are lower bounds on the\n*          reciprocal  of the norm of \"projections\" onto left and right\n*          eigenspace with respect to the selected cluster.\n*          0 < PL, PR <= 1.\n*          If M = 0 or M = N, PL = PR  = 1.\n*          If IJOB = 0, 2 or 3 PL, PR are not referenced.\n*\n*  DIF     (output) DOUBLE PRECISION array, dimension (2).\n*          If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.\n*          If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on\n*          Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based\n*          estimates of Difu and Difl, computed using reversed\n*          communication with ZLACN2.\n*          If M = 0 or N, DIF(1:2) = F-norm([A, B]).\n*          If IJOB = 0 or 1, DIF is not referenced.\n*\n*  WORK    (workspace/output) COMPLEX*16 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 >=  1\n*          If IJOB = 1, 2 or 4, LWORK >=  2*M*(N-M)\n*          If IJOB = 3 or 5, LWORK >=  4*M*(N-M)\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*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK. LIWORK >= 1.\n*          If IJOB = 1, 2 or 4, LIWORK >=  N+2;\n*          If IJOB = 3 or 5, LIWORK >= MAX(N+2, 2*M*(N-M));\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal size of the IWORK array,\n*          returns this value as the first entry of the IWORK array, and\n*          no error message related to LIWORK 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*            =1: Reordering of (A, B) failed because the transformed\n*                matrix pair (A, B) would be too far from generalized\n*                Schur form; the problem is very ill-conditioned.\n*                (A, B) may have been partially reordered.\n*                If requested, 0 is returned in DIF(*), PL and PR.\n*\n*\n\n*  Further Details\n*  ===============\n*\n*  ZTGSEN first collects the selected eigenvalues by computing unitary\n*  U and W that move them to the top left corner of (A, B). In other\n*  words, the selected eigenvalues are the eigenvalues of (A11, B11) in\n*\n*                U'*(A, B)*W = (A11 A12) (B11 B12) n1\n*                              ( 0  A22),( 0  B22) n2\n*                                n1  n2    n1  n2\n*\n*  where N = n1+n2 and U' means the conjugate transpose of U. The first\n*  n1 columns of U and W span the specified pair of left and right\n*  eigenspaces (deflating subspaces) of (A, B).\n*\n*  If (A, B) has been obtained from the generalized real Schur\n*  decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the\n*  reordered generalized Schur form of (C, D) is given by\n*\n*           (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',\n*\n*  and the first n1 columns of Q*U and Z*W span the corresponding\n*  deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).\n*\n*  Note that if the selected eigenvalue is sufficiently ill-conditioned,\n*  then its value may differ significantly from its value before\n*  reordering.\n*\n*  The reciprocal condition numbers of the left and right eigenspaces\n*  spanned by the first n1 columns of U and W (or Q*U and Z*W) may\n*  be returned in DIF(1:2), corresponding to Difu and Difl, resp.\n*\n*  The Difu and Difl are defined as:\n*\n*       Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )\n*  and\n*       Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],\n*\n*  where sigma-min(Zu) is the smallest singular value of the\n*  (2*n1*n2)-by-(2*n1*n2) matrix\n*\n*       Zu = [ kron(In2, A11)  -kron(A22', In1) ]\n*            [ kron(In2, B11)  -kron(B22', In1) ].\n*\n*  Here, Inx is the identity matrix of size nx and A22' is the\n*  transpose of A22. kron(X, Y) is the Kronecker product between\n*  the matrices X and Y.\n*\n*  When DIF(2) is small, small changes in (A, B) can cause large changes\n*  in the deflating subspace. An approximate (asymptotic) bound on the\n*  maximum angular error in the computed deflating subspaces is\n*\n*       EPS * norm((A, B)) / DIF(2),\n*\n*  where EPS is the machine precision.\n*\n*  The reciprocal norm of the projectors on the left and right\n*  eigenspaces associated with (A11, B11) may be returned in PL and PR.\n*  They are computed as follows. First we compute L and R so that\n*  P*(A, B)*Q is block diagonal, where\n*\n*       P = ( I -L ) n1           Q = ( I R ) n1\n*           ( 0  I ) n2    and        ( 0 I ) n2\n*             n1 n2                    n1 n2\n*\n*  and (L, R) is the solution to the generalized Sylvester equation\n*\n*       A11*R - L*A22 = -A12\n*       B11*R - L*B22 = -B12\n*\n*  Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).\n*  An approximate (asymptotic) bound on the average absolute error of\n*  the selected eigenvalues is\n*\n*       EPS * norm((A, B)) / PL.\n*\n*  There are also global error bounds which valid for perturbations up\n*  to a certain restriction:  A lower bound (x) on the smallest\n*  F-norm(E,F) for which an eigenvalue of (A11, B11) may move and\n*  coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),\n*  (i.e. (A + E, B + F), is\n*\n*   x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).\n*\n*  An approximate bound on x can be computed from DIF(1:2), PL and PR.\n*\n*  If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed\n*  (L', R') and unperturbed (L, R) left and right deflating subspaces\n*  associated with the selected cluster in the (1,1)-blocks can be\n*  bounded as\n*\n*   max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))\n*   max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))\n*\n*  See LAPACK User's Guide section 4.11 or the following references\n*  for more information.\n*\n*  Note that if the default method for computing the Frobenius-norm-\n*  based estimate DIF is not wanted (see ZLATDF), then the parameter\n*  IDIFJB (see below) should be changed from 3 to 4 (routine ZLATDF\n*  (IJOB = 2 will be used)). See ZTGSYL for more details.\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  References\n*  ==========\n*\n*  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n*      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n*      M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n*      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n*  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n*      Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n*      Estimation: Theory, Algorithms and Software, Report\n*      UMINF - 94.04, Department of Computing Science, Umea University,\n*      S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.\n*      To appear in Numerical Algorithms, 1996.\n*\n*  [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n*      for Solving the Generalized Sylvester Equation and Estimating the\n*      Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n*      Department of Computing Science, Umea University, S-901 87 Umea,\n*      Sweden, December 1993, Revised April 1994, Also as LAPACK working\n*      Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,\n*      1996.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  alpha, beta, m, pl, pr, dif, work, iwork, info, a, b, q, z = NumRu::Lapack.ztgsen( ijob, wantq, wantz, select, a, b, q, z, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_ijob = argv[0];
  rblapack_wantq = argv[1];
  rblapack_wantz = argv[2];
  rblapack_select = argv[3];
  rblapack_a = argv[4];
  rblapack_b = argv[5];
  rblapack_q = argv[6];
  rblapack_z = argv[7];
  if (argc == 10) {
    rblapack_lwork = argv[8];
    rblapack_liwork = argv[9];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  ijob = NUM2INT(rblapack_ijob);
  wantz = (rblapack_wantz == Qtrue);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (7th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_q) != NA_DCOMPLEX)
    rblapack_q = na_change_type(rblapack_q, NA_DCOMPLEX);
  q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
  wantq = (rblapack_wantq == Qtrue);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  if (!NA_IsNArray(rblapack_select))
    rb_raise(rb_eArgError, "select (4th argument) must be NArray");
  if (NA_RANK(rblapack_select) != 1)
    rb_raise(rb_eArgError, "rank of select (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_select) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_select) != NA_LINT)
    rblapack_select = na_change_type(rblapack_select, NA_LINT);
  select = NA_PTR_TYPE(rblapack_select, logical*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (8th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  if (NA_SHAPE1(rblapack_z) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_z) != NA_DCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  if (rblapack_liwork == Qnil)
    liwork = (ijob==1||ijob==2||ijob==4) ? n+2 : (ijob==3||ijob==5) ? 2*m*(n-m) : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  if (rblapack_lwork == Qnil)
    lwork = (ijob==1||ijob==2||ijob==4) ? 2*m*(n-m) : (ijob==3||ijob==5) ? 4*m*(n-m) : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  alpha = NA_PTR_TYPE(rblapack_alpha, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = 2;
    rblapack_dif = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  dif = NA_PTR_TYPE(rblapack_dif, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublecomplex*);
  MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublecomplex*);
  MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  ztgsen_(&ijob, &wantq, &wantz, select, &n, a, &lda, b, &ldb, alpha, beta, q, &ldq, z, &ldz, &m, &pl, &pr, dif, work, &lwork, iwork, &liwork, &info);

  rblapack_m = INT2NUM(m);
  rblapack_pl = rb_float_new((double)pl);
  rblapack_pr = rb_float_new((double)pr);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(13, rblapack_alpha, rblapack_beta, rblapack_m, rblapack_pl, rblapack_pr, rblapack_dif, rblapack_work, rblapack_iwork, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z);
}

void
init_lapack_ztgsen(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztgsen", rblapack_ztgsen, -1);
}
ruby-lapack-1.7.2/ext/zunmbr.c0000644000175000017500000002243312502221025016043 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zunmbr_(char* vect, char* side, char* trans, integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zunmbr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_vect;
  char vect; 
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_c;
  doublecomplex *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublecomplex *c_out__;

  integer lda;
  integer ldc;
  integer n;
  integer nq;

  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, c = NumRu::Lapack.zunmbr( vect, side, trans, m, k, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  If VECT = 'Q', ZUNMBR overwrites the general complex M-by-N matrix C\n*  with\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'C':      Q**H * C       C * Q**H\n*\n*  If VECT = 'P', ZUNMBR overwrites the general complex M-by-N matrix C\n*  with\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      P * C          C * P\n*  TRANS = 'C':      P**H * C       C * P**H\n*\n*  Here Q and P**H are the unitary matrices determined by ZGEBRD when\n*  reducing a complex matrix A to bidiagonal form: A = Q * B * P**H. Q\n*  and P**H are defined as products of elementary reflectors H(i) and\n*  G(i) respectively.\n*\n*  Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the\n*  order of the unitary matrix Q or P**H that is applied.\n*\n*  If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:\n*  if nq >= k, Q = H(1) H(2) . . . H(k);\n*  if nq < k, Q = H(1) H(2) . . . H(nq-1).\n*\n*  If VECT = 'P', A is assumed to have been a K-by-NQ matrix:\n*  if k < nq, P = G(1) G(2) . . . G(k);\n*  if k >= nq, P = G(1) G(2) . . . G(nq-1).\n*\n\n*  Arguments\n*  =========\n*\n*  VECT    (input) CHARACTER*1\n*          = 'Q': apply Q or Q**H;\n*          = 'P': apply P or P**H.\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q, Q**H, P or P**H from the Left;\n*          = 'R': apply Q, Q**H, P or P**H from the Right.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q or P;\n*          = 'C':  Conjugate transpose, apply Q**H or P**H.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          If VECT = 'Q', the number of columns in the original\n*          matrix reduced by ZGEBRD.\n*          If VECT = 'P', the number of rows in the original\n*          matrix reduced by ZGEBRD.\n*          K >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension\n*                                (LDA,min(nq,K)) if VECT = 'Q'\n*                                (LDA,nq)        if VECT = 'P'\n*          The vectors which define the elementary reflectors H(i) and\n*          G(i), whose products determine the matrices Q and P, as\n*          returned by ZGEBRD.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*          If VECT = 'Q', LDA >= max(1,nq);\n*          if VECT = 'P', LDA >= max(1,min(nq,K)).\n*\n*  TAU     (input) COMPLEX*16 array, dimension (min(nq,K))\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i) or G(i) which determines Q or P, as returned\n*          by ZGEBRD in the array argument TAUQ or TAUP.\n*\n*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q\n*          or P*C or P**H*C or C*P or C*P**H.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace/output) COMPLEX*16 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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M);\n*          if N = 0 or M = 0, LWORK >= 1.\n*          For optimum performance LWORK >= max(1,N*NB) if SIDE = 'L',\n*          and LWORK >= max(1,M*NB) if SIDE = 'R', where NB is the\n*          optimal blocksize. (NB = 0 if M = 0 or N = 0.)\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*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            APPLYQ, LEFT, LQUERY, NOTRAN\n      CHARACTER          TRANST\n      INTEGER            I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            ILAENV\n      EXTERNAL           LSAME, ILAENV\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZUNMLQ, ZUNMQR\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.zunmbr( vect, side, trans, m, k, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_vect = argv[0];
  rblapack_side = argv[1];
  rblapack_trans = argv[2];
  rblapack_m = argv[3];
  rblapack_k = argv[4];
  rblapack_a = argv[5];
  rblapack_tau = argv[6];
  rblapack_c = argv[7];
  if (argc == 9) {
    rblapack_lwork = argv[8];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  vect = StringValueCStr(rblapack_vect)[0];
  trans = StringValueCStr(rblapack_trans)[0];
  k = NUM2INT(rblapack_k);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (8th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
  side = StringValueCStr(rblapack_side)[0];
  m = NUM2INT(rblapack_m);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  nq = lsame_(&side,"L") ? m : lsame_(&side,"R") ? n : 0;
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (6th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (6th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != (MIN(nq,k)))
    rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", MIN(nq,k));
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (7th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_tau) != (MIN(nq,k)))
    rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", MIN(nq,k));
  if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
  MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  zunmbr_(&vect, &side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_zunmbr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zunmbr", rblapack_zunmbr, -1);
}
ruby-lapack-1.7.2/ext/zla_gercond_c.c0000644000175000017500000001730012502221023017312 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal zla_gercond_c_(char* trans, integer* n, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublereal* c, logical* capply, integer* info, doublecomplex* work, doublereal* rwork);


static VALUE
rblapack_zla_gercond_c(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_capply;
  logical capply; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_rwork;
  doublereal *rwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack___out__;
  doublereal __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  info, __out__ = NumRu::Lapack.zla_gercond_c( trans, a, af, ipiv, c, capply, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION ZLA_GERCOND_C( TRANS, N, A, LDA, AF,  LDAF, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n*  Purpose\n*  =======\n*\n*     ZLA_GERCOND_C computes the infinity norm condition number of\n*     op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector.\n*\n\n*  Arguments\n*  =========\n*\n*     TRANS   (input) CHARACTER*1\n*     Specifies the form of the system of equations:\n*       = 'N':  A * X = B     (No transpose)\n*       = 'T':  A**T * X = B  (Transpose)\n*       = 'C':  A**H * X = B  (Conjugate Transpose = Transpose)\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     A       (input) COMPLEX*16 array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX*16 array, dimension (LDAF,N)\n*     The factors L and U from the factorization\n*     A = P*L*U as computed by ZGETRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     The pivot indices from the factorization A = P*L*U\n*     as computed by ZGETRF; row i of the matrix was interchanged\n*     with row IPIV(i).\n*\n*     C       (input) DOUBLE PRECISION array, dimension (N)\n*     The vector C in the formula op(A) * inv(diag(C)).\n*\n*     CAPPLY  (input) LOGICAL\n*     If .TRUE. then access the vector C in the formula above.\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit.\n*     i > 0:  The ith argument is invalid.\n*\n*     WORK    (input) COMPLEX*16 array, dimension (2*N).\n*     Workspace.\n*\n*     RWORK   (input) DOUBLE PRECISION array, dimension (N).\n*     Workspace.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            NOTRANS\n      INTEGER            KASE, I, J\n      DOUBLE PRECISION   AINVNM, ANORM, TMP\n      COMPLEX*16         ZDUM\n*     ..\n*     .. Local Arrays ..\n      INTEGER            ISAVE( 3 )\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           ZLACN2, ZGETRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX, REAL, DIMAG\n*     ..\n*     .. Statement Functions ..\n      DOUBLE PRECISION   CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, __out__ = NumRu::Lapack.zla_gercond_c( trans, a, af, ipiv, c, capply, work, rwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_trans = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_c = argv[4];
  rblapack_capply = argv[5];
  rblapack_work = argv[6];
  rblapack_rwork = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_rwork))
    rb_raise(rb_eArgError, "rwork (8th argument) must be NArray");
  if (NA_RANK(rblapack_rwork) != 1)
    rb_raise(rb_eArgError, "rank of rwork (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_rwork) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_rwork) != NA_DFLOAT)
    rblapack_rwork = na_change_type(rblapack_rwork, NA_DFLOAT);
  rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  capply = (rblapack_capply == Qtrue);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (7th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
  if (NA_TYPE(rblapack_work) != NA_DCOMPLEX)
    rblapack_work = na_change_type(rblapack_work, NA_DCOMPLEX);
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);

  __out__ = zla_gercond_c_(&trans, &n, a, &lda, af, &ldaf, ipiv, c, &capply, &info, work, rwork);

  rblapack_info = INT2NUM(info);
  rblapack___out__ = rb_float_new((double)__out__);
  return rb_ary_new3(2, rblapack_info, rblapack___out__);
}

void
init_lapack_zla_gercond_c(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zla_gercond_c", rblapack_zla_gercond_c, -1);
}
ruby-lapack-1.7.2/ext/zsptri.c0000644000175000017500000001120712502221012016052 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zsptri_(char* uplo, integer* n, doublecomplex* ap, integer* ipiv, doublecomplex* work, integer* info);


static VALUE
rblapack_zsptri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublecomplex *ap_out__;
  doublecomplex *work;

  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  info, ap = NumRu::Lapack.zsptri( uplo, ap, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSPTRI( UPLO, N, AP, IPIV, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZSPTRI computes the inverse of a complex symmetric indefinite matrix\n*  A in packed storage using the factorization A = U*D*U**T or\n*  A = L*D*L**T computed by ZSPTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          On entry, the block diagonal matrix D and the multipliers\n*          used to obtain the factor U or L as computed by ZSPTRF,\n*          stored as a packed triangular matrix.\n*\n*          On exit, if INFO = 0, the (symmetric) inverse of the original\n*          matrix, stored as a packed triangular matrix. The j-th column\n*          of inv(A) is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;\n*          if UPLO = 'L',\n*             AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by ZSPTRF.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (N)\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, D(i,i) = 0; the matrix is singular and its\n*               inverse could not be computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ap = NumRu::Lapack.zsptri( uplo, ap, ipiv, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_ipiv = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
  MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  work = ALLOC_N(doublecomplex, (n));

  zsptri_(&uplo, &n, ap, ipiv, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ap);
}

void
init_lapack_zsptri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zsptri", rblapack_zsptri, -1);
}
ruby-lapack-1.7.2/ext/zla_porfsx_extended.c0000644000175000017500000005575512502221020020605 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zla_porfsx_extended_(integer* prec_type, char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, logical* colequ, doublereal* c, doublecomplex* b, integer* ldb, doublecomplex* y, integer* ldy, doublereal* berr_out, integer* n_norms, doublereal* err_bnds_norm, doublereal* err_bnds_comp, doublecomplex* res, doublereal* ayb, doublecomplex* dy, doublecomplex* y_tail, doublereal* rcond, integer* ithresh, doublereal* rthresh, doublereal* dz_ub, logical* ignore_cwise, integer* info);


static VALUE
rblapack_zla_porfsx_extended(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_prec_type;
  integer prec_type; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_colequ;
  logical colequ; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_y;
  doublecomplex *y; 
  VALUE rblapack_n_norms;
  integer n_norms; 
  VALUE rblapack_err_bnds_norm;
  doublereal *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  doublereal *err_bnds_comp; 
  VALUE rblapack_res;
  doublecomplex *res; 
  VALUE rblapack_ayb;
  doublereal *ayb; 
  VALUE rblapack_dy;
  doublecomplex *dy; 
  VALUE rblapack_y_tail;
  doublecomplex *y_tail; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_ithresh;
  integer ithresh; 
  VALUE rblapack_rthresh;
  doublereal rthresh; 
  VALUE rblapack_dz_ub;
  doublereal dz_ub; 
  VALUE rblapack_ignore_cwise;
  logical ignore_cwise; 
  VALUE rblapack_berr_out;
  doublereal *berr_out; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_y_out__;
  doublecomplex *y_out__;
  VALUE rblapack_err_bnds_norm_out__;
  doublereal *err_bnds_norm_out__;
  VALUE rblapack_err_bnds_comp_out__;
  doublereal *err_bnds_comp_out__;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldy;
  integer n_err_bnds;

  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  berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.zla_porfsx_extended( prec_type, uplo, a, af, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZLA_PORFSX_EXTENDED improves the computed solution to a system of\n*  linear equations by performing extra-precise iterative refinement\n*  and provides error bounds and backward error estimates for the solution.\n*  This subroutine is called by ZPORFSX to perform iterative refinement.\n*  In addition to normwise error bound, the code provides maximum\n*  componentwise error bound if possible. See comments for ERR_BNDS_NORM\n*  and ERR_BNDS_COMP for details of the error bounds. Note that this\n*  subroutine is only resonsible for setting the second fields of\n*  ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n*  Arguments\n*  =========\n*\n*     PREC_TYPE      (input) INTEGER\n*     Specifies the intermediate precision to be used in refinement.\n*     The value is defined by ILAPREC(P) where P is a CHARACTER and\n*     P    = 'S':  Single\n*          = 'D':  Double\n*          = 'I':  Indigenous\n*          = 'X', 'E':  Extra\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N              (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NRHS           (input) INTEGER\n*     The number of right-hand-sides, i.e., the number of columns of the\n*     matrix B.\n*\n*     A              (input) COMPLEX*16 array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA            (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF             (input) COMPLEX*16 array, dimension (LDAF,N)\n*     The triangular factor U or L from the Cholesky factorization\n*     A = U**T*U or A = L*L**T, as computed by ZPOTRF.\n*\n*     LDAF           (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     COLEQU         (input) LOGICAL\n*     If .TRUE. then column equilibration was done to A before calling\n*     this routine. This is needed to compute the solution and error\n*     bounds correctly.\n*\n*     C              (input) DOUBLE PRECISION array, dimension (N)\n*     The column scale factors for A. If COLEQU = .FALSE., C\n*     is not accessed. If C is input, each element of C should be a power\n*     of the radix to ensure a reliable solution and error estimates.\n*     Scaling by powers of the radix does not cause rounding errors unless\n*     the result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B              (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*     The right-hand-side matrix B.\n*\n*     LDB            (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     Y              (input/output) COMPLEX*16 array, dimension\n*                    (LDY,NRHS)\n*     On entry, the solution matrix X, as computed by ZPOTRS.\n*     On exit, the improved solution matrix Y.\n*\n*     LDY            (input) INTEGER\n*     The leading dimension of the array Y.  LDY >= max(1,N).\n*\n*     BERR_OUT       (output) DOUBLE PRECISION array, dimension (NRHS)\n*     On exit, BERR_OUT(j) contains the componentwise relative backward\n*     error for right-hand-side j from the formula\n*         max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n*     where abs(Z) is the componentwise absolute value of the matrix\n*     or vector Z. This is computed by ZLA_LIN_BERR.\n*\n*     N_NORMS        (input) INTEGER\n*     Determines which error bounds to return (see ERR_BNDS_NORM\n*     and ERR_BNDS_COMP).\n*     If N_NORMS >= 1 return normwise error bounds.\n*     If N_NORMS >= 2 return componentwise error bounds.\n*\n*     ERR_BNDS_NORM  (input/output) DOUBLE PRECISION array, dimension\n*                    (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (input/output) DOUBLE PRECISION array, dimension\n*                    (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     RES            (input) COMPLEX*16 array, dimension (N)\n*     Workspace to hold the intermediate residual.\n*\n*     AYB            (input) DOUBLE PRECISION array, dimension (N)\n*     Workspace.\n*\n*     DY             (input) COMPLEX*16 PRECISION array, dimension (N)\n*     Workspace to hold the intermediate solution.\n*\n*     Y_TAIL         (input) COMPLEX*16 array, dimension (N)\n*     Workspace to hold the trailing bits of the intermediate solution.\n*\n*     RCOND          (input) DOUBLE PRECISION\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     ITHRESH        (input) INTEGER\n*     The maximum number of residual computations allowed for\n*     refinement. The default is 10. For 'aggressive' set to 100 to\n*     permit convergence using approximate factorizations or\n*     factorizations other than LU. If the factorization uses a\n*     technique other than Gaussian elimination, the guarantees in\n*     ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n*     RTHRESH        (input) DOUBLE PRECISION\n*     Determines when to stop refinement if the error estimate stops\n*     decreasing. Refinement will stop when the next solution no longer\n*     satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n*     the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n*     default value is 0.5. For 'aggressive' set to 0.9 to permit\n*     convergence on extremely ill-conditioned matrices. See LAWN 165\n*     for more details.\n*\n*     DZ_UB          (input) DOUBLE PRECISION\n*     Determines when to start considering componentwise convergence.\n*     Componentwise convergence is only considered after each component\n*     of the solution Y is stable, which we definte as the relative\n*     change in each component being less than DZ_UB. The default value\n*     is 0.25, requiring the first bit to be stable. See LAWN 165 for\n*     more details.\n*\n*     IGNORE_CWISE   (input) LOGICAL\n*     If .TRUE. then ignore componentwise convergence. Default value\n*     is .FALSE..\n*\n*     INFO           (output) INTEGER\n*       = 0:  Successful exit.\n*       < 0:  if INFO = -i, the ith argument to ZPOTRS had an illegal\n*             value\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            UPLO2, CNT, I, J, X_STATE, Z_STATE,\n     $                   Y_PREC_STATE\n      DOUBLE PRECISION   YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n     $                   DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n     $                   DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n     $                   EPS, HUGEVAL, INCR_THRESH\n      LOGICAL            INCR_PREC\n      COMPLEX*16         ZDUM\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.zla_porfsx_extended( prec_type, uplo, a, af, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 20 && argc != 20)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 20)", argc);
  rblapack_prec_type = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_colequ = argv[4];
  rblapack_c = argv[5];
  rblapack_b = argv[6];
  rblapack_y = argv[7];
  rblapack_n_norms = argv[8];
  rblapack_err_bnds_norm = argv[9];
  rblapack_err_bnds_comp = argv[10];
  rblapack_res = argv[11];
  rblapack_ayb = argv[12];
  rblapack_dy = argv[13];
  rblapack_y_tail = argv[14];
  rblapack_rcond = argv[15];
  rblapack_ithresh = argv[16];
  rblapack_rthresh = argv[17];
  rblapack_dz_ub = argv[18];
  rblapack_ignore_cwise = argv[19];
  if (argc == 20) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  prec_type = NUM2INT(rblapack_prec_type);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  colequ = (rblapack_colequ == Qtrue);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  n_norms = NUM2INT(rblapack_n_norms);
  if (!NA_IsNArray(rblapack_err_bnds_comp))
    rb_raise(rb_eArgError, "err_bnds_comp (11th argument) must be NArray");
  if (NA_RANK(rblapack_err_bnds_comp) != 2)
    rb_raise(rb_eArgError, "rank of err_bnds_comp (11th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_err_bnds_comp) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of b");
  n_err_bnds = NA_SHAPE1(rblapack_err_bnds_comp);
  if (NA_TYPE(rblapack_err_bnds_comp) != NA_DFLOAT)
    rblapack_err_bnds_comp = na_change_type(rblapack_err_bnds_comp, NA_DFLOAT);
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
  if (!NA_IsNArray(rblapack_ayb))
    rb_raise(rb_eArgError, "ayb (13th argument) must be NArray");
  if (NA_RANK(rblapack_ayb) != 1)
    rb_raise(rb_eArgError, "rank of ayb (13th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ayb) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ayb) != NA_DFLOAT)
    rblapack_ayb = na_change_type(rblapack_ayb, NA_DFLOAT);
  ayb = NA_PTR_TYPE(rblapack_ayb, doublereal*);
  if (!NA_IsNArray(rblapack_y_tail))
    rb_raise(rb_eArgError, "y_tail (15th argument) must be NArray");
  if (NA_RANK(rblapack_y_tail) != 1)
    rb_raise(rb_eArgError, "rank of y_tail (15th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y_tail) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_y_tail) != NA_DCOMPLEX)
    rblapack_y_tail = na_change_type(rblapack_y_tail, NA_DCOMPLEX);
  y_tail = NA_PTR_TYPE(rblapack_y_tail, doublecomplex*);
  ithresh = NUM2INT(rblapack_ithresh);
  dz_ub = NUM2DBL(rblapack_dz_ub);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_err_bnds_norm))
    rb_raise(rb_eArgError, "err_bnds_norm (10th argument) must be NArray");
  if (NA_RANK(rblapack_err_bnds_norm) != 2)
    rb_raise(rb_eArgError, "rank of err_bnds_norm (10th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_err_bnds_norm) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of b");
  if (NA_SHAPE1(rblapack_err_bnds_norm) != n_err_bnds)
    rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_norm must be the same as shape 1 of err_bnds_comp");
  if (NA_TYPE(rblapack_err_bnds_norm) != NA_DFLOAT)
    rblapack_err_bnds_norm = na_change_type(rblapack_err_bnds_norm, NA_DFLOAT);
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
  if (!NA_IsNArray(rblapack_dy))
    rb_raise(rb_eArgError, "dy (14th argument) must be NArray");
  if (NA_RANK(rblapack_dy) != 1)
    rb_raise(rb_eArgError, "rank of dy (14th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dy) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_dy) != NA_DCOMPLEX)
    rblapack_dy = na_change_type(rblapack_dy, NA_DCOMPLEX);
  dy = NA_PTR_TYPE(rblapack_dy, doublecomplex*);
  rthresh = NUM2DBL(rblapack_rthresh);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  if (!NA_IsNArray(rblapack_res))
    rb_raise(rb_eArgError, "res (12th argument) must be NArray");
  if (NA_RANK(rblapack_res) != 1)
    rb_raise(rb_eArgError, "rank of res (12th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_res) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_res) != NA_DCOMPLEX)
    rblapack_res = na_change_type(rblapack_res, NA_DCOMPLEX);
  res = NA_PTR_TYPE(rblapack_res, doublecomplex*);
  ignore_cwise = (rblapack_ignore_cwise == Qtrue);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (8th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 2)
    rb_raise(rb_eArgError, "rank of y (8th argument) must be %d", 2);
  ldy = NA_SHAPE0(rblapack_y);
  if (NA_SHAPE1(rblapack_y) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_y) != NA_DCOMPLEX)
    rblapack_y = na_change_type(rblapack_y, NA_DCOMPLEX);
  y = NA_PTR_TYPE(rblapack_y, doublecomplex*);
  rcond = NUM2DBL(rblapack_rcond);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr_out = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr_out = NA_PTR_TYPE(rblapack_berr_out, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldy;
    shape[1] = nrhs;
    rblapack_y_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublecomplex*);
  MEMCPY(y_out__, y, doublecomplex, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm_out__ = NA_PTR_TYPE(rblapack_err_bnds_norm_out__, doublereal*);
  MEMCPY(err_bnds_norm_out__, err_bnds_norm, doublereal, NA_TOTAL(rblapack_err_bnds_norm));
  rblapack_err_bnds_norm = rblapack_err_bnds_norm_out__;
  err_bnds_norm = err_bnds_norm_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp_out__ = NA_PTR_TYPE(rblapack_err_bnds_comp_out__, doublereal*);
  MEMCPY(err_bnds_comp_out__, err_bnds_comp, doublereal, NA_TOTAL(rblapack_err_bnds_comp));
  rblapack_err_bnds_comp = rblapack_err_bnds_comp_out__;
  err_bnds_comp = err_bnds_comp_out__;

  zla_porfsx_extended_(&prec_type, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_err_bnds_norm, rblapack_err_bnds_comp);
}

void
init_lapack_zla_porfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zla_porfsx_extended", rblapack_zla_porfsx_extended, -1);
}
ruby-lapack-1.7.2/ext/dsyrfs.c0000644000175000017500000002163412502221022016037 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsyrfs_(char* uplo, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* af, integer* ldaf, integer* ipiv, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dsyrfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_af;
  doublereal *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  doublereal *x_out__;
  doublereal *work;
  integer *iwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.dsyrfs( uplo, a, af, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSYRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is symmetric indefinite, and\n*  provides error bounds and backward error estimates for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*          The symmetric matrix A.  If UPLO = 'U', the leading N-by-N\n*          upper triangular part of A contains the upper triangular part\n*          of the matrix A, and the strictly lower triangular part of A\n*          is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*          triangular part of A contains the lower triangular part of\n*          the matrix A, and the strictly upper triangular part of A is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AF      (input) DOUBLE PRECISION array, dimension (LDAF,N)\n*          The factored form of the matrix A.  AF contains the block\n*          diagonal matrix D and the multipliers used to obtain the\n*          factor U or L from the factorization A = U*D*U**T or\n*          A = L*D*L**T as computed by DSYTRF.\n*\n*  LDAF    (input) INTEGER\n*          The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by DSYTRF.\n*\n*  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by DSYTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.dsyrfs( uplo, a, af, ipiv, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_b = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_DFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
  af = NA_PTR_TYPE(rblapack_af, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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 (!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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(doublereal, (3*n));
  iwork = ALLOC_N(integer, (n));

  dsyrfs_(&uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_dsyrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsyrfs", rblapack_dsyrfs, -1);
}
ruby-lapack-1.7.2/ext/dgbtrs.c0000644000175000017500000001322512502221021016006 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgbtrs_(char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, doublereal* ab, integer* ldab, integer* ipiv, doublereal* b, integer* ldb, integer* info);


static VALUE
rblapack_dgbtrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublereal *b_out__;

  integer ldab;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.dgbtrs( trans, kl, ku, ab, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGBTRS solves a system of linear equations\n*     A * X = B  or  A' * X = B\n*  with a general band matrix A using the LU factorization computed\n*  by DGBTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations.\n*          = 'N':  A * X = B  (No transpose)\n*          = 'T':  A'* X = B  (Transpose)\n*          = 'C':  A'* X = B  (Conjugate transpose = Transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)\n*          Details of the LU factorization of the band matrix A, as\n*          computed by DGBTRF.  U is stored as an upper triangular band\n*          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n*          the multipliers used during the factorization are stored in\n*          rows KL+KU+2 to 2*KL+KU+1.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices; for 1 <= i <= N, row i of the matrix was\n*          interchanged with row IPIV(i).\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.dgbtrs( trans, kl, ku, ab, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_trans = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_b = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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 (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dgbtrs_(&trans, &n, &kl, &ku, &nrhs, ab, &ldab, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_dgbtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgbtrs", rblapack_dgbtrs, -1);
}
ruby-lapack-1.7.2/ext/zlarzb.c0000644000175000017500000001563412502221026016040 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlarzb_(char* side, char* trans, char* direct, char* storev, integer* m, integer* n, integer* k, integer* l, doublecomplex* v, integer* ldv, doublecomplex* t, integer* ldt, doublecomplex* c, integer* ldc, doublecomplex* work, integer* ldwork);


static VALUE
rblapack_zlarzb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_direct;
  char direct; 
  VALUE rblapack_storev;
  char storev; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_v;
  doublecomplex *v; 
  VALUE rblapack_t;
  doublecomplex *t; 
  VALUE rblapack_c;
  doublecomplex *c; 
  VALUE rblapack_c_out__;
  doublecomplex *c_out__;
  doublecomplex *work;

  integer ldv;
  integer nv;
  integer ldt;
  integer k;
  integer ldc;
  integer n;
  integer ldwork;

  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  c = NumRu::Lapack.zlarzb( side, trans, direct, storev, m, l, v, t, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n*  Purpose\n*  =======\n*\n*  ZLARZB applies a complex block reflector H or its transpose H**H\n*  to a complex distributed M-by-N  C from the left or the right.\n*\n*  Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply H or H' from the Left\n*          = 'R': apply H or H' from the Right\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': apply H (No transpose)\n*          = 'C': apply H' (Conjugate transpose)\n*\n*  DIRECT  (input) CHARACTER*1\n*          Indicates how H is formed from a product of elementary\n*          reflectors\n*          = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n*          = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n*  STOREV  (input) CHARACTER*1\n*          Indicates how the vectors which define the elementary\n*          reflectors are stored:\n*          = 'C': Columnwise                        (not supported yet)\n*          = 'R': Rowwise\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C.\n*\n*  K       (input) INTEGER\n*          The order of the matrix T (= the number of elementary\n*          reflectors whose product defines the block reflector).\n*\n*  L       (input) INTEGER\n*          The number of columns of the matrix V containing the\n*          meaningful part of the Householder reflectors.\n*          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n*  V       (input) COMPLEX*16 array, dimension (LDV,NV).\n*          If STOREV = 'C', NV = K; if STOREV = 'R', NV = L.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V.\n*          If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K.\n*\n*  T       (input) COMPLEX*16 array, dimension (LDT,K)\n*          The triangular K-by-K matrix T in the representation of the\n*          block reflector.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= K.\n*\n*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by H*C or H'*C or C*H or C*H'.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (LDWORK,K)\n*\n*  LDWORK  (input) INTEGER\n*          The leading dimension of the array WORK.\n*          If SIDE = 'L', LDWORK >= max(1,N);\n*          if SIDE = 'R', LDWORK >= max(1,M).\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.zlarzb( side, trans, direct, storev, m, l, v, t, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_direct = argv[2];
  rblapack_storev = argv[3];
  rblapack_m = argv[4];
  rblapack_l = argv[5];
  rblapack_v = argv[6];
  rblapack_t = argv[7];
  rblapack_c = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  direct = StringValueCStr(rblapack_direct)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (7th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  nv = NA_SHAPE1(rblapack_v);
  if (NA_TYPE(rblapack_v) != NA_DCOMPLEX)
    rblapack_v = na_change_type(rblapack_v, NA_DCOMPLEX);
  v = NA_PTR_TYPE(rblapack_v, doublecomplex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (9th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
  trans = StringValueCStr(rblapack_trans)[0];
  l = NUM2INT(rblapack_l);
  ldwork = MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0;
  storev = StringValueCStr(rblapack_storev)[0];
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (8th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (8th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  k = NA_SHAPE1(rblapack_t);
  if (NA_TYPE(rblapack_t) != NA_DCOMPLEX)
    rblapack_t = na_change_type(rblapack_t, NA_DCOMPLEX);
  t = NA_PTR_TYPE(rblapack_t, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
  MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(doublecomplex, (ldwork)*(k));

  zlarzb_(&side, &trans, &direct, &storev, &m, &n, &k, &l, v, &ldv, t, &ldt, c, &ldc, work, &ldwork);

  free(work);
  return rblapack_c;
}

void
init_lapack_zlarzb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlarzb", rblapack_zlarzb, -1);
}
ruby-lapack-1.7.2/ext/ddisna.c0000644000175000017500000001065112502221015015766 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ddisna_(char* job, integer* m, integer* n, doublereal* d, doublereal* sep, integer* info);


static VALUE
rblapack_ddisna(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_sep;
  doublereal *sep; 
  VALUE rblapack_info;
  integer info; 

  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  sep, info = NumRu::Lapack.ddisna( job, n, d, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DDISNA( JOB, M, N, D, SEP, INFO )\n\n*  Purpose\n*  =======\n*\n*  DDISNA computes the reciprocal condition numbers for the eigenvectors\n*  of a real symmetric or complex Hermitian matrix or for the left or\n*  right singular vectors of a general m-by-n matrix. The reciprocal\n*  condition number is the 'gap' between the corresponding eigenvalue or\n*  singular value and the nearest other one.\n*\n*  The bound on the error, measured by angle in radians, in the I-th\n*  computed vector is given by\n*\n*         DLAMCH( 'E' ) * ( ANORM / SEP( I ) )\n*\n*  where ANORM = 2-norm(A) = max( abs( D(j) ) ).  SEP(I) is not allowed\n*  to be smaller than DLAMCH( 'E' )*ANORM in order to limit the size of\n*  the error bound.\n*\n*  DDISNA may also be used to compute error bounds for eigenvectors of\n*  the generalized symmetric definite eigenproblem.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies for which problem the reciprocal condition numbers\n*          should be computed:\n*          = 'E':  the eigenvectors of a symmetric/Hermitian matrix;\n*          = 'L':  the left singular vectors of a general matrix;\n*          = 'R':  the right singular vectors of a general matrix.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix. M >= 0.\n*\n*  N       (input) INTEGER\n*          If JOB = 'L' or 'R', the number of columns of the matrix,\n*          in which case N >= 0. Ignored if JOB = 'E'.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (M) if JOB = 'E'\n*                              dimension (min(M,N)) if JOB = 'L' or 'R'\n*          The eigenvalues (if JOB = 'E') or singular values (if JOB =\n*          'L' or 'R') of the matrix, in either increasing or decreasing\n*          order. If singular values, they must be non-negative.\n*\n*  SEP     (output) DOUBLE PRECISION array, dimension (M) if JOB = 'E'\n*                               dimension (min(M,N)) if JOB = 'L' or 'R'\n*          The reciprocal condition numbers of the vectors.\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sep, info = NumRu::Lapack.ddisna( job, n, d, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_job = argv[0];
  rblapack_n = argv[1];
  rblapack_d = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  job = StringValueCStr(rblapack_job)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  n = NUM2INT(rblapack_n);
  {
    na_shape_t shape[1];
    shape[0] = lsame_(&job,"E") ? m : ((lsame_(&job,"L")) || (lsame_(&job,"R"))) ? MIN(m,n) : 0;
    rblapack_sep = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  sep = NA_PTR_TYPE(rblapack_sep, doublereal*);

  ddisna_(&job, &m, &n, d, sep, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_sep, rblapack_info);
}

void
init_lapack_ddisna(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ddisna", rblapack_ddisna, -1);
}
ruby-lapack-1.7.2/ext/zgeqr2.c0000644000175000017500000001044512502221021015734 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgeqr2_(integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* info);


static VALUE
rblapack_zgeqr2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  doublecomplex *work;

  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, info, a = NumRu::Lapack.zgeqr2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGEQR2 computes a QR factorization of a complex m by n matrix A:\n*  A = Q * R.\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) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the m by n matrix A.\n*          On exit, the elements on and above the diagonal of the array\n*          contain the min(m,n) by n upper trapezoidal matrix R (R is\n*          upper triangular if m >= n); the elements below the diagonal,\n*          with the array TAU, represent the unitary 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) COMPLEX*16 array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (N)\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(1) H(2) . . . H(k), 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 complex scalar, and v is a complex vector with\n*  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\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.zgeqr2( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(doublecomplex, (n));

  zgeqr2_(&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_zgeqr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgeqr2", rblapack_zgeqr2, -1);
}
ruby-lapack-1.7.2/ext/slamrg.c0000644000175000017500000000725212502221020016010 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slamrg_(integer* n1, integer* n2, real* a, integer* strd1, integer* strd2, integer* index);


static VALUE
rblapack_slamrg(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n1;
  integer n1; 
  VALUE rblapack_n2;
  integer n2; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_strd1;
  integer strd1; 
  VALUE rblapack_strd2;
  integer strd2; 
  VALUE rblapack_index;
  integer *index; 


  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  index = NumRu::Lapack.slamrg( n1, n2, a, strd1, strd2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAMRG( N1, N2, A, STRD1, STRD2, INDEX )\n\n*  Purpose\n*  =======\n*\n*  SLAMRG will create a permutation list which will merge the elements\n*  of A (which is composed of two independently sorted sets) into a\n*  single set which is sorted in ascending order.\n*\n\n*  Arguments\n*  =========\n*\n*  N1     (input) INTEGER\n*  N2     (input) INTEGER\n*         These arguements contain the respective lengths of the two\n*         sorted lists to be merged.\n*\n*  A      (input) REAL array, dimension (N1+N2)\n*         The first N1 elements of A contain a list of numbers which\n*         are sorted in either ascending or descending order.  Likewise\n*         for the final N2 elements.\n*\n*  STRD1  (input) INTEGER\n*  STRD2  (input) INTEGER\n*         These are the strides to be taken through the array A.\n*         Allowable strides are 1 and -1.  They indicate whether a\n*         subset of A is sorted in ascending (STRDx = 1) or descending\n*         (STRDx = -1) order.\n*\n*  INDEX  (output) INTEGER array, dimension (N1+N2)\n*         On exit this array will contain a permutation such that\n*         if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be\n*         sorted in ascending order.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, IND1, IND2, N1SV, N2SV\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  index = NumRu::Lapack.slamrg( n1, n2, a, strd1, strd2, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_n1 = argv[0];
  rblapack_n2 = argv[1];
  rblapack_a = argv[2];
  rblapack_strd1 = argv[3];
  rblapack_strd2 = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n1 = NUM2INT(rblapack_n1);
  strd1 = NUM2INT(rblapack_strd1);
  n2 = NUM2INT(rblapack_n2);
  strd2 = NUM2INT(rblapack_strd2);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 1)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_a) != (n1+n2))
    rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n1+n2);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[1];
    shape[0] = n1+n2;
    rblapack_index = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  index = NA_PTR_TYPE(rblapack_index, integer*);

  slamrg_(&n1, &n2, a, &strd1, &strd2, index);

  return rblapack_index;
}

void
init_lapack_slamrg(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slamrg", rblapack_slamrg, -1);
}
ruby-lapack-1.7.2/ext/dspev.c0000644000175000017500000001257712502221013015654 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dspev_(char* jobz, char* uplo, integer* n, doublereal* ap, doublereal* w, doublereal* z, integer* ldz, doublereal* work, integer* info);


static VALUE
rblapack_dspev(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublereal *ap_out__;
  doublereal *work;

  integer ldap;
  integer n;
  integer ldz;

  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  w, z, info, ap = NumRu::Lapack.dspev( jobz, uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSPEV computes all the eigenvalues and, optionally, eigenvectors of a\n*  real symmetric matrix A in packed storage.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, AP is overwritten by values generated during the\n*          reduction to tridiagonal form.  If UPLO = 'U', the diagonal\n*          and first superdiagonal of the tridiagonal matrix T overwrite\n*          the corresponding elements of A, and if UPLO = 'L', the\n*          diagonal and first subdiagonal of T overwrite the\n*          corresponding elements of A.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n*          eigenvectors of the matrix A, with the i-th column of Z\n*          holding the eigenvector associated with W(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)\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 algorithm failed to converge; i\n*                off-diagonal elements of an intermediate tridiagonal\n*                form did not converge to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, info, ap = NumRu::Lapack.dspev( jobz, uplo, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_ap = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  uplo = StringValueCStr(rblapack_uplo)[0];
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
  MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  work = ALLOC_N(doublereal, (3*n));

  dspev_(&jobz, &uplo, &n, ap, w, z, &ldz, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_w, rblapack_z, rblapack_info, rblapack_ap);
}

void
init_lapack_dspev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dspev", rblapack_dspev, -1);
}
ruby-lapack-1.7.2/ext/cgglse.c0000644000175000017500000002225412502221013015770 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgglse_(integer* m, integer* n, integer* p, complex* a, integer* lda, complex* b, integer* ldb, complex* c, complex* d, complex* x, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_cgglse(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_c;
  complex *c; 
  VALUE rblapack_d;
  complex *d; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;
  VALUE rblapack_c_out__;
  complex *c_out__;
  VALUE rblapack_d_out__;
  complex *d_out__;

  integer lda;
  integer n;
  integer ldb;
  integer m;
  integer p;

  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  x, work, info, a, b, c, d = NumRu::Lapack.cgglse( a, b, c, d, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGGLSE solves the linear equality-constrained least squares (LSE)\n*  problem:\n*\n*          minimize || c - A*x ||_2   subject to   B*x = d\n*\n*  where A is an M-by-N matrix, B is a P-by-N matrix, c is a given\n*  M-vector, and d is a given P-vector. It is assumed that\n*  P <= N <= M+P, and\n*\n*           rank(B) = P and  rank( (A) ) = N.\n*                                ( (B) )\n*\n*  These conditions ensure that the LSE problem has a unique solution,\n*  which is obtained using a generalized RQ factorization of the\n*  matrices (B, A) given by\n*\n*     B = (0 R)*Q,   A = Z*T*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 matrices A and B. N >= 0.\n*\n*  P       (input) INTEGER\n*          The number of rows of the matrix B. 0 <= P <= N <= M+P.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, the elements on and above the diagonal of the array\n*          contain the min(M,N)-by-N upper trapezoidal matrix T.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,N)\n*          On entry, the P-by-N matrix B.\n*          On exit, the upper triangle of the subarray B(1:P,N-P+1:N)\n*          contains the P-by-P upper triangular matrix R.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,P).\n*\n*  C       (input/output) COMPLEX array, dimension (M)\n*          On entry, C contains the right hand side vector for the\n*          least squares part of the LSE problem.\n*          On exit, the residual sum of squares for the solution\n*          is given by the sum of squares of elements N-P+1 to M of\n*          vector C.\n*\n*  D       (input/output) COMPLEX array, dimension (P)\n*          On entry, D contains the right hand side vector for the\n*          constrained equation.\n*          On exit, D is destroyed.\n*\n*  X       (output) COMPLEX array, dimension (N)\n*          On exit, X is the solution of the LSE problem.\n*\n*  WORK    (workspace/output) COMPLEX 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+P).\n*          For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,\n*          where NB is an upper bound for the optimal blocksizes for\n*          CGEQRF, CGERQF, CUNMQR and CUNMRQ.\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*          = 1:  the upper triangular factor R associated with B in the\n*                generalized RQ factorization of the pair (B, A) is\n*                singular, so that rank(B) < P; the least squares\n*                solution could not be computed.\n*          = 2:  the (N-P) by (N-P) part of the upper trapezoidal factor\n*                T associated with A in the generalized RQ factorization\n*                of the pair (B, A) is singular, so that\n*                rank( (A) ) < N; the least squares solution could not\n*                    ( (B) )\n*                be computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, work, info, a, b, c, d = NumRu::Lapack.cgglse( a, b, c, d, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  rblapack_c = argv[2];
  rblapack_d = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } 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 (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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (3th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (3th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, complex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  p = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SCOMPLEX)
    rblapack_d = na_change_type(rblapack_d, NA_SCOMPLEX);
  d = NA_PTR_TYPE(rblapack_d, complex*);
  if (rblapack_lwork == Qnil)
    lwork = m+n+p;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_x = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
  MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[1];
    shape[0] = p;
    rblapack_d_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, complex*);
  MEMCPY(d_out__, d, complex, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;

  cgglse_(&m, &n, &p, a, &lda, b, &ldb, c, d, x, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_x, rblapack_work, rblapack_info, rblapack_a, rblapack_b, rblapack_c, rblapack_d);
}

void
init_lapack_cgglse(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgglse", rblapack_cgglse, -1);
}
ruby-lapack-1.7.2/ext/slasq3.c0000644000175000017500000001470312502221023015733 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slasq3_(integer* i0, integer* n0, real* z, integer* pp, real* dmin, real* sigma, real* desig, real* qmax, integer* nfail, integer* iter, integer* ndiv, logical* ieee, integer* ttype, real* dmin1, real* dmin2, real* dn, real* dn1, real* dn2, real* g, real* tau);


static VALUE
rblapack_slasq3(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_i0;
  integer i0; 
  VALUE rblapack_n0;
  integer n0; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_pp;
  integer pp; 
  VALUE rblapack_desig;
  real desig; 
  VALUE rblapack_qmax;
  real qmax; 
  VALUE rblapack_ieee;
  logical ieee; 
  VALUE rblapack_ttype;
  integer ttype; 
  VALUE rblapack_dmin1;
  real dmin1; 
  VALUE rblapack_dmin2;
  real dmin2; 
  VALUE rblapack_dn;
  real dn; 
  VALUE rblapack_dn1;
  real dn1; 
  VALUE rblapack_dn2;
  real dn2; 
  VALUE rblapack_g;
  real g; 
  VALUE rblapack_tau;
  real tau; 
  VALUE rblapack_dmin;
  real dmin; 
  VALUE rblapack_sigma;
  real sigma; 
  VALUE rblapack_nfail;
  integer nfail; 
  VALUE rblapack_iter;
  integer iter; 
  VALUE rblapack_ndiv;
  integer ndiv; 


  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  dmin, sigma, nfail, iter, ndiv, n0, pp, desig, ttype, dmin1, dmin2, dn, dn1, dn2, g, tau = NumRu::Lapack.slasq3( i0, n0, z, pp, desig, qmax, ieee, ttype, dmin1, dmin2, dn, dn1, dn2, g, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, DN2, G, TAU )\n\n*  Purpose\n*  =======\n*\n*  SLASQ3 checks for deflation, computes a shift (TAU) and calls dqds.\n*  In case of failure it changes shifts, and tries again until output\n*  is positive.\n*\n\n*  Arguments\n*  =========\n*\n*  I0     (input) INTEGER\n*         First index.\n*\n*  N0     (input/output) INTEGER\n*         Last index.\n*\n*  Z      (input) REAL array, dimension ( 4*N )\n*         Z holds the qd array.\n*\n*  PP     (input/output) INTEGER\n*         PP=0 for ping, PP=1 for pong.\n*         PP=2 indicates that flipping was applied to the Z array   \n*         and that the initial tests for deflation should not be \n*         performed.\n*\n*  DMIN   (output) REAL\n*         Minimum value of d.\n*\n*  SIGMA  (output) REAL\n*         Sum of shifts used in current segment.\n*\n*  DESIG  (input/output) REAL\n*         Lower order part of SIGMA\n*\n*  QMAX   (input) REAL\n*         Maximum value of q.\n*\n*  NFAIL  (output) INTEGER\n*         Number of times shift was too big.\n*\n*  ITER   (output) INTEGER\n*         Number of iterations.\n*\n*  NDIV   (output) INTEGER\n*         Number of divisions.\n*\n*  IEEE   (input) LOGICAL\n*         Flag for IEEE or non IEEE arithmetic (passed to SLASQ5).\n*\n*  TTYPE  (input/output) INTEGER\n*         Shift type.\n*\n*  DMIN1  (input/output) REAL\n*\n*  DMIN2  (input/output) REAL\n*\n*  DN     (input/output) REAL\n*\n*  DN1    (input/output) REAL\n*\n*  DN2    (input/output) REAL\n*\n*  G      (input/output) REAL\n*\n*  TAU    (input/output) REAL\n*\n*         These are passed as arguments in order to save their values\n*         between calls to SLASQ3.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  dmin, sigma, nfail, iter, ndiv, n0, pp, desig, ttype, dmin1, dmin2, dn, dn1, dn2, g, tau = NumRu::Lapack.slasq3( i0, n0, z, pp, desig, qmax, ieee, ttype, dmin1, dmin2, dn, dn1, dn2, g, tau, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 15 && argc != 15)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
  rblapack_i0 = argv[0];
  rblapack_n0 = argv[1];
  rblapack_z = argv[2];
  rblapack_pp = argv[3];
  rblapack_desig = argv[4];
  rblapack_qmax = argv[5];
  rblapack_ieee = argv[6];
  rblapack_ttype = argv[7];
  rblapack_dmin1 = argv[8];
  rblapack_dmin2 = argv[9];
  rblapack_dn = argv[10];
  rblapack_dn1 = argv[11];
  rblapack_dn2 = argv[12];
  rblapack_g = argv[13];
  rblapack_tau = argv[14];
  if (argc == 15) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  i0 = NUM2INT(rblapack_i0);
  pp = NUM2INT(rblapack_pp);
  qmax = (real)NUM2DBL(rblapack_qmax);
  ttype = NUM2INT(rblapack_ttype);
  dmin2 = (real)NUM2DBL(rblapack_dmin2);
  dn1 = (real)NUM2DBL(rblapack_dn1);
  g = (real)NUM2DBL(rblapack_g);
  n0 = NUM2INT(rblapack_n0);
  desig = (real)NUM2DBL(rblapack_desig);
  dmin1 = (real)NUM2DBL(rblapack_dmin1);
  dn2 = (real)NUM2DBL(rblapack_dn2);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (3th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != (4*n0))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 4*n0);
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  dn = (real)NUM2DBL(rblapack_dn);
  ieee = (rblapack_ieee == Qtrue);
  tau = (real)NUM2DBL(rblapack_tau);

  slasq3_(&i0, &n0, z, &pp, &dmin, &sigma, &desig, &qmax, &nfail, &iter, &ndiv, &ieee, &ttype, &dmin1, &dmin2, &dn, &dn1, &dn2, &g, &tau);

  rblapack_dmin = rb_float_new((double)dmin);
  rblapack_sigma = rb_float_new((double)sigma);
  rblapack_nfail = INT2NUM(nfail);
  rblapack_iter = INT2NUM(iter);
  rblapack_ndiv = INT2NUM(ndiv);
  rblapack_n0 = INT2NUM(n0);
  rblapack_pp = INT2NUM(pp);
  rblapack_desig = rb_float_new((double)desig);
  rblapack_ttype = INT2NUM(ttype);
  rblapack_dmin1 = rb_float_new((double)dmin1);
  rblapack_dmin2 = rb_float_new((double)dmin2);
  rblapack_dn = rb_float_new((double)dn);
  rblapack_dn1 = rb_float_new((double)dn1);
  rblapack_dn2 = rb_float_new((double)dn2);
  rblapack_g = rb_float_new((double)g);
  rblapack_tau = rb_float_new((double)tau);
  return rb_ary_new3(16, rblapack_dmin, rblapack_sigma, rblapack_nfail, rblapack_iter, rblapack_ndiv, rblapack_n0, rblapack_pp, rblapack_desig, rblapack_ttype, rblapack_dmin1, rblapack_dmin2, rblapack_dn, rblapack_dn1, rblapack_dn2, rblapack_g, rblapack_tau);
}

void
init_lapack_slasq3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slasq3", rblapack_slasq3, -1);
}
ruby-lapack-1.7.2/ext/dlarrc.c0000644000175000017500000001170412502221025015774 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlarrc_(char* jobt, integer* n, doublereal* vl, doublereal* vu, doublereal* d, doublereal* e, doublereal* pivmin, integer* eigcnt, integer* lcnt, integer* rcnt, integer* info);


static VALUE
rblapack_dlarrc(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobt;
  char jobt; 
  VALUE rblapack_vl;
  doublereal vl; 
  VALUE rblapack_vu;
  doublereal vu; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_pivmin;
  doublereal pivmin; 
  VALUE rblapack_eigcnt;
  integer eigcnt; 
  VALUE rblapack_lcnt;
  integer lcnt; 
  VALUE rblapack_rcnt;
  integer rcnt; 
  VALUE rblapack_info;
  integer info; 

  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  eigcnt, lcnt, rcnt, info = NumRu::Lapack.dlarrc( jobt, vl, vu, d, e, pivmin, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLARRC( JOBT, N, VL, VU, D, E, PIVMIN, EIGCNT, LCNT, RCNT, INFO )\n\n*  Purpose\n*  =======\n*\n*  Find the number of eigenvalues of the symmetric tridiagonal matrix T\n*  that are in the interval (VL,VU] if JOBT = 'T', and of L D L^T\n*  if JOBT = 'L'.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBT    (input) CHARACTER*1\n*          = 'T':  Compute Sturm count for matrix T.\n*          = 'L':  Compute Sturm count for matrix L D L^T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix. N > 0.\n*\n*  VL      (input) DOUBLE PRECISION\n*  VU      (input) DOUBLE PRECISION\n*          The lower and upper bounds for the eigenvalues.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          JOBT = 'T': The N diagonal elements of the tridiagonal matrix T.\n*          JOBT = 'L': The N diagonal elements of the diagonal matrix D.\n*\n*  E       (input) DOUBLE PRECISION array, dimension (N)\n*          JOBT = 'T': The N-1 offdiagonal elements of the matrix T.\n*          JOBT = 'L': The N-1 offdiagonal elements of the matrix L.\n*\n*  PIVMIN  (input) DOUBLE PRECISION\n*          The minimum pivot in the Sturm sequence for T.\n*\n*  EIGCNT  (output) INTEGER\n*          The number of eigenvalues of the symmetric tridiagonal matrix T\n*          that are in the interval (VL,VU]\n*\n*  LCNT    (output) INTEGER\n*  RCNT    (output) INTEGER\n*          The left and right negcounts of the interval.\n*\n*  INFO    (output) INTEGER\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Beresford Parlett, University of California, Berkeley, USA\n*     Jim Demmel, University of California, Berkeley, USA\n*     Inderjit Dhillon, University of Texas, Austin, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  eigcnt, lcnt, rcnt, info = NumRu::Lapack.dlarrc( jobt, vl, vu, d, e, pivmin, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_jobt = argv[0];
  rblapack_vl = argv[1];
  rblapack_vu = argv[2];
  rblapack_d = argv[3];
  rblapack_e = argv[4];
  rblapack_pivmin = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobt = StringValueCStr(rblapack_jobt)[0];
  vu = NUM2DBL(rblapack_vu);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (5th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_e);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  vl = NUM2DBL(rblapack_vl);
  pivmin = NUM2DBL(rblapack_pivmin);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of e");
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);

  dlarrc_(&jobt, &n, &vl, &vu, d, e, &pivmin, &eigcnt, &lcnt, &rcnt, &info);

  rblapack_eigcnt = INT2NUM(eigcnt);
  rblapack_lcnt = INT2NUM(lcnt);
  rblapack_rcnt = INT2NUM(rcnt);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_eigcnt, rblapack_lcnt, rblapack_rcnt, rblapack_info);
}

void
init_lapack_dlarrc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlarrc", rblapack_dlarrc, -1);
}
ruby-lapack-1.7.2/ext/sposvx.c0000644000175000017500000003575412502221026016103 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sposvx_(char* fact, char* uplo, integer* n, integer* nrhs, real* a, integer* lda, real* af, integer* ldaf, char* equed, real* s, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* ferr, real* berr, real* work, integer* iwork, integer* info);


static VALUE
rblapack_sposvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_af;
  real *af; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_af_out__;
  real *af_out__;
  VALUE rblapack_s_out__;
  real *s_out__;
  VALUE rblapack_b_out__;
  real *b_out__;
  real *work;
  integer *iwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, info, a, af, equed, s, b = NumRu::Lapack.sposvx( fact, uplo, a, af, equed, s, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPOSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to\n*  compute the solution to a real system of linear equations\n*     A * X = B,\n*  where A is an N-by-N symmetric positive definite matrix and X and B\n*  are N-by-NRHS matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'E', real scaling factors are computed to equilibrate\n*     the system:\n*        diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n*  2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n*     factor the matrix A (after equilibration if FACT = 'E') as\n*        A = U**T* U,  if UPLO = 'U', or\n*        A = L * L**T,  if UPLO = 'L',\n*     where U is an upper triangular matrix and L is a lower triangular\n*     matrix.\n*\n*  3. If the leading i-by-i principal minor is not positive definite,\n*     then the routine returns with INFO = i. Otherwise, the factored\n*     form of A is used to estimate the condition number of the matrix\n*     A.  If the reciprocal of the condition number is less than machine\n*     precision, INFO = N+1 is returned as a warning, but the routine\n*     still goes on to solve for X and compute error bounds as\n*     described below.\n*\n*  4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  5. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n*  6. If equilibration was used, the matrix X is premultiplied by\n*     diag(S) so that it solves the original system before\n*     equilibration.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of the matrix A is\n*          supplied on entry, and if not, whether the matrix A should be\n*          equilibrated before it is factored.\n*          = 'F':  On entry, AF contains the factored form of A.\n*                  If EQUED = 'Y', the matrix A has been equilibrated\n*                  with scaling factors given by S.  A and AF will not\n*                  be modified.\n*          = 'N':  The matrix A will be copied to AF and factored.\n*          = 'E':  The matrix A will be equilibrated if necessary, then\n*                  copied to AF and factored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the symmetric matrix A, except if FACT = 'F' and\n*          EQUED = 'Y', then A must contain the equilibrated matrix\n*          diag(S)*A*diag(S).  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.  A is not modified if\n*          FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n*          On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n*          diag(S)*A*diag(S).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AF      (input or output) REAL array, dimension (LDAF,N)\n*          If FACT = 'F', then AF is an input argument and on entry\n*          contains the triangular factor U or L from the Cholesky\n*          factorization A = U**T*U or A = L*L**T, in the same storage\n*          format as A.  If EQUED .ne. 'N', then AF is the factored form\n*          of the equilibrated matrix diag(S)*A*diag(S).\n*\n*          If FACT = 'N', then AF is an output argument and on exit\n*          returns the triangular factor U or L from the Cholesky\n*          factorization A = U**T*U or A = L*L**T of the original\n*          matrix A.\n*\n*          If FACT = 'E', then AF is an output argument and on exit\n*          returns the triangular factor U or L from the Cholesky\n*          factorization A = U**T*U or A = L*L**T of the equilibrated\n*          matrix A (see the description of A for the form of the\n*          equilibrated matrix).\n*\n*  LDAF    (input) INTEGER\n*          The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*  EQUED   (input or output) CHARACTER*1\n*          Specifies the form of equilibration that was done.\n*          = 'N':  No equilibration (always true if FACT = 'N').\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*          EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*          output argument.\n*\n*  S       (input or output) REAL array, dimension (N)\n*          The scale factors for A; not accessed if EQUED = 'N'.  S is\n*          an input argument if FACT = 'F'; otherwise, S is an output\n*          argument.  If FACT = 'F' and EQUED = 'Y', each element of S\n*          must be positive.\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n*          B is overwritten by diag(S) * B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) REAL array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n*          the original system of equations.  Note that if EQUED = 'Y',\n*          A and B are modified on exit, and the solution to the\n*          equilibrated system is inv(diag(S))*X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) REAL\n*          The estimate of the reciprocal condition number of the matrix\n*          A after equilibration (if done).  If RCOND is less than the\n*          machine precision (in particular, if RCOND = 0), the matrix\n*          is singular to working precision.  This condition is\n*          indicated by a return code of INFO > 0.\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) REAL array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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, and i is\n*                <= N:  the leading minor of order i of A is\n*                       not positive definite, so the factorization\n*                       could not be completed, and the solution has not\n*                       been computed. RCOND = 0 is returned.\n*                = N+1: U is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, info, a, af, equed, s, b = NumRu::Lapack.sposvx( fact, uplo, a, af, equed, s, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_equed = argv[4];
  rblapack_s = argv[5];
  rblapack_b = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (6th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
  af = NA_PTR_TYPE(rblapack_af, real*);
  ldx = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldaf;
    shape[1] = n;
    rblapack_af_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  af_out__ = NA_PTR_TYPE(rblapack_af_out__, real*);
  MEMCPY(af_out__, af, real, NA_TOTAL(rblapack_af));
  rblapack_af = rblapack_af_out__;
  af = af_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
  MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(real, (3*n));
  iwork = ALLOC_N(integer, (n));

  sposvx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_a, rblapack_af, rblapack_equed, rblapack_s, rblapack_b);
}

void
init_lapack_sposvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sposvx", rblapack_sposvx, -1);
}
ruby-lapack-1.7.2/ext/ssygst.c0000644000175000017500000001206212502221022016054 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssygst_(integer* itype, char* uplo, integer* n, real* a, integer* lda, real* b, integer* ldb, integer* info);


static VALUE
rblapack_ssygst(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;

  integer lda;
  integer n;
  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  info, a = NumRu::Lapack.ssygst( itype, uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSYGST reduces a real symmetric-definite generalized eigenproblem\n*  to standard form.\n*\n*  If ITYPE = 1, the problem is A*x = lambda*B*x,\n*  and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)\n*\n*  If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n*  B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.\n*\n*  B must have been previously factorized as U**T*U or L*L**T by SPOTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);\n*          = 2 or 3: compute U*A*U**T or L**T*A*L.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored and B is factored as\n*                  U**T*U;\n*          = 'L':  Lower triangle of A is stored and B is factored as\n*                  L*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the transformed matrix, stored in the\n*          same format as A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input) REAL array, dimension (LDB,N)\n*          The triangular factor from the Cholesky factorization of B,\n*          as returned by SPOTRF.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.ssygst( itype, uplo, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_itype = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  itype = NUM2INT(rblapack_itype);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  ssygst_(&itype, &uplo, &n, a, &lda, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_ssygst(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssygst", rblapack_ssygst, -1);
}
ruby-lapack-1.7.2/ext/spprfs.c0000644000175000017500000001717612502221022016050 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID spprfs_(char* uplo, integer* n, integer* nrhs, real* ap, real* afp, real* b, integer* ldb, real* x, integer* ldx, real* ferr, real* berr, real* work, integer* iwork, integer* info);


static VALUE
rblapack_spprfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_afp;
  real *afp; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  real *x_out__;
  real *work;
  integer *iwork;

  integer ldb;
  integer nrhs;
  integer ldx;
  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  ferr, berr, info, x = NumRu::Lapack.spprfs( uplo, ap, afp, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPPRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is symmetric positive definite\n*  and packed, and provides error bounds and backward error estimates\n*  for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AP      (input) REAL array, dimension (N*(N+1)/2)\n*          The upper or lower triangle of the symmetric matrix A, packed\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  AFP     (input) REAL array, dimension (N*(N+1)/2)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**T*U or A = L*L**T, as computed by SPPTRF/CPPTRF,\n*          packed columnwise in a linear array in the same format as A\n*          (see AP).\n*\n*  B       (input) REAL array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) REAL array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by SPPTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) REAL array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.spprfs( uplo, ap, afp, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_afp = argv[2];
  rblapack_b = argv[3];
  rblapack_x = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  n = ldb;
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (5th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  if (!NA_IsNArray(rblapack_afp))
    rb_raise(rb_eArgError, "afp (3th argument) must be NArray");
  if (NA_RANK(rblapack_afp) != 1)
    rb_raise(rb_eArgError, "rank of afp (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_afp) != NA_SFLOAT)
    rblapack_afp = na_change_type(rblapack_afp, NA_SFLOAT);
  afp = NA_PTR_TYPE(rblapack_afp, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(real, (3*n));
  iwork = ALLOC_N(integer, (n));

  spprfs_(&uplo, &n, &nrhs, ap, afp, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_spprfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "spprfs", rblapack_spprfs, -1);
}
ruby-lapack-1.7.2/ext/slaed7.c0000644000175000017500000003634112655767573015750 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaed7_(integer* icompq, integer* n, integer* qsiz, integer* tlvls, integer* curlvl, integer* curpbm, real* d, real* q, integer* ldq, integer* indxq, real* rho, integer* cutpnt, real* qstore, integer* qptr, integer* prmptr, integer* perm, integer* givptr, integer* givcol, real* givnum, real* work, integer* iwork, integer* info);


static VALUE
rblapack_slaed7(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_icompq;
  integer icompq; 
  VALUE rblapack_qsiz;
  integer qsiz; 
  VALUE rblapack_tlvls;
  integer tlvls; 
  VALUE rblapack_curlvl;
  integer curlvl; 
  VALUE rblapack_curpbm;
  integer curpbm; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_q;
  real *q; 
  VALUE rblapack_rho;
  real rho; 
  VALUE rblapack_cutpnt;
  integer cutpnt; 
  VALUE rblapack_qstore;
  real *qstore; 
  VALUE rblapack_qptr;
  integer *qptr; 
  VALUE rblapack_prmptr;
  integer *prmptr; 
  VALUE rblapack_perm;
  integer *perm; 
  VALUE rblapack_givptr;
  integer *givptr; 
  VALUE rblapack_givcol;
  integer *givcol; 
  VALUE rblapack_givnum;
  real *givnum; 
  VALUE rblapack_indxq;
  integer *indxq; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_q_out__;
  real *q_out__;
  VALUE rblapack_qstore_out__;
  real *qstore_out__;
  VALUE rblapack_qptr_out__;
  integer *qptr_out__;
  real *work;
  integer *iwork;

  integer n;
  integer ldq;

  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  indxq, info, d, q, qstore, qptr = NumRu::Lapack.slaed7( icompq, qsiz, tlvls, curlvl, curpbm, d, q, rho, cutpnt, qstore, qptr, prmptr, perm, givptr, givcol, givnum, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR, PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLAED7 computes the updated eigensystem of a diagonal\n*  matrix after modification by a rank-one symmetric matrix. This\n*  routine is used only for the eigenproblem which requires all\n*  eigenvalues and optionally eigenvectors of a dense symmetric matrix\n*  that has been reduced to tridiagonal form.  SLAED1 handles\n*  the case in which all eigenvalues and eigenvectors of a symmetric\n*  tridiagonal matrix are desired.\n*\n*    T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)\n*\n*     where Z = Q'u, u is a vector of length N with ones in the\n*     CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.\n*\n*     The eigenvectors of the original matrix are stored in Q, and the\n*     eigenvalues are in D.  The algorithm consists of three stages:\n*\n*        The first stage consists of deflating the size of the problem\n*        when there are multiple eigenvalues or if there is a zero in\n*        the Z vector.  For each such occurrence the dimension of the\n*        secular equation problem is reduced by one.  This stage is\n*        performed by the routine SLAED8.\n*\n*        The second stage consists of calculating the updated\n*        eigenvalues. This is done by finding the roots of the secular\n*        equation via the routine SLAED4 (as called by SLAED9).\n*        This routine also calculates the eigenvectors of the current\n*        problem.\n*\n*        The final stage consists of computing the updated eigenvectors\n*        directly using the updated eigenvalues.  The eigenvectors for\n*        the current problem are multiplied with the eigenvectors from\n*        the overall problem.\n*\n\n*  Arguments\n*  =========\n*\n*  ICOMPQ  (input) INTEGER\n*          = 0:  Compute eigenvalues only.\n*          = 1:  Compute eigenvectors of original dense symmetric matrix\n*                also.  On entry, Q contains the orthogonal matrix used\n*                to reduce the original matrix to tridiagonal form.\n*\n*  N      (input) INTEGER\n*         The dimension of the symmetric tridiagonal matrix.  N >= 0.\n*\n*  QSIZ   (input) INTEGER\n*         The dimension of the orthogonal matrix used to reduce\n*         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.\n*\n*  TLVLS  (input) INTEGER\n*         The total number of merging levels in the overall divide and\n*         conquer tree.\n*\n*  CURLVL (input) INTEGER\n*         The current level in the overall merge routine,\n*         0 <= CURLVL <= TLVLS.\n*\n*  CURPBM (input) INTEGER\n*         The current problem in the current level in the overall\n*         merge routine (counting from upper left to lower right).\n*\n*  D      (input/output) REAL array, dimension (N)\n*         On entry, the eigenvalues of the rank-1-perturbed matrix.\n*         On exit, the eigenvalues of the repaired matrix.\n*\n*  Q      (input/output) REAL array, dimension (LDQ, N)\n*         On entry, the eigenvectors of the rank-1-perturbed matrix.\n*         On exit, the eigenvectors of the repaired tridiagonal matrix.\n*\n*  LDQ    (input) INTEGER\n*         The leading dimension of the array Q.  LDQ >= max(1,N).\n*\n*  INDXQ  (output) INTEGER array, dimension (N)\n*         The permutation which will reintegrate the subproblem just\n*         solved back into sorted order, i.e., D( INDXQ( I = 1, N ) )\n*         will be in ascending order.\n*\n*  RHO    (input) REAL\n*         The subdiagonal element used to create the rank-1\n*         modification.\n*\n*  CUTPNT (input) INTEGER\n*         Contains the location of the last eigenvalue in the leading\n*         sub-matrix.  min(1,N) <= CUTPNT <= N.\n*\n*  QSTORE (input/output) REAL array, dimension (N**2+1)\n*         Stores eigenvectors of submatrices encountered during\n*         divide and conquer, packed together. QPTR points to\n*         beginning of the submatrices.\n*\n*  QPTR   (input/output) INTEGER array, dimension (N+2)\n*         List of indices pointing to beginning of submatrices stored\n*         in QSTORE. The submatrices are numbered starting at the\n*         bottom left of the divide and conquer tree, from left to\n*         right and bottom to top.\n*\n*  PRMPTR (input) INTEGER array, dimension (N lg N)\n*         Contains a list of pointers which indicate where in PERM a\n*         level's permutation is stored.  PRMPTR(i+1) - PRMPTR(i)\n*         indicates the size of the permutation and also the size of\n*         the full, non-deflated problem.\n*\n*  PERM   (input) INTEGER array, dimension (N lg N)\n*         Contains the permutations (from deflation and sorting) to be\n*         applied to each eigenblock.\n*\n*  GIVPTR (input) INTEGER array, dimension (N lg N)\n*         Contains a list of pointers which indicate where in GIVCOL a\n*         level's Givens rotations are stored.  GIVPTR(i+1) - GIVPTR(i)\n*         indicates the number of Givens rotations.\n*\n*  GIVCOL (input) INTEGER array, dimension (2, N lg N)\n*         Each pair of numbers indicates a pair of columns to take place\n*         in a Givens rotation.\n*\n*  GIVNUM (input) REAL array, dimension (2, N lg N)\n*         Each number indicates the S value to be used in the\n*         corresponding Givens rotation.\n*\n*  WORK   (workspace) REAL array, dimension (3*N+QSIZ*N)\n*\n*  IWORK  (workspace) INTEGER array, dimension (4*N)\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 = 1, an eigenvalue did not converge\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Jeff Rutter, Computer Science Division, University of California\n*     at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  indxq, info, d, q, qstore, qptr = NumRu::Lapack.slaed7( icompq, qsiz, tlvls, curlvl, curpbm, d, q, rho, cutpnt, qstore, qptr, prmptr, perm, givptr, givcol, givnum, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 16 && argc != 16)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 16)", argc);
  rblapack_icompq = argv[0];
  rblapack_qsiz = argv[1];
  rblapack_tlvls = argv[2];
  rblapack_curlvl = argv[3];
  rblapack_curpbm = argv[4];
  rblapack_d = argv[5];
  rblapack_q = argv[6];
  rblapack_rho = argv[7];
  rblapack_cutpnt = argv[8];
  rblapack_qstore = argv[9];
  rblapack_qptr = argv[10];
  rblapack_prmptr = argv[11];
  rblapack_perm = argv[12];
  rblapack_givptr = argv[13];
  rblapack_givcol = argv[14];
  rblapack_givnum = argv[15];
  if (argc == 16) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  icompq = NUM2INT(rblapack_icompq);
  tlvls = NUM2INT(rblapack_tlvls);
  curpbm = NUM2INT(rblapack_curpbm);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (7th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  n = NA_SHAPE1(rblapack_q);
  if (NA_TYPE(rblapack_q) != NA_SFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
  q = NA_PTR_TYPE(rblapack_q, real*);
  cutpnt = NUM2INT(rblapack_cutpnt);
  qsiz = NUM2INT(rblapack_qsiz);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (6th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of q");
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_qstore))
    rb_raise(rb_eArgError, "qstore (10th argument) must be NArray");
  if (NA_RANK(rblapack_qstore) != 1)
    rb_raise(rb_eArgError, "rank of qstore (10th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_qstore) != (pow(n,2)+1))
    rb_raise(rb_eRuntimeError, "shape 0 of qstore must be %d", pow(n,2)+1);
  if (NA_TYPE(rblapack_qstore) != NA_SFLOAT)
    rblapack_qstore = na_change_type(rblapack_qstore, NA_SFLOAT);
  qstore = NA_PTR_TYPE(rblapack_qstore, real*);
  if (!NA_IsNArray(rblapack_prmptr))
    rb_raise(rb_eArgError, "prmptr (12th argument) must be NArray");
  if (NA_RANK(rblapack_prmptr) != 1)
    rb_raise(rb_eArgError, "rank of prmptr (12th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_prmptr) != (n*LG(n)))
    rb_raise(rb_eRuntimeError, "shape 0 of prmptr must be %d", n*LG(n));
  if (NA_TYPE(rblapack_prmptr) != NA_LINT)
    rblapack_prmptr = na_change_type(rblapack_prmptr, NA_LINT);
  prmptr = NA_PTR_TYPE(rblapack_prmptr, integer*);
  if (!NA_IsNArray(rblapack_givptr))
    rb_raise(rb_eArgError, "givptr (14th argument) must be NArray");
  if (NA_RANK(rblapack_givptr) != 1)
    rb_raise(rb_eArgError, "rank of givptr (14th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_givptr) != (n*LG(n)))
    rb_raise(rb_eRuntimeError, "shape 0 of givptr must be %d", n*LG(n));
  if (NA_TYPE(rblapack_givptr) != NA_LINT)
    rblapack_givptr = na_change_type(rblapack_givptr, NA_LINT);
  givptr = NA_PTR_TYPE(rblapack_givptr, integer*);
  if (!NA_IsNArray(rblapack_givnum))
    rb_raise(rb_eArgError, "givnum (16th argument) must be NArray");
  if (NA_RANK(rblapack_givnum) != 2)
    rb_raise(rb_eArgError, "rank of givnum (16th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_givnum) != (2))
    rb_raise(rb_eRuntimeError, "shape 0 of givnum must be %d", 2);
  if (NA_SHAPE1(rblapack_givnum) != (n*LG(n)))
    rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", n*LG(n));
  if (NA_TYPE(rblapack_givnum) != NA_SFLOAT)
    rblapack_givnum = na_change_type(rblapack_givnum, NA_SFLOAT);
  givnum = NA_PTR_TYPE(rblapack_givnum, real*);
  curlvl = NUM2INT(rblapack_curlvl);
  if (!NA_IsNArray(rblapack_qptr))
    rb_raise(rb_eArgError, "qptr (11th argument) must be NArray");
  if (NA_RANK(rblapack_qptr) != 1)
    rb_raise(rb_eArgError, "rank of qptr (11th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_qptr) != (n+2))
    rb_raise(rb_eRuntimeError, "shape 0 of qptr must be %d", n+2);
  if (NA_TYPE(rblapack_qptr) != NA_LINT)
    rblapack_qptr = na_change_type(rblapack_qptr, NA_LINT);
  qptr = NA_PTR_TYPE(rblapack_qptr, integer*);
  if (!NA_IsNArray(rblapack_givcol))
    rb_raise(rb_eArgError, "givcol (15th argument) must be NArray");
  if (NA_RANK(rblapack_givcol) != 2)
    rb_raise(rb_eArgError, "rank of givcol (15th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_givcol) != (2))
    rb_raise(rb_eRuntimeError, "shape 0 of givcol must be %d", 2);
  if (NA_SHAPE1(rblapack_givcol) != (n*LG(n)))
    rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", n*LG(n));
  if (NA_TYPE(rblapack_givcol) != NA_LINT)
    rblapack_givcol = na_change_type(rblapack_givcol, NA_LINT);
  givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
  rho = (real)NUM2DBL(rblapack_rho);
  if (!NA_IsNArray(rblapack_perm))
    rb_raise(rb_eArgError, "perm (13th argument) must be NArray");
  if (NA_RANK(rblapack_perm) != 1)
    rb_raise(rb_eArgError, "rank of perm (13th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_perm) != (n*LG(n)))
    rb_raise(rb_eRuntimeError, "shape 0 of perm must be %d", n*LG(n));
  if (NA_TYPE(rblapack_perm) != NA_LINT)
    rblapack_perm = na_change_type(rblapack_perm, NA_LINT);
  perm = NA_PTR_TYPE(rblapack_perm, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_indxq = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  indxq = NA_PTR_TYPE(rblapack_indxq, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
  MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  {
    na_shape_t shape[1];
    shape[0] = pow(n,2)+1;
    rblapack_qstore_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  qstore_out__ = NA_PTR_TYPE(rblapack_qstore_out__, real*);
  MEMCPY(qstore_out__, qstore, real, NA_TOTAL(rblapack_qstore));
  rblapack_qstore = rblapack_qstore_out__;
  qstore = qstore_out__;
  {
    na_shape_t shape[1];
    shape[0] = n+2;
    rblapack_qptr_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  qptr_out__ = NA_PTR_TYPE(rblapack_qptr_out__, integer*);
  MEMCPY(qptr_out__, qptr, integer, NA_TOTAL(rblapack_qptr));
  rblapack_qptr = rblapack_qptr_out__;
  qptr = qptr_out__;
  work = ALLOC_N(real, (3*n+qsiz*n));
  iwork = ALLOC_N(integer, (4*n));

  slaed7_(&icompq, &n, &qsiz, &tlvls, &curlvl, &curpbm, d, q, &ldq, indxq, &rho, &cutpnt, qstore, qptr, prmptr, perm, givptr, givcol, givnum, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_indxq, rblapack_info, rblapack_d, rblapack_q, rblapack_qstore, rblapack_qptr);
}

void
init_lapack_slaed7(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaed7", rblapack_slaed7, -1);
}
ruby-lapack-1.7.2/ext/dppsv.c0000644000175000017500000001437112502221022015661 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dppsv_(char* uplo, integer* n, integer* nrhs, doublereal* ap, doublereal* b, integer* ldb, integer* info);


static VALUE
rblapack_dppsv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublereal *ap_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;

  integer ldb;
  integer nrhs;

  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  info, ap, b = NumRu::Lapack.dppsv( uplo, n, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPPSV( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPPSV computes the solution to a real system of linear equations\n*     A * X = B,\n*  where A is an N-by-N symmetric positive definite matrix stored in\n*  packed format and X and B are N-by-NRHS matrices.\n*\n*  The Cholesky decomposition is used to factor A as\n*     A = U**T* U,  if UPLO = 'U', or\n*     A = L * L**T,  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is a lower triangular\n*  matrix.  The factored form of A is then used to solve the system of\n*  equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          See below for further details.\n*\n*          On exit, if INFO = 0, the factor U or L from the Cholesky\n*          factorization A = U**T*U or A = L*L**T, in the same storage\n*          format as A.\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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 leading minor of order i of A is not\n*                positive definite, so the factorization could not be\n*                completed, and the solution has not been computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  The packed storage scheme is illustrated by the following example\n*  when N = 4, UPLO = 'U':\n*\n*  Two-dimensional storage of the symmetric matrix A:\n*\n*     a11 a12 a13 a14\n*         a22 a23 a24\n*             a33 a34     (aij = conjg(aji))\n*                 a44\n*\n*  Packed storage of the upper triangle of A:\n*\n*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n*  =====================================================================\n*\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DPPTRF, DPPTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ap, b = NumRu::Lapack.dppsv( uplo, n, ap, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_n = argv[1];
  rblapack_ap = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
  MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dppsv_(&uplo, &n, &nrhs, ap, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_ap, rblapack_b);
}

void
init_lapack_dppsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dppsv", rblapack_dppsv, -1);
}
ruby-lapack-1.7.2/ext/dtgsna.c0000644000175000017500000004141312502221025016005 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtgsna_(char* job, char* howmny, logical* select, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* vl, integer* ldvl, doublereal* vr, integer* ldvr, doublereal* s, doublereal* dif, integer* mm, integer* m, doublereal* work, integer* lwork, integer* iwork, integer* info);


static VALUE
rblapack_dtgsna(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_howmny;
  char howmny; 
  VALUE rblapack_select;
  logical *select; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_vl;
  doublereal *vl; 
  VALUE rblapack_vr;
  doublereal *vr; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_dif;
  doublereal *dif; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  integer *iwork;

  integer n;
  integer lda;
  integer ldb;
  integer ldvl;
  integer ldvr;
  integer mm;

  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  s, dif, m, work, info = NumRu::Lapack.dtgsna( job, howmny, select, a, b, vl, vr, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTGSNA estimates reciprocal condition numbers for specified\n*  eigenvalues and/or eigenvectors of a matrix pair (A, B) in\n*  generalized real Schur canonical form (or of any matrix pair\n*  (Q*A*Z', Q*B*Z') with orthogonal matrices Q and Z, where\n*  Z' denotes the transpose of Z.\n*\n*  (A, B) must be in generalized real Schur form (as returned by DGGES),\n*  i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal\n*  blocks. B is upper triangular.\n*\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies whether condition numbers are required for\n*          eigenvalues (S) or eigenvectors (DIF):\n*          = 'E': for eigenvalues only (S);\n*          = 'V': for eigenvectors only (DIF);\n*          = 'B': for both eigenvalues and eigenvectors (S and DIF).\n*\n*  HOWMNY  (input) CHARACTER*1\n*          = 'A': compute condition numbers for all eigenpairs;\n*          = 'S': compute condition numbers for selected eigenpairs\n*                 specified by the array SELECT.\n*\n*  SELECT  (input) LOGICAL array, dimension (N)\n*          If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n*          condition numbers are required. To select condition numbers\n*          for the eigenpair corresponding to a real eigenvalue w(j),\n*          SELECT(j) must be set to .TRUE.. To select condition numbers\n*          corresponding to a complex conjugate pair of eigenvalues w(j)\n*          and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be\n*          set to .TRUE..\n*          If HOWMNY = 'A', SELECT is not referenced.\n*\n*  N       (input) INTEGER\n*          The order of the square matrix pair (A, B). N >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*          The upper quasi-triangular matrix A in the pair (A,B).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  B       (input) DOUBLE PRECISION array, dimension (LDB,N)\n*          The upper triangular matrix B in the pair (A,B).\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  VL      (input) DOUBLE PRECISION array, dimension (LDVL,M)\n*          If JOB = 'E' or 'B', VL must contain left eigenvectors of\n*          (A, B), corresponding to the eigenpairs specified by HOWMNY\n*          and SELECT. The eigenvectors must be stored in consecutive\n*          columns of VL, as returned by DTGEVC.\n*          If JOB = 'V', VL is not referenced.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the array VL. LDVL >= 1.\n*          If JOB = 'E' or 'B', LDVL >= N.\n*\n*  VR      (input) DOUBLE PRECISION array, dimension (LDVR,M)\n*          If JOB = 'E' or 'B', VR must contain right eigenvectors of\n*          (A, B), corresponding to the eigenpairs specified by HOWMNY\n*          and SELECT. The eigenvectors must be stored in consecutive\n*          columns ov VR, as returned by DTGEVC.\n*          If JOB = 'V', VR is not referenced.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the array VR. LDVR >= 1.\n*          If JOB = 'E' or 'B', LDVR >= N.\n*\n*  S       (output) DOUBLE PRECISION array, dimension (MM)\n*          If JOB = 'E' or 'B', the reciprocal condition numbers of the\n*          selected eigenvalues, stored in consecutive elements of the\n*          array. For a complex conjugate pair of eigenvalues two\n*          consecutive elements of S are set to the same value. Thus\n*          S(j), DIF(j), and the j-th columns of VL and VR all\n*          correspond to the same eigenpair (but not in general the\n*          j-th eigenpair, unless all eigenpairs are selected).\n*          If JOB = 'V', S is not referenced.\n*\n*  DIF     (output) DOUBLE PRECISION array, dimension (MM)\n*          If JOB = 'V' or 'B', the estimated reciprocal condition\n*          numbers of the selected eigenvectors, stored in consecutive\n*          elements of the array. For a complex eigenvector two\n*          consecutive elements of DIF are set to the same value. If\n*          the eigenvalues cannot be reordered to compute DIF(j), DIF(j)\n*          is set to 0; this can only occur when the true value would be\n*          very small anyway.\n*          If JOB = 'E', DIF is not referenced.\n*\n*  MM      (input) INTEGER\n*          The number of elements in the arrays S and DIF. MM >= M.\n*\n*  M       (output) INTEGER\n*          The number of elements of the arrays S and DIF used to store\n*          the specified condition numbers; for each selected real\n*          eigenvalue one element is used, and for each selected complex\n*          conjugate pair of eigenvalues, two elements are used.\n*          If HOWMNY = 'A', M is set to 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. LWORK >= max(1,N).\n*          If JOB = 'V' or 'B' LWORK >= 2*N*(N+2)+16.\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*  IWORK   (workspace) INTEGER array, dimension (N + 6)\n*          If JOB = 'E', IWORK is not referenced.\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\n*  Further Details\n*  ===============\n*\n*  The reciprocal of the condition number of a generalized eigenvalue\n*  w = (a, b) is defined as\n*\n*       S(w) = (|u'Av|**2 + |u'Bv|**2)**(1/2) / (norm(u)*norm(v))\n*\n*  where u and v are the left and right eigenvectors of (A, B)\n*  corresponding to w; |z| denotes the absolute value of the complex\n*  number, and norm(u) denotes the 2-norm of the vector u.\n*  The pair (a, b) corresponds to an eigenvalue w = a/b (= u'Av/u'Bv)\n*  of the matrix pair (A, B). If both a and b equal zero, then (A B) is\n*  singular and S(I) = -1 is returned.\n*\n*  An approximate error bound on the chordal distance between the i-th\n*  computed generalized eigenvalue w and the corresponding exact\n*  eigenvalue lambda is\n*\n*       chord(w, lambda) <= EPS * norm(A, B) / S(I)\n*\n*  where EPS is the machine precision.\n*\n*  The reciprocal of the condition number DIF(i) of right eigenvector u\n*  and left eigenvector v corresponding to the generalized eigenvalue w\n*  is defined as follows:\n*\n*  a) If the i-th eigenvalue w = (a,b) is real\n*\n*     Suppose U and V are orthogonal transformations such that\n*\n*                U'*(A, B)*V  = (S, T) = ( a   *  ) ( b  *  )  1\n*                                        ( 0  S22 ),( 0 T22 )  n-1\n*                                          1  n-1     1 n-1\n*\n*     Then the reciprocal condition number DIF(i) is\n*\n*                Difl((a, b), (S22, T22)) = sigma-min( Zl ),\n*\n*     where sigma-min(Zl) denotes the smallest singular value of the\n*     2(n-1)-by-2(n-1) matrix\n*\n*         Zl = [ kron(a, In-1)  -kron(1, S22) ]\n*              [ kron(b, In-1)  -kron(1, T22) ] .\n*\n*     Here In-1 is the identity matrix of size n-1. kron(X, Y) is the\n*     Kronecker product between the matrices X and Y.\n*\n*     Note that if the default method for computing DIF(i) is wanted\n*     (see DLATDF), then the parameter DIFDRI (see below) should be\n*     changed from 3 to 4 (routine DLATDF(IJOB = 2 will be used)).\n*     See DTGSYL for more details.\n*\n*  b) If the i-th and (i+1)-th eigenvalues are complex conjugate pair,\n*\n*     Suppose U and V are orthogonal transformations such that\n*\n*                U'*(A, B)*V = (S, T) = ( S11  *   ) ( T11  *  )  2\n*                                       ( 0    S22 ),( 0    T22) n-2\n*                                         2    n-2     2    n-2\n*\n*     and (S11, T11) corresponds to the complex conjugate eigenvalue\n*     pair (w, conjg(w)). There exist unitary matrices U1 and V1 such\n*     that\n*\n*         U1'*S11*V1 = ( s11 s12 )   and U1'*T11*V1 = ( t11 t12 )\n*                      (  0  s22 )                    (  0  t22 )\n*\n*     where the generalized eigenvalues w = s11/t11 and\n*     conjg(w) = s22/t22.\n*\n*     Then the reciprocal condition number DIF(i) is bounded by\n*\n*         min( d1, max( 1, |real(s11)/real(s22)| )*d2 )\n*\n*     where, d1 = Difl((s11, t11), (s22, t22)) = sigma-min(Z1), where\n*     Z1 is the complex 2-by-2 matrix\n*\n*              Z1 =  [ s11  -s22 ]\n*                    [ t11  -t22 ],\n*\n*     This is done by computing (using real arithmetic) the\n*     roots of the characteristical polynomial det(Z1' * Z1 - lambda I),\n*     where Z1' denotes the conjugate transpose of Z1 and det(X) denotes\n*     the determinant of X.\n*\n*     and d2 is an upper bound on Difl((S11, T11), (S22, T22)), i.e. an\n*     upper bound on sigma-min(Z2), where Z2 is (2n-2)-by-(2n-2)\n*\n*              Z2 = [ kron(S11', In-2)  -kron(I2, S22) ]\n*                   [ kron(T11', In-2)  -kron(I2, T22) ]\n*\n*     Note that if the default method for computing DIF is wanted (see\n*     DLATDF), then the parameter DIFDRI (see below) should be changed\n*     from 3 to 4 (routine DLATDF(IJOB = 2 will be used)). See DTGSYL\n*     for more details.\n*\n*  For each eigenvalue/vector specified by SELECT, DIF stores a\n*  Frobenius norm-based estimate of Difl.\n*\n*  An approximate error bound for the i-th computed eigenvector VL(i) or\n*  VR(i) is given by\n*\n*             EPS * norm(A, B) / DIF(i).\n*\n*  See ref. [2-3] for more details and further references.\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  References\n*  ==========\n*\n*  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n*      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n*      M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n*      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n*  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n*      Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n*      Estimation: Theory, Algorithms and Software,\n*      Report UMINF - 94.04, Department of Computing Science, Umea\n*      University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working\n*      Note 87. To appear in Numerical Algorithms, 1996.\n*\n*  [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n*      for Solving the Generalized Sylvester Equation and Estimating the\n*      Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n*      Department of Computing Science, Umea University, S-901 87 Umea,\n*      Sweden, December 1993, Revised April 1994, Also as LAPACK Working\n*      Note 75.  To appear in ACM Trans. on Math. Software, Vol 22,\n*      No 1, 1996.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, dif, m, work, info = NumRu::Lapack.dtgsna( job, howmny, select, a, b, vl, vr, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_job = argv[0];
  rblapack_howmny = argv[1];
  rblapack_select = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  rblapack_vl = argv[5];
  rblapack_vr = argv[6];
  if (argc == 8) {
    rblapack_lwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  job = StringValueCStr(rblapack_job)[0];
  if (!NA_IsNArray(rblapack_select))
    rb_raise(rb_eArgError, "select (3th argument) must be NArray");
  if (NA_RANK(rblapack_select) != 1)
    rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_select);
  if (NA_TYPE(rblapack_select) != NA_LINT)
    rblapack_select = na_change_type(rblapack_select, NA_LINT);
  select = NA_PTR_TYPE(rblapack_select, logical*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  if (!NA_IsNArray(rblapack_vr))
    rb_raise(rb_eArgError, "vr (7th argument) must be NArray");
  if (NA_RANK(rblapack_vr) != 2)
    rb_raise(rb_eArgError, "rank of vr (7th argument) must be %d", 2);
  ldvr = NA_SHAPE0(rblapack_vr);
  m = NA_SHAPE1(rblapack_vr);
  if (NA_TYPE(rblapack_vr) != NA_DFLOAT)
    rblapack_vr = na_change_type(rblapack_vr, NA_DFLOAT);
  vr = NA_PTR_TYPE(rblapack_vr, doublereal*);
  howmny = StringValueCStr(rblapack_howmny)[0];
  if (!NA_IsNArray(rblapack_vl))
    rb_raise(rb_eArgError, "vl (6th argument) must be NArray");
  if (NA_RANK(rblapack_vl) != 2)
    rb_raise(rb_eArgError, "rank of vl (6th argument) must be %d", 2);
  ldvl = NA_SHAPE0(rblapack_vl);
  if (NA_SHAPE1(rblapack_vl) != m)
    rb_raise(rb_eRuntimeError, "shape 1 of vl must be the same as shape 1 of vr");
  if (NA_TYPE(rblapack_vl) != NA_DFLOAT)
    rblapack_vl = na_change_type(rblapack_vl, NA_DFLOAT);
  vl = NA_PTR_TYPE(rblapack_vl, doublereal*);
  mm = m;
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  if (rblapack_lwork == Qnil)
    lwork = (lsame_(&job,"V")||lsame_(&job,"B")) ? 2*n*n : n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = mm;
    rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = mm;
    rblapack_dif = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  dif = NA_PTR_TYPE(rblapack_dif, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  iwork = ALLOC_N(integer, (lsame_(&job,"E") ? 0 : n + 6));

  dtgsna_(&job, &howmny, select, &n, a, &lda, b, &ldb, vl, &ldvl, vr, &ldvr, s, dif, &mm, &m, work, &lwork, iwork, &info);

  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_s, rblapack_dif, rblapack_m, rblapack_work, rblapack_info);
}

void
init_lapack_dtgsna(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtgsna", rblapack_dtgsna, -1);
}
ruby-lapack-1.7.2/ext/ctprfs.c0000644000175000017500000001623612502221017016034 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctprfs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, complex* ap, complex* b, integer* ldb, complex* x, integer* ldx, real* ferr, real* berr, complex* work, real* rwork, integer* info);


static VALUE
rblapack_ctprfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  complex *work;
  real *rwork;

  integer ldb;
  integer nrhs;
  integer ldx;
  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  ferr, berr, info = NumRu::Lapack.ctprfs( uplo, trans, diag, ap, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTPRFS provides error bounds and backward error estimates for the\n*  solution to a system of linear equations with a triangular packed\n*  coefficient matrix.\n*\n*  The solution matrix X must be computed by CTPTRS or some other\n*  means before entering this routine.  CTPRFS does not do iterative\n*  refinement because doing so cannot improve the backward error.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)\n*          The upper or lower triangular matrix A, packed columnwise in\n*          a linear array.  The j-th column of A is stored in the array\n*          AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          If DIAG = 'U', the diagonal elements of A are not referenced\n*          and are assumed to be 1.\n*\n*  B       (input) COMPLEX array, dimension (LDB,NRHS)\n*          The right hand side matrix B. \n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input) COMPLEX array, dimension (LDX,NRHS)\n*          The solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info = NumRu::Lapack.ctprfs( uplo, trans, diag, ap, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_ap = argv[3];
  rblapack_b = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  n = ldb;
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (n));

  ctprfs_(&uplo, &trans, &diag, &n, &nrhs, ap, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ferr, rblapack_berr, rblapack_info);
}

void
init_lapack_ctprfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctprfs", rblapack_ctprfs, -1);
}
ruby-lapack-1.7.2/ext/zgbequb.c0000644000175000017500000001412312502221022016157 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgbequb_(integer* m, integer* n, integer* kl, integer* ku, doublereal* ab, integer* ldab, doublereal* r, doublereal* c, doublereal* rowcnd, doublereal* colcnd, doublereal* amax, integer* info);


static VALUE
rblapack_zgbequb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_r;
  doublereal *r; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_rowcnd;
  doublereal rowcnd; 
  VALUE rblapack_colcnd;
  doublereal colcnd; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_info;
  integer info; 

  integer ldab;
  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  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.zgbequb( kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGBEQUB computes row and column scalings intended to equilibrate an\n*  M-by-N matrix A and reduce its condition number.  R returns the row\n*  scale factors and C the column scale factors, chosen to try to make\n*  the largest element in each row and column of the matrix B with\n*  elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most\n*  the radix.\n*\n*  R(i) and C(j) are restricted to be a power of the radix between\n*  SMLNUM = smallest safe number and BIGNUM = largest safe number.  Use\n*  of these scaling factors is not guaranteed to reduce the condition\n*  number of A but works well in practice.\n*\n*  This routine differs from ZGEEQU by restricting the scaling factors\n*  to a power of the radix.  Baring over- and underflow, scaling by\n*  these factors introduces no additional rounding errors.  However, the\n*  scaled entries' magnitured are no longer approximately 1 but lie\n*  between sqrt(radix) and 1/sqrt(radix).\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*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)\n*          On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n*          The j-th column of A is stored in the j-th column of the\n*          array AB as follows:\n*          AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array A.  LDAB >= max(1,M).\n*\n*  R       (output) DOUBLE PRECISION array, dimension (M)\n*          If INFO = 0 or INFO > M, R contains the row scale factors\n*          for A.\n*\n*  C       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0,  C contains the column scale factors for A.\n*\n*  ROWCND  (output) DOUBLE PRECISION\n*          If INFO = 0 or INFO > M, ROWCND contains the ratio of the\n*          smallest R(i) to the largest R(i).  If ROWCND >= 0.1 and\n*          AMAX is neither too large nor too small, it is not worth\n*          scaling by R.\n*\n*  COLCND  (output) DOUBLE PRECISION\n*          If INFO = 0, COLCND contains the ratio of the smallest\n*          C(i) to the largest C(i).  If COLCND >= 0.1, it is not\n*          worth scaling by C.\n*\n*  AMAX    (output) DOUBLE PRECISION\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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,  and i is\n*                <= M:  the i-th row of A is exactly zero\n*                >  M:  the (i-M)-th column of A is exactly zero\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  r, c, rowcnd, colcnd, amax, info = NumRu::Lapack.zgbequb( kl, ku, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_kl = argv[0];
  rblapack_ku = argv[1];
  rblapack_ab = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  ku = NUM2INT(rblapack_ku);
  m = ldab;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_r = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  r = NA_PTR_TYPE(rblapack_r, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  c = NA_PTR_TYPE(rblapack_c, doublereal*);

  zgbequb_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &info);

  rblapack_rowcnd = rb_float_new((double)rowcnd);
  rblapack_colcnd = rb_float_new((double)colcnd);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_r, rblapack_c, rblapack_rowcnd, rblapack_colcnd, rblapack_amax, rblapack_info);
}

void
init_lapack_zgbequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgbequb", rblapack_zgbequb, -1);
}
ruby-lapack-1.7.2/ext/zgeqrf.c0000644000175000017500000001350512502221025016024 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgeqrf_(integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zgeqrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *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.zgeqrf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGEQRF computes a QR factorization of a complex M-by-N matrix A:\n*  A = Q * R.\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) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, the elements on and above the diagonal of the array\n*          contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n*          upper triangular if m >= n); the elements below the diagonal,\n*          with the array TAU, represent the unitary matrix Q as a\n*          product of min(m,n) elementary reflectors (see Further\n*          Details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  TAU     (output) COMPLEX*16 array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace/output) COMPLEX*16 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,N).\n*          For optimum performance LWORK >= N*NB, where NB is\n*          the 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(1) H(2) . . . H(k), 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 complex scalar, and v is a complex vector with\n*  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),\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           XERBLA, ZGEQR2, ZLARFB, ZLARFT\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.zgeqrf( 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;
  }

  m = NUM2INT(rblapack_m);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zgeqrf_(&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_zgeqrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgeqrf", rblapack_zgeqrf, -1);
}
ruby-lapack-1.7.2/ext/clascl2.c0000644000175000017500000000652212502221013016047 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clascl2_(integer* m, integer* n, real* d, complex* x, integer* ldx);


static VALUE
rblapack_clascl2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_x_out__;
  complex *x_out__;

  integer m;
  integer ldx;
  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  x = NumRu::Lapack.clascl2( d, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLASCL2 ( M, N, D, X, LDX )\n\n*  Purpose\n*  =======\n*\n*  CLASCL2 performs a diagonal scaling on a vector:\n*    x <-- D * x\n*  where the diagonal REAL matrix D is stored as a vector.\n*\n*  Eventually to be replaced by BLAS_cge_diag_scale in the new BLAS\n*  standard.\n*\n\n*  Arguments\n*  =========\n*\n*     M       (input) INTEGER\n*     The number of rows of D and X. M >= 0.\n*\n*     N       (input) INTEGER\n*     The number of columns of D and X. N >= 0.\n*\n*     D       (input) REAL array, length M\n*     Diagonal matrix D, stored as a vector of length M.\n*\n*     X       (input/output) COMPLEX array, dimension (LDX,N)\n*     On entry, the vector X to be scaled by D.\n*     On exit, the scaled vector.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the vector X. LDX >= 0.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x = NumRu::Lapack.clascl2( d, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_d = argv[0];
  rblapack_x = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  n = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = n;
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;

  clascl2_(&m, &n, d, x, &ldx);

  return rblapack_x;
}

void
init_lapack_clascl2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clascl2", rblapack_clascl2, -1);
}
ruby-lapack-1.7.2/ext/slauu2.c0000644000175000017500000000730412502221020015734 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slauu2_(char* uplo, integer* n, real* a, integer* lda, integer* info);


static VALUE
rblapack_slauu2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *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  info, a = NumRu::Lapack.slauu2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAUU2( UPLO, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLAUU2 computes the product U * U' or L' * L, where the triangular\n*  factor U or L is stored in the upper or lower triangular part of\n*  the array A.\n*\n*  If UPLO = 'U' or 'u' then the upper triangle of the result is stored,\n*  overwriting the factor U in A.\n*  If UPLO = 'L' or 'l' then the lower triangle of the result is stored,\n*  overwriting the factor L in A.\n*\n*  This is the unblocked form of the algorithm, calling Level 2 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the triangular factor stored in the array A\n*          is upper or lower triangular:\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the triangular factor U or L.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the triangular factor U or L.\n*          On exit, if UPLO = 'U', the upper triangle of A is\n*          overwritten with the upper triangle of the product U * U';\n*          if UPLO = 'L', the lower triangle of A is overwritten with\n*          the lower triangle of the product L' * L.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.slauu2( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  slauu2_(&uplo, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_slauu2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slauu2", rblapack_slauu2, -1);
}
ruby-lapack-1.7.2/ext/sgeqlf.c0000644000175000017500000001346012502221023016005 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgeqlf_(integer* m, integer* n, real* a, integer* lda, real* tau, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sgeqlf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *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.sgeqlf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGEQLF computes a QL factorization of a real M-by-N matrix A:\n*  A = Q * L.\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) REAL array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit,\n*          if m >= n, the lower triangle of the subarray\n*          A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L;\n*          if m <= n, the elements on and below the (n-m)-th\n*          superdiagonal contain the M-by-N lower trapezoidal matrix L;\n*          the remaining elements, with the array TAU, represent the\n*          orthogonal matrix Q as a product of elementary reflectors\n*          (see Further Details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  TAU     (output) REAL array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace/output) REAL 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,N).\n*          For optimum performance LWORK >= N*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(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n*  A(1:m-k+i-1,n-k+i), and tau in TAU(i).\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY\n      INTEGER            I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n     $                   MU, NB, NBMIN, NU, NX\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SGEQL2, SLARFB, SLARFT, 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.sgeqlf( 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;
  }

  m = NUM2INT(rblapack_m);
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  sgeqlf_(&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_sgeqlf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgeqlf", rblapack_sgeqlf, -1);
}
ruby-lapack-1.7.2/ext/ztrexc.c0000644000175000017500000001341412502221012016040 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztrexc_(char* compq, integer* n, doublecomplex* t, integer* ldt, doublecomplex* q, integer* ldq, integer* ifst, integer* ilst, integer* info);


static VALUE
rblapack_ztrexc(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_compq;
  char compq; 
  VALUE rblapack_t;
  doublecomplex *t; 
  VALUE rblapack_q;
  doublecomplex *q; 
  VALUE rblapack_ifst;
  integer ifst; 
  VALUE rblapack_ilst;
  integer ilst; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_t_out__;
  doublecomplex *t_out__;
  VALUE rblapack_q_out__;
  doublecomplex *q_out__;

  integer ldt;
  integer n;
  integer ldq;

  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  info, t, q = NumRu::Lapack.ztrexc( compq, t, q, ifst, ilst, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTREXC reorders the Schur factorization of a complex matrix\n*  A = Q*T*Q**H, so that the diagonal element of T with row index IFST\n*  is moved to row ILST.\n*\n*  The Schur form T is reordered by a unitary similarity transformation\n*  Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by\n*  postmultplying it with Z.\n*\n\n*  Arguments\n*  =========\n*\n*  COMPQ   (input) CHARACTER*1\n*          = 'V':  update the matrix Q of Schur vectors;\n*          = 'N':  do not update Q.\n*\n*  N       (input) INTEGER\n*          The order of the matrix T. N >= 0.\n*\n*  T       (input/output) COMPLEX*16 array, dimension (LDT,N)\n*          On entry, the upper triangular matrix T.\n*          On exit, the reordered upper triangular matrix.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= max(1,N).\n*\n*  Q       (input/output) COMPLEX*16 array, dimension (LDQ,N)\n*          On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n*          On exit, if COMPQ = 'V', Q has been postmultiplied by the\n*          unitary transformation matrix Z which reorders T.\n*          If COMPQ = 'N', Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.  LDQ >= max(1,N).\n*\n*  IFST    (input) INTEGER\n*  ILST    (input) INTEGER\n*          Specify the reordering of the diagonal elements of T:\n*          The element with row index IFST is moved to row ILST by a\n*          sequence of transpositions between adjacent elements.\n*          1 <= IFST <= N; 1 <= ILST <= N.\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*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            WANTQ\n      INTEGER            K, M1, M2, M3\n      DOUBLE PRECISION   CS\n      COMPLEX*16         SN, T11, T22, TEMP\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZLARTG, ZROT\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          DCONJG, MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, t, q = NumRu::Lapack.ztrexc( compq, t, q, ifst, ilst, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_compq = argv[0];
  rblapack_t = argv[1];
  rblapack_q = argv[2];
  rblapack_ifst = argv[3];
  rblapack_ilst = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  compq = StringValueCStr(rblapack_compq)[0];
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (3th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (3th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  n = NA_SHAPE1(rblapack_q);
  if (NA_TYPE(rblapack_q) != NA_DCOMPLEX)
    rblapack_q = na_change_type(rblapack_q, NA_DCOMPLEX);
  q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
  ilst = NUM2INT(rblapack_ilst);
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (2th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (2th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  if (NA_SHAPE1(rblapack_t) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of q");
  if (NA_TYPE(rblapack_t) != NA_DCOMPLEX)
    rblapack_t = na_change_type(rblapack_t, NA_DCOMPLEX);
  t = NA_PTR_TYPE(rblapack_t, doublecomplex*);
  ifst = NUM2INT(rblapack_ifst);
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = n;
    rblapack_t_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  t_out__ = NA_PTR_TYPE(rblapack_t_out__, doublecomplex*);
  MEMCPY(t_out__, t, doublecomplex, NA_TOTAL(rblapack_t));
  rblapack_t = rblapack_t_out__;
  t = t_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublecomplex*);
  MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;

  ztrexc_(&compq, &n, t, &ldt, q, &ldq, &ifst, &ilst, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_t, rblapack_q);
}

void
init_lapack_ztrexc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztrexc", rblapack_ztrexc, -1);
}
ruby-lapack-1.7.2/ext/csyswapr.c0000644000175000017500000000767112502221015016407 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID csyswapr_(char* uplo, integer* n, complex* a, integer* i1, integer* i2);


static VALUE
rblapack_csyswapr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_i1;
  integer i1; 
  VALUE rblapack_i2;
  integer i2; 
  VALUE rblapack_a_out__;
  complex *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  a = NumRu::Lapack.csyswapr( uplo, a, i1, i2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSYSWAPR( UPLO, N, A, I1, I2)\n\n*  Purpose\n*  =======\n*\n*  CSYSWAPR applies an elementary permutation on the rows and the columns of\n*  a symmetric matrix.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the NB diagonal matrix D and the multipliers\n*          used to obtain the factor U or L as computed by CSYTRF.\n*\n*          On exit, if INFO = 0, the (symmetric) inverse of the original\n*          matrix.  If UPLO = 'U', the upper triangular part of the\n*          inverse is formed and the part of A below the diagonal is not\n*          referenced; if UPLO = 'L' the lower triangular part of the\n*          inverse is formed and the part of A above the diagonal is\n*          not referenced.\n*\n*  I1      (input) INTEGER\n*          Index of the first row to swap\n*\n*  I2      (input) INTEGER\n*          Index of the second row to swap\n*\n\n*  =====================================================================\n*\n*     ..\n*     .. Local Scalars ..\n      LOGICAL            UPPER\n      INTEGER            I\n      COMPLEX            TMP\n*\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CSWAP\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  a = NumRu::Lapack.csyswapr( uplo, a, i1, i2, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_i1 = argv[2];
  rblapack_i2 = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  i1 = NUM2INT(rblapack_i1);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  i2 = NUM2INT(rblapack_i2);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  csyswapr_(&uplo, &n, a, &i1, &i2);

  return rblapack_a;
}

void
init_lapack_csyswapr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "csyswapr", rblapack_csyswapr, -1);
}
ruby-lapack-1.7.2/ext/chpgst.c0000644000175000017500000001161612502221022016014 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chpgst_(integer* itype, char* uplo, integer* n, complex* ap, complex* bp, integer* info);


static VALUE
rblapack_chpgst(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_bp;
  complex *bp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  complex *ap_out__;


  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  info, ap = NumRu::Lapack.chpgst( itype, uplo, n, ap, bp, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHPGST( ITYPE, UPLO, N, AP, BP, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHPGST reduces a complex Hermitian-definite generalized\n*  eigenproblem to standard form, using packed storage.\n*\n*  If ITYPE = 1, the problem is A*x = lambda*B*x,\n*  and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)\n*\n*  If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n*  B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L.\n*\n*  B must have been previously factorized as U**H*U or L*L**H by CPPTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);\n*          = 2 or 3: compute U*A*U**H or L**H*A*L.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored and B is factored as\n*                  U**H*U;\n*          = 'L':  Lower triangle of A is stored and B is factored as\n*                  L*L**H.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, if INFO = 0, the transformed matrix, stored in the\n*          same format as A.\n*\n*  BP      (input) COMPLEX array, dimension (N*(N+1)/2)\n*          The triangular factor from the Cholesky factorization of B,\n*          stored in the same format as A, as returned by CPPTRF.\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ap = NumRu::Lapack.chpgst( itype, uplo, n, ap, bp, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_itype = argv[0];
  rblapack_uplo = argv[1];
  rblapack_n = argv[2];
  rblapack_ap = argv[3];
  rblapack_bp = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  itype = NUM2INT(rblapack_itype);
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_bp))
    rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
  if (NA_RANK(rblapack_bp) != 1)
    rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_bp) != NA_SCOMPLEX)
    rblapack_bp = na_change_type(rblapack_bp, NA_SCOMPLEX);
  bp = NA_PTR_TYPE(rblapack_bp, complex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
  MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  chpgst_(&itype, &uplo, &n, ap, bp, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ap);
}

void
init_lapack_chpgst(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chpgst", rblapack_chpgst, -1);
}
ruby-lapack-1.7.2/ext/lsamen.c0000644000175000017500000000502412502221022015777 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern logical lsamen_(integer* n, char* ca, char* cb);


static VALUE
rblapack_lsamen(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ca;
  char *ca; 
  VALUE rblapack_cb;
  char *cb; 
  VALUE rblapack___out__;
  logical __out__; 


  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  __out__ = NumRu::Lapack.lsamen( n, ca, cb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      LOGICAL          FUNCTION LSAMEN( N, CA, CB )\n\n*  Purpose\n*  =======\n*\n*  LSAMEN  tests if the first N letters of CA are the same as the\n*  first N letters of CB, regardless of case.\n*  LSAMEN returns .TRUE. if CA and CB are equivalent except for case\n*  and .FALSE. otherwise.  LSAMEN also returns .FALSE. if LEN( CA )\n*  or LEN( CB ) is less than N.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of characters in CA and CB to be compared.\n*\n*  CA      (input) CHARACTER*(*)\n*  CB      (input) CHARACTER*(*)\n*          CA and CB specify two character strings of length at least N.\n*          Only the first N characters of each string will be accessed.\n*\n\n* =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          LEN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.lsamen( n, ca, cb, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_n = argv[0];
  rblapack_ca = argv[1];
  rblapack_cb = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  cb = StringValueCStr(rblapack_cb);
  ca = StringValueCStr(rblapack_ca);

  __out__ = lsamen_(&n, ca, cb);

  rblapack___out__ = __out__ ? Qtrue : Qfalse;
  return rblapack___out__;
}

void
init_lapack_lsamen(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "lsamen", rblapack_lsamen, -1);
}
ruby-lapack-1.7.2/ext/cspsv.c0000644000175000017500000001637012502221024015666 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cspsv_(char* uplo, integer* n, integer* nrhs, complex* ap, integer* ipiv, complex* b, integer* ldb, integer* info);


static VALUE
rblapack_cspsv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  complex *ap_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer ldb;
  integer nrhs;
  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  ipiv, info, ap, b = NumRu::Lapack.cspsv( uplo, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  CSPSV computes the solution to a complex system of linear equations\n*     A * X = B,\n*  where A is an N-by-N symmetric matrix stored in packed format and X\n*  and B are N-by-NRHS matrices.\n*\n*  The diagonal pivoting method is used to factor A as\n*     A = U * D * U**T,  if UPLO = 'U', or\n*     A = L * D * L**T,  if UPLO = 'L',\n*  where U (or L) is a product of permutation and unit upper (lower)\n*  triangular matrices, D is symmetric and block diagonal with 1-by-1\n*  and 2-by-2 diagonal blocks.  The factored form of A is then used to\n*  solve the system of equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          See below for further details.\n*\n*          On exit, the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L from the factorization\n*          A = U*D*U**T or A = L*D*L**T as computed by CSPTRF, stored as\n*          a packed triangular matrix in the same storage format as A.\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D, as\n*          determined by CSPTRF.  If IPIV(k) > 0, then rows and columns\n*          k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n*          diagonal block.  If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n*          then rows and columns k-1 and -IPIV(k) were interchanged and\n*          D(k-1:k,k-1:k) is a 2-by-2 diagonal block.  If UPLO = 'L' and\n*          IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n*          -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n*          diagonal block.\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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, D(i,i) is exactly zero.  The factorization\n*                has been completed, but the block diagonal matrix D is\n*                exactly singular, so the solution could not be\n*                computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  The packed storage scheme is illustrated by the following example\n*  when N = 4, UPLO = 'U':\n*\n*  Two-dimensional storage of the symmetric matrix A:\n*\n*     a11 a12 a13 a14\n*         a22 a23 a24\n*             a33 a34     (aij = aji)\n*                 a44\n*\n*  Packed storage of the upper triangle of A:\n*\n*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n*  =====================================================================\n*\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CSPTRF, CSPTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, ap, b = NumRu::Lapack.cspsv( uplo, ap, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_b = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  n = ldb;
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
  MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  cspsv_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ipiv, rblapack_info, rblapack_ap, rblapack_b);
}

void
init_lapack_cspsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cspsv", rblapack_cspsv, -1);
}
ruby-lapack-1.7.2/ext/zsytf2.c0000644000175000017500000001607512502221024015773 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zsytf2_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* ipiv, integer* info);


static VALUE
rblapack_zsytf2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *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  ipiv, info, a = NumRu::Lapack.zsytf2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSYTF2( UPLO, N, A, LDA, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZSYTF2 computes the factorization of a complex symmetric matrix A\n*  using the Bunch-Kaufman diagonal pivoting method:\n*\n*     A = U*D*U'  or  A = L*D*L'\n*\n*  where U (or L) is a product of permutation and unit upper (lower)\n*  triangular matrices, U' is the transpose of U, and D is symmetric and\n*  block diagonal with 1-by-1 and 2-by-2 diagonal blocks.\n*\n*  This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored:\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          n-by-n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n-by-n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L (see below for further details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D.\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*          > 0: if INFO = k, D(k,k) is exactly zero.  The factorization\n*               has been completed, but the block diagonal matrix D is\n*               exactly singular, and division by zero will occur if it\n*               is used to solve a system of equations.\n*\n\n*  Further Details\n*  ===============\n*\n*  09-29-06 - patch from\n*    Bobby Cheng, MathWorks\n*\n*    Replace l.209 and l.377\n*         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN\n*    by\n*         IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN\n*\n*  1-96 - Based on modifications by J. Lewis, Boeing Computer Services\n*         Company\n*\n*  If UPLO = 'U', then A = U*D*U', where\n*     U = P(n)*U(n)* ... *P(k)U(k)* ...,\n*  i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n*  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    v    0   )   k-s\n*     U(k) =  (   0    I    0   )   s\n*             (   0    0    I   )   n-k\n*                k-s   s   n-k\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n*  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n*  and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n*  If UPLO = 'L', then A = L*D*L', where\n*     L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n*  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n*  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    0     0   )  k-1\n*     L(k) =  (   0    I     0   )  s\n*             (   0    v     I   )  n-k-s+1\n*                k-1   s  n-k-s+1\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n*  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n*  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, a = NumRu::Lapack.zsytf2( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zsytf2_(&uplo, &n, a, &lda, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_a);
}

void
init_lapack_zsytf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zsytf2", rblapack_zsytf2, -1);
}
ruby-lapack-1.7.2/ext/dlansf.c0000644000175000017500000001730412502221024015775 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal dlansf_(char* norm, char* transr, char* uplo, integer* n, doublereal* a, doublereal* work);


static VALUE
rblapack_dlansf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack___out__;
  doublereal __out__; 
  doublereal *work;

  integer lwork;

  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  __out__ = NumRu::Lapack.dlansf( norm, transr, uplo, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION DLANSF( NORM, TRANSR, UPLO, N, A, WORK )\n\n*  Purpose\n*  =======\n*\n*  DLANSF returns the value of the one norm, or the Frobenius norm, or\n*  the infinity norm, or the element of largest absolute value of a\n*  real symmetric matrix A in RFP format.\n*\n*  Description\n*  ===========\n*\n*  DLANSF returns the value\n*\n*     DLANSF = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a  matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in DLANSF as described\n*          above.\n*\n*  TRANSR  (input) CHARACTER*1\n*          Specifies whether the RFP format of A is normal or\n*          transposed format.\n*          = 'N':  RFP format is Normal;\n*          = 'T':  RFP format is Transpose.\n*\n*  UPLO    (input) CHARACTER*1\n*           On entry, UPLO specifies whether the RFP matrix A came from\n*           an upper or lower triangular matrix as follows:\n*           = 'U': RFP A came from an upper triangular matrix;\n*           = 'L': RFP A came from a lower triangular matrix.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0. When N = 0, DLANSF is\n*          set to zero.\n*\n*  A       (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 );\n*          On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')\n*          part of the symmetric matrix A stored in RFP format. See the\n*          \"Notes\" below for more details.\n*          Unchanged on exit.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n*          WORK is not referenced.\n*\n\n*  Further Details\n*  ===============\n*\n*  We first consider Rectangular Full Packed (RFP) Format when N is\n*  even. We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  the transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  the transpose of the last three columns of AP lower.\n*  This covers the case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        03 04 05                33 43 53\n*        13 14 15                00 44 54\n*        23 24 25                10 11 55\n*        33 34 35                20 21 22\n*        00 44 45                30 31 32\n*        01 11 55                40 41 42\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We then consider Rectangular Full Packed (RFP) Format when N is\n*  odd. We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  the transpose of the first two columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  the transpose of the last two columns of AP lower.\n*  This covers the case N odd and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        02 03 04                00 33 43\n*        12 13 14                10 11 44\n*        22 23 24                20 21 22\n*        00 33 34                30 31 32\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*           RFP A                   RFP A\n*\n*     02 12 22 00 01             00 10 20 30 40 50\n*     03 13 23 33 11             33 11 21 31 41 51\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  Reference\n*  =========\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.dlansf( norm, transr, uplo, n, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_norm = argv[0];
  rblapack_transr = argv[1];
  rblapack_uplo = argv[2];
  rblapack_n = argv[3];
  rblapack_a = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  transr = StringValueCStr(rblapack_transr)[0];
  n = NUM2INT(rblapack_n);
  lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 1)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  work = ALLOC_N(doublereal, (MAX(1,lwork)));

  __out__ = dlansf_(&norm, &transr, &uplo, &n, a, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_dlansf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlansf", rblapack_dlansf, -1);
}
ruby-lapack-1.7.2/ext/zpbstf.c0000644000175000017500000001311112502221024016026 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zpbstf_(char* uplo, integer* n, integer* kd, doublecomplex* ab, integer* ldab, integer* info);


static VALUE
rblapack_zpbstf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublecomplex *ab_out__;

  integer ldab;
  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  info, ab = NumRu::Lapack.zpbstf( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPBSTF( UPLO, N, KD, AB, LDAB, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPBSTF computes a split Cholesky factorization of a complex\n*  Hermitian positive definite band matrix A.\n*\n*  This routine is designed to be used in conjunction with ZHBGST.\n*\n*  The factorization has the form  A = S**H*S  where S is a band matrix\n*  of the same bandwidth as A and the following structure:\n*\n*    S = ( U    )\n*        ( M  L )\n*\n*  where U is upper triangular of order m = (n+kd)/2, and L is lower\n*  triangular of order n-m.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix A, stored in the first kd+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*          On exit, if INFO = 0, the factor S from the split Cholesky\n*          factorization A = S**H*S. See Further Details.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\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 factorization could not be completed,\n*               because the updated element a(i,i) was negative; the\n*               matrix A is not positive definite.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  N = 7, KD = 2:\n*\n*  S = ( s11  s12  s13                     )\n*      (      s22  s23  s24                )\n*      (           s33  s34                )\n*      (                s44                )\n*      (           s53  s54  s55           )\n*      (                s64  s65  s66      )\n*      (                     s75  s76  s77 )\n*\n*  If UPLO = 'U', the array AB holds:\n*\n*  on entry:                          on exit:\n*\n*   *    *   a13  a24  a35  a46  a57   *    *   s13  s24  s53' s64' s75'\n*   *   a12  a23  a34  a45  a56  a67   *   s12  s23  s34  s54' s65' s76'\n*  a11  a22  a33  a44  a55  a66  a77  s11  s22  s33  s44  s55  s66  s77\n*\n*  If UPLO = 'L', the array AB holds:\n*\n*  on entry:                          on exit:\n*\n*  a11  a22  a33  a44  a55  a66  a77  s11  s22  s33  s44  s55  s66  s77\n*  a21  a32  a43  a54  a65  a76   *   s12' s23' s34' s54  s65  s76   *\n*  a31  a42  a53  a64  a64   *    *   s13' s24' s53  s64  s75   *    *\n*\n*  Array elements marked * are not used by the routine; s12' denotes\n*  conjg(s12); the diagonal elements of S are real.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ab = NumRu::Lapack.zpbstf( uplo, kd, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  kd = NUM2INT(rblapack_kd);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
  MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  zpbstf_(&uplo, &n, &kd, ab, &ldab, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ab);
}

void
init_lapack_zpbstf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zpbstf", rblapack_zpbstf, -1);
}
ruby-lapack-1.7.2/ext/csytri2x.c0000644000175000017500000001157412502221016016321 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID csytri2x_(char* uplo, integer* n, complex* a, integer* lda, integer* ipiv, complex* work, integer* nb, integer* info);


static VALUE
rblapack_csytri2x(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_nb;
  integer nb; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  complex *work;

  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  info, a = NumRu::Lapack.csytri2x( uplo, a, ipiv, nb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO )\n\n*  Purpose\n*  =======\n*\n*  CSYTRI2X computes the inverse of a real symmetric indefinite matrix\n*  A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n*  CSYTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the NNB diagonal matrix D and the multipliers\n*          used to obtain the factor U or L as computed by CSYTRF.\n*\n*          On exit, if INFO = 0, the (symmetric) inverse of the original\n*          matrix.  If UPLO = 'U', the upper triangular part of the\n*          inverse is formed and the part of A below the diagonal is not\n*          referenced; if UPLO = 'L' the lower triangular part of the\n*          inverse is formed and the part of A above the diagonal is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the NNB structure of D\n*          as determined by CSYTRF.\n*\n*  WORK    (workspace) COMPLEX array, dimension (N+NNB+1,NNB+3)\n*\n*  NB      (input) INTEGER\n*          Block size\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, D(i,i) = 0; the matrix is singular and its\n*               inverse could not be computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.csytri2x( uplo, a, ipiv, nb, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_nb = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  nb = NUM2INT(rblapack_nb);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(complex, (n+nb+1)*(nb+3));

  csytri2x_(&uplo, &n, a, &lda, ipiv, work, &nb, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_csytri2x(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "csytri2x", rblapack_csytri2x, -1);
}
ruby-lapack-1.7.2/ext/cgelsx.c0000644000175000017500000002045412502221025016014 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgelsx_(integer* m, integer* n, integer* nrhs, complex* a, integer* lda, complex* b, integer* ldb, integer* jpvt, real* rcond, integer* rank, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cgelsx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_jpvt;
  integer *jpvt; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_rank;
  integer rank; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;
  VALUE rblapack_jpvt_out__;
  integer *jpvt_out__;
  complex *work;
  real *rwork;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  rank, info, a, b, jpvt = NumRu::Lapack.cgelsx( m, a, b, jpvt, rcond, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  This routine is deprecated and has been replaced by routine CGELSY.\n*\n*  CGELSX computes the minimum-norm solution to a complex linear least\n*  squares problem:\n*      minimize || A * X - B ||\n*  using a complete orthogonal factorization of A.  A is an M-by-N\n*  matrix which may be rank-deficient.\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*  The routine first computes a QR factorization with column pivoting:\n*      A * P = Q * [ R11 R12 ]\n*                  [  0  R22 ]\n*  with R11 defined as the largest leading submatrix whose estimated\n*  condition number is less than 1/RCOND.  The order of R11, RANK,\n*  is the effective rank of A.\n*\n*  Then, R22 is considered to be negligible, and R12 is annihilated\n*  by unitary transformations from the right, arriving at the\n*  complete orthogonal factorization:\n*     A * P = Q * [ T11 0 ] * Z\n*                 [  0  0 ]\n*  The minimum-norm solution is then\n*     X = P * Z' [ inv(T11)*Q1'*B ]\n*                [        0       ]\n*  where Q1 consists of the first RANK columns of 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*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of\n*          columns of matrices B and X. NRHS >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, A has been overwritten by details of its\n*          complete orthogonal factorization.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the M-by-NRHS right hand side matrix B.\n*          On exit, the N-by-NRHS solution matrix X.\n*          If m >= n and RANK = n, the residual sum-of-squares for\n*          the solution in the i-th column is given by the sum of\n*          squares of elements N+1:M in that column.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,M,N).\n*\n*  JPVT    (input/output) INTEGER array, dimension (N)\n*          On entry, if JPVT(i) .ne. 0, the i-th column of A is an\n*          initial column, otherwise it is a free column.  Before\n*          the QR factorization of A, all initial columns are\n*          permuted to the leading positions; only the remaining\n*          free columns are moved as a result of column pivoting\n*          during the factorization.\n*          On exit, if JPVT(i) = k, then the i-th column of A*P\n*          was the k-th column of A.\n*\n*  RCOND   (input) REAL\n*          RCOND is used to determine the effective rank of A, which\n*          is defined as the order of the largest leading triangular\n*          submatrix R11 in the QR factorization with pivoting of A,\n*          whose estimated condition number < 1/RCOND.\n*\n*  RANK    (output) INTEGER\n*          The effective rank of A, i.e., the order of the submatrix\n*          R11.  This is the same as the order of the submatrix T11\n*          in the complete orthogonal factorization of A.\n*\n*  WORK    (workspace) COMPLEX array, dimension\n*                      (min(M,N) + max( N, 2*min(M,N)+NRHS )),\n*\n*  RWORK   (workspace) REAL array, dimension (2*N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rank, info, a, b, jpvt = NumRu::Lapack.cgelsx( m, a, b, jpvt, rcond, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  rblapack_b = argv[2];
  rblapack_jpvt = argv[3];
  rblapack_rcond = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  rcond = (real)NUM2DBL(rblapack_rcond);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_jpvt))
    rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
  if (NA_RANK(rblapack_jpvt) != 1)
    rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_jpvt) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_jpvt) != NA_LINT)
    rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
  jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
  MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
  rblapack_jpvt = rblapack_jpvt_out__;
  jpvt = jpvt_out__;
  work = ALLOC_N(complex, (MIN(m,n) + MAX(n,2*(MIN(m,n))+nrhs)));
  rwork = ALLOC_N(real, (2*n));

  cgelsx_(&m, &n, &nrhs, a, &lda, b, &ldb, jpvt, &rcond, &rank, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rank = INT2NUM(rank);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_rank, rblapack_info, rblapack_a, rblapack_b, rblapack_jpvt);
}

void
init_lapack_cgelsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgelsx", rblapack_cgelsx, -1);
}
ruby-lapack-1.7.2/ext/cunmhr.c0000644000175000017500000002012612502221022016014 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cunmhr_(char* side, char* trans, integer* m, integer* n, integer* ilo, integer* ihi, complex* a, integer* lda, complex* tau, complex* c, integer* ldc, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_cunmhr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_c;
  complex *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  complex *c_out__;

  integer lda;
  integer m;
  integer ldc;
  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  work, info, c = NumRu::Lapack.cunmhr( side, trans, ilo, ihi, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CUNMHR overwrites the general complex M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'C':      Q**H * C       C * Q**H\n*\n*  where Q is a complex unitary matrix of order nq, with nq = m if\n*  SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of\n*  IHI-ILO elementary reflectors, as returned by CGEHRD:\n*\n*  Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**H from the Left;\n*          = 'R': apply Q or Q**H from the Right.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': apply Q  (No transpose)\n*          = 'C': apply Q**H (Conjugate transpose)\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          ILO and IHI must have the same values as in the previous call\n*          of CGEHRD. Q is equal to the unit matrix except in the\n*          submatrix Q(ilo+1:ihi,ilo+1:ihi).\n*          If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and\n*          ILO = 1 and IHI = 0, if M = 0;\n*          if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and\n*          ILO = 1 and IHI = 0, if N = 0.\n*\n*  A       (input) COMPLEX array, dimension\n*                               (LDA,M) if SIDE = 'L'\n*                               (LDA,N) if SIDE = 'R'\n*          The vectors which define the elementary reflectors, as\n*          returned by CGEHRD.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*          LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n*\n*  TAU     (input) COMPLEX array, dimension\n*                               (M-1) if SIDE = 'L'\n*                               (N-1) if SIDE = 'R'\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by CGEHRD.\n*\n*  C       (input/output) COMPLEX array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace/output) COMPLEX 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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M).\n*          For optimum performance LWORK >= N*NB if SIDE = 'L', and\n*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n*          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*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LEFT, LQUERY\n      INTEGER            I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            ILAENV\n      EXTERNAL           ILAENV, LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CUNMQR, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.cunmhr( side, trans, ilo, ihi, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_ilo = argv[2];
  rblapack_ihi = argv[3];
  rblapack_a = argv[4];
  rblapack_tau = argv[5];
  rblapack_c = argv[6];
  if (argc == 8) {
    rblapack_lwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  side = StringValueCStr(rblapack_side)[0];
  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, complex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (6th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_tau) != (m-1))
    rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", m-1);
  if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  ihi = NUM2INT(rblapack_ihi);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
  MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  cunmhr_(&side, &trans, &m, &n, &ilo, &ihi, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_cunmhr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cunmhr", rblapack_cunmhr, -1);
}
ruby-lapack-1.7.2/ext/ssygs2.c0000644000175000017500000001206512502221016015760 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssygs2_(integer* itype, char* uplo, integer* n, real* a, integer* lda, real* b, integer* ldb, integer* info);


static VALUE
rblapack_ssygs2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;

  integer lda;
  integer n;
  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  info, a = NumRu::Lapack.ssygs2( itype, uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSYGS2 reduces a real symmetric-definite generalized eigenproblem\n*  to standard form.\n*\n*  If ITYPE = 1, the problem is A*x = lambda*B*x,\n*  and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')\n*\n*  If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n*  B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.\n*\n*  B must have been previously factorized as U'*U or L*L' by SPOTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');\n*          = 2 or 3: compute U*A*U' or L'*A*L.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored, and how B has been factorized.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          n by n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n by n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the transformed matrix, stored in the\n*          same format as A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input) REAL array, dimension (LDB,N)\n*          The triangular factor from the Cholesky factorization of B,\n*          as returned by SPOTRF.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.ssygs2( itype, uplo, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_itype = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  itype = NUM2INT(rblapack_itype);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  ssygs2_(&itype, &uplo, &n, a, &lda, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_ssygs2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssygs2", rblapack_ssygs2, -1);
}
ruby-lapack-1.7.2/ext/dpbsvx.c0000644000175000017500000004047012502221023016033 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dpbsvx_(char* fact, char* uplo, integer* n, integer* kd, integer* nrhs, doublereal* ab, integer* ldab, doublereal* afb, integer* ldafb, char* equed, doublereal* s, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dpbsvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_afb;
  doublereal *afb; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublereal *ab_out__;
  VALUE rblapack_afb_out__;
  doublereal *afb_out__;
  VALUE rblapack_s_out__;
  doublereal *s_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;
  doublereal *work;
  integer *iwork;

  integer ldab;
  integer n;
  integer ldafb;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, info, ab, afb, equed, s, b = NumRu::Lapack.dpbsvx( fact, uplo, kd, ab, afb, equed, s, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPBSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to\n*  compute the solution to a real system of linear equations\n*     A * X = B,\n*  where A is an N-by-N symmetric positive definite band matrix and X\n*  and B are N-by-NRHS matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'E', real scaling factors are computed to equilibrate\n*     the system:\n*        diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n*  2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n*     factor the matrix A (after equilibration if FACT = 'E') as\n*        A = U**T * U,  if UPLO = 'U', or\n*        A = L * L**T,  if UPLO = 'L',\n*     where U is an upper triangular band matrix, and L is a lower\n*     triangular band matrix.\n*\n*  3. If the leading i-by-i principal minor is not positive definite,\n*     then the routine returns with INFO = i. Otherwise, the factored\n*     form of A is used to estimate the condition number of the matrix\n*     A.  If the reciprocal of the condition number is less than machine\n*     precision, INFO = N+1 is returned as a warning, but the routine\n*     still goes on to solve for X and compute error bounds as\n*     described below.\n*\n*  4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  5. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n*  6. If equilibration was used, the matrix X is premultiplied by\n*     diag(S) so that it solves the original system before\n*     equilibration.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of the matrix A is\n*          supplied on entry, and if not, whether the matrix A should be\n*          equilibrated before it is factored.\n*          = 'F':  On entry, AFB contains the factored form of A.\n*                  If EQUED = 'Y', the matrix A has been equilibrated\n*                  with scaling factors given by S.  AB and AFB will not\n*                  be modified.\n*          = 'N':  The matrix A will be copied to AFB and factored.\n*          = 'E':  The matrix A will be equilibrated if necessary, then\n*                  copied to AFB and factored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right-hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first KD+1 rows of the array, except\n*          if FACT = 'F' and EQUED = 'Y', then A must contain the\n*          equilibrated matrix diag(S)*A*diag(S).  The j-th column of A\n*          is stored in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(N,j+KD).\n*          See below for further details.\n*\n*          On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n*          diag(S)*A*diag(S).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array A.  LDAB >= KD+1.\n*\n*  AFB     (input or output) DOUBLE PRECISION array, dimension (LDAFB,N)\n*          If FACT = 'F', then AFB is an input argument and on entry\n*          contains the triangular factor U or L from the Cholesky\n*          factorization A = U**T*U or A = L*L**T of the band matrix\n*          A, in the same storage format as A (see AB).  If EQUED = 'Y',\n*          then AFB is the factored form of the equilibrated matrix A.\n*\n*          If FACT = 'N', then AFB is an output argument and on exit\n*          returns the triangular factor U or L from the Cholesky\n*          factorization A = U**T*U or A = L*L**T.\n*\n*          If FACT = 'E', then AFB is an output argument and on exit\n*          returns the triangular factor U or L from the Cholesky\n*          factorization A = U**T*U or A = L*L**T of the equilibrated\n*          matrix A (see the description of A for the form of the\n*          equilibrated matrix).\n*\n*  LDAFB   (input) INTEGER\n*          The leading dimension of the array AFB.  LDAFB >= KD+1.\n*\n*  EQUED   (input or output) CHARACTER*1\n*          Specifies the form of equilibration that was done.\n*          = 'N':  No equilibration (always true if FACT = 'N').\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*          EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*          output argument.\n*\n*  S       (input or output) DOUBLE PRECISION array, dimension (N)\n*          The scale factors for A; not accessed if EQUED = 'N'.  S is\n*          an input argument if FACT = 'F'; otherwise, S is an output\n*          argument.  If FACT = 'F' and EQUED = 'Y', each element of S\n*          must be positive.\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n*          B is overwritten by diag(S) * B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n*          the original system of equations.  Note that if EQUED = 'Y',\n*          A and B are modified on exit, and the solution to the\n*          equilibrated system is inv(diag(S))*X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The estimate of the reciprocal condition number of the matrix\n*          A after equilibration (if done).  If RCOND is less than the\n*          machine precision (in particular, if RCOND = 0), the matrix\n*          is singular to working precision.  This condition is\n*          indicated by a return code of INFO > 0.\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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, and i is\n*                <= N:  the leading minor of order i of A is\n*                       not positive definite, so the factorization\n*                       could not be completed, and the solution has not\n*                       been computed. RCOND = 0 is returned.\n*                = N+1: U is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  N = 6, KD = 2, and UPLO = 'U':\n*\n*  Two-dimensional storage of the symmetric matrix A:\n*\n*     a11  a12  a13\n*          a22  a23  a24\n*               a33  a34  a35\n*                    a44  a45  a46\n*                         a55  a56\n*     (aij=conjg(aji))         a66\n*\n*  Band storage of the upper triangle of A:\n*\n*      *    *   a13  a24  a35  a46\n*      *   a12  a23  a34  a45  a56\n*     a11  a22  a33  a44  a55  a66\n*\n*  Similarly, if UPLO = 'L' the format of A is as follows:\n*\n*     a11  a22  a33  a44  a55  a66\n*     a21  a32  a43  a54  a65   *\n*     a31  a42  a53  a64   *    *\n*\n*  Array elements marked * are not used by the routine.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, info, ab, afb, equed, s, b = NumRu::Lapack.dpbsvx( fact, uplo, kd, ab, afb, equed, s, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_kd = argv[2];
  rblapack_ab = argv[3];
  rblapack_afb = argv[4];
  rblapack_equed = argv[5];
  rblapack_s = argv[6];
  rblapack_b = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  kd = NUM2INT(rblapack_kd);
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
  ldafb = NA_SHAPE0(rblapack_afb);
  n = NA_SHAPE1(rblapack_afb);
  if (NA_TYPE(rblapack_afb) != NA_DFLOAT)
    rblapack_afb = na_change_type(rblapack_afb, NA_DFLOAT);
  afb = NA_PTR_TYPE(rblapack_afb, doublereal*);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (7th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  ldx = MAX(1,n);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
  MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldafb;
    shape[1] = n;
    rblapack_afb_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  afb_out__ = NA_PTR_TYPE(rblapack_afb_out__, doublereal*);
  MEMCPY(afb_out__, afb, doublereal, NA_TOTAL(rblapack_afb));
  rblapack_afb = rblapack_afb_out__;
  afb = afb_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
  MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(doublereal, (3*n));
  iwork = ALLOC_N(integer, (n));

  dpbsvx_(&fact, &uplo, &n, &kd, &nrhs, ab, &ldab, afb, &ldafb, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_ab, rblapack_afb, rblapack_equed, rblapack_s, rblapack_b);
}

void
init_lapack_dpbsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dpbsvx", rblapack_dpbsvx, -1);
}
ruby-lapack-1.7.2/ext/cgeql2.c0000644000175000017500000001050612502221017015702 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgeql2_(integer* m, integer* n, complex* a, integer* lda, complex* tau, complex* work, integer* info);


static VALUE
rblapack_cgeql2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  complex *work;

  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, info, a = NumRu::Lapack.cgeql2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGEQL2( M, N, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGEQL2 computes a QL factorization of a complex m by n matrix A:\n*  A = Q * L.\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) COMPLEX array, dimension (LDA,N)\n*          On entry, the m by n matrix A.\n*          On exit, if m >= n, the lower triangle of the subarray\n*          A(m-n+1:m,1:n) contains the n by n lower triangular matrix L;\n*          if m <= n, the elements on and below the (n-m)-th\n*          superdiagonal contain the m by n lower trapezoidal matrix L;\n*          the remaining elements, with the array TAU, represent the\n*          unitary matrix Q as a product of elementary reflectors\n*          (see Further Details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  TAU     (output) COMPLEX array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace) COMPLEX array, dimension (N)\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 complex scalar, and v is a complex vector with\n*  v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n*  A(1:m-k+i-1,n-k+i), 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.cgeql2( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(complex, (n));

  cgeql2_(&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_cgeql2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgeql2", rblapack_cgeql2, -1);
}
ruby-lapack-1.7.2/ext/sgesv.c0000644000175000017500000001256212502221016015657 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgesv_(integer* n, integer* nrhs, real* a, integer* lda, integer* ipiv, real* b, integer* ldb, integer* info);


static VALUE
rblapack_sgesv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_b_out__;
  real *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  ipiv, info, a, b = NumRu::Lapack.sgesv( a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGESV computes the solution to a real system of linear equations\n*     A * X = B,\n*  where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n*  The LU decomposition with partial pivoting and row interchanges is\n*  used to factor A as\n*     A = P * L * U,\n*  where P is a permutation matrix, L is unit lower triangular, and U is\n*  upper triangular.  The factored form of A is then used to solve the\n*  system of equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the N-by-N coefficient matrix A.\n*          On exit, the factors L and U from the factorization\n*          A = P*L*U; the unit diagonal elements of L are not stored.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          The pivot indices that define the permutation matrix P;\n*          row i of the matrix was interchanged with row IPIV(i).\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS matrix of right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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, U(i,i) is exactly zero.  The factorization\n*                has been completed, but the factor U is exactly\n*                singular, so the solution could not be computed.\n*\n\n*  =====================================================================\n*\n*     .. External Subroutines ..\n      EXTERNAL           SGETRF, SGETRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, a, b = NumRu::Lapack.sgesv( a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  if (argc == 2) {
  } 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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  sgesv_(&n, &nrhs, a, &lda, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ipiv, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_sgesv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgesv", rblapack_sgesv, -1);
}
ruby-lapack-1.7.2/ext/clapmt.c0000644000175000017500000001064412502221020016002 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clapmt_(logical* forwrd, integer* m, integer* n, complex* x, integer* ldx, integer* k);


static VALUE
rblapack_clapmt(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_forwrd;
  logical forwrd; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_k;
  integer *k; 
  VALUE rblapack_x_out__;
  complex *x_out__;
  VALUE rblapack_k_out__;
  integer *k_out__;

  integer ldx;
  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  x, k = NumRu::Lapack.clapmt( forwrd, m, x, k, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAPMT( FORWRD, M, N, X, LDX, K )\n\n*  Purpose\n*  =======\n*\n*  CLAPMT rearranges the columns of the M by N matrix X as specified\n*  by the permutation K(1),K(2),...,K(N) of the integers 1,...,N.\n*  If FORWRD = .TRUE.,  forward permutation:\n*\n*       X(*,K(J)) is moved X(*,J) for J = 1,2,...,N.\n*\n*  If FORWRD = .FALSE., backward permutation:\n*\n*       X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N.\n*\n\n*  Arguments\n*  =========\n*\n*  FORWRD  (input) LOGICAL\n*          = .TRUE., forward permutation\n*          = .FALSE., backward permutation\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix X. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix X. N >= 0.\n*\n*  X       (input/output) COMPLEX array, dimension (LDX,N)\n*          On entry, the M by N matrix X.\n*          On exit, X contains the permuted matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X, LDX >= MAX(1,M).\n*\n*  K       (input/output) INTEGER array, dimension (N)\n*          On entry, K contains the permutation vector. K is used as\n*          internal workspace, but reset to its original value on\n*          output.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, II, J, IN\n      COMPLEX            TEMP\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, k = NumRu::Lapack.clapmt( forwrd, m, x, k, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_forwrd = argv[0];
  rblapack_m = argv[1];
  rblapack_x = argv[2];
  rblapack_k = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  forwrd = (rblapack_forwrd == Qtrue);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (3th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  n = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_k))
    rb_raise(rb_eArgError, "k (4th argument) must be NArray");
  if (NA_RANK(rblapack_k) != 1)
    rb_raise(rb_eArgError, "rank of k (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_k) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of k must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_k) != NA_LINT)
    rblapack_k = na_change_type(rblapack_k, NA_LINT);
  k = NA_PTR_TYPE(rblapack_k, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = n;
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_k_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  k_out__ = NA_PTR_TYPE(rblapack_k_out__, integer*);
  MEMCPY(k_out__, k, integer, NA_TOTAL(rblapack_k));
  rblapack_k = rblapack_k_out__;
  k = k_out__;

  clapmt_(&forwrd, &m, &n, x, &ldx, k);

  return rb_ary_new3(2, rblapack_x, rblapack_k);
}

void
init_lapack_clapmt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clapmt", rblapack_clapmt, -1);
}
ruby-lapack-1.7.2/ext/zppcon.c0000644000175000017500000001024612502221014016034 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zppcon_(char* uplo, integer* n, doublecomplex* ap, doublereal* anorm, doublereal* rcond, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zppcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_anorm;
  doublereal anorm; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_info;
  integer info; 
  doublecomplex *work;
  doublereal *rwork;

  integer ldap;
  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  rcond, info = NumRu::Lapack.zppcon( uplo, ap, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPPCON( UPLO, N, AP, ANORM, RCOND, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPPCON estimates the reciprocal of the condition number (in the\n*  1-norm) of a complex Hermitian positive definite packed matrix using\n*  the Cholesky factorization A = U**H*U or A = L*L**H computed by\n*  ZPPTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**H*U or A = L*L**H, packed columnwise in a linear\n*          array.  The j-th column of U or L is stored in the array AP\n*          as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n*  ANORM   (input) DOUBLE PRECISION\n*          The 1-norm (or infinity-norm) of the Hermitian matrix A.\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n*          estimate of the 1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.zppcon( uplo, ap, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_anorm = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  anorm = NUM2DBL(rblapack_anorm);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (n));

  zppcon_(&uplo, &n, ap, &anorm, &rcond, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_zppcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zppcon", rblapack_zppcon, -1);
}
ruby-lapack-1.7.2/ext/clarzt.c0000644000175000017500000001660512502221020016024 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clarzt_(char* direct, char* storev, integer* n, integer* k, complex* v, integer* ldv, complex* tau, complex* t, integer* ldt);


static VALUE
rblapack_clarzt(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_direct;
  char direct; 
  VALUE rblapack_storev;
  char storev; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_v;
  complex *v; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_t;
  complex *t; 
  VALUE rblapack_v_out__;
  complex *v_out__;

  integer ldv;
  integer k;
  integer ldt;

  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  t, v = NumRu::Lapack.clarzt( direct, storev, n, v, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n*  Purpose\n*  =======\n*\n*  CLARZT forms the triangular factor T of a complex block reflector\n*  H of order > n, which is defined as a product of k elementary\n*  reflectors.\n*\n*  If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n*\n*  If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n*\n*  If STOREV = 'C', the vector which defines the elementary reflector\n*  H(i) is stored in the i-th column of the array V, and\n*\n*     H  =  I - V * T * V'\n*\n*  If STOREV = 'R', the vector which defines the elementary reflector\n*  H(i) is stored in the i-th row of the array V, and\n*\n*     H  =  I - V' * T * V\n*\n*  Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n*\n\n*  Arguments\n*  =========\n*\n*  DIRECT  (input) CHARACTER*1\n*          Specifies the order in which the elementary reflectors are\n*          multiplied to form the block reflector:\n*          = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n*          = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n*  STOREV  (input) CHARACTER*1\n*          Specifies how the vectors which define the elementary\n*          reflectors are stored (see also Further Details):\n*          = 'C': columnwise                        (not supported yet)\n*          = 'R': rowwise\n*\n*  N       (input) INTEGER\n*          The order of the block reflector H. N >= 0.\n*\n*  K       (input) INTEGER\n*          The order of the triangular factor T (= the number of\n*          elementary reflectors). K >= 1.\n*\n*  V       (input/output) COMPLEX array, dimension\n*                               (LDV,K) if STOREV = 'C'\n*                               (LDV,N) if STOREV = 'R'\n*          The matrix V. See further details.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V.\n*          If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n*\n*  TAU     (input) COMPLEX array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i).\n*\n*  T       (output) COMPLEX array, dimension (LDT,K)\n*          The k by k triangular factor T of the block reflector.\n*          If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n*          lower triangular. The rest of the array is not used.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= K.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n*  The shape of the matrix V and the storage of the vectors which define\n*  the H(i) is best illustrated by the following example with n = 5 and\n*  k = 3. The elements equal to 1 are not stored; the corresponding\n*  array elements are modified but restored on exit. The rest of the\n*  array is not used.\n*\n*  DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R':\n*\n*                                              ______V_____\n*         ( v1 v2 v3 )                        /            \\\n*         ( v1 v2 v3 )                      ( v1 v1 v1 v1 v1 . . . . 1 )\n*     V = ( v1 v2 v3 )                      ( v2 v2 v2 v2 v2 . . . 1   )\n*         ( v1 v2 v3 )                      ( v3 v3 v3 v3 v3 . . 1     )\n*         ( v1 v2 v3 )\n*            .  .  .\n*            .  .  .\n*            1  .  .\n*               1  .\n*                  1\n*\n*  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R':\n*\n*                                                        ______V_____\n*            1                                          /            \\\n*            .  1                           ( 1 . . . . v1 v1 v1 v1 v1 )\n*            .  .  1                        ( . 1 . . . v2 v2 v2 v2 v2 )\n*            .  .  .                        ( . . 1 . . v3 v3 v3 v3 v3 )\n*            .  .  .\n*         ( v1 v2 v3 )\n*         ( v1 v2 v3 )\n*     V = ( v1 v2 v3 )\n*         ( v1 v2 v3 )\n*         ( v1 v2 v3 )\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  t, v = NumRu::Lapack.clarzt( direct, storev, n, v, tau, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_direct = argv[0];
  rblapack_storev = argv[1];
  rblapack_n = argv[2];
  rblapack_v = argv[3];
  rblapack_tau = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  direct = StringValueCStr(rblapack_direct)[0];
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  storev = StringValueCStr(rblapack_storev)[0];
  ldt = k;
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (4th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  if (NA_SHAPE1(rblapack_v) != (lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0))
    rb_raise(rb_eRuntimeError, "shape 1 of v must be %d", lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0);
  if (NA_TYPE(rblapack_v) != NA_SCOMPLEX)
    rblapack_v = na_change_type(rblapack_v, NA_SCOMPLEX);
  v = NA_PTR_TYPE(rblapack_v, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = k;
    rblapack_t = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  t = NA_PTR_TYPE(rblapack_t, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0;
    rblapack_v_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  v_out__ = NA_PTR_TYPE(rblapack_v_out__, complex*);
  MEMCPY(v_out__, v, complex, NA_TOTAL(rblapack_v));
  rblapack_v = rblapack_v_out__;
  v = v_out__;

  clarzt_(&direct, &storev, &n, &k, v, &ldv, tau, t, &ldt);

  return rb_ary_new3(2, rblapack_t, rblapack_v);
}

void
init_lapack_clarzt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clarzt", rblapack_clarzt, -1);
}
ruby-lapack-1.7.2/ext/zggesx.c0000644000175000017500000004045112502221015016034 0ustar  uwabamiuwabami#include "rb_lapack.h"

static logical
rblapack_selctg(doublecomplex *arg0, doublecomplex *arg1){
  VALUE rblapack_arg0, rblapack_arg1;

  VALUE rblapack_ret;
  logical ret;

  rblapack_arg0 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg0->r)), rb_float_new((double)(arg0->i)));
  rblapack_arg1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg1->r)), rb_float_new((double)(arg1->i)));

  rblapack_ret = rb_yield_values(2, rblapack_arg0, rblapack_arg1);

  ret = (rblapack_ret == Qtrue);
  return ret;
}

extern VOID zggesx_(char* jobvsl, char* jobvsr, char* sort, L_fp selctg, char* sense, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, integer* sdim, doublecomplex* alpha, doublecomplex* beta, doublecomplex* vsl, integer* ldvsl, doublecomplex* vsr, integer* ldvsr, doublereal* rconde, doublereal* rcondv, doublecomplex* work, integer* lwork, doublereal* rwork, integer* iwork, integer* liwork, logical* bwork, integer* info);


static VALUE
rblapack_zggesx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvsl;
  char jobvsl; 
  VALUE rblapack_jobvsr;
  char jobvsr; 
  VALUE rblapack_sort;
  char sort; 
  VALUE rblapack_sense;
  char sense; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_sdim;
  integer sdim; 
  VALUE rblapack_alpha;
  doublecomplex *alpha; 
  VALUE rblapack_beta;
  doublecomplex *beta; 
  VALUE rblapack_vsl;
  doublecomplex *vsl; 
  VALUE rblapack_vsr;
  doublecomplex *vsr; 
  VALUE rblapack_rconde;
  doublereal *rconde; 
  VALUE rblapack_rcondv;
  doublereal *rcondv; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  doublereal *rwork;
  logical *bwork;

  integer lda;
  integer n;
  integer ldb;
  integer ldvsl;
  integer ldvsr;

  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  sdim, alpha, beta, vsl, vsr, rconde, rcondv, work, iwork, info, a, b = NumRu::Lapack.zggesx( jobvsl, jobvsr, sort, sense, a, b, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help]){|a,b| ... }\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, B, LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, RWORK, IWORK, LIWORK, BWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGGESX computes for a pair of N-by-N complex nonsymmetric matrices\n*  (A,B), the generalized eigenvalues, the complex Schur form (S,T),\n*  and, optionally, the left and/or right matrices of Schur vectors (VSL\n*  and VSR).  This gives the generalized Schur factorization\n*\n*       (A,B) = ( (VSL) S (VSR)**H, (VSL) T (VSR)**H )\n*\n*  where (VSR)**H is the conjugate-transpose of VSR.\n*\n*  Optionally, it also orders the eigenvalues so that a selected cluster\n*  of eigenvalues appears in the leading diagonal blocks of the upper\n*  triangular matrix S and the upper triangular matrix T; computes\n*  a reciprocal condition number for the average of the selected\n*  eigenvalues (RCONDE); and computes a reciprocal condition number for\n*  the right and left deflating subspaces corresponding to the selected\n*  eigenvalues (RCONDV). The leading columns of VSL and VSR then form\n*  an orthonormal basis for the corresponding left and right eigenspaces\n*  (deflating subspaces).\n*\n*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n*  or a ratio alpha/beta = w, such that  A - w*B is singular.  It is\n*  usually represented as the pair (alpha,beta), as there is a\n*  reasonable interpretation for beta=0 or for both being zero.\n*\n*  A pair of matrices (S,T) is in generalized complex Schur form if T is\n*  upper triangular with non-negative diagonal and S is upper\n*  triangular.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVSL  (input) CHARACTER*1\n*          = 'N':  do not compute the left Schur vectors;\n*          = 'V':  compute the left Schur vectors.\n*\n*  JOBVSR  (input) CHARACTER*1\n*          = 'N':  do not compute the right Schur vectors;\n*          = 'V':  compute the right Schur vectors.\n*\n*  SORT    (input) CHARACTER*1\n*          Specifies whether or not to order the eigenvalues on the\n*          diagonal of the generalized Schur form.\n*          = 'N':  Eigenvalues are not ordered;\n*          = 'S':  Eigenvalues are ordered (see SELCTG).\n*\n*  SELCTG  (external procedure) LOGICAL FUNCTION of two COMPLEX*16 arguments\n*          SELCTG must be declared EXTERNAL in the calling subroutine.\n*          If SORT = 'N', SELCTG is not referenced.\n*          If SORT = 'S', SELCTG is used to select eigenvalues to sort\n*          to the top left of the Schur form.\n*          Note that a selected complex eigenvalue may no longer satisfy\n*          SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since\n*          ordering may change the value of complex eigenvalues\n*          (especially if the eigenvalue is ill-conditioned), in this\n*          case INFO is set to N+3 see INFO below).\n*\n*  SENSE   (input) CHARACTER*1\n*          Determines which reciprocal condition numbers are computed.\n*          = 'N' : None are computed;\n*          = 'E' : Computed for average of selected eigenvalues only;\n*          = 'V' : Computed for selected deflating subspaces only;\n*          = 'B' : Computed for both.\n*          If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A, B, VSL, and VSR.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA, N)\n*          On entry, the first of the pair of matrices.\n*          On exit, A has been overwritten by its generalized Schur\n*          form S.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of A.  LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB, N)\n*          On entry, the second of the pair of matrices.\n*          On exit, B has been overwritten by its generalized Schur\n*          form T.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of B.  LDB >= max(1,N).\n*\n*  SDIM    (output) INTEGER\n*          If SORT = 'N', SDIM = 0.\n*          If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n*          for which SELCTG is true.\n*\n*  ALPHA   (output) COMPLEX*16 array, dimension (N)\n*  BETA    (output) COMPLEX*16 array, dimension (N)\n*          On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the\n*          generalized eigenvalues.  ALPHA(j) and BETA(j),j=1,...,N  are\n*          the diagonals of the complex Schur form (S,T).  BETA(j) will\n*          be non-negative real.\n*\n*          Note: the quotients ALPHA(j)/BETA(j) may easily over- or\n*          underflow, and BETA(j) may even be zero.  Thus, the user\n*          should avoid naively computing the ratio alpha/beta.\n*          However, ALPHA will be always less than and usually\n*          comparable with norm(A) in magnitude, and BETA always less\n*          than and usually comparable with norm(B).\n*\n*  VSL     (output) COMPLEX*16 array, dimension (LDVSL,N)\n*          If JOBVSL = 'V', VSL will contain the left Schur vectors.\n*          Not referenced if JOBVSL = 'N'.\n*\n*  LDVSL   (input) INTEGER\n*          The leading dimension of the matrix VSL. LDVSL >=1, and\n*          if JOBVSL = 'V', LDVSL >= N.\n*\n*  VSR     (output) COMPLEX*16 array, dimension (LDVSR,N)\n*          If JOBVSR = 'V', VSR will contain the right Schur vectors.\n*          Not referenced if JOBVSR = 'N'.\n*\n*  LDVSR   (input) INTEGER\n*          The leading dimension of the matrix VSR. LDVSR >= 1, and\n*          if JOBVSR = 'V', LDVSR >= N.\n*\n*  RCONDE  (output) DOUBLE PRECISION array, dimension ( 2 )\n*          If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the\n*          reciprocal condition numbers for the average of the selected\n*          eigenvalues.\n*          Not referenced if SENSE = 'N' or 'V'.\n*\n*  RCONDV  (output) DOUBLE PRECISION array, dimension ( 2 )\n*          If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the\n*          reciprocal condition number for the selected deflating\n*          subspaces.\n*          Not referenced if SENSE = 'N' or 'E'.\n*\n*  WORK    (workspace/output) COMPLEX*16 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*          If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B',\n*          LWORK >= MAX(1,2*N,2*SDIM*(N-SDIM)), else\n*          LWORK >= MAX(1,2*N).  Note that 2*SDIM*(N-SDIM) <= N*N/2.\n*          Note also that an error is only returned if\n*          LWORK < MAX(1,2*N), but if SENSE = 'E' or 'V' or 'B' this may\n*          not be large enough.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the bound on the optimal size of the WORK\n*          array and the minimum size of the IWORK array, returns these\n*          values as the first entries of the WORK and IWORK arrays, and\n*          no error message related to LWORK or LIWORK is issued by\n*          XERBLA.\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension ( 8*N )\n*          Real workspace.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.\n*          If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise\n*          LIWORK >= N+2.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the bound on the optimal size of the\n*          WORK array and the minimum size of the IWORK array, returns\n*          these values as the first entries of the WORK and IWORK\n*          arrays, and no error message related to LWORK or LIWORK is\n*          issued by XERBLA.\n*\n*  BWORK   (workspace) LOGICAL array, dimension (N)\n*          Not referenced if SORT = 'N'.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          = 1,...,N:\n*                The QZ iteration failed.  (A,B) are not in Schur\n*                form, but ALPHA(j) and BETA(j) should be correct for\n*                j=INFO+1,...,N.\n*          > N:  =N+1: other than QZ iteration failed in ZHGEQZ\n*                =N+2: after reordering, roundoff changed values of\n*                      some complex eigenvalues so that leading\n*                      eigenvalues in the Generalized Schur form no\n*                      longer satisfy SELCTG=.TRUE.  This could also\n*                      be caused due to scaling.\n*                =N+3: reordering failed in ZTGSEN.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sdim, alpha, beta, vsl, vsr, rconde, rcondv, work, iwork, info, a, b = NumRu::Lapack.zggesx( jobvsl, jobvsr, sort, sense, a, b, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help]){|a,b| ... }\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_jobvsl = argv[0];
  rblapack_jobvsr = argv[1];
  rblapack_sort = argv[2];
  rblapack_sense = argv[3];
  rblapack_a = argv[4];
  rblapack_b = argv[5];
  if (argc == 8) {
    rblapack_lwork = argv[6];
    rblapack_liwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobvsl = StringValueCStr(rblapack_jobvsl)[0];
  sort = StringValueCStr(rblapack_sort)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  jobvsr = StringValueCStr(rblapack_jobvsr)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  ldvsl = lsame_(&jobvsl,"V") ? n : 1;
  sense = StringValueCStr(rblapack_sense)[0];
  if (rblapack_liwork == Qnil)
    liwork = (lsame_(&sense,"N")||n==0) ? 1 : n+2;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  if (rblapack_lwork == Qnil)
    lwork = n==0 ? 1 : (lsame_(&sense,"E")||lsame_(&sense,"V")||lsame_(&sense,"B")) ? MAX(2*n,n*n/2) : 2*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldvsr = lsame_(&jobvsr,"V") ? n : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  alpha = NA_PTR_TYPE(rblapack_alpha, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvsl;
    shape[1] = n;
    rblapack_vsl = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  vsl = NA_PTR_TYPE(rblapack_vsl, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvsr;
    shape[1] = n;
    rblapack_vsr = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  vsr = NA_PTR_TYPE(rblapack_vsr, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = 2;
    rblapack_rconde = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  rconde = NA_PTR_TYPE(rblapack_rconde, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 2;
    rblapack_rcondv = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  rcondv = NA_PTR_TYPE(rblapack_rcondv, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  rwork = ALLOC_N(doublereal, (8*n));
  bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));

  zggesx_(&jobvsl, &jobvsr, &sort, rblapack_selctg, &sense, &n, a, &lda, b, &ldb, &sdim, alpha, beta, vsl, &ldvsl, vsr, &ldvsr, rconde, rcondv, work, &lwork, rwork, iwork, &liwork, bwork, &info);

  free(rwork);
  free(bwork);
  rblapack_sdim = INT2NUM(sdim);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(12, rblapack_sdim, rblapack_alpha, rblapack_beta, rblapack_vsl, rblapack_vsr, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_iwork, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_zggesx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zggesx", rblapack_zggesx, -1);
}
ruby-lapack-1.7.2/ext/claed8.c0000644000175000017500000002635112502221026015672 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID claed8_(integer* k, integer* n, integer* qsiz, complex* q, integer* ldq, real* d, real* rho, integer* cutpnt, real* z, real* dlamda, complex* q2, integer* ldq2, real* w, integer* indxp, integer* indx, integer* indxq, integer* perm, integer* givptr, integer* givcol, real* givnum, integer* info);


static VALUE
rblapack_claed8(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_qsiz;
  integer qsiz; 
  VALUE rblapack_q;
  complex *q; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_rho;
  real rho; 
  VALUE rblapack_cutpnt;
  integer cutpnt; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_indxq;
  integer *indxq; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_dlamda;
  real *dlamda; 
  VALUE rblapack_q2;
  complex *q2; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_perm;
  integer *perm; 
  VALUE rblapack_givptr;
  integer givptr; 
  VALUE rblapack_givcol;
  integer *givcol; 
  VALUE rblapack_givnum;
  real *givnum; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_q_out__;
  complex *q_out__;
  VALUE rblapack_d_out__;
  real *d_out__;
  integer *indxp;
  integer *indx;

  integer ldq;
  integer n;
  integer ldq2;

  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  k, dlamda, q2, w, perm, givptr, givcol, givnum, info, q, d, rho = NumRu::Lapack.claed8( qsiz, q, d, rho, cutpnt, z, indxq, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA, Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR, GIVCOL, GIVNUM, INFO )\n\n*  Purpose\n*  =======\n*\n*  CLAED8 merges the two sets of eigenvalues together into a single\n*  sorted set.  Then it tries to deflate the size of the problem.\n*  There are two ways in which deflation can occur:  when two or more\n*  eigenvalues are close together or if there is a tiny element in the\n*  Z vector.  For each such occurrence the order of the related secular\n*  equation problem is reduced by one.\n*\n\n*  Arguments\n*  =========\n*\n*  K      (output) INTEGER\n*         Contains the number of non-deflated eigenvalues.\n*         This is the order of the related secular equation.\n*\n*  N      (input) INTEGER\n*         The dimension of the symmetric tridiagonal matrix.  N >= 0.\n*\n*  QSIZ   (input) INTEGER\n*         The dimension of the unitary matrix used to reduce\n*         the dense or band matrix to tridiagonal form.\n*         QSIZ >= N if ICOMPQ = 1.\n*\n*  Q      (input/output) COMPLEX array, dimension (LDQ,N)\n*         On entry, Q contains the eigenvectors of the partially solved\n*         system which has been previously updated in matrix\n*         multiplies with other partially solved eigensystems.\n*         On exit, Q contains the trailing (N-K) updated eigenvectors\n*         (those which were deflated) in its last N-K columns.\n*\n*  LDQ    (input) INTEGER\n*         The leading dimension of the array Q.  LDQ >= max( 1, N ).\n*\n*  D      (input/output) REAL array, dimension (N)\n*         On entry, D contains the eigenvalues of the two submatrices to\n*         be combined.  On exit, D contains the trailing (N-K) updated\n*         eigenvalues (those which were deflated) sorted into increasing\n*         order.\n*\n*  RHO    (input/output) REAL\n*         Contains the off diagonal element associated with the rank-1\n*         cut which originally split the two submatrices which are now\n*         being recombined. RHO is modified during the computation to\n*         the value required by SLAED3.\n*\n*  CUTPNT (input) INTEGER\n*         Contains the location of the last eigenvalue in the leading\n*         sub-matrix.  MIN(1,N) <= CUTPNT <= N.\n*\n*  Z      (input) REAL array, dimension (N)\n*         On input this vector contains the updating vector (the last\n*         row of the first sub-eigenvector matrix and the first row of\n*         the second sub-eigenvector matrix).  The contents of Z are\n*         destroyed during the updating process.\n*\n*  DLAMDA (output) REAL array, dimension (N)\n*         Contains a copy of the first K eigenvalues which will be used\n*         by SLAED3 to form the secular equation.\n*\n*  Q2     (output) COMPLEX array, dimension (LDQ2,N)\n*         If ICOMPQ = 0, Q2 is not referenced.  Otherwise,\n*         Contains a copy of the first K eigenvectors which will be used\n*         by SLAED7 in a matrix multiply (SGEMM) to update the new\n*         eigenvectors.\n*\n*  LDQ2   (input) INTEGER\n*         The leading dimension of the array Q2.  LDQ2 >= max( 1, N ).\n*\n*  W      (output) REAL array, dimension (N)\n*         This will hold the first k values of the final\n*         deflation-altered z-vector and will be passed to SLAED3.\n*\n*  INDXP  (workspace) INTEGER array, dimension (N)\n*         This will contain the permutation used to place deflated\n*         values of D at the end of the array. On output INDXP(1:K)\n*         points to the nondeflated D-values and INDXP(K+1:N)\n*         points to the deflated eigenvalues.\n*\n*  INDX   (workspace) INTEGER array, dimension (N)\n*         This will contain the permutation used to sort the contents of\n*         D into ascending order.\n*\n*  INDXQ  (input) INTEGER array, dimension (N)\n*         This contains the permutation which separately sorts the two\n*         sub-problems in D into ascending order.  Note that elements in\n*         the second half of this permutation must first have CUTPNT\n*         added to their values in order to be accurate.\n*\n*  PERM   (output) INTEGER array, dimension (N)\n*         Contains the permutations (from deflation and sorting) to be\n*         applied to each eigenblock.\n*\n*  GIVPTR (output) INTEGER\n*         Contains the number of Givens rotations which took place in\n*         this subproblem.\n*\n*  GIVCOL (output) INTEGER array, dimension (2, N)\n*         Each pair of numbers indicates a pair of columns to take place\n*         in a Givens rotation.\n*\n*  GIVNUM (output) REAL array, dimension (2, N)\n*         Each number indicates the S value to be used in the\n*         corresponding Givens rotation.\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  k, dlamda, q2, w, perm, givptr, givcol, givnum, info, q, d, rho = NumRu::Lapack.claed8( qsiz, q, d, rho, cutpnt, z, indxq, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_qsiz = argv[0];
  rblapack_q = argv[1];
  rblapack_d = argv[2];
  rblapack_rho = argv[3];
  rblapack_cutpnt = argv[4];
  rblapack_z = argv[5];
  rblapack_indxq = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  qsiz = NUM2INT(rblapack_qsiz);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  cutpnt = NUM2INT(rblapack_cutpnt);
  if (!NA_IsNArray(rblapack_indxq))
    rb_raise(rb_eArgError, "indxq (7th argument) must be NArray");
  if (NA_RANK(rblapack_indxq) != 1)
    rb_raise(rb_eArgError, "rank of indxq (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_indxq) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of indxq must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_indxq) != NA_LINT)
    rblapack_indxq = na_change_type(rblapack_indxq, NA_LINT);
  indxq = NA_PTR_TYPE(rblapack_indxq, integer*);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (2th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (2th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_q) != NA_SCOMPLEX)
    rblapack_q = na_change_type(rblapack_q, NA_SCOMPLEX);
  q = NA_PTR_TYPE(rblapack_q, complex*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (6th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  rho = (real)NUM2DBL(rblapack_rho);
  ldq2 = MAX( 1, n );
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_dlamda = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  dlamda = NA_PTR_TYPE(rblapack_dlamda, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldq2;
    shape[1] = n;
    rblapack_q2 = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  q2 = NA_PTR_TYPE(rblapack_q2, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_perm = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  perm = NA_PTR_TYPE(rblapack_perm, integer*);
  {
    na_shape_t shape[2];
    shape[0] = 2;
    shape[1] = n;
    rblapack_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
  }
  givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
  {
    na_shape_t shape[2];
    shape[0] = 2;
    shape[1] = n;
    rblapack_givnum = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  givnum = NA_PTR_TYPE(rblapack_givnum, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, complex*);
  MEMCPY(q_out__, q, complex, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  indxp = ALLOC_N(integer, (n));
  indx = ALLOC_N(integer, (n));

  claed8_(&k, &n, &qsiz, q, &ldq, d, &rho, &cutpnt, z, dlamda, q2, &ldq2, w, indxp, indx, indxq, perm, &givptr, givcol, givnum, &info);

  free(indxp);
  free(indx);
  rblapack_k = INT2NUM(k);
  rblapack_givptr = INT2NUM(givptr);
  rblapack_info = INT2NUM(info);
  rblapack_rho = rb_float_new((double)rho);
  return rb_ary_new3(12, rblapack_k, rblapack_dlamda, rblapack_q2, rblapack_w, rblapack_perm, rblapack_givptr, rblapack_givcol, rblapack_givnum, rblapack_info, rblapack_q, rblapack_d, rblapack_rho);
}

void
init_lapack_claed8(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "claed8", rblapack_claed8, -1);
}
ruby-lapack-1.7.2/ext/chpev.c0000644000175000017500000001274312502221026015637 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chpev_(char* jobz, char* uplo, integer* n, complex* ap, real* w, complex* z, integer* ldz, complex* work, real* rwork, integer* info);


static VALUE
rblapack_chpev(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  complex *ap_out__;
  complex *work;
  real *rwork;

  integer ldap;
  integer n;
  integer ldz;

  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  w, z, info, ap = NumRu::Lapack.chpev( jobz, uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHPEV computes all the eigenvalues and, optionally, eigenvectors of a\n*  complex Hermitian matrix in packed storage.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, AP is overwritten by values generated during the\n*          reduction to tridiagonal form.  If UPLO = 'U', the diagonal\n*          and first superdiagonal of the tridiagonal matrix T overwrite\n*          the corresponding elements of A, and if UPLO = 'L', the\n*          diagonal and first subdiagonal of T overwrite the\n*          corresponding elements of A.\n*\n*  W       (output) REAL array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) COMPLEX array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n*          eigenvectors of the matrix A, with the i-th column of Z\n*          holding the eigenvector associated with W(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace) COMPLEX array, dimension (max(1, 2*N-1))\n*\n*  RWORK   (workspace) REAL array, dimension (max(1, 3*N-2))\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 algorithm failed to converge; i\n*                off-diagonal elements of an intermediate tridiagonal\n*                form did not converge to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, info, ap = NumRu::Lapack.chpev( jobz, uplo, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_ap = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  uplo = StringValueCStr(rblapack_uplo)[0];
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, complex*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
  MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  work = ALLOC_N(complex, (MAX(1, 2*n-1)));
  rwork = ALLOC_N(real, (MAX(1, 3*n-2)));

  chpev_(&jobz, &uplo, &n, ap, w, z, &ldz, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_w, rblapack_z, rblapack_info, rblapack_ap);
}

void
init_lapack_chpev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chpev", rblapack_chpev, -1);
}
ruby-lapack-1.7.2/ext/zlasr.c0000644000175000017500000002070512502221024015660 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlasr_(char* side, char* pivot, char* direct, integer* m, integer* n, doublereal* c, doublereal* s, doublecomplex* a, integer* lda);


static VALUE
rblapack_zlasr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_pivot;
  char pivot; 
  VALUE rblapack_direct;
  char direct; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_a_out__;
  doublecomplex *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  a = NumRu::Lapack.zlasr( side, pivot, direct, m, c, s, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )\n\n*  Purpose\n*  =======\n*\n*  ZLASR applies a sequence of real plane rotations to a complex matrix\n*  A, from either the left or the right.\n*\n*  When SIDE = 'L', the transformation takes the form\n*\n*     A := P*A\n*\n*  and when SIDE = 'R', the transformation takes the form\n*\n*     A := A*P**T\n*\n*  where P is an orthogonal matrix consisting of a sequence of z plane\n*  rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',\n*  and P**T is the transpose of P.\n*  \n*  When DIRECT = 'F' (Forward sequence), then\n*  \n*     P = P(z-1) * ... * P(2) * P(1)\n*  \n*  and when DIRECT = 'B' (Backward sequence), then\n*  \n*     P = P(1) * P(2) * ... * P(z-1)\n*  \n*  where P(k) is a plane rotation matrix defined by the 2-by-2 rotation\n*  \n*     R(k) = (  c(k)  s(k) )\n*          = ( -s(k)  c(k) ).\n*  \n*  When PIVOT = 'V' (Variable pivot), the rotation is performed\n*  for the plane (k,k+1), i.e., P(k) has the form\n*  \n*     P(k) = (  1                                            )\n*            (       ...                                     )\n*            (              1                                )\n*            (                   c(k)  s(k)                  )\n*            (                  -s(k)  c(k)                  )\n*            (                                1              )\n*            (                                     ...       )\n*            (                                            1  )\n*  \n*  where R(k) appears as a rank-2 modification to the identity matrix in\n*  rows and columns k and k+1.\n*  \n*  When PIVOT = 'T' (Top pivot), the rotation is performed for the\n*  plane (1,k+1), so P(k) has the form\n*  \n*     P(k) = (  c(k)                    s(k)                 )\n*            (         1                                     )\n*            (              ...                              )\n*            (                     1                         )\n*            ( -s(k)                    c(k)                 )\n*            (                                 1             )\n*            (                                      ...      )\n*            (                                             1 )\n*  \n*  where R(k) appears in rows and columns 1 and k+1.\n*  \n*  Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is\n*  performed for the plane (k,z), giving P(k) the form\n*  \n*     P(k) = ( 1                                             )\n*            (      ...                                      )\n*            (             1                                 )\n*            (                  c(k)                    s(k) )\n*            (                         1                     )\n*            (                              ...              )\n*            (                                     1         )\n*            (                 -s(k)                    c(k) )\n*  \n*  where R(k) appears in rows and columns k and z.  The rotations are\n*  performed without ever forming P(k) explicitly.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          Specifies whether the plane rotation matrix P is applied to\n*          A on the left or the right.\n*          = 'L':  Left, compute A := P*A\n*          = 'R':  Right, compute A:= A*P**T\n*\n*  PIVOT   (input) CHARACTER*1\n*          Specifies the plane for which P(k) is a plane rotation\n*          matrix.\n*          = 'V':  Variable pivot, the plane (k,k+1)\n*          = 'T':  Top pivot, the plane (1,k+1)\n*          = 'B':  Bottom pivot, the plane (k,z)\n*\n*  DIRECT  (input) CHARACTER*1\n*          Specifies whether P is a forward or backward sequence of\n*          plane rotations.\n*          = 'F':  Forward, P = P(z-1)*...*P(2)*P(1)\n*          = 'B':  Backward, P = P(1)*P(2)*...*P(z-1)\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.  If m <= 1, an immediate\n*          return is effected.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.  If n <= 1, an\n*          immediate return is effected.\n*\n*  C       (input) DOUBLE PRECISION array, dimension\n*                  (M-1) if SIDE = 'L'\n*                  (N-1) if SIDE = 'R'\n*          The cosines c(k) of the plane rotations.\n*\n*  S       (input) DOUBLE PRECISION array, dimension\n*                  (M-1) if SIDE = 'L'\n*                  (N-1) if SIDE = 'R'\n*          The sines s(k) of the plane rotations.  The 2-by-2 plane\n*          rotation part of the matrix P(k), R(k), has the form\n*          R(k) = (  c(k)  s(k) )\n*                 ( -s(k)  c(k) ).\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          The M-by-N matrix A.  On exit, A is overwritten by P*A if\n*          SIDE = 'R' or by A*P**T if SIDE = 'L'.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  a = NumRu::Lapack.zlasr( side, pivot, direct, m, c, s, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_side = argv[0];
  rblapack_pivot = argv[1];
  rblapack_direct = argv[2];
  rblapack_m = argv[3];
  rblapack_c = argv[4];
  rblapack_s = argv[5];
  rblapack_a = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  direct = StringValueCStr(rblapack_direct)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (7th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (7th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  pivot = StringValueCStr(rblapack_pivot)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (6th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != (m-1))
    rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", m-1);
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != (m-1))
    rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", m-1);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zlasr_(&side, &pivot, &direct, &m, &n, c, s, a, &lda);

  return rblapack_a;
}

void
init_lapack_zlasr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlasr", rblapack_zlasr, -1);
}
ruby-lapack-1.7.2/ext/dtfttr.c0000644000175000017500000001665212502221020016036 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtfttr_(char* transr, char* uplo, integer* n, doublereal* arf, doublereal* a, integer* lda, integer* info);


static VALUE
rblapack_dtfttr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_arf;
  doublereal *arf; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_info;
  integer info; 
  integer ldarf;

  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  a, info = NumRu::Lapack.dtfttr( transr, uplo, arf, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTFTTR copies a triangular matrix A from rectangular full packed\n*  format (TF) to standard full format (TR).\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR  (input) CHARACTER*1\n*          = 'N':  ARF is in Normal format;\n*          = 'T':  ARF is in Transpose format.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrices ARF and A. N >= 0.\n*\n*  ARF     (input) DOUBLE PRECISION array, dimension (N*(N+1)/2).\n*          On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')\n*          matrix A in RFP format. See the \"Notes\" below for more\n*          details.\n*\n*  A       (output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On exit, the triangular matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of the array A contains\n*          the upper triangular matrix, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of the array A contains\n*          the lower triangular matrix, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\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*  We first consider Rectangular Full Packed (RFP) Format when N is\n*  even. We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  the transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  the transpose of the last three columns of AP lower.\n*  This covers the case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        03 04 05                33 43 53\n*        13 14 15                00 44 54\n*        23 24 25                10 11 55\n*        33 34 35                20 21 22\n*        00 44 45                30 31 32\n*        01 11 55                40 41 42\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We then consider Rectangular Full Packed (RFP) Format when N is\n*  odd. We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  the transpose of the first two columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  the transpose of the last two columns of AP lower.\n*  This covers the case N odd and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        02 03 04                00 33 43\n*        12 13 14                10 11 44\n*        22 23 24                20 21 22\n*        00 33 34                30 31 32\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*           RFP A                   RFP A\n*\n*     02 12 22 00 01             00 10 20 30 40 50\n*     03 13 23 33 11             33 11 21 31 41 51\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  Reference\n*  =========\n*\n*  =====================================================================\n*\n*     ..\n*     .. Local Scalars ..\n      LOGICAL            LOWER, NISODD, NORMALTRANSR\n      INTEGER            N1, N2, K, NT, NX2, NP1X2\n      INTEGER            I, J, L, IJ\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MOD\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  a, info = NumRu::Lapack.dtfttr( transr, uplo, arf, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_arf = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  if (!NA_IsNArray(rblapack_arf))
    rb_raise(rb_eArgError, "arf (3th argument) must be NArray");
  if (NA_RANK(rblapack_arf) != 1)
    rb_raise(rb_eArgError, "rank of arf (3th argument) must be %d", 1);
  ldarf = NA_SHAPE0(rblapack_arf);
  if (NA_TYPE(rblapack_arf) != NA_DFLOAT)
    rblapack_arf = na_change_type(rblapack_arf, NA_DFLOAT);
  arf = NA_PTR_TYPE(rblapack_arf, doublereal*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  n = ((int)sqrtf(8*ldarf+1.0f)-1)/2;
  lda = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  a = NA_PTR_TYPE(rblapack_a, doublereal*);

  dtfttr_(&transr, &uplo, &n, arf, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_a, rblapack_info);
}

void
init_lapack_dtfttr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtfttr", rblapack_dtfttr, -1);
}
ruby-lapack-1.7.2/ext/claqr5.c0000644000175000017500000002535212502221023015716 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID claqr5_(logical* wantt, logical* wantz, integer* kacc22, integer* n, integer* ktop, integer* kbot, integer* nshfts, complex* s, complex* h, integer* ldh, integer* iloz, integer* ihiz, complex* z, integer* ldz, complex* v, integer* ldv, complex* u, integer* ldu, integer* nv, complex* wv, integer* ldwv, integer* nh, complex* wh, integer* ldwh);


static VALUE
rblapack_claqr5(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantt;
  logical wantt; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_kacc22;
  integer kacc22; 
  VALUE rblapack_ktop;
  integer ktop; 
  VALUE rblapack_kbot;
  integer kbot; 
  VALUE rblapack_s;
  complex *s; 
  VALUE rblapack_h;
  complex *h; 
  VALUE rblapack_iloz;
  integer iloz; 
  VALUE rblapack_ihiz;
  integer ihiz; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_ldz;
  integer ldz; 
  VALUE rblapack_nv;
  integer nv; 
  VALUE rblapack_nh;
  integer nh; 
  VALUE rblapack_s_out__;
  complex *s_out__;
  VALUE rblapack_h_out__;
  complex *h_out__;
  VALUE rblapack_z_out__;
  complex *z_out__;
  complex *v;
  complex *u;
  complex *wv;
  complex *wh;

  integer nshfts;
  integer ldh;
  integer n;
  integer ldv;
  integer ldu;
  integer ldwv;
  integer ldwh;

  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  s, h, z = NumRu::Lapack.claqr5( wantt, wantz, kacc22, ktop, kbot, s, h, iloz, ihiz, z, ldz, nv, nh, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, WV, LDWV, NH, WH, LDWH )\n\n*     This auxiliary subroutine called by CLAQR0 performs a\n*     single small-bulge multi-shift QR sweep.\n*\n\n*      WANTT  (input) logical scalar\n*             WANTT = .true. if the triangular Schur factor\n*             is being computed.  WANTT is set to .false. otherwise.\n*\n*      WANTZ  (input) logical scalar\n*             WANTZ = .true. if the unitary Schur factor is being\n*             computed.  WANTZ is set to .false. otherwise.\n*\n*      KACC22 (input) integer with value 0, 1, or 2.\n*             Specifies the computation mode of far-from-diagonal\n*             orthogonal updates.\n*        = 0: CLAQR5 does not accumulate reflections and does not\n*             use matrix-matrix multiply to update far-from-diagonal\n*             matrix entries.\n*        = 1: CLAQR5 accumulates reflections and uses matrix-matrix\n*             multiply to update the far-from-diagonal matrix entries.\n*        = 2: CLAQR5 accumulates reflections, uses matrix-matrix\n*             multiply to update the far-from-diagonal matrix entries,\n*             and takes advantage of 2-by-2 block structure during\n*             matrix multiplies.\n*\n*      N      (input) integer scalar\n*             N is the order of the Hessenberg matrix H upon which this\n*             subroutine operates.\n*\n*      KTOP   (input) integer scalar\n*      KBOT   (input) integer scalar\n*             These are the first and last rows and columns of an\n*             isolated diagonal block upon which the QR sweep is to be\n*             applied. It is assumed without a check that\n*                       either KTOP = 1  or   H(KTOP,KTOP-1) = 0\n*             and\n*                       either KBOT = N  or   H(KBOT+1,KBOT) = 0.\n*\n*      NSHFTS (input) integer scalar\n*             NSHFTS gives the number of simultaneous shifts.  NSHFTS\n*             must be positive and even.\n*\n*      S      (input/output) COMPLEX array of size (NSHFTS)\n*             S contains the shifts of origin that define the multi-\n*             shift QR sweep.  On output S may be reordered.\n*\n*      H      (input/output) COMPLEX array of size (LDH,N)\n*             On input H contains a Hessenberg matrix.  On output a\n*             multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied\n*             to the isolated diagonal block in rows and columns KTOP\n*             through KBOT.\n*\n*      LDH    (input) integer scalar\n*             LDH is the leading dimension of H just as declared in the\n*             calling procedure.  LDH.GE.MAX(1,N).\n*\n*      ILOZ   (input) INTEGER\n*      IHIZ   (input) INTEGER\n*             Specify the rows of Z to which transformations must be\n*             applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N\n*\n*      Z      (input/output) COMPLEX array of size (LDZ,IHI)\n*             If WANTZ = .TRUE., then the QR Sweep unitary\n*             similarity transformation is accumulated into\n*             Z(ILOZ:IHIZ,ILO:IHI) from the right.\n*             If WANTZ = .FALSE., then Z is unreferenced.\n*\n*      LDZ    (input) integer scalar\n*             LDA is the leading dimension of Z just as declared in\n*             the calling procedure. LDZ.GE.N.\n*\n*      V      (workspace) COMPLEX array of size (LDV,NSHFTS/2)\n*\n*      LDV    (input) integer scalar\n*             LDV is the leading dimension of V as declared in the\n*             calling procedure.  LDV.GE.3.\n*\n*      U      (workspace) COMPLEX array of size\n*             (LDU,3*NSHFTS-3)\n*\n*      LDU    (input) integer scalar\n*             LDU is the leading dimension of U just as declared in the\n*             in the calling subroutine.  LDU.GE.3*NSHFTS-3.\n*\n*      NH     (input) integer scalar\n*             NH is the number of columns in array WH available for\n*             workspace. NH.GE.1.\n*\n*      WH     (workspace) COMPLEX array of size (LDWH,NH)\n*\n*      LDWH   (input) integer scalar\n*             Leading dimension of WH just as declared in the\n*             calling procedure.  LDWH.GE.3*NSHFTS-3.\n*\n*      NV     (input) integer scalar\n*             NV is the number of rows in WV agailable for workspace.\n*             NV.GE.1.\n*\n*      WV     (workspace) COMPLEX array of size\n*             (LDWV,3*NSHFTS-3)\n*\n*      LDWV   (input) integer scalar\n*             LDWV is the leading dimension of WV as declared in the\n*             in the calling subroutine.  LDWV.GE.NV.\n*\n\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n*     Reference:\n*\n*     K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n*     Algorithm Part I: Maintaining Well Focused Shifts, and\n*     Level 3 Performance, SIAM Journal of Matrix Analysis,\n*     volume 23, pages 929--947, 2002.\n*\n*     ================================================================\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, h, z = NumRu::Lapack.claqr5( wantt, wantz, kacc22, ktop, kbot, s, h, iloz, ihiz, z, ldz, nv, nh, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 13 && argc != 13)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 13)", argc);
  rblapack_wantt = argv[0];
  rblapack_wantz = argv[1];
  rblapack_kacc22 = argv[2];
  rblapack_ktop = argv[3];
  rblapack_kbot = argv[4];
  rblapack_s = argv[5];
  rblapack_h = argv[6];
  rblapack_iloz = argv[7];
  rblapack_ihiz = argv[8];
  rblapack_z = argv[9];
  rblapack_ldz = argv[10];
  rblapack_nv = argv[11];
  rblapack_nh = argv[12];
  if (argc == 13) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  wantt = (rblapack_wantt == Qtrue);
  kacc22 = NUM2INT(rblapack_kacc22);
  kbot = NUM2INT(rblapack_kbot);
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (7th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (7th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_SCOMPLEX)
    rblapack_h = na_change_type(rblapack_h, NA_SCOMPLEX);
  h = NA_PTR_TYPE(rblapack_h, complex*);
  ihiz = NUM2INT(rblapack_ihiz);
  ldz = NUM2INT(rblapack_ldz);
  nh = NUM2INT(rblapack_nh);
  ldv = 3;
  wantz = (rblapack_wantz == Qtrue);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (6th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
  nshfts = NA_SHAPE0(rblapack_s);
  if (NA_TYPE(rblapack_s) != NA_SCOMPLEX)
    rblapack_s = na_change_type(rblapack_s, NA_SCOMPLEX);
  s = NA_PTR_TYPE(rblapack_s, complex*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (10th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (10th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_z) != (wantz ? ldz : 0))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantz ? ldz : 0);
  if (NA_SHAPE1(rblapack_z) != (wantz ? ihiz : 0))
    rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantz ? ihiz : 0);
  if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, complex*);
  ldwh = 3*nshfts-3;
  ldu = 3*nshfts-3;
  ktop = NUM2INT(rblapack_ktop);
  nv = NUM2INT(rblapack_nv);
  iloz = NUM2INT(rblapack_iloz);
  ldwv = nv;
  {
    na_shape_t shape[1];
    shape[0] = nshfts;
    rblapack_s_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, complex*);
  MEMCPY(s_out__, s, complex, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, complex*);
  MEMCPY(h_out__, h, complex, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = wantz ? ldz : 0;
    shape[1] = wantz ? ihiz : 0;
    rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
  MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  v = ALLOC_N(complex, (ldv)*(nshfts/2));
  u = ALLOC_N(complex, (ldu)*(3*nshfts-3));
  wv = ALLOC_N(complex, (ldwv)*(3*nshfts-3));
  wh = ALLOC_N(complex, (ldwh)*(MAX(1,nh)));

  claqr5_(&wantt, &wantz, &kacc22, &n, &ktop, &kbot, &nshfts, s, h, &ldh, &iloz, &ihiz, z, &ldz, v, &ldv, u, &ldu, &nv, wv, &ldwv, &nh, wh, &ldwh);

  free(v);
  free(u);
  free(wv);
  free(wh);
  return rb_ary_new3(3, rblapack_s, rblapack_h, rblapack_z);
}

void
init_lapack_claqr5(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "claqr5", rblapack_claqr5, -1);
}
ruby-lapack-1.7.2/ext/dgeqlf.c0000644000175000017500000001363412502221015015772 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgeqlf_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dgeqlf(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.dgeqlf( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGEQLF computes a QL factorization of a real M-by-N matrix A:\n*  A = Q * L.\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,\n*          if m >= n, the lower triangle of the subarray\n*          A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L;\n*          if m <= n, the elements on and below the (n-m)-th\n*          superdiagonal contain the M-by-N lower trapezoidal matrix L;\n*          the remaining elements, with the array TAU, represent the\n*          orthogonal matrix Q as a product of elementary reflectors\n*          (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,N).\n*          For optimum performance LWORK >= N*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(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n*  A(1:m-k+i-1,n-k+i), and tau in TAU(i).\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY\n      INTEGER            I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,\n     $                   MU, NB, NBMIN, NU, NX\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DGEQL2, 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.dgeqlf( 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;
  }

  m = NUM2INT(rblapack_m);
  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*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;

  dgeqlf_(&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_dgeqlf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgeqlf", rblapack_dgeqlf, -1);
}
ruby-lapack-1.7.2/ext/sgtsv.c0000644000175000017500000001510612502221014015671 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgtsv_(integer* n, integer* nrhs, real* dl, real* d, real* du, real* b, integer* ldb, integer* info);


static VALUE
rblapack_sgtsv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_dl;
  real *dl; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_du;
  real *du; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_dl_out__;
  real *dl_out__;
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_du_out__;
  real *du_out__;
  VALUE rblapack_b_out__;
  real *b_out__;

  integer n;
  integer ldb;
  integer nrhs;

  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  info, dl, d, du, b = NumRu::Lapack.sgtsv( dl, d, du, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGTSV  solves the equation\n*\n*     A*X = B,\n*\n*  where A is an n by n tridiagonal matrix, by Gaussian elimination with\n*  partial pivoting.\n*\n*  Note that the equation  A'*X = B  may be solved by interchanging the\n*  order of the arguments DU and DL.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  DL      (input/output) REAL array, dimension (N-1)\n*          On entry, DL must contain the (n-1) sub-diagonal elements of\n*          A.\n*\n*          On exit, DL is overwritten by the (n-2) elements of the\n*          second super-diagonal of the upper triangular matrix U from\n*          the LU factorization of A, in DL(1), ..., DL(n-2).\n*\n*  D       (input/output) REAL array, dimension (N)\n*          On entry, D must contain the diagonal elements of A.\n*\n*          On exit, D is overwritten by the n diagonal elements of U.\n*\n*  DU      (input/output) REAL array, dimension (N-1)\n*          On entry, DU must contain the (n-1) super-diagonal elements\n*          of A.\n*\n*          On exit, DU is overwritten by the (n-1) elements of the first\n*          super-diagonal of U.\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the N by NRHS matrix of right hand side matrix B.\n*          On exit, if INFO = 0, the N by NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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, U(i,i) is exactly zero, and the solution\n*               has not been computed.  The factorization has not been\n*               completed unless i = N.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, dl, d, du, b = NumRu::Lapack.sgtsv( dl, d, du, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_dl = argv[0];
  rblapack_d = argv[1];
  rblapack_du = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (1th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (1th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_SFLOAT)
    rblapack_dl = na_change_type(rblapack_dl, NA_SFLOAT);
  dl = NA_PTR_TYPE(rblapack_dl, real*);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (3th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_SFLOAT)
    rblapack_du = na_change_type(rblapack_du, NA_SFLOAT);
  du = NA_PTR_TYPE(rblapack_du, real*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_dl_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  dl_out__ = NA_PTR_TYPE(rblapack_dl_out__, real*);
  MEMCPY(dl_out__, dl, real, NA_TOTAL(rblapack_dl));
  rblapack_dl = rblapack_dl_out__;
  dl = dl_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_du_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  du_out__ = NA_PTR_TYPE(rblapack_du_out__, real*);
  MEMCPY(du_out__, du, real, NA_TOTAL(rblapack_du));
  rblapack_du = rblapack_du_out__;
  du = du_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  sgtsv_(&n, &nrhs, dl, d, du, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_info, rblapack_dl, rblapack_d, rblapack_du, rblapack_b);
}

void
init_lapack_sgtsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgtsv", rblapack_sgtsv, -1);
}
ruby-lapack-1.7.2/ext/dormbr.c0000644000175000017500000002222512502221016016012 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dormbr_(char* vect, char* side, char* trans, integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* c, integer* ldc, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dormbr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_vect;
  char vect; 
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublereal *c_out__;

  integer lda;
  integer ldc;
  integer n;
  integer nq;

  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, c = NumRu::Lapack.dormbr( vect, side, trans, m, k, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  If VECT = 'Q', DORMBR overwrites the general real M-by-N matrix C\n*  with\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'T':      Q**T * C       C * Q**T\n*\n*  If VECT = 'P', DORMBR overwrites the general real M-by-N matrix C\n*  with\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      P * C          C * P\n*  TRANS = 'T':      P**T * C       C * P**T\n*\n*  Here Q and P**T are the orthogonal matrices determined by DGEBRD when\n*  reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and\n*  P**T are defined as products of elementary reflectors H(i) and G(i)\n*  respectively.\n*\n*  Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the\n*  order of the orthogonal matrix Q or P**T that is applied.\n*\n*  If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:\n*  if nq >= k, Q = H(1) H(2) . . . H(k);\n*  if nq < k, Q = H(1) H(2) . . . H(nq-1).\n*\n*  If VECT = 'P', A is assumed to have been a K-by-NQ matrix:\n*  if k < nq, P = G(1) G(2) . . . G(k);\n*  if k >= nq, P = G(1) G(2) . . . G(nq-1).\n*\n\n*  Arguments\n*  =========\n*\n*  VECT    (input) CHARACTER*1\n*          = 'Q': apply Q or Q**T;\n*          = 'P': apply P or P**T.\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q, Q**T, P or P**T from the Left;\n*          = 'R': apply Q, Q**T, P or P**T from the Right.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q  or P;\n*          = 'T':  Transpose, apply Q**T or P**T.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          If VECT = 'Q', the number of columns in the original\n*          matrix reduced by DGEBRD.\n*          If VECT = 'P', the number of rows in the original\n*          matrix reduced by DGEBRD.\n*          K >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension\n*                                (LDA,min(nq,K)) if VECT = 'Q'\n*                                (LDA,nq)        if VECT = 'P'\n*          The vectors which define the elementary reflectors H(i) and\n*          G(i), whose products determine the matrices Q and P, as\n*          returned by DGEBRD.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*          If VECT = 'Q', LDA >= max(1,nq);\n*          if VECT = 'P', LDA >= max(1,min(nq,K)).\n*\n*  TAU     (input) DOUBLE PRECISION array, dimension (min(nq,K))\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i) or G(i) which determines Q or P, as returned\n*          by DGEBRD in the array argument TAUQ or TAUP.\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q\n*          or P*C or P**T*C or C*P or C*P**T.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M).\n*          For optimum performance LWORK >= N*NB if SIDE = 'L', and\n*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n*          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*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            APPLYQ, LEFT, LQUERY, NOTRAN\n      CHARACTER          TRANST\n      INTEGER            I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            ILAENV\n      EXTERNAL           LSAME, ILAENV\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DORMLQ, DORMQR, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.dormbr( vect, side, trans, m, k, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_vect = argv[0];
  rblapack_side = argv[1];
  rblapack_trans = argv[2];
  rblapack_m = argv[3];
  rblapack_k = argv[4];
  rblapack_a = argv[5];
  rblapack_tau = argv[6];
  rblapack_c = argv[7];
  if (argc == 9) {
    rblapack_lwork = argv[8];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  vect = StringValueCStr(rblapack_vect)[0];
  trans = StringValueCStr(rblapack_trans)[0];
  k = NUM2INT(rblapack_k);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (8th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  side = StringValueCStr(rblapack_side)[0];
  m = NUM2INT(rblapack_m);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  nq = lsame_(&side,"L") ? m : lsame_(&side,"R") ? n : 0;
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (6th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (6th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != (MIN(nq,k)))
    rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", MIN(nq,k));
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (7th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_tau) != (MIN(nq,k)))
    rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", MIN(nq,k));
  if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  dormbr_(&vect, &side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_dormbr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dormbr", rblapack_dormbr, -1);
}
ruby-lapack-1.7.2/ext/dlarra.c0000644000175000017500000001500112502221015015763 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlarra_(integer* n, doublereal* d, doublereal* e, doublereal* e2, doublereal* spltol, doublereal* tnrm, integer* nsplit, integer* isplit, integer* info);


static VALUE
rblapack_dlarra(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_e2;
  doublereal *e2; 
  VALUE rblapack_spltol;
  doublereal spltol; 
  VALUE rblapack_tnrm;
  doublereal tnrm; 
  VALUE rblapack_nsplit;
  integer nsplit; 
  VALUE rblapack_isplit;
  integer *isplit; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_e_out__;
  doublereal *e_out__;
  VALUE rblapack_e2_out__;
  doublereal *e2_out__;

  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  nsplit, isplit, info, e, e2 = NumRu::Lapack.dlarra( d, e, e2, spltol, tnrm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLARRA( N, D, E, E2, SPLTOL, TNRM, NSPLIT, ISPLIT, INFO )\n\n*  Purpose\n*  =======\n*\n*  Compute the splitting points with threshold SPLTOL.\n*  DLARRA sets any \"small\" off-diagonal elements to zero.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix. N > 0.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          On entry, the N diagonal elements of the tridiagonal\n*          matrix T.\n*\n*  E       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the first (N-1) entries contain the subdiagonal\n*          elements of the tridiagonal matrix T; E(N) need not be set.\n*          On exit, the entries E( ISPLIT( I ) ), 1 <= I <= NSPLIT,\n*          are set to zero, the other entries of E are untouched.\n*\n*  E2      (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the first (N-1) entries contain the SQUARES of the\n*          subdiagonal elements of the tridiagonal matrix T;\n*          E2(N) need not be set.\n*          On exit, the entries E2( ISPLIT( I ) ),\n*          1 <= I <= NSPLIT, have been set to zero\n*\n*  SPLTOL  (input) DOUBLE PRECISION\n*          The threshold for splitting. Two criteria can be used:\n*          SPLTOL<0 : criterion based on absolute off-diagonal value\n*          SPLTOL>0 : criterion that preserves relative accuracy\n*\n*  TNRM    (input) DOUBLE PRECISION\n*          The norm of the matrix.\n*\n*  NSPLIT  (output) INTEGER\n*          The number of blocks T splits into. 1 <= NSPLIT <= N.\n*\n*  ISPLIT  (output) INTEGER array, dimension (N)\n*          The splitting points, at which T breaks up into blocks.\n*          The first block consists of rows/columns 1 to ISPLIT(1),\n*          the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),\n*          etc., and the NSPLIT-th consists of rows/columns\n*          ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.\n*\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Beresford Parlett, University of California, Berkeley, USA\n*     Jim Demmel, University of California, Berkeley, USA\n*     Inderjit Dhillon, University of Texas, Austin, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  nsplit, isplit, info, e, e2 = NumRu::Lapack.dlarra( d, e, e2, spltol, tnrm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_d = argv[0];
  rblapack_e = argv[1];
  rblapack_e2 = argv[2];
  rblapack_spltol = argv[3];
  rblapack_tnrm = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_e2))
    rb_raise(rb_eArgError, "e2 (3th argument) must be NArray");
  if (NA_RANK(rblapack_e2) != 1)
    rb_raise(rb_eArgError, "rank of e2 (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e2) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of e2 must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_e2) != NA_DFLOAT)
    rblapack_e2 = na_change_type(rblapack_e2, NA_DFLOAT);
  e2 = NA_PTR_TYPE(rblapack_e2, doublereal*);
  tnrm = NUM2DBL(rblapack_tnrm);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (2th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  spltol = NUM2DBL(rblapack_spltol);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_isplit = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
  MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_e2_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e2_out__ = NA_PTR_TYPE(rblapack_e2_out__, doublereal*);
  MEMCPY(e2_out__, e2, doublereal, NA_TOTAL(rblapack_e2));
  rblapack_e2 = rblapack_e2_out__;
  e2 = e2_out__;

  dlarra_(&n, d, e, e2, &spltol, &tnrm, &nsplit, isplit, &info);

  rblapack_nsplit = INT2NUM(nsplit);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_nsplit, rblapack_isplit, rblapack_info, rblapack_e, rblapack_e2);
}

void
init_lapack_dlarra(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlarra", rblapack_dlarra, -1);
}
ruby-lapack-1.7.2/ext/zla_syrpvgrw.c0000644000175000017500000001417512502221024017302 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal zla_syrpvgrw_(char* uplo, integer* n, integer* info, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublecomplex* work);


static VALUE
rblapack_zla_syrpvgrw(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack___out__;
  doublereal __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  __out__ = NumRu::Lapack.zla_syrpvgrw( uplo, info, a, af, ipiv, work, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION ZLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, WORK )\n\n*  Purpose\n*  =======\n* \n*  ZLA_SYRPVGRW computes the reciprocal pivot growth factor\n*  norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n*  much less than 1, the stability of the LU factorization of the\n*  (equilibrated) matrix A could be poor. This also means that the\n*  solution X, estimated condition numbers, and error bounds could be\n*  unreliable.\n*\n\n*  Arguments\n*  =========\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     INFO    (input) INTEGER\n*     The value of INFO returned from ZSYTRF, .i.e., the pivot in\n*     column INFO is exactly 0.\n*\n*     NCOLS   (input) INTEGER\n*     The number of columns of the matrix A. NCOLS >= 0.\n*\n*     A       (input) COMPLEX*16 array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX*16 array, dimension (LDAF,N)\n*     The block diagonal matrix D and the multipliers used to\n*     obtain the factor U or L as computed by ZSYTRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     Details of the interchanges and the block structure of D\n*     as determined by ZSYTRF.\n*\n*     WORK    (input) COMPLEX*16 array, dimension (2*N)\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            NCOLS, I, J, K, KP\n      DOUBLE PRECISION   AMAX, UMAX, RPVGRW, TMP\n      LOGICAL            UPPER\n      COMPLEX*16         ZDUM\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, REAL, DIMAG, MAX, MIN\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           LSAME, ZLASET\n      LOGICAL            LSAME\n*     ..\n*     .. Statement Functions ..\n      DOUBLE PRECISION   CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( ZDUM ) = ABS( DBLE ( ZDUM ) ) + ABS( DIMAG ( ZDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.zla_syrpvgrw( uplo, info, a, af, ipiv, work, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_info = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_work = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  info = NUM2INT(rblapack_info);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (6th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
  if (NA_TYPE(rblapack_work) != NA_DCOMPLEX)
    rblapack_work = na_change_type(rblapack_work, NA_DCOMPLEX);
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);

  __out__ = zla_syrpvgrw_(&uplo, &n, &info, a, &lda, af, &ldaf, ipiv, work);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_zla_syrpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zla_syrpvgrw", rblapack_zla_syrpvgrw, -1);
}
ruby-lapack-1.7.2/ext/dsptrf.c0000644000175000017500000001500012502221026016021 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsptrf_(char* uplo, integer* n, doublereal* ap, integer* ipiv, integer* info);


static VALUE
rblapack_dsptrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublereal *ap_out__;

  integer ldap;
  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  ipiv, info, ap = NumRu::Lapack.dsptrf( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSPTRF( UPLO, N, AP, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSPTRF computes the factorization of a real symmetric matrix A stored\n*  in packed format using the Bunch-Kaufman diagonal pivoting method:\n*\n*     A = U*D*U**T  or  A = L*D*L**T\n*\n*  where U (or L) is a product of permutation and unit upper (lower)\n*  triangular matrices, and D is symmetric and block diagonal with\n*  1-by-1 and 2-by-2 diagonal blocks.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L, stored as a packed triangular\n*          matrix overwriting A (see below for further details).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D.\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\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, D(i,i) is exactly zero.  The factorization\n*               has been completed, but the block diagonal matrix D is\n*               exactly singular, and division by zero will occur if it\n*               is used to solve a system of equations.\n*\n\n*  Further Details\n*  ===============\n*\n*  5-96 - Based on modifications by J. Lewis, Boeing Computer Services\n*         Company\n*\n*  If UPLO = 'U', then A = U*D*U', where\n*     U = P(n)*U(n)* ... *P(k)U(k)* ...,\n*  i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n*  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    v    0   )   k-s\n*     U(k) =  (   0    I    0   )   s\n*             (   0    0    I   )   n-k\n*                k-s   s   n-k\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n*  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n*  and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n*  If UPLO = 'L', then A = L*D*L', where\n*     L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n*  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n*  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    0     0   )  k-1\n*     L(k) =  (   0    I     0   )  s\n*             (   0    v     I   )  n-k-s+1\n*                k-1   s  n-k-s+1\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n*  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n*  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, ap = NumRu::Lapack.dsptrf( uplo, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
  MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  dsptrf_(&uplo, &n, ap, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_ap);
}

void
init_lapack_dsptrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsptrf", rblapack_dsptrf, -1);
}
ruby-lapack-1.7.2/ext/ssytrs2.c0000644000175000017500000001214412502221026016156 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssytrs2_(char* uplo, integer* n, integer* nrhs, real* a, integer* lda, integer* ipiv, real* b, integer* ldb, real* work, integer* info);


static VALUE
rblapack_ssytrs2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  real *b_out__;
  real *work;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.ssytrs2( uplo, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,  WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSYTRS2 solves a system of linear equations A*X = B with a real\n*  symmetric matrix A using the factorization A = U*D*U**T or\n*  A = L*D*L**T computed by SSYTRF and converted by SSYCONV.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input) REAL array, dimension (LDA,N)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by SSYTRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by SSYTRF.\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  WORK    (workspace) REAL array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.ssytrs2( uplo, a, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(real, (n));

  ssytrs2_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_ssytrs2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssytrs2", rblapack_ssytrs2, -1);
}
ruby-lapack-1.7.2/ext/zpotrf.c0000644000175000017500000001001212502221023016036 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zpotrf_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* info);


static VALUE
rblapack_zpotrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *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  info, a = NumRu::Lapack.zpotrf( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPOTRF( UPLO, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPOTRF computes the Cholesky factorization of a complex Hermitian\n*  positive definite matrix A.\n*\n*  The factorization has the form\n*     A = U**H * U,  if UPLO = 'U', or\n*     A = L  * L**H,  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is lower triangular.\n*\n*  This is the block version of the algorithm, calling Level 3 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the factor U or L from the Cholesky\n*          factorization A = U**H*U or A = L*L**H.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\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 leading minor of order i is not\n*                positive definite, and the factorization could not be\n*                completed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.zpotrf( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zpotrf_(&uplo, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_zpotrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zpotrf", rblapack_zpotrf, -1);
}
ruby-lapack-1.7.2/ext/dlaqgb.c0000644000175000017500000001503212502221021015751 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaqgb_(integer* m, integer* n, integer* kl, integer* ku, doublereal* ab, integer* ldab, doublereal* r, doublereal* c, doublereal* rowcnd, doublereal* colcnd, doublereal* amax, char* equed);


static VALUE
rblapack_dlaqgb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_r;
  doublereal *r; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_rowcnd;
  doublereal rowcnd; 
  VALUE rblapack_colcnd;
  doublereal colcnd; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_ab_out__;
  doublereal *ab_out__;

  integer ldab;
  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  equed, ab = NumRu::Lapack.dlaqgb( kl, ku, ab, r, c, rowcnd, colcnd, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, EQUED )\n\n*  Purpose\n*  =======\n*\n*  DLAQGB equilibrates a general M by N band matrix A with KL\n*  subdiagonals and KU superdiagonals using the row and scaling factors\n*  in the vectors R and C.\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*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n*          On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n*          The j-th column of A is stored in the j-th column of the\n*          array AB as follows:\n*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n*          On exit, the equilibrated matrix, in the same storage format\n*          as A.  See EQUED for the form of the equilibrated matrix.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDA >= KL+KU+1.\n*\n*  R       (input) DOUBLE PRECISION array, dimension (M)\n*          The row scale factors for A.\n*\n*  C       (input) DOUBLE PRECISION array, dimension (N)\n*          The column scale factors for A.\n*\n*  ROWCND  (input) DOUBLE PRECISION\n*          Ratio of the smallest R(i) to the largest R(i).\n*\n*  COLCND  (input) DOUBLE PRECISION\n*          Ratio of the smallest C(i) to the largest C(i).\n*\n*  AMAX    (input) DOUBLE PRECISION\n*          Absolute value of largest matrix entry.\n*\n*  EQUED   (output) CHARACTER*1\n*          Specifies the form of equilibration that was done.\n*          = 'N':  No equilibration\n*          = 'R':  Row equilibration, i.e., A has been premultiplied by\n*                  diag(R).\n*          = 'C':  Column equilibration, i.e., A has been postmultiplied\n*                  by diag(C).\n*          = 'B':  Both row and column equilibration, i.e., A has been\n*                  replaced by diag(R) * A * diag(C).\n*\n*  Internal Parameters\n*  ===================\n*\n*  THRESH is a threshold value used to decide if row or column scaling\n*  should be done based on the ratio of the row or column scaling\n*  factors.  If ROWCND < THRESH, row scaling is done, and if\n*  COLCND < THRESH, column scaling is done.\n*\n*  LARGE and SMALL are threshold values used to decide if row scaling\n*  should be done based on the absolute size of the largest matrix\n*  element.  If AMAX > LARGE or AMAX < SMALL, row scaling is done.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  equed, ab = NumRu::Lapack.dlaqgb( kl, ku, ab, r, c, rowcnd, colcnd, amax, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_kl = argv[0];
  rblapack_ku = argv[1];
  rblapack_ab = argv[2];
  rblapack_r = argv[3];
  rblapack_c = argv[4];
  rblapack_rowcnd = argv[5];
  rblapack_colcnd = argv[6];
  rblapack_amax = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  colcnd = NUM2DBL(rblapack_colcnd);
  ku = NUM2INT(rblapack_ku);
  rowcnd = NUM2DBL(rblapack_rowcnd);
  if (!NA_IsNArray(rblapack_r))
    rb_raise(rb_eArgError, "r (4th argument) must be NArray");
  if (NA_RANK(rblapack_r) != 1)
    rb_raise(rb_eArgError, "rank of r (4th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_r);
  if (NA_TYPE(rblapack_r) != NA_DFLOAT)
    rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
  r = NA_PTR_TYPE(rblapack_r, doublereal*);
  amax = NUM2DBL(rblapack_amax);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
  MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  dlaqgb_(&m, &n, &kl, &ku, ab, &ldab, r, c, &rowcnd, &colcnd, &amax, &equed);

  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(2, rblapack_equed, rblapack_ab);
}

void
init_lapack_dlaqgb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaqgb", rblapack_dlaqgb, -1);
}
ruby-lapack-1.7.2/ext/sgelss.c0000644000175000017500000001770212502221024016030 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgelss_(integer* m, integer* n, integer* nrhs, real* a, integer* lda, real* b, integer* ldb, real* s, real* rcond, integer* rank, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sgelss(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_rank;
  integer rank; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_b_out__;
  real *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  s, rank, work, info, a, b = NumRu::Lapack.sgelss( a, b, rcond, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGELSS computes the minimum norm solution to a real linear least\n*  squares problem:\n*\n*  Minimize 2-norm(| b - A*x |).\n*\n*  using the singular value decomposition (SVD) of A. A is an M-by-N\n*  matrix which may be rank-deficient.\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 matrix\n*  X.\n*\n*  The effective rank of A is determined by treating as zero those\n*  singular values which are less than RCOND times the largest singular\n*  value.\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*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X. NRHS >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, the first min(m,n) rows of A are overwritten with\n*          its right singular vectors, stored rowwise.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the M-by-NRHS right hand side matrix B.\n*          On exit, B is overwritten by the N-by-NRHS solution\n*          matrix X.  If m >= n and RANK = n, the residual\n*          sum-of-squares for the solution in the i-th column is given\n*          by the sum of squares of elements n+1:m in that column.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,max(M,N)).\n*\n*  S       (output) REAL array, dimension (min(M,N))\n*          The singular values of A in decreasing order.\n*          The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n*\n*  RCOND   (input) REAL\n*          RCOND is used to determine the effective rank of A.\n*          Singular values S(i) <= RCOND*S(1) are treated as zero.\n*          If RCOND < 0, machine precision is used instead.\n*\n*  RANK    (output) INTEGER\n*          The effective rank of A, i.e., the number of singular values\n*          which are greater than RCOND*S(1).\n*\n*  WORK    (workspace/output) REAL 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 >= 1, and also:\n*          LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS )\n*          For good performance, LWORK should generally be larger.\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:  the algorithm for computing the SVD failed to converge;\n*                if INFO = i, i off-diagonal elements of an intermediate\n*                bidiagonal form did not converge to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, rank, work, info, a, b = NumRu::Lapack.sgelss( a, b, rcond, [: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_a = argv[0];
  rblapack_b = argv[1];
  rblapack_rcond = 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 (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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  rcond = (real)NUM2DBL(rblapack_rcond);
  m = lda;
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th 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_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  ldb = MAX(m,n);
  if (rblapack_lwork == Qnil)
    lwork = 3*MIN(m,n) + MAX(MAX(2*MIN(m,n),MAX(m,n)),nrhs);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = MAX(m, n);
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  {
    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__;

  sgelss_(&m, &n, &nrhs, a, &lda, b, &ldb, s, &rcond, &rank, work, &lwork, &info);

  rblapack_rank = INT2NUM(rank);
  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(6, rblapack_s, rblapack_rank, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_sgelss(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgelss", rblapack_sgelss, -1);
}
ruby-lapack-1.7.2/ext/clarscl2.c0000644000175000017500000000655512502221023016240 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clarscl2_(integer* m, integer* n, real* d, complex* x, integer* ldx);


static VALUE
rblapack_clarscl2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_x_out__;
  complex *x_out__;

  integer m;
  integer ldx;
  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  x = NumRu::Lapack.clarscl2( d, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLARSCL2 ( M, N, D, X, LDX )\n\n*  Purpose\n*  =======\n*\n*  CLARSCL2 performs a reciprocal diagonal scaling on an vector:\n*    x <-- inv(D) * x\n*  where the REAL diagonal matrix D is stored as a vector.\n*\n*  Eventually to be replaced by BLAS_cge_diag_scale in the new BLAS\n*  standard.\n*\n\n*  Arguments\n*  =========\n*\n*     M       (input) INTEGER\n*     The number of rows of D and X. M >= 0.\n*\n*     N       (input) INTEGER\n*     The number of columns of D and X. N >= 0.\n*\n*     D       (input) REAL array, length M\n*     Diagonal matrix D, stored as a vector of length M.\n*\n*     X       (input/output) COMPLEX array, dimension (LDX,N)\n*     On entry, the vector X to be scaled by D.\n*     On exit, the scaled vector.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the vector X. LDX >= 0.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x = NumRu::Lapack.clarscl2( d, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_d = argv[0];
  rblapack_x = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  n = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = n;
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;

  clarscl2_(&m, &n, d, x, &ldx);

  return rblapack_x;
}

void
init_lapack_clarscl2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clarscl2", rblapack_clarscl2, -1);
}
ruby-lapack-1.7.2/ext/dgeql2.c0000644000175000017500000001056712502221013015706 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgeql2_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* info);


static VALUE
rblapack_dgeql2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  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;

  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.dgeql2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGEQL2( M, N, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGEQL2 computes a QL factorization of a real m by n matrix A:\n*  A = Q * L.\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, if m >= n, the lower triangle of the subarray\n*          A(m-n+1:m,1:n) contains the n by n lower triangular matrix L;\n*          if m <= n, the elements on and below the (n-m)-th\n*          superdiagonal contain the m by n lower trapezoidal matrix L;\n*          the remaining elements, with the array TAU, represent the\n*          orthogonal matrix Q as a product of elementary reflectors\n*          (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 (N)\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(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in\n*  A(1:m-k+i-1,n-k+i), 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.dgeql2( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t 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, (n));

  dgeql2_(&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_dgeql2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgeql2", rblapack_dgeql2, -1);
}
ruby-lapack-1.7.2/ext/dsygvd.c0000644000175000017500000002600012502221022016015 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsygvd_(integer* itype, char* jobz, char* uplo, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* w, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_dsygvd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;

  integer lda;
  integer n;
  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  w, work, iwork, info, a, b = NumRu::Lapack.dsygvd( itype, jobz, uplo, a, b, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSYGVD computes all the eigenvalues, and optionally, the eigenvectors\n*  of a real generalized symmetric-definite eigenproblem, of the form\n*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A and\n*  B are assumed to be symmetric and B is also positive definite.\n*  If eigenvectors are desired, it uses a divide and conquer algorithm.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          Specifies the problem type to be solved:\n*          = 1:  A*x = (lambda)*B*x\n*          = 2:  A*B*x = (lambda)*x\n*          = 3:  B*A*x = (lambda)*x\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of A contains the\n*          upper triangular part of the matrix A.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of A contains\n*          the lower triangular part of the matrix A.\n*\n*          On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n*          matrix Z of eigenvectors.  The eigenvectors are normalized\n*          as follows:\n*          if ITYPE = 1 or 2, Z**T*B*Z = I;\n*          if ITYPE = 3, Z**T*inv(B)*Z = I.\n*          If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n*          or the lower triangle (if UPLO='L') of A, including the\n*          diagonal, is destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n*          On entry, the symmetric matrix B.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of B contains the\n*          upper triangular part of the matrix B.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of B contains\n*          the lower triangular part of the matrix B.\n*\n*          On exit, if INFO <= N, the part of B containing the matrix is\n*          overwritten by the triangular factor U or L from the Cholesky\n*          factorization B = U**T*U or B = L*L**T.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\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*          If N <= 1,               LWORK >= 1.\n*          If JOBZ = 'N' and N > 1, LWORK >= 2*N+1.\n*          If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal sizes of the WORK and IWORK\n*          arrays, returns these values as the first entries of the WORK\n*          and IWORK arrays, and no error message related to LWORK or\n*          LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.\n*          If N <= 1,                LIWORK >= 1.\n*          If JOBZ  = 'N' and N > 1, LIWORK >= 1.\n*          If JOBZ  = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK and IWORK arrays, and no error message related to\n*          LWORK or LIWORK 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:  DPOTRF or DSYEVD returned an error code:\n*             <= N:  if INFO = i and JOBZ = 'N', then the algorithm\n*                    failed to converge; i off-diagonal elements of an\n*                    intermediate tridiagonal form did not converge to\n*                    zero;\n*                    if INFO = i and JOBZ = 'V', then the algorithm\n*                    failed to compute an eigenvalue while working on\n*                    the submatrix lying in rows and columns INFO/(N+1)\n*                    through mod(INFO,N+1);\n*             > N:   if INFO = N + i, for 1 <= i <= N, then the leading\n*                    minor of order i of B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n*  Modified so that no backsubstitution is performed if DSYEVD fails to\n*  converge (NEIG in old code could be greater than N causing out of\n*  bounds reference to A - reported by Ralf Meyer).  Also corrected the\n*  description of INFO and the test on ITYPE. Sven, 16 Feb 05.\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, work, iwork, info, a, b = NumRu::Lapack.dsygvd( itype, jobz, uplo, a, b, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_itype = argv[0];
  rblapack_jobz = argv[1];
  rblapack_uplo = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  if (argc == 7) {
    rblapack_lwork = argv[5];
    rblapack_liwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  itype = NUM2INT(rblapack_itype);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = 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*);
  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  if (rblapack_liwork == Qnil)
    liwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  if (rblapack_lwork == Qnil)
    lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 2*n+1 : lsame_(&jobz,"V") ? 1+6*n+2*n*n : 1;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dsygvd_(&itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, work, &lwork, iwork, &liwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_w, rblapack_work, rblapack_iwork, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_dsygvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsygvd", rblapack_dsygvd, -1);
}
ruby-lapack-1.7.2/ext/sgetf2.c0000644000175000017500000001011012502221021015701 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgetf2_(integer* m, integer* n, real* a, integer* lda, integer* ipiv, integer* info);


static VALUE
rblapack_sgetf2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *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  ipiv, info, a = NumRu::Lapack.sgetf2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGETF2( M, N, A, LDA, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGETF2 computes an LU factorization of a general m-by-n matrix A\n*  using partial pivoting with row interchanges.\n*\n*  The factorization has the form\n*     A = P * L * U\n*  where P is a permutation matrix, L is lower triangular with unit\n*  diagonal elements (lower trapezoidal if m > n), and U is upper\n*  triangular (upper trapezoidal if m < n).\n*\n*  This is the right-looking Level 2 BLAS version of the algorithm.\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) REAL array, dimension (LDA,N)\n*          On entry, the m by n matrix to be factored.\n*          On exit, the factors L and U from the factorization\n*          A = P*L*U; the unit diagonal elements of L are not stored.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  IPIV    (output) INTEGER array, dimension (min(M,N))\n*          The pivot indices; for 1 <= i <= min(M,N), row i of the\n*          matrix was interchanged with row IPIV(i).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*          > 0: if INFO = k, U(k,k) is exactly zero. The factorization\n*               has been completed, but the factor U is exactly\n*               singular, and division by zero will occur if it is used\n*               to solve a system of equations.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, a = NumRu::Lapack.sgetf2( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  sgetf2_(&m, &n, a, &lda, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_a);
}

void
init_lapack_sgetf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgetf2", rblapack_sgetf2, -1);
}
ruby-lapack-1.7.2/ext/sopgtr.c0000644000175000017500000001017212502221017016042 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sopgtr_(char* uplo, integer* n, real* ap, real* tau, real* q, integer* ldq, real* work, integer* info);


static VALUE
rblapack_sopgtr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_q;
  real *q; 
  VALUE rblapack_info;
  integer info; 
  real *work;

  integer ldap;
  integer ldtau;
  integer ldq;
  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  q, info = NumRu::Lapack.sopgtr( uplo, ap, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SOPGTR generates a real orthogonal matrix Q which is defined as the\n*  product of n-1 elementary reflectors H(i) of order n, as returned by\n*  SSPTRD using packed storage:\n*\n*  if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),\n*\n*  if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U': Upper triangular packed storage used in previous\n*                 call to SSPTRD;\n*          = 'L': Lower triangular packed storage used in previous\n*                 call to SSPTRD.\n*\n*  N       (input) INTEGER\n*          The order of the matrix Q. N >= 0.\n*\n*  AP      (input) REAL array, dimension (N*(N+1)/2)\n*          The vectors which define the elementary reflectors, as\n*          returned by SSPTRD.\n*\n*  TAU     (input) REAL array, dimension (N-1)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by SSPTRD.\n*\n*  Q       (output) REAL array, dimension (LDQ,N)\n*          The N-by-N orthogonal matrix Q.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q. LDQ >= max(1,N).\n*\n*  WORK    (workspace) REAL array, dimension (N-1)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  q, info = NumRu::Lapack.sopgtr( uplo, ap, tau, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_tau = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  ldtau = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  n = ldtau+1;
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  ldq = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  q = NA_PTR_TYPE(rblapack_q, real*);
  work = ALLOC_N(real, (n-1));

  sopgtr_(&uplo, &n, ap, tau, q, &ldq, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_q, rblapack_info);
}

void
init_lapack_sopgtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sopgtr", rblapack_sopgtr, -1);
}
ruby-lapack-1.7.2/ext/zlaqr0.c0000644000175000017500000002622112502221020015731 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlaqr0_(logical* wantt, logical* wantz, integer* n, integer* ilo, integer* ihi, doublecomplex* h, integer* ldh, doublecomplex* w, integer* iloz, integer* ihiz, doublecomplex* z, integer* ldz, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zlaqr0(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantt;
  logical wantt; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_h;
  doublecomplex *h; 
  VALUE rblapack_iloz;
  integer iloz; 
  VALUE rblapack_ihiz;
  integer ihiz; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_ldz;
  integer ldz; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_w;
  doublecomplex *w; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_h_out__;
  doublecomplex *h_out__;
  VALUE rblapack_z_out__;
  doublecomplex *z_out__;

  integer ldh;
  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  w, work, info, h, z = NumRu::Lapack.zlaqr0( wantt, wantz, ilo, ihi, h, iloz, ihiz, z, ldz, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     ZLAQR0 computes the eigenvalues of a Hessenberg matrix H\n*     and, optionally, the matrices T and Z from the Schur decomposition\n*     H = Z T Z**H, where T is an upper triangular matrix (the\n*     Schur form), and Z is the unitary matrix of Schur vectors.\n*\n*     Optionally Z may be postmultiplied into an input unitary\n*     matrix Q so that this routine can give the Schur factorization\n*     of a matrix A which has been reduced to the Hessenberg form H\n*     by the unitary matrix Q:  A = Q*H*Q**H = (QZ)*H*(QZ)**H.\n*\n\n*     Arguments\n*     =========\n*\n*     WANTT   (input) LOGICAL\n*          = .TRUE. : the full Schur form T is required;\n*          = .FALSE.: only eigenvalues are required.\n*\n*     WANTZ   (input) LOGICAL\n*          = .TRUE. : the matrix of Schur vectors Z is required;\n*          = .FALSE.: Schur vectors are not required.\n*\n*     N     (input) INTEGER\n*           The order of the matrix H.  N .GE. 0.\n*\n*     ILO   (input) INTEGER\n*     IHI   (input) INTEGER\n*           It is assumed that H is already upper triangular in rows\n*           and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n*           H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n*           previous call to ZGEBAL, and then passed to ZGEHRD when the\n*           matrix output by ZGEBAL is reduced to Hessenberg form.\n*           Otherwise, ILO and IHI should be set to 1 and N,\n*           respectively.  If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n*           If N = 0, then ILO = 1 and IHI = 0.\n*\n*     H     (input/output) COMPLEX*16 array, dimension (LDH,N)\n*           On entry, the upper Hessenberg matrix H.\n*           On exit, if INFO = 0 and WANTT is .TRUE., then H\n*           contains the upper triangular matrix T from the Schur\n*           decomposition (the Schur form). If INFO = 0 and WANT is\n*           .FALSE., then the contents of H are unspecified on exit.\n*           (The output value of H when INFO.GT.0 is given under the\n*           description of INFO below.)\n*\n*           This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n*           j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n*\n*     LDH   (input) INTEGER\n*           The leading dimension of the array H. LDH .GE. max(1,N).\n*\n*     W        (output) COMPLEX*16 array, dimension (N)\n*           The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored\n*           in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are\n*           stored in the same order as on the diagonal of the Schur\n*           form returned in H, with W(i) = H(i,i).\n*\n*     Z     (input/output) COMPLEX*16 array, dimension (LDZ,IHI)\n*           If WANTZ is .FALSE., then Z is not referenced.\n*           If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n*           replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n*           orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n*           (The output value of Z when INFO.GT.0 is given under\n*           the description of INFO below.)\n*\n*     LDZ   (input) INTEGER\n*           The leading dimension of the array Z.  if WANTZ is .TRUE.\n*           then LDZ.GE.MAX(1,IHIZ).  Otherwize, LDZ.GE.1.\n*\n*     WORK  (workspace/output) COMPLEX*16 array, dimension LWORK\n*           On exit, if LWORK = -1, WORK(1) returns an estimate of\n*           the optimal value for LWORK.\n*\n*     LWORK (input) INTEGER\n*           The dimension of the array WORK.  LWORK .GE. max(1,N)\n*           is sufficient, but LWORK typically as large as 6*N may\n*           be required for optimal performance.  A workspace query\n*           to determine the optimal workspace size is recommended.\n*\n*           If LWORK = -1, then ZLAQR0 does a workspace query.\n*           In this case, ZLAQR0 checks the input parameters and\n*           estimates the optimal workspace size for the given\n*           values of N, ILO and IHI.  The estimate is returned\n*           in WORK(1).  No error message related to LWORK is\n*           issued by XERBLA.  Neither H nor Z are accessed.\n*\n*\n*     INFO  (output) INTEGER\n*             =  0:  successful exit\n*           .GT. 0:  if INFO = i, ZLAQR0 failed to compute all of\n*                the eigenvalues.  Elements 1:ilo-1 and i+1:n of WR\n*                and WI contain those eigenvalues which have been\n*                successfully computed.  (Failures are rare.)\n*\n*                If INFO .GT. 0 and WANT is .FALSE., then on exit,\n*                the remaining unconverged eigenvalues are the eigen-\n*                values of the upper Hessenberg matrix rows and\n*                columns ILO through INFO of the final, output\n*                value of H.\n*\n*                If INFO .GT. 0 and WANTT is .TRUE., then on exit\n*\n*           (*)  (initial value of H)*U  = U*(final value of H)\n*\n*                where U is a unitary matrix.  The final\n*                value of  H is upper Hessenberg and triangular in\n*                rows and columns INFO+1 through IHI.\n*\n*                If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n*\n*                  (final value of Z(ILO:IHI,ILOZ:IHIZ)\n*                   =  (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n*\n*                where U is the unitary matrix in (*) (regard-\n*                less of the value of WANTT.)\n*\n*                If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n*                accessed.\n*\n\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n*     References:\n*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n*       Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n*       Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n*       929--947, 2002.\n*\n*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n*       Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n*       of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n*     ================================================================\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, work, info, h, z = NumRu::Lapack.zlaqr0( wantt, wantz, ilo, ihi, h, iloz, ihiz, z, ldz, [: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_wantt = argv[0];
  rblapack_wantz = argv[1];
  rblapack_ilo = argv[2];
  rblapack_ihi = argv[3];
  rblapack_h = argv[4];
  rblapack_iloz = argv[5];
  rblapack_ihiz = argv[6];
  rblapack_z = argv[7];
  rblapack_ldz = 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;
  }

  wantt = (rblapack_wantt == Qtrue);
  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (5th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_DCOMPLEX)
    rblapack_h = na_change_type(rblapack_h, NA_DCOMPLEX);
  h = NA_PTR_TYPE(rblapack_h, doublecomplex*);
  ihiz = NUM2INT(rblapack_ihiz);
  ldz = NUM2INT(rblapack_ldz);
  wantz = (rblapack_wantz == Qtrue);
  iloz = NUM2INT(rblapack_iloz);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ihi = NUM2INT(rblapack_ihi);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (8th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_z) != (wantz ? ldz : 0))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantz ? ldz : 0);
  if (NA_SHAPE1(rblapack_z) != (wantz ? ihi : 0))
    rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantz ? ihi : 0);
  if (NA_TYPE(rblapack_z) != NA_DCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublecomplex*);
  MEMCPY(h_out__, h, doublecomplex, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = wantz ? ldz : 0;
    shape[1] = wantz ? ihi : 0;
    rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublecomplex*);
  MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  zlaqr0_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, w, &iloz, &ihiz, z, &ldz, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_w, rblapack_work, rblapack_info, rblapack_h, rblapack_z);
}

void
init_lapack_zlaqr0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlaqr0", rblapack_zlaqr0, -1);
}
ruby-lapack-1.7.2/ext/dposvxx.c0000644000175000017500000006266712502221023016254 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dposvxx_(char* fact, char* uplo, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* af, integer* ldaf, char* equed, doublereal* s, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* rpvgrw, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dposvxx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_af;
  doublereal *af; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_params;
  doublereal *params; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_rpvgrw;
  doublereal rpvgrw; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_err_bnds_norm;
  doublereal *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  doublereal *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  VALUE rblapack_af_out__;
  doublereal *af_out__;
  VALUE rblapack_s_out__;
  doublereal *s_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;
  VALUE rblapack_params_out__;
  doublereal *params_out__;
  doublereal *work;
  integer *iwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer nparams;
  integer ldx;
  integer n_err_bnds;

  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  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, equed, s, b, params = NumRu::Lapack.dposvxx( fact, uplo, a, af, equed, s, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     DPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T\n*     to compute the solution to a double precision system of linear equations\n*     A * X = B, where A is an N-by-N symmetric positive definite matrix\n*     and X and B are N-by-NRHS matrices.\n*\n*     If requested, both normwise and maximum componentwise error bounds\n*     are returned. DPOSVXX will return a solution with a tiny\n*     guaranteed error (O(eps) where eps is the working machine\n*     precision) unless the matrix is very ill-conditioned, in which\n*     case a warning is returned. Relevant condition numbers also are\n*     calculated and returned.\n*\n*     DPOSVXX accepts user-provided factorizations and equilibration\n*     factors; see the definitions of the FACT and EQUED options.\n*     Solving with refinement and using a factorization from a previous\n*     DPOSVXX call will also produce a solution with either O(eps)\n*     errors or warnings, but we cannot make that claim for general\n*     user-provided factorizations and equilibration factors if they\n*     differ from what DPOSVXX would itself produce.\n*\n*     Description\n*     ===========\n*\n*     The following steps are performed:\n*\n*     1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n*     the system:\n*\n*       diag(S)*A*diag(S)     *inv(diag(S))*X = diag(S)*B\n*\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n*     2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n*     factor the matrix A (after equilibration if FACT = 'E') as\n*        A = U**T* U,  if UPLO = 'U', or\n*        A = L * L**T,  if UPLO = 'L',\n*     where U is an upper triangular matrix and L is a lower triangular\n*     matrix.\n*\n*     3. If the leading i-by-i principal minor is not positive definite,\n*     then the routine returns with INFO = i. Otherwise, the factored\n*     form of A is used to estimate the condition number of the matrix\n*     A (see argument RCOND).  If the reciprocal of the condition number\n*     is less than machine precision, the routine still goes on to solve\n*     for X and compute error bounds as described below.\n*\n*     4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*     5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n*     the routine will use iterative refinement to try to get a small\n*     error and error bounds.  Refinement calculates the residual to at\n*     least twice the working precision.\n*\n*     6. If equilibration was used, the matrix X is premultiplied by\n*     diag(S) so that it solves the original system before\n*     equilibration.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     FACT    (input) CHARACTER*1\n*     Specifies whether or not the factored form of the matrix A is\n*     supplied on entry, and if not, whether the matrix A should be\n*     equilibrated before it is factored.\n*       = 'F':  On entry, AF contains the factored form of A.\n*               If EQUED is not 'N', the matrix A has been\n*               equilibrated with scaling factors given by S.\n*               A and AF are not modified.\n*       = 'N':  The matrix A will be copied to AF and factored.\n*       = 'E':  The matrix A will be equilibrated if necessary, then\n*               copied to AF and factored.\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*     On entry, the symmetric matrix A, except if FACT = 'F' and EQUED =\n*     'Y', then A must contain the equilibrated matrix\n*     diag(S)*A*diag(S).  If UPLO = 'U', the leading N-by-N upper\n*     triangular part of A contains the upper triangular part of the\n*     matrix A, and the strictly lower triangular part of A is not\n*     referenced.  If UPLO = 'L', the leading N-by-N lower triangular\n*     part of A contains the lower triangular part of the matrix A, and\n*     the strictly upper triangular part of A is not referenced.  A is\n*     not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED =\n*     'N' on exit.\n*\n*     On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n*     diag(S)*A*diag(S).\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input or output) DOUBLE PRECISION array, dimension (LDAF,N)\n*     If FACT = 'F', then AF is an input argument and on entry\n*     contains the triangular factor U or L from the Cholesky\n*     factorization A = U**T*U or A = L*L**T, in the same storage\n*     format as A.  If EQUED .ne. 'N', then AF is the factored\n*     form of the equilibrated matrix diag(S)*A*diag(S).\n*\n*     If FACT = 'N', then AF is an output argument and on exit\n*     returns the triangular factor U or L from the Cholesky\n*     factorization A = U**T*U or A = L*L**T of the original\n*     matrix A.\n*\n*     If FACT = 'E', then AF is an output argument and on exit\n*     returns the triangular factor U or L from the Cholesky\n*     factorization A = U**T*U or A = L*L**T of the equilibrated\n*     matrix A (see the description of A for the form of the\n*     equilibrated matrix).\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     EQUED   (input or output) CHARACTER*1\n*     Specifies the form of equilibration that was done.\n*       = 'N':  No equilibration (always true if FACT = 'N').\n*       = 'Y':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(S) * A * diag(S).\n*     EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*     output argument.\n*\n*     S       (input or output) DOUBLE PRECISION array, dimension (N)\n*     The row scale factors for A.  If EQUED = 'Y', A is multiplied on\n*     the left and right by diag(S).  S is an input argument if FACT =\n*     'F'; otherwise, S is an output argument.  If FACT = 'F' and EQUED\n*     = 'Y', each element of S must be positive.  If S is output, each\n*     element of S is a power of the radix. If S is input, each element\n*     of S should be a power of the radix to ensure a reliable solution\n*     and error estimates. Scaling by powers of the radix does not cause\n*     rounding errors unless the result underflows or overflows.\n*     Rounding errors during scaling lead to refining with a matrix that\n*     is not equivalent to the input matrix, producing error estimates\n*     that may not be reliable.\n*\n*     B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*     On entry, the N-by-NRHS right hand side matrix B.\n*     On exit,\n*     if EQUED = 'N', B is not modified;\n*     if EQUED = 'Y', B is overwritten by diag(S)*B;\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*     If INFO = 0, the N-by-NRHS solution matrix X to the original\n*     system of equations.  Note that A and B are modified on exit if\n*     EQUED .ne. 'N', and the solution to the equilibrated system is\n*     inv(diag(S))*X.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) DOUBLE PRECISION\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     RPVGRW  (output) DOUBLE PRECISION\n*     Reciprocal pivot growth.  On exit, this contains the reciprocal\n*     pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n*     norm is used.  If this is much less than 1, then the stability of\n*     the LU factorization of the (equilibrated) matrix A could be poor.\n*     This also means that the solution X, estimated condition numbers,\n*     and error bounds could be unreliable. If factorization fails with\n*     0 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, equed, s, b, params = NumRu::Lapack.dposvxx( fact, uplo, a, af, equed, s, b, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_equed = argv[4];
  rblapack_s = argv[5];
  rblapack_b = argv[6];
  rblapack_params = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  n_err_bnds = 3;
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (6th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
  af = NA_PTR_TYPE(rblapack_af, doublereal*);
  ldx = MAX(1,n);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (8th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (8th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_DFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
  params = NA_PTR_TYPE(rblapack_params, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[2];
    shape[0] = ldaf;
    shape[1] = n;
    rblapack_af_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  af_out__ = NA_PTR_TYPE(rblapack_af_out__, doublereal*);
  MEMCPY(af_out__, af, doublereal, NA_TOTAL(rblapack_af));
  rblapack_af = rblapack_af_out__;
  af = af_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
  MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
  MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(doublereal, (4*n));
  iwork = ALLOC_N(integer, (n));

  dposvxx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &equed, s, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_rpvgrw = rb_float_new((double)rpvgrw);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(13, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_a, rblapack_af, rblapack_equed, rblapack_s, rblapack_b, rblapack_params);
}

void
init_lapack_dposvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dposvxx", rblapack_dposvxx, -1);
}
ruby-lapack-1.7.2/ext/dla_geamv.c0000644000175000017500000001726012502221026016450 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dla_geamv_(integer* trans, integer* m, integer* n, doublereal* alpha, doublereal* a, integer* lda, doublereal* x, integer* incx, doublereal* beta, doublereal* y, integer* incy);


static VALUE
rblapack_dla_geamv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  integer trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_alpha;
  doublereal alpha; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_beta;
  doublereal beta; 
  VALUE rblapack_y;
  doublereal *y; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_y_out__;
  doublereal *y_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  y = NumRu::Lapack.dla_geamv( trans, m, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n*  Purpose\n*  =======\n*\n*  DLA_GEAMV  performs one of the matrix-vector operations\n*\n*          y := alpha*abs(A)*abs(x) + beta*abs(y),\n*     or   y := alpha*abs(A)'*abs(x) + beta*abs(y),\n*\n*  where alpha and beta are scalars, x and y are vectors and A is an\n*  m by n matrix.\n*\n*  This function is primarily used in calculating error bounds.\n*  To protect against underflow during evaluation, components in\n*  the resulting vector are perturbed away from zero by (N+1)\n*  times the underflow threshold.  To prevent unnecessarily large\n*  errors for block-structure embedded in general matrices,\n*  \"symbolically\" zero components are not perturbed.  A zero\n*  entry is considered \"symbolic\" if all multiplications involved\n*  in computing that entry have at least one zero multiplicand.\n*\n\n*  Arguments\n*  ==========\n*\n*  TRANS   (input) INTEGER\n*           On entry, TRANS specifies the operation to be performed as\n*           follows:\n*\n*             BLAS_NO_TRANS      y := alpha*abs(A)*abs(x) + beta*abs(y)\n*             BLAS_TRANS         y := alpha*abs(A')*abs(x) + beta*abs(y)\n*             BLAS_CONJ_TRANS    y := alpha*abs(A')*abs(x) + beta*abs(y)\n*\n*           Unchanged on exit.\n*\n*  M       (input) INTEGER\n*           On entry, M specifies the number of rows of the matrix A.\n*           M must be at least zero.\n*           Unchanged on exit.\n*\n*  N       (input) INTEGER\n*           On entry, N specifies the number of columns of the matrix A.\n*           N must be at least zero.\n*           Unchanged on exit.\n*\n*  ALPHA  - DOUBLE PRECISION\n*           On entry, ALPHA specifies the scalar alpha.\n*           Unchanged on exit.\n*\n*  A      - DOUBLE PRECISION   array of DIMENSION ( LDA, n )\n*           Before entry, the leading m by n part of the array A must\n*           contain the matrix of coefficients.\n*           Unchanged on exit.\n*\n*  LDA     (input) INTEGER\n*           On entry, LDA specifies the first dimension of A as declared\n*           in the calling (sub) program. LDA must be at least\n*           max( 1, m ).\n*           Unchanged on exit.\n*\n*  X       (input) DOUBLE PRECISION array, dimension\n*           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n*           and at least\n*           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n*           Before entry, the incremented array X must contain the\n*           vector x.\n*           Unchanged on exit.\n*\n*  INCX    (input) INTEGER\n*           On entry, INCX specifies the increment for the elements of\n*           X. INCX must not be zero.\n*           Unchanged on exit.\n*\n*  BETA   - DOUBLE PRECISION\n*           On entry, BETA specifies the scalar beta. When BETA is\n*           supplied as zero then Y need not be set on input.\n*           Unchanged on exit.\n*\n*  Y      - DOUBLE PRECISION\n*           Array of DIMENSION at least\n*           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n*           and at least\n*           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n*           Before entry with BETA non-zero, the incremented array Y\n*           must contain the vector y. On exit, Y is overwritten by the\n*           updated vector y.\n*\n*  INCY    (input) INTEGER\n*           On entry, INCY specifies the increment for the elements of\n*           Y. INCY must not be zero.\n*           Unchanged on exit.\n*\n*  Level 2 Blas routine.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  y = NumRu::Lapack.dla_geamv( trans, m, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_trans = argv[0];
  rblapack_m = argv[1];
  rblapack_alpha = argv[2];
  rblapack_a = argv[3];
  rblapack_x = argv[4];
  rblapack_incx = argv[5];
  rblapack_beta = argv[6];
  rblapack_y = argv[7];
  rblapack_incy = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = NUM2INT(rblapack_trans);
  alpha = NUM2DBL(rblapack_alpha);
  incx = NUM2INT(rblapack_incx);
  incy = NUM2INT(rblapack_incy);
  m = NUM2INT(rblapack_m);
  beta = NUM2DBL(rblapack_beta);
  lda = MAX(1, m);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_a) != lda)
    rb_raise(rb_eRuntimeError, "shape 0 of a must be MAX(1, m)");
  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*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (8th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (trans == ilatrans_("N") ? 1+(m-1)*abs(incy) : 1+(n-1)*abs(incy)))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", trans == ilatrans_("N") ? 1+(m-1)*abs(incy) : 1+(n-1)*abs(incy));
  if (NA_TYPE(rblapack_y) != NA_DFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
  y = NA_PTR_TYPE(rblapack_y, doublereal*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (5th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (trans == ilatrans_("N") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", trans == ilatrans_("N") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx ));
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = trans == ilatrans_("N") ? 1+(m-1)*abs(incy) : 1+(n-1)*abs(incy);
    rblapack_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
  MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  dla_geamv_(&trans, &m, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);

  return rblapack_y;
}

void
init_lapack_dla_geamv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dla_geamv", rblapack_dla_geamv, -1);
}
ruby-lapack-1.7.2/ext/dtrttp.c0000644000175000017500000000732312502221020016043 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtrttp_(char* uplo, integer* n, doublereal* a, integer* lda, doublereal* ap, integer* info);


static VALUE
rblapack_dtrttp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_info;
  integer info; 

  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  ap, info = NumRu::Lapack.dtrttp( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTRTTP( UPLO, N, A, LDA, AP, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTRTTP copies a triangular matrix A from full format (TR) to standard\n*  packed format (TP).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular.\n*          = 'L':  A is lower triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrices AP and A.  N >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*          On exit, the triangular matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AP      (output) DOUBLE PRECISION array, dimension (N*(N+1)/2\n*          On exit, the upper or lower triangular matrix A, packed\n*          columnwise in a linear array. The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ap, info = NumRu::Lapack.dtrttp( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);

  dtrttp_(&uplo, &n, a, &lda, ap, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_ap, rblapack_info);
}

void
init_lapack_dtrttp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtrttp", rblapack_dtrttp, -1);
}
ruby-lapack-1.7.2/ext/ssytri2x.c0000644000175000017500000001152512502221025016335 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssytri2x_(char* uplo, integer* n, real* a, integer* lda, integer* ipiv, real* work, integer* nb, integer* info);


static VALUE
rblapack_ssytri2x(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_nb;
  integer nb; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  real *work;

  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  info, a = NumRu::Lapack.ssytri2x( uplo, a, ipiv, nb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSYTRI2X computes the inverse of a real symmetric indefinite matrix\n*  A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n*  SSYTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the NNB diagonal matrix D and the multipliers\n*          used to obtain the factor U or L as computed by SSYTRF.\n*\n*          On exit, if INFO = 0, the (symmetric) inverse of the original\n*          matrix.  If UPLO = 'U', the upper triangular part of the\n*          inverse is formed and the part of A below the diagonal is not\n*          referenced; if UPLO = 'L' the lower triangular part of the\n*          inverse is formed and the part of A above the diagonal is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the NNB structure of D\n*          as determined by SSYTRF.\n*\n*  WORK    (workspace) REAL array, dimension (N+NNB+1,NNB+3)\n*\n*  NB      (input) INTEGER\n*          Block size\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, D(i,i) = 0; the matrix is singular and its\n*               inverse could not be computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.ssytri2x( uplo, a, ipiv, nb, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_nb = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  nb = NUM2INT(rblapack_nb);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(real, (n+nb+1)*(nb+3));

  ssytri2x_(&uplo, &n, a, &lda, ipiv, work, &nb, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_ssytri2x(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssytri2x", rblapack_ssytri2x, -1);
}
ruby-lapack-1.7.2/ext/spbcon.c0000644000175000017500000001077112502221014016012 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID spbcon_(char* uplo, integer* n, integer* kd, real* ab, integer* ldab, real* anorm, real* rcond, real* work, integer* iwork, integer* info);


static VALUE
rblapack_spbcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_anorm;
  real anorm; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_info;
  integer info; 
  real *work;
  integer *iwork;

  integer ldab;
  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  rcond, info = NumRu::Lapack.spbcon( uplo, kd, ab, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPBCON estimates the reciprocal of the condition number (in the\n*  1-norm) of a real symmetric positive definite band matrix using the\n*  Cholesky factorization A = U**T*U or A = L*L**T computed by SPBTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangular factor stored in AB;\n*          = 'L':  Lower triangular factor stored in AB.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input) REAL array, dimension (LDAB,N)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**T*U or A = L*L**T of the band matrix A, stored in the\n*          first KD+1 rows of the array.  The j-th column of U or L is\n*          stored in the j-th column of the array AB as follows:\n*          if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO ='L', AB(1+i-j,j)    = L(i,j) for j<=i<=min(n,j+kd).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  ANORM   (input) REAL\n*          The 1-norm (or infinity-norm) of the symmetric band matrix A.\n*\n*  RCOND   (output) REAL\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n*          estimate of the 1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) REAL array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.spbcon( uplo, kd, ab, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  rblapack_anorm = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  kd = NUM2INT(rblapack_kd);
  anorm = (real)NUM2DBL(rblapack_anorm);
  work = ALLOC_N(real, (3*n));
  iwork = ALLOC_N(integer, (n));

  spbcon_(&uplo, &n, &kd, ab, &ldab, &anorm, &rcond, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_spbcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "spbcon", rblapack_spbcon, -1);
}
ruby-lapack-1.7.2/ext/cgelq2.c0000644000175000017500000001023412502221024015676 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgelq2_(integer* m, integer* n, complex* a, integer* lda, complex* tau, complex* work, integer* info);


static VALUE
rblapack_cgelq2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  complex *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.cgelq2( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGELQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGELQ2 computes an LQ factorization of a complex 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) COMPLEX 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 unitary 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) COMPLEX array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace) COMPLEX 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 complex scalar, and v is a complex vector with\n*  v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in\n*  A(i,i+1: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.cgelq2( 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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  m = lda;
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(complex, (m));

  cgelq2_(&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_cgelq2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgelq2", rblapack_cgelq2, -1);
}
ruby-lapack-1.7.2/ext/dlaqsb.c0000644000175000017500000001315212502221023015770 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaqsb_(char* uplo, integer* n, integer* kd, doublereal* ab, integer* ldab, doublereal* s, doublereal* scond, doublereal* amax, char* equed);


static VALUE
rblapack_dlaqsb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_scond;
  doublereal scond; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_ab_out__;
  doublereal *ab_out__;

  integer ldab;
  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  equed, ab = NumRu::Lapack.dlaqsb( uplo, kd, ab, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )\n\n*  Purpose\n*  =======\n*\n*  DLAQSB equilibrates a symmetric band matrix A using the scaling\n*  factors in the vector S.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of super-diagonals of the matrix A if UPLO = 'U',\n*          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*          On exit, if INFO = 0, the triangular factor U or L from the\n*          Cholesky factorization A = U'*U or A = L*L' of the band\n*          matrix A, in the same storage format as A.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  S       (input) DOUBLE PRECISION array, dimension (N)\n*          The scale factors for A.\n*\n*  SCOND   (input) DOUBLE PRECISION\n*          Ratio of the smallest S(i) to the largest S(i).\n*\n*  AMAX    (input) DOUBLE PRECISION\n*          Absolute value of largest matrix entry.\n*\n*  EQUED   (output) CHARACTER*1\n*          Specifies whether or not equilibration was done.\n*          = 'N':  No equilibration.\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*\n*  Internal Parameters\n*  ===================\n*\n*  THRESH is a threshold value used to decide if scaling should be done\n*  based on the ratio of the scaling factors.  If SCOND < THRESH,\n*  scaling is done.\n*\n*  LARGE and SMALL are threshold values used to decide if scaling should\n*  be done based on the absolute size of the largest matrix element.\n*  If AMAX > LARGE or AMAX < SMALL, scaling is done.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  equed, ab = NumRu::Lapack.dlaqsb( uplo, kd, ab, s, scond, amax, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  rblapack_s = argv[3];
  rblapack_scond = argv[4];
  rblapack_amax = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  scond = NUM2DBL(rblapack_scond);
  kd = NUM2INT(rblapack_kd);
  amax = NUM2DBL(rblapack_amax);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (4th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
  MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  dlaqsb_(&uplo, &n, &kd, ab, &ldab, s, &scond, &amax, &equed);

  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(2, rblapack_equed, rblapack_ab);
}

void
init_lapack_dlaqsb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaqsb", rblapack_dlaqsb, -1);
}
ruby-lapack-1.7.2/ext/dpptri.c0000644000175000017500000000735712502221023016036 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dpptri_(char* uplo, integer* n, doublereal* ap, integer* info);


static VALUE
rblapack_dpptri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublereal *ap_out__;


  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  info, ap = NumRu::Lapack.dpptri( uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPPTRI( UPLO, N, AP, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPPTRI computes the inverse of a real symmetric positive definite\n*  matrix A using the Cholesky factorization A = U**T*U or A = L*L**T\n*  computed by DPPTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangular factor is stored in AP;\n*          = 'L':  Lower triangular factor is stored in AP.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          On entry, the triangular factor U or L from the Cholesky\n*          factorization A = U**T*U or A = L*L**T, packed columnwise as\n*          a linear array.  The j-th column of U or L is stored in the\n*          array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n*          On exit, the upper or lower triangle of the (symmetric)\n*          inverse of A, overwriting the input factor U or L.\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,i) element of the factor U or L is\n*                zero, and the inverse could not be computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ap = NumRu::Lapack.dpptri( uplo, n, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_n = argv[1];
  rblapack_ap = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
  MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  dpptri_(&uplo, &n, ap, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ap);
}

void
init_lapack_dpptri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dpptri", rblapack_dpptri, -1);
}
ruby-lapack-1.7.2/ext/slaed4.c0000644000175000017500000001225012502221020015671 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaed4_(integer* n, integer* i, real* d, real* z, real* delta, real* rho, real* dlam, integer* info);


static VALUE
rblapack_slaed4(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_i;
  integer i; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_rho;
  real rho; 
  VALUE rblapack_delta;
  real *delta; 
  VALUE rblapack_dlam;
  real dlam; 
  VALUE rblapack_info;
  integer info; 

  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  delta, dlam, info = NumRu::Lapack.slaed4( i, d, z, rho, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO )\n\n*  Purpose\n*  =======\n*\n*  This subroutine computes the I-th updated eigenvalue of a symmetric\n*  rank-one modification to a diagonal matrix whose elements are\n*  given in the array d, and that\n*\n*             D(i) < D(j)  for  i < j\n*\n*  and that RHO > 0.  This is arranged by the calling routine, and is\n*  no loss in generality.  The rank-one modified system is thus\n*\n*             diag( D )  +  RHO *  Z * Z_transpose.\n*\n*  where we assume the Euclidean norm of Z is 1.\n*\n*  The method consists of approximating the rational functions in the\n*  secular equation by simpler interpolating rational functions.\n*\n\n*  Arguments\n*  =========\n*\n*  N      (input) INTEGER\n*         The length of all arrays.\n*\n*  I      (input) INTEGER\n*         The index of the eigenvalue to be computed.  1 <= I <= N.\n*\n*  D      (input) REAL array, dimension (N)\n*         The original eigenvalues.  It is assumed that they are in\n*         order, D(I) < D(J)  for I < J.\n*\n*  Z      (input) REAL array, dimension (N)\n*         The components of the updating vector.\n*\n*  DELTA  (output) REAL array, dimension (N)\n*         If N .GT. 2, DELTA contains (D(j) - lambda_I) in its  j-th\n*         component.  If N = 1, then DELTA(1) = 1. If N = 2, see SLAED5\n*         for detail. The vector DELTA contains the information necessary\n*         to construct the eigenvectors by SLAED3 and SLAED9.\n*\n*  RHO    (input) REAL\n*         The scalar in the symmetric updating formula.\n*\n*  DLAM   (output) REAL\n*         The computed lambda_I, the I-th updated eigenvalue.\n*\n*  INFO   (output) INTEGER\n*         = 0:  successful exit\n*         > 0:  if INFO = 1, the updating process failed.\n*\n*  Internal Parameters\n*  ===================\n*\n*  Logical variable ORGATI (origin-at-i?) is used for distinguishing\n*  whether D(i) or D(i+1) is treated as the origin.\n*\n*            ORGATI = .true.    origin at i\n*            ORGATI = .false.   origin at i+1\n*\n*   Logical variable SWTCH3 (switch-for-3-poles?) is for noting\n*   if we are working with THREE poles!\n*\n*   MAXIT is the maximum number of iterations allowed for each\n*   eigenvalue.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ren-Cang Li, Computer Science Division, University of California\n*     at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  delta, dlam, info = NumRu::Lapack.slaed4( i, d, z, rho, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_i = argv[0];
  rblapack_d = argv[1];
  rblapack_z = argv[2];
  rblapack_rho = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  i = NUM2INT(rblapack_i);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (3th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of z");
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  rho = (real)NUM2DBL(rblapack_rho);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_delta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  delta = NA_PTR_TYPE(rblapack_delta, real*);

  slaed4_(&n, &i, d, z, delta, &rho, &dlam, &info);

  rblapack_dlam = rb_float_new((double)dlam);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_delta, rblapack_dlam, rblapack_info);
}

void
init_lapack_slaed4(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaed4", rblapack_slaed4, -1);
}
ruby-lapack-1.7.2/ext/ztpcon.c0000644000175000017500000001071412502221025016042 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztpcon_(char* norm, char* uplo, char* diag, integer* n, doublecomplex* ap, doublereal* rcond, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_ztpcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_info;
  integer info; 
  doublecomplex *work;
  doublereal *rwork;

  integer ldap;
  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  rcond, info = NumRu::Lapack.ztpcon( norm, uplo, diag, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTPCON estimates the reciprocal of the condition number of a packed\n*  triangular matrix A, in either the 1-norm or the infinity-norm.\n*\n*  The norm of A is computed and an estimate is obtained for\n*  norm(inv(A)), then the reciprocal of the condition number is\n*  computed as\n*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies whether the 1-norm condition number or the\n*          infinity-norm condition number is required:\n*          = '1' or 'O':  1-norm;\n*          = 'I':         Infinity-norm.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          The upper or lower triangular matrix A, packed columnwise in\n*          a linear array.  The j-th column of A is stored in the array\n*          AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          If DIAG = 'U', the diagonal elements of A are not referenced\n*          and are assumed to be 1.\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(norm(A) * norm(inv(A))).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.ztpcon( norm, uplo, diag, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_diag = argv[2];
  rblapack_ap = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (n));

  ztpcon_(&norm, &uplo, &diag, &n, ap, &rcond, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_ztpcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztpcon", rblapack_ztpcon, -1);
}
ruby-lapack-1.7.2/ext/dgbsvxx.c0000644000175000017500000007406412502221023016220 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgbsvxx_(char* fact, char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, doublereal* ab, integer* ldab, doublereal* afb, integer* ldafb, integer* ipiv, char* equed, doublereal* r, doublereal* c, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* rpvgrw, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dgbsvxx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_afb;
  doublereal *afb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_r;
  doublereal *r; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_params;
  doublereal *params; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_rpvgrw;
  doublereal rpvgrw; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_err_bnds_norm;
  doublereal *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  doublereal *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublereal *ab_out__;
  VALUE rblapack_afb_out__;
  doublereal *afb_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  VALUE rblapack_r_out__;
  doublereal *r_out__;
  VALUE rblapack_c_out__;
  doublereal *c_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;
  VALUE rblapack_params_out__;
  doublereal *params_out__;
  doublereal *work;
  integer *iwork;

  integer ldab;
  integer n;
  integer ldafb;
  integer ldb;
  integer nrhs;
  integer nparams;
  integer ldx;
  integer n_err_bnds;

  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  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, ab, afb, ipiv, equed, r, c, b, params = NumRu::Lapack.dgbsvxx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     DGBSVXX uses the LU factorization to compute the solution to a\n*     double precision system of linear equations  A * X = B,  where A is an\n*     N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n*     If requested, both normwise and maximum componentwise error bounds\n*     are returned. DGBSVXX will return a solution with a tiny\n*     guaranteed error (O(eps) where eps is the working machine\n*     precision) unless the matrix is very ill-conditioned, in which\n*     case a warning is returned. Relevant condition numbers also are\n*     calculated and returned.\n*\n*     DGBSVXX accepts user-provided factorizations and equilibration\n*     factors; see the definitions of the FACT and EQUED options.\n*     Solving with refinement and using a factorization from a previous\n*     DGBSVXX call will also produce a solution with either O(eps)\n*     errors or warnings, but we cannot make that claim for general\n*     user-provided factorizations and equilibration factors if they\n*     differ from what DGBSVXX would itself produce.\n*\n*     Description\n*     ===========\n*\n*     The following steps are performed:\n*\n*     1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n*     the system:\n*\n*       TRANS = 'N':  diag(R)*A*diag(C)     *inv(diag(C))*X = diag(R)*B\n*       TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n*       TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n*     or diag(C)*B (if TRANS = 'T' or 'C').\n*\n*     2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n*     the matrix A (after equilibration if FACT = 'E') as\n*\n*       A = P * L * U,\n*\n*     where P is a permutation matrix, L is a unit lower triangular\n*     matrix, and U is upper triangular.\n*\n*     3. If some U(i,i)=0, so that U is exactly singular, then the\n*     routine returns with INFO = i. Otherwise, the factored form of A\n*     is used to estimate the condition number of the matrix A (see\n*     argument RCOND). If the reciprocal of the condition number is less\n*     than machine precision, the routine still goes on to solve for X\n*     and compute error bounds as described below.\n*\n*     4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*     5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n*     the routine will use iterative refinement to try to get a small\n*     error and error bounds.  Refinement calculates the residual to at\n*     least twice the working precision.\n*\n*     6. If equilibration was used, the matrix X is premultiplied by\n*     diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n*     that it solves the original system before equilibration.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     FACT    (input) CHARACTER*1\n*     Specifies whether or not the factored form of the matrix A is\n*     supplied on entry, and if not, whether the matrix A should be\n*     equilibrated before it is factored.\n*       = 'F':  On entry, AF and IPIV contain the factored form of A.\n*               If EQUED is not 'N', the matrix A has been\n*               equilibrated with scaling factors given by R and C.\n*               A, AF, and IPIV are not modified.\n*       = 'N':  The matrix A will be copied to AF and factored.\n*       = 'E':  The matrix A will be equilibrated if necessary, then\n*               copied to AF and factored.\n*\n*     TRANS   (input) CHARACTER*1\n*     Specifies the form of the system of equations:\n*       = 'N':  A * X = B     (No transpose)\n*       = 'T':  A**T * X = B  (Transpose)\n*       = 'C':  A**H * X = B  (Conjugate Transpose = Transpose)\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     KL      (input) INTEGER\n*     The number of subdiagonals within the band of A.  KL >= 0.\n*\n*     KU      (input) INTEGER\n*     The number of superdiagonals within the band of A.  KU >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n*     On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n*     The j-th column of A is stored in the j-th column of the\n*     array AB as follows:\n*     AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n*     If FACT = 'F' and EQUED is not 'N', then AB must have been\n*     equilibrated by the scaling factors in R and/or C.  AB is not\n*     modified if FACT = 'F' or 'N', or if FACT = 'E' and\n*     EQUED = 'N' on exit.\n*\n*     On exit, if EQUED .ne. 'N', A is scaled as follows:\n*     EQUED = 'R':  A := diag(R) * A\n*     EQUED = 'C':  A := A * diag(C)\n*     EQUED = 'B':  A := diag(R) * A * diag(C).\n*\n*     LDAB    (input) INTEGER\n*     The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*     AFB     (input or output) DOUBLE PRECISION array, dimension (LDAFB,N)\n*     If FACT = 'F', then AFB is an input argument and on entry\n*     contains details of the LU factorization of the band matrix\n*     A, as computed by DGBTRF.  U is stored as an upper triangular\n*     band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n*     and the multipliers used during the factorization are stored\n*     in rows KL+KU+2 to 2*KL+KU+1.  If EQUED .ne. 'N', then AFB is\n*     the factored form of the equilibrated matrix A.\n*\n*     If FACT = 'N', then AF is an output argument and on exit\n*     returns the factors L and U from the factorization A = P*L*U\n*     of the original matrix A.\n*\n*     If FACT = 'E', then AF is an output argument and on exit\n*     returns the factors L and U from the factorization A = P*L*U\n*     of the equilibrated matrix A (see the description of A for\n*     the form of the equilibrated matrix).\n*\n*     LDAFB   (input) INTEGER\n*     The leading dimension of the array AFB.  LDAFB >= 2*KL+KU+1.\n*\n*     IPIV    (input or output) INTEGER array, dimension (N)\n*     If FACT = 'F', then IPIV is an input argument and on entry\n*     contains the pivot indices from the factorization A = P*L*U\n*     as computed by DGETRF; row i of the matrix was interchanged\n*     with row IPIV(i).\n*\n*     If FACT = 'N', then IPIV is an output argument and on exit\n*     contains the pivot indices from the factorization A = P*L*U\n*     of the original matrix A.\n*\n*     If FACT = 'E', then IPIV is an output argument and on exit\n*     contains the pivot indices from the factorization A = P*L*U\n*     of the equilibrated matrix A.\n*\n*     EQUED   (input or output) CHARACTER*1\n*     Specifies the form of equilibration that was done.\n*       = 'N':  No equilibration (always true if FACT = 'N').\n*       = 'R':  Row equilibration, i.e., A has been premultiplied by\n*               diag(R).\n*       = 'C':  Column equilibration, i.e., A has been postmultiplied\n*               by diag(C).\n*       = 'B':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(R) * A * diag(C).\n*     EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*     output argument.\n*\n*     R       (input or output) DOUBLE PRECISION array, dimension (N)\n*     The row scale factors for A.  If EQUED = 'R' or 'B', A is\n*     multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n*     is not accessed.  R is an input argument if FACT = 'F';\n*     otherwise, R is an output argument.  If FACT = 'F' and\n*     EQUED = 'R' or 'B', each element of R must be positive.\n*     If R is output, each element of R is a power of the radix.\n*     If R is input, each element of R should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     C       (input or output) DOUBLE PRECISION array, dimension (N)\n*     The column scale factors for A.  If EQUED = 'C' or 'B', A is\n*     multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n*     is not accessed.  C is an input argument if FACT = 'F';\n*     otherwise, C is an output argument.  If FACT = 'F' and\n*     EQUED = 'C' or 'B', each element of C must be positive.\n*     If C is output, each element of C is a power of the radix.\n*     If C is input, each element of C should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*     On entry, the N-by-NRHS right hand side matrix B.\n*     On exit,\n*     if EQUED = 'N', B is not modified;\n*     if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n*        diag(R)*B;\n*     if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n*        overwritten by diag(C)*B.\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*     If INFO = 0, the N-by-NRHS solution matrix X to the original\n*     system of equations.  Note that A and B are modified on exit\n*     if EQUED .ne. 'N', and the solution to the equilibrated system is\n*     inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n*     inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) DOUBLE PRECISION\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     RPVGRW  (output) DOUBLE PRECISION\n*     Reciprocal pivot growth.  On exit, this contains the reciprocal\n*     pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n*     norm is used.  If this is much less than 1, then the stability of\n*     the LU factorization of the (equilibrated) matrix A could be poor.\n*     This also means that the solution X, estimated condition numbers,\n*     and error bounds could be unreliable. If factorization fails with\n*     0 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, ab, afb, ipiv, equed, r, c, b, params = NumRu::Lapack.dgbsvxx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_fact = argv[0];
  rblapack_trans = argv[1];
  rblapack_kl = argv[2];
  rblapack_ku = argv[3];
  rblapack_ab = argv[4];
  rblapack_afb = argv[5];
  rblapack_ipiv = argv[6];
  rblapack_equed = argv[7];
  rblapack_r = argv[8];
  rblapack_c = argv[9];
  rblapack_b = argv[10];
  rblapack_params = argv[11];
  if (argc == 12) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_r))
    rb_raise(rb_eArgError, "r (9th argument) must be NArray");
  if (NA_RANK(rblapack_r) != 1)
    rb_raise(rb_eArgError, "rank of r (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_r) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_r) != NA_DFLOAT)
    rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
  r = NA_PTR_TYPE(rblapack_r, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (11th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (11th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  n_err_bnds = 3;
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
  ldafb = NA_SHAPE0(rblapack_afb);
  if (NA_SHAPE1(rblapack_afb) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_afb) != NA_DFLOAT)
    rblapack_afb = na_change_type(rblapack_afb, NA_DFLOAT);
  afb = NA_PTR_TYPE(rblapack_afb, doublereal*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (10th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (10th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  ldx = MAX(1,n);
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (12th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (12th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_DFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
  params = NA_PTR_TYPE(rblapack_params, doublereal*);
  equed = StringValueCStr(rblapack_equed)[0];
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
  MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldafb;
    shape[1] = n;
    rblapack_afb_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  afb_out__ = NA_PTR_TYPE(rblapack_afb_out__, doublereal*);
  MEMCPY(afb_out__, afb, doublereal, NA_TOTAL(rblapack_afb));
  rblapack_afb = rblapack_afb_out__;
  afb = afb_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_r_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  r_out__ = NA_PTR_TYPE(rblapack_r_out__, doublereal*);
  MEMCPY(r_out__, r, doublereal, NA_TOTAL(rblapack_r));
  rblapack_r = rblapack_r_out__;
  r = r_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
  MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(doublereal, (4*n));
  iwork = ALLOC_N(integer, (n));

  dgbsvxx_(&fact, &trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_rpvgrw = rb_float_new((double)rpvgrw);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(15, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_ab, rblapack_afb, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b, rblapack_params);
}

void
init_lapack_dgbsvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgbsvxx", rblapack_dgbsvxx, -1);
}
ruby-lapack-1.7.2/ext/sgbsv.c0000644000175000017500000001625112502221013015650 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgbsv_(integer* n, integer* kl, integer* ku, integer* nrhs, real* ab, integer* ldab, integer* ipiv, real* b, integer* ldb, integer* info);


static VALUE
rblapack_sgbsv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  real *ab_out__;
  VALUE rblapack_b_out__;
  real *b_out__;

  integer ldab;
  integer n;
  integer ldb;
  integer nrhs;

  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  ipiv, info, ab, b = NumRu::Lapack.sgbsv( kl, ku, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGBSV computes the solution to a real system of linear equations\n*  A * X = B, where A is a band matrix of order N with KL subdiagonals\n*  and KU superdiagonals, and X and B are N-by-NRHS matrices.\n*\n*  The LU decomposition with partial pivoting and row interchanges is\n*  used to factor A as A = L * U, where L is a product of permutation\n*  and unit lower triangular matrices with KL subdiagonals, and U is\n*  upper triangular with KL+KU superdiagonals.  The factored form of A\n*  is then used to solve the system of equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AB      (input/output) REAL array, dimension (LDAB,N)\n*          On entry, the matrix A in band storage, in rows KL+1 to\n*          2*KL+KU+1; rows 1 to KL of the array need not be set.\n*          The j-th column of A is stored in the j-th column of the\n*          array AB as follows:\n*          AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)\n*          On exit, details of the factorization: U is stored as an\n*          upper triangular band matrix with KL+KU superdiagonals in\n*          rows 1 to KL+KU+1, and the multipliers used during the\n*          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n*          See below for further details.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          The pivot indices that define the permutation matrix P;\n*          row i of the matrix was interchanged with row IPIV(i).\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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, U(i,i) is exactly zero.  The factorization\n*                has been completed, but the factor U is exactly\n*                singular, and the solution has not been computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  M = N = 6, KL = 2, KU = 1:\n*\n*  On entry:                       On exit:\n*\n*      *    *    *    +    +    +       *    *    *   u14  u25  u36\n*      *    *    +    +    +    +       *    *   u13  u24  u35  u46\n*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56\n*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66\n*     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *\n*     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *\n*\n*  Array elements marked * are not used by the routine; elements marked\n*  + need not be set on entry, but are required by the routine to store\n*  elements of U because of fill-in resulting from the row interchanges.\n*\n*  =====================================================================\n*\n*     .. External Subroutines ..\n      EXTERNAL           SGBTRF, SGBTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, ab, b = NumRu::Lapack.sgbsv( kl, ku, ab, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_kl = argv[0];
  rblapack_ku = argv[1];
  rblapack_ab = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
  MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  sgbsv_(&n, &kl, &ku, &nrhs, ab, &ldab, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ipiv, rblapack_info, rblapack_ab, rblapack_b);
}

void
init_lapack_sgbsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgbsv", rblapack_sgbsv, -1);
}
ruby-lapack-1.7.2/ext/ilazlc.c0000644000175000017500000000461612502221021016003 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern integer ilazlc_(integer* m, integer* n, doublecomplex* a, integer* lda);


static VALUE
rblapack_ilazlc(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack___out__;
  integer __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  __out__ = NumRu::Lapack.ilazlc( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      INTEGER FUNCTION ILAZLC( M, N, A, LDA )\n\n*  Purpose\n*  =======\n*\n*  ILAZLC scans A for its last non-zero column.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          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\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.ilazlc( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);

  __out__ = ilazlc_(&m, &n, a, &lda);

  rblapack___out__ = INT2NUM(__out__);
  return rblapack___out__;
}

void
init_lapack_ilazlc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ilazlc", rblapack_ilazlc, -1);
}
ruby-lapack-1.7.2/ext/stbcon.c0000644000175000017500000001137312502221026016020 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID stbcon_(char* norm, char* uplo, char* diag, integer* n, integer* kd, real* ab, integer* ldab, real* rcond, real* work, integer* iwork, integer* info);


static VALUE
rblapack_stbcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_info;
  integer info; 
  real *work;
  integer *iwork;

  integer ldab;
  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  rcond, info = NumRu::Lapack.stbcon( norm, uplo, diag, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  STBCON estimates the reciprocal of the condition number of a\n*  triangular band matrix A, in either the 1-norm or the infinity-norm.\n*\n*  The norm of A is computed and an estimate is obtained for\n*  norm(inv(A)), then the reciprocal of the condition number is\n*  computed as\n*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies whether the 1-norm condition number or the\n*          infinity-norm condition number is required:\n*          = '1' or 'O':  1-norm;\n*          = 'I':         Infinity-norm.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals or subdiagonals of the\n*          triangular band matrix A.  KD >= 0.\n*\n*  AB      (input) REAL array, dimension (LDAB,N)\n*          The upper or lower triangular band matrix A, stored in the\n*          first kd+1 rows of the array. The j-th column of A is stored\n*          in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*          If DIAG = 'U', the diagonal elements of A are not referenced\n*          and are assumed to be 1.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  RCOND   (output) REAL\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(norm(A) * norm(inv(A))).\n*\n*  WORK    (workspace) REAL array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.stbcon( norm, uplo, diag, kd, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_diag = argv[2];
  rblapack_kd = argv[3];
  rblapack_ab = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  kd = NUM2INT(rblapack_kd);
  work = ALLOC_N(real, (3*n));
  iwork = ALLOC_N(integer, (n));

  stbcon_(&norm, &uplo, &diag, &n, &kd, ab, &ldab, &rcond, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_stbcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "stbcon", rblapack_stbcon, -1);
}
ruby-lapack-1.7.2/ext/slasv2.c0000644000175000017500000001043612502221023015736 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slasv2_(real* f, real* g, real* h, real* ssmin, real* ssmax, real* snr, real* csr, real* snl, real* csl);


static VALUE
rblapack_slasv2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_f;
  real f; 
  VALUE rblapack_g;
  real g; 
  VALUE rblapack_h;
  real h; 
  VALUE rblapack_ssmin;
  real ssmin; 
  VALUE rblapack_ssmax;
  real ssmax; 
  VALUE rblapack_snr;
  real snr; 
  VALUE rblapack_csr;
  real csr; 
  VALUE rblapack_snl;
  real snl; 
  VALUE rblapack_csl;
  real csl; 


  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  ssmin, ssmax, snr, csr, snl, csl = NumRu::Lapack.slasv2( f, g, h, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL )\n\n*  Purpose\n*  =======\n*\n*  SLASV2 computes the singular value decomposition of a 2-by-2\n*  triangular matrix\n*     [  F   G  ]\n*     [  0   H  ].\n*  On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the\n*  smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and\n*  right singular vectors for abs(SSMAX), giving the decomposition\n*\n*     [ CSL  SNL ] [  F   G  ] [ CSR -SNR ]  =  [ SSMAX   0   ]\n*     [-SNL  CSL ] [  0   H  ] [ SNR  CSR ]     [  0    SSMIN ].\n*\n\n*  Arguments\n*  =========\n*\n*  F       (input) REAL\n*          The (1,1) element of the 2-by-2 matrix.\n*\n*  G       (input) REAL\n*          The (1,2) element of the 2-by-2 matrix.\n*\n*  H       (input) REAL\n*          The (2,2) element of the 2-by-2 matrix.\n*\n*  SSMIN   (output) REAL\n*          abs(SSMIN) is the smaller singular value.\n*\n*  SSMAX   (output) REAL\n*          abs(SSMAX) is the larger singular value.\n*\n*  SNL     (output) REAL\n*  CSL     (output) REAL\n*          The vector (CSL, SNL) is a unit left singular vector for the\n*          singular value abs(SSMAX).\n*\n*  SNR     (output) REAL\n*  CSR     (output) REAL\n*          The vector (CSR, SNR) is a unit right singular vector for the\n*          singular value abs(SSMAX).\n*\n\n*  Further Details\n*  ===============\n*\n*  Any input parameter may be aliased with any output parameter.\n*\n*  Barring over/underflow and assuming a guard digit in subtraction, all\n*  output quantities are correct to within a few units in the last\n*  place (ulps).\n*\n*  In IEEE arithmetic, the code works correctly if one matrix element is\n*  infinite.\n*\n*  Overflow will not occur unless the largest singular value itself\n*  overflows or is within a few ulps of overflow. (On machines with\n*  partial overflow, like the Cray, overflow may occur if the largest\n*  singular value is within a factor of 2 of overflow.)\n*\n*  Underflow is harmless if underflow is gradual. Otherwise, results\n*  may correspond to a matrix modified by perturbations of size near\n*  the underflow threshold.\n*\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ssmin, ssmax, snr, csr, snl, csl = NumRu::Lapack.slasv2( f, g, h, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_f = argv[0];
  rblapack_g = argv[1];
  rblapack_h = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  f = (real)NUM2DBL(rblapack_f);
  h = (real)NUM2DBL(rblapack_h);
  g = (real)NUM2DBL(rblapack_g);

  slasv2_(&f, &g, &h, &ssmin, &ssmax, &snr, &csr, &snl, &csl);

  rblapack_ssmin = rb_float_new((double)ssmin);
  rblapack_ssmax = rb_float_new((double)ssmax);
  rblapack_snr = rb_float_new((double)snr);
  rblapack_csr = rb_float_new((double)csr);
  rblapack_snl = rb_float_new((double)snl);
  rblapack_csl = rb_float_new((double)csl);
  return rb_ary_new3(6, rblapack_ssmin, rblapack_ssmax, rblapack_snr, rblapack_csr, rblapack_snl, rblapack_csl);
}

void
init_lapack_slasv2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slasv2", rblapack_slasv2, -1);
}
ruby-lapack-1.7.2/ext/cheevx.c0000644000175000017500000002533212502221014016007 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cheevx_(char* jobz, char* range, char* uplo, integer* n, complex* a, integer* lda, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, complex* z, integer* ldz, complex* work, integer* lwork, real* rwork, integer* iwork, integer* ifail, integer* info);


static VALUE
rblapack_cheevx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_vl;
  real vl; 
  VALUE rblapack_vu;
  real vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  real abstol; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_ifail;
  integer *ifail; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  real *rwork;
  integer *iwork;

  integer lda;
  integer n;
  integer ldz;

  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  m, w, z, work, ifail, info, a = NumRu::Lapack.cheevx( jobz, range, uplo, a, vl, vu, il, iu, abstol, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHEEVX computes selected eigenvalues and, optionally, eigenvectors\n*  of a complex Hermitian matrix A.  Eigenvalues and eigenvectors can\n*  be selected by specifying either a range of values or a range of\n*  indices for the desired eigenvalues.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found.\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found.\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA, N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of A contains the\n*          upper triangular part of the matrix A.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of A contains\n*          the lower triangular part of the matrix A.\n*          On exit, the lower triangle (if UPLO='L') or the upper\n*          triangle (if UPLO='U') of A, including the diagonal, is\n*          destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  VL      (input) REAL\n*  VU      (input) REAL\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) REAL\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less than\n*          or equal to zero, then  EPS*|T|  will be used in its place,\n*          where |T| is the 1-norm of the tridiagonal matrix obtained\n*          by reducing A to tridiagonal form.\n*\n*          Eigenvalues will be computed most accurately when ABSTOL is\n*          set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n*          If this routine returns with INFO>0, indicating that some\n*          eigenvectors did not converge, try setting ABSTOL to\n*          2*SLAMCH('S').\n*\n*          See \"Computing Small Singular Values of Bidiagonal Matrices\n*          with Guaranteed High Relative Accuracy,\" by Demmel and\n*          Kahan, LAPACK Working Note #3.\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) REAL array, dimension (N)\n*          On normal exit, the first M elements contain the selected\n*          eigenvalues in ascending order.\n*\n*  Z       (output) COMPLEX array, dimension (LDZ, max(1,M))\n*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix A\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          If an eigenvector fails to converge, then that column of Z\n*          contains the latest approximation to the eigenvector, and the\n*          index of the eigenvector is returned in IFAIL.\n*          If JOBZ = 'N', then Z is not referenced.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of the array WORK.  LWORK >= 1, when N <= 1;\n*          otherwise 2*N.\n*          For optimal efficiency, LWORK >= (NB+1)*N,\n*          where NB is the max of the blocksize for CHETRD and for\n*          CUNMTR as returned by ILAENV.\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*  RWORK   (workspace) REAL array, dimension (7*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (5*N)\n*\n*  IFAIL   (output) INTEGER array, dimension (N)\n*          If JOBZ = 'V', then if INFO = 0, the first M elements of\n*          IFAIL are zero.  If INFO > 0, then IFAIL contains the\n*          indices of the eigenvectors that failed to converge.\n*          If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n*                Their indices are stored in array IFAIL.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, work, ifail, info, a = NumRu::Lapack.cheevx( jobz, range, uplo, a, vl, vu, il, iu, abstol, [: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_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_uplo = argv[2];
  rblapack_a = argv[3];
  rblapack_vl = argv[4];
  rblapack_vu = argv[5];
  rblapack_il = argv[6];
  rblapack_iu = argv[7];
  rblapack_abstol = 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;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  vl = (real)NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  abstol = (real)NUM2DBL(rblapack_abstol);
  range = StringValueCStr(rblapack_range)[0];
  vu = (real)NUM2DBL(rblapack_vu);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (rblapack_lwork == Qnil)
    lwork = n<=1 ? 1 : 2*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  iu = NUM2INT(rblapack_iu);
  m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  rwork = ALLOC_N(real, (7*n));
  iwork = ALLOC_N(integer, (5*n));

  cheevx_(&jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, &lwork, rwork, iwork, ifail, &info);

  free(rwork);
  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_m, rblapack_w, rblapack_z, rblapack_work, rblapack_ifail, rblapack_info, rblapack_a);
}

void
init_lapack_cheevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cheevx", rblapack_cheevx, -1);
}
ruby-lapack-1.7.2/ext/dlaneg.c0000644000175000017500000001123312502221023015752 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern integer dlaneg_(integer* n, doublereal* d, doublereal* lld, doublereal* sigma, doublereal* pivmin, integer* r);


static VALUE
rblapack_dlaneg(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_lld;
  doublereal *lld; 
  VALUE rblapack_sigma;
  doublereal sigma; 
  VALUE rblapack_pivmin;
  doublereal pivmin; 
  VALUE rblapack_r;
  integer r; 
  VALUE rblapack___out__;
  integer __out__; 

  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  __out__ = NumRu::Lapack.dlaneg( d, lld, sigma, pivmin, r, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      INTEGER FUNCTION DLANEG( N, D, LLD, SIGMA, PIVMIN, R )\n\n*  Purpose\n*  =======\n*\n*  DLANEG computes the Sturm count, the number of negative pivots\n*  encountered while factoring tridiagonal T - sigma I = L D L^T.\n*  This implementation works directly on the factors without forming\n*  the tridiagonal matrix T.  The Sturm count is also the number of\n*  eigenvalues of T less than sigma.\n*\n*  This routine is called from DLARRB.\n*\n*  The current routine does not use the PIVMIN parameter but rather\n*  requires IEEE-754 propagation of Infinities and NaNs.  This\n*  routine also has no input range restrictions but does require\n*  default exception handling such that x/0 produces Inf when x is\n*  non-zero, and Inf/Inf produces NaN.  For more information, see:\n*\n*    Marques, Riedy, and Voemel, \"Benefits of IEEE-754 Features in\n*    Modern Symmetric Tridiagonal Eigensolvers,\" SIAM Journal on\n*    Scientific Computing, v28, n5, 2006.  DOI 10.1137/050641624\n*    (Tech report version in LAWN 172 with the same title.)\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          The N diagonal elements of the diagonal matrix D.\n*\n*  LLD     (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (N-1) elements L(i)*L(i)*D(i).\n*\n*  SIGMA   (input) DOUBLE PRECISION\n*          Shift amount in T - sigma I = L D L^T.\n*\n*  PIVMIN  (input) DOUBLE PRECISION\n*          The minimum pivot in the Sturm sequence.  May be used\n*          when zero pivots are encountered on non-IEEE-754\n*          architectures.\n*\n*  R       (input) INTEGER\n*          The twist index for the twisted factorization that is used\n*          for the negcount.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*     Jason Riedy, University of California, Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.dlaneg( d, lld, sigma, pivmin, r, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_d = argv[0];
  rblapack_lld = argv[1];
  rblapack_sigma = argv[2];
  rblapack_pivmin = argv[3];
  rblapack_r = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  sigma = NUM2DBL(rblapack_sigma);
  r = NUM2INT(rblapack_r);
  if (!NA_IsNArray(rblapack_lld))
    rb_raise(rb_eArgError, "lld (2th argument) must be NArray");
  if (NA_RANK(rblapack_lld) != 1)
    rb_raise(rb_eArgError, "rank of lld (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_lld) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of lld must be %d", n-1);
  if (NA_TYPE(rblapack_lld) != NA_DFLOAT)
    rblapack_lld = na_change_type(rblapack_lld, NA_DFLOAT);
  lld = NA_PTR_TYPE(rblapack_lld, doublereal*);
  pivmin = NUM2DBL(rblapack_pivmin);

  __out__ = dlaneg_(&n, d, lld, &sigma, &pivmin, &r);

  rblapack___out__ = INT2NUM(__out__);
  return rblapack___out__;
}

void
init_lapack_dlaneg(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaneg", rblapack_dlaneg, -1);
}
ruby-lapack-1.7.2/ext/zgghrd.c0000644000175000017500000002400312502221016016006 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgghrd_(char* compq, char* compz, integer* n, integer* ilo, integer* ihi, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* q, integer* ldq, doublecomplex* z, integer* ldz, integer* info);


static VALUE
rblapack_zgghrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_compq;
  char compq; 
  VALUE rblapack_compz;
  char compz; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_q;
  doublecomplex *q; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  VALUE rblapack_q_out__;
  doublecomplex *q_out__;
  VALUE rblapack_z_out__;
  doublecomplex *z_out__;

  integer lda;
  integer n;
  integer ldb;
  integer ldq;
  integer ldz;

  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  info, a, b, q, z = NumRu::Lapack.zgghrd( compq, compz, ilo, ihi, a, b, q, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGGHRD reduces a pair of complex matrices (A,B) to generalized upper\n*  Hessenberg form using unitary transformations, where A is a\n*  general matrix and B is upper triangular.  The form of the\n*  generalized eigenvalue problem is\n*     A*x = lambda*B*x,\n*  and B is typically made upper triangular by computing its QR\n*  factorization and moving the unitary matrix Q to the left side\n*  of the equation.\n*\n*  This subroutine simultaneously reduces A to a Hessenberg matrix H:\n*     Q**H*A*Z = H\n*  and transforms B to another upper triangular matrix T:\n*     Q**H*B*Z = T\n*  in order to reduce the problem to its standard form\n*     H*y = lambda*T*y\n*  where y = Z**H*x.\n*\n*  The unitary matrices Q and Z are determined as products of Givens\n*  rotations.  They may either be formed explicitly, or they may be\n*  postmultiplied into input matrices Q1 and Z1, so that\n*       Q1 * A * Z1**H = (Q1*Q) * H * (Z1*Z)**H\n*       Q1 * B * Z1**H = (Q1*Q) * T * (Z1*Z)**H\n*  If Q1 is the unitary matrix from the QR factorization of B in the\n*  original equation A*x = lambda*B*x, then ZGGHRD reduces the original\n*  problem to generalized Hessenberg form.\n*\n\n*  Arguments\n*  =========\n*\n*  COMPQ   (input) CHARACTER*1\n*          = 'N': do not compute Q;\n*          = 'I': Q is initialized to the unit matrix, and the\n*                 unitary matrix Q is returned;\n*          = 'V': Q must contain a unitary matrix Q1 on entry,\n*                 and the product Q1*Q is returned.\n*\n*  COMPZ   (input) CHARACTER*1\n*          = 'N': do not compute Q;\n*          = 'I': Q is initialized to the unit matrix, and the\n*                 unitary matrix Q is returned;\n*          = 'V': Q must contain a unitary matrix Q1 on entry,\n*                 and the product Q1*Q is returned.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          ILO and IHI mark the rows and columns of A which are to be\n*          reduced.  It is assumed that A is already upper triangular\n*          in rows and columns 1:ILO-1 and IHI+1:N.  ILO and IHI are\n*          normally set by a previous call to ZGGBAL; otherwise they\n*          should be set to 1 and N respectively.\n*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA, N)\n*          On entry, the N-by-N general matrix to be reduced.\n*          On exit, the upper triangle and the first subdiagonal of A\n*          are overwritten with the upper Hessenberg matrix H, and the\n*          rest is set to zero.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB, N)\n*          On entry, the N-by-N upper triangular matrix B.\n*          On exit, the upper triangular matrix T = Q**H B Z.  The\n*          elements below the diagonal are set to zero.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  Q       (input/output) COMPLEX*16 array, dimension (LDQ, N)\n*          On entry, if COMPQ = 'V', the unitary matrix Q1, typically\n*          from the QR factorization of B.\n*          On exit, if COMPQ='I', the unitary matrix Q, and if\n*          COMPQ = 'V', the product Q1*Q.\n*          Not referenced if COMPQ='N'.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.\n*          LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.\n*\n*  Z       (input/output) COMPLEX*16 array, dimension (LDZ, N)\n*          On entry, if COMPZ = 'V', the unitary matrix Z1.\n*          On exit, if COMPZ='I', the unitary matrix Z, and if\n*          COMPZ = 'V', the product Z1*Z.\n*          Not referenced if COMPZ='N'.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.\n*          LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.\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*  This routine reduces A to Hessenberg and B to triangular form by\n*  an unblocked reduction, as described in _Matrix_Computations_,\n*  by Golub and van Loan (Johns Hopkins Press).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a, b, q, z = NumRu::Lapack.zgghrd( compq, compz, ilo, ihi, a, b, q, z, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_compq = argv[0];
  rblapack_compz = argv[1];
  rblapack_ilo = argv[2];
  rblapack_ihi = argv[3];
  rblapack_a = argv[4];
  rblapack_b = argv[5];
  rblapack_q = argv[6];
  rblapack_z = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  compq = StringValueCStr(rblapack_compq)[0];
  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (7th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_q) != NA_DCOMPLEX)
    rblapack_q = na_change_type(rblapack_q, NA_DCOMPLEX);
  q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
  compz = StringValueCStr(rblapack_compz)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  ihi = NUM2INT(rblapack_ihi);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (8th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  if (NA_SHAPE1(rblapack_z) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_z) != NA_DCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublecomplex*);
  MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublecomplex*);
  MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  zgghrd_(&compq, &compz, &n, &ilo, &ihi, a, &lda, b, &ldb, q, &ldq, z, &ldz, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z);
}

void
init_lapack_zgghrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgghrd", rblapack_zgghrd, -1);
}
ruby-lapack-1.7.2/ext/shsein.c0000644000175000017500000003365512502221014016025 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID shsein_(char* side, char* eigsrc, char* initv, logical* select, integer* n, real* h, integer* ldh, real* wr, real* wi, real* vl, integer* ldvl, real* vr, integer* ldvr, integer* mm, integer* m, real* work, integer* ifaill, integer* ifailr, integer* info);


static VALUE
rblapack_shsein(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_eigsrc;
  char eigsrc; 
  VALUE rblapack_initv;
  char initv; 
  VALUE rblapack_select;
  logical *select; 
  VALUE rblapack_h;
  real *h; 
  VALUE rblapack_wr;
  real *wr; 
  VALUE rblapack_wi;
  real *wi; 
  VALUE rblapack_vl;
  real *vl; 
  VALUE rblapack_vr;
  real *vr; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_ifaill;
  integer *ifaill; 
  VALUE rblapack_ifailr;
  integer *ifailr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_select_out__;
  logical *select_out__;
  VALUE rblapack_wr_out__;
  real *wr_out__;
  VALUE rblapack_vl_out__;
  real *vl_out__;
  VALUE rblapack_vr_out__;
  real *vr_out__;
  real *work;

  integer n;
  integer ldh;
  integer ldvl;
  integer mm;
  integer ldvr;

  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  m, ifaill, ifailr, info, select, wr, vl, vr = NumRu::Lapack.shsein( side, eigsrc, initv, select, h, wr, wi, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI, VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL, IFAILR, INFO )\n\n*  Purpose\n*  =======\n*\n*  SHSEIN uses inverse iteration to find specified right and/or left\n*  eigenvectors of a real upper Hessenberg matrix H.\n*\n*  The right eigenvector x and the left eigenvector y of the matrix H\n*  corresponding to an eigenvalue w are defined by:\n*\n*               H * x = w * x,     y**h * H = w * y**h\n*\n*  where y**h denotes the conjugate transpose of the vector y.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'R': compute right eigenvectors only;\n*          = 'L': compute left eigenvectors only;\n*          = 'B': compute both right and left eigenvectors.\n*\n*  EIGSRC  (input) CHARACTER*1\n*          Specifies the source of eigenvalues supplied in (WR,WI):\n*          = 'Q': the eigenvalues were found using SHSEQR; thus, if\n*                 H has zero subdiagonal elements, and so is\n*                 block-triangular, then the j-th eigenvalue can be\n*                 assumed to be an eigenvalue of the block containing\n*                 the j-th row/column.  This property allows SHSEIN to\n*                 perform inverse iteration on just one diagonal block.\n*          = 'N': no assumptions are made on the correspondence\n*                 between eigenvalues and diagonal blocks.  In this\n*                 case, SHSEIN must always perform inverse iteration\n*                 using the whole matrix H.\n*\n*  INITV   (input) CHARACTER*1\n*          = 'N': no initial vectors are supplied;\n*          = 'U': user-supplied initial vectors are stored in the arrays\n*                 VL and/or VR.\n*\n*  SELECT  (input/output) LOGICAL array, dimension (N)\n*          Specifies the eigenvectors to be computed. To select the\n*          real eigenvector corresponding to a real eigenvalue WR(j),\n*          SELECT(j) must be set to .TRUE.. To select the complex\n*          eigenvector corresponding to a complex eigenvalue\n*          (WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)),\n*          either SELECT(j) or SELECT(j+1) or both must be set to\n*          .TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is\n*          .FALSE..\n*\n*  N       (input) INTEGER\n*          The order of the matrix H.  N >= 0.\n*\n*  H       (input) REAL array, dimension (LDH,N)\n*          The upper Hessenberg matrix H.\n*\n*  LDH     (input) INTEGER\n*          The leading dimension of the array H.  LDH >= max(1,N).\n*\n*  WR      (input/output) REAL array, dimension (N)\n*  WI      (input) REAL array, dimension (N)\n*          On entry, the real and imaginary parts of the eigenvalues of\n*          H; a complex conjugate pair of eigenvalues must be stored in\n*          consecutive elements of WR and WI.\n*          On exit, WR may have been altered since close eigenvalues\n*          are perturbed slightly in searching for independent\n*          eigenvectors.\n*\n*  VL      (input/output) REAL array, dimension (LDVL,MM)\n*          On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must\n*          contain starting vectors for the inverse iteration for the\n*          left eigenvectors; the starting vector for each eigenvector\n*          must be in the same column(s) in which the eigenvector will\n*          be stored.\n*          On exit, if SIDE = 'L' or 'B', the left eigenvectors\n*          specified by SELECT will be stored consecutively in the\n*          columns of VL, in the same order as their eigenvalues. A\n*          complex eigenvector corresponding to a complex eigenvalue is\n*          stored in two consecutive columns, the first holding the real\n*          part and the second the imaginary part.\n*          If SIDE = 'R', VL is not referenced.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the array VL.\n*          LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.\n*\n*  VR      (input/output) REAL array, dimension (LDVR,MM)\n*          On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must\n*          contain starting vectors for the inverse iteration for the\n*          right eigenvectors; the starting vector for each eigenvector\n*          must be in the same column(s) in which the eigenvector will\n*          be stored.\n*          On exit, if SIDE = 'R' or 'B', the right eigenvectors\n*          specified by SELECT will be stored consecutively in the\n*          columns of VR, in the same order as their eigenvalues. A\n*          complex eigenvector corresponding to a complex eigenvalue is\n*          stored in two consecutive columns, the first holding the real\n*          part and the second the imaginary part.\n*          If SIDE = 'L', VR is not referenced.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the array VR.\n*          LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.\n*\n*  MM      (input) INTEGER\n*          The number of columns in the arrays VL and/or VR. MM >= M.\n*\n*  M       (output) INTEGER\n*          The number of columns in the arrays VL and/or VR required to\n*          store the eigenvectors; each selected real eigenvector\n*          occupies one column and each selected complex eigenvector\n*          occupies two columns.\n*\n*  WORK    (workspace) REAL array, dimension ((N+2)*N)\n*\n*  IFAILL  (output) INTEGER array, dimension (MM)\n*          If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left\n*          eigenvector in the i-th column of VL (corresponding to the\n*          eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the\n*          eigenvector converged satisfactorily. If the i-th and (i+1)th\n*          columns of VL hold a complex eigenvector, then IFAILL(i) and\n*          IFAILL(i+1) are set to the same value.\n*          If SIDE = 'R', IFAILL is not referenced.\n*\n*  IFAILR  (output) INTEGER array, dimension (MM)\n*          If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right\n*          eigenvector in the i-th column of VR (corresponding to the\n*          eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the\n*          eigenvector converged satisfactorily. If the i-th and (i+1)th\n*          columns of VR hold a complex eigenvector, then IFAILR(i) and\n*          IFAILR(i+1) are set to the same value.\n*          If SIDE = 'L', IFAILR is not referenced.\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, i is the number of eigenvectors which\n*                failed to converge; see IFAILL and IFAILR for further\n*                details.\n*\n\n*  Further Details\n*  ===============\n*\n*  Each eigenvector is normalized so that the element of largest\n*  magnitude has magnitude 1; here the magnitude of a complex number\n*  (x,y) is taken to be |x|+|y|.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, ifaill, ifailr, info, select, wr, vl, vr = NumRu::Lapack.shsein( side, eigsrc, initv, select, h, wr, wi, vl, vr, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_side = argv[0];
  rblapack_eigsrc = argv[1];
  rblapack_initv = argv[2];
  rblapack_select = argv[3];
  rblapack_h = argv[4];
  rblapack_wr = argv[5];
  rblapack_wi = argv[6];
  rblapack_vl = argv[7];
  rblapack_vr = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  initv = StringValueCStr(rblapack_initv)[0];
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (5th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_SFLOAT)
    rblapack_h = na_change_type(rblapack_h, NA_SFLOAT);
  h = NA_PTR_TYPE(rblapack_h, real*);
  if (!NA_IsNArray(rblapack_wi))
    rb_raise(rb_eArgError, "wi (7th argument) must be NArray");
  if (NA_RANK(rblapack_wi) != 1)
    rb_raise(rb_eArgError, "rank of wi (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_wi) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of wi must be the same as shape 1 of h");
  if (NA_TYPE(rblapack_wi) != NA_SFLOAT)
    rblapack_wi = na_change_type(rblapack_wi, NA_SFLOAT);
  wi = NA_PTR_TYPE(rblapack_wi, real*);
  if (!NA_IsNArray(rblapack_vr))
    rb_raise(rb_eArgError, "vr (9th argument) must be NArray");
  if (NA_RANK(rblapack_vr) != 2)
    rb_raise(rb_eArgError, "rank of vr (9th argument) must be %d", 2);
  ldvr = NA_SHAPE0(rblapack_vr);
  mm = NA_SHAPE1(rblapack_vr);
  if (NA_TYPE(rblapack_vr) != NA_SFLOAT)
    rblapack_vr = na_change_type(rblapack_vr, NA_SFLOAT);
  vr = NA_PTR_TYPE(rblapack_vr, real*);
  eigsrc = StringValueCStr(rblapack_eigsrc)[0];
  if (!NA_IsNArray(rblapack_wr))
    rb_raise(rb_eArgError, "wr (6th argument) must be NArray");
  if (NA_RANK(rblapack_wr) != 1)
    rb_raise(rb_eArgError, "rank of wr (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_wr) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of wr must be the same as shape 1 of h");
  if (NA_TYPE(rblapack_wr) != NA_SFLOAT)
    rblapack_wr = na_change_type(rblapack_wr, NA_SFLOAT);
  wr = NA_PTR_TYPE(rblapack_wr, real*);
  if (!NA_IsNArray(rblapack_select))
    rb_raise(rb_eArgError, "select (4th argument) must be NArray");
  if (NA_RANK(rblapack_select) != 1)
    rb_raise(rb_eArgError, "rank of select (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_select) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of h");
  if (NA_TYPE(rblapack_select) != NA_LINT)
    rblapack_select = na_change_type(rblapack_select, NA_LINT);
  select = NA_PTR_TYPE(rblapack_select, logical*);
  if (!NA_IsNArray(rblapack_vl))
    rb_raise(rb_eArgError, "vl (8th argument) must be NArray");
  if (NA_RANK(rblapack_vl) != 2)
    rb_raise(rb_eArgError, "rank of vl (8th argument) must be %d", 2);
  ldvl = NA_SHAPE0(rblapack_vl);
  if (NA_SHAPE1(rblapack_vl) != mm)
    rb_raise(rb_eRuntimeError, "shape 1 of vl must be the same as shape 1 of vr");
  if (NA_TYPE(rblapack_vl) != NA_SFLOAT)
    rblapack_vl = na_change_type(rblapack_vl, NA_SFLOAT);
  vl = NA_PTR_TYPE(rblapack_vl, real*);
  {
    na_shape_t shape[1];
    shape[0] = mm;
    rblapack_ifaill = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifaill = NA_PTR_TYPE(rblapack_ifaill, integer*);
  {
    na_shape_t shape[1];
    shape[0] = mm;
    rblapack_ifailr = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifailr = NA_PTR_TYPE(rblapack_ifailr, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_select_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  select_out__ = NA_PTR_TYPE(rblapack_select_out__, logical*);
  MEMCPY(select_out__, select, logical, NA_TOTAL(rblapack_select));
  rblapack_select = rblapack_select_out__;
  select = select_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wr_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  wr_out__ = NA_PTR_TYPE(rblapack_wr_out__, real*);
  MEMCPY(wr_out__, wr, real, NA_TOTAL(rblapack_wr));
  rblapack_wr = rblapack_wr_out__;
  wr = wr_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = mm;
    rblapack_vl_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, real*);
  MEMCPY(vl_out__, vl, real, NA_TOTAL(rblapack_vl));
  rblapack_vl = rblapack_vl_out__;
  vl = vl_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = mm;
    rblapack_vr_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vr_out__ = NA_PTR_TYPE(rblapack_vr_out__, real*);
  MEMCPY(vr_out__, vr, real, NA_TOTAL(rblapack_vr));
  rblapack_vr = rblapack_vr_out__;
  vr = vr_out__;
  work = ALLOC_N(real, ((n+2)*n));

  shsein_(&side, &eigsrc, &initv, select, &n, h, &ldh, wr, wi, vl, &ldvl, vr, &ldvr, &mm, &m, work, ifaill, ifailr, &info);

  free(work);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_m, rblapack_ifaill, rblapack_ifailr, rblapack_info, rblapack_select, rblapack_wr, rblapack_vl, rblapack_vr);
}

void
init_lapack_shsein(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "shsein", rblapack_shsein, -1);
}
ruby-lapack-1.7.2/ext/zgelq2.c0000644000175000017500000001035512502221012015726 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgelq2_(integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* info);


static VALUE
rblapack_zgelq2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  doublecomplex *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.zgelq2( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGELQ2 computes an LQ factorization of a complex 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) COMPLEX*16 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 unitary 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) COMPLEX*16 array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace) COMPLEX*16 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 complex scalar, and v is a complex vector with\n*  v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in\n*  A(i,i+1: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.zgelq2( 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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  m = lda;
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(doublecomplex, (m));

  zgelq2_(&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_zgelq2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgelq2", rblapack_zgelq2, -1);
}
ruby-lapack-1.7.2/ext/dla_syrfsx_extended.c0000644000175000017500000005716512502221014020574 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dla_syrfsx_extended_(integer* prec_type, char* uplo, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* af, integer* ldaf, integer* ipiv, logical* colequ, doublereal* c, doublereal* b, integer* ldb, doublereal* y, integer* ldy, doublereal* berr_out, integer* n_norms, doublereal* err_bnds_norm, doublereal* err_bnds_comp, doublereal* res, doublereal* ayb, doublereal* dy, doublereal* y_tail, doublereal* rcond, integer* ithresh, doublereal* rthresh, doublereal* dz_ub, logical* ignore_cwise, integer* info);


static VALUE
rblapack_dla_syrfsx_extended(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_prec_type;
  integer prec_type; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_af;
  doublereal *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_colequ;
  logical colequ; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_y;
  doublereal *y; 
  VALUE rblapack_n_norms;
  integer n_norms; 
  VALUE rblapack_err_bnds_norm;
  doublereal *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  doublereal *err_bnds_comp; 
  VALUE rblapack_res;
  doublereal *res; 
  VALUE rblapack_ayb;
  doublereal *ayb; 
  VALUE rblapack_dy;
  doublereal *dy; 
  VALUE rblapack_y_tail;
  doublereal *y_tail; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_ithresh;
  integer ithresh; 
  VALUE rblapack_rthresh;
  doublereal rthresh; 
  VALUE rblapack_dz_ub;
  doublereal dz_ub; 
  VALUE rblapack_ignore_cwise;
  logical ignore_cwise; 
  VALUE rblapack_berr_out;
  doublereal *berr_out; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_y_out__;
  doublereal *y_out__;
  VALUE rblapack_err_bnds_norm_out__;
  doublereal *err_bnds_norm_out__;
  VALUE rblapack_err_bnds_comp_out__;
  doublereal *err_bnds_comp_out__;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldy;
  integer n_err_bnds;

  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  berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.dla_syrfsx_extended( prec_type, uplo, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n*  Purpose\n*  =======\n* \n*  DLA_SYRFSX_EXTENDED improves the computed solution to a system of\n*  linear equations by performing extra-precise iterative refinement\n*  and provides error bounds and backward error estimates for the solution.\n*  This subroutine is called by DSYRFSX to perform iterative refinement.\n*  In addition to normwise error bound, the code provides maximum\n*  componentwise error bound if possible. See comments for ERR_BNDS_NORM\n*  and ERR_BNDS_COMP for details of the error bounds. Note that this\n*  subroutine is only resonsible for setting the second fields of\n*  ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n*  Arguments\n*  =========\n*\n*     PREC_TYPE      (input) INTEGER\n*     Specifies the intermediate precision to be used in refinement.\n*     The value is defined by ILAPREC(P) where P is a CHARACTER and\n*     P    = 'S':  Single\n*          = 'D':  Double\n*          = 'I':  Indigenous\n*          = 'X', 'E':  Extra\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N              (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NRHS           (input) INTEGER\n*     The number of right-hand-sides, i.e., the number of columns of the\n*     matrix B.\n*\n*     A              (input) DOUBLE PRECISION array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA            (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF             (input) DOUBLE PRECISION array, dimension (LDAF,N)\n*     The block diagonal matrix D and the multipliers used to\n*     obtain the factor U or L as computed by DSYTRF.\n*\n*     LDAF           (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV           (input) INTEGER array, dimension (N)\n*     Details of the interchanges and the block structure of D\n*     as determined by DSYTRF.\n*\n*     COLEQU         (input) LOGICAL\n*     If .TRUE. then column equilibration was done to A before calling\n*     this routine. This is needed to compute the solution and error\n*     bounds correctly.\n*\n*     C              (input) DOUBLE PRECISION array, dimension (N)\n*     The column scale factors for A. If COLEQU = .FALSE., C\n*     is not accessed. If C is input, each element of C should be a power\n*     of the radix to ensure a reliable solution and error estimates.\n*     Scaling by powers of the radix does not cause rounding errors unless\n*     the result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B              (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*     The right-hand-side matrix B.\n*\n*     LDB            (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     Y              (input/output) DOUBLE PRECISION array, dimension\n*                    (LDY,NRHS)\n*     On entry, the solution matrix X, as computed by DSYTRS.\n*     On exit, the improved solution matrix Y.\n*\n*     LDY            (input) INTEGER\n*     The leading dimension of the array Y.  LDY >= max(1,N).\n*\n*     BERR_OUT       (output) DOUBLE PRECISION array, dimension (NRHS)\n*     On exit, BERR_OUT(j) contains the componentwise relative backward\n*     error for right-hand-side j from the formula\n*         max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n*     where abs(Z) is the componentwise absolute value of the matrix\n*     or vector Z. This is computed by DLA_LIN_BERR.\n*\n*     N_NORMS        (input) INTEGER\n*     Determines which error bounds to return (see ERR_BNDS_NORM\n*     and ERR_BNDS_COMP).\n*     If N_NORMS >= 1 return normwise error bounds.\n*     If N_NORMS >= 2 return componentwise error bounds.\n*\n*     ERR_BNDS_NORM  (input/output) DOUBLE PRECISION array, dimension\n*                    (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (input/output) DOUBLE PRECISION array, dimension\n*                    (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     RES            (input) DOUBLE PRECISION array, dimension (N)\n*     Workspace to hold the intermediate residual.\n*\n*     AYB            (input) DOUBLE PRECISION array, dimension (N)\n*     Workspace. This can be the same workspace passed for Y_TAIL.\n*\n*     DY             (input) DOUBLE PRECISION array, dimension (N)\n*     Workspace to hold the intermediate solution.\n*\n*     Y_TAIL         (input) DOUBLE PRECISION array, dimension (N)\n*     Workspace to hold the trailing bits of the intermediate solution.\n*\n*     RCOND          (input) DOUBLE PRECISION\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     ITHRESH        (input) INTEGER\n*     The maximum number of residual computations allowed for\n*     refinement. The default is 10. For 'aggressive' set to 100 to\n*     permit convergence using approximate factorizations or\n*     factorizations other than LU. If the factorization uses a\n*     technique other than Gaussian elimination, the guarantees in\n*     ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n*     RTHRESH        (input) DOUBLE PRECISION\n*     Determines when to stop refinement if the error estimate stops\n*     decreasing. Refinement will stop when the next solution no longer\n*     satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n*     the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n*     default value is 0.5. For 'aggressive' set to 0.9 to permit\n*     convergence on extremely ill-conditioned matrices. See LAWN 165\n*     for more details.\n*\n*     DZ_UB          (input) DOUBLE PRECISION\n*     Determines when to start considering componentwise convergence.\n*     Componentwise convergence is only considered after each component\n*     of the solution Y is stable, which we definte as the relative\n*     change in each component being less than DZ_UB. The default value\n*     is 0.25, requiring the first bit to be stable. See LAWN 165 for\n*     more details.\n*\n*     IGNORE_CWISE   (input) LOGICAL\n*     If .TRUE. then ignore componentwise convergence. Default value\n*     is .FALSE..\n*\n*     INFO           (output) INTEGER\n*       = 0:  Successful exit.\n*       < 0:  if INFO = -i, the ith argument to DSYTRS had an illegal\n*             value\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            UPLO2, CNT, I, J, X_STATE, Z_STATE\n      DOUBLE PRECISION   YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n     $                   DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n     $                   DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n     $                   EPS, HUGEVAL, INCR_THRESH\n      LOGICAL            INCR_PREC\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.dla_syrfsx_extended( prec_type, uplo, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 21 && argc != 21)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 21)", argc);
  rblapack_prec_type = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_colequ = argv[5];
  rblapack_c = argv[6];
  rblapack_b = argv[7];
  rblapack_y = argv[8];
  rblapack_n_norms = argv[9];
  rblapack_err_bnds_norm = argv[10];
  rblapack_err_bnds_comp = argv[11];
  rblapack_res = argv[12];
  rblapack_ayb = argv[13];
  rblapack_dy = argv[14];
  rblapack_y_tail = argv[15];
  rblapack_rcond = argv[16];
  rblapack_ithresh = argv[17];
  rblapack_rthresh = argv[18];
  rblapack_dz_ub = argv[19];
  rblapack_ignore_cwise = argv[20];
  if (argc == 21) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  prec_type = NUM2INT(rblapack_prec_type);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (9th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 2)
    rb_raise(rb_eArgError, "rank of y (9th argument) must be %d", 2);
  ldy = NA_SHAPE0(rblapack_y);
  nrhs = NA_SHAPE1(rblapack_y);
  if (NA_TYPE(rblapack_y) != NA_DFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
  y = NA_PTR_TYPE(rblapack_y, doublereal*);
  if (!NA_IsNArray(rblapack_err_bnds_norm))
    rb_raise(rb_eArgError, "err_bnds_norm (11th argument) must be NArray");
  if (NA_RANK(rblapack_err_bnds_norm) != 2)
    rb_raise(rb_eArgError, "rank of err_bnds_norm (11th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_err_bnds_norm) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of y");
  n_err_bnds = NA_SHAPE1(rblapack_err_bnds_norm);
  if (NA_TYPE(rblapack_err_bnds_norm) != NA_DFLOAT)
    rblapack_err_bnds_norm = na_change_type(rblapack_err_bnds_norm, NA_DFLOAT);
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
  if (!NA_IsNArray(rblapack_res))
    rb_raise(rb_eArgError, "res (13th argument) must be NArray");
  if (NA_RANK(rblapack_res) != 1)
    rb_raise(rb_eArgError, "rank of res (13th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_res) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_res) != NA_DFLOAT)
    rblapack_res = na_change_type(rblapack_res, NA_DFLOAT);
  res = NA_PTR_TYPE(rblapack_res, doublereal*);
  if (!NA_IsNArray(rblapack_dy))
    rb_raise(rb_eArgError, "dy (15th argument) must be NArray");
  if (NA_RANK(rblapack_dy) != 1)
    rb_raise(rb_eArgError, "rank of dy (15th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dy) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_dy) != NA_DFLOAT)
    rblapack_dy = na_change_type(rblapack_dy, NA_DFLOAT);
  dy = NA_PTR_TYPE(rblapack_dy, doublereal*);
  rcond = NUM2DBL(rblapack_rcond);
  rthresh = NUM2DBL(rblapack_rthresh);
  ignore_cwise = (rblapack_ignore_cwise == Qtrue);
  uplo = StringValueCStr(rblapack_uplo)[0];
  colequ = (rblapack_colequ == Qtrue);
  n_norms = NUM2INT(rblapack_n_norms);
  if (!NA_IsNArray(rblapack_ayb))
    rb_raise(rb_eArgError, "ayb (14th argument) must be NArray");
  if (NA_RANK(rblapack_ayb) != 1)
    rb_raise(rb_eArgError, "rank of ayb (14th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ayb) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ayb) != NA_DFLOAT)
    rblapack_ayb = na_change_type(rblapack_ayb, NA_DFLOAT);
  ayb = NA_PTR_TYPE(rblapack_ayb, doublereal*);
  ithresh = NUM2INT(rblapack_ithresh);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
  af = NA_PTR_TYPE(rblapack_af, doublereal*);
  if (!NA_IsNArray(rblapack_err_bnds_comp))
    rb_raise(rb_eArgError, "err_bnds_comp (12th argument) must be NArray");
  if (NA_RANK(rblapack_err_bnds_comp) != 2)
    rb_raise(rb_eArgError, "rank of err_bnds_comp (12th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_err_bnds_comp) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of y");
  if (NA_SHAPE1(rblapack_err_bnds_comp) != n_err_bnds)
    rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_comp must be the same as shape 1 of err_bnds_norm");
  if (NA_TYPE(rblapack_err_bnds_comp) != NA_DFLOAT)
    rblapack_err_bnds_comp = na_change_type(rblapack_err_bnds_comp, NA_DFLOAT);
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
  dz_ub = NUM2DBL(rblapack_dz_ub);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of y");
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  if (!NA_IsNArray(rblapack_y_tail))
    rb_raise(rb_eArgError, "y_tail (16th argument) must be NArray");
  if (NA_RANK(rblapack_y_tail) != 1)
    rb_raise(rb_eArgError, "rank of y_tail (16th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y_tail) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_y_tail) != NA_DFLOAT)
    rblapack_y_tail = na_change_type(rblapack_y_tail, NA_DFLOAT);
  y_tail = NA_PTR_TYPE(rblapack_y_tail, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr_out = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr_out = NA_PTR_TYPE(rblapack_berr_out, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldy;
    shape[1] = nrhs;
    rblapack_y_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
  MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm_out__ = NA_PTR_TYPE(rblapack_err_bnds_norm_out__, doublereal*);
  MEMCPY(err_bnds_norm_out__, err_bnds_norm, doublereal, NA_TOTAL(rblapack_err_bnds_norm));
  rblapack_err_bnds_norm = rblapack_err_bnds_norm_out__;
  err_bnds_norm = err_bnds_norm_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp_out__ = NA_PTR_TYPE(rblapack_err_bnds_comp_out__, doublereal*);
  MEMCPY(err_bnds_comp_out__, err_bnds_comp, doublereal, NA_TOTAL(rblapack_err_bnds_comp));
  rblapack_err_bnds_comp = rblapack_err_bnds_comp_out__;
  err_bnds_comp = err_bnds_comp_out__;

  dla_syrfsx_extended_(&prec_type, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_err_bnds_norm, rblapack_err_bnds_comp);
}

void
init_lapack_dla_syrfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dla_syrfsx_extended", rblapack_dla_syrfsx_extended, -1);
}
ruby-lapack-1.7.2/ext/icmax1.c0000644000175000017500000000561712502221026015716 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern integer icmax1_(integer* n, complex* cx, integer* incx);


static VALUE
rblapack_icmax1(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_cx;
  complex *cx; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack___out__;
  integer __out__; 

  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  __out__ = NumRu::Lapack.icmax1( cx, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      INTEGER          FUNCTION ICMAX1( N, CX, INCX )\n\n*  Purpose\n*  =======\n*\n*  ICMAX1 finds the index of the element whose real part has maximum\n*  absolute value.\n*\n*  Based on ICAMAX from Level 1 BLAS.\n*  The change is to use the 'genuine' absolute value.\n*\n*  Contributed by Nick Higham for use with CLACON.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of elements in the vector CX.\n*\n*  CX      (input) COMPLEX array, dimension (N)\n*          The vector whose elements will be summed.\n*\n*  INCX    (input) INTEGER\n*          The spacing between successive values of CX.  INCX >= 1.\n*\n\n* =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, IX\n      REAL               SMAX\n      COMPLEX            ZDUM\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS\n*     ..\n*     .. Statement Functions ..\n      REAL               CABS1\n*     ..\n*     .. Statement Function definitions ..\n*\n*     NEXT LINE IS THE ONLY MODIFICATION.\n      CABS1( ZDUM ) = ABS( ZDUM )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.icmax1( cx, incx, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_cx = argv[0];
  rblapack_incx = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_cx))
    rb_raise(rb_eArgError, "cx (1th argument) must be NArray");
  if (NA_RANK(rblapack_cx) != 1)
    rb_raise(rb_eArgError, "rank of cx (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_cx);
  if (NA_TYPE(rblapack_cx) != NA_SCOMPLEX)
    rblapack_cx = na_change_type(rblapack_cx, NA_SCOMPLEX);
  cx = NA_PTR_TYPE(rblapack_cx, complex*);
  incx = NUM2INT(rblapack_incx);

  __out__ = icmax1_(&n, cx, &incx);

  rblapack___out__ = INT2NUM(__out__);
  return rblapack___out__;
}

void
init_lapack_icmax1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "icmax1", rblapack_icmax1, -1);
}
ruby-lapack-1.7.2/ext/slaed8.c0000644000175000017500000002767312502221014015717 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaed8_(integer* icompq, integer* k, integer* n, integer* qsiz, real* d, real* q, integer* ldq, integer* indxq, real* rho, integer* cutpnt, real* z, real* dlamda, real* q2, integer* ldq2, real* w, integer* perm, integer* givptr, integer* givcol, real* givnum, integer* indxp, integer* indx, integer* info);


static VALUE
rblapack_slaed8(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_icompq;
  integer icompq; 
  VALUE rblapack_qsiz;
  integer qsiz; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_q;
  real *q; 
  VALUE rblapack_ldq;
  integer ldq; 
  VALUE rblapack_indxq;
  integer *indxq; 
  VALUE rblapack_rho;
  real rho; 
  VALUE rblapack_cutpnt;
  integer cutpnt; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_dlamda;
  real *dlamda; 
  VALUE rblapack_q2;
  real *q2; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_perm;
  integer *perm; 
  VALUE rblapack_givptr;
  integer givptr; 
  VALUE rblapack_givcol;
  integer *givcol; 
  VALUE rblapack_givnum;
  real *givnum; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_q_out__;
  real *q_out__;
  integer *indxp;
  integer *indx;

  integer n;
  integer ldq2;

  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  k, dlamda, q2, w, perm, givptr, givcol, givnum, info, d, q, rho = NumRu::Lapack.slaed8( icompq, qsiz, d, q, ldq, indxq, rho, cutpnt, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR, GIVCOL, GIVNUM, INDXP, INDX, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLAED8 merges the two sets of eigenvalues together into a single\n*  sorted set.  Then it tries to deflate the size of the problem.\n*  There are two ways in which deflation can occur:  when two or more\n*  eigenvalues are close together or if there is a tiny element in the\n*  Z vector.  For each such occurrence the order of the related secular\n*  equation problem is reduced by one.\n*\n\n*  Arguments\n*  =========\n*\n*  ICOMPQ  (input) INTEGER\n*          = 0:  Compute eigenvalues only.\n*          = 1:  Compute eigenvectors of original dense symmetric matrix\n*                also.  On entry, Q contains the orthogonal matrix used\n*                to reduce the original matrix to tridiagonal form.\n*\n*  K      (output) INTEGER\n*         The number of non-deflated eigenvalues, and the order of the\n*         related secular equation.\n*\n*  N      (input) INTEGER\n*         The dimension of the symmetric tridiagonal matrix.  N >= 0.\n*\n*  QSIZ   (input) INTEGER\n*         The dimension of the orthogonal matrix used to reduce\n*         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.\n*\n*  D      (input/output) REAL array, dimension (N)\n*         On entry, the eigenvalues of the two submatrices to be\n*         combined.  On exit, the trailing (N-K) updated eigenvalues\n*         (those which were deflated) sorted into increasing order.\n*\n*  Q      (input/output) REAL array, dimension (LDQ,N)\n*         If ICOMPQ = 0, Q is not referenced.  Otherwise,\n*         on entry, Q contains the eigenvectors of the partially solved\n*         system which has been previously updated in matrix\n*         multiplies with other partially solved eigensystems.\n*         On exit, Q contains the trailing (N-K) updated eigenvectors\n*         (those which were deflated) in its last N-K columns.\n*\n*  LDQ    (input) INTEGER\n*         The leading dimension of the array Q.  LDQ >= max(1,N).\n*\n*  INDXQ  (input) INTEGER array, dimension (N)\n*         The permutation which separately sorts the two sub-problems\n*         in D into ascending order.  Note that elements in the second\n*         half of this permutation must first have CUTPNT added to\n*         their values in order to be accurate.\n*\n*  RHO    (input/output) REAL\n*         On entry, the off-diagonal element associated with the rank-1\n*         cut which originally split the two submatrices which are now\n*         being recombined.\n*         On exit, RHO has been modified to the value required by\n*         SLAED3.\n*\n*  CUTPNT (input) INTEGER\n*         The location of the last eigenvalue in the leading\n*         sub-matrix.  min(1,N) <= CUTPNT <= N.\n*\n*  Z      (input) REAL array, dimension (N)\n*         On entry, Z contains the updating vector (the last row of\n*         the first sub-eigenvector matrix and the first row of the\n*         second sub-eigenvector matrix).\n*         On exit, the contents of Z are destroyed by the updating\n*         process.\n*\n*  DLAMDA (output) REAL array, dimension (N)\n*         A copy of the first K eigenvalues which will be used by\n*         SLAED3 to form the secular equation.\n*\n*  Q2     (output) REAL array, dimension (LDQ2,N)\n*         If ICOMPQ = 0, Q2 is not referenced.  Otherwise,\n*         a copy of the first K eigenvectors which will be used by\n*         SLAED7 in a matrix multiply (SGEMM) to update the new\n*         eigenvectors.\n*\n*  LDQ2   (input) INTEGER\n*         The leading dimension of the array Q2.  LDQ2 >= max(1,N).\n*\n*  W      (output) REAL array, dimension (N)\n*         The first k values of the final deflation-altered z-vector and\n*         will be passed to SLAED3.\n*\n*  PERM   (output) INTEGER array, dimension (N)\n*         The permutations (from deflation and sorting) to be applied\n*         to each eigenblock.\n*\n*  GIVPTR (output) INTEGER\n*         The number of Givens rotations which took place in this\n*         subproblem.\n*\n*  GIVCOL (output) INTEGER array, dimension (2, N)\n*         Each pair of numbers indicates a pair of columns to take place\n*         in a Givens rotation.\n*\n*  GIVNUM (output) REAL array, dimension (2, N)\n*         Each number indicates the S value to be used in the\n*         corresponding Givens rotation.\n*\n*  INDXP  (workspace) INTEGER array, dimension (N)\n*         The permutation used to place deflated values of D at the end\n*         of the array.  INDXP(1:K) points to the nondeflated D-values\n*         and INDXP(K+1:N) points to the deflated eigenvalues.\n*\n*  INDX   (workspace) INTEGER array, dimension (N)\n*         The permutation used to sort the contents of D into ascending\n*         order.\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*  Based on contributions by\n*     Jeff Rutter, Computer Science Division, University of California\n*     at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  k, dlamda, q2, w, perm, givptr, givcol, givnum, info, d, q, rho = NumRu::Lapack.slaed8( icompq, qsiz, d, q, ldq, indxq, rho, cutpnt, z, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_icompq = argv[0];
  rblapack_qsiz = argv[1];
  rblapack_d = argv[2];
  rblapack_q = argv[3];
  rblapack_ldq = argv[4];
  rblapack_indxq = argv[5];
  rblapack_rho = argv[6];
  rblapack_cutpnt = argv[7];
  rblapack_z = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  icompq = NUM2INT(rblapack_icompq);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  ldq = NUM2INT(rblapack_ldq);
  rho = (real)NUM2DBL(rblapack_rho);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (9th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  qsiz = NUM2INT(rblapack_qsiz);
  if (!NA_IsNArray(rblapack_indxq))
    rb_raise(rb_eArgError, "indxq (6th argument) must be NArray");
  if (NA_RANK(rblapack_indxq) != 1)
    rb_raise(rb_eArgError, "rank of indxq (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_indxq) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of indxq must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_indxq) != NA_LINT)
    rblapack_indxq = na_change_type(rblapack_indxq, NA_LINT);
  indxq = NA_PTR_TYPE(rblapack_indxq, integer*);
  ldq2 = MAX(1,n);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (4th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (4th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_q) != (icompq==0 ? 0 : ldq))
    rb_raise(rb_eRuntimeError, "shape 0 of q must be %d", icompq==0 ? 0 : ldq);
  if (NA_SHAPE1(rblapack_q) != (icompq==0 ? 0 : n))
    rb_raise(rb_eRuntimeError, "shape 1 of q must be %d", icompq==0 ? 0 : n);
  if (NA_TYPE(rblapack_q) != NA_SFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
  q = NA_PTR_TYPE(rblapack_q, real*);
  cutpnt = NUM2INT(rblapack_cutpnt);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_dlamda = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  dlamda = NA_PTR_TYPE(rblapack_dlamda, real*);
  {
    na_shape_t shape[2];
    shape[0] = icompq==0 ? 0 : ldq2;
    shape[1] = icompq==0 ? 0 : n;
    rblapack_q2 = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  q2 = NA_PTR_TYPE(rblapack_q2, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_perm = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  perm = NA_PTR_TYPE(rblapack_perm, integer*);
  {
    na_shape_t shape[2];
    shape[0] = 2;
    shape[1] = n;
    rblapack_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
  }
  givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
  {
    na_shape_t shape[2];
    shape[0] = 2;
    shape[1] = n;
    rblapack_givnum = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  givnum = NA_PTR_TYPE(rblapack_givnum, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[2];
    shape[0] = icompq==0 ? 0 : ldq;
    shape[1] = icompq==0 ? 0 : n;
    rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
  MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  indxp = ALLOC_N(integer, (n));
  indx = ALLOC_N(integer, (n));

  slaed8_(&icompq, &k, &n, &qsiz, d, q, &ldq, indxq, &rho, &cutpnt, z, dlamda, q2, &ldq2, w, perm, &givptr, givcol, givnum, indxp, indx, &info);

  free(indxp);
  free(indx);
  rblapack_k = INT2NUM(k);
  rblapack_givptr = INT2NUM(givptr);
  rblapack_info = INT2NUM(info);
  rblapack_rho = rb_float_new((double)rho);
  return rb_ary_new3(12, rblapack_k, rblapack_dlamda, rblapack_q2, rblapack_w, rblapack_perm, rblapack_givptr, rblapack_givcol, rblapack_givnum, rblapack_info, rblapack_d, rblapack_q, rblapack_rho);
}

void
init_lapack_slaed8(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaed8", rblapack_slaed8, -1);
}
ruby-lapack-1.7.2/ext/dormtr.c0000644000175000017500000001756112502221021016037 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dormtr_(char* side, char* uplo, char* trans, integer* m, integer* n, doublereal* a, integer* lda, doublereal* tau, doublereal* c, integer* ldc, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dormtr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublereal *c_out__;

  integer lda;
  integer m;
  integer ldc;
  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  work, info, c = NumRu::Lapack.dormtr( side, uplo, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DORMTR overwrites the general real M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'T':      Q**T * C       C * Q**T\n*\n*  where Q is a real orthogonal matrix of order nq, with nq = m if\n*  SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of\n*  nq-1 elementary reflectors, as returned by DSYTRD:\n*\n*  if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);\n*\n*  if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**T from the Left;\n*          = 'R': apply Q or Q**T from the Right.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U': Upper triangle of A contains elementary reflectors\n*                 from DSYTRD;\n*          = 'L': Lower triangle of A contains elementary reflectors\n*                 from DSYTRD.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'T':  Transpose, apply Q**T.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension\n*                               (LDA,M) if SIDE = 'L'\n*                               (LDA,N) if SIDE = 'R'\n*          The vectors which define the elementary reflectors, as\n*          returned by DSYTRD.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*          LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n*\n*  TAU     (input) DOUBLE PRECISION array, dimension\n*                               (M-1) if SIDE = 'L'\n*                               (N-1) if SIDE = 'R'\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by DSYTRD.\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M).\n*          For optimum performance LWORK >= N*NB if SIDE = 'L', and\n*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n*          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*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LEFT, LQUERY, UPPER\n      INTEGER            I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            ILAENV\n      EXTERNAL           LSAME, ILAENV\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DORMQL, DORMQR, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.dormtr( side, uplo, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_uplo = argv[1];
  rblapack_trans = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 7) {
    rblapack_lwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  side = StringValueCStr(rblapack_side)[0];
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = 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*);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_tau) != (m-1))
    rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", m-1);
  if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  dormtr_(&side, &uplo, &trans, &m, &n, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_dormtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dormtr", rblapack_dormtr, -1);
}
ruby-lapack-1.7.2/ext/slartg.c0000644000175000017500000000553512502221013016023 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slartg_(real* f, real* g, real* cs, real* sn, real* r);


static VALUE
rblapack_slartg(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_f;
  real f; 
  VALUE rblapack_g;
  real g; 
  VALUE rblapack_cs;
  real cs; 
  VALUE rblapack_sn;
  real sn; 
  VALUE rblapack_r;
  real r; 


  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  cs, sn, r = NumRu::Lapack.slartg( f, g, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLARTG( F, G, CS, SN, R )\n\n*  Purpose\n*  =======\n*\n*  SLARTG generate a plane rotation so that\n*\n*     [  CS  SN  ]  .  [ F ]  =  [ R ]   where CS**2 + SN**2 = 1.\n*     [ -SN  CS  ]     [ G ]     [ 0 ]\n*\n*  This is a slower, more accurate version of the BLAS1 routine SROTG,\n*  with the following other differences:\n*     F and G are unchanged on return.\n*     If G=0, then CS=1 and SN=0.\n*     If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any\n*        floating point operations (saves work in SBDSQR when\n*        there are zeros on the diagonal).\n*\n*  If F exceeds G in magnitude, CS will be positive.\n*\n\n*  Arguments\n*  =========\n*\n*  F       (input) REAL\n*          The first component of vector to be rotated.\n*\n*  G       (input) REAL\n*          The second component of vector to be rotated.\n*\n*  CS      (output) REAL\n*          The cosine of the rotation.\n*\n*  SN      (output) REAL\n*          The sine of the rotation.\n*\n*  R       (output) REAL\n*          The nonzero component of the rotated vector.\n*\n*  This version has a few statements commented out for thread safety\n*  (machine parameters are computed on each entry). 10 feb 03, SJH.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  cs, sn, r = NumRu::Lapack.slartg( f, g, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_f = argv[0];
  rblapack_g = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  f = (real)NUM2DBL(rblapack_f);
  g = (real)NUM2DBL(rblapack_g);

  slartg_(&f, &g, &cs, &sn, &r);

  rblapack_cs = rb_float_new((double)cs);
  rblapack_sn = rb_float_new((double)sn);
  rblapack_r = rb_float_new((double)r);
  return rb_ary_new3(3, rblapack_cs, rblapack_sn, rblapack_r);
}

void
init_lapack_slartg(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slartg", rblapack_slartg, -1);
}
ruby-lapack-1.7.2/ext/dormr2.c0000644000175000017500000001416112502221015015731 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dormr2_(char* side, char* trans, integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* c, integer* ldc, doublereal* work, integer* info);


static VALUE
rblapack_dormr2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublereal *c_out__;
  doublereal *work;

  integer lda;
  integer m;
  integer k;
  integer ldc;
  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  info, c = NumRu::Lapack.dormr2( side, trans, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DORMR2 overwrites the general real m by n matrix C with\n*\n*        Q * C  if SIDE = 'L' and TRANS = 'N', or\n*\n*        Q'* C  if SIDE = 'L' and TRANS = 'T', or\n*\n*        C * Q  if SIDE = 'R' and TRANS = 'N', or\n*\n*        C * Q' if SIDE = 'R' and TRANS = 'T',\n*\n*  where Q is a real orthogonal matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(1) H(2) . . . H(k)\n*\n*  as returned by DGERQF. Q is of order m if SIDE = 'L' and of order n\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q' from the Left\n*          = 'R': apply Q or Q' from the Right\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': apply Q  (No transpose)\n*          = 'T': apply Q' (Transpose)\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension\n*                               (LDA,M) if SIDE = 'L',\n*                               (LDA,N) if SIDE = 'R'\n*          The i-th row must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          DGERQF in the last k rows of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,K).\n*\n*  TAU     (input) DOUBLE PRECISION array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by DGERQF.\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n*          On entry, the m by n matrix C.\n*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension\n*                                   (N) if SIDE = 'L',\n*                                   (M) if SIDE = 'R'\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, c = NumRu::Lapack.dormr2( side, trans, a, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_a = argv[2];
  rblapack_tau = argv[3];
  rblapack_c = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = 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*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  dormr2_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_c);
}

void
init_lapack_dormr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dormr2", rblapack_dormr2, -1);
}
ruby-lapack-1.7.2/ext/ctpcon.c0000644000175000017500000001055412502221016016015 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctpcon_(char* norm, char* uplo, char* diag, integer* n, complex* ap, real* rcond, complex* work, real* rwork, integer* info);


static VALUE
rblapack_ctpcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_info;
  integer info; 
  complex *work;
  real *rwork;

  integer ldap;
  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  rcond, info = NumRu::Lapack.ctpcon( norm, uplo, diag, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTPCON estimates the reciprocal of the condition number of a packed\n*  triangular matrix A, in either the 1-norm or the infinity-norm.\n*\n*  The norm of A is computed and an estimate is obtained for\n*  norm(inv(A)), then the reciprocal of the condition number is\n*  computed as\n*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies whether the 1-norm condition number or the\n*          infinity-norm condition number is required:\n*          = '1' or 'O':  1-norm;\n*          = 'I':         Infinity-norm.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)\n*          The upper or lower triangular matrix A, packed columnwise in\n*          a linear array.  The j-th column of A is stored in the array\n*          AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          If DIAG = 'U', the diagonal elements of A are not referenced\n*          and are assumed to be 1.\n*\n*  RCOND   (output) REAL\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(norm(A) * norm(inv(A))).\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.ctpcon( norm, uplo, diag, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_diag = argv[2];
  rblapack_ap = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (n));

  ctpcon_(&norm, &uplo, &diag, &n, ap, &rcond, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_ctpcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctpcon", rblapack_ctpcon, -1);
}
ruby-lapack-1.7.2/ext/sggrqf.c0000644000175000017500000002317712502221021016021 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sggrqf_(integer* m, integer* p, integer* n, real* a, integer* lda, real* taua, real* b, integer* ldb, real* taub, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sggrqf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_p;
  integer p; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_taua;
  real *taua; 
  VALUE rblapack_taub;
  real *taub; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_b_out__;
  real *b_out__;

  integer lda;
  integer n;
  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  taua, taub, work, info, a, b = NumRu::Lapack.sggrqf( m, p, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGGRQF computes a generalized RQ factorization of an M-by-N matrix A\n*  and a P-by-N matrix B:\n*\n*              A = R*Q,        B = Z*T*Q,\n*\n*  where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal\n*  matrix, and R and T assume one of the forms:\n*\n*  if M <= N,  R = ( 0  R12 ) M,   or if M > N,  R = ( R11 ) M-N,\n*                   N-M  M                           ( R21 ) N\n*                                                       N\n*\n*  where R12 or R21 is upper triangular, and\n*\n*  if P >= N,  T = ( T11 ) N  ,   or if P < N,  T = ( T11  T12 ) P,\n*                  (  0  ) P-N                         P   N-P\n*                     N\n*\n*  where T11 is upper triangular.\n*\n*  In particular, if B is square and nonsingular, the GRQ factorization\n*  of A and B implicitly gives the RQ factorization of A*inv(B):\n*\n*               A*inv(B) = (R*inv(T))*Z'\n*\n*  where inv(B) denotes the inverse of the matrix B, and Z' denotes the\n*  transpose of the matrix Z.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.  M >= 0.\n*\n*  P       (input) INTEGER\n*          The number of rows of the matrix B.  P >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrices A and B. N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, if M <= N, the upper triangle of the subarray\n*          A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;\n*          if M > N, the elements on and above the (M-N)-th subdiagonal\n*          contain the M-by-N upper trapezoidal matrix R; the remaining\n*          elements, with the array TAUA, represent the orthogonal\n*          matrix Q as a product of elementary reflectors (see Further\n*          Details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  TAUA    (output) REAL array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors which\n*          represent the orthogonal matrix Q (see Further Details).\n*\n*  B       (input/output) REAL array, dimension (LDB,N)\n*          On entry, the P-by-N matrix B.\n*          On exit, the elements on and above the diagonal of the array\n*          contain the min(P,N)-by-N upper trapezoidal matrix T (T is\n*          upper triangular if P >= N); the elements below the diagonal,\n*          with the array TAUB, represent the orthogonal matrix Z as a\n*          product of elementary reflectors (see Further Details).\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,P).\n*\n*  TAUB    (output) REAL array, dimension (min(P,N))\n*          The scalar factors of the elementary reflectors which\n*          represent the orthogonal matrix Z (see Further Details).\n*\n*  WORK    (workspace/output) REAL 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,N,M,P).\n*          For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),\n*          where NB1 is the optimal blocksize for the RQ factorization\n*          of an M-by-N matrix, NB2 is the optimal blocksize for the\n*          QR factorization of a P-by-N matrix, and NB3 is the optimal\n*          blocksize for a call of SORMRQ.\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 INF0= -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(1) H(2) . . . H(k), where k = min(m,n).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - taua * v * v'\n*\n*  where taua is a real scalar, and v is a real vector with\n*  v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in\n*  A(m-k+i,1:n-k+i-1), and taua in TAUA(i).\n*  To form Q explicitly, use LAPACK subroutine SORGRQ.\n*  To use Q to update another matrix, use LAPACK subroutine SORMRQ.\n*\n*  The matrix Z is represented as a product of elementary reflectors\n*\n*     Z = H(1) H(2) . . . H(k), where k = min(p,n).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - taub * v * v'\n*\n*  where taub is a real scalar, and v is a real vector with\n*  v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),\n*  and taub in TAUB(i).\n*  To form Z explicitly, use LAPACK subroutine SORGQR.\n*  To use Z to update another matrix, use LAPACK subroutine SORMQR.\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY\n      INTEGER            LOPT, LWKOPT, NB, NB1, NB2, NB3\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SGEQRF, SGERQF, SORMRQ, XERBLA\n*     ..\n*     .. External Functions ..\n      INTEGER            ILAENV \n      EXTERNAL           ILAENV \n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          INT, MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  taua, taub, work, info, a, b = NumRu::Lapack.sggrqf( m, p, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_m = argv[0];
  rblapack_p = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  p = NUM2INT(rblapack_p);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (rblapack_lwork == Qnil)
    lwork = MAX(MAX(n,m),p);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_taua = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  taua = NA_PTR_TYPE(rblapack_taua, real*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(p,n);
    rblapack_taub = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  taub = NA_PTR_TYPE(rblapack_taub, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  sggrqf_(&m, &p, &n, a, &lda, taua, b, &ldb, taub, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_taua, rblapack_taub, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_sggrqf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sggrqf", rblapack_sggrqf, -1);
}
ruby-lapack-1.7.2/ext/zgecon.c0000644000175000017500000001006412502221016016010 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgecon_(char* norm, integer* n, doublecomplex* a, integer* lda, doublereal* anorm, doublereal* rcond, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zgecon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_anorm;
  doublereal anorm; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_info;
  integer info; 
  doublecomplex *work;
  doublereal *rwork;

  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  rcond, info = NumRu::Lapack.zgecon( norm, a, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGECON estimates the reciprocal of the condition number of a general\n*  complex matrix A, in either the 1-norm or the infinity-norm, using\n*  the LU factorization computed by ZGETRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as\n*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies whether the 1-norm condition number or the\n*          infinity-norm condition number is required:\n*          = '1' or 'O':  1-norm;\n*          = 'I':         Infinity-norm.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          The factors L and U from the factorization A = P*L*U\n*          as computed by ZGETRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  ANORM   (input) DOUBLE PRECISION\n*          If NORM = '1' or 'O', the 1-norm of the original matrix A.\n*          If NORM = 'I', the infinity-norm of the original matrix A.\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(norm(A) * norm(inv(A))).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (2*N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.zgecon( norm, a, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_norm = argv[0];
  rblapack_a = argv[1];
  rblapack_anorm = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  anorm = NUM2DBL(rblapack_anorm);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (2*n));

  zgecon_(&norm, &n, a, &lda, &anorm, &rcond, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_zgecon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgecon", rblapack_zgecon, -1);
}
ruby-lapack-1.7.2/ext/slarrc.c0000644000175000017500000001160212502221013016005 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slarrc_(char* jobt, integer* n, real* vl, real* vu, real* d, real* e, real* pivmin, integer* eigcnt, integer* lcnt, integer* rcnt, integer* info);


static VALUE
rblapack_slarrc(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobt;
  char jobt; 
  VALUE rblapack_vl;
  real vl; 
  VALUE rblapack_vu;
  real vu; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_pivmin;
  real pivmin; 
  VALUE rblapack_eigcnt;
  integer eigcnt; 
  VALUE rblapack_lcnt;
  integer lcnt; 
  VALUE rblapack_rcnt;
  integer rcnt; 
  VALUE rblapack_info;
  integer info; 

  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  eigcnt, lcnt, rcnt, info = NumRu::Lapack.slarrc( jobt, vl, vu, d, e, pivmin, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLARRC( JOBT, N, VL, VU, D, E, PIVMIN, EIGCNT, LCNT, RCNT, INFO )\n\n*  Purpose\n*  =======\n*\n*  Find the number of eigenvalues of the symmetric tridiagonal matrix T\n*  that are in the interval (VL,VU] if JOBT = 'T', and of L D L^T\n*  if JOBT = 'L'.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBT    (input) CHARACTER*1\n*          = 'T':  Compute Sturm count for matrix T.\n*          = 'L':  Compute Sturm count for matrix L D L^T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix. N > 0.\n*\n*  VL      (input) DOUBLE PRECISION\n*  VU      (input) DOUBLE PRECISION\n*          The lower and upper bounds for the eigenvalues.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          JOBT = 'T': The N diagonal elements of the tridiagonal matrix T.\n*          JOBT = 'L': The N diagonal elements of the diagonal matrix D.\n*\n*  E       (input) DOUBLE PRECISION array, dimension (N)\n*          JOBT = 'T': The N-1 offdiagonal elements of the matrix T.\n*          JOBT = 'L': The N-1 offdiagonal elements of the matrix L.\n*\n*  PIVMIN  (input) REAL\n*          The minimum pivot in the Sturm sequence for T.\n*\n*  EIGCNT  (output) INTEGER\n*          The number of eigenvalues of the symmetric tridiagonal matrix T\n*          that are in the interval (VL,VU]\n*\n*  LCNT    (output) INTEGER\n*  RCNT    (output) INTEGER\n*          The left and right negcounts of the interval.\n*\n*  INFO    (output) INTEGER\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Beresford Parlett, University of California, Berkeley, USA\n*     Jim Demmel, University of California, Berkeley, USA\n*     Inderjit Dhillon, University of Texas, Austin, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  eigcnt, lcnt, rcnt, info = NumRu::Lapack.slarrc( jobt, vl, vu, d, e, pivmin, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_jobt = argv[0];
  rblapack_vl = argv[1];
  rblapack_vu = argv[2];
  rblapack_d = argv[3];
  rblapack_e = argv[4];
  rblapack_pivmin = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobt = StringValueCStr(rblapack_jobt)[0];
  vu = (real)NUM2DBL(rblapack_vu);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (5th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_e);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  vl = (real)NUM2DBL(rblapack_vl);
  pivmin = (real)NUM2DBL(rblapack_pivmin);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of e");
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);

  slarrc_(&jobt, &n, &vl, &vu, d, e, &pivmin, &eigcnt, &lcnt, &rcnt, &info);

  rblapack_eigcnt = INT2NUM(eigcnt);
  rblapack_lcnt = INT2NUM(lcnt);
  rblapack_rcnt = INT2NUM(rcnt);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_eigcnt, rblapack_lcnt, rblapack_rcnt, rblapack_info);
}

void
init_lapack_slarrc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slarrc", rblapack_slarrc, -1);
}
ruby-lapack-1.7.2/ext/zlaqsb.c0000644000175000017500000001317412502221014016022 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlaqsb_(char* uplo, integer* n, integer* kd, doublecomplex* ab, integer* ldab, doublereal* s, doublereal* scond, doublereal* amax, char* equed);


static VALUE
rblapack_zlaqsb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_scond;
  doublereal scond; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_ab_out__;
  doublecomplex *ab_out__;

  integer ldab;
  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  equed, ab = NumRu::Lapack.zlaqsb( uplo, kd, ab, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )\n\n*  Purpose\n*  =======\n*\n*  ZLAQSB equilibrates a symmetric band matrix A using the scaling\n*  factors in the vector S.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of super-diagonals of the matrix A if UPLO = 'U',\n*          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*          On exit, if INFO = 0, the triangular factor U or L from the\n*          Cholesky factorization A = U'*U or A = L*L' of the band\n*          matrix A, in the same storage format as A.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  S       (input) DOUBLE PRECISION array, dimension (N)\n*          The scale factors for A.\n*\n*  SCOND   (input) DOUBLE PRECISION\n*          Ratio of the smallest S(i) to the largest S(i).\n*\n*  AMAX    (input) DOUBLE PRECISION\n*          Absolute value of largest matrix entry.\n*\n*  EQUED   (output) CHARACTER*1\n*          Specifies whether or not equilibration was done.\n*          = 'N':  No equilibration.\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*\n*  Internal Parameters\n*  ===================\n*\n*  THRESH is a threshold value used to decide if scaling should be done\n*  based on the ratio of the scaling factors.  If SCOND < THRESH,\n*  scaling is done.\n*\n*  LARGE and SMALL are threshold values used to decide if scaling should\n*  be done based on the absolute size of the largest matrix element.\n*  If AMAX > LARGE or AMAX < SMALL, scaling is done.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  equed, ab = NumRu::Lapack.zlaqsb( uplo, kd, ab, s, scond, amax, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  rblapack_s = argv[3];
  rblapack_scond = argv[4];
  rblapack_amax = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  scond = NUM2DBL(rblapack_scond);
  kd = NUM2INT(rblapack_kd);
  amax = NUM2DBL(rblapack_amax);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (4th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
  MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  zlaqsb_(&uplo, &n, &kd, ab, &ldab, s, &scond, &amax, &equed);

  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(2, rblapack_equed, rblapack_ab);
}

void
init_lapack_zlaqsb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlaqsb", rblapack_zlaqsb, -1);
}
ruby-lapack-1.7.2/ext/clacpy.c0000644000175000017500000000705112502221024015777 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clacpy_(char* uplo, integer* m, integer* n, complex* a, integer* lda, complex* b, integer* ldb);


static VALUE
rblapack_clacpy(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 

  integer lda;
  integer n;
  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  b = NumRu::Lapack.clacpy( uplo, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLACPY( UPLO, M, N, A, LDA, B, LDB )\n\n*  Purpose\n*  =======\n*\n*  CLACPY copies all or part of a two-dimensional matrix A to another\n*  matrix B.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies the part of the matrix A to be copied to B.\n*          = 'U':      Upper triangular part\n*          = 'L':      Lower triangular part\n*          Otherwise:  All of the matrix A\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) COMPLEX array, dimension (LDA,N)\n*          The m by n matrix A.  If UPLO = 'U', only the upper trapezium\n*          is accessed; if UPLO = 'L', only the lower trapezium is\n*          accessed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  B       (output) COMPLEX array, dimension (LDB,N)\n*          On exit, B = A in the locations specified by UPLO.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,M).\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  b = NumRu::Lapack.clacpy( uplo, m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_m = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  m = NUM2INT(rblapack_m);
  ldb = MAX(1,m);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b = NA_PTR_TYPE(rblapack_b, complex*);

  clacpy_(&uplo, &m, &n, a, &lda, b, &ldb);

  return rblapack_b;
}

void
init_lapack_clacpy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clacpy", rblapack_clacpy, -1);
}
ruby-lapack-1.7.2/ext/clags2.c0000644000175000017500000001242412502221022015675 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clags2_(logical* upper, real* a1, complex* a2, real* a3, real* b1, complex* b2, real* b3, real* csu, complex* snu, real* csv, complex* snv, real* csq, complex* snq);


static VALUE
rblapack_clags2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_upper;
  logical upper; 
  VALUE rblapack_a1;
  real a1; 
  VALUE rblapack_a2;
  complex a2; 
  VALUE rblapack_a3;
  real a3; 
  VALUE rblapack_b1;
  real b1; 
  VALUE rblapack_b2;
  complex b2; 
  VALUE rblapack_b3;
  real b3; 
  VALUE rblapack_csu;
  real csu; 
  VALUE rblapack_snu;
  complex snu; 
  VALUE rblapack_csv;
  real csv; 
  VALUE rblapack_snv;
  complex snv; 
  VALUE rblapack_csq;
  real csq; 
  VALUE rblapack_snq;
  complex snq; 


  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  csu, snu, csv, snv, csq, snq = NumRu::Lapack.clags2( upper, a1, a2, a3, b1, b2, b3, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, SNV, CSQ, SNQ )\n\n*  Purpose\n*  =======\n*\n*  CLAGS2 computes 2-by-2 unitary matrices U, V and Q, such\n*  that if ( UPPER ) then\n*\n*            U'*A*Q = U'*( A1 A2 )*Q = ( x  0  )\n*                        ( 0  A3 )     ( x  x  )\n*  and\n*            V'*B*Q = V'*( B1 B2 )*Q = ( x  0  )\n*                        ( 0  B3 )     ( x  x  )\n*\n*  or if ( .NOT.UPPER ) then\n*\n*            U'*A*Q = U'*( A1 0  )*Q = ( x  x  )\n*                        ( A2 A3 )     ( 0  x  )\n*  and\n*            V'*B*Q = V'*( B1 0  )*Q = ( x  x  )\n*                        ( B2 B3 )     ( 0  x  )\n*  where\n*\n*    U = (     CSU      SNU ), V = (     CSV     SNV ),\n*        ( -CONJG(SNU)  CSU )      ( -CONJG(SNV) CSV )\n*\n*    Q = (     CSQ      SNQ )\n*        ( -CONJG(SNQ)  CSQ )\n*\n*  Z' denotes the conjugate transpose of Z.\n*\n*  The rows of the transformed A and B are parallel. Moreover, if the\n*  input 2-by-2 matrix A is not zero, then the transformed (1,1) entry\n*  of A is not zero. If the input matrices A and B are both not zero,\n*  then the transformed (2,2) element of B is not zero, except when the\n*  first rows of input A and B are parallel and the second rows are\n*  zero.\n*\n\n*  Arguments\n*  =========\n*\n*  UPPER   (input) LOGICAL\n*          = .TRUE.: the input matrices A and B are upper triangular.\n*          = .FALSE.: the input matrices A and B are lower triangular.\n*\n*  A1      (input) REAL\n*  A2      (input) COMPLEX\n*  A3      (input) REAL\n*          On entry, A1, A2 and A3 are elements of the input 2-by-2\n*          upper (lower) triangular matrix A.\n*\n*  B1      (input) REAL\n*  B2      (input) COMPLEX\n*  B3      (input) REAL\n*          On entry, B1, B2 and B3 are elements of the input 2-by-2\n*          upper (lower) triangular matrix B.\n*\n*  CSU     (output) REAL\n*  SNU     (output) COMPLEX\n*          The desired unitary matrix U.\n*\n*  CSV     (output) REAL\n*  SNV     (output) COMPLEX\n*          The desired unitary matrix V.\n*\n*  CSQ     (output) REAL\n*  SNQ     (output) COMPLEX\n*          The desired unitary matrix Q.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  csu, snu, csv, snv, csq, snq = NumRu::Lapack.clags2( upper, a1, a2, a3, b1, b2, b3, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_upper = argv[0];
  rblapack_a1 = argv[1];
  rblapack_a2 = argv[2];
  rblapack_a3 = argv[3];
  rblapack_b1 = argv[4];
  rblapack_b2 = argv[5];
  rblapack_b3 = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  upper = (rblapack_upper == Qtrue);
  a2.r = (real)NUM2DBL(rb_funcall(rblapack_a2, rb_intern("real"), 0));
  a2.i = (real)NUM2DBL(rb_funcall(rblapack_a2, rb_intern("imag"), 0));
  b1 = (real)NUM2DBL(rblapack_b1);
  b3 = (real)NUM2DBL(rblapack_b3);
  a1 = (real)NUM2DBL(rblapack_a1);
  b2.r = (real)NUM2DBL(rb_funcall(rblapack_b2, rb_intern("real"), 0));
  b2.i = (real)NUM2DBL(rb_funcall(rblapack_b2, rb_intern("imag"), 0));
  a3 = (real)NUM2DBL(rblapack_a3);

  clags2_(&upper, &a1, &a2, &a3, &b1, &b2, &b3, &csu, &snu, &csv, &snv, &csq, &snq);

  rblapack_csu = rb_float_new((double)csu);
  rblapack_snu = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(snu.r)), rb_float_new((double)(snu.i)));
  rblapack_csv = rb_float_new((double)csv);
  rblapack_snv = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(snv.r)), rb_float_new((double)(snv.i)));
  rblapack_csq = rb_float_new((double)csq);
  rblapack_snq = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(snq.r)), rb_float_new((double)(snq.i)));
  return rb_ary_new3(6, rblapack_csu, rblapack_snu, rblapack_csv, rblapack_snv, rblapack_csq, rblapack_snq);
}

void
init_lapack_clags2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clags2", rblapack_clags2, -1);
}
ruby-lapack-1.7.2/ext/dpbtrf.c0000644000175000017500000001215112502221014016001 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dpbtrf_(char* uplo, integer* n, integer* kd, doublereal* ab, integer* ldab, integer* info);


static VALUE
rblapack_dpbtrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublereal *ab_out__;

  integer ldab;
  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  info, ab = NumRu::Lapack.dpbtrf( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPBTRF( UPLO, N, KD, AB, LDAB, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPBTRF computes the Cholesky factorization of a real symmetric\n*  positive definite band matrix A.\n*\n*  The factorization has the form\n*     A = U**T * U,  if UPLO = 'U', or\n*     A = L  * L**T,  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is lower triangular.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*          On exit, if INFO = 0, the triangular factor U or L from the\n*          Cholesky factorization A = U**T*U or A = L*L**T of the band\n*          matrix A, in the same storage format as A.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\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 leading minor of order i is not\n*                positive definite, and the factorization could not be\n*                completed.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  N = 6, KD = 2, and UPLO = 'U':\n*\n*  On entry:                       On exit:\n*\n*      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46\n*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56\n*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66\n*\n*  Similarly, if UPLO = 'L' the format of A is as follows:\n*\n*  On entry:                       On exit:\n*\n*     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66\n*     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *\n*     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *\n*\n*  Array elements marked * are not used by the routine.\n*\n*  Contributed by\n*  Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ab = NumRu::Lapack.dpbtrf( uplo, kd, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  kd = NUM2INT(rblapack_kd);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
  MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  dpbtrf_(&uplo, &n, &kd, ab, &ldab, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ab);
}

void
init_lapack_dpbtrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dpbtrf", rblapack_dpbtrf, -1);
}
ruby-lapack-1.7.2/ext/zlahqr.c0000644000175000017500000002145412502221026016032 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlahqr_(logical* wantt, logical* wantz, integer* n, integer* ilo, integer* ihi, doublecomplex* h, integer* ldh, doublecomplex* w, integer* iloz, integer* ihiz, doublecomplex* z, integer* ldz, integer* info);


static VALUE
rblapack_zlahqr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantt;
  logical wantt; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_h;
  doublecomplex *h; 
  VALUE rblapack_iloz;
  integer iloz; 
  VALUE rblapack_ihiz;
  integer ihiz; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_ldz;
  integer ldz; 
  VALUE rblapack_w;
  doublecomplex *w; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_h_out__;
  doublecomplex *h_out__;
  VALUE rblapack_z_out__;
  doublecomplex *z_out__;

  integer ldh;
  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  w, info, h, z = NumRu::Lapack.zlahqr( wantt, wantz, ilo, ihi, h, iloz, ihiz, z, ldz, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, IHIZ, Z, LDZ, INFO )\n\n*     Purpose\n*     =======\n*\n*     ZLAHQR is an auxiliary routine called by CHSEQR to update the\n*     eigenvalues and Schur decomposition already computed by CHSEQR, by\n*     dealing with the Hessenberg submatrix in rows and columns ILO to\n*     IHI.\n*\n\n*     Arguments\n*     =========\n*\n*     WANTT   (input) LOGICAL\n*          = .TRUE. : the full Schur form T is required;\n*          = .FALSE.: only eigenvalues are required.\n*\n*     WANTZ   (input) LOGICAL\n*          = .TRUE. : the matrix of Schur vectors Z is required;\n*          = .FALSE.: Schur vectors are not required.\n*\n*     N       (input) INTEGER\n*          The order of the matrix H.  N >= 0.\n*\n*     ILO     (input) INTEGER\n*     IHI     (input) INTEGER\n*          It is assumed that H is already upper triangular in rows and\n*          columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1).\n*          ZLAHQR works primarily with the Hessenberg submatrix in rows\n*          and columns ILO to IHI, but applies transformations to all of\n*          H if WANTT is .TRUE..\n*          1 <= ILO <= max(1,IHI); IHI <= N.\n*\n*     H       (input/output) COMPLEX*16 array, dimension (LDH,N)\n*          On entry, the upper Hessenberg matrix H.\n*          On exit, if INFO is zero and if WANTT is .TRUE., then H\n*          is upper triangular in rows and columns ILO:IHI.  If INFO\n*          is zero and if WANTT is .FALSE., then the contents of H\n*          are unspecified on exit.  The output state of H in case\n*          INF is positive is below under the description of INFO.\n*\n*     LDH     (input) INTEGER\n*          The leading dimension of the array H. LDH >= max(1,N).\n*\n*     W       (output) COMPLEX*16 array, dimension (N)\n*          The computed eigenvalues ILO to IHI are stored in the\n*          corresponding elements of W. If WANTT is .TRUE., the\n*          eigenvalues are stored in the same order as on the diagonal\n*          of the Schur form returned in H, with W(i) = H(i,i).\n*\n*     ILOZ    (input) INTEGER\n*     IHIZ    (input) INTEGER\n*          Specify the rows of Z to which transformations must be\n*          applied if WANTZ is .TRUE..\n*          1 <= ILOZ <= ILO; IHI <= IHIZ <= N.\n*\n*     Z       (input/output) COMPLEX*16 array, dimension (LDZ,N)\n*          If WANTZ is .TRUE., on entry Z must contain the current\n*          matrix Z of transformations accumulated by CHSEQR, and on\n*          exit Z has been updated; transformations are applied only to\n*          the submatrix Z(ILOZ:IHIZ,ILO:IHI).\n*          If WANTZ is .FALSE., Z is not referenced.\n*\n*     LDZ     (input) INTEGER\n*          The leading dimension of the array Z. LDZ >= max(1,N).\n*\n*     INFO    (output) INTEGER\n*           =   0: successful exit\n*          .GT. 0: if INFO = i, ZLAHQR failed to compute all the\n*                  eigenvalues ILO to IHI in a total of 30 iterations\n*                  per eigenvalue; elements i+1:ihi of W contain\n*                  those eigenvalues which have been successfully\n*                  computed.\n*\n*                  If INFO .GT. 0 and WANTT is .FALSE., then on exit,\n*                  the remaining unconverged eigenvalues are the\n*                  eigenvalues of the upper Hessenberg matrix\n*                  rows and columns ILO thorugh INFO of the final,\n*                  output value of H.\n*\n*                  If INFO .GT. 0 and WANTT is .TRUE., then on exit\n*          (*)       (initial value of H)*U  = U*(final value of H)\n*                  where U is an orthognal matrix.    The final\n*                  value of H is upper Hessenberg and triangular in\n*                  rows and columns INFO+1 through IHI.\n*\n*                  If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n*                      (final value of Z)  = (initial value of Z)*U\n*                  where U is the orthogonal matrix in (*)\n*                  (regardless of the value of WANTT.)\n*\n\n*     Further Details\n*     ===============\n*\n*     02-96 Based on modifications by\n*     David Day, Sandia National Laboratory, USA\n*\n*     12-04 Further modifications by\n*     Ralph Byers, University of Kansas, USA\n*     This is a modified version of ZLAHQR from LAPACK version 3.0.\n*     It is (1) more robust against overflow and underflow and\n*     (2) adopts the more conservative Ahues & Tisseur stopping\n*     criterion (LAWN 122, 1997).\n*\n*     =========================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, info, h, z = NumRu::Lapack.zlahqr( wantt, wantz, ilo, ihi, h, iloz, ihiz, z, ldz, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_wantt = argv[0];
  rblapack_wantz = argv[1];
  rblapack_ilo = argv[2];
  rblapack_ihi = argv[3];
  rblapack_h = argv[4];
  rblapack_iloz = argv[5];
  rblapack_ihiz = argv[6];
  rblapack_z = argv[7];
  rblapack_ldz = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  wantt = (rblapack_wantt == Qtrue);
  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (5th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_DCOMPLEX)
    rblapack_h = na_change_type(rblapack_h, NA_DCOMPLEX);
  h = NA_PTR_TYPE(rblapack_h, doublecomplex*);
  ihiz = NUM2INT(rblapack_ihiz);
  ldz = NUM2INT(rblapack_ldz);
  wantz = (rblapack_wantz == Qtrue);
  iloz = NUM2INT(rblapack_iloz);
  ihi = NUM2INT(rblapack_ihi);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (8th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_z) != (wantz ? ldz : 0))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantz ? ldz : 0);
  if (NA_SHAPE1(rblapack_z) != (wantz ? n : 0))
    rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantz ? n : 0);
  if (NA_TYPE(rblapack_z) != NA_DCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublecomplex*);
  MEMCPY(h_out__, h, doublecomplex, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = wantz ? ldz : 0;
    shape[1] = wantz ? n : 0;
    rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublecomplex*);
  MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  zlahqr_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, w, &iloz, &ihiz, z, &ldz, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_w, rblapack_info, rblapack_h, rblapack_z);
}

void
init_lapack_zlahqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlahqr", rblapack_zlahqr, -1);
}
ruby-lapack-1.7.2/ext/dtgex2.c0000644000175000017500000002467612502221023015734 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtgex2_(logical* wantq, logical* wantz, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* q, integer* ldq, doublereal* z, integer* ldz, integer* j1, integer* n1, integer* n2, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dtgex2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantq;
  logical wantq; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_q;
  doublereal *q; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_j1;
  integer j1; 
  VALUE rblapack_n1;
  integer n1; 
  VALUE rblapack_n2;
  integer n2; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;
  VALUE rblapack_q_out__;
  doublereal *q_out__;
  VALUE rblapack_z_out__;
  doublereal *z_out__;
  doublereal *work;

  integer lda;
  integer n;
  integer ldb;
  integer ldq;
  integer ldz;

  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  info, a, b, q, z = NumRu::Lapack.dtgex2( wantq, wantz, a, b, q, z, j1, n1, n2, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, J1, N1, N2, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22)\n*  of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair\n*  (A, B) by an orthogonal equivalence transformation.\n*\n*  (A, B) must be in generalized real Schur canonical form (as returned\n*  by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2\n*  diagonal blocks. B is upper triangular.\n*\n*  Optionally, the matrices Q and Z of generalized Schur vectors are\n*  updated.\n*\n*         Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n*         Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n*\n*\n\n*  Arguments\n*  =========\n*\n*  WANTQ   (input) LOGICAL\n*          .TRUE. : update the left transformation matrix Q;\n*          .FALSE.: do not update Q.\n*\n*  WANTZ   (input) LOGICAL\n*          .TRUE. : update the right transformation matrix Z;\n*          .FALSE.: do not update Z.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B. N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimensions (LDA,N)\n*          On entry, the matrix A in the pair (A, B).\n*          On exit, the updated matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  B       (input/output) DOUBLE PRECISION array, dimensions (LDB,N)\n*          On entry, the matrix B in the pair (A, B).\n*          On exit, the updated matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n*          On entry, if WANTQ = .TRUE., the orthogonal matrix Q.\n*          On exit, the updated matrix Q.\n*          Not referenced if WANTQ = .FALSE..\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q. LDQ >= 1.\n*          If WANTQ = .TRUE., LDQ >= N.\n*\n*  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n*          On entry, if WANTZ =.TRUE., the orthogonal matrix Z.\n*          On exit, the updated matrix Z.\n*          Not referenced if WANTZ = .FALSE..\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z. LDZ >= 1.\n*          If WANTZ = .TRUE., LDZ >= N.\n*\n*  J1      (input) INTEGER\n*          The index to the first block (A11, B11). 1 <= J1 <= N.\n*\n*  N1      (input) INTEGER\n*          The order of the first block (A11, B11). N1 = 0, 1 or 2.\n*\n*  N2      (input) INTEGER\n*          The order of the second block (A22, B22). N2 = 0, 1 or 2.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)).\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK.\n*          LWORK >=  MAX( 1, N*(N2+N1), (N2+N1)*(N2+N1)*2 )\n*\n*  INFO    (output) INTEGER\n*            =0: Successful exit\n*            >0: If INFO = 1, the transformed matrix (A, B) would be\n*                too far from generalized Schur form; the blocks are\n*                not swapped and (A, B) and (Q, Z) are unchanged.\n*                The problem of swapping is too ill-conditioned.\n*            <0: If INFO = -16: LWORK is too small. Appropriate value\n*                for LWORK is returned in WORK(1).\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  In the current code both weak and strong stability tests are\n*  performed. The user can omit the strong stability test by changing\n*  the internal logical parameter WANDS to .FALSE.. See ref. [2] for\n*  details.\n*\n*  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n*      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n*      M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n*      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n*  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n*      Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n*      Estimation: Theory, Algorithms and Software,\n*      Report UMINF - 94.04, Department of Computing Science, Umea\n*      University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working\n*      Note 87. To appear in Numerical Algorithms, 1996.\n*\n*  =====================================================================\n*  Replaced various illegal calls to DCOPY by calls to DLASET, or by DO\n*  loops. Sven Hammarling, 1/5/02.\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a, b, q, z = NumRu::Lapack.dtgex2( wantq, wantz, a, b, q, z, j1, n1, n2, [: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_wantq = argv[0];
  rblapack_wantz = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  rblapack_q = argv[4];
  rblapack_z = argv[5];
  rblapack_j1 = argv[6];
  rblapack_n1 = argv[7];
  rblapack_n2 = 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;
  }

  wantq = (rblapack_wantq == Qtrue);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (5th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_q) != NA_DFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
  q = NA_PTR_TYPE(rblapack_q, doublereal*);
  j1 = NUM2INT(rblapack_j1);
  n2 = NUM2INT(rblapack_n2);
  wantz = (rblapack_wantz == Qtrue);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (6th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (6th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  if (NA_SHAPE1(rblapack_z) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  n1 = NUM2INT(rblapack_n1);
  lwork = MAX(1,(MAX(n*(n2+n1),(n2+n1)*(n2+n1)*2)));
  {
    na_shape_t 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__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
  MEMCPY(q_out__, q, doublereal, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
  MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  work = ALLOC_N(doublereal, (lwork));

  dtgex2_(&wantq, &wantz, &n, a, &lda, b, &ldb, q, &ldq, z, &ldz, &j1, &n1, &n2, work, &lwork, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z);
}

void
init_lapack_dtgex2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtgex2", rblapack_dtgex2, -1);
}
ruby-lapack-1.7.2/ext/zgbsvx.c0000644000175000017500000005320412502221013016046 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgbsvx_(char* fact, char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, doublecomplex* ab, integer* ldab, doublecomplex* afb, integer* ldafb, integer* ipiv, char* equed, doublereal* r, doublereal* c, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zgbsvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_afb;
  doublecomplex *afb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_r;
  doublereal *r; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_rwork;
  doublereal *rwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublecomplex *ab_out__;
  VALUE rblapack_afb_out__;
  doublecomplex *afb_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  VALUE rblapack_r_out__;
  doublereal *r_out__;
  VALUE rblapack_c_out__;
  doublereal *c_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  doublecomplex *work;

  integer ldab;
  integer n;
  integer ldb;
  integer nrhs;
  integer ldafb;
  integer ldx;

  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  x, rcond, ferr, berr, rwork, info, ab, afb, ipiv, equed, r, c, b = NumRu::Lapack.zgbsvx( fact, trans, kl, ku, ab, b, [:afb => afb, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGBSVX uses the LU factorization to compute the solution to a complex\n*  system of linear equations A * X = B, A**T * X = B, or A**H * X = B,\n*  where A is a band matrix of order N with KL subdiagonals and KU\n*  superdiagonals, and X and B are N-by-NRHS matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed by this subroutine:\n*\n*  1. If FACT = 'E', real scaling factors are computed to equilibrate\n*     the system:\n*        TRANS = 'N':  diag(R)*A*diag(C)     *inv(diag(C))*X = diag(R)*B\n*        TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n*        TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n*     or diag(C)*B (if TRANS = 'T' or 'C').\n*\n*  2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n*     matrix A (after equilibration if FACT = 'E') as\n*        A = L * U,\n*     where L is a product of permutation and unit lower triangular\n*     matrices with KL subdiagonals, and U is upper triangular with\n*     KL+KU superdiagonals.\n*\n*  3. If some U(i,i)=0, so that U is exactly singular, then the routine\n*     returns with INFO = i. Otherwise, the factored form of A is used\n*     to estimate the condition number of the matrix A.  If the\n*     reciprocal of the condition number is less than machine precision,\n*     INFO = N+1 is returned as a warning, but the routine still goes on\n*     to solve for X and compute error bounds as described below.\n*\n*  4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  5. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n*  6. If equilibration was used, the matrix X is premultiplied by\n*     diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n*     that it solves the original system before equilibration.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of the matrix A is\n*          supplied on entry, and if not, whether the matrix A should be\n*          equilibrated before it is factored.\n*          = 'F':  On entry, AFB and IPIV contain the factored form of\n*                  A.  If EQUED is not 'N', the matrix A has been\n*                  equilibrated with scaling factors given by R and C.\n*                  AB, AFB, and IPIV are not modified.\n*          = 'N':  The matrix A will be copied to AFB and factored.\n*          = 'E':  The matrix A will be equilibrated if necessary, then\n*                  copied to AFB and factored.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations.\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose)\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)\n*          On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n*          The j-th column of A is stored in the j-th column of the\n*          array AB as follows:\n*          AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n*          If FACT = 'F' and EQUED is not 'N', then A must have been\n*          equilibrated by the scaling factors in R and/or C.  AB is not\n*          modified if FACT = 'F' or 'N', or if FACT = 'E' and\n*          EQUED = 'N' on exit.\n*\n*          On exit, if EQUED .ne. 'N', A is scaled as follows:\n*          EQUED = 'R':  A := diag(R) * A\n*          EQUED = 'C':  A := A * diag(C)\n*          EQUED = 'B':  A := diag(R) * A * diag(C).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*  AFB     (input or output) COMPLEX*16 array, dimension (LDAFB,N)\n*          If FACT = 'F', then AFB is an input argument and on entry\n*          contains details of the LU factorization of the band matrix\n*          A, as computed by ZGBTRF.  U is stored as an upper triangular\n*          band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n*          and the multipliers used during the factorization are stored\n*          in rows KL+KU+2 to 2*KL+KU+1.  If EQUED .ne. 'N', then AFB is\n*          the factored form of the equilibrated matrix A.\n*\n*          If FACT = 'N', then AFB is an output argument and on exit\n*          returns details of the LU factorization of A.\n*\n*          If FACT = 'E', then AFB is an output argument and on exit\n*          returns details of the LU factorization of the equilibrated\n*          matrix A (see the description of AB for the form of the\n*          equilibrated matrix).\n*\n*  LDAFB   (input) INTEGER\n*          The leading dimension of the array AFB.  LDAFB >= 2*KL+KU+1.\n*\n*  IPIV    (input or output) INTEGER array, dimension (N)\n*          If FACT = 'F', then IPIV is an input argument and on entry\n*          contains the pivot indices from the factorization A = L*U\n*          as computed by ZGBTRF; row i of the matrix was interchanged\n*          with row IPIV(i).\n*\n*          If FACT = 'N', then IPIV is an output argument and on exit\n*          contains the pivot indices from the factorization A = L*U\n*          of the original matrix A.\n*\n*          If FACT = 'E', then IPIV is an output argument and on exit\n*          contains the pivot indices from the factorization A = L*U\n*          of the equilibrated matrix A.\n*\n*  EQUED   (input or output) CHARACTER*1\n*          Specifies the form of equilibration that was done.\n*          = 'N':  No equilibration (always true if FACT = 'N').\n*          = 'R':  Row equilibration, i.e., A has been premultiplied by\n*                  diag(R).\n*          = 'C':  Column equilibration, i.e., A has been postmultiplied\n*                  by diag(C).\n*          = 'B':  Both row and column equilibration, i.e., A has been\n*                  replaced by diag(R) * A * diag(C).\n*          EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*          output argument.\n*\n*  R       (input or output) DOUBLE PRECISION array, dimension (N)\n*          The row scale factors for A.  If EQUED = 'R' or 'B', A is\n*          multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n*          is not accessed.  R is an input argument if FACT = 'F';\n*          otherwise, R is an output argument.  If FACT = 'F' and\n*          EQUED = 'R' or 'B', each element of R must be positive.\n*\n*  C       (input or output) DOUBLE PRECISION array, dimension (N)\n*          The column scale factors for A.  If EQUED = 'C' or 'B', A is\n*          multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n*          is not accessed.  C is an input argument if FACT = 'F';\n*          otherwise, C is an output argument.  If FACT = 'F' and\n*          EQUED = 'C' or 'B', each element of C must be positive.\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit,\n*          if EQUED = 'N', B is not modified;\n*          if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n*          diag(R)*B;\n*          if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n*          overwritten by diag(C)*B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) COMPLEX*16 array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n*          to the original system of equations.  Note that A and B are\n*          modified on exit if EQUED .ne. 'N', and the solution to the\n*          equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n*          EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n*          and EQUED = 'R' or 'B'.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The estimate of the reciprocal condition number of the matrix\n*          A after equilibration (if done).  If RCOND is less than the\n*          machine precision (in particular, if RCOND = 0), the matrix\n*          is singular to working precision.  This condition is\n*          indicated by a return code of INFO > 0.\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace/output) DOUBLE PRECISION array, dimension (N)\n*          On exit, RWORK(1) contains the reciprocal pivot growth\n*          factor norm(A)/norm(U). The \"max absolute element\" norm is\n*          used. If RWORK(1) is much less than 1, then the stability\n*          of the LU factorization of the (equilibrated) matrix A\n*          could be poor. This also means that the solution X, condition\n*          estimator RCOND, and forward error bound FERR could be\n*          unreliable. If factorization fails with 0 0:  if INFO = i, and i is\n*                <= N:  U(i,i) is exactly zero.  The factorization\n*                       has been completed, but the factor U is exactly\n*                       singular, so the solution and error bounds\n*                       could not be computed. RCOND = 0 is returned.\n*                = N+1: U is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  =====================================================================\n*  Moved setting of INFO = N+1 so INFO does not subsequently get\n*  overwritten.  Sven, 17 Mar 05. \n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, rwork, info, ab, afb, ipiv, equed, r, c, b = NumRu::Lapack.zgbsvx( fact, trans, kl, ku, ab, b, [:afb => afb, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 11)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_fact = argv[0];
  rblapack_trans = argv[1];
  rblapack_kl = argv[2];
  rblapack_ku = argv[3];
  rblapack_ab = argv[4];
  rblapack_b = argv[5];
  if (argc == 11) {
    rblapack_afb = argv[6];
    rblapack_ipiv = argv[7];
    rblapack_equed = argv[8];
    rblapack_r = argv[9];
    rblapack_c = argv[10];
  } else if (rblapack_options != Qnil) {
    rblapack_afb = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("afb")));
    rblapack_ipiv = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("ipiv")));
    rblapack_equed = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("equed")));
    rblapack_r = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("r")));
    rblapack_c = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("c")));
  } else {
    rblapack_afb = Qnil;
    rblapack_ipiv = Qnil;
    rblapack_equed = Qnil;
    rblapack_r = Qnil;
    rblapack_c = Qnil;
  }

  fact = StringValueCStr(rblapack_fact)[0];
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  if (rblapack_ipiv != Qnil) {
    if (!NA_IsNArray(rblapack_ipiv))
      rb_raise(rb_eArgError, "ipiv (option) must be NArray");
    if (NA_RANK(rblapack_ipiv) != 1)
      rb_raise(rb_eArgError, "rank of ipiv (option) must be %d", 1);
    if (NA_SHAPE0(rblapack_ipiv) != n)
      rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of ab");
    if (NA_TYPE(rblapack_ipiv) != NA_LINT)
      rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
    ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  }
  if (rblapack_r != Qnil) {
    if (!NA_IsNArray(rblapack_r))
      rb_raise(rb_eArgError, "r (option) must be NArray");
    if (NA_RANK(rblapack_r) != 1)
      rb_raise(rb_eArgError, "rank of r (option) must be %d", 1);
    if (NA_SHAPE0(rblapack_r) != n)
      rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of ab");
    if (NA_TYPE(rblapack_r) != NA_DFLOAT)
      rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
    r = NA_PTR_TYPE(rblapack_r, doublereal*);
  }
  ldx = n;
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  if (rblapack_equed != Qnil) {
  equed = StringValueCStr(rblapack_equed)[0];
  }
  ku = NUM2INT(rblapack_ku);
  if (rblapack_c != Qnil) {
    if (!NA_IsNArray(rblapack_c))
      rb_raise(rb_eArgError, "c (option) must be NArray");
    if (NA_RANK(rblapack_c) != 1)
      rb_raise(rb_eArgError, "rank of c (option) must be %d", 1);
    if (NA_SHAPE0(rblapack_c) != n)
      rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
    if (NA_TYPE(rblapack_c) != NA_DFLOAT)
      rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
    c = NA_PTR_TYPE(rblapack_c, doublereal*);
  }
  ldafb = 2*kl+ku+1;
  if (rblapack_afb != Qnil) {
    if (!NA_IsNArray(rblapack_afb))
      rb_raise(rb_eArgError, "afb (option) must be NArray");
    if (NA_RANK(rblapack_afb) != 2)
      rb_raise(rb_eArgError, "rank of afb (option) must be %d", 2);
    if (NA_SHAPE0(rblapack_afb) != ldafb)
      rb_raise(rb_eRuntimeError, "shape 0 of afb must be 2*kl+ku+1");
    if (NA_SHAPE1(rblapack_afb) != n)
      rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
    if (NA_TYPE(rblapack_afb) != NA_DCOMPLEX)
      rblapack_afb = na_change_type(rblapack_afb, NA_DCOMPLEX);
    afb = NA_PTR_TYPE(rblapack_afb, doublecomplex*);
  }
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
  MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldafb;
    shape[1] = n;
    rblapack_afb_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  afb_out__ = NA_PTR_TYPE(rblapack_afb_out__, doublecomplex*);
  if (rblapack_afb != Qnil) {
    MEMCPY(afb_out__, afb, doublecomplex, NA_TOTAL(rblapack_afb));
  }
  rblapack_afb = rblapack_afb_out__;
  afb = afb_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  if (rblapack_ipiv != Qnil) {
    MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  }
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_r_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  r_out__ = NA_PTR_TYPE(rblapack_r_out__, doublereal*);
  if (rblapack_r != Qnil) {
    MEMCPY(r_out__, r, doublereal, NA_TOTAL(rblapack_r));
  }
  rblapack_r = rblapack_r_out__;
  r = r_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  if (rblapack_c != Qnil) {
    MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  }
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(doublecomplex, (2*n));

  zgbsvx_(&fact, &trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);

  free(work);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(13, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_rwork, rblapack_info, rblapack_ab, rblapack_afb, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b);
}

void
init_lapack_zgbsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgbsvx", rblapack_zgbsvx, -1);
}
ruby-lapack-1.7.2/ext/slasdq.c0000644000175000017500000002546012502221024016017 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slasdq_(char* uplo, integer* sqre, integer* n, integer* ncvt, integer* nru, integer* ncc, real* d, real* e, real* vt, integer* ldvt, real* u, integer* ldu, real* c, integer* ldc, real* work, integer* info);


static VALUE
rblapack_slasdq(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_sqre;
  integer sqre; 
  VALUE rblapack_nru;
  integer nru; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_vt;
  real *vt; 
  VALUE rblapack_u;
  real *u; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_e_out__;
  real *e_out__;
  VALUE rblapack_vt_out__;
  real *vt_out__;
  VALUE rblapack_u_out__;
  real *u_out__;
  VALUE rblapack_c_out__;
  real *c_out__;
  real *work;

  integer n;
  integer ldvt;
  integer ncvt;
  integer ldu;
  integer ldc;
  integer ncc;

  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  info, d, e, vt, u, c = NumRu::Lapack.slasdq( uplo, sqre, nru, d, e, vt, u, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLASDQ computes the singular value decomposition (SVD) of a real\n*  (upper or lower) bidiagonal matrix with diagonal D and offdiagonal\n*  E, accumulating the transformations if desired. Letting B denote\n*  the input bidiagonal matrix, the algorithm computes orthogonal\n*  matrices Q and P such that B = Q * S * P' (P' denotes the transpose\n*  of P). The singular values S are overwritten on D.\n*\n*  The input matrix U  is changed to U  * Q  if desired.\n*  The input matrix VT is changed to P' * VT if desired.\n*  The input matrix C  is changed to Q' * C  if desired.\n*\n*  See \"Computing  Small Singular Values of Bidiagonal Matrices With\n*  Guaranteed High Relative Accuracy,\" by J. Demmel and W. Kahan,\n*  LAPACK Working Note #3, for a detailed description of the algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO  (input) CHARACTER*1\n*        On entry, UPLO specifies whether the input bidiagonal matrix\n*        is upper or lower bidiagonal, and wether it is square are\n*        not.\n*           UPLO = 'U' or 'u'   B is upper bidiagonal.\n*           UPLO = 'L' or 'l'   B is lower bidiagonal.\n*\n*  SQRE  (input) INTEGER\n*        = 0: then the input matrix is N-by-N.\n*        = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and\n*             (N+1)-by-N if UPLU = 'L'.\n*\n*        The bidiagonal matrix has\n*        N = NL + NR + 1 rows and\n*        M = N + SQRE >= N columns.\n*\n*  N     (input) INTEGER\n*        On entry, N specifies the number of rows and columns\n*        in the matrix. N must be at least 0.\n*\n*  NCVT  (input) INTEGER\n*        On entry, NCVT specifies the number of columns of\n*        the matrix VT. NCVT must be at least 0.\n*\n*  NRU   (input) INTEGER\n*        On entry, NRU specifies the number of rows of\n*        the matrix U. NRU must be at least 0.\n*\n*  NCC   (input) INTEGER\n*        On entry, NCC specifies the number of columns of\n*        the matrix C. NCC must be at least 0.\n*\n*  D     (input/output) REAL array, dimension (N)\n*        On entry, D contains the diagonal entries of the\n*        bidiagonal matrix whose SVD is desired. On normal exit,\n*        D contains the singular values in ascending order.\n*\n*  E     (input/output) REAL array.\n*        dimension is (N-1) if SQRE = 0 and N if SQRE = 1.\n*        On entry, the entries of E contain the offdiagonal entries\n*        of the bidiagonal matrix whose SVD is desired. On normal\n*        exit, E will contain 0. If the algorithm does not converge,\n*        D and E will contain the diagonal and superdiagonal entries\n*        of a bidiagonal matrix orthogonally equivalent to the one\n*        given as input.\n*\n*  VT    (input/output) REAL array, dimension (LDVT, NCVT)\n*        On entry, contains a matrix which on exit has been\n*        premultiplied by P', dimension N-by-NCVT if SQRE = 0\n*        and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0).\n*\n*  LDVT  (input) INTEGER\n*        On entry, LDVT specifies the leading dimension of VT as\n*        declared in the calling (sub) program. LDVT must be at\n*        least 1. If NCVT is nonzero LDVT must also be at least N.\n*\n*  U     (input/output) REAL array, dimension (LDU, N)\n*        On entry, contains a  matrix which on exit has been\n*        postmultiplied by Q, dimension NRU-by-N if SQRE = 0\n*        and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0).\n*\n*  LDU   (input) INTEGER\n*        On entry, LDU  specifies the leading dimension of U as\n*        declared in the calling (sub) program. LDU must be at\n*        least max( 1, NRU ) .\n*\n*  C     (input/output) REAL array, dimension (LDC, NCC)\n*        On entry, contains an N-by-NCC matrix which on exit\n*        has been premultiplied by Q'  dimension N-by-NCC if SQRE = 0\n*        and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0).\n*\n*  LDC   (input) INTEGER\n*        On entry, LDC  specifies the leading dimension of C as\n*        declared in the calling (sub) program. LDC must be at\n*        least 1. If NCC is nonzero, LDC must also be at least N.\n*\n*  WORK  (workspace) REAL array, dimension (4*N)\n*        Workspace. Only referenced if one of NCVT, NRU, or NCC is\n*        nonzero, and if N is at least 2.\n*\n*  INFO  (output) INTEGER\n*        On exit, a value of 0 indicates a successful exit.\n*        If INFO < 0, argument number -INFO is illegal.\n*        If INFO > 0, the algorithm did not converge, and INFO\n*        specifies how many superdiagonals did not converge.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, e, vt, u, c = NumRu::Lapack.slasdq( uplo, sqre, nru, d, e, vt, u, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_uplo = argv[0];
  rblapack_sqre = argv[1];
  rblapack_nru = argv[2];
  rblapack_d = argv[3];
  rblapack_e = argv[4];
  rblapack_vt = argv[5];
  rblapack_u = argv[6];
  rblapack_c = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  nru = NUM2INT(rblapack_nru);
  if (!NA_IsNArray(rblapack_vt))
    rb_raise(rb_eArgError, "vt (6th argument) must be NArray");
  if (NA_RANK(rblapack_vt) != 2)
    rb_raise(rb_eArgError, "rank of vt (6th argument) must be %d", 2);
  ldvt = NA_SHAPE0(rblapack_vt);
  ncvt = NA_SHAPE1(rblapack_vt);
  if (NA_TYPE(rblapack_vt) != NA_SFLOAT)
    rblapack_vt = na_change_type(rblapack_vt, NA_SFLOAT);
  vt = NA_PTR_TYPE(rblapack_vt, real*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (8th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  ncc = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  sqre = NUM2INT(rblapack_sqre);
  if (!NA_IsNArray(rblapack_u))
    rb_raise(rb_eArgError, "u (7th argument) must be NArray");
  if (NA_RANK(rblapack_u) != 2)
    rb_raise(rb_eArgError, "rank of u (7th argument) must be %d", 2);
  ldu = NA_SHAPE0(rblapack_u);
  n = NA_SHAPE1(rblapack_u);
  if (NA_TYPE(rblapack_u) != NA_SFLOAT)
    rblapack_u = na_change_type(rblapack_u, NA_SFLOAT);
  u = NA_PTR_TYPE(rblapack_u, real*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of u");
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (5th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (sqre==0 ? n-1 : sqre==1 ? n : 0))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", sqre==0 ? n-1 : sqre==1 ? n : 0);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = sqre==0 ? n-1 : sqre==1 ? n : 0;
    rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
  MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvt;
    shape[1] = ncvt;
    rblapack_vt_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vt_out__ = NA_PTR_TYPE(rblapack_vt_out__, real*);
  MEMCPY(vt_out__, vt, real, NA_TOTAL(rblapack_vt));
  rblapack_vt = rblapack_vt_out__;
  vt = vt_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = n;
    rblapack_u_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  u_out__ = NA_PTR_TYPE(rblapack_u_out__, real*);
  MEMCPY(u_out__, u, real, NA_TOTAL(rblapack_u));
  rblapack_u = rblapack_u_out__;
  u = u_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = ncc;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(real, (4*n));

  slasdq_(&uplo, &sqre, &n, &ncvt, &nru, &ncc, d, e, vt, &ldvt, u, &ldu, c, &ldc, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_info, rblapack_d, rblapack_e, rblapack_vt, rblapack_u, rblapack_c);
}

void
init_lapack_slasdq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slasdq", rblapack_slasdq, -1);
}
ruby-lapack-1.7.2/ext/chpevd.c0000644000175000017500000002356612502221026016010 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chpevd_(char* jobz, char* uplo, integer* n, complex* ap, real* w, complex* z, integer* ldz, complex* work, integer* lwork, real* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_chpevd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_lrwork;
  integer lrwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_rwork;
  real *rwork; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  complex *ap_out__;

  integer ldap;
  integer n;
  integer ldz;

  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  w, z, work, rwork, iwork, info, ap = NumRu::Lapack.chpevd( jobz, uplo, ap, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHPEVD computes all the eigenvalues and, optionally, eigenvectors of\n*  a complex Hermitian matrix A in packed storage.  If eigenvectors are\n*  desired, it uses a divide and conquer algorithm.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, AP is overwritten by values generated during the\n*          reduction to tridiagonal form.  If UPLO = 'U', the diagonal\n*          and first superdiagonal of the tridiagonal matrix T overwrite\n*          the corresponding elements of A, and if UPLO = 'L', the\n*          diagonal and first subdiagonal of T overwrite the\n*          corresponding elements of A.\n*\n*  W       (output) REAL array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) COMPLEX array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n*          eigenvectors of the matrix A, with the i-th column of Z\n*          holding the eigenvector associated with W(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the required LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of array WORK.\n*          If N <= 1,               LWORK must be at least 1.\n*          If JOBZ = 'N' and N > 1, LWORK must be at least N.\n*          If JOBZ = 'V' and N > 1, LWORK must be at least 2*N.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the required sizes of the WORK, RWORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  RWORK   (workspace/output) REAL array, dimension (MAX(1,LRWORK))\n*          On exit, if INFO = 0, RWORK(1) returns the required LRWORK.\n*\n*  LRWORK  (input) INTEGER\n*          The dimension of array RWORK.\n*          If N <= 1,               LRWORK must be at least 1.\n*          If JOBZ = 'N' and N > 1, LRWORK must be at least N.\n*          If JOBZ = 'V' and N > 1, LRWORK must be at least\n*                    1 + 5*N + 2*N**2.\n*\n*          If LRWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the required sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of array IWORK.\n*          If JOBZ  = 'N' or N <= 1, LIWORK must be at least 1.\n*          If JOBZ  = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the required sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK 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 algorithm failed to converge; i\n*                off-diagonal elements of an intermediate tridiagonal\n*                form did not converge to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, work, rwork, iwork, info, ap = NumRu::Lapack.chpevd( jobz, uplo, ap, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_ap = argv[2];
  if (argc == 6) {
    rblapack_lwork = argv[3];
    rblapack_lrwork = argv[4];
    rblapack_liwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_lrwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (rblapack_lrwork == Qnil)
    lrwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
  else {
    lrwork = NUM2INT(rblapack_lrwork);
  }
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  if (rblapack_lwork == Qnil)
    lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 2*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (rblapack_liwork == Qnil)
    liwork = (lsame_(&jobz,"N")||n<=1) ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lrwork);
    rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  rwork = NA_PTR_TYPE(rblapack_rwork, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
  MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  chpevd_(&jobz, &uplo, &n, ap, w, z, &ldz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_w, rblapack_z, rblapack_work, rblapack_rwork, rblapack_iwork, rblapack_info, rblapack_ap);
}

void
init_lapack_chpevd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chpevd", rblapack_chpevd, -1);
}
ruby-lapack-1.7.2/ext/cgges.c0000644000175000017500000003121412502221014015611 0ustar  uwabamiuwabami#include "rb_lapack.h"

static logical
rblapack_selctg(complex *arg0, complex *arg1){
  VALUE rblapack_arg0, rblapack_arg1;

  VALUE rblapack_ret;
  logical ret;

  rblapack_arg0 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg0->r)), rb_float_new((double)(arg0->i)));
  rblapack_arg1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg1->r)), rb_float_new((double)(arg1->i)));

  rblapack_ret = rb_yield_values(2, rblapack_arg0, rblapack_arg1);

  ret = (rblapack_ret == Qtrue);
  return ret;
}

extern VOID cgges_(char* jobvsl, char* jobvsr, char* sort, L_fp selctg, integer* n, complex* a, integer* lda, complex* b, integer* ldb, integer* sdim, complex* alpha, complex* beta, complex* vsl, integer* ldvsl, complex* vsr, integer* ldvsr, complex* work, integer* lwork, real* rwork, logical* bwork, integer* info);


static VALUE
rblapack_cgges(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvsl;
  char jobvsl; 
  VALUE rblapack_jobvsr;
  char jobvsr; 
  VALUE rblapack_sort;
  char sort; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_sdim;
  integer sdim; 
  VALUE rblapack_alpha;
  complex *alpha; 
  VALUE rblapack_beta;
  complex *beta; 
  VALUE rblapack_vsl;
  complex *vsl; 
  VALUE rblapack_vsr;
  complex *vsr; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;
  real *rwork;
  logical *bwork;

  integer lda;
  integer n;
  integer ldb;
  integer ldvsl;
  integer ldvsr;

  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  sdim, alpha, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.cgges( jobvsl, jobvsr, sort, a, b, [:lwork => lwork, :usage => usage, :help => help]){|a,b| ... }\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, BWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGGES computes for a pair of N-by-N complex nonsymmetric matrices\n*  (A,B), the generalized eigenvalues, the generalized complex Schur\n*  form (S, T), and optionally left and/or right Schur vectors (VSL\n*  and VSR). This gives the generalized Schur factorization\n*\n*          (A,B) = ( (VSL)*S*(VSR)**H, (VSL)*T*(VSR)**H )\n*\n*  where (VSR)**H is the conjugate-transpose of VSR.\n*\n*  Optionally, it also orders the eigenvalues so that a selected cluster\n*  of eigenvalues appears in the leading diagonal blocks of the upper\n*  triangular matrix S and the upper triangular matrix T. The leading\n*  columns of VSL and VSR then form an unitary basis for the\n*  corresponding left and right eigenspaces (deflating subspaces).\n*\n*  (If only the generalized eigenvalues are needed, use the driver\n*  CGGEV instead, which is faster.)\n*\n*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n*  or a ratio alpha/beta = w, such that  A - w*B is singular.  It is\n*  usually represented as the pair (alpha,beta), as there is a\n*  reasonable interpretation for beta=0, and even for both being zero.\n*\n*  A pair of matrices (S,T) is in generalized complex Schur form if S\n*  and T are upper triangular and, in addition, the diagonal elements\n*  of T are non-negative real numbers.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVSL  (input) CHARACTER*1\n*          = 'N':  do not compute the left Schur vectors;\n*          = 'V':  compute the left Schur vectors.\n*\n*  JOBVSR  (input) CHARACTER*1\n*          = 'N':  do not compute the right Schur vectors;\n*          = 'V':  compute the right Schur vectors.\n*\n*  SORT    (input) CHARACTER*1\n*          Specifies whether or not to order the eigenvalues on the\n*          diagonal of the generalized Schur form.\n*          = 'N':  Eigenvalues are not ordered;\n*          = 'S':  Eigenvalues are ordered (see SELCTG).\n*\n*  SELCTG  (external procedure) LOGICAL FUNCTION of two COMPLEX arguments\n*          SELCTG must be declared EXTERNAL in the calling subroutine.\n*          If SORT = 'N', SELCTG is not referenced.\n*          If SORT = 'S', SELCTG is used to select eigenvalues to sort\n*          to the top left of the Schur form.\n*          An eigenvalue ALPHA(j)/BETA(j) is selected if\n*          SELCTG(ALPHA(j),BETA(j)) is true.\n*\n*          Note that a selected complex eigenvalue may no longer satisfy\n*          SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since\n*          ordering may change the value of complex eigenvalues\n*          (especially if the eigenvalue is ill-conditioned), in this\n*          case INFO is set to N+2 (See INFO below).\n*\n*  N       (input) INTEGER\n*          The order of the matrices A, B, VSL, and VSR.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA, N)\n*          On entry, the first of the pair of matrices.\n*          On exit, A has been overwritten by its generalized Schur\n*          form S.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of A.  LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX array, dimension (LDB, N)\n*          On entry, the second of the pair of matrices.\n*          On exit, B has been overwritten by its generalized Schur\n*          form T.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of B.  LDB >= max(1,N).\n*\n*  SDIM    (output) INTEGER\n*          If SORT = 'N', SDIM = 0.\n*          If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n*          for which SELCTG is true.\n*\n*  ALPHA   (output) COMPLEX array, dimension (N)\n*  BETA    (output) COMPLEX array, dimension (N)\n*          On exit,  ALPHA(j)/BETA(j), j=1,...,N, will be the\n*          generalized eigenvalues.  ALPHA(j), j=1,...,N  and  BETA(j),\n*          j=1,...,N  are the diagonals of the complex Schur form (A,B)\n*          output by CGGES. The  BETA(j) will be non-negative real.\n*\n*          Note: the quotients ALPHA(j)/BETA(j) may easily over- or\n*          underflow, and BETA(j) may even be zero.  Thus, the user\n*          should avoid naively computing the ratio alpha/beta.\n*          However, ALPHA will be always less than and usually\n*          comparable with norm(A) in magnitude, and BETA always less\n*          than and usually comparable with norm(B).\n*\n*  VSL     (output) COMPLEX array, dimension (LDVSL,N)\n*          If JOBVSL = 'V', VSL will contain the left Schur vectors.\n*          Not referenced if JOBVSL = 'N'.\n*\n*  LDVSL   (input) INTEGER\n*          The leading dimension of the matrix VSL. LDVSL >= 1, and\n*          if JOBVSL = 'V', LDVSL >= N.\n*\n*  VSR     (output) COMPLEX array, dimension (LDVSR,N)\n*          If JOBVSR = 'V', VSR will contain the right Schur vectors.\n*          Not referenced if JOBVSR = 'N'.\n*\n*  LDVSR   (input) INTEGER\n*          The leading dimension of the matrix VSR. LDVSR >= 1, and\n*          if JOBVSR = 'V', LDVSR >= N.\n*\n*  WORK    (workspace/output) COMPLEX 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,2*N).\n*          For good performance, LWORK must generally be larger.\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*  RWORK   (workspace) REAL array, dimension (8*N)\n*\n*  BWORK   (workspace) LOGICAL array, dimension (N)\n*          Not referenced if SORT = 'N'.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          =1,...,N:\n*                The QZ iteration failed.  (A,B) are not in Schur\n*                form, but ALPHA(j) and BETA(j) should be correct for\n*                j=INFO+1,...,N.\n*          > N:  =N+1: other than QZ iteration failed in CHGEQZ\n*                =N+2: after reordering, roundoff changed values of\n*                      some complex eigenvalues so that leading\n*                      eigenvalues in the Generalized Schur form no\n*                      longer satisfy SELCTG=.TRUE.  This could also\n*                      be caused due to scaling.\n*                =N+3: reordering falied in CTGSEN.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sdim, alpha, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.cgges( jobvsl, jobvsr, sort, a, b, [:lwork => lwork, :usage => usage, :help => help]){|a,b| ... }\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_jobvsl = argv[0];
  rblapack_jobvsr = argv[1];
  rblapack_sort = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  if (argc == 6) {
    rblapack_lwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  jobvsl = StringValueCStr(rblapack_jobvsl)[0];
  sort = StringValueCStr(rblapack_sort)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  jobvsr = StringValueCStr(rblapack_jobvsr)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  ldvsl = lsame_(&jobvsl,"V") ? n : 1;
  if (rblapack_lwork == Qnil)
    lwork = 2*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldvsr = lsame_(&jobvsr,"V") ? n : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  alpha = NA_PTR_TYPE(rblapack_alpha, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvsl;
    shape[1] = n;
    rblapack_vsl = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  vsl = NA_PTR_TYPE(rblapack_vsl, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvsr;
    shape[1] = n;
    rblapack_vsr = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  vsr = NA_PTR_TYPE(rblapack_vsr, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  rwork = ALLOC_N(real, (8*n));
  bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));

  cgges_(&jobvsl, &jobvsr, &sort, rblapack_selctg, &n, a, &lda, b, &ldb, &sdim, alpha, beta, vsl, &ldvsl, vsr, &ldvsr, work, &lwork, rwork, bwork, &info);

  free(rwork);
  free(bwork);
  rblapack_sdim = INT2NUM(sdim);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_sdim, rblapack_alpha, rblapack_beta, rblapack_vsl, rblapack_vsr, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_cgges(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgges", rblapack_cgges, -1);
}
ruby-lapack-1.7.2/ext/zhpgvx.c0000644000175000017500000003103712502221021016050 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhpgvx_(integer* itype, char* jobz, char* range, char* uplo, integer* n, doublecomplex* ap, doublecomplex* bp, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublecomplex* z, integer* ldz, doublecomplex* work, doublereal* rwork, integer* iwork, integer* ifail, integer* info);


static VALUE
rblapack_zhpgvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_bp;
  doublecomplex *bp; 
  VALUE rblapack_vl;
  doublereal vl; 
  VALUE rblapack_vu;
  doublereal vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  doublereal abstol; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_ifail;
  integer *ifail; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublecomplex *ap_out__;
  VALUE rblapack_bp_out__;
  doublecomplex *bp_out__;
  doublecomplex *work;
  doublereal *rwork;
  integer *iwork;

  integer ldap;
  integer n;
  integer ldz;

  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  m, w, z, ifail, info, ap, bp = NumRu::Lapack.zhpgvx( itype, jobz, range, uplo, ap, bp, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHPGVX computes selected eigenvalues and, optionally, eigenvectors\n*  of a complex generalized Hermitian-definite eigenproblem, of the form\n*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A and\n*  B are assumed to be Hermitian, stored in packed format, and B is also\n*  positive definite.  Eigenvalues and eigenvectors can be selected by\n*  specifying either a range of values or a range of indices for the\n*  desired eigenvalues.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          Specifies the problem type to be solved:\n*          = 1:  A*x = (lambda)*B*x\n*          = 2:  A*B*x = (lambda)*x\n*          = 3:  B*A*x = (lambda)*x\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found;\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found;\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, the contents of AP are destroyed.\n*\n*  BP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          B, packed columnwise in a linear array.  The j-th column of B\n*          is stored in the array BP as follows:\n*          if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n*          if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n*          On exit, the triangular factor U or L from the Cholesky\n*          factorization B = U**H*U or B = L*L**H, in the same storage\n*          format as B.\n*\n*  VL      (input) DOUBLE PRECISION\n*  VU      (input) DOUBLE PRECISION\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) DOUBLE PRECISION\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less than\n*          or equal to zero, then  EPS*|T|  will be used in its place,\n*          where |T| is the 1-norm of the tridiagonal matrix obtained\n*          by reducing AP to tridiagonal form.\n*\n*          Eigenvalues will be computed most accurately when ABSTOL is\n*          set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n*          If this routine returns with INFO>0, indicating that some\n*          eigenvectors did not converge, try setting ABSTOL to\n*          2*DLAMCH('S').\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          On normal exit, the first M elements contain the selected\n*          eigenvalues in ascending order.\n*\n*  Z       (output) COMPLEX*16 array, dimension (LDZ, N)\n*          If JOBZ = 'N', then Z is not referenced.\n*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix A\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          The eigenvectors are normalized as follows:\n*          if ITYPE = 1 or 2, Z**H*B*Z = I;\n*          if ITYPE = 3, Z**H*inv(B)*Z = I.\n*\n*          If an eigenvector fails to converge, then that column of Z\n*          contains the latest approximation to the eigenvector, and the\n*          index of the eigenvector is returned in IFAIL.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (7*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (5*N)\n*\n*  IFAIL   (output) INTEGER array, dimension (N)\n*          If JOBZ = 'V', then if INFO = 0, the first M elements of\n*          IFAIL are zero.  If INFO > 0, then IFAIL contains the\n*          indices of the eigenvectors that failed to converge.\n*          If JOBZ = 'N', then IFAIL is not referenced.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  ZPPTRF or ZHPEVX returned an error code:\n*             <= N:  if INFO = i, ZHPEVX failed to converge;\n*                    i eigenvectors failed to converge.  Their indices\n*                    are stored in array IFAIL.\n*             > N:   if INFO = N + i, for 1 <= i <= n, then the leading\n*                    minor of order i of B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            ALLEIG, INDEIG, UPPER, VALEIG, WANTZ\n      CHARACTER          TRANS\n      INTEGER            J\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZHPEVX, ZHPGST, ZPPTRF, ZTPMV, ZTPSV\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, ifail, info, ap, bp = NumRu::Lapack.zhpgvx( itype, jobz, range, uplo, ap, bp, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 11 && argc != 11)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
  rblapack_itype = argv[0];
  rblapack_jobz = argv[1];
  rblapack_range = argv[2];
  rblapack_uplo = argv[3];
  rblapack_ap = argv[4];
  rblapack_bp = argv[5];
  rblapack_vl = argv[6];
  rblapack_vu = argv[7];
  rblapack_il = argv[8];
  rblapack_iu = argv[9];
  rblapack_abstol = argv[10];
  if (argc == 11) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  itype = NUM2INT(rblapack_itype);
  range = StringValueCStr(rblapack_range)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  vl = NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  abstol = NUM2DBL(rblapack_abstol);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_bp))
    rb_raise(rb_eArgError, "bp (6th argument) must be NArray");
  if (NA_RANK(rblapack_bp) != 1)
    rb_raise(rb_eArgError, "rank of bp (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_bp) != NA_DCOMPLEX)
    rblapack_bp = na_change_type(rblapack_bp, NA_DCOMPLEX);
  bp = NA_PTR_TYPE(rblapack_bp, doublecomplex*);
  iu = NUM2INT(rblapack_iu);
  uplo = StringValueCStr(rblapack_uplo)[0];
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  vu = NUM2DBL(rblapack_vu);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = lsame_(&jobz,"N") ? 0 : ldz;
    shape[1] = lsame_(&jobz,"N") ? 0 : n;
    rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
  MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_bp_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  bp_out__ = NA_PTR_TYPE(rblapack_bp_out__, doublecomplex*);
  MEMCPY(bp_out__, bp, doublecomplex, NA_TOTAL(rblapack_bp));
  rblapack_bp = rblapack_bp_out__;
  bp = bp_out__;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (7*n));
  iwork = ALLOC_N(integer, (5*n));

  zhpgvx_(&itype, &jobz, &range, &uplo, &n, ap, bp, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, rwork, iwork, ifail, &info);

  free(work);
  free(rwork);
  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_ap, rblapack_bp);
}

void
init_lapack_zhpgvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhpgvx", rblapack_zhpgvx, -1);
}
ruby-lapack-1.7.2/ext/ctrsen.c0000644000175000017500000002750212502221020016021 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctrsen_(char* job, char* compq, logical* select, integer* n, complex* t, integer* ldt, complex* q, integer* ldq, complex* w, integer* m, real* s, real* sep, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_ctrsen(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_compq;
  char compq; 
  VALUE rblapack_select;
  logical *select; 
  VALUE rblapack_t;
  complex *t; 
  VALUE rblapack_q;
  complex *q; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_w;
  complex *w; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_s;
  real s; 
  VALUE rblapack_sep;
  real sep; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_t_out__;
  complex *t_out__;
  VALUE rblapack_q_out__;
  complex *q_out__;

  integer n;
  integer ldt;
  integer ldq;

  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  w, m, s, sep, work, info, t, q = NumRu::Lapack.ctrsen( job, compq, select, t, q, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S, SEP, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTRSEN reorders the Schur factorization of a complex matrix\n*  A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in\n*  the leading positions on the diagonal of the upper triangular matrix\n*  T, and the leading columns of Q form an orthonormal basis of the\n*  corresponding right invariant subspace.\n*\n*  Optionally the routine computes the reciprocal condition numbers of\n*  the cluster of eigenvalues and/or the invariant subspace.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies whether condition numbers are required for the\n*          cluster of eigenvalues (S) or the invariant subspace (SEP):\n*          = 'N': none;\n*          = 'E': for eigenvalues only (S);\n*          = 'V': for invariant subspace only (SEP);\n*          = 'B': for both eigenvalues and invariant subspace (S and\n*                 SEP).\n*\n*  COMPQ   (input) CHARACTER*1\n*          = 'V': update the matrix Q of Schur vectors;\n*          = 'N': do not update Q.\n*\n*  SELECT  (input) LOGICAL array, dimension (N)\n*          SELECT specifies the eigenvalues in the selected cluster. To\n*          select the j-th eigenvalue, SELECT(j) must be set to .TRUE..\n*\n*  N       (input) INTEGER\n*          The order of the matrix T. N >= 0.\n*\n*  T       (input/output) COMPLEX array, dimension (LDT,N)\n*          On entry, the upper triangular matrix T.\n*          On exit, T is overwritten by the reordered matrix T, with the\n*          selected eigenvalues as the leading diagonal elements.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= max(1,N).\n*\n*  Q       (input/output) COMPLEX array, dimension (LDQ,N)\n*          On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n*          On exit, if COMPQ = 'V', Q has been postmultiplied by the\n*          unitary transformation matrix which reorders T; the leading M\n*          columns of Q form an orthonormal basis for the specified\n*          invariant subspace.\n*          If COMPQ = 'N', Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.\n*          LDQ >= 1; and if COMPQ = 'V', LDQ >= N.\n*\n*  W       (output) COMPLEX array, dimension (N)\n*          The reordered eigenvalues of T, in the same order as they\n*          appear on the diagonal of T.\n*\n*  M       (output) INTEGER\n*          The dimension of the specified invariant subspace.\n*          0 <= M <= N.\n*\n*  S       (output) REAL\n*          If JOB = 'E' or 'B', S is a lower bound on the reciprocal\n*          condition number for the selected cluster of eigenvalues.\n*          S cannot underestimate the true reciprocal condition number\n*          by more than a factor of sqrt(N). If M = 0 or N, S = 1.\n*          If JOB = 'N' or 'V', S is not referenced.\n*\n*  SEP     (output) REAL\n*          If JOB = 'V' or 'B', SEP is the estimated reciprocal\n*          condition number of the specified invariant subspace. If\n*          M = 0 or N, SEP = norm(T).\n*          If JOB = 'N' or 'E', SEP is not referenced.\n*\n*  WORK    (workspace/output) COMPLEX 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*          If JOB = 'N', LWORK >= 1;\n*          if JOB = 'E', LWORK = max(1,M*(N-M));\n*          if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).\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*  CTRSEN first collects the selected eigenvalues by computing a unitary\n*  transformation Z to move them to the top left corner of T. In other\n*  words, the selected eigenvalues are the eigenvalues of T11 in:\n*\n*                Z'*T*Z = ( T11 T12 ) n1\n*                         (  0  T22 ) n2\n*                            n1  n2\n*\n*  where N = n1+n2 and Z' means the conjugate transpose of Z. The first\n*  n1 columns of Z span the specified invariant subspace of T.\n*\n*  If T has been obtained from the Schur factorization of a matrix\n*  A = Q*T*Q', then the reordered Schur factorization of A is given by\n*  A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span the\n*  corresponding invariant subspace of A.\n*\n*  The reciprocal condition number of the average of the eigenvalues of\n*  T11 may be returned in S. S lies between 0 (very badly conditioned)\n*  and 1 (very well conditioned). It is computed as follows. First we\n*  compute R so that\n*\n*                         P = ( I  R ) n1\n*                             ( 0  0 ) n2\n*                               n1 n2\n*\n*  is the projector on the invariant subspace associated with T11.\n*  R is the solution of the Sylvester equation:\n*\n*                        T11*R - R*T22 = T12.\n*\n*  Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote\n*  the two-norm of M. Then S is computed as the lower bound\n*\n*                      (1 + F-norm(R)**2)**(-1/2)\n*\n*  on the reciprocal of 2-norm(P), the true reciprocal condition number.\n*  S cannot underestimate 1 / 2-norm(P) by more than a factor of\n*  sqrt(N).\n*\n*  An approximate error bound for the computed average of the\n*  eigenvalues of T11 is\n*\n*                         EPS * norm(T) / S\n*\n*  where EPS is the machine precision.\n*\n*  The reciprocal condition number of the right invariant subspace\n*  spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.\n*  SEP is defined as the separation of T11 and T22:\n*\n*                     sep( T11, T22 ) = sigma-min( C )\n*\n*  where sigma-min(C) is the smallest singular value of the\n*  n1*n2-by-n1*n2 matrix\n*\n*     C  = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )\n*\n*  I(m) is an m by m identity matrix, and kprod denotes the Kronecker\n*  product. We estimate sigma-min(C) by the reciprocal of an estimate of\n*  the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)\n*  cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).\n*\n*  When SEP is small, small changes in T can cause large changes in\n*  the invariant subspace. An approximate bound on the maximum angular\n*  error in the computed right invariant subspace is\n*\n*                      EPS * norm(T) / SEP\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, m, s, sep, work, info, t, q = NumRu::Lapack.ctrsen( job, compq, select, t, q, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_job = argv[0];
  rblapack_compq = argv[1];
  rblapack_select = argv[2];
  rblapack_t = argv[3];
  rblapack_q = argv[4];
  if (argc == 6) {
    rblapack_lwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  job = StringValueCStr(rblapack_job)[0];
  if (!NA_IsNArray(rblapack_select))
    rb_raise(rb_eArgError, "select (3th argument) must be NArray");
  if (NA_RANK(rblapack_select) != 1)
    rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_select);
  if (NA_TYPE(rblapack_select) != NA_LINT)
    rblapack_select = na_change_type(rblapack_select, NA_LINT);
  select = NA_PTR_TYPE(rblapack_select, logical*);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (5th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_q) != NA_SCOMPLEX)
    rblapack_q = na_change_type(rblapack_q, NA_SCOMPLEX);
  q = NA_PTR_TYPE(rblapack_q, complex*);
  compq = StringValueCStr(rblapack_compq)[0];
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (4th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  if (NA_SHAPE1(rblapack_t) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_t) != NA_SCOMPLEX)
    rblapack_t = na_change_type(rblapack_t, NA_SCOMPLEX);
  t = NA_PTR_TYPE(rblapack_t, complex*);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&job,"N") ? n : lsame_(&job,"E") ? m*(n-m) : (lsame_(&job,"V")||lsame_(&job,"B")) ? 2*m*(n-m) : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = n;
    rblapack_t_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  t_out__ = NA_PTR_TYPE(rblapack_t_out__, complex*);
  MEMCPY(t_out__, t, complex, NA_TOTAL(rblapack_t));
  rblapack_t = rblapack_t_out__;
  t = t_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, complex*);
  MEMCPY(q_out__, q, complex, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;

  ctrsen_(&job, &compq, select, &n, t, &ldt, q, &ldq, w, &m, &s, &sep, work, &lwork, &info);

  rblapack_m = INT2NUM(m);
  rblapack_s = rb_float_new((double)s);
  rblapack_sep = rb_float_new((double)sep);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_w, rblapack_m, rblapack_s, rblapack_sep, rblapack_work, rblapack_info, rblapack_t, rblapack_q);
}

void
init_lapack_ctrsen(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctrsen", rblapack_ctrsen, -1);
}
ruby-lapack-1.7.2/ext/dposvx.c0000644000175000017500000003647412502221015016062 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dposvx_(char* fact, char* uplo, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* af, integer* ldaf, char* equed, doublereal* s, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dposvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_af;
  doublereal *af; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  VALUE rblapack_af_out__;
  doublereal *af_out__;
  VALUE rblapack_s_out__;
  doublereal *s_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;
  doublereal *work;
  integer *iwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, info, a, af, equed, s, b = NumRu::Lapack.dposvx( fact, uplo, a, af, equed, s, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPOSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to\n*  compute the solution to a real system of linear equations\n*     A * X = B,\n*  where A is an N-by-N symmetric positive definite matrix and X and B\n*  are N-by-NRHS matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'E', real scaling factors are computed to equilibrate\n*     the system:\n*        diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n*  2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n*     factor the matrix A (after equilibration if FACT = 'E') as\n*        A = U**T* U,  if UPLO = 'U', or\n*        A = L * L**T,  if UPLO = 'L',\n*     where U is an upper triangular matrix and L is a lower triangular\n*     matrix.\n*\n*  3. If the leading i-by-i principal minor is not positive definite,\n*     then the routine returns with INFO = i. Otherwise, the factored\n*     form of A is used to estimate the condition number of the matrix\n*     A.  If the reciprocal of the condition number is less than machine\n*     precision, INFO = N+1 is returned as a warning, but the routine\n*     still goes on to solve for X and compute error bounds as\n*     described below.\n*\n*  4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  5. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n*  6. If equilibration was used, the matrix X is premultiplied by\n*     diag(S) so that it solves the original system before\n*     equilibration.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of the matrix A is\n*          supplied on entry, and if not, whether the matrix A should be\n*          equilibrated before it is factored.\n*          = 'F':  On entry, AF contains the factored form of A.\n*                  If EQUED = 'Y', the matrix A has been equilibrated\n*                  with scaling factors given by S.  A and AF will not\n*                  be modified.\n*          = 'N':  The matrix A will be copied to AF and factored.\n*          = 'E':  The matrix A will be equilibrated if necessary, then\n*                  copied to AF and factored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the symmetric matrix A, except if FACT = 'F' and\n*          EQUED = 'Y', then A must contain the equilibrated matrix\n*          diag(S)*A*diag(S).  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.  A is not modified if\n*          FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n*          On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n*          diag(S)*A*diag(S).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AF      (input or output) DOUBLE PRECISION array, dimension (LDAF,N)\n*          If FACT = 'F', then AF is an input argument and on entry\n*          contains the triangular factor U or L from the Cholesky\n*          factorization A = U**T*U or A = L*L**T, in the same storage\n*          format as A.  If EQUED .ne. 'N', then AF is the factored form\n*          of the equilibrated matrix diag(S)*A*diag(S).\n*\n*          If FACT = 'N', then AF is an output argument and on exit\n*          returns the triangular factor U or L from the Cholesky\n*          factorization A = U**T*U or A = L*L**T of the original\n*          matrix A.\n*\n*          If FACT = 'E', then AF is an output argument and on exit\n*          returns the triangular factor U or L from the Cholesky\n*          factorization A = U**T*U or A = L*L**T of the equilibrated\n*          matrix A (see the description of A for the form of the\n*          equilibrated matrix).\n*\n*  LDAF    (input) INTEGER\n*          The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*  EQUED   (input or output) CHARACTER*1\n*          Specifies the form of equilibration that was done.\n*          = 'N':  No equilibration (always true if FACT = 'N').\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*          EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*          output argument.\n*\n*  S       (input or output) DOUBLE PRECISION array, dimension (N)\n*          The scale factors for A; not accessed if EQUED = 'N'.  S is\n*          an input argument if FACT = 'F'; otherwise, S is an output\n*          argument.  If FACT = 'F' and EQUED = 'Y', each element of S\n*          must be positive.\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n*          B is overwritten by diag(S) * B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n*          the original system of equations.  Note that if EQUED = 'Y',\n*          A and B are modified on exit, and the solution to the\n*          equilibrated system is inv(diag(S))*X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The estimate of the reciprocal condition number of the matrix\n*          A after equilibration (if done).  If RCOND is less than the\n*          machine precision (in particular, if RCOND = 0), the matrix\n*          is singular to working precision.  This condition is\n*          indicated by a return code of INFO > 0.\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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, and i is\n*                <= N:  the leading minor of order i of A is\n*                       not positive definite, so the factorization\n*                       could not be completed, and the solution has not\n*                       been computed. RCOND = 0 is returned.\n*                = N+1: U is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, info, a, af, equed, s, b = NumRu::Lapack.dposvx( fact, uplo, a, af, equed, s, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_equed = argv[4];
  rblapack_s = argv[5];
  rblapack_b = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (6th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
  af = NA_PTR_TYPE(rblapack_af, doublereal*);
  ldx = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[2];
    shape[0] = ldaf;
    shape[1] = n;
    rblapack_af_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  af_out__ = NA_PTR_TYPE(rblapack_af_out__, doublereal*);
  MEMCPY(af_out__, af, doublereal, NA_TOTAL(rblapack_af));
  rblapack_af = rblapack_af_out__;
  af = af_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
  MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(doublereal, (3*n));
  iwork = ALLOC_N(integer, (n));

  dposvx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_a, rblapack_af, rblapack_equed, rblapack_s, rblapack_b);
}

void
init_lapack_dposvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dposvx", rblapack_dposvx, -1);
}
ruby-lapack-1.7.2/ext/zgglse.c0000644000175000017500000002256612502221023016026 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgglse_(integer* m, integer* n, integer* p, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublecomplex* c, doublecomplex* d, doublecomplex* x, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zgglse(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_c;
  doublecomplex *c; 
  VALUE rblapack_d;
  doublecomplex *d; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  VALUE rblapack_c_out__;
  doublecomplex *c_out__;
  VALUE rblapack_d_out__;
  doublecomplex *d_out__;

  integer lda;
  integer n;
  integer ldb;
  integer m;
  integer p;

  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  x, work, info, a, b, c, d = NumRu::Lapack.zgglse( a, b, c, d, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGGLSE solves the linear equality-constrained least squares (LSE)\n*  problem:\n*\n*          minimize || c - A*x ||_2   subject to   B*x = d\n*\n*  where A is an M-by-N matrix, B is a P-by-N matrix, c is a given\n*  M-vector, and d is a given P-vector. It is assumed that\n*  P <= N <= M+P, and\n*\n*           rank(B) = P and  rank( ( A ) ) = N.\n*                                ( ( B ) )\n*\n*  These conditions ensure that the LSE problem has a unique solution,\n*  which is obtained using a generalized RQ factorization of the\n*  matrices (B, A) given by\n*\n*     B = (0 R)*Q,   A = Z*T*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 matrices A and B. N >= 0.\n*\n*  P       (input) INTEGER\n*          The number of rows of the matrix B. 0 <= P <= N <= M+P.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, the elements on and above the diagonal of the array\n*          contain the min(M,N)-by-N upper trapezoidal matrix T.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,N)\n*          On entry, the P-by-N matrix B.\n*          On exit, the upper triangle of the subarray B(1:P,N-P+1:N)\n*          contains the P-by-P upper triangular matrix R.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,P).\n*\n*  C       (input/output) COMPLEX*16 array, dimension (M)\n*          On entry, C contains the right hand side vector for the\n*          least squares part of the LSE problem.\n*          On exit, the residual sum of squares for the solution\n*          is given by the sum of squares of elements N-P+1 to M of\n*          vector C.\n*\n*  D       (input/output) COMPLEX*16 array, dimension (P)\n*          On entry, D contains the right hand side vector for the\n*          constrained equation.\n*          On exit, D is destroyed.\n*\n*  X       (output) COMPLEX*16 array, dimension (N)\n*          On exit, X is the solution of the LSE problem.\n*\n*  WORK    (workspace/output) COMPLEX*16 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+P).\n*          For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,\n*          where NB is an upper bound for the optimal blocksizes for\n*          ZGEQRF, CGERQF, ZUNMQR and CUNMRQ.\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*          = 1:  the upper triangular factor R associated with B in the\n*                generalized RQ factorization of the pair (B, A) is\n*                singular, so that rank(B) < P; the least squares\n*                solution could not be computed.\n*          = 2:  the (N-P) by (N-P) part of the upper trapezoidal factor\n*                T associated with A in the generalized RQ factorization\n*                of the pair (B, A) is singular, so that\n*                rank( (A) ) < N; the least squares solution could not\n*                    ( (B) )\n*                be computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, work, info, a, b, c, d = NumRu::Lapack.zgglse( a, b, c, d, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  rblapack_c = argv[2];
  rblapack_d = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } 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 (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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (3th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (3th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  p = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DCOMPLEX)
    rblapack_d = na_change_type(rblapack_d, NA_DCOMPLEX);
  d = NA_PTR_TYPE(rblapack_d, doublecomplex*);
  if (rblapack_lwork == Qnil)
    lwork = m+n+p;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_x = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
  MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[1];
    shape[0] = p;
    rblapack_d_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublecomplex*);
  MEMCPY(d_out__, d, doublecomplex, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;

  zgglse_(&m, &n, &p, a, &lda, b, &ldb, c, d, x, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_x, rblapack_work, rblapack_info, rblapack_a, rblapack_b, rblapack_c, rblapack_d);
}

void
init_lapack_zgglse(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgglse", rblapack_zgglse, -1);
}
ruby-lapack-1.7.2/ext/claed0.c0000644000175000017500000001546612502221013015663 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID claed0_(integer* qsiz, integer* n, real* d, real* e, complex* q, integer* ldq, complex* qstore, integer* ldqs, real* rwork, integer* iwork, integer* info);


static VALUE
rblapack_claed0(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_qsiz;
  integer qsiz; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_q;
  complex *q; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_e_out__;
  real *e_out__;
  VALUE rblapack_q_out__;
  complex *q_out__;
  complex *qstore;
  real *rwork;
  integer *iwork;

  integer n;
  integer ldq;
  integer ldqs;

  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  info, d, e, q = NumRu::Lapack.claed0( qsiz, d, e, q, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  Using the divide and conquer method, CLAED0 computes all eigenvalues\n*  of a symmetric tridiagonal matrix which is one diagonal block of\n*  those from reducing a dense or band Hermitian matrix and\n*  corresponding eigenvectors of the dense or band matrix.\n*\n\n*  Arguments\n*  =========\n*\n*  QSIZ   (input) INTEGER\n*         The dimension of the unitary matrix used to reduce\n*         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.\n*\n*  N      (input) INTEGER\n*         The dimension of the symmetric tridiagonal matrix.  N >= 0.\n*\n*  D      (input/output) REAL array, dimension (N)\n*         On entry, the diagonal elements of the tridiagonal matrix.\n*         On exit, the eigenvalues in ascending order.\n*\n*  E      (input/output) REAL array, dimension (N-1)\n*         On entry, the off-diagonal elements of the tridiagonal matrix.\n*         On exit, E has been destroyed.\n*\n*  Q      (input/output) COMPLEX array, dimension (LDQ,N)\n*         On entry, Q must contain an QSIZ x N matrix whose columns\n*         unitarily orthonormal. It is a part of the unitary matrix\n*         that reduces the full dense Hermitian matrix to a\n*         (reducible) symmetric tridiagonal matrix.\n*\n*  LDQ    (input) INTEGER\n*         The leading dimension of the array Q.  LDQ >= max(1,N).\n*\n*  IWORK  (workspace) INTEGER array,\n*         the dimension of IWORK must be at least\n*                      6 + 6*N + 5*N*lg N\n*                      ( lg( N ) = smallest integer k\n*                                  such that 2^k >= N )\n*\n*  RWORK  (workspace) REAL array,\n*                               dimension (1 + 3*N + 2*N*lg N + 3*N**2)\n*                        ( lg( N ) = smallest integer k\n*                                    such that 2^k >= N )\n*\n*  QSTORE (workspace) COMPLEX array, dimension (LDQS, N)\n*         Used to store parts of\n*         the eigenvector matrix when the updating matrix multiplies\n*         take place.\n*\n*  LDQS   (input) INTEGER\n*         The leading dimension of the array QSTORE.\n*         LDQS >= max(1,N).\n*\n*  INFO   (output) INTEGER\n*          = 0:  successful exit.\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          > 0:  The algorithm failed to compute an eigenvalue while\n*                working on the submatrix lying in rows and columns\n*                INFO/(N+1) through mod(INFO,N+1).\n*\n\n*  =====================================================================\n*\n*  Warning:      N could be as big as QSIZ!\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, e, q = NumRu::Lapack.claed0( qsiz, d, e, q, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_qsiz = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  rblapack_q = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  qsiz = NUM2INT(rblapack_qsiz);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (4th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (4th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  n = NA_SHAPE1(rblapack_q);
  if (NA_TYPE(rblapack_q) != NA_SCOMPLEX)
    rblapack_q = na_change_type(rblapack_q, NA_SCOMPLEX);
  q = NA_PTR_TYPE(rblapack_q, complex*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of q");
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  ldqs = MAX(1,n);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
  MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, complex*);
  MEMCPY(q_out__, q, complex, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  qstore = ALLOC_N(complex, (ldqs)*(n));
  rwork = ALLOC_N(real, (1 + 3*n + 2*n*LG(n) + 3*pow(n,2)));
  iwork = ALLOC_N(integer, (6 + 6*n + 5*n*LG(n)));

  claed0_(&qsiz, &n, d, e, q, &ldq, qstore, &ldqs, rwork, iwork, &info);

  free(qstore);
  free(rwork);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_e, rblapack_q);
}

void
init_lapack_claed0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "claed0", rblapack_claed0, -1);
}
ruby-lapack-1.7.2/ext/sla_geamv.c0000644000175000017500000001703512502221017016467 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sla_geamv_(char* trans, integer* m, integer* n, real* alpha, real* a, integer* lda, real* x, integer* incx, real* beta, real* y, integer* incy);


static VALUE
rblapack_sla_geamv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_alpha;
  real alpha; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_beta;
  real beta; 
  VALUE rblapack_y;
  real *y; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_y_out__;
  real *y_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  y = NumRu::Lapack.sla_geamv( trans, m, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n*  Purpose\n*  =======\n*\n*  SLA_GEAMV  performs one of the matrix-vector operations\n*\n*          y := alpha*abs(A)*abs(x) + beta*abs(y),\n*     or   y := alpha*abs(A)'*abs(x) + beta*abs(y),\n*\n*  where alpha and beta are scalars, x and y are vectors and A is an\n*  m by n matrix.\n*\n*  This function is primarily used in calculating error bounds.\n*  To protect against underflow during evaluation, components in\n*  the resulting vector are perturbed away from zero by (N+1)\n*  times the underflow threshold.  To prevent unnecessarily large\n*  errors for block-structure embedded in general matrices,\n*  \"symbolically\" zero components are not perturbed.  A zero\n*  entry is considered \"symbolic\" if all multiplications involved\n*  in computing that entry have at least one zero multiplicand.\n*\n\n*  Arguments\n*  ==========\n*\n*  TRANS   (input) INTEGER\n*           On entry, TRANS specifies the operation to be performed as\n*           follows:\n*\n*             BLAS_NO_TRANS      y := alpha*abs(A)*abs(x) + beta*abs(y)\n*             BLAS_TRANS         y := alpha*abs(A')*abs(x) + beta*abs(y)\n*             BLAS_CONJ_TRANS    y := alpha*abs(A')*abs(x) + beta*abs(y)\n*\n*           Unchanged on exit.\n*\n*  M       (input) INTEGER\n*           On entry, M specifies the number of rows of the matrix A.\n*           M must be at least zero.\n*           Unchanged on exit.\n*\n*  N       (input) INTEGER\n*           On entry, N specifies the number of columns of the matrix A.\n*           N must be at least zero.\n*           Unchanged on exit.\n*\n*  ALPHA   (input) REAL\n*           On entry, ALPHA specifies the scalar alpha.\n*           Unchanged on exit.\n*\n*  A      - REAL             array of DIMENSION ( LDA, n )\n*           Before entry, the leading m by n part of the array A must\n*           contain the matrix of coefficients.\n*           Unchanged on exit.\n*\n*  LDA     (input) INTEGER\n*           On entry, LDA specifies the first dimension of A as declared\n*           in the calling (sub) program. LDA must be at least\n*           max( 1, m ).\n*           Unchanged on exit.\n*\n*  X       (input) REAL array, dimension\n*           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n*           and at least\n*           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n*           Before entry, the incremented array X must contain the\n*           vector x.\n*           Unchanged on exit.\n*\n*  INCX    (input) INTEGER\n*           On entry, INCX specifies the increment for the elements of\n*           X. INCX must not be zero.\n*           Unchanged on exit.\n*\n*  BETA    (input) REAL\n*           On entry, BETA specifies the scalar beta. When BETA is\n*           supplied as zero then Y need not be set on input.\n*           Unchanged on exit.\n*\n*  Y      - REAL\n*           Array of DIMENSION at least\n*           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n*           and at least\n*           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n*           Before entry with BETA non-zero, the incremented array Y\n*           must contain the vector y. On exit, Y is overwritten by the\n*           updated vector y.\n*\n*  INCY    (input) INTEGER\n*           On entry, INCY specifies the increment for the elements of\n*           Y. INCY must not be zero.\n*           Unchanged on exit.\n*\n*  Level 2 Blas routine.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  y = NumRu::Lapack.sla_geamv( trans, m, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_trans = argv[0];
  rblapack_m = argv[1];
  rblapack_alpha = argv[2];
  rblapack_a = argv[3];
  rblapack_x = argv[4];
  rblapack_incx = argv[5];
  rblapack_beta = argv[6];
  rblapack_y = argv[7];
  rblapack_incy = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  alpha = (real)NUM2DBL(rblapack_alpha);
  incx = NUM2INT(rblapack_incx);
  incy = NUM2INT(rblapack_incy);
  m = NUM2INT(rblapack_m);
  beta = (real)NUM2DBL(rblapack_beta);
  lda = MAX(1, m);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_a) != lda)
    rb_raise(rb_eRuntimeError, "shape 0 of a must be MAX(1, m)");
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (8th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (trans == ilatrans_("N") ? 1+(m-1)*abs(incy) : 1+(n-1)*abs(incy)))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", trans == ilatrans_("N") ? 1+(m-1)*abs(incy) : 1+(n-1)*abs(incy));
  if (NA_TYPE(rblapack_y) != NA_SFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
  y = NA_PTR_TYPE(rblapack_y, real*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (5th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (trans == ilatrans_("N") ? 1+(n-1)*abs(incx) : 1+(m-1)*abs(incx)))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", trans == ilatrans_("N") ? 1+(n-1)*abs(incx) : 1+(m-1)*abs(incx));
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[1];
    shape[0] = trans == ilatrans_("N") ? 1+(m-1)*abs(incy) : 1+(n-1)*abs(incy);
    rblapack_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
  MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  sla_geamv_(&trans, &m, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);

  return rblapack_y;
}

void
init_lapack_sla_geamv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sla_geamv", rblapack_sla_geamv, -1);
}
ruby-lapack-1.7.2/ext/cptsvx.c0000644000175000017500000002640112502221017016055 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cptsvx_(char* fact, integer* n, integer* nrhs, real* d, complex* e, real* df, complex* ef, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* ferr, real* berr, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cptsvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  complex *e; 
  VALUE rblapack_df;
  real *df; 
  VALUE rblapack_ef;
  complex *ef; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_df_out__;
  real *df_out__;
  VALUE rblapack_ef_out__;
  complex *ef_out__;
  complex *work;
  real *rwork;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, info, df, ef = NumRu::Lapack.cptsvx( fact, d, e, df, ef, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPTSVX uses the factorization A = L*D*L**H to compute the solution\n*  to a complex system of linear equations A*X = B, where A is an\n*  N-by-N Hermitian positive definite tridiagonal matrix and X and B\n*  are N-by-NRHS matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'N', the matrix A is factored as A = L*D*L**H, where L\n*     is a unit lower bidiagonal matrix and D is diagonal.  The\n*     factorization can also be regarded as having the form\n*     A = U**H*D*U.\n*\n*  2. If the leading i-by-i principal minor is not positive definite,\n*     then the routine returns with INFO = i. Otherwise, the factored\n*     form of A is used to estimate the condition number of the matrix\n*     A.  If the reciprocal of the condition number is less than machine\n*     precision, INFO = N+1 is returned as a warning, but the routine\n*     still goes on to solve for X and compute error bounds as\n*     described below.\n*\n*  3. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  4. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of the matrix\n*          A is supplied on entry.\n*          = 'F':  On entry, DF and EF contain the factored form of A.\n*                  D, E, DF, and EF will not be modified.\n*          = 'N':  The matrix A will be copied to DF and EF and\n*                  factored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  D       (input) REAL array, dimension (N)\n*          The n diagonal elements of the tridiagonal matrix A.\n*\n*  E       (input) COMPLEX array, dimension (N-1)\n*          The (n-1) subdiagonal elements of the tridiagonal matrix A.\n*\n*  DF      (input or output) REAL array, dimension (N)\n*          If FACT = 'F', then DF is an input argument and on entry\n*          contains the n diagonal elements of the diagonal matrix D\n*          from the L*D*L**H factorization of A.\n*          If FACT = 'N', then DF is an output argument and on exit\n*          contains the n diagonal elements of the diagonal matrix D\n*          from the L*D*L**H factorization of A.\n*\n*  EF      (input or output) COMPLEX array, dimension (N-1)\n*          If FACT = 'F', then EF is an input argument and on entry\n*          contains the (n-1) subdiagonal elements of the unit\n*          bidiagonal factor L from the L*D*L**H factorization of A.\n*          If FACT = 'N', then EF is an output argument and on exit\n*          contains the (n-1) subdiagonal elements of the unit\n*          bidiagonal factor L from the L*D*L**H factorization of A.\n*\n*  B       (input) COMPLEX array, dimension (LDB,NRHS)\n*          The N-by-NRHS right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) COMPLEX array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) REAL\n*          The reciprocal condition number of the matrix A.  If RCOND\n*          is less than the machine precision (in particular, if\n*          RCOND = 0), the matrix is singular to working precision.\n*          This condition is indicated by a return code of INFO > 0.\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in any\n*          element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX array, dimension (N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\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, and i is\n*                <= N:  the leading minor of order i of A is\n*                       not positive definite, so the factorization\n*                       could not be completed, and the solution has not\n*                       been computed. RCOND = 0 is returned.\n*                = N+1: U is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, info, df, ef = NumRu::Lapack.cptsvx( fact, d, e, df, ef, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_fact = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  rblapack_df = argv[3];
  rblapack_ef = argv[4];
  rblapack_b = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_df))
    rb_raise(rb_eArgError, "df (4th argument) must be NArray");
  if (NA_RANK(rblapack_df) != 1)
    rb_raise(rb_eArgError, "rank of df (4th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_df);
  if (NA_TYPE(rblapack_df) != NA_SFLOAT)
    rblapack_df = na_change_type(rblapack_df, NA_SFLOAT);
  df = NA_PTR_TYPE(rblapack_df, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of df");
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_ef))
    rb_raise(rb_eArgError, "ef (5th argument) must be NArray");
  if (NA_RANK(rblapack_ef) != 1)
    rb_raise(rb_eArgError, "rank of ef (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ef) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of ef must be %d", n-1);
  if (NA_TYPE(rblapack_ef) != NA_SCOMPLEX)
    rblapack_ef = na_change_type(rblapack_ef, NA_SCOMPLEX);
  ef = NA_PTR_TYPE(rblapack_ef, complex*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SCOMPLEX)
    rblapack_e = na_change_type(rblapack_e, NA_SCOMPLEX);
  e = NA_PTR_TYPE(rblapack_e, complex*);
  ldx = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_df_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  df_out__ = NA_PTR_TYPE(rblapack_df_out__, real*);
  MEMCPY(df_out__, df, real, NA_TOTAL(rblapack_df));
  rblapack_df = rblapack_df_out__;
  df = df_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_ef_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  ef_out__ = NA_PTR_TYPE(rblapack_ef_out__, complex*);
  MEMCPY(ef_out__, ef, complex, NA_TOTAL(rblapack_ef));
  rblapack_ef = rblapack_ef_out__;
  ef = ef_out__;
  work = ALLOC_N(complex, (n));
  rwork = ALLOC_N(real, (n));

  cptsvx_(&fact, &n, &nrhs, d, e, df, ef, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_df, rblapack_ef);
}

void
init_lapack_cptsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cptsvx", rblapack_cptsvx, -1);
}
ruby-lapack-1.7.2/ext/stfttp.c0000644000175000017500000001527312502221017016057 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID stfttp_(char* transr, char* uplo, integer* n, real* arf, real* ap, integer* info);


static VALUE
rblapack_stfttp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_arf;
  real *arf; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_info;
  integer info; 


  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  ap, info = NumRu::Lapack.stfttp( transr, uplo, n, arf, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STFTTP( TRANSR, UPLO, N, ARF, AP, INFO )\n\n*  Purpose\n*  =======\n*\n*  STFTTP copies a triangular matrix A from rectangular full packed\n*  format (TF) to standard packed format (TP).\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR   (input) CHARACTER*1\n*          = 'N':  ARF is in Normal format;\n*          = 'T':  ARF is in Transpose format;\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0.\n*\n*  ARF     (input) REAL array, dimension ( N*(N+1)/2 ),\n*          On entry, the upper or lower triangular matrix A stored in\n*          RFP format. For a further discussion see Notes below.\n*\n*  AP      (output) REAL array, dimension ( N*(N+1)/2 ),\n*          On exit, the upper or lower triangular matrix A, packed\n*          columnwise in a linear array. The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\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*  We first consider Rectangular Full Packed (RFP) Format when N is\n*  even. We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  the transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  the transpose of the last three columns of AP lower.\n*  This covers the case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        03 04 05                33 43 53\n*        13 14 15                00 44 54\n*        23 24 25                10 11 55\n*        33 34 35                20 21 22\n*        00 44 45                30 31 32\n*        01 11 55                40 41 42\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We then consider Rectangular Full Packed (RFP) Format when N is\n*  odd. We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  the transpose of the first two columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  the transpose of the last two columns of AP lower.\n*  This covers the case N odd and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        02 03 04                00 33 43\n*        12 13 14                10 11 44\n*        22 23 24                20 21 22\n*        00 33 34                30 31 32\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*           RFP A                   RFP A\n*\n*     02 12 22 00 01             00 10 20 30 40 50\n*     03 13 23 33 11             33 11 21 31 41 51\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ap, info = NumRu::Lapack.stfttp( transr, uplo, n, arf, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_n = argv[2];
  rblapack_arf = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  n = NUM2INT(rblapack_n);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_arf))
    rb_raise(rb_eArgError, "arf (4th argument) must be NArray");
  if (NA_RANK(rblapack_arf) != 1)
    rb_raise(rb_eArgError, "rank of arf (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_arf) != (( n*(n+1)/2 )))
    rb_raise(rb_eRuntimeError, "shape 0 of arf must be %d", ( n*(n+1)/2 ));
  if (NA_TYPE(rblapack_arf) != NA_SFLOAT)
    rblapack_arf = na_change_type(rblapack_arf, NA_SFLOAT);
  arf = NA_PTR_TYPE(rblapack_arf, real*);
  {
    na_shape_t shape[1];
    shape[0] = ( n*(n+1)/2 );
    rblapack_ap = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ap = NA_PTR_TYPE(rblapack_ap, real*);

  stfttp_(&transr, &uplo, &n, arf, ap, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_ap, rblapack_info);
}

void
init_lapack_stfttp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "stfttp", rblapack_stfttp, -1);
}
ruby-lapack-1.7.2/ext/dlaeda.c0000644000175000017500000002222312502221024015734 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaeda_(integer* n, integer* tlvls, integer* curlvl, integer* curpbm, integer* prmptr, integer* perm, integer* givptr, integer* givcol, doublereal* givnum, doublereal* q, integer* qptr, doublereal* z, doublereal* ztemp, integer* info);


static VALUE
rblapack_dlaeda(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_tlvls;
  integer tlvls; 
  VALUE rblapack_curlvl;
  integer curlvl; 
  VALUE rblapack_curpbm;
  integer curpbm; 
  VALUE rblapack_prmptr;
  integer *prmptr; 
  VALUE rblapack_perm;
  integer *perm; 
  VALUE rblapack_givptr;
  integer *givptr; 
  VALUE rblapack_givcol;
  integer *givcol; 
  VALUE rblapack_givnum;
  doublereal *givnum; 
  VALUE rblapack_q;
  doublereal *q; 
  VALUE rblapack_qptr;
  integer *qptr; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_info;
  integer info; 
  doublereal *ztemp;

  integer ldqptr;
  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  z, info = NumRu::Lapack.dlaeda( tlvls, curlvl, curpbm, prmptr, perm, givptr, givcol, givnum, q, qptr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLAEDA computes the Z vector corresponding to the merge step in the\n*  CURLVLth step of the merge process with TLVLS steps for the CURPBMth\n*  problem.\n*\n\n*  Arguments\n*  =========\n*\n*  N      (input) INTEGER\n*         The dimension of the symmetric tridiagonal matrix.  N >= 0.\n*\n*  TLVLS  (input) INTEGER\n*         The total number of merging levels in the overall divide and\n*         conquer tree.\n*\n*  CURLVL (input) INTEGER\n*         The current level in the overall merge routine,\n*         0 <= curlvl <= tlvls.\n*\n*  CURPBM (input) INTEGER\n*         The current problem in the current level in the overall\n*         merge routine (counting from upper left to lower right).\n*\n*  PRMPTR (input) INTEGER array, dimension (N lg N)\n*         Contains a list of pointers which indicate where in PERM a\n*         level's permutation is stored.  PRMPTR(i+1) - PRMPTR(i)\n*         indicates the size of the permutation and incidentally the\n*         size of the full, non-deflated problem.\n*\n*  PERM   (input) INTEGER array, dimension (N lg N)\n*         Contains the permutations (from deflation and sorting) to be\n*         applied to each eigenblock.\n*\n*  GIVPTR (input) INTEGER array, dimension (N lg N)\n*         Contains a list of pointers which indicate where in GIVCOL a\n*         level's Givens rotations are stored.  GIVPTR(i+1) - GIVPTR(i)\n*         indicates the number of Givens rotations.\n*\n*  GIVCOL (input) INTEGER array, dimension (2, N lg N)\n*         Each pair of numbers indicates a pair of columns to take place\n*         in a Givens rotation.\n*\n*  GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N)\n*         Each number indicates the S value to be used in the\n*         corresponding Givens rotation.\n*\n*  Q      (input) DOUBLE PRECISION array, dimension (N**2)\n*         Contains the square eigenblocks from previous levels, the\n*         starting positions for blocks are given by QPTR.\n*\n*  QPTR   (input) INTEGER array, dimension (N+2)\n*         Contains a list of pointers which indicate where in Q an\n*         eigenblock is stored.  SQRT( QPTR(i+1) - QPTR(i) ) indicates\n*         the size of the block.\n*\n*  Z      (output) DOUBLE PRECISION array, dimension (N)\n*         On output this vector contains the updating vector (the last\n*         row of the first sub-eigenvector matrix and the first row of\n*         the second sub-eigenvector matrix).\n*\n*  ZTEMP  (workspace) DOUBLE PRECISION array, dimension (N)\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*  Based on contributions by\n*     Jeff Rutter, Computer Science Division, University of California\n*     at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  z, info = NumRu::Lapack.dlaeda( tlvls, curlvl, curpbm, prmptr, perm, givptr, givcol, givnum, q, qptr, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_tlvls = argv[0];
  rblapack_curlvl = argv[1];
  rblapack_curpbm = argv[2];
  rblapack_prmptr = argv[3];
  rblapack_perm = argv[4];
  rblapack_givptr = argv[5];
  rblapack_givcol = argv[6];
  rblapack_givnum = argv[7];
  rblapack_q = argv[8];
  rblapack_qptr = argv[9];
  if (argc == 10) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  tlvls = NUM2INT(rblapack_tlvls);
  curpbm = NUM2INT(rblapack_curpbm);
  if (!NA_IsNArray(rblapack_qptr))
    rb_raise(rb_eArgError, "qptr (10th argument) must be NArray");
  if (NA_RANK(rblapack_qptr) != 1)
    rb_raise(rb_eArgError, "rank of qptr (10th argument) must be %d", 1);
  ldqptr = NA_SHAPE0(rblapack_qptr);
  if (NA_TYPE(rblapack_qptr) != NA_LINT)
    rblapack_qptr = na_change_type(rblapack_qptr, NA_LINT);
  qptr = NA_PTR_TYPE(rblapack_qptr, integer*);
  curlvl = NUM2INT(rblapack_curlvl);
  n = ldqptr-2;
  if (!NA_IsNArray(rblapack_prmptr))
    rb_raise(rb_eArgError, "prmptr (4th argument) must be NArray");
  if (NA_RANK(rblapack_prmptr) != 1)
    rb_raise(rb_eArgError, "rank of prmptr (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_prmptr) != (n*LG(n)))
    rb_raise(rb_eRuntimeError, "shape 0 of prmptr must be %d", n*LG(n));
  if (NA_TYPE(rblapack_prmptr) != NA_LINT)
    rblapack_prmptr = na_change_type(rblapack_prmptr, NA_LINT);
  prmptr = NA_PTR_TYPE(rblapack_prmptr, integer*);
  if (!NA_IsNArray(rblapack_givptr))
    rb_raise(rb_eArgError, "givptr (6th argument) must be NArray");
  if (NA_RANK(rblapack_givptr) != 1)
    rb_raise(rb_eArgError, "rank of givptr (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_givptr) != (n*LG(n)))
    rb_raise(rb_eRuntimeError, "shape 0 of givptr must be %d", n*LG(n));
  if (NA_TYPE(rblapack_givptr) != NA_LINT)
    rblapack_givptr = na_change_type(rblapack_givptr, NA_LINT);
  givptr = NA_PTR_TYPE(rblapack_givptr, integer*);
  if (!NA_IsNArray(rblapack_givnum))
    rb_raise(rb_eArgError, "givnum (8th argument) must be NArray");
  if (NA_RANK(rblapack_givnum) != 2)
    rb_raise(rb_eArgError, "rank of givnum (8th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_givnum) != (2))
    rb_raise(rb_eRuntimeError, "shape 0 of givnum must be %d", 2);
  if (NA_SHAPE1(rblapack_givnum) != (n*LG(n)))
    rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", n*LG(n));
  if (NA_TYPE(rblapack_givnum) != NA_DFLOAT)
    rblapack_givnum = na_change_type(rblapack_givnum, NA_DFLOAT);
  givnum = NA_PTR_TYPE(rblapack_givnum, doublereal*);
  if (!NA_IsNArray(rblapack_perm))
    rb_raise(rb_eArgError, "perm (5th argument) must be NArray");
  if (NA_RANK(rblapack_perm) != 1)
    rb_raise(rb_eArgError, "rank of perm (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_perm) != (n*LG(n)))
    rb_raise(rb_eRuntimeError, "shape 0 of perm must be %d", n*LG(n));
  if (NA_TYPE(rblapack_perm) != NA_LINT)
    rblapack_perm = na_change_type(rblapack_perm, NA_LINT);
  perm = NA_PTR_TYPE(rblapack_perm, integer*);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (9th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 1)
    rb_raise(rb_eArgError, "rank of q (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_q) != (pow(n,2)))
    rb_raise(rb_eRuntimeError, "shape 0 of q must be %d", pow(n,2));
  if (NA_TYPE(rblapack_q) != NA_DFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
  q = NA_PTR_TYPE(rblapack_q, doublereal*);
  if (!NA_IsNArray(rblapack_givcol))
    rb_raise(rb_eArgError, "givcol (7th argument) must be NArray");
  if (NA_RANK(rblapack_givcol) != 2)
    rb_raise(rb_eArgError, "rank of givcol (7th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_givcol) != (2))
    rb_raise(rb_eRuntimeError, "shape 0 of givcol must be %d", 2);
  if (NA_SHAPE1(rblapack_givcol) != (n*LG(n)))
    rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", n*LG(n));
  if (NA_TYPE(rblapack_givcol) != NA_LINT)
    rblapack_givcol = na_change_type(rblapack_givcol, NA_LINT);
  givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_z = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  ztemp = ALLOC_N(doublereal, (n));

  dlaeda_(&n, &tlvls, &curlvl, &curpbm, prmptr, perm, givptr, givcol, givnum, q, qptr, z, ztemp, &info);

  free(ztemp);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_z, rblapack_info);
}

void
init_lapack_dlaeda(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaeda", rblapack_dlaeda, -1);
}
ruby-lapack-1.7.2/ext/dpotf2.c0000644000175000017500000001010412502221021015710 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dpotf2_(char* uplo, integer* n, doublereal* a, integer* lda, integer* info);


static VALUE
rblapack_dpotf2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  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  info, a = NumRu::Lapack.dpotf2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPOTF2 computes the Cholesky factorization of a real symmetric\n*  positive definite matrix A.\n*\n*  The factorization has the form\n*     A = U' * U ,  if UPLO = 'U', or\n*     A = L  * L',  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is lower triangular.\n*\n*  This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          n by n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n by n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the factor U or L from the Cholesky\n*          factorization A = U'*U  or A = L*L'.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*          > 0: if INFO = k, the leading minor of order k is not\n*               positive definite, and the factorization could not be\n*               completed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.dpotf2( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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*);
  {
    na_shape_t 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__;

  dpotf2_(&uplo, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_dpotf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dpotf2", rblapack_dpotf2, -1);
}
ruby-lapack-1.7.2/ext/dlaqps.c0000644000175000017500000002410312502221021016002 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaqps_(integer* m, integer* n, integer* offset, integer* nb, integer* kb, doublereal* a, integer* lda, integer* jpvt, doublereal* tau, doublereal* vn1, doublereal* vn2, doublereal* auxv, doublereal* f, integer* ldf);


static VALUE
rblapack_dlaqps(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_offset;
  integer offset; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_jpvt;
  integer *jpvt; 
  VALUE rblapack_vn1;
  doublereal *vn1; 
  VALUE rblapack_vn2;
  doublereal *vn2; 
  VALUE rblapack_auxv;
  doublereal *auxv; 
  VALUE rblapack_f;
  doublereal *f; 
  VALUE rblapack_kb;
  integer kb; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  VALUE rblapack_jpvt_out__;
  integer *jpvt_out__;
  VALUE rblapack_vn1_out__;
  doublereal *vn1_out__;
  VALUE rblapack_vn2_out__;
  doublereal *vn2_out__;
  VALUE rblapack_auxv_out__;
  doublereal *auxv_out__;
  VALUE rblapack_f_out__;
  doublereal *f_out__;

  integer lda;
  integer n;
  integer nb;
  integer ldf;

  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  kb, tau, a, jpvt, vn1, vn2, auxv, f = NumRu::Lapack.dlaqps( m, offset, a, jpvt, vn1, vn2, auxv, f, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, VN2, AUXV, F, LDF )\n\n*  Purpose\n*  =======\n*\n*  DLAQPS computes a step of QR factorization with column pivoting\n*  of a real M-by-N matrix A by using Blas-3.  It tries to factorize\n*  NB columns from A starting from the row OFFSET+1, and updates all\n*  of the matrix with Blas-3 xGEMM.\n*\n*  In some cases, due to catastrophic cancellations, it cannot\n*  factorize NB columns.  Hence, the actual number of factorized\n*  columns is returned in KB.\n*\n*  Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\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*  OFFSET  (input) INTEGER\n*          The number of rows of A that have been factorized in\n*          previous steps.\n*\n*  NB      (input) INTEGER\n*          The number of columns to factorize.\n*\n*  KB      (output) INTEGER\n*          The number of columns actually factorized.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, block A(OFFSET+1:M,1:KB) is the triangular\n*          factor obtained and block A(1:OFFSET,1:N) has been\n*          accordingly pivoted, but no factorized.\n*          The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has\n*          been updated.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  JPVT    (input/output) INTEGER array, dimension (N)\n*          JPVT(I) = K <==> Column K of the full matrix A has been\n*          permuted into position I in AP.\n*\n*  TAU     (output) DOUBLE PRECISION array, dimension (KB)\n*          The scalar factors of the elementary reflectors.\n*\n*  VN1     (input/output) DOUBLE PRECISION array, dimension (N)\n*          The vector with the partial column norms.\n*\n*  VN2     (input/output) DOUBLE PRECISION array, dimension (N)\n*          The vector with the exact column norms.\n*\n*  AUXV    (input/output) DOUBLE PRECISION array, dimension (NB)\n*          Auxiliar vector.\n*\n*  F       (input/output) DOUBLE PRECISION array, dimension (LDF,NB)\n*          Matrix F' = L*Y'*A.\n*\n*  LDF     (input) INTEGER\n*          The leading dimension of the array F. LDF >= max(1,N).\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n*    X. Sun, Computer Science Dept., Duke University, USA\n*\n*  Partial column norm updating strategy modified by\n*    Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n*    University of Zagreb, Croatia.\n*     June 2010\n*  For more details see LAPACK Working Note 176.\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  kb, tau, a, jpvt, vn1, vn2, auxv, f = NumRu::Lapack.dlaqps( m, offset, a, jpvt, vn1, vn2, auxv, f, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_m = argv[0];
  rblapack_offset = argv[1];
  rblapack_a = argv[2];
  rblapack_jpvt = argv[3];
  rblapack_vn1 = argv[4];
  rblapack_vn2 = argv[5];
  rblapack_auxv = argv[6];
  rblapack_f = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  if (!NA_IsNArray(rblapack_vn1))
    rb_raise(rb_eArgError, "vn1 (5th argument) must be NArray");
  if (NA_RANK(rblapack_vn1) != 1)
    rb_raise(rb_eArgError, "rank of vn1 (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_vn1) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of vn1 must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_vn1) != NA_DFLOAT)
    rblapack_vn1 = na_change_type(rblapack_vn1, NA_DFLOAT);
  vn1 = NA_PTR_TYPE(rblapack_vn1, doublereal*);
  if (!NA_IsNArray(rblapack_auxv))
    rb_raise(rb_eArgError, "auxv (7th argument) must be NArray");
  if (NA_RANK(rblapack_auxv) != 1)
    rb_raise(rb_eArgError, "rank of auxv (7th argument) must be %d", 1);
  nb = NA_SHAPE0(rblapack_auxv);
  if (NA_TYPE(rblapack_auxv) != NA_DFLOAT)
    rblapack_auxv = na_change_type(rblapack_auxv, NA_DFLOAT);
  auxv = NA_PTR_TYPE(rblapack_auxv, doublereal*);
  offset = NUM2INT(rblapack_offset);
  if (!NA_IsNArray(rblapack_vn2))
    rb_raise(rb_eArgError, "vn2 (6th argument) must be NArray");
  if (NA_RANK(rblapack_vn2) != 1)
    rb_raise(rb_eArgError, "rank of vn2 (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_vn2) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of vn2 must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_vn2) != NA_DFLOAT)
    rblapack_vn2 = na_change_type(rblapack_vn2, NA_DFLOAT);
  vn2 = NA_PTR_TYPE(rblapack_vn2, doublereal*);
  if (!NA_IsNArray(rblapack_jpvt))
    rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
  if (NA_RANK(rblapack_jpvt) != 1)
    rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_jpvt) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_jpvt) != NA_LINT)
    rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
  jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
  if (!NA_IsNArray(rblapack_f))
    rb_raise(rb_eArgError, "f (8th argument) must be NArray");
  if (NA_RANK(rblapack_f) != 2)
    rb_raise(rb_eArgError, "rank of f (8th argument) must be %d", 2);
  ldf = NA_SHAPE0(rblapack_f);
  if (NA_SHAPE1(rblapack_f) != nb)
    rb_raise(rb_eRuntimeError, "shape 1 of f must be the same as shape 0 of auxv");
  if (NA_TYPE(rblapack_f) != NA_DFLOAT)
    rblapack_f = na_change_type(rblapack_f, NA_DFLOAT);
  f = NA_PTR_TYPE(rblapack_f, doublereal*);
  kb = nb;
  {
    na_shape_t shape[1];
    shape[0] = kb;
    rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
  MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
  rblapack_jpvt = rblapack_jpvt_out__;
  jpvt = jpvt_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_vn1_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  vn1_out__ = NA_PTR_TYPE(rblapack_vn1_out__, doublereal*);
  MEMCPY(vn1_out__, vn1, doublereal, NA_TOTAL(rblapack_vn1));
  rblapack_vn1 = rblapack_vn1_out__;
  vn1 = vn1_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_vn2_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  vn2_out__ = NA_PTR_TYPE(rblapack_vn2_out__, doublereal*);
  MEMCPY(vn2_out__, vn2, doublereal, NA_TOTAL(rblapack_vn2));
  rblapack_vn2 = rblapack_vn2_out__;
  vn2 = vn2_out__;
  {
    na_shape_t shape[1];
    shape[0] = nb;
    rblapack_auxv_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  auxv_out__ = NA_PTR_TYPE(rblapack_auxv_out__, doublereal*);
  MEMCPY(auxv_out__, auxv, doublereal, NA_TOTAL(rblapack_auxv));
  rblapack_auxv = rblapack_auxv_out__;
  auxv = auxv_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldf;
    shape[1] = nb;
    rblapack_f_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  f_out__ = NA_PTR_TYPE(rblapack_f_out__, doublereal*);
  MEMCPY(f_out__, f, doublereal, NA_TOTAL(rblapack_f));
  rblapack_f = rblapack_f_out__;
  f = f_out__;

  dlaqps_(&m, &n, &offset, &nb, &kb, a, &lda, jpvt, tau, vn1, vn2, auxv, f, &ldf);

  rblapack_kb = INT2NUM(kb);
  return rb_ary_new3(8, rblapack_kb, rblapack_tau, rblapack_a, rblapack_jpvt, rblapack_vn1, rblapack_vn2, rblapack_auxv, rblapack_f);
}

void
init_lapack_dlaqps(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaqps", rblapack_dlaqps, -1);
}
ruby-lapack-1.7.2/ext/strsen.c0000644000175000017500000003436112502221012016043 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID strsen_(char* job, char* compq, logical* select, integer* n, real* t, integer* ldt, real* q, integer* ldq, real* wr, real* wi, integer* m, real* s, real* sep, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_strsen(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_compq;
  char compq; 
  VALUE rblapack_select;
  logical *select; 
  VALUE rblapack_t;
  real *t; 
  VALUE rblapack_q;
  real *q; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_wr;
  real *wr; 
  VALUE rblapack_wi;
  real *wi; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_s;
  real s; 
  VALUE rblapack_sep;
  real sep; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_t_out__;
  real *t_out__;
  VALUE rblapack_q_out__;
  real *q_out__;
  integer *iwork;

  integer n;
  integer ldt;
  integer ldq;

  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  wr, wi, m, s, sep, work, info, t, q = NumRu::Lapack.strsen( job, compq, select, t, q, liwork, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  STRSEN reorders the real Schur factorization of a real matrix\n*  A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in\n*  the leading diagonal blocks of the upper quasi-triangular matrix T,\n*  and the leading columns of Q form an orthonormal basis of the\n*  corresponding right invariant subspace.\n*\n*  Optionally the routine computes the reciprocal condition numbers of\n*  the cluster of eigenvalues and/or the invariant subspace.\n*\n*  T must be in Schur canonical form (as returned by SHSEQR), that is,\n*  block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each\n*  2-by-2 diagonal block has its diagonal elemnts equal and its\n*  off-diagonal elements of opposite sign.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies whether condition numbers are required for the\n*          cluster of eigenvalues (S) or the invariant subspace (SEP):\n*          = 'N': none;\n*          = 'E': for eigenvalues only (S);\n*          = 'V': for invariant subspace only (SEP);\n*          = 'B': for both eigenvalues and invariant subspace (S and\n*                 SEP).\n*\n*  COMPQ   (input) CHARACTER*1\n*          = 'V': update the matrix Q of Schur vectors;\n*          = 'N': do not update Q.\n*\n*  SELECT  (input) LOGICAL array, dimension (N)\n*          SELECT specifies the eigenvalues in the selected cluster. To\n*          select a real eigenvalue w(j), SELECT(j) must be set to\n*          .TRUE.. To select a complex conjugate pair of eigenvalues\n*          w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,\n*          either SELECT(j) or SELECT(j+1) or both must be set to\n*          .TRUE.; a complex conjugate pair of eigenvalues must be\n*          either both included in the cluster or both excluded.\n*\n*  N       (input) INTEGER\n*          The order of the matrix T. N >= 0.\n*\n*  T       (input/output) REAL array, dimension (LDT,N)\n*          On entry, the upper quasi-triangular matrix T, in Schur\n*          canonical form.\n*          On exit, T is overwritten by the reordered matrix T, again in\n*          Schur canonical form, with the selected eigenvalues in the\n*          leading diagonal blocks.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= max(1,N).\n*\n*  Q       (input/output) REAL array, dimension (LDQ,N)\n*          On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n*          On exit, if COMPQ = 'V', Q has been postmultiplied by the\n*          orthogonal transformation matrix which reorders T; the\n*          leading M columns of Q form an orthonormal basis for the\n*          specified invariant subspace.\n*          If COMPQ = 'N', Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.\n*          LDQ >= 1; and if COMPQ = 'V', LDQ >= N.\n*\n*  WR      (output) REAL array, dimension (N)\n*  WI      (output) REAL array, dimension (N)\n*          The real and imaginary parts, respectively, of the reordered\n*          eigenvalues of T. The eigenvalues are stored in the same\n*          order as on the diagonal of T, with WR(i) = T(i,i) and, if\n*          T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and\n*          WI(i+1) = -WI(i). Note that if a complex eigenvalue is\n*          sufficiently ill-conditioned, then its value may differ\n*          significantly from its value before reordering.\n*\n*  M       (output) INTEGER\n*          The dimension of the specified invariant subspace.\n*          0 < = M <= N.\n*\n*  S       (output) REAL\n*          If JOB = 'E' or 'B', S is a lower bound on the reciprocal\n*          condition number for the selected cluster of eigenvalues.\n*          S cannot underestimate the true reciprocal condition number\n*          by more than a factor of sqrt(N). If M = 0 or N, S = 1.\n*          If JOB = 'N' or 'V', S is not referenced.\n*\n*  SEP     (output) REAL\n*          If JOB = 'V' or 'B', SEP is the estimated reciprocal\n*          condition number of the specified invariant subspace. If\n*          M = 0 or N, SEP = norm(T).\n*          If JOB = 'N' or 'E', SEP is not referenced.\n*\n*  WORK    (workspace/output) REAL 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*          If JOB = 'N', LWORK >= max(1,N);\n*          if JOB = 'E', LWORK >= max(1,M*(N-M));\n*          if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).\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*  IWORK   (workspace) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.\n*          If JOB = 'N' or 'E', LIWORK >= 1;\n*          if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)).\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal size of the IWORK array,\n*          returns this value as the first entry of the IWORK array, and\n*          no error message related to LIWORK 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*          = 1: reordering of T failed because some eigenvalues are too\n*               close to separate (the problem is very ill-conditioned);\n*               T may have been partially reordered, and WR and WI\n*               contain the eigenvalues in the same order as in T; S and\n*               SEP (if requested) are set to zero.\n*\n\n*  Further Details\n*  ===============\n*\n*  STRSEN first collects the selected eigenvalues by computing an\n*  orthogonal transformation Z to move them to the top left corner of T.\n*  In other words, the selected eigenvalues are the eigenvalues of T11\n*  in:\n*\n*                Z'*T*Z = ( T11 T12 ) n1\n*                         (  0  T22 ) n2\n*                            n1  n2\n*\n*  where N = n1+n2 and Z' means the transpose of Z. The first n1 columns\n*  of Z span the specified invariant subspace of T.\n*\n*  If T has been obtained from the real Schur factorization of a matrix\n*  A = Q*T*Q', then the reordered real Schur factorization of A is given\n*  by A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span\n*  the corresponding invariant subspace of A.\n*\n*  The reciprocal condition number of the average of the eigenvalues of\n*  T11 may be returned in S. S lies between 0 (very badly conditioned)\n*  and 1 (very well conditioned). It is computed as follows. First we\n*  compute R so that\n*\n*                         P = ( I  R ) n1\n*                             ( 0  0 ) n2\n*                               n1 n2\n*\n*  is the projector on the invariant subspace associated with T11.\n*  R is the solution of the Sylvester equation:\n*\n*                        T11*R - R*T22 = T12.\n*\n*  Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote\n*  the two-norm of M. Then S is computed as the lower bound\n*\n*                      (1 + F-norm(R)**2)**(-1/2)\n*\n*  on the reciprocal of 2-norm(P), the true reciprocal condition number.\n*  S cannot underestimate 1 / 2-norm(P) by more than a factor of\n*  sqrt(N).\n*\n*  An approximate error bound for the computed average of the\n*  eigenvalues of T11 is\n*\n*                         EPS * norm(T) / S\n*\n*  where EPS is the machine precision.\n*\n*  The reciprocal condition number of the right invariant subspace\n*  spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.\n*  SEP is defined as the separation of T11 and T22:\n*\n*                     sep( T11, T22 ) = sigma-min( C )\n*\n*  where sigma-min(C) is the smallest singular value of the\n*  n1*n2-by-n1*n2 matrix\n*\n*     C  = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )\n*\n*  I(m) is an m by m identity matrix, and kprod denotes the Kronecker\n*  product. We estimate sigma-min(C) by the reciprocal of an estimate of\n*  the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)\n*  cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).\n*\n*  When SEP is small, small changes in T can cause large changes in\n*  the invariant subspace. An approximate bound on the maximum angular\n*  error in the computed right invariant subspace is\n*\n*                      EPS * norm(T) / SEP\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  wr, wi, m, s, sep, work, info, t, q = NumRu::Lapack.strsen( job, compq, select, t, q, liwork, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_job = argv[0];
  rblapack_compq = argv[1];
  rblapack_select = argv[2];
  rblapack_t = argv[3];
  rblapack_q = argv[4];
  rblapack_liwork = argv[5];
  if (argc == 7) {
    rblapack_lwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  job = StringValueCStr(rblapack_job)[0];
  if (!NA_IsNArray(rblapack_select))
    rb_raise(rb_eArgError, "select (3th argument) must be NArray");
  if (NA_RANK(rblapack_select) != 1)
    rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_select);
  if (NA_TYPE(rblapack_select) != NA_LINT)
    rblapack_select = na_change_type(rblapack_select, NA_LINT);
  select = NA_PTR_TYPE(rblapack_select, logical*);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (5th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_q) != NA_SFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
  q = NA_PTR_TYPE(rblapack_q, real*);
  compq = StringValueCStr(rblapack_compq)[0];
  liwork = NUM2INT(rblapack_liwork);
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (4th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  if (NA_SHAPE1(rblapack_t) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_t) != NA_SFLOAT)
    rblapack_t = na_change_type(rblapack_t, NA_SFLOAT);
  t = NA_PTR_TYPE(rblapack_t, real*);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&job,"N") ? n : lsame_(&job,"E") ? m*(n-m) : (lsame_(&job,"V")||lsame_(&job,"B")) ? 2*m*(n-m) : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  wr = NA_PTR_TYPE(rblapack_wr, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  wi = NA_PTR_TYPE(rblapack_wi, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = n;
    rblapack_t_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  t_out__ = NA_PTR_TYPE(rblapack_t_out__, real*);
  MEMCPY(t_out__, t, real, NA_TOTAL(rblapack_t));
  rblapack_t = rblapack_t_out__;
  t = t_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
  MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  iwork = ALLOC_N(integer, (MAX(1,liwork)));

  strsen_(&job, &compq, select, &n, t, &ldt, q, &ldq, wr, wi, &m, &s, &sep, work, &lwork, iwork, &liwork, &info);

  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_s = rb_float_new((double)s);
  rblapack_sep = rb_float_new((double)sep);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_wr, rblapack_wi, rblapack_m, rblapack_s, rblapack_sep, rblapack_work, rblapack_info, rblapack_t, rblapack_q);
}

void
init_lapack_strsen(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "strsen", rblapack_strsen, -1);
}
ruby-lapack-1.7.2/ext/dspevx.c0000644000175000017500000002324112502221026016036 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dspevx_(char* jobz, char* range, char* uplo, integer* n, doublereal* ap, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublereal* z, integer* ldz, doublereal* work, integer* iwork, integer* ifail, integer* info);


static VALUE
rblapack_dspevx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_vl;
  doublereal vl; 
  VALUE rblapack_vu;
  doublereal vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  doublereal abstol; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_ifail;
  integer *ifail; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublereal *ap_out__;
  doublereal *work;
  integer *iwork;

  integer ldap;
  integer n;
  integer ldz;

  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  m, w, z, ifail, info, ap = NumRu::Lapack.dspevx( jobz, range, uplo, ap, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSPEVX computes selected eigenvalues and, optionally, eigenvectors\n*  of a real symmetric matrix A in packed storage.  Eigenvalues/vectors\n*  can be selected by specifying either a range of values or a range of\n*  indices for the desired eigenvalues.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found;\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found;\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, AP is overwritten by values generated during the\n*          reduction to tridiagonal form.  If UPLO = 'U', the diagonal\n*          and first superdiagonal of the tridiagonal matrix T overwrite\n*          the corresponding elements of A, and if UPLO = 'L', the\n*          diagonal and first subdiagonal of T overwrite the\n*          corresponding elements of A.\n*\n*  VL      (input) DOUBLE PRECISION\n*  VU      (input) DOUBLE PRECISION\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) DOUBLE PRECISION\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less than\n*          or equal to zero, then  EPS*|T|  will be used in its place,\n*          where |T| is the 1-norm of the tridiagonal matrix obtained\n*          by reducing AP to tridiagonal form.\n*\n*          Eigenvalues will be computed most accurately when ABSTOL is\n*          set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n*          If this routine returns with INFO>0, indicating that some\n*          eigenvectors did not converge, try setting ABSTOL to\n*          2*DLAMCH('S').\n*\n*          See \"Computing Small Singular Values of Bidiagonal Matrices\n*          with Guaranteed High Relative Accuracy,\" by Demmel and\n*          Kahan, LAPACK Working Note #3.\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, the selected eigenvalues in ascending order.\n*\n*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))\n*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix A\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          If an eigenvector fails to converge, then that column of Z\n*          contains the latest approximation to the eigenvector, and the\n*          index of the eigenvector is returned in IFAIL.\n*          If JOBZ = 'N', then Z is not referenced.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (8*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (5*N)\n*\n*  IFAIL   (output) INTEGER array, dimension (N)\n*          If JOBZ = 'V', then if INFO = 0, the first M elements of\n*          IFAIL are zero.  If INFO > 0, then IFAIL contains the\n*          indices of the eigenvectors that failed to converge.\n*          If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n*                Their indices are stored in array IFAIL.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, ifail, info, ap = NumRu::Lapack.dspevx( jobz, range, uplo, ap, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_uplo = argv[2];
  rblapack_ap = argv[3];
  rblapack_vl = argv[4];
  rblapack_vu = argv[5];
  rblapack_il = argv[6];
  rblapack_iu = argv[7];
  rblapack_abstol = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  vl = NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  abstol = NUM2DBL(rblapack_abstol);
  range = StringValueCStr(rblapack_range)[0];
  vu = NUM2DBL(rblapack_vu);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  iu = NUM2INT(rblapack_iu);
  m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
  MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  work = ALLOC_N(doublereal, (8*n));
  iwork = ALLOC_N(integer, (5*n));

  dspevx_(&jobz, &range, &uplo, &n, ap, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, iwork, ifail, &info);

  free(work);
  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_ap);
}

void
init_lapack_dspevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dspevx", rblapack_dspevx, -1);
}
ruby-lapack-1.7.2/ext/stfttr.c0000644000175000017500000001655712502221026016067 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID stfttr_(char* transr, char* uplo, integer* n, real* arf, real* a, integer* lda, integer* info);


static VALUE
rblapack_stfttr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_arf;
  real *arf; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_info;
  integer info; 

  integer ldarf;
  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  a, info = NumRu::Lapack.stfttr( transr, uplo, arf, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  STFTTR copies a triangular matrix A from rectangular full packed\n*  format (TF) to standard full format (TR).\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR   (input) CHARACTER*1\n*          = 'N':  ARF is in Normal format;\n*          = 'T':  ARF is in Transpose format.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrices ARF and A. N >= 0.\n*\n*  ARF     (input) REAL array, dimension (N*(N+1)/2).\n*          On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')\n*          matrix A in RFP format. See the \"Notes\" below for more\n*          details.\n*\n*  A       (output) REAL array, dimension (LDA,N)\n*          On exit, the triangular matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of the array A contains\n*          the upper triangular matrix, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of the array A contains\n*          the lower triangular matrix, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\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*  We first consider Rectangular Full Packed (RFP) Format when N is\n*  even. We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  the transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  the transpose of the last three columns of AP lower.\n*  This covers the case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        03 04 05                33 43 53\n*        13 14 15                00 44 54\n*        23 24 25                10 11 55\n*        33 34 35                20 21 22\n*        00 44 45                30 31 32\n*        01 11 55                40 41 42\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We then consider Rectangular Full Packed (RFP) Format when N is\n*  odd. We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  the transpose of the first two columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  the transpose of the last two columns of AP lower.\n*  This covers the case N odd and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        02 03 04                00 33 43\n*        12 13 14                10 11 44\n*        22 23 24                20 21 22\n*        00 33 34                30 31 32\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*           RFP A                   RFP A\n*\n*     02 12 22 00 01             00 10 20 30 40 50\n*     03 13 23 33 11             33 11 21 31 41 51\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  Reference\n*  =========\n*\n*  =====================================================================\n*\n*     ..\n*     .. Local Scalars ..\n      LOGICAL            LOWER, NISODD, NORMALTRANSR\n      INTEGER            N1, N2, K, NT, NX2, NP1X2\n      INTEGER            I, J, L, IJ\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MOD\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  a, info = NumRu::Lapack.stfttr( transr, uplo, arf, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_arf = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  if (!NA_IsNArray(rblapack_arf))
    rb_raise(rb_eArgError, "arf (3th argument) must be NArray");
  if (NA_RANK(rblapack_arf) != 1)
    rb_raise(rb_eArgError, "rank of arf (3th argument) must be %d", 1);
  ldarf = NA_SHAPE0(rblapack_arf);
  if (NA_TYPE(rblapack_arf) != NA_SFLOAT)
    rblapack_arf = na_change_type(rblapack_arf, NA_SFLOAT);
  arf = NA_PTR_TYPE(rblapack_arf, real*);
  n = ((int)sqrtf(ldarf*8+1.0f)-1)/2;
  uplo = StringValueCStr(rblapack_uplo)[0];
  lda = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a = NA_PTR_TYPE(rblapack_a, real*);

  stfttr_(&transr, &uplo, &n, arf, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_a, rblapack_info);
}

void
init_lapack_stfttr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "stfttr", rblapack_stfttr, -1);
}
ruby-lapack-1.7.2/ext/dlarrk.c0000644000175000017500000001246012502221013016001 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlarrk_(integer* n, integer* iw, doublereal* gl, doublereal* gu, doublereal* d, doublereal* e2, doublereal* pivmin, doublereal* reltol, doublereal* w, doublereal* werr, integer* info);


static VALUE
rblapack_dlarrk(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_iw;
  integer iw; 
  VALUE rblapack_gl;
  doublereal gl; 
  VALUE rblapack_gu;
  doublereal gu; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e2;
  doublereal *e2; 
  VALUE rblapack_pivmin;
  doublereal pivmin; 
  VALUE rblapack_reltol;
  doublereal reltol; 
  VALUE rblapack_w;
  doublereal w; 
  VALUE rblapack_werr;
  doublereal werr; 
  VALUE rblapack_info;
  integer info; 

  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  w, werr, info = NumRu::Lapack.dlarrk( iw, gl, gu, d, e2, pivmin, reltol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLARRK( N, IW, GL, GU, D, E2, PIVMIN, RELTOL, W, WERR, INFO)\n\n*  Purpose\n*  =======\n*\n*  DLARRK computes one eigenvalue of a symmetric tridiagonal\n*  matrix T to suitable accuracy. This is an auxiliary code to be\n*  called from DSTEMR.\n*\n*  To avoid overflow, the matrix must be scaled so that its\n*  largest element is no greater than overflow**(1/2) *\n*  underflow**(1/4) in absolute value, and for greatest\n*  accuracy, it should not be much smaller than that.\n*\n*  See W. Kahan \"Accurate Eigenvalues of a Symmetric Tridiagonal\n*  Matrix\", Report CS41, Computer Science Dept., Stanford\n*  University, July 21, 1966.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the tridiagonal matrix T.  N >= 0.\n*\n*  IW      (input) INTEGER\n*          The index of the eigenvalues to be returned.\n*\n*  GL      (input) DOUBLE PRECISION\n*  GU      (input) DOUBLE PRECISION\n*          An upper and a lower bound on the eigenvalue.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          The n diagonal elements of the tridiagonal matrix T.\n*\n*  E2      (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (n-1) squared off-diagonal elements of the tridiagonal matrix T.\n*\n*  PIVMIN  (input) DOUBLE PRECISION\n*          The minimum pivot allowed in the Sturm sequence for T.\n*\n*  RELTOL  (input) DOUBLE PRECISION\n*          The minimum relative width of an interval.  When an interval\n*          is narrower than RELTOL times the larger (in\n*          magnitude) endpoint, then it is considered to be\n*          sufficiently small, i.e., converged.  Note: this should\n*          always be at least radix*machine epsilon.\n*\n*  W       (output) DOUBLE PRECISION\n*\n*  WERR    (output) DOUBLE PRECISION\n*          The error bound on the corresponding eigenvalue approximation\n*          in W.\n*\n*  INFO    (output) INTEGER\n*          = 0:       Eigenvalue converged\n*          = -1:      Eigenvalue did NOT converge\n*\n*  Internal Parameters\n*  ===================\n*\n*  FUDGE   DOUBLE PRECISION, default = 2\n*          A \"fudge factor\" to widen the Gershgorin intervals.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, werr, info = NumRu::Lapack.dlarrk( iw, gl, gu, d, e2, pivmin, reltol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_iw = argv[0];
  rblapack_gl = argv[1];
  rblapack_gu = argv[2];
  rblapack_d = argv[3];
  rblapack_e2 = argv[4];
  rblapack_pivmin = argv[5];
  rblapack_reltol = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  iw = NUM2INT(rblapack_iw);
  gu = NUM2DBL(rblapack_gu);
  pivmin = NUM2DBL(rblapack_pivmin);
  gl = NUM2DBL(rblapack_gl);
  reltol = NUM2DBL(rblapack_reltol);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_e2))
    rb_raise(rb_eArgError, "e2 (5th argument) must be NArray");
  if (NA_RANK(rblapack_e2) != 1)
    rb_raise(rb_eArgError, "rank of e2 (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e2) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e2 must be %d", n-1);
  if (NA_TYPE(rblapack_e2) != NA_DFLOAT)
    rblapack_e2 = na_change_type(rblapack_e2, NA_DFLOAT);
  e2 = NA_PTR_TYPE(rblapack_e2, doublereal*);

  dlarrk_(&n, &iw, &gl, &gu, d, e2, &pivmin, &reltol, &w, &werr, &info);

  rblapack_w = rb_float_new((double)w);
  rblapack_werr = rb_float_new((double)werr);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_w, rblapack_werr, rblapack_info);
}

void
init_lapack_dlarrk(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlarrk", rblapack_dlarrk, -1);
}
ruby-lapack-1.7.2/ext/sgesvxx.c0000644000175000017500000007145712502221013016244 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgesvxx_(char* fact, char* trans, integer* n, integer* nrhs, real* a, integer* lda, real* af, integer* ldaf, integer* ipiv, char* equed, real* r, real* c, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* rpvgrw, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, real* work, integer* iwork, integer* info);


static VALUE
rblapack_sgesvxx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_af;
  real *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_r;
  real *r; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_params;
  real *params; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_rpvgrw;
  real rpvgrw; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_err_bnds_norm;
  real *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  real *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_af_out__;
  real *af_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  VALUE rblapack_r_out__;
  real *r_out__;
  VALUE rblapack_c_out__;
  real *c_out__;
  VALUE rblapack_b_out__;
  real *b_out__;
  VALUE rblapack_params_out__;
  real *params_out__;
  real *work;
  integer *iwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer nparams;
  integer ldx;
  integer n_err_bnds;

  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  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, r, c, b, params = NumRu::Lapack.sgesvxx( fact, trans, a, af, ipiv, equed, r, c, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     SGESVXX uses the LU factorization to compute the solution to a\n*     real system of linear equations  A * X = B,  where A is an\n*     N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n*     If requested, both normwise and maximum componentwise error bounds\n*     are returned. SGESVXX will return a solution with a tiny\n*     guaranteed error (O(eps) where eps is the working machine\n*     precision) unless the matrix is very ill-conditioned, in which\n*     case a warning is returned. Relevant condition numbers also are\n*     calculated and returned.\n*\n*     SGESVXX accepts user-provided factorizations and equilibration\n*     factors; see the definitions of the FACT and EQUED options.\n*     Solving with refinement and using a factorization from a previous\n*     SGESVXX call will also produce a solution with either O(eps)\n*     errors or warnings, but we cannot make that claim for general\n*     user-provided factorizations and equilibration factors if they\n*     differ from what SGESVXX would itself produce.\n*\n*     Description\n*     ===========\n*\n*     The following steps are performed:\n*\n*     1. If FACT = 'E', real scaling factors are computed to equilibrate\n*     the system:\n*\n*       TRANS = 'N':  diag(R)*A*diag(C)     *inv(diag(C))*X = diag(R)*B\n*       TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n*       TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n*     or diag(C)*B (if TRANS = 'T' or 'C').\n*\n*     2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n*     the matrix A (after equilibration if FACT = 'E') as\n*\n*       A = P * L * U,\n*\n*     where P is a permutation matrix, L is a unit lower triangular\n*     matrix, and U is upper triangular.\n*\n*     3. If some U(i,i)=0, so that U is exactly singular, then the\n*     routine returns with INFO = i. Otherwise, the factored form of A\n*     is used to estimate the condition number of the matrix A (see\n*     argument RCOND). If the reciprocal of the condition number is less\n*     than machine precision, the routine still goes on to solve for X\n*     and compute error bounds as described below.\n*\n*     4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*     5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n*     the routine will use iterative refinement to try to get a small\n*     error and error bounds.  Refinement calculates the residual to at\n*     least twice the working precision.\n*\n*     6. If equilibration was used, the matrix X is premultiplied by\n*     diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n*     that it solves the original system before equilibration.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     FACT    (input) CHARACTER*1\n*     Specifies whether or not the factored form of the matrix A is\n*     supplied on entry, and if not, whether the matrix A should be\n*     equilibrated before it is factored.\n*       = 'F':  On entry, AF and IPIV contain the factored form of A.\n*               If EQUED is not 'N', the matrix A has been\n*               equilibrated with scaling factors given by R and C.\n*               A, AF, and IPIV are not modified.\n*       = 'N':  The matrix A will be copied to AF and factored.\n*       = 'E':  The matrix A will be equilibrated if necessary, then\n*               copied to AF and factored.\n*\n*     TRANS   (input) CHARACTER*1\n*     Specifies the form of the system of equations:\n*       = 'N':  A * X = B     (No transpose)\n*       = 'T':  A**T * X = B  (Transpose)\n*       = 'C':  A**H * X = B  (Conjugate Transpose = Transpose)\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     A       (input/output) REAL array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.  If FACT = 'F' and EQUED is\n*     not 'N', then A must have been equilibrated by the scaling\n*     factors in R and/or C.  A is not modified if FACT = 'F' or\n*     'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n*     On exit, if EQUED .ne. 'N', A is scaled as follows:\n*     EQUED = 'R':  A := diag(R) * A\n*     EQUED = 'C':  A := A * diag(C)\n*     EQUED = 'B':  A := diag(R) * A * diag(C).\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input or output) REAL array, dimension (LDAF,N)\n*     If FACT = 'F', then AF is an input argument and on entry\n*     contains the factors L and U from the factorization\n*     A = P*L*U as computed by SGETRF.  If EQUED .ne. 'N', then\n*     AF is the factored form of the equilibrated matrix A.\n*\n*     If FACT = 'N', then AF is an output argument and on exit\n*     returns the factors L and U from the factorization A = P*L*U\n*     of the original matrix A.\n*\n*     If FACT = 'E', then AF is an output argument and on exit\n*     returns the factors L and U from the factorization A = P*L*U\n*     of the equilibrated matrix A (see the description of A for\n*     the form of the equilibrated matrix).\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input or output) INTEGER array, dimension (N)\n*     If FACT = 'F', then IPIV is an input argument and on entry\n*     contains the pivot indices from the factorization A = P*L*U\n*     as computed by SGETRF; row i of the matrix was interchanged\n*     with row IPIV(i).\n*\n*     If FACT = 'N', then IPIV is an output argument and on exit\n*     contains the pivot indices from the factorization A = P*L*U\n*     of the original matrix A.\n*\n*     If FACT = 'E', then IPIV is an output argument and on exit\n*     contains the pivot indices from the factorization A = P*L*U\n*     of the equilibrated matrix A.\n*\n*     EQUED   (input or output) CHARACTER*1\n*     Specifies the form of equilibration that was done.\n*       = 'N':  No equilibration (always true if FACT = 'N').\n*       = 'R':  Row equilibration, i.e., A has been premultiplied by\n*               diag(R).\n*       = 'C':  Column equilibration, i.e., A has been postmultiplied\n*               by diag(C).\n*       = 'B':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(R) * A * diag(C).\n*     EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*     output argument.\n*\n*     R       (input or output) REAL array, dimension (N)\n*     The row scale factors for A.  If EQUED = 'R' or 'B', A is\n*     multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n*     is not accessed.  R is an input argument if FACT = 'F';\n*     otherwise, R is an output argument.  If FACT = 'F' and\n*     EQUED = 'R' or 'B', each element of R must be positive.\n*     If R is output, each element of R is a power of the radix.\n*     If R is input, each element of R should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     C       (input or output) REAL array, dimension (N)\n*     The column scale factors for A.  If EQUED = 'C' or 'B', A is\n*     multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n*     is not accessed.  C is an input argument if FACT = 'F';\n*     otherwise, C is an output argument.  If FACT = 'F' and\n*     EQUED = 'C' or 'B', each element of C must be positive.\n*     If C is output, each element of C is a power of the radix.\n*     If C is input, each element of C should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B       (input/output) REAL array, dimension (LDB,NRHS)\n*     On entry, the N-by-NRHS right hand side matrix B.\n*     On exit,\n*     if EQUED = 'N', B is not modified;\n*     if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n*        diag(R)*B;\n*     if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n*        overwritten by diag(C)*B.\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (output) REAL array, dimension (LDX,NRHS)\n*     If INFO = 0, the N-by-NRHS solution matrix X to the original\n*     system of equations.  Note that A and B are modified on exit\n*     if EQUED .ne. 'N', and the solution to the equilibrated system is\n*     inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n*     inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) REAL\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     RPVGRW  (output) REAL\n*     Reciprocal pivot growth.  On exit, this contains the reciprocal\n*     pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n*     norm is used.  If this is much less than 1, then the stability of\n*     the LU factorization of the (equilibrated) matrix A could be poor.\n*     This also means that the solution X, estimated condition numbers,\n*     and error bounds could be unreliable. If factorization fails with\n*     0 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, r, c, b, params = NumRu::Lapack.sgesvxx( fact, trans, a, af, ipiv, equed, r, c, b, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_fact = argv[0];
  rblapack_trans = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_equed = argv[5];
  rblapack_r = argv[6];
  rblapack_c = argv[7];
  rblapack_b = argv[8];
  rblapack_params = argv[9];
  if (argc == 10) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_r))
    rb_raise(rb_eArgError, "r (7th argument) must be NArray");
  if (NA_RANK(rblapack_r) != 1)
    rb_raise(rb_eArgError, "rank of r (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_r) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_r) != NA_SFLOAT)
    rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
  r = NA_PTR_TYPE(rblapack_r, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (9th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (9th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  n_err_bnds = 3;
  trans = StringValueCStr(rblapack_trans)[0];
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (10th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (10th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_SFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
  params = NA_PTR_TYPE(rblapack_params, real*);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
  af = NA_PTR_TYPE(rblapack_af, real*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (8th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  ldx = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldaf;
    shape[1] = n;
    rblapack_af_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  af_out__ = NA_PTR_TYPE(rblapack_af_out__, real*);
  MEMCPY(af_out__, af, real, NA_TOTAL(rblapack_af));
  rblapack_af = rblapack_af_out__;
  af = af_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_r_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  r_out__ = NA_PTR_TYPE(rblapack_r_out__, real*);
  MEMCPY(r_out__, r, real, NA_TOTAL(rblapack_r));
  rblapack_r = rblapack_r_out__;
  r = r_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
  MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(real, (4*n));
  iwork = ALLOC_N(integer, (n));

  sgesvxx_(&fact, &trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_rpvgrw = rb_float_new((double)rpvgrw);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(15, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_a, rblapack_af, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b, rblapack_params);
}

void
init_lapack_sgesvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgesvxx", rblapack_sgesvxx, -1);
}
ruby-lapack-1.7.2/ext/cunm2r.c0000644000175000017500000001431012502221021015723 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cunm2r_(char* side, char* trans, integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* c, integer* ldc, complex* work, integer* info);


static VALUE
rblapack_cunm2r(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_c;
  complex *c; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  complex *c_out__;
  complex *work;

  integer lda;
  integer k;
  integer ldc;
  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  info, c = NumRu::Lapack.cunm2r( side, trans, m, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CUNM2R overwrites the general complex m-by-n matrix C with\n*\n*        Q * C  if SIDE = 'L' and TRANS = 'N', or\n*\n*        Q'* C  if SIDE = 'L' and TRANS = 'C', or\n*\n*        C * Q  if SIDE = 'R' and TRANS = 'N', or\n*\n*        C * Q' if SIDE = 'R' and TRANS = 'C',\n*\n*  where Q is a complex unitary matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(1) H(2) . . . H(k)\n*\n*  as returned by CGEQRF. Q is of order m if SIDE = 'L' and of order n\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q' from the Left\n*          = 'R': apply Q or Q' from the Right\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': apply Q  (No transpose)\n*          = 'C': apply Q' (Conjugate transpose)\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,K)\n*          The i-th column must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          CGEQRF in the first k columns of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*          If SIDE = 'L', LDA >= max(1,M);\n*          if SIDE = 'R', LDA >= max(1,N).\n*\n*  TAU     (input) COMPLEX array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by CGEQRF.\n*\n*  C       (input/output) COMPLEX array, dimension (LDC,N)\n*          On entry, the m-by-n matrix C.\n*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) COMPLEX array, dimension\n*                                   (N) if SIDE = 'L',\n*                                   (M) if SIDE = 'R'\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, c = NumRu::Lapack.cunm2r( side, trans, m, a, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_m = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, complex*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != k)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
  MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(complex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  cunm2r_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_c);
}

void
init_lapack_cunm2r(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cunm2r", rblapack_cunm2r, -1);
}
ruby-lapack-1.7.2/ext/ssytf2.c0000644000175000017500000001623312502221025015761 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssytf2_(char* uplo, integer* n, real* a, integer* lda, integer* ipiv, integer* info);


static VALUE
rblapack_ssytf2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *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  ipiv, info, a = NumRu::Lapack.ssytf2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSYTF2( UPLO, N, A, LDA, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSYTF2 computes the factorization of a real symmetric matrix A using\n*  the Bunch-Kaufman diagonal pivoting method:\n*\n*     A = U*D*U'  or  A = L*D*L'\n*\n*  where U (or L) is a product of permutation and unit upper (lower)\n*  triangular matrices, U' is the transpose of U, and D is symmetric and\n*  block diagonal with 1-by-1 and 2-by-2 diagonal blocks.\n*\n*  This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored:\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          n-by-n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n-by-n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L (see below for further details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D.\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*          > 0: if INFO = k, D(k,k) is exactly zero.  The factorization\n*               has been completed, but the block diagonal matrix D is\n*               exactly singular, and division by zero will occur if it\n*               is used to solve a system of equations.\n*\n\n*  Further Details\n*  ===============\n*\n*  09-29-06 - patch from\n*    Bobby Cheng, MathWorks\n*\n*    Replace l.204 and l.372\n*         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN\n*    by\n*         IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN\n*\n*  01-01-96 - Based on modifications by\n*    J. Lewis, Boeing Computer Services Company\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*  1-96 - Based on modifications by J. Lewis, Boeing Computer Services\n*         Company\n*\n*  If UPLO = 'U', then A = U*D*U', where\n*     U = P(n)*U(n)* ... *P(k)U(k)* ...,\n*  i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n*  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    v    0   )   k-s\n*     U(k) =  (   0    I    0   )   s\n*             (   0    0    I   )   n-k\n*                k-s   s   n-k\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n*  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n*  and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n*  If UPLO = 'L', then A = L*D*L', where\n*     L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n*  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n*  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    0     0   )  k-1\n*     L(k) =  (   0    I     0   )  s\n*             (   0    v     I   )  n-k-s+1\n*                k-1   s  n-k-s+1\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n*  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n*  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, a = NumRu::Lapack.ssytf2( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  ssytf2_(&uplo, &n, a, &lda, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_a);
}

void
init_lapack_ssytf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssytf2", rblapack_ssytf2, -1);
}
ruby-lapack-1.7.2/ext/ctgsja.c0000644000175000017500000003743112502221017016006 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctgsja_(char* jobu, char* jobv, char* jobq, integer* m, integer* p, integer* n, integer* k, integer* l, complex* a, integer* lda, complex* b, integer* ldb, real* tola, real* tolb, real* alpha, real* beta, complex* u, integer* ldu, complex* v, integer* ldv, complex* q, integer* ldq, complex* work, integer* ncycle, integer* info);


static VALUE
rblapack_ctgsja(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobu;
  char jobu; 
  VALUE rblapack_jobv;
  char jobv; 
  VALUE rblapack_jobq;
  char jobq; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_tola;
  real tola; 
  VALUE rblapack_tolb;
  real tolb; 
  VALUE rblapack_u;
  complex *u; 
  VALUE rblapack_v;
  complex *v; 
  VALUE rblapack_q;
  complex *q; 
  VALUE rblapack_alpha;
  real *alpha; 
  VALUE rblapack_beta;
  real *beta; 
  VALUE rblapack_ncycle;
  integer ncycle; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;
  VALUE rblapack_u_out__;
  complex *u_out__;
  VALUE rblapack_v_out__;
  complex *v_out__;
  VALUE rblapack_q_out__;
  complex *q_out__;
  complex *work;

  integer lda;
  integer n;
  integer ldb;
  integer ldu;
  integer m;
  integer ldv;
  integer p;
  integer ldq;

  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  alpha, beta, ncycle, info, a, b, u, v, q = NumRu::Lapack.ctgsja( jobu, jobv, jobq, k, l, a, b, tola, tolb, u, v, q, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, NCYCLE, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTGSJA computes the generalized singular value decomposition (GSVD)\n*  of two complex upper triangular (or trapezoidal) matrices A and B.\n*\n*  On entry, it is assumed that matrices A and B have the following\n*  forms, which may be obtained by the preprocessing subroutine CGGSVP\n*  from a general M-by-N matrix A and P-by-N matrix B:\n*\n*               N-K-L  K    L\n*     A =    K ( 0    A12  A13 ) if M-K-L >= 0;\n*            L ( 0     0   A23 )\n*        M-K-L ( 0     0    0  )\n*\n*             N-K-L  K    L\n*     A =  K ( 0    A12  A13 ) if M-K-L < 0;\n*        M-K ( 0     0   A23 )\n*\n*             N-K-L  K    L\n*     B =  L ( 0     0   B13 )\n*        P-L ( 0     0    0  )\n*\n*  where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n*  upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n*  otherwise A23 is (M-K)-by-L upper trapezoidal.\n*\n*  On exit,\n*\n*         U'*A*Q = D1*( 0 R ),    V'*B*Q = D2*( 0 R ),\n*\n*  where U, V and Q are unitary matrices, Z' denotes the conjugate\n*  transpose of Z, R is a nonsingular upper triangular matrix, and D1\n*  and D2 are ``diagonal'' matrices, which are of the following\n*  structures:\n*\n*  If M-K-L >= 0,\n*\n*                      K  L\n*         D1 =     K ( I  0 )\n*                  L ( 0  C )\n*              M-K-L ( 0  0 )\n*\n*                     K  L\n*         D2 = L   ( 0  S )\n*              P-L ( 0  0 )\n*\n*                 N-K-L  K    L\n*    ( 0 R ) = K (  0   R11  R12 ) K\n*              L (  0    0   R22 ) L\n*\n*  where\n*\n*    C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n*    S = diag( BETA(K+1),  ... , BETA(K+L) ),\n*    C**2 + S**2 = I.\n*\n*    R is stored in A(1:K+L,N-K-L+1:N) on exit.\n*\n*  If M-K-L < 0,\n*\n*                 K M-K K+L-M\n*      D1 =   K ( I  0    0   )\n*           M-K ( 0  C    0   )\n*\n*                   K M-K K+L-M\n*      D2 =   M-K ( 0  S    0   )\n*           K+L-M ( 0  0    I   )\n*             P-L ( 0  0    0   )\n*\n*                 N-K-L  K   M-K  K+L-M\n* ( 0 R ) =    K ( 0    R11  R12  R13  )\n*            M-K ( 0     0   R22  R23  )\n*          K+L-M ( 0     0    0   R33  )\n*\n*  where\n*  C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n*  S = diag( BETA(K+1),  ... , BETA(M) ),\n*  C**2 + S**2 = I.\n*\n*  R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored\n*      (  0  R22 R23 )\n*  in B(M-K+1:L,N+M-K-L+1:N) on exit.\n*\n*  The computation of the unitary transformation matrices U, V or Q\n*  is optional.  These matrices may either be formed explicitly, or they\n*  may be postmultiplied into input matrices U1, V1, or Q1.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBU    (input) CHARACTER*1\n*          = 'U':  U must contain a unitary matrix U1 on entry, and\n*                  the product U1*U is returned;\n*          = 'I':  U is initialized to the unit matrix, and the\n*                  unitary matrix U is returned;\n*          = 'N':  U is not computed.\n*\n*  JOBV    (input) CHARACTER*1\n*          = 'V':  V must contain a unitary matrix V1 on entry, and\n*                  the product V1*V is returned;\n*          = 'I':  V is initialized to the unit matrix, and the\n*                  unitary matrix V is returned;\n*          = 'N':  V is not computed.\n*\n*  JOBQ    (input) CHARACTER*1\n*          = 'Q':  Q must contain a unitary matrix Q1 on entry, and\n*                  the product Q1*Q is returned;\n*          = 'I':  Q is initialized to the unit matrix, and the\n*                  unitary matrix Q is returned;\n*          = 'N':  Q is not computed.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.  M >= 0.\n*\n*  P       (input) INTEGER\n*          The number of rows of the matrix B.  P >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrices A and B.  N >= 0.\n*\n*  K       (input) INTEGER\n*  L       (input) INTEGER\n*          K and L specify the subblocks in the input matrices A and B:\n*          A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,,N-L+1:N)\n*          of A and B, whose GSVD is going to be computed by CTGSJA.\n*          See Further Details.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular\n*          matrix R or part of R.  See Purpose for details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,N)\n*          On entry, the P-by-N matrix B.\n*          On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains\n*          a part of R.  See Purpose for details.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,P).\n*\n*  TOLA    (input) REAL\n*  TOLB    (input) REAL\n*          TOLA and TOLB are the convergence criteria for the Jacobi-\n*          Kogbetliantz iteration procedure. Generally, they are the\n*          same as used in the preprocessing step, say\n*              TOLA = MAX(M,N)*norm(A)*MACHEPS,\n*              TOLB = MAX(P,N)*norm(B)*MACHEPS.\n*\n*  ALPHA   (output) REAL array, dimension (N)\n*  BETA    (output) REAL array, dimension (N)\n*          On exit, ALPHA and BETA contain the generalized singular\n*          value pairs of A and B;\n*            ALPHA(1:K) = 1,\n*            BETA(1:K)  = 0,\n*          and if M-K-L >= 0,\n*            ALPHA(K+1:K+L) = diag(C),\n*            BETA(K+1:K+L)  = diag(S),\n*          or if M-K-L < 0,\n*            ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0\n*            BETA(K+1:M) = S, BETA(M+1:K+L) = 1.\n*          Furthermore, if K+L < N,\n*            ALPHA(K+L+1:N) = 0\n*            BETA(K+L+1:N)  = 0.\n*\n*  U       (input/output) COMPLEX array, dimension (LDU,M)\n*          On entry, if JOBU = 'U', U must contain a matrix U1 (usually\n*          the unitary matrix returned by CGGSVP).\n*          On exit,\n*          if JOBU = 'I', U contains the unitary matrix U;\n*          if JOBU = 'U', U contains the product U1*U.\n*          If JOBU = 'N', U is not referenced.\n*\n*  LDU     (input) INTEGER\n*          The leading dimension of the array U. LDU >= max(1,M) if\n*          JOBU = 'U'; LDU >= 1 otherwise.\n*\n*  V       (input/output) COMPLEX array, dimension (LDV,P)\n*          On entry, if JOBV = 'V', V must contain a matrix V1 (usually\n*          the unitary matrix returned by CGGSVP).\n*          On exit,\n*          if JOBV = 'I', V contains the unitary matrix V;\n*          if JOBV = 'V', V contains the product V1*V.\n*          If JOBV = 'N', V is not referenced.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V. LDV >= max(1,P) if\n*          JOBV = 'V'; LDV >= 1 otherwise.\n*\n*  Q       (input/output) COMPLEX array, dimension (LDQ,N)\n*          On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually\n*          the unitary matrix returned by CGGSVP).\n*          On exit,\n*          if JOBQ = 'I', Q contains the unitary matrix Q;\n*          if JOBQ = 'Q', Q contains the product Q1*Q.\n*          If JOBQ = 'N', Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q. LDQ >= max(1,N) if\n*          JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  NCYCLE  (output) INTEGER\n*          The number of cycles required for convergence.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          = 1:  the procedure does not converge after MAXIT cycles.\n*\n*  Internal Parameters\n*  ===================\n*\n*  MAXIT   INTEGER\n*          MAXIT specifies the total loops that the iterative procedure\n*          may take. If after MAXIT cycles, the routine fails to\n*          converge, we return INFO = 1.\n*\n\n*  Further Details\n*  ===============\n*\n*  CTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce\n*  min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L\n*  matrix B13 to the form:\n*\n*           U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1,\n*\n*  where U1, V1 and Q1 are unitary matrix, and Z' is the conjugate\n*  transpose of Z.  C1 and S1 are diagonal matrices satisfying\n*\n*                C1**2 + S1**2 = I,\n*\n*  and R1 is an L-by-L nonsingular upper triangular matrix.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  alpha, beta, ncycle, info, a, b, u, v, q = NumRu::Lapack.ctgsja( jobu, jobv, jobq, k, l, a, b, tola, tolb, u, v, q, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_jobu = argv[0];
  rblapack_jobv = argv[1];
  rblapack_jobq = argv[2];
  rblapack_k = argv[3];
  rblapack_l = argv[4];
  rblapack_a = argv[5];
  rblapack_b = argv[6];
  rblapack_tola = argv[7];
  rblapack_tolb = argv[8];
  rblapack_u = argv[9];
  rblapack_v = argv[10];
  rblapack_q = argv[11];
  if (argc == 12) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobu = StringValueCStr(rblapack_jobu)[0];
  jobq = StringValueCStr(rblapack_jobq)[0];
  l = NUM2INT(rblapack_l);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  tolb = (real)NUM2DBL(rblapack_tolb);
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (11th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (11th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  p = NA_SHAPE1(rblapack_v);
  if (NA_TYPE(rblapack_v) != NA_SCOMPLEX)
    rblapack_v = na_change_type(rblapack_v, NA_SCOMPLEX);
  v = NA_PTR_TYPE(rblapack_v, complex*);
  jobv = StringValueCStr(rblapack_jobv)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (6th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (6th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_u))
    rb_raise(rb_eArgError, "u (10th argument) must be NArray");
  if (NA_RANK(rblapack_u) != 2)
    rb_raise(rb_eArgError, "rank of u (10th argument) must be %d", 2);
  ldu = NA_SHAPE0(rblapack_u);
  m = NA_SHAPE1(rblapack_u);
  if (NA_TYPE(rblapack_u) != NA_SCOMPLEX)
    rblapack_u = na_change_type(rblapack_u, NA_SCOMPLEX);
  u = NA_PTR_TYPE(rblapack_u, complex*);
  k = NUM2INT(rblapack_k);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (12th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (12th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_q) != NA_SCOMPLEX)
    rblapack_q = na_change_type(rblapack_q, NA_SCOMPLEX);
  q = NA_PTR_TYPE(rblapack_q, complex*);
  tola = (real)NUM2DBL(rblapack_tola);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alpha = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  alpha = NA_PTR_TYPE(rblapack_alpha, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = m;
    rblapack_u_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  u_out__ = NA_PTR_TYPE(rblapack_u_out__, complex*);
  MEMCPY(u_out__, u, complex, NA_TOTAL(rblapack_u));
  rblapack_u = rblapack_u_out__;
  u = u_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = p;
    rblapack_v_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  v_out__ = NA_PTR_TYPE(rblapack_v_out__, complex*);
  MEMCPY(v_out__, v, complex, NA_TOTAL(rblapack_v));
  rblapack_v = rblapack_v_out__;
  v = v_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, complex*);
  MEMCPY(q_out__, q, complex, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  work = ALLOC_N(complex, (2*n));

  ctgsja_(&jobu, &jobv, &jobq, &m, &p, &n, &k, &l, a, &lda, b, &ldb, &tola, &tolb, alpha, beta, u, &ldu, v, &ldv, q, &ldq, work, &ncycle, &info);

  free(work);
  rblapack_ncycle = INT2NUM(ncycle);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_alpha, rblapack_beta, rblapack_ncycle, rblapack_info, rblapack_a, rblapack_b, rblapack_u, rblapack_v, rblapack_q);
}

void
init_lapack_ctgsja(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctgsja", rblapack_ctgsja, -1);
}
ruby-lapack-1.7.2/ext/cla_wwaddw.c0000644000175000017500000001022112502221023016630 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cla_wwaddw_(integer* n, complex* x, complex* y, complex* w);


static VALUE
rblapack_cla_wwaddw(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_y;
  complex *y; 
  VALUE rblapack_w;
  complex *w; 
  VALUE rblapack_x_out__;
  complex *x_out__;
  VALUE rblapack_y_out__;
  complex *y_out__;

  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  x, y = NumRu::Lapack.cla_wwaddw( x, y, w, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLA_WWADDW( N, X, Y, W )\n\n*     Purpose\n*     =======\n*\n*     CLA_WWADDW adds a vector W into a doubled-single vector (X, Y).\n*\n*     This works for all extant IBM's hex and binary floating point\n*     arithmetics, but not for decimal.\n*\n\n*     Arguments\n*     =========\n*\n*     N      (input) INTEGER\n*            The length of vectors X, Y, and W.\n*\n*     X      (input/output) COMPLEX array, dimension (N)\n*            The first part of the doubled-single accumulation vector.\n*\n*     Y      (input/output) COMPLEX array, dimension (N)\n*            The second part of the doubled-single accumulation vector.\n*\n*     W      (input) COMPLEX array, dimension (N)\n*            The vector to be added.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      COMPLEX            S\n      INTEGER            I\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, y = NumRu::Lapack.cla_wwaddw( x, y, w, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_x = argv[0];
  rblapack_y = argv[1];
  rblapack_w = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (1th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  if (!NA_IsNArray(rblapack_w))
    rb_raise(rb_eArgError, "w (3th argument) must be NArray");
  if (NA_RANK(rblapack_w) != 1)
    rb_raise(rb_eArgError, "rank of w (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_w) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of x");
  if (NA_TYPE(rblapack_w) != NA_SCOMPLEX)
    rblapack_w = na_change_type(rblapack_w, NA_SCOMPLEX);
  w = NA_PTR_TYPE(rblapack_w, complex*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (2th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of y must be the same as shape 0 of x");
  if (NA_TYPE(rblapack_y) != NA_SCOMPLEX)
    rblapack_y = na_change_type(rblapack_y, NA_SCOMPLEX);
  y = NA_PTR_TYPE(rblapack_y, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_y_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, complex*);
  MEMCPY(y_out__, y, complex, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  cla_wwaddw_(&n, x, y, w);

  return rb_ary_new3(2, rblapack_x, rblapack_y);
}

void
init_lapack_cla_wwaddw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cla_wwaddw", rblapack_cla_wwaddw, -1);
}
ruby-lapack-1.7.2/ext/sgbbrd.c0000644000175000017500000001717312502221017015777 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgbbrd_(char* vect, integer* m, integer* n, integer* ncc, integer* kl, integer* ku, real* ab, integer* ldab, real* d, real* e, real* q, integer* ldq, real* pt, integer* ldpt, real* c, integer* ldc, real* work, integer* info);


static VALUE
rblapack_sgbbrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_vect;
  char vect; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_q;
  real *q; 
  VALUE rblapack_pt;
  real *pt; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  real *ab_out__;
  VALUE rblapack_c_out__;
  real *c_out__;
  real *work;

  integer ldab;
  integer n;
  integer ldc;
  integer ncc;
  integer ldq;
  integer m;
  integer ldpt;

  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  d, e, q, pt, info, ab, c = NumRu::Lapack.sgbbrd( vect, kl, ku, ab, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, LDQ, PT, LDPT, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGBBRD reduces a real general m-by-n band matrix A to upper\n*  bidiagonal form B by an orthogonal transformation: Q' * A * P = B.\n*\n*  The routine computes B, and optionally forms Q or P', or computes\n*  Q'*C for a given matrix C.\n*\n\n*  Arguments\n*  =========\n*\n*  VECT    (input) CHARACTER*1\n*          Specifies whether or not the matrices Q and P' are to be\n*          formed.\n*          = 'N': do not form Q or P';\n*          = 'Q': form Q only;\n*          = 'P': form P' only;\n*          = 'B': form both.\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*  NCC     (input) INTEGER\n*          The number of columns of the matrix C.  NCC >= 0.\n*\n*  KL      (input) INTEGER\n*          The number of subdiagonals of the matrix A. KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals of the matrix A. KU >= 0.\n*\n*  AB      (input/output) REAL array, dimension (LDAB,N)\n*          On entry, the m-by-n band matrix A, stored in rows 1 to\n*          KL+KU+1. The j-th column of A is stored in the j-th column of\n*          the array AB as follows:\n*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).\n*          On exit, A is overwritten by values generated during the\n*          reduction.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array A. LDAB >= KL+KU+1.\n*\n*  D       (output) REAL array, dimension (min(M,N))\n*          The diagonal elements of the bidiagonal matrix B.\n*\n*  E       (output) REAL array, dimension (min(M,N)-1)\n*          The superdiagonal elements of the bidiagonal matrix B.\n*\n*  Q       (output) REAL array, dimension (LDQ,M)\n*          If VECT = 'Q' or 'B', the m-by-m orthogonal matrix Q.\n*          If VECT = 'N' or 'P', the array Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.\n*          LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.\n*\n*  PT      (output) REAL array, dimension (LDPT,N)\n*          If VECT = 'P' or 'B', the n-by-n orthogonal matrix P'.\n*          If VECT = 'N' or 'Q', the array PT is not referenced.\n*\n*  LDPT    (input) INTEGER\n*          The leading dimension of the array PT.\n*          LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.\n*\n*  C       (input/output) REAL array, dimension (LDC,NCC)\n*          On entry, an m-by-ncc matrix C.\n*          On exit, C is overwritten by Q'*C.\n*          C is not referenced if NCC = 0.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C.\n*          LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.\n*\n*  WORK    (workspace) REAL array, dimension (2*max(M,N))\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, q, pt, info, ab, c = NumRu::Lapack.sgbbrd( vect, kl, ku, ab, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_vect = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  rblapack_c = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  vect = StringValueCStr(rblapack_vect)[0];
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  ncc = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  ldpt = ((lsame_(&vect,"P")) || (lsame_(&vect,"B"))) ? MAX(1,n) : 1;
  m = ldab;
  ldq = ((lsame_(&vect,"Q")) || (lsame_(&vect,"B"))) ? MAX(1,m) : 1;
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, real*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n)-1;
    rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = m;
    rblapack_q = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  q = NA_PTR_TYPE(rblapack_q, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldpt;
    shape[1] = n;
    rblapack_pt = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  pt = NA_PTR_TYPE(rblapack_pt, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
  MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = ncc;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(real, (2*MAX(m,n)));

  sgbbrd_(&vect, &m, &n, &ncc, &kl, &ku, ab, &ldab, d, e, q, &ldq, pt, &ldpt, c, &ldc, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_d, rblapack_e, rblapack_q, rblapack_pt, rblapack_info, rblapack_ab, rblapack_c);
}

void
init_lapack_sgbbrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgbbrd", rblapack_sgbbrd, -1);
}
ruby-lapack-1.7.2/ext/dlaed6.c0000644000175000017500000001223612502221025015665 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaed6_(integer* kniter, logical* orgati, doublereal* rho, doublereal* d, doublereal* z, doublereal* finit, doublereal* tau, integer* info);


static VALUE
rblapack_dlaed6(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_kniter;
  integer kniter; 
  VALUE rblapack_orgati;
  logical orgati; 
  VALUE rblapack_rho;
  doublereal rho; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_finit;
  doublereal finit; 
  VALUE rblapack_tau;
  doublereal tau; 
  VALUE rblapack_info;
  integer info; 


  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 = NumRu::Lapack.dlaed6( kniter, orgati, rho, d, z, finit, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLAED6 computes the positive or negative root (closest to the origin)\n*  of\n*                   z(1)        z(2)        z(3)\n*  f(x) =   rho + --------- + ---------- + ---------\n*                  d(1)-x      d(2)-x      d(3)-x\n*\n*  It is assumed that\n*\n*        if ORGATI = .true. the root is between d(2) and d(3);\n*        otherwise it is between d(1) and d(2)\n*\n*  This routine will be called by DLAED4 when necessary. In most cases,\n*  the root sought is the smallest in magnitude, though it might not be\n*  in some extremely rare situations.\n*\n\n*  Arguments\n*  =========\n*\n*  KNITER       (input) INTEGER\n*               Refer to DLAED4 for its significance.\n*\n*  ORGATI       (input) LOGICAL\n*               If ORGATI is true, the needed root is between d(2) and\n*               d(3); otherwise it is between d(1) and d(2).  See\n*               DLAED4 for further details.\n*\n*  RHO          (input) DOUBLE PRECISION\n*               Refer to the equation f(x) above.\n*\n*  D            (input) DOUBLE PRECISION array, dimension (3)\n*               D satisfies d(1) < d(2) < d(3).\n*\n*  Z            (input) DOUBLE PRECISION array, dimension (3)\n*               Each of the elements in z must be positive.\n*\n*  FINIT        (input) DOUBLE PRECISION\n*               The value of f at 0. It is more accurate than the one\n*               evaluated inside this routine (if someone wants to do\n*               so).\n*\n*  TAU          (output) DOUBLE PRECISION\n*               The root of the equation f(x).\n*\n*  INFO         (output) INTEGER\n*               = 0: successful exit\n*               > 0: if INFO = 1, failure to converge\n*\n\n*  Further Details\n*  ===============\n*\n*  30/06/99: Based on contributions by\n*     Ren-Cang Li, Computer Science Division, University of California\n*     at Berkeley, USA\n*\n*  10/02/03: This version has a few statements commented out for thread\n*  safety (machine parameters are computed on each entry). SJH.\n*\n*  05/10/06: Modified from a new version of Ren-Cang Li, use\n*     Gragg-Thornton-Warner cubic convergent scheme for better stability.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, info = NumRu::Lapack.dlaed6( kniter, orgati, rho, d, z, finit, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_kniter = argv[0];
  rblapack_orgati = argv[1];
  rblapack_rho = argv[2];
  rblapack_d = argv[3];
  rblapack_z = argv[4];
  rblapack_finit = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  kniter = NUM2INT(rblapack_kniter);
  rho = NUM2DBL(rblapack_rho);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (5th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != (3))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 3);
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  orgati = (rblapack_orgati == Qtrue);
  finit = NUM2DBL(rblapack_finit);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != (3))
    rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", 3);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);

  dlaed6_(&kniter, &orgati, &rho, d, z, &finit, &tau, &info);

  rblapack_tau = rb_float_new((double)tau);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_tau, rblapack_info);
}

void
init_lapack_dlaed6(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaed6", rblapack_dlaed6, -1);
}
ruby-lapack-1.7.2/ext/sorgr2.c0000644000175000017500000001017612502221014015743 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sorgr2_(integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* work, integer* info);


static VALUE
rblapack_sorgr2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  real *work;

  integer lda;
  integer n;
  integer k;
  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  info, a = NumRu::Lapack.sorgr2( a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SORGR2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SORGR2 generates an m by n real matrix Q with orthonormal rows,\n*  which is defined as the last m rows of a product of k elementary\n*  reflectors of order n\n*\n*        Q  =  H(1) H(2) . . . H(k)\n*\n*  as returned by SGERQF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. N >= M.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. M >= K >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the (m-k+i)-th row must contain the vector which\n*          defines the elementary reflector H(i), for i = 1,2,...,k, as\n*          returned by SGERQF in the last k rows of its array argument\n*          A.\n*          On exit, the m by n matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) REAL array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by SGERQF.\n*\n*  WORK    (workspace) REAL array, dimension (M)\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -i, the i-th argument has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.sorgr2( a, tau, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_a = argv[0];
  rblapack_tau = argv[1];
  if (argc == 2) {
  } 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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  m = lda;
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (2th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (2th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(real, (m));

  sorgr2_(&m, &n, &k, a, &lda, tau, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_sorgr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sorgr2", rblapack_sorgr2, -1);
}
ruby-lapack-1.7.2/ext/ctgsyl.c0000644000175000017500000003324012502221024016030 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctgsyl_(char* trans, integer* ijob, integer* m, integer* n, complex* a, integer* lda, complex* b, integer* ldb, complex* c, integer* ldc, complex* d, integer* ldd, complex* e, integer* lde, complex* f, integer* ldf, real* scale, real* dif, complex* work, integer* lwork, integer* iwork, integer* info);


static VALUE
rblapack_ctgsyl(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_ijob;
  integer ijob; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_c;
  complex *c; 
  VALUE rblapack_d;
  complex *d; 
  VALUE rblapack_e;
  complex *e; 
  VALUE rblapack_f;
  complex *f; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_scale;
  real scale; 
  VALUE rblapack_dif;
  real dif; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  complex *c_out__;
  VALUE rblapack_f_out__;
  complex *f_out__;
  integer *iwork;

  integer lda;
  integer m;
  integer ldb;
  integer n;
  integer ldc;
  integer ldd;
  integer lde;
  integer ldf;

  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  scale, dif, work, info, c, f = NumRu::Lapack.ctgsyl( trans, ijob, a, b, c, d, e, f, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTGSYL solves the generalized Sylvester equation:\n*\n*              A * R - L * B = scale * C            (1)\n*              D * R - L * E = scale * F\n*\n*  where R and L are unknown m-by-n matrices, (A, D), (B, E) and\n*  (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n,\n*  respectively, with complex entries. A, B, D and E are upper\n*  triangular (i.e., (A,D) and (B,E) in generalized Schur form).\n*\n*  The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1\n*  is an output scaling factor chosen to avoid overflow.\n*\n*  In matrix notation (1) is equivalent to solve Zx = scale*b, where Z\n*  is defined as\n*\n*         Z = [ kron(In, A)  -kron(B', Im) ]        (2)\n*             [ kron(In, D)  -kron(E', Im) ],\n*\n*  Here Ix is the identity matrix of size x and X' is the conjugate\n*  transpose of X. Kron(X, Y) is the Kronecker product between the\n*  matrices X and Y.\n*\n*  If TRANS = 'C', y in the conjugate transposed system Z'*y = scale*b\n*  is solved for, which is equivalent to solve for R and L in\n*\n*              A' * R + D' * L = scale * C           (3)\n*              R * B' + L * E' = scale * -F\n*\n*  This case (TRANS = 'C') is used to compute an one-norm-based estimate\n*  of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D)\n*  and (B,E), using CLACON.\n*\n*  If IJOB >= 1, CTGSYL computes a Frobenius norm-based estimate of\n*  Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the\n*  reciprocal of the smallest singular value of Z.\n*\n*  This is a level-3 BLAS algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': solve the generalized sylvester equation (1).\n*          = 'C': solve the \"conjugate transposed\" system (3).\n*\n*  IJOB    (input) INTEGER\n*          Specifies what kind of functionality to be performed.\n*          =0: solve (1) only.\n*          =1: The functionality of 0 and 3.\n*          =2: The functionality of 0 and 4.\n*          =3: Only an estimate of Dif[(A,D), (B,E)] is computed.\n*              (look ahead strategy is used).\n*          =4: Only an estimate of Dif[(A,D), (B,E)] is computed.\n*              (CGECON on sub-systems is used).\n*          Not referenced if TRANS = 'C'.\n*\n*  M       (input) INTEGER\n*          The order of the matrices A and D, and the row dimension of\n*          the matrices C, F, R and L.\n*\n*  N       (input) INTEGER\n*          The order of the matrices B and E, and the column dimension\n*          of the matrices C, F, R and L.\n*\n*  A       (input) COMPLEX array, dimension (LDA, M)\n*          The upper triangular matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1, M).\n*\n*  B       (input) COMPLEX array, dimension (LDB, N)\n*          The upper triangular matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1, N).\n*\n*  C       (input/output) COMPLEX array, dimension (LDC, N)\n*          On entry, C contains the right-hand-side of the first matrix\n*          equation in (1) or (3).\n*          On exit, if IJOB = 0, 1 or 2, C has been overwritten by\n*          the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R,\n*          the solution achieved during the computation of the\n*          Dif-estimate.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1, M).\n*\n*  D       (input) COMPLEX array, dimension (LDD, M)\n*          The upper triangular matrix D.\n*\n*  LDD     (input) INTEGER\n*          The leading dimension of the array D. LDD >= max(1, M).\n*\n*  E       (input) COMPLEX array, dimension (LDE, N)\n*          The upper triangular matrix E.\n*\n*  LDE     (input) INTEGER\n*          The leading dimension of the array E. LDE >= max(1, N).\n*\n*  F       (input/output) COMPLEX array, dimension (LDF, N)\n*          On entry, F contains the right-hand-side of the second matrix\n*          equation in (1) or (3).\n*          On exit, if IJOB = 0, 1 or 2, F has been overwritten by\n*          the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L,\n*          the solution achieved during the computation of the\n*          Dif-estimate.\n*\n*  LDF     (input) INTEGER\n*          The leading dimension of the array F. LDF >= max(1, M).\n*\n*  DIF     (output) REAL\n*          On exit DIF is the reciprocal of a lower bound of the\n*          reciprocal of the Dif-function, i.e. DIF is an upper bound of\n*          Dif[(A,D), (B,E)] = sigma-min(Z), where Z as in (2).\n*          IF IJOB = 0 or TRANS = 'C', DIF is not referenced.\n*\n*  SCALE   (output) REAL\n*          On exit SCALE is the scaling factor in (1) or (3).\n*          If 0 < SCALE < 1, C and F hold the solutions R and L, resp.,\n*          to a slightly perturbed system but the input matrices A, B,\n*          D and E have not been changed. If SCALE = 0, R and L will\n*          hold the solutions to the homogenious system with C = F = 0.\n*\n*  WORK    (workspace/output) COMPLEX 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 > = 1.\n*          If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N).\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*  IWORK   (workspace) INTEGER array, dimension (M+N+2)\n*\n*  INFO    (output) INTEGER\n*            =0: successful exit\n*            <0: If INFO = -i, the i-th argument had an illegal value.\n*            >0: (A, D) and (B, E) have common or very close\n*                eigenvalues.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n*      for Solving the Generalized Sylvester Equation and Estimating the\n*      Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n*      Department of Computing Science, Umea University, S-901 87 Umea,\n*      Sweden, December 1993, Revised April 1994, Also as LAPACK Working\n*      Note 75.  To appear in ACM Trans. on Math. Software, Vol 22,\n*      No 1, 1996.\n*\n*  [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester\n*      Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal.\n*      Appl., 15(4):1045-1060, 1994.\n*\n*  [3] B. Kagstrom and L. Westin, Generalized Schur Methods with\n*      Condition Estimators for Solving the Generalized Sylvester\n*      Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7,\n*      July 1989, pp 745-751.\n*\n*  =====================================================================\n*  Replaced various illegal calls to CCOPY by calls to CLASET.\n*  Sven Hammarling, 1/5/02.\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, dif, work, info, c, f = NumRu::Lapack.ctgsyl( trans, ijob, a, b, c, d, e, f, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_trans = argv[0];
  rblapack_ijob = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  rblapack_c = argv[4];
  rblapack_d = argv[5];
  rblapack_e = argv[6];
  rblapack_f = argv[7];
  if (argc == 9) {
    rblapack_lwork = argv[8];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, complex*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (7th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 2)
    rb_raise(rb_eArgError, "rank of e (7th argument) must be %d", 2);
  lde = NA_SHAPE0(rblapack_e);
  if (NA_SHAPE1(rblapack_e) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of e must be the same as shape 1 of c");
  if (NA_TYPE(rblapack_e) != NA_SCOMPLEX)
    rblapack_e = na_change_type(rblapack_e, NA_SCOMPLEX);
  e = NA_PTR_TYPE(rblapack_e, complex*);
  ijob = NUM2INT(rblapack_ijob);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (6th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 2)
    rb_raise(rb_eArgError, "rank of d (6th argument) must be %d", 2);
  ldd = NA_SHAPE0(rblapack_d);
  if (NA_SHAPE1(rblapack_d) != m)
    rb_raise(rb_eRuntimeError, "shape 1 of d must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_d) != NA_SCOMPLEX)
    rblapack_d = na_change_type(rblapack_d, NA_SCOMPLEX);
  d = NA_PTR_TYPE(rblapack_d, complex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of c");
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (!NA_IsNArray(rblapack_f))
    rb_raise(rb_eArgError, "f (8th argument) must be NArray");
  if (NA_RANK(rblapack_f) != 2)
    rb_raise(rb_eArgError, "rank of f (8th argument) must be %d", 2);
  ldf = NA_SHAPE0(rblapack_f);
  if (NA_SHAPE1(rblapack_f) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of f must be the same as shape 1 of c");
  if (NA_TYPE(rblapack_f) != NA_SCOMPLEX)
    rblapack_f = na_change_type(rblapack_f, NA_SCOMPLEX);
  f = NA_PTR_TYPE(rblapack_f, complex*);
  if (rblapack_lwork == Qnil)
    lwork = ((ijob==1||ijob==2)&&lsame_(&trans,"N")) ? 2*m*n : 1;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
  MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldf;
    shape[1] = n;
    rblapack_f_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  f_out__ = NA_PTR_TYPE(rblapack_f_out__, complex*);
  MEMCPY(f_out__, f, complex, NA_TOTAL(rblapack_f));
  rblapack_f = rblapack_f_out__;
  f = f_out__;
  iwork = ALLOC_N(integer, (m+n+2));

  ctgsyl_(&trans, &ijob, &m, &n, a, &lda, b, &ldb, c, &ldc, d, &ldd, e, &lde, f, &ldf, &scale, &dif, work, &lwork, iwork, &info);

  free(iwork);
  rblapack_scale = rb_float_new((double)scale);
  rblapack_dif = rb_float_new((double)dif);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_scale, rblapack_dif, rblapack_work, rblapack_info, rblapack_c, rblapack_f);
}

void
init_lapack_ctgsyl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctgsyl", rblapack_ctgsyl, -1);
}
ruby-lapack-1.7.2/ext/zgges.c0000644000175000017500000003156012502221022015643 0ustar  uwabamiuwabami#include "rb_lapack.h"

static logical
rblapack_selctg(doublecomplex *arg0, doublecomplex *arg1){
  VALUE rblapack_arg0, rblapack_arg1;

  VALUE rblapack_ret;
  logical ret;

  rblapack_arg0 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg0->r)), rb_float_new((double)(arg0->i)));
  rblapack_arg1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg1->r)), rb_float_new((double)(arg1->i)));

  rblapack_ret = rb_yield_values(2, rblapack_arg0, rblapack_arg1);

  ret = (rblapack_ret == Qtrue);
  return ret;
}

extern VOID zgges_(char* jobvsl, char* jobvsr, char* sort, L_fp selctg, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, integer* sdim, doublecomplex* alpha, doublecomplex* beta, doublecomplex* vsl, integer* ldvsl, doublecomplex* vsr, integer* ldvsr, doublecomplex* work, integer* lwork, doublereal* rwork, logical* bwork, integer* info);


static VALUE
rblapack_zgges(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvsl;
  char jobvsl; 
  VALUE rblapack_jobvsr;
  char jobvsr; 
  VALUE rblapack_sort;
  char sort; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_sdim;
  integer sdim; 
  VALUE rblapack_alpha;
  doublecomplex *alpha; 
  VALUE rblapack_beta;
  doublecomplex *beta; 
  VALUE rblapack_vsl;
  doublecomplex *vsl; 
  VALUE rblapack_vsr;
  doublecomplex *vsr; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  doublereal *rwork;
  logical *bwork;

  integer lda;
  integer n;
  integer ldb;
  integer ldvsl;
  integer ldvsr;

  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  sdim, alpha, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.zgges( jobvsl, jobvsr, sort, a, b, [:lwork => lwork, :usage => usage, :help => help]){|a,b| ... }\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB, SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, BWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGGES computes for a pair of N-by-N complex nonsymmetric matrices\n*  (A,B), the generalized eigenvalues, the generalized complex Schur\n*  form (S, T), and optionally left and/or right Schur vectors (VSL\n*  and VSR). This gives the generalized Schur factorization\n*\n*          (A,B) = ( (VSL)*S*(VSR)**H, (VSL)*T*(VSR)**H )\n*\n*  where (VSR)**H is the conjugate-transpose of VSR.\n*\n*  Optionally, it also orders the eigenvalues so that a selected cluster\n*  of eigenvalues appears in the leading diagonal blocks of the upper\n*  triangular matrix S and the upper triangular matrix T. The leading\n*  columns of VSL and VSR then form an unitary basis for the\n*  corresponding left and right eigenspaces (deflating subspaces).\n*\n*  (If only the generalized eigenvalues are needed, use the driver\n*  ZGGEV instead, which is faster.)\n*\n*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n*  or a ratio alpha/beta = w, such that  A - w*B is singular.  It is\n*  usually represented as the pair (alpha,beta), as there is a\n*  reasonable interpretation for beta=0, and even for both being zero.\n*\n*  A pair of matrices (S,T) is in generalized complex Schur form if S\n*  and T are upper triangular and, in addition, the diagonal elements\n*  of T are non-negative real numbers.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVSL  (input) CHARACTER*1\n*          = 'N':  do not compute the left Schur vectors;\n*          = 'V':  compute the left Schur vectors.\n*\n*  JOBVSR  (input) CHARACTER*1\n*          = 'N':  do not compute the right Schur vectors;\n*          = 'V':  compute the right Schur vectors.\n*\n*  SORT    (input) CHARACTER*1\n*          Specifies whether or not to order the eigenvalues on the\n*          diagonal of the generalized Schur form.\n*          = 'N':  Eigenvalues are not ordered;\n*          = 'S':  Eigenvalues are ordered (see SELCTG).\n*\n*  SELCTG  (external procedure) LOGICAL FUNCTION of two COMPLEX*16 arguments\n*          SELCTG must be declared EXTERNAL in the calling subroutine.\n*          If SORT = 'N', SELCTG is not referenced.\n*          If SORT = 'S', SELCTG is used to select eigenvalues to sort\n*          to the top left of the Schur form.\n*          An eigenvalue ALPHA(j)/BETA(j) is selected if\n*          SELCTG(ALPHA(j),BETA(j)) is true.\n*\n*          Note that a selected complex eigenvalue may no longer satisfy\n*          SELCTG(ALPHA(j),BETA(j)) = .TRUE. after ordering, since\n*          ordering may change the value of complex eigenvalues\n*          (especially if the eigenvalue is ill-conditioned), in this\n*          case INFO is set to N+2 (See INFO below).\n*\n*  N       (input) INTEGER\n*          The order of the matrices A, B, VSL, and VSR.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA, N)\n*          On entry, the first of the pair of matrices.\n*          On exit, A has been overwritten by its generalized Schur\n*          form S.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of A.  LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB, N)\n*          On entry, the second of the pair of matrices.\n*          On exit, B has been overwritten by its generalized Schur\n*          form T.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of B.  LDB >= max(1,N).\n*\n*  SDIM    (output) INTEGER\n*          If SORT = 'N', SDIM = 0.\n*          If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n*          for which SELCTG is true.\n*\n*  ALPHA   (output) COMPLEX*16 array, dimension (N)\n*  BETA    (output) COMPLEX*16 array, dimension (N)\n*          On exit,  ALPHA(j)/BETA(j), j=1,...,N, will be the\n*          generalized eigenvalues.  ALPHA(j), j=1,...,N  and  BETA(j),\n*          j=1,...,N  are the diagonals of the complex Schur form (A,B)\n*          output by ZGGES. The  BETA(j) will be non-negative real.\n*\n*          Note: the quotients ALPHA(j)/BETA(j) may easily over- or\n*          underflow, and BETA(j) may even be zero.  Thus, the user\n*          should avoid naively computing the ratio alpha/beta.\n*          However, ALPHA will be always less than and usually\n*          comparable with norm(A) in magnitude, and BETA always less\n*          than and usually comparable with norm(B).\n*\n*  VSL     (output) COMPLEX*16 array, dimension (LDVSL,N)\n*          If JOBVSL = 'V', VSL will contain the left Schur vectors.\n*          Not referenced if JOBVSL = 'N'.\n*\n*  LDVSL   (input) INTEGER\n*          The leading dimension of the matrix VSL. LDVSL >= 1, and\n*          if JOBVSL = 'V', LDVSL >= N.\n*\n*  VSR     (output) COMPLEX*16 array, dimension (LDVSR,N)\n*          If JOBVSR = 'V', VSR will contain the right Schur vectors.\n*          Not referenced if JOBVSR = 'N'.\n*\n*  LDVSR   (input) INTEGER\n*          The leading dimension of the matrix VSR. LDVSR >= 1, and\n*          if JOBVSR = 'V', LDVSR >= N.\n*\n*  WORK    (workspace/output) COMPLEX*16 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,2*N).\n*          For good performance, LWORK must generally be larger.\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*  RWORK   (workspace) DOUBLE PRECISION array, dimension (8*N)\n*\n*  BWORK   (workspace) LOGICAL array, dimension (N)\n*          Not referenced if SORT = 'N'.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          =1,...,N:\n*                The QZ iteration failed.  (A,B) are not in Schur\n*                form, but ALPHA(j) and BETA(j) should be correct for\n*                j=INFO+1,...,N.\n*          > N:  =N+1: other than QZ iteration failed in ZHGEQZ\n*                =N+2: after reordering, roundoff changed values of\n*                      some complex eigenvalues so that leading\n*                      eigenvalues in the Generalized Schur form no\n*                      longer satisfy SELCTG=.TRUE.  This could also\n*                      be caused due to scaling.\n*                =N+3: reordering falied in ZTGSEN.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sdim, alpha, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.zgges( jobvsl, jobvsr, sort, a, b, [:lwork => lwork, :usage => usage, :help => help]){|a,b| ... }\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_jobvsl = argv[0];
  rblapack_jobvsr = argv[1];
  rblapack_sort = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  if (argc == 6) {
    rblapack_lwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  jobvsl = StringValueCStr(rblapack_jobvsl)[0];
  sort = StringValueCStr(rblapack_sort)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  jobvsr = StringValueCStr(rblapack_jobvsr)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  ldvsl = lsame_(&jobvsl,"V") ? n : 1;
  if (rblapack_lwork == Qnil)
    lwork = 2*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldvsr = lsame_(&jobvsr,"V") ? n : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  alpha = NA_PTR_TYPE(rblapack_alpha, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvsl;
    shape[1] = n;
    rblapack_vsl = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  vsl = NA_PTR_TYPE(rblapack_vsl, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvsr;
    shape[1] = n;
    rblapack_vsr = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  vsr = NA_PTR_TYPE(rblapack_vsr, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  rwork = ALLOC_N(doublereal, (8*n));
  bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));

  zgges_(&jobvsl, &jobvsr, &sort, rblapack_selctg, &n, a, &lda, b, &ldb, &sdim, alpha, beta, vsl, &ldvsl, vsr, &ldvsr, work, &lwork, rwork, bwork, &info);

  free(rwork);
  free(bwork);
  rblapack_sdim = INT2NUM(sdim);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_sdim, rblapack_alpha, rblapack_beta, rblapack_vsl, rblapack_vsr, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_zgges(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgges", rblapack_zgges, -1);
}
ruby-lapack-1.7.2/ext/csytf2.c0000644000175000017500000001602612502221022015736 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID csytf2_(char* uplo, integer* n, complex* a, integer* lda, integer* ipiv, integer* info);


static VALUE
rblapack_csytf2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *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  ipiv, info, a = NumRu::Lapack.csytf2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSYTF2( UPLO, N, A, LDA, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  CSYTF2 computes the factorization of a complex symmetric matrix A\n*  using the Bunch-Kaufman diagonal pivoting method:\n*\n*     A = U*D*U'  or  A = L*D*L'\n*\n*  where U (or L) is a product of permutation and unit upper (lower)\n*  triangular matrices, U' is the transpose of U, and D is symmetric and\n*  block diagonal with 1-by-1 and 2-by-2 diagonal blocks.\n*\n*  This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored:\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          n-by-n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n-by-n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L (see below for further details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D.\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*          > 0: if INFO = k, D(k,k) is exactly zero.  The factorization\n*               has been completed, but the block diagonal matrix D is\n*               exactly singular, and division by zero will occur if it\n*               is used to solve a system of equations.\n*\n\n*  Further Details\n*  ===============\n*\n*  09-29-06 - patch from\n*    Bobby Cheng, MathWorks\n*\n*    Replace l.209 and l.377\n*         IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN\n*    by\n*         IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN\n*\n*  1-96 - Based on modifications by J. Lewis, Boeing Computer Services\n*         Company\n*\n*  If UPLO = 'U', then A = U*D*U', where\n*     U = P(n)*U(n)* ... *P(k)U(k)* ...,\n*  i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n*  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    v    0   )   k-s\n*     U(k) =  (   0    I    0   )   s\n*             (   0    0    I   )   n-k\n*                k-s   s   n-k\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n*  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n*  and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n*  If UPLO = 'L', then A = L*D*L', where\n*     L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n*  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n*  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    0     0   )  k-1\n*     L(k) =  (   0    I     0   )  s\n*             (   0    v     I   )  n-k-s+1\n*                k-1   s  n-k-s+1\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n*  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n*  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, a = NumRu::Lapack.csytf2( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  csytf2_(&uplo, &n, a, &lda, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_a);
}

void
init_lapack_csytf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "csytf2", rblapack_csytf2, -1);
}
ruby-lapack-1.7.2/ext/zheequb.c0000644000175000017500000001046412502221022016167 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zheequb_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublereal* s, doublereal* scond, doublereal* amax, doublecomplex* work, integer* info);


static VALUE
rblapack_zheequb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_scond;
  doublereal scond; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_info;
  integer info; 
  doublecomplex *work;

  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  s, scond, amax, info = NumRu::Lapack.zheequb( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHEEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZSYEQUB computes row and column scalings intended to equilibrate a\n*  symmetric matrix A and reduce its condition number\n*  (with respect to the two-norm).  S contains the scale factors,\n*  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n*  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This\n*  choice of S puts the condition number of B within a factor N of the\n*  smallest possible condition number over all possible diagonal\n*  scalings.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          The N-by-N symmetric matrix whose scaling\n*          factors are to be computed.  Only the diagonal elements of A\n*          are referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  S       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, S contains the scale factors for A.\n*\n*  SCOND   (output) DOUBLE PRECISION\n*          If INFO = 0, S contains the ratio of the smallest S(i) to\n*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too\n*          large nor too small, it is not worth scaling by S.\n*\n*  AMAX    (output) DOUBLE PRECISION\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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 is nonpositive.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, scond, amax, info = NumRu::Lapack.zheequb( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  work = ALLOC_N(doublecomplex, (3*n));

  zheequb_(&uplo, &n, a, &lda, s, &scond, &amax, work, &info);

  free(work);
  rblapack_scond = rb_float_new((double)scond);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
}

void
init_lapack_zheequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zheequb", rblapack_zheequb, -1);
}
ruby-lapack-1.7.2/ext/cladiv.c0000644000175000017500000000456212502221026015774 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cladiv_(complex *__out__, complex* x, complex* y);


static VALUE
rblapack_cladiv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_x;
  complex x; 
  VALUE rblapack_y;
  complex y; 
  VALUE rblapack___out__;
  complex __out__; 


  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  __out__ = NumRu::Lapack.cladiv( x, y, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      COMPLEX FUNCTION CLADIV( X, Y )\n\n*  Purpose\n*  =======\n*\n*  CLADIV := X / Y, where X and Y are complex.  The computation of X / Y\n*  will not overflow on an intermediary step unless the results\n*  overflows.\n*\n\n*  Arguments\n*  =========\n*\n*  X       (input) COMPLEX\n*  Y       (input) COMPLEX\n*          The complex scalars X and Y.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      REAL               ZI, ZR\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SLADIV\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          AIMAG, CMPLX, REAL\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.cladiv( x, y, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_x = argv[0];
  rblapack_y = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  x.r = (real)NUM2DBL(rb_funcall(rblapack_x, rb_intern("real"), 0));
  x.i = (real)NUM2DBL(rb_funcall(rblapack_x, rb_intern("imag"), 0));
  y.r = (real)NUM2DBL(rb_funcall(rblapack_y, rb_intern("real"), 0));
  y.i = (real)NUM2DBL(rb_funcall(rblapack_y, rb_intern("imag"), 0));

  cladiv_(&__out__, &x, &y);

  rblapack___out__ = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(__out__.r)), rb_float_new((double)(__out__.i)));
  return rblapack___out__;
}

void
init_lapack_cladiv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cladiv", rblapack_cladiv, -1);
}
ruby-lapack-1.7.2/ext/spoequ.c0000644000175000017500000000773712502221013016051 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID spoequ_(integer* n, real* a, integer* lda, real* s, real* scond, real* amax, integer* info);


static VALUE
rblapack_spoequ(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_scond;
  real scond; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_info;
  integer info; 

  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  s, scond, amax, info = NumRu::Lapack.spoequ( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPOEQU computes row and column scalings intended to equilibrate a\n*  symmetric positive definite matrix A and reduce its condition number\n*  (with respect to the two-norm).  S contains the scale factors,\n*  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n*  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This\n*  choice of S puts the condition number of B within a factor N of the\n*  smallest possible condition number over all possible diagonal\n*  scalings.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) REAL array, dimension (LDA,N)\n*          The N-by-N symmetric positive definite matrix whose scaling\n*          factors are to be computed.  Only the diagonal elements of A\n*          are referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  S       (output) REAL array, dimension (N)\n*          If INFO = 0, S contains the scale factors for A.\n*\n*  SCOND   (output) REAL\n*          If INFO = 0, S contains the ratio of the smallest S(i) to\n*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too\n*          large nor too small, it is not worth scaling by S.\n*\n*  AMAX    (output) REAL\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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 is nonpositive.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, scond, amax, info = NumRu::Lapack.spoequ( 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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, real*);

  spoequ_(&n, a, &lda, s, &scond, &amax, &info);

  rblapack_scond = rb_float_new((double)scond);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
}

void
init_lapack_spoequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "spoequ", rblapack_spoequ, -1);
}
ruby-lapack-1.7.2/ext/slargv.c0000644000175000017500000001130412502221016016017 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slargv_(integer* n, real* x, integer* incx, real* y, integer* incy, real* c, integer* incc);


static VALUE
rblapack_slargv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_y;
  real *y; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_incc;
  integer incc; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_x_out__;
  real *x_out__;
  VALUE rblapack_y_out__;
  real *y_out__;


  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  c, x, y = NumRu::Lapack.slargv( n, x, incx, y, incy, incc, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLARGV( N, X, INCX, Y, INCY, C, INCC )\n\n*  Purpose\n*  =======\n*\n*  SLARGV generates a vector of real plane rotations, determined by\n*  elements of the real vectors x and y. For i = 1,2,...,n\n*\n*     (  c(i)  s(i) ) ( x(i) ) = ( a(i) )\n*     ( -s(i)  c(i) ) ( y(i) ) = (   0  )\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of plane rotations to be generated.\n*\n*  X       (input/output) REAL array,\n*                         dimension (1+(N-1)*INCX)\n*          On entry, the vector x.\n*          On exit, x(i) is overwritten by a(i), for i = 1,...,n.\n*\n*  INCX    (input) INTEGER\n*          The increment between elements of X. INCX > 0.\n*\n*  Y       (input/output) REAL array,\n*                         dimension (1+(N-1)*INCY)\n*          On entry, the vector y.\n*          On exit, the sines of the plane rotations.\n*\n*  INCY    (input) INTEGER\n*          The increment between elements of Y. INCY > 0.\n*\n*  C       (output) REAL array, dimension (1+(N-1)*INCC)\n*          The cosines of the plane rotations.\n*\n*  INCC    (input) INTEGER\n*          The increment between elements of C. INCC > 0.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c, x, y = NumRu::Lapack.slargv( n, x, incx, y, incy, incc, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_n = argv[0];
  rblapack_x = argv[1];
  rblapack_incx = argv[2];
  rblapack_y = argv[3];
  rblapack_incy = argv[4];
  rblapack_incc = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  incx = NUM2INT(rblapack_incx);
  incy = NUM2INT(rblapack_incy);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1+(n-1)*incx))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  incc = NUM2INT(rblapack_incc);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (4th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incy))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
  if (NA_TYPE(rblapack_y) != NA_SFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
  y = NA_PTR_TYPE(rblapack_y, real*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incc;
    rblapack_c = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  c = NA_PTR_TYPE(rblapack_c, real*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incx;
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incy;
    rblapack_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
  MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  slargv_(&n, x, &incx, y, &incy, c, &incc);

  return rb_ary_new3(3, rblapack_c, rblapack_x, rblapack_y);
}

void
init_lapack_slargv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slargv", rblapack_slargv, -1);
}
ruby-lapack-1.7.2/ext/ztrtrs.c0000644000175000017500000001276412502221026016105 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztrtrs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, integer* info);


static VALUE
rblapack_ztrtrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.ztrtrs( uplo, trans, diag, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTRTRS solves a triangular system of the form\n*\n*     A * X = B,  A**T * X = B,  or  A**H * X = B,\n*\n*  where A is a triangular matrix of order N, and B is an N-by-NRHS\n*  matrix.  A check is made to verify that A is nonsingular.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          The triangular matrix A.  If UPLO = 'U', the leading N-by-N\n*          upper triangular part of the array A contains the upper\n*          triangular matrix, and the strictly lower triangular part of\n*          A is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*          triangular part of the array A contains the lower triangular\n*          matrix, and the strictly upper triangular part of A is not\n*          referenced.  If DIAG = 'U', the diagonal elements of A are\n*          also not referenced and are assumed to be 1.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, if INFO = 0, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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 A is zero,\n*               indicating that the matrix is singular and the solutions\n*               X have not been computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.ztrtrs( uplo, trans, diag, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  ztrtrs_(&uplo, &trans, &diag, &n, &nrhs, a, &lda, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_ztrtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztrtrs", rblapack_ztrtrs, -1);
}
ruby-lapack-1.7.2/ext/zsytrs.c0000644000175000017500000001204412502221023016077 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zsytrs_(char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* b, integer* ldb, integer* info);


static VALUE
rblapack_zsytrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.zsytrs( uplo, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZSYTRS solves a system of linear equations A*X = B with a complex\n*  symmetric matrix A using the factorization A = U*D*U**T or\n*  A = L*D*L**T computed by ZSYTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by ZSYTRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by ZSYTRF.\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.zsytrs( uplo, a, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zsytrs_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_zsytrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zsytrs", rblapack_zsytrs, -1);
}
ruby-lapack-1.7.2/ext/dpbtrs.c0000644000175000017500000001220512502221021016014 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dpbtrs_(char* uplo, integer* n, integer* kd, integer* nrhs, doublereal* ab, integer* ldab, doublereal* b, integer* ldb, integer* info);


static VALUE
rblapack_dpbtrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublereal *b_out__;

  integer ldab;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.dpbtrs( uplo, kd, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPBTRS solves a system of linear equations A*X = B with a symmetric\n*  positive definite band matrix A using the Cholesky factorization\n*  A = U**T*U or A = L*L**T computed by DPBTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangular factor stored in AB;\n*          = 'L':  Lower triangular factor stored in AB.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**T*U or A = L*L**T of the band matrix A, stored in the\n*          first KD+1 rows of the array.  The j-th column of U or L is\n*          stored in the j-th column of the array AB as follows:\n*          if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO ='L', AB(1+i-j,j)    = L(i,j) for j<=i<=min(n,j+kd).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            UPPER\n      INTEGER            J\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DTBSV, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.dpbtrs( uplo, kd, ab, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  kd = NUM2INT(rblapack_kd);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dpbtrs_(&uplo, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_dpbtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dpbtrs", rblapack_dpbtrs, -1);
}
ruby-lapack-1.7.2/ext/spftri.c0000644000175000017500000001647412502221021016041 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID spftri_(char* transr, char* uplo, integer* n, real* a, integer* info);


static VALUE
rblapack_spftri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;


  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  info, a = NumRu::Lapack.spftri( transr, uplo, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPFTRI( TRANSR, UPLO, N, A, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPFTRI computes the inverse of a real (symmetric) positive definite\n*  matrix A using the Cholesky factorization A = U**T*U or A = L*L**T\n*  computed by SPFTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR    (input) CHARACTER*1\n*          = 'N':  The Normal TRANSR of RFP A is stored;\n*          = 'T':  The Transpose TRANSR of RFP A is stored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension ( N*(N+1)/2 )\n*          On entry, the symmetric matrix A in RFP format. RFP format is\n*          described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n*          then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n*          (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is\n*          the transpose of RFP A as defined when\n*          TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n*          follows: If UPLO = 'U' the RFP A contains the nt elements of\n*          upper packed A. If UPLO = 'L' the RFP A contains the elements\n*          of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n*          'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n*          is odd. See the Note below for more details.\n*\n*          On exit, the symmetric inverse of the original matrix, in the\n*          same storage format.\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,i) element of the factor U or L is\n*                zero, and the inverse could not be computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  We first consider Rectangular Full Packed (RFP) Format when N is\n*  even. We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  the transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  the transpose of the last three columns of AP lower.\n*  This covers the case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        03 04 05                33 43 53\n*        13 14 15                00 44 54\n*        23 24 25                10 11 55\n*        33 34 35                20 21 22\n*        00 44 45                30 31 32\n*        01 11 55                40 41 42\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We then consider Rectangular Full Packed (RFP) Format when N is\n*  odd. We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  the transpose of the first two columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  the transpose of the last two columns of AP lower.\n*  This covers the case N odd and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        02 03 04                00 33 43\n*        12 13 14                10 11 44\n*        22 23 24                20 21 22\n*        00 33 34                30 31 32\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*           RFP A                   RFP A\n*\n*     02 12 22 00 01             00 10 20 30 40 50\n*     03 13 23 33 11             33 11 21 31 41 51\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.spftri( transr, uplo, n, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_n = argv[2];
  rblapack_a = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  n = NUM2INT(rblapack_n);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 1)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  spftri_(&transr, &uplo, &n, a, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_spftri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "spftri", rblapack_spftri, -1);
}
ruby-lapack-1.7.2/ext/zlaein.c0000644000175000017500000001344712502221015016014 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlaein_(logical* rightv, logical* noinit, integer* n, doublecomplex* h, integer* ldh, doublecomplex* w, doublecomplex* v, doublecomplex* b, integer* ldb, doublereal* rwork, doublereal* eps3, doublereal* smlnum, integer* info);


static VALUE
rblapack_zlaein(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_rightv;
  logical rightv; 
  VALUE rblapack_noinit;
  logical noinit; 
  VALUE rblapack_h;
  doublecomplex *h; 
  VALUE rblapack_w;
  doublecomplex w; 
  VALUE rblapack_v;
  doublecomplex *v; 
  VALUE rblapack_eps3;
  doublereal eps3; 
  VALUE rblapack_smlnum;
  doublereal smlnum; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_v_out__;
  doublecomplex *v_out__;
  doublecomplex *b;
  doublereal *rwork;

  integer ldh;
  integer n;
  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  info, v = NumRu::Lapack.zlaein( rightv, noinit, h, w, v, eps3, smlnum, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAEIN( RIGHTV, NOINIT, N, H, LDH, W, V, B, LDB, RWORK, EPS3, SMLNUM, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZLAEIN uses inverse iteration to find a right or left eigenvector\n*  corresponding to the eigenvalue W of a complex upper Hessenberg\n*  matrix H.\n*\n\n*  Arguments\n*  =========\n*\n*  RIGHTV   (input) LOGICAL\n*          = .TRUE. : compute right eigenvector;\n*          = .FALSE.: compute left eigenvector.\n*\n*  NOINIT   (input) LOGICAL\n*          = .TRUE. : no initial vector supplied in V\n*          = .FALSE.: initial vector supplied in V.\n*\n*  N       (input) INTEGER\n*          The order of the matrix H.  N >= 0.\n*\n*  H       (input) COMPLEX*16 array, dimension (LDH,N)\n*          The upper Hessenberg matrix H.\n*\n*  LDH     (input) INTEGER\n*          The leading dimension of the array H.  LDH >= max(1,N).\n*\n*  W       (input) COMPLEX*16\n*          The eigenvalue of H whose corresponding right or left\n*          eigenvector is to be computed.\n*\n*  V       (input/output) COMPLEX*16 array, dimension (N)\n*          On entry, if NOINIT = .FALSE., V must contain a starting\n*          vector for inverse iteration; otherwise V need not be set.\n*          On exit, V contains the computed eigenvector, normalized so\n*          that the component of largest magnitude has magnitude 1; here\n*          the magnitude of a complex number (x,y) is taken to be\n*          |x| + |y|.\n*\n*  B       (workspace) COMPLEX*16 array, dimension (LDB,N)\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\n*\n*  EPS3    (input) DOUBLE PRECISION\n*          A small machine-dependent value which is used to perturb\n*          close eigenvalues, and to replace zero pivots.\n*\n*  SMLNUM  (input) DOUBLE PRECISION\n*          A machine-dependent value close to the underflow threshold.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          = 1:  inverse iteration did not converge; V is set to the\n*                last iterate.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, v = NumRu::Lapack.zlaein( rightv, noinit, h, w, v, eps3, smlnum, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_rightv = argv[0];
  rblapack_noinit = argv[1];
  rblapack_h = argv[2];
  rblapack_w = argv[3];
  rblapack_v = argv[4];
  rblapack_eps3 = argv[5];
  rblapack_smlnum = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  rightv = (rblapack_rightv == Qtrue);
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (3th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (3th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_DCOMPLEX)
    rblapack_h = na_change_type(rblapack_h, NA_DCOMPLEX);
  h = NA_PTR_TYPE(rblapack_h, doublecomplex*);
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (5th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 1)
    rb_raise(rb_eArgError, "rank of v (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_v) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of v must be the same as shape 1 of h");
  if (NA_TYPE(rblapack_v) != NA_DCOMPLEX)
    rblapack_v = na_change_type(rblapack_v, NA_DCOMPLEX);
  v = NA_PTR_TYPE(rblapack_v, doublecomplex*);
  smlnum = NUM2DBL(rblapack_smlnum);
  noinit = (rblapack_noinit == Qtrue);
  eps3 = NUM2DBL(rblapack_eps3);
  w.r = NUM2DBL(rb_funcall(rblapack_w, rb_intern("real"), 0));
  w.i = NUM2DBL(rb_funcall(rblapack_w, rb_intern("imag"), 0));
  ldb = MAX(1,n);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_v_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  v_out__ = NA_PTR_TYPE(rblapack_v_out__, doublecomplex*);
  MEMCPY(v_out__, v, doublecomplex, NA_TOTAL(rblapack_v));
  rblapack_v = rblapack_v_out__;
  v = v_out__;
  b = ALLOC_N(doublecomplex, (ldb)*(n));
  rwork = ALLOC_N(doublereal, (n));

  zlaein_(&rightv, &noinit, &n, h, &ldh, &w, v, b, &ldb, rwork, &eps3, &smlnum, &info);

  free(b);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_v);
}

void
init_lapack_zlaein(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlaein", rblapack_zlaein, -1);
}
ruby-lapack-1.7.2/ext/chesvxx.c0000644000175000017500000006470412502221020016220 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chesvxx_(char* fact, char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, char* equed, real* s, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* rpvgrw, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, complex* work, real* rwork, integer* info);


static VALUE
rblapack_chesvxx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_params;
  real *params; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_rpvgrw;
  real rpvgrw; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_err_bnds_norm;
  real *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  real *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_af_out__;
  complex *af_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  VALUE rblapack_s_out__;
  real *s_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;
  VALUE rblapack_params_out__;
  real *params_out__;
  complex *work;
  real *rwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer nparams;
  integer ldx;
  integer n_err_bnds;

  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  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.chesvxx( fact, uplo, a, af, ipiv, equed, s, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHESVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     CHESVXX uses the diagonal pivoting factorization to compute the\n*     solution to a complex system of linear equations A * X = B, where\n*     A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n*     matrices.\n*\n*     If requested, both normwise and maximum componentwise error bounds\n*     are returned. CHESVXX will return a solution with a tiny\n*     guaranteed error (O(eps) where eps is the working machine\n*     precision) unless the matrix is very ill-conditioned, in which\n*     case a warning is returned. Relevant condition numbers also are\n*     calculated and returned.\n*\n*     CHESVXX accepts user-provided factorizations and equilibration\n*     factors; see the definitions of the FACT and EQUED options.\n*     Solving with refinement and using a factorization from a previous\n*     CHESVXX call will also produce a solution with either O(eps)\n*     errors or warnings, but we cannot make that claim for general\n*     user-provided factorizations and equilibration factors if they\n*     differ from what CHESVXX would itself produce.\n*\n*     Description\n*     ===========\n*\n*     The following steps are performed:\n*\n*     1. If FACT = 'E', real scaling factors are computed to equilibrate\n*     the system:\n*\n*       diag(S)*A*diag(S)     *inv(diag(S))*X = diag(S)*B\n*\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n*     2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n*     the matrix A (after equilibration if FACT = 'E') as\n*\n*        A = U * D * U**T,  if UPLO = 'U', or\n*        A = L * D * L**T,  if UPLO = 'L',\n*\n*     where U (or L) is a product of permutation and unit upper (lower)\n*     triangular matrices, and D is symmetric and block diagonal with\n*     1-by-1 and 2-by-2 diagonal blocks.\n*\n*     3. If some D(i,i)=0, so that D is exactly singular, then the\n*     routine returns with INFO = i. Otherwise, the factored form of A\n*     is used to estimate the condition number of the matrix A (see\n*     argument RCOND).  If the reciprocal of the condition number is\n*     less than machine precision, the routine still goes on to solve\n*     for X and compute error bounds as described below.\n*\n*     4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*     5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n*     the routine will use iterative refinement to try to get a small\n*     error and error bounds.  Refinement calculates the residual to at\n*     least twice the working precision.\n*\n*     6. If equilibration was used, the matrix X is premultiplied by\n*     diag(R) so that it solves the original system before\n*     equilibration.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     FACT    (input) CHARACTER*1\n*     Specifies whether or not the factored form of the matrix A is\n*     supplied on entry, and if not, whether the matrix A should be\n*     equilibrated before it is factored.\n*       = 'F':  On entry, AF and IPIV contain the factored form of A.\n*               If EQUED is not 'N', the matrix A has been\n*               equilibrated with scaling factors given by S.\n*               A, AF, and IPIV are not modified.\n*       = 'N':  The matrix A will be copied to AF and factored.\n*       = 'E':  The matrix A will be equilibrated if necessary, then\n*               copied to AF and factored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     A       (input/output) COMPLEX array, dimension (LDA,N)\n*     The symmetric matrix A.  If UPLO = 'U', the leading N-by-N\n*     upper triangular part of A contains the upper triangular\n*     part of the matrix A, and the strictly lower triangular\n*     part of A is not referenced.  If UPLO = 'L', the leading\n*     N-by-N lower triangular part of A contains the lower\n*     triangular part of the matrix A, and the strictly upper\n*     triangular part of A is not referenced.\n*\n*     On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n*     diag(S)*A*diag(S).\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input or output) COMPLEX array, dimension (LDAF,N)\n*     If FACT = 'F', then AF is an input argument and on entry\n*     contains the block diagonal matrix D and the multipliers\n*     used to obtain the factor U or L from the factorization A =\n*     U*D*U**T or A = L*D*L**T as computed by SSYTRF.\n*\n*     If FACT = 'N', then AF is an output argument and on exit\n*     returns the block diagonal matrix D and the multipliers\n*     used to obtain the factor U or L from the factorization A =\n*     U*D*U**T or A = L*D*L**T.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input or output) INTEGER array, dimension (N)\n*     If FACT = 'F', then IPIV is an input argument and on entry\n*     contains details of the interchanges and the block\n*     structure of D, as determined by CHETRF.  If IPIV(k) > 0,\n*     then rows and columns k and IPIV(k) were interchanged and\n*     D(k,k) is a 1-by-1 diagonal block.  If UPLO = 'U' and\n*     IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and\n*     -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2\n*     diagonal block.  If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0,\n*     then rows and columns k+1 and -IPIV(k) were interchanged\n*     and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*     If FACT = 'N', then IPIV is an output argument and on exit\n*     contains details of the interchanges and the block\n*     structure of D, as determined by CHETRF.\n*\n*     EQUED   (input or output) CHARACTER*1\n*     Specifies the form of equilibration that was done.\n*       = 'N':  No equilibration (always true if FACT = 'N').\n*       = 'Y':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(S) * A * diag(S).\n*     EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*     output argument.\n*\n*     S       (input or output) REAL array, dimension (N)\n*     The scale factors for A.  If EQUED = 'Y', A is multiplied on\n*     the left and right by diag(S).  S is an input argument if FACT =\n*     'F'; otherwise, S is an output argument.  If FACT = 'F' and EQUED\n*     = 'Y', each element of S must be positive.  If S is output, each\n*     element of S is a power of the radix. If S is input, each element\n*     of S should be a power of the radix to ensure a reliable solution\n*     and error estimates. Scaling by powers of the radix does not cause\n*     rounding errors unless the result underflows or overflows.\n*     Rounding errors during scaling lead to refining with a matrix that\n*     is not equivalent to the input matrix, producing error estimates\n*     that may not be reliable.\n*\n*     B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*     On entry, the N-by-NRHS right hand side matrix B.\n*     On exit,\n*     if EQUED = 'N', B is not modified;\n*     if EQUED = 'Y', B is overwritten by diag(S)*B;\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (output) COMPLEX array, dimension (LDX,NRHS)\n*     If INFO = 0, the N-by-NRHS solution matrix X to the original\n*     system of equations.  Note that A and B are modified on exit if\n*     EQUED .ne. 'N', and the solution to the equilibrated system is\n*     inv(diag(S))*X.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) REAL\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     RPVGRW  (output) REAL\n*     Reciprocal pivot growth.  On exit, this contains the reciprocal\n*     pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n*     norm is used.  If this is much less than 1, then the stability of\n*     the LU factorization of the (equilibrated) matrix A could be poor.\n*     This also means that the solution X, estimated condition numbers,\n*     and error bounds could be unreliable. If factorization fails with\n*     0 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.chesvxx( fact, uplo, a, af, ipiv, equed, s, b, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_equed = argv[5];
  rblapack_s = argv[6];
  rblapack_b = argv[7];
  rblapack_params = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (7th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (9th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_SFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
  params = NA_PTR_TYPE(rblapack_params, real*);
  n_err_bnds = 3;
  uplo = StringValueCStr(rblapack_uplo)[0];
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  ldx = MAX(1,n);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldaf;
    shape[1] = n;
    rblapack_af_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  af_out__ = NA_PTR_TYPE(rblapack_af_out__, complex*);
  MEMCPY(af_out__, af, complex, NA_TOTAL(rblapack_af));
  rblapack_af = rblapack_af_out__;
  af = af_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
  MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
  MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (2*n));

  chesvxx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, s, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_rpvgrw = rb_float_new((double)rpvgrw);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(14, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_a, rblapack_af, rblapack_ipiv, rblapack_equed, rblapack_s, rblapack_b, rblapack_params);
}

void
init_lapack_chesvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chesvxx", rblapack_chesvxx, -1);
}
ruby-lapack-1.7.2/ext/dsyevr.c0000644000175000017500000003617212502221024016046 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsyevr_(char* jobz, char* range, char* uplo, integer* n, doublereal* a, integer* lda, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublereal* z, integer* ldz, integer* isuppz, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_dsyevr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_vl;
  doublereal vl; 
  VALUE rblapack_vu;
  doublereal vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  doublereal abstol; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_isuppz;
  integer *isuppz; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;

  integer lda;
  integer n;
  integer ldz;

  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  m, w, z, isuppz, work, iwork, info, a = NumRu::Lapack.dsyevr( jobz, range, uplo, a, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSYEVR computes selected eigenvalues and, optionally, eigenvectors\n*  of a real symmetric matrix A.  Eigenvalues and eigenvectors can be\n*  selected by specifying either a range of values or a range of\n*  indices for the desired eigenvalues.\n*\n*  DSYEVR first reduces the matrix A to tridiagonal form T with a call\n*  to DSYTRD.  Then, whenever possible, DSYEVR calls DSTEMR to compute\n*  the eigenspectrum using Relatively Robust Representations.  DSTEMR\n*  computes eigenvalues by the dqds algorithm, while orthogonal\n*  eigenvectors are computed from various \"good\" L D L^T representations\n*  (also known as Relatively Robust Representations). Gram-Schmidt\n*  orthogonalization is avoided as far as possible. More specifically,\n*  the various steps of the algorithm are as follows.\n*\n*  For each unreduced block (submatrix) of T,\n*     (a) Compute T - sigma I  = L D L^T, so that L and D\n*         define all the wanted eigenvalues to high relative accuracy.\n*         This means that small relative changes in the entries of D and L\n*         cause only small relative changes in the eigenvalues and\n*         eigenvectors. The standard (unfactored) representation of the\n*         tridiagonal matrix T does not have this property in general.\n*     (b) Compute the eigenvalues to suitable accuracy.\n*         If the eigenvectors are desired, the algorithm attains full\n*         accuracy of the computed eigenvalues only right before\n*         the corresponding vectors have to be computed, see steps c) and d).\n*     (c) For each cluster of close eigenvalues, select a new\n*         shift close to the cluster, find a new factorization, and refine\n*         the shifted eigenvalues to suitable accuracy.\n*     (d) For each eigenvalue with a large enough relative separation compute\n*         the corresponding eigenvector by forming a rank revealing twisted\n*         factorization. Go back to (c) for any clusters that remain.\n*\n*  The desired accuracy of the output can be specified by the input\n*  parameter ABSTOL.\n*\n*  For more details, see DSTEMR's documentation and:\n*  - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n*    to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n*    Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n*  - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n*    Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n*    2004.  Also LAPACK Working Note 154.\n*  - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n*    tridiagonal eigenvalue/eigenvector problem\",\n*    Computer Science Division Technical Report No. UCB/CSD-97-971,\n*    UC Berkeley, May 1997.\n*\n*\n*  Note 1 : DSYEVR calls DSTEMR when the full spectrum is requested\n*  on machines which conform to the ieee-754 floating point standard.\n*  DSYEVR calls DSTEBZ and SSTEIN on non-ieee machines and\n*  when partial spectrum requests are made.\n*\n*  Normal execution of DSTEMR may create NaNs and infinities and\n*  hence may abort due to a floating point exception in environments\n*  which do not handle NaNs and infinities in the ieee standard default\n*  manner.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found.\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found.\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n********** For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and\n********** DSTEIN are called\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of A contains the\n*          upper triangular part of the matrix A.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of A contains\n*          the lower triangular part of the matrix A.\n*          On exit, the lower triangle (if UPLO='L') or the upper\n*          triangle (if UPLO='U') of A, including the diagonal, is\n*          destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  VL      (input) DOUBLE PRECISION\n*  VU      (input) DOUBLE PRECISION\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) DOUBLE PRECISION\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less than\n*          or equal to zero, then  EPS*|T|  will be used in its place,\n*          where |T| is the 1-norm of the tridiagonal matrix obtained\n*          by reducing A to tridiagonal form.\n*\n*          See \"Computing Small Singular Values of Bidiagonal Matrices\n*          with Guaranteed High Relative Accuracy,\" by Demmel and\n*          Kahan, LAPACK Working Note #3.\n*\n*          If high relative accuracy is important, set ABSTOL to\n*          DLAMCH( 'Safe minimum' ).  Doing so will guarantee that\n*          eigenvalues are computed to high relative accuracy when\n*          possible in future releases.  The current code does not\n*          make any guarantees about high relative accuracy, but\n*          future releases will. See J. Barlow and J. Demmel,\n*          \"Computing Accurate Eigensystems of Scaled Diagonally\n*          Dominant Matrices\", LAPACK Working Note #7, for a discussion\n*          of which matrices define their eigenvalues to high relative\n*          accuracy.\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          The first M elements contain the selected eigenvalues in\n*          ascending order.\n*\n*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))\n*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix A\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*          Supplying N columns is always safe.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  ISUPPZ  (output) INTEGER array, dimension ( 2*max(1,M) )\n*          The support of the eigenvectors in Z, i.e., the indices\n*          indicating the nonzero elements in Z. The i-th eigenvector\n*          is nonzero only in elements ISUPPZ( 2*i-1 ) through\n*          ISUPPZ( 2*i ).\n********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1\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,26*N).\n*          For optimal efficiency, LWORK >= (NB+6)*N,\n*          where NB is the max of the blocksize for DSYTRD and DORMTR\n*          returned by ILAENV.\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*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.  LIWORK >= max(1,10*N).\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal size of the IWORK array,\n*          returns this value as the first entry of the IWORK array, and\n*          no error message related to LIWORK 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:  Internal error\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Inderjit Dhillon, IBM Almaden, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Ken Stanley, Computer Science Division, University of\n*       California at Berkeley, USA\n*     Jason Riedy, Computer Science Division, University of\n*       California at Berkeley, USA\n*\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, isuppz, work, iwork, info, a = NumRu::Lapack.dsyevr( jobz, range, uplo, a, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 11)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_uplo = argv[2];
  rblapack_a = argv[3];
  rblapack_vl = argv[4];
  rblapack_vu = argv[5];
  rblapack_il = argv[6];
  rblapack_iu = argv[7];
  rblapack_abstol = argv[8];
  if (argc == 11) {
    rblapack_lwork = argv[9];
    rblapack_liwork = argv[10];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  vl = NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  abstol = NUM2DBL(rblapack_abstol);
  range = StringValueCStr(rblapack_range)[0];
  vu = NUM2DBL(rblapack_vu);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th 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*);
  if (rblapack_lwork == Qnil)
    lwork = 26*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  iu = NUM2INT(rblapack_iu);
  m = lsame_(&range,"I") ? iu-il+1 : n;
  if (rblapack_liwork == Qnil)
    liwork = 10*n;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 2*MAX(1,m);
    rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t 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__;

  dsyevr_(&jobz, &range, &uplo, &n, a, &lda, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, isuppz, work, &lwork, iwork, &liwork, &info);

  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_m, rblapack_w, rblapack_z, rblapack_isuppz, rblapack_work, rblapack_iwork, rblapack_info, rblapack_a);
}

void
init_lapack_dsyevr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsyevr", rblapack_dsyevr, -1);
}
ruby-lapack-1.7.2/ext/zspr.c0000644000175000017500000001360412502221016015524 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zspr_(char* uplo, integer* n, doublecomplex* alpha, doublecomplex* x, integer* incx, doublecomplex* ap);


static VALUE
rblapack_zspr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_alpha;
  doublecomplex alpha; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_ap_out__;
  doublecomplex *ap_out__;


  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  ap = NumRu::Lapack.zspr( uplo, n, alpha, x, incx, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSPR( UPLO, N, ALPHA, X, INCX, AP )\n\n*  Purpose\n*  =======\n*\n*  ZSPR    performs the symmetric rank 1 operation\n*\n*     A := alpha*x*conjg( x' ) + A,\n*\n*  where alpha is a complex scalar, x is an n element vector and A is an\n*  n by n symmetric matrix, supplied in packed form.\n*\n\n*  Arguments\n*  ==========\n*\n*  UPLO     (input) CHARACTER*1\n*           On entry, UPLO specifies whether the upper or lower\n*           triangular part of the matrix A is supplied in the packed\n*           array AP as follows:\n*\n*              UPLO = 'U' or 'u'   The upper triangular part of A is\n*                                  supplied in AP.\n*\n*              UPLO = 'L' or 'l'   The lower triangular part of A is\n*                                  supplied in AP.\n*\n*           Unchanged on exit.\n*\n*  N        (input) INTEGER\n*           On entry, N specifies the order of the matrix A.\n*           N must be at least zero.\n*           Unchanged on exit.\n*\n*  ALPHA    (input) COMPLEX*16\n*           On entry, ALPHA specifies the scalar alpha.\n*           Unchanged on exit.\n*\n*  X        (input) COMPLEX*16 array, dimension at least\n*           ( 1 + ( N - 1 )*abs( INCX ) ).\n*           Before entry, the incremented array X must contain the N-\n*           element vector x.\n*           Unchanged on exit.\n*\n*  INCX     (input) INTEGER\n*           On entry, INCX specifies the increment for the elements of\n*           X. INCX must not be zero.\n*           Unchanged on exit.\n*\n*  AP       (input/output) COMPLEX*16 array, dimension at least\n*           ( ( N*( N + 1 ) )/2 ).\n*           Before entry, with  UPLO = 'U' or 'u', the array AP must\n*           contain the upper triangular part of the symmetric matrix\n*           packed sequentially, column by column, so that AP( 1 )\n*           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )\n*           and a( 2, 2 ) respectively, and so on. On exit, the array\n*           AP is overwritten by the upper triangular part of the\n*           updated matrix.\n*           Before entry, with UPLO = 'L' or 'l', the array AP must\n*           contain the lower triangular part of the symmetric matrix\n*           packed sequentially, column by column, so that AP( 1 )\n*           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )\n*           and a( 3, 1 ) respectively, and so on. On exit, the array\n*           AP is overwritten by the lower triangular part of the\n*           updated matrix.\n*           Note that the imaginary parts of the diagonal elements need\n*           not be set, they are assumed to be zero, and on exit they\n*           are set to zero.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ap = NumRu::Lapack.zspr( uplo, n, alpha, x, incx, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_n = argv[1];
  rblapack_alpha = argv[2];
  rblapack_x = argv[3];
  rblapack_incx = argv[4];
  rblapack_ap = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  alpha.r = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
  alpha.i = NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
  incx = NUM2INT(rblapack_incx);
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (6th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (( n*( n + 1 ) )/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", ( n*( n + 1 ) )/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (4th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1 + ( n - 1 )*abs( incx )))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = ( n*( n + 1 ) )/2;
    rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
  MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  zspr_(&uplo, &n, &alpha, x, &incx, ap);

  return rblapack_ap;
}

void
init_lapack_zspr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zspr", rblapack_zspr, -1);
}
ruby-lapack-1.7.2/ext/sorgql.c0000644000175000017500000001241512502221013016031 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sorgql_(integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sorgql(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;

  integer lda;
  integer n;
  integer k;

  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 = NumRu::Lapack.sorgql( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SORGQL generates an M-by-N real matrix Q with orthonormal columns,\n*  which is defined as the last N columns of a product of K elementary\n*  reflectors of order M\n*\n*        Q  =  H(k) . . . H(2) H(1)\n*\n*  as returned by SGEQLF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. M >= N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. N >= K >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the (n-k+i)-th column must contain the vector which\n*          defines the elementary reflector H(i), for i = 1,2,...,k, as\n*          returned by SGEQLF in the last k columns of its array\n*          argument A.\n*          On exit, the M-by-N matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) REAL array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by SGEQLF.\n*\n*  WORK    (workspace/output) REAL 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,N).\n*          For optimum performance LWORK >= N*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 has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, a = NumRu::Lapack.sorgql( m, a, tau, [: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_m = argv[0];
  rblapack_a = argv[1];
  rblapack_tau = 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;
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  sorgql_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_sorgql(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sorgql", rblapack_sorgql, -1);
}
ruby-lapack-1.7.2/ext/dlasq3.c0000644000175000017500000001526312502221023015716 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlasq3_(integer* i0, integer* n0, doublereal* z, integer* pp, doublereal* dmin, doublereal* sigma, doublereal* desig, doublereal* qmax, integer* nfail, integer* iter, integer* ndiv, logical* ieee, integer* ttype, doublereal* dmin1, doublereal* dmin2, doublereal* dn, doublereal* dn1, doublereal* dn2, doublereal* g, doublereal* tau);


static VALUE
rblapack_dlasq3(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_i0;
  integer i0; 
  VALUE rblapack_n0;
  integer n0; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_pp;
  integer pp; 
  VALUE rblapack_desig;
  doublereal desig; 
  VALUE rblapack_qmax;
  doublereal qmax; 
  VALUE rblapack_ieee;
  logical ieee; 
  VALUE rblapack_ttype;
  integer ttype; 
  VALUE rblapack_dmin1;
  doublereal dmin1; 
  VALUE rblapack_dmin2;
  doublereal dmin2; 
  VALUE rblapack_dn;
  doublereal dn; 
  VALUE rblapack_dn1;
  doublereal dn1; 
  VALUE rblapack_dn2;
  doublereal dn2; 
  VALUE rblapack_g;
  doublereal g; 
  VALUE rblapack_tau;
  doublereal tau; 
  VALUE rblapack_dmin;
  doublereal dmin; 
  VALUE rblapack_sigma;
  doublereal sigma; 
  VALUE rblapack_nfail;
  integer nfail; 
  VALUE rblapack_iter;
  integer iter; 
  VALUE rblapack_ndiv;
  integer ndiv; 


  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  dmin, sigma, nfail, iter, ndiv, n0, pp, desig, ttype, dmin1, dmin2, dn, dn1, dn2, g, tau = NumRu::Lapack.dlasq3( i0, n0, z, pp, desig, qmax, ieee, ttype, dmin1, dmin2, dn, dn1, dn2, g, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, DN2, G, TAU )\n\n*  Purpose\n*  =======\n*\n*  DLASQ3 checks for deflation, computes a shift (TAU) and calls dqds.\n*  In case of failure it changes shifts, and tries again until output\n*  is positive.\n*\n\n*  Arguments\n*  =========\n*\n*  I0     (input) INTEGER\n*         First index.\n*\n*  N0     (input/output) INTEGER\n*         Last index.\n*\n*  Z      (input) DOUBLE PRECISION array, dimension ( 4*N )\n*         Z holds the qd array.\n*\n*  PP     (input/output) INTEGER\n*         PP=0 for ping, PP=1 for pong.\n*         PP=2 indicates that flipping was applied to the Z array   \n*         and that the initial tests for deflation should not be \n*         performed.\n*\n*  DMIN   (output) DOUBLE PRECISION\n*         Minimum value of d.\n*\n*  SIGMA  (output) DOUBLE PRECISION\n*         Sum of shifts used in current segment.\n*\n*  DESIG  (input/output) DOUBLE PRECISION\n*         Lower order part of SIGMA\n*\n*  QMAX   (input) DOUBLE PRECISION\n*         Maximum value of q.\n*\n*  NFAIL  (output) INTEGER\n*         Number of times shift was too big.\n*\n*  ITER   (output) INTEGER\n*         Number of iterations.\n*\n*  NDIV   (output) INTEGER\n*         Number of divisions.\n*\n*  IEEE   (input) LOGICAL\n*         Flag for IEEE or non IEEE arithmetic (passed to DLASQ5).\n*\n*  TTYPE  (input/output) INTEGER\n*         Shift type.\n*\n*  DMIN1  (input/output) DOUBLE PRECISION\n*\n*  DMIN2  (input/output) DOUBLE PRECISION\n*\n*  DN     (input/output) DOUBLE PRECISION\n*\n*  DN1    (input/output) DOUBLE PRECISION\n*\n*  DN2    (input/output) DOUBLE PRECISION\n*\n*  G      (input/output) DOUBLE PRECISION\n*\n*  TAU    (input/output) DOUBLE PRECISION\n*\n*         These are passed as arguments in order to save their values\n*         between calls to DLASQ3.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  dmin, sigma, nfail, iter, ndiv, n0, pp, desig, ttype, dmin1, dmin2, dn, dn1, dn2, g, tau = NumRu::Lapack.dlasq3( i0, n0, z, pp, desig, qmax, ieee, ttype, dmin1, dmin2, dn, dn1, dn2, g, tau, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 15 && argc != 15)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
  rblapack_i0 = argv[0];
  rblapack_n0 = argv[1];
  rblapack_z = argv[2];
  rblapack_pp = argv[3];
  rblapack_desig = argv[4];
  rblapack_qmax = argv[5];
  rblapack_ieee = argv[6];
  rblapack_ttype = argv[7];
  rblapack_dmin1 = argv[8];
  rblapack_dmin2 = argv[9];
  rblapack_dn = argv[10];
  rblapack_dn1 = argv[11];
  rblapack_dn2 = argv[12];
  rblapack_g = argv[13];
  rblapack_tau = argv[14];
  if (argc == 15) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  i0 = NUM2INT(rblapack_i0);
  pp = NUM2INT(rblapack_pp);
  qmax = NUM2DBL(rblapack_qmax);
  ttype = NUM2INT(rblapack_ttype);
  dmin2 = NUM2DBL(rblapack_dmin2);
  dn1 = NUM2DBL(rblapack_dn1);
  g = NUM2DBL(rblapack_g);
  n0 = NUM2INT(rblapack_n0);
  desig = NUM2DBL(rblapack_desig);
  dmin1 = NUM2DBL(rblapack_dmin1);
  dn2 = NUM2DBL(rblapack_dn2);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (3th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != (4*n0))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", 4*n0);
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  dn = NUM2DBL(rblapack_dn);
  ieee = (rblapack_ieee == Qtrue);
  tau = NUM2DBL(rblapack_tau);

  dlasq3_(&i0, &n0, z, &pp, &dmin, &sigma, &desig, &qmax, &nfail, &iter, &ndiv, &ieee, &ttype, &dmin1, &dmin2, &dn, &dn1, &dn2, &g, &tau);

  rblapack_dmin = rb_float_new((double)dmin);
  rblapack_sigma = rb_float_new((double)sigma);
  rblapack_nfail = INT2NUM(nfail);
  rblapack_iter = INT2NUM(iter);
  rblapack_ndiv = INT2NUM(ndiv);
  rblapack_n0 = INT2NUM(n0);
  rblapack_pp = INT2NUM(pp);
  rblapack_desig = rb_float_new((double)desig);
  rblapack_ttype = INT2NUM(ttype);
  rblapack_dmin1 = rb_float_new((double)dmin1);
  rblapack_dmin2 = rb_float_new((double)dmin2);
  rblapack_dn = rb_float_new((double)dn);
  rblapack_dn1 = rb_float_new((double)dn1);
  rblapack_dn2 = rb_float_new((double)dn2);
  rblapack_g = rb_float_new((double)g);
  rblapack_tau = rb_float_new((double)tau);
  return rb_ary_new3(16, rblapack_dmin, rblapack_sigma, rblapack_nfail, rblapack_iter, rblapack_ndiv, rblapack_n0, rblapack_pp, rblapack_desig, rblapack_ttype, rblapack_dmin1, rblapack_dmin2, rblapack_dn, rblapack_dn1, rblapack_dn2, rblapack_g, rblapack_tau);
}

void
init_lapack_dlasq3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlasq3", rblapack_dlasq3, -1);
}
ruby-lapack-1.7.2/ext/sspevd.c0000644000175000017500000002057612502221015016037 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sspevd_(char* jobz, char* uplo, integer* n, real* ap, real* w, real* z, integer* ldz, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_sspevd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  real *ap_out__;

  integer ldap;
  integer n;
  integer ldz;

  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  w, z, work, iwork, info, ap = NumRu::Lapack.sspevd( jobz, uplo, ap, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSPEVD computes all the eigenvalues and, optionally, eigenvectors\n*  of a real symmetric matrix A in packed storage. If eigenvectors are\n*  desired, it uses a divide and conquer algorithm.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) REAL array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, AP is overwritten by values generated during the\n*          reduction to tridiagonal form.  If UPLO = 'U', the diagonal\n*          and first superdiagonal of the tridiagonal matrix T overwrite\n*          the corresponding elements of A, and if UPLO = 'L', the\n*          diagonal and first subdiagonal of T overwrite the\n*          corresponding elements of A.\n*\n*  W       (output) REAL array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) REAL array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n*          eigenvectors of the matrix A, with the i-th column of Z\n*          holding the eigenvector associated with W(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace/output) REAL array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the required LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK.\n*          If N <= 1,               LWORK must be at least 1.\n*          If JOBZ = 'N' and N > 1, LWORK must be at least 2*N.\n*          If JOBZ = 'V' and N > 1, LWORK must be at least\n*                                                 1 + 6*N + N**2.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the required sizes of the WORK and IWORK\n*          arrays, returns these values as the first entries of the WORK\n*          and IWORK arrays, and no error message related to LWORK or\n*          LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.\n*          If JOBZ  = 'N' or N <= 1, LIWORK must be at least 1.\n*          If JOBZ  = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the required sizes of the WORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK and IWORK arrays, and no error message related to\n*          LWORK or LIWORK 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 algorithm failed to converge; i\n*                off-diagonal elements of an intermediate tridiagonal\n*                form did not converge to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, work, iwork, info, ap = NumRu::Lapack.sspevd( jobz, uplo, ap, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_ap = argv[2];
  if (argc == 5) {
    rblapack_lwork = argv[3];
    rblapack_liwork = argv[4];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (rblapack_liwork == Qnil)
    liwork = (lsame_(&jobz,"N")||n<=1) ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  if (rblapack_lwork == Qnil)
    lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 2*n : lsame_(&jobz,"V") ? 1+6*n+n*n : 2;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, real*);
  MEMCPY(ap_out__, ap, real, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  sspevd_(&jobz, &uplo, &n, ap, w, z, &ldz, work, &lwork, iwork, &liwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_w, rblapack_z, rblapack_work, rblapack_iwork, rblapack_info, rblapack_ap);
}

void
init_lapack_sspevd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sspevd", rblapack_sspevd, -1);
}
ruby-lapack-1.7.2/ext/claqsb.c0000644000175000017500000001302312502221016015766 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID claqsb_(char* uplo, integer* n, integer* kd, complex* ab, integer* ldab, real* s, real* scond, real* amax, char* equed);


static VALUE
rblapack_claqsb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_scond;
  real scond; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_ab_out__;
  complex *ab_out__;

  integer ldab;
  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  equed, ab = NumRu::Lapack.claqsb( uplo, kd, ab, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )\n\n*  Purpose\n*  =======\n*\n*  CLAQSB equilibrates a symmetric band matrix A using the scaling\n*  factors in the vector S.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of super-diagonals of the matrix A if UPLO = 'U',\n*          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) COMPLEX array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*          On exit, if INFO = 0, the triangular factor U or L from the\n*          Cholesky factorization A = U'*U or A = L*L' of the band\n*          matrix A, in the same storage format as A.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  S       (input) REAL array, dimension (N)\n*          The scale factors for A.\n*\n*  SCOND   (input) REAL\n*          Ratio of the smallest S(i) to the largest S(i).\n*\n*  AMAX    (input) REAL\n*          Absolute value of largest matrix entry.\n*\n*  EQUED   (output) CHARACTER*1\n*          Specifies whether or not equilibration was done.\n*          = 'N':  No equilibration.\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*\n*  Internal Parameters\n*  ===================\n*\n*  THRESH is a threshold value used to decide if scaling should be done\n*  based on the ratio of the scaling factors.  If SCOND < THRESH,\n*  scaling is done.\n*\n*  LARGE and SMALL are threshold values used to decide if scaling should\n*  be done based on the absolute size of the largest matrix element.\n*  If AMAX > LARGE or AMAX < SMALL, scaling is done.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  equed, ab = NumRu::Lapack.claqsb( uplo, kd, ab, s, scond, amax, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  rblapack_s = argv[3];
  rblapack_scond = argv[4];
  rblapack_amax = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  scond = (real)NUM2DBL(rblapack_scond);
  kd = NUM2INT(rblapack_kd);
  amax = (real)NUM2DBL(rblapack_amax);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (4th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
  MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  claqsb_(&uplo, &n, &kd, ab, &ldab, s, &scond, &amax, &equed);

  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(2, rblapack_equed, rblapack_ab);
}

void
init_lapack_claqsb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "claqsb", rblapack_claqsb, -1);
}
ruby-lapack-1.7.2/ext/dgetrs.c0000644000175000017500000001174512502221020016015 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgetrs_(char* trans, integer* n, integer* nrhs, doublereal* a, integer* lda, integer* ipiv, doublereal* b, integer* ldb, integer* info);


static VALUE
rblapack_dgetrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublereal *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.dgetrs( trans, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGETRS solves a system of linear equations\n*     A * X = B  or  A' * X = B\n*  with a general N-by-N matrix A using the LU factorization computed\n*  by DGETRF.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B  (No transpose)\n*          = 'T':  A'* X = B  (Transpose)\n*          = 'C':  A'* X = B  (Conjugate transpose = Transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*          The factors L and U from the factorization A = P*L*U\n*          as computed by DGETRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices from DGETRF; for 1<=i<=N, row i of the\n*          matrix was interchanged with row IPIV(i).\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.dgetrs( trans, a, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_trans = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dgetrs_(&trans, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_dgetrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgetrs", rblapack_dgetrs, -1);
}
ruby-lapack-1.7.2/ext/zsysvx.c0000644000175000017500000003376412502221015016124 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zsysvx_(char* fact, char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublecomplex* work, integer* lwork, doublereal* rwork, integer* info);


static VALUE
rblapack_zsysvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_af_out__;
  doublecomplex *af_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  doublereal *rwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.zsysvx( fact, uplo, a, af, ipiv, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZSYSVX uses the diagonal pivoting factorization to compute the\n*  solution to a complex system of linear equations A * X = B,\n*  where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n*  matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'N', the diagonal pivoting method is used to factor A.\n*     The form of the factorization is\n*        A = U * D * U**T,  if UPLO = 'U', or\n*        A = L * D * L**T,  if UPLO = 'L',\n*     where U (or L) is a product of permutation and unit upper (lower)\n*     triangular matrices, and D is symmetric and block diagonal with\n*     1-by-1 and 2-by-2 diagonal blocks.\n*\n*  2. If some D(i,i)=0, so that D is exactly singular, then the routine\n*     returns with INFO = i. Otherwise, the factored form of A is used\n*     to estimate the condition number of the matrix A.  If the\n*     reciprocal of the condition number is less than machine precision,\n*     INFO = N+1 is returned as a warning, but the routine still goes on\n*     to solve for X and compute error bounds as described below.\n*\n*  3. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  4. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of A has been\n*          supplied on entry.\n*          = 'F':  On entry, AF and IPIV contain the factored form\n*                  of A.  A, AF and IPIV will not be modified.\n*          = 'N':  The matrix A will be copied to AF and factored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          The symmetric matrix A.  If UPLO = 'U', the leading N-by-N\n*          upper triangular part of A contains the upper triangular part\n*          of the matrix A, and the strictly lower triangular part of A\n*          is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*          triangular part of A contains the lower triangular part of\n*          the matrix A, and the strictly upper triangular part of A is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AF      (input or output) COMPLEX*16 array, dimension (LDAF,N)\n*          If FACT = 'F', then AF is an input argument and on entry\n*          contains the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L from the factorization\n*          A = U*D*U**T or A = L*D*L**T as computed by ZSYTRF.\n*\n*          If FACT = 'N', then AF is an output argument and on exit\n*          returns the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L from the factorization\n*          A = U*D*U**T or A = L*D*L**T.\n*\n*  LDAF    (input) INTEGER\n*          The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*  IPIV    (input or output) INTEGER array, dimension (N)\n*          If FACT = 'F', then IPIV is an input argument and on entry\n*          contains details of the interchanges and the block structure\n*          of D, as determined by ZSYTRF.\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*          If FACT = 'N', then IPIV is an output argument and on exit\n*          contains details of the interchanges and the block structure\n*          of D, as determined by ZSYTRF.\n*\n*  B       (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*          The N-by-NRHS right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) COMPLEX*16 array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The estimate of the reciprocal condition number of the matrix\n*          A.  If RCOND is less than the machine precision (in\n*          particular, if RCOND = 0), the matrix is singular to working\n*          precision.  This condition is indicated by a return code of\n*          INFO > 0.\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of WORK.  LWORK >= max(1,2*N), and for best\n*          performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where\n*          NB is the optimal blocksize for ZSYTRF.\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*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\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, and i is\n*                <= N:  D(i,i) is exactly zero.  The factorization\n*                       has been completed but the factor D is exactly\n*                       singular, so the solution and error bounds could\n*                       not be computed. RCOND = 0 is returned.\n*                = N+1: D is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.zsysvx( fact, uplo, a, af, ipiv, b, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_b = argv[5];
  if (argc == 7) {
    rblapack_lwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  ldx = MAX(1,n);
  if (rblapack_lwork == Qnil)
    lwork = 3*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldaf;
    shape[1] = n;
    rblapack_af_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  af_out__ = NA_PTR_TYPE(rblapack_af_out__, doublecomplex*);
  MEMCPY(af_out__, af, doublecomplex, NA_TOTAL(rblapack_af));
  rblapack_af = rblapack_af_out__;
  af = af_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  rwork = ALLOC_N(doublereal, (n));

  zsysvx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, &lwork, rwork, &info);

  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_work, rblapack_info, rblapack_af, rblapack_ipiv);
}

void
init_lapack_zsysvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zsysvx", rblapack_zsysvx, -1);
}
ruby-lapack-1.7.2/ext/dgbsv.c0000644000175000017500000001641112502221016015632 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgbsv_(integer* n, integer* kl, integer* ku, integer* nrhs, doublereal* ab, integer* ldab, integer* ipiv, doublereal* b, integer* ldb, integer* info);


static VALUE
rblapack_dgbsv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublereal *ab_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;

  integer ldab;
  integer n;
  integer ldb;
  integer nrhs;

  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  ipiv, info, ab, b = NumRu::Lapack.dgbsv( kl, ku, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGBSV computes the solution to a real system of linear equations\n*  A * X = B, where A is a band matrix of order N with KL subdiagonals\n*  and KU superdiagonals, and X and B are N-by-NRHS matrices.\n*\n*  The LU decomposition with partial pivoting and row interchanges is\n*  used to factor A as A = L * U, where L is a product of permutation\n*  and unit lower triangular matrices with KL subdiagonals, and U is\n*  upper triangular with KL+KU superdiagonals.  The factored form of A\n*  is then used to solve the system of equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n*          On entry, the matrix A in band storage, in rows KL+1 to\n*          2*KL+KU+1; rows 1 to KL of the array need not be set.\n*          The j-th column of A is stored in the j-th column of the\n*          array AB as follows:\n*          AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)\n*          On exit, details of the factorization: U is stored as an\n*          upper triangular band matrix with KL+KU superdiagonals in\n*          rows 1 to KL+KU+1, and the multipliers used during the\n*          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n*          See below for further details.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          The pivot indices that define the permutation matrix P;\n*          row i of the matrix was interchanged with row IPIV(i).\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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, U(i,i) is exactly zero.  The factorization\n*                has been completed, but the factor U is exactly\n*                singular, and the solution has not been computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  M = N = 6, KL = 2, KU = 1:\n*\n*  On entry:                       On exit:\n*\n*      *    *    *    +    +    +       *    *    *   u14  u25  u36\n*      *    *    +    +    +    +       *    *   u13  u24  u35  u46\n*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56\n*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66\n*     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *\n*     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *\n*\n*  Array elements marked * are not used by the routine; elements marked\n*  + need not be set on entry, but are required by the routine to store\n*  elements of U because of fill-in resulting from the row interchanges.\n*\n*  =====================================================================\n*\n*     .. External Subroutines ..\n      EXTERNAL           DGBTRF, DGBTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, ab, b = NumRu::Lapack.dgbsv( kl, ku, ab, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_kl = argv[0];
  rblapack_ku = argv[1];
  rblapack_ab = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
  MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dgbsv_(&n, &kl, &ku, &nrhs, ab, &ldab, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ipiv, rblapack_info, rblapack_ab, rblapack_b);
}

void
init_lapack_dgbsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgbsv", rblapack_dgbsv, -1);
}
ruby-lapack-1.7.2/ext/sla_syrfsx_extended.c0000644000175000017500000005613712502221020020606 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sla_syrfsx_extended_(integer* prec_type, char* uplo, integer* n, integer* nrhs, real* a, integer* lda, real* af, integer* ldaf, integer* ipiv, logical* colequ, real* c, real* b, integer* ldb, real* y, integer* ldy, real* berr_out, integer* n_norms, real* err_bnds_norm, real* err_bnds_comp, real* res, real* ayb, real* dy, real* y_tail, real* rcond, integer* ithresh, real* rthresh, real* dz_ub, logical* ignore_cwise, integer* info);


static VALUE
rblapack_sla_syrfsx_extended(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_prec_type;
  integer prec_type; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_af;
  real *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_colequ;
  logical colequ; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_y;
  real *y; 
  VALUE rblapack_n_norms;
  integer n_norms; 
  VALUE rblapack_err_bnds_norm;
  real *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  real *err_bnds_comp; 
  VALUE rblapack_res;
  real *res; 
  VALUE rblapack_ayb;
  real *ayb; 
  VALUE rblapack_dy;
  real *dy; 
  VALUE rblapack_y_tail;
  real *y_tail; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_ithresh;
  integer ithresh; 
  VALUE rblapack_rthresh;
  real rthresh; 
  VALUE rblapack_dz_ub;
  real dz_ub; 
  VALUE rblapack_ignore_cwise;
  logical ignore_cwise; 
  VALUE rblapack_berr_out;
  real *berr_out; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_y_out__;
  real *y_out__;
  VALUE rblapack_err_bnds_norm_out__;
  real *err_bnds_norm_out__;
  VALUE rblapack_err_bnds_comp_out__;
  real *err_bnds_comp_out__;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldy;
  integer n_err_bnds;

  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  berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.sla_syrfsx_extended( prec_type, uplo, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n*  Purpose\n*  =======\n* \n*  SLA_SYRFSX_EXTENDED improves the computed solution to a system of\n*  linear equations by performing extra-precise iterative refinement\n*  and provides error bounds and backward error estimates for the solution.\n*  This subroutine is called by SSYRFSX to perform iterative refinement.\n*  In addition to normwise error bound, the code provides maximum\n*  componentwise error bound if possible. See comments for ERR_BNDS_NORM\n*  and ERR_BNDS_COMP for details of the error bounds. Note that this\n*  subroutine is only resonsible for setting the second fields of\n*  ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n*  Arguments\n*  =========\n*\n*     PREC_TYPE      (input) INTEGER\n*     Specifies the intermediate precision to be used in refinement.\n*     The value is defined by ILAPREC(P) where P is a CHARACTER and\n*     P    = 'S':  Single\n*          = 'D':  Double\n*          = 'I':  Indigenous\n*          = 'X', 'E':  Extra\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N              (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NRHS           (input) INTEGER\n*     The number of right-hand-sides, i.e., the number of columns of the\n*     matrix B.\n*\n*     A              (input) REAL array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA            (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF             (input) REAL array, dimension (LDAF,N)\n*     The block diagonal matrix D and the multipliers used to\n*     obtain the factor U or L as computed by SSYTRF.\n*\n*     LDAF           (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV           (input) INTEGER array, dimension (N)\n*     Details of the interchanges and the block structure of D\n*     as determined by SSYTRF.\n*\n*     COLEQU         (input) LOGICAL\n*     If .TRUE. then column equilibration was done to A before calling\n*     this routine. This is needed to compute the solution and error\n*     bounds correctly.\n*\n*     C              (input) REAL array, dimension (N)\n*     The column scale factors for A. If COLEQU = .FALSE., C\n*     is not accessed. If C is input, each element of C should be a power\n*     of the radix to ensure a reliable solution and error estimates.\n*     Scaling by powers of the radix does not cause rounding errors unless\n*     the result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B              (input) REAL array, dimension (LDB,NRHS)\n*     The right-hand-side matrix B.\n*\n*     LDB            (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     Y              (input/output) REAL array, dimension (LDY,NRHS)\n*     On entry, the solution matrix X, as computed by SSYTRS.\n*     On exit, the improved solution matrix Y.\n*\n*     LDY            (input) INTEGER\n*     The leading dimension of the array Y.  LDY >= max(1,N).\n*\n*     BERR_OUT       (output) REAL array, dimension (NRHS)\n*     On exit, BERR_OUT(j) contains the componentwise relative backward\n*     error for right-hand-side j from the formula\n*         max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n*     where abs(Z) is the componentwise absolute value of the matrix\n*     or vector Z. This is computed by SLA_LIN_BERR.\n*\n*     N_NORMS        (input) INTEGER\n*     Determines which error bounds to return (see ERR_BNDS_NORM\n*     and ERR_BNDS_COMP).\n*     If N_NORMS >= 1 return normwise error bounds.\n*     If N_NORMS >= 2 return componentwise error bounds.\n*\n*     ERR_BNDS_NORM  (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (input/output) REAL array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     RES            (input) REAL array, dimension (N)\n*     Workspace to hold the intermediate residual.\n*\n*     AYB            (input) REAL array, dimension (N)\n*     Workspace. This can be the same workspace passed for Y_TAIL.\n*\n*     DY             (input) REAL array, dimension (N)\n*     Workspace to hold the intermediate solution.\n*\n*     Y_TAIL         (input) REAL array, dimension (N)\n*     Workspace to hold the trailing bits of the intermediate solution.\n*\n*     RCOND          (input) REAL\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     ITHRESH        (input) INTEGER\n*     The maximum number of residual computations allowed for\n*     refinement. The default is 10. For 'aggressive' set to 100 to\n*     permit convergence using approximate factorizations or\n*     factorizations other than LU. If the factorization uses a\n*     technique other than Gaussian elimination, the guarantees in\n*     ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n*     RTHRESH        (input) REAL\n*     Determines when to stop refinement if the error estimate stops\n*     decreasing. Refinement will stop when the next solution no longer\n*     satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n*     the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n*     default value is 0.5. For 'aggressive' set to 0.9 to permit\n*     convergence on extremely ill-conditioned matrices. See LAWN 165\n*     for more details.\n*\n*     DZ_UB          (input) REAL\n*     Determines when to start considering componentwise convergence.\n*     Componentwise convergence is only considered after each component\n*     of the solution Y is stable, which we definte as the relative\n*     change in each component being less than DZ_UB. The default value\n*     is 0.25, requiring the first bit to be stable. See LAWN 165 for\n*     more details.\n*\n*     IGNORE_CWISE   (input) LOGICAL\n*     If .TRUE. then ignore componentwise convergence. Default value\n*     is .FALSE..\n*\n*     INFO           (output) INTEGER\n*       = 0:  Successful exit.\n*       < 0:  if INFO = -i, the ith argument to SSYTRS had an illegal\n*             value\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            UPLO2, CNT, I, J, X_STATE, Z_STATE\n      REAL               YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n     $                   DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n     $                   DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n     $                   EPS, HUGEVAL, INCR_THRESH\n      LOGICAL            INCR_PREC\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.sla_syrfsx_extended( prec_type, uplo, a, af, ipiv, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 21 && argc != 21)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 21)", argc);
  rblapack_prec_type = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_colequ = argv[5];
  rblapack_c = argv[6];
  rblapack_b = argv[7];
  rblapack_y = argv[8];
  rblapack_n_norms = argv[9];
  rblapack_err_bnds_norm = argv[10];
  rblapack_err_bnds_comp = argv[11];
  rblapack_res = argv[12];
  rblapack_ayb = argv[13];
  rblapack_dy = argv[14];
  rblapack_y_tail = argv[15];
  rblapack_rcond = argv[16];
  rblapack_ithresh = argv[17];
  rblapack_rthresh = argv[18];
  rblapack_dz_ub = argv[19];
  rblapack_ignore_cwise = argv[20];
  if (argc == 21) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  prec_type = NUM2INT(rblapack_prec_type);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (9th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 2)
    rb_raise(rb_eArgError, "rank of y (9th argument) must be %d", 2);
  ldy = NA_SHAPE0(rblapack_y);
  nrhs = NA_SHAPE1(rblapack_y);
  if (NA_TYPE(rblapack_y) != NA_SFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
  y = NA_PTR_TYPE(rblapack_y, real*);
  if (!NA_IsNArray(rblapack_err_bnds_norm))
    rb_raise(rb_eArgError, "err_bnds_norm (11th argument) must be NArray");
  if (NA_RANK(rblapack_err_bnds_norm) != 2)
    rb_raise(rb_eArgError, "rank of err_bnds_norm (11th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_err_bnds_norm) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of y");
  n_err_bnds = NA_SHAPE1(rblapack_err_bnds_norm);
  if (NA_TYPE(rblapack_err_bnds_norm) != NA_SFLOAT)
    rblapack_err_bnds_norm = na_change_type(rblapack_err_bnds_norm, NA_SFLOAT);
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
  if (!NA_IsNArray(rblapack_res))
    rb_raise(rb_eArgError, "res (13th argument) must be NArray");
  if (NA_RANK(rblapack_res) != 1)
    rb_raise(rb_eArgError, "rank of res (13th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_res) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_res) != NA_SFLOAT)
    rblapack_res = na_change_type(rblapack_res, NA_SFLOAT);
  res = NA_PTR_TYPE(rblapack_res, real*);
  if (!NA_IsNArray(rblapack_dy))
    rb_raise(rb_eArgError, "dy (15th argument) must be NArray");
  if (NA_RANK(rblapack_dy) != 1)
    rb_raise(rb_eArgError, "rank of dy (15th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dy) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_dy) != NA_SFLOAT)
    rblapack_dy = na_change_type(rblapack_dy, NA_SFLOAT);
  dy = NA_PTR_TYPE(rblapack_dy, real*);
  rcond = (real)NUM2DBL(rblapack_rcond);
  rthresh = (real)NUM2DBL(rblapack_rthresh);
  ignore_cwise = (rblapack_ignore_cwise == Qtrue);
  uplo = StringValueCStr(rblapack_uplo)[0];
  colequ = (rblapack_colequ == Qtrue);
  n_norms = NUM2INT(rblapack_n_norms);
  if (!NA_IsNArray(rblapack_ayb))
    rb_raise(rb_eArgError, "ayb (14th argument) must be NArray");
  if (NA_RANK(rblapack_ayb) != 1)
    rb_raise(rb_eArgError, "rank of ayb (14th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ayb) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ayb) != NA_SFLOAT)
    rblapack_ayb = na_change_type(rblapack_ayb, NA_SFLOAT);
  ayb = NA_PTR_TYPE(rblapack_ayb, real*);
  ithresh = NUM2INT(rblapack_ithresh);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
  af = NA_PTR_TYPE(rblapack_af, real*);
  if (!NA_IsNArray(rblapack_err_bnds_comp))
    rb_raise(rb_eArgError, "err_bnds_comp (12th argument) must be NArray");
  if (NA_RANK(rblapack_err_bnds_comp) != 2)
    rb_raise(rb_eArgError, "rank of err_bnds_comp (12th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_err_bnds_comp) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of y");
  if (NA_SHAPE1(rblapack_err_bnds_comp) != n_err_bnds)
    rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_comp must be the same as shape 1 of err_bnds_norm");
  if (NA_TYPE(rblapack_err_bnds_comp) != NA_SFLOAT)
    rblapack_err_bnds_comp = na_change_type(rblapack_err_bnds_comp, NA_SFLOAT);
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
  dz_ub = (real)NUM2DBL(rblapack_dz_ub);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of y");
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (!NA_IsNArray(rblapack_y_tail))
    rb_raise(rb_eArgError, "y_tail (16th argument) must be NArray");
  if (NA_RANK(rblapack_y_tail) != 1)
    rb_raise(rb_eArgError, "rank of y_tail (16th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y_tail) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_y_tail) != NA_SFLOAT)
    rblapack_y_tail = na_change_type(rblapack_y_tail, NA_SFLOAT);
  y_tail = NA_PTR_TYPE(rblapack_y_tail, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr_out = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr_out = NA_PTR_TYPE(rblapack_berr_out, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldy;
    shape[1] = nrhs;
    rblapack_y_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
  MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm_out__ = NA_PTR_TYPE(rblapack_err_bnds_norm_out__, real*);
  MEMCPY(err_bnds_norm_out__, err_bnds_norm, real, NA_TOTAL(rblapack_err_bnds_norm));
  rblapack_err_bnds_norm = rblapack_err_bnds_norm_out__;
  err_bnds_norm = err_bnds_norm_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp_out__ = NA_PTR_TYPE(rblapack_err_bnds_comp_out__, real*);
  MEMCPY(err_bnds_comp_out__, err_bnds_comp, real, NA_TOTAL(rblapack_err_bnds_comp));
  rblapack_err_bnds_comp = rblapack_err_bnds_comp_out__;
  err_bnds_comp = err_bnds_comp_out__;

  sla_syrfsx_extended_(&prec_type, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_err_bnds_norm, rblapack_err_bnds_comp);
}

void
init_lapack_sla_syrfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sla_syrfsx_extended", rblapack_sla_syrfsx_extended, -1);
}
ruby-lapack-1.7.2/ext/slarrv.c0000644000175000017500000004105512655767574016101 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slarrv_(integer* n, real* vl, real* vu, real* d, real* l, real* pivmin, integer* isplit, integer* m, integer* dol, integer* dou, real* minrgp, real* rtol1, real* rtol2, real* w, real* werr, real* wgap, integer* iblock, integer* indexw, real* gers, real* z, integer* ldz, integer* isuppz, real* work, integer* iwork, integer* info);


static VALUE
rblapack_slarrv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_vl;
  real vl; 
  VALUE rblapack_vu;
  real vu; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_l;
  real *l; 
  VALUE rblapack_pivmin;
  real pivmin; 
  VALUE rblapack_isplit;
  integer *isplit; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_dol;
  integer dol; 
  VALUE rblapack_dou;
  integer dou; 
  VALUE rblapack_minrgp;
  real minrgp; 
  VALUE rblapack_rtol1;
  real rtol1; 
  VALUE rblapack_rtol2;
  real rtol2; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_werr;
  real *werr; 
  VALUE rblapack_wgap;
  real *wgap; 
  VALUE rblapack_iblock;
  integer *iblock; 
  VALUE rblapack_indexw;
  integer *indexw; 
  VALUE rblapack_gers;
  real *gers; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_isuppz;
  integer *isuppz; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_l_out__;
  real *l_out__;
  VALUE rblapack_w_out__;
  real *w_out__;
  VALUE rblapack_werr_out__;
  real *werr_out__;
  VALUE rblapack_wgap_out__;
  real *wgap_out__;
  real *work;
  integer *iwork;

  integer n;
  integer ldz;

  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  z, isuppz, info, d, l, w, werr, wgap = NumRu::Lapack.slarrv( vl, vu, d, l, pivmin, isplit, m, dol, dou, minrgp, rtol1, rtol2, w, werr, wgap, iblock, indexw, gers, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLARRV( N, VL, VU, D, L, PIVMIN, ISPLIT, M, DOL, DOU, MINRGP, RTOL1, RTOL2, W, WERR, WGAP, IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLARRV computes the eigenvectors of the tridiagonal matrix\n*  T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T.\n*  The input eigenvalues should have been computed by SLARRE.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  VL      (input) REAL            \n*  VU      (input) REAL            \n*          Lower and upper bounds of the interval that contains the desired\n*          eigenvalues. VL < VU. Needed to compute gaps on the left or right\n*          end of the extremal eigenvalues in the desired RANGE.\n*\n*  D       (input/output) REAL array, dimension (N)\n*          On entry, the N diagonal elements of the diagonal matrix D.\n*          On exit, D may be overwritten.\n*\n*  L       (input/output) REAL array, dimension (N)\n*          On entry, the (N-1) subdiagonal elements of the unit\n*          bidiagonal matrix L are in elements 1 to N-1 of L\n*          (if the matrix is not split.) At the end of each block\n*          is stored the corresponding shift as given by SLARRE.\n*          On exit, L is overwritten.\n*\n*  PIVMIN  (input) REAL\n*          The minimum pivot allowed in the Sturm sequence.\n*\n*  ISPLIT  (input) INTEGER array, dimension (N)\n*          The splitting points, at which T breaks up into blocks.\n*          The first block consists of rows/columns 1 to\n*          ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n*          through ISPLIT( 2 ), etc.\n*\n*  M       (input) INTEGER\n*          The total number of input eigenvalues.  0 <= M <= N.\n*\n*  DOL     (input) INTEGER\n*  DOU     (input) INTEGER\n*          If the user wants to compute only selected eigenvectors from all\n*          the eigenvalues supplied, he can specify an index range DOL:DOU.\n*          Or else the setting DOL=1, DOU=M should be applied.\n*          Note that DOL and DOU refer to the order in which the eigenvalues\n*          are stored in W.\n*          If the user wants to compute only selected eigenpairs, then\n*          the columns DOL-1 to DOU+1 of the eigenvector space Z contain the\n*          computed eigenvectors. All other columns of Z are set to zero.\n*\n*  MINRGP  (input) REAL            \n*\n*  RTOL1   (input) REAL            \n*  RTOL2   (input) REAL            \n*           Parameters for bisection.\n*           An interval [LEFT,RIGHT] has converged if\n*           RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n*\n*  W       (input/output) REAL             array, dimension (N)\n*          The first M elements of W contain the APPROXIMATE eigenvalues for\n*          which eigenvectors are to be computed.  The eigenvalues\n*          should be grouped by split-off block and ordered from\n*          smallest to largest within the block ( The output array\n*          W from SLARRE is expected here ). Furthermore, they are with\n*          respect to the shift of the corresponding root representation\n*          for their block. On exit, W holds the eigenvalues of the\n*          UNshifted matrix.\n*\n*  WERR    (input/output) REAL array, dimension (N)\n*          The first M elements contain the semiwidth of the uncertainty\n*          interval of the corresponding eigenvalue in W\n*\n*  WGAP    (input/output) REAL array, dimension (N)\n*          The separation from the right neighbor eigenvalue in W.\n*\n*  IBLOCK  (input) INTEGER array, dimension (N)\n*          The indices of the blocks (submatrices) associated with the\n*          corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue\n*          W(i) belongs to the first block from the top, =2 if W(i)\n*          belongs to the second block, etc.\n*\n*  INDEXW  (input) INTEGER array, dimension (N)\n*          The indices of the eigenvalues within each block (submatrix);\n*          for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the\n*          i-th eigenvalue W(i) is the 10-th eigenvalue in the second block.\n*\n*  GERS    (input) REAL array, dimension (2*N)\n*          The N Gerschgorin intervals (the i-th Gerschgorin interval\n*          is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should\n*          be computed from the original UNshifted matrix.\n*\n*  Z       (output) REAL array, dimension (LDZ, max(1,M) )\n*          If INFO = 0, the first M columns of Z contain the\n*          orthonormal eigenvectors of the matrix T\n*          corresponding to the input eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  ISUPPZ  (output) INTEGER array, dimension ( 2*max(1,M) )\n*          The support of the eigenvectors in Z, i.e., the indices\n*          indicating the nonzero elements in Z. The I-th eigenvector\n*          is nonzero only in elements ISUPPZ( 2*I-1 ) through\n*          ISUPPZ( 2*I ).\n*\n*  WORK    (workspace) REAL array, dimension (12*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (7*N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*\n*          > 0:  A problem occured in SLARRV.\n*          < 0:  One of the called subroutines signaled an internal problem.\n*                Needs inspection of the corresponding parameter IINFO\n*                for further information.\n*\n*          =-1:  Problem in SLARRB when refining a child's eigenvalues.\n*          =-2:  Problem in SLARRF when computing the RRR of a child.\n*                When a child is inside a tight cluster, it can be difficult\n*                to find an RRR. A partial remedy from the user's point of\n*                view is to make the parameter MINRGP smaller and recompile.\n*                However, as the orthogonality of the computed vectors is\n*                proportional to 1/MINRGP, the user should be aware that\n*                he might be trading in precision when he decreases MINRGP.\n*          =-3:  Problem in SLARRB when refining a single eigenvalue\n*                after the Rayleigh correction was rejected.\n*          = 5:  The Rayleigh Quotient Iteration failed to converge to\n*                full accuracy in MAXITR steps.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Beresford Parlett, University of California, Berkeley, USA\n*     Jim Demmel, University of California, Berkeley, USA\n*     Inderjit Dhillon, University of Texas, Austin, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  z, isuppz, info, d, l, w, werr, wgap = NumRu::Lapack.slarrv( vl, vu, d, l, pivmin, isplit, m, dol, dou, minrgp, rtol1, rtol2, w, werr, wgap, iblock, indexw, gers, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 18 && argc != 18)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 18)", argc);
  rblapack_vl = argv[0];
  rblapack_vu = argv[1];
  rblapack_d = argv[2];
  rblapack_l = argv[3];
  rblapack_pivmin = argv[4];
  rblapack_isplit = argv[5];
  rblapack_m = argv[6];
  rblapack_dol = argv[7];
  rblapack_dou = argv[8];
  rblapack_minrgp = argv[9];
  rblapack_rtol1 = argv[10];
  rblapack_rtol2 = argv[11];
  rblapack_w = argv[12];
  rblapack_werr = argv[13];
  rblapack_wgap = argv[14];
  rblapack_iblock = argv[15];
  rblapack_indexw = argv[16];
  rblapack_gers = argv[17];
  if (argc == 18) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  vl = (real)NUM2DBL(rblapack_vl);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  pivmin = (real)NUM2DBL(rblapack_pivmin);
  m = NUM2INT(rblapack_m);
  dou = NUM2INT(rblapack_dou);
  rtol1 = (real)NUM2DBL(rblapack_rtol1);
  if (!NA_IsNArray(rblapack_w))
    rb_raise(rb_eArgError, "w (13th argument) must be NArray");
  if (NA_RANK(rblapack_w) != 1)
    rb_raise(rb_eArgError, "rank of w (13th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_w) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_w) != NA_SFLOAT)
    rblapack_w = na_change_type(rblapack_w, NA_SFLOAT);
  w = NA_PTR_TYPE(rblapack_w, real*);
  if (!NA_IsNArray(rblapack_wgap))
    rb_raise(rb_eArgError, "wgap (15th argument) must be NArray");
  if (NA_RANK(rblapack_wgap) != 1)
    rb_raise(rb_eArgError, "rank of wgap (15th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_wgap) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of wgap must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_wgap) != NA_SFLOAT)
    rblapack_wgap = na_change_type(rblapack_wgap, NA_SFLOAT);
  wgap = NA_PTR_TYPE(rblapack_wgap, real*);
  if (!NA_IsNArray(rblapack_indexw))
    rb_raise(rb_eArgError, "indexw (17th argument) must be NArray");
  if (NA_RANK(rblapack_indexw) != 1)
    rb_raise(rb_eArgError, "rank of indexw (17th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_indexw) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of indexw must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_indexw) != NA_LINT)
    rblapack_indexw = na_change_type(rblapack_indexw, NA_LINT);
  indexw = NA_PTR_TYPE(rblapack_indexw, integer*);
  vu = (real)NUM2DBL(rblapack_vu);
  if (!NA_IsNArray(rblapack_isplit))
    rb_raise(rb_eArgError, "isplit (6th argument) must be NArray");
  if (NA_RANK(rblapack_isplit) != 1)
    rb_raise(rb_eArgError, "rank of isplit (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_isplit) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of isplit must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_isplit) != NA_LINT)
    rblapack_isplit = na_change_type(rblapack_isplit, NA_LINT);
  isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
  minrgp = (real)NUM2DBL(rblapack_minrgp);
  if (!NA_IsNArray(rblapack_werr))
    rb_raise(rb_eArgError, "werr (14th argument) must be NArray");
  if (NA_RANK(rblapack_werr) != 1)
    rb_raise(rb_eArgError, "rank of werr (14th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_werr) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of werr must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_werr) != NA_SFLOAT)
    rblapack_werr = na_change_type(rblapack_werr, NA_SFLOAT);
  werr = NA_PTR_TYPE(rblapack_werr, real*);
  if (!NA_IsNArray(rblapack_l))
    rb_raise(rb_eArgError, "l (4th argument) must be NArray");
  if (NA_RANK(rblapack_l) != 1)
    rb_raise(rb_eArgError, "rank of l (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_l) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of l must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_l) != NA_SFLOAT)
    rblapack_l = na_change_type(rblapack_l, NA_SFLOAT);
  l = NA_PTR_TYPE(rblapack_l, real*);
  rtol2 = (real)NUM2DBL(rblapack_rtol2);
  dol = NUM2INT(rblapack_dol);
  if (!NA_IsNArray(rblapack_iblock))
    rb_raise(rb_eArgError, "iblock (16th argument) must be NArray");
  if (NA_RANK(rblapack_iblock) != 1)
    rb_raise(rb_eArgError, "rank of iblock (16th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_iblock) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of iblock must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_iblock) != NA_LINT)
    rblapack_iblock = na_change_type(rblapack_iblock, NA_LINT);
  iblock = NA_PTR_TYPE(rblapack_iblock, integer*);
  ldz = n;
  if (!NA_IsNArray(rblapack_gers))
    rb_raise(rb_eArgError, "gers (18th argument) must be NArray");
  if (NA_RANK(rblapack_gers) != 1)
    rb_raise(rb_eArgError, "rank of gers (18th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_gers) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of gers must be %d", 2*n);
  if (NA_TYPE(rblapack_gers) != NA_SFLOAT)
    rblapack_gers = na_change_type(rblapack_gers, NA_SFLOAT);
  gers = NA_PTR_TYPE(rblapack_gers, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[1];
    shape[0] = 2*MAX(1,m);
    rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_l_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  l_out__ = NA_PTR_TYPE(rblapack_l_out__, real*);
  MEMCPY(l_out__, l, real, NA_TOTAL(rblapack_l));
  rblapack_l = rblapack_l_out__;
  l = l_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w_out__ = NA_PTR_TYPE(rblapack_w_out__, real*);
  MEMCPY(w_out__, w, real, NA_TOTAL(rblapack_w));
  rblapack_w = rblapack_w_out__;
  w = w_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_werr_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  werr_out__ = NA_PTR_TYPE(rblapack_werr_out__, real*);
  MEMCPY(werr_out__, werr, real, NA_TOTAL(rblapack_werr));
  rblapack_werr = rblapack_werr_out__;
  werr = werr_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wgap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  wgap_out__ = NA_PTR_TYPE(rblapack_wgap_out__, real*);
  MEMCPY(wgap_out__, wgap, real, NA_TOTAL(rblapack_wgap));
  rblapack_wgap = rblapack_wgap_out__;
  wgap = wgap_out__;
  work = ALLOC_N(real, (12*n));
  iwork = ALLOC_N(integer, (7*n));

  slarrv_(&n, &vl, &vu, d, l, &pivmin, isplit, &m, &dol, &dou, &minrgp, &rtol1, &rtol2, w, werr, wgap, iblock, indexw, gers, z, &ldz, isuppz, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_z, rblapack_isuppz, rblapack_info, rblapack_d, rblapack_l, rblapack_w, rblapack_werr, rblapack_wgap);
}

void
init_lapack_slarrv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slarrv", rblapack_slarrv, -1);
}
ruby-lapack-1.7.2/ext/zlarft.c0000644000175000017500000001550612502221021016027 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlarft_(char* direct, char* storev, integer* n, integer* k, doublecomplex* v, integer* ldv, doublecomplex* tau, doublecomplex* t, integer* ldt);


static VALUE
rblapack_zlarft(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_direct;
  char direct; 
  VALUE rblapack_storev;
  char storev; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_v;
  doublecomplex *v; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_t;
  doublecomplex *t; 
  VALUE rblapack_v_out__;
  doublecomplex *v_out__;

  integer ldv;
  integer k;
  integer ldt;

  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  t, v = NumRu::Lapack.zlarft( direct, storev, n, v, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n*  Purpose\n*  =======\n*\n*  ZLARFT forms the triangular factor T of a complex block reflector H\n*  of order n, which is defined as a product of k elementary reflectors.\n*\n*  If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n*\n*  If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n*\n*  If STOREV = 'C', the vector which defines the elementary reflector\n*  H(i) is stored in the i-th column of the array V, and\n*\n*     H  =  I - V * T * V'\n*\n*  If STOREV = 'R', the vector which defines the elementary reflector\n*  H(i) is stored in the i-th row of the array V, and\n*\n*     H  =  I - V' * T * V\n*\n\n*  Arguments\n*  =========\n*\n*  DIRECT  (input) CHARACTER*1\n*          Specifies the order in which the elementary reflectors are\n*          multiplied to form the block reflector:\n*          = 'F': H = H(1) H(2) . . . H(k) (Forward)\n*          = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n*  STOREV  (input) CHARACTER*1\n*          Specifies how the vectors which define the elementary\n*          reflectors are stored (see also Further Details):\n*          = 'C': columnwise\n*          = 'R': rowwise\n*\n*  N       (input) INTEGER\n*          The order of the block reflector H. N >= 0.\n*\n*  K       (input) INTEGER\n*          The order of the triangular factor T (= the number of\n*          elementary reflectors). K >= 1.\n*\n*  V       (input/output) COMPLEX*16 array, dimension\n*                               (LDV,K) if STOREV = 'C'\n*                               (LDV,N) if STOREV = 'R'\n*          The matrix V. See further details.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V.\n*          If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n*\n*  TAU     (input) COMPLEX*16 array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i).\n*\n*  T       (output) COMPLEX*16 array, dimension (LDT,K)\n*          The k by k triangular factor T of the block reflector.\n*          If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n*          lower triangular. The rest of the array is not used.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= K.\n*\n\n*  Further Details\n*  ===============\n*\n*  The shape of the matrix V and the storage of the vectors which define\n*  the H(i) is best illustrated by the following example with n = 5 and\n*  k = 3. The elements equal to 1 are not stored; the corresponding\n*  array elements are modified but restored on exit. The rest of the\n*  array is not used.\n*\n*  DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R':\n*\n*               V = (  1       )                 V = (  1 v1 v1 v1 v1 )\n*                   ( v1  1    )                     (     1 v2 v2 v2 )\n*                   ( v1 v2  1 )                     (        1 v3 v3 )\n*                   ( v1 v2 v3 )\n*                   ( v1 v2 v3 )\n*\n*  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R':\n*\n*               V = ( v1 v2 v3 )                 V = ( v1 v1  1       )\n*                   ( v1 v2 v3 )                     ( v2 v2 v2  1    )\n*                   (  1 v2 v3 )                     ( v3 v3 v3 v3  1 )\n*                   (     1 v3 )\n*                   (        1 )\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  t, v = NumRu::Lapack.zlarft( direct, storev, n, v, tau, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_direct = argv[0];
  rblapack_storev = argv[1];
  rblapack_n = argv[2];
  rblapack_v = argv[3];
  rblapack_tau = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  direct = StringValueCStr(rblapack_direct)[0];
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  storev = StringValueCStr(rblapack_storev)[0];
  ldt = k;
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (4th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  if (NA_SHAPE1(rblapack_v) != (lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0))
    rb_raise(rb_eRuntimeError, "shape 1 of v must be %d", lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0);
  if (NA_TYPE(rblapack_v) != NA_DCOMPLEX)
    rblapack_v = na_change_type(rblapack_v, NA_DCOMPLEX);
  v = NA_PTR_TYPE(rblapack_v, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = k;
    rblapack_t = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  t = NA_PTR_TYPE(rblapack_t, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0;
    rblapack_v_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  v_out__ = NA_PTR_TYPE(rblapack_v_out__, doublecomplex*);
  MEMCPY(v_out__, v, doublecomplex, NA_TOTAL(rblapack_v));
  rblapack_v = rblapack_v_out__;
  v = v_out__;

  zlarft_(&direct, &storev, &n, &k, v, &ldv, tau, t, &ldt);

  return rb_ary_new3(2, rblapack_t, rblapack_v);
}

void
init_lapack_zlarft(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlarft", rblapack_zlarft, -1);
}
ruby-lapack-1.7.2/ext/slasd1.c0000644000175000017500000002315512655767573015757 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slasd1_(integer* nl, integer* nr, integer* sqre, real* d, real* alpha, real* beta, real* u, integer* ldu, real* vt, integer* ldvt, integer* idxq, integer* iwork, real* work, integer* info);


static VALUE
rblapack_slasd1(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_nl;
  integer nl; 
  VALUE rblapack_nr;
  integer nr; 
  VALUE rblapack_sqre;
  integer sqre; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_alpha;
  real alpha; 
  VALUE rblapack_beta;
  real beta; 
  VALUE rblapack_u;
  real *u; 
  VALUE rblapack_vt;
  real *vt; 
  VALUE rblapack_idxq;
  integer *idxq; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_u_out__;
  real *u_out__;
  VALUE rblapack_vt_out__;
  real *vt_out__;
  integer *iwork;
  real *work;

  integer ldu;
  integer n;
  integer ldvt;
  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  idxq, info, d, alpha, beta, u, vt = NumRu::Lapack.slasd1( nl, nr, sqre, d, alpha, beta, u, vt, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT, IDXQ, IWORK, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B,\n*  where N = NL + NR + 1 and M = N + SQRE. SLASD1 is called from SLASD0.\n*\n*  A related subroutine SLASD7 handles the case in which the singular\n*  values (and the singular vectors in factored form) are desired.\n*\n*  SLASD1 computes the SVD as follows:\n*\n*                ( D1(in)  0    0     0 )\n*    B = U(in) * (   Z1'   a   Z2'    b ) * VT(in)\n*                (   0     0   D2(in) 0 )\n*\n*      = U(out) * ( D(out) 0) * VT(out)\n*\n*  where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M\n*  with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros\n*  elsewhere; and the entry b is empty if SQRE = 0.\n*\n*  The left singular vectors of the original matrix are stored in U, and\n*  the transpose of the right singular vectors are stored in VT, and the\n*  singular values are in D.  The algorithm consists of three stages:\n*\n*     The first stage consists of deflating the size of the problem\n*     when there are multiple singular values or when there are zeros in\n*     the Z vector.  For each such occurrence the dimension of the\n*     secular equation problem is reduced by one.  This stage is\n*     performed by the routine SLASD2.\n*\n*     The second stage consists of calculating the updated\n*     singular values. This is done by finding the square roots of the\n*     roots of the secular equation via the routine SLASD4 (as called\n*     by SLASD3). This routine also calculates the singular vectors of\n*     the current problem.\n*\n*     The final stage consists of computing the updated singular vectors\n*     directly using the updated singular values.  The singular vectors\n*     for the current problem are multiplied with the singular vectors\n*     from the overall problem.\n*\n\n*  Arguments\n*  =========\n*\n*  NL     (input) INTEGER\n*         The row dimension of the upper block.  NL >= 1.\n*\n*  NR     (input) INTEGER\n*         The row dimension of the lower block.  NR >= 1.\n*\n*  SQRE   (input) INTEGER\n*         = 0: the lower block is an NR-by-NR square matrix.\n*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n*         The bidiagonal matrix has row dimension N = NL + NR + 1,\n*         and column dimension M = N + SQRE.\n*\n*  D      (input/output) REAL array, dimension (NL+NR+1).\n*         N = NL+NR+1\n*         On entry D(1:NL,1:NL) contains the singular values of the\n*         upper block; and D(NL+2:N) contains the singular values of\n*         the lower block. On exit D(1:N) contains the singular values\n*         of the modified matrix.\n*\n*  ALPHA  (input/output) REAL\n*         Contains the diagonal element associated with the added row.\n*\n*  BETA   (input/output) REAL\n*         Contains the off-diagonal element associated with the added\n*         row.\n*\n*  U      (input/output) REAL array, dimension (LDU,N)\n*         On entry U(1:NL, 1:NL) contains the left singular vectors of\n*         the upper block; U(NL+2:N, NL+2:N) contains the left singular\n*         vectors of the lower block. On exit U contains the left\n*         singular vectors of the bidiagonal matrix.\n*\n*  LDU    (input) INTEGER\n*         The leading dimension of the array U.  LDU >= max( 1, N ).\n*\n*  VT     (input/output) REAL array, dimension (LDVT,M)\n*         where M = N + SQRE.\n*         On entry VT(1:NL+1, 1:NL+1)' contains the right singular\n*         vectors of the upper block; VT(NL+2:M, NL+2:M)' contains\n*         the right singular vectors of the lower block. On exit\n*         VT' contains the right singular vectors of the\n*         bidiagonal matrix.\n*\n*  LDVT   (input) INTEGER\n*         The leading dimension of the array VT.  LDVT >= max( 1, M ).\n*\n*  IDXQ  (output) INTEGER array, dimension (N)\n*         This contains the permutation which will reintegrate the\n*         subproblem just solved back into sorted order, i.e.\n*         D( IDXQ( I = 1, N ) ) will be in ascending order.\n*\n*  IWORK  (workspace) INTEGER array, dimension (4*N)\n*\n*  WORK   (workspace) REAL array, dimension (3*M**2+2*M)\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 = 1, a singular value did not converge\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  idxq, info, d, alpha, beta, u, vt = NumRu::Lapack.slasd1( nl, nr, sqre, d, alpha, beta, u, vt, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_nl = argv[0];
  rblapack_nr = argv[1];
  rblapack_sqre = argv[2];
  rblapack_d = argv[3];
  rblapack_alpha = argv[4];
  rblapack_beta = argv[5];
  rblapack_u = argv[6];
  rblapack_vt = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  nl = NUM2INT(rblapack_nl);
  sqre = NUM2INT(rblapack_sqre);
  alpha = (real)NUM2DBL(rblapack_alpha);
  if (!NA_IsNArray(rblapack_u))
    rb_raise(rb_eArgError, "u (7th argument) must be NArray");
  if (NA_RANK(rblapack_u) != 2)
    rb_raise(rb_eArgError, "rank of u (7th argument) must be %d", 2);
  ldu = NA_SHAPE0(rblapack_u);
  n = NA_SHAPE1(rblapack_u);
  if (NA_TYPE(rblapack_u) != NA_SFLOAT)
    rblapack_u = na_change_type(rblapack_u, NA_SFLOAT);
  u = NA_PTR_TYPE(rblapack_u, real*);
  m = n + sqre;
  nr = NUM2INT(rblapack_nr);
  beta = (real)NUM2DBL(rblapack_beta);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != (nl+nr+1))
    rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", nl+nr+1);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_vt))
    rb_raise(rb_eArgError, "vt (8th argument) must be NArray");
  if (NA_RANK(rblapack_vt) != 2)
    rb_raise(rb_eArgError, "rank of vt (8th argument) must be %d", 2);
  ldvt = NA_SHAPE0(rblapack_vt);
  if (NA_SHAPE1(rblapack_vt) != m)
    rb_raise(rb_eRuntimeError, "shape 1 of vt must be n + sqre");
  if (NA_TYPE(rblapack_vt) != NA_SFLOAT)
    rblapack_vt = na_change_type(rblapack_vt, NA_SFLOAT);
  vt = NA_PTR_TYPE(rblapack_vt, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_idxq = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  idxq = NA_PTR_TYPE(rblapack_idxq, integer*);
  {
    na_shape_t shape[1];
    shape[0] = nl+nr+1;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = n;
    rblapack_u_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  u_out__ = NA_PTR_TYPE(rblapack_u_out__, real*);
  MEMCPY(u_out__, u, real, NA_TOTAL(rblapack_u));
  rblapack_u = rblapack_u_out__;
  u = u_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvt;
    shape[1] = m;
    rblapack_vt_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vt_out__ = NA_PTR_TYPE(rblapack_vt_out__, real*);
  MEMCPY(vt_out__, vt, real, NA_TOTAL(rblapack_vt));
  rblapack_vt = rblapack_vt_out__;
  vt = vt_out__;
  iwork = ALLOC_N(integer, (4*n));
  work = ALLOC_N(real, (3*pow(m,2)+2*m));

  slasd1_(&nl, &nr, &sqre, d, &alpha, &beta, u, &ldu, vt, &ldvt, idxq, iwork, work, &info);

  free(iwork);
  free(work);
  rblapack_info = INT2NUM(info);
  rblapack_alpha = rb_float_new((double)alpha);
  rblapack_beta = rb_float_new((double)beta);
  return rb_ary_new3(7, rblapack_idxq, rblapack_info, rblapack_d, rblapack_alpha, rblapack_beta, rblapack_u, rblapack_vt);
}

void
init_lapack_slasd1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slasd1", rblapack_slasd1, -1);
}
ruby-lapack-1.7.2/ext/ssyconv.c0000644000175000017500000001060212502221012016221 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssyconv_(char* uplo, char* way, integer* n, real* a, integer* lda, integer* ipiv, real* work, integer* info);


static VALUE
rblapack_ssyconv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_way;
  char way; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  real *work;

  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  info = NumRu::Lapack.ssyconv( uplo, way, a, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSYCONV( UPLO, WAY, N, A, LDA, IPIV, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSYCONV convert A given by TRF into L and D and vice-versa.\n*  Get Non-diag elements of D (returned in workspace) and \n*  apply or reverse permutation done in TRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n* \n*  WAY     (input) CHARACTER*1\n*          = 'C': Convert \n*          = 'R': Revert\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) REAL array, dimension (LDA,N)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by SSYTRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by SSYTRF.\n*\n* WORK     (workspace) REAL array, dimension (N)\n*\n* LWORK    (input) INTEGER\n*          The length of WORK.  LWORK >=1. \n*          LWORK = N\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info = NumRu::Lapack.ssyconv( uplo, way, a, ipiv, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_way = argv[1];
  rblapack_a = argv[2];
  rblapack_ipiv = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  way = StringValueCStr(rblapack_way)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  work = ALLOC_N(real, (MAX(1,n)));

  ssyconv_(&uplo, &way, &n, a, &lda, ipiv, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rblapack_info;
}

void
init_lapack_ssyconv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssyconv", rblapack_ssyconv, -1);
}
ruby-lapack-1.7.2/ext/cpptrf.c0000644000175000017500000001052412502221022016017 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cpptrf_(char* uplo, integer* n, complex* ap, integer* info);


static VALUE
rblapack_cpptrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  complex *ap_out__;


  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  info, ap = NumRu::Lapack.cpptrf( uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPPTRF( UPLO, N, AP, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPPTRF computes the Cholesky factorization of a complex Hermitian\n*  positive definite matrix A stored in packed format.\n*\n*  The factorization has the form\n*     A = U**H * U,  if UPLO = 'U', or\n*     A = L  * L**H,  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is lower triangular.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          See below for further details.\n*\n*          On exit, if INFO = 0, the triangular factor U or L from the\n*          Cholesky factorization A = U**H*U or A = L*L**H, in the same\n*          storage format as A.\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 leading minor of order i is not\n*                positive definite, and the factorization could not be\n*                completed.\n*\n\n*  Further Details\n*  ===============\n*\n*  The packed storage scheme is illustrated by the following example\n*  when N = 4, UPLO = 'U':\n*\n*  Two-dimensional storage of the Hermitian matrix A:\n*\n*     a11 a12 a13 a14\n*         a22 a23 a24\n*             a33 a34     (aij = conjg(aji))\n*                 a44\n*\n*  Packed storage of the upper triangle of A:\n*\n*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ap = NumRu::Lapack.cpptrf( uplo, n, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_n = argv[1];
  rblapack_ap = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
  MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  cpptrf_(&uplo, &n, ap, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ap);
}

void
init_lapack_cpptrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cpptrf", rblapack_cpptrf, -1);
}
ruby-lapack-1.7.2/ext/dlae2.c0000644000175000017500000000576612502221021015523 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlae2_(doublereal* a, doublereal* b, doublereal* c, doublereal* rt1, doublereal* rt2);


static VALUE
rblapack_dlae2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublereal a; 
  VALUE rblapack_b;
  doublereal b; 
  VALUE rblapack_c;
  doublereal c; 
  VALUE rblapack_rt1;
  doublereal rt1; 
  VALUE rblapack_rt2;
  doublereal rt2; 


  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  rt1, rt2 = NumRu::Lapack.dlae2( a, b, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAE2( A, B, C, RT1, RT2 )\n\n*  Purpose\n*  =======\n*\n*  DLAE2  computes the eigenvalues of a 2-by-2 symmetric matrix\n*     [  A   B  ]\n*     [  B   C  ].\n*  On return, RT1 is the eigenvalue of larger absolute value, and RT2\n*  is the eigenvalue of smaller absolute value.\n*\n\n*  Arguments\n*  =========\n*\n*  A       (input) DOUBLE PRECISION\n*          The (1,1) element of the 2-by-2 matrix.\n*\n*  B       (input) DOUBLE PRECISION\n*          The (1,2) and (2,1) elements of the 2-by-2 matrix.\n*\n*  C       (input) DOUBLE PRECISION\n*          The (2,2) element of the 2-by-2 matrix.\n*\n*  RT1     (output) DOUBLE PRECISION\n*          The eigenvalue of larger absolute value.\n*\n*  RT2     (output) DOUBLE PRECISION\n*          The eigenvalue of smaller absolute value.\n*\n\n*  Further Details\n*  ===============\n*\n*  RT1 is accurate to a few ulps barring over/underflow.\n*\n*  RT2 may be inaccurate if there is massive cancellation in the\n*  determinant A*C-B*B; higher precision or correctly rounded or\n*  correctly truncated arithmetic would be needed to compute RT2\n*  accurately in all cases.\n*\n*  Overflow is possible only if RT1 is within a factor of 5 of overflow.\n*  Underflow is harmless if the input data is 0 or exceeds\n*     underflow_threshold / macheps.\n*\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rt1, rt2 = NumRu::Lapack.dlae2( a, b, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  rblapack_c = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  a = NUM2DBL(rblapack_a);
  c = NUM2DBL(rblapack_c);
  b = NUM2DBL(rblapack_b);

  dlae2_(&a, &b, &c, &rt1, &rt2);

  rblapack_rt1 = rb_float_new((double)rt1);
  rblapack_rt2 = rb_float_new((double)rt2);
  return rb_ary_new3(2, rblapack_rt1, rblapack_rt2);
}

void
init_lapack_dlae2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlae2", rblapack_dlae2, -1);
}
ruby-lapack-1.7.2/ext/sppsv.c0000644000175000017500000001423312502221017015701 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sppsv_(char* uplo, integer* n, integer* nrhs, real* ap, real* b, integer* ldb, integer* info);


static VALUE
rblapack_sppsv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  real *ap_out__;
  VALUE rblapack_b_out__;
  real *b_out__;

  integer ldb;
  integer nrhs;

  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  info, ap, b = NumRu::Lapack.sppsv( uplo, n, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPPSV( UPLO, N, NRHS, AP, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPPSV computes the solution to a real system of linear equations\n*     A * X = B,\n*  where A is an N-by-N symmetric positive definite matrix stored in\n*  packed format and X and B are N-by-NRHS matrices.\n*\n*  The Cholesky decomposition is used to factor A as\n*     A = U**T* U,  if UPLO = 'U', or\n*     A = L * L**T,  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is a lower triangular\n*  matrix.  The factored form of A is then used to solve the system of\n*  equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AP      (input/output) REAL array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          See below for further details.  \n*\n*          On exit, if INFO = 0, the factor U or L from the Cholesky\n*          factorization A = U**T*U or A = L*L**T, in the same storage\n*          format as A.\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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 leading minor of order i of A is not\n*                positive definite, so the factorization could not be\n*                completed, and the solution has not been computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  The packed storage scheme is illustrated by the following example\n*  when N = 4, UPLO = 'U':\n*\n*  Two-dimensional storage of the symmetric matrix A:\n*\n*     a11 a12 a13 a14\n*         a22 a23 a24\n*             a33 a34     (aij = conjg(aji))\n*                 a44\n*\n*  Packed storage of the upper triangle of A:\n*\n*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n*  =====================================================================\n*\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SPPTRF, SPPTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ap, b = NumRu::Lapack.sppsv( uplo, n, ap, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_n = argv[1];
  rblapack_ap = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, real*);
  MEMCPY(ap_out__, ap, real, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  sppsv_(&uplo, &n, &nrhs, ap, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_ap, rblapack_b);
}

void
init_lapack_sppsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sppsv", rblapack_sppsv, -1);
}
ruby-lapack-1.7.2/ext/slarfx.c0000644000175000017500000001040512502221020016014 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slarfx_(char* side, integer* m, integer* n, real* v, real* tau, real* c, integer* ldc, real* work);


static VALUE
rblapack_slarfx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_v;
  real *v; 
  VALUE rblapack_tau;
  real tau; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_c_out__;
  real *c_out__;
  real *work;

  integer m;
  integer ldc;
  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  c = NumRu::Lapack.slarfx( side, v, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )\n\n*  Purpose\n*  =======\n*\n*  SLARFX applies a real elementary reflector H to a real m by n\n*  matrix C, from either the left or the right. H is represented in the\n*  form\n*\n*        H = I - tau * v * v'\n*\n*  where tau is a real scalar and v is a real vector.\n*\n*  If tau = 0, then H is taken to be the unit matrix\n*\n*  This version uses inline code if H has order < 11.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': form  H * C\n*          = 'R': form  C * H\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C.\n*\n*  V       (input) REAL array, dimension (M) if SIDE = 'L'\n*                                     or (N) if SIDE = 'R'\n*          The vector v in the representation of H.\n*\n*  TAU     (input) REAL\n*          The value tau in the representation of H.\n*\n*  C       (input/output) REAL array, dimension (LDC,N)\n*          On entry, the m by n matrix C.\n*          On exit, C is overwritten by the matrix H * C if SIDE = 'L',\n*          or C * H if SIDE = 'R'.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDA >= (1,M).\n*\n*  WORK    (workspace) REAL array, dimension\n*                      (N) if SIDE = 'L'\n*                      or (M) if SIDE = 'R'\n*          WORK is not referenced if H has order < 11.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.slarfx( side, v, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_side = argv[0];
  rblapack_v = argv[1];
  rblapack_tau = argv[2];
  rblapack_c = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  tau = (real)NUM2DBL(rblapack_tau);
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (2th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 1)
    rb_raise(rb_eArgError, "rank of v (2th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_v);
  if (NA_TYPE(rblapack_v) != NA_SFLOAT)
    rblapack_v = na_change_type(rblapack_v, NA_SFLOAT);
  v = NA_PTR_TYPE(rblapack_v, real*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (4th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (4th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(real, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  slarfx_(&side, &m, &n, v, &tau, c, &ldc, work);

  free(work);
  return rblapack_c;
}

void
init_lapack_slarfx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slarfx", rblapack_slarfx, -1);
}
ruby-lapack-1.7.2/ext/zlaswp.c0000644000175000017500000001077212502221025016051 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlaswp_(integer* n, doublecomplex* a, integer* lda, integer* k1, integer* k2, integer* ipiv, integer* incx);


static VALUE
rblapack_zlaswp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_k1;
  integer k1; 
  VALUE rblapack_k2;
  integer k2; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_a_out__;
  doublecomplex *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  a = NumRu::Lapack.zlaswp( a, k1, k2, ipiv, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX )\n\n*  Purpose\n*  =======\n*\n*  ZLASWP performs a series of row interchanges on the matrix A.\n*  One row interchange is initiated for each of rows K1 through K2 of A.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the matrix of column dimension N to which the row\n*          interchanges will be applied.\n*          On exit, the permuted matrix.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*\n*  K1      (input) INTEGER\n*          The first element of IPIV for which a row interchange will\n*          be done.\n*\n*  K2      (input) INTEGER\n*          The last element of IPIV for which a row interchange will\n*          be done.\n*\n*  IPIV    (input) INTEGER array, dimension (K2*abs(INCX))\n*          The vector of pivot indices.  Only the elements in positions\n*          K1 through K2 of IPIV are accessed.\n*          IPIV(K) = L implies rows K and L are to be interchanged.\n*\n*  INCX    (input) INTEGER\n*          The increment between successive values of IPIV.  If IPIV\n*          is negative, the pivots are applied in reverse order.\n*\n\n*  Further Details\n*  ===============\n*\n*  Modified by\n*   R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, I1, I2, INC, IP, IX, IX0, J, K, N32\n      COMPLEX*16         TEMP\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  a = NumRu::Lapack.zlaswp( a, k1, k2, ipiv, incx, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_a = argv[0];
  rblapack_k1 = argv[1];
  rblapack_k2 = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_incx = argv[4];
  if (argc == 5) {
  } 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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  k2 = NUM2INT(rblapack_k2);
  incx = NUM2INT(rblapack_incx);
  k1 = NUM2INT(rblapack_k1);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != (k2*abs(incx)))
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be %d", k2*abs(incx));
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zlaswp_(&n, a, &lda, &k1, &k2, ipiv, &incx);

  return rblapack_a;
}

void
init_lapack_zlaswp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlaswp", rblapack_zlaswp, -1);
}
ruby-lapack-1.7.2/ext/cla_herpvgrw.c0000644000175000017500000001401312502221015017203 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real cla_herpvgrw_(char* uplo, integer* n, integer* info, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, complex* work);


static VALUE
rblapack_cla_herpvgrw(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack___out__;
  real __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  __out__ = NumRu::Lapack.cla_herpvgrw( uplo, info, a, af, ipiv, work, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL FUNCTION CLA_HERPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, WORK )\n\n*  Purpose\n*  =======\n* \n*  CLA_HERPVGRW computes the reciprocal pivot growth factor\n*  norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n*  much less than 1, the stability of the LU factorization of the\n*  (equilibrated) matrix A could be poor. This also means that the\n*  solution X, estimated condition numbers, and error bounds could be\n*  unreliable.\n*\n\n*  Arguments\n*  =========\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     INFO    (input) INTEGER\n*     The value of INFO returned from SSYTRF, .i.e., the pivot in\n*     column INFO is exactly 0.\n*\n*     NCOLS   (input) INTEGER\n*     The number of columns of the matrix A. NCOLS >= 0.\n*\n*     A       (input) COMPLEX array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX array, dimension (LDAF,N)\n*     The block diagonal matrix D and the multipliers used to\n*     obtain the factor U or L as computed by CHETRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     Details of the interchanges and the block structure of D\n*     as determined by CHETRF.\n*\n*     WORK    (input) COMPLEX array, dimension (2*N)\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            NCOLS, I, J, K, KP\n      REAL               AMAX, UMAX, RPVGRW, TMP\n      LOGICAL            UPPER, LSAME\n      COMPLEX            ZDUM\n*     ..\n*     .. External Functions ..\n      EXTERNAL           LSAME, CLASET\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, REAL, AIMAG, MAX, MIN\n*     ..\n*     .. Statement Functions ..\n      REAL               CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( ZDUM ) = ABS( REAL ( ZDUM ) ) + ABS( AIMAG ( ZDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.cla_herpvgrw( uplo, info, a, af, ipiv, work, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_info = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_work = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  info = NUM2INT(rblapack_info);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (6th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
  if (NA_TYPE(rblapack_work) != NA_SCOMPLEX)
    rblapack_work = na_change_type(rblapack_work, NA_SCOMPLEX);
  work = NA_PTR_TYPE(rblapack_work, complex*);

  __out__ = cla_herpvgrw_(&uplo, &n, &info, a, &lda, af, &ldaf, ipiv, work);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_cla_herpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cla_herpvgrw", rblapack_cla_herpvgrw, -1);
}
ruby-lapack-1.7.2/ext/ssbtrd.c0000644000175000017500000001543512502221013016030 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssbtrd_(char* vect, char* uplo, integer* n, integer* kd, real* ab, integer* ldab, real* d, real* e, real* q, integer* ldq, real* work, integer* info);


static VALUE
rblapack_ssbtrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_vect;
  char vect; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_q;
  real *q; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  real *ab_out__;
  VALUE rblapack_q_out__;
  real *q_out__;
  real *work;

  integer ldab;
  integer n;
  integer ldq;

  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  d, e, info, ab, q = NumRu::Lapack.ssbtrd( vect, uplo, kd, ab, q, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSBTRD reduces a real symmetric band matrix A to symmetric\n*  tridiagonal form T by an orthogonal similarity transformation:\n*  Q**T * A * Q = T.\n*\n\n*  Arguments\n*  =========\n*\n*  VECT    (input) CHARACTER*1\n*          = 'N':  do not form Q;\n*          = 'V':  form Q;\n*          = 'U':  update a matrix X, by forming X*Q.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) REAL array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*          On exit, the diagonal elements of AB are overwritten by the\n*          diagonal elements of the tridiagonal matrix T; if KD > 0, the\n*          elements on the first superdiagonal (if UPLO = 'U') or the\n*          first subdiagonal (if UPLO = 'L') are overwritten by the\n*          off-diagonal elements of T; the rest of AB is overwritten by\n*          values generated during the reduction.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  D       (output) REAL array, dimension (N)\n*          The diagonal elements of the tridiagonal matrix T.\n*\n*  E       (output) REAL array, dimension (N-1)\n*          The off-diagonal elements of the tridiagonal matrix T:\n*          E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.\n*\n*  Q       (input/output) REAL array, dimension (LDQ,N)\n*          On entry, if VECT = 'U', then Q must contain an N-by-N\n*          matrix X; if VECT = 'N' or 'V', then Q need not be set.\n*\n*          On exit:\n*          if VECT = 'V', Q contains the N-by-N orthogonal matrix Q;\n*          if VECT = 'U', Q contains the product X*Q;\n*          if VECT = 'N', the array Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.\n*          LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.\n*\n*  WORK    (workspace) REAL array, dimension (N)\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*  Modified by Linda Kaufman, Bell Labs.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, info, ab, q = NumRu::Lapack.ssbtrd( vect, uplo, kd, ab, q, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_vect = argv[0];
  rblapack_uplo = argv[1];
  rblapack_kd = argv[2];
  rblapack_ab = argv[3];
  rblapack_q = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  vect = StringValueCStr(rblapack_vect)[0];
  kd = NUM2INT(rblapack_kd);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (5th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  n = NA_SHAPE1(rblapack_q);
  if (NA_TYPE(rblapack_q) != NA_SFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
  q = NA_PTR_TYPE(rblapack_q, real*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of q");
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, real*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
  MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
  MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  work = ALLOC_N(real, (n));

  ssbtrd_(&vect, &uplo, &n, &kd, ab, &ldab, d, e, q, &ldq, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_d, rblapack_e, rblapack_info, rblapack_ab, rblapack_q);
}

void
init_lapack_ssbtrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssbtrd", rblapack_ssbtrd, -1);
}
ruby-lapack-1.7.2/ext/slanv2.c0000644000175000017500000001000112502221021015713 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slanv2_(real* a, real* b, real* c, real* d, real* rt1r, real* rt1i, real* rt2r, real* rt2i, real* cs, real* sn);


static VALUE
rblapack_slanv2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  real a; 
  VALUE rblapack_b;
  real b; 
  VALUE rblapack_c;
  real c; 
  VALUE rblapack_d;
  real d; 
  VALUE rblapack_rt1r;
  real rt1r; 
  VALUE rblapack_rt1i;
  real rt1i; 
  VALUE rblapack_rt2r;
  real rt2r; 
  VALUE rblapack_rt2i;
  real rt2i; 
  VALUE rblapack_cs;
  real cs; 
  VALUE rblapack_sn;
  real sn; 


  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  rt1r, rt1i, rt2r, rt2i, cs, sn, a, b, c, d = NumRu::Lapack.slanv2( a, b, c, d, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN )\n\n*  Purpose\n*  =======\n*\n*  SLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric\n*  matrix in standard form:\n*\n*       [ A  B ] = [ CS -SN ] [ AA  BB ] [ CS  SN ]\n*       [ C  D ]   [ SN  CS ] [ CC  DD ] [-SN  CS ]\n*\n*  where either\n*  1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or\n*  2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex\n*  conjugate eigenvalues.\n*\n\n*  Arguments\n*  =========\n*\n*  A       (input/output) REAL            \n*  B       (input/output) REAL            \n*  C       (input/output) REAL            \n*  D       (input/output) REAL            \n*          On entry, the elements of the input matrix.\n*          On exit, they are overwritten by the elements of the\n*          standardised Schur form.\n*\n*  RT1R    (output) REAL \n*  RT1I    (output) REAL            \n*  RT2R    (output) REAL            \n*  RT2I    (output) REAL            \n*          The real and imaginary parts of the eigenvalues. If the\n*          eigenvalues are a complex conjugate pair, RT1I > 0.\n*\n*  CS      (output) REAL            \n*  SN      (output) REAL            \n*          Parameters of the rotation matrix.\n*\n\n*  Further Details\n*  ===============\n*\n*  Modified by V. Sima, Research Institute for Informatics, Bucharest,\n*  Romania, to reduce the risk of cancellation errors,\n*  when computing real eigenvalues, and to ensure, if possible, that\n*  abs(RT1R) >= abs(RT2R).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rt1r, rt1i, rt2r, rt2i, cs, sn, a, b, c, d = NumRu::Lapack.slanv2( a, b, c, d, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  rblapack_c = argv[2];
  rblapack_d = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  a = (real)NUM2DBL(rblapack_a);
  c = (real)NUM2DBL(rblapack_c);
  b = (real)NUM2DBL(rblapack_b);
  d = (real)NUM2DBL(rblapack_d);

  slanv2_(&a, &b, &c, &d, &rt1r, &rt1i, &rt2r, &rt2i, &cs, &sn);

  rblapack_rt1r = rb_float_new((double)rt1r);
  rblapack_rt1i = rb_float_new((double)rt1i);
  rblapack_rt2r = rb_float_new((double)rt2r);
  rblapack_rt2i = rb_float_new((double)rt2i);
  rblapack_cs = rb_float_new((double)cs);
  rblapack_sn = rb_float_new((double)sn);
  rblapack_a = rb_float_new((double)a);
  rblapack_b = rb_float_new((double)b);
  rblapack_c = rb_float_new((double)c);
  rblapack_d = rb_float_new((double)d);
  return rb_ary_new3(10, rblapack_rt1r, rblapack_rt1i, rblapack_rt2r, rblapack_rt2i, rblapack_cs, rblapack_sn, rblapack_a, rblapack_b, rblapack_c, rblapack_d);
}

void
init_lapack_slanv2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slanv2", rblapack_slanv2, -1);
}
ruby-lapack-1.7.2/ext/zsyrfs.c0000644000175000017500000002173012502221024016064 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zsyrfs_(char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zsyrfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.zsyrfs( uplo, a, af, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZSYRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is symmetric indefinite, and\n*  provides error bounds and backward error estimates for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          The symmetric matrix A.  If UPLO = 'U', the leading N-by-N\n*          upper triangular part of A contains the upper triangular part\n*          of the matrix A, and the strictly lower triangular part of A\n*          is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*          triangular part of A contains the lower triangular part of\n*          the matrix A, and the strictly upper triangular part of A is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AF      (input) COMPLEX*16 array, dimension (LDAF,N)\n*          The factored form of the matrix A.  AF contains the block\n*          diagonal matrix D and the multipliers used to obtain the\n*          factor U or L from the factorization A = U*D*U**T or\n*          A = L*D*L**T as computed by ZSYTRF.\n*\n*  LDAF    (input) INTEGER\n*          The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by ZSYTRF.\n*\n*  B       (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) COMPLEX*16 array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by ZSYTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.zsyrfs( uplo, a, af, ipiv, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_b = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (n));

  zsyrfs_(&uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_zsyrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zsyrfs", rblapack_zsyrfs, -1);
}
ruby-lapack-1.7.2/ext/cgeesx.c0000644000175000017500000002500012502221015015774 0ustar  uwabamiuwabami#include "rb_lapack.h"

static logical
rblapack_select(complex *arg0){
  VALUE rblapack_arg0;

  VALUE rblapack_ret;
  logical ret;

  rblapack_arg0 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg0->r)), rb_float_new((double)(arg0->i)));

  rblapack_ret = rb_yield_values(1, rblapack_arg0);

  ret = (rblapack_ret == Qtrue);
  return ret;
}

extern VOID cgeesx_(char* jobvs, char* sort, L_fp select, char* sense, integer* n, complex* a, integer* lda, integer* sdim, complex* w, complex* vs, integer* ldvs, real* rconde, real* rcondv, complex* work, integer* lwork, real* rwork, logical* bwork, integer* info);


static VALUE
rblapack_cgeesx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvs;
  char jobvs; 
  VALUE rblapack_sort;
  char sort; 
  VALUE rblapack_sense;
  char sense; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_sdim;
  integer sdim; 
  VALUE rblapack_w;
  complex *w; 
  VALUE rblapack_vs;
  complex *vs; 
  VALUE rblapack_rconde;
  real rconde; 
  VALUE rblapack_rcondv;
  real rcondv; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  real *rwork;
  logical *bwork;

  integer lda;
  integer n;
  integer ldvs;

  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  sdim, w, vs, rconde, rcondv, work, info, a = NumRu::Lapack.cgeesx( jobvs, sort, sense, a, [:lwork => lwork, :usage => usage, :help => help]){|a| ... }\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, W, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, RWORK, BWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGEESX computes for an N-by-N complex nonsymmetric matrix A, the\n*  eigenvalues, the Schur form T, and, optionally, the matrix of Schur\n*  vectors Z.  This gives the Schur factorization A = Z*T*(Z**H).\n*\n*  Optionally, it also orders the eigenvalues on the diagonal of the\n*  Schur form so that selected eigenvalues are at the top left;\n*  computes a reciprocal condition number for the average of the\n*  selected eigenvalues (RCONDE); and computes a reciprocal condition\n*  number for the right invariant subspace corresponding to the\n*  selected eigenvalues (RCONDV).  The leading columns of Z form an\n*  orthonormal basis for this invariant subspace.\n*\n*  For further explanation of the reciprocal condition numbers RCONDE\n*  and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where\n*  these quantities are called s and sep respectively).\n*\n*  A complex matrix is in Schur form if it is upper triangular.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVS   (input) CHARACTER*1\n*          = 'N': Schur vectors are not computed;\n*          = 'V': Schur vectors are computed.\n*\n*  SORT    (input) CHARACTER*1\n*          Specifies whether or not to order the eigenvalues on the\n*          diagonal of the Schur form.\n*          = 'N': Eigenvalues are not ordered;\n*          = 'S': Eigenvalues are ordered (see SELECT).\n*\n*  SELECT  (external procedure) LOGICAL FUNCTION of one COMPLEX argument\n*          SELECT must be declared EXTERNAL in the calling subroutine.\n*          If SORT = 'S', SELECT is used to select eigenvalues to order\n*          to the top left of the Schur form.\n*          If SORT = 'N', SELECT is not referenced.\n*          An eigenvalue W(j) is selected if SELECT(W(j)) is true.\n*\n*  SENSE   (input) CHARACTER*1\n*          Determines which reciprocal condition numbers are computed.\n*          = 'N': None are computed;\n*          = 'E': Computed for average of selected eigenvalues only;\n*          = 'V': Computed for selected right invariant subspace only;\n*          = 'B': Computed for both.\n*          If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA, N)\n*          On entry, the N-by-N matrix A.\n*          On exit, A is overwritten by its Schur form T.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  SDIM    (output) INTEGER\n*          If SORT = 'N', SDIM = 0.\n*          If SORT = 'S', SDIM = number of eigenvalues for which\n*                         SELECT is true.\n*\n*  W       (output) COMPLEX array, dimension (N)\n*          W contains the computed eigenvalues, in the same order\n*          that they appear on the diagonal of the output Schur form T.\n*\n*  VS      (output) COMPLEX array, dimension (LDVS,N)\n*          If JOBVS = 'V', VS contains the unitary matrix Z of Schur\n*          vectors.\n*          If JOBVS = 'N', VS is not referenced.\n*\n*  LDVS    (input) INTEGER\n*          The leading dimension of the array VS.  LDVS >= 1, and if\n*          JOBVS = 'V', LDVS >= N.\n*\n*  RCONDE  (output) REAL\n*          If SENSE = 'E' or 'B', RCONDE contains the reciprocal\n*          condition number for the average of the selected eigenvalues.\n*          Not referenced if SENSE = 'N' or 'V'.\n*\n*  RCONDV  (output) REAL\n*          If SENSE = 'V' or 'B', RCONDV contains the reciprocal\n*          condition number for the selected right invariant subspace.\n*          Not referenced if SENSE = 'N' or 'E'.\n*\n*  WORK    (workspace/output) COMPLEX 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,2*N).\n*          Also, if SENSE = 'E' or 'V' or 'B', LWORK >= 2*SDIM*(N-SDIM),\n*          where SDIM is the number of selected eigenvalues computed by\n*          this routine.  Note that 2*SDIM*(N-SDIM) <= N*N/2. Note also\n*          that an error is only returned if LWORK < max(1,2*N), but if\n*          SENSE = 'E' or 'V' or 'B' this may not be large enough.\n*          For good performance, LWORK must generally be larger.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates upper bound on the optimal size of the\n*          array WORK, returns this value as the first entry of the WORK\n*          array, and no error message related to LWORK is issued by\n*          XERBLA.\n*\n*  RWORK   (workspace) REAL array, dimension (N)\n*\n*  BWORK   (workspace) LOGICAL array, dimension (N)\n*          Not referenced if SORT = 'N'.\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, and i is\n*             <= N: the QR algorithm failed to compute all the\n*                   eigenvalues; elements 1:ILO-1 and i+1:N of W\n*                   contain those eigenvalues which have converged; if\n*                   JOBVS = 'V', VS contains the transformation which\n*                   reduces A to its partially converged Schur form.\n*             = N+1: the eigenvalues could not be reordered because some\n*                   eigenvalues were too close to separate (the problem\n*                   is very ill-conditioned);\n*             = N+2: after reordering, roundoff changed values of some\n*                   complex eigenvalues so that leading eigenvalues in\n*                   the Schur form no longer satisfy SELECT=.TRUE.  This\n*                   could also be caused by underflow due to scaling.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sdim, w, vs, rconde, rcondv, work, info, a = NumRu::Lapack.cgeesx( jobvs, sort, sense, a, [:lwork => lwork, :usage => usage, :help => help]){|a| ... }\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_jobvs = argv[0];
  rblapack_sort = argv[1];
  rblapack_sense = argv[2];
  rblapack_a = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  jobvs = StringValueCStr(rblapack_jobvs)[0];
  sense = StringValueCStr(rblapack_sense)[0];
  sort = StringValueCStr(rblapack_sort)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  ldvs = lsame_(&jobvs,"V") ? n : 1;
  if (rblapack_lwork == Qnil)
    lwork = (lsame_(&sense,"E")||lsame_(&sense,"V")||lsame_(&sense,"B")) ? n*n/2 : 2*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvs;
    shape[1] = n;
    rblapack_vs = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  vs = NA_PTR_TYPE(rblapack_vs, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  rwork = ALLOC_N(real, (n));
  bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));

  cgeesx_(&jobvs, &sort, rblapack_select, &sense, &n, a, &lda, &sdim, w, vs, &ldvs, &rconde, &rcondv, work, &lwork, rwork, bwork, &info);

  free(rwork);
  free(bwork);
  rblapack_sdim = INT2NUM(sdim);
  rblapack_rconde = rb_float_new((double)rconde);
  rblapack_rcondv = rb_float_new((double)rcondv);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_sdim, rblapack_w, rblapack_vs, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_cgeesx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgeesx", rblapack_cgeesx, -1);
}
ruby-lapack-1.7.2/ext/claqr4.c0000644000175000017500000002521512502221020015710 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID claqr4_(logical* wantt, logical* wantz, integer* n, integer* ilo, integer* ihi, complex* h, integer* ldh, complex* w, integer* iloz, integer* ihiz, complex* z, integer* ldz, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_claqr4(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantt;
  logical wantt; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_h;
  complex *h; 
  VALUE rblapack_iloz;
  integer iloz; 
  VALUE rblapack_ihiz;
  integer ihiz; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_w;
  complex *w; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_h_out__;
  complex *h_out__;
  VALUE rblapack_z_out__;
  complex *z_out__;

  integer ldh;
  integer n;
  integer ldz;
  integer ihi;

  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  w, work, info, h, z = NumRu::Lapack.claqr4( wantt, wantz, ilo, h, iloz, ihiz, z, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     CLAQR4 computes the eigenvalues of a Hessenberg matrix H\n*     and, optionally, the matrices T and Z from the Schur decomposition\n*     H = Z T Z**H, where T is an upper triangular matrix (the\n*     Schur form), and Z is the unitary matrix of Schur vectors.\n*\n*     Optionally Z may be postmultiplied into an input unitary\n*     matrix Q so that this routine can give the Schur factorization\n*     of a matrix A which has been reduced to the Hessenberg form H\n*     by the unitary matrix Q:  A = Q*H*Q**H = (QZ)*H*(QZ)**H.\n*\n\n*     Arguments\n*     =========\n*\n*     WANTT   (input) LOGICAL\n*          = .TRUE. : the full Schur form T is required;\n*          = .FALSE.: only eigenvalues are required.\n*\n*     WANTZ   (input) LOGICAL\n*          = .TRUE. : the matrix of Schur vectors Z is required;\n*          = .FALSE.: Schur vectors are not required.\n*\n*     N     (input) INTEGER\n*           The order of the matrix H.  N .GE. 0.\n*\n*     ILO   (input) INTEGER\n*     IHI   (input) INTEGER\n*           It is assumed that H is already upper triangular in rows\n*           and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,\n*           H(ILO,ILO-1) is zero. ILO and IHI are normally set by a\n*           previous call to CGEBAL, and then passed to CGEHRD when the\n*           matrix output by CGEBAL is reduced to Hessenberg form.\n*           Otherwise, ILO and IHI should be set to 1 and N,\n*           respectively.  If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n*           If N = 0, then ILO = 1 and IHI = 0.\n*\n*     H     (input/output) COMPLEX array, dimension (LDH,N)\n*           On entry, the upper Hessenberg matrix H.\n*           On exit, if INFO = 0 and WANTT is .TRUE., then H\n*           contains the upper triangular matrix T from the Schur\n*           decomposition (the Schur form). If INFO = 0 and WANT is\n*           .FALSE., then the contents of H are unspecified on exit.\n*           (The output value of H when INFO.GT.0 is given under the\n*           description of INFO below.)\n*\n*           This subroutine may explicitly set H(i,j) = 0 for i.GT.j and\n*           j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.\n*\n*     LDH   (input) INTEGER\n*           The leading dimension of the array H. LDH .GE. max(1,N).\n*\n*     W        (output) COMPLEX array, dimension (N)\n*           The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored\n*           in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are\n*           stored in the same order as on the diagonal of the Schur\n*           form returned in H, with W(i) = H(i,i).\n*\n*     Z     (input/output) COMPLEX array, dimension (LDZ,IHI)\n*           If WANTZ is .FALSE., then Z is not referenced.\n*           If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is\n*           replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the\n*           orthogonal Schur factor of H(ILO:IHI,ILO:IHI).\n*           (The output value of Z when INFO.GT.0 is given under\n*           the description of INFO below.)\n*\n*     LDZ   (input) INTEGER\n*           The leading dimension of the array Z.  if WANTZ is .TRUE.\n*           then LDZ.GE.MAX(1,IHIZ).  Otherwize, LDZ.GE.1.\n*\n*     WORK  (workspace/output) COMPLEX array, dimension LWORK\n*           On exit, if LWORK = -1, WORK(1) returns an estimate of\n*           the optimal value for LWORK.\n*\n*     LWORK (input) INTEGER\n*           The dimension of the array WORK.  LWORK .GE. max(1,N)\n*           is sufficient, but LWORK typically as large as 6*N may\n*           be required for optimal performance.  A workspace query\n*           to determine the optimal workspace size is recommended.\n*\n*           If LWORK = -1, then CLAQR4 does a workspace query.\n*           In this case, CLAQR4 checks the input parameters and\n*           estimates the optimal workspace size for the given\n*           values of N, ILO and IHI.  The estimate is returned\n*           in WORK(1).  No error message related to LWORK is\n*           issued by XERBLA.  Neither H nor Z are accessed.\n*\n*\n*     INFO  (output) INTEGER\n*             =  0:  successful exit\n*           .GT. 0:  if INFO = i, CLAQR4 failed to compute all of\n*                the eigenvalues.  Elements 1:ilo-1 and i+1:n of WR\n*                and WI contain those eigenvalues which have been\n*                successfully computed.  (Failures are rare.)\n*\n*                If INFO .GT. 0 and WANT is .FALSE., then on exit,\n*                the remaining unconverged eigenvalues are the eigen-\n*                values of the upper Hessenberg matrix rows and\n*                columns ILO through INFO of the final, output\n*                value of H.\n*\n*                If INFO .GT. 0 and WANTT is .TRUE., then on exit\n*\n*           (*)  (initial value of H)*U  = U*(final value of H)\n*\n*                where U is a unitary matrix.  The final\n*                value of  H is upper Hessenberg and triangular in\n*                rows and columns INFO+1 through IHI.\n*\n*                If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n*\n*                  (final value of Z(ILO:IHI,ILOZ:IHIZ)\n*                   =  (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U\n*\n*                where U is the unitary matrix in (*) (regard-\n*                less of the value of WANTT.)\n*\n*                If INFO .GT. 0 and WANTZ is .FALSE., then Z is not\n*                accessed.\n*\n\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n*     References:\n*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n*       Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n*       Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n*       929--947, 2002.\n*\n*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n*       Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n*       of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n*     ================================================================\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, work, info, h, z = NumRu::Lapack.claqr4( wantt, wantz, ilo, h, iloz, ihiz, z, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_wantt = argv[0];
  rblapack_wantz = argv[1];
  rblapack_ilo = argv[2];
  rblapack_h = argv[3];
  rblapack_iloz = argv[4];
  rblapack_ihiz = argv[5];
  rblapack_z = argv[6];
  if (argc == 8) {
    rblapack_lwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  wantt = (rblapack_wantt == Qtrue);
  ilo = NUM2INT(rblapack_ilo);
  iloz = NUM2INT(rblapack_iloz);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (7th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  ihi = NA_SHAPE1(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, complex*);
  wantz = (rblapack_wantz == Qtrue);
  ihiz = NUM2INT(rblapack_ihiz);
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (4th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (4th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_SCOMPLEX)
    rblapack_h = na_change_type(rblapack_h, NA_SCOMPLEX);
  h = NA_PTR_TYPE(rblapack_h, complex*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, complex*);
  MEMCPY(h_out__, h, complex, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = ihi;
    rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
  MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  claqr4_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, w, &iloz, &ihiz, z, &ldz, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_w, rblapack_work, rblapack_info, rblapack_h, rblapack_z);
}

void
init_lapack_claqr4(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "claqr4", rblapack_claqr4, -1);
}
ruby-lapack-1.7.2/ext/zsyequb.c0000644000175000017500000001167612502221017016240 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zsyequb_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublereal* s, doublereal* scond, doublereal* amax, doublecomplex* work, integer* info);


static VALUE
rblapack_zsyequb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_scond;
  doublereal scond; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_info;
  integer info; 
  doublecomplex *work;

  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  s, scond, amax, info = NumRu::Lapack.zsyequb( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZSYEQUB computes row and column scalings intended to equilibrate a\n*  symmetric matrix A and reduce its condition number\n*  (with respect to the two-norm).  S contains the scale factors,\n*  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n*  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This\n*  choice of S puts the condition number of B within a factor N of the\n*  smallest possible condition number over all possible diagonal\n*  scalings.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          The N-by-N symmetric matrix whose scaling\n*          factors are to be computed.  Only the diagonal elements of A\n*          are referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  S       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, S contains the scale factors for A.\n*\n*  SCOND   (output) DOUBLE PRECISION\n*          If INFO = 0, S contains the ratio of the smallest S(i) to\n*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too\n*          large nor too small, it is not worth scaling by S.\n*\n*  AMAX    (output) DOUBLE PRECISION\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (3*N)\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 is nonpositive.\n*\n\n*  Further Details\n*  ======= =======\n*\n*  Reference: Livne, O.E. and Golub, G.H., \"Scaling by Binormalization\",\n*  Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004.\n*  DOI 10.1023/B:NUMA.0000016606.32820.69\n*  Tech report version: http://ruready.utah.edu/archive/papers/bin.pdf\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, scond, amax, info = NumRu::Lapack.zsyequb( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  work = ALLOC_N(doublecomplex, (3*n));

  zsyequb_(&uplo, &n, a, &lda, s, &scond, &amax, work, &info);

  free(work);
  rblapack_scond = rb_float_new((double)scond);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
}

void
init_lapack_zsyequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zsyequb", rblapack_zsyequb, -1);
}
ruby-lapack-1.7.2/ext/dspgvd.c0000644000175000017500000002515712502221012016017 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dspgvd_(integer* itype, char* jobz, char* uplo, integer* n, doublereal* ap, doublereal* bp, doublereal* w, doublereal* z, integer* ldz, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_dspgvd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_bp;
  doublereal *bp; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublereal *ap_out__;
  VALUE rblapack_bp_out__;
  doublereal *bp_out__;

  integer ldap;
  integer n;
  integer ldz;

  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  w, z, work, iwork, info, ap, bp = NumRu::Lapack.dspgvd( itype, jobz, uplo, ap, bp, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSPGVD computes all the eigenvalues, and optionally, the eigenvectors\n*  of a real generalized symmetric-definite eigenproblem, of the form\n*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A and\n*  B are assumed to be symmetric, stored in packed format, and B is also\n*  positive definite.\n*  If eigenvectors are desired, it uses a divide and conquer algorithm.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          Specifies the problem type to be solved:\n*          = 1:  A*x = (lambda)*B*x\n*          = 2:  A*B*x = (lambda)*x\n*          = 3:  B*A*x = (lambda)*x\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, the contents of AP are destroyed.\n*\n*  BP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          B, packed columnwise in a linear array.  The j-th column of B\n*          is stored in the array BP as follows:\n*          if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n*          if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n*          On exit, the triangular factor U or L from the Cholesky\n*          factorization B = U**T*U or B = L*L**T, in the same storage\n*          format as B.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n*          eigenvectors.  The eigenvectors are normalized as follows:\n*          if ITYPE = 1 or 2, Z**T*B*Z = I;\n*          if ITYPE = 3, Z**T*inv(B)*Z = I.\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the required LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK.\n*          If N <= 1,               LWORK >= 1.\n*          If JOBZ = 'N' and N > 1, LWORK >= 2*N.\n*          If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the required sizes of the WORK and IWORK\n*          arrays, returns these values as the first entries of the WORK\n*          and IWORK arrays, and no error message related to LWORK or\n*          LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.\n*          If JOBZ  = 'N' or N <= 1, LIWORK >= 1.\n*          If JOBZ  = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the required sizes of the WORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK and IWORK arrays, and no error message related to\n*          LWORK or LIWORK 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:  DPPTRF or DSPEVD returned an error code:\n*             <= N:  if INFO = i, DSPEVD failed to converge;\n*                    i off-diagonal elements of an intermediate\n*                    tridiagonal form did not converge to zero;\n*             > N:   if INFO = N + i, for 1 <= i <= N, then the leading\n*                    minor of order i of B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, work, iwork, info, ap, bp = NumRu::Lapack.dspgvd( itype, jobz, uplo, ap, bp, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_itype = argv[0];
  rblapack_jobz = argv[1];
  rblapack_uplo = argv[2];
  rblapack_ap = argv[3];
  rblapack_bp = argv[4];
  if (argc == 7) {
    rblapack_lwork = argv[5];
    rblapack_liwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  itype = NUM2INT(rblapack_itype);
  uplo = StringValueCStr(rblapack_uplo)[0];
  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  if (!NA_IsNArray(rblapack_bp))
    rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
  if (NA_RANK(rblapack_bp) != 1)
    rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_bp) != NA_DFLOAT)
    rblapack_bp = na_change_type(rblapack_bp, NA_DFLOAT);
  bp = NA_PTR_TYPE(rblapack_bp, doublereal*);
  if (rblapack_liwork == Qnil)
    liwork = (lsame_(&jobz,"N")||n<=1) ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  if (rblapack_lwork == Qnil)
    lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 2*n : lsame_(&jobz,"V") ? 1+6*n+2*n*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
  MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_bp_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  bp_out__ = NA_PTR_TYPE(rblapack_bp_out__, doublereal*);
  MEMCPY(bp_out__, bp, doublereal, NA_TOTAL(rblapack_bp));
  rblapack_bp = rblapack_bp_out__;
  bp = bp_out__;

  dspgvd_(&itype, &jobz, &uplo, &n, ap, bp, w, z, &ldz, work, &lwork, iwork, &liwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_w, rblapack_z, rblapack_work, rblapack_iwork, rblapack_info, rblapack_ap, rblapack_bp);
}

void
init_lapack_dspgvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dspgvd", rblapack_dspgvd, -1);
}
ruby-lapack-1.7.2/ext/sorglq.c0000644000175000017500000001235412502221020016031 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sorglq_(integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sorglq(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;

  integer lda;
  integer n;
  integer k;

  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 = NumRu::Lapack.sorglq( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SORGLQ generates an M-by-N real matrix Q with orthonormal rows,\n*  which is defined as the first M rows of a product of K elementary\n*  reflectors of order N\n*\n*        Q  =  H(k) . . . H(2) H(1)\n*\n*  as returned by SGELQF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. N >= M.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. M >= K >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the i-th row must contain the vector which defines\n*          the elementary reflector H(i), for i = 1,2,...,k, as returned\n*          by SGELQF in the first k rows of its array argument A.\n*          On exit, the M-by-N matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) REAL array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by SGELQF.\n*\n*  WORK    (workspace/output) REAL 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\n*          the 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 has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, a = NumRu::Lapack.sorglq( m, a, tau, [: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_m = argv[0];
  rblapack_a = argv[1];
  rblapack_tau = 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;
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (rblapack_lwork == Qnil)
    lwork = m;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  sorglq_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_sorglq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sorglq", rblapack_sorglq, -1);
}
ruby-lapack-1.7.2/ext/zla_gbamv.c0000644000175000017500000002027212502221014016465 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zla_gbamv_(integer* trans, integer* m, integer* n, integer* kl, integer* ku, doublereal* alpha, doublereal* ab, integer* ldab, doublereal* x, integer* incx, doublereal* beta, doublereal* y, integer* incy);


static VALUE
rblapack_zla_gbamv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  integer trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_alpha;
  doublereal alpha; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_beta;
  doublereal beta; 
  VALUE rblapack_y;
  doublereal *y; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_y_out__;
  doublereal *y_out__;

  integer ldab;
  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  y = NumRu::Lapack.zla_gbamv( trans, m, kl, ku, alpha, ab, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, INCX, BETA, Y, INCY )\n\n*  Purpose\n*  =======\n*\n*  DLA_GBAMV  performs one of the matrix-vector operations\n*\n*          y := alpha*abs(A)*abs(x) + beta*abs(y),\n*     or   y := alpha*abs(A)'*abs(x) + beta*abs(y),\n*\n*  where alpha and beta are scalars, x and y are vectors and A is an\n*  m by n matrix.\n*\n*  This function is primarily used in calculating error bounds.\n*  To protect against underflow during evaluation, components in\n*  the resulting vector are perturbed away from zero by (N+1)\n*  times the underflow threshold.  To prevent unnecessarily large\n*  errors for block-structure embedded in general matrices,\n*  \"symbolically\" zero components are not perturbed.  A zero\n*  entry is considered \"symbolic\" if all multiplications involved\n*  in computing that entry have at least one zero multiplicand.\n*\n\n*  Arguments\n*  ==========\n*\n*  TRANS   (input) INTEGER\n*           On entry, TRANS specifies the operation to be performed as\n*           follows:\n*\n*             BLAS_NO_TRANS      y := alpha*abs(A)*abs(x) + beta*abs(y)\n*             BLAS_TRANS         y := alpha*abs(A')*abs(x) + beta*abs(y)\n*             BLAS_CONJ_TRANS    y := alpha*abs(A')*abs(x) + beta*abs(y)\n*\n*           Unchanged on exit.\n*\n*  M       (input) INTEGER\n*           On entry, M specifies the number of rows of the matrix A.\n*           M must be at least zero.\n*           Unchanged on exit.\n*\n*  N       (input) INTEGER\n*           On entry, N specifies the number of columns of the matrix A.\n*           N must be at least zero.\n*           Unchanged on exit.\n*\n*  KL      (input) INTEGER\n*           The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*           The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  ALPHA  - DOUBLE PRECISION\n*           On entry, ALPHA specifies the scalar alpha.\n*           Unchanged on exit.\n*\n*  A      - DOUBLE PRECISION   array of DIMENSION ( LDA, n )\n*           Before entry, the leading m by n part of the array A must\n*           contain the matrix of coefficients.\n*           Unchanged on exit.\n*\n*  LDA     (input) INTEGER\n*           On entry, LDA specifies the first dimension of A as declared\n*           in the calling (sub) program. LDA must be at least\n*           max( 1, m ).\n*           Unchanged on exit.\n*\n*  X       (input) DOUBLE PRECISION array, dimension\n*           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n*           and at least\n*           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n*           Before entry, the incremented array X must contain the\n*           vector x.\n*           Unchanged on exit.\n*\n*  INCX    (input) INTEGER\n*           On entry, INCX specifies the increment for the elements of\n*           X. INCX must not be zero.\n*           Unchanged on exit.\n*\n*  BETA   - DOUBLE PRECISION\n*           On entry, BETA specifies the scalar beta. When BETA is\n*           supplied as zero then Y need not be set on input.\n*           Unchanged on exit.\n*\n*  Y       (input/output) DOUBLE PRECISION  array, dimension\n*           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n*           and at least\n*           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n*           Before entry with BETA non-zero, the incremented array Y\n*           must contain the vector y. On exit, Y is overwritten by the\n*           updated vector y.\n*\n*  INCY    (input) INTEGER\n*           On entry, INCY specifies the increment for the elements of\n*           Y. INCY must not be zero.\n*           Unchanged on exit.\n*\n*\n*  Level 2 Blas routine.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  y = NumRu::Lapack.zla_gbamv( trans, m, kl, ku, alpha, ab, x, incx, beta, y, incy, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 11 && argc != 11)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
  rblapack_trans = argv[0];
  rblapack_m = argv[1];
  rblapack_kl = argv[2];
  rblapack_ku = argv[3];
  rblapack_alpha = argv[4];
  rblapack_ab = argv[5];
  rblapack_x = argv[6];
  rblapack_incx = argv[7];
  rblapack_beta = argv[8];
  rblapack_y = argv[9];
  rblapack_incy = argv[10];
  if (argc == 11) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = NUM2INT(rblapack_trans);
  kl = NUM2INT(rblapack_kl);
  alpha = NUM2DBL(rblapack_alpha);
  incx = NUM2INT(rblapack_incx);
  incy = NUM2INT(rblapack_incy);
  m = NUM2INT(rblapack_m);
  beta = NUM2DBL(rblapack_beta);
  ldab = MAX(1, m);
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (6th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (6th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_ab) != ldab)
    rb_raise(rb_eRuntimeError, "shape 0 of ab must be MAX(1, m)");
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (10th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (10th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy ));
  if (NA_TYPE(rblapack_y) != NA_DFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
  y = NA_PTR_TYPE(rblapack_y, doublereal*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (7th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (trans == ilatrans_("N") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", trans == ilatrans_("N") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx ));
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy );
    rblapack_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
  MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  zla_gbamv_(&trans, &m, &n, &kl, &ku, &alpha, ab, &ldab, x, &incx, &beta, y, &incy);

  return rblapack_y;
}

void
init_lapack_zla_gbamv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zla_gbamv", rblapack_zla_gbamv, -1);
}
ruby-lapack-1.7.2/ext/dorgl2.c0000644000175000017500000001033212502221023015710 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dorgl2_(integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* info);


static VALUE
rblapack_dorgl2(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 k;
  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  info, a = NumRu::Lapack.dorgl2( a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DORGL2 generates an m by n real matrix Q with orthonormal rows,\n*  which is defined as the first m rows of a product of k elementary\n*  reflectors of order n\n*\n*        Q  =  H(k) . . . H(2) H(1)\n*\n*  as returned by DGELQF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. N >= M.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. M >= K >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the i-th row must contain the vector which defines\n*          the elementary reflector H(i), for i = 1,2,...,k, as returned\n*          by DGELQF in the first k rows of its array argument A.\n*          On exit, the m-by-n matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) DOUBLE PRECISION array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by DGELQF.\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 has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.dorgl2( a, tau, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_a = argv[0];
  rblapack_tau = argv[1];
  if (argc == 2) {
  } 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;
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (2th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (2th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t 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));

  dorgl2_(&m, &n, &k, a, &lda, tau, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_dorgl2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dorgl2", rblapack_dorgl2, -1);
}
ruby-lapack-1.7.2/ext/cgegs.c0000644000175000017500000002445412502221017015624 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgegs_(char* jobvsl, char* jobvsr, integer* n, complex* a, integer* lda, complex* b, integer* ldb, complex* alpha, complex* beta, complex* vsl, integer* ldvsl, complex* vsr, integer* ldvsr, complex* work, integer* lwork, real* rwork, integer* info);


static VALUE
rblapack_cgegs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvsl;
  char jobvsl; 
  VALUE rblapack_jobvsr;
  char jobvsr; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_alpha;
  complex *alpha; 
  VALUE rblapack_beta;
  complex *beta; 
  VALUE rblapack_vsl;
  complex *vsl; 
  VALUE rblapack_vsr;
  complex *vsr; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;
  real *rwork;

  integer lda;
  integer n;
  integer ldb;
  integer ldvsl;
  integer ldvsr;

  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  alpha, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.cgegs( jobvsl, jobvsr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  This routine is deprecated and has been replaced by routine CGGES.\n*\n*  CGEGS computes the eigenvalues, Schur form, and, optionally, the\n*  left and or/right Schur vectors of a complex matrix pair (A,B).\n*  Given two square matrices A and B, the generalized Schur\n*  factorization has the form\n*  \n*     A = Q*S*Z**H,  B = Q*T*Z**H\n*  \n*  where Q and Z are unitary matrices and S and T are upper triangular.\n*  The columns of Q are the left Schur vectors\n*  and the columns of Z are the right Schur vectors.\n*  \n*  If only the eigenvalues of (A,B) are needed, the driver routine\n*  CGEGV should be used instead.  See CGEGV for a description of the\n*  eigenvalues of the generalized nonsymmetric eigenvalue problem\n*  (GNEP).\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVSL   (input) CHARACTER*1\n*          = 'N':  do not compute the left Schur vectors;\n*          = 'V':  compute the left Schur vectors (returned in VSL).\n*\n*  JOBVSR   (input) CHARACTER*1\n*          = 'N':  do not compute the right Schur vectors;\n*          = 'V':  compute the right Schur vectors (returned in VSR).\n*\n*  N       (input) INTEGER\n*          The order of the matrices A, B, VSL, and VSR.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA, N)\n*          On entry, the matrix A.\n*          On exit, the upper triangular matrix S from the generalized\n*          Schur factorization.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of A.  LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX array, dimension (LDB, N)\n*          On entry, the matrix B.\n*          On exit, the upper triangular matrix T from the generalized\n*          Schur factorization.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of B.  LDB >= max(1,N).\n*\n*  ALPHA   (output) COMPLEX array, dimension (N)\n*          The complex scalars alpha that define the eigenvalues of\n*          GNEP.  ALPHA(j) = S(j,j), the diagonal element of the Schur\n*          form of A.\n*\n*  BETA    (output) COMPLEX array, dimension (N)\n*          The non-negative real scalars beta that define the\n*          eigenvalues of GNEP.  BETA(j) = T(j,j), the diagonal element\n*          of the triangular factor T.\n*\n*          Together, the quantities alpha = ALPHA(j) and beta = BETA(j)\n*          represent the j-th eigenvalue of the matrix pair (A,B), in\n*          one of the forms lambda = alpha/beta or mu = beta/alpha.\n*          Since either lambda or mu may overflow, they should not,\n*          in general, be computed.\n*\n*  VSL     (output) COMPLEX array, dimension (LDVSL,N)\n*          If JOBVSL = 'V', the matrix of left Schur vectors Q.\n*          Not referenced if JOBVSL = 'N'.\n*\n*  LDVSL   (input) INTEGER\n*          The leading dimension of the matrix VSL. LDVSL >= 1, and\n*          if JOBVSL = 'V', LDVSL >= N.\n*\n*  VSR     (output) COMPLEX array, dimension (LDVSR,N)\n*          If JOBVSR = 'V', the matrix of right Schur vectors Z.\n*          Not referenced if JOBVSR = 'N'.\n*\n*  LDVSR   (input) INTEGER\n*          The leading dimension of the matrix VSR. LDVSR >= 1, and\n*          if JOBVSR = 'V', LDVSR >= N.\n*\n*  WORK    (workspace/output) COMPLEX 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,2*N).\n*          For good performance, LWORK must generally be larger.\n*          To compute the optimal value of LWORK, call ILAENV to get\n*          blocksizes (for CGEQRF, CUNMQR, and CUNGQR.)  Then compute:\n*          NB  -- MAX of the blocksizes for CGEQRF, CUNMQR, and CUNGQR;\n*          the optimal LWORK is N*(NB+1).\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*  RWORK   (workspace) REAL array, dimension (3*N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          =1,...,N:\n*                The QZ iteration failed.  (A,B) are not in Schur\n*                form, but ALPHA(j) and BETA(j) should be correct for\n*                j=INFO+1,...,N.\n*          > N:  errors that usually indicate LAPACK problems:\n*                =N+1: error return from CGGBAL\n*                =N+2: error return from CGEQRF\n*                =N+3: error return from CUNMQR\n*                =N+4: error return from CUNGQR\n*                =N+5: error return from CGGHRD\n*                =N+6: error return from CHGEQZ (other than failed\n*                                               iteration)\n*                =N+7: error return from CGGBAK (computing VSL)\n*                =N+8: error return from CGGBAK (computing VSR)\n*                =N+9: error return from CLASCL (various places)\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  alpha, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.cgegs( jobvsl, jobvsr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_jobvsl = argv[0];
  rblapack_jobvsr = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  jobvsl = StringValueCStr(rblapack_jobvsl)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  jobvsr = StringValueCStr(rblapack_jobvsr)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  ldvsl = lsame_(&jobvsl,"V") ? n : 1;
  if (rblapack_lwork == Qnil)
    lwork = 2*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldvsr = lsame_(&jobvsr,"V") ? n : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  alpha = NA_PTR_TYPE(rblapack_alpha, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvsl;
    shape[1] = n;
    rblapack_vsl = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  vsl = NA_PTR_TYPE(rblapack_vsl, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvsr;
    shape[1] = n;
    rblapack_vsr = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  vsr = NA_PTR_TYPE(rblapack_vsr, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  rwork = ALLOC_N(real, (3*n));

  cgegs_(&jobvsl, &jobvsr, &n, a, &lda, b, &ldb, alpha, beta, vsl, &ldvsl, vsr, &ldvsr, work, &lwork, rwork, &info);

  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_alpha, rblapack_beta, rblapack_vsl, rblapack_vsr, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_cgegs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgegs", rblapack_cgegs, -1);
}
ruby-lapack-1.7.2/ext/zpprfs.c0000644000175000017500000001763512502221026016063 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zpprfs_(char* uplo, integer* n, integer* nrhs, doublecomplex* ap, doublecomplex* afp, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zpprfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_afp;
  doublecomplex *afp; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer ldb;
  integer nrhs;
  integer ldx;
  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  ferr, berr, info, x = NumRu::Lapack.zpprfs( uplo, ap, afp, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPPRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is Hermitian positive definite\n*  and packed, and provides error bounds and backward error estimates\n*  for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          The upper or lower triangle of the Hermitian matrix A, packed\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  AFP     (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**H*U or A = L*L**H, as computed by DPPTRF/ZPPTRF,\n*          packed columnwise in a linear array in the same format as A\n*          (see AP).\n*\n*  B       (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) COMPLEX*16 array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by ZPPTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  ====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.zpprfs( uplo, ap, afp, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_afp = argv[2];
  rblapack_b = argv[3];
  rblapack_x = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  n = ldb;
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (5th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  if (!NA_IsNArray(rblapack_afp))
    rb_raise(rb_eArgError, "afp (3th argument) must be NArray");
  if (NA_RANK(rblapack_afp) != 1)
    rb_raise(rb_eArgError, "rank of afp (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_afp) != NA_DCOMPLEX)
    rblapack_afp = na_change_type(rblapack_afp, NA_DCOMPLEX);
  afp = NA_PTR_TYPE(rblapack_afp, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (n));

  zpprfs_(&uplo, &n, &nrhs, ap, afp, b, &ldb, x, &ldx, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_zpprfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zpprfs", rblapack_zpprfs, -1);
}
ruby-lapack-1.7.2/ext/claqr3.c0000644000175000017500000002565212502221013015716 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID claqr3_(logical* wantt, logical* wantz, integer* n, integer* ktop, integer* kbot, integer* nw, complex* h, integer* ldh, integer* iloz, integer* ihiz, complex* z, integer* ldz, integer* ns, integer* nd, complex* sh, complex* v, integer* ldv, integer* nh, complex* t, integer* ldt, integer* nv, complex* wv, integer* ldwv, complex* work, integer* lwork);


static VALUE
rblapack_claqr3(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantt;
  logical wantt; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_ktop;
  integer ktop; 
  VALUE rblapack_kbot;
  integer kbot; 
  VALUE rblapack_nw;
  integer nw; 
  VALUE rblapack_h;
  complex *h; 
  VALUE rblapack_iloz;
  integer iloz; 
  VALUE rblapack_ihiz;
  integer ihiz; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_nh;
  integer nh; 
  VALUE rblapack_nv;
  integer nv; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_ns;
  integer ns; 
  VALUE rblapack_nd;
  integer nd; 
  VALUE rblapack_sh;
  complex *sh; 
  VALUE rblapack_h_out__;
  complex *h_out__;
  VALUE rblapack_z_out__;
  complex *z_out__;
  complex *v;
  complex *t;
  complex *wv;
  complex *work;

  integer ldh;
  integer n;
  integer ldz;
  integer ldv;
  integer ldwv;
  integer ldt;

  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  ns, nd, sh, h, z = NumRu::Lapack.claqr3( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n*     Aggressive early deflation:\n*\n*     This subroutine accepts as input an upper Hessenberg matrix\n*     H and performs an unitary similarity transformation\n*     designed to detect and deflate fully converged eigenvalues from\n*     a trailing principal submatrix.  On output H has been over-\n*     written by a new Hessenberg matrix that is a perturbation of\n*     an unitary similarity transformation of H.  It is to be\n*     hoped that the final version of H has many zero subdiagonal\n*     entries.\n*\n*     ******************************************************************\n\n*     WANTT   (input) LOGICAL\n*          If .TRUE., then the Hessenberg matrix H is fully updated\n*          so that the triangular Schur factor may be\n*          computed (in cooperation with the calling subroutine).\n*          If .FALSE., then only enough of H is updated to preserve\n*          the eigenvalues.\n*\n*     WANTZ   (input) LOGICAL\n*          If .TRUE., then the unitary matrix Z is updated so\n*          so that the unitary Schur factor may be computed\n*          (in cooperation with the calling subroutine).\n*          If .FALSE., then Z is not referenced.\n*\n*     N       (input) INTEGER\n*          The order of the matrix H and (if WANTZ is .TRUE.) the\n*          order of the unitary matrix Z.\n*\n*     KTOP    (input) INTEGER\n*          It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n*          KBOT and KTOP together determine an isolated block\n*          along the diagonal of the Hessenberg matrix.\n*\n*     KBOT    (input) INTEGER\n*          It is assumed without a check that either\n*          KBOT = N or H(KBOT+1,KBOT)=0.  KBOT and KTOP together\n*          determine an isolated block along the diagonal of the\n*          Hessenberg matrix.\n*\n*     NW      (input) INTEGER\n*          Deflation window size.  1 .LE. NW .LE. (KBOT-KTOP+1).\n*\n*     H       (input/output) COMPLEX array, dimension (LDH,N)\n*          On input the initial N-by-N section of H stores the\n*          Hessenberg matrix undergoing aggressive early deflation.\n*          On output H has been transformed by a unitary\n*          similarity transformation, perturbed, and the returned\n*          to Hessenberg form that (it is to be hoped) has some\n*          zero subdiagonal entries.\n*\n*     LDH     (input) integer\n*          Leading dimension of H just as declared in the calling\n*          subroutine.  N .LE. LDH\n*\n*     ILOZ    (input) INTEGER\n*     IHIZ    (input) INTEGER\n*          Specify the rows of Z to which transformations must be\n*          applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n*\n*     Z       (input/output) COMPLEX array, dimension (LDZ,N)\n*          IF WANTZ is .TRUE., then on output, the unitary\n*          similarity transformation mentioned above has been\n*          accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n*          If WANTZ is .FALSE., then Z is unreferenced.\n*\n*     LDZ     (input) integer\n*          The leading dimension of Z just as declared in the\n*          calling subroutine.  1 .LE. LDZ.\n*\n*     NS      (output) integer\n*          The number of unconverged (ie approximate) eigenvalues\n*          returned in SR and SI that may be used as shifts by the\n*          calling subroutine.\n*\n*     ND      (output) integer\n*          The number of converged eigenvalues uncovered by this\n*          subroutine.\n*\n*     SH      (output) COMPLEX array, dimension KBOT\n*          On output, approximate eigenvalues that may\n*          be used for shifts are stored in SH(KBOT-ND-NS+1)\n*          through SR(KBOT-ND).  Converged eigenvalues are\n*          stored in SH(KBOT-ND+1) through SH(KBOT).\n*\n*     V       (workspace) COMPLEX array, dimension (LDV,NW)\n*          An NW-by-NW work array.\n*\n*     LDV     (input) integer scalar\n*          The leading dimension of V just as declared in the\n*          calling subroutine.  NW .LE. LDV\n*\n*     NH      (input) integer scalar\n*          The number of columns of T.  NH.GE.NW.\n*\n*     T       (workspace) COMPLEX array, dimension (LDT,NW)\n*\n*     LDT     (input) integer\n*          The leading dimension of T just as declared in the\n*          calling subroutine.  NW .LE. LDT\n*\n*     NV      (input) integer\n*          The number of rows of work array WV available for\n*          workspace.  NV.GE.NW.\n*\n*     WV      (workspace) COMPLEX array, dimension (LDWV,NW)\n*\n*     LDWV    (input) integer\n*          The leading dimension of W just as declared in the\n*          calling subroutine.  NW .LE. LDV\n*\n*     WORK    (workspace) COMPLEX array, dimension LWORK.\n*          On exit, WORK(1) is set to an estimate of the optimal value\n*          of LWORK for the given values of N, NW, KTOP and KBOT.\n*\n*     LWORK   (input) integer\n*          The dimension of the work array WORK.  LWORK = 2*NW\n*          suffices, but greater efficiency may result from larger\n*          values of LWORK.\n*\n*          If LWORK = -1, then a workspace query is assumed; CLAQR3\n*          only estimates the optimal workspace size for the given\n*          values of N, NW, KTOP and KBOT.  The estimate is returned\n*          in WORK(1).  No error message related to LWORK is issued\n*          by XERBLA.  Neither H nor Z are accessed.\n*\n\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ns, nd, sh, h, z = NumRu::Lapack.claqr3( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 11 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
  rblapack_wantt = argv[0];
  rblapack_wantz = argv[1];
  rblapack_ktop = argv[2];
  rblapack_kbot = argv[3];
  rblapack_nw = argv[4];
  rblapack_h = argv[5];
  rblapack_iloz = argv[6];
  rblapack_ihiz = argv[7];
  rblapack_z = argv[8];
  rblapack_nh = argv[9];
  rblapack_nv = argv[10];
  if (argc == 12) {
    rblapack_lwork = argv[11];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  wantt = (rblapack_wantt == Qtrue);
  ktop = NUM2INT(rblapack_ktop);
  nw = NUM2INT(rblapack_nw);
  iloz = NUM2INT(rblapack_iloz);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (9th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  n = NA_SHAPE1(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, complex*);
  nv = NUM2INT(rblapack_nv);
  ldwv = nw;
  ldv = nw;
  wantz = (rblapack_wantz == Qtrue);
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (6th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  if (NA_SHAPE1(rblapack_h) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of z");
  if (NA_TYPE(rblapack_h) != NA_SCOMPLEX)
    rblapack_h = na_change_type(rblapack_h, NA_SCOMPLEX);
  h = NA_PTR_TYPE(rblapack_h, complex*);
  nh = NUM2INT(rblapack_nh);
  ldt = nw;
  kbot = NUM2INT(rblapack_kbot);
  if (rblapack_lwork == Qnil)
    lwork = 2*nw;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ihiz = NUM2INT(rblapack_ihiz);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,kbot);
    rblapack_sh = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  sh = NA_PTR_TYPE(rblapack_sh, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, complex*);
  MEMCPY(h_out__, h, complex, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
  MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  v = ALLOC_N(complex, (ldv)*(MAX(1,nw)));
  t = ALLOC_N(complex, (ldv)*(MAX(1,nw)));
  wv = ALLOC_N(complex, (ldv)*(MAX(1,nw)));
  work = ALLOC_N(complex, (MAX(1,lwork)));

  claqr3_(&wantt, &wantz, &n, &ktop, &kbot, &nw, h, &ldh, &iloz, &ihiz, z, &ldz, &ns, &nd, sh, v, &ldv, &nh, t, &ldt, &nv, wv, &ldwv, work, &lwork);

  free(v);
  free(t);
  free(wv);
  free(work);
  rblapack_ns = INT2NUM(ns);
  rblapack_nd = INT2NUM(nd);
  return rb_ary_new3(5, rblapack_ns, rblapack_nd, rblapack_sh, rblapack_h, rblapack_z);
}

void
init_lapack_claqr3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "claqr3", rblapack_claqr3, -1);
}
ruby-lapack-1.7.2/ext/clauum.c0000644000175000017500000000733512502221017016021 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clauum_(char* uplo, integer* n, complex* a, integer* lda, integer* info);


static VALUE
rblapack_clauum(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *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  info, a = NumRu::Lapack.clauum( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAUUM( UPLO, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  CLAUUM computes the product U * U' or L' * L, where the triangular\n*  factor U or L is stored in the upper or lower triangular part of\n*  the array A.\n*\n*  If UPLO = 'U' or 'u' then the upper triangle of the result is stored,\n*  overwriting the factor U in A.\n*  If UPLO = 'L' or 'l' then the lower triangle of the result is stored,\n*  overwriting the factor L in A.\n*\n*  This is the blocked form of the algorithm, calling Level 3 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the triangular factor stored in the array A\n*          is upper or lower triangular:\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the triangular factor U or L.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the triangular factor U or L.\n*          On exit, if UPLO = 'U', the upper triangle of A is\n*          overwritten with the upper triangle of the product U * U';\n*          if UPLO = 'L', the lower triangle of A is overwritten with\n*          the lower triangle of the product L' * L.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.clauum( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  clauum_(&uplo, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_clauum(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clauum", rblapack_clauum, -1);
}
ruby-lapack-1.7.2/ext/cherfsx.c0000644000175000017500000005147712502221020016175 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cherfsx_(char* uplo, char* equed, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, real* s, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cherfsx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_params;
  real *params; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_err_bnds_norm;
  real *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  real *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_s_out__;
  real *s_out__;
  VALUE rblapack_x_out__;
  complex *x_out__;
  VALUE rblapack_params_out__;
  real *params_out__;
  complex *work;
  real *rwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;
  integer nparams;
  integer n_err_bnds;

  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  rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.cherfsx( uplo, equed, a, af, ipiv, s, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHERFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     CHERFSX improves the computed solution to a system of linear\n*     equations when the coefficient matrix is Hermitian indefinite, and\n*     provides error bounds and backward error estimates for the\n*     solution.  In addition to normwise error bound, the code provides\n*     maximum componentwise error bound if possible.  See comments for\n*     ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.\n*\n*     The original system of linear equations may have been equilibrated\n*     before calling this routine, as described by arguments EQUED and S\n*     below. In this case, the solution and error bounds returned are\n*     for the original unequilibrated system.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     EQUED   (input) CHARACTER*1\n*     Specifies the form of equilibration that was done to A\n*     before calling this routine. This is needed to compute\n*     the solution and error bounds correctly.\n*       = 'N':  No equilibration\n*       = 'Y':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(S) * A * diag(S).\n*               The right hand side B has been changed accordingly.\n*\n*     N       (input) INTEGER\n*     The order of the matrix A.  N >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     A       (input) COMPLEX array, dimension (LDA,N)\n*     The symmetric matrix A.  If UPLO = 'U', the leading N-by-N\n*     upper triangular part of A contains the upper triangular\n*     part of the matrix A, and the strictly lower triangular\n*     part of A is not referenced.  If UPLO = 'L', the leading\n*     N-by-N lower triangular part of A contains the lower\n*     triangular part of the matrix A, and the strictly upper\n*     triangular part of A is not referenced.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX array, dimension (LDAF,N)\n*     The factored form of the matrix A.  AF contains the block\n*     diagonal matrix D and the multipliers used to obtain the\n*     factor U or L from the factorization A = U*D*U**T or A =\n*     L*D*L**T as computed by SSYTRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     Details of the interchanges and the block structure of D\n*     as determined by SSYTRF.\n*\n*     S       (input or output) REAL array, dimension (N)\n*     The scale factors for A.  If EQUED = 'Y', A is multiplied on\n*     the left and right by diag(S).  S is an input argument if FACT =\n*     'F'; otherwise, S is an output argument.  If FACT = 'F' and EQUED\n*     = 'Y', each element of S must be positive.  If S is output, each\n*     element of S is a power of the radix. If S is input, each element\n*     of S should be a power of the radix to ensure a reliable solution\n*     and error estimates. Scaling by powers of the radix does not cause\n*     rounding errors unless the result underflows or overflows.\n*     Rounding errors during scaling lead to refining with a matrix that\n*     is not equivalent to the input matrix, producing error estimates\n*     that may not be reliable.\n*\n*     B       (input) COMPLEX array, dimension (LDB,NRHS)\n*     The right hand side matrix B.\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (input/output) COMPLEX array, dimension (LDX,NRHS)\n*     On entry, the solution matrix X, as computed by SGETRS.\n*     On exit, the improved solution matrix X.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) REAL\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     BERR    (output) REAL array, dimension (NRHS)\n*     Componentwise relative backward error.  This is the\n*     componentwise relative backward error of each solution vector X(j)\n*     (i.e., the smallest relative change in any element of A or B that\n*     makes X(j) an exact solution).\n*\n*     N_ERR_BNDS (input) INTEGER\n*     Number of error bounds to return for each right hand side\n*     and each type (normwise or componentwise).  See ERR_BNDS_NORM and\n*     ERR_BNDS_COMP below.\n*\n*     ERR_BNDS_NORM  (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     NPARAMS (input) INTEGER\n*     Specifies the number of parameters set in PARAMS.  If .LE. 0, the\n*     PARAMS array is never referenced and default values are used.\n*\n*     PARAMS  (input / output) REAL array, dimension NPARAMS\n*     Specifies algorithm parameters.  If an entry is .LT. 0.0, then\n*     that entry will be filled with default value used for that\n*     parameter.  Only positions up to NPARAMS are accessed; defaults\n*     are used for higher-numbered parameters.\n*\n*       PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n*            refinement or not.\n*         Default: 1.0\n*            = 0.0 : No refinement is performed, and no error bounds are\n*                    computed.\n*            = 1.0 : Use the double-precision refinement algorithm,\n*                    possibly with doubled-single computations if the\n*                    compilation environment does not support DOUBLE\n*                    PRECISION.\n*              (other values are reserved for future use)\n*\n*       PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n*            computations allowed for refinement.\n*         Default: 10\n*         Aggressive: Set to 100 to permit convergence using approximate\n*                     factorizations or factorizations other than LU. If\n*                     the factorization uses a technique other than\n*                     Gaussian elimination, the guarantees in\n*                     err_bnds_norm and err_bnds_comp may no longer be\n*                     trustworthy.\n*\n*       PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n*            will attempt to find a solution with small componentwise\n*            relative error in the double-precision algorithm.  Positive\n*            is true, 0.0 is false.\n*         Default: 1.0 (attempt componentwise convergence)\n*\n*     WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*     RWORK   (workspace) REAL array, dimension (2*N)\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit. The solution to every right-hand side is\n*         guaranteed.\n*       < 0:  If INFO = -i, the i-th argument had an illegal value\n*       > 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.cherfsx( uplo, equed, a, af, ipiv, s, b, x, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_uplo = argv[0];
  rblapack_equed = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_s = argv[5];
  rblapack_b = argv[6];
  rblapack_x = argv[7];
  rblapack_params = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (9th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_SFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
  params = NA_PTR_TYPE(rblapack_params, real*);
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (6th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  n_err_bnds = 3;
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (8th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (8th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
  MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
  MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (2*n));

  cherfsx_(&uplo, &equed, &n, &nrhs, a, &lda, af, &ldaf, ipiv, s, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_s, rblapack_x, rblapack_params);
}

void
init_lapack_cherfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cherfsx", rblapack_cherfsx, -1);
}
ruby-lapack-1.7.2/ext/drscl.c0000644000175000017500000000636312502221017015642 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID drscl_(integer* n, doublereal* sa, doublereal* sx, integer* incx);


static VALUE
rblapack_drscl(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_sa;
  doublereal sa; 
  VALUE rblapack_sx;
  doublereal *sx; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_sx_out__;
  doublereal *sx_out__;


  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  sx = NumRu::Lapack.drscl( n, sa, sx, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DRSCL( N, SA, SX, INCX )\n\n*  Purpose\n*  =======\n*\n*  DRSCL multiplies an n-element real vector x by the real scalar 1/a.\n*  This is done without overflow or underflow as long as\n*  the final result x/a does not overflow or underflow.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of components of the vector x.\n*\n*  SA      (input) DOUBLE PRECISION\n*          The scalar a which is used to divide each component of x.\n*          SA must be >= 0, or the subroutine will divide by zero.\n*\n*  SX      (input/output) DOUBLE PRECISION array, dimension\n*                         (1+(N-1)*abs(INCX))\n*          The n-element vector x.\n*\n*  INCX    (input) INTEGER\n*          The increment between successive values of the vector SX.\n*          > 0:  SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i),     1< i<= n\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sx = NumRu::Lapack.drscl( n, sa, sx, incx, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_n = argv[0];
  rblapack_sa = argv[1];
  rblapack_sx = argv[2];
  rblapack_incx = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  incx = NUM2INT(rblapack_incx);
  sa = NUM2DBL(rblapack_sa);
  if (!NA_IsNArray(rblapack_sx))
    rb_raise(rb_eArgError, "sx (3th argument) must be NArray");
  if (NA_RANK(rblapack_sx) != 1)
    rb_raise(rb_eArgError, "rank of sx (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_sx) != (1+(n-1)*abs(incx)))
    rb_raise(rb_eRuntimeError, "shape 0 of sx must be %d", 1+(n-1)*abs(incx));
  if (NA_TYPE(rblapack_sx) != NA_DFLOAT)
    rblapack_sx = na_change_type(rblapack_sx, NA_DFLOAT);
  sx = NA_PTR_TYPE(rblapack_sx, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*abs(incx);
    rblapack_sx_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  sx_out__ = NA_PTR_TYPE(rblapack_sx_out__, doublereal*);
  MEMCPY(sx_out__, sx, doublereal, NA_TOTAL(rblapack_sx));
  rblapack_sx = rblapack_sx_out__;
  sx = sx_out__;

  drscl_(&n, &sa, sx, &incx);

  return rblapack_sx;
}

void
init_lapack_drscl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "drscl", rblapack_drscl, -1);
}
ruby-lapack-1.7.2/ext/cunbdb.c0000644000175000017500000003451712502221021015765 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cunbdb_(char* trans, char* signs, integer* m, integer* p, integer* q, complex* x11, integer* ldx11, complex* x12, integer* ldx12, complex* x21, integer* ldx21, complex* x22, integer* ldx22, real* theta, real* phi, complex* taup1, complex* taup2, complex* tauq1, complex* tauq2, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_cunbdb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_signs;
  char signs; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_x11;
  complex *x11; 
  VALUE rblapack_x12;
  complex *x12; 
  VALUE rblapack_x21;
  complex *x21; 
  VALUE rblapack_x22;
  complex *x22; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_theta;
  real *theta; 
  VALUE rblapack_phi;
  real *phi; 
  VALUE rblapack_taup1;
  complex *taup1; 
  VALUE rblapack_taup2;
  complex *taup2; 
  VALUE rblapack_tauq1;
  complex *tauq1; 
  VALUE rblapack_tauq2;
  complex *tauq2; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x11_out__;
  complex *x11_out__;
  VALUE rblapack_x12_out__;
  complex *x12_out__;
  VALUE rblapack_x21_out__;
  complex *x21_out__;
  VALUE rblapack_x22_out__;
  complex *x22_out__;
  complex *work;

  integer ldx11;
  integer q;
  integer ldx12;
  integer ldx21;
  integer ldx22;
  integer p;

  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  theta, phi, taup1, taup2, tauq1, tauq2, info, x11, x12, x21, x22 = NumRu::Lapack.cunbdb( trans, signs, m, x11, x12, x21, x22, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CUNBDB simultaneously bidiagonalizes the blocks of an M-by-M\n*  partitioned unitary matrix X:\n*\n*                                  [ B11 | B12 0  0 ]\n*      [ X11 | X12 ]   [ P1 |    ] [  0  |  0 -I  0 ] [ Q1 |    ]**H\n*  X = [-----------] = [---------] [----------------] [---------]   .\n*      [ X21 | X22 ]   [    | P2 ] [ B21 | B22 0  0 ] [    | Q2 ]\n*                                  [  0  |  0  0  I ]\n*\n*  X11 is P-by-Q. Q must be no larger than P, M-P, or M-Q. (If this is\n*  not the case, then X must be transposed and/or permuted. This can be\n*  done in constant time using the TRANS and SIGNS options. See CUNCSD\n*  for details.)\n*\n*  The unitary matrices P1, P2, Q1, and Q2 are P-by-P, (M-P)-by-\n*  (M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. They are\n*  represented implicitly by Householder vectors.\n*\n*  B11, B12, B21, and B22 are Q-by-Q bidiagonal matrices represented\n*  implicitly by angles THETA, PHI.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER\n*          = 'T':      X, U1, U2, V1T, and V2T are stored in row-major\n*                      order;\n*          otherwise:  X, U1, U2, V1T, and V2T are stored in column-\n*                      major order.\n*\n*  SIGNS   (input) CHARACTER\n*          = 'O':      The lower-left block is made nonpositive (the\n*                      \"other\" convention);\n*          otherwise:  The upper-right block is made nonpositive (the\n*                      \"default\" convention).\n*\n*  M       (input) INTEGER\n*          The number of rows and columns in X.\n*\n*  P       (input) INTEGER\n*          The number of rows in X11 and X12. 0 <= P <= M.\n*\n*  Q       (input) INTEGER\n*          The number of columns in X11 and X21. 0 <= Q <=\n*          MIN(P,M-P,M-Q).\n*\n*  X11     (input/output) COMPLEX array, dimension (LDX11,Q)\n*          On entry, the top-left block of the unitary matrix to be\n*          reduced. On exit, the form depends on TRANS:\n*          If TRANS = 'N', then\n*             the columns of tril(X11) specify reflectors for P1,\n*             the rows of triu(X11,1) specify reflectors for Q1;\n*          else TRANS = 'T', and\n*             the rows of triu(X11) specify reflectors for P1,\n*             the columns of tril(X11,-1) specify reflectors for Q1.\n*\n*  LDX11   (input) INTEGER\n*          The leading dimension of X11. If TRANS = 'N', then LDX11 >=\n*          P; else LDX11 >= Q.\n*\n*  X12     (input/output) CMPLX array, dimension (LDX12,M-Q)\n*          On entry, the top-right block of the unitary matrix to\n*          be reduced. On exit, the form depends on TRANS:\n*          If TRANS = 'N', then\n*             the rows of triu(X12) specify the first P reflectors for\n*             Q2;\n*          else TRANS = 'T', and\n*             the columns of tril(X12) specify the first P reflectors\n*             for Q2.\n*\n*  LDX12   (input) INTEGER\n*          The leading dimension of X12. If TRANS = 'N', then LDX12 >=\n*          P; else LDX11 >= M-Q.\n*\n*  X21     (input/output) COMPLEX array, dimension (LDX21,Q)\n*          On entry, the bottom-left block of the unitary matrix to\n*          be reduced. On exit, the form depends on TRANS:\n*          If TRANS = 'N', then\n*             the columns of tril(X21) specify reflectors for P2;\n*          else TRANS = 'T', and\n*             the rows of triu(X21) specify reflectors for P2.\n*\n*  LDX21   (input) INTEGER\n*          The leading dimension of X21. If TRANS = 'N', then LDX21 >=\n*          M-P; else LDX21 >= Q.\n*\n*  X22     (input/output) COMPLEX array, dimension (LDX22,M-Q)\n*          On entry, the bottom-right block of the unitary matrix to\n*          be reduced. On exit, the form depends on TRANS:\n*          If TRANS = 'N', then\n*             the rows of triu(X22(Q+1:M-P,P+1:M-Q)) specify the last\n*             M-P-Q reflectors for Q2,\n*          else TRANS = 'T', and\n*             the columns of tril(X22(P+1:M-Q,Q+1:M-P)) specify the last\n*             M-P-Q reflectors for P2.\n*\n*  LDX22   (input) INTEGER\n*          The leading dimension of X22. If TRANS = 'N', then LDX22 >=\n*          M-P; else LDX22 >= M-Q.\n*\n*  THETA   (output) REAL array, dimension (Q)\n*          The entries of the bidiagonal blocks B11, B12, B21, B22 can\n*          be computed from the angles THETA and PHI. See Further\n*          Details.\n*\n*  PHI     (output) REAL array, dimension (Q-1)\n*          The entries of the bidiagonal blocks B11, B12, B21, B22 can\n*          be computed from the angles THETA and PHI. See Further\n*          Details.\n*\n*  TAUP1   (output) COMPLEX array, dimension (P)\n*          The scalar factors of the elementary reflectors that define\n*          P1.\n*\n*  TAUP2   (output) COMPLEX array, dimension (M-P)\n*          The scalar factors of the elementary reflectors that define\n*          P2.\n*\n*  TAUQ1   (output) COMPLEX array, dimension (Q)\n*          The scalar factors of the elementary reflectors that define\n*          Q1.\n*\n*  TAUQ2   (output) COMPLEX array, dimension (M-Q)\n*          The scalar factors of the elementary reflectors that define\n*          Q2.\n*\n*  WORK    (workspace) COMPLEX array, dimension (LWORK)\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK. LWORK >= M-Q.\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 bidiagonal blocks B11, B12, B21, and B22 are represented\n*  implicitly by angles THETA(1), ..., THETA(Q) and PHI(1), ...,\n*  PHI(Q-1). B11 and B21 are upper bidiagonal, while B21 and B22 are\n*  lower bidiagonal. Every entry in each bidiagonal band is a product\n*  of a sine or cosine of a THETA with a sine or cosine of a PHI. See\n*  [1] or CUNCSD for details.\n*\n*  P1, P2, Q1, and Q2 are represented as products of elementary\n*  reflectors. See CUNCSD for details on generating P1, P2, Q1, and Q2\n*  using CUNGQR and CUNGLQ.\n*\n*  Reference\n*  =========\n*\n*  [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.\n*      Algorithms, 50(1):33-65, 2009.\n*\n*  ====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  theta, phi, taup1, taup2, tauq1, tauq2, info, x11, x12, x21, x22 = NumRu::Lapack.cunbdb( trans, signs, m, x11, x12, x21, x22, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_trans = argv[0];
  rblapack_signs = argv[1];
  rblapack_m = argv[2];
  rblapack_x11 = argv[3];
  rblapack_x12 = argv[4];
  rblapack_x21 = argv[5];
  rblapack_x22 = argv[6];
  if (argc == 8) {
    rblapack_lwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  trans = StringValueCStr(rblapack_trans)[0];
  m = NUM2INT(rblapack_m);
  signs = StringValueCStr(rblapack_signs)[0];
  if (!NA_IsNArray(rblapack_x11))
    rb_raise(rb_eArgError, "x11 (4th argument) must be NArray");
  if (NA_RANK(rblapack_x11) != 2)
    rb_raise(rb_eArgError, "rank of x11 (4th argument) must be %d", 2);
  ldx11 = NA_SHAPE0(rblapack_x11);
  q = NA_SHAPE1(rblapack_x11);
  if (NA_TYPE(rblapack_x11) != NA_SCOMPLEX)
    rblapack_x11 = na_change_type(rblapack_x11, NA_SCOMPLEX);
  x11 = NA_PTR_TYPE(rblapack_x11, complex*);
  p = ldx11;
  ldx21 = p;
  if (!NA_IsNArray(rblapack_x21))
    rb_raise(rb_eArgError, "x21 (6th argument) must be NArray");
  if (NA_RANK(rblapack_x21) != 2)
    rb_raise(rb_eArgError, "rank of x21 (6th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_x21) != ldx21)
    rb_raise(rb_eRuntimeError, "shape 0 of x21 must be p");
  if (NA_SHAPE1(rblapack_x21) != q)
    rb_raise(rb_eRuntimeError, "shape 1 of x21 must be the same as shape 1 of x11");
  if (NA_TYPE(rblapack_x21) != NA_SCOMPLEX)
    rblapack_x21 = na_change_type(rblapack_x21, NA_SCOMPLEX);
  x21 = NA_PTR_TYPE(rblapack_x21, complex*);
  if (rblapack_lwork == Qnil)
    lwork = m-q;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldx22 = p;
  if (!NA_IsNArray(rblapack_x22))
    rb_raise(rb_eArgError, "x22 (7th argument) must be NArray");
  if (NA_RANK(rblapack_x22) != 2)
    rb_raise(rb_eArgError, "rank of x22 (7th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_x22) != ldx22)
    rb_raise(rb_eRuntimeError, "shape 0 of x22 must be p");
  if (NA_SHAPE1(rblapack_x22) != (m-q))
    rb_raise(rb_eRuntimeError, "shape 1 of x22 must be %d", m-q);
  if (NA_TYPE(rblapack_x22) != NA_SCOMPLEX)
    rblapack_x22 = na_change_type(rblapack_x22, NA_SCOMPLEX);
  x22 = NA_PTR_TYPE(rblapack_x22, complex*);
  ldx12 = p;
  if (!NA_IsNArray(rblapack_x12))
    rb_raise(rb_eArgError, "x12 (5th argument) must be NArray");
  if (NA_RANK(rblapack_x12) != 2)
    rb_raise(rb_eArgError, "rank of x12 (5th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_x12) != ldx12)
    rb_raise(rb_eRuntimeError, "shape 0 of x12 must be p");
  if (NA_SHAPE1(rblapack_x12) != (m-q))
    rb_raise(rb_eRuntimeError, "shape 1 of x12 must be %d", m-q);
  if (NA_TYPE(rblapack_x12) != NA_SCOMPLEX)
    rblapack_x12 = na_change_type(rblapack_x12, NA_SCOMPLEX);
  x12 = NA_PTR_TYPE(rblapack_x12, complex*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_theta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  theta = NA_PTR_TYPE(rblapack_theta, real*);
  {
    na_shape_t shape[1];
    shape[0] = q-1;
    rblapack_phi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  phi = NA_PTR_TYPE(rblapack_phi, real*);
  {
    na_shape_t shape[1];
    shape[0] = p;
    rblapack_taup1 = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  taup1 = NA_PTR_TYPE(rblapack_taup1, complex*);
  {
    na_shape_t shape[1];
    shape[0] = m-p;
    rblapack_taup2 = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  taup2 = NA_PTR_TYPE(rblapack_taup2, complex*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_tauq1 = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  tauq1 = NA_PTR_TYPE(rblapack_tauq1, complex*);
  {
    na_shape_t shape[1];
    shape[0] = m-q;
    rblapack_tauq2 = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  tauq2 = NA_PTR_TYPE(rblapack_tauq2, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldx11;
    shape[1] = q;
    rblapack_x11_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x11_out__ = NA_PTR_TYPE(rblapack_x11_out__, complex*);
  MEMCPY(x11_out__, x11, complex, NA_TOTAL(rblapack_x11));
  rblapack_x11 = rblapack_x11_out__;
  x11 = x11_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldx12;
    shape[1] = m-q;
    rblapack_x12_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x12_out__ = NA_PTR_TYPE(rblapack_x12_out__, complex*);
  MEMCPY(x12_out__, x12, complex, NA_TOTAL(rblapack_x12));
  rblapack_x12 = rblapack_x12_out__;
  x12 = x12_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldx21;
    shape[1] = q;
    rblapack_x21_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x21_out__ = NA_PTR_TYPE(rblapack_x21_out__, complex*);
  MEMCPY(x21_out__, x21, complex, NA_TOTAL(rblapack_x21));
  rblapack_x21 = rblapack_x21_out__;
  x21 = x21_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldx22;
    shape[1] = m-q;
    rblapack_x22_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x22_out__ = NA_PTR_TYPE(rblapack_x22_out__, complex*);
  MEMCPY(x22_out__, x22, complex, NA_TOTAL(rblapack_x22));
  rblapack_x22 = rblapack_x22_out__;
  x22 = x22_out__;
  work = ALLOC_N(complex, (MAX(1,lwork)));

  cunbdb_(&trans, &signs, &m, &p, &q, x11, &ldx11, x12, &ldx12, x21, &ldx21, x22, &ldx22, theta, phi, taup1, taup2, tauq1, tauq2, work, &lwork, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(11, rblapack_theta, rblapack_phi, rblapack_taup1, rblapack_taup2, rblapack_tauq1, rblapack_tauq2, rblapack_info, rblapack_x11, rblapack_x12, rblapack_x21, rblapack_x22);
}

void
init_lapack_cunbdb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cunbdb", rblapack_cunbdb, -1);
}
ruby-lapack-1.7.2/ext/dorgbr.c0000644000175000017500000001557112502221014016010 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dorgbr_(char* vect, integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dorgbr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_vect;
  char vect; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_lwork;
  integer lwork; 
  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  work, info, a = NumRu::Lapack.dorgbr( vect, m, k, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DORGBR generates one of the real orthogonal matrices Q or P**T\n*  determined by DGEBRD when reducing a real matrix A to bidiagonal\n*  form: A = Q * B * P**T.  Q and P**T are defined as products of\n*  elementary reflectors H(i) or G(i) respectively.\n*\n*  If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q\n*  is of order M:\n*  if m >= k, Q = H(1) H(2) . . . H(k) and DORGBR returns the first n\n*  columns of Q, where m >= n >= k;\n*  if m < k, Q = H(1) H(2) . . . H(m-1) and DORGBR returns Q as an\n*  M-by-M matrix.\n*\n*  If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T\n*  is of order N:\n*  if k < n, P**T = G(k) . . . G(2) G(1) and DORGBR returns the first m\n*  rows of P**T, where n >= m >= k;\n*  if k >= n, P**T = G(n-1) . . . G(2) G(1) and DORGBR returns P**T as\n*  an N-by-N matrix.\n*\n\n*  Arguments\n*  =========\n*\n*  VECT    (input) CHARACTER*1\n*          Specifies whether the matrix Q or the matrix P**T is\n*          required, as defined in the transformation applied by DGEBRD:\n*          = 'Q':  generate Q;\n*          = 'P':  generate P**T.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q or P**T to be returned.\n*          M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q or P**T to be returned.\n*          N >= 0.\n*          If VECT = 'Q', M >= N >= min(M,K);\n*          if VECT = 'P', N >= M >= min(N,K).\n*\n*  K       (input) INTEGER\n*          If VECT = 'Q', the number of columns in the original M-by-K\n*          matrix reduced by DGEBRD.\n*          If VECT = 'P', the number of rows in the original K-by-N\n*          matrix reduced by DGEBRD.\n*          K >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the vectors which define the elementary reflectors,\n*          as returned by DGEBRD.\n*          On exit, the M-by-N matrix Q or P**T.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) DOUBLE PRECISION array, dimension\n*                                (min(M,K)) if VECT = 'Q'\n*                                (min(N,K)) if VECT = 'P'\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i) or G(i), which determines Q or P**T, as\n*          returned by DGEBRD in its array argument TAUQ or TAUP.\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,min(M,N)).\n*          For optimum performance LWORK >= min(M,N)*NB, where NB\n*          is the 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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, a = NumRu::Lapack.dorgbr( vect, m, k, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_vect = argv[0];
  rblapack_m = argv[1];
  rblapack_k = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  if (argc == 6) {
    rblapack_lwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  vect = StringValueCStr(rblapack_vect)[0];
  k = NUM2INT(rblapack_k);
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_tau) != (MIN(m,k)))
    rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", MIN(m,k));
  if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th 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*);
  if (rblapack_lwork == Qnil)
    lwork = MIN(m,n);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;

  dorgbr_(&vect, &m, &n, &k, a, &lda, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_dorgbr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dorgbr", rblapack_dorgbr, -1);
}
ruby-lapack-1.7.2/ext/clahrd.c0000644000175000017500000001462412502221017015767 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clahrd_(integer* n, integer* k, integer* nb, complex* a, integer* lda, complex* tau, complex* t, integer* ldt, complex* y, integer* ldy);


static VALUE
rblapack_clahrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_nb;
  integer nb; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_t;
  complex *t; 
  VALUE rblapack_y;
  complex *y; 
  VALUE rblapack_a_out__;
  complex *a_out__;

  integer lda;
  integer ldt;
  integer ldy;

  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, t, y, a = NumRu::Lapack.clahrd( n, k, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )\n\n*  Purpose\n*  =======\n*\n*  CLAHRD reduces the first NB columns of a complex general n-by-(n-k+1)\n*  matrix A so that elements below the k-th subdiagonal are zero. The\n*  reduction is performed by a unitary similarity transformation\n*  Q' * A * Q. The routine returns the matrices V and T which determine\n*  Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.\n*\n*  This is an OBSOLETE auxiliary routine. \n*  This routine will be 'deprecated' in a  future release.\n*  Please use the new routine CLAHR2 instead.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.\n*\n*  K       (input) INTEGER\n*          The offset for the reduction. Elements below the k-th\n*          subdiagonal in the first NB columns are reduced to zero.\n*\n*  NB      (input) INTEGER\n*          The number of columns to be reduced.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N-K+1)\n*          On entry, the n-by-(n-k+1) general matrix A.\n*          On exit, the elements on and above the k-th subdiagonal in\n*          the first NB columns are overwritten with the corresponding\n*          elements of the reduced matrix; the elements below the k-th\n*          subdiagonal, with the array TAU, represent the matrix Q as a\n*          product of elementary reflectors. The other columns of A are\n*          unchanged. See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  TAU     (output) COMPLEX array, dimension (NB)\n*          The scalar factors of the elementary reflectors. See Further\n*          Details.\n*\n*  T       (output) COMPLEX array, dimension (LDT,NB)\n*          The upper triangular matrix T.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T.  LDT >= NB.\n*\n*  Y       (output) COMPLEX array, dimension (LDY,NB)\n*          The n-by-nb matrix Y.\n*\n*  LDY     (input) INTEGER\n*          The leading dimension of the array Y. LDY >= max(1,N).\n*\n\n*  Further Details\n*  ===============\n*\n*  The matrix Q is represented as a product of nb elementary reflectors\n*\n*     Q = H(1) H(2) . . . H(nb).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - tau * v * v'\n*\n*  where tau is a complex scalar, and v is a complex vector with\n*  v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in\n*  A(i+k+1:n,i), and tau in TAU(i).\n*\n*  The elements of the vectors v together form the (n-k+1)-by-nb matrix\n*  V which is needed, with T and Y, to apply the transformation to the\n*  unreduced part of the matrix, using an update of the form:\n*  A := (I - V*T*V') * (A - Y*V').\n*\n*  The contents of A on exit are illustrated by the following example\n*  with n = 7, k = 3 and nb = 2:\n*\n*     ( a   h   a   a   a )\n*     ( a   h   a   a   a )\n*     ( a   h   a   a   a )\n*     ( h   h   a   a   a )\n*     ( v1  h   a   a   a )\n*     ( v1  v2  a   a   a )\n*     ( v1  v2  a   a   a )\n*\n*  where a denotes an element of the original matrix A, h denotes a\n*  modified element of the upper Hessenberg matrix H, and vi denotes an\n*  element of the vector defining H(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, t, y, a = NumRu::Lapack.clahrd( n, k, nb, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_n = argv[0];
  rblapack_k = argv[1];
  rblapack_nb = argv[2];
  rblapack_a = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  nb = NUM2INT(rblapack_nb);
  ldy = MAX(1,n);
  k = NUM2INT(rblapack_k);
  ldt = nb;
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != (n-k+1))
    rb_raise(rb_eRuntimeError, "shape 1 of a must be %d", n-k+1);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,nb);
    rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = MAX(1,nb);
    rblapack_t = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  t = NA_PTR_TYPE(rblapack_t, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldy;
    shape[1] = MAX(1,nb);
    rblapack_y = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  y = NA_PTR_TYPE(rblapack_y, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n-k+1;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  clahrd_(&n, &k, &nb, a, &lda, tau, t, &ldt, y, &ldy);

  return rb_ary_new3(4, rblapack_tau, rblapack_t, rblapack_y, rblapack_a);
}

void
init_lapack_clahrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clahrd", rblapack_clahrd, -1);
}
ruby-lapack-1.7.2/ext/zhpgv.c0000644000175000017500000002006412502221016015662 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhpgv_(integer* itype, char* jobz, char* uplo, integer* n, doublecomplex* ap, doublecomplex* bp, doublereal* w, doublecomplex* z, integer* ldz, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zhpgv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_bp;
  doublecomplex *bp; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublecomplex *ap_out__;
  VALUE rblapack_bp_out__;
  doublecomplex *bp_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer ldap;
  integer n;
  integer ldz;

  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  w, z, info, ap, bp = NumRu::Lapack.zhpgv( itype, jobz, uplo, ap, bp, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHPGV computes all the eigenvalues and, optionally, the eigenvectors\n*  of a complex generalized Hermitian-definite eigenproblem, of the form\n*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.\n*  Here A and B are assumed to be Hermitian, stored in packed format,\n*  and B is also positive definite.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          Specifies the problem type to be solved:\n*          = 1:  A*x = (lambda)*B*x\n*          = 2:  A*B*x = (lambda)*x\n*          = 3:  B*A*x = (lambda)*x\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, the contents of AP are destroyed.\n*\n*  BP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          B, packed columnwise in a linear array.  The j-th column of B\n*          is stored in the array BP as follows:\n*          if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n*          if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n*          On exit, the triangular factor U or L from the Cholesky\n*          factorization B = U**H*U or B = L*L**H, in the same storage\n*          format as B.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) COMPLEX*16 array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n*          eigenvectors.  The eigenvectors are normalized as follows:\n*          if ITYPE = 1 or 2, Z**H*B*Z = I;\n*          if ITYPE = 3, Z**H*inv(B)*Z = I.\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (max(1, 2*N-1))\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2))\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  ZPPTRF or ZHPEV returned an error code:\n*             <= N:  if INFO = i, ZHPEV failed to converge;\n*                    i off-diagonal elements of an intermediate\n*                    tridiagonal form did not convergeto zero;\n*             > N:   if INFO = N + i, for 1 <= i <= n, then the leading\n*                    minor of order i of B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            UPPER, WANTZ\n      CHARACTER          TRANS\n      INTEGER            J, NEIG\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZHPEV, ZHPGST, ZPPTRF, ZTPMV, ZTPSV\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, info, ap, bp = NumRu::Lapack.zhpgv( itype, jobz, uplo, ap, bp, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_itype = argv[0];
  rblapack_jobz = argv[1];
  rblapack_uplo = argv[2];
  rblapack_ap = argv[3];
  rblapack_bp = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  itype = NUM2INT(rblapack_itype);
  uplo = StringValueCStr(rblapack_uplo)[0];
  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  if (!NA_IsNArray(rblapack_bp))
    rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
  if (NA_RANK(rblapack_bp) != 1)
    rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_bp) != NA_DCOMPLEX)
    rblapack_bp = na_change_type(rblapack_bp, NA_DCOMPLEX);
  bp = NA_PTR_TYPE(rblapack_bp, doublecomplex*);
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
  MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_bp_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  bp_out__ = NA_PTR_TYPE(rblapack_bp_out__, doublecomplex*);
  MEMCPY(bp_out__, bp, doublecomplex, NA_TOTAL(rblapack_bp));
  rblapack_bp = rblapack_bp_out__;
  bp = bp_out__;
  work = ALLOC_N(doublecomplex, (MAX(1, 2*n-1)));
  rwork = ALLOC_N(doublereal, (MAX(1, 3*n-2)));

  zhpgv_(&itype, &jobz, &uplo, &n, ap, bp, w, z, &ldz, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_w, rblapack_z, rblapack_info, rblapack_ap, rblapack_bp);
}

void
init_lapack_zhpgv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhpgv", rblapack_zhpgv, -1);
}
ruby-lapack-1.7.2/ext/sla_gercond.c0000644000175000017500000001723712502221022017011 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real sla_gercond_(char* trans, integer* n, real* a, integer* lda, real* af, integer* ldaf, integer* ipiv, integer* cmode, real* c, integer* info, real* work, integer* iwork);


static VALUE
rblapack_sla_gercond(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_af;
  real *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_cmode;
  integer cmode; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack___out__;
  real __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  info, __out__ = NumRu::Lapack.sla_gercond( trans, a, af, ipiv, cmode, c, work, iwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL FUNCTION SLA_GERCOND ( TRANS, N, A, LDA, AF, LDAF, IPIV, CMODE, C, INFO, WORK, IWORK )\n\n*  Purpose\n*  =======\n*\n*     SLA_GERCOND estimates the Skeel condition number of op(A) * op2(C)\n*     where op2 is determined by CMODE as follows\n*     CMODE =  1    op2(C) = C\n*     CMODE =  0    op2(C) = I\n*     CMODE = -1    op2(C) = inv(C)\n*     The Skeel condition number cond(A) = norminf( |inv(A)||A| )\n*     is computed by computing scaling factors R such that\n*     diag(R)*A*op2(C) is row equilibrated and computing the standard\n*     infinity-norm condition number.\n*\n\n*  Arguments\n*  ==========\n*\n*     TRANS   (input) CHARACTER*1\n*     Specifies the form of the system of equations:\n*       = 'N':  A * X = B     (No transpose)\n*       = 'T':  A**T * X = B  (Transpose)\n*       = 'C':  A**H * X = B  (Conjugate Transpose = Transpose)\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     A       (input) REAL array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) REAL array, dimension (LDAF,N)\n*     The factors L and U from the factorization\n*     A = P*L*U as computed by SGETRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     The pivot indices from the factorization A = P*L*U\n*     as computed by SGETRF; row i of the matrix was interchanged\n*     with row IPIV(i).\n*\n*     CMODE   (input) INTEGER\n*     Determines op2(C) in the formula op(A) * op2(C) as follows:\n*     CMODE =  1    op2(C) = C\n*     CMODE =  0    op2(C) = I\n*     CMODE = -1    op2(C) = inv(C)\n*\n*     C       (input) REAL array, dimension (N)\n*     The vector C in the formula op(A) * op2(C).\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit.\n*     i > 0:  The ith argument is invalid.\n*\n*     WORK    (input) REAL array, dimension (3*N).\n*     Workspace.\n*\n*     IWORK   (input) INTEGER array, dimension (N).\n*     Workspace.2\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            NOTRANS\n      INTEGER            KASE, I, J\n      REAL               AINVNM, TMP\n*     ..\n*     .. Local Arrays ..\n      INTEGER            ISAVE( 3 )\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SLACN2, SGETRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, __out__ = NumRu::Lapack.sla_gercond( trans, a, af, ipiv, cmode, c, work, iwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_trans = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_cmode = argv[4];
  rblapack_c = argv[5];
  rblapack_work = argv[6];
  rblapack_iwork = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_SFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
  af = NA_PTR_TYPE(rblapack_af, real*);
  cmode = NUM2INT(rblapack_cmode);
  if (!NA_IsNArray(rblapack_iwork))
    rb_raise(rb_eArgError, "iwork (8th argument) must be NArray");
  if (NA_RANK(rblapack_iwork) != 1)
    rb_raise(rb_eArgError, "rank of iwork (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_iwork) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of iwork must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_iwork) != NA_LINT)
    rblapack_iwork = na_change_type(rblapack_iwork, NA_LINT);
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (7th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (3*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 3*n);
  if (NA_TYPE(rblapack_work) != NA_SFLOAT)
    rblapack_work = na_change_type(rblapack_work, NA_SFLOAT);
  work = NA_PTR_TYPE(rblapack_work, real*);

  __out__ = sla_gercond_(&trans, &n, a, &lda, af, &ldaf, ipiv, &cmode, c, &info, work, iwork);

  rblapack_info = INT2NUM(info);
  rblapack___out__ = rb_float_new((double)__out__);
  return rb_ary_new3(2, rblapack_info, rblapack___out__);
}

void
init_lapack_sla_gercond(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sla_gercond", rblapack_sla_gercond, -1);
}
ruby-lapack-1.7.2/ext/zhetrf.c0000644000175000017500000001760012502221021016024 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhetrf_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zhetrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *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  ipiv, work, info, a = NumRu::Lapack.zhetrf( uplo, a, lwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHETRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHETRF computes the factorization of a complex Hermitian matrix A\n*  using the Bunch-Kaufman diagonal pivoting method.  The form of the\n*  factorization is\n*\n*     A = U*D*U**H  or  A = L*D*L**H\n*\n*  where U (or L) is a product of permutation and unit upper (lower)\n*  triangular matrices, and D is Hermitian and block diagonal with\n*  1-by-1 and 2-by-2 diagonal blocks.\n*\n*  This is the blocked version of the algorithm, calling Level 3 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L (see below for further details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D.\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of WORK.  LWORK >=1.  For best performance\n*          LWORK >= N*NB, where NB is the block size returned by ILAENV.\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, D(i,i) is exactly zero.  The factorization\n*                has been completed, but the block diagonal matrix D is\n*                exactly singular, and division by zero will occur if it\n*                is used to solve a system of equations.\n*\n\n*  Further Details\n*  ===============\n*\n*  If UPLO = 'U', then A = U*D*U', where\n*     U = P(n)*U(n)* ... *P(k)U(k)* ...,\n*  i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n*  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    v    0   )   k-s\n*     U(k) =  (   0    I    0   )   s\n*             (   0    0    I   )   n-k\n*                k-s   s   n-k\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n*  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n*  and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n*  If UPLO = 'L', then A = L*D*L', where\n*     L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n*  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n*  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    0     0   )  k-1\n*     L(k) =  (   0    I     0   )  s\n*             (   0    v     I   )  n-k-s+1\n*                k-1   s  n-k-s+1\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n*  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n*  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY, UPPER\n      INTEGER            IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            ILAENV\n      EXTERNAL           LSAME, ILAENV\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZHETF2, ZLAHEF\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, work, info, a = NumRu::Lapack.zhetrf( uplo, a, lwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_lwork = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  lwork = NUM2INT(rblapack_lwork);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zhetrf_(&uplo, &n, a, &lda, ipiv, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ipiv, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_zhetrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhetrf", rblapack_zhetrf, -1);
}
ruby-lapack-1.7.2/ext/zlaed7.c0000644000175000017500000003646112655767576015765 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlaed7_(integer* n, integer* cutpnt, integer* qsiz, integer* tlvls, integer* curlvl, integer* curpbm, doublereal* d, doublecomplex* q, integer* ldq, doublereal* rho, integer* indxq, doublereal* qstore, integer* qptr, integer* prmptr, integer* perm, integer* givptr, integer* givcol, doublereal* givnum, doublecomplex* work, doublereal* rwork, integer* iwork, integer* info);


static VALUE
rblapack_zlaed7(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_cutpnt;
  integer cutpnt; 
  VALUE rblapack_qsiz;
  integer qsiz; 
  VALUE rblapack_tlvls;
  integer tlvls; 
  VALUE rblapack_curlvl;
  integer curlvl; 
  VALUE rblapack_curpbm;
  integer curpbm; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_q;
  doublecomplex *q; 
  VALUE rblapack_rho;
  doublereal rho; 
  VALUE rblapack_qstore;
  doublereal *qstore; 
  VALUE rblapack_qptr;
  integer *qptr; 
  VALUE rblapack_prmptr;
  integer *prmptr; 
  VALUE rblapack_perm;
  integer *perm; 
  VALUE rblapack_givptr;
  integer *givptr; 
  VALUE rblapack_givcol;
  integer *givcol; 
  VALUE rblapack_givnum;
  doublereal *givnum; 
  VALUE rblapack_indxq;
  integer *indxq; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_q_out__;
  doublecomplex *q_out__;
  VALUE rblapack_qstore_out__;
  doublereal *qstore_out__;
  VALUE rblapack_qptr_out__;
  integer *qptr_out__;
  doublecomplex *work;
  doublereal *rwork;
  integer *iwork;

  integer n;
  integer ldq;

  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  indxq, info, d, q, qstore, qptr = NumRu::Lapack.zlaed7( cutpnt, qsiz, tlvls, curlvl, curpbm, d, q, rho, qstore, qptr, prmptr, perm, givptr, givcol, givnum, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAED7( N, CUTPNT, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, LDQ, RHO, INDXQ, QSTORE, QPTR, PRMPTR, PERM, GIVPTR, GIVCOL, GIVNUM, WORK, RWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZLAED7 computes the updated eigensystem of a diagonal\n*  matrix after modification by a rank-one symmetric matrix. This\n*  routine is used only for the eigenproblem which requires all\n*  eigenvalues and optionally eigenvectors of a dense or banded\n*  Hermitian matrix that has been reduced to tridiagonal form.\n*\n*    T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)\n*\n*    where Z = Q'u, u is a vector of length N with ones in the\n*    CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.\n*\n*     The eigenvectors of the original matrix are stored in Q, and the\n*     eigenvalues are in D.  The algorithm consists of three stages:\n*\n*        The first stage consists of deflating the size of the problem\n*        when there are multiple eigenvalues or if there is a zero in\n*        the Z vector.  For each such occurrence the dimension of the\n*        secular equation problem is reduced by one.  This stage is\n*        performed by the routine DLAED2.\n*\n*        The second stage consists of calculating the updated\n*        eigenvalues. This is done by finding the roots of the secular\n*        equation via the routine DLAED4 (as called by SLAED3).\n*        This routine also calculates the eigenvectors of the current\n*        problem.\n*\n*        The final stage consists of computing the updated eigenvectors\n*        directly using the updated eigenvalues.  The eigenvectors for\n*        the current problem are multiplied with the eigenvectors from\n*        the overall problem.\n*\n\n*  Arguments\n*  =========\n*\n*  N      (input) INTEGER\n*         The dimension of the symmetric tridiagonal matrix.  N >= 0.\n*\n*  CUTPNT (input) INTEGER\n*         Contains the location of the last eigenvalue in the leading\n*         sub-matrix.  min(1,N) <= CUTPNT <= N.\n*\n*  QSIZ   (input) INTEGER\n*         The dimension of the unitary matrix used to reduce\n*         the full matrix to tridiagonal form.  QSIZ >= N.\n*\n*  TLVLS  (input) INTEGER\n*         The total number of merging levels in the overall divide and\n*         conquer tree.\n*\n*  CURLVL (input) INTEGER\n*         The current level in the overall merge routine,\n*         0 <= curlvl <= tlvls.\n*\n*  CURPBM (input) INTEGER\n*         The current problem in the current level in the overall\n*         merge routine (counting from upper left to lower right).\n*\n*  D      (input/output) DOUBLE PRECISION array, dimension (N)\n*         On entry, the eigenvalues of the rank-1-perturbed matrix.\n*         On exit, the eigenvalues of the repaired matrix.\n*\n*  Q      (input/output) COMPLEX*16 array, dimension (LDQ,N)\n*         On entry, the eigenvectors of the rank-1-perturbed matrix.\n*         On exit, the eigenvectors of the repaired tridiagonal matrix.\n*\n*  LDQ    (input) INTEGER\n*         The leading dimension of the array Q.  LDQ >= max(1,N).\n*\n*  RHO    (input) DOUBLE PRECISION\n*         Contains the subdiagonal element used to create the rank-1\n*         modification.\n*\n*  INDXQ  (output) INTEGER array, dimension (N)\n*         This contains the permutation which will reintegrate the\n*         subproblem just solved back into sorted order,\n*         ie. D( INDXQ( I = 1, N ) ) will be in ascending order.\n*\n*  IWORK  (workspace) INTEGER array, dimension (4*N)\n*\n*  RWORK  (workspace) DOUBLE PRECISION array,\n*                                 dimension (3*N+2*QSIZ*N)\n*\n*  WORK   (workspace) COMPLEX*16 array, dimension (QSIZ*N)\n*\n*  QSTORE (input/output) DOUBLE PRECISION array, dimension (N**2+1)\n*         Stores eigenvectors of submatrices encountered during\n*         divide and conquer, packed together. QPTR points to\n*         beginning of the submatrices.\n*\n*  QPTR   (input/output) INTEGER array, dimension (N+2)\n*         List of indices pointing to beginning of submatrices stored\n*         in QSTORE. The submatrices are numbered starting at the\n*         bottom left of the divide and conquer tree, from left to\n*         right and bottom to top.\n*\n*  PRMPTR (input) INTEGER array, dimension (N lg N)\n*         Contains a list of pointers which indicate where in PERM a\n*         level's permutation is stored.  PRMPTR(i+1) - PRMPTR(i)\n*         indicates the size of the permutation and also the size of\n*         the full, non-deflated problem.\n*\n*  PERM   (input) INTEGER array, dimension (N lg N)\n*         Contains the permutations (from deflation and sorting) to be\n*         applied to each eigenblock.\n*\n*  GIVPTR (input) INTEGER array, dimension (N lg N)\n*         Contains a list of pointers which indicate where in GIVCOL a\n*         level's Givens rotations are stored.  GIVPTR(i+1) - GIVPTR(i)\n*         indicates the number of Givens rotations.\n*\n*  GIVCOL (input) INTEGER array, dimension (2, N lg N)\n*         Each pair of numbers indicates a pair of columns to take place\n*         in a Givens rotation.\n*\n*  GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N)\n*         Each number indicates the S value to be used in the\n*         corresponding Givens rotation.\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 = 1, an eigenvalue did not converge\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            COLTYP, CURR, I, IDLMDA, INDX,\n     $                   INDXC, INDXP, IQ, IW, IZ, K, N1, N2, PTR\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DLAED9, DLAEDA, DLAMRG, XERBLA, ZLACRM, ZLAED8\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  indxq, info, d, q, qstore, qptr = NumRu::Lapack.zlaed7( cutpnt, qsiz, tlvls, curlvl, curpbm, d, q, rho, qstore, qptr, prmptr, perm, givptr, givcol, givnum, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 15 && argc != 15)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
  rblapack_cutpnt = argv[0];
  rblapack_qsiz = argv[1];
  rblapack_tlvls = argv[2];
  rblapack_curlvl = argv[3];
  rblapack_curpbm = argv[4];
  rblapack_d = argv[5];
  rblapack_q = argv[6];
  rblapack_rho = argv[7];
  rblapack_qstore = argv[8];
  rblapack_qptr = argv[9];
  rblapack_prmptr = argv[10];
  rblapack_perm = argv[11];
  rblapack_givptr = argv[12];
  rblapack_givcol = argv[13];
  rblapack_givnum = argv[14];
  if (argc == 15) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  cutpnt = NUM2INT(rblapack_cutpnt);
  tlvls = NUM2INT(rblapack_tlvls);
  curpbm = NUM2INT(rblapack_curpbm);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (7th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  n = NA_SHAPE1(rblapack_q);
  if (NA_TYPE(rblapack_q) != NA_DCOMPLEX)
    rblapack_q = na_change_type(rblapack_q, NA_DCOMPLEX);
  q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
  qsiz = NUM2INT(rblapack_qsiz);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (6th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of q");
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_qstore))
    rb_raise(rb_eArgError, "qstore (9th argument) must be NArray");
  if (NA_RANK(rblapack_qstore) != 1)
    rb_raise(rb_eArgError, "rank of qstore (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_qstore) != (pow(n,2)+1))
    rb_raise(rb_eRuntimeError, "shape 0 of qstore must be %d", pow(n,2)+1);
  if (NA_TYPE(rblapack_qstore) != NA_DFLOAT)
    rblapack_qstore = na_change_type(rblapack_qstore, NA_DFLOAT);
  qstore = NA_PTR_TYPE(rblapack_qstore, doublereal*);
  if (!NA_IsNArray(rblapack_prmptr))
    rb_raise(rb_eArgError, "prmptr (11th argument) must be NArray");
  if (NA_RANK(rblapack_prmptr) != 1)
    rb_raise(rb_eArgError, "rank of prmptr (11th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_prmptr) != (n*LG(n)))
    rb_raise(rb_eRuntimeError, "shape 0 of prmptr must be %d", n*LG(n));
  if (NA_TYPE(rblapack_prmptr) != NA_LINT)
    rblapack_prmptr = na_change_type(rblapack_prmptr, NA_LINT);
  prmptr = NA_PTR_TYPE(rblapack_prmptr, integer*);
  if (!NA_IsNArray(rblapack_givptr))
    rb_raise(rb_eArgError, "givptr (13th argument) must be NArray");
  if (NA_RANK(rblapack_givptr) != 1)
    rb_raise(rb_eArgError, "rank of givptr (13th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_givptr) != (n*LG(n)))
    rb_raise(rb_eRuntimeError, "shape 0 of givptr must be %d", n*LG(n));
  if (NA_TYPE(rblapack_givptr) != NA_LINT)
    rblapack_givptr = na_change_type(rblapack_givptr, NA_LINT);
  givptr = NA_PTR_TYPE(rblapack_givptr, integer*);
  if (!NA_IsNArray(rblapack_givnum))
    rb_raise(rb_eArgError, "givnum (15th argument) must be NArray");
  if (NA_RANK(rblapack_givnum) != 2)
    rb_raise(rb_eArgError, "rank of givnum (15th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_givnum) != (2))
    rb_raise(rb_eRuntimeError, "shape 0 of givnum must be %d", 2);
  if (NA_SHAPE1(rblapack_givnum) != (n*LG(n)))
    rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", n*LG(n));
  if (NA_TYPE(rblapack_givnum) != NA_DFLOAT)
    rblapack_givnum = na_change_type(rblapack_givnum, NA_DFLOAT);
  givnum = NA_PTR_TYPE(rblapack_givnum, doublereal*);
  curlvl = NUM2INT(rblapack_curlvl);
  if (!NA_IsNArray(rblapack_qptr))
    rb_raise(rb_eArgError, "qptr (10th argument) must be NArray");
  if (NA_RANK(rblapack_qptr) != 1)
    rb_raise(rb_eArgError, "rank of qptr (10th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_qptr) != (n+2))
    rb_raise(rb_eRuntimeError, "shape 0 of qptr must be %d", n+2);
  if (NA_TYPE(rblapack_qptr) != NA_LINT)
    rblapack_qptr = na_change_type(rblapack_qptr, NA_LINT);
  qptr = NA_PTR_TYPE(rblapack_qptr, integer*);
  if (!NA_IsNArray(rblapack_givcol))
    rb_raise(rb_eArgError, "givcol (14th argument) must be NArray");
  if (NA_RANK(rblapack_givcol) != 2)
    rb_raise(rb_eArgError, "rank of givcol (14th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_givcol) != (2))
    rb_raise(rb_eRuntimeError, "shape 0 of givcol must be %d", 2);
  if (NA_SHAPE1(rblapack_givcol) != (n*LG(n)))
    rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", n*LG(n));
  if (NA_TYPE(rblapack_givcol) != NA_LINT)
    rblapack_givcol = na_change_type(rblapack_givcol, NA_LINT);
  givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
  rho = NUM2DBL(rblapack_rho);
  if (!NA_IsNArray(rblapack_perm))
    rb_raise(rb_eArgError, "perm (12th argument) must be NArray");
  if (NA_RANK(rblapack_perm) != 1)
    rb_raise(rb_eArgError, "rank of perm (12th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_perm) != (n*LG(n)))
    rb_raise(rb_eRuntimeError, "shape 0 of perm must be %d", n*LG(n));
  if (NA_TYPE(rblapack_perm) != NA_LINT)
    rblapack_perm = na_change_type(rblapack_perm, NA_LINT);
  perm = NA_PTR_TYPE(rblapack_perm, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_indxq = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  indxq = NA_PTR_TYPE(rblapack_indxq, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublecomplex*);
  MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  {
    na_shape_t shape[1];
    shape[0] = pow(n,2)+1;
    rblapack_qstore_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  qstore_out__ = NA_PTR_TYPE(rblapack_qstore_out__, doublereal*);
  MEMCPY(qstore_out__, qstore, doublereal, NA_TOTAL(rblapack_qstore));
  rblapack_qstore = rblapack_qstore_out__;
  qstore = qstore_out__;
  {
    na_shape_t shape[1];
    shape[0] = n+2;
    rblapack_qptr_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  qptr_out__ = NA_PTR_TYPE(rblapack_qptr_out__, integer*);
  MEMCPY(qptr_out__, qptr, integer, NA_TOTAL(rblapack_qptr));
  rblapack_qptr = rblapack_qptr_out__;
  qptr = qptr_out__;
  work = ALLOC_N(doublecomplex, (qsiz*n));
  rwork = ALLOC_N(doublereal, (3*n+2*qsiz*n));
  iwork = ALLOC_N(integer, (4*n));

  zlaed7_(&n, &cutpnt, &qsiz, &tlvls, &curlvl, &curpbm, d, q, &ldq, &rho, indxq, qstore, qptr, prmptr, perm, givptr, givcol, givnum, work, rwork, iwork, &info);

  free(work);
  free(rwork);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_indxq, rblapack_info, rblapack_d, rblapack_q, rblapack_qstore, rblapack_qptr);
}

void
init_lapack_zlaed7(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlaed7", rblapack_zlaed7, -1);
}
ruby-lapack-1.7.2/ext/dlaic1.c0000644000175000017500000001131512502221013015655 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaic1_(integer* job, integer* j, doublereal* x, doublereal* sest, doublereal* w, doublereal* gamma, doublereal* sestpr, doublereal* s, doublereal* c);


static VALUE
rblapack_dlaic1(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  integer job; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_sest;
  doublereal sest; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_gamma;
  doublereal gamma; 
  VALUE rblapack_sestpr;
  doublereal sestpr; 
  VALUE rblapack_s;
  doublereal s; 
  VALUE rblapack_c;
  doublereal c; 

  integer j;

  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  sestpr, s, c = NumRu::Lapack.dlaic1( job, x, sest, w, gamma, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C )\n\n*  Purpose\n*  =======\n*\n*  DLAIC1 applies one step of incremental condition estimation in\n*  its simplest version:\n*\n*  Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j\n*  lower triangular matrix L, such that\n*           twonorm(L*x) = sest\n*  Then DLAIC1 computes sestpr, s, c such that\n*  the vector\n*                  [ s*x ]\n*           xhat = [  c  ]\n*  is an approximate singular vector of\n*                  [ L     0  ]\n*           Lhat = [ w' gamma ]\n*  in the sense that\n*           twonorm(Lhat*xhat) = sestpr.\n*\n*  Depending on JOB, an estimate for the largest or smallest singular\n*  value is computed.\n*\n*  Note that [s c]' and sestpr**2 is an eigenpair of the system\n*\n*      diag(sest*sest, 0) + [alpha  gamma] * [ alpha ]\n*                                            [ gamma ]\n*\n*  where  alpha =  x'*w.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) INTEGER\n*          = 1: an estimate for the largest singular value is computed.\n*          = 2: an estimate for the smallest singular value is computed.\n*\n*  J       (input) INTEGER\n*          Length of X and W\n*\n*  X       (input) DOUBLE PRECISION array, dimension (J)\n*          The j-vector x.\n*\n*  SEST    (input) DOUBLE PRECISION\n*          Estimated singular value of j by j matrix L\n*\n*  W       (input) DOUBLE PRECISION array, dimension (J)\n*          The j-vector w.\n*\n*  GAMMA   (input) DOUBLE PRECISION\n*          The diagonal element gamma.\n*\n*  SESTPR  (output) DOUBLE PRECISION\n*          Estimated singular value of (j+1) by (j+1) matrix Lhat.\n*\n*  S       (output) DOUBLE PRECISION\n*          Sine needed in forming xhat.\n*\n*  C       (output) DOUBLE PRECISION\n*          Cosine needed in forming xhat.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sestpr, s, c = NumRu::Lapack.dlaic1( job, x, sest, w, gamma, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_job = argv[0];
  rblapack_x = argv[1];
  rblapack_sest = argv[2];
  rblapack_w = argv[3];
  rblapack_gamma = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  job = NUM2INT(rblapack_job);
  sest = NUM2DBL(rblapack_sest);
  gamma = NUM2DBL(rblapack_gamma);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
  j = NA_SHAPE0(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  if (!NA_IsNArray(rblapack_w))
    rb_raise(rb_eArgError, "w (4th argument) must be NArray");
  if (NA_RANK(rblapack_w) != 1)
    rb_raise(rb_eArgError, "rank of w (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_w) != j)
    rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of x");
  if (NA_TYPE(rblapack_w) != NA_DFLOAT)
    rblapack_w = na_change_type(rblapack_w, NA_DFLOAT);
  w = NA_PTR_TYPE(rblapack_w, doublereal*);

  dlaic1_(&job, &j, x, &sest, w, &gamma, &sestpr, &s, &c);

  rblapack_sestpr = rb_float_new((double)sestpr);
  rblapack_s = rb_float_new((double)s);
  rblapack_c = rb_float_new((double)c);
  return rb_ary_new3(3, rblapack_sestpr, rblapack_s, rblapack_c);
}

void
init_lapack_dlaic1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaic1", rblapack_dlaic1, -1);
}
ruby-lapack-1.7.2/ext/zlartv.c0000644000175000017500000001350412502221013016044 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlartv_(integer* n, doublecomplex* x, integer* incx, doublecomplex* y, integer* incy, doublereal* c, doublecomplex* s, integer* incc);


static VALUE
rblapack_zlartv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_y;
  doublecomplex *y; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_s;
  doublecomplex *s; 
  VALUE rblapack_incc;
  integer incc; 
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;
  VALUE rblapack_y_out__;
  doublecomplex *y_out__;


  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  x, y = NumRu::Lapack.zlartv( n, x, incx, y, incy, c, s, incc, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLARTV( N, X, INCX, Y, INCY, C, S, INCC )\n\n*  Purpose\n*  =======\n*\n*  ZLARTV applies a vector of complex plane rotations with real cosines\n*  to elements of the complex vectors x and y. For i = 1,2,...,n\n*\n*     ( x(i) ) := (        c(i)   s(i) ) ( x(i) )\n*     ( y(i) )    ( -conjg(s(i))  c(i) ) ( y(i) )\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of plane rotations to be applied.\n*\n*  X       (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCX)\n*          The vector x.\n*\n*  INCX    (input) INTEGER\n*          The increment between elements of X. INCX > 0.\n*\n*  Y       (input/output) COMPLEX*16 array, dimension (1+(N-1)*INCY)\n*          The vector y.\n*\n*  INCY    (input) INTEGER\n*          The increment between elements of Y. INCY > 0.\n*\n*  C       (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)\n*          The cosines of the plane rotations.\n*\n*  S       (input) COMPLEX*16 array, dimension (1+(N-1)*INCC)\n*          The sines of the plane rotations.\n*\n*  INCC    (input) INTEGER\n*          The increment between elements of C and S. INCC > 0.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, IC, IX, IY\n      COMPLEX*16         XI, YI\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          DCONJG\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, y = NumRu::Lapack.zlartv( n, x, incx, y, incy, c, s, incc, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_n = argv[0];
  rblapack_x = argv[1];
  rblapack_incx = argv[2];
  rblapack_y = argv[3];
  rblapack_incy = argv[4];
  rblapack_c = argv[5];
  rblapack_s = argv[6];
  rblapack_incc = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  incx = NUM2INT(rblapack_incx);
  incy = NUM2INT(rblapack_incy);
  incc = NUM2INT(rblapack_incc);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1+(n-1)*incx))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != (1+(n-1)*incc))
    rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", 1+(n-1)*incc);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (4th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incy))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
  if (NA_TYPE(rblapack_y) != NA_DCOMPLEX)
    rblapack_y = na_change_type(rblapack_y, NA_DCOMPLEX);
  y = NA_PTR_TYPE(rblapack_y, doublecomplex*);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (7th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != (1+(n-1)*incc))
    rb_raise(rb_eRuntimeError, "shape 0 of s must be %d", 1+(n-1)*incc);
  if (NA_TYPE(rblapack_s) != NA_DCOMPLEX)
    rblapack_s = na_change_type(rblapack_s, NA_DCOMPLEX);
  s = NA_PTR_TYPE(rblapack_s, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incx;
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incy;
    rblapack_y_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublecomplex*);
  MEMCPY(y_out__, y, doublecomplex, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  zlartv_(&n, x, &incx, y, &incy, c, s, &incc);

  return rb_ary_new3(2, rblapack_x, rblapack_y);
}

void
init_lapack_zlartv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlartv", rblapack_zlartv, -1);
}
ruby-lapack-1.7.2/ext/cgebrd.c0000644000175000017500000002126112502221017015753 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgebrd_(integer* m, integer* n, complex* a, integer* lda, real* d, real* e, complex* tauq, complex* taup, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_cgebrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_tauq;
  complex *tauq; 
  VALUE rblapack_taup;
  complex *taup; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *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  d, e, tauq, taup, work, info, a = NumRu::Lapack.cgebrd( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGEBRD reduces a general complex M-by-N matrix A to upper or lower\n*  bidiagonal form B by a unitary transformation: Q**H * A * P = B.\n*\n*  If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows in the matrix A.  M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns in the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the M-by-N general matrix to be reduced.\n*          On exit,\n*          if m >= n, the diagonal and the first superdiagonal are\n*            overwritten with the upper bidiagonal matrix B; the\n*            elements below the diagonal, with the array TAUQ, represent\n*            the unitary matrix Q as a product of elementary\n*            reflectors, and the elements above the first superdiagonal,\n*            with the array TAUP, represent the unitary matrix P as\n*            a product of elementary reflectors;\n*          if m < n, the diagonal and the first subdiagonal are\n*            overwritten with the lower bidiagonal matrix B; the\n*            elements below the first subdiagonal, with the array TAUQ,\n*            represent the unitary matrix Q as a product of\n*            elementary reflectors, and the elements above the diagonal,\n*            with the array TAUP, represent the unitary matrix P as\n*            a product of elementary reflectors.\n*          See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  D       (output) REAL array, dimension (min(M,N))\n*          The diagonal elements of the bidiagonal matrix B:\n*          D(i) = A(i,i).\n*\n*  E       (output) REAL array, dimension (min(M,N)-1)\n*          The off-diagonal elements of the bidiagonal matrix B:\n*          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n*          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n*\n*  TAUQ    (output) COMPLEX array dimension (min(M,N))\n*          The scalar factors of the elementary reflectors which\n*          represent the unitary matrix Q. See Further Details.\n*\n*  TAUP    (output) COMPLEX array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors which\n*          represent the unitary matrix P. See Further Details.\n*\n*  WORK    (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of the array WORK.  LWORK >= max(1,M,N).\n*          For optimum performance LWORK >= (M+N)*NB, where NB\n*          is the 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 matrices Q and P are represented as products of elementary\n*  reflectors:\n*\n*  If m >= n,\n*\n*     Q = H(1) H(2) . . . H(n)  and  P = G(1) G(2) . . . G(n-1)\n*\n*  Each H(i) and G(i) has the form:\n*\n*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'\n*\n*  where tauq and taup are complex scalars, and v and u are complex\n*  vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in\n*  A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in\n*  A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n*  If m < n,\n*\n*     Q = H(1) H(2) . . . H(m-1)  and  P = G(1) G(2) . . . G(m)\n*\n*  Each H(i) and G(i) has the form:\n*\n*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'\n*\n*  where tauq and taup are complex scalars, and v and u are complex\n*  vectors; v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in\n*  A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in\n*  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n*  The contents of A on exit are illustrated by the following examples:\n*\n*  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):\n*\n*    (  d   e   u1  u1  u1 )           (  d   u1  u1  u1  u1  u1 )\n*    (  v1  d   e   u2  u2 )           (  e   d   u2  u2  u2  u2 )\n*    (  v1  v2  d   e   u3 )           (  v1  e   d   u3  u3  u3 )\n*    (  v1  v2  v3  d   e  )           (  v1  v2  e   d   u4  u4 )\n*    (  v1  v2  v3  v4  d  )           (  v1  v2  v3  e   d   u5 )\n*    (  v1  v2  v3  v4  v5 )\n*\n*  where d and e denote diagonal and off-diagonal elements of B, vi\n*  denotes an element of the vector defining H(i), and ui an element of\n*  the vector defining G(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, tauq, taup, work, info, a = NumRu::Lapack.cgebrd( 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;
  }

  m = NUM2INT(rblapack_m);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (rblapack_lwork == Qnil)
    lwork = MAX(m,n);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, real*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n)-1;
    rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tauq = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  tauq = NA_PTR_TYPE(rblapack_tauq, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_taup = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  taup = NA_PTR_TYPE(rblapack_taup, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  cgebrd_(&m, &n, a, &lda, d, e, tauq, taup, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_d, rblapack_e, rblapack_tauq, rblapack_taup, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_cgebrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgebrd", rblapack_cgebrd, -1);
}
ruby-lapack-1.7.2/ext/zsysv.c0000644000175000017500000002047112502221024015723 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zsysv_(char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* b, integer* ldb, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zsysv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  ipiv, work, info, a, b = NumRu::Lapack.zsysv( uplo, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZSYSV computes the solution to a complex system of linear equations\n*     A * X = B,\n*  where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n*  matrices.\n*\n*  The diagonal pivoting method is used to factor A as\n*     A = U * D * U**T,  if UPLO = 'U', or\n*     A = L * D * L**T,  if UPLO = 'L',\n*  where U (or L) is a product of permutation and unit upper (lower)\n*  triangular matrices, and D is symmetric and block diagonal with\n*  1-by-1 and 2-by-2 diagonal blocks.  The factored form of A is then\n*  used to solve the system of equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the block diagonal matrix D and the\n*          multipliers used to obtain the factor U or L from the\n*          factorization A = U*D*U**T or A = L*D*L**T as computed by\n*          ZSYTRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D, as\n*          determined by ZSYTRF.  If IPIV(k) > 0, then rows and columns\n*          k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n*          diagonal block.  If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n*          then rows and columns k-1 and -IPIV(k) were interchanged and\n*          D(k-1:k,k-1:k) is a 2-by-2 diagonal block.  If UPLO = 'L' and\n*          IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n*          -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n*          diagonal block.\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of WORK.  LWORK >= 1, and for best performance\n*          LWORK >= max(1,N*NB), where NB is the optimal blocksize for\n*          ZSYTRF.\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, D(i,i) is exactly zero.  The factorization\n*               has been completed, but the block diagonal matrix D is\n*               exactly singular, so the solution could not be computed.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY\n      INTEGER            LWKOPT, NB\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            ILAENV\n      EXTERNAL           LSAME, ILAENV\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           XERBLA, ZSYTRF, ZSYTRS2\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, work, info, a, b = NumRu::Lapack.zsysv( uplo, 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_uplo = 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;
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zsysv_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_ipiv, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_zsysv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zsysv", rblapack_zsysv, -1);
}
ruby-lapack-1.7.2/ext/zgttrf.c0000644000175000017500000001513612502221025016050 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgttrf_(integer* n, doublecomplex* dl, doublecomplex* d, doublecomplex* du, doublecomplex* du2, integer* ipiv, integer* info);


static VALUE
rblapack_zgttrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_dl;
  doublecomplex *dl; 
  VALUE rblapack_d;
  doublecomplex *d; 
  VALUE rblapack_du;
  doublecomplex *du; 
  VALUE rblapack_du2;
  doublecomplex *du2; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_dl_out__;
  doublecomplex *dl_out__;
  VALUE rblapack_d_out__;
  doublecomplex *d_out__;
  VALUE rblapack_du_out__;
  doublecomplex *du_out__;

  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  du2, ipiv, info, dl, d, du = NumRu::Lapack.zgttrf( dl, d, du, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGTTRF( N, DL, D, DU, DU2, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGTTRF computes an LU factorization of a complex tridiagonal matrix A\n*  using elimination with partial pivoting and row interchanges.\n*\n*  The factorization has the form\n*     A = L * U\n*  where L is a product of permutation and unit lower bidiagonal\n*  matrices and U is upper triangular with nonzeros in only the main\n*  diagonal and first two superdiagonals.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.\n*\n*  DL      (input/output) COMPLEX*16 array, dimension (N-1)\n*          On entry, DL must contain the (n-1) sub-diagonal elements of\n*          A.\n*\n*          On exit, DL is overwritten by the (n-1) multipliers that\n*          define the matrix L from the LU factorization of A.\n*\n*  D       (input/output) COMPLEX*16 array, dimension (N)\n*          On entry, D must contain the diagonal elements of A.\n*\n*          On exit, D is overwritten by the n diagonal elements of the\n*          upper triangular matrix U from the LU factorization of A.\n*\n*  DU      (input/output) COMPLEX*16 array, dimension (N-1)\n*          On entry, DU must contain the (n-1) super-diagonal elements\n*          of A.\n*\n*          On exit, DU is overwritten by the (n-1) elements of the first\n*          super-diagonal of U.\n*\n*  DU2     (output) COMPLEX*16 array, dimension (N-2)\n*          On exit, DU2 is overwritten by the (n-2) elements of the\n*          second super-diagonal of U.\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          The pivot indices; for 1 <= i <= n, row i of the matrix was\n*          interchanged with row IPIV(i).  IPIV(i) will always be either\n*          i or i+1; IPIV(i) = i indicates a row interchange was not\n*          required.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -k, the k-th argument had an illegal value\n*          > 0:  if INFO = k, U(k,k) is exactly zero. The factorization\n*                has been completed, but the factor U is exactly\n*                singular, and division by zero will occur if it is used\n*                to solve a system of equations.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  du2, ipiv, info, dl, d, du = NumRu::Lapack.zgttrf( dl, d, du, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_dl = argv[0];
  rblapack_d = argv[1];
  rblapack_du = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DCOMPLEX)
    rblapack_d = na_change_type(rblapack_d, NA_DCOMPLEX);
  d = NA_PTR_TYPE(rblapack_d, doublecomplex*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (1th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (1th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_DCOMPLEX)
    rblapack_dl = na_change_type(rblapack_dl, NA_DCOMPLEX);
  dl = NA_PTR_TYPE(rblapack_dl, doublecomplex*);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (3th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_DCOMPLEX)
    rblapack_du = na_change_type(rblapack_du, NA_DCOMPLEX);
  du = NA_PTR_TYPE(rblapack_du, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n-2;
    rblapack_du2 = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  du2 = NA_PTR_TYPE(rblapack_du2, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_dl_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  dl_out__ = NA_PTR_TYPE(rblapack_dl_out__, doublecomplex*);
  MEMCPY(dl_out__, dl, doublecomplex, NA_TOTAL(rblapack_dl));
  rblapack_dl = rblapack_dl_out__;
  dl = dl_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublecomplex*);
  MEMCPY(d_out__, d, doublecomplex, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_du_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  du_out__ = NA_PTR_TYPE(rblapack_du_out__, doublecomplex*);
  MEMCPY(du_out__, du, doublecomplex, NA_TOTAL(rblapack_du));
  rblapack_du = rblapack_du_out__;
  du = du_out__;

  zgttrf_(&n, dl, d, du, du2, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_du2, rblapack_ipiv, rblapack_info, rblapack_dl, rblapack_d, rblapack_du);
}

void
init_lapack_zgttrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgttrf", rblapack_zgttrf, -1);
}
ruby-lapack-1.7.2/ext/zgelsd.c0000644000175000017500000002521712502221016016021 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgelsd_(integer* m, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublereal* s, doublereal* rcond, integer* rank, doublecomplex* work, integer* lwork, doublereal* rwork, integer* iwork, integer* info);


static VALUE
rblapack_zgelsd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_rank;
  integer rank; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  doublereal *rwork;
  integer *iwork;

  integer lda;
  integer n;
  integer m;
  integer nrhs;
  integer ldb;
  integer c__9;
  integer c__0;
  integer liwork;
  integer lrwork;
  integer nlvl;
  integer smlsiz;

  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  s, rank, work, info, b = NumRu::Lapack.zgelsd( a, b, rcond, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, WORK, LWORK, RWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGELSD computes the minimum-norm solution to a real linear least\n*  squares problem:\n*      minimize 2-norm(| b - A*x |)\n*  using the singular value decomposition (SVD) of A. A is an M-by-N\n*  matrix which may be rank-deficient.\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*  The problem is solved in three steps:\n*  (1) Reduce the coefficient matrix A to bidiagonal form with\n*      Householder tranformations, reducing the original problem\n*      into a \"bidiagonal least squares problem\" (BLS)\n*  (2) Solve the BLS using a divide and conquer approach.\n*  (3) Apply back all the Householder tranformations to solve\n*      the original least squares problem.\n*\n*  The effective rank of A is determined by treating as zero those\n*  singular values which are less than RCOND times the largest singular\n*  value.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\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*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X. NRHS >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, A has been destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the M-by-NRHS right hand side matrix B.\n*          On exit, B is overwritten by the N-by-NRHS solution matrix X.\n*          If m >= n and RANK = n, the residual sum-of-squares for\n*          the solution in the i-th column is given by the sum of\n*          squares of the modulus of elements n+1:m in that column.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,M,N).\n*\n*  S       (output) DOUBLE PRECISION array, dimension (min(M,N))\n*          The singular values of A in decreasing order.\n*          The condition number of A in the 2-norm = S(1)/S(min(m,n)).\n*\n*  RCOND   (input) DOUBLE PRECISION\n*          RCOND is used to determine the effective rank of A.\n*          Singular values S(i) <= RCOND*S(1) are treated as zero.\n*          If RCOND < 0, machine precision is used instead.\n*\n*  RANK    (output) INTEGER\n*          The effective rank of A, i.e., the number of singular values\n*          which are greater than RCOND*S(1).\n*\n*  WORK    (workspace/output) COMPLEX*16 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 must be at least 1.\n*          The exact minimum amount of workspace needed depends on M,\n*          N and NRHS. As long as LWORK is at least\n*              2*N + N*NRHS\n*          if M is greater than or equal to N or\n*              2*M + M*NRHS\n*          if M is less than N, the code will execute correctly.\n*          For good performance, LWORK should generally be larger.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal size of the array WORK and the\n*          minimum sizes of the arrays RWORK and IWORK, and returns\n*          these values as the first entries of the WORK, RWORK and\n*          IWORK arrays, and no error message related to LWORK is issued\n*          by XERBLA.\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (MAX(1,LRWORK))\n*          LRWORK >=\n*             10*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS +\n*             MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS )\n*          if M is greater than or equal to N or\n*             10*M + 2*M*SMLSIZ + 8*M*NLVL + 3*SMLSIZ*NRHS +\n*             MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS )\n*          if M is less than N, the code will execute correctly.\n*          SMLSIZ is returned by ILAENV and is equal to the maximum\n*          size of the subproblems at the bottom of the computation\n*          tree (usually about 25), and\n*             NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )\n*          On exit, if INFO = 0, RWORK(1) returns the minimum LRWORK.\n*\n*  IWORK   (workspace) INTEGER array, dimension (MAX(1,LIWORK))\n*          LIWORK >= max(1, 3*MINMN*NLVL + 11*MINMN),\n*          where MINMN = MIN( M,N ).\n*          On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -i, the i-th argument had an illegal value.\n*          > 0:  the algorithm for computing the SVD failed to converge;\n*                if INFO = i, i off-diagonal elements of an intermediate\n*                bidiagonal form did not converge to zero.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Ren-Cang Li, Computer Science Division, University of\n*       California at Berkeley, USA\n*     Osni Marques, LBNL/NERSC, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, rank, work, info, b = NumRu::Lapack.zgelsd( a, b, rcond, [: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_a = argv[0];
  rblapack_b = argv[1];
  rblapack_rcond = 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 (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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  rcond = NUM2DBL(rblapack_rcond);
  m = lda;
  c__9 = 9;
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th 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_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  ldb = MAX(m,n);
  if (rblapack_lwork == Qnil)
    lwork = m>=n ? 2*n+n*nrhs : 2*m+m*nrhs;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  c__0 = 0;
  smlsiz = ilaenv_(&c__9,"ZGELSD"," ",&c__0,&c__0,&c__0,&c__0);
  nlvl = MAX(0,(int)(log(1.0*MIN(m,n)/(smlsiz+1))/log(2.0)));
  liwork = MAX(1,3*(MIN(m,n))*nlvl+11*(MIN(m,n)));
  lrwork = m>=n ? 10*n+2*n*smlsiz+8*n*nlvl+3*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1) : 10*m+2*m*smlsiz+8*m*nlvl+2*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = MAX(m, n);
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  {
    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__;
  rwork = ALLOC_N(doublereal, (MAX(1,lrwork)));
  iwork = ALLOC_N(integer, (MAX(1,liwork)));

  zgelsd_(&m, &n, &nrhs, a, &lda, b, &ldb, s, &rcond, &rank, work, &lwork, rwork, iwork, &info);

  free(rwork);
  free(iwork);
  rblapack_rank = INT2NUM(rank);
  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(5, rblapack_s, rblapack_rank, rblapack_work, rblapack_info, rblapack_b);
}

void
init_lapack_zgelsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgelsd", rblapack_zgelsd, -1);
}
ruby-lapack-1.7.2/ext/cupmtr.c0000644000175000017500000001447012502221013016037 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cupmtr_(char* side, char* uplo, char* trans, integer* m, integer* n, complex* ap, complex* tau, complex* c, integer* ldc, complex* work, integer* info);


static VALUE
rblapack_cupmtr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_c;
  complex *c; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  complex *c_out__;
  complex *work;

  integer ldc;
  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  info, c = NumRu::Lapack.cupmtr( side, uplo, trans, m, ap, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CUPMTR overwrites the general complex M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'C':      Q**H * C       C * Q**H\n*\n*  where Q is a complex unitary matrix of order nq, with nq = m if\n*  SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of\n*  nq-1 elementary reflectors, as returned by CHPTRD using packed\n*  storage:\n*\n*  if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);\n*\n*  if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**H from the Left;\n*          = 'R': apply Q or Q**H from the Right.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U': Upper triangular packed storage used in previous\n*                 call to CHPTRD;\n*          = 'L': Lower triangular packed storage used in previous\n*                 call to CHPTRD.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'C':  Conjugate transpose, apply Q**H.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  AP      (input) COMPLEX array, dimension\n*                               (M*(M+1)/2) if SIDE = 'L'\n*                               (N*(N+1)/2) if SIDE = 'R'\n*          The vectors which define the elementary reflectors, as\n*          returned by CHPTRD.  AP is modified by the routine but\n*          restored on exit.\n*\n*  TAU     (input) COMPLEX array, dimension (M-1) if SIDE = 'L'\n*                                     or (N-1) if SIDE = 'R'\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by CHPTRD.\n*\n*  C       (input/output) COMPLEX array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) COMPLEX array, dimension\n*                                   (N) if SIDE = 'L'\n*                                   (M) if SIDE = 'R'\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, c = NumRu::Lapack.cupmtr( side, uplo, trans, m, ap, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_side = argv[0];
  rblapack_uplo = argv[1];
  rblapack_trans = argv[2];
  rblapack_m = argv[3];
  rblapack_ap = argv[4];
  rblapack_tau = argv[5];
  rblapack_c = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, complex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (6th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_tau) != (m-1))
    rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", m-1);
  if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (m*(m+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", m*(m+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
  MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(complex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  cupmtr_(&side, &uplo, &trans, &m, &n, ap, tau, c, &ldc, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_c);
}

void
init_lapack_cupmtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cupmtr", rblapack_cupmtr, -1);
}
ruby-lapack-1.7.2/ext/chetd2.c0000644000175000017500000001535012502221020015672 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chetd2_(char* uplo, integer* n, complex* a, integer* lda, real* d, real* e, complex* tau, integer* info);


static VALUE
rblapack_chetd2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *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  d, e, tau, info, a = NumRu::Lapack.chetd2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHETD2( UPLO, N, A, LDA, D, E, TAU, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHETD2 reduces a complex Hermitian matrix A to real symmetric\n*  tridiagonal form T by a unitary similarity transformation:\n*  Q' * A * Q = T.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          Hermitian matrix A is stored:\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading\n*          n-by-n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n-by-n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*          On exit, if UPLO = 'U', the diagonal and first superdiagonal\n*          of A are overwritten by the corresponding elements of the\n*          tridiagonal matrix T, and the elements above the first\n*          superdiagonal, with the array TAU, represent the unitary\n*          matrix Q as a product of elementary reflectors; if UPLO\n*          = 'L', the diagonal and first subdiagonal of A are over-\n*          written by the corresponding elements of the tridiagonal\n*          matrix T, and the elements below the first subdiagonal, with\n*          the array TAU, represent the unitary matrix Q as a product\n*          of elementary reflectors. See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  D       (output) REAL array, dimension (N)\n*          The diagonal elements of the tridiagonal matrix T:\n*          D(i) = A(i,i).\n*\n*  E       (output) REAL array, dimension (N-1)\n*          The off-diagonal elements of the tridiagonal matrix T:\n*          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n*  TAU     (output) COMPLEX array, dimension (N-1)\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\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*  If UPLO = 'U', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(n-1) . . . H(2) H(1).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - tau * v * v'\n*\n*  where tau is a complex scalar, and v is a complex vector with\n*  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n*  A(1:i-1,i+1), and tau in TAU(i).\n*\n*  If UPLO = 'L', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(1) H(2) . . . H(n-1).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - tau * v * v'\n*\n*  where tau is a complex scalar, and v is a complex vector with\n*  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n*  and tau in TAU(i).\n*\n*  The contents of A on exit are illustrated by the following examples\n*  with n = 5:\n*\n*  if UPLO = 'U':                       if UPLO = 'L':\n*\n*    (  d   e   v2  v3  v4 )              (  d                  )\n*    (      d   e   v3  v4 )              (  e   d              )\n*    (          d   e   v4 )              (  v1  e   d          )\n*    (              d   e  )              (  v1  v2  e   d      )\n*    (                  d  )              (  v1  v2  v3  e   d  )\n*\n*  where d and e denote diagonal and off-diagonal elements of T, and vi\n*  denotes an element of the vector defining H(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, tau, info, a = NumRu::Lapack.chetd2( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, real*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  chetd2_(&uplo, &n, a, &lda, d, e, tau, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_d, rblapack_e, rblapack_tau, rblapack_info, rblapack_a);
}

void
init_lapack_chetd2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chetd2", rblapack_chetd2, -1);
}
ruby-lapack-1.7.2/ext/claesy.c0000644000175000017500000001106112502221014015777 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID claesy_(complex* a, complex* b, complex* c, complex* rt1, complex* rt2, complex* evscal, complex* cs1, complex* sn1);


static VALUE
rblapack_claesy(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  complex a; 
  VALUE rblapack_b;
  complex b; 
  VALUE rblapack_c;
  complex c; 
  VALUE rblapack_rt1;
  complex rt1; 
  VALUE rblapack_rt2;
  complex rt2; 
  VALUE rblapack_evscal;
  complex evscal; 
  VALUE rblapack_cs1;
  complex cs1; 
  VALUE rblapack_sn1;
  complex sn1; 


  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  rt1, rt2, evscal, cs1, sn1 = NumRu::Lapack.claesy( a, b, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAESY( A, B, C, RT1, RT2, EVSCAL, CS1, SN1 )\n\n*  Purpose\n*  =======\n*\n*  CLAESY computes the eigendecomposition of a 2-by-2 symmetric matrix\n*     ( ( A, B );( B, C ) )\n*  provided the norm of the matrix of eigenvectors is larger than\n*  some threshold value.\n*\n*  RT1 is the eigenvalue of larger absolute value, and RT2 of\n*  smaller absolute value.  If the eigenvectors are computed, then\n*  on return ( CS1, SN1 ) is the unit eigenvector for RT1, hence\n*\n*  [  CS1     SN1   ] . [ A  B ] . [ CS1    -SN1   ] = [ RT1  0  ]\n*  [ -SN1     CS1   ]   [ B  C ]   [ SN1     CS1   ]   [  0  RT2 ]\n*\n\n*  Arguments\n*  =========\n*\n*  A       (input) COMPLEX\n*          The ( 1, 1 ) element of input matrix.\n*\n*  B       (input) COMPLEX\n*          The ( 1, 2 ) element of input matrix.  The ( 2, 1 ) element\n*          is also given by B, since the 2-by-2 matrix is symmetric.\n*\n*  C       (input) COMPLEX\n*          The ( 2, 2 ) element of input matrix.\n*\n*  RT1     (output) COMPLEX\n*          The eigenvalue of larger modulus.\n*\n*  RT2     (output) COMPLEX\n*          The eigenvalue of smaller modulus.\n*\n*  EVSCAL  (output) COMPLEX\n*          The complex value by which the eigenvector matrix was scaled\n*          to make it orthonormal.  If EVSCAL is zero, the eigenvectors\n*          were not computed.  This means one of two things:  the 2-by-2\n*          matrix could not be diagonalized, or the norm of the matrix\n*          of eigenvectors before scaling was larger than the threshold\n*          value THRESH (set below).\n*\n*  CS1     (output) COMPLEX\n*  SN1     (output) COMPLEX\n*          If EVSCAL .NE. 0,  ( CS1, SN1 ) is the unit right eigenvector\n*          for RT1.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rt1, rt2, evscal, cs1, sn1 = NumRu::Lapack.claesy( a, b, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  rblapack_c = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  a.r = (real)NUM2DBL(rb_funcall(rblapack_a, rb_intern("real"), 0));
  a.i = (real)NUM2DBL(rb_funcall(rblapack_a, rb_intern("imag"), 0));
  c.r = (real)NUM2DBL(rb_funcall(rblapack_c, rb_intern("real"), 0));
  c.i = (real)NUM2DBL(rb_funcall(rblapack_c, rb_intern("imag"), 0));
  b.r = (real)NUM2DBL(rb_funcall(rblapack_b, rb_intern("real"), 0));
  b.i = (real)NUM2DBL(rb_funcall(rblapack_b, rb_intern("imag"), 0));

  claesy_(&a, &b, &c, &rt1, &rt2, &evscal, &cs1, &sn1);

  rblapack_rt1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(rt1.r)), rb_float_new((double)(rt1.i)));
  rblapack_rt2 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(rt2.r)), rb_float_new((double)(rt2.i)));
  rblapack_evscal = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(evscal.r)), rb_float_new((double)(evscal.i)));
  rblapack_cs1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(cs1.r)), rb_float_new((double)(cs1.i)));
  rblapack_sn1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(sn1.r)), rb_float_new((double)(sn1.i)));
  return rb_ary_new3(5, rblapack_rt1, rblapack_rt2, rblapack_evscal, rblapack_cs1, rblapack_sn1);
}

void
init_lapack_claesy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "claesy", rblapack_claesy, -1);
}
ruby-lapack-1.7.2/ext/zhgeqz.c0000644000175000017500000003431312502221020016031 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhgeqz_(char* job, char* compq, char* compz, integer* n, integer* ilo, integer* ihi, doublecomplex* h, integer* ldh, doublecomplex* t, integer* ldt, doublecomplex* alpha, doublecomplex* beta, doublecomplex* q, integer* ldq, doublecomplex* z, integer* ldz, doublecomplex* work, integer* lwork, doublereal* rwork, integer* info);


static VALUE
rblapack_zhgeqz(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_compq;
  char compq; 
  VALUE rblapack_compz;
  char compz; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_h;
  doublecomplex *h; 
  VALUE rblapack_t;
  doublecomplex *t; 
  VALUE rblapack_q;
  doublecomplex *q; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_alpha;
  doublecomplex *alpha; 
  VALUE rblapack_beta;
  doublecomplex *beta; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_h_out__;
  doublecomplex *h_out__;
  VALUE rblapack_t_out__;
  doublecomplex *t_out__;
  VALUE rblapack_q_out__;
  doublecomplex *q_out__;
  VALUE rblapack_z_out__;
  doublecomplex *z_out__;
  doublereal *rwork;

  integer ldh;
  integer n;
  integer ldt;
  integer ldq;
  integer ldz;

  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  alpha, beta, work, info, h, t, q, z = NumRu::Lapack.zhgeqz( job, compq, compz, ilo, ihi, h, t, q, z, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHGEQZ computes the eigenvalues of a complex matrix pair (H,T),\n*  where H is an upper Hessenberg matrix and T is upper triangular,\n*  using the single-shift QZ method.\n*  Matrix pairs of this type are produced by the reduction to\n*  generalized upper Hessenberg form of a complex matrix pair (A,B):\n*  \n*     A = Q1*H*Z1**H,  B = Q1*T*Z1**H,\n*  \n*  as computed by ZGGHRD.\n*  \n*  If JOB='S', then the Hessenberg-triangular pair (H,T) is\n*  also reduced to generalized Schur form,\n*  \n*     H = Q*S*Z**H,  T = Q*P*Z**H,\n*  \n*  where Q and Z are unitary matrices and S and P are upper triangular.\n*  \n*  Optionally, the unitary matrix Q from the generalized Schur\n*  factorization may be postmultiplied into an input matrix Q1, and the\n*  unitary matrix Z may be postmultiplied into an input matrix Z1.\n*  If Q1 and Z1 are the unitary matrices from ZGGHRD that reduced\n*  the matrix pair (A,B) to generalized Hessenberg form, then the output\n*  matrices Q1*Q and Z1*Z are the unitary factors from the generalized\n*  Schur factorization of (A,B):\n*  \n*     A = (Q1*Q)*S*(Z1*Z)**H,  B = (Q1*Q)*P*(Z1*Z)**H.\n*  \n*  To avoid overflow, eigenvalues of the matrix pair (H,T)\n*  (equivalently, of (A,B)) are computed as a pair of complex values\n*  (alpha,beta).  If beta is nonzero, lambda = alpha / beta is an\n*  eigenvalue of the generalized nonsymmetric eigenvalue problem (GNEP)\n*     A*x = lambda*B*x\n*  and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the\n*  alternate form of the GNEP\n*     mu*A*y = B*y.\n*  The values of alpha and beta for the i-th eigenvalue can be read\n*  directly from the generalized Schur form:  alpha = S(i,i),\n*  beta = P(i,i).\n*\n*  Ref: C.B. Moler & G.W. Stewart, \"An Algorithm for Generalized Matrix\n*       Eigenvalue Problems\", SIAM J. Numer. Anal., 10(1973),\n*       pp. 241--256.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          = 'E': Compute eigenvalues only;\n*          = 'S': Computer eigenvalues and the Schur form.\n*\n*  COMPQ   (input) CHARACTER*1\n*          = 'N': Left Schur vectors (Q) are not computed;\n*          = 'I': Q is initialized to the unit matrix and the matrix Q\n*                 of left Schur vectors of (H,T) is returned;\n*          = 'V': Q must contain a unitary matrix Q1 on entry and\n*                 the product Q1*Q is returned.\n*\n*  COMPZ   (input) CHARACTER*1\n*          = 'N': Right Schur vectors (Z) are not computed;\n*          = 'I': Q is initialized to the unit matrix and the matrix Z\n*                 of right Schur vectors of (H,T) is returned;\n*          = 'V': Z must contain a unitary matrix Z1 on entry and\n*                 the product Z1*Z is returned.\n*\n*  N       (input) INTEGER\n*          The order of the matrices H, T, Q, and Z.  N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          ILO and IHI mark the rows and columns of H which are in\n*          Hessenberg form.  It is assumed that A is already upper\n*          triangular in rows and columns 1:ILO-1 and IHI+1:N.\n*          If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.\n*\n*  H       (input/output) COMPLEX*16 array, dimension (LDH, N)\n*          On entry, the N-by-N upper Hessenberg matrix H.\n*          On exit, if JOB = 'S', H contains the upper triangular\n*          matrix S from the generalized Schur factorization.\n*          If JOB = 'E', the diagonal of H matches that of S, but\n*          the rest of H is unspecified.\n*\n*  LDH     (input) INTEGER\n*          The leading dimension of the array H.  LDH >= max( 1, N ).\n*\n*  T       (input/output) COMPLEX*16 array, dimension (LDT, N)\n*          On entry, the N-by-N upper triangular matrix T.\n*          On exit, if JOB = 'S', T contains the upper triangular\n*          matrix P from the generalized Schur factorization.\n*          If JOB = 'E', the diagonal of T matches that of P, but\n*          the rest of T is unspecified.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T.  LDT >= max( 1, N ).\n*\n*  ALPHA   (output) COMPLEX*16 array, dimension (N)\n*          The complex scalars alpha that define the eigenvalues of\n*          GNEP.  ALPHA(i) = S(i,i) in the generalized Schur\n*          factorization.\n*\n*  BETA    (output) COMPLEX*16 array, dimension (N)\n*          The real non-negative scalars beta that define the\n*          eigenvalues of GNEP.  BETA(i) = P(i,i) in the generalized\n*          Schur factorization.\n*\n*          Together, the quantities alpha = ALPHA(j) and beta = BETA(j)\n*          represent the j-th eigenvalue of the matrix pair (A,B), in\n*          one of the forms lambda = alpha/beta or mu = beta/alpha.\n*          Since either lambda or mu may overflow, they should not,\n*          in general, be computed.\n*\n*  Q       (input/output) COMPLEX*16 array, dimension (LDQ, N)\n*          On entry, if COMPZ = 'V', the unitary matrix Q1 used in the\n*          reduction of (A,B) to generalized Hessenberg form.\n*          On exit, if COMPZ = 'I', the unitary matrix of left Schur\n*          vectors of (H,T), and if COMPZ = 'V', the unitary matrix of\n*          left Schur vectors of (A,B).\n*          Not referenced if COMPZ = 'N'.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.  LDQ >= 1.\n*          If COMPQ='V' or 'I', then LDQ >= N.\n*\n*  Z       (input/output) COMPLEX*16 array, dimension (LDZ, N)\n*          On entry, if COMPZ = 'V', the unitary matrix Z1 used in the\n*          reduction of (A,B) to generalized Hessenberg form.\n*          On exit, if COMPZ = 'I', the unitary matrix of right Schur\n*          vectors of (H,T), and if COMPZ = 'V', the unitary matrix of\n*          right Schur vectors of (A,B).\n*          Not referenced if COMPZ = 'N'.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1.\n*          If COMPZ='V' or 'I', then LDZ >= N.\n*\n*  WORK    (workspace/output) COMPLEX*16 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,N).\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*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -i, the i-th argument had an illegal value\n*          = 1,...,N: the QZ iteration did not converge.  (H,T) is not\n*                     in Schur form, but ALPHA(i) and BETA(i),\n*                     i=INFO+1,...,N should be correct.\n*          = N+1,...,2*N: the shift calculation failed.  (H,T) is not\n*                     in Schur form, but ALPHA(i) and BETA(i),\n*                     i=INFO-N+1,...,N should be correct.\n*\n\n*  Further Details\n*  ===============\n*\n*  We assume that complex ABS works as long as its value is less than\n*  overflow.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  alpha, beta, work, info, h, t, q, z = NumRu::Lapack.zhgeqz( job, compq, compz, ilo, ihi, h, t, q, z, [: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_job = argv[0];
  rblapack_compq = argv[1];
  rblapack_compz = argv[2];
  rblapack_ilo = argv[3];
  rblapack_ihi = argv[4];
  rblapack_h = argv[5];
  rblapack_t = argv[6];
  rblapack_q = argv[7];
  rblapack_z = 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;
  }

  job = StringValueCStr(rblapack_job)[0];
  compz = StringValueCStr(rblapack_compz)[0];
  ihi = NUM2INT(rblapack_ihi);
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (7th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (7th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  n = NA_SHAPE1(rblapack_t);
  if (NA_TYPE(rblapack_t) != NA_DCOMPLEX)
    rblapack_t = na_change_type(rblapack_t, NA_DCOMPLEX);
  t = NA_PTR_TYPE(rblapack_t, doublecomplex*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (9th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  if (NA_SHAPE1(rblapack_z) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of t");
  if (NA_TYPE(rblapack_z) != NA_DCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  compq = StringValueCStr(rblapack_compq)[0];
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (6th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  if (NA_SHAPE1(rblapack_h) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of t");
  if (NA_TYPE(rblapack_h) != NA_DCOMPLEX)
    rblapack_h = na_change_type(rblapack_h, NA_DCOMPLEX);
  h = NA_PTR_TYPE(rblapack_h, doublecomplex*);
  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (8th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (8th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of t");
  if (NA_TYPE(rblapack_q) != NA_DCOMPLEX)
    rblapack_q = na_change_type(rblapack_q, NA_DCOMPLEX);
  q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alpha = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  alpha = NA_PTR_TYPE(rblapack_alpha, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublecomplex*);
  MEMCPY(h_out__, h, doublecomplex, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = n;
    rblapack_t_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  t_out__ = NA_PTR_TYPE(rblapack_t_out__, doublecomplex*);
  MEMCPY(t_out__, t, doublecomplex, NA_TOTAL(rblapack_t));
  rblapack_t = rblapack_t_out__;
  t = t_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublecomplex*);
  MEMCPY(q_out__, q, doublecomplex, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublecomplex*);
  MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  rwork = ALLOC_N(doublereal, (n));

  zhgeqz_(&job, &compq, &compz, &n, &ilo, &ihi, h, &ldh, t, &ldt, alpha, beta, q, &ldq, z, &ldz, work, &lwork, rwork, &info);

  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_alpha, rblapack_beta, rblapack_work, rblapack_info, rblapack_h, rblapack_t, rblapack_q, rblapack_z);
}

void
init_lapack_zhgeqz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhgeqz", rblapack_zhgeqz, -1);
}
ruby-lapack-1.7.2/ext/sbdsqr.c0000644000175000017500000002711212502221020016016 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sbdsqr_(char* uplo, integer* n, integer* ncvt, integer* nru, integer* ncc, real* d, real* e, real* vt, integer* ldvt, real* u, integer* ldu, real* c, integer* ldc, real* work, integer* info);


static VALUE
rblapack_sbdsqr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_nru;
  integer nru; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_vt;
  real *vt; 
  VALUE rblapack_u;
  real *u; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_e_out__;
  real *e_out__;
  VALUE rblapack_vt_out__;
  real *vt_out__;
  VALUE rblapack_u_out__;
  real *u_out__;
  VALUE rblapack_c_out__;
  real *c_out__;
  real *work;

  integer n;
  integer ldvt;
  integer ncvt;
  integer ldu;
  integer ldc;
  integer ncc;

  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  info, d, e, vt, u, c = NumRu::Lapack.sbdsqr( uplo, nru, d, e, vt, u, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SBDSQR computes the singular values and, optionally, the right and/or\n*  left singular vectors from the singular value decomposition (SVD) of\n*  a real N-by-N (upper or lower) bidiagonal matrix B using the implicit\n*  zero-shift QR algorithm.  The SVD of B has the form\n*  \n*     B = Q * S * P**T\n*  \n*  where S is the diagonal matrix of singular values, Q is an orthogonal\n*  matrix of left singular vectors, and P is an orthogonal matrix of\n*  right singular vectors.  If left singular vectors are requested, this\n*  subroutine actually returns U*Q instead of Q, and, if right singular\n*  vectors are requested, this subroutine returns P**T*VT instead of\n*  P**T, for given real input matrices U and VT.  When U and VT are the\n*  orthogonal matrices that reduce a general matrix A to bidiagonal\n*  form:  A = U*B*VT, as computed by SGEBRD, then\n* \n*     A = (U*Q) * S * (P**T*VT)\n* \n*  is the SVD of A.  Optionally, the subroutine may also compute Q**T*C\n*  for a given real input matrix C.\n*\n*  See \"Computing  Small Singular Values of Bidiagonal Matrices With\n*  Guaranteed High Relative Accuracy,\" by J. Demmel and W. Kahan,\n*  LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,\n*  no. 5, pp. 873-912, Sept 1990) and\n*  \"Accurate singular values and differential qd algorithms,\" by\n*  B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics\n*  Department, University of California at Berkeley, July 1992\n*  for a detailed description of the algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  B is upper bidiagonal;\n*          = 'L':  B is lower bidiagonal.\n*\n*  N       (input) INTEGER\n*          The order of the matrix B.  N >= 0.\n*\n*  NCVT    (input) INTEGER\n*          The number of columns of the matrix VT. NCVT >= 0.\n*\n*  NRU     (input) INTEGER\n*          The number of rows of the matrix U. NRU >= 0.\n*\n*  NCC     (input) INTEGER\n*          The number of columns of the matrix C. NCC >= 0.\n*\n*  D       (input/output) REAL array, dimension (N)\n*          On entry, the n diagonal elements of the bidiagonal matrix B.\n*          On exit, if INFO=0, the singular values of B in decreasing\n*          order.\n*\n*  E       (input/output) REAL array, dimension (N-1)\n*          On entry, the N-1 offdiagonal elements of the bidiagonal\n*          matrix B.\n*          On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E\n*          will contain the diagonal and superdiagonal elements of a\n*          bidiagonal matrix orthogonally equivalent to the one given\n*          as input.\n*\n*  VT      (input/output) REAL array, dimension (LDVT, NCVT)\n*          On entry, an N-by-NCVT matrix VT.\n*          On exit, VT is overwritten by P**T * VT.\n*          Not referenced if NCVT = 0.\n*\n*  LDVT    (input) INTEGER\n*          The leading dimension of the array VT.\n*          LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.\n*\n*  U       (input/output) REAL array, dimension (LDU, N)\n*          On entry, an NRU-by-N matrix U.\n*          On exit, U is overwritten by U * Q.\n*          Not referenced if NRU = 0.\n*\n*  LDU     (input) INTEGER\n*          The leading dimension of the array U.  LDU >= max(1,NRU).\n*\n*  C       (input/output) REAL array, dimension (LDC, NCC)\n*          On entry, an N-by-NCC matrix C.\n*          On exit, C is overwritten by Q**T * C.\n*          Not referenced if NCC = 0.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C.\n*          LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.\n*\n*  WORK    (workspace) REAL array, dimension (4*N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  If INFO = -i, the i-th argument had an illegal value\n*          > 0:\n*             if NCVT = NRU = NCC = 0,\n*                = 1, a split was marked by a positive value in E\n*                = 2, current block of Z not diagonalized after 30*N\n*                     iterations (in inner while loop)\n*                = 3, termination criterion of outer while loop not met \n*                     (program created more than N unreduced blocks)\n*             else NCVT = NRU = NCC = 0,\n*                   the algorithm did not converge; D and E contain the\n*                   elements of a bidiagonal matrix which is orthogonally\n*                   similar to the input matrix B;  if INFO = i, i\n*                   elements of E have not converged to zero.\n*\n*  Internal Parameters\n*  ===================\n*\n*  TOLMUL  REAL, default = max(10,min(100,EPS**(-1/8)))\n*          TOLMUL controls the convergence criterion of the QR loop.\n*          If it is positive, TOLMUL*EPS is the desired relative\n*             precision in the computed singular values.\n*          If it is negative, abs(TOLMUL*EPS*sigma_max) is the\n*             desired absolute accuracy in the computed singular\n*             values (corresponds to relative accuracy\n*             abs(TOLMUL*EPS) in the largest singular value.\n*          abs(TOLMUL) should be between 1 and 1/EPS, and preferably\n*             between 10 (for fast convergence) and .1/EPS\n*             (for there to be some accuracy in the results).\n*          Default is to lose at either one eighth or 2 of the\n*             available decimal digits in each computed singular value\n*             (whichever is smaller).\n*\n*  MAXITR  INTEGER, default = 6\n*          MAXITR controls the maximum number of passes of the\n*          algorithm through its inner loop. The algorithms stops\n*          (and so fails to converge) if the number of passes\n*          through the inner loop exceeds MAXITR*N**2.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, e, vt, u, c = NumRu::Lapack.sbdsqr( uplo, nru, d, e, vt, u, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_uplo = argv[0];
  rblapack_nru = argv[1];
  rblapack_d = argv[2];
  rblapack_e = argv[3];
  rblapack_vt = argv[4];
  rblapack_u = argv[5];
  rblapack_c = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_vt))
    rb_raise(rb_eArgError, "vt (5th argument) must be NArray");
  if (NA_RANK(rblapack_vt) != 2)
    rb_raise(rb_eArgError, "rank of vt (5th argument) must be %d", 2);
  ldvt = NA_SHAPE0(rblapack_vt);
  ncvt = NA_SHAPE1(rblapack_vt);
  if (NA_TYPE(rblapack_vt) != NA_SFLOAT)
    rblapack_vt = na_change_type(rblapack_vt, NA_SFLOAT);
  vt = NA_PTR_TYPE(rblapack_vt, real*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  ncc = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  nru = NUM2INT(rblapack_nru);
  if (!NA_IsNArray(rblapack_u))
    rb_raise(rb_eArgError, "u (6th argument) must be NArray");
  if (NA_RANK(rblapack_u) != 2)
    rb_raise(rb_eArgError, "rank of u (6th argument) must be %d", 2);
  ldu = NA_SHAPE0(rblapack_u);
  if (NA_SHAPE1(rblapack_u) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of u must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_u) != NA_SFLOAT)
    rblapack_u = na_change_type(rblapack_u, NA_SFLOAT);
  u = NA_PTR_TYPE(rblapack_u, real*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (4th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
  MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvt;
    shape[1] = ncvt;
    rblapack_vt_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vt_out__ = NA_PTR_TYPE(rblapack_vt_out__, real*);
  MEMCPY(vt_out__, vt, real, NA_TOTAL(rblapack_vt));
  rblapack_vt = rblapack_vt_out__;
  vt = vt_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = n;
    rblapack_u_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  u_out__ = NA_PTR_TYPE(rblapack_u_out__, real*);
  MEMCPY(u_out__, u, real, NA_TOTAL(rblapack_u));
  rblapack_u = rblapack_u_out__;
  u = u_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = ncc;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(real, (4*n));

  sbdsqr_(&uplo, &n, &ncvt, &nru, &ncc, d, e, vt, &ldvt, u, &ldu, c, &ldc, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_info, rblapack_d, rblapack_e, rblapack_vt, rblapack_u, rblapack_c);
}

void
init_lapack_sbdsqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sbdsqr", rblapack_sbdsqr, -1);
}
ruby-lapack-1.7.2/ext/sla_syrcond.c0000644000175000017500000001721712502221016017052 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real sla_syrcond_(char* uplo, integer* n, real* a, integer* lda, real* af, integer* ldaf, integer* ipiv, integer* cmode, real* c, integer* info, real* work, integer* iwork);


static VALUE
rblapack_sla_syrcond(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_af;
  real *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_cmode;
  integer cmode; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack___out__;
  real __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  info, __out__ = NumRu::Lapack.sla_syrcond( uplo, a, af, ipiv, cmode, c, work, iwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL FUNCTION SLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, IPIV, CMODE, C, INFO, WORK, IWORK )\n\n*  Purpose\n*  =======\n*\n*     SLA_SYRCOND estimates the Skeel condition number of  op(A) * op2(C)\n*     where op2 is determined by CMODE as follows\n*     CMODE =  1    op2(C) = C\n*     CMODE =  0    op2(C) = I\n*     CMODE = -1    op2(C) = inv(C)\n*     The Skeel condition number cond(A) = norminf( |inv(A)||A| )\n*     is computed by computing scaling factors R such that\n*     diag(R)*A*op2(C) is row equilibrated and computing the standard\n*     infinity-norm condition number.\n*\n\n*  Arguments\n*  ==========\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     A       (input) REAL array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) REAL array, dimension (LDAF,N)\n*     The block diagonal matrix D and the multipliers used to\n*     obtain the factor U or L as computed by SSYTRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     Details of the interchanges and the block structure of D\n*     as determined by SSYTRF.\n*\n*     CMODE   (input) INTEGER\n*     Determines op2(C) in the formula op(A) * op2(C) as follows:\n*     CMODE =  1    op2(C) = C\n*     CMODE =  0    op2(C) = I\n*     CMODE = -1    op2(C) = inv(C)\n*\n*     C       (input) REAL array, dimension (N)\n*     The vector C in the formula op(A) * op2(C).\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit.\n*     i > 0:  The ith argument is invalid.\n*\n*     WORK    (input) REAL array, dimension (3*N).\n*     Workspace.\n*\n*     IWORK   (input) INTEGER array, dimension (N).\n*     Workspace.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      CHARACTER          NORMIN\n      INTEGER            KASE, I, J\n      REAL               AINVNM, SMLNUM, TMP\n      LOGICAL            UP\n*     ..\n*     .. Local Arrays ..\n      INTEGER            ISAVE( 3 )\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            ISAMAX\n      REAL               SLAMCH\n      EXTERNAL           LSAME, ISAMAX, SLAMCH\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SLACN2, SLATRS, SRSCL, XERBLA, SSYTRS\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, __out__ = NumRu::Lapack.sla_syrcond( uplo, a, af, ipiv, cmode, c, work, iwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_cmode = argv[4];
  rblapack_c = argv[5];
  rblapack_work = argv[6];
  rblapack_iwork = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_SFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
  af = NA_PTR_TYPE(rblapack_af, real*);
  cmode = NUM2INT(rblapack_cmode);
  if (!NA_IsNArray(rblapack_iwork))
    rb_raise(rb_eArgError, "iwork (8th argument) must be NArray");
  if (NA_RANK(rblapack_iwork) != 1)
    rb_raise(rb_eArgError, "rank of iwork (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_iwork) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of iwork must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_iwork) != NA_LINT)
    rblapack_iwork = na_change_type(rblapack_iwork, NA_LINT);
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (7th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (3*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 3*n);
  if (NA_TYPE(rblapack_work) != NA_SFLOAT)
    rblapack_work = na_change_type(rblapack_work, NA_SFLOAT);
  work = NA_PTR_TYPE(rblapack_work, real*);

  __out__ = sla_syrcond_(&uplo, &n, a, &lda, af, &ldaf, ipiv, &cmode, c, &info, work, iwork);

  rblapack_info = INT2NUM(info);
  rblapack___out__ = rb_float_new((double)__out__);
  return rb_ary_new3(2, rblapack_info, rblapack___out__);
}

void
init_lapack_sla_syrcond(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sla_syrcond", rblapack_sla_syrcond, -1);
}
ruby-lapack-1.7.2/ext/sgbrfs.c0000644000175000017500000002223612502221023016013 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgbrfs_(char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, real* ab, integer* ldab, real* afb, integer* ldafb, integer* ipiv, real* b, integer* ldb, real* x, integer* ldx, real* ferr, real* berr, real* work, integer* iwork, integer* info);


static VALUE
rblapack_sgbrfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_afb;
  real *afb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  real *x_out__;
  real *work;
  integer *iwork;

  integer ldab;
  integer n;
  integer ldafb;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.sgbrfs( trans, kl, ku, ab, afb, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGBRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is banded, and provides\n*  error bounds and backward error estimates for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AB      (input) REAL array, dimension (LDAB,N)\n*          The original band matrix A, stored in rows 1 to KL+KU+1.\n*          The j-th column of A is stored in the j-th column of the\n*          array AB as follows:\n*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*  AFB     (input) REAL array, dimension (LDAFB,N)\n*          Details of the LU factorization of the band matrix A, as\n*          computed by SGBTRF.  U is stored as an upper triangular band\n*          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n*          the multipliers used during the factorization are stored in\n*          rows KL+KU+2 to 2*KL+KU+1.\n*\n*  LDAFB   (input) INTEGER\n*          The leading dimension of the array AFB.  LDAFB >= 2*KL*KU+1.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices from SGBTRF; for 1<=i<=N, row i of the\n*          matrix was interchanged with row IPIV(i).\n*\n*  B       (input) REAL array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) REAL array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by SGBTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) REAL array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.sgbrfs( trans, kl, ku, ab, afb, ipiv, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_trans = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  rblapack_afb = argv[4];
  rblapack_ipiv = argv[5];
  rblapack_b = argv[6];
  rblapack_x = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
  ldafb = NA_SHAPE0(rblapack_afb);
  n = NA_SHAPE1(rblapack_afb);
  if (NA_TYPE(rblapack_afb) != NA_SFLOAT)
    rblapack_afb = na_change_type(rblapack_afb, NA_SFLOAT);
  afb = NA_PTR_TYPE(rblapack_afb, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (8th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (8th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(real, (3*n));
  iwork = ALLOC_N(integer, (n));

  sgbrfs_(&trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_sgbrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgbrfs", rblapack_sgbrfs, -1);
}
ruby-lapack-1.7.2/ext/zgebd2.c0000644000175000017500000001742712502221020015705 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgebd2_(integer* m, integer* n, doublecomplex* a, integer* lda, doublereal* d, doublereal* e, doublecomplex* tauq, doublecomplex* taup, doublecomplex* work, integer* info);


static VALUE
rblapack_zgebd2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_tauq;
  doublecomplex *tauq; 
  VALUE rblapack_taup;
  doublecomplex *taup; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  doublecomplex *work;

  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  d, e, tauq, taup, info, a = NumRu::Lapack.zgebd2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGEBD2 reduces a complex general m by n matrix A to upper or lower\n*  real bidiagonal form B by a unitary transformation: Q' * A * P = B.\n*\n*  If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows in the matrix A.  M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns in the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the m by n general matrix to be reduced.\n*          On exit,\n*          if m >= n, the diagonal and the first superdiagonal are\n*            overwritten with the upper bidiagonal matrix B; the\n*            elements below the diagonal, with the array TAUQ, represent\n*            the unitary matrix Q as a product of elementary\n*            reflectors, and the elements above the first superdiagonal,\n*            with the array TAUP, represent the unitary matrix P as\n*            a product of elementary reflectors;\n*          if m < n, the diagonal and the first subdiagonal are\n*            overwritten with the lower bidiagonal matrix B; the\n*            elements below the first subdiagonal, with the array TAUQ,\n*            represent the unitary matrix Q as a product of\n*            elementary reflectors, and the elements above the diagonal,\n*            with the array TAUP, represent the unitary matrix P as\n*            a product of elementary reflectors.\n*          See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  D       (output) DOUBLE PRECISION array, dimension (min(M,N))\n*          The diagonal elements of the bidiagonal matrix B:\n*          D(i) = A(i,i).\n*\n*  E       (output) DOUBLE PRECISION array, dimension (min(M,N)-1)\n*          The off-diagonal elements of the bidiagonal matrix B:\n*          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n*          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n*\n*  TAUQ    (output) COMPLEX*16 array dimension (min(M,N))\n*          The scalar factors of the elementary reflectors which\n*          represent the unitary matrix Q. See Further Details.\n*\n*  TAUP    (output) COMPLEX*16 array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors which\n*          represent the unitary matrix P. See Further Details.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (max(M,N))\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 matrices Q and P are represented as products of elementary\n*  reflectors:\n*\n*  If m >= n,\n*\n*     Q = H(1) H(2) . . . H(n)  and  P = G(1) G(2) . . . G(n-1)\n*\n*  Each H(i) and G(i) has the form:\n*\n*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'\n*\n*  where tauq and taup are complex scalars, and v and u are complex\n*  vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in\n*  A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in\n*  A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n*  If m < n,\n*\n*     Q = H(1) H(2) . . . H(m-1)  and  P = G(1) G(2) . . . G(m)\n*\n*  Each H(i) and G(i) has the form:\n*\n*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'\n*\n*  where tauq and taup are complex scalars, v and u are complex vectors;\n*  v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);\n*  u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);\n*  tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n*  The contents of A on exit are illustrated by the following examples:\n*\n*  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):\n*\n*    (  d   e   u1  u1  u1 )           (  d   u1  u1  u1  u1  u1 )\n*    (  v1  d   e   u2  u2 )           (  e   d   u2  u2  u2  u2 )\n*    (  v1  v2  d   e   u3 )           (  v1  e   d   u3  u3  u3 )\n*    (  v1  v2  v3  d   e  )           (  v1  v2  e   d   u4  u4 )\n*    (  v1  v2  v3  v4  d  )           (  v1  v2  v3  e   d   u5 )\n*    (  v1  v2  v3  v4  v5 )\n*\n*  where d and e denote diagonal and off-diagonal elements of B, vi\n*  denotes an element of the vector defining H(i), and ui an element of\n*  the vector defining G(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, tauq, taup, info, a = NumRu::Lapack.zgebd2( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n)-1;
    rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tauq = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  tauq = NA_PTR_TYPE(rblapack_tauq, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_taup = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  taup = NA_PTR_TYPE(rblapack_taup, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(doublecomplex, (MAX(m,n)));

  zgebd2_(&m, &n, a, &lda, d, e, tauq, taup, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_d, rblapack_e, rblapack_tauq, rblapack_taup, rblapack_info, rblapack_a);
}

void
init_lapack_zgebd2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgebd2", rblapack_zgebd2, -1);
}
ruby-lapack-1.7.2/ext/ssycon.c0000644000175000017500000001131112502221025016035 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssycon_(char* uplo, integer* n, real* a, integer* lda, integer* ipiv, real* anorm, real* rcond, real* work, integer* iwork, integer* info);


static VALUE
rblapack_ssycon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_anorm;
  real anorm; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_info;
  integer info; 
  real *work;
  integer *iwork;

  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  rcond, info = NumRu::Lapack.ssycon( uplo, a, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSYCON estimates the reciprocal of the condition number (in the\n*  1-norm) of a real symmetric matrix A using the factorization\n*  A = U*D*U**T or A = L*D*L**T computed by SSYTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) REAL array, dimension (LDA,N)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by SSYTRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by SSYTRF.\n*\n*  ANORM   (input) REAL\n*          The 1-norm of the original matrix A.\n*\n*  RCOND   (output) REAL\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n*          estimate of the 1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) REAL array, dimension (2*N)\n*\n*  IWORK    (workspace) INTEGER array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.ssycon( uplo, a, ipiv, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_anorm = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  anorm = (real)NUM2DBL(rblapack_anorm);
  work = ALLOC_N(real, (2*n));
  iwork = ALLOC_N(integer, (n));

  ssycon_(&uplo, &n, a, &lda, ipiv, &anorm, &rcond, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_ssycon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssycon", rblapack_ssycon, -1);
}
ruby-lapack-1.7.2/ext/zlatrs.c0000644000175000017500000002514512502221023016046 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlatrs_(char* uplo, char* trans, char* diag, char* normin, integer* n, doublecomplex* a, integer* lda, doublecomplex* x, doublereal* scale, doublereal* cnorm, integer* info);


static VALUE
rblapack_zlatrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_normin;
  char normin; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_cnorm;
  doublereal *cnorm; 
  VALUE rblapack_scale;
  doublereal scale; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;
  VALUE rblapack_cnorm_out__;
  doublereal *cnorm_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  scale, info, x, cnorm = NumRu::Lapack.zlatrs( uplo, trans, diag, normin, a, x, cnorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, CNORM, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZLATRS solves one of the triangular systems\n*\n*     A * x = s*b,  A**T * x = s*b,  or  A**H * x = s*b,\n*\n*  with scaling to prevent overflow.  Here A is an upper or lower\n*  triangular matrix, A**T denotes the transpose of A, A**H denotes the\n*  conjugate transpose of A, x and b are n-element vectors, and s is a\n*  scaling factor, usually less than or equal to 1, chosen so that the\n*  components of x will be less than the overflow threshold.  If the\n*  unscaled problem will not cause overflow, the Level 2 BLAS routine\n*  ZTRSV is called. If the matrix A is singular (A(j,j) = 0 for some j),\n*  then s is set to 0 and a non-trivial solution to A*x = 0 is returned.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the matrix A is upper or lower triangular.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the operation applied to A.\n*          = 'N':  Solve A * x = s*b     (No transpose)\n*          = 'T':  Solve A**T * x = s*b  (Transpose)\n*          = 'C':  Solve A**H * x = s*b  (Conjugate transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          Specifies whether or not the matrix A is unit triangular.\n*          = 'N':  Non-unit triangular\n*          = 'U':  Unit triangular\n*\n*  NORMIN  (input) CHARACTER*1\n*          Specifies whether CNORM has been set or not.\n*          = 'Y':  CNORM contains the column norms on entry\n*          = 'N':  CNORM is not set on entry.  On exit, the norms will\n*                  be computed and stored in CNORM.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          The triangular matrix A.  If UPLO = 'U', the leading n by n\n*          upper triangular part of the array A contains the upper\n*          triangular matrix, and the strictly lower triangular part of\n*          A is not referenced.  If UPLO = 'L', the leading n by n lower\n*          triangular part of the array A contains the lower triangular\n*          matrix, and the strictly upper triangular part of A is not\n*          referenced.  If DIAG = 'U', the diagonal elements of A are\n*          also not referenced and are assumed to be 1.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max (1,N).\n*\n*  X       (input/output) COMPLEX*16 array, dimension (N)\n*          On entry, the right hand side b of the triangular system.\n*          On exit, X is overwritten by the solution vector x.\n*\n*  SCALE   (output) DOUBLE PRECISION\n*          The scaling factor s for the triangular system\n*             A * x = s*b,  A**T * x = s*b,  or  A**H * x = s*b.\n*          If SCALE = 0, the matrix A is singular or badly scaled, and\n*          the vector x is an exact or approximate solution to A*x = 0.\n*\n*  CNORM   (input or output) DOUBLE PRECISION array, dimension (N)\n*\n*          If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n*          contains the norm of the off-diagonal part of the j-th column\n*          of A.  If TRANS = 'N', CNORM(j) must be greater than or equal\n*          to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n*          must be greater than or equal to the 1-norm.\n*\n*          If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n*          returns the 1-norm of the offdiagonal part of the j-th column\n*          of A.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -k, the k-th argument had an illegal value\n*\n\n*  Further Details\n*  ======= =======\n*\n*  A rough bound on x is computed; if that is less than overflow, ZTRSV\n*  is called, otherwise, specific code is used which checks for possible\n*  overflow or divide-by-zero at every operation.\n*\n*  A columnwise scheme is used for solving A*x = b.  The basic algorithm\n*  if A is lower triangular is\n*\n*       x[1:n] := b[1:n]\n*       for j = 1, ..., n\n*            x(j) := x(j) / A(j,j)\n*            x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n*       end\n*\n*  Define bounds on the components of x after j iterations of the loop:\n*     M(j) = bound on x[1:j]\n*     G(j) = bound on x[j+1:n]\n*  Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n*  Then for iteration j+1 we have\n*     M(j+1) <= G(j) / | A(j+1,j+1) |\n*     G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n*            <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n*  where CNORM(j+1) is greater than or equal to the infinity-norm of\n*  column j+1 of A, not counting the diagonal.  Hence\n*\n*     G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n*                  1<=i<=j\n*  and\n*\n*     |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n*                                   1<=i< j\n*\n*  Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTRSV if the\n*  reciprocal of the largest M(j), j=1,..,n, is larger than\n*  max(underflow, 1/overflow).\n*\n*  The bound on x(j) is also used to determine when a step in the\n*  columnwise method can be performed without fear of overflow.  If\n*  the computed bound is greater than a large constant, x is scaled to\n*  prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n*  1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n*  Similarly, a row-wise scheme is used to solve A**T *x = b  or\n*  A**H *x = b.  The basic algorithm for A upper triangular is\n*\n*       for j = 1, ..., n\n*            x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n*       end\n*\n*  We simultaneously compute two bounds\n*       G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n*       M(j) = bound on x(i), 1<=i<=j\n*\n*  The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n*  add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n*  Then the bound on x(j) is\n*\n*       M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n*            <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n*                      1<=i<=j\n*\n*  and we can safely call ZTRSV if 1/M(n) and 1/G(n) are both greater\n*  than max(underflow, 1/overflow).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, info, x, cnorm = NumRu::Lapack.zlatrs( uplo, trans, diag, normin, a, x, cnorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_normin = argv[3];
  rblapack_a = argv[4];
  rblapack_x = argv[5];
  rblapack_cnorm = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_cnorm))
    rb_raise(rb_eArgError, "cnorm (7th argument) must be NArray");
  if (NA_RANK(rblapack_cnorm) != 1)
    rb_raise(rb_eArgError, "rank of cnorm (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_cnorm) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of cnorm must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_cnorm) != NA_DFLOAT)
    rblapack_cnorm = na_change_type(rblapack_cnorm, NA_DFLOAT);
  cnorm = NA_PTR_TYPE(rblapack_cnorm, doublereal*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  normin = StringValueCStr(rblapack_normin)[0];
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_cnorm_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  cnorm_out__ = NA_PTR_TYPE(rblapack_cnorm_out__, doublereal*);
  MEMCPY(cnorm_out__, cnorm, doublereal, NA_TOTAL(rblapack_cnorm));
  rblapack_cnorm = rblapack_cnorm_out__;
  cnorm = cnorm_out__;

  zlatrs_(&uplo, &trans, &diag, &normin, &n, a, &lda, x, &scale, cnorm, &info);

  rblapack_scale = rb_float_new((double)scale);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_scale, rblapack_info, rblapack_x, rblapack_cnorm);
}

void
init_lapack_zlatrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlatrs", rblapack_zlatrs, -1);
}
ruby-lapack-1.7.2/ext/zpotrs.c0000644000175000017500000001030212502221016016057 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zpotrs_(char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, integer* info);


static VALUE
rblapack_zpotrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.zpotrs( uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPOTRS solves a system of linear equations A*X = B with a Hermitian\n*  positive definite matrix A using the Cholesky factorization\n*  A = U**H*U or A = L*L**H computed by ZPOTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**H*U or A = L*L**H, as computed by ZPOTRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.zpotrs( uplo, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_b = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zpotrs_(&uplo, &n, &nrhs, a, &lda, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_zpotrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zpotrs", rblapack_zpotrs, -1);
}
ruby-lapack-1.7.2/ext/zunmrq.c0000644000175000017500000001626212502221024016064 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zunmrq_(char* side, char* trans, integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_zunmrq(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_c;
  doublecomplex *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublecomplex *c_out__;

  integer lda;
  integer m;
  integer k;
  integer ldc;
  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  work, info, c = NumRu::Lapack.zunmrq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZUNMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZUNMRQ overwrites the general complex M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'C':      Q**H * C       C * Q**H\n*\n*  where Q is a complex unitary matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(1)' H(2)' . . . H(k)'\n*\n*  as returned by ZGERQF. Q is of order M if SIDE = 'L' and of order N\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**H from the Left;\n*          = 'R': apply Q or Q**H from the Right.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'C':  Transpose, apply Q**H.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension\n*                               (LDA,M) if SIDE = 'L',\n*                               (LDA,N) if SIDE = 'R'\n*          The i-th row must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          ZGERQF in the last k rows of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,K).\n*\n*  TAU     (input) COMPLEX*16 array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by ZGERQF.\n*\n*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace/output) COMPLEX*16 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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M).\n*          For optimum performance LWORK >= N*NB if SIDE = 'L', and\n*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n*          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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.zunmrq( side, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_a = argv[2];
  rblapack_tau = argv[3];
  rblapack_c = argv[4];
  if (argc == 6) {
    rblapack_lwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
  MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  zunmrq_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_zunmrq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zunmrq", rblapack_zunmrq, -1);
}
ruby-lapack-1.7.2/ext/ctgsna.c0000644000175000017500000003262112502221017016006 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctgsna_(char* job, char* howmny, logical* select, integer* n, complex* a, integer* lda, complex* b, integer* ldb, complex* vl, integer* ldvl, complex* vr, integer* ldvr, real* s, real* dif, integer* mm, integer* m, complex* work, integer* lwork, integer* iwork, integer* info);


static VALUE
rblapack_ctgsna(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_howmny;
  char howmny; 
  VALUE rblapack_select;
  logical *select; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_vl;
  complex *vl; 
  VALUE rblapack_vr;
  complex *vr; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_dif;
  real *dif; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  integer *iwork;

  integer n;
  integer lda;
  integer ldb;
  integer ldvl;
  integer ldvr;
  integer mm;

  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  s, dif, m, work, info = NumRu::Lapack.ctgsna( job, howmny, select, a, b, vl, vr, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTGSNA estimates reciprocal condition numbers for specified\n*  eigenvalues and/or eigenvectors of a matrix pair (A, B).\n*\n*  (A, B) must be in generalized Schur canonical form, that is, A and\n*  B are both upper triangular.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies whether condition numbers are required for\n*          eigenvalues (S) or eigenvectors (DIF):\n*          = 'E': for eigenvalues only (S);\n*          = 'V': for eigenvectors only (DIF);\n*          = 'B': for both eigenvalues and eigenvectors (S and DIF).\n*\n*  HOWMNY  (input) CHARACTER*1\n*          = 'A': compute condition numbers for all eigenpairs;\n*          = 'S': compute condition numbers for selected eigenpairs\n*                 specified by the array SELECT.\n*\n*  SELECT  (input) LOGICAL array, dimension (N)\n*          If HOWMNY = 'S', SELECT specifies the eigenpairs for which\n*          condition numbers are required. To select condition numbers\n*          for the corresponding j-th eigenvalue and/or eigenvector,\n*          SELECT(j) must be set to .TRUE..\n*          If HOWMNY = 'A', SELECT is not referenced.\n*\n*  N       (input) INTEGER\n*          The order of the square matrix pair (A, B). N >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The upper triangular matrix A in the pair (A,B).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  B       (input) COMPLEX array, dimension (LDB,N)\n*          The upper triangular matrix B in the pair (A, B).\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  VL      (input) COMPLEX array, dimension (LDVL,M)\n*          IF JOB = 'E' or 'B', VL must contain left eigenvectors of\n*          (A, B), corresponding to the eigenpairs specified by HOWMNY\n*          and SELECT.  The eigenvectors must be stored in consecutive\n*          columns of VL, as returned by CTGEVC.\n*          If JOB = 'V', VL is not referenced.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the array VL. LDVL >= 1; and\n*          If JOB = 'E' or 'B', LDVL >= N.\n*\n*  VR      (input) COMPLEX array, dimension (LDVR,M)\n*          IF JOB = 'E' or 'B', VR must contain right eigenvectors of\n*          (A, B), corresponding to the eigenpairs specified by HOWMNY\n*          and SELECT.  The eigenvectors must be stored in consecutive\n*          columns of VR, as returned by CTGEVC.\n*          If JOB = 'V', VR is not referenced.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the array VR. LDVR >= 1;\n*          If JOB = 'E' or 'B', LDVR >= N.\n*\n*  S       (output) REAL array, dimension (MM)\n*          If JOB = 'E' or 'B', the reciprocal condition numbers of the\n*          selected eigenvalues, stored in consecutive elements of the\n*          array.\n*          If JOB = 'V', S is not referenced.\n*\n*  DIF     (output) REAL array, dimension (MM)\n*          If JOB = 'V' or 'B', the estimated reciprocal condition\n*          numbers of the selected eigenvectors, stored in consecutive\n*          elements of the array.\n*          If the eigenvalues cannot be reordered to compute DIF(j),\n*          DIF(j) is set to 0; this can only occur when the true value\n*          would be very small anyway.\n*          For each eigenvalue/vector specified by SELECT, DIF stores\n*          a Frobenius norm-based estimate of Difl.\n*          If JOB = 'E', DIF is not referenced.\n*\n*  MM      (input) INTEGER\n*          The number of elements in the arrays S and DIF. MM >= M.\n*\n*  M       (output) INTEGER\n*          The number of elements of the arrays S and DIF used to store\n*          the specified condition numbers; for each selected eigenvalue\n*          one element is used. If HOWMNY = 'A', M is set to N.\n*\n*  WORK    (workspace/output) COMPLEX 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,N).\n*          If JOB = 'V' or 'B', LWORK >= max(1,2*N*N).\n*\n*  IWORK   (workspace) INTEGER array, dimension (N+2)\n*          If JOB = 'E', IWORK is not referenced.\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 reciprocal of the condition number of the i-th generalized\n*  eigenvalue w = (a, b) is defined as\n*\n*          S(I) = (|v'Au|**2 + |v'Bu|**2)**(1/2) / (norm(u)*norm(v))\n*\n*  where u and v are the right and left eigenvectors of (A, B)\n*  corresponding to w; |z| denotes the absolute value of the complex\n*  number, and norm(u) denotes the 2-norm of the vector u. The pair\n*  (a, b) corresponds to an eigenvalue w = a/b (= v'Au/v'Bu) of the\n*  matrix pair (A, B). If both a and b equal zero, then (A,B) is\n*  singular and S(I) = -1 is returned.\n*\n*  An approximate error bound on the chordal distance between the i-th\n*  computed generalized eigenvalue w and the corresponding exact\n*  eigenvalue lambda is\n*\n*          chord(w, lambda) <=   EPS * norm(A, B) / S(I),\n*\n*  where EPS is the machine precision.\n*\n*  The reciprocal of the condition number of the right eigenvector u\n*  and left eigenvector v corresponding to the generalized eigenvalue w\n*  is defined as follows. Suppose\n*\n*                   (A, B) = ( a   *  ) ( b  *  )  1\n*                            ( 0  A22 ),( 0 B22 )  n-1\n*                              1  n-1     1 n-1\n*\n*  Then the reciprocal condition number DIF(I) is\n*\n*          Difl[(a, b), (A22, B22)]  = sigma-min( Zl )\n*\n*  where sigma-min(Zl) denotes the smallest singular value of\n*\n*         Zl = [ kron(a, In-1) -kron(1, A22) ]\n*              [ kron(b, In-1) -kron(1, B22) ].\n*\n*  Here In-1 is the identity matrix of size n-1 and X' is the conjugate\n*  transpose of X. kron(X, Y) is the Kronecker product between the\n*  matrices X and Y.\n*\n*  We approximate the smallest singular value of Zl with an upper\n*  bound. This is done by CLATDF.\n*\n*  An approximate error bound for a computed eigenvector VL(i) or\n*  VR(i) is given by\n*\n*                      EPS * norm(A, B) / DIF(i).\n*\n*  See ref. [2-3] for more details and further references.\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  References\n*  ==========\n*\n*  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n*      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n*      M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n*      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n*  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n*      Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n*      Estimation: Theory, Algorithms and Software, Report\n*      UMINF - 94.04, Department of Computing Science, Umea University,\n*      S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.\n*      To appear in Numerical Algorithms, 1996.\n*\n*  [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n*      for Solving the Generalized Sylvester Equation and Estimating the\n*      Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n*      Department of Computing Science, Umea University, S-901 87 Umea,\n*      Sweden, December 1993, Revised April 1994, Also as LAPACK Working\n*      Note 75.\n*      To appear in ACM Trans. on Math. Software, Vol 22, No 1, 1996.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, dif, m, work, info = NumRu::Lapack.ctgsna( job, howmny, select, a, b, vl, vr, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_job = argv[0];
  rblapack_howmny = argv[1];
  rblapack_select = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  rblapack_vl = argv[5];
  rblapack_vr = argv[6];
  if (argc == 8) {
    rblapack_lwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  job = StringValueCStr(rblapack_job)[0];
  if (!NA_IsNArray(rblapack_select))
    rb_raise(rb_eArgError, "select (3th argument) must be NArray");
  if (NA_RANK(rblapack_select) != 1)
    rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_select);
  if (NA_TYPE(rblapack_select) != NA_LINT)
    rblapack_select = na_change_type(rblapack_select, NA_LINT);
  select = NA_PTR_TYPE(rblapack_select, logical*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (!NA_IsNArray(rblapack_vr))
    rb_raise(rb_eArgError, "vr (7th argument) must be NArray");
  if (NA_RANK(rblapack_vr) != 2)
    rb_raise(rb_eArgError, "rank of vr (7th argument) must be %d", 2);
  ldvr = NA_SHAPE0(rblapack_vr);
  m = NA_SHAPE1(rblapack_vr);
  if (NA_TYPE(rblapack_vr) != NA_SCOMPLEX)
    rblapack_vr = na_change_type(rblapack_vr, NA_SCOMPLEX);
  vr = NA_PTR_TYPE(rblapack_vr, complex*);
  howmny = StringValueCStr(rblapack_howmny)[0];
  if (!NA_IsNArray(rblapack_vl))
    rb_raise(rb_eArgError, "vl (6th argument) must be NArray");
  if (NA_RANK(rblapack_vl) != 2)
    rb_raise(rb_eArgError, "rank of vl (6th argument) must be %d", 2);
  ldvl = NA_SHAPE0(rblapack_vl);
  if (NA_SHAPE1(rblapack_vl) != m)
    rb_raise(rb_eRuntimeError, "shape 1 of vl must be the same as shape 1 of vr");
  if (NA_TYPE(rblapack_vl) != NA_SCOMPLEX)
    rblapack_vl = na_change_type(rblapack_vl, NA_SCOMPLEX);
  vl = NA_PTR_TYPE(rblapack_vl, complex*);
  mm = m;
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (rblapack_lwork == Qnil)
    lwork = (lsame_(&job,"V")||lsame_(&job,"B")) ? 2*n*n : n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = mm;
    rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, real*);
  {
    na_shape_t shape[1];
    shape[0] = mm;
    rblapack_dif = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  dif = NA_PTR_TYPE(rblapack_dif, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  iwork = ALLOC_N(integer, (lsame_(&job,"E") ? 0 : n+2));

  ctgsna_(&job, &howmny, select, &n, a, &lda, b, &ldb, vl, &ldvl, vr, &ldvr, s, dif, &mm, &m, work, &lwork, iwork, &info);

  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_s, rblapack_dif, rblapack_m, rblapack_work, rblapack_info);
}

void
init_lapack_ctgsna(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctgsna", rblapack_ctgsna, -1);
}
ruby-lapack-1.7.2/ext/slapy3.c0000644000175000017500000000361712502221026015745 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real slapy3_(real* x, real* y, real* z);


static VALUE
rblapack_slapy3(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_x;
  real x; 
  VALUE rblapack_y;
  real y; 
  VALUE rblapack_z;
  real z; 
  VALUE rblapack___out__;
  real __out__; 


  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  __out__ = NumRu::Lapack.slapy3( x, y, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL             FUNCTION SLAPY3( X, Y, Z )\n\n*  Purpose\n*  =======\n*\n*  SLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause\n*  unnecessary overflow.\n*\n\n*  Arguments\n*  =========\n*\n*  X       (input) REAL\n*  Y       (input) REAL\n*  Z       (input) REAL\n*          X, Y and Z specify the values x, y and z.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.slapy3( x, y, z, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_x = argv[0];
  rblapack_y = argv[1];
  rblapack_z = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  x = (real)NUM2DBL(rblapack_x);
  z = (real)NUM2DBL(rblapack_z);
  y = (real)NUM2DBL(rblapack_y);

  __out__ = slapy3_(&x, &y, &z);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_slapy3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slapy3", rblapack_slapy3, -1);
}
ruby-lapack-1.7.2/ext/zlaqps.c0000644000175000017500000002365412502221022016043 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlaqps_(integer* m, integer* n, integer* offset, integer* nb, integer* kb, doublecomplex* a, integer* lda, integer* jpvt, doublecomplex* tau, doublereal* vn1, doublereal* vn2, doublecomplex* auxv, doublecomplex* f, integer* ldf);


static VALUE
rblapack_zlaqps(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_offset;
  integer offset; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_jpvt;
  integer *jpvt; 
  VALUE rblapack_vn1;
  doublereal *vn1; 
  VALUE rblapack_vn2;
  doublereal *vn2; 
  VALUE rblapack_auxv;
  doublecomplex *auxv; 
  VALUE rblapack_f;
  doublecomplex *f; 
  VALUE rblapack_kb;
  integer kb; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_jpvt_out__;
  integer *jpvt_out__;
  VALUE rblapack_vn1_out__;
  doublereal *vn1_out__;
  VALUE rblapack_vn2_out__;
  doublereal *vn2_out__;
  VALUE rblapack_auxv_out__;
  doublecomplex *auxv_out__;
  VALUE rblapack_f_out__;
  doublecomplex *f_out__;

  integer lda;
  integer n;
  integer nb;
  integer ldf;

  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  kb, tau, a, jpvt, vn1, vn2, auxv, f = NumRu::Lapack.zlaqps( m, offset, a, jpvt, vn1, vn2, auxv, f, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, VN2, AUXV, F, LDF )\n\n*  Purpose\n*  =======\n*\n*  ZLAQPS computes a step of QR factorization with column pivoting\n*  of a complex M-by-N matrix A by using Blas-3.  It tries to factorize\n*  NB columns from A starting from the row OFFSET+1, and updates all\n*  of the matrix with Blas-3 xGEMM.\n*\n*  In some cases, due to catastrophic cancellations, it cannot\n*  factorize NB columns.  Hence, the actual number of factorized\n*  columns is returned in KB.\n*\n*  Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\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*  OFFSET  (input) INTEGER\n*          The number of rows of A that have been factorized in\n*          previous steps.\n*\n*  NB      (input) INTEGER\n*          The number of columns to factorize.\n*\n*  KB      (output) INTEGER\n*          The number of columns actually factorized.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, block A(OFFSET+1:M,1:KB) is the triangular\n*          factor obtained and block A(1:OFFSET,1:N) has been\n*          accordingly pivoted, but no factorized.\n*          The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has\n*          been updated.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  JPVT    (input/output) INTEGER array, dimension (N)\n*          JPVT(I) = K <==> Column K of the full matrix A has been\n*          permuted into position I in AP.\n*\n*  TAU     (output) COMPLEX*16 array, dimension (KB)\n*          The scalar factors of the elementary reflectors.\n*\n*  VN1     (input/output) DOUBLE PRECISION array, dimension (N)\n*          The vector with the partial column norms.\n*\n*  VN2     (input/output) DOUBLE PRECISION array, dimension (N)\n*          The vector with the exact column norms.\n*\n*  AUXV    (input/output) COMPLEX*16 array, dimension (NB)\n*          Auxiliar vector.\n*\n*  F       (input/output) COMPLEX*16 array, dimension (LDF,NB)\n*          Matrix F' = L*Y'*A.\n*\n*  LDF     (input) INTEGER\n*          The leading dimension of the array F. LDF >= max(1,N).\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n*    X. Sun, Computer Science Dept., Duke University, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  kb, tau, a, jpvt, vn1, vn2, auxv, f = NumRu::Lapack.zlaqps( m, offset, a, jpvt, vn1, vn2, auxv, f, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_m = argv[0];
  rblapack_offset = argv[1];
  rblapack_a = argv[2];
  rblapack_jpvt = argv[3];
  rblapack_vn1 = argv[4];
  rblapack_vn2 = argv[5];
  rblapack_auxv = argv[6];
  rblapack_f = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_vn1))
    rb_raise(rb_eArgError, "vn1 (5th argument) must be NArray");
  if (NA_RANK(rblapack_vn1) != 1)
    rb_raise(rb_eArgError, "rank of vn1 (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_vn1) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of vn1 must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_vn1) != NA_DFLOAT)
    rblapack_vn1 = na_change_type(rblapack_vn1, NA_DFLOAT);
  vn1 = NA_PTR_TYPE(rblapack_vn1, doublereal*);
  if (!NA_IsNArray(rblapack_auxv))
    rb_raise(rb_eArgError, "auxv (7th argument) must be NArray");
  if (NA_RANK(rblapack_auxv) != 1)
    rb_raise(rb_eArgError, "rank of auxv (7th argument) must be %d", 1);
  nb = NA_SHAPE0(rblapack_auxv);
  if (NA_TYPE(rblapack_auxv) != NA_DCOMPLEX)
    rblapack_auxv = na_change_type(rblapack_auxv, NA_DCOMPLEX);
  auxv = NA_PTR_TYPE(rblapack_auxv, doublecomplex*);
  offset = NUM2INT(rblapack_offset);
  if (!NA_IsNArray(rblapack_vn2))
    rb_raise(rb_eArgError, "vn2 (6th argument) must be NArray");
  if (NA_RANK(rblapack_vn2) != 1)
    rb_raise(rb_eArgError, "rank of vn2 (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_vn2) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of vn2 must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_vn2) != NA_DFLOAT)
    rblapack_vn2 = na_change_type(rblapack_vn2, NA_DFLOAT);
  vn2 = NA_PTR_TYPE(rblapack_vn2, doublereal*);
  if (!NA_IsNArray(rblapack_jpvt))
    rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
  if (NA_RANK(rblapack_jpvt) != 1)
    rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_jpvt) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_jpvt) != NA_LINT)
    rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
  jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
  if (!NA_IsNArray(rblapack_f))
    rb_raise(rb_eArgError, "f (8th argument) must be NArray");
  if (NA_RANK(rblapack_f) != 2)
    rb_raise(rb_eArgError, "rank of f (8th argument) must be %d", 2);
  ldf = NA_SHAPE0(rblapack_f);
  if (NA_SHAPE1(rblapack_f) != nb)
    rb_raise(rb_eRuntimeError, "shape 1 of f must be the same as shape 0 of auxv");
  if (NA_TYPE(rblapack_f) != NA_DCOMPLEX)
    rblapack_f = na_change_type(rblapack_f, NA_DCOMPLEX);
  f = NA_PTR_TYPE(rblapack_f, doublecomplex*);
  kb = nb;
  {
    na_shape_t shape[1];
    shape[0] = kb;
    rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
  MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
  rblapack_jpvt = rblapack_jpvt_out__;
  jpvt = jpvt_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_vn1_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  vn1_out__ = NA_PTR_TYPE(rblapack_vn1_out__, doublereal*);
  MEMCPY(vn1_out__, vn1, doublereal, NA_TOTAL(rblapack_vn1));
  rblapack_vn1 = rblapack_vn1_out__;
  vn1 = vn1_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_vn2_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  vn2_out__ = NA_PTR_TYPE(rblapack_vn2_out__, doublereal*);
  MEMCPY(vn2_out__, vn2, doublereal, NA_TOTAL(rblapack_vn2));
  rblapack_vn2 = rblapack_vn2_out__;
  vn2 = vn2_out__;
  {
    na_shape_t shape[1];
    shape[0] = nb;
    rblapack_auxv_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  auxv_out__ = NA_PTR_TYPE(rblapack_auxv_out__, doublecomplex*);
  MEMCPY(auxv_out__, auxv, doublecomplex, NA_TOTAL(rblapack_auxv));
  rblapack_auxv = rblapack_auxv_out__;
  auxv = auxv_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldf;
    shape[1] = nb;
    rblapack_f_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  f_out__ = NA_PTR_TYPE(rblapack_f_out__, doublecomplex*);
  MEMCPY(f_out__, f, doublecomplex, NA_TOTAL(rblapack_f));
  rblapack_f = rblapack_f_out__;
  f = f_out__;

  zlaqps_(&m, &n, &offset, &nb, &kb, a, &lda, jpvt, tau, vn1, vn2, auxv, f, &ldf);

  rblapack_kb = INT2NUM(kb);
  return rb_ary_new3(8, rblapack_kb, rblapack_tau, rblapack_a, rblapack_jpvt, rblapack_vn1, rblapack_vn2, rblapack_auxv, rblapack_f);
}

void
init_lapack_zlaqps(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlaqps", rblapack_zlaqps, -1);
}
ruby-lapack-1.7.2/ext/slaqr1.c0000644000175000017500000000722412502221026015733 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaqr1_(integer* n, real* h, integer* ldh, real* sr1, real* si1, real* sr2, real* si2, real* v);


static VALUE
rblapack_slaqr1(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_h;
  real *h; 
  VALUE rblapack_sr1;
  real sr1; 
  VALUE rblapack_si1;
  real si1; 
  VALUE rblapack_sr2;
  real sr2; 
  VALUE rblapack_si2;
  real si2; 
  VALUE rblapack_v;
  real *v; 

  integer ldh;
  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  v = NumRu::Lapack.slaqr1( h, sr1, si1, sr2, si2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V )\n\n*       Given a 2-by-2 or 3-by-3 matrix H, SLAQR1 sets v to a\n*       scalar multiple of the first column of the product\n*\n*       (*)  K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I)\n*\n*       scaling to avoid overflows and most underflows. It\n*       is assumed that either\n*\n*               1) sr1 = sr2 and si1 = -si2\n*           or\n*               2) si1 = si2 = 0.\n*\n*       This is useful for starting double implicit shift bulges\n*       in the QR algorithm.\n*\n*\n\n*       N      (input) integer\n*              Order of the matrix H. N must be either 2 or 3.\n*\n*       H      (input) REAL array of dimension (LDH,N)\n*              The 2-by-2 or 3-by-3 matrix H in (*).\n*\n*       LDH    (input) integer\n*              The leading dimension of H as declared in\n*              the calling procedure.  LDH.GE.N\n*\n*       SR1    (input) REAL\n*       SI1    The shifts in (*).\n*       SR2\n*       SI2\n*\n*       V      (output) REAL array of dimension N\n*              A scalar multiple of the first column of the\n*              matrix K in (*).\n*\n\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  v = NumRu::Lapack.slaqr1( h, sr1, si1, sr2, si2, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_h = argv[0];
  rblapack_sr1 = argv[1];
  rblapack_si1 = argv[2];
  rblapack_sr2 = argv[3];
  rblapack_si2 = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (1th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (1th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_SFLOAT)
    rblapack_h = na_change_type(rblapack_h, NA_SFLOAT);
  h = NA_PTR_TYPE(rblapack_h, real*);
  si1 = (real)NUM2DBL(rblapack_si1);
  si2 = (real)NUM2DBL(rblapack_si2);
  sr1 = (real)NUM2DBL(rblapack_sr1);
  sr2 = (real)NUM2DBL(rblapack_sr2);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_v = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  v = NA_PTR_TYPE(rblapack_v, real*);

  slaqr1_(&n, h, &ldh, &sr1, &si1, &sr2, &si2, v);

  return rblapack_v;
}

void
init_lapack_slaqr1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaqr1", rblapack_slaqr1, -1);
}
ruby-lapack-1.7.2/ext/cung2r.c0000644000175000017500000001041012502221016015716 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cung2r_(integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* work, integer* info);


static VALUE
rblapack_cung2r(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  complex *work;

  integer lda;
  integer n;
  integer k;

  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  info, a = NumRu::Lapack.cung2r( m, a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CUNG2R( M, N, K, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CUNG2R generates an m by n complex matrix Q with orthonormal columns,\n*  which is defined as the first n columns of a product of k elementary\n*  reflectors of order m\n*\n*        Q  =  H(1) H(2) . . . H(k)\n*\n*  as returned by CGEQRF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. M >= N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. N >= K >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the i-th column must contain the vector which\n*          defines the elementary reflector H(i), for i = 1,2,...,k, as\n*          returned by CGEQRF in the first k columns of its array\n*          argument A.\n*          On exit, the m by n matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) COMPLEX array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by CGEQRF.\n*\n*  WORK    (workspace) COMPLEX array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -i, the i-th argument has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.cung2r( m, a, tau, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  rblapack_tau = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(complex, (n));

  cung2r_(&m, &n, &k, a, &lda, tau, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_cung2r(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cung2r", rblapack_cung2r, -1);
}
ruby-lapack-1.7.2/ext/slatrd.c0000644000175000017500000001737412502221020016022 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slatrd_(char* uplo, integer* n, integer* nb, real* a, integer* lda, real* e, real* tau, real* w, integer* ldw);


static VALUE
rblapack_slatrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_nb;
  integer nb; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_a_out__;
  real *a_out__;

  integer lda;
  integer n;
  integer ldw;

  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  e, tau, w, a = NumRu::Lapack.slatrd( uplo, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )\n\n*  Purpose\n*  =======\n*\n*  SLATRD reduces NB rows and columns of a real symmetric matrix A to\n*  symmetric tridiagonal form by an orthogonal similarity\n*  transformation Q' * A * Q, and returns the matrices V and W which are\n*  needed to apply the transformation to the unreduced part of A.\n*\n*  If UPLO = 'U', SLATRD reduces the last NB rows and columns of a\n*  matrix, of which the upper triangle is supplied;\n*  if UPLO = 'L', SLATRD reduces the first NB rows and columns of a\n*  matrix, of which the lower triangle is supplied.\n*\n*  This is an auxiliary routine called by SSYTRD.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored:\n*          = 'U': Upper triangular\n*          = 'L': Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.\n*\n*  NB      (input) INTEGER\n*          The number of rows and columns to be reduced.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          n-by-n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n-by-n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*          On exit:\n*          if UPLO = 'U', the last NB columns have been reduced to\n*            tridiagonal form, with the diagonal elements overwriting\n*            the diagonal elements of A; the elements above the diagonal\n*            with the array TAU, represent the orthogonal matrix Q as a\n*            product of elementary reflectors;\n*          if UPLO = 'L', the first NB columns have been reduced to\n*            tridiagonal form, with the diagonal elements overwriting\n*            the diagonal elements of A; the elements below the diagonal\n*            with the array TAU, represent the  orthogonal matrix Q as a\n*            product of elementary reflectors.\n*          See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= (1,N).\n*\n*  E       (output) REAL array, dimension (N-1)\n*          If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal\n*          elements of the last NB columns of the reduced matrix;\n*          if UPLO = 'L', E(1:nb) contains the subdiagonal elements of\n*          the first NB columns of the reduced matrix.\n*\n*  TAU     (output) REAL array, dimension (N-1)\n*          The scalar factors of the elementary reflectors, stored in\n*          TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.\n*          See Further Details.\n*\n*  W       (output) REAL array, dimension (LDW,NB)\n*          The n-by-nb matrix W required to update the unreduced part\n*          of A.\n*\n*  LDW     (input) INTEGER\n*          The leading dimension of the array W. LDW >= max(1,N).\n*\n\n*  Further Details\n*  ===============\n*\n*  If UPLO = 'U', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(n) H(n-1) . . . H(n-nb+1).\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(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),\n*  and tau in TAU(i-1).\n*\n*  If UPLO = 'L', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(1) H(2) . . . H(nb).\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) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),\n*  and tau in TAU(i).\n*\n*  The elements of the vectors v together form the n-by-nb matrix V\n*  which is needed, with W, to apply the transformation to the unreduced\n*  part of the matrix, using a symmetric rank-2k update of the form:\n*  A := A - V*W' - W*V'.\n*\n*  The contents of A on exit are illustrated by the following examples\n*  with n = 5 and nb = 2:\n*\n*  if UPLO = 'U':                       if UPLO = 'L':\n*\n*    (  a   a   a   v4  v5 )              (  d                  )\n*    (      a   a   v4  v5 )              (  1   d              )\n*    (          a   1   v5 )              (  v1  1   a          )\n*    (              d   1  )              (  v1  v2  a   a      )\n*    (                  d  )              (  v1  v2  a   a   a  )\n*\n*  where d denotes a diagonal element of the reduced matrix, a denotes\n*  an element of the original matrix that is unchanged, and vi denotes\n*  an element of the vector defining H(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  e, tau, w, a = NumRu::Lapack.slatrd( uplo, nb, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_nb = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  nb = NUM2INT(rblapack_nb);
  ldw = MAX(1,n);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldw;
    shape[1] = MAX(n,nb);
    rblapack_w = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  slatrd_(&uplo, &n, &nb, a, &lda, e, tau, w, &ldw);

  return rb_ary_new3(4, rblapack_e, rblapack_tau, rblapack_w, rblapack_a);
}

void
init_lapack_slatrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slatrd", rblapack_slatrd, -1);
}
ruby-lapack-1.7.2/ext/sptrfs.c0000644000175000017500000001753612502221021016053 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sptrfs_(integer* n, integer* nrhs, real* d, real* e, real* df, real* ef, real* b, integer* ldb, real* x, integer* ldx, real* ferr, real* berr, real* work, integer* info);


static VALUE
rblapack_sptrfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_df;
  real *df; 
  VALUE rblapack_ef;
  real *ef; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  real *x_out__;
  real *work;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.sptrfs( d, e, df, ef, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPTRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is symmetric positive definite\n*  and tridiagonal, and provides error bounds and backward error\n*  estimates for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  D       (input) REAL array, dimension (N)\n*          The n diagonal elements of the tridiagonal matrix A.\n*\n*  E       (input) REAL array, dimension (N-1)\n*          The (n-1) subdiagonal elements of the tridiagonal matrix A.\n*\n*  DF      (input) REAL array, dimension (N)\n*          The n diagonal elements of the diagonal matrix D from the\n*          factorization computed by SPTTRF.\n*\n*  EF      (input) REAL array, dimension (N-1)\n*          The (n-1) subdiagonal elements of the unit bidiagonal factor\n*          L from the factorization computed by SPTTRF.\n*\n*  B       (input) REAL array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) REAL array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by SPTTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) REAL array, dimension (2*N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.sptrfs( d, e, df, ef, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_d = argv[0];
  rblapack_e = argv[1];
  rblapack_df = argv[2];
  rblapack_ef = argv[3];
  rblapack_b = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_df))
    rb_raise(rb_eArgError, "df (3th argument) must be NArray");
  if (NA_RANK(rblapack_df) != 1)
    rb_raise(rb_eArgError, "rank of df (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_df) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of df must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_df) != NA_SFLOAT)
    rblapack_df = na_change_type(rblapack_df, NA_SFLOAT);
  df = NA_PTR_TYPE(rblapack_df, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (2th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  if (!NA_IsNArray(rblapack_ef))
    rb_raise(rb_eArgError, "ef (4th argument) must be NArray");
  if (NA_RANK(rblapack_ef) != 1)
    rb_raise(rb_eArgError, "rank of ef (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ef) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of ef must be %d", n-1);
  if (NA_TYPE(rblapack_ef) != NA_SFLOAT)
    rblapack_ef = na_change_type(rblapack_ef, NA_SFLOAT);
  ef = NA_PTR_TYPE(rblapack_ef, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(real, (2*n));

  sptrfs_(&n, &nrhs, d, e, df, ef, b, &ldb, x, &ldx, ferr, berr, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_sptrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sptrfs", rblapack_sptrfs, -1);
}
ruby-lapack-1.7.2/ext/zstein.c0000644000175000017500000002064612502221014016044 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zstein_(integer* n, doublereal* d, doublereal* e, integer* m, doublereal* w, integer* iblock, integer* isplit, doublecomplex* z, integer* ldz, doublereal* work, integer* iwork, integer* ifail, integer* info);


static VALUE
rblapack_zstein(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_iblock;
  integer *iblock; 
  VALUE rblapack_isplit;
  integer *isplit; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_ifail;
  integer *ifail; 
  VALUE rblapack_info;
  integer info; 
  doublereal *work;
  integer *iwork;

  integer n;
  integer ldz;
  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  z, ifail, info = NumRu::Lapack.zstein( d, e, w, iblock, isplit, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZSTEIN computes the eigenvectors of a real symmetric tridiagonal\n*  matrix T corresponding to specified eigenvalues, using inverse\n*  iteration.\n*\n*  The maximum number of iterations allowed for each eigenvector is\n*  specified by an internal parameter MAXITS (currently set to 5).\n*\n*  Although the eigenvectors are real, they are stored in a complex\n*  array, which may be passed to ZUNMTR or ZUPMTR for back\n*  transformation to the eigenvectors of a complex Hermitian matrix\n*  which was reduced to tridiagonal form.\n*\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          The n diagonal elements of the tridiagonal matrix T.\n*\n*  E       (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (n-1) subdiagonal elements of the tridiagonal matrix\n*          T, stored in elements 1 to N-1.\n*\n*  M       (input) INTEGER\n*          The number of eigenvectors to be found.  0 <= M <= N.\n*\n*  W       (input) DOUBLE PRECISION array, dimension (N)\n*          The first M elements of W contain the eigenvalues for\n*          which eigenvectors are to be computed.  The eigenvalues\n*          should be grouped by split-off block and ordered from\n*          smallest to largest within the block.  ( The output array\n*          W from DSTEBZ with ORDER = 'B' is expected here. )\n*\n*  IBLOCK  (input) INTEGER array, dimension (N)\n*          The submatrix indices associated with the corresponding\n*          eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to\n*          the first submatrix from the top, =2 if W(i) belongs to\n*          the second submatrix, etc.  ( The output array IBLOCK\n*          from DSTEBZ is expected here. )\n*\n*  ISPLIT  (input) INTEGER array, dimension (N)\n*          The splitting points, at which T breaks up into submatrices.\n*          The first submatrix consists of rows/columns 1 to\n*          ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n*          through ISPLIT( 2 ), etc.\n*          ( The output array ISPLIT from DSTEBZ is expected here. )\n*\n*  Z       (output) COMPLEX*16 array, dimension (LDZ, M)\n*          The computed eigenvectors.  The eigenvector associated\n*          with the eigenvalue W(i) is stored in the i-th column of\n*          Z.  Any vector which fails to converge is set to its current\n*          iterate after MAXITS iterations.\n*          The imaginary parts of the eigenvectors are set to zero.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= max(1,N).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (5*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\n*\n*  IFAIL   (output) INTEGER array, dimension (M)\n*          On normal exit, all elements of IFAIL are zero.\n*          If one or more eigenvectors fail to converge after\n*          MAXITS iterations, then their indices are stored in\n*          array IFAIL.\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, then i eigenvectors failed to converge\n*               in MAXITS iterations.  Their indices are stored in\n*               array IFAIL.\n*\n*  Internal Parameters\n*  ===================\n*\n*  MAXITS  INTEGER, default = 5\n*          The maximum number of iterations performed.\n*\n*  EXTRA   INTEGER, default = 2\n*          The number of iterations performed after norm growth\n*          criterion is satisfied, should be at least 1.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  z, ifail, info = NumRu::Lapack.zstein( d, e, w, iblock, isplit, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_d = argv[0];
  rblapack_e = argv[1];
  rblapack_w = argv[2];
  rblapack_iblock = argv[3];
  rblapack_isplit = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_w))
    rb_raise(rb_eArgError, "w (3th argument) must be NArray");
  if (NA_RANK(rblapack_w) != 1)
    rb_raise(rb_eArgError, "rank of w (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_w) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_w) != NA_DFLOAT)
    rblapack_w = na_change_type(rblapack_w, NA_DFLOAT);
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  if (!NA_IsNArray(rblapack_isplit))
    rb_raise(rb_eArgError, "isplit (5th argument) must be NArray");
  if (NA_RANK(rblapack_isplit) != 1)
    rb_raise(rb_eArgError, "rank of isplit (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_isplit) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of isplit must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_isplit) != NA_LINT)
    rblapack_isplit = na_change_type(rblapack_isplit, NA_LINT);
  isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
  if (!NA_IsNArray(rblapack_iblock))
    rb_raise(rb_eArgError, "iblock (4th argument) must be NArray");
  if (NA_RANK(rblapack_iblock) != 1)
    rb_raise(rb_eArgError, "rank of iblock (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_iblock) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of iblock must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_iblock) != NA_LINT)
    rblapack_iblock = na_change_type(rblapack_iblock, NA_LINT);
  iblock = NA_PTR_TYPE(rblapack_iblock, integer*);
  m = n;
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (2th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  ldz = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = m;
    rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
  work = ALLOC_N(doublereal, (5*n));
  iwork = ALLOC_N(integer, (n));

  zstein_(&n, d, e, &m, w, iblock, isplit, z, &ldz, work, iwork, ifail, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_z, rblapack_ifail, rblapack_info);
}

void
init_lapack_zstein(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zstein", rblapack_zstein, -1);
}
ruby-lapack-1.7.2/ext/sla_syrpvgrw.c0000644000175000017500000001340312502221020017260 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real sla_syrpvgrw_(char* uplo, integer* n, integer* info, real* a, integer* lda, real* af, integer* ldaf, integer* ipiv, real* work);


static VALUE
rblapack_sla_syrpvgrw(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_af;
  real *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack___out__;
  real __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  __out__ = NumRu::Lapack.sla_syrpvgrw( uplo, info, a, af, ipiv, work, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL FUNCTION SLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, WORK )\n\n*  Purpose\n*  =======\n* \n*  SLA_SYRPVGRW computes the reciprocal pivot growth factor\n*  norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n*  much less than 1, the stability of the LU factorization of the\n*  (equilibrated) matrix A could be poor. This also means that the\n*  solution X, estimated condition numbers, and error bounds could be\n*  unreliable.\n*\n\n*  Arguments\n*  =========\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     INFO    (input) INTEGER\n*     The value of INFO returned from SSYTRF, .i.e., the pivot in\n*     column INFO is exactly 0.\n*\n*     NCOLS   (input) INTEGER\n*     The number of columns of the matrix A. NCOLS >= 0.\n*\n*     A       (input) REAL array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) REAL array, dimension (LDAF,N)\n*     The block diagonal matrix D and the multipliers used to\n*     obtain the factor U or L as computed by SSYTRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     Details of the interchanges and the block structure of D\n*     as determined by SSYTRF.\n*\n*     WORK    (input) REAL array, dimension (2*N)\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            NCOLS, I, J, K, KP\n      REAL               AMAX, UMAX, RPVGRW, TMP\n      LOGICAL            UPPER\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX, MIN\n*     ..\n*     .. External Functions ..\n      EXTERNAL           LSAME, SLASET\n      LOGICAL            LSAME\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.sla_syrpvgrw( uplo, info, a, af, ipiv, work, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_info = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_work = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  info = NUM2INT(rblapack_info);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
  af = NA_PTR_TYPE(rblapack_af, real*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (6th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
  if (NA_TYPE(rblapack_work) != NA_SFLOAT)
    rblapack_work = na_change_type(rblapack_work, NA_SFLOAT);
  work = NA_PTR_TYPE(rblapack_work, real*);

  __out__ = sla_syrpvgrw_(&uplo, &n, &info, a, &lda, af, &ldaf, ipiv, work);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_sla_syrpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sla_syrpvgrw", rblapack_sla_syrpvgrw, -1);
}
ruby-lapack-1.7.2/ext/zlauum.c0000644000175000017500000000740412502221025016044 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlauum_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* info);


static VALUE
rblapack_zlauum(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *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  info, a = NumRu::Lapack.zlauum( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAUUM( UPLO, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZLAUUM computes the product U * U' or L' * L, where the triangular\n*  factor U or L is stored in the upper or lower triangular part of\n*  the array A.\n*\n*  If UPLO = 'U' or 'u' then the upper triangle of the result is stored,\n*  overwriting the factor U in A.\n*  If UPLO = 'L' or 'l' then the lower triangle of the result is stored,\n*  overwriting the factor L in A.\n*\n*  This is the blocked form of the algorithm, calling Level 3 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the triangular factor stored in the array A\n*          is upper or lower triangular:\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the triangular factor U or L.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the triangular factor U or L.\n*          On exit, if UPLO = 'U', the upper triangle of A is\n*          overwritten with the upper triangle of the product U * U';\n*          if UPLO = 'L', the lower triangle of A is overwritten with\n*          the lower triangle of the product L' * L.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.zlauum( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zlauum_(&uplo, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_zlauum(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlauum", rblapack_zlauum, -1);
}
ruby-lapack-1.7.2/ext/zppsvx.c0000644000175000017500000003675612502221017016116 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zppsvx_(char* fact, char* uplo, integer* n, integer* nrhs, doublecomplex* ap, doublecomplex* afp, char* equed, doublereal* s, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zppsvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_afp;
  doublecomplex *afp; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublecomplex *ap_out__;
  VALUE rblapack_afp_out__;
  doublecomplex *afp_out__;
  VALUE rblapack_s_out__;
  doublereal *s_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, info, ap, afp, equed, s, b = NumRu::Lapack.zppsvx( fact, uplo, ap, afp, equed, s, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPPSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to\n*  compute the solution to a complex system of linear equations\n*     A * X = B,\n*  where A is an N-by-N Hermitian positive definite matrix stored in\n*  packed format and X and B are N-by-NRHS matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'E', real scaling factors are computed to equilibrate\n*     the system:\n*        diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n*  2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n*     factor the matrix A (after equilibration if FACT = 'E') as\n*        A = U'* U ,  if UPLO = 'U', or\n*        A = L * L',  if UPLO = 'L',\n*     where U is an upper triangular matrix, L is a lower triangular\n*     matrix, and ' indicates conjugate transpose.\n*\n*  3. If the leading i-by-i principal minor is not positive definite,\n*     then the routine returns with INFO = i. Otherwise, the factored\n*     form of A is used to estimate the condition number of the matrix\n*     A.  If the reciprocal of the condition number is less than machine\n*     precision, INFO = N+1 is returned as a warning, but the routine\n*     still goes on to solve for X and compute error bounds as\n*     described below.\n*\n*  4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  5. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n*  6. If equilibration was used, the matrix X is premultiplied by\n*     diag(S) so that it solves the original system before\n*     equilibration.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of the matrix A is\n*          supplied on entry, and if not, whether the matrix A should be\n*          equilibrated before it is factored.\n*          = 'F':  On entry, AFP contains the factored form of A.\n*                  If EQUED = 'Y', the matrix A has been equilibrated\n*                  with scaling factors given by S.  AP and AFP will not\n*                  be modified.\n*          = 'N':  The matrix A will be copied to AFP and factored.\n*          = 'E':  The matrix A will be equilibrated if necessary, then\n*                  copied to AFP and factored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          A, packed columnwise in a linear array, except if FACT = 'F'\n*          and EQUED = 'Y', then A must contain the equilibrated matrix\n*          diag(S)*A*diag(S).  The j-th column of A is stored in the\n*          array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          See below for further details.  A is not modified if\n*          FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n*          On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n*          diag(S)*A*diag(S).\n*\n*  AFP     (input or output) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          If FACT = 'F', then AFP is an input argument and on entry\n*          contains the triangular factor U or L from the Cholesky\n*          factorization A = U**H*U or A = L*L**H, in the same storage\n*          format as A.  If EQUED .ne. 'N', then AFP is the factored\n*          form of the equilibrated matrix A.\n*\n*          If FACT = 'N', then AFP is an output argument and on exit\n*          returns the triangular factor U or L from the Cholesky\n*          factorization A = U**H*U or A = L*L**H of the original\n*          matrix A.\n*\n*          If FACT = 'E', then AFP is an output argument and on exit\n*          returns the triangular factor U or L from the Cholesky\n*          factorization A = U**H*U or A = L*L**H of the equilibrated\n*          matrix A (see the description of AP for the form of the\n*          equilibrated matrix).\n*\n*  EQUED   (input or output) CHARACTER*1\n*          Specifies the form of equilibration that was done.\n*          = 'N':  No equilibration (always true if FACT = 'N').\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*          EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*          output argument.\n*\n*  S       (input or output) DOUBLE PRECISION array, dimension (N)\n*          The scale factors for A; not accessed if EQUED = 'N'.  S is\n*          an input argument if FACT = 'F'; otherwise, S is an output\n*          argument.  If FACT = 'F' and EQUED = 'Y', each element of S\n*          must be positive.\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n*          B is overwritten by diag(S) * B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) COMPLEX*16 array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n*          the original system of equations.  Note that if EQUED = 'Y',\n*          A and B are modified on exit, and the solution to the\n*          equilibrated system is inv(diag(S))*X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The estimate of the reciprocal condition number of the matrix\n*          A after equilibration (if done).  If RCOND is less than the\n*          machine precision (in particular, if RCOND = 0), the matrix\n*          is singular to working precision.  This condition is\n*          indicated by a return code of INFO > 0.\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\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, and i is\n*                <= N:  the leading minor of order i of A is\n*                       not positive definite, so the factorization\n*                       could not be completed, and the solution has not\n*                       been computed. RCOND = 0 is returned.\n*                = N+1: U is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  Further Details\n*  ===============\n*\n*  The packed storage scheme is illustrated by the following example\n*  when N = 4, UPLO = 'U':\n*\n*  Two-dimensional storage of the Hermitian matrix A:\n*\n*     a11 a12 a13 a14\n*         a22 a23 a24\n*             a33 a34     (aij = conjg(aji))\n*                 a44\n*\n*  Packed storage of the upper triangle of A:\n*\n*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, info, ap, afp, equed, s, b = NumRu::Lapack.zppsvx( fact, uplo, ap, afp, equed, s, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_ap = argv[2];
  rblapack_afp = argv[3];
  rblapack_equed = argv[4];
  rblapack_s = argv[5];
  rblapack_b = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (6th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_s);
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  ldx = MAX(1,n);
  if (!NA_IsNArray(rblapack_afp))
    rb_raise(rb_eArgError, "afp (4th argument) must be NArray");
  if (NA_RANK(rblapack_afp) != 1)
    rb_raise(rb_eArgError, "rank of afp (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_afp) != NA_DCOMPLEX)
    rblapack_afp = na_change_type(rblapack_afp, NA_DCOMPLEX);
  afp = NA_PTR_TYPE(rblapack_afp, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
  MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_afp_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  afp_out__ = NA_PTR_TYPE(rblapack_afp_out__, doublecomplex*);
  MEMCPY(afp_out__, afp, doublecomplex, NA_TOTAL(rblapack_afp));
  rblapack_afp = rblapack_afp_out__;
  afp = afp_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
  MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (n));

  zppsvx_(&fact, &uplo, &n, &nrhs, ap, afp, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_ap, rblapack_afp, rblapack_equed, rblapack_s, rblapack_b);
}

void
init_lapack_zppsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zppsvx", rblapack_zppsvx, -1);
}
ruby-lapack-1.7.2/ext/dgegv.c0000644000175000017500000003440012502221026015620 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgegv_(char* jobvl, char* jobvr, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* alphar, doublereal* alphai, doublereal* beta, doublereal* vl, integer* ldvl, doublereal* vr, integer* ldvr, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dgegv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvl;
  char jobvl; 
  VALUE rblapack_jobvr;
  char jobvr; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_alphar;
  doublereal *alphar; 
  VALUE rblapack_alphai;
  doublereal *alphai; 
  VALUE rblapack_beta;
  doublereal *beta; 
  VALUE rblapack_vl;
  doublereal *vl; 
  VALUE rblapack_vr;
  doublereal *vr; 
  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 ldb;
  integer ldvl;
  integer ldvr;

  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  alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.dgegv( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  This routine is deprecated and has been replaced by routine DGGEV.\n*\n*  DGEGV computes the eigenvalues and, optionally, the left and/or right\n*  eigenvectors of a real matrix pair (A,B).\n*  Given two square matrices A and B,\n*  the generalized nonsymmetric eigenvalue problem (GNEP) is to find the\n*  eigenvalues lambda and corresponding (non-zero) eigenvectors x such\n*  that\n*\n*     A*x = lambda*B*x.\n*\n*  An alternate form is to find the eigenvalues mu and corresponding\n*  eigenvectors y such that\n*\n*     mu*A*y = B*y.\n*\n*  These two forms are equivalent with mu = 1/lambda and x = y if\n*  neither lambda nor mu is zero.  In order to deal with the case that\n*  lambda or mu is zero or small, two values alpha and beta are returned\n*  for each eigenvalue, such that lambda = alpha/beta and\n*  mu = beta/alpha.\n*\n*  The vectors x and y in the above equations are right eigenvectors of\n*  the matrix pair (A,B).  Vectors u and v satisfying\n*\n*     u**H*A = lambda*u**H*B  or  mu*v**H*A = v**H*B\n*\n*  are left eigenvectors of (A,B).\n*\n*  Note: this routine performs \"full balancing\" on A and B -- see\n*  \"Further Details\", below.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVL   (input) CHARACTER*1\n*          = 'N':  do not compute the left generalized eigenvectors;\n*          = 'V':  compute the left generalized eigenvectors (returned\n*                  in VL).\n*\n*  JOBVR   (input) CHARACTER*1\n*          = 'N':  do not compute the right generalized eigenvectors;\n*          = 'V':  compute the right generalized eigenvectors (returned\n*                  in VR).\n*\n*  N       (input) INTEGER\n*          The order of the matrices A, B, VL, and VR.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n*          On entry, the matrix A.\n*          If JOBVL = 'V' or JOBVR = 'V', then on exit A\n*          contains the real Schur form of A from the generalized Schur\n*          factorization of the pair (A,B) after balancing.\n*          If no eigenvectors were computed, then only the diagonal\n*          blocks from the Schur form will be correct.  See DGGHRD and\n*          DHGEQZ for details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of A.  LDA >= max(1,N).\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n*          On entry, the matrix B.\n*          If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the\n*          upper triangular matrix obtained from B in the generalized\n*          Schur factorization of the pair (A,B) after balancing.\n*          If no eigenvectors were computed, then only those elements of\n*          B corresponding to the diagonal blocks from the Schur form of\n*          A will be correct.  See DGGHRD and DHGEQZ for details.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of B.  LDB >= max(1,N).\n*\n*  ALPHAR  (output) DOUBLE PRECISION array, dimension (N)\n*          The real parts of each scalar alpha defining an eigenvalue of\n*          GNEP.\n*\n*  ALPHAI  (output) DOUBLE PRECISION array, dimension (N)\n*          The imaginary parts of each scalar alpha defining an\n*          eigenvalue of GNEP.  If ALPHAI(j) is zero, then the j-th\n*          eigenvalue is real; if positive, then the j-th and\n*          (j+1)-st eigenvalues are a complex conjugate pair, with\n*          ALPHAI(j+1) = -ALPHAI(j).\n*\n*  BETA    (output) DOUBLE PRECISION array, dimension (N)\n*          The scalars beta that define the eigenvalues of GNEP.\n*          \n*          Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and\n*          beta = BETA(j) represent the j-th eigenvalue of the matrix\n*          pair (A,B), in one of the forms lambda = alpha/beta or\n*          mu = beta/alpha.  Since either lambda or mu may overflow,\n*          they should not, in general, be computed.\n*\n*  VL      (output) DOUBLE PRECISION array, dimension (LDVL,N)\n*          If JOBVL = 'V', the left eigenvectors u(j) are stored\n*          in the columns of VL, in the same order as their eigenvalues.\n*          If the j-th eigenvalue is real, then u(j) = VL(:,j).\n*          If the j-th and (j+1)-st eigenvalues form a complex conjugate\n*          pair, then\n*             u(j) = VL(:,j) + i*VL(:,j+1)\n*          and\n*            u(j+1) = VL(:,j) - i*VL(:,j+1).\n*\n*          Each eigenvector is scaled so that its largest component has\n*          abs(real part) + abs(imag. part) = 1, except for eigenvectors\n*          corresponding to an eigenvalue with alpha = beta = 0, which\n*          are set to zero.\n*          Not referenced if JOBVL = 'N'.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the matrix VL. LDVL >= 1, and\n*          if JOBVL = 'V', LDVL >= N.\n*\n*  VR      (output) DOUBLE PRECISION array, dimension (LDVR,N)\n*          If JOBVR = 'V', the right eigenvectors x(j) are stored\n*          in the columns of VR, in the same order as their eigenvalues.\n*          If the j-th eigenvalue is real, then x(j) = VR(:,j).\n*          If the j-th and (j+1)-st eigenvalues form a complex conjugate\n*          pair, then\n*            x(j) = VR(:,j) + i*VR(:,j+1)\n*          and\n*            x(j+1) = VR(:,j) - i*VR(:,j+1).\n*\n*          Each eigenvector is scaled so that its largest component has\n*          abs(real part) + abs(imag. part) = 1, except for eigenvalues\n*          corresponding to an eigenvalue with alpha = beta = 0, which\n*          are set to zero.\n*          Not referenced if JOBVR = 'N'.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the matrix VR. LDVR >= 1, and\n*          if JOBVR = 'V', LDVR >= 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.  LWORK >= max(1,8*N).\n*          For good performance, LWORK must generally be larger.\n*          To compute the optimal value of LWORK, call ILAENV to get\n*          blocksizes (for DGEQRF, DORMQR, and DORGQR.)  Then compute:\n*          NB  -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR;\n*          The optimal LWORK is:\n*              2*N + MAX( 6*N, N*(NB+1) ).\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*          = 1,...,N:\n*                The QZ iteration failed.  No eigenvectors have been\n*                calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)\n*                should be correct for j=INFO+1,...,N.\n*          > N:  errors that usually indicate LAPACK problems:\n*                =N+1: error return from DGGBAL\n*                =N+2: error return from DGEQRF\n*                =N+3: error return from DORMQR\n*                =N+4: error return from DORGQR\n*                =N+5: error return from DGGHRD\n*                =N+6: error return from DHGEQZ (other than failed\n*                                                iteration)\n*                =N+7: error return from DTGEVC\n*                =N+8: error return from DGGBAK (computing VL)\n*                =N+9: error return from DGGBAK (computing VR)\n*                =N+10: error return from DLASCL (various calls)\n*\n\n*  Further Details\n*  ===============\n*\n*  Balancing\n*  ---------\n*\n*  This driver calls DGGBAL to both permute and scale rows and columns\n*  of A and B.  The permutations PL and PR are chosen so that PL*A*PR\n*  and PL*B*R will be upper triangular except for the diagonal blocks\n*  A(i:j,i:j) and B(i:j,i:j), with i and j as close together as\n*  possible.  The diagonal scaling matrices DL and DR are chosen so\n*  that the pair  DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to\n*  one (except for the elements that start out zero.)\n*\n*  After the eigenvalues and eigenvectors of the balanced matrices\n*  have been computed, DGGBAK transforms the eigenvectors back to what\n*  they would have been (in perfect arithmetic) if they had not been\n*  balanced.\n*\n*  Contents of A and B on Exit\n*  -------- -- - --- - -- ----\n*\n*  If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or\n*  both), then on exit the arrays A and B will contain the real Schur\n*  form[*] of the \"balanced\" versions of A and B.  If no eigenvectors\n*  are computed, then only the diagonal blocks will be correct.\n*\n*  [*] See DHGEQZ, DGEGS, or read the book \"Matrix Computations\",\n*      by Golub & van Loan, pub. by Johns Hopkins U. Press.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  alphar, alphai, beta, vl, vr, work, info, a, b = NumRu::Lapack.dgegv( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_jobvl = argv[0];
  rblapack_jobvr = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  jobvl = StringValueCStr(rblapack_jobvl)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  jobvr = StringValueCStr(rblapack_jobvr)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  ldvr = lsame_(&jobvr,"V") ? n : 1;
  if (rblapack_lwork == Qnil)
    lwork = 8*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldvl = lsame_(&jobvl,"V") ? n : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  alphar = NA_PTR_TYPE(rblapack_alphar, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  alphai = NA_PTR_TYPE(rblapack_alphai, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = n;
    rblapack_vl = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vl = NA_PTR_TYPE(rblapack_vl, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = n;
    rblapack_vr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vr = NA_PTR_TYPE(rblapack_vr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dgegv_(&jobvl, &jobvr, &n, a, &lda, b, &ldb, alphar, alphai, beta, vl, &ldvl, vr, &ldvr, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_vl, rblapack_vr, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_dgegv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgegv", rblapack_dgegv, -1);
}
ruby-lapack-1.7.2/ext/zhegv.c0000644000175000017500000002105512502221016015650 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhegv_(integer* itype, char* jobz, char* uplo, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublereal* w, doublecomplex* work, integer* lwork, doublereal* rwork, integer* info);


static VALUE
rblapack_zhegv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  doublereal *rwork;

  integer lda;
  integer n;
  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  w, work, info, a, b = NumRu::Lapack.zhegv( itype, jobz, uplo, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHEGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHEGV computes all the eigenvalues, and optionally, the eigenvectors\n*  of a complex generalized Hermitian-definite eigenproblem, of the form\n*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.\n*  Here A and B are assumed to be Hermitian and B is also\n*  positive definite.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          Specifies the problem type to be solved:\n*          = 1:  A*x = (lambda)*B*x\n*          = 2:  A*B*x = (lambda)*x\n*          = 3:  B*A*x = (lambda)*x\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA, N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of A contains the\n*          upper triangular part of the matrix A.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of A contains\n*          the lower triangular part of the matrix A.\n*\n*          On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n*          matrix Z of eigenvectors.  The eigenvectors are normalized\n*          as follows:\n*          if ITYPE = 1 or 2, Z**H*B*Z = I;\n*          if ITYPE = 3, Z**H*inv(B)*Z = I.\n*          If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n*          or the lower triangle (if UPLO='L') of A, including the\n*          diagonal, is destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB, N)\n*          On entry, the Hermitian positive definite matrix B.\n*          If UPLO = 'U', the leading N-by-N upper triangular part of B\n*          contains the upper triangular part of the matrix B.\n*          If UPLO = 'L', the leading N-by-N lower triangular part of B\n*          contains the lower triangular part of the matrix B.\n*\n*          On exit, if INFO <= N, the part of B containing the matrix is\n*          overwritten by the triangular factor U or L from the Cholesky\n*          factorization B = U**H*U or B = L*L**H.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of the array WORK.  LWORK >= max(1,2*N-1).\n*          For optimal efficiency, LWORK >= (NB+1)*N,\n*          where NB is the blocksize for ZHETRD returned by ILAENV.\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*  RWORK   (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2))\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  ZPOTRF or ZHEEV returned an error code:\n*             <= N:  if INFO = i, ZHEEV failed to converge;\n*                    i off-diagonal elements of an intermediate\n*                    tridiagonal form did not converge to zero;\n*             > N:   if INFO = N + i, for 1 <= i <= N, then the leading\n*                    minor of order i of B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, work, info, a, b = NumRu::Lapack.zhegv( itype, jobz, uplo, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_itype = argv[0];
  rblapack_jobz = argv[1];
  rblapack_uplo = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  if (argc == 6) {
    rblapack_lwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  itype = NUM2INT(rblapack_itype);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (rblapack_lwork == Qnil)
    lwork = 2*n-1;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  rwork = ALLOC_N(doublereal, (MAX(1, 3*n-2)));

  zhegv_(&itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, work, &lwork, rwork, &info);

  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_w, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_zhegv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhegv", rblapack_zhegv, -1);
}
ruby-lapack-1.7.2/ext/cstegr.c0000644000175000017500000003027612502221014016017 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cstegr_(char* jobz, char* range, integer* n, real* d, real* e, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, complex* z, integer* ldz, integer* isuppz, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_cstegr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_vl;
  real vl; 
  VALUE rblapack_vu;
  real vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  real abstol; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_isuppz;
  integer *isuppz; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_e_out__;
  real *e_out__;

  integer n;
  integer ldz;

  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  m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.cstegr( jobz, range, d, e, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CSTEGR computes selected eigenvalues and, optionally, eigenvectors\n*  of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n*  a well defined set of pairwise different real eigenvalues, the corresponding\n*  real eigenvectors are pairwise orthogonal.\n*\n*  The spectrum may be computed either completely or partially by specifying\n*  either an interval (VL,VU] or a range of indices IL:IU for the desired\n*  eigenvalues.\n*\n*  CSTEGR is a compatability wrapper around the improved CSTEMR routine.\n*  See SSTEMR for further details.\n*\n*  One important change is that the ABSTOL parameter no longer provides any\n*  benefit and hence is no longer used.\n*\n*  Note : CSTEGR and CSTEMR work only on machines which follow\n*  IEEE-754 floating-point standard in their handling of infinities and\n*  NaNs.  Normal execution may create these exceptiona values and hence\n*  may abort due to a floating point exception in environments which\n*  do not conform to the IEEE-754 standard.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found.\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found.\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  D       (input/output) REAL array, dimension (N)\n*          On entry, the N diagonal elements of the tridiagonal matrix\n*          T. On exit, D is overwritten.\n*\n*  E       (input/output) REAL array, dimension (N)\n*          On entry, the (N-1) subdiagonal elements of the tridiagonal\n*          matrix T in elements 1 to N-1 of E. E(N) need not be set on\n*          input, but is used internally as workspace.\n*          On exit, E is overwritten.\n*\n*  VL      (input) REAL\n*  VU      (input) REAL\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) REAL\n*          Unused.  Was the absolute error tolerance for the\n*          eigenvalues/eigenvectors in previous versions.\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) REAL array, dimension (N)\n*          The first M elements contain the selected eigenvalues in\n*          ascending order.\n*\n*  Z       (output) COMPLEX array, dimension (LDZ, max(1,M) )\n*          If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix T\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*          Supplying N columns is always safe.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', then LDZ >= max(1,N).\n*\n*  ISUPPZ  (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n*          The support of the eigenvectors in Z, i.e., the indices\n*          indicating the nonzero elements in Z. The i-th computed eigenvector\n*          is nonzero only in elements ISUPPZ( 2*i-1 ) through\n*          ISUPPZ( 2*i ). This is relevant in the case when the matrix\n*          is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n*\n*  WORK    (workspace/output) REAL array, dimension (LWORK)\n*          On exit, if INFO = 0, WORK(1) returns the optimal\n*          (and minimal) LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK. LWORK >= max(1,18*N)\n*          if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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*  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.  LIWORK >= max(1,10*N)\n*          if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n*          if only the eigenvalues are to be computed.\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal size of the IWORK array,\n*          returns this value as the first entry of the IWORK array, and\n*          no error message related to LIWORK is issued by XERBLA.\n*\n*  INFO    (output) INTEGER\n*          On exit, INFO\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  if INFO = 1X, internal error in SLARRE,\n*                if INFO = 2X, internal error in CLARRV.\n*                Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n*                the nonzero error code returned by SLARRE or\n*                CLARRV, respectively.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Inderjit Dhillon, IBM Almaden, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, LBNL/NERSC, USA\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL TRYRAC\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL CSTEMR\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.cstegr( jobz, range, d, e, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 11)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_d = argv[2];
  rblapack_e = argv[3];
  rblapack_vl = argv[4];
  rblapack_vu = argv[5];
  rblapack_il = argv[6];
  rblapack_iu = argv[7];
  rblapack_abstol = argv[8];
  if (argc == 11) {
    rblapack_lwork = argv[9];
    rblapack_liwork = argv[10];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  vl = (real)NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  abstol = (real)NUM2DBL(rblapack_abstol);
  range = StringValueCStr(rblapack_range)[0];
  vu = (real)NUM2DBL(rblapack_vu);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (4th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&jobz,"V") ? 18*n : lsame_(&jobz,"N") ? 12*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  iu = NUM2INT(rblapack_iu);
  m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
  if (rblapack_liwork == Qnil)
    liwork = lsame_(&jobz,"V") ? 10*n : lsame_(&jobz,"N") ? 8*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, complex*);
  {
    na_shape_t shape[1];
    shape[0] = 2*MAX(1,m);
    rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
  MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;

  cstegr_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, isuppz, work, &lwork, iwork, &liwork, &info);

  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_m, rblapack_w, rblapack_z, rblapack_isuppz, rblapack_work, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e);
}

void
init_lapack_cstegr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cstegr", rblapack_cstegr, -1);
}
ruby-lapack-1.7.2/ext/zpbcon.c0000644000175000017500000001120312502221023016010 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zpbcon_(char* uplo, integer* n, integer* kd, doublecomplex* ab, integer* ldab, doublereal* anorm, doublereal* rcond, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zpbcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_anorm;
  doublereal anorm; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_info;
  integer info; 
  doublecomplex *work;
  doublereal *rwork;

  integer ldab;
  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  rcond, info = NumRu::Lapack.zpbcon( uplo, kd, ab, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPBCON estimates the reciprocal of the condition number (in the\n*  1-norm) of a complex Hermitian positive definite band matrix using\n*  the Cholesky factorization A = U**H*U or A = L*L**H computed by\n*  ZPBTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangular factor stored in AB;\n*          = 'L':  Lower triangular factor stored in AB.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**H*U or A = L*L**H of the band matrix A, stored in the\n*          first KD+1 rows of the array.  The j-th column of U or L is\n*          stored in the j-th column of the array AB as follows:\n*          if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO ='L', AB(1+i-j,j)    = L(i,j) for j<=i<=min(n,j+kd).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  ANORM   (input) DOUBLE PRECISION\n*          The 1-norm (or infinity-norm) of the Hermitian band matrix A.\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n*          estimate of the 1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.zpbcon( uplo, kd, ab, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  rblapack_anorm = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  kd = NUM2INT(rblapack_kd);
  anorm = NUM2DBL(rblapack_anorm);
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (n));

  zpbcon_(&uplo, &n, &kd, ab, &ldab, &anorm, &rcond, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_zpbcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zpbcon", rblapack_zpbcon, -1);
}
ruby-lapack-1.7.2/ext/ilazlr.c0000644000175000017500000000461312502221023016021 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern integer ilazlr_(integer* m, integer* n, doublecomplex* a, integer* lda);


static VALUE
rblapack_ilazlr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack___out__;
  integer __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  __out__ = NumRu::Lapack.ilazlr( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      INTEGER FUNCTION ILAZLR( M, N, A, LDA )\n\n*  Purpose\n*  =======\n*\n*  ILAZLR scans A for its last non-zero row.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          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\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.ilazlr( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);

  __out__ = ilazlr_(&m, &n, a, &lda);

  rblapack___out__ = INT2NUM(__out__);
  return rblapack___out__;
}

void
init_lapack_ilazlr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ilazlr", rblapack_ilazlr, -1);
}
ruby-lapack-1.7.2/ext/zupmtr.c0000644000175000017500000001463612502221020016070 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zupmtr_(char* side, char* uplo, char* trans, integer* m, integer* n, doublecomplex* ap, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work, integer* info);


static VALUE
rblapack_zupmtr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_c;
  doublecomplex *c; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublecomplex *c_out__;
  doublecomplex *work;

  integer ldc;
  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  info, c = NumRu::Lapack.zupmtr( side, uplo, trans, m, ap, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZUPMTR overwrites the general complex M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'C':      Q**H * C       C * Q**H\n*\n*  where Q is a complex unitary matrix of order nq, with nq = m if\n*  SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of\n*  nq-1 elementary reflectors, as returned by ZHPTRD using packed\n*  storage:\n*\n*  if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);\n*\n*  if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**H from the Left;\n*          = 'R': apply Q or Q**H from the Right.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U': Upper triangular packed storage used in previous\n*                 call to ZHPTRD;\n*          = 'L': Lower triangular packed storage used in previous\n*                 call to ZHPTRD.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'C':  Conjugate transpose, apply Q**H.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  AP      (input) COMPLEX*16 array, dimension\n*                               (M*(M+1)/2) if SIDE = 'L'\n*                               (N*(N+1)/2) if SIDE = 'R'\n*          The vectors which define the elementary reflectors, as\n*          returned by ZHPTRD.  AP is modified by the routine but\n*          restored on exit.\n*\n*  TAU     (input) COMPLEX*16 array, dimension (M-1) if SIDE = 'L'\n*                                     or (N-1) if SIDE = 'R'\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by ZHPTRD.\n*\n*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension\n*                                   (N) if SIDE = 'L'\n*                                   (M) if SIDE = 'R'\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, c = NumRu::Lapack.zupmtr( side, uplo, trans, m, ap, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_side = argv[0];
  rblapack_uplo = argv[1];
  rblapack_trans = argv[2];
  rblapack_m = argv[3];
  rblapack_ap = argv[4];
  rblapack_tau = argv[5];
  rblapack_c = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (6th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_tau) != (m-1))
    rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", m-1);
  if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (m*(m+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", m*(m+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
  MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(doublecomplex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  zupmtr_(&side, &uplo, &trans, &m, &n, ap, tau, c, &ldc, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_c);
}

void
init_lapack_zupmtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zupmtr", rblapack_zupmtr, -1);
}
ruby-lapack-1.7.2/ext/dgttrs.c0000644000175000017500000001655712502221012016043 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgttrs_(char* trans, integer* n, integer* nrhs, doublereal* dl, doublereal* d, doublereal* du, doublereal* du2, integer* ipiv, doublereal* b, integer* ldb, integer* info);


static VALUE
rblapack_dgttrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_dl;
  doublereal *dl; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_du;
  doublereal *du; 
  VALUE rblapack_du2;
  doublereal *du2; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublereal *b_out__;

  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.dgttrs( trans, dl, d, du, du2, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGTTRS solves one of the systems of equations\n*     A*X = B  or  A'*X = B,\n*  with a tridiagonal matrix A using the LU factorization computed\n*  by DGTTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations.\n*          = 'N':  A * X = B  (No transpose)\n*          = 'T':  A'* X = B  (Transpose)\n*          = 'C':  A'* X = B  (Conjugate transpose = Transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  DL      (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (n-1) multipliers that define the matrix L from the\n*          LU factorization of A.\n*\n*  D       (input) DOUBLE PRECISION array, dimension (N)\n*          The n diagonal elements of the upper triangular matrix U from\n*          the LU factorization of A.\n*\n*  DU      (input) DOUBLE PRECISION array, dimension (N-1)\n*          The (n-1) elements of the first super-diagonal of U.\n*\n*  DU2     (input) DOUBLE PRECISION array, dimension (N-2)\n*          The (n-2) elements of the second super-diagonal of U.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices; for 1 <= i <= n, row i of the matrix was\n*          interchanged with row IPIV(i).  IPIV(i) will always be either\n*          i or i+1; IPIV(i) = i indicates a row interchange was not\n*          required.\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the matrix of right hand side vectors B.\n*          On exit, B is overwritten by the solution vectors X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            NOTRAN\n      INTEGER            ITRANS, J, JB, NB\n*     ..\n*     .. External Functions ..\n      INTEGER            ILAENV\n      EXTERNAL           ILAENV\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DGTTS2, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.dgttrs( trans, dl, d, du, du2, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_trans = argv[0];
  rblapack_dl = argv[1];
  rblapack_d = argv[2];
  rblapack_du = argv[3];
  rblapack_du2 = argv[4];
  rblapack_ipiv = argv[5];
  rblapack_b = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_DFLOAT)
    rblapack_dl = na_change_type(rblapack_dl, NA_DFLOAT);
  dl = NA_PTR_TYPE(rblapack_dl, doublereal*);
  if (!NA_IsNArray(rblapack_du2))
    rb_raise(rb_eArgError, "du2 (5th argument) must be NArray");
  if (NA_RANK(rblapack_du2) != 1)
    rb_raise(rb_eArgError, "rank of du2 (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du2) != (n-2))
    rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
  if (NA_TYPE(rblapack_du2) != NA_DFLOAT)
    rblapack_du2 = na_change_type(rblapack_du2, NA_DFLOAT);
  du2 = NA_PTR_TYPE(rblapack_du2, doublereal*);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (4th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_DFLOAT)
    rblapack_du = na_change_type(rblapack_du, NA_DFLOAT);
  du = NA_PTR_TYPE(rblapack_du, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dgttrs_(&trans, &n, &nrhs, dl, d, du, du2, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_dgttrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgttrs", rblapack_dgttrs, -1);
}
ruby-lapack-1.7.2/ext/cggbak.c0000644000175000017500000001472212502221012015742 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cggbak_(char* job, char* side, integer* n, integer* ilo, integer* ihi, real* lscale, real* rscale, integer* m, complex* v, integer* ldv, integer* info);


static VALUE
rblapack_cggbak(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_lscale;
  real *lscale; 
  VALUE rblapack_rscale;
  real *rscale; 
  VALUE rblapack_v;
  complex *v; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_v_out__;
  complex *v_out__;

  integer n;
  integer ldv;
  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  info, v = NumRu::Lapack.cggbak( job, side, ilo, ihi, lscale, rscale, v, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGGBAK forms the right or left eigenvectors of a complex generalized\n*  eigenvalue problem A*x = lambda*B*x, by backward transformation on\n*  the computed eigenvectors of the balanced pair of matrices output by\n*  CGGBAL.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies the type of backward transformation required:\n*          = 'N':  do nothing, return immediately;\n*          = 'P':  do backward transformation for permutation only;\n*          = 'S':  do backward transformation for scaling only;\n*          = 'B':  do backward transformations for both permutation and\n*                  scaling.\n*          JOB must be the same as the argument JOB supplied to CGGBAL.\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'R':  V contains right eigenvectors;\n*          = 'L':  V contains left eigenvectors.\n*\n*  N       (input) INTEGER\n*          The number of rows of the matrix V.  N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          The integers ILO and IHI determined by CGGBAL.\n*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n*  LSCALE  (input) REAL array, dimension (N)\n*          Details of the permutations and/or scaling factors applied\n*          to the left side of A and B, as returned by CGGBAL.\n*\n*  RSCALE  (input) REAL array, dimension (N)\n*          Details of the permutations and/or scaling factors applied\n*          to the right side of A and B, as returned by CGGBAL.\n*\n*  M       (input) INTEGER\n*          The number of columns of the matrix V.  M >= 0.\n*\n*  V       (input/output) COMPLEX array, dimension (LDV,M)\n*          On entry, the matrix of right or left eigenvectors to be\n*          transformed, as returned by CTGEVC.\n*          On exit, V is overwritten by the transformed eigenvectors.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the matrix V. LDV >= max(1,N).\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*  See R.C. Ward, Balancing the generalized eigenvalue problem,\n*                 SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LEFTV, RIGHTV\n      INTEGER            I, K\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CSSCAL, CSWAP, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, v = NumRu::Lapack.cggbak( job, side, ilo, ihi, lscale, rscale, v, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_job = argv[0];
  rblapack_side = argv[1];
  rblapack_ilo = argv[2];
  rblapack_ihi = argv[3];
  rblapack_lscale = argv[4];
  rblapack_rscale = argv[5];
  rblapack_v = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  job = StringValueCStr(rblapack_job)[0];
  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_lscale))
    rb_raise(rb_eArgError, "lscale (5th argument) must be NArray");
  if (NA_RANK(rblapack_lscale) != 1)
    rb_raise(rb_eArgError, "rank of lscale (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_lscale);
  if (NA_TYPE(rblapack_lscale) != NA_SFLOAT)
    rblapack_lscale = na_change_type(rblapack_lscale, NA_SFLOAT);
  lscale = NA_PTR_TYPE(rblapack_lscale, real*);
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (7th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  m = NA_SHAPE1(rblapack_v);
  if (NA_TYPE(rblapack_v) != NA_SCOMPLEX)
    rblapack_v = na_change_type(rblapack_v, NA_SCOMPLEX);
  v = NA_PTR_TYPE(rblapack_v, complex*);
  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_rscale))
    rb_raise(rb_eArgError, "rscale (6th argument) must be NArray");
  if (NA_RANK(rblapack_rscale) != 1)
    rb_raise(rb_eArgError, "rank of rscale (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_rscale) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of rscale must be the same as shape 0 of lscale");
  if (NA_TYPE(rblapack_rscale) != NA_SFLOAT)
    rblapack_rscale = na_change_type(rblapack_rscale, NA_SFLOAT);
  rscale = NA_PTR_TYPE(rblapack_rscale, real*);
  ihi = NUM2INT(rblapack_ihi);
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = m;
    rblapack_v_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  v_out__ = NA_PTR_TYPE(rblapack_v_out__, complex*);
  MEMCPY(v_out__, v, complex, NA_TOTAL(rblapack_v));
  rblapack_v = rblapack_v_out__;
  v = v_out__;

  cggbak_(&job, &side, &n, &ilo, &ihi, lscale, rscale, &m, v, &ldv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_v);
}

void
init_lapack_cggbak(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cggbak", rblapack_cggbak, -1);
}
ruby-lapack-1.7.2/ext/dgees.c0000644000175000017500000002340712502221022015614 0ustar  uwabamiuwabami#include "rb_lapack.h"

static logical
rblapack_select(doublereal *arg0, doublereal *arg1){
  VALUE rblapack_arg0, rblapack_arg1;

  VALUE rblapack_ret;
  logical ret;

  rblapack_arg0 = rb_float_new((double)(*arg0));
  rblapack_arg1 = rb_float_new((double)(*arg1));

  rblapack_ret = rb_yield_values(2, rblapack_arg0, rblapack_arg1);

  ret = (rblapack_ret == Qtrue);
  return ret;
}

extern VOID dgees_(char* jobvs, char* sort, L_fp select, integer* n, doublereal* a, integer* lda, integer* sdim, doublereal* wr, doublereal* wi, doublereal* vs, integer* ldvs, doublereal* work, integer* lwork, logical* bwork, integer* info);


static VALUE
rblapack_dgees(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvs;
  char jobvs; 
  VALUE rblapack_sort;
  char sort; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_sdim;
  integer sdim; 
  VALUE rblapack_wr;
  doublereal *wr; 
  VALUE rblapack_wi;
  doublereal *wi; 
  VALUE rblapack_vs;
  doublereal *vs; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  logical *bwork;

  integer lda;
  integer n;
  integer ldvs;

  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  sdim, wr, wi, vs, work, info, a = NumRu::Lapack.dgees( jobvs, sort, a, [:lwork => lwork, :usage => usage, :help => help]){|a,b| ... }\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, VS, LDVS, WORK, LWORK, BWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGEES computes for an N-by-N real nonsymmetric matrix A, the\n*  eigenvalues, the real Schur form T, and, optionally, the matrix of\n*  Schur vectors Z.  This gives the Schur factorization A = Z*T*(Z**T).\n*\n*  Optionally, it also orders the eigenvalues on the diagonal of the\n*  real Schur form so that selected eigenvalues are at the top left.\n*  The leading columns of Z then form an orthonormal basis for the\n*  invariant subspace corresponding to the selected eigenvalues.\n*\n*  A matrix is in real Schur form if it is upper quasi-triangular with\n*  1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the\n*  form\n*          [  a  b  ]\n*          [  c  a  ]\n*\n*  where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVS   (input) CHARACTER*1\n*          = 'N': Schur vectors are not computed;\n*          = 'V': Schur vectors are computed.\n*\n*  SORT    (input) CHARACTER*1\n*          Specifies whether or not to order the eigenvalues on the\n*          diagonal of the Schur form.\n*          = 'N': Eigenvalues are not ordered;\n*          = 'S': Eigenvalues are ordered (see SELECT).\n*\n*  SELECT  (external procedure) LOGICAL FUNCTION of two DOUBLE PRECISION arguments\n*          SELECT must be declared EXTERNAL in the calling subroutine.\n*          If SORT = 'S', SELECT is used to select eigenvalues to sort\n*          to the top left of the Schur form.\n*          If SORT = 'N', SELECT is not referenced.\n*          An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if\n*          SELECT(WR(j),WI(j)) is true; i.e., if either one of a complex\n*          conjugate pair of eigenvalues is selected, then both complex\n*          eigenvalues are selected.\n*          Note that a selected complex eigenvalue may no longer\n*          satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since\n*          ordering may change the value of complex eigenvalues\n*          (especially if the eigenvalue is ill-conditioned); in this\n*          case INFO is set to N+2 (see INFO below).\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the N-by-N matrix A.\n*          On exit, A has been overwritten by its real Schur form T.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  SDIM    (output) INTEGER\n*          If SORT = 'N', SDIM = 0.\n*          If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n*                         for which SELECT is true. (Complex conjugate\n*                         pairs for which SELECT is true for either\n*                         eigenvalue count as 2.)\n*\n*  WR      (output) DOUBLE PRECISION array, dimension (N)\n*  WI      (output) DOUBLE PRECISION array, dimension (N)\n*          WR and WI contain the real and imaginary parts,\n*          respectively, of the computed eigenvalues in the same order\n*          that they appear on the diagonal of the output Schur form T.\n*          Complex conjugate pairs of eigenvalues will appear\n*          consecutively with the eigenvalue having the positive\n*          imaginary part first.\n*\n*  VS      (output) DOUBLE PRECISION array, dimension (LDVS,N)\n*          If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur\n*          vectors.\n*          If JOBVS = 'N', VS is not referenced.\n*\n*  LDVS    (input) INTEGER\n*          The leading dimension of the array VS.  LDVS >= 1; if\n*          JOBVS = 'V', LDVS >= N.\n*\n*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) contains the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK.  LWORK >= max(1,3*N).\n*          For good performance, LWORK must generally be larger.\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*  BWORK   (workspace) LOGICAL array, dimension (N)\n*          Not referenced if SORT = 'N'.\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, and i is\n*             <= N: the QR algorithm failed to compute all the\n*                   eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI\n*                   contain those eigenvalues which have converged; if\n*                   JOBVS = 'V', VS contains the matrix which reduces A\n*                   to its partially converged Schur form.\n*             = N+1: the eigenvalues could not be reordered because some\n*                   eigenvalues were too close to separate (the problem\n*                   is very ill-conditioned);\n*             = N+2: after reordering, roundoff changed values of some\n*                   complex eigenvalues so that leading eigenvalues in\n*                   the Schur form no longer satisfy SELECT=.TRUE.  This\n*                   could also be caused by underflow due to scaling.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sdim, wr, wi, vs, work, info, a = NumRu::Lapack.dgees( jobvs, sort, a, [:lwork => lwork, :usage => usage, :help => help]){|a,b| ... }\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_jobvs = argv[0];
  rblapack_sort = argv[1];
  rblapack_a = 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;
  }

  jobvs = StringValueCStr(rblapack_jobvs)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  ldvs = lsame_(&jobvs,"V") ? n : 1;
  sort = StringValueCStr(rblapack_sort)[0];
  if (rblapack_lwork == Qnil)
    lwork = 3*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  wr = NA_PTR_TYPE(rblapack_wr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  wi = NA_PTR_TYPE(rblapack_wi, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldvs;
    shape[1] = n;
    rblapack_vs = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vs = NA_PTR_TYPE(rblapack_vs, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;
  bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));

  dgees_(&jobvs, &sort, rblapack_select, &n, a, &lda, &sdim, wr, wi, vs, &ldvs, work, &lwork, bwork, &info);

  free(bwork);
  rblapack_sdim = INT2NUM(sdim);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_sdim, rblapack_wr, rblapack_wi, rblapack_vs, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_dgees(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgees", rblapack_dgees, -1);
}
ruby-lapack-1.7.2/ext/cposvxx.c0000644000175000017500000006237512502221022016246 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cposvxx_(char* fact, char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, char* equed, real* s, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* rpvgrw, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cposvxx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_params;
  real *params; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_rpvgrw;
  real rpvgrw; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_err_bnds_norm;
  real *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  real *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_af_out__;
  complex *af_out__;
  VALUE rblapack_s_out__;
  real *s_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;
  VALUE rblapack_params_out__;
  real *params_out__;
  complex *work;
  real *rwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer nparams;
  integer ldx;
  integer n_err_bnds;

  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  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, equed, s, b, params = NumRu::Lapack.cposvxx( fact, uplo, a, af, equed, s, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     CPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T\n*     to compute the solution to a complex system of linear equations\n*     A * X = B, where A is an N-by-N symmetric positive definite matrix\n*     and X and B are N-by-NRHS matrices.\n*\n*     If requested, both normwise and maximum componentwise error bounds\n*     are returned. CPOSVXX will return a solution with a tiny\n*     guaranteed error (O(eps) where eps is the working machine\n*     precision) unless the matrix is very ill-conditioned, in which\n*     case a warning is returned. Relevant condition numbers also are\n*     calculated and returned.\n*\n*     CPOSVXX accepts user-provided factorizations and equilibration\n*     factors; see the definitions of the FACT and EQUED options.\n*     Solving with refinement and using a factorization from a previous\n*     CPOSVXX call will also produce a solution with either O(eps)\n*     errors or warnings, but we cannot make that claim for general\n*     user-provided factorizations and equilibration factors if they\n*     differ from what CPOSVXX would itself produce.\n*\n*     Description\n*     ===========\n*\n*     The following steps are performed:\n*\n*     1. If FACT = 'E', real scaling factors are computed to equilibrate\n*     the system:\n*\n*       diag(S)*A*diag(S)     *inv(diag(S))*X = diag(S)*B\n*\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n*     2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n*     factor the matrix A (after equilibration if FACT = 'E') as\n*        A = U**T* U,  if UPLO = 'U', or\n*        A = L * L**T,  if UPLO = 'L',\n*     where U is an upper triangular matrix and L is a lower triangular\n*     matrix.\n*\n*     3. If the leading i-by-i principal minor is not positive definite,\n*     then the routine returns with INFO = i. Otherwise, the factored\n*     form of A is used to estimate the condition number of the matrix\n*     A (see argument RCOND).  If the reciprocal of the condition number\n*     is less than machine precision, the routine still goes on to solve\n*     for X and compute error bounds as described below.\n*\n*     4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*     5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n*     the routine will use iterative refinement to try to get a small\n*     error and error bounds.  Refinement calculates the residual to at\n*     least twice the working precision.\n*\n*     6. If equilibration was used, the matrix X is premultiplied by\n*     diag(S) so that it solves the original system before\n*     equilibration.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     FACT    (input) CHARACTER*1\n*     Specifies whether or not the factored form of the matrix A is\n*     supplied on entry, and if not, whether the matrix A should be\n*     equilibrated before it is factored.\n*       = 'F':  On entry, AF contains the factored form of A.\n*               If EQUED is not 'N', the matrix A has been\n*               equilibrated with scaling factors given by S.\n*               A and AF are not modified.\n*       = 'N':  The matrix A will be copied to AF and factored.\n*       = 'E':  The matrix A will be equilibrated if necessary, then\n*               copied to AF and factored.\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     A       (input/output) COMPLEX array, dimension (LDA,N)\n*     On entry, the symmetric matrix A, except if FACT = 'F' and EQUED =\n*     'Y', then A must contain the equilibrated matrix\n*     diag(S)*A*diag(S).  If UPLO = 'U', the leading N-by-N upper\n*     triangular part of A contains the upper triangular part of the\n*     matrix A, and the strictly lower triangular part of A is not\n*     referenced.  If UPLO = 'L', the leading N-by-N lower triangular\n*     part of A contains the lower triangular part of the matrix A, and\n*     the strictly upper triangular part of A is not referenced.  A is\n*     not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED =\n*     'N' on exit.\n*\n*     On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n*     diag(S)*A*diag(S).\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input or output) COMPLEX array, dimension (LDAF,N)\n*     If FACT = 'F', then AF is an input argument and on entry\n*     contains the triangular factor U or L from the Cholesky\n*     factorization A = U**T*U or A = L*L**T, in the same storage\n*     format as A.  If EQUED .ne. 'N', then AF is the factored\n*     form of the equilibrated matrix diag(S)*A*diag(S).\n*\n*     If FACT = 'N', then AF is an output argument and on exit\n*     returns the triangular factor U or L from the Cholesky\n*     factorization A = U**T*U or A = L*L**T of the original\n*     matrix A.\n*\n*     If FACT = 'E', then AF is an output argument and on exit\n*     returns the triangular factor U or L from the Cholesky\n*     factorization A = U**T*U or A = L*L**T of the equilibrated\n*     matrix A (see the description of A for the form of the\n*     equilibrated matrix).\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     EQUED   (input or output) CHARACTER*1\n*     Specifies the form of equilibration that was done.\n*       = 'N':  No equilibration (always true if FACT = 'N').\n*       = 'Y':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(S) * A * diag(S).\n*     EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*     output argument.\n*\n*     S       (input or output) REAL array, dimension (N)\n*     The row scale factors for A.  If EQUED = 'Y', A is multiplied on\n*     the left and right by diag(S).  S is an input argument if FACT =\n*     'F'; otherwise, S is an output argument.  If FACT = 'F' and EQUED\n*     = 'Y', each element of S must be positive.  If S is output, each\n*     element of S is a power of the radix. If S is input, each element\n*     of S should be a power of the radix to ensure a reliable solution\n*     and error estimates. Scaling by powers of the radix does not cause\n*     rounding errors unless the result underflows or overflows.\n*     Rounding errors during scaling lead to refining with a matrix that\n*     is not equivalent to the input matrix, producing error estimates\n*     that may not be reliable.\n*\n*     B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*     On entry, the N-by-NRHS right hand side matrix B.\n*     On exit,\n*     if EQUED = 'N', B is not modified;\n*     if EQUED = 'Y', B is overwritten by diag(S)*B;\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (output) COMPLEX array, dimension (LDX,NRHS)\n*     If INFO = 0, the N-by-NRHS solution matrix X to the original\n*     system of equations.  Note that A and B are modified on exit if\n*     EQUED .ne. 'N', and the solution to the equilibrated system is\n*     inv(diag(S))*X.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) REAL\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     RPVGRW  (output) REAL\n*     Reciprocal pivot growth.  On exit, this contains the reciprocal\n*     pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n*     norm is used.  If this is much less than 1, then the stability of\n*     the LU factorization of the (equilibrated) matrix A could be poor.\n*     This also means that the solution X, estimated condition numbers,\n*     and error bounds could be unreliable. If factorization fails with\n*     0 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, equed, s, b, params = NumRu::Lapack.cposvxx( fact, uplo, a, af, equed, s, b, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_equed = argv[4];
  rblapack_s = argv[5];
  rblapack_b = argv[6];
  rblapack_params = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  n_err_bnds = 3;
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (6th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  ldx = MAX(1,n);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (8th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (8th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_SFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
  params = NA_PTR_TYPE(rblapack_params, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldaf;
    shape[1] = n;
    rblapack_af_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  af_out__ = NA_PTR_TYPE(rblapack_af_out__, complex*);
  MEMCPY(af_out__, af, complex, NA_TOTAL(rblapack_af));
  rblapack_af = rblapack_af_out__;
  af = af_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
  MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
  MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (2*n));

  cposvxx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &equed, s, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_rpvgrw = rb_float_new((double)rpvgrw);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(13, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_a, rblapack_af, rblapack_equed, rblapack_s, rblapack_b, rblapack_params);
}

void
init_lapack_cposvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cposvxx", rblapack_cposvxx, -1);
}
ruby-lapack-1.7.2/ext/dbdsdc.c0000644000175000017500000002444112502221016015752 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dbdsdc_(char* uplo, char* compq, integer* n, doublereal* d, doublereal* e, doublereal* u, integer* ldu, doublereal* vt, integer* ldvt, doublereal* q, integer* iq, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dbdsdc(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_compq;
  char compq; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_u;
  doublereal *u; 
  VALUE rblapack_vt;
  doublereal *vt; 
  VALUE rblapack_q;
  doublereal *q; 
  VALUE rblapack_iq;
  integer *iq; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_e_out__;
  doublereal *e_out__;
  integer c__0;
  integer c__9;
  real smlsiz;
  doublereal *work;
  integer *iwork;

  integer n;
  integer ldvt;
  integer ldu;

  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  u, vt, q, iq, info, d, e = NumRu::Lapack.dbdsdc( uplo, compq, d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DBDSDC computes the singular value decomposition (SVD) of a real\n*  N-by-N (upper or lower) bidiagonal matrix B:  B = U * S * VT,\n*  using a divide and conquer method, where S is a diagonal matrix\n*  with non-negative diagonal elements (the singular values of B), and\n*  U and VT are orthogonal matrices of left and right singular vectors,\n*  respectively. DBDSDC can be used to compute all singular values,\n*  and optionally, singular vectors or singular vectors in compact form.\n*\n*  This code makes very mild assumptions about floating point\n*  arithmetic. It will work on machines with a guard digit in\n*  add/subtract, or on those binary machines without guard digits\n*  which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n*  It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.  See DLASD3 for details.\n*\n*  The code currently calls DLASDQ if singular values only are desired.\n*  However, it can be slightly modified to compute singular values\n*  using the divide and conquer method.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  B is upper bidiagonal.\n*          = 'L':  B is lower bidiagonal.\n*\n*  COMPQ   (input) CHARACTER*1\n*          Specifies whether singular vectors are to be computed\n*          as follows:\n*          = 'N':  Compute singular values only;\n*          = 'P':  Compute singular values and compute singular\n*                  vectors in compact form;\n*          = 'I':  Compute singular values and singular vectors.\n*\n*  N       (input) INTEGER\n*          The order of the matrix B.  N >= 0.\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the n diagonal elements of the bidiagonal matrix B.\n*          On exit, if INFO=0, the singular values of B.\n*\n*  E       (input/output) DOUBLE PRECISION array, dimension (N-1)\n*          On entry, the elements of E contain the offdiagonal\n*          elements of the bidiagonal matrix whose SVD is desired.\n*          On exit, E has been destroyed.\n*\n*  U       (output) DOUBLE PRECISION array, dimension (LDU,N)\n*          If  COMPQ = 'I', then:\n*             On exit, if INFO = 0, U contains the left singular vectors\n*             of the bidiagonal matrix.\n*          For other values of COMPQ, U is not referenced.\n*\n*  LDU     (input) INTEGER\n*          The leading dimension of the array U.  LDU >= 1.\n*          If singular vectors are desired, then LDU >= max( 1, N ).\n*\n*  VT      (output) DOUBLE PRECISION array, dimension (LDVT,N)\n*          If  COMPQ = 'I', then:\n*             On exit, if INFO = 0, VT' contains the right singular\n*             vectors of the bidiagonal matrix.\n*          For other values of COMPQ, VT is not referenced.\n*\n*  LDVT    (input) INTEGER\n*          The leading dimension of the array VT.  LDVT >= 1.\n*          If singular vectors are desired, then LDVT >= max( 1, N ).\n*\n*  Q       (output) DOUBLE PRECISION array, dimension (LDQ)\n*          If  COMPQ = 'P', then:\n*             On exit, if INFO = 0, Q and IQ contain the left\n*             and right singular vectors in a compact form,\n*             requiring O(N log N) space instead of 2*N**2.\n*             In particular, Q contains all the DOUBLE PRECISION data in\n*             LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))\n*             words of memory, where SMLSIZ is returned by ILAENV and\n*             is equal to the maximum size of the subproblems at the\n*             bottom of the computation tree (usually about 25).\n*          For other values of COMPQ, Q is not referenced.\n*\n*  IQ      (output) INTEGER array, dimension (LDIQ)\n*          If  COMPQ = 'P', then:\n*             On exit, if INFO = 0, Q and IQ contain the left\n*             and right singular vectors in a compact form,\n*             requiring O(N log N) space instead of 2*N**2.\n*             In particular, IQ contains all INTEGER data in\n*             LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))\n*             words of memory, where SMLSIZ is returned by ILAENV and\n*             is equal to the maximum size of the subproblems at the\n*             bottom of the computation tree (usually about 25).\n*          For other values of COMPQ, IQ is not referenced.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n*          If COMPQ = 'N' then LWORK >= (4 * N).\n*          If COMPQ = 'P' then LWORK >= (6 * N).\n*          If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N).\n*\n*  IWORK   (workspace) INTEGER array, dimension (8*N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit.\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          > 0:  The algorithm failed to compute a singular value.\n*                The update process of divide and conquer failed.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*  Changed dimension statement in comment describing E from (N) to\n*  (N-1).  Sven, 17 Feb 05.\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  u, vt, q, iq, info, d, e = NumRu::Lapack.dbdsdc( uplo, compq, d, e, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_compq = argv[1];
  rblapack_d = argv[2];
  rblapack_e = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  c__0 = 0;
  compq = StringValueCStr(rblapack_compq)[0];
  c__9 = 9;
  ldu = lsame_(&compq,"I") ? MAX(1,n) : 0;
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (4th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  smlsiz = ilaenv_(&c__9, "DBDSDC", " ", &c__0, &c__0, &c__0, &c__0);
  ldvt = lsame_(&compq,"I") ? MAX(1,n) : 0;
  {
    na_shape_t shape[2];
    shape[0] = lsame_(&compq,"I") ? ldu : 0;
    shape[1] = lsame_(&compq,"I") ? n : 0;
    rblapack_u = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  u = NA_PTR_TYPE(rblapack_u, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = lsame_(&compq,"I") ? ldvt : 0;
    shape[1] = lsame_(&compq,"I") ? n : 0;
    rblapack_vt = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vt = NA_PTR_TYPE(rblapack_vt, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = lsame_(&compq,"I") ? (lsame_(&compq,"P") ? n*(11+2*smlsiz+8*(int)(log(((double)n)/(smlsiz+1))/log(2.0))) : 0) : 0;
    rblapack_q = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  q = NA_PTR_TYPE(rblapack_q, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = lsame_(&compq,"I") ? (lsame_(&compq,"P") ? n*(3+3*(int)(log(((double)n)/(smlsiz+1))/log(2.0))) : 0) : 0;
    rblapack_iq = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iq = NA_PTR_TYPE(rblapack_iq, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
  MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  work = ALLOC_N(doublereal, (MAX(1,lsame_(&compq,"N") ? 4*n : lsame_(&compq,"P") ? 6*n : lsame_(&compq,"I") ? 3*n*n+4*n : 0)));
  iwork = ALLOC_N(integer, (8*n));

  dbdsdc_(&uplo, &compq, &n, d, e, u, &ldu, vt, &ldvt, q, iq, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_u, rblapack_vt, rblapack_q, rblapack_iq, rblapack_info, rblapack_d, rblapack_e);
}

void
init_lapack_dbdsdc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dbdsdc", rblapack_dbdsdc, -1);
}
ruby-lapack-1.7.2/ext/shseqr.c0000644000175000017500000003564512502221023016042 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID shseqr_(char* job, char* compz, integer* n, integer* ilo, integer* ihi, real* h, integer* ldh, real* wr, real* wi, real* z, integer* ldz, real* work, integer* lwork, integer* info);


static VALUE
rblapack_shseqr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_compz;
  char compz; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_h;
  real *h; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_ldz;
  integer ldz; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_wr;
  real *wr; 
  VALUE rblapack_wi;
  real *wi; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_h_out__;
  real *h_out__;
  VALUE rblapack_z_out__;
  real *z_out__;

  integer ldh;
  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  wr, wi, work, info, h, z = NumRu::Lapack.shseqr( job, compz, ilo, ihi, h, z, ldz, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, LDZ, WORK, LWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     SHSEQR computes the eigenvalues of a Hessenberg matrix H\n*     and, optionally, the matrices T and Z from the Schur decomposition\n*     H = Z T Z**T, where T is an upper quasi-triangular matrix (the\n*     Schur form), and Z is the orthogonal matrix of Schur vectors.\n*\n*     Optionally Z may be postmultiplied into an input orthogonal\n*     matrix Q so that this routine can give the Schur factorization\n*     of a matrix A which has been reduced to the Hessenberg form H\n*     by the orthogonal matrix Q:  A = Q*H*Q**T = (QZ)*T*(QZ)**T.\n*\n\n*     Arguments\n*     =========\n*\n*     JOB   (input) CHARACTER*1\n*           = 'E':  compute eigenvalues only;\n*           = 'S':  compute eigenvalues and the Schur form T.\n*\n*     COMPZ (input) CHARACTER*1\n*           = 'N':  no Schur vectors are computed;\n*           = 'I':  Z is initialized to the unit matrix and the matrix Z\n*                   of Schur vectors of H is returned;\n*           = 'V':  Z must contain an orthogonal matrix Q on entry, and\n*                   the product Q*Z is returned.\n*\n*     N     (input) INTEGER\n*           The order of the matrix H.  N .GE. 0.\n*\n*     ILO   (input) INTEGER\n*     IHI   (input) INTEGER\n*           It is assumed that H is already upper triangular in rows\n*           and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n*           set by a previous call to SGEBAL, and then passed to SGEHRD\n*           when the matrix output by SGEBAL is reduced to Hessenberg\n*           form. Otherwise ILO and IHI should be set to 1 and N\n*           respectively.  If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.\n*           If N = 0, then ILO = 1 and IHI = 0.\n*\n*     H     (input/output) REAL array, dimension (LDH,N)\n*           On entry, the upper Hessenberg matrix H.\n*           On exit, if INFO = 0 and JOB = 'S', then H contains the\n*           upper quasi-triangular matrix T from the Schur decomposition\n*           (the Schur form); 2-by-2 diagonal blocks (corresponding to\n*           complex conjugate pairs of eigenvalues) are returned in\n*           standard form, with H(i,i) = H(i+1,i+1) and\n*           H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and JOB = 'E', the\n*           contents of H are unspecified on exit.  (The output value of\n*           H when INFO.GT.0 is given under the description of INFO\n*           below.)\n*\n*           Unlike earlier versions of SHSEQR, this subroutine may\n*           explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1\n*           or j = IHI+1, IHI+2, ... N.\n*\n*     LDH   (input) INTEGER\n*           The leading dimension of the array H. LDH .GE. max(1,N).\n*\n*     WR    (output) REAL array, dimension (N)\n*     WI    (output) REAL array, dimension (N)\n*           The real and imaginary parts, respectively, of the computed\n*           eigenvalues. If two eigenvalues are computed as a complex\n*           conjugate pair, they are stored in consecutive elements of\n*           WR and WI, say the i-th and (i+1)th, with WI(i) .GT. 0 and\n*           WI(i+1) .LT. 0. If JOB = 'S', the eigenvalues are stored in\n*           the same order as on the diagonal of the Schur form returned\n*           in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2\n*           diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and\n*           WI(i+1) = -WI(i).\n*\n*     Z     (input/output) REAL array, dimension (LDZ,N)\n*           If COMPZ = 'N', Z is not referenced.\n*           If COMPZ = 'I', on entry Z need not be set and on exit,\n*           if INFO = 0, Z contains the orthogonal matrix Z of the Schur\n*           vectors of H.  If COMPZ = 'V', on entry Z must contain an\n*           N-by-N matrix Q, which is assumed to be equal to the unit\n*           matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,\n*           if INFO = 0, Z contains Q*Z.\n*           Normally Q is the orthogonal matrix generated by SORGHR\n*           after the call to SGEHRD which formed the Hessenberg matrix\n*           H. (The output value of Z when INFO.GT.0 is given under\n*           the description of INFO below.)\n*\n*     LDZ   (input) INTEGER\n*           The leading dimension of the array Z.  if COMPZ = 'I' or\n*           COMPZ = 'V', then LDZ.GE.MAX(1,N).  Otherwize, LDZ.GE.1.\n*\n*     WORK  (workspace/output) REAL array, dimension (LWORK)\n*           On exit, if INFO = 0, WORK(1) returns an estimate of\n*           the optimal value for LWORK.\n*\n*     LWORK (input) INTEGER\n*           The dimension of the array WORK.  LWORK .GE. max(1,N)\n*           is sufficient and delivers very good and sometimes\n*           optimal performance.  However, LWORK as large as 11*N\n*           may be required for optimal performance.  A workspace\n*           query is recommended to determine the optimal workspace\n*           size.\n*\n*           If LWORK = -1, then SHSEQR does a workspace query.\n*           In this case, SHSEQR checks the input parameters and\n*           estimates the optimal workspace size for the given\n*           values of N, ILO and IHI.  The estimate is returned\n*           in WORK(1).  No error message related to LWORK is\n*           issued by XERBLA.  Neither H nor Z are accessed.\n*\n*\n*     INFO  (output) INTEGER\n*             =  0:  successful exit\n*           .LT. 0:  if INFO = -i, the i-th argument had an illegal\n*                    value\n*           .GT. 0:  if INFO = i, SHSEQR failed to compute all of\n*                the eigenvalues.  Elements 1:ilo-1 and i+1:n of WR\n*                and WI contain those eigenvalues which have been\n*                successfully computed.  (Failures are rare.)\n*\n*                If INFO .GT. 0 and JOB = 'E', then on exit, the\n*                remaining unconverged eigenvalues are the eigen-\n*                values of the upper Hessenberg matrix rows and\n*                columns ILO through INFO of the final, output\n*                value of H.\n*\n*                If INFO .GT. 0 and JOB   = 'S', then on exit\n*\n*           (*)  (initial value of H)*U  = U*(final value of H)\n*\n*                where U is an orthogonal matrix.  The final\n*                value of H is upper Hessenberg and quasi-triangular\n*                in rows and columns INFO+1 through IHI.\n*\n*                If INFO .GT. 0 and COMPZ = 'V', then on exit\n*\n*                  (final value of Z)  =  (initial value of Z)*U\n*\n*                where U is the orthogonal matrix in (*) (regard-\n*                less of the value of JOB.)\n*\n*                If INFO .GT. 0 and COMPZ = 'I', then on exit\n*                      (final value of Z)  = U\n*                where U is the orthogonal matrix in (*) (regard-\n*                less of the value of JOB.)\n*\n*                If INFO .GT. 0 and COMPZ = 'N', then Z is not\n*                accessed.\n*\n\n*     ================================================================\n*             Default values supplied by\n*             ILAENV(ISPEC,'SHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).\n*             It is suggested that these defaults be adjusted in order\n*             to attain best performance in each particular\n*             computational environment.\n*\n*            ISPEC=12: The SLAHQR vs SLAQR0 crossover point.\n*                      Default: 75. (Must be at least 11.)\n*\n*            ISPEC=13: Recommended deflation window size.\n*                      This depends on ILO, IHI and NS.  NS is the\n*                      number of simultaneous shifts returned\n*                      by ILAENV(ISPEC=15).  (See ISPEC=15 below.)\n*                      The default for (IHI-ILO+1).LE.500 is NS.\n*                      The default for (IHI-ILO+1).GT.500 is 3*NS/2.\n*\n*            ISPEC=14: Nibble crossover point. (See IPARMQ for\n*                      details.)  Default: 14% of deflation window\n*                      size.\n*\n*            ISPEC=15: Number of simultaneous shifts in a multishift\n*                      QR iteration.\n*\n*                      If IHI-ILO+1 is ...\n*\n*                      greater than      ...but less    ... the\n*                      or equal to ...      than        default is\n*\n*                           1               30          NS =   2(+)\n*                          30               60          NS =   4(+)\n*                          60              150          NS =  10(+)\n*                         150              590          NS =  **\n*                         590             3000          NS =  64\n*                        3000             6000          NS = 128\n*                        6000             infinity      NS = 256\n*\n*                  (+)  By default some or all matrices of this order\n*                       are passed to the implicit double shift routine\n*                       SLAHQR and this parameter is ignored.  See\n*                       ISPEC=12 above and comments in IPARMQ for\n*                       details.\n*\n*                 (**)  The asterisks (**) indicate an ad-hoc\n*                       function of N increasing from 10 to 64.\n*\n*            ISPEC=16: Select structured matrix multiply.\n*                      If the number of simultaneous shifts (specified\n*                      by ISPEC=15) is less than 14, then the default\n*                      for ISPEC=16 is 0.  Otherwise the default for\n*                      ISPEC=16 is 2.\n*\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n*     References:\n*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n*       Algorithm Part I: Maintaining Well Focused Shifts, and Level 3\n*       Performance, SIAM Journal of Matrix Analysis, volume 23, pages\n*       929--947, 2002.\n*\n*       K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n*       Algorithm Part II: Aggressive Early Deflation, SIAM Journal\n*       of Matrix Analysis, volume 23, pages 948--973, 2002.\n*\n*     ================================================================\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  wr, wi, work, info, h, z = NumRu::Lapack.shseqr( job, compz, ilo, ihi, h, z, ldz, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_job = argv[0];
  rblapack_compz = argv[1];
  rblapack_ilo = argv[2];
  rblapack_ihi = argv[3];
  rblapack_h = argv[4];
  rblapack_z = argv[5];
  rblapack_ldz = argv[6];
  if (argc == 8) {
    rblapack_lwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  job = StringValueCStr(rblapack_job)[0];
  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (5th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_SFLOAT)
    rblapack_h = na_change_type(rblapack_h, NA_SFLOAT);
  h = NA_PTR_TYPE(rblapack_h, real*);
  ldz = NUM2INT(rblapack_ldz);
  compz = StringValueCStr(rblapack_compz)[0];
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (6th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (6th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_z) != (lsame_(&compz,"N") ? 0 : ldz))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", lsame_(&compz,"N") ? 0 : ldz);
  if (NA_SHAPE1(rblapack_z) != (lsame_(&compz,"N") ? 0 : n))
    rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", lsame_(&compz,"N") ? 0 : n);
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  ihi = NUM2INT(rblapack_ihi);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  wr = NA_PTR_TYPE(rblapack_wr, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  wi = NA_PTR_TYPE(rblapack_wi, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, real*);
  MEMCPY(h_out__, h, real, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = lsame_(&compz,"N") ? 0 : ldz;
    shape[1] = lsame_(&compz,"N") ? 0 : n;
    rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
  MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  shseqr_(&job, &compz, &n, &ilo, &ihi, h, &ldh, wr, wi, z, &ldz, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_wr, rblapack_wi, rblapack_work, rblapack_info, rblapack_h, rblapack_z);
}

void
init_lapack_shseqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "shseqr", rblapack_shseqr, -1);
}
ruby-lapack-1.7.2/ext/zgtsv.c0000644000175000017500000001547412502221023015710 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgtsv_(integer* n, integer* nrhs, doublecomplex* dl, doublecomplex* d, doublecomplex* du, doublecomplex* b, integer* ldb, integer* info);


static VALUE
rblapack_zgtsv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_dl;
  doublecomplex *dl; 
  VALUE rblapack_d;
  doublecomplex *d; 
  VALUE rblapack_du;
  doublecomplex *du; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_dl_out__;
  doublecomplex *dl_out__;
  VALUE rblapack_d_out__;
  doublecomplex *d_out__;
  VALUE rblapack_du_out__;
  doublecomplex *du_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer n;
  integer ldb;
  integer nrhs;

  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  info, dl, d, du, b = NumRu::Lapack.zgtsv( dl, d, du, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGTSV  solves the equation\n*\n*     A*X = B,\n*\n*  where A is an N-by-N tridiagonal matrix, by Gaussian elimination with\n*  partial pivoting.\n*\n*  Note that the equation  A'*X = B  may be solved by interchanging the\n*  order of the arguments DU and DL.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  DL      (input/output) COMPLEX*16 array, dimension (N-1)\n*          On entry, DL must contain the (n-1) subdiagonal elements of\n*          A.\n*          On exit, DL is overwritten by the (n-2) elements of the\n*          second superdiagonal of the upper triangular matrix U from\n*          the LU factorization of A, in DL(1), ..., DL(n-2).\n*\n*  D       (input/output) COMPLEX*16 array, dimension (N)\n*          On entry, D must contain the diagonal elements of A.\n*          On exit, D is overwritten by the n diagonal elements of U.\n*\n*  DU      (input/output) COMPLEX*16 array, dimension (N-1)\n*          On entry, DU must contain the (n-1) superdiagonal elements\n*          of A.\n*          On exit, DU is overwritten by the (n-1) elements of the first\n*          superdiagonal of U.\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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, U(i,i) is exactly zero, and the solution\n*                has not been computed.  The factorization has not been\n*                completed unless i = N.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, dl, d, du, b = NumRu::Lapack.zgtsv( dl, d, du, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_dl = argv[0];
  rblapack_d = argv[1];
  rblapack_du = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DCOMPLEX)
    rblapack_d = na_change_type(rblapack_d, NA_DCOMPLEX);
  d = NA_PTR_TYPE(rblapack_d, doublecomplex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (1th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (1th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_DCOMPLEX)
    rblapack_dl = na_change_type(rblapack_dl, NA_DCOMPLEX);
  dl = NA_PTR_TYPE(rblapack_dl, doublecomplex*);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (3th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_DCOMPLEX)
    rblapack_du = na_change_type(rblapack_du, NA_DCOMPLEX);
  du = NA_PTR_TYPE(rblapack_du, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_dl_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  dl_out__ = NA_PTR_TYPE(rblapack_dl_out__, doublecomplex*);
  MEMCPY(dl_out__, dl, doublecomplex, NA_TOTAL(rblapack_dl));
  rblapack_dl = rblapack_dl_out__;
  dl = dl_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublecomplex*);
  MEMCPY(d_out__, d, doublecomplex, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_du_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  du_out__ = NA_PTR_TYPE(rblapack_du_out__, doublecomplex*);
  MEMCPY(du_out__, du, doublecomplex, NA_TOTAL(rblapack_du));
  rblapack_du = rblapack_du_out__;
  du = du_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zgtsv_(&n, &nrhs, dl, d, du, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_info, rblapack_dl, rblapack_d, rblapack_du, rblapack_b);
}

void
init_lapack_zgtsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgtsv", rblapack_zgtsv, -1);
}
ruby-lapack-1.7.2/ext/sgesvd.c0000644000175000017500000002310712502221016016020 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgesvd_(char* jobu, char* jobvt, integer* m, integer* n, real* a, integer* lda, real* s, real* u, integer* ldu, real* vt, integer* ldvt, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sgesvd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobu;
  char jobu; 
  VALUE rblapack_jobvt;
  char jobvt; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_u;
  real *u; 
  VALUE rblapack_vt;
  real *vt; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;

  integer lda;
  integer n;
  integer ldu;
  integer ldvt;
  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  s, u, vt, work, info, a = NumRu::Lapack.sgesvd( jobu, jobvt, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGESVD computes the singular value decomposition (SVD) of a real\n*  M-by-N matrix A, optionally computing the left and/or right singular\n*  vectors. The SVD is written\n*\n*       A = U * SIGMA * transpose(V)\n*\n*  where SIGMA is an M-by-N matrix which is zero except for its\n*  min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and\n*  V is an N-by-N orthogonal matrix.  The diagonal elements of SIGMA\n*  are the singular values of A; they are real and non-negative, and\n*  are returned in descending order.  The first min(m,n) columns of\n*  U and V are the left and right singular vectors of A.\n*\n*  Note that the routine returns V**T, not V.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBU    (input) CHARACTER*1\n*          Specifies options for computing all or part of the matrix U:\n*          = 'A':  all M columns of U are returned in array U:\n*          = 'S':  the first min(m,n) columns of U (the left singular\n*                  vectors) are returned in the array U;\n*          = 'O':  the first min(m,n) columns of U (the left singular\n*                  vectors) are overwritten on the array A;\n*          = 'N':  no columns of U (no left singular vectors) are\n*                  computed.\n*\n*  JOBVT   (input) CHARACTER*1\n*          Specifies options for computing all or part of the matrix\n*          V**T:\n*          = 'A':  all N rows of V**T are returned in the array VT;\n*          = 'S':  the first min(m,n) rows of V**T (the right singular\n*                  vectors) are returned in the array VT;\n*          = 'O':  the first min(m,n) rows of V**T (the right singular\n*                  vectors) are overwritten on the array A;\n*          = 'N':  no rows of V**T (no right singular vectors) are\n*                  computed.\n*\n*          JOBVT and JOBU cannot both be 'O'.\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.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit,\n*          if JOBU = 'O',  A is overwritten with the first min(m,n)\n*                          columns of U (the left singular vectors,\n*                          stored columnwise);\n*          if JOBVT = 'O', A is overwritten with the first min(m,n)\n*                          rows of V**T (the right singular vectors,\n*                          stored rowwise);\n*          if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A\n*                          are destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  S       (output) REAL array, dimension (min(M,N))\n*          The singular values of A, sorted so that S(i) >= S(i+1).\n*\n*  U       (output) REAL array, dimension (LDU,UCOL)\n*          (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.\n*          If JOBU = 'A', U contains the M-by-M orthogonal matrix U;\n*          if JOBU = 'S', U contains the first min(m,n) columns of U\n*          (the left singular vectors, stored columnwise);\n*          if JOBU = 'N' or 'O', U is not referenced.\n*\n*  LDU     (input) INTEGER\n*          The leading dimension of the array U.  LDU >= 1; if\n*          JOBU = 'S' or 'A', LDU >= M.\n*\n*  VT      (output) REAL array, dimension (LDVT,N)\n*          If JOBVT = 'A', VT contains the N-by-N orthogonal matrix\n*          V**T;\n*          if JOBVT = 'S', VT contains the first min(m,n) rows of\n*          V**T (the right singular vectors, stored rowwise);\n*          if JOBVT = 'N' or 'O', VT is not referenced.\n*\n*  LDVT    (input) INTEGER\n*          The leading dimension of the array VT.  LDVT >= 1; if\n*          JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).\n*\n*  WORK    (workspace/output) REAL array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK;\n*          if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged\n*          superdiagonal elements of an upper bidiagonal matrix B\n*          whose diagonal is in S (not necessarily sorted). B\n*          satisfies A = U * B * VT, so it has the same singular values\n*          as A, and singular vectors related by U and VT.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK.\n*          LWORK >= MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)).\n*          For good performance, LWORK should generally be larger.\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 SBDSQR did not converge, INFO specifies how many\n*                superdiagonals of an intermediate bidiagonal form B\n*                did not converge to zero. See the description of WORK\n*                above for details.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, u, vt, work, info, a = NumRu::Lapack.sgesvd( jobu, jobvt, a, [: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_jobu = argv[0];
  rblapack_jobvt = argv[1];
  rblapack_a = 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;
  }

  jobu = StringValueCStr(rblapack_jobu)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  m = lda;
  ldu = ((lsame_(&jobu,"S")) || (lsame_(&jobu,"A"))) ? m : 1;
  jobvt = StringValueCStr(rblapack_jobvt)[0];
  ldvt = lsame_(&jobvt,"A") ? n : lsame_(&jobvt,"S") ? MIN(m,n) : 1;
  if (rblapack_lwork == Qnil)
    lwork = MAX(MAX(1, 3*MIN(m,n)+MAX(m,n)), 5*MIN(m,n));
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = lsame_(&jobu,"A") ? m : lsame_(&jobu,"S") ? MIN(m,n) : 0;
    rblapack_u = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  u = NA_PTR_TYPE(rblapack_u, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldvt;
    shape[1] = n;
    rblapack_vt = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vt = NA_PTR_TYPE(rblapack_vt, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = MAX(n, MIN(m,n));
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  {
    VALUE __shape__[3];
    __shape__[0] = Qtrue;
    __shape__[1] = n < MIN(m,n) ? rb_range_new(rblapack_ZERO, INT2NUM(n), Qtrue) : Qtrue;
    __shape__[2] = rblapack_a;
    na_aset(3, __shape__, rblapack_a_out__);
  }
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  sgesvd_(&jobu, &jobvt, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  {
    VALUE __shape__[2];
    __shape__[0] = Qtrue;
    __shape__[1] = n < MIN(m,n) ? Qtrue : rb_range_new(rblapack_ZERO, INT2NUM(MIN(m,n)), Qtrue);
    rblapack_a = na_aref(2, __shape__, rblapack_a);
  }
  return rb_ary_new3(6, rblapack_s, rblapack_u, rblapack_vt, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_sgesvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgesvd", rblapack_sgesvd, -1);
}
ruby-lapack-1.7.2/ext/slarfb.c0000644000175000017500000001472412502221024016002 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slarfb_(char* side, char* trans, char* direct, char* storev, integer* m, integer* n, integer* k, real* v, integer* ldv, real* t, integer* ldt, real* c, integer* ldc, real* work, integer* ldwork);


static VALUE
rblapack_slarfb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_direct;
  char direct; 
  VALUE rblapack_storev;
  char storev; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_v;
  real *v; 
  VALUE rblapack_t;
  real *t; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_c_out__;
  real *c_out__;
  real *work;

  integer ldv;
  integer k;
  integer ldt;
  integer ldc;
  integer n;
  integer ldwork;

  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  c = NumRu::Lapack.slarfb( side, trans, direct, storev, m, v, t, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n*  Purpose\n*  =======\n*\n*  SLARFB applies a real block reflector H or its transpose H' to a\n*  real m by n matrix C, from either the left or the right.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply H or H' from the Left\n*          = 'R': apply H or H' from the Right\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': apply H (No transpose)\n*          = 'T': apply H' (Transpose)\n*\n*  DIRECT  (input) CHARACTER*1\n*          Indicates how H is formed from a product of elementary\n*          reflectors\n*          = 'F': H = H(1) H(2) . . . H(k) (Forward)\n*          = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n*  STOREV  (input) CHARACTER*1\n*          Indicates how the vectors which define the elementary\n*          reflectors are stored:\n*          = 'C': Columnwise\n*          = 'R': Rowwise\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C.\n*\n*  K       (input) INTEGER\n*          The order of the matrix T (= the number of elementary\n*          reflectors whose product defines the block reflector).\n*\n*  V       (input) REAL array, dimension\n*                                (LDV,K) if STOREV = 'C'\n*                                (LDV,M) if STOREV = 'R' and SIDE = 'L'\n*                                (LDV,N) if STOREV = 'R' and SIDE = 'R'\n*          The matrix V. See further details.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V.\n*          If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);\n*          if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);\n*          if STOREV = 'R', LDV >= K.\n*\n*  T       (input) REAL array, dimension (LDT,K)\n*          The triangular k by k matrix T in the representation of the\n*          block reflector.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= K.\n*\n*  C       (input/output) REAL array, dimension (LDC,N)\n*          On entry, the m by n matrix C.\n*          On exit, C is overwritten by H*C or H'*C or C*H or C*H'.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDA >= max(1,M).\n*\n*  WORK    (workspace) REAL array, dimension (LDWORK,K)\n*\n*  LDWORK  (input) INTEGER\n*          The leading dimension of the array WORK.\n*          If SIDE = 'L', LDWORK >= max(1,N);\n*          if SIDE = 'R', LDWORK >= max(1,M).\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.slarfb( side, trans, direct, storev, m, v, t, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_direct = argv[2];
  rblapack_storev = argv[3];
  rblapack_m = argv[4];
  rblapack_v = argv[5];
  rblapack_t = argv[6];
  rblapack_c = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  direct = StringValueCStr(rblapack_direct)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (7th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (7th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  k = NA_SHAPE1(rblapack_t);
  if (NA_TYPE(rblapack_t) != NA_SFLOAT)
    rblapack_t = na_change_type(rblapack_t, NA_SFLOAT);
  t = NA_PTR_TYPE(rblapack_t, real*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (6th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (6th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  if (NA_SHAPE1(rblapack_v) != k)
    rb_raise(rb_eRuntimeError, "shape 1 of v must be the same as shape 1 of t");
  if (NA_TYPE(rblapack_v) != NA_SFLOAT)
    rblapack_v = na_change_type(rblapack_v, NA_SFLOAT);
  v = NA_PTR_TYPE(rblapack_v, real*);
  storev = StringValueCStr(rblapack_storev)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (8th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  ldwork = MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0;
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(real, (ldwork)*(k));

  slarfb_(&side, &trans, &direct, &storev, &m, &n, &k, v, &ldv, t, &ldt, c, &ldc, work, &ldwork);

  free(work);
  return rblapack_c;
}

void
init_lapack_slarfb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slarfb", rblapack_slarfb, -1);
}
ruby-lapack-1.7.2/ext/zlar1v.c0000644000175000017500000002557612502221023015756 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlar1v_(integer* n, integer* b1, integer* bn, doublereal* lambda, doublereal* d, doublereal* l, doublereal* ld, doublereal* lld, doublereal* pivmin, doublereal* gaptol, doublecomplex* z, logical* wantnc, integer* negcnt, doublereal* ztz, doublereal* mingma, integer* r, integer* isuppz, doublereal* nrminv, doublereal* resid, doublereal* rqcorr, doublereal* work);


static VALUE
rblapack_zlar1v(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_b1;
  integer b1; 
  VALUE rblapack_bn;
  integer bn; 
  VALUE rblapack_lambda;
  doublereal lambda; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_l;
  doublereal *l; 
  VALUE rblapack_ld;
  doublereal *ld; 
  VALUE rblapack_lld;
  doublereal *lld; 
  VALUE rblapack_pivmin;
  doublereal pivmin; 
  VALUE rblapack_gaptol;
  doublereal gaptol; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_wantnc;
  logical wantnc; 
  VALUE rblapack_r;
  integer r; 
  VALUE rblapack_negcnt;
  integer negcnt; 
  VALUE rblapack_ztz;
  doublereal ztz; 
  VALUE rblapack_mingma;
  doublereal mingma; 
  VALUE rblapack_isuppz;
  integer *isuppz; 
  VALUE rblapack_nrminv;
  doublereal nrminv; 
  VALUE rblapack_resid;
  doublereal resid; 
  VALUE rblapack_rqcorr;
  doublereal rqcorr; 
  VALUE rblapack_z_out__;
  doublecomplex *z_out__;
  doublereal *work;

  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  negcnt, ztz, mingma, isuppz, nrminv, resid, rqcorr, z, r = NumRu::Lapack.zlar1v( b1, bn, lambda, d, l, ld, lld, pivmin, gaptol, z, wantnc, r, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD, PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, R, ISUPPZ, NRMINV, RESID, RQCORR, WORK )\n\n*  Purpose\n*  =======\n*\n*  ZLAR1V computes the (scaled) r-th column of the inverse of\n*  the sumbmatrix in rows B1 through BN of the tridiagonal matrix\n*  L D L^T - sigma I. When sigma is close to an eigenvalue, the\n*  computed vector is an accurate eigenvector. Usually, r corresponds\n*  to the index where the eigenvector is largest in magnitude.\n*  The following steps accomplish this computation :\n*  (a) Stationary qd transform,  L D L^T - sigma I = L(+) D(+) L(+)^T,\n*  (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T,\n*  (c) Computation of the diagonal elements of the inverse of\n*      L D L^T - sigma I by combining the above transforms, and choosing\n*      r as the index where the diagonal of the inverse is (one of the)\n*      largest in magnitude.\n*  (d) Computation of the (scaled) r-th column of the inverse using the\n*      twisted factorization obtained by combining the top part of the\n*      the stationary and the bottom part of the progressive transform.\n*\n\n*  Arguments\n*  =========\n*\n*  N        (input) INTEGER\n*           The order of the matrix L D L^T.\n*\n*  B1       (input) INTEGER\n*           First index of the submatrix of L D L^T.\n*\n*  BN       (input) INTEGER\n*           Last index of the submatrix of L D L^T.\n*\n*  LAMBDA    (input) DOUBLE PRECISION\n*           The shift. In order to compute an accurate eigenvector,\n*           LAMBDA should be a good approximation to an eigenvalue\n*           of L D L^T.\n*\n*  L        (input) DOUBLE PRECISION array, dimension (N-1)\n*           The (n-1) subdiagonal elements of the unit bidiagonal matrix\n*           L, in elements 1 to N-1.\n*\n*  D        (input) DOUBLE PRECISION array, dimension (N)\n*           The n diagonal elements of the diagonal matrix D.\n*\n*  LD       (input) DOUBLE PRECISION array, dimension (N-1)\n*           The n-1 elements L(i)*D(i).\n*\n*  LLD      (input) DOUBLE PRECISION array, dimension (N-1)\n*           The n-1 elements L(i)*L(i)*D(i).\n*\n*  PIVMIN   (input) DOUBLE PRECISION\n*           The minimum pivot in the Sturm sequence.\n*\n*  GAPTOL   (input) DOUBLE PRECISION\n*           Tolerance that indicates when eigenvector entries are negligible\n*           w.r.t. their contribution to the residual.\n*\n*  Z        (input/output) COMPLEX*16       array, dimension (N)\n*           On input, all entries of Z must be set to 0.\n*           On output, Z contains the (scaled) r-th column of the\n*           inverse. The scaling is such that Z(R) equals 1.\n*\n*  WANTNC   (input) LOGICAL\n*           Specifies whether NEGCNT has to be computed.\n*\n*  NEGCNT   (output) INTEGER\n*           If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin\n*           in the  matrix factorization L D L^T, and NEGCNT = -1 otherwise.\n*\n*  ZTZ      (output) DOUBLE PRECISION\n*           The square of the 2-norm of Z.\n*\n*  MINGMA   (output) DOUBLE PRECISION\n*           The reciprocal of the largest (in magnitude) diagonal\n*           element of the inverse of L D L^T - sigma I.\n*\n*  R        (input/output) INTEGER\n*           The twist index for the twisted factorization used to\n*           compute Z.\n*           On input, 0 <= R <= N. If R is input as 0, R is set to\n*           the index where (L D L^T - sigma I)^{-1} is largest\n*           in magnitude. If 1 <= R <= N, R is unchanged.\n*           On output, R contains the twist index used to compute Z.\n*           Ideally, R designates the position of the maximum entry in the\n*           eigenvector.\n*\n*  ISUPPZ   (output) INTEGER array, dimension (2)\n*           The support of the vector in Z, i.e., the vector Z is\n*           nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ).\n*\n*  NRMINV   (output) DOUBLE PRECISION\n*           NRMINV = 1/SQRT( ZTZ )\n*\n*  RESID    (output) DOUBLE PRECISION\n*           The residual of the FP vector.\n*           RESID = ABS( MINGMA )/SQRT( ZTZ )\n*\n*  RQCORR   (output) DOUBLE PRECISION\n*           The Rayleigh Quotient correction to LAMBDA.\n*           RQCORR = MINGMA*TMP\n*\n*  WORK     (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Beresford Parlett, University of California, Berkeley, USA\n*     Jim Demmel, University of California, Berkeley, USA\n*     Inderjit Dhillon, University of Texas, Austin, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  negcnt, ztz, mingma, isuppz, nrminv, resid, rqcorr, z, r = NumRu::Lapack.zlar1v( b1, bn, lambda, d, l, ld, lld, pivmin, gaptol, z, wantnc, r, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_b1 = argv[0];
  rblapack_bn = argv[1];
  rblapack_lambda = argv[2];
  rblapack_d = argv[3];
  rblapack_l = argv[4];
  rblapack_ld = argv[5];
  rblapack_lld = argv[6];
  rblapack_pivmin = argv[7];
  rblapack_gaptol = argv[8];
  rblapack_z = argv[9];
  rblapack_wantnc = argv[10];
  rblapack_r = argv[11];
  if (argc == 12) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  b1 = NUM2INT(rblapack_b1);
  lambda = NUM2DBL(rblapack_lambda);
  pivmin = NUM2DBL(rblapack_pivmin);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (10th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (10th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_DCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  r = NUM2INT(rblapack_r);
  bn = NUM2INT(rblapack_bn);
  gaptol = NUM2DBL(rblapack_gaptol);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of z");
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_ld))
    rb_raise(rb_eArgError, "ld (6th argument) must be NArray");
  if (NA_RANK(rblapack_ld) != 1)
    rb_raise(rb_eArgError, "rank of ld (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ld) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of ld must be %d", n-1);
  if (NA_TYPE(rblapack_ld) != NA_DFLOAT)
    rblapack_ld = na_change_type(rblapack_ld, NA_DFLOAT);
  ld = NA_PTR_TYPE(rblapack_ld, doublereal*);
  wantnc = (rblapack_wantnc == Qtrue);
  if (!NA_IsNArray(rblapack_l))
    rb_raise(rb_eArgError, "l (5th argument) must be NArray");
  if (NA_RANK(rblapack_l) != 1)
    rb_raise(rb_eArgError, "rank of l (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_l) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of l must be %d", n-1);
  if (NA_TYPE(rblapack_l) != NA_DFLOAT)
    rblapack_l = na_change_type(rblapack_l, NA_DFLOAT);
  l = NA_PTR_TYPE(rblapack_l, doublereal*);
  if (!NA_IsNArray(rblapack_lld))
    rb_raise(rb_eArgError, "lld (7th argument) must be NArray");
  if (NA_RANK(rblapack_lld) != 1)
    rb_raise(rb_eArgError, "rank of lld (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_lld) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of lld must be %d", n-1);
  if (NA_TYPE(rblapack_lld) != NA_DFLOAT)
    rblapack_lld = na_change_type(rblapack_lld, NA_DFLOAT);
  lld = NA_PTR_TYPE(rblapack_lld, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 2;
    rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublecomplex*);
  MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  work = ALLOC_N(doublereal, (4*n));

  zlar1v_(&n, &b1, &bn, &lambda, d, l, ld, lld, &pivmin, &gaptol, z, &wantnc, &negcnt, &ztz, &mingma, &r, isuppz, &nrminv, &resid, &rqcorr, work);

  free(work);
  rblapack_negcnt = INT2NUM(negcnt);
  rblapack_ztz = rb_float_new((double)ztz);
  rblapack_mingma = rb_float_new((double)mingma);
  rblapack_nrminv = rb_float_new((double)nrminv);
  rblapack_resid = rb_float_new((double)resid);
  rblapack_rqcorr = rb_float_new((double)rqcorr);
  rblapack_r = INT2NUM(r);
  return rb_ary_new3(9, rblapack_negcnt, rblapack_ztz, rblapack_mingma, rblapack_isuppz, rblapack_nrminv, rblapack_resid, rblapack_rqcorr, rblapack_z, rblapack_r);
}

void
init_lapack_zlar1v(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlar1v", rblapack_zlar1v, -1);
}
ruby-lapack-1.7.2/ext/dtgsy2.c0000644000175000017500000003170312502221020015735 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtgsy2_(char* trans, integer* ijob, integer* m, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* c, integer* ldc, doublereal* d, integer* ldd, doublereal* e, integer* lde, doublereal* f, integer* ldf, doublereal* scale, doublereal* rdsum, doublereal* rdscal, integer* iwork, integer* pq, integer* info);


static VALUE
rblapack_dtgsy2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_ijob;
  integer ijob; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_f;
  doublereal *f; 
  VALUE rblapack_rdsum;
  doublereal rdsum; 
  VALUE rblapack_rdscal;
  doublereal rdscal; 
  VALUE rblapack_scale;
  doublereal scale; 
  VALUE rblapack_pq;
  integer pq; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublereal *c_out__;
  VALUE rblapack_f_out__;
  doublereal *f_out__;
  integer *iwork;

  integer lda;
  integer m;
  integer ldb;
  integer n;
  integer ldc;
  integer ldd;
  integer lde;
  integer ldf;

  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  scale, pq, info, c, f, rdsum, rdscal = NumRu::Lapack.dtgsy2( trans, ijob, a, b, c, d, e, f, rdsum, rdscal, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, IWORK, PQ, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTGSY2 solves the generalized Sylvester equation:\n*\n*              A * R - L * B = scale * C                (1)\n*              D * R - L * E = scale * F,\n*\n*  using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices,\n*  (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,\n*  N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E)\n*  must be in generalized Schur canonical form, i.e. A, B are upper\n*  quasi triangular and D, E are upper triangular. The solution (R, L)\n*  overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor\n*  chosen to avoid overflow.\n*\n*  In matrix notation solving equation (1) corresponds to solve\n*  Z*x = scale*b, where Z is defined as\n*\n*         Z = [ kron(In, A)  -kron(B', Im) ]             (2)\n*             [ kron(In, D)  -kron(E', Im) ],\n*\n*  Ik is the identity matrix of size k and X' is the transpose of X.\n*  kron(X, Y) is the Kronecker product between the matrices X and Y.\n*  In the process of solving (1), we solve a number of such systems\n*  where Dim(In), Dim(In) = 1 or 2.\n*\n*  If TRANS = 'T', solve the transposed system Z'*y = scale*b for y,\n*  which is equivalent to solve for R and L in\n*\n*              A' * R  + D' * L   = scale *  C           (3)\n*              R  * B' + L  * E'  = scale * -F\n*\n*  This case is used to compute an estimate of Dif[(A, D), (B, E)] =\n*  sigma_min(Z) using reverse communicaton with DLACON.\n*\n*  DTGSY2 also (IJOB >= 1) contributes to the computation in DTGSYL\n*  of an upper bound on the separation between to matrix pairs. Then\n*  the input (A, D), (B, E) are sub-pencils of the matrix pair in\n*  DTGSYL. See DTGSYL for details.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N', solve the generalized Sylvester equation (1).\n*          = 'T': solve the 'transposed' system (3).\n*\n*  IJOB    (input) INTEGER\n*          Specifies what kind of functionality to be performed.\n*          = 0: solve (1) only.\n*          = 1: A contribution from this subsystem to a Frobenius\n*               norm-based estimate of the separation between two matrix\n*               pairs is computed. (look ahead strategy is used).\n*          = 2: A contribution from this subsystem to a Frobenius\n*               norm-based estimate of the separation between two matrix\n*               pairs is computed. (DGECON on sub-systems is used.)\n*          Not referenced if TRANS = 'T'.\n*\n*  M       (input) INTEGER\n*          On entry, M specifies the order of A and D, and the row\n*          dimension of C, F, R and L.\n*\n*  N       (input) INTEGER\n*          On entry, N specifies the order of B and E, and the column\n*          dimension of C, F, R and L.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA, M)\n*          On entry, A contains an upper quasi triangular matrix.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the matrix A. LDA >= max(1, M).\n*\n*  B       (input) DOUBLE PRECISION array, dimension (LDB, N)\n*          On entry, B contains an upper quasi triangular matrix.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the matrix B. LDB >= max(1, N).\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (LDC, N)\n*          On entry, C contains the right-hand-side of the first matrix\n*          equation in (1).\n*          On exit, if IJOB = 0, C has been overwritten by the\n*          solution R.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the matrix C. LDC >= max(1, M).\n*\n*  D       (input) DOUBLE PRECISION array, dimension (LDD, M)\n*          On entry, D contains an upper triangular matrix.\n*\n*  LDD     (input) INTEGER\n*          The leading dimension of the matrix D. LDD >= max(1, M).\n*\n*  E       (input) DOUBLE PRECISION array, dimension (LDE, N)\n*          On entry, E contains an upper triangular matrix.\n*\n*  LDE     (input) INTEGER\n*          The leading dimension of the matrix E. LDE >= max(1, N).\n*\n*  F       (input/output) DOUBLE PRECISION array, dimension (LDF, N)\n*          On entry, F contains the right-hand-side of the second matrix\n*          equation in (1).\n*          On exit, if IJOB = 0, F has been overwritten by the\n*          solution L.\n*\n*  LDF     (input) INTEGER\n*          The leading dimension of the matrix F. LDF >= max(1, M).\n*\n*  SCALE   (output) DOUBLE PRECISION\n*          On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions\n*          R and L (C and F on entry) will hold the solutions to a\n*          slightly perturbed system but the input matrices A, B, D and\n*          E have not been changed. If SCALE = 0, R and L will hold the\n*          solutions to the homogeneous system with C = F = 0. Normally,\n*          SCALE = 1.\n*\n*  RDSUM   (input/output) DOUBLE PRECISION\n*          On entry, the sum of squares of computed contributions to\n*          the Dif-estimate under computation by DTGSYL, where the\n*          scaling factor RDSCAL (see below) has been factored out.\n*          On exit, the corresponding sum of squares updated with the\n*          contributions from the current sub-system.\n*          If TRANS = 'T' RDSUM is not touched.\n*          NOTE: RDSUM only makes sense when DTGSY2 is called by DTGSYL.\n*\n*  RDSCAL  (input/output) DOUBLE PRECISION\n*          On entry, scaling factor used to prevent overflow in RDSUM.\n*          On exit, RDSCAL is updated w.r.t. the current contributions\n*          in RDSUM.\n*          If TRANS = 'T', RDSCAL is not touched.\n*          NOTE: RDSCAL only makes sense when DTGSY2 is called by\n*                DTGSYL.\n*\n*  IWORK   (workspace) INTEGER array, dimension (M+N+2)\n*\n*  PQ      (output) INTEGER\n*          On exit, the number of subsystems (of size 2-by-2, 4-by-4 and\n*          8-by-8) solved by this routine.\n*\n*  INFO    (output) INTEGER\n*          On exit, if INFO is set to\n*            =0: Successful exit\n*            <0: If INFO = -i, the i-th argument had an illegal value.\n*            >0: The matrix pairs (A, D) and (B, E) have common or very\n*                close eigenvalues.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  =====================================================================\n*  Replaced various illegal calls to DCOPY by calls to DLASET.\n*  Sven Hammarling, 27/5/02.\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, pq, info, c, f, rdsum, rdscal = NumRu::Lapack.dtgsy2( trans, ijob, a, b, c, d, e, f, rdsum, rdscal, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_trans = argv[0];
  rblapack_ijob = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  rblapack_c = argv[4];
  rblapack_d = argv[5];
  rblapack_e = argv[6];
  rblapack_f = argv[7];
  rblapack_rdsum = argv[8];
  rblapack_rdscal = argv[9];
  if (argc == 10) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = 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*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (7th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 2)
    rb_raise(rb_eArgError, "rank of e (7th argument) must be %d", 2);
  lde = NA_SHAPE0(rblapack_e);
  if (NA_SHAPE1(rblapack_e) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of e must be the same as shape 1 of c");
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  rdsum = NUM2DBL(rblapack_rdsum);
  ijob = NUM2INT(rblapack_ijob);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (6th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 2)
    rb_raise(rb_eArgError, "rank of d (6th argument) must be %d", 2);
  ldd = NA_SHAPE0(rblapack_d);
  if (NA_SHAPE1(rblapack_d) != m)
    rb_raise(rb_eRuntimeError, "shape 1 of d must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  rdscal = NUM2DBL(rblapack_rdscal);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of c");
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  if (!NA_IsNArray(rblapack_f))
    rb_raise(rb_eArgError, "f (8th argument) must be NArray");
  if (NA_RANK(rblapack_f) != 2)
    rb_raise(rb_eArgError, "rank of f (8th argument) must be %d", 2);
  ldf = NA_SHAPE0(rblapack_f);
  if (NA_SHAPE1(rblapack_f) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of f must be the same as shape 1 of c");
  if (NA_TYPE(rblapack_f) != NA_DFLOAT)
    rblapack_f = na_change_type(rblapack_f, NA_DFLOAT);
  f = NA_PTR_TYPE(rblapack_f, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldf;
    shape[1] = n;
    rblapack_f_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  f_out__ = NA_PTR_TYPE(rblapack_f_out__, doublereal*);
  MEMCPY(f_out__, f, doublereal, NA_TOTAL(rblapack_f));
  rblapack_f = rblapack_f_out__;
  f = f_out__;
  iwork = ALLOC_N(integer, (m+n+2));

  dtgsy2_(&trans, &ijob, &m, &n, a, &lda, b, &ldb, c, &ldc, d, &ldd, e, &lde, f, &ldf, &scale, &rdsum, &rdscal, iwork, &pq, &info);

  free(iwork);
  rblapack_scale = rb_float_new((double)scale);
  rblapack_pq = INT2NUM(pq);
  rblapack_info = INT2NUM(info);
  rblapack_rdsum = rb_float_new((double)rdsum);
  rblapack_rdscal = rb_float_new((double)rdscal);
  return rb_ary_new3(7, rblapack_scale, rblapack_pq, rblapack_info, rblapack_c, rblapack_f, rblapack_rdsum, rblapack_rdscal);
}

void
init_lapack_dtgsy2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtgsy2", rblapack_dtgsy2, -1);
}
ruby-lapack-1.7.2/ext/dsprfs.c0000644000175000017500000002104312502221023016021 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsprfs_(char* uplo, integer* n, integer* nrhs, doublereal* ap, doublereal* afp, integer* ipiv, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dsprfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_afp;
  doublereal *afp; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  doublereal *x_out__;
  doublereal *work;
  integer *iwork;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.dsprfs( uplo, ap, afp, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSPRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is symmetric indefinite\n*  and packed, and provides error bounds and backward error estimates\n*  for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          The upper or lower triangle of the symmetric matrix A, packed\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  AFP     (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          The factored form of the matrix A.  AFP contains the block\n*          diagonal matrix D and the multipliers used to obtain the\n*          factor U or L from the factorization A = U*D*U**T or\n*          A = L*D*L**T as computed by DSPTRF, stored as a packed\n*          triangular matrix.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by DSPTRF.\n*\n*  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by DSPTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.dsprfs( uplo, ap, afp, ipiv, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_afp = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_b = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  if (!NA_IsNArray(rblapack_afp))
    rb_raise(rb_eArgError, "afp (3th argument) must be NArray");
  if (NA_RANK(rblapack_afp) != 1)
    rb_raise(rb_eArgError, "rank of afp (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_afp) != NA_DFLOAT)
    rblapack_afp = na_change_type(rblapack_afp, NA_DFLOAT);
  afp = NA_PTR_TYPE(rblapack_afp, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(doublereal, (3*n));
  iwork = ALLOC_N(integer, (n));

  dsprfs_(&uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_dsprfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsprfs", rblapack_dsprfs, -1);
}
ruby-lapack-1.7.2/ext/slasd6.c0000644000175000017500000003614112655767574015764 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slasd6_(integer* icompq, integer* nl, integer* nr, integer* sqre, real* d, real* vf, real* vl, real* alpha, real* beta, integer* idxq, integer* perm, integer* givptr, integer* givcol, integer* ldgcol, real* givnum, integer* ldgnum, real* poles, real* difl, real* difr, real* z, integer* k, real* c, real* s, real* work, integer* iwork, integer* info);


static VALUE
rblapack_slasd6(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_icompq;
  integer icompq; 
  VALUE rblapack_nl;
  integer nl; 
  VALUE rblapack_nr;
  integer nr; 
  VALUE rblapack_sqre;
  integer sqre; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_vf;
  real *vf; 
  VALUE rblapack_vl;
  real *vl; 
  VALUE rblapack_alpha;
  real alpha; 
  VALUE rblapack_beta;
  real beta; 
  VALUE rblapack_idxq;
  integer *idxq; 
  VALUE rblapack_perm;
  integer *perm; 
  VALUE rblapack_givptr;
  integer givptr; 
  VALUE rblapack_givcol;
  integer *givcol; 
  VALUE rblapack_givnum;
  real *givnum; 
  VALUE rblapack_poles;
  real *poles; 
  VALUE rblapack_difl;
  real *difl; 
  VALUE rblapack_difr;
  real *difr; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_c;
  real c; 
  VALUE rblapack_s;
  real s; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_vf_out__;
  real *vf_out__;
  VALUE rblapack_vl_out__;
  real *vl_out__;
  real *work;
  integer *iwork;

  integer m;
  integer n;
  integer ldgcol;
  integer ldgnum;

  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  idxq, perm, givptr, givcol, givnum, poles, difl, difr, z, k, c, s, info, d, vf, vl, alpha, beta = NumRu::Lapack.slasd6( icompq, nl, nr, sqre, d, vf, vl, alpha, beta, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA, IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLASD6 computes the SVD of an updated upper bidiagonal matrix B\n*  obtained by merging two smaller ones by appending a row. This\n*  routine is used only for the problem which requires all singular\n*  values and optionally singular vector matrices in factored form.\n*  B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE.\n*  A related subroutine, SLASD1, handles the case in which all singular\n*  values and singular vectors of the bidiagonal matrix are desired.\n*\n*  SLASD6 computes the SVD as follows:\n*\n*                ( D1(in)  0    0     0 )\n*    B = U(in) * (   Z1'   a   Z2'    b ) * VT(in)\n*                (   0     0   D2(in) 0 )\n*\n*      = U(out) * ( D(out) 0) * VT(out)\n*\n*  where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M\n*  with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros\n*  elsewhere; and the entry b is empty if SQRE = 0.\n*\n*  The singular values of B can be computed using D1, D2, the first\n*  components of all the right singular vectors of the lower block, and\n*  the last components of all the right singular vectors of the upper\n*  block. These components are stored and updated in VF and VL,\n*  respectively, in SLASD6. Hence U and VT are not explicitly\n*  referenced.\n*\n*  The singular values are stored in D. The algorithm consists of two\n*  stages:\n*\n*        The first stage consists of deflating the size of the problem\n*        when there are multiple singular values or if there is a zero\n*        in the Z vector. For each such occurrence the dimension of the\n*        secular equation problem is reduced by one. This stage is\n*        performed by the routine SLASD7.\n*\n*        The second stage consists of calculating the updated\n*        singular values. This is done by finding the roots of the\n*        secular equation via the routine SLASD4 (as called by SLASD8).\n*        This routine also updates VF and VL and computes the distances\n*        between the updated singular values and the old singular\n*        values.\n*\n*  SLASD6 is called from SLASDA.\n*\n\n*  Arguments\n*  =========\n*\n*  ICOMPQ (input) INTEGER\n*         Specifies whether singular vectors are to be computed in\n*         factored form:\n*         = 0: Compute singular values only.\n*         = 1: Compute singular vectors in factored form as well.\n*\n*  NL     (input) INTEGER\n*         The row dimension of the upper block.  NL >= 1.\n*\n*  NR     (input) INTEGER\n*         The row dimension of the lower block.  NR >= 1.\n*\n*  SQRE   (input) INTEGER\n*         = 0: the lower block is an NR-by-NR square matrix.\n*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n*         The bidiagonal matrix has row dimension N = NL + NR + 1,\n*         and column dimension M = N + SQRE.\n*\n*  D      (input/output) REAL array, dimension (NL+NR+1).\n*         On entry D(1:NL,1:NL) contains the singular values of the\n*         upper block, and D(NL+2:N) contains the singular values\n*         of the lower block. On exit D(1:N) contains the singular\n*         values of the modified matrix.\n*\n*  VF     (input/output) REAL array, dimension (M)\n*         On entry, VF(1:NL+1) contains the first components of all\n*         right singular vectors of the upper block; and VF(NL+2:M)\n*         contains the first components of all right singular vectors\n*         of the lower block. On exit, VF contains the first components\n*         of all right singular vectors of the bidiagonal matrix.\n*\n*  VL     (input/output) REAL array, dimension (M)\n*         On entry, VL(1:NL+1) contains the  last components of all\n*         right singular vectors of the upper block; and VL(NL+2:M)\n*         contains the last components of all right singular vectors of\n*         the lower block. On exit, VL contains the last components of\n*         all right singular vectors of the bidiagonal matrix.\n*\n*  ALPHA  (input/output) REAL\n*         Contains the diagonal element associated with the added row.\n*\n*  BETA   (input/output) REAL\n*         Contains the off-diagonal element associated with the added\n*         row.\n*\n*  IDXQ   (output) INTEGER array, dimension (N)\n*         This contains the permutation which will reintegrate the\n*         subproblem just solved back into sorted order, i.e.\n*         D( IDXQ( I = 1, N ) ) will be in ascending order.\n*\n*  PERM   (output) INTEGER array, dimension ( N )\n*         The permutations (from deflation and sorting) to be applied\n*         to each block. Not referenced if ICOMPQ = 0.\n*\n*  GIVPTR (output) INTEGER\n*         The number of Givens rotations which took place in this\n*         subproblem. Not referenced if ICOMPQ = 0.\n*\n*  GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )\n*         Each pair of numbers indicates a pair of columns to take place\n*         in a Givens rotation. Not referenced if ICOMPQ = 0.\n*\n*  LDGCOL (input) INTEGER\n*         leading dimension of GIVCOL, must be at least N.\n*\n*  GIVNUM (output) REAL array, dimension ( LDGNUM, 2 )\n*         Each number indicates the C or S value to be used in the\n*         corresponding Givens rotation. Not referenced if ICOMPQ = 0.\n*\n*  LDGNUM (input) INTEGER\n*         The leading dimension of GIVNUM and POLES, must be at least N.\n*\n*  POLES  (output) REAL array, dimension ( LDGNUM, 2 )\n*         On exit, POLES(1,*) is an array containing the new singular\n*         values obtained from solving the secular equation, and\n*         POLES(2,*) is an array containing the poles in the secular\n*         equation. Not referenced if ICOMPQ = 0.\n*\n*  DIFL   (output) REAL array, dimension ( N )\n*         On exit, DIFL(I) is the distance between I-th updated\n*         (undeflated) singular value and the I-th (undeflated) old\n*         singular value.\n*\n*  DIFR   (output) REAL array,\n*                  dimension ( LDGNUM, 2 ) if ICOMPQ = 1 and\n*                  dimension ( N ) if ICOMPQ = 0.\n*         On exit, DIFR(I, 1) is the distance between I-th updated\n*         (undeflated) singular value and the I+1-th (undeflated) old\n*         singular value.\n*\n*         If ICOMPQ = 1, DIFR(1:K,2) is an array containing the\n*         normalizing factors for the right singular vector matrix.\n*\n*         See SLASD8 for details on DIFL and DIFR.\n*\n*  Z      (output) REAL array, dimension ( M )\n*         The first elements of this array contain the components\n*         of the deflation-adjusted updating row vector.\n*\n*  K      (output) INTEGER\n*         Contains the dimension of the non-deflated matrix,\n*         This is the order of the related secular equation. 1 <= K <=N.\n*\n*  C      (output) REAL\n*         C contains garbage if SQRE =0 and the C-value of a Givens\n*         rotation related to the right null space if SQRE = 1.\n*\n*  S      (output) REAL\n*         S contains garbage if SQRE =0 and the S-value of a Givens\n*         rotation related to the right null space if SQRE = 1.\n*\n*  WORK   (workspace) REAL array, dimension ( 4 * M )\n*\n*  IWORK  (workspace) INTEGER array, dimension ( 3 * N )\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 = 1, a singular value did not converge\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  idxq, perm, givptr, givcol, givnum, poles, difl, difr, z, k, c, s, info, d, vf, vl, alpha, beta = NumRu::Lapack.slasd6( icompq, nl, nr, sqre, d, vf, vl, alpha, beta, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_icompq = argv[0];
  rblapack_nl = argv[1];
  rblapack_nr = argv[2];
  rblapack_sqre = argv[3];
  rblapack_d = argv[4];
  rblapack_vf = argv[5];
  rblapack_vl = argv[6];
  rblapack_alpha = argv[7];
  rblapack_beta = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  icompq = NUM2INT(rblapack_icompq);
  nr = NUM2INT(rblapack_nr);
  alpha = (real)NUM2DBL(rblapack_alpha);
  nl = NUM2INT(rblapack_nl);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (5th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != (nl+nr+1))
    rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", nl+nr+1);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  beta = (real)NUM2DBL(rblapack_beta);
  n = nl + nr + 1;
  ldgcol = n;
  sqre = NUM2INT(rblapack_sqre);
  m = n + sqre;
  if (!NA_IsNArray(rblapack_vf))
    rb_raise(rb_eArgError, "vf (6th argument) must be NArray");
  if (NA_RANK(rblapack_vf) != 1)
    rb_raise(rb_eArgError, "rank of vf (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_vf) != m)
    rb_raise(rb_eRuntimeError, "shape 0 of vf must be n + sqre");
  if (NA_TYPE(rblapack_vf) != NA_SFLOAT)
    rblapack_vf = na_change_type(rblapack_vf, NA_SFLOAT);
  vf = NA_PTR_TYPE(rblapack_vf, real*);
  ldgnum = n;
  if (!NA_IsNArray(rblapack_vl))
    rb_raise(rb_eArgError, "vl (7th argument) must be NArray");
  if (NA_RANK(rblapack_vl) != 1)
    rb_raise(rb_eArgError, "rank of vl (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_vl) != m)
    rb_raise(rb_eRuntimeError, "shape 0 of vl must be n + sqre");
  if (NA_TYPE(rblapack_vl) != NA_SFLOAT)
    rblapack_vl = na_change_type(rblapack_vl, NA_SFLOAT);
  vl = NA_PTR_TYPE(rblapack_vl, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_idxq = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  idxq = NA_PTR_TYPE(rblapack_idxq, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_perm = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  perm = NA_PTR_TYPE(rblapack_perm, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldgcol;
    shape[1] = 2;
    rblapack_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
  }
  givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldgnum;
    shape[1] = 2;
    rblapack_givnum = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  givnum = NA_PTR_TYPE(rblapack_givnum, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldgnum;
    shape[1] = 2;
    rblapack_poles = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  poles = NA_PTR_TYPE(rblapack_poles, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_difl = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  difl = NA_PTR_TYPE(rblapack_difl, real*);
  {
    na_shape_t shape[2];
    shape[0] = icompq == 1 ? ldgnum : icompq == 0 ? n : 0;
    shape[1] = icompq == 1 ? 2 : 0;
    rblapack_difr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  difr = NA_PTR_TYPE(rblapack_difr, real*);
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_z = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[1];
    shape[0] = nl+nr+1;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_vf_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  vf_out__ = NA_PTR_TYPE(rblapack_vf_out__, real*);
  MEMCPY(vf_out__, vf, real, NA_TOTAL(rblapack_vf));
  rblapack_vf = rblapack_vf_out__;
  vf = vf_out__;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_vl_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, real*);
  MEMCPY(vl_out__, vl, real, NA_TOTAL(rblapack_vl));
  rblapack_vl = rblapack_vl_out__;
  vl = vl_out__;
  work = ALLOC_N(real, (4 * m));
  iwork = ALLOC_N(integer, (3 * n));

  slasd6_(&icompq, &nl, &nr, &sqre, d, vf, vl, &alpha, &beta, idxq, perm, &givptr, givcol, &ldgcol, givnum, &ldgnum, poles, difl, difr, z, &k, &c, &s, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_givptr = INT2NUM(givptr);
  rblapack_k = INT2NUM(k);
  rblapack_c = rb_float_new((double)c);
  rblapack_s = rb_float_new((double)s);
  rblapack_info = INT2NUM(info);
  rblapack_alpha = rb_float_new((double)alpha);
  rblapack_beta = rb_float_new((double)beta);
  return rb_ary_new3(18, rblapack_idxq, rblapack_perm, rblapack_givptr, rblapack_givcol, rblapack_givnum, rblapack_poles, rblapack_difl, rblapack_difr, rblapack_z, rblapack_k, rblapack_c, rblapack_s, rblapack_info, rblapack_d, rblapack_vf, rblapack_vl, rblapack_alpha, rblapack_beta);
}

void
init_lapack_slasd6(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slasd6", rblapack_slasd6, -1);
}
ruby-lapack-1.7.2/ext/zlalsd.c0000644000175000017500000002135112502221025016015 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlalsd_(char* uplo, integer* smlsiz, integer* n, integer* nrhs, doublereal* d, doublereal* e, doublecomplex* b, integer* ldb, doublereal* rcond, integer* rank, doublecomplex* work, doublereal* rwork, integer* iwork, integer* info);


static VALUE
rblapack_zlalsd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_smlsiz;
  integer smlsiz; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_rank;
  integer rank; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_e_out__;
  doublereal *e_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  doublecomplex *work;
  doublereal *rwork;
  integer *iwork;

  integer n;
  integer ldb;
  integer nrhs;
  integer nlvl;

  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  rank, info, d, e, b = NumRu::Lapack.zlalsd( uplo, smlsiz, d, e, b, rcond, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, RANK, WORK, RWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZLALSD uses the singular value decomposition of A to solve the least\n*  squares problem of finding X to minimize the Euclidean norm of each\n*  column of A*X-B, where A is N-by-N upper bidiagonal, and X and B\n*  are N-by-NRHS. The solution X overwrites B.\n*\n*  The singular values of A smaller than RCOND times the largest\n*  singular value are treated as zero in solving the least squares\n*  problem; in this case a minimum norm solution is returned.\n*  The actual singular values are returned in D in ascending order.\n*\n*  This code makes very mild assumptions about floating point\n*  arithmetic. It will work on machines with a guard digit in\n*  add/subtract, or on those binary machines without guard digits\n*  which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.\n*  It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO   (input) CHARACTER*1\n*         = 'U': D and E define an upper bidiagonal matrix.\n*         = 'L': D and E define a  lower bidiagonal matrix.\n*\n*  SMLSIZ (input) INTEGER\n*         The maximum size of the subproblems at the bottom of the\n*         computation tree.\n*\n*  N      (input) INTEGER\n*         The dimension of the  bidiagonal matrix.  N >= 0.\n*\n*  NRHS   (input) INTEGER\n*         The number of columns of B. NRHS must be at least 1.\n*\n*  D      (input/output) DOUBLE PRECISION array, dimension (N)\n*         On entry D contains the main diagonal of the bidiagonal\n*         matrix. On exit, if INFO = 0, D contains its singular values.\n*\n*  E      (input/output) DOUBLE PRECISION array, dimension (N-1)\n*         Contains the super-diagonal entries of the bidiagonal matrix.\n*         On exit, E has been destroyed.\n*\n*  B      (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*         On input, B contains the right hand sides of the least\n*         squares problem. On output, B contains the solution X.\n*\n*  LDB    (input) INTEGER\n*         The leading dimension of B in the calling subprogram.\n*         LDB must be at least max(1,N).\n*\n*  RCOND  (input) DOUBLE PRECISION\n*         The singular values of A less than or equal to RCOND times\n*         the largest singular value are treated as zero in solving\n*         the least squares problem. If RCOND is negative,\n*         machine precision is used instead.\n*         For example, if diag(S)*X=B were the least squares problem,\n*         where diag(S) is a diagonal matrix of singular values, the\n*         solution would be X(i) = B(i) / S(i) if S(i) is greater than\n*         RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to\n*         RCOND*max(S).\n*\n*  RANK   (output) INTEGER\n*         The number of singular values of A greater than RCOND times\n*         the largest singular value.\n*\n*  WORK   (workspace) COMPLEX*16 array, dimension at least\n*         (N * NRHS).\n*\n*  RWORK  (workspace) DOUBLE PRECISION array, dimension at least\n*         (9*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS +\n*         MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS ),\n*         where\n*         NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )\n*\n*  IWORK  (workspace) INTEGER array, dimension at least\n*         (3*N*NLVL + 11*N).\n*\n*  INFO   (output) INTEGER\n*         = 0:  successful exit.\n*         < 0:  if INFO = -i, the i-th argument had an illegal value.\n*         > 0:  The algorithm failed to compute a singular value while\n*               working on the submatrix lying in rows and columns\n*               INFO/(N+1) through MOD(INFO,N+1).\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Ren-Cang Li, Computer Science Division, University of\n*       California at Berkeley, USA\n*     Osni Marques, LBNL/NERSC, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rank, info, d, e, b = NumRu::Lapack.zlalsd( uplo, smlsiz, d, e, b, rcond, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_smlsiz = argv[1];
  rblapack_d = argv[2];
  rblapack_e = argv[3];
  rblapack_b = argv[4];
  rblapack_rcond = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  smlsiz = NUM2INT(rblapack_smlsiz);
  rcond = NUM2DBL(rblapack_rcond);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (4th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  nlvl = ( (int)( log(((double)n)/(smlsiz+1))/log(2.0) ) ) + 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
  MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(doublecomplex, (n * nrhs));
  rwork = ALLOC_N(doublereal, (9*n+2*n*smlsiz+8*n*nlvl+3*smlsiz*nrhs+(smlsiz+1)*(smlsiz+1)));
  iwork = ALLOC_N(integer, (3*n*nlvl + 11*n));

  zlalsd_(&uplo, &smlsiz, &n, &nrhs, d, e, b, &ldb, &rcond, &rank, work, rwork, iwork, &info);

  free(work);
  free(rwork);
  free(iwork);
  rblapack_rank = INT2NUM(rank);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_rank, rblapack_info, rblapack_d, rblapack_e, rblapack_b);
}

void
init_lapack_zlalsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlalsd", rblapack_zlalsd, -1);
}
ruby-lapack-1.7.2/ext/dsyev.c0000644000175000017500000001322612502221020015653 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsyev_(char* jobz, char* uplo, integer* n, doublereal* a, integer* lda, doublereal* w, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dsyev(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_w;
  doublereal *w; 
  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  w, work, info, a = NumRu::Lapack.dsyev( jobz, uplo, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSYEV computes all eigenvalues and, optionally, eigenvectors of a\n*  real symmetric matrix A.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of A contains the\n*          upper triangular part of the matrix A.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of A contains\n*          the lower triangular part of the matrix A.\n*          On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n*          orthonormal eigenvectors of the matrix A.\n*          If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')\n*          or the upper triangle (if UPLO='U') of A, including the\n*          diagonal, is destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\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 length of the array WORK.  LWORK >= max(1,3*N-1).\n*          For optimal efficiency, LWORK >= (NB+2)*N,\n*          where NB is the blocksize for DSYTRD returned by ILAENV.\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 algorithm failed to converge; i\n*                off-diagonal elements of an intermediate tridiagonal\n*                form did not converge to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, work, info, a = NumRu::Lapack.dsyev( jobz, uplo, a, [: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_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = 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;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (rblapack_lwork == Qnil)
    lwork = 3*n-1;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;

  dsyev_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_w, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_dsyev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsyev", rblapack_dsyev, -1);
}
ruby-lapack-1.7.2/ext/dlaed8.c0000644000175000017500000003030312502221015015661 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaed8_(integer* icompq, integer* k, integer* n, integer* qsiz, doublereal* d, doublereal* q, integer* ldq, integer* indxq, doublereal* rho, integer* cutpnt, doublereal* z, doublereal* dlamda, doublereal* q2, integer* ldq2, doublereal* w, integer* perm, integer* givptr, integer* givcol, doublereal* givnum, integer* indxp, integer* indx, integer* info);


static VALUE
rblapack_dlaed8(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_icompq;
  integer icompq; 
  VALUE rblapack_qsiz;
  integer qsiz; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_q;
  doublereal *q; 
  VALUE rblapack_ldq;
  integer ldq; 
  VALUE rblapack_indxq;
  integer *indxq; 
  VALUE rblapack_rho;
  doublereal rho; 
  VALUE rblapack_cutpnt;
  integer cutpnt; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_dlamda;
  doublereal *dlamda; 
  VALUE rblapack_q2;
  doublereal *q2; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_perm;
  integer *perm; 
  VALUE rblapack_givptr;
  integer givptr; 
  VALUE rblapack_givcol;
  integer *givcol; 
  VALUE rblapack_givnum;
  doublereal *givnum; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_q_out__;
  doublereal *q_out__;
  integer *indxp;
  integer *indx;

  integer n;
  integer ldq2;

  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  k, dlamda, q2, w, perm, givptr, givcol, givnum, info, d, q, rho = NumRu::Lapack.dlaed8( icompq, qsiz, d, q, ldq, indxq, rho, cutpnt, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR, GIVCOL, GIVNUM, INDXP, INDX, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLAED8 merges the two sets of eigenvalues together into a single\n*  sorted set.  Then it tries to deflate the size of the problem.\n*  There are two ways in which deflation can occur:  when two or more\n*  eigenvalues are close together or if there is a tiny element in the\n*  Z vector.  For each such occurrence the order of the related secular\n*  equation problem is reduced by one.\n*\n\n*  Arguments\n*  =========\n*\n*  ICOMPQ  (input) INTEGER\n*          = 0:  Compute eigenvalues only.\n*          = 1:  Compute eigenvectors of original dense symmetric matrix\n*                also.  On entry, Q contains the orthogonal matrix used\n*                to reduce the original matrix to tridiagonal form.\n*\n*  K      (output) INTEGER\n*         The number of non-deflated eigenvalues, and the order of the\n*         related secular equation.\n*\n*  N      (input) INTEGER\n*         The dimension of the symmetric tridiagonal matrix.  N >= 0.\n*\n*  QSIZ   (input) INTEGER\n*         The dimension of the orthogonal matrix used to reduce\n*         the full matrix to tridiagonal form.  QSIZ >= N if ICOMPQ = 1.\n*\n*  D      (input/output) DOUBLE PRECISION array, dimension (N)\n*         On entry, the eigenvalues of the two submatrices to be\n*         combined.  On exit, the trailing (N-K) updated eigenvalues\n*         (those which were deflated) sorted into increasing order.\n*\n*  Q      (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n*         If ICOMPQ = 0, Q is not referenced.  Otherwise,\n*         on entry, Q contains the eigenvectors of the partially solved\n*         system which has been previously updated in matrix\n*         multiplies with other partially solved eigensystems.\n*         On exit, Q contains the trailing (N-K) updated eigenvectors\n*         (those which were deflated) in its last N-K columns.\n*\n*  LDQ    (input) INTEGER\n*         The leading dimension of the array Q.  LDQ >= max(1,N).\n*\n*  INDXQ  (input) INTEGER array, dimension (N)\n*         The permutation which separately sorts the two sub-problems\n*         in D into ascending order.  Note that elements in the second\n*         half of this permutation must first have CUTPNT added to\n*         their values in order to be accurate.\n*\n*  RHO    (input/output) DOUBLE PRECISION\n*         On entry, the off-diagonal element associated with the rank-1\n*         cut which originally split the two submatrices which are now\n*         being recombined.\n*         On exit, RHO has been modified to the value required by\n*         DLAED3.\n*\n*  CUTPNT (input) INTEGER\n*         The location of the last eigenvalue in the leading\n*         sub-matrix.  min(1,N) <= CUTPNT <= N.\n*\n*  Z      (input) DOUBLE PRECISION array, dimension (N)\n*         On entry, Z contains the updating vector (the last row of\n*         the first sub-eigenvector matrix and the first row of the\n*         second sub-eigenvector matrix).\n*         On exit, the contents of Z are destroyed by the updating\n*         process.\n*\n*  DLAMDA (output) DOUBLE PRECISION array, dimension (N)\n*         A copy of the first K eigenvalues which will be used by\n*         DLAED3 to form the secular equation.\n*\n*  Q2     (output) DOUBLE PRECISION array, dimension (LDQ2,N)\n*         If ICOMPQ = 0, Q2 is not referenced.  Otherwise,\n*         a copy of the first K eigenvectors which will be used by\n*         DLAED7 in a matrix multiply (DGEMM) to update the new\n*         eigenvectors.\n*\n*  LDQ2   (input) INTEGER\n*         The leading dimension of the array Q2.  LDQ2 >= max(1,N).\n*\n*  W      (output) DOUBLE PRECISION array, dimension (N)\n*         The first k values of the final deflation-altered z-vector and\n*         will be passed to DLAED3.\n*\n*  PERM   (output) INTEGER array, dimension (N)\n*         The permutations (from deflation and sorting) to be applied\n*         to each eigenblock.\n*\n*  GIVPTR (output) INTEGER\n*         The number of Givens rotations which took place in this\n*         subproblem.\n*\n*  GIVCOL (output) INTEGER array, dimension (2, N)\n*         Each pair of numbers indicates a pair of columns to take place\n*         in a Givens rotation.\n*\n*  GIVNUM (output) DOUBLE PRECISION array, dimension (2, N)\n*         Each number indicates the S value to be used in the\n*         corresponding Givens rotation.\n*\n*  INDXP  (workspace) INTEGER array, dimension (N)\n*         The permutation used to place deflated values of D at the end\n*         of the array.  INDXP(1:K) points to the nondeflated D-values\n*         and INDXP(K+1:N) points to the deflated eigenvalues.\n*\n*  INDX   (workspace) INTEGER array, dimension (N)\n*         The permutation used to sort the contents of D into ascending\n*         order.\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*  Based on contributions by\n*     Jeff Rutter, Computer Science Division, University of California\n*     at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  k, dlamda, q2, w, perm, givptr, givcol, givnum, info, d, q, rho = NumRu::Lapack.dlaed8( icompq, qsiz, d, q, ldq, indxq, rho, cutpnt, z, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_icompq = argv[0];
  rblapack_qsiz = argv[1];
  rblapack_d = argv[2];
  rblapack_q = argv[3];
  rblapack_ldq = argv[4];
  rblapack_indxq = argv[5];
  rblapack_rho = argv[6];
  rblapack_cutpnt = argv[7];
  rblapack_z = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  icompq = NUM2INT(rblapack_icompq);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  ldq = NUM2INT(rblapack_ldq);
  rho = NUM2DBL(rblapack_rho);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (9th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  qsiz = NUM2INT(rblapack_qsiz);
  if (!NA_IsNArray(rblapack_indxq))
    rb_raise(rb_eArgError, "indxq (6th argument) must be NArray");
  if (NA_RANK(rblapack_indxq) != 1)
    rb_raise(rb_eArgError, "rank of indxq (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_indxq) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of indxq must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_indxq) != NA_LINT)
    rblapack_indxq = na_change_type(rblapack_indxq, NA_LINT);
  indxq = NA_PTR_TYPE(rblapack_indxq, integer*);
  ldq2 = MAX(1,n);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (4th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (4th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_q) != (icompq==0 ? 0 : ldq))
    rb_raise(rb_eRuntimeError, "shape 0 of q must be %d", icompq==0 ? 0 : ldq);
  if (NA_SHAPE1(rblapack_q) != (icompq==0 ? 0 : n))
    rb_raise(rb_eRuntimeError, "shape 1 of q must be %d", icompq==0 ? 0 : n);
  if (NA_TYPE(rblapack_q) != NA_DFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
  q = NA_PTR_TYPE(rblapack_q, doublereal*);
  cutpnt = NUM2INT(rblapack_cutpnt);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_dlamda = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  dlamda = NA_PTR_TYPE(rblapack_dlamda, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = icompq==0 ? 0 : ldq2;
    shape[1] = icompq==0 ? 0 : n;
    rblapack_q2 = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  q2 = NA_PTR_TYPE(rblapack_q2, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_perm = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  perm = NA_PTR_TYPE(rblapack_perm, integer*);
  {
    na_shape_t shape[2];
    shape[0] = 2;
    shape[1] = n;
    rblapack_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
  }
  givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
  {
    na_shape_t shape[2];
    shape[0] = 2;
    shape[1] = n;
    rblapack_givnum = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  givnum = NA_PTR_TYPE(rblapack_givnum, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[2];
    shape[0] = icompq==0 ? 0 : ldq;
    shape[1] = icompq==0 ? 0 : n;
    rblapack_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
  MEMCPY(q_out__, q, doublereal, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  indxp = ALLOC_N(integer, (n));
  indx = ALLOC_N(integer, (n));

  dlaed8_(&icompq, &k, &n, &qsiz, d, q, &ldq, indxq, &rho, &cutpnt, z, dlamda, q2, &ldq2, w, perm, &givptr, givcol, givnum, indxp, indx, &info);

  free(indxp);
  free(indx);
  rblapack_k = INT2NUM(k);
  rblapack_givptr = INT2NUM(givptr);
  rblapack_info = INT2NUM(info);
  rblapack_rho = rb_float_new((double)rho);
  return rb_ary_new3(12, rblapack_k, rblapack_dlamda, rblapack_q2, rblapack_w, rblapack_perm, rblapack_givptr, rblapack_givcol, rblapack_givnum, rblapack_info, rblapack_d, rblapack_q, rblapack_rho);
}

void
init_lapack_dlaed8(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaed8", rblapack_dlaed8, -1);
}
ruby-lapack-1.7.2/ext/clansp.c0000644000175000017500000001051412502221020015776 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real clansp_(char* norm, char* uplo, integer* n, complex* ap, real* work);


static VALUE
rblapack_clansp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack___out__;
  real __out__; 
  real *work;


  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  __out__ = NumRu::Lapack.clansp( norm, uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL             FUNCTION CLANSP( NORM, UPLO, N, AP, WORK )\n\n*  Purpose\n*  =======\n*\n*  CLANSP  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  complex symmetric matrix A,  supplied in packed form.\n*\n*  Description\n*  ===========\n*\n*  CLANSP returns the value\n*\n*     CLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in CLANSP as described\n*          above.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is supplied.\n*          = 'U':  Upper triangular part of A is supplied\n*          = 'L':  Lower triangular part of A is supplied\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, CLANSP is\n*          set to zero.\n*\n*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)\n*          The upper or lower triangle of the symmetric matrix A, packed\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n*          WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.clansp( norm, uplo, n, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_n = argv[2];
  rblapack_ap = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  n = NUM2INT(rblapack_n);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  work = ALLOC_N(real, (MAX(1,(lsame_(&norm,"I")||lsame_(&norm,"1")||lsame_(&norm,"O")) ? n : 0)));

  __out__ = clansp_(&norm, &uplo, &n, ap, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_clansp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clansp", rblapack_clansp, -1);
}
ruby-lapack-1.7.2/ext/ctrttp.c0000644000175000017500000000727612502221020016051 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctrttp_(char* uplo, integer* n, complex* a, integer* lda, complex* ap, integer* info);


static VALUE
rblapack_ctrttp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_info;
  integer info; 

  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  ap, info = NumRu::Lapack.ctrttp( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTRTTP( UPLO, N, A, LDA, AP, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTRTTP copies a triangular matrix A from full format (TR) to standard\n*  packed format (TP).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrices AP and A.  N >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          On entry, the triangular matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AP      (output) COMPLEX array, dimension ( N*(N+1)/2 ),\n*          On exit, the upper or lower triangular matrix A, packed\n*          columnwise in a linear array. The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ap, info = NumRu::Lapack.ctrttp( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = ( n*(n+1)/2 );
    rblapack_ap = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  ap = NA_PTR_TYPE(rblapack_ap, complex*);

  ctrttp_(&uplo, &n, a, &lda, ap, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_ap, rblapack_info);
}

void
init_lapack_ctrttp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctrttp", rblapack_ctrttp, -1);
}
ruby-lapack-1.7.2/ext/claswp.c0000644000175000017500000001072312502221016016016 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID claswp_(integer* n, complex* a, integer* lda, integer* k1, integer* k2, integer* ipiv, integer* incx);


static VALUE
rblapack_claswp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_k1;
  integer k1; 
  VALUE rblapack_k2;
  integer k2; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_a_out__;
  complex *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  a = NumRu::Lapack.claswp( a, k1, k2, ipiv, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLASWP( N, A, LDA, K1, K2, IPIV, INCX )\n\n*  Purpose\n*  =======\n*\n*  CLASWP performs a series of row interchanges on the matrix A.\n*  One row interchange is initiated for each of rows K1 through K2 of A.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the matrix of column dimension N to which the row\n*          interchanges will be applied.\n*          On exit, the permuted matrix.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*\n*  K1      (input) INTEGER\n*          The first element of IPIV for which a row interchange will\n*          be done.\n*\n*  K2      (input) INTEGER\n*          The last element of IPIV for which a row interchange will\n*          be done.\n*\n*  IPIV    (input) INTEGER array, dimension (K2*abs(INCX))\n*          The vector of pivot indices.  Only the elements in positions\n*          K1 through K2 of IPIV are accessed.\n*          IPIV(K) = L implies rows K and L are to be interchanged.\n*\n*  INCX    (input) INTEGER\n*          The increment between successive values of IPIV.  If IPIV\n*          is negative, the pivots are applied in reverse order.\n*\n\n*  Further Details\n*  ===============\n*\n*  Modified by\n*   R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n* =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, I1, I2, INC, IP, IX, IX0, J, K, N32\n      COMPLEX            TEMP\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  a = NumRu::Lapack.claswp( a, k1, k2, ipiv, incx, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_a = argv[0];
  rblapack_k1 = argv[1];
  rblapack_k2 = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_incx = argv[4];
  if (argc == 5) {
  } 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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  k2 = NUM2INT(rblapack_k2);
  incx = NUM2INT(rblapack_incx);
  k1 = NUM2INT(rblapack_k1);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != (k2*abs(incx)))
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be %d", k2*abs(incx));
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  claswp_(&n, a, &lda, &k1, &k2, ipiv, &incx);

  return rblapack_a;
}

void
init_lapack_claswp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "claswp", rblapack_claswp, -1);
}
ruby-lapack-1.7.2/ext/chptri.c0000644000175000017500000001111312502221024016007 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chptri_(char* uplo, integer* n, complex* ap, integer* ipiv, complex* work, integer* info);


static VALUE
rblapack_chptri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  complex *ap_out__;
  complex *work;

  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  info, ap = NumRu::Lapack.chptri( uplo, ap, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHPTRI( UPLO, N, AP, IPIV, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHPTRI computes the inverse of a complex Hermitian indefinite matrix\n*  A in packed storage using the factorization A = U*D*U**H or\n*  A = L*D*L**H computed by CHPTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**H;\n*          = 'L':  Lower triangular, form is A = L*D*L**H.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)\n*          On entry, the block diagonal matrix D and the multipliers\n*          used to obtain the factor U or L as computed by CHPTRF,\n*          stored as a packed triangular matrix.\n*\n*          On exit, if INFO = 0, the (Hermitian) inverse of the original\n*          matrix, stored as a packed triangular matrix. The j-th column\n*          of inv(A) is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;\n*          if UPLO = 'L',\n*             AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by CHPTRF.\n*\n*  WORK    (workspace) COMPLEX array, dimension (N)\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, D(i,i) = 0; the matrix is singular and its\n*               inverse could not be computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ap = NumRu::Lapack.chptri( uplo, ap, ipiv, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_ipiv = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
  MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  work = ALLOC_N(complex, (n));

  chptri_(&uplo, &n, ap, ipiv, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ap);
}

void
init_lapack_chptri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chptri", rblapack_chptri, -1);
}
ruby-lapack-1.7.2/ext/slagts.c0000644000175000017500000002070212502221012016014 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slagts_(integer* job, integer* n, real* a, real* b, real* c, real* d, integer* in, real* y, real* tol, integer* info);


static VALUE
rblapack_slagts(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  integer job; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_in;
  integer *in; 
  VALUE rblapack_y;
  real *y; 
  VALUE rblapack_tol;
  real tol; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_y_out__;
  real *y_out__;

  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  info, y, tol = NumRu::Lapack.slagts( job, a, b, c, d, in, y, tol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLAGTS may be used to solve one of the systems of equations\n*\n*     (T - lambda*I)*x = y   or   (T - lambda*I)'*x = y,\n*\n*  where T is an n by n tridiagonal matrix, for x, following the\n*  factorization of (T - lambda*I) as\n*\n*     (T - lambda*I) = P*L*U ,\n*\n*  by routine SLAGTF. The choice of equation to be solved is\n*  controlled by the argument JOB, and in each case there is an option\n*  to perturb zero or very small diagonal elements of U, this option\n*  being intended for use in applications such as inverse iteration.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) INTEGER\n*          Specifies the job to be performed by SLAGTS as follows:\n*          =  1: The equations  (T - lambda*I)x = y  are to be solved,\n*                but diagonal elements of U are not to be perturbed.\n*          = -1: The equations  (T - lambda*I)x = y  are to be solved\n*                and, if overflow would otherwise occur, the diagonal\n*                elements of U are to be perturbed. See argument TOL\n*                below.\n*          =  2: The equations  (T - lambda*I)'x = y  are to be solved,\n*                but diagonal elements of U are not to be perturbed.\n*          = -2: The equations  (T - lambda*I)'x = y  are to be solved\n*                and, if overflow would otherwise occur, the diagonal\n*                elements of U are to be perturbed. See argument TOL\n*                below.\n*\n*  N       (input) INTEGER\n*          The order of the matrix T.\n*\n*  A       (input) REAL array, dimension (N)\n*          On entry, A must contain the diagonal elements of U as\n*          returned from SLAGTF.\n*\n*  B       (input) REAL array, dimension (N-1)\n*          On entry, B must contain the first super-diagonal elements of\n*          U as returned from SLAGTF.\n*\n*  C       (input) REAL array, dimension (N-1)\n*          On entry, C must contain the sub-diagonal elements of L as\n*          returned from SLAGTF.\n*\n*  D       (input) REAL array, dimension (N-2)\n*          On entry, D must contain the second super-diagonal elements\n*          of U as returned from SLAGTF.\n*\n*  IN      (input) INTEGER array, dimension (N)\n*          On entry, IN must contain details of the matrix P as returned\n*          from SLAGTF.\n*\n*  Y       (input/output) REAL array, dimension (N)\n*          On entry, the right hand side vector y.\n*          On exit, Y is overwritten by the solution vector x.\n*\n*  TOL     (input/output) REAL\n*          On entry, with  JOB .lt. 0, TOL should be the minimum\n*          perturbation to be made to very small diagonal elements of U.\n*          TOL should normally be chosen as about eps*norm(U), where eps\n*          is the relative machine precision, but if TOL is supplied as\n*          non-positive, then it is reset to eps*max( abs( u(i,j) ) ).\n*          If  JOB .gt. 0  then TOL is not referenced.\n*\n*          On exit, TOL is changed as described above, only if TOL is\n*          non-positive on entry. Otherwise TOL is unchanged.\n*\n*  INFO    (output) INTEGER\n*          = 0   : successful exit\n*          .lt. 0: if INFO = -i, the i-th argument had an illegal value\n*          .gt. 0: overflow would occur when computing the INFO(th)\n*                  element of the solution vector x. This can only occur\n*                  when JOB is supplied as positive and either means\n*                  that a diagonal element of U is very small, or that\n*                  the elements of the right-hand side vector y are very\n*                  large.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, y, tol = NumRu::Lapack.slagts( job, a, b, c, d, in, y, tol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_job = argv[0];
  rblapack_a = argv[1];
  rblapack_b = argv[2];
  rblapack_c = argv[3];
  rblapack_d = argv[4];
  rblapack_in = argv[5];
  rblapack_y = argv[6];
  rblapack_tol = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  job = NUM2INT(rblapack_job);
  if (!NA_IsNArray(rblapack_in))
    rb_raise(rb_eArgError, "in (6th argument) must be NArray");
  if (NA_RANK(rblapack_in) != 1)
    rb_raise(rb_eArgError, "rank of in (6th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_in);
  if (NA_TYPE(rblapack_in) != NA_LINT)
    rblapack_in = na_change_type(rblapack_in, NA_LINT);
  in = NA_PTR_TYPE(rblapack_in, integer*);
  tol = (real)NUM2DBL(rblapack_tol);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (2th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 1)
    rb_raise(rb_eArgError, "rank of a (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of a must be the same as shape 0 of in");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (7th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of y must be the same as shape 0 of in");
  if (NA_TYPE(rblapack_y) != NA_SFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
  y = NA_PTR_TYPE(rblapack_y, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (3th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 1)
    rb_raise(rb_eArgError, "rank of b (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_b) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of b must be %d", n-1);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (5th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != (n-2))
    rb_raise(rb_eRuntimeError, "shape 0 of d must be %d", n-2);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (4th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of c must be %d", n-1);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
  MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  slagts_(&job, &n, a, b, c, d, in, y, &tol, &info);

  rblapack_info = INT2NUM(info);
  rblapack_tol = rb_float_new((double)tol);
  return rb_ary_new3(3, rblapack_info, rblapack_y, rblapack_tol);
}

void
init_lapack_slagts(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slagts", rblapack_slagts, -1);
}
ruby-lapack-1.7.2/ext/dlasd1.c0000644000175000017500000002361712655767575015745 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlasd1_(integer* nl, integer* nr, integer* sqre, doublereal* d, doublereal* alpha, doublereal* beta, doublereal* u, integer* ldu, doublereal* vt, integer* ldvt, integer* idxq, integer* iwork, doublereal* work, integer* info);


static VALUE
rblapack_dlasd1(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_nl;
  integer nl; 
  VALUE rblapack_nr;
  integer nr; 
  VALUE rblapack_sqre;
  integer sqre; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_alpha;
  doublereal alpha; 
  VALUE rblapack_beta;
  doublereal beta; 
  VALUE rblapack_u;
  doublereal *u; 
  VALUE rblapack_vt;
  doublereal *vt; 
  VALUE rblapack_idxq;
  integer *idxq; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_u_out__;
  doublereal *u_out__;
  VALUE rblapack_vt_out__;
  doublereal *vt_out__;
  integer *iwork;
  doublereal *work;

  integer n;
  integer ldu;
  integer ldvt;
  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  idxq, info, d, alpha, beta, u, vt = NumRu::Lapack.dlasd1( nl, nr, sqre, d, alpha, beta, u, vt, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT, IDXQ, IWORK, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B,\n*  where N = NL + NR + 1 and M = N + SQRE. DLASD1 is called from DLASD0.\n*\n*  A related subroutine DLASD7 handles the case in which the singular\n*  values (and the singular vectors in factored form) are desired.\n*\n*  DLASD1 computes the SVD as follows:\n*\n*                ( D1(in)  0    0     0 )\n*    B = U(in) * (   Z1'   a   Z2'    b ) * VT(in)\n*                (   0     0   D2(in) 0 )\n*\n*      = U(out) * ( D(out) 0) * VT(out)\n*\n*  where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M\n*  with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros\n*  elsewhere; and the entry b is empty if SQRE = 0.\n*\n*  The left singular vectors of the original matrix are stored in U, and\n*  the transpose of the right singular vectors are stored in VT, and the\n*  singular values are in D.  The algorithm consists of three stages:\n*\n*     The first stage consists of deflating the size of the problem\n*     when there are multiple singular values or when there are zeros in\n*     the Z vector.  For each such occurrence the dimension of the\n*     secular equation problem is reduced by one.  This stage is\n*     performed by the routine DLASD2.\n*\n*     The second stage consists of calculating the updated\n*     singular values. This is done by finding the square roots of the\n*     roots of the secular equation via the routine DLASD4 (as called\n*     by DLASD3). This routine also calculates the singular vectors of\n*     the current problem.\n*\n*     The final stage consists of computing the updated singular vectors\n*     directly using the updated singular values.  The singular vectors\n*     for the current problem are multiplied with the singular vectors\n*     from the overall problem.\n*\n\n*  Arguments\n*  =========\n*\n*  NL     (input) INTEGER\n*         The row dimension of the upper block.  NL >= 1.\n*\n*  NR     (input) INTEGER\n*         The row dimension of the lower block.  NR >= 1.\n*\n*  SQRE   (input) INTEGER\n*         = 0: the lower block is an NR-by-NR square matrix.\n*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n*         The bidiagonal matrix has row dimension N = NL + NR + 1,\n*         and column dimension M = N + SQRE.\n*\n*  D      (input/output) DOUBLE PRECISION array,\n*                        dimension (N = NL+NR+1).\n*         On entry D(1:NL,1:NL) contains the singular values of the\n*         upper block; and D(NL+2:N) contains the singular values of\n*         the lower block. On exit D(1:N) contains the singular values\n*         of the modified matrix.\n*\n*  ALPHA  (input/output) DOUBLE PRECISION\n*         Contains the diagonal element associated with the added row.\n*\n*  BETA   (input/output) DOUBLE PRECISION\n*         Contains the off-diagonal element associated with the added\n*         row.\n*\n*  U      (input/output) DOUBLE PRECISION array, dimension(LDU,N)\n*         On entry U(1:NL, 1:NL) contains the left singular vectors of\n*         the upper block; U(NL+2:N, NL+2:N) contains the left singular\n*         vectors of the lower block. On exit U contains the left\n*         singular vectors of the bidiagonal matrix.\n*\n*  LDU    (input) INTEGER\n*         The leading dimension of the array U.  LDU >= max( 1, N ).\n*\n*  VT     (input/output) DOUBLE PRECISION array, dimension(LDVT,M)\n*         where M = N + SQRE.\n*         On entry VT(1:NL+1, 1:NL+1)' contains the right singular\n*         vectors of the upper block; VT(NL+2:M, NL+2:M)' contains\n*         the right singular vectors of the lower block. On exit\n*         VT' contains the right singular vectors of the\n*         bidiagonal matrix.\n*\n*  LDVT   (input) INTEGER\n*         The leading dimension of the array VT.  LDVT >= max( 1, M ).\n*\n*  IDXQ  (output) INTEGER array, dimension(N)\n*         This contains the permutation which will reintegrate the\n*         subproblem just solved back into sorted order, i.e.\n*         D( IDXQ( I = 1, N ) ) will be in ascending order.\n*\n*  IWORK  (workspace) INTEGER array, dimension( 4 * N )\n*\n*  WORK   (workspace) DOUBLE PRECISION array, dimension( 3*M**2 + 2*M )\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 = 1, a singular value did not converge\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  idxq, info, d, alpha, beta, u, vt = NumRu::Lapack.dlasd1( nl, nr, sqre, d, alpha, beta, u, vt, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_nl = argv[0];
  rblapack_nr = argv[1];
  rblapack_sqre = argv[2];
  rblapack_d = argv[3];
  rblapack_alpha = argv[4];
  rblapack_beta = argv[5];
  rblapack_u = argv[6];
  rblapack_vt = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  nl = NUM2INT(rblapack_nl);
  sqre = NUM2INT(rblapack_sqre);
  alpha = NUM2DBL(rblapack_alpha);
  nr = NUM2INT(rblapack_nr);
  beta = NUM2DBL(rblapack_beta);
  n = nl+nr+1;
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be nl+nr+1");
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  m = n + sqre;
  if (!NA_IsNArray(rblapack_u))
    rb_raise(rb_eArgError, "u (7th argument) must be NArray");
  if (NA_RANK(rblapack_u) != 2)
    rb_raise(rb_eArgError, "rank of u (7th argument) must be %d", 2);
  ldu = NA_SHAPE0(rblapack_u);
  if (NA_SHAPE1(rblapack_u) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of u must be nl+nr+1");
  if (NA_TYPE(rblapack_u) != NA_DFLOAT)
    rblapack_u = na_change_type(rblapack_u, NA_DFLOAT);
  u = NA_PTR_TYPE(rblapack_u, doublereal*);
  if (!NA_IsNArray(rblapack_vt))
    rb_raise(rb_eArgError, "vt (8th argument) must be NArray");
  if (NA_RANK(rblapack_vt) != 2)
    rb_raise(rb_eArgError, "rank of vt (8th argument) must be %d", 2);
  ldvt = NA_SHAPE0(rblapack_vt);
  if (NA_SHAPE1(rblapack_vt) != m)
    rb_raise(rb_eRuntimeError, "shape 1 of vt must be n + sqre");
  if (NA_TYPE(rblapack_vt) != NA_DFLOAT)
    rblapack_vt = na_change_type(rblapack_vt, NA_DFLOAT);
  vt = NA_PTR_TYPE(rblapack_vt, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_idxq = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  idxq = NA_PTR_TYPE(rblapack_idxq, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = n;
    rblapack_u_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  u_out__ = NA_PTR_TYPE(rblapack_u_out__, doublereal*);
  MEMCPY(u_out__, u, doublereal, NA_TOTAL(rblapack_u));
  rblapack_u = rblapack_u_out__;
  u = u_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvt;
    shape[1] = m;
    rblapack_vt_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vt_out__ = NA_PTR_TYPE(rblapack_vt_out__, doublereal*);
  MEMCPY(vt_out__, vt, doublereal, NA_TOTAL(rblapack_vt));
  rblapack_vt = rblapack_vt_out__;
  vt = vt_out__;
  iwork = ALLOC_N(integer, (4 * n));
  work = ALLOC_N(doublereal, (3*pow(m,2) + 2*m));

  dlasd1_(&nl, &nr, &sqre, d, &alpha, &beta, u, &ldu, vt, &ldvt, idxq, iwork, work, &info);

  free(iwork);
  free(work);
  rblapack_info = INT2NUM(info);
  rblapack_alpha = rb_float_new((double)alpha);
  rblapack_beta = rb_float_new((double)beta);
  return rb_ary_new3(7, rblapack_idxq, rblapack_info, rblapack_d, rblapack_alpha, rblapack_beta, rblapack_u, rblapack_vt);
}

void
init_lapack_dlasd1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlasd1", rblapack_dlasd1, -1);
}
ruby-lapack-1.7.2/ext/ztrttf.c0000644000175000017500000001716412502221021016064 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztrttf_(char* transr, char* uplo, integer* n, doublecomplex* a, integer* lda, doublecomplex* arf, integer* info);


static VALUE
rblapack_ztrttf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_arf;
  doublecomplex *arf; 
  VALUE rblapack_info;
  integer info; 

  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  arf, info = NumRu::Lapack.ztrttf( transr, uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTRTTF copies a triangular matrix A from standard full format (TR)\n*  to rectangular full packed format (TF) .\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR   (input) CHARACTER*1\n*          = 'N':  ARF in Normal mode is wanted;\n*          = 'C':  ARF in Conjugate Transpose mode is wanted;\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension ( LDA, N ) \n*          On entry, the triangular matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of the array A contains\n*          the upper triangular matrix, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of the array A contains\n*          the lower triangular matrix, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the matrix A.  LDA >= max(1,N).\n*\n*  ARF     (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ),\n*          On exit, the upper or lower triangular matrix A stored in\n*          RFP format. For a further discussion see Notes below.\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*  We first consider Standard Packed Format when N is even.\n*  We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = `N'. RFP holds AP as follows:\n*  For UPLO = `U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  conjugate-transpose of the first three columns of AP upper.\n*  For UPLO = `L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  conjugate-transpose of the last three columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N even and TRANSR = `N'.\n*\n*         RFP A                   RFP A\n*\n*                                -- -- --\n*        03 04 05                33 43 53\n*                                   -- --\n*        13 14 15                00 44 54\n*                                      --\n*        23 24 25                10 11 55\n*\n*        33 34 35                20 21 22\n*        --\n*        00 44 45                30 31 32\n*        -- --\n*        01 11 55                40 41 42\n*        -- -- --\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = `C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- -- --                -- -- -- -- -- --\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     -- -- -- -- --                -- -- -- -- --\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     -- -- -- -- -- --                -- -- -- --\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We next  consider Standard Packed Format when N is odd.\n*  We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = `N'. RFP holds AP as follows:\n*  For UPLO = `U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  conjugate-transpose of the first two   columns of AP upper.\n*  For UPLO = `L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  conjugate-transpose of the last two   columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N odd  and TRANSR = `N'.\n*\n*         RFP A                   RFP A\n*\n*                                   -- --\n*        02 03 04                00 33 43\n*                                      --\n*        12 13 14                10 11 44\n*\n*        22 23 24                20 21 22\n*        --\n*        00 33 34                30 31 32\n*        -- --\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = `C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- --                   -- -- -- -- -- --\n*     02 12 22 00 01             00 10 20 30 40 50\n*     -- -- -- --                   -- -- -- -- --\n*     03 13 23 33 11             33 11 21 31 41 51\n*     -- -- -- -- --                   -- -- -- --\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  arf, info = NumRu::Lapack.ztrttf( transr, uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  {
    na_shape_t shape[1];
    shape[0] = ( n*(n+1)/2 );
    rblapack_arf = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  arf = NA_PTR_TYPE(rblapack_arf, doublecomplex*);

  ztrttf_(&transr, &uplo, &n, a, &lda, arf, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_arf, rblapack_info);
}

void
init_lapack_ztrttf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztrttf", rblapack_ztrttf, -1);
}
ruby-lapack-1.7.2/ext/dgehrd.c0000644000175000017500000001553412502221022015764 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgehrd_(integer* n, integer* ilo, integer* ihi, doublereal* a, integer* lda, doublereal* tau, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dgehrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  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.dgehrd( ilo, ihi, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGEHRD reduces a real general matrix A to upper Hessenberg form H by\n*  an orthogonal similarity transformation:  Q' * A * Q = H .\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          It is assumed that A is already upper triangular in rows\n*          and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally\n*          set by a previous call to DGEBAL; otherwise they should be\n*          set to 1 and N respectively. See Further Details.\n*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the N-by-N general matrix to be reduced.\n*          On exit, the upper triangle and the first subdiagonal of A\n*          are overwritten with the upper Hessenberg matrix H, and the\n*          elements below the first subdiagonal, with the array TAU,\n*          represent the orthogonal matrix Q as a product of elementary\n*          reflectors. See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  TAU     (output) DOUBLE PRECISION array, dimension (N-1)\n*          The scalar factors of the elementary reflectors (see Further\n*          Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to\n*          zero.\n*\n*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of the array WORK.  LWORK >= max(1,N).\n*          For optimum performance LWORK >= N*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 (ihi-ilo) elementary\n*  reflectors\n*\n*     Q = H(ilo) H(ilo+1) . . . H(ihi-1).\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) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on\n*  exit in A(i+2:ihi,i), and tau in TAU(i).\n*\n*  The contents of A are illustrated by the following example, with\n*  n = 7, ilo = 2 and ihi = 6:\n*\n*  on entry,                        on exit,\n*\n*  ( a   a   a   a   a   a   a )    (  a   a   h   h   h   h   a )\n*  (     a   a   a   a   a   a )    (      a   h   h   h   h   a )\n*  (     a   a   a   a   a   a )    (      h   h   h   h   h   h )\n*  (     a   a   a   a   a   a )    (      v2  h   h   h   h   h )\n*  (     a   a   a   a   a   a )    (      v2  v3  h   h   h   h )\n*  (     a   a   a   a   a   a )    (      v2  v3  v4  h   h   h )\n*  (                         a )    (                          a )\n*\n*  where a denotes an element of the original matrix A, h denotes a\n*  modified element of the upper Hessenberg matrix H, and vi denotes an\n*  element of the vector defining H(i).\n*\n*  This file is a slight modification of LAPACK-3.0's DGEHRD\n*  subroutine incorporating improvements proposed by Quintana-Orti and\n*  Van de Geijn (2006). (See DLAHR2.)\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, work, info, a = NumRu::Lapack.dgehrd( ilo, ihi, a, [: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_ilo = argv[0];
  rblapack_ihi = argv[1];
  rblapack_a = 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;
  }

  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  ihi = NUM2INT(rblapack_ihi);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;

  dgehrd_(&n, &ilo, &ihi, 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_dgehrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgehrd", rblapack_dgehrd, -1);
}
ruby-lapack-1.7.2/ext/zhptrs.c0000644000175000017500000001172612502221013016060 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhptrs_(char* uplo, integer* n, integer* nrhs, doublecomplex* ap, integer* ipiv, doublecomplex* b, integer* ldb, integer* info);


static VALUE
rblapack_zhptrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.zhptrs( uplo, ap, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHPTRS solves a system of linear equations A*X = B with a complex\n*  Hermitian matrix A stored in packed format using the factorization\n*  A = U*D*U**H or A = L*D*L**H computed by ZHPTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**H;\n*          = 'L':  Lower triangular, form is A = L*D*L**H.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by ZHPTRF, stored as a\n*          packed triangular matrix.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by ZHPTRF.\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.zhptrs( uplo, ap, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zhptrs_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_zhptrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhptrs", rblapack_zhptrs, -1);
}
ruby-lapack-1.7.2/ext/sbdsdc.c0000644000175000017500000002422612502221014015770 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sbdsdc_(char* uplo, char* compq, integer* n, real* d, real* e, real* u, integer* ldu, real* vt, integer* ldvt, real* q, integer* iq, real* work, integer* iwork, integer* info);


static VALUE
rblapack_sbdsdc(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_compq;
  char compq; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_u;
  real *u; 
  VALUE rblapack_vt;
  real *vt; 
  VALUE rblapack_q;
  real *q; 
  VALUE rblapack_iq;
  integer *iq; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_e_out__;
  real *e_out__;
  real *work;
  integer *iwork;

  integer n;
  integer c__9;
  integer c__0;
  integer ldq;
  integer ldvt;
  integer ldiq;
  integer lwork;
  integer ldu;
  integer smlsiz;

  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  u, vt, q, iq, info, d, e = NumRu::Lapack.sbdsdc( uplo, compq, d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SBDSDC computes the singular value decomposition (SVD) of a real\n*  N-by-N (upper or lower) bidiagonal matrix B:  B = U * S * VT,\n*  using a divide and conquer method, where S is a diagonal matrix\n*  with non-negative diagonal elements (the singular values of B), and\n*  U and VT are orthogonal matrices of left and right singular vectors,\n*  respectively. SBDSDC can be used to compute all singular values,\n*  and optionally, singular vectors or singular vectors in compact form.\n*\n*  This code makes very mild assumptions about floating point\n*  arithmetic. It will work on machines with a guard digit in\n*  add/subtract, or on those binary machines without guard digits\n*  which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n*  It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.  See SLASD3 for details.\n*\n*  The code currently calls SLASDQ if singular values only are desired.\n*  However, it can be slightly modified to compute singular values\n*  using the divide and conquer method.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  B is upper bidiagonal.\n*          = 'L':  B is lower bidiagonal.\n*\n*  COMPQ   (input) CHARACTER*1\n*          Specifies whether singular vectors are to be computed\n*          as follows:\n*          = 'N':  Compute singular values only;\n*          = 'P':  Compute singular values and compute singular\n*                  vectors in compact form;\n*          = 'I':  Compute singular values and singular vectors.\n*\n*  N       (input) INTEGER\n*          The order of the matrix B.  N >= 0.\n*\n*  D       (input/output) REAL array, dimension (N)\n*          On entry, the n diagonal elements of the bidiagonal matrix B.\n*          On exit, if INFO=0, the singular values of B.\n*\n*  E       (input/output) REAL array, dimension (N-1)\n*          On entry, the elements of E contain the offdiagonal\n*          elements of the bidiagonal matrix whose SVD is desired.\n*          On exit, E has been destroyed.\n*\n*  U       (output) REAL array, dimension (LDU,N)\n*          If  COMPQ = 'I', then:\n*             On exit, if INFO = 0, U contains the left singular vectors\n*             of the bidiagonal matrix.\n*          For other values of COMPQ, U is not referenced.\n*\n*  LDU     (input) INTEGER\n*          The leading dimension of the array U.  LDU >= 1.\n*          If singular vectors are desired, then LDU >= max( 1, N ).\n*\n*  VT      (output) REAL array, dimension (LDVT,N)\n*          If  COMPQ = 'I', then:\n*             On exit, if INFO = 0, VT' contains the right singular\n*             vectors of the bidiagonal matrix.\n*          For other values of COMPQ, VT is not referenced.\n*\n*  LDVT    (input) INTEGER\n*          The leading dimension of the array VT.  LDVT >= 1.\n*          If singular vectors are desired, then LDVT >= max( 1, N ).\n*\n*  Q       (output) REAL array, dimension (LDQ)\n*          If  COMPQ = 'P', then:\n*             On exit, if INFO = 0, Q and IQ contain the left\n*             and right singular vectors in a compact form,\n*             requiring O(N log N) space instead of 2*N**2.\n*             In particular, Q contains all the REAL data in\n*             LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))\n*             words of memory, where SMLSIZ is returned by ILAENV and\n*             is equal to the maximum size of the subproblems at the\n*             bottom of the computation tree (usually about 25).\n*          For other values of COMPQ, Q is not referenced.\n*\n*  IQ      (output) INTEGER array, dimension (LDIQ)\n*          If  COMPQ = 'P', then:\n*             On exit, if INFO = 0, Q and IQ contain the left\n*             and right singular vectors in a compact form,\n*             requiring O(N log N) space instead of 2*N**2.\n*             In particular, IQ contains all INTEGER data in\n*             LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))\n*             words of memory, where SMLSIZ is returned by ILAENV and\n*             is equal to the maximum size of the subproblems at the\n*             bottom of the computation tree (usually about 25).\n*          For other values of COMPQ, IQ is not referenced.\n*\n*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK))\n*          If COMPQ = 'N' then LWORK >= (4 * N).\n*          If COMPQ = 'P' then LWORK >= (6 * N).\n*          If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N).\n*\n*  IWORK   (workspace) INTEGER array, dimension (8*N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit.\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          > 0:  The algorithm failed to compute a singular value.\n*                The update process of divide and conquer failed.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*  =====================================================================\n*  Changed dimension statement in comment describing E from (N) to\n*  (N-1).  Sven, 17 Feb 05.\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  u, vt, q, iq, info, d, e = NumRu::Lapack.sbdsdc( uplo, compq, d, e, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_compq = argv[1];
  rblapack_d = argv[2];
  rblapack_e = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  c__9 = 9;
  compq = StringValueCStr(rblapack_compq)[0];
  c__0 = 0;
  ldvt = lsame_(&compq,"I") ? MAX(1,n) : 0;
  lwork = lsame_(&compq,"N") ? 4*n : lsame_(&compq,"P") ? 6*n : lsame_(&compq,"I") ? 3*n*n+4*n : 0;
  smlsiz = ilaenv_(&c__9, "SBDSDC", " ", &c__0, &c__0, &c__0, &c__0);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (4th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  ldiq = lsame_(&compq,"P") ? n*(3+3*(int)(log(((double)n)/(smlsiz+1))/log(2.0))) : 0;
  ldq = lsame_(&compq,"P") ? n*(11+2*smlsiz+8*(int)(log(((double)n)/(smlsiz+1))/log(2.0))) : 0;
  ldu = lsame_(&compq,"I") ? MAX(1,n) : 0;
  {
    na_shape_t shape[2];
    shape[0] = lsame_(&compq,"I") ? ldu : 0;
    shape[1] = lsame_(&compq,"I") ? n : 0;
    rblapack_u = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  u = NA_PTR_TYPE(rblapack_u, real*);
  {
    na_shape_t shape[2];
    shape[0] = lsame_(&compq,"I") ? ldvt : 0;
    shape[1] = lsame_(&compq,"I") ? n : 0;
    rblapack_vt = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vt = NA_PTR_TYPE(rblapack_vt, real*);
  {
    na_shape_t shape[1];
    shape[0] = lsame_(&compq,"I") ? ldq : 0;
    rblapack_q = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  q = NA_PTR_TYPE(rblapack_q, real*);
  {
    na_shape_t shape[1];
    shape[0] = lsame_(&compq,"I") ? ldiq : 0;
    rblapack_iq = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iq = NA_PTR_TYPE(rblapack_iq, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
  MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  work = ALLOC_N(real, (MAX(1,lwork)));
  iwork = ALLOC_N(integer, (8*n));

  sbdsdc_(&uplo, &compq, &n, d, e, u, &ldu, vt, &ldvt, q, iq, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_u, rblapack_vt, rblapack_q, rblapack_iq, rblapack_info, rblapack_d, rblapack_e);
}

void
init_lapack_sbdsdc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sbdsdc", rblapack_sbdsdc, -1);
}
ruby-lapack-1.7.2/ext/ztftri.c0000644000175000017500000002055212502221013016045 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztftri_(char* transr, char* uplo, char* diag, integer* n, doublecomplex* a, integer* info);


static VALUE
rblapack_ztftri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;


  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  info, a = NumRu::Lapack.ztftri( transr, uplo, diag, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTFTRI( TRANSR, UPLO, DIAG, N, A, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTFTRI computes the inverse of a triangular matrix A stored in RFP\n*  format.\n*\n*  This is a Level 3 BLAS version of the algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR    (input) CHARACTER*1\n*          = 'N':  The Normal TRANSR of RFP A is stored;\n*          = 'C':  The Conjugate-transpose TRANSR of RFP A is stored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension ( N*(N+1)/2 );\n*          On entry, the triangular matrix A in RFP format. RFP format\n*          is described by TRANSR, UPLO, and N as follows: If TRANSR =\n*          'N' then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n*          (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is\n*          the Conjugate-transpose of RFP A as defined when\n*          TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n*          follows: If UPLO = 'U' the RFP A contains the nt elements of\n*          upper packed A; If UPLO = 'L' the RFP A contains the nt\n*          elements of lower packed A. The LDA of RFP A is (N+1)/2 when\n*          TRANSR = 'C'. When TRANSR is 'N' the LDA is N+1 when N is\n*          even and N is odd. See the Note below for more details.\n*\n*          On exit, the (triangular) inverse of the original matrix, in\n*          the same storage format.\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, A(i,i) is exactly zero.  The triangular\n*               matrix is singular and its inverse can not be computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  We first consider Standard Packed Format when N is even.\n*  We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  conjugate-transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  conjugate-transpose of the last three columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                -- -- --\n*        03 04 05                33 43 53\n*                                   -- --\n*        13 14 15                00 44 54\n*                                      --\n*        23 24 25                10 11 55\n*\n*        33 34 35                20 21 22\n*        --\n*        00 44 45                30 31 32\n*        -- --\n*        01 11 55                40 41 42\n*        -- -- --\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- -- --                -- -- -- -- -- --\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     -- -- -- -- --                -- -- -- -- --\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     -- -- -- -- -- --                -- -- -- --\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We next  consider Standard Packed Format when N is odd.\n*  We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  conjugate-transpose of the first two   columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  conjugate-transpose of the last two   columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N odd  and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                   -- --\n*        02 03 04                00 33 43\n*                                      --\n*        12 13 14                10 11 44\n*\n*        22 23 24                20 21 22\n*        --\n*        00 33 34                30 31 32\n*        -- --\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- --                   -- -- -- -- -- --\n*     02 12 22 00 01             00 10 20 30 40 50\n*     -- -- -- --                   -- -- -- -- --\n*     03 13 23 33 11             33 11 21 31 41 51\n*     -- -- -- -- --                   -- -- -- --\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.ztftri( transr, uplo, diag, n, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_diag = argv[2];
  rblapack_n = argv[3];
  rblapack_a = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 1)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  ztftri_(&transr, &uplo, &diag, &n, a, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_ztftri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztftri", rblapack_ztftri, -1);
}
ruby-lapack-1.7.2/ext/zungl2.c0000644000175000017500000001037412502221017015751 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zungl2_(integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* info);


static VALUE
rblapack_zungl2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  doublecomplex *work;

  integer lda;
  integer n;
  integer k;
  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  info, a = NumRu::Lapack.zungl2( a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZUNGL2 generates an m-by-n complex matrix Q with orthonormal rows,\n*  which is defined as the first m rows of a product of k elementary\n*  reflectors of order n\n*\n*        Q  =  H(k)' . . . H(2)' H(1)'\n*\n*  as returned by ZGELQF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. N >= M.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. M >= K >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the i-th row must contain the vector which defines\n*          the elementary reflector H(i), for i = 1,2,...,k, as returned\n*          by ZGELQF in the first k rows of its array argument A.\n*          On exit, the m by n matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) COMPLEX*16 array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by ZGELQF.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (M)\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -i, the i-th argument has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.zungl2( a, tau, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_a = argv[0];
  rblapack_tau = argv[1];
  if (argc == 2) {
  } 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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  m = lda;
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (2th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (2th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(doublecomplex, (m));

  zungl2_(&m, &n, &k, a, &lda, tau, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_zungl2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zungl2", rblapack_zungl2, -1);
}
ruby-lapack-1.7.2/ext/cgbtrf.c0000644000175000017500000001313612502221014015773 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgbtrf_(integer* m, integer* n, integer* kl, integer* ku, complex* ab, integer* ldab, integer* ipiv, integer* info);


static VALUE
rblapack_cgbtrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  complex *ab_out__;

  integer ldab;
  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  ipiv, info, ab = NumRu::Lapack.cgbtrf( m, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGBTRF computes an LU factorization of a complex m-by-n band matrix A\n*  using partial pivoting with row interchanges.\n*\n*  This is the blocked version of the algorithm, calling Level 3 BLAS.\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*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  AB      (input/output) COMPLEX array, dimension (LDAB,N)\n*          On entry, the matrix A in band storage, in rows KL+1 to\n*          2*KL+KU+1; rows 1 to KL of the array need not be set.\n*          The j-th column of A is stored in the j-th column of the\n*          array AB as follows:\n*          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n*          On exit, details of the factorization: U is stored as an\n*          upper triangular band matrix with KL+KU superdiagonals in\n*          rows 1 to KL+KU+1, and the multipliers used during the\n*          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n*          See below for further details.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.\n*\n*  IPIV    (output) INTEGER array, dimension (min(M,N))\n*          The pivot indices; for 1 <= i <= min(M,N), row i of the\n*          matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n*               has been completed, but the factor U is exactly\n*               singular, and division by zero will occur if it is used\n*               to solve a system of equations.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  M = N = 6, KL = 2, KU = 1:\n*\n*  On entry:                       On exit:\n*\n*      *    *    *    +    +    +       *    *    *   u14  u25  u36\n*      *    *    +    +    +    +       *    *   u13  u24  u35  u46\n*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56\n*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66\n*     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *\n*     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *\n*\n*  Array elements marked * are not used by the routine; elements marked\n*  + need not be set on entry, but are required by the routine to store\n*  elements of U because of fill-in resulting from the row interchanges.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, ab = NumRu::Lapack.cgbtrf( m, kl, ku, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_m = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  ku = NUM2INT(rblapack_ku);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
  MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  cgbtrf_(&m, &n, &kl, &ku, ab, &ldab, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_ab);
}

void
init_lapack_cgbtrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgbtrf", rblapack_cgbtrf, -1);
}
ruby-lapack-1.7.2/ext/disnan.c0000644000175000017500000000342312502221023015776 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern logical disnan_(doublereal* din);


static VALUE
rblapack_disnan(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_din;
  doublereal din; 
  VALUE rblapack___out__;
  logical __out__; 


  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  __out__ = NumRu::Lapack.disnan( din, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      LOGICAL FUNCTION DISNAN( DIN )\n\n*  Purpose\n*  =======\n*\n*  DISNAN returns .TRUE. if its argument is NaN, and .FALSE.\n*  otherwise.  To be replaced by the Fortran 2003 intrinsic in the\n*  future.\n*\n\n*  Arguments\n*  =========\n*\n*  DIN     (input) DOUBLE PRECISION\n*          Input to test for NaN.\n*\n\n*  =====================================================================\n*\n*  .. External Functions ..\n      LOGICAL DLAISNAN\n      EXTERNAL DLAISNAN\n*  ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.disnan( din, [: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_din = argv[0];
  if (argc == 1) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  din = NUM2DBL(rblapack_din);

  __out__ = disnan_(&din);

  rblapack___out__ = __out__ ? Qtrue : Qfalse;
  return rblapack___out__;
}

void
init_lapack_disnan(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "disnan", rblapack_disnan, -1);
}
ruby-lapack-1.7.2/ext/zggsvp.c0000644000175000017500000002404712502221025016051 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zggsvp_(char* jobu, char* jobv, char* jobq, integer* m, integer* p, integer* n, doublecomplex* a, integer* lda, doublecomplex* b, integer* ldb, doublereal* tola, doublereal* tolb, integer* k, integer* l, doublecomplex* u, integer* ldu, doublecomplex* v, integer* ldv, doublecomplex* q, integer* ldq, integer* iwork, doublereal* rwork, doublecomplex* tau, doublecomplex* work, integer* info);


static VALUE
rblapack_zggsvp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobu;
  char jobu; 
  VALUE rblapack_jobv;
  char jobv; 
  VALUE rblapack_jobq;
  char jobq; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_tola;
  doublereal tola; 
  VALUE rblapack_tolb;
  doublereal tolb; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_u;
  doublecomplex *u; 
  VALUE rblapack_v;
  doublecomplex *v; 
  VALUE rblapack_q;
  doublecomplex *q; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  integer *iwork;
  doublereal *rwork;
  doublecomplex *tau;
  doublecomplex *work;

  integer lda;
  integer n;
  integer ldb;
  integer ldu;
  integer m;
  integer ldv;
  integer p;
  integer ldq;

  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  k, l, u, v, q, info, a, b = NumRu::Lapack.zggsvp( jobu, jobv, jobq, a, b, tola, tolb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, RWORK, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGGSVP computes unitary matrices U, V and Q such that\n*\n*                   N-K-L  K    L\n*   U'*A*Q =     K ( 0    A12  A13 )  if M-K-L >= 0;\n*                L ( 0     0   A23 )\n*            M-K-L ( 0     0    0  )\n*\n*                   N-K-L  K    L\n*          =     K ( 0    A12  A13 )  if M-K-L < 0;\n*              M-K ( 0     0   A23 )\n*\n*                 N-K-L  K    L\n*   V'*B*Q =   L ( 0     0   B13 )\n*            P-L ( 0     0    0  )\n*\n*  where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular\n*  upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,\n*  otherwise A23 is (M-K)-by-L upper trapezoidal.  K+L = the effective\n*  numerical rank of the (M+P)-by-N matrix (A',B')'.  Z' denotes the\n*  conjugate transpose of Z.\n*\n*  This decomposition is the preprocessing step for computing the\n*  Generalized Singular Value Decomposition (GSVD), see subroutine\n*  ZGGSVD.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBU    (input) CHARACTER*1\n*          = 'U':  Unitary matrix U is computed;\n*          = 'N':  U is not computed.\n*\n*  JOBV    (input) CHARACTER*1\n*          = 'V':  Unitary matrix V is computed;\n*          = 'N':  V is not computed.\n*\n*  JOBQ    (input) CHARACTER*1\n*          = 'Q':  Unitary matrix Q is computed;\n*          = 'N':  Q is not computed.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.  M >= 0.\n*\n*  P       (input) INTEGER\n*          The number of rows of the matrix B.  P >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrices A and B.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, A contains the triangular (or trapezoidal) matrix\n*          described in the Purpose section.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,N)\n*          On entry, the P-by-N matrix B.\n*          On exit, B contains the triangular matrix described in\n*          the Purpose section.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,P).\n*\n*  TOLA    (input) DOUBLE PRECISION\n*  TOLB    (input) DOUBLE PRECISION\n*          TOLA and TOLB are the thresholds to determine the effective\n*          numerical rank of matrix B and a subblock of A. Generally,\n*          they are set to\n*             TOLA = MAX(M,N)*norm(A)*MAZHEPS,\n*             TOLB = MAX(P,N)*norm(B)*MAZHEPS.\n*          The size of TOLA and TOLB may affect the size of backward\n*          errors of the decomposition.\n*\n*  K       (output) INTEGER\n*  L       (output) INTEGER\n*          On exit, K and L specify the dimension of the subblocks\n*          described in Purpose section.\n*          K + L = effective numerical rank of (A',B')'.\n*\n*  U       (output) COMPLEX*16 array, dimension (LDU,M)\n*          If JOBU = 'U', U contains the unitary matrix U.\n*          If JOBU = 'N', U is not referenced.\n*\n*  LDU     (input) INTEGER\n*          The leading dimension of the array U. LDU >= max(1,M) if\n*          JOBU = 'U'; LDU >= 1 otherwise.\n*\n*  V       (output) COMPLEX*16 array, dimension (LDV,P)\n*          If JOBV = 'V', V contains the unitary matrix V.\n*          If JOBV = 'N', V is not referenced.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V. LDV >= max(1,P) if\n*          JOBV = 'V'; LDV >= 1 otherwise.\n*\n*  Q       (output) COMPLEX*16 array, dimension (LDQ,N)\n*          If JOBQ = 'Q', Q contains the unitary matrix Q.\n*          If JOBQ = 'N', Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q. LDQ >= max(1,N) if\n*          JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n*  TAU     (workspace) COMPLEX*16 array, dimension (N)\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (max(3*N,M,P))\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 subroutine uses LAPACK subroutine ZGEQPF for the QR factorization\n*  with column pivoting to detect the effective numerical rank of the\n*  a matrix. It may be replaced by a better rank determination strategy.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  k, l, u, v, q, info, a, b = NumRu::Lapack.zggsvp( jobu, jobv, jobq, a, b, tola, tolb, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_jobu = argv[0];
  rblapack_jobv = argv[1];
  rblapack_jobq = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  rblapack_tola = argv[5];
  rblapack_tolb = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobu = StringValueCStr(rblapack_jobu)[0];
  jobq = StringValueCStr(rblapack_jobq)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  tolb = NUM2DBL(rblapack_tolb);
  p = ldb;
  jobv = StringValueCStr(rblapack_jobv)[0];
  tola = NUM2DBL(rblapack_tola);
  ldv = lsame_(&jobv,"V") ? MAX(1,p) : 1;
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  ldq = lsame_(&jobq,"Q") ? MAX(1,n) : 1;
  m = lda;
  ldu = lsame_(&jobu,"U") ? MAX(1,m) : 1;
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = m;
    rblapack_u = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  u = NA_PTR_TYPE(rblapack_u, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = p;
    rblapack_v = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  v = NA_PTR_TYPE(rblapack_v, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  q = NA_PTR_TYPE(rblapack_q, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  iwork = ALLOC_N(integer, (n));
  rwork = ALLOC_N(doublereal, (2*n));
  tau = ALLOC_N(doublecomplex, (n));
  work = ALLOC_N(doublecomplex, (MAX(3*n,m)*(p)));

  zggsvp_(&jobu, &jobv, &jobq, &m, &p, &n, a, &lda, b, &ldb, &tola, &tolb, &k, &l, u, &ldu, v, &ldv, q, &ldq, iwork, rwork, tau, work, &info);

  free(iwork);
  free(rwork);
  free(tau);
  free(work);
  rblapack_k = INT2NUM(k);
  rblapack_l = INT2NUM(l);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_k, rblapack_l, rblapack_u, rblapack_v, rblapack_q, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_zggsvp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zggsvp", rblapack_zggsvp, -1);
}
ruby-lapack-1.7.2/ext/dgelsy.c0000644000175000017500000002420512502221022016011 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgelsy_(integer* m, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* b, integer* ldb, integer* jpvt, doublereal* rcond, integer* rank, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dgelsy(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_jpvt;
  integer *jpvt; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_rank;
  integer rank; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;
  VALUE rblapack_jpvt_out__;
  integer *jpvt_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  rank, work, info, a, b, jpvt = NumRu::Lapack.dgelsy( a, b, jpvt, rcond, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGELSY computes the minimum-norm solution to a real linear least\n*  squares problem:\n*      minimize || A * X - B ||\n*  using a complete orthogonal factorization of A.  A is an M-by-N\n*  matrix which may be rank-deficient.\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*  The routine first computes a QR factorization with column pivoting:\n*      A * P = Q * [ R11 R12 ]\n*                  [  0  R22 ]\n*  with R11 defined as the largest leading submatrix whose estimated\n*  condition number is less than 1/RCOND.  The order of R11, RANK,\n*  is the effective rank of A.\n*\n*  Then, R22 is considered to be negligible, and R12 is annihilated\n*  by orthogonal transformations from the right, arriving at the\n*  complete orthogonal factorization:\n*     A * P = Q * [ T11 0 ] * Z\n*                 [  0  0 ]\n*  The minimum-norm solution is then\n*     X = P * Z' [ inv(T11)*Q1'*B ]\n*                [        0       ]\n*  where Q1 consists of the first RANK columns of Q.\n*\n*  This routine is basically identical to the original xGELSX except\n*  three differences:\n*    o The call to the subroutine xGEQPF has been substituted by the\n*      the call to the subroutine xGEQP3. This subroutine is a Blas-3\n*      version of the QR factorization with column pivoting.\n*    o Matrix B (the right hand side) is updated with Blas-3.\n*    o The permutation of matrix B (the right hand side) is faster and\n*      more simple.\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*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of\n*          columns of 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, A has been overwritten by details of its\n*          complete orthogonal factorization.\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 M-by-NRHS right hand side matrix B.\n*          On exit, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,M,N).\n*\n*  JPVT    (input/output) INTEGER array, dimension (N)\n*          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n*          to the front of AP, otherwise column i is a free column.\n*          On exit, if JPVT(i) = k, then the i-th column of AP\n*          was the k-th column of A.\n*\n*  RCOND   (input) DOUBLE PRECISION\n*          RCOND is used to determine the effective rank of A, which\n*          is defined as the order of the largest leading triangular\n*          submatrix R11 in the QR factorization with pivoting of A,\n*          whose estimated condition number < 1/RCOND.\n*\n*  RANK    (output) INTEGER\n*          The effective rank of A, i.e., the order of the submatrix\n*          R11.  This is the same as the order of the submatrix T11\n*          in the complete orthogonal factorization of A.\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*          The unblocked strategy requires that:\n*             LWORK >= MAX( MN+3*N+1, 2*MN+NRHS ),\n*          where MN = min( M, N ).\n*          The block algorithm requires that:\n*             LWORK >= MAX( MN+2*N+NB*(N+1), 2*MN+NB*NRHS ),\n*          where NB is an upper bound on the blocksize returned\n*          by ILAENV for the routines DGEQP3, DTZRZF, STZRQF, DORMQR,\n*          and DORMRZ.\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*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*    E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n*    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rank, work, info, a, b, jpvt = NumRu::Lapack.dgelsy( a, b, jpvt, rcond, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  rblapack_jpvt = argv[2];
  rblapack_rcond = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } 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 (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*);
  if (!NA_IsNArray(rblapack_jpvt))
    rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
  if (NA_RANK(rblapack_jpvt) != 1)
    rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_jpvt) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_jpvt) != NA_LINT)
    rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
  jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
  m = lda;
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th 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 = MAX(MIN(m,n)+3*n+1, 2*MIN(m,n)+nrhs);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  rcond = NUM2DBL(rblapack_rcond);
  ldb = MAX(m,n);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;
  {
    na_shape_t 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__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
  MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
  rblapack_jpvt = rblapack_jpvt_out__;
  jpvt = jpvt_out__;

  dgelsy_(&m, &n, &nrhs, a, &lda, b, &ldb, jpvt, &rcond, &rank, work, &lwork, &info);

  rblapack_rank = INT2NUM(rank);
  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(6, rblapack_rank, rblapack_work, rblapack_info, rblapack_a, rblapack_b, rblapack_jpvt);
}

void
init_lapack_dgelsy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgelsy", rblapack_dgelsy, -1);
}
ruby-lapack-1.7.2/ext/dgglse.c0000644000175000017500000002244012502221017015772 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgglse_(integer* m, integer* n, integer* p, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* c, doublereal* d, doublereal* x, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dgglse(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;
  VALUE rblapack_c_out__;
  doublereal *c_out__;
  VALUE rblapack_d_out__;
  doublereal *d_out__;

  integer lda;
  integer n;
  integer ldb;
  integer m;
  integer p;

  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  x, work, info, a, b, c, d = NumRu::Lapack.dgglse( a, b, c, d, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGGLSE solves the linear equality-constrained least squares (LSE)\n*  problem:\n*\n*          minimize || c - A*x ||_2   subject to   B*x = d\n*\n*  where A is an M-by-N matrix, B is a P-by-N matrix, c is a given\n*  M-vector, and d is a given P-vector. It is assumed that\n*  P <= N <= M+P, and\n*\n*           rank(B) = P and  rank( (A) ) = N.\n*                                ( (B) )\n*\n*  These conditions ensure that the LSE problem has a unique solution,\n*  which is obtained using a generalized RQ factorization of the\n*  matrices (B, A) given by\n*\n*     B = (0 R)*Q,   A = Z*T*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 matrices A and B. N >= 0.\n*\n*  P       (input) INTEGER\n*          The number of rows of the matrix B. 0 <= P <= N <= M+P.\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 above the diagonal of the array\n*          contain the min(M,N)-by-N upper trapezoidal matrix T.\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,N)\n*          On entry, the P-by-N matrix B.\n*          On exit, the upper triangle of the subarray B(1:P,N-P+1:N)\n*          contains the P-by-P upper triangular matrix R.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,P).\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (M)\n*          On entry, C contains the right hand side vector for the\n*          least squares part of the LSE problem.\n*          On exit, the residual sum of squares for the solution\n*          is given by the sum of squares of elements N-P+1 to M of\n*          vector C.\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (P)\n*          On entry, D contains the right hand side vector for the\n*          constrained equation.\n*          On exit, D is destroyed.\n*\n*  X       (output) DOUBLE PRECISION array, dimension (N)\n*          On exit, X is the solution of the LSE problem.\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+P).\n*          For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,\n*          where NB is an upper bound for the optimal blocksizes for\n*          DGEQRF, SGERQF, DORMQR and SORMRQ.\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*          = 1:  the upper triangular factor R associated with B in the\n*                generalized RQ factorization of the pair (B, A) is\n*                singular, so that rank(B) < P; the least squares\n*                solution could not be computed.\n*          = 2:  the (N-P) by (N-P) part of the upper trapezoidal factor\n*                T associated with A in the generalized RQ factorization\n*                of the pair (B, A) is singular, so that\n*                rank( (A) ) < N; the least squares solution could not\n*                    ( (B) )\n*                be computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, work, info, a, b, c, d = NumRu::Lapack.dgglse( a, b, c, d, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  rblapack_c = argv[2];
  rblapack_d = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } 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 (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*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (3th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (3th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  p = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (rblapack_lwork == Qnil)
    lwork = m+n+p;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_x = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[1];
    shape[0] = p;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;

  dgglse_(&m, &n, &p, a, &lda, b, &ldb, c, d, x, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_x, rblapack_work, rblapack_info, rblapack_a, rblapack_b, rblapack_c, rblapack_d);
}

void
init_lapack_dgglse(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgglse", rblapack_dgglse, -1);
}
ruby-lapack-1.7.2/ext/zhpevx.c0000644000175000017500000002355312502221023016054 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhpevx_(char* jobz, char* range, char* uplo, integer* n, doublecomplex* ap, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublecomplex* z, integer* ldz, doublecomplex* work, doublereal* rwork, integer* iwork, integer* ifail, integer* info);


static VALUE
rblapack_zhpevx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_vl;
  doublereal vl; 
  VALUE rblapack_vu;
  doublereal vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  doublereal abstol; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_ifail;
  integer *ifail; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublecomplex *ap_out__;
  doublecomplex *work;
  doublereal *rwork;
  integer *iwork;

  integer ldap;
  integer n;
  integer ldz;

  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  m, w, z, ifail, info, ap = NumRu::Lapack.zhpevx( jobz, range, uplo, ap, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHPEVX computes selected eigenvalues and, optionally, eigenvectors\n*  of a complex Hermitian matrix A in packed storage.\n*  Eigenvalues/vectors can be selected by specifying either a range of\n*  values or a range of indices for the desired eigenvalues.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found;\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found;\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, AP is overwritten by values generated during the\n*          reduction to tridiagonal form.  If UPLO = 'U', the diagonal\n*          and first superdiagonal of the tridiagonal matrix T overwrite\n*          the corresponding elements of A, and if UPLO = 'L', the\n*          diagonal and first subdiagonal of T overwrite the\n*          corresponding elements of A.\n*\n*  VL      (input) DOUBLE PRECISION\n*  VU      (input) DOUBLE PRECISION\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) DOUBLE PRECISION\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less than\n*          or equal to zero, then  EPS*|T|  will be used in its place,\n*          where |T| is the 1-norm of the tridiagonal matrix obtained\n*          by reducing AP to tridiagonal form.\n*\n*          Eigenvalues will be computed most accurately when ABSTOL is\n*          set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n*          If this routine returns with INFO>0, indicating that some\n*          eigenvectors did not converge, try setting ABSTOL to\n*          2*DLAMCH('S').\n*\n*          See \"Computing Small Singular Values of Bidiagonal Matrices\n*          with Guaranteed High Relative Accuracy,\" by Demmel and\n*          Kahan, LAPACK Working Note #3.\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, the selected eigenvalues in ascending order.\n*\n*  Z       (output) COMPLEX*16 array, dimension (LDZ, max(1,M))\n*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix A\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          If an eigenvector fails to converge, then that column of Z\n*          contains the latest approximation to the eigenvector, and\n*          the index of the eigenvector is returned in IFAIL.\n*          If JOBZ = 'N', then Z is not referenced.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (7*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (5*N)\n*\n*  IFAIL   (output) INTEGER array, dimension (N)\n*          If JOBZ = 'V', then if INFO = 0, the first M elements of\n*          IFAIL are zero.  If INFO > 0, then IFAIL contains the\n*          indices of the eigenvectors that failed to converge.\n*          If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n*                Their indices are stored in array IFAIL.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, ifail, info, ap = NumRu::Lapack.zhpevx( jobz, range, uplo, ap, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_uplo = argv[2];
  rblapack_ap = argv[3];
  rblapack_vl = argv[4];
  rblapack_vu = argv[5];
  rblapack_il = argv[6];
  rblapack_iu = argv[7];
  rblapack_abstol = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  vl = NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  abstol = NUM2DBL(rblapack_abstol);
  range = StringValueCStr(rblapack_range)[0];
  vu = NUM2DBL(rblapack_vu);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  iu = NUM2INT(rblapack_iu);
  m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
  MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (7*n));
  iwork = ALLOC_N(integer, (5*n));

  zhpevx_(&jobz, &range, &uplo, &n, ap, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, rwork, iwork, ifail, &info);

  free(work);
  free(rwork);
  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_ap);
}

void
init_lapack_zhpevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhpevx", rblapack_zhpevx, -1);
}
ruby-lapack-1.7.2/ext/cgees.c0000644000175000017500000002073012502221016015612 0ustar  uwabamiuwabami#include "rb_lapack.h"

static logical
rblapack_select(complex *arg0){
  VALUE rblapack_arg0;

  VALUE rblapack_ret;
  logical ret;

  rblapack_arg0 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(arg0->r)), rb_float_new((double)(arg0->i)));

  rblapack_ret = rb_yield_values(1, rblapack_arg0);

  ret = (rblapack_ret == Qtrue);
  return ret;
}

extern VOID cgees_(char* jobvs, char* sort, L_fp select, integer* n, complex* a, integer* lda, integer* sdim, complex* w, complex* vs, integer* ldvs, complex* work, integer* lwork, real* rwork, logical* bwork, integer* info);


static VALUE
rblapack_cgees(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvs;
  char jobvs; 
  VALUE rblapack_sort;
  char sort; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_sdim;
  integer sdim; 
  VALUE rblapack_w;
  complex *w; 
  VALUE rblapack_vs;
  complex *vs; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  real *rwork;
  logical *bwork;

  integer lda;
  integer n;
  integer ldvs;

  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  sdim, w, vs, work, info, a = NumRu::Lapack.cgees( jobvs, sort, a, [:lwork => lwork, :usage => usage, :help => help]){|a| ... }\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS, LDVS, WORK, LWORK, RWORK, BWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGEES computes for an N-by-N complex nonsymmetric matrix A, the\n*  eigenvalues, the Schur form T, and, optionally, the matrix of Schur\n*  vectors Z.  This gives the Schur factorization A = Z*T*(Z**H).\n*\n*  Optionally, it also orders the eigenvalues on the diagonal of the\n*  Schur form so that selected eigenvalues are at the top left.\n*  The leading columns of Z then form an orthonormal basis for the\n*  invariant subspace corresponding to the selected eigenvalues.\n\n*  A complex matrix is in Schur form if it is upper triangular.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVS   (input) CHARACTER*1\n*          = 'N': Schur vectors are not computed;\n*          = 'V': Schur vectors are computed.\n*\n*  SORT    (input) CHARACTER*1\n*          Specifies whether or not to order the eigenvalues on the\n*          diagonal of the Schur form.\n*          = 'N': Eigenvalues are not ordered:\n*          = 'S': Eigenvalues are ordered (see SELECT).\n*\n*  SELECT  (external procedure) LOGICAL FUNCTION of one COMPLEX argument\n*          SELECT must be declared EXTERNAL in the calling subroutine.\n*          If SORT = 'S', SELECT is used to select eigenvalues to order\n*          to the top left of the Schur form.\n*          IF SORT = 'N', SELECT is not referenced.\n*          The eigenvalue W(j) is selected if SELECT(W(j)) is true.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the N-by-N matrix A.\n*          On exit, A has been overwritten by its Schur form T.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  SDIM    (output) INTEGER\n*          If SORT = 'N', SDIM = 0.\n*          If SORT = 'S', SDIM = number of eigenvalues for which\n*                         SELECT is true.\n*\n*  W       (output) COMPLEX array, dimension (N)\n*          W contains the computed eigenvalues, in the same order that\n*          they appear on the diagonal of the output Schur form T.\n*\n*  VS      (output) COMPLEX array, dimension (LDVS,N)\n*          If JOBVS = 'V', VS contains the unitary matrix Z of Schur\n*          vectors.\n*          If JOBVS = 'N', VS is not referenced.\n*\n*  LDVS    (input) INTEGER\n*          The leading dimension of the array VS.  LDVS >= 1; if\n*          JOBVS = 'V', LDVS >= N.\n*\n*  WORK    (workspace/output) COMPLEX 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,2*N).\n*          For good performance, LWORK must generally be larger.\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*  RWORK   (workspace) REAL array, dimension (N)\n*\n*  BWORK   (workspace) LOGICAL array, dimension (N)\n*          Not referenced if SORT = 'N'.\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, and i is\n*               <= N:  the QR algorithm failed to compute all the\n*                      eigenvalues; elements 1:ILO-1 and i+1:N of W\n*                      contain those eigenvalues which have converged;\n*                      if JOBVS = 'V', VS contains the matrix which\n*                      reduces A to its partially converged Schur form.\n*               = N+1: the eigenvalues could not be reordered because\n*                      some eigenvalues were too close to separate (the\n*                      problem is very ill-conditioned);\n*               = N+2: after reordering, roundoff changed values of\n*                      some complex eigenvalues so that leading\n*                      eigenvalues in the Schur form no longer satisfy\n*                      SELECT = .TRUE..  This could also be caused by\n*                      underflow due to scaling.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sdim, w, vs, work, info, a = NumRu::Lapack.cgees( jobvs, sort, a, [:lwork => lwork, :usage => usage, :help => help]){|a| ... }\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_jobvs = argv[0];
  rblapack_sort = argv[1];
  rblapack_a = 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;
  }

  jobvs = StringValueCStr(rblapack_jobvs)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  ldvs = lsame_(&jobvs,"V") ? n : 1;
  sort = StringValueCStr(rblapack_sort)[0];
  if (rblapack_lwork == Qnil)
    lwork = 2*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvs;
    shape[1] = n;
    rblapack_vs = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  vs = NA_PTR_TYPE(rblapack_vs, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  rwork = ALLOC_N(real, (n));
  bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));

  cgees_(&jobvs, &sort, rblapack_select, &n, a, &lda, &sdim, w, vs, &ldvs, work, &lwork, rwork, bwork, &info);

  free(rwork);
  free(bwork);
  rblapack_sdim = INT2NUM(sdim);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_sdim, rblapack_w, rblapack_vs, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_cgees(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgees", rblapack_cgees, -1);
}
ruby-lapack-1.7.2/ext/dpoequ.c0000644000175000017500000001011312502221014016011 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dpoequ_(integer* n, doublereal* a, integer* lda, doublereal* s, doublereal* scond, doublereal* amax, integer* info);


static VALUE
rblapack_dpoequ(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_scond;
  doublereal scond; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_info;
  integer info; 

  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  s, scond, amax, info = NumRu::Lapack.dpoequ( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPOEQU computes row and column scalings intended to equilibrate a\n*  symmetric positive definite matrix A and reduce its condition number\n*  (with respect to the two-norm).  S contains the scale factors,\n*  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n*  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This\n*  choice of S puts the condition number of B within a factor N of the\n*  smallest possible condition number over all possible diagonal\n*  scalings.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*          The N-by-N symmetric positive definite matrix whose scaling\n*          factors are to be computed.  Only the diagonal elements of A\n*          are referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  S       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, S contains the scale factors for A.\n*\n*  SCOND   (output) DOUBLE PRECISION\n*          If INFO = 0, S contains the ratio of the smallest S(i) to\n*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too\n*          large nor too small, it is not worth scaling by S.\n*\n*  AMAX    (output) DOUBLE PRECISION\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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 is nonpositive.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, scond, amax, info = NumRu::Lapack.dpoequ( 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*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, doublereal*);

  dpoequ_(&n, a, &lda, s, &scond, &amax, &info);

  rblapack_scond = rb_float_new((double)scond);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
}

void
init_lapack_dpoequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dpoequ", rblapack_dpoequ, -1);
}
ruby-lapack-1.7.2/ext/zlags2.c0000644000175000017500000001272712502221020015730 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlags2_(logical* upper, doublereal* a1, doublecomplex* a2, doublereal* a3, doublereal* b1, doublecomplex* b2, doublereal* b3, doublereal* csu, doublecomplex* snu, doublereal* csv, doublecomplex* snv, doublereal* csq, doublecomplex* snq);


static VALUE
rblapack_zlags2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_upper;
  logical upper; 
  VALUE rblapack_a1;
  doublereal a1; 
  VALUE rblapack_a2;
  doublecomplex a2; 
  VALUE rblapack_a3;
  doublereal a3; 
  VALUE rblapack_b1;
  doublereal b1; 
  VALUE rblapack_b2;
  doublecomplex b2; 
  VALUE rblapack_b3;
  doublereal b3; 
  VALUE rblapack_csu;
  doublereal csu; 
  VALUE rblapack_snu;
  doublecomplex snu; 
  VALUE rblapack_csv;
  doublereal csv; 
  VALUE rblapack_snv;
  doublecomplex snv; 
  VALUE rblapack_csq;
  doublereal csq; 
  VALUE rblapack_snq;
  doublecomplex snq; 


  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  csu, snu, csv, snv, csq, snq = NumRu::Lapack.zlags2( upper, a1, a2, a3, b1, b2, b3, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, SNV, CSQ, SNQ )\n\n*  Purpose\n*  =======\n*\n*  ZLAGS2 computes 2-by-2 unitary matrices U, V and Q, such\n*  that if ( UPPER ) then\n*\n*            U'*A*Q = U'*( A1 A2 )*Q = ( x  0  )\n*                        ( 0  A3 )     ( x  x  )\n*  and\n*            V'*B*Q = V'*( B1 B2 )*Q = ( x  0  )\n*                        ( 0  B3 )     ( x  x  )\n*\n*  or if ( .NOT.UPPER ) then\n*\n*            U'*A*Q = U'*( A1 0  )*Q = ( x  x  )\n*                        ( A2 A3 )     ( 0  x  )\n*  and\n*            V'*B*Q = V'*( B1 0  )*Q = ( x  x  )\n*                        ( B2 B3 )     ( 0  x  )\n*  where\n*\n*    U = (     CSU      SNU ), V = (     CSV     SNV ),\n*        ( -CONJG(SNU)  CSU )      ( -CONJG(SNV) CSV )\n*\n*    Q = (     CSQ      SNQ )\n*        ( -CONJG(SNQ)  CSQ )\n*\n*  Z' denotes the conjugate transpose of Z.\n*\n*  The rows of the transformed A and B are parallel. Moreover, if the\n*  input 2-by-2 matrix A is not zero, then the transformed (1,1) entry\n*  of A is not zero. If the input matrices A and B are both not zero,\n*  then the transformed (2,2) element of B is not zero, except when the\n*  first rows of input A and B are parallel and the second rows are\n*  zero.\n*\n\n*  Arguments\n*  =========\n*\n*  UPPER   (input) LOGICAL\n*          = .TRUE.: the input matrices A and B are upper triangular.\n*          = .FALSE.: the input matrices A and B are lower triangular.\n*\n*  A1      (input) DOUBLE PRECISION\n*  A2      (input) COMPLEX*16\n*  A3      (input) DOUBLE PRECISION\n*          On entry, A1, A2 and A3 are elements of the input 2-by-2\n*          upper (lower) triangular matrix A.\n*\n*  B1      (input) DOUBLE PRECISION\n*  B2      (input) COMPLEX*16\n*  B3      (input) DOUBLE PRECISION\n*          On entry, B1, B2 and B3 are elements of the input 2-by-2\n*          upper (lower) triangular matrix B.\n*\n*  CSU     (output) DOUBLE PRECISION\n*  SNU     (output) COMPLEX*16\n*          The desired unitary matrix U.\n*\n*  CSV     (output) DOUBLE PRECISION\n*  SNV     (output) COMPLEX*16\n*          The desired unitary matrix V.\n*\n*  CSQ     (output) DOUBLE PRECISION\n*  SNQ     (output) COMPLEX*16\n*          The desired unitary matrix Q.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  csu, snu, csv, snv, csq, snq = NumRu::Lapack.zlags2( upper, a1, a2, a3, b1, b2, b3, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_upper = argv[0];
  rblapack_a1 = argv[1];
  rblapack_a2 = argv[2];
  rblapack_a3 = argv[3];
  rblapack_b1 = argv[4];
  rblapack_b2 = argv[5];
  rblapack_b3 = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  upper = (rblapack_upper == Qtrue);
  a2.r = NUM2DBL(rb_funcall(rblapack_a2, rb_intern("real"), 0));
  a2.i = NUM2DBL(rb_funcall(rblapack_a2, rb_intern("imag"), 0));
  b1 = NUM2DBL(rblapack_b1);
  b3 = NUM2DBL(rblapack_b3);
  a1 = NUM2DBL(rblapack_a1);
  b2.r = NUM2DBL(rb_funcall(rblapack_b2, rb_intern("real"), 0));
  b2.i = NUM2DBL(rb_funcall(rblapack_b2, rb_intern("imag"), 0));
  a3 = NUM2DBL(rblapack_a3);

  zlags2_(&upper, &a1, &a2, &a3, &b1, &b2, &b3, &csu, &snu, &csv, &snv, &csq, &snq);

  rblapack_csu = rb_float_new((double)csu);
  rblapack_snu = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(snu.r)), rb_float_new((double)(snu.i)));
  rblapack_csv = rb_float_new((double)csv);
  rblapack_snv = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(snv.r)), rb_float_new((double)(snv.i)));
  rblapack_csq = rb_float_new((double)csq);
  rblapack_snq = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(snq.r)), rb_float_new((double)(snq.i)));
  return rb_ary_new3(6, rblapack_csu, rblapack_snu, rblapack_csv, rblapack_snv, rblapack_csq, rblapack_snq);
}

void
init_lapack_zlags2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlags2", rblapack_zlags2, -1);
}
ruby-lapack-1.7.2/ext/ctrevc.c0000644000175000017500000002407612502221024016020 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctrevc_(char* side, char* howmny, logical* select, integer* n, complex* t, integer* ldt, complex* vl, integer* ldvl, complex* vr, integer* ldvr, integer* mm, integer* m, complex* work, real* rwork, integer* info);


static VALUE
rblapack_ctrevc(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_howmny;
  char howmny; 
  VALUE rblapack_select;
  logical *select; 
  VALUE rblapack_t;
  complex *t; 
  VALUE rblapack_vl;
  complex *vl; 
  VALUE rblapack_vr;
  complex *vr; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_t_out__;
  complex *t_out__;
  VALUE rblapack_vl_out__;
  complex *vl_out__;
  VALUE rblapack_vr_out__;
  complex *vr_out__;
  complex *work;
  real *rwork;

  integer n;
  integer ldt;
  integer ldvl;
  integer mm;
  integer ldvr;

  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  m, info, t, vl, vr = NumRu::Lapack.ctrevc( side, howmny, select, t, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTREVC computes some or all of the right and/or left eigenvectors of\n*  a complex upper triangular matrix T.\n*  Matrices of this type are produced by the Schur factorization of\n*  a complex general matrix:  A = Q*T*Q**H, as computed by CHSEQR.\n*  \n*  The right eigenvector x and the left eigenvector y of T corresponding\n*  to an eigenvalue w are defined by:\n*  \n*               T*x = w*x,     (y**H)*T = w*(y**H)\n*  \n*  where y**H denotes the conjugate transpose of the vector y.\n*  The eigenvalues are not input to this routine, but are read directly\n*  from the diagonal of T.\n*  \n*  This routine returns the matrices X and/or Y of right and left\n*  eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an\n*  input matrix.  If Q is the unitary factor that reduces a matrix A to\n*  Schur form T, then Q*X and Q*Y are the matrices of right and left\n*  eigenvectors of A.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'R':  compute right eigenvectors only;\n*          = 'L':  compute left eigenvectors only;\n*          = 'B':  compute both right and left eigenvectors.\n*\n*  HOWMNY  (input) CHARACTER*1\n*          = 'A':  compute all right and/or left eigenvectors;\n*          = 'B':  compute all right and/or left eigenvectors,\n*                  backtransformed using the matrices supplied in\n*                  VR and/or VL;\n*          = 'S':  compute selected right and/or left eigenvectors,\n*                  as indicated by the logical array SELECT.\n*\n*  SELECT  (input) LOGICAL array, dimension (N)\n*          If HOWMNY = 'S', SELECT specifies the eigenvectors to be\n*          computed.\n*          The eigenvector corresponding to the j-th eigenvalue is\n*          computed if SELECT(j) = .TRUE..\n*          Not referenced if HOWMNY = 'A' or 'B'.\n*\n*  N       (input) INTEGER\n*          The order of the matrix T. N >= 0.\n*\n*  T       (input/output) COMPLEX array, dimension (LDT,N)\n*          The upper triangular matrix T.  T is modified, but restored\n*          on exit.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= max(1,N).\n*\n*  VL      (input/output) COMPLEX array, dimension (LDVL,MM)\n*          On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n*          contain an N-by-N matrix Q (usually the unitary matrix Q of\n*          Schur vectors returned by CHSEQR).\n*          On exit, if SIDE = 'L' or 'B', VL contains:\n*          if HOWMNY = 'A', the matrix Y of left eigenvectors of T;\n*          if HOWMNY = 'B', the matrix Q*Y;\n*          if HOWMNY = 'S', the left eigenvectors of T specified by\n*                           SELECT, stored consecutively in the columns\n*                           of VL, in the same order as their\n*                           eigenvalues.\n*          Not referenced if SIDE = 'R'.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the array VL.  LDVL >= 1, and if\n*          SIDE = 'L' or 'B', LDVL >= N.\n*\n*  VR      (input/output) COMPLEX array, dimension (LDVR,MM)\n*          On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n*          contain an N-by-N matrix Q (usually the unitary matrix Q of\n*          Schur vectors returned by CHSEQR).\n*          On exit, if SIDE = 'R' or 'B', VR contains:\n*          if HOWMNY = 'A', the matrix X of right eigenvectors of T;\n*          if HOWMNY = 'B', the matrix Q*X;\n*          if HOWMNY = 'S', the right eigenvectors of T specified by\n*                           SELECT, stored consecutively in the columns\n*                           of VR, in the same order as their\n*                           eigenvalues.\n*          Not referenced if SIDE = 'L'.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the array VR.  LDVR >= 1, and if\n*          SIDE = 'R' or 'B'; LDVR >= N.\n*\n*  MM      (input) INTEGER\n*          The number of columns in the arrays VL and/or VR. MM >= M.\n*\n*  M       (output) INTEGER\n*          The number of columns in the arrays VL and/or VR actually\n*          used to store the eigenvectors.  If HOWMNY = 'A' or 'B', M\n*          is set to N.  Each selected eigenvector occupies one\n*          column.\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\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 algorithm used in this program is basically backward (forward)\n*  substitution, with scaling to make the the code robust against\n*  possible overflow.\n*\n*  Each eigenvector is normalized so that the element of largest\n*  magnitude has magnitude 1; here the magnitude of a complex number\n*  (x,y) is taken to be |x| + |y|.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, info, t, vl, vr = NumRu::Lapack.ctrevc( side, howmny, select, t, vl, vr, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_howmny = argv[1];
  rblapack_select = argv[2];
  rblapack_t = argv[3];
  rblapack_vl = argv[4];
  rblapack_vr = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_select))
    rb_raise(rb_eArgError, "select (3th argument) must be NArray");
  if (NA_RANK(rblapack_select) != 1)
    rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_select);
  if (NA_TYPE(rblapack_select) != NA_LINT)
    rblapack_select = na_change_type(rblapack_select, NA_LINT);
  select = NA_PTR_TYPE(rblapack_select, logical*);
  if (!NA_IsNArray(rblapack_vl))
    rb_raise(rb_eArgError, "vl (5th argument) must be NArray");
  if (NA_RANK(rblapack_vl) != 2)
    rb_raise(rb_eArgError, "rank of vl (5th argument) must be %d", 2);
  ldvl = NA_SHAPE0(rblapack_vl);
  mm = NA_SHAPE1(rblapack_vl);
  if (NA_TYPE(rblapack_vl) != NA_SCOMPLEX)
    rblapack_vl = na_change_type(rblapack_vl, NA_SCOMPLEX);
  vl = NA_PTR_TYPE(rblapack_vl, complex*);
  howmny = StringValueCStr(rblapack_howmny)[0];
  if (!NA_IsNArray(rblapack_vr))
    rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
  if (NA_RANK(rblapack_vr) != 2)
    rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 2);
  ldvr = NA_SHAPE0(rblapack_vr);
  if (NA_SHAPE1(rblapack_vr) != mm)
    rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
  if (NA_TYPE(rblapack_vr) != NA_SCOMPLEX)
    rblapack_vr = na_change_type(rblapack_vr, NA_SCOMPLEX);
  vr = NA_PTR_TYPE(rblapack_vr, complex*);
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (4th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  if (NA_SHAPE1(rblapack_t) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_t) != NA_SCOMPLEX)
    rblapack_t = na_change_type(rblapack_t, NA_SCOMPLEX);
  t = NA_PTR_TYPE(rblapack_t, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = n;
    rblapack_t_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  t_out__ = NA_PTR_TYPE(rblapack_t_out__, complex*);
  MEMCPY(t_out__, t, complex, NA_TOTAL(rblapack_t));
  rblapack_t = rblapack_t_out__;
  t = t_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = mm;
    rblapack_vl_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, complex*);
  MEMCPY(vl_out__, vl, complex, NA_TOTAL(rblapack_vl));
  rblapack_vl = rblapack_vl_out__;
  vl = vl_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = mm;
    rblapack_vr_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  vr_out__ = NA_PTR_TYPE(rblapack_vr_out__, complex*);
  MEMCPY(vr_out__, vr, complex, NA_TOTAL(rblapack_vr));
  rblapack_vr = rblapack_vr_out__;
  vr = vr_out__;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (n));

  ctrevc_(&side, &howmny, select, &n, t, &ldt, vl, &ldvl, vr, &ldvr, &mm, &m, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_m, rblapack_info, rblapack_t, rblapack_vl, rblapack_vr);
}

void
init_lapack_ctrevc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctrevc", rblapack_ctrevc, -1);
}
ruby-lapack-1.7.2/ext/csysv.c0000644000175000017500000002032712502221015015674 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID csysv_(char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, integer* ipiv, complex* b, integer* ldb, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_csysv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  ipiv, work, info, a, b = NumRu::Lapack.csysv( uplo, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CSYSV computes the solution to a complex system of linear equations\n*     A * X = B,\n*  where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n*  matrices.\n*\n*  The diagonal pivoting method is used to factor A as\n*     A = U * D * U**T,  if UPLO = 'U', or\n*     A = L * D * L**T,  if UPLO = 'L',\n*  where U (or L) is a product of permutation and unit upper (lower)\n*  triangular matrices, and D is symmetric and block diagonal with \n*  1-by-1 and 2-by-2 diagonal blocks.  The factored form of A is then\n*  used to solve the system of equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the block diagonal matrix D and the\n*          multipliers used to obtain the factor U or L from the\n*          factorization A = U*D*U**T or A = L*D*L**T as computed by\n*          CSYTRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D, as\n*          determined by CSYTRF.  If IPIV(k) > 0, then rows and columns\n*          k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1\n*          diagonal block.  If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,\n*          then rows and columns k-1 and -IPIV(k) were interchanged and\n*          D(k-1:k,k-1:k) is a 2-by-2 diagonal block.  If UPLO = 'L' and\n*          IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and\n*          -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2\n*          diagonal block.\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  WORK    (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of WORK.  LWORK >= 1, and for best performance\n*          LWORK >= max(1,N*NB), where NB is the optimal blocksize for\n*          CSYTRF.\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, D(i,i) is exactly zero.  The factorization\n*               has been completed, but the block diagonal matrix D is\n*               exactly singular, so the solution could not be computed.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY\n      INTEGER            LWKOPT, NB\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            ILAENV\n      EXTERNAL           ILAENV, LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CSYTRF, CSYTRS2, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, work, info, a, b = NumRu::Lapack.csysv( uplo, 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_uplo = 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;
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  csysv_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_ipiv, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_csysv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "csysv", rblapack_csysv, -1);
}
ruby-lapack-1.7.2/ext/sla_lin_berr.c0000644000175000017500000001063512502221015017161 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sla_lin_berr_(integer* n, integer* nz, integer* nrhs, real* res, real* ayb, real* berr);


static VALUE
rblapack_sla_lin_berr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_nz;
  integer nz; 
  VALUE rblapack_res;
  real *res; 
  VALUE rblapack_ayb;
  real *ayb; 
  VALUE rblapack_berr;
  real *berr; 

  integer n;
  integer nrhs;

  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  berr = NumRu::Lapack.sla_lin_berr( nz, res, ayb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR )\n\n*  Purpose\n*  =======\n*\n*     SLA_LIN_BERR computes componentwise relative backward error from\n*     the formula\n*         max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n*     where abs(Z) is the componentwise absolute value of the matrix\n*     or vector Z.\n*\n\n*  Arguments\n*  ==========\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NZ      (input) INTEGER\n*     We add (NZ+1)*SLAMCH( 'Safe minimum' ) to R(i) in the numerator to\n*     guard against spuriously zero residuals. Default value is N.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices AYB, RES, and BERR.  NRHS >= 0.\n*\n*     RES    (input) REAL array, dimension (N,NRHS)\n*     The residual matrix, i.e., the matrix R in the relative backward\n*     error formula above.\n*\n*     AYB    (input) REAL array, dimension (N, NRHS)\n*     The denominator in the relative backward error formula above, i.e.,\n*     the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B\n*     are from iterative refinement (see sla_gerfsx_extended.f).\n*     \n*     BERR   (output) REAL array, dimension (NRHS)\n*     The componentwise relative backward error from the formula above.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      REAL               TMP\n      INTEGER            I, J\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX\n*     ..\n*     .. External Functions ..\n      EXTERNAL           SLAMCH\n      REAL               SLAMCH\n      REAL               SAFE1\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  berr = NumRu::Lapack.sla_lin_berr( nz, res, ayb, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_nz = argv[0];
  rblapack_res = argv[1];
  rblapack_ayb = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  nz = NUM2INT(rblapack_nz);
  if (!NA_IsNArray(rblapack_ayb))
    rb_raise(rb_eArgError, "ayb (3th argument) must be NArray");
  if (NA_RANK(rblapack_ayb) != 2)
    rb_raise(rb_eArgError, "rank of ayb (3th argument) must be %d", 2);
  n = NA_SHAPE0(rblapack_ayb);
  nrhs = NA_SHAPE1(rblapack_ayb);
  if (NA_TYPE(rblapack_ayb) != NA_SFLOAT)
    rblapack_ayb = na_change_type(rblapack_ayb, NA_SFLOAT);
  ayb = NA_PTR_TYPE(rblapack_ayb, real*);
  if (!NA_IsNArray(rblapack_res))
    rb_raise(rb_eArgError, "res (2th argument) must be NArray");
  if (NA_RANK(rblapack_res) != 2)
    rb_raise(rb_eArgError, "rank of res (2th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_res) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 0 of ayb");
  if (NA_SHAPE1(rblapack_res) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of res must be the same as shape 1 of ayb");
  if (NA_TYPE(rblapack_res) != NA_SFLOAT)
    rblapack_res = na_change_type(rblapack_res, NA_SFLOAT);
  res = NA_PTR_TYPE(rblapack_res, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);

  sla_lin_berr_(&n, &nz, &nrhs, res, ayb, berr);

  return rblapack_berr;
}

void
init_lapack_sla_lin_berr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sla_lin_berr", rblapack_sla_lin_berr, -1);
}
ruby-lapack-1.7.2/ext/ssytrd.c0000644000175000017500000001714012502221020016050 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssytrd_(char* uplo, integer* n, real* a, integer* lda, real* d, real* e, real* tau, real* work, integer* lwork, integer* info);


static VALUE
rblapack_ssytrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *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  d, e, tau, work, info, a = NumRu::Lapack.ssytrd( uplo, a, lwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSYTRD reduces a real symmetric matrix A to real symmetric\n*  tridiagonal form T by an orthogonal similarity transformation:\n*  Q**T * A * Q = T.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*          On exit, if UPLO = 'U', the diagonal and first superdiagonal\n*          of A are overwritten by the corresponding elements of the\n*          tridiagonal matrix T, and the elements above the first\n*          superdiagonal, with the array TAU, represent the orthogonal\n*          matrix Q as a product of elementary reflectors; if UPLO\n*          = 'L', the diagonal and first subdiagonal of A are over-\n*          written by the corresponding elements of the tridiagonal\n*          matrix T, and the elements below the first subdiagonal, with\n*          the array TAU, represent the orthogonal matrix Q as a product\n*          of elementary reflectors. See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  D       (output) REAL array, dimension (N)\n*          The diagonal elements of the tridiagonal matrix T:\n*          D(i) = A(i,i).\n*\n*  E       (output) REAL array, dimension (N-1)\n*          The off-diagonal elements of the tridiagonal matrix T:\n*          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n*  TAU     (output) REAL array, dimension (N-1)\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace/output) REAL 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 >= 1.\n*          For optimum performance LWORK >= N*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*  If UPLO = 'U', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(n-1) . . . H(2) H(1).\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(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n*  A(1:i-1,i+1), and tau in TAU(i).\n*\n*  If UPLO = 'L', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(1) H(2) . . . H(n-1).\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) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n*  and tau in TAU(i).\n*\n*  The contents of A on exit are illustrated by the following examples\n*  with n = 5:\n*\n*  if UPLO = 'U':                       if UPLO = 'L':\n*\n*    (  d   e   v2  v3  v4 )              (  d                  )\n*    (      d   e   v3  v4 )              (  e   d              )\n*    (          d   e   v4 )              (  v1  e   d          )\n*    (              d   e  )              (  v1  v2  e   d      )\n*    (                  d  )              (  v1  v2  v3  e   d  )\n*\n*  where d and e denote diagonal and off-diagonal elements of T, and vi\n*  denotes an element of the vector defining H(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, tau, work, info, a = NumRu::Lapack.ssytrd( uplo, a, lwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_lwork = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  lwork = NUM2INT(rblapack_lwork);
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, real*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  ssytrd_(&uplo, &n, a, &lda, d, e, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_d, rblapack_e, rblapack_tau, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_ssytrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssytrd", rblapack_ssytrd, -1);
}
ruby-lapack-1.7.2/ext/dorbdb.c0000644000175000017500000003510512502221020015755 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dorbdb_(char* trans, char* signs, integer* m, integer* p, integer* q, doublereal* x11, integer* ldx11, doublereal* x12, integer* ldx12, doublereal* x21, integer* ldx21, doublereal* x22, integer* ldx22, doublereal* theta, doublereal* phi, doublereal* taup1, doublereal* taup2, doublereal* tauq1, doublereal* tauq2, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dorbdb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_signs;
  char signs; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_x11;
  doublereal *x11; 
  VALUE rblapack_x12;
  doublereal *x12; 
  VALUE rblapack_x21;
  doublereal *x21; 
  VALUE rblapack_x22;
  doublereal *x22; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_theta;
  doublereal *theta; 
  VALUE rblapack_phi;
  doublereal *phi; 
  VALUE rblapack_taup1;
  doublereal *taup1; 
  VALUE rblapack_taup2;
  doublereal *taup2; 
  VALUE rblapack_tauq1;
  doublereal *tauq1; 
  VALUE rblapack_tauq2;
  doublereal *tauq2; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x11_out__;
  doublereal *x11_out__;
  VALUE rblapack_x12_out__;
  doublereal *x12_out__;
  VALUE rblapack_x21_out__;
  doublereal *x21_out__;
  VALUE rblapack_x22_out__;
  doublereal *x22_out__;
  doublereal *work;

  integer ldx11;
  integer q;
  integer ldx12;
  integer ldx21;
  integer ldx22;
  integer p;

  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  theta, phi, taup1, taup2, tauq1, tauq2, info, x11, x12, x21, x22 = NumRu::Lapack.dorbdb( trans, signs, m, x11, x12, x21, x22, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DORBDB simultaneously bidiagonalizes the blocks of an M-by-M\n*  partitioned orthogonal matrix X:\n*\n*                                  [ B11 | B12 0  0 ]\n*      [ X11 | X12 ]   [ P1 |    ] [  0  |  0 -I  0 ] [ Q1 |    ]**T\n*  X = [-----------] = [---------] [----------------] [---------]   .\n*      [ X21 | X22 ]   [    | P2 ] [ B21 | B22 0  0 ] [    | Q2 ]\n*                                  [  0  |  0  0  I ]\n*\n*  X11 is P-by-Q. Q must be no larger than P, M-P, or M-Q. (If this is\n*  not the case, then X must be transposed and/or permuted. This can be\n*  done in constant time using the TRANS and SIGNS options. See DORCSD\n*  for details.)\n*\n*  The orthogonal matrices P1, P2, Q1, and Q2 are P-by-P, (M-P)-by-\n*  (M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. They are\n*  represented implicitly by Householder vectors.\n*\n*  B11, B12, B21, and B22 are Q-by-Q bidiagonal matrices represented\n*  implicitly by angles THETA, PHI.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER\n*          = 'T':      X, U1, U2, V1T, and V2T are stored in row-major\n*                      order;\n*          otherwise:  X, U1, U2, V1T, and V2T are stored in column-\n*                      major order.\n*\n*  SIGNS   (input) CHARACTER\n*          = 'O':      The lower-left block is made nonpositive (the\n*                      \"other\" convention);\n*          otherwise:  The upper-right block is made nonpositive (the\n*                      \"default\" convention).\n*\n*  M       (input) INTEGER\n*          The number of rows and columns in X.\n*\n*  P       (input) INTEGER\n*          The number of rows in X11 and X12. 0 <= P <= M.\n*\n*  Q       (input) INTEGER\n*          The number of columns in X11 and X21. 0 <= Q <=\n*          MIN(P,M-P,M-Q).\n*\n*  X11     (input/output) DOUBLE PRECISION array, dimension (LDX11,Q)\n*          On entry, the top-left block of the orthogonal matrix to be\n*          reduced. On exit, the form depends on TRANS:\n*          If TRANS = 'N', then\n*             the columns of tril(X11) specify reflectors for P1,\n*             the rows of triu(X11,1) specify reflectors for Q1;\n*          else TRANS = 'T', and\n*             the rows of triu(X11) specify reflectors for P1,\n*             the columns of tril(X11,-1) specify reflectors for Q1.\n*\n*  LDX11   (input) INTEGER\n*          The leading dimension of X11. If TRANS = 'N', then LDX11 >=\n*          P; else LDX11 >= Q.\n*\n*  X12     (input/output) DOUBLE PRECISION array, dimension (LDX12,M-Q)\n*          On entry, the top-right block of the orthogonal matrix to\n*          be reduced. On exit, the form depends on TRANS:\n*          If TRANS = 'N', then\n*             the rows of triu(X12) specify the first P reflectors for\n*             Q2;\n*          else TRANS = 'T', and\n*             the columns of tril(X12) specify the first P reflectors\n*             for Q2.\n*\n*  LDX12   (input) INTEGER\n*          The leading dimension of X12. If TRANS = 'N', then LDX12 >=\n*          P; else LDX11 >= M-Q.\n*\n*  X21     (input/output) DOUBLE PRECISION array, dimension (LDX21,Q)\n*          On entry, the bottom-left block of the orthogonal matrix to\n*          be reduced. On exit, the form depends on TRANS:\n*          If TRANS = 'N', then\n*             the columns of tril(X21) specify reflectors for P2;\n*          else TRANS = 'T', and\n*             the rows of triu(X21) specify reflectors for P2.\n*\n*  LDX21   (input) INTEGER\n*          The leading dimension of X21. If TRANS = 'N', then LDX21 >=\n*          M-P; else LDX21 >= Q.\n*\n*  X22     (input/output) DOUBLE PRECISION array, dimension (LDX22,M-Q)\n*          On entry, the bottom-right block of the orthogonal matrix to\n*          be reduced. On exit, the form depends on TRANS:\n*          If TRANS = 'N', then\n*             the rows of triu(X22(Q+1:M-P,P+1:M-Q)) specify the last\n*             M-P-Q reflectors for Q2,\n*          else TRANS = 'T', and\n*             the columns of tril(X22(P+1:M-Q,Q+1:M-P)) specify the last\n*             M-P-Q reflectors for P2.\n*\n*  LDX22   (input) INTEGER\n*          The leading dimension of X22. If TRANS = 'N', then LDX22 >=\n*          M-P; else LDX22 >= M-Q.\n*\n*  THETA   (output) DOUBLE PRECISION array, dimension (Q)\n*          The entries of the bidiagonal blocks B11, B12, B21, B22 can\n*          be computed from the angles THETA and PHI. See Further\n*          Details.\n*\n*  PHI     (output) DOUBLE PRECISION array, dimension (Q-1)\n*          The entries of the bidiagonal blocks B11, B12, B21, B22 can\n*          be computed from the angles THETA and PHI. See Further\n*          Details.\n*\n*  TAUP1   (output) DOUBLE PRECISION array, dimension (P)\n*          The scalar factors of the elementary reflectors that define\n*          P1.\n*\n*  TAUP2   (output) DOUBLE PRECISION array, dimension (M-P)\n*          The scalar factors of the elementary reflectors that define\n*          P2.\n*\n*  TAUQ1   (output) DOUBLE PRECISION array, dimension (Q)\n*          The scalar factors of the elementary reflectors that define\n*          Q1.\n*\n*  TAUQ2   (output) DOUBLE PRECISION array, dimension (M-Q)\n*          The scalar factors of the elementary reflectors that define\n*          Q2.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (LWORK)\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK. LWORK >= M-Q.\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 bidiagonal blocks B11, B12, B21, and B22 are represented\n*  implicitly by angles THETA(1), ..., THETA(Q) and PHI(1), ...,\n*  PHI(Q-1). B11 and B21 are upper bidiagonal, while B21 and B22 are\n*  lower bidiagonal. Every entry in each bidiagonal band is a product\n*  of a sine or cosine of a THETA with a sine or cosine of a PHI. See\n*  [1] or DORCSD for details.\n*\n*  P1, P2, Q1, and Q2 are represented as products of elementary\n*  reflectors. See DORCSD for details on generating P1, P2, Q1, and Q2\n*  using DORGQR and DORGLQ.\n*\n*  Reference\n*  =========\n*\n*  [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.\n*      Algorithms, 50(1):33-65, 2009.\n*\n*  ====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  theta, phi, taup1, taup2, tauq1, tauq2, info, x11, x12, x21, x22 = NumRu::Lapack.dorbdb( trans, signs, m, x11, x12, x21, x22, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_trans = argv[0];
  rblapack_signs = argv[1];
  rblapack_m = argv[2];
  rblapack_x11 = argv[3];
  rblapack_x12 = argv[4];
  rblapack_x21 = argv[5];
  rblapack_x22 = argv[6];
  if (argc == 8) {
    rblapack_lwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  trans = StringValueCStr(rblapack_trans)[0];
  m = NUM2INT(rblapack_m);
  signs = StringValueCStr(rblapack_signs)[0];
  if (!NA_IsNArray(rblapack_x11))
    rb_raise(rb_eArgError, "x11 (4th argument) must be NArray");
  if (NA_RANK(rblapack_x11) != 2)
    rb_raise(rb_eArgError, "rank of x11 (4th argument) must be %d", 2);
  ldx11 = NA_SHAPE0(rblapack_x11);
  q = NA_SHAPE1(rblapack_x11);
  if (NA_TYPE(rblapack_x11) != NA_DFLOAT)
    rblapack_x11 = na_change_type(rblapack_x11, NA_DFLOAT);
  x11 = NA_PTR_TYPE(rblapack_x11, doublereal*);
  p = ldx11;
  ldx21 = p;
  if (!NA_IsNArray(rblapack_x21))
    rb_raise(rb_eArgError, "x21 (6th argument) must be NArray");
  if (NA_RANK(rblapack_x21) != 2)
    rb_raise(rb_eArgError, "rank of x21 (6th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_x21) != ldx21)
    rb_raise(rb_eRuntimeError, "shape 0 of x21 must be p");
  if (NA_SHAPE1(rblapack_x21) != q)
    rb_raise(rb_eRuntimeError, "shape 1 of x21 must be the same as shape 1 of x11");
  if (NA_TYPE(rblapack_x21) != NA_DFLOAT)
    rblapack_x21 = na_change_type(rblapack_x21, NA_DFLOAT);
  x21 = NA_PTR_TYPE(rblapack_x21, doublereal*);
  if (rblapack_lwork == Qnil)
    lwork = m-q;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldx22 = p;
  if (!NA_IsNArray(rblapack_x22))
    rb_raise(rb_eArgError, "x22 (7th argument) must be NArray");
  if (NA_RANK(rblapack_x22) != 2)
    rb_raise(rb_eArgError, "rank of x22 (7th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_x22) != ldx22)
    rb_raise(rb_eRuntimeError, "shape 0 of x22 must be p");
  if (NA_SHAPE1(rblapack_x22) != (m-q))
    rb_raise(rb_eRuntimeError, "shape 1 of x22 must be %d", m-q);
  if (NA_TYPE(rblapack_x22) != NA_DFLOAT)
    rblapack_x22 = na_change_type(rblapack_x22, NA_DFLOAT);
  x22 = NA_PTR_TYPE(rblapack_x22, doublereal*);
  ldx12 = p;
  if (!NA_IsNArray(rblapack_x12))
    rb_raise(rb_eArgError, "x12 (5th argument) must be NArray");
  if (NA_RANK(rblapack_x12) != 2)
    rb_raise(rb_eArgError, "rank of x12 (5th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_x12) != ldx12)
    rb_raise(rb_eRuntimeError, "shape 0 of x12 must be p");
  if (NA_SHAPE1(rblapack_x12) != (m-q))
    rb_raise(rb_eRuntimeError, "shape 1 of x12 must be %d", m-q);
  if (NA_TYPE(rblapack_x12) != NA_DFLOAT)
    rblapack_x12 = na_change_type(rblapack_x12, NA_DFLOAT);
  x12 = NA_PTR_TYPE(rblapack_x12, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_theta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  theta = NA_PTR_TYPE(rblapack_theta, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = q-1;
    rblapack_phi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  phi = NA_PTR_TYPE(rblapack_phi, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = p;
    rblapack_taup1 = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  taup1 = NA_PTR_TYPE(rblapack_taup1, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = m-p;
    rblapack_taup2 = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  taup2 = NA_PTR_TYPE(rblapack_taup2, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_tauq1 = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  tauq1 = NA_PTR_TYPE(rblapack_tauq1, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = m-q;
    rblapack_tauq2 = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  tauq2 = NA_PTR_TYPE(rblapack_tauq2, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx11;
    shape[1] = q;
    rblapack_x11_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x11_out__ = NA_PTR_TYPE(rblapack_x11_out__, doublereal*);
  MEMCPY(x11_out__, x11, doublereal, NA_TOTAL(rblapack_x11));
  rblapack_x11 = rblapack_x11_out__;
  x11 = x11_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldx12;
    shape[1] = m-q;
    rblapack_x12_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x12_out__ = NA_PTR_TYPE(rblapack_x12_out__, doublereal*);
  MEMCPY(x12_out__, x12, doublereal, NA_TOTAL(rblapack_x12));
  rblapack_x12 = rblapack_x12_out__;
  x12 = x12_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldx21;
    shape[1] = q;
    rblapack_x21_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x21_out__ = NA_PTR_TYPE(rblapack_x21_out__, doublereal*);
  MEMCPY(x21_out__, x21, doublereal, NA_TOTAL(rblapack_x21));
  rblapack_x21 = rblapack_x21_out__;
  x21 = x21_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldx22;
    shape[1] = m-q;
    rblapack_x22_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x22_out__ = NA_PTR_TYPE(rblapack_x22_out__, doublereal*);
  MEMCPY(x22_out__, x22, doublereal, NA_TOTAL(rblapack_x22));
  rblapack_x22 = rblapack_x22_out__;
  x22 = x22_out__;
  work = ALLOC_N(doublereal, (MAX(1,lwork)));

  dorbdb_(&trans, &signs, &m, &p, &q, x11, &ldx11, x12, &ldx12, x21, &ldx21, x22, &ldx22, theta, phi, taup1, taup2, tauq1, tauq2, work, &lwork, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(11, rblapack_theta, rblapack_phi, rblapack_taup1, rblapack_taup2, rblapack_tauq1, rblapack_tauq2, rblapack_info, rblapack_x11, rblapack_x12, rblapack_x21, rblapack_x22);
}

void
init_lapack_dorbdb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dorbdb", rblapack_dorbdb, -1);
}
ruby-lapack-1.7.2/ext/ilaprec.c0000644000175000017500000000404112502221024016137 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern integer ilaprec_(char* prec);


static VALUE
rblapack_ilaprec(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_prec;
  char prec; 
  VALUE rblapack___out__;
  integer __out__; 


  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  __out__ = NumRu::Lapack.ilaprec( prec, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      INTEGER FUNCTION ILAPREC( PREC )\n\n*  Purpose\n*  =======\n*\n*  This subroutine translated from a character string specifying an\n*  intermediate precision to the relevant BLAST-specified integer\n*  constant.\n*\n*  ILAPREC returns an INTEGER.  If ILAPREC < 0, then the input is not a\n*  character indicating a supported intermediate precision.  Otherwise\n*  ILAPREC returns the constant value corresponding to PREC.\n*\n\n*  Arguments\n*  =========\n*  PREC    (input) CHARACTER\n*          Specifies the form of the system of equations:\n*          = 'S':  Single\n*          = 'D':  Double\n*          = 'I':  Indigenous\n*          = 'X', 'E':  Extra\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.ilaprec( prec, [: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_prec = argv[0];
  if (argc == 1) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  prec = StringValueCStr(rblapack_prec)[0];

  __out__ = ilaprec_(&prec);

  rblapack___out__ = INT2NUM(__out__);
  return rblapack___out__;
}

void
init_lapack_ilaprec(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ilaprec", rblapack_ilaprec, -1);
}
ruby-lapack-1.7.2/ext/dlaed3.c0000644000175000017500000002316012502221015015657 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaed3_(integer* k, integer* n, integer* n1, doublereal* d, doublereal* q, integer* ldq, doublereal* rho, doublereal* dlamda, doublereal* q2, integer* indx, integer* ctot, doublereal* w, doublereal* s, integer* info);


static VALUE
rblapack_dlaed3(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n1;
  integer n1; 
  VALUE rblapack_rho;
  doublereal rho; 
  VALUE rblapack_dlamda;
  doublereal *dlamda; 
  VALUE rblapack_q2;
  doublereal *q2; 
  VALUE rblapack_indx;
  integer *indx; 
  VALUE rblapack_ctot;
  integer *ctot; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_q;
  doublereal *q; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_dlamda_out__;
  doublereal *dlamda_out__;
  VALUE rblapack_w_out__;
  doublereal *w_out__;
  doublereal *s;

  integer k;
  integer n;
  integer ldq;

  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  d, q, info, dlamda, w = NumRu::Lapack.dlaed3( n1, rho, dlamda, q2, indx, ctot, w, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX, CTOT, W, S, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLAED3 finds the roots of the secular equation, as defined by the\n*  values in D, W, and RHO, between 1 and K.  It makes the\n*  appropriate calls to DLAED4 and then updates the eigenvectors by\n*  multiplying the matrix of eigenvectors of the pair of eigensystems\n*  being combined by the matrix of eigenvectors of the K-by-K system\n*  which is solved here.\n*\n*  This code makes very mild assumptions about floating point\n*  arithmetic. It will work on machines with a guard digit in\n*  add/subtract, or on those binary machines without guard digits\n*  which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n*  It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  K       (input) INTEGER\n*          The number of terms in the rational function to be solved by\n*          DLAED4.  K >= 0.\n*\n*  N       (input) INTEGER\n*          The number of rows and columns in the Q matrix.\n*          N >= K (deflation may result in N>K).\n*\n*  N1      (input) INTEGER\n*          The location of the last eigenvalue in the leading submatrix.\n*          min(1,N) <= N1 <= N/2.\n*\n*  D       (output) DOUBLE PRECISION array, dimension (N)\n*          D(I) contains the updated eigenvalues for\n*          1 <= I <= K.\n*\n*  Q       (output) DOUBLE PRECISION array, dimension (LDQ,N)\n*          Initially the first K columns are used as workspace.\n*          On output the columns 1 to K contain\n*          the updated eigenvectors.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.  LDQ >= max(1,N).\n*\n*  RHO     (input) DOUBLE PRECISION\n*          The value of the parameter in the rank one update equation.\n*          RHO >= 0 required.\n*\n*  DLAMDA  (input/output) DOUBLE PRECISION array, dimension (K)\n*          The first K elements of this array contain the old roots\n*          of the deflated updating problem.  These are the poles\n*          of the secular equation. May be changed on output by\n*          having lowest order bit set to zero on Cray X-MP, Cray Y-MP,\n*          Cray-2, or Cray C-90, as described above.\n*\n*  Q2      (input) DOUBLE PRECISION array, dimension (LDQ2, N)\n*          The first K columns of this matrix contain the non-deflated\n*          eigenvectors for the split problem.\n*\n*  INDX    (input) INTEGER array, dimension (N)\n*          The permutation used to arrange the columns of the deflated\n*          Q matrix into three groups (see DLAED2).\n*          The rows of the eigenvectors found by DLAED4 must be likewise\n*          permuted before the matrix multiply can take place.\n*\n*  CTOT    (input) INTEGER array, dimension (4)\n*          A count of the total number of the various types of columns\n*          in Q, as described in INDX.  The fourth column type is any\n*          column which has been deflated.\n*\n*  W       (input/output) DOUBLE PRECISION array, dimension (K)\n*          The first K elements of this array contain the components\n*          of the deflation-adjusted updating vector. Destroyed on\n*          output.\n*\n*  S       (workspace) DOUBLE PRECISION array, dimension (N1 + 1)*K\n*          Will contain the eigenvectors of the repaired matrix which\n*          will be multiplied by the previously accumulated eigenvectors\n*          to update the system.\n*\n*  LDS     (input) INTEGER\n*          The leading dimension of S.  LDS >= max(1,K).\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 = 1, an eigenvalue did not converge\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Jeff Rutter, Computer Science Division, University of California\n*     at Berkeley, USA\n*  Modified by Francoise Tisseur, University of Tennessee.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, q, info, dlamda, w = NumRu::Lapack.dlaed3( n1, rho, dlamda, q2, indx, ctot, w, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_n1 = argv[0];
  rblapack_rho = argv[1];
  rblapack_dlamda = argv[2];
  rblapack_q2 = argv[3];
  rblapack_indx = argv[4];
  rblapack_ctot = argv[5];
  rblapack_w = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n1 = NUM2INT(rblapack_n1);
  if (!NA_IsNArray(rblapack_dlamda))
    rb_raise(rb_eArgError, "dlamda (3th argument) must be NArray");
  if (NA_RANK(rblapack_dlamda) != 1)
    rb_raise(rb_eArgError, "rank of dlamda (3th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_dlamda);
  if (NA_TYPE(rblapack_dlamda) != NA_DFLOAT)
    rblapack_dlamda = na_change_type(rblapack_dlamda, NA_DFLOAT);
  dlamda = NA_PTR_TYPE(rblapack_dlamda, doublereal*);
  if (!NA_IsNArray(rblapack_indx))
    rb_raise(rb_eArgError, "indx (5th argument) must be NArray");
  if (NA_RANK(rblapack_indx) != 1)
    rb_raise(rb_eArgError, "rank of indx (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_indx);
  if (NA_TYPE(rblapack_indx) != NA_LINT)
    rblapack_indx = na_change_type(rblapack_indx, NA_LINT);
  indx = NA_PTR_TYPE(rblapack_indx, integer*);
  if (!NA_IsNArray(rblapack_w))
    rb_raise(rb_eArgError, "w (7th argument) must be NArray");
  if (NA_RANK(rblapack_w) != 1)
    rb_raise(rb_eArgError, "rank of w (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_w) != k)
    rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of dlamda");
  if (NA_TYPE(rblapack_w) != NA_DFLOAT)
    rblapack_w = na_change_type(rblapack_w, NA_DFLOAT);
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  rho = NUM2DBL(rblapack_rho);
  if (!NA_IsNArray(rblapack_ctot))
    rb_raise(rb_eArgError, "ctot (6th argument) must be NArray");
  if (NA_RANK(rblapack_ctot) != 1)
    rb_raise(rb_eArgError, "rank of ctot (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ctot) != (4))
    rb_raise(rb_eRuntimeError, "shape 0 of ctot must be %d", 4);
  if (NA_TYPE(rblapack_ctot) != NA_LINT)
    rblapack_ctot = na_change_type(rblapack_ctot, NA_LINT);
  ctot = NA_PTR_TYPE(rblapack_ctot, integer*);
  if (!NA_IsNArray(rblapack_q2))
    rb_raise(rb_eArgError, "q2 (4th argument) must be NArray");
  if (NA_RANK(rblapack_q2) != 2)
    rb_raise(rb_eArgError, "rank of q2 (4th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_q2) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of q2 must be the same as shape 0 of indx");
  if (NA_SHAPE1(rblapack_q2) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q2 must be the same as shape 0 of indx");
  if (NA_TYPE(rblapack_q2) != NA_DFLOAT)
    rblapack_q2 = na_change_type(rblapack_q2, NA_DFLOAT);
  q2 = NA_PTR_TYPE(rblapack_q2, doublereal*);
  ldq = MAX(1,n);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  q = NA_PTR_TYPE(rblapack_q, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = k;
    rblapack_dlamda_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  dlamda_out__ = NA_PTR_TYPE(rblapack_dlamda_out__, doublereal*);
  MEMCPY(dlamda_out__, dlamda, doublereal, NA_TOTAL(rblapack_dlamda));
  rblapack_dlamda = rblapack_dlamda_out__;
  dlamda = dlamda_out__;
  {
    na_shape_t shape[1];
    shape[0] = k;
    rblapack_w_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w_out__ = NA_PTR_TYPE(rblapack_w_out__, doublereal*);
  MEMCPY(w_out__, w, doublereal, NA_TOTAL(rblapack_w));
  rblapack_w = rblapack_w_out__;
  w = w_out__;
  s = ALLOC_N(doublereal, (MAX(1,k))*((n1 + 1)));

  dlaed3_(&k, &n, &n1, d, q, &ldq, &rho, dlamda, q2, indx, ctot, w, s, &info);

  free(s);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_d, rblapack_q, rblapack_info, rblapack_dlamda, rblapack_w);
}

void
init_lapack_dlaed3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaed3", rblapack_dlaed3, -1);
}
ruby-lapack-1.7.2/ext/ssbgvx.c0000644000175000017500000003117112502221024016040 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssbgvx_(char* jobz, char* range, char* uplo, integer* n, integer* ka, integer* kb, real* ab, integer* ldab, real* bb, integer* ldbb, real* q, integer* ldq, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, real* z, integer* ldz, real* work, integer* iwork, integer* ifail, integer* info);


static VALUE
rblapack_ssbgvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ka;
  integer ka; 
  VALUE rblapack_kb;
  integer kb; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_bb;
  real *bb; 
  VALUE rblapack_vl;
  real vl; 
  VALUE rblapack_vu;
  real vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  real abstol; 
  VALUE rblapack_q;
  real *q; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_ifail;
  integer *ifail; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  real *ab_out__;
  VALUE rblapack_bb_out__;
  real *bb_out__;

  integer ldab;
  integer n;
  integer ldbb;
  integer ldq;
  integer ldz;

  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  q, m, w, z, work, iwork, ifail, info, ab, bb = NumRu::Lapack.ssbgvx( jobz, range, uplo, ka, kb, ab, bb, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSBGVX( JOBZ, RANGE, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSBGVX computes selected eigenvalues, and optionally, eigenvectors\n*  of a real generalized symmetric-definite banded eigenproblem, of\n*  the form A*x=(lambda)*B*x.  Here A and B are assumed to be symmetric\n*  and banded, and B is also positive definite.  Eigenvalues and\n*  eigenvectors can be selected by specifying either all eigenvalues,\n*  a range of values or a range of indices for the desired eigenvalues.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found.\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found.\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  KA      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KA >= 0.\n*\n*  KB      (input) INTEGER\n*          The number of superdiagonals of the matrix B if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KB >= 0.\n*\n*  AB      (input/output) REAL array, dimension (LDAB, N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first ka+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).\n*\n*          On exit, the contents of AB are destroyed.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KA+1.\n*\n*  BB      (input/output) REAL array, dimension (LDBB, N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix B, stored in the first kb+1 rows of the array.  The\n*          j-th column of B is stored in the j-th column of the array BB\n*          as follows:\n*          if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n*          if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb).\n*\n*          On exit, the factor S from the split Cholesky factorization\n*          B = S**T*S, as returned by SPBSTF.\n*\n*  LDBB    (input) INTEGER\n*          The leading dimension of the array BB.  LDBB >= KB+1.\n*\n*  Q       (output) REAL array, dimension (LDQ, N)\n*          If JOBZ = 'V', the n-by-n matrix used in the reduction of\n*          A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x,\n*          and consequently C to tridiagonal form.\n*          If JOBZ = 'N', the array Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.  If JOBZ = 'N',\n*          LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N).\n*\n*  VL      (input) REAL\n*  VU      (input) REAL\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) REAL\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less than\n*          or equal to zero, then  EPS*|T|  will be used in its place,\n*          where |T| is the 1-norm of the tridiagonal matrix obtained\n*          by reducing A to tridiagonal form.\n*\n*          Eigenvalues will be computed most accurately when ABSTOL is\n*          set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n*          If this routine returns with INFO>0, indicating that some\n*          eigenvectors did not converge, try setting ABSTOL to\n*          2*SLAMCH('S').\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) REAL array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) REAL array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n*          eigenvectors, with the i-th column of Z holding the\n*          eigenvector associated with W(i).  The eigenvectors are\n*          normalized so Z**T*B*Z = I.\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace/output) REAL array, dimension (7N)\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (5N)\n*\n*  IFAIL   (output) INTEGER array, dimension (M)\n*          If JOBZ = 'V', then if INFO = 0, the first M elements of\n*          IFAIL are zero.  If INFO > 0, then IFAIL contains the\n*          indices of the eigenvalues that failed to converge.\n*          If JOBZ = 'N', then IFAIL is not referenced.\n*\n*  INFO    (output) INTEGER\n*          = 0 : successful exit\n*          < 0 : if INFO = -i, the i-th argument had an illegal value\n*          <= N: if INFO = i, then i eigenvectors failed to converge.\n*                  Their indices are stored in IFAIL.\n*          > N : SPBSTF returned an error code; i.e.,\n*                if INFO = N + i, for 1 <= i <= N, then the leading\n*                minor of order i of B is not positive definite.\n*                The factorization of B could not be completed and\n*                no eigenvalues or eigenvectors were computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  q, m, w, z, work, iwork, ifail, info, ab, bb = NumRu::Lapack.ssbgvx( jobz, range, uplo, ka, kb, ab, bb, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_uplo = argv[2];
  rblapack_ka = argv[3];
  rblapack_kb = argv[4];
  rblapack_ab = argv[5];
  rblapack_bb = argv[6];
  rblapack_vl = argv[7];
  rblapack_vu = argv[8];
  rblapack_il = argv[9];
  rblapack_iu = argv[10];
  rblapack_abstol = argv[11];
  if (argc == 12) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  kb = NUM2INT(rblapack_kb);
  if (!NA_IsNArray(rblapack_bb))
    rb_raise(rb_eArgError, "bb (7th argument) must be NArray");
  if (NA_RANK(rblapack_bb) != 2)
    rb_raise(rb_eArgError, "rank of bb (7th argument) must be %d", 2);
  ldbb = NA_SHAPE0(rblapack_bb);
  n = NA_SHAPE1(rblapack_bb);
  if (NA_TYPE(rblapack_bb) != NA_SFLOAT)
    rblapack_bb = na_change_type(rblapack_bb, NA_SFLOAT);
  bb = NA_PTR_TYPE(rblapack_bb, real*);
  vu = (real)NUM2DBL(rblapack_vu);
  iu = NUM2INT(rblapack_iu);
  range = StringValueCStr(rblapack_range)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (6th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (6th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of bb");
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  il = NUM2INT(rblapack_il);
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  ldq = 1 ? jobz = 'n' : MAX(1,n) ? jobz = 'v' : 0;
  ka = NUM2INT(rblapack_ka);
  abstol = (real)NUM2DBL(rblapack_abstol);
  vl = (real)NUM2DBL(rblapack_vl);
  m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  q = NA_PTR_TYPE(rblapack_q, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[1];
    shape[0] = 7*n;
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[1];
    shape[0] = 5*n;
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
  MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldbb;
    shape[1] = n;
    rblapack_bb_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  bb_out__ = NA_PTR_TYPE(rblapack_bb_out__, real*);
  MEMCPY(bb_out__, bb, real, NA_TOTAL(rblapack_bb));
  rblapack_bb = rblapack_bb_out__;
  bb = bb_out__;

  ssbgvx_(&jobz, &range, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, q, &ldq, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, iwork, ifail, &info);

  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(10, rblapack_q, rblapack_m, rblapack_w, rblapack_z, rblapack_work, rblapack_iwork, rblapack_ifail, rblapack_info, rblapack_ab, rblapack_bb);
}

void
init_lapack_ssbgvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssbgvx", rblapack_ssbgvx, -1);
}
ruby-lapack-1.7.2/ext/chegvx.c0000644000175000017500000003247712502221025016023 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chegvx_(integer* itype, char* jobz, char* range, char* uplo, integer* n, complex* a, integer* lda, complex* b, integer* ldb, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, complex* z, integer* ldz, complex* work, integer* lwork, real* rwork, integer* iwork, integer* ifail, integer* info);


static VALUE
rblapack_chegvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_vl;
  real vl; 
  VALUE rblapack_vu;
  real vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  real abstol; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_ifail;
  integer *ifail; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;
  real *rwork;
  integer *iwork;

  integer lda;
  integer n;
  integer ldb;
  integer ldz;

  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  m, w, z, work, ifail, info, a, b = NumRu::Lapack.chegvx( itype, jobz, range, uplo, a, b, vl, vu, il, iu, abstol, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHEGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, IWORK, IFAIL, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHEGVX computes selected eigenvalues, and optionally, eigenvectors\n*  of a complex generalized Hermitian-definite eigenproblem, of the form\n*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A and\n*  B are assumed to be Hermitian and B is also positive definite.\n*  Eigenvalues and eigenvectors can be selected by specifying either a\n*  range of values or a range of indices for the desired eigenvalues.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          Specifies the problem type to be solved:\n*          = 1:  A*x = (lambda)*B*x\n*          = 2:  A*B*x = (lambda)*x\n*          = 3:  B*A*x = (lambda)*x\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found.\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found.\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n**\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA, N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of A contains the\n*          upper triangular part of the matrix A.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of A contains\n*          the lower triangular part of the matrix A.\n*\n*          On exit,  the lower triangle (if UPLO='L') or the upper\n*          triangle (if UPLO='U') of A, including the diagonal, is\n*          destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX array, dimension (LDB, N)\n*          On entry, the Hermitian matrix B.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of B contains the\n*          upper triangular part of the matrix B.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of B contains\n*          the lower triangular part of the matrix B.\n*\n*          On exit, if INFO <= N, the part of B containing the matrix is\n*          overwritten by the triangular factor U or L from the Cholesky\n*          factorization B = U**H*U or B = L*L**H.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  VL      (input) REAL\n*  VU      (input) REAL\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) REAL\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less than\n*          or equal to zero, then  EPS*|T|  will be used in its place,\n*          where |T| is the 1-norm of the tridiagonal matrix obtained\n*          by reducing A to tridiagonal form.\n*\n*          Eigenvalues will be computed most accurately when ABSTOL is\n*          set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n*          If this routine returns with INFO>0, indicating that some\n*          eigenvectors did not converge, try setting ABSTOL to\n*          2*SLAMCH('S').\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) REAL array, dimension (N)\n*          The first M elements contain the selected\n*          eigenvalues in ascending order.\n*\n*  Z       (output) COMPLEX array, dimension (LDZ, max(1,M))\n*          If JOBZ = 'N', then Z is not referenced.\n*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix A\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          The eigenvectors are normalized as follows:\n*          if ITYPE = 1 or 2, Z**T*B*Z = I;\n*          if ITYPE = 3, Z**T*inv(B)*Z = I.\n*\n*          If an eigenvector fails to converge, then that column of Z\n*          contains the latest approximation to the eigenvector, and the\n*          index of the eigenvector is returned in IFAIL.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of the array WORK.  LWORK >= max(1,2*N).\n*          For optimal efficiency, LWORK >= (NB+1)*N,\n*          where NB is the blocksize for CHETRD returned by ILAENV.\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*  RWORK   (workspace) REAL array, dimension (7*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (5*N)\n*\n*  IFAIL   (output) INTEGER array, dimension (N)\n*          If JOBZ = 'V', then if INFO = 0, the first M elements of\n*          IFAIL are zero.  If INFO > 0, then IFAIL contains the\n*          indices of the eigenvectors that failed to converge.\n*          If JOBZ = 'N', then IFAIL is not referenced.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  CPOTRF or CHEEVX returned an error code:\n*             <= N:  if INFO = i, CHEEVX failed to converge;\n*                    i eigenvectors failed to converge.  Their indices\n*                    are stored in array IFAIL.\n*             > N:   if INFO = N + i, for 1 <= i <= N, then the leading\n*                    minor of order i of B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, work, ifail, info, a, b = NumRu::Lapack.chegvx( itype, jobz, range, uplo, a, b, vl, vu, il, iu, abstol, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 11 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
  rblapack_itype = argv[0];
  rblapack_jobz = argv[1];
  rblapack_range = argv[2];
  rblapack_uplo = argv[3];
  rblapack_a = argv[4];
  rblapack_b = argv[5];
  rblapack_vl = argv[6];
  rblapack_vu = argv[7];
  rblapack_il = argv[8];
  rblapack_iu = argv[9];
  rblapack_abstol = argv[10];
  if (argc == 12) {
    rblapack_lwork = argv[11];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  itype = NUM2INT(rblapack_itype);
  range = StringValueCStr(rblapack_range)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  vl = (real)NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  abstol = (real)NUM2DBL(rblapack_abstol);
  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  iu = NUM2INT(rblapack_iu);
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (rblapack_lwork == Qnil)
    lwork = 2*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  vu = (real)NUM2DBL(rblapack_vu);
  m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = lsame_(&jobz,"N") ? 0 : ldz;
    shape[1] = lsame_(&jobz,"N") ? 0 : MAX(1,m);
    rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  rwork = ALLOC_N(real, (7*n));
  iwork = ALLOC_N(integer, (5*n));

  chegvx_(&itype, &jobz, &range, &uplo, &n, a, &lda, b, &ldb, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, &lwork, rwork, iwork, ifail, &info);

  free(rwork);
  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_m, rblapack_w, rblapack_z, rblapack_work, rblapack_ifail, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_chegvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chegvx", rblapack_chegvx, -1);
}
ruby-lapack-1.7.2/ext/slarzb.c0000644000175000017500000001533712502221022016025 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slarzb_(char* side, char* trans, char* direct, char* storev, integer* m, integer* n, integer* k, integer* l, real* v, integer* ldv, real* t, integer* ldt, real* c, integer* ldc, real* work, integer* ldwork);


static VALUE
rblapack_slarzb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_direct;
  char direct; 
  VALUE rblapack_storev;
  char storev; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_v;
  real *v; 
  VALUE rblapack_t;
  real *t; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_c_out__;
  real *c_out__;
  real *work;

  integer ldv;
  integer nv;
  integer ldt;
  integer k;
  integer ldc;
  integer n;
  integer ldwork;

  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  c = NumRu::Lapack.slarzb( side, trans, direct, storev, m, l, v, t, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n*  Purpose\n*  =======\n*\n*  SLARZB applies a real block reflector H or its transpose H**T to\n*  a real distributed M-by-N  C from the left or the right.\n*\n*  Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply H or H' from the Left\n*          = 'R': apply H or H' from the Right\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': apply H (No transpose)\n*          = 'C': apply H' (Transpose)\n*\n*  DIRECT  (input) CHARACTER*1\n*          Indicates how H is formed from a product of elementary\n*          reflectors\n*          = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n*          = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n*  STOREV  (input) CHARACTER*1\n*          Indicates how the vectors which define the elementary\n*          reflectors are stored:\n*          = 'C': Columnwise                        (not supported yet)\n*          = 'R': Rowwise\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C.\n*\n*  K       (input) INTEGER\n*          The order of the matrix T (= the number of elementary\n*          reflectors whose product defines the block reflector).\n*\n*  L       (input) INTEGER\n*          The number of columns of the matrix V containing the\n*          meaningful part of the Householder reflectors.\n*          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n*  V       (input) REAL array, dimension (LDV,NV).\n*          If STOREV = 'C', NV = K; if STOREV = 'R', NV = L.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V.\n*          If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K.\n*\n*  T       (input) REAL array, dimension (LDT,K)\n*          The triangular K-by-K matrix T in the representation of the\n*          block reflector.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= K.\n*\n*  C       (input/output) REAL array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by H*C or H'*C or C*H or C*H'.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) REAL array, dimension (LDWORK,K)\n*\n*  LDWORK  (input) INTEGER\n*          The leading dimension of the array WORK.\n*          If SIDE = 'L', LDWORK >= max(1,N);\n*          if SIDE = 'R', LDWORK >= max(1,M).\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.slarzb( side, trans, direct, storev, m, l, v, t, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_direct = argv[2];
  rblapack_storev = argv[3];
  rblapack_m = argv[4];
  rblapack_l = argv[5];
  rblapack_v = argv[6];
  rblapack_t = argv[7];
  rblapack_c = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  direct = StringValueCStr(rblapack_direct)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (7th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (7th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  nv = NA_SHAPE1(rblapack_v);
  if (NA_TYPE(rblapack_v) != NA_SFLOAT)
    rblapack_v = na_change_type(rblapack_v, NA_SFLOAT);
  v = NA_PTR_TYPE(rblapack_v, real*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (9th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (9th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  trans = StringValueCStr(rblapack_trans)[0];
  l = NUM2INT(rblapack_l);
  ldwork = MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0;
  storev = StringValueCStr(rblapack_storev)[0];
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (8th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (8th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  k = NA_SHAPE1(rblapack_t);
  if (NA_TYPE(rblapack_t) != NA_SFLOAT)
    rblapack_t = na_change_type(rblapack_t, NA_SFLOAT);
  t = NA_PTR_TYPE(rblapack_t, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(real, (ldwork)*(k));

  slarzb_(&side, &trans, &direct, &storev, &m, &n, &k, &l, v, &ldv, t, &ldt, c, &ldc, work, &ldwork);

  free(work);
  return rblapack_c;
}

void
init_lapack_slarzb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slarzb", rblapack_slarzb, -1);
}
ruby-lapack-1.7.2/ext/cgegv.c0000644000175000017500000003212512502221025015620 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgegv_(char* jobvl, char* jobvr, integer* n, complex* a, integer* lda, complex* b, integer* ldb, complex* alpha, complex* beta, complex* vl, integer* ldvl, complex* vr, integer* ldvr, complex* work, integer* lwork, real* rwork, integer* info);


static VALUE
rblapack_cgegv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvl;
  char jobvl; 
  VALUE rblapack_jobvr;
  char jobvr; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_alpha;
  complex *alpha; 
  VALUE rblapack_beta;
  complex *beta; 
  VALUE rblapack_vl;
  complex *vl; 
  VALUE rblapack_vr;
  complex *vr; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_rwork;
  real *rwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer ldvl;
  integer ldvr;

  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  alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.cgegv( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  This routine is deprecated and has been replaced by routine CGGEV.\n*\n*  CGEGV computes the eigenvalues and, optionally, the left and/or right\n*  eigenvectors of a complex matrix pair (A,B).\n*  Given two square matrices A and B,\n*  the generalized nonsymmetric eigenvalue problem (GNEP) is to find the\n*  eigenvalues lambda and corresponding (non-zero) eigenvectors x such\n*  that\n*     A*x = lambda*B*x.\n*\n*  An alternate form is to find the eigenvalues mu and corresponding\n*  eigenvectors y such that\n*     mu*A*y = B*y.\n*\n*  These two forms are equivalent with mu = 1/lambda and x = y if\n*  neither lambda nor mu is zero.  In order to deal with the case that\n*  lambda or mu is zero or small, two values alpha and beta are returned\n*  for each eigenvalue, such that lambda = alpha/beta and\n*  mu = beta/alpha.\n*  \n*  The vectors x and y in the above equations are right eigenvectors of\n*  the matrix pair (A,B).  Vectors u and v satisfying\n*     u**H*A = lambda*u**H*B  or  mu*v**H*A = v**H*B\n*  are left eigenvectors of (A,B).\n*\n*  Note: this routine performs \"full balancing\" on A and B -- see\n*  \"Further Details\", below.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVL   (input) CHARACTER*1\n*          = 'N':  do not compute the left generalized eigenvectors;\n*          = 'V':  compute the left generalized eigenvectors (returned\n*                  in VL).\n*\n*  JOBVR   (input) CHARACTER*1\n*          = 'N':  do not compute the right generalized eigenvectors;\n*          = 'V':  compute the right generalized eigenvectors (returned\n*                  in VR).\n*\n*  N       (input) INTEGER\n*          The order of the matrices A, B, VL, and VR.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA, N)\n*          On entry, the matrix A.\n*          If JOBVL = 'V' or JOBVR = 'V', then on exit A\n*          contains the Schur form of A from the generalized Schur\n*          factorization of the pair (A,B) after balancing.  If no\n*          eigenvectors were computed, then only the diagonal elements\n*          of the Schur form will be correct.  See CGGHRD and CHGEQZ\n*          for details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of A.  LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX array, dimension (LDB, N)\n*          On entry, the matrix B.\n*          If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the\n*          upper triangular matrix obtained from B in the generalized\n*          Schur factorization of the pair (A,B) after balancing.\n*          If no eigenvectors were computed, then only the diagonal\n*          elements of B will be correct.  See CGGHRD and CHGEQZ for\n*          details.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of B.  LDB >= max(1,N).\n*\n*  ALPHA   (output) COMPLEX array, dimension (N)\n*          The complex scalars alpha that define the eigenvalues of\n*          GNEP.\n*\n*  BETA    (output) COMPLEX array, dimension (N)\n*          The complex scalars beta that define the eigenvalues of GNEP.\n*          \n*          Together, the quantities alpha = ALPHA(j) and beta = BETA(j)\n*          represent the j-th eigenvalue of the matrix pair (A,B), in\n*          one of the forms lambda = alpha/beta or mu = beta/alpha.\n*          Since either lambda or mu may overflow, they should not,\n*          in general, be computed.\n\n*\n*  VL      (output) COMPLEX array, dimension (LDVL,N)\n*          If JOBVL = 'V', the left eigenvectors u(j) are stored\n*          in the columns of VL, in the same order as their eigenvalues.\n*          Each eigenvector is scaled so that its largest component has\n*          abs(real part) + abs(imag. part) = 1, except for eigenvectors\n*          corresponding to an eigenvalue with alpha = beta = 0, which\n*          are set to zero.\n*          Not referenced if JOBVL = 'N'.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the matrix VL. LDVL >= 1, and\n*          if JOBVL = 'V', LDVL >= N.\n*\n*  VR      (output) COMPLEX array, dimension (LDVR,N)\n*          If JOBVR = 'V', the right eigenvectors x(j) are stored\n*          in the columns of VR, in the same order as their eigenvalues.\n*          Each eigenvector is scaled so that its largest component has\n*          abs(real part) + abs(imag. part) = 1, except for eigenvectors\n*          corresponding to an eigenvalue with alpha = beta = 0, which\n*          are set to zero.\n*          Not referenced if JOBVR = 'N'.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the matrix VR. LDVR >= 1, and\n*          if JOBVR = 'V', LDVR >= N.\n*\n*  WORK    (workspace/output) COMPLEX 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,2*N).\n*          For good performance, LWORK must generally be larger.\n*          To compute the optimal value of LWORK, call ILAENV to get\n*          blocksizes (for CGEQRF, CUNMQR, and CUNGQR.)  Then compute:\n*          NB  -- MAX of the blocksizes for CGEQRF, CUNMQR, and CUNGQR;\n*          The optimal LWORK is  MAX( 2*N, N*(NB+1) ).\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*  RWORK   (workspace/output) REAL array, dimension (8*N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          =1,...,N:\n*                The QZ iteration failed.  No eigenvectors have been\n*                calculated, but ALPHA(j) and BETA(j) should be\n*                correct for j=INFO+1,...,N.\n*          > N:  errors that usually indicate LAPACK problems:\n*                =N+1: error return from CGGBAL\n*                =N+2: error return from CGEQRF\n*                =N+3: error return from CUNMQR\n*                =N+4: error return from CUNGQR\n*                =N+5: error return from CGGHRD\n*                =N+6: error return from CHGEQZ (other than failed\n*                                               iteration)\n*                =N+7: error return from CTGEVC\n*                =N+8: error return from CGGBAK (computing VL)\n*                =N+9: error return from CGGBAK (computing VR)\n*                =N+10: error return from CLASCL (various calls)\n*\n\n*  Further Details\n*  ===============\n*\n*  Balancing\n*  ---------\n*\n*  This driver calls CGGBAL to both permute and scale rows and columns\n*  of A and B.  The permutations PL and PR are chosen so that PL*A*PR\n*  and PL*B*R will be upper triangular except for the diagonal blocks\n*  A(i:j,i:j) and B(i:j,i:j), with i and j as close together as\n*  possible.  The diagonal scaling matrices DL and DR are chosen so\n*  that the pair  DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to\n*  one (except for the elements that start out zero.)\n*\n*  After the eigenvalues and eigenvectors of the balanced matrices\n*  have been computed, CGGBAK transforms the eigenvectors back to what\n*  they would have been (in perfect arithmetic) if they had not been\n*  balanced.\n*\n*  Contents of A and B on Exit\n*  -------- -- - --- - -- ----\n*\n*  If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or\n*  both), then on exit the arrays A and B will contain the complex Schur\n*  form[*] of the \"balanced\" versions of A and B.  If no eigenvectors\n*  are computed, then only the diagonal blocks will be correct.\n*\n*  [*] In other words, upper triangular form.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  alpha, beta, vl, vr, work, rwork, info, a, b = NumRu::Lapack.cgegv( jobvl, jobvr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_jobvl = argv[0];
  rblapack_jobvr = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  jobvl = StringValueCStr(rblapack_jobvl)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  jobvr = StringValueCStr(rblapack_jobvr)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  ldvr = lsame_(&jobvr,"V") ? n : 1;
  if (rblapack_lwork == Qnil)
    lwork = 2*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldvl = lsame_(&jobvl,"V") ? n : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  alpha = NA_PTR_TYPE(rblapack_alpha, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = n;
    rblapack_vl = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  vl = NA_PTR_TYPE(rblapack_vl, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = n;
    rblapack_vr = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  vr = NA_PTR_TYPE(rblapack_vr, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[1];
    shape[0] = 8*n;
    rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  rwork = NA_PTR_TYPE(rblapack_rwork, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  cgegv_(&jobvl, &jobvr, &n, a, &lda, b, &ldb, alpha, beta, vl, &ldvl, vr, &ldvr, work, &lwork, rwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_alpha, rblapack_beta, rblapack_vl, rblapack_vr, rblapack_work, rblapack_rwork, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_cgegv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgegv", rblapack_cgegv, -1);
}
ruby-lapack-1.7.2/ext/sgeqp3.c0000644000175000017500000001517312502221020015726 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgeqp3_(integer* m, integer* n, real* a, integer* lda, integer* jpvt, real* tau, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sgeqp3(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_jpvt;
  integer *jpvt; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_jpvt_out__;
  integer *jpvt_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, jpvt = NumRu::Lapack.sgeqp3( m, a, jpvt, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGEQP3 computes a QR factorization with column pivoting of a\n*  matrix A:  A*P = Q*R  using Level 3 BLAS.\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) REAL array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, the upper triangle of the array contains the\n*          min(M,N)-by-N upper trapezoidal matrix R; the elements below\n*          the diagonal, together with the array TAU, represent the\n*          orthogonal matrix Q as a product of min(M,N) elementary\n*          reflectors.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  JPVT    (input/output) INTEGER array, dimension (N)\n*          On entry, if JPVT(J).ne.0, the J-th column of A is permuted\n*          to the front of A*P (a leading column); if JPVT(J)=0,\n*          the J-th column of A is a free column.\n*          On exit, if JPVT(J)=K, then the J-th column of A*P was the\n*          the K-th column of A.\n*\n*  TAU     (output) REAL array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors.\n*\n*  WORK    (workspace/output) REAL 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 >= 3*N+1.\n*          For optimal performance LWORK >= 2*N+( N+1 )*NB, where NB\n*          is the 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(1) H(2) . . . H(k), 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/complex scalar, and v is a real/complex vector\n*  with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in\n*  A(i+1:m,i), and tau in TAU(i).\n*\n*  Based on contributions by\n*    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n*    X. Sun, Computer Science Dept., Duke University, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, work, info, a, jpvt = NumRu::Lapack.sgeqp3( m, a, jpvt, [: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_m = argv[0];
  rblapack_a = argv[1];
  rblapack_jpvt = 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;
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_jpvt))
    rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
  if (NA_RANK(rblapack_jpvt) != 1)
    rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_jpvt);
  if (NA_TYPE(rblapack_jpvt) != NA_LINT)
    rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
  jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of jpvt");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (rblapack_lwork == Qnil)
    lwork = 3*n+1;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
  MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
  rblapack_jpvt = rblapack_jpvt_out__;
  jpvt = jpvt_out__;

  sgeqp3_(&m, &n, a, &lda, jpvt, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_tau, rblapack_work, rblapack_info, rblapack_a, rblapack_jpvt);
}

void
init_lapack_sgeqp3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgeqp3", rblapack_sgeqp3, -1);
}
ruby-lapack-1.7.2/ext/zsytrs2.c0000644000175000017500000001232312502221017016164 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zsytrs2_(char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* b, integer* ldb, real* work, integer* info);


static VALUE
rblapack_zsytrs2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  real *work;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.zsytrs2( uplo, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,  WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZSYTRS2 solves a system of linear equations A*X = B with a real\n*  symmetric matrix A using the factorization A = U*D*U**T or\n*  A = L*D*L**T computed by ZSYTRF and converted by ZSYCONV.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input) DOUBLE COMPLEX array, dimension (LDA,N)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by ZSYTRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by ZSYTRF.\n*\n*  B       (input/output) DOUBLE COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  WORK    (workspace) REAL array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.zsytrs2( uplo, a, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(real, (n));

  zsytrs2_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_zsytrs2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zsytrs2", rblapack_zsytrs2, -1);
}
ruby-lapack-1.7.2/ext/zlahef.c0000644000175000017500000001437612502221023016004 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlahef_(char* uplo, integer* n, integer* nb, integer* kb, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* w, integer* ldw, integer* info);


static VALUE
rblapack_zlahef(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_nb;
  integer nb; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_kb;
  integer kb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  doublecomplex *w;

  integer lda;
  integer n;
  integer ldw;

  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  kb, ipiv, info, a = NumRu::Lapack.zlahef( uplo, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZLAHEF computes a partial factorization of a complex Hermitian\n*  matrix A using the Bunch-Kaufman diagonal pivoting method. The\n*  partial factorization has the form:\n*\n*  A  =  ( I  U12 ) ( A11  0  ) (  I    0   )  if UPLO = 'U', or:\n*        ( 0  U22 ) (  0   D  ) ( U12' U22' )\n*\n*  A  =  ( L11  0 ) (  D   0  ) ( L11' L21' )  if UPLO = 'L'\n*        ( L21  I ) (  0  A22 ) (  0    I   )\n*\n*  where the order of D is at most NB. The actual order is returned in\n*  the argument KB, and is either NB or NB-1, or N if N <= NB.\n*  Note that U' denotes the conjugate transpose of U.\n*\n*  ZLAHEF is an auxiliary routine called by ZHETRF. It uses blocked code\n*  (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or\n*  A22 (if UPLO = 'L').\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          Hermitian matrix A is stored:\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NB      (input) INTEGER\n*          The maximum number of columns of the matrix A that should be\n*          factored.  NB should be at least 2 to allow for 2-by-2 pivot\n*          blocks.\n*\n*  KB      (output) INTEGER\n*          The number of columns of A that were actually factored.\n*          KB is either NB-1 or NB, or N if N <= NB.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading\n*          n-by-n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n-by-n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*          On exit, A contains details of the partial factorization.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D.\n*          If UPLO = 'U', only the last KB elements of IPIV are set;\n*          if UPLO = 'L', only the first KB elements are set.\n*\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*  W       (workspace) COMPLEX*16 array, dimension (LDW,NB)\n*\n*  LDW     (input) INTEGER\n*          The leading dimension of the array W.  LDW >= max(1,N).\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          > 0: if INFO = k, D(k,k) is exactly zero.  The factorization\n*               has been completed, but the block diagonal matrix D is\n*               exactly singular.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  kb, ipiv, info, a = NumRu::Lapack.zlahef( uplo, nb, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_nb = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  nb = NUM2INT(rblapack_nb);
  ldw = MAX(1,n);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  w = ALLOC_N(doublecomplex, (ldw)*(MAX(n,nb)));

  zlahef_(&uplo, &n, &nb, &kb, a, &lda, ipiv, w, &ldw, &info);

  free(w);
  rblapack_kb = INT2NUM(kb);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_kb, rblapack_ipiv, rblapack_info, rblapack_a);
}

void
init_lapack_zlahef(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlahef", rblapack_zlahef, -1);
}
ruby-lapack-1.7.2/ext/zsptrs.c0000644000175000017500000001172612502221015016075 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zsptrs_(char* uplo, integer* n, integer* nrhs, doublecomplex* ap, integer* ipiv, doublecomplex* b, integer* ldb, integer* info);


static VALUE
rblapack_zsptrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.zsptrs( uplo, ap, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZSPTRS solves a system of linear equations A*X = B with a complex\n*  symmetric matrix A stored in packed format using the factorization\n*  A = U*D*U**T or A = L*D*L**T computed by ZSPTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by ZSPTRF, stored as a\n*          packed triangular matrix.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by ZSPTRF.\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.zsptrs( uplo, ap, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zsptrs_(&uplo, &n, &nrhs, ap, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_zsptrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zsptrs", rblapack_zsptrs, -1);
}
ruby-lapack-1.7.2/ext/ssygvd.c0000644000175000017500000002554412502221026016054 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssygvd_(integer* itype, char* jobz, char* uplo, integer* n, real* a, integer* lda, real* b, integer* ldb, real* w, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_ssygvd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_b_out__;
  real *b_out__;

  integer lda;
  integer n;
  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  w, work, iwork, info, a, b = NumRu::Lapack.ssygvd( itype, jobz, uplo, a, b, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSYGVD computes all the eigenvalues, and optionally, the eigenvectors\n*  of a real generalized symmetric-definite eigenproblem, of the form\n*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A and\n*  B are assumed to be symmetric and B is also positive definite.\n*  If eigenvectors are desired, it uses a divide and conquer algorithm.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          Specifies the problem type to be solved:\n*          = 1:  A*x = (lambda)*B*x\n*          = 2:  A*B*x = (lambda)*x\n*          = 3:  B*A*x = (lambda)*x\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA, N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of A contains the\n*          upper triangular part of the matrix A.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of A contains\n*          the lower triangular part of the matrix A.\n*\n*          On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n*          matrix Z of eigenvectors.  The eigenvectors are normalized\n*          as follows:\n*          if ITYPE = 1 or 2, Z**T*B*Z = I;\n*          if ITYPE = 3, Z**T*inv(B)*Z = I.\n*          If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n*          or the lower triangle (if UPLO='L') of A, including the\n*          diagonal, is destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input/output) REAL array, dimension (LDB, N)\n*          On entry, the symmetric matrix B.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of B contains the\n*          upper triangular part of the matrix B.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of B contains\n*          the lower triangular part of the matrix B.\n*\n*          On exit, if INFO <= N, the part of B containing the matrix is\n*          overwritten by the triangular factor U or L from the Cholesky\n*          factorization B = U**T*U or B = L*L**T.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  W       (output) REAL array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  WORK    (workspace/output) REAL 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*          If N <= 1,               LWORK >= 1.\n*          If JOBZ = 'N' and N > 1, LWORK >= 2*N+1.\n*          If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal sizes of the WORK and IWORK\n*          arrays, returns these values as the first entries of the WORK\n*          and IWORK arrays, and no error message related to LWORK or\n*          LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.\n*          If N <= 1,                LIWORK >= 1.\n*          If JOBZ  = 'N' and N > 1, LIWORK >= 1.\n*          If JOBZ  = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK and IWORK arrays, and no error message related to\n*          LWORK or LIWORK 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:  SPOTRF or SSYEVD returned an error code:\n*             <= N:  if INFO = i and JOBZ = 'N', then the algorithm\n*                    failed to converge; i off-diagonal elements of an\n*                    intermediate tridiagonal form did not converge to\n*                    zero;\n*                    if INFO = i and JOBZ = 'V', then the algorithm\n*                    failed to compute an eigenvalue while working on\n*                    the submatrix lying in rows and columns INFO/(N+1)\n*                    through mod(INFO,N+1);\n*             > N:   if INFO = N + i, for 1 <= i <= N, then the leading\n*                    minor of order i of B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n*  Modified so that no backsubstitution is performed if SSYEVD fails to\n*  converge (NEIG in old code could be greater than N causing out of\n*  bounds reference to A - reported by Ralf Meyer).  Also corrected the\n*  description of INFO and the test on ITYPE. Sven, 16 Feb 05.\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, work, iwork, info, a, b = NumRu::Lapack.ssygvd( itype, jobz, uplo, a, b, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_itype = argv[0];
  rblapack_jobz = argv[1];
  rblapack_uplo = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  if (argc == 7) {
    rblapack_lwork = argv[5];
    rblapack_liwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  itype = NUM2INT(rblapack_itype);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (rblapack_liwork == Qnil)
    liwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  if (rblapack_lwork == Qnil)
    lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 2*n+1 : lsame_(&jobz,"V") ? 1+6*n+2*n*n : 1;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  ssygvd_(&itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, work, &lwork, iwork, &liwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_w, rblapack_work, rblapack_iwork, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_ssygvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssygvd", rblapack_ssygvd, -1);
}
ruby-lapack-1.7.2/ext/ctpttf.c0000644000175000017500000001672512502221015016040 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctpttf_(char* transr, char* uplo, integer* n, complex* ap, complex* arf, integer* info);


static VALUE
rblapack_ctpttf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_arf;
  complex *arf; 
  VALUE rblapack_info;
  integer info; 


  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  arf, info = NumRu::Lapack.ctpttf( transr, uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTPTTF( TRANSR, UPLO, N, AP, ARF, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTPTTF copies a triangular matrix A from standard packed format (TP)\n*  to rectangular full packed format (TF).\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR   (input) CHARACTER*1\n*          = 'N':  ARF in Normal format is wanted;\n*          = 'C':  ARF in Conjugate-transpose format is wanted.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input) COMPLEX array, dimension ( N*(N+1)/2 ),\n*          On entry, the upper or lower triangular matrix A, packed\n*          columnwise in a linear array. The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  ARF     (output) COMPLEX array, dimension ( N*(N+1)/2 ),\n*          On exit, the upper or lower triangular matrix A stored in\n*          RFP format. For a further discussion see Notes below.\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*  We first consider Standard Packed Format when N is even.\n*  We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  conjugate-transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  conjugate-transpose of the last three columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                -- -- --\n*        03 04 05                33 43 53\n*                                   -- --\n*        13 14 15                00 44 54\n*                                      --\n*        23 24 25                10 11 55\n*\n*        33 34 35                20 21 22\n*        --\n*        00 44 45                30 31 32\n*        -- --\n*        01 11 55                40 41 42\n*        -- -- --\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- -- --                -- -- -- -- -- --\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     -- -- -- -- --                -- -- -- -- --\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     -- -- -- -- -- --                -- -- -- --\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We next  consider Standard Packed Format when N is odd.\n*  We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  conjugate-transpose of the first two   columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  conjugate-transpose of the last two   columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N odd  and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                   -- --\n*        02 03 04                00 33 43\n*                                      --\n*        12 13 14                10 11 44\n*\n*        22 23 24                20 21 22\n*        --\n*        00 33 34                30 31 32\n*        -- --\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- --                   -- -- -- -- -- --\n*     02 12 22 00 01             00 10 20 30 40 50\n*     -- -- -- --                   -- -- -- -- --\n*     03 13 23 33 11             33 11 21 31 41 51\n*     -- -- -- -- --                   -- -- -- --\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  arf, info = NumRu::Lapack.ctpttf( transr, uplo, n, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_n = argv[2];
  rblapack_ap = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  n = NUM2INT(rblapack_n);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (( n*(n+1)/2 )))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", ( n*(n+1)/2 ));
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  {
    na_shape_t shape[1];
    shape[0] = ( n*(n+1)/2 );
    rblapack_arf = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  arf = NA_PTR_TYPE(rblapack_arf, complex*);

  ctpttf_(&transr, &uplo, &n, ap, arf, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_arf, rblapack_info);
}

void
init_lapack_ctpttf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctpttf", rblapack_ctpttf, -1);
}
ruby-lapack-1.7.2/ext/sgeqrfp.c0000644000175000017500000001330312502221024016170 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgeqrfp_(integer* m, integer* n, real* a, integer* lda, real* tau, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sgeqrfp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *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.sgeqrfp( m, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGEQRFP computes a QR factorization of a real M-by-N matrix A:\n*  A = Q * R.\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) REAL array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, the elements on and above the diagonal of the array\n*          contain the min(M,N)-by-N upper trapezoidal matrix R (R is\n*          upper triangular if m >= n); the elements below the diagonal,\n*          with the array TAU, represent the orthogonal matrix Q as a\n*          product of min(m,n) elementary reflectors (see Further\n*          Details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  TAU     (output) REAL array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace/output) REAL 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,N).\n*          For optimum performance LWORK >= N*NB, where NB is \n*          the 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(1) H(2) . . . H(k), 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:m) is stored on exit in A(i+1:m,i),\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           SGEQR2P, SLARFB, SLARFT, 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.sgeqrfp( 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;
  }

  m = NUM2INT(rblapack_m);
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (rblapack_lwork == Qnil)
    lwork = n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  sgeqrfp_(&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_sgeqrfp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgeqrfp", rblapack_sgeqrfp, -1);
}
ruby-lapack-1.7.2/ext/slanhs.c0000644000175000017500000000721612502221012016014 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real slanhs_(char* norm, integer* n, real* a, integer* lda, real* work);


static VALUE
rblapack_slanhs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack___out__;
  real __out__; 
  real *work;

  integer lda;
  integer n;
  integer lwork;

  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  __out__ = NumRu::Lapack.slanhs( norm, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL             FUNCTION SLANHS( NORM, N, A, LDA, WORK )\n\n*  Purpose\n*  =======\n*\n*  SLANHS  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  Hessenberg matrix A.\n*\n*  Description\n*  ===========\n*\n*  SLANHS returns the value\n*\n*     SLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in SLANHS as described\n*          above.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, SLANHS is\n*          set to zero.\n*\n*  A       (input) REAL array, dimension (LDA,N)\n*          The n by n upper Hessenberg matrix A; the part of A below the\n*          first sub-diagonal is not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(N,1).\n*\n*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n*          referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.slanhs( norm, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_norm = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  lwork = lsame_(&norm,"I") ? n : 0;
  work = ALLOC_N(real, (MAX(1,lwork)));

  __out__ = slanhs_(&norm, &n, a, &lda, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_slanhs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slanhs", rblapack_slanhs, -1);
}
ruby-lapack-1.7.2/ext/sorgrq.c0000644000175000017500000001237412502221020016041 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sorgrq_(integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sorgrq(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;

  integer lda;
  integer n;
  integer k;

  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 = NumRu::Lapack.sorgrq( m, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SORGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SORGRQ generates an M-by-N real matrix Q with orthonormal rows,\n*  which is defined as the last M rows of a product of K elementary\n*  reflectors of order N\n*\n*        Q  =  H(1) H(2) . . . H(k)\n*\n*  as returned by SGERQF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. N >= M.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. M >= K >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the (m-k+i)-th row must contain the vector which\n*          defines the elementary reflector H(i), for i = 1,2,...,k, as\n*          returned by SGERQF in the last k rows of its array argument\n*          A.\n*          On exit, the M-by-N matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) REAL array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by SGERQF.\n*\n*  WORK    (workspace/output) REAL 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 has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, a = NumRu::Lapack.sorgrq( m, a, tau, [: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_m = argv[0];
  rblapack_a = argv[1];
  rblapack_tau = 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;
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (rblapack_lwork == Qnil)
    lwork = m;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  sorgrq_(&m, &n, &k, a, &lda, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_sorgrq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sorgrq", rblapack_sorgrq, -1);
}
ruby-lapack-1.7.2/ext/cpbequ.c0000644000175000017500000001141612502221022016001 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cpbequ_(char* uplo, integer* n, integer* kd, complex* ab, integer* ldab, real* s, real* scond, real* amax, integer* info);


static VALUE
rblapack_cpbequ(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_scond;
  real scond; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_info;
  integer info; 

  integer ldab;
  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  s, scond, amax, info = NumRu::Lapack.cpbequ( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPBEQU computes row and column scalings intended to equilibrate a\n*  Hermitian positive definite band matrix A and reduce its condition\n*  number (with respect to the two-norm).  S contains the scale factors,\n*  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n*  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This\n*  choice of S puts the condition number of B within a factor N of the\n*  smallest possible condition number over all possible diagonal\n*  scalings.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangular of A is stored;\n*          = 'L':  Lower triangular of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input) COMPLEX array, dimension (LDAB,N)\n*          The upper or lower triangle of the Hermitian band matrix A,\n*          stored in the first KD+1 rows of the array.  The j-th column\n*          of A is stored in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*  LDAB     (input) INTEGER\n*          The leading dimension of the array A.  LDAB >= KD+1.\n*\n*  S       (output) REAL array, dimension (N)\n*          If INFO = 0, S contains the scale factors for A.\n*\n*  SCOND   (output) REAL\n*          If INFO = 0, S contains the ratio of the smallest S(i) to\n*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too\n*          large nor too small, it is not worth scaling by S.\n*\n*  AMAX    (output) REAL\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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 is nonpositive.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, scond, amax, info = NumRu::Lapack.cpbequ( uplo, kd, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  kd = NUM2INT(rblapack_kd);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, real*);

  cpbequ_(&uplo, &n, &kd, ab, &ldab, s, &scond, &amax, &info);

  rblapack_scond = rb_float_new((double)scond);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
}

void
init_lapack_cpbequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cpbequ", rblapack_cpbequ, -1);
}
ruby-lapack-1.7.2/ext/sgbtrf.c0000644000175000017500000001310012502221016016004 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgbtrf_(integer* m, integer* n, integer* kl, integer* ku, real* ab, integer* ldab, integer* ipiv, integer* info);


static VALUE
rblapack_sgbtrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  real *ab_out__;

  integer ldab;
  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  ipiv, info, ab = NumRu::Lapack.sgbtrf( m, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGBTRF computes an LU factorization of a real m-by-n band matrix A\n*  using partial pivoting with row interchanges.\n*\n*  This is the blocked version of the algorithm, calling Level 3 BLAS.\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*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  AB      (input/output) REAL array, dimension (LDAB,N)\n*          On entry, the matrix A in band storage, in rows KL+1 to\n*          2*KL+KU+1; rows 1 to KL of the array need not be set.\n*          The j-th column of A is stored in the j-th column of the\n*          array AB as follows:\n*          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n*          On exit, details of the factorization: U is stored as an\n*          upper triangular band matrix with KL+KU superdiagonals in\n*          rows 1 to KL+KU+1, and the multipliers used during the\n*          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n*          See below for further details.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.\n*\n*  IPIV    (output) INTEGER array, dimension (min(M,N))\n*          The pivot indices; for 1 <= i <= min(M,N), row i of the\n*          matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n*               has been completed, but the factor U is exactly\n*               singular, and division by zero will occur if it is used\n*               to solve a system of equations.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  M = N = 6, KL = 2, KU = 1:\n*\n*  On entry:                       On exit:\n*\n*      *    *    *    +    +    +       *    *    *   u14  u25  u36\n*      *    *    +    +    +    +       *    *   u13  u24  u35  u46\n*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56\n*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66\n*     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *\n*     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *\n*\n*  Array elements marked * are not used by the routine; elements marked\n*  + need not be set on entry, but are required by the routine to store\n*  elements of U because of fill-in resulting from the row interchanges.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, ab = NumRu::Lapack.sgbtrf( m, kl, ku, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_m = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  ku = NUM2INT(rblapack_ku);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
  MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  sgbtrf_(&m, &n, &kl, &ku, ab, &ldab, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_ab);
}

void
init_lapack_sgbtrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgbtrf", rblapack_sgbtrf, -1);
}
ruby-lapack-1.7.2/ext/slarrr.c0000644000175000017500000000750712502221023016036 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slarrr_(integer* n, real* d, real* e, integer* info);


static VALUE
rblapack_slarrr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_e_out__;
  real *e_out__;

  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  info, e = NumRu::Lapack.slarrr( d, e, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLARRR( N, D, E, INFO )\n\n*  Purpose\n*  =======\n*\n*  Perform tests to decide whether the symmetric tridiagonal matrix T\n*  warrants expensive computations which guarantee high relative accuracy\n*  in the eigenvalues.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix. N > 0.\n*\n*  D       (input) REAL             array, dimension (N)\n*          The N diagonal elements of the tridiagonal matrix T.\n*\n*  E       (input/output) REAL array, dimension (N)\n*          On entry, the first (N-1) entries contain the subdiagonal\n*          elements of the tridiagonal matrix T; E(N) is set to ZERO.\n*\n*  INFO    (output) INTEGER\n*          INFO = 0(default) : the matrix warrants computations preserving\n*                              relative accuracy.\n*          INFO = 1          : the matrix warrants computations guaranteeing\n*                              only absolute accuracy.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Beresford Parlett, University of California, Berkeley, USA\n*     Jim Demmel, University of California, Berkeley, USA\n*     Inderjit Dhillon, University of Texas, Austin, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, e = NumRu::Lapack.slarrr( d, e, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_d = argv[0];
  rblapack_e = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (1th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (2th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
  MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;

  slarrr_(&n, d, e, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_e);
}

void
init_lapack_slarrr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slarrr", rblapack_slarrr, -1);
}
ruby-lapack-1.7.2/ext/ssteqr.c0000644000175000017500000001523112502221014016043 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssteqr_(char* compz, integer* n, real* d, real* e, real* z, integer* ldz, real* work, integer* info);


static VALUE
rblapack_ssteqr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_compz;
  char compz; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_e_out__;
  real *e_out__;
  VALUE rblapack_z_out__;
  real *z_out__;
  real *work;

  integer n;
  integer ldz;

  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  info, d, e, z = NumRu::Lapack.ssteqr( compz, d, e, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSTEQR computes all eigenvalues and, optionally, eigenvectors of a\n*  symmetric tridiagonal matrix using the implicit QL or QR method.\n*  The eigenvectors of a full or band symmetric matrix can also be found\n*  if SSYTRD or SSPTRD or SSBTRD has been used to reduce this matrix to\n*  tridiagonal form.\n*\n\n*  Arguments\n*  =========\n*\n*  COMPZ   (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only.\n*          = 'V':  Compute eigenvalues and eigenvectors of the original\n*                  symmetric matrix.  On entry, Z must contain the\n*                  orthogonal matrix used to reduce the original matrix\n*                  to tridiagonal form.\n*          = 'I':  Compute eigenvalues and eigenvectors of the\n*                  tridiagonal matrix.  Z is initialized to the identity\n*                  matrix.\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  D       (input/output) REAL array, dimension (N)\n*          On entry, the diagonal elements of the tridiagonal matrix.\n*          On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n*  E       (input/output) REAL array, dimension (N-1)\n*          On entry, the (n-1) subdiagonal elements of the tridiagonal\n*          matrix.\n*          On exit, E has been destroyed.\n*\n*  Z       (input/output) REAL array, dimension (LDZ, N)\n*          On entry, if  COMPZ = 'V', then Z contains the orthogonal\n*          matrix used in the reduction to tridiagonal form.\n*          On exit, if INFO = 0, then if  COMPZ = 'V', Z contains the\n*          orthonormal eigenvectors of the original symmetric matrix,\n*          and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n*          of the symmetric tridiagonal matrix.\n*          If COMPZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          eigenvectors are desired, then  LDZ >= max(1,N).\n*\n*  WORK    (workspace) REAL array, dimension (max(1,2*N-2))\n*          If COMPZ = 'N', then WORK is not referenced.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  the algorithm has failed to find all the eigenvalues in\n*                a total of 30*N iterations; if INFO = i, then i\n*                elements of E have not converged to zero; on exit, D\n*                and E contain the elements of a symmetric tridiagonal\n*                matrix which is orthogonally similar to the original\n*                matrix.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, e, z = NumRu::Lapack.ssteqr( compz, d, e, z, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_compz = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  rblapack_z = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  compz = StringValueCStr(rblapack_compz)[0];
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (4th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  n = NA_SHAPE1(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of z");
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
  MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
  MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  work = ALLOC_N(real, (lsame_(&compz,"N") ? 0 : MAX(1,2*n-2)));

  ssteqr_(&compz, &n, d, e, z, &ldz, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_e, rblapack_z);
}

void
init_lapack_ssteqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssteqr", rblapack_ssteqr, -1);
}
ruby-lapack-1.7.2/ext/zlatzm.c0000644000175000017500000001650712502221016016054 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlatzm_(char* side, integer* m, integer* n, doublecomplex* v, integer* incv, doublecomplex* tau, doublecomplex* c1, doublecomplex* c2, integer* ldc, doublecomplex* work);


static VALUE
rblapack_zlatzm(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_v;
  doublecomplex *v; 
  VALUE rblapack_incv;
  integer incv; 
  VALUE rblapack_tau;
  doublecomplex tau; 
  VALUE rblapack_c1;
  doublecomplex *c1; 
  VALUE rblapack_c2;
  doublecomplex *c2; 
  VALUE rblapack_c1_out__;
  doublecomplex *c1_out__;
  VALUE rblapack_c2_out__;
  doublecomplex *c2_out__;
  doublecomplex *work;

  integer ldc;

  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  c1, c2 = NumRu::Lapack.zlatzm( side, m, n, v, incv, tau, c1, c2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK )\n\n*  Purpose\n*  =======\n*\n*  This routine is deprecated and has been replaced by routine ZUNMRZ.\n*\n*  ZLATZM applies a Householder matrix generated by ZTZRQF to a matrix.\n*\n*  Let P = I - tau*u*u',   u = ( 1 ),\n*                              ( v )\n*  where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if\n*  SIDE = 'R'.\n*\n*  If SIDE equals 'L', let\n*         C = [ C1 ] 1\n*             [ C2 ] m-1\n*               n\n*  Then C is overwritten by P*C.\n*\n*  If SIDE equals 'R', let\n*         C = [ C1, C2 ] m\n*                1  n-1\n*  Then C is overwritten by C*P.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': form P * C\n*          = 'R': form C * P\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C.\n*\n*  V       (input) COMPLEX*16 array, dimension\n*                  (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n*                  (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n*          The vector v in the representation of P. V is not used\n*          if TAU = 0.\n*\n*  INCV    (input) INTEGER\n*          The increment between elements of v. INCV <> 0\n*\n*  TAU     (input) COMPLEX*16\n*          The value tau in the representation of P.\n*\n*  C1      (input/output) COMPLEX*16 array, dimension\n*                         (LDC,N) if SIDE = 'L'\n*                         (M,1)   if SIDE = 'R'\n*          On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1\n*          if SIDE = 'R'.\n*\n*          On exit, the first row of P*C if SIDE = 'L', or the first\n*          column of C*P if SIDE = 'R'.\n*\n*  C2      (input/output) COMPLEX*16 array, dimension\n*                         (LDC, N)   if SIDE = 'L'\n*                         (LDC, N-1) if SIDE = 'R'\n*          On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the\n*          m x (n - 1) matrix C2 if SIDE = 'R'.\n*\n*          On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P\n*          if SIDE = 'R'.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the arrays C1 and C2.\n*          LDC >= max(1,M).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension\n*                      (N) if SIDE = 'L'\n*                      (M) if SIDE = 'R'\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c1, c2 = NumRu::Lapack.zlatzm( side, m, n, v, incv, tau, c1, c2, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_side = argv[0];
  rblapack_m = argv[1];
  rblapack_n = argv[2];
  rblapack_v = argv[3];
  rblapack_incv = argv[4];
  rblapack_tau = argv[5];
  rblapack_c1 = argv[6];
  rblapack_c2 = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  n = NUM2INT(rblapack_n);
  incv = NUM2INT(rblapack_incv);
  if (!NA_IsNArray(rblapack_c2))
    rb_raise(rb_eArgError, "c2 (8th argument) must be NArray");
  if (NA_RANK(rblapack_c2) != 2)
    rb_raise(rb_eArgError, "rank of c2 (8th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c2);
  if (NA_SHAPE1(rblapack_c2) != (lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0))
    rb_raise(rb_eRuntimeError, "shape 1 of c2 must be %d", lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0);
  if (NA_TYPE(rblapack_c2) != NA_DCOMPLEX)
    rblapack_c2 = na_change_type(rblapack_c2, NA_DCOMPLEX);
  c2 = NA_PTR_TYPE(rblapack_c2, doublecomplex*);
  m = NUM2INT(rblapack_m);
  tau.r = NUM2DBL(rb_funcall(rblapack_tau, rb_intern("real"), 0));
  tau.i = NUM2DBL(rb_funcall(rblapack_tau, rb_intern("imag"), 0));
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (4th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 1)
    rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_v) != (1 + (m-1)*abs(incv)))
    rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1 + (m-1)*abs(incv));
  if (NA_TYPE(rblapack_v) != NA_DCOMPLEX)
    rblapack_v = na_change_type(rblapack_v, NA_DCOMPLEX);
  v = NA_PTR_TYPE(rblapack_v, doublecomplex*);
  if (!NA_IsNArray(rblapack_c1))
    rb_raise(rb_eArgError, "c1 (7th argument) must be NArray");
  if (NA_RANK(rblapack_c1) != 2)
    rb_raise(rb_eArgError, "rank of c1 (7th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_c1) != (lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0))
    rb_raise(rb_eRuntimeError, "shape 0 of c1 must be %d", lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0);
  if (NA_SHAPE1(rblapack_c1) != (lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0))
    rb_raise(rb_eRuntimeError, "shape 1 of c1 must be %d", lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0);
  if (NA_TYPE(rblapack_c1) != NA_DCOMPLEX)
    rblapack_c1 = na_change_type(rblapack_c1, NA_DCOMPLEX);
  c1 = NA_PTR_TYPE(rblapack_c1, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0;
    shape[1] = lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0;
    rblapack_c1_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  c1_out__ = NA_PTR_TYPE(rblapack_c1_out__, doublecomplex*);
  MEMCPY(c1_out__, c1, doublecomplex, NA_TOTAL(rblapack_c1));
  rblapack_c1 = rblapack_c1_out__;
  c1 = c1_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0;
    rblapack_c2_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  c2_out__ = NA_PTR_TYPE(rblapack_c2_out__, doublecomplex*);
  MEMCPY(c2_out__, c2, doublecomplex, NA_TOTAL(rblapack_c2));
  rblapack_c2 = rblapack_c2_out__;
  c2 = c2_out__;
  work = ALLOC_N(doublecomplex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  zlatzm_(&side, &m, &n, v, &incv, &tau, c1, c2, &ldc, work);

  free(work);
  return rb_ary_new3(2, rblapack_c1, rblapack_c2);
}

void
init_lapack_zlatzm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlatzm", rblapack_zlatzm, -1);
}
ruby-lapack-1.7.2/ext/sppcon.c0000644000175000017500000001004112502221020016013 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sppcon_(char* uplo, integer* n, real* ap, real* anorm, real* rcond, real* work, integer* iwork, integer* info);


static VALUE
rblapack_sppcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_anorm;
  real anorm; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_info;
  integer info; 
  real *work;
  integer *iwork;

  integer ldap;
  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  rcond, info = NumRu::Lapack.sppcon( uplo, ap, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPPCON( UPLO, N, AP, ANORM, RCOND, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPPCON estimates the reciprocal of the condition number (in the\n*  1-norm) of a real symmetric positive definite packed matrix using\n*  the Cholesky factorization A = U**T*U or A = L*L**T computed by\n*  SPPTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input) REAL array, dimension (N*(N+1)/2)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**T*U or A = L*L**T, packed columnwise in a linear\n*          array.  The j-th column of U or L is stored in the array AP\n*          as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n*  ANORM   (input) REAL\n*          The 1-norm (or infinity-norm) of the symmetric matrix A.\n*\n*  RCOND   (output) REAL\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n*          estimate of the 1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) REAL array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.sppcon( uplo, ap, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_anorm = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  anorm = (real)NUM2DBL(rblapack_anorm);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  work = ALLOC_N(real, (3*n));
  iwork = ALLOC_N(integer, (n));

  sppcon_(&uplo, &n, ap, &anorm, &rcond, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_sppcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sppcon", rblapack_sppcon, -1);
}
ruby-lapack-1.7.2/ext/dlahqr.c0000644000175000017500000002303512502221026016001 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlahqr_(logical* wantt, logical* wantz, integer* n, integer* ilo, integer* ihi, doublereal* h, integer* ldh, doublereal* wr, doublereal* wi, integer* iloz, integer* ihiz, doublereal* z, integer* ldz, integer* info);


static VALUE
rblapack_dlahqr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantt;
  logical wantt; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_h;
  doublereal *h; 
  VALUE rblapack_iloz;
  integer iloz; 
  VALUE rblapack_ihiz;
  integer ihiz; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_ldz;
  integer ldz; 
  VALUE rblapack_wr;
  doublereal *wr; 
  VALUE rblapack_wi;
  doublereal *wi; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_h_out__;
  doublereal *h_out__;
  VALUE rblapack_z_out__;
  doublereal *z_out__;

  integer ldh;
  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  wr, wi, info, h, z = NumRu::Lapack.dlahqr( wantt, wantz, ilo, ihi, h, iloz, ihiz, z, ldz, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILOZ, IHIZ, Z, LDZ, INFO )\n\n*     Purpose\n*     =======\n*\n*     DLAHQR is an auxiliary routine called by DHSEQR to update the\n*     eigenvalues and Schur decomposition already computed by DHSEQR, by\n*     dealing with the Hessenberg submatrix in rows and columns ILO to\n*     IHI.\n*\n\n*     Arguments\n*     =========\n*\n*     WANTT   (input) LOGICAL\n*          = .TRUE. : the full Schur form T is required;\n*          = .FALSE.: only eigenvalues are required.\n*\n*     WANTZ   (input) LOGICAL\n*          = .TRUE. : the matrix of Schur vectors Z is required;\n*          = .FALSE.: Schur vectors are not required.\n*\n*     N       (input) INTEGER\n*          The order of the matrix H.  N >= 0.\n*\n*     ILO     (input) INTEGER\n*     IHI     (input) INTEGER\n*          It is assumed that H is already upper quasi-triangular in\n*          rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless\n*          ILO = 1). DLAHQR works primarily with the Hessenberg\n*          submatrix in rows and columns ILO to IHI, but applies\n*          transformations to all of H if WANTT is .TRUE..\n*          1 <= ILO <= max(1,IHI); IHI <= N.\n*\n*     H       (input/output) DOUBLE PRECISION array, dimension (LDH,N)\n*          On entry, the upper Hessenberg matrix H.\n*          On exit, if INFO is zero and if WANTT is .TRUE., H is upper\n*          quasi-triangular in rows and columns ILO:IHI, with any\n*          2-by-2 diagonal blocks in standard form. If INFO is zero\n*          and WANTT is .FALSE., the contents of H are unspecified on\n*          exit.  The output state of H if INFO is nonzero is given\n*          below under the description of INFO.\n*\n*     LDH     (input) INTEGER\n*          The leading dimension of the array H. LDH >= max(1,N).\n*\n*     WR      (output) DOUBLE PRECISION array, dimension (N)\n*     WI      (output) DOUBLE PRECISION array, dimension (N)\n*          The real and imaginary parts, respectively, of the computed\n*          eigenvalues ILO to IHI are stored in the corresponding\n*          elements of WR and WI. If two eigenvalues are computed as a\n*          complex conjugate pair, they are stored in consecutive\n*          elements of WR and WI, say the i-th and (i+1)th, with\n*          WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the\n*          eigenvalues are stored in the same order as on the diagonal\n*          of the Schur form returned in H, with WR(i) = H(i,i), and, if\n*          H(i:i+1,i:i+1) is a 2-by-2 diagonal block,\n*          WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i).\n*\n*     ILOZ    (input) INTEGER\n*     IHIZ    (input) INTEGER\n*          Specify the rows of Z to which transformations must be\n*          applied if WANTZ is .TRUE..\n*          1 <= ILOZ <= ILO; IHI <= IHIZ <= N.\n*\n*     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n*          If WANTZ is .TRUE., on entry Z must contain the current\n*          matrix Z of transformations accumulated by DHSEQR, and on\n*          exit Z has been updated; transformations are applied only to\n*          the submatrix Z(ILOZ:IHIZ,ILO:IHI).\n*          If WANTZ is .FALSE., Z is not referenced.\n*\n*     LDZ     (input) INTEGER\n*          The leading dimension of the array Z. LDZ >= max(1,N).\n*\n*     INFO    (output) INTEGER\n*           =   0: successful exit\n*          .GT. 0: If INFO = i, DLAHQR failed to compute all the\n*                  eigenvalues ILO to IHI in a total of 30 iterations\n*                  per eigenvalue; elements i+1:ihi of WR and WI\n*                  contain those eigenvalues which have been\n*                  successfully computed.\n*\n*                  If INFO .GT. 0 and WANTT is .FALSE., then on exit,\n*                  the remaining unconverged eigenvalues are the\n*                  eigenvalues of the upper Hessenberg matrix rows\n*                  and columns ILO thorugh INFO of the final, output\n*                  value of H.\n*\n*                  If INFO .GT. 0 and WANTT is .TRUE., then on exit\n*          (*)       (initial value of H)*U  = U*(final value of H)\n*                  where U is an orthognal matrix.    The final\n*                  value of H is upper Hessenberg and triangular in\n*                  rows and columns INFO+1 through IHI.\n*\n*                  If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n*                      (final value of Z)  = (initial value of Z)*U\n*                  where U is the orthogonal matrix in (*)\n*                  (regardless of the value of WANTT.)\n*\n\n*     Further Details\n*     ===============\n*\n*     02-96 Based on modifications by\n*     David Day, Sandia National Laboratory, USA\n*\n*     12-04 Further modifications by\n*     Ralph Byers, University of Kansas, USA\n*     This is a modified version of DLAHQR from LAPACK version 3.0.\n*     It is (1) more robust against overflow and underflow and\n*     (2) adopts the more conservative Ahues & Tisseur stopping\n*     criterion (LAWN 122, 1997).\n*\n*     =========================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  wr, wi, info, h, z = NumRu::Lapack.dlahqr( wantt, wantz, ilo, ihi, h, iloz, ihiz, z, ldz, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_wantt = argv[0];
  rblapack_wantz = argv[1];
  rblapack_ilo = argv[2];
  rblapack_ihi = argv[3];
  rblapack_h = argv[4];
  rblapack_iloz = argv[5];
  rblapack_ihiz = argv[6];
  rblapack_z = argv[7];
  rblapack_ldz = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  wantt = (rblapack_wantt == Qtrue);
  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (5th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_DFLOAT)
    rblapack_h = na_change_type(rblapack_h, NA_DFLOAT);
  h = NA_PTR_TYPE(rblapack_h, doublereal*);
  ihiz = NUM2INT(rblapack_ihiz);
  ldz = NUM2INT(rblapack_ldz);
  wantz = (rblapack_wantz == Qtrue);
  iloz = NUM2INT(rblapack_iloz);
  ihi = NUM2INT(rblapack_ihi);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (8th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_z) != (wantz ? ldz : 0))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantz ? ldz : 0);
  if (NA_SHAPE1(rblapack_z) != (wantz ? n : 0))
    rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantz ? n : 0);
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  wr = NA_PTR_TYPE(rblapack_wr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wi = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  wi = NA_PTR_TYPE(rblapack_wi, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublereal*);
  MEMCPY(h_out__, h, doublereal, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = wantz ? ldz : 0;
    shape[1] = wantz ? n : 0;
    rblapack_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
  MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  dlahqr_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, wr, wi, &iloz, &ihiz, z, &ldz, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_wr, rblapack_wi, rblapack_info, rblapack_h, rblapack_z);
}

void
init_lapack_dlahqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlahqr", rblapack_dlahqr, -1);
}
ruby-lapack-1.7.2/ext/chbevx.c0000644000175000017500000002511112502221026016002 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chbevx_(char* jobz, char* range, char* uplo, integer* n, integer* kd, complex* ab, integer* ldab, complex* q, integer* ldq, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, complex* z, integer* ldz, complex* work, real* rwork, integer* iwork, integer* ifail, integer* info);


static VALUE
rblapack_chbevx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_vl;
  real vl; 
  VALUE rblapack_vu;
  real vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  real abstol; 
  VALUE rblapack_q;
  complex *q; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_ifail;
  integer *ifail; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  complex *ab_out__;
  complex *work;
  real *rwork;
  integer *iwork;

  integer ldab;
  integer n;
  integer ldq;
  integer ldz;

  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  q, m, w, z, ifail, info, ab = NumRu::Lapack.chbevx( jobz, range, uplo, kd, ab, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, IFAIL, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHBEVX computes selected eigenvalues and, optionally, eigenvectors\n*  of a complex Hermitian band matrix A.  Eigenvalues and eigenvectors\n*  can be selected by specifying either a range of values or a range of\n*  indices for the desired eigenvalues.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found;\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found;\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) COMPLEX array, dimension (LDAB, N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*          On exit, AB is overwritten by values generated during the\n*          reduction to tridiagonal form.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD + 1.\n*\n*  Q       (output) COMPLEX array, dimension (LDQ, N)\n*          If JOBZ = 'V', the N-by-N unitary matrix used in the\n*                          reduction to tridiagonal form.\n*          If JOBZ = 'N', the array Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.  If JOBZ = 'V', then\n*          LDQ >= max(1,N).\n*\n*  VL      (input) REAL\n*  VU      (input) REAL\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) REAL\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less than\n*          or equal to zero, then  EPS*|T|  will be used in its place,\n*          where |T| is the 1-norm of the tridiagonal matrix obtained\n*          by reducing AB to tridiagonal form.\n*\n*          Eigenvalues will be computed most accurately when ABSTOL is\n*          set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n*          If this routine returns with INFO>0, indicating that some\n*          eigenvectors did not converge, try setting ABSTOL to\n*          2*SLAMCH('S').\n*\n*          See \"Computing Small Singular Values of Bidiagonal Matrices\n*          with Guaranteed High Relative Accuracy,\" by Demmel and\n*          Kahan, LAPACK Working Note #3.\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) REAL array, dimension (N)\n*          The first M elements contain the selected eigenvalues in\n*          ascending order.\n*\n*  Z       (output) COMPLEX array, dimension (LDZ, max(1,M))\n*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix A\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          If an eigenvector fails to converge, then that column of Z\n*          contains the latest approximation to the eigenvector, and the\n*          index of the eigenvector is returned in IFAIL.\n*          If JOBZ = 'N', then Z is not referenced.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace) COMPLEX array, dimension (N)\n*\n*  RWORK   (workspace) REAL array, dimension (7*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (5*N)\n*\n*  IFAIL   (output) INTEGER array, dimension (N)\n*          If JOBZ = 'V', then if INFO = 0, the first M elements of\n*          IFAIL are zero.  If INFO > 0, then IFAIL contains the\n*          indices of the eigenvectors that failed to converge.\n*          If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n*                Their indices are stored in array IFAIL.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  q, m, w, z, ifail, info, ab = NumRu::Lapack.chbevx( jobz, range, uplo, kd, ab, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_uplo = argv[2];
  rblapack_kd = argv[3];
  rblapack_ab = argv[4];
  rblapack_vl = argv[5];
  rblapack_vu = argv[6];
  rblapack_il = argv[7];
  rblapack_iu = argv[8];
  rblapack_abstol = argv[9];
  if (argc == 10) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  vu = (real)NUM2DBL(rblapack_vu);
  iu = NUM2INT(rblapack_iu);
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  ldq = lsame_(&jobz,"V") ? MAX(1,n) : 0;
  range = StringValueCStr(rblapack_range)[0];
  vl = (real)NUM2DBL(rblapack_vl);
  abstol = (real)NUM2DBL(rblapack_abstol);
  kd = NUM2INT(rblapack_kd);
  il = NUM2INT(rblapack_il);
  m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  q = NA_PTR_TYPE(rblapack_q, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
  MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  work = ALLOC_N(complex, (n));
  rwork = ALLOC_N(real, (7*n));
  iwork = ALLOC_N(integer, (5*n));

  chbevx_(&jobz, &range, &uplo, &n, &kd, ab, &ldab, q, &ldq, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, rwork, iwork, ifail, &info);

  free(work);
  free(rwork);
  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_q, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_ab);
}

void
init_lapack_chbevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chbevx", rblapack_chbevx, -1);
}
ruby-lapack-1.7.2/ext/zlaqr1.c0000644000175000017500000000702512502221015015737 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlaqr1_(integer* n, doublecomplex* h, integer* ldh, doublecomplex* s1, doublecomplex* s2, doublecomplex* v);


static VALUE
rblapack_zlaqr1(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_h;
  doublecomplex *h; 
  VALUE rblapack_s1;
  doublecomplex s1; 
  VALUE rblapack_s2;
  doublecomplex s2; 
  VALUE rblapack_v;
  doublecomplex *v; 

  integer ldh;
  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  v = NumRu::Lapack.zlaqr1( h, s1, s2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAQR1( N, H, LDH, S1, S2, V )\n\n*       Given a 2-by-2 or 3-by-3 matrix H, ZLAQR1 sets v to a\n*       scalar multiple of the first column of the product\n*\n*       (*)  K = (H - s1*I)*(H - s2*I)\n*\n*       scaling to avoid overflows and most underflows.\n*\n*       This is useful for starting double implicit shift bulges\n*       in the QR algorithm.\n*\n*\n\n*       N      (input) integer\n*              Order of the matrix H. N must be either 2 or 3.\n*\n*       H      (input) COMPLEX*16 array of dimension (LDH,N)\n*              The 2-by-2 or 3-by-3 matrix H in (*).\n*\n*       LDH    (input) integer\n*              The leading dimension of H as declared in\n*              the calling procedure.  LDH.GE.N\n*\n*       S1     (input) COMPLEX*16\n*       S2     S1 and S2 are the shifts defining K in (*) above.\n*\n*       V      (output) COMPLEX*16 array of dimension N\n*              A scalar multiple of the first column of the\n*              matrix K in (*).\n*\n\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  v = NumRu::Lapack.zlaqr1( h, s1, s2, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_h = argv[0];
  rblapack_s1 = argv[1];
  rblapack_s2 = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (1th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (1th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_DCOMPLEX)
    rblapack_h = na_change_type(rblapack_h, NA_DCOMPLEX);
  h = NA_PTR_TYPE(rblapack_h, doublecomplex*);
  s2.r = NUM2DBL(rb_funcall(rblapack_s2, rb_intern("real"), 0));
  s2.i = NUM2DBL(rb_funcall(rblapack_s2, rb_intern("imag"), 0));
  s1.r = NUM2DBL(rb_funcall(rblapack_s1, rb_intern("real"), 0));
  s1.i = NUM2DBL(rb_funcall(rblapack_s1, rb_intern("imag"), 0));
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_v = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  v = NA_PTR_TYPE(rblapack_v, doublecomplex*);

  zlaqr1_(&n, h, &ldh, &s1, &s2, v);

  return rblapack_v;
}

void
init_lapack_zlaqr1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlaqr1", rblapack_zlaqr1, -1);
}
ruby-lapack-1.7.2/ext/dlangb.c0000644000175000017500000001050612502221012015747 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal dlangb_(char* norm, integer* n, integer* kl, integer* ku, doublereal* ab, integer* ldab, doublereal* work);


static VALUE
rblapack_dlangb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack___out__;
  doublereal __out__; 
  doublereal *work;

  integer ldab;
  integer n;
  integer lwork;

  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  __out__ = NumRu::Lapack.dlangb( norm, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION DLANGB( NORM, N, KL, KU, AB, LDAB, WORK )\n\n*  Purpose\n*  =======\n*\n*  DLANGB  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the element of  largest absolute value  of an\n*  n by n band matrix  A,  with kl sub-diagonals and ku super-diagonals.\n*\n*  Description\n*  ===========\n*\n*  DLANGB returns the value\n*\n*     DLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in DLANGB as described\n*          above.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, DLANGB is\n*          set to zero.\n*\n*  KL      (input) INTEGER\n*          The number of sub-diagonals of the matrix A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of super-diagonals of the matrix A.  KU >= 0.\n*\n*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)\n*          The band matrix A, stored in rows 1 to KL+KU+1.  The j-th\n*          column of A is stored in the j-th column of the array AB as\n*          follows:\n*          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n*          referenced.\n*\n\n* =====================================================================\n*\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.dlangb( norm, kl, ku, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_norm = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  ku = NUM2INT(rblapack_ku);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  lwork = lsame_(&norm,"I") ? n : 0;
  work = ALLOC_N(doublereal, (MAX(1,lwork)));

  __out__ = dlangb_(&norm, &n, &kl, &ku, ab, &ldab, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_dlangb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlangb", rblapack_dlangb, -1);
}
ruby-lapack-1.7.2/ext/cgeev.c0000644000175000017500000001640112502221024015614 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgeev_(char* jobvl, char* jobvr, integer* n, complex* a, integer* lda, complex* w, complex* vl, integer* ldvl, complex* vr, integer* ldvr, complex* work, integer* lwork, real* rwork, integer* info);


static VALUE
rblapack_cgeev(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvl;
  char jobvl; 
  VALUE rblapack_jobvr;
  char jobvr; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_w;
  complex *w; 
  VALUE rblapack_vl;
  complex *vl; 
  VALUE rblapack_vr;
  complex *vr; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  real *rwork;

  integer lda;
  integer n;
  integer ldvl;
  integer ldvr;

  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  w, vl, vr, work, info, a = NumRu::Lapack.cgeev( jobvl, jobvr, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGEEV computes for an N-by-N complex nonsymmetric matrix A, the\n*  eigenvalues and, optionally, the left and/or right eigenvectors.\n*\n*  The right eigenvector v(j) of A satisfies\n*                   A * v(j) = lambda(j) * v(j)\n*  where lambda(j) is its eigenvalue.\n*  The left eigenvector u(j) of A satisfies\n*                u(j)**H * A = lambda(j) * u(j)**H\n*  where u(j)**H denotes the conjugate transpose of u(j).\n*\n*  The computed eigenvectors are normalized to have Euclidean norm\n*  equal to 1 and largest component real.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVL   (input) CHARACTER*1\n*          = 'N': left eigenvectors of A are not computed;\n*          = 'V': left eigenvectors of are computed.\n*\n*  JOBVR   (input) CHARACTER*1\n*          = 'N': right eigenvectors of A are not computed;\n*          = 'V': right eigenvectors of A are computed.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the N-by-N matrix A.\n*          On exit, A has been overwritten.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  W       (output) COMPLEX array, dimension (N)\n*          W contains the computed eigenvalues.\n*\n*  VL      (output) COMPLEX array, dimension (LDVL,N)\n*          If JOBVL = 'V', the left eigenvectors u(j) are stored one\n*          after another in the columns of VL, in the same order\n*          as their eigenvalues.\n*          If JOBVL = 'N', VL is not referenced.\n*          u(j) = VL(:,j), the j-th column of VL.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the array VL.  LDVL >= 1; if\n*          JOBVL = 'V', LDVL >= N.\n*\n*  VR      (output) COMPLEX array, dimension (LDVR,N)\n*          If JOBVR = 'V', the right eigenvectors v(j) are stored one\n*          after another in the columns of VR, in the same order\n*          as their eigenvalues.\n*          If JOBVR = 'N', VR is not referenced.\n*          v(j) = VR(:,j), the j-th column of VR.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the array VR.  LDVR >= 1; if\n*          JOBVR = 'V', LDVR >= N.\n*\n*  WORK    (workspace/output) COMPLEX 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,2*N).\n*          For good performance, LWORK must generally be larger.\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*  RWORK   (workspace) REAL array, dimension (2*N)\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 QR algorithm failed to compute all the\n*                eigenvalues, and no eigenvectors have been computed;\n*                elements and i+1:N of W contain eigenvalues which have\n*                converged.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, vl, vr, work, info, a = NumRu::Lapack.cgeev( jobvl, jobvr, a, [: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_jobvl = argv[0];
  rblapack_jobvr = argv[1];
  rblapack_a = 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;
  }

  jobvl = StringValueCStr(rblapack_jobvl)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  ldvl = lsame_(&jobvl,"V") ? n : 1;
  jobvr = StringValueCStr(rblapack_jobvr)[0];
  ldvr = lsame_(&jobvr,"V") ? n : 1;
  if (rblapack_lwork == Qnil)
    lwork = 2*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = n;
    rblapack_vl = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  vl = NA_PTR_TYPE(rblapack_vl, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = n;
    rblapack_vr = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  vr = NA_PTR_TYPE(rblapack_vr, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  rwork = ALLOC_N(real, (2*n));

  cgeev_(&jobvl, &jobvr, &n, a, &lda, w, vl, &ldvl, vr, &ldvr, work, &lwork, rwork, &info);

  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_w, rblapack_vl, rblapack_vr, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_cgeev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgeev", rblapack_cgeev, -1);
}
ruby-lapack-1.7.2/ext/clahqr.c0000644000175000017500000002131112502221022015767 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clahqr_(logical* wantt, logical* wantz, integer* n, integer* ilo, integer* ihi, complex* h, integer* ldh, complex* w, integer* iloz, integer* ihiz, complex* z, integer* ldz, integer* info);


static VALUE
rblapack_clahqr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantt;
  logical wantt; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_h;
  complex *h; 
  VALUE rblapack_iloz;
  integer iloz; 
  VALUE rblapack_ihiz;
  integer ihiz; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_ldz;
  integer ldz; 
  VALUE rblapack_w;
  complex *w; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_h_out__;
  complex *h_out__;
  VALUE rblapack_z_out__;
  complex *z_out__;

  integer ldh;
  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  w, info, h, z = NumRu::Lapack.clahqr( wantt, wantz, ilo, ihi, h, iloz, ihiz, z, ldz, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, IHIZ, Z, LDZ, INFO )\n\n*     Purpose\n*     =======\n*\n*     CLAHQR is an auxiliary routine called by CHSEQR to update the\n*     eigenvalues and Schur decomposition already computed by CHSEQR, by\n*     dealing with the Hessenberg submatrix in rows and columns ILO to\n*     IHI.\n*\n\n*     Arguments\n*     =========\n*\n*     WANTT   (input) LOGICAL\n*          = .TRUE. : the full Schur form T is required;\n*          = .FALSE.: only eigenvalues are required.\n*\n*     WANTZ   (input) LOGICAL\n*          = .TRUE. : the matrix of Schur vectors Z is required;\n*          = .FALSE.: Schur vectors are not required.\n*\n*     N       (input) INTEGER\n*          The order of the matrix H.  N >= 0.\n*\n*     ILO     (input) INTEGER\n*     IHI     (input) INTEGER\n*          It is assumed that H is already upper triangular in rows and\n*          columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1).\n*          CLAHQR works primarily with the Hessenberg submatrix in rows\n*          and columns ILO to IHI, but applies transformations to all of\n*          H if WANTT is .TRUE..\n*          1 <= ILO <= max(1,IHI); IHI <= N.\n*\n*     H       (input/output) COMPLEX array, dimension (LDH,N)\n*          On entry, the upper Hessenberg matrix H.\n*          On exit, if INFO is zero and if WANTT is .TRUE., then H\n*          is upper triangular in rows and columns ILO:IHI.  If INFO\n*          is zero and if WANTT is .FALSE., then the contents of H\n*          are unspecified on exit.  The output state of H in case\n*          INF is positive is below under the description of INFO.\n*\n*     LDH     (input) INTEGER\n*          The leading dimension of the array H. LDH >= max(1,N).\n*\n*     W       (output) COMPLEX array, dimension (N)\n*          The computed eigenvalues ILO to IHI are stored in the\n*          corresponding elements of W. If WANTT is .TRUE., the\n*          eigenvalues are stored in the same order as on the diagonal\n*          of the Schur form returned in H, with W(i) = H(i,i).\n*\n*     ILOZ    (input) INTEGER\n*     IHIZ    (input) INTEGER\n*          Specify the rows of Z to which transformations must be\n*          applied if WANTZ is .TRUE..\n*          1 <= ILOZ <= ILO; IHI <= IHIZ <= N.\n*\n*     Z       (input/output) COMPLEX array, dimension (LDZ,N)\n*          If WANTZ is .TRUE., on entry Z must contain the current\n*          matrix Z of transformations accumulated by CHSEQR, and on\n*          exit Z has been updated; transformations are applied only to\n*          the submatrix Z(ILOZ:IHIZ,ILO:IHI).\n*          If WANTZ is .FALSE., Z is not referenced.\n*\n*     LDZ     (input) INTEGER\n*          The leading dimension of the array Z. LDZ >= max(1,N).\n*\n*     INFO    (output) INTEGER\n*           =   0: successful exit\n*          .GT. 0: if INFO = i, CLAHQR failed to compute all the\n*                  eigenvalues ILO to IHI in a total of 30 iterations\n*                  per eigenvalue; elements i+1:ihi of W contain\n*                  those eigenvalues which have been successfully\n*                  computed.\n*\n*                  If INFO .GT. 0 and WANTT is .FALSE., then on exit,\n*                  the remaining unconverged eigenvalues are the\n*                  eigenvalues of the upper Hessenberg matrix\n*                  rows and columns ILO thorugh INFO of the final,\n*                  output value of H.\n*\n*                  If INFO .GT. 0 and WANTT is .TRUE., then on exit\n*          (*)       (initial value of H)*U  = U*(final value of H)\n*                  where U is an orthognal matrix.    The final\n*                  value of H is upper Hessenberg and triangular in\n*                  rows and columns INFO+1 through IHI.\n*\n*                  If INFO .GT. 0 and WANTZ is .TRUE., then on exit\n*                      (final value of Z)  = (initial value of Z)*U\n*                  where U is the orthogonal matrix in (*)\n*                  (regardless of the value of WANTT.)\n*\n\n*     Further Details\n*     ===============\n*\n*     02-96 Based on modifications by\n*     David Day, Sandia National Laboratory, USA\n*\n*     12-04 Further modifications by\n*     Ralph Byers, University of Kansas, USA\n*     This is a modified version of CLAHQR from LAPACK version 3.0.\n*     It is (1) more robust against overflow and underflow and\n*     (2) adopts the more conservative Ahues & Tisseur stopping\n*     criterion (LAWN 122, 1997).\n*\n*     =========================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, info, h, z = NumRu::Lapack.clahqr( wantt, wantz, ilo, ihi, h, iloz, ihiz, z, ldz, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_wantt = argv[0];
  rblapack_wantz = argv[1];
  rblapack_ilo = argv[2];
  rblapack_ihi = argv[3];
  rblapack_h = argv[4];
  rblapack_iloz = argv[5];
  rblapack_ihiz = argv[6];
  rblapack_z = argv[7];
  rblapack_ldz = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  wantt = (rblapack_wantt == Qtrue);
  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (5th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (5th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_SCOMPLEX)
    rblapack_h = na_change_type(rblapack_h, NA_SCOMPLEX);
  h = NA_PTR_TYPE(rblapack_h, complex*);
  ihiz = NUM2INT(rblapack_ihiz);
  ldz = NUM2INT(rblapack_ldz);
  wantz = (rblapack_wantz == Qtrue);
  iloz = NUM2INT(rblapack_iloz);
  ihi = NUM2INT(rblapack_ihi);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (8th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_z) != (wantz ? ldz : 0))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantz ? ldz : 0);
  if (NA_SHAPE1(rblapack_z) != (wantz ? n : 0))
    rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantz ? n : 0);
  if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, complex*);
  MEMCPY(h_out__, h, complex, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = wantz ? ldz : 0;
    shape[1] = wantz ? n : 0;
    rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
  MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  clahqr_(&wantt, &wantz, &n, &ilo, &ihi, h, &ldh, w, &iloz, &ihiz, z, &ldz, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_w, rblapack_info, rblapack_h, rblapack_z);
}

void
init_lapack_clahqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clahqr", rblapack_clahqr, -1);
}
ruby-lapack-1.7.2/ext/cgbsvx.c0000644000175000017500000005242312502221025016024 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgbsvx_(char* fact, char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, complex* ab, integer* ldab, complex* afb, integer* ldafb, integer* ipiv, char* equed, real* r, real* c, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* ferr, real* berr, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cgbsvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_afb;
  complex *afb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_r;
  real *r; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_rwork;
  real *rwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  complex *ab_out__;
  VALUE rblapack_afb_out__;
  complex *afb_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  VALUE rblapack_r_out__;
  real *r_out__;
  VALUE rblapack_c_out__;
  real *c_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;
  complex *work;

  integer ldab;
  integer n;
  integer ldb;
  integer nrhs;
  integer ldafb;
  integer ldx;

  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  x, rcond, ferr, berr, rwork, info, ab, afb, ipiv, equed, r, c, b = NumRu::Lapack.cgbsvx( fact, trans, kl, ku, ab, b, [:afb => afb, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGBSVX uses the LU factorization to compute the solution to a complex\n*  system of linear equations A * X = B, A**T * X = B, or A**H * X = B,\n*  where A is a band matrix of order N with KL subdiagonals and KU\n*  superdiagonals, and X and B are N-by-NRHS matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed by this subroutine:\n*\n*  1. If FACT = 'E', real scaling factors are computed to equilibrate\n*     the system:\n*        TRANS = 'N':  diag(R)*A*diag(C)     *inv(diag(C))*X = diag(R)*B\n*        TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n*        TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n*     or diag(C)*B (if TRANS = 'T' or 'C').\n*\n*  2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n*     matrix A (after equilibration if FACT = 'E') as\n*        A = L * U,\n*     where L is a product of permutation and unit lower triangular\n*     matrices with KL subdiagonals, and U is upper triangular with\n*     KL+KU superdiagonals.\n*\n*  3. If some U(i,i)=0, so that U is exactly singular, then the routine\n*     returns with INFO = i. Otherwise, the factored form of A is used\n*     to estimate the condition number of the matrix A.  If the\n*     reciprocal of the condition number is less than machine precision,\n*     INFO = N+1 is returned as a warning, but the routine still goes on\n*     to solve for X and compute error bounds as described below.\n*\n*  4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  5. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n*  6. If equilibration was used, the matrix X is premultiplied by\n*     diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n*     that it solves the original system before equilibration.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of the matrix A is\n*          supplied on entry, and if not, whether the matrix A should be\n*          equilibrated before it is factored.\n*          = 'F':  On entry, AFB and IPIV contain the factored form of\n*                  A.  If EQUED is not 'N', the matrix A has been\n*                  equilibrated with scaling factors given by R and C.\n*                  AB, AFB, and IPIV are not modified.\n*          = 'N':  The matrix A will be copied to AFB and factored.\n*          = 'E':  The matrix A will be equilibrated if necessary, then\n*                  copied to AFB and factored.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations.\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose)\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AB      (input/output) COMPLEX array, dimension (LDAB,N)\n*          On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n*          The j-th column of A is stored in the j-th column of the\n*          array AB as follows:\n*          AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n*          If FACT = 'F' and EQUED is not 'N', then A must have been\n*          equilibrated by the scaling factors in R and/or C.  AB is not\n*          modified if FACT = 'F' or 'N', or if FACT = 'E' and\n*          EQUED = 'N' on exit.\n*\n*          On exit, if EQUED .ne. 'N', A is scaled as follows:\n*          EQUED = 'R':  A := diag(R) * A\n*          EQUED = 'C':  A := A * diag(C)\n*          EQUED = 'B':  A := diag(R) * A * diag(C).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*  AFB     (input or output) COMPLEX array, dimension (LDAFB,N)\n*          If FACT = 'F', then AFB is an input argument and on entry\n*          contains details of the LU factorization of the band matrix\n*          A, as computed by CGBTRF.  U is stored as an upper triangular\n*          band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n*          and the multipliers used during the factorization are stored\n*          in rows KL+KU+2 to 2*KL+KU+1.  If EQUED .ne. 'N', then AFB is\n*          the factored form of the equilibrated matrix A.\n*\n*          If FACT = 'N', then AFB is an output argument and on exit\n*          returns details of the LU factorization of A.\n*\n*          If FACT = 'E', then AFB is an output argument and on exit\n*          returns details of the LU factorization of the equilibrated\n*          matrix A (see the description of AB for the form of the\n*          equilibrated matrix).\n*\n*  LDAFB   (input) INTEGER\n*          The leading dimension of the array AFB.  LDAFB >= 2*KL+KU+1.\n*\n*  IPIV    (input or output) INTEGER array, dimension (N)\n*          If FACT = 'F', then IPIV is an input argument and on entry\n*          contains the pivot indices from the factorization A = L*U\n*          as computed by CGBTRF; row i of the matrix was interchanged\n*          with row IPIV(i).\n*\n*          If FACT = 'N', then IPIV is an output argument and on exit\n*          contains the pivot indices from the factorization A = L*U\n*          of the original matrix A.\n*\n*          If FACT = 'E', then IPIV is an output argument and on exit\n*          contains the pivot indices from the factorization A = L*U\n*          of the equilibrated matrix A.\n*\n*  EQUED   (input or output) CHARACTER*1\n*          Specifies the form of equilibration that was done.\n*          = 'N':  No equilibration (always true if FACT = 'N').\n*          = 'R':  Row equilibration, i.e., A has been premultiplied by\n*                  diag(R).\n*          = 'C':  Column equilibration, i.e., A has been postmultiplied\n*                  by diag(C).\n*          = 'B':  Both row and column equilibration, i.e., A has been\n*                  replaced by diag(R) * A * diag(C).\n*          EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*          output argument.\n*\n*  R       (input or output) REAL array, dimension (N)\n*          The row scale factors for A.  If EQUED = 'R' or 'B', A is\n*          multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n*          is not accessed.  R is an input argument if FACT = 'F';\n*          otherwise, R is an output argument.  If FACT = 'F' and\n*          EQUED = 'R' or 'B', each element of R must be positive.\n*\n*  C       (input or output) REAL array, dimension (N)\n*          The column scale factors for A.  If EQUED = 'C' or 'B', A is\n*          multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n*          is not accessed.  C is an input argument if FACT = 'F';\n*          otherwise, C is an output argument.  If FACT = 'F' and\n*          EQUED = 'C' or 'B', each element of C must be positive.\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit,\n*          if EQUED = 'N', B is not modified;\n*          if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n*          diag(R)*B;\n*          if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n*          overwritten by diag(C)*B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) COMPLEX array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n*          to the original system of equations.  Note that A and B are\n*          modified on exit if EQUED .ne. 'N', and the solution to the\n*          equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n*          EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n*          and EQUED = 'R' or 'B'.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) REAL\n*          The estimate of the reciprocal condition number of the matrix\n*          A after equilibration (if done).  If RCOND is less than the\n*          machine precision (in particular, if RCOND = 0), the matrix\n*          is singular to working precision.  This condition is\n*          indicated by a return code of INFO > 0.\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace/output) REAL array, dimension (N)\n*          On exit, RWORK(1) contains the reciprocal pivot growth\n*          factor norm(A)/norm(U). The \"max absolute element\" norm is\n*          used. If RWORK(1) is much less than 1, then the stability\n*          of the LU factorization of the (equilibrated) matrix A\n*          could be poor. This also means that the solution X, condition\n*          estimator RCOND, and forward error bound FERR could be\n*          unreliable. If factorization fails with 0 0:  if INFO = i, and i is\n*                <= N:  U(i,i) is exactly zero.  The factorization\n*                       has been completed, but the factor U is exactly\n*                       singular, so the solution and error bounds\n*                       could not be computed. RCOND = 0 is returned.\n*                = N+1: U is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  =====================================================================\n*  Moved setting of INFO = N+1 so INFO does not subsequently get\n*  overwritten.  Sven, 17 Mar 05. \n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, rwork, info, ab, afb, ipiv, equed, r, c, b = NumRu::Lapack.cgbsvx( fact, trans, kl, ku, ab, b, [:afb => afb, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 11)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_fact = argv[0];
  rblapack_trans = argv[1];
  rblapack_kl = argv[2];
  rblapack_ku = argv[3];
  rblapack_ab = argv[4];
  rblapack_b = argv[5];
  if (argc == 11) {
    rblapack_afb = argv[6];
    rblapack_ipiv = argv[7];
    rblapack_equed = argv[8];
    rblapack_r = argv[9];
    rblapack_c = argv[10];
  } else if (rblapack_options != Qnil) {
    rblapack_afb = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("afb")));
    rblapack_ipiv = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("ipiv")));
    rblapack_equed = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("equed")));
    rblapack_r = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("r")));
    rblapack_c = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("c")));
  } else {
    rblapack_afb = Qnil;
    rblapack_ipiv = Qnil;
    rblapack_equed = Qnil;
    rblapack_r = Qnil;
    rblapack_c = Qnil;
  }

  fact = StringValueCStr(rblapack_fact)[0];
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  if (rblapack_ipiv != Qnil) {
    if (!NA_IsNArray(rblapack_ipiv))
      rb_raise(rb_eArgError, "ipiv (option) must be NArray");
    if (NA_RANK(rblapack_ipiv) != 1)
      rb_raise(rb_eArgError, "rank of ipiv (option) must be %d", 1);
    if (NA_SHAPE0(rblapack_ipiv) != n)
      rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of ab");
    if (NA_TYPE(rblapack_ipiv) != NA_LINT)
      rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
    ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  }
  if (rblapack_r != Qnil) {
    if (!NA_IsNArray(rblapack_r))
      rb_raise(rb_eArgError, "r (option) must be NArray");
    if (NA_RANK(rblapack_r) != 1)
      rb_raise(rb_eArgError, "rank of r (option) must be %d", 1);
    if (NA_SHAPE0(rblapack_r) != n)
      rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of ab");
    if (NA_TYPE(rblapack_r) != NA_SFLOAT)
      rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
    r = NA_PTR_TYPE(rblapack_r, real*);
  }
  ldx = n;
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (rblapack_equed != Qnil) {
  equed = StringValueCStr(rblapack_equed)[0];
  }
  ku = NUM2INT(rblapack_ku);
  if (rblapack_c != Qnil) {
    if (!NA_IsNArray(rblapack_c))
      rb_raise(rb_eArgError, "c (option) must be NArray");
    if (NA_RANK(rblapack_c) != 1)
      rb_raise(rb_eArgError, "rank of c (option) must be %d", 1);
    if (NA_SHAPE0(rblapack_c) != n)
      rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
    if (NA_TYPE(rblapack_c) != NA_SFLOAT)
      rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
    c = NA_PTR_TYPE(rblapack_c, real*);
  }
  ldafb = 2*kl+ku+1;
  if (rblapack_afb != Qnil) {
    if (!NA_IsNArray(rblapack_afb))
      rb_raise(rb_eArgError, "afb (option) must be NArray");
    if (NA_RANK(rblapack_afb) != 2)
      rb_raise(rb_eArgError, "rank of afb (option) must be %d", 2);
    if (NA_SHAPE0(rblapack_afb) != ldafb)
      rb_raise(rb_eRuntimeError, "shape 0 of afb must be 2*kl+ku+1");
    if (NA_SHAPE1(rblapack_afb) != n)
      rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
    if (NA_TYPE(rblapack_afb) != NA_SCOMPLEX)
      rblapack_afb = na_change_type(rblapack_afb, NA_SCOMPLEX);
    afb = NA_PTR_TYPE(rblapack_afb, complex*);
  }
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  rwork = NA_PTR_TYPE(rblapack_rwork, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
  MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldafb;
    shape[1] = n;
    rblapack_afb_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  afb_out__ = NA_PTR_TYPE(rblapack_afb_out__, complex*);
  if (rblapack_afb != Qnil) {
    MEMCPY(afb_out__, afb, complex, NA_TOTAL(rblapack_afb));
  }
  rblapack_afb = rblapack_afb_out__;
  afb = afb_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  if (rblapack_ipiv != Qnil) {
    MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  }
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_r_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  r_out__ = NA_PTR_TYPE(rblapack_r_out__, real*);
  if (rblapack_r != Qnil) {
    MEMCPY(r_out__, r, real, NA_TOTAL(rblapack_r));
  }
  rblapack_r = rblapack_r_out__;
  r = r_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  if (rblapack_c != Qnil) {
    MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  }
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(complex, (2*n));

  cgbsvx_(&fact, &trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);

  free(work);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(13, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_rwork, rblapack_info, rblapack_ab, rblapack_afb, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b);
}

void
init_lapack_cgbsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgbsvx", rblapack_cgbsvx, -1);
}
ruby-lapack-1.7.2/ext/dstedc.c0000644000175000017500000002462412502221024015777 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dstedc_(char* compz, integer* n, doublereal* d, doublereal* e, doublereal* z, integer* ldz, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_dstedc(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_compz;
  char compz; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_e_out__;
  doublereal *e_out__;
  VALUE rblapack_z_out__;
  doublereal *z_out__;

  integer n;
  integer ldz;

  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, iwork, info, d, e, z = NumRu::Lapack.dstedc( compz, d, e, z, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSTEDC computes all eigenvalues and, optionally, eigenvectors of a\n*  symmetric tridiagonal matrix using the divide and conquer method.\n*  The eigenvectors of a full or band real symmetric matrix can also be\n*  found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this\n*  matrix to tridiagonal form.\n*\n*  This code makes very mild assumptions about floating point\n*  arithmetic. It will work on machines with a guard digit in\n*  add/subtract, or on those binary machines without guard digits\n*  which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n*  It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.  See DLAED3 for details.\n*\n\n*  Arguments\n*  =========\n*\n*  COMPZ   (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only.\n*          = 'I':  Compute eigenvectors of tridiagonal matrix also.\n*          = 'V':  Compute eigenvectors of original dense symmetric\n*                  matrix also.  On entry, Z contains the orthogonal\n*                  matrix used to reduce the original matrix to\n*                  tridiagonal form.\n*\n*  N       (input) INTEGER\n*          The dimension of the symmetric tridiagonal matrix.  N >= 0.\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the diagonal elements of the tridiagonal matrix.\n*          On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n*  E       (input/output) DOUBLE PRECISION array, dimension (N-1)\n*          On entry, the subdiagonal elements of the tridiagonal matrix.\n*          On exit, E has been destroyed.\n*\n*  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)\n*          On entry, if COMPZ = 'V', then Z contains the orthogonal\n*          matrix used in the reduction to tridiagonal form.\n*          On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n*          orthonormal eigenvectors of the original symmetric matrix,\n*          and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n*          of the symmetric tridiagonal matrix.\n*          If  COMPZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1.\n*          If eigenvectors are desired, then LDZ >= max(1,N).\n*\n*  WORK    (workspace/output) DOUBLE PRECISION array,\n*                                         dimension (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*          If COMPZ = 'N' or N <= 1 then LWORK must be at least 1.\n*          If COMPZ = 'V' and N > 1 then LWORK must be at least\n*                         ( 1 + 3*N + 2*N*lg N + 3*N**2 ),\n*                         where lg( N ) = smallest integer k such\n*                         that 2**k >= N.\n*          If COMPZ = 'I' and N > 1 then LWORK must be at least\n*                         ( 1 + 4*N + N**2 ).\n*          Note that for COMPZ = 'I' or 'V', then if N is less than or\n*          equal to the minimum divide size, usually 25, then LWORK need\n*          only be max(1,2*(N-1)).\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*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.\n*          If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1.\n*          If COMPZ = 'V' and N > 1 then LIWORK must be at least\n*                         ( 6 + 6*N + 5*N*lg N ).\n*          If COMPZ = 'I' and N > 1 then LIWORK must be at least\n*                         ( 3 + 5*N ).\n*          Note that for COMPZ = 'I' or 'V', then if N is less than or\n*          equal to the minimum divide size, usually 25, then LIWORK\n*          need only be 1.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal size of the IWORK array,\n*          returns this value as the first entry of the IWORK array, and\n*          no error message related to LIWORK 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:  The algorithm failed to compute an eigenvalue while\n*                working on the submatrix lying in rows and columns\n*                INFO/(N+1) through mod(INFO,N+1).\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Jeff Rutter, Computer Science Division, University of California\n*     at Berkeley, USA\n*  Modified by Francoise Tisseur, University of Tennessee.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, iwork, info, d, e, z = NumRu::Lapack.dstedc( compz, d, e, z, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_compz = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  rblapack_z = argv[3];
  if (argc == 6) {
    rblapack_lwork = argv[4];
    rblapack_liwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  compz = StringValueCStr(rblapack_compz)[0];
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (4th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  n = NA_SHAPE1(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of z");
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (rblapack_lwork == Qnil)
    lwork = (lsame_(&compz,"N")||n<=1) ? 1 : lsame_(&compz,"V") ? 1+3*n+2*n*LG(n)+3*n*n : lsame_(&compz,"I") ? 1+4*n+2*n*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  if (rblapack_liwork == Qnil)
    liwork = (lsame_(&compz,"N")||n<=1) ? 1 : lsame_(&compz,"V") ? 6+6*n+5*n*LG(n) : lsame_(&compz,"I") ? 3+5*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
  MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
  MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  dstedc_(&compz, &n, d, e, z, &ldz, work, &lwork, iwork, &liwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_work, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e, rblapack_z);
}

void
init_lapack_dstedc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dstedc", rblapack_dstedc, -1);
}
ruby-lapack-1.7.2/ext/sla_porcond.c0000644000175000017500000001552712502221016017037 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real sla_porcond_(char* uplo, integer* n, real* a, integer* lda, real* af, integer* ldaf, integer* cmode, real* c, integer* info, real* work, integer* iwork);


static VALUE
rblapack_sla_porcond(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_af;
  real *af; 
  VALUE rblapack_cmode;
  integer cmode; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack___out__;
  real __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  info, __out__ = NumRu::Lapack.sla_porcond( uplo, a, af, cmode, c, work, iwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL FUNCTION SLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, CMODE, C, INFO, WORK, IWORK )\n\n*  Purpose\n*  =======\n*\n*     SLA_PORCOND Estimates the Skeel condition number of  op(A) * op2(C)\n*     where op2 is determined by CMODE as follows\n*     CMODE =  1    op2(C) = C\n*     CMODE =  0    op2(C) = I\n*     CMODE = -1    op2(C) = inv(C)\n*     The Skeel condition number  cond(A) = norminf( |inv(A)||A| )\n*     is computed by computing scaling factors R such that\n*     diag(R)*A*op2(C) is row equilibrated and computing the standard\n*     infinity-norm condition number.\n*\n\n*  Arguments\n*  ==========\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     A       (input) REAL array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) REAL array, dimension (LDAF,N)\n*     The triangular factor U or L from the Cholesky factorization\n*     A = U**T*U or A = L*L**T, as computed by SPOTRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     CMODE   (input) INTEGER\n*     Determines op2(C) in the formula op(A) * op2(C) as follows:\n*     CMODE =  1    op2(C) = C\n*     CMODE =  0    op2(C) = I\n*     CMODE = -1    op2(C) = inv(C)\n*\n*     C       (input) REAL array, dimension (N)\n*     The vector C in the formula op(A) * op2(C).\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit.\n*     i > 0:  The ith argument is invalid.\n*\n*     WORK    (input) REAL array, dimension (3*N).\n*     Workspace.\n*\n*     IWORK   (input) INTEGER array, dimension (N).\n*     Workspace.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            KASE, I, J\n      REAL               AINVNM, TMP\n      LOGICAL            UP\n*     ..\n*     .. Array Arguments ..\n      INTEGER            ISAVE( 3 )\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            ISAMAX\n      EXTERNAL           LSAME, ISAMAX\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SLACN2, SPOTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, __out__ = NumRu::Lapack.sla_porcond( uplo, a, af, cmode, c, work, iwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_cmode = argv[3];
  rblapack_c = argv[4];
  rblapack_work = argv[5];
  rblapack_iwork = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_SFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
  af = NA_PTR_TYPE(rblapack_af, real*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_iwork))
    rb_raise(rb_eArgError, "iwork (7th argument) must be NArray");
  if (NA_RANK(rblapack_iwork) != 1)
    rb_raise(rb_eArgError, "rank of iwork (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_iwork) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of iwork must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_iwork) != NA_LINT)
    rblapack_iwork = na_change_type(rblapack_iwork, NA_LINT);
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (6th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (3*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 3*n);
  if (NA_TYPE(rblapack_work) != NA_SFLOAT)
    rblapack_work = na_change_type(rblapack_work, NA_SFLOAT);
  work = NA_PTR_TYPE(rblapack_work, real*);
  cmode = NUM2INT(rblapack_cmode);

  __out__ = sla_porcond_(&uplo, &n, a, &lda, af, &ldaf, &cmode, c, &info, work, iwork);

  rblapack_info = INT2NUM(info);
  rblapack___out__ = rb_float_new((double)__out__);
  return rb_ary_new3(2, rblapack_info, rblapack___out__);
}

void
init_lapack_sla_porcond(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sla_porcond", rblapack_sla_porcond, -1);
}
ruby-lapack-1.7.2/ext/sormtr.c0000644000175000017500000001734712502221017016065 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sormtr_(char* side, char* uplo, char* trans, integer* m, integer* n, real* a, integer* lda, real* tau, real* c, integer* ldc, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sormtr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  real *c_out__;

  integer lda;
  integer m;
  integer ldc;
  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  work, info, c = NumRu::Lapack.sormtr( side, uplo, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SORMTR overwrites the general real M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'T':      Q**T * C       C * Q**T\n*\n*  where Q is a real orthogonal matrix of order nq, with nq = m if\n*  SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of\n*  nq-1 elementary reflectors, as returned by SSYTRD:\n*\n*  if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);\n*\n*  if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**T from the Left;\n*          = 'R': apply Q or Q**T from the Right.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U': Upper triangle of A contains elementary reflectors\n*                 from SSYTRD;\n*          = 'L': Lower triangle of A contains elementary reflectors\n*                 from SSYTRD.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'T':  Transpose, apply Q**T.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  A       (input) REAL array, dimension\n*                               (LDA,M) if SIDE = 'L'\n*                               (LDA,N) if SIDE = 'R'\n*          The vectors which define the elementary reflectors, as\n*          returned by SSYTRD.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*          LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.\n*\n*  TAU     (input) REAL array, dimension\n*                               (M-1) if SIDE = 'L'\n*                               (N-1) if SIDE = 'R'\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by SSYTRD.\n*\n*  C       (input/output) REAL array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace/output) REAL 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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M).\n*          For optimum performance LWORK >= N*NB if SIDE = 'L', and\n*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n*          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*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LEFT, LQUERY, UPPER\n      INTEGER            I1, I2, IINFO, LWKOPT, MI, NI, NB, NQ, NW\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            ILAENV\n      EXTERNAL           ILAENV, LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SORMQL, SORMQR, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.sormtr( side, uplo, trans, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_uplo = argv[1];
  rblapack_trans = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 7) {
    rblapack_lwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  side = StringValueCStr(rblapack_side)[0];
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_tau) != (m-1))
    rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", m-1);
  if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  sormtr_(&side, &uplo, &trans, &m, &n, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_sormtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sormtr", rblapack_sormtr, -1);
}
ruby-lapack-1.7.2/ext/clatdf.c0000644000175000017500000002006512502221021015756 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clatdf_(integer* ijob, integer* n, complex* z, integer* ldz, complex* rhs, real* rdsum, real* rdscal, integer* ipiv, integer* jpiv);


static VALUE
rblapack_clatdf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ijob;
  integer ijob; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_rhs;
  complex *rhs; 
  VALUE rblapack_rdsum;
  real rdsum; 
  VALUE rblapack_rdscal;
  real rdscal; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_jpiv;
  integer *jpiv; 
  VALUE rblapack_rhs_out__;
  complex *rhs_out__;

  integer ldz;
  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  rhs, rdsum, rdscal = NumRu::Lapack.clatdf( ijob, z, rhs, rdsum, rdscal, ipiv, jpiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, JPIV )\n\n*  Purpose\n*  =======\n*\n*  CLATDF computes the contribution to the reciprocal Dif-estimate\n*  by solving for x in Z * x = b, where b is chosen such that the norm\n*  of x is as large as possible. It is assumed that LU decomposition\n*  of Z has been computed by CGETC2. On entry RHS = f holds the\n*  contribution from earlier solved sub-systems, and on return RHS = x.\n*\n*  The factorization of Z returned by CGETC2 has the form\n*  Z = P * L * U * Q, where P and Q are permutation matrices. L is lower\n*  triangular with unit diagonal elements and U is upper triangular.\n*\n\n*  Arguments\n*  =========\n*\n*  IJOB    (input) INTEGER\n*          IJOB = 2: First compute an approximative null-vector e\n*              of Z using CGECON, e is normalized and solve for\n*              Zx = +-e - f with the sign giving the greater value of\n*              2-norm(x).  About 5 times as expensive as Default.\n*          IJOB .ne. 2: Local look ahead strategy where\n*              all entries of the r.h.s. b is choosen as either +1 or\n*              -1.  Default.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Z.\n*\n*  Z       (input) REAL array, dimension (LDZ, N)\n*          On entry, the LU part of the factorization of the n-by-n\n*          matrix Z computed by CGETC2:  Z = P * L * U * Q\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDA >= max(1, N).\n*\n*  RHS     (input/output) REAL array, dimension (N).\n*          On entry, RHS contains contributions from other subsystems.\n*          On exit, RHS contains the solution of the subsystem with\n*          entries according to the value of IJOB (see above).\n*\n*  RDSUM   (input/output) REAL\n*          On entry, the sum of squares of computed contributions to\n*          the Dif-estimate under computation by CTGSYL, where the\n*          scaling factor RDSCAL (see below) has been factored out.\n*          On exit, the corresponding sum of squares updated with the\n*          contributions from the current sub-system.\n*          If TRANS = 'T' RDSUM is not touched.\n*          NOTE: RDSUM only makes sense when CTGSY2 is called by CTGSYL.\n*\n*  RDSCAL  (input/output) REAL\n*          On entry, scaling factor used to prevent overflow in RDSUM.\n*          On exit, RDSCAL is updated w.r.t. the current contributions\n*          in RDSUM.\n*          If TRANS = 'T', RDSCAL is not touched.\n*          NOTE: RDSCAL only makes sense when CTGSY2 is called by\n*          CTGSYL.\n*\n*  IPIV    (input) INTEGER array, dimension (N).\n*          The pivot indices; for 1 <= i <= N, row i of the\n*          matrix has been interchanged with row IPIV(i).\n*\n*  JPIV    (input) INTEGER array, dimension (N).\n*          The pivot indices; for 1 <= j <= N, column j of the\n*          matrix has been interchanged with column JPIV(j).\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  This routine is a further developed implementation of algorithm\n*  BSOLVE in [1] using complete pivoting in the LU factorization.\n*\n*   [1]   Bo Kagstrom and Lars Westin,\n*         Generalized Schur Methods with Condition Estimators for\n*         Solving the Generalized Sylvester Equation, IEEE Transactions\n*         on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.\n*\n*   [2]   Peter Poromaa,\n*         On Efficient and Robust Estimators for the Separation\n*         between two Regular Matrix Pairs with Applications in\n*         Condition Estimation. Report UMINF-95.05, Department of\n*         Computing Science, Umea University, S-901 87 Umea, Sweden,\n*         1995.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rhs, rdsum, rdscal = NumRu::Lapack.clatdf( ijob, z, rhs, rdsum, rdscal, ipiv, jpiv, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_ijob = argv[0];
  rblapack_z = argv[1];
  rblapack_rhs = argv[2];
  rblapack_rdsum = argv[3];
  rblapack_rdscal = argv[4];
  rblapack_ipiv = argv[5];
  rblapack_jpiv = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  ijob = NUM2INT(rblapack_ijob);
  if (!NA_IsNArray(rblapack_rhs))
    rb_raise(rb_eArgError, "rhs (3th argument) must be NArray");
  if (NA_RANK(rblapack_rhs) != 1)
    rb_raise(rb_eArgError, "rank of rhs (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_rhs);
  if (NA_TYPE(rblapack_rhs) != NA_SCOMPLEX)
    rblapack_rhs = na_change_type(rblapack_rhs, NA_SCOMPLEX);
  rhs = NA_PTR_TYPE(rblapack_rhs, complex*);
  rdscal = (real)NUM2DBL(rblapack_rdscal);
  if (!NA_IsNArray(rblapack_jpiv))
    rb_raise(rb_eArgError, "jpiv (7th argument) must be NArray");
  if (NA_RANK(rblapack_jpiv) != 1)
    rb_raise(rb_eArgError, "rank of jpiv (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_jpiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of jpiv must be the same as shape 0 of rhs");
  if (NA_TYPE(rblapack_jpiv) != NA_LINT)
    rblapack_jpiv = na_change_type(rblapack_jpiv, NA_LINT);
  jpiv = NA_PTR_TYPE(rblapack_jpiv, integer*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (2th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (2th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  if (NA_SHAPE1(rblapack_z) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 0 of rhs");
  if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, complex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of rhs");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  rdsum = (real)NUM2DBL(rblapack_rdsum);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rhs_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  rhs_out__ = NA_PTR_TYPE(rblapack_rhs_out__, complex*);
  MEMCPY(rhs_out__, rhs, complex, NA_TOTAL(rblapack_rhs));
  rblapack_rhs = rblapack_rhs_out__;
  rhs = rhs_out__;

  clatdf_(&ijob, &n, z, &ldz, rhs, &rdsum, &rdscal, ipiv, jpiv);

  rblapack_rdsum = rb_float_new((double)rdsum);
  rblapack_rdscal = rb_float_new((double)rdscal);
  return rb_ary_new3(3, rblapack_rhs, rblapack_rdsum, rblapack_rdscal);
}

void
init_lapack_clatdf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clatdf", rblapack_clatdf, -1);
}
ruby-lapack-1.7.2/ext/dlaln2.c0000644000175000017500000002102112502221024015671 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaln2_(logical* ltrans, integer* na, integer* nw, doublereal* smin, doublereal* ca, doublereal* a, integer* lda, doublereal* d1, doublereal* d2, doublereal* b, integer* ldb, doublereal* wr, doublereal* wi, doublereal* x, integer* ldx, doublereal* scale, doublereal* xnorm, integer* info);


static VALUE
rblapack_dlaln2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ltrans;
  logical ltrans; 
  VALUE rblapack_smin;
  doublereal smin; 
  VALUE rblapack_ca;
  doublereal ca; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_d1;
  doublereal d1; 
  VALUE rblapack_d2;
  doublereal d2; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_wr;
  doublereal wr; 
  VALUE rblapack_wi;
  doublereal wi; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_scale;
  doublereal scale; 
  VALUE rblapack_xnorm;
  doublereal xnorm; 
  VALUE rblapack_info;
  integer info; 

  integer lda;
  integer na;
  integer ldb;
  integer nw;
  integer ldx;

  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  x, scale, xnorm, info = NumRu::Lapack.dlaln2( ltrans, smin, ca, a, d1, d2, b, wr, wi, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, LDB, WR, WI, X, LDX, SCALE, XNORM, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLALN2 solves a system of the form  (ca A - w D ) X = s B\n*  or (ca A' - w D) X = s B   with possible scaling (\"s\") and\n*  perturbation of A.  (A' means A-transpose.)\n*\n*  A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA\n*  real diagonal matrix, w is a real or complex value, and X and B are\n*  NA x 1 matrices -- real if w is real, complex if w is complex.  NA\n*  may be 1 or 2.\n*\n*  If w is complex, X and B are represented as NA x 2 matrices,\n*  the first column of each being the real part and the second\n*  being the imaginary part.\n*\n*  \"s\" is a scaling factor (.LE. 1), computed by DLALN2, which is\n*  so chosen that X can be computed without overflow.  X is further\n*  scaled if necessary to assure that norm(ca A - w D)*norm(X) is less\n*  than overflow.\n*\n*  If both singular values of (ca A - w D) are less than SMIN,\n*  SMIN*identity will be used instead of (ca A - w D).  If only one\n*  singular value is less than SMIN, one element of (ca A - w D) will be\n*  perturbed enough to make the smallest singular value roughly SMIN.\n*  If both singular values are at least SMIN, (ca A - w D) will not be\n*  perturbed.  In any case, the perturbation will be at most some small\n*  multiple of max( SMIN, ulp*norm(ca A - w D) ).  The singular values\n*  are computed by infinity-norm approximations, and thus will only be\n*  correct to a factor of 2 or so.\n*\n*  Note: all input quantities are assumed to be smaller than overflow\n*  by a reasonable factor.  (See BIGNUM.)\n*\n\n*  Arguments\n*  ==========\n*\n*  LTRANS  (input) LOGICAL\n*          =.TRUE.:  A-transpose will be used.\n*          =.FALSE.: A will be used (not transposed.)\n*\n*  NA      (input) INTEGER\n*          The size of the matrix A.  It may (only) be 1 or 2.\n*\n*  NW      (input) INTEGER\n*          1 if \"w\" is real, 2 if \"w\" is complex.  It may only be 1\n*          or 2.\n*\n*  SMIN    (input) DOUBLE PRECISION\n*          The desired lower bound on the singular values of A.  This\n*          should be a safe distance away from underflow or overflow,\n*          say, between (underflow/machine precision) and  (machine\n*          precision * overflow ).  (See BIGNUM and ULP.)\n*\n*  CA      (input) DOUBLE PRECISION\n*          The coefficient c, which A is multiplied by.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,NA)\n*          The NA x NA matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of A.  It must be at least NA.\n*\n*  D1      (input) DOUBLE PRECISION\n*          The 1,1 element in the diagonal matrix D.\n*\n*  D2      (input) DOUBLE PRECISION\n*          The 2,2 element in the diagonal matrix D.  Not used if NW=1.\n*\n*  B       (input) DOUBLE PRECISION array, dimension (LDB,NW)\n*          The NA x NW matrix B (right-hand side).  If NW=2 (\"w\" is\n*          complex), column 1 contains the real part of B and column 2\n*          contains the imaginary part.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of B.  It must be at least NA.\n*\n*  WR      (input) DOUBLE PRECISION\n*          The real part of the scalar \"w\".\n*\n*  WI      (input) DOUBLE PRECISION\n*          The imaginary part of the scalar \"w\".  Not used if NW=1.\n*\n*  X       (output) DOUBLE PRECISION array, dimension (LDX,NW)\n*          The NA x NW matrix X (unknowns), as computed by DLALN2.\n*          If NW=2 (\"w\" is complex), on exit, column 1 will contain\n*          the real part of X and column 2 will contain the imaginary\n*          part.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of X.  It must be at least NA.\n*\n*  SCALE   (output) DOUBLE PRECISION\n*          The scale factor that B must be multiplied by to insure\n*          that overflow does not occur when computing X.  Thus,\n*          (ca A - w D) X  will be SCALE*B, not B (ignoring\n*          perturbations of A.)  It will be at most 1.\n*\n*  XNORM   (output) DOUBLE PRECISION\n*          The infinity-norm of X, when X is regarded as an NA x NW\n*          real matrix.\n*\n*  INFO    (output) INTEGER\n*          An error flag.  It will be set to zero if no error occurs,\n*          a negative number if an argument is in error, or a positive\n*          number if  ca A - w D  had to be perturbed.\n*          The possible values are:\n*          = 0: No error occurred, and (ca A - w D) did not have to be\n*                 perturbed.\n*          = 1: (ca A - w D) had to be perturbed to make its smallest\n*               (or only) singular value greater than SMIN.\n*          NOTE: In the interests of speed, this routine does not\n*                check the inputs for errors.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, scale, xnorm, info = NumRu::Lapack.dlaln2( ltrans, smin, ca, a, d1, d2, b, wr, wi, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_ltrans = argv[0];
  rblapack_smin = argv[1];
  rblapack_ca = argv[2];
  rblapack_a = argv[3];
  rblapack_d1 = argv[4];
  rblapack_d2 = argv[5];
  rblapack_b = argv[6];
  rblapack_wr = argv[7];
  rblapack_wi = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  ltrans = (rblapack_ltrans == Qtrue);
  ca = NUM2DBL(rblapack_ca);
  d1 = NUM2DBL(rblapack_d1);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nw = 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*);
  wi = NUM2DBL(rblapack_wi);
  smin = NUM2DBL(rblapack_smin);
  d2 = NUM2DBL(rblapack_d2);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  na = 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*);
  ldx = na;
  wr = NUM2DBL(rblapack_wr);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nw;
    rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublereal*);

  dlaln2_(<rans, &na, &nw, &smin, &ca, a, &lda, &d1, &d2, b, &ldb, &wr, &wi, x, &ldx, &scale, &xnorm, &info);

  rblapack_scale = rb_float_new((double)scale);
  rblapack_xnorm = rb_float_new((double)xnorm);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_x, rblapack_scale, rblapack_xnorm, rblapack_info);
}

void
init_lapack_dlaln2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaln2", rblapack_dlaln2, -1);
}
ruby-lapack-1.7.2/ext/strevc.c0000644000175000017500000002516712502221016016043 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID strevc_(char* side, char* howmny, logical* select, integer* n, real* t, integer* ldt, real* vl, integer* ldvl, real* vr, integer* ldvr, integer* mm, integer* m, real* work, integer* info);


static VALUE
rblapack_strevc(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_howmny;
  char howmny; 
  VALUE rblapack_select;
  logical *select; 
  VALUE rblapack_t;
  real *t; 
  VALUE rblapack_vl;
  real *vl; 
  VALUE rblapack_vr;
  real *vr; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_select_out__;
  logical *select_out__;
  VALUE rblapack_vl_out__;
  real *vl_out__;
  VALUE rblapack_vr_out__;
  real *vr_out__;
  real *work;

  integer n;
  integer ldt;
  integer ldvl;
  integer mm;
  integer ldvr;

  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  m, info, select, vl, vr = NumRu::Lapack.strevc( side, howmny, select, t, vl, vr, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, LDVR, MM, M, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  STREVC computes some or all of the right and/or left eigenvectors of\n*  a real upper quasi-triangular matrix T.\n*  Matrices of this type are produced by the Schur factorization of\n*  a real general matrix:  A = Q*T*Q**T, as computed by SHSEQR.\n*  \n*  The right eigenvector x and the left eigenvector y of T corresponding\n*  to an eigenvalue w are defined by:\n*  \n*     T*x = w*x,     (y**H)*T = w*(y**H)\n*  \n*  where y**H denotes the conjugate transpose of y.\n*  The eigenvalues are not input to this routine, but are read directly\n*  from the diagonal blocks of T.\n*  \n*  This routine returns the matrices X and/or Y of right and left\n*  eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an\n*  input matrix.  If Q is the orthogonal factor that reduces a matrix\n*  A to Schur form T, then Q*X and Q*Y are the matrices of right and\n*  left eigenvectors of A.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'R':  compute right eigenvectors only;\n*          = 'L':  compute left eigenvectors only;\n*          = 'B':  compute both right and left eigenvectors.\n*\n*  HOWMNY  (input) CHARACTER*1\n*          = 'A':  compute all right and/or left eigenvectors;\n*          = 'B':  compute all right and/or left eigenvectors,\n*                  backtransformed by the matrices in VR and/or VL;\n*          = 'S':  compute selected right and/or left eigenvectors,\n*                  as indicated by the logical array SELECT.\n*\n*  SELECT  (input/output) LOGICAL array, dimension (N)\n*          If HOWMNY = 'S', SELECT specifies the eigenvectors to be\n*          computed.\n*          If w(j) is a real eigenvalue, the corresponding real\n*          eigenvector is computed if SELECT(j) is .TRUE..\n*          If w(j) and w(j+1) are the real and imaginary parts of a\n*          complex eigenvalue, the corresponding complex eigenvector is\n*          computed if either SELECT(j) or SELECT(j+1) is .TRUE., and\n*          on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to\n*          .FALSE..\n*          Not referenced if HOWMNY = 'A' or 'B'.\n*\n*  N       (input) INTEGER\n*          The order of the matrix T. N >= 0.\n*\n*  T       (input) REAL array, dimension (LDT,N)\n*          The upper quasi-triangular matrix T in Schur canonical form.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= max(1,N).\n*\n*  VL      (input/output) REAL array, dimension (LDVL,MM)\n*          On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must\n*          contain an N-by-N matrix Q (usually the orthogonal matrix Q\n*          of Schur vectors returned by SHSEQR).\n*          On exit, if SIDE = 'L' or 'B', VL contains:\n*          if HOWMNY = 'A', the matrix Y of left eigenvectors of T;\n*          if HOWMNY = 'B', the matrix Q*Y;\n*          if HOWMNY = 'S', the left eigenvectors of T specified by\n*                           SELECT, stored consecutively in the columns\n*                           of VL, in the same order as their\n*                           eigenvalues.\n*          A complex eigenvector corresponding to a complex eigenvalue\n*          is stored in two consecutive columns, the first holding the\n*          real part, and the second the imaginary part.\n*          Not referenced if SIDE = 'R'.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the array VL.  LDVL >= 1, and if\n*          SIDE = 'L' or 'B', LDVL >= N.\n*\n*  VR      (input/output) REAL array, dimension (LDVR,MM)\n*          On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must\n*          contain an N-by-N matrix Q (usually the orthogonal matrix Q\n*          of Schur vectors returned by SHSEQR).\n*          On exit, if SIDE = 'R' or 'B', VR contains:\n*          if HOWMNY = 'A', the matrix X of right eigenvectors of T;\n*          if HOWMNY = 'B', the matrix Q*X;\n*          if HOWMNY = 'S', the right eigenvectors of T specified by\n*                           SELECT, stored consecutively in the columns\n*                           of VR, in the same order as their\n*                           eigenvalues.\n*          A complex eigenvector corresponding to a complex eigenvalue\n*          is stored in two consecutive columns, the first holding the\n*          real part and the second the imaginary part.\n*          Not referenced if SIDE = 'L'.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the array VR.  LDVR >= 1, and if\n*          SIDE = 'R' or 'B', LDVR >= N.\n*\n*  MM      (input) INTEGER\n*          The number of columns in the arrays VL and/or VR. MM >= M.\n*\n*  M       (output) INTEGER\n*          The number of columns in the arrays VL and/or VR actually\n*          used to store the eigenvectors.\n*          If HOWMNY = 'A' or 'B', M is set to N.\n*          Each selected real eigenvector occupies one column and each\n*          selected complex eigenvector occupies two columns.\n*\n*  WORK    (workspace) REAL array, dimension (3*N)\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 algorithm used in this program is basically backward (forward)\n*  substitution, with scaling to make the the code robust against\n*  possible overflow.\n*\n*  Each eigenvector is normalized so that the element of largest\n*  magnitude has magnitude 1; here the magnitude of a complex number\n*  (x,y) is taken to be |x| + |y|.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, info, select, vl, vr = NumRu::Lapack.strevc( side, howmny, select, t, vl, vr, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_howmny = argv[1];
  rblapack_select = argv[2];
  rblapack_t = argv[3];
  rblapack_vl = argv[4];
  rblapack_vr = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_select))
    rb_raise(rb_eArgError, "select (3th argument) must be NArray");
  if (NA_RANK(rblapack_select) != 1)
    rb_raise(rb_eArgError, "rank of select (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_select);
  if (NA_TYPE(rblapack_select) != NA_LINT)
    rblapack_select = na_change_type(rblapack_select, NA_LINT);
  select = NA_PTR_TYPE(rblapack_select, logical*);
  if (!NA_IsNArray(rblapack_vl))
    rb_raise(rb_eArgError, "vl (5th argument) must be NArray");
  if (NA_RANK(rblapack_vl) != 2)
    rb_raise(rb_eArgError, "rank of vl (5th argument) must be %d", 2);
  ldvl = NA_SHAPE0(rblapack_vl);
  mm = NA_SHAPE1(rblapack_vl);
  if (NA_TYPE(rblapack_vl) != NA_SFLOAT)
    rblapack_vl = na_change_type(rblapack_vl, NA_SFLOAT);
  vl = NA_PTR_TYPE(rblapack_vl, real*);
  howmny = StringValueCStr(rblapack_howmny)[0];
  if (!NA_IsNArray(rblapack_vr))
    rb_raise(rb_eArgError, "vr (6th argument) must be NArray");
  if (NA_RANK(rblapack_vr) != 2)
    rb_raise(rb_eArgError, "rank of vr (6th argument) must be %d", 2);
  ldvr = NA_SHAPE0(rblapack_vr);
  if (NA_SHAPE1(rblapack_vr) != mm)
    rb_raise(rb_eRuntimeError, "shape 1 of vr must be the same as shape 1 of vl");
  if (NA_TYPE(rblapack_vr) != NA_SFLOAT)
    rblapack_vr = na_change_type(rblapack_vr, NA_SFLOAT);
  vr = NA_PTR_TYPE(rblapack_vr, real*);
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (4th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (4th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  if (NA_SHAPE1(rblapack_t) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 0 of select");
  if (NA_TYPE(rblapack_t) != NA_SFLOAT)
    rblapack_t = na_change_type(rblapack_t, NA_SFLOAT);
  t = NA_PTR_TYPE(rblapack_t, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_select_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  select_out__ = NA_PTR_TYPE(rblapack_select_out__, logical*);
  MEMCPY(select_out__, select, logical, NA_TOTAL(rblapack_select));
  rblapack_select = rblapack_select_out__;
  select = select_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = mm;
    rblapack_vl_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, real*);
  MEMCPY(vl_out__, vl, real, NA_TOTAL(rblapack_vl));
  rblapack_vl = rblapack_vl_out__;
  vl = vl_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = mm;
    rblapack_vr_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vr_out__ = NA_PTR_TYPE(rblapack_vr_out__, real*);
  MEMCPY(vr_out__, vr, real, NA_TOTAL(rblapack_vr));
  rblapack_vr = rblapack_vr_out__;
  vr = vr_out__;
  work = ALLOC_N(real, (3*n));

  strevc_(&side, &howmny, select, &n, t, &ldt, vl, &ldvl, vr, &ldvr, &mm, &m, work, &info);

  free(work);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_m, rblapack_info, rblapack_select, rblapack_vl, rblapack_vr);
}

void
init_lapack_strevc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "strevc", rblapack_strevc, -1);
}
ruby-lapack-1.7.2/ext/cpftri.c0000644000175000017500000002013012502221024016004 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cpftri_(char* transr, char* uplo, integer* n, complex* a, integer* info);


static VALUE
rblapack_cpftri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;


  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  info, a = NumRu::Lapack.cpftri( transr, uplo, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPFTRI( TRANSR, UPLO, N, A, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPFTRI computes the inverse of a complex Hermitian positive definite\n*  matrix A using the Cholesky factorization A = U**H*U or A = L*L**H\n*  computed by CPFTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANSR    (input) CHARACTER*1\n*          = 'N':  The Normal TRANSR of RFP A is stored;\n*          = 'C':  The Conjugate-transpose TRANSR of RFP A is stored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension ( N*(N+1)/2 );\n*          On entry, the Hermitian matrix A in RFP format. RFP format is\n*          described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'\n*          then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is\n*          (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is\n*          the Conjugate-transpose of RFP A as defined when\n*          TRANSR = 'N'. The contents of RFP A are defined by UPLO as\n*          follows: If UPLO = 'U' the RFP A contains the nt elements of\n*          upper packed A. If UPLO = 'L' the RFP A contains the elements\n*          of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =\n*          'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N\n*          is odd. See the Note below for more details.\n*\n*          On exit, the Hermitian inverse of the original matrix, in the\n*          same storage format.\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,i) element of the factor U or L is\n*                zero, and the inverse could not be computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  We first consider Standard Packed Format when N is even.\n*  We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  conjugate-transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  conjugate-transpose of the last three columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                -- -- --\n*        03 04 05                33 43 53\n*                                   -- --\n*        13 14 15                00 44 54\n*                                      --\n*        23 24 25                10 11 55\n*\n*        33 34 35                20 21 22\n*        --\n*        00 44 45                30 31 32\n*        -- --\n*        01 11 55                40 41 42\n*        -- -- --\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- -- --                -- -- -- -- -- --\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     -- -- -- -- --                -- -- -- -- --\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     -- -- -- -- -- --                -- -- -- --\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We next  consider Standard Packed Format when N is odd.\n*  We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  conjugate-transpose of the first two   columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  conjugate-transpose of the last two   columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N odd  and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                   -- --\n*        02 03 04                00 33 43\n*                                      --\n*        12 13 14                10 11 44\n*\n*        22 23 24                20 21 22\n*        --\n*        00 33 34                30 31 32\n*        -- --\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- --                   -- -- -- -- -- --\n*     02 12 22 00 01             00 10 20 30 40 50\n*     -- -- -- --                   -- -- -- -- --\n*     03 13 23 33 11             33 11 21 31 41 51\n*     -- -- -- -- --                   -- -- -- --\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.cpftri( transr, uplo, n, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_transr = argv[0];
  rblapack_uplo = argv[1];
  rblapack_n = argv[2];
  rblapack_a = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  n = NUM2INT(rblapack_n);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 1)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  cpftri_(&transr, &uplo, &n, a, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_cpftri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cpftri", rblapack_cpftri, -1);
}
ruby-lapack-1.7.2/ext/zgesvxx.c0000644000175000017500000007230112502221017016244 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgesvxx_(char* fact, char* trans, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, char* equed, doublereal* r, doublereal* c, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* rpvgrw, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zgesvxx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_r;
  doublereal *r; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_params;
  doublereal *params; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_rpvgrw;
  doublereal rpvgrw; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_err_bnds_norm;
  doublereal *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  doublereal *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_af_out__;
  doublecomplex *af_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  VALUE rblapack_r_out__;
  doublereal *r_out__;
  VALUE rblapack_c_out__;
  doublereal *c_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  VALUE rblapack_params_out__;
  doublereal *params_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer nparams;
  integer ldx;
  integer n_err_bnds;

  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  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, r, c, b, params = NumRu::Lapack.zgesvxx( fact, trans, a, af, ipiv, equed, r, c, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     ZGESVXX uses the LU factorization to compute the solution to a\n*     complex*16 system of linear equations  A * X = B,  where A is an\n*     N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n*     If requested, both normwise and maximum componentwise error bounds\n*     are returned. ZGESVXX will return a solution with a tiny\n*     guaranteed error (O(eps) where eps is the working machine\n*     precision) unless the matrix is very ill-conditioned, in which\n*     case a warning is returned. Relevant condition numbers also are\n*     calculated and returned.\n*\n*     ZGESVXX accepts user-provided factorizations and equilibration\n*     factors; see the definitions of the FACT and EQUED options.\n*     Solving with refinement and using a factorization from a previous\n*     ZGESVXX call will also produce a solution with either O(eps)\n*     errors or warnings, but we cannot make that claim for general\n*     user-provided factorizations and equilibration factors if they\n*     differ from what ZGESVXX would itself produce.\n*\n*     Description\n*     ===========\n*\n*     The following steps are performed:\n*\n*     1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n*     the system:\n*\n*       TRANS = 'N':  diag(R)*A*diag(C)     *inv(diag(C))*X = diag(R)*B\n*       TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n*       TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n*     or diag(C)*B (if TRANS = 'T' or 'C').\n*\n*     2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n*     the matrix A (after equilibration if FACT = 'E') as\n*\n*       A = P * L * U,\n*\n*     where P is a permutation matrix, L is a unit lower triangular\n*     matrix, and U is upper triangular.\n*\n*     3. If some U(i,i)=0, so that U is exactly singular, then the\n*     routine returns with INFO = i. Otherwise, the factored form of A\n*     is used to estimate the condition number of the matrix A (see\n*     argument RCOND). If the reciprocal of the condition number is less\n*     than machine precision, the routine still goes on to solve for X\n*     and compute error bounds as described below.\n*\n*     4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*     5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n*     the routine will use iterative refinement to try to get a small\n*     error and error bounds.  Refinement calculates the residual to at\n*     least twice the working precision.\n*\n*     6. If equilibration was used, the matrix X is premultiplied by\n*     diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n*     that it solves the original system before equilibration.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     FACT    (input) CHARACTER*1\n*     Specifies whether or not the factored form of the matrix A is\n*     supplied on entry, and if not, whether the matrix A should be\n*     equilibrated before it is factored.\n*       = 'F':  On entry, AF and IPIV contain the factored form of A.\n*               If EQUED is not 'N', the matrix A has been\n*               equilibrated with scaling factors given by R and C.\n*               A, AF, and IPIV are not modified.\n*       = 'N':  The matrix A will be copied to AF and factored.\n*       = 'E':  The matrix A will be equilibrated if necessary, then\n*               copied to AF and factored.\n*\n*     TRANS   (input) CHARACTER*1\n*     Specifies the form of the system of equations:\n*       = 'N':  A * X = B     (No transpose)\n*       = 'T':  A**T * X = B  (Transpose)\n*       = 'C':  A**H * X = B  (Conjugate Transpose)\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.  If FACT = 'F' and EQUED is\n*     not 'N', then A must have been equilibrated by the scaling\n*     factors in R and/or C.  A is not modified if FACT = 'F' or\n*     'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n*     On exit, if EQUED .ne. 'N', A is scaled as follows:\n*     EQUED = 'R':  A := diag(R) * A\n*     EQUED = 'C':  A := A * diag(C)\n*     EQUED = 'B':  A := diag(R) * A * diag(C).\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input or output) COMPLEX*16 array, dimension (LDAF,N)\n*     If FACT = 'F', then AF is an input argument and on entry\n*     contains the factors L and U from the factorization\n*     A = P*L*U as computed by ZGETRF.  If EQUED .ne. 'N', then\n*     AF is the factored form of the equilibrated matrix A.\n*\n*     If FACT = 'N', then AF is an output argument and on exit\n*     returns the factors L and U from the factorization A = P*L*U\n*     of the original matrix A.\n*\n*     If FACT = 'E', then AF is an output argument and on exit\n*     returns the factors L and U from the factorization A = P*L*U\n*     of the equilibrated matrix A (see the description of A for\n*     the form of the equilibrated matrix).\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input or output) INTEGER array, dimension (N)\n*     If FACT = 'F', then IPIV is an input argument and on entry\n*     contains the pivot indices from the factorization A = P*L*U\n*     as computed by ZGETRF; row i of the matrix was interchanged\n*     with row IPIV(i).\n*\n*     If FACT = 'N', then IPIV is an output argument and on exit\n*     contains the pivot indices from the factorization A = P*L*U\n*     of the original matrix A.\n*\n*     If FACT = 'E', then IPIV is an output argument and on exit\n*     contains the pivot indices from the factorization A = P*L*U\n*     of the equilibrated matrix A.\n*\n*     EQUED   (input or output) CHARACTER*1\n*     Specifies the form of equilibration that was done.\n*       = 'N':  No equilibration (always true if FACT = 'N').\n*       = 'R':  Row equilibration, i.e., A has been premultiplied by\n*               diag(R).\n*       = 'C':  Column equilibration, i.e., A has been postmultiplied\n*               by diag(C).\n*       = 'B':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(R) * A * diag(C).\n*     EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*     output argument.\n*\n*     R       (input or output) DOUBLE PRECISION array, dimension (N)\n*     The row scale factors for A.  If EQUED = 'R' or 'B', A is\n*     multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n*     is not accessed.  R is an input argument if FACT = 'F';\n*     otherwise, R is an output argument.  If FACT = 'F' and\n*     EQUED = 'R' or 'B', each element of R must be positive.\n*     If R is output, each element of R is a power of the radix.\n*     If R is input, each element of R should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     C       (input or output) DOUBLE PRECISION array, dimension (N)\n*     The column scale factors for A.  If EQUED = 'C' or 'B', A is\n*     multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n*     is not accessed.  C is an input argument if FACT = 'F';\n*     otherwise, C is an output argument.  If FACT = 'F' and\n*     EQUED = 'C' or 'B', each element of C must be positive.\n*     If C is output, each element of C is a power of the radix.\n*     If C is input, each element of C should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*     On entry, the N-by-NRHS right hand side matrix B.\n*     On exit,\n*     if EQUED = 'N', B is not modified;\n*     if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n*        diag(R)*B;\n*     if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n*        overwritten by diag(C)*B.\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (output) COMPLEX*16 array, dimension (LDX,NRHS)\n*     If INFO = 0, the N-by-NRHS solution matrix X to the original\n*     system of equations.  Note that A and B are modified on exit\n*     if EQUED .ne. 'N', and the solution to the equilibrated system is\n*     inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n*     inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) DOUBLE PRECISION\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     RPVGRW  (output) DOUBLE PRECISION\n*     Reciprocal pivot growth.  On exit, this contains the reciprocal\n*     pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n*     norm is used.  If this is much less than 1, then the stability of\n*     the LU factorization of the (equilibrated) matrix A could be poor.\n*     This also means that the solution X, estimated condition numbers,\n*     and error bounds could be unreliable. If factorization fails with\n*     0 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, r, c, b, params = NumRu::Lapack.zgesvxx( fact, trans, a, af, ipiv, equed, r, c, b, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_fact = argv[0];
  rblapack_trans = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_equed = argv[5];
  rblapack_r = argv[6];
  rblapack_c = argv[7];
  rblapack_b = argv[8];
  rblapack_params = argv[9];
  if (argc == 10) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_r))
    rb_raise(rb_eArgError, "r (7th argument) must be NArray");
  if (NA_RANK(rblapack_r) != 1)
    rb_raise(rb_eArgError, "rank of r (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_r) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_r) != NA_DFLOAT)
    rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
  r = NA_PTR_TYPE(rblapack_r, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (9th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (9th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  n_err_bnds = 3;
  trans = StringValueCStr(rblapack_trans)[0];
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (10th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (10th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_DFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
  params = NA_PTR_TYPE(rblapack_params, doublereal*);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (8th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  ldx = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldaf;
    shape[1] = n;
    rblapack_af_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  af_out__ = NA_PTR_TYPE(rblapack_af_out__, doublecomplex*);
  MEMCPY(af_out__, af, doublecomplex, NA_TOTAL(rblapack_af));
  rblapack_af = rblapack_af_out__;
  af = af_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_r_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  r_out__ = NA_PTR_TYPE(rblapack_r_out__, doublereal*);
  MEMCPY(r_out__, r, doublereal, NA_TOTAL(rblapack_r));
  rblapack_r = rblapack_r_out__;
  r = r_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
  MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (2*n));

  zgesvxx_(&fact, &trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_rpvgrw = rb_float_new((double)rpvgrw);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(15, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_a, rblapack_af, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b, rblapack_params);
}

void
init_lapack_zgesvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgesvxx", rblapack_zgesvxx, -1);
}
ruby-lapack-1.7.2/ext/clals0.c0000644000175000017500000003131712502221013015702 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clals0_(integer* icompq, integer* nl, integer* nr, integer* sqre, integer* nrhs, complex* b, integer* ldb, complex* bx, integer* ldbx, integer* perm, integer* givptr, integer* givcol, integer* ldgcol, real* givnum, integer* ldgnum, real* poles, real* difl, real* difr, real* z, integer* k, real* c, real* s, real* rwork, integer* info);


static VALUE
rblapack_clals0(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_icompq;
  integer icompq; 
  VALUE rblapack_nl;
  integer nl; 
  VALUE rblapack_nr;
  integer nr; 
  VALUE rblapack_sqre;
  integer sqre; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_perm;
  integer *perm; 
  VALUE rblapack_givptr;
  integer givptr; 
  VALUE rblapack_givcol;
  integer *givcol; 
  VALUE rblapack_givnum;
  real *givnum; 
  VALUE rblapack_poles;
  real *poles; 
  VALUE rblapack_difl;
  real *difl; 
  VALUE rblapack_difr;
  real *difr; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_c;
  real c; 
  VALUE rblapack_s;
  real s; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  complex *b_out__;
  complex *bx;
  real *rwork;

  integer ldb;
  integer nrhs;
  integer n;
  integer ldgcol;
  integer ldgnum;
  integer k;
  integer ldbx;

  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  info, b = NumRu::Lapack.clals0( icompq, nl, nr, sqre, b, perm, givptr, givcol, givnum, poles, difl, difr, z, c, s, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CLALS0 applies back the multiplying factors of either the left or the\n*  right singular vector matrix of a diagonal matrix appended by a row\n*  to the right hand side matrix B in solving the least squares problem\n*  using the divide-and-conquer SVD approach.\n*\n*  For the left singular vector matrix, three types of orthogonal\n*  matrices are involved:\n*\n*  (1L) Givens rotations: the number of such rotations is GIVPTR; the\n*       pairs of columns/rows they were applied to are stored in GIVCOL;\n*       and the C- and S-values of these rotations are stored in GIVNUM.\n*\n*  (2L) Permutation. The (NL+1)-st row of B is to be moved to the first\n*       row, and for J=2:N, PERM(J)-th row of B is to be moved to the\n*       J-th row.\n*\n*  (3L) The left singular vector matrix of the remaining matrix.\n*\n*  For the right singular vector matrix, four types of orthogonal\n*  matrices are involved:\n*\n*  (1R) The right singular vector matrix of the remaining matrix.\n*\n*  (2R) If SQRE = 1, one extra Givens rotation to generate the right\n*       null space.\n*\n*  (3R) The inverse transformation of (2L).\n*\n*  (4R) The inverse transformation of (1L).\n*\n\n*  Arguments\n*  =========\n*\n*  ICOMPQ (input) INTEGER\n*         Specifies whether singular vectors are to be computed in\n*         factored form:\n*         = 0: Left singular vector matrix.\n*         = 1: Right singular vector matrix.\n*\n*  NL     (input) INTEGER\n*         The row dimension of the upper block. NL >= 1.\n*\n*  NR     (input) INTEGER\n*         The row dimension of the lower block. NR >= 1.\n*\n*  SQRE   (input) INTEGER\n*         = 0: the lower block is an NR-by-NR square matrix.\n*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n*         The bidiagonal matrix has row dimension N = NL + NR + 1,\n*         and column dimension M = N + SQRE.\n*\n*  NRHS   (input) INTEGER\n*         The number of columns of B and BX. NRHS must be at least 1.\n*\n*  B      (input/output) COMPLEX array, dimension ( LDB, NRHS )\n*         On input, B contains the right hand sides of the least\n*         squares problem in rows 1 through M. On output, B contains\n*         the solution X in rows 1 through N.\n*\n*  LDB    (input) INTEGER\n*         The leading dimension of B. LDB must be at least\n*         max(1,MAX( M, N ) ).\n*\n*  BX     (workspace) COMPLEX array, dimension ( LDBX, NRHS )\n*\n*  LDBX   (input) INTEGER\n*         The leading dimension of BX.\n*\n*  PERM   (input) INTEGER array, dimension ( N )\n*         The permutations (from deflation and sorting) applied\n*         to the two blocks.\n*\n*  GIVPTR (input) INTEGER\n*         The number of Givens rotations which took place in this\n*         subproblem.\n*\n*  GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )\n*         Each pair of numbers indicates a pair of rows/columns\n*         involved in a Givens rotation.\n*\n*  LDGCOL (input) INTEGER\n*         The leading dimension of GIVCOL, must be at least N.\n*\n*  GIVNUM (input) REAL array, dimension ( LDGNUM, 2 )\n*         Each number indicates the C or S value used in the\n*         corresponding Givens rotation.\n*\n*  LDGNUM (input) INTEGER\n*         The leading dimension of arrays DIFR, POLES and\n*         GIVNUM, must be at least K.\n*\n*  POLES  (input) REAL array, dimension ( LDGNUM, 2 )\n*         On entry, POLES(1:K, 1) contains the new singular\n*         values obtained from solving the secular equation, and\n*         POLES(1:K, 2) is an array containing the poles in the secular\n*         equation.\n*\n*  DIFL   (input) REAL array, dimension ( K ).\n*         On entry, DIFL(I) is the distance between I-th updated\n*         (undeflated) singular value and the I-th (undeflated) old\n*         singular value.\n*\n*  DIFR   (input) REAL array, dimension ( LDGNUM, 2 ).\n*         On entry, DIFR(I, 1) contains the distances between I-th\n*         updated (undeflated) singular value and the I+1-th\n*         (undeflated) old singular value. And DIFR(I, 2) is the\n*         normalizing factor for the I-th right singular vector.\n*\n*  Z      (input) REAL array, dimension ( K )\n*         Contain the components of the deflation-adjusted updating row\n*         vector.\n*\n*  K      (input) INTEGER\n*         Contains the dimension of the non-deflated matrix,\n*         This is the order of the related secular equation. 1 <= K <=N.\n*\n*  C      (input) REAL\n*         C contains garbage if SQRE =0 and the C-value of a Givens\n*         rotation related to the right null space if SQRE = 1.\n*\n*  S      (input) REAL\n*         S contains garbage if SQRE =0 and the S-value of a Givens\n*         rotation related to the right null space if SQRE = 1.\n*\n*  RWORK  (workspace) REAL array, dimension\n*         ( K*(1+NRHS) + 2*NRHS )\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*  Based on contributions by\n*     Ming Gu and Ren-Cang Li, Computer Science Division, University of\n*       California at Berkeley, USA\n*     Osni Marques, LBNL/NERSC, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.clals0( icompq, nl, nr, sqre, b, perm, givptr, givcol, givnum, poles, difl, difr, z, c, s, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 15 && argc != 15)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
  rblapack_icompq = argv[0];
  rblapack_nl = argv[1];
  rblapack_nr = argv[2];
  rblapack_sqre = argv[3];
  rblapack_b = argv[4];
  rblapack_perm = argv[5];
  rblapack_givptr = argv[6];
  rblapack_givcol = argv[7];
  rblapack_givnum = argv[8];
  rblapack_poles = argv[9];
  rblapack_difl = argv[10];
  rblapack_difr = argv[11];
  rblapack_z = argv[12];
  rblapack_c = argv[13];
  rblapack_s = argv[14];
  if (argc == 15) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  icompq = NUM2INT(rblapack_icompq);
  nr = NUM2INT(rblapack_nr);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  givptr = NUM2INT(rblapack_givptr);
  if (!NA_IsNArray(rblapack_givnum))
    rb_raise(rb_eArgError, "givnum (9th argument) must be NArray");
  if (NA_RANK(rblapack_givnum) != 2)
    rb_raise(rb_eArgError, "rank of givnum (9th argument) must be %d", 2);
  ldgnum = NA_SHAPE0(rblapack_givnum);
  if (NA_SHAPE1(rblapack_givnum) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", 2);
  if (NA_TYPE(rblapack_givnum) != NA_SFLOAT)
    rblapack_givnum = na_change_type(rblapack_givnum, NA_SFLOAT);
  givnum = NA_PTR_TYPE(rblapack_givnum, real*);
  if (!NA_IsNArray(rblapack_difl))
    rb_raise(rb_eArgError, "difl (11th argument) must be NArray");
  if (NA_RANK(rblapack_difl) != 1)
    rb_raise(rb_eArgError, "rank of difl (11th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_difl);
  if (NA_TYPE(rblapack_difl) != NA_SFLOAT)
    rblapack_difl = na_change_type(rblapack_difl, NA_SFLOAT);
  difl = NA_PTR_TYPE(rblapack_difl, real*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (13th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (13th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != k)
    rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of difl");
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  s = (real)NUM2DBL(rblapack_s);
  nl = NUM2INT(rblapack_nl);
  if (!NA_IsNArray(rblapack_perm))
    rb_raise(rb_eArgError, "perm (6th argument) must be NArray");
  if (NA_RANK(rblapack_perm) != 1)
    rb_raise(rb_eArgError, "rank of perm (6th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_perm);
  if (NA_TYPE(rblapack_perm) != NA_LINT)
    rblapack_perm = na_change_type(rblapack_perm, NA_LINT);
  perm = NA_PTR_TYPE(rblapack_perm, integer*);
  if (!NA_IsNArray(rblapack_poles))
    rb_raise(rb_eArgError, "poles (10th argument) must be NArray");
  if (NA_RANK(rblapack_poles) != 2)
    rb_raise(rb_eArgError, "rank of poles (10th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_poles) != ldgnum)
    rb_raise(rb_eRuntimeError, "shape 0 of poles must be the same as shape 0 of givnum");
  if (NA_SHAPE1(rblapack_poles) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of poles must be %d", 2);
  if (NA_TYPE(rblapack_poles) != NA_SFLOAT)
    rblapack_poles = na_change_type(rblapack_poles, NA_SFLOAT);
  poles = NA_PTR_TYPE(rblapack_poles, real*);
  c = (real)NUM2DBL(rblapack_c);
  sqre = NUM2INT(rblapack_sqre);
  if (!NA_IsNArray(rblapack_difr))
    rb_raise(rb_eArgError, "difr (12th argument) must be NArray");
  if (NA_RANK(rblapack_difr) != 2)
    rb_raise(rb_eArgError, "rank of difr (12th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_difr) != ldgnum)
    rb_raise(rb_eRuntimeError, "shape 0 of difr must be the same as shape 0 of givnum");
  if (NA_SHAPE1(rblapack_difr) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of difr must be %d", 2);
  if (NA_TYPE(rblapack_difr) != NA_SFLOAT)
    rblapack_difr = na_change_type(rblapack_difr, NA_SFLOAT);
  difr = NA_PTR_TYPE(rblapack_difr, real*);
  if (!NA_IsNArray(rblapack_givcol))
    rb_raise(rb_eArgError, "givcol (8th argument) must be NArray");
  if (NA_RANK(rblapack_givcol) != 2)
    rb_raise(rb_eArgError, "rank of givcol (8th argument) must be %d", 2);
  ldgcol = NA_SHAPE0(rblapack_givcol);
  if (NA_SHAPE1(rblapack_givcol) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", 2);
  if (NA_TYPE(rblapack_givcol) != NA_LINT)
    rblapack_givcol = na_change_type(rblapack_givcol, NA_LINT);
  givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
  ldbx = n;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  bx = ALLOC_N(complex, (ldbx)*(nrhs));
  rwork = ALLOC_N(real, (k*(1+nrhs) + 2*nrhs));

  clals0_(&icompq, &nl, &nr, &sqre, &nrhs, b, &ldb, bx, &ldbx, perm, &givptr, givcol, &ldgcol, givnum, &ldgnum, poles, difl, difr, z, &k, &c, &s, rwork, &info);

  free(bx);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_clals0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clals0", rblapack_clals0, -1);
}
ruby-lapack-1.7.2/ext/chetrs.c0000644000175000017500000001175012502221026016017 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chetrs_(char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, integer* ipiv, complex* b, integer* ldb, integer* info);


static VALUE
rblapack_chetrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.chetrs( uplo, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHETRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHETRS solves a system of linear equations A*X = B with a complex\n*  Hermitian matrix A using the factorization A = U*D*U**H or\n*  A = L*D*L**H computed by CHETRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**H;\n*          = 'L':  Lower triangular, form is A = L*D*L**H.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by CHETRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by CHETRF.\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.chetrs( uplo, a, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  chetrs_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_chetrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chetrs", rblapack_chetrs, -1);
}
ruby-lapack-1.7.2/ext/dspgv.c0000644000175000017500000001751612502221021015653 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dspgv_(integer* itype, char* jobz, char* uplo, integer* n, doublereal* ap, doublereal* bp, doublereal* w, doublereal* z, integer* ldz, doublereal* work, integer* info);


static VALUE
rblapack_dspgv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_bp;
  doublereal *bp; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublereal *ap_out__;
  VALUE rblapack_bp_out__;
  doublereal *bp_out__;
  doublereal *work;

  integer ldap;
  integer n;
  integer ldz;

  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  w, z, info, ap, bp = NumRu::Lapack.dspgv( itype, jobz, uplo, ap, bp, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSPGV computes all the eigenvalues and, optionally, the eigenvectors\n*  of a real generalized symmetric-definite eigenproblem, of the form\n*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.\n*  Here A and B are assumed to be symmetric, stored in packed format,\n*  and B is also positive definite.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          Specifies the problem type to be solved:\n*          = 1:  A*x = (lambda)*B*x\n*          = 2:  A*B*x = (lambda)*x\n*          = 3:  B*A*x = (lambda)*x\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  AP      (input/output) DOUBLE PRECISION array, dimension\n*                            (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, the contents of AP are destroyed.\n*\n*  BP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          B, packed columnwise in a linear array.  The j-th column of B\n*          is stored in the array BP as follows:\n*          if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n*          if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n*          On exit, the triangular factor U or L from the Cholesky\n*          factorization B = U**T*U or B = L*L**T, in the same storage\n*          format as B.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n*          eigenvectors.  The eigenvectors are normalized as follows:\n*          if ITYPE = 1 or 2, Z**T*B*Z = I;\n*          if ITYPE = 3, Z**T*inv(B)*Z = I.\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  DPPTRF or DSPEV returned an error code:\n*             <= N:  if INFO = i, DSPEV failed to converge;\n*                    i off-diagonal elements of an intermediate\n*                    tridiagonal form did not converge to zero.\n*             > N:   if INFO = n + i, for 1 <= i <= n, then the leading\n*                    minor of order i of B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            UPPER, WANTZ\n      CHARACTER          TRANS\n      INTEGER            J, NEIG\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DPPTRF, DSPEV, DSPGST, DTPMV, DTPSV, XERBLA\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, info, ap, bp = NumRu::Lapack.dspgv( itype, jobz, uplo, ap, bp, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_itype = argv[0];
  rblapack_jobz = argv[1];
  rblapack_uplo = argv[2];
  rblapack_ap = argv[3];
  rblapack_bp = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  itype = NUM2INT(rblapack_itype);
  uplo = StringValueCStr(rblapack_uplo)[0];
  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  if (!NA_IsNArray(rblapack_bp))
    rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
  if (NA_RANK(rblapack_bp) != 1)
    rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_bp) != NA_DFLOAT)
    rblapack_bp = na_change_type(rblapack_bp, NA_DFLOAT);
  bp = NA_PTR_TYPE(rblapack_bp, doublereal*);
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
  MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_bp_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  bp_out__ = NA_PTR_TYPE(rblapack_bp_out__, doublereal*);
  MEMCPY(bp_out__, bp, doublereal, NA_TOTAL(rblapack_bp));
  rblapack_bp = rblapack_bp_out__;
  bp = bp_out__;
  work = ALLOC_N(doublereal, (3*n));

  dspgv_(&itype, &jobz, &uplo, &n, ap, bp, w, z, &ldz, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_w, rblapack_z, rblapack_info, rblapack_ap, rblapack_bp);
}

void
init_lapack_dspgv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dspgv", rblapack_dspgv, -1);
}
ruby-lapack-1.7.2/ext/sgbsvxx.c0000644000175000017500000007334212502221023016235 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgbsvxx_(char* fact, char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, real* ab, integer* ldab, real* afb, integer* ldafb, integer* ipiv, char* equed, real* r, real* c, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* rpvgrw, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, real* work, integer* iwork, integer* info);


static VALUE
rblapack_sgbsvxx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_afb;
  real *afb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_r;
  real *r; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_params;
  real *params; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_rpvgrw;
  real rpvgrw; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_err_bnds_norm;
  real *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  real *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  real *ab_out__;
  VALUE rblapack_afb_out__;
  real *afb_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  VALUE rblapack_r_out__;
  real *r_out__;
  VALUE rblapack_c_out__;
  real *c_out__;
  VALUE rblapack_b_out__;
  real *b_out__;
  VALUE rblapack_params_out__;
  real *params_out__;
  real *work;
  integer *iwork;

  integer ldab;
  integer n;
  integer ldafb;
  integer ldb;
  integer nrhs;
  integer nparams;
  integer ldx;
  integer n_err_bnds;

  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  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, ab, afb, ipiv, equed, r, c, b, params = NumRu::Lapack.sgbsvxx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     SGBSVXX uses the LU factorization to compute the solution to a\n*     real system of linear equations  A * X = B,  where A is an\n*     N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n*     If requested, both normwise and maximum componentwise error bounds\n*     are returned. SGBSVXX will return a solution with a tiny\n*     guaranteed error (O(eps) where eps is the working machine\n*     precision) unless the matrix is very ill-conditioned, in which\n*     case a warning is returned. Relevant condition numbers also are\n*     calculated and returned.\n*\n*     SGBSVXX accepts user-provided factorizations and equilibration\n*     factors; see the definitions of the FACT and EQUED options.\n*     Solving with refinement and using a factorization from a previous\n*     SGBSVXX call will also produce a solution with either O(eps)\n*     errors or warnings, but we cannot make that claim for general\n*     user-provided factorizations and equilibration factors if they\n*     differ from what SGBSVXX would itself produce.\n*\n*     Description\n*     ===========\n*\n*     The following steps are performed:\n*\n*     1. If FACT = 'E', real scaling factors are computed to equilibrate\n*     the system:\n*\n*       TRANS = 'N':  diag(R)*A*diag(C)     *inv(diag(C))*X = diag(R)*B\n*       TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n*       TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n*     or diag(C)*B (if TRANS = 'T' or 'C').\n*\n*     2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n*     the matrix A (after equilibration if FACT = 'E') as\n*\n*       A = P * L * U,\n*\n*     where P is a permutation matrix, L is a unit lower triangular\n*     matrix, and U is upper triangular.\n*\n*     3. If some U(i,i)=0, so that U is exactly singular, then the\n*     routine returns with INFO = i. Otherwise, the factored form of A\n*     is used to estimate the condition number of the matrix A (see\n*     argument RCOND). If the reciprocal of the condition number is less\n*     than machine precision, the routine still goes on to solve for X\n*     and compute error bounds as described below.\n*\n*     4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*     5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n*     the routine will use iterative refinement to try to get a small\n*     error and error bounds.  Refinement calculates the residual to at\n*     least twice the working precision.\n*\n*     6. If equilibration was used, the matrix X is premultiplied by\n*     diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n*     that it solves the original system before equilibration.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     FACT    (input) CHARACTER*1\n*     Specifies whether or not the factored form of the matrix A is\n*     supplied on entry, and if not, whether the matrix A should be\n*     equilibrated before it is factored.\n*       = 'F':  On entry, AF and IPIV contain the factored form of A.\n*               If EQUED is not 'N', the matrix A has been\n*               equilibrated with scaling factors given by R and C.\n*               A, AF, and IPIV are not modified.\n*       = 'N':  The matrix A will be copied to AF and factored.\n*       = 'E':  The matrix A will be equilibrated if necessary, then\n*               copied to AF and factored.\n*\n*     TRANS   (input) CHARACTER*1\n*     Specifies the form of the system of equations:\n*       = 'N':  A * X = B     (No transpose)\n*       = 'T':  A**T * X = B  (Transpose)\n*       = 'C':  A**H * X = B  (Conjugate Transpose = Transpose)\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     KL      (input) INTEGER\n*     The number of subdiagonals within the band of A.  KL >= 0.\n*\n*     KU      (input) INTEGER\n*     The number of superdiagonals within the band of A.  KU >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     AB      (input/output) REAL array, dimension (LDAB,N)\n*     On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n*     The j-th column of A is stored in the j-th column of the\n*     array AB as follows:\n*     AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n*     If FACT = 'F' and EQUED is not 'N', then AB must have been\n*     equilibrated by the scaling factors in R and/or C.  AB is not\n*     modified if FACT = 'F' or 'N', or if FACT = 'E' and\n*     EQUED = 'N' on exit.\n*\n*     On exit, if EQUED .ne. 'N', A is scaled as follows:\n*     EQUED = 'R':  A := diag(R) * A\n*     EQUED = 'C':  A := A * diag(C)\n*     EQUED = 'B':  A := diag(R) * A * diag(C).\n*\n*     LDAB    (input) INTEGER\n*     The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*     AFB     (input or output) REAL array, dimension (LDAFB,N)\n*     If FACT = 'F', then AFB is an input argument and on entry\n*     contains details of the LU factorization of the band matrix\n*     A, as computed by SGBTRF.  U is stored as an upper triangular\n*     band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n*     and the multipliers used during the factorization are stored\n*     in rows KL+KU+2 to 2*KL+KU+1.  If EQUED .ne. 'N', then AFB is\n*     the factored form of the equilibrated matrix A.\n*\n*     If FACT = 'N', then AF is an output argument and on exit\n*     returns the factors L and U from the factorization A = P*L*U\n*     of the original matrix A.\n*\n*     If FACT = 'E', then AF is an output argument and on exit\n*     returns the factors L and U from the factorization A = P*L*U\n*     of the equilibrated matrix A (see the description of A for\n*     the form of the equilibrated matrix).\n*\n*     LDAFB   (input) INTEGER\n*     The leading dimension of the array AFB.  LDAFB >= 2*KL+KU+1.\n*\n*     IPIV    (input or output) INTEGER array, dimension (N)\n*     If FACT = 'F', then IPIV is an input argument and on entry\n*     contains the pivot indices from the factorization A = P*L*U\n*     as computed by SGETRF; row i of the matrix was interchanged\n*     with row IPIV(i).\n*\n*     If FACT = 'N', then IPIV is an output argument and on exit\n*     contains the pivot indices from the factorization A = P*L*U\n*     of the original matrix A.\n*\n*     If FACT = 'E', then IPIV is an output argument and on exit\n*     contains the pivot indices from the factorization A = P*L*U\n*     of the equilibrated matrix A.\n*\n*     EQUED   (input or output) CHARACTER*1\n*     Specifies the form of equilibration that was done.\n*       = 'N':  No equilibration (always true if FACT = 'N').\n*       = 'R':  Row equilibration, i.e., A has been premultiplied by\n*               diag(R).\n*       = 'C':  Column equilibration, i.e., A has been postmultiplied\n*               by diag(C).\n*       = 'B':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(R) * A * diag(C).\n*     EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*     output argument.\n*\n*     R       (input or output) REAL array, dimension (N)\n*     The row scale factors for A.  If EQUED = 'R' or 'B', A is\n*     multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n*     is not accessed.  R is an input argument if FACT = 'F';\n*     otherwise, R is an output argument.  If FACT = 'F' and\n*     EQUED = 'R' or 'B', each element of R must be positive.\n*     If R is output, each element of R is a power of the radix.\n*     If R is input, each element of R should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     C       (input or output) REAL array, dimension (N)\n*     The column scale factors for A.  If EQUED = 'C' or 'B', A is\n*     multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n*     is not accessed.  C is an input argument if FACT = 'F';\n*     otherwise, C is an output argument.  If FACT = 'F' and\n*     EQUED = 'C' or 'B', each element of C must be positive.\n*     If C is output, each element of C is a power of the radix.\n*     If C is input, each element of C should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B       (input/output) REAL array, dimension (LDB,NRHS)\n*     On entry, the N-by-NRHS right hand side matrix B.\n*     On exit,\n*     if EQUED = 'N', B is not modified;\n*     if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n*        diag(R)*B;\n*     if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n*        overwritten by diag(C)*B.\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (output) REAL array, dimension (LDX,NRHS)\n*     If INFO = 0, the N-by-NRHS solution matrix X to the original\n*     system of equations.  Note that A and B are modified on exit\n*     if EQUED .ne. 'N', and the solution to the equilibrated system is\n*     inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n*     inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) REAL\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     RPVGRW  (output) REAL\n*     Reciprocal pivot growth.  On exit, this contains the reciprocal\n*     pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n*     norm is used.  If this is much less than 1, then the stability of\n*     the LU factorization of the (equilibrated) matrix A could be poor.\n*     This also means that the solution X, estimated condition numbers,\n*     and error bounds could be unreliable. If factorization fails with\n*     0 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, ab, afb, ipiv, equed, r, c, b, params = NumRu::Lapack.sgbsvxx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_fact = argv[0];
  rblapack_trans = argv[1];
  rblapack_kl = argv[2];
  rblapack_ku = argv[3];
  rblapack_ab = argv[4];
  rblapack_afb = argv[5];
  rblapack_ipiv = argv[6];
  rblapack_equed = argv[7];
  rblapack_r = argv[8];
  rblapack_c = argv[9];
  rblapack_b = argv[10];
  rblapack_params = argv[11];
  if (argc == 12) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_r))
    rb_raise(rb_eArgError, "r (9th argument) must be NArray");
  if (NA_RANK(rblapack_r) != 1)
    rb_raise(rb_eArgError, "rank of r (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_r) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_r) != NA_SFLOAT)
    rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
  r = NA_PTR_TYPE(rblapack_r, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (11th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (11th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  n_err_bnds = 3;
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
  ldafb = NA_SHAPE0(rblapack_afb);
  if (NA_SHAPE1(rblapack_afb) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_afb) != NA_SFLOAT)
    rblapack_afb = na_change_type(rblapack_afb, NA_SFLOAT);
  afb = NA_PTR_TYPE(rblapack_afb, real*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (10th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (10th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  ldx = MAX(1,n);
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (12th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (12th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_SFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
  params = NA_PTR_TYPE(rblapack_params, real*);
  equed = StringValueCStr(rblapack_equed)[0];
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
  MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldafb;
    shape[1] = n;
    rblapack_afb_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  afb_out__ = NA_PTR_TYPE(rblapack_afb_out__, real*);
  MEMCPY(afb_out__, afb, real, NA_TOTAL(rblapack_afb));
  rblapack_afb = rblapack_afb_out__;
  afb = afb_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_r_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  r_out__ = NA_PTR_TYPE(rblapack_r_out__, real*);
  MEMCPY(r_out__, r, real, NA_TOTAL(rblapack_r));
  rblapack_r = rblapack_r_out__;
  r = r_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
  MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(real, (4*n));
  iwork = ALLOC_N(integer, (n));

  sgbsvxx_(&fact, &trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_rpvgrw = rb_float_new((double)rpvgrw);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(15, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_ab, rblapack_afb, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b, rblapack_params);
}

void
init_lapack_sgbsvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgbsvxx", rblapack_sgbsvxx, -1);
}
ruby-lapack-1.7.2/ext/dsbev.c0000644000175000017500000001353712502221017015637 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsbev_(char* jobz, char* uplo, integer* n, integer* kd, doublereal* ab, integer* ldab, doublereal* w, doublereal* z, integer* ldz, doublereal* work, integer* info);


static VALUE
rblapack_dsbev(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublereal *ab_out__;
  doublereal *work;

  integer ldab;
  integer n;
  integer ldz;

  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  w, z, info, ab = NumRu::Lapack.dsbev( jobz, uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSBEV computes all the eigenvalues and, optionally, eigenvectors of\n*  a real symmetric band matrix A.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB, N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*          On exit, AB is overwritten by values generated during the\n*          reduction to tridiagonal form.  If UPLO = 'U', the first\n*          superdiagonal and the diagonal of the tridiagonal matrix T\n*          are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n*          the diagonal and first subdiagonal of T are returned in the\n*          first two rows of AB.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD + 1.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n*          eigenvectors of the matrix A, with the i-th column of Z\n*          holding the eigenvector associated with W(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (max(1,3*N-2))\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 algorithm failed to converge; i\n*                off-diagonal elements of an intermediate tridiagonal\n*                form did not converge to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, info, ab = NumRu::Lapack.dsbev( jobz, uplo, kd, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_kd = argv[2];
  rblapack_ab = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  kd = NUM2INT(rblapack_kd);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
  MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  work = ALLOC_N(doublereal, (MAX(1,3*n-2)));

  dsbev_(&jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_w, rblapack_z, rblapack_info, rblapack_ab);
}

void
init_lapack_dsbev(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsbev", rblapack_dsbev, -1);
}
ruby-lapack-1.7.2/ext/chegvd.c0000644000175000017500000003056112502221025015767 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chegvd_(integer* itype, char* jobz, char* uplo, integer* n, complex* a, integer* lda, complex* b, integer* ldb, real* w, complex* work, integer* lwork, real* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_chegvd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_lrwork;
  integer lrwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_rwork;
  real *rwork; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer lda;
  integer n;
  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  w, work, rwork, iwork, info, a, b = NumRu::Lapack.chegvd( itype, jobz, uplo, a, b, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHEGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHEGVD computes all the eigenvalues, and optionally, the eigenvectors\n*  of a complex generalized Hermitian-definite eigenproblem, of the form\n*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A and\n*  B are assumed to be Hermitian and B is also positive definite.\n*  If eigenvectors are desired, it uses a divide and conquer algorithm.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          Specifies the problem type to be solved:\n*          = 1:  A*x = (lambda)*B*x\n*          = 2:  A*B*x = (lambda)*x\n*          = 3:  B*A*x = (lambda)*x\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA, N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of A contains the\n*          upper triangular part of the matrix A.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of A contains\n*          the lower triangular part of the matrix A.\n*\n*          On exit, if JOBZ = 'V', then if INFO = 0, A contains the\n*          matrix Z of eigenvectors.  The eigenvectors are normalized\n*          as follows:\n*          if ITYPE = 1 or 2, Z**H*B*Z = I;\n*          if ITYPE = 3, Z**H*inv(B)*Z = I.\n*          If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')\n*          or the lower triangle (if UPLO='L') of A, including the\n*          diagonal, is destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX array, dimension (LDB, N)\n*          On entry, the Hermitian matrix B.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of B contains the\n*          upper triangular part of the matrix B.  If UPLO = 'L',\n*          the leading N-by-N lower triangular part of B contains\n*          the lower triangular part of the matrix B.\n*\n*          On exit, if INFO <= N, the part of B containing the matrix is\n*          overwritten by the triangular factor U or L from the Cholesky\n*          factorization B = U**H*U or B = L*L**H.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  W       (output) REAL array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  WORK    (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of the array WORK.\n*          If N <= 1,                LWORK >= 1.\n*          If JOBZ  = 'N' and N > 1, LWORK >= N + 1.\n*          If JOBZ  = 'V' and N > 1, LWORK >= 2*N + N**2.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal sizes of the WORK, RWORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  RWORK   (workspace/output) REAL array, dimension (MAX(1,LRWORK))\n*          On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.\n*\n*  LRWORK  (input) INTEGER\n*          The dimension of the array RWORK.\n*          If N <= 1,                LRWORK >= 1.\n*          If JOBZ  = 'N' and N > 1, LRWORK >= N.\n*          If JOBZ  = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.\n*\n*          If LRWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.\n*          If N <= 1,                LIWORK >= 1.\n*          If JOBZ  = 'N' and N > 1, LIWORK >= 1.\n*          If JOBZ  = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK 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:  CPOTRF or CHEEVD returned an error code:\n*             <= N:  if INFO = i and JOBZ = 'N', then the algorithm\n*                    failed to converge; i off-diagonal elements of an\n*                    intermediate tridiagonal form did not converge to\n*                    zero;\n*                    if INFO = i and JOBZ = 'V', then the algorithm\n*                    failed to compute an eigenvalue while working on\n*                    the submatrix lying in rows and columns INFO/(N+1)\n*                    through mod(INFO,N+1);\n*             > N:   if INFO = N + i, for 1 <= i <= N, then the leading\n*                    minor of order i of B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n*  Modified so that no backsubstitution is performed if CHEEVD fails to\n*  converge (NEIG in old code could be greater than N causing out of\n*  bounds reference to A - reported by Ralf Meyer).  Also corrected the\n*  description of INFO and the test on ITYPE. Sven, 16 Feb 05.\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, work, rwork, iwork, info, a, b = NumRu::Lapack.chegvd( itype, jobz, uplo, a, b, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_itype = argv[0];
  rblapack_jobz = argv[1];
  rblapack_uplo = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  if (argc == 8) {
    rblapack_lwork = argv[5];
    rblapack_lrwork = argv[6];
    rblapack_liwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_lrwork = Qnil;
    rblapack_liwork = Qnil;
  }

  itype = NUM2INT(rblapack_itype);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (rblapack_lrwork == Qnil)
    lrwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
  else {
    lrwork = NUM2INT(rblapack_lrwork);
  }
  if (rblapack_lwork == Qnil)
    lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n+1 : lsame_(&jobz,"V") ? 2*n+n*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (rblapack_liwork == Qnil)
    liwork = n<=1 ? 1 : lsame_(&jobz,"N") ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lrwork);
    rblapack_rwork = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  rwork = NA_PTR_TYPE(rblapack_rwork, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  chegvd_(&itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_w, rblapack_work, rblapack_rwork, rblapack_iwork, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_chegvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chegvd", rblapack_chegvd, -1);
}
ruby-lapack-1.7.2/ext/dsteqr.c0000644000175000017500000001550712502221023016032 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsteqr_(char* compz, integer* n, doublereal* d, doublereal* e, doublereal* z, integer* ldz, doublereal* work, integer* info);


static VALUE
rblapack_dsteqr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_compz;
  char compz; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_e_out__;
  doublereal *e_out__;
  VALUE rblapack_z_out__;
  doublereal *z_out__;
  doublereal *work;

  integer n;
  integer ldz;

  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  info, d, e, z = NumRu::Lapack.dsteqr( compz, d, e, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSTEQR computes all eigenvalues and, optionally, eigenvectors of a\n*  symmetric tridiagonal matrix using the implicit QL or QR method.\n*  The eigenvectors of a full or band symmetric matrix can also be found\n*  if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to\n*  tridiagonal form.\n*\n\n*  Arguments\n*  =========\n*\n*  COMPZ   (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only.\n*          = 'V':  Compute eigenvalues and eigenvectors of the original\n*                  symmetric matrix.  On entry, Z must contain the\n*                  orthogonal matrix used to reduce the original matrix\n*                  to tridiagonal form.\n*          = 'I':  Compute eigenvalues and eigenvectors of the\n*                  tridiagonal matrix.  Z is initialized to the identity\n*                  matrix.\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the diagonal elements of the tridiagonal matrix.\n*          On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n*  E       (input/output) DOUBLE PRECISION array, dimension (N-1)\n*          On entry, the (n-1) subdiagonal elements of the tridiagonal\n*          matrix.\n*          On exit, E has been destroyed.\n*\n*  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ, N)\n*          On entry, if  COMPZ = 'V', then Z contains the orthogonal\n*          matrix used in the reduction to tridiagonal form.\n*          On exit, if INFO = 0, then if  COMPZ = 'V', Z contains the\n*          orthonormal eigenvectors of the original symmetric matrix,\n*          and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n*          of the symmetric tridiagonal matrix.\n*          If COMPZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          eigenvectors are desired, then  LDZ >= max(1,N).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))\n*          If COMPZ = 'N', then WORK is not referenced.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  the algorithm has failed to find all the eigenvalues in\n*                a total of 30*N iterations; if INFO = i, then i\n*                elements of E have not converged to zero; on exit, D\n*                and E contain the elements of a symmetric tridiagonal\n*                matrix which is orthogonally similar to the original\n*                matrix.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, e, z = NumRu::Lapack.dsteqr( compz, d, e, z, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_compz = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  rblapack_z = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  compz = StringValueCStr(rblapack_compz)[0];
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (4th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  n = NA_SHAPE1(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of z");
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
  MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
  MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  work = ALLOC_N(doublereal, (lsame_(&compz,"N") ? 0 : MAX(1,2*n-2)));

  dsteqr_(&compz, &n, d, e, z, &ldz, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_info, rblapack_d, rblapack_e, rblapack_z);
}

void
init_lapack_dsteqr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsteqr", rblapack_dsteqr, -1);
}
ruby-lapack-1.7.2/ext/zunml2.c0000644000175000017500000001424512502221015015756 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zunml2_(char* side, char* trans, integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* c, integer* ldc, doublecomplex* work, integer* info);


static VALUE
rblapack_zunml2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_c;
  doublecomplex *c; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublecomplex *c_out__;
  doublecomplex *work;

  integer lda;
  integer m;
  integer k;
  integer ldc;
  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  info, c = NumRu::Lapack.zunml2( side, trans, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZUNML2 overwrites the general complex m-by-n matrix C with\n*\n*        Q * C  if SIDE = 'L' and TRANS = 'N', or\n*\n*        Q'* C  if SIDE = 'L' and TRANS = 'C', or\n*\n*        C * Q  if SIDE = 'R' and TRANS = 'N', or\n*\n*        C * Q' if SIDE = 'R' and TRANS = 'C',\n*\n*  where Q is a complex unitary matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(k)' . . . H(2)' H(1)'\n*\n*  as returned by ZGELQF. Q is of order m if SIDE = 'L' and of order n\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q' from the Left\n*          = 'R': apply Q or Q' from the Right\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': apply Q  (No transpose)\n*          = 'C': apply Q' (Conjugate transpose)\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension\n*                               (LDA,M) if SIDE = 'L',\n*                               (LDA,N) if SIDE = 'R'\n*          The i-th row must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          ZGELQF in the first k rows of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,K).\n*\n*  TAU     (input) COMPLEX*16 array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by ZGELQF.\n*\n*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)\n*          On entry, the m-by-n matrix C.\n*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension\n*                                   (N) if SIDE = 'L',\n*                                   (M) if SIDE = 'R'\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, c = NumRu::Lapack.zunml2( side, trans, a, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_a = argv[2];
  rblapack_tau = argv[3];
  rblapack_c = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
  MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(doublecomplex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  zunml2_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_c);
}

void
init_lapack_zunml2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zunml2", rblapack_zunml2, -1);
}
ruby-lapack-1.7.2/ext/zlarfb.c0000644000175000017500000001522112502221024016002 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlarfb_(char* side, char* trans, char* direct, char* storev, integer* m, integer* n, integer* k, doublecomplex* v, integer* ldv, doublecomplex* t, integer* ldt, doublecomplex* c, integer* ldc, doublecomplex* work, integer* ldwork);


static VALUE
rblapack_zlarfb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_direct;
  char direct; 
  VALUE rblapack_storev;
  char storev; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_v;
  doublecomplex *v; 
  VALUE rblapack_t;
  doublecomplex *t; 
  VALUE rblapack_c;
  doublecomplex *c; 
  VALUE rblapack_c_out__;
  doublecomplex *c_out__;
  doublecomplex *work;

  integer ldv;
  integer k;
  integer ldt;
  integer ldc;
  integer n;
  integer ldwork;

  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  c = NumRu::Lapack.zlarfb( side, trans, direct, storev, m, v, t, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, T, LDT, C, LDC, WORK, LDWORK )\n\n*  Purpose\n*  =======\n*\n*  ZLARFB applies a complex block reflector H or its transpose H' to a\n*  complex M-by-N matrix C, from either the left or the right.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply H or H' from the Left\n*          = 'R': apply H or H' from the Right\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': apply H (No transpose)\n*          = 'C': apply H' (Conjugate transpose)\n*\n*  DIRECT  (input) CHARACTER*1\n*          Indicates how H is formed from a product of elementary\n*          reflectors\n*          = 'F': H = H(1) H(2) . . . H(k) (Forward)\n*          = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n*  STOREV  (input) CHARACTER*1\n*          Indicates how the vectors which define the elementary\n*          reflectors are stored:\n*          = 'C': Columnwise\n*          = 'R': Rowwise\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C.\n*\n*  K       (input) INTEGER\n*          The order of the matrix T (= the number of elementary\n*          reflectors whose product defines the block reflector).\n*\n*  V       (input) COMPLEX*16 array, dimension\n*                                (LDV,K) if STOREV = 'C'\n*                                (LDV,M) if STOREV = 'R' and SIDE = 'L'\n*                                (LDV,N) if STOREV = 'R' and SIDE = 'R'\n*          The matrix V. See further details.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V.\n*          If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);\n*          if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);\n*          if STOREV = 'R', LDV >= K.\n*\n*  T       (input) COMPLEX*16 array, dimension (LDT,K)\n*          The triangular K-by-K matrix T in the representation of the\n*          block reflector.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= K.\n*\n*  C       (input/output) COMPLEX*16 array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by H*C or H'*C or C*H or C*H'.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (LDWORK,K)\n*\n*  LDWORK  (input) INTEGER\n*          The leading dimension of the array WORK.\n*          If SIDE = 'L', LDWORK >= max(1,N);\n*          if SIDE = 'R', LDWORK >= max(1,M).\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c = NumRu::Lapack.zlarfb( side, trans, direct, storev, m, v, t, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_direct = argv[2];
  rblapack_storev = argv[3];
  rblapack_m = argv[4];
  rblapack_v = argv[5];
  rblapack_t = argv[6];
  rblapack_c = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  direct = StringValueCStr(rblapack_direct)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (7th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (7th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  k = NA_SHAPE1(rblapack_t);
  if (NA_TYPE(rblapack_t) != NA_DCOMPLEX)
    rblapack_t = na_change_type(rblapack_t, NA_DCOMPLEX);
  t = NA_PTR_TYPE(rblapack_t, doublecomplex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (6th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (6th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  if (NA_SHAPE1(rblapack_v) != k)
    rb_raise(rb_eRuntimeError, "shape 1 of v must be the same as shape 1 of t");
  if (NA_TYPE(rblapack_v) != NA_DCOMPLEX)
    rblapack_v = na_change_type(rblapack_v, NA_DCOMPLEX);
  v = NA_PTR_TYPE(rblapack_v, doublecomplex*);
  storev = StringValueCStr(rblapack_storev)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (8th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_DCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, doublecomplex*);
  ldwork = MAX(1,n) ? side = 'l' : MAX(1,m) ? side = 'r' : 0;
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublecomplex*);
  MEMCPY(c_out__, c, doublecomplex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(doublecomplex, (ldwork)*(k));

  zlarfb_(&side, &trans, &direct, &storev, &m, &n, &k, v, &ldv, t, &ldt, c, &ldc, work, &ldwork);

  free(work);
  return rblapack_c;
}

void
init_lapack_zlarfb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlarfb", rblapack_zlarfb, -1);
}
ruby-lapack-1.7.2/ext/slatrs.c0000644000175000017500000002451512502221016016041 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slatrs_(char* uplo, char* trans, char* diag, char* normin, integer* n, real* a, integer* lda, real* x, real* scale, real* cnorm, integer* info);


static VALUE
rblapack_slatrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_normin;
  char normin; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_cnorm;
  real *cnorm; 
  VALUE rblapack_scale;
  real scale; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  real *x_out__;
  VALUE rblapack_cnorm_out__;
  real *cnorm_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  scale, info, x, cnorm = NumRu::Lapack.slatrs( uplo, trans, diag, normin, a, x, cnorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, CNORM, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLATRS solves one of the triangular systems\n*\n*     A *x = s*b  or  A'*x = s*b\n*\n*  with scaling to prevent overflow.  Here A is an upper or lower\n*  triangular matrix, A' denotes the transpose of A, x and b are\n*  n-element vectors, and s is a scaling factor, usually less than\n*  or equal to 1, chosen so that the components of x will be less than\n*  the overflow threshold.  If the unscaled problem will not cause\n*  overflow, the Level 2 BLAS routine STRSV is called.  If the matrix A\n*  is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n*  non-trivial solution to A*x = 0 is returned.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the matrix A is upper or lower triangular.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the operation applied to A.\n*          = 'N':  Solve A * x = s*b  (No transpose)\n*          = 'T':  Solve A'* x = s*b  (Transpose)\n*          = 'C':  Solve A'* x = s*b  (Conjugate transpose = Transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          Specifies whether or not the matrix A is unit triangular.\n*          = 'N':  Non-unit triangular\n*          = 'U':  Unit triangular\n*\n*  NORMIN  (input) CHARACTER*1\n*          Specifies whether CNORM has been set or not.\n*          = 'Y':  CNORM contains the column norms on entry\n*          = 'N':  CNORM is not set on entry.  On exit, the norms will\n*                  be computed and stored in CNORM.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) REAL array, dimension (LDA,N)\n*          The triangular matrix A.  If UPLO = 'U', the leading n by n\n*          upper triangular part of the array A contains the upper\n*          triangular matrix, and the strictly lower triangular part of\n*          A is not referenced.  If UPLO = 'L', the leading n by n lower\n*          triangular part of the array A contains the lower triangular\n*          matrix, and the strictly upper triangular part of A is not\n*          referenced.  If DIAG = 'U', the diagonal elements of A are\n*          also not referenced and are assumed to be 1.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max (1,N).\n*\n*  X       (input/output) REAL array, dimension (N)\n*          On entry, the right hand side b of the triangular system.\n*          On exit, X is overwritten by the solution vector x.\n*\n*  SCALE   (output) REAL\n*          The scaling factor s for the triangular system\n*             A * x = s*b  or  A'* x = s*b.\n*          If SCALE = 0, the matrix A is singular or badly scaled, and\n*          the vector x is an exact or approximate solution to A*x = 0.\n*\n*  CNORM   (input or output) REAL array, dimension (N)\n*\n*          If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n*          contains the norm of the off-diagonal part of the j-th column\n*          of A.  If TRANS = 'N', CNORM(j) must be greater than or equal\n*          to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n*          must be greater than or equal to the 1-norm.\n*\n*          If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n*          returns the 1-norm of the offdiagonal part of the j-th column\n*          of A.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -k, the k-th argument had an illegal value\n*\n\n*  Further Details\n*  ======= =======\n*\n*  A rough bound on x is computed; if that is less than overflow, STRSV\n*  is called, otherwise, specific code is used which checks for possible\n*  overflow or divide-by-zero at every operation.\n*\n*  A columnwise scheme is used for solving A*x = b.  The basic algorithm\n*  if A is lower triangular is\n*\n*       x[1:n] := b[1:n]\n*       for j = 1, ..., n\n*            x(j) := x(j) / A(j,j)\n*            x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n*       end\n*\n*  Define bounds on the components of x after j iterations of the loop:\n*     M(j) = bound on x[1:j]\n*     G(j) = bound on x[j+1:n]\n*  Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n*  Then for iteration j+1 we have\n*     M(j+1) <= G(j) / | A(j+1,j+1) |\n*     G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n*            <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n*  where CNORM(j+1) is greater than or equal to the infinity-norm of\n*  column j+1 of A, not counting the diagonal.  Hence\n*\n*     G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n*                  1<=i<=j\n*  and\n*\n*     |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n*                                   1<=i< j\n*\n*  Since |x(j)| <= M(j), we use the Level 2 BLAS routine STRSV if the\n*  reciprocal of the largest M(j), j=1,..,n, is larger than\n*  max(underflow, 1/overflow).\n*\n*  The bound on x(j) is also used to determine when a step in the\n*  columnwise method can be performed without fear of overflow.  If\n*  the computed bound is greater than a large constant, x is scaled to\n*  prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n*  1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n*  Similarly, a row-wise scheme is used to solve A'*x = b.  The basic\n*  algorithm for A upper triangular is\n*\n*       for j = 1, ..., n\n*            x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n*       end\n*\n*  We simultaneously compute two bounds\n*       G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n*       M(j) = bound on x(i), 1<=i<=j\n*\n*  The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n*  add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n*  Then the bound on x(j) is\n*\n*       M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n*            <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n*                      1<=i<=j\n*\n*  and we can safely call STRSV if 1/M(n) and 1/G(n) are both greater\n*  than max(underflow, 1/overflow).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, info, x, cnorm = NumRu::Lapack.slatrs( uplo, trans, diag, normin, a, x, cnorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_normin = argv[3];
  rblapack_a = argv[4];
  rblapack_x = argv[5];
  rblapack_cnorm = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_cnorm))
    rb_raise(rb_eArgError, "cnorm (7th argument) must be NArray");
  if (NA_RANK(rblapack_cnorm) != 1)
    rb_raise(rb_eArgError, "rank of cnorm (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_cnorm) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of cnorm must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_cnorm) != NA_SFLOAT)
    rblapack_cnorm = na_change_type(rblapack_cnorm, NA_SFLOAT);
  cnorm = NA_PTR_TYPE(rblapack_cnorm, real*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  normin = StringValueCStr(rblapack_normin)[0];
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_cnorm_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  cnorm_out__ = NA_PTR_TYPE(rblapack_cnorm_out__, real*);
  MEMCPY(cnorm_out__, cnorm, real, NA_TOTAL(rblapack_cnorm));
  rblapack_cnorm = rblapack_cnorm_out__;
  cnorm = cnorm_out__;

  slatrs_(&uplo, &trans, &diag, &normin, &n, a, &lda, x, &scale, cnorm, &info);

  rblapack_scale = rb_float_new((double)scale);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_scale, rblapack_info, rblapack_x, rblapack_cnorm);
}

void
init_lapack_slatrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slatrs", rblapack_slatrs, -1);
}
ruby-lapack-1.7.2/ext/dsytrf.c0000644000175000017500000002017712502221017016045 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsytrf_(char* uplo, integer* n, doublereal* a, integer* lda, integer* ipiv, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dsytrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  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  ipiv, work, info, a = NumRu::Lapack.dsytrf( uplo, a, lwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSYTRF computes the factorization of a real symmetric matrix A using\n*  the Bunch-Kaufman diagonal pivoting method.  The form of the\n*  factorization is\n*\n*     A = U*D*U**T  or  A = L*D*L**T\n*\n*  where U (or L) is a product of permutation and unit upper (lower)\n*  triangular matrices, and D is symmetric and block diagonal with\n*  1-by-1 and 2-by-2 diagonal blocks.\n*\n*  This is the blocked version of the algorithm, calling Level 3 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L (see below for further details).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D.\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\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 length of WORK.  LWORK >=1.  For best performance\n*          LWORK >= N*NB, where NB is the block size returned by ILAENV.\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, D(i,i) is exactly zero.  The factorization\n*                has been completed, but the block diagonal matrix D is\n*                exactly singular, and division by zero will occur if it\n*                is used to solve a system of equations.\n*\n\n*  Further Details\n*  ===============\n*\n*  If UPLO = 'U', then A = U*D*U', where\n*     U = P(n)*U(n)* ... *P(k)U(k)* ...,\n*  i.e., U is a product of terms P(k)*U(k), where k decreases from n to\n*  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    v    0   )   k-s\n*     U(k) =  (   0    I    0   )   s\n*             (   0    0    I   )   n-k\n*                k-s   s   n-k\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).\n*  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),\n*  and A(k,k), and v overwrites A(1:k-2,k-1:k).\n*\n*  If UPLO = 'L', then A = L*D*L', where\n*     L = P(1)*L(1)* ... *P(k)*L(k)* ...,\n*  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to\n*  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1\n*  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as\n*  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such\n*  that if the diagonal block D(k) is of order s (s = 1 or 2), then\n*\n*             (   I    0     0   )  k-1\n*     L(k) =  (   0    I     0   )  s\n*             (   0    v     I   )  n-k-s+1\n*                k-1   s  n-k-s+1\n*\n*  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).\n*  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),\n*  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY, UPPER\n      INTEGER            IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      INTEGER            ILAENV\n      EXTERNAL           LSAME, ILAENV\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DLASYF, DSYTF2, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, work, info, a = NumRu::Lapack.dsytrf( uplo, a, lwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_lwork = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  lwork = NUM2INT(rblapack_lwork);
  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*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;

  dsytrf_(&uplo, &n, a, &lda, ipiv, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ipiv, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_dsytrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsytrf", rblapack_dsytrf, -1);
}
ruby-lapack-1.7.2/ext/sggevx.c0000644000175000017500000004452112502221025016033 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sggevx_(char* balanc, char* jobvl, char* jobvr, char* sense, integer* n, real* a, integer* lda, real* b, integer* ldb, real* alphar, real* alphai, real* beta, real* vl, integer* ldvl, real* vr, integer* ldvr, integer* ilo, integer* ihi, real* lscale, real* rscale, real* abnrm, real* bbnrm, real* rconde, real* rcondv, real* work, integer* lwork, integer* iwork, logical* bwork, integer* info);


static VALUE
rblapack_sggevx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_balanc;
  char balanc; 
  VALUE rblapack_jobvl;
  char jobvl; 
  VALUE rblapack_jobvr;
  char jobvr; 
  VALUE rblapack_sense;
  char sense; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_alphar;
  real *alphar; 
  VALUE rblapack_alphai;
  real *alphai; 
  VALUE rblapack_beta;
  real *beta; 
  VALUE rblapack_vl;
  real *vl; 
  VALUE rblapack_vr;
  real *vr; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_lscale;
  real *lscale; 
  VALUE rblapack_rscale;
  real *rscale; 
  VALUE rblapack_abnrm;
  real abnrm; 
  VALUE rblapack_bbnrm;
  real bbnrm; 
  VALUE rblapack_rconde;
  real *rconde; 
  VALUE rblapack_rcondv;
  real *rcondv; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_b_out__;
  real *b_out__;
  integer *iwork;
  logical *bwork;

  integer lda;
  integer n;
  integer ldb;
  integer ldvl;
  integer ldvr;

  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  alphar, alphai, beta, vl, vr, ilo, ihi, lscale, rscale, abnrm, bbnrm, rconde, rcondv, work, info, a, b = NumRu::Lapack.sggevx( balanc, jobvl, jobvr, sense, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, ILO, IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, WORK, LWORK, IWORK, BWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B)\n*  the generalized eigenvalues, and optionally, the left and/or right\n*  generalized eigenvectors.\n*\n*  Optionally also, it computes a balancing transformation to improve\n*  the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n*  LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for\n*  the eigenvalues (RCONDE), and reciprocal condition numbers for the\n*  right eigenvectors (RCONDV).\n*\n*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n*  lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n*  singular. It is usually represented as the pair (alpha,beta), as\n*  there is a reasonable interpretation for beta=0, and even for both\n*  being zero.\n*\n*  The right eigenvector v(j) corresponding to the eigenvalue lambda(j)\n*  of (A,B) satisfies\n*\n*                   A * v(j) = lambda(j) * B * v(j) .\n*\n*  The left eigenvector u(j) corresponding to the eigenvalue lambda(j)\n*  of (A,B) satisfies\n*\n*                   u(j)**H * A  = lambda(j) * u(j)**H * B.\n*\n*  where u(j)**H is the conjugate-transpose of u(j).\n*\n*\n\n*  Arguments\n*  =========\n*\n*  BALANC  (input) CHARACTER*1\n*          Specifies the balance option to be performed.\n*          = 'N':  do not diagonally scale or permute;\n*          = 'P':  permute only;\n*          = 'S':  scale only;\n*          = 'B':  both permute and scale.\n*          Computed reciprocal condition numbers will be for the\n*          matrices after permuting and/or balancing. Permuting does\n*          not change condition numbers (in exact arithmetic), but\n*          balancing does.\n*\n*  JOBVL   (input) CHARACTER*1\n*          = 'N':  do not compute the left generalized eigenvectors;\n*          = 'V':  compute the left generalized eigenvectors.\n*\n*  JOBVR   (input) CHARACTER*1\n*          = 'N':  do not compute the right generalized eigenvectors;\n*          = 'V':  compute the right generalized eigenvectors.\n*\n*  SENSE   (input) CHARACTER*1\n*          Determines which reciprocal condition numbers are computed.\n*          = 'N': none are computed;\n*          = 'E': computed for eigenvalues only;\n*          = 'V': computed for eigenvectors only;\n*          = 'B': computed for eigenvalues and eigenvectors.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A, B, VL, and VR.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA, N)\n*          On entry, the matrix A in the pair (A,B).\n*          On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'\n*          or both, then A contains the first part of the real Schur\n*          form of the \"balanced\" versions of the input A and B.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of A.  LDA >= max(1,N).\n*\n*  B       (input/output) REAL array, dimension (LDB, N)\n*          On entry, the matrix B in the pair (A,B).\n*          On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'\n*          or both, then B contains the second part of the real Schur\n*          form of the \"balanced\" versions of the input A and B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of B.  LDB >= max(1,N).\n*\n*  ALPHAR  (output) REAL array, dimension (N)\n*  ALPHAI  (output) REAL array, dimension (N)\n*  BETA    (output) REAL array, dimension (N)\n*          On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n*          be the generalized eigenvalues.  If ALPHAI(j) is zero, then\n*          the j-th eigenvalue is real; if positive, then the j-th and\n*          (j+1)-st eigenvalues are a complex conjugate pair, with\n*          ALPHAI(j+1) negative.\n*\n*          Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n*          may easily over- or underflow, and BETA(j) may even be zero.\n*          Thus, the user should avoid naively computing the ratio\n*          ALPHA/BETA. However, ALPHAR and ALPHAI will be always less\n*          than and usually comparable with norm(A) in magnitude, and\n*          BETA always less than and usually comparable with norm(B).\n*\n*  VL      (output) REAL array, dimension (LDVL,N)\n*          If JOBVL = 'V', the left eigenvectors u(j) are stored one\n*          after another in the columns of VL, in the same order as\n*          their eigenvalues. If the j-th eigenvalue is real, then\n*          u(j) = VL(:,j), the j-th column of VL. If the j-th and\n*          (j+1)-th eigenvalues form a complex conjugate pair, then\n*          u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).\n*          Each eigenvector will be scaled so the largest component have\n*          abs(real part) + abs(imag. part) = 1.\n*          Not referenced if JOBVL = 'N'.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the matrix VL. LDVL >= 1, and\n*          if JOBVL = 'V', LDVL >= N.\n*\n*  VR      (output) REAL array, dimension (LDVR,N)\n*          If JOBVR = 'V', the right eigenvectors v(j) are stored one\n*          after another in the columns of VR, in the same order as\n*          their eigenvalues. If the j-th eigenvalue is real, then\n*          v(j) = VR(:,j), the j-th column of VR. If the j-th and\n*          (j+1)-th eigenvalues form a complex conjugate pair, then\n*          v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).\n*          Each eigenvector will be scaled so the largest component have\n*          abs(real part) + abs(imag. part) = 1.\n*          Not referenced if JOBVR = 'N'.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the matrix VR. LDVR >= 1, and\n*          if JOBVR = 'V', LDVR >= N.\n*\n*  ILO     (output) INTEGER\n*  IHI     (output) INTEGER\n*          ILO and IHI are integer values such that on exit\n*          A(i,j) = 0 and B(i,j) = 0 if i > j and\n*          j = 1,...,ILO-1 or i = IHI+1,...,N.\n*          If BALANC = 'N' or 'S', ILO = 1 and IHI = N.\n*\n*  LSCALE  (output) REAL array, dimension (N)\n*          Details of the permutations and scaling factors applied\n*          to the left side of A and B.  If PL(j) is the index of the\n*          row interchanged with row j, and DL(j) is the scaling\n*          factor applied to row j, then\n*            LSCALE(j) = PL(j)  for j = 1,...,ILO-1\n*                      = DL(j)  for j = ILO,...,IHI\n*                      = PL(j)  for j = IHI+1,...,N.\n*          The order in which the interchanges are made is N to IHI+1,\n*          then 1 to ILO-1.\n*\n*  RSCALE  (output) REAL array, dimension (N)\n*          Details of the permutations and scaling factors applied\n*          to the right side of A and B.  If PR(j) is the index of the\n*          column interchanged with column j, and DR(j) is the scaling\n*          factor applied to column j, then\n*            RSCALE(j) = PR(j)  for j = 1,...,ILO-1\n*                      = DR(j)  for j = ILO,...,IHI\n*                      = PR(j)  for j = IHI+1,...,N\n*          The order in which the interchanges are made is N to IHI+1,\n*          then 1 to ILO-1.\n*\n*  ABNRM   (output) REAL\n*          The one-norm of the balanced matrix A.\n*\n*  BBNRM   (output) REAL\n*          The one-norm of the balanced matrix B.\n*\n*  RCONDE  (output) REAL array, dimension (N)\n*          If SENSE = 'E' or 'B', the reciprocal condition numbers of\n*          the eigenvalues, stored in consecutive elements of the array.\n*          For a complex conjugate pair of eigenvalues two consecutive\n*          elements of RCONDE are set to the same value. Thus RCONDE(j),\n*          RCONDV(j), and the j-th columns of VL and VR all correspond\n*          to the j-th eigenpair.\n*          If SENSE = 'N' or 'V', RCONDE is not referenced.\n*\n*  RCONDV  (output) REAL array, dimension (N)\n*          If SENSE = 'V' or 'B', the estimated reciprocal condition\n*          numbers of the eigenvectors, stored in consecutive elements\n*          of the array. For a complex eigenvector two consecutive\n*          elements of RCONDV are set to the same value. If the\n*          eigenvalues cannot be reordered to compute RCONDV(j),\n*          RCONDV(j) is set to 0; this can only occur when the true\n*          value would be very small anyway.\n*          If SENSE = 'N' or 'E', RCONDV is not referenced.\n*\n*  WORK    (workspace/output) REAL 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,2*N).\n*          If BALANC = 'S' or 'B', or JOBVL = 'V', or JOBVR = 'V',\n*          LWORK >= max(1,6*N).\n*          If SENSE = 'E', LWORK >= max(1,10*N).\n*          If SENSE = 'V' or 'B', LWORK >= 2*N*N+8*N+16.\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*  IWORK   (workspace) INTEGER array, dimension (N+6)\n*          If SENSE = 'E', IWORK is not referenced.\n*\n*  BWORK   (workspace) LOGICAL array, dimension (N)\n*          If SENSE = 'N', BWORK is not referenced.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          = 1,...,N:\n*                The QZ iteration failed.  No eigenvectors have been\n*                calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)\n*                should be correct for j=INFO+1,...,N.\n*          > N:  =N+1: other than QZ iteration failed in SHGEQZ.\n*                =N+2: error return from STGEVC.\n*\n\n*  Further Details\n*  ===============\n*\n*  Balancing a matrix pair (A,B) includes, first, permuting rows and\n*  columns to isolate eigenvalues, second, applying diagonal similarity\n*  transformation to the rows and columns to make the rows and columns\n*  as close in norm as possible. The computed reciprocal condition\n*  numbers correspond to the balanced matrix. Permuting rows and columns\n*  will not change the condition numbers (in exact arithmetic) but\n*  diagonal scaling will.  For further explanation of balancing, see\n*  section 4.11.1.2 of LAPACK Users' Guide.\n*\n*  An approximate error bound on the chordal distance between the i-th\n*  computed generalized eigenvalue w and the corresponding exact\n*  eigenvalue lambda is\n*\n*       chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)\n*\n*  An approximate error bound for the angle between the i-th computed\n*  eigenvector VL(i) or VR(i) is given by\n*\n*       EPS * norm(ABNRM, BBNRM) / DIF(i).\n*\n*  For further explanation of the reciprocal condition numbers RCONDE\n*  and RCONDV, see section 4.11 of LAPACK User's Guide.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  alphar, alphai, beta, vl, vr, ilo, ihi, lscale, rscale, abnrm, bbnrm, rconde, rcondv, work, info, a, b = NumRu::Lapack.sggevx( balanc, jobvl, jobvr, sense, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_balanc = argv[0];
  rblapack_jobvl = argv[1];
  rblapack_jobvr = argv[2];
  rblapack_sense = argv[3];
  rblapack_a = argv[4];
  rblapack_b = argv[5];
  if (argc == 7) {
    rblapack_lwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  balanc = StringValueCStr(rblapack_balanc)[0];
  jobvr = StringValueCStr(rblapack_jobvr)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  jobvl = StringValueCStr(rblapack_jobvl)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  ldvr = lsame_(&jobvr,"V") ? n : 1;
  sense = StringValueCStr(rblapack_sense)[0];
  ldvl = lsame_(&jobvl,"V") ? n : 1;
  if (rblapack_lwork == Qnil)
    lwork = (lsame_(&balanc,"S")||lsame_(&balanc,"B")||lsame_(&jobvl,"V")||lsame_(&jobvr,"V")) ? 6*n : lsame_(&sense,"E") ? 10*n : (lsame_(&sense,"V")||lsame_(&sense,"B")) ? 2*n*n+8*n+16 : 2*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  alphar = NA_PTR_TYPE(rblapack_alphar, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  alphai = NA_PTR_TYPE(rblapack_alphai, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = n;
    rblapack_vl = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vl = NA_PTR_TYPE(rblapack_vl, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = n;
    rblapack_vr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vr = NA_PTR_TYPE(rblapack_vr, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_lscale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  lscale = NA_PTR_TYPE(rblapack_lscale, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rscale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  rscale = NA_PTR_TYPE(rblapack_rscale, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rconde = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  rconde = NA_PTR_TYPE(rblapack_rconde, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rcondv = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  rcondv = NA_PTR_TYPE(rblapack_rcondv, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  iwork = ALLOC_N(integer, (lsame_(&sense,"E") ? 0 : n+6));
  bwork = ALLOC_N(logical, (lsame_(&sense,"N") ? 0 : n));

  sggevx_(&balanc, &jobvl, &jobvr, &sense, &n, a, &lda, b, &ldb, alphar, alphai, beta, vl, &ldvl, vr, &ldvr, &ilo, &ihi, lscale, rscale, &abnrm, &bbnrm, rconde, rcondv, work, &lwork, iwork, bwork, &info);

  free(iwork);
  free(bwork);
  rblapack_ilo = INT2NUM(ilo);
  rblapack_ihi = INT2NUM(ihi);
  rblapack_abnrm = rb_float_new((double)abnrm);
  rblapack_bbnrm = rb_float_new((double)bbnrm);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(17, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_vl, rblapack_vr, rblapack_ilo, rblapack_ihi, rblapack_lscale, rblapack_rscale, rblapack_abnrm, rblapack_bbnrm, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_sggevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sggevx", rblapack_sggevx, -1);
}
ruby-lapack-1.7.2/ext/zhetri.c0000644000175000017500000001134512502221026016034 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhetri_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* work, integer* info);


static VALUE
rblapack_zhetri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  doublecomplex *work;

  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  info, a = NumRu::Lapack.zhetri( uplo, a, ipiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHETRI( UPLO, N, A, LDA, IPIV, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHETRI computes the inverse of a complex Hermitian indefinite matrix\n*  A using the factorization A = U*D*U**H or A = L*D*L**H computed by\n*  ZHETRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**H;\n*          = 'L':  Lower triangular, form is A = L*D*L**H.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the block diagonal matrix D and the multipliers\n*          used to obtain the factor U or L as computed by ZHETRF.\n*\n*          On exit, if INFO = 0, the (Hermitian) inverse of the original\n*          matrix.  If UPLO = 'U', the upper triangular part of the\n*          inverse is formed and the part of A below the diagonal is not\n*          referenced; if UPLO = 'L' the lower triangular part of the\n*          inverse is formed and the part of A above the diagonal is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by ZHETRF.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (N)\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, D(i,i) = 0; the matrix is singular and its\n*               inverse could not be computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.zhetri( uplo, a, ipiv, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(doublecomplex, (n));

  zhetri_(&uplo, &n, a, &lda, ipiv, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_zhetri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhetri", rblapack_zhetri, -1);
}
ruby-lapack-1.7.2/ext/cggevx.c0000644000175000017500000004230412502221013016005 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cggevx_(char* balanc, char* jobvl, char* jobvr, char* sense, integer* n, complex* a, integer* lda, complex* b, integer* ldb, complex* alpha, complex* beta, complex* vl, integer* ldvl, complex* vr, integer* ldvr, integer* ilo, integer* ihi, real* lscale, real* rscale, real* abnrm, real* bbnrm, real* rconde, real* rcondv, complex* work, integer* lwork, real* rwork, integer* iwork, logical* bwork, integer* info);


static VALUE
rblapack_cggevx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_balanc;
  char balanc; 
  VALUE rblapack_jobvl;
  char jobvl; 
  VALUE rblapack_jobvr;
  char jobvr; 
  VALUE rblapack_sense;
  char sense; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_alpha;
  complex *alpha; 
  VALUE rblapack_beta;
  complex *beta; 
  VALUE rblapack_vl;
  complex *vl; 
  VALUE rblapack_vr;
  complex *vr; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_lscale;
  real *lscale; 
  VALUE rblapack_rscale;
  real *rscale; 
  VALUE rblapack_abnrm;
  real abnrm; 
  VALUE rblapack_bbnrm;
  real bbnrm; 
  VALUE rblapack_rconde;
  real *rconde; 
  VALUE rblapack_rcondv;
  real *rcondv; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;
  real *rwork;
  integer *iwork;
  logical *bwork;

  integer lda;
  integer n;
  integer ldb;
  integer ldvl;
  integer ldvr;
  integer lrwork;

  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  alpha, beta, vl, vr, ilo, ihi, lscale, rscale, abnrm, bbnrm, rconde, rcondv, work, info, a, b = NumRu::Lapack.cggevx( balanc, jobvl, jobvr, sense, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB, ALPHA, BETA, VL, LDVL, VR, LDVR, ILO, IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, WORK, LWORK, RWORK, IWORK, BWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGGEVX computes for a pair of N-by-N complex nonsymmetric matrices\n*  (A,B) the generalized eigenvalues, and optionally, the left and/or\n*  right generalized eigenvectors.\n*\n*  Optionally, it also computes a balancing transformation to improve\n*  the conditioning of the eigenvalues and eigenvectors (ILO, IHI,\n*  LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for\n*  the eigenvalues (RCONDE), and reciprocal condition numbers for the\n*  right eigenvectors (RCONDV).\n*\n*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar\n*  lambda or a ratio alpha/beta = lambda, such that A - lambda*B is\n*  singular. It is usually represented as the pair (alpha,beta), as\n*  there is a reasonable interpretation for beta=0, and even for both\n*  being zero.\n*\n*  The right eigenvector v(j) corresponding to the eigenvalue lambda(j)\n*  of (A,B) satisfies\n*                   A * v(j) = lambda(j) * B * v(j) .\n*  The left eigenvector u(j) corresponding to the eigenvalue lambda(j)\n*  of (A,B) satisfies\n*                   u(j)**H * A  = lambda(j) * u(j)**H * B.\n*  where u(j)**H is the conjugate-transpose of u(j).\n*\n*\n\n*  Arguments\n*  =========\n*\n*  BALANC  (input) CHARACTER*1\n*          Specifies the balance option to be performed:\n*          = 'N':  do not diagonally scale or permute;\n*          = 'P':  permute only;\n*          = 'S':  scale only;\n*          = 'B':  both permute and scale.\n*          Computed reciprocal condition numbers will be for the\n*          matrices after permuting and/or balancing. Permuting does\n*          not change condition numbers (in exact arithmetic), but\n*          balancing does.\n*\n*  JOBVL   (input) CHARACTER*1\n*          = 'N':  do not compute the left generalized eigenvectors;\n*          = 'V':  compute the left generalized eigenvectors.\n*\n*  JOBVR   (input) CHARACTER*1\n*          = 'N':  do not compute the right generalized eigenvectors;\n*          = 'V':  compute the right generalized eigenvectors.\n*\n*  SENSE   (input) CHARACTER*1\n*          Determines which reciprocal condition numbers are computed.\n*          = 'N': none are computed;\n*          = 'E': computed for eigenvalues only;\n*          = 'V': computed for eigenvectors only;\n*          = 'B': computed for eigenvalues and eigenvectors.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A, B, VL, and VR.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA, N)\n*          On entry, the matrix A in the pair (A,B).\n*          On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'\n*          or both, then A contains the first part of the complex Schur\n*          form of the \"balanced\" versions of the input A and B.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of A.  LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX array, dimension (LDB, N)\n*          On entry, the matrix B in the pair (A,B).\n*          On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'\n*          or both, then B contains the second part of the complex\n*          Schur form of the \"balanced\" versions of the input A and B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of B.  LDB >= max(1,N).\n*\n*  ALPHA   (output) COMPLEX array, dimension (N)\n*  BETA    (output) COMPLEX array, dimension (N)\n*          On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the generalized\n*          eigenvalues.\n*\n*          Note: the quotient ALPHA(j)/BETA(j) ) may easily over- or\n*          underflow, and BETA(j) may even be zero.  Thus, the user\n*          should avoid naively computing the ratio ALPHA/BETA.\n*          However, ALPHA will be always less than and usually\n*          comparable with norm(A) in magnitude, and BETA always less\n*          than and usually comparable with norm(B).\n*\n*  VL      (output) COMPLEX array, dimension (LDVL,N)\n*          If JOBVL = 'V', the left generalized eigenvectors u(j) are\n*          stored one after another in the columns of VL, in the same\n*          order as their eigenvalues.\n*          Each eigenvector will be scaled so the largest component\n*          will have abs(real part) + abs(imag. part) = 1.\n*          Not referenced if JOBVL = 'N'.\n*\n*  LDVL    (input) INTEGER\n*          The leading dimension of the matrix VL. LDVL >= 1, and\n*          if JOBVL = 'V', LDVL >= N.\n*\n*  VR      (output) COMPLEX array, dimension (LDVR,N)\n*          If JOBVR = 'V', the right generalized eigenvectors v(j) are\n*          stored one after another in the columns of VR, in the same\n*          order as their eigenvalues.\n*          Each eigenvector will be scaled so the largest component\n*          will have abs(real part) + abs(imag. part) = 1.\n*          Not referenced if JOBVR = 'N'.\n*\n*  LDVR    (input) INTEGER\n*          The leading dimension of the matrix VR. LDVR >= 1, and\n*          if JOBVR = 'V', LDVR >= N.\n*\n*  ILO     (output) INTEGER\n*  IHI     (output) INTEGER\n*          ILO and IHI are integer values such that on exit\n*          A(i,j) = 0 and B(i,j) = 0 if i > j and\n*          j = 1,...,ILO-1 or i = IHI+1,...,N.\n*          If BALANC = 'N' or 'S', ILO = 1 and IHI = N.\n*\n*  LSCALE  (output) REAL array, dimension (N)\n*          Details of the permutations and scaling factors applied\n*          to the left side of A and B.  If PL(j) is the index of the\n*          row interchanged with row j, and DL(j) is the scaling\n*          factor applied to row j, then\n*            LSCALE(j) = PL(j)  for j = 1,...,ILO-1\n*                      = DL(j)  for j = ILO,...,IHI\n*                      = PL(j)  for j = IHI+1,...,N.\n*          The order in which the interchanges are made is N to IHI+1,\n*          then 1 to ILO-1.\n*\n*  RSCALE  (output) REAL array, dimension (N)\n*          Details of the permutations and scaling factors applied\n*          to the right side of A and B.  If PR(j) is the index of the\n*          column interchanged with column j, and DR(j) is the scaling\n*          factor applied to column j, then\n*            RSCALE(j) = PR(j)  for j = 1,...,ILO-1\n*                      = DR(j)  for j = ILO,...,IHI\n*                      = PR(j)  for j = IHI+1,...,N\n*          The order in which the interchanges are made is N to IHI+1,\n*          then 1 to ILO-1.\n*\n*  ABNRM   (output) REAL\n*          The one-norm of the balanced matrix A.\n*\n*  BBNRM   (output) REAL\n*          The one-norm of the balanced matrix B.\n*\n*  RCONDE  (output) REAL array, dimension (N)\n*          If SENSE = 'E' or 'B', the reciprocal condition numbers of\n*          the eigenvalues, stored in consecutive elements of the array.\n*          If SENSE = 'N' or 'V', RCONDE is not referenced.\n*\n*  RCONDV  (output) REAL array, dimension (N)\n*          If SENSE = 'V' or 'B', the estimated reciprocal condition\n*          numbers of the eigenvectors, stored in consecutive elements\n*          of the array. If the eigenvalues cannot be reordered to\n*          compute RCONDV(j), RCONDV(j) is set to 0; this can only occur\n*          when the true value would be very small anyway. \n*          If SENSE = 'N' or 'E', RCONDV is not referenced.\n*\n*  WORK    (workspace/output) COMPLEX 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,2*N).\n*          If SENSE = 'E', LWORK >= max(1,4*N).\n*          If SENSE = 'V' or 'B', LWORK >= max(1,2*N*N+2*N).\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*  RWORK   (workspace) REAL array, dimension (lrwork)\n*          lrwork must be at least max(1,6*N) if BALANC = 'S' or 'B',\n*          and at least max(1,2*N) otherwise.\n*          Real workspace.\n*\n*  IWORK   (workspace) INTEGER array, dimension (N+2)\n*          If SENSE = 'E', IWORK is not referenced.\n*\n*  BWORK   (workspace) LOGICAL array, dimension (N)\n*          If SENSE = 'N', BWORK is not referenced.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          = 1,...,N:\n*                The QZ iteration failed.  No eigenvectors have been\n*                calculated, but ALPHA(j) and BETA(j) should be correct\n*                for j=INFO+1,...,N.\n*          > N:  =N+1: other than QZ iteration failed in CHGEQZ.\n*                =N+2: error return from CTGEVC.\n*\n\n*  Further Details\n*  ===============\n*\n*  Balancing a matrix pair (A,B) includes, first, permuting rows and\n*  columns to isolate eigenvalues, second, applying diagonal similarity\n*  transformation to the rows and columns to make the rows and columns\n*  as close in norm as possible. The computed reciprocal condition\n*  numbers correspond to the balanced matrix. Permuting rows and columns\n*  will not change the condition numbers (in exact arithmetic) but\n*  diagonal scaling will.  For further explanation of balancing, see\n*  section 4.11.1.2 of LAPACK Users' Guide.\n*\n*  An approximate error bound on the chordal distance between the i-th\n*  computed generalized eigenvalue w and the corresponding exact\n*  eigenvalue lambda is\n*\n*       chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)\n*\n*  An approximate error bound for the angle between the i-th computed\n*  eigenvector VL(i) or VR(i) is given by\n*\n*       EPS * norm(ABNRM, BBNRM) / DIF(i).\n*\n*  For further explanation of the reciprocal condition numbers RCONDE\n*  and RCONDV, see section 4.11 of LAPACK User's Guide.\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  alpha, beta, vl, vr, ilo, ihi, lscale, rscale, abnrm, bbnrm, rconde, rcondv, work, info, a, b = NumRu::Lapack.cggevx( balanc, jobvl, jobvr, sense, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_balanc = argv[0];
  rblapack_jobvl = argv[1];
  rblapack_jobvr = argv[2];
  rblapack_sense = argv[3];
  rblapack_a = argv[4];
  rblapack_b = argv[5];
  if (argc == 7) {
    rblapack_lwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  balanc = StringValueCStr(rblapack_balanc)[0];
  jobvr = StringValueCStr(rblapack_jobvr)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  jobvl = StringValueCStr(rblapack_jobvl)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  ldvr = lsame_(&jobvr,"V") ? n : 1;
  ldvl = lsame_(&jobvl,"V") ? n : 1;
  sense = StringValueCStr(rblapack_sense)[0];
  lrwork = ((lsame_(&balanc,"S")) || (lsame_(&balanc,"B"))) ? MAX(1,6*n) : MAX(1,2*n);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&sense,"E") ? 4*n : (lsame_(&sense,"V")||lsame_(&sense,"B")) ? 2*n*n+2*n : 2*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  alpha = NA_PTR_TYPE(rblapack_alpha, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvl;
    shape[1] = n;
    rblapack_vl = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  vl = NA_PTR_TYPE(rblapack_vl, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvr;
    shape[1] = n;
    rblapack_vr = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  vr = NA_PTR_TYPE(rblapack_vr, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_lscale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  lscale = NA_PTR_TYPE(rblapack_lscale, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rscale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  rscale = NA_PTR_TYPE(rblapack_rscale, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rconde = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  rconde = NA_PTR_TYPE(rblapack_rconde, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rcondv = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  rcondv = NA_PTR_TYPE(rblapack_rcondv, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  rwork = ALLOC_N(real, (lrwork));
  iwork = ALLOC_N(integer, (lsame_(&sense,"E") ? 0 : n+2));
  bwork = ALLOC_N(logical, (lsame_(&sense,"N") ? 0 : n));

  cggevx_(&balanc, &jobvl, &jobvr, &sense, &n, a, &lda, b, &ldb, alpha, beta, vl, &ldvl, vr, &ldvr, &ilo, &ihi, lscale, rscale, &abnrm, &bbnrm, rconde, rcondv, work, &lwork, rwork, iwork, bwork, &info);

  free(rwork);
  free(iwork);
  free(bwork);
  rblapack_ilo = INT2NUM(ilo);
  rblapack_ihi = INT2NUM(ihi);
  rblapack_abnrm = rb_float_new((double)abnrm);
  rblapack_bbnrm = rb_float_new((double)bbnrm);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(16, rblapack_alpha, rblapack_beta, rblapack_vl, rblapack_vr, rblapack_ilo, rblapack_ihi, rblapack_lscale, rblapack_rscale, rblapack_abnrm, rblapack_bbnrm, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_cggevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cggevx", rblapack_cggevx, -1);
}
ruby-lapack-1.7.2/ext/sstedc.c0000644000175000017500000002430212502221017016011 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sstedc_(char* compz, integer* n, real* d, real* e, real* z, integer* ldz, real* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_sstedc(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_compz;
  char compz; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_e_out__;
  real *e_out__;
  VALUE rblapack_z_out__;
  real *z_out__;

  integer n;
  integer ldz;

  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, iwork, info, d, e, z = NumRu::Lapack.sstedc( compz, d, e, z, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSTEDC computes all eigenvalues and, optionally, eigenvectors of a\n*  symmetric tridiagonal matrix using the divide and conquer method.\n*  The eigenvectors of a full or band real symmetric matrix can also be\n*  found if SSYTRD or SSPTRD or SSBTRD has been used to reduce this\n*  matrix to tridiagonal form.\n*\n*  This code makes very mild assumptions about floating point\n*  arithmetic. It will work on machines with a guard digit in\n*  add/subtract, or on those binary machines without guard digits\n*  which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.\n*  It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.  See SLAED3 for details.\n*\n\n*  Arguments\n*  =========\n*\n*  COMPZ   (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only.\n*          = 'I':  Compute eigenvectors of tridiagonal matrix also.\n*          = 'V':  Compute eigenvectors of original dense symmetric\n*                  matrix also.  On entry, Z contains the orthogonal\n*                  matrix used to reduce the original matrix to\n*                  tridiagonal form.\n*\n*  N       (input) INTEGER\n*          The dimension of the symmetric tridiagonal matrix.  N >= 0.\n*\n*  D       (input/output) REAL array, dimension (N)\n*          On entry, the diagonal elements of the tridiagonal matrix.\n*          On exit, if INFO = 0, the eigenvalues in ascending order.\n*\n*  E       (input/output) REAL array, dimension (N-1)\n*          On entry, the subdiagonal elements of the tridiagonal matrix.\n*          On exit, E has been destroyed.\n*\n*  Z       (input/output) REAL array, dimension (LDZ,N)\n*          On entry, if COMPZ = 'V', then Z contains the orthogonal\n*          matrix used in the reduction to tridiagonal form.\n*          On exit, if INFO = 0, then if COMPZ = 'V', Z contains the\n*          orthonormal eigenvectors of the original symmetric matrix,\n*          and if COMPZ = 'I', Z contains the orthonormal eigenvectors\n*          of the symmetric tridiagonal matrix.\n*          If  COMPZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1.\n*          If eigenvectors are desired, then LDZ >= max(1,N).\n*\n*  WORK    (workspace/output) REAL 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*          If COMPZ = 'N' or N <= 1 then LWORK must be at least 1.\n*          If COMPZ = 'V' and N > 1 then LWORK must be at least\n*                         ( 1 + 3*N + 2*N*lg N + 3*N**2 ),\n*                         where lg( N ) = smallest integer k such\n*                         that 2**k >= N.\n*          If COMPZ = 'I' and N > 1 then LWORK must be at least\n*                         ( 1 + 4*N + N**2 ).\n*          Note that for COMPZ = 'I' or 'V', then if N is less than or\n*          equal to the minimum divide size, usually 25, then LWORK need\n*          only be max(1,2*(N-1)).\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*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.\n*          If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1.\n*          If COMPZ = 'V' and N > 1 then LIWORK must be at least\n*                         ( 6 + 6*N + 5*N*lg N ).\n*          If COMPZ = 'I' and N > 1 then LIWORK must be at least\n*                         ( 3 + 5*N ).\n*          Note that for COMPZ = 'I' or 'V', then if N is less than or\n*          equal to the minimum divide size, usually 25, then LIWORK\n*          need only be 1.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal size of the IWORK array,\n*          returns this value as the first entry of the IWORK array, and\n*          no error message related to LIWORK 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:  The algorithm failed to compute an eigenvalue while\n*                working on the submatrix lying in rows and columns\n*                INFO/(N+1) through mod(INFO,N+1).\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Jeff Rutter, Computer Science Division, University of California\n*     at Berkeley, USA\n*  Modified by Francoise Tisseur, University of Tennessee.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, iwork, info, d, e, z = NumRu::Lapack.sstedc( compz, d, e, z, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_compz = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  rblapack_z = argv[3];
  if (argc == 6) {
    rblapack_lwork = argv[4];
    rblapack_liwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  compz = StringValueCStr(rblapack_compz)[0];
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (4th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (4th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  n = NA_SHAPE1(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of z");
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (rblapack_lwork == Qnil)
    lwork = (lsame_(&compz,"N")||n<=1) ? 1 : lsame_(&compz,"V") ? 1+3*n+2*n*LG(n)+3*n*n : lsame_(&compz,"I") ? 1+4*n+2*n*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  if (rblapack_liwork == Qnil)
    liwork = (lsame_(&compz,"N")||n<=1) ? 1 : lsame_(&compz,"V") ? 6+6*n+5*n*LG(n) : lsame_(&compz,"I") ? 3+5*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, real*);
  MEMCPY(e_out__, e, real, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
  MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  sstedc_(&compz, &n, d, e, z, &ldz, work, &lwork, iwork, &liwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_work, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e, rblapack_z);
}

void
init_lapack_sstedc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sstedc", rblapack_sstedc, -1);
}
ruby-lapack-1.7.2/ext/slasd2.c0000644000175000017500000003272712502221016015725 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slasd2_(integer* nl, integer* nr, integer* sqre, integer* k, real* d, real* z, real* alpha, real* beta, real* u, integer* ldu, real* vt, integer* ldvt, real* dsigma, real* u2, integer* ldu2, real* vt2, integer* ldvt2, integer* idxp, integer* idx, integer* idxc, integer* idxq, integer* coltyp, integer* info);


static VALUE
rblapack_slasd2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_nl;
  integer nl; 
  VALUE rblapack_nr;
  integer nr; 
  VALUE rblapack_sqre;
  integer sqre; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_alpha;
  real alpha; 
  VALUE rblapack_beta;
  real beta; 
  VALUE rblapack_u;
  real *u; 
  VALUE rblapack_vt;
  real *vt; 
  VALUE rblapack_idxq;
  integer *idxq; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_dsigma;
  real *dsigma; 
  VALUE rblapack_u2;
  real *u2; 
  VALUE rblapack_vt2;
  real *vt2; 
  VALUE rblapack_idxc;
  integer *idxc; 
  VALUE rblapack_coltyp;
  integer *coltyp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_u_out__;
  real *u_out__;
  VALUE rblapack_vt_out__;
  real *vt_out__;
  VALUE rblapack_idxq_out__;
  integer *idxq_out__;
  integer *idxp;
  integer *idx;

  integer n;
  integer ldu;
  integer ldvt;
  integer m;
  integer ldu2;
  integer ldvt2;

  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  k, z, dsigma, u2, vt2, idxc, coltyp, info, d, u, vt, idxq = NumRu::Lapack.slasd2( nl, nr, sqre, d, alpha, beta, u, vt, idxq, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX, IDXC, IDXQ, COLTYP, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLASD2 merges the two sets of singular values together into a single\n*  sorted set.  Then it tries to deflate the size of the problem.\n*  There are two ways in which deflation can occur:  when two or more\n*  singular values are close together or if there is a tiny entry in the\n*  Z vector.  For each such occurrence the order of the related secular\n*  equation problem is reduced by one.\n*\n*  SLASD2 is called from SLASD1.\n*\n\n*  Arguments\n*  =========\n*\n*  NL     (input) INTEGER\n*         The row dimension of the upper block.  NL >= 1.\n*\n*  NR     (input) INTEGER\n*         The row dimension of the lower block.  NR >= 1.\n*\n*  SQRE   (input) INTEGER\n*         = 0: the lower block is an NR-by-NR square matrix.\n*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n*         The bidiagonal matrix has N = NL + NR + 1 rows and\n*         M = N + SQRE >= N columns.\n*\n*  K      (output) INTEGER\n*         Contains the dimension of the non-deflated matrix,\n*         This is the order of the related secular equation. 1 <= K <=N.\n*\n*  D      (input/output) REAL array, dimension (N)\n*         On entry D contains the singular values of the two submatrices\n*         to be combined.  On exit D contains the trailing (N-K) updated\n*         singular values (those which were deflated) sorted into\n*         increasing order.\n*\n*  Z      (output) REAL array, dimension (N)\n*         On exit Z contains the updating row vector in the secular\n*         equation.\n*\n*  ALPHA  (input) REAL\n*         Contains the diagonal element associated with the added row.\n*\n*  BETA   (input) REAL\n*         Contains the off-diagonal element associated with the added\n*         row.\n*\n*  U      (input/output) REAL array, dimension (LDU,N)\n*         On entry U contains the left singular vectors of two\n*         submatrices in the two square blocks with corners at (1,1),\n*         (NL, NL), and (NL+2, NL+2), (N,N).\n*         On exit U contains the trailing (N-K) updated left singular\n*         vectors (those which were deflated) in its last N-K columns.\n*\n*  LDU    (input) INTEGER\n*         The leading dimension of the array U.  LDU >= N.\n*\n*  VT     (input/output) REAL array, dimension (LDVT,M)\n*         On entry VT' contains the right singular vectors of two\n*         submatrices in the two square blocks with corners at (1,1),\n*         (NL+1, NL+1), and (NL+2, NL+2), (M,M).\n*         On exit VT' contains the trailing (N-K) updated right singular\n*         vectors (those which were deflated) in its last N-K columns.\n*         In case SQRE =1, the last row of VT spans the right null\n*         space.\n*\n*  LDVT   (input) INTEGER\n*         The leading dimension of the array VT.  LDVT >= M.\n*\n*  DSIGMA (output) REAL array, dimension (N)\n*         Contains a copy of the diagonal elements (K-1 singular values\n*         and one zero) in the secular equation.\n*\n*  U2     (output) REAL array, dimension (LDU2,N)\n*         Contains a copy of the first K-1 left singular vectors which\n*         will be used by SLASD3 in a matrix multiply (SGEMM) to solve\n*         for the new left singular vectors. U2 is arranged into four\n*         blocks. The first block contains a column with 1 at NL+1 and\n*         zero everywhere else; the second block contains non-zero\n*         entries only at and above NL; the third contains non-zero\n*         entries only below NL+1; and the fourth is dense.\n*\n*  LDU2   (input) INTEGER\n*         The leading dimension of the array U2.  LDU2 >= N.\n*\n*  VT2    (output) REAL array, dimension (LDVT2,N)\n*         VT2' contains a copy of the first K right singular vectors\n*         which will be used by SLASD3 in a matrix multiply (SGEMM) to\n*         solve for the new right singular vectors. VT2 is arranged into\n*         three blocks. The first block contains a row that corresponds\n*         to the special 0 diagonal element in SIGMA; the second block\n*         contains non-zeros only at and before NL +1; the third block\n*         contains non-zeros only at and after  NL +2.\n*\n*  LDVT2  (input) INTEGER\n*         The leading dimension of the array VT2.  LDVT2 >= M.\n*\n*  IDXP   (workspace) INTEGER array, dimension (N)\n*         This will contain the permutation used to place deflated\n*         values of D at the end of the array. On output IDXP(2:K)\n*         points to the nondeflated D-values and IDXP(K+1:N)\n*         points to the deflated singular values.\n*\n*  IDX    (workspace) INTEGER array, dimension (N)\n*         This will contain the permutation used to sort the contents of\n*         D into ascending order.\n*\n*  IDXC   (output) INTEGER array, dimension (N)\n*         This will contain the permutation used to arrange the columns\n*         of the deflated U matrix into three groups:  the first group\n*         contains non-zero entries only at and above NL, the second\n*         contains non-zero entries only below NL+2, and the third is\n*         dense.\n*\n*  IDXQ   (input/output) INTEGER array, dimension (N)\n*         This contains the permutation which separately sorts the two\n*         sub-problems in D into ascending order.  Note that entries in\n*         the first hlaf of this permutation must first be moved one\n*         position backward; and entries in the second half\n*         must first have NL+1 added to their values.\n*\n*  COLTYP (workspace/output) INTEGER array, dimension (N)\n*         As workspace, this will contain a label which will indicate\n*         which of the following types a column in the U2 matrix or a\n*         row in the VT2 matrix is:\n*         1 : non-zero in the upper half only\n*         2 : non-zero in the lower half only\n*         3 : dense\n*         4 : deflated\n*\n*         On exit, it is an array of dimension 4, with COLTYP(I) being\n*         the dimension of the I-th type columns.\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*  Based on contributions by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  k, z, dsigma, u2, vt2, idxc, coltyp, info, d, u, vt, idxq = NumRu::Lapack.slasd2( nl, nr, sqre, d, alpha, beta, u, vt, idxq, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_nl = argv[0];
  rblapack_nr = argv[1];
  rblapack_sqre = argv[2];
  rblapack_d = argv[3];
  rblapack_alpha = argv[4];
  rblapack_beta = argv[5];
  rblapack_u = argv[6];
  rblapack_vt = argv[7];
  rblapack_idxq = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  nl = NUM2INT(rblapack_nl);
  sqre = NUM2INT(rblapack_sqre);
  alpha = (real)NUM2DBL(rblapack_alpha);
  if (!NA_IsNArray(rblapack_u))
    rb_raise(rb_eArgError, "u (7th argument) must be NArray");
  if (NA_RANK(rblapack_u) != 2)
    rb_raise(rb_eArgError, "rank of u (7th argument) must be %d", 2);
  ldu = NA_SHAPE0(rblapack_u);
  n = NA_SHAPE1(rblapack_u);
  if (NA_TYPE(rblapack_u) != NA_SFLOAT)
    rblapack_u = na_change_type(rblapack_u, NA_SFLOAT);
  u = NA_PTR_TYPE(rblapack_u, real*);
  if (!NA_IsNArray(rblapack_idxq))
    rb_raise(rb_eArgError, "idxq (9th argument) must be NArray");
  if (NA_RANK(rblapack_idxq) != 1)
    rb_raise(rb_eArgError, "rank of idxq (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_idxq) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of idxq must be the same as shape 1 of u");
  if (NA_TYPE(rblapack_idxq) != NA_LINT)
    rblapack_idxq = na_change_type(rblapack_idxq, NA_LINT);
  idxq = NA_PTR_TYPE(rblapack_idxq, integer*);
  nr = NUM2INT(rblapack_nr);
  beta = (real)NUM2DBL(rblapack_beta);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of u");
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  ldu2 = n;
  if (!NA_IsNArray(rblapack_vt))
    rb_raise(rb_eArgError, "vt (8th argument) must be NArray");
  if (NA_RANK(rblapack_vt) != 2)
    rb_raise(rb_eArgError, "rank of vt (8th argument) must be %d", 2);
  ldvt = NA_SHAPE0(rblapack_vt);
  m = NA_SHAPE1(rblapack_vt);
  if (NA_TYPE(rblapack_vt) != NA_SFLOAT)
    rblapack_vt = na_change_type(rblapack_vt, NA_SFLOAT);
  vt = NA_PTR_TYPE(rblapack_vt, real*);
  ldvt2 = m;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_z = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_dsigma = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  dsigma = NA_PTR_TYPE(rblapack_dsigma, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldu2;
    shape[1] = n;
    rblapack_u2 = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  u2 = NA_PTR_TYPE(rblapack_u2, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldvt2;
    shape[1] = n;
    rblapack_vt2 = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vt2 = NA_PTR_TYPE(rblapack_vt2, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_idxc = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  idxc = NA_PTR_TYPE(rblapack_idxc, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_coltyp = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  coltyp = NA_PTR_TYPE(rblapack_coltyp, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = n;
    rblapack_u_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  u_out__ = NA_PTR_TYPE(rblapack_u_out__, real*);
  MEMCPY(u_out__, u, real, NA_TOTAL(rblapack_u));
  rblapack_u = rblapack_u_out__;
  u = u_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvt;
    shape[1] = m;
    rblapack_vt_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vt_out__ = NA_PTR_TYPE(rblapack_vt_out__, real*);
  MEMCPY(vt_out__, vt, real, NA_TOTAL(rblapack_vt));
  rblapack_vt = rblapack_vt_out__;
  vt = vt_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_idxq_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  idxq_out__ = NA_PTR_TYPE(rblapack_idxq_out__, integer*);
  MEMCPY(idxq_out__, idxq, integer, NA_TOTAL(rblapack_idxq));
  rblapack_idxq = rblapack_idxq_out__;
  idxq = idxq_out__;
  idxp = ALLOC_N(integer, (n));
  idx = ALLOC_N(integer, (n));

  slasd2_(&nl, &nr, &sqre, &k, d, z, &alpha, &beta, u, &ldu, vt, &ldvt, dsigma, u2, &ldu2, vt2, &ldvt2, idxp, idx, idxc, idxq, coltyp, &info);

  free(idxp);
  free(idx);
  rblapack_k = INT2NUM(k);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(12, rblapack_k, rblapack_z, rblapack_dsigma, rblapack_u2, rblapack_vt2, rblapack_idxc, rblapack_coltyp, rblapack_info, rblapack_d, rblapack_u, rblapack_vt, rblapack_idxq);
}

void
init_lapack_slasd2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slasd2", rblapack_slasd2, -1);
}
ruby-lapack-1.7.2/ext/dlasd7.c0000644000175000017500000003252412502221014015704 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlasd7_(integer* icompq, integer* nl, integer* nr, integer* sqre, integer* k, doublereal* d, doublereal* z, doublereal* zw, doublereal* vf, doublereal* vfw, doublereal* vl, doublereal* vlw, doublereal* alpha, doublereal* beta, doublereal* dsigma, integer* idx, integer* idxp, integer* idxq, integer* perm, integer* givptr, integer* givcol, integer* ldgcol, doublereal* givnum, integer* ldgnum, doublereal* c, doublereal* s, integer* info);


static VALUE
rblapack_dlasd7(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_icompq;
  integer icompq; 
  VALUE rblapack_nl;
  integer nl; 
  VALUE rblapack_nr;
  integer nr; 
  VALUE rblapack_sqre;
  integer sqre; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_vf;
  doublereal *vf; 
  VALUE rblapack_vl;
  doublereal *vl; 
  VALUE rblapack_alpha;
  doublereal alpha; 
  VALUE rblapack_beta;
  doublereal beta; 
  VALUE rblapack_idxq;
  integer *idxq; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_dsigma;
  doublereal *dsigma; 
  VALUE rblapack_perm;
  integer *perm; 
  VALUE rblapack_givptr;
  integer givptr; 
  VALUE rblapack_givcol;
  integer *givcol; 
  VALUE rblapack_givnum;
  doublereal *givnum; 
  VALUE rblapack_c;
  doublereal c; 
  VALUE rblapack_s;
  doublereal s; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_vf_out__;
  doublereal *vf_out__;
  VALUE rblapack_vl_out__;
  doublereal *vl_out__;
  doublereal *zw;
  doublereal *vfw;
  doublereal *vlw;
  integer *idx;
  integer *idxp;

  integer n;
  integer m;
  integer ldgcol;
  integer ldgnum;

  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  k, z, dsigma, perm, givptr, givcol, givnum, c, s, info, d, vf, vl = NumRu::Lapack.dlasd7( icompq, nl, nr, sqre, d, vf, vl, alpha, beta, idxq, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL, VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, C, S, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLASD7 merges the two sets of singular values together into a single\n*  sorted set. Then it tries to deflate the size of the problem. There\n*  are two ways in which deflation can occur:  when two or more singular\n*  values are close together or if there is a tiny entry in the Z\n*  vector. For each such occurrence the order of the related\n*  secular equation problem is reduced by one.\n*\n*  DLASD7 is called from DLASD6.\n*\n\n*  Arguments\n*  =========\n*\n*  ICOMPQ  (input) INTEGER\n*          Specifies whether singular vectors are to be computed\n*          in compact form, as follows:\n*          = 0: Compute singular values only.\n*          = 1: Compute singular vectors of upper\n*               bidiagonal matrix in compact form.\n*\n*  NL     (input) INTEGER\n*         The row dimension of the upper block. NL >= 1.\n*\n*  NR     (input) INTEGER\n*         The row dimension of the lower block. NR >= 1.\n*\n*  SQRE   (input) INTEGER\n*         = 0: the lower block is an NR-by-NR square matrix.\n*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n*         The bidiagonal matrix has\n*         N = NL + NR + 1 rows and\n*         M = N + SQRE >= N columns.\n*\n*  K      (output) INTEGER\n*         Contains the dimension of the non-deflated matrix, this is\n*         the order of the related secular equation. 1 <= K <=N.\n*\n*  D      (input/output) DOUBLE PRECISION array, dimension ( N )\n*         On entry D contains the singular values of the two submatrices\n*         to be combined. On exit D contains the trailing (N-K) updated\n*         singular values (those which were deflated) sorted into\n*         increasing order.\n*\n*  Z      (output) DOUBLE PRECISION array, dimension ( M )\n*         On exit Z contains the updating row vector in the secular\n*         equation.\n*\n*  ZW     (workspace) DOUBLE PRECISION array, dimension ( M )\n*         Workspace for Z.\n*\n*  VF     (input/output) DOUBLE PRECISION array, dimension ( M )\n*         On entry, VF(1:NL+1) contains the first components of all\n*         right singular vectors of the upper block; and VF(NL+2:M)\n*         contains the first components of all right singular vectors\n*         of the lower block. On exit, VF contains the first components\n*         of all right singular vectors of the bidiagonal matrix.\n*\n*  VFW    (workspace) DOUBLE PRECISION array, dimension ( M )\n*         Workspace for VF.\n*\n*  VL     (input/output) DOUBLE PRECISION array, dimension ( M )\n*         On entry, VL(1:NL+1) contains the  last components of all\n*         right singular vectors of the upper block; and VL(NL+2:M)\n*         contains the last components of all right singular vectors\n*         of the lower block. On exit, VL contains the last components\n*         of all right singular vectors of the bidiagonal matrix.\n*\n*  VLW    (workspace) DOUBLE PRECISION array, dimension ( M )\n*         Workspace for VL.\n*\n*  ALPHA  (input) DOUBLE PRECISION\n*         Contains the diagonal element associated with the added row.\n*\n*  BETA   (input) DOUBLE PRECISION\n*         Contains the off-diagonal element associated with the added\n*         row.\n*\n*  DSIGMA (output) DOUBLE PRECISION array, dimension ( N )\n*         Contains a copy of the diagonal elements (K-1 singular values\n*         and one zero) in the secular equation.\n*\n*  IDX    (workspace) INTEGER array, dimension ( N )\n*         This will contain the permutation used to sort the contents of\n*         D into ascending order.\n*\n*  IDXP   (workspace) INTEGER array, dimension ( N )\n*         This will contain the permutation used to place deflated\n*         values of D at the end of the array. On output IDXP(2:K)\n*         points to the nondeflated D-values and IDXP(K+1:N)\n*         points to the deflated singular values.\n*\n*  IDXQ   (input) INTEGER array, dimension ( N )\n*         This contains the permutation which separately sorts the two\n*         sub-problems in D into ascending order.  Note that entries in\n*         the first half of this permutation must first be moved one\n*         position backward; and entries in the second half\n*         must first have NL+1 added to their values.\n*\n*  PERM   (output) INTEGER array, dimension ( N )\n*         The permutations (from deflation and sorting) to be applied\n*         to each singular block. Not referenced if ICOMPQ = 0.\n*\n*  GIVPTR (output) INTEGER\n*         The number of Givens rotations which took place in this\n*         subproblem. Not referenced if ICOMPQ = 0.\n*\n*  GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )\n*         Each pair of numbers indicates a pair of columns to take place\n*         in a Givens rotation. Not referenced if ICOMPQ = 0.\n*\n*  LDGCOL (input) INTEGER\n*         The leading dimension of GIVCOL, must be at least N.\n*\n*  GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )\n*         Each number indicates the C or S value to be used in the\n*         corresponding Givens rotation. Not referenced if ICOMPQ = 0.\n*\n*  LDGNUM (input) INTEGER\n*         The leading dimension of GIVNUM, must be at least N.\n*\n*  C      (output) DOUBLE PRECISION\n*         C contains garbage if SQRE =0 and the C-value of a Givens\n*         rotation related to the right null space if SQRE = 1.\n*\n*  S      (output) DOUBLE PRECISION\n*         S contains garbage if SQRE =0 and the S-value of a Givens\n*         rotation related to the right null space if SQRE = 1.\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*  Based on contributions by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  k, z, dsigma, perm, givptr, givcol, givnum, c, s, info, d, vf, vl = NumRu::Lapack.dlasd7( icompq, nl, nr, sqre, d, vf, vl, alpha, beta, idxq, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_icompq = argv[0];
  rblapack_nl = argv[1];
  rblapack_nr = argv[2];
  rblapack_sqre = argv[3];
  rblapack_d = argv[4];
  rblapack_vf = argv[5];
  rblapack_vl = argv[6];
  rblapack_alpha = argv[7];
  rblapack_beta = argv[8];
  rblapack_idxq = argv[9];
  if (argc == 10) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  icompq = NUM2INT(rblapack_icompq);
  nr = NUM2INT(rblapack_nr);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (5th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_vl))
    rb_raise(rb_eArgError, "vl (7th argument) must be NArray");
  if (NA_RANK(rblapack_vl) != 1)
    rb_raise(rb_eArgError, "rank of vl (7th argument) must be %d", 1);
  m = NA_SHAPE0(rblapack_vl);
  if (NA_TYPE(rblapack_vl) != NA_DFLOAT)
    rblapack_vl = na_change_type(rblapack_vl, NA_DFLOAT);
  vl = NA_PTR_TYPE(rblapack_vl, doublereal*);
  beta = NUM2DBL(rblapack_beta);
  nl = NUM2INT(rblapack_nl);
  if (!NA_IsNArray(rblapack_vf))
    rb_raise(rb_eArgError, "vf (6th argument) must be NArray");
  if (NA_RANK(rblapack_vf) != 1)
    rb_raise(rb_eArgError, "rank of vf (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_vf) != m)
    rb_raise(rb_eRuntimeError, "shape 0 of vf must be the same as shape 0 of vl");
  if (NA_TYPE(rblapack_vf) != NA_DFLOAT)
    rblapack_vf = na_change_type(rblapack_vf, NA_DFLOAT);
  vf = NA_PTR_TYPE(rblapack_vf, doublereal*);
  if (!NA_IsNArray(rblapack_idxq))
    rb_raise(rb_eArgError, "idxq (10th argument) must be NArray");
  if (NA_RANK(rblapack_idxq) != 1)
    rb_raise(rb_eArgError, "rank of idxq (10th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_idxq) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of idxq must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_idxq) != NA_LINT)
    rblapack_idxq = na_change_type(rblapack_idxq, NA_LINT);
  idxq = NA_PTR_TYPE(rblapack_idxq, integer*);
  ldgcol = n;
  sqre = NUM2INT(rblapack_sqre);
  ldgnum = n;
  alpha = NUM2DBL(rblapack_alpha);
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_z = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_dsigma = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  dsigma = NA_PTR_TYPE(rblapack_dsigma, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_perm = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  perm = NA_PTR_TYPE(rblapack_perm, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldgcol;
    shape[1] = 2;
    rblapack_givcol = na_make_object(NA_LINT, 2, shape, cNArray);
  }
  givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldgnum;
    shape[1] = 2;
    rblapack_givnum = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  givnum = NA_PTR_TYPE(rblapack_givnum, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_vf_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  vf_out__ = NA_PTR_TYPE(rblapack_vf_out__, doublereal*);
  MEMCPY(vf_out__, vf, doublereal, NA_TOTAL(rblapack_vf));
  rblapack_vf = rblapack_vf_out__;
  vf = vf_out__;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_vl_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  vl_out__ = NA_PTR_TYPE(rblapack_vl_out__, doublereal*);
  MEMCPY(vl_out__, vl, doublereal, NA_TOTAL(rblapack_vl));
  rblapack_vl = rblapack_vl_out__;
  vl = vl_out__;
  zw = ALLOC_N(doublereal, (m));
  vfw = ALLOC_N(doublereal, (m));
  vlw = ALLOC_N(doublereal, (m));
  idx = ALLOC_N(integer, (n));
  idxp = ALLOC_N(integer, (n));

  dlasd7_(&icompq, &nl, &nr, &sqre, &k, d, z, zw, vf, vfw, vl, vlw, &alpha, &beta, dsigma, idx, idxp, idxq, perm, &givptr, givcol, &ldgcol, givnum, &ldgnum, &c, &s, &info);

  free(zw);
  free(vfw);
  free(vlw);
  free(idx);
  free(idxp);
  rblapack_k = INT2NUM(k);
  rblapack_givptr = INT2NUM(givptr);
  rblapack_c = rb_float_new((double)c);
  rblapack_s = rb_float_new((double)s);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(13, rblapack_k, rblapack_z, rblapack_dsigma, rblapack_perm, rblapack_givptr, rblapack_givcol, rblapack_givnum, rblapack_c, rblapack_s, rblapack_info, rblapack_d, rblapack_vf, rblapack_vl);
}

void
init_lapack_dlasd7(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlasd7", rblapack_dlasd7, -1);
}
ruby-lapack-1.7.2/ext/cpbtf2.c0000644000175000017500000001227412502221022015705 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cpbtf2_(char* uplo, integer* n, integer* kd, complex* ab, integer* ldab, integer* info);


static VALUE
rblapack_cpbtf2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  complex *ab_out__;

  integer ldab;
  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  info, ab = NumRu::Lapack.cpbtf2( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPBTF2( UPLO, N, KD, AB, LDAB, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPBTF2 computes the Cholesky factorization of a complex Hermitian\n*  positive definite band matrix A.\n*\n*  The factorization has the form\n*     A = U' * U ,  if UPLO = 'U', or\n*     A = L  * L',  if UPLO = 'L',\n*  where U is an upper triangular matrix, U' is the conjugate transpose\n*  of U, and L is lower triangular.\n*\n*  This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          Hermitian matrix A is stored:\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of super-diagonals of the matrix A if UPLO = 'U',\n*          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) COMPLEX array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*          On exit, if INFO = 0, the triangular factor U or L from the\n*          Cholesky factorization A = U'*U or A = L*L' of the band\n*          matrix A, in the same storage format as A.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*          > 0: if INFO = k, the leading minor of order k is not\n*               positive definite, and the factorization could not be\n*               completed.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  N = 6, KD = 2, and UPLO = 'U':\n*\n*  On entry:                       On exit:\n*\n*      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46\n*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56\n*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66\n*\n*  Similarly, if UPLO = 'L' the format of A is as follows:\n*\n*  On entry:                       On exit:\n*\n*     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66\n*     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *\n*     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *\n*\n*  Array elements marked * are not used by the routine.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ab = NumRu::Lapack.cpbtf2( uplo, kd, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  kd = NUM2INT(rblapack_kd);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
  MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  cpbtf2_(&uplo, &n, &kd, ab, &ldab, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ab);
}

void
init_lapack_cpbtf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cpbtf2", rblapack_cpbtf2, -1);
}
ruby-lapack-1.7.2/ext/stgex2.c0000644000175000017500000002462212502221026015745 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID stgex2_(logical* wantq, logical* wantz, integer* n, real* a, integer* lda, real* b, integer* ldb, real* q, integer* ldq, real* z, integer* ldz, integer* j1, integer* n1, integer* n2, real* work, integer* lwork, integer* info);


static VALUE
rblapack_stgex2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantq;
  logical wantq; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_q;
  real *q; 
  VALUE rblapack_ldq;
  integer ldq; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_j1;
  integer j1; 
  VALUE rblapack_n1;
  integer n1; 
  VALUE rblapack_n2;
  integer n2; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_b_out__;
  real *b_out__;
  VALUE rblapack_q_out__;
  real *q_out__;
  VALUE rblapack_z_out__;
  real *z_out__;
  real *work;

  integer lda;
  integer n;
  integer ldb;
  integer ldz;

  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  info, a, b, q, z = NumRu::Lapack.stgex2( wantq, wantz, a, b, q, ldq, z, j1, n1, n2, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, J1, N1, N2, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  STGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22)\n*  of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair\n*  (A, B) by an orthogonal equivalence transformation.\n*\n*  (A, B) must be in generalized real Schur canonical form (as returned\n*  by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2\n*  diagonal blocks. B is upper triangular.\n*\n*  Optionally, the matrices Q and Z of generalized Schur vectors are\n*  updated.\n*\n*         Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'\n*         Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'\n*\n*\n\n*  Arguments\n*  =========\n*\n*  WANTQ   (input) LOGICAL\n*          .TRUE. : update the left transformation matrix Q;\n*          .FALSE.: do not update Q.\n*\n*  WANTZ   (input) LOGICAL\n*          .TRUE. : update the right transformation matrix Z;\n*          .FALSE.: do not update Z.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B. N >= 0.\n*\n*  A      (input/output) REAL arrays, dimensions (LDA,N)\n*          On entry, the matrix A in the pair (A, B).\n*          On exit, the updated matrix A.\n*\n*  LDA     (input)  INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  B      (input/output) REAL arrays, dimensions (LDB,N)\n*          On entry, the matrix B in the pair (A, B).\n*          On exit, the updated matrix B.\n*\n*  LDB     (input)  INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  Q       (input/output) REAL array, dimension (LDZ,N)\n*          On entry, if WANTQ = .TRUE., the orthogonal matrix Q.\n*          On exit, the updated matrix Q.\n*          Not referenced if WANTQ = .FALSE..\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q. LDQ >= 1.\n*          If WANTQ = .TRUE., LDQ >= N.\n*\n*  Z       (input/output) REAL array, dimension (LDZ,N)\n*          On entry, if WANTZ =.TRUE., the orthogonal matrix Z.\n*          On exit, the updated matrix Z.\n*          Not referenced if WANTZ = .FALSE..\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z. LDZ >= 1.\n*          If WANTZ = .TRUE., LDZ >= N.\n*\n*  J1      (input) INTEGER\n*          The index to the first block (A11, B11). 1 <= J1 <= N.\n*\n*  N1      (input) INTEGER\n*          The order of the first block (A11, B11). N1 = 0, 1 or 2.\n*\n*  N2      (input) INTEGER\n*          The order of the second block (A22, B22). N2 = 0, 1 or 2.\n*\n*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)).\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK.\n*          LWORK >=  MAX( N*(N2+N1), (N2+N1)*(N2+N1)*2 )\n*\n*  INFO    (output) INTEGER\n*            =0: Successful exit\n*            >0: If INFO = 1, the transformed matrix (A, B) would be\n*                too far from generalized Schur form; the blocks are\n*                not swapped and (A, B) and (Q, Z) are unchanged.\n*                The problem of swapping is too ill-conditioned.\n*            <0: If INFO = -16: LWORK is too small. Appropriate value\n*                for LWORK is returned in WORK(1).\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  In the current code both weak and strong stability tests are\n*  performed. The user can omit the strong stability test by changing\n*  the internal logical parameter WANDS to .FALSE.. See ref. [2] for\n*  details.\n*\n*  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n*      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n*      M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n*      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n*  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n*      Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n*      Estimation: Theory, Algorithms and Software,\n*      Report UMINF - 94.04, Department of Computing Science, Umea\n*      University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working\n*      Note 87. To appear in Numerical Algorithms, 1996.\n*\n*  =====================================================================\n*  Replaced various illegal calls to SCOPY by calls to SLASET, or by DO\n*  loops. Sven Hammarling, 1/5/02.\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a, b, q, z = NumRu::Lapack.stgex2( wantq, wantz, a, b, q, ldq, z, j1, n1, n2, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 11)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_wantq = argv[0];
  rblapack_wantz = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  rblapack_q = argv[4];
  rblapack_ldq = argv[5];
  rblapack_z = argv[6];
  rblapack_j1 = argv[7];
  rblapack_n1 = argv[8];
  rblapack_n2 = argv[9];
  if (argc == 11) {
    rblapack_lwork = argv[10];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  wantq = (rblapack_wantq == Qtrue);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (5th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_q) != NA_SFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
  q = NA_PTR_TYPE(rblapack_q, real*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (7th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (7th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_z) != ldz)
    rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of q");
  if (NA_SHAPE1(rblapack_z) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  n1 = NUM2INT(rblapack_n1);
  wantz = (rblapack_wantz == Qtrue);
  ldq = NUM2INT(rblapack_ldq);
  n2 = NUM2INT(rblapack_n2);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  lwork = MAX(1,(MAX(n*(n2+n1),(n2+n1)*(n2+n1)*2)));
  j1 = NUM2INT(rblapack_j1);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
  MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
  MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  work = ALLOC_N(real, (lwork));

  stgex2_(&wantq, &wantz, &n, a, &lda, b, &ldb, q, &ldq, z, &ldz, &j1, &n1, &n2, work, &lwork, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z);
}

void
init_lapack_stgex2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "stgex2", rblapack_stgex2, -1);
}
ruby-lapack-1.7.2/ext/dgetrf.c0000644000175000017500000001017612502221014016000 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgetrf_(integer* m, integer* n, doublereal* a, integer* lda, integer* ipiv, integer* info);


static VALUE
rblapack_dgetrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  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  ipiv, info, a = NumRu::Lapack.dgetrf( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGETRF computes an LU factorization of a general M-by-N matrix A\n*  using partial pivoting with row interchanges.\n*\n*  The factorization has the form\n*     A = P * L * U\n*  where P is a permutation matrix, L is lower triangular with unit\n*  diagonal elements (lower trapezoidal if m > n), and U is upper\n*  triangular (upper trapezoidal if m < n).\n*\n*  This is the right-looking Level 3 BLAS version of the algorithm.\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 to be factored.\n*          On exit, the factors L and U from the factorization\n*          A = P*L*U; the unit diagonal elements of L are not stored.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  IPIV    (output) INTEGER array, dimension (min(M,N))\n*          The pivot indices; for 1 <= i <= min(M,N), row i of the\n*          matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n*                has been completed, but the factor U is exactly\n*                singular, and division by zero will occur if it is used\n*                to solve a system of equations.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, a = NumRu::Lapack.dgetrf( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t 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__;

  dgetrf_(&m, &n, a, &lda, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_a);
}

void
init_lapack_dgetrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgetrf", rblapack_dgetrf, -1);
}
ruby-lapack-1.7.2/ext/dla_gercond.c0000644000175000017500000001745612502221013016775 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal dla_gercond_(char* trans, integer* n, doublereal* a, integer* lda, doublereal* af, integer* ldaf, integer* ipiv, integer* cmode, doublereal* c, integer* info, doublereal* work, integer* iwork);


static VALUE
rblapack_dla_gercond(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_af;
  doublereal *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_cmode;
  integer cmode; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack___out__;
  doublereal __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  info, __out__ = NumRu::Lapack.dla_gercond( trans, a, af, ipiv, cmode, c, work, iwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION DLA_GERCOND ( TRANS, N, A, LDA, AF, LDAF, IPIV, CMODE, C, INFO, WORK, IWORK )\n\n*  Purpose\n*  =======\n*\n*     DLA_GERCOND estimates the Skeel condition number of op(A) * op2(C)\n*     where op2 is determined by CMODE as follows\n*     CMODE =  1    op2(C) = C\n*     CMODE =  0    op2(C) = I\n*     CMODE = -1    op2(C) = inv(C)\n*     The Skeel condition number cond(A) = norminf( |inv(A)||A| )\n*     is computed by computing scaling factors R such that\n*     diag(R)*A*op2(C) is row equilibrated and computing the standard\n*     infinity-norm condition number.\n*\n\n*  Arguments\n*  ==========\n*\n*     TRANS   (input) CHARACTER*1\n*     Specifies the form of the system of equations:\n*       = 'N':  A * X = B     (No transpose)\n*       = 'T':  A**T * X = B  (Transpose)\n*       = 'C':  A**H * X = B  (Conjugate Transpose = Transpose)\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) DOUBLE PRECISION array, dimension (LDAF,N)\n*     The factors L and U from the factorization\n*     A = P*L*U as computed by DGETRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     The pivot indices from the factorization A = P*L*U\n*     as computed by DGETRF; row i of the matrix was interchanged\n*     with row IPIV(i).\n*\n*     CMODE   (input) INTEGER\n*     Determines op2(C) in the formula op(A) * op2(C) as follows:\n*     CMODE =  1    op2(C) = C\n*     CMODE =  0    op2(C) = I\n*     CMODE = -1    op2(C) = inv(C)\n*\n*     C       (input) DOUBLE PRECISION array, dimension (N)\n*     The vector C in the formula op(A) * op2(C).\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit.\n*     i > 0:  The ith argument is invalid.\n*\n*     WORK    (input) DOUBLE PRECISION array, dimension (3*N).\n*     Workspace.\n*\n*     IWORK   (input) INTEGER array, dimension (N).\n*     Workspace.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            NOTRANS\n      INTEGER            KASE, I, J\n      DOUBLE PRECISION   AINVNM, TMP\n*     ..\n*     .. Local Arrays ..\n      INTEGER            ISAVE( 3 )\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DLACN2, DGETRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, __out__ = NumRu::Lapack.dla_gercond( trans, a, af, ipiv, cmode, c, work, iwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_trans = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_cmode = argv[4];
  rblapack_c = argv[5];
  rblapack_work = argv[6];
  rblapack_iwork = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_DFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
  af = NA_PTR_TYPE(rblapack_af, doublereal*);
  cmode = NUM2INT(rblapack_cmode);
  if (!NA_IsNArray(rblapack_iwork))
    rb_raise(rb_eArgError, "iwork (8th argument) must be NArray");
  if (NA_RANK(rblapack_iwork) != 1)
    rb_raise(rb_eArgError, "rank of iwork (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_iwork) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of iwork must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_iwork) != NA_LINT)
    rblapack_iwork = na_change_type(rblapack_iwork, NA_LINT);
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (7th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (3*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 3*n);
  if (NA_TYPE(rblapack_work) != NA_DFLOAT)
    rblapack_work = na_change_type(rblapack_work, NA_DFLOAT);
  work = NA_PTR_TYPE(rblapack_work, doublereal*);

  __out__ = dla_gercond_(&trans, &n, a, &lda, af, &ldaf, ipiv, &cmode, c, &info, work, iwork);

  rblapack_info = INT2NUM(info);
  rblapack___out__ = rb_float_new((double)__out__);
  return rb_ary_new3(2, rblapack_info, rblapack___out__);
}

void
init_lapack_dla_gercond(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dla_gercond", rblapack_dla_gercond, -1);
}
ruby-lapack-1.7.2/ext/claqhp.c0000644000175000017500000001165512502221013015777 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID claqhp_(char* uplo, integer* n, complex* ap, real* s, real* scond, real* amax, char* equed);


static VALUE
rblapack_claqhp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_scond;
  real scond; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_ap_out__;
  complex *ap_out__;

  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  equed, ap = NumRu::Lapack.claqhp( uplo, ap, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAQHP( UPLO, N, AP, S, SCOND, AMAX, EQUED )\n\n*  Purpose\n*  =======\n*\n*  CLAQHP equilibrates a Hermitian matrix A using the scaling factors\n*  in the vector S.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          Hermitian matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, the equilibrated matrix:  diag(S) * A * diag(S), in\n*          the same storage format as A.\n*\n*  S       (input) REAL array, dimension (N)\n*          The scale factors for A.\n*\n*  SCOND   (input) REAL\n*          Ratio of the smallest S(i) to the largest S(i).\n*\n*  AMAX    (input) REAL\n*          Absolute value of largest matrix entry.\n*\n*  EQUED   (output) CHARACTER*1\n*          Specifies whether or not equilibration was done.\n*          = 'N':  No equilibration.\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*\n*  Internal Parameters\n*  ===================\n*\n*  THRESH is a threshold value used to decide if scaling should be done\n*  based on the ratio of the scaling factors.  If SCOND < THRESH,\n*  scaling is done.\n*\n*  LARGE and SMALL are threshold values used to decide if scaling should\n*  be done based on the absolute size of the largest matrix element.\n*  If AMAX > LARGE or AMAX < SMALL, scaling is done.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  equed, ap = NumRu::Lapack.claqhp( uplo, ap, s, scond, amax, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_s = argv[2];
  rblapack_scond = argv[3];
  rblapack_amax = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (3th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_s);
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  amax = (real)NUM2DBL(rblapack_amax);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  scond = (real)NUM2DBL(rblapack_scond);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
  MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  claqhp_(&uplo, &n, ap, s, &scond, &amax, &equed);

  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(2, rblapack_equed, rblapack_ap);
}

void
init_lapack_claqhp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "claqhp", rblapack_claqhp, -1);
}
ruby-lapack-1.7.2/ext/slansb.c0000644000175000017500000001113112502221024016000 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real slansb_(char* norm, char* uplo, integer* n, integer* k, real* ab, integer* ldab, real* work);


static VALUE
rblapack_slansb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack___out__;
  real __out__; 
  real *work;

  integer ldab;
  integer n;
  integer lwork;

  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  __out__ = NumRu::Lapack.slansb( norm, uplo, k, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL             FUNCTION SLANSB( NORM, UPLO, N, K, AB, LDAB, WORK )\n\n*  Purpose\n*  =======\n*\n*  SLANSB  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the element of  largest absolute value  of an\n*  n by n symmetric band matrix A,  with k super-diagonals.\n*\n*  Description\n*  ===========\n*\n*  SLANSB returns the value\n*\n*     SLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in SLANSB as described\n*          above.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          band matrix A is supplied.\n*          = 'U':  Upper triangular part is supplied\n*          = 'L':  Lower triangular part is supplied\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, SLANSB is\n*          set to zero.\n*\n*  K       (input) INTEGER\n*          The number of super-diagonals or sub-diagonals of the\n*          band matrix A.  K >= 0.\n*\n*  AB      (input) REAL array, dimension (LDAB,N)\n*          The upper or lower triangle of the symmetric band matrix A,\n*          stored in the first K+1 rows of AB.  The j-th column of A is\n*          stored in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)   = A(i,j) for j<=i<=min(n,j+k).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= K+1.\n*\n*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n*          WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.slansb( norm, uplo, k, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_k = argv[2];
  rblapack_ab = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  k = NUM2INT(rblapack_k);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
  work = ALLOC_N(real, (MAX(1,lwork)));

  __out__ = slansb_(&norm, &uplo, &n, &k, ab, &ldab, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_slansb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slansb", rblapack_slansb, -1);
}
ruby-lapack-1.7.2/ext/dsysvxx.c0000644000175000017500000006537712502221024016273 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsysvxx_(char* fact, char* uplo, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* af, integer* ldaf, integer* ipiv, char* equed, doublereal* s, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* rpvgrw, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dsysvxx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_af;
  doublereal *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_params;
  doublereal *params; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_rpvgrw;
  doublereal rpvgrw; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_err_bnds_norm;
  doublereal *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  doublereal *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  VALUE rblapack_af_out__;
  doublereal *af_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  VALUE rblapack_s_out__;
  doublereal *s_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;
  VALUE rblapack_params_out__;
  doublereal *params_out__;
  doublereal *work;
  integer *iwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer nparams;
  integer ldx;
  integer n_err_bnds;

  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  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.dsysvxx( fact, uplo, a, af, ipiv, equed, s, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     DSYSVXX uses the diagonal pivoting factorization to compute the\n*     solution to a double precision system of linear equations A * X = B, where A\n*     is an N-by-N symmetric matrix and X and B are N-by-NRHS matrices.\n*\n*     If requested, both normwise and maximum componentwise error bounds\n*     are returned. DSYSVXX will return a solution with a tiny\n*     guaranteed error (O(eps) where eps is the working machine\n*     precision) unless the matrix is very ill-conditioned, in which\n*     case a warning is returned. Relevant condition numbers also are\n*     calculated and returned.\n*\n*     DSYSVXX accepts user-provided factorizations and equilibration\n*     factors; see the definitions of the FACT and EQUED options.\n*     Solving with refinement and using a factorization from a previous\n*     DSYSVXX call will also produce a solution with either O(eps)\n*     errors or warnings, but we cannot make that claim for general\n*     user-provided factorizations and equilibration factors if they\n*     differ from what DSYSVXX would itself produce.\n*\n*     Description\n*     ===========\n*\n*     The following steps are performed:\n*\n*     1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n*     the system:\n*\n*       diag(S)*A*diag(S)     *inv(diag(S))*X = diag(S)*B\n*\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n*     2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n*     the matrix A (after equilibration if FACT = 'E') as\n*\n*        A = U * D * U**T,  if UPLO = 'U', or\n*        A = L * D * L**T,  if UPLO = 'L',\n*\n*     where U (or L) is a product of permutation and unit upper (lower)\n*     triangular matrices, and D is symmetric and block diagonal with\n*     1-by-1 and 2-by-2 diagonal blocks.\n*\n*     3. If some D(i,i)=0, so that D is exactly singular, then the\n*     routine returns with INFO = i. Otherwise, the factored form of A\n*     is used to estimate the condition number of the matrix A (see\n*     argument RCOND).  If the reciprocal of the condition number is\n*     less than machine precision, the routine still goes on to solve\n*     for X and compute error bounds as described below.\n*\n*     4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*     5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n*     the routine will use iterative refinement to try to get a small\n*     error and error bounds.  Refinement calculates the residual to at\n*     least twice the working precision.\n*\n*     6. If equilibration was used, the matrix X is premultiplied by\n*     diag(R) so that it solves the original system before\n*     equilibration.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     FACT    (input) CHARACTER*1\n*     Specifies whether or not the factored form of the matrix A is\n*     supplied on entry, and if not, whether the matrix A should be\n*     equilibrated before it is factored.\n*       = 'F':  On entry, AF and IPIV contain the factored form of A.\n*               If EQUED is not 'N', the matrix A has been\n*               equilibrated with scaling factors given by S.\n*               A, AF, and IPIV are not modified.\n*       = 'N':  The matrix A will be copied to AF and factored.\n*       = 'E':  The matrix A will be equilibrated if necessary, then\n*               copied to AF and factored.\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*     The symmetric matrix A.  If UPLO = 'U', the leading N-by-N\n*     upper triangular part of A contains the upper triangular\n*     part of the matrix A, and the strictly lower triangular\n*     part of A is not referenced.  If UPLO = 'L', the leading\n*     N-by-N lower triangular part of A contains the lower\n*     triangular part of the matrix A, and the strictly upper\n*     triangular part of A is not referenced.\n*\n*     On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n*     diag(S)*A*diag(S).\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input or output) DOUBLE PRECISION array, dimension (LDAF,N)\n*     If FACT = 'F', then AF is an input argument and on entry\n*     contains the block diagonal matrix D and the multipliers\n*     used to obtain the factor U or L from the factorization A =\n*     U*D*U**T or A = L*D*L**T as computed by DSYTRF.\n*\n*     If FACT = 'N', then AF is an output argument and on exit\n*     returns the block diagonal matrix D and the multipliers\n*     used to obtain the factor U or L from the factorization A =\n*     U*D*U**T or A = L*D*L**T.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input or output) INTEGER array, dimension (N)\n*     If FACT = 'F', then IPIV is an input argument and on entry\n*     contains details of the interchanges and the block\n*     structure of D, as determined by DSYTRF.  If IPIV(k) > 0,\n*     then rows and columns k and IPIV(k) were interchanged and\n*     D(k,k) is a 1-by-1 diagonal block.  If UPLO = 'U' and\n*     IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and\n*     -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2\n*     diagonal block.  If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0,\n*     then rows and columns k+1 and -IPIV(k) were interchanged\n*     and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*     If FACT = 'N', then IPIV is an output argument and on exit\n*     contains details of the interchanges and the block\n*     structure of D, as determined by DSYTRF.\n*\n*     EQUED   (input or output) CHARACTER*1\n*     Specifies the form of equilibration that was done.\n*       = 'N':  No equilibration (always true if FACT = 'N').\n*       = 'Y':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(S) * A * diag(S).\n*     EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*     output argument.\n*\n*     S       (input or output) DOUBLE PRECISION array, dimension (N)\n*     The scale factors for A.  If EQUED = 'Y', A is multiplied on\n*     the left and right by diag(S).  S is an input argument if FACT =\n*     'F'; otherwise, S is an output argument.  If FACT = 'F' and EQUED\n*     = 'Y', each element of S must be positive.  If S is output, each\n*     element of S is a power of the radix. If S is input, each element\n*     of S should be a power of the radix to ensure a reliable solution\n*     and error estimates. Scaling by powers of the radix does not cause\n*     rounding errors unless the result underflows or overflows.\n*     Rounding errors during scaling lead to refining with a matrix that\n*     is not equivalent to the input matrix, producing error estimates\n*     that may not be reliable.\n*\n*     B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*     On entry, the N-by-NRHS right hand side matrix B.\n*     On exit,\n*     if EQUED = 'N', B is not modified;\n*     if EQUED = 'Y', B is overwritten by diag(S)*B;\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*     If INFO = 0, the N-by-NRHS solution matrix X to the original\n*     system of equations.  Note that A and B are modified on exit if\n*     EQUED .ne. 'N', and the solution to the equilibrated system is\n*     inv(diag(S))*X.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) DOUBLE PRECISION\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     RPVGRW  (output) DOUBLE PRECISION\n*     Reciprocal pivot growth.  On exit, this contains the reciprocal\n*     pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n*     norm is used.  If this is much less than 1, then the stability of\n*     the LU factorization of the (equilibrated) matrix A could be poor.\n*     This also means that the solution X, estimated condition numbers,\n*     and error bounds could be unreliable. If factorization fails with\n*     0 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.dsysvxx( fact, uplo, a, af, ipiv, equed, s, b, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_equed = argv[5];
  rblapack_s = argv[6];
  rblapack_b = argv[7];
  rblapack_params = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (7th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (9th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_DFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
  params = NA_PTR_TYPE(rblapack_params, doublereal*);
  n_err_bnds = 3;
  uplo = StringValueCStr(rblapack_uplo)[0];
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
  af = NA_PTR_TYPE(rblapack_af, doublereal*);
  ldx = MAX(1,n);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[2];
    shape[0] = ldaf;
    shape[1] = n;
    rblapack_af_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  af_out__ = NA_PTR_TYPE(rblapack_af_out__, doublereal*);
  MEMCPY(af_out__, af, doublereal, NA_TOTAL(rblapack_af));
  rblapack_af = rblapack_af_out__;
  af = af_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
  MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
  MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(doublereal, (4*n));
  iwork = ALLOC_N(integer, (n));

  dsysvxx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, s, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_rpvgrw = rb_float_new((double)rpvgrw);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(14, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_a, rblapack_af, rblapack_ipiv, rblapack_equed, rblapack_s, rblapack_b, rblapack_params);
}

void
init_lapack_dsysvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsysvxx", rblapack_dsysvxx, -1);
}
ruby-lapack-1.7.2/ext/zsyrfsx.c0000644000175000017500000005225512502221017016264 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zsyrfsx_(char* uplo, char* equed, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublereal* s, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zsyrfsx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_params;
  doublereal *params; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_err_bnds_norm;
  doublereal *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  doublereal *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_s_out__;
  doublereal *s_out__;
  VALUE rblapack_x_out__;
  doublecomplex *x_out__;
  VALUE rblapack_params_out__;
  doublereal *params_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;
  integer nparams;
  integer n_err_bnds;

  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  rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.zsyrfsx( uplo, equed, a, af, ipiv, s, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     ZSYRFSX improves the computed solution to a system of linear\n*     equations when the coefficient matrix is symmetric indefinite, and\n*     provides error bounds and backward error estimates for the\n*     solution.  In addition to normwise error bound, the code provides\n*     maximum componentwise error bound if possible.  See comments for\n*     ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.\n*\n*     The original system of linear equations may have been equilibrated\n*     before calling this routine, as described by arguments EQUED and S\n*     below. In this case, the solution and error bounds returned are\n*     for the original unequilibrated system.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     EQUED   (input) CHARACTER*1\n*     Specifies the form of equilibration that was done to A\n*     before calling this routine. This is needed to compute\n*     the solution and error bounds correctly.\n*       = 'N':  No equilibration\n*       = 'Y':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(S) * A * diag(S).\n*               The right hand side B has been changed accordingly.\n*\n*     N       (input) INTEGER\n*     The order of the matrix A.  N >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     A       (input) COMPLEX*16 array, dimension (LDA,N)\n*     The symmetric matrix A.  If UPLO = 'U', the leading N-by-N\n*     upper triangular part of A contains the upper triangular\n*     part of the matrix A, and the strictly lower triangular\n*     part of A is not referenced.  If UPLO = 'L', the leading\n*     N-by-N lower triangular part of A contains the lower\n*     triangular part of the matrix A, and the strictly upper\n*     triangular part of A is not referenced.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX*16 array, dimension (LDAF,N)\n*     The factored form of the matrix A.  AF contains the block\n*     diagonal matrix D and the multipliers used to obtain the\n*     factor U or L from the factorization A = U*D*U**T or A =\n*     L*D*L**T as computed by DSYTRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     Details of the interchanges and the block structure of D\n*     as determined by DSYTRF.\n*\n*     S       (input or output) DOUBLE PRECISION array, dimension (N)\n*     The scale factors for A.  If EQUED = 'Y', A is multiplied on\n*     the left and right by diag(S).  S is an input argument if FACT =\n*     'F'; otherwise, S is an output argument.  If FACT = 'F' and EQUED\n*     = 'Y', each element of S must be positive.  If S is output, each\n*     element of S is a power of the radix. If S is input, each element\n*     of S should be a power of the radix to ensure a reliable solution\n*     and error estimates. Scaling by powers of the radix does not cause\n*     rounding errors unless the result underflows or overflows.\n*     Rounding errors during scaling lead to refining with a matrix that\n*     is not equivalent to the input matrix, producing error estimates\n*     that may not be reliable.\n*\n*     B       (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*     The right hand side matrix B.\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (input/output) COMPLEX*16 array, dimension (LDX,NRHS)\n*     On entry, the solution matrix X, as computed by DGETRS.\n*     On exit, the improved solution matrix X.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) DOUBLE PRECISION\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*     Componentwise relative backward error.  This is the\n*     componentwise relative backward error of each solution vector X(j)\n*     (i.e., the smallest relative change in any element of A or B that\n*     makes X(j) an exact solution).\n*\n*     N_ERR_BNDS (input) INTEGER\n*     Number of error bounds to return for each right hand side\n*     and each type (normwise or componentwise).  See ERR_BNDS_NORM and\n*     ERR_BNDS_COMP below.\n*\n*     ERR_BNDS_NORM  (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * dlamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * dlamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * dlamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * dlamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * dlamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * dlamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     NPARAMS (input) INTEGER\n*     Specifies the number of parameters set in PARAMS.  If .LE. 0, the\n*     PARAMS array is never referenced and default values are used.\n*\n*     PARAMS  (input / output) DOUBLE PRECISION array, dimension NPARAMS\n*     Specifies algorithm parameters.  If an entry is .LT. 0.0, then\n*     that entry will be filled with default value used for that\n*     parameter.  Only positions up to NPARAMS are accessed; defaults\n*     are used for higher-numbered parameters.\n*\n*       PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n*            refinement or not.\n*         Default: 1.0D+0\n*            = 0.0 : No refinement is performed, and no error bounds are\n*                    computed.\n*            = 1.0 : Use the double-precision refinement algorithm,\n*                    possibly with doubled-single computations if the\n*                    compilation environment does not support DOUBLE\n*                    PRECISION.\n*              (other values are reserved for future use)\n*\n*       PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n*            computations allowed for refinement.\n*         Default: 10\n*         Aggressive: Set to 100 to permit convergence using approximate\n*                     factorizations or factorizations other than LU. If\n*                     the factorization uses a technique other than\n*                     Gaussian elimination, the guarantees in\n*                     err_bnds_norm and err_bnds_comp may no longer be\n*                     trustworthy.\n*\n*       PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n*            will attempt to find a solution with small componentwise\n*            relative error in the double-precision algorithm.  Positive\n*            is true, 0.0 is false.\n*         Default: 1.0 (attempt componentwise convergence)\n*\n*     WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*     RWORK   (workspace) DOUBLE PRECISION array, dimension (2*N)\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit. The solution to every right-hand side is\n*         guaranteed.\n*       < 0:  If INFO = -i, the i-th argument had an illegal value\n*       > 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.zsyrfsx( uplo, equed, a, af, ipiv, s, b, x, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_uplo = argv[0];
  rblapack_equed = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_s = argv[5];
  rblapack_b = argv[6];
  rblapack_x = argv[7];
  rblapack_params = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (9th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_DFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
  params = NA_PTR_TYPE(rblapack_params, doublereal*);
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (6th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  n_err_bnds = 3;
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (8th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (8th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
  MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublecomplex*);
  MEMCPY(x_out__, x, doublecomplex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
  MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (2*n));

  zsyrfsx_(&uplo, &equed, &n, &nrhs, a, &lda, af, &ldaf, ipiv, s, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_s, rblapack_x, rblapack_params);
}

void
init_lapack_zsyrfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zsyrfsx", rblapack_zsyrfsx, -1);
}
ruby-lapack-1.7.2/ext/clascl.c0000644000175000017500000001221612502221016015765 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clascl_(char* type, integer* kl, integer* ku, real* cfrom, real* cto, integer* m, integer* n, complex* a, integer* lda, integer* info);


static VALUE
rblapack_clascl(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_type;
  char type; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_cfrom;
  real cfrom; 
  VALUE rblapack_cto;
  real cto; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *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  info, a = NumRu::Lapack.clascl( type, kl, ku, cfrom, cto, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  CLASCL multiplies the M by N complex matrix A by the real scalar\n*  CTO/CFROM.  This is done without over/underflow as long as the final\n*  result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that\n*  A may be full, upper triangular, lower triangular, upper Hessenberg,\n*  or banded.\n*\n\n*  Arguments\n*  =========\n*\n*  TYPE    (input) CHARACTER*1\n*          TYPE indices the storage type of the input matrix.\n*          = 'G':  A is a full matrix.\n*          = 'L':  A is a lower triangular matrix.\n*          = 'U':  A is an upper triangular matrix.\n*          = 'H':  A is an upper Hessenberg matrix.\n*          = 'B':  A is a symmetric band matrix with lower bandwidth KL\n*                  and upper bandwidth KU and with the only the lower\n*                  half stored.\n*          = 'Q':  A is a symmetric band matrix with lower bandwidth KL\n*                  and upper bandwidth KU and with the only the upper\n*                  half stored.\n*          = 'Z':  A is a band matrix with lower bandwidth KL and upper\n*                  bandwidth KU. See CGBTRF for storage details.\n*\n*  KL      (input) INTEGER\n*          The lower bandwidth of A.  Referenced only if TYPE = 'B',\n*          'Q' or 'Z'.\n*\n*  KU      (input) INTEGER\n*          The upper bandwidth of A.  Referenced only if TYPE = 'B',\n*          'Q' or 'Z'.\n*\n*  CFROM   (input) REAL\n*  CTO     (input) REAL\n*          The matrix A is multiplied by CTO/CFROM. A(I,J) is computed\n*          without over/underflow if the final result CTO*A(I,J)/CFROM\n*          can be represented without over/underflow.  CFROM must be\n*          nonzero.\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) COMPLEX array, dimension (LDA,N)\n*          The matrix to be multiplied by CTO/CFROM.  See TYPE for the\n*          storage type.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.clascl( type, kl, ku, cfrom, cto, m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_type = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_cfrom = argv[3];
  rblapack_cto = argv[4];
  rblapack_m = argv[5];
  rblapack_a = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  type = StringValueCStr(rblapack_type)[0];
  ku = NUM2INT(rblapack_ku);
  cto = (real)NUM2DBL(rblapack_cto);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (7th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (7th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  kl = NUM2INT(rblapack_kl);
  m = NUM2INT(rblapack_m);
  cfrom = (real)NUM2DBL(rblapack_cfrom);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  clascl_(&type, &kl, &ku, &cfrom, &cto, &m, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_clascl(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clascl", rblapack_clascl, -1);
}
ruby-lapack-1.7.2/ext/slals0.c0000644000175000017500000003116312502221020015717 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slals0_(integer* icompq, integer* nl, integer* nr, integer* sqre, integer* nrhs, real* b, integer* ldb, real* bx, integer* ldbx, integer* perm, integer* givptr, integer* givcol, integer* ldgcol, real* givnum, integer* ldgnum, real* poles, real* difl, real* difr, real* z, integer* k, real* c, real* s, real* work, integer* info);


static VALUE
rblapack_slals0(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_icompq;
  integer icompq; 
  VALUE rblapack_nl;
  integer nl; 
  VALUE rblapack_nr;
  integer nr; 
  VALUE rblapack_sqre;
  integer sqre; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_perm;
  integer *perm; 
  VALUE rblapack_givptr;
  integer givptr; 
  VALUE rblapack_givcol;
  integer *givcol; 
  VALUE rblapack_givnum;
  real *givnum; 
  VALUE rblapack_poles;
  real *poles; 
  VALUE rblapack_difl;
  real *difl; 
  VALUE rblapack_difr;
  real *difr; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_c;
  real c; 
  VALUE rblapack_s;
  real s; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  real *b_out__;
  real *bx;
  real *work;

  integer ldb;
  integer nrhs;
  integer n;
  integer ldgcol;
  integer ldgnum;
  integer k;
  integer ldbx;

  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  info, b = NumRu::Lapack.slals0( icompq, nl, nr, sqre, b, perm, givptr, givcol, givnum, poles, difl, difr, z, c, s, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLALS0 applies back the multiplying factors of either the left or the\n*  right singular vector matrix of a diagonal matrix appended by a row\n*  to the right hand side matrix B in solving the least squares problem\n*  using the divide-and-conquer SVD approach.\n*\n*  For the left singular vector matrix, three types of orthogonal\n*  matrices are involved:\n*\n*  (1L) Givens rotations: the number of such rotations is GIVPTR; the\n*       pairs of columns/rows they were applied to are stored in GIVCOL;\n*       and the C- and S-values of these rotations are stored in GIVNUM.\n*\n*  (2L) Permutation. The (NL+1)-st row of B is to be moved to the first\n*       row, and for J=2:N, PERM(J)-th row of B is to be moved to the\n*       J-th row.\n*\n*  (3L) The left singular vector matrix of the remaining matrix.\n*\n*  For the right singular vector matrix, four types of orthogonal\n*  matrices are involved:\n*\n*  (1R) The right singular vector matrix of the remaining matrix.\n*\n*  (2R) If SQRE = 1, one extra Givens rotation to generate the right\n*       null space.\n*\n*  (3R) The inverse transformation of (2L).\n*\n*  (4R) The inverse transformation of (1L).\n*\n\n*  Arguments\n*  =========\n*\n*  ICOMPQ (input) INTEGER\n*         Specifies whether singular vectors are to be computed in\n*         factored form:\n*         = 0: Left singular vector matrix.\n*         = 1: Right singular vector matrix.\n*\n*  NL     (input) INTEGER\n*         The row dimension of the upper block. NL >= 1.\n*\n*  NR     (input) INTEGER\n*         The row dimension of the lower block. NR >= 1.\n*\n*  SQRE   (input) INTEGER\n*         = 0: the lower block is an NR-by-NR square matrix.\n*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n*         The bidiagonal matrix has row dimension N = NL + NR + 1,\n*         and column dimension M = N + SQRE.\n*\n*  NRHS   (input) INTEGER\n*         The number of columns of B and BX. NRHS must be at least 1.\n*\n*  B      (input/output) REAL array, dimension ( LDB, NRHS )\n*         On input, B contains the right hand sides of the least\n*         squares problem in rows 1 through M. On output, B contains\n*         the solution X in rows 1 through N.\n*\n*  LDB    (input) INTEGER\n*         The leading dimension of B. LDB must be at least\n*         max(1,MAX( M, N ) ).\n*\n*  BX     (workspace) REAL array, dimension ( LDBX, NRHS )\n*\n*  LDBX   (input) INTEGER\n*         The leading dimension of BX.\n*\n*  PERM   (input) INTEGER array, dimension ( N )\n*         The permutations (from deflation and sorting) applied\n*         to the two blocks.\n*\n*  GIVPTR (input) INTEGER\n*         The number of Givens rotations which took place in this\n*         subproblem.\n*\n*  GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )\n*         Each pair of numbers indicates a pair of rows/columns\n*         involved in a Givens rotation.\n*\n*  LDGCOL (input) INTEGER\n*         The leading dimension of GIVCOL, must be at least N.\n*\n*  GIVNUM (input) REAL array, dimension ( LDGNUM, 2 )\n*         Each number indicates the C or S value used in the\n*         corresponding Givens rotation.\n*\n*  LDGNUM (input) INTEGER\n*         The leading dimension of arrays DIFR, POLES and\n*         GIVNUM, must be at least K.\n*\n*  POLES  (input) REAL array, dimension ( LDGNUM, 2 )\n*         On entry, POLES(1:K, 1) contains the new singular\n*         values obtained from solving the secular equation, and\n*         POLES(1:K, 2) is an array containing the poles in the secular\n*         equation.\n*\n*  DIFL   (input) REAL array, dimension ( K ).\n*         On entry, DIFL(I) is the distance between I-th updated\n*         (undeflated) singular value and the I-th (undeflated) old\n*         singular value.\n*\n*  DIFR   (input) REAL array, dimension ( LDGNUM, 2 ).\n*         On entry, DIFR(I, 1) contains the distances between I-th\n*         updated (undeflated) singular value and the I+1-th\n*         (undeflated) old singular value. And DIFR(I, 2) is the\n*         normalizing factor for the I-th right singular vector.\n*\n*  Z      (input) REAL array, dimension ( K )\n*         Contain the components of the deflation-adjusted updating row\n*         vector.\n*\n*  K      (input) INTEGER\n*         Contains the dimension of the non-deflated matrix,\n*         This is the order of the related secular equation. 1 <= K <=N.\n*\n*  C      (input) REAL\n*         C contains garbage if SQRE =0 and the C-value of a Givens\n*         rotation related to the right null space if SQRE = 1.\n*\n*  S      (input) REAL\n*         S contains garbage if SQRE =0 and the S-value of a Givens\n*         rotation related to the right null space if SQRE = 1.\n*\n*  WORK   (workspace) REAL array, dimension ( K )\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*  Based on contributions by\n*     Ming Gu and Ren-Cang Li, Computer Science Division, University of\n*       California at Berkeley, USA\n*     Osni Marques, LBNL/NERSC, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.slals0( icompq, nl, nr, sqre, b, perm, givptr, givcol, givnum, poles, difl, difr, z, c, s, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 15 && argc != 15)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
  rblapack_icompq = argv[0];
  rblapack_nl = argv[1];
  rblapack_nr = argv[2];
  rblapack_sqre = argv[3];
  rblapack_b = argv[4];
  rblapack_perm = argv[5];
  rblapack_givptr = argv[6];
  rblapack_givcol = argv[7];
  rblapack_givnum = argv[8];
  rblapack_poles = argv[9];
  rblapack_difl = argv[10];
  rblapack_difr = argv[11];
  rblapack_z = argv[12];
  rblapack_c = argv[13];
  rblapack_s = argv[14];
  if (argc == 15) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  icompq = NUM2INT(rblapack_icompq);
  nr = NUM2INT(rblapack_nr);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  givptr = NUM2INT(rblapack_givptr);
  if (!NA_IsNArray(rblapack_givnum))
    rb_raise(rb_eArgError, "givnum (9th argument) must be NArray");
  if (NA_RANK(rblapack_givnum) != 2)
    rb_raise(rb_eArgError, "rank of givnum (9th argument) must be %d", 2);
  ldgnum = NA_SHAPE0(rblapack_givnum);
  if (NA_SHAPE1(rblapack_givnum) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", 2);
  if (NA_TYPE(rblapack_givnum) != NA_SFLOAT)
    rblapack_givnum = na_change_type(rblapack_givnum, NA_SFLOAT);
  givnum = NA_PTR_TYPE(rblapack_givnum, real*);
  if (!NA_IsNArray(rblapack_difl))
    rb_raise(rb_eArgError, "difl (11th argument) must be NArray");
  if (NA_RANK(rblapack_difl) != 1)
    rb_raise(rb_eArgError, "rank of difl (11th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_difl);
  if (NA_TYPE(rblapack_difl) != NA_SFLOAT)
    rblapack_difl = na_change_type(rblapack_difl, NA_SFLOAT);
  difl = NA_PTR_TYPE(rblapack_difl, real*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (13th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (13th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_z) != k)
    rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of difl");
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  s = (real)NUM2DBL(rblapack_s);
  nl = NUM2INT(rblapack_nl);
  if (!NA_IsNArray(rblapack_perm))
    rb_raise(rb_eArgError, "perm (6th argument) must be NArray");
  if (NA_RANK(rblapack_perm) != 1)
    rb_raise(rb_eArgError, "rank of perm (6th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_perm);
  if (NA_TYPE(rblapack_perm) != NA_LINT)
    rblapack_perm = na_change_type(rblapack_perm, NA_LINT);
  perm = NA_PTR_TYPE(rblapack_perm, integer*);
  if (!NA_IsNArray(rblapack_poles))
    rb_raise(rb_eArgError, "poles (10th argument) must be NArray");
  if (NA_RANK(rblapack_poles) != 2)
    rb_raise(rb_eArgError, "rank of poles (10th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_poles) != ldgnum)
    rb_raise(rb_eRuntimeError, "shape 0 of poles must be the same as shape 0 of givnum");
  if (NA_SHAPE1(rblapack_poles) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of poles must be %d", 2);
  if (NA_TYPE(rblapack_poles) != NA_SFLOAT)
    rblapack_poles = na_change_type(rblapack_poles, NA_SFLOAT);
  poles = NA_PTR_TYPE(rblapack_poles, real*);
  c = (real)NUM2DBL(rblapack_c);
  sqre = NUM2INT(rblapack_sqre);
  if (!NA_IsNArray(rblapack_difr))
    rb_raise(rb_eArgError, "difr (12th argument) must be NArray");
  if (NA_RANK(rblapack_difr) != 2)
    rb_raise(rb_eArgError, "rank of difr (12th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_difr) != ldgnum)
    rb_raise(rb_eRuntimeError, "shape 0 of difr must be the same as shape 0 of givnum");
  if (NA_SHAPE1(rblapack_difr) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of difr must be %d", 2);
  if (NA_TYPE(rblapack_difr) != NA_SFLOAT)
    rblapack_difr = na_change_type(rblapack_difr, NA_SFLOAT);
  difr = NA_PTR_TYPE(rblapack_difr, real*);
  if (!NA_IsNArray(rblapack_givcol))
    rb_raise(rb_eArgError, "givcol (8th argument) must be NArray");
  if (NA_RANK(rblapack_givcol) != 2)
    rb_raise(rb_eArgError, "rank of givcol (8th argument) must be %d", 2);
  ldgcol = NA_SHAPE0(rblapack_givcol);
  if (NA_SHAPE1(rblapack_givcol) != (2))
    rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", 2);
  if (NA_TYPE(rblapack_givcol) != NA_LINT)
    rblapack_givcol = na_change_type(rblapack_givcol, NA_LINT);
  givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
  ldbx = n;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  bx = ALLOC_N(real, (ldbx)*(nrhs));
  work = ALLOC_N(real, (k));

  slals0_(&icompq, &nl, &nr, &sqre, &nrhs, b, &ldb, bx, &ldbx, perm, &givptr, givcol, &ldgcol, givnum, &ldgnum, poles, difl, difr, z, &k, &c, &s, work, &info);

  free(bx);
  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_slals0(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slals0", rblapack_slals0, -1);
}
ruby-lapack-1.7.2/ext/cgerfsx.c0000644000175000017500000005234612502221015016174 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgerfsx_(char* trans, char* equed, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, real* r, real* c, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cgerfsx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_r;
  real *r; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_params;
  real *params; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_err_bnds_norm;
  real *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  real *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  complex *x_out__;
  VALUE rblapack_params_out__;
  real *params_out__;
  complex *work;
  real *rwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;
  integer nparams;
  integer n_err_bnds;

  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  rcond, berr, err_bnds_norm, err_bnds_comp, info, x, params = NumRu::Lapack.cgerfsx( trans, equed, a, af, ipiv, r, c, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     CGERFSX improves the computed solution to a system of linear\n*     equations and provides error bounds and backward error estimates\n*     for the solution.  In addition to normwise error bound, the code\n*     provides maximum componentwise error bound if possible.  See\n*     comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n*     error bounds.\n*\n*     The original system of linear equations may have been equilibrated\n*     before calling this routine, as described by arguments EQUED, R\n*     and C below. In this case, the solution and error bounds returned\n*     are for the original unequilibrated system.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     TRANS   (input) CHARACTER*1\n*     Specifies the form of the system of equations:\n*       = 'N':  A * X = B     (No transpose)\n*       = 'T':  A**T * X = B  (Transpose)\n*       = 'C':  A**H * X = B  (Conjugate transpose = Transpose)\n*\n*     EQUED   (input) CHARACTER*1\n*     Specifies the form of equilibration that was done to A\n*     before calling this routine. This is needed to compute\n*     the solution and error bounds correctly.\n*       = 'N':  No equilibration\n*       = 'R':  Row equilibration, i.e., A has been premultiplied by\n*               diag(R).\n*       = 'C':  Column equilibration, i.e., A has been postmultiplied\n*               by diag(C).\n*       = 'B':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(R) * A * diag(C).\n*               The right hand side B has been changed accordingly.\n*\n*     N       (input) INTEGER\n*     The order of the matrix A.  N >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     A       (input) COMPLEX array, dimension (LDA,N)\n*     The original N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX array, dimension (LDAF,N)\n*     The factors L and U from the factorization A = P*L*U\n*     as computed by CGETRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     The pivot indices from CGETRF; for 1<=i<=N, row i of the\n*     matrix was interchanged with row IPIV(i).\n*\n*     R       (input) REAL array, dimension (N)\n*     The row scale factors for A.  If EQUED = 'R' or 'B', A is\n*     multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n*     is not accessed. \n*     If R is accessed, each element of R should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     C       (input) REAL array, dimension (N)\n*     The column scale factors for A.  If EQUED = 'C' or 'B', A is\n*     multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n*     is not accessed. \n*     If C is accessed, each element of C should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B       (input) COMPLEX array, dimension (LDB,NRHS)\n*     The right hand side matrix B.\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (input/output) COMPLEX array, dimension (LDX,NRHS)\n*     On entry, the solution matrix X, as computed by CGETRS.\n*     On exit, the improved solution matrix X.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) REAL\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     BERR    (output) REAL array, dimension (NRHS)\n*     Componentwise relative backward error.  This is the\n*     componentwise relative backward error of each solution vector X(j)\n*     (i.e., the smallest relative change in any element of A or B that\n*     makes X(j) an exact solution).\n*\n*     N_ERR_BNDS (input) INTEGER\n*     Number of error bounds to return for each right hand side\n*     and each type (normwise or componentwise).  See ERR_BNDS_NORM and\n*     ERR_BNDS_COMP below.\n*\n*     ERR_BNDS_NORM  (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (output) REAL array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     NPARAMS (input) INTEGER\n*     Specifies the number of parameters set in PARAMS.  If .LE. 0, the\n*     PARAMS array is never referenced and default values are used.\n*\n*     PARAMS  (input / output) REAL array, dimension NPARAMS\n*     Specifies algorithm parameters.  If an entry is .LT. 0.0, then\n*     that entry will be filled with default value used for that\n*     parameter.  Only positions up to NPARAMS are accessed; defaults\n*     are used for higher-numbered parameters.\n*\n*       PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n*            refinement or not.\n*         Default: 1.0\n*            = 0.0 : No refinement is performed, and no error bounds are\n*                    computed.\n*            = 1.0 : Use the double-precision refinement algorithm,\n*                    possibly with doubled-single computations if the\n*                    compilation environment does not support DOUBLE\n*                    PRECISION.\n*              (other values are reserved for future use)\n*\n*       PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n*            computations allowed for refinement.\n*         Default: 10\n*         Aggressive: Set to 100 to permit convergence using approximate\n*                     factorizations or factorizations other than LU. If\n*                     the factorization uses a technique other than\n*                     Gaussian elimination, the guarantees in\n*                     err_bnds_norm and err_bnds_comp may no longer be\n*                     trustworthy.\n*\n*       PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n*            will attempt to find a solution with small componentwise\n*            relative error in the double-precision algorithm.  Positive\n*            is true, 0.0 is false.\n*         Default: 1.0 (attempt componentwise convergence)\n*\n*     WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*     RWORK   (workspace) REAL array, dimension (2*N)\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit. The solution to every right-hand side is\n*         guaranteed.\n*       < 0:  If INFO = -i, the i-th argument had an illegal value\n*       > 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, berr, err_bnds_norm, err_bnds_comp, info, x, params = NumRu::Lapack.cgerfsx( trans, equed, a, af, ipiv, r, c, b, x, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_trans = argv[0];
  rblapack_equed = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_r = argv[5];
  rblapack_c = argv[6];
  rblapack_b = argv[7];
  rblapack_x = argv[8];
  rblapack_params = argv[9];
  if (argc == 10) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (9th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (9th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  n_err_bnds = 3;
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_r))
    rb_raise(rb_eArgError, "r (6th argument) must be NArray");
  if (NA_RANK(rblapack_r) != 1)
    rb_raise(rb_eArgError, "rank of r (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_r) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_r) != NA_SFLOAT)
    rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
  r = NA_PTR_TYPE(rblapack_r, real*);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (10th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (10th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_SFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
  params = NA_PTR_TYPE(rblapack_params, real*);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
  MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (2*n));

  cgerfsx_(&trans, &equed, &n, &nrhs, a, &lda, af, &ldaf, ipiv, r, c, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_x, rblapack_params);
}

void
init_lapack_cgerfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgerfsx", rblapack_cgerfsx, -1);
}
ruby-lapack-1.7.2/ext/sspcon.c0000644000175000017500000001115312502221026016031 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sspcon_(char* uplo, integer* n, real* ap, integer* ipiv, real* anorm, real* rcond, real* work, integer* iwork, integer* info);


static VALUE
rblapack_sspcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_anorm;
  real anorm; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_info;
  integer info; 
  real *work;
  integer *iwork;

  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  rcond, info = NumRu::Lapack.sspcon( uplo, ap, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSPCON estimates the reciprocal of the condition number (in the\n*  1-norm) of a real symmetric packed matrix A using the factorization\n*  A = U*D*U**T or A = L*D*L**T computed by SSPTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input) REAL array, dimension (N*(N+1)/2)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by SSPTRF, stored as a\n*          packed triangular matrix.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by SSPTRF.\n*\n*  ANORM   (input) REAL\n*          The 1-norm of the original matrix A.\n*\n*  RCOND   (output) REAL\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n*          estimate of the 1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) REAL array, dimension (2*N)\n*\n*  IWORK    (workspace) INTEGER array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.sspcon( uplo, ap, ipiv, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_anorm = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  anorm = (real)NUM2DBL(rblapack_anorm);
  work = ALLOC_N(real, (2*n));
  iwork = ALLOC_N(integer, (n));

  sspcon_(&uplo, &n, ap, ipiv, &anorm, &rcond, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_sspcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sspcon", rblapack_sspcon, -1);
}
ruby-lapack-1.7.2/ext/zgesvd.c0000644000175000017500000002366612502221012016035 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgesvd_(char* jobu, char* jobvt, integer* m, integer* n, doublecomplex* a, integer* lda, doublereal* s, doublecomplex* u, integer* ldu, doublecomplex* vt, integer* ldvt, doublecomplex* work, integer* lwork, doublereal* rwork, integer* info);


static VALUE
rblapack_zgesvd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobu;
  char jobu; 
  VALUE rblapack_jobvt;
  char jobvt; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_u;
  doublecomplex *u; 
  VALUE rblapack_vt;
  doublecomplex *vt; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  doublereal *rwork;

  integer lda;
  integer n;
  integer ldu;
  integer ldvt;
  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  s, u, vt, work, info, a = NumRu::Lapack.zgesvd( jobu, jobvt, a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGESVD computes the singular value decomposition (SVD) of a complex\n*  M-by-N matrix A, optionally computing the left and/or right singular\n*  vectors. The SVD is written\n*\n*       A = U * SIGMA * conjugate-transpose(V)\n*\n*  where SIGMA is an M-by-N matrix which is zero except for its\n*  min(m,n) diagonal elements, U is an M-by-M unitary matrix, and\n*  V is an N-by-N unitary matrix.  The diagonal elements of SIGMA\n*  are the singular values of A; they are real and non-negative, and\n*  are returned in descending order.  The first min(m,n) columns of\n*  U and V are the left and right singular vectors of A.\n*\n*  Note that the routine returns V**H, not V.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBU    (input) CHARACTER*1\n*          Specifies options for computing all or part of the matrix U:\n*          = 'A':  all M columns of U are returned in array U:\n*          = 'S':  the first min(m,n) columns of U (the left singular\n*                  vectors) are returned in the array U;\n*          = 'O':  the first min(m,n) columns of U (the left singular\n*                  vectors) are overwritten on the array A;\n*          = 'N':  no columns of U (no left singular vectors) are\n*                  computed.\n*\n*  JOBVT   (input) CHARACTER*1\n*          Specifies options for computing all or part of the matrix\n*          V**H:\n*          = 'A':  all N rows of V**H are returned in the array VT;\n*          = 'S':  the first min(m,n) rows of V**H (the right singular\n*                  vectors) are returned in the array VT;\n*          = 'O':  the first min(m,n) rows of V**H (the right singular\n*                  vectors) are overwritten on the array A;\n*          = 'N':  no rows of V**H (no right singular vectors) are\n*                  computed.\n*\n*          JOBVT and JOBU cannot both be 'O'.\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.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit,\n*          if JOBU = 'O',  A is overwritten with the first min(m,n)\n*                          columns of U (the left singular vectors,\n*                          stored columnwise);\n*          if JOBVT = 'O', A is overwritten with the first min(m,n)\n*                          rows of V**H (the right singular vectors,\n*                          stored rowwise);\n*          if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A\n*                          are destroyed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  S       (output) DOUBLE PRECISION array, dimension (min(M,N))\n*          The singular values of A, sorted so that S(i) >= S(i+1).\n*\n*  U       (output) COMPLEX*16 array, dimension (LDU,UCOL)\n*          (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.\n*          If JOBU = 'A', U contains the M-by-M unitary matrix U;\n*          if JOBU = 'S', U contains the first min(m,n) columns of U\n*          (the left singular vectors, stored columnwise);\n*          if JOBU = 'N' or 'O', U is not referenced.\n*\n*  LDU     (input) INTEGER\n*          The leading dimension of the array U.  LDU >= 1; if\n*          JOBU = 'S' or 'A', LDU >= M.\n*\n*  VT      (output) COMPLEX*16 array, dimension (LDVT,N)\n*          If JOBVT = 'A', VT contains the N-by-N unitary matrix\n*          V**H;\n*          if JOBVT = 'S', VT contains the first min(m,n) rows of\n*          V**H (the right singular vectors, stored rowwise);\n*          if JOBVT = 'N' or 'O', VT is not referenced.\n*\n*  LDVT    (input) INTEGER\n*          The leading dimension of the array VT.  LDVT >= 1; if\n*          JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).\n*\n*  WORK    (workspace/output) COMPLEX*16 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,2*MIN(M,N)+MAX(M,N)).\n*          For good performance, LWORK should generally be larger.\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*  RWORK   (workspace) DOUBLE PRECISION array, dimension (5*min(M,N))\n*          On exit, if INFO > 0, RWORK(1:MIN(M,N)-1) contains the\n*          unconverged superdiagonal elements of an upper bidiagonal\n*          matrix B whose diagonal is in S (not necessarily sorted).\n*          B satisfies A = U * B * VT, so it has the same singular\n*          values as A, and singular vectors related by U and VT.\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 ZBDSQR did not converge, INFO specifies how many\n*                superdiagonals of an intermediate bidiagonal form B\n*                did not converge to zero. See the description of RWORK\n*                above for details.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, u, vt, work, info, a = NumRu::Lapack.zgesvd( jobu, jobvt, a, [: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_jobu = argv[0];
  rblapack_jobvt = argv[1];
  rblapack_a = 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;
  }

  jobu = StringValueCStr(rblapack_jobu)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  m = lda;
  ldu = ((lsame_(&jobu,"S")) || (lsame_(&jobu,"A"))) ? m : 1;
  jobvt = StringValueCStr(rblapack_jobvt)[0];
  ldvt = lsame_(&jobvt,"A") ? n : lsame_(&jobvt,"S") ? MIN(m,n) : 1;
  if (rblapack_lwork == Qnil)
    lwork = MAX(1, 2*MIN(m,n)+MAX(m,n));
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = lsame_(&jobu,"A") ? m : lsame_(&jobu,"S") ? MIN(m,n) : 0;
    rblapack_u = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  u = NA_PTR_TYPE(rblapack_u, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldvt;
    shape[1] = n;
    rblapack_vt = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  vt = NA_PTR_TYPE(rblapack_vt, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = MAX(n, MIN(m,n));
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  {
    VALUE __shape__[3];
    __shape__[0] = Qtrue;
    __shape__[1] = n < MIN(m,n) ? rb_range_new(rblapack_ZERO, INT2NUM(n), Qtrue) : Qtrue;
    __shape__[2] = rblapack_a;
    na_aset(3, __shape__, rblapack_a_out__);
  }
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  rwork = ALLOC_N(doublereal, (5*MIN(m,n)));

  zgesvd_(&jobu, &jobvt, &m, &n, a, &lda, s, u, &ldu, vt, &ldvt, work, &lwork, rwork, &info);

  free(rwork);
  rblapack_info = INT2NUM(info);
  {
    VALUE __shape__[2];
    __shape__[0] = Qtrue;
    __shape__[1] = n < MIN(m,n) ? Qtrue : rb_range_new(rblapack_ZERO, INT2NUM(MIN(m,n)), Qtrue);
    rblapack_a = na_aref(2, __shape__, rblapack_a);
  }
  return rb_ary_new3(6, rblapack_s, rblapack_u, rblapack_vt, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_zgesvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgesvd", rblapack_zgesvd, -1);
}
ruby-lapack-1.7.2/ext/dgebd2.c0000644000175000017500000001737712502221014015666 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgebd2_(integer* m, integer* n, doublereal* a, integer* lda, doublereal* d, doublereal* e, doublereal* tauq, doublereal* taup, doublereal* work, integer* info);


static VALUE
rblapack_dgebd2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_tauq;
  doublereal *tauq; 
  VALUE rblapack_taup;
  doublereal *taup; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  doublereal *work;

  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  d, e, tauq, taup, info, a = NumRu::Lapack.dgebd2( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGEBD2 reduces a real general m by n matrix A to upper or lower\n*  bidiagonal form B by an orthogonal transformation: Q' * A * P = B.\n*\n*  If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows in the matrix A.  M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns in the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the m by n general matrix to be reduced.\n*          On exit,\n*          if m >= n, the diagonal and the first superdiagonal are\n*            overwritten with the upper bidiagonal matrix B; the\n*            elements below the diagonal, with the array TAUQ, represent\n*            the orthogonal matrix Q as a product of elementary\n*            reflectors, and the elements above the first superdiagonal,\n*            with the array TAUP, represent the orthogonal matrix P as\n*            a product of elementary reflectors;\n*          if m < n, the diagonal and the first subdiagonal are\n*            overwritten with the lower bidiagonal matrix B; the\n*            elements below the first subdiagonal, with the array TAUQ,\n*            represent the orthogonal matrix Q as a product of\n*            elementary reflectors, and the elements above the diagonal,\n*            with the array TAUP, represent the orthogonal matrix P as\n*            a product of elementary reflectors.\n*          See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  D       (output) DOUBLE PRECISION array, dimension (min(M,N))\n*          The diagonal elements of the bidiagonal matrix B:\n*          D(i) = A(i,i).\n*\n*  E       (output) DOUBLE PRECISION array, dimension (min(M,N)-1)\n*          The off-diagonal elements of the bidiagonal matrix B:\n*          if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;\n*          if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.\n*\n*  TAUQ    (output) DOUBLE PRECISION array dimension (min(M,N))\n*          The scalar factors of the elementary reflectors which\n*          represent the orthogonal matrix Q. See Further Details.\n*\n*  TAUP    (output) DOUBLE PRECISION array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors which\n*          represent the orthogonal matrix P. See Further Details.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (max(M,N))\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 matrices Q and P are represented as products of elementary\n*  reflectors:\n*\n*  If m >= n,\n*\n*     Q = H(1) H(2) . . . H(n)  and  P = G(1) G(2) . . . G(n-1)\n*\n*  Each H(i) and G(i) has the form:\n*\n*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'\n*\n*  where tauq and taup are real scalars, and v and u are real vectors;\n*  v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);\n*  u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);\n*  tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n*  If m < n,\n*\n*     Q = H(1) H(2) . . . H(m-1)  and  P = G(1) G(2) . . . G(m)\n*\n*  Each H(i) and G(i) has the form:\n*\n*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'\n*\n*  where tauq and taup are real scalars, and v and u are real vectors;\n*  v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);\n*  u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);\n*  tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n*  The contents of A on exit are illustrated by the following examples:\n*\n*  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):\n*\n*    (  d   e   u1  u1  u1 )           (  d   u1  u1  u1  u1  u1 )\n*    (  v1  d   e   u2  u2 )           (  e   d   u2  u2  u2  u2 )\n*    (  v1  v2  d   e   u3 )           (  v1  e   d   u3  u3  u3 )\n*    (  v1  v2  v3  d   e  )           (  v1  v2  e   d   u4  u4 )\n*    (  v1  v2  v3  v4  d  )           (  v1  v2  v3  e   d   u5 )\n*    (  v1  v2  v3  v4  v5 )\n*\n*  where d and e denote diagonal and off-diagonal elements of B, vi\n*  denotes an element of the vector defining H(i), and ui an element of\n*  the vector defining G(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, tauq, taup, info, a = NumRu::Lapack.dgebd2( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n)-1;
    rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tauq = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  tauq = NA_PTR_TYPE(rblapack_tauq, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_taup = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  taup = NA_PTR_TYPE(rblapack_taup, doublereal*);
  {
    na_shape_t 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, (MAX(m,n)));

  dgebd2_(&m, &n, a, &lda, d, e, tauq, taup, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_d, rblapack_e, rblapack_tauq, rblapack_taup, rblapack_info, rblapack_a);
}

void
init_lapack_dgebd2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgebd2", rblapack_dgebd2, -1);
}
ruby-lapack-1.7.2/ext/dlatrd.c0000644000175000017500000001760612502221017016007 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlatrd_(char* uplo, integer* n, integer* nb, doublereal* a, integer* lda, doublereal* e, doublereal* tau, doublereal* w, integer* ldw);


static VALUE
rblapack_dlatrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_nb;
  integer nb; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;

  integer lda;
  integer n;
  integer ldw;

  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  e, tau, w, a = NumRu::Lapack.dlatrd( uplo, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )\n\n*  Purpose\n*  =======\n*\n*  DLATRD reduces NB rows and columns of a real symmetric matrix A to\n*  symmetric tridiagonal form by an orthogonal similarity\n*  transformation Q' * A * Q, and returns the matrices V and W which are\n*  needed to apply the transformation to the unreduced part of A.\n*\n*  If UPLO = 'U', DLATRD reduces the last NB rows and columns of a\n*  matrix, of which the upper triangle is supplied;\n*  if UPLO = 'L', DLATRD reduces the first NB rows and columns of a\n*  matrix, of which the lower triangle is supplied.\n*\n*  This is an auxiliary routine called by DSYTRD.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored:\n*          = 'U': Upper triangular\n*          = 'L': Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.\n*\n*  NB      (input) INTEGER\n*          The number of rows and columns to be reduced.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          n-by-n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n-by-n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*          On exit:\n*          if UPLO = 'U', the last NB columns have been reduced to\n*            tridiagonal form, with the diagonal elements overwriting\n*            the diagonal elements of A; the elements above the diagonal\n*            with the array TAU, represent the orthogonal matrix Q as a\n*            product of elementary reflectors;\n*          if UPLO = 'L', the first NB columns have been reduced to\n*            tridiagonal form, with the diagonal elements overwriting\n*            the diagonal elements of A; the elements below the diagonal\n*            with the array TAU, represent the  orthogonal matrix Q as a\n*            product of elementary reflectors.\n*          See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= (1,N).\n*\n*  E       (output) DOUBLE PRECISION array, dimension (N-1)\n*          If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal\n*          elements of the last NB columns of the reduced matrix;\n*          if UPLO = 'L', E(1:nb) contains the subdiagonal elements of\n*          the first NB columns of the reduced matrix.\n*\n*  TAU     (output) DOUBLE PRECISION array, dimension (N-1)\n*          The scalar factors of the elementary reflectors, stored in\n*          TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.\n*          See Further Details.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (LDW,NB)\n*          The n-by-nb matrix W required to update the unreduced part\n*          of A.\n*\n*  LDW     (input) INTEGER\n*          The leading dimension of the array W. LDW >= max(1,N).\n*\n\n*  Further Details\n*  ===============\n*\n*  If UPLO = 'U', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(n) H(n-1) . . . H(n-nb+1).\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(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),\n*  and tau in TAU(i-1).\n*\n*  If UPLO = 'L', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(1) H(2) . . . H(nb).\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) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),\n*  and tau in TAU(i).\n*\n*  The elements of the vectors v together form the n-by-nb matrix V\n*  which is needed, with W, to apply the transformation to the unreduced\n*  part of the matrix, using a symmetric rank-2k update of the form:\n*  A := A - V*W' - W*V'.\n*\n*  The contents of A on exit are illustrated by the following examples\n*  with n = 5 and nb = 2:\n*\n*  if UPLO = 'U':                       if UPLO = 'L':\n*\n*    (  a   a   a   v4  v5 )              (  d                  )\n*    (      a   a   v4  v5 )              (  1   d              )\n*    (          a   1   v5 )              (  v1  1   a          )\n*    (              d   1  )              (  v1  v2  a   a      )\n*    (                  d  )              (  v1  v2  a   a   a  )\n*\n*  where d denotes a diagonal element of the reduced matrix, a denotes\n*  an element of the original matrix that is unchanged, and vi denotes\n*  an element of the vector defining H(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  e, tau, w, a = NumRu::Lapack.dlatrd( uplo, nb, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_nb = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  nb = NUM2INT(rblapack_nb);
  ldw = MAX(1,n);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_tau = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldw;
    shape[1] = MAX(n,nb);
    rblapack_w = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t 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__;

  dlatrd_(&uplo, &n, &nb, a, &lda, e, tau, w, &ldw);

  return rb_ary_new3(4, rblapack_e, rblapack_tau, rblapack_w, rblapack_a);
}

void
init_lapack_dlatrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlatrd", rblapack_dlatrd, -1);
}
ruby-lapack-1.7.2/ext/zla_geamv.c0000644000175000017500000001730012502221022016465 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zla_geamv_(integer* trans, integer* m, integer* n, doublereal* alpha, doublereal* a, integer* lda, doublereal* x, integer* incx, doublereal* beta, doublereal* y, integer* incy);


static VALUE
rblapack_zla_geamv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  integer trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_alpha;
  doublereal alpha; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_beta;
  doublereal beta; 
  VALUE rblapack_y;
  doublereal *y; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_y_out__;
  doublereal *y_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  y = NumRu::Lapack.zla_geamv( trans, m, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n*  Purpose\n*  =======\n*\n*  ZLA_GEAMV  performs one of the matrix-vector operations\n*\n*          y := alpha*abs(A)*abs(x) + beta*abs(y),\n*     or   y := alpha*abs(A)'*abs(x) + beta*abs(y),\n*\n*  where alpha and beta are scalars, x and y are vectors and A is an\n*  m by n matrix.\n*\n*  This function is primarily used in calculating error bounds.\n*  To protect against underflow during evaluation, components in\n*  the resulting vector are perturbed away from zero by (N+1)\n*  times the underflow threshold.  To prevent unnecessarily large\n*  errors for block-structure embedded in general matrices,\n*  \"symbolically\" zero components are not perturbed.  A zero\n*  entry is considered \"symbolic\" if all multiplications involved\n*  in computing that entry have at least one zero multiplicand.\n*\n\n*  Arguments\n*  ==========\n*\n*  TRANS   (input) INTEGER\n*           On entry, TRANS specifies the operation to be performed as\n*           follows:\n*\n*             BLAS_NO_TRANS      y := alpha*abs(A)*abs(x) + beta*abs(y)\n*             BLAS_TRANS         y := alpha*abs(A')*abs(x) + beta*abs(y)\n*             BLAS_CONJ_TRANS    y := alpha*abs(A')*abs(x) + beta*abs(y)\n*\n*           Unchanged on exit.\n*\n*  M       (input) INTEGER\n*           On entry, M specifies the number of rows of the matrix A.\n*           M must be at least zero.\n*           Unchanged on exit.\n*\n*  N       (input) INTEGER\n*           On entry, N specifies the number of columns of the matrix A.\n*           N must be at least zero.\n*           Unchanged on exit.\n*\n*  ALPHA  - DOUBLE PRECISION\n*           On entry, ALPHA specifies the scalar alpha.\n*           Unchanged on exit.\n*\n*  A      - COMPLEX*16         array of DIMENSION ( LDA, n )\n*           Before entry, the leading m by n part of the array A must\n*           contain the matrix of coefficients.\n*           Unchanged on exit.\n*\n*  LDA     (input) INTEGER\n*           On entry, LDA specifies the first dimension of A as declared\n*           in the calling (sub) program. LDA must be at least\n*           max( 1, m ).\n*           Unchanged on exit.\n*\n*  X      - COMPLEX*16         array of DIMENSION at least\n*           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n*           and at least\n*           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n*           Before entry, the incremented array X must contain the\n*           vector x.\n*           Unchanged on exit.\n*\n*  INCX    (input) INTEGER\n*           On entry, INCX specifies the increment for the elements of\n*           X. INCX must not be zero.\n*           Unchanged on exit.\n*\n*  BETA   - DOUBLE PRECISION\n*           On entry, BETA specifies the scalar beta. When BETA is\n*           supplied as zero then Y need not be set on input.\n*           Unchanged on exit.\n*\n*  Y       (input/output) DOUBLE PRECISION  array, dimension\n*           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n*           and at least\n*           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n*           Before entry with BETA non-zero, the incremented array Y\n*           must contain the vector y. On exit, Y is overwritten by the\n*           updated vector y.\n*\n*  INCY    (input) INTEGER\n*           On entry, INCY specifies the increment for the elements of\n*           Y. INCY must not be zero.\n*           Unchanged on exit.\n*\n*\n*  Level 2 Blas routine.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  y = NumRu::Lapack.zla_geamv( trans, m, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_trans = argv[0];
  rblapack_m = argv[1];
  rblapack_alpha = argv[2];
  rblapack_a = argv[3];
  rblapack_x = argv[4];
  rblapack_incx = argv[5];
  rblapack_beta = argv[6];
  rblapack_y = argv[7];
  rblapack_incy = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = NUM2INT(rblapack_trans);
  alpha = NUM2DBL(rblapack_alpha);
  incx = NUM2INT(rblapack_incx);
  incy = NUM2INT(rblapack_incy);
  m = NUM2INT(rblapack_m);
  beta = NUM2DBL(rblapack_beta);
  lda = MAX(1, m);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_a) != lda)
    rb_raise(rb_eRuntimeError, "shape 0 of a must be MAX(1, m)");
  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*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (8th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy ));
  if (NA_TYPE(rblapack_y) != NA_DFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
  y = NA_PTR_TYPE(rblapack_y, doublereal*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (5th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (trans == ilatrans_("N") ? 1+(n-1)*abs(incx) : 1+(m-1)*abs(incx)))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", trans == ilatrans_("N") ? 1+(n-1)*abs(incx) : 1+(m-1)*abs(incx));
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy );
    rblapack_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
  MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  zla_geamv_(&trans, &m, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);

  return rblapack_y;
}

void
init_lapack_zla_geamv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zla_geamv", rblapack_zla_geamv, -1);
}
ruby-lapack-1.7.2/ext/sposv.c0000644000175000017500000001335212502221015015677 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sposv_(char* uplo, integer* n, integer* nrhs, real* a, integer* lda, real* b, integer* ldb, integer* info);


static VALUE
rblapack_sposv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_b_out__;
  real *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, a, b = NumRu::Lapack.sposv( uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPOSV computes the solution to a real system of linear equations\n*     A * X = B,\n*  where A is an N-by-N symmetric positive definite matrix and X and B\n*  are N-by-NRHS matrices.\n*\n*  The Cholesky decomposition is used to factor A as\n*     A = U**T* U,  if UPLO = 'U', or\n*     A = L * L**T,  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is a lower triangular\n*  matrix.  The factored form of A is then used to solve the system of\n*  equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the factor U or L from the Cholesky\n*          factorization A = U**T*U or A = L*L**T.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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 leading minor of order i of A is not\n*                positive definite, so the factorization could not be\n*                completed, and the solution has not been computed.\n*\n\n*  =====================================================================\n*\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           SPOTRF, SPOTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a, b = NumRu::Lapack.sposv( uplo, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_b = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  sposv_(&uplo, &n, &nrhs, a, &lda, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_sposv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sposv", rblapack_sposv, -1);
}
ruby-lapack-1.7.2/ext/chbtrd.c0000644000175000017500000001554012502221026015776 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chbtrd_(char* vect, char* uplo, integer* n, integer* kd, complex* ab, integer* ldab, real* d, real* e, complex* q, integer* ldq, complex* work, integer* info);


static VALUE
rblapack_chbtrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_vect;
  char vect; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_q;
  complex *q; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  complex *ab_out__;
  VALUE rblapack_q_out__;
  complex *q_out__;
  complex *work;

  integer ldab;
  integer n;
  integer ldq;

  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  d, e, info, ab, q = NumRu::Lapack.chbtrd( vect, uplo, kd, ab, q, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHBTRD reduces a complex Hermitian band matrix A to real symmetric\n*  tridiagonal form T by a unitary similarity transformation:\n*  Q**H * A * Q = T.\n*\n\n*  Arguments\n*  =========\n*\n*  VECT    (input) CHARACTER*1\n*          = 'N':  do not form Q;\n*          = 'V':  form Q;\n*          = 'U':  update a matrix X, by forming X*Q.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) COMPLEX array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*          On exit, the diagonal elements of AB are overwritten by the\n*          diagonal elements of the tridiagonal matrix T; if KD > 0, the\n*          elements on the first superdiagonal (if UPLO = 'U') or the\n*          first subdiagonal (if UPLO = 'L') are overwritten by the\n*          off-diagonal elements of T; the rest of AB is overwritten by\n*          values generated during the reduction.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  D       (output) REAL array, dimension (N)\n*          The diagonal elements of the tridiagonal matrix T.\n*\n*  E       (output) REAL array, dimension (N-1)\n*          The off-diagonal elements of the tridiagonal matrix T:\n*          E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.\n*\n*  Q       (input/output) COMPLEX array, dimension (LDQ,N)\n*          On entry, if VECT = 'U', then Q must contain an N-by-N\n*          matrix X; if VECT = 'N' or 'V', then Q need not be set.\n*\n*          On exit:\n*          if VECT = 'V', Q contains the N-by-N unitary matrix Q;\n*          if VECT = 'U', Q contains the product X*Q;\n*          if VECT = 'N', the array Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.\n*          LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.\n*\n*  WORK    (workspace) COMPLEX array, dimension (N)\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*  Modified by Linda Kaufman, Bell Labs.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, info, ab, q = NumRu::Lapack.chbtrd( vect, uplo, kd, ab, q, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_vect = argv[0];
  rblapack_uplo = argv[1];
  rblapack_kd = argv[2];
  rblapack_ab = argv[3];
  rblapack_q = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  vect = StringValueCStr(rblapack_vect)[0];
  kd = NUM2INT(rblapack_kd);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (5th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (5th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  n = NA_SHAPE1(rblapack_q);
  if (NA_TYPE(rblapack_q) != NA_SCOMPLEX)
    rblapack_q = na_change_type(rblapack_q, NA_SCOMPLEX);
  q = NA_PTR_TYPE(rblapack_q, complex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of q");
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, real*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
  MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, complex*);
  MEMCPY(q_out__, q, complex, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  work = ALLOC_N(complex, (n));

  chbtrd_(&vect, &uplo, &n, &kd, ab, &ldab, d, e, q, &ldq, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_d, rblapack_e, rblapack_info, rblapack_ab, rblapack_q);
}

void
init_lapack_chbtrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chbtrd", rblapack_chbtrd, -1);
}
ruby-lapack-1.7.2/ext/cspmv.c0000644000175000017500000001557312502221017015666 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cspmv_(char* uplo, integer* n, complex* alpha, complex* ap, complex* x, integer* incx, complex* beta, complex* y, integer* incy);


static VALUE
rblapack_cspmv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_alpha;
  complex alpha; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_beta;
  complex beta; 
  VALUE rblapack_y;
  complex *y; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_y_out__;
  complex *y_out__;
  integer ldap;

  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  y = NumRu::Lapack.cspmv( uplo, alpha, ap, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CSPMV( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY )\n\n*  Purpose\n*  =======\n*\n*  CSPMV  performs the matrix-vector operation\n*\n*     y := alpha*A*x + beta*y,\n*\n*  where alpha and beta are scalars, x and y are n element vectors and\n*  A is an n by n symmetric matrix, supplied in packed form.\n*\n\n*  Arguments\n*  ==========\n*\n*  UPLO     (input) CHARACTER*1\n*           On entry, UPLO specifies whether the upper or lower\n*           triangular part of the matrix A is supplied in the packed\n*           array AP as follows:\n*\n*              UPLO = 'U' or 'u'   The upper triangular part of A is\n*                                  supplied in AP.\n*\n*              UPLO = 'L' or 'l'   The lower triangular part of A is\n*                                  supplied in AP.\n*\n*           Unchanged on exit.\n*\n*  N        (input) INTEGER\n*           On entry, N specifies the order of the matrix A.\n*           N must be at least zero.\n*           Unchanged on exit.\n*\n*  ALPHA    (input) COMPLEX\n*           On entry, ALPHA specifies the scalar alpha.\n*           Unchanged on exit.\n*\n*  AP       (input) COMPLEX array, dimension at least\n*           ( ( N*( N + 1 ) )/2 ).\n*           Before entry, with UPLO = 'U' or 'u', the array AP must\n*           contain the upper triangular part of the symmetric matrix\n*           packed sequentially, column by column, so that AP( 1 )\n*           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )\n*           and a( 2, 2 ) respectively, and so on.\n*           Before entry, with UPLO = 'L' or 'l', the array AP must\n*           contain the lower triangular part of the symmetric matrix\n*           packed sequentially, column by column, so that AP( 1 )\n*           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )\n*           and a( 3, 1 ) respectively, and so on.\n*           Unchanged on exit.\n*\n*  X        (input) COMPLEX array, dimension at least\n*           ( 1 + ( N - 1 )*abs( INCX ) ).\n*           Before entry, the incremented array X must contain the N-\n*           element vector x.\n*           Unchanged on exit.\n*\n*  INCX     (input) INTEGER\n*           On entry, INCX specifies the increment for the elements of\n*           X. INCX must not be zero.\n*           Unchanged on exit.\n*\n*  BETA     (input) COMPLEX\n*           On entry, BETA specifies the scalar beta. When BETA is\n*           supplied as zero then Y need not be set on input.\n*           Unchanged on exit.\n*\n*  Y        (input/output) COMPLEX array, dimension at least \n*           ( 1 + ( N - 1 )*abs( INCY ) ).\n*           Before entry, the incremented array Y must contain the n\n*           element vector y. On exit, Y is overwritten by the updated\n*           vector y.\n*\n*  INCY     (input) INTEGER\n*           On entry, INCY specifies the increment for the elements of\n*           Y. INCY must not be zero.\n*           Unchanged on exit.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  y = NumRu::Lapack.cspmv( uplo, alpha, ap, x, incx, beta, y, incy, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_uplo = argv[0];
  rblapack_alpha = argv[1];
  rblapack_ap = argv[2];
  rblapack_x = argv[3];
  rblapack_incx = argv[4];
  rblapack_beta = argv[5];
  rblapack_y = argv[6];
  rblapack_incy = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  incx = NUM2INT(rblapack_incx);
  incy = NUM2INT(rblapack_incy);
  alpha.r = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("real"), 0));
  alpha.i = (real)NUM2DBL(rb_funcall(rblapack_alpha, rb_intern("imag"), 0));
  beta.r = (real)NUM2DBL(rb_funcall(rblapack_beta, rb_intern("real"), 0));
  beta.i = (real)NUM2DBL(rb_funcall(rblapack_beta, rb_intern("imag"), 0));
  n = ((integer)sqrtf(8*ldap+1.0f)-1)/2;
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (4th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1 + (n-1)*abs(incx)))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + (n-1)*abs(incx));
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (7th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (1 + (n-1)*abs(incy)))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1 + (n-1)*abs(incy));
  if (NA_TYPE(rblapack_y) != NA_SCOMPLEX)
    rblapack_y = na_change_type(rblapack_y, NA_SCOMPLEX);
  y = NA_PTR_TYPE(rblapack_y, complex*);
  {
    na_shape_t shape[1];
    shape[0] = 1 + (n-1)*abs(incy);
    rblapack_y_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, complex*);
  MEMCPY(y_out__, y, complex, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  cspmv_(&uplo, &n, &alpha, ap, x, &incx, &beta, y, &incy);

  return rblapack_y;
}

void
init_lapack_cspmv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cspmv", rblapack_cspmv, -1);
}
ruby-lapack-1.7.2/ext/zhpsvx.c0000644000175000017500000003221612502221023016066 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhpsvx_(char* fact, char* uplo, integer* n, integer* nrhs, doublecomplex* ap, doublecomplex* afp, integer* ipiv, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zhpsvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_afp;
  doublecomplex *afp; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_afp_out__;
  doublecomplex *afp_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.zhpsvx( fact, uplo, ap, afp, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHPSVX uses the diagonal pivoting factorization A = U*D*U**H or\n*  A = L*D*L**H to compute the solution to a complex system of linear\n*  equations A * X = B, where A is an N-by-N Hermitian matrix stored\n*  in packed format and X and B are N-by-NRHS matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'N', the diagonal pivoting method is used to factor A as\n*        A = U * D * U**H,  if UPLO = 'U', or\n*        A = L * D * L**H,  if UPLO = 'L',\n*     where U (or L) is a product of permutation and unit upper (lower)\n*     triangular matrices and D is Hermitian and block diagonal with\n*     1-by-1 and 2-by-2 diagonal blocks.\n*\n*  2. If some D(i,i)=0, so that D is exactly singular, then the routine\n*     returns with INFO = i. Otherwise, the factored form of A is used\n*     to estimate the condition number of the matrix A.  If the\n*     reciprocal of the condition number is less than machine precision,\n*     INFO = N+1 is returned as a warning, but the routine still goes on\n*     to solve for X and compute error bounds as described below.\n*\n*  3. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  4. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of A has been\n*          supplied on entry.\n*          = 'F':  On entry, AFP and IPIV contain the factored form of\n*                  A.  AFP and IPIV will not be modified.\n*          = 'N':  The matrix A will be copied to AFP and factored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          The upper or lower triangle of the Hermitian matrix A, packed\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*          See below for further details.\n*\n*  AFP     (input or output) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          If FACT = 'F', then AFP is an input argument and on entry\n*          contains the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L from the factorization\n*          A = U*D*U**H or A = L*D*L**H as computed by ZHPTRF, stored as\n*          a packed triangular matrix in the same storage format as A.\n*\n*          If FACT = 'N', then AFP is an output argument and on exit\n*          contains the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L from the factorization\n*          A = U*D*U**H or A = L*D*L**H as computed by ZHPTRF, stored as\n*          a packed triangular matrix in the same storage format as A.\n*\n*  IPIV    (input or output) INTEGER array, dimension (N)\n*          If FACT = 'F', then IPIV is an input argument and on entry\n*          contains details of the interchanges and the block structure\n*          of D, as determined by ZHPTRF.\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*          If FACT = 'N', then IPIV is an output argument and on exit\n*          contains details of the interchanges and the block structure\n*          of D, as determined by ZHPTRF.\n*\n*  B       (input) COMPLEX*16 array, dimension (LDB,NRHS)\n*          The N-by-NRHS right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) COMPLEX*16 array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The estimate of the reciprocal condition number of the matrix\n*          A.  If RCOND is less than the machine precision (in\n*          particular, if RCOND = 0), the matrix is singular to working\n*          precision.  This condition is indicated by a return code of\n*          INFO > 0.\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\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, and i is\n*                <= N:  D(i,i) is exactly zero.  The factorization\n*                       has been completed but the factor D is exactly\n*                       singular, so the solution and error bounds could\n*                       not be computed. RCOND = 0 is returned.\n*                = N+1: D is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  Further Details\n*  ===============\n*\n*  The packed storage scheme is illustrated by the following example\n*  when N = 4, UPLO = 'U':\n*\n*  Two-dimensional storage of the Hermitian matrix A:\n*\n*     a11 a12 a13 a14\n*         a22 a23 a24\n*             a33 a34     (aij = conjg(aji))\n*                 a44\n*\n*  Packed storage of the upper triangle of A:\n*\n*  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, info, afp, ipiv = NumRu::Lapack.zhpsvx( fact, uplo, ap, afp, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_ap = argv[2];
  rblapack_afp = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_b = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  ldx = MAX(1,n);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_afp))
    rb_raise(rb_eArgError, "afp (4th argument) must be NArray");
  if (NA_RANK(rblapack_afp) != 1)
    rb_raise(rb_eArgError, "rank of afp (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_afp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of afp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_afp) != NA_DCOMPLEX)
    rblapack_afp = na_change_type(rblapack_afp, NA_DCOMPLEX);
  afp = NA_PTR_TYPE(rblapack_afp, doublecomplex*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_afp_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  afp_out__ = NA_PTR_TYPE(rblapack_afp_out__, doublecomplex*);
  MEMCPY(afp_out__, afp, doublecomplex, NA_TOTAL(rblapack_afp));
  rblapack_afp = rblapack_afp_out__;
  afp = afp_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (n));

  zhpsvx_(&fact, &uplo, &n, &nrhs, ap, afp, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_afp, rblapack_ipiv);
}

void
init_lapack_zhpsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhpsvx", rblapack_zhpsvx, -1);
}
ruby-lapack-1.7.2/ext/dlalsa.c0000644000175000017500000004111112502221017015761 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlalsa_(integer* icompq, integer* smlsiz, integer* n, integer* nrhs, doublereal* b, integer* ldb, doublereal* bx, integer* ldbx, doublereal* u, integer* ldu, doublereal* vt, integer* k, doublereal* difl, doublereal* difr, doublereal* z, doublereal* poles, integer* givptr, integer* givcol, integer* ldgcol, integer* perm, doublereal* givnum, doublereal* c, doublereal* s, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dlalsa(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_icompq;
  integer icompq; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_u;
  doublereal *u; 
  VALUE rblapack_vt;
  doublereal *vt; 
  VALUE rblapack_k;
  integer *k; 
  VALUE rblapack_difl;
  doublereal *difl; 
  VALUE rblapack_difr;
  doublereal *difr; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_poles;
  doublereal *poles; 
  VALUE rblapack_givptr;
  integer *givptr; 
  VALUE rblapack_givcol;
  integer *givcol; 
  VALUE rblapack_perm;
  integer *perm; 
  VALUE rblapack_givnum;
  doublereal *givnum; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_bx;
  doublereal *bx; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublereal *b_out__;
  doublereal *work;
  integer *iwork;

  integer ldb;
  integer nrhs;
  integer ldu;
  integer smlsiz;
  integer n;
  integer nlvl;
  integer ldgcol;
  integer ldbx;

  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  bx, info, b = NumRu::Lapack.dlalsa( icompq, b, u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLALSA is an itermediate step in solving the least squares problem\n*  by computing the SVD of the coefficient matrix in compact form (The\n*  singular vectors are computed as products of simple orthorgonal\n*  matrices.).\n*\n*  If ICOMPQ = 0, DLALSA applies the inverse of the left singular vector\n*  matrix of an upper bidiagonal matrix to the right hand side; and if\n*  ICOMPQ = 1, DLALSA applies the right singular vector matrix to the\n*  right hand side. The singular vector matrices were generated in\n*  compact form by DLALSA.\n*\n\n*  Arguments\n*  =========\n*\n*\n*  ICOMPQ (input) INTEGER\n*         Specifies whether the left or the right singular vector\n*         matrix is involved.\n*         = 0: Left singular vector matrix\n*         = 1: Right singular vector matrix\n*\n*  SMLSIZ (input) INTEGER\n*         The maximum size of the subproblems at the bottom of the\n*         computation tree.\n*\n*  N      (input) INTEGER\n*         The row and column dimensions of the upper bidiagonal matrix.\n*\n*  NRHS   (input) INTEGER\n*         The number of columns of B and BX. NRHS must be at least 1.\n*\n*  B      (input/output) DOUBLE PRECISION array, dimension ( LDB, NRHS )\n*         On input, B contains the right hand sides of the least\n*         squares problem in rows 1 through M.\n*         On output, B contains the solution X in rows 1 through N.\n*\n*  LDB    (input) INTEGER\n*         The leading dimension of B in the calling subprogram.\n*         LDB must be at least max(1,MAX( M, N ) ).\n*\n*  BX     (output) DOUBLE PRECISION array, dimension ( LDBX, NRHS )\n*         On exit, the result of applying the left or right singular\n*         vector matrix to B.\n*\n*  LDBX   (input) INTEGER\n*         The leading dimension of BX.\n*\n*  U      (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ).\n*         On entry, U contains the left singular vector matrices of all\n*         subproblems at the bottom level.\n*\n*  LDU    (input) INTEGER, LDU = > N.\n*         The leading dimension of arrays U, VT, DIFL, DIFR,\n*         POLES, GIVNUM, and Z.\n*\n*  VT     (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ).\n*         On entry, VT' contains the right singular vector matrices of\n*         all subproblems at the bottom level.\n*\n*  K      (input) INTEGER array, dimension ( N ).\n*\n*  DIFL   (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).\n*         where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.\n*\n*  DIFR   (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).\n*         On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record\n*         distances between singular values on the I-th level and\n*         singular values on the (I -1)-th level, and DIFR(*, 2 * I)\n*         record the normalizing factors of the right singular vectors\n*         matrices of subproblems on I-th level.\n*\n*  Z      (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).\n*         On entry, Z(1, I) contains the components of the deflation-\n*         adjusted updating row vector for subproblems on the I-th\n*         level.\n*\n*  POLES  (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).\n*         On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old\n*         singular values involved in the secular equations on the I-th\n*         level.\n*\n*  GIVPTR (input) INTEGER array, dimension ( N ).\n*         On entry, GIVPTR( I ) records the number of Givens\n*         rotations performed on the I-th problem on the computation\n*         tree.\n*\n*  GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ).\n*         On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the\n*         locations of Givens rotations performed on the I-th level on\n*         the computation tree.\n*\n*  LDGCOL (input) INTEGER, LDGCOL = > N.\n*         The leading dimension of arrays GIVCOL and PERM.\n*\n*  PERM   (input) INTEGER array, dimension ( LDGCOL, NLVL ).\n*         On entry, PERM(*, I) records permutations done on the I-th\n*         level of the computation tree.\n*\n*  GIVNUM (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).\n*         On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-\n*         values of Givens rotations performed on the I-th level on the\n*         computation tree.\n*\n*  C      (input) DOUBLE PRECISION array, dimension ( N ).\n*         On entry, if the I-th subproblem is not square,\n*         C( I ) contains the C-value of a Givens rotation related to\n*         the right null space of the I-th subproblem.\n*\n*  S      (input) DOUBLE PRECISION array, dimension ( N ).\n*         On entry, if the I-th subproblem is not square,\n*         S( I ) contains the S-value of a Givens rotation related to\n*         the right null space of the I-th subproblem.\n*\n*  WORK   (workspace) DOUBLE PRECISION array.\n*         The dimension must be at least N.\n*\n*  IWORK  (workspace) INTEGER array.\n*         The dimension must be at least 3 * N\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*  Based on contributions by\n*     Ming Gu and Ren-Cang Li, Computer Science Division, University of\n*       California at Berkeley, USA\n*     Osni Marques, LBNL/NERSC, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  bx, info, b = NumRu::Lapack.dlalsa( icompq, b, u, vt, k, difl, difr, z, poles, givptr, givcol, perm, givnum, c, s, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 15 && argc != 15)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 15)", argc);
  rblapack_icompq = argv[0];
  rblapack_b = argv[1];
  rblapack_u = argv[2];
  rblapack_vt = argv[3];
  rblapack_k = argv[4];
  rblapack_difl = argv[5];
  rblapack_difr = argv[6];
  rblapack_z = argv[7];
  rblapack_poles = argv[8];
  rblapack_givptr = argv[9];
  rblapack_givcol = argv[10];
  rblapack_perm = argv[11];
  rblapack_givnum = argv[12];
  rblapack_c = argv[13];
  rblapack_s = argv[14];
  if (argc == 15) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  icompq = NUM2INT(rblapack_icompq);
  if (!NA_IsNArray(rblapack_u))
    rb_raise(rb_eArgError, "u (3th argument) must be NArray");
  if (NA_RANK(rblapack_u) != 2)
    rb_raise(rb_eArgError, "rank of u (3th argument) must be %d", 2);
  ldu = NA_SHAPE0(rblapack_u);
  smlsiz = NA_SHAPE1(rblapack_u);
  if (NA_TYPE(rblapack_u) != NA_DFLOAT)
    rblapack_u = na_change_type(rblapack_u, NA_DFLOAT);
  u = NA_PTR_TYPE(rblapack_u, doublereal*);
  if (!NA_IsNArray(rblapack_k))
    rb_raise(rb_eArgError, "k (5th argument) must be NArray");
  if (NA_RANK(rblapack_k) != 1)
    rb_raise(rb_eArgError, "rank of k (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_k);
  if (NA_TYPE(rblapack_k) != NA_LINT)
    rblapack_k = na_change_type(rblapack_k, NA_LINT);
  k = NA_PTR_TYPE(rblapack_k, integer*);
  if (!NA_IsNArray(rblapack_givptr))
    rb_raise(rb_eArgError, "givptr (10th argument) must be NArray");
  if (NA_RANK(rblapack_givptr) != 1)
    rb_raise(rb_eArgError, "rank of givptr (10th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_givptr) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of givptr must be the same as shape 0 of k");
  if (NA_TYPE(rblapack_givptr) != NA_LINT)
    rblapack_givptr = na_change_type(rblapack_givptr, NA_LINT);
  givptr = NA_PTR_TYPE(rblapack_givptr, integer*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (14th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (14th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 0 of k");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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 (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (15th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (15th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 0 of k");
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  nlvl = (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1;
  if (!NA_IsNArray(rblapack_vt))
    rb_raise(rb_eArgError, "vt (4th argument) must be NArray");
  if (NA_RANK(rblapack_vt) != 2)
    rb_raise(rb_eArgError, "rank of vt (4th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_vt) != ldu)
    rb_raise(rb_eRuntimeError, "shape 0 of vt must be the same as shape 0 of u");
  if (NA_SHAPE1(rblapack_vt) != (smlsiz+1))
    rb_raise(rb_eRuntimeError, "shape 1 of vt must be %d", smlsiz+1);
  if (NA_TYPE(rblapack_vt) != NA_DFLOAT)
    rblapack_vt = na_change_type(rblapack_vt, NA_DFLOAT);
  vt = NA_PTR_TYPE(rblapack_vt, doublereal*);
  if (!NA_IsNArray(rblapack_difr))
    rb_raise(rb_eArgError, "difr (7th argument) must be NArray");
  if (NA_RANK(rblapack_difr) != 2)
    rb_raise(rb_eArgError, "rank of difr (7th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_difr) != ldu)
    rb_raise(rb_eRuntimeError, "shape 0 of difr must be the same as shape 0 of u");
  if (NA_SHAPE1(rblapack_difr) != (2 * nlvl))
    rb_raise(rb_eRuntimeError, "shape 1 of difr must be %d", 2 * nlvl);
  if (NA_TYPE(rblapack_difr) != NA_DFLOAT)
    rblapack_difr = na_change_type(rblapack_difr, NA_DFLOAT);
  difr = NA_PTR_TYPE(rblapack_difr, doublereal*);
  if (!NA_IsNArray(rblapack_poles))
    rb_raise(rb_eArgError, "poles (9th argument) must be NArray");
  if (NA_RANK(rblapack_poles) != 2)
    rb_raise(rb_eArgError, "rank of poles (9th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_poles) != ldu)
    rb_raise(rb_eRuntimeError, "shape 0 of poles must be the same as shape 0 of u");
  if (NA_SHAPE1(rblapack_poles) != (2 * nlvl))
    rb_raise(rb_eRuntimeError, "shape 1 of poles must be %d", 2 * nlvl);
  if (NA_TYPE(rblapack_poles) != NA_DFLOAT)
    rblapack_poles = na_change_type(rblapack_poles, NA_DFLOAT);
  poles = NA_PTR_TYPE(rblapack_poles, doublereal*);
  if (!NA_IsNArray(rblapack_perm))
    rb_raise(rb_eArgError, "perm (12th argument) must be NArray");
  if (NA_RANK(rblapack_perm) != 2)
    rb_raise(rb_eArgError, "rank of perm (12th argument) must be %d", 2);
  ldgcol = NA_SHAPE0(rblapack_perm);
  if (NA_SHAPE1(rblapack_perm) != nlvl)
    rb_raise(rb_eRuntimeError, "shape 1 of perm must be (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1");
  if (NA_TYPE(rblapack_perm) != NA_LINT)
    rblapack_perm = na_change_type(rblapack_perm, NA_LINT);
  perm = NA_PTR_TYPE(rblapack_perm, integer*);
  ldbx = n;
  if (!NA_IsNArray(rblapack_difl))
    rb_raise(rb_eArgError, "difl (6th argument) must be NArray");
  if (NA_RANK(rblapack_difl) != 2)
    rb_raise(rb_eArgError, "rank of difl (6th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_difl) != ldu)
    rb_raise(rb_eRuntimeError, "shape 0 of difl must be the same as shape 0 of u");
  if (NA_SHAPE1(rblapack_difl) != nlvl)
    rb_raise(rb_eRuntimeError, "shape 1 of difl must be (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1");
  if (NA_TYPE(rblapack_difl) != NA_DFLOAT)
    rblapack_difl = na_change_type(rblapack_difl, NA_DFLOAT);
  difl = NA_PTR_TYPE(rblapack_difl, doublereal*);
  if (!NA_IsNArray(rblapack_givcol))
    rb_raise(rb_eArgError, "givcol (11th argument) must be NArray");
  if (NA_RANK(rblapack_givcol) != 2)
    rb_raise(rb_eArgError, "rank of givcol (11th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_givcol) != ldgcol)
    rb_raise(rb_eRuntimeError, "shape 0 of givcol must be the same as shape 0 of perm");
  if (NA_SHAPE1(rblapack_givcol) != (2 * nlvl))
    rb_raise(rb_eRuntimeError, "shape 1 of givcol must be %d", 2 * nlvl);
  if (NA_TYPE(rblapack_givcol) != NA_LINT)
    rblapack_givcol = na_change_type(rblapack_givcol, NA_LINT);
  givcol = NA_PTR_TYPE(rblapack_givcol, integer*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (8th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_z) != ldu)
    rb_raise(rb_eRuntimeError, "shape 0 of z must be the same as shape 0 of u");
  if (NA_SHAPE1(rblapack_z) != nlvl)
    rb_raise(rb_eRuntimeError, "shape 1 of z must be (int)(1.0/log(2.0)*log((double)n/(smlsiz+1))) + 1");
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  if (!NA_IsNArray(rblapack_givnum))
    rb_raise(rb_eArgError, "givnum (13th argument) must be NArray");
  if (NA_RANK(rblapack_givnum) != 2)
    rb_raise(rb_eArgError, "rank of givnum (13th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_givnum) != ldu)
    rb_raise(rb_eRuntimeError, "shape 0 of givnum must be the same as shape 0 of u");
  if (NA_SHAPE1(rblapack_givnum) != (2 * nlvl))
    rb_raise(rb_eRuntimeError, "shape 1 of givnum must be %d", 2 * nlvl);
  if (NA_TYPE(rblapack_givnum) != NA_DFLOAT)
    rblapack_givnum = na_change_type(rblapack_givnum, NA_DFLOAT);
  givnum = NA_PTR_TYPE(rblapack_givnum, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldbx;
    shape[1] = nrhs;
    rblapack_bx = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  bx = NA_PTR_TYPE(rblapack_bx, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(doublereal, (n));
  iwork = ALLOC_N(integer, (3 * n));

  dlalsa_(&icompq, &smlsiz, &n, &nrhs, b, &ldb, bx, &ldbx, u, &ldu, vt, k, difl, difr, z, poles, givptr, givcol, &ldgcol, perm, givnum, c, s, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_bx, rblapack_info, rblapack_b);
}

void
init_lapack_dlalsa(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlalsa", rblapack_dlalsa, -1);
}
ruby-lapack-1.7.2/ext/dtbrfs.c0000644000175000017500000001724012502221016016012 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtbrfs_(char* uplo, char* trans, char* diag, integer* n, integer* kd, integer* nrhs, doublereal* ab, integer* ldab, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dtbrfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_info;
  integer info; 
  doublereal *work;
  integer *iwork;

  integer ldab;
  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info = NumRu::Lapack.dtbrfs( uplo, trans, diag, kd, ab, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTBRFS provides error bounds and backward error estimates for the\n*  solution to a system of linear equations with a triangular band\n*  coefficient matrix.\n*\n*  The solution matrix X must be computed by DTBTRS or some other\n*  means before entering this routine.  DTBRFS does not do iterative\n*  refinement because doing so cannot improve the backward error.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B  (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals or subdiagonals of the\n*          triangular band matrix A.  KD >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)\n*          The upper or lower triangular band matrix A, stored in the\n*          first kd+1 rows of the array. The j-th column of A is stored\n*          in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*          If DIAG = 'U', the diagonal elements of A are not referenced\n*          and are assumed to be 1.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*          The solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info = NumRu::Lapack.dtbrfs( uplo, trans, diag, kd, ab, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_kd = argv[3];
  rblapack_ab = argv[4];
  rblapack_b = argv[5];
  rblapack_x = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (7th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  kd = NUM2INT(rblapack_kd);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  work = ALLOC_N(doublereal, (3*n));
  iwork = ALLOC_N(integer, (n));

  dtbrfs_(&uplo, &trans, &diag, &n, &kd, &nrhs, ab, &ldab, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ferr, rblapack_berr, rblapack_info);
}

void
init_lapack_dtbrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtbrfs", rblapack_dtbrfs, -1);
}
ruby-lapack-1.7.2/ext/chpgvd.c0000644000175000017500000003004712502221022015776 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chpgvd_(integer* itype, char* jobz, char* uplo, integer* n, complex* ap, complex* bp, real* w, complex* z, integer* ldz, complex* work, integer* lwork, real* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_chpgvd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_bp;
  complex *bp; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_lrwork;
  integer lrwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  complex *ap_out__;
  VALUE rblapack_bp_out__;
  complex *bp_out__;
  complex *work;
  real *rwork;

  integer ldap;
  integer n;
  integer ldz;

  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  w, z, iwork, info, ap, bp = NumRu::Lapack.chpgvd( itype, jobz, uplo, ap, bp, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHPGVD computes all the eigenvalues and, optionally, the eigenvectors\n*  of a complex generalized Hermitian-definite eigenproblem, of the form\n*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A and\n*  B are assumed to be Hermitian, stored in packed format, and B is also\n*  positive definite.\n*  If eigenvectors are desired, it uses a divide and conquer algorithm.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          Specifies the problem type to be solved:\n*          = 1:  A*x = (lambda)*B*x\n*          = 2:  A*B*x = (lambda)*x\n*          = 3:  B*A*x = (lambda)*x\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, the contents of AP are destroyed.\n*\n*  BP      (input/output) COMPLEX array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          B, packed columnwise in a linear array.  The j-th column of B\n*          is stored in the array BP as follows:\n*          if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n*          if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n*          On exit, the triangular factor U or L from the Cholesky\n*          factorization B = U**H*U or B = L*L**H, in the same storage\n*          format as B.\n*\n*  W       (output) REAL array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) COMPLEX array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n*          eigenvectors.  The eigenvectors are normalized as follows:\n*          if ITYPE = 1 or 2, Z**H*B*Z = I;\n*          if ITYPE = 3, Z**H*inv(B)*Z = I.\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace) COMPLEX array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the required LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of array WORK.\n*          If N <= 1,               LWORK >= 1.\n*          If JOBZ = 'N' and N > 1, LWORK >= N.\n*          If JOBZ = 'V' and N > 1, LWORK >= 2*N.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the required sizes of the WORK, RWORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  RWORK   (workspace) REAL array, dimension (MAX(1,LRWORK))\n*          On exit, if INFO = 0, RWORK(1) returns the required LRWORK.\n*\n*  LRWORK  (input) INTEGER\n*          The dimension of array RWORK.\n*          If N <= 1,               LRWORK >= 1.\n*          If JOBZ = 'N' and N > 1, LRWORK >= N.\n*          If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2.\n*\n*          If LRWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the required sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of array IWORK.\n*          If JOBZ  = 'N' or N <= 1, LIWORK >= 1.\n*          If JOBZ  = 'V' and N > 1, LIWORK >= 3 + 5*N.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the required sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK 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:  CPPTRF or CHPEVD returned an error code:\n*             <= N:  if INFO = i, CHPEVD failed to converge;\n*                    i off-diagonal elements of an intermediate\n*                    tridiagonal form did not convergeto zero;\n*             > N:   if INFO = N + i, for 1 <= i <= n, then the leading\n*                    minor of order i of B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LQUERY, UPPER, WANTZ\n      CHARACTER          TRANS\n      INTEGER            J, LIWMIN, LRWMIN, LWMIN, NEIG\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CHPEVD, CHPGST, CPPTRF, CTPMV, CTPSV, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, REAL\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, iwork, info, ap, bp = NumRu::Lapack.chpgvd( itype, jobz, uplo, ap, bp, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_itype = argv[0];
  rblapack_jobz = argv[1];
  rblapack_uplo = argv[2];
  rblapack_ap = argv[3];
  rblapack_bp = argv[4];
  if (argc == 8) {
    rblapack_lwork = argv[5];
    rblapack_lrwork = argv[6];
    rblapack_liwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_lrwork = Qnil;
    rblapack_liwork = Qnil;
  }

  itype = NUM2INT(rblapack_itype);
  uplo = StringValueCStr(rblapack_uplo)[0];
  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  if (!NA_IsNArray(rblapack_bp))
    rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
  if (NA_RANK(rblapack_bp) != 1)
    rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_bp) != NA_SCOMPLEX)
    rblapack_bp = na_change_type(rblapack_bp, NA_SCOMPLEX);
  bp = NA_PTR_TYPE(rblapack_bp, complex*);
  if (rblapack_lrwork == Qnil)
    lrwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
  else {
    lrwork = NUM2INT(rblapack_lrwork);
  }
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  if (rblapack_lwork == Qnil)
    lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 2*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (rblapack_liwork == Qnil)
    liwork = (lsame_(&jobz,"N")||n<=1) ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
  MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_bp_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  bp_out__ = NA_PTR_TYPE(rblapack_bp_out__, complex*);
  MEMCPY(bp_out__, bp, complex, NA_TOTAL(rblapack_bp));
  rblapack_bp = rblapack_bp_out__;
  bp = bp_out__;
  work = ALLOC_N(complex, (MAX(1,lwork)));
  rwork = ALLOC_N(real, (MAX(1,lrwork)));

  chpgvd_(&itype, &jobz, &uplo, &n, ap, bp, w, z, &ldz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_w, rblapack_z, rblapack_iwork, rblapack_info, rblapack_ap, rblapack_bp);
}

void
init_lapack_chpgvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chpgvd", rblapack_chpgvd, -1);
}
ruby-lapack-1.7.2/ext/dgbsvx.c0000644000175000017500000005255712502221024016034 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgbsvx_(char* fact, char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, doublereal* ab, integer* ldab, doublereal* afb, integer* ldafb, integer* ipiv, char* equed, doublereal* r, doublereal* c, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dgbsvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_afb;
  doublereal *afb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_r;
  doublereal *r; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublereal *ab_out__;
  VALUE rblapack_afb_out__;
  doublereal *afb_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  VALUE rblapack_r_out__;
  doublereal *r_out__;
  VALUE rblapack_c_out__;
  doublereal *c_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;
  integer *iwork;

  integer ldab;
  integer n;
  integer ldb;
  integer nrhs;
  integer ldafb;
  integer ldx;

  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  x, rcond, ferr, berr, work, info, ab, afb, ipiv, equed, r, c, b = NumRu::Lapack.dgbsvx( fact, trans, kl, ku, ab, b, [:afb => afb, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGBSVX uses the LU factorization to compute the solution to a real\n*  system of linear equations A * X = B, A**T * X = B, or A**H * X = B,\n*  where A is a band matrix of order N with KL subdiagonals and KU\n*  superdiagonals, and X and B are N-by-NRHS matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed by this subroutine:\n*\n*  1. If FACT = 'E', real scaling factors are computed to equilibrate\n*     the system:\n*        TRANS = 'N':  diag(R)*A*diag(C)     *inv(diag(C))*X = diag(R)*B\n*        TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n*        TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n*     or diag(C)*B (if TRANS = 'T' or 'C').\n*\n*  2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n*     matrix A (after equilibration if FACT = 'E') as\n*        A = L * U,\n*     where L is a product of permutation and unit lower triangular\n*     matrices with KL subdiagonals, and U is upper triangular with\n*     KL+KU superdiagonals.\n*\n*  3. If some U(i,i)=0, so that U is exactly singular, then the routine\n*     returns with INFO = i. Otherwise, the factored form of A is used\n*     to estimate the condition number of the matrix A.  If the\n*     reciprocal of the condition number is less than machine precision,\n*     INFO = N+1 is returned as a warning, but the routine still goes on\n*     to solve for X and compute error bounds as described below.\n*\n*  4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  5. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n*  6. If equilibration was used, the matrix X is premultiplied by\n*     diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n*     that it solves the original system before equilibration.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of the matrix A is\n*          supplied on entry, and if not, whether the matrix A should be\n*          equilibrated before it is factored.\n*          = 'F':  On entry, AFB and IPIV contain the factored form of\n*                  A.  If EQUED is not 'N', the matrix A has been\n*                  equilibrated with scaling factors given by R and C.\n*                  AB, AFB, and IPIV are not modified.\n*          = 'N':  The matrix A will be copied to AFB and factored.\n*          = 'E':  The matrix A will be equilibrated if necessary, then\n*                  copied to AFB and factored.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations.\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Transpose)\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n*          On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n*          The j-th column of A is stored in the j-th column of the\n*          array AB as follows:\n*          AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n*          If FACT = 'F' and EQUED is not 'N', then A must have been\n*          equilibrated by the scaling factors in R and/or C.  AB is not\n*          modified if FACT = 'F' or 'N', or if FACT = 'E' and\n*          EQUED = 'N' on exit.\n*\n*          On exit, if EQUED .ne. 'N', A is scaled as follows:\n*          EQUED = 'R':  A := diag(R) * A\n*          EQUED = 'C':  A := A * diag(C)\n*          EQUED = 'B':  A := diag(R) * A * diag(C).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*  AFB     (input or output) DOUBLE PRECISION array, dimension (LDAFB,N)\n*          If FACT = 'F', then AFB is an input argument and on entry\n*          contains details of the LU factorization of the band matrix\n*          A, as computed by DGBTRF.  U is stored as an upper triangular\n*          band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n*          and the multipliers used during the factorization are stored\n*          in rows KL+KU+2 to 2*KL+KU+1.  If EQUED .ne. 'N', then AFB is\n*          the factored form of the equilibrated matrix A.\n*\n*          If FACT = 'N', then AFB is an output argument and on exit\n*          returns details of the LU factorization of A.\n*\n*          If FACT = 'E', then AFB is an output argument and on exit\n*          returns details of the LU factorization of the equilibrated\n*          matrix A (see the description of AB for the form of the\n*          equilibrated matrix).\n*\n*  LDAFB   (input) INTEGER\n*          The leading dimension of the array AFB.  LDAFB >= 2*KL+KU+1.\n*\n*  IPIV    (input or output) INTEGER array, dimension (N)\n*          If FACT = 'F', then IPIV is an input argument and on entry\n*          contains the pivot indices from the factorization A = L*U\n*          as computed by DGBTRF; row i of the matrix was interchanged\n*          with row IPIV(i).\n*\n*          If FACT = 'N', then IPIV is an output argument and on exit\n*          contains the pivot indices from the factorization A = L*U\n*          of the original matrix A.\n*\n*          If FACT = 'E', then IPIV is an output argument and on exit\n*          contains the pivot indices from the factorization A = L*U\n*          of the equilibrated matrix A.\n*\n*  EQUED   (input or output) CHARACTER*1\n*          Specifies the form of equilibration that was done.\n*          = 'N':  No equilibration (always true if FACT = 'N').\n*          = 'R':  Row equilibration, i.e., A has been premultiplied by\n*                  diag(R).\n*          = 'C':  Column equilibration, i.e., A has been postmultiplied\n*                  by diag(C).\n*          = 'B':  Both row and column equilibration, i.e., A has been\n*                  replaced by diag(R) * A * diag(C).\n*          EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*          output argument.\n*\n*  R       (input or output) DOUBLE PRECISION array, dimension (N)\n*          The row scale factors for A.  If EQUED = 'R' or 'B', A is\n*          multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n*          is not accessed.  R is an input argument if FACT = 'F';\n*          otherwise, R is an output argument.  If FACT = 'F' and\n*          EQUED = 'R' or 'B', each element of R must be positive.\n*\n*  C       (input or output) DOUBLE PRECISION array, dimension (N)\n*          The column scale factors for A.  If EQUED = 'C' or 'B', A is\n*          multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n*          is not accessed.  C is an input argument if FACT = 'F';\n*          otherwise, C is an output argument.  If FACT = 'F' and\n*          EQUED = 'C' or 'B', each element of C must be positive.\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit,\n*          if EQUED = 'N', B is not modified;\n*          if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n*          diag(R)*B;\n*          if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n*          overwritten by diag(C)*B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n*          to the original system of equations.  Note that A and B are\n*          modified on exit if EQUED .ne. 'N', and the solution to the\n*          equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n*          EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n*          and EQUED = 'R' or 'B'.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The estimate of the reciprocal condition number of the matrix\n*          A after equilibration (if done).  If RCOND is less than the\n*          machine precision (in particular, if RCOND = 0), the matrix\n*          is singular to working precision.  This condition is\n*          indicated by a return code of INFO > 0.\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (3*N)\n*          On exit, WORK(1) contains the reciprocal pivot growth\n*          factor norm(A)/norm(U). The \"max absolute element\" norm is\n*          used. If WORK(1) is much less than 1, then the stability\n*          of the LU factorization of the (equilibrated) matrix A\n*          could be poor. This also means that the solution X, condition\n*          estimator RCOND, and forward error bound FERR could be\n*          unreliable. If factorization fails with 0 0:  if INFO = i, and i is\n*                <= N:  U(i,i) is exactly zero.  The factorization\n*                       has been completed, but the factor U is exactly\n*                       singular, so the solution and error bounds\n*                       could not be computed. RCOND = 0 is returned.\n*                = N+1: U is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, work, info, ab, afb, ipiv, equed, r, c, b = NumRu::Lapack.dgbsvx( fact, trans, kl, ku, ab, b, [:afb => afb, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 11)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_fact = argv[0];
  rblapack_trans = argv[1];
  rblapack_kl = argv[2];
  rblapack_ku = argv[3];
  rblapack_ab = argv[4];
  rblapack_b = argv[5];
  if (argc == 11) {
    rblapack_afb = argv[6];
    rblapack_ipiv = argv[7];
    rblapack_equed = argv[8];
    rblapack_r = argv[9];
    rblapack_c = argv[10];
  } else if (rblapack_options != Qnil) {
    rblapack_afb = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("afb")));
    rblapack_ipiv = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("ipiv")));
    rblapack_equed = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("equed")));
    rblapack_r = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("r")));
    rblapack_c = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("c")));
  } else {
    rblapack_afb = Qnil;
    rblapack_ipiv = Qnil;
    rblapack_equed = Qnil;
    rblapack_r = Qnil;
    rblapack_c = Qnil;
  }

  fact = StringValueCStr(rblapack_fact)[0];
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  if (rblapack_ipiv != Qnil) {
    if (!NA_IsNArray(rblapack_ipiv))
      rb_raise(rb_eArgError, "ipiv (option) must be NArray");
    if (NA_RANK(rblapack_ipiv) != 1)
      rb_raise(rb_eArgError, "rank of ipiv (option) must be %d", 1);
    if (NA_SHAPE0(rblapack_ipiv) != n)
      rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of ab");
    if (NA_TYPE(rblapack_ipiv) != NA_LINT)
      rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
    ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  }
  if (rblapack_r != Qnil) {
    if (!NA_IsNArray(rblapack_r))
      rb_raise(rb_eArgError, "r (option) must be NArray");
    if (NA_RANK(rblapack_r) != 1)
      rb_raise(rb_eArgError, "rank of r (option) must be %d", 1);
    if (NA_SHAPE0(rblapack_r) != n)
      rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of ab");
    if (NA_TYPE(rblapack_r) != NA_DFLOAT)
      rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
    r = NA_PTR_TYPE(rblapack_r, doublereal*);
  }
  ldx = n;
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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_equed != Qnil) {
  equed = StringValueCStr(rblapack_equed)[0];
  }
  ku = NUM2INT(rblapack_ku);
  if (rblapack_c != Qnil) {
    if (!NA_IsNArray(rblapack_c))
      rb_raise(rb_eArgError, "c (option) must be NArray");
    if (NA_RANK(rblapack_c) != 1)
      rb_raise(rb_eArgError, "rank of c (option) must be %d", 1);
    if (NA_SHAPE0(rblapack_c) != n)
      rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
    if (NA_TYPE(rblapack_c) != NA_DFLOAT)
      rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
    c = NA_PTR_TYPE(rblapack_c, doublereal*);
  }
  ldafb = 2*kl+ku+1;
  if (rblapack_afb != Qnil) {
    if (!NA_IsNArray(rblapack_afb))
      rb_raise(rb_eArgError, "afb (option) must be NArray");
    if (NA_RANK(rblapack_afb) != 2)
      rb_raise(rb_eArgError, "rank of afb (option) must be %d", 2);
    if (NA_SHAPE0(rblapack_afb) != ldafb)
      rb_raise(rb_eRuntimeError, "shape 0 of afb must be 2*kl+ku+1");
    if (NA_SHAPE1(rblapack_afb) != n)
      rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
    if (NA_TYPE(rblapack_afb) != NA_DFLOAT)
      rblapack_afb = na_change_type(rblapack_afb, NA_DFLOAT);
    afb = NA_PTR_TYPE(rblapack_afb, doublereal*);
  }
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 3*n;
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
  MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldafb;
    shape[1] = n;
    rblapack_afb_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  afb_out__ = NA_PTR_TYPE(rblapack_afb_out__, doublereal*);
  if (rblapack_afb != Qnil) {
    MEMCPY(afb_out__, afb, doublereal, NA_TOTAL(rblapack_afb));
  }
  rblapack_afb = rblapack_afb_out__;
  afb = afb_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  if (rblapack_ipiv != Qnil) {
    MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  }
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_r_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  r_out__ = NA_PTR_TYPE(rblapack_r_out__, doublereal*);
  if (rblapack_r != Qnil) {
    MEMCPY(r_out__, r, doublereal, NA_TOTAL(rblapack_r));
  }
  rblapack_r = rblapack_r_out__;
  r = r_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  if (rblapack_c != Qnil) {
    MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  }
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  iwork = ALLOC_N(integer, (n));

  dgbsvx_(&fact, &trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);

  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(13, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_work, rblapack_info, rblapack_ab, rblapack_afb, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b);
}

void
init_lapack_dgbsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgbsvx", rblapack_dgbsvx, -1);
}
ruby-lapack-1.7.2/ext/dsytri2x.c0000644000175000017500000001164312502221023016315 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsytri2x_(char* uplo, integer* n, doublereal* a, integer* lda, integer* ipiv, doublereal* work, integer* nb, integer* info);


static VALUE
rblapack_dsytri2x(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_nb;
  integer nb; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  doublereal *work;

  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  info, a = NumRu::Lapack.dsytri2x( uplo, a, ipiv, nb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSYTRI2X computes the inverse of a real symmetric indefinite matrix\n*  A using the factorization A = U*D*U**T or A = L*D*L**T computed by\n*  DSYTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**T;\n*          = 'L':  Lower triangular, form is A = L*D*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the NNB diagonal matrix D and the multipliers\n*          used to obtain the factor U or L as computed by DSYTRF.\n*\n*          On exit, if INFO = 0, the (symmetric) inverse of the original\n*          matrix.  If UPLO = 'U', the upper triangular part of the\n*          inverse is formed and the part of A below the diagonal is not\n*          referenced; if UPLO = 'L' the lower triangular part of the\n*          inverse is formed and the part of A above the diagonal is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the NNB structure of D\n*          as determined by DSYTRF.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (N+NNB+1,NNB+3)\n*\n*  NB      (input) INTEGER\n*          Block size\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, D(i,i) = 0; the matrix is singular and its\n*               inverse could not be computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.dsytri2x( uplo, a, ipiv, nb, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_nb = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  nb = NUM2INT(rblapack_nb);
  {
    na_shape_t 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, (n+nb+1)*(nb+3));

  dsytri2x_(&uplo, &n, a, &lda, ipiv, work, &nb, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_dsytri2x(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsytri2x", rblapack_dsytri2x, -1);
}
ruby-lapack-1.7.2/ext/cpbsv.c0000644000175000017500000001577312502221016015654 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cpbsv_(char* uplo, integer* n, integer* kd, integer* nrhs, complex* ab, integer* ldab, complex* b, integer* ldb, integer* info);


static VALUE
rblapack_cpbsv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  complex *ab_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer ldab;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, ab, b = NumRu::Lapack.cpbsv( uplo, kd, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPBSV computes the solution to a complex system of linear equations\n*     A * X = B,\n*  where A is an N-by-N Hermitian positive definite band matrix and X\n*  and B are N-by-NRHS matrices.\n*\n*  The Cholesky decomposition is used to factor A as\n*     A = U**H * U,  if UPLO = 'U', or\n*     A = L * L**H,  if UPLO = 'L',\n*  where U is an upper triangular band matrix, and L is a lower\n*  triangular band matrix, with the same number of superdiagonals or\n*  subdiagonals as A.  The factored form of A is then used to solve the\n*  system of equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AB      (input/output) COMPLEX array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(N,j+KD).\n*          See below for further details.\n*\n*          On exit, if INFO = 0, the triangular factor U or L from the\n*          Cholesky factorization A = U**H*U or A = L*L**H of the band\n*          matrix A, in the same storage format as A.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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 leading minor of order i of A is not\n*                positive definite, so the factorization could not be\n*                completed, and the solution has not been computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  N = 6, KD = 2, and UPLO = 'U':\n*\n*  On entry:                       On exit:\n*\n*      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46\n*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56\n*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66\n*\n*  Similarly, if UPLO = 'L' the format of A is as follows:\n*\n*  On entry:                       On exit:\n*\n*     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66\n*     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *\n*     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *\n*\n*  Array elements marked * are not used by the routine.\n*\n*  =====================================================================\n*\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CPBTRF, CPBTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ab, b = NumRu::Lapack.cpbsv( uplo, kd, ab, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  kd = NUM2INT(rblapack_kd);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
  MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  cpbsv_(&uplo, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_ab, rblapack_b);
}

void
init_lapack_cpbsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cpbsv", rblapack_cpbsv, -1);
}
ruby-lapack-1.7.2/ext/dspgvx.c0000644000175000017500000003062112502221022016034 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dspgvx_(integer* itype, char* jobz, char* range, char* uplo, integer* n, doublereal* ap, doublereal* bp, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublereal* z, integer* ldz, doublereal* work, integer* iwork, integer* ifail, integer* info);


static VALUE
rblapack_dspgvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_bp;
  doublereal *bp; 
  VALUE rblapack_vl;
  doublereal vl; 
  VALUE rblapack_vu;
  doublereal vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  doublereal abstol; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_ifail;
  integer *ifail; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublereal *ap_out__;
  VALUE rblapack_bp_out__;
  doublereal *bp_out__;
  doublereal *work;
  integer *iwork;

  integer ldap;
  integer n;
  integer ldz;

  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  m, w, z, ifail, info, ap, bp = NumRu::Lapack.dspgvx( itype, jobz, range, uplo, ap, bp, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSPGVX computes selected eigenvalues, and optionally, eigenvectors\n*  of a real generalized symmetric-definite eigenproblem, of the form\n*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A\n*  and B are assumed to be symmetric, stored in packed storage, and B\n*  is also positive definite.  Eigenvalues and eigenvectors can be\n*  selected by specifying either a range of values or a range of indices\n*  for the desired eigenvalues.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          Specifies the problem type to be solved:\n*          = 1:  A*x = (lambda)*B*x\n*          = 2:  A*B*x = (lambda)*x\n*          = 3:  B*A*x = (lambda)*x\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found.\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found.\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A and B are stored;\n*          = 'L':  Lower triangle of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix pencil (A,B).  N >= 0.\n*\n*  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, the contents of AP are destroyed.\n*\n*  BP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          B, packed columnwise in a linear array.  The j-th column of B\n*          is stored in the array BP as follows:\n*          if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;\n*          if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.\n*\n*          On exit, the triangular factor U or L from the Cholesky\n*          factorization B = U**T*U or B = L*L**T, in the same storage\n*          format as B.\n*\n*  VL      (input) DOUBLE PRECISION\n*  VU      (input) DOUBLE PRECISION\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) DOUBLE PRECISION\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less than\n*          or equal to zero, then  EPS*|T|  will be used in its place,\n*          where |T| is the 1-norm of the tridiagonal matrix obtained\n*          by reducing A to tridiagonal form.\n*\n*          Eigenvalues will be computed most accurately when ABSTOL is\n*          set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n*          If this routine returns with INFO>0, indicating that some\n*          eigenvectors did not converge, try setting ABSTOL to\n*          2*DLAMCH('S').\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          On normal exit, the first M elements contain the selected\n*          eigenvalues in ascending order.\n*\n*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))\n*          If JOBZ = 'N', then Z is not referenced.\n*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix A\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          The eigenvectors are normalized as follows:\n*          if ITYPE = 1 or 2, Z**T*B*Z = I;\n*          if ITYPE = 3, Z**T*inv(B)*Z = I.\n*\n*          If an eigenvector fails to converge, then that column of Z\n*          contains the latest approximation to the eigenvector, and the\n*          index of the eigenvector is returned in IFAIL.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (8*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (5*N)\n*\n*  IFAIL   (output) INTEGER array, dimension (N)\n*          If JOBZ = 'V', then if INFO = 0, the first M elements of\n*          IFAIL are zero.  If INFO > 0, then IFAIL contains the\n*          indices of the eigenvectors that failed to converge.\n*          If JOBZ = 'N', then IFAIL is not referenced.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  DPPTRF or DSPEVX returned an error code:\n*             <= N:  if INFO = i, DSPEVX failed to converge;\n*                    i eigenvectors failed to converge.  Their indices\n*                    are stored in array IFAIL.\n*             > N:   if INFO = N + i, for 1 <= i <= N, then the leading\n*                    minor of order i of B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA\n*\n* =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            ALLEIG, INDEIG, UPPER, VALEIG, WANTZ\n      CHARACTER          TRANS\n      INTEGER            J\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DPPTRF, DSPEVX, DSPGST, DTPMV, DTPSV, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, ifail, info, ap, bp = NumRu::Lapack.dspgvx( itype, jobz, range, uplo, ap, bp, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 11 && argc != 11)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
  rblapack_itype = argv[0];
  rblapack_jobz = argv[1];
  rblapack_range = argv[2];
  rblapack_uplo = argv[3];
  rblapack_ap = argv[4];
  rblapack_bp = argv[5];
  rblapack_vl = argv[6];
  rblapack_vu = argv[7];
  rblapack_il = argv[8];
  rblapack_iu = argv[9];
  rblapack_abstol = argv[10];
  if (argc == 11) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  itype = NUM2INT(rblapack_itype);
  range = StringValueCStr(rblapack_range)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  vl = NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  abstol = NUM2DBL(rblapack_abstol);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_bp))
    rb_raise(rb_eArgError, "bp (6th argument) must be NArray");
  if (NA_RANK(rblapack_bp) != 1)
    rb_raise(rb_eArgError, "rank of bp (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_bp) != NA_DFLOAT)
    rblapack_bp = na_change_type(rblapack_bp, NA_DFLOAT);
  bp = NA_PTR_TYPE(rblapack_bp, doublereal*);
  iu = NUM2INT(rblapack_iu);
  m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
  uplo = StringValueCStr(rblapack_uplo)[0];
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  vu = NUM2DBL(rblapack_vu);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = lsame_(&jobz,"N") ? 0 : ldz;
    shape[1] = lsame_(&jobz,"N") ? 0 : MAX(1,m);
    rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
  MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_bp_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  bp_out__ = NA_PTR_TYPE(rblapack_bp_out__, doublereal*);
  MEMCPY(bp_out__, bp, doublereal, NA_TOTAL(rblapack_bp));
  rblapack_bp = rblapack_bp_out__;
  bp = bp_out__;
  work = ALLOC_N(doublereal, (8*n));
  iwork = ALLOC_N(integer, (5*n));

  dspgvx_(&itype, &jobz, &range, &uplo, &n, ap, bp, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, iwork, ifail, &info);

  free(work);
  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_ap, rblapack_bp);
}

void
init_lapack_dspgvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dspgvx", rblapack_dspgvx, -1);
}
ruby-lapack-1.7.2/ext/zung2l.c0000644000175000017500000001053512502221024015746 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zung2l_(integer* m, integer* n, integer* k, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* info);


static VALUE
rblapack_zung2l(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  doublecomplex *work;

  integer lda;
  integer n;
  integer k;

  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  info, a = NumRu::Lapack.zung2l( m, a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZUNG2L generates an m by n complex matrix Q with orthonormal columns,\n*  which is defined as the last n columns of a product of k elementary\n*  reflectors of order m\n*\n*        Q  =  H(k) . . . H(2) H(1)\n*\n*  as returned by ZGEQLF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. M >= N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. N >= K >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the (n-k+i)-th column must contain the vector which\n*          defines the elementary reflector H(i), for i = 1,2,...,k, as\n*          returned by ZGEQLF in the last k columns of its array\n*          argument A.\n*          On exit, the m-by-n matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) COMPLEX*16 array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by ZGEQLF.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -i, the i-th argument has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.zung2l( m, a, tau, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  rblapack_tau = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (3th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (3th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_DCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(doublecomplex, (n));

  zung2l_(&m, &n, &k, a, &lda, tau, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_zung2l(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zung2l", rblapack_zung2l, -1);
}
ruby-lapack-1.7.2/ext/zla_syamv.c0000644000175000017500000001660612502221015016537 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zla_syamv_(integer* uplo, integer* n, doublereal* alpha, doublereal* a, integer* lda, doublecomplex* x, integer* incx, doublereal* beta, doublereal* y, integer* incy);


static VALUE
rblapack_zla_syamv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  integer uplo; 
  VALUE rblapack_alpha;
  doublereal alpha; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_beta;
  doublereal beta; 
  VALUE rblapack_y;
  doublereal *y; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_y_out__;
  doublereal *y_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  y = NumRu::Lapack.zla_syamv( uplo, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n*  Purpose\n*  =======\n*\n*  ZLA_SYAMV  performs the matrix-vector operation\n*\n*          y := alpha*abs(A)*abs(x) + beta*abs(y),\n*\n*  where alpha and beta are scalars, x and y are vectors and A is an\n*  n by n symmetric matrix.\n*\n*  This function is primarily used in calculating error bounds.\n*  To protect against underflow during evaluation, components in\n*  the resulting vector are perturbed away from zero by (N+1)\n*  times the underflow threshold.  To prevent unnecessarily large\n*  errors for block-structure embedded in general matrices,\n*  \"symbolically\" zero components are not perturbed.  A zero\n*  entry is considered \"symbolic\" if all multiplications involved\n*  in computing that entry have at least one zero multiplicand.\n*\n\n*  Arguments\n*  ==========\n*\n*  UPLO    (input) INTEGER\n*           On entry, UPLO specifies whether the upper or lower\n*           triangular part of the array A is to be referenced as\n*           follows:\n*\n*              UPLO = BLAS_UPPER   Only the upper triangular part of A\n*                                  is to be referenced.\n*\n*              UPLO = BLAS_LOWER   Only the lower triangular part of A\n*                                  is to be referenced.\n*\n*           Unchanged on exit.\n*\n*  N       (input) INTEGER\n*           On entry, N specifies the number of columns of the matrix A.\n*           N must be at least zero.\n*           Unchanged on exit.\n*\n*  ALPHA  - DOUBLE PRECISION   .\n*           On entry, ALPHA specifies the scalar alpha.\n*           Unchanged on exit.\n*\n*  A      - COMPLEX*16         array of DIMENSION ( LDA, n ).\n*           Before entry, the leading m by n part of the array A must\n*           contain the matrix of coefficients.\n*           Unchanged on exit.\n*\n*  LDA     (input) INTEGER\n*           On entry, LDA specifies the first dimension of A as declared\n*           in the calling (sub) program. LDA must be at least\n*           max( 1, n ).\n*           Unchanged on exit.\n*\n*  X      - COMPLEX*16         array of DIMENSION at least\n*           ( 1 + ( n - 1 )*abs( INCX ) )\n*           Before entry, the incremented array X must contain the\n*           vector x.\n*           Unchanged on exit.\n*\n*  INCX    (input) INTEGER\n*           On entry, INCX specifies the increment for the elements of\n*           X. INCX must not be zero.\n*           Unchanged on exit.\n*\n*  BETA   - DOUBLE PRECISION   .\n*           On entry, BETA specifies the scalar beta. When BETA is\n*           supplied as zero then Y need not be set on input.\n*           Unchanged on exit.\n*\n*  Y       (input/output) DOUBLE PRECISION  array, dimension\n*           ( 1 + ( n - 1 )*abs( INCY ) )\n*           Before entry with BETA non-zero, the incremented array Y\n*           must contain the vector y. On exit, Y is overwritten by the\n*           updated vector y.\n*\n*  INCY    (input) INTEGER\n*           On entry, INCY specifies the increment for the elements of\n*           Y. INCY must not be zero.\n*           Unchanged on exit.\n*\n\n*  Further Details\n*  ===============\n*\n*  Level 2 Blas routine.\n*\n*  -- Written on 22-October-1986.\n*     Jack Dongarra, Argonne National Lab.\n*     Jeremy Du Croz, Nag Central Office.\n*     Sven Hammarling, Nag Central Office.\n*     Richard Hanson, Sandia National Labs.\n*  -- Modified for the absolute-value product, April 2006\n*     Jason Riedy, UC Berkeley\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  y = NumRu::Lapack.zla_syamv( uplo, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_uplo = argv[0];
  rblapack_alpha = argv[1];
  rblapack_a = argv[2];
  rblapack_x = argv[3];
  rblapack_incx = argv[4];
  rblapack_beta = argv[5];
  rblapack_y = argv[6];
  rblapack_incy = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = NUM2INT(rblapack_uplo);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (lda != (MAX(1, n)))
    rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", MAX(1, n));
  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*);
  incx = NUM2INT(rblapack_incx);
  incy = NUM2INT(rblapack_incy);
  alpha = NUM2DBL(rblapack_alpha);
  beta = NUM2DBL(rblapack_beta);
  lda = MAX(1, n);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (4th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1+(n-1)*abs(incx)))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*abs(incx));
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (7th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (1 + ( n - 1 )*abs( incy )))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1 + ( n - 1 )*abs( incy ));
  if (NA_TYPE(rblapack_y) != NA_DFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
  y = NA_PTR_TYPE(rblapack_y, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 1 + ( n - 1 )*abs( incy );
    rblapack_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
  MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  zla_syamv_(&uplo, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);

  return rblapack_y;
}

void
init_lapack_zla_syamv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zla_syamv", rblapack_zla_syamv, -1);
}
ruby-lapack-1.7.2/ext/cgttrf.c0000644000175000017500000001472412502221023016021 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgttrf_(integer* n, complex* dl, complex* d, complex* du, complex* du2, integer* ipiv, integer* info);


static VALUE
rblapack_cgttrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_dl;
  complex *dl; 
  VALUE rblapack_d;
  complex *d; 
  VALUE rblapack_du;
  complex *du; 
  VALUE rblapack_du2;
  complex *du2; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_dl_out__;
  complex *dl_out__;
  VALUE rblapack_d_out__;
  complex *d_out__;
  VALUE rblapack_du_out__;
  complex *du_out__;

  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  du2, ipiv, info, dl, d, du = NumRu::Lapack.cgttrf( dl, d, du, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGTTRF( N, DL, D, DU, DU2, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGTTRF computes an LU factorization of a complex tridiagonal matrix A\n*  using elimination with partial pivoting and row interchanges.\n*\n*  The factorization has the form\n*     A = L * U\n*  where L is a product of permutation and unit lower bidiagonal\n*  matrices and U is upper triangular with nonzeros in only the main\n*  diagonal and first two superdiagonals.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.\n*\n*  DL      (input/output) COMPLEX array, dimension (N-1)\n*          On entry, DL must contain the (n-1) sub-diagonal elements of\n*          A.\n*\n*          On exit, DL is overwritten by the (n-1) multipliers that\n*          define the matrix L from the LU factorization of A.\n*\n*  D       (input/output) COMPLEX array, dimension (N)\n*          On entry, D must contain the diagonal elements of A.\n*\n*          On exit, D is overwritten by the n diagonal elements of the\n*          upper triangular matrix U from the LU factorization of A.\n*\n*  DU      (input/output) COMPLEX array, dimension (N-1)\n*          On entry, DU must contain the (n-1) super-diagonal elements\n*          of A.\n*\n*          On exit, DU is overwritten by the (n-1) elements of the first\n*          super-diagonal of U.\n*\n*  DU2     (output) COMPLEX array, dimension (N-2)\n*          On exit, DU2 is overwritten by the (n-2) elements of the\n*          second super-diagonal of U.\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          The pivot indices; for 1 <= i <= n, row i of the matrix was\n*          interchanged with row IPIV(i).  IPIV(i) will always be either\n*          i or i+1; IPIV(i) = i indicates a row interchange was not\n*          required.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -k, the k-th argument had an illegal value\n*          > 0:  if INFO = k, U(k,k) is exactly zero. The factorization\n*                has been completed, but the factor U is exactly\n*                singular, and division by zero will occur if it is used\n*                to solve a system of equations.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  du2, ipiv, info, dl, d, du = NumRu::Lapack.cgttrf( dl, d, du, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_dl = argv[0];
  rblapack_d = argv[1];
  rblapack_du = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SCOMPLEX)
    rblapack_d = na_change_type(rblapack_d, NA_SCOMPLEX);
  d = NA_PTR_TYPE(rblapack_d, complex*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (1th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (1th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_SCOMPLEX)
    rblapack_dl = na_change_type(rblapack_dl, NA_SCOMPLEX);
  dl = NA_PTR_TYPE(rblapack_dl, complex*);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (3th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_SCOMPLEX)
    rblapack_du = na_change_type(rblapack_du, NA_SCOMPLEX);
  du = NA_PTR_TYPE(rblapack_du, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n-2;
    rblapack_du2 = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  du2 = NA_PTR_TYPE(rblapack_du2, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_dl_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  dl_out__ = NA_PTR_TYPE(rblapack_dl_out__, complex*);
  MEMCPY(dl_out__, dl, complex, NA_TOTAL(rblapack_dl));
  rblapack_dl = rblapack_dl_out__;
  dl = dl_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, complex*);
  MEMCPY(d_out__, d, complex, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_du_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  du_out__ = NA_PTR_TYPE(rblapack_du_out__, complex*);
  MEMCPY(du_out__, du, complex, NA_TOTAL(rblapack_du));
  rblapack_du = rblapack_du_out__;
  du = du_out__;

  cgttrf_(&n, dl, d, du, du2, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_du2, rblapack_ipiv, rblapack_info, rblapack_dl, rblapack_d, rblapack_du);
}

void
init_lapack_cgttrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgttrf", rblapack_cgttrf, -1);
}
ruby-lapack-1.7.2/ext/sgees.c0000644000175000017500000002310712502221024015632 0ustar  uwabamiuwabami#include "rb_lapack.h"

static logical
rblapack_select(real *arg0, real *arg1){
  VALUE rblapack_arg0, rblapack_arg1;

  VALUE rblapack_ret;
  logical ret;

  rblapack_arg0 = rb_float_new((double)(*arg0));
  rblapack_arg1 = rb_float_new((double)(*arg1));

  rblapack_ret = rb_yield_values(2, rblapack_arg0, rblapack_arg1);

  ret = (rblapack_ret == Qtrue);
  return ret;
}

extern VOID sgees_(char* jobvs, char* sort, L_fp select, integer* n, real* a, integer* lda, integer* sdim, real* wr, real* wi, real* vs, integer* ldvs, real* work, integer* lwork, logical* bwork, integer* info);


static VALUE
rblapack_sgees(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvs;
  char jobvs; 
  VALUE rblapack_sort;
  char sort; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_sdim;
  integer sdim; 
  VALUE rblapack_wr;
  real *wr; 
  VALUE rblapack_wi;
  real *wi; 
  VALUE rblapack_vs;
  real *vs; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  logical *bwork;

  integer lda;
  integer n;
  integer ldvs;

  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  sdim, wr, wi, vs, work, info, a = NumRu::Lapack.sgees( jobvs, sort, a, [:lwork => lwork, :usage => usage, :help => help]){|a,b| ... }\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, VS, LDVS, WORK, LWORK, BWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGEES computes for an N-by-N real nonsymmetric matrix A, the\n*  eigenvalues, the real Schur form T, and, optionally, the matrix of\n*  Schur vectors Z.  This gives the Schur factorization A = Z*T*(Z**T).\n*\n*  Optionally, it also orders the eigenvalues on the diagonal of the\n*  real Schur form so that selected eigenvalues are at the top left.\n*  The leading columns of Z then form an orthonormal basis for the\n*  invariant subspace corresponding to the selected eigenvalues.\n*\n*  A matrix is in real Schur form if it is upper quasi-triangular with\n*  1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the\n*  form\n*          [  a  b  ]\n*          [  c  a  ]\n*\n*  where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVS   (input) CHARACTER*1\n*          = 'N': Schur vectors are not computed;\n*          = 'V': Schur vectors are computed.\n*\n*  SORT    (input) CHARACTER*1\n*          Specifies whether or not to order the eigenvalues on the\n*          diagonal of the Schur form.\n*          = 'N': Eigenvalues are not ordered;\n*          = 'S': Eigenvalues are ordered (see SELECT).\n*\n*  SELECT  (external procedure) LOGICAL FUNCTION of two REAL arguments\n*          SELECT must be declared EXTERNAL in the calling subroutine.\n*          If SORT = 'S', SELECT is used to select eigenvalues to sort\n*          to the top left of the Schur form.\n*          If SORT = 'N', SELECT is not referenced.\n*          An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if\n*          SELECT(WR(j),WI(j)) is true; i.e., if either one of a complex\n*          conjugate pair of eigenvalues is selected, then both complex\n*          eigenvalues are selected.\n*          Note that a selected complex eigenvalue may no longer\n*          satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since\n*          ordering may change the value of complex eigenvalues\n*          (especially if the eigenvalue is ill-conditioned); in this\n*          case INFO is set to N+2 (see INFO below).\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the N-by-N matrix A.\n*          On exit, A has been overwritten by its real Schur form T.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  SDIM    (output) INTEGER\n*          If SORT = 'N', SDIM = 0.\n*          If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n*                         for which SELECT is true. (Complex conjugate\n*                         pairs for which SELECT is true for either\n*                         eigenvalue count as 2.)\n*\n*  WR      (output) REAL array, dimension (N)\n*  WI      (output) REAL array, dimension (N)\n*          WR and WI contain the real and imaginary parts,\n*          respectively, of the computed eigenvalues in the same order\n*          that they appear on the diagonal of the output Schur form T.\n*          Complex conjugate pairs of eigenvalues will appear\n*          consecutively with the eigenvalue having the positive\n*          imaginary part first.\n*\n*  VS      (output) REAL array, dimension (LDVS,N)\n*          If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur\n*          vectors.\n*          If JOBVS = 'N', VS is not referenced.\n*\n*  LDVS    (input) INTEGER\n*          The leading dimension of the array VS.  LDVS >= 1; if\n*          JOBVS = 'V', LDVS >= N.\n*\n*  WORK    (workspace/output) REAL array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) contains the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK.  LWORK >= max(1,3*N).\n*          For good performance, LWORK must generally be larger.\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*  BWORK   (workspace) LOGICAL array, dimension (N)\n*          Not referenced if SORT = 'N'.\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, and i is\n*             <= N: the QR algorithm failed to compute all the\n*                   eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI\n*                   contain those eigenvalues which have converged; if\n*                   JOBVS = 'V', VS contains the matrix which reduces A\n*                   to its partially converged Schur form.\n*             = N+1: the eigenvalues could not be reordered because some\n*                   eigenvalues were too close to separate (the problem\n*                   is very ill-conditioned);\n*             = N+2: after reordering, roundoff changed values of some\n*                   complex eigenvalues so that leading eigenvalues in\n*                   the Schur form no longer satisfy SELECT=.TRUE.  This\n*                   could also be caused by underflow due to scaling.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sdim, wr, wi, vs, work, info, a = NumRu::Lapack.sgees( jobvs, sort, a, [:lwork => lwork, :usage => usage, :help => help]){|a,b| ... }\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_jobvs = argv[0];
  rblapack_sort = argv[1];
  rblapack_a = 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;
  }

  jobvs = StringValueCStr(rblapack_jobvs)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  ldvs = lsame_(&jobvs,"V") ? n : 1;
  sort = StringValueCStr(rblapack_sort)[0];
  if (rblapack_lwork == Qnil)
    lwork = 3*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  wr = NA_PTR_TYPE(rblapack_wr, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wi = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  wi = NA_PTR_TYPE(rblapack_wi, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldvs;
    shape[1] = n;
    rblapack_vs = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vs = NA_PTR_TYPE(rblapack_vs, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));

  sgees_(&jobvs, &sort, rblapack_select, &n, a, &lda, &sdim, wr, wi, vs, &ldvs, work, &lwork, bwork, &info);

  free(bwork);
  rblapack_sdim = INT2NUM(sdim);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_sdim, rblapack_wr, rblapack_wi, rblapack_vs, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_sgees(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgees", rblapack_sgees, -1);
}
ruby-lapack-1.7.2/ext/dgesv.c0000644000175000017500000001272212502221020015631 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgesv_(integer* n, integer* nrhs, doublereal* a, integer* lda, integer* ipiv, doublereal* b, integer* ldb, integer* info);


static VALUE
rblapack_dgesv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  ipiv, info, a, b = NumRu::Lapack.dgesv( a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGESV computes the solution to a real system of linear equations\n*     A * X = B,\n*  where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n*  The LU decomposition with partial pivoting and row interchanges is\n*  used to factor A as\n*     A = P * L * U,\n*  where P is a permutation matrix, L is unit lower triangular, and U is\n*  upper triangular.  The factored form of A is then used to solve the\n*  system of equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the N-by-N coefficient matrix A.\n*          On exit, the factors L and U from the factorization\n*          A = P*L*U; the unit diagonal elements of L are not stored.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          The pivot indices that define the permutation matrix P;\n*          row i of the matrix was interchanged with row IPIV(i).\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS matrix of right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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, U(i,i) is exactly zero.  The factorization\n*                has been completed, but the factor U is exactly\n*                singular, so the solution could not be computed.\n*\n\n*  =====================================================================\n*\n*     .. External Subroutines ..\n      EXTERNAL           DGETRF, DGETRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, a, b = NumRu::Lapack.dgesv( a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  if (argc == 2) {
  } 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*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dgesv_(&n, &nrhs, a, &lda, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ipiv, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_dgesv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgesv", rblapack_dgesv, -1);
}
ruby-lapack-1.7.2/ext/dbbcsd.c0000644000175000017500000004124712502221022015750 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dbbcsd_(char* jobu1, char* jobu2, char* jobv1t, char* jobv2t, char* trans, integer* m, integer* p, integer* q, doublereal* theta, doublereal* phi, doublereal* u1, integer* ldu1, doublereal* u2, integer* ldu2, doublereal* v1t, integer* ldv1t, doublereal* v2t, integer* ldv2t, doublereal* b11d, doublereal* b11e, doublereal* b12d, doublereal* b12e, doublereal* b21d, doublereal* b21e, doublereal* b22d, doublereal* b22e, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dbbcsd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobu1;
  char jobu1; 
  VALUE rblapack_jobu2;
  char jobu2; 
  VALUE rblapack_jobv1t;
  char jobv1t; 
  VALUE rblapack_jobv2t;
  char jobv2t; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_theta;
  doublereal *theta; 
  VALUE rblapack_phi;
  doublereal *phi; 
  VALUE rblapack_u1;
  doublereal *u1; 
  VALUE rblapack_u2;
  doublereal *u2; 
  VALUE rblapack_v1t;
  doublereal *v1t; 
  VALUE rblapack_v2t;
  doublereal *v2t; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_b11d;
  doublereal *b11d; 
  VALUE rblapack_b11e;
  doublereal *b11e; 
  VALUE rblapack_b12d;
  doublereal *b12d; 
  VALUE rblapack_b12e;
  doublereal *b12e; 
  VALUE rblapack_b21d;
  doublereal *b21d; 
  VALUE rblapack_b21e;
  doublereal *b21e; 
  VALUE rblapack_b22d;
  doublereal *b22d; 
  VALUE rblapack_b22e;
  doublereal *b22e; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_theta_out__;
  doublereal *theta_out__;
  VALUE rblapack_u1_out__;
  doublereal *u1_out__;
  VALUE rblapack_u2_out__;
  doublereal *u2_out__;
  VALUE rblapack_v1t_out__;
  doublereal *v1t_out__;
  VALUE rblapack_v2t_out__;
  doublereal *v2t_out__;
  doublereal *work;

  integer q;
  integer ldu1;
  integer p;
  integer ldu2;
  integer ldv1t;
  integer ldv2t;

  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  b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, info, theta, u1, u2, v1t, v2t = NumRu::Lapack.dbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, theta, phi, u1, u2, v1t, v2t, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, THETA, PHI, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, B22D, B22E, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DBBCSD computes the CS decomposition of an orthogonal matrix in\n*  bidiagonal-block form,\n*\n*\n*      [ B11 | B12 0  0 ]\n*      [  0  |  0 -I  0 ]\n*  X = [----------------]\n*      [ B21 | B22 0  0 ]\n*      [  0  |  0  0  I ]\n*\n*                                [  C | -S  0  0 ]\n*                    [ U1 |    ] [  0 |  0 -I  0 ] [ V1 |    ]**T\n*                  = [---------] [---------------] [---------]   .\n*                    [    | U2 ] [  S |  C  0  0 ] [    | V2 ]\n*                                [  0 |  0  0  I ]\n*\n*  X is M-by-M, its top-left block is P-by-Q, and Q must be no larger\n*  than P, M-P, or M-Q. (If Q is not the smallest index, then X must be\n*  transposed and/or permuted. This can be done in constant time using\n*  the TRANS and SIGNS options. See DORCSD for details.)\n*\n*  The bidiagonal matrices B11, B12, B21, and B22 are represented\n*  implicitly by angles THETA(1:Q) and PHI(1:Q-1).\n*\n*  The orthogonal matrices U1, U2, V1T, and V2T are input/output.\n*  The input matrices are pre- or post-multiplied by the appropriate\n*  singular vector matrices.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBU1   (input) CHARACTER\n*          = 'Y':      U1 is updated;\n*          otherwise:  U1 is not updated.\n*\n*  JOBU2   (input) CHARACTER\n*          = 'Y':      U2 is updated;\n*          otherwise:  U2 is not updated.\n*\n*  JOBV1T  (input) CHARACTER\n*          = 'Y':      V1T is updated;\n*          otherwise:  V1T is not updated.\n*\n*  JOBV2T  (input) CHARACTER\n*          = 'Y':      V2T is updated;\n*          otherwise:  V2T is not updated.\n*\n*  TRANS   (input) CHARACTER\n*          = 'T':      X, U1, U2, V1T, and V2T are stored in row-major\n*                      order;\n*          otherwise:  X, U1, U2, V1T, and V2T are stored in column-\n*                      major order.\n*\n*  M       (input) INTEGER\n*          The number of rows and columns in X, the orthogonal matrix in\n*          bidiagonal-block form.\n*\n*  P       (input) INTEGER\n*          The number of rows in the top-left block of X. 0 <= P <= M.\n*\n*  Q       (input) INTEGER\n*          The number of columns in the top-left block of X.\n*          0 <= Q <= MIN(P,M-P,M-Q).\n*\n*  THETA   (input/output) DOUBLE PRECISION array, dimension (Q)\n*          On entry, the angles THETA(1),...,THETA(Q) that, along with\n*          PHI(1), ...,PHI(Q-1), define the matrix in bidiagonal-block\n*          form. On exit, the angles whose cosines and sines define the\n*          diagonal blocks in the CS decomposition.\n*\n*  PHI     (input/workspace) DOUBLE PRECISION array, dimension (Q-1)\n*          The angles PHI(1),...,PHI(Q-1) that, along with THETA(1),...,\n*          THETA(Q), define the matrix in bidiagonal-block form.\n*\n*  U1      (input/output) DOUBLE PRECISION array, dimension (LDU1,P)\n*          On entry, an LDU1-by-P matrix. On exit, U1 is postmultiplied\n*          by the left singular vector matrix common to [ B11 ; 0 ] and\n*          [ B12 0 0 ; 0 -I 0 0 ].\n*\n*  LDU1    (input) INTEGER\n*          The leading dimension of the array U1.\n*\n*  U2      (input/output) DOUBLE PRECISION array, dimension (LDU2,M-P)\n*          On entry, an LDU2-by-(M-P) matrix. On exit, U2 is\n*          postmultiplied by the left singular vector matrix common to\n*          [ B21 ; 0 ] and [ B22 0 0 ; 0 0 I ].\n*\n*  LDU2    (input) INTEGER\n*          The leading dimension of the array U2.\n*\n*  V1T     (input/output) DOUBLE PRECISION array, dimension (LDV1T,Q)\n*          On entry, a LDV1T-by-Q matrix. On exit, V1T is premultiplied\n*          by the transpose of the right singular vector\n*          matrix common to [ B11 ; 0 ] and [ B21 ; 0 ].\n*\n*  LDV1T   (input) INTEGER\n*          The leading dimension of the array V1T.\n*\n*  V2T     (input/output) DOUBLE PRECISION array, dimenison (LDV2T,M-Q)\n*          On entry, a LDV2T-by-(M-Q) matrix. On exit, V2T is\n*          premultiplied by the transpose of the right\n*          singular vector matrix common to [ B12 0 0 ; 0 -I 0 ] and\n*          [ B22 0 0 ; 0 0 I ].\n*\n*  LDV2T   (input) INTEGER\n*          The leading dimension of the array V2T.\n*\n*  B11D    (output) DOUBLE PRECISION array, dimension (Q)\n*          When DBBCSD converges, B11D contains the cosines of THETA(1),\n*          ..., THETA(Q). If DBBCSD fails to converge, then B11D\n*          contains the diagonal of the partially reduced top-left\n*          block.\n*\n*  B11E    (output) DOUBLE PRECISION array, dimension (Q-1)\n*          When DBBCSD converges, B11E contains zeros. If DBBCSD fails\n*          to converge, then B11E contains the superdiagonal of the\n*          partially reduced top-left block.\n*\n*  B12D    (output) DOUBLE PRECISION array, dimension (Q)\n*          When DBBCSD converges, B12D contains the negative sines of\n*          THETA(1), ..., THETA(Q). If DBBCSD fails to converge, then\n*          B12D contains the diagonal of the partially reduced top-right\n*          block.\n*\n*  B12E    (output) DOUBLE PRECISION array, dimension (Q-1)\n*          When DBBCSD converges, B12E contains zeros. If DBBCSD fails\n*          to converge, then B12E contains the subdiagonal of the\n*          partially reduced top-right block.\n*\n*  WORK    (workspace) 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,8*Q).\n*\n*          If LWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal size of the WORK array,\n*          returns this value as the first entry of the work array, and\n*          no error 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 DBBCSD did not converge, INFO specifies the number\n*                of nonzero entries in PHI, and B11D, B11E, etc.,\n*                contain the partially reduced matrix.\n*\n*  Reference\n*  =========\n*\n*  [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.\n*      Algorithms, 50(1):33-65, 2009.\n*\n*  Internal Parameters\n*  ===================\n*\n*  TOLMUL  DOUBLE PRECISION, default = MAX(10,MIN(100,EPS**(-1/8)))\n*          TOLMUL controls the convergence criterion of the QR loop.\n*          Angles THETA(i), PHI(i) are rounded to 0 or PI/2 when they\n*          are within TOLMUL*EPS of either bound.\n*\n\n*  ===================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, info, theta, u1, u2, v1t, v2t = NumRu::Lapack.dbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, theta, phi, u1, u2, v1t, v2t, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 13)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_jobu1 = argv[0];
  rblapack_jobu2 = argv[1];
  rblapack_jobv1t = argv[2];
  rblapack_jobv2t = argv[3];
  rblapack_trans = argv[4];
  rblapack_m = argv[5];
  rblapack_theta = argv[6];
  rblapack_phi = argv[7];
  rblapack_u1 = argv[8];
  rblapack_u2 = argv[9];
  rblapack_v1t = argv[10];
  rblapack_v2t = argv[11];
  if (argc == 13) {
    rblapack_lwork = argv[12];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  jobu1 = StringValueCStr(rblapack_jobu1)[0];
  jobv1t = StringValueCStr(rblapack_jobv1t)[0];
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_theta))
    rb_raise(rb_eArgError, "theta (7th argument) must be NArray");
  if (NA_RANK(rblapack_theta) != 1)
    rb_raise(rb_eArgError, "rank of theta (7th argument) must be %d", 1);
  q = NA_SHAPE0(rblapack_theta);
  if (NA_TYPE(rblapack_theta) != NA_DFLOAT)
    rblapack_theta = na_change_type(rblapack_theta, NA_DFLOAT);
  theta = NA_PTR_TYPE(rblapack_theta, doublereal*);
  if (!NA_IsNArray(rblapack_u1))
    rb_raise(rb_eArgError, "u1 (9th argument) must be NArray");
  if (NA_RANK(rblapack_u1) != 2)
    rb_raise(rb_eArgError, "rank of u1 (9th argument) must be %d", 2);
  ldu1 = NA_SHAPE0(rblapack_u1);
  p = NA_SHAPE1(rblapack_u1);
  if (NA_TYPE(rblapack_u1) != NA_DFLOAT)
    rblapack_u1 = na_change_type(rblapack_u1, NA_DFLOAT);
  u1 = NA_PTR_TYPE(rblapack_u1, doublereal*);
  if (!NA_IsNArray(rblapack_v1t))
    rb_raise(rb_eArgError, "v1t (11th argument) must be NArray");
  if (NA_RANK(rblapack_v1t) != 2)
    rb_raise(rb_eArgError, "rank of v1t (11th argument) must be %d", 2);
  ldv1t = NA_SHAPE0(rblapack_v1t);
  if (NA_SHAPE1(rblapack_v1t) != q)
    rb_raise(rb_eRuntimeError, "shape 1 of v1t must be the same as shape 0 of theta");
  if (NA_TYPE(rblapack_v1t) != NA_DFLOAT)
    rblapack_v1t = na_change_type(rblapack_v1t, NA_DFLOAT);
  v1t = NA_PTR_TYPE(rblapack_v1t, doublereal*);
  if (rblapack_lwork == Qnil)
    lwork = 8*q;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  jobu2 = StringValueCStr(rblapack_jobu2)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_u2))
    rb_raise(rb_eArgError, "u2 (10th argument) must be NArray");
  if (NA_RANK(rblapack_u2) != 2)
    rb_raise(rb_eArgError, "rank of u2 (10th argument) must be %d", 2);
  ldu2 = NA_SHAPE0(rblapack_u2);
  if (NA_SHAPE1(rblapack_u2) != (m-p))
    rb_raise(rb_eRuntimeError, "shape 1 of u2 must be %d", m-p);
  if (NA_TYPE(rblapack_u2) != NA_DFLOAT)
    rblapack_u2 = na_change_type(rblapack_u2, NA_DFLOAT);
  u2 = NA_PTR_TYPE(rblapack_u2, doublereal*);
  jobv2t = StringValueCStr(rblapack_jobv2t)[0];
  if (!NA_IsNArray(rblapack_v2t))
    rb_raise(rb_eArgError, "v2t (12th argument) must be NArray");
  if (NA_RANK(rblapack_v2t) != 2)
    rb_raise(rb_eArgError, "rank of v2t (12th argument) must be %d", 2);
  ldv2t = NA_SHAPE0(rblapack_v2t);
  if (NA_SHAPE1(rblapack_v2t) != (m-q))
    rb_raise(rb_eRuntimeError, "shape 1 of v2t must be %d", m-q);
  if (NA_TYPE(rblapack_v2t) != NA_DFLOAT)
    rblapack_v2t = na_change_type(rblapack_v2t, NA_DFLOAT);
  v2t = NA_PTR_TYPE(rblapack_v2t, doublereal*);
  if (!NA_IsNArray(rblapack_phi))
    rb_raise(rb_eArgError, "phi (8th argument) must be NArray");
  if (NA_RANK(rblapack_phi) != 1)
    rb_raise(rb_eArgError, "rank of phi (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_phi) != (q-1))
    rb_raise(rb_eRuntimeError, "shape 0 of phi must be %d", q-1);
  if (NA_TYPE(rblapack_phi) != NA_DFLOAT)
    rblapack_phi = na_change_type(rblapack_phi, NA_DFLOAT);
  phi = NA_PTR_TYPE(rblapack_phi, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_b11d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  b11d = NA_PTR_TYPE(rblapack_b11d, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = q-1;
    rblapack_b11e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  b11e = NA_PTR_TYPE(rblapack_b11e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_b12d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  b12d = NA_PTR_TYPE(rblapack_b12d, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = q-1;
    rblapack_b12e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  b12e = NA_PTR_TYPE(rblapack_b12e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_b21d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  b21d = NA_PTR_TYPE(rblapack_b21d, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = q-1;
    rblapack_b21e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  b21e = NA_PTR_TYPE(rblapack_b21e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_b22d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  b22d = NA_PTR_TYPE(rblapack_b22d, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = q-1;
    rblapack_b22e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  b22e = NA_PTR_TYPE(rblapack_b22e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = q;
    rblapack_theta_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  theta_out__ = NA_PTR_TYPE(rblapack_theta_out__, doublereal*);
  MEMCPY(theta_out__, theta, doublereal, NA_TOTAL(rblapack_theta));
  rblapack_theta = rblapack_theta_out__;
  theta = theta_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldu1;
    shape[1] = p;
    rblapack_u1_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  u1_out__ = NA_PTR_TYPE(rblapack_u1_out__, doublereal*);
  MEMCPY(u1_out__, u1, doublereal, NA_TOTAL(rblapack_u1));
  rblapack_u1 = rblapack_u1_out__;
  u1 = u1_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldu2;
    shape[1] = m-p;
    rblapack_u2_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  u2_out__ = NA_PTR_TYPE(rblapack_u2_out__, doublereal*);
  MEMCPY(u2_out__, u2, doublereal, NA_TOTAL(rblapack_u2));
  rblapack_u2 = rblapack_u2_out__;
  u2 = u2_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldv1t;
    shape[1] = q;
    rblapack_v1t_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  v1t_out__ = NA_PTR_TYPE(rblapack_v1t_out__, doublereal*);
  MEMCPY(v1t_out__, v1t, doublereal, NA_TOTAL(rblapack_v1t));
  rblapack_v1t = rblapack_v1t_out__;
  v1t = v1t_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldv2t;
    shape[1] = m-q;
    rblapack_v2t_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  v2t_out__ = NA_PTR_TYPE(rblapack_v2t_out__, doublereal*);
  MEMCPY(v2t_out__, v2t, doublereal, NA_TOTAL(rblapack_v2t));
  rblapack_v2t = rblapack_v2t_out__;
  v2t = v2t_out__;
  work = ALLOC_N(doublereal, (MAX(1,lwork)));

  dbbcsd_(&jobu1, &jobu2, &jobv1t, &jobv2t, &trans, &m, &p, &q, theta, phi, u1, &ldu1, u2, &ldu2, v1t, &ldv1t, v2t, &ldv2t, b11d, b11e, b12d, b12e, b21d, b21e, b22d, b22e, work, &lwork, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(14, rblapack_b11d, rblapack_b11e, rblapack_b12d, rblapack_b12e, rblapack_b21d, rblapack_b21e, rblapack_b22d, rblapack_b22e, rblapack_info, rblapack_theta, rblapack_u1, rblapack_u2, rblapack_v1t, rblapack_v2t);
}

void
init_lapack_dbbcsd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dbbcsd", rblapack_dbbcsd, -1);
}
ruby-lapack-1.7.2/ext/claqr2.c0000644000175000017500000002616412502221020015712 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID claqr2_(logical* wantt, logical* wantz, integer* n, integer* ktop, integer* kbot, integer* nw, complex* h, integer* ldh, integer* iloz, integer* ihiz, complex* z, integer* ldz, integer* ns, integer* nd, complex* sh, complex* v, integer* ldv, integer* nh, complex* t, integer* ldt, integer* nv, complex* wv, integer* ldwv, complex* work, integer* lwork);


static VALUE
rblapack_claqr2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantt;
  logical wantt; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_ktop;
  integer ktop; 
  VALUE rblapack_kbot;
  integer kbot; 
  VALUE rblapack_nw;
  integer nw; 
  VALUE rblapack_h;
  complex *h; 
  VALUE rblapack_iloz;
  integer iloz; 
  VALUE rblapack_ihiz;
  integer ihiz; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_nh;
  integer nh; 
  VALUE rblapack_nv;
  integer nv; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_ns;
  integer ns; 
  VALUE rblapack_nd;
  integer nd; 
  VALUE rblapack_sh;
  complex *sh; 
  VALUE rblapack_h_out__;
  complex *h_out__;
  VALUE rblapack_z_out__;
  complex *z_out__;
  complex *v;
  complex *t;
  complex *wv;
  complex *work;

  integer ldh;
  integer n;
  integer ldz;
  integer ldv;
  integer ldwv;
  integer ldt;

  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  ns, nd, sh, h, z = NumRu::Lapack.claqr2( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n*     This subroutine is identical to CLAQR3 except that it avoids\n*     recursion by calling CLAHQR instead of CLAQR4.\n*\n*\n*     ******************************************************************\n*     Aggressive early deflation:\n*\n*     This subroutine accepts as input an upper Hessenberg matrix\n*     H and performs an unitary similarity transformation\n*     designed to detect and deflate fully converged eigenvalues from\n*     a trailing principal submatrix.  On output H has been over-\n*     written by a new Hessenberg matrix that is a perturbation of\n*     an unitary similarity transformation of H.  It is to be\n*     hoped that the final version of H has many zero subdiagonal\n*     entries.\n*\n*     ******************************************************************\n\n*     WANTT   (input) LOGICAL\n*          If .TRUE., then the Hessenberg matrix H is fully updated\n*          so that the triangular Schur factor may be\n*          computed (in cooperation with the calling subroutine).\n*          If .FALSE., then only enough of H is updated to preserve\n*          the eigenvalues.\n*\n*     WANTZ   (input) LOGICAL\n*          If .TRUE., then the unitary matrix Z is updated so\n*          so that the unitary Schur factor may be computed\n*          (in cooperation with the calling subroutine).\n*          If .FALSE., then Z is not referenced.\n*\n*     N       (input) INTEGER\n*          The order of the matrix H and (if WANTZ is .TRUE.) the\n*          order of the unitary matrix Z.\n*\n*     KTOP    (input) INTEGER\n*          It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n*          KBOT and KTOP together determine an isolated block\n*          along the diagonal of the Hessenberg matrix.\n*\n*     KBOT    (input) INTEGER\n*          It is assumed without a check that either\n*          KBOT = N or H(KBOT+1,KBOT)=0.  KBOT and KTOP together\n*          determine an isolated block along the diagonal of the\n*          Hessenberg matrix.\n*\n*     NW      (input) INTEGER\n*          Deflation window size.  1 .LE. NW .LE. (KBOT-KTOP+1).\n*\n*     H       (input/output) COMPLEX array, dimension (LDH,N)\n*          On input the initial N-by-N section of H stores the\n*          Hessenberg matrix undergoing aggressive early deflation.\n*          On output H has been transformed by a unitary\n*          similarity transformation, perturbed, and the returned\n*          to Hessenberg form that (it is to be hoped) has some\n*          zero subdiagonal entries.\n*\n*     LDH     (input) integer\n*          Leading dimension of H just as declared in the calling\n*          subroutine.  N .LE. LDH\n*\n*     ILOZ    (input) INTEGER\n*     IHIZ    (input) INTEGER\n*          Specify the rows of Z to which transformations must be\n*          applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n*\n*     Z       (input/output) COMPLEX array, dimension (LDZ,N)\n*          IF WANTZ is .TRUE., then on output, the unitary\n*          similarity transformation mentioned above has been\n*          accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n*          If WANTZ is .FALSE., then Z is unreferenced.\n*\n*     LDZ     (input) integer\n*          The leading dimension of Z just as declared in the\n*          calling subroutine.  1 .LE. LDZ.\n*\n*     NS      (output) integer\n*          The number of unconverged (ie approximate) eigenvalues\n*          returned in SR and SI that may be used as shifts by the\n*          calling subroutine.\n*\n*     ND      (output) integer\n*          The number of converged eigenvalues uncovered by this\n*          subroutine.\n*\n*     SH      (output) COMPLEX array, dimension KBOT\n*          On output, approximate eigenvalues that may\n*          be used for shifts are stored in SH(KBOT-ND-NS+1)\n*          through SR(KBOT-ND).  Converged eigenvalues are\n*          stored in SH(KBOT-ND+1) through SH(KBOT).\n*\n*     V       (workspace) COMPLEX array, dimension (LDV,NW)\n*          An NW-by-NW work array.\n*\n*     LDV     (input) integer scalar\n*          The leading dimension of V just as declared in the\n*          calling subroutine.  NW .LE. LDV\n*\n*     NH      (input) integer scalar\n*          The number of columns of T.  NH.GE.NW.\n*\n*     T       (workspace) COMPLEX array, dimension (LDT,NW)\n*\n*     LDT     (input) integer\n*          The leading dimension of T just as declared in the\n*          calling subroutine.  NW .LE. LDT\n*\n*     NV      (input) integer\n*          The number of rows of work array WV available for\n*          workspace.  NV.GE.NW.\n*\n*     WV      (workspace) COMPLEX array, dimension (LDWV,NW)\n*\n*     LDWV    (input) integer\n*          The leading dimension of W just as declared in the\n*          calling subroutine.  NW .LE. LDV\n*\n*     WORK    (workspace) COMPLEX array, dimension LWORK.\n*          On exit, WORK(1) is set to an estimate of the optimal value\n*          of LWORK for the given values of N, NW, KTOP and KBOT.\n*\n*     LWORK   (input) integer\n*          The dimension of the work array WORK.  LWORK = 2*NW\n*          suffices, but greater efficiency may result from larger\n*          values of LWORK.\n*\n*          If LWORK = -1, then a workspace query is assumed; CLAQR2\n*          only estimates the optimal workspace size for the given\n*          values of N, NW, KTOP and KBOT.  The estimate is returned\n*          in WORK(1).  No error message related to LWORK is issued\n*          by XERBLA.  Neither H nor Z are accessed.\n*\n\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ns, nd, sh, h, z = NumRu::Lapack.claqr2( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 11 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
  rblapack_wantt = argv[0];
  rblapack_wantz = argv[1];
  rblapack_ktop = argv[2];
  rblapack_kbot = argv[3];
  rblapack_nw = argv[4];
  rblapack_h = argv[5];
  rblapack_iloz = argv[6];
  rblapack_ihiz = argv[7];
  rblapack_z = argv[8];
  rblapack_nh = argv[9];
  rblapack_nv = argv[10];
  if (argc == 12) {
    rblapack_lwork = argv[11];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  wantt = (rblapack_wantt == Qtrue);
  ktop = NUM2INT(rblapack_ktop);
  nw = NUM2INT(rblapack_nw);
  iloz = NUM2INT(rblapack_iloz);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (9th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  n = NA_SHAPE1(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, complex*);
  nv = NUM2INT(rblapack_nv);
  ldwv = nw;
  ldv = nw;
  wantz = (rblapack_wantz == Qtrue);
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (6th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  if (NA_SHAPE1(rblapack_h) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of z");
  if (NA_TYPE(rblapack_h) != NA_SCOMPLEX)
    rblapack_h = na_change_type(rblapack_h, NA_SCOMPLEX);
  h = NA_PTR_TYPE(rblapack_h, complex*);
  nh = NUM2INT(rblapack_nh);
  ldt = nw;
  kbot = NUM2INT(rblapack_kbot);
  if (rblapack_lwork == Qnil)
    lwork = 2*nw;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ihiz = NUM2INT(rblapack_ihiz);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,kbot);
    rblapack_sh = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  sh = NA_PTR_TYPE(rblapack_sh, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, complex*);
  MEMCPY(h_out__, h, complex, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
  MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  v = ALLOC_N(complex, (ldv)*(MAX(1,nw)));
  t = ALLOC_N(complex, (ldv)*(MAX(1,nw)));
  wv = ALLOC_N(complex, (ldv)*(MAX(1,nw)));
  work = ALLOC_N(complex, (MAX(1,lwork)));

  claqr2_(&wantt, &wantz, &n, &ktop, &kbot, &nw, h, &ldh, &iloz, &ihiz, z, &ldz, &ns, &nd, sh, v, &ldv, &nh, t, &ldt, &nv, wv, &ldwv, work, &lwork);

  free(v);
  free(t);
  free(wv);
  free(work);
  rblapack_ns = INT2NUM(ns);
  rblapack_nd = INT2NUM(nd);
  return rb_ary_new3(5, rblapack_ns, rblapack_nd, rblapack_sh, rblapack_h, rblapack_z);
}

void
init_lapack_claqr2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "claqr2", rblapack_claqr2, -1);
}
ruby-lapack-1.7.2/ext/dtptri.c0000644000175000017500000001075712502221012016036 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtptri_(char* uplo, char* diag, integer* n, doublereal* ap, integer* info);


static VALUE
rblapack_dtptri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  doublereal *ap; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublereal *ap_out__;


  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  info, ap = NumRu::Lapack.dtptri( uplo, diag, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTPTRI( UPLO, DIAG, N, AP, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTPTRI computes the inverse of a real upper or lower triangular\n*  matrix A stored in packed format.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangular matrix A, stored\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n.\n*          See below for further details.\n*          On exit, the (triangular) inverse of the original matrix, in\n*          the same packed storage format.\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, A(i,i) is exactly zero.  The triangular\n*                matrix is singular and its inverse can not be computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  A triangular matrix A can be transferred to packed storage using one\n*  of the following program segments:\n*\n*  UPLO = 'U':                      UPLO = 'L':\n*\n*        JC = 1                           JC = 1\n*        DO 2 J = 1, N                    DO 2 J = 1, N\n*           DO 1 I = 1, J                    DO 1 I = J, N\n*              AP(JC+I-1) = A(I,J)              AP(JC+I-J) = A(I,J)\n*      1    CONTINUE                    1    CONTINUE\n*           JC = JC + J                      JC = JC + N - J + 1\n*      2 CONTINUE                       2 CONTINUE\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ap = NumRu::Lapack.dtptri( uplo, diag, n, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_diag = argv[1];
  rblapack_n = argv[2];
  rblapack_ap = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  n = NUM2INT(rblapack_n);
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_DFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublereal*);
  MEMCPY(ap_out__, ap, doublereal, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  dtptri_(&uplo, &diag, &n, ap, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ap);
}

void
init_lapack_dtptri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtptri", rblapack_dtptri, -1);
}
ruby-lapack-1.7.2/ext/dlasd3.c0000644000175000017500000002646612502221020015705 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlasd3_(integer* nl, integer* nr, integer* sqre, integer* k, doublereal* d, doublereal* q, integer* ldq, doublereal* dsigma, doublereal* u, integer* ldu, doublereal* u2, integer* ldu2, doublereal* vt, integer* ldvt, doublereal* vt2, integer* ldvt2, integer* idxc, integer* ctot, doublereal* z, integer* info);


static VALUE
rblapack_dlasd3(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_nl;
  integer nl; 
  VALUE rblapack_nr;
  integer nr; 
  VALUE rblapack_sqre;
  integer sqre; 
  VALUE rblapack_dsigma;
  doublereal *dsigma; 
  VALUE rblapack_u2;
  doublereal *u2; 
  VALUE rblapack_vt2;
  doublereal *vt2; 
  VALUE rblapack_idxc;
  integer *idxc; 
  VALUE rblapack_ctot;
  integer *ctot; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_u;
  doublereal *u; 
  VALUE rblapack_vt;
  doublereal *vt; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_u2_out__;
  doublereal *u2_out__;
  VALUE rblapack_vt2_out__;
  doublereal *vt2_out__;
  doublereal *q;

  integer k;
  integer ldu2;
  integer n;
  integer ldvt2;
  integer ldu;
  integer ldvt;
  integer m;
  integer ldq;

  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  d, u, vt, info, u2, vt2 = NumRu::Lapack.dlasd3( nl, nr, sqre, dsigma, u2, vt2, idxc, ctot, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLASD3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2, LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLASD3 finds all the square roots of the roots of the secular\n*  equation, as defined by the values in D and Z.  It makes the\n*  appropriate calls to DLASD4 and then updates the singular\n*  vectors by matrix multiplication.\n*\n*  This code makes very mild assumptions about floating point\n*  arithmetic. It will work on machines with a guard digit in\n*  add/subtract, or on those binary machines without guard digits\n*  which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.\n*  It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n*  DLASD3 is called from DLASD1.\n*\n\n*  Arguments\n*  =========\n*\n*  NL     (input) INTEGER\n*         The row dimension of the upper block.  NL >= 1.\n*\n*  NR     (input) INTEGER\n*         The row dimension of the lower block.  NR >= 1.\n*\n*  SQRE   (input) INTEGER\n*         = 0: the lower block is an NR-by-NR square matrix.\n*         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.\n*\n*         The bidiagonal matrix has N = NL + NR + 1 rows and\n*         M = N + SQRE >= N columns.\n*\n*  K      (input) INTEGER\n*         The size of the secular equation, 1 =< K = < N.\n*\n*  D      (output) DOUBLE PRECISION array, dimension(K)\n*         On exit the square roots of the roots of the secular equation,\n*         in ascending order.\n*\n*  Q      (workspace) DOUBLE PRECISION array,\n*                     dimension at least (LDQ,K).\n*\n*  LDQ    (input) INTEGER\n*         The leading dimension of the array Q.  LDQ >= K.\n*\n*  DSIGMA (input) DOUBLE PRECISION array, dimension(K)\n*         The first K elements of this array contain the old roots\n*         of the deflated updating problem.  These are the poles\n*         of the secular equation.\n*\n*  U      (output) DOUBLE PRECISION array, dimension (LDU, N)\n*         The last N - K columns of this matrix contain the deflated\n*         left singular vectors.\n*\n*  LDU    (input) INTEGER\n*         The leading dimension of the array U.  LDU >= N.\n*\n*  U2     (input/output) DOUBLE PRECISION array, dimension (LDU2, N)\n*         The first K columns of this matrix contain the non-deflated\n*         left singular vectors for the split problem.\n*\n*  LDU2   (input) INTEGER\n*         The leading dimension of the array U2.  LDU2 >= N.\n*\n*  VT     (output) DOUBLE PRECISION array, dimension (LDVT, M)\n*         The last M - K columns of VT' contain the deflated\n*         right singular vectors.\n*\n*  LDVT   (input) INTEGER\n*         The leading dimension of the array VT.  LDVT >= N.\n*\n*  VT2    (input/output) DOUBLE PRECISION array, dimension (LDVT2, N)\n*         The first K columns of VT2' contain the non-deflated\n*         right singular vectors for the split problem.\n*\n*  LDVT2  (input) INTEGER\n*         The leading dimension of the array VT2.  LDVT2 >= N.\n*\n*  IDXC   (input) INTEGER array, dimension ( N )\n*         The permutation used to arrange the columns of U (and rows of\n*         VT) into three groups:  the first group contains non-zero\n*         entries only at and above (or before) NL +1; the second\n*         contains non-zero entries only at and below (or after) NL+2;\n*         and the third is dense. The first column of U and the row of\n*         VT are treated separately, however.\n*\n*         The rows of the singular vectors found by DLASD4\n*         must be likewise permuted before the matrix multiplies can\n*         take place.\n*\n*  CTOT   (input) INTEGER array, dimension ( 4 )\n*         A count of the total number of the various types of columns\n*         in U (or rows in VT), as described in IDXC. The fourth column\n*         type is any column which has been deflated.\n*\n*  Z      (input) DOUBLE PRECISION array, dimension (K)\n*         The first K elements of this array contain the components\n*         of the deflation-adjusted updating row vector.\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 = 1, a singular value did not converge\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, u, vt, info, u2, vt2 = NumRu::Lapack.dlasd3( nl, nr, sqre, dsigma, u2, vt2, idxc, ctot, z, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_nl = argv[0];
  rblapack_nr = argv[1];
  rblapack_sqre = argv[2];
  rblapack_dsigma = argv[3];
  rblapack_u2 = argv[4];
  rblapack_vt2 = argv[5];
  rblapack_idxc = argv[6];
  rblapack_ctot = argv[7];
  rblapack_z = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  nl = NUM2INT(rblapack_nl);
  sqre = NUM2INT(rblapack_sqre);
  if (!NA_IsNArray(rblapack_ctot))
    rb_raise(rb_eArgError, "ctot (8th argument) must be NArray");
  if (NA_RANK(rblapack_ctot) != 1)
    rb_raise(rb_eArgError, "rank of ctot (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ctot) != (4))
    rb_raise(rb_eRuntimeError, "shape 0 of ctot must be %d", 4);
  if (NA_TYPE(rblapack_ctot) != NA_LINT)
    rblapack_ctot = na_change_type(rblapack_ctot, NA_LINT);
  ctot = NA_PTR_TYPE(rblapack_ctot, integer*);
  nr = NUM2INT(rblapack_nr);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (9th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  n = nl + nr + 1;
  ldvt = n;
  ldu = n;
  if (!NA_IsNArray(rblapack_dsigma))
    rb_raise(rb_eArgError, "dsigma (4th argument) must be NArray");
  if (NA_RANK(rblapack_dsigma) != 1)
    rb_raise(rb_eArgError, "rank of dsigma (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dsigma) != k)
    rb_raise(rb_eRuntimeError, "shape 0 of dsigma must be the same as shape 0 of z");
  if (NA_TYPE(rblapack_dsigma) != NA_DFLOAT)
    rblapack_dsigma = na_change_type(rblapack_dsigma, NA_DFLOAT);
  dsigma = NA_PTR_TYPE(rblapack_dsigma, doublereal*);
  if (!NA_IsNArray(rblapack_idxc))
    rb_raise(rb_eArgError, "idxc (7th argument) must be NArray");
  if (NA_RANK(rblapack_idxc) != 1)
    rb_raise(rb_eArgError, "rank of idxc (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_idxc) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of idxc must be nl + nr + 1");
  if (NA_TYPE(rblapack_idxc) != NA_LINT)
    rblapack_idxc = na_change_type(rblapack_idxc, NA_LINT);
  idxc = NA_PTR_TYPE(rblapack_idxc, integer*);
  ldq = k;
  ldvt2 = n;
  if (!NA_IsNArray(rblapack_vt2))
    rb_raise(rb_eArgError, "vt2 (6th argument) must be NArray");
  if (NA_RANK(rblapack_vt2) != 2)
    rb_raise(rb_eArgError, "rank of vt2 (6th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_vt2) != ldvt2)
    rb_raise(rb_eRuntimeError, "shape 0 of vt2 must be n");
  if (NA_SHAPE1(rblapack_vt2) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of vt2 must be nl + nr + 1");
  if (NA_TYPE(rblapack_vt2) != NA_DFLOAT)
    rblapack_vt2 = na_change_type(rblapack_vt2, NA_DFLOAT);
  vt2 = NA_PTR_TYPE(rblapack_vt2, doublereal*);
  ldu2 = n;
  if (!NA_IsNArray(rblapack_u2))
    rb_raise(rb_eArgError, "u2 (5th argument) must be NArray");
  if (NA_RANK(rblapack_u2) != 2)
    rb_raise(rb_eArgError, "rank of u2 (5th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_u2) != ldu2)
    rb_raise(rb_eRuntimeError, "shape 0 of u2 must be n");
  if (NA_SHAPE1(rblapack_u2) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of u2 must be nl + nr + 1");
  if (NA_TYPE(rblapack_u2) != NA_DFLOAT)
    rblapack_u2 = na_change_type(rblapack_u2, NA_DFLOAT);
  u2 = NA_PTR_TYPE(rblapack_u2, doublereal*);
  m = n + sqre;
  {
    na_shape_t shape[1];
    shape[0] = k;
    rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  {
    na_shape_t 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*);
  {
    na_shape_t shape[2];
    shape[0] = ldvt;
    shape[1] = m;
    rblapack_vt = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vt = NA_PTR_TYPE(rblapack_vt, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldu2;
    shape[1] = n;
    rblapack_u2_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  u2_out__ = NA_PTR_TYPE(rblapack_u2_out__, doublereal*);
  MEMCPY(u2_out__, u2, doublereal, NA_TOTAL(rblapack_u2));
  rblapack_u2 = rblapack_u2_out__;
  u2 = u2_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvt2;
    shape[1] = n;
    rblapack_vt2_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vt2_out__ = NA_PTR_TYPE(rblapack_vt2_out__, doublereal*);
  MEMCPY(vt2_out__, vt2, doublereal, NA_TOTAL(rblapack_vt2));
  rblapack_vt2 = rblapack_vt2_out__;
  vt2 = vt2_out__;
  q = ALLOC_N(doublereal, (ldq)*(k));

  dlasd3_(&nl, &nr, &sqre, &k, d, q, &ldq, dsigma, u, &ldu, u2, &ldu2, vt, &ldvt, vt2, &ldvt2, idxc, ctot, z, &info);

  free(q);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_d, rblapack_u, rblapack_vt, rblapack_info, rblapack_u2, rblapack_vt2);
}

void
init_lapack_dlasd3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlasd3", rblapack_dlasd3, -1);
}
ruby-lapack-1.7.2/ext/cunghr.c0000644000175000017500000001267712502221020016020 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cunghr_(integer* n, integer* ilo, integer* ihi, complex* a, integer* lda, complex* tau, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_cunghr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *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  work, info, a = NumRu::Lapack.cunghr( ilo, ihi, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CUNGHR generates a complex unitary matrix Q which is defined as the\n*  product of IHI-ILO elementary reflectors of order N, as returned by\n*  CGEHRD:\n*\n*  Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix Q. N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          ILO and IHI must have the same values as in the previous call\n*          of CGEHRD. Q is equal to the unit matrix except in the\n*          submatrix Q(ilo+1:ihi,ilo+1:ihi).\n*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the vectors which define the elementary reflectors,\n*          as returned by CGEHRD.\n*          On exit, the N-by-N unitary matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  TAU     (input) COMPLEX array, dimension (N-1)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by CGEHRD.\n*\n*  WORK    (workspace/output) COMPLEX 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 >= IHI-ILO.\n*          For optimum performance LWORK >= (IHI-ILO)*NB, where NB is\n*          the 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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, a = NumRu::Lapack.cunghr( ilo, ihi, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_ilo = argv[0];
  rblapack_ihi = argv[1];
  rblapack_a = argv[2];
  rblapack_tau = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  ihi = NUM2INT(rblapack_ihi);
  if (rblapack_lwork == Qnil)
    lwork = ihi-ilo;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_tau) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", n-1);
  if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  cunghr_(&n, &ilo, &ihi, a, &lda, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_cunghr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cunghr", rblapack_cunghr, -1);
}
ruby-lapack-1.7.2/ext/strcon.c0000644000175000017500000001107212502221017016034 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID strcon_(char* norm, char* uplo, char* diag, integer* n, real* a, integer* lda, real* rcond, real* work, integer* iwork, integer* info);


static VALUE
rblapack_strcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_info;
  integer info; 
  real *work;
  integer *iwork;

  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  rcond, info = NumRu::Lapack.strcon( norm, uplo, diag, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  STRCON estimates the reciprocal of the condition number of a\n*  triangular matrix A, in either the 1-norm or the infinity-norm.\n*\n*  The norm of A is computed and an estimate is obtained for\n*  norm(inv(A)), then the reciprocal of the condition number is\n*  computed as\n*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies whether the 1-norm condition number or the\n*          infinity-norm condition number is required:\n*          = '1' or 'O':  1-norm;\n*          = 'I':         Infinity-norm.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) REAL array, dimension (LDA,N)\n*          The triangular matrix A.  If UPLO = 'U', the leading N-by-N\n*          upper triangular part of the array A contains the upper\n*          triangular matrix, and the strictly lower triangular part of\n*          A is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*          triangular part of the array A contains the lower triangular\n*          matrix, and the strictly upper triangular part of A is not\n*          referenced.  If DIAG = 'U', the diagonal elements of A are\n*          also not referenced and are assumed to be 1.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  RCOND   (output) REAL\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(norm(A) * norm(inv(A))).\n*\n*  WORK    (workspace) REAL array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.strcon( norm, uplo, diag, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_diag = argv[2];
  rblapack_a = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  work = ALLOC_N(real, (3*n));
  iwork = ALLOC_N(integer, (n));

  strcon_(&norm, &uplo, &diag, &n, a, &lda, &rcond, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_strcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "strcon", rblapack_strcon, -1);
}
ruby-lapack-1.7.2/ext/dpocon.c0000644000175000017500000000774612502221013016017 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dpocon_(char* uplo, integer* n, doublereal* a, integer* lda, doublereal* anorm, doublereal* rcond, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dpocon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_anorm;
  doublereal anorm; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_info;
  integer info; 
  doublereal *work;
  integer *iwork;

  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  rcond, info = NumRu::Lapack.dpocon( uplo, a, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPOCON estimates the reciprocal of the condition number (in the\n*  1-norm) of a real symmetric positive definite matrix using the\n*  Cholesky factorization A = U**T*U or A = L*L**T computed by DPOTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**T*U or A = L*L**T, as computed by DPOTRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  ANORM   (input) DOUBLE PRECISION\n*          The 1-norm (or infinity-norm) of the symmetric matrix A.\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n*          estimate of the 1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.dpocon( uplo, a, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_anorm = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  anorm = NUM2DBL(rblapack_anorm);
  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*);
  work = ALLOC_N(doublereal, (3*n));
  iwork = ALLOC_N(integer, (n));

  dpocon_(&uplo, &n, a, &lda, &anorm, &rcond, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_dpocon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dpocon", rblapack_dpocon, -1);
}
ruby-lapack-1.7.2/ext/ztptrs.c0000644000175000017500000001245612502221015016077 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztptrs_(char* uplo, char* trans, char* diag, integer* n, integer* nrhs, doublecomplex* ap, doublecomplex* b, integer* ldb, integer* info);


static VALUE
rblapack_ztptrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.ztptrs( uplo, trans, diag, n, ap, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTPTRS solves a triangular system of the form\n*\n*     A * X = B,  A**T * X = B,  or  A**H * X = B,\n*\n*  where A is a triangular matrix of order N stored in packed format,\n*  and B is an N-by-NRHS matrix.  A check is made to verify that A is\n*  nonsingular.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          The upper or lower triangular matrix A, packed columnwise in\n*          a linear array.  The j-th column of A is stored in the array\n*          AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, if INFO = 0, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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 A is zero,\n*                indicating that the matrix is singular and the\n*                solutions X have not been computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.ztptrs( uplo, trans, diag, n, ap, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_n = argv[3];
  rblapack_ap = argv[4];
  rblapack_b = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  trans = StringValueCStr(rblapack_trans)[0];
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  ztptrs_(&uplo, &trans, &diag, &n, &nrhs, ap, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_ztptrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztptrs", rblapack_ztptrs, -1);
}
ruby-lapack-1.7.2/ext/dgegs.c0000644000175000017500000002571312502221017015624 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgegs_(char* jobvsl, char* jobvsr, integer* n, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* alphar, doublereal* alphai, doublereal* beta, doublereal* vsl, integer* ldvsl, doublereal* vsr, integer* ldvsr, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dgegs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvsl;
  char jobvsl; 
  VALUE rblapack_jobvsr;
  char jobvsr; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_alphar;
  doublereal *alphar; 
  VALUE rblapack_alphai;
  doublereal *alphai; 
  VALUE rblapack_beta;
  doublereal *beta; 
  VALUE rblapack_vsl;
  doublereal *vsl; 
  VALUE rblapack_vsr;
  doublereal *vsr; 
  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 ldb;
  integer ldvsl;
  integer ldvsr;

  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  alphar, alphai, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.dgegs( jobvsl, jobvsr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  This routine is deprecated and has been replaced by routine DGGES.\n*\n*  DGEGS computes the eigenvalues, real Schur form, and, optionally,\n*  left and or/right Schur vectors of a real matrix pair (A,B).\n*  Given two square matrices A and B, the generalized real Schur\n*  factorization has the form\n*\n*    A = Q*S*Z**T,  B = Q*T*Z**T\n*\n*  where Q and Z are orthogonal matrices, T is upper triangular, and S\n*  is an upper quasi-triangular matrix with 1-by-1 and 2-by-2 diagonal\n*  blocks, the 2-by-2 blocks corresponding to complex conjugate pairs\n*  of eigenvalues of (A,B).  The columns of Q are the left Schur vectors\n*  and the columns of Z are the right Schur vectors.\n*\n*  If only the eigenvalues of (A,B) are needed, the driver routine\n*  DGEGV should be used instead.  See DGEGV for a description of the\n*  eigenvalues of the generalized nonsymmetric eigenvalue problem\n*  (GNEP).\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVSL  (input) CHARACTER*1\n*          = 'N':  do not compute the left Schur vectors;\n*          = 'V':  compute the left Schur vectors (returned in VSL).\n*\n*  JOBVSR  (input) CHARACTER*1\n*          = 'N':  do not compute the right Schur vectors;\n*          = 'V':  compute the right Schur vectors (returned in VSR).\n*\n*  N       (input) INTEGER\n*          The order of the matrices A, B, VSL, and VSR.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n*          On entry, the matrix A.\n*          On exit, the upper quasi-triangular matrix S from the\n*          generalized real Schur factorization.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of A.  LDA >= max(1,N).\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n*          On entry, the matrix B.\n*          On exit, the upper triangular matrix T from the generalized\n*          real Schur factorization.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of B.  LDB >= max(1,N).\n*\n*  ALPHAR  (output) DOUBLE PRECISION array, dimension (N)\n*          The real parts of each scalar alpha defining an eigenvalue\n*          of GNEP.\n*\n*  ALPHAI  (output) DOUBLE PRECISION array, dimension (N)\n*          The imaginary parts of each scalar alpha defining an\n*          eigenvalue of GNEP.  If ALPHAI(j) is zero, then the j-th\n*          eigenvalue is real; if positive, then the j-th and (j+1)-st\n*          eigenvalues are a complex conjugate pair, with\n*          ALPHAI(j+1) = -ALPHAI(j).\n*\n*  BETA    (output) DOUBLE PRECISION array, dimension (N)\n*          The scalars beta that define the eigenvalues of GNEP.\n*          Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and\n*          beta = BETA(j) represent the j-th eigenvalue of the matrix\n*          pair (A,B), in one of the forms lambda = alpha/beta or\n*          mu = beta/alpha.  Since either lambda or mu may overflow,\n*          they should not, in general, be computed.\n*\n*  VSL     (output) DOUBLE PRECISION array, dimension (LDVSL,N)\n*          If JOBVSL = 'V', the matrix of left Schur vectors Q.\n*          Not referenced if JOBVSL = 'N'.\n*\n*  LDVSL   (input) INTEGER\n*          The leading dimension of the matrix VSL. LDVSL >=1, and\n*          if JOBVSL = 'V', LDVSL >= N.\n*\n*  VSR     (output) DOUBLE PRECISION array, dimension (LDVSR,N)\n*          If JOBVSR = 'V', the matrix of right Schur vectors Z.\n*          Not referenced if JOBVSR = 'N'.\n*\n*  LDVSR   (input) INTEGER\n*          The leading dimension of the matrix VSR. LDVSR >= 1, and\n*          if JOBVSR = 'V', LDVSR >= 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.  LWORK >= max(1,4*N).\n*          For good performance, LWORK must generally be larger.\n*          To compute the optimal value of LWORK, call ILAENV to get\n*          blocksizes (for DGEQRF, DORMQR, and DORGQR.)  Then compute:\n*          NB  -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR\n*          The optimal LWORK is  2*N + N*(NB+1).\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*          = 1,...,N:\n*                The QZ iteration failed.  (A,B) are not in Schur\n*                form, but ALPHAR(j), ALPHAI(j), and BETA(j) should\n*                be correct for j=INFO+1,...,N.\n*          > N:  errors that usually indicate LAPACK problems:\n*                =N+1: error return from DGGBAL\n*                =N+2: error return from DGEQRF\n*                =N+3: error return from DORMQR\n*                =N+4: error return from DORGQR\n*                =N+5: error return from DGGHRD\n*                =N+6: error return from DHGEQZ (other than failed\n*                                                iteration)\n*                =N+7: error return from DGGBAK (computing VSL)\n*                =N+8: error return from DGGBAK (computing VSR)\n*                =N+9: error return from DLASCL (various places)\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  alphar, alphai, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.dgegs( jobvsl, jobvsr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_jobvsl = argv[0];
  rblapack_jobvsr = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  jobvsl = StringValueCStr(rblapack_jobvsl)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  jobvsr = StringValueCStr(rblapack_jobvsr)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  ldvsl = lsame_(&jobvsl,"V") ? n : 1;
  if (rblapack_lwork == Qnil)
    lwork = 4*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldvsr = lsame_(&jobvsr,"V") ? n : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphar = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  alphar = NA_PTR_TYPE(rblapack_alphar, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphai = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  alphai = NA_PTR_TYPE(rblapack_alphai, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldvsl;
    shape[1] = n;
    rblapack_vsl = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vsl = NA_PTR_TYPE(rblapack_vsl, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldvsr;
    shape[1] = n;
    rblapack_vsr = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vsr = NA_PTR_TYPE(rblapack_vsr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dgegs_(&jobvsl, &jobvsr, &n, a, &lda, b, &ldb, alphar, alphai, beta, vsl, &ldvsl, vsr, &ldvsr, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_vsl, rblapack_vsr, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_dgegs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgegs", rblapack_dgegs, -1);
}
ruby-lapack-1.7.2/ext/sggesx.c0000644000175000017500000004253112502221017016030 0ustar  uwabamiuwabami#include "rb_lapack.h"

static logical
rblapack_selctg(real *arg0, real *arg1, real *arg2){
  VALUE rblapack_arg0, rblapack_arg1, rblapack_arg2;

  VALUE rblapack_ret;
  logical ret;

  rblapack_arg0 = rb_float_new((double)(*arg0));
  rblapack_arg1 = rb_float_new((double)(*arg1));
  rblapack_arg2 = rb_float_new((double)(*arg2));

  rblapack_ret = rb_yield_values(3, rblapack_arg0, rblapack_arg1, rblapack_arg2);

  ret = (rblapack_ret == Qtrue);
  return ret;
}

extern VOID sggesx_(char* jobvsl, char* jobvsr, char* sort, L_fp selctg, char* sense, integer* n, real* a, integer* lda, real* b, integer* ldb, integer* sdim, real* alphar, real* alphai, real* beta, real* vsl, integer* ldvsl, real* vsr, integer* ldvsr, real* rconde, real* rcondv, real* work, integer* lwork, integer* iwork, integer* liwork, logical* bwork, integer* info);


static VALUE
rblapack_sggesx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvsl;
  char jobvsl; 
  VALUE rblapack_jobvsr;
  char jobvsr; 
  VALUE rblapack_sort;
  char sort; 
  VALUE rblapack_sense;
  char sense; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_sdim;
  integer sdim; 
  VALUE rblapack_alphar;
  real *alphar; 
  VALUE rblapack_alphai;
  real *alphai; 
  VALUE rblapack_beta;
  real *beta; 
  VALUE rblapack_vsl;
  real *vsl; 
  VALUE rblapack_vsr;
  real *vsr; 
  VALUE rblapack_rconde;
  real *rconde; 
  VALUE rblapack_rcondv;
  real *rcondv; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_b_out__;
  real *b_out__;
  integer *iwork;
  logical *bwork;

  integer lda;
  integer n;
  integer ldb;
  integer ldvsl;
  integer ldvsr;

  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  sdim, alphar, alphai, beta, vsl, vsr, rconde, rcondv, work, info, a, b = NumRu::Lapack.sggesx( jobvsl, jobvsr, sort, sense, a, b, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help]){|a,b,c| ... }\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGGESX( JOBVSL, JOBVSR, SORT, SELCTG, SENSE, N, A, LDA, B, LDB, SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, IWORK, LIWORK, BWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGGESX computes for a pair of N-by-N real nonsymmetric matrices\n*  (A,B), the generalized eigenvalues, the real Schur form (S,T), and,\n*  optionally, the left and/or right matrices of Schur vectors (VSL and\n*  VSR).  This gives the generalized Schur factorization\n*\n*       (A,B) = ( (VSL) S (VSR)**T, (VSL) T (VSR)**T )\n*\n*  Optionally, it also orders the eigenvalues so that a selected cluster\n*  of eigenvalues appears in the leading diagonal blocks of the upper\n*  quasi-triangular matrix S and the upper triangular matrix T; computes\n*  a reciprocal condition number for the average of the selected\n*  eigenvalues (RCONDE); and computes a reciprocal condition number for\n*  the right and left deflating subspaces corresponding to the selected\n*  eigenvalues (RCONDV). The leading columns of VSL and VSR then form\n*  an orthonormal basis for the corresponding left and right eigenspaces\n*  (deflating subspaces).\n*\n*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar w\n*  or a ratio alpha/beta = w, such that  A - w*B is singular.  It is\n*  usually represented as the pair (alpha,beta), as there is a\n*  reasonable interpretation for beta=0 or for both being zero.\n*\n*  A pair of matrices (S,T) is in generalized real Schur form if T is\n*  upper triangular with non-negative diagonal and S is block upper\n*  triangular with 1-by-1 and 2-by-2 blocks.  1-by-1 blocks correspond\n*  to real generalized eigenvalues, while 2-by-2 blocks of S will be\n*  \"standardized\" by making the corresponding elements of T have the\n*  form:\n*          [  a  0  ]\n*          [  0  b  ]\n*\n*  and the pair of corresponding 2-by-2 blocks in S and T will have a\n*  complex conjugate pair of generalized eigenvalues.\n*\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVSL  (input) CHARACTER*1\n*          = 'N':  do not compute the left Schur vectors;\n*          = 'V':  compute the left Schur vectors.\n*\n*  JOBVSR  (input) CHARACTER*1\n*          = 'N':  do not compute the right Schur vectors;\n*          = 'V':  compute the right Schur vectors.\n*\n*  SORT    (input) CHARACTER*1\n*          Specifies whether or not to order the eigenvalues on the\n*          diagonal of the generalized Schur form.\n*          = 'N':  Eigenvalues are not ordered;\n*          = 'S':  Eigenvalues are ordered (see SELCTG).\n*\n*  SELCTG  (external procedure) LOGICAL FUNCTION of three REAL arguments\n*          SELCTG must be declared EXTERNAL in the calling subroutine.\n*          If SORT = 'N', SELCTG is not referenced.\n*          If SORT = 'S', SELCTG is used to select eigenvalues to sort\n*          to the top left of the Schur form.\n*          An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if\n*          SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either\n*          one of a complex conjugate pair of eigenvalues is selected,\n*          then both complex eigenvalues are selected.\n*          Note that a selected complex eigenvalue may no longer satisfy\n*          SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) = .TRUE. after ordering,\n*          since ordering may change the value of complex eigenvalues\n*          (especially if the eigenvalue is ill-conditioned), in this\n*          case INFO is set to N+3.\n*\n*  SENSE   (input) CHARACTER*1\n*          Determines which reciprocal condition numbers are computed.\n*          = 'N' : None are computed;\n*          = 'E' : Computed for average of selected eigenvalues only;\n*          = 'V' : Computed for selected deflating subspaces only;\n*          = 'B' : Computed for both.\n*          If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A, B, VSL, and VSR.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA, N)\n*          On entry, the first of the pair of matrices.\n*          On exit, A has been overwritten by its generalized Schur\n*          form S.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of A.  LDA >= max(1,N).\n*\n*  B       (input/output) REAL array, dimension (LDB, N)\n*          On entry, the second of the pair of matrices.\n*          On exit, B has been overwritten by its generalized Schur\n*          form T.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of B.  LDB >= max(1,N).\n*\n*  SDIM    (output) INTEGER\n*          If SORT = 'N', SDIM = 0.\n*          If SORT = 'S', SDIM = number of eigenvalues (after sorting)\n*          for which SELCTG is true.  (Complex conjugate pairs for which\n*          SELCTG is true for either eigenvalue count as 2.)\n*\n*  ALPHAR  (output) REAL array, dimension (N)\n*  ALPHAI  (output) REAL array, dimension (N)\n*  BETA    (output) REAL array, dimension (N)\n*          On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will\n*          be the generalized eigenvalues.  ALPHAR(j) + ALPHAI(j)*i\n*          and BETA(j),j=1,...,N  are the diagonals of the complex Schur\n*          form (S,T) that would result if the 2-by-2 diagonal blocks of\n*          the real Schur form of (A,B) were further reduced to\n*          triangular form using 2-by-2 complex unitary transformations.\n*          If ALPHAI(j) is zero, then the j-th eigenvalue is real; if\n*          positive, then the j-th and (j+1)-st eigenvalues are a\n*          complex conjugate pair, with ALPHAI(j+1) negative.\n*\n*          Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)\n*          may easily over- or underflow, and BETA(j) may even be zero.\n*          Thus, the user should avoid naively computing the ratio.\n*          However, ALPHAR and ALPHAI will be always less than and\n*          usually comparable with norm(A) in magnitude, and BETA always\n*          less than and usually comparable with norm(B).\n*\n*  VSL     (output) REAL array, dimension (LDVSL,N)\n*          If JOBVSL = 'V', VSL will contain the left Schur vectors.\n*          Not referenced if JOBVSL = 'N'.\n*\n*  LDVSL   (input) INTEGER\n*          The leading dimension of the matrix VSL. LDVSL >=1, and\n*          if JOBVSL = 'V', LDVSL >= N.\n*\n*  VSR     (output) REAL array, dimension (LDVSR,N)\n*          If JOBVSR = 'V', VSR will contain the right Schur vectors.\n*          Not referenced if JOBVSR = 'N'.\n*\n*  LDVSR   (input) INTEGER\n*          The leading dimension of the matrix VSR. LDVSR >= 1, and\n*          if JOBVSR = 'V', LDVSR >= N.\n*\n*  RCONDE  (output) REAL array, dimension ( 2 )\n*          If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the\n*          reciprocal condition numbers for the average of the selected\n*          eigenvalues.\n*          Not referenced if SENSE = 'N' or 'V'.\n*\n*  RCONDV  (output) REAL array, dimension ( 2 )\n*          If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the\n*          reciprocal condition numbers for the selected deflating\n*          subspaces.\n*          Not referenced if SENSE = 'N' or 'E'.\n*\n*  WORK    (workspace/output) REAL 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*          If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B',\n*          LWORK >= max( 8*N, 6*N+16, 2*SDIM*(N-SDIM) ), else\n*          LWORK >= max( 8*N, 6*N+16 ).\n*          Note that 2*SDIM*(N-SDIM) <= N*N/2.\n*          Note also that an error is only returned if\n*          LWORK < max( 8*N, 6*N+16), but if SENSE = 'E' or 'V' or 'B'\n*          this may not be large enough.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the bound on the optimal size of the WORK\n*          array and the minimum size of the IWORK array, returns these\n*          values as the first entries of the WORK and IWORK arrays, and\n*          no error message related to LWORK or LIWORK is issued by\n*          XERBLA.\n*\n*  IWORK   (workspace) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.\n*          If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise\n*          LIWORK >= N+6.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the bound on the optimal size of the\n*          WORK array and the minimum size of the IWORK array, returns\n*          these values as the first entries of the WORK and IWORK\n*          arrays, and no error message related to LWORK or LIWORK is\n*          issued by XERBLA.\n*\n*  BWORK   (workspace) LOGICAL array, dimension (N)\n*          Not referenced if SORT = 'N'.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value.\n*          = 1,...,N:\n*                The QZ iteration failed.  (A,B) are not in Schur\n*                form, but ALPHAR(j), ALPHAI(j), and BETA(j) should\n*                be correct for j=INFO+1,...,N.\n*          > N:  =N+1: other than QZ iteration failed in SHGEQZ\n*                =N+2: after reordering, roundoff changed values of\n*                      some complex eigenvalues so that leading\n*                      eigenvalues in the Generalized Schur form no\n*                      longer satisfy SELCTG=.TRUE.  This could also\n*                      be caused due to scaling.\n*                =N+3: reordering failed in STGSEN.\n*\n\n*  Further Details\n*  ===============\n*\n*  An approximate (asymptotic) bound on the average absolute error of\n*  the selected eigenvalues is\n*\n*       EPS * norm((A, B)) / RCONDE( 1 ).\n*\n*  An approximate (asymptotic) bound on the maximum angular error in\n*  the computed deflating subspaces is\n*\n*       EPS * norm((A, B)) / RCONDV( 2 ).\n*\n*  See LAPACK User's Guide, section 4.11 for more information.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sdim, alphar, alphai, beta, vsl, vsr, rconde, rcondv, work, info, a, b = NumRu::Lapack.sggesx( jobvsl, jobvsr, sort, sense, a, b, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help]){|a,b,c| ... }\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_jobvsl = argv[0];
  rblapack_jobvsr = argv[1];
  rblapack_sort = argv[2];
  rblapack_sense = argv[3];
  rblapack_a = argv[4];
  rblapack_b = argv[5];
  if (argc == 8) {
    rblapack_lwork = argv[6];
    rblapack_liwork = argv[7];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobvsl = StringValueCStr(rblapack_jobvsl)[0];
  sort = StringValueCStr(rblapack_sort)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  jobvsr = StringValueCStr(rblapack_jobvsr)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  ldvsl = lsame_(&jobvsl,"V") ? n : 1;
  sense = StringValueCStr(rblapack_sense)[0];
  if (rblapack_liwork == Qnil)
    liwork = (lsame_(&sense,"N")||n==0) ? 1 : n+6;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  if (rblapack_lwork == Qnil)
    lwork = n==0 ? 1 : (lsame_(&sense,"E")||lsame_(&sense,"V")||lsame_(&sense,"B")) ? MAX(MAX(8*n,6*n+16),n*n/2) : MAX(8*n,6*n+16);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldvsr = lsame_(&jobvsr,"V") ? n : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  alphar = NA_PTR_TYPE(rblapack_alphar, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  alphai = NA_PTR_TYPE(rblapack_alphai, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldvsl;
    shape[1] = n;
    rblapack_vsl = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vsl = NA_PTR_TYPE(rblapack_vsl, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldvsr;
    shape[1] = n;
    rblapack_vsr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vsr = NA_PTR_TYPE(rblapack_vsr, real*);
  {
    na_shape_t shape[1];
    shape[0] = 2;
    rblapack_rconde = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  rconde = NA_PTR_TYPE(rblapack_rconde, real*);
  {
    na_shape_t shape[1];
    shape[0] = 2;
    rblapack_rcondv = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  rcondv = NA_PTR_TYPE(rblapack_rcondv, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  iwork = ALLOC_N(integer, (MAX(1,liwork)));
  bwork = ALLOC_N(logical, (lsame_(&sort,"N") ? 0 : n));

  sggesx_(&jobvsl, &jobvsr, &sort, rblapack_selctg, &sense, &n, a, &lda, b, &ldb, &sdim, alphar, alphai, beta, vsl, &ldvsl, vsr, &ldvsr, rconde, rcondv, work, &lwork, iwork, &liwork, bwork, &info);

  free(iwork);
  free(bwork);
  rblapack_sdim = INT2NUM(sdim);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(12, rblapack_sdim, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_vsl, rblapack_vsr, rblapack_rconde, rblapack_rcondv, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_sggesx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sggesx", rblapack_sggesx, -1);
}
ruby-lapack-1.7.2/ext/dlargv.c0000644000175000017500000001150212502221026016001 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlargv_(integer* n, doublereal* x, integer* incx, doublereal* y, integer* incy, doublereal* c, integer* incc);


static VALUE
rblapack_dlargv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_y;
  doublereal *y; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_incc;
  integer incc; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_x_out__;
  doublereal *x_out__;
  VALUE rblapack_y_out__;
  doublereal *y_out__;


  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  c, x, y = NumRu::Lapack.dlargv( n, x, incx, y, incy, incc, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLARGV( N, X, INCX, Y, INCY, C, INCC )\n\n*  Purpose\n*  =======\n*\n*  DLARGV generates a vector of real plane rotations, determined by\n*  elements of the real vectors x and y. For i = 1,2,...,n\n*\n*     (  c(i)  s(i) ) ( x(i) ) = ( a(i) )\n*     ( -s(i)  c(i) ) ( y(i) ) = (   0  )\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of plane rotations to be generated.\n*\n*  X       (input/output) DOUBLE PRECISION array,\n*                         dimension (1+(N-1)*INCX)\n*          On entry, the vector x.\n*          On exit, x(i) is overwritten by a(i), for i = 1,...,n.\n*\n*  INCX    (input) INTEGER\n*          The increment between elements of X. INCX > 0.\n*\n*  Y       (input/output) DOUBLE PRECISION array,\n*                         dimension (1+(N-1)*INCY)\n*          On entry, the vector y.\n*          On exit, the sines of the plane rotations.\n*\n*  INCY    (input) INTEGER\n*          The increment between elements of Y. INCY > 0.\n*\n*  C       (output) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)\n*          The cosines of the plane rotations.\n*\n*  INCC    (input) INTEGER\n*          The increment between elements of C. INCC > 0.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c, x, y = NumRu::Lapack.dlargv( n, x, incx, y, incy, incc, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_n = argv[0];
  rblapack_x = argv[1];
  rblapack_incx = argv[2];
  rblapack_y = argv[3];
  rblapack_incy = argv[4];
  rblapack_incc = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  incx = NUM2INT(rblapack_incx);
  incy = NUM2INT(rblapack_incy);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1+(n-1)*incx))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  incc = NUM2INT(rblapack_incc);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (4th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incy))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
  if (NA_TYPE(rblapack_y) != NA_DFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
  y = NA_PTR_TYPE(rblapack_y, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incc;
    rblapack_c = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incx;
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incy;
    rblapack_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
  MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  dlargv_(&n, x, &incx, y, &incy, c, &incc);

  return rb_ary_new3(3, rblapack_c, rblapack_x, rblapack_y);
}

void
init_lapack_dlargv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlargv", rblapack_dlargv, -1);
}
ruby-lapack-1.7.2/ext/sptsvx.c0000644000175000017500000002603412502221020016071 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sptsvx_(char* fact, integer* n, integer* nrhs, real* d, real* e, real* df, real* ef, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* ferr, real* berr, real* work, integer* info);


static VALUE
rblapack_sptsvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_e;
  real *e; 
  VALUE rblapack_df;
  real *df; 
  VALUE rblapack_ef;
  real *ef; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_df_out__;
  real *df_out__;
  VALUE rblapack_ef_out__;
  real *ef_out__;
  real *work;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, info, df, ef = NumRu::Lapack.sptsvx( fact, d, e, df, ef, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SPTSVX uses the factorization A = L*D*L**T to compute the solution\n*  to a real system of linear equations A*X = B, where A is an N-by-N\n*  symmetric positive definite tridiagonal matrix and X and B are\n*  N-by-NRHS matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'N', the matrix A is factored as A = L*D*L**T, where L\n*     is a unit lower bidiagonal matrix and D is diagonal.  The\n*     factorization can also be regarded as having the form\n*     A = U**T*D*U.\n*\n*  2. If the leading i-by-i principal minor is not positive definite,\n*     then the routine returns with INFO = i. Otherwise, the factored\n*     form of A is used to estimate the condition number of the matrix\n*     A.  If the reciprocal of the condition number is less than machine\n*     precision, INFO = N+1 is returned as a warning, but the routine\n*     still goes on to solve for X and compute error bounds as\n*     described below.\n*\n*  3. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  4. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of A has been\n*          supplied on entry.\n*          = 'F':  On entry, DF and EF contain the factored form of A.\n*                  D, E, DF, and EF will not be modified.\n*          = 'N':  The matrix A will be copied to DF and EF and\n*                  factored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  D       (input) REAL array, dimension (N)\n*          The n diagonal elements of the tridiagonal matrix A.\n*\n*  E       (input) REAL array, dimension (N-1)\n*          The (n-1) subdiagonal elements of the tridiagonal matrix A.\n*\n*  DF      (input or output) REAL array, dimension (N)\n*          If FACT = 'F', then DF is an input argument and on entry\n*          contains the n diagonal elements of the diagonal matrix D\n*          from the L*D*L**T factorization of A.\n*          If FACT = 'N', then DF is an output argument and on exit\n*          contains the n diagonal elements of the diagonal matrix D\n*          from the L*D*L**T factorization of A.\n*\n*  EF      (input or output) REAL array, dimension (N-1)\n*          If FACT = 'F', then EF is an input argument and on entry\n*          contains the (n-1) subdiagonal elements of the unit\n*          bidiagonal factor L from the L*D*L**T factorization of A.\n*          If FACT = 'N', then EF is an output argument and on exit\n*          contains the (n-1) subdiagonal elements of the unit\n*          bidiagonal factor L from the L*D*L**T factorization of A.\n*\n*  B       (input) REAL array, dimension (LDB,NRHS)\n*          The N-by-NRHS right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) REAL array, dimension (LDX,NRHS)\n*          If INFO = 0 of INFO = N+1, the N-by-NRHS solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) REAL\n*          The reciprocal condition number of the matrix A.  If RCOND\n*          is less than the machine precision (in particular, if\n*          RCOND = 0), the matrix is singular to working precision.\n*          This condition is indicated by a return code of INFO > 0.\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in any\n*          element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) REAL array, dimension (2*N)\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, and i is\n*                <= N:  the leading minor of order i of A is\n*                       not positive definite, so the factorization\n*                       could not be completed, and the solution has not\n*                       been computed. RCOND = 0 is returned.\n*                = N+1: U is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, info, df, ef = NumRu::Lapack.sptsvx( fact, d, e, df, ef, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_fact = argv[0];
  rblapack_d = argv[1];
  rblapack_e = argv[2];
  rblapack_df = argv[3];
  rblapack_ef = argv[4];
  rblapack_b = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_df))
    rb_raise(rb_eArgError, "df (4th argument) must be NArray");
  if (NA_RANK(rblapack_df) != 1)
    rb_raise(rb_eArgError, "rank of df (4th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_df);
  if (NA_TYPE(rblapack_df) != NA_SFLOAT)
    rblapack_df = na_change_type(rblapack_df, NA_SFLOAT);
  df = NA_PTR_TYPE(rblapack_df, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of df");
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_ef))
    rb_raise(rb_eArgError, "ef (5th argument) must be NArray");
  if (NA_RANK(rblapack_ef) != 1)
    rb_raise(rb_eArgError, "rank of ef (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ef) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of ef must be %d", n-1);
  if (NA_TYPE(rblapack_ef) != NA_SFLOAT)
    rblapack_ef = na_change_type(rblapack_ef, NA_SFLOAT);
  ef = NA_PTR_TYPE(rblapack_ef, real*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (3th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", n-1);
  if (NA_TYPE(rblapack_e) != NA_SFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_SFLOAT);
  e = NA_PTR_TYPE(rblapack_e, real*);
  ldx = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_df_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  df_out__ = NA_PTR_TYPE(rblapack_df_out__, real*);
  MEMCPY(df_out__, df, real, NA_TOTAL(rblapack_df));
  rblapack_df = rblapack_df_out__;
  df = df_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_ef_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ef_out__ = NA_PTR_TYPE(rblapack_ef_out__, real*);
  MEMCPY(ef_out__, ef, real, NA_TOTAL(rblapack_ef));
  rblapack_ef = rblapack_ef_out__;
  ef = ef_out__;
  work = ALLOC_N(real, (2*n));

  sptsvx_(&fact, &n, &nrhs, d, e, df, ef, b, &ldb, x, &ldx, &rcond, ferr, berr, work, &info);

  free(work);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_df, rblapack_ef);
}

void
init_lapack_sptsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sptsvx", rblapack_sptsvx, -1);
}
ruby-lapack-1.7.2/ext/slaln2.c0000644000175000017500000002043312502221016015717 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaln2_(logical* ltrans, integer* na, integer* nw, real* smin, real* ca, real* a, integer* lda, real* d1, real* d2, real* b, integer* ldb, real* wr, real* wi, real* x, integer* ldx, real* scale, real* xnorm, integer* info);


static VALUE
rblapack_slaln2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ltrans;
  logical ltrans; 
  VALUE rblapack_smin;
  real smin; 
  VALUE rblapack_ca;
  real ca; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_d1;
  real d1; 
  VALUE rblapack_d2;
  real d2; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_wr;
  real wr; 
  VALUE rblapack_wi;
  real wi; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_scale;
  real scale; 
  VALUE rblapack_xnorm;
  real xnorm; 
  VALUE rblapack_info;
  integer info; 

  integer lda;
  integer na;
  integer ldb;
  integer nw;
  integer ldx;

  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  x, scale, xnorm, info = NumRu::Lapack.slaln2( ltrans, smin, ca, a, d1, d2, b, wr, wi, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, LDB, WR, WI, X, LDX, SCALE, XNORM, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLALN2 solves a system of the form  (ca A - w D ) X = s B\n*  or (ca A' - w D) X = s B   with possible scaling (\"s\") and\n*  perturbation of A.  (A' means A-transpose.)\n*\n*  A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA\n*  real diagonal matrix, w is a real or complex value, and X and B are\n*  NA x 1 matrices -- real if w is real, complex if w is complex.  NA\n*  may be 1 or 2.\n*\n*  If w is complex, X and B are represented as NA x 2 matrices,\n*  the first column of each being the real part and the second\n*  being the imaginary part.\n*\n*  \"s\" is a scaling factor (.LE. 1), computed by SLALN2, which is\n*  so chosen that X can be computed without overflow.  X is further\n*  scaled if necessary to assure that norm(ca A - w D)*norm(X) is less\n*  than overflow.\n*\n*  If both singular values of (ca A - w D) are less than SMIN,\n*  SMIN*identity will be used instead of (ca A - w D).  If only one\n*  singular value is less than SMIN, one element of (ca A - w D) will be\n*  perturbed enough to make the smallest singular value roughly SMIN.\n*  If both singular values are at least SMIN, (ca A - w D) will not be\n*  perturbed.  In any case, the perturbation will be at most some small\n*  multiple of max( SMIN, ulp*norm(ca A - w D) ).  The singular values\n*  are computed by infinity-norm approximations, and thus will only be\n*  correct to a factor of 2 or so.\n*\n*  Note: all input quantities are assumed to be smaller than overflow\n*  by a reasonable factor.  (See BIGNUM.)\n*\n\n*  Arguments\n*  ==========\n*\n*  LTRANS  (input) LOGICAL\n*          =.TRUE.:  A-transpose will be used.\n*          =.FALSE.: A will be used (not transposed.)\n*\n*  NA      (input) INTEGER\n*          The size of the matrix A.  It may (only) be 1 or 2.\n*\n*  NW      (input) INTEGER\n*          1 if \"w\" is real, 2 if \"w\" is complex.  It may only be 1\n*          or 2.\n*\n*  SMIN    (input) REAL\n*          The desired lower bound on the singular values of A.  This\n*          should be a safe distance away from underflow or overflow,\n*          say, between (underflow/machine precision) and  (machine\n*          precision * overflow ).  (See BIGNUM and ULP.)\n*\n*  CA      (input) REAL\n*          The coefficient c, which A is multiplied by.\n*\n*  A       (input) REAL array, dimension (LDA,NA)\n*          The NA x NA matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of A.  It must be at least NA.\n*\n*  D1      (input) REAL\n*          The 1,1 element in the diagonal matrix D.\n*\n*  D2      (input) REAL\n*          The 2,2 element in the diagonal matrix D.  Not used if NW=1.\n*\n*  B       (input) REAL array, dimension (LDB,NW)\n*          The NA x NW matrix B (right-hand side).  If NW=2 (\"w\" is\n*          complex), column 1 contains the real part of B and column 2\n*          contains the imaginary part.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of B.  It must be at least NA.\n*\n*  WR      (input) REAL\n*          The real part of the scalar \"w\".\n*\n*  WI      (input) REAL\n*          The imaginary part of the scalar \"w\".  Not used if NW=1.\n*\n*  X       (output) REAL array, dimension (LDX,NW)\n*          The NA x NW matrix X (unknowns), as computed by SLALN2.\n*          If NW=2 (\"w\" is complex), on exit, column 1 will contain\n*          the real part of X and column 2 will contain the imaginary\n*          part.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of X.  It must be at least NA.\n*\n*  SCALE   (output) REAL\n*          The scale factor that B must be multiplied by to insure\n*          that overflow does not occur when computing X.  Thus,\n*          (ca A - w D) X  will be SCALE*B, not B (ignoring\n*          perturbations of A.)  It will be at most 1.\n*\n*  XNORM   (output) REAL\n*          The infinity-norm of X, when X is regarded as an NA x NW\n*          real matrix.\n*\n*  INFO    (output) INTEGER\n*          An error flag.  It will be set to zero if no error occurs,\n*          a negative number if an argument is in error, or a positive\n*          number if  ca A - w D  had to be perturbed.\n*          The possible values are:\n*          = 0: No error occurred, and (ca A - w D) did not have to be\n*                 perturbed.\n*          = 1: (ca A - w D) had to be perturbed to make its smallest\n*               (or only) singular value greater than SMIN.\n*          NOTE: In the interests of speed, this routine does not\n*                check the inputs for errors.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, scale, xnorm, info = NumRu::Lapack.slaln2( ltrans, smin, ca, a, d1, d2, b, wr, wi, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_ltrans = argv[0];
  rblapack_smin = argv[1];
  rblapack_ca = argv[2];
  rblapack_a = argv[3];
  rblapack_d1 = argv[4];
  rblapack_d2 = argv[5];
  rblapack_b = argv[6];
  rblapack_wr = argv[7];
  rblapack_wi = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  ltrans = (rblapack_ltrans == Qtrue);
  ca = (real)NUM2DBL(rblapack_ca);
  d1 = (real)NUM2DBL(rblapack_d1);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nw = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  wi = (real)NUM2DBL(rblapack_wi);
  smin = (real)NUM2DBL(rblapack_smin);
  d2 = (real)NUM2DBL(rblapack_d2);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  na = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  ldx = na;
  wr = (real)NUM2DBL(rblapack_wr);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nw;
    rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, real*);

  slaln2_(<rans, &na, &nw, &smin, &ca, a, &lda, &d1, &d2, b, &ldb, &wr, &wi, x, &ldx, &scale, &xnorm, &info);

  rblapack_scale = rb_float_new((double)scale);
  rblapack_xnorm = rb_float_new((double)xnorm);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_x, rblapack_scale, rblapack_xnorm, rblapack_info);
}

void
init_lapack_slaln2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaln2", rblapack_slaln2, -1);
}
ruby-lapack-1.7.2/ext/zhbgst.c0000644000175000017500000001515212502221025016027 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhbgst_(char* vect, char* uplo, integer* n, integer* ka, integer* kb, doublecomplex* ab, integer* ldab, doublecomplex* bb, integer* ldbb, doublecomplex* x, integer* ldx, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zhbgst(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_vect;
  char vect; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ka;
  integer ka; 
  VALUE rblapack_kb;
  integer kb; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_bb;
  doublecomplex *bb; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublecomplex *ab_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer ldab;
  integer n;
  integer ldbb;
  integer ldx;

  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  x, info, ab = NumRu::Lapack.zhbgst( vect, uplo, ka, kb, ab, bb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, LDX, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHBGST reduces a complex Hermitian-definite banded generalized\n*  eigenproblem  A*x = lambda*B*x  to standard form  C*y = lambda*y,\n*  such that C has the same bandwidth as A.\n*\n*  B must have been previously factorized as S**H*S by ZPBSTF, using a\n*  split Cholesky factorization. A is overwritten by C = X**H*A*X, where\n*  X = S**(-1)*Q and Q is a unitary matrix chosen to preserve the\n*  bandwidth of A.\n*\n\n*  Arguments\n*  =========\n*\n*  VECT    (input) CHARACTER*1\n*          = 'N':  do not form the transformation matrix X;\n*          = 'V':  form X.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  KA      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KA >= 0.\n*\n*  KB      (input) INTEGER\n*          The number of superdiagonals of the matrix B if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KA >= KB >= 0.\n*\n*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix A, stored in the first ka+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).\n*\n*          On exit, the transformed matrix X**H*A*X, stored in the same\n*          format as A.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KA+1.\n*\n*  BB      (input) COMPLEX*16 array, dimension (LDBB,N)\n*          The banded factor S from the split Cholesky factorization of\n*          B, as returned by ZPBSTF, stored in the first kb+1 rows of\n*          the array.\n*\n*  LDBB    (input) INTEGER\n*          The leading dimension of the array BB.  LDBB >= KB+1.\n*\n*  X       (output) COMPLEX*16 array, dimension (LDX,N)\n*          If VECT = 'V', the n-by-n matrix X.\n*          If VECT = 'N', the array X is not referenced.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.\n*          LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (N)\n*\n*  RWORK   (workspace) DOUBLE PRECISION array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, info, ab = NumRu::Lapack.zhbgst( vect, uplo, ka, kb, ab, bb, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_vect = argv[0];
  rblapack_uplo = argv[1];
  rblapack_ka = argv[2];
  rblapack_kb = argv[3];
  rblapack_ab = argv[4];
  rblapack_bb = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  vect = StringValueCStr(rblapack_vect)[0];
  ka = NUM2INT(rblapack_ka);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_bb))
    rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
  if (NA_RANK(rblapack_bb) != 2)
    rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
  ldbb = NA_SHAPE0(rblapack_bb);
  if (NA_SHAPE1(rblapack_bb) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of bb must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_bb) != NA_DCOMPLEX)
    rblapack_bb = na_change_type(rblapack_bb, NA_DCOMPLEX);
  bb = NA_PTR_TYPE(rblapack_bb, doublecomplex*);
  kb = NUM2INT(rblapack_kb);
  ldx = lsame_(&vect,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = n;
    rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
  MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  work = ALLOC_N(doublecomplex, (n));
  rwork = ALLOC_N(doublereal, (n));

  zhbgst_(&vect, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, x, &ldx, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_x, rblapack_info, rblapack_ab);
}

void
init_lapack_zhbgst(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhbgst", rblapack_zhbgst, -1);
}
ruby-lapack-1.7.2/ext/dlansb.c0000644000175000017500000001124112502221024015763 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal dlansb_(char* norm, char* uplo, integer* n, integer* k, doublereal* ab, integer* ldab, doublereal* work);


static VALUE
rblapack_dlansb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack___out__;
  doublereal __out__; 
  doublereal *work;

  integer ldab;
  integer n;
  integer lwork;

  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  __out__ = NumRu::Lapack.dlansb( norm, uplo, k, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION DLANSB( NORM, UPLO, N, K, AB, LDAB, WORK )\n\n*  Purpose\n*  =======\n*\n*  DLANSB  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the element of  largest absolute value  of an\n*  n by n symmetric band matrix A,  with k super-diagonals.\n*\n*  Description\n*  ===========\n*\n*  DLANSB returns the value\n*\n*     DLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in DLANSB as described\n*          above.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          band matrix A is supplied.\n*          = 'U':  Upper triangular part is supplied\n*          = 'L':  Lower triangular part is supplied\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, DLANSB is\n*          set to zero.\n*\n*  K       (input) INTEGER\n*          The number of super-diagonals or sub-diagonals of the\n*          band matrix A.  K >= 0.\n*\n*  AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)\n*          The upper or lower triangle of the symmetric band matrix A,\n*          stored in the first K+1 rows of AB.  The j-th column of A is\n*          stored in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)   = A(i,j) for j<=i<=min(n,j+k).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= K+1.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n*          WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.dlansb( norm, uplo, k, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_k = argv[2];
  rblapack_ab = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  k = NUM2INT(rblapack_k);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
  work = ALLOC_N(doublereal, (MAX(1,lwork)));

  __out__ = dlansb_(&norm, &uplo, &n, &k, ab, &ldab, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_dlansb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlansb", rblapack_dlansb, -1);
}
ruby-lapack-1.7.2/ext/dlartgs.c0000644000175000017500000000533612502221015016170 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlartgs_(doublereal* x, doublereal* y, doublereal* sigma, doublereal* cs, doublereal* sn);


static VALUE
rblapack_dlartgs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_x;
  doublereal x; 
  VALUE rblapack_y;
  doublereal y; 
  VALUE rblapack_sigma;
  doublereal sigma; 
  VALUE rblapack_cs;
  doublereal cs; 
  VALUE rblapack_sn;
  doublereal sn; 


  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  cs, sn = NumRu::Lapack.dlartgs( x, y, sigma, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLARTGS( X, Y, SIGMA, CS, SN )\n\n*  Purpose\n*  =======\n*\n*  DLARTGS generates a plane rotation designed to introduce a bulge in\n*  Golub-Reinsch-style implicit QR iteration for the bidiagonal SVD\n*  problem. X and Y are the top-row entries, and SIGMA is the shift.\n*  The computed CS and SN define a plane rotation satisfying\n*\n*     [  CS  SN  ]  .  [ X^2 - SIGMA ]  =  [ R ],\n*     [ -SN  CS  ]     [    X * Y    ]     [ 0 ]\n*\n*  with R nonnegative.  If X^2 - SIGMA and X * Y are 0, then the\n*  rotation is by PI/2.\n*\n\n*  Arguments\n*  =========\n*\n*  X       (input) DOUBLE PRECISION\n*          The (1,1) entry of an upper bidiagonal matrix.\n*\n*  Y       (input) DOUBLE PRECISION\n*          The (1,2) entry of an upper bidiagonal matrix.\n*\n*  SIGMA   (input) DOUBLE PRECISION\n*          The shift.\n*\n*  CS      (output) DOUBLE PRECISION\n*          The cosine of the rotation.\n*\n*  SN      (output) DOUBLE PRECISION\n*          The sine of the rotation.\n*\n\n*  ===================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  cs, sn = NumRu::Lapack.dlartgs( x, y, sigma, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_x = argv[0];
  rblapack_y = argv[1];
  rblapack_sigma = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  x = NUM2DBL(rblapack_x);
  sigma = NUM2DBL(rblapack_sigma);
  y = NUM2DBL(rblapack_y);

  dlartgs_(&x, &y, &sigma, &cs, &sn);

  rblapack_cs = rb_float_new((double)cs);
  rblapack_sn = rb_float_new((double)sn);
  return rb_ary_new3(2, rblapack_cs, rblapack_sn);
}

void
init_lapack_dlartgs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlartgs", rblapack_dlartgs, -1);
}
ruby-lapack-1.7.2/ext/cppequ.c0000644000175000017500000001052412502221014016017 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cppequ_(char* uplo, integer* n, complex* ap, real* s, real* scond, real* amax, integer* info);


static VALUE
rblapack_cppequ(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_scond;
  real scond; 
  VALUE rblapack_amax;
  real amax; 
  VALUE rblapack_info;
  integer info; 

  integer ldap;
  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  s, scond, amax, info = NumRu::Lapack.cppequ( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPPEQU computes row and column scalings intended to equilibrate a\n*  Hermitian positive definite matrix A in packed storage and reduce\n*  its condition number (with respect to the two-norm).  S contains the\n*  scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix\n*  B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.\n*  This choice of S puts the condition number of B within a factor N of\n*  the smallest possible condition number over all possible diagonal\n*  scalings.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)\n*          The upper or lower triangle of the Hermitian matrix A, packed\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  S       (output) REAL array, dimension (N)\n*          If INFO = 0, S contains the scale factors for A.\n*\n*  SCOND   (output) REAL\n*          If INFO = 0, S contains the ratio of the smallest S(i) to\n*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too\n*          large nor too small, it is not worth scaling by S.\n*\n*  AMAX    (output) REAL\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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 is nonpositive.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, scond, amax, info = NumRu::Lapack.cppequ( uplo, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, real*);

  cppequ_(&uplo, &n, ap, s, &scond, &amax, &info);

  rblapack_scond = rb_float_new((double)scond);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
}

void
init_lapack_cppequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cppequ", rblapack_cppequ, -1);
}
ruby-lapack-1.7.2/ext/zpbtf2.c0000644000175000017500000001234312502221021015730 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zpbtf2_(char* uplo, integer* n, integer* kd, doublecomplex* ab, integer* ldab, integer* info);


static VALUE
rblapack_zpbtf2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublecomplex *ab_out__;

  integer ldab;
  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  info, ab = NumRu::Lapack.zpbtf2( uplo, kd, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPBTF2( UPLO, N, KD, AB, LDAB, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPBTF2 computes the Cholesky factorization of a complex Hermitian\n*  positive definite band matrix A.\n*\n*  The factorization has the form\n*     A = U' * U ,  if UPLO = 'U', or\n*     A = L  * L',  if UPLO = 'L',\n*  where U is an upper triangular matrix, U' is the conjugate transpose\n*  of U, and L is lower triangular.\n*\n*  This is the unblocked version of the algorithm, calling Level 2 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          Hermitian matrix A is stored:\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of super-diagonals of the matrix A if UPLO = 'U',\n*          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*          On exit, if INFO = 0, the triangular factor U or L from the\n*          Cholesky factorization A = U'*U or A = L*L' of the band\n*          matrix A, in the same storage format as A.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -k, the k-th argument had an illegal value\n*          > 0: if INFO = k, the leading minor of order k is not\n*               positive definite, and the factorization could not be\n*               completed.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  N = 6, KD = 2, and UPLO = 'U':\n*\n*  On entry:                       On exit:\n*\n*      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46\n*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56\n*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66\n*\n*  Similarly, if UPLO = 'L' the format of A is as follows:\n*\n*  On entry:                       On exit:\n*\n*     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66\n*     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *\n*     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *\n*\n*  Array elements marked * are not used by the routine.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ab = NumRu::Lapack.zpbtf2( uplo, kd, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  kd = NUM2INT(rblapack_kd);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
  MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  zpbtf2_(&uplo, &n, &kd, ab, &ldab, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ab);
}

void
init_lapack_zpbtf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zpbtf2", rblapack_zpbtf2, -1);
}
ruby-lapack-1.7.2/ext/ctrexc.c0000644000175000017500000001327512502221021016016 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctrexc_(char* compq, integer* n, complex* t, integer* ldt, complex* q, integer* ldq, integer* ifst, integer* ilst, integer* info);


static VALUE
rblapack_ctrexc(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_compq;
  char compq; 
  VALUE rblapack_t;
  complex *t; 
  VALUE rblapack_q;
  complex *q; 
  VALUE rblapack_ifst;
  integer ifst; 
  VALUE rblapack_ilst;
  integer ilst; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_t_out__;
  complex *t_out__;
  VALUE rblapack_q_out__;
  complex *q_out__;

  integer ldt;
  integer n;
  integer ldq;

  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  info, t, q = NumRu::Lapack.ctrexc( compq, t, q, ifst, ilst, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTREXC reorders the Schur factorization of a complex matrix\n*  A = Q*T*Q**H, so that the diagonal element of T with row index IFST\n*  is moved to row ILST.\n*\n*  The Schur form T is reordered by a unitary similarity transformation\n*  Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by\n*  postmultplying it with Z.\n*\n\n*  Arguments\n*  =========\n*\n*  COMPQ   (input) CHARACTER*1\n*          = 'V':  update the matrix Q of Schur vectors;\n*          = 'N':  do not update Q.\n*\n*  N       (input) INTEGER\n*          The order of the matrix T. N >= 0.\n*\n*  T       (input/output) COMPLEX array, dimension (LDT,N)\n*          On entry, the upper triangular matrix T.\n*          On exit, the reordered upper triangular matrix.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= max(1,N).\n*\n*  Q       (input/output) COMPLEX array, dimension (LDQ,N)\n*          On entry, if COMPQ = 'V', the matrix Q of Schur vectors.\n*          On exit, if COMPQ = 'V', Q has been postmultiplied by the\n*          unitary transformation matrix Z which reorders T.\n*          If COMPQ = 'N', Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.  LDQ >= max(1,N).\n*\n*  IFST    (input) INTEGER\n*  ILST    (input) INTEGER\n*          Specify the reordering of the diagonal elements of T:\n*          The element with row index IFST is moved to row ILST by a\n*          sequence of transpositions between adjacent elements.\n*          1 <= IFST <= N; 1 <= ILST <= N.\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*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            WANTQ\n      INTEGER            K, M1, M2, M3\n      REAL               CS\n      COMPLEX            SN, T11, T22, TEMP\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CLARTG, CROT, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          CONJG, MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, t, q = NumRu::Lapack.ctrexc( compq, t, q, ifst, ilst, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_compq = argv[0];
  rblapack_t = argv[1];
  rblapack_q = argv[2];
  rblapack_ifst = argv[3];
  rblapack_ilst = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  compq = StringValueCStr(rblapack_compq)[0];
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (3th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (3th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  n = NA_SHAPE1(rblapack_q);
  if (NA_TYPE(rblapack_q) != NA_SCOMPLEX)
    rblapack_q = na_change_type(rblapack_q, NA_SCOMPLEX);
  q = NA_PTR_TYPE(rblapack_q, complex*);
  ilst = NUM2INT(rblapack_ilst);
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (2th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (2th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  if (NA_SHAPE1(rblapack_t) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of q");
  if (NA_TYPE(rblapack_t) != NA_SCOMPLEX)
    rblapack_t = na_change_type(rblapack_t, NA_SCOMPLEX);
  t = NA_PTR_TYPE(rblapack_t, complex*);
  ifst = NUM2INT(rblapack_ifst);
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = n;
    rblapack_t_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  t_out__ = NA_PTR_TYPE(rblapack_t_out__, complex*);
  MEMCPY(t_out__, t, complex, NA_TOTAL(rblapack_t));
  rblapack_t = rblapack_t_out__;
  t = t_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, complex*);
  MEMCPY(q_out__, q, complex, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;

  ctrexc_(&compq, &n, t, &ldt, q, &ldq, &ifst, &ilst, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_t, rblapack_q);
}

void
init_lapack_ctrexc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctrexc", rblapack_ctrexc, -1);
}
ruby-lapack-1.7.2/ext/zsysvxx.c0000644000175000017500000006552212502221025016312 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zsysvxx_(char* fact, char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, char* equed, doublereal* s, doublecomplex* b, integer* ldb, doublecomplex* x, integer* ldx, doublereal* rcond, doublereal* rpvgrw, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublecomplex* work, doublereal* rwork, integer* info);


static VALUE
rblapack_zsysvxx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_params;
  doublereal *params; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_rpvgrw;
  doublereal rpvgrw; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_err_bnds_norm;
  doublereal *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  doublereal *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  VALUE rblapack_af_out__;
  doublecomplex *af_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  VALUE rblapack_s_out__;
  doublereal *s_out__;
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;
  VALUE rblapack_params_out__;
  doublereal *params_out__;
  doublecomplex *work;
  doublereal *rwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer nparams;
  integer ldx;
  integer n_err_bnds;

  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  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.zsysvxx( fact, uplo, a, af, ipiv, equed, s, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     ZSYSVXX uses the diagonal pivoting factorization to compute the\n*     solution to a complex*16 system of linear equations A * X = B, where\n*     A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n*     matrices.\n*\n*     If requested, both normwise and maximum componentwise error bounds\n*     are returned. ZSYSVXX will return a solution with a tiny\n*     guaranteed error (O(eps) where eps is the working machine\n*     precision) unless the matrix is very ill-conditioned, in which\n*     case a warning is returned. Relevant condition numbers also are\n*     calculated and returned.\n*\n*     ZSYSVXX accepts user-provided factorizations and equilibration\n*     factors; see the definitions of the FACT and EQUED options.\n*     Solving with refinement and using a factorization from a previous\n*     ZSYSVXX call will also produce a solution with either O(eps)\n*     errors or warnings, but we cannot make that claim for general\n*     user-provided factorizations and equilibration factors if they\n*     differ from what ZSYSVXX would itself produce.\n*\n*     Description\n*     ===========\n*\n*     The following steps are performed:\n*\n*     1. If FACT = 'E', double precision scaling factors are computed to equilibrate\n*     the system:\n*\n*       diag(S)*A*diag(S)     *inv(diag(S))*X = diag(S)*B\n*\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n*     2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n*     the matrix A (after equilibration if FACT = 'E') as\n*\n*        A = U * D * U**T,  if UPLO = 'U', or\n*        A = L * D * L**T,  if UPLO = 'L',\n*\n*     where U (or L) is a product of permutation and unit upper (lower)\n*     triangular matrices, and D is symmetric and block diagonal with\n*     1-by-1 and 2-by-2 diagonal blocks.\n*\n*     3. If some D(i,i)=0, so that D is exactly singular, then the\n*     routine returns with INFO = i. Otherwise, the factored form of A\n*     is used to estimate the condition number of the matrix A (see\n*     argument RCOND).  If the reciprocal of the condition number is\n*     less than machine precision, the routine still goes on to solve\n*     for X and compute error bounds as described below.\n*\n*     4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*     5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n*     the routine will use iterative refinement to try to get a small\n*     error and error bounds.  Refinement calculates the residual to at\n*     least twice the working precision.\n*\n*     6. If equilibration was used, the matrix X is premultiplied by\n*     diag(R) so that it solves the original system before\n*     equilibration.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     FACT    (input) CHARACTER*1\n*     Specifies whether or not the factored form of the matrix A is\n*     supplied on entry, and if not, whether the matrix A should be\n*     equilibrated before it is factored.\n*       = 'F':  On entry, AF and IPIV contain the factored form of A.\n*               If EQUED is not 'N', the matrix A has been\n*               equilibrated with scaling factors given by S.\n*               A, AF, and IPIV are not modified.\n*       = 'N':  The matrix A will be copied to AF and factored.\n*       = 'E':  The matrix A will be equilibrated if necessary, then\n*               copied to AF and factored.\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*     The symmetric matrix A.  If UPLO = 'U', the leading N-by-N\n*     upper triangular part of A contains the upper triangular\n*     part of the matrix A, and the strictly lower triangular\n*     part of A is not referenced.  If UPLO = 'L', the leading\n*     N-by-N lower triangular part of A contains the lower\n*     triangular part of the matrix A, and the strictly upper\n*     triangular part of A is not referenced.\n*\n*     On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n*     diag(S)*A*diag(S).\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input or output) COMPLEX*16 array, dimension (LDAF,N)\n*     If FACT = 'F', then AF is an input argument and on entry\n*     contains the block diagonal matrix D and the multipliers\n*     used to obtain the factor U or L from the factorization A =\n*     U*D*U**T or A = L*D*L**T as computed by DSYTRF.\n*\n*     If FACT = 'N', then AF is an output argument and on exit\n*     returns the block diagonal matrix D and the multipliers\n*     used to obtain the factor U or L from the factorization A =\n*     U*D*U**T or A = L*D*L**T.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input or output) INTEGER array, dimension (N)\n*     If FACT = 'F', then IPIV is an input argument and on entry\n*     contains details of the interchanges and the block\n*     structure of D, as determined by DSYTRF.  If IPIV(k) > 0,\n*     then rows and columns k and IPIV(k) were interchanged and\n*     D(k,k) is a 1-by-1 diagonal block.  If UPLO = 'U' and\n*     IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and\n*     -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2\n*     diagonal block.  If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0,\n*     then rows and columns k+1 and -IPIV(k) were interchanged\n*     and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*     If FACT = 'N', then IPIV is an output argument and on exit\n*     contains details of the interchanges and the block\n*     structure of D, as determined by DSYTRF.\n*\n*     EQUED   (input or output) CHARACTER*1\n*     Specifies the form of equilibration that was done.\n*       = 'N':  No equilibration (always true if FACT = 'N').\n*       = 'Y':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(S) * A * diag(S).\n*     EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*     output argument.\n*\n*     S       (input or output) DOUBLE PRECISION array, dimension (N)\n*     The scale factors for A.  If EQUED = 'Y', A is multiplied on\n*     the left and right by diag(S).  S is an input argument if FACT =\n*     'F'; otherwise, S is an output argument.  If FACT = 'F' and EQUED\n*     = 'Y', each element of S must be positive.  If S is output, each\n*     element of S is a power of the radix. If S is input, each element\n*     of S should be a power of the radix to ensure a reliable solution\n*     and error estimates. Scaling by powers of the radix does not cause\n*     rounding errors unless the result underflows or overflows.\n*     Rounding errors during scaling lead to refining with a matrix that\n*     is not equivalent to the input matrix, producing error estimates\n*     that may not be reliable.\n*\n*     B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*     On entry, the N-by-NRHS right hand side matrix B.\n*     On exit,\n*     if EQUED = 'N', B is not modified;\n*     if EQUED = 'Y', B is overwritten by diag(S)*B;\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (output) COMPLEX*16 array, dimension (LDX,NRHS)\n*     If INFO = 0, the N-by-NRHS solution matrix X to the original\n*     system of equations.  Note that A and B are modified on exit if\n*     EQUED .ne. 'N', and the solution to the equilibrated system is\n*     inv(diag(S))*X.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) DOUBLE PRECISION\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     RPVGRW  (output) DOUBLE PRECISION\n*     Reciprocal pivot growth.  On exit, this contains the reciprocal\n*     pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n*     norm is used.  If this is much less than 1, then the stability of\n*     the LU factorization of the (equilibrated) matrix A could be poor.\n*     This also means that the solution X, estimated condition numbers,\n*     and error bounds could be unreliable. If factorization fails with\n*     0 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, a, af, ipiv, equed, s, b, params = NumRu::Lapack.zsysvxx( fact, uplo, a, af, ipiv, equed, s, b, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_equed = argv[5];
  rblapack_s = argv[6];
  rblapack_b = argv[7];
  rblapack_params = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (7th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (9th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_DFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
  params = NA_PTR_TYPE(rblapack_params, doublereal*);
  n_err_bnds = 3;
  uplo = StringValueCStr(rblapack_uplo)[0];
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  ldx = MAX(1,n);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldaf;
    shape[1] = n;
    rblapack_af_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  af_out__ = NA_PTR_TYPE(rblapack_af_out__, doublecomplex*);
  MEMCPY(af_out__, af, doublecomplex, NA_TOTAL(rblapack_af));
  rblapack_af = rblapack_af_out__;
  af = af_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
  MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
  MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(doublecomplex, (2*n));
  rwork = ALLOC_N(doublereal, (2*n));

  zsysvxx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, s, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_rpvgrw = rb_float_new((double)rpvgrw);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(14, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_a, rblapack_af, rblapack_ipiv, rblapack_equed, rblapack_s, rblapack_b, rblapack_params);
}

void
init_lapack_zsysvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zsysvxx", rblapack_zsysvxx, -1);
}
ruby-lapack-1.7.2/ext/cgbcon.c0000644000175000017500000001255512502221024015764 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgbcon_(char* norm, integer* n, integer* kl, integer* ku, complex* ab, integer* ldab, integer* ipiv, real* anorm, real* rcond, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cgbcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_anorm;
  real anorm; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_info;
  integer info; 
  complex *work;
  real *rwork;

  integer ldab;
  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  rcond, info = NumRu::Lapack.cgbcon( norm, kl, ku, ab, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGBCON estimates the reciprocal of the condition number of a complex\n*  general band matrix A, in either the 1-norm or the infinity-norm,\n*  using the LU factorization computed by CGBTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as\n*     RCOND = 1 / ( norm(A) * norm(inv(A)) ).\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies whether the 1-norm condition number or the\n*          infinity-norm condition number is required:\n*          = '1' or 'O':  1-norm;\n*          = 'I':         Infinity-norm.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  AB      (input) COMPLEX array, dimension (LDAB,N)\n*          Details of the LU factorization of the band matrix A, as\n*          computed by CGBTRF.  U is stored as an upper triangular band\n*          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n*          the multipliers used during the factorization are stored in\n*          rows KL+KU+2 to 2*KL+KU+1.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices; for 1 <= i <= N, row i of the matrix was\n*          interchanged with row IPIV(i).\n*\n*  ANORM   (input) REAL\n*          If NORM = '1' or 'O', the 1-norm of the original matrix A.\n*          If NORM = 'I', the infinity-norm of the original matrix A.\n*\n*  RCOND   (output) REAL\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(norm(A) * norm(inv(A))).\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.cgbcon( norm, kl, ku, ab, ipiv, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_norm = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_anorm = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  kl = NUM2INT(rblapack_kl);
  anorm = (real)NUM2DBL(rblapack_anorm);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (n));

  cgbcon_(&norm, &n, &kl, &ku, ab, &ldab, ipiv, &anorm, &rcond, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_cgbcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgbcon", rblapack_cgbcon, -1);
}
ruby-lapack-1.7.2/ext/dsbevd.c0000644000175000017500000002175312502221025016001 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsbevd_(char* jobz, char* uplo, integer* n, integer* kd, doublereal* ab, integer* ldab, doublereal* w, doublereal* z, integer* ldz, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_dsbevd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublereal *ab_out__;

  integer ldab;
  integer n;
  integer ldz;

  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  w, z, work, iwork, info, ab = NumRu::Lapack.dsbevd( jobz, uplo, kd, ab, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSBEVD computes all the eigenvalues and, optionally, eigenvectors of\n*  a real symmetric band matrix A. If eigenvectors are desired, it uses\n*  a divide and conquer algorithm.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB, N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*          On exit, AB is overwritten by values generated during the\n*          reduction to tridiagonal form.  If UPLO = 'U', the first\n*          superdiagonal and the diagonal of the tridiagonal matrix T\n*          are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n*          the diagonal and first subdiagonal of T are returned in the\n*          first two rows of AB.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD + 1.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n*          eigenvectors of the matrix A, with the i-th column of Z\n*          holding the eigenvector associated with W(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace/output) DOUBLE PRECISION array,\n*                                         dimension (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*          IF N <= 1,                LWORK must be at least 1.\n*          If JOBZ  = 'N' and N > 2, LWORK must be at least 2*N.\n*          If JOBZ  = 'V' and N > 2, LWORK must be at least\n*                         ( 1 + 5*N + 2*N**2 ).\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal sizes of the WORK and IWORK\n*          arrays, returns these values as the first entries of the WORK\n*          and IWORK arrays, and no error message related to LWORK or\n*          LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array LIWORK.\n*          If JOBZ  = 'N' or N <= 1, LIWORK must be at least 1.\n*          If JOBZ  = 'V' and N > 2, LIWORK must be at least 3 + 5*N.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK and IWORK arrays, and no error message related to\n*          LWORK or LIWORK 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 algorithm failed to converge; i\n*                off-diagonal elements of an intermediate tridiagonal\n*                form did not converge to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, work, iwork, info, ab = NumRu::Lapack.dsbevd( jobz, uplo, kd, ab, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_kd = argv[2];
  rblapack_ab = argv[3];
  if (argc == 6) {
    rblapack_lwork = argv[4];
    rblapack_liwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  kd = NUM2INT(rblapack_kd);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  if (rblapack_liwork == Qnil)
    liwork = (lsame_(&jobz,"N")||n<=0) ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  if (rblapack_lwork == Qnil)
    lwork = n<=0 ? 1 : lsame_(&jobz,"N") ? 2*n : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
  MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  dsbevd_(&jobz, &uplo, &n, &kd, ab, &ldab, w, z, &ldz, work, &lwork, iwork, &liwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_w, rblapack_z, rblapack_work, rblapack_iwork, rblapack_info, rblapack_ab);
}

void
init_lapack_dsbevd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsbevd", rblapack_dsbevd, -1);
}
ruby-lapack-1.7.2/ext/dlarfgp.c0000644000175000017500000000753412502221025016152 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlarfgp_(integer* n, doublereal* alpha, doublereal* x, integer* incx, doublereal* tau);


static VALUE
rblapack_dlarfgp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_alpha;
  doublereal alpha; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_tau;
  doublereal tau; 
  VALUE rblapack_x_out__;
  doublereal *x_out__;


  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, alpha, x = NumRu::Lapack.dlarfgp( n, alpha, x, incx, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLARFGP( N, ALPHA, X, INCX, TAU )\n\n*  Purpose\n*  =======\n*\n*  DLARFGP generates a real elementary reflector H of order n, such\n*  that\n*\n*        H * ( alpha ) = ( beta ),   H' * H = I.\n*            (   x   )   (   0  )\n*\n*  where alpha and beta are scalars, beta is non-negative, and x is\n*  an (n-1)-element real vector.  H is represented in the form\n*\n*        H = I - tau * ( 1 ) * ( 1 v' ) ,\n*                      ( v )\n*\n*  where tau is a real scalar and v is a real (n-1)-element\n*  vector.\n*\n*  If the elements of x are all zero, then tau = 0 and H is taken to be\n*  the unit matrix.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the elementary reflector.\n*\n*  ALPHA   (input/output) DOUBLE PRECISION\n*          On entry, the value alpha.\n*          On exit, it is overwritten with the value beta.\n*\n*  X       (input/output) DOUBLE PRECISION array, dimension\n*                         (1+(N-2)*abs(INCX))\n*          On entry, the vector x.\n*          On exit, it is overwritten with the vector v.\n*\n*  INCX    (input) INTEGER\n*          The increment between elements of X. INCX > 0.\n*\n*  TAU     (output) DOUBLE PRECISION\n*          The value tau.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, alpha, x = NumRu::Lapack.dlarfgp( n, alpha, x, incx, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_n = argv[0];
  rblapack_alpha = argv[1];
  rblapack_x = argv[2];
  rblapack_incx = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  incx = NUM2INT(rblapack_incx);
  alpha = NUM2DBL(rblapack_alpha);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (3th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1+(n-2)*abs(incx)))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-2)*abs(incx));
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-2)*abs(incx);
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;

  dlarfgp_(&n, &alpha, x, &incx, &tau);

  rblapack_tau = rb_float_new((double)tau);
  rblapack_alpha = rb_float_new((double)alpha);
  return rb_ary_new3(3, rblapack_tau, rblapack_alpha, rblapack_x);
}

void
init_lapack_dlarfgp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlarfgp", rblapack_dlarfgp, -1);
}
ruby-lapack-1.7.2/ext/zppequ.c0000644000175000017500000001066712502221026016061 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zppequ_(char* uplo, integer* n, doublecomplex* ap, doublereal* s, doublereal* scond, doublereal* amax, integer* info);


static VALUE
rblapack_zppequ(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_scond;
  doublereal scond; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_info;
  integer info; 

  integer ldap;
  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  s, scond, amax, info = NumRu::Lapack.zppequ( uplo, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPPEQU computes row and column scalings intended to equilibrate a\n*  Hermitian positive definite matrix A in packed storage and reduce\n*  its condition number (with respect to the two-norm).  S contains the\n*  scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix\n*  B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.\n*  This choice of S puts the condition number of B within a factor N of\n*  the smallest possible condition number over all possible diagonal\n*  scalings.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          The upper or lower triangle of the Hermitian matrix A, packed\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  S       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, S contains the scale factors for A.\n*\n*  SCOND   (output) DOUBLE PRECISION\n*          If INFO = 0, S contains the ratio of the smallest S(i) to\n*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too\n*          large nor too small, it is not worth scaling by S.\n*\n*  AMAX    (output) DOUBLE PRECISION\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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 is nonpositive.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, scond, amax, info = NumRu::Lapack.zppequ( uplo, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, doublereal*);

  zppequ_(&uplo, &n, ap, s, &scond, &amax, &info);

  rblapack_scond = rb_float_new((double)scond);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
}

void
init_lapack_zppequ(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zppequ", rblapack_zppequ, -1);
}
ruby-lapack-1.7.2/ext/cgetc2.c0000644000175000017500000001061712502221022015673 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgetc2_(integer* n, complex* a, integer* lda, integer* ipiv, integer* jpiv, integer* info);


static VALUE
rblapack_cgetc2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_jpiv;
  integer *jpiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *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  ipiv, jpiv, info, a = NumRu::Lapack.cgetc2( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGETC2( N, A, LDA, IPIV, JPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGETC2 computes an LU factorization, using complete pivoting, of the\n*  n-by-n matrix A. The factorization has the form A = P * L * U * Q,\n*  where P and Q are permutation matrices, L is lower triangular with\n*  unit diagonal elements and U is upper triangular.\n*\n*  This is a level 1 BLAS version of the algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA, N)\n*          On entry, the n-by-n matrix to be factored.\n*          On exit, the factors L and U from the factorization\n*          A = P*L*U*Q; the unit diagonal elements of L are not stored.\n*          If U(k, k) appears to be less than SMIN, U(k, k) is given the\n*          value of SMIN, giving a nonsingular perturbed system.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1, N).\n*\n*  IPIV    (output) INTEGER array, dimension (N).\n*          The pivot indices; for 1 <= i <= N, row i of the\n*          matrix has been interchanged with row IPIV(i).\n*\n*  JPIV    (output) INTEGER array, dimension (N).\n*          The pivot indices; for 1 <= j <= N, column j of the\n*          matrix has been interchanged with column JPIV(j).\n*\n*  INFO    (output) INTEGER\n*           = 0: successful exit\n*           > 0: if INFO = k, U(k, k) is likely to produce overflow if\n*                one tries to solve for x in Ax = b. So U is perturbed\n*                to avoid the overflow.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, jpiv, info, a = NumRu::Lapack.cgetc2( 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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_jpiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  jpiv = NA_PTR_TYPE(rblapack_jpiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  cgetc2_(&n, a, &lda, ipiv, jpiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ipiv, rblapack_jpiv, rblapack_info, rblapack_a);
}

void
init_lapack_cgetc2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgetc2", rblapack_cgetc2, -1);
}
ruby-lapack-1.7.2/ext/chpcon.c0000644000175000017500000001074112502221023015775 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chpcon_(char* uplo, integer* n, complex* ap, integer* ipiv, real* anorm, real* rcond, complex* work, integer* info);


static VALUE
rblapack_chpcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_anorm;
  real anorm; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_info;
  integer info; 
  complex *work;

  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  rcond, info = NumRu::Lapack.chpcon( uplo, ap, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHPCON estimates the reciprocal of the condition number of a complex\n*  Hermitian packed matrix A using the factorization A = U*D*U**H or\n*  A = L*D*L**H computed by CHPTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**H;\n*          = 'L':  Lower triangular, form is A = L*D*L**H.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input) COMPLEX array, dimension (N*(N+1)/2)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by CHPTRF, stored as a\n*          packed triangular matrix.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by CHPTRF.\n*\n*  ANORM   (input) REAL\n*          The 1-norm of the original matrix A.\n*\n*  RCOND   (output) REAL\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n*          estimate of the 1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.chpcon( uplo, ap, ipiv, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_ap = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_anorm = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (2th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  anorm = (real)NUM2DBL(rblapack_anorm);
  work = ALLOC_N(complex, (2*n));

  chpcon_(&uplo, &n, ap, ipiv, &anorm, &rcond, work, &info);

  free(work);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_chpcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chpcon", rblapack_chpcon, -1);
}
ruby-lapack-1.7.2/ext/zhetrs.c0000644000175000017500000001204412502221022016037 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhetrs_(char* uplo, integer* n, integer* nrhs, doublecomplex* a, integer* lda, integer* ipiv, doublecomplex* b, integer* ldb, integer* info);


static VALUE
rblapack_zhetrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublecomplex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  doublecomplex *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.zhetrs( uplo, a, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHETRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHETRS solves a system of linear equations A*X = B with a complex\n*  Hermitian matrix A using the factorization A = U*D*U**H or\n*  A = L*D*L**H computed by ZHETRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the details of the factorization are stored\n*          as an upper or lower triangular matrix.\n*          = 'U':  Upper triangular, form is A = U*D*U**H;\n*          = 'L':  Lower triangular, form is A = L*D*L**H.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          The block diagonal matrix D and the multipliers used to\n*          obtain the factor U or L as computed by ZHETRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          Details of the interchanges and the block structure of D\n*          as determined by ZHETRF.\n*\n*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.zhetrs( uplo, a, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_DCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_DCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublecomplex*);
  MEMCPY(b_out__, b, doublecomplex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  zhetrs_(&uplo, &n, &nrhs, a, &lda, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_zhetrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhetrs", rblapack_zhetrs, -1);
}
ruby-lapack-1.7.2/ext/dlaqr1.c0000644000175000017500000000736412502221014015716 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaqr1_(integer* n, doublereal* h, integer* ldh, doublereal* sr1, doublereal* si1, doublereal* sr2, doublereal* si2, doublereal* v);


static VALUE
rblapack_dlaqr1(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_h;
  doublereal *h; 
  VALUE rblapack_sr1;
  doublereal sr1; 
  VALUE rblapack_si1;
  doublereal si1; 
  VALUE rblapack_sr2;
  doublereal sr2; 
  VALUE rblapack_si2;
  doublereal si2; 
  VALUE rblapack_v;
  doublereal *v; 

  integer ldh;
  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  v = NumRu::Lapack.dlaqr1( h, sr1, si1, sr2, si2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V )\n\n*       Given a 2-by-2 or 3-by-3 matrix H, DLAQR1 sets v to a\n*       scalar multiple of the first column of the product\n*\n*       (*)  K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I)\n*\n*       scaling to avoid overflows and most underflows. It\n*       is assumed that either\n*\n*               1) sr1 = sr2 and si1 = -si2\n*           or\n*               2) si1 = si2 = 0.\n*\n*       This is useful for starting double implicit shift bulges\n*       in the QR algorithm.\n*\n*\n\n*       N      (input) integer\n*              Order of the matrix H. N must be either 2 or 3.\n*\n*       H      (input) DOUBLE PRECISION array of dimension (LDH,N)\n*              The 2-by-2 or 3-by-3 matrix H in (*).\n*\n*       LDH    (input) integer\n*              The leading dimension of H as declared in\n*              the calling procedure.  LDH.GE.N\n*\n*       SR1    (input) DOUBLE PRECISION\n*       SI1    The shifts in (*).\n*       SR2\n*       SI2\n*\n*       V      (output) DOUBLE PRECISION array of dimension N\n*              A scalar multiple of the first column of the\n*              matrix K in (*).\n*\n\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  v = NumRu::Lapack.dlaqr1( h, sr1, si1, sr2, si2, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_h = argv[0];
  rblapack_sr1 = argv[1];
  rblapack_si1 = argv[2];
  rblapack_sr2 = argv[3];
  rblapack_si2 = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (1th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (1th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_DFLOAT)
    rblapack_h = na_change_type(rblapack_h, NA_DFLOAT);
  h = NA_PTR_TYPE(rblapack_h, doublereal*);
  si1 = NUM2DBL(rblapack_si1);
  si2 = NUM2DBL(rblapack_si2);
  sr1 = NUM2DBL(rblapack_sr1);
  sr2 = NUM2DBL(rblapack_sr2);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_v = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  v = NA_PTR_TYPE(rblapack_v, doublereal*);

  dlaqr1_(&n, h, &ldh, &sr1, &si1, &sr2, &si2, v);

  return rblapack_v;
}

void
init_lapack_dlaqr1(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaqr1", rblapack_dlaqr1, -1);
}
ruby-lapack-1.7.2/ext/cla_porfsx_extended.c0000644000175000017500000005511612502221017020553 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cla_porfsx_extended_(integer* prec_type, char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, logical* colequ, real* c, complex* b, integer* ldb, complex* y, integer* ldy, real* berr_out, integer* n_norms, real* err_bnds_norm, real* err_bnds_comp, complex* res, real* ayb, complex* dy, complex* y_tail, real* rcond, integer* ithresh, real* rthresh, real* dz_ub, logical* ignore_cwise, integer* info);


static VALUE
rblapack_cla_porfsx_extended(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_prec_type;
  integer prec_type; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_colequ;
  logical colequ; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_y;
  complex *y; 
  VALUE rblapack_n_norms;
  integer n_norms; 
  VALUE rblapack_err_bnds_norm;
  real *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  real *err_bnds_comp; 
  VALUE rblapack_res;
  complex *res; 
  VALUE rblapack_ayb;
  real *ayb; 
  VALUE rblapack_dy;
  complex *dy; 
  VALUE rblapack_y_tail;
  complex *y_tail; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_ithresh;
  integer ithresh; 
  VALUE rblapack_rthresh;
  real rthresh; 
  VALUE rblapack_dz_ub;
  real dz_ub; 
  VALUE rblapack_ignore_cwise;
  logical ignore_cwise; 
  VALUE rblapack_berr_out;
  real *berr_out; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_y_out__;
  complex *y_out__;
  VALUE rblapack_err_bnds_norm_out__;
  real *err_bnds_norm_out__;
  VALUE rblapack_err_bnds_comp_out__;
  real *err_bnds_comp_out__;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldy;
  integer n_err_bnds;

  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  berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.cla_porfsx_extended( prec_type, uplo, a, af, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n*  Purpose\n*  =======\n*\n*  CLA_PORFSX_EXTENDED improves the computed solution to a system of\n*  linear equations by performing extra-precise iterative refinement\n*  and provides error bounds and backward error estimates for the solution.\n*  This subroutine is called by CPORFSX to perform iterative refinement.\n*  In addition to normwise error bound, the code provides maximum\n*  componentwise error bound if possible. See comments for ERR_BNDS_NORM\n*  and ERR_BNDS_COMP for details of the error bounds. Note that this\n*  subroutine is only resonsible for setting the second fields of\n*  ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n*  Arguments\n*  =========\n*\n*     PREC_TYPE      (input) INTEGER\n*     Specifies the intermediate precision to be used in refinement.\n*     The value is defined by ILAPREC(P) where P is a CHARACTER and\n*     P    = 'S':  Single\n*          = 'D':  Double\n*          = 'I':  Indigenous\n*          = 'X', 'E':  Extra\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N              (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NRHS           (input) INTEGER\n*     The number of right-hand-sides, i.e., the number of columns of the\n*     matrix B.\n*\n*     A              (input) COMPLEX array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA            (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF             (input) COMPLEX array, dimension (LDAF,N)\n*     The triangular factor U or L from the Cholesky factorization\n*     A = U**T*U or A = L*L**T, as computed by CPOTRF.\n*\n*     LDAF           (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     COLEQU         (input) LOGICAL\n*     If .TRUE. then column equilibration was done to A before calling\n*     this routine. This is needed to compute the solution and error\n*     bounds correctly.\n*\n*     C              (input) REAL array, dimension (N)\n*     The column scale factors for A. If COLEQU = .FALSE., C\n*     is not accessed. If C is input, each element of C should be a power\n*     of the radix to ensure a reliable solution and error estimates.\n*     Scaling by powers of the radix does not cause rounding errors unless\n*     the result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B              (input) COMPLEX array, dimension (LDB,NRHS)\n*     The right-hand-side matrix B.\n*\n*     LDB            (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     Y              (input/output) COMPLEX array, dimension\n*                    (LDY,NRHS)\n*     On entry, the solution matrix X, as computed by CPOTRS.\n*     On exit, the improved solution matrix Y.\n*\n*     LDY            (input) INTEGER\n*     The leading dimension of the array Y.  LDY >= max(1,N).\n*\n*     BERR_OUT       (output) REAL array, dimension (NRHS)\n*     On exit, BERR_OUT(j) contains the componentwise relative backward\n*     error for right-hand-side j from the formula\n*         max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n*     where abs(Z) is the componentwise absolute value of the matrix\n*     or vector Z. This is computed by CLA_LIN_BERR.\n*\n*     N_NORMS        (input) INTEGER\n*     Determines which error bounds to return (see ERR_BNDS_NORM\n*     and ERR_BNDS_COMP).\n*     If N_NORMS >= 1 return normwise error bounds.\n*     If N_NORMS >= 2 return componentwise error bounds.\n*\n*     ERR_BNDS_NORM  (input/output) REAL array, dimension\n*                    (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (input/output) REAL array, dimension\n*                    (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     RES            (input) COMPLEX array, dimension (N)\n*     Workspace to hold the intermediate residual.\n*\n*     AYB            (input) REAL array, dimension (N)\n*     Workspace.\n*\n*     DY             (input) COMPLEX array, dimension (N)\n*     Workspace to hold the intermediate solution.\n*\n*     Y_TAIL         (input) COMPLEX array, dimension (N)\n*     Workspace to hold the trailing bits of the intermediate solution.\n*\n*     RCOND          (input) REAL\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     ITHRESH        (input) INTEGER\n*     The maximum number of residual computations allowed for\n*     refinement. The default is 10. For 'aggressive' set to 100 to\n*     permit convergence using approximate factorizations or\n*     factorizations other than LU. If the factorization uses a\n*     technique other than Gaussian elimination, the guarantees in\n*     ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n*     RTHRESH        (input) REAL\n*     Determines when to stop refinement if the error estimate stops\n*     decreasing. Refinement will stop when the next solution no longer\n*     satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n*     the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n*     default value is 0.5. For 'aggressive' set to 0.9 to permit\n*     convergence on extremely ill-conditioned matrices. See LAWN 165\n*     for more details.\n*\n*     DZ_UB          (input) REAL\n*     Determines when to start considering componentwise convergence.\n*     Componentwise convergence is only considered after each component\n*     of the solution Y is stable, which we definte as the relative\n*     change in each component being less than DZ_UB. The default value\n*     is 0.25, requiring the first bit to be stable. See LAWN 165 for\n*     more details.\n*\n*     IGNORE_CWISE   (input) LOGICAL\n*     If .TRUE. then ignore componentwise convergence. Default value\n*     is .FALSE..\n*\n*     INFO           (output) INTEGER\n*       = 0:  Successful exit.\n*       < 0:  if INFO = -i, the ith argument to CPOTRS had an illegal\n*             value\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            UPLO2, CNT, I, J, X_STATE, Z_STATE,\n     $                   Y_PREC_STATE\n      REAL               YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n     $                   DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n     $                   DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n     $                   EPS, HUGEVAL, INCR_THRESH\n      LOGICAL            INCR_PREC\n      COMPLEX            ZDUM\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.cla_porfsx_extended( prec_type, uplo, a, af, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 20 && argc != 20)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 20)", argc);
  rblapack_prec_type = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_colequ = argv[4];
  rblapack_c = argv[5];
  rblapack_b = argv[6];
  rblapack_y = argv[7];
  rblapack_n_norms = argv[8];
  rblapack_err_bnds_norm = argv[9];
  rblapack_err_bnds_comp = argv[10];
  rblapack_res = argv[11];
  rblapack_ayb = argv[12];
  rblapack_dy = argv[13];
  rblapack_y_tail = argv[14];
  rblapack_rcond = argv[15];
  rblapack_ithresh = argv[16];
  rblapack_rthresh = argv[17];
  rblapack_dz_ub = argv[18];
  rblapack_ignore_cwise = argv[19];
  if (argc == 20) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  prec_type = NUM2INT(rblapack_prec_type);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  colequ = (rblapack_colequ == Qtrue);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  n_norms = NUM2INT(rblapack_n_norms);
  if (!NA_IsNArray(rblapack_err_bnds_comp))
    rb_raise(rb_eArgError, "err_bnds_comp (11th argument) must be NArray");
  if (NA_RANK(rblapack_err_bnds_comp) != 2)
    rb_raise(rb_eArgError, "rank of err_bnds_comp (11th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_err_bnds_comp) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of b");
  n_err_bnds = NA_SHAPE1(rblapack_err_bnds_comp);
  if (NA_TYPE(rblapack_err_bnds_comp) != NA_SFLOAT)
    rblapack_err_bnds_comp = na_change_type(rblapack_err_bnds_comp, NA_SFLOAT);
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
  if (!NA_IsNArray(rblapack_ayb))
    rb_raise(rb_eArgError, "ayb (13th argument) must be NArray");
  if (NA_RANK(rblapack_ayb) != 1)
    rb_raise(rb_eArgError, "rank of ayb (13th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ayb) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ayb) != NA_SFLOAT)
    rblapack_ayb = na_change_type(rblapack_ayb, NA_SFLOAT);
  ayb = NA_PTR_TYPE(rblapack_ayb, real*);
  if (!NA_IsNArray(rblapack_y_tail))
    rb_raise(rb_eArgError, "y_tail (15th argument) must be NArray");
  if (NA_RANK(rblapack_y_tail) != 1)
    rb_raise(rb_eArgError, "rank of y_tail (15th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y_tail) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_y_tail) != NA_SCOMPLEX)
    rblapack_y_tail = na_change_type(rblapack_y_tail, NA_SCOMPLEX);
  y_tail = NA_PTR_TYPE(rblapack_y_tail, complex*);
  ithresh = NUM2INT(rblapack_ithresh);
  dz_ub = (real)NUM2DBL(rblapack_dz_ub);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_err_bnds_norm))
    rb_raise(rb_eArgError, "err_bnds_norm (10th argument) must be NArray");
  if (NA_RANK(rblapack_err_bnds_norm) != 2)
    rb_raise(rb_eArgError, "rank of err_bnds_norm (10th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_err_bnds_norm) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of b");
  if (NA_SHAPE1(rblapack_err_bnds_norm) != n_err_bnds)
    rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_norm must be the same as shape 1 of err_bnds_comp");
  if (NA_TYPE(rblapack_err_bnds_norm) != NA_SFLOAT)
    rblapack_err_bnds_norm = na_change_type(rblapack_err_bnds_norm, NA_SFLOAT);
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
  if (!NA_IsNArray(rblapack_dy))
    rb_raise(rb_eArgError, "dy (14th argument) must be NArray");
  if (NA_RANK(rblapack_dy) != 1)
    rb_raise(rb_eArgError, "rank of dy (14th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dy) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_dy) != NA_SCOMPLEX)
    rblapack_dy = na_change_type(rblapack_dy, NA_SCOMPLEX);
  dy = NA_PTR_TYPE(rblapack_dy, complex*);
  rthresh = (real)NUM2DBL(rblapack_rthresh);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  if (!NA_IsNArray(rblapack_res))
    rb_raise(rb_eArgError, "res (12th argument) must be NArray");
  if (NA_RANK(rblapack_res) != 1)
    rb_raise(rb_eArgError, "rank of res (12th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_res) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_res) != NA_SCOMPLEX)
    rblapack_res = na_change_type(rblapack_res, NA_SCOMPLEX);
  res = NA_PTR_TYPE(rblapack_res, complex*);
  ignore_cwise = (rblapack_ignore_cwise == Qtrue);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (8th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 2)
    rb_raise(rb_eArgError, "rank of y (8th argument) must be %d", 2);
  ldy = NA_SHAPE0(rblapack_y);
  if (NA_SHAPE1(rblapack_y) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_y) != NA_SCOMPLEX)
    rblapack_y = na_change_type(rblapack_y, NA_SCOMPLEX);
  y = NA_PTR_TYPE(rblapack_y, complex*);
  rcond = (real)NUM2DBL(rblapack_rcond);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr_out = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr_out = NA_PTR_TYPE(rblapack_berr_out, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldy;
    shape[1] = nrhs;
    rblapack_y_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, complex*);
  MEMCPY(y_out__, y, complex, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm_out__ = NA_PTR_TYPE(rblapack_err_bnds_norm_out__, real*);
  MEMCPY(err_bnds_norm_out__, err_bnds_norm, real, NA_TOTAL(rblapack_err_bnds_norm));
  rblapack_err_bnds_norm = rblapack_err_bnds_norm_out__;
  err_bnds_norm = err_bnds_norm_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp_out__ = NA_PTR_TYPE(rblapack_err_bnds_comp_out__, real*);
  MEMCPY(err_bnds_comp_out__, err_bnds_comp, real, NA_TOTAL(rblapack_err_bnds_comp));
  rblapack_err_bnds_comp = rblapack_err_bnds_comp_out__;
  err_bnds_comp = err_bnds_comp_out__;

  cla_porfsx_extended_(&prec_type, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_err_bnds_norm, rblapack_err_bnds_comp);
}

void
init_lapack_cla_porfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cla_porfsx_extended", rblapack_cla_porfsx_extended, -1);
}
ruby-lapack-1.7.2/ext/dlaed4.c0000644000175000017500000001245412502221024015664 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaed4_(integer* n, integer* i, doublereal* d, doublereal* z, doublereal* delta, doublereal* rho, doublereal* dlam, integer* info);


static VALUE
rblapack_dlaed4(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_i;
  integer i; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_rho;
  doublereal rho; 
  VALUE rblapack_delta;
  doublereal *delta; 
  VALUE rblapack_dlam;
  doublereal dlam; 
  VALUE rblapack_info;
  integer info; 

  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  delta, dlam, info = NumRu::Lapack.dlaed4( i, d, z, rho, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO )\n\n*  Purpose\n*  =======\n*\n*  This subroutine computes the I-th updated eigenvalue of a symmetric\n*  rank-one modification to a diagonal matrix whose elements are\n*  given in the array d, and that\n*\n*             D(i) < D(j)  for  i < j\n*\n*  and that RHO > 0.  This is arranged by the calling routine, and is\n*  no loss in generality.  The rank-one modified system is thus\n*\n*             diag( D )  +  RHO *  Z * Z_transpose.\n*\n*  where we assume the Euclidean norm of Z is 1.\n*\n*  The method consists of approximating the rational functions in the\n*  secular equation by simpler interpolating rational functions.\n*\n\n*  Arguments\n*  =========\n*\n*  N      (input) INTEGER\n*         The length of all arrays.\n*\n*  I      (input) INTEGER\n*         The index of the eigenvalue to be computed.  1 <= I <= N.\n*\n*  D      (input) DOUBLE PRECISION array, dimension (N)\n*         The original eigenvalues.  It is assumed that they are in\n*         order, D(I) < D(J)  for I < J.\n*\n*  Z      (input) DOUBLE PRECISION array, dimension (N)\n*         The components of the updating vector.\n*\n*  DELTA  (output) DOUBLE PRECISION array, dimension (N)\n*         If N .GT. 2, DELTA contains (D(j) - lambda_I) in its  j-th\n*         component.  If N = 1, then DELTA(1) = 1. If N = 2, see DLAED5\n*         for detail. The vector DELTA contains the information necessary\n*         to construct the eigenvectors by DLAED3 and DLAED9.\n*\n*  RHO    (input) DOUBLE PRECISION\n*         The scalar in the symmetric updating formula.\n*\n*  DLAM   (output) DOUBLE PRECISION\n*         The computed lambda_I, the I-th updated eigenvalue.\n*\n*  INFO   (output) INTEGER\n*         = 0:  successful exit\n*         > 0:  if INFO = 1, the updating process failed.\n*\n*  Internal Parameters\n*  ===================\n*\n*  Logical variable ORGATI (origin-at-i?) is used for distinguishing\n*  whether D(i) or D(i+1) is treated as the origin.\n*\n*            ORGATI = .true.    origin at i\n*            ORGATI = .false.   origin at i+1\n*\n*   Logical variable SWTCH3 (switch-for-3-poles?) is for noting\n*   if we are working with THREE poles!\n*\n*   MAXIT is the maximum number of iterations allowed for each\n*   eigenvalue.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ren-Cang Li, Computer Science Division, University of California\n*     at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  delta, dlam, info = NumRu::Lapack.dlaed4( i, d, z, rho, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_i = argv[0];
  rblapack_d = argv[1];
  rblapack_z = argv[2];
  rblapack_rho = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  i = NUM2INT(rblapack_i);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (3th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 1)
    rb_raise(rb_eArgError, "rank of z (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 0 of z");
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  rho = NUM2DBL(rblapack_rho);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_delta = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  delta = NA_PTR_TYPE(rblapack_delta, doublereal*);

  dlaed4_(&n, &i, d, z, delta, &rho, &dlam, &info);

  rblapack_dlam = rb_float_new((double)dlam);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_delta, rblapack_dlam, rblapack_info);
}

void
init_lapack_dlaed4(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaed4", rblapack_dlaed4, -1);
}
ruby-lapack-1.7.2/ext/cpbsvx.c0000644000175000017500000004010712502221013016026 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cpbsvx_(char* fact, char* uplo, integer* n, integer* kd, integer* nrhs, complex* ab, integer* ldab, complex* afb, integer* ldafb, char* equed, real* s, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* ferr, real* berr, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cpbsvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_afb;
  complex *afb; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_s;
  real *s; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  complex *ab_out__;
  VALUE rblapack_afb_out__;
  complex *afb_out__;
  VALUE rblapack_s_out__;
  real *s_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;
  complex *work;
  real *rwork;

  integer ldab;
  integer n;
  integer ldafb;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, info, ab, afb, equed, s, b = NumRu::Lapack.cpbsvx( fact, uplo, kd, ab, afb, equed, s, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPBSVX uses the Cholesky factorization A = U**H*U or A = L*L**H to\n*  compute the solution to a complex system of linear equations\n*     A * X = B,\n*  where A is an N-by-N Hermitian positive definite band matrix and X\n*  and B are N-by-NRHS matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'E', real scaling factors are computed to equilibrate\n*     the system:\n*        diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(S)*A*diag(S) and B by diag(S)*B.\n*\n*  2. If FACT = 'N' or 'E', the Cholesky decomposition is used to\n*     factor the matrix A (after equilibration if FACT = 'E') as\n*        A = U**H * U,  if UPLO = 'U', or\n*        A = L * L**H,  if UPLO = 'L',\n*     where U is an upper triangular band matrix, and L is a lower\n*     triangular band matrix.\n*\n*  3. If the leading i-by-i principal minor is not positive definite,\n*     then the routine returns with INFO = i. Otherwise, the factored\n*     form of A is used to estimate the condition number of the matrix\n*     A.  If the reciprocal of the condition number is less than machine\n*     precision, INFO = N+1 is returned as a warning, but the routine\n*     still goes on to solve for X and compute error bounds as\n*     described below.\n*\n*  4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  5. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n*  6. If equilibration was used, the matrix X is premultiplied by\n*     diag(S) so that it solves the original system before\n*     equilibration.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of the matrix A is\n*          supplied on entry, and if not, whether the matrix A should be\n*          equilibrated before it is factored.\n*          = 'F':  On entry, AFB contains the factored form of A.\n*                  If EQUED = 'Y', the matrix A has been equilibrated\n*                  with scaling factors given by S.  AB and AFB will not\n*                  be modified.\n*          = 'N':  The matrix A will be copied to AFB and factored.\n*          = 'E':  The matrix A will be equilibrated if necessary, then\n*                  copied to AFB and factored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right-hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  AB      (input/output) COMPLEX array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the Hermitian band\n*          matrix A, stored in the first KD+1 rows of the array, except\n*          if FACT = 'F' and EQUED = 'Y', then A must contain the\n*          equilibrated matrix diag(S)*A*diag(S).  The j-th column of A\n*          is stored in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(N,j+KD).\n*          See below for further details.\n*\n*          On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by\n*          diag(S)*A*diag(S).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array A.  LDAB >= KD+1.\n*\n*  AFB     (input or output) COMPLEX array, dimension (LDAFB,N)\n*          If FACT = 'F', then AFB is an input argument and on entry\n*          contains the triangular factor U or L from the Cholesky\n*          factorization A = U**H*U or A = L*L**H of the band matrix\n*          A, in the same storage format as A (see AB).  If EQUED = 'Y',\n*          then AFB is the factored form of the equilibrated matrix A.\n*\n*          If FACT = 'N', then AFB is an output argument and on exit\n*          returns the triangular factor U or L from the Cholesky\n*          factorization A = U**H*U or A = L*L**H.\n*\n*          If FACT = 'E', then AFB is an output argument and on exit\n*          returns the triangular factor U or L from the Cholesky\n*          factorization A = U**H*U or A = L*L**H of the equilibrated\n*          matrix A (see the description of A for the form of the\n*          equilibrated matrix).\n*\n*  LDAFB   (input) INTEGER\n*          The leading dimension of the array AFB.  LDAFB >= KD+1.\n*\n*  EQUED   (input or output) CHARACTER*1\n*          Specifies the form of equilibration that was done.\n*          = 'N':  No equilibration (always true if FACT = 'N').\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*          EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*          output argument.\n*\n*  S       (input or output) REAL array, dimension (N)\n*          The scale factors for A; not accessed if EQUED = 'N'.  S is\n*          an input argument if FACT = 'F'; otherwise, S is an output\n*          argument.  If FACT = 'F' and EQUED = 'Y', each element of S\n*          must be positive.\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',\n*          B is overwritten by diag(S) * B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) COMPLEX array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to\n*          the original system of equations.  Note that if EQUED = 'Y',\n*          A and B are modified on exit, and the solution to the\n*          equilibrated system is inv(diag(S))*X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) REAL\n*          The estimate of the reciprocal condition number of the matrix\n*          A after equilibration (if done).  If RCOND is less than the\n*          machine precision (in particular, if RCOND = 0), the matrix\n*          is singular to working precision.  This condition is\n*          indicated by a return code of INFO > 0.\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) COMPLEX array, dimension (2*N)\n*\n*  RWORK   (workspace) REAL array, dimension (N)\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, and i is\n*                <= N:  the leading minor of order i of A is\n*                       not positive definite, so the factorization\n*                       could not be completed, and the solution has not\n*                       been computed. RCOND = 0 is returned.\n*                = N+1: U is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  N = 6, KD = 2, and UPLO = 'U':\n*\n*  Two-dimensional storage of the Hermitian matrix A:\n*\n*     a11  a12  a13\n*          a22  a23  a24\n*               a33  a34  a35\n*                    a44  a45  a46\n*                         a55  a56\n*     (aij=conjg(aji))         a66\n*\n*  Band storage of the upper triangle of A:\n*\n*      *    *   a13  a24  a35  a46\n*      *   a12  a23  a34  a45  a56\n*     a11  a22  a33  a44  a55  a66\n*\n*  Similarly, if UPLO = 'L' the format of A is as follows:\n*\n*     a11  a22  a33  a44  a55  a66\n*     a21  a32  a43  a54  a65   *\n*     a31  a42  a53  a64   *    *\n*\n*  Array elements marked * are not used by the routine.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, info, ab, afb, equed, s, b = NumRu::Lapack.cpbsvx( fact, uplo, kd, ab, afb, equed, s, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_kd = argv[2];
  rblapack_ab = argv[3];
  rblapack_afb = argv[4];
  rblapack_equed = argv[5];
  rblapack_s = argv[6];
  rblapack_b = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  kd = NUM2INT(rblapack_kd);
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
  ldafb = NA_SHAPE0(rblapack_afb);
  n = NA_SHAPE1(rblapack_afb);
  if (NA_TYPE(rblapack_afb) != NA_SCOMPLEX)
    rblapack_afb = na_change_type(rblapack_afb, NA_SCOMPLEX);
  afb = NA_PTR_TYPE(rblapack_afb, complex*);
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (7th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_s) != NA_SFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_SFLOAT);
  s = NA_PTR_TYPE(rblapack_s, real*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  ldx = MAX(1,n);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
  MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldafb;
    shape[1] = n;
    rblapack_afb_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  afb_out__ = NA_PTR_TYPE(rblapack_afb_out__, complex*);
  MEMCPY(afb_out__, afb, complex, NA_TOTAL(rblapack_afb));
  rblapack_afb = rblapack_afb_out__;
  afb = afb_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, real*);
  MEMCPY(s_out__, s, real, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (n));

  cpbsvx_(&fact, &uplo, &n, &kd, &nrhs, ab, &ldab, afb, &ldafb, &equed, s, b, &ldb, x, &ldx, &rcond, ferr, berr, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(10, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_ab, rblapack_afb, rblapack_equed, rblapack_s, rblapack_b);
}

void
init_lapack_cpbsvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cpbsvx", rblapack_cpbsvx, -1);
}
ruby-lapack-1.7.2/ext/dgerfsx.c0000644000175000017500000005304312502221015016170 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgerfsx_(char* trans, char* equed, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* af, integer* ldaf, integer* ipiv, doublereal* r, doublereal* c, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dgerfsx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_af;
  doublereal *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_r;
  doublereal *r; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_params;
  doublereal *params; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_err_bnds_norm;
  doublereal *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  doublereal *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  doublereal *x_out__;
  VALUE rblapack_params_out__;
  doublereal *params_out__;
  doublereal *work;
  integer *iwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;
  integer nparams;
  integer n_err_bnds;

  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  rcond, berr, err_bnds_norm, err_bnds_comp, info, x, params = NumRu::Lapack.dgerfsx( trans, equed, a, af, ipiv, r, c, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     DGERFSX improves the computed solution to a system of linear\n*     equations and provides error bounds and backward error estimates\n*     for the solution.  In addition to normwise error bound, the code\n*     provides maximum componentwise error bound if possible.  See\n*     comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the\n*     error bounds.\n*\n*     The original system of linear equations may have been equilibrated\n*     before calling this routine, as described by arguments EQUED, R\n*     and C below. In this case, the solution and error bounds returned\n*     are for the original unequilibrated system.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     TRANS   (input) CHARACTER*1\n*     Specifies the form of the system of equations:\n*       = 'N':  A * X = B     (No transpose)\n*       = 'T':  A**T * X = B  (Transpose)\n*       = 'C':  A**H * X = B  (Conjugate transpose = Transpose)\n*\n*     EQUED   (input) CHARACTER*1\n*     Specifies the form of equilibration that was done to A\n*     before calling this routine. This is needed to compute\n*     the solution and error bounds correctly.\n*       = 'N':  No equilibration\n*       = 'R':  Row equilibration, i.e., A has been premultiplied by\n*               diag(R).\n*       = 'C':  Column equilibration, i.e., A has been postmultiplied\n*               by diag(C).\n*       = 'B':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(R) * A * diag(C).\n*               The right hand side B has been changed accordingly.\n*\n*     N       (input) INTEGER\n*     The order of the matrix A.  N >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*     The original N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) DOUBLE PRECISION array, dimension (LDAF,N)\n*     The factors L and U from the factorization A = P*L*U\n*     as computed by DGETRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     The pivot indices from DGETRF; for 1<=i<=N, row i of the\n*     matrix was interchanged with row IPIV(i).\n*\n*     R       (input) DOUBLE PRECISION array, dimension (N)\n*     The row scale factors for A.  If EQUED = 'R' or 'B', A is\n*     multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n*     is not accessed.  \n*     If R is accessed, each element of R should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     C       (input) DOUBLE PRECISION array, dimension (N)\n*     The column scale factors for A.  If EQUED = 'C' or 'B', A is\n*     multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n*     is not accessed. \n*     If C is accessed, each element of C should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*     The right hand side matrix B.\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*     On entry, the solution matrix X, as computed by DGETRS.\n*     On exit, the improved solution matrix X.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) DOUBLE PRECISION\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*     Componentwise relative backward error.  This is the\n*     componentwise relative backward error of each solution vector X(j)\n*     (i.e., the smallest relative change in any element of A or B that\n*     makes X(j) an exact solution).\n*\n*     N_ERR_BNDS (input) INTEGER\n*     Number of error bounds to return for each right hand side\n*     and each type (normwise or componentwise).  See ERR_BNDS_NORM and\n*     ERR_BNDS_COMP below.\n*\n*     ERR_BNDS_NORM  (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * dlamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * dlamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * dlamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * dlamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * dlamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * dlamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     NPARAMS (input) INTEGER\n*     Specifies the number of parameters set in PARAMS.  If .LE. 0, the\n*     PARAMS array is never referenced and default values are used.\n*\n*     PARAMS  (input / output) DOUBLE PRECISION array, dimension (NPARAMS)\n*     Specifies algorithm parameters.  If an entry is .LT. 0.0, then\n*     that entry will be filled with default value used for that\n*     parameter.  Only positions up to NPARAMS are accessed; defaults\n*     are used for higher-numbered parameters.\n*\n*       PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n*            refinement or not.\n*         Default: 1.0D+0\n*            = 0.0 : No refinement is performed, and no error bounds are\n*                    computed.\n*            = 1.0 : Use the double-precision refinement algorithm,\n*                    possibly with doubled-single computations if the\n*                    compilation environment does not support DOUBLE\n*                    PRECISION.\n*              (other values are reserved for future use)\n*\n*       PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n*            computations allowed for refinement.\n*         Default: 10\n*         Aggressive: Set to 100 to permit convergence using approximate\n*                     factorizations or factorizations other than LU. If\n*                     the factorization uses a technique other than\n*                     Gaussian elimination, the guarantees in\n*                     err_bnds_norm and err_bnds_comp may no longer be\n*                     trustworthy.\n*\n*       PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n*            will attempt to find a solution with small componentwise\n*            relative error in the double-precision algorithm.  Positive\n*            is true, 0.0 is false.\n*         Default: 1.0 (attempt componentwise convergence)\n*\n*     WORK    (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n*     IWORK   (workspace) INTEGER array, dimension (N)\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit. The solution to every right-hand side is\n*         guaranteed.\n*       < 0:  If INFO = -i, the i-th argument had an illegal value\n*       > 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, berr, err_bnds_norm, err_bnds_comp, info, x, params = NumRu::Lapack.dgerfsx( trans, equed, a, af, ipiv, r, c, b, x, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_trans = argv[0];
  rblapack_equed = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_r = argv[5];
  rblapack_c = argv[6];
  rblapack_b = argv[7];
  rblapack_x = argv[8];
  rblapack_params = argv[9];
  if (argc == 10) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (7th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (9th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (9th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  n_err_bnds = 3;
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_r))
    rb_raise(rb_eArgError, "r (6th argument) must be NArray");
  if (NA_RANK(rblapack_r) != 1)
    rb_raise(rb_eArgError, "rank of r (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_r) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_r) != NA_DFLOAT)
    rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
  r = NA_PTR_TYPE(rblapack_r, doublereal*);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (10th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (10th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_DFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
  params = NA_PTR_TYPE(rblapack_params, doublereal*);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
  af = NA_PTR_TYPE(rblapack_af, doublereal*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (8th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (8th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
  MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(doublereal, (4*n));
  iwork = ALLOC_N(integer, (n));

  dgerfsx_(&trans, &equed, &n, &nrhs, a, &lda, af, &ldaf, ipiv, r, c, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_x, rblapack_params);
}

void
init_lapack_dgerfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgerfsx", rblapack_dgerfsx, -1);
}
ruby-lapack-1.7.2/ext/cpotrs.c0000644000175000017500000001020712502221013016031 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cpotrs_(char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, complex* b, integer* ldb, integer* info);


static VALUE
rblapack_cpotrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.cpotrs( uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPOTRS solves a system of linear equations A*X = B with a Hermitian\n*  positive definite matrix A using the Cholesky factorization \n*  A = U**H*U or A = L*L**H computed by CPOTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The triangular factor U or L from the Cholesky factorization\n*          A = U**H*U or A = L*L**H, as computed by CPOTRF.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.cpotrs( uplo, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_b = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  cpotrs_(&uplo, &n, &nrhs, a, &lda, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_cpotrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cpotrs", rblapack_cpotrs, -1);
}
ruby-lapack-1.7.2/ext/slansf.c0000644000175000017500000001714612502221020016014 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real slansf_(char* norm, char* transr, char* uplo, integer* n, real* a, real* work);


static VALUE
rblapack_slansf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack___out__;
  real __out__; 
  real *work;


  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  __out__ = NumRu::Lapack.slansf( norm, transr, uplo, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL FUNCTION SLANSF( NORM, TRANSR, UPLO, N, A, WORK )\n\n*  Purpose\n*  =======\n*\n*  SLANSF returns the value of the one norm, or the Frobenius norm, or\n*  the infinity norm, or the element of largest absolute value of a\n*  real symmetric matrix A in RFP format.\n*\n*  Description\n*  ===========\n*\n*  SLANSF returns the value\n*\n*     SLANSF = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a  matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in SLANSF as described\n*          above.\n*\n*  TRANSR  (input) CHARACTER*1\n*          Specifies whether the RFP format of A is normal or\n*          transposed format.\n*          = 'N':  RFP format is Normal;\n*          = 'T':  RFP format is Transpose.\n*\n*  UPLO    (input) CHARACTER*1\n*           On entry, UPLO specifies whether the RFP matrix A came from\n*           an upper or lower triangular matrix as follows:\n*           = 'U': RFP A came from an upper triangular matrix;\n*           = 'L': RFP A came from a lower triangular matrix.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0. When N = 0, SLANSF is\n*          set to zero.\n*\n*  A       (input) REAL array, dimension ( N*(N+1)/2 );\n*          On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')\n*          part of the symmetric matrix A stored in RFP format. See the\n*          \"Notes\" below for more details.\n*          Unchanged on exit.\n*\n*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n*          WORK is not referenced.\n*\n\n*  Further Details\n*  ===============\n*\n*  We first consider Rectangular Full Packed (RFP) Format when N is\n*  even. We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  the transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  the transpose of the last three columns of AP lower.\n*  This covers the case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        03 04 05                33 43 53\n*        13 14 15                00 44 54\n*        23 24 25                10 11 55\n*        33 34 35                20 21 22\n*        00 44 45                30 31 32\n*        01 11 55                40 41 42\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We then consider Rectangular Full Packed (RFP) Format when N is\n*  odd. We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  the transpose of the first two columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  the transpose of the last two columns of AP lower.\n*  This covers the case N odd and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        02 03 04                00 33 43\n*        12 13 14                10 11 44\n*        22 23 24                20 21 22\n*        00 33 34                30 31 32\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*           RFP A                   RFP A\n*\n*     02 12 22 00 01             00 10 20 30 40 50\n*     03 13 23 33 11             33 11 21 31 41 51\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  Reference\n*  =========\n*\n*  =====================================================================\n*\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.slansf( norm, transr, uplo, n, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_norm = argv[0];
  rblapack_transr = argv[1];
  rblapack_uplo = argv[2];
  rblapack_n = argv[3];
  rblapack_a = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  transr = StringValueCStr(rblapack_transr)[0];
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 1)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  work = ALLOC_N(real, (MAX(1,(lsame_(&norm,"I")||lsame_(&norm,"1")||lsame_(&norm,"o")) ? n : 0)));

  __out__ = slansf_(&norm, &transr, &uplo, &n, a, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_slansf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slansf", rblapack_slansf, -1);
}
ruby-lapack-1.7.2/ext/clapll.c0000644000175000017500000001102312502221020015761 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clapll_(integer* n, complex* x, integer* incx, complex* y, integer* incy, real* ssmin);


static VALUE
rblapack_clapll(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_y;
  complex *y; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_ssmin;
  real ssmin; 
  VALUE rblapack_x_out__;
  complex *x_out__;
  VALUE rblapack_y_out__;
  complex *y_out__;


  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  ssmin, x, y = NumRu::Lapack.clapll( n, x, incx, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAPLL( N, X, INCX, Y, INCY, SSMIN )\n\n*  Purpose\n*  =======\n*\n*  Given two column vectors X and Y, let\n*\n*                       A = ( X Y ).\n*\n*  The subroutine first computes the QR factorization of A = Q*R,\n*  and then computes the SVD of the 2-by-2 upper triangular matrix R.\n*  The smaller singular value of R is returned in SSMIN, which is used\n*  as the measurement of the linear dependency of the vectors X and Y.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The length of the vectors X and Y.\n*\n*  X       (input/output) COMPLEX array, dimension (1+(N-1)*INCX)\n*          On entry, X contains the N-vector X.\n*          On exit, X is overwritten.\n*\n*  INCX    (input) INTEGER\n*          The increment between successive elements of X. INCX > 0.\n*\n*  Y       (input/output) COMPLEX array, dimension (1+(N-1)*INCY)\n*          On entry, Y contains the N-vector Y.\n*          On exit, Y is overwritten.\n*\n*  INCY    (input) INTEGER\n*          The increment between successive elements of Y. INCY > 0.\n*\n*  SSMIN   (output) REAL\n*          The smallest singular value of the N-by-2 matrix A = ( X Y ).\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ssmin, x, y = NumRu::Lapack.clapll( n, x, incx, y, incy, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_n = argv[0];
  rblapack_x = argv[1];
  rblapack_incx = argv[2];
  rblapack_y = argv[3];
  rblapack_incy = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  n = NUM2INT(rblapack_n);
  incx = NUM2INT(rblapack_incx);
  incy = NUM2INT(rblapack_incy);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (2th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1+(n-1)*incx))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1+(n-1)*incx);
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (4th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (1+(n-1)*incy))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1+(n-1)*incy);
  if (NA_TYPE(rblapack_y) != NA_SCOMPLEX)
    rblapack_y = na_change_type(rblapack_y, NA_SCOMPLEX);
  y = NA_PTR_TYPE(rblapack_y, complex*);
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incx;
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = 1+(n-1)*incy;
    rblapack_y_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, complex*);
  MEMCPY(y_out__, y, complex, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  clapll_(&n, x, &incx, y, &incy, &ssmin);

  rblapack_ssmin = rb_float_new((double)ssmin);
  return rb_ary_new3(3, rblapack_ssmin, rblapack_x, rblapack_y);
}

void
init_lapack_clapll(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clapll", rblapack_clapll, -1);
}
ruby-lapack-1.7.2/ext/dtfsm.c0000644000175000017500000002474412502221024015651 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtfsm_(char* transr, char* side, char* uplo, char* trans, char* diag, integer* m, integer* n, doublereal* alpha, doublereal* a, doublereal* b, integer* ldb);


static VALUE
rblapack_dtfsm(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_alpha;
  doublereal alpha; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_b_out__;
  doublereal *b_out__;

  integer nt;
  integer ldb;
  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  b = NumRu::Lapack.dtfsm( transr, side, uplo, trans, diag, m, alpha, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, B, LDB )\n\n*  Purpose\n*  =======\n*\n*  Level 3 BLAS like routine for A in RFP Format.\n*\n*  DTFSM  solves the matrix equation\n*\n*     op( A )*X = alpha*B  or  X*op( A ) = alpha*B\n*\n*  where alpha is a scalar, X and B are m by n matrices, A is a unit, or\n*  non-unit,  upper or lower triangular matrix  and  op( A )  is one  of\n*\n*     op( A ) = A   or   op( A ) = A'.\n*\n*  A is in Rectangular Full Packed (RFP) Format.\n*\n*  The matrix X is overwritten on B.\n*\n\n*  Arguments\n*  ==========\n*\n*  TRANSR  (input) CHARACTER*1\n*          = 'N':  The Normal Form of RFP A is stored;\n*          = 'T':  The Transpose Form of RFP A is stored.\n*\n*  SIDE    (input) CHARACTER*1\n*           On entry, SIDE specifies whether op( A ) appears on the left\n*           or right of X as follows:\n*\n*              SIDE = 'L' or 'l'   op( A )*X = alpha*B.\n*\n*              SIDE = 'R' or 'r'   X*op( A ) = alpha*B.\n*\n*           Unchanged on exit.\n*\n*  UPLO    (input) CHARACTER*1\n*           On entry, UPLO specifies whether the RFP matrix A came from\n*           an upper or lower triangular matrix as follows:\n*           UPLO = 'U' or 'u' RFP A came from an upper triangular matrix\n*           UPLO = 'L' or 'l' RFP A came from a  lower triangular matrix\n*\n*           Unchanged on exit.\n*\n*  TRANS   (input) CHARACTER*1\n*           On entry, TRANS  specifies the form of op( A ) to be used\n*           in the matrix multiplication as follows:\n*\n*              TRANS  = 'N' or 'n'   op( A ) = A.\n*\n*              TRANS  = 'T' or 't'   op( A ) = A'.\n*\n*           Unchanged on exit.\n*\n*  DIAG    (input) CHARACTER*1\n*           On entry, DIAG specifies whether or not RFP A is unit\n*           triangular as follows:\n*\n*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.\n*\n*              DIAG = 'N' or 'n'   A is not assumed to be unit\n*                                  triangular.\n*\n*           Unchanged on exit.\n*\n*  M       (input) INTEGER\n*           On entry, M specifies the number of rows of B. M must be at\n*           least zero.\n*           Unchanged on exit.\n*\n*  N       (input) INTEGER\n*           On entry, N specifies the number of columns of B.  N must be\n*           at least zero.\n*           Unchanged on exit.\n*\n*  ALPHA   (input) DOUBLE PRECISION\n*           On entry,  ALPHA specifies the scalar  alpha. When  alpha is\n*           zero then  A is not referenced and  B need not be set before\n*           entry.\n*           Unchanged on exit.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (NT)\n*           NT = N*(N+1)/2. On entry, the matrix A in RFP Format.\n*           RFP Format is described by TRANSR, UPLO and N as follows:\n*           If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;\n*           K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If\n*           TRANSR = 'T' then RFP is the transpose of RFP A as\n*           defined when TRANSR = 'N'. The contents of RFP A are defined\n*           by UPLO as follows: If UPLO = 'U' the RFP A contains the NT\n*           elements of upper packed A either in normal or\n*           transpose Format. If UPLO = 'L' the RFP A contains\n*           the NT elements of lower packed A either in normal or\n*           transpose Format. The LDA of RFP A is (N+1)/2 when\n*           TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is\n*           even and is N when is odd.\n*           See the Note below for more details. Unchanged on exit.\n*\n*  B       (input/output) DOUBLE PRECISION array,  dimension (LDB,N)\n*           Before entry,  the leading  m by n part of the array  B must\n*           contain  the  right-hand  side  matrix  B,  and  on exit  is\n*           overwritten by the solution matrix  X.\n*\n*  LDB     (input) INTEGER\n*           On entry, LDB specifies the first dimension of B as declared\n*           in  the  calling  (sub)  program.   LDB  must  be  at  least\n*           max( 1, m ).\n*           Unchanged on exit.\n*\n\n*  Further Details\n*  ===============\n*\n*  We first consider Rectangular Full Packed (RFP) Format when N is\n*  even. We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  the transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  the transpose of the last three columns of AP lower.\n*  This covers the case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        03 04 05                33 43 53\n*        13 14 15                00 44 54\n*        23 24 25                10 11 55\n*        33 34 35                20 21 22\n*        00 44 45                30 31 32\n*        01 11 55                40 41 42\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We then consider Rectangular Full Packed (RFP) Format when N is\n*  odd. We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  the transpose of the first two columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  the transpose of the last two columns of AP lower.\n*  This covers the case N odd and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*        02 03 04                00 33 43\n*        12 13 14                10 11 44\n*        22 23 24                20 21 22\n*        00 33 34                30 31 32\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the\n*  transpose of RFP A above. One therefore gets:\n*\n*           RFP A                   RFP A\n*\n*     02 12 22 00 01             00 10 20 30 40 50\n*     03 13 23 33 11             33 11 21 31 41 51\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  Reference\n*  =========\n*\n*  =====================================================================\n*\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  b = NumRu::Lapack.dtfsm( transr, side, uplo, trans, diag, m, alpha, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_transr = argv[0];
  rblapack_side = argv[1];
  rblapack_uplo = argv[2];
  rblapack_trans = argv[3];
  rblapack_diag = argv[4];
  rblapack_m = argv[5];
  rblapack_alpha = argv[6];
  rblapack_a = argv[7];
  rblapack_b = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  transr = StringValueCStr(rblapack_transr)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  alpha = NUM2DBL(rblapack_alpha);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (9th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (9th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = 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*);
  side = StringValueCStr(rblapack_side)[0];
  m = NUM2INT(rblapack_m);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (8th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 1)
    rb_raise(rb_eArgError, "rank of a (8th argument) must be %d", 1);
  nt = NA_SHAPE0(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*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dtfsm_(&transr, &side, &uplo, &trans, &diag, &m, &n, &alpha, a, b, &ldb);

  return rblapack_b;
}

void
init_lapack_dtfsm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtfsm", rblapack_dtfsm, -1);
}
ruby-lapack-1.7.2/ext/dla_gbrpvgrw.c0000644000175000017500000001146712502221016017213 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal dla_gbrpvgrw_(integer* n, integer* kl, integer* ku, integer* ncols, doublereal* ab, integer* ldab, doublereal* afb, integer* ldafb);


static VALUE
rblapack_dla_gbrpvgrw(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ncols;
  integer ncols; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_afb;
  doublereal *afb; 
  VALUE rblapack___out__;
  doublereal __out__; 

  integer ldab;
  integer n;
  integer ldafb;

  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  __out__ = NumRu::Lapack.dla_gbrpvgrw( kl, ku, ncols, ab, afb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION DLA_GBRPVGRW( N, KL, KU, NCOLS, AB, LDAB, AFB, LDAFB )\n\n*  Purpose\n*  =======\n*\n*  DLA_GBRPVGRW computes the reciprocal pivot growth factor\n*  norm(A)/norm(U). The \"max absolute element\" norm is used. If this is\n*  much less than 1, the stability of the LU factorization of the\n*  (equilibrated) matrix A could be poor. This also means that the\n*  solution X, estimated condition numbers, and error bounds could be\n*  unreliable.\n*\n\n*  Arguments\n*  =========\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     KL      (input) INTEGER\n*     The number of subdiagonals within the band of A.  KL >= 0.\n*\n*     KU      (input) INTEGER\n*     The number of superdiagonals within the band of A.  KU >= 0.\n*\n*     NCOLS   (input) INTEGER\n*     The number of columns of the matrix A.  NCOLS >= 0.\n*\n*     AB      (input) DOUBLE PRECISION array, dimension (LDAB,N)\n*     On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n*     The j-th column of A is stored in the j-th column of the\n*     array AB as follows:\n*     AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n*     LDAB    (input) INTEGER\n*     The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*     AFB     (input) DOUBLE PRECISION array, dimension (LDAFB,N)\n*     Details of the LU factorization of the band matrix A, as\n*     computed by DGBTRF.  U is stored as an upper triangular\n*     band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n*     and the multipliers used during the factorization are stored\n*     in rows KL+KU+2 to 2*KL+KU+1.\n*\n*     LDAFB   (input) INTEGER\n*     The leading dimension of the array AFB.  LDAFB >= 2*KL+KU+1.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J, KD\n      DOUBLE PRECISION   AMAX, UMAX, RPVGRW\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.dla_gbrpvgrw( kl, ku, ncols, ab, afb, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_kl = argv[0];
  rblapack_ku = argv[1];
  rblapack_ncols = argv[2];
  rblapack_ab = argv[3];
  rblapack_afb = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  kl = NUM2INT(rblapack_kl);
  ncols = NUM2INT(rblapack_ncols);
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (5th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (5th argument) must be %d", 2);
  ldafb = NA_SHAPE0(rblapack_afb);
  n = NA_SHAPE1(rblapack_afb);
  if (NA_TYPE(rblapack_afb) != NA_DFLOAT)
    rblapack_afb = na_change_type(rblapack_afb, NA_DFLOAT);
  afb = NA_PTR_TYPE(rblapack_afb, doublereal*);
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 1 of afb");
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);

  __out__ = dla_gbrpvgrw_(&n, &kl, &ku, &ncols, ab, &ldab, afb, &ldafb);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_dla_gbrpvgrw(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dla_gbrpvgrw", rblapack_dla_gbrpvgrw, -1);
}
ruby-lapack-1.7.2/ext/sorghr.c0000644000175000017500000001261112502221026016030 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sorghr_(integer* n, integer* ilo, integer* ihi, real* a, integer* lda, real* tau, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sorghr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *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  work, info, a = NumRu::Lapack.sorghr( ilo, ihi, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SORGHR generates a real orthogonal matrix Q which is defined as the\n*  product of IHI-ILO elementary reflectors of order N, as returned by\n*  SGEHRD:\n*\n*  Q = H(ilo) H(ilo+1) . . . H(ihi-1).\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix Q. N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          ILO and IHI must have the same values as in the previous call\n*          of SGEHRD. Q is equal to the unit matrix except in the\n*          submatrix Q(ilo+1:ihi,ilo+1:ihi).\n*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the vectors which define the elementary reflectors,\n*          as returned by SGEHRD.\n*          On exit, the N-by-N orthogonal matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  TAU     (input) REAL array, dimension (N-1)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by SGEHRD.\n*\n*  WORK    (workspace/output) REAL 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 >= IHI-ILO.\n*          For optimum performance LWORK >= (IHI-ILO)*NB, where NB is\n*          the 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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, a = NumRu::Lapack.sorghr( ilo, ihi, a, tau, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_ilo = argv[0];
  rblapack_ihi = argv[1];
  rblapack_a = argv[2];
  rblapack_tau = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  ihi = NUM2INT(rblapack_ihi);
  if (rblapack_lwork == Qnil)
    lwork = ihi-ilo;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (4th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_tau) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of tau must be %d", n-1);
  if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  sorghr_(&n, &ilo, &ihi, a, &lda, tau, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_a);
}

void
init_lapack_sorghr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sorghr", rblapack_sorghr, -1);
}
ruby-lapack-1.7.2/ext/dlatrs.c0000644000175000017500000002474312502221015016024 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlatrs_(char* uplo, char* trans, char* diag, char* normin, integer* n, doublereal* a, integer* lda, doublereal* x, doublereal* scale, doublereal* cnorm, integer* info);


static VALUE
rblapack_dlatrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_normin;
  char normin; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_cnorm;
  doublereal *cnorm; 
  VALUE rblapack_scale;
  doublereal scale; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  doublereal *x_out__;
  VALUE rblapack_cnorm_out__;
  doublereal *cnorm_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  scale, info, x, cnorm = NumRu::Lapack.dlatrs( uplo, trans, diag, normin, a, x, cnorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, CNORM, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLATRS solves one of the triangular systems\n*\n*     A *x = s*b  or  A'*x = s*b\n*\n*  with scaling to prevent overflow.  Here A is an upper or lower\n*  triangular matrix, A' denotes the transpose of A, x and b are\n*  n-element vectors, and s is a scaling factor, usually less than\n*  or equal to 1, chosen so that the components of x will be less than\n*  the overflow threshold.  If the unscaled problem will not cause\n*  overflow, the Level 2 BLAS routine DTRSV is called.  If the matrix A\n*  is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n*  non-trivial solution to A*x = 0 is returned.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the matrix A is upper or lower triangular.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the operation applied to A.\n*          = 'N':  Solve A * x = s*b  (No transpose)\n*          = 'T':  Solve A'* x = s*b  (Transpose)\n*          = 'C':  Solve A'* x = s*b  (Conjugate transpose = Transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          Specifies whether or not the matrix A is unit triangular.\n*          = 'N':  Non-unit triangular\n*          = 'U':  Unit triangular\n*\n*  NORMIN  (input) CHARACTER*1\n*          Specifies whether CNORM has been set or not.\n*          = 'Y':  CNORM contains the column norms on entry\n*          = 'N':  CNORM is not set on entry.  On exit, the norms will\n*                  be computed and stored in CNORM.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*          The triangular matrix A.  If UPLO = 'U', the leading n by n\n*          upper triangular part of the array A contains the upper\n*          triangular matrix, and the strictly lower triangular part of\n*          A is not referenced.  If UPLO = 'L', the leading n by n lower\n*          triangular part of the array A contains the lower triangular\n*          matrix, and the strictly upper triangular part of A is not\n*          referenced.  If DIAG = 'U', the diagonal elements of A are\n*          also not referenced and are assumed to be 1.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max (1,N).\n*\n*  X       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the right hand side b of the triangular system.\n*          On exit, X is overwritten by the solution vector x.\n*\n*  SCALE   (output) DOUBLE PRECISION\n*          The scaling factor s for the triangular system\n*             A * x = s*b  or  A'* x = s*b.\n*          If SCALE = 0, the matrix A is singular or badly scaled, and\n*          the vector x is an exact or approximate solution to A*x = 0.\n*\n*  CNORM   (input or output) DOUBLE PRECISION array, dimension (N)\n*\n*          If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n*          contains the norm of the off-diagonal part of the j-th column\n*          of A.  If TRANS = 'N', CNORM(j) must be greater than or equal\n*          to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n*          must be greater than or equal to the 1-norm.\n*\n*          If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n*          returns the 1-norm of the offdiagonal part of the j-th column\n*          of A.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -k, the k-th argument had an illegal value\n*\n\n*  Further Details\n*  ======= =======\n*\n*  A rough bound on x is computed; if that is less than overflow, DTRSV\n*  is called, otherwise, specific code is used which checks for possible\n*  overflow or divide-by-zero at every operation.\n*\n*  A columnwise scheme is used for solving A*x = b.  The basic algorithm\n*  if A is lower triangular is\n*\n*       x[1:n] := b[1:n]\n*       for j = 1, ..., n\n*            x(j) := x(j) / A(j,j)\n*            x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n*       end\n*\n*  Define bounds on the components of x after j iterations of the loop:\n*     M(j) = bound on x[1:j]\n*     G(j) = bound on x[j+1:n]\n*  Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n*  Then for iteration j+1 we have\n*     M(j+1) <= G(j) / | A(j+1,j+1) |\n*     G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n*            <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n*  where CNORM(j+1) is greater than or equal to the infinity-norm of\n*  column j+1 of A, not counting the diagonal.  Hence\n*\n*     G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n*                  1<=i<=j\n*  and\n*\n*     |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n*                                   1<=i< j\n*\n*  Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTRSV if the\n*  reciprocal of the largest M(j), j=1,..,n, is larger than\n*  max(underflow, 1/overflow).\n*\n*  The bound on x(j) is also used to determine when a step in the\n*  columnwise method can be performed without fear of overflow.  If\n*  the computed bound is greater than a large constant, x is scaled to\n*  prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n*  1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n*  Similarly, a row-wise scheme is used to solve A'*x = b.  The basic\n*  algorithm for A upper triangular is\n*\n*       for j = 1, ..., n\n*            x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n*       end\n*\n*  We simultaneously compute two bounds\n*       G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n*       M(j) = bound on x(i), 1<=i<=j\n*\n*  The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n*  add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n*  Then the bound on x(j) is\n*\n*       M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n*            <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n*                      1<=i<=j\n*\n*  and we can safely call DTRSV if 1/M(n) and 1/G(n) are both greater\n*  than max(underflow, 1/overflow).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, info, x, cnorm = NumRu::Lapack.dlatrs( uplo, trans, diag, normin, a, x, cnorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_normin = argv[3];
  rblapack_a = argv[4];
  rblapack_x = argv[5];
  rblapack_cnorm = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th 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*);
  if (!NA_IsNArray(rblapack_cnorm))
    rb_raise(rb_eArgError, "cnorm (7th argument) must be NArray");
  if (NA_RANK(rblapack_cnorm) != 1)
    rb_raise(rb_eArgError, "rank of cnorm (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_cnorm) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of cnorm must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_cnorm) != NA_DFLOAT)
    rblapack_cnorm = na_change_type(rblapack_cnorm, NA_DFLOAT);
  cnorm = NA_PTR_TYPE(rblapack_cnorm, doublereal*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  normin = StringValueCStr(rblapack_normin)[0];
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_cnorm_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  cnorm_out__ = NA_PTR_TYPE(rblapack_cnorm_out__, doublereal*);
  MEMCPY(cnorm_out__, cnorm, doublereal, NA_TOTAL(rblapack_cnorm));
  rblapack_cnorm = rblapack_cnorm_out__;
  cnorm = cnorm_out__;

  dlatrs_(&uplo, &trans, &diag, &normin, &n, a, &lda, x, &scale, cnorm, &info);

  rblapack_scale = rb_float_new((double)scale);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_scale, rblapack_info, rblapack_x, rblapack_cnorm);
}

void
init_lapack_dlatrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlatrs", rblapack_dlatrs, -1);
}
ruby-lapack-1.7.2/ext/ctzrzf.c0000644000175000017500000001410112502221021016035 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctzrzf_(integer* m, integer* n, complex* a, integer* lda, complex* tau, complex* work, integer* lwork, integer* info);


static VALUE
rblapack_ctzrzf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;

  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, work, info, a = NumRu::Lapack.ctzrzf( a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTZRZF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A\n*  to upper triangular form by means of unitary transformations.\n*\n*  The upper trapezoidal matrix A is factored as\n*\n*     A = ( R  0 ) * Z,\n*\n*  where Z is an N-by-N unitary matrix and R is an M-by-M upper\n*  triangular matrix.\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 >= M.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the leading M-by-N upper trapezoidal part of the\n*          array A must contain the matrix to be factorized.\n*          On exit, the leading M-by-M upper triangular part of A\n*          contains the upper triangular matrix R, and elements M+1 to\n*          N of the first M rows of A, with the array TAU, represent the\n*          unitary matrix Z as a product of M elementary reflectors.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  TAU     (output) COMPLEX array, dimension (M)\n*          The scalar factors of the elementary reflectors.\n*\n*  WORK    (workspace/output) COMPLEX 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\n*          the 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*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n*  The factorization is obtained by Householder's method.  The kth\n*  transformation matrix, Z( k ), which is used to introduce zeros into\n*  the ( m - k + 1 )th row of A, is given in the form\n*\n*     Z( k ) = ( I     0   ),\n*              ( 0  T( k ) )\n*\n*  where\n*\n*     T( k ) = I - tau*u( k )*u( k )',   u( k ) = (   1    ),\n*                                                 (   0    )\n*                                                 ( z( k ) )\n*\n*  tau is a scalar and z( k ) is an ( n - m ) element vector.\n*  tau and z( k ) are chosen to annihilate the elements of the kth row\n*  of X.\n*\n*  The scalar tau is returned in the kth element of TAU and the vector\n*  u( k ) in the kth row of A, such that the elements of z( k ) are\n*  in  a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n*  the upper triangular part of A.\n*\n*  Z is given by\n*\n*     Z =  Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, work, info, a = NumRu::Lapack.ctzrzf( a, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 1 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
  rblapack_a = argv[0];
  if (argc == 2) {
    rblapack_lwork = argv[1];
  } 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 (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_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  m = lda;
  if (rblapack_lwork == Qnil)
    lwork = m;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  ctzrzf_(&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_ctzrzf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctzrzf", rblapack_ctzrzf, -1);
}
ruby-lapack-1.7.2/ext/dtrtri.c0000644000175000017500000001013312502221024016027 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dtrtri_(char* uplo, char* diag, integer* n, doublereal* a, integer* lda, integer* info);


static VALUE
rblapack_dtrtri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_a;
  doublereal *a; 
  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  info, a = NumRu::Lapack.dtrtri( uplo, diag, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO )\n\n*  Purpose\n*  =======\n*\n*  DTRTRI computes the inverse of a real upper or lower triangular\n*  matrix A.\n*\n*  This is the Level 3 BLAS version of the algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the triangular matrix A.  If UPLO = 'U', the\n*          leading N-by-N upper triangular part of the array A contains\n*          the upper triangular matrix, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of the array A contains\n*          the lower triangular matrix, and the strictly upper\n*          triangular part of A is not referenced.  If DIAG = 'U', the\n*          diagonal elements of A are also not referenced and are\n*          assumed to be 1.\n*          On exit, the (triangular) inverse of the original matrix, in\n*          the same storage format.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\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, A(i,i) is exactly zero.  The triangular\n*               matrix is singular and its inverse can not be computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.dtrtri( uplo, diag, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_diag = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  diag = StringValueCStr(rblapack_diag)[0];
  {
    na_shape_t 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__;

  dtrtri_(&uplo, &diag, &n, a, &lda, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_dtrtri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dtrtri", rblapack_dtrtri, -1);
}
ruby-lapack-1.7.2/ext/sgtrfs.c0000644000175000017500000002641612502221017016044 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgtrfs_(char* trans, integer* n, integer* nrhs, real* dl, real* d, real* du, real* dlf, real* df, real* duf, real* du2, integer* ipiv, real* b, integer* ldb, real* x, integer* ldx, real* ferr, real* berr, real* work, integer* iwork, integer* info);


static VALUE
rblapack_sgtrfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_dl;
  real *dl; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_du;
  real *du; 
  VALUE rblapack_dlf;
  real *dlf; 
  VALUE rblapack_df;
  real *df; 
  VALUE rblapack_duf;
  real *duf; 
  VALUE rblapack_du2;
  real *du2; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  real *x_out__;
  real *work;
  integer *iwork;

  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.sgtrfs( trans, dl, d, du, dlf, df, duf, du2, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGTRFS improves the computed solution to a system of linear\n*  equations when the coefficient matrix is tridiagonal, and provides\n*  error bounds and backward error estimates for the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  DL      (input) REAL array, dimension (N-1)\n*          The (n-1) subdiagonal elements of A.\n*\n*  D       (input) REAL array, dimension (N)\n*          The diagonal elements of A.\n*\n*  DU      (input) REAL array, dimension (N-1)\n*          The (n-1) superdiagonal elements of A.\n*\n*  DLF     (input) REAL array, dimension (N-1)\n*          The (n-1) multipliers that define the matrix L from the\n*          LU factorization of A as computed by SGTTRF.\n*\n*  DF      (input) REAL array, dimension (N)\n*          The n diagonal elements of the upper triangular matrix U from\n*          the LU factorization of A.\n*\n*  DUF     (input) REAL array, dimension (N-1)\n*          The (n-1) elements of the first superdiagonal of U.\n*\n*  DU2     (input) REAL array, dimension (N-2)\n*          The (n-2) elements of the second superdiagonal of U.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices; for 1 <= i <= n, row i of the matrix was\n*          interchanged with row IPIV(i).  IPIV(i) will always be either\n*          i or i+1; IPIV(i) = i indicates a row interchange was not\n*          required.\n*\n*  B       (input) REAL array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) REAL array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by SGTTRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) REAL array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.sgtrfs( trans, dl, d, du, dlf, df, duf, du2, ipiv, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 11 && argc != 11)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
  rblapack_trans = argv[0];
  rblapack_dl = argv[1];
  rblapack_d = argv[2];
  rblapack_du = argv[3];
  rblapack_dlf = argv[4];
  rblapack_df = argv[5];
  rblapack_duf = argv[6];
  rblapack_du2 = argv[7];
  rblapack_ipiv = argv[8];
  rblapack_b = argv[9];
  rblapack_x = argv[10];
  if (argc == 11) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_df))
    rb_raise(rb_eArgError, "df (6th argument) must be NArray");
  if (NA_RANK(rblapack_df) != 1)
    rb_raise(rb_eArgError, "rank of df (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_df) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of df must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_df) != NA_SFLOAT)
    rblapack_df = na_change_type(rblapack_df, NA_SFLOAT);
  df = NA_PTR_TYPE(rblapack_df, real*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (9th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (11th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (11th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  nrhs = NA_SHAPE1(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_SFLOAT)
    rblapack_dl = na_change_type(rblapack_dl, NA_SFLOAT);
  dl = NA_PTR_TYPE(rblapack_dl, real*);
  if (!NA_IsNArray(rblapack_dlf))
    rb_raise(rb_eArgError, "dlf (5th argument) must be NArray");
  if (NA_RANK(rblapack_dlf) != 1)
    rb_raise(rb_eArgError, "rank of dlf (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dlf) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dlf must be %d", n-1);
  if (NA_TYPE(rblapack_dlf) != NA_SFLOAT)
    rblapack_dlf = na_change_type(rblapack_dlf, NA_SFLOAT);
  dlf = NA_PTR_TYPE(rblapack_dlf, real*);
  if (!NA_IsNArray(rblapack_du2))
    rb_raise(rb_eArgError, "du2 (8th argument) must be NArray");
  if (NA_RANK(rblapack_du2) != 1)
    rb_raise(rb_eArgError, "rank of du2 (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du2) != (n-2))
    rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
  if (NA_TYPE(rblapack_du2) != NA_SFLOAT)
    rblapack_du2 = na_change_type(rblapack_du2, NA_SFLOAT);
  du2 = NA_PTR_TYPE(rblapack_du2, real*);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (4th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_SFLOAT)
    rblapack_du = na_change_type(rblapack_du, NA_SFLOAT);
  du = NA_PTR_TYPE(rblapack_du, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (10th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (10th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of x");
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (!NA_IsNArray(rblapack_duf))
    rb_raise(rb_eArgError, "duf (7th argument) must be NArray");
  if (NA_RANK(rblapack_duf) != 1)
    rb_raise(rb_eArgError, "rank of duf (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_duf) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of duf must be %d", n-1);
  if (NA_TYPE(rblapack_duf) != NA_SFLOAT)
    rblapack_duf = na_change_type(rblapack_duf, NA_SFLOAT);
  duf = NA_PTR_TYPE(rblapack_duf, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(real, (3*n));
  iwork = ALLOC_N(integer, (n));

  sgtrfs_(&trans, &n, &nrhs, dl, d, du, dlf, df, duf, du2, ipiv, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_sgtrfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgtrfs", rblapack_sgtrfs, -1);
}
ruby-lapack-1.7.2/ext/chesvx.c0000644000175000017500000003340712502221024016030 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID chesvx_(char* fact, char* uplo, integer* n, integer* nrhs, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, complex* b, integer* ldb, complex* x, integer* ldx, real* rcond, real* ferr, real* berr, complex* work, integer* lwork, real* rwork, integer* info);


static VALUE
rblapack_chesvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_af_out__;
  complex *af_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  real *rwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.chesvx( fact, uplo, a, af, ipiv, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CHESVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, RWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CHESVX uses the diagonal pivoting factorization to compute the\n*  solution to a complex system of linear equations A * X = B,\n*  where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS\n*  matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'N', the diagonal pivoting method is used to factor A.\n*     The form of the factorization is\n*        A = U * D * U**H,  if UPLO = 'U', or\n*        A = L * D * L**H,  if UPLO = 'L',\n*     where U (or L) is a product of permutation and unit upper (lower)\n*     triangular matrices, and D is Hermitian and block diagonal with\n*     1-by-1 and 2-by-2 diagonal blocks.\n*\n*  2. If some D(i,i)=0, so that D is exactly singular, then the routine\n*     returns with INFO = i. Otherwise, the factored form of A is used\n*     to estimate the condition number of the matrix A.  If the\n*     reciprocal of the condition number is less than machine precision,\n*     INFO = N+1 is returned as a warning, but the routine still goes on\n*     to solve for X and compute error bounds as described below.\n*\n*  3. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  4. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of A has been\n*          supplied on entry.\n*          = 'F':  On entry, AF and IPIV contain the factored form\n*                  of A.  A, AF and IPIV will not be modified.\n*          = 'N':  The matrix A will be copied to AF and factored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The Hermitian matrix A.  If UPLO = 'U', the leading N-by-N\n*          upper triangular part of A contains the upper triangular part\n*          of the matrix A, and the strictly lower triangular part of A\n*          is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*          triangular part of A contains the lower triangular part of\n*          the matrix A, and the strictly upper triangular part of A is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AF      (input or output) COMPLEX array, dimension (LDAF,N)\n*          If FACT = 'F', then AF is an input argument and on entry\n*          contains the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L from the factorization\n*          A = U*D*U**H or A = L*D*L**H as computed by CHETRF.\n*\n*          If FACT = 'N', then AF is an output argument and on exit\n*          returns the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L from the factorization\n*          A = U*D*U**H or A = L*D*L**H.\n*\n*  LDAF    (input) INTEGER\n*          The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*  IPIV    (input or output) INTEGER array, dimension (N)\n*          If FACT = 'F', then IPIV is an input argument and on entry\n*          contains details of the interchanges and the block structure\n*          of D, as determined by CHETRF.\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*          If FACT = 'N', then IPIV is an output argument and on exit\n*          contains details of the interchanges and the block structure\n*          of D, as determined by CHETRF.\n*\n*  B       (input) COMPLEX array, dimension (LDB,NRHS)\n*          The N-by-NRHS right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) COMPLEX array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) REAL\n*          The estimate of the reciprocal condition number of the matrix\n*          A.  If RCOND is less than the machine precision (in\n*          particular, if RCOND = 0), the matrix is singular to working\n*          precision.  This condition is indicated by a return code of\n*          INFO > 0.\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The length of WORK.  LWORK >= max(1,2*N), and for best\n*          performance, when FACT = 'N', LWORK >= max(1,2*N,N*NB), where\n*          NB is the optimal blocksize for CHETRF.\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*  RWORK   (workspace) REAL array, dimension (N)\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, and i is\n*                <= N:  D(i,i) is exactly zero.  The factorization\n*                       has been completed but the factor D is exactly\n*                       singular, so the solution and error bounds could\n*                       not be computed. RCOND = 0 is returned.\n*                = N+1: D is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.chesvx( fact, uplo, a, af, ipiv, b, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_b = argv[5];
  if (argc == 7) {
    rblapack_lwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  ldx = MAX(1,n);
  if (rblapack_lwork == Qnil)
    lwork = 2*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, complex*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldaf;
    shape[1] = n;
    rblapack_af_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  af_out__ = NA_PTR_TYPE(rblapack_af_out__, complex*);
  MEMCPY(af_out__, af, complex, NA_TOTAL(rblapack_af));
  rblapack_af = rblapack_af_out__;
  af = af_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  rwork = ALLOC_N(real, (n));

  chesvx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, &lwork, rwork, &info);

  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_work, rblapack_info, rblapack_af, rblapack_ipiv);
}

void
init_lapack_chesvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "chesvx", rblapack_chesvx, -1);
}
ruby-lapack-1.7.2/ext/ssbevx.c0000644000175000017500000002521512502221023016037 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssbevx_(char* jobz, char* range, char* uplo, integer* n, integer* kd, real* ab, integer* ldab, real* q, integer* ldq, real* vl, real* vu, integer* il, integer* iu, real* abstol, integer* m, real* w, real* z, integer* ldz, real* work, integer* iwork, integer* ifail, integer* info);


static VALUE
rblapack_ssbevx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_vl;
  real vl; 
  VALUE rblapack_vu;
  real vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  real abstol; 
  VALUE rblapack_q;
  real *q; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  real *w; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_ifail;
  integer *ifail; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  real *ab_out__;
  real *work;
  integer *iwork;

  integer ldab;
  integer n;
  integer ldq;
  integer ldz;

  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  q, m, w, z, ifail, info, ab = NumRu::Lapack.ssbevx( jobz, range, uplo, kd, ab, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSBEVX computes selected eigenvalues and, optionally, eigenvectors\n*  of a real symmetric band matrix A.  Eigenvalues and eigenvectors can\n*  be selected by specifying either a range of values or a range of\n*  indices for the desired eigenvalues.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found;\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found;\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) REAL array, dimension (LDAB, N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*          On exit, AB is overwritten by values generated during the\n*          reduction to tridiagonal form.  If UPLO = 'U', the first\n*          superdiagonal and the diagonal of the tridiagonal matrix T\n*          are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n*          the diagonal and first subdiagonal of T are returned in the\n*          first two rows of AB.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD + 1.\n*\n*  Q       (output) REAL array, dimension (LDQ, N)\n*          If JOBZ = 'V', the N-by-N orthogonal matrix used in the\n*                         reduction to tridiagonal form.\n*          If JOBZ = 'N', the array Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.  If JOBZ = 'V', then\n*          LDQ >= max(1,N).\n*\n*  VL      (input) REAL\n*  VU      (input) REAL\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) REAL\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less than\n*          or equal to zero, then  EPS*|T|  will be used in its place,\n*          where |T| is the 1-norm of the tridiagonal matrix obtained\n*          by reducing AB to tridiagonal form.\n*\n*          Eigenvalues will be computed most accurately when ABSTOL is\n*          set to twice the underflow threshold 2*SLAMCH('S'), not zero.\n*          If this routine returns with INFO>0, indicating that some\n*          eigenvectors did not converge, try setting ABSTOL to\n*          2*SLAMCH('S').\n*\n*          See \"Computing Small Singular Values of Bidiagonal Matrices\n*          with Guaranteed High Relative Accuracy,\" by Demmel and\n*          Kahan, LAPACK Working Note #3.\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) REAL array, dimension (N)\n*          The first M elements contain the selected eigenvalues in\n*          ascending order.\n*\n*  Z       (output) REAL array, dimension (LDZ, max(1,M))\n*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix A\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          If an eigenvector fails to converge, then that column of Z\n*          contains the latest approximation to the eigenvector, and the\n*          index of the eigenvector is returned in IFAIL.\n*          If JOBZ = 'N', then Z is not referenced.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace) REAL array, dimension (7*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (5*N)\n*\n*  IFAIL   (output) INTEGER array, dimension (N)\n*          If JOBZ = 'V', then if INFO = 0, the first M elements of\n*          IFAIL are zero.  If INFO > 0, then IFAIL contains the\n*          indices of the eigenvectors that failed to converge.\n*          If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n*                Their indices are stored in array IFAIL.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  q, m, w, z, ifail, info, ab = NumRu::Lapack.ssbevx( jobz, range, uplo, kd, ab, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_uplo = argv[2];
  rblapack_kd = argv[3];
  rblapack_ab = argv[4];
  rblapack_vl = argv[5];
  rblapack_vu = argv[6];
  rblapack_il = argv[7];
  rblapack_iu = argv[8];
  rblapack_abstol = argv[9];
  if (argc == 10) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  vu = (real)NUM2DBL(rblapack_vu);
  iu = NUM2INT(rblapack_iu);
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  ldq = lsame_(&jobz,"V") ? MAX(1,n) : 0;
  range = StringValueCStr(rblapack_range)[0];
  vl = (real)NUM2DBL(rblapack_vl);
  abstol = (real)NUM2DBL(rblapack_abstol);
  kd = NUM2INT(rblapack_kd);
  il = NUM2INT(rblapack_il);
  m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  q = NA_PTR_TYPE(rblapack_q, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
  MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  work = ALLOC_N(real, (7*n));
  iwork = ALLOC_N(integer, (5*n));

  ssbevx_(&jobz, &range, &uplo, &n, &kd, ab, &ldab, q, &ldq, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, iwork, ifail, &info);

  free(work);
  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_q, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_ab);
}

void
init_lapack_ssbevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssbevx", rblapack_ssbevx, -1);
}
ruby-lapack-1.7.2/ext/dgebak.c0000644000175000017500000001211212502221023015732 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgebak_(char* job, char* side, integer* n, integer* ilo, integer* ihi, doublereal* scale, integer* m, doublereal* v, integer* ldv, integer* info);


static VALUE
rblapack_dgebak(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_scale;
  doublereal *scale; 
  VALUE rblapack_v;
  doublereal *v; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_v_out__;
  doublereal *v_out__;

  integer n;
  integer ldv;
  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  info, v = NumRu::Lapack.dgebak( job, side, ilo, ihi, scale, v, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGEBAK forms the right or left eigenvectors of a real general matrix\n*  by backward transformation on the computed eigenvectors of the\n*  balanced matrix output by DGEBAL.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies the type of backward transformation required:\n*          = 'N', do nothing, return immediately;\n*          = 'P', do backward transformation for permutation only;\n*          = 'S', do backward transformation for scaling only;\n*          = 'B', do backward transformations for both permutation and\n*                 scaling.\n*          JOB must be the same as the argument JOB supplied to DGEBAL.\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'R':  V contains right eigenvectors;\n*          = 'L':  V contains left eigenvectors.\n*\n*  N       (input) INTEGER\n*          The number of rows of the matrix V.  N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          The integers ILO and IHI determined by DGEBAL.\n*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n*  SCALE   (input) DOUBLE PRECISION array, dimension (N)\n*          Details of the permutation and scaling factors, as returned\n*          by DGEBAL.\n*\n*  M       (input) INTEGER\n*          The number of columns of the matrix V.  M >= 0.\n*\n*  V       (input/output) DOUBLE PRECISION array, dimension (LDV,M)\n*          On entry, the matrix of right or left eigenvectors to be\n*          transformed, as returned by DHSEIN or DTREVC.\n*          On exit, V is overwritten by the transformed eigenvectors.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V. LDV >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, v = NumRu::Lapack.dgebak( job, side, ilo, ihi, scale, v, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_job = argv[0];
  rblapack_side = argv[1];
  rblapack_ilo = argv[2];
  rblapack_ihi = argv[3];
  rblapack_scale = argv[4];
  rblapack_v = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  job = StringValueCStr(rblapack_job)[0];
  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_scale))
    rb_raise(rb_eArgError, "scale (5th argument) must be NArray");
  if (NA_RANK(rblapack_scale) != 1)
    rb_raise(rb_eArgError, "rank of scale (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_scale);
  if (NA_TYPE(rblapack_scale) != NA_DFLOAT)
    rblapack_scale = na_change_type(rblapack_scale, NA_DFLOAT);
  scale = NA_PTR_TYPE(rblapack_scale, doublereal*);
  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (6th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (6th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  m = NA_SHAPE1(rblapack_v);
  if (NA_TYPE(rblapack_v) != NA_DFLOAT)
    rblapack_v = na_change_type(rblapack_v, NA_DFLOAT);
  v = NA_PTR_TYPE(rblapack_v, doublereal*);
  ihi = NUM2INT(rblapack_ihi);
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = m;
    rblapack_v_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  v_out__ = NA_PTR_TYPE(rblapack_v_out__, doublereal*);
  MEMCPY(v_out__, v, doublereal, NA_TOTAL(rblapack_v));
  rblapack_v = rblapack_v_out__;
  v = v_out__;

  dgebak_(&job, &side, &n, &ilo, &ihi, scale, &m, v, &ldv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_v);
}

void
init_lapack_dgebak(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgebak", rblapack_dgebak, -1);
}
ruby-lapack-1.7.2/ext/dlaqtr.c0000644000175000017500000001546612502221026016026 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaqtr_(logical* ltran, logical* lreal, integer* n, doublereal* t, integer* ldt, doublereal* b, doublereal* w, doublereal* scale, doublereal* x, doublereal* work, integer* info);


static VALUE
rblapack_dlaqtr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ltran;
  logical ltran; 
  VALUE rblapack_lreal;
  logical lreal; 
  VALUE rblapack_t;
  doublereal *t; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_w;
  doublereal w; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_scale;
  doublereal scale; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  doublereal *x_out__;
  doublereal *work;

  integer ldt;
  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  scale, info, x = NumRu::Lapack.dlaqtr( ltran, lreal, t, b, w, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLAQTR solves the real quasi-triangular system\n*\n*               op(T)*p = scale*c,               if LREAL = .TRUE.\n*\n*  or the complex quasi-triangular systems\n*\n*             op(T + iB)*(p+iq) = scale*(c+id),  if LREAL = .FALSE.\n*\n*  in real arithmetic, where T is upper quasi-triangular.\n*  If LREAL = .FALSE., then the first diagonal block of T must be\n*  1 by 1, B is the specially structured matrix\n*\n*                 B = [ b(1) b(2) ... b(n) ]\n*                     [       w            ]\n*                     [           w        ]\n*                     [              .     ]\n*                     [                 w  ]\n*\n*  op(A) = A or A', A' denotes the conjugate transpose of\n*  matrix A.\n*\n*  On input, X = [ c ].  On output, X = [ p ].\n*                [ d ]                  [ q ]\n*\n*  This subroutine is designed for the condition number estimation\n*  in routine DTRSNA.\n*\n\n*  Arguments\n*  =========\n*\n*  LTRAN   (input) LOGICAL\n*          On entry, LTRAN specifies the option of conjugate transpose:\n*             = .FALSE.,    op(T+i*B) = T+i*B,\n*             = .TRUE.,     op(T+i*B) = (T+i*B)'.\n*\n*  LREAL   (input) LOGICAL\n*          On entry, LREAL specifies the input matrix structure:\n*             = .FALSE.,    the input is complex\n*             = .TRUE.,     the input is real\n*\n*  N       (input) INTEGER\n*          On entry, N specifies the order of T+i*B. N >= 0.\n*\n*  T       (input) DOUBLE PRECISION array, dimension (LDT,N)\n*          On entry, T contains a matrix in Schur canonical form.\n*          If LREAL = .FALSE., then the first diagonal block of T mu\n*          be 1 by 1.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the matrix T. LDT >= max(1,N).\n*\n*  B       (input) DOUBLE PRECISION array, dimension (N)\n*          On entry, B contains the elements to form the matrix\n*          B as described above.\n*          If LREAL = .TRUE., B is not referenced.\n*\n*  W       (input) DOUBLE PRECISION\n*          On entry, W is the diagonal element of the matrix B.\n*          If LREAL = .TRUE., W is not referenced.\n*\n*  SCALE   (output) DOUBLE PRECISION\n*          On exit, SCALE is the scale factor.\n*\n*  X       (input/output) DOUBLE PRECISION array, dimension (2*N)\n*          On entry, X contains the right hand side of the system.\n*          On exit, X is overwritten by the solution.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          On exit, INFO is set to\n*             0: successful exit.\n*               1: the some diagonal 1 by 1 block has been perturbed by\n*                  a small number SMIN to keep nonsingularity.\n*               2: the some diagonal 2 by 2 block has been perturbed by\n*                  a small number in DLALN2 to keep nonsingularity.\n*          NOTE: In the interests of speed, this routine does not\n*                check the inputs for errors.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, info, x = NumRu::Lapack.dlaqtr( ltran, lreal, t, b, w, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_ltran = argv[0];
  rblapack_lreal = argv[1];
  rblapack_t = argv[2];
  rblapack_b = argv[3];
  rblapack_w = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  ltran = (rblapack_ltran == Qtrue);
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (3th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (3th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  n = NA_SHAPE1(rblapack_t);
  if (NA_TYPE(rblapack_t) != NA_DFLOAT)
    rblapack_t = na_change_type(rblapack_t, NA_DFLOAT);
  t = NA_PTR_TYPE(rblapack_t, doublereal*);
  w = NUM2DBL(rblapack_w);
  lreal = (rblapack_lreal == Qtrue);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 1)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of b must be the same as shape 1 of t");
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 2*n);
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 2*n;
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(doublereal, (n));

  dlaqtr_(<ran, &lreal, &n, t, &ldt, b, &w, &scale, x, work, &info);

  free(work);
  rblapack_scale = rb_float_new((double)scale);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_scale, rblapack_info, rblapack_x);
}

void
init_lapack_dlaqtr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaqtr", rblapack_dlaqtr, -1);
}
ruby-lapack-1.7.2/ext/zgtcon.c0000644000175000017500000001527612502221016016041 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgtcon_(char* norm, integer* n, doublecomplex* dl, doublecomplex* d, doublecomplex* du, doublecomplex* du2, integer* ipiv, doublereal* anorm, doublereal* rcond, doublecomplex* work, integer* info);


static VALUE
rblapack_zgtcon(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_dl;
  doublecomplex *dl; 
  VALUE rblapack_d;
  doublecomplex *d; 
  VALUE rblapack_du;
  doublecomplex *du; 
  VALUE rblapack_du2;
  doublecomplex *du2; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_anorm;
  doublereal anorm; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_info;
  integer info; 
  doublecomplex *work;

  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  rcond, info = NumRu::Lapack.zgtcon( norm, dl, d, du, du2, ipiv, anorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGTCON estimates the reciprocal of the condition number of a complex\n*  tridiagonal matrix A using the LU factorization as computed by\n*  ZGTTRF.\n*\n*  An estimate is obtained for norm(inv(A)), and the reciprocal of the\n*  condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies whether the 1-norm condition number or the\n*          infinity-norm condition number is required:\n*          = '1' or 'O':  1-norm;\n*          = 'I':         Infinity-norm.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  DL      (input) COMPLEX*16 array, dimension (N-1)\n*          The (n-1) multipliers that define the matrix L from the\n*          LU factorization of A as computed by ZGTTRF.\n*\n*  D       (input) COMPLEX*16 array, dimension (N)\n*          The n diagonal elements of the upper triangular matrix U from\n*          the LU factorization of A.\n*\n*  DU      (input) COMPLEX*16 array, dimension (N-1)\n*          The (n-1) elements of the first superdiagonal of U.\n*\n*  DU2     (input) COMPLEX*16 array, dimension (N-2)\n*          The (n-2) elements of the second superdiagonal of U.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices; for 1 <= i <= n, row i of the matrix was\n*          interchanged with row IPIV(i).  IPIV(i) will always be either\n*          i or i+1; IPIV(i) = i indicates a row interchange was not\n*          required.\n*\n*  ANORM   (input) DOUBLE PRECISION\n*          If NORM = '1' or 'O', the 1-norm of the original matrix A.\n*          If NORM = 'I', the infinity-norm of the original matrix A.\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The reciprocal of the condition number of the matrix A,\n*          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an\n*          estimate of the 1-norm of inv(A) computed in this routine.\n*\n*  WORK    (workspace) COMPLEX*16 array, dimension (2*N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, info = NumRu::Lapack.zgtcon( norm, dl, d, du, du2, ipiv, anorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_norm = argv[0];
  rblapack_dl = argv[1];
  rblapack_d = argv[2];
  rblapack_du = argv[3];
  rblapack_du2 = argv[4];
  rblapack_ipiv = argv[5];
  rblapack_anorm = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DCOMPLEX)
    rblapack_d = na_change_type(rblapack_d, NA_DCOMPLEX);
  d = NA_PTR_TYPE(rblapack_d, doublecomplex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (6th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (2th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_DCOMPLEX)
    rblapack_dl = na_change_type(rblapack_dl, NA_DCOMPLEX);
  dl = NA_PTR_TYPE(rblapack_dl, doublecomplex*);
  if (!NA_IsNArray(rblapack_du2))
    rb_raise(rb_eArgError, "du2 (5th argument) must be NArray");
  if (NA_RANK(rblapack_du2) != 1)
    rb_raise(rb_eArgError, "rank of du2 (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du2) != (n-2))
    rb_raise(rb_eRuntimeError, "shape 0 of du2 must be %d", n-2);
  if (NA_TYPE(rblapack_du2) != NA_DCOMPLEX)
    rblapack_du2 = na_change_type(rblapack_du2, NA_DCOMPLEX);
  du2 = NA_PTR_TYPE(rblapack_du2, doublecomplex*);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (4th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_DCOMPLEX)
    rblapack_du = na_change_type(rblapack_du, NA_DCOMPLEX);
  du = NA_PTR_TYPE(rblapack_du, doublecomplex*);
  anorm = NUM2DBL(rblapack_anorm);
  work = ALLOC_N(doublecomplex, (2*n));

  zgtcon_(&norm, &n, dl, d, du, du2, ipiv, &anorm, &rcond, work, &info);

  free(work);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_rcond, rblapack_info);
}

void
init_lapack_zgtcon(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgtcon", rblapack_zgtcon, -1);
}
ruby-lapack-1.7.2/ext/slantp.c0000644000175000017500000001130212502221026016021 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real slantp_(char* norm, char* uplo, char* diag, integer* n, real* ap, real* work);


static VALUE
rblapack_slantp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack___out__;
  real __out__; 
  real *work;

  integer lwork;

  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  __out__ = NumRu::Lapack.slantp( norm, uplo, diag, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL             FUNCTION SLANTP( NORM, UPLO, DIAG, N, AP, WORK )\n\n*  Purpose\n*  =======\n*\n*  SLANTP  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  triangular matrix A, supplied in packed form.\n*\n*  Description\n*  ===========\n*\n*  SLANTP returns the value\n*\n*     SLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in SLANTP as described\n*          above.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the matrix A is upper or lower triangular.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  DIAG    (input) CHARACTER*1\n*          Specifies whether or not the matrix A is unit triangular.\n*          = 'N':  Non-unit triangular\n*          = 'U':  Unit triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, SLANTP is\n*          set to zero.\n*\n*  AP      (input) REAL array, dimension (N*(N+1)/2)\n*          The upper or lower triangular matrix A, packed columnwise in\n*          a linear array.  The j-th column of A is stored in the array\n*          AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*          Note that when DIAG = 'U', the elements of the array AP\n*          corresponding to the diagonal elements of the matrix A are\n*          not referenced, but are assumed to be one.\n*\n*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I'; otherwise, WORK is not\n*          referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.slantp( norm, uplo, diag, n, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_diag = argv[2];
  rblapack_n = argv[3];
  rblapack_ap = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  n = NUM2INT(rblapack_n);
  lwork = lsame_(&norm,"I") ? n : 0;
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (5th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  work = ALLOC_N(real, (MAX(1,lwork)));

  __out__ = slantp_(&norm, &uplo, &diag, &n, ap, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_slantp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slantp", rblapack_slantp, -1);
}
ruby-lapack-1.7.2/ext/zgbtf2.c0000644000175000017500000001321412502221020015714 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgbtf2_(integer* m, integer* n, integer* kl, integer* ku, doublecomplex* ab, integer* ldab, integer* ipiv, integer* info);


static VALUE
rblapack_zgbtf2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublecomplex *ab_out__;

  integer ldab;
  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  ipiv, info, ab = NumRu::Lapack.zgbtf2( m, kl, ku, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGBTF2 computes an LU factorization of a complex m-by-n band matrix\n*  A using partial pivoting with row interchanges.\n*\n*  This is the unblocked version of the algorithm, calling Level 2 BLAS.\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*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)\n*          On entry, the matrix A in band storage, in rows KL+1 to\n*          2*KL+KU+1; rows 1 to KL of the array need not be set.\n*          The j-th column of A is stored in the j-th column of the\n*          array AB as follows:\n*          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)\n*\n*          On exit, details of the factorization: U is stored as an\n*          upper triangular band matrix with KL+KU superdiagonals in\n*          rows 1 to KL+KU+1, and the multipliers used during the\n*          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n*          See below for further details.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.\n*\n*  IPIV    (output) INTEGER array, dimension (min(M,N))\n*          The pivot indices; for 1 <= i <= min(M,N), row i of the\n*          matrix was interchanged with row IPIV(i).\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, U(i,i) is exactly zero. The factorization\n*               has been completed, but the factor U is exactly\n*               singular, and division by zero will occur if it is used\n*               to solve a system of equations.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  M = N = 6, KL = 2, KU = 1:\n*\n*  On entry:                       On exit:\n*\n*      *    *    *    +    +    +       *    *    *   u14  u25  u36\n*      *    *    +    +    +    +       *    *   u13  u24  u35  u46\n*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56\n*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66\n*     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *\n*     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *\n*\n*  Array elements marked * are not used by the routine; elements marked\n*  + need not be set on entry, but are required by the routine to store\n*  elements of U, because of fill-in resulting from the row\n*  interchanges.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, ab = NumRu::Lapack.zgbtf2( m, kl, ku, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_m = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  ku = NUM2INT(rblapack_ku);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublecomplex*);
  MEMCPY(ab_out__, ab, doublecomplex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;

  zgbtf2_(&m, &n, &kl, &ku, ab, &ldab, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_ipiv, rblapack_info, rblapack_ab);
}

void
init_lapack_zgbtf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgbtf2", rblapack_zgbtf2, -1);
}
ruby-lapack-1.7.2/ext/clanhf.c0000644000175000017500000002230012502221017015753 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real clanhf_(char* norm, char* transr, char* uplo, integer* n, doublecomplex* a, real* work);


static VALUE
rblapack_clanhf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_transr;
  char transr; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack___out__;
  real __out__; 
  real *work;

  integer lwork;

  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  __out__ = NumRu::Lapack.clanhf( norm, transr, uplo, n, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL FUNCTION CLANHF( NORM, TRANSR, UPLO, N, A, WORK )\n\n*  Purpose\n*  =======\n*\n*  CLANHF  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  complex Hermitian matrix A in RFP format.\n*\n*  Description\n*  ===========\n*\n*  CLANHF returns the value\n*\n*     CLANHF = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a  matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM      (input) CHARACTER\n*            Specifies the value to be returned in CLANHF as described\n*            above.\n*\n*  TRANSR    (input) CHARACTER\n*            Specifies whether the RFP format of A is normal or\n*            conjugate-transposed format.\n*            = 'N':  RFP format is Normal\n*            = 'C':  RFP format is Conjugate-transposed\n*\n*  UPLO      (input) CHARACTER\n*            On entry, UPLO specifies whether the RFP matrix A came from\n*            an upper or lower triangular matrix as follows:\n*\n*            UPLO = 'U' or 'u' RFP A came from an upper triangular\n*            matrix\n*\n*            UPLO = 'L' or 'l' RFP A came from a  lower triangular\n*            matrix\n*\n*  N         (input) INTEGER\n*            The order of the matrix A.  N >= 0.  When N = 0, CLANHF is\n*            set to zero.\n*\n*   A        (input) COMPLEX*16 array, dimension ( N*(N+1)/2 );\n*            On entry, the matrix A in RFP Format.\n*            RFP Format is described by TRANSR, UPLO and N as follows:\n*            If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even;\n*            K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If\n*            TRANSR = 'C' then RFP is the Conjugate-transpose of RFP A\n*            as defined when TRANSR = 'N'. The contents of RFP A are\n*            defined by UPLO as follows: If UPLO = 'U' the RFP A\n*            contains the ( N*(N+1)/2 ) elements of upper packed A\n*            either in normal or conjugate-transpose Format. If\n*            UPLO = 'L' the RFP A contains the ( N*(N+1) /2 ) elements\n*            of lower packed A either in normal or conjugate-transpose\n*            Format. The LDA of RFP A is (N+1)/2 when TRANSR = 'C'. When\n*            TRANSR is 'N' the LDA is N+1 when N is even and is N when\n*            is odd. See the Note below for more details.\n*            Unchanged on exit.\n*\n*  WORK      (workspace) REAL array, dimension (LWORK),\n*            where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n*            WORK is not referenced.\n*\n\n*  Further Details\n*  ===============\n*\n*  We first consider Standard Packed Format when N is even.\n*  We give an example where N = 6.\n*\n*      AP is Upper             AP is Lower\n*\n*   00 01 02 03 04 05       00\n*      11 12 13 14 15       10 11\n*         22 23 24 25       20 21 22\n*            33 34 35       30 31 32 33\n*               44 45       40 41 42 43 44\n*                  55       50 51 52 53 54 55\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(4:6,0:2) consists of\n*  conjugate-transpose of the first three columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:2,0:2) consists of\n*  conjugate-transpose of the last three columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N even and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                -- -- --\n*        03 04 05                33 43 53\n*                                   -- --\n*        13 14 15                00 44 54\n*                                      --\n*        23 24 25                10 11 55\n*\n*        33 34 35                20 21 22\n*        --\n*        00 44 45                30 31 32\n*        -- --\n*        01 11 55                40 41 42\n*        -- -- --\n*        02 12 22                50 51 52\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- -- --                -- -- -- -- -- --\n*     03 13 23 33 00 01 02    33 00 10 20 30 40 50\n*     -- -- -- -- --                -- -- -- -- --\n*     04 14 24 34 44 11 12    43 44 11 21 31 41 51\n*     -- -- -- -- -- --                -- -- -- --\n*     05 15 25 35 45 55 22    53 54 55 22 32 42 52\n*\n*\n*  We next  consider Standard Packed Format when N is odd.\n*  We give an example where N = 5.\n*\n*     AP is Upper                 AP is Lower\n*\n*   00 01 02 03 04              00\n*      11 12 13 14              10 11\n*         22 23 24              20 21 22\n*            33 34              30 31 32 33\n*               44              40 41 42 43 44\n*\n*\n*  Let TRANSR = 'N'. RFP holds AP as follows:\n*  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last\n*  three columns of AP upper. The lower triangle A(3:4,0:1) consists of\n*  conjugate-transpose of the first two   columns of AP upper.\n*  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first\n*  three columns of AP lower. The upper triangle A(0:1,1:2) consists of\n*  conjugate-transpose of the last two   columns of AP lower.\n*  To denote conjugate we place -- above the element. This covers the\n*  case N odd  and TRANSR = 'N'.\n*\n*         RFP A                   RFP A\n*\n*                                   -- --\n*        02 03 04                00 33 43\n*                                      --\n*        12 13 14                10 11 44\n*\n*        22 23 24                20 21 22\n*        --\n*        00 33 34                30 31 32\n*        -- --\n*        01 11 44                40 41 42\n*\n*  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-\n*  transpose of RFP A above. One therefore gets:\n*\n*\n*           RFP A                   RFP A\n*\n*     -- -- --                   -- -- -- -- -- --\n*     02 12 22 00 01             00 10 20 30 40 50\n*     -- -- -- --                   -- -- -- -- --\n*     03 13 23 33 11             33 11 21 31 41 51\n*     -- -- -- -- --                   -- -- -- --\n*     04 14 24 34 44             43 44 22 32 42 52\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.clanhf( norm, transr, uplo, n, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_norm = argv[0];
  rblapack_transr = argv[1];
  rblapack_uplo = argv[2];
  rblapack_n = argv[3];
  rblapack_a = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  transr = StringValueCStr(rblapack_transr)[0];
  n = NUM2INT(rblapack_n);
  lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 1)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_a) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of a must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  work = ALLOC_N(real, (lwork));

  __out__ = clanhf_(&norm, &transr, &uplo, &n, a, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_clanhf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clanhf", rblapack_clanhf, -1);
}
ruby-lapack-1.7.2/ext/cla_syrcond_c.c0000644000175000017500000001660512502221026017335 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real cla_syrcond_c_(char* uplo, integer* n, complex* a, integer* lda, complex* af, integer* ldaf, integer* ipiv, real* c, logical* capply, integer* info, complex* work, real* rwork);


static VALUE
rblapack_cla_syrcond_c(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_af;
  complex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_capply;
  logical capply; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_rwork;
  real *rwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack___out__;
  real __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  info, __out__ = NumRu::Lapack.cla_syrcond_c( uplo, a, af, ipiv, c, capply, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL FUNCTION CLA_SYRCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, C, CAPPLY, INFO, WORK, RWORK )\n\n*  Purpose\n*  =======\n*\n*     CLA_SYRCOND_C Computes the infinity norm condition number of\n*     op(A) * inv(diag(C)) where C is a REAL vector.\n*\n\n*  Arguments\n*  =========\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     A       (input) COMPLEX array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX array, dimension (LDAF,N)\n*     The block diagonal matrix D and the multipliers used to\n*     obtain the factor U or L as computed by CSYTRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     Details of the interchanges and the block structure of D\n*     as determined by CSYTRF.\n*\n*     C       (input) REAL array, dimension (N)\n*     The vector C in the formula op(A) * inv(diag(C)).\n*\n*     CAPPLY  (input) LOGICAL\n*     If .TRUE. then access the vector C in the formula above.\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit.\n*     i > 0:  The ith argument is invalid.\n*\n*     WORK    (input) COMPLEX array, dimension (2*N).\n*     Workspace.\n*\n*     RWORK   (input) REAL array, dimension (N).\n*     Workspace.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            KASE\n      REAL               AINVNM, ANORM, TMP\n      INTEGER            I, J\n      LOGICAL            UP\n      COMPLEX            ZDUM\n*     ..\n*     .. Local Arrays ..\n      INTEGER            ISAVE( 3 )\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CLACN2, CSYTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX\n*     ..\n*     .. Statement Functions ..\n      REAL CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, __out__ = NumRu::Lapack.cla_syrcond_c( uplo, a, af, ipiv, c, capply, work, rwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_c = argv[4];
  rblapack_capply = argv[5];
  rblapack_work = argv[6];
  rblapack_rwork = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_SCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_SCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, complex*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (5th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  if (!NA_IsNArray(rblapack_rwork))
    rb_raise(rb_eArgError, "rwork (8th argument) must be NArray");
  if (NA_RANK(rblapack_rwork) != 1)
    rb_raise(rb_eArgError, "rank of rwork (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_rwork) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_rwork) != NA_SFLOAT)
    rblapack_rwork = na_change_type(rblapack_rwork, NA_SFLOAT);
  rwork = NA_PTR_TYPE(rblapack_rwork, real*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  capply = (rblapack_capply == Qtrue);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (7th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
  if (NA_TYPE(rblapack_work) != NA_SCOMPLEX)
    rblapack_work = na_change_type(rblapack_work, NA_SCOMPLEX);
  work = NA_PTR_TYPE(rblapack_work, complex*);

  __out__ = cla_syrcond_c_(&uplo, &n, a, &lda, af, &ldaf, ipiv, c, &capply, &info, work, rwork);

  rblapack_info = INT2NUM(info);
  rblapack___out__ = rb_float_new((double)__out__);
  return rb_ary_new3(2, rblapack_info, rblapack___out__);
}

void
init_lapack_cla_syrcond_c(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cla_syrcond_c", rblapack_cla_syrcond_c, -1);
}
ruby-lapack-1.7.2/ext/dsysvx.c0000644000175000017500000003366212502221020016067 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsysvx_(char* fact, char* uplo, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* af, integer* ldaf, integer* ipiv, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublereal* work, integer* lwork, integer* iwork, integer* info);


static VALUE
rblapack_dsysvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_af;
  doublereal *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_af_out__;
  doublereal *af_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  integer *iwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.dsysvx( fact, uplo, a, af, ipiv, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSYSVX uses the diagonal pivoting factorization to compute the\n*  solution to a real system of linear equations A * X = B,\n*  where A is an N-by-N symmetric matrix and X and B are N-by-NRHS\n*  matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'N', the diagonal pivoting method is used to factor A.\n*     The form of the factorization is\n*        A = U * D * U**T,  if UPLO = 'U', or\n*        A = L * D * L**T,  if UPLO = 'L',\n*     where U (or L) is a product of permutation and unit upper (lower)\n*     triangular matrices, and D is symmetric and block diagonal with\n*     1-by-1 and 2-by-2 diagonal blocks.\n*\n*  2. If some D(i,i)=0, so that D is exactly singular, then the routine\n*     returns with INFO = i. Otherwise, the factored form of A is used\n*     to estimate the condition number of the matrix A.  If the\n*     reciprocal of the condition number is less than machine precision,\n*     INFO = N+1 is returned as a warning, but the routine still goes on\n*     to solve for X and compute error bounds as described below.\n*\n*  3. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  4. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of A has been\n*          supplied on entry.\n*          = 'F':  On entry, AF and IPIV contain the factored form of\n*                  A.  AF and IPIV will not be modified.\n*          = 'N':  The matrix A will be copied to AF and factored.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*          The symmetric matrix A.  If UPLO = 'U', the leading N-by-N\n*          upper triangular part of A contains the upper triangular part\n*          of the matrix A, and the strictly lower triangular part of A\n*          is not referenced.  If UPLO = 'L', the leading N-by-N lower\n*          triangular part of A contains the lower triangular part of\n*          the matrix A, and the strictly upper triangular part of A is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AF      (input or output) DOUBLE PRECISION array, dimension (LDAF,N)\n*          If FACT = 'F', then AF is an input argument and on entry\n*          contains the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L from the factorization\n*          A = U*D*U**T or A = L*D*L**T as computed by DSYTRF.\n*\n*          If FACT = 'N', then AF is an output argument and on exit\n*          returns the block diagonal matrix D and the multipliers used\n*          to obtain the factor U or L from the factorization\n*          A = U*D*U**T or A = L*D*L**T.\n*\n*  LDAF    (input) INTEGER\n*          The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*  IPIV    (input or output) INTEGER array, dimension (N)\n*          If FACT = 'F', then IPIV is an input argument and on entry\n*          contains details of the interchanges and the block structure\n*          of D, as determined by DSYTRF.\n*          If IPIV(k) > 0, then rows and columns k and IPIV(k) were\n*          interchanged and D(k,k) is a 1-by-1 diagonal block.\n*          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and\n*          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)\n*          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) =\n*          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were\n*          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.\n*\n*          If FACT = 'N', then IPIV is an output argument and on exit\n*          contains details of the interchanges and the block structure\n*          of D, as determined by DSYTRF.\n*\n*  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          The N-by-NRHS right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The estimate of the reciprocal condition number of the matrix\n*          A.  If RCOND is less than the machine precision (in\n*          particular, if RCOND = 0), the matrix is singular to working\n*          precision.  This condition is indicated by a return code of\n*          INFO > 0.\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\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 length of WORK.  LWORK >= max(1,3*N), and for best\n*          performance, when FACT = 'N', LWORK >= max(1,3*N,N*NB), where\n*          NB is the optimal blocksize for DSYTRF.\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*  IWORK   (workspace) INTEGER array, dimension (N)\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, and i is\n*                <= N:  D(i,i) is exactly zero.  The factorization\n*                       has been completed but the factor D is exactly\n*                       singular, so the solution and error bounds could\n*                       not be computed. RCOND = 0 is returned.\n*                = N+1: D is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, work, info, af, ipiv = NumRu::Lapack.dsysvx( fact, uplo, a, af, ipiv, b, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_fact = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_b = argv[5];
  if (argc == 7) {
    rblapack_lwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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 (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
  af = NA_PTR_TYPE(rblapack_af, doublereal*);
  ldx = MAX(1,n);
  if (rblapack_lwork == Qnil)
    lwork = 3*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldaf;
    shape[1] = n;
    rblapack_af_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  af_out__ = NA_PTR_TYPE(rblapack_af_out__, doublereal*);
  MEMCPY(af_out__, af, doublereal, NA_TOTAL(rblapack_af));
  rblapack_af = rblapack_af_out__;
  af = af_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  iwork = ALLOC_N(integer, (n));

  dsysvx_(&fact, &uplo, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, &rcond, ferr, berr, work, &lwork, iwork, &info);

  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_work, rblapack_info, rblapack_af, rblapack_ipiv);
}

void
init_lapack_dsysvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsysvx", rblapack_dsysvx, -1);
}
ruby-lapack-1.7.2/ext/claqp2.c0000644000175000017500000001723712502221017015717 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID claqp2_(integer* m, integer* n, integer* offset, complex* a, integer* lda, integer* jpvt, complex* tau, real* vn1, real* vn2, complex* work);


static VALUE
rblapack_claqp2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_offset;
  integer offset; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_jpvt;
  integer *jpvt; 
  VALUE rblapack_vn1;
  real *vn1; 
  VALUE rblapack_vn2;
  real *vn2; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_jpvt_out__;
  integer *jpvt_out__;
  VALUE rblapack_vn1_out__;
  real *vn1_out__;
  VALUE rblapack_vn2_out__;
  real *vn2_out__;
  complex *work;

  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, a, jpvt, vn1, vn2 = NumRu::Lapack.claqp2( m, offset, a, jpvt, vn1, vn2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, WORK )\n\n*  Purpose\n*  =======\n*\n*  CLAQP2 computes a QR factorization with column pivoting of\n*  the block A(OFFSET+1:M,1:N).\n*  The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.\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*  OFFSET  (input) INTEGER\n*          The number of rows of the matrix A that must be pivoted\n*          but no factorized. OFFSET >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, the upper triangle of block A(OFFSET+1:M,1:N) is \n*          the triangular factor obtained; the elements in block\n*          A(OFFSET+1:M,1:N) below the diagonal, together with the\n*          array TAU, represent the orthogonal matrix Q as a product of\n*          elementary reflectors. Block A(1:OFFSET,1:N) has been\n*          accordingly pivoted, but no factorized.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  JPVT    (input/output) INTEGER array, dimension (N)\n*          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n*          to the front of A*P (a leading column); if JPVT(i) = 0,\n*          the i-th column of A is a free column.\n*          On exit, if JPVT(i) = k, then the i-th column of A*P\n*          was the k-th column of A.\n*\n*  TAU     (output) COMPLEX array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors.\n*\n*  VN1     (input/output) REAL array, dimension (N)\n*          The vector with the partial column norms.\n*\n*  VN2     (input/output) REAL array, dimension (N)\n*          The vector with the exact column norms.\n*\n*  WORK    (workspace) COMPLEX array, dimension (N)\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n*    X. Sun, Computer Science Dept., Duke University, USA\n*\n*  Partial column norm updating strategy modified by\n*    Z. Drmac and Z. Bujanovic, Dept. of Mathematics,\n*    University of Zagreb, Croatia.\n*     June 2010\n*  For more details see LAPACK Working Note 176.\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, a, jpvt, vn1, vn2 = NumRu::Lapack.claqp2( m, offset, a, jpvt, vn1, vn2, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_m = argv[0];
  rblapack_offset = argv[1];
  rblapack_a = argv[2];
  rblapack_jpvt = argv[3];
  rblapack_vn1 = argv[4];
  rblapack_vn2 = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_vn1))
    rb_raise(rb_eArgError, "vn1 (5th argument) must be NArray");
  if (NA_RANK(rblapack_vn1) != 1)
    rb_raise(rb_eArgError, "rank of vn1 (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_vn1) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of vn1 must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_vn1) != NA_SFLOAT)
    rblapack_vn1 = na_change_type(rblapack_vn1, NA_SFLOAT);
  vn1 = NA_PTR_TYPE(rblapack_vn1, real*);
  offset = NUM2INT(rblapack_offset);
  if (!NA_IsNArray(rblapack_vn2))
    rb_raise(rb_eArgError, "vn2 (6th argument) must be NArray");
  if (NA_RANK(rblapack_vn2) != 1)
    rb_raise(rb_eArgError, "rank of vn2 (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_vn2) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of vn2 must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_vn2) != NA_SFLOAT)
    rblapack_vn2 = na_change_type(rblapack_vn2, NA_SFLOAT);
  vn2 = NA_PTR_TYPE(rblapack_vn2, real*);
  if (!NA_IsNArray(rblapack_jpvt))
    rb_raise(rb_eArgError, "jpvt (4th argument) must be NArray");
  if (NA_RANK(rblapack_jpvt) != 1)
    rb_raise(rb_eArgError, "rank of jpvt (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_jpvt) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_jpvt) != NA_LINT)
    rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
  jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
  MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
  rblapack_jpvt = rblapack_jpvt_out__;
  jpvt = jpvt_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_vn1_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  vn1_out__ = NA_PTR_TYPE(rblapack_vn1_out__, real*);
  MEMCPY(vn1_out__, vn1, real, NA_TOTAL(rblapack_vn1));
  rblapack_vn1 = rblapack_vn1_out__;
  vn1 = vn1_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_vn2_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  vn2_out__ = NA_PTR_TYPE(rblapack_vn2_out__, real*);
  MEMCPY(vn2_out__, vn2, real, NA_TOTAL(rblapack_vn2));
  rblapack_vn2 = rblapack_vn2_out__;
  vn2 = vn2_out__;
  work = ALLOC_N(complex, (n));

  claqp2_(&m, &n, &offset, a, &lda, jpvt, tau, vn1, vn2, work);

  free(work);
  return rb_ary_new3(5, rblapack_tau, rblapack_a, rblapack_jpvt, rblapack_vn1, rblapack_vn2);
}

void
init_lapack_claqp2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "claqp2", rblapack_claqp2, -1);
}
ruby-lapack-1.7.2/ext/slansp.c0000644000175000017500000001051512502221020016017 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real slansp_(char* norm, char* uplo, integer* n, real* ap, real* work);


static VALUE
rblapack_slansp(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack___out__;
  real __out__; 
  real *work;

  integer lwork;

  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  __out__ = NumRu::Lapack.slansp( norm, uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL             FUNCTION SLANSP( NORM, UPLO, N, AP, WORK )\n\n*  Purpose\n*  =======\n*\n*  SLANSP  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  real symmetric matrix A,  supplied in packed form.\n*\n*  Description\n*  ===========\n*\n*  SLANSP returns the value\n*\n*     SLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in SLANSP as described\n*          above.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is supplied.\n*          = 'U':  Upper triangular part of A is supplied\n*          = 'L':  Lower triangular part of A is supplied\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, SLANSP is\n*          set to zero.\n*\n*  AP      (input) REAL array, dimension (N*(N+1)/2)\n*          The upper or lower triangle of the symmetric matrix A, packed\n*          columnwise in a linear array.  The j-th column of A is stored\n*          in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n*          WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.slansp( norm, uplo, n, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_n = argv[2];
  rblapack_ap = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  n = NUM2INT(rblapack_n);
  lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  work = ALLOC_N(real, (MAX(1,lwork)));

  __out__ = slansp_(&norm, &uplo, &n, ap, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_slansp(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slansp", rblapack_slansp, -1);
}
ruby-lapack-1.7.2/ext/zgebak.c0000644000175000017500000001213712502221015015770 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgebak_(char* job, char* side, integer* n, integer* ilo, integer* ihi, doublereal* scale, integer* m, doublecomplex* v, integer* ldv, integer* info);


static VALUE
rblapack_zgebak(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_scale;
  doublereal *scale; 
  VALUE rblapack_v;
  doublecomplex *v; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_v_out__;
  doublecomplex *v_out__;

  integer n;
  integer ldv;
  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  info, v = NumRu::Lapack.zgebak( job, side, ilo, ihi, scale, v, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZGEBAK forms the right or left eigenvectors of a complex general\n*  matrix by backward transformation on the computed eigenvectors of the\n*  balanced matrix output by ZGEBAL.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies the type of backward transformation required:\n*          = 'N', do nothing, return immediately;\n*          = 'P', do backward transformation for permutation only;\n*          = 'S', do backward transformation for scaling only;\n*          = 'B', do backward transformations for both permutation and\n*                 scaling.\n*          JOB must be the same as the argument JOB supplied to ZGEBAL.\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'R':  V contains right eigenvectors;\n*          = 'L':  V contains left eigenvectors.\n*\n*  N       (input) INTEGER\n*          The number of rows of the matrix V.  N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          The integers ILO and IHI determined by ZGEBAL.\n*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n*  SCALE   (input) DOUBLE PRECISION array, dimension (N)\n*          Details of the permutation and scaling factors, as returned\n*          by ZGEBAL.\n*\n*  M       (input) INTEGER\n*          The number of columns of the matrix V.  M >= 0.\n*\n*  V       (input/output) COMPLEX*16 array, dimension (LDV,M)\n*          On entry, the matrix of right or left eigenvectors to be\n*          transformed, as returned by ZHSEIN or ZTREVC.\n*          On exit, V is overwritten by the transformed eigenvectors.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V. LDV >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, v = NumRu::Lapack.zgebak( job, side, ilo, ihi, scale, v, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_job = argv[0];
  rblapack_side = argv[1];
  rblapack_ilo = argv[2];
  rblapack_ihi = argv[3];
  rblapack_scale = argv[4];
  rblapack_v = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  job = StringValueCStr(rblapack_job)[0];
  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_scale))
    rb_raise(rb_eArgError, "scale (5th argument) must be NArray");
  if (NA_RANK(rblapack_scale) != 1)
    rb_raise(rb_eArgError, "rank of scale (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_scale);
  if (NA_TYPE(rblapack_scale) != NA_DFLOAT)
    rblapack_scale = na_change_type(rblapack_scale, NA_DFLOAT);
  scale = NA_PTR_TYPE(rblapack_scale, doublereal*);
  side = StringValueCStr(rblapack_side)[0];
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (6th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (6th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  m = NA_SHAPE1(rblapack_v);
  if (NA_TYPE(rblapack_v) != NA_DCOMPLEX)
    rblapack_v = na_change_type(rblapack_v, NA_DCOMPLEX);
  v = NA_PTR_TYPE(rblapack_v, doublecomplex*);
  ihi = NUM2INT(rblapack_ihi);
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = m;
    rblapack_v_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  v_out__ = NA_PTR_TYPE(rblapack_v_out__, doublecomplex*);
  MEMCPY(v_out__, v, doublecomplex, NA_TOTAL(rblapack_v));
  rblapack_v = rblapack_v_out__;
  v = v_out__;

  zgebak_(&job, &side, &n, &ilo, &ihi, scale, &m, v, &ldv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_v);
}

void
init_lapack_zgebak(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgebak", rblapack_zgebak, -1);
}
ruby-lapack-1.7.2/ext/zlansb.c0000644000175000017500000001125012502221023016010 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal zlansb_(char* norm, char* uplo, integer* n, integer* k, doublecomplex* ab, integer* ldab, doublereal* work);


static VALUE
rblapack_zlansb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_ab;
  doublecomplex *ab; 
  VALUE rblapack___out__;
  doublereal __out__; 
  doublereal *work;

  integer ldab;
  integer n;
  integer lwork;

  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  __out__ = NumRu::Lapack.zlansb( norm, uplo, k, ab, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION ZLANSB( NORM, UPLO, N, K, AB, LDAB, WORK )\n\n*  Purpose\n*  =======\n*\n*  ZLANSB  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the element of  largest absolute value  of an\n*  n by n symmetric band matrix A,  with k super-diagonals.\n*\n*  Description\n*  ===========\n*\n*  ZLANSB returns the value\n*\n*     ZLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in ZLANSB as described\n*          above.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          band matrix A is supplied.\n*          = 'U':  Upper triangular part is supplied\n*          = 'L':  Lower triangular part is supplied\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, ZLANSB is\n*          set to zero.\n*\n*  K       (input) INTEGER\n*          The number of super-diagonals or sub-diagonals of the\n*          band matrix A.  K >= 0.\n*\n*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)\n*          The upper or lower triangle of the symmetric band matrix A,\n*          stored in the first K+1 rows of AB.  The j-th column of A is\n*          stored in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)   = A(i,j) for j<=i<=min(n,j+k).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= K+1.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n*          WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.zlansb( norm, uplo, k, ab, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_k = argv[2];
  rblapack_ab = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  k = NUM2INT(rblapack_k);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_DCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, doublecomplex*);
  lwork = ((lsame_(&norm,"I")) || ((('1') || ('o')))) ? n : 0;
  work = ALLOC_N(doublereal, (MAX(1,lwork)));

  __out__ = zlansb_(&norm, &uplo, &n, &k, ab, &ldab, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_zlansb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlansb", rblapack_zlansb, -1);
}
ruby-lapack-1.7.2/ext/sspgst.c0000644000175000017500000001154012502221020016041 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sspgst_(integer* itype, char* uplo, integer* n, real* ap, real* bp, integer* info);


static VALUE
rblapack_sspgst(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_itype;
  integer itype; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  real *ap; 
  VALUE rblapack_bp;
  real *bp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  real *ap_out__;


  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  info, ap = NumRu::Lapack.sspgst( itype, uplo, n, ap, bp, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSPGST( ITYPE, UPLO, N, AP, BP, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSPGST reduces a real symmetric-definite generalized eigenproblem\n*  to standard form, using packed storage.\n*\n*  If ITYPE = 1, the problem is A*x = lambda*B*x,\n*  and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)\n*\n*  If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or\n*  B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.\n*\n*  B must have been previously factorized as U**T*U or L*L**T by SPPTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  ITYPE   (input) INTEGER\n*          = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);\n*          = 2 or 3: compute U*A*U**T or L**T*A*L.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored and B is factored as\n*                  U**T*U;\n*          = 'L':  Lower triangle of A is stored and B is factored as\n*                  L*L**T.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  AP      (input/output) REAL array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the symmetric matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, if INFO = 0, the transformed matrix, stored in the\n*          same format as A.\n*\n*  BP      (input) REAL array, dimension (N*(N+1)/2)\n*          The triangular factor from the Cholesky factorization of B,\n*          stored in the same format as A, as returned by SPPTRF.\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ap = NumRu::Lapack.sspgst( itype, uplo, n, ap, bp, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_itype = argv[0];
  rblapack_uplo = argv[1];
  rblapack_n = argv[2];
  rblapack_ap = argv[3];
  rblapack_bp = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  itype = NUM2INT(rblapack_itype);
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_bp))
    rb_raise(rb_eArgError, "bp (5th argument) must be NArray");
  if (NA_RANK(rblapack_bp) != 1)
    rb_raise(rb_eArgError, "rank of bp (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_bp) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of bp must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_bp) != NA_SFLOAT)
    rblapack_bp = na_change_type(rblapack_bp, NA_SFLOAT);
  bp = NA_PTR_TYPE(rblapack_bp, real*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (4th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SFLOAT)
    rblapack_ap = na_change_type(rblapack_ap, NA_SFLOAT);
  ap = NA_PTR_TYPE(rblapack_ap, real*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, real*);
  MEMCPY(ap_out__, ap, real, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  sspgst_(&itype, &uplo, &n, ap, bp, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ap);
}

void
init_lapack_sspgst(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sspgst", rblapack_sspgst, -1);
}
ruby-lapack-1.7.2/ext/ssbgst.c0000644000175000017500000001443212502221024016032 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ssbgst_(char* vect, char* uplo, integer* n, integer* ka, integer* kb, real* ab, integer* ldab, real* bb, integer* ldbb, real* x, integer* ldx, real* work, integer* info);


static VALUE
rblapack_ssbgst(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_vect;
  char vect; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ka;
  integer ka; 
  VALUE rblapack_kb;
  integer kb; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_bb;
  real *bb; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  real *ab_out__;
  real *work;

  integer ldab;
  integer n;
  integer ldbb;
  integer ldx;

  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  x, info, ab = NumRu::Lapack.ssbgst( vect, uplo, ka, kb, ab, bb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SSBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, LDX, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SSBGST reduces a real symmetric-definite banded generalized\n*  eigenproblem  A*x = lambda*B*x  to standard form  C*y = lambda*y,\n*  such that C has the same bandwidth as A.\n*\n*  B must have been previously factorized as S**T*S by SPBSTF, using a\n*  split Cholesky factorization. A is overwritten by C = X**T*A*X, where\n*  X = S**(-1)*Q and Q is an orthogonal matrix chosen to preserve the\n*  bandwidth of A.\n*\n\n*  Arguments\n*  =========\n*\n*  VECT    (input) CHARACTER*1\n*          = 'N':  do not form the transformation matrix X;\n*          = 'V':  form X.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  KA      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KA >= 0.\n*\n*  KB      (input) INTEGER\n*          The number of superdiagonals of the matrix B if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KA >= KB >= 0.\n*\n*  AB      (input/output) REAL array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first ka+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).\n*\n*          On exit, the transformed matrix X**T*A*X, stored in the same\n*          format as A.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KA+1.\n*\n*  BB      (input) REAL array, dimension (LDBB,N)\n*          The banded factor S from the split Cholesky factorization of\n*          B, as returned by SPBSTF, stored in the first KB+1 rows of\n*          the array.\n*\n*  LDBB    (input) INTEGER\n*          The leading dimension of the array BB.  LDBB >= KB+1.\n*\n*  X       (output) REAL array, dimension (LDX,N)\n*          If VECT = 'V', the n-by-n matrix X.\n*          If VECT = 'N', the array X is not referenced.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.\n*          LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.\n*\n*  WORK    (workspace) REAL array, dimension (2*N)\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, info, ab = NumRu::Lapack.ssbgst( vect, uplo, ka, kb, ab, bb, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_vect = argv[0];
  rblapack_uplo = argv[1];
  rblapack_ka = argv[2];
  rblapack_kb = argv[3];
  rblapack_ab = argv[4];
  rblapack_bb = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  vect = StringValueCStr(rblapack_vect)[0];
  ka = NUM2INT(rblapack_ka);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_bb))
    rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
  if (NA_RANK(rblapack_bb) != 2)
    rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
  ldbb = NA_SHAPE0(rblapack_bb);
  if (NA_SHAPE1(rblapack_bb) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of bb must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_bb) != NA_SFLOAT)
    rblapack_bb = na_change_type(rblapack_bb, NA_SFLOAT);
  bb = NA_PTR_TYPE(rblapack_bb, real*);
  kb = NUM2INT(rblapack_kb);
  ldx = lsame_(&vect,"V") ? MAX(1,n) : 1;
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = n;
    rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
  MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  work = ALLOC_N(real, (2*n));

  ssbgst_(&vect, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, x, &ldx, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_x, rblapack_info, rblapack_ab);
}

void
init_lapack_ssbgst(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ssbgst", rblapack_ssbgst, -1);
}
ruby-lapack-1.7.2/ext/cunmr3.c0000644000175000017500000001572612502221020015737 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cunmr3_(char* side, char* trans, integer* m, integer* n, integer* k, integer* l, complex* a, integer* lda, complex* tau, complex* c, integer* ldc, complex* work, integer* info);


static VALUE
rblapack_cunmr3(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_c;
  complex *c; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  complex *c_out__;
  complex *work;

  integer lda;
  integer m;
  integer k;
  integer ldc;
  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  info, c = NumRu::Lapack.cunmr3( side, trans, l, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CUNMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CUNMR3 overwrites the general complex m by n matrix C with\n*\n*        Q * C  if SIDE = 'L' and TRANS = 'N', or\n*\n*        Q'* C  if SIDE = 'L' and TRANS = 'C', or\n*\n*        C * Q  if SIDE = 'R' and TRANS = 'N', or\n*\n*        C * Q' if SIDE = 'R' and TRANS = 'C',\n*\n*  where Q is a complex unitary matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(1) H(2) . . . H(k)\n*\n*  as returned by CTZRZF. Q is of order m if SIDE = 'L' and of order n\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q' from the Left\n*          = 'R': apply Q or Q' from the Right\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': apply Q  (No transpose)\n*          = 'C': apply Q' (Conjugate transpose)\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  L       (input) INTEGER\n*          The number of columns of the matrix A containing\n*          the meaningful part of the Householder reflectors.\n*          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n*  A       (input) COMPLEX array, dimension\n*                               (LDA,M) if SIDE = 'L',\n*                               (LDA,N) if SIDE = 'R'\n*          The i-th row must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          CTZRZF in the last k rows of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,K).\n*\n*  TAU     (input) COMPLEX array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by CTZRZF.\n*\n*  C       (input/output) COMPLEX array, dimension (LDC,N)\n*          On entry, the m-by-n matrix C.\n*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) COMPLEX array, dimension\n*                                   (N) if SIDE = 'L',\n*                                   (M) if SIDE = 'R'\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*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            LEFT, NOTRAN\n      INTEGER            I, I1, I2, I3, IC, JA, JC, MI, NI, NQ\n      COMPLEX            TAUI\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CLARZ, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          CONJG, MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, c = NumRu::Lapack.cunmr3( side, trans, l, a, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_l = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  l = NUM2INT(rblapack_l);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, complex*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
  MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(complex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  cunmr3_(&side, &trans, &m, &n, &k, &l, a, &lda, tau, c, &ldc, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_c);
}

void
init_lapack_cunmr3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cunmr3", rblapack_cunmr3, -1);
}
ruby-lapack-1.7.2/ext/ctbtrs.c0000644000175000017500000001316712502221026016034 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctbtrs_(char* uplo, char* trans, char* diag, integer* n, integer* kd, integer* nrhs, complex* ab, integer* ldab, complex* b, integer* ldb, integer* info);


static VALUE
rblapack_ctbtrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer ldab;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.ctbtrs( uplo, trans, diag, kd, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTBTRS solves a triangular system of the form\n*\n*     A * X = B,  A**T * X = B,  or  A**H * X = B,\n*\n*  where A is a triangular band matrix of order N, and B is an\n*  N-by-NRHS matrix.  A check is made to verify that A is nonsingular.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals or subdiagonals of the\n*          triangular band matrix A.  KD >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AB      (input) COMPLEX array, dimension (LDAB,N)\n*          The upper or lower triangular band matrix A, stored in the\n*          first kd+1 rows of AB.  The j-th column of A is stored\n*          in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*          If DIAG = 'U', the diagonal elements of A are not referenced\n*          and are assumed to be 1.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, if INFO = 0, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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 A is zero,\n*                indicating that the matrix is singular and the\n*                solutions X have not been computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.ctbtrs( uplo, trans, diag, kd, ab, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_kd = argv[3];
  rblapack_ab = argv[4];
  rblapack_b = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  kd = NUM2INT(rblapack_kd);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  ctbtrs_(&uplo, &trans, &diag, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_ctbtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctbtrs", rblapack_ctbtrs, -1);
}
ruby-lapack-1.7.2/ext/sgbtrs.c0000644000175000017500000001310712502221017016031 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgbtrs_(char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, real* ab, integer* ldab, integer* ipiv, real* b, integer* ldb, integer* info);


static VALUE
rblapack_sgbtrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  real *b_out__;

  integer ldab;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.sgbtrs( trans, kl, ku, ab, ipiv, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGBTRS solves a system of linear equations\n*     A * X = B  or  A' * X = B\n*  with a general band matrix A using the LU factorization computed\n*  by SGBTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations.\n*          = 'N':  A * X = B  (No transpose)\n*          = 'T':  A'* X = B  (Transpose)\n*          = 'C':  A'* X = B  (Conjugate transpose = Transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AB      (input) REAL array, dimension (LDAB,N)\n*          Details of the LU factorization of the band matrix A, as\n*          computed by SGBTRF.  U is stored as an upper triangular band\n*          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and\n*          the multipliers used during the factorization are stored in\n*          rows KL+KU+2 to 2*KL+KU+1.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices; for 1 <= i <= N, row i of the matrix was\n*          interchanged with row IPIV(i).\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.sgbtrs( trans, kl, ku, ab, ipiv, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_trans = argv[0];
  rblapack_kl = argv[1];
  rblapack_ku = argv[2];
  rblapack_ab = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_b = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_ipiv);
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (4th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (4th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of ipiv");
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  sgbtrs_(&trans, &n, &kl, &ku, &nrhs, ab, &ldab, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_sgbtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgbtrs", rblapack_sgbtrs, -1);
}
ruby-lapack-1.7.2/ext/clartg.c0000644000175000017500000000635112502221025016003 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clartg_(complex* f, complex* g, real* cs, complex* sn, complex* r);


static VALUE
rblapack_clartg(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_f;
  complex f; 
  VALUE rblapack_g;
  complex g; 
  VALUE rblapack_cs;
  real cs; 
  VALUE rblapack_sn;
  complex sn; 
  VALUE rblapack_r;
  complex r; 


  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  cs, sn, r = NumRu::Lapack.clartg( f, g, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLARTG( F, G, CS, SN, R )\n\n*  Purpose\n*  =======\n*\n*  CLARTG generates a plane rotation so that\n*\n*     [  CS  SN  ]     [ F ]     [ R ]\n*     [  __      ]  .  [   ]  =  [   ]   where CS**2 + |SN|**2 = 1.\n*     [ -SN  CS  ]     [ G ]     [ 0 ]\n*\n*  This is a faster version of the BLAS1 routine CROTG, except for\n*  the following differences:\n*     F and G are unchanged on return.\n*     If G=0, then CS=1 and SN=0.\n*     If F=0, then CS=0 and SN is chosen so that R is real.\n*\n\n*  Arguments\n*  =========\n*\n*  F       (input) COMPLEX\n*          The first component of vector to be rotated.\n*\n*  G       (input) COMPLEX\n*          The second component of vector to be rotated.\n*\n*  CS      (output) REAL\n*          The cosine of the rotation.\n*\n*  SN      (output) COMPLEX\n*          The sine of the rotation.\n*\n*  R       (output) COMPLEX\n*          The nonzero component of the rotated vector.\n*\n\n*  Further Details\n*  ======= =======\n*\n*  3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel\n*\n*  This version has a few statements commented out for thread safety\n*  (machine parameters are computed on each entry). 10 feb 03, SJH.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  cs, sn, r = NumRu::Lapack.clartg( f, g, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_f = argv[0];
  rblapack_g = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  f.r = (real)NUM2DBL(rb_funcall(rblapack_f, rb_intern("real"), 0));
  f.i = (real)NUM2DBL(rb_funcall(rblapack_f, rb_intern("imag"), 0));
  g.r = (real)NUM2DBL(rb_funcall(rblapack_g, rb_intern("real"), 0));
  g.i = (real)NUM2DBL(rb_funcall(rblapack_g, rb_intern("imag"), 0));

  clartg_(&f, &g, &cs, &sn, &r);

  rblapack_cs = rb_float_new((double)cs);
  rblapack_sn = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(sn.r)), rb_float_new((double)(sn.i)));
  rblapack_r = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(r.r)), rb_float_new((double)(r.i)));
  return rb_ary_new3(3, rblapack_cs, rblapack_sn, rblapack_r);
}

void
init_lapack_clartg(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clartg", rblapack_clartg, -1);
}
ruby-lapack-1.7.2/ext/cpptri.c0000644000175000017500000000733512502221022016030 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cpptri_(char* uplo, integer* n, complex* ap, integer* info);


static VALUE
rblapack_cpptri(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_ap;
  complex *ap; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  complex *ap_out__;


  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  info, ap = NumRu::Lapack.cpptri( uplo, n, ap, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CPPTRI( UPLO, N, AP, INFO )\n\n*  Purpose\n*  =======\n*\n*  CPPTRI computes the inverse of a complex Hermitian positive definite\n*  matrix A using the Cholesky factorization A = U**H*U or A = L*L**H\n*  computed by CPPTRF.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangular factor is stored in AP;\n*          = 'L':  Lower triangular factor is stored in AP.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) COMPLEX array, dimension (N*(N+1)/2)\n*          On entry, the triangular factor U or L from the Cholesky\n*          factorization A = U**H*U or A = L*L**H, packed columnwise as\n*          a linear array.  The j-th column of U or L is stored in the\n*          array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.\n*\n*          On exit, the upper or lower triangle of the (Hermitian)\n*          inverse of A, overwriting the input factor U or L.\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,i) element of the factor U or L is\n*                zero, and the inverse could not be computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ap = NumRu::Lapack.cpptri( uplo, n, ap, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_n = argv[1];
  rblapack_ap = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ap) != (n*(n+1)/2))
    rb_raise(rb_eRuntimeError, "shape 0 of ap must be %d", n*(n+1)/2);
  if (NA_TYPE(rblapack_ap) != NA_SCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_SCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n*(n+1)/2;
    rblapack_ap_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, complex*);
  MEMCPY(ap_out__, ap, complex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  cpptri_(&uplo, &n, ap, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_ap);
}

void
init_lapack_cpptri(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cpptri", rblapack_cpptri, -1);
}
ruby-lapack-1.7.2/ext/zlaqr3.c0000644000175000017500000002614112502221023015740 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlaqr3_(logical* wantt, logical* wantz, integer* n, integer* ktop, integer* kbot, integer* nw, doublecomplex* h, integer* ldh, integer* iloz, integer* ihiz, doublecomplex* z, integer* ldz, integer* ns, integer* nd, doublecomplex* sh, doublecomplex* v, integer* ldv, integer* nh, doublecomplex* t, integer* ldt, integer* nv, doublecomplex* wv, integer* ldwv, doublecomplex* work, integer* lwork);


static VALUE
rblapack_zlaqr3(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantt;
  logical wantt; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_ktop;
  integer ktop; 
  VALUE rblapack_kbot;
  integer kbot; 
  VALUE rblapack_nw;
  integer nw; 
  VALUE rblapack_h;
  doublecomplex *h; 
  VALUE rblapack_iloz;
  integer iloz; 
  VALUE rblapack_ihiz;
  integer ihiz; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_nh;
  integer nh; 
  VALUE rblapack_nv;
  integer nv; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_ns;
  integer ns; 
  VALUE rblapack_nd;
  integer nd; 
  VALUE rblapack_sh;
  doublecomplex *sh; 
  VALUE rblapack_h_out__;
  doublecomplex *h_out__;
  VALUE rblapack_z_out__;
  doublecomplex *z_out__;
  doublecomplex *v;
  doublecomplex *t;
  doublecomplex *wv;
  doublecomplex *work;

  integer ldh;
  integer n;
  integer ldz;
  integer ldv;
  integer ldwv;
  integer ldt;

  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  ns, nd, sh, h, z = NumRu::Lapack.zlaqr3( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, NV, WV, LDWV, WORK, LWORK )\n\n*     Aggressive early deflation:\n*\n*     This subroutine accepts as input an upper Hessenberg matrix\n*     H and performs an unitary similarity transformation\n*     designed to detect and deflate fully converged eigenvalues from\n*     a trailing principal submatrix.  On output H has been over-\n*     written by a new Hessenberg matrix that is a perturbation of\n*     an unitary similarity transformation of H.  It is to be\n*     hoped that the final version of H has many zero subdiagonal\n*     entries.\n*\n*     ******************************************************************\n\n*     WANTT   (input) LOGICAL\n*          If .TRUE., then the Hessenberg matrix H is fully updated\n*          so that the triangular Schur factor may be\n*          computed (in cooperation with the calling subroutine).\n*          If .FALSE., then only enough of H is updated to preserve\n*          the eigenvalues.\n*\n*     WANTZ   (input) LOGICAL\n*          If .TRUE., then the unitary matrix Z is updated so\n*          so that the unitary Schur factor may be computed\n*          (in cooperation with the calling subroutine).\n*          If .FALSE., then Z is not referenced.\n*\n*     N       (input) INTEGER\n*          The order of the matrix H and (if WANTZ is .TRUE.) the\n*          order of the unitary matrix Z.\n*\n*     KTOP    (input) INTEGER\n*          It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.\n*          KBOT and KTOP together determine an isolated block\n*          along the diagonal of the Hessenberg matrix.\n*\n*     KBOT    (input) INTEGER\n*          It is assumed without a check that either\n*          KBOT = N or H(KBOT+1,KBOT)=0.  KBOT and KTOP together\n*          determine an isolated block along the diagonal of the\n*          Hessenberg matrix.\n*\n*     NW      (input) INTEGER\n*          Deflation window size.  1 .LE. NW .LE. (KBOT-KTOP+1).\n*\n*     H       (input/output) COMPLEX*16 array, dimension (LDH,N)\n*          On input the initial N-by-N section of H stores the\n*          Hessenberg matrix undergoing aggressive early deflation.\n*          On output H has been transformed by a unitary\n*          similarity transformation, perturbed, and the returned\n*          to Hessenberg form that (it is to be hoped) has some\n*          zero subdiagonal entries.\n*\n*     LDH     (input) integer\n*          Leading dimension of H just as declared in the calling\n*          subroutine.  N .LE. LDH\n*\n*     ILOZ    (input) INTEGER\n*     IHIZ    (input) INTEGER\n*          Specify the rows of Z to which transformations must be\n*          applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.\n*\n*     Z       (input/output) COMPLEX*16 array, dimension (LDZ,N)\n*          IF WANTZ is .TRUE., then on output, the unitary\n*          similarity transformation mentioned above has been\n*          accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.\n*          If WANTZ is .FALSE., then Z is unreferenced.\n*\n*     LDZ     (input) integer\n*          The leading dimension of Z just as declared in the\n*          calling subroutine.  1 .LE. LDZ.\n*\n*     NS      (output) integer\n*          The number of unconverged (ie approximate) eigenvalues\n*          returned in SR and SI that may be used as shifts by the\n*          calling subroutine.\n*\n*     ND      (output) integer\n*          The number of converged eigenvalues uncovered by this\n*          subroutine.\n*\n*     SH      (output) COMPLEX*16 array, dimension KBOT\n*          On output, approximate eigenvalues that may\n*          be used for shifts are stored in SH(KBOT-ND-NS+1)\n*          through SR(KBOT-ND).  Converged eigenvalues are\n*          stored in SH(KBOT-ND+1) through SH(KBOT).\n*\n*     V       (workspace) COMPLEX*16 array, dimension (LDV,NW)\n*          An NW-by-NW work array.\n*\n*     LDV     (input) integer scalar\n*          The leading dimension of V just as declared in the\n*          calling subroutine.  NW .LE. LDV\n*\n*     NH      (input) integer scalar\n*          The number of columns of T.  NH.GE.NW.\n*\n*     T       (workspace) COMPLEX*16 array, dimension (LDT,NW)\n*\n*     LDT     (input) integer\n*          The leading dimension of T just as declared in the\n*          calling subroutine.  NW .LE. LDT\n*\n*     NV      (input) integer\n*          The number of rows of work array WV available for\n*          workspace.  NV.GE.NW.\n*\n*     WV      (workspace) COMPLEX*16 array, dimension (LDWV,NW)\n*\n*     LDWV    (input) integer\n*          The leading dimension of W just as declared in the\n*          calling subroutine.  NW .LE. LDV\n*\n*     WORK    (workspace) COMPLEX*16 array, dimension LWORK.\n*          On exit, WORK(1) is set to an estimate of the optimal value\n*          of LWORK for the given values of N, NW, KTOP and KBOT.\n*\n*     LWORK   (input) integer\n*          The dimension of the work array WORK.  LWORK = 2*NW\n*          suffices, but greater efficiency may result from larger\n*          values of LWORK.\n*\n*          If LWORK = -1, then a workspace query is assumed; ZLAQR3\n*          only estimates the optimal workspace size for the given\n*          values of N, NW, KTOP and KBOT.  The estimate is returned\n*          in WORK(1).  No error message related to LWORK is issued\n*          by XERBLA.  Neither H nor Z are accessed.\n*\n\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ns, nd, sh, h, z = NumRu::Lapack.zlaqr3( wantt, wantz, ktop, kbot, nw, h, iloz, ihiz, z, nh, nv, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 11 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
  rblapack_wantt = argv[0];
  rblapack_wantz = argv[1];
  rblapack_ktop = argv[2];
  rblapack_kbot = argv[3];
  rblapack_nw = argv[4];
  rblapack_h = argv[5];
  rblapack_iloz = argv[6];
  rblapack_ihiz = argv[7];
  rblapack_z = argv[8];
  rblapack_nh = argv[9];
  rblapack_nv = argv[10];
  if (argc == 12) {
    rblapack_lwork = argv[11];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  wantt = (rblapack_wantt == Qtrue);
  ktop = NUM2INT(rblapack_ktop);
  nw = NUM2INT(rblapack_nw);
  iloz = NUM2INT(rblapack_iloz);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (9th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (9th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  n = NA_SHAPE1(rblapack_z);
  if (NA_TYPE(rblapack_z) != NA_DCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_DCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  nv = NUM2INT(rblapack_nv);
  ldwv = nw;
  ldv = nw;
  wantz = (rblapack_wantz == Qtrue);
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (6th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (6th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  if (NA_SHAPE1(rblapack_h) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of h must be the same as shape 1 of z");
  if (NA_TYPE(rblapack_h) != NA_DCOMPLEX)
    rblapack_h = na_change_type(rblapack_h, NA_DCOMPLEX);
  h = NA_PTR_TYPE(rblapack_h, doublecomplex*);
  nh = NUM2INT(rblapack_nh);
  ldt = nw;
  kbot = NUM2INT(rblapack_kbot);
  if (rblapack_lwork == Qnil)
    lwork = 2*nw;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ihiz = NUM2INT(rblapack_ihiz);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,kbot);
    rblapack_sh = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  sh = NA_PTR_TYPE(rblapack_sh, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, doublecomplex*);
  MEMCPY(h_out__, h, doublecomplex, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublecomplex*);
  MEMCPY(z_out__, z, doublecomplex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  v = ALLOC_N(doublecomplex, (ldv)*(MAX(1,nw)));
  t = ALLOC_N(doublecomplex, (ldv)*(MAX(1,nw)));
  wv = ALLOC_N(doublecomplex, (ldv)*(MAX(1,nw)));
  work = ALLOC_N(doublecomplex, (MAX(1,lwork)));

  zlaqr3_(&wantt, &wantz, &n, &ktop, &kbot, &nw, h, &ldh, &iloz, &ihiz, z, &ldz, &ns, &nd, sh, v, &ldv, &nh, t, &ldt, &nv, wv, &ldwv, work, &lwork);

  free(v);
  free(t);
  free(wv);
  free(work);
  rblapack_ns = INT2NUM(ns);
  rblapack_nd = INT2NUM(nd);
  return rb_ary_new3(5, rblapack_ns, rblapack_nd, rblapack_sh, rblapack_h, rblapack_z);
}

void
init_lapack_zlaqr3(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlaqr3", rblapack_zlaqr3, -1);
}
ruby-lapack-1.7.2/ext/zla_gercond_x.c0000644000175000017500000001671412502221016017351 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal zla_gercond_x_(char* trans, integer* n, doublecomplex* a, integer* lda, doublecomplex* af, integer* ldaf, integer* ipiv, doublecomplex* x, integer* info, doublecomplex* work, doublereal* rwork);


static VALUE
rblapack_zla_gercond_x(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_af;
  doublecomplex *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_rwork;
  doublereal *rwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack___out__;
  doublereal __out__; 

  integer lda;
  integer n;
  integer ldaf;

  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  info, __out__ = NumRu::Lapack.zla_gercond_x( trans, a, af, ipiv, x, work, rwork, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION ZLA_GERCOND_X( TRANS, N, A, LDA, AF, LDAF, IPIV, X, INFO, WORK, RWORK )\n\n*  Purpose\n*  =======\n*\n*     ZLA_GERCOND_X computes the infinity norm condition number of\n*     op(A) * diag(X) where X is a COMPLEX*16 vector.\n*\n\n*  Arguments\n*  =========\n*\n*     TRANS   (input) CHARACTER*1\n*     Specifies the form of the system of equations:\n*       = 'N':  A * X = B     (No transpose)\n*       = 'T':  A**T * X = B  (Transpose)\n*       = 'C':  A**H * X = B  (Conjugate Transpose = Transpose)\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     A       (input) COMPLEX*16 array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) COMPLEX*16 array, dimension (LDAF,N)\n*     The factors L and U from the factorization\n*     A = P*L*U as computed by ZGETRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     The pivot indices from the factorization A = P*L*U\n*     as computed by ZGETRF; row i of the matrix was interchanged\n*     with row IPIV(i).\n*\n*     X       (input) COMPLEX*16 array, dimension (N)\n*     The vector X in the formula op(A) * diag(X).\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit.\n*     i > 0:  The ith argument is invalid.\n*\n*     WORK    (input) COMPLEX*16 array, dimension (2*N).\n*     Workspace.\n*\n*     RWORK   (input) DOUBLE PRECISION array, dimension (N).\n*     Workspace.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            NOTRANS\n      INTEGER            KASE\n      DOUBLE PRECISION   AINVNM, ANORM, TMP\n      INTEGER            I, J\n      COMPLEX*16         ZDUM\n*     ..\n*     .. Local Arrays ..\n      INTEGER            ISAVE( 3 )\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           ZLACN2, ZGETRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX, REAL, DIMAG\n*     ..\n*     .. Statement Functions ..\n      DOUBLE PRECISION   CABS1\n*     ..\n*     .. Statement Function Definitions ..\n      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, __out__ = NumRu::Lapack.zla_gercond_x( trans, a, af, ipiv, x, work, rwork, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 7 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 7)", argc);
  rblapack_trans = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_x = argv[4];
  rblapack_work = argv[5];
  rblapack_rwork = argv[6];
  if (argc == 7) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_DCOMPLEX)
    rblapack_af = na_change_type(rblapack_af, NA_DCOMPLEX);
  af = NA_PTR_TYPE(rblapack_af, doublecomplex*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (5th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of x must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_x) != NA_DCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_DCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  if (!NA_IsNArray(rblapack_rwork))
    rb_raise(rb_eArgError, "rwork (7th argument) must be NArray");
  if (NA_RANK(rblapack_rwork) != 1)
    rb_raise(rb_eArgError, "rank of rwork (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_rwork) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of rwork must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_rwork) != NA_DFLOAT)
    rblapack_rwork = na_change_type(rblapack_rwork, NA_DFLOAT);
  rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_work))
    rb_raise(rb_eArgError, "work (6th argument) must be NArray");
  if (NA_RANK(rblapack_work) != 1)
    rb_raise(rb_eArgError, "rank of work (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_work) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of work must be %d", 2*n);
  if (NA_TYPE(rblapack_work) != NA_DCOMPLEX)
    rblapack_work = na_change_type(rblapack_work, NA_DCOMPLEX);
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);

  __out__ = zla_gercond_x_(&trans, &n, a, &lda, af, &ldaf, ipiv, x, &info, work, rwork);

  rblapack_info = INT2NUM(info);
  rblapack___out__ = rb_float_new((double)__out__);
  return rb_ary_new3(2, rblapack_info, rblapack___out__);
}

void
init_lapack_zla_gercond_x(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zla_gercond_x", rblapack_zla_gercond_x, -1);
}
ruby-lapack-1.7.2/ext/zlarrv.c0000644000175000017500000004164312655767575016114 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlarrv_(integer* n, doublereal* vl, doublereal* vu, doublereal* d, doublereal* l, doublereal* pivmin, integer* isplit, integer* m, integer* dol, integer* dou, doublereal* minrgp, doublereal* rtol1, doublereal* rtol2, doublereal* w, doublereal* werr, doublereal* wgap, integer* iblock, integer* indexw, doublereal* gers, doublecomplex* z, integer* ldz, integer* isuppz, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_zlarrv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_vl;
  doublereal vl; 
  VALUE rblapack_vu;
  doublereal vu; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_l;
  doublereal *l; 
  VALUE rblapack_pivmin;
  doublereal pivmin; 
  VALUE rblapack_isplit;
  integer *isplit; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_dol;
  integer dol; 
  VALUE rblapack_dou;
  integer dou; 
  VALUE rblapack_minrgp;
  doublereal minrgp; 
  VALUE rblapack_rtol1;
  doublereal rtol1; 
  VALUE rblapack_rtol2;
  doublereal rtol2; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_werr;
  doublereal *werr; 
  VALUE rblapack_wgap;
  doublereal *wgap; 
  VALUE rblapack_iblock;
  integer *iblock; 
  VALUE rblapack_indexw;
  integer *indexw; 
  VALUE rblapack_gers;
  doublereal *gers; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_isuppz;
  integer *isuppz; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_l_out__;
  doublereal *l_out__;
  VALUE rblapack_w_out__;
  doublereal *w_out__;
  VALUE rblapack_werr_out__;
  doublereal *werr_out__;
  VALUE rblapack_wgap_out__;
  doublereal *wgap_out__;
  doublereal *work;
  integer *iwork;

  integer n;
  integer ldz;

  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  z, isuppz, info, d, l, w, werr, wgap = NumRu::Lapack.zlarrv( vl, vu, d, l, pivmin, isplit, m, dol, dou, minrgp, rtol1, rtol2, w, werr, wgap, iblock, indexw, gers, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLARRV( N, VL, VU, D, L, PIVMIN, ISPLIT, M, DOL, DOU, MINRGP, RTOL1, RTOL2, W, WERR, WGAP, IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZLARRV computes the eigenvectors of the tridiagonal matrix\n*  T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T.\n*  The input eigenvalues should have been computed by DLARRE.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  VL      (input) DOUBLE PRECISION\n*  VU      (input) DOUBLE PRECISION\n*          Lower and upper bounds of the interval that contains the desired\n*          eigenvalues. VL < VU. Needed to compute gaps on the left or right\n*          end of the extremal eigenvalues in the desired RANGE.\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the N diagonal elements of the diagonal matrix D.\n*          On exit, D may be overwritten.\n*\n*  L       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the (N-1) subdiagonal elements of the unit\n*          bidiagonal matrix L are in elements 1 to N-1 of L\n*          (if the matrix is not split.) At the end of each block\n*          is stored the corresponding shift as given by DLARRE.\n*          On exit, L is overwritten.\n*\n*  PIVMIN  (in) DOUBLE PRECISION\n*          The minimum pivot allowed in the Sturm sequence.\n*\n*  ISPLIT  (input) INTEGER array, dimension (N)\n*          The splitting points, at which T breaks up into blocks.\n*          The first block consists of rows/columns 1 to\n*          ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1\n*          through ISPLIT( 2 ), etc.\n*\n*  M       (input) INTEGER\n*          The total number of input eigenvalues.  0 <= M <= N.\n*\n*  DOL     (input) INTEGER\n*  DOU     (input) INTEGER\n*          If the user wants to compute only selected eigenvectors from all\n*          the eigenvalues supplied, he can specify an index range DOL:DOU.\n*          Or else the setting DOL=1, DOU=M should be applied.\n*          Note that DOL and DOU refer to the order in which the eigenvalues\n*          are stored in W.\n*          If the user wants to compute only selected eigenpairs, then\n*          the columns DOL-1 to DOU+1 of the eigenvector space Z contain the\n*          computed eigenvectors. All other columns of Z are set to zero.\n*\n*  MINRGP  (input) DOUBLE PRECISION\n*\n*  RTOL1   (input) DOUBLE PRECISION\n*  RTOL2   (input) DOUBLE PRECISION\n*           Parameters for bisection.\n*           An interval [LEFT,RIGHT] has converged if\n*           RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )\n*\n*  W       (input/output) DOUBLE PRECISION array, dimension (N)\n*          The first M elements of W contain the APPROXIMATE eigenvalues for\n*          which eigenvectors are to be computed.  The eigenvalues\n*          should be grouped by split-off block and ordered from\n*          smallest to largest within the block ( The output array\n*          W from DLARRE is expected here ). Furthermore, they are with\n*          respect to the shift of the corresponding root representation\n*          for their block. On exit, W holds the eigenvalues of the\n*          UNshifted matrix.\n*\n*  WERR    (input/output) DOUBLE PRECISION array, dimension (N)\n*          The first M elements contain the semiwidth of the uncertainty\n*          interval of the corresponding eigenvalue in W\n*\n*  WGAP    (input/output) DOUBLE PRECISION array, dimension (N)\n*          The separation from the right neighbor eigenvalue in W.\n*\n*  IBLOCK  (input) INTEGER array, dimension (N)\n*          The indices of the blocks (submatrices) associated with the\n*          corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue\n*          W(i) belongs to the first block from the top, =2 if W(i)\n*          belongs to the second block, etc.\n*\n*  INDEXW  (input) INTEGER array, dimension (N)\n*          The indices of the eigenvalues within each block (submatrix);\n*          for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the\n*          i-th eigenvalue W(i) is the 10-th eigenvalue in the second block.\n*\n*  GERS    (input) DOUBLE PRECISION array, dimension (2*N)\n*          The N Gerschgorin intervals (the i-th Gerschgorin interval\n*          is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should\n*          be computed from the original UNshifted matrix.\n*\n*  Z       (output) COMPLEX*16       array, dimension (LDZ, max(1,M) )\n*          If INFO = 0, the first M columns of Z contain the\n*          orthonormal eigenvectors of the matrix T\n*          corresponding to the input eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  ISUPPZ  (output) INTEGER array, dimension ( 2*max(1,M) )\n*          The support of the eigenvectors in Z, i.e., the indices\n*          indicating the nonzero elements in Z. The I-th eigenvector\n*          is nonzero only in elements ISUPPZ( 2*I-1 ) through\n*          ISUPPZ( 2*I ).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (12*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (7*N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*\n*          > 0:  A problem occured in ZLARRV.\n*          < 0:  One of the called subroutines signaled an internal problem.\n*                Needs inspection of the corresponding parameter IINFO\n*                for further information.\n*\n*          =-1:  Problem in DLARRB when refining a child's eigenvalues.\n*          =-2:  Problem in DLARRF when computing the RRR of a child.\n*                When a child is inside a tight cluster, it can be difficult\n*                to find an RRR. A partial remedy from the user's point of\n*                view is to make the parameter MINRGP smaller and recompile.\n*                However, as the orthogonality of the computed vectors is\n*                proportional to 1/MINRGP, the user should be aware that\n*                he might be trading in precision when he decreases MINRGP.\n*          =-3:  Problem in DLARRB when refining a single eigenvalue\n*                after the Rayleigh correction was rejected.\n*          = 5:  The Rayleigh Quotient Iteration failed to converge to\n*                full accuracy in MAXITR steps.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Beresford Parlett, University of California, Berkeley, USA\n*     Jim Demmel, University of California, Berkeley, USA\n*     Inderjit Dhillon, University of Texas, Austin, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  z, isuppz, info, d, l, w, werr, wgap = NumRu::Lapack.zlarrv( vl, vu, d, l, pivmin, isplit, m, dol, dou, minrgp, rtol1, rtol2, w, werr, wgap, iblock, indexw, gers, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 18 && argc != 18)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 18)", argc);
  rblapack_vl = argv[0];
  rblapack_vu = argv[1];
  rblapack_d = argv[2];
  rblapack_l = argv[3];
  rblapack_pivmin = argv[4];
  rblapack_isplit = argv[5];
  rblapack_m = argv[6];
  rblapack_dol = argv[7];
  rblapack_dou = argv[8];
  rblapack_minrgp = argv[9];
  rblapack_rtol1 = argv[10];
  rblapack_rtol2 = argv[11];
  rblapack_w = argv[12];
  rblapack_werr = argv[13];
  rblapack_wgap = argv[14];
  rblapack_iblock = argv[15];
  rblapack_indexw = argv[16];
  rblapack_gers = argv[17];
  if (argc == 18) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  vl = NUM2DBL(rblapack_vl);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  pivmin = NUM2DBL(rblapack_pivmin);
  m = NUM2INT(rblapack_m);
  dou = NUM2INT(rblapack_dou);
  rtol1 = NUM2DBL(rblapack_rtol1);
  if (!NA_IsNArray(rblapack_w))
    rb_raise(rb_eArgError, "w (13th argument) must be NArray");
  if (NA_RANK(rblapack_w) != 1)
    rb_raise(rb_eArgError, "rank of w (13th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_w) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of w must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_w) != NA_DFLOAT)
    rblapack_w = na_change_type(rblapack_w, NA_DFLOAT);
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  if (!NA_IsNArray(rblapack_wgap))
    rb_raise(rb_eArgError, "wgap (15th argument) must be NArray");
  if (NA_RANK(rblapack_wgap) != 1)
    rb_raise(rb_eArgError, "rank of wgap (15th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_wgap) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of wgap must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_wgap) != NA_DFLOAT)
    rblapack_wgap = na_change_type(rblapack_wgap, NA_DFLOAT);
  wgap = NA_PTR_TYPE(rblapack_wgap, doublereal*);
  if (!NA_IsNArray(rblapack_indexw))
    rb_raise(rb_eArgError, "indexw (17th argument) must be NArray");
  if (NA_RANK(rblapack_indexw) != 1)
    rb_raise(rb_eArgError, "rank of indexw (17th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_indexw) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of indexw must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_indexw) != NA_LINT)
    rblapack_indexw = na_change_type(rblapack_indexw, NA_LINT);
  indexw = NA_PTR_TYPE(rblapack_indexw, integer*);
  vu = NUM2DBL(rblapack_vu);
  if (!NA_IsNArray(rblapack_isplit))
    rb_raise(rb_eArgError, "isplit (6th argument) must be NArray");
  if (NA_RANK(rblapack_isplit) != 1)
    rb_raise(rb_eArgError, "rank of isplit (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_isplit) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of isplit must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_isplit) != NA_LINT)
    rblapack_isplit = na_change_type(rblapack_isplit, NA_LINT);
  isplit = NA_PTR_TYPE(rblapack_isplit, integer*);
  minrgp = NUM2DBL(rblapack_minrgp);
  if (!NA_IsNArray(rblapack_werr))
    rb_raise(rb_eArgError, "werr (14th argument) must be NArray");
  if (NA_RANK(rblapack_werr) != 1)
    rb_raise(rb_eArgError, "rank of werr (14th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_werr) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of werr must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_werr) != NA_DFLOAT)
    rblapack_werr = na_change_type(rblapack_werr, NA_DFLOAT);
  werr = NA_PTR_TYPE(rblapack_werr, doublereal*);
  if (!NA_IsNArray(rblapack_l))
    rb_raise(rb_eArgError, "l (4th argument) must be NArray");
  if (NA_RANK(rblapack_l) != 1)
    rb_raise(rb_eArgError, "rank of l (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_l) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of l must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_l) != NA_DFLOAT)
    rblapack_l = na_change_type(rblapack_l, NA_DFLOAT);
  l = NA_PTR_TYPE(rblapack_l, doublereal*);
  rtol2 = NUM2DBL(rblapack_rtol2);
  dol = NUM2INT(rblapack_dol);
  if (!NA_IsNArray(rblapack_iblock))
    rb_raise(rb_eArgError, "iblock (16th argument) must be NArray");
  if (NA_RANK(rblapack_iblock) != 1)
    rb_raise(rb_eArgError, "rank of iblock (16th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_iblock) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of iblock must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_iblock) != NA_LINT)
    rblapack_iblock = na_change_type(rblapack_iblock, NA_LINT);
  iblock = NA_PTR_TYPE(rblapack_iblock, integer*);
  ldz = n;
  if (!NA_IsNArray(rblapack_gers))
    rb_raise(rb_eArgError, "gers (18th argument) must be NArray");
  if (NA_RANK(rblapack_gers) != 1)
    rb_raise(rb_eArgError, "rank of gers (18th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_gers) != (2*n))
    rb_raise(rb_eRuntimeError, "shape 0 of gers must be %d", 2*n);
  if (NA_TYPE(rblapack_gers) != NA_DFLOAT)
    rblapack_gers = na_change_type(rblapack_gers, NA_DFLOAT);
  gers = NA_PTR_TYPE(rblapack_gers, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = 2*MAX(1,m);
    rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_l_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  l_out__ = NA_PTR_TYPE(rblapack_l_out__, doublereal*);
  MEMCPY(l_out__, l, doublereal, NA_TOTAL(rblapack_l));
  rblapack_l = rblapack_l_out__;
  l = l_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w_out__ = NA_PTR_TYPE(rblapack_w_out__, doublereal*);
  MEMCPY(w_out__, w, doublereal, NA_TOTAL(rblapack_w));
  rblapack_w = rblapack_w_out__;
  w = w_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_werr_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  werr_out__ = NA_PTR_TYPE(rblapack_werr_out__, doublereal*);
  MEMCPY(werr_out__, werr, doublereal, NA_TOTAL(rblapack_werr));
  rblapack_werr = rblapack_werr_out__;
  werr = werr_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_wgap_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  wgap_out__ = NA_PTR_TYPE(rblapack_wgap_out__, doublereal*);
  MEMCPY(wgap_out__, wgap, doublereal, NA_TOTAL(rblapack_wgap));
  rblapack_wgap = rblapack_wgap_out__;
  wgap = wgap_out__;
  work = ALLOC_N(doublereal, (12*n));
  iwork = ALLOC_N(integer, (7*n));

  zlarrv_(&n, &vl, &vu, d, l, &pivmin, isplit, &m, &dol, &dou, &minrgp, &rtol1, &rtol2, w, werr, wgap, iblock, indexw, gers, z, &ldz, isuppz, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_z, rblapack_isuppz, rblapack_info, rblapack_d, rblapack_l, rblapack_w, rblapack_werr, rblapack_wgap);
}

void
init_lapack_zlarrv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlarrv", rblapack_zlarrv, -1);
}
ruby-lapack-1.7.2/ext/dlabad.c0000644000175000017500000000537612502221020015737 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlabad_(doublereal* small, doublereal* large);


static VALUE
rblapack_dlabad(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_small;
  doublereal small; 
  VALUE rblapack_large;
  doublereal large; 


  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  small, large = NumRu::Lapack.dlabad( small, large, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLABAD( SMALL, LARGE )\n\n*  Purpose\n*  =======\n*\n*  DLABAD takes as input the values computed by DLAMCH for underflow and\n*  overflow, and returns the square root of each of these values if the\n*  log of LARGE is sufficiently large.  This subroutine is intended to\n*  identify machines with a large exponent range, such as the Crays, and\n*  redefine the underflow and overflow limits to be the square roots of\n*  the values computed by DLAMCH.  This subroutine is needed because\n*  DLAMCH does not compensate for poor arithmetic in the upper half of\n*  the exponent range, as is found on a Cray.\n*\n\n*  Arguments\n*  =========\n*\n*  SMALL   (input/output) DOUBLE PRECISION\n*          On entry, the underflow threshold as computed by DLAMCH.\n*          On exit, if LOG10(LARGE) is sufficiently large, the square\n*          root of SMALL, otherwise unchanged.\n*\n*  LARGE   (input/output) DOUBLE PRECISION\n*          On entry, the overflow threshold as computed by DLAMCH.\n*          On exit, if LOG10(LARGE) is sufficiently large, the square\n*          root of LARGE, otherwise unchanged.\n*\n\n*  =====================================================================\n*\n*     .. Intrinsic Functions ..\n      INTRINSIC          LOG10, SQRT\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  small, large = NumRu::Lapack.dlabad( small, large, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_small = argv[0];
  rblapack_large = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  small = NUM2DBL(rblapack_small);
  large = NUM2DBL(rblapack_large);

  dlabad_(&small, &large);

  rblapack_small = rb_float_new((double)small);
  rblapack_large = rb_float_new((double)large);
  return rb_ary_new3(2, rblapack_small, rblapack_large);
}

void
init_lapack_dlabad(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlabad", rblapack_dlabad, -1);
}
ruby-lapack-1.7.2/ext/zlabrd.c0000644000175000017500000002147312502221026016010 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlabrd_(integer* m, integer* n, integer* nb, doublecomplex* a, integer* lda, doublereal* d, doublereal* e, doublecomplex* tauq, doublecomplex* taup, doublecomplex* x, integer* ldx, doublecomplex* y, integer* ldy);


static VALUE
rblapack_zlabrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_nb;
  integer nb; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_tauq;
  doublecomplex *tauq; 
  VALUE rblapack_taup;
  doublecomplex *taup; 
  VALUE rblapack_x;
  doublecomplex *x; 
  VALUE rblapack_y;
  doublecomplex *y; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;

  integer lda;
  integer n;
  integer ldx;
  integer ldy;

  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  d, e, tauq, taup, x, y, a = NumRu::Lapack.zlabrd( m, nb, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, LDY )\n\n*  Purpose\n*  =======\n*\n*  ZLABRD reduces the first NB rows and columns of a complex general\n*  m by n matrix A to upper or lower real bidiagonal form by a unitary\n*  transformation Q' * A * P, and returns the matrices X and Y which\n*  are needed to apply the transformation to the unreduced part of A.\n*\n*  If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower\n*  bidiagonal form.\n*\n*  This is an auxiliary routine called by ZGEBRD\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows in the matrix A.\n*\n*  N       (input) INTEGER\n*          The number of columns in the matrix A.\n*\n*  NB      (input) INTEGER\n*          The number of leading rows and columns of A to be reduced.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the m by n general matrix to be reduced.\n*          On exit, the first NB rows and columns of the matrix are\n*          overwritten; the rest of the array is unchanged.\n*          If m >= n, elements on and below the diagonal in the first NB\n*            columns, with the array TAUQ, represent the unitary\n*            matrix Q as a product of elementary reflectors; and\n*            elements above the diagonal in the first NB rows, with the\n*            array TAUP, represent the unitary matrix P as a product\n*            of elementary reflectors.\n*          If m < n, elements below the diagonal in the first NB\n*            columns, with the array TAUQ, represent the unitary\n*            matrix Q as a product of elementary reflectors, and\n*            elements on and above the diagonal in the first NB rows,\n*            with the array TAUP, represent the unitary matrix P as\n*            a product of elementary reflectors.\n*          See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  D       (output) DOUBLE PRECISION array, dimension (NB)\n*          The diagonal elements of the first NB rows and columns of\n*          the reduced matrix.  D(i) = A(i,i).\n*\n*  E       (output) DOUBLE PRECISION array, dimension (NB)\n*          The off-diagonal elements of the first NB rows and columns of\n*          the reduced matrix.\n*\n*  TAUQ    (output) COMPLEX*16 array dimension (NB)\n*          The scalar factors of the elementary reflectors which\n*          represent the unitary matrix Q. See Further Details.\n*\n*  TAUP    (output) COMPLEX*16 array, dimension (NB)\n*          The scalar factors of the elementary reflectors which\n*          represent the unitary matrix P. See Further Details.\n*\n*  X       (output) COMPLEX*16 array, dimension (LDX,NB)\n*          The m-by-nb matrix X required to update the unreduced part\n*          of A.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X. LDX >= max(1,M).\n*\n*  Y       (output) COMPLEX*16 array, dimension (LDY,NB)\n*          The n-by-nb matrix Y required to update the unreduced part\n*          of A.\n*\n*  LDY     (input) INTEGER\n*          The leading dimension of the array Y. LDY >= max(1,N).\n*\n\n*  Further Details\n*  ===============\n*\n*  The matrices Q and P are represented as products of elementary\n*  reflectors:\n*\n*     Q = H(1) H(2) . . . H(nb)  and  P = G(1) G(2) . . . G(nb)\n*\n*  Each H(i) and G(i) has the form:\n*\n*     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'\n*\n*  where tauq and taup are complex scalars, and v and u are complex\n*  vectors.\n*\n*  If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in\n*  A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in\n*  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n*  If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in\n*  A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in\n*  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).\n*\n*  The elements of the vectors v and u together form the m-by-nb matrix\n*  V and the nb-by-n matrix U' which are needed, with X and Y, to apply\n*  the transformation to the unreduced part of the matrix, using a block\n*  update of the form:  A := A - V*Y' - X*U'.\n*\n*  The contents of A on exit are illustrated by the following examples\n*  with nb = 2:\n*\n*  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):\n*\n*    (  1   1   u1  u1  u1 )           (  1   u1  u1  u1  u1  u1 )\n*    (  v1  1   1   u2  u2 )           (  1   1   u2  u2  u2  u2 )\n*    (  v1  v2  a   a   a  )           (  v1  1   a   a   a   a  )\n*    (  v1  v2  a   a   a  )           (  v1  v2  a   a   a   a  )\n*    (  v1  v2  a   a   a  )           (  v1  v2  a   a   a   a  )\n*    (  v1  v2  a   a   a  )\n*\n*  where a denotes an element of the original matrix which is unchanged,\n*  vi denotes an element of the vector defining H(i), and ui an element\n*  of the vector defining G(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, tauq, taup, x, y, a = NumRu::Lapack.zlabrd( m, nb, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_m = argv[0];
  rblapack_nb = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  ldy = MAX(1,n);
  nb = NUM2INT(rblapack_nb);
  ldx = MAX(1,m);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,nb);
    rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,nb);
    rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,nb);
    rblapack_tauq = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  tauq = NA_PTR_TYPE(rblapack_tauq, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,nb);
    rblapack_taup = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  taup = NA_PTR_TYPE(rblapack_taup, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = MAX(1,nb);
    rblapack_x = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = ldy;
    shape[1] = MAX(1,nb);
    rblapack_y = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  y = NA_PTR_TYPE(rblapack_y, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zlabrd_(&m, &n, &nb, a, &lda, d, e, tauq, taup, x, &ldx, y, &ldy);

  return rb_ary_new3(7, rblapack_d, rblapack_e, rblapack_tauq, rblapack_taup, rblapack_x, rblapack_y, rblapack_a);
}

void
init_lapack_zlabrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlabrd", rblapack_zlabrd, -1);
}
ruby-lapack-1.7.2/ext/ztzrzf.c0000644000175000017500000001422212502221014016072 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ztzrzf_(integer* m, integer* n, doublecomplex* a, integer* lda, doublecomplex* tau, doublecomplex* work, integer* lwork, integer* info);


static VALUE
rblapack_ztzrzf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;

  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, work, info, a = NumRu::Lapack.ztzrzf( a, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZTZRZF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A\n*  to upper triangular form by means of unitary transformations.\n*\n*  The upper trapezoidal matrix A is factored as\n*\n*     A = ( R  0 ) * Z,\n*\n*  where Z is an N-by-N unitary matrix and R is an M-by-M upper\n*  triangular matrix.\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 >= M.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the leading M-by-N upper trapezoidal part of the\n*          array A must contain the matrix to be factorized.\n*          On exit, the leading M-by-M upper triangular part of A\n*          contains the upper triangular matrix R, and elements M+1 to\n*          N of the first M rows of A, with the array TAU, represent the\n*          unitary matrix Z as a product of M elementary reflectors.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  TAU     (output) COMPLEX*16 array, dimension (M)\n*          The scalar factors of the elementary reflectors.\n*\n*  WORK    (workspace/output) COMPLEX*16 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\n*          the 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*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n*  The factorization is obtained by Householder's method.  The kth\n*  transformation matrix, Z( k ), which is used to introduce zeros into\n*  the ( m - k + 1 )th row of A, is given in the form\n*\n*     Z( k ) = ( I     0   ),\n*              ( 0  T( k ) )\n*\n*  where\n*\n*     T( k ) = I - tau*u( k )*u( k )',   u( k ) = (   1    ),\n*                                                 (   0    )\n*                                                 ( z( k ) )\n*\n*  tau is a scalar and z( k ) is an ( n - m ) element vector.\n*  tau and z( k ) are chosen to annihilate the elements of the kth row\n*  of X.\n*\n*  The scalar tau is returned in the kth element of TAU and the vector\n*  u( k ) in the kth row of A, such that the elements of z( k ) are\n*  in  a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in\n*  the upper triangular part of A.\n*\n*  Z is given by\n*\n*     Z =  Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, work, info, a = NumRu::Lapack.ztzrzf( a, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 1 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 1)", argc);
  rblapack_a = argv[0];
  if (argc == 2) {
    rblapack_lwork = argv[1];
  } 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 (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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  m = lda;
  if (rblapack_lwork == Qnil)
    lwork = m;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  ztzrzf_(&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_ztzrzf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ztzrzf", rblapack_ztzrzf, -1);
}
ruby-lapack-1.7.2/ext/dlasdq.c0000644000175000017500000002607612502221017016006 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlasdq_(char* uplo, integer* sqre, integer* n, integer* ncvt, integer* nru, integer* ncc, doublereal* d, doublereal* e, doublereal* vt, integer* ldvt, doublereal* u, integer* ldu, doublereal* c, integer* ldc, doublereal* work, integer* info);


static VALUE
rblapack_dlasdq(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_sqre;
  integer sqre; 
  VALUE rblapack_nru;
  integer nru; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_vt;
  doublereal *vt; 
  VALUE rblapack_u;
  doublereal *u; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_e_out__;
  doublereal *e_out__;
  VALUE rblapack_vt_out__;
  doublereal *vt_out__;
  VALUE rblapack_u_out__;
  doublereal *u_out__;
  VALUE rblapack_c_out__;
  doublereal *c_out__;
  doublereal *work;

  integer n;
  integer ldvt;
  integer ncvt;
  integer ldu;
  integer ldc;
  integer ncc;

  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  info, d, e, vt, u, c = NumRu::Lapack.dlasdq( uplo, sqre, nru, d, e, vt, u, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLASDQ computes the singular value decomposition (SVD) of a real\n*  (upper or lower) bidiagonal matrix with diagonal D and offdiagonal\n*  E, accumulating the transformations if desired. Letting B denote\n*  the input bidiagonal matrix, the algorithm computes orthogonal\n*  matrices Q and P such that B = Q * S * P' (P' denotes the transpose\n*  of P). The singular values S are overwritten on D.\n*\n*  The input matrix U  is changed to U  * Q  if desired.\n*  The input matrix VT is changed to P' * VT if desired.\n*  The input matrix C  is changed to Q' * C  if desired.\n*\n*  See \"Computing  Small Singular Values of Bidiagonal Matrices With\n*  Guaranteed High Relative Accuracy,\" by J. Demmel and W. Kahan,\n*  LAPACK Working Note #3, for a detailed description of the algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO  (input) CHARACTER*1\n*        On entry, UPLO specifies whether the input bidiagonal matrix\n*        is upper or lower bidiagonal, and wether it is square are\n*        not.\n*           UPLO = 'U' or 'u'   B is upper bidiagonal.\n*           UPLO = 'L' or 'l'   B is lower bidiagonal.\n*\n*  SQRE  (input) INTEGER\n*        = 0: then the input matrix is N-by-N.\n*        = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and\n*             (N+1)-by-N if UPLU = 'L'.\n*\n*        The bidiagonal matrix has\n*        N = NL + NR + 1 rows and\n*        M = N + SQRE >= N columns.\n*\n*  N     (input) INTEGER\n*        On entry, N specifies the number of rows and columns\n*        in the matrix. N must be at least 0.\n*\n*  NCVT  (input) INTEGER\n*        On entry, NCVT specifies the number of columns of\n*        the matrix VT. NCVT must be at least 0.\n*\n*  NRU   (input) INTEGER\n*        On entry, NRU specifies the number of rows of\n*        the matrix U. NRU must be at least 0.\n*\n*  NCC   (input) INTEGER\n*        On entry, NCC specifies the number of columns of\n*        the matrix C. NCC must be at least 0.\n*\n*  D     (input/output) DOUBLE PRECISION array, dimension (N)\n*        On entry, D contains the diagonal entries of the\n*        bidiagonal matrix whose SVD is desired. On normal exit,\n*        D contains the singular values in ascending order.\n*\n*  E     (input/output) DOUBLE PRECISION array.\n*        dimension is (N-1) if SQRE = 0 and N if SQRE = 1.\n*        On entry, the entries of E contain the offdiagonal entries\n*        of the bidiagonal matrix whose SVD is desired. On normal\n*        exit, E will contain 0. If the algorithm does not converge,\n*        D and E will contain the diagonal and superdiagonal entries\n*        of a bidiagonal matrix orthogonally equivalent to the one\n*        given as input.\n*\n*  VT    (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT)\n*        On entry, contains a matrix which on exit has been\n*        premultiplied by P', dimension N-by-NCVT if SQRE = 0\n*        and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0).\n*\n*  LDVT  (input) INTEGER\n*        On entry, LDVT specifies the leading dimension of VT as\n*        declared in the calling (sub) program. LDVT must be at\n*        least 1. If NCVT is nonzero LDVT must also be at least N.\n*\n*  U     (input/output) DOUBLE PRECISION array, dimension (LDU, N)\n*        On entry, contains a  matrix which on exit has been\n*        postmultiplied by Q, dimension NRU-by-N if SQRE = 0\n*        and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0).\n*\n*  LDU   (input) INTEGER\n*        On entry, LDU  specifies the leading dimension of U as\n*        declared in the calling (sub) program. LDU must be at\n*        least max( 1, NRU ) .\n*\n*  C     (input/output) DOUBLE PRECISION array, dimension (LDC, NCC)\n*        On entry, contains an N-by-NCC matrix which on exit\n*        has been premultiplied by Q'  dimension N-by-NCC if SQRE = 0\n*        and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0).\n*\n*  LDC   (input) INTEGER\n*        On entry, LDC  specifies the leading dimension of C as\n*        declared in the calling (sub) program. LDC must be at\n*        least 1. If NCC is nonzero, LDC must also be at least N.\n*\n*  WORK  (workspace) DOUBLE PRECISION array, dimension (4*N)\n*        Workspace. Only referenced if one of NCVT, NRU, or NCC is\n*        nonzero, and if N is at least 2.\n*\n*  INFO  (output) INTEGER\n*        On exit, a value of 0 indicates a successful exit.\n*        If INFO < 0, argument number -INFO is illegal.\n*        If INFO > 0, the algorithm did not converge, and INFO\n*        specifies how many superdiagonals did not converge.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, d, e, vt, u, c = NumRu::Lapack.dlasdq( uplo, sqre, nru, d, e, vt, u, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_uplo = argv[0];
  rblapack_sqre = argv[1];
  rblapack_nru = argv[2];
  rblapack_d = argv[3];
  rblapack_e = argv[4];
  rblapack_vt = argv[5];
  rblapack_u = argv[6];
  rblapack_c = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  nru = NUM2INT(rblapack_nru);
  if (!NA_IsNArray(rblapack_vt))
    rb_raise(rb_eArgError, "vt (6th argument) must be NArray");
  if (NA_RANK(rblapack_vt) != 2)
    rb_raise(rb_eArgError, "rank of vt (6th argument) must be %d", 2);
  ldvt = NA_SHAPE0(rblapack_vt);
  ncvt = NA_SHAPE1(rblapack_vt);
  if (NA_TYPE(rblapack_vt) != NA_DFLOAT)
    rblapack_vt = na_change_type(rblapack_vt, NA_DFLOAT);
  vt = NA_PTR_TYPE(rblapack_vt, doublereal*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (8th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (8th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  ncc = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  sqre = NUM2INT(rblapack_sqre);
  if (!NA_IsNArray(rblapack_u))
    rb_raise(rb_eArgError, "u (7th argument) must be NArray");
  if (NA_RANK(rblapack_u) != 2)
    rb_raise(rb_eArgError, "rank of u (7th argument) must be %d", 2);
  ldu = NA_SHAPE0(rblapack_u);
  n = NA_SHAPE1(rblapack_u);
  if (NA_TYPE(rblapack_u) != NA_DFLOAT)
    rblapack_u = na_change_type(rblapack_u, NA_DFLOAT);
  u = NA_PTR_TYPE(rblapack_u, doublereal*);
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (4th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_d) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of d must be the same as shape 1 of u");
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (5th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (sqre==0 ? n-1 : sqre==1 ? n : 0))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", sqre==0 ? n-1 : sqre==1 ? n : 0);
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = sqre==0 ? n-1 : sqre==1 ? n : 0;
    rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
  MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldvt;
    shape[1] = ncvt;
    rblapack_vt_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  vt_out__ = NA_PTR_TYPE(rblapack_vt_out__, doublereal*);
  MEMCPY(vt_out__, vt, doublereal, NA_TOTAL(rblapack_vt));
  rblapack_vt = rblapack_vt_out__;
  vt = vt_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = n;
    rblapack_u_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  u_out__ = NA_PTR_TYPE(rblapack_u_out__, doublereal*);
  MEMCPY(u_out__, u, doublereal, NA_TOTAL(rblapack_u));
  rblapack_u = rblapack_u_out__;
  u = u_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = ncc;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(doublereal, (4*n));

  dlasdq_(&uplo, &sqre, &n, &ncvt, &nru, &ncc, d, e, vt, &ldvt, u, &ldu, c, &ldc, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_info, rblapack_d, rblapack_e, rblapack_vt, rblapack_u, rblapack_c);
}

void
init_lapack_dlasdq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlasdq", rblapack_dlasdq, -1);
}
ruby-lapack-1.7.2/ext/dpbsv.c0000644000175000017500000001604212502221023015641 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dpbsv_(char* uplo, integer* n, integer* kd, integer* nrhs, doublereal* ab, integer* ldab, doublereal* b, integer* ldb, integer* info);


static VALUE
rblapack_dpbsv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublereal *ab_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;

  integer ldab;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, ab, b = NumRu::Lapack.dpbsv( uplo, kd, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  DPBSV computes the solution to a real system of linear equations\n*     A * X = B,\n*  where A is an N-by-N symmetric positive definite band matrix and X\n*  and B are N-by-NRHS matrices.\n*\n*  The Cholesky decomposition is used to factor A as\n*     A = U**T * U,  if UPLO = 'U', or\n*     A = L * L**T,  if UPLO = 'L',\n*  where U is an upper triangular band matrix, and L is a lower\n*  triangular band matrix, with the same number of superdiagonals or\n*  subdiagonals as A.  The factored form of A is then used to solve the\n*  system of equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB,N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(N,j+KD).\n*          See below for further details.\n*\n*          On exit, if INFO = 0, the triangular factor U or L from the\n*          Cholesky factorization A = U**T*U or A = L*L**T of the band\n*          matrix A, in the same storage format as A.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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 leading minor of order i of A is not\n*                positive definite, so the factorization could not be\n*                completed, and the solution has not been computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  N = 6, KD = 2, and UPLO = 'U':\n*\n*  On entry:                       On exit:\n*\n*      *    *   a13  a24  a35  a46      *    *   u13  u24  u35  u46\n*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56\n*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66\n*\n*  Similarly, if UPLO = 'L' the format of A is as follows:\n*\n*  On entry:                       On exit:\n*\n*     a11  a22  a33  a44  a55  a66     l11  l22  l33  l44  l55  l66\n*     a21  a32  a43  a54  a65   *      l21  l32  l43  l54  l65   *\n*     a31  a42  a53  a64   *    *      l31  l42  l53  l64   *    *\n*\n*  Array elements marked * are not used by the routine.\n*\n*  =====================================================================\n*\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DPBTRF, DPBTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, ab, b = NumRu::Lapack.dpbsv( uplo, kd, ab, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_uplo = argv[0];
  rblapack_kd = argv[1];
  rblapack_ab = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  kd = NUM2INT(rblapack_kd);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
  MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  dpbsv_(&uplo, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_ab, rblapack_b);
}

void
init_lapack_dpbsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dpbsv", rblapack_dpbsv, -1);
}
ruby-lapack-1.7.2/ext/cunm2l.c0000644000175000017500000001430712502221025015727 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cunm2l_(char* side, char* trans, integer* m, integer* n, integer* k, complex* a, integer* lda, complex* tau, complex* c, integer* ldc, complex* work, integer* info);


static VALUE
rblapack_cunm2l(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_tau;
  complex *tau; 
  VALUE rblapack_c;
  complex *c; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  complex *c_out__;
  complex *work;

  integer lda;
  integer k;
  integer ldc;
  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  info, c = NumRu::Lapack.cunm2l( side, trans, m, a, tau, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CUNM2L overwrites the general complex m-by-n matrix C with\n*\n*        Q * C  if SIDE = 'L' and TRANS = 'N', or\n*\n*        Q'* C  if SIDE = 'L' and TRANS = 'C', or\n*\n*        C * Q  if SIDE = 'R' and TRANS = 'N', or\n*\n*        C * Q' if SIDE = 'R' and TRANS = 'C',\n*\n*  where Q is a complex unitary matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(k) . . . H(2) H(1)\n*\n*  as returned by CGEQLF. Q is of order m if SIDE = 'L' and of order n\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q' from the Left\n*          = 'R': apply Q or Q' from the Right\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N': apply Q  (No transpose)\n*          = 'C': apply Q' (Conjugate transpose)\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) COMPLEX array, dimension (LDA,K)\n*          The i-th column must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          CGEQLF in the last k columns of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*          If SIDE = 'L', LDA >= max(1,M);\n*          if SIDE = 'R', LDA >= max(1,N).\n*\n*  TAU     (input) COMPLEX array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by CGEQLF.\n*\n*  C       (input/output) COMPLEX array, dimension (LDC,N)\n*          On entry, the m-by-n matrix C.\n*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\n*\n*  WORK    (workspace) COMPLEX array, dimension\n*                                   (N) if SIDE = 'L',\n*                                   (M) if SIDE = 'R'\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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, c = NumRu::Lapack.cunm2l( side, trans, m, a, tau, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_m = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SCOMPLEX)
    rblapack_tau = na_change_type(rblapack_tau, NA_SCOMPLEX);
  tau = NA_PTR_TYPE(rblapack_tau, complex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_SCOMPLEX)
    rblapack_c = na_change_type(rblapack_c, NA_SCOMPLEX);
  c = NA_PTR_TYPE(rblapack_c, complex*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != k)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, complex*);
  MEMCPY(c_out__, c, complex, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  work = ALLOC_N(complex, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  cunm2l_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_c);
}

void
init_lapack_cunm2l(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cunm2l", rblapack_cunm2l, -1);
}
ruby-lapack-1.7.2/ext/zpstf2.c0000644000175000017500000001265512502221021015757 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zpstf2_(char* uplo, integer* n, doublecomplex* a, integer* lda, integer* piv, integer* rank, doublereal* tol, doublereal* work, integer* info);


static VALUE
rblapack_zpstf2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_tol;
  doublereal tol; 
  VALUE rblapack_piv;
  integer *piv; 
  VALUE rblapack_rank;
  integer rank; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *a_out__;
  doublereal *work;

  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  piv, rank, info, a = NumRu::Lapack.zpstf2( uplo, a, tol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPSTF2 computes the Cholesky factorization with complete\n*  pivoting of a complex Hermitian positive semidefinite matrix A.\n*\n*  The factorization has the form\n*     P' * A * P = U' * U ,  if UPLO = 'U',\n*     P' * A * P = L  * L',  if UPLO = 'L',\n*  where U is an upper triangular matrix and L is lower triangular, and\n*  P is stored as vector PIV.\n*\n*  This algorithm does not attempt to check that A is positive\n*  semidefinite. This version of the algorithm calls level 2 BLAS.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          n by n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n by n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if INFO = 0, the factor U or L from the Cholesky\n*          factorization as above.\n*\n*  PIV     (output) INTEGER array, dimension (N)\n*          PIV is such that the nonzero entries are P( PIV(K), K ) = 1.\n*\n*  RANK    (output) INTEGER\n*          The rank of A given by the number of steps the algorithm\n*          completed.\n*\n*  TOL     (input) DOUBLE PRECISION\n*          User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) )\n*          will be used. The algorithm terminates at the (K-1)st step\n*          if the pivot <= TOL.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N)\n*          Work space.\n*\n*  INFO    (output) INTEGER\n*          < 0: If INFO = -K, the K-th argument had an illegal value,\n*          = 0: algorithm completed successfully, and\n*          > 0: the matrix A is either rank deficient with computed rank\n*               as returned in RANK, or is indefinite.  See Section 7 of\n*               LAPACK Working Note #161 for further information.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  piv, rank, info, a = NumRu::Lapack.zpstf2( uplo, a, tol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_tol = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  tol = NUM2DBL(rblapack_tol);
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_piv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  piv = NA_PTR_TYPE(rblapack_piv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(doublereal, (2*n));

  zpstf2_(&uplo, &n, a, &lda, piv, &rank, &tol, work, &info);

  free(work);
  rblapack_rank = INT2NUM(rank);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_piv, rblapack_rank, rblapack_info, rblapack_a);
}

void
init_lapack_zpstf2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zpstf2", rblapack_zpstf2, -1);
}
ruby-lapack-1.7.2/ext/dormrz.c0000644000175000017500000001715112502221025016044 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dormrz_(char* side, char* trans, integer* m, integer* n, integer* k, integer* l, doublereal* a, integer* lda, doublereal* tau, doublereal* c, integer* ldc, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dormrz(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublereal *c_out__;

  integer lda;
  integer m;
  integer k;
  integer ldc;
  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  work, info, c = NumRu::Lapack.dormrz( side, trans, l, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DORMRZ overwrites the general real M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'T':      Q**T * C       C * Q**T\n*\n*  where Q is a real orthogonal matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(1) H(2) . . . H(k)\n*\n*  as returned by DTZRZF. Q is of order M if SIDE = 'L' and of order N\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**T from the Left;\n*          = 'R': apply Q or Q**T from the Right.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'T':  Transpose, apply Q**T.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  L       (input) INTEGER\n*          The number of columns of the matrix A containing\n*          the meaningful part of the Householder reflectors.\n*          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension\n*                               (LDA,M) if SIDE = 'L',\n*                               (LDA,N) if SIDE = 'R'\n*          The i-th row must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          DTZRZF in the last k rows of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,K).\n*\n*  TAU     (input) DOUBLE PRECISION array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by DTZRZF.\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M).\n*          For optimum performance LWORK >= N*NB if SIDE = 'L', and\n*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n*          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*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.dormrz( side, trans, l, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_l = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 7) {
    rblapack_lwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  side = StringValueCStr(rblapack_side)[0];
  l = NUM2INT(rblapack_l);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  m = 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*);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  dormrz_(&side, &trans, &m, &n, &k, &l, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_dormrz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dormrz", rblapack_dormrz, -1);
}
ruby-lapack-1.7.2/ext/slaqr5.c0000644000175000017500000002714512502221017015743 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaqr5_(logical* wantt, logical* wantz, integer* kacc22, integer* n, integer* ktop, integer* kbot, integer* nshfts, real* sr, real* si, real* h, integer* ldh, integer* iloz, integer* ihiz, real* z, integer* ldz, real* v, integer* ldv, real* u, integer* ldu, integer* nv, real* wv, integer* ldwv, integer* nh, real* wh, integer* ldwh);


static VALUE
rblapack_slaqr5(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantt;
  logical wantt; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_kacc22;
  integer kacc22; 
  VALUE rblapack_ktop;
  integer ktop; 
  VALUE rblapack_kbot;
  integer kbot; 
  VALUE rblapack_sr;
  real *sr; 
  VALUE rblapack_si;
  real *si; 
  VALUE rblapack_h;
  real *h; 
  VALUE rblapack_iloz;
  integer iloz; 
  VALUE rblapack_ihiz;
  integer ihiz; 
  VALUE rblapack_z;
  real *z; 
  VALUE rblapack_nv;
  integer nv; 
  VALUE rblapack_nh;
  integer nh; 
  VALUE rblapack_sr_out__;
  real *sr_out__;
  VALUE rblapack_si_out__;
  real *si_out__;
  VALUE rblapack_h_out__;
  real *h_out__;
  VALUE rblapack_z_out__;
  real *z_out__;
  real *v;
  real *u;
  real *wv;
  real *wh;

  integer nshfts;
  integer ldh;
  integer n;
  integer ldv;
  integer ldu;
  integer ldwv;
  integer ldwh;
  integer ldz;

  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  sr, si, h, z = NumRu::Lapack.slaqr5( wantt, wantz, kacc22, ktop, kbot, sr, si, h, iloz, ihiz, z, nv, nh, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, SR, SI, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, WV, LDWV, NH, WH, LDWH )\n\n*     This auxiliary subroutine called by SLAQR0 performs a\n*     single small-bulge multi-shift QR sweep.\n*\n\n*      WANTT  (input) logical scalar\n*             WANTT = .true. if the quasi-triangular Schur factor\n*             is being computed.  WANTT is set to .false. otherwise.\n*\n*      WANTZ  (input) logical scalar\n*             WANTZ = .true. if the orthogonal Schur factor is being\n*             computed.  WANTZ is set to .false. otherwise.\n*\n*      KACC22 (input) integer with value 0, 1, or 2.\n*             Specifies the computation mode of far-from-diagonal\n*             orthogonal updates.\n*        = 0: SLAQR5 does not accumulate reflections and does not\n*             use matrix-matrix multiply to update far-from-diagonal\n*             matrix entries.\n*        = 1: SLAQR5 accumulates reflections and uses matrix-matrix\n*             multiply to update the far-from-diagonal matrix entries.\n*        = 2: SLAQR5 accumulates reflections, uses matrix-matrix\n*             multiply to update the far-from-diagonal matrix entries,\n*             and takes advantage of 2-by-2 block structure during\n*             matrix multiplies.\n*\n*      N      (input) integer scalar\n*             N is the order of the Hessenberg matrix H upon which this\n*             subroutine operates.\n*\n*      KTOP   (input) integer scalar\n*      KBOT   (input) integer scalar\n*             These are the first and last rows and columns of an\n*             isolated diagonal block upon which the QR sweep is to be\n*             applied. It is assumed without a check that\n*                       either KTOP = 1  or   H(KTOP,KTOP-1) = 0\n*             and\n*                       either KBOT = N  or   H(KBOT+1,KBOT) = 0.\n*\n*      NSHFTS (input) integer scalar\n*             NSHFTS gives the number of simultaneous shifts.  NSHFTS\n*             must be positive and even.\n*\n*      SR     (input/output) REAL array of size (NSHFTS)\n*      SI     (input/output) REAL array of size (NSHFTS)\n*             SR contains the real parts and SI contains the imaginary\n*             parts of the NSHFTS shifts of origin that define the\n*             multi-shift QR sweep.  On output SR and SI may be\n*             reordered.\n*\n*      H      (input/output) REAL array of size (LDH,N)\n*             On input H contains a Hessenberg matrix.  On output a\n*             multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied\n*             to the isolated diagonal block in rows and columns KTOP\n*             through KBOT.\n*\n*      LDH    (input) integer scalar\n*             LDH is the leading dimension of H just as declared in the\n*             calling procedure.  LDH.GE.MAX(1,N).\n*\n*      ILOZ   (input) INTEGER\n*      IHIZ   (input) INTEGER\n*             Specify the rows of Z to which transformations must be\n*             applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N\n*\n*      Z      (input/output) REAL array of size (LDZ,IHI)\n*             If WANTZ = .TRUE., then the QR Sweep orthogonal\n*             similarity transformation is accumulated into\n*             Z(ILOZ:IHIZ,ILO:IHI) from the right.\n*             If WANTZ = .FALSE., then Z is unreferenced.\n*\n*      LDZ    (input) integer scalar\n*             LDA is the leading dimension of Z just as declared in\n*             the calling procedure. LDZ.GE.N.\n*\n*      V      (workspace) REAL array of size (LDV,NSHFTS/2)\n*\n*      LDV    (input) integer scalar\n*             LDV is the leading dimension of V as declared in the\n*             calling procedure.  LDV.GE.3.\n*\n*      U      (workspace) REAL array of size\n*             (LDU,3*NSHFTS-3)\n*\n*      LDU    (input) integer scalar\n*             LDU is the leading dimension of U just as declared in the\n*             in the calling subroutine.  LDU.GE.3*NSHFTS-3.\n*\n*      NH     (input) integer scalar\n*             NH is the number of columns in array WH available for\n*             workspace. NH.GE.1.\n*\n*      WH     (workspace) REAL array of size (LDWH,NH)\n*\n*      LDWH   (input) integer scalar\n*             Leading dimension of WH just as declared in the\n*             calling procedure.  LDWH.GE.3*NSHFTS-3.\n*\n*      NV     (input) integer scalar\n*             NV is the number of rows in WV agailable for workspace.\n*             NV.GE.1.\n*\n*      WV     (workspace) REAL array of size\n*             (LDWV,3*NSHFTS-3)\n*\n*      LDWV   (input) integer scalar\n*             LDWV is the leading dimension of WV as declared in the\n*             in the calling subroutine.  LDWV.GE.NV.\n*\n\n*     ================================================================\n*     Based on contributions by\n*        Karen Braman and Ralph Byers, Department of Mathematics,\n*        University of Kansas, USA\n*\n*     ================================================================\n*     Reference:\n*\n*     K. Braman, R. Byers and R. Mathias, The Multi-Shift QR\n*     Algorithm Part I: Maintaining Well Focused Shifts, and\n*     Level 3 Performance, SIAM Journal of Matrix Analysis,\n*     volume 23, pages 929--947, 2002.\n*\n*     ================================================================\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  sr, si, h, z = NumRu::Lapack.slaqr5( wantt, wantz, kacc22, ktop, kbot, sr, si, h, iloz, ihiz, z, nv, nh, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 13 && argc != 13)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 13)", argc);
  rblapack_wantt = argv[0];
  rblapack_wantz = argv[1];
  rblapack_kacc22 = argv[2];
  rblapack_ktop = argv[3];
  rblapack_kbot = argv[4];
  rblapack_sr = argv[5];
  rblapack_si = argv[6];
  rblapack_h = argv[7];
  rblapack_iloz = argv[8];
  rblapack_ihiz = argv[9];
  rblapack_z = argv[10];
  rblapack_nv = argv[11];
  rblapack_nh = argv[12];
  if (argc == 13) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  wantt = (rblapack_wantt == Qtrue);
  kacc22 = NUM2INT(rblapack_kacc22);
  kbot = NUM2INT(rblapack_kbot);
  if (!NA_IsNArray(rblapack_si))
    rb_raise(rb_eArgError, "si (7th argument) must be NArray");
  if (NA_RANK(rblapack_si) != 1)
    rb_raise(rb_eArgError, "rank of si (7th argument) must be %d", 1);
  nshfts = NA_SHAPE0(rblapack_si);
  if (NA_TYPE(rblapack_si) != NA_SFLOAT)
    rblapack_si = na_change_type(rblapack_si, NA_SFLOAT);
  si = NA_PTR_TYPE(rblapack_si, real*);
  iloz = NUM2INT(rblapack_iloz);
  nv = NUM2INT(rblapack_nv);
  ldwv = nv;
  ldv = 3;
  wantz = (rblapack_wantz == Qtrue);
  if (!NA_IsNArray(rblapack_sr))
    rb_raise(rb_eArgError, "sr (6th argument) must be NArray");
  if (NA_RANK(rblapack_sr) != 1)
    rb_raise(rb_eArgError, "rank of sr (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_sr) != nshfts)
    rb_raise(rb_eRuntimeError, "shape 0 of sr must be the same as shape 0 of si");
  if (NA_TYPE(rblapack_sr) != NA_SFLOAT)
    rblapack_sr = na_change_type(rblapack_sr, NA_SFLOAT);
  sr = NA_PTR_TYPE(rblapack_sr, real*);
  ihiz = NUM2INT(rblapack_ihiz);
  nh = NUM2INT(rblapack_nh);
  ldu = 3*nshfts-3;
  ktop = NUM2INT(rblapack_ktop);
  ldwh = 3*nshfts-3;
  if (!NA_IsNArray(rblapack_h))
    rb_raise(rb_eArgError, "h (8th argument) must be NArray");
  if (NA_RANK(rblapack_h) != 2)
    rb_raise(rb_eArgError, "rank of h (8th argument) must be %d", 2);
  ldh = NA_SHAPE0(rblapack_h);
  n = NA_SHAPE1(rblapack_h);
  if (NA_TYPE(rblapack_h) != NA_SFLOAT)
    rblapack_h = na_change_type(rblapack_h, NA_SFLOAT);
  h = NA_PTR_TYPE(rblapack_h, real*);
  ldz = n;
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (11th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (11th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_z) != (wantz ? ldz : 0))
    rb_raise(rb_eRuntimeError, "shape 0 of z must be %d", wantz ? ldz : 0);
  if (NA_SHAPE1(rblapack_z) != (wantz ? ihiz : 0))
    rb_raise(rb_eRuntimeError, "shape 1 of z must be %d", wantz ? ihiz : 0);
  if (NA_TYPE(rblapack_z) != NA_SFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_SFLOAT);
  z = NA_PTR_TYPE(rblapack_z, real*);
  {
    na_shape_t shape[1];
    shape[0] = nshfts;
    rblapack_sr_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  sr_out__ = NA_PTR_TYPE(rblapack_sr_out__, real*);
  MEMCPY(sr_out__, sr, real, NA_TOTAL(rblapack_sr));
  rblapack_sr = rblapack_sr_out__;
  sr = sr_out__;
  {
    na_shape_t shape[1];
    shape[0] = nshfts;
    rblapack_si_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  si_out__ = NA_PTR_TYPE(rblapack_si_out__, real*);
  MEMCPY(si_out__, si, real, NA_TOTAL(rblapack_si));
  rblapack_si = rblapack_si_out__;
  si = si_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldh;
    shape[1] = n;
    rblapack_h_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  h_out__ = NA_PTR_TYPE(rblapack_h_out__, real*);
  MEMCPY(h_out__, h, real, NA_TOTAL(rblapack_h));
  rblapack_h = rblapack_h_out__;
  h = h_out__;
  {
    na_shape_t shape[2];
    shape[0] = wantz ? ldz : 0;
    shape[1] = wantz ? ihiz : 0;
    rblapack_z_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, real*);
  MEMCPY(z_out__, z, real, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;
  v = ALLOC_N(real, (ldv)*(nshfts/2));
  u = ALLOC_N(real, (ldu)*(3*nshfts-3));
  wv = ALLOC_N(real, (ldwv)*(3*nshfts-3));
  wh = ALLOC_N(real, (ldwh)*(MAX(1,nh)));

  slaqr5_(&wantt, &wantz, &kacc22, &n, &ktop, &kbot, &nshfts, sr, si, h, &ldh, &iloz, &ihiz, z, &ldz, v, &ldv, u, &ldu, &nv, wv, &ldwv, &nh, wh, &ldwh);

  free(v);
  free(u);
  free(wv);
  free(wh);
  return rb_ary_new3(4, rblapack_sr, rblapack_si, rblapack_h, rblapack_z);
}

void
init_lapack_slaqr5(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaqr5", rblapack_slaqr5, -1);
}
ruby-lapack-1.7.2/ext/zlaesy.c0000644000175000017500000001120512502221017016031 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlaesy_(doublecomplex* a, doublecomplex* b, doublecomplex* c, doublecomplex* rt1, doublecomplex* rt2, doublecomplex* evscal, doublecomplex* cs1, doublecomplex* sn1);


static VALUE
rblapack_zlaesy(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublecomplex a; 
  VALUE rblapack_b;
  doublecomplex b; 
  VALUE rblapack_c;
  doublecomplex c; 
  VALUE rblapack_rt1;
  doublecomplex rt1; 
  VALUE rblapack_rt2;
  doublecomplex rt2; 
  VALUE rblapack_evscal;
  doublecomplex evscal; 
  VALUE rblapack_cs1;
  doublecomplex cs1; 
  VALUE rblapack_sn1;
  doublecomplex sn1; 


  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  rt1, rt2, evscal, cs1, sn1 = NumRu::Lapack.zlaesy( a, b, c, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAESY( A, B, C, RT1, RT2, EVSCAL, CS1, SN1 )\n\n*  Purpose\n*  =======\n*\n*  ZLAESY computes the eigendecomposition of a 2-by-2 symmetric matrix\n*     ( ( A, B );( B, C ) )\n*  provided the norm of the matrix of eigenvectors is larger than\n*  some threshold value.\n*\n*  RT1 is the eigenvalue of larger absolute value, and RT2 of\n*  smaller absolute value.  If the eigenvectors are computed, then\n*  on return ( CS1, SN1 ) is the unit eigenvector for RT1, hence\n*\n*  [  CS1     SN1   ] . [ A  B ] . [ CS1    -SN1   ] = [ RT1  0  ]\n*  [ -SN1     CS1   ]   [ B  C ]   [ SN1     CS1   ]   [  0  RT2 ]\n*\n\n*  Arguments\n*  =========\n*\n*  A       (input) COMPLEX*16\n*          The ( 1, 1 ) element of input matrix.\n*\n*  B       (input) COMPLEX*16\n*          The ( 1, 2 ) element of input matrix.  The ( 2, 1 ) element\n*          is also given by B, since the 2-by-2 matrix is symmetric.\n*\n*  C       (input) COMPLEX*16\n*          The ( 2, 2 ) element of input matrix.\n*\n*  RT1     (output) COMPLEX*16\n*          The eigenvalue of larger modulus.\n*\n*  RT2     (output) COMPLEX*16\n*          The eigenvalue of smaller modulus.\n*\n*  EVSCAL  (output) COMPLEX*16\n*          The complex value by which the eigenvector matrix was scaled\n*          to make it orthonormal.  If EVSCAL is zero, the eigenvectors\n*          were not computed.  This means one of two things:  the 2-by-2\n*          matrix could not be diagonalized, or the norm of the matrix\n*          of eigenvectors before scaling was larger than the threshold\n*          value THRESH (set below).\n*\n*  CS1     (output) COMPLEX*16\n*  SN1     (output) COMPLEX*16\n*          If EVSCAL .NE. 0,  ( CS1, SN1 ) is the unit right eigenvector\n*          for RT1.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rt1, rt2, evscal, cs1, sn1 = NumRu::Lapack.zlaesy( a, b, c, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  rblapack_c = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  a.r = NUM2DBL(rb_funcall(rblapack_a, rb_intern("real"), 0));
  a.i = NUM2DBL(rb_funcall(rblapack_a, rb_intern("imag"), 0));
  c.r = NUM2DBL(rb_funcall(rblapack_c, rb_intern("real"), 0));
  c.i = NUM2DBL(rb_funcall(rblapack_c, rb_intern("imag"), 0));
  b.r = NUM2DBL(rb_funcall(rblapack_b, rb_intern("real"), 0));
  b.i = NUM2DBL(rb_funcall(rblapack_b, rb_intern("imag"), 0));

  zlaesy_(&a, &b, &c, &rt1, &rt2, &evscal, &cs1, &sn1);

  rblapack_rt1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(rt1.r)), rb_float_new((double)(rt1.i)));
  rblapack_rt2 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(rt2.r)), rb_float_new((double)(rt2.i)));
  rblapack_evscal = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(evscal.r)), rb_float_new((double)(evscal.i)));
  rblapack_cs1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(cs1.r)), rb_float_new((double)(cs1.i)));
  rblapack_sn1 = rb_funcall(rb_gv_get("Complex"), rb_intern("new"), 2, rb_float_new((double)(sn1.r)), rb_float_new((double)(sn1.i)));
  return rb_ary_new3(5, rblapack_rt1, rblapack_rt2, rblapack_evscal, rblapack_cs1, rblapack_sn1);
}

void
init_lapack_zlaesy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlaesy", rblapack_zlaesy, -1);
}
ruby-lapack-1.7.2/ext/dla_syamv.c0000644000175000017500000001642012502221021016500 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dla_syamv_(integer* uplo, integer* n, doublereal* alpha, doublereal* a, integer* lda, doublereal* x, integer* incx, doublereal* beta, doublereal* y, integer* incy);


static VALUE
rblapack_dla_syamv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  integer uplo; 
  VALUE rblapack_alpha;
  doublereal alpha; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_beta;
  doublereal beta; 
  VALUE rblapack_y;
  doublereal *y; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_y_out__;
  doublereal *y_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  y = NumRu::Lapack.dla_syamv( uplo, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY )\n\n*  Purpose\n*  =======\n*\n*  DLA_SYAMV  performs the matrix-vector operation\n*\n*          y := alpha*abs(A)*abs(x) + beta*abs(y),\n*\n*  where alpha and beta are scalars, x and y are vectors and A is an\n*  n by n symmetric matrix.\n*\n*  This function is primarily used in calculating error bounds.\n*  To protect against underflow during evaluation, components in\n*  the resulting vector are perturbed away from zero by (N+1)\n*  times the underflow threshold.  To prevent unnecessarily large\n*  errors for block-structure embedded in general matrices,\n*  \"symbolically\" zero components are not perturbed.  A zero\n*  entry is considered \"symbolic\" if all multiplications involved\n*  in computing that entry have at least one zero multiplicand.\n*\n\n*  Arguments\n*  ==========\n*\n*  UPLO    (input) INTEGER\n*           On entry, UPLO specifies whether the upper or lower\n*           triangular part of the array A is to be referenced as\n*           follows:\n*\n*              UPLO = BLAS_UPPER   Only the upper triangular part of A\n*                                  is to be referenced.\n*\n*              UPLO = BLAS_LOWER   Only the lower triangular part of A\n*                                  is to be referenced.\n*\n*           Unchanged on exit.\n*\n*  N       (input) INTEGER\n*           On entry, N specifies the number of columns of the matrix A.\n*           N must be at least zero.\n*           Unchanged on exit.\n*\n*  ALPHA  - DOUBLE PRECISION   .\n*           On entry, ALPHA specifies the scalar alpha.\n*           Unchanged on exit.\n*\n*  A      - DOUBLE PRECISION   array of DIMENSION ( LDA, n ).\n*           Before entry, the leading m by n part of the array A must\n*           contain the matrix of coefficients.\n*           Unchanged on exit.\n*\n*  LDA     (input) INTEGER\n*           On entry, LDA specifies the first dimension of A as declared\n*           in the calling (sub) program. LDA must be at least\n*           max( 1, n ).\n*           Unchanged on exit.\n*\n*  X       (input) DOUBLE PRECISION array, dimension\n*           ( 1 + ( n - 1 )*abs( INCX ) )\n*           Before entry, the incremented array X must contain the\n*           vector x.\n*           Unchanged on exit.\n*\n*  INCX    (input) INTEGER\n*           On entry, INCX specifies the increment for the elements of\n*           X. INCX must not be zero.\n*           Unchanged on exit.\n*\n*  BETA   - DOUBLE PRECISION   .\n*           On entry, BETA specifies the scalar beta. When BETA is\n*           supplied as zero then Y need not be set on input.\n*           Unchanged on exit.\n*\n*  Y       (input/output) DOUBLE PRECISION  array, dimension\n*           ( 1 + ( n - 1 )*abs( INCY ) )\n*           Before entry with BETA non-zero, the incremented array Y\n*           must contain the vector y. On exit, Y is overwritten by the\n*           updated vector y.\n*\n*  INCY    (input) INTEGER\n*           On entry, INCY specifies the increment for the elements of\n*           Y. INCY must not be zero.\n*           Unchanged on exit.\n*\n\n*  Further Details\n*  ===============\n*\n*  Level 2 Blas routine.\n*\n*  -- Written on 22-October-1986.\n*     Jack Dongarra, Argonne National Lab.\n*     Jeremy Du Croz, Nag Central Office.\n*     Sven Hammarling, Nag Central Office.\n*     Richard Hanson, Sandia National Labs.\n*  -- Modified for the absolute-value product, April 2006\n*     Jason Riedy, UC Berkeley\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  y = NumRu::Lapack.dla_syamv( uplo, alpha, a, x, incx, beta, y, incy, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_uplo = argv[0];
  rblapack_alpha = argv[1];
  rblapack_a = argv[2];
  rblapack_x = argv[3];
  rblapack_incx = argv[4];
  rblapack_beta = argv[5];
  rblapack_y = argv[6];
  rblapack_incy = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = NUM2INT(rblapack_uplo);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  incx = NUM2INT(rblapack_incx);
  incy = NUM2INT(rblapack_incy);
  alpha = NUM2DBL(rblapack_alpha);
  beta = NUM2DBL(rblapack_beta);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (4th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (1 + ( n - 1 )*abs( incx )))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", 1 + ( n - 1 )*abs( incx ));
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (7th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (1 + ( n - 1 )*abs( incy )))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", 1 + ( n - 1 )*abs( incy ));
  if (NA_TYPE(rblapack_y) != NA_DFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
  y = NA_PTR_TYPE(rblapack_y, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 1 + ( n - 1 )*abs( incy );
    rblapack_y_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
  MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  dla_syamv_(&uplo, &n, &alpha, a, &lda, x, &incx, &beta, y, &incy);

  return rblapack_y;
}

void
init_lapack_dla_syamv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dla_syamv", rblapack_dla_syamv, -1);
}
ruby-lapack-1.7.2/ext/clansy.c0000644000175000017500000001066512502221014016021 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern real clansy_(char* norm, char* uplo, integer* n, complex* a, integer* lda, real* work);


static VALUE
rblapack_clansy(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_norm;
  char norm; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack___out__;
  real __out__; 
  real *work;

  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  __out__ = NumRu::Lapack.clansy( norm, uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      REAL             FUNCTION CLANSY( NORM, UPLO, N, A, LDA, WORK )\n\n*  Purpose\n*  =======\n*\n*  CLANSY  returns the value of the one norm,  or the Frobenius norm, or\n*  the  infinity norm,  or the  element of  largest absolute value  of a\n*  complex symmetric matrix A.\n*\n*  Description\n*  ===========\n*\n*  CLANSY returns the value\n*\n*     CLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm'\n*              (\n*              ( norm1(A),         NORM = '1', 'O' or 'o'\n*              (\n*              ( normI(A),         NORM = 'I' or 'i'\n*              (\n*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e'\n*\n*  where  norm1  denotes the  one norm of a matrix (maximum column sum),\n*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and\n*  normF  denotes the  Frobenius norm of a matrix (square root of sum of\n*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm.\n*\n\n*  Arguments\n*  =========\n*\n*  NORM    (input) CHARACTER*1\n*          Specifies the value to be returned in CLANSY as described\n*          above.\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          symmetric matrix A is to be referenced.\n*          = 'U':  Upper triangular part of A is referenced\n*          = 'L':  Lower triangular part of A is referenced\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.  When N = 0, CLANSY is\n*          set to zero.\n*\n*  A       (input) COMPLEX array, dimension (LDA,N)\n*          The symmetric matrix A.  If UPLO = 'U', the leading n by n\n*          upper triangular part of A contains the upper triangular part\n*          of the matrix A, and the strictly lower triangular part of A\n*          is not referenced.  If UPLO = 'L', the leading n by n lower\n*          triangular part of A contains the lower triangular part of\n*          the matrix A, and the strictly upper triangular part of A is\n*          not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(N,1).\n*\n*  WORK    (workspace) REAL array, dimension (MAX(1,LWORK)),\n*          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,\n*          WORK is not referenced.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.clansy( norm, uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_norm = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  norm = StringValueCStr(rblapack_norm)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  work = ALLOC_N(real, (MAX(1,(lsame_(&norm,"I")||lsame_(&norm,"1")||lsame_(&norm,"o")) ? n : 0)));

  __out__ = clansy_(&norm, &uplo, &n, a, &lda, work);

  free(work);
  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_clansy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clansy", rblapack_clansy, -1);
}
ruby-lapack-1.7.2/ext/zstemr.c0000644000175000017500000004110412502221022016043 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zstemr_(char* jobz, char* range, integer* n, doublereal* d, doublereal* e, doublereal* vl, doublereal* vu, integer* il, integer* iu, integer* m, doublereal* w, doublecomplex* z, integer* ldz, integer* nzc, integer* isuppz, logical* tryrac, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_zstemr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_vl;
  doublereal vl; 
  VALUE rblapack_vu;
  doublereal vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_nzc;
  integer nzc; 
  VALUE rblapack_tryrac;
  logical tryrac; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_isuppz;
  integer *isuppz; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_e_out__;
  doublereal *e_out__;

  integer n;
  integer ldz;

  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  m, w, z, isuppz, work, iwork, info, d, e, tryrac = NumRu::Lapack.zstemr( jobz, range, d, e, vl, vu, il, iu, nzc, tryrac, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZSTEMR computes selected eigenvalues and, optionally, eigenvectors\n*  of a real symmetric tridiagonal matrix T. Any such unreduced matrix has\n*  a well defined set of pairwise different real eigenvalues, the corresponding\n*  real eigenvectors are pairwise orthogonal.\n*\n*  The spectrum may be computed either completely or partially by specifying\n*  either an interval (VL,VU] or a range of indices IL:IU for the desired\n*  eigenvalues.\n*\n*  Depending on the number of desired eigenvalues, these are computed either\n*  by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are\n*  computed by the use of various suitable L D L^T factorizations near clusters\n*  of close eigenvalues (referred to as RRRs, Relatively Robust\n*  Representations). An informal sketch of the algorithm follows.\n*\n*  For each unreduced block (submatrix) of T,\n*     (a) Compute T - sigma I  = L D L^T, so that L and D\n*         define all the wanted eigenvalues to high relative accuracy.\n*         This means that small relative changes in the entries of D and L\n*         cause only small relative changes in the eigenvalues and\n*         eigenvectors. The standard (unfactored) representation of the\n*         tridiagonal matrix T does not have this property in general.\n*     (b) Compute the eigenvalues to suitable accuracy.\n*         If the eigenvectors are desired, the algorithm attains full\n*         accuracy of the computed eigenvalues only right before\n*         the corresponding vectors have to be computed, see steps c) and d).\n*     (c) For each cluster of close eigenvalues, select a new\n*         shift close to the cluster, find a new factorization, and refine\n*         the shifted eigenvalues to suitable accuracy.\n*     (d) For each eigenvalue with a large enough relative separation compute\n*         the corresponding eigenvector by forming a rank revealing twisted\n*         factorization. Go back to (c) for any clusters that remain.\n*\n*  For more details, see:\n*  - Inderjit S. Dhillon and Beresford N. Parlett: \"Multiple representations\n*    to compute orthogonal eigenvectors of symmetric tridiagonal matrices,\"\n*    Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.\n*  - Inderjit Dhillon and Beresford Parlett: \"Orthogonal Eigenvectors and\n*    Relative Gaps,\" SIAM Journal on Matrix Analysis and Applications, Vol. 25,\n*    2004.  Also LAPACK Working Note 154.\n*  - Inderjit Dhillon: \"A new O(n^2) algorithm for the symmetric\n*    tridiagonal eigenvalue/eigenvector problem\",\n*    Computer Science Division Technical Report No. UCB/CSD-97-971,\n*    UC Berkeley, May 1997.\n*\n*  Further Details\n*  1.ZSTEMR works only on machines which follow IEEE-754\n*  floating-point standard in their handling of infinities and NaNs.\n*  This permits the use of efficient inner loops avoiding a check for\n*  zero divisors.\n*\n*  2. LAPACK routines can be used to reduce a complex Hermitean matrix to\n*  real symmetric tridiagonal form.\n*\n*  (Any complex Hermitean tridiagonal matrix has real values on its diagonal\n*  and potentially complex numbers on its off-diagonals. By applying a\n*  similarity transform with an appropriate diagonal matrix\n*  diag(1,e^{i \\phy_1}, ... , e^{i \\phy_{n-1}}), the complex Hermitean\n*  matrix can be transformed into a real symmetric matrix and complex\n*  arithmetic can be entirely avoided.)\n*\n*  While the eigenvectors of the real symmetric tridiagonal matrix are real,\n*  the eigenvectors of original complex Hermitean matrix have complex entries\n*  in general.\n*  Since LAPACK drivers overwrite the matrix data with the eigenvectors,\n*  ZSTEMR accepts complex workspace to facilitate interoperability\n*  with ZUNMTR or ZUPMTR.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found.\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found.\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the N diagonal elements of the tridiagonal matrix\n*          T. On exit, D is overwritten.\n*\n*  E       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the (N-1) subdiagonal elements of the tridiagonal\n*          matrix T in elements 1 to N-1 of E. E(N) need not be set on\n*          input, but is used internally as workspace.\n*          On exit, E is overwritten.\n*\n*  VL      (input) DOUBLE PRECISION\n*  VU      (input) DOUBLE PRECISION\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          The first M elements contain the selected eigenvalues in\n*          ascending order.\n*\n*  Z       (output) COMPLEX*16 array, dimension (LDZ, max(1,M) )\n*          If JOBZ = 'V', and if INFO = 0, then the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix T\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and can be computed with a workspace\n*          query by setting NZC = -1, see below.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', then LDZ >= max(1,N).\n*\n*  NZC     (input) INTEGER\n*          The number of eigenvectors to be held in the array Z.\n*          If RANGE = 'A', then NZC >= max(1,N).\n*          If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].\n*          If RANGE = 'I', then NZC >= IU-IL+1.\n*          If NZC = -1, then a workspace query is assumed; the\n*          routine calculates the number of columns of the array Z that\n*          are needed to hold the eigenvectors.\n*          This value is returned as the first entry of the Z array, and\n*          no error message related to NZC is issued by XERBLA.\n*\n*  ISUPPZ  (output) INTEGER ARRAY, dimension ( 2*max(1,M) )\n*          The support of the eigenvectors in Z, i.e., the indices\n*          indicating the nonzero elements in Z. The i-th computed eigenvector\n*          is nonzero only in elements ISUPPZ( 2*i-1 ) through\n*          ISUPPZ( 2*i ). This is relevant in the case when the matrix\n*          is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.\n*\n*  TRYRAC  (input/output) LOGICAL\n*          If TRYRAC.EQ..TRUE., indicates that the code should check whether\n*          the tridiagonal matrix defines its eigenvalues to high relative\n*          accuracy.  If so, the code uses relative-accuracy preserving\n*          algorithms that might be (a bit) slower depending on the matrix.\n*          If the matrix does not define its eigenvalues to high relative\n*          accuracy, the code can uses possibly faster algorithms.\n*          If TRYRAC.EQ..FALSE., the code is not required to guarantee\n*          relatively accurate eigenvalues and can use the fastest possible\n*          techniques.\n*          On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix\n*          does not define its eigenvalues to high relative accuracy.\n*\n*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK)\n*          On exit, if INFO = 0, WORK(1) returns the optimal\n*          (and minimal) LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK. LWORK >= max(1,18*N)\n*          if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = '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*  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.  LIWORK >= max(1,10*N)\n*          if the eigenvectors are desired, and LIWORK >= max(1,8*N)\n*          if only the eigenvalues are to be computed.\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal size of the IWORK array,\n*          returns this value as the first entry of the IWORK array, and\n*          no error message related to LIWORK is issued by XERBLA.\n*\n*  INFO    (output) INTEGER\n*          On exit, INFO\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*          > 0:  if INFO = 1X, internal error in DLARRE,\n*                if INFO = 2X, internal error in ZLARRV.\n*                Here, the digit X = ABS( IINFO ) < 10, where IINFO is\n*                the nonzero error code returned by DLARRE or\n*                ZLARRV, respectively.\n*\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Beresford Parlett, University of California, Berkeley, USA\n*     Jim Demmel, University of California, Berkeley, USA\n*     Inderjit Dhillon, University of Texas, Austin, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Christof Voemel, University of California, Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, isuppz, work, iwork, info, d, e, tryrac = NumRu::Lapack.zstemr( jobz, range, d, e, vl, vu, il, iu, nzc, tryrac, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_d = argv[2];
  rblapack_e = argv[3];
  rblapack_vl = argv[4];
  rblapack_vu = argv[5];
  rblapack_il = argv[6];
  rblapack_iu = argv[7];
  rblapack_nzc = argv[8];
  rblapack_tryrac = argv[9];
  if (argc == 12) {
    rblapack_lwork = argv[10];
    rblapack_liwork = argv[11];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  vl = NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  nzc = NUM2INT(rblapack_nzc);
  range = StringValueCStr(rblapack_range)[0];
  vu = NUM2DBL(rblapack_vu);
  tryrac = (rblapack_tryrac == Qtrue);
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (4th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of e must be the same as shape 0 of d");
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&jobz,"V") ? 18*n : lsame_(&jobz,"N") ? 12*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  iu = NUM2INT(rblapack_iu);
  m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
  if (rblapack_liwork == Qnil)
    liwork = lsame_(&jobz,"V") ? 10*n : lsame_(&jobz,"N") ? 8*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = 2*MAX(1,m);
    rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
  MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;

  zstemr_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &m, w, z, &ldz, &nzc, isuppz, &tryrac, work, &lwork, iwork, &liwork, &info);

  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  rblapack_tryrac = tryrac ? Qtrue : Qfalse;
  return rb_ary_new3(10, rblapack_m, rblapack_w, rblapack_z, rblapack_isuppz, rblapack_work, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e, rblapack_tryrac);
}

void
init_lapack_zstemr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zstemr", rblapack_zstemr, -1);
}
ruby-lapack-1.7.2/ext/dsbgv.c0000644000175000017500000002052212502221025015630 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsbgv_(char* jobz, char* uplo, integer* n, integer* ka, integer* kb, doublereal* ab, integer* ldab, doublereal* bb, integer* ldbb, doublereal* w, doublereal* z, integer* ldz, doublereal* work, integer* info);


static VALUE
rblapack_dsbgv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ka;
  integer ka; 
  VALUE rblapack_kb;
  integer kb; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_bb;
  doublereal *bb; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublereal *ab_out__;
  VALUE rblapack_bb_out__;
  doublereal *bb_out__;
  doublereal *work;

  integer ldab;
  integer n;
  integer ldbb;
  integer ldz;

  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  w, z, info, ab, bb = NumRu::Lapack.dsbgv( jobz, uplo, ka, kb, ab, bb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, LDZ, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSBGV computes all the eigenvalues, and optionally, the eigenvectors\n*  of a real generalized symmetric-definite banded eigenproblem, of\n*  the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric\n*  and banded, and B is also positive definite.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangles of A and B are stored;\n*          = 'L':  Lower triangles of A and B are stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  KA      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'. KA >= 0.\n*\n*  KB      (input) INTEGER\n*          The number of superdiagonals of the matrix B if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'. KB >= 0.\n*\n*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB, N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first ka+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka).\n*\n*          On exit, the contents of AB are destroyed.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KA+1.\n*\n*  BB      (input/output) DOUBLE PRECISION array, dimension (LDBB, N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix B, stored in the first kb+1 rows of the array.  The\n*          j-th column of B is stored in the j-th column of the array BB\n*          as follows:\n*          if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;\n*          if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb).\n*\n*          On exit, the factor S from the split Cholesky factorization\n*          B = S**T*S, as returned by DPBSTF.\n*\n*  LDBB    (input) INTEGER\n*          The leading dimension of the array BB.  LDBB >= KB+1.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of\n*          eigenvectors, with the i-th column of Z holding the\n*          eigenvector associated with W(i). The eigenvectors are\n*          normalized so that Z**T*B*Z = I.\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= N.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (3*N)\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, and i is:\n*             <= N:  the algorithm failed to converge:\n*                    i off-diagonal elements of an intermediate\n*                    tridiagonal form did not converge to zero;\n*             > N:   if INFO = N + i, for 1 <= i <= N, then DPBSTF\n*                    returned INFO = i: B is not positive definite.\n*                    The factorization of B could not be completed and\n*                    no eigenvalues or eigenvectors were computed.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            UPPER, WANTZ\n      CHARACTER          VECT\n      INTEGER            IINFO, INDE, INDWRK\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           DPBSTF, DSBGST, DSBTRD, DSTEQR, DSTERF, XERBLA\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, info, ab, bb = NumRu::Lapack.dsbgv( jobz, uplo, ka, kb, ab, bb, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_ka = argv[2];
  rblapack_kb = argv[3];
  rblapack_ab = argv[4];
  rblapack_bb = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  ka = NUM2INT(rblapack_ka);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_bb))
    rb_raise(rb_eArgError, "bb (6th argument) must be NArray");
  if (NA_RANK(rblapack_bb) != 2)
    rb_raise(rb_eArgError, "rank of bb (6th argument) must be %d", 2);
  ldbb = NA_SHAPE0(rblapack_bb);
  if (NA_SHAPE1(rblapack_bb) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of bb must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_bb) != NA_DFLOAT)
    rblapack_bb = na_change_type(rblapack_bb, NA_DFLOAT);
  bb = NA_PTR_TYPE(rblapack_bb, doublereal*);
  kb = NUM2INT(rblapack_kb);
  ldz = lsame_(&jobz,"V") ? n : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
  MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldbb;
    shape[1] = n;
    rblapack_bb_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  bb_out__ = NA_PTR_TYPE(rblapack_bb_out__, doublereal*);
  MEMCPY(bb_out__, bb, doublereal, NA_TOTAL(rblapack_bb));
  rblapack_bb = rblapack_bb_out__;
  bb = bb_out__;
  work = ALLOC_N(doublereal, (3*n));

  dsbgv_(&jobz, &uplo, &n, &ka, &kb, ab, &ldab, bb, &ldbb, w, z, &ldz, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_w, rblapack_z, rblapack_info, rblapack_ab, rblapack_bb);
}

void
init_lapack_dsbgv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsbgv", rblapack_dsbgv, -1);
}
ruby-lapack-1.7.2/ext/cgghrd.c0000644000175000017500000002354712502221015015772 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgghrd_(char* compq, char* compz, integer* n, integer* ilo, integer* ihi, complex* a, integer* lda, complex* b, integer* ldb, complex* q, integer* ldq, complex* z, integer* ldz, integer* info);


static VALUE
rblapack_cgghrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_compq;
  char compq; 
  VALUE rblapack_compz;
  char compz; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_q;
  complex *q; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;
  VALUE rblapack_q_out__;
  complex *q_out__;
  VALUE rblapack_z_out__;
  complex *z_out__;

  integer lda;
  integer n;
  integer ldb;
  integer ldq;
  integer ldz;

  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  info, a, b, q, z = NumRu::Lapack.cgghrd( compq, compz, ilo, ihi, a, b, q, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGGHRD reduces a pair of complex matrices (A,B) to generalized upper\n*  Hessenberg form using unitary transformations, where A is a\n*  general matrix and B is upper triangular.  The form of the generalized\n*  eigenvalue problem is\n*     A*x = lambda*B*x,\n*  and B is typically made upper triangular by computing its QR\n*  factorization and moving the unitary matrix Q to the left side\n*  of the equation.\n*\n*  This subroutine simultaneously reduces A to a Hessenberg matrix H:\n*     Q**H*A*Z = H\n*  and transforms B to another upper triangular matrix T:\n*     Q**H*B*Z = T\n*  in order to reduce the problem to its standard form\n*     H*y = lambda*T*y\n*  where y = Z**H*x.\n*\n*  The unitary matrices Q and Z are determined as products of Givens\n*  rotations.  They may either be formed explicitly, or they may be\n*  postmultiplied into input matrices Q1 and Z1, so that\n*       Q1 * A * Z1**H = (Q1*Q) * H * (Z1*Z)**H\n*       Q1 * B * Z1**H = (Q1*Q) * T * (Z1*Z)**H\n*  If Q1 is the unitary matrix from the QR factorization of B in the\n*  original equation A*x = lambda*B*x, then CGGHRD reduces the original\n*  problem to generalized Hessenberg form.\n*\n\n*  Arguments\n*  =========\n*\n*  COMPQ   (input) CHARACTER*1\n*          = 'N': do not compute Q;\n*          = 'I': Q is initialized to the unit matrix, and the\n*                 unitary matrix Q is returned;\n*          = 'V': Q must contain a unitary matrix Q1 on entry,\n*                 and the product Q1*Q is returned.\n*\n*  COMPZ   (input) CHARACTER*1\n*          = 'N': do not compute Q;\n*          = 'I': Q is initialized to the unit matrix, and the\n*                 unitary matrix Q is returned;\n*          = 'V': Q must contain a unitary matrix Q1 on entry,\n*                 and the product Q1*Q is returned.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          ILO and IHI mark the rows and columns of A which are to be\n*          reduced.  It is assumed that A is already upper triangular\n*          in rows and columns 1:ILO-1 and IHI+1:N.  ILO and IHI are\n*          normally set by a previous call to CGGBAL; otherwise they\n*          should be set to 1 and N respectively.\n*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA, N)\n*          On entry, the N-by-N general matrix to be reduced.\n*          On exit, the upper triangle and the first subdiagonal of A\n*          are overwritten with the upper Hessenberg matrix H, and the\n*          rest is set to zero.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX array, dimension (LDB, N)\n*          On entry, the N-by-N upper triangular matrix B.\n*          On exit, the upper triangular matrix T = Q**H B Z.  The\n*          elements below the diagonal are set to zero.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  Q       (input/output) COMPLEX array, dimension (LDQ, N)\n*          On entry, if COMPQ = 'V', the unitary matrix Q1, typically\n*          from the QR factorization of B.\n*          On exit, if COMPQ='I', the unitary matrix Q, and if\n*          COMPQ = 'V', the product Q1*Q.\n*          Not referenced if COMPQ='N'.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.\n*          LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.\n*\n*  Z       (input/output) COMPLEX array, dimension (LDZ, N)\n*          On entry, if COMPZ = 'V', the unitary matrix Z1.\n*          On exit, if COMPZ='I', the unitary matrix Z, and if\n*          COMPZ = 'V', the product Z1*Z.\n*          Not referenced if COMPZ='N'.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.\n*          LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.\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*  This routine reduces A to Hessenberg and B to triangular form by\n*  an unblocked reduction, as described in _Matrix_Computations_,\n*  by Golub and van Loan (Johns Hopkins Press).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a, b, q, z = NumRu::Lapack.cgghrd( compq, compz, ilo, ihi, a, b, q, z, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_compq = argv[0];
  rblapack_compz = argv[1];
  rblapack_ilo = argv[2];
  rblapack_ihi = argv[3];
  rblapack_a = argv[4];
  rblapack_b = argv[5];
  rblapack_q = argv[6];
  rblapack_z = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  compq = StringValueCStr(rblapack_compq)[0];
  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (7th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_q) != NA_SCOMPLEX)
    rblapack_q = na_change_type(rblapack_q, NA_SCOMPLEX);
  q = NA_PTR_TYPE(rblapack_q, complex*);
  compz = StringValueCStr(rblapack_compz)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  ihi = NUM2INT(rblapack_ihi);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (8th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  if (NA_SHAPE1(rblapack_z) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, complex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, complex*);
  MEMCPY(q_out__, q, complex, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
  MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  cgghrd_(&compq, &compz, &n, &ilo, &ihi, a, &lda, b, &ldb, q, &ldq, z, &ldz, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z);
}

void
init_lapack_cgghrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgghrd", rblapack_cgghrd, -1);
}
ruby-lapack-1.7.2/ext/cggsvd.c0000644000175000017500000003250412502221012015777 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cggsvd_(char* jobu, char* jobv, char* jobq, integer* m, integer* n, integer* p, integer* k, integer* l, complex* a, integer* lda, complex* b, integer* ldb, real* alpha, real* beta, complex* u, integer* ldu, complex* v, integer* ldv, complex* q, integer* ldq, complex* work, real* rwork, integer* iwork, integer* info);


static VALUE
rblapack_cggsvd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobu;
  char jobu; 
  VALUE rblapack_jobv;
  char jobv; 
  VALUE rblapack_jobq;
  char jobq; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_k;
  integer k; 
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_alpha;
  real *alpha; 
  VALUE rblapack_beta;
  real *beta; 
  VALUE rblapack_u;
  complex *u; 
  VALUE rblapack_v;
  complex *v; 
  VALUE rblapack_q;
  complex *q; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;
  complex *work;
  real *rwork;

  integer lda;
  integer n;
  integer ldb;
  integer ldu;
  integer m;
  integer ldv;
  integer p;
  integer ldq;

  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  k, l, alpha, beta, u, v, q, iwork, info, a, b = NumRu::Lapack.cggsvd( jobu, jobv, jobq, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGGSVD( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B, LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, RWORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGGSVD computes the generalized singular value decomposition (GSVD)\n*  of an M-by-N complex matrix A and P-by-N complex matrix B:\n*\n*        U'*A*Q = D1*( 0 R ),    V'*B*Q = D2*( 0 R )\n*\n*  where U, V and Q are unitary matrices, and Z' means the conjugate\n*  transpose of Z.  Let K+L = the effective numerical rank of the\n*  matrix (A',B')', then R is a (K+L)-by-(K+L) nonsingular upper\n*  triangular matrix, D1 and D2 are M-by-(K+L) and P-by-(K+L) \"diagonal\"\n*  matrices and of the following structures, respectively:\n*\n*  If M-K-L >= 0,\n*\n*                      K  L\n*         D1 =     K ( I  0 )\n*                  L ( 0  C )\n*              M-K-L ( 0  0 )\n*\n*                    K  L\n*         D2 =   L ( 0  S )\n*              P-L ( 0  0 )\n*\n*                  N-K-L  K    L\n*    ( 0 R ) = K (  0   R11  R12 )\n*              L (  0    0   R22 )\n*  where\n*\n*    C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),\n*    S = diag( BETA(K+1),  ... , BETA(K+L) ),\n*    C**2 + S**2 = I.\n*\n*    R is stored in A(1:K+L,N-K-L+1:N) on exit.\n*\n*  If M-K-L < 0,\n*\n*                    K M-K K+L-M\n*         D1 =   K ( I  0    0   )\n*              M-K ( 0  C    0   )\n*\n*                      K M-K K+L-M\n*         D2 =   M-K ( 0  S    0  )\n*              K+L-M ( 0  0    I  )\n*                P-L ( 0  0    0  )\n*\n*                     N-K-L  K   M-K  K+L-M\n*    ( 0 R ) =     K ( 0    R11  R12  R13  )\n*                M-K ( 0     0   R22  R23  )\n*              K+L-M ( 0     0    0   R33  )\n*\n*  where\n*\n*    C = diag( ALPHA(K+1), ... , ALPHA(M) ),\n*    S = diag( BETA(K+1),  ... , BETA(M) ),\n*    C**2 + S**2 = I.\n*\n*    (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored\n*    ( 0  R22 R23 )\n*    in B(M-K+1:L,N+M-K-L+1:N) on exit.\n*\n*  The routine computes C, S, R, and optionally the unitary\n*  transformation matrices U, V and Q.\n*\n*  In particular, if B is an N-by-N nonsingular matrix, then the GSVD of\n*  A and B implicitly gives the SVD of A*inv(B):\n*                       A*inv(B) = U*(D1*inv(D2))*V'.\n*  If ( A',B')' has orthnormal columns, then the GSVD of A and B is also\n*  equal to the CS decomposition of A and B. Furthermore, the GSVD can\n*  be used to derive the solution of the eigenvalue problem:\n*                       A'*A x = lambda* B'*B x.\n*  In some literature, the GSVD of A and B is presented in the form\n*                   U'*A*X = ( 0 D1 ),   V'*B*X = ( 0 D2 )\n*  where U and V are orthogonal and X is nonsingular, and D1 and D2 are\n*  ``diagonal''.  The former GSVD form can be converted to the latter\n*  form by taking the nonsingular matrix X as\n*\n*                        X = Q*(  I   0    )\n*                              (  0 inv(R) )\n*\n\n*  Arguments\n*  =========\n*\n*  JOBU    (input) CHARACTER*1\n*          = 'U':  Unitary matrix U is computed;\n*          = 'N':  U is not computed.\n*\n*  JOBV    (input) CHARACTER*1\n*          = 'V':  Unitary matrix V is computed;\n*          = 'N':  V is not computed.\n*\n*  JOBQ    (input) CHARACTER*1\n*          = 'Q':  Unitary matrix Q is computed;\n*          = 'N':  Q is not computed.\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 matrices A and B.  N >= 0.\n*\n*  P       (input) INTEGER\n*          The number of rows of the matrix B.  P >= 0.\n*\n*  K       (output) INTEGER\n*  L       (output) INTEGER\n*          On exit, K and L specify the dimension of the subblocks\n*          described in Purpose.\n*          K + L = effective numerical rank of (A',B')'.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, A contains the triangular matrix R, or part of R.\n*          See Purpose for details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,M).\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,N)\n*          On entry, the P-by-N matrix B.\n*          On exit, B contains part of the triangular matrix R if\n*          M-K-L < 0.  See Purpose for details.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,P).\n*\n*  ALPHA   (output) REAL array, dimension (N)\n*  BETA    (output) REAL array, dimension (N)\n*          On exit, ALPHA and BETA contain the generalized singular\n*          value pairs of A and B;\n*            ALPHA(1:K) = 1,\n*            BETA(1:K)  = 0,\n*          and if M-K-L >= 0,\n*            ALPHA(K+1:K+L) = C,\n*            BETA(K+1:K+L)  = S,\n*          or if M-K-L < 0,\n*            ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0\n*            BETA(K+1:M) = S, BETA(M+1:K+L) = 1\n*          and\n*            ALPHA(K+L+1:N) = 0\n*            BETA(K+L+1:N)  = 0\n*\n*  U       (output) COMPLEX array, dimension (LDU,M)\n*          If JOBU = 'U', U contains the M-by-M unitary matrix U.\n*          If JOBU = 'N', U is not referenced.\n*\n*  LDU     (input) INTEGER\n*          The leading dimension of the array U. LDU >= max(1,M) if\n*          JOBU = 'U'; LDU >= 1 otherwise.\n*\n*  V       (output) COMPLEX array, dimension (LDV,P)\n*          If JOBV = 'V', V contains the P-by-P unitary matrix V.\n*          If JOBV = 'N', V is not referenced.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V. LDV >= max(1,P) if\n*          JOBV = 'V'; LDV >= 1 otherwise.\n*\n*  Q       (output) COMPLEX array, dimension (LDQ,N)\n*          If JOBQ = 'Q', Q contains the N-by-N unitary matrix Q.\n*          If JOBQ = 'N', Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q. LDQ >= max(1,N) if\n*          JOBQ = 'Q'; LDQ >= 1 otherwise.\n*\n*  WORK    (workspace) COMPLEX array, dimension (max(3*N,M,P)+N)\n*\n*  RWORK   (workspace) REAL array, dimension (2*N)\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (N)\n*          On exit, IWORK stores the sorting information. More\n*          precisely, the following loop will sort ALPHA\n*             for I = K+1, min(M,K+L)\n*                 swap ALPHA(I) and ALPHA(IWORK(I))\n*             endfor\n*          such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N).\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 = 1, the Jacobi-type procedure failed to\n*                converge.  For further details, see subroutine CTGSJA.\n*\n*  Internal Parameters\n*  ===================\n*\n*  TOLA    REAL\n*  TOLB    REAL\n*          TOLA and TOLB are the thresholds to determine the effective\n*          rank of (A',B')'. Generally, they are set to\n*                   TOLA = MAX(M,N)*norm(A)*MACHEPS,\n*                   TOLB = MAX(P,N)*norm(B)*MACHEPS.\n*          The size of TOLA and TOLB may affect the size of backward\n*          errors of the decomposition.\n*\n\n*  Further Details\n*  ===============\n*\n*  2-96 Based on modifications by\n*     Ming Gu and Huan Ren, Computer Science Division, University of\n*     California at Berkeley, USA\n*\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      LOGICAL            WANTQ, WANTU, WANTV\n      INTEGER            I, IBND, ISUB, J, NCYCLE\n      REAL               ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      REAL               CLANGE, SLAMCH\n      EXTERNAL           LSAME, CLANGE, SLAMCH\n*     ..\n*     .. External Subroutines ..\n      EXTERNAL           CGGSVP, CTGSJA, SCOPY, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX, MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  k, l, alpha, beta, u, v, q, iwork, info, a, b = NumRu::Lapack.cggsvd( jobu, jobv, jobq, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_jobu = argv[0];
  rblapack_jobv = argv[1];
  rblapack_jobq = argv[2];
  rblapack_a = argv[3];
  rblapack_b = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobu = StringValueCStr(rblapack_jobu)[0];
  jobq = StringValueCStr(rblapack_jobq)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  p = ldb;
  jobv = StringValueCStr(rblapack_jobv)[0];
  ldv = lsame_(&jobv,"V") ? MAX(1,p) : 1;
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  ldq = lsame_(&jobq,"Q") ? MAX(1,n) : 1;
  m = lda;
  ldu = lsame_(&jobu,"U") ? MAX(1,m) : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alpha = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  alpha = NA_PTR_TYPE(rblapack_alpha, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldu;
    shape[1] = m;
    rblapack_u = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  u = NA_PTR_TYPE(rblapack_u, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = p;
    rblapack_v = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  v = NA_PTR_TYPE(rblapack_v, complex*);
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  q = NA_PTR_TYPE(rblapack_q, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(complex, (MAX(3*n,m)*(p)+n));
  rwork = ALLOC_N(real, (2*n));

  cggsvd_(&jobu, &jobv, &jobq, &m, &n, &p, &k, &l, a, &lda, b, &ldb, alpha, beta, u, &ldu, v, &ldv, q, &ldq, work, rwork, iwork, &info);

  free(work);
  free(rwork);
  rblapack_k = INT2NUM(k);
  rblapack_l = INT2NUM(l);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(11, rblapack_k, rblapack_l, rblapack_alpha, rblapack_beta, rblapack_u, rblapack_v, rblapack_q, rblapack_iwork, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_cggsvd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cggsvd", rblapack_cggsvd, -1);
}
ruby-lapack-1.7.2/ext/dlaexc.c0000644000175000017500000001330012502221020015752 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlaexc_(logical* wantq, integer* n, doublereal* t, integer* ldt, doublereal* q, integer* ldq, integer* j1, integer* n1, integer* n2, doublereal* work, integer* info);


static VALUE
rblapack_dlaexc(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantq;
  logical wantq; 
  VALUE rblapack_t;
  doublereal *t; 
  VALUE rblapack_q;
  doublereal *q; 
  VALUE rblapack_j1;
  integer j1; 
  VALUE rblapack_n1;
  integer n1; 
  VALUE rblapack_n2;
  integer n2; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_t_out__;
  doublereal *t_out__;
  VALUE rblapack_q_out__;
  doublereal *q_out__;
  doublereal *work;

  integer ldt;
  integer n;
  integer ldq;

  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  info, t, q = NumRu::Lapack.dlaexc( wantq, t, q, j1, n1, n2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in\n*  an upper quasi-triangular matrix T by an orthogonal similarity\n*  transformation.\n*\n*  T must be in Schur canonical form, that is, block upper triangular\n*  with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block\n*  has its diagonal elemnts equal and its off-diagonal elements of\n*  opposite sign.\n*\n\n*  Arguments\n*  =========\n*\n*  WANTQ   (input) LOGICAL\n*          = .TRUE. : accumulate the transformation in the matrix Q;\n*          = .FALSE.: do not accumulate the transformation.\n*\n*  N       (input) INTEGER\n*          The order of the matrix T. N >= 0.\n*\n*  T       (input/output) DOUBLE PRECISION array, dimension (LDT,N)\n*          On entry, the upper quasi-triangular matrix T, in Schur\n*          canonical form.\n*          On exit, the updated matrix T, again in Schur canonical form.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= max(1,N).\n*\n*  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)\n*          On entry, if WANTQ is .TRUE., the orthogonal matrix Q.\n*          On exit, if WANTQ is .TRUE., the updated matrix Q.\n*          If WANTQ is .FALSE., Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.\n*          LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N.\n*\n*  J1      (input) INTEGER\n*          The index of the first row of the first block T11.\n*\n*  N1      (input) INTEGER\n*          The order of the first block T11. N1 = 0, 1 or 2.\n*\n*  N2      (input) INTEGER\n*          The order of the second block T22. N2 = 0, 1 or 2.\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          = 1: the transformed matrix T would be too far from Schur\n*               form; the blocks are not swapped and T and Q are\n*               unchanged.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, t, q = NumRu::Lapack.dlaexc( wantq, t, q, j1, n1, n2, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_wantq = argv[0];
  rblapack_t = argv[1];
  rblapack_q = argv[2];
  rblapack_j1 = argv[3];
  rblapack_n1 = argv[4];
  rblapack_n2 = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  wantq = (rblapack_wantq == Qtrue);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (3th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (3th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  n = NA_SHAPE1(rblapack_q);
  if (NA_TYPE(rblapack_q) != NA_DFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
  q = NA_PTR_TYPE(rblapack_q, doublereal*);
  n1 = NUM2INT(rblapack_n1);
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (2th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (2th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  if (NA_SHAPE1(rblapack_t) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of q");
  if (NA_TYPE(rblapack_t) != NA_DFLOAT)
    rblapack_t = na_change_type(rblapack_t, NA_DFLOAT);
  t = NA_PTR_TYPE(rblapack_t, doublereal*);
  n2 = NUM2INT(rblapack_n2);
  j1 = NUM2INT(rblapack_j1);
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = n;
    rblapack_t_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  t_out__ = NA_PTR_TYPE(rblapack_t_out__, doublereal*);
  MEMCPY(t_out__, t, doublereal, NA_TOTAL(rblapack_t));
  rblapack_t = rblapack_t_out__;
  t = t_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
  MEMCPY(q_out__, q, doublereal, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  work = ALLOC_N(doublereal, (n));

  dlaexc_(&wantq, &n, t, &ldt, q, &ldq, &j1, &n1, &n2, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_t, rblapack_q);
}

void
init_lapack_dlaexc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlaexc", rblapack_dlaexc, -1);
}
ruby-lapack-1.7.2/ext/slarzt.c0000644000175000017500000001651112502221014016043 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slarzt_(char* direct, char* storev, integer* n, integer* k, real* v, integer* ldv, real* tau, real* t, integer* ldt);


static VALUE
rblapack_slarzt(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_direct;
  char direct; 
  VALUE rblapack_storev;
  char storev; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_v;
  real *v; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_t;
  real *t; 
  VALUE rblapack_v_out__;
  real *v_out__;

  integer ldv;
  integer k;
  integer ldt;

  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  t, v = NumRu::Lapack.slarzt( direct, storev, n, v, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )\n\n*  Purpose\n*  =======\n*\n*  SLARZT forms the triangular factor T of a real block reflector\n*  H of order > n, which is defined as a product of k elementary\n*  reflectors.\n*\n*  If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;\n*\n*  If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.\n*\n*  If STOREV = 'C', the vector which defines the elementary reflector\n*  H(i) is stored in the i-th column of the array V, and\n*\n*     H  =  I - V * T * V'\n*\n*  If STOREV = 'R', the vector which defines the elementary reflector\n*  H(i) is stored in the i-th row of the array V, and\n*\n*     H  =  I - V' * T * V\n*\n*  Currently, only STOREV = 'R' and DIRECT = 'B' are supported.\n*\n\n*  Arguments\n*  =========\n*\n*  DIRECT  (input) CHARACTER*1\n*          Specifies the order in which the elementary reflectors are\n*          multiplied to form the block reflector:\n*          = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)\n*          = 'B': H = H(k) . . . H(2) H(1) (Backward)\n*\n*  STOREV  (input) CHARACTER*1\n*          Specifies how the vectors which define the elementary\n*          reflectors are stored (see also Further Details):\n*          = 'C': columnwise                        (not supported yet)\n*          = 'R': rowwise\n*\n*  N       (input) INTEGER\n*          The order of the block reflector H. N >= 0.\n*\n*  K       (input) INTEGER\n*          The order of the triangular factor T (= the number of\n*          elementary reflectors). K >= 1.\n*\n*  V       (input/output) REAL array, dimension\n*                               (LDV,K) if STOREV = 'C'\n*                               (LDV,N) if STOREV = 'R'\n*          The matrix V. See further details.\n*\n*  LDV     (input) INTEGER\n*          The leading dimension of the array V.\n*          If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.\n*\n*  TAU     (input) REAL array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i).\n*\n*  T       (output) REAL array, dimension (LDT,K)\n*          The k by k triangular factor T of the block reflector.\n*          If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is\n*          lower triangular. The rest of the array is not used.\n*\n*  LDT     (input) INTEGER\n*          The leading dimension of the array T. LDT >= K.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n*  The shape of the matrix V and the storage of the vectors which define\n*  the H(i) is best illustrated by the following example with n = 5 and\n*  k = 3. The elements equal to 1 are not stored; the corresponding\n*  array elements are modified but restored on exit. The rest of the\n*  array is not used.\n*\n*  DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R':\n*\n*                                              ______V_____\n*         ( v1 v2 v3 )                        /            \\\n*         ( v1 v2 v3 )                      ( v1 v1 v1 v1 v1 . . . . 1 )\n*     V = ( v1 v2 v3 )                      ( v2 v2 v2 v2 v2 . . . 1   )\n*         ( v1 v2 v3 )                      ( v3 v3 v3 v3 v3 . . 1     )\n*         ( v1 v2 v3 )\n*            .  .  .\n*            .  .  .\n*            1  .  .\n*               1  .\n*                  1\n*\n*  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R':\n*\n*                                                        ______V_____\n*            1                                          /            \\\n*            .  1                           ( 1 . . . . v1 v1 v1 v1 v1 )\n*            .  .  1                        ( . 1 . . . v2 v2 v2 v2 v2 )\n*            .  .  .                        ( . . 1 . . v3 v3 v3 v3 v3 )\n*            .  .  .\n*         ( v1 v2 v3 )\n*         ( v1 v2 v3 )\n*     V = ( v1 v2 v3 )\n*         ( v1 v2 v3 )\n*         ( v1 v2 v3 )\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  t, v = NumRu::Lapack.slarzt( direct, storev, n, v, tau, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_direct = argv[0];
  rblapack_storev = argv[1];
  rblapack_n = argv[2];
  rblapack_v = argv[3];
  rblapack_tau = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  direct = StringValueCStr(rblapack_direct)[0];
  n = NUM2INT(rblapack_n);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  storev = StringValueCStr(rblapack_storev)[0];
  ldt = k;
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (4th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 2)
    rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 2);
  ldv = NA_SHAPE0(rblapack_v);
  if (NA_SHAPE1(rblapack_v) != (lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0))
    rb_raise(rb_eRuntimeError, "shape 1 of v must be %d", lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0);
  if (NA_TYPE(rblapack_v) != NA_SFLOAT)
    rblapack_v = na_change_type(rblapack_v, NA_SFLOAT);
  v = NA_PTR_TYPE(rblapack_v, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = k;
    rblapack_t = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  t = NA_PTR_TYPE(rblapack_t, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldv;
    shape[1] = lsame_(&storev,"C") ? k : lsame_(&storev,"R") ? n : 0;
    rblapack_v_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  v_out__ = NA_PTR_TYPE(rblapack_v_out__, real*);
  MEMCPY(v_out__, v, real, NA_TOTAL(rblapack_v));
  rblapack_v = rblapack_v_out__;
  v = v_out__;

  slarzt_(&direct, &storev, &n, &k, v, &ldv, tau, t, &ldt);

  return rb_ary_new3(2, rblapack_t, rblapack_v);
}

void
init_lapack_slarzt(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slarzt", rblapack_slarzt, -1);
}
ruby-lapack-1.7.2/ext/dlatzm.c0000644000175000017500000001624312502221021016017 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dlatzm_(char* side, integer* m, integer* n, doublereal* v, integer* incv, doublereal* tau, doublereal* c1, doublereal* c2, integer* ldc, doublereal* work);


static VALUE
rblapack_dlatzm(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_n;
  integer n; 
  VALUE rblapack_v;
  doublereal *v; 
  VALUE rblapack_incv;
  integer incv; 
  VALUE rblapack_tau;
  doublereal tau; 
  VALUE rblapack_c1;
  doublereal *c1; 
  VALUE rblapack_c2;
  doublereal *c2; 
  VALUE rblapack_c1_out__;
  doublereal *c1_out__;
  VALUE rblapack_c2_out__;
  doublereal *c2_out__;
  doublereal *work;

  integer ldc;

  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  c1, c2 = NumRu::Lapack.dlatzm( side, m, n, v, incv, tau, c1, c2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK )\n\n*  Purpose\n*  =======\n*\n*  This routine is deprecated and has been replaced by routine DORMRZ.\n*\n*  DLATZM applies a Householder matrix generated by DTZRQF to a matrix.\n*\n*  Let P = I - tau*u*u',   u = ( 1 ),\n*                              ( v )\n*  where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if\n*  SIDE = 'R'.\n*\n*  If SIDE equals 'L', let\n*         C = [ C1 ] 1\n*             [ C2 ] m-1\n*               n\n*  Then C is overwritten by P*C.\n*\n*  If SIDE equals 'R', let\n*         C = [ C1, C2 ] m\n*                1  n-1\n*  Then C is overwritten by C*P.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': form P * C\n*          = 'R': form C * P\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C.\n*\n*  V       (input) DOUBLE PRECISION array, dimension\n*                  (1 + (M-1)*abs(INCV)) if SIDE = 'L'\n*                  (1 + (N-1)*abs(INCV)) if SIDE = 'R'\n*          The vector v in the representation of P. V is not used\n*          if TAU = 0.\n*\n*  INCV    (input) INTEGER\n*          The increment between elements of v. INCV <> 0\n*\n*  TAU     (input) DOUBLE PRECISION\n*          The value tau in the representation of P.\n*\n*  C1      (input/output) DOUBLE PRECISION array, dimension\n*                         (LDC,N) if SIDE = 'L'\n*                         (M,1)   if SIDE = 'R'\n*          On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1\n*          if SIDE = 'R'.\n*\n*          On exit, the first row of P*C if SIDE = 'L', or the first\n*          column of C*P if SIDE = 'R'.\n*\n*  C2      (input/output) DOUBLE PRECISION array, dimension\n*                         (LDC, N)   if SIDE = 'L'\n*                         (LDC, N-1) if SIDE = 'R'\n*          On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the\n*          m x (n - 1) matrix C2 if SIDE = 'R'.\n*\n*          On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P\n*          if SIDE = 'R'.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the arrays C1 and C2. LDC >= (1,M).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension\n*                      (N) if SIDE = 'L'\n*                      (M) if SIDE = 'R'\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  c1, c2 = NumRu::Lapack.dlatzm( side, m, n, v, incv, tau, c1, c2, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_side = argv[0];
  rblapack_m = argv[1];
  rblapack_n = argv[2];
  rblapack_v = argv[3];
  rblapack_incv = argv[4];
  rblapack_tau = argv[5];
  rblapack_c1 = argv[6];
  rblapack_c2 = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  side = StringValueCStr(rblapack_side)[0];
  n = NUM2INT(rblapack_n);
  incv = NUM2INT(rblapack_incv);
  if (!NA_IsNArray(rblapack_c2))
    rb_raise(rb_eArgError, "c2 (8th argument) must be NArray");
  if (NA_RANK(rblapack_c2) != 2)
    rb_raise(rb_eArgError, "rank of c2 (8th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c2);
  if (NA_SHAPE1(rblapack_c2) != (lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0))
    rb_raise(rb_eRuntimeError, "shape 1 of c2 must be %d", lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0);
  if (NA_TYPE(rblapack_c2) != NA_DFLOAT)
    rblapack_c2 = na_change_type(rblapack_c2, NA_DFLOAT);
  c2 = NA_PTR_TYPE(rblapack_c2, doublereal*);
  m = NUM2INT(rblapack_m);
  tau = NUM2DBL(rblapack_tau);
  if (!NA_IsNArray(rblapack_v))
    rb_raise(rb_eArgError, "v (4th argument) must be NArray");
  if (NA_RANK(rblapack_v) != 1)
    rb_raise(rb_eArgError, "rank of v (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_v) != (1 + (m-1)*abs(incv)))
    rb_raise(rb_eRuntimeError, "shape 0 of v must be %d", 1 + (m-1)*abs(incv));
  if (NA_TYPE(rblapack_v) != NA_DFLOAT)
    rblapack_v = na_change_type(rblapack_v, NA_DFLOAT);
  v = NA_PTR_TYPE(rblapack_v, doublereal*);
  if (!NA_IsNArray(rblapack_c1))
    rb_raise(rb_eArgError, "c1 (7th argument) must be NArray");
  if (NA_RANK(rblapack_c1) != 2)
    rb_raise(rb_eArgError, "rank of c1 (7th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_c1) != (lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0))
    rb_raise(rb_eRuntimeError, "shape 0 of c1 must be %d", lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0);
  if (NA_SHAPE1(rblapack_c1) != (lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0))
    rb_raise(rb_eRuntimeError, "shape 1 of c1 must be %d", lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0);
  if (NA_TYPE(rblapack_c1) != NA_DFLOAT)
    rblapack_c1 = na_change_type(rblapack_c1, NA_DFLOAT);
  c1 = NA_PTR_TYPE(rblapack_c1, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = lsame_(&side,"L") ? ldc : lsame_(&side,"R") ? m : 0;
    shape[1] = lsame_(&side,"L") ? n : lsame_(&side,"R") ? 1 : 0;
    rblapack_c1_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  c1_out__ = NA_PTR_TYPE(rblapack_c1_out__, doublereal*);
  MEMCPY(c1_out__, c1, doublereal, NA_TOTAL(rblapack_c1));
  rblapack_c1 = rblapack_c1_out__;
  c1 = c1_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = lsame_(&side,"L") ? n : lsame_(&side,"R") ? n-1 : 0;
    rblapack_c2_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  c2_out__ = NA_PTR_TYPE(rblapack_c2_out__, doublereal*);
  MEMCPY(c2_out__, c2, doublereal, NA_TOTAL(rblapack_c2));
  rblapack_c2 = rblapack_c2_out__;
  c2 = c2_out__;
  work = ALLOC_N(doublereal, (lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0));

  dlatzm_(&side, &m, &n, v, &incv, &tau, c1, c2, &ldc, work);

  free(work);
  return rb_ary_new3(2, rblapack_c1, rblapack_c2);
}

void
init_lapack_dlatzm(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlatzm", rblapack_dlatzm, -1);
}
ruby-lapack-1.7.2/ext/zgesc2.c0000644000175000017500000001270312502221012015716 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zgesc2_(integer* n, doublecomplex* a, integer* lda, doublecomplex* rhs, integer* ipiv, integer* jpiv, doublereal* scale);


static VALUE
rblapack_zgesc2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_rhs;
  doublecomplex *rhs; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_jpiv;
  integer *jpiv; 
  VALUE rblapack_scale;
  doublereal scale; 
  VALUE rblapack_rhs_out__;
  doublecomplex *rhs_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  scale, rhs = NumRu::Lapack.zgesc2( a, rhs, ipiv, jpiv, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )\n\n*  Purpose\n*  =======\n*\n*  ZGESC2 solves a system of linear equations\n*\n*            A * X = scale* RHS\n*\n*  with a general N-by-N matrix A using the LU factorization with\n*  complete pivoting computed by ZGETC2.\n*\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA, N)\n*          On entry, the  LU part of the factorization of the n-by-n\n*          matrix A computed by ZGETC2:  A = P * L * U * Q\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1, N).\n*\n*  RHS     (input/output) COMPLEX*16 array, dimension N.\n*          On entry, the right hand side vector b.\n*          On exit, the solution vector X.\n*\n*  IPIV    (input) INTEGER array, dimension (N).\n*          The pivot indices; for 1 <= i <= N, row i of the\n*          matrix has been interchanged with row IPIV(i).\n*\n*  JPIV    (input) INTEGER array, dimension (N).\n*          The pivot indices; for 1 <= j <= N, column j of the\n*          matrix has been interchanged with column JPIV(j).\n*\n*  SCALE    (output) DOUBLE PRECISION\n*           On exit, SCALE contains the scale factor. SCALE is chosen\n*           0 <= SCALE <= 1 to prevent owerflow in the solution.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, rhs = NumRu::Lapack.zgesc2( a, rhs, ipiv, jpiv, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_a = argv[0];
  rblapack_rhs = argv[1];
  rblapack_ipiv = argv[2];
  rblapack_jpiv = argv[3];
  if (argc == 4) {
  } 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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (3th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_rhs))
    rb_raise(rb_eArgError, "rhs (2th argument) must be NArray");
  if (NA_RANK(rblapack_rhs) != 1)
    rb_raise(rb_eArgError, "rank of rhs (2th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_rhs) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of rhs must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_rhs) != NA_DCOMPLEX)
    rblapack_rhs = na_change_type(rblapack_rhs, NA_DCOMPLEX);
  rhs = NA_PTR_TYPE(rblapack_rhs, doublecomplex*);
  if (!NA_IsNArray(rblapack_jpiv))
    rb_raise(rb_eArgError, "jpiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_jpiv) != 1)
    rb_raise(rb_eArgError, "rank of jpiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_jpiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of jpiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_jpiv) != NA_LINT)
    rblapack_jpiv = na_change_type(rblapack_jpiv, NA_LINT);
  jpiv = NA_PTR_TYPE(rblapack_jpiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rhs_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  rhs_out__ = NA_PTR_TYPE(rblapack_rhs_out__, doublecomplex*);
  MEMCPY(rhs_out__, rhs, doublecomplex, NA_TOTAL(rblapack_rhs));
  rblapack_rhs = rblapack_rhs_out__;
  rhs = rhs_out__;

  zgesc2_(&n, a, &lda, rhs, ipiv, jpiv, &scale);

  rblapack_scale = rb_float_new((double)scale);
  return rb_ary_new3(2, rblapack_scale, rblapack_rhs);
}

void
init_lapack_zgesc2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zgesc2", rblapack_zgesc2, -1);
}
ruby-lapack-1.7.2/ext/dgghrd.c0000644000175000017500000002374712502221020015771 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgghrd_(char* compq, char* compz, integer* n, integer* ilo, integer* ihi, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* q, integer* ldq, doublereal* z, integer* ldz, integer* info);


static VALUE
rblapack_dgghrd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_compq;
  char compq; 
  VALUE rblapack_compz;
  char compz; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_q;
  doublereal *q; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;
  VALUE rblapack_q_out__;
  doublereal *q_out__;
  VALUE rblapack_z_out__;
  doublereal *z_out__;

  integer lda;
  integer n;
  integer ldb;
  integer ldq;
  integer ldz;

  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  info, a, b, q, z = NumRu::Lapack.dgghrd( compq, compz, ilo, ihi, a, b, q, z, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGGHRD reduces a pair of real matrices (A,B) to generalized upper\n*  Hessenberg form using orthogonal transformations, where A is a\n*  general matrix and B is upper triangular.  The form of the\n*  generalized eigenvalue problem is\n*     A*x = lambda*B*x,\n*  and B is typically made upper triangular by computing its QR\n*  factorization and moving the orthogonal matrix Q to the left side\n*  of the equation.\n*\n*  This subroutine simultaneously reduces A to a Hessenberg matrix H:\n*     Q**T*A*Z = H\n*  and transforms B to another upper triangular matrix T:\n*     Q**T*B*Z = T\n*  in order to reduce the problem to its standard form\n*     H*y = lambda*T*y\n*  where y = Z**T*x.\n*\n*  The orthogonal matrices Q and Z are determined as products of Givens\n*  rotations.  They may either be formed explicitly, or they may be\n*  postmultiplied into input matrices Q1 and Z1, so that\n*\n*       Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T\n*\n*       Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T\n*\n*  If Q1 is the orthogonal matrix from the QR factorization of B in the\n*  original equation A*x = lambda*B*x, then DGGHRD reduces the original\n*  problem to generalized Hessenberg form.\n*\n\n*  Arguments\n*  =========\n*\n*  COMPQ   (input) CHARACTER*1\n*          = 'N': do not compute Q;\n*          = 'I': Q is initialized to the unit matrix, and the\n*                 orthogonal matrix Q is returned;\n*          = 'V': Q must contain an orthogonal matrix Q1 on entry,\n*                 and the product Q1*Q is returned.\n*\n*  COMPZ   (input) CHARACTER*1\n*          = 'N': do not compute Z;\n*          = 'I': Z is initialized to the unit matrix, and the\n*                 orthogonal matrix Z is returned;\n*          = 'V': Z must contain an orthogonal matrix Z1 on entry,\n*                 and the product Z1*Z is returned.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  ILO     (input) INTEGER\n*  IHI     (input) INTEGER\n*          ILO and IHI mark the rows and columns of A which are to be\n*          reduced.  It is assumed that A is already upper triangular\n*          in rows and columns 1:ILO-1 and IHI+1:N.  ILO and IHI are\n*          normally set by a previous call to SGGBAL; otherwise they\n*          should be set to 1 and N respectively.\n*          1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n*          On entry, the N-by-N general matrix to be reduced.\n*          On exit, the upper triangle and the first subdiagonal of A\n*          are overwritten with the upper Hessenberg matrix H, and the\n*          rest is set to zero.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB, N)\n*          On entry, the N-by-N upper triangular matrix B.\n*          On exit, the upper triangular matrix T = Q**T B Z.  The\n*          elements below the diagonal are set to zero.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  Q       (input/output) DOUBLE PRECISION array, dimension (LDQ, N)\n*          On entry, if COMPQ = 'V', the orthogonal matrix Q1,\n*          typically from the QR factorization of B.\n*          On exit, if COMPQ='I', the orthogonal matrix Q, and if\n*          COMPQ = 'V', the product Q1*Q.\n*          Not referenced if COMPQ='N'.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.\n*          LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.\n*\n*  Z       (input/output) DOUBLE PRECISION array, dimension (LDZ, N)\n*          On entry, if COMPZ = 'V', the orthogonal matrix Z1.\n*          On exit, if COMPZ='I', the orthogonal matrix Z, and if\n*          COMPZ = 'V', the product Z1*Z.\n*          Not referenced if COMPZ='N'.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.\n*          LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.\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*  This routine reduces A to Hessenberg and B to triangular form by\n*  an unblocked reduction, as described in _Matrix_Computations_,\n*  by Golub and Van Loan (Johns Hopkins Press.)\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a, b, q, z = NumRu::Lapack.dgghrd( compq, compz, ilo, ihi, a, b, q, z, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_compq = argv[0];
  rblapack_compz = argv[1];
  rblapack_ilo = argv[2];
  rblapack_ihi = argv[3];
  rblapack_a = argv[4];
  rblapack_b = argv[5];
  rblapack_q = argv[6];
  rblapack_z = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  compq = StringValueCStr(rblapack_compq)[0];
  ilo = NUM2INT(rblapack_ilo);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th 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*);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (7th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_q) != NA_DFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_DFLOAT);
  q = NA_PTR_TYPE(rblapack_q, doublereal*);
  compz = StringValueCStr(rblapack_compz)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_DFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_DFLOAT);
  b = NA_PTR_TYPE(rblapack_b, doublereal*);
  ihi = NUM2INT(rblapack_ihi);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (8th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  if (NA_SHAPE1(rblapack_z) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_z) != NA_DFLOAT)
    rblapack_z = na_change_type(rblapack_z, NA_DFLOAT);
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, doublereal*);
  MEMCPY(q_out__, q, doublereal, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, doublereal*);
  MEMCPY(z_out__, z, doublereal, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  dgghrd_(&compq, &compz, &n, &ilo, &ihi, a, &lda, b, &ldb, q, &ldq, z, &ldz, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z);
}

void
init_lapack_dgghrd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgghrd", rblapack_dgghrd, -1);
}
ruby-lapack-1.7.2/ext/cgbsvxx.c0000644000175000017500000007335112502221012016213 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgbsvxx_(char* fact, char* trans, integer* n, integer* kl, integer* ku, integer* nrhs, real* ab, integer* ldab, real* afb, integer* ldafb, integer* ipiv, char* equed, real* r, real* c, real* b, integer* ldb, real* x, integer* ldx, real* rcond, real* rpvgrw, real* berr, integer* n_err_bnds, real* err_bnds_norm, real* err_bnds_comp, integer* nparams, real* params, complex* work, real* rwork, integer* info);


static VALUE
rblapack_cgbsvxx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_afb;
  real *afb; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_r;
  real *r; 
  VALUE rblapack_c;
  real *c; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_params;
  real *params; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_rpvgrw;
  real rpvgrw; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_err_bnds_norm;
  real *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  real *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  real *ab_out__;
  VALUE rblapack_afb_out__;
  real *afb_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  VALUE rblapack_r_out__;
  real *r_out__;
  VALUE rblapack_c_out__;
  real *c_out__;
  VALUE rblapack_b_out__;
  real *b_out__;
  VALUE rblapack_params_out__;
  real *params_out__;
  complex *work;
  real *rwork;

  integer ldab;
  integer n;
  integer ldafb;
  integer ldb;
  integer nrhs;
  integer nparams;
  integer ldx;
  integer n_err_bnds;

  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  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, ab, afb, ipiv, equed, r, c, b, params = NumRu::Lapack.cgbsvxx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     CGBSVXX uses the LU factorization to compute the solution to a\n*     complex system of linear equations  A * X = B,  where A is an\n*     N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n*     If requested, both normwise and maximum componentwise error bounds\n*     are returned. CGBSVXX will return a solution with a tiny\n*     guaranteed error (O(eps) where eps is the working machine\n*     precision) unless the matrix is very ill-conditioned, in which\n*     case a warning is returned. Relevant condition numbers also are\n*     calculated and returned.\n*\n*     CGBSVXX accepts user-provided factorizations and equilibration\n*     factors; see the definitions of the FACT and EQUED options.\n*     Solving with refinement and using a factorization from a previous\n*     CGBSVXX call will also produce a solution with either O(eps)\n*     errors or warnings, but we cannot make that claim for general\n*     user-provided factorizations and equilibration factors if they\n*     differ from what CGBSVXX would itself produce.\n*\n*     Description\n*     ===========\n*\n*     The following steps are performed:\n*\n*     1. If FACT = 'E', real scaling factors are computed to equilibrate\n*     the system:\n*\n*       TRANS = 'N':  diag(R)*A*diag(C)     *inv(diag(C))*X = diag(R)*B\n*       TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n*       TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n*     or diag(C)*B (if TRANS = 'T' or 'C').\n*\n*     2. If FACT = 'N' or 'E', the LU decomposition is used to factor\n*     the matrix A (after equilibration if FACT = 'E') as\n*\n*       A = P * L * U,\n*\n*     where P is a permutation matrix, L is a unit lower triangular\n*     matrix, and U is upper triangular.\n*\n*     3. If some U(i,i)=0, so that U is exactly singular, then the\n*     routine returns with INFO = i. Otherwise, the factored form of A\n*     is used to estimate the condition number of the matrix A (see\n*     argument RCOND). If the reciprocal of the condition number is less\n*     than machine precision, the routine still goes on to solve for X\n*     and compute error bounds as described below.\n*\n*     4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*     5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero),\n*     the routine will use iterative refinement to try to get a small\n*     error and error bounds.  Refinement calculates the residual to at\n*     least twice the working precision.\n*\n*     6. If equilibration was used, the matrix X is premultiplied by\n*     diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n*     that it solves the original system before equilibration.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     FACT    (input) CHARACTER*1\n*     Specifies whether or not the factored form of the matrix A is\n*     supplied on entry, and if not, whether the matrix A should be\n*     equilibrated before it is factored.\n*       = 'F':  On entry, AF and IPIV contain the factored form of A.\n*               If EQUED is not 'N', the matrix A has been\n*               equilibrated with scaling factors given by R and C.\n*               A, AF, and IPIV are not modified.\n*       = 'N':  The matrix A will be copied to AF and factored.\n*       = 'E':  The matrix A will be equilibrated if necessary, then\n*               copied to AF and factored.\n*\n*     TRANS   (input) CHARACTER*1\n*     Specifies the form of the system of equations:\n*       = 'N':  A * X = B     (No transpose)\n*       = 'T':  A**T * X = B  (Transpose)\n*       = 'C':  A**H * X = B  (Conjugate Transpose = Transpose)\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     KL      (input) INTEGER\n*     The number of subdiagonals within the band of A.  KL >= 0.\n*\n*     KU      (input) INTEGER\n*     The number of superdiagonals within the band of A.  KU >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     AB      (input/output) REAL array, dimension (LDAB,N)\n*     On entry, the matrix A in band storage, in rows 1 to KL+KU+1.\n*     The j-th column of A is stored in the j-th column of the\n*     array AB as follows:\n*     AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)\n*\n*     If FACT = 'F' and EQUED is not 'N', then AB must have been\n*     equilibrated by the scaling factors in R and/or C.  AB is not\n*     modified if FACT = 'F' or 'N', or if FACT = 'E' and\n*     EQUED = 'N' on exit.\n*\n*     On exit, if EQUED .ne. 'N', A is scaled as follows:\n*     EQUED = 'R':  A := diag(R) * A\n*     EQUED = 'C':  A := A * diag(C)\n*     EQUED = 'B':  A := diag(R) * A * diag(C).\n*\n*     LDAB    (input) INTEGER\n*     The leading dimension of the array AB.  LDAB >= KL+KU+1.\n*\n*     AFB     (input or output) REAL array, dimension (LDAFB,N)\n*     If FACT = 'F', then AFB is an input argument and on entry\n*     contains details of the LU factorization of the band matrix\n*     A, as computed by CGBTRF.  U is stored as an upper triangular\n*     band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,\n*     and the multipliers used during the factorization are stored\n*     in rows KL+KU+2 to 2*KL+KU+1.  If EQUED .ne. 'N', then AFB is\n*     the factored form of the equilibrated matrix A.\n*\n*     If FACT = 'N', then AF is an output argument and on exit\n*     returns the factors L and U from the factorization A = P*L*U\n*     of the original matrix A.\n*\n*     If FACT = 'E', then AF is an output argument and on exit\n*     returns the factors L and U from the factorization A = P*L*U\n*     of the equilibrated matrix A (see the description of A for\n*     the form of the equilibrated matrix).\n*\n*     LDAFB   (input) INTEGER\n*     The leading dimension of the array AFB.  LDAFB >= 2*KL+KU+1.\n*\n*     IPIV    (input or output) INTEGER array, dimension (N)\n*     If FACT = 'F', then IPIV is an input argument and on entry\n*     contains the pivot indices from the factorization A = P*L*U\n*     as computed by SGETRF; row i of the matrix was interchanged\n*     with row IPIV(i).\n*\n*     If FACT = 'N', then IPIV is an output argument and on exit\n*     contains the pivot indices from the factorization A = P*L*U\n*     of the original matrix A.\n*\n*     If FACT = 'E', then IPIV is an output argument and on exit\n*     contains the pivot indices from the factorization A = P*L*U\n*     of the equilibrated matrix A.\n*\n*     EQUED   (input or output) CHARACTER*1\n*     Specifies the form of equilibration that was done.\n*       = 'N':  No equilibration (always true if FACT = 'N').\n*       = 'R':  Row equilibration, i.e., A has been premultiplied by\n*               diag(R).\n*       = 'C':  Column equilibration, i.e., A has been postmultiplied\n*               by diag(C).\n*       = 'B':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(R) * A * diag(C).\n*     EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*     output argument.\n*\n*     R       (input or output) REAL array, dimension (N)\n*     The row scale factors for A.  If EQUED = 'R' or 'B', A is\n*     multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n*     is not accessed.  R is an input argument if FACT = 'F';\n*     otherwise, R is an output argument.  If FACT = 'F' and\n*     EQUED = 'R' or 'B', each element of R must be positive.\n*     If R is output, each element of R is a power of the radix.\n*     If R is input, each element of R should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     C       (input or output) REAL array, dimension (N)\n*     The column scale factors for A.  If EQUED = 'C' or 'B', A is\n*     multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n*     is not accessed.  C is an input argument if FACT = 'F';\n*     otherwise, C is an output argument.  If FACT = 'F' and\n*     EQUED = 'C' or 'B', each element of C must be positive.\n*     If C is output, each element of C is a power of the radix.\n*     If C is input, each element of C should be a power of the radix\n*     to ensure a reliable solution and error estimates. Scaling by\n*     powers of the radix does not cause rounding errors unless the\n*     result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B       (input/output) REAL array, dimension (LDB,NRHS)\n*     On entry, the N-by-NRHS right hand side matrix B.\n*     On exit,\n*     if EQUED = 'N', B is not modified;\n*     if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n*        diag(R)*B;\n*     if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n*        overwritten by diag(C)*B.\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (output) REAL array, dimension (LDX,NRHS)\n*     If INFO = 0, the N-by-NRHS solution matrix X to the original\n*     system of equations.  Note that A and B are modified on exit\n*     if EQUED .ne. 'N', and the solution to the equilibrated system is\n*     inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or\n*     inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) REAL\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     RPVGRW  (output) REAL\n*     Reciprocal pivot growth.  On exit, this contains the reciprocal\n*     pivot growth factor norm(A)/norm(U). The \"max absolute element\"\n*     norm is used.  If this is much less than 1, then the stability of\n*     the LU factorization of the (equilibrated) matrix A could be poor.\n*     This also means that the solution X, estimated condition numbers,\n*     and error bounds could be unreliable. If factorization fails with\n*     0 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, rpvgrw, berr, err_bnds_norm, err_bnds_comp, info, ab, afb, ipiv, equed, r, c, b, params = NumRu::Lapack.cgbsvxx( fact, trans, kl, ku, ab, afb, ipiv, equed, r, c, b, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 12 && argc != 12)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 12)", argc);
  rblapack_fact = argv[0];
  rblapack_trans = argv[1];
  rblapack_kl = argv[2];
  rblapack_ku = argv[3];
  rblapack_ab = argv[4];
  rblapack_afb = argv[5];
  rblapack_ipiv = argv[6];
  rblapack_equed = argv[7];
  rblapack_r = argv[8];
  rblapack_c = argv[9];
  rblapack_b = argv[10];
  rblapack_params = argv[11];
  if (argc == 12) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  fact = StringValueCStr(rblapack_fact)[0];
  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (7th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_r))
    rb_raise(rb_eArgError, "r (9th argument) must be NArray");
  if (NA_RANK(rblapack_r) != 1)
    rb_raise(rb_eArgError, "rank of r (9th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_r) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_r) != NA_SFLOAT)
    rblapack_r = na_change_type(rblapack_r, NA_SFLOAT);
  r = NA_PTR_TYPE(rblapack_r, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (11th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (11th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  n_err_bnds = 3;
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_afb))
    rb_raise(rb_eArgError, "afb (6th argument) must be NArray");
  if (NA_RANK(rblapack_afb) != 2)
    rb_raise(rb_eArgError, "rank of afb (6th argument) must be %d", 2);
  ldafb = NA_SHAPE0(rblapack_afb);
  if (NA_SHAPE1(rblapack_afb) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of afb must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_afb) != NA_SFLOAT)
    rblapack_afb = na_change_type(rblapack_afb, NA_SFLOAT);
  afb = NA_PTR_TYPE(rblapack_afb, real*);
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (10th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (10th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of ab");
  if (NA_TYPE(rblapack_c) != NA_SFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_SFLOAT);
  c = NA_PTR_TYPE(rblapack_c, real*);
  ldx = MAX(1,n);
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (12th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (12th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_SFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_SFLOAT);
  params = NA_PTR_TYPE(rblapack_params, real*);
  equed = StringValueCStr(rblapack_equed)[0];
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, real*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, real*);
  MEMCPY(ab_out__, ab, real, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldafb;
    shape[1] = n;
    rblapack_afb_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  afb_out__ = NA_PTR_TYPE(rblapack_afb_out__, real*);
  MEMCPY(afb_out__, afb, real, NA_TOTAL(rblapack_afb));
  rblapack_afb = rblapack_afb_out__;
  afb = afb_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_r_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  r_out__ = NA_PTR_TYPE(rblapack_r_out__, real*);
  MEMCPY(r_out__, r, real, NA_TOTAL(rblapack_r));
  rblapack_r = rblapack_r_out__;
  r = r_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, real*);
  MEMCPY(c_out__, c, real, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, real*);
  MEMCPY(params_out__, params, real, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(complex, (2*n));
  rwork = ALLOC_N(real, (2*n));

  cgbsvxx_(&fact, &trans, &n, &kl, &ku, &nrhs, ab, &ldab, afb, &ldafb, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, &rpvgrw, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, rwork, &info);

  free(work);
  free(rwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_rpvgrw = rb_float_new((double)rpvgrw);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(15, rblapack_x, rblapack_rcond, rblapack_rpvgrw, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_ab, rblapack_afb, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b, rblapack_params);
}

void
init_lapack_cgbsvxx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgbsvxx", rblapack_cgbsvxx, -1);
}
ruby-lapack-1.7.2/ext/ilaslr.c0000644000175000017500000000454612502221021016015 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern integer ilaslr_(integer* m, integer* n, real* a, integer* lda);


static VALUE
rblapack_ilaslr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack___out__;
  integer __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  __out__ = NumRu::Lapack.ilaslr( m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      INTEGER FUNCTION ILASLR( M, N, A, LDA )\n\n*  Purpose\n*  =======\n*\n*  ILASLR scans A for its last non-zero row.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix A.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix A.\n*\n*  A       (input) REAL array, dimension (LDA,N)\n*          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\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.ilaslr( m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_m = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  m = NUM2INT(rblapack_m);
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);

  __out__ = ilaslr_(&m, &n, a, &lda);

  rblapack___out__ = INT2NUM(__out__);
  return rblapack___out__;
}

void
init_lapack_ilaslr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ilaslr", rblapack_ilaslr, -1);
}
ruby-lapack-1.7.2/ext/sgttrf.c0000644000175000017500000001456212502221017016044 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgttrf_(integer* n, real* dl, real* d, real* du, real* du2, integer* ipiv, integer* info);


static VALUE
rblapack_sgttrf(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_dl;
  real *dl; 
  VALUE rblapack_d;
  real *d; 
  VALUE rblapack_du;
  real *du; 
  VALUE rblapack_du2;
  real *du2; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_dl_out__;
  real *dl_out__;
  VALUE rblapack_d_out__;
  real *d_out__;
  VALUE rblapack_du_out__;
  real *du_out__;

  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  du2, ipiv, info, dl, d, du = NumRu::Lapack.sgttrf( dl, d, du, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGTTRF( N, DL, D, DU, DU2, IPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGTTRF computes an LU factorization of a real tridiagonal matrix A\n*  using elimination with partial pivoting and row interchanges.\n*\n*  The factorization has the form\n*     A = L * U\n*  where L is a product of permutation and unit lower bidiagonal\n*  matrices and U is upper triangular with nonzeros in only the main\n*  diagonal and first two superdiagonals.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.\n*\n*  DL      (input/output) REAL array, dimension (N-1)\n*          On entry, DL must contain the (n-1) sub-diagonal elements of\n*          A.\n*\n*          On exit, DL is overwritten by the (n-1) multipliers that\n*          define the matrix L from the LU factorization of A.\n*\n*  D       (input/output) REAL array, dimension (N)\n*          On entry, D must contain the diagonal elements of A.\n*\n*          On exit, D is overwritten by the n diagonal elements of the\n*          upper triangular matrix U from the LU factorization of A.\n*\n*  DU      (input/output) REAL array, dimension (N-1)\n*          On entry, DU must contain the (n-1) super-diagonal elements\n*          of A.\n*\n*          On exit, DU is overwritten by the (n-1) elements of the first\n*          super-diagonal of U.\n*\n*  DU2     (output) REAL array, dimension (N-2)\n*          On exit, DU2 is overwritten by the (n-2) elements of the\n*          second super-diagonal of U.\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          The pivot indices; for 1 <= i <= n, row i of the matrix was\n*          interchanged with row IPIV(i).  IPIV(i) will always be either\n*          i or i+1; IPIV(i) = i indicates a row interchange was not\n*          required.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -k, the k-th argument had an illegal value\n*          > 0:  if INFO = k, U(k,k) is exactly zero. The factorization\n*                has been completed, but the factor U is exactly\n*                singular, and division by zero will occur if it is used\n*                to solve a system of equations.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  du2, ipiv, info, dl, d, du = NumRu::Lapack.sgttrf( dl, d, du, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_dl = argv[0];
  rblapack_d = argv[1];
  rblapack_du = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (2th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (2th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_SFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_SFLOAT);
  d = NA_PTR_TYPE(rblapack_d, real*);
  if (!NA_IsNArray(rblapack_dl))
    rb_raise(rb_eArgError, "dl (1th argument) must be NArray");
  if (NA_RANK(rblapack_dl) != 1)
    rb_raise(rb_eArgError, "rank of dl (1th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dl) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of dl must be %d", n-1);
  if (NA_TYPE(rblapack_dl) != NA_SFLOAT)
    rblapack_dl = na_change_type(rblapack_dl, NA_SFLOAT);
  dl = NA_PTR_TYPE(rblapack_dl, real*);
  if (!NA_IsNArray(rblapack_du))
    rb_raise(rb_eArgError, "du (3th argument) must be NArray");
  if (NA_RANK(rblapack_du) != 1)
    rb_raise(rb_eArgError, "rank of du (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_du) != (n-1))
    rb_raise(rb_eRuntimeError, "shape 0 of du must be %d", n-1);
  if (NA_TYPE(rblapack_du) != NA_SFLOAT)
    rblapack_du = na_change_type(rblapack_du, NA_SFLOAT);
  du = NA_PTR_TYPE(rblapack_du, real*);
  {
    na_shape_t shape[1];
    shape[0] = n-2;
    rblapack_du2 = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  du2 = NA_PTR_TYPE(rblapack_du2, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_dl_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  dl_out__ = NA_PTR_TYPE(rblapack_dl_out__, real*);
  MEMCPY(dl_out__, dl, real, NA_TOTAL(rblapack_dl));
  rblapack_dl = rblapack_dl_out__;
  dl = dl_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, real*);
  MEMCPY(d_out__, d, real, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_du_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  du_out__ = NA_PTR_TYPE(rblapack_du_out__, real*);
  MEMCPY(du_out__, du, real, NA_TOTAL(rblapack_du));
  rblapack_du = rblapack_du_out__;
  du = du_out__;

  sgttrf_(&n, dl, d, du, du2, ipiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(6, rblapack_du2, rblapack_ipiv, rblapack_info, rblapack_dl, rblapack_d, rblapack_du);
}

void
init_lapack_sgttrf(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgttrf", rblapack_sgttrf, -1);
}
ruby-lapack-1.7.2/ext/zlaqhe.c0000644000175000017500000001243412502221013016007 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zlaqhe_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublereal* s, doublereal* scond, doublereal* amax, char* equed);


static VALUE
rblapack_zlaqhe(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_scond;
  doublereal scond; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_a_out__;
  doublecomplex *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  equed, a = NumRu::Lapack.zlaqhe( uplo, a, s, scond, amax, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )\n\n*  Purpose\n*  =======\n*\n*  ZLAQHE equilibrates a Hermitian matrix A using the scaling factors\n*  in the vector S.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          Hermitian matrix A is stored.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading\n*          n by n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n by n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*\n*          On exit, if EQUED = 'Y', the equilibrated matrix:\n*          diag(S) * A * diag(S).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(N,1).\n*\n*  S       (input) DOUBLE PRECISION array, dimension (N)\n*          The scale factors for A.\n*\n*  SCOND   (input) DOUBLE PRECISION\n*          Ratio of the smallest S(i) to the largest S(i).\n*\n*  AMAX    (input) DOUBLE PRECISION\n*          Absolute value of largest matrix entry.\n*\n*  EQUED   (output) CHARACTER*1\n*          Specifies whether or not equilibration was done.\n*          = 'N':  No equilibration.\n*          = 'Y':  Equilibration was done, i.e., A has been replaced by\n*                  diag(S) * A * diag(S).\n*\n*  Internal Parameters\n*  ===================\n*\n*  THRESH is a threshold value used to decide if scaling should be done\n*  based on the ratio of the scaling factors.  If SCOND < THRESH,\n*  scaling is done.\n*\n*  LARGE and SMALL are threshold values used to decide if scaling should\n*  be done based on the absolute size of the largest matrix element.\n*  If AMAX > LARGE or AMAX < SMALL, scaling is done.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  equed, a = NumRu::Lapack.zlaqhe( uplo, a, s, scond, amax, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 5 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 5)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_s = argv[2];
  rblapack_scond = argv[3];
  rblapack_amax = argv[4];
  if (argc == 5) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (3th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_s);
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  amax = NUM2DBL(rblapack_amax);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of s");
  if (NA_TYPE(rblapack_a) != NA_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  scond = NUM2DBL(rblapack_scond);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zlaqhe_(&uplo, &n, a, &lda, s, &scond, &amax, &equed);

  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(2, rblapack_equed, rblapack_a);
}

void
init_lapack_zlaqhe(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zlaqhe", rblapack_zlaqhe, -1);
}
ruby-lapack-1.7.2/ext/dsbevx.c0000644000175000017500000002555312502221015016026 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsbevx_(char* jobz, char* range, char* uplo, integer* n, integer* kd, doublereal* ab, integer* ldab, doublereal* q, integer* ldq, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublereal* z, integer* ldz, doublereal* work, integer* iwork, integer* ifail, integer* info);


static VALUE
rblapack_dsbevx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  doublereal *ab; 
  VALUE rblapack_vl;
  doublereal vl; 
  VALUE rblapack_vu;
  doublereal vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  doublereal abstol; 
  VALUE rblapack_q;
  doublereal *q; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_ifail;
  integer *ifail; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  doublereal *ab_out__;
  doublereal *work;
  integer *iwork;

  integer ldab;
  integer n;
  integer ldq;
  integer ldz;

  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  q, m, w, z, ifail, info, ab = NumRu::Lapack.dsbevx( jobz, range, uplo, kd, ab, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSBEVX computes selected eigenvalues and, optionally, eigenvectors\n*  of a real symmetric band matrix A.  Eigenvalues and eigenvectors can\n*  be selected by specifying either a range of values or a range of\n*  indices for the desired eigenvalues.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found;\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found;\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals of the matrix A if UPLO = 'U',\n*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.\n*\n*  AB      (input/output) DOUBLE PRECISION array, dimension (LDAB, N)\n*          On entry, the upper or lower triangle of the symmetric band\n*          matrix A, stored in the first KD+1 rows of the array.  The\n*          j-th column of A is stored in the j-th column of the array AB\n*          as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*          On exit, AB is overwritten by values generated during the\n*          reduction to tridiagonal form.  If UPLO = 'U', the first\n*          superdiagonal and the diagonal of the tridiagonal matrix T\n*          are returned in rows KD and KD+1 of AB, and if UPLO = 'L',\n*          the diagonal and first subdiagonal of T are returned in the\n*          first two rows of AB.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD + 1.\n*\n*  Q       (output) DOUBLE PRECISION array, dimension (LDQ, N)\n*          If JOBZ = 'V', the N-by-N orthogonal matrix used in the\n*                         reduction to tridiagonal form.\n*          If JOBZ = 'N', the array Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.  If JOBZ = 'V', then\n*          LDQ >= max(1,N).\n*\n*  VL      (input) DOUBLE PRECISION\n*  VU      (input) DOUBLE PRECISION\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) DOUBLE PRECISION\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less than\n*          or equal to zero, then  EPS*|T|  will be used in its place,\n*          where |T| is the 1-norm of the tridiagonal matrix obtained\n*          by reducing AB to tridiagonal form.\n*\n*          Eigenvalues will be computed most accurately when ABSTOL is\n*          set to twice the underflow threshold 2*DLAMCH('S'), not zero.\n*          If this routine returns with INFO>0, indicating that some\n*          eigenvectors did not converge, try setting ABSTOL to\n*          2*DLAMCH('S').\n*\n*          See \"Computing Small Singular Values of Bidiagonal Matrices\n*          with Guaranteed High Relative Accuracy,\" by Demmel and\n*          Kahan, LAPACK Working Note #3.\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          The first M elements contain the selected eigenvalues in\n*          ascending order.\n*\n*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))\n*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix A\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          If an eigenvector fails to converge, then that column of Z\n*          contains the latest approximation to the eigenvector, and the\n*          index of the eigenvector is returned in IFAIL.\n*          If JOBZ = 'N', then Z is not referenced.\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (7*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (5*N)\n*\n*  IFAIL   (output) INTEGER array, dimension (N)\n*          If JOBZ = 'V', then if INFO = 0, the first M elements of\n*          IFAIL are zero.  If INFO > 0, then IFAIL contains the\n*          indices of the eigenvectors that failed to converge.\n*          If JOBZ = 'N', then IFAIL is not referenced.\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, then i eigenvectors failed to converge.\n*                Their indices are stored in array IFAIL.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  q, m, w, z, ifail, info, ab = NumRu::Lapack.dsbevx( jobz, range, uplo, kd, ab, vl, vu, il, iu, abstol, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 10 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 10)", argc);
  rblapack_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_uplo = argv[2];
  rblapack_kd = argv[3];
  rblapack_ab = argv[4];
  rblapack_vl = argv[5];
  rblapack_vu = argv[6];
  rblapack_il = argv[7];
  rblapack_iu = argv[8];
  rblapack_abstol = argv[9];
  if (argc == 10) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_DFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_DFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, doublereal*);
  vu = NUM2DBL(rblapack_vu);
  iu = NUM2INT(rblapack_iu);
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  ldq = lsame_(&jobz,"V") ? MAX(1,n) : 0;
  range = StringValueCStr(rblapack_range)[0];
  vl = NUM2DBL(rblapack_vl);
  abstol = NUM2DBL(rblapack_abstol);
  kd = NUM2INT(rblapack_kd);
  il = NUM2INT(rblapack_il);
  m = lsame_(&range,"A") ? n : lsame_(&range,"I") ? iu-il+1 : 0;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  q = NA_PTR_TYPE(rblapack_q, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ifail = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ifail = NA_PTR_TYPE(rblapack_ifail, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, doublereal*);
  MEMCPY(ab_out__, ab, doublereal, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  work = ALLOC_N(doublereal, (7*n));
  iwork = ALLOC_N(integer, (5*n));

  dsbevx_(&jobz, &range, &uplo, &n, &kd, ab, &ldab, q, &ldq, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, work, iwork, ifail, &info);

  free(work);
  free(iwork);
  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_q, rblapack_m, rblapack_w, rblapack_z, rblapack_ifail, rblapack_info, rblapack_ab);
}

void
init_lapack_dsbevx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsbevx", rblapack_dsbevx, -1);
}
ruby-lapack-1.7.2/ext/zhpevd.c0000644000175000017500000002404712502221022016026 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhpevd_(char* jobz, char* uplo, integer* n, doublecomplex* ap, doublereal* w, doublecomplex* z, integer* ldz, doublecomplex* work, integer* lwork, doublereal* rwork, integer* lrwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_zhpevd(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_ap;
  doublecomplex *ap; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_lrwork;
  integer lrwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublecomplex *z; 
  VALUE rblapack_work;
  doublecomplex *work; 
  VALUE rblapack_rwork;
  doublereal *rwork; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ap_out__;
  doublecomplex *ap_out__;

  integer ldap;
  integer n;
  integer ldz;

  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  w, z, work, rwork, iwork, info, ap = NumRu::Lapack.zhpevd( jobz, uplo, ap, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHPEVD computes all the eigenvalues and, optionally, eigenvectors of\n*  a complex Hermitian matrix A in packed storage.  If eigenvectors are\n*  desired, it uses a divide and conquer algorithm.\n*\n*  The divide and conquer algorithm makes very mild assumptions about\n*  floating point arithmetic. It will work on machines with a guard\n*  digit in add/subtract, or on those binary machines without guard\n*  digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or\n*  Cray-2. It could conceivably fail on hexadecimal or decimal machines\n*  without guard digits, but we know of none.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  AP      (input/output) COMPLEX*16 array, dimension (N*(N+1)/2)\n*          On entry, the upper or lower triangle of the Hermitian matrix\n*          A, packed columnwise in a linear array.  The j-th column of A\n*          is stored in the array AP as follows:\n*          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;\n*          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.\n*\n*          On exit, AP is overwritten by values generated during the\n*          reduction to tridiagonal form.  If UPLO = 'U', the diagonal\n*          and first superdiagonal of the tridiagonal matrix T overwrite\n*          the corresponding elements of A, and if UPLO = 'L', the\n*          diagonal and first subdiagonal of T overwrite the\n*          corresponding elements of A.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, the eigenvalues in ascending order.\n*\n*  Z       (output) COMPLEX*16 array, dimension (LDZ, N)\n*          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal\n*          eigenvectors of the matrix A, with the i-th column of Z\n*          holding the eigenvector associated with W(i).\n*          If JOBZ = 'N', then Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  WORK    (workspace/output) COMPLEX*16 array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the required LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of array WORK.\n*          If N <= 1,               LWORK must be at least 1.\n*          If JOBZ = 'N' and N > 1, LWORK must be at least N.\n*          If JOBZ = 'V' and N > 1, LWORK must be at least 2*N.\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the required sizes of the WORK, RWORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  RWORK   (workspace/output) DOUBLE PRECISION array,\n*                                         dimension (LRWORK)\n*          On exit, if INFO = 0, RWORK(1) returns the required LRWORK.\n*\n*  LRWORK  (input) INTEGER\n*          The dimension of array RWORK.\n*          If N <= 1,               LRWORK must be at least 1.\n*          If JOBZ = 'N' and N > 1, LRWORK must be at least N.\n*          If JOBZ = 'V' and N > 1, LRWORK must be at least\n*                    1 + 5*N + 2*N**2.\n*\n*          If LRWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the required sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the required LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of array IWORK.\n*          If JOBZ  = 'N' or N <= 1, LIWORK must be at least 1.\n*          If JOBZ  = 'V' and N > 1, LIWORK must be at least 3 + 5*N.\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the required sizes of the WORK, RWORK\n*          and IWORK arrays, returns these values as the first entries\n*          of the WORK, RWORK and IWORK arrays, and no error message\n*          related to LWORK or LRWORK or LIWORK 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 algorithm failed to converge; i\n*                off-diagonal elements of an intermediate tridiagonal\n*                form did not converge to zero.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  w, z, work, rwork, iwork, info, ap = NumRu::Lapack.zhpevd( jobz, uplo, ap, [:lwork => lwork, :lrwork => lrwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_jobz = argv[0];
  rblapack_uplo = argv[1];
  rblapack_ap = argv[2];
  if (argc == 6) {
    rblapack_lwork = argv[3];
    rblapack_lrwork = argv[4];
    rblapack_liwork = argv[5];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_lrwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lrwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_lrwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_ap))
    rb_raise(rb_eArgError, "ap (3th argument) must be NArray");
  if (NA_RANK(rblapack_ap) != 1)
    rb_raise(rb_eArgError, "rank of ap (3th argument) must be %d", 1);
  ldap = NA_SHAPE0(rblapack_ap);
  if (NA_TYPE(rblapack_ap) != NA_DCOMPLEX)
    rblapack_ap = na_change_type(rblapack_ap, NA_DCOMPLEX);
  ap = NA_PTR_TYPE(rblapack_ap, doublecomplex*);
  n = ((int)sqrtf(ldap*8+1.0f)-1)/2;
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (rblapack_lrwork == Qnil)
    lrwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 1+5*n+2*n*n : 0;
  else {
    lrwork = NUM2INT(rblapack_lrwork);
  }
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  if (rblapack_lwork == Qnil)
    lwork = n<=1 ? 1 : lsame_(&jobz,"N") ? n : lsame_(&jobz,"V") ? 2*n : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (rblapack_liwork == Qnil)
    liwork = (lsame_(&jobz,"N")||n<=1) ? 1 : lsame_(&jobz,"V") ? 3+5*n : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lrwork);
    rblapack_rwork = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  rwork = NA_PTR_TYPE(rblapack_rwork, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[1];
    shape[0] = ldap;
    rblapack_ap_out__ = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  ap_out__ = NA_PTR_TYPE(rblapack_ap_out__, doublecomplex*);
  MEMCPY(ap_out__, ap, doublecomplex, NA_TOTAL(rblapack_ap));
  rblapack_ap = rblapack_ap_out__;
  ap = ap_out__;

  zhpevd_(&jobz, &uplo, &n, ap, w, z, &ldz, work, &lwork, rwork, &lrwork, iwork, &liwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_w, rblapack_z, rblapack_work, rblapack_rwork, rblapack_iwork, rblapack_info, rblapack_ap);
}

void
init_lapack_zhpevd(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhpevd", rblapack_zhpevd, -1);
}
ruby-lapack-1.7.2/ext/dstevr.c0000644000175000017500000003446712502221025016047 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dstevr_(char* jobz, char* range, integer* n, doublereal* d, doublereal* e, doublereal* vl, doublereal* vu, integer* il, integer* iu, doublereal* abstol, integer* m, doublereal* w, doublereal* z, integer* ldz, integer* isuppz, doublereal* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_dstevr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobz;
  char jobz; 
  VALUE rblapack_range;
  char range; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_vl;
  doublereal vl; 
  VALUE rblapack_vu;
  doublereal vu; 
  VALUE rblapack_il;
  integer il; 
  VALUE rblapack_iu;
  integer iu; 
  VALUE rblapack_abstol;
  doublereal abstol; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_w;
  doublereal *w; 
  VALUE rblapack_z;
  doublereal *z; 
  VALUE rblapack_isuppz;
  integer *isuppz; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_d_out__;
  doublereal *d_out__;
  VALUE rblapack_e_out__;
  doublereal *e_out__;

  integer n;
  integer ldz;

  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  m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.dstevr( jobz, range, d, e, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSTEVR computes selected eigenvalues and, optionally, eigenvectors\n*  of a real symmetric tridiagonal matrix T.  Eigenvalues and\n*  eigenvectors can be selected by specifying either a range of values\n*  or a range of indices for the desired eigenvalues.\n*\n*  Whenever possible, DSTEVR calls DSTEMR to compute the\n*  eigenspectrum using Relatively Robust Representations.  DSTEMR\n*  computes eigenvalues by the dqds algorithm, while orthogonal\n*  eigenvectors are computed from various \"good\" L D L^T representations\n*  (also known as Relatively Robust Representations). Gram-Schmidt\n*  orthogonalization is avoided as far as possible. More specifically,\n*  the various steps of the algorithm are as follows. For the i-th\n*  unreduced block of T,\n*     (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T\n*          is a relatively robust representation,\n*     (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high\n*         relative accuracy by the dqds algorithm,\n*     (c) If there is a cluster of close eigenvalues, \"choose\" sigma_i\n*         close to the cluster, and go to step (a),\n*     (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T,\n*         compute the corresponding eigenvector by forming a\n*         rank-revealing twisted factorization.\n*  The desired accuracy of the output can be specified by the input\n*  parameter ABSTOL.\n*\n*  For more details, see \"A new O(n^2) algorithm for the symmetric\n*  tridiagonal eigenvalue/eigenvector problem\", by Inderjit Dhillon,\n*  Computer Science Division Technical Report No. UCB//CSD-97-971,\n*  UC Berkeley, May 1997.\n*\n*\n*  Note 1 : DSTEVR calls DSTEMR when the full spectrum is requested\n*  on machines which conform to the ieee-754 floating point standard.\n*  DSTEVR calls DSTEBZ and DSTEIN on non-ieee machines and\n*  when partial spectrum requests are made.\n*\n*  Normal execution of DSTEMR may create NaNs and infinities and\n*  hence may abort due to a floating point exception in environments\n*  which do not handle NaNs and infinities in the ieee standard default\n*  manner.\n*\n\n*  Arguments\n*  =========\n*\n*  JOBZ    (input) CHARACTER*1\n*          = 'N':  Compute eigenvalues only;\n*          = 'V':  Compute eigenvalues and eigenvectors.\n*\n*  RANGE   (input) CHARACTER*1\n*          = 'A': all eigenvalues will be found.\n*          = 'V': all eigenvalues in the half-open interval (VL,VU]\n*                 will be found.\n*          = 'I': the IL-th through IU-th eigenvalues will be found.\n********** For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and\n********** DSTEIN are called\n*\n*  N       (input) INTEGER\n*          The order of the matrix.  N >= 0.\n*\n*  D       (input/output) DOUBLE PRECISION array, dimension (N)\n*          On entry, the n diagonal elements of the tridiagonal matrix\n*          A.\n*          On exit, D may be multiplied by a constant factor chosen\n*          to avoid over/underflow in computing the eigenvalues.\n*\n*  E       (input/output) DOUBLE PRECISION array, dimension (max(1,N-1))\n*          On entry, the (n-1) subdiagonal elements of the tridiagonal\n*          matrix A in elements 1 to N-1 of E.\n*          On exit, E may be multiplied by a constant factor chosen\n*          to avoid over/underflow in computing the eigenvalues.\n*\n*  VL      (input) DOUBLE PRECISION\n*  VU      (input) DOUBLE PRECISION\n*          If RANGE='V', the lower and upper bounds of the interval to\n*          be searched for eigenvalues. VL < VU.\n*          Not referenced if RANGE = 'A' or 'I'.\n*\n*  IL      (input) INTEGER\n*  IU      (input) INTEGER\n*          If RANGE='I', the indices (in ascending order) of the\n*          smallest and largest eigenvalues to be returned.\n*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.\n*          Not referenced if RANGE = 'A' or 'V'.\n*\n*  ABSTOL  (input) DOUBLE PRECISION\n*          The absolute error tolerance for the eigenvalues.\n*          An approximate eigenvalue is accepted as converged\n*          when it is determined to lie in an interval [a,b]\n*          of width less than or equal to\n*\n*                  ABSTOL + EPS *   max( |a|,|b| ) ,\n*\n*          where EPS is the machine precision.  If ABSTOL is less than\n*          or equal to zero, then  EPS*|T|  will be used in its place,\n*          where |T| is the 1-norm of the tridiagonal matrix obtained\n*          by reducing A to tridiagonal form.\n*\n*          See \"Computing Small Singular Values of Bidiagonal Matrices\n*          with Guaranteed High Relative Accuracy,\" by Demmel and\n*          Kahan, LAPACK Working Note #3.\n*\n*          If high relative accuracy is important, set ABSTOL to\n*          DLAMCH( 'Safe minimum' ).  Doing so will guarantee that\n*          eigenvalues are computed to high relative accuracy when\n*          possible in future releases.  The current code does not\n*          make any guarantees about high relative accuracy, but\n*          future releases will. See J. Barlow and J. Demmel,\n*          \"Computing Accurate Eigensystems of Scaled Diagonally\n*          Dominant Matrices\", LAPACK Working Note #7, for a discussion\n*          of which matrices define their eigenvalues to high relative\n*          accuracy.\n*\n*  M       (output) INTEGER\n*          The total number of eigenvalues found.  0 <= M <= N.\n*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.\n*\n*  W       (output) DOUBLE PRECISION array, dimension (N)\n*          The first M elements contain the selected eigenvalues in\n*          ascending order.\n*\n*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )\n*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z\n*          contain the orthonormal eigenvectors of the matrix A\n*          corresponding to the selected eigenvalues, with the i-th\n*          column of Z holding the eigenvector associated with W(i).\n*          Note: the user must ensure that at least max(1,M) columns are\n*          supplied in the array Z; if RANGE = 'V', the exact value of M\n*          is not known in advance and an upper bound must be used.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z.  LDZ >= 1, and if\n*          JOBZ = 'V', LDZ >= max(1,N).\n*\n*  ISUPPZ  (output) INTEGER array, dimension ( 2*max(1,M) )\n*          The support of the eigenvectors in Z, i.e., the indices\n*          indicating the nonzero elements in Z. The i-th eigenvector\n*          is nonzero only in elements ISUPPZ( 2*i-1 ) through\n*          ISUPPZ( 2*i ).\n********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1\n*\n*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))\n*          On exit, if INFO = 0, WORK(1) returns the optimal (and\n*          minimal) LWORK.\n*\n*  LWORK   (input) INTEGER\n*          The dimension of the array WORK.  LWORK >= max(1,20*N).\n*\n*          If LWORK = -1, then a workspace query is assumed; the routine\n*          only calculates the optimal sizes of the WORK and IWORK\n*          arrays, returns these values as the first entries of the WORK\n*          and IWORK arrays, and no error message related to LWORK or\n*          LIWORK is issued by XERBLA.\n*\n*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal (and\n*          minimal) LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK.  LIWORK >= max(1,10*N).\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal sizes of the WORK and\n*          IWORK arrays, returns these values as the first entries of\n*          the WORK and IWORK arrays, and no error message related to\n*          LWORK or LIWORK 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:  Internal error\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Inderjit Dhillon, IBM Almaden, USA\n*     Osni Marques, LBNL/NERSC, USA\n*     Ken Stanley, Computer Science Division, University of\n*       California at Berkeley, USA\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  m, w, z, isuppz, work, iwork, info, d, e = NumRu::Lapack.dstevr( jobz, range, d, e, vl, vu, il, iu, abstol, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 11)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_jobz = argv[0];
  rblapack_range = argv[1];
  rblapack_d = argv[2];
  rblapack_e = argv[3];
  rblapack_vl = argv[4];
  rblapack_vu = argv[5];
  rblapack_il = argv[6];
  rblapack_iu = argv[7];
  rblapack_abstol = argv[8];
  if (argc == 11) {
    rblapack_lwork = argv[9];
    rblapack_liwork = argv[10];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  jobz = StringValueCStr(rblapack_jobz)[0];
  if (!NA_IsNArray(rblapack_d))
    rb_raise(rb_eArgError, "d (3th argument) must be NArray");
  if (NA_RANK(rblapack_d) != 1)
    rb_raise(rb_eArgError, "rank of d (3th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_d);
  if (NA_TYPE(rblapack_d) != NA_DFLOAT)
    rblapack_d = na_change_type(rblapack_d, NA_DFLOAT);
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  vl = NUM2DBL(rblapack_vl);
  il = NUM2INT(rblapack_il);
  abstol = NUM2DBL(rblapack_abstol);
  if (rblapack_liwork == Qnil)
    liwork = 10*n;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  range = StringValueCStr(rblapack_range)[0];
  vu = NUM2DBL(rblapack_vu);
  if (rblapack_lwork == Qnil)
    lwork = 20*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  if (!NA_IsNArray(rblapack_e))
    rb_raise(rb_eArgError, "e (4th argument) must be NArray");
  if (NA_RANK(rblapack_e) != 1)
    rb_raise(rb_eArgError, "rank of e (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_e) != (MAX(1,n-1)))
    rb_raise(rb_eRuntimeError, "shape 0 of e must be %d", MAX(1,n-1));
  if (NA_TYPE(rblapack_e) != NA_DFLOAT)
    rblapack_e = na_change_type(rblapack_e, NA_DFLOAT);
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  ldz = lsame_(&jobz,"V") ? MAX(1,n) : 1;
  iu = NUM2INT(rblapack_iu);
  m = lsame_(&range,"I") ? iu-il+1 : n;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_w = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  w = NA_PTR_TYPE(rblapack_w, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = MAX(1,m);
    rblapack_z = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  z = NA_PTR_TYPE(rblapack_z, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 2*MAX(1,m);
    rblapack_isuppz = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  isuppz = NA_PTR_TYPE(rblapack_isuppz, integer*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d_out__ = NA_PTR_TYPE(rblapack_d_out__, doublereal*);
  MEMCPY(d_out__, d, doublereal, NA_TOTAL(rblapack_d));
  rblapack_d = rblapack_d_out__;
  d = d_out__;
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,n-1);
    rblapack_e_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e_out__ = NA_PTR_TYPE(rblapack_e_out__, doublereal*);
  MEMCPY(e_out__, e, doublereal, NA_TOTAL(rblapack_e));
  rblapack_e = rblapack_e_out__;
  e = e_out__;

  dstevr_(&jobz, &range, &n, d, e, &vl, &vu, &il, &iu, &abstol, &m, w, z, &ldz, isuppz, work, &lwork, iwork, &liwork, &info);

  rblapack_m = INT2NUM(m);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_m, rblapack_w, rblapack_z, rblapack_isuppz, rblapack_work, rblapack_iwork, rblapack_info, rblapack_d, rblapack_e);
}

void
init_lapack_dstevr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dstevr", rblapack_dstevr, -1);
}
ruby-lapack-1.7.2/ext/dsposv.c0000644000175000017500000002027312502221017016045 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsposv_(char* uplo, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* work, real* swork, integer* iter, integer* info);


static VALUE
rblapack_dsposv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_iter;
  integer iter; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  doublereal *work;
  real *swork;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  x, iter, info, a = NumRu::Lapack.dsposv( uplo, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSPOSV( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, WORK, SWORK, ITER, INFO )\n\n*  Purpose\n*  =======\n*\n*  DSPOSV computes the solution to a real system of linear equations\n*     A * X = B,\n*  where A is an N-by-N symmetric positive definite matrix and X and B\n*  are N-by-NRHS matrices.\n*\n*  DSPOSV first attempts to factorize the matrix in SINGLE PRECISION\n*  and use this factorization within an iterative refinement procedure\n*  to produce a solution with DOUBLE PRECISION normwise backward error\n*  quality (see below). If the approach fails the method switches to a\n*  DOUBLE PRECISION factorization and solve.\n*\n*  The iterative refinement is not going to be a winning strategy if\n*  the ratio SINGLE PRECISION performance over DOUBLE PRECISION\n*  performance is too small. A reasonable strategy should take the\n*  number of right-hand sides and the size of the matrix into account.\n*  This might be done with a call to ILAENV in the future. Up to now, we\n*  always try iterative refinement.\n*\n*  The iterative refinement process is stopped if\n*      ITER > ITERMAX\n*  or for all the RHS we have:\n*      RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX\n*  where\n*      o ITER is the number of the current iteration in the iterative\n*        refinement process\n*      o RNRM is the infinity-norm of the residual\n*      o XNRM is the infinity-norm of the solution\n*      o ANRM is the infinity-operator-norm of the matrix A\n*      o EPS is the machine epsilon returned by DLAMCH('Epsilon')\n*  The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00\n*  respectively.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  Upper triangle of A is stored;\n*          = 'L':  Lower triangle of A is stored.\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array,\n*          dimension (LDA,N)\n*          On entry, the symmetric matrix A.  If UPLO = 'U', the leading\n*          N-by-N upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading N-by-N lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*          On exit, if iterative refinement has been successfully used\n*          (INFO.EQ.0 and ITER.GE.0, see description below), then A is\n*          unchanged, if double precision factorization has been used\n*          (INFO.EQ.0 and ITER.LT.0, see description below), then the\n*          array A contains the factor U or L from the Cholesky\n*          factorization A = U**T*U or A = L*L**T.\n*\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          The N-by-NRHS right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*          If INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  WORK    (workspace) DOUBLE PRECISION array, dimension (N,NRHS)\n*          This array is used to hold the residual vectors.\n*\n*  SWORK   (workspace) REAL array, dimension (N*(N+NRHS))\n*          This array is used to use the single precision matrix and the\n*          right-hand sides or solutions in single precision.\n*\n*  ITER    (output) INTEGER\n*          < 0: iterative refinement has failed, double precision\n*               factorization has been performed\n*               -1 : the routine fell back to full precision for\n*                    implementation- or machine-specific reasons\n*               -2 : narrowing the precision induced an overflow,\n*                    the routine fell back to full precision\n*               -3 : failure of SPOTRF\n*               -31: stop the iterative refinement after the 30th\n*                    iterations\n*          > 0: iterative refinement has been sucessfully used.\n*               Returns the number of iterations\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 leading minor of order i of (DOUBLE\n*                PRECISION) A is not positive definite, so the\n*                factorization could not be completed, and the solution\n*                has not been computed.\n*\n*  =========\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, iter, info, a = NumRu::Lapack.dsposv( uplo, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  rblapack_b = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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);
  ldb = NA_SHAPE0(rblapack_b);
  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 (!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*);
  ldx = MAX(1,n);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t 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, (n)*(nrhs));
  swork = ALLOC_N(real, (n*(n+nrhs)));

  dsposv_(&uplo, &n, &nrhs, a, &lda, b, &ldb, x, &ldx, work, swork, &iter, &info);

  free(work);
  free(swork);
  rblapack_iter = INT2NUM(iter);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_x, rblapack_iter, rblapack_info, rblapack_a);
}

void
init_lapack_dsposv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsposv", rblapack_dsposv, -1);
}
ruby-lapack-1.7.2/ext/slatrz.c0000644000175000017500000001165512502221024016050 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slatrz_(integer* m, integer* n, integer* l, real* a, integer* lda, real* tau, real* work);


static VALUE
rblapack_slatrz(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_l;
  integer l; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_a_out__;
  real *a_out__;
  real *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, a = NumRu::Lapack.slatrz( l, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLATRZ( M, N, L, A, LDA, TAU, WORK )\n\n*  Purpose\n*  =======\n*\n*  SLATRZ factors the M-by-(M+L) real upper trapezoidal matrix\n*  [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R  0 ) * Z, by means\n*  of orthogonal transformations.  Z is an (M+L)-by-(M+L) orthogonal\n*  matrix and, R and A1 are M-by-M upper triangular matrices.\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*  L       (input) INTEGER\n*          The number of columns of the matrix A containing the\n*          meaningful part of the Householder vectors. N-M >= L >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the leading M-by-N upper trapezoidal part of the\n*          array A must contain the matrix to be factorized.\n*          On exit, the leading M-by-M upper triangular part of A\n*          contains the upper triangular matrix R, and elements N-L+1 to\n*          N of the first M rows of A, with the array TAU, represent the\n*          orthogonal matrix Z as a product of M elementary reflectors.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  TAU     (output) REAL array, dimension (M)\n*          The scalar factors of the elementary reflectors.\n*\n*  WORK    (workspace) REAL array, dimension (M)\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*\n*  The factorization is obtained by Householder's method.  The kth\n*  transformation matrix, Z( k ), which is used to introduce zeros into\n*  the ( m - k + 1 )th row of A, is given in the form\n*\n*     Z( k ) = ( I     0   ),\n*              ( 0  T( k ) )\n*\n*  where\n*\n*     T( k ) = I - tau*u( k )*u( k )',   u( k ) = (   1    ),\n*                                                 (   0    )\n*                                                 ( z( k ) )\n*\n*  tau is a scalar and z( k ) is an l element vector. tau and z( k )\n*  are chosen to annihilate the elements of the kth row of A2.\n*\n*  The scalar tau is returned in the kth element of TAU and the vector\n*  u( k ) in the kth row of A2, such that the elements of z( k ) are\n*  in  a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in\n*  the upper triangular part of A1.\n*\n*  Z is given by\n*\n*     Z =  Z( 1 ) * Z( 2 ) * ... * Z( m ).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  tau, a = NumRu::Lapack.slatrz( l, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_l = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  l = NUM2INT(rblapack_l);
  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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  m = lda;
  {
    na_shape_t shape[1];
    shape[0] = m;
    rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(real, (m));

  slatrz_(&m, &n, &l, a, &lda, tau, work);

  free(work);
  return rb_ary_new3(2, rblapack_tau, rblapack_a);
}

void
init_lapack_slatrz(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slatrz", rblapack_slatrz, -1);
}
ruby-lapack-1.7.2/ext/dla_porfsx_extended.c0000644000175000017500000005562212502221023020553 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dla_porfsx_extended_(integer* prec_type, char* uplo, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* af, integer* ldaf, logical* colequ, doublereal* c, doublereal* b, integer* ldb, doublereal* y, integer* ldy, doublereal* berr_out, integer* n_norms, doublereal* err_bnds_norm, doublereal* err_bnds_comp, doublereal* res, doublereal* ayb, doublereal* dy, doublereal* y_tail, doublereal* rcond, integer* ithresh, doublereal* rthresh, doublereal* dz_ub, logical* ignore_cwise, integer* info);


static VALUE
rblapack_dla_porfsx_extended(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_prec_type;
  integer prec_type; 
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_af;
  doublereal *af; 
  VALUE rblapack_colequ;
  logical colequ; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_y;
  doublereal *y; 
  VALUE rblapack_n_norms;
  integer n_norms; 
  VALUE rblapack_err_bnds_norm;
  doublereal *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  doublereal *err_bnds_comp; 
  VALUE rblapack_res;
  doublereal *res; 
  VALUE rblapack_ayb;
  doublereal *ayb; 
  VALUE rblapack_dy;
  doublereal *dy; 
  VALUE rblapack_y_tail;
  doublereal *y_tail; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_ithresh;
  integer ithresh; 
  VALUE rblapack_rthresh;
  doublereal rthresh; 
  VALUE rblapack_dz_ub;
  doublereal dz_ub; 
  VALUE rblapack_ignore_cwise;
  logical ignore_cwise; 
  VALUE rblapack_berr_out;
  doublereal *berr_out; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_y_out__;
  doublereal *y_out__;
  VALUE rblapack_err_bnds_norm_out__;
  doublereal *err_bnds_norm_out__;
  VALUE rblapack_err_bnds_comp_out__;
  doublereal *err_bnds_comp_out__;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldy;
  integer n_err_bnds;

  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  berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.dla_porfsx_extended( prec_type, uplo, a, af, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO )\n\n*  Purpose\n*  =======\n*\n*  DLA_PORFSX_EXTENDED improves the computed solution to a system of\n*  linear equations by performing extra-precise iterative refinement\n*  and provides error bounds and backward error estimates for the solution.\n*  This subroutine is called by DPORFSX to perform iterative refinement.\n*  In addition to normwise error bound, the code provides maximum\n*  componentwise error bound if possible. See comments for ERR_BNDS_NORM\n*  and ERR_BNDS_COMP for details of the error bounds. Note that this\n*  subroutine is only resonsible for setting the second fields of\n*  ERR_BNDS_NORM and ERR_BNDS_COMP.\n*\n\n*  Arguments\n*  =========\n*\n*     PREC_TYPE      (input) INTEGER\n*     Specifies the intermediate precision to be used in refinement.\n*     The value is defined by ILAPREC(P) where P is a CHARACTER and\n*     P    = 'S':  Single\n*          = 'D':  Double\n*          = 'I':  Indigenous\n*          = 'X', 'E':  Extra\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     N              (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NRHS           (input) INTEGER\n*     The number of right-hand-sides, i.e., the number of columns of the\n*     matrix B.\n*\n*     A              (input) DOUBLE PRECISION array, dimension (LDA,N)\n*     On entry, the N-by-N matrix A.\n*\n*     LDA            (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF             (input) DOUBLE PRECISION array, dimension (LDAF,N)\n*     The triangular factor U or L from the Cholesky factorization\n*     A = U**T*U or A = L*L**T, as computed by DPOTRF.\n*\n*     LDAF           (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     COLEQU         (input) LOGICAL\n*     If .TRUE. then column equilibration was done to A before calling\n*     this routine. This is needed to compute the solution and error\n*     bounds correctly.\n*\n*     C              (input) DOUBLE PRECISION array, dimension (N)\n*     The column scale factors for A. If COLEQU = .FALSE., C\n*     is not accessed. If C is input, each element of C should be a power\n*     of the radix to ensure a reliable solution and error estimates.\n*     Scaling by powers of the radix does not cause rounding errors unless\n*     the result underflows or overflows. Rounding errors during scaling\n*     lead to refining with a matrix that is not equivalent to the\n*     input matrix, producing error estimates that may not be\n*     reliable.\n*\n*     B              (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*     The right-hand-side matrix B.\n*\n*     LDB            (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     Y              (input/output) DOUBLE PRECISION array, dimension\n*                    (LDY,NRHS)\n*     On entry, the solution matrix X, as computed by DPOTRS.\n*     On exit, the improved solution matrix Y.\n*\n*     LDY            (input) INTEGER\n*     The leading dimension of the array Y.  LDY >= max(1,N).\n*\n*     BERR_OUT       (output) DOUBLE PRECISION array, dimension (NRHS)\n*     On exit, BERR_OUT(j) contains the componentwise relative backward\n*     error for right-hand-side j from the formula\n*         max(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n*     where abs(Z) is the componentwise absolute value of the matrix\n*     or vector Z. This is computed by DLA_LIN_BERR.\n*\n*     N_NORMS        (input) INTEGER\n*     Determines which error bounds to return (see ERR_BNDS_NORM\n*     and ERR_BNDS_COMP).\n*     If N_NORMS >= 1 return normwise error bounds.\n*     If N_NORMS >= 2 return componentwise error bounds.\n*\n*     ERR_BNDS_NORM  (input/output) DOUBLE PRECISION array, dimension\n*                    (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (input/output) DOUBLE PRECISION array, dimension\n*                    (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * slamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * slamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * slamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     This subroutine is only responsible for setting the second field\n*     above.\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     RES            (input) DOUBLE PRECISION array, dimension (N)\n*     Workspace to hold the intermediate residual.\n*\n*     AYB            (input) DOUBLE PRECISION array, dimension (N)\n*     Workspace. This can be the same workspace passed for Y_TAIL.\n*\n*     DY             (input) DOUBLE PRECISION array, dimension (N)\n*     Workspace to hold the intermediate solution.\n*\n*     Y_TAIL         (input) DOUBLE PRECISION array, dimension (N)\n*     Workspace to hold the trailing bits of the intermediate solution.\n*\n*     RCOND          (input) DOUBLE PRECISION\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     ITHRESH        (input) INTEGER\n*     The maximum number of residual computations allowed for\n*     refinement. The default is 10. For 'aggressive' set to 100 to\n*     permit convergence using approximate factorizations or\n*     factorizations other than LU. If the factorization uses a\n*     technique other than Gaussian elimination, the guarantees in\n*     ERR_BNDS_NORM and ERR_BNDS_COMP may no longer be trustworthy.\n*\n*     RTHRESH        (input) DOUBLE PRECISION\n*     Determines when to stop refinement if the error estimate stops\n*     decreasing. Refinement will stop when the next solution no longer\n*     satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is\n*     the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The\n*     default value is 0.5. For 'aggressive' set to 0.9 to permit\n*     convergence on extremely ill-conditioned matrices. See LAWN 165\n*     for more details.\n*\n*     DZ_UB          (input) DOUBLE PRECISION\n*     Determines when to start considering componentwise convergence.\n*     Componentwise convergence is only considered after each component\n*     of the solution Y is stable, which we definte as the relative\n*     change in each component being less than DZ_UB. The default value\n*     is 0.25, requiring the first bit to be stable. See LAWN 165 for\n*     more details.\n*\n*     IGNORE_CWISE   (input) LOGICAL\n*     If .TRUE. then ignore componentwise convergence. Default value\n*     is .FALSE..\n*\n*     INFO           (output) INTEGER\n*       = 0:  Successful exit.\n*       < 0:  if INFO = -i, the ith argument to DPOTRS had an illegal\n*             value\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            UPLO2, CNT, I, J, X_STATE, Z_STATE\n      DOUBLE PRECISION   YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,\n     $                   DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX,\n     $                   DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z,\n     $                   EPS, HUGEVAL, INCR_THRESH\n      LOGICAL            INCR_PREC\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  berr_out, info, y, err_bnds_norm, err_bnds_comp = NumRu::Lapack.dla_porfsx_extended( prec_type, uplo, a, af, colequ, c, b, y, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 20 && argc != 20)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 20)", argc);
  rblapack_prec_type = argv[0];
  rblapack_uplo = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_colequ = argv[4];
  rblapack_c = argv[5];
  rblapack_b = argv[6];
  rblapack_y = argv[7];
  rblapack_n_norms = argv[8];
  rblapack_err_bnds_norm = argv[9];
  rblapack_err_bnds_comp = argv[10];
  rblapack_res = argv[11];
  rblapack_ayb = argv[12];
  rblapack_dy = argv[13];
  rblapack_y_tail = argv[14];
  rblapack_rcond = argv[15];
  rblapack_ithresh = argv[16];
  rblapack_rthresh = argv[17];
  rblapack_dz_ub = argv[18];
  rblapack_ignore_cwise = argv[19];
  if (argc == 20) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  prec_type = NUM2INT(rblapack_prec_type);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  colequ = (rblapack_colequ == Qtrue);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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*);
  n_norms = NUM2INT(rblapack_n_norms);
  if (!NA_IsNArray(rblapack_err_bnds_comp))
    rb_raise(rb_eArgError, "err_bnds_comp (11th argument) must be NArray");
  if (NA_RANK(rblapack_err_bnds_comp) != 2)
    rb_raise(rb_eArgError, "rank of err_bnds_comp (11th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_err_bnds_comp) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_comp must be the same as shape 1 of b");
  n_err_bnds = NA_SHAPE1(rblapack_err_bnds_comp);
  if (NA_TYPE(rblapack_err_bnds_comp) != NA_DFLOAT)
    rblapack_err_bnds_comp = na_change_type(rblapack_err_bnds_comp, NA_DFLOAT);
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
  if (!NA_IsNArray(rblapack_ayb))
    rb_raise(rb_eArgError, "ayb (13th argument) must be NArray");
  if (NA_RANK(rblapack_ayb) != 1)
    rb_raise(rb_eArgError, "rank of ayb (13th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ayb) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ayb must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ayb) != NA_DFLOAT)
    rblapack_ayb = na_change_type(rblapack_ayb, NA_DFLOAT);
  ayb = NA_PTR_TYPE(rblapack_ayb, doublereal*);
  if (!NA_IsNArray(rblapack_y_tail))
    rb_raise(rb_eArgError, "y_tail (15th argument) must be NArray");
  if (NA_RANK(rblapack_y_tail) != 1)
    rb_raise(rb_eArgError, "rank of y_tail (15th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y_tail) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of y_tail must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_y_tail) != NA_DFLOAT)
    rblapack_y_tail = na_change_type(rblapack_y_tail, NA_DFLOAT);
  y_tail = NA_PTR_TYPE(rblapack_y_tail, doublereal*);
  ithresh = NUM2INT(rblapack_ithresh);
  dz_ub = NUM2DBL(rblapack_dz_ub);
  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 1)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_c) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_err_bnds_norm))
    rb_raise(rb_eArgError, "err_bnds_norm (10th argument) must be NArray");
  if (NA_RANK(rblapack_err_bnds_norm) != 2)
    rb_raise(rb_eArgError, "rank of err_bnds_norm (10th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_err_bnds_norm) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 0 of err_bnds_norm must be the same as shape 1 of b");
  if (NA_SHAPE1(rblapack_err_bnds_norm) != n_err_bnds)
    rb_raise(rb_eRuntimeError, "shape 1 of err_bnds_norm must be the same as shape 1 of err_bnds_comp");
  if (NA_TYPE(rblapack_err_bnds_norm) != NA_DFLOAT)
    rblapack_err_bnds_norm = na_change_type(rblapack_err_bnds_norm, NA_DFLOAT);
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
  if (!NA_IsNArray(rblapack_dy))
    rb_raise(rb_eArgError, "dy (14th argument) must be NArray");
  if (NA_RANK(rblapack_dy) != 1)
    rb_raise(rb_eArgError, "rank of dy (14th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_dy) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of dy must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_dy) != NA_DFLOAT)
    rblapack_dy = na_change_type(rblapack_dy, NA_DFLOAT);
  dy = NA_PTR_TYPE(rblapack_dy, doublereal*);
  rthresh = NUM2DBL(rblapack_rthresh);
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
  af = NA_PTR_TYPE(rblapack_af, doublereal*);
  if (!NA_IsNArray(rblapack_res))
    rb_raise(rb_eArgError, "res (12th argument) must be NArray");
  if (NA_RANK(rblapack_res) != 1)
    rb_raise(rb_eArgError, "rank of res (12th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_res) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_res) != NA_DFLOAT)
    rblapack_res = na_change_type(rblapack_res, NA_DFLOAT);
  res = NA_PTR_TYPE(rblapack_res, doublereal*);
  ignore_cwise = (rblapack_ignore_cwise == Qtrue);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (8th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 2)
    rb_raise(rb_eArgError, "rank of y (8th argument) must be %d", 2);
  ldy = NA_SHAPE0(rblapack_y);
  if (NA_SHAPE1(rblapack_y) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of y must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_y) != NA_DFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_DFLOAT);
  y = NA_PTR_TYPE(rblapack_y, doublereal*);
  rcond = NUM2DBL(rblapack_rcond);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr_out = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr_out = NA_PTR_TYPE(rblapack_berr_out, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldy;
    shape[1] = nrhs;
    rblapack_y_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, doublereal*);
  MEMCPY(y_out__, y, doublereal, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm_out__ = NA_PTR_TYPE(rblapack_err_bnds_norm_out__, doublereal*);
  MEMCPY(err_bnds_norm_out__, err_bnds_norm, doublereal, NA_TOTAL(rblapack_err_bnds_norm));
  rblapack_err_bnds_norm = rblapack_err_bnds_norm_out__;
  err_bnds_norm = err_bnds_norm_out__;
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp_out__ = NA_PTR_TYPE(rblapack_err_bnds_comp_out__, doublereal*);
  MEMCPY(err_bnds_comp_out__, err_bnds_comp, doublereal, NA_TOTAL(rblapack_err_bnds_comp));
  rblapack_err_bnds_comp = rblapack_err_bnds_comp_out__;
  err_bnds_comp = err_bnds_comp_out__;

  dla_porfsx_extended_(&prec_type, &uplo, &n, &nrhs, a, &lda, af, &ldaf, &colequ, c, b, &ldb, y, &ldy, berr_out, &n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, &rcond, &ithresh, &rthresh, &dz_ub, &ignore_cwise, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_berr_out, rblapack_info, rblapack_y, rblapack_err_bnds_norm, rblapack_err_bnds_comp);
}

void
init_lapack_dla_porfsx_extended(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dla_porfsx_extended", rblapack_dla_porfsx_extended, -1);
}
ruby-lapack-1.7.2/ext/sgerfs.c0000644000175000017500000002033212502221026016014 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgerfs_(char* trans, integer* n, integer* nrhs, real* a, integer* lda, real* af, integer* ldaf, integer* ipiv, real* b, integer* ldb, real* x, integer* ldx, real* ferr, real* berr, real* work, integer* iwork, integer* info);


static VALUE
rblapack_sgerfs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_af;
  real *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_ferr;
  real *ferr; 
  VALUE rblapack_berr;
  real *berr; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  real *x_out__;
  real *work;
  integer *iwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;

  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  ferr, berr, info, x = NumRu::Lapack.sgerfs( trans, a, af, ipiv, b, x, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGERFS improves the computed solution to a system of linear\n*  equations and provides error bounds and backward error estimates for\n*  the solution.\n*\n\n*  Arguments\n*  =========\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input) REAL array, dimension (LDA,N)\n*          The original N-by-N matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AF      (input) REAL array, dimension (LDAF,N)\n*          The factors L and U from the factorization A = P*L*U\n*          as computed by SGETRF.\n*\n*  LDAF    (input) INTEGER\n*          The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*  IPIV    (input) INTEGER array, dimension (N)\n*          The pivot indices from SGETRF; for 1<=i<=N, row i of the\n*          matrix was interchanged with row IPIV(i).\n*\n*  B       (input) REAL array, dimension (LDB,NRHS)\n*          The right hand side matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (input/output) REAL array, dimension (LDX,NRHS)\n*          On entry, the solution matrix X, as computed by SGETRS.\n*          On exit, the improved solution matrix X.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  FERR    (output) REAL array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) REAL array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace) REAL array, dimension (3*N)\n*\n*  IWORK   (workspace) INTEGER array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -i, the i-th argument had an illegal value\n*\n*  Internal Parameters\n*  ===================\n*\n*  ITMAX is the maximum number of steps of iterative refinement.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ferr, berr, info, x = NumRu::Lapack.sgerfs( trans, a, af, ipiv, b, x, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_trans = argv[0];
  rblapack_a = argv[1];
  rblapack_af = argv[2];
  rblapack_ipiv = argv[3];
  rblapack_b = argv[4];
  rblapack_x = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (3th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (3th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  n = NA_SHAPE1(rblapack_af);
  if (NA_TYPE(rblapack_af) != NA_SFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_SFLOAT);
  af = NA_PTR_TYPE(rblapack_af, real*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (5th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (5th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (6th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (6th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (4th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of af");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, real*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, real*);
  MEMCPY(x_out__, x, real, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  work = ALLOC_N(real, (3*n));
  iwork = ALLOC_N(integer, (n));

  sgerfs_(&trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, b, &ldb, x, &ldx, ferr, berr, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ferr, rblapack_berr, rblapack_info, rblapack_x);
}

void
init_lapack_sgerfs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgerfs", rblapack_sgerfs, -1);
}
ruby-lapack-1.7.2/ext/sgelsy.c0000644000175000017500000002377312502221024016043 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgelsy_(integer* m, integer* n, integer* nrhs, real* a, integer* lda, real* b, integer* ldb, integer* jpvt, real* rcond, integer* rank, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sgelsy(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_jpvt;
  integer *jpvt; 
  VALUE rblapack_rcond;
  real rcond; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_rank;
  integer rank; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_b_out__;
  real *b_out__;
  VALUE rblapack_jpvt_out__;
  integer *jpvt_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  rank, work, info, a, b, jpvt = NumRu::Lapack.sgelsy( a, b, jpvt, rcond, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGELSY computes the minimum-norm solution to a real linear least\n*  squares problem:\n*      minimize || A * X - B ||\n*  using a complete orthogonal factorization of A.  A is an M-by-N\n*  matrix which may be rank-deficient.\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*  The routine first computes a QR factorization with column pivoting:\n*      A * P = Q * [ R11 R12 ]\n*                  [  0  R22 ]\n*  with R11 defined as the largest leading submatrix whose estimated\n*  condition number is less than 1/RCOND.  The order of R11, RANK,\n*  is the effective rank of A.\n*\n*  Then, R22 is considered to be negligible, and R12 is annihilated\n*  by orthogonal transformations from the right, arriving at the\n*  complete orthogonal factorization:\n*     A * P = Q * [ T11 0 ] * Z\n*                 [  0  0 ]\n*  The minimum-norm solution is then\n*     X = P * Z' [ inv(T11)*Q1'*B ]\n*                [        0       ]\n*  where Q1 consists of the first RANK columns of Q.\n*\n*  This routine is basically identical to the original xGELSX except\n*  three differences:\n*    o The call to the subroutine xGEQPF has been substituted by the\n*      the call to the subroutine xGEQP3. This subroutine is a Blas-3\n*      version of the QR factorization with column pivoting.\n*    o Matrix B (the right hand side) is updated with Blas-3.\n*    o The permutation of matrix B (the right hand side) is faster and\n*      more simple.\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*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of\n*          columns of matrices B and X. NRHS >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the M-by-N matrix A.\n*          On exit, A has been overwritten by details of its\n*          complete orthogonal factorization.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the M-by-NRHS right hand side matrix B.\n*          On exit, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,M,N).\n*\n*  JPVT    (input/output) INTEGER array, dimension (N)\n*          On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted\n*          to the front of AP, otherwise column i is a free column.\n*          On exit, if JPVT(i) = k, then the i-th column of AP\n*          was the k-th column of A.\n*\n*  RCOND   (input) REAL\n*          RCOND is used to determine the effective rank of A, which\n*          is defined as the order of the largest leading triangular\n*          submatrix R11 in the QR factorization with pivoting of A,\n*          whose estimated condition number < 1/RCOND.\n*\n*  RANK    (output) INTEGER\n*          The effective rank of A, i.e., the order of the submatrix\n*          R11.  This is the same as the order of the submatrix T11\n*          in the complete orthogonal factorization of A.\n*\n*  WORK    (workspace/output) REAL 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*          The unblocked strategy requires that:\n*             LWORK >= MAX( MN+3*N+1, 2*MN+NRHS ),\n*          where MN = min( M, N ).\n*          The block algorithm requires that:\n*             LWORK >= MAX( MN+2*N+NB*(N+1), 2*MN+NB*NRHS ),\n*          where NB is an upper bound on the blocksize returned\n*          by ILAENV for the routines SGEQP3, STZRZF, STZRQF, SORMQR,\n*          and SORMRZ.\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*  Based on contributions by\n*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA\n*    E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n*    G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rank, work, info, a, b, jpvt = NumRu::Lapack.sgelsy( a, b, jpvt, rcond, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_a = argv[0];
  rblapack_b = argv[1];
  rblapack_jpvt = argv[2];
  rblapack_rcond = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } 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 (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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  if (!NA_IsNArray(rblapack_jpvt))
    rb_raise(rb_eArgError, "jpvt (3th argument) must be NArray");
  if (NA_RANK(rblapack_jpvt) != 1)
    rb_raise(rb_eArgError, "rank of jpvt (3th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_jpvt) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of jpvt must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_jpvt) != NA_LINT)
    rblapack_jpvt = na_change_type(rblapack_jpvt, NA_LINT);
  jpvt = NA_PTR_TYPE(rblapack_jpvt, integer*);
  m = lda;
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (2th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (2th 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_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  if (rblapack_lwork == Qnil)
    lwork = MAX(MIN(m,n)+3*n+1, 2*MIN(m,n)+nrhs);
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  rcond = (real)NUM2DBL(rblapack_rcond);
  ldb = MAX(m,n);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = MAX(m, n);
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  {
    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__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_jpvt_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  jpvt_out__ = NA_PTR_TYPE(rblapack_jpvt_out__, integer*);
  MEMCPY(jpvt_out__, jpvt, integer, NA_TOTAL(rblapack_jpvt));
  rblapack_jpvt = rblapack_jpvt_out__;
  jpvt = jpvt_out__;

  sgelsy_(&m, &n, &nrhs, a, &lda, b, &ldb, jpvt, &rcond, &rank, work, &lwork, &info);

  rblapack_rank = INT2NUM(rank);
  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(6, rblapack_rank, rblapack_work, rblapack_info, rblapack_a, rblapack_b, rblapack_jpvt);
}

void
init_lapack_sgelsy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgelsy", rblapack_sgelsy, -1);
}
ruby-lapack-1.7.2/ext/cggbal.c0000644000175000017500000001732612502221024015751 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cggbal_(char* job, integer* n, complex* a, integer* lda, complex* b, integer* ldb, integer* ilo, integer* ihi, real* lscale, real* rscale, real* work, integer* info);


static VALUE
rblapack_cggbal(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_job;
  char job; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_ilo;
  integer ilo; 
  VALUE rblapack_ihi;
  integer ihi; 
  VALUE rblapack_lscale;
  real *lscale; 
  VALUE rblapack_rscale;
  real *rscale; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;
  real *work;

  integer lda;
  integer n;
  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  ilo, ihi, lscale, rscale, info, a, b = NumRu::Lapack.cggbal( job, a, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGGBAL balances a pair of general complex matrices (A,B).  This\n*  involves, first, permuting A and B by similarity transformations to\n*  isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N\n*  elements on the diagonal; and second, applying a diagonal similarity\n*  transformation to rows and columns ILO to IHI to make the rows\n*  and columns as close in norm as possible. Both steps are optional.\n*\n*  Balancing may reduce the 1-norm of the matrices, and improve the\n*  accuracy of the computed eigenvalues and/or eigenvectors in the\n*  generalized eigenvalue problem A*x = lambda*B*x.\n*\n\n*  Arguments\n*  =========\n*\n*  JOB     (input) CHARACTER*1\n*          Specifies the operations to be performed on A and B:\n*          = 'N':  none:  simply set ILO = 1, IHI = N, LSCALE(I) = 1.0\n*                  and RSCALE(I) = 1.0 for i=1,...,N;\n*          = 'P':  permute only;\n*          = 'S':  scale only;\n*          = 'B':  both permute and scale.\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B.  N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension (LDA,N)\n*          On entry, the input matrix A.\n*          On exit, A is overwritten by the balanced matrix.\n*          If JOB = 'N', A is not referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,N)\n*          On entry, the input matrix B.\n*          On exit, B is overwritten by the balanced matrix.\n*          If JOB = 'N', B is not referenced.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  ILO     (output) INTEGER\n*  IHI     (output) INTEGER\n*          ILO and IHI are set to integers such that on exit\n*          A(i,j) = 0 and B(i,j) = 0 if i > j and\n*          j = 1,...,ILO-1 or i = IHI+1,...,N.\n*          If JOB = 'N' or 'S', ILO = 1 and IHI = N.\n*\n*  LSCALE  (output) REAL array, dimension (N)\n*          Details of the permutations and scaling factors applied\n*          to the left side of A and B.  If P(j) is the index of the\n*          row interchanged with row j, and D(j) is the scaling factor\n*          applied to row j, then\n*            LSCALE(j) = P(j)    for J = 1,...,ILO-1\n*                      = D(j)    for J = ILO,...,IHI\n*                      = P(j)    for J = IHI+1,...,N.\n*          The order in which the interchanges are made is N to IHI+1,\n*          then 1 to ILO-1.\n*\n*  RSCALE  (output) REAL array, dimension (N)\n*          Details of the permutations and scaling factors applied\n*          to the right side of A and B.  If P(j) is the index of the\n*          column interchanged with column j, and D(j) is the scaling\n*          factor applied to column j, then\n*            RSCALE(j) = P(j)    for J = 1,...,ILO-1\n*                      = D(j)    for J = ILO,...,IHI\n*                      = P(j)    for J = IHI+1,...,N.\n*          The order in which the interchanges are made is N to IHI+1,\n*          then 1 to ILO-1.\n*\n*  WORK    (workspace) REAL array, dimension (lwork)\n*          lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and\n*          at least 1 when JOB = 'N' or 'P'.\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*  See R.C. WARD, Balancing the generalized eigenvalue problem,\n*                 SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ilo, ihi, lscale, rscale, info, a, b = NumRu::Lapack.cggbal( job, a, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_job = argv[0];
  rblapack_a = argv[1];
  rblapack_b = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  job = StringValueCStr(rblapack_job)[0];
  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);
  ldb = NA_SHAPE0(rblapack_b);
  n = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  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);
  if (NA_SHAPE1(rblapack_a) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_lscale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  lscale = NA_PTR_TYPE(rblapack_lscale, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_rscale = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  rscale = NA_PTR_TYPE(rblapack_rscale, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  work = ALLOC_N(real, ((lsame_(&job,"S")||lsame_(&job,"B")) ? MAX(1,6*n) : (lsame_(&job,"N")||lsame_(&job,"P")) ? 1 : 0));

  cggbal_(&job, &n, a, &lda, b, &ldb, &ilo, &ihi, lscale, rscale, work, &info);

  free(work);
  rblapack_ilo = INT2NUM(ilo);
  rblapack_ihi = INT2NUM(ihi);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(7, rblapack_ilo, rblapack_ihi, rblapack_lscale, rblapack_rscale, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_cggbal(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cggbal", rblapack_cggbal, -1);
}
ruby-lapack-1.7.2/ext/cla_gbamv.c0000644000175000017500000002007312502221026016440 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cla_gbamv_(integer* trans, integer* m, integer* n, integer* kl, integer* ku, real* alpha, real* ab, integer* ldab, real* x, integer* incx, real* beta, real* y, integer* incy);


static VALUE
rblapack_cla_gbamv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_trans;
  integer trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_alpha;
  real alpha; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_beta;
  real beta; 
  VALUE rblapack_y;
  real *y; 
  VALUE rblapack_incy;
  integer incy; 
  VALUE rblapack_y_out__;
  real *y_out__;

  integer ldab;
  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  y = NumRu::Lapack.cla_gbamv( trans, m, kl, ku, alpha, ab, x, incx, beta, y, incy, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, INCX, BETA, Y, INCY )\n\n*  Purpose\n*  =======\n*\n*  SLA_GBAMV  performs one of the matrix-vector operations\n*\n*          y := alpha*abs(A)*abs(x) + beta*abs(y),\n*     or   y := alpha*abs(A)'*abs(x) + beta*abs(y),\n*\n*  where alpha and beta are scalars, x and y are vectors and A is an\n*  m by n matrix.\n*\n*  This function is primarily used in calculating error bounds.\n*  To protect against underflow during evaluation, components in\n*  the resulting vector are perturbed away from zero by (N+1)\n*  times the underflow threshold.  To prevent unnecessarily large\n*  errors for block-structure embedded in general matrices,\n*  \"symbolically\" zero components are not perturbed.  A zero\n*  entry is considered \"symbolic\" if all multiplications involved\n*  in computing that entry have at least one zero multiplicand.\n*\n\n*  Arguments\n*  ==========\n*\n*  TRANS   (input) INTEGER\n*           On entry, TRANS specifies the operation to be performed as\n*           follows:\n*\n*             BLAS_NO_TRANS      y := alpha*abs(A)*abs(x) + beta*abs(y)\n*             BLAS_TRANS         y := alpha*abs(A')*abs(x) + beta*abs(y)\n*             BLAS_CONJ_TRANS    y := alpha*abs(A')*abs(x) + beta*abs(y)\n*\n*           Unchanged on exit.\n*\n*  M      (input) INTEGER\n*           On entry, M specifies the number of rows of the matrix A.\n*           M must be at least zero.\n*           Unchanged on exit.\n*\n*  N      (input) INTEGER\n*           On entry, N specifies the number of columns of the matrix A.\n*           N must be at least zero.\n*           Unchanged on exit.\n*\n*  KL     (input) INTEGER\n*           The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU     (input) INTEGER\n*           The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  ALPHA  (input) REAL\n*           On entry, ALPHA specifies the scalar alpha.\n*           Unchanged on exit.\n*\n*  A      (input) REAL array, dimension (LDA,n)\n*           Before entry, the leading m by n part of the array A must\n*           contain the matrix of coefficients.\n*           Unchanged on exit.\n*\n*  LDA    (input) INTEGER\n*           On entry, LDA specifies the first dimension of A as declared\n*           in the calling (sub) program. LDA must be at least\n*           max( 1, m ).\n*           Unchanged on exit.\n*\n*  X      (input) REAL array, dimension at least\n*           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'\n*           and at least\n*           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.\n*           Before entry, the incremented array X must contain the\n*           vector x.\n*           Unchanged on exit.\n*\n*  INCX   (input) INTEGER\n*           On entry, INCX specifies the increment for the elements of\n*           X. INCX must not be zero.\n*           Unchanged on exit.\n*\n*  BETA   (input) REAL\n*           On entry, BETA specifies the scalar beta. When BETA is\n*           supplied as zero then Y need not be set on input.\n*           Unchanged on exit.\n*\n*  Y      (input/output) REAL array, dimension at least\n*           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'\n*           and at least\n*           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.\n*           Before entry with BETA non-zero, the incremented array Y\n*           must contain the vector y. On exit, Y is overwritten by the\n*           updated vector y.\n*\n*  INCY   (input) INTEGER\n*           On entry, INCY specifies the increment for the elements of\n*           Y. INCY must not be zero.\n*           Unchanged on exit.\n*\n*\n*  Level 2 Blas routine.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  y = NumRu::Lapack.cla_gbamv( trans, m, kl, ku, alpha, ab, x, incx, beta, y, incy, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 11 && argc != 11)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 11)", argc);
  rblapack_trans = argv[0];
  rblapack_m = argv[1];
  rblapack_kl = argv[2];
  rblapack_ku = argv[3];
  rblapack_alpha = argv[4];
  rblapack_ab = argv[5];
  rblapack_x = argv[6];
  rblapack_incx = argv[7];
  rblapack_beta = argv[8];
  rblapack_y = argv[9];
  rblapack_incy = argv[10];
  if (argc == 11) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  trans = NUM2INT(rblapack_trans);
  kl = NUM2INT(rblapack_kl);
  alpha = (real)NUM2DBL(rblapack_alpha);
  incx = NUM2INT(rblapack_incx);
  incy = NUM2INT(rblapack_incy);
  m = NUM2INT(rblapack_m);
  beta = (real)NUM2DBL(rblapack_beta);
  ldab = MAX(1,m);
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (6th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (6th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_ab) != ldab)
    rb_raise(rb_eRuntimeError, "shape 0 of ab must be MAX(1,m)");
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  if (!NA_IsNArray(rblapack_y))
    rb_raise(rb_eArgError, "y (10th argument) must be NArray");
  if (NA_RANK(rblapack_y) != 1)
    rb_raise(rb_eArgError, "rank of y (10th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_y) != (trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy )))
    rb_raise(rb_eRuntimeError, "shape 0 of y must be %d", trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy ));
  if (NA_TYPE(rblapack_y) != NA_SFLOAT)
    rblapack_y = na_change_type(rblapack_y, NA_SFLOAT);
  y = NA_PTR_TYPE(rblapack_y, real*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (7th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_x) != (trans == ilatrans_("N") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx )))
    rb_raise(rb_eRuntimeError, "shape 0 of x must be %d", trans == ilatrans_("N") ? 1 + ( n - 1 )*abs( incx ) : 1 + ( m - 1 )*abs( incx ));
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  {
    na_shape_t shape[1];
    shape[0] = trans == ilatrans_("N") ? 1 + ( m - 1 )*abs( incy ) : 1 + ( n - 1 )*abs( incy );
    rblapack_y_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  y_out__ = NA_PTR_TYPE(rblapack_y_out__, real*);
  MEMCPY(y_out__, y, real, NA_TOTAL(rblapack_y));
  rblapack_y = rblapack_y_out__;
  y = y_out__;

  cla_gbamv_(&trans, &m, &n, &kl, &ku, &alpha, ab, &ldab, x, &incx, &beta, y, &incy);

  return rblapack_y;
}

void
init_lapack_cla_gbamv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cla_gbamv", rblapack_cla_gbamv, -1);
}
ruby-lapack-1.7.2/ext/sgelq2.c0000644000175000017500000001012712502221020015713 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgelq2_(integer* m, integer* n, real* a, integer* lda, real* tau, real* work, integer* info);


static VALUE
rblapack_sgelq2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  real *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.sgelq2( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGELQ2( M, N, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SGELQ2 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) REAL 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) REAL array, dimension (min(M,N))\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\n*\n*  WORK    (workspace) REAL 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.sgelq2( 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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  m = lda;
  {
    na_shape_t shape[1];
    shape[0] = MIN(m,n);
    rblapack_tau = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(real, (m));

  sgelq2_(&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_sgelq2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgelq2", rblapack_sgelq2, -1);
}
ruby-lapack-1.7.2/ext/dgesvx.c0000644000175000017500000005047212502221026016033 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgesvx_(char* fact, char* trans, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* af, integer* ldaf, integer* ipiv, char* equed, doublereal* r, doublereal* c, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* ferr, doublereal* berr, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dgesvx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_fact;
  char fact; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_af;
  doublereal *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_r;
  doublereal *r; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_ferr;
  doublereal *ferr; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublereal *a_out__;
  VALUE rblapack_af_out__;
  doublereal *af_out__;
  VALUE rblapack_ipiv_out__;
  integer *ipiv_out__;
  VALUE rblapack_r_out__;
  doublereal *r_out__;
  VALUE rblapack_c_out__;
  doublereal *c_out__;
  VALUE rblapack_b_out__;
  doublereal *b_out__;
  integer *iwork;

  integer lda;
  integer n;
  integer ldb;
  integer nrhs;
  integer ldaf;
  integer ldx;

  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  x, rcond, ferr, berr, work, info, a, af, ipiv, equed, r, c, b = NumRu::Lapack.dgesvx( fact, trans, a, b, [:af => af, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGESVX uses the LU factorization to compute the solution to a real\n*  system of linear equations\n*     A * X = B,\n*  where A is an N-by-N matrix and X and B are N-by-NRHS matrices.\n*\n*  Error bounds on the solution and a condition estimate are also\n*  provided.\n*\n*  Description\n*  ===========\n*\n*  The following steps are performed:\n*\n*  1. If FACT = 'E', real scaling factors are computed to equilibrate\n*     the system:\n*        TRANS = 'N':  diag(R)*A*diag(C)     *inv(diag(C))*X = diag(R)*B\n*        TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B\n*        TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B\n*     Whether or not the system will be equilibrated depends on the\n*     scaling of the matrix A, but if equilibration is used, A is\n*     overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')\n*     or diag(C)*B (if TRANS = 'T' or 'C').\n*\n*  2. If FACT = 'N' or 'E', the LU decomposition is used to factor the\n*     matrix A (after equilibration if FACT = 'E') as\n*        A = P * L * U,\n*     where P is a permutation matrix, L is a unit lower triangular\n*     matrix, and U is upper triangular.\n*\n*  3. If some U(i,i)=0, so that U is exactly singular, then the routine\n*     returns with INFO = i. Otherwise, the factored form of A is used\n*     to estimate the condition number of the matrix A.  If the\n*     reciprocal of the condition number is less than machine precision,\n*     INFO = N+1 is returned as a warning, but the routine still goes on\n*     to solve for X and compute error bounds as described below.\n*\n*  4. The system of equations is solved for X using the factored form\n*     of A.\n*\n*  5. Iterative refinement is applied to improve the computed solution\n*     matrix and calculate error bounds and backward error estimates\n*     for it.\n*\n*  6. If equilibration was used, the matrix X is premultiplied by\n*     diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so\n*     that it solves the original system before equilibration.\n*\n\n*  Arguments\n*  =========\n*\n*  FACT    (input) CHARACTER*1\n*          Specifies whether or not the factored form of the matrix A is\n*          supplied on entry, and if not, whether the matrix A should be\n*          equilibrated before it is factored.\n*          = 'F':  On entry, AF and IPIV contain the factored form of A.\n*                  If EQUED is not 'N', the matrix A has been\n*                  equilibrated with scaling factors given by R and C.\n*                  A, AF, and IPIV are not modified.\n*          = 'N':  The matrix A will be copied to AF and factored.\n*          = 'E':  The matrix A will be equilibrated if necessary, then\n*                  copied to AF and factored.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form of the system of equations:\n*          = 'N':  A * X = B     (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Transpose)\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrices B and X.  NRHS >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)\n*          On entry, the N-by-N matrix A.  If FACT = 'F' and EQUED is\n*          not 'N', then A must have been equilibrated by the scaling\n*          factors in R and/or C.  A is not modified if FACT = 'F' or\n*          'N', or if FACT = 'E' and EQUED = 'N' on exit.\n*\n*          On exit, if EQUED .ne. 'N', A is scaled as follows:\n*          EQUED = 'R':  A := diag(R) * A\n*          EQUED = 'C':  A := A * diag(C)\n*          EQUED = 'B':  A := diag(R) * A * diag(C).\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  AF      (input or output) DOUBLE PRECISION array, dimension (LDAF,N)\n*          If FACT = 'F', then AF is an input argument and on entry\n*          contains the factors L and U from the factorization\n*          A = P*L*U as computed by DGETRF.  If EQUED .ne. 'N', then\n*          AF is the factored form of the equilibrated matrix A.\n*\n*          If FACT = 'N', then AF is an output argument and on exit\n*          returns the factors L and U from the factorization A = P*L*U\n*          of the original matrix A.\n*\n*          If FACT = 'E', then AF is an output argument and on exit\n*          returns the factors L and U from the factorization A = P*L*U\n*          of the equilibrated matrix A (see the description of A for\n*          the form of the equilibrated matrix).\n*\n*  LDAF    (input) INTEGER\n*          The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*  IPIV    (input or output) INTEGER array, dimension (N)\n*          If FACT = 'F', then IPIV is an input argument and on entry\n*          contains the pivot indices from the factorization A = P*L*U\n*          as computed by DGETRF; row i of the matrix was interchanged\n*          with row IPIV(i).\n*\n*          If FACT = 'N', then IPIV is an output argument and on exit\n*          contains the pivot indices from the factorization A = P*L*U\n*          of the original matrix A.\n*\n*          If FACT = 'E', then IPIV is an output argument and on exit\n*          contains the pivot indices from the factorization A = P*L*U\n*          of the equilibrated matrix A.\n*\n*  EQUED   (input or output) CHARACTER*1\n*          Specifies the form of equilibration that was done.\n*          = 'N':  No equilibration (always true if FACT = 'N').\n*          = 'R':  Row equilibration, i.e., A has been premultiplied by\n*                  diag(R).\n*          = 'C':  Column equilibration, i.e., A has been postmultiplied\n*                  by diag(C).\n*          = 'B':  Both row and column equilibration, i.e., A has been\n*                  replaced by diag(R) * A * diag(C).\n*          EQUED is an input argument if FACT = 'F'; otherwise, it is an\n*          output argument.\n*\n*  R       (input or output) DOUBLE PRECISION array, dimension (N)\n*          The row scale factors for A.  If EQUED = 'R' or 'B', A is\n*          multiplied on the left by diag(R); if EQUED = 'N' or 'C', R\n*          is not accessed.  R is an input argument if FACT = 'F';\n*          otherwise, R is an output argument.  If FACT = 'F' and\n*          EQUED = 'R' or 'B', each element of R must be positive.\n*\n*  C       (input or output) DOUBLE PRECISION array, dimension (N)\n*          The column scale factors for A.  If EQUED = 'C' or 'B', A is\n*          multiplied on the right by diag(C); if EQUED = 'N' or 'R', C\n*          is not accessed.  C is an input argument if FACT = 'F';\n*          otherwise, C is an output argument.  If FACT = 'F' and\n*          EQUED = 'C' or 'B', each element of C must be positive.\n*\n*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit,\n*          if EQUED = 'N', B is not modified;\n*          if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by\n*          diag(R)*B;\n*          if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is\n*          overwritten by diag(C)*B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\n*\n*  X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X\n*          to the original system of equations.  Note that A and B are\n*          modified on exit if EQUED .ne. 'N', and the solution to the\n*          equilibrated system is inv(diag(C))*X if TRANS = 'N' and\n*          EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'\n*          and EQUED = 'R' or 'B'.\n*\n*  LDX     (input) INTEGER\n*          The leading dimension of the array X.  LDX >= max(1,N).\n*\n*  RCOND   (output) DOUBLE PRECISION\n*          The estimate of the reciprocal condition number of the matrix\n*          A after equilibration (if done).  If RCOND is less than the\n*          machine precision (in particular, if RCOND = 0), the matrix\n*          is singular to working precision.  This condition is\n*          indicated by a return code of INFO > 0.\n*\n*  FERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The estimated forward error bound for each solution vector\n*          X(j) (the j-th column of the solution matrix X).\n*          If XTRUE is the true solution corresponding to X(j), FERR(j)\n*          is an estimated upper bound for the magnitude of the largest\n*          element in (X(j) - XTRUE) divided by the magnitude of the\n*          largest element in X(j).  The estimate is as reliable as\n*          the estimate for RCOND, and is almost always a slight\n*          overestimate of the true error.\n*\n*  BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*          The componentwise relative backward error of each solution\n*          vector X(j) (i.e., the smallest relative change in\n*          any element of A or B that makes X(j) an exact solution).\n*\n*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (4*N)\n*          On exit, WORK(1) contains the reciprocal pivot growth\n*          factor norm(A)/norm(U). The \"max absolute element\" norm is\n*          used. If WORK(1) is much less than 1, then the stability\n*          of the LU factorization of the (equilibrated) matrix A\n*          could be poor. This also means that the solution X, condition\n*          estimator RCOND, and forward error bound FERR could be\n*          unreliable. If factorization fails with 0 0:  if INFO = i, and i is\n*                <= N:  U(i,i) is exactly zero.  The factorization has\n*                       been completed, but the factor U is exactly\n*                       singular, so the solution and error bounds\n*                       could not be computed. RCOND = 0 is returned.\n*                = N+1: U is nonsingular, but RCOND is less than machine\n*                       precision, meaning that the matrix is singular\n*                       to working precision.  Nevertheless, the\n*                       solution and error bounds are computed because\n*                       there are a number of situations where the\n*                       computed solution can be more accurate than the\n*                       value of RCOND would suggest.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  x, rcond, ferr, berr, work, info, a, af, ipiv, equed, r, c, b = NumRu::Lapack.dgesvx( fact, trans, a, b, [:af => af, :ipiv => ipiv, :equed => equed, :r => r, :c => c, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_fact = argv[0];
  rblapack_trans = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  if (argc == 9) {
    rblapack_af = argv[4];
    rblapack_ipiv = argv[5];
    rblapack_equed = argv[6];
    rblapack_r = argv[7];
    rblapack_c = argv[8];
  } else if (rblapack_options != Qnil) {
    rblapack_af = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("af")));
    rblapack_ipiv = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("ipiv")));
    rblapack_equed = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("equed")));
    rblapack_r = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("r")));
    rblapack_c = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("c")));
  } else {
    rblapack_af = Qnil;
    rblapack_ipiv = Qnil;
    rblapack_equed = Qnil;
    rblapack_r = Qnil;
    rblapack_c = Qnil;
  }

  fact = StringValueCStr(rblapack_fact)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  if (rblapack_ipiv != Qnil) {
    if (!NA_IsNArray(rblapack_ipiv))
      rb_raise(rb_eArgError, "ipiv (option) must be NArray");
    if (NA_RANK(rblapack_ipiv) != 1)
      rb_raise(rb_eArgError, "rank of ipiv (option) must be %d", 1);
    if (NA_SHAPE0(rblapack_ipiv) != n)
      rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
    if (NA_TYPE(rblapack_ipiv) != NA_LINT)
      rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
    ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  }
  if (rblapack_r != Qnil) {
    if (!NA_IsNArray(rblapack_r))
      rb_raise(rb_eArgError, "r (option) must be NArray");
    if (NA_RANK(rblapack_r) != 1)
      rb_raise(rb_eArgError, "rank of r (option) must be %d", 1);
    if (NA_SHAPE0(rblapack_r) != n)
      rb_raise(rb_eRuntimeError, "shape 0 of r must be the same as shape 1 of a");
    if (NA_TYPE(rblapack_r) != NA_DFLOAT)
      rblapack_r = na_change_type(rblapack_r, NA_DFLOAT);
    r = NA_PTR_TYPE(rblapack_r, doublereal*);
  }
  ldx = n;
  trans = StringValueCStr(rblapack_trans)[0];
  if (rblapack_equed != Qnil) {
  equed = StringValueCStr(rblapack_equed)[0];
  }
  ldaf = n;
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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_c != Qnil) {
    if (!NA_IsNArray(rblapack_c))
      rb_raise(rb_eArgError, "c (option) must be NArray");
    if (NA_RANK(rblapack_c) != 1)
      rb_raise(rb_eArgError, "rank of c (option) must be %d", 1);
    if (NA_SHAPE0(rblapack_c) != n)
      rb_raise(rb_eRuntimeError, "shape 0 of c must be the same as shape 1 of a");
    if (NA_TYPE(rblapack_c) != NA_DFLOAT)
      rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
    c = NA_PTR_TYPE(rblapack_c, doublereal*);
  }
  if (rblapack_af != Qnil) {
    if (!NA_IsNArray(rblapack_af))
      rb_raise(rb_eArgError, "af (option) must be NArray");
    if (NA_RANK(rblapack_af) != 2)
      rb_raise(rb_eArgError, "rank of af (option) must be %d", 2);
    if (NA_SHAPE0(rblapack_af) != ldaf)
      rb_raise(rb_eRuntimeError, "shape 0 of af must be n");
    if (NA_SHAPE1(rblapack_af) != n)
      rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
    if (NA_TYPE(rblapack_af) != NA_DFLOAT)
      rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
    af = NA_PTR_TYPE(rblapack_af, doublereal*);
  }
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_ferr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  ferr = NA_PTR_TYPE(rblapack_ferr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = 4*n;
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t 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__;
  {
    na_shape_t shape[2];
    shape[0] = ldaf;
    shape[1] = n;
    rblapack_af_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  af_out__ = NA_PTR_TYPE(rblapack_af_out__, doublereal*);
  if (rblapack_af != Qnil) {
    MEMCPY(af_out__, af, doublereal, NA_TOTAL(rblapack_af));
  }
  rblapack_af = rblapack_af_out__;
  af = af_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv_out__ = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv_out__ = NA_PTR_TYPE(rblapack_ipiv_out__, integer*);
  if (rblapack_ipiv != Qnil) {
    MEMCPY(ipiv_out__, ipiv, integer, NA_TOTAL(rblapack_ipiv));
  }
  rblapack_ipiv = rblapack_ipiv_out__;
  ipiv = ipiv_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_r_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  r_out__ = NA_PTR_TYPE(rblapack_r_out__, doublereal*);
  if (rblapack_r != Qnil) {
    MEMCPY(r_out__, r, doublereal, NA_TOTAL(rblapack_r));
  }
  rblapack_r = rblapack_r_out__;
  r = r_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  if (rblapack_c != Qnil) {
    MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  }
  rblapack_c = rblapack_c_out__;
  c = c_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, doublereal*);
  MEMCPY(b_out__, b, doublereal, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  iwork = ALLOC_N(integer, (n));

  dgesvx_(&fact, &trans, &n, &nrhs, a, &lda, af, &ldaf, ipiv, &equed, r, c, b, &ldb, x, &ldx, &rcond, ferr, berr, work, iwork, &info);

  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  rblapack_equed = rb_str_new(&equed,1);
  return rb_ary_new3(13, rblapack_x, rblapack_rcond, rblapack_ferr, rblapack_berr, rblapack_work, rblapack_info, rblapack_a, rblapack_af, rblapack_ipiv, rblapack_equed, rblapack_r, rblapack_c, rblapack_b);
}

void
init_lapack_dgesvx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgesvx", rblapack_dgesvx, -1);
}
ruby-lapack-1.7.2/ext/slassq.c0000644000175000017500000000707212502221025016036 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slassq_(integer* n, real* x, integer* incx, real* scale, real* sumsq);


static VALUE
rblapack_slassq(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_x;
  real *x; 
  VALUE rblapack_incx;
  integer incx; 
  VALUE rblapack_scale;
  real scale; 
  VALUE rblapack_sumsq;
  real sumsq; 

  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  scale, sumsq = NumRu::Lapack.slassq( x, incx, scale, sumsq, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLASSQ( N, X, INCX, SCALE, SUMSQ )\n\n*  Purpose\n*  =======\n*\n*  SLASSQ  returns the values  scl  and  smsq  such that\n*\n*     ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,\n*\n*  where  x( i ) = X( 1 + ( i - 1 )*INCX ). The value of  sumsq  is\n*  assumed to be non-negative and  scl  returns the value\n*\n*     scl = max( scale, abs( x( i ) ) ).\n*\n*  scale and sumsq must be supplied in SCALE and SUMSQ and\n*  scl and smsq are overwritten on SCALE and SUMSQ respectively.\n*\n*  The routine makes only one pass through the vector x.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of elements to be used from the vector X.\n*\n*  X       (input) REAL array, dimension (N)\n*          The vector for which a scaled sum of squares is computed.\n*             x( i )  = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.\n*\n*  INCX    (input) INTEGER\n*          The increment between successive values of the vector X.\n*          INCX > 0.\n*\n*  SCALE   (input/output) REAL\n*          On entry, the value  scale  in the equation above.\n*          On exit, SCALE is overwritten with  scl , the scaling factor\n*          for the sum of squares.\n*\n*  SUMSQ   (input/output) REAL\n*          On entry, the value  sumsq  in the equation above.\n*          On exit, SUMSQ is overwritten with  smsq , the basic sum of\n*          squares from which  scl  has been factored out.\n*\n\n* =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, sumsq = NumRu::Lapack.slassq( x, incx, scale, sumsq, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_x = argv[0];
  rblapack_incx = argv[1];
  rblapack_scale = argv[2];
  rblapack_sumsq = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (1th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (1th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_SFLOAT);
  x = NA_PTR_TYPE(rblapack_x, real*);
  scale = (real)NUM2DBL(rblapack_scale);
  incx = NUM2INT(rblapack_incx);
  sumsq = (real)NUM2DBL(rblapack_sumsq);

  slassq_(&n, x, &incx, &scale, &sumsq);

  rblapack_scale = rb_float_new((double)scale);
  rblapack_sumsq = rb_float_new((double)sumsq);
  return rb_ary_new3(2, rblapack_scale, rblapack_sumsq);
}

void
init_lapack_slassq(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slassq", rblapack_slassq, -1);
}
ruby-lapack-1.7.2/ext/rb_lapack.c0000644000175000017500000076344712655767577016531 0ustar  uwabamiuwabami#include "ruby.h"
#include "rb_lapack.h"

extern void init_lapack_slabrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlargv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssyconv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zpotri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cla_porpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cungl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgtsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dpotri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlacrt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cpocon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cggbak(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgesvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgtcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgbtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtptri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cggsvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlansy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaed6(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlaset(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsptrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgesc2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slatbs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dormql(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chegs2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztrti2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_strsna(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlatbs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztrexc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgehd2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slanhs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slagts(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgtsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgerfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ilaver(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cggqrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cunmql(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dspgvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtgevc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cggev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clacgv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlangb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgesvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_csysvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sppsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zsptri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlapll(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgesc2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaswp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgbsvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_strsen(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgges(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dptsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sla_wwaddw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cherfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgghrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgttrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgelq2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgesvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slasd4(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_spptrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zcgesv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dpttrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlasd6(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgeequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssysv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cpbrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlaqhe(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlarf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slarf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dla_gercond(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slasd1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztrtri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlatps(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_claqr3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slansy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlartv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cpptrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgeqr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dggbak(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssbtrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgglse(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clatrz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dpocon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgeqp3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sorgql(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgetrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dggevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_claqhp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsbgvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clascl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clartv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctgexc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sorgqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaqps(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgeqr2p(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgebrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slagtf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlasd8(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_spoequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaic1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgetri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_claed0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztftri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgbequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_stpcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cggevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlanv2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dggbal(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgbbrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_claic1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlartg(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_csytrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaruv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cpftrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlarft(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgebd2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clatbs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cla_gercond_x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgeql2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgeqrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgbequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhptrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clanhs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlasd0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cpbsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ilauplo(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cpftrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chetf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clals0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slarrc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zrot(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlarrv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_stgsja(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_spbrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgeqr2p(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgelsy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlarrk(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgbsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtzrqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_spftrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cheev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgesvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sstebz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlarre(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgerqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgtsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slarfg(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlapy3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgsvj0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dspev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cupmtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgbsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_stgsyl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtrsyl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sspsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssbevd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_claqr1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_csytri2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sla_gerfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssytd2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cspsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cpotf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zherfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clacrm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zungbr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_xerbla_array(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhbgvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_scsum1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dstev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlatbs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slartv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_spttrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctfttr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zla_gbrfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgebd2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsysv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtrrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_csptrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slartg(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zpocon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cporfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztrcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sptts2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlascl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_csyequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sporfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slacon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dorgrq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgehd2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zla_gerfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cstemr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cpotrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaic1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_stbtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_stfsm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slacn2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhetrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztzrzf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgtsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dla_syrfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sbdsdc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlasv2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlaqsb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sorgr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cggglm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clar1v(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtftri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cupgtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slas2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaqge(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chesv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cheevr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaqr4(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dorgbr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cpbcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slacpy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zla_gbamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_claesy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_shgeqz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtrttf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clansy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slarrb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_claset(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlasyf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgeqrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_claqps(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zppcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zstein(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slalsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_spstrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlacon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgetri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slapmt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgbtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dspgst(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsygvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sorgbr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_csycon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaqp2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zpbsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slapmr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cstegr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlarfgp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlantr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zpoequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgerqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zla_herfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zpstrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgetrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgebd2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsygs2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sorml2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_shsein(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zptts2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slasq1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlasd7(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cheevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlar1v(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssteqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlascl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dorg2r(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaed2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtgsen(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgetf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgbrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slarft(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chetrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgesdd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_claqge(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhbgvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zsptrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dpoequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slarzt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztbtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgetrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dorml2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cunmr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgels(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaqr1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dstevd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zunm2r(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssyev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgges(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlaed8(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssytri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cpstf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgbtrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgbtrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssterf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sla_porfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cla_gbrfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaed8(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dpbtrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlatdf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zpttrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaset(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dstemr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slatps(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaed7(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgglse(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsptrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztgevc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_spbcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlanhs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zladiv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dormr3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zla_syrcond_x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtgsja(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cppequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zggsvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgegs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cggsvp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zsyconv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssptrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctpttf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgerfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cppsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dposvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgeqpf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sggbal(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztptrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlahrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dggsvp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zla_syamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaed3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_stgsna(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgebak(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgeqrfp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sstev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slatdf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_csytri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlauu2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlanhs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dla_syrpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_csyrfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_stgsen(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgetc2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zggbal(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlarfb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssysvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgghrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaed9(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgecon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_csysv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zla_herpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_spbtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slarre(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cbdsqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dla_gbamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlarnv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_spotri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ilaclr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlacpy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slasq2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_strexc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztrsna(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_csyswapr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgbrfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_claqgb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlasq5(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgbrfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sptcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsbevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sporfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clarrv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctrsna(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chptrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cungr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgeqrfp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsyevd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cung2l(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaed8(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zunmr3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dorm2l(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhbevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsterf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clanhp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgelqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clantp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtbcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_csytrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlacon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlacn2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlatrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgeqlf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgerfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sspev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dptsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slarrk(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clacon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgeesx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zcposv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlangt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlarra(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlartgs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlaqr1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgtsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlatrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cstein(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cpotri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgtts2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgehd2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlaic1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaqr3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zla_rpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sposv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgeev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zsptrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sspevd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zsytri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlaein(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sla_lin_berr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlaqr5(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlapmr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cla_herpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clargv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dspsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cungbr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zunml2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slasq6(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sspevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgsvj0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zsyswapr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chseqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dormr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zggglm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zpptrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsyconv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sggsvp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_iladlc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhpsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssptrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zggesx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zsysvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ddisna(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zbbcsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgelsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztzrqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chetrs2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgejsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clabrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sggglm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_strti2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_spptrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sla_gbamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgelsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zla_hercond_x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgtcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_srscl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cpbsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clanht(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztfttr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_spbtf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaln2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slasdt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgecon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cla_syrpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cla_porcond_c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slapy2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zla_gercond_x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlarrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cung2r(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dpttrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgeesx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sormr3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztgexc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slarrv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zspr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtbrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlaqp2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlanht(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgesc2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_spbequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clarcm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssygs2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chsein(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtrsen(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaebz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlantp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_strevc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaqge(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slargv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zpbequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slasd2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zpteqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sspgv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgbtrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhpgvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgbequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slasd5(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zsymv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctpcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgelsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zdrscl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clarz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgecon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgerfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_claqsb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sormrz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgbsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sormlq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgegv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sla_syrcond(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgghrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgees(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlaqsy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clasyf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_csytri2x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clalsa(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clascl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgesvj(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_stftri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slahr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clahr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssptrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgebal(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgesvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlasd4(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaqsy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlansy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsbgvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cpbtrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_stzrqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dpteqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssytrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zposv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaqr3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhegv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhpgv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chpevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_csprfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgbrfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlag2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sggev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_claswp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaein(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_stgsy2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zpotrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssyequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgesv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zunmr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zla_porcond_c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dspcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dla_gbrcond(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slatrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlarfg(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slasd0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgtts2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_csrscl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgebak(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sladiv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dla_gbrpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cheevd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssygv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dbdsdc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sla_porcond(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zstedc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dormbr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlatzm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgehrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaqr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zsyequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_strtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sorg2l(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsptri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsbev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgebrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgerfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlarscl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlarscl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgtcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_strcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zsytri2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlassq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dla_gerfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cspmv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgetc2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sopgtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_strttf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztgsyl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cla_porfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chprfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zporfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztrsyl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtgexc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chpsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhegst(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgesvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dpbstf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctrtri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlantb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clag2z(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlangt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_drscl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlasdq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsygv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgtrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dormrq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dppsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgesvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctprfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dhsein(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhegs2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dorgr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_stfttp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaqr0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clahrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_claqp2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slasda(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_spotf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sormtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zposvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssbgv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zptsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlarzt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sppsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sormr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sggesx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaqr5(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sopmtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgegs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlatrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtrevc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dzsum1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_stpttr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssptri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sorm2r(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlarz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sspsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgbbrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgglse(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clarfgp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dopmtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlasd2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaneg(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chetri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cpteqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlabrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zsteqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctgsen(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zla_lin_berr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dpftrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zpbsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slanst(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zsyrfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhfrk(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsyequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlaesy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cla_geamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_csymv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgttrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgegs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgbtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsytrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slantr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sstevd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctgsja(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clange(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgeql2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zppsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slascl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clapmr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctgsna(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgelq2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clauum(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaed0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zsytrs2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chbevd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctrsyl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sstein(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgttrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clatrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhsein(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sstedc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cppcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zungl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dstebz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clanhf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sla_geamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cptsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhbtrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgtrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlalsa(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsposv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sorgl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgtrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clauu2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtgsyl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dorbdb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slarfx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlaqr0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgeqlf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slag2d(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgesv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctrtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slag2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zpoequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_iladiag(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhpgst(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slamrg(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgeqr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgetf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clapmt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chbgvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhgeqz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhptri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slasd8(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slarrj(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtgsy2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_claqr4(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgbtf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlatrz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sbdsqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dormlq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dpftri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssytrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sorglq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgels(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgesv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clatps(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlapmt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slals0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgetc2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slauum(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaed1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zla_porfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sptsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssyswapr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgelqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtfttr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slahrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sppcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsygst(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgeqp3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsyev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgetrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cla_gbrcond_c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zsyr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dpbrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgels(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgebrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sspgst(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zpftri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlabad(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zunmlq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clanhe(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgetrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slarra(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctrrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zunmtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sla_syrfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssysvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slansf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaed4(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chesvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dorgqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cposv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztrevc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgelqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clarzt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgebal(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slasd3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgehrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chegv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dppequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cheequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slansp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgbbrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clar2v(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clapll(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgesdd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chfrk(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cunmr3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slatrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dorm2r(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clarfg(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgesvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clansp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dstegr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssbgvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlasd3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgehrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhseqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slantb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sorgrq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_claqr0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zunmqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zunmrz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_xerbla(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgtts2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaed3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhptrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgebd2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chpgvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctrttp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sla_syrpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slauu2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_claqr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_spteqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slangb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cherfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaexc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlansp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgelq2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlartv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlagts(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cpttrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlags2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgeevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sptsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtprfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtrttp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cposvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sdisna(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsysvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zupmtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgbsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsycon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cunghr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlaev2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chla_transtype(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgghrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cla_syamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cppsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaeda(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dorglq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctrsen(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cungtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chetd2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sisnan(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgerfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgejsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtpcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slarfgp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chptrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_stgevc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dpbtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slanv2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slasd7(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgesvj(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cunmbr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ieeeck(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dormtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlatrz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgbrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cla_herfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sormql(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhetf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlanst(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlahr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sorm2l(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zsycon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhesvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_spftri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgees(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaed2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ilazlc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zpstf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgeqr2p(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsytri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgetf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zunmhr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztrrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zunghr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgeqr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtrexc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctrexc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctpttr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaqgb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slartgs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cpprfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_claqhe(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctzrzf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clatzm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlarrr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhbev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sla_rpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dspgv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sggrqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slar2v(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaed0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsytri2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slags2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlarzb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgebak(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztgsen(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhetrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dla_syamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cla_rpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zpbtrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clacrt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgetf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlatzm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaev2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zungrq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cunmlq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ilaslr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sorgtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztpttf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaqps(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgeequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgelss(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgeequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaqsp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zppsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zungql(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cunm2r(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zpbtf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dpotf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slarz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsytrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sorcsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zheevr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slarrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slasd6(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clarnv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_claed7(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgeesx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgtrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dstevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaed5(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sptrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlaqhb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaqgb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlasdt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zsprfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slascl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ilatrans(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlasq6(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zptsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dpotrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clatdf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dggqrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtfttp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgelss(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sstemr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sormrq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_spbsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlarrb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctrttf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaev2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_spptri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cspr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgbtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cla_hercond_c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cunbdb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_csyr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgerq2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlartg(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhesvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhpgvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slasyf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgehd2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zpptrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zptcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_strsyl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cbbcsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztrttf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssfrk(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsytrs2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zbdsqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlae2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dpbcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctrcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clantb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sorbdb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaed7(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgetri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlartgp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zla_gbrcond_x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_spotrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zla_porcond_x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlarft(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztgsna(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cla_gbrcond_x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slarzb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cla_heamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dla_wwaddw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_spocon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaqtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtptrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dggrqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgbrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chbgv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_iladlr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chpgst(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dpstrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgbrfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sormbr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_csteqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cpptri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlange(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlarzt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlag2s(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clags2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztfttp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zla_heamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dpptrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgeesx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssygst(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgees(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgges(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtrsna(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsygvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cposvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zpttrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlals0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctptri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zungtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zheevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlantp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_claein(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slae2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dla_porcond(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlasda(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgetc2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sbbcsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cpttrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clacn2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dpbequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dorghr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgelsy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgelsy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cunmrq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhecon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_csptrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sla_gercond(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dptrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlacgv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlaqps(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctgevc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cunmhr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztgsy2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sstevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgbtf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlalsa(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_stptri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztpttr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_csyrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgbsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaqr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clacp2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dorg2l(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dpstf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clagtm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zla_hercond_c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clasr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlange(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgeqrfp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ilaclc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sla_gbrpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlarz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chbev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_spprfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_strttp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlapll(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsyrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dspgvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cpptrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_lsamen(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssygvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhetrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtpttr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlasy2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chpgvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgbequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_classq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlasyf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zstemr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zheequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dppsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dorgql(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlatps(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dporfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgeequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cpbtf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgehrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgbcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgtcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgeevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clansb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_csytf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chptrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlassq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgesdd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cpbequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_csytrs2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clahqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_crot(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaqr4(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgelss(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chetrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dopgtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgeqr2p(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cptts2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zla_geamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clatrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cunglq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dggglm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlarfx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhpevd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsyevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clanhb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_csysvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clahef(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slar1v(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cla_gercond_c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dbbcsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlapy2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_stprfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlar1v(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgegv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssbevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgtts2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlasd1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgbcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsprfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlauu2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clarscl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlarrv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlat2c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slahqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgesvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaqp2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhpevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dorgl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_stpttf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgeql2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgerqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_shseqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaqr0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgglse(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slatzm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slarrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dorgtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clarft(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dpbsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ilazlr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlansb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_claqhb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_claev2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaneg(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_stzrzf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zstegr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgbrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlamrg(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgetrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slapll(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgebak(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dla_porfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zungr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgebal(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zggevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgsvj1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zung2r(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zspsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cpbtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtgex2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssyevd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dggesx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sla_porpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slasv2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsytri2x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsfrk(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsteqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaruv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgesvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dppcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cungql(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztprfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dla_lin_berr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlatrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlaqsp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlaqr4(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ilaenv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zsytrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgebrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlasq3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_disnan(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_stptrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgsvj1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zspcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dposvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztbrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlansp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssyevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlanhb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgesdd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhpsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhpev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_claqr5(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgbsvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slartgp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dpptri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zla_gercond_c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgeqlf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhptrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgeqp3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zla_syrfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlarrj(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtrtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cpbstf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zpotrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_spbsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dspsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgeevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cla_wwaddw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dpbsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaqsb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssytrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgelsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlaqr3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgbequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_strtri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgelsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgbsvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zpbcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zpftrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgges(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cptrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlahef(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cunmtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhegvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sggsvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlangb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clangb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgtsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sspgvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgttrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgbcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhpcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dptts2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhesv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlacp2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zposvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dstein(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zherfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dpotrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cungrq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slarrr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slasq3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlaqge(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zupgtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chpcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssbgvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dpptrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaeda(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctgex2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chgeqz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dstedc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgbsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zptrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ilaprec(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zsysv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cggbal(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zggbak(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlauum(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlantb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgbtrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgeequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dladiv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgeql2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_claqsy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaed4(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dormqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgegs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgesv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctgsyl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgesvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlascl(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgbcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_checon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cla_syrfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctptrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chbgvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaqsb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zla_gbrpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dptcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slarnv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dormhr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgelss(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssyrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgeqrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssbev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cunmrz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_izmax1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zla_wwaddw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlagv2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chptri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlahrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgelsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_spbtrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgbbrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtrcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsytf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlapmr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sorg2r(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zunglq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaln2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtrti2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlasq1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgbsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zpotf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlapmt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlag2c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztgex2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgerq2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zung2l(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zunmrq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zuncsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cpftri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgees(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgeev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaed5(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsyevr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgeqpf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtzrzf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dpoequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaed9(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zunbdb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zpbrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsbgst(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlanhp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlaqhp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chesvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sposvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zggqrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clarf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slasdq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlasr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgerq2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slagtm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dla_rpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cungqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_spoequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctfttp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cla_lin_berr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlarfx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlaqr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cspsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgeqpf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cla_hercond_x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgeqrfp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctrevc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clarfb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlansb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zpbstf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clarzb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlansf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_spftrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsysvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clacpy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgelq2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zheevd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dggev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dhseqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cla_syrcond_x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgeequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtfsm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slangt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlarfb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgelsy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slabad(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zunmql(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zla_syrpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sla_gbrfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgbequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_stbrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlasr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zsytf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlagtf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgeqp3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cptcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgeequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dhgeqz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slarfb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaed1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtrtri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhprfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhbevd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slatrz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_spttrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaqsy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zsyrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgttrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgeqlf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cpoequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slansb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssbgst(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sormhr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dspevd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgbtf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgbequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sstegr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sla_syamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dstevr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chpsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlaed7(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_strrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssprfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clarfx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaswp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dpbtf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgels(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zpbtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dporfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slagv2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_claqsp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slasr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgesc2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlarrc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlals0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlacn2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtpttf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztpcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cuncsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sspgvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlasq4(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctbcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zsysvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dbdsqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zheev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlauum(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zggsvp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cptsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chegst(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztbcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgeev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhbgst(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsyrfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgelsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zspsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlacpy(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztrsen(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cunml2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_csyconv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaqsp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaexc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlalsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clalsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaed6(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slalsa(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssyrfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsytrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgetri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlalsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgelsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgeqrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cla_gerfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chegvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cpoequb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaqr5(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sggevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slasrt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztfsm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cunmqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsyswapr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dla_gbrfsx_extended(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cporfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dpprfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaein(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztrttp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgeevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssytf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sggbak(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsytd2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlaqgb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlanhe(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dla_syrcond(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slarscl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgttrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chpgv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slasq4(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhetrs2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgerq2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_iparmq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlantr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_stgexc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sppequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_spbstf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dormrz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slange(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlasrt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgebal(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cggesx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chbgst(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clartg(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlaed0(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cla_porcond_x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlar2v(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgegv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctzrqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhetd2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clantr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cpotrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlatdf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtgsna(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cunm2l(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlarnv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlarfgp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zspmv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlas2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssycon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztptri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaebz(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cggrqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_clangt(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zungqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgttrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlar2v(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssytri2x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zla_syrcond_c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhbgv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cstedc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sstevr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlaswp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsbgv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgbsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slassq(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgttrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctfsm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chegvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsbevd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zunmbr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgeequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgbequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgbtf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlagtm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssyevr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssytrs2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlags2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cpstrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctbtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctftri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zla_gbrcond_c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zporfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgetrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgerfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chbtrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slasq5(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlarzb(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlahqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_stbcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlabrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgeqpf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cspcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgtsvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cla_syrcond_c(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgerfsx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssygvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_claed8(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsptrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sla_gbrcond(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ilaslc(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsgesv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zla_porpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zsytri2x(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chbevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgeev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sorghr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slasy2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sspcon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctbrfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dggsvd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slantp(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sormqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgerqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlat2s(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlacrm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_icmax1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaset(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlarcm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chpev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dposv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cla_gbamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slapy3(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dla_porpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sggqrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zgbsvxx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chpevd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlaqtr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_spotrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgelqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlarrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ssytri2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_stgex2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_csptri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dla_geamv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhetri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_slaqr1(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dpftrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zunm2l(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctrti2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dtbtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zpptri(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_spstf2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_stfttr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zpftrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cla_gbrpvgrw(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cgtsv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlagtm(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dsbtrd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlanhf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlasd5(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_chetrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zggrqf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgeqr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlahqr(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zppequ(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dorcsd(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zpprfs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ctgsy2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_cladiv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zggev(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztrtrs(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlarf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlargv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlarfg(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zsytrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sposvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlahr2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zlascl2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_zhegvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgesvx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dspevx(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_ztgsja(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgetrf(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dgegv(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_sgecon(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);
extern void init_lapack_dlasq2(VALUE mLapack, VALUE sHelp, VALUE sUsage, VALUE rblapack_ZERO);

void Init_lapack(){
  VALUE mNumRu;
  VALUE mLapack;

  rb_require("narray");

  mNumRu = rb_define_module("NumRu");
  mLapack = rb_define_module_under(mNumRu, "Lapack");

  sHelp = ID2SYM(rb_intern("help"));
  sUsage = ID2SYM(rb_intern("usage"));

  rblapack_ZERO = INT2NUM(0);

  init_lapack_slabrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlargv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssyconv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zpotri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cla_porpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cungl2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgtsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dpotri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlacrt(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cpocon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cggbak(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgesvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgtcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgbtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtptri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cggsvd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlansy(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaed6(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlaset(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsptrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgesc2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slatbs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dormql(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chegs2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztrti2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_strsna(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlatbs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztrexc(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgehd2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slanhs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slagts(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgtsv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgerfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ilaver(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cggqrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cunmql(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dspgvd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtgevc(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cggev(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clacgv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlangb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgesvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_csysvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sppsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zsptri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlapll(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgesc2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaswp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgbsvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_strsen(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgges(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dptsv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sla_wwaddw(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cherfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgghrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgttrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgelq2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgesvd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slasd4(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_spptrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zcgesv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dpttrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlasd6(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgeequ(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssysv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cpbrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlaqhe(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlarf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slarf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dla_gercond(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slasd1(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztrtri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlatps(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_claqr3(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slansy(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlartv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cpptrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgeqr2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dggbak(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssbtrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgglse(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clatrz(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dpocon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgeqp3(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sorgql(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgetrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dggevx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_claqhp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsbgvd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clascl2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clartv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctgexc(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sorgqr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaqps(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgeqr2p(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgebrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slagtf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlasd8(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_spoequ(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaic1(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgetri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_claed0(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztftri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgbequb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_stpcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cggevx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlanv2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dggbal(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgbbrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_claic1(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlartg(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_csytrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaruv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cpftrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlarft(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgebd2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clatbs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cla_gercond_x(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgeql2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgeqrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgbequb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhptrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clanhs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlasd0(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cpbsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ilauplo(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cpftrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chetf2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clals0(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slarrc(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zrot(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlarrv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_stgsja(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_spbrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgeqr2p(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgelsy(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlarrk(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgbsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtzrqf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_spftrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cheev(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgesvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sstebz(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlarre(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgerqf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgtsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slarfg(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlapy3(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgsvj0(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dspev(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cupmtr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgbsv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_stgsyl(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtrsyl(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sspsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssbevd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_claqr1(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_csytri2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sla_gerfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssytd2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cspsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cpotf2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zherfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clacrm(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zungbr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_xerbla_array(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhbgvd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_scsum1(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dstev(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlatbs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slartv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_spttrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctfttr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zla_gbrfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgebd2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsysv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtrrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_csptrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slartg(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zpocon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cporfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztrcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sptts2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlascl2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_csyequb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sporfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slacon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dorgrq(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgehd2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zla_gerfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cstemr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cpotrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaic1(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_stbtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_stfsm(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slacn2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhetrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztzrzf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgtsv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dla_syrfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sbdsdc(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlasv2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlaqsb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sorgr2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cggglm(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clar1v(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtftri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cupgtr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slas2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaqge(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chesv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cheevr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaqr4(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dorgbr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cpbcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slacpy(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zla_gbamv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_claesy(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_shgeqz(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtrttf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clansy(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slarrb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_claset(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlasyf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgeqrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_claqps(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zppcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zstein(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slalsd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_spstrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlacon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgetri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slapmt(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgbtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dspgst(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsygvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sorgbr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_csycon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaqp2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zpbsv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slapmr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cstegr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlarfgp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlantr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zpoequ(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgerqf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zla_herfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zpstrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgetrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgebd2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsygs2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sorml2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_shsein(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zptts2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slasq1(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlasd7(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cheevx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlar1v(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssteqr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlascl(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dorg2r(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaed2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtgsen(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgetf2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgbrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slarft(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chetrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgesdd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_claqge(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhbgvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zsptrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dpoequ(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slarzt(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztbtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgetrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dorml2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cunmr2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgels(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaqr1(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dstevd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zunm2r(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssyev(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgges(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlaed8(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssytri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cpstf2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgbtrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgbtrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssterf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sla_porfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cla_gbrfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaed8(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dpbtrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlatdf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zpttrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaset(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dstemr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slatps(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaed7(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgglse(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsptrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztgevc(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_spbcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlanhs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zladiv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dormr3(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zla_syrcond_x(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtgsja(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cppequ(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zggsvd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgegs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cggsvp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zsyconv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssptrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctpttf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgerfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cppsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dposvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgeqpf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sggbal(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztptrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlahrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dggsvp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zla_syamv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaed3(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_stgsna(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgebak(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgeqrfp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sstev(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slatdf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_csytri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlauu2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlanhs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dla_syrpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_csyrfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_stgsen(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgetc2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zggbal(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlarfb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssysvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgghrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaed9(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgecon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_csysv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zla_herpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_spbtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slarre(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cbdsqr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dla_gbamv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlarnv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_spotri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ilaclr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlacpy(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slasq2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_strexc(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztrsna(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_csyswapr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgbrfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_claqgb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlasq5(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgbrfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sptcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsbevx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sporfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clarrv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctrsna(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chptrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cungr2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgeqrfp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsyevd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cung2l(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaed8(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zunmr3(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dorm2l(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhbevx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsterf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clanhp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgelqf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clantp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtbcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_csytrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlacon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlacn2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlatrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgeqlf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgerfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sspev(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dptsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slarrk(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clacon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgeesx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zcposv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlangt(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlarra(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlartgs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlaqr1(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgtsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlatrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cstein(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cpotri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgtts2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgehd2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlaic1(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaqr3(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zla_rpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sposv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgeev(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zsptrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sspevd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zsytri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlaein(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sla_lin_berr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlaqr5(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlapmr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cla_herpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clargv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dspsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cungbr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zunml2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slasq6(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sspevx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgsvj0(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zsyswapr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chseqr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dormr2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zggglm(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zpptrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsyconv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sggsvp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_iladlc(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhpsv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssptrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zggesx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zsysvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ddisna(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zbbcsd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgelsd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztzrqf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chetrs2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgejsv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clabrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sggglm(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_strti2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_spptrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sla_gbamv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgelsd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zla_hercond_x(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgtcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_srscl(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cpbsv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clanht(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztfttr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_spbtf2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaln2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slasdt(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgecon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cla_syrpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cla_porcond_c(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slapy2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zla_gercond_x(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlarrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cung2r(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dpttrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgeesx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sormr3(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztgexc(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slarrv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zspr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtbrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlaqp2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlanht(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgesc2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_spbequ(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clarcm(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssygs2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chsein(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtrsen(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaebz(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlantp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_strevc(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaqge(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slargv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zpbequ(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slasd2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zpteqr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sspgv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgbtrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhpgvd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgbequb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slasd5(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zsymv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctpcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgelsd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zdrscl(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clarz(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgecon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgerfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_claqsb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sormrz(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgbsv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sormlq(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgegv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sla_syrcond(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgghrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgees(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlaqsy(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clasyf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_csytri2x(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clalsa(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clascl(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgesvj(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_stftri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slahr2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clahr2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssptrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgebal(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgesvd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlasd4(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaqsy(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlansy(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsbgvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cpbtrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_stzrqf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dpteqr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssytrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zposv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaqr3(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhegv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhpgv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chpevx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_csprfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgbrfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlag2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sggev(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_claswp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaein(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_stgsy2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zpotrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssyequb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgesv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zunmr2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zla_porcond_c(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dspcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dla_gbrcond(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slatrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlarfg(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slasd0(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgtts2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_csrscl(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgebak(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sladiv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dla_gbrpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cheevd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssygv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dbdsdc(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sla_porcond(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zstedc(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dormbr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlatzm(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgehrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaqr2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zsyequb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_strtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sorg2l(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsptri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsbev(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgebrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgerfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlarscl2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlarscl2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgtcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_strcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zsytri2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlassq(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dla_gerfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cspmv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgetc2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sopgtr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_strttf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztgsyl(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cla_porfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chprfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zporfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztrsyl(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtgexc(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chpsv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhegst(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgesvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dpbstf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctrtri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlantb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clag2z(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlangt(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_drscl(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlasdq(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsygv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgtrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dormrq(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dppsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgesvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctprfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dhsein(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhegs2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dorgr2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_stfttp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaqr0(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clahrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_claqp2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slasda(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_spotf2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sormtr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zposvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssbgv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zptsv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlarzt(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sppsv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sormr2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sggesx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaqr5(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sopmtr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgegs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlatrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtrevc(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dzsum1(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_stpttr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssptri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sorm2r(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlarz(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sspsv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgbbrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgglse(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clarfgp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dopmtr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlasd2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaneg(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chetri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cpteqr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlabrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zsteqr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctgsen(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zla_lin_berr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dpftrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zpbsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slanst(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zsyrfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhfrk(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsyequb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlaesy(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cla_geamv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_csymv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgttrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgegs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgbtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsytrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slantr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sstevd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctgsja(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clange(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgeql2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zppsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slascl2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clapmr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctgsna(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgelq2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clauum(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaed0(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zsytrs2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chbevd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctrsyl(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sstein(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgttrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clatrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhsein(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sstedc(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cppcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zungl2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dstebz(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clanhf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sla_geamv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cptsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhbtrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgtrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlalsa(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsposv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sorgl2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgtrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clauu2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtgsyl(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dorbdb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slarfx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlaqr0(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgeqlf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slag2d(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgesv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctrtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slag2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zpoequb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_iladiag(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhpgst(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slamrg(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgeqr2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgetf2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clapmt(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chbgvd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhgeqz(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhptri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slasd8(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slarrj(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtgsy2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_claqr4(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgbtf2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlatrz(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sbdsqr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dormlq(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dpftri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssytrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sorglq(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgels(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgesv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clatps(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlapmt(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slals0(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgetc2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slauum(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaed1(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zla_porfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sptsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssyswapr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgelqf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtfttr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slahrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sppcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsygst(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgeqp3(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsyev(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgetrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cla_gbrcond_c(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zsyr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dpbrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgels(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgebrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sspgst(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zpftri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlabad(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zunmlq(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clanhe(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgetrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slarra(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctrrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zunmtr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sla_syrfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssysvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slansf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaed4(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chesvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dorgqr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cposv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztrevc(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgelqf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clarzt(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgebal(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slasd3(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgehrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chegv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dppequ(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cheequb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slansp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgbbrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clar2v(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clapll(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgesdd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chfrk(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cunmr3(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slatrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dorm2r(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clarfg(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgesvd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clansp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dstegr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssbgvd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlasd3(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgehrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhseqr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slantb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sorgrq(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_claqr0(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zunmqr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zunmrz(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_xerbla(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgtts2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaed3(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhptrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgebd2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chpgvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctrttp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sla_syrpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slauu2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_claqr2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_spteqr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slangb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cherfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaexc(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlansp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgelq2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlartv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlagts(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cpttrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlags2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgeevx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sptsv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtprfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtrttp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cposvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sdisna(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsysvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zupmtr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgbsv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsycon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cunghr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlaev2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chla_transtype(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgghrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cla_syamv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cppsv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaeda(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dorglq(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctrsen(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cungtr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chetd2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sisnan(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgerfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgejsv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtpcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slarfgp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chptrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_stgevc(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dpbtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slanv2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slasd7(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgesvj(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cunmbr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ieeeck(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dormtr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlatrz(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgbrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cla_herfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sormql(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhetf2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlanst(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlahr2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sorm2l(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zsycon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhesvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_spftri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgees(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaed2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ilazlc(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zpstf2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgeqr2p(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsytri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgetf2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zunmhr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztrrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zunghr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgeqr2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtrexc(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctrexc(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctpttr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaqgb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slartgs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cpprfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_claqhe(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctzrzf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clatzm(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlarrr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhbev(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sla_rpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dspgv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sggrqf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slar2v(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaed0(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsytri2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slags2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlarzb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgebak(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztgsen(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhetrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dla_syamv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cla_rpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zpbtrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clacrt(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgetf2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlatzm(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaev2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zungrq(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cunmlq(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ilaslr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sorgtr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztpttf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaqps(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgeequb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgelss(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgeequb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaqsp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zppsv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zungql(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cunm2r(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zpbtf2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dpotf2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slarz(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsytrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sorcsd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zheevr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slarrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slasd6(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clarnv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_claed7(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgeesx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgtrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dstevx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaed5(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sptrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlaqhb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaqgb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlasdt(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zsprfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slascl(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ilatrans(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlasq6(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zptsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dpotrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clatdf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dggqrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtfttp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgelss(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sstemr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sormrq(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_spbsv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlarrb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctrttf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaev2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_spptri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cspr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgbtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cla_hercond_c(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cunbdb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_csyr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgerq2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlartg(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhesvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhpgvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slasyf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgehd2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zpptrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zptcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_strsyl(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cbbcsd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztrttf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssfrk(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsytrs2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zbdsqr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlae2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dpbcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctrcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clantb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sorbdb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaed7(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgetri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlartgp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zla_gbrcond_x(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_spotrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zla_porcond_x(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlarft(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztgsna(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cla_gbrcond_x(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slarzb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cla_heamv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dla_wwaddw(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_spocon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaqtr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtptrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dggrqf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgbrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chbgv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_iladlr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chpgst(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dpstrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgbrfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sormbr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_csteqr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cpptri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlange(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlarzt(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlag2s(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clags2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztfttp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zla_heamv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dpptrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgeesx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssygst(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgees(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgges(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtrsna(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsygvd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cposvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zpttrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlals0(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctptri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zungtr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zheevx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlantp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_claein(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slae2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dla_porcond(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlasda(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgetc2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sbbcsd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cpttrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clacn2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dpbequ(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dorghr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgelsy(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgelsy(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cunmrq(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhecon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_csptrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sla_gercond(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dptrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlacgv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlaqps(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctgevc(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cunmhr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztgsy2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sstevx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgbtf2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlalsa(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_stptri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztpttr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_csyrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgbsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaqr2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clacp2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dorg2l(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dpstf2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clagtm(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zla_hercond_c(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clasr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlange(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgeqrfp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ilaclc(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sla_gbrpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlarz(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chbev(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_spprfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_strttp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlapll(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsyrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dspgvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cpptrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_lsamen(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssygvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhetrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtpttr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlasy2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chpgvd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgbequb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_classq(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlasyf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zstemr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zheequb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dppsv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dorgql(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlatps(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dporfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgeequ(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cpbtf2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgehrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgbcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgtcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgeevx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clansb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_csytf2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chptrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlassq(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgesdd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cpbequ(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_csytrs2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clahqr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_crot(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaqr4(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgelss(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chetrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dopgtr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgeqr2p(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cptts2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zla_geamv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clatrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cunglq(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dggglm(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlarfx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhpevd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsyevx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clanhb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_csysvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clahef(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slar1v(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cla_gercond_c(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dbbcsd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlapy2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_stprfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlar1v(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgegv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssbevx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgtts2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlasd1(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgbcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsprfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlauu2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clarscl2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlarrv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlat2c(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slahqr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgesvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaqp2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhpevx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dorgl2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_stpttf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgeql2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgerqf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_shseqr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaqr0(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgglse(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slatzm(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slarrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dorgtr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clarft(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dpbsv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ilazlr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlansb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_claqhb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_claev2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaneg(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_stzrzf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zstegr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgbrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlamrg(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgetrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slapll(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgebak(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dla_porfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zungr2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgebal(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zggevx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgsvj1(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zung2r(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zspsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cpbtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtgex2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssyevd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dggesx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sla_porpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slasv2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsytri2x(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsfrk(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsteqr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaruv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgesvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dppcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cungql(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztprfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dla_lin_berr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlatrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlaqsp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlaqr4(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ilaenv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zsytrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgebrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlasq3(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_disnan(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_stptrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgsvj1(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zspcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dposvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztbrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlansp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssyevx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlanhb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgesdd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhpsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhpev(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_claqr5(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgbsvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slartgp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dpptri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zla_gercond_c(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgeqlf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhptrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgeqp3(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zla_syrfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlarrj(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtrtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cpbstf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zpotrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_spbsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dspsv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgeevx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cla_wwaddw(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dpbsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaqsb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssytrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgelsx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlaqr3(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgbequ(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_strtri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgelsd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgbsvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zpbcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zpftrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgges(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cptrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlahef(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cunmtr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhegvd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sggsvd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlangb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clangb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgtsv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sspgvd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgttrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgbcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhpcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dptts2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhesv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlacp2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zposvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dstein(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zherfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dpotrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cungrq(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slarrr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slasq3(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlaqge(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zupgtr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chpcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssbgvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dpptrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaeda(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctgex2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chgeqz(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dstedc(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgbsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zptrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ilaprec(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zsysv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cggbal(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zggbak(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlauum(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlantb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgbtrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgeequ(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dladiv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgeql2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_claqsy(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaed4(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dormqr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgegs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgesv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctgsyl(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgesvd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlascl(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgbcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_checon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cla_syrfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctptrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chbgvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaqsb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zla_gbrpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dptcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slarnv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dormhr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgelss(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssyrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgeqrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssbev(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cunmrz(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_izmax1(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zla_wwaddw(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlagv2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chptri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlahrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgelsx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_spbtrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgbbrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtrcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsytf2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlapmr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sorg2r(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zunglq(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaln2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtrti2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlasq1(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgbsv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zpotf2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlapmt(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlag2c(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztgex2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgerq2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zung2l(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zunmrq(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zuncsd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cpftri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgees(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgeev(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaed5(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsyevr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgeqpf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtzrzf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dpoequb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaed9(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zunbdb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zpbrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsbgst(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlanhp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlaqhp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chesvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sposvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zggqrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clarf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slasdq(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlasr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgerq2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slagtm(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dla_rpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cungqr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_spoequb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctfttp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cla_lin_berr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlarfx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlaqr2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cspsv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgeqpf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cla_hercond_x(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgeqrfp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctrevc(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clarfb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlansb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zpbstf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clarzb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlansf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_spftrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsysvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clacpy(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgelq2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zheevd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dggev(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dhseqr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cla_syrcond_x(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgeequb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtfsm(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slangt(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlarfb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgelsy(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slabad(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zunmql(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zla_syrpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sla_gbrfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgbequ(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_stbrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlasr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zsytf2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlagtf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgeqp3(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cptcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgeequb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dhgeqz(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slarfb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaed1(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtrtri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhprfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhbevd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slatrz(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_spttrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaqsy(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zsyrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgttrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgeqlf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cpoequ(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slansb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssbgst(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sormhr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dspevd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgbtf2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgbequ(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sstegr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sla_syamv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dstevr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chpsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlaed7(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_strrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssprfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clarfx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaswp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dpbtf2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgels(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zpbtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dporfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slagv2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_claqsp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slasr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgesc2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlarrc(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlals0(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlacn2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtpttf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztpcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cuncsd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sspgvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlasq4(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctbcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zsysvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dbdsqr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zheev(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlauum(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zggsvp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cptsv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chegst(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztbcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgeev(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhbgst(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsyrfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgelsx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zspsv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlacpy(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztrsen(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cunml2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_csyconv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaqsp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaexc(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlalsd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clalsd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaed6(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slalsa(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssyrfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsytrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgetri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlalsd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgelsx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgeqrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cla_gerfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chegvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cpoequb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaqr5(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sggevx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slasrt(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztfsm(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cunmqr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsyswapr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dla_gbrfsx_extended(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cporfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dpprfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaein(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztrttp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgeevx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssytf2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sggbak(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsytd2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlaqgb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlanhe(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dla_syrcond(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slarscl2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgttrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chpgv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slasq4(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhetrs2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgerq2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_iparmq(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlantr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_stgexc(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sppequ(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_spbstf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dormrz(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slange(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlasrt(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgebal(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cggesx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chbgst(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clartg(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlaed0(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cla_porcond_x(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlar2v(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgegv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctzrqf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhetd2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clantr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cpotrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlatdf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtgsna(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cunm2l(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlarnv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlarfgp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zspmv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlas2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssycon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztptri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaebz(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cggrqf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_clangt(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zungqr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgttrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlar2v(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssytri2x(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zla_syrcond_c(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhbgv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cstedc(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sstevr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlaswp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsbgv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgbsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slassq(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgttrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctfsm(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chegvd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsbevd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zunmbr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgeequ(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgbequ(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgbtf2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlagtm(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssyevr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssytrs2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlags2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cpstrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctbtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctftri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zla_gbrcond_c(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zporfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgetrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgerfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chbtrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slasq5(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlarzb(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlahqr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_stbcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlabrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgeqpf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cspcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgtsvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cla_syrcond_c(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgerfsx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssygvd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_claed8(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsptrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sla_gbrcond(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ilaslc(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsgesv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zla_porpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zsytri2x(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chbevx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgeev(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sorghr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slasy2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sspcon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctbrfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dggsvd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slantp(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sormqr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgerqf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlat2s(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlacrm(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_icmax1(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaset(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlarcm(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chpev(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dposv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cla_gbamv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slapy3(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dla_porpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sggqrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zgbsvxx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chpevd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlaqtr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_spotrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgelqf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlarrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ssytri2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_stgex2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_csptri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dla_geamv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhetri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_slaqr1(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dpftrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zunm2l(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctrti2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dtbtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zpptri(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_spstf2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_stfttr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zpftrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cla_gbrpvgrw(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cgtsv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlagtm(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dsbtrd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlanhf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlasd5(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_chetrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zggrqf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgeqr2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlahqr(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zppequ(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dorcsd(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zpprfs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ctgsy2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_cladiv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zggev(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztrtrs(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlarf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlargv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlarfg(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zsytrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sposvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlahr2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zlascl2(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_zhegvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgesvx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dspevx(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_ztgsja(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgetrf(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dgegv(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_sgecon(mLapack, sHelp, sUsage, rblapack_ZERO);
  init_lapack_dlasq2(mLapack, sHelp, sUsage, rblapack_ZERO);
}
ruby-lapack-1.7.2/ext/zpoequb.c0000644000175000017500000001013412502221020016201 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zpoequb_(integer* n, doublecomplex* a, integer* lda, doublereal* s, doublereal* scond, doublereal* amax, integer* info);


static VALUE
rblapack_zpoequb(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_scond;
  doublereal scond; 
  VALUE rblapack_amax;
  doublereal amax; 
  VALUE rblapack_info;
  integer info; 

  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  s, scond, amax, info = NumRu::Lapack.zpoequb( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZPOEQUB computes row and column scalings intended to equilibrate a\n*  symmetric positive definite matrix A and reduce its condition number\n*  (with respect to the two-norm).  S contains the scale factors,\n*  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with\n*  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This\n*  choice of S puts the condition number of B within a factor N of the\n*  smallest possible condition number over all possible diagonal\n*  scalings.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input) COMPLEX*16 array, dimension (LDA,N)\n*          The N-by-N symmetric positive definite matrix whose scaling\n*          factors are to be computed.  Only the diagonal elements of A\n*          are referenced.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  S       (output) DOUBLE PRECISION array, dimension (N)\n*          If INFO = 0, S contains the scale factors for A.\n*\n*  SCOND   (output) DOUBLE PRECISION\n*          If INFO = 0, S contains the ratio of the smallest S(i) to\n*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too\n*          large nor too small, it is not worth scaling by S.\n*\n*  AMAX    (output) DOUBLE PRECISION\n*          Absolute value of largest matrix element.  If AMAX is very\n*          close to overflow or very close to underflow, the matrix\n*          should be scaled.\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 is nonpositive.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  s, scond, amax, info = NumRu::Lapack.zpoequb( 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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s = NA_PTR_TYPE(rblapack_s, doublereal*);

  zpoequb_(&n, a, &lda, s, &scond, &amax, &info);

  rblapack_scond = rb_float_new((double)scond);
  rblapack_amax = rb_float_new((double)amax);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_s, rblapack_scond, rblapack_amax, rblapack_info);
}

void
init_lapack_zpoequb(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zpoequb", rblapack_zpoequb, -1);
}
ruby-lapack-1.7.2/ext/dlapy2.c0000644000175000017500000000345512502221022015721 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern doublereal dlapy2_(doublereal* x, doublereal* y);


static VALUE
rblapack_dlapy2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_x;
  doublereal x; 
  VALUE rblapack_y;
  doublereal y; 
  VALUE rblapack___out__;
  doublereal __out__; 


  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  __out__ = NumRu::Lapack.dlapy2( x, y, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      DOUBLE PRECISION FUNCTION DLAPY2( X, Y )\n\n*  Purpose\n*  =======\n*\n*  DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary\n*  overflow.\n*\n\n*  Arguments\n*  =========\n*\n*  X       (input) DOUBLE PRECISION\n*  Y       (input) DOUBLE PRECISION\n*          X and Y specify the values x and y.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  __out__ = NumRu::Lapack.dlapy2( x, y, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_x = argv[0];
  rblapack_y = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  x = NUM2DBL(rblapack_x);
  y = NUM2DBL(rblapack_y);

  __out__ = dlapy2_(&x, &y);

  rblapack___out__ = rb_float_new((double)__out__);
  return rblapack___out__;
}

void
init_lapack_dlapy2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dlapy2", rblapack_dlapy2, -1);
}
ruby-lapack-1.7.2/ext/dsyrfsx.c0000644000175000017500000005215712502221025016236 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dsyrfsx_(char* uplo, char* equed, integer* n, integer* nrhs, doublereal* a, integer* lda, doublereal* af, integer* ldaf, integer* ipiv, doublereal* s, doublereal* b, integer* ldb, doublereal* x, integer* ldx, doublereal* rcond, doublereal* berr, integer* n_err_bnds, doublereal* err_bnds_norm, doublereal* err_bnds_comp, integer* nparams, doublereal* params, doublereal* work, integer* iwork, integer* info);


static VALUE
rblapack_dsyrfsx(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_equed;
  char equed; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_af;
  doublereal *af; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_s;
  doublereal *s; 
  VALUE rblapack_b;
  doublereal *b; 
  VALUE rblapack_x;
  doublereal *x; 
  VALUE rblapack_params;
  doublereal *params; 
  VALUE rblapack_rcond;
  doublereal rcond; 
  VALUE rblapack_berr;
  doublereal *berr; 
  VALUE rblapack_err_bnds_norm;
  doublereal *err_bnds_norm; 
  VALUE rblapack_err_bnds_comp;
  doublereal *err_bnds_comp; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_s_out__;
  doublereal *s_out__;
  VALUE rblapack_x_out__;
  doublereal *x_out__;
  VALUE rblapack_params_out__;
  doublereal *params_out__;
  doublereal *work;
  integer *iwork;

  integer lda;
  integer n;
  integer ldaf;
  integer ldb;
  integer nrhs;
  integer ldx;
  integer nparams;
  integer n_err_bnds;

  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  rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.dsyrfsx( uplo, equed, a, af, ipiv, s, b, x, params, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO )\n\n*     Purpose\n*     =======\n*\n*     DSYRFSX improves the computed solution to a system of linear\n*     equations when the coefficient matrix is symmetric indefinite, and\n*     provides error bounds and backward error estimates for the\n*     solution.  In addition to normwise error bound, the code provides\n*     maximum componentwise error bound if possible.  See comments for\n*     ERR_BNDS_NORM and ERR_BNDS_COMP for details of the error bounds.\n*\n*     The original system of linear equations may have been equilibrated\n*     before calling this routine, as described by arguments EQUED and S\n*     below. In this case, the solution and error bounds returned are\n*     for the original unequilibrated system.\n*\n\n*     Arguments\n*     =========\n*\n*     Some optional parameters are bundled in the PARAMS array.  These\n*     settings determine how refinement is performed, but often the\n*     defaults are acceptable.  If the defaults are acceptable, users\n*     can pass NPARAMS = 0 which prevents the source code from accessing\n*     the PARAMS argument.\n*\n*     UPLO    (input) CHARACTER*1\n*       = 'U':  Upper triangle of A is stored;\n*       = 'L':  Lower triangle of A is stored.\n*\n*     EQUED   (input) CHARACTER*1\n*     Specifies the form of equilibration that was done to A\n*     before calling this routine. This is needed to compute\n*     the solution and error bounds correctly.\n*       = 'N':  No equilibration\n*       = 'Y':  Both row and column equilibration, i.e., A has been\n*               replaced by diag(S) * A * diag(S).\n*               The right hand side B has been changed accordingly.\n*\n*     N       (input) INTEGER\n*     The order of the matrix A.  N >= 0.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices B and X.  NRHS >= 0.\n*\n*     A       (input) DOUBLE PRECISION array, dimension (LDA,N)\n*     The symmetric matrix A.  If UPLO = 'U', the leading N-by-N\n*     upper triangular part of A contains the upper triangular\n*     part of the matrix A, and the strictly lower triangular\n*     part of A is not referenced.  If UPLO = 'L', the leading\n*     N-by-N lower triangular part of A contains the lower\n*     triangular part of the matrix A, and the strictly upper\n*     triangular part of A is not referenced.\n*\n*     LDA     (input) INTEGER\n*     The leading dimension of the array A.  LDA >= max(1,N).\n*\n*     AF      (input) DOUBLE PRECISION array, dimension (LDAF,N)\n*     The factored form of the matrix A.  AF contains the block\n*     diagonal matrix D and the multipliers used to obtain the\n*     factor U or L from the factorization A = U*D*U**T or A =\n*     L*D*L**T as computed by DSYTRF.\n*\n*     LDAF    (input) INTEGER\n*     The leading dimension of the array AF.  LDAF >= max(1,N).\n*\n*     IPIV    (input) INTEGER array, dimension (N)\n*     Details of the interchanges and the block structure of D\n*     as determined by DSYTRF.\n*\n*     S       (input or output) DOUBLE PRECISION array, dimension (N)\n*     The scale factors for A.  If EQUED = 'Y', A is multiplied on\n*     the left and right by diag(S).  S is an input argument if FACT =\n*     'F'; otherwise, S is an output argument.  If FACT = 'F' and EQUED\n*     = 'Y', each element of S must be positive.  If S is output, each\n*     element of S is a power of the radix. If S is input, each element\n*     of S should be a power of the radix to ensure a reliable solution\n*     and error estimates. Scaling by powers of the radix does not cause\n*     rounding errors unless the result underflows or overflows.\n*     Rounding errors during scaling lead to refining with a matrix that\n*     is not equivalent to the input matrix, producing error estimates\n*     that may not be reliable.\n*\n*     B       (input) DOUBLE PRECISION array, dimension (LDB,NRHS)\n*     The right hand side matrix B.\n*\n*     LDB     (input) INTEGER\n*     The leading dimension of the array B.  LDB >= max(1,N).\n*\n*     X       (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)\n*     On entry, the solution matrix X, as computed by DGETRS.\n*     On exit, the improved solution matrix X.\n*\n*     LDX     (input) INTEGER\n*     The leading dimension of the array X.  LDX >= max(1,N).\n*\n*     RCOND   (output) DOUBLE PRECISION\n*     Reciprocal scaled condition number.  This is an estimate of the\n*     reciprocal Skeel condition number of the matrix A after\n*     equilibration (if done).  If this is less than the machine\n*     precision (in particular, if it is zero), the matrix is singular\n*     to working precision.  Note that the error may still be small even\n*     if this number is very small and the matrix appears ill-\n*     conditioned.\n*\n*     BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*     Componentwise relative backward error.  This is the\n*     componentwise relative backward error of each solution vector X(j)\n*     (i.e., the smallest relative change in any element of A or B that\n*     makes X(j) an exact solution).\n*\n*     N_ERR_BNDS (input) INTEGER\n*     Number of error bounds to return for each right hand side\n*     and each type (normwise or componentwise).  See ERR_BNDS_NORM and\n*     ERR_BNDS_COMP below.\n*\n*     ERR_BNDS_NORM  (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     normwise relative error, which is defined as follows:\n*\n*     Normwise relative error in the ith solution vector:\n*             max_j (abs(XTRUE(j,i) - X(j,i)))\n*            ------------------------------\n*                  max_j abs(X(j,i))\n*\n*     The array is indexed by the type of error information as described\n*     below. There currently are up to three pieces of information\n*     returned.\n*\n*     The first index in ERR_BNDS_NORM(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_NORM(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * dlamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * dlamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated normwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * dlamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*A, where S scales each row by a power of the\n*              radix so all absolute row sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     ERR_BNDS_COMP  (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS)\n*     For each right-hand side, this array contains information about\n*     various error bounds and condition numbers corresponding to the\n*     componentwise relative error, which is defined as follows:\n*\n*     Componentwise relative error in the ith solution vector:\n*                    abs(XTRUE(j,i) - X(j,i))\n*             max_j ----------------------\n*                         abs(X(j,i))\n*\n*     The array is indexed by the right-hand side i (on which the\n*     componentwise relative error depends), and the type of error\n*     information as described below. There currently are up to three\n*     pieces of information returned for each right-hand side. If\n*     componentwise accuracy is not requested (PARAMS(3) = 0.0), then\n*     ERR_BNDS_COMP is not accessed.  If N_ERR_BNDS .LT. 3, then at most\n*     the first (:,N_ERR_BNDS) entries are returned.\n*\n*     The first index in ERR_BNDS_COMP(i,:) corresponds to the ith\n*     right-hand side.\n*\n*     The second index in ERR_BNDS_COMP(:,err) contains the following\n*     three fields:\n*     err = 1 \"Trust/don't trust\" boolean. Trust the answer if the\n*              reciprocal condition number is less than the threshold\n*              sqrt(n) * dlamch('Epsilon').\n*\n*     err = 2 \"Guaranteed\" error bound: The estimated forward error,\n*              almost certainly within a factor of 10 of the true error\n*              so long as the next entry is greater than the threshold\n*              sqrt(n) * dlamch('Epsilon'). This error bound should only\n*              be trusted if the previous boolean is true.\n*\n*     err = 3  Reciprocal condition number: Estimated componentwise\n*              reciprocal condition number.  Compared with the threshold\n*              sqrt(n) * dlamch('Epsilon') to determine if the error\n*              estimate is \"guaranteed\". These reciprocal condition\n*              numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some\n*              appropriately scaled matrix Z.\n*              Let Z = S*(A*diag(x)), where x is the solution for the\n*              current right-hand side and S scales each row of\n*              A*diag(x) by a power of the radix so all absolute row\n*              sums of Z are approximately 1.\n*\n*     See Lapack Working Note 165 for further details and extra\n*     cautions.\n*\n*     NPARAMS (input) INTEGER\n*     Specifies the number of parameters set in PARAMS.  If .LE. 0, the\n*     PARAMS array is never referenced and default values are used.\n*\n*     PARAMS  (input / output) DOUBLE PRECISION array, dimension (NPARAMS)\n*     Specifies algorithm parameters.  If an entry is .LT. 0.0, then\n*     that entry will be filled with default value used for that\n*     parameter.  Only positions up to NPARAMS are accessed; defaults\n*     are used for higher-numbered parameters.\n*\n*       PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative\n*            refinement or not.\n*         Default: 1.0D+0\n*            = 0.0 : No refinement is performed, and no error bounds are\n*                    computed.\n*            = 1.0 : Use the double-precision refinement algorithm,\n*                    possibly with doubled-single computations if the\n*                    compilation environment does not support DOUBLE\n*                    PRECISION.\n*              (other values are reserved for future use)\n*\n*       PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual\n*            computations allowed for refinement.\n*         Default: 10\n*         Aggressive: Set to 100 to permit convergence using approximate\n*                     factorizations or factorizations other than LU. If\n*                     the factorization uses a technique other than\n*                     Gaussian elimination, the guarantees in\n*                     err_bnds_norm and err_bnds_comp may no longer be\n*                     trustworthy.\n*\n*       PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code\n*            will attempt to find a solution with small componentwise\n*            relative error in the double-precision algorithm.  Positive\n*            is true, 0.0 is false.\n*         Default: 1.0 (attempt componentwise convergence)\n*\n*     WORK    (workspace) DOUBLE PRECISION array, dimension (4*N)\n*\n*     IWORK   (workspace) INTEGER array, dimension (N)\n*\n*     INFO    (output) INTEGER\n*       = 0:  Successful exit. The solution to every right-hand side is\n*         guaranteed.\n*       < 0:  If INFO = -i, the i-th argument had an illegal value\n*       > 0 and <= N:  U(INFO,INFO) is exactly zero.  The factorization\n*         has been completed, but the factor U is exactly singular, so\n*         the solution and error bounds could not be computed. RCOND = 0\n*         is returned.\n*       = N+J: The solution corresponding to the Jth right-hand side is\n*         not guaranteed. The solutions corresponding to other right-\n*         hand sides K with K > J may not be guaranteed as well, but\n*         only the first such right-hand side is reported. If a small\n*         componentwise error is not requested (PARAMS(3) = 0.0) then\n*         the Jth right-hand side is the first with a normwise error\n*         bound that is not guaranteed (the smallest J such\n*         that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0)\n*         the Jth right-hand side is the first with either a normwise or\n*         componentwise error bound that is not guaranteed (the smallest\n*         J such that either ERR_BNDS_NORM(J,1) = 0.0 or\n*         ERR_BNDS_COMP(J,1) = 0.0). See the definition of\n*         ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information\n*         about all of the right-hand sides check ERR_BNDS_NORM or\n*         ERR_BNDS_COMP.\n*\n\n*     ==================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  rcond, berr, err_bnds_norm, err_bnds_comp, info, s, x, params = NumRu::Lapack.dsyrfsx( uplo, equed, a, af, ipiv, s, b, x, params, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 9 && argc != 9)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 9)", argc);
  rblapack_uplo = argv[0];
  rblapack_equed = argv[1];
  rblapack_a = argv[2];
  rblapack_af = argv[3];
  rblapack_ipiv = argv[4];
  rblapack_s = argv[5];
  rblapack_b = argv[6];
  rblapack_x = argv[7];
  rblapack_params = argv[8];
  if (argc == 9) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th 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*);
  if (!NA_IsNArray(rblapack_ipiv))
    rb_raise(rb_eArgError, "ipiv (5th argument) must be NArray");
  if (NA_RANK(rblapack_ipiv) != 1)
    rb_raise(rb_eArgError, "rank of ipiv (5th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_ipiv) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of ipiv must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_ipiv) != NA_LINT)
    rblapack_ipiv = na_change_type(rblapack_ipiv, NA_LINT);
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (7th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (7th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  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 (!NA_IsNArray(rblapack_params))
    rb_raise(rb_eArgError, "params (9th argument) must be NArray");
  if (NA_RANK(rblapack_params) != 1)
    rb_raise(rb_eArgError, "rank of params (9th argument) must be %d", 1);
  nparams = NA_SHAPE0(rblapack_params);
  if (NA_TYPE(rblapack_params) != NA_DFLOAT)
    rblapack_params = na_change_type(rblapack_params, NA_DFLOAT);
  params = NA_PTR_TYPE(rblapack_params, doublereal*);
  equed = StringValueCStr(rblapack_equed)[0];
  if (!NA_IsNArray(rblapack_s))
    rb_raise(rb_eArgError, "s (6th argument) must be NArray");
  if (NA_RANK(rblapack_s) != 1)
    rb_raise(rb_eArgError, "rank of s (6th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_s) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of s must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_s) != NA_DFLOAT)
    rblapack_s = na_change_type(rblapack_s, NA_DFLOAT);
  s = NA_PTR_TYPE(rblapack_s, doublereal*);
  n_err_bnds = 3;
  if (!NA_IsNArray(rblapack_af))
    rb_raise(rb_eArgError, "af (4th argument) must be NArray");
  if (NA_RANK(rblapack_af) != 2)
    rb_raise(rb_eArgError, "rank of af (4th argument) must be %d", 2);
  ldaf = NA_SHAPE0(rblapack_af);
  if (NA_SHAPE1(rblapack_af) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of af must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_af) != NA_DFLOAT)
    rblapack_af = na_change_type(rblapack_af, NA_DFLOAT);
  af = NA_PTR_TYPE(rblapack_af, doublereal*);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (8th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 2)
    rb_raise(rb_eArgError, "rank of x (8th argument) must be %d", 2);
  ldx = NA_SHAPE0(rblapack_x);
  if (NA_SHAPE1(rblapack_x) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of x must be the same as shape 1 of b");
  if (NA_TYPE(rblapack_x) != NA_DFLOAT)
    rblapack_x = na_change_type(rblapack_x, NA_DFLOAT);
  x = NA_PTR_TYPE(rblapack_x, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_norm = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_norm = NA_PTR_TYPE(rblapack_err_bnds_norm, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = nrhs;
    shape[1] = n_err_bnds;
    rblapack_err_bnds_comp = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  err_bnds_comp = NA_PTR_TYPE(rblapack_err_bnds_comp, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_s_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  s_out__ = NA_PTR_TYPE(rblapack_s_out__, doublereal*);
  MEMCPY(s_out__, s, doublereal, NA_TOTAL(rblapack_s));
  rblapack_s = rblapack_s_out__;
  s = s_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldx;
    shape[1] = nrhs;
    rblapack_x_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, doublereal*);
  MEMCPY(x_out__, x, doublereal, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = nparams;
    rblapack_params_out__ = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  params_out__ = NA_PTR_TYPE(rblapack_params_out__, doublereal*);
  MEMCPY(params_out__, params, doublereal, NA_TOTAL(rblapack_params));
  rblapack_params = rblapack_params_out__;
  params = params_out__;
  work = ALLOC_N(doublereal, (4*n));
  iwork = ALLOC_N(integer, (n));

  dsyrfsx_(&uplo, &equed, &n, &nrhs, a, &lda, af, &ldaf, ipiv, s, b, &ldb, x, &ldx, &rcond, berr, &n_err_bnds, err_bnds_norm, err_bnds_comp, &nparams, params, work, iwork, &info);

  free(work);
  free(iwork);
  rblapack_rcond = rb_float_new((double)rcond);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(8, rblapack_rcond, rblapack_berr, rblapack_err_bnds_norm, rblapack_err_bnds_comp, rblapack_info, rblapack_s, rblapack_x, rblapack_params);
}

void
init_lapack_dsyrfsx(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dsyrfsx", rblapack_dsyrfsx, -1);
}
ruby-lapack-1.7.2/ext/dgetc2.c0000644000175000017500000001062612502221017015700 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dgetc2_(integer* n, doublereal* a, integer* lda, integer* ipiv, integer* jpiv, integer* info);


static VALUE
rblapack_dgetc2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_jpiv;
  integer *jpiv; 
  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  ipiv, jpiv, info, a = NumRu::Lapack.dgetc2( a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DGETC2( N, A, LDA, IPIV, JPIV, INFO )\n\n*  Purpose\n*  =======\n*\n*  DGETC2 computes an LU factorization with complete pivoting of the\n*  n-by-n matrix A. The factorization has the form A = P * L * U * Q,\n*  where P and Q are permutation matrices, L is lower triangular with\n*  unit diagonal elements and U is upper triangular.\n*\n*  This is the Level 2 BLAS algorithm.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The order of the matrix A. N >= 0.\n*\n*  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N)\n*          On entry, the n-by-n matrix A to be factored.\n*          On exit, the factors L and U from the factorization\n*          A = P*L*U*Q; the unit diagonal elements of L are not stored.\n*          If U(k, k) appears to be less than SMIN, U(k, k) is given the\n*          value of SMIN, i.e., giving a nonsingular perturbed system.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  IPIV    (output) INTEGER array, dimension(N).\n*          The pivot indices; for 1 <= i <= N, row i of the\n*          matrix has been interchanged with row IPIV(i).\n*\n*  JPIV    (output) INTEGER array, dimension(N).\n*          The pivot indices; for 1 <= j <= N, column j of the\n*          matrix has been interchanged with column JPIV(j).\n*\n*  INFO    (output) INTEGER\n*           = 0: successful exit\n*           > 0: if INFO = k, U(k, k) is likely to produce owerflow if\n*                we try to solve for x in Ax = b. So U is perturbed to\n*                avoid the overflow.\n*\n\n*  Further Details\n*  ===============\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, jpiv, info, a = NumRu::Lapack.dgetc2( 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*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_jpiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  jpiv = NA_PTR_TYPE(rblapack_jpiv, integer*);
  {
    na_shape_t 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__;

  dgetc2_(&n, a, &lda, ipiv, jpiv, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ipiv, rblapack_jpiv, rblapack_info, rblapack_a);
}

void
init_lapack_dgetc2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dgetc2", rblapack_dgetc2, -1);
}
ruby-lapack-1.7.2/ext/stbtrs.c0000644000175000017500000001310212502221014016036 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID stbtrs_(char* uplo, char* trans, char* diag, integer* n, integer* kd, integer* nrhs, real* ab, integer* ldab, real* b, integer* ldb, integer* info);


static VALUE
rblapack_stbtrs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  real *ab; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_b_out__;
  real *b_out__;

  integer ldab;
  integer n;
  integer ldb;
  integer nrhs;

  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  info, b = NumRu::Lapack.stbtrs( uplo, trans, diag, kd, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE STBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  STBTRS solves a triangular system of the form\n*\n*     A * X = B  or  A**T * X = B,\n*\n*  where A is a triangular band matrix of order N, and B is an\n*  N-by NRHS matrix.  A check is made to verify that A is nonsingular.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          = 'U':  A is upper triangular;\n*          = 'L':  A is lower triangular.\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the form the system of equations:\n*          = 'N':  A * X = B  (No transpose)\n*          = 'T':  A**T * X = B  (Transpose)\n*          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          = 'N':  A is non-unit triangular;\n*          = 'U':  A is unit triangular.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of superdiagonals or subdiagonals of the\n*          triangular band matrix A.  KD >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AB      (input) REAL array, dimension (LDAB,N)\n*          The upper or lower triangular band matrix A, stored in the\n*          first kd+1 rows of AB.  The j-th column of A is stored\n*          in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*          If DIAG = 'U', the diagonal elements of A are not referenced\n*          and are assumed to be 1.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  B       (input/output) REAL array, dimension (LDB,NRHS)\n*          On entry, the right hand side matrix B.\n*          On exit, if INFO = 0, the solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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 A is zero,\n*                indicating that the matrix is singular and the\n*                solutions X have not been computed.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, b = NumRu::Lapack.stbtrs( uplo, trans, diag, kd, ab, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_kd = argv[3];
  rblapack_ab = argv[4];
  rblapack_b = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (5th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (5th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SFLOAT)
    rblapack_ab = na_change_type(rblapack_ab, NA_SFLOAT);
  ab = NA_PTR_TYPE(rblapack_ab, real*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  kd = NUM2INT(rblapack_kd);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  stbtrs_(&uplo, &trans, &diag, &n, &kd, &nrhs, ab, &ldab, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_b);
}

void
init_lapack_stbtrs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "stbtrs", rblapack_stbtrs, -1);
}
ruby-lapack-1.7.2/ext/zhetd2.c0000644000175000017500000001554012502221025015727 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID zhetd2_(char* uplo, integer* n, doublecomplex* a, integer* lda, doublereal* d, doublereal* e, doublecomplex* tau, integer* info);


static VALUE
rblapack_zhetd2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_a;
  doublecomplex *a; 
  VALUE rblapack_d;
  doublereal *d; 
  VALUE rblapack_e;
  doublereal *e; 
  VALUE rblapack_tau;
  doublecomplex *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  doublecomplex *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  d, e, tau, info, a = NumRu::Lapack.zhetd2( uplo, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO )\n\n*  Purpose\n*  =======\n*\n*  ZHETD2 reduces a complex Hermitian matrix A to real symmetric\n*  tridiagonal form T by a unitary similarity transformation:\n*  Q' * A * Q = T.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the upper or lower triangular part of the\n*          Hermitian matrix A is stored:\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  A       (input/output) COMPLEX*16 array, dimension (LDA,N)\n*          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading\n*          n-by-n upper triangular part of A contains the upper\n*          triangular part of the matrix A, and the strictly lower\n*          triangular part of A is not referenced.  If UPLO = 'L', the\n*          leading n-by-n lower triangular part of A contains the lower\n*          triangular part of the matrix A, and the strictly upper\n*          triangular part of A is not referenced.\n*          On exit, if UPLO = 'U', the diagonal and first superdiagonal\n*          of A are overwritten by the corresponding elements of the\n*          tridiagonal matrix T, and the elements above the first\n*          superdiagonal, with the array TAU, represent the unitary\n*          matrix Q as a product of elementary reflectors; if UPLO\n*          = 'L', the diagonal and first subdiagonal of A are over-\n*          written by the corresponding elements of the tridiagonal\n*          matrix T, and the elements below the first subdiagonal, with\n*          the array TAU, represent the unitary matrix Q as a product\n*          of elementary reflectors. See Further Details.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,N).\n*\n*  D       (output) DOUBLE PRECISION array, dimension (N)\n*          The diagonal elements of the tridiagonal matrix T:\n*          D(i) = A(i,i).\n*\n*  E       (output) DOUBLE PRECISION array, dimension (N-1)\n*          The off-diagonal elements of the tridiagonal matrix T:\n*          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.\n*\n*  TAU     (output) COMPLEX*16 array, dimension (N-1)\n*          The scalar factors of the elementary reflectors (see Further\n*          Details).\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*  If UPLO = 'U', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(n-1) . . . H(2) H(1).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - tau * v * v'\n*\n*  where tau is a complex scalar, and v is a complex vector with\n*  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in\n*  A(1:i-1,i+1), and tau in TAU(i).\n*\n*  If UPLO = 'L', the matrix Q is represented as a product of elementary\n*  reflectors\n*\n*     Q = H(1) H(2) . . . H(n-1).\n*\n*  Each H(i) has the form\n*\n*     H(i) = I - tau * v * v'\n*\n*  where tau is a complex scalar, and v is a complex vector with\n*  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),\n*  and tau in TAU(i).\n*\n*  The contents of A on exit are illustrated by the following examples\n*  with n = 5:\n*\n*  if UPLO = 'U':                       if UPLO = 'L':\n*\n*    (  d   e   v2  v3  v4 )              (  d                  )\n*    (      d   e   v3  v4 )              (  e   d              )\n*    (          d   e   v4 )              (  v1  e   d          )\n*    (              d   e  )              (  v1  v2  e   d      )\n*    (                  d  )              (  v1  v2  v3  e   d  )\n*\n*  where d and e denote diagonal and off-diagonal elements of T, and vi\n*  denotes an element of the vector defining H(i).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  d, e, tau, info, a = NumRu::Lapack.zhetd2( uplo, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_uplo = argv[0];
  rblapack_a = argv[1];
  if (argc == 2) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  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_DCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_DCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, doublecomplex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_d = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  d = NA_PTR_TYPE(rblapack_d, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_e = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  e = NA_PTR_TYPE(rblapack_e, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = n-1;
    rblapack_tau = na_make_object(NA_DCOMPLEX, 1, shape, cNArray);
  }
  tau = NA_PTR_TYPE(rblapack_tau, doublecomplex*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_DCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, doublecomplex*);
  MEMCPY(a_out__, a, doublecomplex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;

  zhetd2_(&uplo, &n, a, &lda, d, e, tau, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(5, rblapack_d, rblapack_e, rblapack_tau, rblapack_info, rblapack_a);
}

void
init_lapack_zhetd2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "zhetd2", rblapack_zhetd2, -1);
}
ruby-lapack-1.7.2/ext/cgbsv.c0000644000175000017500000001634212502221020015627 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID cgbsv_(integer* n, integer* kl, integer* ku, integer* nrhs, complex* ab, integer* ldab, integer* ipiv, complex* b, integer* ldb, integer* info);


static VALUE
rblapack_cgbsv(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_kl;
  integer kl; 
  VALUE rblapack_ku;
  integer ku; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_ipiv;
  integer *ipiv; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_ab_out__;
  complex *ab_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;

  integer ldab;
  integer n;
  integer ldb;
  integer nrhs;

  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  ipiv, info, ab, b = NumRu::Lapack.cgbsv( kl, ku, ab, b, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )\n\n*  Purpose\n*  =======\n*\n*  CGBSV computes the solution to a complex system of linear equations\n*  A * X = B, where A is a band matrix of order N with KL subdiagonals\n*  and KU superdiagonals, and X and B are N-by-NRHS matrices.\n*\n*  The LU decomposition with partial pivoting and row interchanges is\n*  used to factor A as A = L * U, where L is a product of permutation\n*  and unit lower triangular matrices with KL subdiagonals, and U is\n*  upper triangular with KL+KU superdiagonals.  The factored form of A\n*  is then used to solve the system of equations A * X = B.\n*\n\n*  Arguments\n*  =========\n*\n*  N       (input) INTEGER\n*          The number of linear equations, i.e., the order of the\n*          matrix A.  N >= 0.\n*\n*  KL      (input) INTEGER\n*          The number of subdiagonals within the band of A.  KL >= 0.\n*\n*  KU      (input) INTEGER\n*          The number of superdiagonals within the band of A.  KU >= 0.\n*\n*  NRHS    (input) INTEGER\n*          The number of right hand sides, i.e., the number of columns\n*          of the matrix B.  NRHS >= 0.\n*\n*  AB      (input/output) COMPLEX array, dimension (LDAB,N)\n*          On entry, the matrix A in band storage, in rows KL+1 to\n*          2*KL+KU+1; rows 1 to KL of the array need not be set.\n*          The j-th column of A is stored in the j-th column of the\n*          array AB as follows:\n*          AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)\n*          On exit, details of the factorization: U is stored as an\n*          upper triangular band matrix with KL+KU superdiagonals in\n*          rows 1 to KL+KU+1, and the multipliers used during the\n*          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.\n*          See below for further details.\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.\n*\n*  IPIV    (output) INTEGER array, dimension (N)\n*          The pivot indices that define the permutation matrix P;\n*          row i of the matrix was interchanged with row IPIV(i).\n*\n*  B       (input/output) COMPLEX array, dimension (LDB,NRHS)\n*          On entry, the N-by-NRHS right hand side matrix B.\n*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,N).\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, U(i,i) is exactly zero.  The factorization\n*                has been completed, but the factor U is exactly\n*                singular, and the solution has not been computed.\n*\n\n*  Further Details\n*  ===============\n*\n*  The band storage scheme is illustrated by the following example, when\n*  M = N = 6, KL = 2, KU = 1:\n*\n*  On entry:                       On exit:\n*\n*      *    *    *    +    +    +       *    *    *   u14  u25  u36\n*      *    *    +    +    +    +       *    *   u13  u24  u35  u46\n*      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56\n*     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66\n*     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *\n*     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *\n*\n*  Array elements marked * are not used by the routine; elements marked\n*  + need not be set on entry, but are required by the routine to store\n*  elements of U because of fill-in resulting from the row interchanges.\n*\n*  =====================================================================\n*\n*     .. External Subroutines ..\n      EXTERNAL           CGBTRF, CGBTRS, XERBLA\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MAX\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  ipiv, info, ab, b = NumRu::Lapack.cgbsv( kl, ku, ab, b, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 4)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_kl = argv[0];
  rblapack_ku = argv[1];
  rblapack_ab = argv[2];
  rblapack_b = argv[3];
  if (argc == 4) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  kl = NUM2INT(rblapack_kl);
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (3th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (3th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  n = NA_SHAPE1(rblapack_ab);
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  ku = NUM2INT(rblapack_ku);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  nrhs = NA_SHAPE1(rblapack_b);
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_ipiv = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  ipiv = NA_PTR_TYPE(rblapack_ipiv, integer*);
  {
    na_shape_t shape[2];
    shape[0] = ldab;
    shape[1] = n;
    rblapack_ab_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  ab_out__ = NA_PTR_TYPE(rblapack_ab_out__, complex*);
  MEMCPY(ab_out__, ab, complex, NA_TOTAL(rblapack_ab));
  rblapack_ab = rblapack_ab_out__;
  ab = ab_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = nrhs;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  cgbsv_(&n, &kl, &ku, &nrhs, ab, &ldab, ipiv, b, &ldb, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_ipiv, rblapack_info, rblapack_ab, rblapack_b);
}

void
init_lapack_cgbsv(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "cgbsv", rblapack_cgbsv, -1);
}
ruby-lapack-1.7.2/ext/sgegs.c0000644000175000017500000002527312502221024015642 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sgegs_(char* jobvsl, char* jobvsr, integer* n, real* a, integer* lda, real* b, integer* ldb, real* alphar, real* alphai, real* beta, real* vsl, integer* ldvsl, real* vsr, integer* ldvsr, real* work, integer* lwork, integer* info);


static VALUE
rblapack_sgegs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_jobvsl;
  char jobvsl; 
  VALUE rblapack_jobvsr;
  char jobvsr; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_alphar;
  real *alphar; 
  VALUE rblapack_alphai;
  real *alphai; 
  VALUE rblapack_beta;
  real *beta; 
  VALUE rblapack_vsl;
  real *vsl; 
  VALUE rblapack_vsr;
  real *vsr; 
  VALUE rblapack_work;
  real *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  VALUE rblapack_b_out__;
  real *b_out__;

  integer lda;
  integer n;
  integer ldb;
  integer ldvsl;
  integer ldvsr;

  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  alphar, alphai, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.sgegs( jobvsl, jobvsr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  This routine is deprecated and has been replaced by routine SGGES.\n*\n*  SGEGS computes the eigenvalues, real Schur form, and, optionally,\n*  left and or/right Schur vectors of a real matrix pair (A,B).\n*  Given two square matrices A and B, the generalized real Schur\n*  factorization has the form\n*  \n*    A = Q*S*Z**T,  B = Q*T*Z**T\n*\n*  where Q and Z are orthogonal matrices, T is upper triangular, and S\n*  is an upper quasi-triangular matrix with 1-by-1 and 2-by-2 diagonal\n*  blocks, the 2-by-2 blocks corresponding to complex conjugate pairs\n*  of eigenvalues of (A,B).  The columns of Q are the left Schur vectors\n*  and the columns of Z are the right Schur vectors.\n*  \n*  If only the eigenvalues of (A,B) are needed, the driver routine\n*  SGEGV should be used instead.  See SGEGV for a description of the\n*  eigenvalues of the generalized nonsymmetric eigenvalue problem\n*  (GNEP).\n*\n\n*  Arguments\n*  =========\n*\n*  JOBVSL  (input) CHARACTER*1\n*          = 'N':  do not compute the left Schur vectors;\n*          = 'V':  compute the left Schur vectors (returned in VSL).\n*\n*  JOBVSR  (input) CHARACTER*1\n*          = 'N':  do not compute the right Schur vectors;\n*          = 'V':  compute the right Schur vectors (returned in VSR).\n*\n*  N       (input) INTEGER\n*          The order of the matrices A, B, VSL, and VSR.  N >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA, N)\n*          On entry, the matrix A.\n*          On exit, the upper quasi-triangular matrix S from the\n*          generalized real Schur factorization.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of A.  LDA >= max(1,N).\n*\n*  B       (input/output) REAL array, dimension (LDB, N)\n*          On entry, the matrix B.\n*          On exit, the upper triangular matrix T from the generalized\n*          real Schur factorization.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of B.  LDB >= max(1,N).\n*\n*  ALPHAR  (output) REAL array, dimension (N)\n*          The real parts of each scalar alpha defining an eigenvalue\n*          of GNEP.\n*\n*  ALPHAI  (output) REAL array, dimension (N)\n*          The imaginary parts of each scalar alpha defining an\n*          eigenvalue of GNEP.  If ALPHAI(j) is zero, then the j-th\n*          eigenvalue is real; if positive, then the j-th and (j+1)-st\n*          eigenvalues are a complex conjugate pair, with\n*          ALPHAI(j+1) = -ALPHAI(j).\n*\n*  BETA    (output) REAL array, dimension (N)\n*          The scalars beta that define the eigenvalues of GNEP.\n*          Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and\n*          beta = BETA(j) represent the j-th eigenvalue of the matrix\n*          pair (A,B), in one of the forms lambda = alpha/beta or\n*          mu = beta/alpha.  Since either lambda or mu may overflow,\n*          they should not, in general, be computed.\n*\n*  VSL     (output) REAL array, dimension (LDVSL,N)\n*          If JOBVSL = 'V', the matrix of left Schur vectors Q.\n*          Not referenced if JOBVSL = 'N'.\n*\n*  LDVSL   (input) INTEGER\n*          The leading dimension of the matrix VSL. LDVSL >=1, and\n*          if JOBVSL = 'V', LDVSL >= N.\n*\n*  VSR     (output) REAL array, dimension (LDVSR,N)\n*          If JOBVSR = 'V', the matrix of right Schur vectors Z.\n*          Not referenced if JOBVSR = 'N'.\n*\n*  LDVSR   (input) INTEGER\n*          The leading dimension of the matrix VSR. LDVSR >= 1, and\n*          if JOBVSR = 'V', LDVSR >= N.\n*\n*  WORK    (workspace/output) REAL 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,4*N).\n*          For good performance, LWORK must generally be larger.\n*          To compute the optimal value of LWORK, call ILAENV to get\n*          blocksizes (for SGEQRF, SORMQR, and SORGQR.)  Then compute:\n*          NB  -- MAX of the blocksizes for SGEQRF, SORMQR, and SORGQR\n*          The optimal LWORK is  2*N + N*(NB+1).\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*          = 1,...,N:\n*                The QZ iteration failed.  (A,B) are not in Schur\n*                form, but ALPHAR(j), ALPHAI(j), and BETA(j) should\n*                be correct for j=INFO+1,...,N.\n*          > N:  errors that usually indicate LAPACK problems:\n*                =N+1: error return from SGGBAL\n*                =N+2: error return from SGEQRF\n*                =N+3: error return from SORMQR\n*                =N+4: error return from SORGQR\n*                =N+5: error return from SGGHRD\n*                =N+6: error return from SHGEQZ (other than failed\n*                                                iteration)\n*                =N+7: error return from SGGBAK (computing VSL)\n*                =N+8: error return from SGGBAK (computing VSR)\n*                =N+9: error return from SLASCL (various places)\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  alphar, alphai, beta, vsl, vsr, work, info, a, b = NumRu::Lapack.sgegs( jobvsl, jobvsr, a, b, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 4 && argc != 5)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 4)", argc);
  rblapack_jobvsl = argv[0];
  rblapack_jobvsr = argv[1];
  rblapack_a = argv[2];
  rblapack_b = argv[3];
  if (argc == 5) {
    rblapack_lwork = argv[4];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  jobvsl = StringValueCStr(rblapack_jobvsl)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  jobvsr = StringValueCStr(rblapack_jobvsr)[0];
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (4th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (4th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_SFLOAT)
    rblapack_b = na_change_type(rblapack_b, NA_SFLOAT);
  b = NA_PTR_TYPE(rblapack_b, real*);
  ldvsl = lsame_(&jobvsl,"V") ? n : 1;
  if (rblapack_lwork == Qnil)
    lwork = 4*n;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  ldvsr = lsame_(&jobvsr,"V") ? n : 1;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphar = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  alphar = NA_PTR_TYPE(rblapack_alphar, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alphai = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  alphai = NA_PTR_TYPE(rblapack_alphai, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldvsl;
    shape[1] = n;
    rblapack_vsl = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vsl = NA_PTR_TYPE(rblapack_vsl, real*);
  {
    na_shape_t shape[2];
    shape[0] = ldvsr;
    shape[1] = n;
    rblapack_vsr = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  vsr = NA_PTR_TYPE(rblapack_vsr, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, real*);
  MEMCPY(b_out__, b, real, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;

  sgegs_(&jobvsl, &jobvsr, &n, a, &lda, b, &ldb, alphar, alphai, beta, vsl, &ldvsl, vsr, &ldvsr, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(9, rblapack_alphar, rblapack_alphai, rblapack_beta, rblapack_vsl, rblapack_vsr, rblapack_work, rblapack_info, rblapack_a, rblapack_b);
}

void
init_lapack_sgegs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sgegs", rblapack_sgegs, -1);
}
ruby-lapack-1.7.2/ext/slaexc.c0000644000175000017500000001310312502221025015777 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slaexc_(logical* wantq, integer* n, real* t, integer* ldt, real* q, integer* ldq, integer* j1, integer* n1, integer* n2, real* work, integer* info);


static VALUE
rblapack_slaexc(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_wantq;
  logical wantq; 
  VALUE rblapack_t;
  real *t; 
  VALUE rblapack_q;
  real *q; 
  VALUE rblapack_j1;
  integer j1; 
  VALUE rblapack_n1;
  integer n1; 
  VALUE rblapack_n2;
  integer n2; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_t_out__;
  real *t_out__;
  VALUE rblapack_q_out__;
  real *q_out__;
  real *work;

  integer ldt;
  integer n;
  integer ldq;

  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  info, t, q = NumRu::Lapack.slaexc( wantq, t, q, j1, n1, n2, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in\n*  an upper quasi-triangular matrix T by an orthogonal similarity\n*  transformation.\n*\n*  T must be in Schur canonical form, that is, block upper triangular\n*  with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block\n*  has its diagonal elemnts equal and its off-diagonal elements of\n*  opposite sign.\n*\n\n*  Arguments\n*  =========\n*\n*  WANTQ   (input) LOGICAL\n*          = .TRUE. : accumulate the transformation in the matrix Q;\n*          = .FALSE.: do not accumulate the transformation.\n*\n*  N       (input) INTEGER\n*          The order of the matrix T. N >= 0.\n*\n*  T       (input/output) REAL array, dimension (LDT,N)\n*          On entry, the upper quasi-triangular matrix T, in Schur\n*          canonical form.\n*          On exit, the updated matrix T, again in Schur canonical form.\n*\n*  LDT     (input)  INTEGER\n*          The leading dimension of the array T. LDT >= max(1,N).\n*\n*  Q       (input/output) REAL array, dimension (LDQ,N)\n*          On entry, if WANTQ is .TRUE., the orthogonal matrix Q.\n*          On exit, if WANTQ is .TRUE., the updated matrix Q.\n*          If WANTQ is .FALSE., Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q.\n*          LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N.\n*\n*  J1      (input) INTEGER\n*          The index of the first row of the first block T11.\n*\n*  N1      (input) INTEGER\n*          The order of the first block T11. N1 = 0, 1 or 2.\n*\n*  N2      (input) INTEGER\n*          The order of the second block T22. N2 = 0, 1 or 2.\n*\n*  WORK    (workspace) REAL array, dimension (N)\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          = 1: the transformed matrix T would be too far from Schur\n*               form; the blocks are not swapped and T and Q are\n*               unchanged.\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, t, q = NumRu::Lapack.slaexc( wantq, t, q, j1, n1, n2, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 6)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_wantq = argv[0];
  rblapack_t = argv[1];
  rblapack_q = argv[2];
  rblapack_j1 = argv[3];
  rblapack_n1 = argv[4];
  rblapack_n2 = argv[5];
  if (argc == 6) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  wantq = (rblapack_wantq == Qtrue);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (3th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (3th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  n = NA_SHAPE1(rblapack_q);
  if (NA_TYPE(rblapack_q) != NA_SFLOAT)
    rblapack_q = na_change_type(rblapack_q, NA_SFLOAT);
  q = NA_PTR_TYPE(rblapack_q, real*);
  n1 = NUM2INT(rblapack_n1);
  if (!NA_IsNArray(rblapack_t))
    rb_raise(rb_eArgError, "t (2th argument) must be NArray");
  if (NA_RANK(rblapack_t) != 2)
    rb_raise(rb_eArgError, "rank of t (2th argument) must be %d", 2);
  ldt = NA_SHAPE0(rblapack_t);
  if (NA_SHAPE1(rblapack_t) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of t must be the same as shape 1 of q");
  if (NA_TYPE(rblapack_t) != NA_SFLOAT)
    rblapack_t = na_change_type(rblapack_t, NA_SFLOAT);
  t = NA_PTR_TYPE(rblapack_t, real*);
  n2 = NUM2INT(rblapack_n2);
  j1 = NUM2INT(rblapack_j1);
  {
    na_shape_t shape[2];
    shape[0] = ldt;
    shape[1] = n;
    rblapack_t_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  t_out__ = NA_PTR_TYPE(rblapack_t_out__, real*);
  MEMCPY(t_out__, t, real, NA_TOTAL(rblapack_t));
  rblapack_t = rblapack_t_out__;
  t = t_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, real*);
  MEMCPY(q_out__, q, real, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  work = ALLOC_N(real, (n));

  slaexc_(&wantq, &n, t, &ldt, q, &ldq, &j1, &n1, &n2, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_info, rblapack_t, rblapack_q);
}

void
init_lapack_slaexc(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slaexc", rblapack_slaexc, -1);
}
ruby-lapack-1.7.2/ext/slacpy.c0000644000175000017500000000704312502221014016017 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID slacpy_(char* uplo, integer* m, integer* n, real* a, integer* lda, real* b, integer* ldb);


static VALUE
rblapack_slacpy(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_b;
  real *b; 

  integer lda;
  integer n;
  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  b = NumRu::Lapack.slacpy( uplo, m, a, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SLACPY( UPLO, M, N, A, LDA, B, LDB )\n\n*  Purpose\n*  =======\n*\n*  SLACPY copies all or part of a two-dimensional matrix A to another\n*  matrix B.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies the part of the matrix A to be copied to B.\n*          = 'U':      Upper triangular part\n*          = 'L':      Lower triangular part\n*          Otherwise:  All of the matrix A\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) REAL array, dimension (LDA,N)\n*          The m by n matrix A.  If UPLO = 'U', only the upper triangle\n*          or trapezoid is accessed; if UPLO = 'L', only the lower\n*          triangle or trapezoid is accessed.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.  LDA >= max(1,M).\n*\n*  B       (output) REAL array, dimension (LDB,N)\n*          On exit, B = A in the locations specified by UPLO.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B.  LDB >= max(1,M).\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      INTEGER            I, J\n*     ..\n*     .. External Functions ..\n      LOGICAL            LSAME\n      EXTERNAL           LSAME\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          MIN\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  b = NumRu::Lapack.slacpy( uplo, m, a, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_uplo = argv[0];
  rblapack_m = argv[1];
  rblapack_a = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (3th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (3th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  m = NUM2INT(rblapack_m);
  ldb = MAX(1,m);
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  b = NA_PTR_TYPE(rblapack_b, real*);

  slacpy_(&uplo, &m, &n, a, &lda, b, &ldb);

  return rblapack_b;
}

void
init_lapack_slacpy(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "slacpy", rblapack_slacpy, -1);
}
ruby-lapack-1.7.2/ext/dormql.c0000644000175000017500000001642312502221012016022 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dormql_(char* side, char* trans, integer* m, integer* n, integer* k, doublereal* a, integer* lda, doublereal* tau, doublereal* c, integer* ldc, doublereal* work, integer* lwork, integer* info);


static VALUE
rblapack_dormql(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_side;
  char side; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_a;
  doublereal *a; 
  VALUE rblapack_tau;
  doublereal *tau; 
  VALUE rblapack_c;
  doublereal *c; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_work;
  doublereal *work; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_c_out__;
  doublereal *c_out__;

  integer lda;
  integer k;
  integer ldc;
  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  work, info, c = NumRu::Lapack.dormql( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  DORMQL overwrites the general real M-by-N matrix C with\n*\n*                  SIDE = 'L'     SIDE = 'R'\n*  TRANS = 'N':      Q * C          C * Q\n*  TRANS = 'T':      Q**T * C       C * Q**T\n*\n*  where Q is a real orthogonal matrix defined as the product of k\n*  elementary reflectors\n*\n*        Q = H(k) . . . H(2) H(1)\n*\n*  as returned by DGEQLF. Q is of order M if SIDE = 'L' and of order N\n*  if SIDE = 'R'.\n*\n\n*  Arguments\n*  =========\n*\n*  SIDE    (input) CHARACTER*1\n*          = 'L': apply Q or Q**T from the Left;\n*          = 'R': apply Q or Q**T from the Right.\n*\n*  TRANS   (input) CHARACTER*1\n*          = 'N':  No transpose, apply Q;\n*          = 'T':  Transpose, apply Q**T.\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix C. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix C. N >= 0.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines\n*          the matrix Q.\n*          If SIDE = 'L', M >= K >= 0;\n*          if SIDE = 'R', N >= K >= 0.\n*\n*  A       (input) DOUBLE PRECISION array, dimension (LDA,K)\n*          The i-th column must contain the vector which defines the\n*          elementary reflector H(i), for i = 1,2,...,k, as returned by\n*          DGEQLF in the last k columns of its array argument A.\n*          A is modified by the routine but restored on exit.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A.\n*          If SIDE = 'L', LDA >= max(1,M);\n*          if SIDE = 'R', LDA >= max(1,N).\n*\n*  TAU     (input) DOUBLE PRECISION array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by DGEQLF.\n*\n*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)\n*          On entry, the M-by-N matrix C.\n*          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.\n*\n*  LDC     (input) INTEGER\n*          The leading dimension of the array C. LDC >= max(1,M).\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*          If SIDE = 'L', LWORK >= max(1,N);\n*          if SIDE = 'R', LWORK >= max(1,M).\n*          For optimum performance LWORK >= N*NB if SIDE = 'L', and\n*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal\n*          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*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  work, info, c = NumRu::Lapack.dormql( side, trans, m, a, tau, c, [:lwork => lwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 6 && argc != 7)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 6)", argc);
  rblapack_side = argv[0];
  rblapack_trans = argv[1];
  rblapack_m = argv[2];
  rblapack_a = argv[3];
  rblapack_tau = argv[4];
  rblapack_c = argv[5];
  if (argc == 7) {
    rblapack_lwork = argv[6];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
  } else {
    rblapack_lwork = Qnil;
  }

  side = StringValueCStr(rblapack_side)[0];
  m = NUM2INT(rblapack_m);
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (5th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (5th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_DFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_DFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, doublereal*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_c))
    rb_raise(rb_eArgError, "c (6th argument) must be NArray");
  if (NA_RANK(rblapack_c) != 2)
    rb_raise(rb_eArgError, "rank of c (6th argument) must be %d", 2);
  ldc = NA_SHAPE0(rblapack_c);
  n = NA_SHAPE1(rblapack_c);
  if (NA_TYPE(rblapack_c) != NA_DFLOAT)
    rblapack_c = na_change_type(rblapack_c, NA_DFLOAT);
  c = NA_PTR_TYPE(rblapack_c, doublereal*);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (4th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (4th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  if (NA_SHAPE1(rblapack_a) != k)
    rb_raise(rb_eRuntimeError, "shape 1 of a must be the same as shape 0 of tau");
  if (NA_TYPE(rblapack_a) != NA_DFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_DFLOAT);
  a = NA_PTR_TYPE(rblapack_a, doublereal*);
  if (rblapack_lwork == Qnil)
    lwork = lsame_(&side,"L") ? n : lsame_(&side,"R") ? m : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, doublereal*);
  {
    na_shape_t shape[2];
    shape[0] = ldc;
    shape[1] = n;
    rblapack_c_out__ = na_make_object(NA_DFLOAT, 2, shape, cNArray);
  }
  c_out__ = NA_PTR_TYPE(rblapack_c_out__, doublereal*);
  MEMCPY(c_out__, c, doublereal, NA_TOTAL(rblapack_c));
  rblapack_c = rblapack_c_out__;
  c = c_out__;

  dormql_(&side, &trans, &m, &n, &k, a, &lda, tau, c, &ldc, work, &lwork, &info);

  rblapack_info = INT2NUM(info);
  return rb_ary_new3(3, rblapack_work, rblapack_info, rblapack_c);
}

void
init_lapack_dormql(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dormql", rblapack_dormql, -1);
}
ruby-lapack-1.7.2/ext/sorgl2.c0000644000175000017500000001015612502221017015736 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID sorgl2_(integer* m, integer* n, integer* k, real* a, integer* lda, real* tau, real* work, integer* info);


static VALUE
rblapack_sorgl2(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_a;
  real *a; 
  VALUE rblapack_tau;
  real *tau; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  real *a_out__;
  real *work;

  integer lda;
  integer n;
  integer k;
  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  info, a = NumRu::Lapack.sorgl2( a, tau, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE SORGL2( M, N, K, A, LDA, TAU, WORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  SORGL2 generates an m by n real matrix Q with orthonormal rows,\n*  which is defined as the first m rows of a product of k elementary\n*  reflectors of order n\n*\n*        Q  =  H(k) . . . H(2) H(1)\n*\n*  as returned by SGELQF.\n*\n\n*  Arguments\n*  =========\n*\n*  M       (input) INTEGER\n*          The number of rows of the matrix Q. M >= 0.\n*\n*  N       (input) INTEGER\n*          The number of columns of the matrix Q. N >= M.\n*\n*  K       (input) INTEGER\n*          The number of elementary reflectors whose product defines the\n*          matrix Q. M >= K >= 0.\n*\n*  A       (input/output) REAL array, dimension (LDA,N)\n*          On entry, the i-th row must contain the vector which defines\n*          the elementary reflector H(i), for i = 1,2,...,k, as returned\n*          by SGELQF in the first k rows of its array argument A.\n*          On exit, the m-by-n matrix Q.\n*\n*  LDA     (input) INTEGER\n*          The first dimension of the array A. LDA >= max(1,M).\n*\n*  TAU     (input) REAL array, dimension (K)\n*          TAU(i) must contain the scalar factor of the elementary\n*          reflector H(i), as returned by SGELQF.\n*\n*  WORK    (workspace) REAL array, dimension (M)\n*\n*  INFO    (output) INTEGER\n*          = 0: successful exit\n*          < 0: if INFO = -i, the i-th argument has an illegal value\n*\n\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  info, a = NumRu::Lapack.sorgl2( a, tau, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 2 && argc != 2)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 2)", argc);
  rblapack_a = argv[0];
  rblapack_tau = argv[1];
  if (argc == 2) {
  } 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_SFLOAT)
    rblapack_a = na_change_type(rblapack_a, NA_SFLOAT);
  a = NA_PTR_TYPE(rblapack_a, real*);
  m = lda;
  if (!NA_IsNArray(rblapack_tau))
    rb_raise(rb_eArgError, "tau (2th argument) must be NArray");
  if (NA_RANK(rblapack_tau) != 1)
    rb_raise(rb_eArgError, "rank of tau (2th argument) must be %d", 1);
  k = NA_SHAPE0(rblapack_tau);
  if (NA_TYPE(rblapack_tau) != NA_SFLOAT)
    rblapack_tau = na_change_type(rblapack_tau, NA_SFLOAT);
  tau = NA_PTR_TYPE(rblapack_tau, real*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SFLOAT, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, real*);
  MEMCPY(a_out__, a, real, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  work = ALLOC_N(real, (m));

  sorgl2_(&m, &n, &k, a, &lda, tau, work, &info);

  free(work);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(2, rblapack_info, rblapack_a);
}

void
init_lapack_sorgl2(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "sorgl2", rblapack_sorgl2, -1);
}
ruby-lapack-1.7.2/ext/clatbs.c0000644000175000017500000002501112502221013015766 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID clatbs_(char* uplo, char* trans, char* diag, char* normin, integer* n, integer* kd, complex* ab, integer* ldab, complex* x, real* scale, real* cnorm, integer* info);


static VALUE
rblapack_clatbs(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_uplo;
  char uplo; 
  VALUE rblapack_trans;
  char trans; 
  VALUE rblapack_diag;
  char diag; 
  VALUE rblapack_normin;
  char normin; 
  VALUE rblapack_kd;
  integer kd; 
  VALUE rblapack_ab;
  complex *ab; 
  VALUE rblapack_x;
  complex *x; 
  VALUE rblapack_cnorm;
  real *cnorm; 
  VALUE rblapack_scale;
  real scale; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_x_out__;
  complex *x_out__;
  VALUE rblapack_cnorm_out__;
  real *cnorm_out__;

  integer ldab;
  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  scale, info, x, cnorm = NumRu::Lapack.clatbs( uplo, trans, diag, normin, kd, ab, x, cnorm, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, SCALE, CNORM, INFO )\n\n*  Purpose\n*  =======\n*\n*  CLATBS solves one of the triangular systems\n*\n*     A * x = s*b,  A**T * x = s*b,  or  A**H * x = s*b,\n*\n*  with scaling to prevent overflow, where A is an upper or lower\n*  triangular band matrix.  Here A' denotes the transpose of A, x and b\n*  are n-element vectors, and s is a scaling factor, usually less than\n*  or equal to 1, chosen so that the components of x will be less than\n*  the overflow threshold.  If the unscaled problem will not cause\n*  overflow, the Level 2 BLAS routine CTBSV is called.  If the matrix A\n*  is singular (A(j,j) = 0 for some j), then s is set to 0 and a\n*  non-trivial solution to A*x = 0 is returned.\n*\n\n*  Arguments\n*  =========\n*\n*  UPLO    (input) CHARACTER*1\n*          Specifies whether the matrix A is upper or lower triangular.\n*          = 'U':  Upper triangular\n*          = 'L':  Lower triangular\n*\n*  TRANS   (input) CHARACTER*1\n*          Specifies the operation applied to A.\n*          = 'N':  Solve A * x = s*b     (No transpose)\n*          = 'T':  Solve A**T * x = s*b  (Transpose)\n*          = 'C':  Solve A**H * x = s*b  (Conjugate transpose)\n*\n*  DIAG    (input) CHARACTER*1\n*          Specifies whether or not the matrix A is unit triangular.\n*          = 'N':  Non-unit triangular\n*          = 'U':  Unit triangular\n*\n*  NORMIN  (input) CHARACTER*1\n*          Specifies whether CNORM has been set or not.\n*          = 'Y':  CNORM contains the column norms on entry\n*          = 'N':  CNORM is not set on entry.  On exit, the norms will\n*                  be computed and stored in CNORM.\n*\n*  N       (input) INTEGER\n*          The order of the matrix A.  N >= 0.\n*\n*  KD      (input) INTEGER\n*          The number of subdiagonals or superdiagonals in the\n*          triangular matrix A.  KD >= 0.\n*\n*  AB      (input) COMPLEX array, dimension (LDAB,N)\n*          The upper or lower triangular band matrix A, stored in the\n*          first KD+1 rows of the array. The j-th column of A is stored\n*          in the j-th column of the array AB as follows:\n*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;\n*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).\n*\n*  LDAB    (input) INTEGER\n*          The leading dimension of the array AB.  LDAB >= KD+1.\n*\n*  X       (input/output) COMPLEX array, dimension (N)\n*          On entry, the right hand side b of the triangular system.\n*          On exit, X is overwritten by the solution vector x.\n*\n*  SCALE   (output) REAL\n*          The scaling factor s for the triangular system\n*             A * x = s*b,  A**T * x = s*b,  or  A**H * x = s*b.\n*          If SCALE = 0, the matrix A is singular or badly scaled, and\n*          the vector x is an exact or approximate solution to A*x = 0.\n*\n*  CNORM   (input or output) REAL array, dimension (N)\n*\n*          If NORMIN = 'Y', CNORM is an input argument and CNORM(j)\n*          contains the norm of the off-diagonal part of the j-th column\n*          of A.  If TRANS = 'N', CNORM(j) must be greater than or equal\n*          to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)\n*          must be greater than or equal to the 1-norm.\n*\n*          If NORMIN = 'N', CNORM is an output argument and CNORM(j)\n*          returns the 1-norm of the offdiagonal part of the j-th column\n*          of A.\n*\n*  INFO    (output) INTEGER\n*          = 0:  successful exit\n*          < 0:  if INFO = -k, the k-th argument had an illegal value\n*\n\n*  Further Details\n*  ======= =======\n*\n*  A rough bound on x is computed; if that is less than overflow, CTBSV\n*  is called, otherwise, specific code is used which checks for possible\n*  overflow or divide-by-zero at every operation.\n*\n*  A columnwise scheme is used for solving A*x = b.  The basic algorithm\n*  if A is lower triangular is\n*\n*       x[1:n] := b[1:n]\n*       for j = 1, ..., n\n*            x(j) := x(j) / A(j,j)\n*            x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]\n*       end\n*\n*  Define bounds on the components of x after j iterations of the loop:\n*     M(j) = bound on x[1:j]\n*     G(j) = bound on x[j+1:n]\n*  Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.\n*\n*  Then for iteration j+1 we have\n*     M(j+1) <= G(j) / | A(j+1,j+1) |\n*     G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |\n*            <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )\n*\n*  where CNORM(j+1) is greater than or equal to the infinity-norm of\n*  column j+1 of A, not counting the diagonal.  Hence\n*\n*     G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )\n*                  1<=i<=j\n*  and\n*\n*     |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )\n*                                   1<=i< j\n*\n*  Since |x(j)| <= M(j), we use the Level 2 BLAS routine CTBSV if the\n*  reciprocal of the largest M(j), j=1,..,n, is larger than\n*  max(underflow, 1/overflow).\n*\n*  The bound on x(j) is also used to determine when a step in the\n*  columnwise method can be performed without fear of overflow.  If\n*  the computed bound is greater than a large constant, x is scaled to\n*  prevent overflow, but if the bound overflows, x is set to 0, x(j) to\n*  1, and scale to 0, and a non-trivial solution to A*x = 0 is found.\n*\n*  Similarly, a row-wise scheme is used to solve A**T *x = b  or\n*  A**H *x = b.  The basic algorithm for A upper triangular is\n*\n*       for j = 1, ..., n\n*            x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)\n*       end\n*\n*  We simultaneously compute two bounds\n*       G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j\n*       M(j) = bound on x(i), 1<=i<=j\n*\n*  The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we\n*  add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.\n*  Then the bound on x(j) is\n*\n*       M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |\n*\n*            <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )\n*                      1<=i<=j\n*\n*  and we can safely call CTBSV if 1/M(n) and 1/G(n) are both greater\n*  than max(underflow, 1/overflow).\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  scale, info, x, cnorm = NumRu::Lapack.clatbs( uplo, trans, diag, normin, kd, ab, x, cnorm, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 8)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_uplo = argv[0];
  rblapack_trans = argv[1];
  rblapack_diag = argv[2];
  rblapack_normin = argv[3];
  rblapack_kd = argv[4];
  rblapack_ab = argv[5];
  rblapack_x = argv[6];
  rblapack_cnorm = argv[7];
  if (argc == 8) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  uplo = StringValueCStr(rblapack_uplo)[0];
  diag = StringValueCStr(rblapack_diag)[0];
  kd = NUM2INT(rblapack_kd);
  if (!NA_IsNArray(rblapack_x))
    rb_raise(rb_eArgError, "x (7th argument) must be NArray");
  if (NA_RANK(rblapack_x) != 1)
    rb_raise(rb_eArgError, "rank of x (7th argument) must be %d", 1);
  n = NA_SHAPE0(rblapack_x);
  if (NA_TYPE(rblapack_x) != NA_SCOMPLEX)
    rblapack_x = na_change_type(rblapack_x, NA_SCOMPLEX);
  x = NA_PTR_TYPE(rblapack_x, complex*);
  trans = StringValueCStr(rblapack_trans)[0];
  if (!NA_IsNArray(rblapack_ab))
    rb_raise(rb_eArgError, "ab (6th argument) must be NArray");
  if (NA_RANK(rblapack_ab) != 2)
    rb_raise(rb_eArgError, "rank of ab (6th argument) must be %d", 2);
  ldab = NA_SHAPE0(rblapack_ab);
  if (NA_SHAPE1(rblapack_ab) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of ab must be the same as shape 0 of x");
  if (NA_TYPE(rblapack_ab) != NA_SCOMPLEX)
    rblapack_ab = na_change_type(rblapack_ab, NA_SCOMPLEX);
  ab = NA_PTR_TYPE(rblapack_ab, complex*);
  normin = StringValueCStr(rblapack_normin)[0];
  if (!NA_IsNArray(rblapack_cnorm))
    rb_raise(rb_eArgError, "cnorm (8th argument) must be NArray");
  if (NA_RANK(rblapack_cnorm) != 1)
    rb_raise(rb_eArgError, "rank of cnorm (8th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_cnorm) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of cnorm must be the same as shape 0 of x");
  if (NA_TYPE(rblapack_cnorm) != NA_SFLOAT)
    rblapack_cnorm = na_change_type(rblapack_cnorm, NA_SFLOAT);
  cnorm = NA_PTR_TYPE(rblapack_cnorm, real*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_x_out__ = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  x_out__ = NA_PTR_TYPE(rblapack_x_out__, complex*);
  MEMCPY(x_out__, x, complex, NA_TOTAL(rblapack_x));
  rblapack_x = rblapack_x_out__;
  x = x_out__;
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_cnorm_out__ = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  cnorm_out__ = NA_PTR_TYPE(rblapack_cnorm_out__, real*);
  MEMCPY(cnorm_out__, cnorm, real, NA_TOTAL(rblapack_cnorm));
  rblapack_cnorm = rblapack_cnorm_out__;
  cnorm = cnorm_out__;

  clatbs_(&uplo, &trans, &diag, &normin, &n, &kd, ab, &ldab, x, &scale, cnorm, &info);

  rblapack_scale = rb_float_new((double)scale);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(4, rblapack_scale, rblapack_info, rblapack_x, rblapack_cnorm);
}

void
init_lapack_clatbs(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "clatbs", rblapack_clatbs, -1);
}
ruby-lapack-1.7.2/ext/ctgsen.c0000644000175000017500000005216012502221017016012 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID ctgsen_(integer* ijob, logical* wantq, logical* wantz, logical* select, integer* n, complex* a, integer* lda, complex* b, integer* ldb, complex* alpha, complex* beta, complex* q, integer* ldq, complex* z, integer* ldz, integer* m, real* pl, real* pr, real* dif, complex* work, integer* lwork, integer* iwork, integer* liwork, integer* info);


static VALUE
rblapack_ctgsen(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_ijob;
  integer ijob; 
  VALUE rblapack_wantq;
  logical wantq; 
  VALUE rblapack_wantz;
  logical wantz; 
  VALUE rblapack_select;
  logical *select; 
  VALUE rblapack_a;
  complex *a; 
  VALUE rblapack_b;
  complex *b; 
  VALUE rblapack_q;
  complex *q; 
  VALUE rblapack_z;
  complex *z; 
  VALUE rblapack_lwork;
  integer lwork; 
  VALUE rblapack_liwork;
  integer liwork; 
  VALUE rblapack_alpha;
  complex *alpha; 
  VALUE rblapack_beta;
  complex *beta; 
  VALUE rblapack_m;
  integer m; 
  VALUE rblapack_pl;
  real pl; 
  VALUE rblapack_pr;
  real pr; 
  VALUE rblapack_dif;
  real *dif; 
  VALUE rblapack_work;
  complex *work; 
  VALUE rblapack_iwork;
  integer *iwork; 
  VALUE rblapack_info;
  integer info; 
  VALUE rblapack_a_out__;
  complex *a_out__;
  VALUE rblapack_b_out__;
  complex *b_out__;
  VALUE rblapack_q_out__;
  complex *q_out__;
  VALUE rblapack_z_out__;
  complex *z_out__;

  integer n;
  integer lda;
  integer ldb;
  integer ldq;
  integer ldz;

  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  alpha, beta, m, pl, pr, dif, work, iwork, info, a, b, q, z = NumRu::Lapack.ctgsen( ijob, wantq, wantz, select, a, b, q, z, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE CTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO )\n\n*  Purpose\n*  =======\n*\n*  CTGSEN reorders the generalized Schur decomposition of a complex\n*  matrix pair (A, B) (in terms of an unitary equivalence trans-\n*  formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues\n*  appears in the leading diagonal blocks of the pair (A,B). The leading\n*  columns of Q and Z form unitary bases of the corresponding left and\n*  right eigenspaces (deflating subspaces). (A, B) must be in\n*  generalized Schur canonical form, that is, A and B are both upper\n*  triangular.\n*\n*  CTGSEN also computes the generalized eigenvalues\n*\n*           w(j)= ALPHA(j) / BETA(j)\n*\n*  of the reordered matrix pair (A, B).\n*\n*  Optionally, the routine computes estimates of reciprocal condition\n*  numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),\n*  (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)\n*  between the matrix pairs (A11, B11) and (A22,B22) that correspond to\n*  the selected cluster and the eigenvalues outside the cluster, resp.,\n*  and norms of \"projections\" onto left and right eigenspaces w.r.t.\n*  the selected cluster in the (1,1)-block.\n*\n*\n\n*  Arguments\n*  =========\n*\n*  IJOB    (input) integer\n*          Specifies whether condition numbers are required for the\n*          cluster of eigenvalues (PL and PR) or the deflating subspaces\n*          (Difu and Difl):\n*           =0: Only reorder w.r.t. SELECT. No extras.\n*           =1: Reciprocal of norms of \"projections\" onto left and right\n*               eigenspaces w.r.t. the selected cluster (PL and PR).\n*           =2: Upper bounds on Difu and Difl. F-norm-based estimate\n*               (DIF(1:2)).\n*           =3: Estimate of Difu and Difl. 1-norm-based estimate\n*               (DIF(1:2)).\n*               About 5 times as expensive as IJOB = 2.\n*           =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic\n*               version to get it all.\n*           =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)\n*\n*  WANTQ   (input) LOGICAL\n*          .TRUE. : update the left transformation matrix Q;\n*          .FALSE.: do not update Q.\n*\n*  WANTZ   (input) LOGICAL\n*          .TRUE. : update the right transformation matrix Z;\n*          .FALSE.: do not update Z.\n*\n*  SELECT  (input) LOGICAL array, dimension (N)\n*          SELECT specifies the eigenvalues in the selected cluster. To\n*          select an eigenvalue w(j), SELECT(j) must be set to\n*          .TRUE..\n*\n*  N       (input) INTEGER\n*          The order of the matrices A and B. N >= 0.\n*\n*  A       (input/output) COMPLEX array, dimension(LDA,N)\n*          On entry, the upper triangular matrix A, in generalized\n*          Schur canonical form.\n*          On exit, A is overwritten by the reordered matrix A.\n*\n*  LDA     (input) INTEGER\n*          The leading dimension of the array A. LDA >= max(1,N).\n*\n*  B       (input/output) COMPLEX array, dimension(LDB,N)\n*          On entry, the upper triangular matrix B, in generalized\n*          Schur canonical form.\n*          On exit, B is overwritten by the reordered matrix B.\n*\n*  LDB     (input) INTEGER\n*          The leading dimension of the array B. LDB >= max(1,N).\n*\n*  ALPHA   (output) COMPLEX array, dimension (N)\n*  BETA    (output) COMPLEX array, dimension (N)\n*          The diagonal elements of A and B, respectively,\n*          when the pair (A,B) has been reduced to generalized Schur\n*          form.  ALPHA(i)/BETA(i) i=1,...,N are the generalized\n*          eigenvalues.\n*\n*  Q       (input/output) COMPLEX array, dimension (LDQ,N)\n*          On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.\n*          On exit, Q has been postmultiplied by the left unitary\n*          transformation matrix which reorder (A, B); The leading M\n*          columns of Q form orthonormal bases for the specified pair of\n*          left eigenspaces (deflating subspaces).\n*          If WANTQ = .FALSE., Q is not referenced.\n*\n*  LDQ     (input) INTEGER\n*          The leading dimension of the array Q. LDQ >= 1.\n*          If WANTQ = .TRUE., LDQ >= N.\n*\n*  Z       (input/output) COMPLEX array, dimension (LDZ,N)\n*          On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.\n*          On exit, Z has been postmultiplied by the left unitary\n*          transformation matrix which reorder (A, B); The leading M\n*          columns of Z form orthonormal bases for the specified pair of\n*          left eigenspaces (deflating subspaces).\n*          If WANTZ = .FALSE., Z is not referenced.\n*\n*  LDZ     (input) INTEGER\n*          The leading dimension of the array Z. LDZ >= 1.\n*          If WANTZ = .TRUE., LDZ >= N.\n*\n*  M       (output) INTEGER\n*          The dimension of the specified pair of left and right\n*          eigenspaces, (deflating subspaces) 0 <= M <= N.\n*\n*  PL	   (output) REAL\n*  PR	   (output) REAL\n*          If IJOB = 1, 4 or 5, PL, PR are lower bounds on the\n*          reciprocal  of the norm of \"projections\" onto left and right\n*          eigenspace with respect to the selected cluster.\n*          0 < PL, PR <= 1.\n*          If M = 0 or M = N, PL = PR  = 1.\n*          If IJOB = 0, 2 or 3 PL, PR are not referenced.\n*\n*  DIF     (output) REAL array, dimension (2).\n*          If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.\n*          If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on\n*          Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based\n*          estimates of Difu and Difl, computed using reversed\n*          communication with CLACN2.\n*          If M = 0 or N, DIF(1:2) = F-norm([A, B]).\n*          If IJOB = 0 or 1, DIF is not referenced.\n*\n*  WORK    (workspace/output) COMPLEX 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 >=  1\n*          If IJOB = 1, 2 or 4, LWORK >=  2*M*(N-M)\n*          If IJOB = 3 or 5, LWORK >=  4*M*(N-M)\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*  IWORK   (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))\n*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.\n*\n*  LIWORK  (input) INTEGER\n*          The dimension of the array IWORK. LIWORK >= 1.\n*          If IJOB = 1, 2 or 4, LIWORK >=  N+2;\n*          If IJOB = 3 or 5, LIWORK >= MAX(N+2, 2*M*(N-M));\n*\n*          If LIWORK = -1, then a workspace query is assumed; the\n*          routine only calculates the optimal size of the IWORK array,\n*          returns this value as the first entry of the IWORK array, and\n*          no error message related to LIWORK 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*            =1: Reordering of (A, B) failed because the transformed\n*                matrix pair (A, B) would be too far from generalized\n*                Schur form; the problem is very ill-conditioned.\n*                (A, B) may have been partially reordered.\n*                If requested, 0 is returned in DIF(*), PL and PR.\n*\n*\n\n*  Further Details\n*  ===============\n*\n*  CTGSEN first collects the selected eigenvalues by computing unitary\n*  U and W that move them to the top left corner of (A, B). In other\n*  words, the selected eigenvalues are the eigenvalues of (A11, B11) in\n*\n*                U'*(A, B)*W = (A11 A12) (B11 B12) n1\n*                              ( 0  A22),( 0  B22) n2\n*                                n1  n2    n1  n2\n*\n*  where N = n1+n2 and U' means the conjugate transpose of U. The first\n*  n1 columns of U and W span the specified pair of left and right\n*  eigenspaces (deflating subspaces) of (A, B).\n*\n*  If (A, B) has been obtained from the generalized real Schur\n*  decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the\n*  reordered generalized Schur form of (C, D) is given by\n*\n*           (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',\n*\n*  and the first n1 columns of Q*U and Z*W span the corresponding\n*  deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).\n*\n*  Note that if the selected eigenvalue is sufficiently ill-conditioned,\n*  then its value may differ significantly from its value before\n*  reordering.\n*\n*  The reciprocal condition numbers of the left and right eigenspaces\n*  spanned by the first n1 columns of U and W (or Q*U and Z*W) may\n*  be returned in DIF(1:2), corresponding to Difu and Difl, resp.\n*\n*  The Difu and Difl are defined as:\n*\n*       Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )\n*  and\n*       Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],\n*\n*  where sigma-min(Zu) is the smallest singular value of the\n*  (2*n1*n2)-by-(2*n1*n2) matrix\n*\n*       Zu = [ kron(In2, A11)  -kron(A22', In1) ]\n*            [ kron(In2, B11)  -kron(B22', In1) ].\n*\n*  Here, Inx is the identity matrix of size nx and A22' is the\n*  transpose of A22. kron(X, Y) is the Kronecker product between\n*  the matrices X and Y.\n*\n*  When DIF(2) is small, small changes in (A, B) can cause large changes\n*  in the deflating subspace. An approximate (asymptotic) bound on the\n*  maximum angular error in the computed deflating subspaces is\n*\n*       EPS * norm((A, B)) / DIF(2),\n*\n*  where EPS is the machine precision.\n*\n*  The reciprocal norm of the projectors on the left and right\n*  eigenspaces associated with (A11, B11) may be returned in PL and PR.\n*  They are computed as follows. First we compute L and R so that\n*  P*(A, B)*Q is block diagonal, where\n*\n*       P = ( I -L ) n1           Q = ( I R ) n1\n*           ( 0  I ) n2    and        ( 0 I ) n2\n*             n1 n2                    n1 n2\n*\n*  and (L, R) is the solution to the generalized Sylvester equation\n*\n*       A11*R - L*A22 = -A12\n*       B11*R - L*B22 = -B12\n*\n*  Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).\n*  An approximate (asymptotic) bound on the average absolute error of\n*  the selected eigenvalues is\n*\n*       EPS * norm((A, B)) / PL.\n*\n*  There are also global error bounds which valid for perturbations up\n*  to a certain restriction:  A lower bound (x) on the smallest\n*  F-norm(E,F) for which an eigenvalue of (A11, B11) may move and\n*  coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),\n*  (i.e. (A + E, B + F), is\n*\n*   x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).\n*\n*  An approximate bound on x can be computed from DIF(1:2), PL and PR.\n*\n*  If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed\n*  (L', R') and unperturbed (L, R) left and right deflating subspaces\n*  associated with the selected cluster in the (1,1)-blocks can be\n*  bounded as\n*\n*   max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))\n*   max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))\n*\n*  See LAPACK User's Guide section 4.11 or the following references\n*  for more information.\n*\n*  Note that if the default method for computing the Frobenius-norm-\n*  based estimate DIF is not wanted (see CLATDF), then the parameter\n*  IDIFJB (see below) should be changed from 3 to 4 (routine CLATDF\n*  (IJOB = 2 will be used)). See CTGSYL for more details.\n*\n*  Based on contributions by\n*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,\n*     Umea University, S-901 87 Umea, Sweden.\n*\n*  References\n*  ==========\n*\n*  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the\n*      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in\n*      M.S. Moonen et al (eds), Linear Algebra for Large Scale and\n*      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.\n*\n*  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified\n*      Eigenvalues of a Regular Matrix Pair (A, B) and Condition\n*      Estimation: Theory, Algorithms and Software, Report\n*      UMINF - 94.04, Department of Computing Science, Umea University,\n*      S-901 87 Umea, Sweden, 1994. Also as LAPACK Working Note 87.\n*      To appear in Numerical Algorithms, 1996.\n*\n*  [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software\n*      for Solving the Generalized Sylvester Equation and Estimating the\n*      Separation between Regular Matrix Pairs, Report UMINF - 93.23,\n*      Department of Computing Science, Umea University, S-901 87 Umea,\n*      Sweden, December 1993, Revised April 1994, Also as LAPACK working\n*      Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,\n*      1996.\n*\n*  =====================================================================\n*\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  alpha, beta, m, pl, pr, dif, work, iwork, info, a, b, q, z = NumRu::Lapack.ctgsen( ijob, wantq, wantz, select, a, b, q, z, [:lwork => lwork, :liwork => liwork, :usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 8 && argc != 10)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 8)", argc);
  rblapack_ijob = argv[0];
  rblapack_wantq = argv[1];
  rblapack_wantz = argv[2];
  rblapack_select = argv[3];
  rblapack_a = argv[4];
  rblapack_b = argv[5];
  rblapack_q = argv[6];
  rblapack_z = argv[7];
  if (argc == 10) {
    rblapack_lwork = argv[8];
    rblapack_liwork = argv[9];
  } else if (rblapack_options != Qnil) {
    rblapack_lwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("lwork")));
    rblapack_liwork = rb_hash_aref(rblapack_options, ID2SYM(rb_intern("liwork")));
  } else {
    rblapack_lwork = Qnil;
    rblapack_liwork = Qnil;
  }

  ijob = NUM2INT(rblapack_ijob);
  wantz = (rblapack_wantz == Qtrue);
  if (!NA_IsNArray(rblapack_a))
    rb_raise(rb_eArgError, "a (5th argument) must be NArray");
  if (NA_RANK(rblapack_a) != 2)
    rb_raise(rb_eArgError, "rank of a (5th argument) must be %d", 2);
  lda = NA_SHAPE0(rblapack_a);
  n = NA_SHAPE1(rblapack_a);
  if (NA_TYPE(rblapack_a) != NA_SCOMPLEX)
    rblapack_a = na_change_type(rblapack_a, NA_SCOMPLEX);
  a = NA_PTR_TYPE(rblapack_a, complex*);
  if (!NA_IsNArray(rblapack_q))
    rb_raise(rb_eArgError, "q (7th argument) must be NArray");
  if (NA_RANK(rblapack_q) != 2)
    rb_raise(rb_eArgError, "rank of q (7th argument) must be %d", 2);
  ldq = NA_SHAPE0(rblapack_q);
  if (NA_SHAPE1(rblapack_q) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of q must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_q) != NA_SCOMPLEX)
    rblapack_q = na_change_type(rblapack_q, NA_SCOMPLEX);
  q = NA_PTR_TYPE(rblapack_q, complex*);
  wantq = (rblapack_wantq == Qtrue);
  if (!NA_IsNArray(rblapack_b))
    rb_raise(rb_eArgError, "b (6th argument) must be NArray");
  if (NA_RANK(rblapack_b) != 2)
    rb_raise(rb_eArgError, "rank of b (6th argument) must be %d", 2);
  ldb = NA_SHAPE0(rblapack_b);
  if (NA_SHAPE1(rblapack_b) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of b must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_b) != NA_SCOMPLEX)
    rblapack_b = na_change_type(rblapack_b, NA_SCOMPLEX);
  b = NA_PTR_TYPE(rblapack_b, complex*);
  if (!NA_IsNArray(rblapack_select))
    rb_raise(rb_eArgError, "select (4th argument) must be NArray");
  if (NA_RANK(rblapack_select) != 1)
    rb_raise(rb_eArgError, "rank of select (4th argument) must be %d", 1);
  if (NA_SHAPE0(rblapack_select) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of select must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_select) != NA_LINT)
    rblapack_select = na_change_type(rblapack_select, NA_LINT);
  select = NA_PTR_TYPE(rblapack_select, logical*);
  if (!NA_IsNArray(rblapack_z))
    rb_raise(rb_eArgError, "z (8th argument) must be NArray");
  if (NA_RANK(rblapack_z) != 2)
    rb_raise(rb_eArgError, "rank of z (8th argument) must be %d", 2);
  ldz = NA_SHAPE0(rblapack_z);
  if (NA_SHAPE1(rblapack_z) != n)
    rb_raise(rb_eRuntimeError, "shape 1 of z must be the same as shape 1 of a");
  if (NA_TYPE(rblapack_z) != NA_SCOMPLEX)
    rblapack_z = na_change_type(rblapack_z, NA_SCOMPLEX);
  z = NA_PTR_TYPE(rblapack_z, complex*);
  if (rblapack_liwork == Qnil)
    liwork = (ijob==1||ijob==2||ijob==4) ? n+2 : (ijob==3||ijob==5) ? 2*m*(n-m) : 0;
  else {
    liwork = NUM2INT(rblapack_liwork);
  }
  if (rblapack_lwork == Qnil)
    lwork = (ijob==1||ijob==2||ijob==4) ? 2*m*(n-m) : (ijob==3||ijob==5) ? 4*m*(n-m) : 0;
  else {
    lwork = NUM2INT(rblapack_lwork);
  }
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_alpha = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  alpha = NA_PTR_TYPE(rblapack_alpha, complex*);
  {
    na_shape_t shape[1];
    shape[0] = n;
    rblapack_beta = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  beta = NA_PTR_TYPE(rblapack_beta, complex*);
  {
    na_shape_t shape[1];
    shape[0] = 2;
    rblapack_dif = na_make_object(NA_SFLOAT, 1, shape, cNArray);
  }
  dif = NA_PTR_TYPE(rblapack_dif, real*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,lwork);
    rblapack_work = na_make_object(NA_SCOMPLEX, 1, shape, cNArray);
  }
  work = NA_PTR_TYPE(rblapack_work, complex*);
  {
    na_shape_t shape[1];
    shape[0] = MAX(1,liwork);
    rblapack_iwork = na_make_object(NA_LINT, 1, shape, cNArray);
  }
  iwork = NA_PTR_TYPE(rblapack_iwork, integer*);
  {
    na_shape_t shape[2];
    shape[0] = lda;
    shape[1] = n;
    rblapack_a_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  a_out__ = NA_PTR_TYPE(rblapack_a_out__, complex*);
  MEMCPY(a_out__, a, complex, NA_TOTAL(rblapack_a));
  rblapack_a = rblapack_a_out__;
  a = a_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldb;
    shape[1] = n;
    rblapack_b_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  b_out__ = NA_PTR_TYPE(rblapack_b_out__, complex*);
  MEMCPY(b_out__, b, complex, NA_TOTAL(rblapack_b));
  rblapack_b = rblapack_b_out__;
  b = b_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldq;
    shape[1] = n;
    rblapack_q_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  q_out__ = NA_PTR_TYPE(rblapack_q_out__, complex*);
  MEMCPY(q_out__, q, complex, NA_TOTAL(rblapack_q));
  rblapack_q = rblapack_q_out__;
  q = q_out__;
  {
    na_shape_t shape[2];
    shape[0] = ldz;
    shape[1] = n;
    rblapack_z_out__ = na_make_object(NA_SCOMPLEX, 2, shape, cNArray);
  }
  z_out__ = NA_PTR_TYPE(rblapack_z_out__, complex*);
  MEMCPY(z_out__, z, complex, NA_TOTAL(rblapack_z));
  rblapack_z = rblapack_z_out__;
  z = z_out__;

  ctgsen_(&ijob, &wantq, &wantz, select, &n, a, &lda, b, &ldb, alpha, beta, q, &ldq, z, &ldz, &m, &pl, &pr, dif, work, &lwork, iwork, &liwork, &info);

  rblapack_m = INT2NUM(m);
  rblapack_pl = rb_float_new((double)pl);
  rblapack_pr = rb_float_new((double)pr);
  rblapack_info = INT2NUM(info);
  return rb_ary_new3(13, rblapack_alpha, rblapack_beta, rblapack_m, rblapack_pl, rblapack_pr, rblapack_dif, rblapack_work, rblapack_iwork, rblapack_info, rblapack_a, rblapack_b, rblapack_q, rblapack_z);
}

void
init_lapack_ctgsen(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "ctgsen", rblapack_ctgsen, -1);
}
ruby-lapack-1.7.2/ext/dla_lin_berr.c0000644000175000017500000001077512502221023017146 0ustar  uwabamiuwabami#include "rb_lapack.h"

extern VOID dla_lin_berr_(integer* n, integer* nz, integer* nrhs, doublereal* res, doublereal* ayb, doublereal* berr);


static VALUE
rblapack_dla_lin_berr(int argc, VALUE *argv, VALUE self){
  VALUE rblapack_nz;
  integer nz; 
  VALUE rblapack_res;
  doublereal *res; 
  VALUE rblapack_ayb;
  doublereal *ayb; 
  VALUE rblapack_berr;
  doublereal *berr; 

  integer n;
  integer nrhs;

  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  berr = NumRu::Lapack.dla_lin_berr( nz, res, ayb, [:usage => usage, :help => help])\n\n\nFORTRAN MANUAL\n      SUBROUTINE DLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR )\n\n*  Purpose\n*  =======\n*\n*     DLA_LIN_BERR computes component-wise relative backward error from\n*     the formula\n*         max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )\n*     where abs(Z) is the component-wise absolute value of the matrix\n*     or vector Z.\n*\n\n*  Arguments\n*  ==========\n*\n*     N       (input) INTEGER\n*     The number of linear equations, i.e., the order of the\n*     matrix A.  N >= 0.\n*\n*     NZ      (input) INTEGER\n*     We add (NZ+1)*SLAMCH( 'Safe minimum' ) to R(i) in the numerator to\n*     guard against spuriously zero residuals. Default value is N.\n*\n*     NRHS    (input) INTEGER\n*     The number of right hand sides, i.e., the number of columns\n*     of the matrices AYB, RES, and BERR.  NRHS >= 0.\n*\n*     RES     (input) DOUBLE PRECISION array, dimension (N,NRHS)\n*     The residual matrix, i.e., the matrix R in the relative backward\n*     error formula above.\n*\n*     AYB     (input) DOUBLE PRECISION array, dimension (N, NRHS)\n*     The denominator in the relative backward error formula above, i.e.,\n*     the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B\n*     are from iterative refinement (see dla_gerfsx_extended.f).\n*     \n*     BERR    (output) DOUBLE PRECISION array, dimension (NRHS)\n*     The component-wise relative backward error from the formula above.\n*\n\n*  =====================================================================\n*\n*     .. Local Scalars ..\n      DOUBLE PRECISION   TMP\n      INTEGER            I, J\n*     ..\n*     .. Intrinsic Functions ..\n      INTRINSIC          ABS, MAX\n*     ..\n*     .. External Functions ..\n      EXTERNAL           DLAMCH\n      DOUBLE PRECISION   DLAMCH\n      DOUBLE PRECISION   SAFE1\n*     ..\n\n");
      return Qnil;
    }
    if (rb_hash_aref(rblapack_options, sUsage) == Qtrue) {
      printf("%s\n", "USAGE:\n  berr = NumRu::Lapack.dla_lin_berr( nz, res, ayb, [:usage => usage, :help => help])\n");
      return Qnil;
    } 
  } else
    rblapack_options = Qnil;
  if (argc != 3 && argc != 3)
    rb_raise(rb_eArgError,"wrong number of arguments (%d for 3)", argc);
  rblapack_nz = argv[0];
  rblapack_res = argv[1];
  rblapack_ayb = argv[2];
  if (argc == 3) {
  } else if (rblapack_options != Qnil) {
  } else {
  }

  nz = NUM2INT(rblapack_nz);
  if (!NA_IsNArray(rblapack_ayb))
    rb_raise(rb_eArgError, "ayb (3th argument) must be NArray");
  if (NA_RANK(rblapack_ayb) != 2)
    rb_raise(rb_eArgError, "rank of ayb (3th argument) must be %d", 2);
  n = NA_SHAPE0(rblapack_ayb);
  nrhs = NA_SHAPE1(rblapack_ayb);
  if (NA_TYPE(rblapack_ayb) != NA_DFLOAT)
    rblapack_ayb = na_change_type(rblapack_ayb, NA_DFLOAT);
  ayb = NA_PTR_TYPE(rblapack_ayb, doublereal*);
  if (!NA_IsNArray(rblapack_res))
    rb_raise(rb_eArgError, "res (2th argument) must be NArray");
  if (NA_RANK(rblapack_res) != 2)
    rb_raise(rb_eArgError, "rank of res (2th argument) must be %d", 2);
  if (NA_SHAPE0(rblapack_res) != n)
    rb_raise(rb_eRuntimeError, "shape 0 of res must be the same as shape 0 of ayb");
  if (NA_SHAPE1(rblapack_res) != nrhs)
    rb_raise(rb_eRuntimeError, "shape 1 of res must be the same as shape 1 of ayb");
  if (NA_TYPE(rblapack_res) != NA_DFLOAT)
    rblapack_res = na_change_type(rblapack_res, NA_DFLOAT);
  res = NA_PTR_TYPE(rblapack_res, doublereal*);
  {
    na_shape_t shape[1];
    shape[0] = nrhs;
    rblapack_berr = na_make_object(NA_DFLOAT, 1, shape, cNArray);
  }
  berr = NA_PTR_TYPE(rblapack_berr, doublereal*);

  dla_lin_berr_(&n, &nz, &nrhs, res, ayb, berr);

  return rblapack_berr;
}

void
init_lapack_dla_lin_berr(VALUE mLapack, VALUE sH, VALUE sU, VALUE zero){
  sHelp = sH;
  sUsage = sU;
  rblapack_ZERO = zero;

  rb_define_module_function(mLapack, "dla_lin_berr", rblapack_dla_lin_berr, -1);
}
ruby-lapack-1.7.2/README.rdoc0000644000175000017500000000463112502223525015377 0ustar  uwabamiuwabami= What's Ruby-LAPACK

Ruby-LAPACK is a Ruby wrapper of LAPACK.

= Requires

    * Ruby   (http://www.ruby-lang.org/)
    * LAPACK (http://www.netlib.org/lapack/)
    * NArray (http://narray.rubyforge.org/index.html.en)


= Install

== with gem
 # gem install ruby-lapack

== build from source
 % rake
 % rake tests
 % sudo rake install


= Usage

You need require numru/lapack to use Ruby-lapack
 require 'numru/lapack'

Each subroutine/function is defined as module function of NumRu::Lapack.
 returns = NumRu::Lapack.method_name(args)

    * Arguments
    * The arguments of each method are the arguments of the corresponding subroutine/function without arguments for output, workspace and dimension size of array. Returns
      The methods return the arguments for output of the correspoing subroutine/function. 

In the arguments and returns, array (Matrix) is NArray object. The order of Matrix dimensions is the same as the notation of mathematics: x_ij => x[i-1,j-1].
If you call methods with the argument of :help=>true, or :usage=>true, help or usage message will be printed, respectively.
 NumRu::Lapack.method_name(:help => true)
 NumRu::Lapack.method_name(:usage => true)


= Documents

Documents for individual methods are "doc" directory in the source


= Example

DSYEVR: Compultes selected eigenvalues, and optinally, eigenvectors of a real symmetric matrix.
The following script calculats the leading eigenvalue and corresponding eigenvector of the matrix (x_11 = 1, x_12 = x_21 = 2, x_22 = 3).
Ruby method is NumRu::Lapack.dsyevr.

jobz = "V"
range = "I"
uplo = "U"
a = NArray[[1,2],[2,3]]
vl =  vu = 0 # not be used in this example
il = 1
iu = 2
abstol = 0.0

m, w, z, isuppz, work, iwork, info, a = NumRu::Lapack.dsyevr(jobz, range, uplo, a, vl, vu, il, iu, abstol)

The corresponding FORTRAN subroutine is DSYEVR.

SUBROUTINE DSYEVR(JOBZ, RANGE, UPLO, N, A, LDA, VL, IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, LIWORK, INFO)
# JOBZ(input), RANGE(input), UPLO(input)
# N(input), A(input/output), LDA(input)
# VL(input), IL(input), IU(input), ABSTOL(input)
# M(output), W(output), Z(output), LDZ(input), ISUPPZ(output)
# WORK(workspace/output), LWORK(input), IWORK(workspace/output), LIWORK(input)
# INFO(output)

N is order of the matrix A, LDA is size of the leading dimension of the array A, and LDZ is size of the leading dimension of the array Z, LWORK is size of the array WORK, and LIWORK is size of the array IWORK.